diff --git a/AGENTS.md b/AGENTS.md index 9a2c5ada..76260797 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -7,7 +7,7 @@ A minimal (zero-knowledge Virtual Machine, which is actually not ZK in the real - `doc/leanvm/` is the LaTeX project describing the machine ISA and the snark that proves it. Its root is `doc/leanvm/main.tex`; build it with `cd doc/leanvm && latexmk -pdf main.tex`, which writes to the gitignored `doc/leanvm/.build/`. Sections live in `doc/leanvm/body/`, numbered `01`..`10` plus the lettered annexes `a` (ring switching), `b` (the PCS), and `c` (Flock), and every symbol is defined once in `doc/leanvm/preamble/macros.tex`. If latexmk fails oddly (a bibtex error, or a missing `main.log`) right after inputs are renamed or `refs.bib` is edited, remove `doc/leanvm/.build` and rerun; it has not reproduced on unchanged inputs. **Drafting one section:** each section file carries a `% !TeX root` comment pointing at its generated driver in `doc/leanvm/drafts/`, so the LaTeX build key (`F5`, or the extension's `cmd+alt+b`) compiles only that section, numbered as in the full document and with cross-references and citations resolved against `.build/main.aux`; in `main.tex` the same key builds everything. Run `doc/leanvm/make-drafts.sh` after adding, renaming or renumbering a section. - `doc/xmss/` is the standalone specification of the concrete XMSS instance implemented by `crates/xmss`. - `doc/sphincs/` is the standalone specification of the concrete SPHINCS+ instance we would use instead of XMSS where statelessness matters; its root is `doc/sphincs/main.tex`, built the same way as `doc/xmss`, and implemented by `crates/sphincs`. It shares XMSS's hash function, tweakable hash and target-sum code, so an aggregator implements one primitive. -- `formal/xmss/` is a Lean 4 proof (over VCVio) of that instance's classical random-oracle security, `xmss_has_127_bits_of_classical_security`. `XmssSecurity/Statement.lean` is the only module a reviewer has to read: the concrete parameters, the byte layout of every hash input, the three algorithms, the game, and the claim. `lake exe cache get` once, then `lake build`. SPHINCS has no formalization; its security section is a target, not a theorem. +- `formal/xmss/` is a Lean 4 proof (over VCVio) of that instance's classical random-oracle security, `xmss_has_127_bits_of_classical_security`, and `formal/sphincs/` states the same kind of claim for the SPHINCS instance at 120 bits, with no proof yet. In both, `*/Statement.lean` is the only module a reviewer has to read: the concrete parameters, the byte layout of every hash input, the three algorithms, the game, and the claim. `lake exe cache get` once, then `lake build`. - The one hash function is BLAKE2s, in `primitives::hash`: scalar, streaming, keyed, and a lane-transposed batched form for the PCS Merkle tree. The VM proves one compression per opcode, and BLAKE2s takes the byte counter and final-block flag as ordinary compression inputs, so a single opcode is a complete hash for any length, with no tree structure to reproduce in-circuit. - `crates/lean_compiler/zkDSL.md` documents the (pythonic) zkDSL (that compiles to the ISA that our VM runs, and that our snark proves). diff --git a/doc/sphincs/main.tex b/doc/sphincs/main.tex index 4f825a41..6f9a2253 100644 --- a/doc/sphincs/main.tex +++ b/doc/sphincs/main.tex @@ -26,6 +26,7 @@ \newcommand{\Sig}{\mathsf{Sig}} \newcommand{\Ver}{\mathsf{Ver}} \newcommand{\SIG}{\mathsf{SIG}} +\newcommand{\Forge}{\mathsf{Forge}} \newcommand{\Chain}{\mathsf{Chain}} \newcommand{\hash}{\mathsf{H}} \newcommand{\LE}{\mathsf{LE}} @@ -74,7 +75,7 @@ \item \textbf{signature: 4924 bytes}. \item \textbf{497 hashes per verification}. \item signing costs 190K hashes with 1024 bytes of cached signer state, or 1.55M without. - \item \textbf{key generation costs 1.38M hashes}. + \item \textbf{key generation costs 1.38M hashes}, which is the one tree of layer $0$ and nothing else. \end{itemize} \end{abstract} @@ -436,10 +437,10 @@ \section{Security} \subsection{Classical security} \begin{definition}[Strong unforgeability in the ROM] -Let $\SIG=(\Gen,\Sig,\Ver)$ be a signature scheme whose algorithms use a hash function $\hash:\bits{*}\to\bits{256}$. Consider the following game between a signer and an adversary $\mathcal A$ (an arbitrary probabilistic algorithm with unbounded running time and memory), with $\hash$ sampled as a random oracle, that both signer and adversary can query. The signer first runs $(\pk,\sk)\gets\Gen$ and gives $\pk$ to $\mathcal A$. The adversary may then adaptively take any of the following actions: +Let $\SIG=(\Gen,\Sig,\Ver)$ be a signature scheme whose algorithms use a hash function $\hash:\bits{*}\to\bits{256}$. Consider the following game between a signer and an adversary $\mathcal A$ (an arbitrary probabilistic algorithm with unbounded running time and memory), with $\hash$ sampled as a random oracle that both may query. The signer runs $(\pk,\sk)\gets\Gen$ and gives $\pk$ to $\mathcal A$, which may then adaptively take any of the following actions: \begin{enumerate}[leftmargin=2em] \item Query the random oracle on any input and receive its 256-bit output. - \item Submit a message $m\in\bits{\lmsg}$ and receive $\sigma\gets\Sig(\sk,m)$ from the signer, which may be $\bot$. It may do so at most $\qs$ times, on any messages, the same one included: $\Sig$ keeps no state, so nothing here is used up. + \item Submit a message $m\in\bits{\lmsg}$ and receive $\sigma\gets\Sig(\sk,m)$ from the signer, which may be $\bot$. It may do so at most $\qs$ times. \item Terminate with a claimed forgery $(m^*,\sigma^*)$. \end{enumerate} The adversary wins if $\Ver(\pk,m^*,\sigma^*)=1$ and the signer did not return $\sigma^*$ in response to a signing query for $m^*$, meaning: @@ -447,14 +448,13 @@ \subsection{Classical security} \item if the adversary never queried a signature for $m^*$; \item or it did, but no answer it received was $\sigma^*$. \end{itemize} - -Call $\mathcal A$ $q$-bounded if the experiment makes at most $q$ random-oracle queries on every execution, counting those of key generation, signing, and the final verification of the claimed forgery. We say that $\SIG$ has $x$ bits of classical strong unforgeability in the ROM at $\qs$ signatures if every $q\geq1$ and every $q$-bounded $\mathcal A$ satisfy +Let $\Forge_{\SIG}(\qs,q)$ be the maximum winning probability of any adversary for which the total number of random-oracle queries made in the experiment, including during key generation, signing, and the final verification of the claimed forgery, is at most $q$ on every execution path; it is $0$ below what key generation and one verification already cost. An adversary that spends all $\qs$ signatures needs $q$ past $2^{58}$, the attempt caps bounding the loops, so that is where the claim is read. We say that $\SIG$ has $x$ bits of classical strong unforgeability in the ROM at $\qs$ signatures if \[ - \Pr[\mathcal A\text{ wins}]\leq\frac{q}{2^{x}}. + \max_{q\geq1}\frac{\Forge_{\SIG}(\qs,q)}{q}\leq 2^{-x}. \] \end{definition} -TODO prove 127 bits of classical strong unforgeability in the ROM at $\qs=2^{24}$ signatures. +That game, with the parameters and the algorithms above, is written out in Lean4 over the VCVio framework~\cite{VCVio} in \texttt{./formal/sphincs/SphincsSecurity/Statement.lean}, which states $x=120$ at $\qs=2^{24}$: the eight bits below $n$ are what a proof may spend on union bounds and constants. Nothing proves it yet. \subsection{Quantum security} \label{sec:quantum} diff --git a/formal/sphincs/.gitignore b/formal/sphincs/.gitignore new file mode 100644 index 00000000..4080d07d --- /dev/null +++ b/formal/sphincs/.gitignore @@ -0,0 +1 @@ +/.lake/ diff --git a/formal/sphincs/README.md b/formal/sphincs/README.md new file mode 100644 index 00000000..57fea66e --- /dev/null +++ b/formal/sphincs/README.md @@ -0,0 +1,885 @@ +# SPHINCS security statement + +The chain-start and private structural risks now share the budget-dependent rate `1 / (2^128 - q)`. `OtsProbeStartHistoryRate.lean` bounds chain-start completion against the surviving secret-table mass. `OtsProbeStartAdaptiveRate.lean` transports this estimate through the actual adaptive history and completion filter for every budget below `2^128`. `OtsProbeInitializedRate.lean` combines the two hit sums within one expected OTS query count, without adding their separate worst-case counts. Its sampled native direct-risk bound is valid for `q < 2^128`, including the full 127-bit query range. `OtsProbeNativeRateBound.lean` carries the rate into the established rejection/finalization and residual-opening bounds for `q ≤ 2^126`, where the existing erasure estimate applies, and proves that this OTS contribution is at most the earlier direct charge. `SecurityQueryRateEndpoint.lean` connects it to the original SUF experiment with the existing structural, FTS, message and forest terms. The joint collision/opening estimate and the remaining estimates above `2^126` queries still need work; 127-bit SUF remains unproved. + +The private structural-probe risk now keeps its history-dependent guessing rate. `OtsProbePrivateHistoryRate.lean` proves that a compatible record with `m` excluded digests has guessing rate at most `1 / (2^128 - m)`, retains this rate inside the sum over records, and derives budget caps from it. `OtsProbePrivateWeightedRisk.lean` transports the estimate to the actual resolved private-probe event and sums the reachable target/ordinal cases against the existing adaptive structural-probe charge. `OtsProbePrivateWeightedGame.lean` connects this sampled private-hit sum to the original experiment's expected OTS query count, with factor `1 / (2^128 - q)` for every `q < 2^128`; the original whole-experiment query bound gives the further cap `q / (2^128 - q)`. This extends the private component through `q = 2^127` and recovers the previous `4/3 * 2^-128` rate at `q = 2^126`. Its decomposition theorem identifies this sum as the private component of the established native direct risk. The combined native direct-risk bound above now includes the chain-start component; the joint collision/opening probability estimate remains open for the 127-bit endpoint. A position settled in the honest cache can still hide its value from the adversary, so settled status alone does not remove its secret-guessing charge. No 127-bit SUF theorem is claimed. + +The early-query collision residual now retains the forged verifier's actual inputs. `SettledCollisionViewedTrace.lean` and `SettledCollisionViewedProjection.lean` couple the settled-collision monitor to the full original trace and to the complete monitored experiment, preserving the forgery, signing history, verifier view, verdict, cache and monitor history. `SettledCollisionViewedTerminal.lean` restricts the residual collision input to the intersection of the verifier's queried inputs with those first queried before their position was settled. It also retains successful verification and its cache replay, and excludes runs where the settled-collision monitor triggered. The encoding and opening witnesses keep their original predicates. `SettledCollisionViewedGame.lean` carries the resulting primitive-event split through independent secret sampling. `SecuritySettledCollisionEndpoint.lean` bounds the original forgery probability by the settled-query charge times `2^-128`, the precise remaining primitive-event probability, and the existing message and forest terms for `q ≤ 2^126`. The remaining event still needs a joint probability bound; this refinement alone does not lower the complete numerical bound or prove 127 bits. + +`SettledCollisionQuery.lean` bounds a fresh query's collision with an already settled honest value by one unit of `2^-128`, using uniqueness of the input's structural position. `SettledCollisionMonitor.lean` lifts this to arbitrary adaptive computations, preserves their original random-oracle execution exactly, and records inputs first queried before their position was settled. `SettledCollisionSupport.lean` splits collisions on any terminal selection of inputs into a detected settled-value collision or a collision on those recorded inputs. `SettledCollisionGame.lean` connects the monitor to the original sampled SUF experiment, including key generation, signing and verification, and bounds its hit probability by the expected eligible-query charge times `2^-128`, at most `q / 2^128` for every whole-experiment budget `q`. Its first sampled residual permits any recorded input; the viewed monitor above preserves the narrower verifier-input selection. The full primitive estimate remains `10/3`, and the 127-bit theorem remains open. + +`VerifierStructuralCollision.lean` strengthens the winning-forgery classification: its structural-collision branch requires a colliding input actually queried by the successful forged verification. The event can be evaluated from the final cache, independently of the chosen compatible answer function. `RetainedCollisionCache.lean` keeps the verifier inputs and settled honest inputs, proves that every settled position survives, and identifies collisions in this proof-only cache exactly with collisions on the retained inputs. `RetainedForgeryClassify.lean` carries this refinement through every hypertree layer and FTS recovery while preserving the original signing-log and opening predicates. `VerifierPrimitiveTerminal.lean` packages the resulting primitive event and proves that it implies the previous joint primitive event. `SecurityVerifierPrimitiveEndpoint.lean` reduces the original forgery probability to this more precise event plus the proved message and forest terms. Its current numerical primitive bound is still inherited from the previous `10/3` estimate; the joint probability analysis needed for 127 bits remains open. + +The next target is 127 bits. The cache-dependent forest bound now reaches the original sampled experiment for every `q ≤ 2^127`: `probEvent_sampled_honest_leak_le_weighted` bounds the honest proper forest-leak event by `(2q + 1)` times the weighted source-configuration sum. The source weight is `1 / (2^128 - (q + 2^32))`, including the digest-attempt allowance. `FewTimeWeightedTargetPotential.lean` and `FewTimeWeightedTargetBound.lean` carry this weight through the existing target monitor; `FewTimeWeightedTargetUnion.lean` and `FewTimeWeightedHonestLeak.lean` connect it to both fresh and cached verifier targets, with the original source-overlap exclusions and independently sampled secrets. + +`FewTimeWeightedTargetCount.lean` identifies the configuration sum with a parameterized forest-pattern count and connects it to the exact integer certificate method. `FewTimeOccupancyCount.lean` proves that, for `q ≤ 2^126`, the forest contribution improves from `19q / 2^133` to `23q / 2^134`. `SecurityOccupancyEndpoint.lean` carries this improvement into the full original forgery bound with the native query charge. The joint primitive bound still has a worst-case charge of `10/3` and still requires `q ≤ 2^126`; reaching the 127-bit slope requires tighter joint accounting and sufficient numerical bounds across the larger query range. No 127-bit SUF theorem is claimed. + +`FewTimeWeightedOriginPotential.lean`, `FewTimeWeightedOriginInvariant.lean` and `FewTimeWeightedOriginAdaptive.lean` provide the weighted origin-monitor induction. `FewTimeWeightedOriginRace.lean` proves the source-coefficient identity and finiteness of the reuse weight through `q = 2^127`, using the actual signer bounds from `FewTimeParametricRace.lean` and `FewTimeParametricSignerRace.lean`. `OtsProbeNativeDirectBound.lean` and `JointNativeQueryCharge.lean` supply the direct OTS charge without the unused root-match allowance. The scheme, monitor transitions and SUF game are unchanged. + +The public theorem `sphincs_has_126_bits_of_classical_security` proves `SphincsSecurity126Statement`: every classical adaptive adversary with a nonzero whole-experiment hash-query budget `q` has strong-forgery probability at most `q / 2^126`, with at most `2^24` signing requests per key pair. The scheme, SUF game, independently sampled secrets and classical random-oracle model are unchanged. The earlier 125-bit and 120-bit theorems remain available. + +`OtsProbeEnsuredExecution.lean` proves that adding ensured-coordinate bookkeeping preserves raw execution up to that bookkeeping and preserves rejection/finalization probability. `OtsProbeNativeRetainedProjection.lean` erases native query histories and the retained root without changing this probability, then applies the existing chronological winning-verifier-probe theorem. `Security126Completion.lean` projects the original residual-forgery event into this native failure experiment and applies its refined reserve bound plus `q / 2^216`. This closes coverage directly through native failure, so the endpoint needs no separate final-root match event. The existing numerical endpoint assembles the full 126-bit claim. The development notes below record earlier milestones and superseded obligations. + +`OtsProbeNativeAfterRootAllowance.lean` identifies the expected native history charges after key generation with the full retained computation's start and missing structural allowances. `OtsProbeNativeAfterRootRisk.lean` proves that initialized key generation has zero terminal failure risk and carries the existing rejection and finalization estimate into the same charge, retaining failed branches. `OtsProbeNativeTerminalReserve.lean` averages this estimate and combines it with the actual final-root history-match event inside the refined reserve plus `q / 2^216`. `OtsProbeNativeTerminalExperiment.lean` identifies the risk with an explicit Boolean native rejection/finalization experiment. Its theorem `probEvent_sampledNativeTerminalFailure_add_rootMatch_le_refinedReserve` uses the original game query bound for `q ≤ 2^126`, with all structural positions ensured and non-top layer roots in the root event. The remaining endpoint must project the original residual-forgery event into these bounded native events, preserving their hidden-root and source-exclusion conditions. The public theorem is still 125 bits; the 126-bit theorem remains incomplete. + +`OtsProbeLiveResolvedBudget.lean` defines query bounds along supported resolved executions, stopping at incomplete contexts, and proves their monotonicity and composition with syntactically bounded prefixes. `OtsProbeNativeLiveBudget.lean` derives the probe bound for the full native retained computation directly from the original `HasHashQueryBound`, using the actual signer coupling and including key generation. `OtsProbeLiveStartAllowanceCounting.lean` and `OtsProbeLivePrivateAllowanceCounting.lean` replace the stronger syntactic premises of the finite allowance identities with these supported bounds. `OtsProbeNativeLiveAllowanceReserve.lean` therefore bounds the native missing start and structural allowances by the initialized direct risk under the original game budget. Its sampled theorem combines those allowances with the actual root-match event within the refined reserve. Connecting the native rejection and finalization estimates to this combined allowance bound, and proving complete residual-forgery coverage, remain necessary for 126 bits. The public theorem remains 125 bits. + +`OtsProbeNativeSupportedRootProjection.lean` replaces the syntactic outer-query premise of the successful final-root history-match projection with a bound on supported histories. The original `HasHashQueryBound` supplies that bound after actual key generation, so the native event projects into the finite initialized charged-root cut sum without an extra adversary assumption. `OtsProbeNativeSupportedRootReserve.lean` averages over all secret and parameter samplers and proves `sampledNativeDirectRisk_add_finalRootMatch_le_refinedReserve`: the existing direct-probe risk and the actual final-root history-match event share the same refined reserve. The root event retains its hidden-root and unknown-source-exclusion conditions. The direct allowance sums still need their supported-count connection, and complete residual-forgery coverage remains open. The public theorem is still 125 bits, and the 126-bit proof remains incomplete. + +`OtsProbeNativeSupportedBudget.lean` transfers the original game query budget to every supported native query history after key generation, using the coupling to the expanded concrete signer. It includes rejected histories and does not assume a bound over impossible abstract signing replies. `OtsProbeNativeTraceSafety.lean` tracks pending candidates and remaining fuel through native execution. At initial fuel `q + 1`, `HasHashQueryBound` and `q ≤ 2^126` prove both safety guards of `canonicalGuessCharge` at every reached query. `OtsProbeNativeSupportedAllowances.lean` removes the extra outer-query-bound premise from the `q / 2^216` materialized allowance estimate, proves exact decomposition of the full native history charge, and bounds that charge by its missing start and structural components plus the encoding-erasure term. The remaining connections include replacing syntactic query-bound premises in the direct and root allowance sums with supported execution bounds, and proving that the resulting bounded events cover every residual forgery. The 126-bit theorem is still incomplete; the public theorem remains 125 bits. + +`OtsProbeStartAllowance.lean` and `OtsProbeStartAllowanceCounting.lean` identify the full unresolved-chain-start allowance with the sum of actual numbered native probe-hit probabilities. Their composition and hash-handler lemmas lift this identity through adaptive native outer execution in `OtsProbeNativeStartCharge.lean`. The combined chain-start and missing structural allowances of the initialized retained computation are bounded by `initializedNativeDirectRisk`, under an explicit syntactic probe bound. `OtsProbeNativeCandidateComponents.lean` splits the candidate failure allowance exactly into those two missing-value components and a materialized component. `OtsProbeNativeMaterializedAllowance.lean` bounds the accumulated materialized component after actual key generation by `q / 2^216`, using the chain-publication failure event and an explicit hash-query bound. The safe-query candidate charge has the same exact decomposition. Deriving the required bounds and safe-query guards from supported executions of the security game, then proving full residual-forgery coverage and assembling the endpoint, remain necessary for 126 bits. The public theorem remains 125 bits. + +The 126-bit proof remains incomplete. `OtsProbeRootMaterializationExecution.lean`, `OtsProbeRootMaterializationHash.lean`, and `OtsProbeRootMaterializationSigner.lean` preserve the distinction between roots copied into native state and roots stored only in the auxiliary table. `OtsProbeRootMaterializationChronological.lean` proves that every auxiliary-known layer root has been copied into state throughout the original chronological game, including key generation, signing, adversarial hash queries, verification, and supported query histories from the initialized context. `OtsProbeMaterializedRootReserve.lean` consequently equates the preload-invariant encoding-root occurrence charge with the existing charge on these executions and places it in the same joint reserve. + +`OtsProbeNativeRootHistoryObserver.lean` accumulates the actual native root guesses while retaining completion guards and terminal root resolution. Its sampling-order theorem moves root resolution before an arbitrary adaptive outer computation without changing the observed distribution. `OtsProbeNativeRootHistoryTraceSampling.lean` identifies this observer with the existing native query trace and derives the explicit uniform-preload equality for an initially fresh, ensured target in a valid completable context. The equality retains earlier guesses, terminal resolution, and pending-hit failure branches. `OtsProbeChargedRootCut.lean` gates the selected candidate using known structural-root queries or state-materialized encoding-root queries, with direct probes handled by the separate direct-risk term. `OtsProbeChargedRootObservation.lean` and `OtsProbeNativeTraceStoredRoot.lean` preserve this selection through terminal root resolution. `OtsProbeChargedRootCutRisk.lean` specializes the compatible-record bound to that candidate. `OtsProbeChargedRootAdaptiveRisk.lean` transfers both hit and occurrence probabilities to the original adaptive execution, proving the `(4/3) / 2^128` hit-to-occurrence bound for an initially fresh, ensured layer root under the stated history, cache and query-budget premises. `OtsProbeChargedRootOccurrence.lean` bounds the terminal-filtered occurrence by the candidate occurrence in the original native trace. The counting and reserve lemmas below bound the summed root occurrences and combine the sampled probability terms; covering the full residual forgery event remains necessary. The public theorem remains 125 bits. + +`OtsProbeChargedRootInitialization.lean` proves the freshness, validity, completion, pending-history and encoding-cache premises after native key generation for an ensured layer root other than the public top root. `OtsProbeInitializedChargedRootRisk.lean` averages the resulting cut bound over key generation and instantiates the continuation with the actual adversary and verifier computation, retaining failed key-generation branches. This is a bound for the selected matching-guess event; its global count is proved below, while the residual forgery projection remains open. + +`OtsProbeChargedRootSelection.lean` proves that the separate root term makes no direct probe and counts at most one target per query. It classifies any hidden-root candidate as a direct probe, a charged root query, or an encoding guess for an unknown root, while the earlier-guess history still retains all three kinds. `OtsProbeChargedRootSelectionProjection.lean` identifies cut occurrences with the original live query selector, retaining completion filtering. `OtsProbeChargedRootCounting.lean` sums these occurrences across all selected roots and hash ordinals without a target-count factor. `OtsProbeChargedRootGlobalRisk.lean` combines the occurrence and hit bounds and places the root charge alongside direct-probe costs within the same refined reserve. `OtsProbeInitializedChargedRootGlobalRisk.lean` averages the summed root-hit bound over actual key generation for any set of ensured non-top layer roots. The sampled combination is proved below; covering the full residual forgery event remains open. + +`OtsProbeInitializedChargedRootReserve.lean` carries the joint native probe and charged-root cost through key generation into the original game reserve. `OtsProbeInitializedJointRootRisk.lean` combines the actual direct-probe and charged-root hit probabilities within that reserve. `OtsProbeSampledJointRootRisk.lean` averages over the parameter and secret samplers: `sampledInitializedNativeDirectRisk_add_chargedRootRisk_le_refinedReserve` bounds their sum by the sampled refined reserve divided by `2^128`, for `q ≤ 2^126` and ensured non-top layer-root targets. This combination spends each query allowance once. `OtsProbeNativeTraceCompletion.lean` propagates a successful native trace's final completion back through its query history and proves that an executed direct probe cannot match a value that remains hidden. A history candidate matching a hidden final root must therefore be charged when unknown-source encoding matches are excluded and the source context materializes layer roots. These are support and probability bounds for specified events. Proving that they cover every residual forgery, including failed native executions, and applying the supported query budget remain necessary for the 126-bit theorem. + +`OtsProbeNativeRootFirstMatch.lean` identifies the first matching root guess in a successful native query history. When the root remains hidden and unknown-source encoding matches are excluded, that query is charged, its stored root equals the final root, and its preceding history excludes the matching digest. `OtsProbeNativeHashHistorySelection.lean` proves equality in distribution between selecting a hash query together with its preceding hash history from the full native trace and executing the corresponding numbered cut. `OtsProbeNativeRootHitProjection.lean` uses this equality to bound the final-root history-match event by the summed charged cut-hit probabilities. Its theorem `probEvent_exists_nativeFinalRootHistoryMatch_le_charge` bounds the union over initially fresh, ensured layer-root targets by the shared root charge divided by `2^128`, under the stated completion, materialization, source-exclusion and syntactic hash-query-bound premises. This closes the probability projection for that successful-trace event. It does not establish that all residual forgeries produce such an event or a bounded direct failure; the complete 126-bit theorem remains open. + +`OtsProbeNativeRejectionProbability.lean` identifies native trace rejection probability with the expected sum of rejection risks at the queries actually reached. `OtsProbeNativeRiskAccumulation.lean` bounds native rejection and terminal finalization risk by the initial pending-guess failure probability plus the live native candidate allowance. The finalization argument carries existing pending risk forward, so later probe-free queries do not charge it again. It uses the existing `canonicalGuessCharge` function on native contexts; this function still includes explicit fuel and pending-cardinality guards. `OtsProbeNativeCandidateRisk.lean` identifies the allowance of a hidden structural candidate with its actual resolver hit probability, including duplicate-guess exclusion. It extends this identity to adaptive private-resolution views as an expected allowance over completable results. Summing these allowances against the initialized direct-probe risks, handling chain starts and the supported query bounds, and proving full residual-forgery coverage remain necessary. These lemmas do not complete the 126-bit theorem. + +`OtsProbePrivateAllowanceCounting.lean` sums numbered candidate allowances exactly to the live allowance before the target's first reveal or publication, under a syntactic target-probe bound. `OtsProbePrivateAllowanceCut.lean` identifies each numbered allowance with the expected allowance at its actual resolved cut. `OtsProbePrivateAllowanceHit.lean` turns this into an equality with the sum of actual private candidate-hit probabilities for an initially hidden target, retaining completion filtering and duplicate-guess exclusion. `OtsProbePrivateAllowanceReserve.lean` sums over ensured targets, bounds the resulting stopped allowance by the existing structural-query charge, and rewrites the initialized direct-risk term as unresolved chain-start hits plus these sampled structural allowances. This adds no target-count factor. The allowance stops at a reveal even though revealing materializes a value without necessarily publishing it. Covering subsequent native candidates, handling chain starts and supported query bounds, and connecting all residual forgeries to the bounded events remain necessary for 126 bits. + +`OtsProbeNativeMaterializedCandidate.lean` proves that a candidate selected by the native hash plan is either missing from native state or is a chain coordinate. Thus, under `MaterializedChainsPublished`, a hidden candidate must be missing and a materialized candidate has zero failure allowance. This condition only concerns materialized chain values; structural values retained solely in the auxiliary table still require the private-hit bounds. `OtsProbeNativeChainMaterialization.lean` establishes the condition at ensured initialization and after supported key generation, and proves that actual probing hash queries preserve it by publishing every value they newly materialize. The signing and adaptive-history results below bound exceptions to this condition. Connecting native query allowances to the stopped sums remains open. + +`OtsProbeSigningChainValues.lean` preserves any chain coordinate outside the selected signature chain values through native signing. `OtsProbeSigningChainPublication.lean` proves that successful signing preserves publication of all materialized chain values. `OtsProbeSigningChainFailureCoupling.lean` couples a completable signing result that violates this condition to cached encoding failure in the concrete signing run. `OtsProbeNativeChainQuery.lean` extends this coupling to every outer query. `OtsProbeNativeChainTrace.lean` carries it through arbitrary adaptive execution: all recorded query contexts and any successful final context satisfy the condition, unless the paired concrete run reaches encoding exhaustion. The exhaustion event persists in the concrete cache, so later queries do not incur additional charges. `OtsProbeNativeChainBound.lean` includes ensured initialization, key generation and the actual parameter and secret samplers; `probEvent_sampledNativeChainTrace_failure_le_inv216` bounds failure of this publication condition by `2^-216`. It also bounds the event that a recorded hash query assigns nonzero candidate allowance to an already materialized value. This bounds the signing exception, but the missing-value allowances must still be connected to the stopped probe sums and the supported query budget. Full residual-forgery coverage and the 126-bit theorem remain open. + +`OtsProbePrivateInactive.lean` proves that native state never loses a materialized coordinate, and that a structural target remains materialized or published after its first disclosure. `OtsProbePrivateMissingAllowance.lean` uses this persistence to bound the full execution's allowance for missing structural values by the earlier stopped allowance. Summing over ensured targets therefore uses the existing structural-query reserve without a target-count factor. `OtsProbePrivateMissingComposition.lean` composes these context-dependent allowances across computations, preserving completion filtering and costs before rejection. `OtsProbePrivateMissingHash.lean` identifies the expanded hash handler's allowance with that of its single planned candidate; the planner and probe-free suffix add no allowance. `OtsProbeNativeMissingStructuralCharge.lean` lifts this equality through arbitrary adaptive outer execution and bounds the summed native missing-structural charges by the existing reserve under explicit syntactic target-probe bounds. The corresponding chain-start allowance accounting, use of the actual supported query budget, aggregation of the materialization exception, and full residual-forgery coverage remain necessary for 126 bits. + +This Lean project proves `125` bits of classical strong unforgeability in the random-oracle model for the formalized SPHINCS variant: `sphincs_has_125_bits_of_classical_security : SphincsSecurity125Statement`, which reads `HasClassicalSecurityBits Concrete.scheme 125`. The algorithms and parameters follow `doc/sphincs/main.tex`; the model samples secrets independently and does not prove equivalence to the seed derivation or BLAKE2s used by `crates/sphincs`. The earlier 120-bit theorem remains available. + +`OtsProbeNativeRootTraceOrdinaryCache.lean` removes the hidden-cache-entry requirement from the compatible-record comparison and proves the same-cache law when neither compared root has an encoding guess cached. `OtsProbeNativeStoredRootRecords.lean` tracks prior guesses explicitly, proves equal likelihoods outside the recorded history, and rejects histories matching the sampled root. `OtsProbeNativeStoredRootRisk.lean` derives the `(4/3) / 2^128` hit-to-occurrence bound for a uniformly preloaded root when the initial history covers pending and cached encoding guesses and its size plus the query budget is at most `2^126`. `OtsProbeNativeRootCandidateNormalization.lean` preserves the actual candidate under root normalization without a pending-guess premise. `OtsProbeNativeStoredRootCutRisk.lean` applies the bound to the actual candidate at a selected hash-query cut. `OtsProbeNativeResolvedRootCutRisk.lean` transfers it to an experiment that runs the real fresh-root resolver before that computation, including pending-guess cleanup. The charged observation above now relates the local experiment to the original adaptive execution from an initially fresh root. The complete argument still needs occurrence costs charged against the shared reserve and the full residual forgery event covered. The public theorem remains 125 bits. + +`OtsProbeNativeRootCandidate.lean` unifies native probes, encoding-root guesses and known structural-root guesses into one optional candidate per hash query, preserved by stored-root replacement. `OtsProbeNativeRootCandidateHistory.lean` bounds the number of distinct guesses in a supported native trace by its hash-query budget, with no extra factor for the three cases. `OtsProbeNativeRootTraceSafety.lean` proves that a trace which keeps the root hidden and avoids both compared values cannot start with an unsafe query. `OtsProbeNativeRootCompatibleTrace.lean` filters those compatible histories from the original native execution, preserving sequential composition. `OtsProbeNativeRootTraceCoupling.lean` proves equality of their normalized result-and-history distributions for arbitrary adaptive computations from related stored-root contexts and full caches. `OtsProbeNativeRootRecordLikelihood.lean` derives equal probabilities for every fixed record whose history excludes both root values. Instantiating this likelihood law with the actual root sampler and initial caches, bounding the resulting matches within the joint reserve, and covering the complete residual forgery event remain open. The public theorem remains 125 bits. + +`OtsProbeNativeRootSwapStep.lean` composes the actual signing, uniform and safe hash-query comparisons. `OtsProbeNativeOuterCut.lean` stops before an unsafe query and retains its continuation, with an exact theorem that resuming the cut recovers the original native execution. `OtsProbeNativeRootOuterCut.lean` couples arbitrary adaptive computations up to that cut while retaining the full cache relation. `OtsProbeNativeRootOuterCutStop.lean` and `OtsProbeNativeRootUnsafeAction.lean` classify the stopped query. `OtsProbeNativeRootExposure.lean` proves that the selected-root resolution case publishes the root; if the root remains hidden after any continuation, the unsafe query is covered by encoding guesses, direct probes or structural-root queries. `OtsProbeNativeStructuralRootGuess.lean` strengthens the structural case to a matching payload-slot guess, proves that one structural input has at most one layer-root candidate, and retains its occurrence charge alongside the match. Bounding these adaptive matching guesses against the joint reserve and covering the complete residual forgery event remain open. The public theorem remains 125 bits. + +`OtsProbeNativeRootProbe.lean` preserves stored-root replacement through probes that miss both compared values. `OtsProbeNativeRootHashInput.lean` and `OtsProbeNativeRootHashAction.lean` couple the native hash action when its reconstructed input agrees away from the selected root, or when both reconstructions miss the queried input. `OtsProbeNativeRootEncodingHash.lean` extends the encoding-cache comparison through the complete native hash handler for inputs avoiding both root encodings. `OtsProbeNativeRootHashPlan.lean` composes the state comparison with the invariant plan and optional probe. `OtsProbeNativeRootSwapHash.lean` combines both cache and state comparisons for the actual handler, retaining the full cache relation and proving equality of normalized, completion-filtered result distributions for arbitrary initial hidden cache entries. These local equations require the explicit probe, encoding and hash-action safety conditions. The adaptive stopped comparison above composes these local equations. Bounding the first unsafe query and closing the residual forgery probability bound remain open. The public theorem remains 125 bits. + +`OtsProbeNativePeekInput.lean` gives exact native execution equations for structural input lookup. `OtsProbeNativeRootInputObservation.lean` proves that replacing a stored root preserves the native query plan and whether a structural input can be reconstructed. A reconstructed input can change only when the selected root is one of its children and both contexts can reconstruct the input. This includes structural queries above a short layer root, so the remaining root argument must cover structural inputs as well as encoding inputs. + +`OtsProbeNativePlannedReserve.lean` proves that a native hash query has zero direct-probe cost when its plan has no candidate. `OtsProbeNativePlannedReserveComposition.lean` retains the unused allowance through arbitrary adaptive execution and bounds the combined allowance by the actual direct OTS query charge. `OtsProbeNativeStoredRootStructuralCharge.lean` proves that structural queries with a hidden layer-root child and reconstructible input make no direct probe, bounds their occurrence charge by this unused allowance, and preserves that occurrence predicate under root replacement. `OtsProbeNativeRootJointReserve.lean` combines the native probe cost, structural-root occurrence charge and encoding-root occurrence charge within the same actual refined OTS reserve. These are cost bounds, not yet bounds on matching guesses. The compatible-history root guessing argument and the complete residual forgery projection remain open. The public theorem remains 125 bits. + +`OtsProbeNativeRootEncoding.lean` and `OtsProbeNativeRootCache.lean` transport the hidden-root encoding-cache comparison to the native executor. `OtsProbeNativeStoredRoot.lean` proves that stored position values survive every successful native run. `OtsProbeNativeRootSigner.lean` and `OtsProbeNativeChronologicalRootSigner.lean` use these facts to couple the complete chronological signer with a comparison signer that substitutes a fixed root in the relevant encoding inputs. The relation preserves the exact native context, remaining fuel, chain-start table, signature result and failure branches, while relating the two encoding caches. This is an intermediate cache comparison, not the hidden-root guessing bound: proving the compatible-record likelihood law for native hash-query selection, and covering the full residual forgery event remain open. The public theorem remains 125 bits. + +`OtsProbeNativeValueReplacement.lean` extends root replacement to values already copied into the native state while preserving whether that copy exists. `OtsProbeNativeValueCompletion.lean` preserves completability and validity when both values avoid the pending guesses. `OtsProbeNativeValueResolver.lean` commutes replacement through the recursive structural resolvers, and `OtsProbeNativeValueMaterialization.lean` carries it through a native reveal, changing the revealed output and hidden cache entry together. `OtsProbeNativeValueObservation.lean` preserves the known-hidden-root query charge and gives a common normalized context for both replacement values. These results support the stored-root replacement step. The signer composition below combines it with the encoding-cache comparison; the compatible-record likelihood law for adaptive hash-query selection and the full residual forgery bound remain open. + +`OtsProbeNativeRootState.lean`, `OtsProbeNativeRootStateCoupling.lean`, `OtsProbeNativeRootStateSigner.lean`, and `OtsProbeNativeRootStateChronological.lean` lift stored-root replacement through the complete chronological signer, including retry failures and returned authentication paths. `OtsProbeNativeRootSwap.lean` composes this with the encoding-cache comparison. For a stored layer root with its hidden cache entry, and two values avoiding the pending guesses, the original signer runs are coupled while retaining the relation on their full caches and contexts. Erasing the cache and normalizing the selected root yields equal result distributions even after incomplete executions are discarded. This closes the local signer comparison, not the adaptive hidden-root guessing bound: the coupling still needs to cover outer hash queries and their compatible histories before the root-selection occurrence budget can bound matching guesses. The public theorem remains 125 bits. + +`OtsProbeNativeOrdinaryCache.lean` and `OtsProbeNativeOrdinaryCacheSigner.lean` prove that the complete native chronological signer preserves equal ordinary cache projections, with identical contexts, remaining fuel, chain-start tables, returned signatures and failure branches. Hidden cache entries may differ arbitrarily. `OtsProbeNativeRootSwapOrdinaryCache.lean` uses this to remove the hidden-cache-entry premise from the stored-root signer comparison: the root may be stored only in the deferred context. The equality retains the completion guard and erases the final cache. This is still a local signer comparison; adaptive outer hash queries and the full residual probability bound remain open. The public theorem remains 125 bits. + +`OtsProbeNativeOrdinaryCacheHash.lean` extends hidden-cache irrelevance through the actual probing hash handler and arbitrary adaptive chronological adversary computations. `OtsProbeNativeOrdinaryCacheSelection.lean` couples their live hash-query selectors with the same query, context, fuel and chain-start table, retaining equal ordinary cache projections. Erasing hidden cache entries therefore gives equal selection distributions, including the completion guard. This administrative cache comparison does not yet replace the hidden root value through adaptive outer hash queries. + +`OtsProbeNativeQueryTrace.lean` records live native outer-query snapshots. `OtsProbeNativeQueryTraceCoupling.lean` couples the entire trace to the actual prehit-monitor execution, preserving the context invariants at each recorded query and relating successful terminal results. `OtsProbeNativeQueryTraceSource.lean` bounds the union of unknown-source matching-root events by the single actual prehit event, including matches at later snapshots or at termination. `OtsProbeNativeQueryTraceSelection.lean` projects the trace exactly to the live native selectors for all outer queries and for hash queries alone. `OtsProbeNativeQueryTraceProjection.lean` projects its terminal result to the completion-filtered native execution and its expected charge to the existing native budget. The already-stored-root guessing bound and the complete residual opening bound remain open. The public theorem remains 125 bits. + +`OtsProbeCanonicalWeightedCharge.lean` and `OtsProbeWeightedReserve.lean` prove that the unresolved chain-start charge weighted by `4/3`, the unresolved structural-position charge, and the materialized-candidate charge weighted by `4/3` share the actual refined OTS query reserve. The proof uses disjointness of materialized and unmaterialized candidates, then transports the expected charges through adaptive execution, key generation and the original secret samplers. `OtsProbeHashCutReserve.lean` combines that reserve inequality with the proved chain-start probability bound: the sum of chain-start hit probabilities over the first `q` hash-query cuts, plus the two other weighted charges divided by `2^128`, is at most the sampled refined OTS reserve divided by `2^128`, plus `q / 2^216`, for `q ≤ 2^126`. The two other terms here are charges, not yet probability bounds. `OtsProbeCandidateRiskComponents.lean` decomposes the candidate failure allowance into unresolved chain starts, unresolved positions and an indicator for a matching stored structural value. The native resolver recursively stores hidden non-root child values, so the older direct interpreter's non-root freshness argument does not apply directly to these contexts. The stored-value term needs a distribution comparison or its own probability bound. `EncodingPrehitViewedBound.lean` accepts the per-query erasure term in its conditional 126-bit assembly. The remaining work is to bound the structural and hidden-root probabilities by these charges and project the actual prehit-free residual opening event onto the combined bound, including the supported query budget. The public theorem remains 125 bits. + +`OtsProbePrivateValueReplacement.lean` proves an exact replacement law for stored structural values. Replacing one auxiliary value commutes with chain, leaf and tree resolution when the selected position has no materialized state value and pending guesses avoid both the old and replacement values. Every other resolved output is preserved, and resolving the selected position returns its replacement. Replacing an already stored value preserves the materialized and unmaterialized candidate charges and their combined weighted hash charge. Canonicalization commutes with replacement while the selected position is unrevealed. `OtsProbePrivateValueExecution.lean` extends the distribution equality through arbitrary adaptive native computations that do not reveal or publish the selected position or probe either value. `OtsProbePrivateValueCut.lean` constructs a cut before the first such query, proves its exposure bound without a premise on the original computation, and proves that resuming it recovers that computation. The cut's returned value has the same distribution under the two preloaded values, with the exposure predicate symmetric in them. These laws handle stored hidden children directly. A probability bound still requires averaging over the actual sampling, accounting for earlier comparison-value guesses, and connecting these cuts to the canonical outer execution and residual opening event. They do not complete the 126-bit theorem. + +`OtsProbePrivateValueFirstAccess.lean` stops a native computation before its first reveal, publication or probe at a selected position. Its fresh probe-candidate distribution is independent of the preloaded value when that value avoids the initial pending guesses. `OtsProbePrivateValueFirstAccessRisk.lean` averages this law over an independent uniform target draw, dropping draws that match an initial pending guess. In this auxiliary experiment, the first fresh guess hits with probability at most its occurrence probability times `(4/3) / 2^128` when the initial pending set has at most `2^126` entries, or times `1 / 2^128` when the target has no pending guesses. `OtsProbePrivateValueFirstAccessCharge.lean` proves that the target's private value, publication status and pending guesses are preserved before this cut, and identifies the occurrence probability with the expected existing materialized-candidate charge. `OtsProbePrivateValueMaterializedCommutation.lean` retains the complete target resolution across materialization and proves that drawing the target before a native structural reveal has the same joint distribution of context and revealed output as drawing it afterward, from a valid completable context. These are local sampling and cost laws. Connecting the auxiliary experiment to the original adaptive sampling, accounting for repeated guesses and hidden-root encoding accesses, and assembling the actual residual opening bound remain necessary for 126 bits. + +`OtsProbePrivateValueAdaptiveSampling.lean` moves the target draw through an arbitrary native computation from a valid, completable context in which that target is ensured. Its retained view resolves the target at termination, rejects incomplete contexts, and keeps the final context, fuel and return value. Resolving the target before execution as well gives exactly the same retained distribution. If neither value map initially contains the target, the initial resolver is an independent uniform draw with a pending-guess rejection and pending-set cleanup. `OtsProbePrivateValueCompletion.lean` proves that replacing a hidden value by another value avoiding its pending guesses preserves completability. `OtsProbePrivateValueLiveCut.lean` uses that fact to retain the completion filter in the first-candidate replacement law and proves the `(4/3) / 2^128` probability bound against the expected materialized-candidate charge on those retained cuts. The pending cleanup and first-candidate transport below connect these two experiments. Composition with canonical outer queries, repeated guesses and hidden-root encoding accesses remains open. + +`OtsProbePrivateValuePendingCleanup.lean` proves that clearing pending guesses at an already known position preserves the retained native return value and fuel from a valid, completable context. The first-candidate projection continues to filter against the original pending set, so cleanup does not charge duplicate guesses. `OtsProbePrivateValueFirstAccessTransport.lean` connects the adaptive retained view to the independently sampled first-candidate experiment. For an initially fresh, hidden, ensured target in a valid, completable context, the native retained first-access hit probability is bounded by its own candidate-occurrence probability times `(4/3) / 2^128`, provided the initial pending set has at most `2^126` entries. That occurrence probability equals the expected materialized-candidate charge in the sampled experiment. The cut stops before the first direct target reveal, publication or probe; this does not yet bound later guesses or hidden-root encoding accesses. The remaining assembly must charge the original outer query execution, handle those later accesses and project the actual residual forgery event. + +`OtsProbePrivateValueHistoryRisk.lean` gives a probability bound for records whose likelihood is equal across target values avoiding their recorded guesses, and zero for values matching those guesses. If every supported history has at most `2^126` distinct guesses, a selected candidate hits with probability at most its occurrence probability times `(4/3) / 2^128`. The calculation allows the recorded history to depend on the sampled value; it does not assume unconditional independence. A candidate already in its recorded history contributes zero hit probability. `OtsProbePrivateValueProbeCut.lean` stops before a numbered target probe or an earlier target reveal or publication. It resumes to the original computation, has at most that many preceding target probes, and specializes to the first-access cut at ordinal zero. `OtsProbePrivateValueProbeHistory.lean` proves that native execution before this cut preserves the private target value, retains the initial pending guesses and adds at most one distinct guess per target probe. A completable cut result has no recorded guess matching that value. These facts provide the history bound and rejection invariant for later probes. The record comparison and local probability bound below establish the compatible-record likelihood property. The adaptive transport below connects this local experiment to tracked native execution; its composition with the global query-cost bound remains necessary. + +`OtsProbePrivateValueProbeRecords.lean` retains completable native probe-cut results and erases the selected auxiliary value in the returned record. Its supported histories contain the initial pending guesses, add at most the probe ordinal, and avoid the sampled value. `OtsProbePrivateValueRecordReplacement.lean` preserves these normalized records under replacement before the first exposure of either comparison value. `OtsProbePrivateValueCompatibleRecords.lean` proves that stopping at such an exposure does not change compatible final records: a matching probe adds a guess that rules out compatibility, and the probe-cut computation has no target disclosure. Consequently compatible histories have equal likelihood under the two preloaded values. `OtsProbePrivateValueProbeRisk.lean` applies the history probability bound to any numbered target probe. In the uniform-preload experiment, with initial pending cardinality plus probe ordinal at most `2^126`, the fresh candidate hit probability is at most its expected materialized-candidate charge times `(4/3) / 2^128`. Duplicate guesses have zero charge. These are native execution laws for an auxiliary preload experiment. The tracked adaptive transport below handles later probes from an initially fresh target; hidden-root encoding accesses and the global residual opening bound remain open. The public security theorem remains 125 bits. + +`OtsProbePrivateValueHistoryTracking.lean` records target-probe guesses in the computation's return value. Erasing this history recovers the original computation, and tracking preserves its query bounds. For a preloaded hidden target before disclosure, the recorded history equals the native final pending set. `OtsProbePrivateValueProbeTransport.lean` carries this returned history through pending cleanup and terminal target resolution, then proves equality between the tracked adaptive candidate distribution and the uniformly preloaded probe-record experiment. For an initially fresh, hidden, ensured target in a valid, completable context, the native tracked cut's hit probability is at most its candidate-occurrence probability times `(4/3) / 2^128`, provided the initial pending cardinality plus probe ordinal is at most `2^126`. Its occurrence probability equals the sampled probe charge. The history filter continues to exclude earlier guesses even when the resolver clears pending guesses. Connecting these tracked events and charges to the canonical outer-query budget and actual residual opening event, including hidden-root encoding accesses, remains necessary. This does not complete the 126-bit security theorem. + +`OtsProbePrivateValueRawProbeRisk.lean` removes the history tracker and candidate filter from the observed hit event. It transports the original numbered native probe cut to the preloaded record experiment and proves that filtering duplicate guesses does not change its hit probability, since a retained record cannot contain a guess matching its stored value. Thus the unfiltered native hit probability is bounded by the sampled fresh-candidate charge times `(4/3) / 2^128`. That charge is at most the retained raw candidate-occurrence probability, which is at most the probability that native execution reaches the selected probe cut. These bounds require an initially fresh, hidden, ensured target in a valid, completable context, with initial pending cardinality plus probe ordinal at most `2^126`. The remaining assembly must sum these probe-occurrence terms against the shared outer-query reserve, account for hidden-root encoding accesses, and cover the actual residual opening event. The public theorem still proves 125 bits. + +`OtsProbePrivateValueProbeCounting.lean` identifies each native probe-cut occurrence probability with a recursive ordinal mass and bounds their sum by the expected target-probe query charge. Summing over a finite set of targets introduces no multi-target factor: each structural probe names one position. Its native charge counts a probe when reached, including an attempted probe at zero fuel, matching the cut before execution. A syntactic probe bound also bounds this expected charge. `OtsProbeNativeQueryCharge.lean` proves the charge's sequential composition law and bounds the concrete hash-query block by its OTS-position indicator; signing and uniform-query blocks have zero structural charge. Composing these bounds through the native masked adaptive execution bounds the sum of direct structural hit probabilities over targets and probe ordinals by the expected OTS-position outer-query count times `(4/3) / 2^128`. The target freshness, initial context and history-size conditions remain explicit. The remaining proof must transport this native outer-query accounting to the actual shared reserve, incorporate hidden-root encoding accesses without double counting, and cover the residual forgery event. The public security theorem remains 125 bits. + +`OtsProbeLiveNativeReserve.lean` stops native outer-query charges at contexts with no valid completion. This guard is necessary for the concrete coupling: the earlier unguarded native count may continue after inconsistency, when concrete replies need no longer match. For the chronological native implementation, the guarded OTS-query count weighted by `4/3` is bounded by the actual refined reserve, using the proved native-to-concrete coupling and the concrete signing algorithm. This comparison requires the existing context, cache-visibility and publication invariants and does not canonicalize the native state. `OtsProbePrivateValueLiveProbeCut.lean` proves that terminal target resolution cannot restore completability, then strengthens the raw hit bound to charge only completable probe-cut prefixes. The live counting and composition below establish the guarded chronological comparison; the earlier unguarded sum bound alone does not establish it. Hidden-root encoding accesses, initial-state and sampler composition, and residual-forgery coverage also remain necessary for the public 126-bit theorem. + +`OtsProbePrivateValueLiveProbeCounting.lean` identifies live probe-cut probabilities with an ordinal count that stops at inconsistent contexts, then sums over probe ordinals and targets against the guarded native structural-query charge. `OtsProbeLiveNativeComposition.lean` proves sequential composition for that guarded charge using preservation of inconsistency. It bounds the chronological execution's guarded structural charge by its live OTS-position outer-query count and joins this with the concrete-reserve comparison. Consequently the sum of direct structural hit probabilities over the selected targets and probe ordinals is at most the actual refined reserve divided by `2^128`, under the stated initial freshness, history-size and coupling invariants. This closes the local direct-structural reserve comparison. It does not allow separately adding another full reserve for chain starts or hidden roots: the final combination must share each query's allowance. Initial-state and sampler composition, hidden-root encoding accesses, supported query bounds and coverage of the complete residual forgery event remain open; the public theorem still proves 125 bits. + +`OtsProbeLiveJointCharge.lean` proves that native chain-start and structural probe charges add to the total probe charge, and their guarded chronological sum is bounded by the OTS-position outer-query count. `OtsProbeLiveJointReserve.lean` assigns these direct probes a charge of `4/3` at OTS inputs and zero elsewhere, with an exact remaining-reserve partition at both query and sampled-game level. The direct structural hit sum and the weighted chain-start charge fit together within this direct slice. `OtsProbeLiveSampledReserve.lean` carries the guarded chronological OTS charge through public-root generation and the actual parameter and secret samplers, bounding it by the sampled direct slice while preserving the entire remaining reserve. These are joint cost bounds; the chain-start charge in this comparison is not yet a chain-start hit probability, and the remaining reserve still needs to cover hidden-root accesses. + +`OtsProbeLiveStartCut.lean` cuts native execution before a numbered probe and proves that resuming the cut recovers the original computation. The prefix contains at most the selected ordinal's number of probes. From the empty native context with the actual chain-start table sampler, the unresolved chain-start hit probability at each cut is at most its retained unresolved-start charge times `(4/3) / 2^128`; the finite ordinal sum has the same bound without a canonicalization erasure term. Connecting that sum of cut charges to the shared native query charge, composing the structural hit bounds through initialization, handling hidden-root encoding accesses, and projecting the complete residual forgery event remain necessary. The public theorem remains 125 bits. + +`OtsProbeLiveStartCounting.lean` bounds the sum of retained numbered-cut charges by the guarded native query charge. Applied to chain starts, this turns the summed native hit bound into its share of the common query budget. `OtsProbeLiveGameCharge.lean` carries that probability and the structural charge through public-root generation and parameter and secret sampling, preserving the remaining OTS reserve. + +`OtsProbeEnsuredInitialization.lean` initializes any finite set of structural targets as ensured, with no stored values, pending guesses or published positions. This context has the same pending and value maps as the empty context and satisfies the initial concrete-coupling, cache-visibility and publication invariants. Both the structural hit bound and the native chain-start cut bound hold from this common initialization. `OtsProbeInitializedGameCharge.lean` combines their probabilities through the entire chronological native retained computation, including public-root generation, and then averages over the actual parameter and secret samplers. Its theorem `sampledInitializedNativeDirectRisk_add_remaining_le_refinedReserve` bounds the joint direct-hit risk plus the unused reserve by the sampled refined OTS reserve divided by `2^128`, without an extra target-count factor or a canonicalization erasure term. The probability covers unresolved chain-start hits at the first `q` native probe cuts and structural hits before direct target disclosure at the first `q` target-probe cuts, for `q ≤ 2^126`. Covering hidden-root encoding accesses, proving that the complete residual forgery event is dominated by these bounded events, and applying the supported query budget remain necessary. The public security theorem is still 125 bits. + +`OtsProbeNativeRootReserve.lean` couples the chronological native execution directly to the actual encoding-prehit monitor, retaining the concrete-cache relation, supported monitor result and closure of stored structural computations. A live native stored-root match after an encoding query with less than `4/3` remaining reserve is dominated by the prehit event. Encoding inputs use none of the direct OTS charge, so their remaining reserve equals the refined reserve. `OtsProbeNativeRootQueryCharge.lean` defines a `4/3` charge for encoding-root queries with sufficient remaining reserve, proves that known native roots and later matching roots on prehit-free runs have that charge, and combines its sampled expectation with the proved initialized direct-hit risk inside the original refined reserve. This supplies native reserve and prehit relations; it does not yet prove that hidden-root hit probabilities are bounded by the new query charge divided by `2^128`. That probability bound, complete residual-event domination and supported query-cut coverage remain open. The public theorem remains 125 bits. + +`OtsProbeLiveContextCharge.lean` extends guarded native query accounting to charges depending on the current context. `OtsProbeLiveKnownRootCharge.lean` charges `4/3` for an encoding query aimed at an already computed, unrevealed layer root and bounds its native expectation by the concrete root-query charge. `OtsProbeInitializedKnownRootCharge.lean` carries this bound through the ensured initial context, public-root generation and actual parameter and secret sampling. `OtsProbeLiveHashSelection.lean` selects by hash-query ordinal, skipping uniform and signing requests, and identifies the total expected selection charge with the native context-dependent charge. `OtsProbeLiveHashCut.lean` proves that this selector has the same distribution as the corresponding native hash-query cut after filtering incomplete contexts. `OtsProbeInitializedRootSelection.lean` carries that equality through root generation and proves that the sampled known-root selection mass, weighted by `(4/3) / 2^128`, shares the refined reserve with the proved direct-hit risk. This is an occurrence-budget bound: it does not yet bound hidden-root guessing success by that selection mass. The root probability comparison, residual-event domination and supported query-cut coverage remain open; the public theorem remains 125 bits. + +`OtsProbeSettledNativeValue.lean` proves the reverse cache correspondence: a settled concrete OTS position has a stored native value, with the same digest, under the existing chronological cache and completion invariants. `OtsProbeNativeRootSource.lean` uses this to prove that an encoding guess matching a later stored root on a prehit-free continuation already matched a stored root at the source query. In the chronological native execution, a later live hidden-root match from a source outside the known-hidden-root predicate is dominated by the concrete prehit event. `OtsProbeRootSourceTrace.lean` proves source settlement across complete monitored histories. `OtsProbeKnownRootTraceSource.lean` transfers it through the existing trace relation and bounds the union of later and terminal stored-root matches from unknown sources by one final prehit probability, including for the canonical trace. This introduces no factor for the number of query pairs. It does not yet bound guesses against roots already known at their source queries or establish complete residual-forgery coverage; the public security theorem remains 125 bits. + +`EncodingExhaustionProbability.lean` bounds encoding exhaustion under arbitrary adaptive executions of the original random oracle, including queries made before a signing request. For any fixed finite input set, it assigns each missing answer its invalid-encoding probability, each cached invalid answer weight one, and each cached valid answer weight zero. The expected product of these weights is preserved by every oracle query. Thus the probability that all inputs are cached with invalid answers is at most the invalid-encoding probability raised to the number of inputs. Taking the union over every parameter, encoding position and message gives `3 * 2^294 * (1 - validDigests.card / 2^128)^(2^32)`. A fully cached concrete OTS call returning `none` supplies such an exhausted set, which persists under cache extension. `EncodingCount.lean` injects pairs of 21-digit vectors with sums 95 and 96 into the actual valid digests. `EncodingCountCertificate.lean` checks each row of the digit-sum recurrence in Lean and proves `validDigests.card ≥ 2^105`. `EncodingExhaustionBound.lean` uses Bernoulli’s inequality to bound the resulting global exhaustion probability by `2^-216`. `EncodingSigningFailure.lean` proves that a fully cached concrete signing computation returning `none` after the digest-selection stage has an exhausted OTS encoding search. The chronological signer also has a supported failed continuation after a successful digest selection whenever canonicalization erases a known chain start. `OtsProbeSigningFailureCoupling.lean` transports this failure through the complete signing call to the same coupled concrete cache. Its relation proves that a live result either has all materialized chain starts published or has a cached encoding failure. Outside the exhaustion event, canonicalization preserves every stored chain-start value, the completed start table and the history-hit predicate. The local erasure probability is bounded by the failure probability of that concrete signing call from its current cache. The `2^-216` bound applies to the complete oracle execution from the empty cache. + +`OtsProbeStartErasureTrace.lean` carries an erasure flag through every canonical query and retains it after early stops. Removing the flag recovers the existing canonical interpreter’s output distribution. Its adaptive coupling proves that any flagged live chain-start erasure implies encoding exhaustion in the final concrete cache. `OtsProbeStartErasureBound.lean` includes key generation from the empty cache and proves a `2^-216` bound for every fixed secret table and arbitrary adaptive continuation, then averages over the actual parameter and secret samplers for the retained game, including verification. Thus failed-signing erasures have one global bound, without a separate union bound over signing requests. The guarded-interpreter comparison below uses this global erasure bound. The accumulated query-charge comparison and the hidden-root contribution remain necessary for the 126-bit theorem. + +`OtsProbeHistoryCanonicalBoundary.lean` proves the block-level sampling equality needed at canonical boundaries. It checks completion and publication conditions, then shows that executing a native block with an initially sampled, history-filtered table has the same output distribution as sampling secrets during the block, canonicalizing its prefix context, and drawing the remaining table afterward. The boundary preserves history coverage and gives a canonical context for every remaining table. Its unresolved chain-start probability is bounded by the corresponding expected charge with factor `4/3`. For consistent native results with published values, the boundary agrees with live canonicalization whenever the erasure event is absent. The guarded adaptive composition and its comparison with the original execution are proved below. The accumulated query-charge comparison and the hidden-root contribution remain open. + +`OtsProbeHistoryQueryPrefix.lean` retains the history needed by a subsequent block. A block with no probes leaves the history unchanged, including when it reveals secrets. The complete hash-query prefix appends its planned candidate and preserves the context invariants; its sampling equality applies before any continuation that observes the updated history and completed result. A signing specialization preserves the original history. A dependent two-block theorem composes a block with no probes and a bounded block selected by its returned value, moving the remaining table draw through their canonical boundary. This hash-query theorem assumes positive probe fuel; the outer-prefix extension below handles zero fuel as well. + +`OtsProbeHistoryOuterPrefix.lean` handles every outer query and fuel value, retaining the updated candidate history and the context invariants needed by the next query. `OtsProbeHistoryOuterComposition.lean` composes these prefixes through an arbitrary adaptive outer computation. For the guarded native execution, it proves equality between initially sampling a history-filtered table and sampling secrets during execution with the remaining table drawn at termination. The returned history length is bounded by the initial length plus the outer hash-query budget. When that sum is at most `2^126`, the live unresolved chain-start hit probability is bounded by the expected candidate charge times `(4/3) / 2^128`. Every supported guarded output is completable. The guard checks publication conditions at canonical boundaries. The erasure bridge below connects this execution to the original canonical interpreter. The hidden-root bound and the full probability-to-query-charge assembly remain necessary for the 126-bit SUF theorem. + +`OtsProbeHistoryErasureBridge.lean` proves that discarding flagged results from the original canonical erasure trace gives exactly the guarded native interpreter's output distribution. The equality covers arbitrary adaptive computations from a consistent canonical context with published values, including doomed contexts and zero fuel. It extends through actual key generation and the retained game's secret sampling. Consequently, any event on the retained canonical output has probability at most its guarded counterpart plus `2^-216`. Erasing flagged results cannot increase the expectation of any nonnegative cost that is zero on `none`. `OtsProbeHistoryCanonicalRisk.lean` applies these facts to the history-filtered original canonical execution: its live unresolved chain-start hit probability is at most its own expected candidate charge times `(4/3) / 2^128`, plus its erasure probability. This requires the initial context to be canonical for every completed table and the combined history and hash-query budget to be at most `2^126`. The arithmetic in `Security126RefinedEndpoint.lean` also checks that one global `2^-216` term fits the 126-bit budget. Its security assembly remains conditional on the joint primitive bound. The remaining work is to assemble the actual accumulated ordinary and hidden-root probabilities against their shared query reserve. + +`OtsProbeHistoryRootSampling.lean` moves the table draw through actual key generation into the canonical history prefix. The root prefix has empty candidate history and preserves the invariants required by the adaptive sampling theorem. For an outer continuation bounded by `b ≤ 2^126`, the original canonical execution after key generation has live unresolved chain-start hit probability at most its expected candidate charge times `(4/3) / 2^128`, plus `2^-216`. There is no initial history filter in this experiment. `OuterHashQueryCut.lean` stops before the numbered outer hash query, passing through uniform and signing queries. Resuming the cut recovers the original computation, and every cut prefix has at most its ordinal number of outer hash queries on every abstract reply path, without a query-bound premise on the adversary. `OtsProbeHashCutRisk.lean` applies the root-sampling bound to those cuts and proves that the sum of hit probabilities over the first `q` hash-query cuts is at most the sum of their expected candidate charges times `(4/3) / 2^128`, plus `q / 2^216`, for `q ≤ 2^126`. Its output-distribution projection identifies the cut experiment with the original canonical interpreter. The refined endpoint arithmetic checks that this per-cut erasure allowance fits the 126-bit budget. The charge-accumulation result below connects the cut charges to the canonical execution. Combining the ordinary and hidden-root contributions against the shared reserve remains necessary; the public theorem is still 125 bits. + +`OtsProbeHashCutCharge.lean` identifies the expected charge at each hash-query cut with the corresponding ordinal charge in the canonical execution. For any nonnegative query charge, the sum over the first `q` hash ordinals is bounded by `expectedCanonicalQueryCharge` for the original computation; non-hash queries and early stops are included. The bound is lifted through key generation and the original table sampler. Instantiating it with the unresolved chain-start charge gives a bound on the sum of the actual cut hit probabilities by the canonical accumulated start-candidate charge times `(4/3) / 2^128`, plus `q / 2^216`. This closes the unresolved chain-start component's probability-to-accumulated-charge comparison without imposing an abstract query-bound premise on the adversary. The shared charge reserve is proved above. Bounding the ordinary structural and hidden-root probabilities by their respective charges and closing the public 126-bit endpoint remain necessary. + +`OtsProbeHistoryLiveRisk.lean` transfers the adaptive unresolved chain-start bound to the native interpreter, restricting both the hit event and its expected charge to contexts that can still be completed. Under the history filter, this restriction depends only on the prefix context, so it preserves the `4/3` factor. From the empty initial context, the bound applies to the original table sampling without an initial history filter. This is a candidate-hit probability bound; composing the charges across canonical signing boundaries and bounding hidden-root hits remain necessary for 126 bits. + +`OtsProbeSigningStartValues.lean` proves that a successful chronological signing reply publishes every chain start materialized during the attempt, assuming previously materialized starts were already public. Computing layer messages and searching for encodings preserve the stored chain starts; private layer reveals can change only the selected signature coordinates. Consequently, from a canonical context, canonicalization after a successful reply preserves all stored chain-start values, the completed start table and the history-hit predicate. Erasing a known chain start requires a failed signing reply after a successful digest selection; failure of the digest-selection loop alone cannot cause this erasure. The module also proves that canonicalization commutes with the final history-filtered table draw when materialized starts are public and published coordinates have values. These results isolate the failed-reply case in the signing-boundary argument; they do not yet bound that case or the hidden-root contribution, and the 126-bit endpoint remains conditional. + +`OtsProbeHistoryRevealSampling.lean` and `OtsProbeHistoryCompletionInterpreter.lean` extend the chain-start history filter through an entire native computation that makes no probes. They prove equality of the full output distributions, including the returned table, context, fuel and result, between sampling the table initially and sampling missing chain starts when they are revealed, with the remaining table sampled at termination. The equality requires the existing history to cover pending guesses and fewer pending guesses than digest values. Structural reveals use the proved table independence under the history filter. The auxiliary interpreter rejects probe queries, so this theorem does not yet cover the adaptive sequence of hash-query boundaries. Connecting those boundaries and the hidden-root probability to the actual query reserve remains necessary for 126 bits. + +`OtsProbeHistoryCandidateSampling.lean` now carries this equality across one complete hash query, including its candidate probe, the subsequent hash or resolution action, and canonicalization of the returned state. Extending the history filter can newly reject a table only when its chain-start value matches a newly pending guess, which makes the state impossible to complete. The query equality therefore supports any continuation that maps an uncompletable state to the common failure outcome; it retains the result, cache, context and returned table. A separate theorem applies it to finalization without a continuation premise. The initial context must have known values at revealed chain starts, a property proved here from canonical materialization, and its pending guesses must be covered by the prior history. This completes the local hash-query transformation. The distribution and charge comparison across the whole adaptive query sequence, including hidden-root hits, remains open. + +`OtsProbeHistoryAdaptiveInterpreter.lean` extends the sampling equality to arbitrary native computations with a probe bound. Its interpreter appends a guess to the history only when the coordinate is unrevealed, preserves the native fuel stops, and samples the remaining table at termination. The theorem applies after finalization, preserving the full finalized result and table, or before any continuation that rejects uncompletable states. From the empty initial state it gives equality without an initial history filter. This handles adaptive native probes but does not insert canonicalization between outer adversary queries. A chronological signing attempt can materialize unpublished chain values that canonicalization later discards, so their treatment at those boundaries still needs a separate composition argument. The hidden-root probability bound and the final comparison to the actual query reserve remain open. + +`OtsProbeHistoryPrefix.lean` separates this adaptive interpreter into an execution that returns its context, value and probe history, followed by the remaining table draw. The factorization is an equality of computations. Every supported returned history covers the pending guesses and has length at most the initial history length plus the native probe bound. `OtsProbeHistoryPrefixRisk.lean` proves that at least three quarters of the remaining tables pass the history filter when that combined budget is at most `2^126`; this is a history-filter bound before finalization, not a signature-acceptance bound. It then bounds the expected unresolved chain-start candidate allowance by `4/3` times the corresponding expected charge divided by `2^128`, over the adaptive interpreter itself. The candidate may be optional and may depend on the returned context and value; it cannot depend on the remaining table. The unresolved component explicitly excludes structural-position candidates and already materialized chain starts. This advances the ordinary-guess probability comparison beyond a fixed context. Composition through canonical signing boundaries and the hidden-root contribution are still required for the 126-bit security theorem. + +The latest 126-bit OTS reduction is in `OtsProbeJointHiddenFailure.lean` and `OtsProbeSuccessfulHiddenCharge.lean`. Every residual private witness gives an existing hidden-value hit in the coupled diagnostic history. The comparison predicates require successful finalization and the first hidden hit, without requiring a final doomed state. `OtsProbeSuccessfulHiddenOrdinals.lean` restricts that first hit to the original `q` ordinals. `OtsProbeNonRootExclusion.lean` proves that its non-root branch has probability zero: supported canonical selections have no hidden non-root structural output, whereas `GoodForActualRoot` requires such an output to be present. The existing snapshot and diagnostic couplings transport this contradiction through the complete adaptive execution. Thus `hiddenSelectionCharge` is now only `4/3` times the unpublished-root selection probability, with no non-root term. The actual retained verification event is bounded by `(materializedRetainedCharge (2*q) + sampledHiddenSelectionCharge q) / 2^128`. `OtsProbeRootQueryReserve.lean` computes the exact OTS reserve at an encoding input: a fresh query leaves two units when a canonical encoding target exists, one when only the message is settled, and zero otherwise; a cached query leaves three. In the two-unit case, the local ordinary cost plus `4/3` times the materialized-candidate cost fits that reserve. The same bound follows after an actual signer transition that creates a valid encoding target, and persists under cache extension. This is a local bound, not yet a comparison between the accumulated hidden-root selection charge and the actual execution. `OtsProbePreloadCharge.lean` proves that preloading a root preserves the sum of the unmaterialized and materialized candidate charges, because it preserves the pending guesses and revealed set. For an initially missing target, the preloaded materialized charge equals its original unmaterialized charge. This transfers to the canonical planned query handler, including the root comparison factor `4/3`, so the preload transfers an existing charge instead of creating an additional one. The accumulated comparison still needs to retain this joint charge through the adaptive execution. `OtsProbeJointExecutionCharge.lean` records the sum of those two candidate charges along the permissive oracle execution. Erasing the cost gives exactly `runPermissiveFromTable`; composition adds both costs and preserves earlier costs if the continuation stops. Its recorded and expected costs are bounded by the computation's probe bound independently of the interpreter fuel. `OtsProbeJointCostCoupling.lean` couples continuations with equal stored values and revealed coordinates when the left pending set contains the right one, proving that the left charge cannot increase. This handles the pending guesses retained by a preload when the lazy execution materializes its root. `OtsProbeJointPreloadCoupling.lean` carries that inequality through the complete computation: sampling and preloading an initially missing root has expected joint charge at most the original lazy execution, provided the computation never peeks at that coordinate. The coupling includes early fuel stops and the first reveal. `OtsProbeSelectionHistory.lean` strengthens the canonical selector coupling to preserve the entire candidate history. A selected first private hit therefore transfers to a matching, already stored hidden value whose candidate does not occur among earlier guesses. It bounds the actual retained verification event by `materializedRetainedCharge (2*q) / 2^128 + sampledFreshHiddenRisk q`, where the latter is the sum of these fresh matching-selection probabilities in the delayed selector, with fuel `q`. This alternative reduction retains the match and history conditions that the earlier root-selection mass dropped; it does not yet supply a `2^-128` bound for that risk. `OtsProbeSelectionPending.lean` proves that pending guesses are covered by the earlier history throughout the delayed selector, including hashing, signing, and the initial published root. Consequently every supported fresh hidden hit has materialized charge one and unmaterialized charge zero, without an extra coverage premise. Proving the accumulated probability-to-charge comparison and connecting the charged execution to the actual query allowance remain open. The remaining argument must connect ordinary guesses and hidden-root selections to the actual query reserve without overlapping charges; it must also account for the root probes attached to encoding queries. The forest bound now also has a sharper `19q / 2^133` form: the existing mandatory-query theorem gives `q ≥ 42`, so the exact factor `2q + 1` need not be rounded up to `3q`. `Security126RefinedEndpoint.lean` consequently allows a joint primitive bound of `(10/3)q / 2^128`. `OtsOpeningRefinedReserve.lean` assigns the additional `1/3` per actual hash query to the OTS reserve and proves the corresponding conditional security endpoint. The local weighted ordinary/materialized charge fits this larger reserve at every structural OTS input, including parents above short-layer roots, and at an encoding input whenever its message is settled; a valid encoding target is no longer required for that local case. These are verified relaxations of the remaining accounting target, not a completed probability bound. `EncodingMessagePrehit.lean` records a newly settled layer message matching the payload slot of an earlier cached encoding query. Such a hit lies in the encoding-message or structural-settlement target set already charged by the existing potential. `TightEncodingSelectionPotential.lean` now also proves the transition bound with loss one on those hits, retaining its original theorems as specializations. `TightEncodingPrehitCharge.lean` extends that stopped bound to every fresh hash query with the same refined structural/encoding charge, without a separate prehit charge. `OtsProbeEncodingPrehit.lean` identifies a matching cached root-aware encoding candidate at first settlement with this event. `EncodingPrehitMonitor.lean` lifts this bound through arbitrary adaptive oracle computations. Its monitor continues the entire execution, records an absorbing prehit flag, and projects exactly to the original result and cache. The union of a recorded prehit, a structural collision, and an encoding collision is bounded by the same expected refined structural/encoding charge divided by `2^128`. `EncodingPrehitGame.lean` applies this to the actual complete game, including key generation, signing, and verification, and averages over the sampled secrets. Its verdict projection is exactly `sampledGame`. `EncodingPrehitViewedTrace.lean` and `EncodingPrehitViewedProjection.lean` now run this same monitor through the full viewed execution, including the signer and verifier. Forgetting the flag gives exactly the existing viewed game, while forgetting the trace gives exactly the original monitored verdict, cache and flag. These are equalities of the executed computations, retaining the adaptive signing log and all signer views. `EncodingPrehitViewedBound.lean` transfers both projections through the sampled secrets and proves a new conditional 126-bit endpoint whose OTS premise excludes flagged runs. Structural collisions, encoding collisions and prehits share the existing structural/encoding charge; the few-time opening bound is unchanged. `EncodingPrehitSupport.lean` proves that a flag-free completed execution has flag-free prefixes and continuations, with no prehit at a supported query step. `OtsProbeEncodingPrehit.lean` consequently excludes a matching earlier encoding candidate at its first root settlement on such a step. `EncodingPrehitContinuation.lean` now retains the prehit exclusion at the first fresh transition creating any cache event. Applied to root settlement, it proves that a cached encoding guess made while its root is unsettled cannot match the final honest root if that root becomes settled during a flag-free continuation. It also proves that a matching encoding query on a flag-free run with a settled terminal root already had a settled message when the query was made. This supplies the `4/3` refined OTS allowance at that original query. `OtsProbeEncodingPrehitViewed.lean` transfers both results to arbitrary continuations of the actual viewed adversary, including signing calls; the support projection retains the exact appended signing log. The terminal-root settlement premise remains explicit: a hidden value stored in an auxiliary OTS state does not by itself establish that premise in the real cache. The remaining work is to derive the needed settlement and cache correspondence from the complete adaptive OTS diagnostic and bound its flag-free residual opening probability by the refined query reserve. That probability estimate remains an explicit, unproved premise of the new conditional endpoint. The public unconditional theorem remains 125 bits, and the scheme and game are unchanged. + +Work toward 126 bits is incomplete. `RomQueryCharge.lean` proves additive accounting for query-dependent costs in the actual lazy-oracle execution. `TightEncodingRefinedBound.lean` bounds the terminal structural/encoding event by the expected accumulated charge, in units of `2^-128`. A fresh encoding query costs 1 if its target is fixed, 2 if only its message is fixed, and 3 otherwise. A fresh structural query costs 0 if every answer first fixes its honest value, 1 if the value or all its children are already fixed, and 2 otherwise; unrelated or cached queries cost 0. In particular, every few-time leaf input leaves at least two units for secret-opening risk. `OtsProbeRootBudget.lean` generalizes the root comparison and proves its `4/3` factor for `q ≤ 2^126`. The adaptive forest and message-collision estimates now cover that query range; `FewTime126Bound.lean` bounds the forest term by `27q / 2^133`, and the message term remains `q / 2^139`. `Security126Endpoint.lean` assembles 126-bit security conditional on a `3q / 2^128` bound for the sampled joint structural, encoding, and secret-opening event on winning runs defined in `JointPrimitiveTerminal.lean`. `JointPrimitiveQueryBudget.lean` reduces that joint bound to a residual secret-opening estimate using the unused allowance of each actual hash query; the sum of both charges is proved at most `3q`. `AdaptiveRevealProbeCharge.lean` replaces the full probe budget by an expected charge for distinct guesses against unrevealed secrets, and `FtsProbeQueryCharge.lean` bounds the actual sampled few-time-secret opening event by that charge. `AdaptiveRevealProbeCostExpectation.lean` identifies this charge with the expected recorded cost of a stopped execution whose result projects exactly to the existing probe experiment. `FtsProbeCacheCharge.lean` proves the local cache invariant, the charge paid by new cache entries, their preservation under clean cache translation, and the real execution's expected cache-count bound. The invariant and accumulated cost now propagate through the complete masked signer and arbitrary adaptive execution. `FtsProbeCostComparison.lean` couples the recorded cost to the actual cache count, retaining a `q`-weighted hit term for stopped or compromised runs. `FtsProbeCostBound.lean` absorbs that term at `q ≤ 2^126`, and `FtsProbeQueryBudget126.lean` proves the sampled few-time-secret opening probability is at most `4/3` times the actual experiment's expected few-time-leaf query count, in units of `2^-128`. `JointSecretOpeningQueryBudget.lean` allocates that amount from the residual query allowance and reduces 126-bit security to an explicit remaining one-time-secret estimate, `security126_of_sampled_otsOpening_le_queryReserve`. `LazyRevealProbePending.lean` bounds finalization using only pending guesses whose values have not been materialized. `LazyRevealProbeCharge.lean` bounds the lazy one-time probe experiment by its expected charge for distinct guesses against unmaterialized, unpublished values, and `LazyRevealProbeCost.lean` records that cost on every run while projecting exactly to the original execution. `LazyRevealProbeCostBind.lean` composes completed-run costs and proves zero cost for probe-free computations. `OtsProbeQueryCharge.lean` transfers the expected-charge estimate to the concrete deferred clean execution, using the whole-experiment query bound to rule out fuel exhaustion; the honest masked signer and published-root computation have zero probe charge. `OtsProbeStepCharge.lean` proves that each concrete probing hash handler has expected charge at most the remaining one-time allowance for the same input. `LazyRevealProbeChargeBind.lean` gives exact expected-cost composition, retaining costs before an early stop and the continuation's remaining fuel. `LazyRevealProbeSimulationCharge.lean` lifts local bounds through arbitrary adaptive stateful simulations. `OtsProbeExecutionCharge.lean` applies this to the complete deferred execution, including final verification: its clean-finalization failure probability is bounded by the expected number of outer chain, leaf, and node hash queries reached in that execution, in units of `2^-128`. `OtsProbePlannedCharge.lean` handles the root-aware comparison queries as well: the ordinary probe cost and a separate charge for new materialized candidates sum to at most one per planned query. A query recording an existing-hidden-hit diagnostic has zero ordinary probe cost; the first such hit has materialized charge one under the existing observation tracking and pending-coverage invariants. `OtsProbeOrdinaryCharge.lean` carries the unmaterialized-guess and continuation costs through the existing diagnostic interpreter, including its private-hit and fuel stops. `OtsProbeMaterializedCharge.lean` lifts this bound through adaptive hashing and signing with the existing support and budget guards. `OtsProbeDiagnosticCharge.lean` transfers it to diagnostic finalization and the actual retained-verifier event under the original whole-experiment query bound: that event is bounded by the refined ordinary charge, the successful-doomed diagnostic probability, and the residual private-failure probability. The supporting root-coupling, stopping, and diagnostic-classification lemmas now cover `q ≤ 2^126`. `OtsProbeResidualCharge.lean`, `OtsProbeHiddenRootCharge.lean`, and `OtsProbeHiddenSelectionCharge.lean` bound both hidden-value terms by sums of their actual selection probabilities, with root factor `4/3` and non-root factor `1`. `OtsProbeCombinedCharge.lean` bounds the actual retained-verifier event by the sum of the ordinary and both selection charges, in units of `2^-128`, throughout that range. The complete one-time-secret estimate remains unproved: the joint accounting still needs to connect these charges to the unused allowance of actual queries without double counting overlapping failure mechanisms. The public theorem is still 125 bits, and the scheme and game are unchanged. + +`OtsProbeResolvedComputed.lean` records that a stored structural value and its dependencies have been computed. The recursive resolver establishes this property, and `OtsProbeResolvedComputedInvariant.lean` proves that resolving additional positions preserves it for all stored resolvable positions. `OtsProbeResolvedComputedExecution.lean` carries the invariant from the empty context through arbitrary resolved executions and the complete adaptive canonical interpreter, including signing and canonicalization. `OtsProbeResolvedComputedCoupling.lean` strengthens the existing coupling to real oracle execution with this supported invariant, starting after key generation. Together with chronological cache agreement, it proves that every stored layer root is settled in the real cache and supplies the local encoding-query allowance without a successful-guess premise. That local allowance also transfers across `CanonicalSelectionPreserved`. Connecting the invariant and the real cache to the complete ordinal selector, and proving the accumulated probability-to-charge comparison, remain open. The earlier `OtsProbeRootCache.lean` and `OtsProbeRootCacheTransport.lean` retain and transport cached root computations directly; the dependency invariant supplies a route through the recursive resolver used by the canonical execution coupling. + +`OtsProbeCanonicalCharge.lean` lifts local charge comparisons through the complete canonical adaptive interpreter using its coupling to real execution. Charges incurred before a stopped continuation are retained. `RomQueryChargeBind.lean` and `MappedQueryCharge.lean` connect the outer-query accounting to the full expanded oracle computation, including honest signer queries. `OtsProbeCanonicalJointCharge.lean` instantiates the comparison with the ordinary charge of the original public query plan plus `4/3` times the materialized candidate charge, using the context with private values made visible for accounting. Its accumulated expected charge is bounded by the actual refined OTS query reserve. Encoding queries contribute only for already stored roots; transferring successful earlier guesses to the prehit event remains part of the probability argument. The key-generation and secret-sampling averages are now assembled in `OtsProbeCanonicalChargeRoot.lean` and `OtsProbeCanonicalChargeSampled.lean`: the full sampled canonical charge is bounded by the actual sampled refined OTS reserve. The direct ordinal selector and this canonical accumulated charge still need to be related through a probability bound. No 126-bit theorem is claimed. + +`OtsProbeCanonicalQuerySelection.lean` selects a query before its execution, retaining its input, deferred context and split cache. These ordinals count all outer queries, including uniform sampling and signing requests; their joint OTS charge is zero for non-hash queries. Summing expected selection charges is exactly the accumulated canonical query charge. `OtsProbeCanonicalSelectionCoupling.lean` couples this selector to the same query in the real execution, preserving the cache and computed-dependency invariants. `OtsProbeCanonicalSelectionSampled.lean` extends the coupling through key generation and secret sampling and bounds the sum of sampled selection charges by the actual refined OTS reserve. A stored layer root in a coupled selection is proved settled in the real cache at that query, with the same value. This does not yet transfer the older direct private-candidate selector or bound the prehit-free residual forgery probability. + +`OuterQueryCut.lean` cuts the actual outer computation before a query and retains its continuation; resuming recovers the original computation exactly, and its cache projection is the actual query selector. `OtsProbeQueryCutPrehit.lean` lifts this factorization through the viewed prehit monitor, retaining a false flag on both the prefix and suffix of a prehit-free run. `OtsProbeSelectedRootPrehit.lean` couples the canonical selector to this monitored prefix. It proves that an earlier cached encoding guess cannot match a later stored layer root if the root was initially unsettled and the flag remains false. For a matching encoding query followed by such a selection, it derives the earlier query’s refined OTS reserve from the coupled root invariant. The resulting probability inequality bounds a later selected root match by the prefix prehit probability whenever that earlier reserve is below `4/3`. This is a local prefix bound. The history results below share one prehit flag across the recorded execution; the residual forgery classification and remaining guessing bound are still open. + +`OtsProbeCanonicalQueryTrace.lean` retains the entire canonical query history, including queries reached before a later stop. Its ordinal projections agree in distribution with the canonical query selector, and its expected total charge equals the existing canonical charge and is bounded by the actual OTS reserve. `OtsProbePrehitQueryTrace.lean` records the corresponding monitored real history and projects exactly to the original monitored execution. `OtsProbeQueryTraceCoupling.lean` couples these histories in one run, retaining the cache and computed-root invariants at every aligned query and at successful termination. `OtsProbePrehitTracePairs.lean` and `OtsProbePrehitTraceTerminal.lean` prove that any earlier encoding guess matching a later settled root, either before another query or at termination, has the required earlier allowance unless the final prehit flag is true. The probability of the union of these insufficient-allowance events is bounded by the single final prehit probability, with no factor for the number of query pairs. `OtsProbeQueryTraceReserve.lean` transfers the allowance facts to stored roots in the coupled canonical history and terminal context. These results do not yet classify the full residual forgery event or bound the other guesses by the accumulated charge. + +`OtsProbeQueryTraceProjection.lean` proves that erasing the canonical query history preserves the output distribution of the existing synchronized interpreter on consistent starting states. This equality remains valid under any continuation of the terminal result. Applied after key generation, it records the adversary and signing queries while preserving the existing verifier continuation and retained-game distribution. `OtsProbePublicHashValues.lean` proves that key generation and individual hash queries leave only published values in the materialized state; recursively computed dependencies remain in deferred storage. `OtsProbeCanonicalVerifierTrace.lean` uses this invariant to remove canonicalization between verifier queries and proves equality of finalization-failure distributions, including stopped and uncompletable executions. `OtsProbeCanonicalRetainedTrace.lean` joins key generation, adaptive signing and the verifier into the complete recorded trace. Its finalization-failure distribution equals that of the original canonical retained reduction, so the existing winning verifier-probe event is bounded by its failure probability. Its expected joint charge equals `canonicalJointChargeAfterTable` and is bounded by the actual refined OTS query reserve. The remaining argument must classify the residual forgery failures on prehit-free runs and bound their probability by this accumulated charge; the unconditional security theorem remains 125 bits. + +`OtsProbeCanonicalTraceSupport.lean` strengthens the verifier connection from equality of failure probabilities to support of individual successful executions. The complete canonical trace now retains the public root, and every successful result is a supported original canonical retained result with a completable context. Consequently a related real verifier-probe witness cannot accompany a successful canonical trace. `OtsProbeRetainedPrehitTrace.lean` couples the complete canonical history to the monitored real history, including key generation, and retains the implication from a real verifier-probe witness to canonical termination with `none`. The prehit flag and aligned query histories stay in this same coupling. `OtsProbeRetainedPrehitProjection.lean` proves that its verdict, cache and prehit flag project exactly to the original whole-game monitor. The joint prehit, structural-collision and encoding-collision event therefore has the unchanged refined structural/encoding charge bound. Bounding the remaining prehit-free stopping probability by the accumulated OTS charge is still open. + +`OtsProbeCanonicalFuel.lean` bounds the real query history using only supported replies of the expanded concrete signer, and transfers that bound to the canonical prefix. With auxiliary fuel `q + 1`, every recorded canonical query has positive fuel. `OtsProbeCanonicalStopping.lean` proves that the initial published-root computation cannot reject and always leaves a completable context. Every stopped canonical trace consequently ends at a query whose execution rejects or leaves an uncompletable context. The full retained coupling carries this last-query classification together with the actual public root, prehit flag, aligned histories, and the winning verifier-probe implication. These results exclude root initialization and fuel exhaustion as extra failure allowances. Bounding the rejection probability by the existing joint charge remains open; the public security theorem remains 125 bits. + +`OtsProbeCanonicalRejectionProbability.lean` proves an exact stopping identity: the probability that the canonical trace returns no result equals the expected sum of its reached queries' rejection probabilities. A query rejects when its canonical execution returns no result or leaves an uncompletable context. The identity lifts through the published-root computation and bounds the actual retained verifier-probe event without a separate finalization term. This is a probability identity, not yet a comparison with the OTS reserve. `OtsProbePrehitOpeningProjection.lean` preserves the root, forgery, signing log, final cache and prehit flag while projecting the viewed and retained games to a common result. It transports the prehit-free residual OTS opening event to the retained verifier-probe event, including the complete parameter and secret sampling. The remaining estimate must bound this prehit-free retained event by the refined OTS reserve, attributing rejections to the earlier guesses that caused them rather than necessarily to the query that reveals them. + +`OtsProbeCanonicalPending.lean` proves pending-guess provenance for the recursive canonical interpreter, through the published root, signing, hashing and canonicalization. Every pending guess at a recorded query comes from a strictly earlier planned query, and the pending count is bounded by the coupled real hash-query budget. `OtsProbeCanonicalPendingHit.lean` rules out digest-space exhaustion in the 126-bit range: a supported query returning an uncompletable context has a matching fixed-value candidate from the current or an earlier query. It also splits the query's rejection probability exactly into returning no result and returning a context containing a pending fixed-value hit. These are provenance and classification results; a planned candidate need not be a fresh inserted guess. Bounding recursive rejection and fixed-value hits by the accumulated OTS charge remains open, and the unconditional public theorem remains 125 bits. + +`OtsProbeRecursiveRejectionRisk.lean` proves that a pending fixed-value hit makes finalization fail with probability one. Below the digest-space limit, this covers every uncompletable valid context and removes the completeness premise from the recursive reveal's finalization comparison. Resolving a position, materializing its result and finalizing the remaining pending guesses has exactly the initial finalization-failure distribution. The corresponding risk identity retains both immediate rejection and the expected remaining risk, including returned uncompletable contexts. It transfers to the native `revealCoordinate` interpreter and bounds that action's rejection probability by its initial pending-failure risk. The remaining argument must carry this risk through complete query execution and bound the increases caused by guesses, including hidden-root guesses, by the accumulated OTS allowance. + +`OtsProbeProbeFreeRisk.lean` extends the finalization-risk identity through every native interpreter computation that introduces no guesses. The induction includes recursive position reveals, chain-start reveals, sampling, bookkeeping and computations that reject midway; uncompletable contexts are included. Canonicalization preserves the finished failure distribution too. Consequently an outer uniform or signing query, including the complete concrete signer and its internal hashes, preserves the initial risk when its rejection and remaining finalization risk are counted together. Its immediate rejection probability is bounded by the initial pending-failure risk. The remaining work is to bound the risk increases caused by hash-query guesses, including hidden-root guesses, and combine those bounds through the complete adaptive trace with the existing query allowance. + +`OtsProbeHashRisk.lean` isolates the single planned guess in a complete canonical hash query. At positive fuel and below the digest-space limit, executing the query and finalizing has exactly the failure distribution obtained immediately after that candidate is executed. The suffix adds no risk, including when the guess has already made the context uncompletable. Canonicalization is handled for all contexts with consistent values and chain-start tables. The resulting query-rejection bound uses the candidate's actual state transition, preserving skipped and repeated guesses. Repeating a pending guess leaves risk unchanged; adding a guess that misses a known fixed value also leaves risk unchanged, while a fixed-value hit makes the auxiliary completion test fail. The missing probability estimates concern fresh unknown values and hidden-root hits, followed by accumulation over the complete adaptive trace. These identities do not establish the 126-bit theorem. + +`OtsProbeFreshGuessRisk.lean` proves the local probability increment for an unresolved structural value: adding one pending guess increases the context's failure risk by at most `2^-128`, without charging its earlier pending guesses again. A common finalization order preserves the continuation after the selected value is sampled; the only additional failure event is the new digest match. The bound applies below the digest-space limit and includes already uncompletable contexts. The resulting candidate allowance is zero for skipped or duplicate guesses and known-value misses, `2^-128` for an unresolved value, and a hit indicator for a value already fixed in the auxiliary table. A complete canonical hash query, including its remaining finalization risk, is bounded by its initial risk plus this allowance. The fixed-value indicators still need a bound averaged over the sampled secrets, including chain starts and hidden roots, and the local increments still need to be accumulated over the complete adaptive trace. The public unconditional theorem remains 125 bits. + +`OtsProbeRiskAccumulation.lean` accumulates the local candidate allowances through the complete adaptive canonical trace. The bound counts both rejection and the expected remaining finalization risk, so earlier pending guesses are not charged again at each reveal. An auxiliary allowance of one covers invalid fuel or digest-space states; the coupled real query budget excludes those cases at every recorded query in the 126-bit range. `OtsProbeRetainedGuessCharge.lean` proves that the published-root prefix has zero initial risk and lifts the accumulated bound to the actual retained verifier-probe event. This completes accumulation of the local allowances, but does not bound their fixed-value hit indicators by the refined OTS reserve. That sampled probability comparison must still handle chain starts and hidden roots while preserving the prehit-free restriction needed by the reserve argument. The unconditional public theorem remains 125 bits. + +`OtsProbeSampledGuessRisk.lean` averages the candidate allowance over a fresh completion of the unmaterialized chain-start table at a fixed context. Missing chain starts cost at most `2^-128` per fresh guess, with zero allowance for repeated or revealed guesses. Structural guesses split exactly into the ordinary unmaterialized charge and a fixed structural-value hit indicator. This gives a complete hash-query risk bound under that completion-table sampler. `OtsProbeGuardedStartRisk.lean` accounts for conditioning this sampler on the context being completable: when the context is valid, has no private structural hit, and has at most `2^126` pending guesses, the completeness event has probability at least `3/4`. The guarded chain-start allowance is consequently at most `4/3` times its ordinary charge in units of `2^-128`, multiplied by the completeness probability. `OtsProbeGuardedTraceRisk.lean` proves the validity and absence of private structural hits at every reached canonical query and obtains the pending bound from the coupled real query budget. These results concern fresh table completion at a fixed snapshot; they do not yet identify that distribution with the actual adaptive execution's conditional table distribution. That distributional connection and the corresponding hidden-root probability bound remain open. The unconditional public theorem remains 125 bits. + +`OtsProbeStartTableInvariance.lean` proves that structural resolution has the same distribution for any two start tables that avoid the current pending chain-start hits. The proof covers positive chain prefixes, all chains of a leaf, tree nodes and the complete structural reveal. An internal chain-start resolution checks pending guesses and clears them without retaining the start value. The native outer reveal keeps the original pending set except at its explicitly materialized coordinate; internal clears alone therefore do not imply that those exclusions disappear from the outer snapshot. `OtsProbeStartHistoryRisk.lean` therefore filters fresh table completions using all earlier planned candidates whose start values remain unmaterialized. A history of at most `2^126` candidates excludes at most one quarter of the sampling mass, giving the same `4/3` conditioning bound. If that history covers the pending set, passing its filter implies absence of missing chain-start hits and gives the structural-resolution invariance above. `OtsProbeStartCandidateMiss.lean` proves that a supported canonical hash query returning a completable context could not have guessed an unrevealed chain-start secret correctly: completeness propagates backward through the query suffix to the candidate insertion. The remaining distributional argument must connect this history filter to the actual adaptive table distribution; the hidden-root probability estimate also remains open. The unconditional public theorem remains 125 bits. + +`OtsProbeStartHistorySupport.lean` proves monotonicity of revealed coordinates through the recursive native interpreter and canonical queries. A query returning a completable context preserves misses for all earlier unrevealed chain-start guesses and adds its own planned candidate to that invariant. `OtsProbeStartHistoryTrace.lean` lifts this through the entire adaptive trace and published-root prefix. With fuel `q + 1`, every reached canonical snapshot passes the history filter for its actual start table. The coupled hash-query budget also gives the `3/4` lower bound for sampling a table that passes the entire earlier history. Structural reveal has the same distribution after replacing the actual table by any completed table passing that filter. `OtsProbeStartHistorySampling.lean` proves an exact sampling identity for reading an unmaterialized start: first sample its output and reject any earlier matching guess, then materialize that output and sample the remaining filtered completion table. The identity permits arbitrary continuations and retains their table argument. These establish the support invariant and the secret-read sampling step; the complete adaptive distributional connection and hidden-root probability bound remain open. The unconditional public theorem remains 125 bits. + +Everything the claim depends on is in the single module `SphincsSecurity/Statement.lean`, in the order a reviewer needs it: the concrete parameters and types with the tweak and byte layout of every hash input and the target-sum code, the three algorithms with the oracle calls they make, then the strong-unforgeability experiment and the claim. It follows `formal/xmss`, whose statement module is the model for this one and whose proof machinery provides the shared foundations. + +## What the game says + +Key generation samples the public parameter, one secret per Winternitz chain of every layer, tree and leaf, and one per few-time leaf of every instance, then builds layer 0's tree for the root. Signing draws a fresh randomizer per digest attempt until the digest's last index group is zero, opens the few-time forest, and produces one one-time signature per layer, recomputing through the random oracle whatever tree it needs; the proof models independently sampled secrets and does not establish equivalence to the implementation's seed derivation. Verification is the ordinary verifier. Key generation, the adversary, the signing oracle and the final verification share one lazily sampled oracle, and `q` bounds the hash queries of the whole experiment. + +Three things differ from the XMSS statement, all because this scheme is stateless. + +- A signing request is a message, with no epoch. What the game caps is therefore the number of signing queries, at `signatureLimit = 2^24`, rather than forbidding a repeated epoch. +- Signing is randomized, so one message has many valid signatures. The game rejects only a signature the signer actually returned for that message, which is what makes the claim a strong-unforgeability claim. +- The secret key holds the sampled secrets instead of precomputed tables, so signing queries the oracle for the chains, nodes and forests it reads, rebuilding a tree rather than caching it. The honest experiment therefore spends `2^44.5` hash queries of its own, against the `2^41.5` a real signer with the cache of `doc/sphincs/main.tex` pays. What the query bound counts is the worst-case path rather than the average, which the `2^32` digest and counter caps push to exactly `2^58`. + +Every component of the `Signature` structure is read by verification, the authentication path being the `h` nodes of the `d` layers laid end to end. That matters, an unread component making the strong-unforgeability game trivially winnable by perturbing it, so `signaturePath_flattenPaths` and `authPath_exhausted` prove that the verifier reads a layer's node exactly where the signer laid it and that no entry goes unread. The index decomposition is proven the same way rather than asserted: `treeIndexAt_topLayer`, `layers_link_top`, `layers_link_middle` and `leafIndexAt_bottomLayer` hold for all `2^26` indices. + +## The 125-bit bound + +The theorem states `forgeAdvantage Concrete.scheme adversary ≤ q / 2^125` for every positive whole-experiment hash-query budget `q` and every classical adaptive adversary satisfying that bound. It allows at most `2^24` signing requests per key pair, including repeated messages and failed requests. The query budget bounds every execution path, including key generation, signing and final verification; it is not an average-cost or adversary-only budget. + +For `q ≤ 2^125`, the retained-verifier event costs at most `(23/7)q / 2^128`. The remaining terms are `4q / 2^128`, `3q / 2^131` and `q / 2^139`. Their sum is below `q / 2^125`. For larger `q`, the endpoint uses the universal probability bound of one. + +## Status + +`Proof/Security125Completion.lean` closes the 125-bit theorem without an unproved probability premise. `OtsProbeDiagnosticJoint125.lean` bounds diagnostic badness by `(15/7)q / 2^128`, and `OtsProbeResidual125.lean` bounds the residual by `(8/7)q / 2^128`. `OtsProbeJointClassification.lean` shares the diagnostic charge between ordinary failure and private-root failure. The exact execution projections transfer their sum to the original retained-verifier event, and `Security125Endpoint.lean` combines it with the other terminal bounds in the original SUF game. + +The root and non-root estimates retain their mutually exclusive selection probabilities. `OtsProbeNonRootSelectionMass125.lean` proves freshness at selection time. `OtsProbeSelectionTransport125.lean` transports canonical selections to the delayed common execution, and `OtsProbeSelectionSchedule125.lean` connects the delayed and root-aware common selectors despite their different probe schedules and fuel budgets. These comparisons cover key generation, adaptive hashing, uniform sampling and signing. + +The forest estimate is in `FewTimeHonestLeakBound.lean`; it covers earlier direct targets and targets first queried by verification, and eliminates signer-sourced proper-leak targets. `TightEncodingTerminal.lean` bounds structural badness together with encoding collisions by `3q / 2^128`. The additional uncovered-secret term contributes `q / 2^128`, and `MessageCollision125.lean` supplies `q / 2^139`. + +The public theorem depends only on Lean's standard `propext`, `Classical.choice` and `Quot.sound`. There is no `sorryAx`, custom security axiom or `native_decide` dependency. The scheme, game and query-bound definitions are unchanged from the 120-bit result. `securityBits = 120` and `SphincsSecurityStatement` are retained for compatibility with that earlier proof; `SphincsSecurity125Statement` explicitly uses exponent `125`. + +## Earlier development notes + +The following notes record intermediate proof stages. References to unfinished obligations and earlier constants describe those stages, not the current status above. + +## What is proven + +Correctness (`Ver` accepts honest signatures, against every answer function, which is what rules out the claim holding vacuously); domain separation and the injectivity of every payload in the scheme; incomparability of the target-sum code; the one-guess bound `2^-n` at the digest length and at any width, including the index a fresh digest selects; the accounting `(c * q + potential) * eps` for an arbitrary bad event on the oracle's cache; the complete `c = 44` instantiation bounding the structural `Bad` event; deterministic extraction and classification of a winning execution into `Bad` or one of six terminal events; replay of every successful signing-log entry; the finite few-time cover and its exact pattern count, whose uniform-view union is at most `2^-122`; and an observational game that retains each signer invocation's initial and final oracle caches and every query issued directly by the adversary while projecting exactly to the original game. The signer trace is chronological. It selects the first occurrence of each cover entry and proves that every retained entry is a genuine signer run, both endpoints lie below the final cache, every distinct cover entry maps injectively to its signer interval, and each selected successful digest input changes from a cache miss to a cache hit unless it was already present before that signer invocation. No earlier successful signer invocation can have used the same message-digest input as the selected first occurrence. The full trace also records the cache interval of every outer adversary query, preserves the exact order of the signer-only projection, and forms a cache chain from key generation to verification. Key generation queries only structural positions, so its root cache contains no message-digest input. Consequently a selected digest already cached before its signer invocation has an exact earlier source: either the adversary directly queried that input or an earlier signer invocation inserted it. The signer-source branch is now eliminated. If that earlier signer inserted an admissible selected digest, its retry loop necessarily selected the same randomizer and digest; deterministic replay then makes it return the same successful signature, contradicting the cover's first-occurrence property. Thus every selected prehit has an earlier direct adversary query at exactly that input. That direct interval starts with a cache miss, is a genuine fresh random-oracle run at the selected digest input, returns an admissible answer whose retained view is exactly the cover entry's view, and the source intervals for distinct prehit entries can be chosen injectively. Filtering the interval trace shows that their number is at most the length of the direct hash-query list, with outer signing and sampling queries excluded. Embedding the distinct fresh inputs into the final oracle cache further bounds their number by the complete query budget `q`. For a fixed reference cache, a uniform signer randomizer hits at most the number of matching message entries divided by `2^128`; following the actual capped digest loop gives the signer-level bound `digestAttemptLimit * cachedMessageEntryCount * 2^-128` for a completed signature whose selected input was already in that cache. The refined form counts only admissible cached entries whose answer view satisfies an arbitrary predicate and carries that same predicate through the complete signer, so rejected attempts do not populate the count and the randomizer-reuse charge remains conjoined with the coverage constraints. A generic cache-size theorem proves that a run adds at most one entry per hash query and no entry per uniform-sampling query. Applied to the secret-split game, every signer interval's initial cache, and therefore every predicate-filtered admissible message-entry count in it, is at most the complete query budget `q`. The bit layout is now connected to the counting model as well: splitting a fresh 256-bit oracle answer into low and high bits is bijective, decoding the low 166 bits into the 26-bit index and fourteen retained 10-bit leaf coordinates is bijective, and therefore the induced `FewTimeView` is exactly uniform. The complete 176-bit message digest is also proved bijective with `FewTimeView × FtsLeaf`, so the final 10-bit admissibility group is independent of the retained view. The probability of an admissible fresh answer satisfying any retained-view predicate is now exactly `2^-10` times that predicate's uniform-view probability. The cap-only prehit estimate is retained but is too weak for the final range, so it is no longer the intended combination. A generic weighted prefix split preserves the retry probability in a cached-hit, retry, or ordinary-stop race. For the concrete digest attempt, a cache of at most `2^121` entries is missed with probability at least `1 - 2^-7`, and a fresh attempt succeeds with exact probability `2^-10`, giving fresh stopping probability at least `2^-11`. One attempt grows the cache by at most one. The complete retry-loop induction preserves `working cache size + retries remaining ≤ 2^121` and bounds a selected favorable prehit by `cachedMessageEntryCountWhere * 2^-117`, with no `digestAttemptLimit` factor. This bound is now carried through the complete signer: for any predicate on the retained view, a prehit successful signer costs `cachedMessageEntryCountWhere * 2^-117` whenever its initial cache is at most `q ≤ 2^120`. The arithmetic endpoint proves that this cached race cost, combined with the source's `2^-10` admissibility cost, gives effective weight `2^-127`; for `q ≤ 2^120`, the resulting fourteen-entry inflation `(129 / 128)^14` is at most `2`. Lifting the fresh and prehit signer bounds through the adaptive trace remains open. The direct trace proves that a predicate query bound controls the length of its matching query list. A proper leak also forces the forged message-digest input to differ from every selected signer input. `FtsCoverAt.bottom_ots_eq` records the point relevant to key reuse: any two successful signatures at the same few-time index have identical bottom-layer counters and chain values, because that layer signs the fixed few-time public key and the counter search is deterministic. + +The proof-only viewed game now projects exactly to the existing full trace and to the secret-split game. Its support invariant pairs the view list with the signing trace in order, and every successful position recovers the exact digest-loop selection and post-digest run that produced its view. The game also retains the forgery's verifier view and proves that it is the view of the exact message-domain oracle answer used by verification. Combining these facts with the full-trace invariants gives the deterministic probability bridge: every supported `ProperFewTimeLeak` makes the concrete aligned signer views and concrete target view satisfy `SomeFewTimePatternHit`. A proof-only completion replaces absent optional views by uniform values and pads an adaptive transcript to `signatureLimit`, preserving every selected successful position and embedding its cover pattern into the fixed index space. Forgetting those completion and padding draws is now proved to recover exactly the viewed execution distribution. The corresponding ideal padded sampler is proved exactly uniform, so its pattern probability is the existing `2^-122` bound without a union over transcript lengths. The digest retry loop now carries the invariant that every message input inserted after its reference cache contains an inadmissible answer. Consequently, for any predicate on `FewTimeView`, a successful signer whose selected digest input was initially missing satisfies that predicate with probability at most one uniform view's probability, with no `digestAttemptLimit` loss. The selected cover entries now also have one injective origin map into the disjoint union of signer positions and direct-query intervals. A fresh entry maps to its own signer position. A prehit maps to its injectively chosen earlier direct source, whose query starts from a cache miss, returns an admissible answer and has exactly the selected entry's view. The prehit sources are now numbered injectively in the filtered direct hash-query list, so signing and sampling intervals are excluded from the source index space. Transporting the prehit finset through the cover's equivalence between entries and selected pattern positions constructs the exact `OriginConfiguration` used by the ideal count and preserves its cardinality. A path-sensitive query-bound theorem now proves that every supported full trace has at most `q` direct hash intervals. It charges a direct hash call by one and follows only concrete signer replies in support, so it does not require a structural bound over impossible replies. Consequently every prehit is labeled by its actual direct-query ordinal in `Fin q`, which is the source space required by the adaptive induction. Looking up that numbered slot in the filtered trace now recovers the exact digest input and source answer, while the paired full interval proves that the query was fresh, admissible, and had the selected entry's view. The resulting `OriginConfiguration.RealizedBy` relation is now constructed for every concrete cover: its prehit subset is exact, and every configured source slot carries those query and interval witnesses. For a fixed selected set, the weighted sum over every prehit subset and every injective assignment to at most `q` direct sources is at most `(1 + q * 2^-127)^distinct`. An ideal sampler now realizes each configuration with exact probability equal to the old fixed-pattern probability times `2^-127` per prehit, and the sum of all ideal configuration probabilities is definitionally the weighted pattern bound. Combining this with the exact few-time pattern count proves that the ideal origin union totals at most `2^-121` for `q <= 2^120`, so key reuse consumes only the planned one bit over the uniform `2^-122` bound. The signer race now accepts a reference cache smaller than the cache from which signing starts. Restricting that reference to one fixed direct-source input gives at most one matching cached message entry, so later reuse of that exact source costs at most `2^-117`, independently of the rest of the cache. Combined with the source answer's `2^-10` admissibility cost, this is the intended `2^-127` local weight for one prehit origin. The adaptive trace induction that composes these local bounds remains open. + +The local source composition is now formalized too. A fresh direct random-oracle interval exposes the exact `2^-10` admissibility factor at the oracle level, and a generic gated-bind lemma multiplies that source probability by the conditional bound for the remaining execution. Its fixed-prehit specialization gives the uniform-view predicate probability times `2^-127`. Applying this rule at the configured query and signer slots in the adaptive trace remains open. + +The local rules also preserve a view-dependent remaining risk instead of replacing it by a worst-case constant. A fresh selected signer is bounded by the finite expectation of that risk under one uniform `FewTimeView`. A fixed-input prehit signer multiplies an arbitrary continuation event by `2^-117`, and its earlier fresh direct source supplies admissibility and the same uniform-view expectation, producing `2^-127` times the expectation. These are the query and signer cases required by the adaptive recursion. + +Origin configurations now pad from the execution's actual signing-log length into the fixed `signatureLimit` index space. The selected-position equivalence preserves the prehit subset and its cardinality, transports every injective direct-source assignment unchanged, and lifts `OriginConfiguration.RealizedBy` with all exact query and cache-interval witnesses. Consequently every supported cover has a realized padded configuration under the global query budget, so adaptive transcript lengths require no additional union bound. + +The padded configuration now has unique lookups by chronological ordinal. `sourceAt?` identifies the prehit assigned to a direct-query slot, and `selectedAt?` identifies the pattern entry assigned to a signer slot. An `OriginObservation` records the source input and view or the fresh signer view at those slots, with update and noninterference lemmas ready for the recursive probability invariant. + +A proof-only origin monitor now follows one padded configuration through the viewed adversary handler. At configured direct slots it records only fresh admissible source answers; at configured fresh signer slots it records the selected view; at configured prehit signer slots it checks reuse of the recorded exact input and view. Forgetting the observation, ordinals and validity bit projects query by query, and through every simulated adversary computation, exactly to the existing viewed full trace. + +The local source and signer estimates are now available in expectation form, so an arbitrary continuation cost can depend on the retained view without taking a maximum over views. A generic weakest-precondition recursion over a stateful oracle simulation is proved equal to the expected postcondition of the resulting probabilistic run. These are the semantic ingredients for the remaining monitor supermartingale. + +The monitor now has a partial-observation potential. It fixes every selected view already observed, completes all unseen selected positions uniformly, and multiplies by `2^-127` for every pending direct source or by `2^-117` after that source has been seen but its signer reuse remains pending. Its initial value is exactly the ideal fixed-configuration probability. Recording a fresh selected signer preserves the potential in expectation, and recording a source followed by its fixed-input reuse converts one `2^-127` factor exactly into the local `2^-10` and `2^-117` costs. Schedule coherence supplies the required facts that a configured source and fresh signer have not already recorded their view. Preservation of this potential through the complete monitored adversary handler remains open. + +The partial potential is now proved to be a one-query supermartingale for the actual monitored handler. Uniform queries preserve it. An unconfigured direct hash or signing query preserves it, a failed configured obligation sets it to zero, a configured fresh direct source uses the exact admissible-view expectation, a configured fresh signer uses the signer-level uniform-view domination, and a configured prehit signer consumes its `2^-117` factor through the fixed-input race theorem. The theorem is uniform in the continuation event and assumes only schedule coherence and the cache-size hypothesis needed by the prehit race. Proving those hypotheses along every reachable recursive continuation remains open. + +The adaptive fixed-configuration induction is now complete. Schedule coherence is preserved by every direct and signing transition and therefore by every simulated adversary computation. The cache condition is absorbed into a capped potential that becomes zero above `q`; oracle caches only grow, so the capped potential remains a supermartingale without a separate recursive cache invariant. A terminal state that is valid, has discharged every pending source and reuse, has observed every selected view, satisfies a fixed view predicate and remains within the cache cap contributes one unit. Consequently its probability is at most the ideal uniform-view probability times `2^-127` per configured prehit. Concrete realization now pins every fresh source interval to the exact filtered direct-query ordinal watched by the monitor, retains that the source precedes the selected signer interval, identifies that interval with the cover entry, and records its exact filtered signer rank. Validity plus exhausted source and signer ordinals is proved to imply the terminal `Complete` predicate. The retained intervals and signer views determine the monitor fields by a pure chronological replay, and this replay is proved equal to the live monitor through every supported adaptive computation. Concrete realization now proves every replay transition good, so the final replay has the expected source inputs and selected views. Its physical direct and signer counts discharge all configured obligations, forcing the live monitor into `Complete`, and its observation satisfies the exact fixed padded pattern event. The origin-weighted ideal sampler now exposes a finite table of candidate target views too. Evaluating any fixed candidate recovers exactly the old configuration distribution, so the candidate union costs only the table length; after summing every pattern and origin configuration, `N` candidates cost at most `N * 2^-121`. The concrete target's cache origin is classified as well. It is either fresh at final verification or has a first insertion in the retained outer trace, and such an interval must be the exact direct hash query or a signer invocation. These candidate-producing intervals are filtered into their own chronological ordinal space, with final verification as the last candidate. A sharper stream retains only fresh direct inputs and fresh selected digest inputs of successful signers. Chronology embeds these positions injectively into the final oracle cache, so their count is at most the cache cardinality and hence at most `q` in every supported viewed game. The monitor projection is lifted at event probabilities, and the deterministic terminal implication plus replay invariants prove the complete ideal bound for every fixed cover, configuration and target. What remains for the few-time bridge is to show that an admissible target first inserted by a signer is necessarily that signer's selected digest, expose the resulting candidate view to the monitor, and sum the adaptive target and configuration choices. + +The support-level descent is now lifted to probabilities. The winning probability after the secrets are fixed is at most the amortized structural term `44q / 2^128` plus six named terminal probabilities: fresh layer openings, encoding collisions, backward chain openings, message-digest collisions, proper few-time leaks, and uncovered few-time secrets. This decomposition keeps the common accepting-forgery witness in every branch, so later bounds can use the transcript validity, the distinct forgery, the admissible digest, and the cache answer function without reconstructing them. + +## The shape of the proof + +The whole probabilistic side is one lemma, `Amortized.probEvent_bad_le_amortized`. Give it a predicate `Bad` on the random oracle's cache, a potential `Nat` on caches and a constant `c`, prove that a fresh answer on an uncached input turns the cache bad only by landing in a finite set of digests whose size the potential pays for up to `c` per query, and it returns `(c * q + potential) * eps`. Nothing else about the oracle is needed: no presampling, no reprogramming, no hybrid. + +That shape is forced by what the forgery has to hit. Every hit the extraction produces is "a payload other than the honest one, hashing at the same tweak to the honest value there", and the honest value is itself an oracle answer, drawn during the run. So no fixed map on inputs can name the honest partner of an input, and a bound quantified over such a map cannot be instantiated. What replaces it is a cache-local event. A tweak names one structural position (`Bytes.tweakBytes_injective`), a position has one honest payload, and that payload is *determined* by the cache as soon as every honest query below it is cached, in the sense that all answer functions agreeing with the cache agree on it. `Bad` is then: some domain is determined, its honest input is cached, and some other cached input at the same domain has the same truncated answer. + +The charges a fresh answer faces, and what pays for them: + +- an adversarial input at a domain whose honest input is already cached and determined: one target, paid by `c`; +- the honest input at such a domain, queried fresh: one target per cached input at that domain, each of which deposited a unit when it was cached and had no honest counterpart to hit yet; +- the answer that *determines* a domain, one query being the last honest query below it: the domain's honest input is fixed only now, and may already be cached, so one target per cached input at that domain, each of which deposited one unit per undetermined slot of its own domain's payload. + +Each honest position feeds exactly one parent, so one answer determines at most one domain and the third charge happens once per slot. The potential is therefore the sum, over cached inputs at a structural domain, of one plus the number of that domain's slots still undetermined, and `c` is `2` plus the widest payload, the `v = 42` chain endpoints of a leaf. That is `log2 44 = 5.5` bits of the `8` the claim leaves, against `2^-122.9` for the few-time leak: the two together stay under `2^-120`. + +The frame splits the game at the secret sampling rather than after key generation. Key generation's own hash queries then belong to the accounted run, so the accounting starts from the empty cache, at potential `0` and trivially clean, and no fact about what key generation leaves behind is needed. + +`PairBound` was deleted rather than kept: it bounded the same sum through a fixed partner map on inputs, which is exactly what the honest value's run dependence rules out. + +## Proof development history + +The completion audit now works backward from `security_of_sampledWinningRetainedVerifyProbe_le_mul`. The stopped relation is projected at one chronological ordinal before splitting its coordinate kind, so the selected structural alternative is charged once. The apparent hidden chain-start alternative is eliminated at support level: the published root and signer issue no probes, the direct hash handler performs its single probe before its probe-free public action, and `ChainState.ValidFor (fun _ => True)` proves that every materialized chain coordinate is already revealed at each outer boundary. This invariant is compiled through the complete retained run. The root-swap audit found one necessary comparison-root exception. Eager fixed-position normalization and selector domination are proved, but their failure-aware Boolean marginal is deliberately not a final endpoint: it also accepts unrelated doomed runs and would repeat that mass across root-position fibers. A shared-prefix interpreter now runs the observed execution and ordinal selector together until selection or failure is fixed, then continues only the observed side, and its observed projection is proved exactly equal to the real materialized boundary. The audit of its other projection found an intentional mismatch in the older exchangeable selector: the real handler executes a root-aware encoding probe after recording its candidate, while the older selector suppresses that proof-only probe. The shared interpreter therefore has a new root-aware failure-retaining selector as its second projection, and that marginal is also proved exactly. The weighted one-guess bound for this root-aware selector and the reverse fixed-ordinal transport are now complete. The reverse transport starts from the ordinary cache, crosses the canonical materialized state, installs the hidden target cache without changing its ordinary projection, and retains the public root; its endpoint directly bounds the successful observed good-comparison fiber by the root-aware production mass times `2^-128`. The comparison-root exception is now absorbed at every fixed target: for `ordinal < q ≤ 2^120`, its coefficient is at most one half, so the complete target fiber is bounded by the same production weight times `2 * 2^-128`. The explicit high/root eager sampler in that production weight is now exactly normalized to the ordinary deferred resolution of the selected position for every supported public-root result. The delayed source branch now records the root-aware candidate while executing only the source hash action, and its coupling retains the dynamically sampled target output, selected candidate, target position and target value through the common permissive selector. This removes the unsound fixed-partner formulation. The delayed selector now has the weight-preserving root-swap endpoint. A tagged factorization retains the dynamically sampled full target output through the signer-dependent continuation, exchanges only its root digest, and bounds the delayed guess by the disjoint target fiber of the common selector times `2^-128`. This endpoint is connected back through the fixed-root private selector and the concrete delayed-good comparison event. A source-support invariant now proves that every stored snapshot came from the root-aware planner and therefore carries a structural parent. Nonempty delayed fibers satisfy the exchange hypotheses, empty fibers have probability zero, and the existing ordinal aggregation yields the complete `2q * 2^-128` delayed residual. The canonical witness source is now proved candidate-covered and its diagnostic, delayed and non-root branches combine to the honest conservative bound `8q * 2^-128`. This corrects the stale seven-unit target: the delayed comparison costs two units, so the existing `2 * c + 1 ≤ 19` terminal interface cannot simply accept the resulting ten-unit boundary. What remains is to transfer the canonical estimate to the granular Boolean event and avoid double-counting the fresh and backward terminal classifications, which both reduce to the same verifier-probe witness. Each stage is compiled and committed before the next. The key soundness checkpoint is that no already-materialized hit is charged as fresh randomness, no global failure mass is copied across fibers, and no produced-list probability weight is discarded. + +The one-time branch now has a complete masked signer and game skeleton. It performs the concrete digest and counter searches, reserves the exact chain prefixes and Merkle subtrees queried by signing, reveals and publishes returned chain and path values only after every layer succeeds, handles adaptive signing requests, and runs verification through an injective probing decoder. A failed signer leaves its reserved values opaque, so a later correct adversarial probe is still charged. The lazy world has probability-neutral reads for materialized cells and an explicit publication operation for public cells, allowing exact public chain, leaf and node inputs to resolve to their hidden successor without sampling opaque cells. Completed hidden tables now reconstruct an exact ordinary cache and total answer function, and deterministic chain and Merkle evaluation under that answer function recovers every table value. Hidden-cache consistency is preserved through every primitive, all masked tree and signer computations, the traced adversary computation and finalization. A retained masked game now exposes the root, forgery, signing log, verifier result and final cache, and its ordinary counterpart projects exactly to the existing viewed signing-trace game. The proof-only terminal predicates are now bound to the exact forged signature and digest-selected index. Deterministic descent supplies a `ForgedLayerObstacle`, whose fresh and backward branches keep the forged layer, tree, leaf, counter, chain values and path rather than selecting unrelated cached work from a signer that later returned `none`. The refined events project through both the viewed and retained games, while the public statement and six-way descent remain unchanged. Reuse of one one-time position is also pinned formally: every successful signer there has the same message, least counter and codeword. A covered-coordinate predicate records the forward closure of every published chain value, and both exact forged opening events now extract a correct cached probe outside that closure. The resolved coupling now retains both the structural computations already pinned by the hidden state and the exact public signer computations. It also carries materialization of every published coordinate as a compositional invariant, including a dedicated reveal-then-publish rule, so adaptive binds cannot lose the fact needed when a later probe skips an already revealed source. The complete adversary hash handler now inhabits that coupling. Decoded chain and leaf queries either consume materialized predecessors, record the first unresolved source with exact fuel accounting, or enter the explicitly doomed branch. Undecoded node queries scan their two children before the same canonical, ordinary or doomed split, including the invalid nodes that `Position` deliberately over-approximates. All remaining domains reduce to stable ordinary queries. This handler and the complete masked signer are now lifted through the traced adaptive adversary computation. Root construction and publication compose with that lift without expanding the finite tree, and the stronger probing verifier is coupled under the same common probe budget. The remaining boundary is the signer's cross-layer schedule, including computations cached before a later layer fails, followed by the clean terminal probability lift and concrete secret-sampler transport. + +The probabilistic side is finished as a tool and half-instantiated. What is in place: `Position` (the finite index set, with `mem_children_iff`, so children and parent agree and no position has two parents), `Honest` (payload, input and value at a position, every payload being the values below it at sixteen bytes each, hence `honestPayload_congr` and `slots_injective`), `Settled` (the positions a cache pins, monotone), `Slot` (`slotDigest_flatMap`, reading the block of a payload a value lands in), and `Charge` (`Bad`, `cachedAt`, `unsettledChildren`, `potential`, and `settled_of_settled_cacheQuery`: one query settles no position but the one its input is at, unless it settles that position's parent). + +In order: + +- **The few-time probability bridge.** Transfer an actual `ProperFewTimeLeak` in the traced game to the uniform-view pattern bound. The remaining distinction is whether each selected successful message-digest input was already present at the start of its signer interval. An initially cached selected input now has an earlier direct adversary query at exactly that input; the apparent earlier-signer source is impossible by retry-loop selection and deterministic replay. The fresh direct answer is admissible, its view equals the selected cover entry's view, distinct prehit entries have distinct source intervals, and their count is at most `q`. For an initially missing selected input, the retry-loop invariant locates the actual successful attempt, proves the input is still fresh there, and identifies its digest and final cache with that fresh answer. The concrete answer is bijectively split into an independent `FewTimeView`, final admissibility group and unused high bits; admissibility conjoined with an arbitrary view predicate factors exactly as `2^-10` times the uniform-view probability. A proof-only signer exposes this selected view alongside the ordinary result; the viewed adversary handler and secret-split game project exactly to the existing full trace, a support invariant aligns every view with its exact signing interval, and the verifier's exact target view is retained too. Every supported proper leak is transferred deterministically to `SomeFewTimePatternHit` on these concrete views. Completion and fixed-length padding preserve the selected positions, embed the pattern into `signatureLimit`, and have an exactly uniform ideal distribution bounded by `2^-122`. The initially missing branch has a tight signer-level domination theorem: every predicate on its selected view costs at most the same predicate under one uniform view, independently of the retry cap. The initially cached branch is now reduced to the fixed direct-source input: the generalized race theorem permits a smaller reference cache, the singleton restriction removes the cached-entry count, and later reuse costs at most `2^-117`. Together with the source query's `2^-10` admissibility cost this gives the intended `2^-127` local weight for one prehit origin. Selected entries are classified by an injective origin map into signer slots or earlier direct-query source slots, so one source cannot pay for two cover entries. Direct sources are injectively numbered in the filtered hash-query list, and the concrete prehit subset is transported into an ideal `OriginConfiguration`. The ideal sampler gives every fixed configuration its exact intended weight, and its complete union is bounded by `2^-121`. The fixed monitored induction, chronological replay, and deterministic terminal implication are complete. The origin-weighted ideal count supports any finite table of target candidates and proves the complete candidate union is at most the table length times `2^-121`. The concrete target is classified as a fresh verifier query or a first insertion by an exact direct query or signer interval, and these cases are assigned chronological candidate ordinals. Every fresh direct query and every signer interval that freshly selects an admissible message-digest answer, including a selection whose later signature construction returns `none`, injects into the final cache, so their count is at most `q`. A support-level transition lemma identifies every fresh admissible signer insertion with the retry-loop selection, and the signer interval's aligned retained view is exactly its `hashOutputFewTimeView`, independently of whether later signature construction succeeds. Reject-only signer intervals are not target candidates. This makes the filtered chronological candidate stream exactly the stream consumed by the target monitor. The compressed candidate-view table contains one view per such interval plus the final verifier slot. Every supported admissible target belongs to it, and its length is at most `q + 1`. In a proper leak, a signer-origin target necessarily comes from an invocation whose later signature construction returned `none`; a successful result would be an honest FTS signing at the forged index and leaves and contradict properness. Thus the target candidate is not one of the cover's successful selected views. A richer proof-only signer now retains the exact selected digest input and projects exactly to `signWithView`; its local domination theorem bounds any event gated on a fresh selected view, including failed-signature paths, by one uniform `FewTimeView`. A fixed-ordinal target monitor now follows the established origin monitor, records that candidate only at fresh direct answers or fresh selected signer inputs, invalidates the disallowed overlap cases, and projects query by query and through every simulated adversary computation exactly to the origin monitor. Its joint potential averages the origin potential over an unseen uniform target, fixes the target once its ordinal arrives, and becomes zero on a disallowed overlap. Target-ordinal coherence is initialized and preserved by candidate recording. Fresh direct answers are exactly uniform at this retained view, and both direct and failed-capable signer candidates now have the weighted expectation lemmas needed by the joint invariant. A generic linearity lemma lifts any pointwise origin-potential decrease through the averaged or fixed target potential. The complete direct-hash transition is now a joint-potential supermartingale: an unselected candidate ordinal inherits the origin invariant, a fresh unconfigured candidate consumes one uniform target draw, a configured overlap becomes invalid, and a cache hit leaves the target pending. The signer optional-skip case is now tight too. Completing an absent fresh selection by an independent uniform view is proved uniform through the complete retry loop; the result survives post-digest signature construction and yields a weighted continuation rule. Consequently the complete signer transition is a joint-potential supermartingale, including failed-signature candidates, configured overlap rejection and origin-obligation updates. These local results are connected to the actual traced target handler, which now has one joint-potential supermartingale theorem covering every query kind. Joint coherence and cache monotonicity are preserved on support, so the capped potential is now lifted through every adaptive computation. A complete terminal state costs one, and its probability from the initial state is bounded by the exact fixed-configuration ideal probability on independent uniform cover and target views. What remains is the deterministic alignment of a concrete candidate ordinal with that terminal state and the sum over target choices. +The target terminal bridge now has the exact per-interval classification and its adaptive lift: the target monitor's final `candidateOrdinal` equals the chronological count of narrowed candidates in the projected trace. That count equals the existing candidate finset's cardinality, so its `q` bound is available without counting reject-only signer intervals. The monitor also retains the chronological candidate views and overlap-permission bits as observational state. Adaptive invariants align both lists with the concrete trace at the exact count-before ordinal of every narrowed candidate interval. Thus duplicate views cannot select the wrong interval, choosing an interval's chronological ordinal makes the monitor's target view equal that interval's trace-derived view, and the monitor's final validity bit equals that interval's exact direct-source or signer-selection permission check. Properness now proves that this permission is true for either concrete source kind. A direct target source cannot also be a configured prehit source because the forged digest input differs from every selected honest digest input. A signer target source cannot be a configured selected signer because properness forces that invocation's final signature to be absent, while every selected signer is successful. These facts are assembled with chronological replay into the target monitor's complete terminal predicate and exact padded pattern hit. The support projection is also complete: every viewed game execution exposes its pre-verification adversary state, and for any fixed target ordinal that state lifts to a target-monitor execution with the same forgery, trace and views, whose cache is below the final game cache. The concrete bridge now transports the target-source position across this projection. Every supported proper leak is either verifier-fresh or yields a supported complete target-monitor execution at the source's exact chronological ordinal, which is strictly below the concrete candidate count. On the probability side, one fixed ordinal's complete event is now bounded by the configuration's exact ideal `Hit` probability, and a generic finite union bounds `N` viewed source-ordinal events by `N` times that probability. This union is now lifted across every distinct count in `1..14`, padded pattern and origin configuration, yielding exactly `N * idealOriginUnionBound`. A fiber-independent viewed terminal event specializes this union. The deterministic bridge proves that every monitored lift of an exact forgery, trace and retained-view projection reaches the same terminal condition. Finally, every concrete nonfresh proper leak is now packaged into that event at a realized padded origin configuration and a source ordinal in `Fin q`; the other branch retains the actual fresh verifier digest query, including its pre-query cache, cache transition and retained view. The trace-aware proper-leak event binds its witness to the run's actual root, forgery, transcript and cache. The root-cache-specific classifier is now lifted through both the verification continuation and key generation, proving that the full nonfresh proper-leak event is at most `q * idealOriginUnionBound signatureLimit q`, hence at most `q * 2^-121`. For the verifier-fresh branch, appending the digest query as a synthetic final direct interval is now proved to preserve the complete padded origin realization, including all earlier source ordinals. An augmented adversary computation performs exactly this final hash query through the ordinary viewed handler, and its support and interval invariants are connected to the real prefix and verifier answer. The appended terminal implication is complete: the final direct interval is fresh, has the verifier's retained target view, occupies the exact count-before ordinal, is disjoint from every configured direct prehit source, and reaches the same fixed monitored terminal event as the earlier source candidates. The verifier-fresh predicate is tied to the actual root cache and adversary cache chain, ruling out an arbitrary smaller-cache witness. The probability lift is now complete: appending the verifier query gives at most `q + 1` candidates, and splitting fresh from nonfresh target sources bounds the full viewed proper-leak event by `q * idealOriginUnionBound signatureLimit q + (q + 1) * idealOriginUnionBound signatureLimit q`. Tightening the fourteen-entry prehit inflation from `2` to `9 / 8` gives `idealOriginUnionBound signatureLimit q ≤ 9 * 2^-125`, hence a full viewed proper-leak bound of `(2 * q + 1) * 9 * 2^-125`. + +- **The remaining terminal probabilities.** The winning probability is now projected to the observational game, where the support-level classifier uses the execution's actual root, forgery, signing transcript, adversary cache chain and verifier run. It decomposes every non-`Bad` win into the six trace-aware terminal events, so no existential witness can substitute an unrelated transcript. Every residual branch now retains the common `¬Bad` hypothesis, and the structural, proper few-time and encoding-collision probability bounds are lifted to this exact viewed decomposition. The clean encoding collision costs at most `44q * 2^-128`, uniformly across the real parameter and secret-table samplings, with no `signatureLimit` or position union factor. The message-digest collision branch is now complete too. Its collision witness supplies one successful signer whose complete digest equals the forged digest, hence a singleton few-time cover with a 166-bit constraint. Generalizing the existing target monitor from proper leaks to any cover whose selected digest inputs differ from the target handles both direct and signer origins, while appending the verifier query handles the fresh target. The singleton origin mass is at most `2^-141`, and the complete sampled event is at most `q * 2^-139`. The uncovered few-time secret is also complete at exactly `q * 2^-128`, including the observational projection back to the original sampled viewed game. What remains is to bound fresh layer openings and backward chain openings. The mandatory public-root computation puts all 42 last-chain positions into its cache, so every complete query bound satisfies `42 ≤ q`. +- **Adaptive secret probes.** A generic table-cell first-fire theorem now proves that `q` adaptive coordinate-and-candidate probes into any sampled table with per-cell mass at most `epsilon` hit with probability at most `q * epsilon`. The all-miss path fixes both the coordinate and candidate, so the theorem has no union over the enormous secret-table index set. Its uniform curried-table specialization is checked. A stronger selective-reveal theorem now permits an arbitrary adaptive computation to reveal table cells, branch on their values and continue probing unrevealed cells, while retaining the exact `q * 2^-128` bound. Concrete terminal extraction packages every uncovered few-time secret as one exact table probe, every fresh layer opening as one exact honest-chain-value probe, and every backward opening as one exact earlier-chain-value probe together with the strict digit inequality. The mandatory top-layer root computation is also proved to issue no few-time leaf query, so its cache contains no such probe input. The few-time split oracle now gives every hidden leaf an opaque coordinate key, decodes ordinary leaf-shaped inputs into probes, synchronizes a selected leaf's hidden and ordinary keys when it is revealed, and reconstructs the exact ordinary cache. Fixed-answer replay is complete for individual hashes, recursive few-time nodes, the forest key and authentication paths. A complete masked signer uses those computations, reveals selected secrets only when it returns a signature, and is proved to issue no probes. The selective-reveal experiment now also has a detailed semantics that retains successful outputs, final reveal states and tables, projects exactly to its Boolean hit experiment, and cannot stop with a false result when the probe bound is respected. Under a clean pending state, hidden-leaf queries, non-leaf ordinary queries and decoded wrong-candidate queries project query by query to the real lazy random oracle with the exact reconstructed cache. A support-aware bind law now composes these local equalities without assuming impossible detailed outcomes. The exact coupling is lifted through every recursive few-time node, the complete forest key, every authentication opening, every successful selected-secret reveal, the digest retry loop and the complete signer, including final signature assembly. The clean-path lift now covers every adaptive adversary query, retains the exact signing transcript, includes final verification, and projects a completed masked game to the original fixed-secret game with the reconstructed oracle cache. A new revealed-coordinate invariant proves locally and through an arbitrary adaptive trace that every revealed coordinate comes from a successful signing-log entry with the exact digest-selected index and leaf, and turns that witness into `SignedFtsLeaf` in the reconstructed execution. The verifier path is connected to this invariant as well: a clean run that queries the correct hidden secret must find it already revealed, hence signed, so a clean `UncoveredFtsSecret` is impossible. The probability coupling is now lifted query by query through an arbitrary adaptive outer computation. Its relational postcondition preserves the exact output and reconstructed cache on every clean path and permits divergence only after a correct unrevealed probe, so it retains the detailed state needed by the terminal contradiction instead of inferring probabilities from support. The hit estimate no longer assumes a structural query bound on unreachable continuations, since the detailed interpreter's fuel itself caps the number of probes. The clean-path probability coupling now uses the concrete expanded signer query bound instead: after a signing request it follows only an output in the honest signer's support. This path-sensitive coupling is composed from the empty split cache through root construction and the complete fixed-secret game under its actual `HasHashQueryBound` consequence. A proof-only raw interpreter now retains the remaining probe fuel and projects exactly to the detailed interpreter, making the adversary and verifier subruns available without resetting or duplicating the query budget. The whole coupling retains the root, forgery, signing log and verifier result; every clean supported result contradicts `UncoveredFtsSecret`. The concrete curried few-time sampler is transported bijectively to the adaptive table sampler without unfolding its function-type `Fintype`, and the sampled retained event is bounded by exactly `q * 2^-128`. The observational sampled event now projects exactly to that retained game, closing the few-time secret branch. For the one-time branch, a separate lazy selective-reveal primitive now reserves opaque honest values without sampling them, samples a value only when it is revealed or the run finishes, and proves the same exact `q * 2^-128` first-fire bound without a presampled random-oracle table. Its retained raw interpreter and fuel-threading bind law are complete. The two remaining one-time terminal events are now bound to the exact forged layer and converted into cached ordinary inputs carrying an exact hidden-value probe. The concrete decoder is injective, so one ordinary input names at most one probe, maps a correct probe to the next hidden chain or leaf output, and has the split-cache and probing-oracle foundation in place. The masked one-time signer, completed-cache reconstruction, total answer-function realization and retained game projection are complete. The forward covered-region predicate is disjoint from both exact terminal probes, including the case of multiple signatures at one one-time position. A combined chain-state and cache-accounting invariant now proves that reserved cells remain opaque, every materialized chain value is public, every public chain coordinate lies in a forward-closed allowed region, and every cached uncovered chain probe remains pending at its source coordinate. This invariant is preserved by the complete probing random oracle, by the masked digest, encoding and few-time computations, and by every tree reservation up to the signer's final publication step. In particular, reconstructing a known chain input identifies its unique revealed predecessor, and the successor is covered by forward closure. Ordinary-cache monotonicity and raw-state value monotonicity are now proved through the masked signing components. A completed masked upper-layer root replays to the corresponding honest root, and every successful masked layer response replays to its exact honest codeword, all at the module's normal heartbeat budget. What remains is to connect those per-layer codewords to the final publication phase, lift the invariant through the retained adversary and verifier, then perform secret-sampler transport and the sampled probability lift. +The one-time branch has since connected every successful masked layer to the signer's final publication phase. A successful complete masked signer now exposes its exact digest selection, honest per-layer codewords and the enlarged chain invariant, while a failed signer preserves the original invariant. Direct adversarial probes can replace decoded structural cache entries, so replay now uses a pointwise stable-input agreement that excludes exactly those entries; digest, encoding and few-time computations query only stable inputs. This agreement is transported backward through arbitrary adaptive suffixes. The chronological retained-adversary lift is complete: direct queries preserve the fixed final covered region, and every signing response publishes only coordinates covered by the final signing log, including repeated use of one one-time position. The invariant is also lifted through verification and the mandatory public-root computation from the empty state. Finalization is now proved incompatible with a clean result whenever an uncovered coordinate has a pending correct probe: the coordinate is still opaque before completion, its pending candidate forces a hit when the honest table value is installed, and later completions preserve that value. Every completed probing hash call is now also proved to return the value stored at its exact ordinary split-cache entry, and later probing computations preserve that entry even when the same input is resolved structurally. Stable computations therefore replay directly through the probing oracle, and a positive chain walk leaves its first exact query in the ordinary cache through the rest of the one-time leaf computation. Target-sum validity supplies a chain whose forged digit is below the last digit, so every fresh-layer witness now has such a concrete first-chain query; the backward witness already has the corresponding strict digit inequality. The terminal union bound now preserves the winning verifier bit and the same replay answer function on both unresolved one-time events, carries them through secret weighting and requires the actual retained verifier result to be true after projection. The terminal predicates also retain the digest-selected leaves and a verifier-layer provenance relation, including through the fully honest replay path. Consequently every extracted fresh or backward chain query is proved to belong to the successful verifier's pure query trace under that same answer function. This removes both unsound enlargements, a false-verdict witness and an unrelated opening reconstructed only by table completion. The actual retained support point now exposes the exact verifier random-oracle subrun, whose replay gives a `CachedRun` for that same answer function. On the masked side, the terminal contradiction is reduced to one explicit trace-transfer invariant: every input in that retained verifier trace occurs at an ordinary key in the raw probing cache. Fresh and cached chronology is now complete through one selected one-time leaf: earlier encoding and other-chain work preserve only the selected source coordinate, the selected first chain query either stops on a fresh correct probe or records a pending hit before returning a cached answer, and that hit survives the rest of the leaf. What remains is to compose this leaf result through the three verifier layers inside the retained-game coupling, then perform secret-sampler transport and the sampled probability bound. + +Since that one-time checkpoint, the concrete one-time secret sampler has been transported to a finite table indexed only by layer, tree, leaf and chain, with no enumeration of structural `Position`. A pointwise relational kernel couples each full hidden output to its truncated digest, and both the eager table and lazy random-oracle distributions are proved equal to the sealed concrete sampler. The exact verifier witness now retains its layer, codeword, chain index and concrete query input. Stable replay through the digest and few-time recovery prefix connects a bottom-layer witness to the exact masked OTS call, whose ordinary cache entry contradicts clean finalization through the chain invariant. The remaining one-time work is to carry that alignment through the earlier hypertree layers for middle and top witnesses, then apply the sampler transport to the probability bound. + +The finite one-time table transport now also has a direct relational coupling to the concrete sampler. Clean lazy finalization is proved to materialize every touched coordinate, and hidden-cache consistency turns each such completed cell into the exact table value selected by the merged ordinary cache. The verifier-layer provenance has been unpacked into explicit bottom, middle and top data, leaving the adaptive retained-game coupling, rather than sampler elaboration or completion semantics, as the remaining one-time bottleneck. + +The retained coupling now has an exact ordinary-world kernel. Projecting a completed split hash query gives the real lazy random-oracle transition exactly, and the result composes through arbitrary hash computations and arbitrary mixed ordinary-world computations containing both uniform and hash queries. The relation preserves the lazy hidden state and remaining probe fuel, so digest searches and stable signing prefixes can be inserted into the larger adaptive coupling without weakening its state invariant. The exact distributional projection now also has a support-level form. The verifier's message-digest and complete few-time recovery prefix are proved definitionally identical under the probing and ordinary handlers, including the recursive forest folds. The completed hidden table now comes with one canonical total answer function: it agrees with every merged-cache entry, realizes every honest one-time position exactly, and reduces to the ordinary fallback on stable inputs. A recursive partial-state completion now preserves every materialized coordinate and defines every missing structural value by applying a fixed fallback answer to its completed children, including the invalid positions that `Position` deliberately over-approximates. A missing position's canonical table answer is proved equal to that fallback, while the completed table's merged cache agrees with its canonical total answer. The retained completion interface packages this table with its exact chain-start secret view, stable-prefix agreement, merged-cache agreement, structural realization and missing-position fallback rule, so later coupling theorems no longer repeat the completion construction. A completed hidden-coordinate reveal now returns the truncation of the value stored in the final hidden state. Consequently a successful layer publication returns exactly the completed table's chain values and authentication path. A successful masked counter search is replayed at its selected least counter and returns exactly the honest chain values under the canonical answer function, including through both kinds of layer-message computation, and the table authentication path is proved equal to the concrete `treePath` evaluation. These per-layer facts are now packaged into a complete `SuccessfulSignRun`: first after digest selection, then through the capped digest loop, every adaptive signing query, the chronological signing trace, the verifier suffix and the whole retained game. Thus every successful retained signing-log entry has the exact honest FTS path, counter, chain values, authentication path and concrete layer evaluations under the canonical answer function. At that checkpoint, the cached-run fields still used the total canonical cache rather than the actual terminal cache. + +The cached-run transfer is now complete. A stable-input cache extension relation separates ordinary digest, encoding and few-time queries from structural queries whose hidden coordinates are supplied by the ensured table. Recursive cached replay covers the complete encoding retry loop, selected chain prefixes, one-time leaves, Merkle subtrees, authentication paths and lower-layer roots. It composes through every successful masked layer, digest selection, adaptive signing query, signing trace, verifier suffix and the complete retained game. Every successful retained signing-log entry now has a `SuccessfulSignRun` against the actual merged terminal cache, the temporary total-answer cache has been removed, and the retained chain invariant is instantiated with that same cache. The remaining one-time work is to compose the middle and top verifier calls with the hidden-opening contradiction already proved for the bottom layer, then apply the concrete secret-sampler transport and sampled probability bound. + +The retained game now splits explicitly at the final verifier. Its proof-only verifier handler records the same chain probe as before, returns every existing ordinary random-oracle answer unchanged, and only on a fresh structural input lazily reveals the direct children needed to resolve that input. This removes the upper-layer replay gap caused by opaque Merkle children without overwriting an answer already fixed by the real run. The pre-verifier chain invariant and every successful signer run against the actual terminal merged cache are both recovered at this boundary. A fresh exact structural verifier query is proved to return the completed table value and cache that same ordinary input after revealing its direct children. More generally, every completed verifier query leaves its returned answer at the ordinary cache key. Agreement of the terminal ordinary cache with the retained answer function therefore replays the entire successful verifier under that same function and proves that every input in its canonical query trace is present in the actual raw terminal cache. This handles bottom, middle and top uniformly. The remaining one-time work is to combine that terminal trace with the pre-verifier chain invariant across the verifier transition, derive the shared hidden-opening contradiction, then apply the concrete secret-sampler transport and sampled probability bound. + +The verifier transition now has both local hidden-opening contradictions. A target query already cached before verification has a pending correct guess in the pre-verifier chain invariant; that guess is proved to survive every completed verifier transition and is rejected by finalization. At a fresh target-query handler call, the handler probes before revealing the source child, and a completed call is proved impossible. The remaining one-time work is the chronological lift locating the selected OTS query in one of these two cases inside the complete verifier, followed by the concrete secret-sampler transport and sampled probability bound. + +The chronological verifier lift now covers all three layers. Stable message-digest and few-time prefixes preserve the selected hidden coordinate. Each earlier OTS and Merkle frame replays to the exact next verifier-layer message while preserving that coordinate, after which the selected OTS records the pending correct hit and the remaining verifier computation carries it to the finalization contradiction. Thus every layer-independent `VerifyProbeWitness` contradicts a clean completed verifier run. Only the retained-game probability coupling, concrete secret-sampler transport and sampled probability lift remain for the one-time branch. + +The all-layer contradiction is now connected to the complete masked retained-game run. Clean finalization preserves the ensured coordinate set and packages the completed table, its canonical answer function, stable-cache agreement, merged-cache agreement, raw and completed state agreement and exact structural realization. A soundness audit showed that global agreement of the raw ordinary cache with this canonical answer function is too strong: an irrelevant structural input may be queried before an opaque node is materialized. The proof now characterizes that agreement exactly as consistency only at cached inputs that become the canonical input of a materialized one-time position; every stable, noncanonical or still-missing input agrees automatically. Verifier replay now uses only agreement on its semantic query trace. That scoped replay is carried through the digest and few-time prefixes, every earlier OTS and Merkle frame, and the selected bottom, middle or top OTS call, so the complete all-layer contradiction no longer assumes global raw-cache agreement. Every completed verifier hash handler is now proved to change the ordinary cache exactly by its one queried key. Induction over the semantic verifier trace uses that equation to replay every initially missing query from the completed hidden table, extend agreement to the remaining trace and recover terminal trace agreement and cache coverage. Consequently the fixed-table coupling is reduced exactly to canonical materialized inputs already cached before verification. The pre-verifier probing handler records the unique source candidate on every chain input. On a leaf input it records chain zero's endpoint while that endpoint is opaque, then records the first remaining opaque endpoint once chain zero is known. On a node input it records the first missing direct child before the ordinary answer can be cached. This remains one probe per hash query, preserves every hidden-cache and chain invariant and is definitionally inert on stable inputs. Its ordinary-cache transition is proved to change exactly the queried key. Canonical chain, leaf and node queries now have complete local dichotomies: if their source values are known they return the completed-table answer, while otherwise they record the completed-table digest at the unresolved source, including chain step zero's secret coordinate and explicit handling of exhausted probe fuel. Reachable probing states satisfy that every published coordinate has a materialized value, and this invariant is proved through root construction and publication, every adversary hash and signing query, and the verifier. The resulting three-way chronological invariant says that a fixed canonical one-time input is absent, cached with the completed-table answer, or backed by a pending correct source hit. It is initialized from the empty ordinary cache after root construction, lifted compositionally through arbitrary direct and signing queries, and preserved through verification. Clean finalization rules out the pending branch, so every cached canonical one-time answer is exact. This establishes exact materialized-cache consistency and closes the deterministic retained-game contradiction for every verifier probe witness without an additional cache-agreement assumption. The contradiction is also lifted through the detailed lazy experiment: any clean completed detailed run cannot carry the retained verifier witness against its completed table. Only the coupling of that detailed run to the concrete retained game, concrete secret-sampler transport and sampled probability lift remain for the one-time branch. + +The query-budget side of the retained coupling is now local and exact. Every adversary-side probing hash query and every verifier hash query performs at most one hidden-value probe, while cache reads, hidden reads, reveals, publication, structural child preparation and known-input resolution perform none. These bounds lift through arbitrary hash computations. Root construction, every reservation and reveal operation, both retry loops, every masked signing layer and complete signature assembly are now probe-free as well. Thus only adversarial and verifier hash queries spend fuel. A mixed-simulation theorem preserves one common budget when the retained computation switches from the adversary handler to the verifier handler, so the lift does not pay separate `q` terms for those phases. Connecting that outer budget to the concrete expanded-game query bound now proceeds together with the clean-path distributional coupling. + +The concrete side of that distributional coupling is now reduced to a finite boundary. Although the masked completion still assigns dynamic structural coordinates, `actualRetainedGameAfterTable` observes its table only through the chain-start slice indexed by `OtsSecretIndex`. Replacing a completed table by the extension of this finite slice leaves the concrete retained game definitionally unchanged. Sampling a uniform table of full 256-bit chain-start outputs and truncating it is coupled exactly to the sealed concrete one-time secret sampler, including the complete retained-game continuation and equality of arbitrary retained-event probabilities. A canonical full-output representative for each concrete digest table makes the retained verifier-probe event itself invariant under this transport. Both revealing and finally completing a missing chain-start coordinate are now proved to be exactly one finite-table update, and drawing that fresh value then patching an independent base table has the same distribution as leaving the base table uniform. The clean versions preserve the joint distribution of the updated hidden state and the completed finite table, rather than only the table marginal. This joint deferral is now lifted through arbitrary computations in the complete probing world and through finalization: chain starts are read from one eager finite table, structural coordinates and ordinary hash outputs remain lazy independent draws, and the final state and completed chain-start table have exactly the original detailed distribution. Probe hits and fuel exhaustion are retained as the discarded paths needed by the clean coupling. Structural-coordinate materialization and completion leave the finite slice unchanged. The finite table sampler and completed verifier-probe predicate are now named opaque boundaries, so downstream support and relational proofs do not normalize the function-type sampler or the full terminal witness. The eager interpreter now also has a compositional bind equation, and projecting any ordinary hash computation through it is exactly the concrete cached random-oracle run. Every supported clean result retains the same eager table and agrees with it at every materialized chain start; a chain-start reveal therefore either takes the discarded hit path or projects to the concrete secret value. This agreement is now preserved through clean finalization as well, so the completed run returns the original sampled chain-start table while it fills structural coordinates. The clean-or-hit relation now composes through arbitrary stateful binds while keeping a stopped retained result opaque, which avoids normalizing the full terminal witness at intermediate boundaries. A clean chain-start reveal followed by any ordinary hash computation is coupled compositionally to the concrete secret value and real cached random oracle, and an ensure operation projects exactly to an ordinary no-op. One exact administrative algebra now lifts that fact through full-chain, chain-prefix, one-time-leaf, recursive-tree and authentication-path reservations. It preserves the finite table, probe fuel and split cache, and the zero-digit masked chain value is coupled through it to the concrete chain secret. Publication is now another exact administrative transition, and both revealing and reveal-then-publishing an already materialized coordinate have exact eager equations and leave the projected ordinary cache unchanged. Thus no structural `Position` enumeration is needed by the remaining coupling, whose only table-valued output is the finite completed chain-start table. + +Deferred clean finalization is now invariant under every permutation of its coordinate list. The proof covers materialized and missing coordinates uniformly, commutes deterministic chain-start completion with randomly sampled structural completion, and preserves pending-hit checks and completed states exactly. A structural value may therefore be moved to the front of finalization without enumerating `Position` or changing the completed distribution. This scheduler is now packaged as a relational kernel: a missing ensured structural position exposes exactly one uniform full hash output, while an already materialized position exposes its stored output, and every clean completed state preserves that value. The corresponding concrete cached-oracle rules now compose through arbitrary continuations, leaving the remaining finalization available after each fresh or cached structural query. A weakest-precondition schedule packages these choices for an arbitrary hash computation, composes exactly through monadic binds, and has direct constructors for raw and tweakable hash queries. An on-demand resolver now keeps structural answers drawn before their proof-world reveal in a separate private partial table, so `peek` still sees those coordinates as hidden and every intervening probe is checked when the value is consumed. Its interpreter has exact equations for every probing-world query, administrative reservations preserve the pending set and both value tables, chain-start reveals recover the fixed finite secret table, and a positive chain resolution is proved to install every predecessor while preserving the original hidden-value map. The structural closure invariant now extends through the full list of 42 chain endpoints, one-time leaves, recursive binary-tree nodes and arbitrary resolved positions, and it preserves every previously known structural value exactly. One private position resolution is coupled to one concrete cached-oracle query in both the fresh and cached cases, with a detected probe hit taking the discarded path. This local coupling is now composed through an arbitrary positive chain prefix under one abstract chronological cache invariant: the theorem returns the exact concrete `chainWalk` value and preserves the invariant after every query. Resolved finalization was narrowed to direct coordinate completion, since recursive child resolution belongs only to an actual structural computation. Its materialized, privately sampled and fresh head equations are exact; on a fresh private table its projection equals the original clean finalizer for every noduplicated coordinate list, and the complete resolved finish projects to the old clean finish from the empty private table. Resolved completion is now permutation-invariant for arbitrary private tables as well. Consequently one missing structural coordinate can be sampled early, checked against its current pending probes and kept private, with exactly the same completed distribution as sampling it in finalization; later probes remain visible to the eventual reuse check. Direct resolution followed by finalization is now inert in all three cases: a fresh value, a privately stored value and an already materialized value. The materialized case is justified by a validity invariant saying that visible structural values agree with the private table and have no matching pending probe. This invariant is preserved through chain starts, arbitrary chain prefixes, all 42 endpoints, one-time leaves, recursive tree nodes, arbitrary resolved positions and final materialization. A complete chain prefix is distributionally inert whenever its reserved coordinates are already in the completion schedule. The reveal boundary now materializes its target from the pre-resolution state rather than the resolver's temporarily cleared state, so pending-only dependencies remain in exactly the completion schedule the clean game uses. Projected finalization is proved insensitive to every private position outside that schedule, and resolving an absent position or chain start before projected finalization is distributionally inert. State-value preservation is lifted through all recursive resolvers, and materializing a resolved target from the original context preserves validity. The next obligation is to compose these scheduled and unscheduled cases through the complete recursive resolver, then couple that resolver to the concrete cached-oracle computation. No structural `Position` enumeration is introduced. + +The scheduled and unscheduled deferral cases are now composed through chain starts, arbitrary chain prefixes, all 42 chain endpoints, one-time leaves, recursive tree nodes and arbitrary structural positions. Pending coverage supplies the split without enumerating `Position`, and projected finalization after any complete recursive resolution has exactly the original clean completion distribution. The next obligation is the game-level coupling between the resolved probing interpreter and the concrete cached-oracle run. + +The concrete-cache side of that coupling is now chronological through every OTS resolver. A deferred completion agrees with every materialized and private structural value, avoids every pending probe, and fixes the finite chain-start table. This invariant starts from the empty cache and is preserved by chain-start resolution and each fresh or cached structural query. The resulting relational lift follows an exact concrete chain prefix, all 42 endpoint computations, the OTS leaf hash and recursive Merkle nodes while retaining the exact returned digest, cache and hidden full output at every resolved position. The proof interpreter distinguishes recursively meaningful OTS positions from the invalid nodes that `Position` deliberately over-approximates. A valid position resolves through the exact concrete structural computation, while an invalid node receives one independent ordinary random-oracle answer, matching the existing completion fallback instead of recursively evaluating a wrapped subtree. A cache-partition invariant records every concrete entry as either an ordinary split-cache entry or a universally fixed resolved structural input. It is preserved through chain starts, every fresh or cached structural query, arbitrary chain families, OTS leaves, recursive tree nodes and the invalid-position fallback, and it gives exact concrete agreement at every stable input. The complete interpreter rules now cover stable ordinary queries, structural position reveals and fixed chain-start reveals. Administrative reservations and publication preserve the full invariant through a deferred-core equivalence, so masked chain values and every span-valid masked Merkle node are coupled end to end to the exact concrete cached-oracle computation. Each structural rule returns either the full invariant or an explicit non-completable state. Completion is now proved backward through position values, chain starts, arbitrary chain prefixes, all 42 chains, OTS leaves, recursive Merkle nodes and the valid/invalid reveal split. That result is lifted through every query constructor of the complete resolved interpreter, so a successful continuation ending in a completable context must have started completable. Equivalently, a later probe that rules out every deferred completion cannot silently recover. A terminal audit found that the old finalizer deliberately skipped a second hit check for an already materialized value, so finalization alone could not construct a completion after a later probe. The resolved finish now enforces the dichotomy directly: completable contexts use the unchanged distribution-preserving finalizer, while non-completable contexts stop. Successful interpreter runs also preserve visible/private value consistency and the fixed chain-start table even on the doomed branch. A compositional `ResolvedCouples` relation now packages the dichotomy with `pure`, `bind` and finite-sequence rules. Stable oracle queries, masked chain values, span-valid masked Merkle nodes and complete tree roots instantiate it against their exact concrete cached-oracle computations. The next obligation is to instantiate this algebra for the complete masked hash handlers, signer and retained game under the single common probe budget. + +The stable ordinary portion of `ResolvedCouples` is now closed under tweakable hashing, the complete few-time forest, encoding and message-digest computations. The remaining coupling work starts at the probe-aware masked hash handlers, then lifts through the signer and retained game under the single common probe budget. + +The clean-or-doomed algebra now includes the local probe transition itself: a new pending candidate either retains a deferred completion and the full invariant, or produces a permanently doomed context. Uniform sampling, the digest retry loop, OTS counter selection, layer-message construction, structural value and path revelation, and the complete masked signer are composed through the same relation. The next missing boundary is the probe-aware direct and verifier hash handlers, followed by the adaptive retained game and the terminal probability lift. + +The probe-aware handler foundation now covers ordinary inputs relative to a deferred completion rather than only syntactically stable domains. A pending decoded probe proves that its input differs from every honest structural input, so the split-cache query couples to the concrete random oracle without assuming a fixed answer map. Deterministic resolved equations for coordinate, child-list and complete table-input peeks now separate the known canonical branch from the missing-input branch. The canonical reveal and the full handler composition remain next. + +The known canonical handler branch is now complete locally. Every visible resolvable chain, leaf or node carries a cached concrete structural computation; replaying that computation leaves only its final random-oracle query. All deferred completions give the same canonical input once the required children are visible, and the final concrete cache recovers the full 256-bit output rather than only its truncated digest. Revealing, publishing and installing that answer in the ordinary split cache therefore couples to exactly one concrete cached-oracle query, with the clean-or-doomed invariant preserved. The next obligation is to make the visible-computation cache property a reachable invariant of every probing transition, then use it to close both complete hash handlers. + +The visible-computation cache property is now part of a stronger reachable clean-or-doomed relation. It is initialized vacuously and preserved through administrative operations, pending probes, uniform sampling, stable ordinary random-oracle queries, fixed chain-start reveals and arbitrary resolvable structural-position reveals. The strengthened relation is compositional under binds, finite sequences and simulated oracle computations, while its doomed branch retains the existing irrecoverability theorem. The full masked signer now inhabits this relation, including digest retries, few-time computations, encoding counter search, structural chain and tree evaluation, publication and final signature assembly. The canonical full-output handler branch was strengthened at the same time. The next obligation is to compose the pending-probe and canonical branches into the complete probing and verifier hash handlers. + +The complete retained execution is now coupled through final verification. The verifier reuses the stronger probing random-oracle handler, whose every query is already coupled to the concrete cached oracle and spends at most one unit of the same probe budget used by direct adversarial queries. The empty-state invariant instantiates this coupling for the whole retained game, and the adversary and verifier suffix is proved to spend at most the original common probe budget. The obsolete weaker verifier-specific invariant has been discarded. The concrete scheduling endpoint is exact within one layer: resolving the layer message, selecting the first admissible counter, computing its selected chain prefixes and building the authentication path is definitionally the concrete `signLayer`, and the immediate after-digest wrapper is the concrete after-digest signer. The selected chain-prefix family and authentication-path family now have chronological private resolvers whose exact values and cache growth agree with those concrete computations. Private resolution preserves the visible value map and publication set, is inert under finalization, and its concrete cache is monotone. Composing these facts with the reachable masked-layer coupling gives one exact immediate scheduled layer, including its clean-or-doomed split. The scheduler is now lifted through an arbitrary finite layer family. Clean executions run every later layer even after an earlier layer returns `none`, preserving the concrete `sequenceFin` schedule, while only an irrecoverably doomed context stops early. Its output and concrete cache are coupled exactly to the corresponding family of immediate concrete layers. A native proof-only signer now performs those private resolutions immediately after each successful layer, including the cache effects of later layers after an earlier failure. It publishes the resolved signature values only when every layer succeeds. The publication pass is proved to replay entirely from the final cache, its richer layer output projects to the ordinary layer parts, and the resulting signer couples exactly to the concrete after-digest signer. That signer now replaces the delayed signer throughout the retained adversary and verifier game. The concrete endpoint is exactly `actualRetainedGameAfterTable`, the empty resolved state supplies the full reachable coupling, and every private resolution and publication is probe-free, so the chronological game preserves the original common probe budget. The completion-local terminal contradiction is now formal: a deferred completion must avoid every pending candidate, while its completed table answer realizes every honest one-time value, so a pending probe cannot also be correct under that completion. The terminal transport now also has a generic resolved-interpreter theorem saying that any computation with no publication query leaves the public revealed set unchanged, together with its lift through arbitrary simulated oracle computations and the ordinary hash and uniform handlers. Every deferred completion's completed table answer is now proved to agree with the full concrete cache, including ordinary cached inputs that decode as structural positions. A particular final completion now propagates backward through every resolved-interpreter operation, so later private resolution cannot erase an earlier avoidance obligation. Consequently an exact unrevealed verifier chain query is proved incompatible with a correct probe under that final completion. A completion-aware publication invariant now classifies the complete probing handler as well. A direct decoded chain query may publish only a forward successor of an already covered public chain value; when its source is still opaque, the final completion forces the resolver down the ordinary branch, so it publishes nothing. The private chronological signer is proved publication-free through its full chain and tree reservation stack, and its final publication pass is isolated as exactly the selected chain endpoints plus non-chain authentication positions. A supported private layer sequence now replays against a concrete cache component by component, its selected counters and encodings are proved honest under the final completed table answer, and the proof interface avoids expanding the concrete three-layer `sequenceFin`. What remains is to connect those selected endpoints to successful entries in the adaptive final signing log, use the resulting covered-coordinate invariant to keep the extracted verifier source opaque, then perform the clean terminal probability lift and concrete secret-sampler transport. + +The chronological signer terminal now classifies a complete successful invocation against one deferred completion. Its internally selected digest run is replayed exactly, so its selected index cannot be confused with another digest run that happens to produce the same finished signature. Every published chain endpoint is then proved covered by that invocation's actual successful signing-log entry. This classification is now lifted through an arbitrary adaptive signing trace. The induction fixes the final completion and signing log, transports only the off-table fallback agreement that later queries can preserve, and proves that every revealed chain coordinate is covered by a successful entry in that final log. A generic verifier-trace theorem now follows the completed answer path through any hash computation and shows that an uncovered matching chain probe cannot hit: the exact verifier query either finds its coordinate already revealed, contrary to the covered-coordinate invariant, or creates a pending candidate that the final completion must avoid. The complete deterministic retained-game assembly is now closed. It starts from the empty resolved context, carries the covered-coordinate invariant through root publication and the adaptive adversary prefix, transports the final concrete signing runs to the completed answer function, and applies the generic contradiction at the verifier query extracted from either hidden-opening event. What remains is the clean terminal probability lift and concrete secret-sampler transport. + +The one-time terminal events now retain the settlement provenance of the forged layer root. Every extracted verifier probe therefore carries a settled source coordinate, which makes its honest target invariant under all answer functions agreeing with the final cache. The full verifier witness, including its layer message, encoding, query membership and uncoveredness, is transported to any deferred completion through the cached verifier run. Combined with the chronological terminal contradiction, an actual retained winning probe now forces the corresponding resolved context to be non-completable. This support statement is now lifted through the concrete resolved-to-actual coupling: the actual winning-probe probability is at most the probability that the chronological resolved run finishes as `none`. Recursive structural resolution is proved neutral under finalization through the complete `resolveDeferredReveal` wrapper. Validity and pending coverage now survive every probe-free resolved computation and a complete layer resolver. Resolving the private chain and authentication-path values of any finite family of preselected layers preserves the completed public-state distribution, including optional failed layers, and the same neutrality now holds when every successful result is resolved after the complete layer-selection family. The cross-layer separation needed for the schedule commute is now explicit too: resolving one layer preserves every deferred value and every pending-candidate fiber at every other layer, as well as the complete public value and publication maps. A layer-local observational relation now also couples recursive structural resolution from two such contexts, including exact failure and output agreement. It is compositional through administrative reservations, ordinary random-oracle queries, encoding retries and the full masked layer selector. In the below-layer branch it tracks exactly the adjacent root that the selector reads, while the top layer preserves any other layer view. The complementary resolver-local relation is now complete through the full later layer selector as well: reservations and ordinary hashes preserve every layer fiber, and the only structural read, the adjacent layer root, is explicitly required to differ from the earlier resolved layer. These two frames are now combined into an exact distributional transposition of one private resolution past one later layer selection. Both orders normalize to the same independent product computation, with exact failure, selected output, remaining fuel, table, public state and every continuation-relevant one-time layer fiber preserved. The layer fibers and complementary non-one-time fibers now form an injective complete-context view, so the observational equality recovers equality of the raw adjacent schedule distributions. A small immutable-table scheduler now carries selections, resolved parts and the split cache explicitly. Three applications of the raw transposition prove the exact concrete permutation from `S0 R0 S1 R1 S2 R2` to `S0 S1 S2 R0 R1 R2`, including failed selections and interpreter failure. The remaining one-time boundary is to connect this scheduler to the chronological signer under finalization, lift the resulting equality through the adaptive signing handler and verification, identify the failure distribution with the clean lazy-probe hit experiment, and apply the already prepared OTS-secret sampler transport. + +Materialized chronological resolution and private deferred resolution now admit exactly the same completions. A finalization-view relation records the completed value map, cleanliness of known values, pending-candidate fibers at unknown values and agreement with the fixed chain-start table. It is an equivalence, determines the same completion set and is preserved through chain-start resolution and recursive structural resolution of chain prefixes, one-time leaves, Merkle nodes and arbitrary positions. The resulting relation gives exact failure and output agreement while preserving validity and completable contexts. The generic immutable scheduler preserves validity and pending coverage through an arbitrary layer-selection list, and its complete resolution suffix is distributionally erased by finalization before specializing to the concrete three layers. Its selection-only endpoint is now identified exactly with the concrete three-layer `sequenceFin maskedSignLayer` computation under finalization, without expanding the function-valued output. Materializing every selected chain endpoint and authentication-path node is now coupled to the corresponding private family resolver under the same finalization view, including zero-padded path levels, and the two families compose into one complete selected-layer value theorem. This finalization relation is now preserved through the complete masked layer selector, including lower-layer root reads, encoding retries and authentication-path reservation. It composes through arbitrary finite layer families while retaining exact optional outputs, immutable table, remaining fuel, ordinary cache and the revealed-coordinate set that controls adaptive probe behavior. The proof-only family is definitionally the immutable `select, resolve` scheduler, and the concrete three-layer family reduces definitionally to the established chronological schedule. The delayed publication pass now preserves the same relation for every chain start, chain endpoint and authentication-path coordinate, and the scheduler reconstructs the exact chronological layer records from its selected and resolved stores. The complete after-digest and digest signers are coupled through FTS authentication work, uniform digest retries and optional failure, with exact signature output, revealed-coordinate equality and a dynamic finalization theorem equating their terminal failure distributions. The remaining one-time boundary is to lift this clean signer kernel through a clean-or-doomed adaptive interpreter and retained verifier continuation, identify its terminal failure with the clean lazy-probe hit experiment, and transport the concrete one-time secret sampler. + +The adaptive lift now has its clean-or-doomed relational foundation. A context with no clean completion remains doomed through every later resolved computation, so the coupling may stop tracking outputs after the first hit without losing the terminal failure event. On a clean pair, equal revealed-coordinate sets make an exact probe take the same branch; inserting its candidate either preserves the common finalization view and validity or makes both contexts doomed. The relation is now also proved to identify the final completion-failure Boolean exactly. A synchronized refinement records equality of the materialized value maps required by representation-dependent peeks. Pure, ordinary, ensure, probe, peek, reveal, publication, relational bind and arbitrary simulated computations preserve it. The complete structured hash handler is now lifted through this refinement, including first-missing scans for leaf and node inputs and every decoded or ordinary fallback branch. The signer boundary is now closed by canonicalization: materialized structural values that were not published move back into the deferred representation when a signer returns, while revealed values remain materialized. Canonicalization preserves validity, completion semantics, pending probes and doom, and it makes two finalization-related contexts exactly equal on the materialized value map. The chronological and delayed signers therefore return synchronized contexts after every signing query, including failed signatures, and a generic clean-or-doomed interpreter now lifts this local relation through an arbitrary adaptive adversary computation. Root construction and publication now enter the same synchronized relation from the empty context, and the final probing verifier preserves it. Thus the complete canonical chronological and delayed retained games have exactly the same finalized failure distribution. Canonicalization also preserves every concrete-simulation invariant, and the canonical chronological handler is now coupled query by query, through the complete adaptive trace and verifier, directly to the real retained game. This avoids comparing its failure event with the original chronological monitor, whose deliberate false-positive paths make that comparison invalid. The signed-chain publication invariant now crosses the canonical adaptive trace, including completion and cache transport at every boundary, so the verifier contradiction applies to the canonical retained game. Consequently the real winning hidden-opening event is at most the canonical chronological finalized-failure probability, which is exactly the canonical delayed probability. The complete support-to-probability checkpoint is kept in one module so its dependent terminal witnesses do not cross an elaboration boundary. What remains is to identify delayed terminal failure with the clean lazy-probe hit experiment and transport the concrete one-time secret sampler. + +The clean terminal probability endpoint is now closed independently. A probe-bounded lazy run cannot stop from fuel exhaustion, its completed fixed-table run returns `none` exactly when the lazy experiment records a hit, and the uniformly completed run therefore costs at most `q * 2^-128`. The endpoint now also has the support-sensitive form needed by the real game: it is enough to prove that `runRaw` has no supported fuel-exhaustion result, without imposing a structural query bound on impossible replies of the abstract signing oracle. The downstream sampler transport is complete too: the uniform one-time hash table couples to the concrete sampled one-time secrets, both fresh and backward openings reduce to the same sampled verifier-probe event, and the independent one-time and few-time sampler order is exchanged exactly. The real retained verifier-probe event is now lifted through the uniformly sampled one-time hash table to canonical delayed finalization failure, without making the false pointwise claim that every fixed table has small risk. The selection-first retained endpoint is now named directly and identified definitionally with the existing masked resolved retained game. Every digest is now proved to be a supported top-tree root for every concrete one-time secret, every finite one-time table is in the sealed concrete secret sampler's support, and the global query bound therefore specializes to the real expanded retained execution for any sampled table and root. The path-sensitive budget argument is now complete as well. Every completed masked signing response is supported by the concrete signer for every start table compatible with the reached lazy state, including `none` through an explicit rejecting oracle. Following only those feasible responses transports the real query bound through the adaptive computation, while a generic fuel invariant accounts for each completed step. Root construction is probe-free, so the complete supported selection-first run cannot exhaust its global budget and its clean finalized failure probability is at most `q * 2^-128`. The atomic same-coordinate transport now commutes a fresh private structural draw across registration of a later probe candidate under finalization, including both old pending hits and hits against the newly registered candidate. One-position deferral now also has its terminal base case, exact commutation through reservation and publication, exact transport across probes at other coordinates, and a two-resolution law for probes at the sampled coordinate. Contexts made impossible by a new probe are handled explicitly: every later resolved run finishes in the failure event, so the proof never assumes a completion that does not exist. Distinct private-position resolutions now commute in distribution, resolving one position twice is idempotent, and the private resolution also commutes across the deterministic one-time chain-start cell. That commutation now lifts through complete chain prefixes, chain lists, one-time leaves, recursive Merkle nodes, arbitrary structural positions and the complete reveal resolver while retaining the revealed output and exact failure behavior. The full interpreter induction is now complete as well: resolving one ensured private structural position before any later probing computation leaves the terminal completion-failure distribution unchanged through uniform sampling, reservation, every probe branch, peeking, publication, deterministic chain-start reveals and recursive structural reveals. The suffix erasure now composes through the exact selected chain family, complete one-time leaves, recursive Merkle subtrees, the authentication-path family and a complete selected layer. Resolved-interpreter ensured-set monotonicity proves that every successful masked layer selection reserves all coordinates required by that erasure, while the existing finalization coupling preserves completability. The three selected layer resolutions are now erased through the complete publication suffix and an arbitrary signature-dependent continuation. A selection-only intermediary is identified exactly with the ordinary masked signer under the resolved interpreter, so the complete delayed chronological signer has the same terminal failure distribution as the clean signer from every valid completable context. Canonical continuations now make this equality stable under arbitrary later resolved computations. Publication preservation is proved for the complete probing handler, masked signer and delayed chronological signer, so the canonical boundary cannot hide an unpublished read or manufacture an invalid public state. Both ordinary and signing queries now have the exact local canonical-continuation equality required by the adaptive lift. What remains is to compose those local equalities through the adaptive game, identify the clean sampled endpoint and apply the final three-event theorem. + +- **Encoding retry probability.** The low 128 bits of a fresh oracle answer are now proved exactly uniform, the admissible target-sum digests form a nonempty finite set, and the validity-weighted potential increment averages to exactly `2^-128`. The real answer distribution now has both local retry rules: an admissible pretarget query adds one unit of normalized pending risk in expectation, while a fresh selecting query either hits a pending digest or consumes that risk. Cached signed targets are proved admissible and are connected to the finite valid-answer target set. The concrete retry loop now proves that its selected counter is admissible and every smaller counter is inadmissible, including the full `2^32` counter range without unfolding a sampling definition. When a query creates a new cache-local target, the old cached-input count pays the full target-set cardinality by the corresponding drop in the encoding potential. An encoding input queried by `otsSign` is now proved to carry that signer's exact layer message and a concrete retry counter. More importantly, a fresh admissible encoding answer inserted during any signer invocation, including an invocation whose final signature construction fails, reconstructs the cache-local canonical target. Key generation is proved to leave every encoding input absent. Outer chronology therefore proves that a target input already cached before a later selected signer either was already pinned or has an earlier direct hash source. In a clean collision execution the pinned alternative is impossible, so the selected target has an exact earlier direct source. The pending risk is now also a cache-derived potential summed over encoding positions. It is zero initially, is unchanged by queries at other encoding positions, and its expected growth under one fresh uniform answer is at most exactly `2^-128`. Pinning a target consumes the entire old pending-risk contribution at that position, with the concrete finite target set identified exactly. A canonical collision now also yields a weaker latent cache witness: the signed payload is already the least admissible cached counter for its settled message, even if smaller counter inputs remain absent. An inadmissible encoding query cannot create this latent collision, so filling the last retry gap only reveals an older event. If a fresh encoding-domain query does create the latent event, its answer must hit the finite set of admissible answers already cached at that position. A direct query that first settles the honest layer message must instead hit the cached message-block set. If the layer message settles indirectly, the query must settle its own structural position and its parent, so its answer belongs to the existing structural `settlingTargets`. Thus every way to first create the latent event is now classified into one of the three finite target sets already present in the two cache potentials. A two-stage encoding potential now pays cached inputs twice before their layer message settles, once after settlement, and zero after the canonical target is pinned. It is zero initially and grows by at most two per fresh query. Combined with the structural potential, it pays the complete cached-message target set, the cached-answer target set when a fresh query pins the target, and the structural settling target set. The first-creation theorem packages every latent collision into an already pinned target, one of those fully paid branches, or the one remaining provisional case where an out-of-order encoding query collides before the retry gaps are filled. The provisional case is now eliminated at a genuine signer boundary: if its query lies inside a supported signer invocation, that invocation's final cache necessarily pins the target, even when signing later returns `none`. A latent witness at a pinned position is also proved to be exactly an `EncodingBad` witness by uniqueness of the least admissible counter. A generic support theorem now extracts the first fresh hash transition that creates any cache event, retaining both surrounding cache inclusions. Applied inside a signer, it reduces the complete invocation to a pinned target or one internally paid transition. At the outer level, the cache chain now locates the first interval that creates the latent event and classifies it as either one direct fresh hash query or that complete signer result; uniform queries and cached hash queries cannot be selected. The root cache is proved latent-clean directly from key generation's absence of encoding inputs. This entire first-creation path is now also parameterized by one fixed encoding position. `EncodingBad` exposes that exact position together with its pinned target, and the direct, signer-internal and outer-interval classifiers preserve it throughout, so an earlier irrelevant latent collision cannot be selected and no union over all encoding positions is introduced. The verifier continuation is now included as well. The viewed terminal game exposes its real pre-verifier state and verifier run, and a final `EncodingBad` is traced either to one outer adversary interval or to one exact fresh verifier query. Existing-target and provisional signer outcomes both retain the creating input, answer, valid-answer hit and cache inclusions, while the final target remains pinned at the same fixed position. What remains is to compose the provisional source with its later signer selection through the retry-risk charge. Treating an unconstrained provisional event alone as linear would be an invalid birthday bound, so the proof continues to retain its signer-selection condition explicitly. + +- **Encoding expected risk.** Structural target-set credit and normalized retry risk form one cache potential. Every clean final encoding collision makes it exactly one, structural-bad paths are capped at zero, and the actual clean viewed encoding event is bounded by its expectation. Query bounds imply the cache finiteness needed by the terminal bridge. The conditional retry schedule is instantiated directly from the concrete cache, and the combined one-query inequality charges at most `44 * 2^-128`. This inequality is lifted through arbitrary adaptive lazy-oracle computations from the empty cache, then through the observational projection and the real parameter and secret-table samplings. The resulting sampled clean encoding probability is at most `44q * 2^-128`. +- **Encoding conditional schedule.** Complete. The model covers all `2^32` retry inputs without evaluating the schedule. Retry inputs are injective throughout the attempt range, the schedule splits exactly at any selected counter, and a fresh cache insertion changes precisely that schedule entry. Revealing an arbitrary missing counter, including one behind earlier unresolved gaps, preserves the old conditional risk in expectation. Recording the same answer as a keyed collision candidate then costs at most exactly `2^-128`. Before settlement the cache contribution is the coarse retry risk; afterward it is the exact conditional schedule risk. Direct and indirect layer-message settlement consume the existing encoding-message and structural settling credits. The complete adaptive and sampled lifts are now checked. + +- **The final union and arithmetic** to `q / 2^120`. The structural term and complete proper few-time term fit within `24 * q / 2^125`, using `42 ≤ q` to absorb the verifier candidate's constant term. The clean encoding event consumes `44 * q / 2^128` of the residual budget. The final Lean interface leaves `20 * q / 2^128` for the four former residuals and applies the completed message bound internally, so it now requires only an aggregate `19 * q / 2^128` bound for the three hidden-opening events. The final arithmetic, the trivial `q > 2^120` range and the complete security quantifiers are discharged once that aggregate bound is supplied. + +Nothing closes the main claim yet. The one-time and Merkle halves of `formal/xmss` carry over, sharing the tweakable hash, the target-sum code and the shape of the bound; what is new is the hypertree, the few-time forest, the digest that picks the index, and the counter search under a tweak shared across attempts. + +The adaptive delayed-signer lift is now complete. A generic boundary observer composes the local ordinary and signing query equalities through an arbitrary adaptive adversary computation, preserves synchronized clean contexts, treats non-completable contexts as terminal failure and remains neutral to ensured private-position resolution. The remaining one-time work is to compose root construction and verifier finalization around this boundary theorem, erase the boundary canonicalizations into the complete clean masked run, identify the resulting table-averaged failure distribution with the existing sampled clean lazy-probe endpoint and apply the final three-event theorem. + +Root construction, adaptive execution and verifier finalization are now composed around the boundary observer. The verifier-plus-finalization continuation itself satisfies the doomed, synchronized and private-position-neutral observer laws, so the canonical delayed retained game has exactly the same fixed-table failure distribution as the boundary-normalized masked run. The remaining one-time work is only the table-averaged identification of that boundary run with `sampledRunThenFinalizeClean`, followed by the existing `q * 2^-128` bound and final three-event theorem. + +The terminal resolved-to-clean quotient is now explicit. Any deferred context related by `FinalizationContextEq` to a clean state with an empty private store has exactly the same final completion-failure Boolean as `finishCleanRunFromTable`; no equality of their hidden representations is assumed. What remains is to preserve that relation through the boundary-normalized root, adaptive masked handler and verifier, then average the resulting endpoint equality over the uniformly sampled one-time table. + +The clean interpreter is now factored through a direct resolved interpreter. It carries the same deferred context and result type as the recursive resolver, but a missing structural reveal samples only the requested coordinate. If that coordinate already has a privately deferred value, the direct reveal reuses it and checks every pending candidate instead of drawing a replacement. From the mirrored context whose private position store is exactly the state's materialized values, its complete execution projects exactly to `runCleanFromTable` for every computation. The remaining semantic lift is therefore only the sampling-order equivalence between recursive structural resolution and this direct interpreter on the concrete masked game. + +The direct terminal projection now covers that mirrored private store exactly: finalization ignores a private copy when the corresponding state value is materialized and requires absence only when the state value is missing. Thus a completable direct result has the same resolved and clean completion distribution. The recursive side now also packages the complementary erasure rule: resolving a chain prefix, one-time leaf or Merkle node before an observer is inert whenever the exact recursive region is ensured and the observer satisfies the already established doom, synchronization and private-position neutrality laws. What remains is to combine these terminal and recursive rules into the local recursive-to-direct reveal coupling and lift it through the boundary-normalized retained game. + +The recursive erasure rule no longer requires the region to have been ensured. Temporarily adding one ensure marker is finalization-equivalent to the original context, so synchronized observers transport the existing atomic rule to every private position. Induction now erases arbitrary chain prefixes, complete chain families, one-time leaves, recursive Merkle nodes and every structural reveal from any valid completable context. The requested reveal's value is now retained while only its recursively sampled dependencies are erased. The resulting local recursive-to-atomic reveal coupling is lifted through the complete resolved interpreter. The proof handles impossible probe branches by transporting every hypothetical direct-run completion back to the input context, handles cached reveals by finalization synchronization, and proves that the recursive and direct interpreters have exactly the same terminal observation from every valid completable context. This equality is also specialized to the exact completion-failure observer, so a valid completable recursive run now reduces directly to the corresponding direct run with the same finalization Boolean. The equality is now lifted query by query through the boundary-normalized root, adaptive handler and verifier. For every fixed one-time secret table, the canonical boundary game has exactly the same failure distribution when every inner computation uses the recursive or direct interpreter, including non-completable branches. The complete retained endpoint now packages this equality around root construction and verifier finalization, so the canonical deferred failure reduces to one fixed-table direct boundary game. Root construction itself is now also transported to the direct interpreter from the empty deferred context, eliminating the last recursive private-tree precomputation before the boundary game starts. A soundness audit ruled out the proposed unconditional equality with the old materialized clean run: after a failed signer, a structural value can remain materialized but unpublished, so canonicalization makes a later guess probeable while the old clean handler can see the value and skip that probe. This discrepancy does not occur at a chain coordinate. `ChainState.ValidFor` proves every materialized chain value is published, canonicalization is now proved to preserve each chain value and the complete `ChainInvariant`, and the final arithmetic interface explicitly accepts any common one-time probe constant `c` with `2c + 1 <= 19`, hence any `c <= 9`. Every successful direct interpreter run started from a mirrored context is now proved to finish mirrored as well, including fresh structural resolutions and fixed one-time chain starts. Combining that support invariant with chain validity proves that canonicalization leaves the private and materialized copies of every chain position equal. The only boundary discrepancy is therefore structural. What remains is to preserve this chain-specific equality across successive canonical boundaries and either erase the structural-only discrepancy under sampled private-value commutation or charge it as one additional first-fire event, then apply the sampled table transport and final theorem. + +The chain-specific invariant is now compositional rather than restricted to a single mirrored run. It survives every direct interpreter primitive and every successful private resolution, and canonicalization preserves it whenever the existing chain-validity invariant holds. A successful direct run is also proved to embed pointwise into the support of the ordinary lazy interpreter, so every existing `PreservesChainInvariant` theorem applies to direct execution without duplicating the scheme-specific invariant proofs. Those facts are now threaded through root construction, the complete adaptive boundary recursion and final verifier execution. The fixed-table equalities from the canonical chronological game through the boundary-normalized and fully direct games are now consolidated into one endpoint theorem, and averaging it over the uniformly sampled one-time table gives the corresponding sampled endpoint equality. Every chain value remains mirrored across every canonical boundary. The remaining discrepancy from the ordinary clean run is exclusively at unpublished structural coordinates. `PrivateStructuralHit` now isolates it exactly: a private structural value is absent from the materialized state and one pending candidate equals its truncation. Every deferred completion excludes this event, and adding one candidate at a hidden private position makes the context non-completable exactly when it creates this event. What remains is to carry that first-fire classification through the adaptive boundary and charge it by one additional probe unit, after which the existing sampled table transport and final theorem apply. + +The direct interpreter now has a cause-aware refinement that distinguishes fuel exhaustion, an ordinary reveal hit and a hit against a privately retained structural value. Forgetting that cause recovers the existing direct interpreter exactly for every computation, context, fuel and one-time table. This makes the classification observational rather than a change to the game. What remains is to lift the cause through canonical query boundaries, including a private hit created by a probe whose inner computation returns before revealing the position, and then prove its one-unit probe bound. + +The cause now lifts through the complete canonical adaptive boundary, root computation and direct verifier. A returned context is classified before canonical continuation: a private structural hit gets its own outcome, any other non-completable context is an ordinary failure, and a completable context continues. The private cause is sticky even when an unpublished result would otherwise stop the boundary first. Mapping both failure outcomes to `true` recovers exactly the existing fixed-table all-direct endpoint and its sampled-table average, and the total failure probability is bounded by the sum of the two outcome probabilities. The ordinary projection is now factored exactly through the detailed interpreter, every canonical adaptive boundary, root computation, verifier finalization and sampled one-time table, leaving a plain Boolean endpoint for the clean coupling. The private projection is factored through the same complete endpoint as a separate Boolean interpreter. A clean context can first acquire a private structural hit only when the current probe names a hidden structural position and its candidate equals that position's retained value. Sampling a previously unresolved value, adding that probe and then continuing now costs at most exactly `2^-128` plus the continuation bound, with an older pending hit excluded into the ordinary cause. What remains is to lift this local additive charge through the common adaptive probe budget and couple the factored ordinary endpoint to the clean lazy-probe failure. + +The complete probability composition is now factored separately from those two endpoint bounds. The real retained one-time opening event is bounded by the sum of the ordinary and private structural boundary outcomes. If each outcome is at most `q * 2^-128`, their common one-time probe constant is `2`; the two one-time terminal events and the one-unit few-time event then consume only `5` of the available `19` units, and the existing terminal arithmetic closes the security statement. Thus the only substantive probability obligations left are the ordinary and private structural `q * 2^-128` endpoint bounds. + +The ordinary endpoint now has its sampling-order bridge and local probability invariant. Averaging a fixed one-time table is exactly equivalent to sampling each missing chain start when it is first revealed, while structural values remain lazy. The resulting safe detailed interpreter is bounded by `(remaining fuel + pending candidates) * 2^-128` for any terminal observer satisfying the same bound, and final lazy completion supplies the required terminal observer directly. From a mirrored deferred context, projecting this completed safe interpreter recovers the existing ordinary lazy interpreter and its finalizer exactly. A detailed fuel-exhaustion outcome therefore transports to the existing raw stopped outcome, so the established path-sensitive query bound can exclude it. What remains for the ordinary endpoint is to lift the invariant through the canonical root, adaptive handler and verifier and connect their successful boundary contexts to this mirrored lazy endpoint. The private structural endpoint still requires its corresponding adaptive lift from the already-proved one-probe first-fire charge. + +The completed safe ordinary interpreter is now identified directly with `LazyRevealProbe.experiment` whenever the raw run has no supported fuel-exhaustion outcome, and its empty-state probability is exposed as exactly the required `q * 2^-128` endpoint. Independently, any probe-bounded fixed-table detailed computation is now proved unable to return the detailed fuel-exhaustion cause from an arbitrary deferred context. This removes the one outcome on which the actual ordinary projection and the safe interpreter disagree. The remaining ordinary work is the distributional refinement across canonical boundaries: private structural hits map to false on the actual side, while every actual ordinary hit must map to a lazy hit. This refinement must use the existing sampling-order commutation rather than an invalid pointwise comparison at a fixed hidden table. + +A valid boundary context with fewer pending candidates than possible digests is now proved completable unless it already contains either a private structural hit or a pending hit against a missing one-time chain start. The latter event is transferred to one exact entry of the pending set, and averaging the missing chain-start table bounds it by `pending candidates * 2^-128` without enumerating the one-time secret index type. This is the terminal classification needed by the one-sided ordinary refinement. What remains is to prove that every reachable boundary has `remaining fuel + pending candidates <= q`, use that invariant to discharge the cardinality premise, and thread the sampled implication through the complete canonical boundary game. + +Every supported successful direct detailed run now conserves `remaining fuel + pending candidates`: it cannot exceed the same quantity at the start of the run. This accounts for probes that add at most one candidate, and for reveals that remove every candidate at their coordinate. Starting from the empty state therefore keeps every reachable successful boundary below `q`; together with `q <= 2^120 < 2^128`, the completion classification's digest-cardinality premise is discharged without a `Fintype` search over structural positions. The remaining ordinary work is to thread this invariant through the one-sided boundary refinement itself. + +The cause-aware direct interpreter now also has a general bind law. A stopped cause remains sticky, while a successful prefix passes its exact context, remaining probe fuel and fixed one-time table to the continuation. This is the compositional interface needed to thread the budget and one-sided failure refinement through root construction, adaptive signing and verification. The remaining ordinary work is unchanged: construct that sampled one-sided refinement, with private structural outcomes imposing no ordinary obligation, and lift it through the complete boundary game. + +The flattened ordinary endpoint now has its complete sampled empty-state wrapper, including final lazy completion rather than stopping at the existence of one clean completion. The safe detailed interpreter charges fresh reveal hits and the finalizer's unresolved pending candidates under the same conserved `(remaining fuel + pending candidates) * 2^-128` quantity, so `sampledFlatDetailedOrdinaryRetained` is bounded by `q * 2^-128` directly from the empty state. Separately, a valid boundary context with fewer pending candidates than digests can become non-completable without a private structural hit only through one missing chain-start table entry, whose averaged probability is at most `pending candidates * 2^-128`; this is the terminal classification needed while removing canonical boundaries. The flattened computation is factored into the same root, adaptive handler and verifier phases used by the canonical boundary game. Under the concrete hash-query bound and sampler support hypotheses, its distribution is now identified exactly with `LazyRevealProbe.experiment` on `deferredCleanRetainedRun`, including the experiment's final completion. What remains is the sampled one-sided refinement from the canonical boundary execution to this flattened endpoint, with private structural outcomes imposing no ordinary obligation and fuel exhaustion excluded by the concrete query bound. + +The one-sided refinement now has its run relation and its central probe-skip step. Clean related runs preserve their output, finalization view, ordinary cache and revealed set while allowing the canonical side to have less remaining fuel. If the canonical side probes a hidden private structural value which the materialized side can already read, a miss preserves that relation after adding the otherwise inert pending candidate, while a match is exactly `PrivateStructuralHit` and imposes no ordinary-failure obligation. What remains in the ordinary bridge is to lift this step through the finite scan in `prepareLeafInputProbe`, the decoded input resolver and the complete probing handler, then through the adaptive outer computation and terminal finalization. + +The clean relation is now directional at unresolved coordinates. The canonical pending set is included in the flattened pending set, allowing the flattened scan to skip a privately retained child and probe a later missing child. Every completion of the more constrained flattened context is a completion of the canonical context, so canonical non-completability implies flattened non-completability. The relation is transitive and is preserved when a completable flattened context gains one pending candidate. What remains is the finite scan and handler lift described above. + +The finite child scan is now lifted through that relation. Aligned materialized children recurse together, aligned missing children issue the same probe, and a canonical hidden child already materialized on the flattened side is classified by the structural skip rule before the flattened scan continues. Both scans spend at most one probe, and a later flattened candidate either preserves the ordered context or makes the flattened endpoint terminally doomed. The relation now records that the flattened side is fully materialized. The detailed interpreter preserves that property on every successful run and can therefore never report a private structural stop there. This makes right-side doom compositional through arbitrary continuations, and a general relational bind now separates clean, private-first-fire and doomed prefixes. The complete `prepareLeafInputProbe` is lifted when its decoded candidate is structural, including the hidden canonical child versus materialized flattened child branch. The decoded input resolver is now lifted too. It reconstructs the same available table input on both sides, sends a nonmatching input through the shared ordinary cache, and handles an exact honest input by coupling reveal, publication and cache insertion. The exact branch covers an already materialized value, a value retained privately only on the canonical side and a value sampled freshly on both sides. In the fresh case the directional pending inclusion makes a canonical ordinary hit imply a flattened ordinary hit, while an extra flattened hit is already an admissible right-side failure. What remains locally is the complete decoded hash handler. + +The complete decoded hash handler now satisfies the one-sided ordinary refinement. Decoded chain inputs couple their probe and resolver directly. Decoded leaf inputs couple the guarded source probe, the finite child scan and the leaf resolver. Undecoded node inputs couple the child scan and node resolver, while every other domain reduces to the shared ordinary cache. A latent private first fire after a leaf or node scan is proved to occur at a missing child, so the parent resolver cannot hide that earlier event behind a later ordinary stop and instead reduces to an ordinary random-oracle query. The remaining ordinary work is to lift this handler through the adaptive outer computation, root construction and verifier finalization, then identify the resulting sampled canonical ordinary endpoint with the already bounded flattened endpoint. The private structural endpoint still requires its adaptive lift from the established one-probe first-fire charge. + +The adaptive ordinary lift now has its boundary-normalization foundation. Canonicalizing the directional left context preserves its finalization relation to the fully materialized right context, published values remain included in the right state, and a latent private structural hit survives canonicalization. The complete `OracleWorld` handler, including probability-neutral uniform queries and the decoded hash handler, is lifted under the same relation. A generic terminal-observer algebra now maps private first fires to no ordinary obligation, propagates clean related runs recursively and absorbs a doomed materialized run as certain ordinary failure. The latter absorption is proved through every complete detailed continuation, so an extra right-side hit remains compositional. The recursive adversary lift must still carry the residual outer hash-query budget so every supported hash step has positive probe fuel; signing queries are probe-free but still require their directional structural coupling. + +The directional signing coupling is now complete. A signer-local stable relation excludes only a successful latent private hit, while retaining stopped private outcomes and doomed materialized runs, and has a compositional bind law. It is preserved by fixed chain-start reveals, fresh structural reveals, publication, ordinary hashes, uniform draws and administrative ensures, then through the complete tree builder, encoding retry loop, layer signer, delayed value publication and `maskedSign`, including failed signatures. Weakening the stable relation at the query boundary combines this signer theorem with the existing probing hash theorem into one complete `maskedExpandedAdversaryImpl` step. The remaining ordinary work is the path-sensitive adaptive induction that carries the residual outer hash-query budget through supported signing replies, followed by root and verifier composition and the sampled endpoint implication. + +The path-sensitive adaptive ordinary induction is now complete. It keeps the sampled one-time table fixed, follows only signer outputs in the support of that same concrete table, spends one residual budget unit exactly at an outer hash query, and preserves the directional clean relation across every canonical boundary. This avoids the false implication that agreement after canonicalization could recover unpublished chain-start materialization erased by canonicalization. Root composition is complete too: the empty canonical and materialized contexts satisfy the directional relation, the full published-root computation has the stronger stable coupling, and a generic observer lift carries any clean related root result into the remaining computation while absorbing a doomed materialized result. The complete retained continuation, including every verifier query and directional finalization over different pending-coordinate lists, now satisfies the same one-sided relation. Thus the root and full retained computation are coupled at one fixed table without losing first-cause ordering. The remaining ordinary work is to identify the original ordinary projection with this granular boundary, factor the materialized side into the already bounded flattened endpoint, and average the implication over the sampled one-time table. + +The ordinary boundary is now composed through the complete retained computation and factored on the materialized side into one direct resolved run with its real finalization observer. A separate granular cause-aware endpoint exposes the same root, complete adaptive retained computation and verifier, and its ordinary and private projections are proved exactly equal to their Boolean interpreters before and after sampling the one-time table. This avoids using a false fixed-table equality at an unpublished materialized structural value. What remains is to prove that forgetting the granular cause recovers the established canonical failure event, bound its ordinary projection by the lazy completion endpoint together with any explicitly retained private discrepancy, and lift the local private first-fire charge through the same granular schedule. + +The sampled granular ordinary projection is now related one-sidedly to the fully materialized boundary, and that materialized boundary is factored exactly into the flattened direct run. A missing chain-start hit is proved to make clean completion fail with certainty, so resolved finalization and clean finalization agree on every valid fully materialized context with fewer pending candidates than digests. The validity premise is essential: a later probe can match a structural value already materialized only on the comparison side, making resolved finalization fail while clean finalization clears that pending entry. This is exactly the private first-fire discrepancy, not an ordinary lazy hit. The remaining bridge must therefore retain that discrepancy explicitly while transporting granular ordinary failure to the clean endpoint, rather than bounding the conservative materialized Boolean by itself. + +The private Boolean interpreter now has a general bind law. A stopped cause remains sticky, while a successful prefix passes its exact deferred context, remaining fuel and fixed one-time table into the continuation. This supplies the compositional interface for lifting the local one-position first-fire estimate through root construction, the adaptive handler and verification. + +The final probability composition now also accepts one bound on the total detailed boundary-failure event with an arbitrary coefficient `c` satisfying `2 * c + 1 <= 19`. Cause names therefore need not be preserved across every canonical boundary. In particular, a three-unit one-time bound still closes the unchanged 120-bit statement because the two one-time terminal events and the one-unit few-time event consume only seven of the available nineteen units. The remaining work can charge a materialization-order discrepancy explicitly instead of asserting an invalid fixed-table equality to retain the tighter two-unit coefficient. + +The total-failure projection is now proved associative across a detailed canonical boundary even though the cause-aware outcome itself is not. Projecting both sides to the sticky Boolean observer reduces the proof to the exact bind law of `directBoundaryObserve`. Applying this law splits the complete granular retained endpoint exactly between the adaptive adversary and the verifier, for a fixed one-time table and after sampling it. The remaining schedule normalization is therefore verifier-local; root construction and adaptive signing no longer have to be regrouped together with it. A general exact bind law for the grouped resolved interpreter now isolates both verifier endpoints to the same concrete `scheme.verify` computation and the same final observer, leaving only canonical per-query boundaries versus one grouped verifier run. Unconditional schedule dominance is not assumed: a grouped scan can skip one hidden materialized child and probe a later child that the granular scan never reaches. Canonicalization now identifies the relevant discrepancy exactly as a pending candidate at an unpublished structural coordinate whose retained value it hits, hence as the existing `PrivateStructuralHit` first-fire event. The fresh local transition is charged too: sampling and privately retaining a structural value, materializing it only in the comparison state and adding one candidate makes the canonical discrepancy with probability at most exactly `2^-128`. Its classifier now has the same additive interface as the ordinary private classifier: after excluding the first fire, any continuation bounded by `b` gives a complete transition bounded by `2^-128 + b`. A cause-aware materialized boundary monitor now follows the grouped materialized execution without changing its hidden representation, checks this canonical discrepancy after every outer query, and projects exactly to its Boolean private event before and after sampling the one-time table. Its ordinary projection is now explicit as well, so reclassifying a materialization discrepancy changes only the cause and not the total failure. A full retained endpoint now carries the real final ordinary observer through the same cause-aware boundaries. Its sampled total failure splits mechanically into the ordinary projection plus the existing private monitor, which is the intended three-unit accounting: one lazy ordinary unit and the two first-fire orders. A generic residual-fuel induction now lifts any such local query bound through an arbitrary oracle computation, and the concrete masked handler is connected to its exact zero-or-one probe fuel conservation law. The adaptive specialization is complete too: it transports consistency and fixed-table agreement through every supported detailed step, uses the resulting honest signer output to inherit the remaining concrete query bound, and charges exactly one unit only in the direct hash branch. A tempting direct equality between the materialized fixed-table endpoint and lazy finalization has been ruled out: a later probe can hit an already materialized value, while lazy finalization deliberately clears that coordinate. This is precisely the event the explicit materialization monitor must pay for. The grouped materialized ordinary endpoint is now coupled below the full cause-aware failed endpoint, first for every fixed table and then after sampling. The proof is a semantic induction through the actual simulated computation: every extra canonical boundary can only turn failure on, including a private stop, a canonical private discrepancy and a non-completable boundary. Independently, the sampled granular total-failure probability is reduced to the sum of the fully materialized ordinary endpoint and the granular private endpoint. The cleanest target remains a three-unit bound that merges the granular private cause into the full endpoint. A strictly simpler four-unit fallback keeps that one-unit cause separate; it still closes the unchanged statement because `2 * 4 + 1 = 9 ≤ 19`. What remains is the local complete probing-handler inequality for the two first-fire orders, the ordinary projection's comparison with the already bounded flat lazy endpoint, and then either the direct three-unit domination or the simpler four-unit composition. + +The materialized guarded ordinary endpoint is now sampled and bounded by one unit. It records ordinary failure already visible in the final materialized context and is deliberately not treated as the full ordinary endpoint: failure created only by the final lazy completion remains in `sampledFlatDetailedOrdinaryRetained`, while a later candidate hitting an unpublished materialized value remains an explicit private discrepancy. The remaining endpoint comparison must retain all three terms. + +The four-unit fallback is now packaged without hiding any premise. The flat lazy and guarded materialized ordinary endpoints together cost two units, and granular total failure is reduced to the materialized canonical ordinary and private projections plus the granular private projection. A conditional theorem performs the final four-unit arithmetic once the original canonical endpoint is dominated by those four explicit events and both private projections are bounded by one unit. The generic adaptive lift for the materialized private projection is in place, and uniform outer queries have been discharged. What remains is the hash and signing step analysis for that lift, the analogous granular private lift, and the verifier-local semantic domination connecting the original endpoint to the four-event union. + +The signing step of the materialized private lift is now discharged. A support invariant proves that any zero-probe computation preserves both raw private cleanliness and cleanliness after canonicalizing unpublished materialized values. It handles uniform and fresh hash-output draws, ensures, peeks, publication and every reveal branch, and also proves that such a computation preserves its probe fuel. Since the masked signer is probe-free, a signing query can only continue from a clean result or stop for an ordinary reason, so it adds no private first-fire charge. The only probabilistic handler case left is a direct hash query. + +The materialized canonical private endpoint is in fact identically zero, so it needs no probabilistic charge. A direct materialized context can acquire a canonical private hit only by becoming invalid. Uniform and signing queries are probe-free and preserve validity. For a direct hash query, every decoded chain probe skips an already materialized chain value because the chain invariant makes it public, every leaf or node scan probes only a state-missing coordinate, and the remaining resolver is probe-free. The complete concrete handler therefore preserves validity on every successful result, while the direct interpreter cannot stop with a private cause from a materialized context. These facts are lifted through every adaptive boundary, root construction and the sampled one-time table. The granular private cause remains the sole first-fire probability bound. + +The granular hash handler now has a probe-free planning phase. It reads only materialization presence and returns at most one probe together with the probe-free suffix action. The finite first-missing scan and the leaf-specialized scan are each proved exactly equal to planning followed by executing the planned probe, and all three planners are probe-free. This isolates the chosen coordinate and candidate before any deferred private value is resolved, which is the interface needed to apply the one-position sampling commutation and first-fire bound. + +The planner is now also reflected as a pure function of the lazy state. Running either the finite first-missing planner or the leaf planner through the direct resolved interpreter is proved to return exactly that pure plan while leaving the deferred context, fuel, cache and fixed one-time table unchanged. Consequently the future first-fire proof can condition on the public plan without conditioning on a hidden structural output. + +The fresh planned-probe inequality is now complete. The local first-fire lemma retains the sampled resolution's support witness, resolving one hidden position and adding its planned candidate preserves canonical materialization on a published context, and a clean miss is carried through any probe-free suffix with no further charge. The resulting bound is exactly `2^-128` plus the continuation bound. What remains is to commute a planned coordinate that was resolved by an earlier root or signer computation to this fresh local form, then lift the inequality through the outer query budget. + +The planned-candidate commutation is now explicit. Resolving one target, executing any planned candidate and resolving the target again has exactly the same distribution as executing the candidate first and resolving once. The same-coordinate branch is the existing two-resolution law, while a different coordinate uses add-pending commutation. Iterating the resulting all-miss view reduces one fresh target to a fixed candidate list, whose hit probability is bounded by `list.length * 2^-128` through a recursive union bound over list entries. No position universe or function table is sampled. + +A proof-only plan trace now threads optional candidates through the complete private boundary. Uniform and signing queries record no candidate, while hash queries record the branch-local leaf, node or decoded-chain plan before executing the concrete handler. Mapping away the plan output recovers every concrete hash-handler branch exactly. Generic projection lemmas then show that a state-neutral planner followed by the plan-carrying boundary projects to the existing granular private interpreter, including stopped private causes. The retained finalizer and sampled-table wrappers are packaged as well. The concrete planner neutrality is intentionally left branch-local to avoid forcing Lean to normalize one large dependent match. + +The planned-candidate count is now tied directly to the source computation's `IsOuterHash` budget. A support-level induction proves that a planned boundary appends at most one candidate at a charged hash query and none at an uncharged uniform or signing query, independently of the hidden-state execution. The theorem is specialized through the complete adaptive retained rest and its finalizer. The root wrapper is deliberately kept separate after a monolithic specialization caused pathological dependent-type normalization. What remains is to combine this count with the first private-fire witness and the existing one-coordinate commutation, then package the lightweight root wrapper around that probability theorem. + +The finite all-miss candidate endpoint is now bounded too. It groups repeated candidates by their named structural coordinate, samples only coordinates that actually occur in the list, and charges the exact count in each group. Summing the groups proves a total `candidates.length * 2^-128` bound without enumerating `Position` or sampling a function table. A generic wrapper averages this bound over any random plan trace whose supported lists have length at most `q`. The remaining granular probability obligation is therefore one semantic domination: a concrete private first fire must imply a fire in this all-miss candidate endpoint for the trace it recorded. The existing resolution commutation lemmas are precisely the local steps for that domination. + +The all-miss endpoint is now realized by the actual deferred structural resolver from the empty context. A freshness invariant ranges only over coordinates occurring in the finite candidate list. Processing one coordinate samples it through `resolveDeferredPositionValue`, repeated candidates share that output, removing the group preserves freshness at every other named coordinate, and the resulting distribution is exactly the abstract grouped game. Thus the same `candidates.length * 2^-128` bound now applies to a concrete resolver execution. What remains is schedule normalization: commute the root, signer and verifier resolutions in the plan-traced private execution into this grouped finite resolver schedule while preserving its first-fire implication. + +The private witness now has candidate provenance. A generic support induction proves that a probe-free resolved computation can only preserve or remove pending candidates. `PendingCoveredBy` records every remaining pending pair in the chronological plan list, is initialized by the empty context, survives pending-set restriction, and is extended by one planned probe. Consequently `PrivateStructuralHit` together with this invariant yields `RecordedCandidateHit`: one private structural output is hit by an exact candidate already in the recorded list. The remaining normalization no longer has to rediscover the firing candidate; it only has to defer the witnessed structural resolutions to the finite resolver endpoint. + +Private structural values are now monotone through the complete direct interpreter as well. `PrivateValuesLE` says that every already sampled private position keeps the same full output, and the support induction proves it across uniform draws, fresh hash-output draws, ensures, probes, peeks, publication, chain-start reveals and fresh or cached structural reveals. This is the persistence fact needed after moving the finite candidate resolutions to an all-miss prefix: later root, signer or verifier work cannot replace a safely tested target with another output. + +The finite resolver now has an all-miss preparation form. Failure is exactly the bounded candidate fire; success returns a context in which every recorded structural coordinate has one persistent private output avoiding every recorded digest at that coordinate. `CandidateOutputsSafe` is preserved by `PrivateValuesLE`, so any later complete direct-interpreter run from a successfully prepared context cannot end in `RecordedCandidateHit`. The preparation's failure probability from the empty context is at most `candidates.length * 2^-128`. The remaining granular bridge is purely distributional: move this preparation across the concrete plan-producing execution, using the existing position-resolution commutation, so concrete private failure is absorbed by preparation failure. + +The local preparation commutation is now complete. If a structural position occurs in a fixed candidate list, resolving it before the all-miss failure observer or letting the grouped preparation resolve it in list order gives exactly the same distribution. The equal-coordinate case uses resolution idempotence. The distinct-coordinate case uses the existing two-position commutation, preserves the current group's output, and recurses after removing that complete coordinate group. This is the precise rule needed to move every root, signer and verifier private resolution across a fixed terminal plan list. + +That commutation now covers positions absent from the list too. `PendingCoveredBy` implies that an unlisted position has no pending digest, so resolving it cannot fail; clearing another coordinate preserves this fact. The grouped induction therefore accepts either list membership or this no-pending condition, and the final wrapper derives the disjunction automatically from candidate provenance. Hence the all-miss preparation observer is neutral under every structural position resolution reachable while the pending set is covered by the fixed plan list. + +The preparation is now packaged as a one-sided guarded observer. On a context whose pending set is covered by the fixed plan list it is exactly the finite all-miss risk; on an uncovered context it is `true`. Resolving any structural position cannot increase this observer. A covered context stays covered because resolution only removes pending entries and uses the exact commutation theorem, while an uncovered context is already at probability one. This is the compositional inequality required to lift the fixed-list normalization through the direct interpreter without assuming unreachable contexts are well formed. + +The first administrative lift is complete. The finite preparation failure distribution is unchanged by adding an ensured coordinate or publishing a coordinate. The proof commutes each operation through every grouped structural resolution and recurses on the remaining coordinate groups. Pending coverage is definitionally unchanged, so the same equalities hold for the guarded observer. These discharge the direct interpreter's `ensure` and `publish` cases without exposing any structural value. + +Planned probe insertion is now administrative too. Adding a chain-start candidate does not affect any structural group, and clearing that chain-start fiber cannot increase the guarded observer. For a structural candidate already present in the fixed terminal list, resolving an already resolved target after inserting the candidate returns `none` exactly when its truncation equals that digest; this is precisely one of the list's explicit `candidateListHits` cases. Distinct target groups commute the pending insertion recursively. Consequently adding any recorded candidate preserves the guarded preparation distribution, whether the concrete probe inserts it or skips it because the coordinate is already revealed. + +The guarded observer is now lifted through the complete direct interpreter for a fixed candidate list. The hypothesis is syntactic and exact: no probe query outside that list may occur. Uniform and fresh hash-output draws average the inductive bound; ensure, publish and recorded probes preserve the observer; chain-start hits contribute zero to the private projection; an existing private structural hit makes the preparation fail with certainty; a clean cached private reveal commutes materialization; and a fresh structural reveal is coupled to one guarded deferred resolution. Thus the interpreter's private-stop probability is at most the guarded preparation risk at its starting context. What remains is to instantiate the fixed-list probe hypothesis from the plan trace, whose planner records the candidate before executing the one probing suffix. + +The concrete planned suffix is now isolated. `probingHashQueryAfterPlan` executes the recorded optional candidate and then the probe-free ordinary or known-input action carried by `PlannedHashQuery`; its complete direct-interpreter computation has no uncovered probe whenever that optional candidate belongs to the fixed list. The pure planner is also executed exactly by the direct interpreter, returning `purePlanProbingHashQuery` without changing the deferred context, fuel, cache or one-time table. The old monolithic handler equality is intentionally avoided because its dependent outer match causes pathological normalization. Instead, the exact planner-then-suffix equation is proved separately for the leaf-plan branch, node-plan branch, decoded nonleaf branch and nonnode fallback. The remaining outer coupling can therefore replace the duplicated planner one query at a time without normalizing one dependent handler match. + +The normalized outer trace is now complete. `directDetailedBoundaryNormalizedPrivatePlanObserve` computes `purePlanProbingHashQuery` once at a hash query, appends its optional candidate before execution, and runs only `probingHashQueryAfterPlan`; uniform and signing queries append nothing. A structural induction over the adaptive source computation uses the four branch-local planner equations to prove that forgetting the list recovers the existing granular private interpreter exactly. The retained rest, root wrapper and sampled one-time-table wrapper are all packaged, so the sampled normalized trace has exactly the original granular private Boolean marginal. The remaining probability step is the hindsight preparation inequality for this normalized list-producing trace, after which the finite candidate bound and query-count theorem apply directly. + +The normalized trace count is also complete through the adaptive retained rest. A source `IsOuterHash` budget is consumed only in the direct hash branch, where `appendPlannedCandidate` grows the list by at most one; uniform and signing branches preserve its length. The proof is support-level and includes canonicalization and the retained finalizer. As with the earlier trace, the published-root wrapper is kept separate because asking Lean to infer the complete dependent retained result in one application causes pathological normalization. It will be attached after the probability theorem with explicit result types. + +The guarded finite preparation observer now crosses canonical boundaries exactly. The proof inducts over the finite candidate groups and uses `evalDist_resolveDeferredPositionValue_canonicalize` at each named structural coordinate, so no position universe is traversed. Candidate hits use the same full output on both sides; on a miss, value consistency and publication are preserved and the induction continues from the resolved context. Pending coverage is definitionally unchanged. Thus moving unpublished materialized values into the private table does not change either the finite preparation failure distribution or its guarded form. + +The fixed-final-list hindsight algebra is now in place. `PlanHitAt` gates the normalized output on one chosen final candidate list. A direct suffix counts a private stop only when its current prefix already equals that list, passes clean results to an arbitrary recursive observer, and is dominated by the guarded fixed-list preparation whenever all suffix probes belong to the list. If the current prefix differs from the final list and every clean continuation has zero gated risk, the complete suffix has zero risk as well. The canonical boundary has the corresponding guarded inequality, using exact preparation invariance and the fact that a private structural hit makes guarded preparation return `true`. What remains is the structural induction over `retainedGameRestComputation`, splitting on whether each appended prefix still prefixes the chosen final list, then summing the resulting fixed-list bounds. + +The clean-result side conditions for that induction are now discharged generically. A direct run whose syntactic computation contains no probe outside the fixed final list preserves `PendingCoveredBy` on every supported completed result, including fresh structural materialization and chain-start resolution. The single-plan probing suffix also preserves `PublishedValues`: its recorded probe changes only pending state, its ordinary action changes only the split cache, and its known-input action reuses the established resolver theorem. Finally, the canonical fixed-list observer is proved identically zero when its current prefix cannot equal the chosen final list and the recursive continuation is zero. The retained outer induction can now obtain consistency and start-table agreement from `ResolvedCore`, publication from the suffix theorem, coverage from the new generic invariant, and the guarded or zero recursive branch from prefix comparison. + +The fixed-list retained outer induction is now complete. Incompatible prefixes recurse with no state hypotheses and remain exactly zero. Compatible prefixes transport `ResolvedCore`, publication and pending coverage through uniform, signing and single-plan hash suffixes, cross canonicalization, and recurse under the guarded observer. A hash query whose appended prefix is incompatible switches immediately to the zero theorem, so no false requirement that its candidate belong to the chosen final list is introduced. The retained private finalizer is specialized too: it retains the current list and is only a `PrivateStructuralHit` classifier, hence an equal final list is absorbed by guarded preparation and a proper or incompatible prefix is zero. The normalized marginal is connected as well. Instead of an elaboration-heavy equality of complete dependent distributions, a probability-level structural induction proves directly that `PlanHitAt` has exactly the fixed-list Boolean recursion's probability. Consequently the normalized retained-rest `PlanHitAt` event is bounded by guarded preparation. A final audit caught that these bounds cannot simply be summed over final lists: each right-hand preparation risk is unconditional and has lost the probability weight of producing that list. The remaining granular bridge must therefore preserve the list-producing continuation weight, either as one joint hindsight coupling or as the equivalent query-ordinal first-fire induction. The probe-free root wrapper is postponed until after that weight-preserving theorem. + +The weight requirement is now an explicit checked interface. A generic fiber theorem permits the finite candidate endpoint only when every exact plan-list hit carries that list's production mass, so the rejected unweighted summation cannot be reintroduced accidentally. The ordinal route now has its first proof-only semantic layer as well: a parallel direct interpreter retains the exact position and full output of a private structural stop, erases distributionally to the existing detailed interpreter, and proves that every retained witness hits a candidate in the fixed covering list whenever the computation contains no uncovered probe. The next step is to thread this witness through the normalized outer plan trace, select its first candidate ordinal, and prove the one-ordinal deferred-sampling charge before taking the finite union over `q` ordinals. + +The witness is now threaded through the complete normalized retained rest. Erasing it recovers the existing normalized Boolean-and-list trace exactly through every uniform, hash and signing branch, canonical boundary and retained finalizer. A support induction proves that any retained witness hits one candidate in its own chronological list. A proof-only selector chooses the first such candidate and embeds its index into the source query budget; the existing normalized length theorem supplies the bound without enumerating `Position`. What remains in the granular probability bridge is the weight-preserving estimate that one fixed selected ordinal costs `2^-128`, followed by the finite union over ordinals and the lightweight published-root wrapper. + +The one-ordinal endpoint and the finite-union arithmetic are now checked. `plannedOrdinalCandidateFire` reads exactly one candidate from a generated prefix, samples only its named structural output and costs at most `2^-128`; averaging over any random prefix retains that same bound. `privateCandidateFire` is the corresponding deferred-context observer and has the same bound from a fresh or empty context. A generic bounded-ordinal theorem turns one `2^-128` estimate for each member of `Fin q` into `q * 2^-128`, provided every supported private witness is classified, which the retained support theorem supplies. The remaining hard statement is now isolated precisely: factor one selected ordinal of the concrete normalized execution through this fresh deferred-context observer while retaining the probability of the prefix that produced its candidate. + +The reverse signer seam now has its exact whole-signer finalization kernel. The masked digest loop, all three signing layers, reveals and publication preserve `FinalizationMaterializedRunEq`; canonicalizing a direct post-signer context and rematerializing it recovers the exact operational state under start-table agreement and chain validity; and published canonical observers synchronize across finalization-equivalent contexts without assuming raw private-state equality. The remaining local composition connects these kernels to the recursive reverse implication, then the nonselected hash constructor completes the prefix induction. + +The selected-ordinal observer now has an all-miss context form. `preparePrivateCandidate` reuses or draws exactly the selected structural output, returns failure precisely when that one candidate matches, and otherwise returns a context in which the candidate is permanently safe under every later `PrivateValuesLE` extension. Its failure marginal is exactly `privateCandidateFire`, hence at most `2^-128` from the empty context. The observer is definitionally unchanged by ensuring, adding pending candidates, publication and clearing pending candidates, and it crosses canonicalization exactly under `ValuesConsistent`. The remaining factorization can therefore move administrative and canonical boundaries directly; its substantive cases are structural resolution and the concrete masked signer/hash continuations that generate the selected prefix. + +Fixed-candidate commutation is now complete through the full direct interpreter. Resolving the selected position early can only discard mass through an older pending hit. Resolving another position is swapped with the selected failure-free deferred draw, after which forgetting the other resolution is one-sided. These local rules lift by structural induction through uniform and hash-output draws, ensure, every probe and fuel branch, peek, publication, deterministic chain starts, cached private structural values and fresh structural materialization. Thus any complete inner computation run before one already fixed candidate cannot increase `privateCandidateFire`. The remaining one-ordinal factorization is no longer inside the resolved interpreter. It is the outer noninterference statement that the later candidate selected from the adversary trace is blind to a structural output that is still private; once that candidate is fixed, the new interpreter theorem discharges every intervening inner computation. + +The retained finite union is now packaged at the exact existing Boolean endpoint. For any retained rest with `q` outer hash queries, if each selected ordinal costs one `2^-128` unit, witness coverage and the normalized plan-length theorem classify every supported private stop in `Fin (currentCandidates.length + q)`. The generic ordinal union then gives the corresponding linear bound, and exact witness erasure plus the normalized marginal theorem transports it to `granularDetailedRetainedRestPrivateObserve`. No witness, list or ordinal data crosses this interface. The sole missing retained-rest probability premise is therefore the fixed-ordinal outer noninterference estimate itself. + +The post-selection half of that premise is now complete. `PrivateHitWitness.MatchesCandidate` identifies the exact fixed candidate responsible for a stop. A combined direct observer counts a matching private stop or, on completion, tests the same candidate against the final deferred context; the complete direct interpreter cannot increase this event. The result lifts through canonicalization, including a hit detected exactly at the boundary, and then through every uniform, hash and signing branch of the normalized outer computation and the retained finalizer. Consequently, from any consistent context with an agreeing chain-start table, every later matching witness is bounded by `privateCandidateFire` for the already selected candidate at that context. What remains for one ordinal is only the prefix-selection half: follow clean earlier queries until that ordinal's candidate is chosen, while retaining that the chosen candidate was not influenced by a still-private output. + +Candidate-list monotonicity is now explicit for the witness trace. Every direct stop retains the current list, every completed continuation extends it, canonicalization preserves it, and a hash query contributes only its one optional append. The invariant is lifted through the complete normalized retained rest and finalizer. Therefore a witness that uses an ordinal already present in the current prefix necessarily matches the exact candidate stored at that ordinal. Combining this support fact with the post-selection probability theorem bounds the complete later retained execution by `privateCandidateFire` for that fixed candidate. The next prefix step is the single hash query at which the ordinal first enters the list; earlier queries then remain as the only noninterference induction. + +That exact selection step is now complete too. A generic append lemma turns extension of `current ++ [candidate]` plus a fixed-candidate matching bound into a bound for `WitnessUsesOrdinal current.length`. It is instantiated on one normalized hash-plan branch: the probing suffix and every later canonical, adaptive and terminal continuation preserve both the appended prefix and the fixed-candidate risk. Hence a witness using the newly selected ordinal is bounded by `privateCandidateFire candidate` in the context before that query executes. The only remaining fixed-ordinal work is to transport this selected-candidate observer backward through the earlier clean query prefix to the empty context, where it costs exactly `2^-128`. + +The backward transport now has an explicit prefix-risk computation and its local simulation algebra. `directDetailedBoundaryPrivateOrdinalRisk` follows the same normalized outer execution while the ordinal is absent, maps every earlier stop to zero, crosses a clean canonical boundary with the same recursive state, and stops immediately at the first append that contains the ordinal to evaluate that candidate's `privateCandidateFire`. If the ordinal is already present it reduces definitionally to the stored candidate's risk; if a pure computation ends first it is zero. Generic direct-finish and canonical lemmas prove that the real witness event is dominated by this risk at every earlier completed step. A monolithic structural induction was rejected after Lean spent minutes normalizing its dependent query match. The remaining assembly is being split into the uniform, hash and signing branch lemmas already used successfully elsewhere. + +The witness-to-prefix-risk assembly is now complete. An unselected direct step crosses its canonical boundary through one reusable lemma, the exact hash branch that appends the ordinal switches to the selected-candidate theorem, and uniform, unselected hash and signing branches recurse with value consistency and start-table agreement. Splitting these cases before unfolding the dependent query match keeps elaboration local. The retained finalizer contributes zero before selection, preserves the candidate prefix and satisfies the fixed-candidate matching bound, so the complete normalized retained witness event is dominated by `granularDetailedRetainedRestPrivateOrdinalRisk`. The remaining fixed-ordinal obligation is the genuinely distributional one: bound that prefix risk from the root-wrapped empty context by `2^-128` without conditioning on a materialized private value. + +A subsequent soundness audit found that the ungated `privateCandidateFire` is too broad for that last bound: it also fires when a recorded plan names an already published coordinate, where the candidate may equal the known value with probability one although no private witness can use it. The new `hiddenPrivateCandidateFire` returns false on published coordinates. A structural candidate produced by the planner is now proved branch by branch to be either a decoded chain probe or an exact child of a leaf or node input, hence its position has a named parent. `CandidatePositionsFresh` states only the required invariant, that an unpublished position with a parent has neither a materialized state value nor an auxiliary private value, and the hidden candidate costs exactly one `2^-128` unit under that invariant. The remaining work is to package the branch provenance without unfolding the complete dependent decoder match, strengthen the selected-ordinal domination to the hidden observer, and preserve `CandidatePositionsFresh` through the root and normalized outer prefix. + +The hidden endpoint is now connected through the full post-selection proof. Planner provenance is packaged without a dependent `Position` case split by using the existing fact that a decoded chain probe's input position is either a chain or leaf and a separate nonnode exclusion for the no-probe branch. A published coordinate is proved monotone through every direct-interpreter instruction, so no supported private stop can match it. This strengthens fixed-candidate matching through the direct run, classification, canonicalization, every normalized outer query and the retained finalizer. The exact selection query now lands on `hiddenPrivateCandidateFire`, and a parallel hidden ordinal-risk computation carries the concrete `WitnessUsesOrdinal` event through the complete retained rest. The obsolete ungated risk remains only as earlier scaffolding and is no longer the intended probability endpoint. What remains for one ordinal is now the support invariant that every unpublished planner-produced child position is fresh at the selection boundary; once available, the hidden risk has the pointwise `2^-128` bound. + +Freshness cannot be asserted pointwise in the concrete post-signing context: an unpublished lower-layer root may already be materialized, while its value remains unpredictable because it only influenced independent random-oracle answers above it. The invariant is therefore for the delayed comparison schedule, not for the concrete state itself. The generic transport needed by that comparison is now checked. If a position starts with neither a state value nor an auxiliary value and a completed direct run still has no state value there, then the run could not have installed an auxiliary value there. Together with monotonic publication, this transports `CandidatePositionsFresh` through canonicalization once the comparison schedule proves that every materialized child value is published. The remaining fixed-ordinal theorem is precisely the weight-preserving coupling from the concrete hidden prefix to that delayed fresh schedule. + +The one-unit arithmetic over the delayed schedule is now complete behind that exact interface. `CandidatesHaveStructuralParent` is initialized by the empty list and preserved by every optional planned append using the planner-proven parent witness. A structural induction over the hidden ordinal risk proves its probability at most `2^-128` whenever uniform, normalized hash and signing steps each transport `CandidatePositionsFresh` across completed published canonical boundaries. Stops and incomplete canonical contexts contribute zero, and the first append selecting the ordinal invokes the hidden one-candidate bound directly. The retained-rest specialization exposes only those three freshness premises. Uniform and normalized hash transport are local implementation obligations; signing is the substantive delayed-sampling coupling because its unpublished lower-layer roots may already be materialized in the concrete schedule. + +Canonicalization itself now preserves `CandidatePositionsFresh`, and the uniform branch is discharged exactly because `splitUniformImpl` leaves the deferred context unchanged. The one-unit theorem also carries `PublishedValues` at every recursive boundary, which is needed to distinguish a truly hidden child from a coordinate already made public. The normalized hash branch is now discharged too. A coordinate that starts materialized only when published remains so through the planned probe and its ordinary or known-input suffix; applying this simultaneously to every structural child shows that canonicalization preserves candidate freshness after `probingHashQueryAfterPlan`. The sole nonlocal premise is now the signing comparison that delays unpublished layer-root values while preserving the adaptive continuation's distribution. + +The signer obstruction is now classified exactly. Every signer primitive preserves the rule that a materialized parented position is published, except `maskedLayerMessage`, which may materialize the root of the tree below the current layer. Composing this fact through the full digest loop, all three layer selections, success publication and failure paths proves that `CandidatePositionsFreshExceptLayerRoots` is preserved by uniform, normalized hash and signing steps. A layer root with a structural parent must be a middle or bottom root: the top root has no parent, while the finite `Position` over-approximation gives a short-layer root an artificial parent one level above the real tree. Thus the distributional remainder is no longer the whole signer. It is exactly the hidden middle or bottom root retained after a signer invocation, including a failed invocation where no signature makes that root recoverable. + +The missing charge for those two root families now has a finite query-local representation. An adversarial encoding-domain query carries its guessed layer message in payload slot zero. `EncodingLayerRootCandidateAt` maps a top-layer encoding query to the corresponding middle root and a middle-layer encoding query to the corresponding bottom root; the mapping is unique even though it is stated existentially through an index, because a layer's tree and leaf determine the layer message position. `decodeEncodingLayerRootCandidate?` packages that map as one optional proof-only candidate, and `rootAwarePlannedCandidate?` prefers the already executed structural candidate when one exists and otherwise records this encoding candidate. Every recorded candidate still has a structural parent and every outer hash query still contributes at most one list entry. This root-aware list is now threaded through the normalized trace, exact Boolean projection, query-count theorem, fixed-list hindsight observers, witness coverage, prefix monotonicity and both ordinal-risk computations. The newly recorded candidate need not be the probe executed by the same query; the fixed-candidate continuation proof is now stated at its actual generality and handles that case unchanged. Consequently a cached encoding prehit is assigned to the query that guessed the root before a signer response can depend on it. The remaining delayed-signer lemma may assume that no earlier recorded candidate already matches the selected root ordinal. + +The ordinal selector now makes that last sentence formal. `firstPrivateWitnessOrdinal?` is the least matching index in the final candidate list rather than an arbitrary classical witness. `WitnessFirstUsesOrdinal` records the exact selected index, the bounded selector implies it directly, and a strict earlier index is proved not to match the same private witness. The existing broader `WitnessUsesOrdinal` remains available for every non-root estimate. The root case can therefore carry the genuinely useful condition that all earlier encoding-root guesses missed, instead of discarding it before the signer comparison. + +The least event is now split definitionally into `WitnessFirstUsesLayerRootOrdinal` and `WitnessFirstUsesNonLayerRootOrdinal`. The complete non-root case costs one `2^-128` unit. `nonRootHiddenPrivateCandidateFire` gates a root candidate to false and otherwise uses the existing hidden observer; `directDetailedBoundaryPrivateOrdinalNonRootRisk` carries that gate through the full adaptive computation. Its structural induction uses `CandidatePositionsFreshExceptLayerRoots`, which is preserved by uniform, normalized hash and concrete signer steps. Separate finish, canonicalization and direct-step lifts retain the least non-root event rather than broadening it to an arbitrary ordinal use. The selected hash branch is zero when the appended candidate is a root and otherwise uses the existing hidden fixed-candidate bound. The resulting retained-rest theorem deterministically dominates the exact least non-root witness event by the non-root risk and then applies its one-unit probability bound. The remaining fixed-ordinal work is only the layer-root case, which needs the delayed comparison with the strict earlier-miss condition. + +The delayed root comparison now has a concrete query-local schedule. `probingHashQueryAfterRootAwarePlan` executes the root-aware candidate before the unchanged probe-free planned action. If the structural planner already selected a candidate this is exactly the old suffix. Otherwise any added candidate is proved to be an encoding-derived layer root with a structural parent. The wrapper and its complete random-oracle implementation spend at most one probe per outer hash query, signing remains probe-free, and the published-root prefix spends none. The corresponding lazy experiment is bounded by `q * 2^-128`. This directly handles a candidate inserted before its root is materialized, since the later reveal checks the pending digest. A candidate inserted after materialization still needs the delayed comparison below. + +The root-aware lazy comparison is now coupled through the complete execution and clean finalization. `ProbeStateLE` keeps the value, revealed and ensured maps equal while allowing the comparison run a superset of pending probes and less remaining fuel. A structural induction couples every uniform draw, hash-output draw, administrative operation and reveal; a comparison-side hit may stop, while a successful comparison step fixes the original step with the same output and cache. The relation is proved for one planned hash suffix, the complete probing handler, one expanded query and an arbitrary adaptive computation, then through the public-root wrapper. Clean finalization is monotone under the same relation even though the comparison state may contain extra coordinates: its coordinate list is permuted to process the original coordinates first, the same missing outputs are coupled, and surviving comparison outputs avoid every original pending candidate. The fixed-table failure inequality is averaged through the opaque OTS-table sampler, so no sampling definition is unfolded. + +The sampled clean failure monotonicity is exposed as a reusable endpoint: the original deferred lazy run followed by clean completion has probability of failure at most the root-aware run followed by clean completion, first for each fixed start table and then after averaging over `sampleOtsHashTable`. The averaging uses a separate opaque wrapper and the existing bind inequality, avoiding elaboration of the function sampler. A terminal audit then identified the exact limitation of this endpoint: `LazyRevealProbe.finalizeFrom` deliberately clears a pending fiber without testing it when that coordinate already has a materialized value. The resolved finalizer repairs this by rejecting every non-completable context, but the clean endpoint alone does not count a correct probe inserted after materialization. The remaining root proof must therefore use `resolveDeferredPositionValue_then_resolveAfterCandidate` to commute that root draw after the selected probe, or equivalently transport the event to the resolved non-completability check. This is the strict earlier-miss delayed comparison and is the sole unresolved probabilistic bridge. + +The source event for that implication is now packaged exactly. `WitnessFirstUsesSomeLayerRoot` and `WitnessFirstUsesSomeNonLayerRoot` split a covered private witness at its least matching candidate, and a generic event theorem bounds the witness event by their union. A sampled normalized witness game is defined by averaging the existing fixed-table trace over `sampleOtsHashTable`; its `isSome` marginal is proved equal to `sampledGranularAllDirectBoundaryDetailedRetainedPrivate`, so no witness data will escape the final interface. The retained-rest coverage theorem is already available. Its published-root specialization must remain branch-local because a monolithic dependent application caused pathological normalization. + +The delayed root comparison now has its cache quotient. For one chosen layer root, `RootEncodingCacheRel` agrees exactly on every ordinary input that does not name that root, pairs every canonical encoding retry input carrying the actual root with its counterpart carrying an alternate root, agrees on every hidden coordinate, and retains exact entries for every root-naming input whose guessed digest is neither distinguished root. Corresponding fresh retry inputs receive the same random-oracle answer, including when either cache already contains the paired entry. This strengthened relation is compositional through administrative ensures, and it couples the exact concrete `encode`, the complete capped `maskedOtsSignFrom` retry loop, all successful chain-prefix and authentication-path reservations, identical non-root ordinary queries, hidden-coordinate reveals, complete lower-tree root reconstruction, the bottom few-time key computation and every ordinary `maskedLayerMessage` computation. The post-message `maskedOtsLayerAfterMessage` is therefore coupled for the two root values. A stored-root invariant is monotone through the complete fixed-table clean interpreter. A small equality-based interface identifies any matching layer message with its exact lower-tree root without normalizing a dependent layer match. The target-aware comparison selects the comparison-root implementation at the unique matching layer and proves that every unrelated layer preserves the quotient through its complete retry and path reservation. The stored-root relation now composes through the full three-layer sequence, the few-time authentication opening, failed-layer propagation, successful chain and path publication, and the complete digest retry prefix. Consequently every complete signer invocation after first materialization, whether it succeeds or fails, preserves the stored actual root and the strengthened cache quotient while returning exactly the same optional signature in the comparison run. A target-naming direct query is classified exactly: it is the actual-root hit, the comparison-root hit, or a wrong guess whose cached or fresh response is identical on both sides and preserves the same relation. The corresponding safe-input predicate now gives one coupling for either a non-root input or a wrong root guess. The complete planned hash suffix preserves the quotient on such an input, including its proof-only probe, recursive structural peeks, known-input reveal, publication and ordinary cache insertion. The public planner is now coupled too: the first-missing scan and leaf scan preserve the quotient by recursion over their finite coordinate lists, and the original probing handler is reconstructed through its four branch-local planner equations. Thus every complete direct hash query that guesses neither distinguished root preserves the quotient without normalizing the dependent decoder match. If neither distinguished root was guessed before first materialization, the identical pre-phase cache establishes the quotient for the two roots directly. A proof-only root-avoiding source computation now stops before either distinguished-root query. Its complete adaptive simulation couples the actual and comparison games through every safe uniform, hash and signing query while preserving both the cache quotient and the stored actual root. The least-ordinal interface now proves that the selected index itself matches the retained private witness and that every strictly earlier candidate at the same position carries a different digest. Domain separation proves that an encoding input has no structural decoder result, so every encoding input guessing either distinguished root is recorded as exactly that root-aware candidate. Candidate avoidance therefore implies the safe-input premise used by the cache quotient. Projecting a complete stored-root coupling to the computation's returned value now gives exact equality of the actual and comparison prefix distributions, forgetting their paired cache keys and internal lazy state. A generic averaging lemma turns any such root-independent output distribution into the exact one-guess bound: sample the comparison root, replace the dependent run by the fixed reference distribution, commute the two independent draws, and the output's chosen digest matches the root with probability at most `2^-128`. A two-root exchangeability wrapper now gives the same bound for the actual root whenever the concrete run is symmetric under swapping the two uniform roots and its visible output is independent of the comparison root. Both results now have weighted forms: conjoining any output-dependent fiber gate costs that fiber's production probability times `2^-128`. Thus hindsight classification by the dynamically selected root position can be summed without a factor for the number of positions. The next lift proves the two exchangeability hypotheses for each least-ordinal position fiber. + +The fixed-ordinal root event is now classified by its dynamically selected layer-root position. Inside a nonempty fiber, the selected list entry is proved to be the exact first match for the retained witness, its coordinate is that fixed root position, and its digest is the truncation of the retained private output. The `none` fiber cannot contain a layer-root event. A generic weighted-fiber wrapper therefore reduces the complete root ordinal bound to one production-weighted exchangeability theorem for each fixed position, with no `Position` enumeration. + +The selected private structural output is now split bijectively into an independent uniform 128-bit root and 128-bit high half, and rebuilding the output recovers exactly the original uniform `HashOutput` distribution. Fresh deferred resolution is expressed through these two draws, and materializing a successful resolution produces the exact `StoredLayerRoot` premise used by the signer comparison. The comparison cache no longer needs either root to be absent beforehand: a proof-only involution swaps every canonical encoding retry key carrying the actual and comparison roots, leaves unrelated and wrong-guess keys fixed, and establishes `RootEncodingCacheRel` from an arbitrary cache. Swapping the roots again restores the original cache. This removes the earlier comparison-root prehit loss rather than union-bounding it. + +The state side of the swap now has its own quotient. `RootHiddenStateRel` permits the two clean runs to store different full outputs at exactly one unpublished layer-root position while keeping pending probes, revealed and ensured coordinates, and every other value synchronized. It is symmetric, initialized by materializing the two root outputs into one common state, and preserved by ensures, pending insertion and clearing, publication away from the target, and materialization of every other coordinate. The next local obligations are the target reveal, whose differing result is deliberately ignored by the comparison signer, and safe direct queries that do not select either root. + +The complete public planner is insensitive to the differing hidden root. Its first-missing and leaf scans are equal because they inspect only whether a cell is present, and `purePlanProbingHashQuery` plus the root-aware optional candidate are therefore identical in the two states. Running the monadic planners through `runCleanFromTable` is now proved exactly neutral: each returns that pure plan without changing state, fuel, table or cache. This supplies one common plan before the remaining suffix comparison. + +`RootHiddenRelates` now lifts the state quotient to complete clean runs, retaining equal fuel, fixed table, returned value and split cache, and it composes through monadic binds. Pure computations, the full planner, uniform outer draws, administrative ensures and proof-only probes are related. The remaining primitive work is narrowed to safe ordinary lookup, target-aware structural resolution, and the comparison signer. + +The clean-run quotient now includes the split cache as well. Ordinary entries remain exactly equal, all hidden entries away from the target remain equal, and the target hidden key stores the respective full root output. Replacing that one entry constructs the relation from an actual materialized cache and is involutive. The monadic, planner, uniform, ensure and probe rules all preserve this stronger cache relation. + +Ordinary random-oracle lookup now preserves the quotient in both cached and fresh cases, with a shared fresh answer updating both ordinary caches. Revealing any coordinate other than the selected root is coupled too: cached values agree, fresh structural outputs are sampled together, pending-hit stops agree because pending sets are equal, and successful materialization plus the hidden-cache update preserve both quotients. The only reveal still outside the equality-valued relation is the selected root itself. + +The selected-root reveal now has its dedicated unequal-value relation. It returns the truncations of the respective full root outputs while preserving the hidden state and cache quotients. All finite chain and tree reservations are related compositionally, `maskedTreeRoot` is reduced to its reservation followed by the exact root reveal, and the complete target tree-root computations therefore satisfy that relation. This is the interface required by the matching layer, where the comparison signer deliberately discards the left root and supplies the right root to both encoding continuations. + +The complete common post-message work is now related: arbitrary `simulateQ` computations whose handlers preserve the quotient, ordinary hash queries, chain-prefix and tree-path reservations, the capped `maskedOtsSignFrom` counter loop, `maskedOtsSign`, and `maskedOtsLayerAfterMessage`. Composing this with the unequal target message proves that the unique matching comparison layer and the actual right-root layer return exactly the same optional layer signature while preserving both quotients. + +Every unrelated layer is now related as well: its tree root is distinct from the selected target or it is the bottom few-time key, so its message remains equal and the same post-message computation follows. The target-aware three-layer sequence is coupled to the complete actual sequence. Successful publication is safe because chain coordinates are never layer roots and every authentication node lies strictly below its tree root. FTS opening, all layer results, failure propagation, success publication and the common digest-selection loop therefore compose into the full signer. Chaining the encoding-cache comparison with the hidden-state comparison proves exact equality of visible signer distributions between actual left-root and actual right-root executions under the full cache swap. + +The direct hash side now has a value-parametric clean relation. `peekCoordinate`, recursive `peekPositionValues` and complete `peekTableInput` agree on option shape even when their reconstructed bytes differ at the hidden root slot. Strengthening this coupling with support witnesses proves the exact safe `resolveKnownInput` rule: if neither reconstructed input equals the adversarial input, both executions take the same ordinary random-oracle branch and preserve the swapped-root quotients. The next step derives those miss premises from the recorded root-aware candidate and least-ordinal condition. + +The combined cache transformation used by the state swap is now involutive as well: swapping the two root digests in canonical encoding keys and replacing the hidden target output, then reversing both operations, restores every split-cache key exactly. + +The adaptive boundary now has its canonical deferred quotient. The two contexts have exactly equal visible lazy state, the selected root is absent and unpublished there, their private tables store the respective full root outputs at that one position, and every other private value agrees. The relation is symmetric, initialized by installing the two outputs, preserved by administrative state changes, gives equal `positionValue` away from the target, and survives `canonicalizeMaterializedValues`. This is the representation used by the normalized retained trace between signer invocations. + +The deferred quotient now crosses the materialized part of one query as well. Materializing the selected target produces the existing hidden-state quotient, and canonicalizing two related materialized contexts restores the deferred quotient while erasing the unpublished root from visible state. Candidate tests away from the target are exactly equal in the two deferred contexts, while a target test reduces definitionally to equality with the respective root digest. The hidden ordinal risk is now factored exactly into a prefix that records the selected candidate and canonical deferred context without reading the target output, followed by this one final candidate test. What remains is to prove exchangeability of that selection prefix under the full root/cache involution and apply the existing weighted position-fiber theorem. + +The full root cache relation is now packaged as its actual two-stage witness: an encoding-key quotient from the left run to the target-aware comparison run, followed by a hidden-root quotient from that comparison run to the right run. The complete signer coupling now retains arbitrary continuation observers on all three runs. Any observer invariant under the encoding relation and then under the hidden-root relation therefore has exactly equal distribution before and after the signer. This removes the earlier loss of final signer state from `evalDist_swappedRoot_maskedSign_eq`; the remaining selection-prefix induction must instantiate those two observer obligations after canonicalization. + +The selection prefix now has its materialized comparison world. `materializedDeferredState` copies only outputs already present in a deferred context, samples nothing, preserves every completed coordinate value and constructs the existing `FinalizationContextLE` shadow required by the directional signer coupling. Swapped deferred roots become the existing hidden-state quotient after this materialization. The auxiliary prefix derives each candidate from the canonical public view while executing against the materialized state, stops before the selected ordinal, and rejects an earlier guess of either distinguished root. Its encoding-side exchangeability induction is complete through uniform draws, every safe planned hash suffix and the full actual-versus-target-aware signer. What remains locally is the hidden-state half of the same induction, whose only new case is a planned structural resolver whose reconstructed payload contains the swapped target root. + +The hidden-state half is now complete too. The materialized prefix no longer lets extra private values change structural input availability: it computes the resolver decision from the canonical public state, then executes the resulting public action against the materialized shadow. Exact public inputs reveal and publish the same non-target coordinate; unavailable or nonmatching inputs use the shared ordinary cache. Candidate execution, full-output reveal, publication and ordinary-cache update all preserve the hidden-root quotient. Consequently the target-aware comparison prefix and the actual right-root prefix have exactly equal selected-candidate distributions. Composing this with the encoding-side theorem and the explicit middle cache proves full exchangeability of the materialized root-avoiding prefix under swapping both root outputs and the complete cache transformation. What remains is to relate the real deferred least-ordinal event to this materialized prefix and account for the branch where the independent comparison root was guessed at an earlier candidate. + +The auxiliary prefix is also invariant under exchanging the order in which the two distinguished roots are named. Together with the involutive full-cache swap, this packages the exact `run leftRoot rightRoot = run rightRoot leftRoot` hypothesis needed by the symmetric two-root probability lemma. The next bridge is one-sided: a real deferred selection that survives to its chosen ordinal must appear in the materialized public-plan prefix, while an earlier private stop contributes no selected event. + +The comparison-root exceptional branch now has its standalone probability and arithmetic tools. For any event produced before an independent uniform comparison root is drawn, membership of that root in a run-dependent list of at most `q` earlier candidate digests costs at most the event probability times `q / 2^128`. Under `q <= 2^120` this coefficient is below one half, and a proved ENNReal absorption lemma turns `p <= 2^-128 + p / 2` into `p <= 2 * 2^-128`. Thus the real-to-materialized bridge may stop at an earlier comparison-root guess without introducing a query-squared term; the layer-root ordinal can safely spend two units. + +The real-to-materialized bridge now retains the selected prefix list and has its two-computation directional kernel. `OrdinaryMaterializedStableCouplesBetween` generalizes the existing signer relation to a deferred computation on the left and a different materialized computation on the right; its positive-fuel form couples the one planned probe and classifies a materialization-only hit as a doomed right context. Pure public structural lookup is proved exactly equal to `peekTableInput` under the detailed deferred interpreter, and `resolveKnownInput` is therefore exactly replaceable there by the explicit canonical public resolver used by the exchangeable prefix. The remaining bridge work is to package that public planned suffix and then lift the relation through the outer computation's canonical boundaries. + +The complete public planned suffix is now packaged. Its optional probe uses the positive-fuel directional relation; ordinary lookup reuses the established cache coupling; an exact public structural input uses a continuation-aware full-output reveal, publication and ordinary-cache update; and the unavailable case is the shared ordinary lookup. The real `probingHashQueryAfterPlan` and this public suffix have exactly equal detailed deferred semantics, so the resulting relation directly couples the real left query to the materialized right query. The selected-root event now explicitly retains the target's private output and requires both distinguished roots to be absent from every earlier candidate. What remains is the structural induction through uniform, hash and signing queries, using the existing canonicalized `OrdinaryMaterializedRunEq` at each continuation. + +All runners used by that induction now share one detailed interface. Erasing a retained private witness and then finishing selection is distributionally equal to the detailed deferred runner; projecting a detailed fully materialized result is distributionally equal to `runCleanFromTable`; and both finish observers commute with those projections exactly. This leaves no probabilistic conversion at an adaptive bind. The remaining relational case is semantic rather than representational: exclude a stopped materialized suffix when the paired real suffix reaches a good selected root, then recurse through the clean `OrdinaryMaterializedRunEq.canonicalize_left` branch. + +The selected record now has its complete chronological prefix invariant. Every supported selection contains the candidate list with which the ordinal was chosen, and that list extends the candidates present at every earlier recursive boundary. The proof covers all stopped outcomes, canonical private-hit and non-completable branches, and every uniform, hash and signing continuation. Therefore an unsafe distinguished-root candidate appended before the chosen ordinal contradicts the good-root event directly; the outer induction may terminate that branch without executing either suffix. + +The materialized side now retains a three-way outcome: failure, ordinary completion without the ordinal and a selected candidate. Stops, non-completable contexts and publication of the target root are classified as failure before any recursive observer runs. A continuation-aware relational finisher is complete for `DirectDetailedOrdinaryStableRunEq`: stopped left results make the good-root premise false, stopped or doomed right results produce failure, and clean results canonicalize the left context and recurse with the exact retained state and caches. This is the terminal algebra required by the outer adaptive induction. + +Canonical planning is now aligned across every clean pair as well. A `FinalizationContextLE` whose left side is canonical has the same visible value map as the canonicalization of its fully materialized right side, and `purePlanProbingHashQuery` depends only on that map. The complete first-missing and leaf planners are proved equal from value-map equality. Consequently each hash branch appends the same root-aware candidate before the directional suffix coupling is applied; only the explicit safe-versus-distinguished-root split remains in the outer induction. + +The three outer transition kernels are now assembled against the failure-retaining outcome. Uniform queries use the existing materialized coupling, signing queries use the complete masked signer coupling, and hash queries choose the zero-probe or positive-fuel public-plan theorem according to the concrete plan. Each kernel first transports the witness runner to the detailed runner, then applies the common relational finisher, so clean continuations receive the exact canonical context relation and stopped or doomed paths become failure. The remaining outer theorem is now only structural recursion and the unsafe-candidate zero branch. + +The failure outcome now executes a target-naming public action rather than rejecting it syntactically. Only an actual publication becomes failure; unavailable and nonmatching target inputs continue through the shared ordinary cache. The unsafe branch is therefore exactly an earlier candidate naming one of the two distinguished roots. A general relational zero rule and the retained-prefix contradiction show that such a candidate makes the good selected-root event impossible whenever it lies before the chosen ordinal. This removes the last semantic case distinction needed by the structural recursion. + +The complete outer structural recursion is now proved. It starts from any canonical deferred/materialized pair satisfying `FinalizationContextLE`, keeps the ordinary cache, revealed set, materialized values and fuel order aligned, and returns `RootSelectionBridgeRel`. Uniform and signing branches invoke their packaged kernels directly. A hash branch first proves the two canonical planners equal, appends the same candidate, uses the no-probe coupling or the positive-fuel coupling as appropriate, and sends a zero-fuel planned probe to the vacuous left event. An earlier distinguished-root candidate is eliminated by the chronological prefix invariant. Every clean continuation recurses with `OrdinaryMaterializedRunEq.canonicalize_left`; every stop, publication or doomed context becomes the one explicit materialized failure. What remains in the fixed-root proof is the probability projection: bound the selected materialized outcome by the symmetric two-root game, bound its failure projection by the established root-aware endpoint, and apply the comparison-root absorption lemma. + +The probability-facing boundary of that recursion is now packaged. `probEvent_goodSelection_le_failure_add_match` projects any bridge coupling to the sum of the materialized failure and selected-match probabilities. A specialization constructs the materialized shadow directly from any valid, completable canonical deferred context, with identical fuel and cache and no new sampling. Thus the remaining fixed-root probability proof no longer mentions the recursive interpreter: it starts from one delayed root context and only has to compare the two outcome projections with their already constructed probabilistic endpoints. + +The failure-retaining materialized outcome now projects to the symmetric optional selection prefix. The projection follows every uniform, hash and signing transition, discards stopped and published paths, and preserves every selected candidate. A target-naming public action is executed rather than rejected syntactically: unavailable or nonmatching inputs use the shared ordinary cache, while only actual publication of the selected root becomes failure. The hidden-state exchangeability proof now covers this target action directly, so the corrected optional prefix remains invariant under the complete root and cache swap. What remains in the fixed-root proof is to apply the symmetric two-root match bound, charge an earlier comparison-root candidate through the existing list estimate and absorption lemma, and combine the two projections. + +The comparison-root match now has its exact one-guess bound. Removing the comparison-root stop from the symmetric optional prefix cannot destroy a selected match: a safe two-root transition is also safe for the actual-root-only prefix, while an extra comparison-root stop makes the implication vacuous. A structural relational induction proves this through every uniform, hash and signing transition. The weakened reference execution no longer mentions the independently sampled comparison root, so its selected comparison-root match costs exactly `2^-128` with no candidate-count factor. The remaining fixed-root factorization must use the full cache swap to turn an actual-root match into this comparison-root match and charge the branches where the weakening stopped earlier through the recorded candidate list. + +The two-root probability argument now preserves the fixed-position production weight. Exact swap symmetry turns an actual-root match into a comparison-root match, guard weakening makes the latter independent, and the uniform guess is multiplied by the probability that the selected ordinal names the fixed target coordinate. A generic root-indexed family packages the only concrete premise needed from the deferred execution: its contexts and split caches must be covariant under `fullSwapRootCache`. Instantiating that premise invokes the existing complete hidden-state and encoding-cache exchangeability theorem. Thus the eventual position fiber has the required `fiber mass * 2^-128` shape rather than one absolute unit per position. What remains is to construct this covariant family at the selected private resolution and relate its production mass and failure outcome to the concrete retained witness run. + +The cache-family premise is now reduced to absence of earlier root guesses. `rootInstalledCache` overlays one root-indexed hidden output on a common base cache, and `fullSwapRootCache` maps the left overlay to the right overlay whenever the base's canonical encoding keys are swap-invariant. A direct key analysis proves that invariance from `NoEncodingRootGuessCached` for the two distinguished digests. The remaining concrete obligation is therefore chronological cache provenance: at the selected root's first resolution, every adversarial encoding query already in the ordinary cache must occur in the recorded candidate prefix. Prefix avoidance will then provide both no-guess hypotheses, while signer-internal encoding queries at that target cannot precede the target root value they consume. + +The concrete root-indexed family can instead start immediately after public top-root construction, which removes the need for a later cache-provenance invariant. A generic support embedding proves that every successful fixed-table clean run is a supported raw lazy run with the same state, fuel, value and split cache; the fixed chain-start outputs are supported uniform answers. Top-root construction preserves the ordinary cache exactly, so its completed cache contains no encoding guess and is fixed by every canonical root-key swap. Any layer-root candidate with a structural parent is a middle or bottom root, hence top-root construction also leaves that target absent and unrevealed. Conditioning on each supported top-root result and each fixed high half now instantiates the weighted materialized match theorem for the complete retained rest. What remains is to couple the direct root result to this materialized family, retain the clean or doomed completion split, and average over the high half. + +The materialized match estimate is now averaged over both the high half and the complete supported top-root result without losing its weight. A generic bind lemma keeps a varying production probability inside the expectation. For every fixed one-time table, the full materialized actual-root match experiment is therefore bounded by the full materialized fixed-position production experiment times `2^-128`. The next comparison must remain one-sided: materialized production can continue after a direct execution has stopped at a private canonical boundary, so it is not unconditionally equal to the concrete position fiber. That exact discrepancy belongs to the explicit materialized failure outcome already retained by the root-selection bridge. + +The explicit failure outcome is now averaged over the same top-root result, high half and two root digests as the exchangeable optional prefix. Its selected branch projects relationally to that optional prefix, so the complete fixed-table materialized match probability is bounded by the existing production-weighted `2^-128` endpoint while the failure projection remains separate. The next theorem must relate the concrete fixed-position fiber to this exact two-term outcome and send the failure term to the shared root-aware clean-finalization bound. + +The concrete deferred root selection is now coupled to that exact failure-retaining experiment. A generic raw-run invariant shows that a probe-free computation can only remove pending candidates, so every supported public top-root result still has empty pending state. Target absence then gives validity of the installed delayed root context, empty pending gives completable finalization, and the existing raw support embedding gives published-value consistency. The coupling is lifted through the sampled high half, actual root, comparison root and fixed-table top-root run while retaining the full root payload needed by the private witness predicate. The remaining fixed-root work is now the global probability projection: charge the failure projection once before any position or ordinal union, and send only successful root matches to the production-weighted endpoint. + +The global failure boundary now has a target-neutral observational interpreter. It records every proof-only probe together with the coordinate's materialized value and publication status at the instant of the probe, while otherwise executing the existing clean interpreter unchanged. Erasing the observations is proved exactly equal to `runCleanFromTable`, the clean finalizer commutes with the same erasure, and the complete sampled observed root-aware run therefore has the existing `q * 2^-128` failure bound. A generic relational probability rule splits a source event into this one comparison-side failure plus a source-side residual before any later union. The observation log now has the required support invariant through both execution and clean finalization. A probe made while a hidden coordinate is absent remains pending until materialization checks it; after a successful check its digest is permanently different, while a value already present at the probe is preserved exactly to the final state. A pure classification theorem uses candidate-list alignment, the final private witness value and the selected observation's hidden status to prove that every successful layer-root witness is delayed and that the value already present at its observation is exactly the witness output. The source run now carries the matching target-neutral chronology too: every planned candidate retains the deferred context in which it was created. This annotation is threaded through the complete normalized adaptive game, finalization and secret-table sampling, and erases exactly to the existing private witness plan at every boundary. A selected snapshot now converts exactly to the existing `PrivateOrdinalSelection`: its candidate and context are unchanged, and its candidate list is precisely the chronological prefix through that ordinal. A delayed least layer-root witness therefore satisfies `PrivateOrdinalSelection.GoodForRoots` whenever the prefix avoids the independent comparison root. Least-ordinal minimality proves avoidance of the actual root automatically, leaving only the already planned comparison-root exceptional term. The target-neutral coupling now has its final relational interface and probability projection: any coupling proving that an observed success forces a delayed source snapshot immediately gives `root risk <= one observed failure + delayed source risk`, and the source marginal is proved exactly equal to the existing private witness-plan game. What remains is only the operational proof of that relational postcondition through the adaptive runner. + +The retained private witness now records the revealed-coordinate set at the exact private stop. Two generic chronological invariants are proved directly over the witness interpreter: revealed coordinates only grow before either a completed step or a private stop, and a private value already fixed at an earlier boundary cannot change before the stop that names it. These are proof-only refinements and erase to the previous witness game exactly. They isolate the source-side obligation needed by the operational coupling: a canonical selected snapshot whose revealed set lies below the stop is hidden at the selected coordinate, while any value already deferred there is the exact final witness output. The remaining branch, where no value was deferred at candidate time, is precisely the comparison-side fresh materialization failure already charged by the global observed run. + +Every retained source snapshot is now proved to satisfy `PublishedValues` throughout the complete normalized retained-rest interpreter, including uniform, hash, signing, canonicalization and finalization boundaries. Together with the revealed-set chronology, a selected snapshot with no visible target value is genuinely unrevealed, and a source fact giving the snapshot's `positionValue` converts directly to the delayed layer-root predicate used by the root endpoint. The generic completed witness runner also preserves `PublishedValues` whenever its underlying state computation does. Specializing that generic result separately to the sealed top-root computation causes pathological definitional reduction, so the operational source-to-observed relation will carry the invariant through its top-root transition directly and then reuse the fast retained-rest theorem. The remaining proof obligation is still the same target-neutral adaptive coupling: on successful comparison execution it must provide target absence and exact `positionValue` at the selected source snapshot, while the only alternative is the single observed failure already bounded globally. + +The terminal algebra of that coupling is now complete. `SnapshotsObservedAt` pairs each retained source snapshot with the comparison observation at the same chronological probe, preserving the candidate, deferred completion value, publication status and canonical materialization. Together with the comparison run's existing tracking invariant and the source stop chronology, this turns every successful observed layer-root witness into the exact delayed source snapshot required by the production-weighted root endpoint. The invariant is intentionally target-neutral, so the clean failure remains outside every ordinal and position union. What remains is to carry `SnapshotsObservedAt` and the revealed-set chronology through the top-root transition and the adaptive outer runner, then instantiate the global split and existing root and non-root bounds. + +The observed interpreter now factors exactly across arbitrary monadic binds, and a probe-free computation is exactly the ordinary clean interpreter with the unchanged observation list attached. The top-root computation, each signer invocation and every action after the single planned candidate are probe-free, so the operational coupling can expose the one root-aware probe at an outer hash boundary and reuse existing deferred-to-materialized relations everywhere else. This rules out the monolithic dependent reduction that previously timed out and fixes the remaining induction at one explicit probe per outer query. + +The source stopped-prefix invariant is now complete through the whole sampled game. Unlike the older completed-run predicate, it records both published-value preservation on successful direct steps and hiddenness at the exact private stop, so it is not vacuous on the branch the coupling must classify. It is proved compositionally for the planned hash suffix, recursive top-root construction and every signer component, including the reveal-then-publish operation, and is threaded through canonicalization, finalization and one-time-table sampling. Consequently every retained witness names an unrevealed coordinate, every earlier snapshot's revealed set lies below the witness stop, and any private value already present in an earlier snapshot equals the witness output. What remains is the two-run operational induction: align each appended source snapshot with the comparison observation, classify a fresh source resolution as comparison failure, and then apply the completed terminal algebra and probability split. + +The terminal use of that invariant is now packaged too. Snapshot alignment alone transfers source-stop hiddenness to the selected comparison observation, without selecting a position before the global failure split. Thus a successful comparison needs only one additional fact, that its final materialized value at the witness coordinate equals the source witness output. The existing observation-tracking theorem then forces the selected snapshot to be delayed. The operational induction's successful postcondition is therefore reduced to candidate-time alignment plus one final value equality; publication chronology, hiddenness, least-ordinal selection and delayed-root construction no longer belong in the probabilistic recursion. + +The source invariant is now specialized through the public top-root computation and the sampled one-time table without unfolding either large computation during unification. A small operational relation packages exactly the remaining successful postcondition: aligned source snapshots and the retained witness value in the comparison state. Unary source chronology and unary comparison observation tracking lift that relation directly to the existing global root relation. The remaining induction therefore has one semantic exceptional case: a private source stop must pair with comparison failure unless the comparison had already materialized the same witness output. All probe-free top-root, signer and post-candidate work preserves this alternative; an outer hash query adds one paired snapshot and observation before invoking the probe-free suffix. + +The operational runner now retains that exceptional case compositionally. `DirectWitnessMaterializedStableRunEq` records the exact witness output whenever a private source stop is paired with a successful materialized comparison run, and otherwise reuses the existing doomed-finalization alternative. Its monadic bind law is proved for arbitrary continuations. Uniform sampling, ordinary hashing, sequencing and simulated computations inhabit the relation directly. The structural reveal proof covers cached, privately deferred and fresh position values, and in the privately deferred hit case explicitly proves that the comparison state contains the witness output. Chain-start reveals and the ordinary random-oracle implementation are covered as well. What remains inside the runner is reveal-then-publish and the compositional masked signer hierarchy, followed by the outer snapshot-and-observation induction and the already packaged endpoint arithmetic. + +Reveal-then-publish, the complete masked signer hierarchy and public top-root construction now inhabit the witness-preserving relation. The comparison interpreter can safely start with `2 * q` fuel while the source uses `q`: it executes every source probe plus at most one additional root-aware probe per outer hash query. Unused fuel does not change the bad-event probability. A generic theorem proves that the hit experiment is fuel-independent once both fuel values dominate the syntactic probe bound, and the observed clean failure remains bounded by `q * 2^-128` at the enlarged fuel. The operational terminal interface has also been corrected from full-list equality to prefix alignment. A private source stop ends its snapshot list, while a successful comparison may record later probes. The source list therefore aligns with an exact prefix of the comparison observations. Trimming only that proof-side log recovers the existing delayed-root terminal theorem without changing either game or event. What remains is the outer induction carrying this prefix, the query-budget fuel slack and the exact retained witness value. + +The operational coupling now has a public executor bridge for every plan action. The witness runner computes peeks and known-input resolution exactly from its current state, so the source suffix can be replaced by a plan whose data-dependent choice is frozen before the two runs diverge. The witness-preserving relation also supports computations that differ on the two sides and the one extra comparison-side probe. Thus each outer hash step will append one aligned snapshot and observation, execute the same probe-free public action, and recurse; signer and top-root steps reuse the completed hierarchy. This direct two-run induction avoids both a general coupling-gluing construction and a second simulation of the hash handler. + +The complete local hash boundary is now proved. The comparison derives the ordinary action from its canonical public state and executes `rootAwareCandidateForPlan?` before that action. If the structural planner already supplied a candidate, both sides use the same positive-fuel coupling. If only the encoding-domain fallback supplies one, the comparison consumes one unit of strict fuel slack and then rejoins the same probe-free public action. If neither supplies one, the no-probe coupling applies. The next layer is a standalone materialized observed interpreter using this public boundary, followed by its one-probe-per-outer-query failure bound and the adaptive snapshot-prefix induction. + +The standalone materialized observed interpreter and its exact local projection are now defined. It derives each plan from `materializedCanonicalContext`, executes the root-aware public suffix in the ordinary clean state, and records the candidate-time value and publication status. Mapping a detailed materialized hash step through `projectDirectDetailedObserved` is proved exactly equal to this observed clean step: a no-candidate action preserves the log, and a candidate action appends exactly one observation before the probe-free public action. The retained top-root and adaptive-rest wrapper is also packaged through final clean completion. What remains is to lift the local coupling through that recursive interpreter, prove the outer-query failure bound, and apply the terminal root algebra. + +The strong local relation now projects all the way to the observed materialized hash step. `WitnessObservedStepRel` retains the detailed comparison result behind the clean projection, so a private source stop still carries its exact witness value while an ordinary stop becomes comparison failure. The proof rewrites the materialized context to `directDeferredContext`, applies the exact observation projection, and preserves both probabilistic marginals. The adaptive induction can now work only with source witness results and observed clean results; it no longer needs to expose the detailed runner at each query. + +The target-neutral adaptive lift is now complete for the retained rest computation. It carries only snapshot-prefix alignment, the exact value of a private source stop and one explicit doomed comparison alternative. Uniform and signing transitions are probe-free. At a hash transition the source and comparison plans are equal in their canonical public views, the local root-aware coupling appends the same snapshot and observation, and each side spends at most one probe. The three fuel inequalities `remaining outer hashes <= source fuel`, `source fuel <= q` and `q + remaining outer hashes <= comparison fuel` are preserved through every recursive continuation. A doomed materialized state is proved unable to recover, so that alternative can be discharged once by clean finalization instead of being copied across positions or ordinals. What remains is to lift this rest theorem through the probe-free public top-root computation and table sampling, convert the doomed alternative to the single observed clean failure, prove the standalone materialized interpreter's one-probe-per-outer-query failure bound, and apply the existing delayed-root, non-root and arithmetic endpoints. + +Snapshot alignment and the fuel facts used by the recursive lift are packaged independently. Appending an optional root-aware candidate preserves `SnapshotsObservedAt` by constructing its observation directly from `FinalizationContextLE`, revealed-set equality, publication and canonical materialization. Generic support lemmas recover `fuel <= remaining + bound` for both detailed and witness runners from the raw interpreter, without inspecting a concrete handler. These facts feed the three outer fuel inequalities and keep the completed induction independent of candidate-specific fuel behavior. + +The fixed-table operational coupling now passes through the probe-free public top-root computation, the complete retained rest, and guarded clean finalization. Successful finalization preserves the source witness, the chronological observation prefix, and every stored witness value; a doomed or non-completable comparison becomes the single `none` failure outcome. The large top-root proof is split into small fuel, continuation, result-step, wrapper, and finalization modules, each of which builds independently without unfolding the sealed root computation. This integration exposed one boundary distinction that must remain explicit: the existing source snapshot experiment enters the retained rest with raw materialized root intermediates, while the sound public planner must first canonicalize those unpublished intermediates back into the deferred context. The completed coupling therefore targets a separately named canonical root-boundary source rather than silently changing the established source marginal. What remains is to relate the established marginal event to this canonical source, lift the fixed-table relation through one-time-table sampling, prove that the standalone materialized comparison has at most one failure opportunity per outer hash query, and assemble the existing delayed-root, non-root, terminal, and arithmetic bounds. + +The fixed-table relation is now lifted through the opaque one-time-table sampler to the exact sampled root postcondition. Source stop chronology is re-established for the canonical root-boundary experiment, and the materialized comparison's observations are tracked through the public root and complete retained run. A root-or-doomed intermediate relation classifies successful runs before finalization and sends every doomed or non-completable run to the one global `none` outcome, avoiding any redundant final-state tracking obligation. The modules remain small enough for ordinary code generation and the full build again reports only the public theorem's `sorry`. What remains is the canonical-to-established source-event domination, the one-probe-per-outer-query bound for the materialized comparison failure, and the final delayed-root, non-root, and arithmetic assembly. + +The sampled root relation yields the global split into materialized comparison failure and delayed source risk, but its current guarded finalizer deliberately merges two semantically different cases. The on-demand completion-table induction now proves the `q * 2^-128` bound for the unguarded comparison from the empty state, including sampling normalization, outer-query fuel accounting and the adaptive canonical public planner. This is exactly the fresh case in which the selected value was absent when probed and a later materialization hits. It cannot soundly be equated with guarded failure: a later query can probe a hidden value materialized by an earlier query, making non-completability deterministic once the intermediate state is fixed. The snapshot chronology was built to classify that second case as delayed source risk because it records the value already present at the probe. What remains is to strengthen the sampled root split so this classification happens before guarded finalization, relate the canonical source event to the established source marginal, assemble the delayed root and non-root finite families, and close the terminal arithmetic. + +The guarded boundary has now been replaced by a sound diagnostic split. Ordinary unguarded finalization is projected exactly to the standalone materialized comparison, and with the `2q` comparison fuel required by the coupling its failure probability is at most `2q * 2^-128`. A separate Boolean retains successful runs whose state was already non-completable before finalization, so an earlier materialized hidden-value hit is no longer mischarged as fresh randomness. The canonical layer-root event is bounded by the sum of this fresh term, the successful-doomed diagnostic event, and the delayed selected-root event. The next proof step is exact and local: classify the successful-doomed event by its first already-materialized hidden hit, sending a layer-root hit to the existing root selection family and a non-root hit to the existing non-root ordinal bound. After that classification, the remaining source-side task is the one-sided domination from the established root boundary to the canonical boundary, not a false equality of their complete distributions. + +The successful-doomed classification is now deterministic and sampled end to end. Every pending candidate is covered by the chronological observation that created it, every such observation retains whether its coordinate was hidden at probe time, the pending set never exceeds the initial probe fuel, and the fixed chain-start table remains unchanged. If an unguarded finalization succeeds from a state already known to be non-completable, absence of an earlier hidden-value hit would make the direct deferred context valid; the existing non-completability classification would then force a missing chain-start hit, which successful finalization rules out. Thus every supported successful-doomed diagnostic contains an actual earlier hidden-value hit, and the sampled successful-doomed probability is bounded by that explicit event. The next obligation is to classify the first such observation by its structural position and reuse the existing layer-root selection and non-root ordinal endpoints. The remaining source-side and arithmetic obligations are unchanged. + +The first hidden hit now has a canonical chronological ordinal. The observed interpreter preserves the exact identity between observation count and spent probe fuel through the recursive runner, the retained boundary and opaque table sampling, so every supported first hit lies in `Fin fuel`. Its position is split deterministically into a layer root or a non-root, and the complete hidden-hit probability is bounded by the finite sum of those two first-hit events over the available ordinals. This is the required global accounting shape: the comparison finalization failure remains one term outside every ordinal union, while each already-materialized hit is charged exactly once. What remains at this boundary is to dominate each fixed-ordinal event by the established non-root unit bound or the production-weighted root selection bound. + +The ordinal reduction now retains the successful-doomed gate instead of replacing it by the larger event of all first hidden hits. This distinction is necessary: after an unrelated doomed transition the existing full-run coupling deliberately stops asserting source alignment, so a later raw hit cannot be sent to the deferred source endpoint. For each fixed table and ordinal, diagnostic finalization is now removed while preserving a successful finalization support witness, non-completability of the pre-finalization state and the exact first root or non-root hit. The sampled projection accepts a table-uniform fixed-bound theorem without elaborating the function-type sampler's support. What remains is a stopped coupling for this gated fixed-table event. Successful finalization rules out an earlier missing chain-start obstruction, so the first non-completability point must contain the hidden hit whose aligned deferred snapshot feeds the existing ordinal endpoint. + +The unrecoverable half of the stopped coupling is now formalized. A missing chain-start hit persists through every supported observed clean computation, including the complete materialized outer interpreter: ensuring, publishing and adding pending candidates preserve it, materializing another coordinate leaves it in place, and attempting to reveal the obstructed chain start aborts. Therefore any materialized continuation that reaches successful finalization could not have entered its current state through this missing-chain branch. What remains in the stopped coupling is the complementary matched-private-stop branch, where the newly appended source snapshot and comparison observation identify the first existing hidden hit and retain its ordinal through the otherwise irrelevant suffix. + +Strengthening the stopped invariant exposed a second syntactic chain-start case that had to be checked against the reachable masked game. It is not reachable. The masked signer can reserve an opaque chain start, but a zero digit reveals and publishes that start before returning, while a positive digit reveals a later chain position and never materializes the start. Root construction and signing are probe-free. A direct hash handler records its only observation before its probe-free public action can materialize anything. The compiled `ChainState.ValidFor (fun _ => True)` invariant therefore proves that every retained materialized chain coordinate was already revealed at observation time, through the complete retained run. The stopped postcondition may retain the chain-start alternative as a conservative local trichotomy, but its concrete sampled execution has no supported outcome in that branch. No WOTS inversion reduction or sampled-table unit is needed. + +The candidate-time stopped trichotomy is now checked. From a completable canonical source context and its materialized comparison, if adding one hidden candidate makes the comparison non-completable, then either the corresponding source context has a private structural position hit, the comparison has a missing chain-start hit, or the appended observation is the first existing hidden chain-start hit. The proof uses the old completion to show that a stored comparison value must match the new candidate, and uses the finite pending-set bound only when the coordinate is still unmaterialized. Source snapshot traces are now proved monotone through the complete retained continuation. The selected-position branch is packaged independently of the source run's eventual witness field, with its exact ordinal, candidate, hidden canonical context and private output, so it also covers a root-aware encoding fallback that the source deliberately records but does not execute. Both the first-hit fact and this source marker persist through arbitrary later signer and adversary work. The stopped relation now has its exact terminal elimination: successful finalization excludes a missing chain start, a first chain-start hit cannot be a layer root, and a successful first root hit therefore forces the selected source snapshot at the same unique ordinal; a non-root hit leaves exactly the selected-position or chain-start alternatives. The root-aware hash boundary is now compiled too. A hidden candidate probe is rewritten exactly to the appended observation and `addPending` state before the probe-free public action; if that state is non-completable, the trichotomy is applied immediately and every arbitrary later public, signing and adversarial suffix preserves the selected marker or stopped cause. The adaptive finisher now composes ordinary aligned steps and persistent missing-chain outcomes through arbitrary recursive continuations. The complementary hidden-candidate branch is compiled as well: when the post-candidate state remains completable, the probe-free public action cannot create a private stop, and tracked, covered, hit-free observations turn every other doomed completion into the persistent missing-chain case. The revealed and absent-candidate branches reduce exactly to the shared probe-free public action. The resulting exhaustive stopped relation is now lifted through the complete adaptive computation: uniform and signing queries preserve the hit-free alignment, hash queries split all four candidate cases, and a newly non-completable hidden candidate terminates immediately in the persistent stopped classification. The fixed-table theorem now also passes through the probe-free public top-root computation and the opaque one-time-table sampler. The comparison starts with empty pending state and `2q` fuel; `q ≤ 2^120` gives the strict digest-space bound needed by every stopped classification. The concrete retained-run invariant now eliminates the chain-start branch. What remains is to project successful root and non-root ordinals jointly to the existing endpoints and assemble the terminal arithmetic. + +The reachable chain-state invariant is now projected through the opaque one-time-table sampler as an exact probability-zero theorem. Consequently every sampled successful first hidden hit is bounded by the selected structural snapshot alone, with no chain-start term. The stopped relation now also preserves the strict earlier-candidate avoidance needed by the root-selection endpoint. This fact is derived from snapshot chronology, final-state observation tracking and revealed-set monotonicity, rather than assumed. The remaining proof is not blocked on WOTS extraction or a cryptographic redesign. It must project the strengthened selected snapshot to the branch-dependent layer-root or non-root endpoint without duplicating the global comparison failure, sum the chronological ordinals, and close the existing boundary and terminal arithmetic at the conservative constant `c = 8`. + +The selected stopped snapshot now projects deterministically to the exact `PrivateOrdinalSelection` consumed by the probability interpreters. It retains the candidate-time context, the selected ordinal prefix and avoidance of the actual hidden root, and it splits exhaustively by whether the selected structural position is a layer root. The accounting audit also identifies the next semantic constraint precisely: the successful materialized comparison witness must remain coupled through this split. Bounding the broader source marginal alone would copy a target-dependent comparison failure across root fibers. The next checkpoint is therefore a joint fixed-ordinal theorem, not a union bound on the source event. + +The finite ordinal accounting after that checkpoint is now complete. Every supported canonical source has at most `q` snapshots because the public root is probe-free and the retained outer computation has at most `q` hash queries. Thus selected-source events vanish at every ordinal at least `q`, even though the materialized comparison carries `2q` fuel. The successful-doomed comparison probability is at most `q * 2^-128` from any uniform fixed-ordinal selected-snapshot bound, and combining it with the already-proved `2q * 2^-128` finalizer gives the exact three-unit diagnostic bound. The only missing hypothesis of that packaged theorem is the joint root/non-root fixed-ordinal estimate. + +The chronological snapshot source is now coupled exactly to the existing `PrivateOrdinalSelection` interpreter. Before the chosen ordinal both execute the same random choices; when the ordinal is appended the selector stops, while snapshot-prefix monotonicity proves that every later source result projects to that same candidate, candidate-time context and chronological prefix. This coupling is specialized through the complete retained-rest computation. It is a semantic projection only: the fixed-ordinal probability proof must still keep the successful materialized comparison gate through the root/non-root split, rather than bounding the broader source marginal and duplicating comparison failure across fibers. + +The non-root half of the fixed-ordinal split is now complete at one unit. Binding the exact selector to the existing non-root observer is definitionally the recursive non-root risk interpreter. Public top-root construction preserves every non-root structural coordinate, so its completed deferred context satisfies freshness except at layer roots; the existing adaptive hash and signer invariants preserve precisely that condition. Consequently every sampled fixed ordinal selected at a non-root position costs at most `2^-128`, without using or copying the materialized comparison failure. The only missing fixed-ordinal term is now the layer-root branch under the same successful comparison gate. + +The stopped relation now retains the exact equality between the selected source snapshot candidate and the comparison observation at the same chronological ordinal. This closes the correlation gap found by the accounting audit: root versus non-root can be classified once on the successful comparison observation and transported to the source selector without enlarging to the ungated source marginal. The next checkpoint is to use this equality to discharge the non-root branch with the existing one-unit theorem and to feed the root branch, still under successful finalization, into the production-weighted materialized root endpoint. + +The successful non-root diagnostic branch is now closed at one unit. Candidate equality transports the comparison-side non-root classification to `SelectedPrivateSnapshotNonRootHitAt`; the stopped trichotomy's only alternative is the already-proved unreachable chain-start event, and the exact non-root selector theorem then gives `2^-128` at every fixed ordinal. The alignment marker now also retains equality of the complete candidate and observation prefixes before that ordinal. This is the information needed to show that the root selection outcome cannot take its conservative earlier-failure branch under the diagnostic's first-hit and successful-finalization gates, so the remaining root branch can use only the production-weighted match term. + +The successful first-hit gate now has an intrinsic source-prefix form. Exact snapshot-to-observation alignment proves that every source snapshot before the selected ordinal avoids an already-materialized hidden structural hit. Auditing the root-selection interpreter confirms that this excludes structural discrepancies against the actual root, while successful finalization excludes a persistent missing chain start and selected hiddenness excludes target publication. It does not exclude an earlier candidate matching the independently sampled comparison root used by the swap argument. That exceptional event must remain explicit rather than being folded into the diagnostic failure. + +The clean layer-root source event is now explicit and checked. A successful first-root diagnostic projects to the exact selected private ordinal, its layer-root position and value, and the clean earlier snapshot prefix. The selected position is also packaged as an optional fiber, with the `none` fiber proved impossible and the generic production-weighted finite-family reduction applied without enumerating `Position`. The comparison-root exception is now isolated too. For a fixed position fiber it is bounded by that fiber's own production mass times `ordinal * 2^-128`, so no position or ordinal weight is discarded. Since every relevant ordinal is below `q <= 2^120`, this self-weighted term is absorbed by a factor below two. The conservative terminal constant is therefore `c = 9`, still exactly within the proved public budget `2 * c + 1 <= 19`. The nonexceptional snapshot event now projects to the exact private ordinal selector while carrying the same independent comparison root. The fixed-position normalization observer is complete across the full adaptive retained computation. It tests the selected target candidate only under the retained comparison-root avoidance prefix, treats every inconsistent completion as an explicit failure, and commutes an arbitrary deferred position resolution across uniform, planned hash and signing branches. The observer is now proved exactly equal in distribution to an eager experiment that samples the fixed target payload before public-root construction; that payload is further split into an independent 128-bit digest and high half using the established `HashOutput` equivalence. + +An accounting audit rejected the Boolean eager-risk marginal as a terminal endpoint. Its observer maps any unrelated non-completable execution to `true`, so using that marginal once per selected-position fiber would copy the same failure mass across fibers. The eager schedule normalization itself is sound and remains useful, but the next relation must retain the successful stopped diagnostic together with the clean snapshot prefix until the materialized root outcome is classified. The corrected fixed-ordinal route is: split the independently sampled comparison-root exception with its existing production weight; couple the remaining clean snapshot prefix to the materialized root-selection outcome; use the clean earlier structural observations, the reachable chain-state invariant and successful finalization to rule out that outcome's conservative failure arm; then apply the existing production-weighted root-match theorem. After this joint root estimate, the non-root unit bound, ordinal sum, three-unit diagnostic bound and `c = 9` public arithmetic are already packaged. + +The terminal interface for that joint relation is now compiled. It turns the missing coupling directly into the existing production-weighted materialized match bound, with no failure disjunct in the postcondition. Its first local schedule lemma is also proved: when `GoodForRoots` holds, `PendingCoveredBy` for the strict ordinal prefix implies that early resolution of the selected target cannot collide with pending work. The resolved selection still satisfies the same good-root predicate after the target pending fiber is cleared. The remaining implementation inside this checkpoint is the adaptive lift of this one-sided resolution fact through the probe-free uniform and signer steps and the single planned hash candidate, while retaining prefix coverage. + +The root checkpoint has been tightened once more after auditing its source marginal. The successful observed retained run is now split directly by its fixed layer-root position, and the impossible `none` fiber is eliminated before any probability estimate. An independent comparison root divides each position fiber into the clean comparison case and an earlier-prefix exception. The exception keeps the fiber's own production weight and costs at most `ordinal * 2^-128`; it is not replaced by an unconditional union bound. The remaining coupling now starts from this successful observed event, rather than the broader source snapshot marginal, so a later unrelated failure cannot be copied across position fibers. Its target is the existing materialized root match outcome, after which the production-weighted endpoint applies unchanged. + +The deterministic side of that joint coupling is now complete. The stopped relation transports a successful observed fixed-target root hit to the exact deferred snapshot selector, proves that the source and observed selected probes name the same target, and identifies their strict candidate prefixes. Comparison-root avoidance therefore crosses the relation exactly. The probability endpoint now accepts one explicit `RelTriple` from this successful observed pair to the materialized root match and immediately applies the existing production-weighted theorem. The remaining semantic obligation is only that `RelTriple`: normalize the selected target's deferred sample while retaining successful observed finalization, so an earlier materialized failure contradicts the already aligned clean prefix instead of becoming a reusable failure disjunct. + +The ordinal selector now carries the missing chronological invariant. Starting from a context whose pending probes are covered by the current candidate list and whose list length has not passed the chosen ordinal, every supported selected result has all pending probes in its candidate-time context covered by the strict earlier prefix. The proof is preserved through canonicalization, uniform draws, probe-free signing and the one candidate-producing hash step, and it is specialized through the probe-free public-root computation. This supplies the exact premise for collision-free early resolution of the selected root. The remaining joint construction must retain the selector's support fact inside the coupling rather than extract a point through the function-table sampler, whose generic support elimination causes pathological elaboration. + +The proof tree now has a local generic marginal-gluing theorem for `RelTriple`. It constructs the common-fiber coupling explicitly and proves both marginals, so two relational executions sharing an intermediate distribution can be composed while retaining an existential witness from that distribution. This is needed to join the successful observed run and the supported ordinal selector through their common chronological snapshot. It introduces no XMSS dependency and no change to the security statement. + +The successful observed run and ordinal selector are now joined through that common snapshot. Pending coverage is established once on the unpaired selector and carried abstractly through the joint relation, so the large coupling never eliminates support from the opaque function-table sampler. A good successful root observation therefore yields one exact selected root together with coverage of every pending probe by its strict chronological prefix. The remaining root obligation is semantic rather than elaborational: couple this selected run to the materialized root outcome while proving that its failure arm contradicts the retained successful observed execution. + +The selected target is now resolved inside that joint coupling. Strict-prefix pending coverage proves that the resolution returns the exact hidden output required by the selected root, clears only the target pending fiber, and preserves `GoodForRoots`. The successful observed gate and independent comparison root remain correlated with the resolved selector. The remaining root obligation is now only to synchronize the earlier materialized prefix with the successful observed execution, which excludes the outcome's conservative failure arm before the existing match bound is applied. + +The synchronization audit found and repaired an exact-marginal mismatch. The observed interpreter executes a proof-only encoding fallback probe after recording its candidate, while the old optional root selector skipped that probe. A shared-prefix coupling now has the observed run as its exact first marginal and a failure-retaining root-aware outcome as its exact second marginal. That outcome projects relationally to a clean root-aware optional selector. Both halves of the hidden-root swap, the full cache swap, the root-indexed family exchangeability theorem and the production-weighted one-guess arithmetic now compile for this corrected selector. What remains is to transport the resulting weighted match bound back through the shared prefix, exclude the failure outcome using the retained successful observed gate, and attach the already packaged ordinal and terminal arithmetic. + +The root-aware family bound is now specialized to the actual installed hidden-root cache used after public top-root construction. The specialization is kept in its own module because combining support extraction from the sealed top-root computation with the large generic family in one declaration causes pathological normalization. The remaining boundary work will lift this small compiled interface through the top-root result and root-output-part samplers without unfolding the selector. + +The installed-cache family bound is now lifted through both remaining public samplers. The first wrapper averages over the high half of the selected layer-root output for each supported top-root result, and the second averages that result through the sealed public top-root computation while retaining the selected-position production factor in the same experiment. The sole remaining root bridge is therefore qualitative rather than probabilistic: the exact shared-prefix coupling must show that a successful observed first-root hit cannot project to the failure arm of the root-aware outcome. Once that implication is checked, the compiled weighted one-guess theorem applies without another marginal relaxation. + +The failure-retaining root-aware outcome is now lifted through the same public-root experiment and bounded by the production-weighted one-guess theorem. The exact joint experiment with the observed run is also packaged, and its terminal deterministic lemma identifies a selected successful first-root observation with the installed hidden root. The qualitative bridge is complete: an induction over the exact shared prefix proves that selection freezes the matching outcome and every earlier failure branch contradicts successful finalization, first-hit chronology, target hiddenness or comparison-root avoidance. The theorem is specialized to the installed hidden-root state produced by a supported public-root result, including its empty pending set, untouched one-time start table and strict remaining digest-space budget. Both shared-prefix marginals are now exposed exactly at each fixed public-root result, the resulting relational theorem is lifted through the sealed public-root computation, and the eagerly resolved successful-root event reaches the compiled production-weighted one-guess endpoint with no additional loss. The remaining root normalization is being built bottom up. An audit confirmed that exact commutation of one fixed position with chain starts, chain prefixes, complete one-time leaves, tree nodes and every structural reveal is already packaged in `OtsProbeResolvedPrivateRecursive`, so no duplicate machinery is needed. The eager endpoint is now also expressed through `resolveDeferredPositionValue` on the target after a fixed public-root result. Under the established absent-target and empty-pending invariants, its distribution is exactly the existing high-half and root-part experiment, including the comparison-root draw and installed hidden cache. This equality is lifted through the sealed public-root computation using its existing target-absence and empty-pending support theorems. The next lift moves the resolver across the retained adaptive boundary while preserving the successful observed gate. After that, the fixed-ordinal root and non-root estimates, ordinal sum, diagnostic bound and terminal arithmetic remain the final assembly. + +The adaptive normalization now has its required typed local coupling. Unlike the older Boolean observer, the retained commutation keeps the lazy resolver result, the state after delayed target resolution and the explicit resolution-failure arm in one joint experiment. Its left marginal is exactly the original resolver even when delayed resolution fails, while structural commutation gives the eager right marginal exactly. The next induction threads this relation through the retained outer boundary until the selected target is materialized; strict-prefix coverage excludes its only failure arm, after which both executions share the already-proved successful root suffix. + +The retained coupling is now specialized to complete structural positions and reveals. The observation side of the outer invariant is packaged too: early installation changes only the stored value recorded at probes of the target position, preserving probe identity and publication status. A clean strict prefix remains clean after installation whenever its candidates avoid the installed root digest. These two local interfaces are the inputs to the outer-query induction; no Boolean failure observer is used in this path. + +The post-materialization suffix is now isolated completely. `SafeTargetPendingLE` records equal stored values, publication state and ensured coordinates, while allowing the eager run to retain only earlier candidates at the selected root whose digests differ from the installed value. The relation is preserved by every lazy-oracle transition. `relTriple_runObservedCleanFromTable_safeTargetPending` couples arbitrary suffix computations with identical returned values, tables and fuel, and transports the observation log exactly through `installPositionValueAtProbe`. The outer induction therefore only has to reach the first materialization of the selected target; every later signer, hash action and adversarial continuation is discharged by this generic theorem. + +That suffix theorem is now lifted through `observedMaterializedBoundary` itself. Equal stored values force identical canonical public plans and root-aware public actions, while uniform and signing branches use the generic lazy-oracle coupling directly. Thus the synchronized relation composes through an arbitrary remaining adversarial computation with equal returned values and split caches. The only unfinished part of the lazy/eager bridge is the prefix ending at the selected target's first materialization. + +The exact synchronization transition is now compiled too. `GoodForRoots` and strict-prefix pending coverage imply that delayed target resolution removes precisely the target pending fiber, eager installation retains only target candidates whose digests differ from the installed output, and the two materialized shadows therefore satisfy `SafeTargetPendingLE`. This statement consumes an actual supported resolver result and is composed directly with the complete `observedMaterializedBoundary` suffix, so the adaptive prefix can hand off at the first target materialization without exposing the sampler's normal form. The remaining prefix proof only has to transport the already-established coverage and avoidance facts to that handoff. + +The synchronized relation now reaches finalization without losing the successful gate. Once the selected target occurs among the delayed state's coordinates, both sides finalize the same coordinate list; every non-target completion preserves `SafeTargetPendingLE`, and installation transports the chronological first-hit witness without changing probe identities. The next checkpoint packages these facts into preservation of `SuccessfulDoomedFirstRootGoodForComparisonAt`, then threads that preserved event through the adaptive prefix to the resolved eager experiment. + +The successful root event is now preserved by the synchronized suffix and finalizer. The proof also covers the case where clearing the selected target removes it from the delayed coordinate set: the eager side can then have only that extra coordinate, its stored output makes its finalization deterministic, and clearing it makes the states equal. Successful finalization, doomedness, first-hit chronology, the fixed layer-root fiber and comparison-root avoidance all cross the relation without a failure disjunct. The remaining semantic work is the adaptive prefix that reaches this relation at the selected target's first materialization while retaining the selected-output and strict-prefix avoidance facts already supplied by the joined selector. + +The joint selector relation now retains the raw snapshot-to-observation alignment through collision-free target resolution. Under the successful fixed-root event it reconstructs the selected `GoodForRoots` witness, strict-prefix pending coverage, the hidden selected observation, equality of its candidate with the installed root digest, actual-root avoidance throughout the earlier observation prefix and the layer-root classification. The first-hit transport was correspondingly simplified to require digest equality rather than equality of the full stored output. These are exactly the terminal premises of the synchronized suffix; the remaining adaptive prefix no longer needs to recover information discarded by the earlier source-only projection. + +The complete post-prefix contract is now compiled. Any exact-marginal coupling that transports the real successful fixed-root event to the early-resolved observed experiment immediately reaches the existing production-weighted one-guess bound, after the already-proved equality between the resolver experiment and the split root-output experiment. This isolates the unfinished proof to one semantic theorem: share the actual continuation while commuting the selected target resolution backward through the adaptive prefix. Pairwise composition through the stopped selector is explicitly insufficient because that selector intentionally forgets the continuation's random tape. + +The contract has been sharpened to the smallest sufficient marginal: the adaptive bridge only needs to couple the Boolean indicators of the real and eager successful fixed-root events, not their complete final records. The post-materialization suffix now exports this indicator coupling directly. It preserves `false` on unrelated failures instead of accepting them as the older failure observer did, so position fibers cannot duplicate failure mass. The unfinished prefix may therefore discard all branches on which the real indicator is false and must retain exact correlation only until the selected target is first materialized. + +The Boolean contract now feeds the production-weighted root endpoint directly. Once the adaptive prefix supplies that one indicator coupling, the eager resolver equality and root-aware one-guess theorem are applied internally, so no later proof can accidentally replace the produced-list weight by an unconditional position bound. + +The probe-free public-root prefix is now factored out of the Boolean bridge. Its observed execution is proved equal in distribution to the ordinary clean result with an empty observation list, and the global lazy/eager indicator coupling is reduced to one supported public-root result at a time. The failure result is discharged as the constant false indicator, while a successful root result retains the actual observed continuation and the independent comparison-root draw. The remaining theorem is therefore the local adaptive prefix coupling after a fixed supported root result; it no longer contains the sealed public-root computation or its sampler. + +The fixed-root Boolean contract now feeds the production-weighted endpoint in one theorem. Once the local adaptive prefix supplies its success-preserving indicator coupling for every supported public-root result, the public-root lift, eager resolver equality and root-aware one-guess bound are applied without exposing another probability interface. The remaining semantic seam is exactly that local coupling; no later layer can discard or duplicate the selected-position production mass. + +The selected-query handoff is now sealed as a single compiled interface. `GoodForRoots` and strict-prefix pending coverage make resolution of the selected root definitionally equal to the unique hidden output, and the result is passed directly to the synchronized suffix indicator coupling. The adaptive prefix therefore no longer handles sampler support, resolution failure or post-selection execution. It only has to preserve the joint deferred, observed and early-installed states until the chosen candidate boundary. + +The ordinal-to-diagnostic arithmetic is now parameterized by the cost of one fixed ordinal. A bound of `c * 2^-128` per ordinal gives `(c + 2) * q * 2^-128` for the complete materialized diagnostic, the extra two units being exactly the already-accounted finalization failure. The original one-unit theorem remains as a wrapper. This removes any dependence of the terminal assembly on an unrealistically lossless root/non-root split. + +The local adaptive root contract is now conditioned on both values that are genuinely independent of the hard continuation: one supported public-root result and one fixed comparison root. A compiled commutation theorem moves the comparison-root sampler across the eager target resolver and reconstructs the original resolver experiment exactly, then feeds the result to the existing production-weighted endpoint. The remaining induction therefore handles only the correlated deferred target draw, the actual observed prefix and the installed-root prefix up to the selected candidate. It must also retain the selected-position production marginal, because the installed production experiment is target-indexed and those probabilities cannot be summed as if they came from one common run. + +The adaptive prefix now has a concrete weight-preserving computation rather than only a theorem-shaped premise. It carries the chronological deferred snapshots and observations together, stops before executing the hash query that appends the chosen ordinal, resolves only the selected root, and hands that complete query and suffix to the compiled selected-root bridge. Its selected-prefix equation is checked. The selected handoff now also preserves the exact outer fixed-root indicator: successful finalization of the retained continuation is transported when the fixed public root is reattached, then composed with the installed-root suffix coupling. The next proof composes this computation with the existing first-stopped coupling, so a successful real observation reaches the selected handoff without resampling or forgetting its suffix. + +The selected-root suffix now retains support membership for both the target resolver and the observed continuation. This is essential chronological data rather than a stronger probability assumption: it lets the adaptive prefix derive observation-prefix and stored-value monotonicity only for executions that can actually occur. The supported contract is lifted through the selected resolver and fixed-root wrapper without changing the successful event. The next induction can therefore prove the selected-hit and earlier-actual-root-avoidance obligations from the carried prefix state instead of requiring them for impossible logical records. + +The selected hash boundary now extracts those chronological obligations from support. Its appended observation is identified exactly at the chosen ordinal, and every earlier observation is transported back to the root-avoiding carried prefix. The generic recursive finisher is compiled as well: an ordinary aligned step recurses with the same continuation, a failed materialized step makes the real indicator false, and a persistent missing chain start contradicts the retained successful finalization witness. The remaining adaptive induction can use this finisher uniformly for probe-free uniform and signing steps and for every nonselected hash step, leaving only the selected hash branch to connect to the compiled handoff. + +The probe-free cases of that induction are now sealed behind typed wrappers. Uniform sampling and masked signing both preserve the materialized run relation, consume no probe budget and pass the exact supported continuation to the recursive Boolean coupling. The dependent signing-query range is handled without changing the game. The remaining local work is confined to hash queries: recurse after a nonselected candidate, or derive the selected root handoff premises at the first chosen candidate. + +The terminal pure branch of the adaptive Boolean lift is now closed as well. A successful first hidden hit cannot arise from a computation that returns immediately when every carried observation is hit-free, so the real indicator couples to constant false without inspecting the deferred sampler. The selected hash boundary remains the only unsealed constructor of the local induction. + +The chronological cutoff is now explicit in the Boolean lift. If the chosen ordinal is already in the carried hit-free observation prefix, the real successful indicator is impossible for every remaining computation. The direct delayed interpreter also has checked equations for both hash cases: the first selected candidate hands the untouched hash query and suffix to the target resolver, while a nonselected candidate executes the retained step and recurses. These equations leave no hidden reduction of the current query at the selection boundary. + +The deterministic selected-hash obligation is now compiled. A supported successful first-root observation identifies the selected candidate, its hidden target value and both earlier-root avoidance facts, producing `GoodForRoots` for the exact chronological selection. Strict-prefix pending coverage is deliberately carried from the deferred run: final materialization does not determine unresolved chain-start values, so attempting to reconstruct this invariant at the boundary would be unsound. The remaining work is the probabilistic hash-step coupling that preserves this invariant through nonselected queries and invokes the selected handoff at the chosen ordinal. + +The adaptive finisher now carries the actual and deferred observation logs separately. A nonselected chain-start probe can see a stored table value in the materialized execution while the deferred shadow still records no stored value, even though both logs contain the same probe and remain hit-free. Keeping both exact logs avoids an invalid record equality; the selected handoff needs only their common probe sequence, while all tracking and successful-event obligations stay on the actual log. + +The adaptive induction is now compiled through every probe-free step and every nonselected hash step, including the fresh hidden candidate whose added probe makes the materialized state non-completable. It preserves the two exact observation logs, their common probe sequence, separate hit-free prefixes, strict-prefix pending coverage, query budgets and supported recursive continuation without equating chain-start observations. At the selected hash boundary, appending one candidate is proved to force the selected ordinal to equal the old prefix length. The real event is impossible unless the fixed selected snapshot has a private output satisfying `GoodForRoots` and prefix coverage, so the remaining case has one fixed output and no support-dependent choice. What remains in this induction is the operational coupling for that fixed-output case: commute the deterministic target resolution through the selected query, retain the common oracle answer, and normalize the two sufficient probe fuels. After it compiles, the fixed-root bridge can be lifted through the public-root result and table samplers, then combined with the existing non-root, ordinal-sum, diagnostic and terminal arithmetic endpoints. + +The fixed-output operational relation is now compiled through both the lazy-oracle interpreter and the full materialized outer boundary. Its invariant is the exact one needed by the selected seam: values and revealed coordinates agree, while a deferred-side pending candidate absent from the real side must be harmless because its structural value is already fixed or because it misses the deterministic chain-start table value. This rules out the suspected dead end without asserting false pending-set equality and without charging an already materialized hit as fresh randomness. Chain validity supplies equality for published chain starts, so the installed selected-root shadow is related to the actual state. The remaining local obligations are to transport successful finalization and the selected first-hit predicate through this directional relation, and to normalize the two sufficient probe fuels before composing with the already compiled delayed-root handoff. + +The selected fixed-output branch is now closed. A generic administrative coupling proves that hidden split-cache entries cannot affect a materialized run when the ordinary cache projections agree, while preserving the common suffix of two separately retained observation prefixes. A second generic coupling proves that any two probe fuels sufficient for the same computation produce equal states, values, tables, caches and observation logs, with only the unused remaining counter allowed to differ. Both relations transport the exact successful first-root event, including finalization, chronology and comparison-root avoidance. Composing them with the completion-safe operational relation closes the selected hash constructor without a new randomness argument. The complete adaptive selected-root induction is now sorry-free. What remains is to attach its fixed-root wrappers, combine the compiled non-root endpoint, sum the reachable ordinals, and discharge the existing diagnostic and terminal arithmetic chain to the public theorem. + +The adaptive relation is now initialized at every supported result of the probe-free public-root computation. Empty pending state supplies validity and completion, the root computation preserves published values and chain validity, and its exact unchanged probe fuel supplies the two-to-one slack required by the adaptive induction. The remaining fixed-root seam is isolated to normalizing the delayed private target draw against the eager target-resolution experiment; all public-root state, cache, table and fuel obligations are discharged. + +The eager normalization now has an explicit checked computation. It resolves the selected target only while the chronological prefix has not yet reached the chosen ordinal; after selection it leaves the stored snapshot context untouched, avoiding an erroneous second independent draw. Its already-selected case and its unselected terminal-pure case have equal Boolean distributions to the delayed computation, and resolving an already resolved target is proved observationally inert. Retaining and removing the public root are also now equivalent for the exact successful fixed-root predicate. The remaining induction cases commute the eager draw through uniform, signing and nonselected planned-hash steps, then the existing selected suffix closes the fixed-root bridge. + +The normalization now commutes the eager target draw exactly through a uniform query and through the hash query that first appends the selected ordinal. At that boundary, target resolution preserves the public value map and therefore the planned candidate; the delayed schedule draws from the stored pre-query context while the eager schedule observes its already resolved copy, so both enter the identical materialized suffix after exactly one draw. The remaining recursive cases are nonselected planned-hash execution and signing, followed by the structural induction that combines these equations. + +The false-on-failure witness interpreter is now connected exactly to the existing recursive resolution machinery by Boolean duality: stopping is false precisely when the ordinary resolved interpreter's failure result is true, and a successful continuation is complemented twice. The canonicalized form is proved automatically doomed on an incompletable context and synchronized whenever its underlying continuation is synchronized. This makes the retained target-first commute reusable without changing the successful event or reintroducing the discarded failure-aware risk bound. + +The continuation synchronization proof now has both terminal cases sealed. Once the chosen ordinal is already present, the direct delayed computation is independent of its current context because it uses the stored chronological snapshot; before selection, a pure tail is constant false. Both facts are also exported under Boolean complementation for the resolver recursion. Recursive uniform, nonselected hash and signing steps remain. + +The complemented canonical wrapper is now definitionally connected to the standard `canonicalizeObserve` on every valid, completable context. It inherits position-neutrality from its underlying continuation, while the previously proved canonical guards provide the doomed and synchronized instances. A generic theorem consequently transports any false-on-stop witness run across finalization-equivalent contexts without inspecting the inner computation. The remaining synchronization induction only has to supply these continuation instances; the full masked signer and planned-hash implementations no longer need separate commutation proofs. + +The generic resolver bridge now also returns an exact equality for the original false-on-stop event by applying the standard true-on-stop recursion under Boolean complementation. The signing-query specialization is complete: the selected target commutes across the entire masked signer without unfolding it. The nonselected hash step must additionally transport its chronological trace. Early target resolution changes the context stored in the new snapshot and installs the target value in the new observation, so those records are not equal; the required relation is the existing `installPositionValueAtProbe` chronology together with equality of the erased probe list. Treating the records as equal would be unsound. After this trace-aware hash step, the structural induction, fixed-root wrapper and existing ordinal and terminal bounds remain. + +The trace audit exposed a narrower but essential qualification to eager normalization. Exact equality at a fixed ordinal is false for the ungated proof-side indicator: an earlier proof-only encoding candidate can equal the hidden root, and eager materialization then recognizes that earlier hit while the delayed log cannot. The successful source event already rules this case out through the strict-prefix `CandidatesAvoidRoots` clause of `GoodForRoots`. The delayed indicator now carries exactly that prefix gate, so it remains a valid dominator of every real success while excluding the extra proof-only executions. With this gate, the selected hash normalization is exact again because resolving the target changes snapshot contexts but not their erased candidate prefix. Both nonselected hash branches are now compiled. In the safe branch, installing the resolved value preserves the event-relevant trace and the complete retained continuation has the same Boolean distribution. In the unsafe branch, a support induction through the full delayed interpreter proves that any `true` result forces every earlier snapshot to avoid both roots, contradicting the unsafe candidate; the same argument applies symmetrically, so both computations are constantly false there. The combined hash theorem is therefore an exact Boolean coupling. What remains at this seam is the structural normalization lift through pure, uniform, signing and hash constructors, followed by the already packaged fixed-root and terminal chain. This is an accounting correction, not a change to the game or security claim. + +The nonselected hash theorem is now unconditional under the chronological prefix invariant. Any successful delayed execution proves that every observation before the chosen ordinal is hit-free. If the new candidate keeps that prefix clean, the exact safe or unsafe trace coupling applies; if it makes the prefix dirty, the first-hit condition forces both the delayed and eagerly resolved computations to be constantly false. Resolving the target is also proved to preserve such a dirty candidate observation. Thus the hash constructor now supplies an exact coupling without assuming in advance that its newly appended observation is clean. What remains at this seam is the mutual structural induction establishing continuation synchronization and position neutrality, followed by the already packaged fixed-root and terminal chain. + +The continuation laws are now compiled for pure, uniform and signing constructors. The proof packages the complemented false-on-stop interpreter as the standard true-on-stop resolved observer, transports it across finalization-equivalent contexts, and moves any ensured structural resolution across the whole private subcomputation. Both laws recurse only while the selected ordinal is still beyond the retained prefix, which is the strongest true invariant and avoids asserting position neutrality after the delayed computation has already stopped at its selection. The hash constructor is the only remaining case of this mutual observer induction. + +The hash synchronization obstruction is now isolated and its semantic invariant is compiled. Finalization-equivalent contexts can have different pending sets at already determined coordinates, but every unmatched entry is certified to miss that coordinate's fixed completion value. `CompletionSafeStateEq` records this safety in both directions. The relation is preserved by every clean probe operation and by the complete materialized hash and signing boundary, including synchronized failure when a reveal meets a pending candidate. This rules out the feared selected-context mismatch without requiring pending-set equality. The remaining local step is to transport finalization success through this bidirectional relation and use it to close the selected hash observer; the nonselected observer then follows from the existing trace and dirty-prefix lemmas. + +Hash observer synchronization is now complete. Successful finalization is invariant under `CompletionSafeStateEq`: missing chain-start failures transfer in both directions, and whenever a position remains unresolved, the two pending sets are equal, so a successful finalization witness on either side supplies the same strict per-coordinate cardinality bound on the other. Coupling target resolution with the bidirectional materialized boundary therefore gives exact equality for a hash query that reaches the selected ordinal. The earlier trace theorem handles a clean nonselected query, while a dirty added observation makes both indicators constantly false. The remaining half of the hash constructor is position neutrality, after which the mutual structural induction can be assembled. + +The selected hash constructor is now position-neutral for resolution of its own selected target. The proof exposes the selected delayed boundary, uses idempotence of a successful target resolution, and preserves the planned candidate and selected ordinal from equality of resolved state values. The open part of hash position neutrality is resolution at a distinct ensured position, where the two position resolutions must be commuted across the materialized selected boundary without losing the first-root event. + +A first-principles audit corrected the last status paragraph: universal neutrality at every distinct position is stronger than the normalization needs and is not justified by the selected-boundary argument. The resolver recursion now has a compiled `ObserverPositionNeutralAt` interface for one fixed position, including the arbitrary-context and canonical-observer transport wrappers, while the existing universal interface remains available to earlier modules. The selected hash lemma supplies exactly this fixed-target premise. The generic direct-to-resolved runner conversion still asks for universal neutrality because an arbitrary inner computation may reveal arbitrary positions, so the next local step is to specialize the commute to the one planned hash execution instead of routing it through that overgeneral conversion. This narrows the remaining proof obligation without changing the game, the security claim or the settled amortized design. + +The fixed-position commute is now proved directly for every oracle computation. Its reveal cases use the existing two-position and chain-start commutation theorems, so it does not pass through the universal direct-to-resolved conversion. The result is connected to the false-on-stop witness event under canonicalization, and pointwise neutrality is compiled through pure, uniform and signing constructors. The remaining constructor is the hash query: its selected branch uses the proved self-target lemma, while its nonselected branch must instantiate the new pointwise witness commute after transporting the appended chronological trace. Once that branch is compiled, the mutual structural induction and the existing fixed-root, sampling and terminal wrappers remain. + +Pointwise hash neutrality is now compiled as well. At the selected ordinal it is the idempotent self-target resolution theorem. Before selection, the delayed computation is compared with its eager form: a clean appended trace uses the fixed-target witness commute, while a dirty trace makes both sides constantly false. Pure, uniform, hash and signing therefore all have the pointwise law needed by the structural induction. What remains is to package those constructor laws with synchronization in the mutual induction, then pass the result through the existing fixed-root, sampling and terminal wrappers to the public theorem. + +The mutual structural observer induction is now complete. A new direct-to-direct synchronization theorem handles arbitrary inner reveal computations without assuming neutrality at unrelated positions; both executions resolve the same requested coordinate together. Uniform, signing and hash synchronization therefore recurse only on synchronization, while the parallel target-neutrality induction remains fixed at the selected structural position. Their conjunction is proved for every outer adversary computation under the chronological aligned, hit-free prefix invariant. What remains is to instantiate this law at the initialized fixed-root prefix, lift the resulting eager/delayed equality through the public-root and secret samplers, then apply the existing ordinal, diagnostic and terminal arithmetic endpoints. + +The structural laws now remove the initial target-resolution precondition as well. A proof-only ensured context transports the resolver through any valid completable starting context, after which fixed-position neutrality removes the temporary ensure and synchronization transports the result back. Consequently the eager and delayed selected-root indicators have exactly the same Boolean distribution at the initialized empty prefix, even though the selected lower or middle layer root is initially absent. The next seam is directional rather than probabilistic: compose this equality with the existing selected-root suffix coupling so the normalized proxy implies the fully resolved eager observed event, then apply the already compiled public-root and production wrappers. + +The initialized fixed-root coupling now lands directly in the eager target-resolution proxy. The public-root support witness supplies validity and completion of the raw deferred context, canonicalization preserves both, and the exact structural normalization replaces the delayed proxy without changing its Boolean distribution. This seals the unresolved-real to eager-proxy direction. The remaining local theorem is the converse semantic direction from a successful eager proxy to the fully observed run with that target installed; it must use the selected-root suffix coupling rather than invert the already proved implication. + +That remaining direction is now the sole explicit premise of a checked end wrapper. Given eager-proxy to resolved-observed coupling for each supported public-root result and fixed comparison root, relational transitivity supplies the fixed-root bridge, commutation samples the comparison root in the production order, and the existing root-aware endpoint gives the weighted per-target `2^-128` bound. Thus public-root sampling and the production experiment contain no additional semantic gap. The next task is exactly the directional eager-proxy lemma, after which the weighted target fibers and ordinal sum are arithmetic assembly. + +The eager-proxy premise is now reduced through the target sampler itself. For every supported public-root result, the raw deferred context is valid, completable, start-table consistent and clean; canonicalization has the same finalization view. Resolving the selected target in those two contexts is therefore coupled with equal output and finalization-equivalent result contexts. A checked bind wrapper reduces the whole missing direction to one pair of supported successful resolutions. The remaining local relation starts after the target value is fixed on both sides and must carry the proxy through the observed materialized execution; no sampler or unresolved target remains inside it. + +The successful-resolution interface now records its canonical normal form explicitly. Coupled successful resolutions have equal revealed sets, and canonicalizing both result contexts gives equal public state values, finalization equivalence and completion-safe materialized states in both directions. Resolving a position from a published canonical context also preserves canonicality, so the delayed proxy's left result needs no further normalization. This isolates the remaining prefix lemma from the target sampler and from representation-dependent state fields. + +The reverse selected-hash boundary is now compiled. Once the fixed target output, hidden selected coordinate, chronological prefix avoidance and pending coverage are available, the delayed proxy invokes the existing selected-root suffix coupling in the required direction. Its installed target state reduces to the original materialized state, its proof-only observation prefix is transported back to the actual prefix through the ordinary-cache quotient, and retaining the public root is removed without weakening the successful event. The remaining semantic work is therefore only the prefix before the chosen ordinal: carry a successful proxy through probe-free uniform and signing steps and through nonselected hash steps until this selected constructor applies. + +The reverse uniform constructor is now compiled as a standalone production lemma. Both executions consume the same uniform answer, the observed state and logs are definitionally unchanged, and canonicality removes the proof-side administrative wrapper before applying the recursive relation. The remaining prefix constructors are signing and nonselected hashing; the latter must retain its failure classification because the older forward coupling intentionally forgets information after a stopped comparison and cannot simply be reversed. + +The reverse induction now carries separate source and observed probe fuels. Equal fuel is not a valid global invariant because the root-aware observed executor may perform one extra proof-only encoding probe at an outer hash query. The source retains at least its remaining outer-hash bound, while the observed side retains `q` additional units; the selected boundary then uses the existing sufficient-fuel coupling to move from the source fuel to the observed fuel. This matches the initialized `q` versus `2q` allocation and removes a latent overstrong statement before the nonselected hash case is attempted. + +The reverse signer constructor is now compiled with an exact strong coupling. A probe-free masked signer preserves finalization equivalence, both fuel counters, the secret table, both split caches, revealed coordinates and the complete materialized value map. The root-aware proxy correction is compiled through the selector, adaptive lift and complete eager-normalization stack. The delayed proxy now executes the same root-aware candidate that it records, so a latent candidate collision stops both the proxy and observed executions instead of being forgotten on one side. A generic first-stopped coupling classifies this corrected private execution against the observed materialized query while preserving the separate fuel budgets. The full build is green again with only the public theorem's `sorry`. The remaining local work is to use this corrected stopped relation in the reverse nonselected hash constructor, assemble the reverse structural prefix induction, and then apply the already compiled fixed-root, ordinal, boundary and terminal arithmetic endpoints. + +The reverse fixed-ordinal prefix transport is now complete. The nonselected hash constructor couples the delayed and observed root-aware steps with their exact zero-or-one fuel difference, reconstructs the detailed observed support invariants, and handles every candidate outcome, including the hidden non-completable branch whose resolved finalizer must fail. Uniform, signing, selected-hash and nonselected-hash constructors now compose into the complete structural induction, and the production build remains green with only the public theorem's `sorry`. What remains is endpoint packaging: instantiate the fixed-ordinal root theorem with this transport, sum the fixed ordinals, combine the root and retained-rest cases with the existing boundary and terminal bounds, and discharge the final arithmetic in `SphincsSecurity.lean`. + +The target-specific production endpoint is now dominated by a permissive root-aware selector whose computation and initial state do not name the target. Canonical public planning erases every unrevealed materialized value, so installing a hidden target does not change the candidate list. The permissive interpreter ignores pending-hit failures but preserves values, revealed coordinates and ensured coordinates, and a structural induction proves that its selected probe is invariant under any pending-only state difference. Factoring the hash constructor into its plan, candidate list, public action and continuation keeps this induction within the ordinary build budget. The next task is the fixed-position eager-to-delayed sampling normalization for this selector. Once that equality is available, its position fibers provide one common production distribution, after which the root and non-root ordinal bounds and terminal arithmetic can be assembled without copying failure mass across targets. + +The explicit high/root sampler in the target-specific production weight is now normalized to one ordinary deferred position resolution for every supported public-root result. The equality is lifted through public-root sampling, the old production weight is bounded by the resolved experiment, and the complete fixed-target root endpoint now refers only to that experiment. The remaining commonization seam is therefore exactly one resolution followed by the target-independent selector. + +The common permissive observer now installs the hidden split-cache entry exactly when its deferred context contains the distinguished output. Its synchronization law is compiled: finalization-equivalent contexts give equal materialized values, equal revealed coordinates and the same installed cache, hence exactly the same selector distribution. The permissive state relation was correspondingly reduced to the fields its interpreter actually reads; `ensured` never affects its control flow. The remaining half is fixed-position neutrality of this observer, which is the deferred-resolution commute itself. + +The common permissive selector now has an exact detailed instrumentation retaining the selected candidate, candidate list and lazy state. Erasing that detail recovers the previous selector exactly, and pending-only differences preserve its unrevealed layer-root fiber. More importantly, a structural coupling from the target-specific clean selector is complete: every successful selected root lands in the same common fiber while still unrevealed, whereas a stopped run, an unsafe comparison candidate or a revealed target creates no obligation. This removes unrelated failure mass before any sum over positions. The next step lifts this stronger endpoint through the target sampler and performs the fixed-position eager-to-delayed commute on the unrevealed fiber. + +The stronger detailed endpoint is now lifted through the concrete low and high root-output sampler. Sampling those parts and installing the resulting hidden target is proved distributionally equal to resolving that target once with the ordinary deferred resolver. Consequently the target-specific clean production mass is bounded by the target's unrevealed fiber in a resolved detailed permissive experiment. The remaining commonization seam is to commute that one eager target resolution past the target-independent detailed selector while preserving only its positive unrevealed fiber; after that, the fibers are disjoint and can be summed in one experiment. + +The target-independent detailed experiment and its cross-experiment fiber summation theorem are now compiled. The common experiment returns one optional structural position, so its nonempty fibers are disjoint by construction and their total mass is at most one; the summation theorem transfers target-specific left fibers into those common fibers without duplicating failure mass. The remaining semantic seam is local: from a supported clean public-root result, move one eagerly sampled hidden target value into the permissive selector's first reveal while preserving the positive event that the ordinal selects that target before publication. + +The one-cell lazy factorization underlying that seam is now compiled for every target-peek-free computation. The eager side preloads only the distinguished position value and keeps its pending probes, so ensure, probe, publish and every unrelated reveal commute through the preload. At the first reveal of the distinguished position, the lazy side samples the same output and the two permissive executions synchronize. This avoids the false stronger invariant that would materialize the eager cell early and erase its pending probes. The remaining lift is concrete: thread this preloaded-or-synchronized state relation through the target-independent outer selector while quotienting its split cache by hidden entries, then apply the common position-fiber summation. + +Target-peek freedom is now compiled for every concrete action used by that selector. It is compositional through the complete masked signer, including digest and encoding retries, all tree reservations, reveals and publications, and through the root-aware public hash action. The latter derives its plan from the canonical public snapshot and performs only a candidate probe followed by an ordinary hash or public resolution, so it never reads the distinguished hidden cell through a runtime peek. The remaining local proof can therefore instantiate the generic factorization at every action boundary; its additional invariant is only that hidden split-cache entries are observationally irrelevant until reveal overwrites them. + +That hidden-cache invariant is now compiled through the permissive interpreter and the full concrete action stack. A generic bind law for the permissive interpreter supports a compositional quotient: equal ordinary cache projections produce equal lazy states, remaining fuel, public results and ordinary cache projections, while hidden entries may differ. The result covers uniform actions, root-aware public hash actions and the complete masked signer. The outer selector induction can now combine this quotient with target-peek freedom and the one-cell factorization; no unproved semantic property remains below that induction. + +The hidden-cache quotient is now lifted through the complete detailed selector. Starting from equal ordinary cache projections, the two selectors return exactly coupled detailed selections: the candidate, candidate list and lazy state agree, even though their hidden cache bookkeeping may differ between action boundaries. In particular, the proof-only target entry installed by the eager experiment can be erased before the sampling commute. The sole remaining commonization theorem is therefore state-only: commute one uniform preloaded target value through the target-peek-free selector on a shared cache, preserving its unrevealed target fiber. + +The continuation-aware state-only factorization is now compiled. It keeps the distinguished uniform sample live across every target-peek-free action that has not revealed the target, commuting it past unrelated uniform and hash draws and through ensures, probes, publications and unrelated reveals. At the first target reveal it couples the lazy answer to that same sample and switches to the existing synchronized-state relation. Its terminal hypotheses are parameterized by the caller's continuations, so the recursive outer selector can instantiate it without conditioning away the sample's independence. What remains at the commonization seam is now structural assembly of these compiled state and cache lemmas, followed by the already prepared position-fiber sum. + +The state-only factorization is now assembled through the complete detailed selector. Revealed coordinates are proved monotone through both the permissive interpreter and the outer selector, which discharges malformed or already-revealed initial states without assuming an unstated validity invariant. The selector induction handles immediate ordinal selection, uniform queries, root-aware public hash queries and the full masked signer; at a public hash boundary it rewrites the target-independent plan and candidate list before applying the continuation-aware action factorization. Thus one eagerly sampled hidden target value is coupled to the target-independent selector while preserving the one-sided positive unrevealed target fiber. The full build remains green with only the public theorem's `sorry`. What remains is to combine this state coupling with the compiled hidden-cache quotient at each supported public-root result, lift it through the production experiment, apply the common position-fiber sum, then assemble the ordinal, boundary, terminal and final arithmetic bounds. + +The resolved target-specific production experiment is now coupled to the common target-independent selector. For every supported public-root result, the empty pending set makes deferred resolution one ordinary target sample; its materialized state agrees with the preloaded state on exactly the value and revealed fields read by the permissive interpreter, and the proof-only hidden cache entry is removed by the ordinary-cache quotient. This coupling is lifted through public-root production and composed with the real root endpoint. Consequently each successful fixed-root fiber is bounded by the corresponding fiber of one common selector distribution times `2 * 2^-128`, with no copied failure mass. + +The finite-position aggregation is now compiled. Every observation emitted by the root-aware public handler is proved to carry a candidate with a structural parent, including both ordinary planned candidates and proof-only encoding-root candidates. That invariant is preserved through the complete observed retained run. It rules out all parentless position fibers operationally, including invalid top-layer positions that the finite `Position` type can name but the handler never selects. The remaining fibers sum against the single common selector distribution, giving a fixed-ordinal root bound of `2 * 2^-128` with no `Position` cardinality factor. The root and non-root bounds are now combined at each reachable ordinal, and source-length support proves that every ordinal at or above `q` has probability zero. Summing gives `3q * 2^-128` for a successful doomed diagnostic and adding its `2q * 2^-128` finalization term gives a complete `5q * 2^-128` diagnostic bound. What remains is to close the granular private-failure projection with its delayed-root residual, reuse the boundary endpoint at `c = 9`, and replace the public theorem's sole `sorry`. + +The final boundary arithmetic is now compiled independently of the remaining semantic endpoint. The materialized canonical-private event has its exact zero bound, rather than the earlier one-unit weakening. Therefore a `7q * 2^-128` granular-private estimate combines with the two ordinary units to give exactly the required `c = 9`. The remaining semantic work is isolated to that granular estimate: add the `1q` delayed hidden-root and `1q` non-root source charges to the existing `5q` diagnostic charge, then connect the resulting boundary estimate through the existing terminal wrapper. + +The two source residuals now have their finite ordinal aggregation compiled. Supported canonical sources contain at most `q` candidate snapshots, so both the delayed layer-root event and the non-root first-use event reduce to `Fin q` fixed-ordinal estimates and sum to `q * 2^-128` without enumerating `Position`. The remaining local probability work is exactly those two fixed-ordinal estimates; after they are connected to the existing five-unit diagnostic, only the granular-to-boundary semantic projection and terminal invocation remain. + +The non-root source residual is now closed at one unit per query. Erasing the canonical snapshot source recovers its witness-plan semantics, whose fixed first-use ordinal is dominated by the existing candidate-time non-root monitor. The root construction preserves the consistency needed by that monitor, and its established freshness theorem supplies the final one-query bound. The only unfinished source probability is now the fixed delayed layer-root ordinal. + +The delayed layer-root residual is now reduced to target-independent position fibers. A delayed fixed ordinal determines one layer-root position and one ordinal selection that is good for the actual hidden root, including the all-miss prefix. Its probability is reduced to proving that each target fiber is at most the matching fiber of the existing permissive production experiment times `2^-128`; those permissive fibers sum to one. This is the remaining probabilistic bridge, with no `Position` cardinality factor and no duplicated failure event. + +The delayed target fiber now has a checked comparison-root split. Its good branch preserves the exact selected ordinal and maps to `GoodForRoots`; its exception is bounded by the delayed fiber's own probability times `ordinal * 2^-128`, so no unrelated failure mass is introduced. This leaves one weight-preserving semantic coupling from the delayed snapshot execution to the target-independent permissive selector. The comparison route yields a conservative two-unit delayed charge after absorption, hence `c = 10`; recovering the earlier `c = 9` target would require a sharper direct exchangeability lemma. + +All arithmetic around that last coupling is now compiled. Assuming only the fixed-table good-comparison fiber bound, the exception is absorbed while its target-production weight is still present, the target fibers are summed through the single permissive selector, table sampling is averaged, and the reachable ordinals are summed to a `2q * 2^-128` delayed bound. No later proof step can accidentally copy an unconditional failure probability across targets. The remaining source theorem is exactly the one-sided coupling from a successful early private ordinal selection to the matching permissive position fiber. + +The first reusable part of that source theorem is now compiled. Any valid, completable deferred action that has the strong finalization-materialization coupling is dominated one-sidedly by the same action in the permissive interpreter: every completed deferred result has the same value, fuel, table, revealed set and fully materialized value map, while stopped deferred results impose no obligation. This removes ordinary unrelated hit failures before the selector induction and reuses the existing strong signer machinery. The remaining work is to thread this local rule through the outer ordinal selector, with the hash branch accounting for its root-aware proof probe and its separate fuel counter. + +A schedule audit separated the delayed-source common selector from the earlier root-production selector. The latter executes an extra proof-only encoding-root probe, which is necessary for root production but can reveal a position that the delayed source never queried and therefore cannot preserve the delayed unrevealed-position fiber. The new delayed selector records exactly the same root-aware candidates while executing only the source game's actual hash action. Its state invariance, candidate alignment, uniform and signing action bridges, and complete outer structural induction are compiled. The induction is parameterized only by `DelayedHashActionCouples`, the remaining local hash-action bridge; once that bridge is discharged, the fixed-table comparison fiber connects directly to the already compiled delayed ordinal and final arithmetic. + +The delayed hash-action bridge is now discharged. Its local relation distinguishes an exactly coupled completed action from a deferred result that canonicalization rejects. For a planned probe whose pending candidate remains completable, the source and permissive interpreters agree on the completed value, cache, fuel, table, revealed set and materialized values. If adding that candidate makes the deferred context incompletable, incompleteness is preserved through the probe-free public suffix and through canonicalization, so the source continuation is rejected instead of being matched to a spurious permissive success. The complete delayed outer selector coupling is therefore unconditional. What remains is endpoint plumbing: instantiate it at the post-root source experiment, prove the fixed-table good-comparison fiber bound against the delayed selector, and feed that bound to the already compiled ordinal sum and final security arithmetic. + +The delayed selector now also has its own hidden-target preloading theorem. Sampling and preloading one absent structural value before the selector cannot increase that position's unrevealed fiber, and the proof covers the delayed hash schedule rather than importing the older selector's extra encoding-root probe. The supporting invariants prove that revealed coordinates only grow, that the delayed public action is unchanged by a hidden preload, and that it never peeks at the target. This closes the target-removal half of the endpoint. The remaining half must retain the sampled target value through the fixed-output good-comparison coupling so that root exchange contributes the required `2^-128` factor before preloading is erased. + +Target removal is now lifted through the full post-root experiment. The delayed selector has its own hidden-cache quotient, including its exact public hash action, so the proof-only target entry can be removed without changing the selected candidate, candidate list or lazy state. Combining that quotient with hidden-value preloading proves that the installed target-specific delayed selector fiber is at most the matching fiber of the single target-independent delayed selector after every supported public-root result. The only remaining endpoint theorem is the first half: transport a good delayed source to this installed experiment while retaining the low root sample and use root exchange to extract its `2^-128` weight. + +The delayed target-preloading coupling now preserves the exact selected probe in the distinguished unrevealed-position fiber. The stronger relation is compiled through immediate ordinal selection, uniform queries, the delayed public hash action, the complete masked signer and the hidden-cache quotient. This repairs the information loss in the earlier fiber-only endpoint: the next source-side coupling can retain the hidden output's low digest and identify it with the selected candidate before target erasure. What remains is to construct that joint source-to-installed experiment, apply the uniform low-root bound, and invoke the compiled ordinal and final arithmetic wrappers. + +The source-to-permissive selector relation now preserves the selected candidate itself whenever the source selection is good for the fixed comparison roots, rather than retaining only its structural position. The installed-to-common target-erasure coupling is lifted through both the supported post-root computation and the fixed secret table while projecting that exact candidate. Thus both sides of the final probability argument expose the same target probe. The remaining theorem must connect that probe to the sampled hidden root output on the source side and apply the uniform low-digest bound before the already compiled target erasure and ordinal sums. + +The existing finite-table materialized selector has now been reused for the delayed branch rather than duplicating its completed root-family argument. Its hash schedule has no proof-only encoding probe, exactly matching the delayed source. A compiled clean-to-delayed coupling transports its production marginal through target installation and then into the common delayed selector, so the materialized match event is bounded by the common target fiber times `2^-128`. The remaining semantic bridge is only from the delayed source good-comparison event into that existing materialized match event; all root exchange, target erasure, fiber summation and arithmetic after it are compiled. + +The delayed source coupling now retains equality of the complete candidate history as well as the selected candidate and target value. This carries the source event's strict-prefix avoidance into the common selector, which is the missing fact needed to reverse the failure-retaining materialized selector on exactly the successful fiber. The remaining local step is to prove that reverse event implication through the materialized selector, after which its existing one-guess bound applies. + +The delayed root witness is now packaged on the common selector as one precise event containing the selected target candidate, its exact hidden output and avoidance of both comparison roots throughout the strict prefix. Every supported delayed selection is proved to extend its initial candidate list. A soundness audit rejected the proposed reverse implication into the clean materialized selector: an unrelated pending hit can stop that selector even though the permissive selector continues and later reaches the target, and avoidance of the target's two comparison roots does not exclude that execution. The replacement endpoint performs root exchange inside the permissive interpreter itself, where unrelated hits are retained. Both halves of its signer exchange are compiled. The hidden-root relation crosses target-aware tree recomputation, every signing layer, the digest loop and complete signature assembly. A single encoding-cache relation now couples corresponding root-dependent cache keys, preserves the stored root, crosses the same complete signer, and handles root-avoiding delayed public actions without discarding unrelated pending hits. What remains is to lift these local rules through the symmetric root-avoiding delayed selector and feed its one-guess bound into the existing target-fiber and terminal arithmetic. + +The symmetric root-avoiding delayed selector is now compiled through both cache-key exchange and hidden-value exchange. The hidden exchange deliberately relates the detailed states instead of claiming their distributions are equal, then projects to exact equality of the selected probe and candidate history. Public resolution of the distinguished cell is filtered only after actual publication; ordinary fallback execution is retained. The hash constructor is factored behind an abstract continuation lemma, so the complete selector lift stays below the ordinary heartbeat budget. What remains is the outer two-root sampling calculation, the event-preserving bridge from the original delayed selector into this filtered selector, and the already compiled ordinal, boundary and terminal arithmetic. + +The complete fixed-output exchange theorem is now compiled. It composes the encoding-key cache permutation with the hidden-value relation, then uses symmetry of the two-root avoidance guard to obtain exact equality of the projected selected-probe distributions under a full root swap. The theorem applies to preloaded states without erasing pending probes and retains unrelated pending hits throughout. What remains around this equality is one weakening from the two-root guard to a fixed-root reference for the independent-guess bound, plus the event-preserving bridge from the original delayed selector; the outer sampler and final arithmetic can then consume the result. + +The fixed-root weakening and independent-guess calculation are now compiled. A one-sided selector coupling removes the comparison-root guard without losing any matching selection, and the generic two-root exchange argument then bounds the actual-root match by the fixed-root reference weight times `2^-128`. The calculation is generic over the root-indexed output and cache family, and the reference probability remains multiplicative rather than being rounded up to one. What remains is to dominate that reference weight by the existing common target fiber and to prove that the original delayed good event reaches the filtered selector; these are the two event-facing sides around the completed exchange. + +The filtered selector is now proved complete on the delayed root-witness event. The witness retains the source fact that the target is still unrevealed, early publication therefore makes the event impossible, and an unsafe planned candidate contradicts the retained strict-prefix avoidance. The opposite direction is compiled as well: every filtered target selection maps into the original delayed target fiber, including the sampled-high installed-root experiment. The generic one-cell factorization now also has a tagged form that can retain the eagerly sampled hidden output through an output-dependent continuation, while the old untagged theorem remains as a wrapper. What remains is to instantiate that tagged factorization through the delayed selector, compose the resulting sampled-output witness with the root exchange, and invoke the existing ordinal, boundary and terminal arithmetic. + +The conservative private witness bound is now assembled at `8q * 2^-128`: two units for diagnostic finalization, three for a successful doomed diagnostic, two for the delayed root comparison and one for the non-root source. The earlier seven-unit target was stale after accepting the honest two-unit delayed comparison. Together with the two ordinary boundary units, the retained verifier-probe endpoint therefore has constant `c = 10`. + +Fresh layer and backward chain terminal witnesses are now grouped before taking probabilities. Both deterministically imply the same retained verifier-probe event, so the grouped terminal endpoint charges that event once. The complete terminal arithmetic now accepts any probe constant satisfying `c + 46 ≤ 64`; the current `c = 10` leaves eight units at denominator `2^128`. The remaining work is semantic plumbing: project the canonical private witness estimate to the original granular Boolean event, establish the complete boundary domination by its two ordinary causes and private causes, and instantiate the grouped endpoint in the public theorem. + +The canonical snapshot estimate now erases exactly to the canonical private-witness plan, and the complete ten-unit retained-probe calculation is packaged without introducing a new interpreter or state relation. A first-principles audit found that the initial endpoint exposed three premises in a misleading shape. In particular, the public concrete query bound does not imply a syntactic `IsOuterHash q` bound for arbitrary sequences of abstract signing-oracle replies. The sound transfer must follow only supported replies of the concrete signer, as the existing path-sensitive `DirectQueryBudget` and `ReachableResolvedCouples` developments already do. The private and ordinary boundary premises are now combined into the exact semantic inequality needed by the arithmetic, so the proof does not require a stronger exact private projection than the operational coupling justifies. Two seams remain: carry the supported concrete query budget through the canonical witness source, and prove that total all-direct boundary failure is bounded by the two ordinary units plus the canonical witness event. These are proof-interface and schedule-normalization obligations, not missing cryptographic cases, and the grouped terminal theorem then closes the unchanged public statement at coefficient ten. + +The supported-budget migration now covers both the snapshot-to-materialized root comparison and every candidate-list length bound. Both inductions install the concrete signer before consuming the budget. Their signing branches prove that the actual masked signer output belongs to the concrete signer's support before inheriting the continuation budget, so impossible abstract replies are excluded. This interface is carried through fixed-table root construction and table sampling, where the public `HasHashQueryBound` premise supplies it directly via `isQueryBoundP_expandedRetained_all_tables_roots`. Consequently the delayed-root and non-root ordinal unions now use only the concrete expanded-game budget. The older raw `IsOuterHash` premise remains in the diagnostic finalization and successful-doomed probability arguments. It no longer participates in candidate counting, but those diagnostic arguments must still be migrated before the canonical eight-unit estimate is a valid consequence of the public bound. + +The first-stopped diagnostic comparison now uses the concrete expanded-game budget as well. Its signing constructor extracts the completed direct run, proves that the returned masked signature belongs to the concrete signer's support, and specializes the continuation bound only to that supported reply. This stronger premise is propagated through the fixed-table and sampled wrappers, so the non-root successful-doomed charge and the unreachable-ordinal argument no longer depend on the raw abstract signing budget. The raw premise now remains in two isolated places: the two-unit finalization-failure estimate and the selected-root delayed-shadow induction used by the root part of the successful-doomed estimate. The next migration targets that delayed-shadow induction, whose signing constructor already retains the direct support witness needed for the same specialization. + +The selected-root delayed-shadow comparison now also follows only supported concrete signer replies. Both directions of the adaptive root coupling reconstruct the expanded-game budget at uniform and hash queries, extract concrete signer support at signing queries, and preserve agreement with the fixed chain-start table. The stronger premise is propagated through the post-root endpoint, fixed-table fibers, common position aggregation and sampled ordinal sum. Consequently the complete three-unit successful-doomed estimate uses only the public expanded-game query bound. On the active path to the canonical eight-unit private estimate, the raw abstract-reply premise remains only in the two-unit finalization-failure theorem. Migrating that final induction is the next soundness repair before the boundary semantic inequality and grouped terminal endpoint can close the public theorem. + +The two-unit finalization-failure estimate now follows only supported replies of the concrete signer too. Its safe-step guard retains cache growth, chain-start-table agreement and an admissibility predicate for actual results; the signing branch derives that predicate from the completed masked signer run, while uniform and hash branches specialize the concrete expanded-game budget directly. The stronger premise is propagated through classification, adaptive-production and canonical endpoint assembly. No raw query bound over impossible abstract signing replies remains on the active path, and the full build is green with only the public goal sorry. The remaining proof obligation is the semantic domination from complete all-direct boundary failure to the already bounded ordinary and canonical private endpoints. + +A review of the remaining boundary seam rejected two tempting shortcuts. `actualRetainedGameAfterTable` eagerly samples only the one-time and few-time secrets, not the adaptive random-oracle table, and VCVio's `DeferredSampling.Factorizes` packages a scheme-specific factorization premise rather than proving it. Exact equality between the all-direct and granular schedules is also too strong because canonicalization deliberately removes unrevealed structural values. The sound local postcondition is now compiled instead: under `DirectWitnessMaterializedStableRunEq`, every detailed failure is covered either by a private witness on the canonical side or by the ordinary projection of the detailed run. Its probability consequence has exactly the combined witness-plus-ordinary shape required by the final boundary inequality. What remains is to lift this terminal kernel through the retained computation and the public-root prefix using the existing materialized-stability action lemmas. + +The terminal witness-or-ordinary kernel is now lifted through the complete retained computation. The induction handles uniform queries, root-aware public hash queries and supported replies from the concrete masked signer, while maintaining separate left and right fuel budgets for the proof-only root-aware probes. A materialized continuation that has become incompletable is classified immediately as ordinary failure, and every clean continuation preserves the canonical witness relation. What remains is to attach this lift to the probe-free public-root computation and identify its detailed materialized endpoint with the all-direct boundary failure up to the two already bounded ordinary endpoints. + +The adaptive lift is now attached to the probe-free public-root computation. Starting from the empty deferred context at fuel `q` and the empty materialized context at fuel `2q`, it couples the complete canonical witness source to a root-aware materialized detailed endpoint under `WitnessOrOrdinaryCovers`. Final resolution cannot introduce a private classification from the related completable contexts, so every terminal failure without a witness is ordinary. What remains is endpoint identification: dominate the real all-direct boundary failure by this detailed endpoint and project the endpoint's ordinary component into the two existing ordinary bounds. + +The endpoint audit found that `WitnessOrOrdinaryCovers` pointed in the wrong direction for the final inequality: it classified failure of the materialized execution, while the event to dominate is failure of the canonical execution. The repaired source now carries its boundary outcome and private witness together. `FinalizationContextLE` supplies the required monotonicity at finalization, and the combined relation is lifted through the complete retained computation, the public-root prefix and one-time-table sampling. Its witness projection is exactly the already bounded canonical witness plan, and its sampled failure probability is now bounded by that witness event plus the ordinary projection of the root-aware materialized endpoint. What remains is to identify the combined source failure with the existing all-direct boundary failure and to bound the root-aware materialized ordinary projection by the existing two-unit ordinary estimate. + +The combined source's failure marginal is now erased exactly to a dedicated canonical Boolean endpoint. The erasure first projects the combined outcome to the existing granular detailed execution, then projects detailed failure through canonicalization to `granularAllCanonicalBoundaryRetainedFinishIsNone`; the sampled wrapper preserves that equality. The remaining first seam is therefore directional and Boolean: transport all-direct failure into this canonical endpoint using the existing deferred-schedule refinement, without equating raw and canonicalized contexts. The second seam remains the root-aware materialized ordinary bound. + +The root-aware materialized endpoint's ordinary component is now erased exactly too. `rootAwareMaterializedDetailedBoundaryOrdinaryObserve` follows the same public plan and concrete query actions but retains only the Boolean ordinary classification; its retained-rest, public-root and table-sampled projections all agree exactly with the ordinary field of the detailed endpoint. The remaining probability step on this side is to dominate that Boolean game by the existing safe-ordinary completion estimate, using the concrete supported-reply query budget to exclude fuel exhaustion. + +Two places a proof can go wrong, both found by attacking the claim rather than by reading it: + +- **A strong forgery needs no chain inversion.** `Ver` does not check that the counter is the least admissible one, so a second `c'` with `Enc(P,lay,tau,e,M,c') = x` reuses the chain values verbatim and verifies. Since the codeword fixes the digest, that is one `2^-128` hit per query and it is harmless, but it is a branch of its own: the one-time signature is unforgeable on a *new* message by incomparability, and unforgeable on the *signed* message only by collision resistance at `tw_enc`. +- **Keep the conjunction in the one-time bound.** A forger does not need a codeword dominating `x`, only one lower on a single chain, `x' = x - e_j + e_l`, of which there are `1258` at these parameters. So an encoding query hits an exploitable shape with probability `2^-117.7`, above the `2^-120` slope; the event is a forgery only together with one chain inversion, giving `q^2 * 2^-247.7`. Charge the shape alone, linearly in `q`, and the proof fails at 120 bits. + +Build with: + +```bash +lake exe cache get # first time only +lake build +``` + +`lake build` checks the complete theorem. The development notes above record earlier intermediate obligations; they are not remaining assumptions of the final theorem. diff --git a/formal/sphincs/SphincsSecurity.lean b/formal/sphincs/SphincsSecurity.lean new file mode 100644 index 00000000..6f8d328a --- /dev/null +++ b/formal/sphincs/SphincsSecurity.lean @@ -0,0 +1,22 @@ +import SphincsSecurity.Statement +import SphincsSecurity.Proof + +namespace SphincsSecurity + +/-! +The public security theorems for the statements in `SphincsSecurity.Statement`. The 126-bit proof projects residual forgeries into the native rejection and finalization experiment, bounds that experiment by the refined query reserve, and combines it with the forest, structural, encoding and message-collision bounds in the original SUF experiment. +-/ + +/-- `126` bits of classical strong unforgeability in the random-oracle model for the concrete SPHINCS instance, at `2^24` signing requests per key pair. -/ +theorem sphincs_has_126_bits_of_classical_security : SphincsSecurity126Statement := by + exact Concrete.OtsProbeSimulation.security126_of_completed_native_boundary + +/-- `125` bits of classical strong unforgeability in the random-oracle model for the concrete SPHINCS instance, at `2^24` signing requests per key pair. -/ +theorem sphincs_has_125_bits_of_classical_security : SphincsSecurity125Statement := by + exact Concrete.OtsProbeSimulation.Range125.security125_of_completed_joint_boundary + +/-- `120` bits of classical strong unforgeability in the random-oracle model for the concrete SPHINCS instance, at `2^24` signatures per key pair. -/ +theorem sphincs_has_120_bits_of_classical_security : SphincsSecurityStatement := by + exact Concrete.OtsProbeSimulation.security_of_completed_canonical_boundary + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof.lean b/formal/sphincs/SphincsSecurity/Proof.lean new file mode 100644 index 00000000..5d81fa79 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof.lean @@ -0,0 +1,558 @@ +import SphincsSecurity.Proof.SecurityVerifierPrimitiveEndpoint +import SphincsSecurity.Proof.SettledCollisionGame +import SphincsSecurity.Proof.SecuritySettledCollisionEndpoint +import SphincsSecurity.Proof.OtsProbePrivateWeightedGame +import SphincsSecurity.Proof.SecurityQueryRateEndpoint +import SphincsSecurity.Proof.SecurityOccupancyEndpoint +import SphincsSecurity.Proof.FewTimeWeightedOriginAdaptive +import SphincsSecurity.Proof.Arith +import SphincsSecurity.Proof.Bytes +import SphincsSecurity.Proof.Code +import SphincsSecurity.Proof.Guess +import SphincsSecurity.Proof.QueryBound +import SphincsSecurity.Proof.CacheSize +import SphincsSecurity.Proof.Amortized +import SphincsSecurity.Proof.Position +import SphincsSecurity.Proof.Game +import SphincsSecurity.Proof.Secrets +import SphincsSecurity.Proof.Logged +import SphincsSecurity.Proof.Support +import SphincsSecurity.Proof.Hybrid +import SphincsSecurity.Proof.LeakArith +import SphincsSecurity.Proof.Chain +import SphincsSecurity.Proof.Eval +import SphincsSecurity.Proof.StatementLemmas +import SphincsSecurity.Proof.OneTime +import SphincsSecurity.Proof.Merkle +import SphincsSecurity.Proof.FewTime +import SphincsSecurity.Proof.Layer +import SphincsSecurity.Proof.Hypertree +import SphincsSecurity.Proof.Correctness +import SphincsSecurity.Proof.Extract +import SphincsSecurity.Proof.ExtractChain +import SphincsSecurity.Proof.ExtractOts +import SphincsSecurity.Proof.ExtractFts +import SphincsSecurity.Proof.Honest +import SphincsSecurity.Proof.Settled +import SphincsSecurity.Proof.Slot +import SphincsSecurity.Proof.Charge +import SphincsSecurity.Proof.ChargeStep +import SphincsSecurity.Proof.HitBad +import SphincsSecurity.Proof.Queried +import SphincsSecurity.Proof.Cached +import SphincsSecurity.Proof.SettledPath +import SphincsSecurity.Proof.Descent +import SphincsSecurity.Proof.Execution +import SphincsSecurity.Proof.ReplayWorld +import SphincsSecurity.Proof.SigningReplay +import SphincsSecurity.Proof.SigningTrace +import SphincsSecurity.Proof.TracedGame +import SphincsSecurity.Proof.RootCache +import SphincsSecurity.Proof.NoMessage +import SphincsSecurity.Proof.SignerDigestSource +import SphincsSecurity.Proof.FullTrace +import SphincsSecurity.Proof.SignSupport +import SphincsSecurity.Proof.EncodingCached +import SphincsSecurity.Proof.LayerCompare +import SphincsSecurity.Proof.FewTimeCompare +import SphincsSecurity.Proof.ForgeryClassify +import SphincsSecurity.Proof.Replay +import SphincsSecurity.Proof.Sampling +import SphincsSecurity.Proof.SecretProbe +import SphincsSecurity.Proof.AdaptiveRevealProbe +import SphincsSecurity.Proof.FtsProbeSimulation +import SphincsSecurity.Proof.FtsProbeLift +import SphincsSecurity.Proof.FtsProbeGame +import SphincsSecurity.Proof.FtsProbeSigner +import SphincsSecurity.Proof.FtsProbeAdversary +import SphincsSecurity.Proof.FtsProbeOrigin +import SphincsSecurity.Proof.FtsProbeTerminal +import SphincsSecurity.Proof.FtsProbeProbability +import SphincsSecurity.Proof.OneTimeEvents +import SphincsSecurity.Proof.TerminalCache +import SphincsSecurity.Proof.EncodingTarget +import SphincsSecurity.Proof.EncodingCharge +import SphincsSecurity.Proof.FewTimeWitness +import SphincsSecurity.Proof.FewTimePatterns +import SphincsSecurity.Proof.FewTimeProbability +import SphincsSecurity.Proof.FewTimeTrace +import SphincsSecurity.Proof.FewTimeSource +import SphincsSecurity.Proof.MessagePrehit +import SphincsSecurity.Proof.FewTimeUniform +import SphincsSecurity.Proof.EncodingProbability +import SphincsSecurity.Proof.EncodingRetry +import SphincsSecurity.Proof.EncodingSelection +import SphincsSecurity.Proof.EncodingSelectionCache +import SphincsSecurity.Proof.EncodingSelectionPotential +import SphincsSecurity.Proof.EncodingSelectionLift +import SphincsSecurity.Proof.EncodingRetryCharge +import SphincsSecurity.Proof.EncodingLatent +import SphincsSecurity.Proof.EncodingStageCharge +import SphincsSecurity.Proof.EncodingRisk +import SphincsSecurity.Proof.EncodingSignerLatent +import SphincsSecurity.Proof.FirstBad +import SphincsSecurity.Proof.EncodingTraceLatent +import SphincsSecurity.Proof.EncodingTerminalLatent +import SphincsSecurity.Proof.FewTimeLoop +import SphincsSecurity.Proof.FewTimeSignerView +import SphincsSecurity.Proof.FewTimeTargetSigner +import SphincsSecurity.Proof.FewTimeViewTrace +import SphincsSecurity.Proof.EncodingTerminalView +import SphincsSecurity.Proof.FewTimeTargetSource +import SphincsSecurity.Proof.FewTimeTargetCount +import SphincsSecurity.Proof.FewTimeTargetView +import SphincsSecurity.Proof.FewTimePadding +import SphincsSecurity.Proof.FewTimeFresh +import SphincsSecurity.Proof.FewTimePrehit +import SphincsSecurity.Proof.FewTimeSourceCount +import SphincsSecurity.Proof.FewTimePrehitArith +import SphincsSecurity.Proof.FewTimeRace +import SphincsSecurity.Proof.FewTimeOrigins +import SphincsSecurity.Proof.FewTimeWeightedCount +import SphincsSecurity.Proof.FewTimeOriginSampler +import SphincsSecurity.Proof.FewTimeOriginCandidates +import SphincsSecurity.Proof.FewTimeNumberedSources +import SphincsSecurity.Proof.FewTimeFixedPrehit +import SphincsSecurity.Proof.DirectQueryBudget +import SphincsSecurity.Proof.FewTimeOriginRealization +import SphincsSecurity.Proof.FewTimeOriginProbability +import SphincsSecurity.Proof.FewTimeOriginPadding +import SphincsSecurity.Proof.FewTimeOriginSchedule +import SphincsSecurity.Proof.FewTimeOriginMonitor +import SphincsSecurity.Proof.FewTimeOriginWP +import SphincsSecurity.Proof.FewTimeOriginPotential +import SphincsSecurity.Proof.FewTimeOriginInvariant +import SphincsSecurity.Proof.FewTimeOriginTerminal +import SphincsSecurity.Proof.FewTimeOriginLift +import SphincsSecurity.Proof.FewTimeTargetMonitor +import SphincsSecurity.Proof.FewTimeTargetCompletion +import SphincsSecurity.Proof.FewTimeTargetInvariant +import SphincsSecurity.Proof.FewTimeTargetTerminal +import SphincsSecurity.Proof.TerminalDecomposition +import SphincsSecurity.Proof.TerminalView +import SphincsSecurity.Proof.MandatoryQueries +import SphincsSecurity.Proof.TerminalArith +import SphincsSecurity.Proof.TerminalBudget +import SphincsSecurity.Proof.TerminalSampling +import SphincsSecurity.Proof.SecretProbeTerminal +import SphincsSecurity.Proof.MessageCollision +import SphincsSecurity.Proof.EncodingSelectionSampling +import SphincsSecurity.Proof.TerminalFinish +import SphincsSecurity.Proof.TerminalResidual +import SphincsSecurity.Proof.FtsProbeSampling +import SphincsSecurity.Proof.FtsProbeQueryBudget126 +import SphincsSecurity.Proof.LazyRevealProbe +import SphincsSecurity.Proof.OtsProbeSimulation +import SphincsSecurity.Proof.OtsProbeRealization +import SphincsSecurity.Proof.OtsProbeRetained +import SphincsSecurity.Proof.OtsProbeOrigin +import SphincsSecurity.Proof.OtsProbeTerminal +import SphincsSecurity.Proof.OtsProbeSampling +import SphincsSecurity.Proof.OtsProbeTrace +import SphincsSecurity.Proof.OtsProbeCoupling +import SphincsSecurity.Proof.OtsProbeCompletionSampling +import SphincsSecurity.Proof.OtsProbeRunSampling +import SphincsSecurity.Proof.OtsProbeResolvedSampling +import SphincsSecurity.Proof.OtsProbeResolvedSchedule +import SphincsSecurity.Proof.OtsProbeResolvedFinalization +import SphincsSecurity.Proof.OtsProbeResolvedSelectionFinalization +import SphincsSecurity.Proof.OtsProbeResolvedSignerFinalization +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveFinalization +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveSigner +import SphincsSecurity.Proof.OtsProbeChronologicalTerminal +import SphincsSecurity.Proof.OtsProbeChronologicalProbability +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveProbability +import SphincsSecurity.Proof.OtsProbeResolvedPrivateSelection +import SphincsSecurity.Proof.OtsProbeResolvedPrivateSchedule +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveClean +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryFirstFire +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivate +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryProbability +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryOrdinary +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryOrdinaryRefinement +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryOrdinarySigner +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryOrdinaryAdaptive +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateSafe +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePlan +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateFresh +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePlannedCommute +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateTrace +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateCount +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateCandidateGame +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateCandidateResolve +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateTraceInvariant +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePreparation +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePreparationCommute +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePreparationLift +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePreparationInterpreter +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePlanExecution +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePlanNormalized +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePlanNormalizedCount +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePreparationCanonical +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateHindsight +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateHindsightOuter +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateHindsightWeighted +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitness +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessPlan +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinal +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalProbability +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalCommute +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalInterpreter +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalUnion +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalMatch +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalMatchLift +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalPrefix +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRisk +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRiskLift +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHidden +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenPlan +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenPlanFinal +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenMatch +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenMatchLift +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenMatchOuter +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenPrefix +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenRisk +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenFresh +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenRiskBound +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenFreshSteps +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenFreshSigner +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalNonRootRisk +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootProbe +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootProbeCoupling +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootEvent +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootCache +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSigner +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootAdaptive +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootFiber +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSwapCache +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootState +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootStateSigner +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootStateHash +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootDeferred +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelection +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionSigner +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionMaterialize +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionMaterialized +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionEncoding +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionHash +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionHidden +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionProbability +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionDeferred +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionOutcome +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionLift +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionOutcomeProbability +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionWeaken +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionFamily +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionInitial +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionBoundary +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobal +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSource +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceHidden +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalCoupling +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalOperational +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalLift +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalFinish +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSample +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalProbability +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassification +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationKernel +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationSample +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationProjection +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStopped +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSource +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedHash +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedLift +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedTopKernel +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedTop +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedProjection +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSample +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSelection +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedProbability +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSelectorCoupling +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedNonRoot +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedAlignedProjection +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRoot +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootComparison +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootEager +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootSharedPrefix +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareProbability +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareBoundary +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareSample +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareExperiment +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareOutcome +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareSharedExperiment +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareSharedSemantic +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEager +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerSelected +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerBridge +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveBridge +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptivePrefix +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveObservation +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveRootAwarePrivate +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveLift +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveAfterRoot +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalize +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizeSupport +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizeLift +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizeStructural +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedAfterRoot +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedResolved +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedSigner +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedSignerStrong +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveRootAwarePrivateStrong +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveReverse +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveEndpoint +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProbability +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProduction +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionNormalize +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionNormalizeLift +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommon +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonLift +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonExperiment +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonFactorization +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonPeekFree +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonCache +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonCacheLift +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonSampling +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonSelectionSampling +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonization +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionAggregation +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionOrdinal +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceProbability +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceNonRootProbability +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedFiber +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedComparison +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedProbability +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedCoupling +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootClosed +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceAssembly +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryFinalAssembly +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootJoint +import SphincsSecurity.Proof.OtsProbeGroupedTerminal +import SphincsSecurity.Proof.OtsProbeCanonicalPrivateEndpoint +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryWitnessCoverage +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryWitnessLift +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryWitnessEndpoint +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryWitnessDomination +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryWitnessOrdinary +import SphincsSecurity.Proof.OtsProbeBoundaryCompletion +import SphincsSecurity.Proof.FewTimeHonestLeakBound +import SphincsSecurity.Proof.TightChargeTerminal +import SphincsSecurity.Proof.Security125Endpoint +import SphincsSecurity.Proof.Security125Completion +import SphincsSecurity.Proof.TightEncodingQueryTerminal +import SphincsSecurity.Proof.OtsProbeRootBudget +import SphincsSecurity.Proof.OtsProbeSuccessfulHiddenCharge +import SphincsSecurity.Proof.OtsProbeJointPreloadCoupling +import SphincsSecurity.Proof.OtsProbeSelectionPending +import SphincsSecurity.Proof.OtsProbeEncodingPrehitViewed +import SphincsSecurity.Proof.EncodingPrehitViewedBound +import SphincsSecurity.Proof.OtsProbeRootCacheTransport +import SphincsSecurity.Proof.OtsProbeResolvedComputedCoupling +import SphincsSecurity.Proof.OtsProbePrehitOpeningProjection +import SphincsSecurity.Proof.OtsProbeCanonicalPendingHit +import SphincsSecurity.Proof.OtsProbeRecursiveRejectionRisk +import SphincsSecurity.Proof.OtsProbeProbeFreeRisk +import SphincsSecurity.Proof.OtsProbeHashRisk +import SphincsSecurity.Proof.OtsProbeFreshGuessRisk +import SphincsSecurity.Proof.OtsProbeRetainedGuessCharge +import SphincsSecurity.Proof.OtsProbeGuardedTraceRisk +import SphincsSecurity.Proof.OtsProbeStartCandidateMiss +import SphincsSecurity.Proof.OtsProbeStartHistorySampling +import SphincsSecurity.Proof.OtsProbeHistoryCompletionInterpreter +import SphincsSecurity.Proof.OtsProbeHistoryCandidateSampling +import SphincsSecurity.Proof.OtsProbeHistoryAdaptiveInterpreter +import SphincsSecurity.Proof.OtsProbeHistoryPrefixRisk +import SphincsSecurity.Proof.OtsProbeHistoryLiveRisk +import SphincsSecurity.Proof.OtsProbeHistoryCanonicalBoundary +import SphincsSecurity.Proof.OtsProbeHistoryQueryPrefix +import SphincsSecurity.Proof.OtsProbeHistoryOuterComposition +import SphincsSecurity.Proof.OtsProbeHistoryCanonicalRisk +import SphincsSecurity.Proof.OtsProbeHashCutRisk +import SphincsSecurity.Proof.OtsProbeHashCutCharge +import SphincsSecurity.Proof.OtsProbeHashCutReserve +import SphincsSecurity.Proof.OtsProbeCandidateRiskComponents +import SphincsSecurity.Proof.OtsProbePrivateValueCut +import SphincsSecurity.Proof.OtsProbePrivateValueFirstAccessCharge +import SphincsSecurity.Proof.OtsProbePrivateValueMaterializedCommutation +import SphincsSecurity.Proof.OtsProbePrivateValueLiveCut +import SphincsSecurity.Proof.OtsProbePrivateValueFirstAccessTransport +import SphincsSecurity.Proof.OtsProbePrivateValueProbeHistory +import SphincsSecurity.Proof.OtsProbePrivateValueProbeRisk +import SphincsSecurity.Proof.OtsProbePrivateValueProbeTransport +import SphincsSecurity.Proof.OtsProbePrivateValueRawProbeRisk +import SphincsSecurity.Proof.OtsProbeNativeQueryCharge +import SphincsSecurity.Proof.OtsProbeLiveNativeReserve +import SphincsSecurity.Proof.OtsProbePrivateValueLiveProbeCut +import SphincsSecurity.Proof.OtsProbeLiveNativeComposition +import SphincsSecurity.Proof.OtsProbeLiveJointCharge +import SphincsSecurity.Proof.OtsProbeLiveJointReserve +import SphincsSecurity.Proof.OtsProbeLiveSampledReserve +import SphincsSecurity.Proof.OtsProbeLiveStartCut +import SphincsSecurity.Proof.OtsProbeLiveStartCounting +import SphincsSecurity.Proof.OtsProbeLiveGameCharge +import SphincsSecurity.Proof.OtsProbeEnsuredInitialization +import SphincsSecurity.Proof.OtsProbeInitializedGameCharge +import SphincsSecurity.Proof.OtsProbeNativeRootReserve +import SphincsSecurity.Proof.OtsProbeNativeRootQueryCharge +import SphincsSecurity.Proof.OtsProbeLiveContextCharge +import SphincsSecurity.Proof.OtsProbeLiveKnownRootCharge +import SphincsSecurity.Proof.OtsProbeInitializedKnownRootCharge +import SphincsSecurity.Proof.OtsProbeLiveHashSelection +import SphincsSecurity.Proof.OtsProbeLiveHashCut +import SphincsSecurity.Proof.OtsProbeInitializedRootSelection +import SphincsSecurity.Proof.OtsProbeSettledNativeValue +import SphincsSecurity.Proof.OtsProbeNativeRootSource +import SphincsSecurity.Proof.OtsProbeRootSourceTrace +import SphincsSecurity.Proof.OtsProbeKnownRootTraceSource +import SphincsSecurity.Proof.OtsProbeNativeRootEncoding +import SphincsSecurity.Proof.OtsProbeNativeRootCache +import SphincsSecurity.Proof.OtsProbeNativeStoredRoot +import SphincsSecurity.Proof.OtsProbeNativeRootSigner +import SphincsSecurity.Proof.OtsProbeNativeChronologicalRootSigner +import SphincsSecurity.Proof.OtsProbeNativeValueReplacement +import SphincsSecurity.Proof.OtsProbeNativeValueCompletion +import SphincsSecurity.Proof.OtsProbeNativeValueResolver +import SphincsSecurity.Proof.OtsProbeNativeValueMaterialization +import SphincsSecurity.Proof.OtsProbeNativeValueObservation +import SphincsSecurity.Proof.OtsProbeNativeRootState +import SphincsSecurity.Proof.OtsProbeNativeRootStateCoupling +import SphincsSecurity.Proof.OtsProbeNativeRootStateSigner +import SphincsSecurity.Proof.OtsProbeNativeRootStateChronological +import SphincsSecurity.Proof.OtsProbeNativeRootSwap +import SphincsSecurity.Proof.OtsProbeNativeOrdinaryCache +import SphincsSecurity.Proof.OtsProbeNativeOrdinaryCacheSigner +import SphincsSecurity.Proof.OtsProbeNativeRootSwapOrdinaryCache +import SphincsSecurity.Proof.OtsProbeNativeOrdinaryCacheHash +import SphincsSecurity.Proof.OtsProbeNativeOrdinaryCacheSelection +import SphincsSecurity.Proof.OtsProbeNativeQueryTrace +import SphincsSecurity.Proof.OtsProbeNativeQueryTraceCoupling +import SphincsSecurity.Proof.OtsProbeNativeQueryTraceSource +import SphincsSecurity.Proof.OtsProbeNativeQueryTraceSelection +import SphincsSecurity.Proof.OtsProbeNativeQueryTraceProjection +import SphincsSecurity.Proof.OtsProbeNativePeekInput +import SphincsSecurity.Proof.OtsProbeNativeRootInputObservation +import SphincsSecurity.Proof.OtsProbeNativePlannedReserve +import SphincsSecurity.Proof.OtsProbeNativePlannedReserveComposition +import SphincsSecurity.Proof.OtsProbeNativeStoredRootStructuralCharge +import SphincsSecurity.Proof.OtsProbeNativeRootJointReserve +import SphincsSecurity.Proof.OtsProbeNativeRootProbe +import SphincsSecurity.Proof.OtsProbeNativeRootHashInput +import SphincsSecurity.Proof.OtsProbeNativeRootEncodingHash +import SphincsSecurity.Proof.OtsProbeNativeRootHashAction +import SphincsSecurity.Proof.OtsProbeNativeRootHashPlan +import SphincsSecurity.Proof.OtsProbeNativeRootSwapHash +import SphincsSecurity.Proof.OtsProbeNativeRootSwapStep +import SphincsSecurity.Proof.OtsProbeNativeOuterCut +import SphincsSecurity.Proof.OtsProbeNativeRootOuterCut +import SphincsSecurity.Proof.OtsProbeNativeRootOuterCutStop +import SphincsSecurity.Proof.OtsProbeNativeRootUnsafeAction +import SphincsSecurity.Proof.OtsProbeNativeRootExposure +import SphincsSecurity.Proof.OtsProbeNativeStructuralRootGuess +import SphincsSecurity.Proof.OtsProbeNativeRootCandidate +import SphincsSecurity.Proof.OtsProbeNativeRootCandidateHistory +import SphincsSecurity.Proof.OtsProbeNativeRootTraceSafety +import SphincsSecurity.Proof.OtsProbeNativeRootCompatibleTrace +import SphincsSecurity.Proof.OtsProbeNativeRootTraceCoupling +import SphincsSecurity.Proof.OtsProbeNativeRootRecordLikelihood +import SphincsSecurity.Proof.OtsProbeNativeRootTraceOrdinaryCache +import SphincsSecurity.Proof.OtsProbeNativeStoredRootRecords +import SphincsSecurity.Proof.OtsProbeNativeStoredRootRisk +import SphincsSecurity.Proof.OtsProbeNativeRootCandidateNormalization +import SphincsSecurity.Proof.OtsProbeNativeStoredRootCutRisk +import SphincsSecurity.Proof.OtsProbeNativeResolvedRootCutRisk +import SphincsSecurity.Proof.OtsProbeNativeRootMaterialization +import SphincsSecurity.Proof.OtsProbeNativeComputedRootMaterialization +import SphincsSecurity.Proof.OtsProbeMaterializedRootCharge +import SphincsSecurity.Proof.OtsProbeRootMaterializationExecution +import SphincsSecurity.Proof.OtsProbeRootMaterializationHash +import SphincsSecurity.Proof.OtsProbeRootMaterializationSigner +import SphincsSecurity.Proof.OtsProbeRootMaterializationChronological +import SphincsSecurity.Proof.OtsProbeMaterializedRootReserve +import SphincsSecurity.Proof.OtsProbeNativeRootHistoryObserver +import SphincsSecurity.Proof.OtsProbeNativeRootHistoryTraceSampling +import SphincsSecurity.Proof.OtsProbeChargedRootCut +import SphincsSecurity.Proof.OtsProbeChargedRootObservation +import SphincsSecurity.Proof.OtsProbeNativeTraceStoredRoot +import SphincsSecurity.Proof.OtsProbeChargedRootCutRisk +import SphincsSecurity.Proof.OtsProbeChargedRootAdaptiveRisk +import SphincsSecurity.Proof.OtsProbeChargedRootOccurrence +import SphincsSecurity.Proof.OtsProbeChargedRootInitialization +import SphincsSecurity.Proof.OtsProbeInitializedChargedRootRisk +import SphincsSecurity.Proof.OtsProbeChargedRootSelection +import SphincsSecurity.Proof.OtsProbeChargedRootSelectionProjection +import SphincsSecurity.Proof.OtsProbeChargedRootCounting +import SphincsSecurity.Proof.OtsProbeChargedRootGlobalRisk +import SphincsSecurity.Proof.OtsProbeInitializedChargedRootGlobalRisk +import SphincsSecurity.Proof.OtsProbeInitializedChargedRootReserve +import SphincsSecurity.Proof.OtsProbeInitializedJointRootRisk +import SphincsSecurity.Proof.OtsProbeSampledJointRootRisk +import SphincsSecurity.Proof.OtsProbeNativeTraceCompletion +import SphincsSecurity.Proof.OtsProbeNativeRootFirstMatch +import SphincsSecurity.Proof.OtsProbeNativeHashHistorySelection +import SphincsSecurity.Proof.OtsProbeNativeRootHitProjection +import SphincsSecurity.Proof.OtsProbeNativeRejectionProbability +import SphincsSecurity.Proof.OtsProbeNativeRiskAccumulation +import SphincsSecurity.Proof.OtsProbeNativeCandidateRisk +import SphincsSecurity.Proof.OtsProbePrivateAllowanceCounting +import SphincsSecurity.Proof.OtsProbePrivateAllowanceCut +import SphincsSecurity.Proof.OtsProbePrivateAllowanceHit +import SphincsSecurity.Proof.OtsProbePrivateAllowanceReserve +import SphincsSecurity.Proof.OtsProbeNativeMaterializedCandidate +import SphincsSecurity.Proof.OtsProbeNativeChainMaterialization +import SphincsSecurity.Proof.OtsProbeSigningChainValues +import SphincsSecurity.Proof.OtsProbeSigningChainPublication +import SphincsSecurity.Proof.OtsProbeSigningChainFailureCoupling +import SphincsSecurity.Proof.OtsProbeNativeChainQuery +import SphincsSecurity.Proof.OtsProbeNativeChainTrace +import SphincsSecurity.Proof.OtsProbeNativeChainBound +import SphincsSecurity.Proof.OtsProbePrivateInactive +import SphincsSecurity.Proof.OtsProbePrivateMissingAllowance +import SphincsSecurity.Proof.OtsProbePrivateMissingComposition +import SphincsSecurity.Proof.OtsProbePrivateMissingHash +import SphincsSecurity.Proof.OtsProbeNativeMissingStructuralCharge +import SphincsSecurity.Proof.OtsProbeStartAllowance +import SphincsSecurity.Proof.OtsProbeStartAllowanceCounting +import SphincsSecurity.Proof.OtsProbeStartAllowanceComposition +import SphincsSecurity.Proof.OtsProbeStartAllowanceHash +import SphincsSecurity.Proof.OtsProbeNativeStartCharge +import SphincsSecurity.Proof.OtsProbeNativeCandidateComponents +import SphincsSecurity.Proof.OtsProbeNativeMaterializedAllowance +import SphincsSecurity.Proof.OtsProbeNativeSupportedBudget +import SphincsSecurity.Proof.OtsProbeNativeTraceSafety +import SphincsSecurity.Proof.OtsProbeNativeSupportedAllowances +import SphincsSecurity.Proof.OtsProbeNativeSupportedRootProjection +import SphincsSecurity.Proof.OtsProbeNativeSupportedRootReserve +import SphincsSecurity.Proof.OtsProbeLiveResolvedBudget +import SphincsSecurity.Proof.OtsProbeNativeLiveBudget +import SphincsSecurity.Proof.OtsProbeLiveStartAllowanceCounting +import SphincsSecurity.Proof.OtsProbeLivePrivateAllowanceCounting +import SphincsSecurity.Proof.OtsProbeNativeLiveAllowanceReserve +import SphincsSecurity.Proof.OtsProbeNativeAfterRootAllowance +import SphincsSecurity.Proof.OtsProbeNativeAfterRootRisk +import SphincsSecurity.Proof.OtsProbeNativeTerminalReserve +import SphincsSecurity.Proof.OtsProbeNativeTerminalExperiment +import SphincsSecurity.Proof.OtsProbeSigningStartValues +import SphincsSecurity.Proof.OtsProbeSigningFailureCoupling +import SphincsSecurity.Proof.OtsProbeStartErasureBound +import SphincsSecurity.Proof.EncodingExhaustionProbability +import SphincsSecurity.Proof.EncodingExhaustionBound +import SphincsSecurity.Proof.EncodingSigningFailure +import SphincsSecurity.Proof.Security126Completion +import SphincsSecurity.Proof.JointNativeQueryCharge +import SphincsSecurity.Proof.FewTimeParametricSignerRace + +/-! +The proof of `SphincsSecurityStatement`. The specification to review is `SphincsSecurity/Statement.lean`; the Lean kernel checks the proof against it. + +What is proven so far is correctness: `Correctness.eval_verify` says `Ver` accepts a signature built +from the secrets, under an arbitrary answer function rather than under the lazy oracle. That is the +form the reduction needs, the random oracle's support being characterized by total answer functions, +and it is what rules out the statement holding vacuously for want of an accepting run. + +`Bytes.tweakBytes_injective` is the other half of the foundation: a tweak names one structural +position, so one query bears on one position and an inversion stays at `2^-n` per query with no +multi-target factor. `Amortized.probEvent_bad_le_amortized` is what turns that into a bound on a +run: it is the only probabilistic argument the reduction makes, and `README.md` explains the shape +it imposes on everything else. +-/ diff --git a/formal/sphincs/SphincsSecurity/Proof/AdaptiveRevealProbe.lean b/formal/sphincs/SphincsSecurity/Proof/AdaptiveRevealProbe.lean new file mode 100644 index 00000000..94a6b7ba --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/AdaptiveRevealProbe.lean @@ -0,0 +1,1422 @@ +import SphincsSecurity.Proof.SecretProbe +import VCVio.OracleComp.QueryTracking.RandomOracle.DeferredSampling + +/-! +# Adaptive probes with selective reveals + +A strategy may reveal table cells and use their values in later probes. A probe against a cell that +has already been revealed is harmless. Every probe against a still-hidden cell adds one candidate, +and revealing that cell or ending the computation tests all accumulated candidates at once. The +total hit probability is therefore at most the number of probes divided by the table range size. +-/ + +namespace SphincsSecurity.AdaptiveRevealProbe + +open OracleComp OracleSpec ENNReal + +variable {Coordinate : Type} [Fintype Coordinate] [DecidableEq Coordinate] + +structure State (Coordinate : Type) where + pending : Coordinate → Finset Digest + revealed : Coordinate → Option Digest + +def State.pendingCount (state : State Coordinate) : Nat := + ∑ coordinate, (state.pending coordinate).card + +def State.addPending (state : State Coordinate) (coordinate : Coordinate) + (candidate : Digest) : State Coordinate := + { state with pending := Function.update state.pending coordinate (insert candidate (state.pending coordinate)) } + +def State.install (state : State Coordinate) (coordinate : Coordinate) + (value : Digest) : State Coordinate := + { pending := Function.update state.pending coordinate ∅ + revealed := Function.update state.revealed coordinate (some value) } + +def State.empty : State Coordinate := + { pending := fun _ => ∅ + revealed := fun _ => none } + +theorem State.pendingCount_addPending_le (state : State Coordinate) + (coordinate : Coordinate) (candidate : Digest) : + (state.addPending coordinate candidate).pendingCount ≤ state.pendingCount + 1 := by + classical + unfold pendingCount addPending + change (∑ other, + (Function.update state.pending coordinate + (insert candidate (state.pending coordinate)) other).card) ≤ _ + have hupdate : + (fun other => + (Function.update state.pending coordinate + (insert candidate (state.pending coordinate)) other).card) = + Function.update (fun other => (state.pending other).card) coordinate + (insert candidate (state.pending coordinate)).card := by + funext other + by_cases heq : other = coordinate <;> simp [heq] + rw [hupdate, Finset.sum_update_of_mem (Finset.mem_univ coordinate)] + have hsum := Finset.sum_erase_add Finset.univ + (fun other => (state.pending other).card) (Finset.mem_univ coordinate) + calc + (insert candidate (state.pending coordinate)).card + + ∑ other ∈ Finset.univ \ {coordinate}, (state.pending other).card ≤ + ((state.pending coordinate).card + 1) + + ∑ other ∈ Finset.univ \ {coordinate}, (state.pending other).card := by + gcongr + exact Finset.card_insert_le candidate (state.pending coordinate) + _ = (∑ other ∈ Finset.univ \ {coordinate}, (state.pending other).card) + + (state.pending coordinate).card + 1 := by omega + _ = (∑ other, (state.pending other).card) + 1 := by + rw [Finset.sdiff_singleton_eq_erase, hsum] + +theorem State.pendingCount_install_add (state : State Coordinate) + (coordinate : Coordinate) (value : Digest) : + (state.install coordinate value).pendingCount + + (state.pending coordinate).card = state.pendingCount := by + classical + unfold pendingCount install + change (∑ other, + (Function.update state.pending coordinate ∅ other).card) + + (state.pending coordinate).card = _ + have hupdate : + (fun other => (Function.update state.pending coordinate ∅ other).card) = + Function.update (fun other => (state.pending other).card) coordinate 0 := by + funext other + by_cases heq : other = coordinate <;> simp [heq] + rw [hupdate, Finset.sum_update_of_mem (Finset.mem_univ coordinate), zero_add, + Finset.sdiff_singleton_eq_erase] + exact Finset.sum_erase_add Finset.univ + (fun other => (state.pending other).card) (Finset.mem_univ coordinate) + +omit [DecidableEq Coordinate] in +@[simp] theorem State.pendingCount_empty : + (State.empty : State Coordinate).pendingCount = 0 := by + simp [State.empty, State.pendingCount] + +def State.Valid (state : State Coordinate) : Prop := + ∀ coordinate value, state.revealed coordinate = some value → + state.pending coordinate = ∅ + +omit [Fintype Coordinate] [DecidableEq Coordinate] in +theorem State.valid_empty : (State.empty : State Coordinate).Valid := by + intro coordinate value hvalue + simp [State.empty] at hvalue + +omit [Fintype Coordinate] in +theorem State.Valid.addPending {state : State Coordinate} (hvalid : state.Valid) + (coordinate : Coordinate) (candidate : Digest) + (hhidden : state.revealed coordinate = none) : + (state.addPending coordinate candidate).Valid := by + intro other value hvalue + by_cases heq : other = coordinate + · subst other + simp [State.addPending, hhidden] at hvalue + · simpa [State.addPending, Function.update_of_ne heq] using + hvalid other value hvalue + +omit [Fintype Coordinate] in +theorem State.Valid.install {state : State Coordinate} (hvalid : state.Valid) + (coordinate : Coordinate) (value : Digest) : + (state.install coordinate value).Valid := by + intro other otherValue hvalue + by_cases heq : other = coordinate + · subst other + simp [State.install] + · have hvalue' : state.revealed other = some otherValue := by + simpa [State.install, Function.update_of_ne heq] using hvalue + simpa [State.install, Function.update_of_ne heq] using + hvalid other otherValue hvalue' + +def extendTable (state : State Coordinate) (base : Coordinate → Digest) : + Coordinate → Digest := + fun coordinate => (state.revealed coordinate).getD (base coordinate) + +omit [Fintype Coordinate] in +theorem extendTable_update_eq_install (state : State Coordinate) + (coordinate : Coordinate) (value : Digest) (base : Coordinate → Digest) + (hhidden : state.revealed coordinate = none) : + extendTable state (Function.update base coordinate value) = + extendTable (state.install coordinate value) base := by + funext other + by_cases heq : other = coordinate + · subst other + simp [extendTable, State.install, hhidden] + · simp [extendTable, State.install, Function.update_of_ne heq] + +def tableHits (state : State Coordinate) (table : Coordinate → Digest) : Bool := + decide (∃ coordinate, table coordinate ∈ state.pending coordinate) + +theorem tableHits_addPending_eq_false (state : State Coordinate) + (table : Coordinate → Digest) (coordinate : Coordinate) (candidate : Digest) + (hclean : tableHits state table = false) + (hmiss : table coordinate ≠ candidate) : + tableHits (state.addPending coordinate candidate) table = false := by + classical + unfold tableHits at hclean ⊢ + simp only [decide_eq_false_iff_not] at hclean ⊢ + rintro ⟨other, hmem⟩ + by_cases heq : other = coordinate + · subst other + simp only [State.addPending, Function.update_self, Finset.mem_insert] at hmem + exact hmem.elim hmiss (fun hold => hclean ⟨coordinate, hold⟩) + · simp only [State.addPending, Function.update_of_ne heq] at hmem + exact hclean ⟨other, hmem⟩ + +theorem tableHits_addPending_eq_true (state : State Coordinate) + (table : Coordinate → Digest) (coordinate : Coordinate) (candidate : Digest) + (hhit : table coordinate = candidate) : + tableHits (state.addPending coordinate candidate) table = true := by + classical + rw [tableHits, decide_eq_true_eq] + exact ⟨coordinate, by simp [State.addPending, hhit]⟩ + +omit [DecidableEq Coordinate] in +theorem not_mem_pending_of_tableHits_eq_false (state : State Coordinate) + (table : Coordinate → Digest) (coordinate : Coordinate) + (hclean : tableHits state table = false) : + table coordinate ∉ state.pending coordinate := by + intro hmem + unfold tableHits at hclean + rw [decide_eq_false_iff_not] at hclean + exact hclean ⟨coordinate, hmem⟩ + +theorem tableHits_install_eq_false (state : State Coordinate) + (table : Coordinate → Digest) (coordinate : Coordinate) (value : Digest) + (hclean : tableHits state table = false) : + tableHits (state.install coordinate value) table = false := by + classical + unfold tableHits at hclean ⊢ + simp only [decide_eq_false_iff_not] at hclean ⊢ + rintro ⟨other, hmem⟩ + by_cases heq : other = coordinate + · subst other + simp [State.install] at hmem + · simp only [State.install, Function.update_of_ne heq] at hmem + exact hclean ⟨other, hmem⟩ + +omit [DecidableEq Coordinate] in +theorem tableHits_extendTable_eq_true_iff (state : State Coordinate) + (hvalid : state.Valid) (base : Coordinate → Digest) : + tableHits state (extendTable state base) = true ↔ + ∃ coordinate ∈ (Finset.univ : Finset Coordinate), + ∃ candidate ∈ state.pending coordinate, base coordinate = candidate := by + simp only [tableHits, decide_eq_true_eq, Finset.mem_univ, true_and] + constructor + · rintro ⟨coordinate, hmem⟩ + have hhidden : state.revealed coordinate = none := by + cases hvalue : state.revealed coordinate with + | none => rfl + | some value => + have hempty := hvalid coordinate value hvalue + rw [hempty] at hmem + simp at hmem + exact ⟨coordinate, extendTable state base coordinate, hmem, by + simp [extendTable, hhidden]⟩ + · rintro ⟨coordinate, candidate, hcandidate, heq⟩ + have hhidden : state.revealed coordinate = none := by + cases hvalue : state.revealed coordinate with + | none => rfl + | some value => + have hempty := hvalid coordinate value hvalue + rw [hempty] at hcandidate + simp at hcandidate + exact ⟨coordinate, by simpa [extendTable, hhidden, heq] using hcandidate⟩ + +noncomputable local instance sampleableDigest : SampleableType Digest := + SampleableType.ofFintype Digest + +@[implicit_reducible] noncomputable def tableSampleableType : + SampleableType (Coordinate → Digest) := + SampleableType.ofFintype (Coordinate → Digest) + +noncomputable local instance sampleableTable : SampleableType (Coordinate → Digest) := + tableSampleableType + +noncomputable def sampleTable : ProbComp (Coordinate → Digest) := + $ᵗ (Coordinate → Digest) + +theorem uniformDigest_mem_finset_le (candidates : Finset Digest) : + Pr[fun value : Digest => value ∈ candidates | ($ᵗ Digest : ProbComp Digest)] ≤ + (candidates.card : ℝ≥0∞) * + ((Fintype.card Digest : Nat) : ℝ≥0∞)⁻¹ := by + calc + Pr[fun value : Digest => value ∈ candidates | ($ᵗ Digest : ProbComp Digest)] = + Pr[fun value : Digest => ∃ candidate ∈ candidates, value = candidate | + ($ᵗ Digest : ProbComp Digest)] := by + apply probEvent_congr' (fun value _ => by simp) rfl + _ ≤ ∑ candidate ∈ candidates, + Pr[fun value : Digest => value = candidate | ($ᵗ Digest : ProbComp Digest)] := + probEvent_exists_finset_le_sum candidates ($ᵗ Digest) + (fun candidate value => value = candidate) + _ = ∑ _candidate ∈ candidates, + ((Fintype.card Digest : Nat) : ℝ≥0∞)⁻¹ := by + apply Finset.sum_congr rfl + intro candidate _ + simp only [probEvent_eq_eq_probOutput, probOutput_uniformSample] + _ = (candidates.card : ℝ≥0∞) * + ((Fintype.card Digest : Nat) : ℝ≥0∞)⁻¹ := by + rw [Finset.sum_const, nsmul_eq_mul] + +theorem finalize_probability_le [Nonempty Coordinate] + (state : State Coordinate) (hvalid : state.Valid) : + Pr[fun hit : Bool => hit = true | + (fun base : Coordinate → Digest => tableHits state (extendTable state base)) <$> + sampleTable] ≤ + (state.pendingCount : ℝ≥0∞) * + ((Fintype.card Digest : Nat) : ℝ≥0∞)⁻¹ := by + rw [probEvent_map] + change Pr[fun base : Coordinate → Digest => + tableHits state (extendTable state base) = true | sampleTable] ≤ _ + have hevent : + (fun base : Coordinate → Digest => + tableHits state (extendTable state base) = true) = + (fun base : Coordinate → Digest => + ∃ coordinate ∈ (Finset.univ : Finset Coordinate), + ∃ candidate ∈ state.pending coordinate, base coordinate = candidate) := by + funext base + exact propext (tableHits_extendTable_eq_true_iff state hvalid base) + rw [hevent] + calc + Pr[fun base : Coordinate → Digest => + ∃ coordinate ∈ (Finset.univ : Finset Coordinate), + ∃ candidate ∈ state.pending coordinate, base coordinate = candidate | + sampleTable] ≤ + ∑ coordinate ∈ (Finset.univ : Finset Coordinate), + Pr[fun base : Coordinate → Digest => + ∃ candidate ∈ state.pending coordinate, base coordinate = candidate | + sampleTable] := + probEvent_exists_finset_le_sum Finset.univ sampleTable + (fun coordinate base => + ∃ candidate ∈ state.pending coordinate, base coordinate = candidate) + _ ≤ ∑ coordinate ∈ (Finset.univ : Finset Coordinate), + ((state.pending coordinate).card : ℝ≥0∞) * + ((Fintype.card Digest : Nat) : ℝ≥0∞)⁻¹ := by + apply Finset.sum_le_sum + intro coordinate _ + calc + Pr[fun base : Coordinate → Digest => + ∃ candidate ∈ state.pending coordinate, base coordinate = candidate | + sampleTable] ≤ + ∑ candidate ∈ state.pending coordinate, + Pr[fun base : Coordinate → Digest => base coordinate = candidate | + sampleTable] := + probEvent_exists_finset_le_sum (state.pending coordinate) sampleTable + (fun candidate base => base coordinate = candidate) + _ = ∑ _candidate ∈ state.pending coordinate, + ((Fintype.card Digest : Nat) : ℝ≥0∞)⁻¹ := by + apply Finset.sum_congr rfl + intro candidate _ + exact SphincsSecurity.uniform_function_coordinate_probability coordinate candidate + _ = ((state.pending coordinate).card : ℝ≥0∞) * + ((Fintype.card Digest : Nat) : ℝ≥0∞)⁻¹ := by + rw [Finset.sum_const, nsmul_eq_mul] + _ = (state.pendingCount : ℝ≥0∞) * + ((Fintype.card Digest : Nat) : ℝ≥0∞)⁻¹ := by + rw [← Finset.sum_mul] + congr 1 + simp [State.pendingCount] + +theorem evalDist_sampleTable_eq_bind_update (coordinate : Coordinate) + (continuation : (Coordinate → Digest) → ProbComp alpha) : + 𝒟[sampleTable >>= continuation] = + 𝒟[do + let value ← ($ᵗ Digest : ProbComp Digest) + let base ← sampleTable + continuation (Function.update base coordinate value)] := by + unfold sampleTable + calc + 𝒟[($ᵗ (Coordinate → Digest) : ProbComp (Coordinate → Digest)) >>= continuation] = + 𝒟[(do + let value ← ($ᵗ Digest : ProbComp Digest) + let base ← ($ᵗ (Coordinate → Digest) : ProbComp (Coordinate → Digest)) + pure (Function.update base coordinate value)) >>= continuation] := by + rw [evalDist_bind, evalDist_bind, evalDist_uniformSample_bind_update coordinate] + _ = _ := by simp [bind_assoc] + +inductive Query (Coordinate : Type) where + | uniform (n : Nat) + | hashOutput + | probe (coordinate : Coordinate) (candidate : Digest) + | reveal (coordinate : Coordinate) + +@[reducible] def World (Coordinate : Type) : OracleSpec (Query Coordinate) := + OracleSpec.ofFn fun + | .uniform n => Fin (n + 1) + | .hashOutput => HashOutput + | .probe _ _ => Unit + | .reveal _ => Digest + +def IsProbe : (World Coordinate).Domain → Prop + | .uniform _ => False + | .hashOutput => False + | .probe _ _ => True + | .reveal _ => False + +def IsStateful : (World Coordinate).Domain → Prop + | .uniform _ => False + | .hashOutput => False + | .probe _ _ => True + | .reveal _ => True + +noncomputable instance : DecidablePred (IsProbe (Coordinate := Coordinate)) := + fun input => match input with + | .uniform _ => isFalse (by simp [IsProbe]) + | .hashOutput => isFalse (by simp [IsProbe]) + | .probe _ _ => isTrue (by simp [IsProbe]) + | .reveal _ => isFalse (by simp [IsProbe]) + +noncomputable instance : DecidablePred (IsStateful (Coordinate := Coordinate)) := + fun input => match input with + | .uniform _ => isFalse (by simp [IsStateful]) + | .hashOutput => isFalse (by simp [IsStateful]) + | .probe _ _ => isTrue (by simp [IsStateful]) + | .reveal _ => isTrue (by simp [IsStateful]) + +def uniformQuery (n : Nat) : OracleComp (World Coordinate) (Fin (n + 1)) := + liftM ((World Coordinate).query (.uniform n)) + +def hashOutputQuery : OracleComp (World Coordinate) HashOutput := + liftM ((World Coordinate).query .hashOutput) + +noncomputable def sampleHashOutput : ProbComp HashOutput := + uniformSampleImpl (spec := HashSpec) ([] : HashInput) + +def probeQuery (coordinate : Coordinate) (candidate : Digest) : + OracleComp (World Coordinate) Unit := + liftM ((World Coordinate).query (.probe coordinate candidate)) + +def revealQuery (coordinate : Coordinate) : OracleComp (World Coordinate) Digest := + liftM ((World Coordinate).query (.reveal coordinate)) + +def uniformForwardImpl : QueryImpl unifSpec (OracleComp (World Coordinate)) := + fun n => uniformQuery n + +def liftProbComp (computation : ProbComp alpha) : OracleComp (World Coordinate) alpha := + simulateQ uniformForwardImpl computation + +omit [Fintype Coordinate] [DecidableEq Coordinate] in +theorem liftProbComp_isProbeBound (computation : ProbComp alpha) (fuel : Nat) : + (liftProbComp (Coordinate := Coordinate) computation).IsQueryBoundP IsProbe fuel := by + induction computation using OracleComp.inductionOn with + | pure result => trivial + | query_bind n next ih => + rw [liftProbComp, simulateQ_query_bind] + change (uniformQuery n >>= fun output => + liftProbComp (next output)).IsQueryBoundP IsProbe fuel + rw [uniformQuery, OracleComp.isQueryBoundP_query_bind_iff] + constructor + · simp [IsProbe] + · intro output + simpa [IsProbe] using ih output + +omit [Fintype Coordinate] [DecidableEq Coordinate] in +theorem probeQuery_isProbeBound (coordinate : Coordinate) (candidate : Digest) : + (probeQuery coordinate candidate).IsQueryBoundP IsProbe 1 := by + rw [probeQuery, OracleComp.isQueryBoundP_query_iff] + simp [IsProbe] + +omit [Fintype Coordinate] [DecidableEq Coordinate] in +theorem revealQuery_isProbeBound (coordinate : Coordinate) (fuel : Nat) : + (revealQuery coordinate).IsQueryBoundP IsProbe fuel := by + rw [revealQuery, OracleComp.isQueryBoundP_query_iff] + simp [IsProbe] + +omit [Fintype Coordinate] [DecidableEq Coordinate] in +theorem hashOutputQuery_isProbeBound (fuel : Nat) : + (hashOutputQuery (Coordinate := Coordinate)).IsQueryBoundP IsProbe fuel := by + rw [hashOutputQuery, OracleComp.isQueryBoundP_query_iff] + simp [IsProbe] + +noncomputable def run (table : Coordinate → Digest) (state : State Coordinate) + (fuel : Nat) (computation : OracleComp (World Coordinate) alpha) : ProbComp Bool := + OracleComp.construct + (C := fun _ => State Coordinate → Nat → ProbComp Bool) + (fun _ state _ => pure (tableHits state table)) + (fun input _next recursivelyRun state fuel => + match input with + | .uniform n => do + let output ← liftM (unifSpec.query n) + recursivelyRun output state fuel + | .hashOutput => do + let output ← liftM sampleHashOutput + recursivelyRun output state fuel + | .probe coordinate candidate => + match fuel with + | 0 => pure (tableHits state table) + | remaining + 1 => + match state.revealed coordinate with + | some _ => recursivelyRun () state remaining + | none => recursivelyRun () (state.addPending coordinate candidate) remaining + | .reveal coordinate => + match state.revealed coordinate with + | some value => recursivelyRun value state fuel + | none => + let value := table coordinate + if value ∈ state.pending coordinate then pure true + else recursivelyRun value (state.install coordinate value) fuel) + computation state fuel + +inductive DetailedResult (Coordinate : Type) (alpha : Type) where + | stopped (hit : Bool) + | done (hit : Bool) (state : State Coordinate) (value : alpha) + +def DetailedResult.hit : DetailedResult Coordinate alpha → Bool + | .stopped hit => hit + | .done hit _ _ => hit + +def DetailedResult.value? : DetailedResult Coordinate alpha → Option alpha + | .stopped _ => none + | .done _ _ value => some value + +inductive RawResult (Coordinate : Type) (alpha : Type) where + | stopped (hit : Bool) + | done (state : State Coordinate) (remaining : Nat) (value : alpha) + +def RawResult.finalize (table : Coordinate → Digest) : + RawResult Coordinate alpha → DetailedResult Coordinate alpha + | .stopped hit => .stopped hit + | .done state _ value => .done (tableHits state table) state value + +noncomputable def runRaw (table : Coordinate → Digest) (state : State Coordinate) + (fuel : Nat) (computation : OracleComp (World Coordinate) alpha) : + ProbComp (RawResult Coordinate alpha) := + OracleComp.construct + (C := fun _ : OracleComp (World Coordinate) alpha => + State Coordinate → Nat → ProbComp (RawResult Coordinate alpha)) + (fun result state remaining => pure (.done state remaining result)) + (fun input _next recursivelyRun state fuel => + match input with + | .uniform n => do + let output ← liftM (unifSpec.query n) + recursivelyRun output state fuel + | .hashOutput => do + let output ← liftM sampleHashOutput + recursivelyRun output state fuel + | .probe coordinate candidate => + match fuel with + | 0 => pure (.stopped (tableHits state table)) + | remaining + 1 => + match state.revealed coordinate with + | some _ => recursivelyRun () state remaining + | none => recursivelyRun () (state.addPending coordinate candidate) remaining + | .reveal coordinate => + match state.revealed coordinate with + | some value => recursivelyRun value state fuel + | none => + let value := table coordinate + if value ∈ state.pending coordinate then pure (.stopped true) + else recursivelyRun value (state.install coordinate value) fuel) + computation state fuel + +theorem runRaw_uniform_query_bind (table : Coordinate → Digest) + (state : State Coordinate) (fuel n : Nat) + (next : Fin (n + 1) → OracleComp (World Coordinate) alpha) : + runRaw table state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.uniform n)) : + OracleComp (World Coordinate) (Fin (n + 1))) >>= next) = (do + let output ← liftM (unifSpec.query n) + runRaw table state fuel (next output)) := by + rw [runRaw, OracleComp.construct_query_bind] + rfl + +theorem runRaw_hashOutput_query_bind (table : Coordinate → Digest) + (state : State Coordinate) (fuel : Nat) + (next : HashOutput → OracleComp (World Coordinate) alpha) : + runRaw table state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) .hashOutput) : + OracleComp (World Coordinate) HashOutput) >>= next) = (do + let output ← liftM sampleHashOutput + runRaw table state fuel (next output)) := by + rw [runRaw, OracleComp.construct_query_bind] + rfl + +theorem runRaw_probe_query_bind (table : Coordinate → Digest) + (state : State Coordinate) (fuel : Nat) (coordinate : Coordinate) + (candidate : Digest) (next : Unit → OracleComp (World Coordinate) alpha) : + runRaw table state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.probe coordinate candidate)) : + OracleComp (World Coordinate) Unit) >>= next) = + match fuel with + | 0 => pure (.stopped (tableHits state table)) + | remaining + 1 => + match state.revealed coordinate with + | some _ => runRaw table state remaining (next ()) + | none => runRaw table (state.addPending coordinate candidate) remaining (next ()) := by + rw [runRaw, OracleComp.construct_query_bind] + rfl + +theorem runRaw_reveal_query_bind (table : Coordinate → Digest) + (state : State Coordinate) (fuel : Nat) (coordinate : Coordinate) + (next : Digest → OracleComp (World Coordinate) alpha) : + runRaw table state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.reveal coordinate)) : + OracleComp (World Coordinate) Digest) >>= next) = + match state.revealed coordinate with + | some value => runRaw table state fuel (next value) + | none => + let value := table coordinate + if value ∈ state.pending coordinate then pure (.stopped true) + else runRaw table (state.install coordinate value) fuel (next value) := by + rw [runRaw, OracleComp.construct_query_bind] + rfl + +noncomputable def runDetailed (table : Coordinate → Digest) (state : State Coordinate) + (fuel : Nat) (computation : OracleComp (World Coordinate) alpha) : + ProbComp (DetailedResult Coordinate alpha) := + OracleComp.construct + (C := fun _ : OracleComp (World Coordinate) alpha => + State Coordinate → Nat → ProbComp (DetailedResult Coordinate alpha)) + (fun result state _ => pure (.done (tableHits state table) state result)) + (fun input _next recursivelyRun state fuel => + match input with + | .uniform n => do + let output ← liftM (unifSpec.query n) + recursivelyRun output state fuel + | .hashOutput => do + let output ← liftM sampleHashOutput + recursivelyRun output state fuel + | .probe coordinate candidate => + match fuel with + | 0 => pure (.stopped (tableHits state table)) + | remaining + 1 => + match state.revealed coordinate with + | some _ => recursivelyRun () state remaining + | none => recursivelyRun () (state.addPending coordinate candidate) remaining + | .reveal coordinate => + match state.revealed coordinate with + | some value => recursivelyRun value state fuel + | none => + let value := table coordinate + if value ∈ state.pending coordinate then pure (.stopped true) + else recursivelyRun value (state.install coordinate value) fuel) + computation state fuel + +theorem runDetailed_uniform_query_bind (table : Coordinate → Digest) + (state : State Coordinate) (fuel n : Nat) + (next : Fin (n + 1) → OracleComp (World Coordinate) alpha) : + runDetailed table state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.uniform n)) : + OracleComp (World Coordinate) (Fin (n + 1))) >>= next) = (do + let output ← liftM (unifSpec.query n) + runDetailed table state fuel (next output)) := by + rw [runDetailed, OracleComp.construct_query_bind] + rfl + +theorem runDetailed_hashOutput_query_bind (table : Coordinate → Digest) + (state : State Coordinate) (fuel : Nat) + (next : HashOutput → OracleComp (World Coordinate) alpha) : + runDetailed table state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) .hashOutput) : + OracleComp (World Coordinate) HashOutput) >>= next) = (do + let output ← liftM sampleHashOutput + runDetailed table state fuel (next output)) := by + rw [runDetailed, OracleComp.construct_query_bind] + rfl + +theorem runDetailed_probe_query_bind (table : Coordinate → Digest) + (state : State Coordinate) (fuel : Nat) (coordinate : Coordinate) + (candidate : Digest) (next : Unit → OracleComp (World Coordinate) alpha) : + runDetailed table state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.probe coordinate candidate)) : + OracleComp (World Coordinate) Unit) >>= next) = + match fuel with + | 0 => pure (.stopped (tableHits state table)) + | remaining + 1 => + match state.revealed coordinate with + | some _ => runDetailed table state remaining (next ()) + | none => runDetailed table (state.addPending coordinate candidate) remaining (next ()) := by + rw [runDetailed, OracleComp.construct_query_bind] + rfl + +theorem runDetailed_reveal_query_bind (table : Coordinate → Digest) + (state : State Coordinate) (fuel : Nat) (coordinate : Coordinate) + (next : Digest → OracleComp (World Coordinate) alpha) : + runDetailed table state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.reveal coordinate)) : + OracleComp (World Coordinate) Digest) >>= next) = + match state.revealed coordinate with + | some value => runDetailed table state fuel (next value) + | none => + let value := table coordinate + if value ∈ state.pending coordinate then pure (.stopped true) + else runDetailed table (state.install coordinate value) fuel (next value) := by + rw [runDetailed, OracleComp.construct_query_bind] + rfl + +theorem finalize_runRaw_eq_runDetailed (table : Coordinate → Digest) + (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) : + RawResult.finalize table <$> runRaw table state fuel computation = + runDetailed table state fuel computation := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + simp [runRaw, runDetailed, RawResult.finalize] + | query_bind input next ih => + cases input with + | uniform n => + rw [runRaw_uniform_query_bind, runDetailed_uniform_query_bind, map_bind] + apply bind_congr + intro output + exact ih output state fuel + | hashOutput => + rw [runRaw_hashOutput_query_bind, runDetailed_hashOutput_query_bind, map_bind] + apply bind_congr + intro output + exact ih output state fuel + | probe coordinate candidate => + rw [runRaw_probe_query_bind, runDetailed_probe_query_bind] + cases fuel with + | zero => simp [RawResult.finalize] + | succ remaining => + cases hrevealed : state.revealed coordinate with + | none => exact ih () (state.addPending coordinate candidate) remaining + | some value => exact ih () state remaining + | reveal coordinate => + rw [runRaw_reveal_query_bind, runDetailed_reveal_query_bind] + cases hrevealed : state.revealed coordinate with + | some value => exact ih value state fuel + | none => + by_cases hhit : table coordinate ∈ state.pending coordinate + · simp [hhit, RawResult.finalize] + · simp only [hhit, ↓reduceIte] + exact ih (table coordinate) (state.install coordinate (table coordinate)) fuel + +theorem runRaw_bind (table : Coordinate → Digest) (state : State Coordinate) + (fuel : Nat) (left : OracleComp (World Coordinate) alpha) + (next : alpha → OracleComp (World Coordinate) beta) : + runRaw table state fuel (left >>= next) = + runRaw table state fuel left >>= fun result => + match result with + | .stopped hit => pure (.stopped hit) + | .done finalState remaining value => + runRaw table finalState remaining (next value) := by + induction left using OracleComp.inductionOn generalizing state fuel with + | pure value => simp [runRaw] + | query_bind input continuation ih => + cases input with + | uniform n => + rw [bind_assoc, runRaw_uniform_query_bind, runRaw_uniform_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output state fuel + | hashOutput => + rw [bind_assoc, runRaw_hashOutput_query_bind, runRaw_hashOutput_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output state fuel + | probe coordinate candidate => + rw [bind_assoc, runRaw_probe_query_bind, runRaw_probe_query_bind] + cases fuel with + | zero => simp + | succ remaining => + cases hrevealed : state.revealed coordinate with + | none => exact ih () (state.addPending coordinate candidate) remaining + | some value => exact ih () state remaining + | reveal coordinate => + rw [bind_assoc, runRaw_reveal_query_bind, runRaw_reveal_query_bind] + cases hrevealed : state.revealed coordinate with + | some value => exact ih value state fuel + | none => + by_cases hhit : table coordinate ∈ state.pending coordinate + · simp [hhit] + · simp only [hhit, ↓reduceIte] + exact ih (table coordinate) (state.install coordinate (table coordinate)) fuel + +theorem exists_mem_support_runRaw_of_mem_runDetailed + (table : Coordinate → Digest) (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) + (result : DetailedResult Coordinate alpha) + (hresult : result ∈ support (runDetailed table state fuel computation)) : + ∃ rawResult ∈ support (runRaw table state fuel computation), + rawResult.finalize table = result := by + have hmapped : result ∈ support + (RawResult.finalize table <$> runRaw table state fuel computation) := by + rwa [finalize_runRaw_eq_runDetailed] + rw [support_map] at hmapped + exact hmapped + +theorem run_uniform_query_bind (table : Coordinate → Digest) (state : State Coordinate) + (fuel n : Nat) + (next : Fin (n + 1) → OracleComp (World Coordinate) alpha) : + run table state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.uniform n)) : + OracleComp (World Coordinate) (Fin (n + 1))) >>= next) = (do + let output ← liftM (unifSpec.query n) + run table state fuel (next output)) := by + rw [run, OracleComp.construct_query_bind] + rfl + +theorem run_probe_query_bind (table : Coordinate → Digest) (state : State Coordinate) + (fuel : Nat) (coordinate : Coordinate) (candidate : Digest) + (next : Unit → OracleComp (World Coordinate) alpha) : + run table state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.probe coordinate candidate)) : + OracleComp (World Coordinate) Unit) >>= next) = + match fuel with + | 0 => pure (tableHits state table) + | remaining + 1 => + match state.revealed coordinate with + | some _ => run table state remaining (next ()) + | none => run table (state.addPending coordinate candidate) remaining (next ()) := by + rw [run, OracleComp.construct_query_bind] + rfl + +theorem run_hashOutput_query_bind (table : Coordinate → Digest) (state : State Coordinate) + (fuel : Nat) (next : HashOutput → OracleComp (World Coordinate) alpha) : + run table state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) .hashOutput) : + OracleComp (World Coordinate) HashOutput) >>= next) = (do + let output ← liftM sampleHashOutput + run table state fuel (next output)) := by + rw [run, OracleComp.construct_query_bind] + rfl + +theorem run_reveal_query_bind (table : Coordinate → Digest) (state : State Coordinate) + (fuel : Nat) (coordinate : Coordinate) + (next : Digest → OracleComp (World Coordinate) alpha) : + run table state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.reveal coordinate)) : + OracleComp (World Coordinate) Digest) >>= next) = + match state.revealed coordinate with + | some value => run table state fuel (next value) + | none => + let value := table coordinate + if value ∈ state.pending coordinate then pure true + else run table (state.install coordinate value) fuel (next value) := by + rw [run, OracleComp.construct_query_bind] + rfl + +theorem runDetailed_hit_eq_run (table : Coordinate → Digest) + (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) : + DetailedResult.hit <$> runDetailed table state fuel computation = + run table state fuel computation := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure result => + simp [runDetailed, run, DetailedResult.hit] + | query_bind input next ih => + cases input with + | uniform n => + rw [runDetailed_uniform_query_bind, run_uniform_query_bind, + map_bind] + apply bind_congr + intro output + exact ih output _ _ + | hashOutput => + rw [runDetailed_hashOutput_query_bind, run_hashOutput_query_bind, + map_bind] + apply bind_congr + intro output + exact ih output _ _ + | probe coordinate candidate => + rw [runDetailed_probe_query_bind, run_probe_query_bind] + cases fuel with + | zero => simp [DetailedResult.hit] + | succ remaining => + cases hrevealed : state.revealed coordinate with + | none => exact ih () (state.addPending coordinate candidate) remaining + | some value => exact ih () state remaining + | reveal coordinate => + rw [runDetailed_reveal_query_bind, run_reveal_query_bind] + cases hrevealed : state.revealed coordinate with + | some value => exact ih value state fuel + | none => + by_cases hhit : table coordinate ∈ state.pending coordinate + · simp [hhit, DetailedResult.hit] + · simp only [hhit, ↓reduceIte] + exact ih (table coordinate) (state.install coordinate (table coordinate)) fuel + +theorem stopped_false_not_mem_support_runDetailed + (table : Coordinate → Digest) (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) + (hbound : computation.IsQueryBoundP IsProbe fuel) : + DetailedResult.stopped false ∉ support (runDetailed table state fuel computation) := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure result => + simp [runDetailed] + | query_bind input next ih => + rw [isQueryBoundP_query_bind_iff] at hbound + cases input with + | uniform n => + rw [runDetailed_uniform_query_bind, mem_support_bind_iff] + rintro ⟨output, houtput, hrest⟩ + exact ih output state fuel (hbound.2 output) hrest + | hashOutput => + rw [runDetailed_hashOutput_query_bind, mem_support_bind_iff] + rintro ⟨output, houtput, hrest⟩ + exact ih output state fuel (hbound.2 output) hrest + | probe coordinate candidate => + have hpositive : 0 < fuel := by + simpa [IsProbe] using hbound.1 + cases fuel with + | zero => omega + | succ remaining => + rw [runDetailed_probe_query_bind] + cases hrevealed : state.revealed coordinate with + | none => + exact ih () (state.addPending coordinate candidate) remaining + (by simpa [IsProbe] using hbound.2 ()) + | some value => + exact ih () state remaining (by simpa [IsProbe] using hbound.2 ()) + | reveal coordinate => + rw [runDetailed_reveal_query_bind] + cases hrevealed : state.revealed coordinate with + | some value => + exact ih value state fuel (by simpa [IsProbe] using hbound.2 value) + | none => + by_cases hhit : table coordinate ∈ state.pending coordinate + · simp [hhit] + · simp only [hhit, ↓reduceIte] + exact ih (table coordinate) (state.install coordinate (table coordinate)) fuel + (by simpa [IsProbe] using hbound.2 (table coordinate)) + +theorem mem_support_of_mem_runDetailed_done + (table : Coordinate → Digest) (state finalState : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) (hit : Bool) (value : alpha) + (hresult : DetailedResult.done hit finalState value ∈ + support (runDetailed table state fuel computation)) : + value ∈ support computation := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure result => + simp [runDetailed] at hresult ⊢ + exact hresult.2.2 + | query_bind input next ih => + rw [mem_support_bind_iff] + cases input with + | uniform n => + rw [runDetailed_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hrest⟩ := hresult + exact ⟨output, OracleComp.mem_support_query _ _, ih output state fuel hrest⟩ + | hashOutput => + rw [runDetailed_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hrest⟩ := hresult + exact ⟨output, OracleComp.mem_support_query _ _, ih output state fuel hrest⟩ + | probe coordinate candidate => + rw [runDetailed_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + cases hrevealed : state.revealed coordinate with + | none => + simp only [hrevealed] at hresult + refine ⟨(), OracleComp.mem_support_query _ _, ?_⟩ + exact ih () (state.addPending coordinate candidate) remaining hresult + | some revealedValue => + simp only [hrevealed] at hresult + refine ⟨(), OracleComp.mem_support_query _ _, ?_⟩ + exact ih () state remaining hresult + | reveal coordinate => + rw [runDetailed_reveal_query_bind] at hresult + cases hrevealed : state.revealed coordinate with + | some revealedValue => + simp only [hrevealed] at hresult + refine ⟨revealedValue, OracleComp.mem_support_query _ _, ?_⟩ + exact ih revealedValue state fuel hresult + | none => + simp only [hrevealed] at hresult + by_cases hhit : table coordinate ∈ state.pending coordinate + · simp [hhit] at hresult + · simp only [hhit, ↓reduceIte] at hresult + refine ⟨table coordinate, OracleComp.mem_support_query _ _, ?_⟩ + exact ih (table coordinate) (state.install coordinate (table coordinate)) fuel + hresult + +theorem runDetailed_stateFree_support + (table : Coordinate → Digest) (state : State Coordinate) + (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) + (hbound : computation.IsQueryBoundP IsStateful 0) + (hclean : tableHits state table = false) + (result : DetailedResult Coordinate alpha) + (hresult : result ∈ support (runDetailed table state fuel computation)) : + ∃ value, result = .done false state value := by + induction computation using OracleComp.inductionOn generalizing state fuel result with + | pure value => + simp [runDetailed, hclean] at hresult + exact ⟨value, hresult⟩ + | query_bind input next ih => + rw [isQueryBoundP_query_bind_iff] at hbound + cases input with + | uniform n => + rw [runDetailed_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hrest⟩ := hresult + exact ih output state fuel (by simpa [IsStateful] using hbound.2 output) + hclean result hrest + | hashOutput => + rw [runDetailed_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hrest⟩ := hresult + exact ih output state fuel (by simpa [IsStateful] using hbound.2 output) + hclean result hrest + | probe coordinate candidate => + simp [IsStateful] at hbound + | reveal coordinate => + simp [IsStateful] at hbound + +theorem runDetailed_bind_stateFree + (table : Coordinate → Digest) (state : State Coordinate) (fuel : Nat) + (left : OracleComp (World Coordinate) alpha) (next : alpha → + OracleComp (World Coordinate) beta) + (hbound : left.IsQueryBoundP IsStateful 0) : + runDetailed table state fuel (left >>= next) = + runDetailed table state fuel left >>= fun result => + match result with + | .stopped hit => pure (.stopped hit) + | .done _ finalState value => runDetailed table finalState fuel (next value) := by + induction left using OracleComp.inductionOn generalizing state with + | pure value => + simp [runDetailed] + | query_bind input continuation ih => + rw [isQueryBoundP_query_bind_iff] at hbound + cases input with + | uniform n => + rw [bind_assoc, runDetailed_uniform_query_bind, + runDetailed_uniform_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output state (by simpa [IsStateful] using hbound.2 output) + | hashOutput => + rw [bind_assoc, runDetailed_hashOutput_query_bind, + runDetailed_hashOutput_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output state (by simpa [IsStateful] using hbound.2 output) + | probe coordinate candidate => + simp [IsStateful] at hbound + | reveal coordinate => + simp [IsStateful] at hbound + +theorem mem_support_runDetailed_bind_stateFree + (table : Coordinate → Digest) (state finalState : State Coordinate) (fuel : Nat) + (left : OracleComp (World Coordinate) alpha) + (next : alpha → OracleComp (World Coordinate) beta) + (hbound : left.IsQueryBoundP IsStateful 0) + (hclean : tableHits state table = false) (hit : Bool) (value : beta) + (hresult : .done hit finalState value ∈ + support (runDetailed table state fuel (left >>= next))) : + ∃ leftValue, + .done false state leftValue ∈ support (runDetailed table state fuel left) ∧ + .done hit finalState value ∈ + support (runDetailed table state fuel (next leftValue)) := by + rw [runDetailed_bind_stateFree table state fuel left next hbound, + mem_support_bind_iff] at hresult + obtain ⟨leftResult, hleft, hnext⟩ := hresult + obtain ⟨leftValue, heq⟩ := runDetailed_stateFree_support table state fuel left + hbound hclean leftResult hleft + subst leftResult + exact ⟨leftValue, hleft, hnext⟩ + +theorem runDetailed_probeFree_support + (table : Coordinate → Digest) (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) + (hbound : computation.IsQueryBoundP IsProbe 0) + (hclean : tableHits state table = false) + (result : DetailedResult Coordinate alpha) + (hresult : result ∈ support (runDetailed table state fuel computation)) : + ∃ finalState value, + result = .done false finalState value ∧ tableHits finalState table = false := by + induction computation using OracleComp.inductionOn generalizing state fuel result with + | pure value => + simp [runDetailed, hclean] at hresult + exact ⟨state, value, hresult, hclean⟩ + | query_bind input next ih => + rw [isQueryBoundP_query_bind_iff] at hbound + cases input with + | uniform n => + rw [runDetailed_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hrest⟩ := hresult + exact ih output state fuel (by simpa [IsProbe] using hbound.2 output) + hclean result hrest + | hashOutput => + rw [runDetailed_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hrest⟩ := hresult + exact ih output state fuel (by simpa [IsProbe] using hbound.2 output) + hclean result hrest + | probe coordinate candidate => + simp [IsProbe] at hbound + | reveal coordinate => + rw [runDetailed_reveal_query_bind] at hresult + cases hrevealed : state.revealed coordinate with + | some value => + simp only [hrevealed] at hresult + exact ih value state fuel (by simpa [IsProbe] using hbound.2 value) + hclean result hresult + | none => + simp only [hrevealed] at hresult + have hmiss := not_mem_pending_of_tableHits_eq_false state table coordinate hclean + rw [if_neg hmiss] at hresult + exact ih (table coordinate) (state.install coordinate (table coordinate)) fuel + (by simpa [IsProbe] using hbound.2 (table coordinate)) + (tableHits_install_eq_false state table coordinate (table coordinate) hclean) + result hresult + +theorem runDetailed_bind_probeFree + (table : Coordinate → Digest) (state : State Coordinate) (fuel : Nat) + (left : OracleComp (World Coordinate) alpha) + (next : alpha → OracleComp (World Coordinate) beta) + (hbound : left.IsQueryBoundP IsProbe 0) : + runDetailed table state fuel (left >>= next) = + runDetailed table state fuel left >>= fun result => + match result with + | .stopped hit => pure (.stopped hit) + | .done _ finalState value => runDetailed table finalState fuel (next value) := by + induction left using OracleComp.inductionOn generalizing state with + | pure value => + simp [runDetailed] + | query_bind input continuation ih => + rw [isQueryBoundP_query_bind_iff] at hbound + cases input with + | uniform n => + rw [bind_assoc, runDetailed_uniform_query_bind, + runDetailed_uniform_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output state (by simpa [IsProbe] using hbound.2 output) + | hashOutput => + rw [bind_assoc, runDetailed_hashOutput_query_bind, + runDetailed_hashOutput_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output state (by simpa [IsProbe] using hbound.2 output) + | probe coordinate candidate => + simp [IsProbe] at hbound + | reveal coordinate => + rw [bind_assoc, runDetailed_reveal_query_bind, + runDetailed_reveal_query_bind] + cases hrevealed : state.revealed coordinate with + | some value => + exact ih value state (by simpa [IsProbe] using hbound.2 value) + | none => + by_cases hhit : table coordinate ∈ state.pending coordinate + · simp [hhit] + · simp only [hhit, ↓reduceIte] + exact ih (table coordinate) (state.install coordinate (table coordinate)) + (by simpa [IsProbe] using hbound.2 (table coordinate)) + +noncomputable def experiment (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) : ProbComp Bool := do + let base ← sampleTable + run (extendTable state base) state fuel computation + +noncomputable def detailedExperiment (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) : + ProbComp ((Coordinate → Digest) × DetailedResult Coordinate alpha) := do + let base ← sampleTable + let table := extendTable state base + let result ← runDetailed table state fuel computation + pure (table, result) + +theorem detailedExperiment_hit_eq_experiment (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) : + (fun result => result.2.hit) <$> detailedExperiment state fuel computation = + experiment state fuel computation := by + unfold detailedExperiment experiment + simp only [map_bind] + apply bind_congr + intro base + rw [← runDetailed_hit_eq_run] + simp [map_eq_bind_pure_comp] + +noncomputable def applyReveal (state : State Coordinate) (coordinate : Coordinate) + (resume : Digest → State Coordinate → ProbComp Bool) : ProbComp Bool := do + let value ← ($ᵗ Digest : ProbComp Digest) + if value ∈ state.pending coordinate then pure true + else resume value (state.install coordinate value) + +theorem applyReveal_probability_le (state : State Coordinate) (coordinate : Coordinate) + (resume : Digest → State Coordinate → ProbComp Bool) (fuel : Nat) + (hresume : ∀ value, + Pr[fun hit : Bool => hit = true | resume value (state.install coordinate value)] ≤ + ((fuel + (state.install coordinate value).pendingCount : Nat) : ℝ≥0∞) * + ((Fintype.card Digest : Nat) : ℝ≥0∞)⁻¹) : + Pr[fun hit : Bool => hit = true | applyReveal state coordinate resume] ≤ + ((fuel + state.pendingCount : Nat) : ℝ≥0∞) * + ((Fintype.card Digest : Nat) : ℝ≥0∞)⁻¹ := by + let installedCount := (state.install coordinate 0).pendingCount + refine (probEvent_bind_le_probEvent_add + (mx := ($ᵗ Digest : ProbComp Digest)) + (my := fun value => + if value ∈ state.pending coordinate then pure true + else resume value (state.install coordinate value)) + (q := fun hit : Bool => hit = true) + (p := fun value : Digest => value ∈ state.pending coordinate) + (ε := ((fuel + installedCount : Nat) : ℝ≥0∞) * + ((Fintype.card Digest : Nat) : ℝ≥0∞)⁻¹) ?_).trans ?_ + · intro value _ hmiss + simp only [hmiss, ↓reduceIte] + have hcount : (state.install coordinate value).pendingCount = installedCount := rfl + simpa [hcount] using hresume value + · refine add_le_add (uniformDigest_mem_finset_le (state.pending coordinate)) le_rfl |>.trans ?_ + have hconserve := state.pendingCount_install_add coordinate 0 + calc + ((state.pending coordinate).card : ℝ≥0∞) * + ((Fintype.card Digest : Nat) : ℝ≥0∞)⁻¹ + + ((fuel + installedCount : Nat) : ℝ≥0∞) * + ((Fintype.card Digest : Nat) : ℝ≥0∞)⁻¹ = + (((state.pending coordinate).card + fuel + installedCount : Nat) : ℝ≥0∞) * + ((Fintype.card Digest : Nat) : ℝ≥0∞)⁻¹ := by + push_cast + ring + _ = ((fuel + state.pendingCount : Nat) : ℝ≥0∞) * + ((Fintype.card Digest : Nat) : ℝ≥0∞)⁻¹ := by + rw [show (state.pending coordinate).card + fuel + installedCount = + fuel + state.pendingCount by omega] + _ ≤ ((fuel + state.pendingCount : Nat) : ℝ≥0∞) * + ((Fintype.card Digest : Nat) : ℝ≥0∞)⁻¹ := le_rfl + +theorem evalDist_sample_applyReveal (state : State Coordinate) (coordinate : Coordinate) + (hhidden : state.revealed coordinate = none) + (resume : (Coordinate → Digest) → Digest → State Coordinate → ProbComp Bool) : + evalDist (sampleTable >>= fun base => + let table := extendTable state base + let value := table coordinate + if value ∈ state.pending coordinate then pure true + else resume table value (state.install coordinate value)) = + evalDist (applyReveal state coordinate (fun value nextState => + sampleTable >>= fun base => + resume (extendTable nextState base) value nextState)) := by + let continuation := fun (base : Coordinate → Digest) => + let table := extendTable state base + let value := table coordinate + if value ∈ state.pending coordinate then pure true + else resume table value (state.install coordinate value) + calc + _ = evalDist (do + let value ← ($ᵗ Digest : ProbComp Digest) + let base ← sampleTable + if value ∈ state.pending coordinate then pure true + else (resume (extendTable (state.install coordinate value) base) + value (state.install coordinate value))) := by + rw [evalDist_sampleTable_eq_bind_update coordinate continuation] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro value + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro base + simp only [continuation] + rw [extendTable_update_eq_install state coordinate value base hhidden] + have hinstalled : + extendTable (state.install coordinate value) base coordinate = value := by + simp [extendTable, State.install] + rw [hinstalled] + _ = _ := by + unfold applyReveal + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro value + by_cases hhit : value ∈ state.pending coordinate + · simp only [hhit, ↓reduceIte] + exact OracleComp.DeferredSampling.evalDist_bind_const_neverFails sampleTable + (by simp [sampleTable]) (pure true) + · simp [hhit] + +theorem experiment_uniform_query_bind (state : State Coordinate) (fuel n : Nat) + (next : Fin (n + 1) → OracleComp (World Coordinate) alpha) : + experiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.uniform n)) : + OracleComp (World Coordinate) (Fin (n + 1))) >>= next) = + sampleTable >>= fun base => (do + let output ← liftM (unifSpec.query n) + run (extendTable state base) state fuel (next output)) := by + unfold experiment + apply bind_congr + intro base + exact run_uniform_query_bind _ _ _ _ _ + +theorem experiment_probe_query_bind (state : State Coordinate) (fuel : Nat) + (coordinate : Coordinate) (candidate : Digest) + (next : Unit → OracleComp (World Coordinate) alpha) : + experiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.probe coordinate candidate)) : + OracleComp (World Coordinate) Unit) >>= next) = + sampleTable >>= fun base => + match fuel with + | 0 => pure (tableHits state (extendTable state base)) + | remaining + 1 => + match state.revealed coordinate with + | some _ => run (extendTable state base) state remaining (next ()) + | none => run (extendTable state base) + (state.addPending coordinate candidate) remaining (next ()) := by + cases fuel with + | zero => + unfold experiment + apply bind_congr + intro base + exact run_probe_query_bind (Coordinate := Coordinate) (alpha := alpha) + (extendTable state base) state 0 coordinate candidate next + | succ remaining => + unfold experiment + apply bind_congr + intro base + exact run_probe_query_bind (Coordinate := Coordinate) (alpha := alpha) + (extendTable state base) state (remaining + 1) coordinate candidate next + +theorem experiment_hashOutput_query_bind (state : State Coordinate) (fuel : Nat) + (next : HashOutput → OracleComp (World Coordinate) alpha) : + experiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) .hashOutput) : + OracleComp (World Coordinate) HashOutput) >>= next) = + sampleTable >>= fun base => (do + let output ← liftM sampleHashOutput + run (extendTable state base) state fuel (next output)) := by + unfold experiment + apply bind_congr + intro base + exact run_hashOutput_query_bind _ _ _ _ + +theorem experiment_reveal_query_bind (state : State Coordinate) (fuel : Nat) + (coordinate : Coordinate) + (next : Digest → OracleComp (World Coordinate) alpha) : + experiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.reveal coordinate)) : + OracleComp (World Coordinate) Digest) >>= next) = + sampleTable >>= fun base => + match state.revealed coordinate with + | some value => run (extendTable state base) state fuel (next value) + | none => + let value := extendTable state base coordinate + if value ∈ state.pending coordinate then pure true + else run (extendTable state base) (state.install coordinate value) + fuel (next value) := by + unfold experiment + apply bind_congr + intro base + exact run_reveal_query_bind _ _ _ _ _ + +set_option maxRecDepth 100000 in +theorem experiment_probability_le_unbounded [Nonempty Coordinate] + (state : State Coordinate) (hvalid : state.Valid) + (fuel : Nat) (computation : OracleComp (World Coordinate) alpha) : + Pr[fun hit : Bool => hit = true | experiment state fuel computation] ≤ + ((fuel + state.pendingCount : Nat) : ℝ≥0∞) * + ((Fintype.card Digest : Nat) : ℝ≥0∞)⁻¹ := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure result => + change Pr[fun hit : Bool => hit = true | + (fun base : Coordinate → Digest => tableHits state (extendTable state base)) <$> + sampleTable] ≤ _ + refine (finalize_probability_le state hvalid).trans ?_ + apply mul_le_mul_left + exact_mod_cast Nat.le_add_left state.pendingCount fuel + | query_bind input next ih => + cases input with + | uniform n => + have hdist : + evalDist (experiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.uniform n)) : + OracleComp (World Coordinate) _) >>= next)) = + evalDist ((liftM (unifSpec.query n) : ProbComp _) >>= fun output => + experiment state fuel (next output)) := by + rw [experiment_uniform_query_bind] + exact OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + refine (probEvent_congr' (oa' := + (liftM (unifSpec.query n) : ProbComp _) >>= fun output => + experiment state fuel (next output)) (fun _ _ => Iff.rfl) hdist).le.trans ?_ + exact probEvent_bind_le_of_forall_le fun output _ => + ih output state hvalid fuel + | hashOutput => + have hdist : + evalDist (experiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) .hashOutput) : + OracleComp (World Coordinate) HashOutput) >>= next)) = + evalDist (sampleHashOutput >>= fun output => + experiment state fuel (next output)) := by + rw [experiment_hashOutput_query_bind] + exact OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + refine (probEvent_congr' (oa' := + sampleHashOutput >>= fun output => + experiment state fuel (next output)) (fun _ _ => Iff.rfl) hdist).le.trans ?_ + exact probEvent_bind_le_of_forall_le fun output _ => + ih output state hvalid fuel + | probe coordinate candidate => + cases fuel with + | zero => + rw [experiment_probe_query_bind] + change Pr[fun hit : Bool => hit = true | + (fun base : Coordinate → Digest => + tableHits state (extendTable state base)) <$> sampleTable] ≤ _ + simpa using finalize_probability_le state hvalid + | succ remaining => + cases hrevealed : state.revealed coordinate with + | some value => + rw [experiment_probe_query_bind] + simp only [hrevealed] + change Pr[fun hit : Bool => hit = true | + experiment state remaining (next ())] ≤ _ + refine (ih () state hvalid remaining).trans ?_ + apply mul_le_mul_left + have hnat : remaining + state.pendingCount ≤ + remaining + 1 + state.pendingCount := by omega + exact_mod_cast hnat + | none => + rw [experiment_probe_query_bind] + simp only [hrevealed] + change Pr[fun hit : Bool => hit = true | + experiment (state.addPending coordinate candidate) remaining + (next ())] ≤ _ + refine (ih () (state.addPending coordinate candidate) + (hvalid.addPending coordinate candidate hrevealed) remaining).trans ?_ + apply mul_le_mul_left + exact_mod_cast (show remaining + + (state.addPending coordinate candidate).pendingCount ≤ + remaining + 1 + state.pendingCount by + have := state.pendingCount_addPending_le coordinate candidate + omega) + | reveal coordinate => + cases hrevealed : state.revealed coordinate with + | some value => + rw [experiment_reveal_query_bind] + simp only [hrevealed] + change Pr[fun hit : Bool => hit = true | + experiment state fuel (next value)] ≤ _ + exact ih value state hvalid fuel + | none => + let resume := fun value nextState => experiment nextState fuel (next value) + have hdist : + evalDist (experiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.reveal coordinate)) : + OracleComp (World Coordinate) _) >>= next)) = + evalDist (applyReveal state coordinate resume) := by + rw [experiment_reveal_query_bind] + simp only [hrevealed] + simpa [resume, experiment] using + evalDist_sample_applyReveal state coordinate hrevealed + fun table value nextState => + run table nextState fuel (next value) + refine (probEvent_congr' (oa' := applyReveal state coordinate resume) + (fun _ _ => Iff.rfl) hdist).le.trans ?_ + apply applyReveal_probability_le state coordinate resume fuel + intro value + exact ih value (state.install coordinate value) + (hvalid.install coordinate value) fuel + +theorem experiment_probability_le [Nonempty Coordinate] + (state : State Coordinate) (hvalid : state.Valid) + (fuel : Nat) (computation : OracleComp (World Coordinate) alpha) + (_hbound : computation.IsQueryBoundP IsProbe fuel) : + Pr[fun hit : Bool => hit = true | experiment state fuel computation] ≤ + ((fuel + state.pendingCount : Nat) : ℝ≥0∞) * + ((Fintype.card Digest : Nat) : ℝ≥0∞)⁻¹ := + experiment_probability_le_unbounded state hvalid fuel computation + +theorem experiment_empty_probability_le_unbounded [Nonempty Coordinate] (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) : + Pr[fun hit : Bool => hit = true | + experiment (State.empty : State Coordinate) fuel computation] ≤ + (fuel : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + simpa [show Fintype.card Digest = 2 ^ digestBits by simp] using + experiment_probability_le_unbounded + (State.empty : State Coordinate) State.valid_empty fuel computation + +theorem experiment_empty_probability_le [Nonempty Coordinate] (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) + (hbound : computation.IsQueryBoundP IsProbe fuel) : + Pr[fun hit : Bool => hit = true | + experiment (State.empty : State Coordinate) fuel computation] ≤ + (fuel : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + simpa [show Fintype.card Digest = 2 ^ digestBits by simp] using + experiment_probability_le (State.empty : State Coordinate) State.valid_empty + fuel computation hbound + +end SphincsSecurity.AdaptiveRevealProbe diff --git a/formal/sphincs/SphincsSecurity/Proof/AdaptiveRevealProbeCharge.lean b/formal/sphincs/SphincsSecurity/Proof/AdaptiveRevealProbeCharge.lean new file mode 100644 index 00000000..bc0f9b50 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/AdaptiveRevealProbeCharge.lean @@ -0,0 +1,316 @@ +import SphincsSecurity.Proof.AdaptiveRevealProbe + +namespace SphincsSecurity.AdaptiveRevealProbe + +open OracleComp OracleSpec ENNReal + +variable {Coordinate : Type} [Fintype Coordinate] [DecidableEq Coordinate] + +def pendingProbeCharge (state : State Coordinate) (coordinate : Coordinate) (candidate : Digest) : Nat := + if candidate ∈ state.pending coordinate then 0 else 1 + +omit [Fintype Coordinate] [DecidableEq Coordinate] in +theorem pendingProbeCharge_le_one (state : State Coordinate) (coordinate : Coordinate) (candidate : Digest) : + pendingProbeCharge state coordinate candidate ≤ 1 := by + unfold pendingProbeCharge + split_ifs <;> omega + +omit [Fintype Coordinate] in +theorem State.addPending_eq_self_of_mem (state : State Coordinate) + (coordinate : Coordinate) (candidate : Digest) (hmem : candidate ∈ state.pending coordinate) : + state.addPending coordinate candidate = state := by + unfold State.addPending + rw [Finset.insert_eq_of_mem hmem, Function.update_eq_self] + +theorem State.pendingCount_addPending_le_charge (state : State Coordinate) + (coordinate : Coordinate) (candidate : Digest) : + (state.addPending coordinate candidate).pendingCount ≤ + state.pendingCount + pendingProbeCharge state coordinate candidate := by + by_cases hmem : candidate ∈ state.pending coordinate + · rw [state.addPending_eq_self_of_mem coordinate candidate hmem] + simp only [pendingProbeCharge, if_pos hmem, Nat.add_zero, le_refl] + · simpa only [pendingProbeCharge, if_neg hmem] using state.pendingCount_addPending_le coordinate candidate + +noncomputable def expectedProbeCharge {α : Type} + (computation : OracleComp (World Coordinate) α) : State Coordinate → Nat → ℝ≥0∞ := + OracleComp.construct (fun _ _ _ => 0) + (fun input _ next state fuel => + match input with + | .uniform n => ∑' output, Pr[= output | (liftM (unifSpec.query n) : ProbComp _)] * + next output state fuel + | .hashOutput => ∑' output, Pr[= output | sampleHashOutput] * next output state fuel + | .probe coordinate candidate => + match fuel with + | 0 => 0 + | remaining + 1 => + match state.revealed coordinate with + | some _ => next () state remaining + | none => (pendingProbeCharge state coordinate candidate : ℝ≥0∞) + + next () (state.addPending coordinate candidate) remaining + | .reveal coordinate => + match state.revealed coordinate with + | some value => next value state fuel + | none => ∑' value, Pr[= value | ($ᵗ Digest : ProbComp Digest)] * + if value ∈ state.pending coordinate then 0 + else next value (state.install coordinate value) fuel) + computation + +omit [Fintype Coordinate] in +theorem expectedProbeCharge_query_bind {α : Type} + (input : (World Coordinate).Domain) + (next : (World Coordinate).Range input → OracleComp (World Coordinate) α) + (state : State Coordinate) (fuel : Nat) : + expectedProbeCharge ((liftM (OracleSpec.query input) : OracleComp (World Coordinate) _) >>= next) state fuel = + match input with + | .uniform n => ∑' output, Pr[= output | (liftM (unifSpec.query n) : ProbComp _)] * + expectedProbeCharge (next output) state fuel + | .hashOutput => ∑' output, Pr[= output | sampleHashOutput] * + expectedProbeCharge (next output) state fuel + | .probe coordinate candidate => + match fuel with + | 0 => 0 + | remaining + 1 => + match state.revealed coordinate with + | some _ => expectedProbeCharge (next ()) state remaining + | none => (pendingProbeCharge state coordinate candidate : ℝ≥0∞) + + expectedProbeCharge (next ()) (state.addPending coordinate candidate) remaining + | .reveal coordinate => + match state.revealed coordinate with + | some value => expectedProbeCharge (next value) state fuel + | none => ∑' value, Pr[= value | ($ᵗ Digest : ProbComp Digest)] * + if value ∈ state.pending coordinate then 0 + else expectedProbeCharge (next value) (state.install coordinate value) fuel := by + cases input <;> rfl + +set_option maxRecDepth 100000 in +theorem applyReveal_probability_le_charge (state : State Coordinate) (coordinate : Coordinate) + (resume : Digest → State Coordinate → ProbComp Bool) (charge : Digest → ℝ≥0∞) + (hresume : ∀ value, + Pr[fun hit : Bool => hit = true | resume value (state.install coordinate value)] ≤ + (charge value + ((state.install coordinate value).pendingCount : ℝ≥0∞)) * + (Fintype.card Digest : ℝ≥0∞)⁻¹) : + Pr[fun hit : Bool => hit = true | applyReveal state coordinate resume] ≤ + ((∑' value, Pr[= value | ($ᵗ Digest : ProbComp Digest)] * + if value ∈ state.pending coordinate then 0 else charge value) + + (state.pendingCount : ℝ≥0∞)) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + classical + let eps := (Fintype.card Digest : ℝ≥0∞)⁻¹ + let remaining := (state.install coordinate 0).pendingCount + calc + _ ≤ ∑' value, Pr[= value | ($ᵗ Digest : ProbComp Digest)] * + ((if value ∈ state.pending coordinate then 1 else 0) + + (if value ∈ state.pending coordinate then 0 else charge value) * eps + + (remaining : ℝ≥0∞) * eps) := by + rw [applyReveal, probEvent_bind_eq_tsum] + apply ENNReal.tsum_le_tsum + intro value + simp only [probOutput_uniformSample] + apply mul_le_mul' le_rfl + by_cases hhit : value ∈ state.pending coordinate + · simp only [hhit, ↓reduceIte, probEvent_pure, zero_mul, add_zero] + exact le_add_right le_rfl + · simp only [hhit, ↓reduceIte, zero_add] + exact (hresume value).trans_eq (by rw [add_mul]; rfl) + _ = Pr[fun value : Digest => value ∈ state.pending coordinate | ($ᵗ Digest : ProbComp Digest)] + + (∑' value, Pr[= value | ($ᵗ Digest : ProbComp Digest)] * + if value ∈ state.pending coordinate then 0 else charge value) * eps + + (remaining : ℝ≥0∞) * eps := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_add, ENNReal.tsum_mul_right, + tsum_probOutput_of_liftM_PMF, one_mul] + congr 1 + · congr 1 + · rw [probEvent_eq_tsum_ite] + apply tsum_congr + intro value + split_ifs <;> simp + · simp_rw [← mul_assoc] + rw [ENNReal.tsum_mul_right] + _ ≤ ((state.pending coordinate).card : ℝ≥0∞) * eps + + (∑' value, Pr[= value | ($ᵗ Digest : ProbComp Digest)] * + if value ∈ state.pending coordinate then 0 else charge value) * eps + + (remaining : ℝ≥0∞) * eps := by + have hmem := uniformDigest_mem_finset_le (state.pending coordinate) + change _ ≤ ((state.pending coordinate).card : ℝ≥0∞) * eps at hmem + simp only [probEvent_eq_tsum_ite, probOutput_uniformSample] at hmem ⊢ + exact add_le_add_left (add_le_add_left hmem _) _ + _ = _ := by + have hcount := state.pendingCount_install_add coordinate 0 + have hcast : (remaining : ℝ≥0∞) + ((state.pending coordinate).card : ℝ≥0∞) = + (state.pendingCount : ℝ≥0∞) := by exact_mod_cast hcount + rw [← hcast] + ring + +theorem probEvent_bind_le_expectedCharge {β : Type} + (source : ProbComp β) (resume : β → ProbComp Bool) + (charge : β → ℝ≥0∞) (pending eps : ℝ≥0∞) + (hresume : ∀ value, Pr[fun hit : Bool => hit = true | resume value] ≤ + (charge value + pending) * eps) : + Pr[fun hit : Bool => hit = true | source >>= resume] ≤ + ((∑' value, Pr[= value | source] * charge value) + pending) * eps := by + rw [probEvent_bind_eq_tsum] + calc + _ ≤ ∑' value, Pr[= value | source] * ((charge value + pending) * eps) := + ENNReal.tsum_le_tsum fun value => mul_le_mul' le_rfl (hresume value) + _ = (∑' value, Pr[= value | source] * charge value) * eps + + (∑' value, Pr[= value | source]) * (pending * eps) := by + simp_rw [add_mul, mul_add, ← mul_assoc] + rw [ENNReal.tsum_add, ENNReal.tsum_mul_right, ENNReal.tsum_mul_right, + ENNReal.tsum_mul_right, mul_assoc] + _ ≤ (∑' value, Pr[= value | source] * charge value) * eps + pending * eps := + add_le_add le_rfl (mul_le_of_le_one_left (by positivity) tsum_probOutput_le_one) + _ = _ := (add_mul ..).symm + +set_option maxRecDepth 100000 in +theorem experiment_probability_le_expectedProbeCharge {α : Type} [Nonempty Coordinate] + (state : State Coordinate) (hvalid : state.Valid) + (fuel : Nat) (computation : OracleComp (World Coordinate) α) : + Pr[fun hit : Bool => hit = true | experiment state fuel computation] ≤ + (expectedProbeCharge computation state fuel + (state.pendingCount : ℝ≥0∞)) * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure result => + change Pr[fun hit : Bool => hit = true | + (fun base : Coordinate → Digest => tableHits state (extendTable state base)) <$> + sampleTable] ≤ (0 + _) * _ + rw [zero_add] + exact finalize_probability_le state hvalid + | query_bind input next ih => + rw [expectedProbeCharge_query_bind] + cases input with + | uniform n => + have hdist : + evalDist (experiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.uniform n)) : + OracleComp (World Coordinate) _) >>= next)) = + evalDist ((liftM (unifSpec.query n) : ProbComp _) >>= fun output => + experiment state fuel (next output)) := by + rw [experiment_uniform_query_bind] + exact OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + refine (probEvent_congr' (oa' := + (liftM (unifSpec.query n) : ProbComp _) >>= fun output => + experiment state fuel (next output)) (fun _ _ => Iff.rfl) hdist).le.trans ?_ + exact probEvent_bind_le_expectedCharge _ _ _ _ _ fun output => + ih output state hvalid fuel + | hashOutput => + have hdist : + evalDist (experiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) .hashOutput) : + OracleComp (World Coordinate) HashOutput) >>= next)) = + evalDist (sampleHashOutput >>= fun output => + experiment state fuel (next output)) := by + rw [experiment_hashOutput_query_bind] + exact OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + refine (probEvent_congr' (oa' := + sampleHashOutput >>= fun output => + experiment state fuel (next output)) (fun _ _ => Iff.rfl) hdist).le.trans ?_ + exact probEvent_bind_le_expectedCharge _ _ _ _ _ fun output => + ih output state hvalid fuel + | probe coordinate candidate => + cases fuel with + | zero => + rw [experiment_probe_query_bind] + change Pr[fun hit : Bool => hit = true | + (fun base : Coordinate → Digest => + tableHits state (extendTable state base)) <$> sampleTable] ≤ (0 + _) * _ + rw [zero_add] + exact finalize_probability_le state hvalid + | succ remaining => + cases hrevealed : state.revealed coordinate with + | some value => + rw [experiment_probe_query_bind] + simp only [hrevealed] + exact ih () state hvalid remaining + | none => + rw [experiment_probe_query_bind] + simp only [hrevealed] + refine (ih () (state.addPending coordinate candidate) + (hvalid.addPending coordinate candidate hrevealed) remaining).trans ?_ + apply mul_le_mul' _ le_rfl + calc + _ ≤ expectedProbeCharge (next ()) (state.addPending coordinate candidate) remaining + + ((state.pendingCount : ℝ≥0∞) + (pendingProbeCharge state coordinate candidate : ℝ≥0∞)) := by + apply add_le_add le_rfl + exact_mod_cast state.pendingCount_addPending_le_charge coordinate candidate + _ = _ := by ac_rfl + | reveal coordinate => + cases hrevealed : state.revealed coordinate with + | some value => + rw [experiment_reveal_query_bind] + simp only [hrevealed] + exact ih value state hvalid fuel + | none => + let resume := fun value nextState => experiment nextState fuel (next value) + have hdist : + evalDist (experiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.reveal coordinate)) : + OracleComp (World Coordinate) _) >>= next)) = + evalDist (applyReveal state coordinate resume) := by + rw [experiment_reveal_query_bind] + simp only [hrevealed] + simpa [resume, experiment] using + evalDist_sample_applyReveal state coordinate hrevealed + fun table value nextState => + run table nextState fuel (next value) + refine (probEvent_congr' (oa' := applyReveal state coordinate resume) + (fun _ _ => Iff.rfl) hdist).le.trans ?_ + simp only [hrevealed] + exact applyReveal_probability_le_charge state coordinate resume _ fun value => + ih value (state.install coordinate value) (hvalid.install coordinate value) fuel + +theorem experiment_empty_probability_le_expectedProbeCharge {α : Type} [Nonempty Coordinate] + (fuel : Nat) (computation : OracleComp (World Coordinate) α) : + Pr[fun hit : Bool => hit = true | experiment (State.empty : State Coordinate) fuel computation] ≤ + expectedProbeCharge computation State.empty fuel * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + simpa only [State.pendingCount_empty, Nat.cast_zero, add_zero] using + experiment_probability_le_expectedProbeCharge State.empty State.valid_empty fuel computation + +omit [Fintype Coordinate] in +theorem expectedProbeCharge_le_fuel {α : Type} + (computation : OracleComp (World Coordinate) α) (state : State Coordinate) (fuel : Nat) : + expectedProbeCharge computation state fuel ≤ fuel := by + have havg {β : Type} (source : ProbComp β) (charge : β → ℝ≥0∞) (cap : ℝ≥0∞) + (hcharge : ∀ value, charge value ≤ cap) : + (∑' value, Pr[= value | source] * charge value) ≤ cap := by + calc + _ ≤ ∑' value, Pr[= value | source] * cap := + ENNReal.tsum_le_tsum fun value => mul_le_mul' le_rfl (hcharge value) + _ ≤ cap := by + rw [ENNReal.tsum_mul_right] + exact mul_le_of_le_one_left (by positivity) tsum_probOutput_le_one + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => exact bot_le + | query_bind input next ih => + rw [expectedProbeCharge_query_bind] + cases input with + | uniform n => exact havg _ _ _ fun output => ih output state fuel + | hashOutput => exact havg _ _ _ fun output => ih output state fuel + | probe coordinate candidate => + cases fuel with + | zero => simp only [Nat.cast_zero, le_refl] + | succ remaining => + cases hrevealed : state.revealed coordinate with + | some value => + simp only [hrevealed] + exact (ih () state remaining).trans (Nat.cast_le.mpr (Nat.le_succ remaining)) + | none => + simp only [hrevealed] + calc + _ ≤ 1 + (remaining : ℝ≥0∞) := + add_le_add (by exact_mod_cast pendingProbeCharge_le_one state coordinate candidate) + (ih () (state.addPending coordinate candidate) remaining) + _ = _ := by simp only [Nat.cast_add, Nat.cast_one, add_comm] + | reveal coordinate => + cases hrevealed : state.revealed coordinate with + | some value => + simp only [hrevealed] + exact ih value state fuel + | none => + simp only [hrevealed] + apply havg + intro value + split_ifs + · exact bot_le + · exact ih value (state.install coordinate value) fuel + +end SphincsSecurity.AdaptiveRevealProbe diff --git a/formal/sphincs/SphincsSecurity/Proof/AdaptiveRevealProbeCost.lean b/formal/sphincs/SphincsSecurity/Proof/AdaptiveRevealProbeCost.lean new file mode 100644 index 00000000..1247aa17 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/AdaptiveRevealProbeCost.lean @@ -0,0 +1,208 @@ +import SphincsSecurity.Proof.AdaptiveRevealProbeCharge + +namespace SphincsSecurity.AdaptiveRevealProbe + +open OracleComp OracleSpec ENNReal + +variable {Coordinate : Type} [Fintype Coordinate] [DecidableEq Coordinate] + +noncomputable def runCharged {α : Type} (table : Coordinate → Digest) + (state : State Coordinate) (fuel : Nat) (computation : OracleComp (World Coordinate) α) : + ProbComp (DetailedResult Coordinate α × Nat) := + OracleComp.construct + (C := fun _ => State Coordinate → Nat → ProbComp (DetailedResult Coordinate α × Nat)) + (fun result state _ => pure (.done (tableHits state table) state result, 0)) + (fun input _ next state fuel => + match input with + | .uniform n => do + let output ← liftM (unifSpec.query n) + next output state fuel + | .hashOutput => do + let output ← liftM sampleHashOutput + next output state fuel + | .probe coordinate candidate => + match fuel with + | 0 => pure (.stopped (tableHits state table), 0) + | remaining + 1 => + match state.revealed coordinate with + | some _ => next () state remaining + | none => (fun result => (result.1, result.2 + pendingProbeCharge state coordinate candidate)) <$> + next () (state.addPending coordinate candidate) remaining + | .reveal coordinate => + match state.revealed coordinate with + | some value => next value state fuel + | none => + let value := table coordinate + if value ∈ state.pending coordinate then pure (.stopped true, 0) + else next value (state.install coordinate value) fuel) + computation state fuel + +theorem runCharged_result_eq_runDetailed {α : Type} (table : Coordinate → Digest) + (state : State Coordinate) (fuel : Nat) (computation : OracleComp (World Coordinate) α) : + Prod.fst <$> runCharged table state fuel computation = runDetailed table state fuel computation := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure result => simp only [runCharged, runDetailed, OracleComp.construct_pure, map_pure] + | query_bind input next ih => + rw [runCharged, runDetailed, OracleComp.construct_query_bind, OracleComp.construct_query_bind] + cases input with + | uniform n => + simp only [map_bind] + apply bind_congr + intro output + exact ih output state fuel + | hashOutput => + simp only [map_bind] + apply bind_congr + intro output + exact ih output state fuel + | probe coordinate candidate => + cases fuel with + | zero => simp only [map_pure] + | succ remaining => + cases hrevealed : state.revealed coordinate with + | some value => simpa only [runCharged, runDetailed, hrevealed] using ih () state remaining + | none => + simpa only [runCharged, runDetailed, hrevealed, Functor.map_map] using + ih () (state.addPending coordinate candidate) remaining + | reveal coordinate => + cases hrevealed : state.revealed coordinate with + | some value => simpa only [runCharged, runDetailed, hrevealed] using ih value state fuel + | none => + simp only [hrevealed] + split_ifs with hhit + · simp only [map_pure] + · exact ih (table coordinate) (state.install coordinate (table coordinate)) fuel + +theorem runCharged_cost_le_fuel {α : Type} (table : Coordinate → Digest) + (state : State Coordinate) (fuel : Nat) (computation : OracleComp (World Coordinate) α) : + ∀ result ∈ support (runCharged table state fuel computation), result.2 ≤ fuel := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + intro result hresult + simp only [runCharged, OracleComp.construct_pure, support_pure, Set.mem_singleton_iff] at hresult + rw [hresult] + exact Nat.zero_le _ + | query_bind input next ih => + intro result hresult + rw [runCharged, OracleComp.construct_query_bind] at hresult + cases input with + | uniform n => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _, hrest⟩ := hresult + exact ih output state fuel result hrest + | hashOutput => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _, hrest⟩ := hresult + exact ih output state fuel result hrest + | probe coordinate candidate => + cases fuel with + | zero => + simp only [support_pure, Set.mem_singleton_iff] at hresult + rw [hresult] + | succ remaining => + cases hrevealed : state.revealed coordinate with + | some value => + simp only [hrevealed] at hresult + exact (ih () state remaining result hresult).trans (Nat.le_succ remaining) + | none => + simp only [hrevealed, support_map, Set.mem_image] at hresult + obtain ⟨previous, hprevious, heq⟩ := hresult + rw [← heq] + exact Nat.add_le_add (ih () (state.addPending coordinate candidate) + remaining previous hprevious) (pendingProbeCharge_le_one state coordinate candidate) + | reveal coordinate => + cases hrevealed : state.revealed coordinate with + | some value => + simp only [hrevealed] at hresult + exact ih value state fuel result hresult + | none => + simp only [hrevealed] at hresult + split_ifs at hresult with hhit + · simp only [support_pure, Set.mem_singleton_iff] at hresult + rw [hresult] + exact Nat.zero_le _ + · exact ih (table coordinate) (state.install coordinate (table coordinate)) fuel result hresult + +set_option maxRecDepth 100000 in +theorem evalDist_sample_applyReveal_result {β : Type} (stopped : β) (state : State Coordinate) (coordinate : Coordinate) + (hhidden : state.revealed coordinate = none) + (resume : (Coordinate → Digest) → Digest → State Coordinate → ProbComp β) : + evalDist (sampleTable >>= fun base => + let table := extendTable state base + let value := table coordinate + if value ∈ state.pending coordinate then pure stopped + else resume table value (state.install coordinate value)) = + evalDist (do + let value ← ($ᵗ Digest : ProbComp Digest) + if value ∈ state.pending coordinate then pure stopped + else sampleTable >>= fun base => + (resume (extendTable (state.install coordinate value) base) value + (state.install coordinate value))) := by + let continuation := fun (base : Coordinate → Digest) => + let table := extendTable state base + let value := table coordinate + if value ∈ state.pending coordinate then pure stopped + else resume table value (state.install coordinate value) + calc + _ = evalDist (do + let value ← ($ᵗ Digest : ProbComp Digest) + let base ← sampleTable + if value ∈ state.pending coordinate then pure stopped + else (resume (extendTable (state.install coordinate value) base) + value (state.install coordinate value))) := by + rw [evalDist_sampleTable_eq_bind_update coordinate continuation] + simp only [evalDist_bind, evalDist_uniformSample] + congr 1 + funext value + congr 1 + funext base + simp only [continuation] + rw [extendTable_update_eq_install state coordinate value base hhidden] + have hinstalled : + extendTable (state.install coordinate value) base coordinate = value := by + simp [extendTable, State.install] + rw [hinstalled] + _ = _ := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro value + by_cases hhit : value ∈ state.pending coordinate + · simp only [hhit, ↓reduceIte] + exact OracleComp.DeferredSampling.evalDist_bind_const_neverFails sampleTable + (by simp [sampleTable]) (pure stopped) + · simp [hhit] + + +noncomputable def chargedExperiment {α : Type} (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) α) : ProbComp (DetailedResult Coordinate α × Nat) := do + let base ← sampleTable + runCharged (extendTable state base) state fuel computation + +theorem chargedExperiment_result_eq {α : Type} (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) α) : + Prod.fst <$> chargedExperiment state fuel computation = + Prod.snd <$> detailedExperiment state fuel computation := by + unfold chargedExperiment detailedExperiment + simp only [map_bind] + apply bind_congr + intro base + simpa only [map_bind, map_pure, bind_pure] using + runCharged_result_eq_runDetailed (extendTable state base) state fuel computation + +theorem chargedExperiment_hit_eq {α : Type} (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) α) : + (fun result => result.1.hit) <$> chargedExperiment state fuel computation = + experiment state fuel computation := by + calc + _ = (fun result : DetailedResult Coordinate α => result.hit) <$> + (Prod.fst <$> chargedExperiment state fuel computation) := by rw [Functor.map_map] + _ = _ := by rw [chargedExperiment_result_eq, Functor.map_map, detailedExperiment_hit_eq_experiment] + +theorem chargedExperiment_cost_le_fuel {α : Type} (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) α) : + ∀ result ∈ support (chargedExperiment state fuel computation), result.2 ≤ fuel := by + intro result hresult + rw [chargedExperiment, mem_support_bind_iff] at hresult + obtain ⟨base, _, hrun⟩ := hresult + exact runCharged_cost_le_fuel _ _ _ _ result hrun + +end SphincsSecurity.AdaptiveRevealProbe diff --git a/formal/sphincs/SphincsSecurity/Proof/AdaptiveRevealProbeCostBind.lean b/formal/sphincs/SphincsSecurity/Proof/AdaptiveRevealProbeCostBind.lean new file mode 100644 index 00000000..1795bd0b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/AdaptiveRevealProbeCostBind.lean @@ -0,0 +1,128 @@ +import SphincsSecurity.Proof.AdaptiveRevealProbeCost + +namespace SphincsSecurity.AdaptiveRevealProbe + +open OracleComp OracleSpec ENNReal + +variable {Coordinate : Type} [Fintype Coordinate] [DecidableEq Coordinate] + +set_option maxRecDepth 10000 in +theorem runCharged_bind_done_support {α β : Type} + (table : Coordinate → Digest) (left : OracleComp (World Coordinate) α) + (next : α → OracleComp (World Coordinate) β) (state : State Coordinate) (fuel : Nat) + (hit : Bool) (finalState : State Coordinate) (value : β) (cost : Nat) + (hresult : (.done hit finalState value, cost) ∈ support (runCharged table state fuel (left >>= next))) : + ∃ middleState middleValue middleFuel leftCost rightCost, + middleFuel ≤ fuel ∧ + (.done (tableHits middleState table) middleState middleValue, leftCost) ∈ + support (runCharged table state fuel left) ∧ + (.done hit finalState value, rightCost) ∈ + support (runCharged table middleState middleFuel (next middleValue)) ∧ + cost = leftCost + rightCost := by + induction left using OracleComp.inductionOn generalizing state fuel cost with + | pure middleValue => + rw [pure_bind] at hresult + refine ⟨state, middleValue, fuel, 0, cost, le_rfl, ?_, hresult, by omega⟩ + simp only [runCharged, OracleComp.construct_pure, support_pure, Set.mem_singleton_iff] + | query_bind input continuation ih => + rw [bind_assoc, runCharged, OracleComp.construct_query_bind] at hresult + cases input with + | uniform n => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hrest⟩ := hresult + obtain ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, hleft, hright, hcost⟩ := + ih output state fuel cost hrest + refine ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, ?_, hright, hcost⟩ + rw [runCharged, OracleComp.construct_query_bind, mem_support_bind_iff] + exact ⟨output, houtput, hleft⟩ + | hashOutput => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hrest⟩ := hresult + obtain ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, hleft, hright, hcost⟩ := + ih output state fuel cost hrest + refine ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, ?_, hright, hcost⟩ + rw [runCharged, OracleComp.construct_query_bind, mem_support_bind_iff] + exact ⟨output, houtput, hleft⟩ + | probe coordinate candidate => + cases fuel with + | zero => + simp only [support_pure, Set.mem_singleton_iff, Prod.mk.injEq, reduceCtorEq, false_and] at hresult + | succ remaining => + cases hrevealed : state.revealed coordinate with + | some revealed => + simp only [hrevealed] at hresult + obtain ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, hleft, hright, hcost⟩ := + ih () state remaining cost hresult + refine ⟨middleState, middleValue, middleFuel, leftCost, rightCost, + hbudget.trans (Nat.le_succ _), ?_, hright, hcost⟩ + rw [runCharged, OracleComp.construct_query_bind] + simpa only [hrevealed, runCharged] using hleft + | none => + simp only [hrevealed, support_map, Set.mem_image] at hresult + obtain ⟨⟨previousResult, previousCost⟩, hrest, heq⟩ := hresult + have hresultEq : previousResult = .done hit finalState value := congrArg Prod.fst heq + have hcostEq : previousCost + pendingProbeCharge state coordinate candidate = cost := congrArg Prod.snd heq + rw [hresultEq] at hrest + obtain ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, hleft, hright, hcost⟩ := + ih () (state.addPending coordinate candidate) remaining previousCost hrest + refine ⟨middleState, middleValue, middleFuel, + leftCost + pendingProbeCharge state coordinate candidate, rightCost, + hbudget.trans (Nat.le_succ _), ?_, hright, by omega⟩ + rw [runCharged, OracleComp.construct_query_bind] + simp only [hrevealed, support_map, Set.mem_image] + exact ⟨(.done (tableHits middleState table) middleState middleValue, leftCost), hleft, rfl⟩ + | reveal coordinate => + cases hrevealed : state.revealed coordinate with + | some revealed => + simp only [hrevealed] at hresult + obtain ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, hleft, hright, hcost⟩ := + ih revealed state fuel cost hresult + refine ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, ?_, hright, hcost⟩ + rw [runCharged, OracleComp.construct_query_bind] + simpa only [hrevealed, runCharged] using hleft + | none => + simp only [hrevealed] at hresult + split_ifs at hresult with hhit + · simp only [support_pure, Set.mem_singleton_iff, Prod.mk.injEq, reduceCtorEq, false_and] at hresult + · obtain ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, hleft, hright, hcost⟩ := + ih (table coordinate) (state.install coordinate (table coordinate)) fuel cost hresult + refine ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, ?_, hright, hcost⟩ + rw [runCharged, OracleComp.construct_query_bind] + simpa only [hrevealed, hhit, ↓reduceIte, runCharged] using hleft + +theorem runCharged_done_mem_support {α : Type} + (table : Coordinate → Digest) (state finalState : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) α) (hit : Bool) (value : α) (cost : Nat) + (hresult : (.done hit finalState value, cost) ∈ support (runCharged table state fuel computation)) : + value ∈ support computation := by + apply mem_support_of_mem_runDetailed_done table state finalState fuel computation hit value + rw [← runCharged_result_eq_runDetailed, support_map] + exact ⟨(.done hit finalState value, cost), hresult, rfl⟩ + +theorem runCharged_done_stateFree {α : Type} + (table : Coordinate → Digest) (state finalState : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) α) + (hbound : computation.IsQueryBoundP IsStateful 0) (hit : Bool) (value : α) (cost : Nat) + (hresult : (.done hit finalState value, cost) ∈ support (runCharged table state fuel computation)) : + finalState = state ∧ cost = 0 := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure result => + simp only [runCharged, OracleComp.construct_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq, DetailedResult.done.injEq] at hresult + exact ⟨hresult.1.2.1, hresult.2⟩ + | query_bind input next ih => + rw [isQueryBoundP_query_bind_iff] at hbound + rw [runCharged, OracleComp.construct_query_bind] at hresult + cases input with + | uniform n => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _, hrest⟩ := hresult + exact ih output state fuel (by simpa [IsStateful] using hbound.2 output) hrest + | hashOutput => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _, hrest⟩ := hresult + exact ih output state fuel (by simpa [IsStateful] using hbound.2 output) hrest + | probe coordinate candidate => simp [IsStateful] at hbound + | reveal coordinate => simp [IsStateful] at hbound + +end SphincsSecurity.AdaptiveRevealProbe diff --git a/formal/sphincs/SphincsSecurity/Proof/AdaptiveRevealProbeCostExpectation.lean b/formal/sphincs/SphincsSecurity/Proof/AdaptiveRevealProbeCostExpectation.lean new file mode 100644 index 00000000..297849b7 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/AdaptiveRevealProbeCostExpectation.lean @@ -0,0 +1,153 @@ +import SphincsSecurity.Proof.AdaptiveRevealProbeCost + +namespace SphincsSecurity.AdaptiveRevealProbe + +open OracleComp OracleSpec ENNReal + +variable {Coordinate : Type} [Fintype Coordinate] [DecidableEq Coordinate] + +theorem expectedCost_congr {β : Type} (left right : ProbComp β) (cost : β → ℝ≥0∞) + (hdist : evalDist left = evalDist right) : + (∑' result, Pr[= result | left] * cost result) = + ∑' result, Pr[= result | right] * cost result := by + apply tsum_congr + intro result + rw [OracleComp.probOutput_congr (x := result) (y := result) rfl hdist] + +set_option maxRecDepth 100000 in +theorem chargedExperiment_expectedCost_eq {α : Type} + (computation : OracleComp (World Coordinate) α) (state : State Coordinate) (fuel : Nat) : + (∑' result, Pr[= result | chargedExperiment state fuel computation] * (result.2 : ℝ≥0∞)) = + expectedProbeCharge computation state fuel := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure result => + rw [chargedExperiment, tsum_probOutput_bind_mul] + simp only [runCharged, OracleComp.construct_pure, tsum_probOutput_pure_mul, + Nat.cast_zero, mul_zero, tsum_zero, expectedProbeCharge] + | query_bind input next ih => + rw [expectedProbeCharge_query_bind] + cases input with + | uniform n => + have hdist : evalDist (chargedExperiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.uniform n)) : + OracleComp (World Coordinate) _) >>= next)) = + evalDist ((liftM (unifSpec.query n) : ProbComp _) >>= fun output => + chargedExperiment state fuel (next output)) := by + unfold chargedExperiment + change evalDist (sampleTable >>= fun base => + (liftM (unifSpec.query n) : ProbComp _) >>= fun output => + runCharged (extendTable state base) state fuel (next output)) = _ + exact OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + rw [expectedCost_congr _ _ _ hdist, tsum_probOutput_bind_mul] + simp_rw [ih] + | hashOutput => + have hdist : evalDist (chargedExperiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) .hashOutput) : + OracleComp (World Coordinate) HashOutput) >>= next)) = + evalDist (sampleHashOutput >>= fun output => + chargedExperiment state fuel (next output)) := by + unfold chargedExperiment + change evalDist (sampleTable >>= fun base => sampleHashOutput >>= fun output => + runCharged (extendTable state base) state fuel (next output)) = _ + exact OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + rw [expectedCost_congr _ _ _ hdist, tsum_probOutput_bind_mul] + simp_rw [ih] + | probe coordinate candidate => + cases fuel with + | zero => + rw [chargedExperiment, tsum_probOutput_bind_mul] + simp only [runCharged, OracleComp.construct_query_bind, tsum_probOutput_pure_mul, + Nat.cast_zero, mul_zero, tsum_zero] + | succ remaining => + cases hrevealed : state.revealed coordinate with + | some value => + simp only [hrevealed] + have heq : chargedExperiment state (remaining + 1) + ((liftM (OracleSpec.query (spec := World Coordinate) (.probe coordinate candidate)) : + OracleComp (World Coordinate) Unit) >>= next) = + chargedExperiment state remaining (next ()) := by + unfold chargedExperiment + apply bind_congr + intro base + rw [runCharged, OracleComp.construct_query_bind] + simp only [hrevealed] + rfl + rw [heq] + exact ih () state remaining + | none => + simp only [hrevealed] + have heq : chargedExperiment state (remaining + 1) + ((liftM (OracleSpec.query (spec := World Coordinate) (.probe coordinate candidate)) : + OracleComp (World Coordinate) Unit) >>= next) = + (fun result : DetailedResult Coordinate α × Nat => (result.1, result.2 + pendingProbeCharge state coordinate candidate)) <$> + chargedExperiment (state.addPending coordinate candidate) remaining (next ()) := by + unfold chargedExperiment + rw [map_bind] + apply bind_congr + intro base + rw [runCharged, OracleComp.construct_query_bind] + simp only [hrevealed] + rfl + rw [heq, tsum_probOutput_map_mul] + simp only [Nat.cast_add, mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_mul_right, + tsum_probOutput_of_liftM_PMF, one_mul, ih, add_comm] + | reveal coordinate => + cases hrevealed : state.revealed coordinate with + | some value => + simp only [hrevealed] + have heq : chargedExperiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.reveal coordinate)) : + OracleComp (World Coordinate) Digest) >>= next) = + chargedExperiment state fuel (next value) := by + unfold chargedExperiment + apply bind_congr + intro base + rw [runCharged, OracleComp.construct_query_bind] + simp only [hrevealed] + rfl + rw [heq] + exact ih value state fuel + | none => + simp only [hrevealed] + let resume : Digest → ProbComp (DetailedResult Coordinate α × Nat) := fun value => + if value ∈ state.pending coordinate then pure (.stopped true, 0) + else chargedExperiment (state.install coordinate value) fuel (next value) + have hdist : evalDist (chargedExperiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.reveal coordinate)) : + OracleComp (World Coordinate) Digest) >>= next)) = + evalDist (($ᵗ Digest : ProbComp Digest) >>= resume) := by + unfold chargedExperiment + change evalDist (sampleTable >>= fun base => + match state.revealed coordinate with + | some value => runCharged (extendTable state base) state fuel (next value) + | none => + if extendTable state base coordinate ∈ state.pending coordinate then pure (.stopped true, 0) + else runCharged (extendTable state base) + (state.install coordinate (extendTable state base coordinate)) fuel + (next (extendTable state base coordinate))) = _ + simp only [hrevealed] + exact evalDist_sample_applyReveal_result (.stopped true, 0) state coordinate hrevealed + (fun table value nextState => runCharged table nextState fuel (next value)) + rw [expectedCost_congr _ _ _ hdist, tsum_probOutput_bind_mul] + apply tsum_congr + intro value + dsimp only [resume] + by_cases hhit : value ∈ state.pending coordinate + · simp only [hhit, ↓reduceIte, tsum_probOutput_pure_mul, Nat.cast_zero, mul_zero] + · simp only [hhit, ↓reduceIte, ih] + +theorem chargedExperiment_probability_le_expectedCost {α : Type} [Nonempty Coordinate] + (fuel : Nat) (computation : OracleComp (World Coordinate) α) : + Pr[fun result => result.1.hit = true | chargedExperiment State.empty fuel computation] ≤ + (∑' result, Pr[= result | chargedExperiment State.empty fuel computation] * (result.2 : ℝ≥0∞)) * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + rw [chargedExperiment_expectedCost_eq] + have heq : Pr[fun result => result.1.hit = true | chargedExperiment State.empty fuel computation] = + Pr[fun hit : Bool => hit = true | experiment State.empty fuel computation] := by + rw [← chargedExperiment_hit_eq, probEvent_map] + rfl + rw [heq] + exact experiment_empty_probability_le_expectedProbeCharge fuel computation + +end SphincsSecurity.AdaptiveRevealProbe diff --git a/formal/sphincs/SphincsSecurity/Proof/Amortized.lean b/formal/sphincs/SphincsSecurity/Proof/Amortized.lean new file mode 100644 index 00000000..6e79e677 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Amortized.lean @@ -0,0 +1,140 @@ +import SphincsSecurity.Proof.QueryBound + +/-! +# The accounting, once and for all + +Every per-query charge in the development has the same shape: a bad event on the random oracle's +cache, and a potential on caches that pays for the charges a query cannot pay for itself. A fresh +answer is dangerous only if it lands in a finite set of digests, and what that set costs is funded +by the potential the earlier queries built up, plus a constant per query. + +That is ordinary amortized analysis, and it is the only probabilistic argument the reduction needs: +`probEvent_bad_le_amortized` takes the bad event, the potential and the constant, and returns +`(c * q + potential) * eps`. Everything else about a strategy, the hits it has to produce and how +many targets each fresh answer faces, is deterministic bookkeeping in the hypothesis. + +The constant matters, since a factor `c` is `log2 c` bits off the claim: the honest value a query has +to hit may itself be undetermined when the query is made, and then the charge falls on the answer +that determines it, one per slot of the payload it lands in. That is what `c` pays for, and the +widest payload in the instance is the `v = 42` chain endpoints of a leaf. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +/-- One fresh answer lands in a finite set of digests with probability at most `|targets| * eps`. -/ +theorem probEvent_mem_targets_le {ε : ℝ≥0∞} + (hstep : ∀ target : Digest, + Pr[fun answer => truncateHash answer = target | ($ᵗ HashOutput : ProbComp HashOutput)] ≤ ε) + (targets : Finset Digest) : + Pr[fun answer => truncateHash answer ∈ targets | ($ᵗ HashOutput : ProbComp HashOutput)] + ≤ (targets.card : ℝ≥0∞) * ε := by + classical + induction targets using Finset.induction with + | empty => simp + | insert a targets hnotMem ih => + calc Pr[fun answer => truncateHash answer ∈ insert a targets + | ($ᵗ HashOutput : ProbComp HashOutput)] + = Pr[fun answer => truncateHash answer = a ∨ truncateHash answer ∈ targets + | ($ᵗ HashOutput : ProbComp HashOutput)] := by + simp only [Finset.mem_insert] + _ ≤ Pr[fun answer => truncateHash answer = a | ($ᵗ HashOutput : ProbComp HashOutput)] + + Pr[fun answer => truncateHash answer ∈ targets + | ($ᵗ HashOutput : ProbComp HashOutput)] := probEvent_or_le _ _ _ + _ ≤ ε + (targets.card : ℝ≥0∞) * ε := add_le_add (hstep a) ih + _ = ((insert a targets).card : ℝ≥0∞) * ε := by + rw [Finset.card_insert_of_notMem hnotMem] + push_cast + ring + +/-- **The accounting.** A computation making at most `q` hash queries leaves a bad cache with +probability at most `(c * q + potential) * eps`, whenever each fresh answer on an uncached input is +dangerous only inside a finite set of digests whose size the potential pays for, up to `c` per +query. -/ +theorem probEvent_bad_le_amortized {Bad Inv : QueryCache HashSpec → Prop} + {potential : QueryCache HashSpec → Nat} {c : Nat} {ε : ℝ≥0∞} + (hstep : ∀ target : Digest, + Pr[fun answer => truncateHash answer = target | ($ᵗ HashOutput : ProbComp HashOutput)] ≤ ε) + (hinv : ∀ (cache : QueryCache HashSpec) (input : HashInput) (answer : HashOutput), Inv cache → + Inv (cache.cacheQuery input answer)) + (hamortized : ∀ cache : QueryCache HashSpec, Inv cache → ¬ Bad cache → ∀ input : HashInput, + cache input = none → ∃ targets : Finset Digest, targets.card ≤ potential cache + c + ∧ ∀ answer : HashOutput, truncateHash answer ∉ targets → + ¬ Bad (cache.cacheQuery input answer) + ∧ potential (cache.cacheQuery input answer) + targets.card ≤ potential cache + c) + {α : Type} (oa : OracleComp OracleWorld α) : + ∀ (q : Nat), oa.IsQueryBoundP (· matches Sum.inr _) q → + ∀ cache : QueryCache HashSpec, Inv cache → ¬ Bad cache → + Pr[fun result => Bad result.2 | (simulateQ romImpl oa).run cache] + ≤ ((c * q + potential cache : Nat) : ℝ≥0∞) * ε := by + classical + induction oa using OracleComp.inductionOn with + | pure x => + intro q _ cache _ hclean + simp [hclean] + | query_bind t k ih => + intro q hq cache hinvCache hclean + rw [isQueryBoundP_query_bind_iff] at hq + obtain ⟨hcan, hcont⟩ := hq + rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind] + cases t with + | inl i => + simp only [Bool.false_eq_true, if_false] at hcont + have hrun : ((romImpl (Sum.inl i)).run cache + >>= fun p => (simulateQ romImpl (k p.1)).run p.2) + = (liftM (unifSpec.query i) : ProbComp _) + >>= fun u => (simulateQ romImpl (k u)).run cache := by + simp [romImpl, unifFwdImpl, QueryImpl.liftTarget, HasQuery.toQueryImpl, + StateT.run_monadLift, map_eq_bind_pure_comp, bind_assoc] + rw [hrun] + exact probEvent_bind_le_of_forall_le fun u _ => + ih u q (hcont u) cache hinvCache hclean + | inr input => + simp only [if_true] at hcont + have hq1 : 0 < q := by simpa using hcan + obtain ⟨q', rfl⟩ : ∃ q', q = q' + 1 := ⟨q - 1, by omega⟩ + simp only [Nat.add_sub_cancel] at hcont + by_cases hcached : cache input = none + · obtain ⟨targets, hcard, htargets⟩ := hamortized cache hinvCache hclean input hcached + have hrun : ((romImpl (Sum.inr input)).run cache + >>= fun p => (simulateQ romImpl (k p.1)).run p.2) + = ($ᵗ HashOutput : ProbComp HashOutput) >>= fun answer => + (simulateQ romImpl (k answer)).run (cache.cacheQuery input answer) := by + have hro : (romImpl (Sum.inr input)).run cache + = ((uniformSampleImpl.withCaching : QueryImpl HashSpec _) input).run cache := rfl + rw [hro, QueryImpl.withCaching_run_none _ hcached] + simp [map_eq_bind_pure_comp, bind_assoc, uniformSampleImpl] + rw [hrun] + refine le_trans (probEvent_bind_le_add_of_forall_le + (bad := fun answer => truncateHash answer ∈ targets) + (c := ((c * q' + (potential cache + c - targets.card) : Nat) : ℝ≥0∞) * ε) ?_) ?_ + · intro answer hgood + obtain ⟨hbad, hpotential⟩ := htargets answer hgood + exact le_trans (ih answer q' (hcont answer) _ (hinv cache input answer hinvCache) hbad) + (mul_le_mul_left (Nat.cast_le.mpr (by omega)) ε) + · calc Pr[fun answer => truncateHash answer ∈ targets + | ($ᵗ HashOutput : ProbComp HashOutput)] + + ((c * q' + (potential cache + c - targets.card) : Nat) : ℝ≥0∞) * ε + ≤ (targets.card : ℝ≥0∞) * ε + + ((c * q' + (potential cache + c - targets.card) : Nat) : ℝ≥0∞) * ε := + add_le_add (probEvent_mem_targets_le hstep targets) le_rfl + _ = ((targets.card + (c * q' + (potential cache + c - targets.card)) : Nat) + : ℝ≥0∞) * ε := by push_cast; ring + _ ≤ ((c * (q' + 1) + potential cache : Nat) : ℝ≥0∞) * ε := + mul_le_mul_left (Nat.cast_le.mpr (by rw [Nat.mul_succ]; omega)) ε + · obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hcached + have hrun : ((romImpl (Sum.inr input)).run cache + >>= fun p => (simulateQ romImpl (k p.1)).run p.2) + = (simulateQ romImpl (k answer)).run cache := by + have hro : (romImpl (Sum.inr input)).run cache + = ((uniformSampleImpl.withCaching : QueryImpl HashSpec _) input).run cache := rfl + rw [hro, QueryImpl.withCaching_run_some _ hanswer] + simp + rw [hrun] + exact le_trans (ih answer q' (hcont answer) cache hinvCache hclean) + (mul_le_mul_left (Nat.cast_le.mpr (by + have : c * q' ≤ c * (q' + 1) := Nat.mul_le_mul_left c (by omega) + omega)) ε) + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Arith.lean b/formal/sphincs/SphincsSecurity/Proof/Arith.lean new file mode 100644 index 00000000..dda7a908 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Arith.lean @@ -0,0 +1,51 @@ +import SphincsSecurity.Statement + +/-! +# Index arithmetic + +The facts every Merkle argument needs: a node's index one level up is half of it, the sibling of an +index is that index with its low bit flipped, and the bit the fold tests is that low bit. +-/ + +namespace SphincsSecurity + +/-- The statement writes `Nat.xor`, the bit library `^^^`; rewriting needs them bridged. -/ +theorem nat_xor_eq (x y : Nat) : Nat.xor x y = x ^^^ y := rfl + +theorem div_pow_succ (x k : Nat) : x / 2 ^ (k + 1) = x / 2 ^ k / 2 := by + rw [Nat.pow_succ, Nat.div_div_eq_div_mul] + +theorem xor_one_div_two (j : Nat) : Nat.xor (2 * j) 1 / 2 = j := by + rw [nat_xor_eq, show (2 : Nat) = 2 ^ 1 from rfl, ← Nat.shiftRight_eq_div_pow, + Nat.shiftRight_xor_distrib, Nat.shiftRight_eq_div_pow] + simp + +theorem xor_one_two_mul (j : Nat) : Nat.xor (2 * j) 1 = 2 * j + 1 := by + apply Nat.eq_of_testBit_eq + intro i + cases i with + | zero => rw [nat_xor_eq]; simp [Nat.testBit_zero] + | succ i => + rw [Nat.testBit_succ, Nat.testBit_succ, xor_one_div_two, Nat.mul_add_div (by omega)] + simp + +theorem xor_one_two_mul_add_one (j : Nat) : Nat.xor (2 * j + 1) 1 = 2 * j := by + rw [← xor_one_two_mul j, nat_xor_eq, nat_xor_eq, Nat.xor_assoc, Nat.xor_self, Nat.xor_zero] + +/-- An index and its sibling are the two children of the index one level up; the low bit says which +of them is the left one. -/ +theorem index_sibling_cases (c : Nat) : + ∃ j, (c = 2 * j ∧ Nat.xor c 1 = 2 * j + 1 ∧ c % 2 = 0) + ∨ (c = 2 * j + 1 ∧ Nat.xor c 1 = 2 * j ∧ c % 2 = 1) := by + obtain ⟨j, hj⟩ : ∃ j, c / 2 = j := ⟨c / 2, rfl⟩ + have hdm := Nat.div_add_mod c 2 + rcases Nat.mod_two_eq_zero_or_one c with hmod | hmod + · have hc : c = 2 * j := by omega + exact ⟨j, Or.inl ⟨hc, by rw [hc]; exact xor_one_two_mul j, hmod⟩⟩ + · have hc : c = 2 * j + 1 := by omega + exact ⟨j, Or.inr ⟨hc, by rw [hc]; exact xor_one_two_mul_add_one j, hmod⟩⟩ + +theorem testBit_iff_div_mod (x k : Nat) : x.testBit k = true ↔ x / 2 ^ k % 2 = 1 := by + rw [Nat.testBit_eq_decide_div_mod_eq, decide_eq_true_iff] + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Bytes.lean b/formal/sphincs/SphincsSecurity/Proof/Bytes.lean new file mode 100644 index 00000000..2618b596 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Bytes.lean @@ -0,0 +1,153 @@ +import SphincsSecurity.Statement + +/-! +# The byte encoding is injective + +Domain separation is what keeps a query from bearing on two structural positions at once, and it +rests on the tweak bytes determining the position. That in turn rests on the fixed-width +little-endian encoding being injective, which is what this module proves. +-/ + +namespace SphincsSecurity + +theorem bytesLE_injective {n : Nat} {x y : BitVec (8 * n)} (h : bytesLE n x = bytesLE n y) : + x = y := by + have hfun := List.ofFn_inj.mp h + apply BitVec.eq_of_getLsbD_eq + intro i hi + have hj : i / 8 < n := by omega + have hbyte := congrFun hfun ⟨i / 8, hj⟩ + have hbits : (x.extractLsb' (8 * (i / 8)) 8) = (y.extractLsb' (8 * (i / 8)) 8) := by + simpa using congrArg UInt8.toBitVec hbyte + have hlsb := congrArg (fun b : BitVec 8 => b.getLsbD (i % 8)) hbits + simp only [BitVec.getLsbD_extractLsb'] at hlsb + have hmod : i % 8 < 8 := by omega + have hsum : 8 * (i / 8) + i % 8 = i := by omega + simpa [hmod, hsum] using hlsb + +theorem bytesLE_length (n : Nat) (x : BitVec (8 * n)) : (bytesLE n x).length = n := by + simp [bytesLE] + +/-- A bit vector determines the natural it encodes, below the wrap. -/ +theorem ofNat_inj_of_lt {w a b : Nat} (ha : a < 2 ^ w) (hb : b < 2 ^ w) + (h : BitVec.ofNat w a = BitVec.ofNat w b) : a = b := by + have htoNat := congrArg BitVec.toNat h + rwa [BitVec.toNat_ofNat, BitVec.toNat_ofNat, Nat.mod_eq_of_lt ha, Nat.mod_eq_of_lt hb] at htoNat + +theorem fieldBytes_injective {t1 t2 : TweakFields} (h : fieldBytes t1 = fieldBytes t2) : t1 = t2 := by + obtain ⟨tag1, layer1, tree1, position1, index1⟩ := t1 + obtain ⟨tag2, layer2, tree2, position2, index2⟩ := t2 + simp only [fieldBytes] at h + obtain ⟨h, _⟩ := List.append_inj' h (by simp) + obtain ⟨h, hindex⟩ := List.append_inj' h (by simp [bytesLE_length]) + obtain ⟨h, hposition⟩ := List.append_inj' h (by simp [bytesLE_length]) + obtain ⟨h, htree⟩ := List.append_inj' h (by simp [bytesLE_length]) + obtain ⟨htag, hlayer⟩ := List.append_inj' h (by simp [bytesLE_length]) + simp only [bytesLE_injective htag, bytesLE_injective hlayer, bytesLE_injective htree, + bytesLE_injective hposition, bytesLE_injective hindex] + +theorem tweakBytes_eq_iff {d1 d2 : HashDomain} : + tweakBytes d1 = tweakBytes d2 ↔ hashDomainFields d1 = hashDomainFields d2 := + ⟨fun h => fieldBytes_injective h, fun h => by rw [tweakBytes, tweakBytes, h]⟩ + +private theorem layer_le : numLayers ≤ 2 ^ 8 := by decide +private theorem tree_le : 2 ^ totalHeight ≤ 2 ^ 32 := Nat.pow_le_pow_right (by omega) (by decide) +private theorem index_le : 2 ^ totalHeight ≤ 2 ^ 32 := tree_le +private theorem leaf_le : 2 ^ maxLayerHeight ≤ 2 ^ 32 := Nat.pow_le_pow_right (by omega) (by decide) +private theorem ftsTree_le : ftsTrees - 1 ≤ 2 ^ 8 := by decide +private theorem ftsLeaf_le : 2 ^ ftsTreeHeight ≤ 2 ^ 32 := Nat.pow_le_pow_right (by omega) (by decide) + +/-- Every field a tweak carries is below the width that encodes it. The `Fin`-valued ones are by +construction; the two tree recursions take their level and node as naturals, so those are the only +positions that need saying, and honest use keeps them far below `2^32`. -/ +def HashDomain.InRange : HashDomain → Prop + | .node _ _ level nodeIdx => level < 2 ^ 32 ∧ nodeIdx < 2 ^ 32 + | .ftsNode _ _ level nodeIdx => level < 2 ^ 32 ∧ nodeIdx < 2 ^ 32 + | _ => True + +theorem fin_of_ofNat_eq {w n : Nat} {a b : Fin n} (hn : n ≤ 2 ^ w) + (h : BitVec.ofNat w a.val = BitVec.ofNat w b.val) : a = b := + Fin.ext (ofNat_inj_of_lt (Nat.lt_of_lt_of_le a.isLt hn) (Nat.lt_of_lt_of_le b.isLt hn) h) + +/-- **Domain separation.** A tweak names one structural position: two in-range domains with the same +tweak bytes are the same domain. This is what stops one query from bearing on two positions, and so +what keeps an inversion at `2^-n` per query with no multi-target factor. -/ +theorem tweakBytes_injective {d1 d2 : HashDomain} (h1 : d1.InRange) (h2 : d2.InRange) + (h : tweakBytes d1 = tweakBytes d2) : d1 = d2 := by + rw [tweakBytes_eq_iff] at h + cases d1 <;> cases d2 <;> + simp_all [hashDomainFields, HashDomain.InRange, TweakFields.mk.injEq] + case chain.chain lay1 tree1 leaf1 i1 s1 lay2 tree2 leaf2 i2 s2 => + obtain ⟨hl, ht, hp, hlf⟩ := h + have hbound : ∀ (i : ChainIndex) (s : ChainStep), chainLength * i.val + s.val < 2 ^ 32 := by + intro i s + have := i.isLt; have := s.isLt + simp only [numChains, chainLength, winternitzBits] at * + omega + have hpos := ofNat_inj_of_lt (hbound i1 s1) (hbound i2 s2) hp + have hs1 := s1.isLt; have hs2 := s2.isLt + simp only [chainLength, winternitzBits] at hpos hs1 hs2 + exact ⟨fin_of_ofNat_eq layer_le hl, fin_of_ofNat_eq tree_le ht, fin_of_ofNat_eq leaf_le hlf, + Fin.ext (by omega), Fin.ext (by omega)⟩ + case leaf.leaf => exact ⟨fin_of_ofNat_eq layer_le h.1, fin_of_ofNat_eq tree_le h.2.1, + fin_of_ofNat_eq leaf_le h.2.2⟩ + case node.node lay1 tree1 level1 nodeIdx1 lay2 tree2 level2 nodeIdx2 => + exact ⟨fin_of_ofNat_eq layer_le h.1, fin_of_ofNat_eq tree_le h.2.1, + ofNat_inj_of_lt h1.1 h2.1 h.2.2.1, ofNat_inj_of_lt h1.2 h2.2 h.2.2.2⟩ + case encoding.encoding => exact ⟨fin_of_ofNat_eq layer_le h.1, fin_of_ofNat_eq tree_le h.2.1, + fin_of_ofNat_eq leaf_le h.2.2⟩ + case ftsLeaf.ftsLeaf => exact ⟨fin_of_ofNat_eq index_le h.2.1, fin_of_ofNat_eq ftsTree_le h.1, + fin_of_ofNat_eq ftsLeaf_le h.2.2⟩ + case ftsNode.ftsNode => + exact ⟨fin_of_ofNat_eq index_le h.2.1, fin_of_ofNat_eq ftsTree_le h.1, + ofNat_inj_of_lt h1.1 h2.1 h.2.2.1, ofNat_inj_of_lt h1.2 h2.2 h.2.2.2⟩ + case ftsRoots.ftsRoots => exact fin_of_ofNat_eq index_le h + +theorem tweakBytes_length (domain : HashDomain) : (tweakBytes domain).length = 16 := by + simp [tweakBytes, fieldBytes, bytesLE_length] + +/-- What the reduction reads off a query: the tweak is a fixed-length prefix of the hashed input, so +the input determines both the position it names and the payload. -/ +theorem tweakableHashInput_injective (parameter : PublicParameter) {d1 d2 : HashDomain} + (h1 : d1.InRange) (h2 : d2.InRange) {payload1 payload2 : HashInput} + (h : tweakableHashInput parameter d1 payload1 = tweakableHashInput parameter d2 payload2) : + d1 = d2 ∧ payload1 = payload2 := by + simp only [tweakableHashInput] at h + obtain ⟨hprefix, hpayload⟩ := List.append_inj h (by simp [tweakBytes_length, bytesLE_length]) + obtain ⟨htweak, _⟩ := List.append_inj' hprefix (by simp [bytesLE_length]) + exact ⟨tweakBytes_injective h1 h2 htweak, hpayload⟩ + +theorem tweakableHashInput_ne_message (parameter : PublicParameter) (domain : HashDomain) + (hdomain : domain ≠ .message) (payload messagePayload : HashInput) : + tweakableHashInput parameter domain payload ≠ + tweakableHashInput parameter .message messagePayload := by + intro hinput + simp only [tweakableHashInput] at hinput + obtain ⟨hprefix, _⟩ := List.append_inj hinput + (by simp [tweakBytes_length, bytesLE_length]) + obtain ⟨htweak, _⟩ := List.append_inj' hprefix (by simp [bytesLE_length]) + apply hdomain + cases domain <;> + simp_all [tweakBytes_eq_iff, hashDomainFields, TweakFields.mk.injEq] + +/-! ### Payloads + +A node's payload is its two children, a leaf's is its `v` chain endpoints, and a few-time key's is +its `k-1` roots. Each is injective, which is what lets the extraction argument descend: if an +adversary's payload hashes to an honest value, either it *is* the honest payload, and then its parts +are the honest parts, or the hash was hit. -/ + +theorem digestBytes_injective {x y : Digest} (h : Concrete.digestBytes x = Concrete.digestBytes y) : + x = y := + bytesLE_injective h + +theorem digestBytes_length (x : Digest) : (Concrete.digestBytes x).length = 16 := + bytesLE_length 16 x + +theorem nodePayload_injective {left right left' right' : Digest} + (h : Concrete.nodePayload left right = Concrete.nodePayload left' right') : + left = left' ∧ right = right' := by + obtain ⟨hleft, hright⟩ := List.append_inj h (by simp [Concrete.digestBytes, bytesLE_length]) + exact ⟨digestBytes_injective hleft, digestBytes_injective hright⟩ + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/CacheSize.lean b/formal/sphincs/SphincsSecurity/Proof/CacheSize.lean new file mode 100644 index 00000000..c462fc19 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/CacheSize.lean @@ -0,0 +1,107 @@ +import SphincsSecurity.Proof.QueryBound + +/-! +# Random-oracle cache size + +A run starting from a cache can add at most one entry per hash query. Uniform-sampling queries leave +the cache unchanged. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +theorem QueryCache.enncard_mono {first second : QueryCache HashSpec} + (hle : first ≤ second) : QueryCache.enncard first ≤ QueryCache.enncard second := by + exact ENat.toENNReal_mono (Set.encard_le_encard (QueryCache.toSet_mono hle)) + +theorem romImpl_uniform_query_enncard_eq + (input : unifSpec.Domain) (cache : QueryCache HashSpec) + (result : unifSpec.Range input × QueryCache HashSpec) + (hmem : result ∈ support ((romImpl (.inl input)).run cache)) : + QueryCache.enncard result.2 = QueryCache.enncard cache := by + change result ∈ support ((unifFwdImpl HashSpec input).run cache) at hmem + have hrun : (unifFwdImpl HashSpec input).run cache = + (fun sample => (sample, cache)) <$> + (liftM (unifSpec.query input) : ProbComp (unifSpec.Range input)) := by + simpa [simulateQ_query] using + (unifFwdImpl.simulateQ_run + (hashSpec := HashSpec) + (liftM (unifSpec.query input) : ProbComp (unifSpec.Range input)) cache) + rw [hrun, support_map] at hmem + obtain ⟨sample, _hsample, rfl⟩ := hmem + rfl + +theorem romImpl_hash_query_enncard_le + (input : HashInput) (cache : QueryCache HashSpec) + (result : HashOutput × QueryCache HashSpec) + (hmem : result ∈ support ((romImpl (.inr input)).run cache)) : + QueryCache.enncard result.2 ≤ QueryCache.enncard cache + 1 := by + change result ∈ support ((randomOracle input).run cache) at hmem + by_cases hcache : cache input = none + · rw [OracleSpec.randomOracle, QueryImpl.withCaching_run_none _ hcache, + support_map] at hmem + obtain ⟨output, _houtput, rfl⟩ := hmem + exact QueryCache.enncard_cacheQuery_le cache input output + · obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hcache + rw [OracleSpec.randomOracle, QueryImpl.withCaching_run_some _ houtput, + support_pure, Set.mem_singleton_iff] at hmem + subst result + exact le_add_right le_rfl + +set_option linter.constructorNameAsVariable false in +theorem simulateQ_romImpl_enncard_le + {Result : Type} (computation : OracleComp OracleWorld Result) : + ∀ (q : Nat), computation.IsQueryBoundP (· matches Sum.inr _) q → + ∀ (cache : QueryCache HashSpec) (result : Result × QueryCache HashSpec), + result ∈ support ((simulateQ romImpl computation).run cache) → + QueryCache.enncard result.2 ≤ QueryCache.enncard cache + q := by + induction computation using OracleComp.inductionOn with + | pure value => + intro q _ cache result hmem + simp only [simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] at hmem + subst result + exact le_add_right le_rfl + | query_bind input continuation ih => + intro q hq cache result hmem + rw [isQueryBoundP_query_bind_iff] at hq + obtain ⟨hcan, hcontinuation⟩ := hq + rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, + mem_support_bind_iff] at hmem + obtain ⟨queryResult, hquery, hrest⟩ := hmem + cases input with + | inl uniformInput => + simp only [Bool.false_eq_true, if_false] at hcontinuation + calc + QueryCache.enncard result.2 ≤ QueryCache.enncard queryResult.2 + q := + ih queryResult.1 q (hcontinuation queryResult.1) queryResult.2 result hrest + _ = QueryCache.enncard cache + q := by + rw [romImpl_uniform_query_enncard_eq uniformInput cache queryResult hquery] + | inr hashInput => + simp only [if_true] at hcontinuation + have hqPositive : 0 < q := by simpa using hcan + obtain ⟨remaining, rfl⟩ : ∃ remaining, q = remaining + 1 := + ⟨q - 1, by omega⟩ + simp only [Nat.add_sub_cancel] at hcontinuation + calc + QueryCache.enncard result.2 ≤ QueryCache.enncard queryResult.2 + remaining := + ih queryResult.1 remaining (hcontinuation queryResult.1) + queryResult.2 result hrest + _ ≤ (QueryCache.enncard cache + 1) + remaining := by + gcongr + exact romImpl_hash_query_enncard_le hashInput cache queryResult hquery + _ = QueryCache.enncard cache + (remaining + 1 : Nat) := by + push_cast + ring + +theorem simulateQ_romImpl_enncard_le_queryBound + {Result : Type} (computation : OracleComp OracleWorld Result) (q : Nat) + (hq : computation.IsQueryBoundP (· matches Sum.inr _) q) + (result : Result × QueryCache HashSpec) + (hmem : result ∈ support ((simulateQ romImpl computation).run ∅)) : + QueryCache.enncard result.2 ≤ q := by + simpa only [QueryCache.enncard_empty, zero_add] using + simulateQ_romImpl_enncard_le computation q hq ∅ result hmem + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Cached.lean b/formal/sphincs/SphincsSecurity/Proof/Cached.lean new file mode 100644 index 00000000..43743f16 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Cached.lean @@ -0,0 +1,482 @@ +import SphincsSecurity.Proof.Queried +import SphincsSecurity.Proof.Settled + +/-! +# Cached honest computations settle positions + +An executed computation is cached when every input in its answer-function trace occurs in the +cache. Honest chain and tree computations then settle every structural position they compute. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +def CachedRun {alpha : Type} (cache : QueryCache HashSpec) (f : QueryImpl HashSpec Id) + (oa : OracleComp HashSpec alpha) : Prop := + ∀ input ∈ queriedInputs f oa, cache input ≠ none + +theorem CachedRun.pure {alpha : Type} (cache : QueryCache HashSpec) + (f : QueryImpl HashSpec Id) (value : alpha) : + CachedRun cache f (pure value) := by + simp [CachedRun] + +theorem CachedRun.bind {alpha beta : Type} {cache : QueryCache HashSpec} + {f : QueryImpl HashSpec Id} {oa : OracleComp HashSpec alpha} + {next : alpha → OracleComp HashSpec beta} + (hleft : CachedRun cache f oa) + (hright : CachedRun cache f (next (evalWithAnswerFn f oa))) : + CachedRun cache f (oa >>= next) := by + intro input hinput + rw [queriedInputs_bind] at hinput + rcases List.mem_append.mp hinput with hinput | hinput + · exact hleft input hinput + · exact hright input hinput + +theorem CachedRun.bind_left {alpha beta : Type} {cache : QueryCache HashSpec} + {f : QueryImpl HashSpec Id} {oa : OracleComp HashSpec alpha} + {next : alpha → OracleComp HashSpec beta} (h : CachedRun cache f (oa >>= next)) : + CachedRun cache f oa := by + intro input hinput + exact h input (queriedInputs_mono_bind_left f oa next hinput) + +theorem CachedRun.bind_right {alpha beta : Type} {cache : QueryCache HashSpec} + {f : QueryImpl HashSpec Id} {oa : OracleComp HashSpec alpha} + {next : alpha → OracleComp HashSpec beta} (h : CachedRun cache f (oa >>= next)) : + CachedRun cache f (next (evalWithAnswerFn f oa)) := by + intro input hinput + exact h input (queriedInputs_mono_bind_right f oa next hinput) + +theorem CachedRun.mono {alpha : Type} {cache cache' : QueryCache HashSpec} + {f : QueryImpl HashSpec Id} {oa : OracleComp HashSpec alpha} + (hle : cache ≤ cache') (h : CachedRun cache f oa) : + CachedRun cache' f oa := by + intro input hinput + obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp (h input hinput) + rw [hle hanswer] + simp + +/-- A fresh cache insertion that the computation does not query cannot be needed to cache that +computation. -/ +theorem CachedRun.of_cacheQuery_of_not_mem {alpha : Type} {cache : QueryCache HashSpec} + {f : QueryImpl HashSpec Id} {oa : OracleComp HashSpec alpha} {input₀ : HashInput} + {answer : HashOutput} (hrun : CachedRun (cache.cacheQuery input₀ answer) f oa) + (hnotMem : input₀ ∉ queriedInputs f oa) : CachedRun cache f oa := by + intro input hinput + have hne : input ≠ input₀ := by + intro heq + exact hnotMem (heq ▸ hinput) + have hcached := hrun input hinput + rwa [QueryCache.cacheQuery_of_ne _ _ hne] at hcached + +theorem CachedRun.eval_eq {alpha : Type} {cache : QueryCache HashSpec} + {f g : QueryImpl HashSpec Id} {oa : OracleComp HashSpec alpha} + (hf : cache.AgreesWithFn f) (hg : cache.AgreesWithFn g) + (hrun : CachedRun cache f oa) : + evalWithAnswerFn f oa = evalWithAnswerFn g oa := by + induction oa using OracleComp.inductionOn with + | pure value => rfl + | query_bind input next ih => + have hcached : cache input ≠ none := by + apply hrun input + rw [queriedInputs_query_bind] + exact List.mem_cons_self + obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hcached + have hfg : f input = g input := (hf hanswer).trans (hg hanswer).symm + rw [evalWithAnswerFn_bind, evalWithAnswerFn_bind, + show evalWithAnswerFn f (liftM (HashSpec.query input)) = f input from + simulateQ_spec_query f input, + show evalWithAnswerFn g (liftM (HashSpec.query input)) = g input from + simulateQ_spec_query g input, hfg] + apply ih (g input) + intro queried hqueried + rw [← hfg] at hqueried + apply hrun queried + rw [queriedInputs_query_bind] + exact List.mem_cons_of_mem input hqueried + +theorem CachedRun.queriedInputs_eq {alpha : Type} {cache : QueryCache HashSpec} + {f g : QueryImpl HashSpec Id} {oa : OracleComp HashSpec alpha} + (hf : cache.AgreesWithFn f) (hg : cache.AgreesWithFn g) + (hrun : CachedRun cache f oa) : queriedInputs f oa = queriedInputs g oa := by + induction oa using OracleComp.inductionOn with + | pure value => rfl + | query_bind input next ih => + have hcached : cache input ≠ none := by + apply hrun input + rw [queriedInputs_query_bind] + exact List.mem_cons_self + obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hcached + have hfg : f input = g input := (hf hanswer).trans (hg hanswer).symm + rw [queriedInputs_query_bind, queriedInputs_query_bind, ← hfg] + congr 1 + apply ih (f input) + intro queried hqueried + apply hrun queried + rw [queriedInputs_query_bind] + exact List.mem_cons_of_mem input hqueried + +theorem CachedRun.changeAnswerFn {alpha : Type} {cache : QueryCache HashSpec} + {f g : QueryImpl HashSpec Id} {oa : OracleComp HashSpec alpha} + (hf : cache.AgreesWithFn f) (hg : cache.AgreesWithFn g) + (hrun : CachedRun cache f oa) : CachedRun cache g oa := by + intro input hinput + apply hrun input + rw [hrun.queriedInputs_eq hf hg] + exact hinput + +theorem simulateQ_randomOracle_run_eq_pure_of_cachedRun + {alpha : Type} {cache : QueryCache HashSpec} {f : QueryImpl HashSpec Id} + {computation : OracleComp HashSpec alpha} + (hagrees : cache.AgreesWithFn f) (hcached : CachedRun cache f computation) : + (simulateQ (randomOracle : QueryImpl HashSpec _) computation).run cache = + pure (evalWithAnswerFn f computation, cache) := by + induction computation using OracleComp.inductionOn with + | pure value => rfl + | query_bind input next ih => + have hinput : cache input ≠ none := by + apply hcached input + rw [queriedInputs_query_bind] + exact List.mem_cons_self + obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hinput + have hf : f input = output := hagrees houtput + rw [simulateQ_query_bind, StateT.run_bind] + change ((randomOracle input).run cache >>= fun result => + (simulateQ randomOracle (next result.1)).run result.2) = _ + rw [QueryImpl.withCaching_run_some uniformSampleImpl houtput] + simp only [pure_bind] + have htail : CachedRun cache f (next (f input)) := hcached.bind_right + have hrecursive := ih (f input) htail + rw [hf] at hrecursive + rw [hrecursive, evalWithAnswerFn_bind, + show evalWithAnswerFn f (liftM (HashSpec.query input)) = f input from + simulateQ_spec_query f input] + rw [hf] + +theorem CachedRun.sequenceFin_component {alpha : Type} {n : Nat} + {cache : QueryCache HashSpec} {f : QueryImpl HashSpec Id} + (computation : Fin n → OracleComp HashSpec alpha) + (h : CachedRun cache f (Concrete.sequenceFin computation)) (index : Fin n) : + CachedRun cache f (computation index) := by + intro input hinput + apply h input + exact Concrete.sequenceFin_component_query_mem f computation index hinput + +theorem CachedRun.sequenceFin {alpha : Type} {n : Nat} + {cache : QueryCache HashSpec} {f : QueryImpl HashSpec Id} + (computation : Fin n → OracleComp HashSpec alpha) + (hcomponent : ∀ index, CachedRun cache f (computation index)) : + CachedRun cache f (Concrete.sequenceFin computation) := by + induction n with + | zero => exact CachedRun.pure cache f _ + | succ n ih => + rw [Concrete.sequenceFin] + exact (hcomponent 0).bind <| (ih + (fun index : Fin n => computation index.succ) + (fun index => hcomponent index.succ)).bind <| CachedRun.pure cache f _ + +namespace Concrete + +variable {f : QueryImpl HashSpec Id} {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {cache : QueryCache HashSpec} + +def TreeRange (level nodeIdx : Nat) : Prop := + 2 ^ level * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight + +private theorem TreeRange.index_lt {level nodeIdx : Nat} (h : TreeRange level nodeIdx) : + nodeIdx < 2 ^ maxLayerHeight := by + have hpow : 1 ≤ 2 ^ level := one_le_pow₀ (by omega) + simp only [TreeRange] at h + nlinarith + +private theorem TreeRange.left {level nodeIdx : Nat} (h : TreeRange (level + 1) nodeIdx) : + TreeRange level (2 * nodeIdx) := by + simp only [TreeRange, pow_succ] at h ⊢ + nlinarith [Nat.zero_le (2 ^ level), Nat.zero_le nodeIdx] + +private theorem TreeRange.right {level nodeIdx : Nat} (h : TreeRange (level + 1) nodeIdx) : + TreeRange level (2 * nodeIdx + 1) := by + simp only [TreeRange, pow_succ] at h ⊢ + nlinarith [Nat.zero_le (2 ^ level), Nat.zero_le nodeIdx] + +def FtsRange (level nodeIdx : Nat) : Prop := + 2 ^ level * (nodeIdx + 1) ≤ 2 ^ ftsTreeHeight + +private theorem FtsRange.index_lt {level nodeIdx : Nat} (h : FtsRange level nodeIdx) : + nodeIdx < 2 ^ ftsTreeHeight := by + have hpow : 1 ≤ 2 ^ level := one_le_pow₀ (by omega) + simp only [FtsRange] at h + nlinarith + +private theorem FtsRange.left {level nodeIdx : Nat} (h : FtsRange (level + 1) nodeIdx) : + FtsRange level (2 * nodeIdx) := by + simp only [FtsRange, pow_succ] at h ⊢ + nlinarith [Nat.zero_le (2 ^ level), Nat.zero_le nodeIdx] + +private theorem FtsRange.right {level nodeIdx : Nat} (h : FtsRange (level + 1) nodeIdx) : + FtsRange level (2 * nodeIdx + 1) := by + simp only [FtsRange, pow_succ] at h ⊢ + nlinarith [Nat.zero_le (2 ^ level), Nat.zero_le nodeIdx] + +theorem settled_chain_of_cachedRun (hf : cache.AgreesWithFn f) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (position : Nat) + (hposition : position < chainLength - 1) + (hrun : CachedRun cache f (chainWalk parameter lay tree leafIdx chainIdx 0 (position + 1) + (otsSecret lay tree leafIdx chainIdx))) : + Settled parameter otsSecret ftsSecret cache + (.chain lay tree leafIdx chainIdx ⟨position, hposition⟩) := by + induction position with + | zero => + apply settled_of_honestInput_cached hf (by trivial) + · apply hrun + have hmem := chainWalk_query_mem f parameter lay tree leafIdx chainIdx 0 1 + (otsSecret lay tree leafIdx chainIdx) 0 (by omega) hposition + convert hmem using 1 + all_goals simp [honestInput, honestPayload, honestChain, Position.domain, walkValue] + · simp [Position.children] + | succ position ih => + have hposition' : position < chainLength - 1 := by omega + have hprefix : CachedRun cache f + (chainWalk parameter lay tree leafIdx chainIdx 0 (position + 1) + (otsSecret lay tree leafIdx chainIdx)) := by + intro input hinput + apply hrun input + rw [show position + 1 + 1 = (position + 1) + 1 by omega, chainWalk, + queriedInputs_bind] + exact List.mem_append_left _ hinput + have hchild := ih hposition' hprefix + apply settled_of_honestInput_cached hf (by trivial) + · apply hrun + have hmem := chainWalk_query_mem f parameter lay tree leafIdx chainIdx 0 (position + 2) + (otsSecret lay tree leafIdx chainIdx) (position + 1) (by omega) (by omega) + convert hmem using 1 + all_goals simp [honestInput, honestPayload, honestChain, Position.domain, walkValue] + · intro c hc + rw [Position.children, dif_pos (Nat.zero_lt_succ position), List.mem_singleton] at hc + subst c + convert hchild using 1 + all_goals simp + +theorem settled_leaf_of_cachedRun (hf : cache.AgreesWithFn f) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) + (hrun : CachedRun cache f (do + let endpoints ← oneTimePublicKey parameter lay tree leafIdx (otsSecret lay tree leafIdx) + leafHash parameter lay tree leafIdx endpoints)) : + Settled parameter otsSecret ftsSecret cache (.leaf lay tree leafIdx) := by + have hpublic : CachedRun cache f + (oneTimePublicKey parameter lay tree leafIdx (otsSecret lay tree leafIdx)) := hrun.bind_left + have hchains : ∀ chainIdx : ChainIndex, Settled parameter otsSecret ftsSecret cache + (.chain lay tree leafIdx chainIdx Position.lastChainStep) := by + intro chainIdx + have hchain : CachedRun cache f + (chainWalk parameter lay tree leafIdx chainIdx 0 (chainLength - 1) + (otsSecret lay tree leafIdx chainIdx)) := by + intro input hinput + apply hpublic input + exact sequenceFin_component_query_mem f _ chainIdx hinput + convert settled_chain_of_cachedRun hf lay tree leafIdx chainIdx (chainLength - 2) (by decide) + hchain using 1 + all_goals simp [Position.lastChainStep] + apply settled_of_honestInput_cached hf (by trivial) + · apply hrun + apply queriedInputs_mono_bind_right + simpa only [eval_oneTimePublicKey, honestEndpoints_def, honestInput, honestPayload, + Position.domain] using + leafHash_query_mem f parameter lay tree leafIdx + (evalWithAnswerFn f + (oneTimePublicKey parameter lay tree leafIdx (otsSecret lay tree leafIdx))) + · intro c hc + simp only [Position.children, List.mem_ofFn] at hc + obtain ⟨chainIdx, rfl⟩ := hc + exact hchains chainIdx + +theorem settled_treeNode_zero_of_cachedRun (hf : cache.AgreesWithFn f) (lay : Layer) + (tree : TreeIndex) (nodeIdx : Nat) + (hrun : CachedRun cache f (treeNode parameter lay tree (otsSecret lay tree) 0 nodeIdx)) : + Settled parameter otsSecret ftsSecret cache (.leaf lay tree (leafOfNat nodeIdx)) := by + rw [treeNode_zero_eq] at hrun + exact settled_leaf_of_cachedRun hf lay tree (leafOfNat nodeIdx) hrun + +theorem settled_treeNode_succ_of_cachedRun (hf : cache.AgreesWithFn f) (lay : Layer) + (tree : TreeIndex) (level nodeIdx : Nat) (hlevel : level < maxLayerHeight) + (hrange : TreeRange (level + 1) nodeIdx) + (hrun : CachedRun cache f + (treeNode parameter lay tree (otsSecret lay tree) (level + 1) nodeIdx)) : + Settled parameter otsSecret ftsSecret cache + (.node lay tree ⟨level, hlevel⟩ ⟨nodeIdx, hrange.index_lt⟩) := by + induction level generalizing nodeIdx with + | zero => + rw [treeNode_succ_eq] at hrun + have hleft := settled_treeNode_zero_of_cachedRun (ftsSecret := ftsSecret) hf lay tree + (2 * nodeIdx) hrun.bind_left + have hright := settled_treeNode_zero_of_cachedRun (ftsSecret := ftsSecret) hf lay tree (2 * nodeIdx + 1) + hrun.bind_right.bind_left + have hvalid : 2 * nodeIdx + 1 < 2 ^ maxLayerHeight := (TreeRange.right hrange).index_lt + apply settled_of_honestInput_cached + (p := .node lay tree ⟨0, hlevel⟩ ⟨nodeIdx, hrange.index_lt⟩) hf hvalid + · apply hrun + apply queriedInputs_mono_bind_right + apply queriedInputs_mono_bind_right + simp only [queriedInputs_tweakableHash, List.mem_singleton, honestInput, honestPayload, + Position.domain, honestNode] + · intro c hc + rw [Position.children, dif_pos hvalid, dif_neg (by simp)] at hc + rcases List.mem_pair.mp hc with hc | hc + · subst c + convert hleft using 1 + all_goals simp [leafOfNat, Nat.mod_eq_of_lt (TreeRange.left hrange).index_lt] + · subst c + convert hright using 1 + all_goals simp [leafOfNat, Nat.mod_eq_of_lt (TreeRange.right hrange).index_lt] + | succ level ih => + rw [treeNode_succ_eq] at hrun + have hleft := ih (2 * nodeIdx) (by omega) (TreeRange.left hrange) hrun.bind_left + have hright := ih (2 * nodeIdx + 1) (by omega) (TreeRange.right hrange) + hrun.bind_right.bind_left + have hvalid : 2 * nodeIdx + 1 < 2 ^ maxLayerHeight := (TreeRange.right hrange).index_lt + apply settled_of_honestInput_cached + (p := .node lay tree ⟨level + 1, hlevel⟩ ⟨nodeIdx, hrange.index_lt⟩) hf hvalid + · apply hrun + apply queriedInputs_mono_bind_right + apply queriedInputs_mono_bind_right + simp only [queriedInputs_tweakableHash, List.mem_singleton, honestInput, honestPayload, + Position.domain, honestNode] + · intro c hc + rw [Position.children, dif_pos hvalid, dif_pos (Nat.zero_lt_succ level)] at hc + rcases List.mem_pair.mp hc with hc | hc + · subst c + convert hleft using 1 + all_goals simp + · subst c + convert hright using 1 + all_goals simp + +theorem settled_treeRoot_of_cachedRun (hf : cache.AgreesWithFn f) (lay : Layer) + (tree : TreeIndex) + (hrun : CachedRun cache f (treeRoot parameter lay tree (otsSecret lay tree))) : + Settled parameter otsSecret ftsSecret cache + (.node lay tree ⟨layerHeight lay - 1, by + have hpos : 0 < layerHeight lay := by unfold layerHeight; split <;> norm_num [maxLayerHeight] + have hle := layerHeight_le lay + omega⟩ ⟨0, by positivity⟩) := by + have hpos : 0 < layerHeight lay := by unfold layerHeight; split <;> norm_num [maxLayerHeight] + have heq : layerHeight lay - 1 + 1 = layerHeight lay := by omega + have hlevel : layerHeight lay - 1 < maxLayerHeight := by + have hle := layerHeight_le lay + omega + have hrange : TreeRange (layerHeight lay) 0 := by + simp only [TreeRange, zero_add, mul_one] + exact pow_le_pow_right' (by omega) (layerHeight_le lay) + apply settled_treeNode_succ_of_cachedRun hf lay tree (layerHeight lay - 1) 0 + hlevel + · simpa only [heq] using hrange + · simpa only [treeRoot, heq] using hrun + +theorem settled_ftsLeaf_of_cachedRun (hf : cache.AgreesWithFn f) (index : Index) + (tree : FtsTree) (leafIdx : FtsLeaf) + (hrun : CachedRun cache f + (ftsLeafHash parameter index tree leafIdx (ftsSecret index tree leafIdx))) : + Settled parameter otsSecret ftsSecret cache (.ftsLeaf index tree leafIdx) := by + apply settled_of_honestInput_cached hf (by trivial) + · apply hrun + simpa only [honestInput, honestPayload, Position.domain] using + ftsLeafHash_query_mem f parameter index tree leafIdx (ftsSecret index tree leafIdx) + · simp [Position.children] + +theorem settled_ftsNode_zero_of_cachedRun (hf : cache.AgreesWithFn f) (index : Index) + (tree : FtsTree) (nodeIdx : Nat) + (hrun : CachedRun cache f (ftsNode parameter index tree (ftsSecret index tree) 0 nodeIdx)) : + Settled parameter otsSecret ftsSecret cache (.ftsLeaf index tree (ftsLeafOfNat nodeIdx)) := by + rw [ftsNode_zero_eq] at hrun + exact settled_ftsLeaf_of_cachedRun hf index tree (ftsLeafOfNat nodeIdx) hrun + +theorem settled_ftsNode_succ_of_cachedRun (hf : cache.AgreesWithFn f) (index : Index) + (tree : FtsTree) (level nodeIdx : Nat) (hlevel : level < ftsTreeHeight) + (hrange : FtsRange (level + 1) nodeIdx) + (hrun : CachedRun cache f + (ftsNode parameter index tree (ftsSecret index tree) (level + 1) nodeIdx)) : + Settled parameter otsSecret ftsSecret cache + (.ftsNode index tree ⟨level, hlevel⟩ ⟨nodeIdx, hrange.index_lt⟩) := by + induction level generalizing nodeIdx with + | zero => + rw [ftsNode_succ_eq] at hrun + have hleft := settled_ftsNode_zero_of_cachedRun (otsSecret := otsSecret) hf index tree + (2 * nodeIdx) hrun.bind_left + have hright := settled_ftsNode_zero_of_cachedRun (otsSecret := otsSecret) hf index tree + (2 * nodeIdx + 1) hrun.bind_right.bind_left + have hvalid : 2 * nodeIdx + 1 < 2 ^ ftsTreeHeight := (FtsRange.right hrange).index_lt + apply settled_of_honestInput_cached + (p := .ftsNode index tree ⟨0, hlevel⟩ ⟨nodeIdx, hrange.index_lt⟩) hf hvalid + · apply hrun + apply queriedInputs_mono_bind_right + apply queriedInputs_mono_bind_right + simp only [queriedInputs_tweakableHash, List.mem_singleton, honestInput, honestPayload, + Position.domain, honestFtsNode] + · intro c hc + rw [Position.children, dif_pos hvalid, dif_neg (by simp)] at hc + rcases List.mem_pair.mp hc with hc | hc + · subst c + convert hleft using 1 + all_goals simp [ftsLeafOfNat, Nat.mod_eq_of_lt (FtsRange.left hrange).index_lt] + · subst c + convert hright using 1 + all_goals simp [ftsLeafOfNat, Nat.mod_eq_of_lt (FtsRange.right hrange).index_lt] + | succ level ih => + rw [ftsNode_succ_eq] at hrun + have hleft := ih (2 * nodeIdx) (by omega) (FtsRange.left hrange) hrun.bind_left + have hright := ih (2 * nodeIdx + 1) (by omega) (FtsRange.right hrange) + hrun.bind_right.bind_left + have hvalid : 2 * nodeIdx + 1 < 2 ^ ftsTreeHeight := (FtsRange.right hrange).index_lt + apply settled_of_honestInput_cached + (p := .ftsNode index tree ⟨level + 1, hlevel⟩ ⟨nodeIdx, hrange.index_lt⟩) hf hvalid + · apply hrun + apply queriedInputs_mono_bind_right + apply queriedInputs_mono_bind_right + simp only [queriedInputs_tweakableHash, List.mem_singleton, honestInput, honestPayload, + Position.domain, honestFtsNode] + · intro c hc + rw [Position.children, dif_pos hvalid, dif_pos (Nat.zero_lt_succ level)] at hc + rcases List.mem_pair.mp hc with hc | hc + · subst c + convert hleft using 1 + all_goals simp + · subst c + convert hright using 1 + all_goals simp + +theorem settled_ftsRoots_of_cachedRun (hf : cache.AgreesWithFn f) (index : Index) + (hrun : CachedRun cache f (ftsKey parameter index (ftsSecret index))) : + Settled parameter otsSecret ftsSecret cache (.ftsRoots index) := by + have hroots : ∀ tree : FtsTree, Settled parameter otsSecret ftsSecret cache + (.ftsNode index tree ⟨ftsTreeHeight - 1, by decide⟩ ⟨0, by positivity⟩) := by + intro tree + have htree : CachedRun cache f + (ftsNode parameter index tree (ftsSecret index tree) ftsTreeHeight 0) := by + intro input hinput + apply hrun.bind_left input + exact sequenceFin_component_query_mem f _ tree hinput + have hrange : FtsRange ftsTreeHeight 0 := by simp [FtsRange] + convert settled_ftsNode_succ_of_cachedRun hf index tree (ftsTreeHeight - 1) 0 (by decide) + (by simpa [ftsTreeHeight] using hrange) (by simpa [ftsTreeHeight] using htree) using 1 + apply settled_of_honestInput_cached hf (by trivial) + · apply hrun + apply queriedInputs_mono_bind_right + simpa only [evalWithAnswerFn_sequenceFin, honestInput, honestPayload, Position.domain, + honestFtsNode] using + (show tweakableHashInput parameter (.ftsRoots index) + (ftsRootsPayload fun tree => evalWithAnswerFn f + (ftsNode parameter index tree (ftsSecret index tree) ftsTreeHeight 0)) + ∈ queriedInputs f + (tweakableHash parameter (.ftsRoots index) + (ftsRootsPayload fun tree => evalWithAnswerFn f + (ftsNode parameter index tree (ftsSecret index tree) ftsTreeHeight 0))) by simp) + · intro c hc + simp only [Position.children, List.mem_ofFn] at hc + obtain ⟨tree, rfl⟩ := hc + exact hroots tree + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Chain.lean b/formal/sphincs/SphincsSecurity/Proof/Chain.lean new file mode 100644 index 00000000..86055737 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Chain.lean @@ -0,0 +1,29 @@ +import SphincsSecurity.Statement + +/-! +# The hash chain + +Walking `a` steps from `start` and then `b` more is walking `a + b` steps. Everything the one-time +signature needs follows: the verifier's half of a chain, `recoverChain`, composes with the signer's +half to reach the public value the leaf is built from. +-/ + +namespace SphincsSecurity.Concrete + +variable {m : Type → Type} [Monad m] [LawfulMonad m] [HasQuery HashSpec m] + +/-- Steps compose. Positions past the last chain step are the constant `0` on both sides, so no +range hypothesis is needed. -/ +theorem chainWalk_add (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leaf : LeafIndex) (chainIdx : ChainIndex) (start a b : Nat) (value : Digest) : + chainWalk (m := m) parameter lay tree leaf chainIdx start (a + b) value + = (do + let mid ← chainWalk (m := m) parameter lay tree leaf chainIdx start a value + chainWalk parameter lay tree leaf chainIdx (start + a) b mid) := by + induction b with + | zero => simp [chainWalk] + | succ b ih => + show chainWalk (m := m) parameter lay tree leaf chainIdx start (a + b + 1) value = _ + simp only [chainWalk, ih, bind_assoc, Nat.add_assoc] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/Charge.lean b/formal/sphincs/SphincsSecurity/Proof/Charge.lean new file mode 100644 index 00000000..d0956816 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Charge.lean @@ -0,0 +1,958 @@ +import SphincsSecurity.Proof.Settled +import SphincsSecurity.Proof.Slot + +/-! +# The bad event and what pays for it + +`Bad` is the event the reduction charges: a settled position, its honest input cached, and another +cached input at the same tweak whose answer agrees with it after truncation. It is a property of the +cache alone, which is what lets the accounting of `Amortized` bound it. + +The potential is one unit per cached input at an unsettled position's tweak, plus one for each of +that position's children still unsettled. The first pays for the answer that settles the position, +which has to miss every input already cached at its tweak; the second pays for the answer that fixes +the honest input one level up, which may find it already cached. + +This module also proves what makes the charge finite: with one query, only the position of the queried +input can become settled, unless its parent does. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +variable (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + +/-- The input is hashed at the position's tweak. -/ +def AtPosition (input : HashInput) (p : Position) : Prop := + ∃ payload, input = tweakableHashInput parameter p.domain payload + +theorem atPosition_honestInput (f : QueryImpl HashSpec Id) (p : Position) : + AtPosition parameter (honestInput f parameter otsSecret ftsSecret p) p := + ⟨_, rfl⟩ + +theorem atPosition_cachedInput (cache : QueryCache HashSpec) (p : Position) : + AtPosition parameter (cachedInput parameter otsSecret ftsSecret cache p) p := + ⟨_, rfl⟩ + +/-- **A tweak names one position.** -/ +theorem atPosition_unique {input : HashInput} {p q : Position} (hp : AtPosition parameter input p) + (hq : AtPosition parameter input q) : p = q := by + obtain ⟨payload, hpayload⟩ := hp + obtain ⟨payload', hpayload'⟩ := hq + exact Position.domain_injective (tweakableHashInput_injective parameter + (Position.domain_inRange p) (Position.domain_inRange q) (hpayload ▸ hpayload')).1 + +theorem atPosition_ne {input input' : HashInput} {p q : Position} (hp : AtPosition parameter input p) + (hq : AtPosition parameter input' q) (hne : p ≠ q) : input ≠ input' := fun heq => + hne (atPosition_unique parameter hp (heq ▸ hq)) + +/-- The cache holds a hit: a settled position whose honest answer another cached input at the same +tweak reproduces after truncation. -/ +def Bad (cache : QueryCache HashSpec) : Prop := + ∃ p : Position, Settled parameter otsSecret ftsSecret cache p ∧ ∃ input ax ay, + AtPosition parameter input p ∧ input ≠ cachedInput parameter otsSecret ftsSecret cache p + ∧ cache input = some ax + ∧ cache (cachedInput parameter otsSecret ftsSecret cache p) = some ay + ∧ truncateHash ax = truncateHash ay + +theorem Bad.mono {cache cache' : QueryCache HashSpec} (hle : cache ≤ cache') + (hbad : Bad parameter otsSecret ftsSecret cache) : + Bad parameter otsSecret ftsSecret cache' := by + obtain ⟨position, hsettled, input, inputAnswer, honestAnswer, hposition, + hne, hinput, hhonest, hcollision⟩ := hbad + have hpinned := cachedInput_eq_of_settled hle hsettled + refine ⟨position, hsettled.mono hle, input, inputAnswer, honestAnswer, + hposition, ?_, hle hinput, ?_, hcollision⟩ + · rwa [hpinned] + · rw [hpinned] + exact hle hhonest + +/-- A cached collision with the honest value at a settled position is `Bad`. -/ +theorem bad_of_settled_collision {cache : QueryCache HashSpec} {f : QueryImpl HashSpec Id} + (hf : cache.AgreesWithFn f) {p : Position} + (hsettled : Settled parameter otsSecret ftsSecret cache p) {input : HashInput} + (hposition : AtPosition parameter input p) + (hne : input ≠ honestInput f parameter otsSecret ftsSecret p) + (hcached : cache input ≠ none) + (hvalue : truncateHash (f input) = honestValue f parameter otsSecret ftsSecret p) : + Bad parameter otsSecret ftsSecret cache := by + obtain ⟨ax, hax⟩ := Option.ne_none_iff_exists'.mp hcached + obtain ⟨ay, hay⟩ := Option.ne_none_iff_exists'.mp hsettled.cached + have hpinned := honestInput_eq_cachedInput hf hsettled + refine ⟨p, hsettled, input, ax, ay, hposition, ?_, hax, hay, ?_⟩ + · rwa [hpinned] at hne + · rw [← hf hax, ← hf hay, hvalue, honestValue, hpinned] + +theorem bad_of_settled_payload_collision {cache : QueryCache HashSpec} + {f : QueryImpl HashSpec Id} (hf : cache.AgreesWithFn f) {p : Position} + (hsettled : Settled parameter otsSecret ftsSecret cache p) {payload : HashInput} + (hpayload : payload ≠ honestPayload f parameter otsSecret ftsSecret p) + (hcached : cache (tweakableHashInput parameter p.domain payload) ≠ none) + (hvalue : truncateHash (f (tweakableHashInput parameter p.domain payload)) + = honestValue f parameter otsSecret ftsSecret p) : + Bad parameter otsSecret ftsSecret cache := by + apply bad_of_settled_collision parameter otsSecret ftsSecret hf hsettled + (hposition := ⟨payload, rfl⟩) (hcached := hcached) (hvalue := hvalue) + intro heq + apply hpayload + exact (tweakableHashInput_injective parameter (Position.domain_inRange p) + (Position.domain_inRange p) (by simpa [honestInput] using heq)).2 + +/-! ### One fresh query -/ + +theorem le_cacheQuery {cache : QueryCache HashSpec} {input : HashInput} {answer : HashOutput} + (huncached : cache input = none) : cache ≤ cache.cacheQuery input answer := by + intro x u hx + by_cases hxeq : x = input + · rw [hxeq, huncached] at hx + simp at hx + · rwa [QueryCache.cacheQuery_of_ne _ _ hxeq] + +/-- **Only the queried position can settle.** A fresh query settles no position other than the one +its input is at, unless it settles that position's parent. -/ +theorem settled_of_settled_cacheQuery {cache : QueryCache HashSpec} {input₀ : HashInput} + {answer : HashOutput} (huncached : cache input₀ = none) {p₀ : Option Position} + (hposition : ∀ q, AtPosition parameter input₀ q → p₀ = some q) + (hparent : ∀ q q₁, p₀ = some q → Position.parentOf q = some q₁ → + ¬ Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) q₁) : + ∀ (n : Nat) (q : Position), q.depth < n → p₀ ≠ some q → + Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) q → + Settled parameter otsSecret ftsSecret cache q := by + have hle := le_cacheQuery (cache := cache) (input := input₀) (answer := answer) huncached + intro n + induction n with + | zero => intro q hdepth; omega + | succ n ih => + intro q hdepth hne hsettled + have hchildren : ∀ c ∈ q.children, Settled parameter otsSecret ftsSecret cache c := by + intro c hc + have hcne : p₀ ≠ some c := by + intro hcp + exact hparent c q hcp (Position.mem_children_iff.mp hc) hsettled + exact ih c (by have := Position.depth_lt_of_mem_children hc; omega) hcne + (hsettled.children c hc) + have hvalues : ∀ c ∈ q.children, + honestValue (fromCache (cache.cacheQuery input₀ answer)) parameter otsSecret ftsSecret c + = honestValue (fromCache cache) parameter otsSecret ftsSecret c := fun c hc => + honestValue_eq_of_settled (agreesWithFn_fromCache_of_le hle) (hchildren c hc) + have hinput : cachedInput parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) q + = cachedInput parameter otsSecret ftsSecret cache q := + honestInput_congr _ _ parameter otsSecret ftsSecret hsettled.valid hvalues + have hcached := hsettled.cached + rw [hinput] at hcached + have hinputne : cachedInput parameter otsSecret ftsSecret cache q ≠ input₀ := by + intro heq + exact hne (hposition q (heq ▸ atPosition_cachedInput parameter otsSecret ftsSecret cache q)) + rw [QueryCache.cacheQuery_of_ne _ _ hinputne] at hcached + rw [settled_iff] + exact ⟨hsettled.valid, hcached, hchildren⟩ + +/-- Querying another input at an already settled position settles nothing new. -/ +theorem settled_of_cacheQuery_at_settled {cache : QueryCache HashSpec} {input₀ : HashInput} + {answer : HashOutput} {p₀ : Position} (huncached : cache input₀ = none) + (hposition : AtPosition parameter input₀ p₀) + (hsettled₀ : Settled parameter otsSecret ftsSecret cache p₀) : + ∀ (n : Nat) (p : Position), p.depth < n → + Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p → + Settled parameter otsSecret ftsSecret cache p := by + have hle := le_cacheQuery (cache := cache) (input := input₀) (answer := answer) huncached + intro n + induction n with + | zero => intro p hdepth; omega + | succ n ih => + intro p hdepth hsettled + by_cases hp : p = p₀ + · simpa [hp] using hsettled₀ + · have hchildren : ∀ c ∈ p.children, Settled parameter otsSecret ftsSecret cache c := by + intro c hc + exact ih c (by have := Position.depth_lt_of_mem_children hc; omega) + (hsettled.children c hc) + have hvalues : ∀ c ∈ p.children, + honestValue (fromCache (cache.cacheQuery input₀ answer)) parameter otsSecret ftsSecret c + = honestValue (fromCache cache) parameter otsSecret ftsSecret c := fun c hc => + honestValue_eq_of_settled (agreesWithFn_fromCache_of_le hle) (hchildren c hc) + have hinput : cachedInput parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p + = cachedInput parameter otsSecret ftsSecret cache p := + honestInput_congr _ _ parameter otsSecret ftsSecret hsettled.valid hvalues + have hinputne : cachedInput parameter otsSecret ftsSecret cache p ≠ input₀ := + atPosition_ne parameter (atPosition_cachedInput parameter otsSecret ftsSecret cache p) + hposition hp + rw [settled_iff] + refine ⟨hsettled.valid, ?_, hchildren⟩ + have hcached := hsettled.cached + rw [hinput, QueryCache.cacheQuery_of_ne _ _ hinputne] at hcached + exact hcached + +/-- Below the queried position, a fresh query settles nothing. -/ +theorem settled_of_cacheQuery_below {cache : QueryCache HashSpec} {input₀ : HashInput} + {answer : HashOutput} {p₀ : Position} (huncached : cache input₀ = none) + (hposition : AtPosition parameter input₀ p₀) : + ∀ (n : Nat) (p : Position), p.depth < n → p.depth < p₀.depth → + Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p → + Settled parameter otsSecret ftsSecret cache p := by + have hle := le_cacheQuery (cache := cache) (input := input₀) (answer := answer) huncached + intro n + induction n with + | zero => intro p hdepth; omega + | succ n ih => + intro p hdepth hbelow hsettled + have hp : p ≠ p₀ := by intro heq; subst heq; omega + have hchildren : ∀ c ∈ p.children, Settled parameter otsSecret ftsSecret cache c := by + intro c hc + exact ih c (by have := Position.depth_lt_of_mem_children hc; omega) + (by have := Position.depth_lt_of_mem_children hc; omega) (hsettled.children c hc) + have hvalues : ∀ c ∈ p.children, + honestValue (fromCache (cache.cacheQuery input₀ answer)) parameter otsSecret ftsSecret c + = honestValue (fromCache cache) parameter otsSecret ftsSecret c := fun c hc => + honestValue_eq_of_settled (agreesWithFn_fromCache_of_le hle) (hchildren c hc) + have hinput : cachedInput parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p + = cachedInput parameter otsSecret ftsSecret cache p := + honestInput_congr _ _ parameter otsSecret ftsSecret hsettled.valid hvalues + have hinputne : cachedInput parameter otsSecret ftsSecret cache p ≠ input₀ := + atPosition_ne parameter (atPosition_cachedInput parameter otsSecret ftsSecret cache p) + hposition hp + rw [settled_iff] + refine ⟨hsettled.valid, ?_, hchildren⟩ + have hcached := hsettled.cached + rw [hinput, QueryCache.cacheQuery_of_ne _ _ hinputne] at hcached + exact hcached + +/-- If a fresh query settles its own previously unsettled position, it was the honest input and all +children were settled before the query. -/ +theorem eq_cachedInput_and_children_of_settled_cacheQuery {cache : QueryCache HashSpec} + {input₀ : HashInput} {answer : HashOutput} {p₀ : Position} + (huncached : cache input₀ = none) (hposition : AtPosition parameter input₀ p₀) + (hunsettled : ¬ Settled parameter otsSecret ftsSecret cache p₀) + (hsettled : Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p₀) : + input₀ = cachedInput parameter otsSecret ftsSecret cache p₀ + ∧ ∀ c ∈ p₀.children, Settled parameter otsSecret ftsSecret cache c := by + have hle := le_cacheQuery (cache := cache) (input := input₀) (answer := answer) huncached + have hchildren : ∀ c ∈ p₀.children, Settled parameter otsSecret ftsSecret cache c := by + intro c hc + exact settled_of_cacheQuery_below parameter otsSecret ftsSecret huncached hposition + (c.depth + 1) c (by omega) (Position.depth_lt_of_mem_children hc) (hsettled.children c hc) + have hvalues : ∀ c ∈ p₀.children, + honestValue (fromCache (cache.cacheQuery input₀ answer)) parameter otsSecret ftsSecret c + = honestValue (fromCache cache) parameter otsSecret ftsSecret c := fun c hc => + honestValue_eq_of_settled (agreesWithFn_fromCache_of_le hle) (hchildren c hc) + have hinput : cachedInput parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p₀ + = cachedInput parameter otsSecret ftsSecret cache p₀ := + honestInput_congr _ _ parameter otsSecret ftsSecret hsettled.valid hvalues + refine ⟨?_, hchildren⟩ + by_contra hne + apply hunsettled + rw [settled_iff] + refine ⟨hsettled.valid, ?_, hchildren⟩ + have hcached := hsettled.cached + have hne' : cachedInput parameter otsSecret ftsSecret cache p₀ ≠ input₀ := + fun h => hne h.symm + rw [hinput, QueryCache.cacheQuery_of_ne _ _ hne'] at hcached + exact hcached + +theorem honestValue_cacheQuery_self_of_settled {cache : QueryCache HashSpec} + {input₀ : HashInput} {answer : HashOutput} {p₀ : Position} + (huncached : cache input₀ = none) (hposition : AtPosition parameter input₀ p₀) + (hunsettled : ¬ Settled parameter otsSecret ftsSecret cache p₀) + (hsettled : Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p₀) : + honestValue (fromCache (cache.cacheQuery input₀ answer)) parameter otsSecret ftsSecret p₀ + = truncateHash answer := by + obtain ⟨hinput₀, hchildren⟩ := eq_cachedInput_and_children_of_settled_cacheQuery + parameter otsSecret ftsSecret huncached hposition hunsettled hsettled + have hle := le_cacheQuery (cache := cache) (input := input₀) (answer := answer) huncached + have hvalues : ∀ c ∈ p₀.children, + honestValue (fromCache (cache.cacheQuery input₀ answer)) parameter otsSecret ftsSecret c + = honestValue (fromCache cache) parameter otsSecret ftsSecret c := fun c hc => + honestValue_eq_of_settled (agreesWithFn_fromCache_of_le hle) (hchildren c hc) + have hinput : cachedInput parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p₀ + = cachedInput parameter otsSecret ftsSecret cache p₀ := + honestInput_congr _ _ parameter otsSecret ftsSecret hsettled.valid hvalues + change truncateHash (fromCache (cache.cacheQuery input₀ answer) + (cachedInput parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p₀)) + = truncateHash answer + rw [hinput, ← hinput₀] + simp [fromCache] + +/-! ### The potential -/ + +/-- The inputs the cache holds at a position's tweak. -/ +def cachedAt (cache : QueryCache HashSpec) (p : Position) : Set HashInput := + {input | cache input ≠ none ∧ AtPosition parameter input p} + +/-- The cache holds finitely many inputs. Every cache a run produces does, and the accounting needs +it to count. -/ +def Finite (cache : QueryCache HashSpec) : Prop := {input | cache input ≠ none}.Finite + +theorem finite_empty : Finite (∅ : QueryCache HashSpec) := by + simp [Finite] + +theorem Finite.of_le {cache cache' : QueryCache HashSpec} + (hfinite : Finite cache') (hle : cache ≤ cache') : Finite cache := by + apply hfinite.subset + intro input hcached + obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hcached + exact Option.ne_none_iff_exists'.mpr ⟨answer, hle hanswer⟩ + +theorem Finite.of_enncard_le {cache : QueryCache HashSpec} {q : Nat} + (hle : QueryCache.enncard cache ≤ (q : ℝ≥0∞)) : Finite cache := by + rw [QueryCache.enncard] at hle + have hfiniteToSet : cache.toSet.Finite := by + rw [← Set.encard_ne_top_iff] + intro htop + rw [htop] at hle + exact not_top_le_coe hle + let cachedInputs : Set HashInput := {input | cache input ≠ none} + have hsubset : cachedInputs ⊆ Sigma.fst '' cache.toSet := by + intro input hcached + obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hcached + exact ⟨⟨input, answer⟩, hanswer, rfl⟩ + exact (hfiniteToSet.image Sigma.fst).subset hsubset + +theorem Finite.cachedInputs_ncard_toENNReal_eq_enncard + {cache : QueryCache HashSpec} (hfinite : Finite cache) : + ({input | cache input ≠ none}.ncard : ℝ≥0∞) = QueryCache.enncard cache := by + let cachedInputs : Set HashInput := {input | cache input ≠ none} + have himage : Sigma.fst '' cache.toSet = cachedInputs := by + ext input + constructor + · rintro ⟨⟨cachedInput, answer⟩, hcached, heq⟩ + subst input + change cache cachedInput = some answer at hcached + exact Option.ne_none_iff_exists'.mpr ⟨answer, hcached⟩ + · intro hcached + obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hcached + exact ⟨⟨input, answer⟩, hanswer, rfl⟩ + have hinjective : Set.InjOn Sigma.fst cache.toSet := by + rintro ⟨leftInput, leftAnswer⟩ hleft ⟨rightInput, rightAnswer⟩ hright heq + simp only at heq + subst rightInput + change cache leftInput = some leftAnswer at hleft + change cache leftInput = some rightAnswer at hright + have hanswer : leftAnswer = rightAnswer := by + rw [hleft] at hright + exact Option.some.inj hright + subst rightAnswer + rfl + have hencard : cachedInputs.encard = cache.toSet.encard := by + rw [← himage] + exact hinjective.encard_image + have hcast := hfinite.cast_ncard_eq.trans hencard + simpa only [cachedInputs, QueryCache.enncard, ENat.toENNReal_coe] using + congrArg ENat.toENNReal hcast + +theorem not_bad_empty : ¬ Bad parameter otsSecret ftsSecret (∅ : QueryCache HashSpec) := by + rintro ⟨p, _, input, ax, ay, _, _, hcached, _⟩ + simp at hcached + +theorem finite_cacheQuery {cache : QueryCache HashSpec} (hfinite : Finite cache) + (input : HashInput) (answer : HashOutput) : Finite (cache.cacheQuery input answer) := by + refine Set.Finite.subset (hfinite.insert input) fun x hx => ?_ + by_cases hxeq : x = input + · exact Set.mem_insert_iff.mpr (Or.inl hxeq) + · refine Set.mem_insert_iff.mpr (Or.inr ?_) + simpa only [Set.mem_setOf_eq, QueryCache.cacheQuery_of_ne _ _ hxeq] using hx + +theorem cachedAt_finite {cache : QueryCache HashSpec} (hfinite : Finite cache) (p : Position) : + (cachedAt parameter cache p).Finite := + hfinite.subset fun _ hx => hx.1 + +/-- Truncated answers already cached at a position. -/ +noncomputable def answerTargets (cache : QueryCache HashSpec) (hfinite : Finite cache) + (p : Position) : Finset Digest := + open Classical in + (cachedAt_finite parameter hfinite p).toFinset.image fun input => + truncateHash ((cache input).getD 0) + +theorem answerTargets_card_le (cache : QueryCache HashSpec) (hfinite : Finite cache) + (p : Position) : + (answerTargets parameter cache hfinite p).card ≤ (cachedAt parameter cache p).ncard := by + rw [answerTargets] + refine (Finset.card_image_le.trans_eq ?_) + exact (Set.ncard_eq_toFinset_card _ (cachedAt_finite parameter hfinite p)).symm + +theorem mem_answerTargets {cache : QueryCache HashSpec} (hfinite : Finite cache) {p : Position} + {input : HashInput} (hinput : input ∈ cachedAt parameter cache p) : + truncateHash ((cache input).getD 0) ∈ answerTargets parameter cache hfinite p := by + classical + rw [answerTargets] + exact Finset.mem_image.mpr ⟨input, + (cachedAt_finite parameter hfinite p).mem_toFinset.mpr hinput, rfl⟩ + +/-- Payload blocks of cached inputs at a parent, at the slot occupied by one of its children. -/ +noncomputable def slotTargets (cache : QueryCache HashSpec) (hfinite : Finite cache) + (child parent : Position) : Finset Digest := + open Classical in + (cachedAt_finite parameter hfinite parent).toFinset.image fun input => + slotDigest (parent.children.idxOf child) input + +theorem slotTargets_card_le (cache : QueryCache HashSpec) (hfinite : Finite cache) + (child parent : Position) : + (slotTargets parameter cache hfinite child parent).card + ≤ (cachedAt parameter cache parent).ncard := by + rw [slotTargets] + refine (Finset.card_image_le.trans_eq ?_) + exact (Set.ncard_eq_toFinset_card _ (cachedAt_finite parameter hfinite parent)).symm + +theorem mem_slotTargets {cache : QueryCache HashSpec} (hfinite : Finite cache) + {child parent : Position} {input : HashInput} (hinput : input ∈ cachedAt parameter cache parent) : + slotDigest (parent.children.idxOf child) input + ∈ slotTargets parameter cache hfinite child parent := by + classical + rw [slotTargets] + exact Finset.mem_image.mpr ⟨input, + (cachedAt_finite parameter hfinite parent).mem_toFinset.mpr hinput, rfl⟩ + +/-- Avoiding a child's slot targets prevents that query from settling the child's parent. -/ +theorem not_settled_parent_of_avoids_slotTargets {cache : QueryCache HashSpec} + (hfinite : Finite cache) {input₀ : HashInput} {answer : HashOutput} {parent child : Position} + (huncached : cache input₀ = none) (hposition : AtPosition parameter input₀ child) + (hunsettled : ¬ Settled parameter otsSecret ftsSecret cache child) + (hsettled : Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) child) + (hmem : child ∈ parent.children) + (havoid : truncateHash answer ∉ slotTargets parameter cache hfinite child parent) : + ¬ Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) parent := by + intro hparent + have hpne : parent ≠ child := by + intro heq + subst heq + have := Position.depth_lt_of_mem_children hmem + omega + have hinputne : cachedInput parameter otsSecret ftsSecret + (cache.cacheQuery input₀ answer) parent ≠ input₀ := + atPosition_ne parameter + (atPosition_cachedInput parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) parent) + hposition hpne + have hcached := hparent.cached + rw [QueryCache.cacheQuery_of_ne _ _ hinputne] at hcached + have hat : cachedInput parameter otsSecret ftsSecret + (cache.cacheQuery input₀ answer) parent ∈ cachedAt parameter cache parent := + ⟨hcached, atPosition_cachedInput parameter otsSecret ftsSecret + (cache.cacheQuery input₀ answer) parent⟩ + apply havoid + have hslot := slotDigest_honestInput_child (fromCache (cache.cacheQuery input₀ answer)) + parameter otsSecret ftsSecret hparent.valid hmem + have hvalue := honestValue_cacheQuery_self_of_settled parameter otsSecret ftsSecret + huncached hposition hunsettled hsettled + rw [hvalue] at hslot + rw [← hslot] + exact mem_slotTargets parameter hfinite hat + +/-- The targets charged when a query settles its own position. -/ +noncomputable def settlingTargets (cache : QueryCache HashSpec) (hfinite : Finite cache) + (p : Position) : Finset Digest := + match p.parentOf with + | none => answerTargets parameter cache hfinite p + | some parent => answerTargets parameter cache hfinite p ∪ + slotTargets parameter cache hfinite p parent + +theorem settlingTargets_card_le (cache : QueryCache HashSpec) (hfinite : Finite cache) + (p : Position) : + (settlingTargets parameter cache hfinite p).card ≤ (cachedAt parameter cache p).ncard + + match p.parentOf with + | none => 0 + | some parent => (cachedAt parameter cache parent).ncard := by + rw [settlingTargets] + split + · simpa using answerTargets_card_le parameter cache hfinite p + · exact (Finset.card_union_le _ _).trans (Nat.add_le_add + (answerTargets_card_le parameter cache hfinite p) + (slotTargets_card_le parameter cache hfinite p _)) + +/-- The children of a position the cache has not settled. -/ +def unsettledChildren (cache : QueryCache HashSpec) (p : Position) : Set Position := + {c | c ∈ p.children ∧ ¬ Settled parameter otsSecret ftsSecret cache c} + +theorem unsettledChildren_finite (cache : QueryCache HashSpec) (p : Position) : + (unsettledChildren parameter otsSecret ftsSecret cache p).Finite := + (p.children.finite_toSet).subset fun _ hc => hc.1 + +/-- No position has more unsettled children than the widest payload has slots. -/ +theorem unsettledChildren_ncard_le (cache : QueryCache HashSpec) (p : Position) : + (unsettledChildren parameter otsSecret ftsSecret cache p).ncard ≤ numChains := by + calc + _ ≤ (p.children.toFinset : Set Position).ncard := Set.ncard_le_ncard (by + intro c hc + simpa using hc.1) (Finset.finite_toSet p.children.toFinset) + _ = p.children.toFinset.card := by + classical + rw [Set.ncard_eq_toFinset_card _ (Finset.finite_toSet p.children.toFinset)] + congr 1 + ext c + simp + _ ≤ p.children.length := List.toFinset_card_le p.children + _ ≤ numChains := Position.children_length_le p + +/-- The summand of `potential` at one position. -/ +noncomputable def contribution (cache : QueryCache HashSpec) (p : Position) : Nat := + open Classical in + if Settled parameter otsSecret ftsSecret cache p then 0 + else (cachedAt parameter cache p).ncard + * (1 + (unsettledChildren parameter otsSecret ftsSecret cache p).ncard) + +/-- **What pays for the charges.** Per cached input at an unsettled position's tweak, one unit for +the answer that will settle the position, which has to miss every input already cached there, and one +for each child still unsettled, for the answer that fixes the honest input one level up. -/ +noncomputable def potential (cache : QueryCache HashSpec) : Nat := + open Classical in + ∑ p : Position, contribution parameter otsSecret ftsSecret cache p + +theorem potential_empty : + potential parameter otsSecret ftsSecret (∅ : QueryCache HashSpec) = 0 := by + classical + rw [potential] + refine Finset.sum_eq_zero fun p _ => ?_ + rw [contribution] + split + · rfl + · have hcachedAt : cachedAt parameter (∅ : QueryCache HashSpec) p = ∅ := by + ext input + simp [cachedAt] + rw [hcachedAt, Set.ncard_empty, Nat.zero_mul] + +/-! ### How one query moves the pieces -/ + +theorem cachedAt_cacheQuery_of_not_atPosition {cache : QueryCache HashSpec} {input₀ : HashInput} + {answer : HashOutput} {p : Position} (hp : ¬ AtPosition parameter input₀ p) : + cachedAt parameter (cache.cacheQuery input₀ answer) p = cachedAt parameter cache p := by + ext x + by_cases hxeq : x = input₀ + · subst hxeq + simp only [cachedAt, Set.mem_setOf_eq, QueryCache.cacheQuery_self] + exact ⟨fun hx => absurd hx.2 hp, fun hx => absurd hx.2 hp⟩ + · simp only [cachedAt, Set.mem_setOf_eq, QueryCache.cacheQuery_of_ne _ _ hxeq] + +theorem cachedAt_cacheQuery_self {cache : QueryCache HashSpec} {input₀ : HashInput} + {answer : HashOutput} {p : Position} (hp : AtPosition parameter input₀ p) : + cachedAt parameter (cache.cacheQuery input₀ answer) p + = insert input₀ (cachedAt parameter cache p) := by + ext x + by_cases hxeq : x = input₀ + · subst hxeq + simp only [cachedAt, Set.mem_setOf_eq, QueryCache.cacheQuery_self, Set.mem_insert_iff, + true_or, ne_eq, reduceCtorEq, not_false_eq_true, hp, and_self] + · simp only [cachedAt, Set.mem_setOf_eq, QueryCache.cacheQuery_of_ne _ _ hxeq, + Set.mem_insert_iff, hxeq, false_or] + +theorem unsettledChildren_subset {cache cache' : QueryCache HashSpec} (hle : cache ≤ cache') + (p : Position) : + unsettledChildren parameter otsSecret ftsSecret cache' p + ⊆ unsettledChildren parameter otsSecret ftsSecret cache p := fun _ hc => + ⟨hc.1, fun hsettled => hc.2 (hsettled.mono hle)⟩ + +theorem unsettledChildren_ncard_mono {cache cache' : QueryCache HashSpec} (hle : cache ≤ cache') + (p : Position) : + (unsettledChildren parameter otsSecret ftsSecret cache' p).ncard + ≤ (unsettledChildren parameter otsSecret ftsSecret cache p).ncard := + Set.ncard_le_ncard (unsettledChildren_subset parameter otsSecret ftsSecret hle p) + (unsettledChildren_finite parameter otsSecret ftsSecret cache p) + +/-- A child that settles is a unit released at its parent, for every input cached there. -/ +theorem unsettledChildren_ncard_lt {cache cache' : QueryCache HashSpec} (hle : cache ≤ cache') + {p c : Position} (hmem : c ∈ p.children) + (hunsettled : ¬ Settled parameter otsSecret ftsSecret cache c) + (hsettled : Settled parameter otsSecret ftsSecret cache' c) : + (unsettledChildren parameter otsSecret ftsSecret cache' p).ncard + 1 + ≤ (unsettledChildren parameter otsSecret ftsSecret cache p).ncard := by + refine Set.ncard_lt_ncard ⟨unsettledChildren_subset parameter otsSecret ftsSecret hle p, ?_⟩ + (unsettledChildren_finite parameter otsSecret ftsSecret cache p) + intro hsubset + exact (hsubset ⟨hmem, hunsettled⟩).2 hsettled + +/-- Away from the queried position, extending a cache can only release potential. -/ +theorem contribution_le_of_cachedAt_eq {cache cache' : QueryCache HashSpec} (hle : cache ≤ cache') + (p : Position) (hcachedAt : cachedAt parameter cache' p = cachedAt parameter cache p) : + contribution parameter otsSecret ftsSecret cache' p + ≤ contribution parameter otsSecret ftsSecret cache p := by + by_cases hsettled : Settled parameter otsSecret ftsSecret cache p + · have hsettled' := hsettled.mono hle + simp [contribution, hsettled, hsettled'] + · by_cases hsettled' : Settled parameter otsSecret ftsSecret cache' p + · simp [contribution, hsettled, hsettled'] + · simp only [contribution, hsettled, hsettled', if_false, hcachedAt] + exact Nat.mul_le_mul_left _ (Nat.add_le_add_left + (unsettledChildren_ncard_mono parameter otsSecret ftsSecret hle p) 1) + +/-- Settling a position whose children were settled releases its base unit at every cached input. -/ +theorem contribution_add_cachedAt_le_of_settled {cache cache' : QueryCache HashSpec} + {p : Position} (hunsettled : ¬ Settled parameter otsSecret ftsSecret cache p) + (hsettled : Settled parameter otsSecret ftsSecret cache' p) + (hchildren : ∀ c ∈ p.children, Settled parameter otsSecret ftsSecret cache c) : + contribution parameter otsSecret ftsSecret cache' p + (cachedAt parameter cache p).ncard + ≤ contribution parameter otsSecret ftsSecret cache p := by + have hempty : unsettledChildren parameter otsSecret ftsSecret cache p = ∅ := by + ext c + constructor + · intro hc + exact (hc.2 (hchildren c hc.1)).elim + · simp + simp [contribution, hunsettled, hsettled, hempty] + +/-- When a child settles, each cached input at its parent releases one child-slot unit. -/ +theorem contribution_add_cachedAt_le_of_child_settled {cache cache' : QueryCache HashSpec} + (hle : cache ≤ cache') {parent child : Position} (hmem : child ∈ parent.children) + (hunsettled : ¬ Settled parameter otsSecret ftsSecret cache child) + (hsettled : Settled parameter otsSecret ftsSecret cache' child) + (hcachedAt : cachedAt parameter cache' parent = cachedAt parameter cache parent) : + contribution parameter otsSecret ftsSecret cache' parent + + (cachedAt parameter cache parent).ncard + ≤ contribution parameter otsSecret ftsSecret cache parent := by + have hparentUnsettled : ¬ Settled parameter otsSecret ftsSecret cache parent := by + intro hp + exact hunsettled (hp.children child hmem) + by_cases hparentSettled : Settled parameter otsSecret ftsSecret cache' parent + · simp only [contribution, hparentSettled, hparentUnsettled, if_true, if_false, zero_add] + exact Nat.le_mul_of_pos_right _ (by positivity) + · simp only [contribution, hparentSettled, hparentUnsettled, if_false, hcachedAt] + have hdrop := unsettledChildren_ncard_lt parameter otsSecret ftsSecret hle hmem + hunsettled hsettled + nlinarith + +/-- The units released when a query settles its position pay for all of `settlingTargets`. -/ +theorem potential_add_settlingTargets_card_le {cache : QueryCache HashSpec} + (hfinite : Finite cache) {input₀ : HashInput} {answer : HashOutput} {p₀ : Position} + (huncached : cache input₀ = none) (hposition : AtPosition parameter input₀ p₀) + (hunsettled : ¬ Settled parameter otsSecret ftsSecret cache p₀) + (hsettled : Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p₀) : + potential parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) + + (settlingTargets parameter cache hfinite p₀).card + ≤ potential parameter otsSecret ftsSecret cache := by + classical + let cache' := cache.cacheQuery input₀ answer + have hle : cache ≤ cache' := le_cacheQuery huncached + obtain ⟨_, hchildren⟩ := eq_cachedInput_and_children_of_settled_cacheQuery + parameter otsSecret ftsSecret huncached hposition hunsettled hsettled + have hrelease₀ : contribution parameter otsSecret ftsSecret cache' p₀ + + (cachedAt parameter cache p₀).ncard + ≤ contribution parameter otsSecret ftsSecret cache p₀ := + contribution_add_cachedAt_le_of_settled parameter otsSecret ftsSecret hunsettled + hsettled hchildren + have hcard := settlingTargets_card_le parameter cache hfinite p₀ + cases hparent : p₀.parentOf with + | none => + simp only [hparent] at hcard + have hsum : ∑ p : Position, (contribution parameter otsSecret ftsSecret cache' p + + if p = p₀ then (cachedAt parameter cache p₀).ncard else 0) + ≤ ∑ p : Position, contribution parameter otsSecret ftsSecret cache p := by + refine Finset.sum_le_sum fun p _ => ?_ + by_cases hp : p = p₀ + · subst hp + simpa using hrelease₀ + · simp only [hp, if_false, Nat.add_zero] + have hnotAt : ¬ AtPosition parameter input₀ p := by + intro hat + exact hp (atPosition_unique parameter hat hposition) + exact contribution_le_of_cachedAt_eq parameter otsSecret ftsSecret hle p + (cachedAt_cacheQuery_of_not_atPosition parameter hnotAt) + rw [Finset.sum_add_distrib, Finset.sum_ite_eq'] at hsum + simp only [Finset.mem_univ, if_true] at hsum + change potential parameter otsSecret ftsSecret cache' + + (settlingTargets parameter cache hfinite p₀).card + ≤ potential parameter otsSecret ftsSecret cache + rw [potential, potential] + omega + | some parent => + have hmem : p₀ ∈ parent.children := Position.mem_children_iff.mpr hparent + have hpne : parent ≠ p₀ := by + intro heq + subst heq + have := Position.depth_lt_of_mem_children hmem + omega + have hcachedAt : cachedAt parameter cache' parent = cachedAt parameter cache parent := + cachedAt_cacheQuery_of_not_atPosition parameter (by + intro hat + exact hpne (atPosition_unique parameter hat hposition)) + have hreleaseParent : contribution parameter otsSecret ftsSecret cache' parent + + (cachedAt parameter cache parent).ncard + ≤ contribution parameter otsSecret ftsSecret cache parent := + contribution_add_cachedAt_le_of_child_settled parameter otsSecret ftsSecret hle hmem + hunsettled hsettled hcachedAt + simp only [hparent] at hcard + have hsum : ∑ p : Position, ((contribution parameter otsSecret ftsSecret cache' p + + if p = p₀ then (cachedAt parameter cache p₀).ncard else 0) + + if p = parent then (cachedAt parameter cache parent).ncard else 0) + ≤ ∑ p : Position, contribution parameter otsSecret ftsSecret cache p := by + refine Finset.sum_le_sum fun p _ => ?_ + by_cases hq : p = p₀ + · subst hq + simp only [if_pos, hpne.symm, if_false, Nat.add_zero] + exact hrelease₀ + · by_cases hp : p = parent + · subst hp + simp only [hpne, if_false, if_pos, Nat.add_zero] + exact hreleaseParent + · simp only [hq, hp, if_false, Nat.add_zero] + have hnotAt : ¬ AtPosition parameter input₀ p := by + intro hat + exact hq (atPosition_unique parameter hat hposition) + exact contribution_le_of_cachedAt_eq parameter otsSecret ftsSecret hle p + (cachedAt_cacheQuery_of_not_atPosition parameter hnotAt) + rw [Finset.sum_add_distrib, Finset.sum_add_distrib, Finset.sum_ite_eq', + Finset.sum_ite_eq'] at hsum + simp only [Finset.mem_univ, if_true] at hsum + change potential parameter otsSecret ftsSecret cache' + + (settlingTargets parameter cache hfinite p₀).card + ≤ potential parameter otsSecret ftsSecret cache + rw [potential, potential] + omega + +/-- If the queried position remains unsettled, the query deposits at most one slot-vector there. -/ +theorem potential_cacheQuery_le_of_unsettled {cache : QueryCache HashSpec} {input₀ : HashInput} + {answer : HashOutput} {p₀ : Position} (huncached : cache input₀ = none) + (hposition : AtPosition parameter input₀ p₀) + (hunsettled : ¬ Settled parameter otsSecret ftsSecret + (cache.cacheQuery input₀ answer) p₀) : + potential parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) + ≤ potential parameter otsSecret ftsSecret cache + 1 + numChains := by + classical + let cache' := cache.cacheQuery input₀ answer + have hle : cache ≤ cache' := le_cacheQuery huncached + have hunsettledBefore : ¬ Settled parameter otsSecret ftsSecret cache p₀ := by + intro hsettled + exact hunsettled (hsettled.mono hle) + have hunsettled' : ¬ Settled parameter otsSecret ftsSecret cache' p₀ := by + simpa [cache'] using hunsettled + have hcard : (cachedAt parameter cache' p₀).ncard + ≤ (cachedAt parameter cache p₀).ncard + 1 := by + rw [show cachedAt parameter cache' p₀ + = insert input₀ (cachedAt parameter cache p₀) from + cachedAt_cacheQuery_self parameter hposition] + exact Set.ncard_insert_le _ _ + have hchildren := unsettledChildren_ncard_mono parameter otsSecret ftsSecret hle p₀ + have hp₀ : contribution parameter otsSecret ftsSecret cache' p₀ + ≤ contribution parameter otsSecret ftsSecret cache p₀ + + 1 + (unsettledChildren parameter otsSecret ftsSecret cache p₀).ncard := by + simp only [contribution, hunsettled', hunsettledBefore, if_false] + have hmul := Nat.mul_le_mul hcard (Nat.add_le_add_left hchildren 1) + calc + _ ≤ ((cachedAt parameter cache p₀).ncard + 1) + * (1 + (unsettledChildren parameter otsSecret ftsSecret cache p₀).ncard) := hmul + _ = _ := by ring + have hwidth := unsettledChildren_ncard_le parameter otsSecret ftsSecret cache p₀ + calc + potential parameter otsSecret ftsSecret cache' + = ∑ p : Position, contribution parameter otsSecret ftsSecret cache' p := rfl + _ ≤ ∑ p : Position, (contribution parameter otsSecret ftsSecret cache p + + if p = p₀ then 1 + + (unsettledChildren parameter otsSecret ftsSecret cache p₀).ncard else 0) := by + refine Finset.sum_le_sum fun p _ => ?_ + by_cases hp : p = p₀ + · subst hp + simp only [if_pos] + omega + · simp only [hp, if_false, Nat.add_zero] + have hnotAt : ¬ AtPosition parameter input₀ p := by + intro hat + exact hp (atPosition_unique parameter hat hposition) + exact contribution_le_of_cachedAt_eq parameter otsSecret ftsSecret hle p + (cachedAt_cacheQuery_of_not_atPosition parameter hnotAt) + _ = potential parameter otsSecret ftsSecret cache + 1 + + (unsettledChildren parameter otsSecret ftsSecret cache p₀).ncard := by + rw [Finset.sum_add_distrib, Finset.sum_ite_eq'] + simp [potential] + omega + _ ≤ potential parameter otsSecret ftsSecret cache + 1 + numChains := by omega + +/-- If the queried position remains unsettled, no hit can appear. -/ +theorem clean_cacheQuery_of_unsettled {cache : QueryCache HashSpec} {input₀ : HashInput} + {answer : HashOutput} {p₀ : Position} + (hclean : ¬ Bad parameter otsSecret ftsSecret cache) (huncached : cache input₀ = none) + (hposition : AtPosition parameter input₀ p₀) + (hunsettled : ¬ Settled parameter otsSecret ftsSecret + (cache.cacheQuery input₀ answer) p₀) : + ¬ Bad parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) := by + have hle : cache ≤ cache.cacheQuery input₀ answer := le_cacheQuery huncached + rintro ⟨p, hsettled', input, ax, ay, hat, hne, hinput, hhonest, heq⟩ + have hpne : p ≠ p₀ := fun hp => hunsettled (hp ▸ hsettled') + have hsettled : Settled parameter otsSecret ftsSecret cache p := + settled_of_settled_cacheQuery parameter otsSecret ftsSecret huncached + (p₀ := some p₀) (fun q hq => by + rw [atPosition_unique parameter hposition hq]) (by + intro q parent hq hparent hparentSettled + rw [Option.some.injEq] at hq + subst hq + exact hunsettled (hparentSettled.children p₀ (Position.mem_children_iff.mpr hparent))) + (p.depth + 1) p (by omega) (by simpa using hpne.symm) hsettled' + have hpinned := cachedInput_eq_of_settled hle hsettled + have hinputne : input ≠ input₀ := + atPosition_ne parameter hat hposition hpne + have hhonestne : cachedInput parameter otsSecret ftsSecret cache p ≠ input₀ := + atPosition_ne parameter (atPosition_cachedInput parameter otsSecret ftsSecret cache p) + hposition hpne + apply hclean + refine ⟨p, hsettled, input, ax, ay, hat, ?_, ?_, ?_, heq⟩ + · rwa [hpinned] at hne + · rwa [QueryCache.cacheQuery_of_ne _ _ hinputne] at hinput + · rw [hpinned, QueryCache.cacheQuery_of_ne _ _ hhonestne] at hhonest + exact hhonest + +/-- Querying another input at a settled position cannot increase the potential. -/ +theorem potential_cacheQuery_le_of_settled {cache : QueryCache HashSpec} {input₀ : HashInput} + {answer : HashOutput} {p₀ : Position} (huncached : cache input₀ = none) + (hposition : AtPosition parameter input₀ p₀) + (hsettled : Settled parameter otsSecret ftsSecret cache p₀) : + potential parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) + ≤ potential parameter otsSecret ftsSecret cache := by + classical + have hle : cache ≤ cache.cacheQuery input₀ answer := le_cacheQuery huncached + have hsettled' : Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p₀ := + hsettled.mono hle + rw [potential, potential] + refine Finset.sum_le_sum fun p _ => ?_ + by_cases hp : p = p₀ + · subst hp + simp [contribution, hsettled, hsettled'] + · have hnotAt : ¬ AtPosition parameter input₀ p := by + intro hat + exact hp (atPosition_unique parameter hat hposition) + exact contribution_le_of_cachedAt_eq parameter otsSecret ftsSecret hle p + (cachedAt_cacheQuery_of_not_atPosition parameter hnotAt) + +/-- At a settled position the only fresh target is its pinned honest value. -/ +theorem clean_cacheQuery_of_settled_of_avoids {cache : QueryCache HashSpec} + {input₀ : HashInput} {answer : HashOutput} {p₀ : Position} + (hclean : ¬ Bad parameter otsSecret ftsSecret cache) (huncached : cache input₀ = none) + (hposition : AtPosition parameter input₀ p₀) + (hsettled₀ : Settled parameter otsSecret ftsSecret cache p₀) + (havoid : truncateHash answer ≠ + honestValue (fromCache cache) parameter otsSecret ftsSecret p₀) : + ¬ Bad parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) := by + have hle : cache ≤ cache.cacheQuery input₀ answer := le_cacheQuery huncached + rintro ⟨p, hsettled', input, ax, ay, hat, hne, hinput, hhonest, heq⟩ + have hsettled : Settled parameter otsSecret ftsSecret cache p := + settled_of_cacheQuery_at_settled parameter otsSecret ftsSecret huncached hposition hsettled₀ + (p.depth + 1) p (by omega) hsettled' + have hpinned := cachedInput_eq_of_settled hle hsettled + have hhonestne : cachedInput parameter otsSecret ftsSecret cache p ≠ input₀ := by + intro heqInput + have hcached := hsettled.cached + rw [heqInput, huncached] at hcached + simp at hcached + rw [hpinned, QueryCache.cacheQuery_of_ne _ _ hhonestne] at hhonest + by_cases hinputeq : input = input₀ + · subst hinputeq + have hp : p = p₀ := atPosition_unique parameter hat hposition + subst hp + rw [QueryCache.cacheQuery_self] at hinput + have hanswer : answer = ax := Option.some.inj hinput + apply havoid + rw [hanswer, heq, honestValue] + change truncateHash ay = truncateHash + (fromCache cache (cachedInput parameter otsSecret ftsSecret cache p)) + simp [fromCache, hhonest] + · have hinputOld : cache input = some ax := by + rwa [QueryCache.cacheQuery_of_ne _ _ hinputeq] at hinput + apply hclean + refine ⟨p, hsettled, input, ax, ay, hat, ?_, hinputOld, hhonest, heq⟩ + rwa [hpinned] at hne + +/-- If a query settles its position and avoids the charged answers and parent slots, the cache stays +clean. -/ +theorem clean_cacheQuery_of_settling_of_avoids {cache : QueryCache HashSpec} + (hfinite : Finite cache) {input₀ : HashInput} {answer : HashOutput} {p₀ : Position} + (hclean : ¬ Bad parameter otsSecret ftsSecret cache) (huncached : cache input₀ = none) + (hposition : AtPosition parameter input₀ p₀) + (hunsettled : ¬ Settled parameter otsSecret ftsSecret cache p₀) + (hsettled : Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p₀) + (havoid : truncateHash answer ∉ settlingTargets parameter cache hfinite p₀) : + ¬ Bad parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) := by + have hle : cache ≤ cache.cacheQuery input₀ answer := le_cacheQuery huncached + obtain ⟨hinput₀, hchildren⟩ := eq_cachedInput_and_children_of_settled_cacheQuery + parameter otsSecret ftsSecret huncached hposition hunsettled hsettled + have hvalues : ∀ c ∈ p₀.children, + honestValue (fromCache (cache.cacheQuery input₀ answer)) parameter otsSecret ftsSecret c + = honestValue (fromCache cache) parameter otsSecret ftsSecret c := fun c hc => + honestValue_eq_of_settled (agreesWithFn_fromCache_of_le hle) (hchildren c hc) + have hpinned₀ : cachedInput parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p₀ + = cachedInput parameter otsSecret ftsSecret cache p₀ := + honestInput_congr _ _ parameter otsSecret ftsSecret hsettled.valid hvalues + have hinputNew : cachedInput parameter otsSecret ftsSecret + (cache.cacheQuery input₀ answer) p₀ = input₀ := hpinned₀.trans hinput₀.symm + have hparentClean : ∀ q parent, some p₀ = some q → q.parentOf = some parent → + ¬ Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) parent := by + intro q parent hq hparent + rw [Option.some.injEq] at hq + subst hq + have hmem : p₀ ∈ parent.children := Position.mem_children_iff.mpr hparent + have hslotAvoid : truncateHash answer ∉ slotTargets parameter cache hfinite p₀ parent := by + intro hmemTarget + apply havoid + simp [settlingTargets, hparent, hmemTarget] + exact not_settled_parent_of_avoids_slotTargets parameter otsSecret ftsSecret hfinite + huncached hposition hunsettled hsettled hmem hslotAvoid + rintro ⟨p, hsettled', input, ax, ay, hat, hne, hinput, hhonest, heq⟩ + by_cases hp : p = p₀ + · subst hp + have hinputne : input ≠ input₀ := by rwa [hinputNew] at hne + have hinputOld : cache input = some ax := by + rwa [QueryCache.cacheQuery_of_ne _ _ hinputne] at hinput + have hcachedAt : input ∈ cachedAt parameter cache p := + ⟨by simp [hinputOld], hat⟩ + have htarget : truncateHash ax ∈ answerTargets parameter cache hfinite p := by + simpa [hinputOld] using mem_answerTargets parameter hfinite hcachedAt + rw [hinputNew, QueryCache.cacheQuery_self] at hhonest + have hanswer : answer = ay := Option.some.inj hhonest + apply havoid + have heqAnswer : truncateHash answer = truncateHash ax := by rw [hanswer, ← heq] + rw [heqAnswer] + rw [settlingTargets] + split + · exact htarget + · exact Finset.mem_union_left _ htarget + · have hsettledOld : Settled parameter otsSecret ftsSecret cache p := + settled_of_settled_cacheQuery parameter otsSecret ftsSecret huncached + (p₀ := some p₀) (fun q hq => by + rw [atPosition_unique parameter hposition hq]) hparentClean + (p.depth + 1) p (by omega) (by + intro heq + exact hp (Option.some.inj heq).symm) hsettled' + have hpinned := cachedInput_eq_of_settled hle hsettledOld + have hinputne : input ≠ input₀ := atPosition_ne parameter hat hposition hp + have hhonestne : cachedInput parameter otsSecret ftsSecret cache p ≠ input₀ := + atPosition_ne parameter (atPosition_cachedInput parameter otsSecret ftsSecret cache p) + hposition hp + have hinputOld : cache input = some ax := by + rwa [QueryCache.cacheQuery_of_ne _ _ hinputne] at hinput + rw [hpinned, QueryCache.cacheQuery_of_ne _ _ hhonestne] at hhonest + apply hclean + refine ⟨p, hsettledOld, input, ax, ay, hat, ?_, hinputOld, hhonest, heq⟩ + rwa [hpinned] at hne + +/-- An input outside every structural domain neither creates a hit nor deposits potential. -/ +theorem clean_and_potential_cacheQuery_of_not_atPosition {cache : QueryCache HashSpec} + {input₀ : HashInput} {answer : HashOutput} + (hclean : ¬ Bad parameter otsSecret ftsSecret cache) (huncached : cache input₀ = none) + (hposition : ∀ p, ¬ AtPosition parameter input₀ p) : + ¬ Bad parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) + ∧ potential parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) + ≤ potential parameter otsSecret ftsSecret cache := by + classical + have hle : cache ≤ cache.cacheQuery input₀ answer := le_cacheQuery huncached + have hpotential : potential parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) + ≤ potential parameter otsSecret ftsSecret cache := by + rw [potential, potential] + exact Finset.sum_le_sum fun p _ => + contribution_le_of_cachedAt_eq parameter otsSecret ftsSecret hle p + (cachedAt_cacheQuery_of_not_atPosition parameter (hposition p)) + refine ⟨?_, hpotential⟩ + rintro ⟨p, hsettled', input, ax, ay, hat, hne, hinput, hhonest, heq⟩ + have hsettled : Settled parameter otsSecret ftsSecret cache p := + settled_of_settled_cacheQuery parameter otsSecret ftsSecret huncached + (p₀ := none) (fun q hq => absurd hq (hposition q)) (by simp) + (p.depth + 1) p (by omega) (by simp) hsettled' + have hpinned := cachedInput_eq_of_settled hle hsettled + have hinputne : input ≠ input₀ := by + intro heqInput + exact hposition p (heqInput ▸ hat) + have hhonestne : cachedInput parameter otsSecret ftsSecret cache p ≠ input₀ := by + intro heqInput + exact hposition p (heqInput ▸ atPosition_cachedInput parameter otsSecret ftsSecret cache p) + apply hclean + refine ⟨p, hsettled, input, ax, ay, hat, ?_, ?_, ?_, heq⟩ + · rwa [hpinned] at hne + · rwa [QueryCache.cacheQuery_of_ne _ _ hinputne] at hinput + · rw [hpinned, QueryCache.cacheQuery_of_ne _ _ hhonestne] at hhonest + exact hhonest + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/ChargeStep.lean b/formal/sphincs/SphincsSecurity/Proof/ChargeStep.lean new file mode 100644 index 00000000..0bb95986 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/ChargeStep.lean @@ -0,0 +1,223 @@ +import SphincsSecurity.Proof.Amortized +import SphincsSecurity.Proof.Charge +import SphincsSecurity.Proof.Guess +import SphincsSecurity.Proof.Secrets + +/-! +# The amortized step for the cache-local bad event + +The finite target set for a fresh query, assembled from the four cache cases proven in `Charge`. +`Step` packages the witness in an inductive proposition so Lean does not repeatedly unfold the +enormous finite sum in `potential` while elaborating the dispatcher. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] potential + +set_option maxHeartbeats 1000 + +variable (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + +private theorem growth_empty (n : Nat) : + (n + 1 + numChains) + (∅ : Finset Digest).card ≤ n + 44 := by + norm_num [numChains] + +private theorem empty_growth (n : Nat) : n + (∅ : Finset Digest).card ≤ n + 44 := by + norm_num + +private theorem singleton_card_le (n : Nat) (target : Digest) : + ({target} : Finset Digest).card ≤ n + 44 := by + simp only [Finset.card_singleton] + omega + +private theorem singleton_growth (n : Nat) (target : Digest) : + n + ({target} : Finset Digest).card ≤ n + 44 := by + simp only [Finset.card_singleton] + omega + +/-- The target set and both obligations needed by `Amortized.probEvent_bad_le_amortized`. -/ +inductive Step (cache : QueryCache HashSpec) (input₀ : HashInput) : Prop where + | intro (targets : Finset Digest) + (card_le : targets.card ≤ potential parameter otsSecret ftsSecret cache + 44) + (safe : ∀ answer : HashOutput, truncateHash answer ∉ targets → + ¬ Bad parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) + ∧ potential parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) + targets.card + ≤ potential parameter otsSecret ftsSecret cache + 44) : Step cache input₀ + +private theorem step_of_unsettled_after {cache : QueryCache HashSpec} {input₀ : HashInput} + {p₀ : Position} (hclean : ¬ Bad parameter otsSecret ftsSecret cache) + (huncached : cache input₀ = none) (hposition : AtPosition parameter input₀ p₀) + (hunsettled : ∀ answer : HashOutput, + ¬ Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p₀) : + Step parameter otsSecret ftsSecret cache input₀ := by + refine Step.intro (parameter := parameter) (otsSecret := otsSecret) (ftsSecret := ftsSecret) + (cache := cache) (input₀ := input₀) ∅ (Nat.zero_le _) (fun answer _ => ?_) + have hunsettled' := hunsettled answer + refine ⟨clean_cacheQuery_of_unsettled parameter otsSecret ftsSecret hclean + (cache := cache) (input₀ := input₀) (answer := answer) (p₀ := p₀) + huncached hposition hunsettled', ?_⟩ + have hpotential := potential_cacheQuery_le_of_unsettled parameter otsSecret ftsSecret + (cache := cache) (input₀ := input₀) (answer := answer) (p₀ := p₀) + huncached hposition hunsettled' + exact (Nat.add_le_add hpotential (Nat.le_refl _)).trans + (growth_empty (potential parameter otsSecret ftsSecret cache)) + +private theorem step_of_settling {cache : QueryCache HashSpec} (hfinite : Finite cache) + {input₀ : HashInput} {p₀ : Position} + (hclean : ¬ Bad parameter otsSecret ftsSecret cache) (huncached : cache input₀ = none) + (hposition : AtPosition parameter input₀ p₀) + (hsettled : ¬ Settled parameter otsSecret ftsSecret cache p₀) + (hsettles : ∀ answer : HashOutput, + Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p₀) : + Step parameter otsSecret ftsSecret cache input₀ := by + have hpaid := potential_add_settlingTargets_card_le parameter otsSecret ftsSecret + (cache := cache) hfinite (input₀ := input₀) (answer := 0) (p₀ := p₀) + huncached hposition hsettled (hsettles 0) + have hcardBase : (settlingTargets parameter cache hfinite p₀).card + ≤ potential parameter otsSecret ftsSecret cache := + (Nat.le_add_left (settlingTargets parameter cache hfinite p₀).card + (potential parameter otsSecret ftsSecret (cache.cacheQuery input₀ 0))).trans hpaid + have hcard := hcardBase.trans + (Nat.le_add_right (potential parameter otsSecret ftsSecret cache) 44) + refine Step.intro (parameter := parameter) (otsSecret := otsSecret) (ftsSecret := ftsSecret) + (cache := cache) (input₀ := input₀) (settlingTargets parameter cache hfinite p₀) hcard + (fun answer hanswer => ?_) + have hsettled' := hsettles answer + refine ⟨clean_cacheQuery_of_settling_of_avoids parameter otsSecret ftsSecret + hfinite hclean huncached hposition hsettled hsettled' hanswer, ?_⟩ + exact (potential_add_settlingTargets_card_le parameter otsSecret ftsSecret + (cache := cache) hfinite (input₀ := input₀) (answer := answer) (p₀ := p₀) + huncached hposition hsettled hsettled').trans + (Nat.le_add_right (potential parameter otsSecret ftsSecret cache) 44) + +private theorem step_at_unsettled {cache : QueryCache HashSpec} (hfinite : Finite cache) + {input₀ : HashInput} {p₀ : Position} + (hclean : ¬ Bad parameter otsSecret ftsSecret cache) (huncached : cache input₀ = none) + (hposition : AtPosition parameter input₀ p₀) + (hsettled : ¬ Settled parameter otsSecret ftsSecret cache p₀) : + Step parameter otsSecret ftsSecret cache input₀ := by + by_cases hinput : input₀ = cachedInput parameter otsSecret ftsSecret cache p₀ + · by_cases hvalid : p₀.Valid + · by_cases hchildren : ∀ c ∈ p₀.children, Settled parameter otsSecret ftsSecret cache c + · apply step_of_settling parameter otsSecret ftsSecret hfinite hclean huncached + hposition hsettled + intro answer + have hle := le_cacheQuery (cache := cache) (input := input₀) (answer := answer) huncached + have hchildren' : ∀ c ∈ p₀.children, + Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) c := + fun c hc => (hchildren c hc).mono hle + have hvalues : ∀ c ∈ p₀.children, + honestValue (fromCache (cache.cacheQuery input₀ answer)) parameter otsSecret ftsSecret c + = honestValue (fromCache cache) parameter otsSecret ftsSecret c := fun c hc => + honestValue_eq_of_settled (agreesWithFn_fromCache_of_le hle) (hchildren c hc) + have hpinned : cachedInput parameter otsSecret ftsSecret + (cache.cacheQuery input₀ answer) p₀ + = cachedInput parameter otsSecret ftsSecret cache p₀ := + honestInput_congr _ _ parameter otsSecret ftsSecret hvalid hvalues + rw [settled_iff] + refine ⟨hvalid, ?_, hchildren'⟩ + rw [hpinned, ← hinput, QueryCache.cacheQuery_self] + simp + · apply step_of_unsettled_after parameter otsSecret ftsSecret hclean huncached hposition + intro answer hsettled' + exact hchildren (eq_cachedInput_and_children_of_settled_cacheQuery + parameter otsSecret ftsSecret huncached hposition hsettled hsettled').2 + · apply step_of_unsettled_after parameter otsSecret ftsSecret hclean huncached hposition + exact fun _ hs => hvalid hs.valid + · apply step_of_unsettled_after parameter otsSecret ftsSecret hclean huncached hposition + intro answer hsettled' + exact hinput (eq_cachedInput_and_children_of_settled_cacheQuery + parameter otsSecret ftsSecret huncached hposition hsettled hsettled').1 + +private theorem step_at_position {cache : QueryCache HashSpec} (hfinite : Finite cache) + {input₀ : HashInput} {p₀ : Position} + (hclean : ¬ Bad parameter otsSecret ftsSecret cache) (huncached : cache input₀ = none) + (hposition : AtPosition parameter input₀ p₀) : + Step parameter otsSecret ftsSecret cache input₀ := by + by_cases hsettled : Settled parameter otsSecret ftsSecret cache p₀ + · let target := honestValue (fromCache cache) parameter otsSecret ftsSecret p₀ + refine Step.intro (parameter := parameter) (otsSecret := otsSecret) (ftsSecret := ftsSecret) + (cache := cache) (input₀ := input₀) {target} + (singleton_card_le (potential parameter otsSecret ftsSecret cache) target) + (fun answer hanswer => ?_) + have havoid : truncateHash answer ≠ target := by simpa [target] using hanswer + refine ⟨clean_cacheQuery_of_settled_of_avoids parameter otsSecret ftsSecret hclean + huncached hposition hsettled havoid, ?_⟩ + have hpotential := potential_cacheQuery_le_of_settled parameter otsSecret ftsSecret + (cache := cache) (input₀ := input₀) (answer := answer) (p₀ := p₀) + huncached hposition hsettled + exact (Nat.add_le_add hpotential (Nat.le_refl _)).trans + (singleton_growth (potential parameter otsSecret ftsSecret cache) target) + · exact step_at_unsettled parameter otsSecret ftsSecret hfinite hclean huncached + hposition hsettled + +/-- **The per-query charge.** A fresh answer is dangerous only inside targets paid for by the +current potential and `44` new units. -/ +theorem bad_step (cache : QueryCache HashSpec) (hfinite : Finite cache) + (hclean : ¬ Bad parameter otsSecret ftsSecret cache) (input₀ : HashInput) + (huncached : cache input₀ = none) : Step parameter otsSecret ftsSecret cache input₀ := by + classical + by_cases hAt : ∃ p, AtPosition parameter input₀ p + · obtain ⟨p₀, hposition⟩ := hAt + exact step_at_position parameter otsSecret ftsSecret hfinite hclean huncached hposition + · refine Step.intro (parameter := parameter) (otsSecret := otsSecret) (ftsSecret := ftsSecret) + (cache := cache) (input₀ := input₀) ∅ (Nat.zero_le _) (fun answer _ => ?_) + obtain ⟨hclean', hpotential⟩ := clean_and_potential_cacheQuery_of_not_atPosition + parameter otsSecret ftsSecret hclean huncached (fun p hp => hAt ⟨p, hp⟩) + refine ⟨hclean', ?_⟩ + exact (Nat.add_le_add hpotential (Nat.le_refl _)).trans + (empty_growth (potential parameter otsSecret ftsSecret cache)) + +/-- **The amortized bad-event bound.** A `q`-query computation makes `Bad` true with probability at +most `(44q + potential) / 2^128`. -/ +theorem probEvent_bad_le {α : Type} (oa : OracleComp OracleWorld α) (q : Nat) + (hq : oa.IsQueryBoundP (· matches Sum.inr _) q) (cache : QueryCache HashSpec) + (hfinite : Finite cache) (hclean : ¬ Bad parameter otsSecret ftsSecret cache) : + Pr[fun result => Bad parameter otsSecret ftsSecret result.2 + | (simulateQ romImpl oa).run cache] + ≤ ((44 * q + potential parameter otsSecret ftsSecret cache : Nat) : ℝ≥0∞) + * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply probEvent_bad_le_amortized + (Bad := Bad parameter otsSecret ftsSecret) (Inv := Finite) + (potential := potential parameter otsSecret ftsSecret) (c := 44) + · intro target + rw [← probOutput_map] + exact probOutput_truncateHash_le target + · intro cache' input answer hfinite' + exact finite_cacheQuery hfinite' input answer + · intro cache' hfinite' hclean' input huncached + rcases bad_step parameter otsSecret ftsSecret cache' hfinite' hclean' input huncached with + ⟨targets, hcard, hsafe⟩ + exact ⟨targets, hcard, hsafe⟩ + · exact hq + · exact hfinite + · exact hclean + +namespace Concrete + +/-- The accounted SPHINCS run starts clean with zero potential, so its structural-hit probability is +at most `44q / 2^128`. -/ +theorem probEvent_bad_gameAfterSecrets_le (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : (gameAfterSecrets adversary parameter otsSecret ftsSecret).IsQueryBoundP + (· matches Sum.inr _) q) : + Pr[fun result => Bad parameter otsSecret ftsSecret result.2 + | (simulateQ romImpl (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅] + ≤ ((44 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + have hbound := probEvent_bad_le parameter otsSecret ftsSecret + (gameAfterSecrets adversary parameter otsSecret ftsSecret) q hq ∅ + finite_empty (not_bad_empty parameter otsSecret ftsSecret) + rw [potential_empty, Nat.add_zero] at hbound + exact hbound + +end Concrete + +set_option maxHeartbeats 0 + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Code.lean b/formal/sphincs/SphincsSecurity/Proof/Code.lean new file mode 100644 index 00000000..294b07de --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Code.lean @@ -0,0 +1,211 @@ +import SphincsSecurity.Proof.Bytes +import Mathlib.Data.BitVec + +/-! +# The target-sum code + +Two codewords of equal digit sum cannot be ordered componentwise unless they are equal. That is what +removes the Winternitz checksum, and what makes a one-time key unforgeable on a new message: an +adversary holding the chain values at `x` can walk each chain forward, so it can produce any +codeword above `x`, and this says the only one is `x` itself. +-/ + +namespace SphincsSecurity.TargetSum + +theorem valid_of_decodeDigest_eq_some {digest : Digest} {encoding : Encoding} + (hdecode : decodeDigest digest = some encoding) : Valid encoding := by + by_cases hvalid : digest.getLsbD 63 = false ∧ digest.getLsbD 127 = false + ∧ Valid (digestEncoding digest) + · rw [decodeDigest, if_pos hvalid] at hdecode + have hencoding : digestEncoding digest = encoding := Option.some.inj hdecode + exact hencoding ▸ hvalid.2.2 + · rw [decodeDigest, if_neg hvalid] at hdecode + simp at hdecode + +private theorem digest_eq_of_encoding_eq_of_padding {left right : Digest} + (hencoding : digestEncoding left = digestEncoding right) + (hleft63 : left.getLsbD 63 = false) (hleft127 : left.getLsbD 127 = false) + (hright63 : right.getLsbD 63 = false) (hright127 : right.getLsbD 127 = false) : + left = right := by + apply BitVec.eq_of_getLsbD_eq + intro bit hbit + by_cases hlow : bit < 63 + · let chainIdx : ChainIndex := ⟨bit / 3, by + have : bit / 3 < 21 := by omega + exact lt_of_lt_of_le this (by decide)⟩ + have hchain := congrFun hencoding chainIdx + change (left.extractLsb' (digitOffset chainIdx) winternitzBits).toFin = + (right.extractLsb' (digitOffset chainIdx) winternitzBits).toFin at hchain + have hword := BitVec.toFin_injective hchain + have hchainVal : chainIdx.val = bit / 3 := rfl + have hoffset : digitOffset chainIdx = 3 * chainIdx.val := by + rw [digitOffset, if_pos] + · norm_num [winternitzBits] + · rw [hchainVal] + norm_num [digitsPerHalf, numChains] + omega + have hwithin : bit - 3 * chainIdx.val < winternitzBits := by + dsimp only [chainIdx] + norm_num [winternitzBits] + omega + have hbitEq := congrArg (fun word : BitVec winternitzBits => + word.getLsbD (bit - 3 * chainIdx.val)) hword + simpa only [digestEncoding, BitVec.getLsbD_extractLsb', hwithin, decide_true, + Bool.true_and, hoffset, show 3 * chainIdx.val + (bit - 3 * chainIdx.val) = bit by + dsimp only [chainIdx] + omega] using hbitEq + · by_cases hpad : bit = 63 + · subst bit + rw [hleft63, hright63] + · by_cases hhigh : bit < 127 + · let chainIdx : ChainIndex := ⟨21 + (bit - 64) / 3, by + have hbit64 : 64 ≤ bit := by omega + have : (bit - 64) / 3 < 21 := by omega + norm_num [numChains] + omega⟩ + have hchain := congrFun hencoding chainIdx + change (left.extractLsb' (digitOffset chainIdx) winternitzBits).toFin = + (right.extractLsb' (digitOffset chainIdx) winternitzBits).toFin at hchain + have hword := BitVec.toFin_injective hchain + have hchainVal : chainIdx.val = 21 + (bit - 64) / 3 := rfl + have hge : digitsPerHalf ≤ chainIdx.val := by + rw [hchainVal] + norm_num [digitsPerHalf, numChains] + have hoffset : digitOffset chainIdx = 64 + 3 * ((bit - 64) / 3) := by + rw [digitOffset, if_neg (by omega)] + rw [hchainVal] + norm_num [winternitzBits] + omega + have hwithin : bit - (64 + 3 * ((bit - 64) / 3)) < winternitzBits := by + norm_num [winternitzBits] + omega + have hbitEq := congrArg (fun word : BitVec winternitzBits => + word.getLsbD (bit - (64 + 3 * ((bit - 64) / 3)))) hword + simpa only [digestEncoding, BitVec.getLsbD_extractLsb', hwithin, decide_true, + Bool.true_and, hoffset, + show 64 + 3 * ((bit - 64) / 3) + + (bit - (64 + 3 * ((bit - 64) / 3))) = bit by omega] using hbitEq + · have : bit = 127 := by + have := hbit + norm_num [digestBits] at this + omega + subst bit + rw [hleft127, hright127] + +theorem decodeDigest_some_injective {left right : Digest} {encoding : Encoding} + (hleft : decodeDigest left = some encoding) + (hright : decodeDigest right = some encoding) : left = right := by + rw [decodeDigest] at hleft hright + split at hleft <;> split at hright + · rename_i hleftValid hrightValid + exact digest_eq_of_encoding_eq_of_padding (Option.some.inj hleft |>.trans + (Option.some.inj hright).symm) hleftValid.1 hleftValid.2.1 + hrightValid.1 hrightValid.2.1 + all_goals simp at hleft hright + +theorem eq_of_le_of_sum_eq {x y : Encoding} (hle : ∀ i, (x i).val ≤ (y i).val) + (hsum : sum x = sum y) : x = y := by + funext i + refine Fin.ext (le_antisymm (hle i) ?_) + by_contra hlt + have hstrict : (x i).val < (y i).val := by omega + have : sum x < sum y := by + refine Finset.sum_lt_sum (fun j _ => hle j) ⟨i, Finset.mem_univ i, hstrict⟩ + omega + +theorem eq_of_le_of_valid {x y : Encoding} (hx : Valid x) (hy : Valid y) + (hle : ∀ i, (x i).val ≤ (y i).val) : x = y := + eq_of_le_of_sum_eq hle (hx.trans hy.symm) + +def ValidDigest (digest : Digest) : Prop := + ∃ encoding, decodeDigest digest = some encoding + +noncomputable instance : DecidablePred ValidDigest := + Classical.decPred _ + +noncomputable def validDigests : Finset Digest := + Finset.univ.filter ValidDigest + +theorem validDigest_iff_decodeDigest_ne_none {digest : Digest} : + ValidDigest digest ↔ decodeDigest digest ≠ none := by + constructor + · rintro ⟨encoding, hencoding⟩ + rw [hencoding] + simp + · intro hdecode + obtain ⟨encoding, hencoding⟩ := Option.ne_none_iff_exists'.mp hdecode + exact ⟨encoding, hencoding⟩ + +@[simp] theorem mem_validDigests {digest : Digest} : + digest ∈ validDigests ↔ ValidDigest digest := by + simp [validDigests] + +theorem ValidDigest.of_eq {left right : Digest} (hleft : ValidDigest left) + (heq : left = right) : ValidDigest right := by + rwa [← heq] + +def exampleValidDigest : Digest := + BitVec.ofNat digestBits 0x00000000000bffff7fffffffffffffff + +theorem exampleValidDigest_valid : ValidDigest exampleValidDigest := by + refine ⟨digestEncoding exampleValidDigest, ?_⟩ + decide + +theorem validDigests_nonempty : validDigests.Nonempty := by + exact ⟨exampleValidDigest, Finset.mem_filter.mpr + ⟨Finset.mem_univ _, exampleValidDigest_valid⟩⟩ + +theorem validDigests_card_pos : 0 < validDigests.card := + Finset.card_pos.mpr validDigests_nonempty + +/-- A concatenation of fixed-length blocks determines the blocks. -/ +theorem flatMap_ofFn_injective {α β : Type} (g : α → List β) (len : Nat) + (hlen : ∀ a, (g a).length = len) (hinj : ∀ a b, g a = g b → a = b) : + ∀ {n : Nat} {f f' : Fin n → α}, + (List.ofFn f).flatMap g = (List.ofFn f').flatMap g → f = f' := by + intro n + induction n with + | zero => intro f f' _; funext i; exact i.elim0 + | succ n ih => + intro f f' h + simp only [List.ofFn_succ, List.flatMap_cons] at h + obtain ⟨hhead, htail⟩ := List.append_inj h (by rw [hlen, hlen]) + have hzero := hinj _ _ hhead + have hsucc := ih htail + funext i + cases i using Fin.cases with + | zero => exact hzero + | succ j => exact congrFun hsucc j + +/-- The same, for lists: a concatenation of fixed-length blocks determines the blocks. -/ +theorem flatMap_injective {α β : Type} (g : α → List β) (len : Nat) + (hlen : ∀ a, (g a).length = len) (hinj : ∀ a b, g a = g b → a = b) : + ∀ {xs ys : List α}, xs.length = ys.length → xs.flatMap g = ys.flatMap g → xs = ys := by + intro xs + induction xs with + | nil => + intro ys hlength _ + exact (List.eq_nil_of_length_eq_zero hlength.symm).symm + | cons x xs ih => + intro ys hlength h + cases ys with + | nil => simp at hlength + | cons y ys => + simp only [List.flatMap_cons] at h + obtain ⟨hhead, htail⟩ := List.append_inj h (by rw [hlen, hlen]) + exact congrArg₂ _ (hinj _ _ hhead) (ih (by simpa using hlength) htail) + +/-- A one-time signature's payload is its `v` endpoints, and the concatenation determines them. -/ +theorem leafPayload_injective {endpoints endpoints' : ChainIndex → Digest} + (h : Concrete.leafPayload endpoints = Concrete.leafPayload endpoints') : + endpoints = endpoints' := + flatMap_ofFn_injective Concrete.digestBytes 16 digestBytes_length + (fun _ _ => digestBytes_injective) h + +/-- A few-time public key's payload is its `k - 1` roots. -/ +theorem ftsRootsPayload_injective {roots roots' : FtsTree → Digest} + (h : Concrete.ftsRootsPayload roots = Concrete.ftsRootsPayload roots') : roots = roots' := + flatMap_ofFn_injective Concrete.digestBytes 16 digestBytes_length + (fun _ _ => digestBytes_injective) h + +end SphincsSecurity.TargetSum diff --git a/formal/sphincs/SphincsSecurity/Proof/Correctness.lean b/formal/sphincs/SphincsSecurity/Proof/Correctness.lean new file mode 100644 index 00000000..24870356 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Correctness.lean @@ -0,0 +1,55 @@ +import SphincsSecurity.Proof.FewTime +import SphincsSecurity.Proof.Hypertree + +/-! +# Correctness + +`Ver` accepts a signature built from the secrets: the digest fixes an index, the few-time opening +recovers the few-time public key, the three layers chain it up to the root, and the root is the one +key generation published. Nothing here is probabilistic; it holds against every answer function, so +in particular against the random oracle on every path of its support. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp + +/-- **Correctness.** An honest signature verifies. -/ +theorem eval_verify (f : QueryImpl HashSpec Id) (secretKey : SecretKey) (publicKey : PublicKey) + (message : Message) (signature : Signature) (digest : MessageDigest) + (codeword : Layer → Encoding) + (hparameter : publicKey.parameter = secretKey.parameter) + (hpkroot : publicKey.root = evalWithAnswerFn f (treeRoot secretKey.parameter topLayer rootTree + (secretKey.otsSecret topLayer rootTree))) + (hdigest : evalWithAnswerFn f (messageDigest publicKey.parameter publicKey.root message + signature.randomness) = digest) + (hadmissible : Admissible digest) + (hftsSecret : signature.ftsSecret = fun tree => + secretKey.ftsSecret (digestIndex digest) tree (digestLeaves digest (ftsIndexOf tree))) + (hftsPath : signature.ftsPath = evalWithAnswerFn f (ftsOpen secretKey.parameter + (digestIndex digest) (digestLeaves digest) (secretKey.ftsSecret (digestIndex digest)))) + (hchain : ∀ lay : Layer, signature.chainValue lay + = fun chainIdx => evalWithAnswerFn f (chainWalk secretKey.parameter lay + (treeIndexAt (digestIndex digest) lay) (leafIndexAt (digestIndex digest) lay) chainIdx 0 + (codeword lay chainIdx).val (secretKey.otsSecret lay + (treeIndexAt (digestIndex digest) lay) (leafIndexAt (digestIndex digest) lay) chainIdx))) + (hpath : ∀ (lay : Layer) (level : Nat), level < layerHeight lay → + signaturePath signature lay level = evalWithAnswerFn f (treeNode secretKey.parameter lay + (treeIndexAt (digestIndex digest) lay) + (secretKey.otsSecret lay (treeIndexAt (digestIndex digest) lay)) level + (Nat.xor ((leafIndexAt (digestIndex digest) lay).val / 2 ^ level) 1))) + (hencode : ∀ lay : Layer, evalWithAnswerFn f (encode secretKey.parameter lay + (treeIndexAt (digestIndex digest) lay) (leafIndexAt (digestIndex digest) lay) + (evalWithAnswerFn f (layerMessage secretKey (digestIndex digest) lay)) + (signature.counter lay)) = some (codeword lay)) : + evalWithAnswerFn f (verify publicKey message signature) = true := by + rw [verify_eq, evalWithAnswerFn_bind, hdigest, if_neg (by simpa using hadmissible), + evalWithAnswerFn_bind, hparameter, hftsSecret, hftsPath, + eval_ftsRecover f secretKey.parameter (digestIndex digest) (digestLeaves digest) + (secretKey.ftsSecret (digestIndex digest)), + evalWithAnswerFn_bind, + eval_verifyLayers f secretKey (digestIndex digest) signature codeword hchain hpath hencode, + evalWithAnswerFn_pure, hpkroot] + simp + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/CoupledQueryCost.lean b/formal/sphincs/SphincsSecurity/Proof/CoupledQueryCost.lean new file mode 100644 index 00000000..7ca99e18 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/CoupledQueryCost.lean @@ -0,0 +1,35 @@ +import SphincsSecurity.Proof.MarginalCoupling + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +theorem expected_cost_le_of_relTriple {α β : Type} + {left : ProbComp α} {right : ProbComp β} {relation : α → β → Prop} + (hrel : RelTriple left right relation) (leftCost : α → ℝ≥0∞) + (rightCost : β → ℝ≥0∞) (errorCost : α → ℝ≥0∞) + (hcost : ∀ a b, relation a b → leftCost a ≤ rightCost b + errorCost a) : + (∑' a, Pr[= a | left] * leftCost a) ≤ + (∑' b, Pr[= b | right] * rightCost b) + ∑' a, Pr[= a | left] * errorCost a := by + obtain ⟨coupling, hrelation⟩ := (relTriple_iff_relWP).mp hrel + have hleft (cost : α → ℝ≥0∞) : + (∑' a, Pr[= a | left] * cost a) = + ∑' pair, Pr[= pair | coupling.1] * cost pair.1 := by + change (∑' a, Pr[= a | (evalDist left : SPMF α)] * cost a) = _ + exact (congrArg (fun run : SPMF α => ∑' a, Pr[= a | run] * cost a) + coupling.2.map_fst.symm).trans (tsum_probOutput_map_mul coupling.1 Prod.fst cost) + have hright : (∑' b, Pr[= b | right] * rightCost b) = + ∑' pair, Pr[= pair | coupling.1] * rightCost pair.2 := by + change (∑' b, Pr[= b | (evalDist right : SPMF β)] * rightCost b) = _ + exact (congrArg (fun run : SPMF β => ∑' b, Pr[= b | run] * rightCost b) + coupling.2.map_snd.symm).trans (tsum_probOutput_map_mul coupling.1 Prod.snd rightCost) + rw [hleft leftCost, hleft errorCost, hright, ← ENNReal.tsum_add] + apply ENNReal.tsum_le_tsum + intro pair + rw [← mul_add] + by_cases hpair : pair ∈ support coupling.1 + · exact mul_le_mul' le_rfl (hcost pair.1 pair.2 (hrelation pair hpair)) + · rw [probOutput_eq_zero_of_not_mem_support hpair, zero_mul, zero_mul] + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Descent.lean b/formal/sphincs/SphincsSecurity/Proof/Descent.lean new file mode 100644 index 00000000..b76bb5f1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Descent.lean @@ -0,0 +1,516 @@ +import SphincsSecurity.Proof.SettledPath +import SphincsSecurity.Proof.HitBad +import SphincsSecurity.Proof.Hypertree + +/-! +# Deterministic forgery descent + +At one hypertree layer, acceptance at the honest root either creates `Bad`, or the supplied chain +values and authentication path are exactly the honest values selected by the decoded codeword. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +variable {f : QueryImpl HashSpec Id} {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {cache : QueryCache HashSpec} + +theorem verify_extract (publicKey : PublicKey) (message : Message) (signature : Signature) + (hverify : evalWithAnswerFn f (verify publicKey message signature) = true) + (hrun : CachedRun cache f (verify publicKey message signature)) : + ∃ digest : MessageDigest, + evalWithAnswerFn f + (messageDigest publicKey.parameter publicKey.root message signature.randomness) = digest + ∧ CachedRun cache f + (messageDigest publicKey.parameter publicKey.root message signature.randomness) + ∧ Admissible digest + ∧ let index := digestIndex digest + let leaves := digestLeaves digest + let ftsPublicKey := evalWithAnswerFn f + (ftsRecover publicKey.parameter index leaves signature.ftsSecret signature.ftsPath) + evalWithAnswerFn f + (verifyLayers publicKey.parameter index signature numLayers ftsPublicKey) + = some publicKey.root + ∧ CachedRun cache f + (ftsRecover publicKey.parameter index leaves signature.ftsSecret signature.ftsPath) + ∧ CachedRun cache f + (verifyLayers publicKey.parameter index signature numLayers ftsPublicKey) := by + let digest := evalWithAnswerFn f + (messageDigest publicKey.parameter publicKey.root message signature.randomness) + have hadmissible : Admissible digest := by + by_contra hnot + rw [verify_eq, evalWithAnswerFn_bind] at hverify + simp only [digest] at hnot + rw [if_pos hnot] at hverify + simp at hverify + let index := digestIndex digest + let leaves := digestLeaves digest + let ftsPublicKey := evalWithAnswerFn f + (ftsRecover publicKey.parameter index leaves signature.ftsSecret signature.ftsPath) + have hlayers : evalWithAnswerFn f + (verifyLayers publicKey.parameter index signature numLayers ftsPublicKey) + = some publicKey.root := by + rw [verify_eq, evalWithAnswerFn_bind] at hverify + simp only [digest, hadmissible, not_true_eq_false, if_false, evalWithAnswerFn_bind] at hverify + cases hresult : evalWithAnswerFn f + (verifyLayers publicKey.parameter index signature numLayers ftsPublicKey) with + | none => + rw [hresult] at hverify + simp at hverify + | some root => + rw [hresult] at hverify + simp only [evalWithAnswerFn_pure, decide_eq_true_eq] at hverify + simp [hverify] + rw [verify_eq] at hrun + have hmessageRun := hrun.bind_left + have hafterDigest := hrun.bind_right + simp only [digest, hadmissible, not_true_eq_false, if_false] at hafterDigest + change CachedRun cache f (do + let ftsPublicKey ← + ftsRecover publicKey.parameter index leaves signature.ftsSecret signature.ftsPath + match ← verifyLayers publicKey.parameter index signature numLayers ftsPublicKey with + | none => pure false + | some root => pure (decide (root = publicKey.root))) at hafterDigest + have hfts : CachedRun cache f + (ftsRecover publicKey.parameter index leaves signature.ftsSecret signature.ftsPath) := + hafterDigest.bind_left + have hlayersRun : CachedRun cache f + (verifyLayers publicKey.parameter index signature numLayers ftsPublicKey) := by + have := hafterDigest.bind_right.bind_left + simpa only [ftsPublicKey] using this + exact ⟨digest, rfl, hmessageRun, hadmissible, hlayers, hfts, hlayersRun⟩ + +theorem verifyLayers_succ_extract_cached (index : Index) (signature : Signature) + (remaining : Nat) (hlayer : remaining < numLayers) (message target : Digest) + (hverify : evalWithAnswerFn f + (verifyLayers parameter index signature (remaining + 1) message) = some target) + (hrun : CachedRun cache f + (verifyLayers parameter index signature (remaining + 1) message)) : + ∃ leafValue, + let lay : Layer := ⟨remaining, hlayer⟩ + let tree := treeIndexAt index lay + let leafIdx := leafIndexAt index lay + let rootValue := foldValue f parameter lay tree leafIdx (signaturePath signature lay) + leafValue (layerHeight lay) + evalWithAnswerFn f (otsLeaf parameter lay tree leafIdx message (signature.counter lay) + (signature.chainValue lay)) = some leafValue + ∧ evalWithAnswerFn f (verifyLayers parameter index signature remaining rootValue) + = some target + ∧ CachedRun cache f (otsLeaf parameter lay tree leafIdx message (signature.counter lay) + (signature.chainValue lay)) + ∧ CachedRun cache f (treeFold parameter lay tree leafIdx (signaturePath signature lay) + (layerHeight lay) leafValue) + ∧ CachedRun cache f (verifyLayers parameter index signature remaining rootValue) := by + obtain ⟨leafValue, hleaf, hrest⟩ := + verifyLayers_succ_extract f parameter index signature remaining hlayer message target hverify + rw [verifyLayers_succ_eq, dif_pos hlayer] at hrun + have hots := hrun.bind_left + have hafter := hrun.bind_right + rw [hleaf] at hafter + exact ⟨leafValue, hleaf, hrest, hots, hafter.bind_left, hafter.bind_right⟩ + +def LayerFrame (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (parameter : PublicParameter) (index : Index) (signature : Signature) + (lay : Layer) (message target leafValue : Digest) : Prop := + evalWithAnswerFn f + (otsLeaf parameter lay (treeIndexAt index lay) (leafIndexAt index lay) message + (signature.counter lay) (signature.chainValue lay)) = some leafValue + ∧ evalWithAnswerFn f + (verifyLayers parameter index signature lay.val + (foldValue f parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (signaturePath signature lay) leafValue (layerHeight lay))) = some target + ∧ CachedRun cache f + (otsLeaf parameter lay (treeIndexAt index lay) (leafIndexAt index lay) message + (signature.counter lay) (signature.chainValue lay)) + ∧ CachedRun cache f + (treeFold parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (signaturePath signature lay) (layerHeight lay) leafValue) + ∧ CachedRun cache f + (verifyLayers parameter index signature lay.val + (foldValue f parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (signaturePath signature lay) leafValue (layerHeight lay))) + +def LayerRun (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (parameter : PublicParameter) (index : Index) (signature : Signature) + (lay : Layer) (message target : Digest) : Prop := + ∃ leafValue, LayerFrame f cache parameter index signature lay message target leafValue + +theorem layerRun_of_verify (index : Index) (signature : Signature) + (lay : Layer) (message target : Digest) + (hverify : evalWithAnswerFn f + (verifyLayers parameter index signature (lay.val + 1) message) = some target) + (hrun : CachedRun cache f + (verifyLayers parameter index signature (lay.val + 1) message)) : + LayerRun f cache parameter index signature lay message target := by + obtain ⟨leafValue, hleaf, hnext, hleafRun, hfoldRun, hnextRun⟩ := + verifyLayers_succ_extract_cached (f := f) (cache := cache) index signature lay.val lay.isLt + message target hverify hrun + exact ⟨leafValue, hleaf, hnext, hleafRun, hfoldRun, hnextRun⟩ + +def HypertreeRun (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (parameter : PublicParameter) (index : Index) (signature : Signature) + (message target : Digest) : Prop := + ∃ bottomLeaf, + LayerFrame f cache parameter index signature bottomLayer message target bottomLeaf + ∧ let middleMessage := foldValue f parameter bottomLayer + (treeIndexAt index bottomLayer) (leafIndexAt index bottomLayer) + (signaturePath signature bottomLayer) bottomLeaf (layerHeight bottomLayer) + ∃ middleLeaf, + LayerFrame f cache parameter index signature middleLayer middleMessage target middleLeaf + ∧ let topMessage := foldValue f parameter middleLayer + (treeIndexAt index middleLayer) (leafIndexAt index middleLayer) + (signaturePath signature middleLayer) middleLeaf (layerHeight middleLayer) + LayerRun f cache parameter index signature topLayer topMessage target + +theorem hypertreeRun_of_verify (index : Index) (signature : Signature) + (message target : Digest) + (hverify : evalWithAnswerFn f + (verifyLayers parameter index signature numLayers message) = some target) + (hrun : CachedRun cache f + (verifyLayers parameter index signature numLayers message)) : + HypertreeRun f cache parameter index signature message target := by + have hbottom := layerRun_of_verify (f := f) (cache := cache) index signature bottomLayer + message target (by simpa only [numLayers, bottomLayer] using hverify) + (by simpa only [numLayers, bottomLayer] using hrun) + obtain ⟨bottomLeaf, hbottom⟩ := hbottom + let middleMessage := foldValue f parameter bottomLayer + (treeIndexAt index bottomLayer) (leafIndexAt index bottomLayer) + (signaturePath signature bottomLayer) bottomLeaf (layerHeight bottomLayer) + have hmiddle := layerRun_of_verify (f := f) (cache := cache) index signature middleLayer + middleMessage target (by + simpa only [middleMessage, bottomLayer, middleLayer, numLayers] using hbottom.2.1) + (by simpa only [middleMessage, bottomLayer, middleLayer, numLayers] using hbottom.2.2.2.2) + obtain ⟨middleLeaf, hmiddle⟩ := hmiddle + let topMessage := foldValue f parameter middleLayer + (treeIndexAt index middleLayer) (leafIndexAt index middleLayer) + (signaturePath signature middleLayer) middleLeaf (layerHeight middleLayer) + have htop := layerRun_of_verify (f := f) (cache := cache) index signature topLayer + topMessage target (by simpa only [topMessage, middleLayer, topLayer] using hmiddle.2.1) + (by simpa only [topMessage, middleLayer, topLayer] using hmiddle.2.2.2.2) + exact ⟨bottomLeaf, hbottom, middleLeaf, hmiddle, htop⟩ + +theorem layer_extract_or_bad (hf : cache.AgreesWithFn f) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) (counter : Counter) + (values : ChainIndex → Digest) (path : Nat → Digest) (codeword : Encoding) + (hencode : evalWithAnswerFn f (encode parameter lay tree leafIdx message counter) + = some codeword) (leafValue : Digest) + (hleaf : evalWithAnswerFn f + (otsLeaf parameter lay tree leafIdx message counter values) = some leafValue) + (hfold : foldValue f parameter lay tree leafIdx path leafValue (layerHeight lay) + = honestNode f parameter lay tree (otsSecret lay tree) (layerHeight lay) + (leafIdx.val / 2 ^ layerHeight lay)) + (hotsRun : CachedRun cache f (otsLeaf parameter lay tree leafIdx message counter values)) + (hfoldRun : CachedRun cache f + (treeFold parameter lay tree leafIdx path (layerHeight lay) leafValue)) + (hchains : ∀ chainIdx position (hposition : position < chainLength - 1), + Settled parameter otsSecret ftsSecret cache + (.chain lay tree leafIdx chainIdx ⟨position, hposition⟩)) + (hleafSettled : Settled parameter otsSecret ftsSecret cache (.leaf lay tree leafIdx)) + (hnodes : ∀ level (hlevel : level < layerHeight lay), + Settled parameter otsSecret ftsSecret cache + (.node lay tree ⟨level, lt_of_lt_of_le hlevel (layerHeight_le lay)⟩ + ⟨leafIdx.val / 2 ^ (level + 1), lt_of_le_of_lt (Nat.div_le_self _ _) + leafIdx.isLt⟩)) : + Bad parameter otsSecret ftsSecret cache ∨ + ((∀ chainIdx, values chainIdx + = honestChain f parameter lay tree leafIdx chainIdx + (otsSecret lay tree leafIdx chainIdx) (codeword chainIdx).val) + ∧ ∀ level, level < layerHeight lay → path level + = honestNode f parameter lay tree (otsSecret lay tree) level + (Nat.xor (leafIdx.val / 2 ^ level) 1)) := by + rcases treeFold_extract f parameter lay tree (otsSecret lay tree) leafIdx path leafValue + (layerHeight lay) hfold with ⟨hleafValue, hpath⟩ | ⟨level, hlevel, hhit⟩ + · have hleafHonest : evalWithAnswerFn f + (otsLeaf parameter lay tree leafIdx message counter values) + = some (honestNode f parameter lay tree (otsSecret lay tree) 0 leafIdx.val) := by + rw [hleaf, hleafValue] + rcases otsLeaf_extract f parameter lay tree (otsSecret lay tree) leafIdx message counter values + codeword hencode hleafHonest with hvalues | hhit | ⟨chainIdx, offset, hrange, hoffset, hhit⟩ + · exact Or.inr ⟨hvalues, hpath⟩ + · left + apply bad_of_leafHit hf lay tree leafIdx _ hhit hleafSettled + apply hotsRun + exact otsLeaf_leaf_query_mem f parameter lay tree leafIdx message counter values codeword hencode + · left + apply bad_of_chainHit hf lay tree leafIdx chainIdx ((codeword chainIdx).val + offset) + hrange _ hhit (hchains chainIdx _ hrange) + apply hotsRun + exact otsLeaf_chain_query_mem f parameter lay tree leafIdx message counter values codeword + hencode chainIdx offset hoffset hrange + · left + have hlevelMax : level < maxLayerHeight := lt_of_lt_of_le hlevel (layerHeight_le lay) + have hnodeIdx : leafIdx.val / 2 ^ (level + 1) < 2 ^ maxLayerHeight := + lt_of_le_of_lt (Nat.div_le_self _ _) leafIdx.isLt + apply bad_of_nodeHit hf lay tree level (leafIdx.val / 2 ^ (level + 1)) hlevelMax + hnodeIdx _ hhit (hnodes level hlevel) + apply hfoldRun + exact treeFold_query_mem f parameter lay tree leafIdx path leafValue (layerHeight lay) level hlevel + +theorem layer_extract_or_bad' (hf : cache.AgreesWithFn f) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) (counter : Counter) + (values : ChainIndex → Digest) (path : Nat → Digest) (leafValue : Digest) + (hleaf : evalWithAnswerFn f + (otsLeaf parameter lay tree leafIdx message counter values) = some leafValue) + (hfold : foldValue f parameter lay tree leafIdx path leafValue (layerHeight lay) + = honestNode f parameter lay tree (otsSecret lay tree) (layerHeight lay) + (leafIdx.val / 2 ^ layerHeight lay)) + (hotsRun : CachedRun cache f (otsLeaf parameter lay tree leafIdx message counter values)) + (hfoldRun : CachedRun cache f + (treeFold parameter lay tree leafIdx path (layerHeight lay) leafValue)) + (hchains : ∀ chainIdx position (hposition : position < chainLength - 1), + Settled parameter otsSecret ftsSecret cache + (.chain lay tree leafIdx chainIdx ⟨position, hposition⟩)) + (hleafSettled : Settled parameter otsSecret ftsSecret cache (.leaf lay tree leafIdx)) + (hnodes : ∀ level (hlevel : level < layerHeight lay), + Settled parameter otsSecret ftsSecret cache + (.node lay tree ⟨level, lt_of_lt_of_le hlevel (layerHeight_le lay)⟩ + ⟨leafIdx.val / 2 ^ (level + 1), lt_of_le_of_lt (Nat.div_le_self _ _) + leafIdx.isLt⟩)) : + Bad parameter otsSecret ftsSecret cache ∨ ∃ codeword : Encoding, + evalWithAnswerFn f (encode parameter lay tree leafIdx message counter) = some codeword + ∧ (∀ chainIdx, values chainIdx + = honestChain f parameter lay tree leafIdx chainIdx + (otsSecret lay tree leafIdx chainIdx) (codeword chainIdx).val) + ∧ ∀ level, level < layerHeight lay → path level + = honestNode f parameter lay tree (otsSecret lay tree) level + (Nat.xor (leafIdx.val / 2 ^ level) 1) := by + cases hencode : evalWithAnswerFn f (encode parameter lay tree leafIdx message counter) with + | none => + simp only [otsLeaf, evalWithAnswerFn_bind, hencode, evalWithAnswerFn_pure] at hleaf + simp at hleaf + | some codeword => + rcases layer_extract_or_bad hf lay tree leafIdx message counter values path codeword hencode + leafValue hleaf hfold hotsRun hfoldRun hchains hleafSettled hnodes with hbad | hhonest + · exact Or.inl hbad + · exact Or.inr ⟨codeword, rfl, hhonest⟩ + +def HonestLayerOpening (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) + (counter : Counter) (values : ChainIndex → Digest) (path : Nat → Digest) : Prop := + ∃ codeword : Encoding, + evalWithAnswerFn f (encode parameter lay tree leafIdx message counter) = some codeword + ∧ (∀ chainIdx, values chainIdx + = honestChain f parameter lay tree leafIdx chainIdx + (otsSecret lay tree leafIdx chainIdx) (codeword chainIdx).val) + ∧ ∀ level, level < layerHeight lay → path level + = honestNode f parameter lay tree (otsSecret lay tree) level + (Nat.xor (leafIdx.val / 2 ^ level) 1) + +theorem layer_extract_from_settled_root_or_bad (hf : cache.AgreesWithFn f) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (hleafIdx : leafIdx.val < 2 ^ layerHeight lay) (message : Digest) (counter : Counter) + (values : ChainIndex → Digest) (path : Nat → Digest) (leafValue : Digest) + (hleaf : evalWithAnswerFn f + (otsLeaf parameter lay tree leafIdx message counter values) = some leafValue) + (hfold : foldValue f parameter lay tree leafIdx path leafValue (layerHeight lay) + = honestNode f parameter lay tree (otsSecret lay tree) (layerHeight lay) 0) + (hotsRun : CachedRun cache f (otsLeaf parameter lay tree leafIdx message counter values)) + (hfoldRun : CachedRun cache f + (treeFold parameter lay tree leafIdx path (layerHeight lay) leafValue)) + (hroot : Settled parameter otsSecret ftsSecret cache + (.node lay tree ⟨layerHeight lay - 1, by + have hpos : 0 < layerHeight lay := by unfold layerHeight; split <;> norm_num [maxLayerHeight] + have hle := layerHeight_le lay + omega⟩ ⟨0, by positivity⟩)) : + Bad parameter otsSecret ftsSecret cache ∨ + HonestLayerOpening f parameter otsSecret lay tree leafIdx message counter values path := by + obtain ⟨hleafSettled, hnodes⟩ := + settled_tree_path_of_settled_root lay tree leafIdx hleafIdx hroot + apply layer_extract_or_bad' hf lay tree leafIdx message counter values path leafValue hleaf + · simpa only [Nat.div_eq_of_lt hleafIdx] using hfold + · exact hotsRun + · exact hfoldRun + · intro chainIdx position hposition + exact settled_chain_of_settled_leaf lay tree leafIdx hleafSettled chainIdx position hposition + · exact hleafSettled + · exact hnodes + +def HypertreeTopOpening (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (index : Index) (signature : Signature) (message target : Digest) : Prop := + ∃ bottomLeaf, + LayerFrame f cache parameter index signature bottomLayer message target bottomLeaf + ∧ let middleMessage := foldValue f parameter bottomLayer + (treeIndexAt index bottomLayer) (leafIndexAt index bottomLayer) + (signaturePath signature bottomLayer) bottomLeaf (layerHeight bottomLayer) + ∃ middleLeaf, + LayerFrame f cache parameter index signature middleLayer middleMessage target middleLeaf + ∧ let topMessage := foldValue f parameter middleLayer + (treeIndexAt index middleLayer) (leafIndexAt index middleLayer) + (signaturePath signature middleLayer) middleLeaf (layerHeight middleLayer) + HonestLayerOpening f parameter otsSecret topLayer (treeIndexAt index topLayer) + (leafIndexAt index topLayer) topMessage (signature.counter topLayer) + (signature.chainValue topLayer) (signaturePath signature topLayer) + ∧ CachedRun cache f (otsLeaf parameter topLayer (treeIndexAt index topLayer) + (leafIndexAt index topLayer) topMessage (signature.counter topLayer) + (signature.chainValue topLayer)) + +theorem hypertree_top_extract_or_bad (hf : cache.AgreesWithFn f) + (index : Index) (signature : Signature) (message target : Digest) + (hrun : HypertreeRun f cache parameter index signature message target) + (htarget : target + = honestNode f parameter topLayer rootTree (otsSecret topLayer rootTree) + (layerHeight topLayer) 0) + (hroot : Settled parameter otsSecret ftsSecret cache + (.node topLayer rootTree ⟨layerHeight topLayer - 1, by decide⟩ ⟨0, by positivity⟩)) : + Bad parameter otsSecret ftsSecret cache ∨ + HypertreeTopOpening f cache parameter otsSecret index signature message target := by + obtain ⟨bottomLeaf, hbottom, middleLeaf, hmiddle, topLeaf, htop⟩ := hrun + let topMessage := foldValue f parameter middleLayer + (treeIndexAt index middleLayer) (leafIndexAt index middleLayer) + (signaturePath signature middleLayer) middleLeaf (layerHeight middleLayer) + have htopFold : foldValue f parameter topLayer (treeIndexAt index topLayer) + (leafIndexAt index topLayer) (signaturePath signature topLayer) topLeaf + (layerHeight topLayer) = target := by + have := htop.2.1 + simpa only [topLayer, verifyLayers_zero_eq, evalWithAnswerFn_pure, + Option.some.injEq] using this + have htree : treeIndexAt index topLayer = rootTree := by + apply Fin.ext + exact treeIndexAt_topLayer index + have hroot' : Settled parameter otsSecret ftsSecret cache + (.node topLayer (treeIndexAt index topLayer) + ⟨layerHeight topLayer - 1, by decide⟩ ⟨0, by positivity⟩) := by + simpa only [htree] using hroot + have hfold : foldValue f parameter topLayer (treeIndexAt index topLayer) + (leafIndexAt index topLayer) (signaturePath signature topLayer) topLeaf + (layerHeight topLayer) + = honestNode f parameter topLayer (treeIndexAt index topLayer) + (otsSecret topLayer (treeIndexAt index topLayer)) (layerHeight topLayer) 0 := by + rw [htopFold, htarget, htree] + rcases layer_extract_from_settled_root_or_bad hf topLayer (treeIndexAt index topLayer) + (leafIndexAt index topLayer) (leafIndexAt_lt index topLayer) topMessage + (signature.counter topLayer) (signature.chainValue topLayer) + (signaturePath signature topLayer) topLeaf htop.1 hfold htop.2.2.1 htop.2.2.2.1 + hroot' with hbad | hhonest + · exact Or.inl hbad + · exact Or.inr ⟨bottomLeaf, hbottom, middleLeaf, hmiddle, hhonest, htop.2.2.1⟩ + +theorem ftsTree_extract_or_bad (hf : cache.AgreesWithFn f) (index : Index) + (leaves : DigestTree → FtsLeaf) (secrets : FtsTree → Digest) + (paths : FtsTree → Fin ftsTreeHeight → Digest) (tree : FtsTree) + (hfold : ftsFoldValue f parameter index tree (leaves (ftsIndexOf tree)) (paths tree) + (truncateHash (f (tweakableHashInput parameter + (.ftsLeaf index tree (leaves (ftsIndexOf tree))) (digestBytes (secrets tree))))) + ftsTreeHeight = honestFtsNode f parameter index tree (ftsSecret index tree) + ftsTreeHeight 0) + (hrun : CachedRun cache f (ftsRecover parameter index leaves secrets paths)) + (hleafSettled : Settled parameter otsSecret ftsSecret cache + (.ftsLeaf index tree (leaves (ftsIndexOf tree)))) + (hnodes : ∀ level (hlevel : level < ftsTreeHeight), + Settled parameter otsSecret ftsSecret cache + (.ftsNode index tree ⟨level, hlevel⟩ + ⟨(leaves (ftsIndexOf tree)).val / 2 ^ (level + 1), + lt_of_le_of_lt (Nat.div_le_self _ _) (leaves (ftsIndexOf tree)).isLt⟩)) : + Bad parameter otsSecret ftsSecret cache ∨ + (secrets tree = ftsSecret index tree (leaves (ftsIndexOf tree)) + ∧ ∀ level (hlevel : level < ftsTreeHeight), paths tree ⟨level, hlevel⟩ + = honestFtsNode f parameter index tree (ftsSecret index tree) level + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level) 1)) := by + let leafIdx := leaves (ftsIndexOf tree) + let leafValue := truncateHash (f (tweakableHashInput parameter + (.ftsLeaf index tree leafIdx) (digestBytes (secrets tree)))) + have hroot : leafIdx.val / 2 ^ ftsTreeHeight = 0 := Nat.div_eq_of_lt leafIdx.isLt + rcases ftsFold_extract f parameter index tree (ftsSecret index tree) leafIdx (paths tree) + leafValue ftsTreeHeight (le_refl _) (by simpa only [leafIdx, leafValue, hroot] using hfold) with + ⟨hleafValue, hpath⟩ | ⟨level, hlevel, hhit⟩ + · rcases ftsLeaf_extract f parameter index tree (ftsSecret index tree) leafIdx (secrets tree) + hleafValue with hsecret | hhit + · right + refine ⟨hsecret, ?_⟩ + intro level hlevel + simpa only [ftsSibling, dif_pos hlevel, leafIdx] using hpath level hlevel + · left + apply bad_of_ftsLeafHit hf index tree leafIdx (secrets tree) hhit hleafSettled + apply hrun + exact ftsRecover_leaf_query_mem f parameter index leaves secrets paths tree + · left + have hnodeIdx : leafIdx.val / 2 ^ (level + 1) < 2 ^ ftsTreeHeight := + lt_of_le_of_lt (Nat.div_le_self _ _) leafIdx.isLt + apply bad_of_ftsNodeHit hf index tree level (leafIdx.val / 2 ^ (level + 1)) hlevel + hnodeIdx _ hhit (hnodes level hlevel) + apply hrun + exact ftsRecover_fold_query_mem f parameter index leaves secrets paths tree level hlevel + +theorem ftsRecover_extract_or_bad (hf : cache.AgreesWithFn f) (index : Index) + (leaves : DigestTree → FtsLeaf) (secrets : FtsTree → Digest) + (paths : FtsTree → Fin ftsTreeHeight → Digest) + (hrecover : evalWithAnswerFn f (ftsRecover parameter index leaves secrets paths) + = honestFtsKey f parameter index (ftsSecret index)) + (hrun : CachedRun cache f (ftsRecover parameter index leaves secrets paths)) + (hrootsSettled : Settled parameter otsSecret ftsSecret cache (.ftsRoots index)) + (hleavesSettled : ∀ tree, Settled parameter otsSecret ftsSecret cache + (.ftsLeaf index tree (leaves (ftsIndexOf tree)))) + (hnodes : ∀ tree level (hlevel : level < ftsTreeHeight), + Settled parameter otsSecret ftsSecret cache + (.ftsNode index tree ⟨level, hlevel⟩ + ⟨(leaves (ftsIndexOf tree)).val / 2 ^ (level + 1), + lt_of_le_of_lt (Nat.div_le_self _ _) (leaves (ftsIndexOf tree)).isLt⟩)) : + Bad parameter otsSecret ftsSecret cache ∨ + ∀ tree, secrets tree = ftsSecret index tree (leaves (ftsIndexOf tree)) + ∧ ∀ level (hlevel : level < ftsTreeHeight), paths tree ⟨level, hlevel⟩ + = honestFtsNode f parameter index tree (ftsSecret index tree) level + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level) 1) := by + let roots : FtsTree → Digest := fun tree => evalWithAnswerFn f + (ftsFold parameter index tree (leaves (ftsIndexOf tree)) (paths tree) ftsTreeHeight + (evalWithAnswerFn f + (ftsLeafHash parameter index tree (leaves (ftsIndexOf tree)) (secrets tree)))) + by_cases hpayload : ftsRootsPayload roots + = honestPayload f parameter otsSecret ftsSecret (.ftsRoots index) + · have hrootValues : roots = fun tree => + honestFtsNode f parameter index tree (ftsSecret index tree) ftsTreeHeight 0 := by + apply TargetSum.ftsRootsPayload_injective + simpa only [roots, honestPayload] using hpayload + by_cases hbad : Bad parameter otsSecret ftsSecret cache + · exact Or.inl hbad + · right + intro tree + have hfold : ftsFoldValue f parameter index tree (leaves (ftsIndexOf tree)) (paths tree) + (truncateHash (f (tweakableHashInput parameter + (.ftsLeaf index tree (leaves (ftsIndexOf tree))) (digestBytes (secrets tree))))) + ftsTreeHeight = honestFtsNode f parameter index tree (ftsSecret index tree) + ftsTreeHeight 0 := by + have := congrFun hrootValues tree + simpa only [roots, evalWithAnswerFn_bind, ftsLeafHash, eval_tweakableHash, + ftsFoldValue] using this + rcases ftsTree_extract_or_bad hf index leaves secrets paths tree hfold hrun + (hleavesSettled tree) (hnodes tree) with hbad' | hhonest + · exact absurd hbad' hbad + · exact hhonest + · left + apply bad_of_settled_payload_collision parameter otsSecret ftsSecret hf hrootsSettled hpayload + · apply hrun + have hmem := ftsRecover_roots_query_mem f parameter index leaves secrets paths + convert hmem using 1 + all_goals simp [roots, Position.domain] + · rw [honestValue_ftsRoots] + have hvalue := hrecover + simp only [ftsRecover, evalWithAnswerFn_bind, evalWithAnswerFn_sequenceFin, + eval_tweakableHash] at hvalue + change truncateHash (f (tweakableHashInput parameter (.ftsRoots index) + (ftsRootsPayload roots))) = honestFtsKey f parameter index (ftsSecret index) + dsimp only [roots] + simpa only [evalWithAnswerFn_bind] using hvalue + +theorem ftsRecover_extract_from_settled_roots_or_bad (hf : cache.AgreesWithFn f) + (index : Index) (leaves : DigestTree → FtsLeaf) (secrets : FtsTree → Digest) + (paths : FtsTree → Fin ftsTreeHeight → Digest) + (hrecover : evalWithAnswerFn f (ftsRecover parameter index leaves secrets paths) + = honestFtsKey f parameter index (ftsSecret index)) + (hrun : CachedRun cache f (ftsRecover parameter index leaves secrets paths)) + (hroots : Settled parameter otsSecret ftsSecret cache (.ftsRoots index)) : + Bad parameter otsSecret ftsSecret cache ∨ + ∀ tree, secrets tree = ftsSecret index tree (leaves (ftsIndexOf tree)) + ∧ ∀ level (hlevel : level < ftsTreeHeight), paths tree ⟨level, hlevel⟩ + = honestFtsNode f parameter index tree (ftsSecret index tree) level + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level) 1) := by + obtain ⟨hleaves, hnodes⟩ := settled_fts_path_of_settled_roots index leaves hroots + exact ftsRecover_extract_or_bad hf index leaves secrets paths hrecover hrun hroots + hleaves hnodes + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/DirectQueryBudget.lean b/formal/sphincs/SphincsSecurity/Proof/DirectQueryBudget.lean new file mode 100644 index 00000000..1ee9f031 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/DirectQueryBudget.lean @@ -0,0 +1,215 @@ +import SphincsSecurity.Proof.FullTrace +import SphincsSecurity.Proof.Secrets + +/-! +# Direct adversary queries within the complete query budget + +The global game bound controls the direct hash intervals on every supported adversary path. The +proof follows only signer replies that the concrete signer can actually return, rather than asking +for a structural bound on continuations after impossible replies. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +noncomputable def expandedAdversaryImpl (secretKey : SecretKey) : + QueryImpl (OracleWorld + SigningSpec) (OracleComp OracleWorld) := by + intro input + cases input with + | inl worldInput => exact liftM (OracleWorld.query worldInput) + | inr request => exact Concrete.scheme.sign secretKey request + +theorem forwardOracles_add_signingOracle_eq_withTraceAppend + (secretKey : SecretKey) : + forwardOracles + signingOracle Concrete.scheme secretKey = + QueryImpl.withTraceAppend (expandedAdversaryImpl secretKey) signingLogFragment := by + funext input + cases input with + | inl worldInput => rfl + | inr request => rfl + +theorem simulateQ_expandedAdversaryImpl_query_bind_inl + (secretKey : SecretKey) (worldInput : OracleWorld.Domain) + (continuation : OracleWorld.Range worldInput → + OracleComp (OracleWorld + SigningSpec) α) : + simulateQ (expandedAdversaryImpl secretKey) + (liftM ((OracleWorld + SigningSpec).query (.inl worldInput)) >>= continuation) = + (liftM (OracleWorld.query worldInput) >>= fun output => + simulateQ (expandedAdversaryImpl secretKey) (continuation output)) := by + simp [expandedAdversaryImpl] + +theorem simulateQ_expandedAdversaryImpl_query_bind_inr + (secretKey : SecretKey) (request : SignRequest) + (continuation : SigningSpec.Range request → + OracleComp (OracleWorld + SigningSpec) α) : + simulateQ (expandedAdversaryImpl secretKey) + (liftM ((OracleWorld + SigningSpec).query (.inr request)) >>= continuation) = + (Concrete.scheme.sign secretKey request >>= fun output => + simulateQ (expandedAdversaryImpl secretKey) (continuation output)) := by + simp [expandedAdversaryImpl] + +theorem isQueryBoundP_expandedAdversaryImpl + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (q : Nat) + (hbound : ((simulateQ (forwardOracles + signingOracle Concrete.scheme secretKey) + computation).run).IsQueryBoundP (· matches Sum.inr _) q) : + (simulateQ (expandedAdversaryImpl secretKey) computation).IsQueryBoundP + (· matches Sum.inr _) q := by + rw [forwardOracles_add_signingOracle_eq_withTraceAppend] at hbound + exact (isQueryBoundP_iff_of_map_eq (p := (· matches Sum.inr _)) + (QueryImpl.fst_map_run_withTraceAppend (expandedAdversaryImpl secretKey) + signingLogFragment computation)).mp hbound + +theorem unloggedMappedAdversaryImpl_eq_simulateQ_expanded + (secretKey : SecretKey) (input : (OracleWorld + SigningSpec).Domain) : + unloggedMappedAdversaryImpl secretKey input = + simulateQ romImpl (expandedAdversaryImpl secretKey input) := by + cases input with + | inl worldInput => + exact (simulateQ_spec_query + (impl := romImpl) worldInput).symm + | inr request => rfl + +theorem unloggedMappedAdversaryImpl_output_mem_support_expanded + (secretKey : SecretKey) (input : (OracleWorld + SigningSpec).Domain) + (initialCache finalCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (hmem : (output, finalCache) ∈ support + ((unloggedMappedAdversaryImpl secretKey input).run initialCache)) : + output ∈ support (expandedAdversaryImpl secretKey input) := by + apply support_simulateQ_run'_subset romImpl + (expandedAdversaryImpl secretKey input) initialCache + rw [StateT.run'_eq, support_map, + ← unloggedMappedAdversaryImpl_eq_simulateQ_expanded] + exact ⟨(output, finalCache), hmem, rfl⟩ + +theorem fullTracedMappedAdversaryImpl_direct_countQ_le_of_expanded + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + ∀ (q : Nat), + (simulateQ (expandedAdversaryImpl secretKey) computation).IsQueryBoundP + (· matches Sum.inr _) q → + ∀ (initialCache : QueryCache HashSpec) (initialTrace : FullAdversaryTrace) + (result : α × (QueryCache HashSpec × FullAdversaryTrace)), + result ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl secretKey) + computation).run (initialCache, initialTrace)) → + result.2.2.direct.countQ isDirectHashQuery ≤ + initialTrace.direct.countQ isDirectHashQuery + q := by + induction computation using OracleComp.inductionOn with + | pure x => + intro q _ initialCache initialTrace result hmem + simp only [simulateQ_pure] at hmem + subst result + simp + | query_bind input continuation ih => + intro q hbound initialCache initialTrace result hmem + rw [simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hmem + obtain ⟨queryResult, hquery, hrest⟩ := hmem + have hquery' := hquery + rw [simulateQ_spec_query, fullTracedMappedAdversaryImpl, + QueryImpl.extendState_apply, mem_support_bind_iff] at hquery' + obtain ⟨underlyingResult, hunderlying, hpure⟩ := hquery' + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst queryResult + have houtput := unloggedMappedAdversaryImpl_output_mem_support_expanded secretKey input + initialCache underlyingResult.2 underlyingResult.1 hunderlying + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + isQueryBoundP_query_bind_iff] at hbound + have htail := ih underlyingResult.1 q (hbound.2 underlyingResult.1) + underlyingResult.2 + (fullAdversaryTraceUpdate (.inl (.inl uniformInput)) initialCache + underlyingResult.1 underlyingResult.2 initialTrace) + result hrest + simp [fullAdversaryTraceUpdate, QueryLog.countQ, QueryLog.getQ_cons, + isDirectHashQuery] at htail ⊢ + exact htail + | inr hashInput => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + isQueryBoundP_query_bind_iff] at hbound + have hpositive : 0 < q := hbound.1.resolve_left (by simp) + have htail := ih underlyingResult.1 (q - 1) (hbound.2 underlyingResult.1) + underlyingResult.2 + (fullAdversaryTraceUpdate (.inl (.inr hashInput)) initialCache + underlyingResult.1 underlyingResult.2 initialTrace) + result hrest + simp [fullAdversaryTraceUpdate, QueryLog.countQ, QueryLog.getQ_cons, + isDirectHashQuery] at htail ⊢ + omega + | inr request => + rw [simulateQ_expandedAdversaryImpl_query_bind_inr] at hbound + have hcontinuation := isQueryBoundP_of_bind hbound underlyingResult.1 houtput + have htail := ih underlyingResult.1 q hcontinuation underlyingResult.2 + (fullAdversaryTraceUpdate (.inr request) initialCache underlyingResult.1 + underlyingResult.2 initialTrace) + result hrest + simp [fullAdversaryTraceUpdate, QueryLog.countQ, QueryLog.getQ_cons, + isDirectHashQuery] at htail ⊢ + exact htail + +theorem gameRestWithFullTrace_hashQueries_length_le_of_bound + (adversary : Adversary) (publicKey : PublicKey) (secretKey : SecretKey) + (initialCache : QueryCache HashSpec) (q : Nat) + (hbound : ((simulateQ (forwardOracles + signingOracle Concrete.scheme secretKey) + (adversary.main publicKey)).run).IsQueryBoundP (· matches Sum.inr _) q) + (result : (Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (gameRestWithFullTrace adversary publicKey secretKey initialCache)) : + result.2.2.hashQueries.length ≤ q := by + rw [gameRestWithFullTrace, mem_support_bind_iff] at hresult + obtain ⟨⟨forgery, adversaryCache, trace⟩, hadversary, hfinish⟩ := hresult + rw [mem_support_bind_iff] at hfinish + obtain ⟨⟨verified, finalCache⟩, hverify, hpure⟩ := hfinish + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + rw [FullAdversaryTrace.hashQueries, directHashQueries_length_eq_countQ] + have hdirect := fullTracedMappedAdversaryImpl_direct_countQ_le_of_expanded secretKey + (adversary.main publicKey) q + (isQueryBoundP_expandedAdversaryImpl secretKey (adversary.main publicKey) q hbound) + initialCache ⟨[], [], []⟩ (forgery, adversaryCache, trace) hadversary + simpa [QueryLog.countQ] using hdirect + +namespace Concrete + +theorem gameAfterSecretsWithFullTrace_hashQueries_length_le + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) : + result.2.2.hashQueries.length ≤ q := by + have hgame := isQueryBoundP_gameAfterSecrets adversary q hq hparameter hots hfts + rw [gameAfterSecrets] at hgame + rw [gameAfterSecretsWithFullTrace, mem_support_bind_iff] at hresult + obtain ⟨⟨root, rootCache⟩, hroot, hrest⟩ := hresult + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult, hrest, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + have hrootSupport : root ∈ support + (liftM ((treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : + OracleComp HashSpec Digest)) : OracleComp OracleWorld Digest) := by + apply support_simulateQ_run'_subset romImpl _ ∅ + rw [StateT.run'_eq, support_map] + exact ⟨(root, rootCache), hroot, rfl⟩ + have hrestBound := isQueryBoundP_of_bind hgame root hrootSupport + rw [gameRest] at hrestBound + have hadversaryBound := IsQueryBoundP.of_bind_left hrestBound + exact gameRestWithFullTrace_hashQueries_length_le_of_bound adversary + (⟨root, parameter⟩ : PublicKey) + (⟨parameter, root, otsSecret, ftsSecret⟩ : SecretKey) + rootCache q hadversaryBound restResult hrest + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingCached.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingCached.lean new file mode 100644 index 00000000..4c7855b1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingCached.lean @@ -0,0 +1,124 @@ +import SphincsSecurity.Proof.SignSupport + +/-! +# Cached encoding queries + +Successful verifier and signer executions retain the encoding query that selected their counter. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +theorem CachedRun.encode_cached {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {parameter : PublicParameter} {lay : Layer} + {tree : TreeIndex} {leafIdx : LeafIndex} {message : Digest} {counter : Counter} + (hrun : CachedRun cache f (encode parameter lay tree leafIdx message counter)) : + cache (tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes message ++ counterBytes counter)) ≠ none := by + apply hrun + rw [encode] + apply queriedInputs_mono_bind_left + simp only [queriedInputs_tweakableHash, List.mem_singleton] + +theorem CachedRun.otsLeaf_encode_cached {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {parameter : PublicParameter} {lay : Layer} + {tree : TreeIndex} {leafIdx : LeafIndex} {message : Digest} {counter : Counter} + {values : ChainIndex → Digest} + (hrun : CachedRun cache f (otsLeaf parameter lay tree leafIdx message counter values)) : + cache (tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes message ++ counterBytes counter)) ≠ none := + CachedRun.encode_cached hrun.bind_left + +theorem cached_encode_of_otsSignFrom_some (f : QueryImpl HashSpec Id) + (cache : QueryCache HashSpec) (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (secret : ChainIndex → Digest) + (message : Digest) (attempts counter : Nat) (resultCounter : Counter) + (values : ChainIndex → Digest) + (hsign : evalWithAnswerFn f + (otsSignFrom parameter lay tree leafIdx secret message attempts counter) + = some (resultCounter, values)) + (hrun : CachedRun cache f + (otsSignFrom parameter lay tree leafIdx secret message attempts counter)) : + cache (tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes message ++ counterBytes resultCounter)) ≠ none := by + induction attempts generalizing counter with + | zero => simp [otsSignFrom] at hsign + | succ attempts ih => + rw [otsSignFrom, evalWithAnswerFn_bind] at hsign + rw [otsSignFrom] at hrun + cases hencode : evalWithAnswerFn f + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) with + | none => + simp only [hencode] at hsign + exact ih (counter + 1) hsign (by + have hrest := hrun.bind_right + simpa only [hencode] using hrest) + | some codeword => + simp only [hencode, evalWithAnswerFn_bind, evalWithAnswerFn_sequenceFin, + evalWithAnswerFn_pure, Option.some.injEq, Prod.mk.injEq] at hsign + have hcounter : BitVec.ofNat counterBits counter = resultCounter := hsign.1 + rw [← hcounter] + exact CachedRun.encode_cached hrun.bind_left + +theorem SuccessfulSignRun.signed_encode_cached {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} (hrun : SuccessfulSignRun f cache secretKey message signature) + (lay : Layer) : + ∃ index leaves, SuccessfulDigestRun f cache secretKey message signature.randomness index leaves + ∧ cache (tweakableHashInput secretKey.parameter + (.encoding lay (treeIndexAt index lay) (leafIndexAt index lay)) + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay))) ≠ none := by + obtain ⟨index, leaves, parts, hdigest, _, _, hcounter, _, _, _, heval, hcached⟩ := hrun + have hlayerEval := heval lay + have hlayerRun := hcached lay + rw [signLayer, evalWithAnswerFn_bind, evalWithAnswerFn_bind] at hlayerEval + rw [signLayer] at hlayerRun + have hrestRun := hlayerRun.bind_right + let layerValue := evalWithAnswerFn f (layerMessage secretKey index lay) + cases hots : evalWithAnswerFn f + (otsSign secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) layerValue) with + | none => + simp only [layerValue, hots, evalWithAnswerFn_pure] at hlayerEval + cases hlayerEval + | some signed => + obtain ⟨counter, values⟩ := signed + have hotsRun : CachedRun cache f + (otsSign secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + layerValue) := by + have := hrestRun.bind_left + simpa only [layerValue] using this + simp only [layerValue, hots, evalWithAnswerFn_bind, evalWithAnswerFn_pure, + Option.some.injEq] at hlayerEval + have hpartCounter : counter = (parts lay).1 := congrArg Prod.fst hlayerEval + have hsignatureCounter : signature.counter lay = (parts lay).1 := congrFun hcounter lay + have hc := cached_encode_of_otsSignFrom_some f cache secretKey.parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) layerValue + encodingAttemptLimit 0 counter values (by simpa only [otsSign] using hots) + (by simpa only [otsSign] using hotsRun) + rw [hpartCounter, ← hsignatureCounter] at hc + exact ⟨index, leaves, hdigest, by simpa only [layerValue] using hc⟩ + +theorem SuccessfulSignRun.signed_encode_cached_of_digest {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} (hrun : SuccessfulSignRun f cache secretKey message signature) + {index : Index} {leaves : DigestTree → FtsLeaf} + (hdigest : SuccessfulDigestRun f cache secretKey message signature.randomness index leaves) + (lay : Layer) : + cache (tweakableHashInput secretKey.parameter + (.encoding lay (treeIndexAt index lay) (leafIndexAt index lay)) + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay))) ≠ none := by + obtain ⟨runIndex, _, hrunDigest, hcached⟩ := hrun.signed_encode_cached lay + obtain ⟨_, runValue, hrunValue, _, hrunIndex, _, _⟩ := hrunDigest.extract + obtain ⟨_, digestValue, hdigestValue, _, hdigestIndex, _, _⟩ := hdigest.extract + have hvalue : runValue = digestValue := by rw [← hrunValue, ← hdigestValue] + have hindex : runIndex = index := by rw [hrunIndex, hdigestIndex, hvalue] + rw [hindex] at hcached + exact hcached + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingCharge.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingCharge.lean new file mode 100644 index 00000000..dbcd590f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingCharge.lean @@ -0,0 +1,2086 @@ +import SphincsSecurity.Proof.EncodingTarget +import SphincsSecurity.Proof.FullTrace +import SphincsSecurity.Proof.MessagePrehit +import SphincsSecurity.Proof.NoMessage +import SphincsSecurity.Proof.RootCache +import SphincsSecurity.Proof.SignerDigestSource +import SphincsSecurity.Proof.SigningTrace + +/-! +# Amortized charge for encoding collisions + +The cache-local encoding target at one one-time position is unique. Inputs cached at that encoding +tweak before the target is pinned pay one unit each for the answer that pins it. Once pinned, a +fresh encoding query has only that one target. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +structure EncodingPosition where + lay : Layer + tree : TreeIndex + leafIdx : LeafIndex + deriving DecidableEq, Fintype + +def EncodingPosition.domain (position : EncodingPosition) : HashDomain := + .encoding position.lay position.tree position.leafIdx + +def AtEncodingPosition (parameter : PublicParameter) (input : HashInput) + (position : EncodingPosition) : Prop := + ∃ payload, input = tweakableHashInput parameter position.domain payload + +theorem atEncodingPosition_unique {parameter : PublicParameter} {input : HashInput} + {left right : EncodingPosition} (hleft : AtEncodingPosition parameter input left) + (hright : AtEncodingPosition parameter input right) : left = right := by + obtain ⟨leftPayload, hleft⟩ := hleft + obtain ⟨rightPayload, hright⟩ := hright + have hdomain := (tweakableHashInput_injective parameter (by trivial) (by trivial) + (hleft.symm.trans hright)).1 + obtain ⟨leftLay, leftTree, leftLeaf⟩ := left + obtain ⟨rightLay, rightTree, rightLeaf⟩ := right + simp only [EncodingPosition.domain, HashDomain.encoding.injEq] at hdomain + obtain ⟨rfl, rfl, rfl⟩ := hdomain + rfl + +theorem atEncodingPosition_ne {parameter : PublicParameter} {leftInput rightInput : HashInput} + {leftPosition rightPosition : EncodingPosition} + (hleft : AtEncodingPosition parameter leftInput leftPosition) + (hright : AtEncodingPosition parameter rightInput rightPosition) + (hne : leftPosition ≠ rightPosition) : leftInput ≠ rightInput := by + intro heq + exact hne (atEncodingPosition_unique hleft (heq ▸ hright)) + +theorem AtEncodingPosition.not_atPosition {parameter : PublicParameter} {input : HashInput} + {encodingPosition : EncodingPosition} (hencoding : AtEncodingPosition parameter input encodingPosition) + (position : Position) : ¬ AtPosition parameter input position := by + rintro ⟨structuralPayload, hstructural⟩ + obtain ⟨encodingPayload, hencodingInput⟩ := hencoding + have hdomain := (tweakableHashInput_injective parameter (by trivial) + position.domain_inRange (hencodingInput.symm.trans hstructural)).1 + cases position <;> simp [EncodingPosition.domain, Position.domain] at hdomain + +def AvoidsEncodingQueries {alpha : Type} (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (oa : OracleComp HashSpec alpha) : Prop := + ∀ (position : EncodingPosition) (payload : HashInput), + tweakableHashInput parameter position.domain payload ∉ queriedInputs f oa + +theorem AvoidsEncodingQueries.pure {alpha : Type} (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (value : alpha) : + AvoidsEncodingQueries parameter f (pure value) := by + simp [AvoidsEncodingQueries] + +theorem AvoidsEncodingQueries.bind {alpha beta : Type} {parameter : PublicParameter} + {f : QueryImpl HashSpec Id} {oa : OracleComp HashSpec alpha} + {next : alpha → OracleComp HashSpec beta} + (hleft : AvoidsEncodingQueries parameter f oa) + (hright : AvoidsEncodingQueries parameter f (next (evalWithAnswerFn f oa))) : + AvoidsEncodingQueries parameter f (oa >>= next) := by + intro position payload hinput + rw [queriedInputs_bind] at hinput + rcases List.mem_append.mp hinput with hinput | hinput + · exact hleft position payload hinput + · exact hright position payload hinput + +theorem AvoidsEncodingQueries.tweakableHash (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (domain : HashDomain) + (hdomain : ∀ position : EncodingPosition, domain ≠ position.domain) + (payload : HashInput) : AvoidsEncodingQueries parameter f + (tweakableHash parameter domain payload) := by + intro position encodingPayload hinput + simp only [queriedInputs_tweakableHash, List.mem_singleton] at hinput + simp only [tweakableHashInput] at hinput + obtain ⟨hprefix, _⟩ := List.append_inj hinput + (by simp [tweakBytes_length, bytesLE_length]) + obtain ⟨htweak, _⟩ := List.append_inj' hprefix (by simp [bytesLE_length]) + cases domain with + | encoding lay tree leafIdx => + apply hdomain position + exact (tweakBytes_injective (by trivial) (by trivial) htweak).symm + | chain | leaf | node | ftsLeaf | ftsNode | ftsRoots | message => + rw [tweakBytes_eq_iff] at htweak + simp [hashDomainFields, EncodingPosition.domain, TweakFields.mk.injEq] at htweak + +theorem QueriesAtPositions.avoidsEncoding {alpha : Type} {parameter : PublicParameter} + {f : QueryImpl HashSpec Id} {oa : OracleComp HashSpec alpha} + (hrun : QueriesAtPositions parameter f oa) : AvoidsEncodingQueries parameter f oa := by + intro position payload hinput + obtain ⟨structuralPosition, structuralPayload, heq⟩ := hrun _ hinput + exact (show AtEncodingPosition parameter + (tweakableHashInput parameter position.domain payload) position from ⟨_, rfl⟩).not_atPosition + structuralPosition ⟨structuralPayload, heq⟩ + +theorem avoidsEncodingQueries_sequenceFin {alpha : Type} {n : Nat} + (parameter : PublicParameter) (f : QueryImpl HashSpec Id) + (computation : Fin n → OracleComp HashSpec alpha) + (hcomputation : ∀ index, AvoidsEncodingQueries parameter f (computation index)) : + AvoidsEncodingQueries parameter f (sequenceFin computation) := by + induction n with + | zero => exact AvoidsEncodingQueries.pure parameter f _ + | succ n ih => + rw [sequenceFin] + apply AvoidsEncodingQueries.bind (hcomputation 0) + apply AvoidsEncodingQueries.bind + · exact ih (fun index : Fin n => computation index.succ) + (fun index => hcomputation index.succ) + · exact AvoidsEncodingQueries.pure parameter f _ + +theorem not_mem_queriedInputs_sequenceFin {alpha : Type} {n : Nat} + (f : QueryImpl HashSpec Id) (computation : Fin n → OracleComp HashSpec alpha) + (input : HashInput) (hcomputation : ∀ index, input ∉ queriedInputs f (computation index)) : + input ∉ queriedInputs f (sequenceFin computation) := by + induction n with + | zero => simp [sequenceFin] + | succ n ih => + rw [sequenceFin, queriedInputs_bind] + intro hinput + rcases List.mem_append.mp hinput with hhead | hrest + · exact hcomputation 0 hhead + · rw [queriedInputs_bind] at hrest + rcases List.mem_append.mp hrest with htail | hpure + · exact ih (fun index : Fin n => computation index.succ) + (fun index : Fin n => hcomputation index.succ) htail + · simp at hpure + +theorem avoidsEncodingQueries_treeNode (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) (level nodeIdx : Nat) : + AvoidsEncodingQueries parameter f (treeNode parameter lay tree secret level nodeIdx) := by + induction level generalizing nodeIdx with + | zero => + rw [treeNode_zero_eq] + apply AvoidsEncodingQueries.bind + · exact QueriesAtPositions.avoidsEncoding + (queriesAtPositions_oneTimePublicKey parameter f lay tree (leafOfNat nodeIdx) + (secret (leafOfNat nodeIdx))) + · apply AvoidsEncodingQueries.tweakableHash + intro position + simp [EncodingPosition.domain] + | succ level ih => + rw [treeNode_succ_eq] + apply AvoidsEncodingQueries.bind (ih (2 * nodeIdx)) + apply AvoidsEncodingQueries.bind (ih (2 * nodeIdx + 1)) + apply AvoidsEncodingQueries.tweakableHash + intro position + simp [EncodingPosition.domain] + +theorem avoidsEncodingQueries_treePath (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) (leafIdx : LeafIndex) : + AvoidsEncodingQueries parameter f (treePath parameter lay tree secret leafIdx) := by + apply avoidsEncodingQueries_sequenceFin + intro level + split + · exact avoidsEncodingQueries_treeNode parameter f lay tree secret _ _ + · exact AvoidsEncodingQueries.pure parameter f _ + +theorem avoidsEncodingQueries_ftsNode (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (index : Index) (tree : FtsTree) + (secret : FtsLeaf → Digest) (level nodeIdx : Nat) : + AvoidsEncodingQueries parameter f (ftsNode parameter index tree secret level nodeIdx) := by + induction level generalizing nodeIdx with + | zero => + rw [ftsNode_zero_eq] + apply AvoidsEncodingQueries.tweakableHash + intro position + simp [EncodingPosition.domain] + | succ level ih => + rw [ftsNode_succ_eq] + apply AvoidsEncodingQueries.bind (ih (2 * nodeIdx)) + apply AvoidsEncodingQueries.bind (ih (2 * nodeIdx + 1)) + apply AvoidsEncodingQueries.tweakableHash + intro position + simp [EncodingPosition.domain] + +theorem avoidsEncodingQueries_ftsKey (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (index : Index) (secret : FtsTree → FtsLeaf → Digest) : + AvoidsEncodingQueries parameter f (ftsKey parameter index secret) := by + rw [ftsKey] + apply AvoidsEncodingQueries.bind + · apply avoidsEncodingQueries_sequenceFin + intro tree + exact avoidsEncodingQueries_ftsNode parameter f index tree (secret tree) ftsTreeHeight 0 + · apply AvoidsEncodingQueries.tweakableHash + intro position + simp [EncodingPosition.domain] + +theorem avoidsEncodingQueries_ftsOpen (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (index : Index) (leaves : DigestTree → FtsLeaf) + (secret : FtsTree → FtsLeaf → Digest) : + AvoidsEncodingQueries parameter f (ftsOpen parameter index leaves secret) := by + apply avoidsEncodingQueries_sequenceFin + intro tree + apply avoidsEncodingQueries_sequenceFin + intro level + exact avoidsEncodingQueries_ftsNode parameter f index tree (secret tree) level.val _ + +theorem avoidsEncodingQueries_layerMessage (f : QueryImpl HashSpec Id) + (secretKey : SecretKey) (index : Index) (lay : Layer) : + AvoidsEncodingQueries secretKey.parameter f (layerMessage secretKey index lay) := by + rw [layerMessage] + split + · exact avoidsEncodingQueries_treeNode secretKey.parameter f _ _ _ _ _ + · exact avoidsEncodingQueries_ftsKey secretKey.parameter f index (secretKey.ftsSecret index) + +theorem signDigestLoop_cache_encoding_none (attempts : Nat) (secretKey : SecretKey) + (message : Message) (beforeCache afterCache : QueryCache HashSpec) + (result : Option (Randomness × Index × (DigestTree → FtsLeaf))) + (hmem : (result, afterCache) ∈ support + ((simulateQ romImpl (signDigestLoop attempts secretKey message)).run beforeCache)) + (target : HashInput) (position : EncodingPosition) + (hposition : AtEncodingPosition secretKey.parameter target position) + (hbefore : beforeCache target = none) : afterCache target = none := by + induction attempts generalizing beforeCache afterCache result with + | zero => + simp only [signDigestLoop, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff, Prod.mk.injEq] at hmem + obtain ⟨rfl, rfl⟩ := hmem + exact hbefore + | succ attempts ih => + rw [signDigestLoop, simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hmem + obtain ⟨⟨randomness, sampleCache⟩, hsample, hrest⟩ := hmem + have hsampleRun : (randomness, sampleCache) ∈ support + ((simulateQ (unifFwdImpl HashSpec) sampleRandomness).run beforeCache) := by + simpa only [romImpl, QueryImpl.simulateQ_add_liftM_left] using hsample + rw [unifFwdImpl.simulateQ_run, support_map] at hsampleRun + obtain ⟨sampledRandomness, _, heq⟩ := hsampleRun + obtain ⟨rfl, rfl⟩ := heq + rw [simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hrest + obtain ⟨⟨attempt, attemptCache⟩, hattempt, hfinish⟩ := hrest + have hattempt' : (attempt, attemptCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAttempt secretKey message randomness)).run beforeCache) := by + simpa only [simulateQ_romImpl_liftM] using hattempt + have hne : target ≠ tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness) := by + intro heq + obtain ⟨payload, htarget⟩ := hposition + have hdomain := (tweakableHashInput_injective secretKey.parameter (by trivial) + (by trivial) (htarget.symm.trans heq)).1 + cases position + simp [EncodingPosition.domain] at hdomain + have hattemptNone : attemptCache target = none := + signAttempt_cache_other_none secretKey message randomness beforeCache attemptCache + attempt hattempt' target hbefore hne + cases attempt with + | none => exact ih attemptCache afterCache result hfinish hattemptNone + | some selected => + simp only [simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq] at hfinish + obtain ⟨rfl, rfl⟩ := hfinish + exact hattemptNone + +theorem sign_cache_encoding_none_of_digest_eval + (secretKey : SecretKey) (message : Message) (signature : Signature) + (beforeCache afterCache : QueryCache HashSpec) + (hmem : (some signature, afterCache) ∈ support + ((simulateQ romImpl (sign secretKey message)).run beforeCache)) + (f : QueryImpl HashSpec Id) (hf : afterCache.AgreesWithFn f) + (index : Index) (leaves : DigestTree → FtsLeaf) + (hdigest : evalWithAnswerFn f + (signAttempt secretKey message signature.randomness) = some (index, leaves)) + (target : HashInput) (position : EncodingPosition) + (hposition : AtEncodingPosition secretKey.parameter target position) + (hbefore : beforeCache target = none) + (havoid : target ∉ queriedInputs f + (signAfterDigest secretKey signature.randomness index leaves)) : + afterCache target = none := by + rw [sign_eq_digestLoop_afterDigest, simulateQ_bind, StateT.run_bind, + mem_support_bind_iff] at hmem + obtain ⟨⟨loopResult, loopCache⟩, hloop, hfinish⟩ := hmem + cases loopResult with + | none => + simp only [simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq] at hfinish + cases hfinish.1 + | some selected => + obtain ⟨randomness, actualIndex, actualLeaves⟩ := selected + have hloopNone := signDigestLoop_cache_encoding_none digestAttemptLimit secretKey message + beforeCache loopCache (some (randomness, actualIndex, actualLeaves)) hloop target + position hposition hbefore + have hfinish' : (some signature, afterCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest secretKey randomness actualIndex actualLeaves)).run loopCache) := by + simpa only [simulateQ_romImpl_liftM] using hfinish + have hloopLe : loopCache ≤ afterCache := + simulateQ_romImpl_cache_le + (liftM (signAfterDigest secretKey randomness actualIndex actualLeaves) : + OracleComp OracleWorld (Option Signature)) loopCache _ hfinish + have hfLoop : loopCache.AgreesWithFn f := fun _ _ hcached => hf (hloopLe hcached) + have hloopReplay := replayRom_of_mem_support + (signDigestLoop digestAttemptLimit secretKey message) beforeCache + (some (randomness, actualIndex, actualLeaves)) loopCache hloop f hfLoop + have hactualDigest := successfulDigestLoop_of_mem_support f secretKey message + digestAttemptLimit randomness actualIndex actualLeaves beforeCache loopCache afterCache + hloopReplay hloopLe hf + have hrandomness : randomness = signature.randomness := + (signAfterDigest_support_some_randomness secretKey randomness actualIndex actualLeaves + loopCache afterCache signature hfinish').symm + have hselected : actualIndex = index ∧ actualLeaves = leaves := by + have hactual := hactualDigest.2.1 + have hexpected := hdigest + rw [hrandomness] at hactual + exact Prod.mk.inj (Option.some.inj (hactual.symm.trans hexpected)) + rw [hselected.1, hselected.2] at hfinish' + subst randomness + apply cache_eq_none_of_not_mem_queriedInputs + (signAfterDigest secretKey signature.randomness index leaves) loopCache + (some signature) afterCache hfinish' f hf target hloopNone + exact havoid + +theorem sign_cache_ne_none_of_digest_eval + (secretKey : SecretKey) (message : Message) (signature : Signature) + (beforeCache afterCache : QueryCache HashSpec) + (hmem : (some signature, afterCache) ∈ support + ((simulateQ romImpl (sign secretKey message)).run beforeCache)) + (f : QueryImpl HashSpec Id) (hf : afterCache.AgreesWithFn f) + (index : Index) (leaves : DigestTree → FtsLeaf) + (hdigest : evalWithAnswerFn f + (signAttempt secretKey message signature.randomness) = some (index, leaves)) + (target : HashInput) + (hquery : target ∈ queriedInputs f + (signAfterDigest secretKey signature.randomness index leaves)) : + afterCache target ≠ none := by + rw [sign_eq_digestLoop_afterDigest, simulateQ_bind, StateT.run_bind, + mem_support_bind_iff] at hmem + obtain ⟨⟨loopResult, loopCache⟩, hloop, hfinish⟩ := hmem + cases loopResult with + | none => + simp only [simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq] at hfinish + cases hfinish.1 + | some selected => + obtain ⟨randomness, actualIndex, actualLeaves⟩ := selected + have hfinish' : (some signature, afterCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest secretKey randomness actualIndex actualLeaves)).run loopCache) := by + simpa only [simulateQ_romImpl_liftM] using hfinish + have hloopLe : loopCache ≤ afterCache := + simulateQ_romImpl_cache_le + (liftM (signAfterDigest secretKey randomness actualIndex actualLeaves) : + OracleComp OracleWorld (Option Signature)) loopCache _ hfinish + have hfLoop : loopCache.AgreesWithFn f := fun _ _ hcached => hf (hloopLe hcached) + have hloopReplay := replayRom_of_mem_support + (signDigestLoop digestAttemptLimit secretKey message) beforeCache + (some (randomness, actualIndex, actualLeaves)) loopCache hloop f hfLoop + have hactualDigest := successfulDigestLoop_of_mem_support f secretKey message + digestAttemptLimit randomness actualIndex actualLeaves beforeCache loopCache afterCache + hloopReplay hloopLe hf + have hrandomness : randomness = signature.randomness := + (signAfterDigest_support_some_randomness secretKey randomness actualIndex actualLeaves + loopCache afterCache signature hfinish').symm + have hselected : actualIndex = index ∧ actualLeaves = leaves := by + have hactual := hactualDigest.2.1 + have hexpected := hdigest + rw [hrandomness] at hactual + exact Prod.mk.inj (Option.some.inj (hactual.symm.trans hexpected)) + rw [hselected.1, hselected.2] at hfinish' + subst randomness + exact (replay_of_mem_support + (signAfterDigest secretKey signature.randomness index leaves) loopCache + (some signature) afterCache hfinish' f hf).2.2 target hquery + +def QueriesAtEncodingPositionOrPositions {alpha : Type} (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (position : EncodingPosition) + (oa : OracleComp HashSpec alpha) : Prop := + ∀ input, input ∈ queriedInputs f oa → + AtEncodingPosition parameter input position ∨ + ∃ structuralPosition : Position, AtPosition parameter input structuralPosition + +theorem QueriesAtEncodingPositionOrPositions.pure {alpha : Type} + (parameter : PublicParameter) (f : QueryImpl HashSpec Id) (position : EncodingPosition) + (value : alpha) : + QueriesAtEncodingPositionOrPositions parameter f position (pure value) := by + simp [QueriesAtEncodingPositionOrPositions] + +theorem QueriesAtEncodingPositionOrPositions.bind {alpha beta : Type} + {parameter : PublicParameter} {f : QueryImpl HashSpec Id} {position : EncodingPosition} + {oa : OracleComp HashSpec alpha} {next : alpha → OracleComp HashSpec beta} + (hleft : QueriesAtEncodingPositionOrPositions parameter f position oa) + (hright : QueriesAtEncodingPositionOrPositions parameter f position + (next (evalWithAnswerFn f oa))) : + QueriesAtEncodingPositionOrPositions parameter f position (oa >>= next) := by + intro input hinput + rw [queriedInputs_bind] at hinput + rcases List.mem_append.mp hinput with hinput | hinput + · exact hleft input hinput + · exact hright input hinput + +theorem QueriesAtEncodingPositionOrPositions.encode (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (position : EncodingPosition) (message : Digest) + (counter : Counter) : + QueriesAtEncodingPositionOrPositions parameter f position + (encode parameter position.lay position.tree position.leafIdx message counter) := by + intro input hinput + rw [SphincsSecurity.Concrete.encode, queriedInputs_bind] at hinput + rcases List.mem_append.mp hinput with hinput | hinput + · simp only [queriedInputs_tweakableHash, List.mem_singleton] at hinput + exact Or.inl ⟨_, hinput⟩ + · simp at hinput + +theorem QueriesAtEncodingPositionOrPositions.structural {alpha : Type} + {parameter : PublicParameter} {f : QueryImpl HashSpec Id} {position : EncodingPosition} + {oa : OracleComp HashSpec alpha} (hrun : QueriesAtPositions parameter f oa) : + QueriesAtEncodingPositionOrPositions parameter f position oa := by + intro input hinput + obtain ⟨structuralPosition, payload, heq⟩ := hrun input hinput + exact Or.inr ⟨structuralPosition, payload, heq⟩ + +theorem queriesAtEncodingPositionOrPositions_otsSignFrom (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (position : EncodingPosition) + (secret : ChainIndex → Digest) (message : Digest) (attempts counter : Nat) : + QueriesAtEncodingPositionOrPositions parameter f position + (otsSignFrom parameter position.lay position.tree position.leafIdx secret message + attempts counter) := by + induction attempts generalizing counter with + | zero => exact QueriesAtEncodingPositionOrPositions.pure parameter f position _ + | succ attempts ih => + rw [otsSignFrom] + apply QueriesAtEncodingPositionOrPositions.bind + (QueriesAtEncodingPositionOrPositions.encode parameter f position message _) + split + · apply QueriesAtEncodingPositionOrPositions.bind + · apply QueriesAtEncodingPositionOrPositions.structural + apply queriesAtPositions_sequenceFin + intro chainIdx + exact queriesAtPositions_chainWalk parameter f position.lay position.tree + position.leafIdx chainIdx 0 _ _ + · exact QueriesAtEncodingPositionOrPositions.pure parameter f position _ + · exact ih (counter + 1) + +theorem queriesAtEncodingPositionOrPositions_otsSign (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (position : EncodingPosition) + (secret : ChainIndex → Digest) (message : Digest) : + QueriesAtEncodingPositionOrPositions parameter f position + (otsSign parameter position.lay position.tree position.leafIdx secret message) := by + exact queriesAtEncodingPositionOrPositions_otsSignFrom parameter f position secret message + encodingAttemptLimit 0 + +theorem encodingPayload_of_mem_otsSignFrom (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (position : EncodingPosition) + (secret : ChainIndex → Digest) (message : Digest) (attempts counter : Nat) + (payload : HashInput) + (hinput : tweakableHashInput parameter position.domain payload ∈ + queriedInputs f + (otsSignFrom parameter position.lay position.tree position.leafIdx secret message + attempts counter)) : + ∃ selected : Counter, payload = digestBytes message ++ counterBytes selected := by + induction attempts generalizing counter with + | zero => simp [otsSignFrom] at hinput + | succ attempts ih => + rw [otsSignFrom, queriedInputs_bind] at hinput + cases hencode : evalWithAnswerFn f + (encode parameter position.lay position.tree position.leafIdx message + (BitVec.ofNat counterBits counter)) with + | none => + rcases List.mem_append.mp hinput with hcurrent | hrest + · simp only [encode, queriedInputs_bind, queriedInputs_tweakableHash, + queriedInputs_pure, List.append_nil, List.mem_singleton] at hcurrent + have hpayload := + (tweakableHashInput_injective parameter (by trivial) (by trivial) hcurrent).2 + exact ⟨BitVec.ofNat counterBits counter, hpayload⟩ + · simp only [hencode] at hrest + exact ih (counter + 1) hrest + | some codeword => + rcases List.mem_append.mp hinput with hcurrent | hrest + · simp only [encode, queriedInputs_bind, queriedInputs_tweakableHash, + queriedInputs_pure, List.append_nil, List.mem_singleton] at hcurrent + have hpayload := + (tweakableHashInput_injective parameter (by trivial) (by trivial) hcurrent).2 + exact ⟨BitVec.ofNat counterBits counter, hpayload⟩ + · have hstructural : QueriesAtPositions parameter f (do + let values ← sequenceFin fun chainIdx => + chainWalk parameter position.lay position.tree position.leafIdx chainIdx 0 + (codeword chainIdx).val (secret chainIdx) + pure (some (BitVec.ofNat counterBits counter, values))) := by + apply QueriesAtPositions.bind + · apply queriesAtPositions_sequenceFin + intro chainIdx + exact queriesAtPositions_chainWalk parameter f position.lay position.tree + position.leafIdx chainIdx 0 _ _ + · exact QueriesAtPositions.pure parameter f _ + simp only [hencode] at hrest + obtain ⟨structuralPosition, structuralPayload, hstructuralInput⟩ := + hstructural _ hrest + exact False.elim ((encodingInput_ne_positionInput parameter position.lay + position.tree position.leafIdx payload structuralPosition structuralPayload) + hstructuralInput) + +theorem encodingPayload_of_mem_otsSign (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (position : EncodingPosition) + (secret : ChainIndex → Digest) (message : Digest) (payload : HashInput) + (hinput : tweakableHashInput parameter position.domain payload ∈ + queriedInputs f + (otsSign parameter position.lay position.tree position.leafIdx secret message)) : + ∃ selected : Counter, payload = digestBytes message ++ counterBytes selected := by + exact encodingPayload_of_mem_otsSignFrom parameter f position secret message + encodingAttemptLimit 0 payload (by simpa only [otsSign] using hinput) + +theorem encodingPosition_eq_of_mem_otsSign {parameter : PublicParameter} + {f : QueryImpl HashSpec Id} {queriedPosition runPosition : EncodingPosition} + {input : HashInput} {secret : ChainIndex → Digest} {message : Digest} + (hposition : AtEncodingPosition parameter input queriedPosition) + (hinput : input ∈ queriedInputs f + (otsSign parameter runPosition.lay runPosition.tree runPosition.leafIdx secret message)) : + queriedPosition = runPosition := by + rcases queriesAtEncodingPositionOrPositions_otsSign parameter f runPosition secret message + input hinput with hrun | ⟨structuralPosition, hstructural⟩ + · exact atEncodingPosition_unique hposition hrun + · exact absurd hstructural (hposition.not_atPosition structuralPosition) + +theorem encodingInput_mem_signLayer_otsSign {f : QueryImpl HashSpec Id} + {secretKey : SecretKey} {index : Index} {lay : Layer} {input : HashInput} + {position : EncodingPosition} (hposition : AtEncodingPosition secretKey.parameter input position) + (hinput : input ∈ queriedInputs f (signLayer secretKey index lay)) : + position = ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩ + ∧ input ∈ queriedInputs f + (otsSign secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay))) := by + obtain ⟨payload, hpayload⟩ := hposition + rw [signLayer, queriedInputs_bind] at hinput + rcases List.mem_append.mp hinput with hmessage | hrest + · exact absurd hmessage (by + rw [hpayload] + exact avoidsEncodingQueries_layerMessage f secretKey index lay position payload) + · rw [queriedInputs_bind] at hrest + rcases List.mem_append.mp hrest with hots | hafter + · exact ⟨encodingPosition_eq_of_mem_otsSign ⟨payload, hpayload⟩ hots, hots⟩ + · let signed := evalWithAnswerFn f + (otsSign secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay))) + have havoidAfter : AvoidsEncodingQueries secretKey.parameter f + (match signed with + | none => pure none + | some (counter, values) => do + let path ← treePath secretKey.parameter lay (treeIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay)) (leafIndexAt index lay) + pure (some (counter, values, path))) := by + cases signed with + | none => exact AvoidsEncodingQueries.pure secretKey.parameter f _ + | some part => + apply AvoidsEncodingQueries.bind + · exact avoidsEncodingQueries_treePath secretKey.parameter f lay + (treeIndexAt index lay) (secretKey.otsSecret lay (treeIndexAt index lay)) + (leafIndexAt index lay) + · exact AvoidsEncodingQueries.pure secretKey.parameter f _ + dsimp only [signed] at havoidAfter + rw [hpayload] at hafter + exact (havoidAfter position payload hafter).elim + +theorem other_valid_encoding_not_mem_otsSignFrom (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (secret : ChainIndex → Digest) (message otherMessage : Digest) (attempts counter : Nat) + (resultCounter otherCounter : Counter) (values : ChainIndex → Digest) + (otherCodeword : Encoding) + (hsign : evalWithAnswerFn f + (otsSignFrom parameter lay tree leafIdx secret message attempts counter) = + some (resultCounter, values)) + (hother : evalWithAnswerFn f + (encode parameter lay tree leafIdx otherMessage otherCounter) = some otherCodeword) + (hne : tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes message ++ counterBytes resultCounter) ≠ + tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes otherMessage ++ counterBytes otherCounter)) : + tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes otherMessage ++ counterBytes otherCounter) ∉ + queriedInputs f + (otsSignFrom parameter lay tree leafIdx secret message attempts counter) := by + induction attempts generalizing counter with + | zero => simp [otsSignFrom] + | succ attempts ih => + rw [otsSignFrom, evalWithAnswerFn_bind] at hsign + rw [otsSignFrom, queriedInputs_bind] + cases hencode : evalWithAnswerFn f + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) with + | none => + simp only [hencode] at hsign + intro hmem + rcases List.mem_append.mp hmem with hcurrent | hrest + · simp only [encode, queriedInputs_bind, queriedInputs_tweakableHash, + queriedInputs_pure, List.append_nil, List.mem_singleton] at hcurrent + have hdecodeNone := hencode + have hdecodeSome := hother + simp only [encode, evalWithAnswerFn_bind, evalWithAnswerFn_pure, + eval_tweakableHash] at hdecodeNone hdecodeSome + rw [hcurrent] at hdecodeSome + rw [hdecodeNone] at hdecodeSome + simp at hdecodeSome + · exact ih (counter + 1) hsign hrest + | some codeword => + simp only [hencode, evalWithAnswerFn_bind, evalWithAnswerFn_sequenceFin, + evalWithAnswerFn_pure, Option.some.injEq, Prod.mk.injEq] at hsign + have hcounter : BitVec.ofNat counterBits counter = resultCounter := hsign.1 + intro hmem + rcases List.mem_append.mp hmem with hcurrent | hrest + · simp only [encode, queriedInputs_bind, queriedInputs_tweakableHash, + queriedInputs_pure, List.append_nil, List.mem_singleton] at hcurrent + apply hne + rw [← hcounter] + exact hcurrent.symm + · have hstructural : QueriesAtPositions parameter f (do + let signedValues ← sequenceFin fun chainIdx => + chainWalk parameter lay tree leafIdx chainIdx 0 (codeword chainIdx).val + (secret chainIdx) + pure (some (BitVec.ofNat counterBits counter, signedValues))) := by + apply QueriesAtPositions.bind + · apply queriesAtPositions_sequenceFin + intro chainIdx + exact queriesAtPositions_chainWalk parameter f lay tree leafIdx chainIdx 0 _ _ + · exact QueriesAtPositions.pure parameter f _ + obtain ⟨position, payload, hinput⟩ := hstructural _ hrest + exact (show AtEncodingPosition parameter + (tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes otherMessage ++ counterBytes otherCounter)) + ⟨lay, tree, leafIdx⟩ from ⟨_, rfl⟩).not_atPosition position ⟨payload, hinput⟩ + +theorem other_valid_encoding_not_mem_otsSign (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (secret : ChainIndex → Digest) (message otherMessage : Digest) + (resultCounter otherCounter : Counter) (values : ChainIndex → Digest) + (otherCodeword : Encoding) + (hsign : evalWithAnswerFn f (otsSign parameter lay tree leafIdx secret message) = + some (resultCounter, values)) + (hother : evalWithAnswerFn f + (encode parameter lay tree leafIdx otherMessage otherCounter) = some otherCodeword) + (hne : tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes message ++ counterBytes resultCounter) ≠ + tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes otherMessage ++ counterBytes otherCounter)) : + tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes otherMessage ++ counterBytes otherCounter) ∉ + queriedInputs f (otsSign parameter lay tree leafIdx secret message) := by + exact other_valid_encoding_not_mem_otsSignFrom f parameter lay tree leafIdx secret message + otherMessage encodingAttemptLimit 0 resultCounter otherCounter values otherCodeword + (by simpa only [otsSign] using hsign) hother hne + +theorem EncodingCollision.forged_encoding_not_mem_signed_otsSign + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} + (hcollision : EncodingCollision f cache secretKey signingLog) : + ∃ (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (forgedMessage : Digest) (forgedCounter : Counter) (index : Index), + treeIndexAt index lay = tree + ∧ leafIndexAt index lay = leafIdx + ∧ tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes forgedMessage ++ counterBytes forgedCounter) ∉ + queriedInputs f + (otsSign secretKey.parameter lay tree leafIdx + (secretKey.otsSecret lay tree leafIdx) + (evalWithAnswerFn f (layerMessage secretKey index lay))) := by + obtain ⟨lay, tree, leafIdx, forgedMessage, forgedCounter, _, _, _, signature, index, + leaves, _, hforgedOpening, _, _, hrun, hdigest, htree, hleaf, _, _, _, hhit⟩ := hcollision + obtain ⟨forgedCodeword, hforgedEncode, _, _⟩ := hforgedOpening + obtain ⟨part, hcounter, _, hlayer⟩ := hrun.layerRun_of_digest hdigest lay + obtain ⟨hots, _⟩ := hlayer.otsSign_eval_cached + have hnotMem := other_valid_encoding_not_mem_otsSign f secretKey.parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay)) forgedMessage part.1 forgedCounter + part.2.1 forgedCodeword hots (by simpa only [htree, hleaf] using hforgedEncode) (by + rw [← hcounter, htree, hleaf] + exact hhit.1) + exact ⟨lay, tree, leafIdx, forgedMessage, forgedCounter, index, htree, hleaf, + by simpa only [htree, hleaf] using hnotMem⟩ + +theorem EncodingCollision.forged_encoding_not_mem_signLayers + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} + (hcollision : EncodingCollision f cache secretKey signingLog) : + ∃ (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (forgedMessage : Digest) (forgedCounter : Counter) (index : Index), + treeIndexAt index lay = tree + ∧ leafIndexAt index lay = leafIdx + ∧ ∀ otherLayer : Layer, + tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes forgedMessage ++ counterBytes forgedCounter) ∉ + queriedInputs f (signLayer secretKey index otherLayer) := by + obtain ⟨lay, tree, leafIdx, forgedMessage, forgedCounter, _, _, _, _, index, leaves, _, + hforgedOpening, _, _, hrun, hdigest, htree, hleaf, _, _, _, hhit⟩ := hcollision + obtain ⟨forgedCodeword, hforgedEncode, _, _⟩ := hforgedOpening + obtain ⟨part, hcounter, _, hlayer⟩ := hrun.layerRun_of_digest hdigest lay + obtain ⟨hots, _⟩ := hlayer.otsSign_eval_cached + have hnotOts := other_valid_encoding_not_mem_otsSign f secretKey.parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay)) forgedMessage part.1 forgedCounter + part.2.1 forgedCodeword hots (by simpa only [htree, hleaf] using hforgedEncode) (by + rw [← hcounter, htree, hleaf] + exact hhit.1) + refine ⟨lay, tree, leafIdx, forgedMessage, forgedCounter, index, htree, hleaf, ?_⟩ + intro otherLayer hmem + have hlocated := encodingInput_mem_signLayer_otsSign + (show AtEncodingPosition secretKey.parameter + (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes forgedMessage ++ counterBytes forgedCounter)) ⟨lay, tree, leafIdx⟩ from + ⟨_, rfl⟩) hmem + have hlayer : lay = otherLayer := congrArg EncodingPosition.lay hlocated.1 + subst otherLayer + rw [htree, hleaf] at hnotOts + rw [htree, hleaf] at hlocated + exact hnotOts hlocated.2 + +theorem SuccessfulSignRun.signed_encoding_mem_signLayer + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {message : Message} {signature : Signature} + (hrun : SuccessfulSignRun f cache secretKey message signature) + {index : Index} {leaves : DigestTree → FtsLeaf} + (hdigest : SuccessfulDigestRun f cache secretKey message signature.randomness index leaves) + (lay : Layer) : + tweakableHashInput secretKey.parameter + (.encoding lay (treeIndexAt index lay) (leafIndexAt index lay)) + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay)) ∈ + queriedInputs f (signLayer secretKey index lay) := by + obtain ⟨part, hcounter, _, hlayer⟩ := hrun.layerRun_of_digest hdigest lay + obtain ⟨hotsEval, _⟩ := hlayer.otsSign_eval_cached + have hmem := otsSign_selected_encoding_mem f secretKey.parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay)) part.1 part.2.1 hotsEval + rw [hcounter] + rw [signLayer] + apply queriedInputs_mono_bind_right f (layerMessage secretKey index lay) + apply queriedInputs_mono_bind_left f + exact hmem + +theorem SuccessfulSignRun.signed_encoding_mem_signAfterDigest + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {message : Message} {signature : Signature} + (hrun : SuccessfulSignRun f cache secretKey message signature) + {index : Index} {leaves : DigestTree → FtsLeaf} + (hdigest : SuccessfulDigestRun f cache secretKey message signature.randomness index leaves) + (lay : Layer) : + tweakableHashInput secretKey.parameter + (.encoding lay (treeIndexAt index lay) (leafIndexAt index lay)) + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay)) ∈ + queriedInputs f (signAfterDigest secretKey signature.randomness index leaves) := by + rw [signAfterDigest] + apply queriedInputs_mono_bind_right f + (ftsOpen secretKey.parameter index leaves (secretKey.ftsSecret index)) + apply queriedInputs_mono_bind_left f + exact sequenceFin_component_query_mem f (fun otherLayer => signLayer secretKey index otherLayer) + lay (hrun.signed_encoding_mem_signLayer hdigest lay) + +theorem EncodingCollision.forged_encoding_not_mem_signAfterDigest + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} + (hcollision : EncodingCollision f cache secretKey signingLog) : + ∃ (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (forgedMessage : Digest) (forgedCounter : Counter) + (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature) (index : Index) (leaves : DigestTree → FtsLeaf), + entry ∈ signingLog + ∧ entry.2 = some signature + ∧ SuccessfulSignRun f cache secretKey entry.1 signature + ∧ SuccessfulDigestRun f cache secretKey entry.1 signature.randomness index leaves + ∧ treeIndexAt index lay = tree + ∧ leafIndexAt index lay = leafIdx + ∧ cache (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay))) ≠ none + ∧ cache (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes forgedMessage ++ counterBytes forgedCounter)) ≠ none + ∧ tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay)) ≠ + tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes forgedMessage ++ counterBytes forgedCounter) + ∧ truncateHash (f (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay)))) = + truncateHash (f (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes forgedMessage ++ counterBytes forgedCounter))) + ∧ tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes forgedMessage ++ counterBytes forgedCounter) ∉ + queriedInputs f (signAfterDigest secretKey signature.randomness index leaves) := by + obtain ⟨lay, tree, leafIdx, forgedMessage, forgedCounter, _, _, entry, signature, index, + leaves, hforgedRun, hforgedOpening, hentry, hresponse, hrun, hdigest, htree, hleaf, _, _, + hsignedCached, hhit⟩ := + hcollision + obtain ⟨forgedCodeword, hforgedEncode, _, _⟩ := hforgedOpening + obtain ⟨part, hcounter, _, hlayer⟩ := hrun.layerRun_of_digest hdigest lay + obtain ⟨hots, _⟩ := hlayer.otsSign_eval_cached + have hnotOts := other_valid_encoding_not_mem_otsSign f secretKey.parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay)) forgedMessage part.1 forgedCounter + part.2.1 forgedCodeword hots (by simpa only [htree, hleaf] using hforgedEncode) (by + rw [← hcounter, htree, hleaf] + exact hhit.1) + let forgedInput := tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes forgedMessage ++ counterBytes forgedCounter) + have hnotLayers : ∀ otherLayer : Layer, + forgedInput ∉ queriedInputs f (signLayer secretKey index otherLayer) := by + intro otherLayer hmem + have hlocated := encodingInput_mem_signLayer_otsSign + (show AtEncodingPosition secretKey.parameter forgedInput ⟨lay, tree, leafIdx⟩ from + ⟨_, rfl⟩) hmem + have hlayer : lay = otherLayer := congrArg EncodingPosition.lay hlocated.1 + subst otherLayer + rw [htree, hleaf] at hnotOts hlocated + exact hnotOts hlocated.2 + have hnotAfter : forgedInput ∉ + queriedInputs f (signAfterDigest secretKey signature.randomness index leaves) := by + rw [signAfterDigest, queriedInputs_bind] + intro hmem + rcases List.mem_append.mp hmem with hfts | hrest + · exact avoidsEncodingQueries_ftsOpen secretKey.parameter f index leaves + (secretKey.ftsSecret index) ⟨lay, tree, leafIdx⟩ + (digestBytes forgedMessage ++ counterBytes forgedCounter) hfts + · rw [queriedInputs_bind] at hrest + rcases List.mem_append.mp hrest with hlayers | hfinal + · exact not_mem_queriedInputs_sequenceFin f (fun otherLayer => + signLayer secretKey index otherLayer) forgedInput hnotLayers hlayers + · split at hfinal <;> simp at hfinal + exact ⟨lay, tree, leafIdx, forgedMessage, forgedCounter, entry, signature, index, leaves, + hentry, hresponse, hrun, hdigest, htree, hleaf, hsignedCached, + CachedRun.otsLeaf_encode_cached hforgedRun, hhit.1, hhit.2, + by simpa only [forgedInput] using hnotAfter⟩ + +theorem SigningCacheTrace.exists_cacheEntry_of_mem_toSigningLog + {trace : SigningCacheTrace} + {entry : (request : SignRequest) × SigningSpec.Range request} + (hentry : entry ∈ trace.toSigningLog) : + ∃ cacheEntry : SigningCacheEntry, cacheEntry ∈ trace + ∧ (⟨cacheEntry.request, cacheEntry.signature⟩ : + (request : SignRequest) × SigningSpec.Range request) = entry := by + rw [SigningCacheTrace.toSigningLog, List.mem_map] at hentry + obtain ⟨cacheEntry, hcacheEntry, heq⟩ := hentry + exact ⟨cacheEntry, hcacheEntry, heq⟩ + +theorem EncodingCollision.signingInterval_collision_timing + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {trace : SigningCacheTrace} {signingLog : QueryLog SigningSpec} + (hcollision : EncodingCollision f cache secretKey signingLog) + (hlog : trace.toSigningLog = signingLog) (hvalid : trace.ValidRuns secretKey) + (hcaches : trace.CachesLe cache) (hf : cache.AgreesWithFn f) : + ∃ (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (forgedMessage : Digest) (forgedCounter : Counter) + (cacheEntry : SigningCacheEntry) (signature : Signature) + (index : Index), + cacheEntry ∈ trace + ∧ cacheEntry.signature = some signature + ∧ treeIndexAt index lay = tree + ∧ leafIndexAt index lay = leafIdx + ∧ let targetInput := tweakableHashInput secretKey.parameter + (.encoding lay tree leafIdx) + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay)) + let forgedInput := tweakableHashInput secretKey.parameter + (.encoding lay tree leafIdx) + (digestBytes forgedMessage ++ counterBytes forgedCounter) + cache targetInput ≠ none ∧ + CachedSignedEncodingPayloadAt cache secretKey lay tree leafIdx + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay)) ∧ + cache forgedInput ≠ none ∧ + targetInput ≠ forgedInput ∧ + truncateHash (f targetInput) = truncateHash (f forgedInput) ∧ + cacheEntry.finalCache targetInput ≠ none ∧ + ((cacheEntry.initialCache forgedInput ≠ none ∧ + cacheEntry.initialCache targetInput = none) ∨ + (cacheEntry.initialCache forgedInput ≠ none ∧ + cacheEntry.initialCache targetInput ≠ none) ∨ + cacheEntry.finalCache forgedInput = none) := by + obtain ⟨lay, tree, leafIdx, forgedMessage, forgedCounter, entry, signature, index, + leaves, hentry, hresponse, hrun, hdigest, htree, hleaf, htargetCached, hforgedCached, + hinputNe, hcollision, havoid⟩ := + hcollision.forged_encoding_not_mem_signAfterDigest + have hsignedTarget : CachedSignedEncodingPayloadAt cache secretKey lay tree leafIdx + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay)) := by + apply SignedEncodingPayloadAt.cached hf + exact ⟨entry, signature, index, leaves, hentry, hresponse, hrun, hdigest, htree, hleaf, rfl⟩ + have hentry' : entry ∈ trace.toSigningLog := by rwa [hlog] + obtain ⟨cacheEntry, hcacheEntry, heq⟩ := + SigningCacheTrace.exists_cacheEntry_of_mem_toSigningLog hentry' + subst entry + have hfinalLe := (hcaches cacheEntry hcacheEntry).2 + have hfinalAgree : cacheEntry.finalCache.AgreesWithFn f := + fun _ _ hcached => hf (hfinalLe hcached) + let forgedInput := tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes forgedMessage ++ counterBytes forgedCounter) + let targetInput := tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay)) + have hposition : AtEncodingPosition secretKey.parameter forgedInput ⟨lay, tree, leafIdx⟩ := + ⟨_, rfl⟩ + have hvalidRun := hvalid cacheEntry hcacheEntry + change cacheEntry.signature = some signature at hresponse + rw [SigningCacheEntry.ValidRun, hresponse] at hvalidRun + have htargetQuery := hrun.signed_encoding_mem_signAfterDigest hdigest lay + have htargetFinal : cacheEntry.finalCache targetInput ≠ none := + sign_cache_ne_none_of_digest_eval secretKey cacheEntry.request signature + cacheEntry.initialCache cacheEntry.finalCache hvalidRun f hfinalAgree index leaves + hdigest.2.1 targetInput (by simpa only [targetInput, htree, hleaf] using htargetQuery) + refine ⟨lay, tree, leafIdx, forgedMessage, forgedCounter, cacheEntry, signature, index, + hcacheEntry, hresponse, htree, hleaf, htargetCached, hsignedTarget, hforgedCached, hinputNe, + hcollision, htargetFinal, ?_⟩ + by_cases hinitial : cacheEntry.initialCache forgedInput = none + · right + right + exact sign_cache_encoding_none_of_digest_eval secretKey cacheEntry.request signature + cacheEntry.initialCache cacheEntry.finalCache hvalidRun f hfinalAgree index leaves + hdigest.2.1 forgedInput ⟨lay, tree, leafIdx⟩ hposition hinitial (by + simpa only [forgedInput] using havoid) + · by_cases htargetInitial : cacheEntry.initialCache targetInput = none + · exact Or.inl ⟨hinitial, htargetInitial⟩ + · exact Or.inr (Or.inl ⟨hinitial, htargetInitial⟩) + +theorem EncodingCollision.signingInterval_prehit_or_later_source + {f : QueryImpl HashSpec Id} {cache rootCache adversaryCache : QueryCache HashSpec} + {secretKey : SecretKey} {trace : FullAdversaryTrace} + (hcollision : EncodingCollision f cache secretKey trace.signing.toSigningLog) + (hvalidRuns : trace.signing.ValidRuns secretKey) + (hcaches : trace.signing.CachesLe cache) (hf : cache.AgreesWithFn f) + (hconsistent : trace.Consistent) + (hchain : FullAdversaryTrace.CacheChain rootCache trace.intervals adversaryCache) + (hchronological : FullAdversaryTrace.Chronological trace.intervals) + (hvalidIntervals : trace.ValidIntervals secretKey) : + ∃ (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (forgedMessage : Digest) (forgedCounter : Counter) + (cacheEntry : SigningCacheEntry) (signature : Signature) (index : Index) + (selected : Fin trace.intervals.length), + cacheEntry ∈ trace.signing + ∧ cacheEntry.signature = some signature + ∧ treeIndexAt index lay = tree + ∧ leafIndexAt index lay = leafIdx + ∧ AdversaryCacheEntry.signingEntry? (trace.intervals.get selected) = some cacheEntry + ∧ let forgedInput := tweakableHashInput secretKey.parameter + (.encoding lay tree leafIdx) + (digestBytes forgedMessage ++ counterBytes forgedCounter) + cache forgedInput ≠ none ∧ + (cacheEntry.initialCache forgedInput ≠ none ∨ + (∃ source : Fin trace.intervals.length, + selected.val < source.val + ∧ (trace.intervals.get source).initialCache forgedInput = none + ∧ (trace.intervals.get source).finalCache forgedInput ≠ none) ∨ + (adversaryCache forgedInput = none ∧ cache forgedInput ≠ none)) := by + obtain ⟨lay, tree, leafIdx, forgedMessage, forgedCounter, cacheEntry, signature, index, + hcacheEntry, hresponse, htree, hleaf, _, _, hforgedCached, _, _, _, hcase⟩ := + hcollision.signingInterval_collision_timing rfl hvalidRuns hcaches hf + obtain ⟨selected, hselected⟩ := + trace.exists_intervalPosition_of_signingEntry hconsistent cacheEntry hcacheEntry + refine ⟨lay, tree, leafIdx, forgedMessage, forgedCounter, cacheEntry, signature, index, + selected, hcacheEntry, hresponse, htree, hleaf, hselected, hforgedCached, ?_⟩ + rcases hcase with hfreshTarget | hbothPrehit | hfinalMiss + · exact Or.inl hfreshTarget.1 + · exact Or.inl hbothPrehit.1 + · right + by_cases hadversary : adversaryCache (tweakableHashInput secretKey.parameter + (.encoding lay tree leafIdx) + (digestBytes forgedMessage ++ counterBytes forgedCounter)) = none + · exact Or.inr ⟨hadversary, hforgedCached⟩ + · left + have hmono : ∀ entry ∈ trace.intervals, + entry.initialCache ≤ entry.finalCache := by + intro entry hentry + exact unloggedMappedAdversaryImpl_cache_le secretKey entry.input entry.initialCache + (entry.output, entry.finalCache) (hvalidIntervals entry hentry) + apply hchain.transition_after hchronological hmono selected + · rwa [(trace.intervals.get selected).finalCache_eq_of_signingEntry?_eq_some hselected] + · exact hadversary + +def encodingCachedAt (parameter : PublicParameter) (cache : QueryCache HashSpec) + (position : EncodingPosition) : Set HashInput := + {input | cache input ≠ none ∧ AtEncodingPosition parameter input position} + +@[simp] theorem slotDigest_zero_encodingInput (parameter : PublicParameter) + (position : EncodingPosition) (message : Digest) (counter : Counter) : + slotDigest 0 (tweakableHashInput parameter position.domain + (digestBytes message ++ counterBytes counter)) = message := by + rw [slotDigest, payloadOf_tweakableHashInput] + simp only [Nat.mul_zero, List.drop_zero] + rw [← digestBytes_length message, List.take_left, digestOfBytes_digestBytes] + +theorem encodingCachedAt_finite {parameter : PublicParameter} {cache : QueryCache HashSpec} + (hfinite : Finite cache) (position : EncodingPosition) : + (encodingCachedAt parameter cache position).Finite := + hfinite.subset fun _ hinput => hinput.1 + +theorem sum_encodingCachedAt_ncard_le + {parameter : PublicParameter} {cache : QueryCache HashSpec} + (hfinite : Finite cache) : + (∑ position : EncodingPosition, + (encodingCachedAt parameter cache position).ncard) ≤ + {input | cache input ≠ none}.ncard := by + have hdisjoint : Pairwise (Function.onFun Disjoint + fun position : EncodingPosition => encodingCachedAt parameter cache position) := by + intro left right hne + change Disjoint (encodingCachedAt parameter cache left) + (encodingCachedAt parameter cache right) + rw [Set.disjoint_left] + intro input hleft hright + exact hne (atEncodingPosition_unique hleft.2 hright.2) + have hsubset : (⋃ position : EncodingPosition, + encodingCachedAt parameter cache position) ⊆ {input | cache input ≠ none} := by + intro input hinput + rw [Set.mem_iUnion] at hinput + obtain ⟨position, hposition⟩ := hinput + exact hposition.1 + calc + (∑ position : EncodingPosition, + (encodingCachedAt parameter cache position).ncard) = + ∑ᶠ position : EncodingPosition, + (encodingCachedAt parameter cache position).ncard := by + exact (finsum_eq_sum_of_fintype _).symm + _ = (⋃ position : EncodingPosition, + encodingCachedAt parameter cache position).ncard := + (Set.ncard_iUnion_of_finite + (fun position => encodingCachedAt_finite + (parameter := parameter) hfinite position) hdisjoint).symm + _ ≤ {input | cache input ≠ none}.ncard := + Set.ncard_le_ncard hsubset hfinite + +noncomputable def encodingMessageTargets (parameter : PublicParameter) + (cache : QueryCache HashSpec) (hfinite : Finite cache) + (position : EncodingPosition) : Finset Digest := + open Classical in + (encodingCachedAt_finite (parameter := parameter) (cache := cache) hfinite position).toFinset.image + (slotDigest 0) + +theorem slotDigest_mem_encodingMessageTargets {parameter : PublicParameter} + {cache : QueryCache HashSpec} (hfinite : Finite cache) {position : EncodingPosition} + {input : HashInput} (hcached : cache input ≠ none) + (hposition : AtEncodingPosition parameter input position) : + slotDigest 0 input ∈ encodingMessageTargets parameter cache hfinite position := by + rw [encodingMessageTargets, Finset.mem_image] + refine ⟨input, ?_, rfl⟩ + rw [Set.Finite.mem_toFinset] + exact ⟨hcached, hposition⟩ + +theorem encodingMessageTargets_card_le {parameter : PublicParameter} + {cache : QueryCache HashSpec} (hfinite : Finite cache) (position : EncodingPosition) : + (encodingMessageTargets parameter cache hfinite position).card ≤ + (encodingCachedAt parameter cache position).ncard := by + rw [encodingMessageTargets, Set.ncard_eq_toFinset_card _ + (encodingCachedAt_finite (parameter := parameter) (cache := cache) hfinite position)] + exact Finset.card_image_le + +noncomputable def encodingAnswerTargets (parameter : PublicParameter) + (cache : QueryCache HashSpec) (hfinite : Finite cache) + (position : EncodingPosition) : Finset Digest := + open Classical in + (encodingCachedAt_finite (parameter := parameter) (cache := cache) hfinite position).toFinset.image + fun input => truncateHash (fromCache cache input) + +theorem cachedAnswer_mem_encodingAnswerTargets {parameter : PublicParameter} + {cache : QueryCache HashSpec} (hfinite : Finite cache) {position : EncodingPosition} + {input : HashInput} {answer : HashOutput} (hcached : cache input = some answer) + (hposition : AtEncodingPosition parameter input position) : + truncateHash answer ∈ encodingAnswerTargets parameter cache hfinite position := by + rw [encodingAnswerTargets, Finset.mem_image] + refine ⟨input, ?_, ?_⟩ + · rw [Set.Finite.mem_toFinset] + exact ⟨by simp [hcached], hposition⟩ + · simp [fromCache, hcached] + +theorem encodingAnswerTargets_card_le {parameter : PublicParameter} + {cache : QueryCache HashSpec} (hfinite : Finite cache) (position : EncodingPosition) : + (encodingAnswerTargets parameter cache hfinite position).card ≤ + (encodingCachedAt parameter cache position).ncard := by + rw [encodingAnswerTargets, Set.ncard_eq_toFinset_card _ + (encodingCachedAt_finite (parameter := parameter) (cache := cache) hfinite position)] + exact Finset.card_image_le + +noncomputable def encodingValidAnswerTargets (parameter : PublicParameter) + (cache : QueryCache HashSpec) (hfinite : Finite cache) + (position : EncodingPosition) : Finset Digest := + (encodingAnswerTargets parameter cache hfinite position).filter TargetSum.ValidDigest + +theorem cachedValidAnswer_mem_encodingValidAnswerTargets {parameter : PublicParameter} + {cache : QueryCache HashSpec} (hfinite : Finite cache) {position : EncodingPosition} + {input : HashInput} {answer : HashOutput} (hcached : cache input = some answer) + (hposition : AtEncodingPosition parameter input position) + (hvalid : TargetSum.ValidDigest (truncateHash answer)) : + truncateHash answer ∈ encodingValidAnswerTargets parameter cache hfinite position := by + rw [encodingValidAnswerTargets, Finset.mem_filter] + exact ⟨cachedAnswer_mem_encodingAnswerTargets hfinite hcached hposition, hvalid⟩ + +theorem encodingValidAnswerTargets_card_le {parameter : PublicParameter} + {cache : QueryCache HashSpec} (hfinite : Finite cache) (position : EncodingPosition) : + (encodingValidAnswerTargets parameter cache hfinite position).card ≤ + (encodingCachedAt parameter cache position).ncard := by + exact (Finset.card_filter_le _ _).trans (encodingAnswerTargets_card_le hfinite position) + +theorem CachedSignedEncodingPayloadAt.target_mem_encodingValidAnswerTargets + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {position : EncodingPosition} {payload : HashInput} + (htarget : CachedSignedEncodingPayloadAt cache secretKey position.lay position.tree + position.leafIdx payload) : + truncateHash (fromCache cache + (tweakableHashInput secretKey.parameter position.domain payload)) ∈ + encodingValidAnswerTargets secretKey.parameter cache hfinite position := by + have htargetData := htarget + obtain ⟨_, _, _, _, _, _, _, _, hcached⟩ := htargetData + obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hcached + have hanswer' : cache + (tweakableHashInput secretKey.parameter position.domain payload) = some answer := by + simpa only [EncodingPosition.domain] using hanswer + have hfromCache : fromCache cache + (tweakableHashInput secretKey.parameter position.domain payload) = answer := by + simp [fromCache, hanswer'] + rw [hfromCache] + apply cachedValidAnswer_mem_encodingValidAnswerTargets hfinite hanswer' + · exact ⟨payload, rfl⟩ + · have hvalid := htarget.target_valid + rwa [show HashDomain.encoding position.lay position.tree position.leafIdx = position.domain by + cases position + rfl, hfromCache] at hvalid + +theorem signedLayerMessage_mem_encodingMessageTargets + {cache : QueryCache HashSpec} (hfinite : Finite cache) {f : QueryImpl HashSpec Id} + {secretKey : SecretKey} {index : Index} {lay : Layer} {tree : TreeIndex} + {leafIdx : LeafIndex} {counter : Counter} + (hcached : cache (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes counter)) ≠ none) : + evalWithAnswerFn f (layerMessage secretKey index lay) ∈ + encodingMessageTargets secretKey.parameter cache hfinite ⟨lay, tree, leafIdx⟩ := by + let position : EncodingPosition := ⟨lay, tree, leafIdx⟩ + change cache (tweakableHashInput secretKey.parameter position.domain + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes counter)) ≠ none at hcached + have hmem := slotDigest_mem_encodingMessageTargets hfinite hcached + (show AtEncodingPosition secretKey.parameter + (tweakableHashInput secretKey.parameter position.domain + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes counter)) position from ⟨_, rfl⟩) + rw [slotDigest_zero_encodingInput] at hmem + exact hmem + +theorem CachedSignedEncodingPayloadAt.message_hit_of_cacheQuery_of_unsettled + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {lay : Layer} {tree : TreeIndex} {leafIdx : LeafIndex} {payload : HashInput} + {queryIndex : Index} (huncached : cache input = none) + (htree : treeIndexAt queryIndex lay = tree) + (hleaf : leafIndexAt queryIndex lay = leafIdx) + (hposition : AtPosition secretKey.parameter input (layerMessagePosition queryIndex lay)) + (hunsettled : ¬ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (layerMessagePosition queryIndex lay)) + (htarget : CachedSignedEncodingPayloadAt (cache.cacheQuery input answer) secretKey + lay tree leafIdx payload) : + truncateHash answer ∈ + encodingMessageTargets secretKey.parameter cache hfinite ⟨lay, tree, leafIdx⟩ := by + obtain ⟨targetIndex, counter, htargetTree, htargetLeaf, hsettled, _, _, hpayload, + hcached⟩ := htarget + have hmessagePosition := layerMessagePosition_eq_of_position_eq queryIndex targetIndex lay + (htree.trans htargetTree.symm) (hleaf.trans htargetLeaf.symm) + have htargetUnsettled : + ¬ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (layerMessagePosition targetIndex lay) := by + rwa [← hmessagePosition] + have htargetPosition : AtPosition secretKey.parameter input + (layerMessagePosition targetIndex lay) := by + rwa [← hmessagePosition] + have hmessage := honestValue_cacheQuery_self_of_settled secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret huncached htargetPosition htargetUnsettled hsettled + let position : EncodingPosition := ⟨lay, tree, leafIdx⟩ + let targetInput := tweakableHashInput secretKey.parameter position.domain payload + have htargetInputNe : targetInput ≠ input := by + intro heq + exact (show AtEncodingPosition secretKey.parameter targetInput position from ⟨payload, rfl⟩).not_atPosition + (layerMessagePosition targetIndex lay) (heq ▸ htargetPosition) + have hcachedOld : cache targetInput ≠ none := by + change cache.cacheQuery input answer targetInput ≠ none at hcached + rwa [QueryCache.cacheQuery_of_ne _ _ htargetInputNe] at hcached + have hmem := slotDigest_mem_encodingMessageTargets hfinite hcachedOld + (show AtEncodingPosition secretKey.parameter targetInput position from ⟨payload, rfl⟩) + dsimp only [targetInput, position, EncodingPosition.domain] at hmem + rw [hpayload] at hmem + have hslot : slotDigest 0 + (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes (honestValue (fromCache (cache.cacheQuery input answer)) + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition targetIndex lay)) ++ counterBytes counter)) = + honestValue (fromCache (cache.cacheQuery input answer)) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret (layerMessagePosition targetIndex lay) := by + simpa only [EncodingPosition.domain] using slotDigest_zero_encodingInput + secretKey.parameter (show EncodingPosition from ⟨lay, tree, leafIdx⟩) + (honestValue (fromCache (cache.cacheQuery input answer)) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret (layerMessagePosition targetIndex lay)) counter + rw [hslot, hmessage] at hmem + exact hmem + +def HasEncodingTarget (cache : QueryCache HashSpec) (secretKey : SecretKey) + (position : EncodingPosition) : Prop := + ∃ payload, CachedSignedEncodingPayloadAt cache secretKey position.lay position.tree + position.leafIdx payload + +theorem HasEncodingTarget.mono {cache cache' : QueryCache HashSpec} {secretKey : SecretKey} + {position : EncodingPosition} (hle : cache ≤ cache') + (htarget : HasEncodingTarget cache secretKey position) : + HasEncodingTarget cache' secretKey position := by + obtain ⟨payload, hpayload⟩ := htarget + exact ⟨payload, hpayload.mono hle⟩ + +theorem HasEncodingTarget.payload_unique {cache : QueryCache HashSpec} {secretKey : SecretKey} + {position : EncodingPosition} {leftPayload rightPayload : HashInput} + (left : CachedSignedEncodingPayloadAt cache secretKey position.lay position.tree + position.leafIdx leftPayload) + (right : CachedSignedEncodingPayloadAt cache secretKey position.lay position.tree + position.leafIdx rightPayload) : leftPayload = rightPayload := + cachedSignedEncodingPayloadAt_unique left right + +theorem hasEncodingTarget_of_sign_transition + (secretKey : SecretKey) (message : Message) + (beforeCache afterCache : QueryCache HashSpec) (result : Option Signature) + (hmem : (result, afterCache) ∈ support + ((simulateQ romImpl (sign secretKey message)).run beforeCache)) + (position : EncodingPosition) (payload : HashInput) + (hbefore : beforeCache + (tweakableHashInput secretKey.parameter position.domain payload) = none) + (hafter : afterCache + (tweakableHashInput secretKey.parameter position.domain payload) ≠ none) + (hvalid : TargetSum.ValidDigest (truncateHash (fromCache afterCache + (tweakableHashInput secretKey.parameter position.domain payload)))) : + HasEncodingTarget afterCache secretKey position := by + let targetInput := tweakableHashInput secretKey.parameter position.domain payload + let f := fromCache afterCache + have hf : afterCache.AgreesWithFn f := agreesWithFn_fromCache afterCache + rw [sign_eq_digestLoop_afterDigest, simulateQ_bind, StateT.run_bind, + mem_support_bind_iff] at hmem + obtain ⟨⟨loopResult, loopCache⟩, hloop, hfinish⟩ := hmem + have hloopNone : loopCache targetInput = none := + signDigestLoop_cache_encoding_none digestAttemptLimit secretKey message beforeCache + loopCache loopResult hloop targetInput position ⟨payload, rfl⟩ (by + simpa only [targetInput] using hbefore) + cases loopResult with + | none => + simp only [simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq] at hfinish + obtain ⟨rfl, rfl⟩ := hfinish + exact (hafter hloopNone).elim + | some selected => + obtain ⟨randomness, index, leaves⟩ := selected + have hfinish' : (result, afterCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest secretKey randomness index leaves)).run loopCache) := by + simpa only [simulateQ_romImpl_liftM] using hfinish + obtain ⟨_, hafterEval, hafterRun⟩ := replay_of_mem_support + (signAfterDigest secretKey randomness index leaves) loopCache result afterCache + hfinish' f hf + have hquery : targetInput ∈ + queriedInputs f (signAfterDigest secretKey randomness index leaves) := by + by_contra hnot + have hnone := cache_eq_none_of_not_mem_queriedInputs + (signAfterDigest secretKey randomness index leaves) loopCache result afterCache + hfinish' f hf targetInput hloopNone hnot + exact hafter (by simpa only [targetInput] using hnone) + rw [signAfterDigest, queriedInputs_bind] at hquery + rcases List.mem_append.mp hquery with hfts | hrest + · exact False.elim (avoidsEncodingQueries_ftsOpen secretKey.parameter f index leaves + (secretKey.ftsSecret index) position payload (by simpa only [targetInput] using hfts)) + · rw [queriedInputs_bind] at hrest + rcases List.mem_append.mp hrest with hlayers | hpure + · have hexists : ∃ lay : Layer, + targetInput ∈ queriedInputs f (signLayer secretKey index lay) := by + by_contra hnone + apply not_mem_queriedInputs_sequenceFin f + (fun lay => signLayer secretKey index lay) targetInput + (fun lay hmem => hnone ⟨lay, hmem⟩) + exact hlayers + obtain ⟨lay, hlayerQuery⟩ := hexists + have hlocated := encodingInput_mem_signLayer_otsSign + (show AtEncodingPosition secretKey.parameter targetInput position from + ⟨payload, rfl⟩) hlayerQuery + have hposition : position = + ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩ := hlocated.1 + subst position + obtain ⟨counter, hpayload⟩ := encodingPayload_of_mem_otsSign + secretKey.parameter f + ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩ + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay)) payload + (by simpa only [targetInput, EncodingPosition.domain] using hlocated.2) + have htargetInput : targetInput = tweakableHashInput secretKey.parameter + (.encoding lay (treeIndexAt index lay) (leafIndexAt index lay)) + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes counter) := by + simp only [targetInput, EncodingPosition.domain, hpayload] + have hvalidEncode : evalWithAnswerFn f + (encode secretKey.parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) + (evalWithAnswerFn f (layerMessage secretKey index lay)) counter) ≠ none := by + apply (eval_encode_ne_none_iff_validDigest f secretKey.parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f (layerMessage secretKey index lay)) counter).mpr + dsimp only [EncodingPosition.domain] at hvalid + rw [hpayload] at hvalid + simpa only [f] using hvalid + obtain ⟨values, hotsEval⟩ := otsSignFrom_eq_some_of_valid_query f + secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay)) encodingAttemptLimit 0 + counter (by simpa only [otsSign, htargetInput] using hlocated.2) hvalidEncode + have hlayerRun : CachedRun afterCache f (signLayer secretKey index lay) := by + intro input hinput + apply hafterRun input + rw [signAfterDigest, queriedInputs_bind] + apply List.mem_append_right + rw [queriedInputs_bind] + apply List.mem_append_left + exact sequenceFin_component_query_mem f + (fun otherLayer => signLayer secretKey index otherLayer) lay hinput + rw [signLayer] at hlayerRun + have hmessageRun := hlayerRun.bind_left + have hotsRun : CachedRun afterCache f + (otsSign secretKey.parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay))) := + hlayerRun.bind_right.bind_left + have hselection := otsSign_encodingSearch_some_cached f afterCache + secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay)) counter values + (by simpa only [otsSign] using hotsEval) hotsRun + have hsettled := layerMessagePosition_settled_of_cachedRun hf hmessageRun + have hmessage := eval_layerMessage_eq_honestValue (fromCache afterCache) + secretKey index lay + dsimp only [f] at hpayload hselection + rw [hmessage] at hpayload hselection + refine ⟨payload, index, counter, rfl, rfl, hsettled, ?_, ?_, hpayload, ?_⟩ + · exact hselection.2 + · exact hselection.1 + · simpa only [targetInput, EncodingPosition.domain] using hafter + · split at hpure <;> simp at hpure + +theorem hasEncodingTarget_of_signing_interval + (secretKey : SecretKey) (entry : AdversaryCacheEntry) + (hsigner : ∃ request, entry.input = .inr request) + (hvalidInterval : (entry.output, entry.finalCache) ∈ support + ((unloggedMappedAdversaryImpl secretKey entry.input).run entry.initialCache)) + (position : EncodingPosition) (payload : HashInput) + (hbefore : entry.initialCache + (tweakableHashInput secretKey.parameter position.domain payload) = none) + (hafter : entry.finalCache + (tweakableHashInput secretKey.parameter position.domain payload) ≠ none) + (hvalid : TargetSum.ValidDigest (truncateHash (fromCache entry.finalCache + (tweakableHashInput secretKey.parameter position.domain payload)))) : + HasEncodingTarget entry.finalCache secretKey position := by + rcases entry with ⟨input, output, initialCache, finalCache⟩ + cases input with + | inl worldInput => + obtain ⟨request, hfalse⟩ := hsigner + simp at hfalse + | inr request => + change Option Signature at output + change (output, finalCache) ∈ support + ((simulateQ romImpl (sign secretKey request)).run initialCache) at hvalidInterval + exact hasEncodingTarget_of_sign_transition secretKey request initialCache finalCache + output hvalidInterval position payload hbefore hafter hvalid + +theorem FullAdversaryTrace.CacheChain.hasEncodingTarget_or_direct_source_before_signingEntry + {rootCache adversaryCache finalCache : QueryCache HashSpec} + {secretKey : SecretKey} {trace : FullAdversaryTrace} + (hchain : FullAdversaryTrace.CacheChain rootCache trace.intervals adversaryCache) + (hconsistent : trace.Consistent) + (hchronological : FullAdversaryTrace.Chronological trace.intervals) + (hvalidIntervals : trace.ValidIntervals secretKey) + (hintervals : trace.IntervalsLe finalCache) + (f : QueryImpl HashSpec Id) (hf : finalCache.AgreesWithFn f) + (entry : SigningCacheEntry) (hentry : entry ∈ trace.signing) + (position : EncodingPosition) (payload : HashInput) + (hroot : rootCache + (tweakableHashInput secretKey.parameter position.domain payload) = none) + (hcached : entry.initialCache + (tweakableHashInput secretKey.parameter position.domain payload) ≠ none) + (hvalid : TargetSum.ValidDigest (truncateHash + (f (tweakableHashInput secretKey.parameter position.domain payload)))) : + HasEncodingTarget entry.initialCache secretKey position ∨ + ∃ (source selected : Fin trace.intervals.length), + source.val < selected.val + ∧ AdversaryCacheEntry.signingEntry? (trace.intervals.get selected) = some entry + ∧ (trace.intervals.get source).input = .inl (.inr + (tweakableHashInput secretKey.parameter position.domain payload)) := by + let targetInput := tweakableHashInput secretKey.parameter position.domain payload + obtain ⟨source, selected, hsourceLt, hselected, hsourceInitial, hsourceFinal⟩ := + hchain.source_before_signingEntry hconsistent entry hentry targetInput + (by simpa only [targetInput] using hroot) (by simpa only [targetInput] using hcached) + have hsourceMem : trace.intervals.get source ∈ trace.intervals := + List.get_mem trace.intervals source + rcases trace.transition_source_kind hvalidIntervals (trace.intervals.get source) + hsourceMem targetInput hsourceInitial hsourceFinal with hdirect | hsigner + · exact Or.inr ⟨source, selected, hsourceLt, hselected, by + simpa only [targetInput] using hdirect⟩ + · obtain ⟨request, hsourceInput⟩ := hsigner + obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hsourceFinal + have hsourceLe : (trace.intervals.get source).finalCache ≤ finalCache := + (hintervals (trace.intervals.get source) hsourceMem).2 + have hfAnswer : f targetInput = answer := hf (hsourceLe hanswer) + have hsourceValid : TargetSum.ValidDigest (truncateHash + (fromCache (trace.intervals.get source).finalCache targetInput)) := by + change TargetSum.ValidDigest (truncateHash (f targetInput)) at hvalid + rw [hfAnswer] at hvalid + simpa only [fromCache, hanswer, Option.getD_some] using hvalid + have htargetSource := hasEncodingTarget_of_signing_interval secretKey + (trace.intervals.get source) ⟨request, hsourceInput⟩ + (hvalidIntervals (trace.intervals.get source) hsourceMem) position payload + (by simpa only [targetInput] using hsourceInitial) + (by simpa only [targetInput] using hsourceFinal) + (by simpa only [targetInput] using hsourceValid) + have hsourceLeSelected := + hchronological.get_finalCache_le_initialCache source selected hsourceLt + have htargetSelected := htargetSource.mono hsourceLeSelected + rw [(trace.intervals.get selected).initialCache_eq_of_signingEntry?_eq_some hselected] + at htargetSelected + exact Or.inl htargetSelected + +theorem CachedSignedEncodingPayloadAt.of_cacheQuery_of_settled_of_not_atPosition + {cache : QueryCache HashSpec} {secretKey : SecretKey} {input : HashInput} + {answer : HashOutput} {lay : Layer} + {tree : TreeIndex} {leafIdx : LeafIndex} {payload : HashInput} + (huncached : cache input = none) + (hsettledAt : ∀ index : Index, treeIndexAt index lay = tree → + leafIndexAt index lay = leafIdx → + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (layerMessagePosition index lay)) + (hnotAt : ¬ AtEncodingPosition secretKey.parameter input ⟨lay, tree, leafIdx⟩) + (htarget : CachedSignedEncodingPayloadAt (cache.cacheQuery input answer) secretKey + lay tree leafIdx payload) : + CachedSignedEncodingPayloadAt cache secretKey lay tree leafIdx payload := by + obtain ⟨targetIndex, counter, htree, hleaf, _, hrunAfter, hevalAfter, hpayload, + hcachedAfter⟩ := htarget + have hle := le_cacheQuery (cache := cache) (input := input) (answer := answer) huncached + have hsettled := hsettledAt targetIndex htree hleaf + have hmessage := honestValue_eq_of_settled (agreesWithFn_fromCache_of_le hle) hsettled + have hnotMem : input ∉ queriedInputs (fromCache (cache.cacheQuery input answer)) + (encodingSearch secretKey.parameter lay (treeIndexAt targetIndex lay) + (leafIndexAt targetIndex lay) + (honestValue (fromCache (cache.cacheQuery input answer)) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret (layerMessagePosition targetIndex lay))) := by + intro hmem + obtain ⟨selectedCounter, hinput⟩ := mem_queriedInputs_encodingSearch + (fromCache (cache.cacheQuery input answer)) secretKey.parameter lay + (treeIndexAt targetIndex lay) (leafIndexAt targetIndex lay) + (honestValue (fromCache (cache.cacheQuery input answer)) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret (layerMessagePosition targetIndex lay)) input hmem + apply hnotAt + simpa only [htree, hleaf] using + (show AtEncodingPosition secretKey.parameter input + ⟨lay, treeIndexAt targetIndex lay, leafIndexAt targetIndex lay⟩ from ⟨_, hinput⟩) + have hrunOldAnswer := hrunAfter.of_cacheQuery_of_not_mem hnotMem + rw [hmessage] at hrunOldAnswer hevalAfter + have hrun := hrunOldAnswer.changeAnswerFn + (agreesWithFn_fromCache_of_le hle) (agreesWithFn_fromCache cache) + have hevalEq := hrunOldAnswer.eval_eq + (agreesWithFn_fromCache_of_le hle) (agreesWithFn_fromCache cache) + have htargetNe : tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) payload ≠ + input := by + intro heq + exact hnotAt ⟨payload, heq.symm⟩ + have hcached : cache + (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) payload) ≠ none := by + rwa [QueryCache.cacheQuery_of_ne _ _ htargetNe] at hcachedAfter + refine ⟨targetIndex, counter, htree, hleaf, hsettled, hrun, ?_, ?_, hcached⟩ + · exact hevalEq.symm.trans hevalAfter + · rwa [hmessage] at hpayload + +theorem CachedSignedEncodingPayloadAt.of_cacheQuery_of_other_encodingPosition + {cache : QueryCache HashSpec} {secretKey : SecretKey} {input : HashInput} + {answer : HashOutput} {queriedPosition : EncodingPosition} {lay : Layer} + {tree : TreeIndex} {leafIdx : LeafIndex} {payload : HashInput} + (huncached : cache input = none) + (hqueried : AtEncodingPosition secretKey.parameter input queriedPosition) + (hne : queriedPosition ≠ ⟨lay, tree, leafIdx⟩) + (htarget : CachedSignedEncodingPayloadAt (cache.cacheQuery input answer) secretKey + lay tree leafIdx payload) : + CachedSignedEncodingPayloadAt cache secretKey lay tree leafIdx payload := by + have htargetData := htarget + obtain ⟨index, _, htree, hleaf, hsettledAfter, _, _, _, _⟩ := htargetData + have hsettled : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (layerMessagePosition index lay) := by + exact settled_of_settled_cacheQuery secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret huncached (p₀ := none) + (fun position hposition => absurd hposition (hqueried.not_atPosition position)) + (by simp) ((layerMessagePosition index lay).depth + 1) + (layerMessagePosition index lay) (by omega) (by simp) hsettledAfter + have hsettledAt : ∀ targetIndex : Index, treeIndexAt targetIndex lay = tree → + leafIndexAt targetIndex lay = leafIdx → + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (layerMessagePosition targetIndex lay) := by + intro targetIndex htree' hleaf' + have hpositionEq := layerMessagePosition_eq_of_position_eq index targetIndex lay + (htree.trans htree'.symm) (hleaf.trans hleaf'.symm) + rwa [← hpositionEq] + exact htarget.of_cacheQuery_of_settled_of_not_atPosition huncached hsettledAt + (fun htargetPosition => hne (atEncodingPosition_unique hqueried htargetPosition)) + +theorem HasEncodingTarget.of_cacheQuery_of_other_encodingPosition + {cache : QueryCache HashSpec} {secretKey : SecretKey} {input : HashInput} + {answer : HashOutput} {queriedPosition targetPosition : EncodingPosition} + (huncached : cache input = none) + (hqueried : AtEncodingPosition secretKey.parameter input queriedPosition) + (hne : queriedPosition ≠ targetPosition) + (htarget : HasEncodingTarget (cache.cacheQuery input answer) secretKey targetPosition) : + HasEncodingTarget cache secretKey targetPosition := by + obtain ⟨payload, hpayload⟩ := htarget + exact ⟨payload, hpayload.of_cacheQuery_of_other_encodingPosition huncached hqueried hne⟩ + +theorem HasEncodingTarget.of_cacheQuery_of_settled_of_not_atPosition + {cache : QueryCache HashSpec} {secretKey : SecretKey} {input : HashInput} + {answer : HashOutput} {position : EncodingPosition} + (huncached : cache input = none) + (hsettledAt : ∀ index : Index, treeIndexAt index position.lay = position.tree → + leafIndexAt index position.lay = position.leafIdx → + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (layerMessagePosition index position.lay)) + (hnotAt : ¬ AtEncodingPosition secretKey.parameter input position) + (htarget : HasEncodingTarget (cache.cacheQuery input answer) secretKey position) : + HasEncodingTarget cache secretKey position := by + obtain ⟨payload, hpayload⟩ := htarget + exact ⟨payload, hpayload.of_cacheQuery_of_settled_of_not_atPosition huncached hsettledAt + hnotAt⟩ + +theorem encodingBad_answer_hit_of_fresh_target_query + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} {targetPayload : HashInput} + (hclean : ¬ EncodingBad cache secretKey) (huncached : cache input = none) + (hinput : input = tweakableHashInput secretKey.parameter position.domain targetPayload) + (htarget : CachedSignedEncodingPayloadAt (cache.cacheQuery input answer) secretKey + position.lay position.tree position.leafIdx targetPayload) + (hbad : EncodingBad (cache.cacheQuery input answer) secretKey) : + truncateHash answer ∈ + encodingAnswerTargets secretKey.parameter cache hfinite position := by + obtain ⟨lay, tree, leafIdx⟩ := position + obtain ⟨badLay, badTree, badLeaf, badTargetPayload, otherPayload, targetAnswer, + otherAnswer, hbadTarget, hpayloadNe, htargetAnswer, hotherAnswer, hcollision⟩ := hbad + let badPosition : EncodingPosition := ⟨badLay, badTree, badLeaf⟩ + have hinputAt : AtEncodingPosition secretKey.parameter input ⟨lay, tree, leafIdx⟩ := + ⟨targetPayload, hinput⟩ + have hpositionEq : (⟨lay, tree, leafIdx⟩ : EncodingPosition) = badPosition := by + by_contra hne + have hbadTargetOld := hbadTarget.of_cacheQuery_of_other_encodingPosition huncached + hinputAt hne + have htargetInputNe : + tweakableHashInput secretKey.parameter badPosition.domain badTargetPayload ≠ input := + atEncodingPosition_ne + (show AtEncodingPosition secretKey.parameter + (tweakableHashInput secretKey.parameter badPosition.domain badTargetPayload) + badPosition from ⟨badTargetPayload, rfl⟩) hinputAt (fun heq => hne heq.symm) + have hotherInputNe : + tweakableHashInput secretKey.parameter badPosition.domain otherPayload ≠ input := + atEncodingPosition_ne + (show AtEncodingPosition secretKey.parameter + (tweakableHashInput secretKey.parameter badPosition.domain otherPayload) + badPosition from ⟨otherPayload, rfl⟩) hinputAt (fun heq => hne heq.symm) + apply hclean + refine ⟨badLay, badTree, badLeaf, badTargetPayload, otherPayload, targetAnswer, + otherAnswer, hbadTargetOld, hpayloadNe, ?_, ?_, hcollision⟩ + · have htargetInputNe' : tweakableHashInput secretKey.parameter + (.encoding badLay badTree badLeaf) badTargetPayload ≠ input := by + simpa only [badPosition, EncodingPosition.domain] using htargetInputNe + rwa [QueryCache.cacheQuery_of_ne _ _ htargetInputNe'] at htargetAnswer + · have hotherInputNe' : tweakableHashInput secretKey.parameter + (.encoding badLay badTree badLeaf) otherPayload ≠ input := by + simpa only [badPosition, EncodingPosition.domain] using hotherInputNe + rwa [QueryCache.cacheQuery_of_ne _ _ hotherInputNe'] at hotherAnswer + simp only [badPosition, EncodingPosition.mk.injEq] at hpositionEq + obtain ⟨rfl, rfl, rfl⟩ := hpositionEq + have hpayload : targetPayload = badTargetPayload := + cachedSignedEncodingPayloadAt_unique htarget hbadTarget + subst badTargetPayload + have htargetInput : tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + targetPayload = input := hinput.symm + have htargetAnswerEq : targetAnswer = answer := by + rw [htargetInput, QueryCache.cacheQuery_self] at htargetAnswer + exact Option.some.inj htargetAnswer.symm + have hotherInputNe : tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + otherPayload ≠ input := by + intro heq + apply hpayloadNe + exact (tweakableHashInput_injective secretKey.parameter (by trivial) (by trivial) + (htargetInput.trans heq.symm)).2 + have hotherOld : cache + (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) otherPayload) = + some otherAnswer := by + rwa [QueryCache.cacheQuery_of_ne _ _ hotherInputNe] at hotherAnswer + have hmem := cachedAnswer_mem_encodingAnswerTargets hfinite hotherOld + (show AtEncodingPosition secretKey.parameter + (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) otherPayload) + ⟨lay, tree, leafIdx⟩ from ⟨otherPayload, rfl⟩) + rw [← hcollision, htargetAnswerEq] at hmem + exact hmem + +theorem encodingBad_valid_answer_hit_of_fresh_target_query + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} {targetPayload : HashInput} + (hclean : ¬ EncodingBad cache secretKey) (huncached : cache input = none) + (hinput : input = tweakableHashInput secretKey.parameter position.domain targetPayload) + (htarget : CachedSignedEncodingPayloadAt (cache.cacheQuery input answer) secretKey + position.lay position.tree position.leafIdx targetPayload) + (hbad : EncodingBad (cache.cacheQuery input answer) secretKey) : + truncateHash answer ∈ + encodingValidAnswerTargets secretKey.parameter cache hfinite position := by + rw [encodingValidAnswerTargets, Finset.mem_filter] + refine ⟨encodingBad_answer_hit_of_fresh_target_query hfinite hclean huncached hinput + htarget hbad, ?_⟩ + have hvalid := htarget.target_valid + have hanswer : fromCache (cache.cacheQuery input answer) + (tweakableHashInput secretKey.parameter position.domain targetPayload) = answer := by + rw [← hinput] + simp [fromCache] + have hanswer' : fromCache (cache.cacheQuery input answer) + (tweakableHashInput secretKey.parameter + (.encoding position.lay position.tree position.leafIdx) targetPayload) = answer := by + simpa only [EncodingPosition.domain] using hanswer + rwa [hanswer'] at hvalid + +theorem encodingBad_of_cached_target_hit + {cache : QueryCache HashSpec} {secretKey : SecretKey} {position : EncodingPosition} + {targetPayload otherPayload : HashInput} {f : QueryImpl HashSpec Id} + (hf : cache.AgreesWithFn f) + (htarget : CachedSignedEncodingPayloadAt cache secretKey position.lay position.tree + position.leafIdx targetPayload) + (hother : cache (tweakableHashInput secretKey.parameter position.domain otherPayload) ≠ none) + (hne : tweakableHashInput secretKey.parameter position.domain targetPayload ≠ + tweakableHashInput secretKey.parameter position.domain otherPayload) + (hvalue : truncateHash + (f (tweakableHashInput secretKey.parameter position.domain targetPayload)) = + truncateHash + (f (tweakableHashInput secretKey.parameter position.domain otherPayload))) : + EncodingBad cache secretKey := by + have htargetData := htarget + obtain ⟨_, _, _, _, _, _, _, _, htargetCached⟩ := htargetData + obtain ⟨targetAnswer, htargetAnswer⟩ := Option.ne_none_iff_exists'.mp htargetCached + obtain ⟨otherAnswer, hotherAnswer⟩ := Option.ne_none_iff_exists'.mp hother + refine ⟨position.lay, position.tree, position.leafIdx, targetPayload, otherPayload, + targetAnswer, otherAnswer, htarget, ?_, htargetAnswer, hotherAnswer, ?_⟩ + · intro hpayload + exact hne (congrArg (tweakableHashInput secretKey.parameter position.domain) hpayload) + · rw [← hf htargetAnswer, ← hf hotherAnswer] + exact hvalue + +theorem encodingBad_of_hasTarget_of_cached_hit + {initialCache finalCache : QueryCache HashSpec} {secretKey : SecretKey} + {position : EncodingPosition} {targetPayload otherPayload : HashInput} + {f : QueryImpl HashSpec Id} (hle : initialCache ≤ finalCache) + (hf : finalCache.AgreesWithFn f) + (htargetFinal : CachedSignedEncodingPayloadAt finalCache secretKey position.lay + position.tree position.leafIdx targetPayload) + (htargetInitial : HasEncodingTarget initialCache secretKey position) + (hother : initialCache + (tweakableHashInput secretKey.parameter position.domain otherPayload) ≠ none) + (hne : tweakableHashInput secretKey.parameter position.domain targetPayload ≠ + tweakableHashInput secretKey.parameter position.domain otherPayload) + (hvalue : truncateHash + (f (tweakableHashInput secretKey.parameter position.domain targetPayload)) = + truncateHash + (f (tweakableHashInput secretKey.parameter position.domain otherPayload))) : + EncodingBad initialCache secretKey := by + obtain ⟨initialPayload, hinitialTarget⟩ := htargetInitial + have hpayload : initialPayload = targetPayload := + cachedSignedEncodingPayloadAt_unique (hinitialTarget.mono hle) htargetFinal + rw [hpayload] at hinitialTarget + have hfInitial : initialCache.AgreesWithFn f := fun _ _ hcached => hf (hle hcached) + exact encodingBad_of_cached_target_hit hfInitial hinitialTarget hother hne hvalue + +theorem direct_source_before_signingEntry_of_clean_encoding_collision + {rootCache adversaryCache finalCache : QueryCache HashSpec} + {secretKey : SecretKey} {trace : FullAdversaryTrace} + (hchain : FullAdversaryTrace.CacheChain rootCache trace.intervals adversaryCache) + (hconsistent : trace.Consistent) + (hchronological : FullAdversaryTrace.Chronological trace.intervals) + (hvalidIntervals : trace.ValidIntervals secretKey) + (hintervals : trace.IntervalsLe finalCache) + (f : QueryImpl HashSpec Id) (hf : finalCache.AgreesWithFn f) + (hclean : ¬ EncodingBad finalCache secretKey) + (entry : SigningCacheEntry) (hentry : entry ∈ trace.signing) + (position : EncodingPosition) (targetPayload otherPayload : HashInput) + (hroot : rootCache + (tweakableHashInput secretKey.parameter position.domain targetPayload) = none) + (htargetInitial : entry.initialCache + (tweakableHashInput secretKey.parameter position.domain targetPayload) ≠ none) + (hother : entry.initialCache + (tweakableHashInput secretKey.parameter position.domain otherPayload) ≠ none) + (htargetFinal : CachedSignedEncodingPayloadAt finalCache secretKey position.lay + position.tree position.leafIdx targetPayload) + (hne : tweakableHashInput secretKey.parameter position.domain targetPayload ≠ + tweakableHashInput secretKey.parameter position.domain otherPayload) + (hvalue : truncateHash + (f (tweakableHashInput secretKey.parameter position.domain targetPayload)) = + truncateHash + (f (tweakableHashInput secretKey.parameter position.domain otherPayload))) : + ∃ (source selected : Fin trace.intervals.length), + source.val < selected.val + ∧ AdversaryCacheEntry.signingEntry? (trace.intervals.get selected) = some entry + ∧ (trace.intervals.get source).input = .inl (.inr + (tweakableHashInput secretKey.parameter position.domain targetPayload)) := by + have htargetValid := htargetFinal.target_valid + rcases FullAdversaryTrace.CacheChain.hasEncodingTarget_or_direct_source_before_signingEntry + hchain hconsistent + hchronological hvalidIntervals hintervals (fromCache finalCache) + (agreesWithFn_fromCache finalCache) entry hentry position targetPayload hroot + htargetInitial htargetValid with htarget | hdirect + · have hentryLe : entry.initialCache ≤ finalCache := by + obtain ⟨selected, hselected⟩ := + trace.exists_intervalPosition_of_signingEntry hconsistent entry hentry + rw [← (trace.intervals.get selected).initialCache_eq_of_signingEntry?_eq_some + hselected] + exact (hintervals (trace.intervals.get selected) (List.get_mem _ selected)).1 + have hbad := encodingBad_of_hasTarget_of_cached_hit hentryLe hf htargetFinal htarget + hother hne hvalue + exact (hclean (hbad.mono hentryLe)).elim + · exact hdirect + +theorem clean_encodingBad_cacheQuery_of_existing_target + {cache : QueryCache HashSpec} {secretKey : SecretKey} {input : HashInput} + {answer : HashOutput} {position : EncodingPosition} {targetPayload : HashInput} + {targetAnswer : HashOutput} + (hclean : ¬ EncodingBad cache secretKey) (huncached : cache input = none) + (hposition : AtEncodingPosition secretKey.parameter input position) + (htarget : CachedSignedEncodingPayloadAt cache secretKey position.lay position.tree + position.leafIdx targetPayload) + (htargetAnswer : cache (tweakableHashInput secretKey.parameter position.domain targetPayload) = + some targetAnswer) + (havoid : truncateHash answer ≠ truncateHash targetAnswer) : + ¬ EncodingBad (cache.cacheQuery input answer) secretKey := by + have hle := le_cacheQuery (cache := cache) (input := input) (answer := answer) huncached + rintro ⟨badLay, badTree, badLeaf, badTargetPayload, otherPayload, badTargetAnswer, + otherAnswer, hbadTarget, hpayloadNe, hbadTargetAnswer, hotherAnswer, hcollision⟩ + let badPosition : EncodingPosition := ⟨badLay, badTree, badLeaf⟩ + by_cases heq : position = badPosition + · have htarget' : CachedSignedEncodingPayloadAt cache secretKey badLay badTree badLeaf + targetPayload := by + simpa only [badPosition, heq] using htarget + have htargetAnswer' : cache + (tweakableHashInput secretKey.parameter (.encoding badLay badTree badLeaf) + targetPayload) = some targetAnswer := by + have := htargetAnswer + rw [heq] at this + simpa only [badPosition, EncodingPosition.domain] using this + have hpayload : targetPayload = badTargetPayload := + cachedSignedEncodingPayloadAt_unique (htarget'.mono hle) hbadTarget + have htargetOld : CachedSignedEncodingPayloadAt cache secretKey badLay badTree badLeaf + badTargetPayload := by + rwa [← hpayload] + have htargetInputNe : + tweakableHashInput secretKey.parameter (.encoding badLay badTree badLeaf) + badTargetPayload ≠ input := by + intro hinput + rw [← hpayload] at hinput + have hnone := huncached + rw [← hinput, htargetAnswer'] at hnone + simp at hnone + have htargetAnswerEq : badTargetAnswer = targetAnswer := by + have hcached := hbadTargetAnswer + rw [QueryCache.cacheQuery_of_ne _ _ htargetInputNe] at hcached + rw [← hpayload] at hcached + exact Option.some.inj (hcached.symm.trans htargetAnswer') + by_cases hother : tweakableHashInput secretKey.parameter + (.encoding badLay badTree badLeaf) otherPayload = input + · have hanswerEq : otherAnswer = answer := by + have hcached := hotherAnswer + rw [hother, QueryCache.cacheQuery_self] at hcached + exact Option.some.inj hcached.symm + apply havoid + rw [← hanswerEq, ← htargetAnswerEq] + exact hcollision.symm + · apply hclean + refine ⟨badLay, badTree, badLeaf, badTargetPayload, otherPayload, + badTargetAnswer, otherAnswer, htargetOld, hpayloadNe, ?_, ?_, hcollision⟩ + · rwa [QueryCache.cacheQuery_of_ne _ _ htargetInputNe] at hbadTargetAnswer + · rwa [QueryCache.cacheQuery_of_ne _ _ hother] at hotherAnswer + · have hne : position ≠ ⟨badLay, badTree, badLeaf⟩ := by + simpa only [badPosition] using heq + have hbadTargetOld := hbadTarget.of_cacheQuery_of_other_encodingPosition + huncached hposition hne + have htargetInputNe : + tweakableHashInput secretKey.parameter (.encoding badLay badTree badLeaf) + badTargetPayload ≠ input := + atEncodingPosition_ne + (show AtEncodingPosition secretKey.parameter + (tweakableHashInput secretKey.parameter (.encoding badLay badTree badLeaf) + badTargetPayload) ⟨badLay, badTree, badLeaf⟩ from ⟨_, rfl⟩) + hposition hne.symm + have hotherInputNe : + tweakableHashInput secretKey.parameter (.encoding badLay badTree badLeaf) + otherPayload ≠ input := + atEncodingPosition_ne + (show AtEncodingPosition secretKey.parameter + (tweakableHashInput secretKey.parameter (.encoding badLay badTree badLeaf) + otherPayload) ⟨badLay, badTree, badLeaf⟩ from ⟨_, rfl⟩) + hposition hne.symm + apply hclean + refine ⟨badLay, badTree, badLeaf, badTargetPayload, otherPayload, badTargetAnswer, + otherAnswer, hbadTargetOld, hpayloadNe, ?_, ?_, hcollision⟩ + · rwa [QueryCache.cacheQuery_of_ne _ _ htargetInputNe] at hbadTargetAnswer + · rwa [QueryCache.cacheQuery_of_ne _ _ hotherInputNe] at hotherAnswer + +noncomputable def encodingContribution (cache : QueryCache HashSpec) (secretKey : SecretKey) + (position : EncodingPosition) : Nat := + open Classical in + if HasEncodingTarget cache secretKey position then 0 + else (encodingCachedAt secretKey.parameter cache position).ncard + +noncomputable def encodingPotential (cache : QueryCache HashSpec) + (secretKey : SecretKey) : Nat := + open Classical in + ∑ position : EncodingPosition, encodingContribution cache secretKey position + +theorem encodingPotential_empty (secretKey : SecretKey) : + encodingPotential ∅ secretKey = 0 := by + classical + rw [encodingPotential] + refine Finset.sum_eq_zero fun position _ => ?_ + rw [encodingContribution] + split + · rfl + · have hempty : encodingCachedAt secretKey.parameter (∅ : QueryCache HashSpec) position = ∅ := by + ext input + simp [encodingCachedAt] + rw [hempty, Set.ncard_empty] + +theorem encodingCachedAt_cacheQuery_of_not_atPosition + {parameter : PublicParameter} {cache : QueryCache HashSpec} {input : HashInput} + {answer : HashOutput} {position : EncodingPosition} + (hposition : ¬ AtEncodingPosition parameter input position) : + encodingCachedAt parameter (cache.cacheQuery input answer) position = + encodingCachedAt parameter cache position := by + ext candidate + by_cases heq : candidate = input + · subst candidate + simp only [encodingCachedAt, Set.mem_setOf_eq, QueryCache.cacheQuery_self] + exact ⟨fun h => absurd h.2 hposition, fun h => absurd h.2 hposition⟩ + · simp only [encodingCachedAt, Set.mem_setOf_eq, + QueryCache.cacheQuery_of_ne _ _ heq] + +theorem encodingCachedAt_cacheQuery_self {parameter : PublicParameter} + {cache : QueryCache HashSpec} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} (hposition : AtEncodingPosition parameter input position) : + encodingCachedAt parameter (cache.cacheQuery input answer) position = + insert input (encodingCachedAt parameter cache position) := by + ext candidate + by_cases heq : candidate = input + · subst candidate + simp only [encodingCachedAt, Set.mem_setOf_eq, QueryCache.cacheQuery_self, + Set.mem_insert_iff, true_or, ne_eq, reduceCtorEq, not_false_eq_true, hposition, and_self] + · simp only [encodingCachedAt, Set.mem_setOf_eq, + QueryCache.cacheQuery_of_ne _ _ heq, Set.mem_insert_iff, heq, false_or] + +theorem encodingContribution_cacheQuery_le_of_not_atPosition + {cache : QueryCache HashSpec} {secretKey : SecretKey} {input : HashInput} + {answer : HashOutput} {position : EncodingPosition} (huncached : cache input = none) + (hposition : ¬ AtEncodingPosition secretKey.parameter input position) : + encodingContribution (cache.cacheQuery input answer) secretKey position ≤ + encodingContribution cache secretKey position := by + classical + have hle := le_cacheQuery (cache := cache) (input := input) (answer := answer) huncached + rw [encodingContribution, encodingContribution] + by_cases htarget : HasEncodingTarget cache secretKey position + · rw [if_pos htarget, if_pos (htarget.mono hle)] + · rw [if_neg htarget] + by_cases htarget' : HasEncodingTarget (cache.cacheQuery input answer) secretKey position + · rw [if_pos htarget'] + omega + · rw [if_neg htarget', encodingCachedAt_cacheQuery_of_not_atPosition hposition] + +theorem encodingContribution_cacheQuery_le_of_atPosition + {cache : QueryCache HashSpec} {secretKey : SecretKey} {input : HashInput} + {answer : HashOutput} {position : EncodingPosition} (huncached : cache input = none) + (hposition : AtEncodingPosition secretKey.parameter input position) : + encodingContribution (cache.cacheQuery input answer) secretKey position ≤ + encodingContribution cache secretKey position + 1 := by + classical + have hle := le_cacheQuery (cache := cache) (input := input) (answer := answer) huncached + rw [encodingContribution, encodingContribution] + by_cases htarget : HasEncodingTarget cache secretKey position + · rw [if_pos htarget, if_pos (htarget.mono hle)] + exact Nat.zero_le _ + · rw [if_neg htarget] + by_cases htarget' : HasEncodingTarget (cache.cacheQuery input answer) secretKey position + · rw [if_pos htarget'] + omega + · rw [if_neg htarget', encodingCachedAt_cacheQuery_self hposition] + exact Set.ncard_insert_le _ _ + +theorem encodingPotential_cacheQuery_le {cache : QueryCache HashSpec} + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + (huncached : cache input = none) : + encodingPotential (cache.cacheQuery input answer) secretKey ≤ + encodingPotential cache secretKey + 1 := by + classical + by_cases hat : ∃ position, AtEncodingPosition secretKey.parameter input position + · obtain ⟨queriedPosition, hqueried⟩ := hat + rw [encodingPotential, encodingPotential] + calc + ∑ position : EncodingPosition, + encodingContribution (cache.cacheQuery input answer) secretKey position ≤ + ∑ position : EncodingPosition, + (encodingContribution cache secretKey position + + if position = queriedPosition then 1 else 0) := by + apply Finset.sum_le_sum + intro position _ + by_cases heq : position = queriedPosition + · rw [if_pos heq] + simpa only [heq] using + encodingContribution_cacheQuery_le_of_atPosition huncached hqueried + · rw [if_neg heq, Nat.add_zero] + apply encodingContribution_cacheQuery_le_of_not_atPosition huncached + intro hposition + exact heq (atEncodingPosition_unique hposition hqueried) + _ = (∑ position : EncodingPosition, + encodingContribution cache secretKey position) + 1 := by + rw [Finset.sum_add_distrib] + rw [Fintype.sum_ite_eq'] + · rw [encodingPotential, encodingPotential] + calc + ∑ position : EncodingPosition, + encodingContribution (cache.cacheQuery input answer) secretKey position ≤ + ∑ position : EncodingPosition, encodingContribution cache secretKey position := by + apply Finset.sum_le_sum + intro position _ + exact encodingContribution_cacheQuery_le_of_not_atPosition huncached + (fun hposition => hat ⟨position, hposition⟩) + _ ≤ _ := Nat.le_add_right _ 1 + +theorem encodingPotential_cacheQuery_le_of_target {cache : QueryCache HashSpec} + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} (huncached : cache input = none) + (hposition : AtEncodingPosition secretKey.parameter input position) + (htarget : HasEncodingTarget cache secretKey position) : + encodingPotential (cache.cacheQuery input answer) secretKey ≤ + encodingPotential cache secretKey := by + classical + have hle := le_cacheQuery (cache := cache) (input := input) (answer := answer) huncached + rw [encodingPotential, encodingPotential] + apply Finset.sum_le_sum + intro otherPosition _ + by_cases heq : otherPosition = position + · rw [heq, encodingContribution, encodingContribution, if_pos htarget, + if_pos (htarget.mono hle)] + · apply encodingContribution_cacheQuery_le_of_not_atPosition huncached + intro hother + exact heq (atEncodingPosition_unique hother hposition) + +theorem encodingPotential_add_cachedAt_le_of_new_target + {cache : QueryCache HashSpec} {secretKey : SecretKey} {input : HashInput} + {answer : HashOutput} {position : EncodingPosition} + (hnotTarget : ¬ HasEncodingTarget cache secretKey position) + (htarget : HasEncodingTarget (cache.cacheQuery input answer) secretKey position) + (hother : ∀ otherPosition : EncodingPosition, otherPosition ≠ position → + encodingContribution (cache.cacheQuery input answer) secretKey otherPosition ≤ + encodingContribution cache secretKey otherPosition) : + encodingPotential (cache.cacheQuery input answer) secretKey + + (encodingCachedAt secretKey.parameter cache position).ncard ≤ + encodingPotential cache secretKey := by + classical + rw [encodingPotential, encodingPotential] + calc + (∑ otherPosition : EncodingPosition, + encodingContribution (cache.cacheQuery input answer) secretKey otherPosition) + + (encodingCachedAt secretKey.parameter cache position).ncard = + ∑ otherPosition : EncodingPosition, + (encodingContribution (cache.cacheQuery input answer) secretKey otherPosition + + if otherPosition = position then + (encodingCachedAt secretKey.parameter cache position).ncard else 0) := by + rw [Finset.sum_add_distrib, Fintype.sum_ite_eq'] + _ ≤ ∑ otherPosition : EncodingPosition, + encodingContribution cache secretKey otherPosition := by + apply Finset.sum_le_sum + intro otherPosition _ + by_cases heq : otherPosition = position + · rw [if_pos heq, heq, encodingContribution, encodingContribution, + if_pos htarget, if_neg hnotTarget, zero_add] + · rw [if_neg heq, Nat.add_zero] + exact hother otherPosition heq + +theorem encodingPotential_add_cachedAt_le_of_new_target_atPosition + {cache : QueryCache HashSpec} {secretKey : SecretKey} {input : HashInput} + {answer : HashOutput} {position : EncodingPosition} + (huncached : cache input = none) + (hposition : AtEncodingPosition secretKey.parameter input position) + (hnotTarget : ¬ HasEncodingTarget cache secretKey position) + (htarget : HasEncodingTarget (cache.cacheQuery input answer) secretKey position) : + encodingPotential (cache.cacheQuery input answer) secretKey + + (encodingCachedAt secretKey.parameter cache position).ncard ≤ + encodingPotential cache secretKey := by + apply encodingPotential_add_cachedAt_le_of_new_target hnotTarget htarget + intro otherPosition hne + apply encodingContribution_cacheQuery_le_of_not_atPosition huncached + intro hother + exact hne (atEncodingPosition_unique hother hposition) + +theorem encodingPotential_add_cachedAt_le_of_new_target_not_atEncoding + {cache : QueryCache HashSpec} {secretKey : SecretKey} {input : HashInput} + {answer : HashOutput} {position : EncodingPosition} + (huncached : cache input = none) + (hnotAt : ∀ otherPosition : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input otherPosition) + (hnotTarget : ¬ HasEncodingTarget cache secretKey position) + (htarget : HasEncodingTarget (cache.cacheQuery input answer) secretKey position) : + encodingPotential (cache.cacheQuery input answer) secretKey + + (encodingCachedAt secretKey.parameter cache position).ncard ≤ + encodingPotential cache secretKey := by + apply encodingPotential_add_cachedAt_le_of_new_target hnotTarget htarget + intro otherPosition _ + exact encodingContribution_cacheQuery_le_of_not_atPosition huncached (hnotAt otherPosition) + +theorem encodingPotential_add_validAnswerTargets_card_le_of_new_target_atPosition + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} + (huncached : cache input = none) + (hposition : AtEncodingPosition secretKey.parameter input position) + (hnotTarget : ¬ HasEncodingTarget cache secretKey position) + (htarget : HasEncodingTarget (cache.cacheQuery input answer) secretKey position) : + encodingPotential (cache.cacheQuery input answer) secretKey + + (encodingValidAnswerTargets secretKey.parameter cache hfinite position).card ≤ + encodingPotential cache secretKey := by + exact (Nat.add_le_add_left (encodingValidAnswerTargets_card_le hfinite position) _).trans + (encodingPotential_add_cachedAt_le_of_new_target_atPosition huncached hposition + hnotTarget htarget) + +theorem encodingPotential_add_messageTargets_card_le_of_new_target_not_atEncoding + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} + (huncached : cache input = none) + (hnotAt : ∀ otherPosition : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input otherPosition) + (hnotTarget : ¬ HasEncodingTarget cache secretKey position) + (htarget : HasEncodingTarget (cache.cacheQuery input answer) secretKey position) : + encodingPotential (cache.cacheQuery input answer) secretKey + + (encodingMessageTargets secretKey.parameter cache hfinite position).card ≤ + encodingPotential cache secretKey := by + exact (Nat.add_le_add_left (encodingMessageTargets_card_le hfinite position) _).trans + (encodingPotential_add_cachedAt_le_of_new_target_not_atEncoding huncached hnotAt + hnotTarget htarget) + +theorem encodingBad_step_of_existing_target {cache : QueryCache HashSpec} + {secretKey : SecretKey} {input : HashInput} {position : EncodingPosition} + (hclean : ¬ EncodingBad cache secretKey) (huncached : cache input = none) + (hposition : AtEncodingPosition secretKey.parameter input position) + (htarget : HasEncodingTarget cache secretKey position) : + ∃ targets : Finset Digest, targets.card ≤ encodingPotential cache secretKey + 1 + ∧ ∀ answer : HashOutput, truncateHash answer ∉ targets → + ¬ EncodingBad (cache.cacheQuery input answer) secretKey + ∧ encodingPotential (cache.cacheQuery input answer) secretKey + targets.card ≤ + encodingPotential cache secretKey + 1 := by + classical + obtain ⟨targetPayload, htargetPayload⟩ := htarget + have htargetData := htargetPayload + obtain ⟨_, _, _, _, _, _, _, _, htargetCached⟩ := htargetData + obtain ⟨targetAnswer, htargetAnswer⟩ := Option.ne_none_iff_exists'.mp htargetCached + let target := truncateHash targetAnswer + refine ⟨{target}, ?_, ?_⟩ + · simp only [Finset.card_singleton] + omega + · intro answer hanswer + have havoid : truncateHash answer ≠ truncateHash targetAnswer := by + simpa only [Finset.mem_singleton, target] using hanswer + refine ⟨clean_encodingBad_cacheQuery_of_existing_target hclean huncached hposition + htargetPayload htargetAnswer havoid, ?_⟩ + simpa only [Finset.card_singleton] using Nat.add_le_add_right + (encodingPotential_cacheQuery_le_of_target huncached hposition + ⟨targetPayload, htargetPayload⟩) 1 + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingCount.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingCount.lean new file mode 100644 index 00000000..33bed81a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingCount.lean @@ -0,0 +1,195 @@ +import SphincsSecurity.Proof.Code + +namespace SphincsSecurity.TargetSum + +open scoped BigOperators + +set_option maxRecDepth 1000 +set_option backward.isDefEq.respectTransparency false + +def packDigits {n : Nat} (digits : Fin n → Digit) : BitVec (3 * n) := + (BitVec.ofBoolListLE (List.ofFn fun bit : Fin (3 * n) => + (BitVec.ofFin (digits ⟨bit.val / 3, by omega⟩)).getLsbD (bit.val % 3))).cast (by simp) + +theorem getLsbD_packDigits {n : Nat} (digits : Fin n → Digit) (bit : Nat) (hbit : bit < 3 * n) : + (packDigits digits).getLsbD bit = + (BitVec.ofFin (digits ⟨bit / 3, by omega⟩)).getLsbD (bit % 3) := by + rw [packDigits, BitVec.getLsbD_cast, BitVec.getLsbD_ofBoolListLE] + simp [List.getD_eq_getElem?_getD, hbit] + +theorem extract_packDigits {n : Nat} (digits : Fin n → Digit) (index : Fin n) : + (packDigits digits).extractLsb' (3 * index.val) 3 = BitVec.ofFin (digits index) := by + apply BitVec.eq_of_getLsbD_eq + intro bit hbit + rw [BitVec.getLsbD_extractLsb'] + have hwithin : 3 * index.val + bit < 3 * n := by omega + rw [getLsbD_packDigits digits _ hwithin] + have hdiv : (3 * index.val + bit) / 3 = index.val := by omega + have hmod : (3 * index.val + bit) % 3 = bit := by omega + simp only [hbit, decide_true, Bool.true_and, hdiv, hmod] + +def packHalves (low high : Fin 21 → Digit) : Digest := + ((0#1 ++ packDigits high) ++ (0#1 ++ packDigits low)) + +theorem packHalves_padding (low high : Fin 21 → Digit) : + (packHalves low high).getLsbD 63 = false ∧ (packHalves low high).getLsbD 127 = false := by + have hpad : ∀ digits : Fin 21 → Digit, (0#1 ++ packDigits digits).getLsbD 63 = false := by + intro digits + rw [BitVec.getLsbD_append, if_neg (by decide)] + rfl + unfold packHalves + constructor + · rw [BitVec.getLsbD_append, if_pos (by decide)] + exact hpad low + · rw [BitVec.getLsbD_append, if_neg (by decide)] + exact hpad high + +theorem packHalves_extract_low (low high : Fin 21 → Digit) (index : Fin 21) : + (packHalves low high).extractLsb' (3 * index.val) 3 = BitVec.ofFin (low index) := by + rw [← extract_packDigits low index] + apply BitVec.eq_of_getLsbD_eq + intro bit hbit + simp only [BitVec.getLsbD_extractLsb', hbit, decide_true, Bool.true_and] + have h63 : 3 * index.val + bit < 63 := by omega + have h64 : 3 * index.val + bit < 64 := by omega + simp only [packHalves, BitVec.getLsbD_append, h63, h64, if_pos] + +theorem packHalves_extract_high (low high : Fin 21 → Digit) (index : Fin 21) : + (packHalves low high).extractLsb' (64 + 3 * index.val) 3 = BitVec.ofFin (high index) := by + rw [← extract_packDigits high index] + apply BitVec.eq_of_getLsbD_eq + intro bit hbit + simp only [BitVec.getLsbD_extractLsb', hbit, decide_true, Bool.true_and] + have h64 : ¬64 + 3 * index.val + bit < 64 := by omega + have h63 : 3 * index.val + bit < 63 := by omega + have hsub : 64 + 3 * index.val + bit - 64 = 3 * index.val + bit := by omega + simp only [packHalves, BitVec.getLsbD_append, h64, ite_false, hsub, h63, if_pos] + +theorem digestEncoding_packHalves_low (low high : Fin 21 → Digit) (index : Fin 21) : + digestEncoding (packHalves low high) (index.castAdd 21) = low index := by + have hoffset : digitOffset (index.castAdd 21) = 3 * index.val := by + simp [digitOffset, winternitzBits, digitsPerHalf, numChains] + unfold digestEncoding + rw [hoffset] + change ((packHalves low high).extractLsb' (3 * index.val) 3).toFin = low index + exact congrArg BitVec.toFin (packHalves_extract_low low high index) + +theorem digestEncoding_packHalves_high (low high : Fin 21 → Digit) (index : Fin 21) : + digestEncoding (packHalves low high) (index.natAdd 21) = high index := by + have hoffset : digitOffset (index.natAdd 21) = 64 + 3 * index.val := by + simp only [digitOffset, Fin.val_natAdd] + norm_num [winternitzBits, digitsPerHalf, numChains] + omega + unfold digestEncoding + rw [hoffset] + change ((packHalves low high).extractLsb' (64 + 3 * index.val) 3).toFin = high index + exact congrArg BitVec.toFin (packHalves_extract_high low high index) + +theorem packHalves_injective : Function.Injective (fun halves : (Fin 21 → Digit) × (Fin 21 → Digit) => + packHalves halves.1 halves.2) := by + intro left right heq + apply Prod.ext + · funext index + have h := congrArg (fun digest => digestEncoding digest (index.castAdd 21)) heq + simpa only [digestEncoding_packHalves_low] using h + · funext index + have h := congrArg (fun digest => digestEncoding digest (index.natAdd 21)) heq + simpa only [digestEncoding_packHalves_high] using h + +theorem packHalves_valid (low high : Fin 21 → Digit) + (hlow : (∑ index, (low index).val) = 95) (hhigh : (∑ index, (high index).val) = 96) : + ValidDigest (packHalves low high) := by + have hsum : Valid (digestEncoding (packHalves low high)) := by + unfold Valid sum + change (∑ index : Fin (21 + 21), (digestEncoding (packHalves low high) index).val) = 191 + rw [Fin.sum_univ_add] + simp only [digestEncoding_packHalves_low, digestEncoding_packHalves_high, hlow, hhigh] + refine ⟨digestEncoding (packHalves low high), ?_⟩ + rw [decodeDigest, if_pos ⟨(packHalves_padding low high).1, (packHalves_padding low high).2, hsum⟩] + +abbrev DigitSumFiber (n total : Nat) := {digits : Fin n → Digit // (∑ index, (digits index).val) = total} + +noncomputable def digitSumCount (n total : Nat) : Nat := Fintype.card (DigitSumFiber n total) + +theorem digitSumCount_zero (total : Nat) : digitSumCount 0 total = if total = 0 then 1 else 0 := by + by_cases hzero : total = 0 + · subst total + simp [digitSumCount, DigitSumFiber] + · have hempty : IsEmpty (DigitSumFiber 0 total) := ⟨fun digits => by + have heq : 0 = total := by simpa using digits.property + exact hzero heq.symm⟩ + simp [digitSumCount, hzero] + +def digitSumSplit (n total : Nat) : DigitSumFiber (n + 1) total ≃ + Σ head : Digit, {tail : Fin n → Digit // head.val + (∑ index, (tail index).val) = total} where + toFun digits := ⟨digits.val 0, ⟨fun index => digits.val index.succ, by + simpa only [Fin.sum_univ_succ] using digits.property⟩⟩ + invFun pair := ⟨Fin.cons pair.1 pair.2.val, by simpa only [Fin.sum_univ_succ, Fin.cons_zero, Fin.cons_succ] using pair.2.property⟩ + left_inv digits := by + apply Subtype.ext + funext index + cases index using Fin.cases <;> rfl + right_inv pair := by + cases pair + rfl + +theorem digitSumCount_succ (n total : Nat) : + digitSumCount (n + 1) total = ∑ head : Digit, if head.val ≤ total then digitSumCount n (total - head.val) else 0 := by + rw [digitSumCount, Fintype.card_congr (digitSumSplit n total), Fintype.card_sigma] + apply Finset.sum_congr rfl + intro head _ + by_cases hle : head.val ≤ total + · rw [if_pos hle] + exact Fintype.card_congr (Equiv.subtypeEquivRight fun tail => by omega) + · rw [if_neg hle] + have hempty : IsEmpty {tail : Fin n → Digit // head.val + (∑ index, (tail index).val) = total} := + ⟨fun tail => by have := tail.property; omega⟩ + exact Fintype.card_eq_zero + +theorem product_card_le_finset_of_injective + {α β γ : Type} [Fintype α] [Fintype β] [DecidableEq γ] + (targets : Finset γ) (packing : α × β → γ) (hinjective : Function.Injective packing) + (hmem : ∀ pair, packing pair ∈ targets) : Fintype.card α * Fintype.card β ≤ targets.card := by + calc + Fintype.card α * Fintype.card β = Fintype.card (α × β) := (Fintype.card_prod α β).symm + _ = (Finset.univ.image packing).card := (Finset.card_image_of_injective Finset.univ hinjective).symm + _ ≤ targets.card := Finset.card_le_card (by + intro value hvalue + obtain ⟨pair, _hpair, rfl⟩ := Finset.mem_image.mp hvalue + exact hmem pair) + +theorem digitSumCount_product_le_finset {γ : Type} [DecidableEq γ] + (n total m otherTotal : Nat) (targets : Finset γ) + (packing : DigitSumFiber n total × DigitSumFiber m otherTotal → γ) + (hinjective : Function.Injective packing) (hmem : ∀ pair, packing pair ∈ targets) : + digitSumCount n total * digitSumCount m otherTotal ≤ targets.card := + product_card_le_finset_of_injective targets packing hinjective hmem + +theorem digitSumCount_halves_le_validDigests : + digitSumCount 21 95 * digitSumCount 21 96 ≤ validDigests.card := by + apply digitSumCount_product_le_finset 21 95 21 96 validDigests + (fun halves : DigitSumFiber 21 95 × DigitSumFiber 21 96 => packHalves halves.1.val halves.2.val) + · intro left right heq + have hvalues := @packHalves_injective (left.1.val, left.2.val) (right.1.val, right.2.val) heq + exact Prod.ext (Subtype.ext (congrArg Prod.fst hvalues)) (Subtype.ext (congrArg Prod.snd hvalues)) + · intro halves + exact mem_validDigests.mpr (packHalves_valid halves.1.val halves.2.val halves.1.property halves.2.property) + +def digitSumStep (row : List Nat) : List Nat := + List.ofFn fun total : Fin 97 => + ∑ head : Digit, if head.val ≤ total.val then row.getD (total.val - head.val) 0 else 0 + +theorem digitSumStep_correct (row : List Nat) (n : Nat) + (hrow : ∀ total, total < 97 → row.getD total 0 = digitSumCount n total) : + ∀ total, total < 97 → (digitSumStep row).getD total 0 = digitSumCount (n + 1) total := by + intro total htotal + simp only [digitSumStep, List.getD_eq_getElem?_getD, List.getElem?_ofFn, htotal, dite_true, Option.getD_some] + rw [digitSumCount_succ] + apply Finset.sum_congr rfl + intro head _ + by_cases hle : head.val ≤ total + · simp only [hle, if_pos] + exact hrow (total - head.val) (by omega) + · simp [hle] + +end SphincsSecurity.TargetSum diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingCountCertificate.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingCountCertificate.lean new file mode 100644 index 00000000..000af31d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingCountCertificate.lean @@ -0,0 +1,496 @@ +import SphincsSecurity.Proof.EncodingCount + +namespace SphincsSecurity.TargetSum + +set_option maxRecDepth 2000 +set_option maxHeartbeats 2000000 + +private def row0 : List Nat := 1 :: List.replicate 96 0 + +private theorem row0_correct (total : Nat) (_htotal : total < 97) : + row0.getD total 0 = digitSumCount 0 total := by + rw [digitSumCount_zero] + cases total with + | zero => rfl + | succ total => + have hlt : total < 96 := by omega + change (List.replicate 96 0).getD total 0 = 0 + rw [List.getD_eq_getElem?_getD, List.getElem?_replicate_of_lt hlt] + rfl + +private def row1 : List Nat := [ + 1, 1, 1, 1, 1, 1, 1, 1, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0] + +private theorem row1_checked : digitSumStep row0 = row1 := by decide + +private theorem row1_correct (total : Nat) (htotal : total < 97) : + row1.getD total 0 = digitSumCount 1 total := by + rw [← row1_checked] + exact digitSumStep_correct row0 0 row0_correct total htotal + +private def row2 : List Nat := [ + 1, 2, 3, 4, 5, 6, 7, 8, + 7, 6, 5, 4, 3, 2, 1, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0] + +private theorem row2_checked : digitSumStep row1 = row2 := by decide + +private theorem row2_correct (total : Nat) (htotal : total < 97) : + row2.getD total 0 = digitSumCount 2 total := by + rw [← row2_checked] + exact digitSumStep_correct row1 1 row1_correct total htotal + +private def row3 : List Nat := [ + 1, 3, 6, 10, 15, 21, 28, 36, + 42, 46, 48, 48, 46, 42, 36, 28, + 21, 15, 10, 6, 3, 1, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0] + +private theorem row3_checked : digitSumStep row2 = row3 := by decide + +private theorem row3_correct (total : Nat) (htotal : total < 97) : + row3.getD total 0 = digitSumCount 3 total := by + rw [← row3_checked] + exact digitSumStep_correct row2 2 row2_correct total htotal + +private def row4 : List Nat := [ + 1, 4, 10, 20, 35, 56, 84, 120, + 161, 204, 246, 284, 315, 336, 344, 336, + 315, 284, 246, 204, 161, 120, 84, 56, + 35, 20, 10, 4, 1, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0] + +private theorem row4_checked : digitSumStep row3 = row4 := by decide + +private theorem row4_correct (total : Nat) (htotal : total < 97) : + row4.getD total 0 = digitSumCount 4 total := by + rw [← row4_checked] + exact digitSumStep_correct row3 3 row3_correct total htotal + +private def row5 : List Nat := [ + 1, 5, 15, 35, 70, 126, 210, 330, + 490, 690, 926, 1190, 1470, 1750, 2010, 2226, + 2380, 2460, 2460, 2380, 2226, 2010, 1750, 1470, + 1190, 926, 690, 490, 330, 210, 126, 70, + 35, 15, 5, 1, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0] + +private theorem row5_checked : digitSumStep row4 = row5 := by decide + +private theorem row5_correct (total : Nat) (htotal : total < 97) : + row5.getD total 0 = digitSumCount 5 total := by + rw [← row5_checked] + exact digitSumStep_correct row4 4 row4_correct total htotal + +private def row6 : List Nat := [ + 1, 6, 21, 56, 126, 252, 462, 792, + 1281, 1966, 2877, 4032, 5432, 7056, 8856, 10752, + 12642, 14412, 15946, 17136, 17892, 18152, 17892, 17136, + 15946, 14412, 12642, 10752, 8856, 7056, 5432, 4032, + 2877, 1966, 1281, 792, 462, 252, 126, 56, + 21, 6, 1, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0] + +private theorem row6_checked : digitSumStep row5 = row6 := by decide + +private theorem row6_correct (total : Nat) (htotal : total < 97) : + row6.getD total 0 = digitSumCount 6 total := by + rw [← row6_checked] + exact digitSumStep_correct row5 5 row5_correct total htotal + +private def row7 : List Nat := [ + 1, 7, 28, 84, 210, 462, 924, 1716, + 2996, 4956, 7812, 11788, 17094, 23898, 32292, 42252, + 53613, 66059, 79128, 92232, 104692, 115788, 124824, 131208, + 134512, 134512, 131208, 124824, 115788, 104692, 92232, 79128, + 66059, 53613, 42252, 32292, 23898, 17094, 11788, 7812, + 4956, 2996, 1716, 924, 462, 210, 84, 28, + 7, 1, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0] + +private theorem row7_checked : digitSumStep row6 = row7 := by decide + +private theorem row7_correct (total : Nat) (htotal : total < 97) : + row7.getD total 0 = digitSumCount 7 total := by + rw [← row7_checked] + exact digitSumStep_correct row6 6 row6_correct total htotal + +private def row8 : List Nat := [ + 1, 8, 36, 120, 330, 792, 1716, 3432, + 6427, 11376, 19160, 30864, 47748, 71184, 102552, 143088, + 193705, 254808, 326124, 406568, 494166, 586056, 678588, 767544, + 848443, 916896, 968976, 1001568, 1012664, 1001568, 968976, 916896, + 848443, 767544, 678588, 586056, 494166, 406568, 326124, 254808, + 193705, 143088, 102552, 71184, 47748, 30864, 19160, 11376, + 6427, 3432, 1716, 792, 330, 120, 36, 8, + 1, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0] + +private theorem row8_checked : digitSumStep row7 = row8 := by decide + +private theorem row8_correct (total : Nat) (htotal : total < 97) : + row8.getD total 0 = digitSumCount 8 total := by + rw [← row8_checked] + exact digitSumStep_correct row7 7 row7_correct total htotal + +private def row9 : List Nat := [ + 1, 9, 45, 165, 495, 1287, 3003, 6435, + 12861, 24229, 43353, 74097, 121515, 191907, 292743, 432399, + 619677, 863109, 1170073, 1545777, 1992195, 2507067, 3083103, 3707559, + 4362297, 5024385, 5667237, 6262237, 6780735, 7196247, 7486635, 7635987, + 7635987, 7486635, 7196247, 6780735, 6262237, 5667237, 5024385, 4362297, + 3707559, 3083103, 2507067, 1992195, 1545777, 1170073, 863109, 619677, + 432399, 292743, 191907, 121515, 74097, 43353, 24229, 12861, + 6435, 3003, 1287, 495, 165, 45, 9, 1, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0] + +private theorem row9_checked : digitSumStep row8 = row9 := by decide + +private theorem row9_correct (total : Nat) (htotal : total < 97) : + row9.getD total 0 = digitSumCount 9 total := by + rw [← row9_checked] + exact digitSumStep_correct row8 8 row8_correct total htotal + +private def row10 : List Nat := [ + 1, 10, 55, 220, 715, 2002, 5005, 11440, + 24300, 48520, 91828, 165760, 286780, 477400, 767140, 1193104, + 1799920, 2638800, 3765520, 5237200, 7107880, 9423040, 12213400, 15488560, + 19231180, 23392456, 27889620, 32606080, 37394620, 42083800, 46487332, 50415760, + 53689450, 56151700, 57680710, 58199208, 57680710, 56151700, 53689450, 50415760, + 46487332, 42083800, 37394620, 32606080, 27889620, 23392456, 19231180, 15488560, + 12213400, 9423040, 7107880, 5237200, 3765520, 2638800, 1799920, 1193104, + 767140, 477400, 286780, 165760, 91828, 48520, 24300, 11440, + 5005, 2002, 715, 220, 55, 10, 1, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0] + +private theorem row10_checked : digitSumStep row9 = row10 := by decide + +private theorem row10_correct (total : Nat) (htotal : total < 97) : + row10.getD total 0 = digitSumCount 10 total := by + rw [← row10_checked] + exact digitSumStep_correct row9 9 row9_correct total htotal + +private def row11 : List Nat := [ + 1, 11, 66, 286, 1001, 3003, 8008, 19448, + 43747, 92257, 184030, 349570, 635635, 1111033, 1873168, 3054832, + 4830452, 7420732, 11094424, 16165864, 22986964, 31932604, 43378864, 57674320, + 75105580, 95859236, 119983336, 147352216, 177638956, 210299716, 244573648, 279500848, + 313959118, 346718362, 376509452, 402102580, 422388670, 436456570, 443658688, 443658688, + 436456570, 422388670, 402102580, 376509452, 346718362, 313959118, 279500848, 244573648, + 210299716, 177638956, 147352216, 119983336, 95859236, 75105580, 57674320, 43378864, + 31932604, 22986964, 16165864, 11094424, 7420732, 4830452, 3054832, 1873168, + 1111033, 635635, 349570, 184030, 92257, 43747, 19448, 8008, + 3003, 1001, 286, 66, 11, 1, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0] + +private theorem row11_checked : digitSumStep row10 = row11 := by decide + +private theorem row11_correct (total : Nat) (htotal : total < 97) : + row11.getD total 0 = digitSumCount 11 total := by + rw [← row11_checked] + exact digitSumStep_correct row10 10 row10_correct total htotal + +private def row12 : List Nat := [ + 1, 12, 78, 364, 1365, 4368, 12376, 31824, + 75570, 167816, 351780, 701064, 1335698, 2443728, 4308888, 7344272, + 12130977, 19459452, 30369846, 46186140, 68537469, 99359040, 140864736, 195484224, + 265759352, 354197856, 463086768, 594273120, 748925112, 927292224, 1128487008, 1350313536, + 1589167074, 1840026200, 2096552316, 2351302680, 2596052394, 2822209248, 3021294288, 3185452128, + 3307949580, 3383619888, 3409213016, 3383619888, 3307949580, 3185452128, 3021294288, 2822209248, + 2596052394, 2351302680, 2096552316, 1840026200, 1589167074, 1350313536, 1128487008, 927292224, + 748925112, 594273120, 463086768, 354197856, 265759352, 195484224, 140864736, 99359040, + 68537469, 46186140, 30369846, 19459452, 12130977, 7344272, 4308888, 2443728, + 1335698, 701064, 351780, 167816, 75570, 31824, 12376, 4368, + 1365, 364, 78, 12, 1, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0] + +private theorem row12_checked : digitSumStep row11 = row12 := by decide + +private theorem row12_correct (total : Nat) (htotal : total < 97) : + row12.getD total 0 = digitSumCount 12 total := by + rw [← row12_checked] + exact digitSumStep_correct row11 11 row11_correct total htotal + +private def row13 : List Nat := [ + 1, 13, 91, 455, 1820, 6188, 18564, 50388, + 125957, 293761, 645463, 1346163, 2680496, 5119856, 9416368, 16728816, + 28784223, 48075859, 78093925, 123579001, 190780772, 287696084, 424251932, 612391884, + 866020259, 1200758663, 1633475585, 2181562565, 2861950208, 3689883392, 4677505664, 5832334976, + 7155742698, 8641571042, 10275036590, 12032066150, 13879193432, 15774110456, 17666917736, 19502056328, + 21220838834, 22764432522, 24077093222, 25109410430, 25821307616, 26184550496, 26184550496, 25821307616, + 25109410430, 24077093222, 22764432522, 21220838834, 19502056328, 17666917736, 15774110456, 13879193432, + 12032066150, 10275036590, 8641571042, 7155742698, 5832334976, 4677505664, 3689883392, 2861950208, + 2181562565, 1633475585, 1200758663, 866020259, 612391884, 424251932, 287696084, 190780772, + 123579001, 78093925, 48075859, 28784223, 16728816, 9416368, 5119856, 2680496, + 1346163, 645463, 293761, 125957, 50388, 18564, 6188, 1820, + 455, 91, 13, 1, 0, 0, 0, 0, + 0] + +private theorem row13_checked : digitSumStep row12 = row13 := by decide + +private theorem row13_correct (total : Nat) (htotal : total < 97) : + row13.getD total 0 = digitSumCount 13 total := by + rw [← row13_checked] + exact digitSumStep_correct row12 12 row12_correct total htotal + +private def row14 : List Nat := [ + 1, 14, 105, 560, 2380, 8568, 27132, 77520, + 203476, 497224, 1142596, 2488304, 5166980, 10280648, 19678452, 36356880, + 65015146, 112797244, 190245706, 312478544, 500578820, 783155048, 1197990612, 1793653680, + 2630889716, 3783572520, 5338954180, 7396937744, 10068107180, 13470294488, 17723548220, 22943491312, + 29233213751, 36674026130, 45315587135, 55166090720, 66183333944, 78267561008, 91256973080, 104926694432, + 118991790568, 133114652048, 146916708680, 159994052960, 171936167144, 182346607184, 190864239944, 197183491232, + 201072062828, 202384723528, 201072062828, 197183491232, 190864239944, 182346607184, 171936167144, 159994052960, + 146916708680, 133114652048, 118991790568, 104926694432, 91256973080, 78267561008, 66183333944, 55166090720, + 45315587135, 36674026130, 29233213751, 22943491312, 17723548220, 13470294488, 10068107180, 7396937744, + 5338954180, 3783572520, 2630889716, 1793653680, 1197990612, 783155048, 500578820, 312478544, + 190245706, 112797244, 65015146, 36356880, 19678452, 10280648, 5166980, 2488304, + 1142596, 497224, 203476, 77520, 27132, 8568, 2380, 560, + 105] + +private theorem row14_checked : digitSumStep row13 = row14 := by decide + +private theorem row14_correct (total : Nat) (htotal : total < 97) : + row14.getD total 0 = digitSumCount 14 total := by + rw [← row14_checked] + exact digitSumStep_correct row13 13 row13_correct total htotal + +private def row15 : List Nat := [ + 1, 15, 120, 680, 3060, 11628, 38760, 116280, + 319755, 816965, 1959456, 4447200, 9611800, 19883880, 39535200, 75814560, + 140626230, 252926250, 442029360, 752019600, 1247431440, 2020305840, 3198618000, 4955914800, + 7521789370, 11192564646, 16341273120, 23425732320, 32993260680, 45680400120, 62205957728, 83355795360, + 109958119395, 142848573005, 182825205960, 230594358936, 286709585700, 351506852220, 425040277080, 507023480200, + 596782057017, 693222682935, 794823804480, 899651766720, 1005404599920, 1109483646096, 1209090912960, 1301347709760, + 1383427982020, 1452698053500, 1506853407648, 1544042845920, 1562970918720, 1562970918720, 1544042845920, 1506853407648, + 1452698053500, 1383427982020, 1301347709760, 1209090912960, 1109483646096, 1005404599920, 899651766720, 794823804480, + 693222682935, 596782057017, 507023480200, 425040277080, 351506852220, 286709585700, 230594358936, 182825205960, + 142848573005, 109958119395, 83355795360, 62205957728, 45680400120, 32993260680, 23425732320, 16341273120, + 11192564646, 7521789370, 4955914800, 3198618000, 2020305840, 1247431440, 752019600, 442029360, + 252926250, 140626230, 75814560, 39535200, 19883880, 9611800, 4447200, 1959456, + 816965] + +private theorem row15_checked : digitSumStep row14 = row15 := by decide + +private theorem row15_correct (total : Nat) (htotal : total < 97) : + row15.getD total 0 = digitSumCount 15 total := by + rw [← row15_checked] + exact digitSumStep_correct row14 14 row14_correct total htotal + +private def row16 : List Nat := [ + 1, 16, 136, 816, 3876, 15504, 54264, 170544, + 490298, 1307248, 3266584, 7713104, 17321844, 37194096, 76690536, 152388816, + 292695291, 544804576, 984874480, 1732446880, 2970266520, 4970688480, 8129771280, 13009871520, + 20391034660, 31330673056, 47229916816, 69903629536, 101649458776, 145309553056, 204316892784, 282716773344, + 385153103369, 516809111728, 683293044568, 890461671184, 1144177996204, 1450004448304, 1812838767656, 2236506452496, + 2723330390118, 3273704500048, 3885703098568, 4554760506352, 5273455520572, 6031432314448, 6815482950328, 7609807179888, + 8396453104891, 9155928475456, 9867958078624, 10512349157824, 11069915476624, 11523402749248, 11858354682208, 12063860380096, + 12133130451576, 12063860380096, 11858354682208, 11523402749248, 11069915476624, 10512349157824, 9867958078624, 9155928475456, + 8396453104891, 7609807179888, 6815482950328, 6031432314448, 5273455520572, 4554760506352, 3885703098568, 3273704500048, + 2723330390118, 2236506452496, 1812838767656, 1450004448304, 1144177996204, 890461671184, 683293044568, 516809111728, + 385153103369, 282716773344, 204316892784, 145309553056, 101649458776, 69903629536, 47229916816, 31330673056, + 20391034660, 13009871520, 8129771280, 4970688480, 2970266520, 1732446880, 984874480, 544804576, + 292695291] + +private theorem row16_checked : digitSumStep row15 = row16 := by decide + +private theorem row16_correct (total : Nat) (htotal : total < 97) : + row16.getD total 0 = digitSumCount 16 total := by + rw [← row16_checked] + exact digitSumStep_correct row15 15 row15_correct total htotal + +private def row17 : List Nat := [ + 1, 17, 153, 969, 4845, 20349, 74613, 245157, + 735454, 2042686, 5309134, 13021422, 30339390, 67517982, 144154254, 296372526, + 588577519, 1132074847, 2113682743, 3838416519, 6791361195, 11724855579, 19777936323, 32635419027, + 52733758396, 83519626876, 129764669212, 197935851868, 296615044124, 436953908700, 633141030204, 902847932028, + 1267610000737, 1753088439409, 2389151567161, 3209709608809, 4252238146237, 5556933041485, 7165454916357, 9119244595509, + 11457421882258, 14214317270578, 17416727324578, 21081026159746, 25210303684114, 29791731550258, 34794375732930, 40167676460322, + 45840799175095, 51723023150503, 57705278130559, 63662866782031, 69459326738083, 74951297172883, 79994168904763, 84448222104971, + 88184899451656, 91092831356296, 93083227959880, 94094281551304, 94094281551304, 93083227959880, 91092831356296, 88184899451656, + 84448222104971, 79994168904763, 74951297172883, 69459326738083, 63662866782031, 57705278130559, 51723023150503, 45840799175095, + 40167676460322, 34794375732930, 29791731550258, 25210303684114, 21081026159746, 17416727324578, 14214317270578, 11457421882258, + 9119244595509, 7165454916357, 5556933041485, 4252238146237, 3209709608809, 2389151567161, 1753088439409, 1267610000737, + 902847932028, 633141030204, 436953908700, 296615044124, 197935851868, 129764669212, 83519626876, 52733758396, + 32635419027] + +private theorem row17_checked : digitSumStep row16 = row17 := by decide + +private theorem row17_correct (total : Nat) (htotal : total < 97) : + row17.getD total 0 = digitSumCount 17 total := by + rw [← row17_checked] + exact digitSumStep_correct row16 16 row16_correct total htotal + +private def row18 : List Nat := [ + 1, 18, 171, 1140, 5985, 26334, 100947, 346104, + 1081557, 3124226, 8433207, 21453660, 51788205, 119285838, 263365479, 559492848, + 1147334913, 2277367074, 4385740683, 8211135780, 14972157585, 26629495182, 46263277251, 78602323752, + 130747504629, 213135056658, 340786043127, 534883478476, 824707161405, 1249936214526, 1863299308407, 2733511821408, + 3948388063749, 5617956876282, 7877343774231, 10889117531172, 14844740633285, 19964719766070, 26497033652223, 34713430315704, + 44903242197225, 57364471028394, 72392046785811, 90263363336748, 111221428874625, 135456227383398, 163085148199971, 194133580064784, + 228516957357621, 266025663237546, 306314214043527, 348896054665812, 393145077719781, 438304643342406, 483504436514239, 527784982158888, + 570129082435449, 609498890641242, 644876840470563, 675308255239836, 699943210053057, 718075140840054, 729173803291587, 732910480638272, + 729173803291587, 718075140840054, 699943210053057, 675308255239836, 644876840470563, 609498890641242, 570129082435449, 527784982158888, + 483504436514239, 438304643342406, 393145077719781, 348896054665812, 306314214043527, 266025663237546, 228516957357621, 194133580064784, + 163085148199971, 135456227383398, 111221428874625, 90263363336748, 72392046785811, 57364471028394, 44903242197225, 34713430315704, + 26497033652223, 19964719766070, 14844740633285, 10889117531172, 7877343774231, 5617956876282, 3948388063749, 2733511821408, + 1863299308407] + +private theorem row18_checked : digitSumStep row17 = row18 := by decide + +private theorem row18_correct (total : Nat) (htotal : total < 97) : + row18.getD total 0 = digitSumCount 18 total := by + rw [← row18_checked] + exact digitSumStep_correct row17 17 row17_correct total htotal + +private def row19 : List Nat := [ + 1, 19, 190, 1330, 7315, 33649, 134596, 480700, + 1562256, 4686464, 13119500, 34572020, 86354240, 205613744, 468878276, 1028025020, + 2174278376, 4448521224, 8825828700, 17015510820, 31935880200, 58446089544, 104446001316, 182488832220, + 312089001936, 522946691520, 859346993964, 1386019336660, 2195754340480, 3419061059824, 5236097090980, 7891006588636, + 11708647147756, 17113468967380, 24650026698484, 35004260751180, 49024294223060, 67739077774604, 92372812118420, 124352730612716, + 165307584746192, 217054098898304, 281568801909884, 360943047715460, 457319735956800, 572811243574128, 709399358121876, 868819507870956, + 1052433223031352, 1261094415240504, 1495016582498220, 1753649273827284, 2035572922672440, 2338421338631448, 2658840626945716, 2992492029039820, + 3334104154117648, 3677577381521344, 4016140007948380, 4342552208522404, 4649350340855680, 4929120838353328, 5174790205130676, 5379915703610060, + 5538960424466198, 5647536674665010, 5702603044247504, 5702603044247504, 5647536674665010, 5538960424466198, 5379915703610060, 5174790205130676, + 4929120838353328, 4649350340855680, 4342552208522404, 4016140007948380, 3677577381521344, 3334104154117648, 2992492029039820, 2658840626945716, + 2338421338631448, 2035572922672440, 1753649273827284, 1495016582498220, 1261094415240504, 1052433223031352, 868819507870956, 709399358121876, + 572811243574128, 457319735956800, 360943047715460, 281568801909884, 217054098898304, 165307584746192, 124352730612716, 92372812118420, + 67739077774604] + +private theorem row19_checked : digitSumStep row18 = row19 := by decide + +private theorem row19_correct (total : Nat) (htotal : total < 97) : + row19.getD total 0 = digitSumCount 19 total := by + rw [← row19_checked] + exact digitSumStep_correct row18 18 row18_correct total htotal + +private def row20 : List Nat := [ + 1, 20, 210, 1540, 8855, 42504, 177100, 657800, + 2220055, 6906500, 20025810, 54596500, 140943425, 346523520, 815267200, 1842811520, + 4015527640, 8459362400, 17272071600, 34253010400, 66102536360, 124343012160, 228320135200, 409780942400, + 719695665960, 1238193836256, 2088715001520, 3457718827360, 5621537287640, 8982152257920, 14113803347584, 21822321104000, + 33218879249820, 49809401525680, 73600081230200, 107218322644720, 154046862527300, 218366879242080, 305503594269520, 421965318293600, + 575564255892036, 775504885822960, 1032423661034360, 1358362447998640, 1766657889732380, 2271730055531904, 2888756601535360, 3633223378793600, + 4520349017078760, 5564389333420960, 6777837114009296, 8170543340121120, 9748796526836760, 11514406621894080, 13463847890717920, 15587520411886784, + 17869191342973080, 20285674309253920, 22806797734704080, 25395700669399200, 28009478087582440, 30600177587304320, 33116127165489280, 35503550840059520, + 37708407110408070, 39678366403551736, 41364829439850860, 42724880275575960, 43723066609385290, 44332906195498160, 44538031693977544, 44332906195498160, + 43723066609385290, 42724880275575960, 41364829439850860, 39678366403551736, 37708407110408070, 35503550840059520, 33116127165489280, 30600177587304320, + 28009478087582440, 25395700669399200, 22806797734704080, 20285674309253920, 17869191342973080, 15587520411886784, 13463847890717920, 11514406621894080, + 9748796526836760, 8170543340121120, 6777837114009296, 5564389333420960, 4520349017078760, 3633223378793600, 2888756601535360, 2271730055531904, + 1766657889732380] + +private theorem row20_checked : digitSumStep row19 = row20 := by decide + +private theorem row20_correct (total : Nat) (htotal : total < 97) : + row20.getD total 0 = digitSumCount 20 total := by + rw [← row20_checked] + exact digitSumStep_correct row19 19 row19_correct total htotal + +private def row21 : List Nat := [ + 1, 21, 231, 1771, 10626, 53130, 230230, 888030, + 3108084, 10014564, 30040164, 84635124, 225569694, 572050710, 1387140810, 3229294530, + 7242602115, 15695058015, 32947103805, 67145517705, 133107110640, 257103599280, 484608467280, 892546598160, + 1608226736480, 2837961210336, 4909404140256, 8332869957216, 13888304708496, 22746113954256, 36631597166640, 58044137328240, + 90543320912100, 139114528601524, 210625894830204, 314386498647564, 462811823887224, 672196550871384, 963586341793320, 1363729338982920, + 1906074715625136, 2631770199922416, 3590593779726576, 4841737905080496, 6454348932285576, 8507712108575400, 11090965115841240, 14302223176341240, + 18247007937527964, 23035892385125964, 28781305838100900, 35593486730223380, 43575625367327760, 52818301933689936, 63393393222872496, 75347690255965680, + 88696532581860000, 103417817557692960, 119446778178387744, 136671935507665824, 154932617068411504, 174018388033821744, 193670667308593104, 213586697736765840, + 233425913504200830, 252818605598498646, 271376637303645426, 288705816909822186, 304419405431625036, 318152134039818876, 329574038568307140, 338403393923745780, + 344418053422723000, 347464567294747224, 347464567294747224, 344418053422723000, 338403393923745780, 329574038568307140, 318152134039818876, 304419405431625036, + 288705816909822186, 271376637303645426, 252818605598498646, 233425913504200830, 213586697736765840, 193670667308593104, 174018388033821744, 154932617068411504, + 136671935507665824, 119446778178387744, 103417817557692960, 88696532581860000, 75347690255965680, 63393393222872496, 52818301933689936, 43575625367327760, + 35593486730223380] + +private theorem row21_checked : digitSumStep row20 = row21 := by decide + +private theorem row21_correct (total : Nat) (htotal : total < 97) : + row21.getD total 0 = digitSumCount 21 total := by + rw [← row21_checked] + exact digitSumStep_correct row20 20 row20_correct total htotal + +theorem digitSumCount_21_95 : digitSumCount 21 95 = 43575625367327760 := by + rw [← row21_correct 95 (by decide)] + rfl + +theorem digitSumCount_21_96 : digitSumCount 21 96 = 35593486730223380 := by + rw [← row21_correct 96 (by decide)] + rfl + +theorem validDigests_card_ge_pow105 : 2 ^ 105 ≤ validDigests.card := by + have hcount := digitSumCount_halves_le_validDigests + rw [digitSumCount_21_95, digitSumCount_21_96] at hcount + exact (by norm_num : 2 ^ 105 ≤ 43575625367327760 * 35593486730223380).trans hcount + +end SphincsSecurity.TargetSum diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingExhaustionBound.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingExhaustionBound.lean new file mode 100644 index 00000000..e88ce71b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingExhaustionBound.lean @@ -0,0 +1,94 @@ +import SphincsSecurity.Proof.EncodingCountCertificate +import SphincsSecurity.Proof.EncodingExhaustionProbability + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +set_option maxRecDepth 4000 +set_option backward.isDefEq.respectTransparency false +set_option exponentiation.threshold 512 + +theorem one_sub_inv_nat_pow_mul_le (m k : Nat) (hm : 1 ≤ m) : + (1 - (m : ℝ)⁻¹) ^ (m * k) ≤ (1 / 2 : ℝ) ^ k := by + have hmpos : (0 : ℝ) < m := by exact_mod_cast (show 0 < m by omega) + have hmin : (1 : ℝ) ≤ m := by exact_mod_cast hm + have hx : (0 : ℝ) ≤ (m : ℝ)⁻¹ := inv_nonneg.mpr hmpos.le + have hxle : (m : ℝ)⁻¹ ≤ 1 := by + simpa using (inv_le_inv₀ hmpos (by norm_num : (0 : ℝ) < 1)).mpr hmin + have hbase : 1 - (m : ℝ)⁻¹ ≤ (1 + (m : ℝ)⁻¹)⁻¹ := by + have h := (le_div_iff₀ (by positivity : (0 : ℝ) < 1 + (m : ℝ)⁻¹)).mpr + (show (1 - (m : ℝ)⁻¹) * (1 + (m : ℝ)⁻¹) ≤ 1 by nlinarith [sq_nonneg ((m : ℝ)⁻¹)]) + simpa only [one_div] using h + have hbernoulli : (2 : ℝ) ≤ (1 + (m : ℝ)⁻¹) ^ m := by + have h := one_add_mul_le_pow (by linarith : (-2 : ℝ) ≤ (m : ℝ)⁻¹) m + simpa only [mul_inv_cancel₀ (ne_of_gt hmpos), show (1 : ℝ) + 1 = 2 by norm_num] using h + have hblock : (1 - (m : ℝ)⁻¹) ^ m ≤ (1 / 2 : ℝ) := by + calc + _ ≤ ((1 + (m : ℝ)⁻¹)⁻¹) ^ m := pow_le_pow_left₀ (sub_nonneg.mpr hxle) hbase m + _ = ((1 + (m : ℝ)⁻¹) ^ m)⁻¹ := inv_pow _ _ + _ ≤ _ := by + rw [one_div] + exact (inv_le_inv₀ (by positivity) (by norm_num)).mpr hbernoulli + rw [pow_mul] + exact pow_le_pow_left₀ (pow_nonneg (sub_nonneg.mpr hxle) m) hblock k + +theorem one_sub_inv_nat_pow_mul_le_ennreal (m k : Nat) (hm : 1 ≤ m) : + (1 - (m : ℝ≥0∞)⁻¹) ^ (m * k) ≤ ((2 ^ k : Nat) : ℝ≥0∞)⁻¹ := by + have hmpos : (0 : ℝ) < m := by exact_mod_cast (show 0 < m by omega) + have hmin : (1 : ℝ) ≤ m := by exact_mod_cast hm + have hxle : (m : ℝ)⁻¹ ≤ 1 := by + simpa using (inv_le_inv₀ hmpos (by norm_num : (0 : ℝ) < 1)).mpr hmin + have hbase : (0 : ℝ) ≤ 1 - (m : ℝ)⁻¹ := sub_nonneg.mpr hxle + have h := ENNReal.ofReal_le_ofReal (one_sub_inv_nat_pow_mul_le m k hm) + rw [ENNReal.ofReal_pow hbase, ENNReal.ofReal_sub 1 (by positivity), ENNReal.ofReal_one, + ENNReal.ofReal_inv_of_pos hmpos, ENNReal.ofReal_natCast] at h + rw [ENNReal.ofReal_pow (by norm_num : (0 : ℝ) ≤ 1 / 2)] at h + have hhalf : ENNReal.ofReal (1 / 2 : ℝ) = (2 : ℝ≥0∞)⁻¹ := by + rw [one_div, ENNReal.ofReal_inv_of_pos (by norm_num), ENNReal.ofReal_ofNat] + rw [hhalf, ← ENNReal.inv_pow] at h + simpa only [Nat.cast_pow, Nat.cast_ofNat] using h + +theorem encoding_exhaustion_tail_le_inv512 : + (1 - ((2 ^ 23 : Nat) : ℝ≥0∞)⁻¹) ^ encodingAttemptLimit ≤ ((2 ^ 512 : Nat) : ℝ≥0∞)⁻¹ := by + have hbound := one_sub_inv_nat_pow_mul_le_ennreal (2 ^ 23) 512 (by norm_num) + have hexponent : (2 ^ 23 : Nat) * 512 = encodingAttemptLimit := by norm_num [encodingAttemptLimit] + rw [hexponent] at hbound + exact hbound + +theorem encoding_exhaustion_global_bound_le_inv216 : + ((3 * 2 ^ 294 : Nat) : ℝ≥0∞) * + (1 - (TargetSum.validDigests.card : ℝ≥0∞) / (Fintype.card Digest : ℝ≥0∞)) ^ encodingAttemptLimit ≤ + ((2 ^ 216 : Nat) : ℝ≥0∞)⁻¹ := by + have hcount : ((2 ^ 105 : Nat) : ℝ≥0∞) ≤ (TargetSum.validDigests.card : ℝ≥0∞) := + (Nat.cast_le (α := ℝ≥0∞)).mpr TargetSum.validDigests_card_ge_pow105 + have hratio : ((2 ^ 23 : Nat) : ℝ≥0∞)⁻¹ ≤ + (TargetSum.validDigests.card : ℝ≥0∞) / (Fintype.card Digest : ℝ≥0∞) := by + calc + _ = ((2 ^ 105 : Nat) : ℝ≥0∞) / (Fintype.card Digest : ℝ≥0∞) := by + have hcard : Fintype.card Digest = 2 ^ 128 := by simp [digestBits] + rw [hcard] + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + norm_num + _ ≤ _ := by rw [div_eq_mul_inv, div_eq_mul_inv]; exact mul_le_mul' hcount le_rfl + have htail := (pow_le_pow_left' (tsub_le_tsub_left hratio 1) encodingAttemptLimit).trans + encoding_exhaustion_tail_le_inv512 + calc + _ ≤ ((3 * 2 ^ 294 : Nat) : ℝ≥0∞) * ((2 ^ 512 : Nat) : ℝ≥0∞)⁻¹ := mul_le_mul' le_rfl htail + _ ≤ _ := by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + norm_num + +theorem probEvent_anyEncodingInputsExhausted_le_inv216 + (computation : OracleComp OracleWorld α) : + Pr[fun result => AnyEncodingInputsExhausted result.2 | (simulateQ romImpl computation).run ∅] ≤ + ((2 ^ 216 : Nat) : ℝ≥0∞)⁻¹ := + (probEvent_anyEncodingInputsExhausted_le computation).trans encoding_exhaustion_global_bound_le_inv216 + +theorem probEvent_cachedOtsEncodingFailure_le_inv216 + (computation : OracleComp OracleWorld α) : + Pr[fun result => CachedOtsEncodingFailure result.2 | (simulateQ romImpl computation).run ∅] ≤ + ((2 ^ 216 : Nat) : ℝ≥0∞)⁻¹ := + (probEvent_cachedOtsEncodingFailure_le computation).trans encoding_exhaustion_global_bound_le_inv216 + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingExhaustionProbability.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingExhaustionProbability.lean new file mode 100644 index 00000000..c1e9d7ad --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingExhaustionProbability.lean @@ -0,0 +1,282 @@ +import SphincsSecurity.Proof.EncodingProbability +import SphincsSecurity.Proof.RomQueryCharge +import SphincsSecurity.Proof.EncodingSelectionCache + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option maxRecDepth 1000 +set_option exponentiation.threshold 512 + +noncomputable def encodingInvalidProbability : ℝ≥0∞ := + Pr[fun output : HashOutput => ¬TargetSum.ValidDigest (truncateHash output) | ($ᵗ HashOutput : ProbComp HashOutput)] + +noncomputable def encodingExhaustionWeight (cache : QueryCache HashSpec) (input : HashInput) : ℝ≥0∞ := + match cache input with + | none => encodingInvalidProbability + | some output => if TargetSum.ValidDigest (truncateHash output) then 0 else 1 + +noncomputable def encodingExhaustionPotential (inputs : Finset HashInput) (cache : QueryCache HashSpec) : ℝ≥0∞ := + ∏ input ∈ inputs, encodingExhaustionWeight cache input + +def EncodingInputsExhausted (inputs : Finset HashInput) (cache : QueryCache HashSpec) : Prop := + ∀ input ∈ inputs, ∃ output, cache input = some output ∧ ¬TargetSum.ValidDigest (truncateHash output) + +theorem encodingExhaustionPotential_empty_cache (inputs : Finset HashInput) : + encodingExhaustionPotential inputs ∅ = encodingInvalidProbability ^ inputs.card := by + simp [encodingExhaustionPotential, encodingExhaustionWeight] + +theorem encodingExhaustionPotential_eq_one_of_exhausted + (inputs : Finset HashInput) (cache : QueryCache HashSpec) (hexhausted : EncodingInputsExhausted inputs cache) : + encodingExhaustionPotential inputs cache = 1 := by + apply Finset.prod_eq_one + intro input hinput + obtain ⟨output, houtput, hinvalid⟩ := hexhausted input hinput + simp [encodingExhaustionWeight, houtput, hinvalid] + +theorem encodingExhaustionPotential_cacheQuery_of_not_mem + (inputs : Finset HashInput) (cache : QueryCache HashSpec) (input : HashInput) (output : HashOutput) + (hnot : input ∉ inputs) : + encodingExhaustionPotential inputs (cache.cacheQuery input output) = encodingExhaustionPotential inputs cache := by + apply Finset.prod_congr rfl + intro other hother + have hne : other ≠ input := fun heq => hnot (heq ▸ hother) + simp [encodingExhaustionWeight, QueryCache.cacheQuery_of_ne _ _ hne] + +theorem encodingExhaustionPotential_cacheQuery_of_mem + (inputs : Finset HashInput) (cache : QueryCache HashSpec) (input : HashInput) (output : HashOutput) + (hmem : input ∈ inputs) : + encodingExhaustionPotential inputs (cache.cacheQuery input output) = + (if TargetSum.ValidDigest (truncateHash output) then 0 else 1) * + encodingExhaustionPotential (inputs.erase input) cache := by + rw [encodingExhaustionPotential, ← Finset.mul_prod_erase inputs _ hmem] + change encodingExhaustionWeight (cache.cacheQuery input output) input * + encodingExhaustionPotential (inputs.erase input) (cache.cacheQuery input output) = _ + rw [encodingExhaustionPotential_cacheQuery_of_not_mem _ cache input output (by simp)] + simp [encodingExhaustionWeight] + +theorem expected_encodingExhaustionPotential_fresh + (inputs : Finset HashInput) (cache : QueryCache HashSpec) (input : HashInput) + (hfresh : cache input = none) : + (∑' output : HashOutput, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingExhaustionPotential inputs (cache.cacheQuery input output)) = encodingExhaustionPotential inputs cache := by + by_cases hmem : input ∈ inputs + · simp_rw [encodingExhaustionPotential_cacheQuery_of_mem inputs cache input _ hmem, ← mul_assoc] + rw [ENNReal.tsum_mul_right] + have hprob : (∑' output : HashOutput, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if TargetSum.ValidDigest (truncateHash output) then 0 else 1)) = encodingInvalidProbability := by + rw [encodingInvalidProbability, probEvent_eq_tsum_ite] + apply tsum_congr + intro output + by_cases hvalid : TargetSum.ValidDigest (truncateHash output) <;> simp [hvalid] + rw [hprob] + change encodingInvalidProbability * (∏ other ∈ inputs.erase input, encodingExhaustionWeight cache other) = + ∏ other ∈ inputs, encodingExhaustionWeight cache other + rw [← Finset.mul_prod_erase inputs _ hmem] + simp only [encodingExhaustionWeight, hfresh] + · simp_rw [encodingExhaustionPotential_cacheQuery_of_not_mem inputs cache input _ hmem] + rw [ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul] + +theorem expected_encodingExhaustionPotential_query + (inputs : Finset HashInput) (cache : QueryCache HashSpec) (query : OracleWorld.Domain) : + (∑' result, Pr[= result | (romImpl query).run cache] * encodingExhaustionPotential inputs result.2) = + encodingExhaustionPotential inputs cache := by + cases query with + | inl n => + have hquery : (romImpl (.inl n)).run cache = + (fun answer => (answer, cache)) <$> (liftM (unifSpec.query n) : ProbComp _) := rfl + rw [hquery] + change (∑' result : Fin (n + 1) × QueryCache HashSpec, + Pr[= result | (fun answer : Fin (n + 1) => (answer, cache)) <$> + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))] * encodingExhaustionPotential inputs result.2) = _ + rw [tsum_probOutput_map_mul] + dsimp only + rw [ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul] + | inr input => + change (∑' result, Pr[= result | (randomOracle input).run cache] * encodingExhaustionPotential inputs result.2) = _ + by_cases hfresh : cache input = none + · rw [randomOracle, QueryImpl.withCaching_run_none _ hfresh, tsum_probOutput_map_mul] + exact expected_encodingExhaustionPotential_fresh inputs cache input hfresh + · obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hfresh + rw [randomOracle, QueryImpl.withCaching_run_some _ houtput] + simp + +theorem expected_encodingExhaustionPotential_run + (inputs : Finset HashInput) (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) : + (∑' result, Pr[= result | (simulateQ romImpl computation).run cache] * encodingExhaustionPotential inputs result.2) = + encodingExhaustionPotential inputs cache := by + induction computation using OracleComp.inductionOn generalizing cache with + | pure value => simp + | query_bind query next ih => + rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, tsum_probOutput_bind_mul] + simp_rw [ih] + exact expected_encodingExhaustionPotential_query inputs cache query + +theorem probEvent_encodingInputsExhausted_le + (inputs : Finset HashInput) (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) : + Pr[fun result => EncodingInputsExhausted inputs result.2 | (simulateQ romImpl computation).run cache] ≤ + encodingExhaustionPotential inputs cache := by + rw [← expected_encodingExhaustionPotential_run inputs computation cache, probEvent_eq_tsum_ite] + apply ENNReal.tsum_le_tsum + intro result + by_cases hexhausted : EncodingInputsExhausted inputs result.2 + · simp [hexhausted, encodingExhaustionPotential_eq_one_of_exhausted inputs result.2 hexhausted] + · simp [hexhausted] + +theorem probEvent_encodingInputsExhausted_empty_le_pow + (inputs : Finset HashInput) (computation : OracleComp OracleWorld α) : + Pr[fun result => EncodingInputsExhausted inputs result.2 | (simulateQ romImpl computation).run ∅] ≤ + (1 - (TargetSum.validDigests.card : ℝ≥0∞) / (Fintype.card Digest : ℝ≥0∞)) ^ inputs.card := by + have hbound := probEvent_encodingInputsExhausted_le inputs computation ∅ + rw [encodingExhaustionPotential_empty_cache, encodingInvalidProbability, probEvent_uniform_encoding_invalid] at hbound + exact hbound + +noncomputable def encodingRetryInputs (parameter : PublicParameter) (position : EncodingPosition) (message : Digest) : + Finset HashInput := + Finset.univ.image fun counter : Fin encodingAttemptLimit => encodingRetryInput parameter position message counter.val + +theorem encodingRetryInputs_card (parameter : PublicParameter) (position : EncodingPosition) (message : Digest) : + (encodingRetryInputs parameter position message).card = encodingAttemptLimit := by + have hinjective : Function.Injective (fun counter : Fin encodingAttemptLimit => + encodingRetryInput parameter position message counter.val) := by + intro left right heq + exact Fin.ext (encodingRetryInput_injective_of_lt left.isLt right.isLt heq) + rw [encodingRetryInputs, Finset.card_image_of_injective _ hinjective, Finset.card_univ, Fintype.card_fin] + +def AnyEncodingInputsExhausted (cache : QueryCache HashSpec) : Prop := + ∃ parameter position message, EncodingInputsExhausted (encodingRetryInputs parameter position message) cache + +theorem probEvent_anyEncodingInputsExhausted_le + (computation : OracleComp OracleWorld α) : + Pr[fun result => AnyEncodingInputsExhausted result.2 | (simulateQ romImpl computation).run ∅] ≤ + ((3 * 2 ^ 294 : Nat) : ℝ≥0∞) * + (1 - (TargetSum.validDigests.card : ℝ≥0∞) / (Fintype.card Digest : ℝ≥0∞)) ^ encodingAttemptLimit := by + let family := PublicParameter × EncodingPosition × Digest + let run := (simulateQ romImpl computation).run ∅ + let event := fun choice : family => fun result : α × QueryCache HashSpec => + EncodingInputsExhausted (encodingRetryInputs choice.1 choice.2.1 choice.2.2) result.2 + have hunion := probEvent_exists_finset_le_sum (Finset.univ : Finset family) run event + have hleft : (fun result : α × QueryCache HashSpec => ∃ choice ∈ (Finset.univ : Finset family), event choice result) = + (fun result => AnyEncodingInputsExhausted result.2) := by + funext result + apply propext + simp only [Finset.mem_univ, true_and, event, AnyEncodingInputsExhausted] + constructor + · rintro ⟨choice, hchoice⟩ + exact ⟨choice.1, choice.2.1, choice.2.2, hchoice⟩ + · rintro ⟨parameter, position, message, hchoice⟩ + exact ⟨(parameter, position, message), hchoice⟩ + rw [hleft] at hunion + apply hunion.trans + calc + _ ≤ ∑ _choice : family, + (1 - (TargetSum.validDigests.card : ℝ≥0∞) / (Fintype.card Digest : ℝ≥0∞)) ^ encodingAttemptLimit := by + apply Finset.sum_le_sum + intro choice _ + have hbound := probEvent_encodingInputsExhausted_empty_le_pow + (encodingRetryInputs choice.1 choice.2.1 choice.2.2) computation + rw [encodingRetryInputs_card] at hbound + exact hbound + _ = _ := by + have hcard : Fintype.card family = 3 * 2 ^ 294 := by + have hposition : Fintype.card EncodingPosition = Fintype.card (Layer × TreeIndex × LeafIndex) := + Fintype.card_congr + { toFun := fun position => (position.lay, position.tree, position.leafIdx) + invFun := fun fields => ⟨fields.1, fields.2.1, fields.2.2⟩ + left_inv := fun _ => rfl + right_inv := fun _ => rfl } + change Fintype.card (PublicParameter × EncodingPosition × Digest) = _ + rw [Fintype.card_prod, Fintype.card_prod, hposition] + norm_num [publicParameterBits, digestBits, numLayers, totalHeight, maxLayerHeight] + rw [Finset.sum_const, Finset.card_univ, hcard, nsmul_eq_mul] + +theorem otsSignFrom_none_cached_invalid + (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (secret : ChainIndex → Digest) (message : Digest) (attempts counter : Nat) + (hagrees : cache.AgreesWithFn f) + (hrun : CachedRun cache f (otsSignFrom parameter lay tree leafIdx secret message attempts counter)) + (hfailed : evalWithAnswerFn f (otsSignFrom parameter lay tree leafIdx secret message attempts counter) = none) + (candidate : Nat) (hlower : counter ≤ candidate) (hupper : candidate < counter + attempts) : + ∃ output, cache (encodingRetryInput parameter ⟨lay, tree, leafIdx⟩ message candidate) = some output ∧ + ¬TargetSum.ValidDigest (truncateHash output) := by + induction attempts generalizing counter with + | zero => omega + | succ attempts ih => + rw [otsSignFrom, evalWithAnswerFn_bind] at hfailed + rw [otsSignFrom] at hrun + cases hencode : evalWithAnswerFn f (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) with + | some encoding => + simp [hencode] at hfailed + | none => + simp only [hencode] at hfailed + by_cases heq : candidate = counter + · subst candidate + obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp (CachedRun.encode_cached hrun.bind_left) + refine ⟨output, houtput, ?_⟩ + intro hvalid + have hvalid' : TargetSum.ValidDigest (truncateHash (f (tweakableHashInput parameter + (.encoding lay tree leafIdx) (digestBytes message ++ counterBytes (BitVec.ofNat counterBits counter))))) := by + rw [hagrees houtput] + exact hvalid + exact ((eval_encode_ne_none_iff_validDigest f parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter)).mpr hvalid') hencode + · apply ih (counter + 1) _ hfailed (by omega) (by omega) + have htail := hrun.bind_right + simpa only [hencode] using htail + +theorem encodingInputsExhausted_of_otsSign_none + (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (secret : ChainIndex → Digest) (message : Digest) + (hagrees : cache.AgreesWithFn f) + (hrun : CachedRun cache f (otsSign parameter lay tree leafIdx secret message)) + (hfailed : evalWithAnswerFn f (otsSign parameter lay tree leafIdx secret message) = none) : + EncodingInputsExhausted (encodingRetryInputs parameter ⟨lay, tree, leafIdx⟩ message) cache := by + intro input hinput + obtain ⟨candidate, _hmem, rfl⟩ := Finset.mem_image.mp hinput + exact otsSignFrom_none_cached_invalid f cache parameter lay tree leafIdx secret message encodingAttemptLimit 0 + hagrees hrun hfailed candidate.val (Nat.zero_le _) (by simp) + +def CachedOtsEncodingFailure (cache : QueryCache HashSpec) : Prop := + ∃ (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (position : EncodingPosition) + (secret : ChainIndex → Digest) (message : Digest), + cache.AgreesWithFn f ∧ CachedRun cache f (otsSign parameter position.lay position.tree position.leafIdx secret message) ∧ + evalWithAnswerFn f (otsSign parameter position.lay position.tree position.leafIdx secret message) = none + +theorem anyEncodingInputsExhausted_of_cachedOtsEncodingFailure + (cache : QueryCache HashSpec) (hfailed : CachedOtsEncodingFailure cache) : AnyEncodingInputsExhausted cache := by + obtain ⟨f, parameter, position, secret, message, hagrees, hrun, hfailed⟩ := hfailed + exact ⟨parameter, position, message, encodingInputsExhausted_of_otsSign_none f cache parameter position.lay position.tree + position.leafIdx secret message hagrees hrun hfailed⟩ + +theorem probEvent_cachedOtsEncodingFailure_le + (computation : OracleComp OracleWorld α) : + Pr[fun result => CachedOtsEncodingFailure result.2 | (simulateQ romImpl computation).run ∅] ≤ + ((3 * 2 ^ 294 : Nat) : ℝ≥0∞) * + (1 - (TargetSum.validDigests.card : ℝ≥0∞) / (Fintype.card Digest : ℝ≥0∞)) ^ encodingAttemptLimit := + (probEvent_mono fun result _ hfailed => anyEncodingInputsExhausted_of_cachedOtsEncodingFailure result.2 hfailed).trans + (probEvent_anyEncodingInputsExhausted_le computation) + +theorem EncodingInputsExhausted.mono + {inputs : Finset HashInput} {before after : QueryCache HashSpec} + (hexhausted : EncodingInputsExhausted inputs before) (hle : before ≤ after) : + EncodingInputsExhausted inputs after := by + intro input hinput + obtain ⟨output, houtput, hinvalid⟩ := hexhausted input hinput + exact ⟨output, hle houtput, hinvalid⟩ + +theorem AnyEncodingInputsExhausted.mono + {before after : QueryCache HashSpec} (hexhausted : AnyEncodingInputsExhausted before) (hle : before ≤ after) : + AnyEncodingInputsExhausted after := by + obtain ⟨parameter, position, message, hexhausted⟩ := hexhausted + exact ⟨parameter, position, message, hexhausted.mono hle⟩ + +theorem anyEncodingInputsExhausted_of_earlier_cachedOtsEncodingFailure + {before after : QueryCache HashSpec} (hfailed : CachedOtsEncodingFailure before) (hle : before ≤ after) : + AnyEncodingInputsExhausted after := + (anyEncodingInputsExhausted_of_cachedOtsEncodingFailure before hfailed).mono hle + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingLatent.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingLatent.lean new file mode 100644 index 00000000..d386cbcc --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingLatent.lean @@ -0,0 +1,1009 @@ +import SphincsSecurity.Proof.EncodingRetryCharge + +/-! +# Latent encoding collisions + +A fully cached encoding search can become canonical when a missing earlier retry receives an +inadmissible answer. The collision itself is older: its target is already the least admissible +cached counter for the settled layer message. This cache event records that older witness without +requiring every smaller counter to be cached. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +set_option maxRecDepth 100000 + +def EncodingMessageSettledAt (cache : QueryCache HashSpec) (secretKey : SecretKey) + (position : EncodingPosition) : Prop := + ∃ index : Index, + treeIndexAt index position.lay = position.tree + ∧ leafIndexAt index position.lay = position.leafIdx + ∧ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (layerMessagePosition index position.lay) + +theorem EncodingMessageSettledAt.mono {cache cache' : QueryCache HashSpec} + {secretKey : SecretKey} {position : EncodingPosition} (hle : cache ≤ cache') + (hsettled : EncodingMessageSettledAt cache secretKey position) : + EncodingMessageSettledAt cache' secretKey position := by + obtain ⟨index, htree, hleaf, hposition⟩ := hsettled + exact ⟨index, htree, hleaf, hposition.mono hle⟩ + +def LatentEncodingBadAt (cache : QueryCache HashSpec) (secretKey : SecretKey) + (position : EncodingPosition) : Prop := + ∃ (index : Index) (counter : Counter) + (targetPayload otherPayload : HashInput) (targetAnswer otherAnswer : HashOutput), + treeIndexAt index position.lay = position.tree + ∧ leafIndexAt index position.lay = position.leafIdx + ∧ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (layerMessagePosition index position.lay) + ∧ targetPayload = digestBytes (honestValue (fromCache cache) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index position.lay)) ++ counterBytes counter + ∧ cache (tweakableHashInput secretKey.parameter position.domain targetPayload) = + some targetAnswer + ∧ TargetSum.ValidDigest (truncateHash targetAnswer) + ∧ (∀ candidate : Counter, candidate.toNat < counter.toNat → + ∀ answer : HashOutput, + cache (tweakableHashInput secretKey.parameter position.domain + (digestBytes (honestValue (fromCache cache) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index position.lay)) ++ counterBytes candidate)) = + some answer → + ¬ TargetSum.ValidDigest (truncateHash answer)) + ∧ targetPayload ≠ otherPayload + ∧ cache (tweakableHashInput secretKey.parameter position.domain otherPayload) = + some otherAnswer + ∧ truncateHash targetAnswer = truncateHash otherAnswer + +def LatentEncodingBad (cache : QueryCache HashSpec) (secretKey : SecretKey) : Prop := + ∃ position, LatentEncodingBadAt cache secretKey position + +theorem encodingAnswerTargets_card_le_encodingPotential + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {position : EncodingPosition} + (hnotTarget : ¬ HasEncodingTarget cache secretKey position) : + (encodingAnswerTargets secretKey.parameter cache hfinite position).card ≤ + encodingPotential cache secretKey := by + calc + (encodingAnswerTargets secretKey.parameter cache hfinite position).card ≤ + (encodingCachedAt secretKey.parameter cache position).ncard := + encodingAnswerTargets_card_le hfinite position + _ = encodingContribution cache secretKey position := by + rw [encodingContribution, if_neg hnotTarget] + _ ≤ ∑ candidate : EncodingPosition, + encodingContribution cache secretKey candidate := by + rw [Fintype.sum_eq_add_sum_subtype_ne _ position] + exact Nat.le_add_right _ _ + _ = encodingPotential cache secretKey := rfl + +theorem encodingMessageTargets_card_le_encodingPotential + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {position : EncodingPosition} + (hnotTarget : ¬ HasEncodingTarget cache secretKey position) : + (encodingMessageTargets secretKey.parameter cache hfinite position).card ≤ + encodingPotential cache secretKey := by + calc + (encodingMessageTargets secretKey.parameter cache hfinite position).card ≤ + (encodingCachedAt secretKey.parameter cache position).ncard := + encodingMessageTargets_card_le hfinite position + _ = encodingContribution cache secretKey position := by + rw [encodingContribution, if_neg hnotTarget] + _ ≤ ∑ candidate : EncodingPosition, + encodingContribution cache secretKey candidate := by + rw [Fintype.sum_eq_add_sum_subtype_ne _ position] + exact Nat.le_add_right _ _ + _ = encodingPotential cache secretKey := rfl + +theorem EncodingBad.latent_with_target + {cache : QueryCache HashSpec} {secretKey : SecretKey} + (hbad : EncodingBad cache secretKey) : + ∃ position : EncodingPosition, + HasEncodingTarget cache secretKey position ∧ + LatentEncodingBadAt cache secretKey position := by + obtain ⟨lay, tree, leafIdx, targetPayload, otherPayload, targetAnswer, otherAnswer, + htarget, hpayloadNe, htargetAnswer, hotherAnswer, hcollision⟩ := hbad + have htargetData := htarget + obtain ⟨index, counter, htree, hleaf, hsettled, _hrun, heval, hpayload, + _htargetCached⟩ := htargetData + let position : EncodingPosition := ⟨lay, tree, leafIdx⟩ + have hselected := encodingSearch_selected_encode_ne_none (fromCache cache) + secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (layerMessagePosition index lay)) counter heval + have hvalid := (eval_encode_ne_none_iff_validDigest (fromCache cache) + secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (layerMessagePosition index lay)) counter).mp hselected + refine ⟨position, ⟨targetPayload, htarget⟩, index, counter, targetPayload, + otherPayload, targetAnswer, otherAnswer, htree, hleaf, hsettled, hpayload, + ?_, ?_, ?_, hpayloadNe, ?_, hcollision⟩ + · simpa only [position, EncodingPosition.domain] using htargetAnswer + · have hfromCache : fromCache cache + (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + targetPayload) = + targetAnswer := by + simp [fromCache, htargetAnswer] + rw [htree, hleaf, ← hpayload] at hvalid + rwa [hfromCache] at hvalid + · intro candidate hcandidate answer hanswer + have hrejected := encodingSearch_rejected_before (fromCache cache) + secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (layerMessagePosition index lay)) counter candidate heval + hcandidate + have hinvalid : ¬ TargetSum.ValidDigest (truncateHash (fromCache cache + (tweakableHashInput secretKey.parameter + (.encoding lay (treeIndexAt index lay) (leafIndexAt index lay)) + (digestBytes (honestValue (fromCache cache) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index lay)) ++ counterBytes candidate)))) := by + intro hvalidCandidate + exact ((eval_encode_ne_none_iff_validDigest (fromCache cache) + secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (layerMessagePosition index lay)) candidate).mpr + hvalidCandidate) hrejected + have hfromCache : fromCache cache + (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes (honestValue (fromCache cache) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index lay)) ++ counterBytes candidate)) = + answer := by + have hanswer' : cache (tweakableHashInput secretKey.parameter + (.encoding lay tree leafIdx) + (digestBytes (honestValue (fromCache cache) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index lay)) ++ counterBytes candidate)) = + some answer := by + simpa only [position, EncodingPosition.domain] using hanswer + simp [fromCache, hanswer'] + rw [htree, hleaf] at hinvalid + rwa [hfromCache] at hinvalid + · simpa only [position, EncodingPosition.domain] using hotherAnswer + +theorem EncodingBad.latent {cache : QueryCache HashSpec} {secretKey : SecretKey} + (hbad : EncodingBad cache secretKey) : LatentEncodingBad cache secretKey := by + obtain ⟨position, htarget, hlatent⟩ := hbad.latent_with_target + exact ⟨position, hlatent⟩ + +theorem LatentEncodingBadAt.encodingBad_of_hasTarget + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {position : EncodingPosition} + (hlatent : LatentEncodingBadAt cache secretKey position) + (htarget : HasEncodingTarget cache secretKey position) : + EncodingBad cache secretKey := by + obtain ⟨index, counter, targetPayload, otherPayload, targetAnswer, otherAnswer, + htree, hleaf, hsettled, hpayload, htargetAnswer, htargetValid, hbefore, + hpayloadNe, hotherAnswer, hcollision⟩ := hlatent + obtain ⟨signedPayload, hsigned⟩ := htarget + have hsignedData := hsigned + obtain ⟨_, _, _, _, _, _, _, _, signedCached⟩ := hsignedData + obtain ⟨signedAnswer, hsignedAnswer⟩ := + Option.ne_none_iff_exists'.mp signedCached + obtain ⟨signedIndex, signedCounter, signedTree, signedLeaf, signedPayloadEq, + signedValid, signedBefore⟩ := hsigned.target_least_valid + have hmessagePosition : layerMessagePosition index position.lay = + layerMessagePosition signedIndex position.lay := + layerMessagePosition_eq_of_position_eq index signedIndex position.lay + (htree.trans signedTree.symm) (hleaf.trans signedLeaf.symm) + have htargetFromCache : fromCache cache + (tweakableHashInput secretKey.parameter position.domain targetPayload) = + targetAnswer := by + simp [fromCache, htargetAnswer] + have hsignedFromCache : fromCache cache + (tweakableHashInput secretKey.parameter + (.encoding position.lay position.tree position.leafIdx) signedPayload) = + signedAnswer := by + simp only [fromCache, hsignedAnswer, Option.getD_some] + have hcounter : counter = signedCounter := by + apply BitVec.eq_of_toNat_eq + by_contra hne + have hcases : counter.toNat < signedCounter.toNat ∨ + signedCounter.toNat < counter.toNat := by omega + rcases hcases with hcounterLt | hsignedLt + · apply signedBefore counter hcounterLt + have hvalid := htargetValid + rw [← htargetFromCache] at hvalid + rw [hpayload, hmessagePosition, EncodingPosition.domain, ← signedTree, + ← signedLeaf] at hvalid + exact hvalid + · have hsignedCachedAtLatent : cache + (tweakableHashInput secretKey.parameter position.domain + (digestBytes (honestValue (fromCache cache) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index position.lay)) ++ + counterBytes signedCounter)) = some signedAnswer := by + rw [hmessagePosition, ← signedPayloadEq] + simpa only [EncodingPosition.domain] using hsignedAnswer + have hinvalid := hbefore signedCounter hsignedLt signedAnswer + hsignedCachedAtLatent + apply hinvalid + rw [hsignedFromCache] at signedValid + exact signedValid + have hpayloadEq : targetPayload = signedPayload := by + rw [hpayload, signedPayloadEq, hmessagePosition, hcounter] + rw [hpayloadEq] at hpayloadNe htargetAnswer + exact ⟨position.lay, position.tree, position.leafIdx, signedPayload, + otherPayload, targetAnswer, otherAnswer, hsigned, hpayloadNe, + by simpa only [EncodingPosition.domain] using htargetAnswer, + by simpa only [EncodingPosition.domain] using hotherAnswer, hcollision⟩ + +theorem LatentEncodingBad.of_cacheQuery_of_invalid_encoding + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} {queriedPosition : EncodingPosition} + (huncached : cache input = none) + (hqueried : AtEncodingPosition secretKey.parameter input queriedPosition) + (hinvalid : ¬ TargetSum.ValidDigest (truncateHash answer)) + (hbad : LatentEncodingBad (cache.cacheQuery input answer) secretKey) : + LatentEncodingBad cache secretKey := by + obtain ⟨position, index, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htree, hleaf, hsettledAfter, hpayload, htargetAnswer, + htargetValid, hbefore, hpayloadNe, hotherAnswer, hcollision⟩ := hbad + have hle := le_cacheQuery (cache := cache) (input := input) (answer := answer) huncached + have hsettled : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (layerMessagePosition index position.lay) := by + exact settled_of_settled_cacheQuery secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret huncached (p₀ := none) + (fun structuralPosition hposition => + absurd hposition (hqueried.not_atPosition structuralPosition)) + (by simp) ((layerMessagePosition index position.lay).depth + 1) + (layerMessagePosition index position.lay) (by omega) (by simp) hsettledAfter + have hmessage := honestValue_eq_of_settled + (agreesWithFn_fromCache_of_le hle) hsettled + have htargetInputNe : + tweakableHashInput secretKey.parameter position.domain targetPayload ≠ input := by + intro heq + have hanswerEq : targetAnswer = answer := by + rw [heq, QueryCache.cacheQuery_self] at htargetAnswer + exact Option.some.inj htargetAnswer.symm + exact hinvalid (hanswerEq ▸ htargetValid) + have hotherValid : TargetSum.ValidDigest (truncateHash otherAnswer) := by + rwa [← hcollision] + have hotherInputNe : + tweakableHashInput secretKey.parameter position.domain otherPayload ≠ input := by + intro heq + have hanswerEq : otherAnswer = answer := by + rw [heq, QueryCache.cacheQuery_self] at hotherAnswer + exact Option.some.inj hotherAnswer.symm + exact hinvalid (hanswerEq ▸ hotherValid) + have htargetOld : cache + (tweakableHashInput secretKey.parameter position.domain targetPayload) = + some targetAnswer := by + rwa [QueryCache.cacheQuery_of_ne _ _ htargetInputNe] at htargetAnswer + have hotherOld : cache + (tweakableHashInput secretKey.parameter position.domain otherPayload) = + some otherAnswer := by + rwa [QueryCache.cacheQuery_of_ne _ _ hotherInputNe] at hotherAnswer + refine ⟨position, index, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htree, hleaf, hsettled, ?_, htargetOld, htargetValid, ?_, + hpayloadNe, hotherOld, hcollision⟩ + · rw [hmessage] at hpayload + exact hpayload + · intro candidate hcandidate candidateAnswer hcandidateAnswer + have hcandidateInputNe : tweakableHashInput secretKey.parameter position.domain + (digestBytes (honestValue (fromCache cache) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index position.lay)) ++ counterBytes candidate) ≠ input := by + intro heq + rw [heq, huncached] at hcandidateAnswer + simp at hcandidateAnswer + have hcandidateAfter : (cache.cacheQuery input answer) + (tweakableHashInput secretKey.parameter position.domain + (digestBytes (honestValue (fromCache (cache.cacheQuery input answer)) + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index position.lay)) ++ counterBytes candidate)) = + some candidateAnswer := by + rw [hmessage] + rwa [QueryCache.cacheQuery_of_ne _ _ hcandidateInputNe] + exact hbefore candidate hcandidate candidateAnswer hcandidateAfter + +theorem latentEncodingBad_of_encodingBad_cacheQuery_of_invalid_encoding + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} {queriedPosition : EncodingPosition} + (huncached : cache input = none) + (hqueried : AtEncodingPosition secretKey.parameter input queriedPosition) + (hinvalid : ¬ TargetSum.ValidDigest (truncateHash answer)) + (hbad : EncodingBad (cache.cacheQuery input answer) secretKey) : + LatentEncodingBad cache secretKey := + hbad.latent.of_cacheQuery_of_invalid_encoding huncached hqueried hinvalid + +theorem not_latentEncodingBad_empty (secretKey : SecretKey) : + ¬ LatentEncodingBad ∅ secretKey := by + rintro ⟨position, index, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htree, hleaf, hsettled, hpayload, htargetAnswer, hrest⟩ + simp at htargetAnswer + +theorem not_latentEncodingBad_of_encoding_none + {cache : QueryCache HashSpec} {secretKey : SecretKey} + (hnone : ∀ (position : EncodingPosition) (payload : HashInput), + cache (tweakableHashInput secretKey.parameter position.domain payload) = none) : + ¬ LatentEncodingBad cache secretKey := by + rintro ⟨position, index, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htree, hleaf, hsettled, hpayload, htargetAnswer, hrest⟩ + rw [hnone position targetPayload] at htargetAnswer + simp at htargetAnswer + +inductive LatentEncodingFreshOrientation + (cache : QueryCache HashSpec) (secretKey : SecretKey) + (input : HashInput) (answer : HashOutput) (position : EncodingPosition) : Prop where + | targetFresh (targetPayload otherPayload : HashInput) + (targetAnswer otherAnswer : HashOutput) + (payloadNe : targetPayload ≠ otherPayload) + (collision : truncateHash targetAnswer = truncateHash otherAnswer) + (targetInput : tweakableHashInput secretKey.parameter position.domain targetPayload = input) + (targetAnswerEq : targetAnswer = answer) + (otherCached : cache + (tweakableHashInput secretKey.parameter position.domain otherPayload) = some otherAnswer) + | otherFresh (targetPayload otherPayload : HashInput) + (targetAnswer otherAnswer : HashOutput) + (payloadNe : targetPayload ≠ otherPayload) + (collision : truncateHash targetAnswer = truncateHash otherAnswer) + (targetCached : cache + (tweakableHashInput secretKey.parameter position.domain targetPayload) = some targetAnswer) + (otherInput : tweakableHashInput secretKey.parameter position.domain otherPayload = input) + (otherAnswerEq : otherAnswer = answer) + +theorem latentEncodingBadAt_fresh_orientation + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} {position : EncodingPosition} + (hclean : ¬ LatentEncodingBadAt cache secretKey position) + (huncached : cache input = none) + (hqueried : AtEncodingPosition secretKey.parameter input position) + (hbad : LatentEncodingBadAt + (cache.cacheQuery input answer) secretKey position) : + LatentEncodingFreshOrientation cache secretKey input answer position := by + obtain ⟨index, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htree, hleaf, hsettledAfter, hpayload, htargetAnswer, + htargetValid, hbefore, hpayloadNe, hotherAnswer, hcollision⟩ := hbad + let targetInput := tweakableHashInput secretKey.parameter position.domain targetPayload + let otherInput := tweakableHashInput secretKey.parameter position.domain otherPayload + by_cases htargetQuery : targetInput = input + · have htargetAnswerEq : targetAnswer = answer := by + have htargetQuery' : tweakableHashInput secretKey.parameter position.domain + targetPayload = input := by simpa only [targetInput] using htargetQuery + rw [htargetQuery', QueryCache.cacheQuery_self] at htargetAnswer + exact Option.some.inj htargetAnswer.symm + have hotherQuery : otherInput ≠ input := by + intro heq + apply hpayloadNe + exact (tweakableHashInput_injective secretKey.parameter (by trivial) (by trivial) + (htargetQuery.trans heq.symm)).2 + have hotherOld : cache otherInput = some otherAnswer := by + rwa [QueryCache.cacheQuery_of_ne _ _ hotherQuery] at hotherAnswer + exact .targetFresh targetPayload otherPayload targetAnswer otherAnswer + hpayloadNe hcollision htargetQuery htargetAnswerEq hotherOld + · by_cases hotherQuery : otherInput = input + · have hotherAnswerEq : otherAnswer = answer := by + have hotherQuery' : tweakableHashInput secretKey.parameter position.domain + otherPayload = input := by simpa only [otherInput] using hotherQuery + rw [hotherQuery', QueryCache.cacheQuery_self] at hotherAnswer + exact Option.some.inj hotherAnswer.symm + have htargetOld : cache targetInput = some targetAnswer := by + rwa [QueryCache.cacheQuery_of_ne _ _ htargetQuery] at htargetAnswer + exact .otherFresh targetPayload otherPayload targetAnswer otherAnswer + hpayloadNe hcollision htargetOld hotherQuery hotherAnswerEq + · exfalso + apply hclean + have hle := le_cacheQuery (cache := cache) (input := input) (answer := answer) + huncached + have hsettled : Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache (layerMessagePosition index position.lay) := by + exact settled_of_settled_cacheQuery secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret huncached (p₀ := none) + (fun structuralPosition hposition => + absurd hposition (hqueried.not_atPosition structuralPosition)) + (by simp) ((layerMessagePosition index position.lay).depth + 1) + (layerMessagePosition index position.lay) (by omega) (by simp) hsettledAfter + have hmessage := honestValue_eq_of_settled + (agreesWithFn_fromCache_of_le hle) hsettled + have htargetOld : cache targetInput = some targetAnswer := by + rwa [QueryCache.cacheQuery_of_ne _ _ htargetQuery] at htargetAnswer + have hotherOld : cache otherInput = some otherAnswer := by + rwa [QueryCache.cacheQuery_of_ne _ _ hotherQuery] at hotherAnswer + refine ⟨index, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htree, hleaf, hsettled, ?_, htargetOld, htargetValid, ?_, + hpayloadNe, hotherOld, hcollision⟩ + · rw [hmessage] at hpayload + exact hpayload + · intro candidate hcandidate candidateAnswer hcandidateAnswer + have hcandidateInputNe : tweakableHashInput secretKey.parameter position.domain + (digestBytes (honestValue (fromCache cache) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index position.lay)) ++ counterBytes candidate) ≠ input := by + intro heq + rw [heq, huncached] at hcandidateAnswer + simp at hcandidateAnswer + have hcandidateAfter : (cache.cacheQuery input answer) + (tweakableHashInput secretKey.parameter position.domain + (digestBytes (honestValue (fromCache (cache.cacheQuery input answer)) + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index position.lay)) ++ counterBytes candidate)) = + some candidateAnswer := by + rw [hmessage] + rwa [QueryCache.cacheQuery_of_ne _ _ hcandidateInputNe] + exact hbefore candidate hcandidate candidateAnswer hcandidateAfter + +theorem latentEncodingBad_answer_hit_of_encoding_query + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {queriedPosition : EncodingPosition} + (hclean : ¬ LatentEncodingBad cache secretKey) + (huncached : cache input = none) + (hqueried : AtEncodingPosition secretKey.parameter input queriedPosition) + (hbad : LatentEncodingBad (cache.cacheQuery input answer) secretKey) : + truncateHash answer ∈ + encodingAnswerTargets secretKey.parameter cache hfinite queriedPosition := by + obtain ⟨position, index, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htree, hleaf, hsettledAfter, hpayload, htargetAnswer, + htargetValid, hbefore, hpayloadNe, hotherAnswer, hcollision⟩ := hbad + let targetInput := tweakableHashInput secretKey.parameter position.domain targetPayload + let otherInput := tweakableHashInput secretKey.parameter position.domain otherPayload + have htargetAt : AtEncodingPosition secretKey.parameter targetInput position := + ⟨targetPayload, rfl⟩ + have hotherAt : AtEncodingPosition secretKey.parameter otherInput position := + ⟨otherPayload, rfl⟩ + by_cases htargetQuery : targetInput = input + · have hposition : position = queriedPosition := + atEncodingPosition_unique htargetAt (htargetQuery ▸ hqueried) + subst position + have htargetAnswerEq : targetAnswer = answer := by + have htargetQuery' : tweakableHashInput secretKey.parameter queriedPosition.domain + targetPayload = input := by + simpa only [targetInput] using htargetQuery + rw [htargetQuery', QueryCache.cacheQuery_self] at htargetAnswer + exact Option.some.inj htargetAnswer.symm + have hotherQuery : otherInput ≠ input := by + intro heq + apply hpayloadNe + exact (tweakableHashInput_injective secretKey.parameter (by trivial) (by trivial) + (htargetQuery.trans heq.symm)).2 + have hotherOld : cache otherInput = some otherAnswer := by + rwa [QueryCache.cacheQuery_of_ne _ _ hotherQuery] at hotherAnswer + have hmem := cachedAnswer_mem_encodingAnswerTargets hfinite hotherOld hotherAt + rwa [← hcollision, htargetAnswerEq] at hmem + · by_cases hotherQuery : otherInput = input + · have hposition : position = queriedPosition := + atEncodingPosition_unique hotherAt (hotherQuery ▸ hqueried) + subst position + have hotherAnswerEq : otherAnswer = answer := by + have hotherQuery' : tweakableHashInput secretKey.parameter queriedPosition.domain + otherPayload = input := by + simpa only [otherInput] using hotherQuery + rw [hotherQuery', QueryCache.cacheQuery_self] at hotherAnswer + exact Option.some.inj hotherAnswer.symm + have htargetOld : cache targetInput = some targetAnswer := by + rwa [QueryCache.cacheQuery_of_ne _ _ htargetQuery] at htargetAnswer + have hmem := cachedAnswer_mem_encodingAnswerTargets hfinite htargetOld htargetAt + rwa [hcollision, hotherAnswerEq] at hmem + · exfalso + apply hclean + have hle := le_cacheQuery (cache := cache) (input := input) (answer := answer) + huncached + have hsettled : Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache (layerMessagePosition index position.lay) := by + exact settled_of_settled_cacheQuery secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret huncached (p₀ := none) + (fun structuralPosition hposition => + absurd hposition (hqueried.not_atPosition structuralPosition)) + (by simp) ((layerMessagePosition index position.lay).depth + 1) + (layerMessagePosition index position.lay) (by omega) (by simp) hsettledAfter + have hmessage := honestValue_eq_of_settled + (agreesWithFn_fromCache_of_le hle) hsettled + have htargetOld : cache targetInput = some targetAnswer := by + rwa [QueryCache.cacheQuery_of_ne _ _ htargetQuery] at htargetAnswer + have hotherOld : cache otherInput = some otherAnswer := by + rwa [QueryCache.cacheQuery_of_ne _ _ hotherQuery] at hotherAnswer + refine ⟨position, index, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htree, hleaf, hsettled, ?_, htargetOld, htargetValid, ?_, + hpayloadNe, hotherOld, hcollision⟩ + · rw [hmessage] at hpayload + exact hpayload + · intro candidate hcandidate candidateAnswer hcandidateAnswer + have hcandidateInputNe : tweakableHashInput secretKey.parameter position.domain + (digestBytes (honestValue (fromCache cache) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index position.lay)) ++ counterBytes candidate) ≠ input := by + intro heq + rw [heq, huncached] at hcandidateAnswer + simp at hcandidateAnswer + have hcandidateAfter : (cache.cacheQuery input answer) + (tweakableHashInput secretKey.parameter position.domain + (digestBytes (honestValue (fromCache (cache.cacheQuery input answer)) + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index position.lay)) ++ counterBytes candidate)) = + some candidateAnswer := by + rw [hmessage] + rwa [QueryCache.cacheQuery_of_ne _ _ hcandidateInputNe] + exact hbefore candidate hcandidate candidateAnswer hcandidateAfter + +theorem latentEncodingBad_validAnswer_hit_of_encoding_query + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {queriedPosition : EncodingPosition} + (hclean : ¬ LatentEncodingBad cache secretKey) + (huncached : cache input = none) + (hqueried : AtEncodingPosition secretKey.parameter input queriedPosition) + (hbad : LatentEncodingBad (cache.cacheQuery input answer) secretKey) : + truncateHash answer ∈ + encodingValidAnswerTargets secretKey.parameter cache hfinite queriedPosition := by + have hhit := latentEncodingBad_answer_hit_of_encoding_query hfinite hclean huncached + hqueried hbad + have hvalid : TargetSum.ValidDigest (truncateHash answer) := by + by_contra hinvalid + exact hclean (hbad.of_cacheQuery_of_invalid_encoding huncached hqueried hinvalid) + exact Finset.mem_filter.mpr ⟨hhit, hvalid⟩ + +theorem latentEncodingBadAt_answer_hit_of_encoding_query + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} + (hclean : ¬ LatentEncodingBadAt cache secretKey position) + (huncached : cache input = none) + (hqueried : AtEncodingPosition secretKey.parameter input position) + (hbad : LatentEncodingBadAt (cache.cacheQuery input answer) secretKey position) : + truncateHash answer ∈ + encodingValidAnswerTargets secretKey.parameter cache hfinite position := by + obtain ⟨index, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htree, hleaf, hsettledAfter, hpayload, htargetAnswer, + htargetValid, hbefore, hpayloadNe, hotherAnswer, hcollision⟩ := hbad + let targetInput := tweakableHashInput secretKey.parameter position.domain targetPayload + let otherInput := tweakableHashInput secretKey.parameter position.domain otherPayload + have htargetAt : AtEncodingPosition secretKey.parameter targetInput position := + ⟨targetPayload, rfl⟩ + have hotherAt : AtEncodingPosition secretKey.parameter otherInput position := + ⟨otherPayload, rfl⟩ + have hhit : truncateHash answer ∈ + encodingAnswerTargets secretKey.parameter cache hfinite position + ∧ TargetSum.ValidDigest (truncateHash answer) := by + by_cases htargetQuery : targetInput = input + · have htargetAnswerEq : targetAnswer = answer := by + have htargetQuery' : tweakableHashInput secretKey.parameter position.domain + targetPayload = input := by simpa only [targetInput] using htargetQuery + rw [htargetQuery', QueryCache.cacheQuery_self] at htargetAnswer + exact Option.some.inj htargetAnswer.symm + have hotherQuery : otherInput ≠ input := by + intro heq + apply hpayloadNe + exact (tweakableHashInput_injective secretKey.parameter (by trivial) (by trivial) + (htargetQuery.trans heq.symm)).2 + have hotherOld : cache otherInput = some otherAnswer := by + rwa [QueryCache.cacheQuery_of_ne _ _ hotherQuery] at hotherAnswer + have hmem := cachedAnswer_mem_encodingAnswerTargets hfinite hotherOld hotherAt + constructor + · rwa [← hcollision, htargetAnswerEq] at hmem + · rwa [← htargetAnswerEq] + · by_cases hotherQuery : otherInput = input + · have hotherAnswerEq : otherAnswer = answer := by + have hotherQuery' : tweakableHashInput secretKey.parameter position.domain + otherPayload = input := by simpa only [otherInput] using hotherQuery + rw [hotherQuery', QueryCache.cacheQuery_self] at hotherAnswer + exact Option.some.inj hotherAnswer.symm + have htargetOld : cache targetInput = some targetAnswer := by + rwa [QueryCache.cacheQuery_of_ne _ _ htargetQuery] at htargetAnswer + have hmem := cachedAnswer_mem_encodingAnswerTargets hfinite htargetOld htargetAt + constructor + · rwa [hcollision, hotherAnswerEq] at hmem + · have hotherValid := htargetValid.of_eq hcollision + rwa [hotherAnswerEq] at hotherValid + · exfalso + apply hclean + have hle := le_cacheQuery (cache := cache) (input := input) (answer := answer) + huncached + have hsettled : Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache (layerMessagePosition index position.lay) := by + exact settled_of_settled_cacheQuery secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret huncached (p₀ := none) + (fun structuralPosition hposition => + absurd hposition (hqueried.not_atPosition structuralPosition)) + (by simp) ((layerMessagePosition index position.lay).depth + 1) + (layerMessagePosition index position.lay) (by omega) (by simp) hsettledAfter + have hmessage := honestValue_eq_of_settled + (agreesWithFn_fromCache_of_le hle) hsettled + have htargetOld : cache targetInput = some targetAnswer := by + rwa [QueryCache.cacheQuery_of_ne _ _ htargetQuery] at htargetAnswer + have hotherOld : cache otherInput = some otherAnswer := by + rwa [QueryCache.cacheQuery_of_ne _ _ hotherQuery] at hotherAnswer + refine ⟨index, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htree, hleaf, hsettled, ?_, htargetOld, htargetValid, ?_, + hpayloadNe, hotherOld, hcollision⟩ + · rw [hmessage] at hpayload + exact hpayload + · intro candidate hcandidate candidateAnswer hcandidateAnswer + have hcandidateInputNe : tweakableHashInput secretKey.parameter position.domain + (digestBytes (honestValue (fromCache cache) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index position.lay)) ++ counterBytes candidate) ≠ input := by + intro heq + rw [heq, huncached] at hcandidateAnswer + simp at hcandidateAnswer + have hcandidateAfter : (cache.cacheQuery input answer) + (tweakableHashInput secretKey.parameter position.domain + (digestBytes (honestValue (fromCache (cache.cacheQuery input answer)) + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index position.lay)) ++ counterBytes candidate)) = + some candidateAnswer := by + rw [hmessage] + rwa [QueryCache.cacheQuery_of_ne _ _ hcandidateInputNe] + exact hbefore candidate hcandidate candidateAnswer hcandidateAfter + exact Finset.mem_filter.mpr hhit + +theorem latentEncodingBadAt_message_hit_of_settling_query + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} {queryIndex : Index} + (huncached : cache input = none) + (htree : treeIndexAt queryIndex position.lay = position.tree) + (hleaf : leafIndexAt queryIndex position.lay = position.leafIdx) + (hposition : AtPosition secretKey.parameter input + (layerMessagePosition queryIndex position.lay)) + (hunsettled : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache (layerMessagePosition queryIndex position.lay)) + (hbad : LatentEncodingBadAt (cache.cacheQuery input answer) secretKey position) : + truncateHash answer ∈ + encodingMessageTargets secretKey.parameter cache hfinite position := by + obtain ⟨targetIndex, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htargetTree, htargetLeaf, hsettledAfter, hpayload, + htargetAnswer, htargetValid, hbefore, hpayloadNe, hotherAnswer, + hcollision⟩ := hbad + have hmessagePosition : layerMessagePosition queryIndex position.lay = + layerMessagePosition targetIndex position.lay := + layerMessagePosition_eq_of_position_eq queryIndex targetIndex position.lay + (htree.trans htargetTree.symm) (hleaf.trans htargetLeaf.symm) + have htargetPosition : AtPosition secretKey.parameter input + (layerMessagePosition targetIndex position.lay) := by + rwa [← hmessagePosition] + have htargetUnsettled : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache (layerMessagePosition targetIndex position.lay) := by + rwa [← hmessagePosition] + have hmessage := honestValue_cacheQuery_self_of_settled secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret huncached htargetPosition + htargetUnsettled hsettledAfter + let targetInput := tweakableHashInput secretKey.parameter position.domain targetPayload + have htargetInputNe : targetInput ≠ input := by + intro heq + exact (show AtEncodingPosition secretKey.parameter targetInput position from + ⟨targetPayload, rfl⟩).not_atPosition + (layerMessagePosition targetIndex position.lay) (heq ▸ htargetPosition) + have htargetOld : cache targetInput ≠ none := by + have htargetAfter : cache.cacheQuery input answer targetInput ≠ none := by + simp [targetInput, htargetAnswer] + rwa [QueryCache.cacheQuery_of_ne _ _ htargetInputNe] at htargetAfter + have hmem := slotDigest_mem_encodingMessageTargets hfinite htargetOld + (show AtEncodingPosition secretKey.parameter targetInput position from + ⟨targetPayload, rfl⟩) + have hslot : slotDigest 0 targetInput = + honestValue (fromCache (cache.cacheQuery input answer)) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition targetIndex position.lay) := by + dsimp only [targetInput] + rw [hpayload] + exact slotDigest_zero_encodingInput secretKey.parameter position + (honestValue (fromCache (cache.cacheQuery input answer)) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition targetIndex position.lay)) counter + rw [hslot, hmessage] at hmem + exact hmem + +theorem LatentEncodingBadAt.of_cacheQuery_of_settled_of_not_atEncoding + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} {position : EncodingPosition} + (huncached : cache input = none) + (hsettledAt : ∀ index : Index, + treeIndexAt index position.lay = position.tree → + leafIndexAt index position.lay = position.leafIdx → + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (layerMessagePosition index position.lay)) + (hnotAt : ¬ AtEncodingPosition secretKey.parameter input position) + (hbad : LatentEncodingBadAt (cache.cacheQuery input answer) secretKey position) : + LatentEncodingBadAt cache secretKey position := by + obtain ⟨index, counter, targetPayload, otherPayload, targetAnswer, otherAnswer, + htree, hleaf, hsettledAfter, hpayload, htargetAnswer, htargetValid, + hbefore, hpayloadNe, hotherAnswer, hcollision⟩ := hbad + have hsettled := hsettledAt index htree hleaf + have hle := le_cacheQuery (cache := cache) (input := input) (answer := answer) huncached + have hmessage := honestValue_eq_of_settled + (agreesWithFn_fromCache_of_le hle) hsettled + let targetInput := tweakableHashInput secretKey.parameter position.domain targetPayload + let otherInput := tweakableHashInput secretKey.parameter position.domain otherPayload + have htargetInputNe : targetInput ≠ input := by + intro heq + exact hnotAt ⟨targetPayload, heq.symm⟩ + have hotherInputNe : otherInput ≠ input := by + intro heq + exact hnotAt ⟨otherPayload, heq.symm⟩ + have htargetOld : cache targetInput = some targetAnswer := by + have htargetAnswer' : cache.cacheQuery input answer targetInput = + some targetAnswer := by + simpa only [targetInput] using htargetAnswer + rwa [QueryCache.cacheQuery_of_ne _ _ htargetInputNe] at htargetAnswer' + have hotherOld : cache otherInput = some otherAnswer := by + have hotherAnswer' : cache.cacheQuery input answer otherInput = some otherAnswer := by + simpa only [otherInput] using hotherAnswer + rwa [QueryCache.cacheQuery_of_ne _ _ hotherInputNe] at hotherAnswer' + refine ⟨index, counter, targetPayload, otherPayload, targetAnswer, otherAnswer, + htree, hleaf, hsettled, ?_, htargetOld, htargetValid, ?_, hpayloadNe, + hotherOld, hcollision⟩ + · rw [hmessage] at hpayload + exact hpayload + · intro candidate hcandidate candidateAnswer hcandidateAnswer + have hcandidateInputNe : tweakableHashInput secretKey.parameter position.domain + (digestBytes (honestValue (fromCache cache) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index position.lay)) ++ counterBytes candidate) ≠ input := by + intro heq + exact hnotAt ⟨_, heq.symm⟩ + have hcandidateAfter : (cache.cacheQuery input answer) + (tweakableHashInput secretKey.parameter position.domain + (digestBytes (honestValue (fromCache (cache.cacheQuery input answer)) + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index position.lay)) ++ counterBytes candidate)) = + some candidateAnswer := by + rw [hmessage] + rwa [QueryCache.cacheQuery_of_ne _ _ hcandidateInputNe] + exact hbefore candidate hcandidate candidateAnswer hcandidateAfter + +def PrematureLayerMessageSettlement (cache : QueryCache HashSpec) + (secretKey : SecretKey) (input : HashInput) (answer : HashOutput) : Prop := + ∃ (position : EncodingPosition) (index : Index), + treeIndexAt index position.lay = position.tree + ∧ leafIndexAt index position.lay = position.leafIdx + ∧ ¬ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (layerMessagePosition index position.lay) + ∧ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) (layerMessagePosition index position.lay) + ∧ ¬ AtPosition secretKey.parameter input + (layerMessagePosition index position.lay) + +theorem latentEncodingBad_step_classify + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + (hclean : ¬ LatentEncodingBad cache secretKey) + (huncached : cache input = none) + (hbad : LatentEncodingBad (cache.cacheQuery input answer) secretKey) : + (∃ position : EncodingPosition, + AtEncodingPosition secretKey.parameter input position ∧ + truncateHash answer ∈ + encodingValidAnswerTargets secretKey.parameter cache hfinite position) + ∨ (∃ (position : EncodingPosition) (index : Index), + treeIndexAt index position.lay = position.tree ∧ + leafIndexAt index position.lay = position.leafIdx ∧ + ¬ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (layerMessagePosition index position.lay) ∧ + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) (layerMessagePosition index position.lay) ∧ + AtPosition secretKey.parameter input + (layerMessagePosition index position.lay) ∧ + truncateHash answer ∈ + encodingMessageTargets secretKey.parameter cache hfinite position) + ∨ PrematureLayerMessageSettlement cache secretKey input answer := by + classical + by_cases hencoding : ∃ position, + AtEncodingPosition secretKey.parameter input position + · obtain ⟨position, hposition⟩ := hencoding + exact Or.inl ⟨position, hposition, + latentEncodingBad_validAnswer_hit_of_encoding_query hfinite hclean huncached + hposition hbad⟩ + · right + obtain ⟨position, index, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htree, hleaf, hsettledAfter, hpayload, htargetAnswer, + htargetValid, hbefore, hpayloadNe, hotherAnswer, hcollision⟩ := hbad + by_cases hsettled : Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache (layerMessagePosition index position.lay) + · exfalso + apply hclean + refine ⟨position, ?_⟩ + apply LatentEncodingBadAt.of_cacheQuery_of_settled_of_not_atEncoding + huncached + · intro candidate hcandidateTree hcandidateLeaf + have hpositionEq := layerMessagePosition_eq_of_position_eq index candidate + position.lay (htree.trans hcandidateTree.symm) + (hleaf.trans hcandidateLeaf.symm) + rwa [← hpositionEq] + · exact fun hposition => hencoding ⟨position, hposition⟩ + · exact ⟨index, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htree, hleaf, hsettledAfter, hpayload, htargetAnswer, + htargetValid, hbefore, hpayloadNe, hotherAnswer, hcollision⟩ + · by_cases hposition : AtPosition secretKey.parameter input + (layerMessagePosition index position.lay) + · left + refine ⟨position, index, htree, hleaf, hsettled, hsettledAfter, + hposition, ?_⟩ + apply latentEncodingBadAt_message_hit_of_settling_query hfinite huncached + htree hleaf hposition hsettled + exact ⟨index, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htree, hleaf, hsettledAfter, hpayload, htargetAnswer, + htargetValid, hbefore, hpayloadNe, hotherAnswer, hcollision⟩ + · right + exact ⟨position, index, htree, hleaf, hsettled, hsettledAfter, hposition⟩ + +theorem latentEncodingBadAt_step_classify + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} + (hclean : ¬ LatentEncodingBadAt cache secretKey position) + (huncached : cache input = none) + (hbad : LatentEncodingBadAt (cache.cacheQuery input answer) secretKey position) : + (AtEncodingPosition secretKey.parameter input position ∧ + truncateHash answer ∈ + encodingValidAnswerTargets secretKey.parameter cache hfinite position) + ∨ (∃ index : Index, + treeIndexAt index position.lay = position.tree ∧ + leafIndexAt index position.lay = position.leafIdx ∧ + ¬ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (layerMessagePosition index position.lay) ∧ + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) (layerMessagePosition index position.lay) ∧ + AtPosition secretKey.parameter input + (layerMessagePosition index position.lay) ∧ + truncateHash answer ∈ + encodingMessageTargets secretKey.parameter cache hfinite position) + ∨ PrematureLayerMessageSettlement cache secretKey input answer := by + classical + by_cases hencoding : AtEncodingPosition secretKey.parameter input position + · exact Or.inl ⟨hencoding, + latentEncodingBadAt_answer_hit_of_encoding_query hfinite hclean huncached + hencoding hbad⟩ + · right + obtain ⟨index, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htree, hleaf, hsettledAfter, hpayload, htargetAnswer, + htargetValid, hbefore, hpayloadNe, hotherAnswer, hcollision⟩ := hbad + by_cases hsettled : Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache (layerMessagePosition index position.lay) + · exfalso + apply hclean + apply LatentEncodingBadAt.of_cacheQuery_of_settled_of_not_atEncoding + huncached + · intro candidate hcandidateTree hcandidateLeaf + have hpositionEq := layerMessagePosition_eq_of_position_eq index candidate + position.lay (htree.trans hcandidateTree.symm) + (hleaf.trans hcandidateLeaf.symm) + rwa [← hpositionEq] + · exact hencoding + · exact ⟨index, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htree, hleaf, hsettledAfter, hpayload, htargetAnswer, + htargetValid, hbefore, hpayloadNe, hotherAnswer, hcollision⟩ + · by_cases hposition : AtPosition secretKey.parameter input + (layerMessagePosition index position.lay) + · left + refine ⟨index, htree, hleaf, hsettled, hsettledAfter, hposition, ?_⟩ + apply latentEncodingBadAt_message_hit_of_settling_query hfinite huncached + htree hleaf hposition hsettled + exact ⟨index, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htree, hleaf, hsettledAfter, hpayload, htargetAnswer, + htargetValid, hbefore, hpayloadNe, hotherAnswer, hcollision⟩ + · right + exact ⟨position, index, htree, hleaf, hsettled, hsettledAfter, hposition⟩ + +theorem PrematureLayerMessageSettlement.mem_settlingTargets + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + (huncached : cache input = none) + (hpremature : PrematureLayerMessageSettlement cache secretKey input answer) : + ∃ queriedPosition : Position, + AtPosition secretKey.parameter input queriedPosition ∧ + ¬ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + cache queriedPosition ∧ + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) queriedPosition ∧ + truncateHash answer ∈ + settlingTargets secretKey.parameter cache hfinite queriedPosition := by + obtain ⟨encodingPosition, index, htree, hleaf, htargetUnsettled, + htargetSettled, hnotTarget⟩ := hpremature + let targetPosition := layerMessagePosition index encodingPosition.lay + have htargetUnsettled' : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache targetPosition := by + simpa only [targetPosition] using htargetUnsettled + have htargetSettled' : Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (cache.cacheQuery input answer) targetPosition := by + simpa only [targetPosition] using htargetSettled + have hnotTarget' : ¬ AtPosition secretKey.parameter input targetPosition := by + simpa only [targetPosition] using hnotTarget + have hat : ∃ queriedPosition, AtPosition secretKey.parameter input queriedPosition := by + by_contra hnone + apply htargetUnsettled' + exact settled_of_settled_cacheQuery secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret huncached (p₀ := none) + (fun position hposition => (hnone ⟨position, hposition⟩).elim) + (by simp) (targetPosition.depth + 1) targetPosition (by omega) (by simp) + htargetSettled' + obtain ⟨queriedPosition, hqueried⟩ := hat + have hqueriedNe : queriedPosition ≠ targetPosition := by + intro heq + exact hnotTarget' (heq ▸ hqueried) + have hqueriedUnsettled : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache queriedPosition := by + intro hsettled + apply htargetUnsettled' + exact settled_of_cacheQuery_at_settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret huncached hqueried hsettled + (targetPosition.depth + 1) targetPosition (by omega) htargetSettled' + have hpositionRule : ∀ position, + AtPosition secretKey.parameter input position → + some queriedPosition = some position := by + intro position hposition + exact congrArg some (atPosition_unique secretKey.parameter hqueried hposition) + obtain ⟨parent, hparent, hparentSettled⟩ : ∃ parent, + queriedPosition.parentOf = some parent ∧ + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) parent := by + cases hparent : queriedPosition.parentOf with + | none => + exfalso + apply htargetUnsettled' + exact settled_of_settled_cacheQuery secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret huncached (p₀ := some queriedPosition) hpositionRule + (by + intro position parent heq hparent' + have hpositionEq : position = queriedPosition := Option.some.inj heq.symm + subst position + rw [hparent] at hparent' + simp at hparent') + (targetPosition.depth + 1) targetPosition (by omega) + (by + intro heq + exact hqueriedNe (Option.some.inj heq)) htargetSettled' + | some parent => + by_cases hsettledParent : Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (cache.cacheQuery input answer) parent + · exact ⟨parent, rfl, hsettledParent⟩ + · exfalso + apply htargetUnsettled' + exact settled_of_settled_cacheQuery secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret huncached (p₀ := some queriedPosition) hpositionRule + (by + intro position candidateParent heq hparent' + have hpositionEq : position = queriedPosition := Option.some.inj heq.symm + subst position + rw [hparent] at hparent' + have : candidateParent = parent := Option.some.inj hparent'.symm + subst candidateParent + exact hsettledParent) + (targetPosition.depth + 1) targetPosition (by omega) + (by + intro heq + exact hqueriedNe (Option.some.inj heq)) htargetSettled' + have hchild : queriedPosition ∈ parent.children := + Position.mem_children_iff.mpr hparent + have hqueriedSettled : Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (cache.cacheQuery input answer) queriedPosition := + hparentSettled.children queriedPosition hchild + have hslot : truncateHash answer ∈ slotTargets secretKey.parameter cache hfinite + queriedPosition parent := by + by_contra havoid + exact (not_settled_parent_of_avoids_slotTargets secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret hfinite huncached hqueried + hqueriedUnsettled hqueriedSettled hchild havoid) hparentSettled + refine ⟨queriedPosition, hqueried, hqueriedUnsettled, hqueriedSettled, ?_⟩ + rw [settlingTargets, hparent] + exact Finset.mem_union_right _ hslot + +theorem latentEncodingBad_step_targets + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + (hclean : ¬ LatentEncodingBad cache secretKey) + (huncached : cache input = none) + (hbad : LatentEncodingBad (cache.cacheQuery input answer) secretKey) : + (∃ position : EncodingPosition, + AtEncodingPosition secretKey.parameter input position ∧ + truncateHash answer ∈ + encodingValidAnswerTargets secretKey.parameter cache hfinite position) + ∨ (∃ position : EncodingPosition, + truncateHash answer ∈ + encodingMessageTargets secretKey.parameter cache hfinite position) + ∨ ∃ position : Position, + AtPosition secretKey.parameter input position ∧ + truncateHash answer ∈ + settlingTargets secretKey.parameter cache hfinite position := by + rcases latentEncodingBad_step_classify hfinite hclean huncached hbad with + hencoding | hmessage | hpremature + · exact Or.inl hencoding + · obtain ⟨position, index, htree, hleaf, hunsettled, hsettled, + hposition, hmem⟩ := hmessage + exact Or.inr (Or.inl ⟨position, hmem⟩) + · obtain ⟨position, hposition, hunsettled, hsettled, hmem⟩ := + PrematureLayerMessageSettlement.mem_settlingTargets hfinite huncached hpremature + exact Or.inr (Or.inr ⟨position, hposition, hmem⟩) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingMessagePrehit.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingMessagePrehit.lean new file mode 100644 index 00000000..030f59e6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingMessagePrehit.lean @@ -0,0 +1,62 @@ +import SphincsSecurity.Proof.TightEncodingSettlement + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +def EncodingMessagePrehit (cache : QueryCache HashSpec) (secretKey : SecretKey) + (input : HashInput) (answer : HashOutput) : Prop := + ∃ (position : EncodingPosition) (index : Index) (previous : HashInput), + treeIndexAt index position.lay = position.tree ∧ + leafIndexAt index position.lay = position.leafIdx ∧ + ¬ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache (layerMessagePosition index position.lay) ∧ + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) (layerMessagePosition index position.lay) ∧ + AtEncodingPosition secretKey.parameter previous position ∧ cache previous ≠ none ∧ + slotDigest 0 previous = honestValue (fromCache (cache.cacheQuery input answer)) + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret (layerMessagePosition index position.lay) + +theorem EncodingMessagePrehit.mem_settlementTargets + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} {queriedPosition : Position} + (hfresh : cache input = none) (hat : AtPosition secretKey.parameter input queriedPosition) + (messageTargets : Finset Digest) + (hdirect : ∀ (position : EncodingPosition) (index : Index), + treeIndexAt index position.lay = position.tree → + leafIndexAt index position.lay = position.leafIdx → + layerMessagePosition index position.lay = queriedPosition → + encodingMessageTargets secretKey.parameter cache hfinite position ⊆ messageTargets) + (hhit : EncodingMessagePrehit cache secretKey input answer) : + truncateHash answer ∈ messageTargets ∪ + tightSettlingTargets secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache hfinite queriedPosition := by + obtain ⟨position, index, previous, htree, hleaf, hbefore, hafter, hencoding, hcached, hvalue⟩ := hhit + by_cases hmessage : AtPosition secretKey.parameter input (layerMessagePosition index position.lay) + · have hanswer := honestValue_cacheQuery_self_of_settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret hfresh hmessage hbefore hafter + apply Finset.mem_union_left + apply hdirect position index htree hleaf (atPosition_unique secretKey.parameter hmessage hat) + have hmem := slotDigest_mem_encodingMessageTargets hfinite hcached hencoding + rwa [hvalue, hanswer] at hmem + · have hpremature : PrematureLayerMessageSettlement cache secretKey input answer := + ⟨position, index, htree, hleaf, hbefore, hafter, hmessage⟩ + obtain ⟨other, hother, _, _, hmem⟩ := hpremature.mem_tightSettlingTargets hfinite hfresh + have heq := atPosition_unique secretKey.parameter hother hat + subst other + exact Finset.mem_union_right _ hmem + +theorem EncodingMessagePrehit.queried_settles + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + (hfresh : cache input = none) (hhit : EncodingMessagePrehit cache secretKey input answer) : + ∃ position : Position, AtPosition secretKey.parameter input position ∧ + ¬ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position ∧ + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret (cache.cacheQuery input answer) position := by + obtain ⟨position, index, previous, htree, hleaf, hbefore, hafter, _⟩ := hhit + by_cases hmessage : AtPosition secretKey.parameter input (layerMessagePosition index position.lay) + · exact ⟨_, hmessage, hbefore, hafter⟩ + · have hpremature : PrematureLayerMessageSettlement cache secretKey input answer := + ⟨position, index, htree, hleaf, hbefore, hafter, hmessage⟩ + obtain ⟨other, hat, hunsettled, hsettled, _⟩ := hpremature.mem_tightSettlingTargets hfinite hfresh + exact ⟨other, hat, hunsettled, hsettled⟩ + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitComposition.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitComposition.lean new file mode 100644 index 00000000..ff5f314b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitComposition.lean @@ -0,0 +1,67 @@ +import SphincsSecurity.Proof.EncodingPrehitMonitor + +namespace SphincsSecurity.Concrete.TightEncoding + +open OracleComp OracleSpec + +theorem runEncodingPrehitMonitor_pure (secretKey : SecretKey) (value : α) + (cache : QueryCache HashSpec) (hit : Bool) : + runEncodingPrehitMonitor secretKey (pure value) cache hit = pure ((value, cache), hit) := rfl + +theorem runEncodingPrehitMonitor_bind (secretKey : SecretKey) + (computation : OracleComp OracleWorld α) (next : α → OracleComp OracleWorld β) + (cache : QueryCache HashSpec) (hit : Bool) : + runEncodingPrehitMonitor secretKey (computation >>= next) cache hit = (do + let result ← runEncodingPrehitMonitor secretKey computation cache hit + runEncodingPrehitMonitor secretKey (next result.1.1) result.1.2 result.2) := by + induction computation using OracleComp.inductionOn generalizing cache hit with + | pure value => simp [runEncodingPrehitMonitor] + | query_bind query continuation ih => + simp only [bind_assoc, runEncodingPrehitMonitor, OracleComp.construct_query_bind] + exact bind_congr fun result => ih result.1 result.2 _ + +theorem runEncodingPrehitMonitor_map (secretKey : SecretKey) + (f : α → β) (computation : OracleComp OracleWorld α) + (cache : QueryCache HashSpec) (hit : Bool) : + runEncodingPrehitMonitor secretKey (f <$> computation) cache hit = + (fun result => ((f result.1.1, result.1.2), result.2)) <$> + runEncodingPrehitMonitor secretKey computation cache hit := by + rw [map_eq_bind_pure_comp, runEncodingPrehitMonitor_bind] + rfl + +theorem runEncodingPrehitMonitor_query (secretKey : SecretKey) + (query : OracleWorld.Domain) (cache : QueryCache HashSpec) (hit : Bool) : + runEncodingPrehitMonitor secretKey (OracleWorld.query query) cache hit = + (fun result => (result, hit || encodingPrehitQuery secretKey cache query result.1)) <$> + (romImpl query).run cache := by + rw [← bind_pure (liftM (OracleWorld.query query) : OracleComp OracleWorld _)] + rw [runEncodingPrehitMonitor, OracleComp.construct_query_bind] + rfl + +noncomputable def encodingPrehitImpl (secretKey : SecretKey) : + QueryImpl OracleWorld (StateT (QueryCache HashSpec × Bool) ProbComp) := + fun query state => + (fun result => (result.1.1, (result.1.2, result.2))) <$> + runEncodingPrehitMonitor secretKey (OracleWorld.query query) state.1 state.2 + +theorem simulateQ_encodingPrehitImpl_run (secretKey : SecretKey) + (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) (hit : Bool) : + (simulateQ (encodingPrehitImpl secretKey) computation).run (cache, hit) = + (fun result => (result.1.1, (result.1.2, result.2))) <$> + runEncodingPrehitMonitor secretKey computation cache hit := by + induction computation using OracleComp.inductionOn generalizing cache hit with + | pure value => simp [runEncodingPrehitMonitor] + | query_bind query next ih => + rw [simulateQ_bind, StateT.run_bind, simulateQ_spec_query, runEncodingPrehitMonitor_bind] + simp only [encodingPrehitImpl, StateT.run, bind_map_left, map_bind] + exact bind_congr fun result => ih result.1.1 result.1.2 result.2 + +theorem runEncodingPrehitMonitor_eq_simulateQ (secretKey : SecretKey) + (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) (hit : Bool) : + runEncodingPrehitMonitor secretKey computation cache hit = + (fun result => ((result.1, result.2.1), result.2.2)) <$> + (simulateQ (encodingPrehitImpl secretKey) computation).run (cache, hit) := by + rw [simulateQ_encodingPrehitImpl_run] + simp + +end SphincsSecurity.Concrete.TightEncoding diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitContinuation.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitContinuation.lean new file mode 100644 index 00000000..ab588e4b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitContinuation.lean @@ -0,0 +1,131 @@ +import SphincsSecurity.Proof.EncodingPrehitSupport + +namespace SphincsSecurity.Concrete.TightEncoding + +open OracleComp OracleSpec + +theorem prehitFree_fresh_transition_of_mem_support + (secretKey : SecretKey) (event : QueryCache HashSpec → Prop) + (computation : OracleComp OracleWorld α) (initialCache : QueryCache HashSpec) + (value : α) (finalCache : QueryCache HashSpec) + (hrun : ((value, finalCache), false) ∈ support + (runEncodingPrehitMonitor secretKey computation initialCache false)) + (hbefore : ¬ event initialCache) (hafter : event finalCache) : + ∃ (cache : QueryCache HashSpec) (input : HashInput) (answer : HashOutput), + initialCache ≤ cache ∧ ¬ event cache ∧ cache input = none ∧ + event (cache.cacheQuery input answer) ∧ cache.cacheQuery input answer ≤ finalCache ∧ + ¬ EncodingMessagePrehit cache secretKey input answer := by + classical + induction computation using OracleComp.inductionOn generalizing initialCache with + | pure output => + simp only [runEncodingPrehitMonitor_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq, and_true] at hrun + obtain ⟨rfl, rfl⟩ := hrun + exact (hbefore hafter).elim + | query_bind query next ih => + obtain ⟨⟨answer, middleCache⟩, hquery, hnohit, hrest⟩ := + (mem_support_runEncodingPrehitMonitor_query_bind_false_iff secretKey query next + initialCache (value, finalCache)).mp hrun + cases query with + | inl uniformInput => + change (answer, middleCache) ∈ support ((unifFwdImpl HashSpec uniformInput).run initialCache) at hquery + have hrunUniform := unifFwdImpl.simulateQ_run (hashSpec := HashSpec) + (liftM (unifSpec.query uniformInput) : ProbComp _) initialCache + simp only [simulateQ_spec_query] at hrunUniform + rw [hrunUniform, support_map] at hquery + obtain ⟨sample, _, heq⟩ := hquery + obtain ⟨rfl, rfl⟩ := heq + exact ih answer initialCache hrest hbefore + | inr input => + change HashOutput at answer + change (answer, middleCache) ∈ support ((randomOracle input).run initialCache) at hquery + cases hcached : initialCache input with + | some cachedAnswer => + rw [QueryImpl.withCaching_run_some uniformSampleImpl hcached, + support_pure, Set.mem_singleton_iff] at hquery + obtain ⟨rfl, rfl⟩ := hquery + exact ih answer initialCache hrest hbefore + | none => + rw [QueryImpl.withCaching_run_none uniformSampleImpl hcached, support_map] at hquery + obtain ⟨freshAnswer, _, heq⟩ := hquery + obtain ⟨rfl, rfl⟩ := heq + by_cases hmiddle : event (initialCache.cacheQuery input answer) + · refine ⟨initialCache, input, answer, le_rfl, hbefore, hcached, hmiddle, ?_, ?_⟩ + · exact cache_le_of_mem_runEncodingPrehitMonitor secretKey (next answer) + (initialCache.cacheQuery input answer) false ((value, finalCache), false) hrest + · simpa [encodingPrehitQuery, hcached] using hnohit + · obtain ⟨cache, laterInput, laterAnswer, hprefix, hlaterBefore, hfresh, hlaterAfter, hsuffix, hnohit⟩ := + ih answer (initialCache.cacheQuery input answer) hrest hmiddle + exact ⟨cache, laterInput, laterAnswer, (le_cacheQuery hcached).trans hprefix, + hlaterBefore, hfresh, hlaterAfter, hsuffix, hnohit⟩ + +theorem encodingMessage_ne_honestValue_of_prehitFree_continuation + (secretKey : SecretKey) (position : EncodingPosition) (index : Index) (previous : HashInput) + (htree : treeIndexAt index position.lay = position.tree) + (hleaf : leafIndexAt index position.lay = position.leafIdx) + (hat : AtEncodingPosition secretKey.parameter previous position) + (computation : OracleComp OracleWorld α) (initialCache : QueryCache HashSpec) + (value : α) (finalCache : QueryCache HashSpec) + (hcached : initialCache previous ≠ none) + (hbefore : ¬ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + initialCache (layerMessagePosition index position.lay)) + (hafter : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + finalCache (layerMessagePosition index position.lay)) + (hrun : ((value, finalCache), false) ∈ support + (runEncodingPrehitMonitor secretKey computation initialCache false)) : + slotDigest 0 previous ≠ honestValue (fromCache finalCache) + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret (layerMessagePosition index position.lay) := by + intro hmatch + obtain ⟨cache, input, answer, hprefix, hunsettled, _hfresh, hsettled, hsuffix, hnohit⟩ := + prehitFree_fresh_transition_of_mem_support secretKey + (fun cache => Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + cache (layerMessagePosition index position.lay)) computation initialCache value finalCache hrun hbefore hafter + apply hnohit + refine ⟨position, index, previous, htree, hleaf, hunsettled, hsettled, hat, ?_, ?_⟩ + · obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hcached + exact Option.ne_none_iff_exists'.mpr ⟨output, hprefix houtput⟩ + · exact hmatch.trans (honestValue_eq_of_settled (agreesWithFn_fromCache_of_le hsuffix) hsettled) + +theorem encodingMessageSettledAt_of_prehitFree_matching_query + (secretKey : SecretKey) (position : EncodingPosition) (index : Index) (input : HashInput) + (htree : treeIndexAt index position.lay = position.tree) + (hleaf : leafIndexAt index position.lay = position.leafIdx) + (hat : AtEncodingPosition secretKey.parameter input position) + (next : HashOutput → OracleComp OracleWorld α) (initialCache : QueryCache HashSpec) + (value : α) (finalCache : QueryCache HashSpec) + (hafter : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + finalCache (layerMessagePosition index position.lay)) + (hmatch : slotDigest 0 input = honestValue (fromCache finalCache) + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret (layerMessagePosition index position.lay)) + (hrun : ((value, finalCache), false) ∈ support + (runEncodingPrehitMonitor secretKey (OracleWorld.query (.inr input) >>= next) initialCache false)) : + EncodingMessageSettledAt initialCache secretKey position := by + classical + by_contra hbefore + obtain ⟨⟨answer, middleCache⟩, hquery, _hnohit, hrest⟩ := + (mem_support_runEncodingPrehitMonitor_query_bind_false_iff secretKey (.inr input) next + initialCache (value, finalCache)).mp hrun + change HashOutput at answer + change (answer, middleCache) ∈ support ((randomOracle input).run initialCache) at hquery + have impossible (cache : QueryCache HashSpec) (output : HashOutput) + (hcached : cache input ≠ none) (hunsettled : ¬ EncodingMessageSettledAt cache secretKey position) + (hcontinuation : ((value, finalCache), false) ∈ support + (runEncodingPrehitMonitor secretKey (next output) cache false)) : False := by + apply encodingMessage_ne_honestValue_of_prehitFree_continuation secretKey position index input htree hleaf hat + (next output) cache value finalCache hcached (fun hsettled => hunsettled ⟨index, htree, hleaf, hsettled⟩) + hafter hcontinuation hmatch + cases hcached : initialCache input with + | some cachedAnswer => + rw [QueryImpl.withCaching_run_some uniformSampleImpl hcached, + support_pure, Set.mem_singleton_iff] at hquery + obtain ⟨rfl, rfl⟩ := hquery + exact impossible initialCache answer (by rw [hcached]; simp) hbefore hrest + | none => + rw [QueryImpl.withCaching_run_none uniformSampleImpl hcached, support_map] at hquery + obtain ⟨freshAnswer, _, heq⟩ := hquery + obtain ⟨rfl, rfl⟩ := heq + exact impossible (initialCache.cacheQuery input answer) answer + (by rw [QueryCache.cacheQuery_self]; simp) + (fun hsettled => hbefore (hsettled.of_cacheQuery_of_atEncoding hcached hat)) hrest + +end SphincsSecurity.Concrete.TightEncoding diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitGame.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitGame.lean new file mode 100644 index 00000000..8329c333 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitGame.lean @@ -0,0 +1,53 @@ +import SphincsSecurity.Proof.EncodingPrehitMonitor +import SphincsSecurity.Proof.JointPrimitiveQueryBudget + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +structure EncodingPrehitGameResult where + secrets : SampledSecrets + verdict : Bool + cache : QueryCache HashSpec + prehit : Bool + +def EncodingPrehitGameResult.Bad (result : EncodingPrehitGameResult) : Prop := + result.prehit = true ∨ + SphincsSecurity.Bad result.secrets.parameter result.secrets.otsSecret result.secrets.ftsSecret result.cache ∨ + EncodingBad result.cache (primitiveAccountingKey result.secrets.parameter result.secrets.otsSecret result.secrets.ftsSecret) + +noncomputable def sampledEncodingPrehitGame (adversary : Adversary) : ProbComp EncodingPrehitGameResult := do + let secrets ← sampleSecrets + (fun result => ⟨secrets, result.1.1, result.1.2, result.2⟩) <$> + TightEncoding.runEncodingPrehitMonitor + (primitiveAccountingKey secrets.parameter secrets.otsSecret secrets.ftsSecret) + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret) ∅ false + +theorem sampledEncodingPrehitGame_verdict_projection (adversary : Adversary) : + EncodingPrehitGameResult.verdict <$> sampledEncodingPrehitGame adversary = sampledGame adversary := by + unfold sampledEncodingPrehitGame sampledGame + rw [map_bind] + apply bind_congr + intro secrets + rw [Functor.map_map, StateT.run'_eq] + rw [← TightEncoding.runEncodingPrehitMonitor_project + (primitiveAccountingKey secrets.parameter secrets.otsSecret secrets.ftsSecret) + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret) ∅ false, + Functor.map_map] + +theorem probEvent_sampledEncodingPrehitGame_bad_le_queryCharge (adversary : Adversary) : + Pr[EncodingPrehitGameResult.Bad | sampledEncodingPrehitGame adversary] ≤ + sampledQueryCharge TightEncoding.refinedStructuralEncodingQueryCharge adversary * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + unfold sampledEncodingPrehitGame sampledQueryCharge + rw [probEvent_bind_eq_tsum, ← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro secrets + rw [mul_assoc] + apply mul_le_mul' le_rfl + rw [probEvent_map] + exact TightEncoding.probEvent_prehit_or_bad_or_encodingBad_le_queryCharge + (primitiveAccountingKey secrets.parameter secrets.otsSecret secrets.ftsSecret) + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitMonitor.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitMonitor.lean new file mode 100644 index 00000000..48f3cb41 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitMonitor.lean @@ -0,0 +1,166 @@ +import SphincsSecurity.Proof.TightEncodingPrehitCharge + +namespace SphincsSecurity.Concrete.TightEncoding + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +noncomputable def encodingPrehitQuery (secretKey : SecretKey) (cache : QueryCache HashSpec) : + (query : OracleWorld.Domain) → OracleWorld.Range query → Bool + | .inl _, _ => false + | .inr input, answer => decide (cache input = none ∧ EncodingMessagePrehit cache secretKey input answer) + +noncomputable def runEncodingPrehitMonitor (secretKey : SecretKey) + (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) (hit : Bool) : + ProbComp ((α × QueryCache HashSpec) × Bool) := + OracleComp.construct + (C := fun _ => QueryCache HashSpec → Bool → ProbComp ((α × QueryCache HashSpec) × Bool)) + (fun value cache hit => pure ((value, cache), hit)) + (fun query _ next cache hit => do + let result ← (romImpl query).run cache + next result.1 result.2 (hit || encodingPrehitQuery secretKey cache query result.1)) + computation cache hit + +noncomputable def encodingPrehitMonitorPotential (secretKey : SecretKey) + (cache : QueryCache HashSpec) (hit : Bool) : ℝ≥0∞ := + if hit then 1 else encodingSelectionAdaptivePotential cache secretKey + +theorem runEncodingPrehitMonitor_project (secretKey : SecretKey) + (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) (hit : Bool) : + Prod.fst <$> runEncodingPrehitMonitor secretKey computation cache hit = + (simulateQ romImpl computation).run cache := by + induction computation using OracleComp.inductionOn generalizing cache hit with + | pure value => simp [runEncodingPrehitMonitor, simulateQ_pure] + | query_bind query next ih => + rw [runEncodingPrehitMonitor, OracleComp.construct_query_bind, map_bind, + simulateQ_bind, simulateQ_spec_query, StateT.run_bind] + exact bind_congr fun result => ih result.1 result.2 _ + +theorem expected_encodingPrehitMonitorPotential_query_le + (secretKey : SecretKey) (query : OracleWorld.Domain) (cache : QueryCache HashSpec) + (hit : Bool) (hfinite : Finite cache) : + (∑' result, Pr[= result | (romImpl query).run cache] * + encodingPrehitMonitorPotential secretKey result.2 (hit || encodingPrehitQuery secretKey cache query result.1)) ≤ + encodingPrehitMonitorPotential secretKey cache hit + + hashQueryCharge (fun cache input => refinedStructuralEncodingQueryCharge secretKey cache input * + (Fintype.card Digest : ℝ≥0∞)⁻¹) cache query := by + cases hit with + | true => + simp only [Bool.true_or, encodingPrehitMonitorPotential, ↓reduceIte, mul_one, + romImpl_query_mass] + exact le_self_add + | false => + cases query with + | inl input => + have hquery : (romImpl (.inl input)).run cache = + (fun answer => (answer, cache)) <$> (liftM (unifSpec.query input) : ProbComp _) := rfl + simp only [encodingPrehitQuery, encodingPrehitMonitorPotential, Bool.false_or, + Bool.false_eq_true, ↓reduceIte, hashQueryCharge, Sum.elim_inl, add_zero] + rw [hquery] + change (∑' result : Fin (input + 1) × QueryCache HashSpec, + Pr[= result | (fun answer : Fin (input + 1) => (answer, cache)) <$> + (liftM (unifSpec.query input) : ProbComp (Fin (input + 1)))] * + encodingSelectionAdaptivePotential result.2 secretKey) ≤ _ + rw [tsum_probOutput_map_mul] + dsimp only + rw [ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul] + | inr input => + change (∑' result, Pr[= result | (randomOracle input).run cache] * + encodingPrehitMonitorPotential secretKey result.2 (false || encodingPrehitQuery secretKey cache (.inr input) result.1)) ≤ _ + by_cases hfresh : cache input = none + · rw [randomOracle, QueryImpl.withCaching_run_none _ hfresh, tsum_probOutput_map_mul] + simp only [encodingPrehitMonitorPotential, encodingPrehitQuery, hfresh, true_and, + Bool.false_or, decide_eq_true_eq, Bool.false_eq_true, ↓reduceIte, + hashQueryCharge, Sum.elim_inr] + simp_rw [encodingSelectionAdaptivePotential_eq (finite_cacheQuery hfinite input _)] + rw [encodingSelectionAdaptivePotential_eq hfinite] + exact uniform_encodingPrehit_or_potential_le_refined_charge hfinite hfresh + · obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hfresh + rw [randomOracle, QueryImpl.withCaching_run_some _ hanswer] + simp [encodingPrehitMonitorPotential, encodingPrehitQuery, hfresh] + +theorem expected_runEncodingPrehitMonitor_potential_le_queryCharge + (secretKey : SecretKey) (computation : OracleComp OracleWorld α) + (cache : QueryCache HashSpec) (hit : Bool) (hfinite : Finite cache) : + (∑' result, Pr[= result | runEncodingPrehitMonitor secretKey computation cache hit] * + encodingPrehitMonitorPotential secretKey result.1.2 result.2) ≤ + encodingPrehitMonitorPotential secretKey cache hit + + expectedQueryCharge (refinedStructuralEncodingQueryCharge secretKey) computation cache * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + rw [← expectedQueryCharge_mul] + let charge := fun cache input => refinedStructuralEncodingQueryCharge secretKey cache input * + (Fintype.card Digest : ℝ≥0∞)⁻¹ + change _ ≤ _ + expectedQueryCharge charge computation cache + induction computation using OracleComp.inductionOn generalizing cache hit with + | pure value => + simp only [runEncodingPrehitMonitor, OracleComp.construct_pure, + tsum_probOutput_pure_mul, expectedQueryCharge_pure, add_zero, le_refl] + | query_bind query next ih => + rw [runEncodingPrehitMonitor, OracleComp.construct_query_bind, tsum_probOutput_bind_mul, + expectedQueryCharge_query_bind] + calc + _ ≤ ∑' result, Pr[= result | (romImpl query).run cache] * + (encodingPrehitMonitorPotential secretKey result.2 + (hit || encodingPrehitQuery secretKey cache query result.1) + + expectedQueryCharge charge (next result.1) result.2) := by + apply ENNReal.tsum_le_tsum + intro result + by_cases hresult : result ∈ support ((romImpl query).run cache) + · exact mul_le_mul' le_rfl + (ih result.1 result.2 _ (finite_of_mem_support_romImpl hfinite hresult)) + · rw [probOutput_eq_zero_of_not_mem_support hresult, zero_mul, zero_mul] + _ = (∑' result, Pr[= result | (romImpl query).run cache] * + encodingPrehitMonitorPotential secretKey result.2 + (hit || encodingPrehitQuery secretKey cache query result.1)) + + ∑' result, Pr[= result | (romImpl query).run cache] * + expectedQueryCharge charge (next result.1) result.2 := by + simp_rw [mul_add, ENNReal.tsum_add] + _ ≤ (encodingPrehitMonitorPotential secretKey cache hit + hashQueryCharge charge cache query) + + ∑' result, Pr[= result | (romImpl query).run cache] * + expectedQueryCharge charge (next result.1) result.2 := + add_le_add (expected_encodingPrehitMonitorPotential_query_le secretKey query cache hit hfinite) le_rfl + _ = _ := by rw [add_assoc] + +theorem finite_of_mem_runEncodingPrehitMonitor + (secretKey : SecretKey) (computation : OracleComp OracleWorld α) + (cache : QueryCache HashSpec) (hit : Bool) (hfinite : Finite cache) + (result : (α × QueryCache HashSpec) × Bool) + (hresult : result ∈ support (runEncodingPrehitMonitor secretKey computation cache hit)) : + Finite result.1.2 := by + have hproject : result.1 ∈ support ((simulateQ romImpl computation).run cache) := by + rw [← runEncodingPrehitMonitor_project secretKey computation cache hit, support_map] + exact ⟨result, hresult, rfl⟩ + exact finite_cache_of_mem_support computation cache result.1.1 result.1.2 hproject hfinite + +theorem probEvent_prehit_or_bad_or_encodingBad_le_queryCharge + (secretKey : SecretKey) (computation : OracleComp OracleWorld α) : + Pr[fun result => result.2 = true ∨ + Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret result.1.2 ∨ + EncodingBad result.1.2 secretKey | runEncodingPrehitMonitor secretKey computation ∅ false] ≤ + expectedQueryCharge (refinedStructuralEncodingQueryCharge secretKey) computation ∅ * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + apply le_trans _ ((expected_runEncodingPrehitMonitor_potential_le_queryCharge + secretKey computation ∅ false finite_empty).trans_eq (by + simp [encodingPrehitMonitorPotential])) + rw [probEvent_eq_tsum_ite] + apply ENNReal.tsum_le_tsum + intro result + by_cases hevent : result.2 = true ∨ + Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret result.1.2 ∨ + EncodingBad result.1.2 secretKey + · rw [if_pos hevent] + by_cases hresult : result ∈ support (runEncodingPrehitMonitor secretKey computation ∅ false) + · have hpotential : encodingPrehitMonitorPotential secretKey result.1.2 result.2 = 1 := by + by_cases hhit : result.2 = true + · simp [encodingPrehitMonitorPotential, hhit] + · have hbad := hevent.resolve_left hhit + have hfinite := finite_of_mem_runEncodingPrehitMonitor secretKey computation ∅ false finite_empty result hresult + rw [encodingPrehitMonitorPotential, if_neg hhit, encodingSelectionAdaptivePotential_eq hfinite, + encodingSelectionTotalPotential_eq_one_of_bad_or_encodingBad hfinite hbad] + rw [hpotential, mul_one] + · rw [probOutput_eq_zero_of_not_mem_support hresult, zero_mul] + · rw [if_neg hevent] + exact bot_le + +end SphincsSecurity.Concrete.TightEncoding diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitSupport.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitSupport.lean new file mode 100644 index 00000000..87a6cd6d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitSupport.lean @@ -0,0 +1,97 @@ +import SphincsSecurity.Proof.EncodingPrehitComposition + +namespace SphincsSecurity.Concrete.TightEncoding + +open OracleComp OracleSpec + +theorem mem_support_simulateQ_of_mem_runEncodingPrehitMonitor + (secretKey : SecretKey) (computation : OracleComp OracleWorld α) + (cache : QueryCache HashSpec) (hit : Bool) (result : (α × QueryCache HashSpec) × Bool) + (hresult : result ∈ support (runEncodingPrehitMonitor secretKey computation cache hit)) : + result.1 ∈ support ((simulateQ romImpl computation).run cache) := by + rw [← runEncodingPrehitMonitor_project secretKey computation cache hit, support_map] + exact ⟨result, hresult, rfl⟩ + +theorem cache_le_of_mem_runEncodingPrehitMonitor + (secretKey : SecretKey) (computation : OracleComp OracleWorld α) + (cache : QueryCache HashSpec) (hit : Bool) (result : (α × QueryCache HashSpec) × Bool) + (hresult : result ∈ support (runEncodingPrehitMonitor secretKey computation cache hit)) : + cache ≤ result.1.2 := + simulateQ_romImpl_cache_le computation cache result.1 + (mem_support_simulateQ_of_mem_runEncodingPrehitMonitor secretKey computation cache hit result hresult) + +theorem runEncodingPrehitMonitor_hit_of_mem_support (secretKey : SecretKey) + (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) + (result : (α × QueryCache HashSpec) × Bool) + (hresult : result ∈ support (runEncodingPrehitMonitor secretKey computation cache true)) : + result.2 = true := by + induction computation using OracleComp.inductionOn generalizing cache with + | pure value => + simpa only [runEncodingPrehitMonitor_pure, support_pure, Set.mem_singleton_iff] using + congrArg Prod.snd (show result = ((value, cache), true) by + simpa only [runEncodingPrehitMonitor_pure, support_pure, Set.mem_singleton_iff] using hresult) + | query_bind query next ih => + rw [runEncodingPrehitMonitor, OracleComp.construct_query_bind, mem_support_bind_iff] at hresult + obtain ⟨response, _, hresult⟩ := hresult + simp only [Bool.true_or] at hresult + exact ih response.1 response.2 hresult + +theorem runEncodingPrehitMonitor_initial_false_of_mem_support + (secretKey : SecretKey) (computation : OracleComp OracleWorld α) + (cache : QueryCache HashSpec) (hit : Bool) (result : α × QueryCache HashSpec) + (hresult : (result, false) ∈ support (runEncodingPrehitMonitor secretKey computation cache hit)) : + hit = false := by + cases hit with + | false => rfl + | true => + exact Bool.noConfusion (runEncodingPrehitMonitor_hit_of_mem_support secretKey computation cache (result, false) hresult) + +theorem mem_support_runEncodingPrehitMonitor_bind_false_iff + (secretKey : SecretKey) (computation : OracleComp OracleWorld α) + (next : α → OracleComp OracleWorld β) (cache : QueryCache HashSpec) + (result : β × QueryCache HashSpec) : + (result, false) ∈ support (runEncodingPrehitMonitor secretKey (computation >>= next) cache false) ↔ + ∃ middle : α × QueryCache HashSpec, + (middle, false) ∈ support (runEncodingPrehitMonitor secretKey computation cache false) ∧ + (result, false) ∈ support (runEncodingPrehitMonitor secretKey (next middle.1) middle.2 false) := by + rw [runEncodingPrehitMonitor_bind, mem_support_bind_iff] + constructor + · rintro ⟨⟨middle, hit⟩, hmiddle, hresult⟩ + have hfalse := runEncodingPrehitMonitor_initial_false_of_mem_support secretKey (next middle.1) middle.2 hit result hresult + subst hit + exact ⟨middle, hmiddle, hresult⟩ + · rintro ⟨middle, hmiddle, hresult⟩ + exact ⟨(middle, false), hmiddle, hresult⟩ + +theorem mem_support_runEncodingPrehitMonitor_query_bind_false_iff + (secretKey : SecretKey) (query : OracleWorld.Domain) + (next : OracleWorld.Range query → OracleComp OracleWorld α) + (cache : QueryCache HashSpec) (result : α × QueryCache HashSpec) : + (result, false) ∈ support (runEncodingPrehitMonitor secretKey (OracleWorld.query query >>= next) cache false) ↔ + ∃ response : OracleWorld.Range query × QueryCache HashSpec, + response ∈ support ((romImpl query).run cache) ∧ + encodingPrehitQuery secretKey cache query response.1 = false ∧ + (result, false) ∈ support (runEncodingPrehitMonitor secretKey (next response.1) response.2 false) := by + rw [runEncodingPrehitMonitor, OracleComp.construct_query_bind, mem_support_bind_iff] + simp only [Bool.false_or] + constructor + · rintro ⟨response, hresponse, hresult⟩ + have hfalse := runEncodingPrehitMonitor_initial_false_of_mem_support secretKey (next response.1) response.2 + (encodingPrehitQuery secretKey cache query response.1) result hresult + exact ⟨response, hresponse, hfalse, hfalse ▸ hresult⟩ + · rintro ⟨response, hresponse, hfalse, hresult⟩ + exact ⟨response, hresponse, hfalse.symm ▸ hresult⟩ + +theorem not_encodingMessagePrehit_of_mem_support_query_false + (secretKey : SecretKey) (input : HashInput) (answer : HashOutput) + (cache finalCache : QueryCache HashSpec) (hit : Bool) (hfresh : cache input = none) + (hresult : ((answer, finalCache), false) ∈ support + (runEncodingPrehitMonitor secretKey (OracleWorld.query (.inr input)) cache hit)) : + ¬ EncodingMessagePrehit cache secretKey input answer := by + rw [runEncodingPrehitMonitor_query, support_map] at hresult + obtain ⟨response, _, heq⟩ := hresult + obtain ⟨rfl, hflag⟩ := Prod.mk.inj heq + have hfalse := (Bool.or_eq_false_iff.mp hflag).2 + simpa [encodingPrehitQuery, hfresh] using hfalse + +end SphincsSecurity.Concrete.TightEncoding diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitViewedBound.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitViewedBound.lean new file mode 100644 index 00000000..1287d2a6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitViewedBound.lean @@ -0,0 +1,124 @@ +import SphincsSecurity.Proof.EncodingPrehitViewedProjection +import SphincsSecurity.Proof.OtsOpeningRefinedReserve + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal TightEncoding + +noncomputable def sampledEncodingPrehitViewedGame (adversary : Adversary) : + ProbComp (SampledViewedResult × Bool) := do + let secrets ← sampleSecrets + (fun result => ((⟨secrets, (result.1, result.2.1)⟩ : SampledViewedResult), result.2.2)) <$> + gameAfterSecretsWithEncodingPrehitView adversary secrets.parameter secrets.otsSecret secrets.ftsSecret + +def encodingPrehitViewedSummary (result : SampledViewedResult × Bool) : EncodingPrehitGameResult := + ⟨result.1.secrets, result.1.result.1.2.2, result.1.result.2.cache, result.2⟩ + +def prehitFreeResidualOtsOpeningEvent (result : SampledViewedResult × Bool) : Prop := + result.2 = false ∧ SampledViewedEvent residualOtsOpeningEvent result.1 + +theorem sampledEncodingPrehitViewedGame_view_projection (adversary : Adversary) : + Prod.fst <$> sampledEncodingPrehitViewedGame adversary = sampledViewedGame adversary := by + rw [sampledEncodingPrehitViewedGame, sampledViewedGame, map_bind] + apply bind_congr + intro secrets + rw [← gameAfterSecretsWithEncodingPrehitView_projection] + simp + +theorem sampledEncodingPrehitViewedGame_monitor_projection (adversary : Adversary) : + encodingPrehitViewedSummary <$> sampledEncodingPrehitViewedGame adversary = + sampledEncodingPrehitGame adversary := by + rw [sampledEncodingPrehitViewedGame, sampledEncodingPrehitGame, map_bind] + apply bind_congr + intro secrets + rw [← gameAfterSecretsWithEncodingPrehitView_monitor_projection] + simp [encodingPrehitViewedSummary] + +theorem probEvent_sampledEncodingPrehitViewedGame_bad_le_queryCharge (adversary : Adversary) : + Pr[fun result => (encodingPrehitViewedSummary result).Bad | sampledEncodingPrehitViewedGame adversary] ≤ + sampledQueryCharge refinedStructuralEncodingQueryCharge adversary * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + have hbound := probEvent_sampledEncodingPrehitGame_bad_le_queryCharge adversary + rw [← sampledEncodingPrehitViewedGame_monitor_projection, probEvent_map] at hbound + exact hbound + +theorem sampled_jointPrimitive_prehit_classify (result : SampledViewedResult × Bool) + (hprimitive : SampledViewedEvent jointPrimitiveEvent result.1) : + (encodingPrehitViewedSummary result).Bad ∨ + prehitFreeResidualOtsOpeningEvent result ∨ SampledViewedEvent cleanUncoveredEvent result.1 := by + classical + obtain ⟨hwin, hevent⟩ := hprimitive + by_cases hhit : result.2 = true + · exact Or.inl (Or.inl hhit) + by_cases hbad : Bad result.1.secrets.parameter result.1.secrets.otsSecret result.1.secrets.ftsSecret + result.1.result.2.cache + · exact Or.inl (Or.inr (Or.inl hbad)) + by_cases hencoding : ViewedEncodingCollisionWitness result.1.secrets.parameter result.1.secrets.otsSecret + result.1.secrets.ftsSecret result.1.result + · apply Or.inl + apply Or.inr + apply Or.inr + exact (encodingBad_mk_root_iff result.1.secrets.parameter result.1.secrets.otsSecret + result.1.secrets.ftsSecret result.1.result.2.cache result.1.result.1.1 default).mp hencoding.encodingBad + rcases (hevent.resolve_left hbad).resolve_left hencoding with hots | hfts + · exact Or.inr (Or.inl ⟨Bool.eq_false_iff.mpr hhit, hwin, hbad, hencoding, hots⟩) + · exact Or.inr (Or.inr hfts) + +theorem probEvent_sampled_jointPrimitive_le_prehit_charge_add_openings (adversary : Adversary) : + Pr[SampledViewedEvent jointPrimitiveEvent | sampledViewedGame adversary] ≤ + sampledQueryCharge refinedStructuralEncodingQueryCharge adversary * (Fintype.card Digest : ℝ≥0∞)⁻¹ + + (Pr[prehitFreeResidualOtsOpeningEvent | sampledEncodingPrehitViewedGame adversary] + + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary]) := by + rw [← sampledEncodingPrehitViewedGame_view_projection, probEvent_map] + apply (probEvent_mono (q := fun result => (encodingPrehitViewedSummary result).Bad ∨ + prehitFreeResidualOtsOpeningEvent result ∨ SampledViewedEvent cleanUncoveredEvent result.1) + (fun result _ hprimitive => sampled_jointPrimitive_prehit_classify result hprimitive)).trans + apply (probEvent_or_le _ _ _).trans + apply add_le_add (probEvent_sampledEncodingPrehitViewedGame_bad_le_queryCharge adversary) + have hopenings := probEvent_or_le (sampledEncodingPrehitViewedGame adversary) + prehitFreeResidualOtsOpeningEvent (fun result => SampledViewedEvent cleanUncoveredEvent result.1) + simpa only [probEvent_map, Function.comp_def] using hopenings + +theorem security126_of_sampled_prehitFree_otsOpening_le_refinedQueryReserve + (hots : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ 126 → + Pr[prehitFreeResidualOtsOpeningEvent | sampledEncodingPrehitViewedGame adversary] ≤ + sampledQueryCharge otsOpeningRefinedQueryReserve adversary * (Fintype.card Digest : ℝ≥0∞)⁻¹) : + HasClassicalSecurityBits scheme 126 := by + apply security126_of_sampled_jointPrimitive_le_ten_thirds_mul + intro q hqPos adversary hq hqMax + have hfts := FtsProbeSimulation.probEvent_sampledViewedGame_cleanUncovered_le_queryCharge126 adversary q hq hqMax + rw [← sampled_ftsOpeningQueryReserve_eq] at hfts + apply (probEvent_sampled_jointPrimitive_le_prehit_charge_add_openings adversary).trans + apply (add_le_add le_rfl (add_le_add (hots q hqPos adversary hq hqMax) hfts)).trans + calc + _ = ((sampledQueryCharge refinedStructuralEncodingQueryCharge adversary + + sampledQueryCharge ftsOpeningQueryReserve adversary) + + sampledQueryCharge otsOpeningRefinedQueryReserve adversary) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by ring + _ ≤ ((10 / 3 : ℝ≥0∞) * q) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := + mul_le_mul' (sampled_structural_add_refined_openingQueryReserve_le adversary q hq) le_rfl + _ = _ := by simp [digestBits] + +theorem security126_of_sampled_prehitFree_otsOpening_le_refinedQueryReserve_add_query_erasure + (hots : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ 126 → + Pr[prehitFreeResidualOtsOpeningEvent | sampledEncodingPrehitViewedGame adversary] ≤ + sampledQueryCharge otsOpeningRefinedQueryReserve adversary * (Fintype.card Digest : ℝ≥0∞)⁻¹ + + (q : ℝ≥0∞) * ((2 ^ 216 : Nat) : ℝ≥0∞)⁻¹) : + HasClassicalSecurityBits scheme 126 := by + apply security126_of_sampled_jointPrimitive_le_ten_thirds_mul_add_query_erasure + intro q hqPos adversary hq hqMax + have hfts := FtsProbeSimulation.probEvent_sampledViewedGame_cleanUncovered_le_queryCharge126 adversary q hq hqMax + rw [← sampled_ftsOpeningQueryReserve_eq] at hfts + apply (probEvent_sampled_jointPrimitive_le_prehit_charge_add_openings adversary).trans + apply (add_le_add le_rfl (add_le_add (hots q hqPos adversary hq hqMax) hfts)).trans + calc + _ = ((sampledQueryCharge refinedStructuralEncodingQueryCharge adversary + + sampledQueryCharge ftsOpeningQueryReserve adversary) + + sampledQueryCharge otsOpeningRefinedQueryReserve adversary) * (Fintype.card Digest : ℝ≥0∞)⁻¹ + + (q : ℝ≥0∞) * ((2 ^ 216 : Nat) : ℝ≥0∞)⁻¹ := by ring + _ ≤ ((10 / 3 : ℝ≥0∞) * q) * (Fintype.card Digest : ℝ≥0∞)⁻¹ + + (q : ℝ≥0∞) * ((2 ^ 216 : Nat) : ℝ≥0∞)⁻¹ := + add_le_add (mul_le_mul' (sampled_structural_add_refined_openingQueryReserve_le adversary q hq) le_rfl) le_rfl + _ = _ := by simp [digestBits] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitViewedProjection.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitViewedProjection.lean new file mode 100644 index 00000000..69917362 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitViewedProjection.lean @@ -0,0 +1,184 @@ +import SphincsSecurity.Proof.EncodingPrehitViewedTrace + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec TightEncoding + +noncomputable def encodingPrehitLoggedAdversaryImpl (accountingKey secretKey : SecretKey) : + QueryImpl (OracleWorld + SigningSpec) + (StateT ((QueryCache HashSpec × Bool) × QueryLog SigningSpec) ProbComp) := + fun input state => do + let result ← (((encodingPrehitImpl accountingKey).writerTMapBase + (forwardOracles + signingOracle scheme secretKey) input).run).run state.1 + pure (result.1.1, (result.2, state.2 ++ result.1.2)) + +theorem encodingPrehitLoggedAdversaryImpl_query (accountingKey secretKey : SecretKey) + (input : (OracleWorld + SigningSpec).Domain) + (cache : QueryCache HashSpec) (hit : Bool) (log : QueryLog SigningSpec) : + (encodingPrehitLoggedAdversaryImpl accountingKey secretKey input).run ((cache, hit), log) = + (fun result => (result.1.1.1, ((result.1.2, result.2), log ++ result.1.1.2))) <$> + runEncodingPrehitMonitor accountingKey + (((forwardOracles + signingOracle scheme secretKey) input).run) cache hit := by + change (((encodingPrehitImpl accountingKey).writerTMapBase + (forwardOracles + signingOracle scheme secretKey) input).run).run (cache, hit) >>= _ = _ + rw [QueryImpl.writerTMapBase, WriterT.run_mk, simulateQ_encodingPrehitImpl_run] + simp + +theorem encodingPrehitLoggedAdversaryImpl_run (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (cache : QueryCache HashSpec) (hit : Bool) (log : QueryLog SigningSpec) : + (simulateQ (encodingPrehitLoggedAdversaryImpl accountingKey secretKey) computation).run ((cache, hit), log) = + (fun result => (result.1.1.1, ((result.1.2, result.2), log ++ result.1.1.2))) <$> + runEncodingPrehitMonitor accountingKey + ((simulateQ (forwardOracles + signingOracle scheme secretKey) computation).run) cache hit := by + rw [runEncodingPrehitMonitor_eq_simulateQ, Functor.map_map, + QueryImpl.simulateQ_writerTMapBase_run] + induction computation using OracleComp.inductionOn generalizing cache hit log with + | pure value => simp + | query_bind input next ih => + simp only [simulateQ_bind, simulateQ_spec_query, WriterT.run_bind', + StateT.run_bind, StateT.run_map, map_bind, Functor.map_map] + simp only [encodingPrehitLoggedAdversaryImpl, StateT.run, bind_assoc, pure_bind] + apply bind_congr + intro result + simpa [List.append_assoc, StateT.run] using ih result.1.1 result.2.1 result.2.2 (log ++ result.1.2) + +def encodingPrehitViewedLogState (state : ViewedFullTraceState × Bool) : + (QueryCache HashSpec × Bool) × QueryLog SigningSpec := + ((state.1.cache, state.2), state.1.trace.signing.toSigningLog) + +theorem encodingPrehitViewedAdversaryImpl_query_log_projection + (accountingKey secretKey : SecretKey) (input : (OracleWorld + SigningSpec).Domain) + (state : ViewedFullTraceState × Bool) : + Prod.map id encodingPrehitViewedLogState <$> + (encodingPrehitViewedAdversaryImpl accountingKey secretKey input).run state = + (encodingPrehitLoggedAdversaryImpl accountingKey secretKey input).run + (encodingPrehitViewedLogState state) := by + change _ = (encodingPrehitLoggedAdversaryImpl accountingKey secretKey input).run + ((state.1.cache, state.2), state.1.trace.signing.toSigningLog) + rw [encodingPrehitLoggedAdversaryImpl_query] + cases input with + | inl query => + have hquery : (((forwardOracles + signingOracle scheme secretKey) (.inl query)).run) = + (fun output => (output, ([] : QueryLog SigningSpec))) <$> + (liftM (OracleWorld.query query) : OracleComp OracleWorld _) := rfl + rw [hquery] + erw [runEncodingPrehitMonitor_map] + cases query <;> + simp [encodingPrehitViewedAdversaryImpl, encodingPrehitViewedLogState, + fullAdversaryTraceUpdate, signingCacheTraceUpdate, StateT.run, Prod.map] + | inr request => + have hquery : (((forwardOracles + signingOracle scheme secretKey) (.inr request)).run) = + (fun output => (output, ([⟨request, output⟩] : QueryLog SigningSpec))) <$> + sign secretKey request := by + change (QueryImpl.withLogging (spec := SigningSpec) (fun request => scheme.sign secretKey request) request).run = _ + rw [QueryImpl.run_withLogging_apply] + rfl + have hsign := runEncodingPrehitMonitor_map accountingKey Prod.fst + (signWithView secretKey request) state.1.cache state.2 + rw [signWithView_fst] at hsign + rw [hquery] + erw [runEncodingPrehitMonitor_map] + rw [hsign] + simp [encodingPrehitViewedAdversaryImpl, encodingPrehitViewedLogState, + fullAdversaryTraceUpdate, signingCacheTraceUpdate, SigningCacheTrace.toSigningLog, + StateT.run, Prod.map] + +theorem encodingPrehitViewedAdversaryImpl_log_projection + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) : + Prod.map id encodingPrehitViewedLogState <$> + (simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run state = + (fun result => (result.1.1.1, + ((result.1.2, result.2), state.1.trace.signing.toSigningLog ++ result.1.1.2))) <$> + runEncodingPrehitMonitor accountingKey + ((simulateQ (forwardOracles + signingOracle scheme secretKey) computation).run) state.1.cache state.2 := by + rw [← encodingPrehitLoggedAdversaryImpl_run] + apply OracleComp.map_run_simulateQ_eq_of_query_map_eq + (encodingPrehitViewedAdversaryImpl accountingKey secretKey) + (encodingPrehitLoggedAdversaryImpl accountingKey secretKey) encodingPrehitViewedLogState + exact encodingPrehitViewedAdversaryImpl_query_log_projection accountingKey secretKey + +theorem encodingPrehitViewedAdversaryImpl_support_monitor + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) + (result : α × (ViewedFullTraceState × Bool)) + (hresult : result ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run state)) : + ∃ log : QueryLog SigningSpec, + (((result.1, log), result.2.1.cache), result.2.2) ∈ support + (runEncodingPrehitMonitor accountingKey + ((simulateQ (forwardOracles + signingOracle scheme secretKey) computation).run) state.1.cache state.2) ∧ + state.1.trace.signing.toSigningLog ++ log = result.2.1.trace.signing.toSigningLog := by + have hproject : Prod.map id encodingPrehitViewedLogState result ∈ support + ((fun result => (result.1.1.1, + ((result.1.2, result.2), state.1.trace.signing.toSigningLog ++ result.1.1.2))) <$> + runEncodingPrehitMonitor accountingKey + ((simulateQ (forwardOracles + signingOracle scheme secretKey) computation).run) state.1.cache state.2) := by + rw [← encodingPrehitViewedAdversaryImpl_log_projection, support_map] + exact ⟨result, hresult, rfl⟩ + rw [support_map] at hproject + obtain ⟨⟨⟨⟨value, log⟩, cache⟩, hit⟩, hrun, heq⟩ := hproject + simp only [Prod.map, id_eq, encodingPrehitViewedLogState, Prod.mk.injEq] at heq + obtain ⟨rfl, ⟨rfl, rfl⟩, hlog⟩ := heq + exact ⟨log, hrun, hlog⟩ + +theorem runEncodingPrehitMonitor_verifyWithView_fst (accountingKey : SecretKey) + (publicKey : PublicKey) (message : Message) (signature : Signature) + (cache : QueryCache HashSpec) (hit : Bool) : + runEncodingPrehitMonitor accountingKey (scheme.verify publicKey message signature) cache hit = + (fun result => ((result.1.1.1, result.1.2), result.2)) <$> + runEncodingPrehitMonitor accountingKey + (liftM (verifyWithView publicKey message signature) : OracleComp OracleWorld (Bool × FewTimeView)) + cache hit := by + have heq : scheme.verify publicKey message signature = + Prod.fst <$> (liftM (verifyWithView publicKey message signature) : + OracleComp OracleWorld (Bool × FewTimeView)) := by + rw [← liftM_map, verifyWithView_fst] + rfl + rw [heq, runEncodingPrehitMonitor_map] + +theorem gameRestWithEncodingPrehitView_monitor_projection (adversary : Adversary) + (accountingKey : SecretKey) (publicKey : PublicKey) (secretKey : SecretKey) + (initialCache : QueryCache HashSpec) (hit : Bool) : + (fun result => ((result.1.2, result.2.1.cache), result.2.2)) <$> + gameRestWithEncodingPrehitView adversary accountingKey publicKey secretKey initialCache hit = + runEncodingPrehitMonitor accountingKey (gameRest scheme adversary publicKey secretKey) initialCache hit := by + let finish : Forgery × ((QueryCache HashSpec × Bool) × QueryLog SigningSpec) → + ProbComp ((Bool × QueryCache HashSpec) × Bool) := fun result => do + let verified ← runEncodingPrehitMonitor accountingKey + (scheme.verify publicKey result.1.message result.1.signature) result.2.1.1 result.2.1.2 + pure ((decide (SigningTranscript.Valid result.2.2 ∧ + ¬ SigningTranscript.Contains result.2.2 result.1) && verified.1.1, verified.1.2), verified.2) + let state : ViewedFullTraceState × Bool := (⟨initialCache, ⟨[], [], []⟩, [], none⟩, hit) + calc + _ = (Prod.map id encodingPrehitViewedLogState <$> + (simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) + (adversary.main publicKey)).run state) >>= finish := by + simp [gameRestWithEncodingPrehitView, state, finish, encodingPrehitViewedLogState, + runEncodingPrehitMonitor_verifyWithView_fst, map_bind, bind_map_left, Prod.map] + rfl + _ = _ := by + rw [encodingPrehitViewedAdversaryImpl_log_projection] + rw [gameRest, runEncodingPrehitMonitor_bind] + simp only [runEncodingPrehitMonitor_bind, runEncodingPrehitMonitor_pure] + simp [finish, state, SigningCacheTrace.toSigningLog, bind_map_left] + +theorem gameAfterSecretsWithEncodingPrehitView_monitor_projection (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + (fun result => ((result.1.2.2, result.2.1.cache), result.2.2)) <$> + gameAfterSecretsWithEncodingPrehitView adversary parameter otsSecret ftsSecret = + runEncodingPrehitMonitor (primitiveAccountingKey parameter otsSecret ftsSecret) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ false := by + rw [gameAfterSecretsWithEncodingPrehitView, gameAfterSecrets, runEncodingPrehitMonitor_bind] + simp only [map_bind] + apply bind_congr + intro result + rw [← gameRestWithEncodingPrehitView_monitor_projection adversary + (primitiveAccountingKey parameter otsSecret ftsSecret) ⟨result.1.1, parameter⟩ + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ result.1.2 result.2] + simp + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitViewedTrace.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitViewedTrace.lean new file mode 100644 index 00000000..53105a06 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingPrehitViewedTrace.lean @@ -0,0 +1,129 @@ +import SphincsSecurity.Proof.EncodingPrehitComposition +import SphincsSecurity.Proof.EncodingPrehitGame + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec TightEncoding + +noncomputable def encodingPrehitViewedAdversaryImpl (accountingKey secretKey : SecretKey) : + QueryImpl (OracleWorld + SigningSpec) (StateT (ViewedFullTraceState × Bool) ProbComp) := by + intro input + cases input with + | inl query => + exact fun state => do + let result ← runEncodingPrehitMonitor accountingKey (OracleWorld.query query) state.1.cache state.2 + let trace := fullAdversaryTraceUpdate (.inl query) state.1.cache result.1.1 result.1.2 state.1.trace + pure (result.1.1, (⟨result.1.2, trace, state.1.views, state.1.targetView⟩, result.2)) + | inr request => + exact fun state => do + let result ← runEncodingPrehitMonitor accountingKey (signWithView secretKey request) state.1.cache state.2 + let trace := fullAdversaryTraceUpdate (.inr request) state.1.cache result.1.1.1 result.1.2 state.1.trace + pure (result.1.1.1, (⟨result.1.2, trace, state.1.views ++ [result.1.1.2], state.1.targetView⟩, result.2)) + +theorem encodingPrehitViewedAdversaryImpl_query_projection + (accountingKey secretKey : SecretKey) (input : (OracleWorld + SigningSpec).Domain) + (state : ViewedFullTraceState × Bool) : + (fun result => (result.1, result.2.1)) <$> + (encodingPrehitViewedAdversaryImpl accountingKey secretKey input).run state = + (viewedFullTracedMappedAdversaryImpl secretKey input).run state.1 := by + cases input with + | inl query => + have hp := runEncodingPrehitMonitor_project accountingKey + (liftM (OracleWorld.query query) : OracleComp OracleWorld _) state.1.cache state.2 + rw [simulateQ_spec_query] at hp + change Prod.fst <$> runEncodingPrehitMonitor accountingKey + (liftM (OracleWorld.query query) : OracleComp OracleWorld _) state.1.cache state.2 = + romImpl query state.1.cache at hp + have h := congrArg (fun run => + (fun result => (result.1, (⟨result.2, + fullAdversaryTraceUpdate (.inl query) state.1.cache result.1 result.2 state.1.trace, + state.1.views, state.1.targetView⟩ : ViewedFullTraceState))) <$> run) hp + cases query <;> + simpa [encodingPrehitViewedAdversaryImpl, viewedFullTracedMappedAdversaryImpl, StateT.run] using h + | inr request => + have hp := runEncodingPrehitMonitor_project accountingKey + (signWithView secretKey request) state.1.cache state.2 + change Prod.fst <$> runEncodingPrehitMonitor accountingKey + (signWithView secretKey request) state.1.cache state.2 = + simulateQ romImpl (signWithView secretKey request) state.1.cache at hp + simpa [encodingPrehitViewedAdversaryImpl, viewedFullTracedMappedAdversaryImpl, + StateT.run] using congrArg (fun run => + (fun result => (result.1.1, (⟨result.2, + fullAdversaryTraceUpdate (.inr request) state.1.cache result.1.1 result.2 state.1.trace, + state.1.views ++ [result.1.2], state.1.targetView⟩ : ViewedFullTraceState))) <$> run) hp + +theorem encodingPrehitViewedAdversaryImpl_projection + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) : + Prod.map id Prod.fst <$> + (simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run state = + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) computation).run state.1 := by + apply OracleComp.map_run_simulateQ_eq_of_query_map_eq + (encodingPrehitViewedAdversaryImpl accountingKey secretKey) + (viewedFullTracedMappedAdversaryImpl secretKey) Prod.fst + exact encodingPrehitViewedAdversaryImpl_query_projection accountingKey secretKey + +noncomputable def gameRestWithEncodingPrehitView (adversary : Adversary) + (accountingKey : SecretKey) (publicKey : PublicKey) (secretKey : SecretKey) + (initialCache : QueryCache HashSpec) (hit : Bool) : + ProbComp ((Forgery × Bool) × (ViewedFullTraceState × Bool)) := do + let (forgery, state) ← + (simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) + (adversary.main publicKey)).run (⟨initialCache, ⟨[], [], []⟩, [], none⟩, hit) + let result ← runEncodingPrehitMonitor accountingKey + (liftM (verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView)) state.1.cache state.2 + let log := state.1.trace.signing.toSigningLog + let verdict := decide (SigningTranscript.Valid log ∧ ¬ SigningTranscript.Contains log forgery) && result.1.1.1 + pure ((forgery, verdict), (⟨result.1.2, state.1.trace, state.1.views, some result.1.1.2⟩, result.2)) + +theorem gameRestWithEncodingPrehitView_projection (adversary : Adversary) + (accountingKey : SecretKey) (publicKey : PublicKey) (secretKey : SecretKey) + (initialCache : QueryCache HashSpec) (hit : Bool) : + (fun result => (result.1, result.2.1)) <$> + gameRestWithEncodingPrehitView adversary accountingKey publicKey secretKey initialCache hit = + gameRestWithViewTrace adversary publicKey secretKey initialCache := by + rw [gameRestWithEncodingPrehitView, gameRestWithViewTrace, + ← encodingPrehitViewedAdversaryImpl_projection accountingKey secretKey + (adversary.main publicKey) (⟨initialCache, ⟨[], [], []⟩, [], none⟩, hit)] + simp only [map_bind, bind_map_left, Prod.map, id_eq] + apply bind_congr + intro result + rw [← runEncodingPrehitMonitor_project accountingKey + (liftM (verifyWithView publicKey result.1.message result.1.signature) : + OracleComp OracleWorld (Bool × FewTimeView)) result.2.1.cache result.2.2] + simp + +noncomputable def gameAfterSecretsWithEncodingPrehitView (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ProbComp ((Digest × Forgery × Bool) × (ViewedFullTraceState × Bool)) := do + let accountingKey := primitiveAccountingKey parameter otsSecret ftsSecret + let rootResult ← runEncodingPrehitMonitor accountingKey + (liftM (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : + OracleComp HashSpec Digest) : OracleComp OracleWorld Digest) ∅ false + let result ← gameRestWithEncodingPrehitView adversary accountingKey ⟨rootResult.1.1, parameter⟩ + ⟨parameter, rootResult.1.1, otsSecret, ftsSecret⟩ rootResult.1.2 rootResult.2 + pure ((rootResult.1.1, result.1.1, result.1.2), result.2) + +theorem gameAfterSecretsWithEncodingPrehitView_projection (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + (fun result => (result.1, result.2.1)) <$> + gameAfterSecretsWithEncodingPrehitView adversary parameter otsSecret ftsSecret = + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret := by + rw [gameAfterSecretsWithEncodingPrehitView, gameAfterSecretsWithViewTrace, + ← runEncodingPrehitMonitor_project (primitiveAccountingKey parameter otsSecret ftsSecret) + (liftM (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : + OracleComp HashSpec Digest) : OracleComp OracleWorld Digest) ∅ false] + simp only [map_bind, bind_map_left] + apply bind_congr + intro result + rw [← gameRestWithEncodingPrehitView_projection adversary + (primitiveAccountingKey parameter otsSecret ftsSecret) ⟨result.1.1, parameter⟩ + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ result.1.2 result.2] + simp + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingProbability.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingProbability.lean new file mode 100644 index 00000000..2f959878 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingProbability.lean @@ -0,0 +1,215 @@ +import SphincsSecurity.Proof.Code +import SphincsSecurity.Proof.FewTimeUniform + +/-! +# Encoding acceptance probability + +The target-sum decoder accepts a finite nonempty set of 128-bit digests. A fresh random-oracle +answer has a uniform 128-bit truncation, so acceptance has exactly the corresponding finite ratio. +-/ + +namespace SphincsSecurity + +open OracleComp ENNReal +open scoped BigOperators + +set_option maxRecDepth 100000 + +theorem evalDist_truncateHash_uniform : + 𝒟[truncateHash <$> ($ᵗ HashOutput : ProbComp HashOutput)] = + 𝒟[($ᵗ Digest : ProbComp Digest)] := by + change 𝒟[(fun output : HashOutput => output.extractLsb' 0 digestBits) <$> + ($ᵗ HashOutput : ProbComp HashOutput)] = _ + exact evalDist_hashOutput_extract_uniform (width := digestBits) (by decide) + +theorem probEvent_uniform_truncateHash_eq (target : Digest) : + Pr[fun output : HashOutput => truncateHash output = target | + ($ᵗ HashOutput : ProbComp HashOutput)] = + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + rw [show (fun output : HashOutput => truncateHash output = target) = + (fun output => output = target) ∘ truncateHash from rfl] + rw [← probEvent_map] + rw [probEvent_congr' (fun _ _ => Iff.rfl) evalDist_truncateHash_uniform] + rw [probEvent_eq_eq_probOutput, probOutput_uniformSample] + +theorem probEvent_uniform_truncateHash_mem (targets : Finset Digest) : + Pr[fun output : HashOutput => truncateHash output ∈ targets | + ($ᵗ HashOutput : ProbComp HashOutput)] = + (targets.card : ℝ≥0∞) / (Fintype.card Digest : ℝ≥0∞) := by + rw [show (fun output : HashOutput => truncateHash output ∈ targets) = + (fun digest => digest ∈ targets) ∘ truncateHash from rfl] + rw [← probEvent_map] + rw [probEvent_congr' (fun _ _ => Iff.rfl) evalDist_truncateHash_uniform] + rw [probEvent_uniformSample] + rw [Finset.filter_univ_mem] + +theorem probEvent_uniform_encoding_valid : + Pr[fun output : HashOutput => TargetSum.ValidDigest (truncateHash output) | + ($ᵗ HashOutput : ProbComp HashOutput)] = + (TargetSum.validDigests.card : ℝ≥0∞) / + (Fintype.card Digest : ℝ≥0∞) := by + rw [show (fun output : HashOutput => TargetSum.ValidDigest (truncateHash output)) = + (fun output => TargetSum.ValidDigest output) ∘ truncateHash from rfl] + rw [← probEvent_map] + rw [probEvent_congr' (fun _ _ => Iff.rfl) evalDist_truncateHash_uniform] + rw [probEvent_uniformSample] + congr 1 + +theorem probEvent_uniform_encoding_invalid : + Pr[fun output : HashOutput => ¬ TargetSum.ValidDigest (truncateHash output) | + ($ᵗ HashOutput : ProbComp HashOutput)] = + 1 - (TargetSum.validDigests.card : ℝ≥0∞) / + (Fintype.card Digest : ℝ≥0∞) := by + have hcompl := probEvent_compl + ($ᵗ HashOutput : ProbComp HashOutput) + (fun output : HashOutput => TargetSum.ValidDigest (truncateHash output)) + simp only [probFailure_of_liftM_PMF, tsub_zero] at hcompl + rw [probEvent_uniform_encoding_valid] at hcompl + apply ENNReal.eq_sub_of_add_eq' (by simp) + rwa [add_comm] + +theorem uniformHashOutput_valid_bonus_sum_eq : + ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if TargetSum.ValidDigest (truncateHash output) then + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ else 0) = + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + calc + _ = Pr[fun output : HashOutput => TargetSum.ValidDigest (truncateHash output) | + ($ᵗ HashOutput : ProbComp HashOutput)] * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ := by + rw [probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_right] + apply tsum_congr + intro output + by_cases hvalid : TargetSum.ValidDigest (truncateHash output) + · simp only [hvalid, if_true] + · simp only [hvalid, if_false, mul_zero, zero_mul] + _ = ((TargetSum.validDigests.card : ℝ≥0∞) / + (Fintype.card Digest : ℝ≥0∞)) * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ := by + rw [probEvent_uniform_encoding_valid] + _ = _ := by + rw [div_eq_mul_inv] + calc + (TargetSum.validDigests.card : ℝ≥0∞) * + (Fintype.card Digest : ℝ≥0∞)⁻¹ * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ = + (Fintype.card Digest : ℝ≥0∞)⁻¹ * + ((TargetSum.validDigests.card : ℝ≥0∞) * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹) := by ac_rfl + _ = (Fintype.card Digest : ℝ≥0∞)⁻¹ * 1 := by + rw [ENNReal.mul_inv_cancel] + · exact_mod_cast Nat.ne_of_gt TargetSum.validDigests_card_pos + · exact ENNReal.natCast_ne_top _ + _ = _ := mul_one _ + +theorem uniformHashOutput_mem_bonus_sum_eq (targets : Finset Digest) : + ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if truncateHash output ∈ targets then 1 else 0) = + (targets.card : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + calc + _ = Pr[fun output : HashOutput => truncateHash output ∈ targets | + ($ᵗ HashOutput : ProbComp HashOutput)] := by + rw [probEvent_eq_tsum_ite] + apply tsum_congr + intro output + by_cases hmem : truncateHash output ∈ targets <;> simp [hmem] + _ = (targets.card : ℝ≥0∞) / + (Fintype.card Digest : ℝ≥0∞) := + probEvent_uniform_truncateHash_mem targets + _ = _ := by rw [div_eq_mul_inv] + +theorem uniformHashOutput_valid_scaled_bonus_sum_eq (scale : Nat) : + ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if TargetSum.ValidDigest (truncateHash output) then + (scale : ℝ≥0∞) * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ else 0) = + (scale : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + calc + _ = (scale : ℝ≥0∞) * + (∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if TargetSum.ValidDigest (truncateHash output) then + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ else 0)) := by + rw [← ENNReal.tsum_mul_left] + apply tsum_congr + intro output + by_cases hvalid : TargetSum.ValidDigest (truncateHash output) + · simp only [hvalid, ↓reduceIte] + ac_rfl + · simp only [hvalid, ↓reduceIte, mul_zero] + _ = _ := by rw [uniformHashOutput_valid_bonus_sum_eq] + +theorem uniformHashOutput_select_bonus_sum_le (targets : Finset Digest) : + ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if TargetSum.ValidDigest (truncateHash output) then + if truncateHash output ∈ targets then 1 else 0 + else + (targets.card : ℝ≥0∞) * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹) ≤ + (targets.card : ℝ≥0∞) * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ := by + let removed := (targets.card : ℝ≥0∞) * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ + calc + _ ≤ ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + ((if truncateHash output ∈ targets then 1 else 0) + + if TargetSum.ValidDigest (truncateHash output) then 0 else removed) := by + apply ENNReal.tsum_le_tsum + intro output + apply mul_le_mul_right + by_cases hvalid : TargetSum.ValidDigest (truncateHash output) + · by_cases hmem : truncateHash output ∈ targets <;> + simp only [hvalid, hmem, if_true, if_false, add_zero, le_refl] + · by_cases hmem : truncateHash output ∈ targets + · simp only [hvalid, hmem, if_true, if_false] + exact le_add_left le_rfl + · simp only [hvalid, hmem, if_false, zero_add] + exact le_rfl + _ = (∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if truncateHash output ∈ targets then 1 else 0)) + + ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if TargetSum.ValidDigest (truncateHash output) then 0 else removed) := by + simp_rw [mul_add] + rw [ENNReal.tsum_add] + _ = (∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if TargetSum.ValidDigest (truncateHash output) then removed else 0)) + + ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if TargetSum.ValidDigest (truncateHash output) then 0 else removed) := by + congr 1 + calc + (∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if truncateHash output ∈ targets then 1 else 0)) = + (targets.card : ℝ≥0∞) * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := + uniformHashOutput_mem_bonus_sum_eq targets + _ = ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if TargetSum.ValidDigest (truncateHash output) then removed else 0) := by + dsimp only [removed] + exact (uniformHashOutput_valid_scaled_bonus_sum_eq targets.card).symm + _ = ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * removed := by + rw [← ENNReal.tsum_add] + apply tsum_congr + intro output + rw [← mul_add] + by_cases hvalid : TargetSum.ValidDigest (truncateHash output) <;> + simp only [hvalid, if_true, if_false, add_zero, zero_add] + _ = removed := by + rw [ENNReal.tsum_mul_right] + have hmass : ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] = 1 := + tsum_probOutput_of_liftM_PMF ($ᵗ HashOutput : ProbComp HashOutput) + rw [hmass, one_mul] + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingRetry.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingRetry.lean new file mode 100644 index 00000000..cd25406d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingRetry.lean @@ -0,0 +1,186 @@ +import SphincsSecurity.Proof.EncodingProbability + +/-! +# Encoding retry risk + +Before an encoding target is installed, every admissible cached answer contributes the reciprocal of the number of admissible digests. A rejected fresh answer preserves this risk, while an admissible fresh answer either hits a pending digest or consumes the pending set. Both transitions are bounded directly on the real random-oracle answer distribution. +-/ + +namespace SphincsSecurity.EncodingRetry + +open OracleComp ENNReal + +set_option maxRecDepth 100000 + +noncomputable def pendingRisk (targets : Finset Digest) : ℝ≥0∞ := + (targets.card : ℝ≥0∞) * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ + +@[simp] theorem pendingRisk_empty : pendingRisk ∅ = 0 := by + unfold pendingRisk + rw [Finset.card_empty, Nat.cast_zero, zero_mul] + +theorem pendingRisk_insert_le (targets : Finset Digest) (digest : Digest) : + pendingRisk (insert digest targets) ≤ + pendingRisk targets + + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ := by + unfold pendingRisk + calc + ((insert digest targets).card : ℝ≥0∞) * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ ≤ + ((targets.card + 1 : Nat) : ℝ≥0∞) * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ := by + gcongr + exact_mod_cast Finset.card_insert_le digest targets + _ = (targets.card : ℝ≥0∞) * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ + + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ := by + push_cast + rw [add_mul, one_mul] + +noncomputable def applyQuery + (targets : Finset Digest) + (resume : HashOutput → Finset Digest → ProbComp Bool) : ProbComp Bool := do + let output ← ($ᵗ HashOutput : ProbComp HashOutput) + let digest := truncateHash output + if TargetSum.ValidDigest digest then + resume output (insert digest targets) + else + resume output targets + +theorem applyQuery_true_probability_le + (targets : Finset Digest) + (resume : HashOutput → Finset Digest → ProbComp Bool) + (base : ℝ≥0∞) + (hresume : ∀ output nextTargets, + Pr[(· = true) | resume output nextTargets] ≤ + base + pendingRisk nextTargets) : + Pr[(· = true) | applyQuery targets resume] ≤ + base + (Fintype.card Digest : ℝ≥0∞)⁻¹ + pendingRisk targets := by + unfold applyQuery + rw [probEvent_bind_eq_tsum] + calc + _ ≤ ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + (base + pendingRisk targets + + if TargetSum.ValidDigest (truncateHash output) then + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ else 0) := by + apply ENNReal.tsum_le_tsum + intro output + apply mul_le_mul_right + by_cases hvalid : TargetSum.ValidDigest (truncateHash output) + · simp only [hvalid, if_true] + calc + Pr[(· = true) | resume output (insert (truncateHash output) targets)] ≤ + base + pendingRisk (insert (truncateHash output) targets) := + hresume output _ + _ ≤ base + (pendingRisk targets + + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹) := by + gcongr + exact pendingRisk_insert_le targets (truncateHash output) + _ = _ := by ac_rfl + · simpa only [hvalid, if_false, add_zero] using hresume output targets + _ = (base + pendingRisk targets) + + ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if TargetSum.ValidDigest (truncateHash output) then + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ else 0) := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_add, ENNReal.tsum_mul_right, + ENNReal.tsum_mul_right, + tsum_probOutput_of_liftM_PMF, one_mul] + simp only [one_mul] + _ = (base + pendingRisk targets) + + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + rw [SphincsSecurity.uniformHashOutput_valid_bonus_sum_eq] + _ = _ := by ac_rfl + +noncomputable def applySelect + (targets : Finset Digest) + (resume : HashOutput → Finset Digest → ProbComp Bool) : ProbComp Bool := do + let output ← ($ᵗ HashOutput : ProbComp HashOutput) + let digest := truncateHash output + if TargetSum.ValidDigest digest then + if digest ∈ targets then pure true else resume output ∅ + else + resume output targets + +theorem applySelect_true_probability_le + (targets : Finset Digest) + (resume : HashOutput → Finset Digest → ProbComp Bool) + (base : ℝ≥0∞) + (hresume : ∀ output nextTargets, + Pr[(· = true) | resume output nextTargets] ≤ + base + pendingRisk nextTargets) : + Pr[(· = true) | applySelect targets resume] ≤ + base + pendingRisk targets := by + unfold applySelect + rw [probEvent_bind_eq_tsum] + calc + _ ≤ ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + (base + + if TargetSum.ValidDigest (truncateHash output) then + if truncateHash output ∈ targets then 1 else 0 + else pendingRisk targets) := by + apply ENNReal.tsum_le_tsum + intro output + apply mul_le_mul_right + by_cases hvalid : TargetSum.ValidDigest (truncateHash output) + · simp only [hvalid, if_true] + by_cases hmem : truncateHash output ∈ targets + · simp only [hmem, if_true, probEvent_pure] + exact le_add_left le_rfl + · simp only [hmem, if_false] + simpa using hresume output ∅ + · simp only [hvalid, if_false] + exact hresume output targets + _ = base + ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if TargetSum.ValidDigest (truncateHash output) then + if truncateHash output ∈ targets then 1 else 0 + else pendingRisk targets) := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_mul_right, + tsum_probOutput_of_liftM_PMF, one_mul] + _ ≤ base + pendingRisk targets := by + gcongr + exact SphincsSecurity.uniformHashOutput_select_bonus_sum_le targets + +noncomputable def buildThenSelect : Nat → Finset Digest → ProbComp Bool + | 0, targets => applySelect targets fun _ _ => pure false + | steps + 1, targets => + applyQuery targets fun _ nextTargets => buildThenSelect steps nextTargets + +theorem buildThenSelect_true_probability_le + (steps : Nat) (targets : Finset Digest) : + Pr[(· = true) | buildThenSelect steps targets] ≤ + (steps : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ + + pendingRisk targets := by + induction steps generalizing targets with + | zero => + rw [buildThenSelect] + simpa using applySelect_true_probability_le targets + (fun _ _ => pure false) 0 (by simp) + | succ steps ih => + rw [buildThenSelect] + calc + Pr[(· = true) | + applyQuery targets fun _ nextTargets => buildThenSelect steps nextTargets] ≤ + (steps : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ + + (Fintype.card Digest : ℝ≥0∞)⁻¹ + pendingRisk targets := + applyQuery_true_probability_le targets + (fun _ nextTargets => buildThenSelect steps nextTargets) + ((steps : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹) + (fun _ nextTargets => ih nextTargets) + _ = ((steps + 1 : Nat) : ℝ≥0∞) * + (Fintype.card Digest : ℝ≥0∞)⁻¹ + pendingRisk targets := by + push_cast + rw [add_mul, one_mul] + +theorem buildThenSelect_empty_true_probability_le (steps : Nat) : + Pr[(· = true) | buildThenSelect steps ∅] ≤ + (steps : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + simpa using buildThenSelect_true_probability_le steps ∅ + +end SphincsSecurity.EncodingRetry diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingRetryCharge.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingRetryCharge.lean new file mode 100644 index 00000000..e5f72c8a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingRetryCharge.lean @@ -0,0 +1,392 @@ +import SphincsSecurity.Proof.EncodingCharge +import SphincsSecurity.Proof.EncodingRetry + +/-! +# Cache potential for encoding retries + +At an encoding position without a canonical target, every distinct admissible digest already in the +cache is pending risk. Pinning the target consumes the whole contribution at that position. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +def encodingValidAnswers (parameter : PublicParameter) (cache : QueryCache HashSpec) + (position : EncodingPosition) : Set Digest := + {digest | TargetSum.ValidDigest digest ∧ + ∃ input answer, cache input = some answer ∧ + AtEncodingPosition parameter input position ∧ truncateHash answer = digest} + +theorem encodingValidAnswers_finite {parameter : PublicParameter} + {cache : QueryCache HashSpec} (hfinite : Finite cache) (position : EncodingPosition) : + (encodingValidAnswers parameter cache position).Finite := by + let answers : Set HashOutput := {answer | ∃ input, cache input = some answer ∧ + AtEncodingPosition parameter input position} + have hanswers : answers.Finite := by + let cachedInputs : Set HashInput := {input | cache input ≠ none} + have hcachedInputs : cachedInputs.Finite := hfinite + let answerOf : HashInput → HashOutput := fun input => (cache input).getD 0 + apply (hcachedInputs.image answerOf).subset + rintro answer ⟨input, hcached, hposition⟩ + refine ⟨input, by simp [cachedInputs, hcached], ?_⟩ + simp [answerOf, hcached] + apply (hanswers.image truncateHash).subset + rintro digest ⟨_, input, answer, hcached, hposition, rfl⟩ + exact ⟨answer, ⟨input, hcached, hposition⟩, rfl⟩ + +theorem encodingValidAnswers_eq_validAnswerTargets {parameter : PublicParameter} + {cache : QueryCache HashSpec} (hfinite : Finite cache) (position : EncodingPosition) : + encodingValidAnswers parameter cache position = + ↑(encodingValidAnswerTargets parameter cache hfinite position) := by + ext digest + constructor + · rintro ⟨hvalid, input, answer, hcached, hposition, rfl⟩ + exact cachedValidAnswer_mem_encodingValidAnswerTargets hfinite hcached hposition hvalid + · intro hmem + change digest ∈ encodingValidAnswerTargets parameter cache hfinite position at hmem + rw [encodingValidAnswerTargets, Finset.mem_filter, encodingAnswerTargets, + Finset.mem_image] at hmem + obtain ⟨⟨input, hinput, hdigest⟩, hvalid⟩ := hmem + rw [Set.Finite.mem_toFinset] at hinput + obtain ⟨hcached, hposition⟩ := hinput + obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hcached + refine ⟨hvalid, input, answer, hanswer, hposition, ?_⟩ + simpa only [fromCache, hanswer, Option.getD_some] using hdigest + +theorem encodingValidAnswers_ncard_eq_validAnswerTargets_card + {parameter : PublicParameter} {cache : QueryCache HashSpec} + (hfinite : Finite cache) (position : EncodingPosition) : + (encodingValidAnswers parameter cache position).ncard = + (encodingValidAnswerTargets parameter cache hfinite position).card := by + rw [encodingValidAnswers_eq_validAnswerTargets hfinite position, Set.ncard_coe_finset] + +theorem encodingValidAnswers_mono {parameter : PublicParameter} + {cache cache' : QueryCache HashSpec} (hle : cache ≤ cache') + (position : EncodingPosition) : + encodingValidAnswers parameter cache position ⊆ + encodingValidAnswers parameter cache' position := by + rintro digest ⟨hvalid, input, answer, hcached, hposition, hdigest⟩ + exact ⟨hvalid, input, answer, hle hcached, hposition, hdigest⟩ + +theorem encodingValidAnswers_cacheQuery_subset_insert + {parameter : PublicParameter} {cache : QueryCache HashSpec} + {input : HashInput} {answer : HashOutput} (position : EncodingPosition) : + encodingValidAnswers parameter (cache.cacheQuery input answer) position ⊆ + insert (truncateHash answer) (encodingValidAnswers parameter cache position) := by + rintro digest ⟨hvalid, cachedInput, cachedAnswer, hcached, hposition, hdigest⟩ + by_cases heq : cachedInput = input + · subst cachedInput + have hanswer : cachedAnswer = answer := by + rw [QueryCache.cacheQuery_self] at hcached + exact Option.some.inj hcached.symm + subst cachedAnswer + exact Set.mem_insert_iff.mpr (Or.inl hdigest.symm) + · apply Set.mem_insert_of_mem + exact ⟨hvalid, cachedInput, cachedAnswer, by + rwa [QueryCache.cacheQuery_of_ne _ _ heq] at hcached, hposition, hdigest⟩ + +theorem encodingValidAnswers_cacheQuery_ncard_le + {parameter : PublicParameter} {cache : QueryCache HashSpec} + (hfinite : Finite cache) {input : HashInput} {answer : HashOutput} + (position : EncodingPosition) : + (encodingValidAnswers parameter (cache.cacheQuery input answer) position).ncard ≤ + (encodingValidAnswers parameter cache position).ncard + 1 := by + have hold := encodingValidAnswers_finite (parameter := parameter) hfinite position + exact (Set.ncard_le_ncard + (encodingValidAnswers_cacheQuery_subset_insert position) (hold.insert _)).trans + (Set.ncard_insert_le _ _) + +theorem encodingValidAnswers_cacheQuery_eq_of_not_atPosition + {parameter : PublicParameter} {cache : QueryCache HashSpec} + {input : HashInput} {answer : HashOutput} (huncached : cache input = none) + (position : EncodingPosition) + (hnotAt : ¬ AtEncodingPosition parameter input position) : + encodingValidAnswers parameter (cache.cacheQuery input answer) position = + encodingValidAnswers parameter cache position := by + apply Set.Subset.antisymm + · rintro digest ⟨hvalid, cachedInput, cachedAnswer, hcached, hposition, hdigest⟩ + have hne : cachedInput ≠ input := by + intro heq + subst cachedInput + exact hnotAt hposition + exact ⟨hvalid, cachedInput, cachedAnswer, by + rwa [QueryCache.cacheQuery_of_ne _ _ hne] at hcached, hposition, hdigest⟩ + · exact encodingValidAnswers_mono + (le_cacheQuery (cache := cache) (input := input) (answer := answer) huncached) position + +theorem encodingValidAnswers_cacheQuery_eq_of_invalid + {parameter : PublicParameter} {cache : QueryCache HashSpec} + {input : HashInput} {answer : HashOutput} (huncached : cache input = none) + (position : EncodingPosition) + (hinvalid : ¬ TargetSum.ValidDigest (truncateHash answer)) : + encodingValidAnswers parameter (cache.cacheQuery input answer) position = + encodingValidAnswers parameter cache position := by + apply Set.Subset.antisymm + · rintro digest ⟨hvalid, cachedInput, cachedAnswer, hcached, hposition, hdigest⟩ + have hne : cachedInput ≠ input := by + intro heq + subst cachedInput + have hanswer : cachedAnswer = answer := by + rw [QueryCache.cacheQuery_self] at hcached + exact Option.some.inj hcached.symm + subst cachedAnswer + exact hinvalid (hdigest ▸ hvalid) + exact ⟨hvalid, cachedInput, cachedAnswer, by + rwa [QueryCache.cacheQuery_of_ne _ _ hne] at hcached, hposition, hdigest⟩ + · exact encodingValidAnswers_mono + (le_cacheQuery (cache := cache) (input := input) (answer := answer) huncached) position + +noncomputable def encodingRetryContribution (cache : QueryCache HashSpec) + (secretKey : SecretKey) (position : EncodingPosition) : ℝ≥0∞ := + open Classical in + if HasEncodingTarget cache secretKey position then 0 + else ((encodingValidAnswers secretKey.parameter cache position).ncard : ℝ≥0∞) * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ + +noncomputable def encodingRetryPotential (cache : QueryCache HashSpec) + (secretKey : SecretKey) : ℝ≥0∞ := + ∑ position : EncodingPosition, encodingRetryContribution cache secretKey position + +theorem encodingRetryContribution_eq_zero_of_target + {cache : QueryCache HashSpec} {secretKey : SecretKey} {position : EncodingPosition} + (htarget : HasEncodingTarget cache secretKey position) : + encodingRetryContribution cache secretKey position = 0 := by + classical + rw [encodingRetryContribution, if_pos htarget] + +theorem encodingRetryContribution_eq_pendingRisk + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {position : EncodingPosition} + (hnotTarget : ¬ HasEncodingTarget cache secretKey position) : + encodingRetryContribution cache secretKey position = + EncodingRetry.pendingRisk + (encodingValidAnswerTargets secretKey.parameter cache hfinite position) := by + classical + rw [encodingRetryContribution, if_neg hnotTarget, EncodingRetry.pendingRisk, + encodingValidAnswers_ncard_eq_validAnswerTargets_card hfinite position] + +theorem encodingRetryContribution_cacheQuery_le_of_not_atPosition + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} (huncached : cache input = none) + (position : EncodingPosition) + (hnotAt : ¬ AtEncodingPosition secretKey.parameter input position) : + encodingRetryContribution (cache.cacheQuery input answer) secretKey position ≤ + encodingRetryContribution cache secretKey position := by + classical + have hle := le_cacheQuery (cache := cache) (input := input) (answer := answer) huncached + rw [encodingRetryContribution, encodingRetryContribution] + by_cases htarget : HasEncodingTarget cache secretKey position + · rw [if_pos htarget, if_pos (htarget.mono hle)] + · rw [if_neg htarget] + by_cases htarget' : HasEncodingTarget (cache.cacheQuery input answer) secretKey position + · rw [if_pos htarget'] + exact bot_le + · rw [if_neg htarget', encodingValidAnswers_cacheQuery_eq_of_not_atPosition + huncached position hnotAt] + +theorem encodingRetryContribution_cacheQuery_le + {cache : QueryCache HashSpec} (hfinite : Finite cache) {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} (huncached : cache input = none) + (position : EncodingPosition) : + encodingRetryContribution (cache.cacheQuery input answer) secretKey position ≤ + encodingRetryContribution cache secretKey position + + if TargetSum.ValidDigest (truncateHash answer) then + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ else 0 := by + classical + have hle := le_cacheQuery (cache := cache) (input := input) (answer := answer) huncached + rw [encodingRetryContribution, encodingRetryContribution] + by_cases htarget : HasEncodingTarget cache secretKey position + · rw [if_pos htarget, if_pos (htarget.mono hle)] + exact bot_le + · rw [if_neg htarget] + by_cases htarget' : HasEncodingTarget (cache.cacheQuery input answer) secretKey position + · rw [if_pos htarget'] + exact bot_le + · rw [if_neg htarget'] + by_cases hvalid : TargetSum.ValidDigest (truncateHash answer) + · rw [if_pos hvalid] + calc + ((encodingValidAnswers secretKey.parameter + (cache.cacheQuery input answer) position).ncard : ℝ≥0∞) * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ ≤ + (((encodingValidAnswers secretKey.parameter cache position).ncard + 1 : Nat) : + ℝ≥0∞) * (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ := by + gcongr + exact_mod_cast encodingValidAnswers_cacheQuery_ncard_le hfinite position + _ = ((encodingValidAnswers secretKey.parameter cache position).ncard : ℝ≥0∞) * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ + + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ := by + push_cast + rw [add_mul, one_mul] + · rw [if_neg hvalid, add_zero, + encodingValidAnswers_cacheQuery_eq_of_invalid huncached position hvalid] + +theorem encodingRetryPotential_cacheQuery_le + {cache : QueryCache HashSpec} (hfinite : Finite cache) {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} (huncached : cache input = none) : + encodingRetryPotential (cache.cacheQuery input answer) secretKey ≤ + encodingRetryPotential cache secretKey + + if TargetSum.ValidDigest (truncateHash answer) then + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ else 0 := by + classical + by_cases hat : ∃ position, AtEncodingPosition secretKey.parameter input position + · obtain ⟨queriedPosition, hqueried⟩ := hat + rw [encodingRetryPotential, encodingRetryPotential] + calc + ∑ position : EncodingPosition, + encodingRetryContribution (cache.cacheQuery input answer) secretKey position ≤ + ∑ position : EncodingPosition, + (encodingRetryContribution cache secretKey position + + if position = queriedPosition then + (if TargetSum.ValidDigest (truncateHash answer) then + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ else 0) else 0) := by + apply Finset.sum_le_sum + intro position _ + by_cases heq : position = queriedPosition + · rw [if_pos heq] + exact encodingRetryContribution_cacheQuery_le hfinite huncached position + · rw [if_neg heq, add_zero] + apply encodingRetryContribution_cacheQuery_le_of_not_atPosition huncached position + intro hposition + exact heq (atEncodingPosition_unique hposition hqueried) + _ = (∑ position : EncodingPosition, + encodingRetryContribution cache secretKey position) + + if TargetSum.ValidDigest (truncateHash answer) then + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ else 0 := by + rw [Finset.sum_add_distrib, Fintype.sum_ite_eq'] + · rw [encodingRetryPotential, encodingRetryPotential] + calc + ∑ position : EncodingPosition, + encodingRetryContribution (cache.cacheQuery input answer) secretKey position ≤ + ∑ position : EncodingPosition, + encodingRetryContribution cache secretKey position := by + apply Finset.sum_le_sum + intro position _ + exact encodingRetryContribution_cacheQuery_le_of_not_atPosition huncached position + (fun hposition => hat ⟨position, hposition⟩) + _ ≤ _ := le_add_right le_rfl + +theorem encodingRetryPotential_add_contribution_le_of_new_target + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} {position : EncodingPosition} + (huncached : cache input = none) + (hnotTarget : ¬ HasEncodingTarget cache secretKey position) + (htarget : HasEncodingTarget (cache.cacheQuery input answer) secretKey position) : + encodingRetryPotential (cache.cacheQuery input answer) secretKey + + encodingRetryContribution cache secretKey position ≤ + encodingRetryPotential cache secretKey := by + classical + have hother : ∀ otherPosition : EncodingPosition, otherPosition ≠ position → + encodingRetryContribution (cache.cacheQuery input answer) secretKey otherPosition ≤ + encodingRetryContribution cache secretKey otherPosition := by + intro otherPosition hne + apply encodingRetryContribution_cacheQuery_le_of_not_atPosition huncached otherPosition + intro hinput + have htargetOld := htarget.of_cacheQuery_of_other_encodingPosition huncached hinput + hne + exact hnotTarget htargetOld + rw [encodingRetryPotential, encodingRetryPotential] + calc + (∑ otherPosition : EncodingPosition, + encodingRetryContribution (cache.cacheQuery input answer) secretKey otherPosition) + + encodingRetryContribution cache secretKey position = + ∑ otherPosition : EncodingPosition, + (encodingRetryContribution (cache.cacheQuery input answer) secretKey otherPosition + + if otherPosition = position then + encodingRetryContribution cache secretKey position else 0) := by + rw [Finset.sum_add_distrib, Fintype.sum_ite_eq'] + _ ≤ ∑ otherPosition : EncodingPosition, + encodingRetryContribution cache secretKey otherPosition := by + apply Finset.sum_le_sum + intro otherPosition _ + by_cases heq : otherPosition = position + · have htargetOther : + HasEncodingTarget (cache.cacheQuery input answer) secretKey otherPosition := + heq.symm ▸ htarget + have hzero := encodingRetryContribution_eq_zero_of_target htargetOther + exact le_of_eq <| calc + encodingRetryContribution (cache.cacheQuery input answer) secretKey otherPosition + + (if otherPosition = position then + encodingRetryContribution cache secretKey position else 0) = + encodingRetryContribution (cache.cacheQuery input answer) secretKey otherPosition + + encodingRetryContribution cache secretKey position := by + exact congrArg _ (if_pos heq) + _ = 0 + encodingRetryContribution cache secretKey position := + congrArg (fun value => value + encodingRetryContribution cache secretKey position) + hzero + _ = encodingRetryContribution cache secretKey position := zero_add _ + _ = encodingRetryContribution cache secretKey otherPosition := + congrArg (fun selectedPosition => + encodingRetryContribution cache secretKey selectedPosition) heq.symm + · calc + encodingRetryContribution (cache.cacheQuery input answer) secretKey otherPosition + + (if otherPosition = position then + encodingRetryContribution cache secretKey position else 0) = + encodingRetryContribution (cache.cacheQuery input answer) secretKey otherPosition + + 0 := congrArg _ (if_neg heq) + _ = encodingRetryContribution (cache.cacheQuery input answer) secretKey otherPosition := + add_zero _ + _ ≤ encodingRetryContribution cache secretKey otherPosition := + hother otherPosition heq + +theorem encodingRetryPotential_add_pendingRisk_le_of_new_target + {cache : QueryCache HashSpec} (hfinite : Finite cache) {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} {position : EncodingPosition} + (huncached : cache input = none) + (hnotTarget : ¬ HasEncodingTarget cache secretKey position) + (htarget : HasEncodingTarget (cache.cacheQuery input answer) secretKey position) : + encodingRetryPotential (cache.cacheQuery input answer) secretKey + + EncodingRetry.pendingRisk + (encodingValidAnswerTargets secretKey.parameter cache hfinite position) ≤ + encodingRetryPotential cache secretKey := by + rw [← encodingRetryContribution_eq_pendingRisk hfinite hnotTarget] + exact encodingRetryPotential_add_contribution_le_of_new_target huncached hnotTarget htarget + +theorem uniformHashOutput_retryPotential_cacheQuery_sum_le + {cache : QueryCache HashSpec} (hfinite : Finite cache) {secretKey : SecretKey} + {input : HashInput} (huncached : cache input = none) : + ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingRetryPotential (cache.cacheQuery input answer) secretKey ≤ + encodingRetryPotential cache secretKey + + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (encodingRetryPotential cache secretKey + + if TargetSum.ValidDigest (truncateHash answer) then + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ else 0) := by + apply ENNReal.tsum_le_tsum + intro answer + gcongr + exact encodingRetryPotential_cacheQuery_le hfinite huncached + _ = encodingRetryPotential cache secretKey + + ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if TargetSum.ValidDigest (truncateHash answer) then + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ else 0) := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_mul_right, + tsum_probOutput_of_liftM_PMF, one_mul] + _ = _ := by + rw [uniformHashOutput_valid_bonus_sum_eq] + +@[simp] theorem encodingValidAnswers_empty (parameter : PublicParameter) + (position : EncodingPosition) : encodingValidAnswers parameter ∅ position = ∅ := by + ext digest + simp [encodingValidAnswers] + +@[simp] theorem encodingRetryContribution_empty (secretKey : SecretKey) + (position : EncodingPosition) : encodingRetryContribution ∅ secretKey position = 0 := by + rw [encodingRetryContribution, if_neg] + · rw [encodingValidAnswers_empty, Set.ncard_empty, Nat.cast_zero, zero_mul] + · rintro ⟨payload, _, _, _, _, _, _, _, _, hcached⟩ + simp at hcached + +@[simp] theorem encodingRetryPotential_empty (secretKey : SecretKey) : + encodingRetryPotential ∅ secretKey = 0 := by + rw [encodingRetryPotential] + simp + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingRisk.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingRisk.lean new file mode 100644 index 00000000..9e11ecfa --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingRisk.lean @@ -0,0 +1,202 @@ +import SphincsSecurity.Proof.EncodingRetryCharge +import SphincsSecurity.Proof.EncodingStageCharge + +/-! +# Encoding collision risk + +Before a canonical encoding target is pinned, the risk at one position is the normalized number of admissible cached answers. Once a latent collision and its target coexist, that position contributes one. The structural potential pays the finite target sets used when the layer message or target becomes settled. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +noncomputable def encodingCollisionRiskContribution + (cache : QueryCache HashSpec) (secretKey : SecretKey) + (position : EncodingPosition) : ℝ≥0∞ := + open Classical in + if LatentEncodingBadAt cache secretKey position ∧ + HasEncodingTarget cache secretKey position then + 1 + else + encodingRetryContribution cache secretKey position + +noncomputable def encodingCollisionRiskPotential + (cache : QueryCache HashSpec) (secretKey : SecretKey) : ℝ≥0∞ := + ∑ position : EncodingPosition, + encodingCollisionRiskContribution cache secretKey position + +noncomputable def encodingTotalRiskPotential + (cache : QueryCache HashSpec) (secretKey : SecretKey) : ℝ≥0∞ := + (encodingStructuralPotential cache secretKey : ℝ≥0∞) * + (Fintype.card Digest : ℝ≥0∞)⁻¹ + + encodingCollisionRiskPotential cache secretKey + +theorem encodingCollisionRiskContribution_eq_one + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {position : EncodingPosition} + (hlatent : LatentEncodingBadAt cache secretKey position) + (htarget : HasEncodingTarget cache secretKey position) : + encodingCollisionRiskContribution cache secretKey position = 1 := by + rw [encodingCollisionRiskContribution, if_pos ⟨hlatent, htarget⟩] + +theorem encodingCollisionRiskContribution_eq_retry + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {position : EncodingPosition} + (hclean : ¬ LatentEncodingBadAt cache secretKey position) : + encodingCollisionRiskContribution cache secretKey position = + encodingRetryContribution cache secretKey position := by + rw [encodingCollisionRiskContribution, if_neg] + exact fun hbad => hclean hbad.1 + +theorem encodingCollisionRiskContribution_eq_zero_of_clean_target + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {position : EncodingPosition} + (hclean : ¬ LatentEncodingBadAt cache secretKey position) + (htarget : HasEncodingTarget cache secretKey position) : + encodingCollisionRiskContribution cache secretKey position = 0 := by + rw [encodingCollisionRiskContribution_eq_retry hclean, + encodingRetryContribution_eq_zero_of_target htarget] + +theorem encodingCollisionRiskPotential_eq_retryPotential_of_not_encodingBad + {cache : QueryCache HashSpec} {secretKey : SecretKey} + (hclean : ¬ EncodingBad cache secretKey) : + encodingCollisionRiskPotential cache secretKey = + encodingRetryPotential cache secretKey := by + rw [encodingCollisionRiskPotential, encodingRetryPotential] + apply Finset.sum_congr rfl + intro position _ + rw [encodingCollisionRiskContribution, if_neg] + rintro ⟨hlatent, htarget⟩ + exact hclean (hlatent.encodingBad_of_hasTarget htarget) + +theorem encodingTotalRiskPotential_eq_of_not_encodingBad + {cache : QueryCache HashSpec} {secretKey : SecretKey} + (hclean : ¬ EncodingBad cache secretKey) : + encodingTotalRiskPotential cache secretKey = + (encodingStructuralPotential cache secretKey : ℝ≥0∞) * + (Fintype.card Digest : ℝ≥0∞)⁻¹ + + encodingRetryPotential cache secretKey := by + rw [encodingTotalRiskPotential, + encodingCollisionRiskPotential_eq_retryPotential_of_not_encodingBad hclean] + +@[simp] theorem encodingCollisionRiskPotential_empty (secretKey : SecretKey) : + encodingCollisionRiskPotential ∅ secretKey = 0 := by + rw [encodingCollisionRiskPotential] + apply Fintype.sum_eq_zero + intro position + rw [encodingCollisionRiskContribution, if_neg] + · exact encodingRetryContribution_empty secretKey position + · rintro ⟨hlatent, _⟩ + exact not_latentEncodingBad_empty secretKey ⟨position, hlatent⟩ + +@[simp] theorem encodingTotalRiskPotential_empty (secretKey : SecretKey) : + encodingTotalRiskPotential ∅ secretKey = 0 := by + rw [encodingTotalRiskPotential, encodingStructuralPotential_empty, + encodingCollisionRiskPotential_empty] + simp + +theorem one_le_encodingCollisionRiskPotential_of_encodingBad + {cache : QueryCache HashSpec} {secretKey : SecretKey} + (hbad : EncodingBad cache secretKey) : + 1 ≤ encodingCollisionRiskPotential cache secretKey := by + obtain ⟨position, htarget, hlatent⟩ := hbad.latent_with_target + rw [encodingCollisionRiskPotential, Fintype.sum_eq_add_sum_subtype_ne _ position, + encodingCollisionRiskContribution_eq_one hlatent htarget] + exact le_add_right le_rfl + +theorem one_le_encodingTotalRiskPotential_of_encodingBad + {cache : QueryCache HashSpec} {secretKey : SecretKey} + (hbad : EncodingBad cache secretKey) : + 1 ≤ encodingTotalRiskPotential cache secretKey := by + exact (one_le_encodingCollisionRiskPotential_of_encodingBad hbad).trans + (le_add_left le_rfl) + +theorem probEvent_encodingBad_le_expected_totalRisk + {alpha : Type} (oa : ProbComp (alpha × QueryCache HashSpec)) + (secretKey : SecretKey) : + Pr[fun result => EncodingBad result.2 secretKey | oa] ≤ + ∑' result, Pr[= result | oa] * + encodingTotalRiskPotential result.2 secretKey := by + classical + rw [probEvent_eq_tsum_ite] + apply ENNReal.tsum_le_tsum + intro result + by_cases hbad : EncodingBad result.2 secretKey + · rw [if_pos hbad] + exact le_mul_of_one_le_right bot_le + (one_le_encodingTotalRiskPotential_of_encodingBad hbad) + · rw [if_neg hbad] + exact bot_le + +theorem encodingRetry_buildThenSelect_sum_probability_le + (steps : EncodingPosition → Nat) (q : Nat) + (hsteps : (∑ position, steps position) ≤ q) : + (∑ position, + Pr[(· = true) | EncodingRetry.buildThenSelect (steps position) ∅]) ≤ + (q : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + calc + (∑ position, + Pr[(· = true) | EncodingRetry.buildThenSelect (steps position) ∅]) ≤ + ∑ position, (steps position : ℝ≥0∞) * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + apply Finset.sum_le_sum + intro position _ + exact EncodingRetry.buildThenSelect_empty_true_probability_le (steps position) + _ = ((∑ position, steps position : Nat) : ℝ≥0∞) * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + rw [Nat.cast_sum, Finset.sum_mul] + _ ≤ (q : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + exact mul_le_mul_left (by exact_mod_cast hsteps) + (Fintype.card Digest : ℝ≥0∞)⁻¹ + +theorem encodingRetry_cachedBuildThenSelect_sum_probability_le + {cache : QueryCache HashSpec} (hfinite : Finite cache) + (parameter : PublicParameter) : + (∑ position : EncodingPosition, + Pr[(· = true) | EncodingRetry.buildThenSelect + (encodingCachedAt parameter cache position).ncard ∅]) ≤ + QueryCache.enncard cache * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + have hbound := encodingRetry_buildThenSelect_sum_probability_le + (fun position => (encodingCachedAt parameter cache position).ncard) + {input | cache input ≠ none}.ncard + (sum_encodingCachedAt_ncard_le hfinite) + rw [hfinite.cachedInputs_ncard_toENNReal_eq_enncard] at hbound + exact hbound + +theorem encodingRetryPotential_le_enncard + {cache : QueryCache HashSpec} (hfinite : Finite cache) + (secretKey : SecretKey) : + encodingRetryPotential cache secretKey ≤ + QueryCache.enncard cache * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ := by + classical + calc + encodingRetryPotential cache secretKey ≤ + (∑ position : EncodingPosition, + ((encodingCachedAt secretKey.parameter cache position).ncard : ℝ≥0∞)) * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ := by + rw [encodingRetryPotential, Finset.sum_mul] + apply Finset.sum_le_sum + intro position _ + rw [encodingRetryContribution] + split + · exact bot_le + · exact mul_le_mul_left + (by + rw [encodingValidAnswers_ncard_eq_validAnswerTargets_card hfinite position] + exact_mod_cast encodingValidAnswerTargets_card_le hfinite position) + _ + _ = ((∑ position : EncodingPosition, + (encodingCachedAt secretKey.parameter cache position).ncard : Nat) : ℝ≥0∞) * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ := by + rw [Nat.cast_sum] + _ ≤ ({input | cache input ≠ none}.ncard : ℝ≥0∞) * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ := by + exact mul_le_mul_left + (by exact_mod_cast sum_encodingCachedAt_ncard_le hfinite) _ + _ = QueryCache.enncard cache * + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ := by + rw [hfinite.cachedInputs_ncard_toENNReal_eq_enncard] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingSelection.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingSelection.lean new file mode 100644 index 00000000..2c3e9bfd --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingSelection.lean @@ -0,0 +1,786 @@ +import SphincsSecurity.Proof.EncodingRetry + +/-! +# Conditional encoding selection risk + +A retry schedule records an input identifier together with the digest already cached there, or +`none` when that input is still missing. Completing the missing inputs with fresh oracle answers +and taking the first admissible digest gives the conditional distribution of the canonical encoding +target. Candidates retain their input identifiers, so the selected input is never mistaken for a +collision with itself. +-/ + +namespace SphincsSecurity.EncodingSelection + +open OracleComp ENNReal + +set_option maxRecDepth 100000 + +noncomputable def selectFirst {ι : Type} [DecidableEq ι] : + List (ι × Option Digest) → ProbComp (Option (ι × Digest)) + | [] => pure none + | (identifier, some digest) :: rest => + if TargetSum.ValidDigest digest then + pure (some (identifier, digest)) + else + selectFirst rest + | (identifier, none) :: rest => do + let output ← ($ᵗ HashOutput : ProbComp HashOutput) + let digest := truncateHash output + if TargetSum.ValidDigest digest then + pure (some (identifier, digest)) + else + selectFirst rest + +def selectedHits {ι : Type} [DecidableEq ι] (targets : Finset (ι × Digest)) : + Option (ι × Digest) → Prop + | none => False + | some selected => + ∃ candidate ∈ targets, + candidate.1 ≠ selected.1 ∧ candidate.2 = selected.2 + +noncomputable def selectionRisk {ι : Type} [DecidableEq ι] + (schedule : List (ι × Option Digest)) (targets : Finset (ι × Digest)) : ℝ≥0∞ := + Pr[selectedHits targets | selectFirst schedule] + +noncomputable def targetDigests {ι : Type} [DecidableEq ι] + (targets : Finset (ι × Digest)) : Finset Digest := + targets.image Prod.snd + +theorem digest_mem_targetDigests_of_selectedHits + {ι : Type} [DecidableEq ι] {targets : Finset (ι × Digest)} + {identifier : ι} {digest : Digest} + (hhit : selectedHits targets (some (identifier, digest))) : + digest ∈ targetDigests targets := by + obtain ⟨candidate, hcandidate, _, hdigest⟩ := hhit + rw [targetDigests, Finset.mem_image] + exact ⟨candidate, hcandidate, hdigest⟩ + +theorem selectFirst_support_some_valid {ι : Type} [DecidableEq ι] + {schedule : List (ι × Option Digest)} {identifier : ι} {digest : Digest} + (hmem : some (identifier, digest) ∈ support (selectFirst schedule)) : + TargetSum.ValidDigest digest := by + induction schedule with + | nil => simp [selectFirst] at hmem + | cons head rest ih => + obtain ⟨headIdentifier, headDigest⟩ := head + cases headDigest with + | none => + rw [selectFirst, mem_support_bind_iff] at hmem + obtain ⟨output, _houtput, hmem⟩ := hmem + by_cases hvalid : TargetSum.ValidDigest (truncateHash output) + · have heq : (identifier, digest) = + (headIdentifier, truncateHash output) := by + simpa [hvalid] using hmem + have hdigest : digest = truncateHash output := by + simpa using congrArg Prod.snd heq + rw [hdigest] + exact hvalid + · simp only [hvalid] at hmem + exact ih hmem + | some cachedDigest => + rw [selectFirst] at hmem + by_cases hvalid : TargetSum.ValidDigest cachedDigest + · have heq : (identifier, digest) = (headIdentifier, cachedDigest) := by + simpa [hvalid] using hmem + have hdigest : digest = cachedDigest := by + simpa using congrArg Prod.snd heq + rw [hdigest] + exact hvalid + · simp only [hvalid] at hmem + exact ih hmem + +@[simp] theorem selectionRisk_nil {ι : Type} [DecidableEq ι] + (targets : Finset (ι × Digest)) : + selectionRisk [] targets = 0 := by + simp [selectionRisk, selectFirst, selectedHits] + +theorem selectionRisk_cons_some_of_valid_of_hit {ι : Type} [DecidableEq ι] + (identifier : ι) (digest : Digest) (rest : List (ι × Option Digest)) + (targets : Finset (ι × Digest)) (hvalid : TargetSum.ValidDigest digest) + (hhit : selectedHits targets (some (identifier, digest))) : + selectionRisk ((identifier, some digest) :: rest) targets = 1 := by + classical + rw [selectionRisk, selectFirst, if_pos hvalid, probEvent_pure, if_pos hhit] + +theorem selectionRisk_cons_some_of_valid_of_miss {ι : Type} [DecidableEq ι] + (identifier : ι) (digest : Digest) (rest : List (ι × Option Digest)) + (targets : Finset (ι × Digest)) (hvalid : TargetSum.ValidDigest digest) + (hmiss : ¬ selectedHits targets (some (identifier, digest))) : + selectionRisk ((identifier, some digest) :: rest) targets = 0 := by + classical + rw [selectionRisk, selectFirst, if_pos hvalid, probEvent_pure, if_neg hmiss] + +theorem selectionRisk_cons_some_of_invalid {ι : Type} [DecidableEq ι] + (identifier : ι) (digest : Digest) (rest : List (ι × Option Digest)) + (targets : Finset (ι × Digest)) (hinvalid : ¬ TargetSum.ValidDigest digest) : + selectionRisk ((identifier, some digest) :: rest) targets = + selectionRisk rest targets := by + simp [selectionRisk, selectFirst, hinvalid] + +theorem selectionRisk_cons_some_of_valid_suffix_eq + {ι : Type} [DecidableEq ι] (identifier : ι) (digest : Digest) + (left right : List (ι × Option Digest)) (targets : Finset (ι × Digest)) + (hvalid : TargetSum.ValidDigest digest) : + selectionRisk ((identifier, some digest) :: left) targets = + selectionRisk ((identifier, some digest) :: right) targets := by + by_cases hhit : selectedHits targets (some (identifier, digest)) + · rw [selectionRisk_cons_some_of_valid_of_hit _ _ _ _ hvalid hhit, + selectionRisk_cons_some_of_valid_of_hit _ _ _ _ hvalid hhit] + · rw [selectionRisk_cons_some_of_valid_of_miss _ _ _ _ hvalid hhit, + selectionRisk_cons_some_of_valid_of_miss _ _ _ _ hvalid hhit] + +theorem selectionRisk_cons_none_eq {ι : Type} [DecidableEq ι] + (identifier : ι) (rest : List (ι × Option Digest)) + (targets : Finset (ι × Digest)) : + selectionRisk ((identifier, none) :: rest) targets = + ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + selectionRisk ((identifier, some (truncateHash output)) :: rest) targets := by + have hselect : selectFirst ((identifier, none) :: rest) = + ($ᵗ HashOutput : ProbComp HashOutput) >>= fun output => + selectFirst ((identifier, some (truncateHash output)) :: rest) := by + rw [selectFirst] + apply bind_congr + intro output + rw [selectFirst] + rw [selectionRisk, hselect, probEvent_bind_eq_tsum] + rfl + +inductive AllMissing {ι : Type} [DecidableEq ι] : + List (ι × Option Digest) → Prop where + | nil : AllMissing [] + | cons (identifier : ι) (rest : List (ι × Option Digest)) + (tail : AllMissing rest) : + AllMissing ((identifier, none) :: rest) + +theorem AllMissing.selectionRisk_le_pendingRisk + {ι : Type} [DecidableEq ι] + {schedule : List (ι × Option Digest)} (hmissing : AllMissing schedule) + (targets : Finset (ι × Digest)) : + selectionRisk schedule targets ≤ + EncodingRetry.pendingRisk (targetDigests targets) := by + induction hmissing with + | nil => + rw [selectionRisk_nil] + exact bot_le + | cons identifier rest _ ih => + rw [selectionRisk_cons_none_eq] + calc + _ ≤ ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if TargetSum.ValidDigest (truncateHash output) then + if truncateHash output ∈ targetDigests targets then 1 else 0 + else EncodingRetry.pendingRisk (targetDigests targets)) := by + apply ENNReal.tsum_le_tsum + intro output + apply mul_le_mul_right + by_cases hvalid : TargetSum.ValidDigest (truncateHash output) + · by_cases hhit : selectedHits targets + (some (identifier, truncateHash output)) + · have hmem := digest_mem_targetDigests_of_selectedHits hhit + rw [selectionRisk_cons_some_of_valid_of_hit _ _ _ _ hvalid hhit, + if_pos hvalid, if_pos hmem] + · rw [selectionRisk_cons_some_of_valid_of_miss _ _ _ _ hvalid hhit, + if_pos hvalid] + split <;> simp + · rw [selectionRisk_cons_some_of_invalid _ _ _ _ hvalid, + if_neg hvalid] + exact ih + _ ≤ EncodingRetry.pendingRisk (targetDigests targets) := by + exact SphincsSecurity.uniformHashOutput_select_bonus_sum_le + (targetDigests targets) + +theorem uniform_reveal_append_sum_eq {ι : Type} [DecidableEq ι] + (initial : List (ι × Option Digest)) (identifier : ι) + (rest : List (ι × Option Digest)) (targets : Finset (ι × Digest)) : + (∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + selectionRisk + (initial ++ (identifier, some (truncateHash output)) :: rest) targets) = + selectionRisk (initial ++ (identifier, none) :: rest) targets := by + induction initial with + | nil => + exact (selectionRisk_cons_none_eq identifier rest targets).symm + | cons head initial ih => + obtain ⟨headIdentifier, headDigest⟩ := head + cases headDigest with + | some digest => + by_cases hvalid : TargetSum.ValidDigest digest + · by_cases hhit : selectedHits targets (some (headIdentifier, digest)) + · simp_rw [List.cons_append, + selectionRisk_cons_some_of_valid_of_hit _ _ _ _ hvalid hhit] + rw [ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul] + · simp_rw [List.cons_append, + selectionRisk_cons_some_of_valid_of_miss _ _ _ _ hvalid hhit] + simp + · simp_rw [List.cons_append, + selectionRisk_cons_some_of_invalid _ _ _ _ hvalid] + exact ih + | none => + simp_rw [List.cons_append, selectionRisk_cons_none_eq] + simp_rw [← ENNReal.tsum_mul_left] + rw [ENNReal.tsum_comm] + apply tsum_congr + intro headOutput + simp_rw [mul_left_comm] + rw [ENNReal.tsum_mul_left] + congr 1 + by_cases hvalid : TargetSum.ValidDigest (truncateHash headOutput) + · by_cases hhit : selectedHits targets + (some (headIdentifier, truncateHash headOutput)) + · simp_rw [selectionRisk_cons_some_of_valid_of_hit _ _ _ _ hvalid hhit] + rw [ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul] + · simp_rw [selectionRisk_cons_some_of_valid_of_miss _ _ _ _ hvalid hhit] + simp + · simp_rw [selectionRisk_cons_some_of_invalid _ _ _ _ hvalid] + exact ih + +inductive FirstValid {ι : Type} [DecidableEq ι] : + List (ι × Option Digest) → ι → Digest → Prop where + | here (identifier : ι) (digest : Digest) (rest : List (ι × Option Digest)) + (valid : TargetSum.ValidDigest digest) : + FirstValid ((identifier, some digest) :: rest) identifier digest + | there (headIdentifier : ι) (headDigest : Digest) + (rest : List (ι × Option Digest)) (identifier : ι) (digest : Digest) + (invalid : ¬ TargetSum.ValidDigest headDigest) + (tail : FirstValid rest identifier digest) : + FirstValid ((headIdentifier, some headDigest) :: rest) identifier digest + +inductive ReachableCachedValid {ι : Type} [DecidableEq ι] : + List (ι × Option Digest) → ι → Digest → Prop where + | here (identifier : ι) (digest : Digest) (rest : List (ι × Option Digest)) + (valid : TargetSum.ValidDigest digest) : + ReachableCachedValid ((identifier, some digest) :: rest) identifier digest + | thereSome (headIdentifier : ι) (headDigest : Digest) + (rest : List (ι × Option Digest)) (identifier : ι) (digest : Digest) + (invalid : ¬ TargetSum.ValidDigest headDigest) + (tail : ReachableCachedValid rest identifier digest) : + ReachableCachedValid ((headIdentifier, some headDigest) :: rest) identifier digest + | thereNone (headIdentifier : ι) (rest : List (ι × Option Digest)) + (identifier : ι) (digest : Digest) + (tail : ReachableCachedValid rest identifier digest) : + ReachableCachedValid ((headIdentifier, none) :: rest) identifier digest + +theorem reachableCachedValid_cons_none_iff + {ι : Type} [DecidableEq ι] (headIdentifier identifier : ι) + (rest : List (ι × Option Digest)) (digest : Digest) : + ReachableCachedValid ((headIdentifier, none) :: rest) identifier digest ↔ + ReachableCachedValid rest identifier digest := by + constructor + · intro hreach + cases hreach with + | thereNone _ _ _ _ htail => exact htail + · exact ReachableCachedValid.thereNone headIdentifier rest identifier digest + +theorem reachableCachedValid_cons_some_iff + {ι : Type} [DecidableEq ι] (headIdentifier identifier : ι) + (headDigest : Digest) (rest : List (ι × Option Digest)) (digest : Digest) : + ReachableCachedValid ((headIdentifier, some headDigest) :: rest) + identifier digest ↔ + (identifier = headIdentifier ∧ digest = headDigest ∧ + TargetSum.ValidDigest headDigest) + ∨ (¬ TargetSum.ValidDigest headDigest ∧ + ReachableCachedValid rest identifier digest) := by + constructor + · intro hreach + cases hreach with + | here _ _ _ hvalid => exact Or.inl ⟨rfl, rfl, hvalid⟩ + | thereSome _ _ _ _ _ hinvalid htail => exact Or.inr ⟨hinvalid, htail⟩ + · rintro (⟨rfl, rfl, hvalid⟩ | ⟨hinvalid, htail⟩) + · exact .here _ _ _ hvalid + · exact .thereSome _ _ _ _ _ hinvalid htail + +def HasCachedHit {ι : Type} [DecidableEq ι] + (schedule : List (ι × Option Digest)) + (targets : Finset (ι × Digest)) : Prop := + ∃ identifier digest, + ReachableCachedValid schedule identifier digest ∧ + selectedHits targets (some (identifier, digest)) + +theorem FirstValid.selectFirst_eq_pure {ι : Type} [DecidableEq ι] + {schedule : List (ι × Option Digest)} {identifier : ι} {digest : Digest} + (hfirst : FirstValid schedule identifier digest) : + selectFirst schedule = pure (some (identifier, digest)) := by + induction hfirst with + | here identifier digest rest hvalid => + rw [selectFirst, if_pos hvalid] + | there headIdentifier headDigest rest identifier digest hinvalid htail ih => + rw [selectFirst, if_neg hinvalid, ih] + +theorem selectionRisk_eq_one_of_firstValid_hit {ι : Type} [DecidableEq ι] + {schedule : List (ι × Option Digest)} {identifier : ι} {digest : Digest} + {targets : Finset (ι × Digest)} + (hfirst : FirstValid schedule identifier digest) + (hhit : selectedHits targets (some (identifier, digest))) : + selectionRisk schedule targets = 1 := by + classical + rw [selectionRisk, hfirst.selectFirst_eq_pure, probEvent_pure, if_pos hhit] + +theorem selectionRisk_le_pendingRisk_of_not_hasCachedHit + {ι : Type} [DecidableEq ι] + (schedule : List (ι × Option Digest)) (targets : Finset (ι × Digest)) + (hclean : ¬ HasCachedHit schedule targets) : + selectionRisk schedule targets ≤ + EncodingRetry.pendingRisk (targetDigests targets) := by + induction schedule with + | nil => + rw [selectionRisk_nil] + exact bot_le + | cons head rest ih => + obtain ⟨identifier, digest⟩ := head + cases digest with + | some digest => + by_cases hvalid : TargetSum.ValidDigest digest + · have hmiss : ¬ selectedHits targets (some (identifier, digest)) := by + intro hhit + exact hclean ⟨identifier, digest, + .here identifier digest rest hvalid, hhit⟩ + rw [selectionRisk_cons_some_of_valid_of_miss _ _ _ _ hvalid hmiss] + exact bot_le + · rw [selectionRisk_cons_some_of_invalid _ _ _ _ hvalid] + apply ih + rintro ⟨selectedIdentifier, selectedDigest, hfirst, hhit⟩ + exact hclean ⟨selectedIdentifier, selectedDigest, + .thereSome identifier digest rest selectedIdentifier selectedDigest + hvalid hfirst, hhit⟩ + | none => + rw [selectionRisk_cons_none_eq] + have htail : ¬ HasCachedHit rest targets := by + rintro ⟨selectedIdentifier, selectedDigest, hfirst, hhit⟩ + exact hclean ⟨selectedIdentifier, selectedDigest, + .thereNone identifier rest selectedIdentifier selectedDigest hfirst, hhit⟩ + calc + _ ≤ ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if TargetSum.ValidDigest (truncateHash output) then + if truncateHash output ∈ targetDigests targets then 1 else 0 + else EncodingRetry.pendingRisk (targetDigests targets)) := by + apply ENNReal.tsum_le_tsum + intro output + apply mul_le_mul_right + by_cases hvalid : TargetSum.ValidDigest (truncateHash output) + · by_cases hhit : selectedHits targets + (some (identifier, truncateHash output)) + · have hmem := digest_mem_targetDigests_of_selectedHits hhit + rw [selectionRisk_cons_some_of_valid_of_hit _ _ _ _ hvalid hhit, + if_pos hvalid, if_pos hmem] + · rw [selectionRisk_cons_some_of_valid_of_miss _ _ _ _ hvalid hhit, + if_pos hvalid] + split <;> simp + · rw [selectionRisk_cons_some_of_invalid _ _ _ _ hvalid, + if_neg hvalid] + exact ih htail + _ ≤ EncodingRetry.pendingRisk (targetDigests targets) := + SphincsSecurity.uniformHashOutput_select_bonus_sum_le + (targetDigests targets) + +@[simp] theorem selectionRisk_empty_targets {ι : Type} [DecidableEq ι] + (schedule : List (ι × Option Digest)) : + selectionRisk schedule ∅ = 0 := by + rw [selectionRisk] + apply probEvent_eq_zero + intro selected _ hhit + cases selected with + | none => exact hhit + | some selected => + obtain ⟨candidate, hcandidate, _⟩ := hhit + simp at hcandidate + +noncomputable def candidateTargets {ι : Type} [DecidableEq ι] + (identifier : ι) (targets : Finset (ι × Digest)) + (output : HashOutput) : Finset (ι × Digest) := + if TargetSum.ValidDigest (truncateHash output) then + insert (identifier, truncateHash output) targets + else + targets + +noncomputable def candidatePair {ι : Type} [DecidableEq ι] + (schedule : List (ι × Option Digest)) : + ProbComp (HashOutput × Option (ι × Digest)) := do + let output ← ($ᵗ HashOutput : ProbComp HashOutput) + let selected ← selectFirst schedule + pure (output, selected) + +def candidateMatches {ι : Type} [DecidableEq ι] (identifier : ι) + (pair : HashOutput × Option (ι × Digest)) : Prop := + ∃ selectedIdentifier, + pair.2 = some (selectedIdentifier, truncateHash pair.1) + ∧ identifier ≠ selectedIdentifier + +theorem selectedHits_mono {ι : Type} [DecidableEq ι] + {left right : Finset (ι × Digest)} (hsubset : left ⊆ right) + {selected : Option (ι × Digest)} + (hhit : selectedHits left selected) : selectedHits right selected := by + cases selected with + | none => exact hhit + | some selected => + obtain ⟨candidate, hcandidate, hidentifier, hdigest⟩ := hhit + exact ⟨candidate, hsubset hcandidate, hidentifier, hdigest⟩ + +theorem candidateTargets_subset {ι : Type} [DecidableEq ι] + (identifier : ι) (targets : Finset (ι × Digest)) (output : HashOutput) : + targets ⊆ candidateTargets identifier targets output := by + intro candidate hcandidate + rw [candidateTargets] + split + · exact Finset.mem_insert_of_mem hcandidate + · exact hcandidate + +theorem selectedHits_candidateTargets_self_iff + {ι : Type} [DecidableEq ι] (identifier : ι) + (targets : Finset (ι × Digest)) (output : HashOutput) : + selectedHits (candidateTargets identifier targets output) + (some (identifier, truncateHash output)) ↔ + selectedHits targets (some (identifier, truncateHash output)) := by + constructor + · intro hhit + obtain ⟨candidate, hcandidate, hidentifier, hdigest⟩ := hhit + rw [candidateTargets] at hcandidate + split at hcandidate + · rw [Finset.mem_insert] at hcandidate + rcases hcandidate with heq | hold + · subst candidate + exact (hidentifier rfl).elim + · exact ⟨candidate, hold, hidentifier, hdigest⟩ + · exact ⟨candidate, hcandidate, hidentifier, hdigest⟩ + · exact selectedHits_mono (candidateTargets_subset identifier targets output) + +theorem candidatePair_oldRisk_eq {ι : Type} [DecidableEq ι] + (schedule : List (ι × Option Digest)) (targets : Finset (ι × Digest)) : + Pr[fun pair => selectedHits targets pair.2 | candidatePair schedule] = + selectionRisk schedule targets := by + rw [candidatePair, probEvent_bind_eq_tsum] + simp_rw [show (fun selected => pure (_, selected)) = + pure ∘ fun selected => (_, selected) from rfl, probEvent_bind_pure_comp] + change (∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + selectionRisk schedule targets) = selectionRisk schedule targets + rw [ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul] + +theorem candidatePair_oldRisk_le_newRisk {ι : Type} [DecidableEq ι] + (identifier : ι) (schedule : List (ι × Option Digest)) + (targets : Finset (ι × Digest)) : + selectionRisk schedule targets ≤ + Pr[fun pair => selectedHits + (candidateTargets identifier targets pair.1) pair.2 | + candidatePair schedule] := by + rw [← candidatePair_oldRisk_eq schedule targets] + apply probEvent_mono + intro pair _ hold + exact selectedHits_mono (candidateTargets_subset identifier targets pair.1) hold + +theorem selectionRisk_reveal_head_candidate_eq + {ι : Type} [DecidableEq ι] (identifier : ι) + (rest : List (ι × Option Digest)) (targets : Finset (ι × Digest)) + (output : HashOutput) : + selectionRisk ((identifier, some (truncateHash output)) :: rest) + (candidateTargets identifier targets output) = + selectionRisk ((identifier, some (truncateHash output)) :: rest) targets := by + by_cases hvalid : TargetSum.ValidDigest (truncateHash output) + · by_cases hhit : selectedHits targets (some (identifier, truncateHash output)) + · rw [selectionRisk_cons_some_of_valid_of_hit _ _ _ _ hvalid hhit, + selectionRisk_cons_some_of_valid_of_hit _ _ _ _ hvalid + ((selectedHits_candidateTargets_self_iff identifier targets output).2 hhit)] + · rw [selectionRisk_cons_some_of_valid_of_miss _ _ _ _ hvalid hhit, + selectionRisk_cons_some_of_valid_of_miss _ _ _ _ hvalid + (fun hnew => hhit + ((selectedHits_candidateTargets_self_iff identifier targets output).1 hnew))] + · rw [selectionRisk_cons_some_of_invalid _ _ _ _ hvalid, + selectionRisk_cons_some_of_invalid _ _ _ _ hvalid, + candidateTargets, if_neg hvalid] + +theorem uniform_reveal_head_candidate_sum_le_independent + {ι : Type} [DecidableEq ι] (identifier : ι) + (rest : List (ι × Option Digest)) (targets : Finset (ι × Digest)) : + (∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + selectionRisk ((identifier, some (truncateHash output)) :: rest) + (candidateTargets identifier targets output)) ≤ + Pr[fun pair => selectedHits + (candidateTargets identifier targets pair.1) pair.2 | + candidatePair ((identifier, none) :: rest)] := by + rw [show (∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + selectionRisk ((identifier, some (truncateHash output)) :: rest) + (candidateTargets identifier targets output)) = + selectionRisk ((identifier, none) :: rest) targets by + rw [selectionRisk_cons_none_eq] + apply tsum_congr + intro output + rw [selectionRisk_reveal_head_candidate_eq]] + exact candidatePair_oldRisk_le_newRisk identifier + ((identifier, none) :: rest) targets + +inductive InvalidPrefix {ι : Type} [DecidableEq ι] : + List (ι × Option Digest) → Prop where + | nil : InvalidPrefix [] + | cons (identifier : ι) (digest : Digest) + (rest : List (ι × Option Digest)) + (invalid : ¬ TargetSum.ValidDigest digest) + (tail : InvalidPrefix rest) : + InvalidPrefix ((identifier, some digest) :: rest) + +theorem InvalidPrefix.firstValid_append {ι : Type} [DecidableEq ι] + {initial : List (ι × Option Digest)} (hinitial : InvalidPrefix initial) + (identifier : ι) (digest : Digest) (rest : List (ι × Option Digest)) + (hvalid : TargetSum.ValidDigest digest) : + FirstValid (initial ++ (identifier, some digest) :: rest) identifier digest := by + induction hinitial with + | nil => exact .here identifier digest rest hvalid + | cons headIdentifier headDigest initial hinvalid _ ih => + rw [List.cons_append] + exact .there headIdentifier headDigest _ identifier digest hinvalid ih + +theorem InvalidPrefix.selectionRisk_append {ι : Type} [DecidableEq ι] + {initial : List (ι × Option Digest)} (hinitial : InvalidPrefix initial) + (suffix : List (ι × Option Digest)) (targets : Finset (ι × Digest)) : + selectionRisk (initial ++ suffix) targets = selectionRisk suffix targets := by + induction hinitial with + | nil => rfl + | cons identifier digest rest hinvalid htail ih => + rw [List.cons_append, + selectionRisk_cons_some_of_invalid identifier digest _ targets hinvalid, ih] + +theorem candidatePair_matchesSelection_le {ι : Type} [DecidableEq ι] + (identifier : ι) (schedule : List (ι × Option Digest)) : + Pr[candidateMatches identifier | candidatePair schedule] ≤ + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + rw [candidatePair] + rw [probEvent_bind_bind_swap + ($ᵗ HashOutput : ProbComp HashOutput) (selectFirst schedule) + (fun output selected => pure (output, selected))] + refine probEvent_bind_le_of_forall_le fun selected _hselected => ?_ + rw [show (fun output => pure (output, selected)) = + pure ∘ fun output => (output, selected) from rfl, probEvent_bind_pure_comp] + cases selected with + | none => + calc + _ = 0 := probEvent_eq_zero (by + intro output _ hmatch + obtain ⟨selectedIdentifier, helected, _⟩ := hmatch + simp at helected) + _ ≤ _ := bot_le + | some selected => + obtain ⟨selectedIdentifier, digest⟩ := selected + by_cases heq : identifier = selectedIdentifier + · calc + _ = 0 := probEvent_eq_zero (by + intro output _ hmatch + obtain ⟨foundIdentifier, helected, hne⟩ := hmatch + have hidentifier : foundIdentifier = selectedIdentifier := by + have hpairs : (selectedIdentifier, digest) = + (foundIdentifier, truncateHash output) := Option.some.inj helected + exact (congrArg Prod.fst hpairs).symm + exact hne (heq.trans hidentifier.symm)) + _ ≤ _ := bot_le + · rw [show ((candidateMatches identifier) ∘ + fun output : HashOutput => (output, some (selectedIdentifier, digest))) = + fun output => truncateHash output = digest by + funext output + apply propext + constructor + · rintro ⟨foundIdentifier, helected, _⟩ + have hpairs : (selectedIdentifier, digest) = + (foundIdentifier, truncateHash output) := Option.some.inj helected + exact (congrArg Prod.snd hpairs).symm + · intro hdigest + exact ⟨selectedIdentifier, by simp [hdigest], heq⟩] + exact le_of_eq (SphincsSecurity.probEvent_uniform_truncateHash_eq digest) + +theorem candidatePair_newRisk_le {ι : Type} [DecidableEq ι] + (identifier : ι) (schedule : List (ι × Option Digest)) + (targets : Finset (ι × Digest)) : + Pr[fun pair => selectedHits + (candidateTargets identifier targets pair.1) pair.2 | + candidatePair schedule] ≤ + selectionRisk schedule targets + + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + let old : HashOutput × Option (ι × Digest) → Prop := + fun pair => selectedHits targets pair.2 + let matched : HashOutput × Option (ι × Digest) → Prop := + candidateMatches identifier + calc + Pr[fun pair => selectedHits (candidateTargets identifier targets pair.1) pair.2 | + candidatePair schedule] ≤ + Pr[fun pair => old pair ∨ matched pair | candidatePair schedule] := by + apply probEvent_mono + intro pair _ hnew + obtain ⟨output, selected⟩ := pair + cases selected with + | none => exact hnew.elim + | some selected => + obtain ⟨selectedIdentifier, selectedDigest⟩ := selected + obtain ⟨candidate, hcandidate, hidentifier, hdigest⟩ := hnew + by_cases hvalid : TargetSum.ValidDigest (truncateHash output) + · rw [candidateTargets, if_pos hvalid, Finset.mem_insert] at hcandidate + rcases hcandidate with heq | hold + · subst candidate + exact Or.inr ⟨selectedIdentifier, by + rw [show truncateHash (output, some + (selectedIdentifier, selectedDigest)).1 = selectedDigest from hdigest] + , hidentifier⟩ + · exact Or.inl ⟨candidate, hold, hidentifier, hdigest⟩ + · rw [candidateTargets, if_neg hvalid] at hcandidate + exact Or.inl ⟨candidate, hcandidate, hidentifier, hdigest⟩ + _ ≤ Pr[old | candidatePair schedule] + + Pr[matched | candidatePair schedule] := + probEvent_or_le _ old matched + _ ≤ selectionRisk schedule targets + + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + rw [candidatePair_oldRisk_eq] + exact add_le_add le_rfl + (candidatePair_matchesSelection_le identifier schedule) + +theorem candidatePair_newRisk_eq_sum {ι : Type} [DecidableEq ι] + (identifier : ι) (schedule : List (ι × Option Digest)) + (targets : Finset (ι × Digest)) : + Pr[fun pair => selectedHits + (candidateTargets identifier targets pair.1) pair.2 | + candidatePair schedule] = + ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + selectionRisk schedule (candidateTargets identifier targets output) := by + rw [candidatePair, probEvent_bind_eq_tsum] + apply tsum_congr + intro output + congr 1 + rw [show (fun selected => pure (output, selected)) = + pure ∘ fun selected => (output, selected) from rfl, probEvent_bind_pure_comp] + rfl + +theorem uniform_candidateTargets_selectionRisk_sum_le + {ι : Type} [DecidableEq ι] + (identifier : ι) (schedule : List (ι × Option Digest)) + (targets : Finset (ι × Digest)) : + (∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + selectionRisk schedule (candidateTargets identifier targets output)) ≤ + selectionRisk schedule targets + + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + rw [← candidatePair_newRisk_eq_sum] + exact candidatePair_newRisk_le identifier schedule targets + +theorem uniform_reveal_after_invalidPrefix_candidate_sum_le + {ι : Type} [DecidableEq ι] + {initial : List (ι × Option Digest)} (hinitial : InvalidPrefix initial) + (identifier : ι) (rest : List (ι × Option Digest)) + (targets : Finset (ι × Digest)) : + (∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + selectionRisk + (initial ++ (identifier, some (truncateHash output)) :: rest) + (candidateTargets identifier targets output)) ≤ + selectionRisk (initial ++ (identifier, none) :: rest) targets + + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + simp_rw [hinitial.selectionRisk_append] + exact (uniform_reveal_head_candidate_sum_le_independent identifier rest targets).trans + (candidatePair_newRisk_le identifier ((identifier, none) :: rest) targets) + +theorem uniform_reveal_append_candidate_sum_le + {ι : Type} [DecidableEq ι] + (initial : List (ι × Option Digest)) (identifier : ι) + (rest : List (ι × Option Digest)) (targets : Finset (ι × Digest)) : + (∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + selectionRisk + (initial ++ (identifier, some (truncateHash output)) :: rest) + (candidateTargets identifier targets output)) ≤ + selectionRisk (initial ++ (identifier, none) :: rest) targets + + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + induction initial with + | nil => + simpa using uniform_reveal_after_invalidPrefix_candidate_sum_le + (InvalidPrefix.nil : InvalidPrefix ([] : List (ι × Option Digest))) + identifier rest targets + | cons head initial ih => + obtain ⟨headIdentifier, headDigest⟩ := head + have validBound (digest : Digest) (hvalid : TargetSum.ValidDigest digest) : + (∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + selectionRisk + ((headIdentifier, some digest) :: + (initial ++ (identifier, some (truncateHash output)) :: rest)) + (candidateTargets identifier targets output)) ≤ + selectionRisk + ((headIdentifier, some digest) :: + (initial ++ (identifier, none) :: rest)) targets + + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + calc + _ = ∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + selectionRisk [(headIdentifier, some digest)] + (candidateTargets identifier targets output) := by + apply tsum_congr + intro output + congr 1 + exact selectionRisk_cons_some_of_valid_suffix_eq + headIdentifier digest _ _ _ hvalid + _ ≤ selectionRisk [(headIdentifier, some digest)] targets + + (Fintype.card Digest : ℝ≥0∞)⁻¹ := + uniform_candidateTargets_selectionRisk_sum_le identifier + [(headIdentifier, some digest)] targets + _ = _ := by + congr 1 + exact selectionRisk_cons_some_of_valid_suffix_eq + headIdentifier digest _ _ _ hvalid + cases headDigest with + | some digest => + by_cases hvalid : TargetSum.ValidDigest digest + · simpa only [List.cons_append] using validBound digest hvalid + · simp_rw [List.cons_append, + selectionRisk_cons_some_of_invalid _ _ _ _ hvalid] + exact ih + | none => + have conditionalBound (headOutput : HashOutput) : + (∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + selectionRisk + ((headIdentifier, some (truncateHash headOutput)) :: + (initial ++ (identifier, some (truncateHash output)) :: rest)) + (candidateTargets identifier targets output)) ≤ + selectionRisk + ((headIdentifier, some (truncateHash headOutput)) :: + (initial ++ (identifier, none) :: rest)) targets + + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + by_cases hvalid : TargetSum.ValidDigest (truncateHash headOutput) + · exact validBound (truncateHash headOutput) hvalid + · simp_rw [selectionRisk_cons_some_of_invalid _ _ _ _ hvalid] + exact ih + simp_rw [List.cons_append, selectionRisk_cons_none_eq] + calc + _ = ∑' headOutput : HashOutput, + Pr[= headOutput | ($ᵗ HashOutput : ProbComp HashOutput)] * + (∑' output : HashOutput, + Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * + selectionRisk + ((headIdentifier, some (truncateHash headOutput)) :: + (initial ++ + (identifier, some (truncateHash output)) :: rest)) + (candidateTargets identifier targets output)) := by + simp_rw [← ENNReal.tsum_mul_left] + rw [ENNReal.tsum_comm] + apply tsum_congr + intro headOutput + simp_rw [mul_left_comm] + _ ≤ ∑' headOutput : HashOutput, + Pr[= headOutput | ($ᵗ HashOutput : ProbComp HashOutput)] * + (selectionRisk + ((headIdentifier, some (truncateHash headOutput)) :: + (initial ++ (identifier, none) :: rest)) targets + + (Fintype.card Digest : ℝ≥0∞)⁻¹) := by + apply ENNReal.tsum_le_tsum + intro headOutput + exact mul_le_mul_right (conditionalBound headOutput) _ + _ = (∑' headOutput : HashOutput, + Pr[= headOutput | ($ᵗ HashOutput : ProbComp HashOutput)] * + selectionRisk + ((headIdentifier, some (truncateHash headOutput)) :: + (initial ++ (identifier, none) :: rest)) targets) + + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_mul_right, + tsum_probOutput_of_liftM_PMF, one_mul] + _ = _ := rfl + +end SphincsSecurity.EncodingSelection diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingSelectionCache.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingSelectionCache.lean new file mode 100644 index 00000000..8d9b6b02 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingSelectionCache.lean @@ -0,0 +1,859 @@ +import SphincsSecurity.Proof.EncodingLatent +import SphincsSecurity.Proof.EncodingSelection + +/-! +# Cache-derived encoding selection risk + +The abstract conditional-selection schedule is instantiated with the concrete encoding inputs at +one structural position and one settled layer message. Every cached candidate retains its full hash +input as the identifier used to exclude the selected input itself. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +set_option maxRecDepth 100000 + +def encodingRetryInput (parameter : PublicParameter) (position : EncodingPosition) + (message : Digest) (counter : Nat) : HashInput := + tweakableHashInput parameter position.domain + (digestBytes message ++ counterBytes (BitVec.ofNat counterBits counter)) + +noncomputable def encodingRetryScheduleFrom + (parameter : PublicParameter) (cache : QueryCache HashSpec) + (position : EncodingPosition) (message : Digest) : + Nat → Nat → List (HashInput × Option Digest) + | 0, _ => [] + | attempts + 1, counter => + let input := encodingRetryInput parameter position message counter + (input, (cache input).map truncateHash) :: + encodingRetryScheduleFrom parameter cache position message attempts (counter + 1) + +noncomputable def encodingRetrySchedule + (parameter : PublicParameter) (cache : QueryCache HashSpec) + (position : EncodingPosition) (message : Digest) : + List (HashInput × Option Digest) := + encodingRetryScheduleFrom parameter cache position message encodingAttemptLimit 0 + +theorem encodingRetryInput_injective_of_lt + {parameter : PublicParameter} {position : EncodingPosition} {message : Digest} + {left right : Nat} (hleft : left < encodingAttemptLimit) + (hright : right < encodingAttemptLimit) + (heq : encodingRetryInput parameter position message left = + encodingRetryInput parameter position message right) : + left = right := by + have hpayload := + (tweakableHashInput_injective parameter (by trivial) (by trivial) heq).2 + obtain ⟨_, hcounter⟩ := + List.append_inj hpayload (by simp [digestBytes_length]) + apply ofNat_inj_of_lt (w := counterBits) + (by simpa [encodingAttemptLimit, counterBits] using hleft) + (by simpa [encodingAttemptLimit, counterBits] using hright) + exact bytesLE_injective hcounter + +theorem encodingRetryScheduleFrom_add + (parameter : PublicParameter) (cache : QueryCache HashSpec) + (position : EncodingPosition) (message : Digest) + (first remaining counter : Nat) : + encodingRetryScheduleFrom parameter cache position message + (first + remaining) counter = + encodingRetryScheduleFrom parameter cache position message first counter ++ + encodingRetryScheduleFrom parameter cache position message remaining + (counter + first) := by + induction first generalizing counter with + | zero => simp [encodingRetryScheduleFrom] + | succ first ih => + rw [Nat.succ_add, encodingRetryScheduleFrom, encodingRetryScheduleFrom] + simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using ih (counter + 1) + +theorem encodingRetryScheduleFrom_cacheQuery_of_ne_of_range + {parameter : PublicParameter} {cache : QueryCache HashSpec} + {position : EncodingPosition} {message : Digest} + {input : HashInput} {answer : HashOutput} {attempts counter : Nat} + (hne : ∀ candidate : Nat, counter ≤ candidate → candidate < counter + attempts → + input ≠ encodingRetryInput parameter position message candidate) : + encodingRetryScheduleFrom parameter (cache.cacheQuery input answer) + position message attempts counter = + encodingRetryScheduleFrom parameter cache position message attempts counter := by + induction attempts generalizing counter with + | zero => rfl + | succ attempts ih => + rw [encodingRetryScheduleFrom, encodingRetryScheduleFrom] + have hcurrent := hne counter (by omega) (by omega) + rw [QueryCache.cacheQuery_of_ne _ _ hcurrent.symm] + apply congrArg ((encodingRetryInput parameter position message counter, + (cache (encodingRetryInput parameter position message counter)).map truncateHash) :: ·) + apply ih + intro candidate hlower hupper + apply hne candidate (by omega) + omega + +theorem encodingRetrySchedule_eq_split + {parameter : PublicParameter} {cache : QueryCache HashSpec} + {position : EncodingPosition} {message : Digest} + {counter : Nat} (hcounter : counter < encodingAttemptLimit) : + encodingRetrySchedule parameter cache position message = + encodingRetryScheduleFrom parameter cache position message counter 0 ++ + (encodingRetryInput parameter position message counter, + (cache (encodingRetryInput parameter position message counter)).map truncateHash) :: + encodingRetryScheduleFrom parameter cache position message + (encodingAttemptLimit - (counter + 1)) (counter + 1) := by + rw [encodingRetrySchedule] + conv_lhs => + rw [show encodingAttemptLimit = counter + + (1 + (encodingAttemptLimit - (counter + 1))) by omega] + rw [encodingRetryScheduleFrom_add] + rw [show 1 + (encodingAttemptLimit - (counter + 1)) = + (encodingAttemptLimit - (counter + 1)) + 1 by omega, + encodingRetryScheduleFrom] + rw [show 0 + counter = counter by omega] + +theorem encodingRetrySchedule_eq_split_of_uncached + {parameter : PublicParameter} {cache : QueryCache HashSpec} + {position : EncodingPosition} {message : Digest} + {counter : Nat} (hcounter : counter < encodingAttemptLimit) + (huncached : cache (encodingRetryInput parameter position message counter) = none) : + encodingRetrySchedule parameter cache position message = + encodingRetryScheduleFrom parameter cache position message counter 0 ++ + (encodingRetryInput parameter position message counter, none) :: + encodingRetryScheduleFrom parameter cache position message + (encodingAttemptLimit - (counter + 1)) (counter + 1) := by + rw [encodingRetrySchedule_eq_split hcounter, huncached] + rfl + +theorem encodingRetrySchedule_cacheQuery_eq_split + {parameter : PublicParameter} {cache : QueryCache HashSpec} + {position : EncodingPosition} {message : Digest} + {counter : Nat} (hcounter : counter < encodingAttemptLimit) + (answer : HashOutput) : + encodingRetrySchedule parameter + (cache.cacheQuery (encodingRetryInput parameter position message counter) answer) + position message = + encodingRetryScheduleFrom parameter cache position message counter 0 ++ + (encodingRetryInput parameter position message counter, + some (truncateHash answer)) :: + encodingRetryScheduleFrom parameter cache position message + (encodingAttemptLimit - (counter + 1)) (counter + 1) := by + rw [encodingRetrySchedule_eq_split hcounter] + have hprefix := encodingRetryScheduleFrom_cacheQuery_of_ne_of_range + (parameter := parameter) (cache := cache) (position := position) (message := message) + (input := encodingRetryInput parameter position message counter) (answer := answer) + (attempts := counter) (counter := 0) (by + intro candidate _ hcandidate heq + have hsame := encodingRetryInput_injective_of_lt + hcounter (by omega) heq + omega) + have hsuffix := encodingRetryScheduleFrom_cacheQuery_of_ne_of_range + (parameter := parameter) (cache := cache) (position := position) (message := message) + (input := encodingRetryInput parameter position message counter) (answer := answer) + (attempts := encodingAttemptLimit - (counter + 1)) (counter := counter + 1) (by + intro candidate hlower hcandidate heq + have hcandidateLt : candidate < encodingAttemptLimit := by omega + have hsame := encodingRetryInput_injective_of_lt + hcounter hcandidateLt heq + omega) + rw [hprefix, hsuffix, QueryCache.cacheQuery_self] + rfl + +theorem encodingRetryScheduleFrom_invalidPrefix + {parameter : PublicParameter} {cache : QueryCache HashSpec} + {position : EncodingPosition} {message : Digest} + {attempts counter : Nat} + (hcached : ∀ candidate : Nat, counter ≤ candidate → candidate < counter + attempts → + cache (encodingRetryInput parameter position message candidate) ≠ none) + (hinvalid : ∀ candidate : Nat, counter ≤ candidate → candidate < counter + attempts → + ¬ TargetSum.ValidDigest (truncateHash (fromCache cache + (encodingRetryInput parameter position message candidate)))) : + EncodingSelection.InvalidPrefix + (encodingRetryScheduleFrom parameter cache position message attempts counter) := by + induction attempts generalizing counter with + | zero => exact .nil + | succ attempts ih => + rw [encodingRetryScheduleFrom] + have hcurrentCached := hcached counter (by omega) (by omega) + cases hanswer : cache (encodingRetryInput parameter position message counter) with + | none => exact (hcurrentCached hanswer).elim + | some answer => + apply EncodingSelection.InvalidPrefix.cons + · simpa only [fromCache, hanswer, Option.getD_some] using + hinvalid counter (by omega) (by omega) + · apply ih + · intro candidate hlower hupper + apply hcached candidate (by omega) + omega + · intro candidate hlower hupper + apply hinvalid candidate (by omega) + omega + +theorem encodingRetryScheduleFrom_allMissing + {parameter : PublicParameter} {cache : QueryCache HashSpec} + {position : EncodingPosition} {message : Digest} + {attempts counter : Nat} + (hmissing : ∀ candidate : Nat, counter ≤ candidate → + candidate < counter + attempts → + cache (encodingRetryInput parameter position message candidate) = none) : + EncodingSelection.AllMissing + (encodingRetryScheduleFrom parameter cache position message attempts counter) := by + revert counter + induction attempts with + | zero => intro counter _; exact .nil + | succ attempts ih => + intro counter hmissing + rw [encodingRetryScheduleFrom, hmissing counter (by omega) (by omega)] + apply EncodingSelection.AllMissing.cons + apply ih + intro candidate hlower hupper + apply hmissing candidate (by omega) + omega + +theorem encodingRetrySchedule_allMissing + {parameter : PublicParameter} {cache : QueryCache HashSpec} + {position : EncodingPosition} {message : Digest} + (hmissing : ∀ counter : Nat, counter < encodingAttemptLimit → + cache (encodingRetryInput parameter position message counter) = none) : + EncodingSelection.AllMissing + (encodingRetrySchedule parameter cache position message) := by + rw [encodingRetrySchedule] + apply encodingRetryScheduleFrom_allMissing + intro candidate _ hcandidate + exact hmissing candidate (by simpa using hcandidate) + +theorem reachableCachedValid_encodingRetryScheduleFrom + {parameter : PublicParameter} {cache : QueryCache HashSpec} + {position : EncodingPosition} {message : Digest} + {attempts counter : Nat} {identifier : HashInput} {digest : Digest} + (hreach : EncodingSelection.ReachableCachedValid + (encodingRetryScheduleFrom parameter cache position message attempts counter) + identifier digest) : + ∃ selected answer, + counter ≤ selected ∧ selected < counter + attempts + ∧ identifier = encodingRetryInput parameter position message selected + ∧ cache identifier = some answer + ∧ digest = truncateHash answer + ∧ TargetSum.ValidDigest digest + ∧ ∀ candidate : Nat, counter ≤ candidate → candidate < selected → + ∀ candidateAnswer : HashOutput, + cache (encodingRetryInput parameter position message candidate) = + some candidateAnswer → + ¬ TargetSum.ValidDigest (truncateHash candidateAnswer) := by + induction attempts generalizing counter identifier digest with + | zero => cases hreach + | succ attempts ih => + rw [encodingRetryScheduleFrom] at hreach + let currentInput := encodingRetryInput parameter position message counter + change EncodingSelection.ReachableCachedValid + ((currentInput, (cache currentInput).map truncateHash) :: + encodingRetryScheduleFrom parameter cache position message attempts (counter + 1)) + identifier digest at hreach + cases hanswer : cache currentInput with + | none => + simp only [hanswer, Option.map_none] at hreach + rw [EncodingSelection.reachableCachedValid_cons_none_iff] at hreach + obtain ⟨selected, answer, hlower, hupper, hidentifier, hcached, + hdigest, hvalid, hbefore⟩ := ih (counter := counter + 1) hreach + refine ⟨selected, answer, by omega, by omega, hidentifier, + hcached, hdigest, hvalid, ?_⟩ + intro candidate hlower' hbefore' candidateAnswer hcandidate + by_cases heq : candidate = counter + · subst candidate + have : (none : Option HashOutput) = some candidateAnswer := by + simpa only [currentInput, hanswer] using hcandidate + exact (Option.some_ne_none candidateAnswer this.symm).elim + · exact hbefore candidate (by omega) hbefore' candidateAnswer hcandidate + | some currentAnswer => + simp only [hanswer, Option.map_some] at hreach + rw [EncodingSelection.reachableCachedValid_cons_some_iff] at hreach + rcases hreach with ⟨rfl, rfl, hvalid⟩ | ⟨hinvalid, htail⟩ + · exact ⟨counter, currentAnswer, by omega, by omega, rfl, + hanswer, rfl, hvalid, by intro candidate _ hbefore; omega⟩ + · obtain ⟨selected, answer, hlower, hupper, hidentifier, hcached, + hdigest, hvalid, hbefore⟩ := ih (counter := counter + 1) htail + refine ⟨selected, answer, by omega, by omega, hidentifier, + hcached, hdigest, hvalid, ?_⟩ + intro candidate hlower' hbefore' candidateAnswer hcandidate + by_cases heq : candidate = counter + · subst candidate + have hcandidateAnswer : candidateAnswer = currentAnswer := by + rw [show encodingRetryInput parameter position message counter = + currentInput from rfl, hanswer] at hcandidate + exact Option.some.inj hcandidate.symm + subst candidateAnswer + exact hinvalid + · exact hbefore candidate (by omega) hbefore' candidateAnswer hcandidate + +theorem encodingRetryScheduleFrom_zero_invalidPrefix + {parameter : PublicParameter} {cache : QueryCache HashSpec} + {position : EncodingPosition} {message : Digest} + {counter : Nat} + (hcached : ∀ candidate : Nat, candidate < counter → + cache (encodingRetryInput parameter position message candidate) ≠ none) + (hinvalid : ∀ candidate : Nat, candidate < counter → + ¬ TargetSum.ValidDigest (truncateHash (fromCache cache + (encodingRetryInput parameter position message candidate)))) : + EncodingSelection.InvalidPrefix + (encodingRetryScheduleFrom parameter cache position message counter 0) := by + apply encodingRetryScheduleFrom_invalidPrefix + · intro candidate _ hcandidate + exact hcached candidate (by simpa using hcandidate) + · intro candidate _ hcandidate + exact hinvalid candidate (by simpa using hcandidate) + +theorem encodingSearchFrom_before_mem (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (position : EncodingPosition) (message : Digest) + (attempts counter : Nat) (selected : Counter) + (hbound : counter + attempts ≤ 2 ^ counterBits) + (hselected : evalWithAnswerFn f + (encodingSearchFrom parameter position.lay position.tree position.leafIdx + message attempts counter) = some selected) + (candidate : Nat) (hlower : counter ≤ candidate) + (hbefore : candidate < selected.toNat) : + encodingRetryInput parameter position message candidate ∈ + queriedInputs f + (encodingSearchFrom parameter position.lay position.tree position.leafIdx + message attempts counter) := by + induction attempts generalizing counter candidate with + | zero => simp [encodingSearchFrom] at hselected + | succ attempts ih => + have hcounterLt : counter < 2 ^ counterBits := by omega + rw [encodingSearchFrom, evalWithAnswerFn_bind] at hselected + cases hencode : evalWithAnswerFn f + (encode parameter position.lay position.tree position.leafIdx message + (BitVec.ofNat counterBits counter)) with + | none => + simp only [hencode] at hselected + rw [encodingSearchFrom, queriedInputs_bind] + by_cases heq : candidate = counter + · subst candidate + apply List.mem_append_left + simp only [encode, queriedInputs_bind, queriedInputs_tweakableHash, + queriedInputs_pure, List.append_nil, List.mem_singleton] + rfl + · apply List.mem_append_right + simp only [hencode] + exact ih (counter + 1) (by omega) hselected candidate (by omega) hbefore + | some codeword => + have hselectedEq : BitVec.ofNat counterBits counter = selected := by + simpa only [hencode, evalWithAnswerFn_pure, Option.some.injEq] using hselected + have hselectedNat : selected.toNat = counter := by + rw [← hselectedEq, BitVec.toNat_ofNat, Nat.mod_eq_of_lt hcounterLt] + omega + +theorem encodingSearch_before_mem (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (position : EncodingPosition) (message : Digest) + (selected : Counter) + (hselected : evalWithAnswerFn f + (encodingSearch parameter position.lay position.tree position.leafIdx message) = + some selected) + (candidate : Nat) (hbefore : candidate < selected.toNat) : + encodingRetryInput parameter position message candidate ∈ + queriedInputs f + (encodingSearch parameter position.lay position.tree position.leafIdx message) := by + exact encodingSearchFrom_before_mem f parameter position message encodingAttemptLimit 0 + selected (by norm_num [encodingAttemptLimit, counterBits]) + (by simpa only [encodingSearch] using hselected) candidate (by omega) hbefore + +theorem encodingSearch_before_cached + {parameter : PublicParameter} {cache : QueryCache HashSpec} + {position : EncodingPosition} {message : Digest} {selected : Counter} + (hselected : evalWithAnswerFn (fromCache cache) + (encodingSearch parameter position.lay position.tree position.leafIdx message) = + some selected) + (hrun : CachedRun cache (fromCache cache) + (encodingSearch parameter position.lay position.tree position.leafIdx message)) + {candidate : Nat} (hbefore : candidate < selected.toNat) : + cache (encodingRetryInput parameter position message candidate) ≠ none := by + exact hrun _ (encodingSearch_before_mem (fromCache cache) parameter position message + selected hselected candidate hbefore) + +theorem encodingSearch_before_invalid + {parameter : PublicParameter} {cache : QueryCache HashSpec} + {position : EncodingPosition} {message : Digest} {selected : Counter} + (hselected : evalWithAnswerFn (fromCache cache) + (encodingSearch parameter position.lay position.tree position.leafIdx message) = + some selected) + {candidate : Nat} (hbefore : candidate < selected.toNat) : + ¬ TargetSum.ValidDigest (truncateHash (fromCache cache + (encodingRetryInput parameter position message candidate))) := by + have hcandidateLt : candidate < 2 ^ counterBits := + hbefore.trans selected.isLt + have hrejected := encodingSearch_rejected_before (fromCache cache) parameter + position.lay position.tree position.leafIdx message selected + (BitVec.ofNat counterBits candidate) hselected (by + rw [BitVec.toNat_ofNat, Nat.mod_eq_of_lt hcandidateLt] + exact hbefore) + intro hvalid + have hnonempty := (eval_encode_ne_none_iff_validDigest (fromCache cache) parameter + position.lay position.tree position.leafIdx message + (BitVec.ofNat counterBits candidate)).mpr hvalid + exact hnonempty hrejected + +theorem encodingRetrySchedule_firstValid_of_encodingSearch + {parameter : PublicParameter} {cache : QueryCache HashSpec} + {position : EncodingPosition} {message : Digest} {selected : Counter} + (hselected : evalWithAnswerFn (fromCache cache) + (encodingSearch parameter position.lay position.tree position.leafIdx message) = + some selected) + (hrun : CachedRun cache (fromCache cache) + (encodingSearch parameter position.lay position.tree position.leafIdx message)) : + EncodingSelection.FirstValid + (encodingRetrySchedule parameter cache position message) + (encodingRetryInput parameter position message selected.toNat) + (truncateHash (fromCache cache + (encodingRetryInput parameter position message selected.toNat))) := by + have hcounter : selected.toNat < encodingAttemptLimit := by + simpa [encodingAttemptLimit, counterBits] using selected.isLt + have hbeforeCached : ∀ candidate : Nat, candidate < selected.toNat → + cache (encodingRetryInput parameter position message candidate) ≠ none := by + intro candidate hbefore + exact encodingSearch_before_cached hselected hrun hbefore + have hbeforeInvalid : ∀ candidate : Nat, candidate < selected.toNat → + ¬ TargetSum.ValidDigest (truncateHash (fromCache cache + (encodingRetryInput parameter position message candidate))) := by + intro candidate hbefore + exact encodingSearch_before_invalid hselected hbefore + have hinitial := encodingRetryScheduleFrom_zero_invalidPrefix + hbeforeCached hbeforeInvalid + have hofNat : BitVec.ofNat counterBits selected.toNat = selected := by + rw [BitVec.ofNat_toNat, BitVec.setWidth_eq] + have hselectedCached : cache + (encodingRetryInput parameter position message selected.toNat) ≠ none := by + have hmem := encodingSearch_selected_mem (fromCache cache) parameter position.lay + position.tree position.leafIdx message selected hselected + have hcached := hrun _ hmem + rw [encodingRetryInput, hofNat, EncodingPosition.domain] + exact hcached + have hvalid : TargetSum.ValidDigest (truncateHash (fromCache cache + (encodingRetryInput parameter position message selected.toNat))) := by + have hnonempty := encodingSearch_selected_encode_ne_none (fromCache cache) + parameter position.lay position.tree position.leafIdx message selected hselected + have hvalid := (eval_encode_ne_none_iff_validDigest (fromCache cache) parameter + position.lay position.tree position.leafIdx message selected).mp hnonempty + rw [encodingRetryInput, hofNat, EncodingPosition.domain] + exact hvalid + have hmap : (cache + (encodingRetryInput parameter position message selected.toNat)).map truncateHash = + some (truncateHash (fromCache cache + (encodingRetryInput parameter position message selected.toNat))) := by + cases hanswer : cache + (encodingRetryInput parameter position message selected.toNat) with + | none => exact (hselectedCached hanswer).elim + | some answer => simp [fromCache, hanswer] + rw [encodingRetrySchedule_eq_split hcounter, hmap] + exact hinitial.firstValid_append _ _ _ hvalid + +theorem encodingRetryScheduleFrom_cacheQuery_of_ne + {parameter : PublicParameter} {cache : QueryCache HashSpec} + {position : EncodingPosition} {message : Digest} + {input : HashInput} {answer : HashOutput} + (hne : ∀ counter : Nat, + input ≠ encodingRetryInput parameter position message counter) : + ∀ attempts counter, + encodingRetryScheduleFrom parameter (cache.cacheQuery input answer) + position message attempts counter = + encodingRetryScheduleFrom parameter cache position message attempts counter := by + intro attempts + induction attempts with + | zero => intro counter; rfl + | succ attempts ih => + intro counter + rw [encodingRetryScheduleFrom, encodingRetryScheduleFrom] + have hother : encodingRetryInput parameter position message counter ≠ input := + (hne counter).symm + rw [QueryCache.cacheQuery_of_ne _ _ hother, ih (counter + 1)] + +theorem encodingRetrySchedule_cacheQuery_of_ne + {parameter : PublicParameter} {cache : QueryCache HashSpec} + {position : EncodingPosition} {message : Digest} + {input : HashInput} {answer : HashOutput} + (hne : ∀ counter : Nat, + input ≠ encodingRetryInput parameter position message counter) : + encodingRetrySchedule parameter (cache.cacheQuery input answer) position message = + encodingRetrySchedule parameter cache position message := by + exact encodingRetryScheduleFrom_cacheQuery_of_ne hne encodingAttemptLimit 0 + +theorem encodingRetrySchedule_cacheQuery_of_ne_of_lt + {parameter : PublicParameter} {cache : QueryCache HashSpec} + {position : EncodingPosition} {message : Digest} + {input : HashInput} {answer : HashOutput} + (hne : ∀ counter : Nat, counter < encodingAttemptLimit → + input ≠ encodingRetryInput parameter position message counter) : + encodingRetrySchedule parameter (cache.cacheQuery input answer) position message = + encodingRetrySchedule parameter cache position message := by + rw [encodingRetrySchedule] + apply encodingRetryScheduleFrom_cacheQuery_of_ne_of_range + intro candidate _ hcandidate + exact hne candidate (by simpa using hcandidate) + +noncomputable def encodingSelectionCandidates + (parameter : PublicParameter) (cache : QueryCache HashSpec) + (hfinite : Finite cache) (position : EncodingPosition) : + Finset (HashInput × Digest) := + open Classical in + (((encodingCachedAt_finite (parameter := parameter) (cache := cache) + hfinite position).toFinset.filter fun input => + TargetSum.ValidDigest (truncateHash (fromCache cache input))).image fun input => + (input, truncateHash (fromCache cache input))) + +noncomputable def encodingConditionalRiskAtMessage + (parameter : PublicParameter) (cache : QueryCache HashSpec) + (hfinite : Finite cache) (position : EncodingPosition) + (message : Digest) : ℝ≥0∞ := + EncodingSelection.selectionRisk + (encodingRetrySchedule parameter cache position message) + (encodingSelectionCandidates parameter cache hfinite position) + +theorem encodingConditionalRiskAtMessage_eq_one_of_encodingSearch_hit + {parameter : PublicParameter} {cache : QueryCache HashSpec} + (hfinite : Finite cache) {position : EncodingPosition} + {message : Digest} {selected : Counter} + (hselected : evalWithAnswerFn (fromCache cache) + (encodingSearch parameter position.lay position.tree position.leafIdx message) = + some selected) + (hrun : CachedRun cache (fromCache cache) + (encodingSearch parameter position.lay position.tree position.leafIdx message)) + (hhit : EncodingSelection.selectedHits + (encodingSelectionCandidates parameter cache hfinite position) + (some (encodingRetryInput parameter position message selected.toNat, + truncateHash (fromCache cache + (encodingRetryInput parameter position message selected.toNat))))) : + encodingConditionalRiskAtMessage parameter cache hfinite position message = 1 := by + rw [encodingConditionalRiskAtMessage] + exact EncodingSelection.selectionRisk_eq_one_of_firstValid_hit + (encodingRetrySchedule_firstValid_of_encodingSearch hselected hrun) hhit + +theorem mem_encodingSelectionCandidates_iff + {parameter : PublicParameter} {cache : QueryCache HashSpec} + (hfinite : Finite cache) {position : EncodingPosition} + {input : HashInput} {digest : Digest} : + (input, digest) ∈ encodingSelectionCandidates parameter cache hfinite position ↔ + cache input ≠ none + ∧ AtEncodingPosition parameter input position + ∧ TargetSum.ValidDigest (truncateHash (fromCache cache input)) + ∧ digest = truncateHash (fromCache cache input) := by + classical + rw [encodingSelectionCandidates, Finset.mem_image] + constructor + · rintro ⟨candidate, hcandidate, hpairs⟩ + rw [Finset.mem_filter, Set.Finite.mem_toFinset] at hcandidate + have hinput : candidate = input := congrArg Prod.fst hpairs + subst candidate + exact ⟨hcandidate.1.1, hcandidate.1.2, hcandidate.2, + (congrArg Prod.snd hpairs).symm⟩ + · rintro ⟨hcached, hposition, hvalid, rfl⟩ + exact ⟨input, by + rw [Finset.mem_filter, Set.Finite.mem_toFinset] + exact ⟨⟨hcached, hposition⟩, hvalid⟩, rfl⟩ + +theorem targetDigests_encodingSelectionCandidates + {parameter : PublicParameter} {cache : QueryCache HashSpec} + (hfinite : Finite cache) (position : EncodingPosition) : + EncodingSelection.targetDigests + (encodingSelectionCandidates parameter cache hfinite position) = + encodingValidAnswerTargets parameter cache hfinite position := by + classical + ext digest + constructor + · intro hmem + rw [EncodingSelection.targetDigests, Finset.mem_image] at hmem + obtain ⟨⟨input, candidateDigest⟩, hcandidate, hdigest⟩ := hmem + rw [mem_encodingSelectionCandidates_iff] at hcandidate + obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hcandidate.1 + have hfromCache : fromCache cache input = answer := by + simp [fromCache, hanswer] + subst digest + rw [hcandidate.2.2.2, hfromCache] + exact cachedValidAnswer_mem_encodingValidAnswerTargets hfinite hanswer + hcandidate.2.1 (by simpa only [hfromCache] using hcandidate.2.2.1) + · intro hmem + have hset : digest ∈ encodingValidAnswers parameter cache position := by + rw [encodingValidAnswers_eq_validAnswerTargets hfinite position] + exact hmem + obtain ⟨hvalid, input, answer, hanswer, hposition, hdigest⟩ := hset + rw [EncodingSelection.targetDigests, Finset.mem_image] + refine ⟨(input, digest), ?_, rfl⟩ + rw [mem_encodingSelectionCandidates_iff] + have hfromCache : fromCache cache input = answer := by + simp [fromCache, hanswer] + exact ⟨by simp [hanswer], hposition, + by simpa only [hfromCache] using hvalid.of_eq hdigest.symm, + by simpa only [hfromCache] using hdigest.symm⟩ + +theorem encodingConditionalRiskAtMessage_le_retryContribution_of_missing + {parameter : PublicParameter} {cache : QueryCache HashSpec} + (hfinite : Finite cache) {position : EncodingPosition} + {secretKey : SecretKey} (hparameter : secretKey.parameter = parameter) + {message : Digest} + (hnotTarget : ¬ HasEncodingTarget cache secretKey position) + (hmissing : ∀ counter : Nat, counter < encodingAttemptLimit → + cache (encodingRetryInput parameter position message counter) = none) : + encodingConditionalRiskAtMessage parameter cache hfinite position message ≤ + encodingRetryContribution cache secretKey position := by + subst parameter + rw [encodingConditionalRiskAtMessage] + calc + _ ≤ EncodingRetry.pendingRisk + (EncodingSelection.targetDigests + (encodingSelectionCandidates secretKey.parameter cache hfinite position)) := + (encodingRetrySchedule_allMissing hmissing).selectionRisk_le_pendingRisk _ + _ = EncodingRetry.pendingRisk + (encodingValidAnswerTargets secretKey.parameter cache hfinite position) := by + rw [targetDigests_encodingSelectionCandidates] + _ = encodingRetryContribution cache secretKey position := + (encodingRetryContribution_eq_pendingRisk hfinite hnotTarget).symm + +theorem latentEncodingBadAt_of_encodingSelection_hasCachedHit + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {position : EncodingPosition} + {index : Index} {message : Digest} + (htree : treeIndexAt index position.lay = position.tree) + (hleaf : leafIndexAt index position.lay = position.leafIdx) + (hsettled : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + cache (layerMessagePosition index position.lay)) + (hmessage : message = honestValue (fromCache cache) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index position.lay)) + (hhit : EncodingSelection.HasCachedHit + (encodingRetrySchedule secretKey.parameter cache position message) + (encodingSelectionCandidates secretKey.parameter cache hfinite position)) : + LatentEncodingBadAt cache secretKey position := by + obtain ⟨identifier, digest, hreach, hselectedHit⟩ := hhit + have hreach' : EncodingSelection.ReachableCachedValid + (encodingRetryScheduleFrom secretKey.parameter cache position message + encodingAttemptLimit 0) identifier digest := by + simpa only [encodingRetrySchedule] using hreach + obtain ⟨selected, targetAnswer, _, hselectedLt, hidentifier, + htargetCached, hdigest, hvalid, hbefore⟩ := + reachableCachedValid_encodingRetryScheduleFrom hreach' + obtain ⟨candidate, hcandidate, hinputNe, hcollision⟩ := hselectedHit + obtain ⟨otherInput, otherDigest⟩ := candidate + rw [mem_encodingSelectionCandidates_iff] at hcandidate + obtain ⟨otherAnswer, hotherCached⟩ := + Option.ne_none_iff_exists'.mp hcandidate.1 + obtain ⟨otherPayload, hotherInput⟩ := hcandidate.2.1 + let targetCounter : Counter := BitVec.ofNat counterBits selected + let targetPayload := digestBytes message ++ counterBytes targetCounter + have htargetInput : encodingRetryInput secretKey.parameter position message selected = + tweakableHashInput secretKey.parameter position.domain targetPayload := by + rfl + have hotherFromCache : fromCache cache otherInput = otherAnswer := by + simp [fromCache, hotherCached] + have htargetPayloadNe : targetPayload ≠ otherPayload := by + intro hpayload + apply hinputNe + rw [hidentifier, htargetInput, hpayload, ← hotherInput] + refine ⟨index, targetCounter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htree, hleaf, hsettled, ?_, ?_, ?_, ?_, htargetPayloadNe, + ?_, ?_⟩ + · simp only [targetPayload, hmessage] + · rw [← htargetInput, ← hidentifier] + exact htargetCached + · exact hvalid.of_eq hdigest + · intro candidate hcandidateLt candidateAnswer hcandidateCached + have hselectedToNat : targetCounter.toNat = selected := by + simp only [targetCounter, BitVec.toNat_ofNat] + simpa [encodingAttemptLimit, counterBits] using hselectedLt + rw [hselectedToNat] at hcandidateLt + have hinvalid := hbefore candidate.toNat (by omega) hcandidateLt + candidateAnswer + apply hinvalid + have hofNat : BitVec.ofNat counterBits candidate.toNat = candidate := by + rw [BitVec.ofNat_toNat, BitVec.setWidth_eq] + rw [encodingRetryInput, hofNat, hmessage, EncodingPosition.domain] + exact hcandidateCached + · rwa [← hotherInput] + · rw [← hdigest, ← hotherFromCache, ← hcandidate.2.2.2] + exact hcollision.symm + +theorem encodingSelectionCandidates_cacheQuery_self + {parameter : PublicParameter} {cache : QueryCache HashSpec} + (hfinite : Finite cache) {position : EncodingPosition} + {input : HashInput} {answer : HashOutput} + (huncached : cache input = none) + (hposition : AtEncodingPosition parameter input position) : + encodingSelectionCandidates parameter (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) position = + EncodingSelection.candidateTargets input + (encodingSelectionCandidates parameter cache hfinite position) answer := by + classical + ext candidate + obtain ⟨candidateInput, candidateDigest⟩ := candidate + rw [mem_encodingSelectionCandidates_iff] + by_cases hvalid : TargetSum.ValidDigest (truncateHash answer) + · rw [EncodingSelection.candidateTargets, if_pos hvalid, Finset.mem_insert] + constructor + · intro hcandidate + by_cases heq : candidateInput = input + · subst candidateInput + apply Or.inl + have hdigest : candidateDigest = truncateHash answer := by + simpa [fromCache, QueryCache.cacheQuery_self] using hcandidate.2.2.2 + rw [hdigest] + · apply Or.inr + rw [mem_encodingSelectionCandidates_iff] + simpa [fromCache, QueryCache.cacheQuery_of_ne _ _ heq] using hcandidate + · rintro (heq | hcandidate) + · have hinput : candidateInput = input := congrArg Prod.fst heq + have hdigest : candidateDigest = truncateHash answer := congrArg Prod.snd heq + subst candidateInput + subst candidateDigest + exact ⟨by simp, hposition, by + simpa [fromCache, QueryCache.cacheQuery_self] using hvalid, by + simp [fromCache, QueryCache.cacheQuery_self]⟩ + · rw [mem_encodingSelectionCandidates_iff] at hcandidate + have hne : candidateInput ≠ input := by + intro heq + subst candidateInput + exact hcandidate.1 huncached + simpa [fromCache, QueryCache.cacheQuery_of_ne _ _ hne] using hcandidate + · rw [EncodingSelection.candidateTargets, if_neg hvalid] + rw [mem_encodingSelectionCandidates_iff] + constructor + · intro hcandidate + have hne : candidateInput ≠ input := by + intro heq + subst candidateInput + apply hvalid + simpa [fromCache, QueryCache.cacheQuery_self] using hcandidate.2.2.1 + simpa [fromCache, QueryCache.cacheQuery_of_ne _ _ hne] using hcandidate + · intro hcandidate + have hne : candidateInput ≠ input := by + intro heq + subst candidateInput + exact hcandidate.1 huncached + simpa [fromCache, QueryCache.cacheQuery_of_ne _ _ hne] using hcandidate + +theorem encodingSelectionCandidates_cacheQuery_of_not_atPosition + {parameter : PublicParameter} {cache : QueryCache HashSpec} + (hfinite : Finite cache) {position : EncodingPosition} + {input : HashInput} {answer : HashOutput} + (hnotAt : ¬ AtEncodingPosition parameter input position) : + encodingSelectionCandidates parameter (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) position = + encodingSelectionCandidates parameter cache hfinite position := by + classical + ext candidate + obtain ⟨candidateInput, candidateDigest⟩ := candidate + rw [mem_encodingSelectionCandidates_iff, mem_encodingSelectionCandidates_iff] + constructor + · intro hcandidate + have hne : candidateInput ≠ input := by + intro heq + subst candidateInput + exact hnotAt hcandidate.2.1 + simpa [fromCache, QueryCache.cacheQuery_of_ne _ _ hne] using hcandidate + · intro hcandidate + have hne : candidateInput ≠ input := by + intro heq + subst candidateInput + exact hnotAt hcandidate.2.1 + simpa [fromCache, QueryCache.cacheQuery_of_ne _ _ hne] using hcandidate + +theorem encodingConditionalRiskAtMessage_cacheQuery_eq_of_not_atPosition + {parameter : PublicParameter} {cache : QueryCache HashSpec} + (hfinite : Finite cache) {position : EncodingPosition} + {message : Digest} {input : HashInput} {answer : HashOutput} + (hnotAt : ¬ AtEncodingPosition parameter input position) : + encodingConditionalRiskAtMessage parameter (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) position message = + encodingConditionalRiskAtMessage parameter cache hfinite position message := by + rw [encodingConditionalRiskAtMessage, encodingConditionalRiskAtMessage, + encodingRetrySchedule_cacheQuery_of_ne_of_lt (by + intro counter _ heq + apply hnotAt + exact ⟨digestBytes message ++ + counterBytes (BitVec.ofNat counterBits counter), heq⟩), + encodingSelectionCandidates_cacheQuery_of_not_atPosition hfinite hnotAt] + +theorem uniform_encodingConditionalRiskAtMessage_cacheQuery_of_ne_sum_le + {parameter : PublicParameter} {cache : QueryCache HashSpec} + (hfinite : Finite cache) {position : EncodingPosition} + {message : Digest} {input : HashInput} + (huncached : cache input = none) + (hposition : AtEncodingPosition parameter input position) + (hne : ∀ counter : Nat, counter < encodingAttemptLimit → + input ≠ encodingRetryInput parameter position message counter) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingConditionalRiskAtMessage parameter + (cache.cacheQuery input answer) (finite_cacheQuery hfinite input answer) + position message) ≤ + encodingConditionalRiskAtMessage parameter cache hfinite position message + + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + simp_rw [encodingConditionalRiskAtMessage, + encodingRetrySchedule_cacheQuery_of_ne_of_lt hne, + encodingSelectionCandidates_cacheQuery_self hfinite huncached hposition] + exact EncodingSelection.uniform_candidateTargets_selectionRisk_sum_le input + (encodingRetrySchedule parameter cache position message) + (encodingSelectionCandidates parameter cache hfinite position) + +theorem uniform_encodingConditionalRiskAtMessage_cacheQuery_at_counter_sum_le + {parameter : PublicParameter} {cache : QueryCache HashSpec} + (hfinite : Finite cache) {position : EncodingPosition} + {message : Digest} {counter : Nat} + (hcounter : counter < encodingAttemptLimit) + (huncached : cache (encodingRetryInput parameter position message counter) = none) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingConditionalRiskAtMessage parameter + (cache.cacheQuery (encodingRetryInput parameter position message counter) answer) + (finite_cacheQuery hfinite + (encodingRetryInput parameter position message counter) answer) + position message) ≤ + encodingConditionalRiskAtMessage parameter cache hfinite position message + + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + have hposition : AtEncodingPosition parameter + (encodingRetryInput parameter position message counter) position := + ⟨digestBytes message ++ counterBytes (BitVec.ofNat counterBits counter), rfl⟩ + simp only [encodingConditionalRiskAtMessage] + simp_rw [encodingRetrySchedule_cacheQuery_eq_split hcounter, + encodingSelectionCandidates_cacheQuery_self hfinite huncached hposition] + rw [encodingRetrySchedule_eq_split_of_uncached hcounter huncached] + exact EncodingSelection.uniform_reveal_append_candidate_sum_le + (encodingRetryScheduleFrom parameter cache position message counter 0) + (encodingRetryInput parameter position message counter) + (encodingRetryScheduleFrom parameter cache position message + (encodingAttemptLimit - (counter + 1)) (counter + 1)) + (encodingSelectionCandidates parameter cache hfinite position) + +theorem uniform_encodingConditionalRiskAtMessage_cacheQuery_sum_le + {parameter : PublicParameter} {cache : QueryCache HashSpec} + (hfinite : Finite cache) {position : EncodingPosition} + {message : Digest} {input : HashInput} + (huncached : cache input = none) + (hposition : AtEncodingPosition parameter input position) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingConditionalRiskAtMessage parameter + (cache.cacheQuery input answer) (finite_cacheQuery hfinite input answer) + position message) ≤ + encodingConditionalRiskAtMessage parameter cache hfinite position message + + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + classical + by_cases hretry : ∃ counter : Nat, counter < encodingAttemptLimit ∧ + input = encodingRetryInput parameter position message counter + · obtain ⟨counter, hcounter, heq⟩ := hretry + subst input + exact uniform_encodingConditionalRiskAtMessage_cacheQuery_at_counter_sum_le + hfinite hcounter huncached + · apply uniform_encodingConditionalRiskAtMessage_cacheQuery_of_ne_sum_le + hfinite huncached hposition + intro counter hcounter heq + exact hretry ⟨counter, hcounter, heq⟩ + +@[simp] theorem encodingSelectionCandidates_empty + (parameter : PublicParameter) (position : EncodingPosition) : + encodingSelectionCandidates parameter ∅ finite_empty position = ∅ := by + ext candidate + obtain ⟨input, digest⟩ := candidate + rw [mem_encodingSelectionCandidates_iff] + simp + +@[simp] theorem encodingConditionalRiskAtMessage_empty + (parameter : PublicParameter) (position : EncodingPosition) + (message : Digest) : + encodingConditionalRiskAtMessage parameter ∅ finite_empty position message = 0 := by + rw [encodingConditionalRiskAtMessage, encodingSelectionCandidates_empty, + EncodingSelection.selectionRisk_empty_targets] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingSelectionLift.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingSelectionLift.lean new file mode 100644 index 00000000..687706b2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingSelectionLift.lean @@ -0,0 +1,183 @@ +import SphincsSecurity.Proof.EncodingSelectionPotential +import SphincsSecurity.Proof.CacheSize + +/-! +# Adaptive conditional encoding risk + +The complete one-query inequality lifts through an arbitrary computation handled by the lazy +random oracle. Only fresh hash queries spend one unit of the query budget. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +set_option maxRecDepth 100000 + +/-- The total encoding potential, extended harmlessly to caches not known to be finite. All caches +reachable from the empty lazy random oracle cache are finite. -/ +noncomputable def encodingSelectionAdaptivePotential + (cache : QueryCache HashSpec) (secretKey : SecretKey) : ℝ≥0∞ := + open Classical in + if hfinite : Finite cache then + encodingSelectionTotalPotential cache hfinite secretKey + else 0 + +theorem encodingSelectionAdaptivePotential_eq + {cache : QueryCache HashSpec} (hfinite : Finite cache) (secretKey : SecretKey) : + encodingSelectionAdaptivePotential cache secretKey = + encodingSelectionTotalPotential cache hfinite secretKey := by + rw [encodingSelectionAdaptivePotential, dif_pos hfinite] + +@[simp] theorem encodingSelectionAdaptivePotential_empty (secretKey : SecretKey) : + encodingSelectionAdaptivePotential ∅ secretKey = 0 := by + rw [encodingSelectionAdaptivePotential_eq finite_empty] + exact encodingSelectionTotalPotential_empty secretKey + +theorem uniform_encodingSelectionAdaptivePotential_cacheQuery_sum_le + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} + (huncached : cache input = none) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionAdaptivePotential (cache.cacheQuery input answer) secretKey) ≤ + encodingSelectionAdaptivePotential cache secretKey + + 44 * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + simp_rw [encodingSelectionAdaptivePotential_eq + (finite_cacheQuery hfinite input _)] + rw [encodingSelectionAdaptivePotential_eq hfinite] + exact uniform_encodingSelectionTotalPotential_cacheQuery_sum_le hfinite huncached + +theorem expected_encodingSelectionAdaptivePotential_simulateQ_le + {alpha : Type} (computation : OracleComp OracleWorld alpha) : + ∀ (q : Nat), computation.IsQueryBoundP (· matches Sum.inr _) q → + ∀ (cache : QueryCache HashSpec), Finite cache → ∀ secretKey : SecretKey, + (∑' result, + Pr[= result | (simulateQ romImpl computation).run cache] * + encodingSelectionAdaptivePotential result.2 secretKey) ≤ + encodingSelectionAdaptivePotential cache secretKey + + (44 * q : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + classical + induction computation using OracleComp.inductionOn with + | pure value => + intro q _ cache _ secretKey + simp [simulateQ_pure] + | query_bind query next ih => + intro q hq cache hfinite secretKey + rw [isQueryBoundP_query_bind_iff] at hq + obtain ⟨hcan, hcont⟩ := hq + rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind] + cases query with + | inl input => + simp only [Bool.false_eq_true, if_false] at hcont + have hrun : ((romImpl (Sum.inl input)).run cache + >>= fun result => (simulateQ romImpl (next result.1)).run result.2) = + (liftM (unifSpec.query input) : ProbComp _) >>= fun answer => + (simulateQ romImpl (next answer)).run cache := by + simp [romImpl, unifFwdImpl, QueryImpl.liftTarget, HasQuery.toQueryImpl, + StateT.run_monadLift, map_eq_bind_pure_comp, bind_assoc] + rw [hrun, tsum_probOutput_bind_mul] + calc + _ ≤ ∑' answer, + Pr[= answer | (liftM (unifSpec.query input) : ProbComp _)] * + (encodingSelectionAdaptivePotential cache secretKey + + (44 * q : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹) := by + apply ENNReal.tsum_le_tsum + intro answer + exact mul_le_mul' le_rfl (ih answer q (hcont answer) cache hfinite secretKey) + _ = _ := by + rw [ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul] + | inr input => + simp only [if_true] at hcont + have hq1 : 0 < q := by simpa using hcan + obtain ⟨q', rfl⟩ : ∃ q', q = q' + 1 := ⟨q - 1, by omega⟩ + simp only [Nat.add_sub_cancel] at hcont + simp only [Nat.cast_add, Nat.cast_one] + by_cases huncached : cache input = none + · have hrun : ((romImpl (Sum.inr input)).run cache + >>= fun result => (simulateQ romImpl (next result.1)).run result.2) = + ($ᵗ HashOutput : ProbComp HashOutput) >>= fun answer => + (simulateQ romImpl (next answer)).run + (cache.cacheQuery input answer) := by + have hro : (romImpl (Sum.inr input)).run cache = + ((uniformSampleImpl.withCaching : QueryImpl HashSpec _) input).run cache := rfl + rw [hro, QueryImpl.withCaching_run_none _ huncached] + simp [map_eq_bind_pure_comp, bind_assoc, uniformSampleImpl] + rw [hrun, tsum_probOutput_bind_mul] + calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (encodingSelectionAdaptivePotential (cache.cacheQuery input answer) secretKey + + (44 * q' : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹) := by + apply ENNReal.tsum_le_tsum + intro answer + exact mul_le_mul' le_rfl + (ih answer q' (hcont answer) (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) + _ = (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionAdaptivePotential (cache.cacheQuery input answer) secretKey) + + (44 * q' : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_mul_right, + tsum_probOutput_of_liftM_PMF, one_mul] + _ ≤ (encodingSelectionAdaptivePotential cache secretKey + + 44 * (Fintype.card Digest : ℝ≥0∞)⁻¹) + + (44 * q' : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := + add_le_add + (uniform_encodingSelectionAdaptivePotential_cacheQuery_sum_le + hfinite huncached) le_rfl + _ = encodingSelectionAdaptivePotential cache secretKey + + 44 * ((q' : ℝ≥0∞) + 1) * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + ring + · obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp huncached + have hrun : ((romImpl (Sum.inr input)).run cache + >>= fun result => (simulateQ romImpl (next result.1)).run result.2) = + (simulateQ romImpl (next answer)).run cache := by + have hro : (romImpl (Sum.inr input)).run cache = + ((uniformSampleImpl.withCaching : QueryImpl HashSpec _) input).run cache := rfl + rw [hro, QueryImpl.withCaching_run_some _ hanswer] + simp + rw [hrun] + exact (ih answer q' (hcont answer) cache hfinite secretKey).trans (by + gcongr + norm_num) + +theorem probEvent_clean_encodingBad_simulateQ_le + {alpha : Type} (computation : OracleComp OracleWorld alpha) + (q : Nat) (hq : computation.IsQueryBoundP (· matches Sum.inr _) q) + (secretKey : SecretKey) : + Pr[fun result => + ¬Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret result.2 ∧ + EncodingBad result.2 secretKey | + (simulateQ romImpl computation).run ∅] ≤ + (44 * q : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + classical + rw [probEvent_eq_tsum_ite] + calc + _ ≤ ∑' result, + Pr[= result | (simulateQ romImpl computation).run ∅] * + encodingSelectionAdaptivePotential result.2 secretKey := by + apply ENNReal.tsum_le_tsum + intro result + by_cases hevent : + ¬Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret result.2 ∧ + EncodingBad result.2 secretKey + · rw [if_pos hevent] + by_cases hresult : result ∈ support ((simulateQ romImpl computation).run ∅) + · have hfinite : Finite result.2 := Finite.of_enncard_le + (simulateQ_romImpl_enncard_le_queryBound computation q hq result hresult) + rw [encodingSelectionAdaptivePotential_eq hfinite, + encodingSelectionTotalPotential_eq_one_of_clean_of_encodingBad + hfinite hevent.1 hevent.2, mul_one] + · rw [probOutput_eq_zero_of_not_mem_support hresult, zero_mul] + · rw [if_neg hevent] + exact bot_le + _ ≤ encodingSelectionAdaptivePotential ∅ secretKey + + (44 * q : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := + expected_encodingSelectionAdaptivePotential_simulateQ_le computation q hq ∅ + finite_empty secretKey + _ = _ := by simp + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingSelectionPotential.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingSelectionPotential.lean new file mode 100644 index 00000000..93554fbf --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingSelectionPotential.lean @@ -0,0 +1,1554 @@ +import SphincsSecurity.Proof.EncodingSelectionCache +import SphincsSecurity.Proof.EncodingStageCharge + +/-! +# Conditional encoding collision potential + +Before an honest layer message is settled, the existing normalized valid-answer contribution +retains the risk of every cached encoding answer. Once the message is settled, the exact +cache-derived retry schedule replaces that coarse contribution. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +set_option maxRecDepth 100000 + +noncomputable def encodingSettledMessage + (cache : QueryCache HashSpec) (secretKey : SecretKey) + (position : EncodingPosition) : Digest := + open Classical in + if hsettled : EncodingMessageSettledAt cache secretKey position then + honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret + (layerMessagePosition (Classical.choose hsettled) position.lay) + else + 0 + +theorem encodingSettledMessage_eq_of_witness + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {position : EncodingPosition} {index : Index} + (htree : treeIndexAt index position.lay = position.tree) + (hleaf : leafIndexAt index position.lay = position.leafIdx) + (hsettled : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + cache (layerMessagePosition index position.lay)) : + encodingSettledMessage cache secretKey position = + honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (layerMessagePosition index position.lay) := by + classical + rw [encodingSettledMessage, dif_pos ⟨index, htree, hleaf, hsettled⟩] + have hchosen := Classical.choose_spec + (show EncodingMessageSettledAt cache secretKey position from + ⟨index, htree, hleaf, hsettled⟩) + have hposition := layerMessagePosition_eq_of_position_eq + (Classical.choose + (show EncodingMessageSettledAt cache secretKey position from + ⟨index, htree, hleaf, hsettled⟩)) + index position.lay (hchosen.1.trans htree.symm) + (hchosen.2.1.trans hleaf.symm) + rw [hposition] + +theorem encodingSettledMessage_eq_of_le + {cache cache' : QueryCache HashSpec} {secretKey : SecretKey} + {position : EncodingPosition} (hle : cache ≤ cache') + (hsettled : EncodingMessageSettledAt cache secretKey position) : + encodingSettledMessage cache' secretKey position = + encodingSettledMessage cache secretKey position := by + obtain ⟨index, htree, hleaf, hposition⟩ := hsettled + rw [encodingSettledMessage_eq_of_witness htree hleaf hposition, + encodingSettledMessage_eq_of_witness htree hleaf (hposition.mono hle)] + exact honestValue_eq_of_settled (agreesWithFn_fromCache_of_le hle) hposition + +theorem encodingPosition_eq_of_layerMessagePosition_eq + {left right : EncodingPosition} {leftIndex rightIndex : Index} + (hleftTree : treeIndexAt leftIndex left.lay = left.tree) + (hleftLeaf : leafIndexAt leftIndex left.lay = left.leafIdx) + (hrightTree : treeIndexAt rightIndex right.lay = right.tree) + (hrightLeaf : leafIndexAt rightIndex right.lay = right.leafIdx) + (heq : layerMessagePosition leftIndex left.lay = + layerMessagePosition rightIndex right.lay) : + left = right := by + obtain ⟨leftLay, leftTree, leftLeaf⟩ := left + obtain ⟨rightLay, rightTree, rightLeaf⟩ := right + have hlay : leftLay = rightLay := by + fin_cases leftLay <;> fin_cases rightLay + all_goals try rfl + all_goals norm_num [layerMessagePosition, topLayer, middleLayer, bottomLayer, + numLayers] at heq + all_goals try { cases heq } + subst rightLay + fin_cases leftLay + · have hnext : treeIndexAt leftIndex middleLayer = + treeIndexAt rightIndex middleLayer := by + change layerMessagePosition leftIndex topLayer = + layerMessagePosition rightIndex topLayer at heq + simp only [layerMessagePosition_top, Position.node.injEq] at heq + exact heq.2.1 + change treeIndexAt leftIndex topLayer = leftTree at hleftTree + change leafIndexAt leftIndex topLayer = leftLeaf at hleftLeaf + change treeIndexAt rightIndex topLayer = rightTree at hrightTree + change leafIndexAt rightIndex topLayer = rightLeaf at hrightLeaf + have hnextVal := congrArg Fin.val hnext + have hleftLink := layers_link_top leftIndex + have hrightLink := layers_link_top rightIndex + have hleftTreeVal := congrArg Fin.val hleftTree + have hrightTreeVal := congrArg Fin.val hrightTree + have hleftLeafVal := congrArg Fin.val hleftLeaf + have hrightLeafVal := congrArg Fin.val hrightLeaf + have hleftTop := treeIndexAt_topLayer leftIndex + have hrightTop := treeIndexAt_topLayer rightIndex + have htreeEq : leftTree = rightTree := by + rw [← hleftTree, ← hrightTree] + apply Fin.ext + rw [treeIndexAt_topLayer, treeIndexAt_topLayer] + have hleafEq : leftLeaf = rightLeaf := by + rw [← hleftLeaf, ← hrightLeaf] + apply Fin.ext + norm_num [layerHeight] at hleftLink hrightLink + rw [hleftTop] at hleftLink + rw [hrightTop] at hrightLink + omega + cases htreeEq + cases hleafEq + rfl + · have hnext : treeIndexAt leftIndex bottomLayer = + treeIndexAt rightIndex bottomLayer := by + change layerMessagePosition leftIndex middleLayer = + layerMessagePosition rightIndex middleLayer at heq + simp only [layerMessagePosition_middle, Position.node.injEq] at heq + exact heq.2.1 + change treeIndexAt leftIndex middleLayer = leftTree at hleftTree + change leafIndexAt leftIndex middleLayer = leftLeaf at hleftLeaf + change treeIndexAt rightIndex middleLayer = rightTree at hrightTree + change leafIndexAt rightIndex middleLayer = rightLeaf at hrightLeaf + have hnextVal := congrArg Fin.val hnext + have hleftLink := layers_link_middle leftIndex + have hrightLink := layers_link_middle rightIndex + norm_num [show layerHeight middleLayer = 7 by decide] at hleftLink hrightLink + have hleftLeafLt : (leafIndexAt leftIndex middleLayer).val < 128 := by + simpa [layerHeight, middleLayer] using leafIndexAt_lt leftIndex middleLayer + have hrightLeafLt : (leafIndexAt rightIndex middleLayer).val < 128 := by + simpa [layerHeight, middleLayer] using leafIndexAt_lt rightIndex middleLayer + have hleftTreeFormula : (treeIndexAt leftIndex middleLayer).val = + (treeIndexAt leftIndex bottomLayer).val / 128 := by + rw [Nat.mul_comm (treeIndexAt leftIndex middleLayer).val 128] at hleftLink + rw [hleftLink] + rw [Nat.mul_add_div (by norm_num), Nat.div_eq_of_lt hleftLeafLt, Nat.add_zero] + have hrightTreeFormula : (treeIndexAt rightIndex middleLayer).val = + (treeIndexAt rightIndex bottomLayer).val / 128 := by + rw [Nat.mul_comm (treeIndexAt rightIndex middleLayer).val 128] at hrightLink + rw [hrightLink] + rw [Nat.mul_add_div (by norm_num), Nat.div_eq_of_lt hrightLeafLt, Nat.add_zero] + have hleftLeafFormula : (leafIndexAt leftIndex middleLayer).val = + (treeIndexAt leftIndex bottomLayer).val % 128 := by + rw [hleftLink] + rw [Nat.mul_comm (treeIndexAt leftIndex middleLayer).val 128] + rw [Nat.mul_add_mod, Nat.mod_eq_of_lt hleftLeafLt] + have hrightLeafFormula : (leafIndexAt rightIndex middleLayer).val = + (treeIndexAt rightIndex bottomLayer).val % 128 := by + rw [hrightLink] + rw [Nat.mul_comm (treeIndexAt rightIndex middleLayer).val 128] + rw [Nat.mul_add_mod, Nat.mod_eq_of_lt hrightLeafLt] + have htreeEq : leftTree = rightTree := by + rw [← hleftTree, ← hrightTree] + apply Fin.ext + rw [hleftTreeFormula, hrightTreeFormula, hnextVal] + have hleafEq : leftLeaf = rightLeaf := by + rw [← hleftLeaf, ← hrightLeaf] + apply Fin.ext + rw [hleftLeafFormula, hrightLeafFormula, hnextVal] + cases htreeEq + cases hleafEq + rfl + · have hindex : leftIndex = rightIndex := by + change layerMessagePosition leftIndex bottomLayer = + layerMessagePosition rightIndex bottomLayer at heq + simpa only [layerMessagePosition_bottom, Position.ftsRoots.injEq] using heq + subst rightIndex + change treeIndexAt leftIndex bottomLayer = leftTree at hleftTree + change leafIndexAt leftIndex bottomLayer = leftLeaf at hleftLeaf + change treeIndexAt leftIndex bottomLayer = rightTree at hrightTree + change leafIndexAt leftIndex bottomLayer = rightLeaf at hrightLeaf + have htreeEq : leftTree = rightTree := hleftTree.symm.trans hrightTree + have hleafEq : leftLeaf = rightLeaf := hleftLeaf.symm.trans hrightLeaf + cases htreeEq + cases hleafEq + rfl + +theorem EncodingMessageSettledAt.of_cacheQuery_of_atEncoding + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} {queriedPosition : EncodingPosition} + (huncached : cache input = none) + (hqueried : AtEncodingPosition secretKey.parameter input queriedPosition) + {position : EncodingPosition} + (hsettled : EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position) : + EncodingMessageSettledAt cache secretKey position := by + obtain ⟨index, htree, hleaf, hposition⟩ := hsettled + refine ⟨index, htree, hleaf, ?_⟩ + exact settled_of_settled_cacheQuery secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret huncached (p₀ := none) + (fun structuralPosition hat => + (hqueried.not_atPosition structuralPosition hat).elim) + (by simp) ((layerMessagePosition index position.lay).depth + 1) + (layerMessagePosition index position.lay) (by omega) (by simp) hposition + +theorem EncodingMessageSettledAt.of_cacheQuery_of_not_atPosition + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} + (huncached : cache input = none) + (hnotAt : ∀ position : Position, + ¬ AtPosition secretKey.parameter input position) + {position : EncodingPosition} + (hsettled : EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position) : + EncodingMessageSettledAt cache secretKey position := by + obtain ⟨index, htree, hleaf, hposition⟩ := hsettled + refine ⟨index, htree, hleaf, ?_⟩ + exact settled_of_settled_cacheQuery secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret huncached (p₀ := none) + (fun structuralPosition hat => (hnotAt structuralPosition hat).elim) + (by simp) ((layerMessagePosition index position.lay).depth + 1) + (layerMessagePosition index position.lay) (by omega) (by simp) hposition + +theorem EncodingMessageSettledAt.of_cacheQuery_of_at_settled + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} {queriedPosition : Position} + (huncached : cache input = none) + (hqueried : AtPosition secretKey.parameter input queriedPosition) + (hqueriedSettled : Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache queriedPosition) + {position : EncodingPosition} + (hsettled : EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position) : + EncodingMessageSettledAt cache secretKey position := by + obtain ⟨index, htree, hleaf, hposition⟩ := hsettled + refine ⟨index, htree, hleaf, ?_⟩ + exact settled_of_cacheQuery_at_settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret huncached hqueried hqueriedSettled + ((layerMessagePosition index position.lay).depth + 1) + (layerMessagePosition index position.lay) (by omega) hposition + +theorem EncodingMessageSettledAt.of_cacheQuery_of_at_unsettledAfter + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} {queriedPosition : Position} + (huncached : cache input = none) + (hqueried : AtPosition secretKey.parameter input queriedPosition) + (hqueriedUnsettled : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (cache.cacheQuery input answer) queriedPosition) + {position : EncodingPosition} + (hsettled : EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position) : + EncodingMessageSettledAt cache secretKey position := by + obtain ⟨index, htree, hleaf, hposition⟩ := hsettled + refine ⟨index, htree, hleaf, ?_⟩ + apply settled_of_settled_cacheQuery secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret huncached (p₀ := some queriedPosition) + (fun structuralPosition hat => by + rw [atPosition_unique secretKey.parameter hqueried hat]) + (fun structuralPosition parent heq hparent hparentSettled => by + have hpositionEq : structuralPosition = queriedPosition := Option.some.inj heq.symm + subst structuralPosition + exact hqueriedUnsettled + (hparentSettled.children queriedPosition (Position.mem_children_iff.mpr hparent))) + ((layerMessagePosition index position.lay).depth + 1) + (layerMessagePosition index position.lay) (by omega) + (by + intro heq + have hpositionEq := Option.some.inj heq + exact hqueriedUnsettled (hpositionEq ▸ hposition)) hposition + +noncomputable def encodingSelectionContribution + (cache : QueryCache HashSpec) (hfinite : Finite cache) + (secretKey : SecretKey) (position : EncodingPosition) : ℝ≥0∞ := + open Classical in + if EncodingMessageSettledAt cache secretKey position then + encodingConditionalRiskAtMessage secretKey.parameter cache hfinite position + (encodingSettledMessage cache secretKey position) + else + encodingRetryContribution cache secretKey position + +noncomputable def encodingSelectionPotential + (cache : QueryCache HashSpec) (hfinite : Finite cache) + (secretKey : SecretKey) : ℝ≥0∞ := + ∑ position : EncodingPosition, + encodingSelectionContribution cache hfinite secretKey position + +noncomputable def encodingSelectionTotalPotential + (cache : QueryCache HashSpec) (hfinite : Finite cache) + (secretKey : SecretKey) : ℝ≥0∞ := + open Classical in + if Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache then 0 + else min 1 ((encodingStructuralPotential cache secretKey : ℝ≥0∞) * + (Fintype.card Digest : ℝ≥0∞)⁻¹ + + encodingSelectionPotential cache hfinite secretKey) + +theorem encodingSelectionContribution_eq_conditional + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {position : EncodingPosition} + (hsettled : EncodingMessageSettledAt cache secretKey position) : + encodingSelectionContribution cache hfinite secretKey position = + encodingConditionalRiskAtMessage secretKey.parameter cache hfinite position + (encodingSettledMessage cache secretKey position) := by + rw [encodingSelectionContribution, if_pos hsettled] + +theorem encodingSelectionContribution_eq_retry + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {position : EncodingPosition} + (hunsettled : ¬ EncodingMessageSettledAt cache secretKey position) : + encodingSelectionContribution cache hfinite secretKey position = + encodingRetryContribution cache secretKey position := by + rw [encodingSelectionContribution, if_neg hunsettled] + +theorem encodingSelectionContribution_cacheQuery_eq_of_settled_of_not_atPosition + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} (huncached : cache input = none) + (hsettled : EncodingMessageSettledAt cache secretKey position) + (hnotAt : ¬ AtEncodingPosition secretKey.parameter input position) : + encodingSelectionContribution (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey position = + encodingSelectionContribution cache hfinite secretKey position := by + have hle := le_cacheQuery (cache := cache) (input := input) (answer := answer) huncached + rw [encodingSelectionContribution_eq_conditional _ (hsettled.mono hle), + encodingSelectionContribution_eq_conditional hfinite hsettled, + encodingSettledMessage_eq_of_le hle hsettled, + encodingConditionalRiskAtMessage_cacheQuery_eq_of_not_atPosition hfinite hnotAt] + +theorem encodingSelectionContribution_cacheQuery_le_of_unsettled_of_stillUnsettled_of_not_atPosition + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} (huncached : cache input = none) + (hunsettled : ¬ EncodingMessageSettledAt cache secretKey position) + (hstillUnsettled : ¬ EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position) + (hnotAt : ¬ AtEncodingPosition secretKey.parameter input position) : + encodingSelectionContribution (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey position ≤ + encodingSelectionContribution cache hfinite secretKey position := by + rw [encodingSelectionContribution_eq_retry _ hstillUnsettled, + encodingSelectionContribution_eq_retry hfinite hunsettled] + exact encodingRetryContribution_cacheQuery_le_of_not_atPosition + huncached position hnotAt + +theorem encodingSelectionContribution_cacheQuery_le_of_newlySettled_of_not_hasCachedHit + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} + (hunsettled : ¬ EncodingMessageSettledAt cache secretKey position) + (hsettled : EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position) + (hnotAt : ¬ AtEncodingPosition secretKey.parameter input position) + (hclean : ¬ EncodingSelection.HasCachedHit + (encodingRetrySchedule secretKey.parameter (cache.cacheQuery input answer) + position (encodingSettledMessage (cache.cacheQuery input answer) secretKey position)) + (encodingSelectionCandidates secretKey.parameter (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) position)) : + encodingSelectionContribution (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey position ≤ + encodingSelectionContribution cache hfinite secretKey position := by + have hnotTarget : ¬ HasEncodingTarget cache secretKey position := + fun htarget => hunsettled htarget.messageSettled + rw [encodingSelectionContribution_eq_conditional _ hsettled, + encodingSelectionContribution_eq_retry hfinite hunsettled, + encodingConditionalRiskAtMessage] + calc + EncodingSelection.selectionRisk + (encodingRetrySchedule secretKey.parameter (cache.cacheQuery input answer) + position (encodingSettledMessage (cache.cacheQuery input answer) secretKey position)) + (encodingSelectionCandidates secretKey.parameter (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) position) ≤ + EncodingRetry.pendingRisk + (EncodingSelection.targetDigests + (encodingSelectionCandidates secretKey.parameter (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) position)) := + EncodingSelection.selectionRisk_le_pendingRisk_of_not_hasCachedHit _ _ hclean + _ = EncodingRetry.pendingRisk + (EncodingSelection.targetDigests + (encodingSelectionCandidates secretKey.parameter cache hfinite position)) := by + rw [encodingSelectionCandidates_cacheQuery_of_not_atPosition hfinite hnotAt] + _ = EncodingRetry.pendingRisk + (encodingValidAnswerTargets secretKey.parameter cache hfinite position) := by + rw [targetDigests_encodingSelectionCandidates] + _ = encodingRetryContribution cache secretKey position := + (encodingRetryContribution_eq_pendingRisk hfinite hnotTarget).symm + +theorem latentEncodingBadAt_of_newlySettled_of_encodingSelection_hasCachedHit + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} + (hsettled : EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position) + (hhit : EncodingSelection.HasCachedHit + (encodingRetrySchedule secretKey.parameter (cache.cacheQuery input answer) + position (encodingSettledMessage (cache.cacheQuery input answer) secretKey position)) + (encodingSelectionCandidates secretKey.parameter (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) position)) : + LatentEncodingBadAt (cache.cacheQuery input answer) secretKey position := by + obtain ⟨index, htree, hleaf, hposition⟩ := hsettled + exact latentEncodingBadAt_of_encodingSelection_hasCachedHit + (finite_cacheQuery hfinite input answer) htree hleaf hposition + (encodingSettledMessage_eq_of_witness htree hleaf hposition) hhit + +theorem encodingConditionalRiskAtMessage_le_one + {parameter : PublicParameter} {cache : QueryCache HashSpec} + (hfinite : Finite cache) {position : EncodingPosition} {message : Digest} : + encodingConditionalRiskAtMessage parameter cache hfinite position message ≤ 1 := by + rw [encodingConditionalRiskAtMessage] + exact probEvent_le_one + +theorem encodingSelection_hasCachedHit_mem_messageTargets_of_newlySettled + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} {index : Index} + (huncached : cache input = none) + (htree : treeIndexAt index position.lay = position.tree) + (hleaf : leafIndexAt index position.lay = position.leafIdx) + (hunsettled : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache (layerMessagePosition index position.lay)) + (hsettled : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) (layerMessagePosition index position.lay)) + (hposition : AtPosition secretKey.parameter input + (layerMessagePosition index position.lay)) + (hhit : EncodingSelection.HasCachedHit + (encodingRetrySchedule secretKey.parameter (cache.cacheQuery input answer) + position (encodingSettledMessage (cache.cacheQuery input answer) secretKey position)) + (encodingSelectionCandidates secretKey.parameter (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) position)) : + truncateHash answer ∈ + encodingMessageTargets secretKey.parameter cache hfinite position := by + have hbad := latentEncodingBadAt_of_newlySettled_of_encodingSelection_hasCachedHit + hfinite (show EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position from + ⟨index, htree, hleaf, hsettled⟩) hhit + exact latentEncodingBadAt_message_hit_of_settling_query hfinite huncached + htree hleaf hposition hunsettled hbad + +theorem encodingSelection_hasCachedHit_mem_settlingTargets_of_prematureSettlement + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} {index : Index} {queriedPosition : Position} + (huncached : cache input = none) + (htree : treeIndexAt index position.lay = position.tree) + (hleaf : leafIndexAt index position.lay = position.leafIdx) + (hunsettled : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache (layerMessagePosition index position.lay)) + (hsettled : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) (layerMessagePosition index position.lay)) + (hnotMessage : ¬ AtPosition secretKey.parameter input + (layerMessagePosition index position.lay)) + (hqueried : AtPosition secretKey.parameter input queriedPosition) + (hhit : EncodingSelection.HasCachedHit + (encodingRetrySchedule secretKey.parameter (cache.cacheQuery input answer) + position (encodingSettledMessage (cache.cacheQuery input answer) secretKey position)) + (encodingSelectionCandidates secretKey.parameter (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) position)) : + truncateHash answer ∈ + settlingTargets secretKey.parameter cache hfinite queriedPosition := by + have hbad := latentEncodingBadAt_of_newlySettled_of_encodingSelection_hasCachedHit + hfinite (show EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position from + ⟨index, htree, hleaf, hsettled⟩) hhit + obtain ⟨targetIndex, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htargetTree, htargetLeaf, htargetSettled, hpayload, + htargetAnswer, htargetValid, hbefore, hpayloadNe, hotherAnswer, + hcollision⟩ := hbad + have hmessagePosition : layerMessagePosition index position.lay = + layerMessagePosition targetIndex position.lay := + layerMessagePosition_eq_of_position_eq index targetIndex position.lay + (htree.trans htargetTree.symm) (hleaf.trans htargetLeaf.symm) + have hpremature : PrematureLayerMessageSettlement cache secretKey input answer := + ⟨position, targetIndex, htargetTree, htargetLeaf, + by rwa [← hmessagePosition], htargetSettled, + by rwa [← hmessagePosition]⟩ + obtain ⟨candidate, hcandidate, _, _, hmem⟩ := + hpremature.mem_settlingTargets hfinite huncached + have heq : candidate = queriedPosition := + atPosition_unique secretKey.parameter hcandidate hqueried + simpa only [heq] using hmem + +theorem encodingSelectionContribution_cacheQuery_le_add_messageBonus + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} {index : Index} + (huncached : cache input = none) + (htree : treeIndexAt index position.lay = position.tree) + (hleaf : leafIndexAt index position.lay = position.leafIdx) + (hunsettled : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache (layerMessagePosition index position.lay)) + (hposition : AtPosition secretKey.parameter input + (layerMessagePosition index position.lay)) : + encodingSelectionContribution (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey position ≤ + encodingSelectionContribution cache hfinite secretKey position + + if truncateHash answer ∈ + encodingMessageTargets secretKey.parameter cache hfinite position then 1 else 0 := by + have hnotAt : ¬ AtEncodingPosition secretKey.parameter input position := + fun hencoding => hencoding.not_atPosition + (layerMessagePosition index position.lay) hposition + have hmessageUnsettled : ¬ EncodingMessageSettledAt cache secretKey position := by + rintro ⟨candidate, hcandidateTree, hcandidateLeaf, hcandidateSettled⟩ + have hpositionEq := layerMessagePosition_eq_of_position_eq index candidate + position.lay (htree.trans hcandidateTree.symm) + (hleaf.trans hcandidateLeaf.symm) + apply hunsettled + rwa [hpositionEq] + by_cases hmessageSettled : EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position + · by_cases hhit : EncodingSelection.HasCachedHit + (encodingRetrySchedule secretKey.parameter (cache.cacheQuery input answer) + position (encodingSettledMessage (cache.cacheQuery input answer) secretKey position)) + (encodingSelectionCandidates secretKey.parameter (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) position) + · obtain ⟨candidate, hcandidateTree, hcandidateLeaf, hcandidateSettled⟩ := + (show EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position from hmessageSettled) + have hpositionEq := layerMessagePosition_eq_of_position_eq index candidate + position.lay (htree.trans hcandidateTree.symm) + (hleaf.trans hcandidateLeaf.symm) + have hsettled : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) (layerMessagePosition index position.lay) := by + rwa [hpositionEq] + have hmem := encodingSelection_hasCachedHit_mem_messageTargets_of_newlySettled + hfinite huncached htree hleaf hunsettled hsettled hposition hhit + rw [if_pos hmem, encodingSelectionContribution_eq_conditional _ hmessageSettled] + exact (encodingConditionalRiskAtMessage_le_one _).trans (le_add_left le_rfl) + · exact (encodingSelectionContribution_cacheQuery_le_of_newlySettled_of_not_hasCachedHit + hfinite hmessageUnsettled hmessageSettled hnotAt hhit).trans + (le_add_right le_rfl) + · exact + (encodingSelectionContribution_cacheQuery_le_of_unsettled_of_stillUnsettled_of_not_atPosition + hfinite huncached hmessageUnsettled hmessageSettled hnotAt).trans + (le_add_right le_rfl) + +theorem uniform_encodingSelectionContribution_cacheQuery_add_messageTargets_sum_le + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} + {position : EncodingPosition} {index : Index} + (huncached : cache input = none) + (htree : treeIndexAt index position.lay = position.tree) + (hleaf : leafIndexAt index position.lay = position.leafIdx) + (hunsettled : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache (layerMessagePosition index position.lay)) + (hposition : AtPosition secretKey.parameter input + (layerMessagePosition index position.lay)) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionContribution (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey position) ≤ + encodingSelectionContribution cache hfinite secretKey position + + (encodingMessageTargets secretKey.parameter cache hfinite position).card * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (encodingSelectionContribution cache hfinite secretKey position + + if truncateHash answer ∈ + encodingMessageTargets secretKey.parameter cache hfinite position then 1 else 0) := by + apply ENNReal.tsum_le_tsum + intro answer + exact mul_le_mul_right + (encodingSelectionContribution_cacheQuery_le_add_messageBonus hfinite + huncached htree hleaf hunsettled hposition) _ + _ = encodingSelectionContribution cache hfinite secretKey position + + ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if truncateHash answer ∈ + encodingMessageTargets secretKey.parameter cache hfinite position then 1 else 0) := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_mul_right, + tsum_probOutput_of_liftM_PMF, one_mul] + _ = _ := by rw [uniformHashOutput_mem_bonus_sum_eq] + +theorem encodingSelectionContribution_cacheQuery_le_add_settlingBonus + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} {index : Index} {queriedPosition : Position} + (huncached : cache input = none) + (htree : treeIndexAt index position.lay = position.tree) + (hleaf : leafIndexAt index position.lay = position.leafIdx) + (hunsettled : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache (layerMessagePosition index position.lay)) + (hnotMessage : ¬ AtPosition secretKey.parameter input + (layerMessagePosition index position.lay)) + (hqueried : AtPosition secretKey.parameter input queriedPosition) : + encodingSelectionContribution (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey position ≤ + encodingSelectionContribution cache hfinite secretKey position + + if truncateHash answer ∈ + settlingTargets secretKey.parameter cache hfinite queriedPosition then 1 else 0 := by + have hnotAt : ¬ AtEncodingPosition secretKey.parameter input position := + fun hencoding => hencoding.not_atPosition queriedPosition hqueried + have hmessageUnsettled : ¬ EncodingMessageSettledAt cache secretKey position := by + rintro ⟨candidate, hcandidateTree, hcandidateLeaf, hcandidateSettled⟩ + have hpositionEq := layerMessagePosition_eq_of_position_eq index candidate + position.lay (htree.trans hcandidateTree.symm) + (hleaf.trans hcandidateLeaf.symm) + apply hunsettled + rwa [hpositionEq] + by_cases hmessageSettled : EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position + · by_cases hhit : EncodingSelection.HasCachedHit + (encodingRetrySchedule secretKey.parameter (cache.cacheQuery input answer) + position (encodingSettledMessage (cache.cacheQuery input answer) secretKey position)) + (encodingSelectionCandidates secretKey.parameter (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) position) + · obtain ⟨candidate, hcandidateTree, hcandidateLeaf, hcandidateSettled⟩ := + (show EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position from hmessageSettled) + have hpositionEq := layerMessagePosition_eq_of_position_eq index candidate + position.lay (htree.trans hcandidateTree.symm) + (hleaf.trans hcandidateLeaf.symm) + have hsettled : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) (layerMessagePosition index position.lay) := by + rwa [hpositionEq] + have hmem := + encodingSelection_hasCachedHit_mem_settlingTargets_of_prematureSettlement + hfinite huncached htree hleaf hunsettled hsettled hnotMessage hqueried hhit + rw [if_pos hmem, encodingSelectionContribution_eq_conditional _ hmessageSettled] + exact (encodingConditionalRiskAtMessage_le_one _).trans (le_add_left le_rfl) + · exact (encodingSelectionContribution_cacheQuery_le_of_newlySettled_of_not_hasCachedHit + hfinite hmessageUnsettled hmessageSettled hnotAt hhit).trans + (le_add_right le_rfl) + · exact + (encodingSelectionContribution_cacheQuery_le_of_unsettled_of_stillUnsettled_of_not_atPosition + hfinite huncached hmessageUnsettled hmessageSettled hnotAt).trans + (le_add_right le_rfl) + +theorem uniform_encodingSelectionContribution_cacheQuery_add_settlingTargets_sum_le + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} + {position : EncodingPosition} {index : Index} {queriedPosition : Position} + (huncached : cache input = none) + (htree : treeIndexAt index position.lay = position.tree) + (hleaf : leafIndexAt index position.lay = position.leafIdx) + (hunsettled : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache (layerMessagePosition index position.lay)) + (hnotMessage : ¬ AtPosition secretKey.parameter input + (layerMessagePosition index position.lay)) + (hqueried : AtPosition secretKey.parameter input queriedPosition) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionContribution (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey position) ≤ + encodingSelectionContribution cache hfinite secretKey position + + (settlingTargets secretKey.parameter cache hfinite queriedPosition).card * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (encodingSelectionContribution cache hfinite secretKey position + + if truncateHash answer ∈ + settlingTargets secretKey.parameter cache hfinite queriedPosition then 1 else 0) := by + apply ENNReal.tsum_le_tsum + intro answer + exact mul_le_mul_right + (encodingSelectionContribution_cacheQuery_le_add_settlingBonus hfinite + huncached htree hleaf hunsettled hnotMessage hqueried) _ + _ = encodingSelectionContribution cache hfinite secretKey position + + ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if truncateHash answer ∈ + settlingTargets secretKey.parameter cache hfinite queriedPosition then 1 else 0) := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_mul_right, + tsum_probOutput_of_liftM_PMF, one_mul] + _ = _ := by rw [uniformHashOutput_mem_bonus_sum_eq] + +theorem encodingSelectionPotential_cacheQuery_le_of_avoids_settlementTargets + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {queriedPosition : Position} + (huncached : cache input = none) + (hqueried : AtPosition secretKey.parameter input queriedPosition) + (havoidMessage : ∀ (position : EncodingPosition) (index : Index), + treeIndexAt index position.lay = position.tree → + leafIndexAt index position.lay = position.leafIdx → + AtPosition secretKey.parameter input (layerMessagePosition index position.lay) → + truncateHash answer ∉ + encodingMessageTargets secretKey.parameter cache hfinite position) + (havoidSettling : truncateHash answer ∉ + settlingTargets secretKey.parameter cache hfinite queriedPosition) : + encodingSelectionPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey ≤ + encodingSelectionPotential cache hfinite secretKey := by + rw [encodingSelectionPotential, encodingSelectionPotential] + apply Finset.sum_le_sum + intro position _ + have hnotAt : ¬ AtEncodingPosition secretKey.parameter input position := + fun hencoding => hencoding.not_atPosition queriedPosition hqueried + by_cases hmessageSettled : EncodingMessageSettledAt cache secretKey position + · exact le_of_eq + (encodingSelectionContribution_cacheQuery_eq_of_settled_of_not_atPosition + hfinite huncached hmessageSettled hnotAt) + · by_cases hmessageSettledAfter : EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position + · by_cases hhit : EncodingSelection.HasCachedHit + (encodingRetrySchedule secretKey.parameter (cache.cacheQuery input answer) + position (encodingSettledMessage (cache.cacheQuery input answer) secretKey position)) + (encodingSelectionCandidates secretKey.parameter (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) position) + · obtain ⟨index, htree, hleaf, hsettled⟩ := + (show EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position from hmessageSettledAfter) + have hunsettled : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache (layerMessagePosition index position.lay) := by + intro hposition + exact hmessageSettled ⟨index, htree, hleaf, hposition⟩ + by_cases hmessage : AtPosition secretKey.parameter input + (layerMessagePosition index position.lay) + · exact (havoidMessage position index htree hleaf hmessage + (encodingSelection_hasCachedHit_mem_messageTargets_of_newlySettled + hfinite huncached htree hleaf hunsettled hsettled hmessage hhit)).elim + · exact (havoidSettling + (encodingSelection_hasCachedHit_mem_settlingTargets_of_prematureSettlement + hfinite huncached htree hleaf hunsettled hsettled hmessage hqueried hhit)).elim + · exact encodingSelectionContribution_cacheQuery_le_of_newlySettled_of_not_hasCachedHit + hfinite hmessageSettled hmessageSettledAfter hnotAt hhit + · exact + encodingSelectionContribution_cacheQuery_le_of_unsettled_of_stillUnsettled_of_not_atPosition + hfinite huncached hmessageSettled hmessageSettledAfter hnotAt + +theorem encodingSelectionPotential_cacheQuery_le_of_no_new_messages + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + (huncached : cache input = none) + (hnotEncoding : ∀ position : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input position) + (hnoNew : ∀ position : EncodingPosition, + EncodingMessageSettledAt (cache.cacheQuery input answer) secretKey position → + EncodingMessageSettledAt cache secretKey position) : + encodingSelectionPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey ≤ + encodingSelectionPotential cache hfinite secretKey := by + rw [encodingSelectionPotential, encodingSelectionPotential] + apply Finset.sum_le_sum + intro position _ + by_cases hsettled : EncodingMessageSettledAt cache secretKey position + · exact le_of_eq + (encodingSelectionContribution_cacheQuery_eq_of_settled_of_not_atPosition + hfinite huncached hsettled (hnotEncoding position)) + · have hstillUnsettled : ¬ EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position := + fun hafter => hsettled (hnoNew position hafter) + exact + encodingSelectionContribution_cacheQuery_le_of_unsettled_of_stillUnsettled_of_not_atPosition + hfinite huncached hsettled hstillUnsettled (hnotEncoding position) + +theorem uniform_encodingSelectionContribution_cacheQuery_atPosition_sum_le + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {position : EncodingPosition} + (huncached : cache input = none) + (hposition : AtEncodingPosition secretKey.parameter input position) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionContribution (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey position) ≤ + encodingSelectionContribution cache hfinite secretKey position + + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + have hle (answer : HashOutput) := + le_cacheQuery (cache := cache) (input := input) (answer := answer) huncached + by_cases hsettled : EncodingMessageSettledAt cache secretKey position + · simp_rw [encodingSelectionContribution_eq_conditional _ (hsettled.mono (hle _)), + encodingSettledMessage_eq_of_le (hle _) hsettled] + rw [encodingSelectionContribution_eq_conditional hfinite hsettled] + exact uniform_encodingConditionalRiskAtMessage_cacheQuery_sum_le + hfinite huncached hposition + · have hstillUnsettled : ∀ answer : HashOutput, + ¬ EncodingMessageSettledAt (cache.cacheQuery input answer) secretKey position := by + intro answer hafter + exact hsettled (hafter.of_cacheQuery_of_atEncoding huncached hposition) + simp_rw [encodingSelectionContribution_eq_retry _ (hstillUnsettled _)] + rw [encodingSelectionContribution_eq_retry hfinite hsettled] + calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (encodingRetryContribution cache secretKey position + + if TargetSum.ValidDigest (truncateHash answer) then + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ else 0) := by + apply ENNReal.tsum_le_tsum + intro answer + gcongr + exact encodingRetryContribution_cacheQuery_le hfinite huncached position + _ = encodingRetryContribution cache secretKey position + + ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if TargetSum.ValidDigest (truncateHash answer) then + (TargetSum.validDigests.card : ℝ≥0∞)⁻¹ else 0) := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_mul_right, + tsum_probOutput_of_liftM_PMF, one_mul] + _ = _ := by rw [uniformHashOutput_valid_bonus_sum_eq] + +theorem encodingSelectionContribution_cacheQuery_le_of_other_encodingPosition + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {queriedPosition position : EncodingPosition} + (huncached : cache input = none) + (hqueried : AtEncodingPosition secretKey.parameter input queriedPosition) + (hne : position ≠ queriedPosition) : + encodingSelectionContribution (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey position ≤ + encodingSelectionContribution cache hfinite secretKey position := by + have hnotAt : ¬ AtEncodingPosition secretKey.parameter input position := by + intro hposition + exact hne (atEncodingPosition_unique hposition hqueried) + by_cases hsettled : EncodingMessageSettledAt cache secretKey position + · exact le_of_eq + (encodingSelectionContribution_cacheQuery_eq_of_settled_of_not_atPosition + hfinite huncached hsettled hnotAt) + · have hstillUnsettled : ¬ EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position := by + intro hafter + exact hsettled (hafter.of_cacheQuery_of_atEncoding huncached hqueried) + exact + encodingSelectionContribution_cacheQuery_le_of_unsettled_of_stillUnsettled_of_not_atPosition + hfinite huncached hsettled hstillUnsettled hnotAt + +theorem uniform_encodingSelectionPotential_cacheQuery_atPosition_sum_le + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {position : EncodingPosition} + (huncached : cache input = none) + (hposition : AtEncodingPosition secretKey.parameter input position) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ + encodingSelectionPotential cache hfinite secretKey + + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + simp only [encodingSelectionPotential] + calc + _ = ∑ candidate : EncodingPosition, + ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionContribution (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey candidate := by + simp_rw [Finset.mul_sum] + exact Summable.tsum_finsetSum fun _ _ => ENNReal.summable + _ ≤ ∑ candidate : EncodingPosition, + (encodingSelectionContribution cache hfinite secretKey candidate + + if candidate = position then + (Fintype.card Digest : ℝ≥0∞)⁻¹ else 0) := by + apply Finset.sum_le_sum + intro candidate _ + by_cases heq : candidate = position + · rw [if_pos heq] + simpa only [heq] using + uniform_encodingSelectionContribution_cacheQuery_atPosition_sum_le + hfinite huncached hposition + · rw [if_neg heq, add_zero] + calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionContribution cache hfinite secretKey candidate := by + apply ENNReal.tsum_le_tsum + intro answer + exact mul_le_mul_right + (encodingSelectionContribution_cacheQuery_le_of_other_encodingPosition + hfinite huncached hposition heq) _ + _ = _ := by + rw [ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul] + _ = (∑ candidate : EncodingPosition, + encodingSelectionContribution cache hfinite secretKey candidate) + + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + rw [Finset.sum_add_distrib, Fintype.sum_ite_eq'] + +theorem encodingStructuralPotential_cacheQuery_le_of_atEncoding + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} {position : EncodingPosition} + (hclean : ¬ Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache) + (huncached : cache input = none) + (hposition : AtEncodingPosition secretKey.parameter input position) : + encodingStructuralPotential (cache.cacheQuery input answer) secretKey ≤ + encodingStructuralPotential cache secretKey + 2 := by + have hstructural := + (clean_and_potential_cacheQuery_of_not_atPosition secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret (answer := answer) hclean huncached + (fun structuralPosition hat => + hposition.not_atPosition structuralPosition hat)).2 + have hencoding := encodingStagePotential_cacheQuery_le + (secretKey := secretKey) (answer := answer) huncached + rw [encodingStructuralPotential, encodingStructuralPotential] + omega + +theorem encodingStructuralPotential_cacheQuery_le_of_not_atEncoding + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + (hclean : ¬ Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache) + (huncached : cache input = none) + (hnotEncoding : ∀ position : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input position) : + encodingStructuralPotential (cache.cacheQuery input answer) secretKey ≤ + encodingStructuralPotential cache secretKey + 43 := by + have hencoding := encodingStagePotential_cacheQuery_le_of_not_atEncoding + (answer := answer) huncached hnotEncoding + by_cases hat : ∃ position : Position, AtPosition secretKey.parameter input position + · obtain ⟨position, hposition⟩ := hat + have hstructural : potential secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (cache.cacheQuery input answer) ≤ + potential secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + 43 := by + by_cases hsettled : Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache position + · exact (potential_cacheQuery_le_of_settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret huncached hposition hsettled).trans (Nat.le_add_right _ 43) + · by_cases hsettledAfter : Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (cache.cacheQuery input answer) position + · have hdrop := potential_add_settlingTargets_card_le secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret hfinite huncached hposition + hsettled hsettledAfter + omega + · have hgrowth := potential_cacheQuery_le_of_unsettled secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret huncached hposition hsettledAfter + norm_num [numChains] at hgrowth ⊢ + omega + rw [encodingStructuralPotential, encodingStructuralPotential] + omega + · have hstructural := + (clean_and_potential_cacheQuery_of_not_atPosition secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret (answer := answer) hclean huncached + (fun position hposition => hat ⟨position, hposition⟩)).2 + rw [encodingStructuralPotential, encodingStructuralPotential] + omega + +theorem encodingSelectionContribution_eq_one_of_collision + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {position : EncodingPosition} + {signedPayload otherPayload : HashInput} + {signedAnswer otherAnswer : HashOutput} + (htarget : CachedSignedEncodingPayloadAt cache secretKey position.lay + position.tree position.leafIdx signedPayload) + (hpayloadNe : signedPayload ≠ otherPayload) + (hsignedAnswer : cache (tweakableHashInput secretKey.parameter + position.domain signedPayload) = some signedAnswer) + (hotherAnswer : cache (tweakableHashInput secretKey.parameter + position.domain otherPayload) = some otherAnswer) + (hcollision : truncateHash signedAnswer = truncateHash otherAnswer) : + encodingSelectionContribution cache hfinite secretKey position = 1 := by + have htargetData := htarget + obtain ⟨index, selected, htree, hleaf, hsettled, hrun, hselected, + hpayload, _⟩ := htargetData + let message := honestValue (fromCache cache) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret (layerMessagePosition index position.lay) + have hmessageSettled : EncodingMessageSettledAt cache secretKey position := + ⟨index, htree, hleaf, hsettled⟩ + have hmessage : encodingSettledMessage cache secretKey position = message := + encodingSettledMessage_eq_of_witness htree hleaf hsettled + rw [encodingSelectionContribution_eq_conditional hfinite hmessageSettled, hmessage] + rw [htree, hleaf] at hselected hrun + apply encodingConditionalRiskAtMessage_eq_one_of_encodingSearch_hit + (parameter := secretKey.parameter) (cache := cache) (position := position) + (message := message) (selected := selected) hfinite hselected hrun + have hofNat : BitVec.ofNat counterBits selected.toNat = selected := by + rw [BitVec.ofNat_toNat, BitVec.setWidth_eq] + let signedInput := tweakableHashInput secretKey.parameter position.domain signedPayload + let otherInput := tweakableHashInput secretKey.parameter position.domain otherPayload + change signedPayload = digestBytes message ++ counterBytes selected at hpayload + have hselectedInput : encodingRetryInput secretKey.parameter position message selected.toNat = + signedInput := by + rw [encodingRetryInput, hofNat, ← hpayload] + have hsignedFromCache : fromCache cache signedInput = signedAnswer := by + simp [signedInput, fromCache, hsignedAnswer] + have hotherFromCache : fromCache cache otherInput = otherAnswer := by + simp [otherInput, fromCache, hotherAnswer] + have hvalid : TargetSum.ValidDigest (truncateHash signedAnswer) := by + have hvalid := htarget.target_valid + change TargetSum.ValidDigest (truncateHash (fromCache cache signedInput)) at hvalid + rwa [hsignedFromCache] at hvalid + refine ⟨(otherInput, truncateHash otherAnswer), ?_, ?_, ?_⟩ + · rw [mem_encodingSelectionCandidates_iff hfinite] + exact ⟨by simp [hotherAnswer, otherInput], ⟨otherPayload, rfl⟩, + hvalid.of_eq (hcollision.trans (congrArg truncateHash hotherFromCache).symm), + by rw [hotherFromCache]⟩ + · rw [hselectedInput] + intro hinput + apply hpayloadNe + exact (tweakableHashInput_injective secretKey.parameter (by trivial) (by trivial) + hinput.symm).2 + · rw [hselectedInput, hsignedFromCache] + exact hcollision.symm + +theorem one_le_encodingSelectionPotential_of_encodingBad + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} (hbad : EncodingBad cache secretKey) : + 1 ≤ encodingSelectionPotential cache hfinite secretKey := by + obtain ⟨lay, tree, leafIdx, signedPayload, otherPayload, signedAnswer, + otherAnswer, htarget, hpayloadNe, hsignedAnswer, hotherAnswer, hcollision⟩ := hbad + let position : EncodingPosition := ⟨lay, tree, leafIdx⟩ + have hone : encodingSelectionContribution cache hfinite secretKey position = 1 := by + exact encodingSelectionContribution_eq_one_of_collision + (cache := cache) (secretKey := secretKey) (position := position) + (signedPayload := signedPayload) (otherPayload := otherPayload) + (signedAnswer := signedAnswer) (otherAnswer := otherAnswer) + hfinite (by simpa only [position] using htarget) hpayloadNe + (by simpa only [position, EncodingPosition.domain] using hsignedAnswer) + (by simpa only [position, EncodingPosition.domain] using hotherAnswer) hcollision + rw [encodingSelectionPotential, Fintype.sum_eq_add_sum_subtype_ne _ position, + hone] + exact le_add_right le_rfl + +theorem encodingSelectionTotalPotential_eq_one_of_clean_of_encodingBad + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} + (hclean : ¬ Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache) + (hbad : EncodingBad cache secretKey) : + encodingSelectionTotalPotential cache hfinite secretKey = 1 := by + rw [encodingSelectionTotalPotential, if_neg hclean, min_eq_left] + exact (one_le_encodingSelectionPotential_of_encodingBad hfinite hbad).trans + (le_add_left le_rfl) + +theorem encodingSelectionTotalPotential_le_one + {cache : QueryCache HashSpec} (hfinite : Finite cache) + (secretKey : SecretKey) : + encodingSelectionTotalPotential cache hfinite secretKey ≤ 1 := by + rw [encodingSelectionTotalPotential] + split + · exact bot_le + · exact min_le_left _ _ + +theorem encodingSelectionTotalPotential_le_uncapped + {cache : QueryCache HashSpec} (hfinite : Finite cache) + (secretKey : SecretKey) : + encodingSelectionTotalPotential cache hfinite secretKey ≤ + (encodingStructuralPotential cache secretKey : ℝ≥0∞) * + (Fintype.card Digest : ℝ≥0∞)⁻¹ + + encodingSelectionPotential cache hfinite secretKey := by + rw [encodingSelectionTotalPotential] + split + · exact bot_le + · exact min_le_right _ _ + +theorem encodingSelectionTotalPotential_cacheQuery_le_of_bad + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + (huncached : cache input = none) + (hbad : Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache) : + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey ≤ + encodingSelectionTotalPotential cache hfinite secretKey := by + have hbadAfter := Bad.mono secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (le_cacheQuery (cache := cache) (input := input) (answer := answer) huncached) hbad + have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = 0 := by + rw [encodingSelectionTotalPotential, if_pos hbad] + have hafter : encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey = 0 := by + rw [encodingSelectionTotalPotential, if_pos hbadAfter] + rw [hbefore, hafter] + +theorem encodingSelectionTotalPotential_cacheQuery_le_of_one_le_uncapped + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + (hclean : ¬ Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache) + (hone : 1 ≤ (encodingStructuralPotential cache secretKey : ℝ≥0∞) * + (Fintype.card Digest : ℝ≥0∞)⁻¹ + + encodingSelectionPotential cache hfinite secretKey) : + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey ≤ + encodingSelectionTotalPotential cache hfinite secretKey := by + have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = 1 := by + rw [encodingSelectionTotalPotential, if_neg hclean, min_eq_left hone] + rw [hbefore] + exact encodingSelectionTotalPotential_le_one _ secretKey + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_atPosition_sum_le + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {position : EncodingPosition} + (huncached : cache input = none) + (hposition : AtEncodingPosition secretKey.parameter input position) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ + encodingSelectionTotalPotential cache hfinite secretKey + + 3 * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + let eps := (Fintype.card Digest : ℝ≥0∞)⁻¹ + by_cases hbad : Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + · have hzero (answer : HashOutput) : + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey = 0 := by + have hle := encodingSelectionTotalPotential_cacheQuery_le_of_bad hfinite + (answer := answer) huncached hbad + have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = 0 := by + rw [encodingSelectionTotalPotential, if_pos hbad] + rw [hbefore] at hle + exact bot_unique hle + simp_rw [hzero, mul_zero] + rw [tsum_zero] + exact (bot_le : (0 : ℝ≥0∞) ≤ + encodingSelectionTotalPotential cache hfinite secretKey + 3 * eps) + · let uncapped := (encodingStructuralPotential cache secretKey : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey + by_cases hone : 1 ≤ uncapped + · calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * 1 := by + apply ENNReal.tsum_le_tsum + intro answer + exact mul_le_mul_right + (encodingSelectionTotalPotential_le_one _ secretKey) _ + _ = 1 := by + simp only [mul_one, tsum_probOutput_of_liftM_PMF] + _ = encodingSelectionTotalPotential cache hfinite secretKey := by + rw [encodingSelectionTotalPotential, if_neg hbad, min_eq_left] + simpa only [uncapped] using hone + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + 3 * eps := + le_add_right le_rfl + · have huncappedLe : uncapped ≤ 1 := le_of_not_ge hone + have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = uncapped := by + rw [encodingSelectionTotalPotential, if_neg hbad, min_eq_right] + exact huncappedLe + calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (((encodingStructuralPotential cache secretKey + 2 : Nat) : ℝ≥0∞) * eps + + encodingSelectionPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) := by + apply ENNReal.tsum_le_tsum + intro answer + apply mul_le_mul_right + refine (encodingSelectionTotalPotential_le_uncapped _ secretKey).trans ?_ + have hstructuralNat := + encodingStructuralPotential_cacheQuery_le_of_atEncoding + (answer := answer) hbad huncached hposition + have hstructural : + (encodingStructuralPotential (cache.cacheQuery input answer) + secretKey : ℝ≥0∞) ≤ + ((encodingStructuralPotential cache secretKey + 2 : Nat) : ℝ≥0∞) := + Nat.cast_le.mpr hstructuralNat + exact add_le_add (mul_le_mul_left hstructural eps) le_rfl + _ = (((encodingStructuralPotential cache secretKey + 2 : Nat) : ℝ≥0∞) * eps) + + ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_mul_right, + tsum_probOutput_of_liftM_PMF, one_mul] + _ ≤ (((encodingStructuralPotential cache secretKey + 2 : Nat) : ℝ≥0∞) * eps) + + (encodingSelectionPotential cache hfinite secretKey + eps) := by + exact add_le_add le_rfl + (uniform_encodingSelectionPotential_cacheQuery_atPosition_sum_le + (cache := cache) (secretKey := secretKey) (input := input) + (position := position) hfinite huncached hposition) + _ = uncapped + 3 * eps := by + simp only [Nat.cast_add, Nat.cast_ofNat] + dsimp only [uncapped] + ring + _ = encodingSelectionTotalPotential cache hfinite secretKey + 3 * eps := by + rw [hbefore] + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_le_of_no_new_messages + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} + (huncached : cache input = none) + (hnotEncoding : ∀ position : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input position) + (hnoNew : ∀ (answer : HashOutput) (position : EncodingPosition), + EncodingMessageSettledAt (cache.cacheQuery input answer) secretKey position → + EncodingMessageSettledAt cache secretKey position) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ + encodingSelectionTotalPotential cache hfinite secretKey + + 43 * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + let eps := (Fintype.card Digest : ℝ≥0∞)⁻¹ + by_cases hbad : Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + · have hzero (answer : HashOutput) : + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey = 0 := by + have hle := encodingSelectionTotalPotential_cacheQuery_le_of_bad hfinite + (answer := answer) huncached hbad + have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = 0 := by + rw [encodingSelectionTotalPotential, if_pos hbad] + rw [hbefore] at hle + exact bot_unique hle + simp_rw [hzero, mul_zero] + rw [tsum_zero] + exact (bot_le : (0 : ℝ≥0∞) ≤ + encodingSelectionTotalPotential cache hfinite secretKey + 43 * eps) + · let uncapped := (encodingStructuralPotential cache secretKey : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey + by_cases hone : 1 ≤ uncapped + · calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * 1 := by + apply ENNReal.tsum_le_tsum + intro answer + exact mul_le_mul_right + (encodingSelectionTotalPotential_le_one _ secretKey) _ + _ = 1 := by simp only [mul_one, tsum_probOutput_of_liftM_PMF] + _ = encodingSelectionTotalPotential cache hfinite secretKey := by + rw [encodingSelectionTotalPotential, if_neg hbad, min_eq_left] + simpa only [uncapped] using hone + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + 43 * eps := + le_add_right le_rfl + · have huncappedLe : uncapped ≤ 1 := le_of_not_ge hone + have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = uncapped := by + rw [encodingSelectionTotalPotential, if_neg hbad, min_eq_right] + exact huncappedLe + calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (((encodingStructuralPotential cache secretKey + 43 : Nat) : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey) := by + apply ENNReal.tsum_le_tsum + intro answer + apply mul_le_mul_right + refine (encodingSelectionTotalPotential_le_uncapped _ secretKey).trans ?_ + have hstructuralNat := + encodingStructuralPotential_cacheQuery_le_of_not_atEncoding hfinite + (answer := answer) hbad huncached hnotEncoding + have hstructural : + (encodingStructuralPotential (cache.cacheQuery input answer) + secretKey : ℝ≥0∞) ≤ + ((encodingStructuralPotential cache secretKey + 43 : Nat) : ℝ≥0∞) := + Nat.cast_le.mpr hstructuralNat + have hselection := encodingSelectionPotential_cacheQuery_le_of_no_new_messages + (answer := answer) hfinite huncached hnotEncoding (hnoNew answer) + exact add_le_add (mul_le_mul_left hstructural eps) hselection + _ = (((encodingStructuralPotential cache secretKey + 43 : Nat) : ℝ≥0∞) * eps) + + encodingSelectionPotential cache hfinite secretKey := by + rw [ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul] + _ = uncapped + 43 * eps := by + simp only [Nat.cast_add, Nat.cast_ofNat] + dsimp only [uncapped] + ring + _ = encodingSelectionTotalPotential cache hfinite secretKey + 43 * eps := by + rw [hbefore] + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settles + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {queriedPosition : Position} + (hclean : ¬ Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache) + (huncached : cache input = none) + (hqueried : AtPosition secretKey.parameter input queriedPosition) + (messageTargets : Finset Digest) + (hdirectTargets : ∀ (position : EncodingPosition) (index : Index), + treeIndexAt index position.lay = position.tree → + leafIndexAt index position.lay = position.leafIdx → + layerMessagePosition index position.lay = queriedPosition → + encodingMessageTargets secretKey.parameter cache hfinite position ⊆ messageTargets) + (hdrop : ∀ answer : HashOutput, + encodingStructuralPotential (cache.cacheQuery input answer) secretKey + + (messageTargets ∪ + settlingTargets secretKey.parameter cache hfinite queriedPosition).card ≤ + encodingStructuralPotential cache secretKey) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ + encodingSelectionTotalPotential cache hfinite secretKey := by + let eps := (Fintype.card Digest : ℝ≥0∞)⁻¹ + let targets := messageTargets ∪ + settlingTargets secretKey.parameter cache hfinite queriedPosition + let credit := encodingStructuralPotential cache secretKey - targets.card + have hcard : targets.card ≤ encodingStructuralPotential cache secretKey := by + have hpaid := hdrop 0 + simp only [targets] + omega + have hcredit : credit + targets.card = encodingStructuralPotential cache secretKey := by + exact Nat.sub_add_cancel hcard + let uncapped := (encodingStructuralPotential cache secretKey : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey + by_cases hone : 1 ≤ uncapped + · calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * 1 := by + apply ENNReal.tsum_le_tsum + intro answer + exact mul_le_mul_right + (encodingSelectionTotalPotential_le_one _ secretKey) _ + _ = 1 := by simp only [mul_one, tsum_probOutput_of_liftM_PMF] + _ = encodingSelectionTotalPotential cache hfinite secretKey := by + rw [encodingSelectionTotalPotential, if_neg hclean, min_eq_left] + simpa only [uncapped] using hone + · have huncappedLe : uncapped ≤ 1 := le_of_not_ge hone + have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = uncapped := by + rw [encodingSelectionTotalPotential, if_neg hclean, min_eq_right] + exact huncappedLe + have hstructural (answer : HashOutput) : + encodingStructuralPotential (cache.cacheQuery input answer) secretKey ≤ credit := by + have hpaid := hdrop answer + change encodingStructuralPotential (cache.cacheQuery input answer) secretKey ≤ + encodingStructuralPotential cache secretKey - + (messageTargets ∪ + settlingTargets secretKey.parameter cache hfinite queriedPosition).card + omega + have hpointwise (answer : HashOutput) : + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey ≤ + (credit : ℝ≥0∞) * eps + encodingSelectionPotential cache hfinite secretKey + + if truncateHash answer ∈ targets then 1 else 0 := by + by_cases hmem : truncateHash answer ∈ targets + · rw [if_pos hmem] + exact (encodingSelectionTotalPotential_le_one _ secretKey).trans + (le_add_left le_rfl) + · rw [if_neg hmem, add_zero] + refine (encodingSelectionTotalPotential_le_uncapped _ secretKey).trans ?_ + have hstructuralCast : + (encodingStructuralPotential (cache.cacheQuery input answer) + secretKey : ℝ≥0∞) ≤ (credit : ℝ≥0∞) := + Nat.cast_le.mpr (hstructural answer) + have hselection := + encodingSelectionPotential_cacheQuery_le_of_avoids_settlementTargets + (answer := answer) hfinite huncached hqueried + (fun position index htree hleaf hmessage hmemMessage => by + apply hmem + change truncateHash answer ∈ messageTargets ∪ + settlingTargets secretKey.parameter cache hfinite queriedPosition + rw [Finset.mem_union] + apply Or.inl + apply hdirectTargets position index htree hleaf + (atPosition_unique secretKey.parameter hmessage hqueried) + exact hmemMessage) + (fun hmemSettling => by + apply hmem + change truncateHash answer ∈ messageTargets ∪ + settlingTargets secretKey.parameter cache hfinite queriedPosition + rw [Finset.mem_union] + exact Or.inr hmemSettling) + exact add_le_add (mul_le_mul_left hstructuralCast eps) hselection + calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + ((credit : ℝ≥0∞) * eps + encodingSelectionPotential cache hfinite secretKey + + if truncateHash answer ∈ targets then 1 else 0) := by + apply ENNReal.tsum_le_tsum + intro answer + exact mul_le_mul_right (hpointwise answer) _ + _ = ((credit : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey) + + ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if truncateHash answer ∈ targets then 1 else 0) := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_add, + ENNReal.tsum_mul_right, ENNReal.tsum_mul_right, + tsum_probOutput_of_liftM_PMF, one_mul] + ring + _ = ((credit : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey) + + (targets.card : ℝ≥0∞) * eps := by + rw [uniformHashOutput_mem_bonus_sum_eq] + _ = uncapped := by + dsimp only [uncapped] + calc + (credit : ℝ≥0∞) * eps + encodingSelectionPotential cache hfinite secretKey + + (targets.card : ℝ≥0∞) * eps = + ((credit : ℝ≥0∞) + (targets.card : ℝ≥0∞)) * eps + + encodingSelectionPotential cache hfinite secretKey := by ring + _ = _ := by rw [← Nat.cast_add, hcredit] + _ = encodingSelectionTotalPotential cache hfinite secretKey := hbefore.symm + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settlingPosition + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {queriedPosition : Position} + (hclean : ¬ Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache) + (huncached : cache input = none) + (hqueried : AtPosition secretKey.parameter input queriedPosition) + (hunsettled : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache queriedPosition) + (hsettles : ∀ answer : HashOutput, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) queriedPosition) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ + encodingSelectionTotalPotential cache hfinite secretKey := by + have hnotEncoding : ∀ position : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input position := by + intro position hposition + exact hposition.not_atPosition queriedPosition hqueried + by_cases hdirect : ∃ (position : EncodingPosition) (index : Index), + treeIndexAt index position.lay = position.tree ∧ + leafIndexAt index position.lay = position.leafIdx ∧ + layerMessagePosition index position.lay = queriedPosition + · obtain ⟨directPosition, directIndex, hdirectTree, hdirectLeaf, + hdirectMessage⟩ := hdirect + let messageTargets := encodingMessageTargets secretKey.parameter cache hfinite directPosition + apply uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settles + hfinite hclean huncached hqueried messageTargets + · intro position index htree hleaf hmessage + have heq : position = directPosition := + encodingPosition_eq_of_layerMessagePosition_eq htree hleaf + hdirectTree hdirectLeaf (hmessage.trans hdirectMessage.symm) + subst position + exact Finset.Subset.rfl + · intro answer + have hstructural := potential_add_settlingTargets_card_le + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret hfinite + huncached hqueried hunsettled (hsettles answer) + have hmessageUnsettled : ¬ EncodingMessageSettledAt cache secretKey directPosition := by + rintro ⟨index, htree, hleaf, hsettled⟩ + have hpositionEq := layerMessagePosition_eq_of_position_eq directIndex index + directPosition.lay (hdirectTree.trans htree.symm) + (hdirectLeaf.trans hleaf.symm) + apply hunsettled + rwa [← hdirectMessage, hpositionEq] + have hmessageSettled : EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey directPosition := + ⟨directIndex, hdirectTree, hdirectLeaf, by + rw [hdirectMessage] + exact hsettles answer⟩ + have hstage := encodingStagePotential_add_messageTargets_card_le_of_new_message + hfinite huncached hnotEncoding hmessageUnsettled hmessageSettled + have hunion : (messageTargets ∪ + settlingTargets secretKey.parameter cache hfinite queriedPosition).card ≤ + messageTargets.card + + (settlingTargets secretKey.parameter cache hfinite queriedPosition).card := + Finset.card_union_le _ _ + rw [encodingStructuralPotential, encodingStructuralPotential] + dsimp only [messageTargets] at hstage hunion ⊢ + omega + · apply uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settles + hfinite hclean huncached hqueried ∅ + · intro position index htree hleaf hmessage + exact (hdirect ⟨position, index, htree, hleaf, hmessage⟩).elim + · intro answer + have hstructural := potential_add_settlingTargets_card_le + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret hfinite + huncached hqueried hunsettled (hsettles answer) + have hstage := encodingStagePotential_cacheQuery_le_of_not_atEncoding + (answer := answer) huncached hnotEncoding + rw [encodingStructuralPotential, encodingStructuralPotential] + simp only [Finset.empty_union] + omega + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_sum_le + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} + (huncached : cache input = none) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ + encodingSelectionTotalPotential cache hfinite secretKey + + 44 * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + let eps := (Fintype.card Digest : ℝ≥0∞)⁻¹ + by_cases hencoding : ∃ position : EncodingPosition, + AtEncodingPosition secretKey.parameter input position + · obtain ⟨position, hposition⟩ := hencoding + calc + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + 3 * eps := + uniform_encodingSelectionTotalPotential_cacheQuery_atPosition_sum_le + hfinite huncached hposition + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + 44 * eps := by + gcongr + norm_num + · have hnotEncoding : ∀ position : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input position := + fun position hposition => hencoding ⟨position, hposition⟩ + by_cases hstructural : ∃ position : Position, + AtPosition secretKey.parameter input position + · obtain ⟨position, hposition⟩ := hstructural + by_cases hsettled : Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache position + · have hbound := + uniform_encodingSelectionTotalPotential_cacheQuery_le_of_no_new_messages + hfinite huncached hnotEncoding + (fun answer candidate hafter => + hafter.of_cacheQuery_of_at_settled huncached hposition hsettled) + calc + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + 43 * eps := hbound + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + 44 * eps := by + gcongr + norm_num + · by_cases hnever : ∀ answer : HashOutput, + ¬ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) position + · have hbound := + uniform_encodingSelectionTotalPotential_cacheQuery_le_of_no_new_messages + hfinite huncached hnotEncoding + (fun answer candidate hafter => + hafter.of_cacheQuery_of_at_unsettledAfter huncached hposition + (hnever answer)) + calc + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + 43 * eps := hbound + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + 44 * eps := by + gcongr + norm_num + · push Not at hnever + obtain ⟨settlingAnswer, hsettling⟩ := hnever + obtain ⟨hinput, hchildren⟩ := + eq_cachedInput_and_children_of_settled_cacheQuery secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret huncached hposition hsettled hsettling + have hsettles : ∀ answer : HashOutput, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) position := by + intro answer + have hle := le_cacheQuery (cache := cache) (input := input) + (answer := answer) huncached + have hchildrenAfter : ∀ child ∈ position.children, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) child := + fun child hchild => (hchildren child hchild).mono hle + have hvalues : ∀ child ∈ position.children, + honestValue (fromCache (cache.cacheQuery input answer)) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret child = + honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret child := + fun child hchild => honestValue_eq_of_settled + (agreesWithFn_fromCache_of_le hle) (hchildren child hchild) + have hpinned : cachedInput secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (cache.cacheQuery input answer) position = + cachedInput secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + cache position := + honestInput_congr _ _ secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret hsettling.valid hvalues + rw [settled_iff] + refine ⟨hsettling.valid, ?_, hchildrenAfter⟩ + rw [hpinned, ← hinput, QueryCache.cacheQuery_self] + simp + by_cases hbad : Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache + · have hzero (answer : HashOutput) : + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey = 0 := by + have hle := encodingSelectionTotalPotential_cacheQuery_le_of_bad hfinite + (answer := answer) huncached hbad + have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = 0 := by + rw [encodingSelectionTotalPotential, if_pos hbad] + rw [hbefore] at hle + exact bot_unique hle + simp_rw [hzero, mul_zero] + rw [tsum_zero] + exact bot_le + · exact (uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settlingPosition + hfinite hbad huncached hposition hsettled hsettles).trans + (le_add_right le_rfl) + · have hbound := + uniform_encodingSelectionTotalPotential_cacheQuery_le_of_no_new_messages + hfinite huncached hnotEncoding + (fun answer candidate hafter => + hafter.of_cacheQuery_of_not_atPosition huncached + (fun position hposition => hstructural ⟨position, hposition⟩)) + calc + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + 43 * eps := hbound + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + 44 * eps := by + gcongr + norm_num + +@[simp] theorem encodingSelectionContribution_empty + (secretKey : SecretKey) (position : EncodingPosition) : + encodingSelectionContribution ∅ finite_empty secretKey position = 0 := by + rw [encodingSelectionContribution, if_neg] + · exact encodingRetryContribution_empty secretKey position + · rintro ⟨index, _, _, hsettled⟩ + exact hsettled.cached (by simp) + +@[simp] theorem encodingSelectionPotential_empty (secretKey : SecretKey) : + encodingSelectionPotential ∅ finite_empty secretKey = 0 := by + rw [encodingSelectionPotential] + apply Fintype.sum_eq_zero + exact encodingSelectionContribution_empty secretKey + +@[simp] theorem encodingSelectionTotalPotential_empty (secretKey : SecretKey) : + encodingSelectionTotalPotential ∅ finite_empty secretKey = 0 := by + rw [encodingSelectionTotalPotential, + if_neg (not_bad_empty secretKey.parameter secretKey.otsSecret secretKey.ftsSecret), + encodingStructuralPotential_empty, encodingSelectionPotential_empty] + simp + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingSelectionSampling.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingSelectionSampling.lean new file mode 100644 index 00000000..ac6b3823 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingSelectionSampling.lean @@ -0,0 +1,48 @@ +import SphincsSecurity.Proof.EncodingTerminalView +import SphincsSecurity.Proof.TerminalSampling + +/-! +# Encoding selection risk across secret sampling + +The fixed-secret adaptive bound is uniform in the sampled parameter and secret tables, so averaging +it at the actual sampling boundary preserves the same bound. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem probEvent_sampled_cleanEncoding_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) : + Pr[SampledViewedEvent cleanEncodingEvent | sampledViewedGame adversary] ≤ + ((44 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [probEvent_sampledViewedGame_eq_weighted] + calc + _ ≤ ∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets] * + (((44 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) := by + apply ENNReal.tsum_le_tsum + intro secrets + by_cases hsecrets : secrets ∈ support sampleSecrets + · obtain ⟨hparameter, hots, hfts⟩ := secrets.support_components hsecrets + apply mul_le_mul' le_rfl + have hgame := isQueryBoundP_gameAfterSecrets adversary q hq hparameter hots hfts + change Pr[fun result => + ¬Bad secrets.parameter secrets.otsSecret secrets.ftsSecret result.2.cache ∧ + ViewedEncodingCollisionWitness secrets.parameter secrets.otsSecret + secrets.ftsSecret result | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret] ≤ _ + calc + _ ≤ (44 * (q : ℝ≥0∞)) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + simpa only [Digest, card_bitVec] using + probEvent_clean_viewedEncodingCollision_le adversary secrets.parameter + secrets.otsSecret secrets.ftsSecret q hgame + _ = ((44 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + push_cast + rfl + · rw [probOutput_eq_zero_of_not_mem_support hsecrets, zero_mul, zero_mul] + _ ≤ ((44 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [ENNReal.tsum_mul_right] + exact mul_le_of_le_one_left zero_le tsum_probOutput_le_one + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingSignerLatent.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingSignerLatent.lean new file mode 100644 index 00000000..d536ac88 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingSignerLatent.lean @@ -0,0 +1,244 @@ +import SphincsSecurity.Proof.EncodingStageCharge +import SphincsSecurity.Proof.FirstBad + +/-! +# Latent encoding collisions inside a signer + +A provisional latent collision created inside one signer invocation cannot remain provisional at +the invocation boundary. Its fresh admissible input is exactly one of that signer's encoding +queries, so the complete retry search pins the canonical target before the signer returns. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +theorem hasEncodingTarget_of_latent_creation_during_sign + {secretKey : SecretKey} {message : Message} + {initialCache cache finalCache : QueryCache HashSpec} + {result : Option Signature} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} + (hrun : (result, finalCache) ∈ support + ((simulateQ romImpl (sign secretKey message)).run initialCache)) + (hinitial : initialCache ≤ cache) + (hfinal : cache.cacheQuery input answer ≤ finalCache) + (hclean : ¬ LatentEncodingBad cache secretKey) + (huncached : cache input = none) + (hposition : AtEncodingPosition secretKey.parameter input position) + (hbad : LatentEncodingBad (cache.cacheQuery input answer) secretKey) : + HasEncodingTarget finalCache secretKey position := by + obtain ⟨payload, hpayload⟩ := hposition + have hinitialMiss : initialCache + (tweakableHashInput secretKey.parameter position.domain payload) = none := by + rw [← hpayload] + by_contra hcached + obtain ⟨cachedAnswer, hcachedAnswer⟩ := Option.ne_none_iff_exists'.mp hcached + have := hinitial hcachedAnswer + rw [huncached] at this + simp at this + have hfinalCached : finalCache + (tweakableHashInput secretKey.parameter position.domain payload) = some answer := by + rw [← hpayload] + exact hfinal (by simp) + have hvalid : TargetSum.ValidDigest (truncateHash answer) := by + by_contra hinvalid + exact hclean (hbad.of_cacheQuery_of_invalid_encoding huncached + ⟨payload, hpayload⟩ hinvalid) + apply hasEncodingTarget_of_sign_transition secretKey message initialCache finalCache result + hrun position payload hinitialMiss + · simp [hfinalCached] + · simpa [fromCache, hfinalCached] using hvalid + +inductive LatentEncodingSignerStepOutcome + (cache : QueryCache HashSpec) (secretKey : SecretKey) + (input : HashInput) (answer : HashOutput) (finalCache : QueryCache HashSpec) : Prop where + | existingTarget (position : EncodingPosition) + (atPosition : AtEncodingPosition secretKey.parameter input position) + (target : HasEncodingTarget cache secretKey position) + | pinnedAtEnd (position : EncodingPosition) + (atPosition : AtEncodingPosition secretKey.parameter input position) + (target : HasEncodingTarget finalCache secretKey position) + | paid (targets : Finset Digest) + (hit : truncateHash answer ∈ targets) + (drop : encodingStructuralPotential (cache.cacheQuery input answer) secretKey + + targets.card ≤ encodingStructuralPotential cache secretKey) + +theorem latentEncodingBad_step_paid_or_pinned_by_sign + {secretKey : SecretKey} {message : Message} + {initialCache cache finalCache : QueryCache HashSpec} + {result : Option Signature} {input : HashInput} {answer : HashOutput} + (hfinite : Finite cache) + (hrun : (result, finalCache) ∈ support + ((simulateQ romImpl (sign secretKey message)).run initialCache)) + (hinitial : initialCache ≤ cache) + (hfinal : cache.cacheQuery input answer ≤ finalCache) + (hstructuralClean : ¬ Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache) + (hclean : ¬ LatentEncodingBad cache secretKey) + (huncached : cache input = none) + (hbad : LatentEncodingBad (cache.cacheQuery input answer) secretKey) : + LatentEncodingSignerStepOutcome cache secretKey input answer finalCache := by + rcases latentEncodingBad_step_paid_or_provisional hfinite hstructuralClean hclean + huncached hbad with ⟨position, hposition, htarget⟩ | + ⟨position, hposition, hnotTarget, hstillNotTarget, hhit⟩ | + ⟨targets, hhit, hdrop⟩ + · exact .existingTarget position hposition htarget + · exact .pinnedAtEnd position hposition + (hasEncodingTarget_of_latent_creation_during_sign hrun hinitial hfinal hclean + huncached hposition hbad) + · exact .paid targets hhit hdrop + +inductive LatentEncodingSignerIntervalOutcome + (initialCache finalCache : QueryCache HashSpec) (secretKey : SecretKey) : Prop where + | pinned (position : EncodingPosition) + (target : HasEncodingTarget finalCache secretKey position) + | paid (cache : QueryCache HashSpec) (input : HashInput) (answer : HashOutput) + (targets : Finset Digest) + (initialLe : initialCache ≤ cache) + (finalLe : cache.cacheQuery input answer ≤ finalCache) + (hit : truncateHash answer ∈ targets) + (drop : encodingStructuralPotential (cache.cacheQuery input answer) secretKey + + targets.card ≤ encodingStructuralPotential cache secretKey) + +theorem latentEncodingBad_signerInterval_paid_or_pinned + {secretKey : SecretKey} {message : Message} + {initialCache finalCache : QueryCache HashSpec} {result : Option Signature} + (hfinite : Finite finalCache) + (hrun : (result, finalCache) ∈ support + ((simulateQ romImpl (sign secretKey message)).run initialCache)) + (hstructuralClean : ¬ Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret finalCache) + (hclean : ¬ LatentEncodingBad initialCache secretKey) + (hbad : LatentEncodingBad finalCache secretKey) : + LatentEncodingSignerIntervalOutcome initialCache finalCache secretKey := by + obtain ⟨cache, input, answer, hinitial, hstepClean, huncached, hstepBad, + hfinal⟩ := freshBadStep_of_mem_support (LatentEncodingBad · secretKey) + (sign secretKey message) initialCache result finalCache hrun hclean hbad + have hfiniteCache : Finite cache := hfinite.of_le + ((le_cacheQuery huncached).trans hfinal) + have hstepStructuralClean : ¬ Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache := by + intro hbadCache + exact hstructuralClean (Bad.mono secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret ((le_cacheQuery huncached).trans hfinal) hbadCache) + rcases latentEncodingBad_step_paid_or_pinned_by_sign hfiniteCache hrun hinitial + hfinal hstepStructuralClean hstepClean huncached hstepBad with + ⟨position, hposition, htarget⟩ | ⟨position, hposition, htarget⟩ | + ⟨targets, hhit, hdrop⟩ + · exact .pinned position (htarget.mono ((le_cacheQuery huncached).trans hfinal)) + · exact .pinned position htarget + · exact .paid cache input answer targets hinitial hfinal hhit hdrop + +theorem hasEncodingTarget_of_latentAt_creation_during_sign + {secretKey : SecretKey} {message : Message} + {initialCache cache finalCache : QueryCache HashSpec} + {result : Option Signature} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} + (hfinite : Finite cache) + (hrun : (result, finalCache) ∈ support + ((simulateQ romImpl (sign secretKey message)).run initialCache)) + (hinitial : initialCache ≤ cache) + (hfinal : cache.cacheQuery input answer ≤ finalCache) + (hclean : ¬ LatentEncodingBadAt cache secretKey position) + (huncached : cache input = none) + (hposition : AtEncodingPosition secretKey.parameter input position) + (hbad : LatentEncodingBadAt + (cache.cacheQuery input answer) secretKey position) : + HasEncodingTarget finalCache secretKey position := by + obtain ⟨payload, hpayload⟩ := hposition + have hinitialMiss : initialCache + (tweakableHashInput secretKey.parameter position.domain payload) = none := by + rw [← hpayload] + by_contra hcached + obtain ⟨cachedAnswer, hcachedAnswer⟩ := Option.ne_none_iff_exists'.mp hcached + have := hinitial hcachedAnswer + rw [huncached] at this + simp at this + have hfinalCached : finalCache + (tweakableHashInput secretKey.parameter position.domain payload) = some answer := by + rw [← hpayload] + exact hfinal (by simp) + have hvalid : TargetSum.ValidDigest (truncateHash answer) := + (Finset.mem_filter.mp (latentEncodingBadAt_answer_hit_of_encoding_query + hfinite hclean huncached ⟨payload, hpayload⟩ hbad)).2 + apply hasEncodingTarget_of_sign_transition secretKey message initialCache finalCache result + hrun position payload hinitialMiss + · simp [hfinalCached] + · simpa [fromCache, hfinalCached] using hvalid + +inductive LatentEncodingAtSignerIntervalOutcome + (initialCache finalCache : QueryCache HashSpec) (secretKey : SecretKey) + (position : EncodingPosition) : Prop where + | existingTarget (cache : QueryCache HashSpec) (input : HashInput) + (answer : HashOutput) (finiteCache : Finite cache) + (initialLe : initialCache ≤ cache) + (finalLe : cache.cacheQuery input answer ≤ finalCache) + (stepClean : ¬ LatentEncodingBadAt cache secretKey position) + (uncached : cache input = none) + (stepBad : LatentEncodingBadAt + (cache.cacheQuery input answer) secretKey position) + (atPosition : AtEncodingPosition secretKey.parameter input position) + (hit : truncateHash answer ∈ + encodingValidAnswerTargets secretKey.parameter cache finiteCache position) + (target : HasEncodingTarget cache secretKey position) + | provisionalPinned (cache : QueryCache HashSpec) (input : HashInput) + (answer : HashOutput) (finiteCache : Finite cache) + (initialLe : initialCache ≤ cache) + (finalLe : cache.cacheQuery input answer ≤ finalCache) + (stepClean : ¬ LatentEncodingBadAt cache secretKey position) + (uncached : cache input = none) + (stepBad : LatentEncodingBadAt + (cache.cacheQuery input answer) secretKey position) + (atPosition : AtEncodingPosition secretKey.parameter input position) + (notTarget : ¬ HasEncodingTarget cache secretKey position) + (stillNotTarget : ¬ HasEncodingTarget + (cache.cacheQuery input answer) secretKey position) + (hit : truncateHash answer ∈ + encodingValidAnswerTargets secretKey.parameter cache finiteCache position) + (target : HasEncodingTarget finalCache secretKey position) + | paid (cache : QueryCache HashSpec) (input : HashInput) (answer : HashOutput) + (targets : Finset Digest) + (initialLe : initialCache ≤ cache) + (finalLe : cache.cacheQuery input answer ≤ finalCache) + (hit : truncateHash answer ∈ targets) + (drop : encodingStructuralPotential (cache.cacheQuery input answer) secretKey + + targets.card ≤ encodingStructuralPotential cache secretKey) + +theorem latentEncodingBadAt_signerInterval_paid_or_pinned + {secretKey : SecretKey} {message : Message} + {initialCache finalCache : QueryCache HashSpec} {result : Option Signature} + {position : EncodingPosition} + (hfinite : Finite finalCache) + (hrun : (result, finalCache) ∈ support + ((simulateQ romImpl (sign secretKey message)).run initialCache)) + (hstructuralClean : ¬ Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret finalCache) + (hclean : ¬ LatentEncodingBadAt initialCache secretKey position) + (hbad : LatentEncodingBadAt finalCache secretKey position) : + LatentEncodingAtSignerIntervalOutcome initialCache finalCache secretKey position := by + obtain ⟨cache, input, answer, hinitial, hstepClean, huncached, hstepBad, + hfinal⟩ := freshBadStep_of_mem_support + (fun cache => LatentEncodingBadAt cache secretKey position) + (sign secretKey message) initialCache result finalCache hrun hclean hbad + have hfiniteCache : Finite cache := hfinite.of_le + ((le_cacheQuery huncached).trans hfinal) + have hstepStructuralClean : ¬ Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache := by + intro hbadCache + exact hstructuralClean (Bad.mono secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret ((le_cacheQuery huncached).trans hfinal) hbadCache) + have houtcome := latentEncodingBadAt_step_paid_or_provisional hfiniteCache + hstepStructuralClean hstepClean huncached hstepBad + cases houtcome with + | existingTarget atPosition hit target => + exact .existingTarget cache input answer hfiniteCache hinitial hfinal hstepClean + huncached hstepBad atPosition hit target + | provisional atPosition notTarget stillNotTarget hit => + exact .provisionalPinned cache input answer hfiniteCache hinitial hfinal hstepClean + huncached hstepBad atPosition notTarget stillNotTarget hit + (hasEncodingTarget_of_latentAt_creation_during_sign + hfiniteCache hrun hinitial hfinal hstepClean huncached atPosition hstepBad) + | paid targets hit drop => + exact .paid cache input answer targets hinitial hfinal hit drop + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingSigningFailure.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingSigningFailure.lean new file mode 100644 index 00000000..4c539af5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingSigningFailure.lean @@ -0,0 +1,62 @@ +import SphincsSecurity.Proof.EncodingExhaustionBound +import SphincsSecurity.Proof.NoMessage + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +set_option backward.isDefEq.respectTransparency false + +theorem cachedOtsEncodingFailure_of_signLayer_none + (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (index : Index) (lay : Layer) + (hagrees : cache.AgreesWithFn f) + (hrun : CachedRun cache f (signLayer secretKey index lay)) + (hfailed : evalWithAnswerFn f (signLayer secretKey index lay) = none) : + CachedOtsEncodingFailure cache := by + rw [signLayer] at hrun + rw [signLayer, evalWithAnswerFn_bind, evalWithAnswerFn_bind] at hfailed + have hots := hrun.bind_right.bind_left + cases hvalue : evalWithAnswerFn f (otsSign secretKey.parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay))) with + | none => + exact ⟨f, secretKey.parameter, ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩, + secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay), + evalWithAnswerFn f (layerMessage secretKey index lay), hagrees, hots, hvalue⟩ + | some values => simp [hvalue] at hfailed + +theorem exists_none_of_traverseOption_none {α : Type} {n : Nat} + (family : Fin n → Option α) (hfailed : traverseOption family = none) : + ∃ index, family index = none := by + induction n with + | zero => simp [traverseOption] at hfailed + | succ n ih => + cases hhead : family 0 with + | none => exact ⟨0, hhead⟩ + | some head => + cases htail : traverseOption (fun index : Fin n => family index.succ) with + | none => + obtain ⟨index, hindex⟩ := ih (fun index : Fin n => family index.succ) htail + exact ⟨index.succ, hindex⟩ + | some tail => simp [traverseOption, hhead, htail] at hfailed + +theorem cachedOtsEncodingFailure_of_signAfterDigest_none + (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (hagrees : cache.AgreesWithFn f) + (hrun : CachedRun cache f (signAfterDigest secretKey randomness index leaves)) + (hfailed : evalWithAnswerFn f (signAfterDigest secretKey randomness index leaves) = none) : + CachedOtsEncodingFailure cache := by + rw [signAfterDigest] at hrun + have hlayers := hrun.bind_right.bind_left + rw [signAfterDigest, evalWithAnswerFn_bind, evalWithAnswerFn_bind, + evalWithAnswerFn_sequenceFin] at hfailed + cases hparts : traverseOption (fun lay => evalWithAnswerFn f (signLayer secretKey index lay)) with + | none => + obtain ⟨lay, hlay⟩ := exists_none_of_traverseOption_none _ hparts + exact cachedOtsEncodingFailure_of_signLayer_none f cache secretKey index lay hagrees + (hlayers.sequenceFin_component _ lay) hlay + | some parts => simp [hparts] at hfailed + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingStageCharge.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingStageCharge.lean new file mode 100644 index 00000000..5538add9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingStageCharge.lean @@ -0,0 +1,526 @@ +import SphincsSecurity.Proof.EncodingLatent + +/-! +# Two-stage encoding potential + +Before an encoding position's honest message is settled, each cached input pays once for the +message-selection query and once for the later fresh target answer. After the message is settled, +only the second unit remains. Installing the canonical target releases that final unit. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +set_option maxRecDepth 100000 + +noncomputable def encodingStageContribution (cache : QueryCache HashSpec) + (secretKey : SecretKey) (position : EncodingPosition) : Nat := + open Classical in + if HasEncodingTarget cache secretKey position then 0 + else if EncodingMessageSettledAt cache secretKey position then + (encodingCachedAt secretKey.parameter cache position).ncard + else 2 * (encodingCachedAt secretKey.parameter cache position).ncard + +noncomputable def encodingStagePotential (cache : QueryCache HashSpec) + (secretKey : SecretKey) : Nat := + ∑ position : EncodingPosition, encodingStageContribution cache secretKey position + +@[simp] theorem encodingStagePotential_empty (secretKey : SecretKey) : + encodingStagePotential ∅ secretKey = 0 := by + rw [encodingStagePotential] + apply Fintype.sum_eq_zero + intro position + rw [encodingStageContribution] + split + · rfl + · split + · have hempty : encodingCachedAt secretKey.parameter + (∅ : QueryCache HashSpec) position = ∅ := by + ext input + simp [encodingCachedAt] + rw [hempty, Set.ncard_empty] + · have hempty : encodingCachedAt secretKey.parameter + (∅ : QueryCache HashSpec) position = ∅ := by + ext input + simp [encodingCachedAt] + rw [hempty, Set.ncard_empty, Nat.mul_zero] + +theorem encodingStageContribution_cacheQuery_le_of_not_atPosition + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} {position : EncodingPosition} + (huncached : cache input = none) + (hnotAt : ¬ AtEncodingPosition secretKey.parameter input position) : + encodingStageContribution (cache.cacheQuery input answer) secretKey position ≤ + encodingStageContribution cache secretKey position := by + classical + have hle := le_cacheQuery (cache := cache) (input := input) (answer := answer) huncached + have hcachedAt := encodingCachedAt_cacheQuery_of_not_atPosition + (parameter := secretKey.parameter) (cache := cache) (answer := answer) hnotAt + rw [encodingStageContribution, encodingStageContribution] + by_cases htarget : HasEncodingTarget cache secretKey position + · rw [if_pos htarget, if_pos (htarget.mono hle)] + · rw [if_neg htarget] + by_cases htarget' : HasEncodingTarget (cache.cacheQuery input answer) secretKey position + · rw [if_pos htarget'] + exact Nat.zero_le _ + · rw [if_neg htarget'] + by_cases hsettled : EncodingMessageSettledAt cache secretKey position + · rw [if_pos hsettled, if_pos (hsettled.mono hle), hcachedAt] + · rw [if_neg hsettled] + by_cases hsettled' : EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position + · rw [if_pos hsettled', hcachedAt] + omega + · rw [if_neg hsettled', hcachedAt] + +theorem encodingStageContribution_cacheQuery_le_of_atPosition + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} {position : EncodingPosition} + (huncached : cache input = none) + (hposition : AtEncodingPosition secretKey.parameter input position) : + encodingStageContribution (cache.cacheQuery input answer) secretKey position ≤ + encodingStageContribution cache secretKey position + 2 := by + classical + have hle := le_cacheQuery (cache := cache) (input := input) (answer := answer) huncached + have hcard : (encodingCachedAt secretKey.parameter + (cache.cacheQuery input answer) position).ncard ≤ + (encodingCachedAt secretKey.parameter cache position).ncard + 1 := by + rw [encodingCachedAt_cacheQuery_self hposition] + exact Set.ncard_insert_le _ _ + rw [encodingStageContribution, encodingStageContribution] + by_cases htarget : HasEncodingTarget cache secretKey position + · rw [if_pos htarget, if_pos (htarget.mono hle)] + omega + · rw [if_neg htarget] + by_cases htarget' : HasEncodingTarget (cache.cacheQuery input answer) secretKey position + · rw [if_pos htarget'] + exact Nat.zero_le _ + · rw [if_neg htarget'] + by_cases hsettled : EncodingMessageSettledAt cache secretKey position + · rw [if_pos hsettled, if_pos (hsettled.mono hle)] + omega + · rw [if_neg hsettled] + by_cases hsettled' : EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position + · rw [if_pos hsettled'] + omega + · rw [if_neg hsettled'] + omega + +theorem encodingStagePotential_cacheQuery_le + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} (huncached : cache input = none) : + encodingStagePotential (cache.cacheQuery input answer) secretKey ≤ + encodingStagePotential cache secretKey + 2 := by + classical + by_cases hat : ∃ position, + AtEncodingPosition secretKey.parameter input position + · obtain ⟨queriedPosition, hqueried⟩ := hat + rw [encodingStagePotential, encodingStagePotential] + calc + ∑ position : EncodingPosition, + encodingStageContribution (cache.cacheQuery input answer) secretKey position ≤ + ∑ position : EncodingPosition, + (encodingStageContribution cache secretKey position + + if position = queriedPosition then 2 else 0) := by + apply Finset.sum_le_sum + intro position _ + by_cases heq : position = queriedPosition + · rw [if_pos heq] + simpa only [heq] using + encodingStageContribution_cacheQuery_le_of_atPosition huncached hqueried + · rw [if_neg heq, Nat.add_zero] + apply encodingStageContribution_cacheQuery_le_of_not_atPosition huncached + intro hposition + exact heq (atEncodingPosition_unique hposition hqueried) + _ = (∑ position : EncodingPosition, + encodingStageContribution cache secretKey position) + 2 := by + rw [Finset.sum_add_distrib, Fintype.sum_ite_eq'] + · rw [encodingStagePotential, encodingStagePotential] + calc + ∑ position : EncodingPosition, + encodingStageContribution (cache.cacheQuery input answer) secretKey position ≤ + ∑ position : EncodingPosition, + encodingStageContribution cache secretKey position := by + apply Finset.sum_le_sum + intro position _ + exact encodingStageContribution_cacheQuery_le_of_not_atPosition huncached + (fun hposition => hat ⟨position, hposition⟩) + _ ≤ _ := Nat.le_add_right _ 2 + +theorem encodingStagePotential_cacheQuery_le_of_not_atEncoding + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} (huncached : cache input = none) + (hnotAt : ∀ position : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input position) : + encodingStagePotential (cache.cacheQuery input answer) secretKey ≤ + encodingStagePotential cache secretKey := by + classical + rw [encodingStagePotential, encodingStagePotential] + apply Finset.sum_le_sum + intro position _ + exact encodingStageContribution_cacheQuery_le_of_not_atPosition huncached + (hnotAt position) + +theorem HasEncodingTarget.messageSettled {cache : QueryCache HashSpec} + {secretKey : SecretKey} {position : EncodingPosition} + (htarget : HasEncodingTarget cache secretKey position) : + EncodingMessageSettledAt cache secretKey position := by + obtain ⟨payload, index, counter, htree, hleaf, hsettled, hrest⟩ := htarget + exact ⟨index, htree, hleaf, hsettled⟩ + +theorem encodingStagePotential_add_messageTargets_card_le_of_new_message + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} + (huncached : cache input = none) + (hnotAt : ∀ candidate : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input candidate) + (hunsettled : ¬ EncodingMessageSettledAt cache secretKey position) + (hsettled : EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position) : + encodingStagePotential (cache.cacheQuery input answer) secretKey + + (encodingMessageTargets secretKey.parameter cache hfinite position).card ≤ + encodingStagePotential cache secretKey := by + classical + have htarget : ¬ HasEncodingTarget cache secretKey position := + fun htarget => hunsettled htarget.messageSettled + have hcachedAt := encodingCachedAt_cacheQuery_of_not_atPosition + (parameter := secretKey.parameter) (cache := cache) (answer := answer) + (hnotAt position) + have hselected : encodingStageContribution (cache.cacheQuery input answer) + secretKey position + + (encodingMessageTargets secretKey.parameter cache hfinite position).card ≤ + encodingStageContribution cache secretKey position := by + simp only [encodingStageContribution, htarget, hunsettled, if_false] + by_cases htarget' : HasEncodingTarget + (cache.cacheQuery input answer) secretKey position + · rw [if_pos htarget', zero_add] + have hcard := encodingMessageTargets_card_le + (parameter := secretKey.parameter) hfinite position + omega + · rw [if_neg htarget', if_pos hsettled, hcachedAt] + have hcard := encodingMessageTargets_card_le + (parameter := secretKey.parameter) hfinite position + omega + rw [encodingStagePotential, encodingStagePotential] + rw [Fintype.sum_eq_add_sum_subtype_ne _ position, + Fintype.sum_eq_add_sum_subtype_ne _ position] + have hother : (∑ candidate : {candidate : EncodingPosition // candidate ≠ position}, + encodingStageContribution (cache.cacheQuery input answer) secretKey candidate) ≤ + ∑ candidate : {candidate : EncodingPosition // candidate ≠ position}, + encodingStageContribution cache secretKey candidate := by + apply Finset.sum_le_sum + intro candidate _ + exact encodingStageContribution_cacheQuery_le_of_not_atPosition huncached + (hnotAt candidate) + calc + (encodingStageContribution (cache.cacheQuery input answer) secretKey position + + ∑ candidate : {candidate : EncodingPosition // candidate ≠ position}, + encodingStageContribution (cache.cacheQuery input answer) secretKey candidate) + + (encodingMessageTargets secretKey.parameter cache hfinite position).card = + (encodingStageContribution (cache.cacheQuery input answer) secretKey position + + (encodingMessageTargets secretKey.parameter cache hfinite position).card) + + ∑ candidate : {candidate : EncodingPosition // candidate ≠ position}, + encodingStageContribution (cache.cacheQuery input answer) secretKey candidate := by + omega + _ ≤ encodingStageContribution cache secretKey position + + ∑ candidate : {candidate : EncodingPosition // candidate ≠ position}, + encodingStageContribution cache secretKey candidate := + Nat.add_le_add hselected hother + +theorem encodingStagePotential_add_answerTargets_card_le_of_new_target_atPosition + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} + (huncached : cache input = none) + (hposition : AtEncodingPosition secretKey.parameter input position) + (hnotTarget : ¬ HasEncodingTarget cache secretKey position) + (htarget : HasEncodingTarget (cache.cacheQuery input answer) secretKey position) : + encodingStagePotential (cache.cacheQuery input answer) secretKey + + (encodingAnswerTargets secretKey.parameter cache hfinite position).card ≤ + encodingStagePotential cache secretKey := by + classical + have hselected : encodingStageContribution (cache.cacheQuery input answer) + secretKey position + + (encodingAnswerTargets secretKey.parameter cache hfinite position).card ≤ + encodingStageContribution cache secretKey position := by + simp only [encodingStageContribution, htarget, hnotTarget, if_true, if_false, + zero_add] + by_cases hsettled : EncodingMessageSettledAt cache secretKey position + · rw [if_pos hsettled] + exact encodingAnswerTargets_card_le hfinite position + · rw [if_neg hsettled] + have hcard := encodingAnswerTargets_card_le + (parameter := secretKey.parameter) hfinite position + omega + rw [encodingStagePotential, encodingStagePotential] + rw [Fintype.sum_eq_add_sum_subtype_ne _ position, + Fintype.sum_eq_add_sum_subtype_ne _ position] + have hother : (∑ candidate : {candidate : EncodingPosition // candidate ≠ position}, + encodingStageContribution (cache.cacheQuery input answer) secretKey candidate) ≤ + ∑ candidate : {candidate : EncodingPosition // candidate ≠ position}, + encodingStageContribution cache secretKey candidate := by + apply Finset.sum_le_sum + intro candidate _ + apply encodingStageContribution_cacheQuery_le_of_not_atPosition huncached + intro hcandidate + exact candidate.property (atEncodingPosition_unique hcandidate hposition) + calc + (encodingStageContribution (cache.cacheQuery input answer) secretKey position + + ∑ candidate : {candidate : EncodingPosition // candidate ≠ position}, + encodingStageContribution (cache.cacheQuery input answer) secretKey candidate) + + (encodingAnswerTargets secretKey.parameter cache hfinite position).card = + (encodingStageContribution (cache.cacheQuery input answer) secretKey position + + (encodingAnswerTargets secretKey.parameter cache hfinite position).card) + + ∑ candidate : {candidate : EncodingPosition // candidate ≠ position}, + encodingStageContribution (cache.cacheQuery input answer) secretKey candidate := by + omega + _ ≤ encodingStageContribution cache secretKey position + + ∑ candidate : {candidate : EncodingPosition // candidate ≠ position}, + encodingStageContribution cache secretKey candidate := + Nat.add_le_add hselected hother + +noncomputable def encodingStructuralPotential (cache : QueryCache HashSpec) + (secretKey : SecretKey) : Nat := + potential secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + + encodingStagePotential cache secretKey + +@[simp] theorem encodingStructuralPotential_empty (secretKey : SecretKey) : + encodingStructuralPotential ∅ secretKey = 0 := by + rw [encodingStructuralPotential, potential_empty, encodingStagePotential_empty, + Nat.zero_add] + +theorem encodingStructuralPotential_add_messageTargets_card_le_of_new_message + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} + (huncached : cache input = none) + (hnotAt : ∀ candidate : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input candidate) + (hunsettled : ¬ EncodingMessageSettledAt cache secretKey position) + (hsettled : EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position) + (hstructural : potential secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) ≤ + potential secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache) : + encodingStructuralPotential (cache.cacheQuery input answer) secretKey + + (encodingMessageTargets secretKey.parameter cache hfinite position).card ≤ + encodingStructuralPotential cache secretKey := by + have hencoding := encodingStagePotential_add_messageTargets_card_le_of_new_message + hfinite huncached hnotAt hunsettled hsettled + rw [encodingStructuralPotential, encodingStructuralPotential] + omega + +theorem encodingStructuralPotential_add_answerTargets_card_le_of_new_target + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} + (huncached : cache input = none) + (hposition : AtEncodingPosition secretKey.parameter input position) + (hnotTarget : ¬ HasEncodingTarget cache secretKey position) + (htarget : HasEncodingTarget (cache.cacheQuery input answer) secretKey position) + (hstructural : potential secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) ≤ + potential secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache) : + encodingStructuralPotential (cache.cacheQuery input answer) secretKey + + (encodingAnswerTargets secretKey.parameter cache hfinite position).card ≤ + encodingStructuralPotential cache secretKey := by + have hencoding := + encodingStagePotential_add_answerTargets_card_le_of_new_target_atPosition + hfinite huncached hposition hnotTarget htarget + rw [encodingStructuralPotential, encodingStructuralPotential] + omega + +theorem encodingStructuralPotential_add_settlingTargets_card_le + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : Position} + (huncached : cache input = none) + (hposition : AtPosition secretKey.parameter input position) + (hunsettled : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache position) + (hsettled : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) position) : + encodingStructuralPotential (cache.cacheQuery input answer) secretKey + + (settlingTargets secretKey.parameter cache hfinite position).card ≤ + encodingStructuralPotential cache secretKey := by + have hstructural := potential_add_settlingTargets_card_le secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret hfinite huncached hposition hunsettled hsettled + have hencoding := encodingStagePotential_cacheQuery_le_of_not_atEncoding + (answer := answer) huncached + (fun candidate hcandidate => hcandidate.not_atPosition position hposition) + rw [encodingStructuralPotential, encodingStructuralPotential] + omega + +inductive LatentEncodingStepOutcome (cache : QueryCache HashSpec) (hfinite : Finite cache) + (secretKey : SecretKey) (input : HashInput) (answer : HashOutput) : Prop where + | existingTarget (position : EncodingPosition) + (atPosition : AtEncodingPosition secretKey.parameter input position) + (target : HasEncodingTarget cache secretKey position) + | provisional (position : EncodingPosition) + (atPosition : AtEncodingPosition secretKey.parameter input position) + (notTarget : ¬ HasEncodingTarget cache secretKey position) + (stillNotTarget : ¬ HasEncodingTarget + (cache.cacheQuery input answer) secretKey position) + (hit : truncateHash answer ∈ + encodingValidAnswerTargets secretKey.parameter cache hfinite position) + | paid (targets : Finset Digest) + (hit : truncateHash answer ∈ targets) + (drop : encodingStructuralPotential (cache.cacheQuery input answer) secretKey + + targets.card ≤ encodingStructuralPotential cache secretKey) + +theorem latentEncodingBad_step_paid_or_provisional + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + (hstructuralClean : ¬ Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache) + (hclean : ¬ LatentEncodingBad cache secretKey) + (huncached : cache input = none) + (hbad : LatentEncodingBad (cache.cacheQuery input answer) secretKey) : + LatentEncodingStepOutcome cache hfinite secretKey input answer := by + classical + rcases latentEncodingBad_step_classify hfinite hclean huncached hbad with + hencoding | hmessage | hpremature + · obtain ⟨position, hposition, hhit⟩ := hencoding + by_cases htarget : HasEncodingTarget cache secretKey position + · exact .existingTarget position hposition htarget + · by_cases htargetAfter : HasEncodingTarget + (cache.cacheQuery input answer) secretKey position + · have hstructural := + (clean_and_potential_cacheQuery_of_not_atPosition secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret (answer := answer) + hstructuralClean huncached + (fun structuralPosition hat => + hposition.not_atPosition structuralPosition hat)).2 + exact .paid (encodingAnswerTargets secretKey.parameter cache hfinite position) + (Finset.mem_filter.mp hhit).1 + (encodingStructuralPotential_add_answerTargets_card_le_of_new_target + hfinite huncached hposition htarget htargetAfter hstructural) + · exact .provisional position hposition htarget htargetAfter hhit + · obtain ⟨position, index, htree, hleaf, hunsettled, hsettled, + hposition, hhit⟩ := hmessage + have hnotEncoding : ∀ candidate : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input candidate := by + intro candidate hcandidate + exact hcandidate.not_atPosition (layerMessagePosition index position.lay) + hposition + have hmessageUnsettled : ¬ EncodingMessageSettledAt cache secretKey position := by + rintro ⟨candidate, hcandidateTree, hcandidateLeaf, hcandidateSettled⟩ + have hpositionEq := layerMessagePosition_eq_of_position_eq index candidate + position.lay (htree.trans hcandidateTree.symm) + (hleaf.trans hcandidateLeaf.symm) + apply hunsettled + rwa [hpositionEq] + have hmessageSettled : EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position := + ⟨index, htree, hleaf, hsettled⟩ + have hstructuralPaid := potential_add_settlingTargets_card_le + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret hfinite huncached + hposition hunsettled hsettled + have hstructural : potential secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (cache.cacheQuery input answer) ≤ + potential secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache := + (Nat.le_add_right _ + (settlingTargets secretKey.parameter cache hfinite + (layerMessagePosition index position.lay)).card).trans hstructuralPaid + exact .paid (encodingMessageTargets secretKey.parameter cache hfinite position) + hhit + (encodingStructuralPotential_add_messageTargets_card_le_of_new_message + hfinite huncached hnotEncoding hmessageUnsettled hmessageSettled hstructural) + · obtain ⟨position, hposition, hunsettled, hsettled, hhit⟩ := + PrematureLayerMessageSettlement.mem_settlingTargets hfinite huncached hpremature + exact .paid (settlingTargets secretKey.parameter cache hfinite position) hhit + (encodingStructuralPotential_add_settlingTargets_card_le hfinite huncached + hposition hunsettled hsettled) + +inductive LatentEncodingAtStepOutcome (cache : QueryCache HashSpec) + (hfinite : Finite cache) (secretKey : SecretKey) + (input : HashInput) (answer : HashOutput) (position : EncodingPosition) : Prop where + | existingTarget + (atPosition : AtEncodingPosition secretKey.parameter input position) + (hit : truncateHash answer ∈ + encodingValidAnswerTargets secretKey.parameter cache hfinite position) + (target : HasEncodingTarget cache secretKey position) + | provisional + (atPosition : AtEncodingPosition secretKey.parameter input position) + (notTarget : ¬ HasEncodingTarget cache secretKey position) + (stillNotTarget : ¬ HasEncodingTarget + (cache.cacheQuery input answer) secretKey position) + (hit : truncateHash answer ∈ + encodingValidAnswerTargets secretKey.parameter cache hfinite position) + (orientation : LatentEncodingFreshOrientation + cache secretKey input answer position) + | paid (targets : Finset Digest) + (hit : truncateHash answer ∈ targets) + (drop : encodingStructuralPotential (cache.cacheQuery input answer) secretKey + + targets.card ≤ encodingStructuralPotential cache secretKey) + +theorem latentEncodingBadAt_step_paid_or_provisional + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} + (hstructuralClean : ¬ Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache) + (hclean : ¬ LatentEncodingBadAt cache secretKey position) + (huncached : cache input = none) + (hbad : LatentEncodingBadAt + (cache.cacheQuery input answer) secretKey position) : + LatentEncodingAtStepOutcome cache hfinite secretKey input answer position := by + classical + rcases latentEncodingBadAt_step_classify hfinite hclean huncached hbad with + hencoding | hmessage | hpremature + · obtain ⟨hposition, hhit⟩ := hencoding + by_cases htarget : HasEncodingTarget cache secretKey position + · exact .existingTarget hposition hhit htarget + · by_cases htargetAfter : HasEncodingTarget + (cache.cacheQuery input answer) secretKey position + · have hstructural := + (clean_and_potential_cacheQuery_of_not_atPosition secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret (answer := answer) + hstructuralClean huncached + (fun structuralPosition hat => + hposition.not_atPosition structuralPosition hat)).2 + exact .paid (encodingAnswerTargets secretKey.parameter cache hfinite position) + (Finset.mem_filter.mp hhit).1 + (encodingStructuralPotential_add_answerTargets_card_le_of_new_target + hfinite huncached hposition htarget htargetAfter hstructural) + · exact .provisional hposition htarget htargetAfter hhit + (latentEncodingBadAt_fresh_orientation hclean huncached hposition hbad) + · obtain ⟨index, htree, hleaf, hunsettled, hsettled, hposition, hhit⟩ := hmessage + have hnotEncoding : ∀ candidate : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input candidate := by + intro candidate hcandidate + exact hcandidate.not_atPosition (layerMessagePosition index position.lay) + hposition + have hmessageUnsettled : ¬ EncodingMessageSettledAt cache secretKey position := by + rintro ⟨candidate, hcandidateTree, hcandidateLeaf, hcandidateSettled⟩ + have hpositionEq := layerMessagePosition_eq_of_position_eq index candidate + position.lay (htree.trans hcandidateTree.symm) + (hleaf.trans hcandidateLeaf.symm) + apply hunsettled + rwa [hpositionEq] + have hmessageSettled : EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position := + ⟨index, htree, hleaf, hsettled⟩ + have hstructuralPaid := potential_add_settlingTargets_card_le + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret hfinite huncached + hposition hunsettled hsettled + have hstructural : potential secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (cache.cacheQuery input answer) ≤ + potential secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache := + (Nat.le_add_right _ + (settlingTargets secretKey.parameter cache hfinite + (layerMessagePosition index position.lay)).card).trans hstructuralPaid + exact .paid (encodingMessageTargets secretKey.parameter cache hfinite position) + hhit + (encodingStructuralPotential_add_messageTargets_card_le_of_new_message + hfinite huncached hnotEncoding hmessageUnsettled hmessageSettled hstructural) + · obtain ⟨structuralPosition, hposition, hunsettled, hsettled, hhit⟩ := + PrematureLayerMessageSettlement.mem_settlingTargets hfinite huncached hpremature + exact .paid (settlingTargets secretKey.parameter cache hfinite structuralPosition) + hhit (encodingStructuralPotential_add_settlingTargets_card_le hfinite huncached + hposition hunsettled hsettled) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingTarget.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingTarget.lean new file mode 100644 index 00000000..07b8ee55 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingTarget.lean @@ -0,0 +1,746 @@ +import SphincsSecurity.Proof.TerminalCache +import SphincsSecurity.Proof.RootCache + +/-! +# Canonical signed encoding targets + +Every successful signer invocation using one one-time position computes the same layer message and +the same least admissible counter. Consequently an encoding collision at that position targets one +canonical signed payload, even when several signatures reuse the position. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +def layerMessagePosition (index : Index) (lay : Layer) : Position := + if lay = topLayer then + .node middleLayer (treeIndexAt index middleLayer) + ⟨layerHeight middleLayer - 1, by decide⟩ ⟨0, by positivity⟩ + else if lay = middleLayer then + .node bottomLayer (treeIndexAt index bottomLayer) + ⟨layerHeight bottomLayer - 1, by decide⟩ ⟨0, by positivity⟩ + else .ftsRoots index + +private theorem topLayer_ne_middleLayer : topLayer ≠ middleLayer := by + intro h + have := congrArg Fin.val h + norm_num [topLayer, middleLayer] at this + +private theorem bottomLayer_ne_topLayer : bottomLayer ≠ topLayer := by + intro h + have := congrArg Fin.val h + norm_num [bottomLayer, topLayer, numLayers] at this + +private theorem bottomLayer_ne_middleLayer : bottomLayer ≠ middleLayer := by + intro h + have := congrArg Fin.val h + norm_num [bottomLayer, middleLayer, numLayers] at this + +@[simp] theorem layerMessagePosition_top (index : Index) : + layerMessagePosition index topLayer = + .node middleLayer (treeIndexAt index middleLayer) + ⟨layerHeight middleLayer - 1, by decide⟩ ⟨0, by positivity⟩ := by + rw [layerMessagePosition, if_pos rfl] + +@[simp] theorem layerMessagePosition_middle (index : Index) : + layerMessagePosition index middleLayer = + .node bottomLayer (treeIndexAt index bottomLayer) + ⟨layerHeight bottomLayer - 1, by decide⟩ ⟨0, by positivity⟩ := by + rw [layerMessagePosition, if_neg topLayer_ne_middleLayer.symm, if_pos rfl] + +@[simp] theorem layerMessagePosition_bottom (index : Index) : + layerMessagePosition index bottomLayer = .ftsRoots index := by + rw [layerMessagePosition, if_neg bottomLayer_ne_topLayer, + if_neg bottomLayer_ne_middleLayer] + +theorem eval_layerMessage_eq_honestValue (f : QueryImpl HashSpec Id) + (secretKey : SecretKey) (index : Index) (lay : Layer) : + evalWithAnswerFn f (layerMessage secretKey index lay) = + honestValue f secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index lay) := by + have hlayer : lay = topLayer ∨ lay = middleLayer ∨ lay = bottomLayer := by + fin_cases lay + · exact Or.inl (Fin.ext rfl) + · exact Or.inr (Or.inl (Fin.ext rfl)) + · exact Or.inr (Or.inr (Fin.ext rfl)) + rcases hlayer with rfl | rfl | rfl + · rw [layerMessage_of_lt secretKey index topLayer (by decide)] + rw [layerMessagePosition_top, honestValue_node] + simp only [show (⟨topLayer.val + 1, by decide⟩ : Layer) = middleLayer from rfl] + rfl + · rw [layerMessage_of_lt secretKey index middleLayer (by decide)] + rw [layerMessagePosition_middle, honestValue_node] + simp only [show (⟨middleLayer.val + 1, by decide⟩ : Layer) = bottomLayer from rfl] + rfl + · rw [layerMessage_bottomLayer secretKey index] + rw [layerMessagePosition_bottom, honestValue_ftsRoots] + rfl + +theorem layerMessagePosition_settled_of_cachedRun {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {index : Index} {lay : Layer} + (hf : cache.AgreesWithFn f) + (hmessage : CachedRun cache f (layerMessage secretKey index lay)) : + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (layerMessagePosition index lay) := by + have hlayer : lay = topLayer ∨ lay = middleLayer ∨ lay = bottomLayer := by + fin_cases lay + · exact Or.inl (Fin.ext rfl) + · exact Or.inr (Or.inl (Fin.ext rfl)) + · exact Or.inr (Or.inr (Fin.ext rfl)) + rcases hlayer with rfl | rfl | rfl + · rw [layerMessage_of_lt secretKey index topLayer (by decide)] at hmessage + rw [layerMessagePosition_top] + simpa only [ + show (⟨topLayer.val + 1, by decide⟩ : Layer) = middleLayer from rfl] using + settled_treeRoot_of_cachedRun (ftsSecret := secretKey.ftsSecret) hf middleLayer + (treeIndexAt index middleLayer) hmessage + · rw [layerMessage_of_lt secretKey index middleLayer (by decide)] at hmessage + rw [layerMessagePosition_middle] + simpa only [ + show (⟨middleLayer.val + 1, by decide⟩ : Layer) = bottomLayer from rfl] using + settled_treeRoot_of_cachedRun (ftsSecret := secretKey.ftsSecret) hf bottomLayer + (treeIndexAt index bottomLayer) hmessage + · rw [layerMessage_bottomLayer secretKey index] at hmessage + rw [layerMessagePosition_bottom] + exact settled_ftsRoots_of_cachedRun (otsSecret := secretKey.otsSecret) hf index hmessage + +theorem SuccessfulSignRun.layerMessagePosition_settled {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} (hf : cache.AgreesWithFn f) + (hrun : SuccessfulSignRun f cache secretKey message signature) + {index : Index} {leaves : DigestTree → FtsLeaf} + (hdigest : SuccessfulDigestRun f cache secretKey message signature.randomness index leaves) + (lay : Layer) : + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (layerMessagePosition index lay) := by + exact layerMessagePosition_settled_of_cachedRun hf + (hrun.honest_layer_at_of_digest hdigest lay).1 + +theorem layerMessagePosition_eq_of_position_eq (left right : Index) (lay : Layer) + (htree : treeIndexAt left lay = treeIndexAt right lay) + (hleaf : leafIndexAt left lay = leafIndexAt right lay) : + layerMessagePosition left lay = layerMessagePosition right lay := by + have hlayer : lay = topLayer ∨ lay = middleLayer ∨ lay = bottomLayer := by + fin_cases lay + · exact Or.inl (Fin.ext rfl) + · exact Or.inr (Or.inl (Fin.ext rfl)) + · exact Or.inr (Or.inr (Fin.ext rfl)) + rcases hlayer with rfl | rfl | rfl + · rw [layerMessagePosition_top, layerMessagePosition_top, + middleTree_eq_of_top_position_eq left right htree hleaf] + · rw [layerMessagePosition_middle, layerMessagePosition_middle, + bottomTree_eq_of_middle_position_eq left right htree hleaf] + · rw [layerMessagePosition_bottom, layerMessagePosition_bottom, + index_eq_of_bottom_position_eq htree hleaf] + +def SignedEncodingPayloadAt (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (payload : HashInput) : Prop := + ∃ (entry : (request : SignRequest) × SigningSpec.Range request) (signature : Signature) + (index : Index) (leaves : DigestTree → FtsLeaf), + entry ∈ signingLog + ∧ entry.2 = some signature + ∧ SuccessfulSignRun f cache secretKey entry.1 signature + ∧ SuccessfulDigestRun f cache secretKey entry.1 signature.randomness index leaves + ∧ treeIndexAt index lay = tree + ∧ leafIndexAt index lay = leafIdx + ∧ payload = digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay) + +def encodingSearchFrom (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : + Nat → Nat → OracleComp HashSpec (Option Counter) + | 0, _ => pure none + | attempts + 1, counter => do + match ← encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter) with + | some _ => pure (some (BitVec.ofNat counterBits counter)) + | none => encodingSearchFrom parameter lay tree leafIdx message attempts (counter + 1) + +def encodingSearch (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : OracleComp HashSpec (Option Counter) := + encodingSearchFrom parameter lay tree leafIdx message encodingAttemptLimit 0 + +theorem mem_queriedInputs_encodingSearchFrom (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (attempts counter : Nat) (input : HashInput) + (hinput : input ∈ queriedInputs f + (encodingSearchFrom parameter lay tree leafIdx message attempts counter)) : + ∃ selectedCounter : Counter, + input = tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes message ++ counterBytes selectedCounter) := by + induction attempts generalizing counter with + | zero => simp [encodingSearchFrom] at hinput + | succ attempts ih => + rw [encodingSearchFrom, queriedInputs_bind] at hinput + rcases List.mem_append.mp hinput with hinput | hinput + · simp only [encode, queriedInputs_bind, queriedInputs_tweakableHash, + queriedInputs_pure, List.append_nil, List.mem_singleton] at hinput + exact ⟨BitVec.ofNat counterBits counter, hinput⟩ + · cases hencode : evalWithAnswerFn f + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) with + | none => + simp only [hencode] at hinput + exact ih (counter + 1) hinput + | some codeword => simp [hencode] at hinput + +theorem mem_queriedInputs_encodingSearch (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (input : HashInput) + (hinput : input ∈ queriedInputs f (encodingSearch parameter lay tree leafIdx message)) : + ∃ selectedCounter : Counter, + input = tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes message ++ counterBytes selectedCounter) := by + exact mem_queriedInputs_encodingSearchFrom f parameter lay tree leafIdx message + encodingAttemptLimit 0 input (by simpa only [encodingSearch] using hinput) + +theorem encodingSearchFrom_selected_mem (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (attempts counter : Nat) (selected : Counter) + (hselected : evalWithAnswerFn f + (encodingSearchFrom parameter lay tree leafIdx message attempts counter) = some selected) : + tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes message ++ counterBytes selected) ∈ + queriedInputs f + (encodingSearchFrom parameter lay tree leafIdx message attempts counter) := by + induction attempts generalizing counter with + | zero => simp [encodingSearchFrom] at hselected + | succ attempts ih => + rw [encodingSearchFrom, evalWithAnswerFn_bind] at hselected + cases hencode : evalWithAnswerFn f + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) with + | none => + simp only [hencode] at hselected + rw [encodingSearchFrom, queriedInputs_bind] + apply List.mem_append_right + simp only [hencode] + exact ih (counter + 1) hselected + | some codeword => + simp only [hencode, evalWithAnswerFn_pure, Option.some.injEq] at hselected + subst selected + rw [encodingSearchFrom, queriedInputs_bind] + apply List.mem_append_left + simp only [encode, queriedInputs_bind, queriedInputs_tweakableHash, + queriedInputs_pure, List.append_nil, List.mem_singleton] + +theorem encodingSearch_selected_mem (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (selected : Counter) + (hselected : evalWithAnswerFn f + (encodingSearch parameter lay tree leafIdx message) = some selected) : + tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes message ++ counterBytes selected) ∈ + queriedInputs f (encodingSearch parameter lay tree leafIdx message) := by + exact encodingSearchFrom_selected_mem f parameter lay tree leafIdx message + encodingAttemptLimit 0 selected (by simpa only [encodingSearch] using hselected) + +theorem encodingSearchFrom_selected_encode_ne_none (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (attempts counter : Nat) (selected : Counter) + (hselected : evalWithAnswerFn f + (encodingSearchFrom parameter lay tree leafIdx message attempts counter) = some selected) : + evalWithAnswerFn f (encode parameter lay tree leafIdx message selected) ≠ none := by + induction attempts generalizing counter with + | zero => simp [encodingSearchFrom] at hselected + | succ attempts ih => + rw [encodingSearchFrom, evalWithAnswerFn_bind] at hselected + cases hencode : evalWithAnswerFn f + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) with + | none => + simp only [hencode] at hselected + exact ih (counter + 1) hselected + | some codeword => + simp only [hencode, evalWithAnswerFn_pure, Option.some.injEq] at hselected + subst selected + rw [hencode] + simp + +theorem encodingSearch_selected_encode_ne_none (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (selected : Counter) + (hselected : evalWithAnswerFn f + (encodingSearch parameter lay tree leafIdx message) = some selected) : + evalWithAnswerFn f (encode parameter lay tree leafIdx message selected) ≠ none := by + exact encodingSearchFrom_selected_encode_ne_none f parameter lay tree leafIdx message + encodingAttemptLimit 0 selected (by simpa only [encodingSearch] using hselected) + +theorem encodingSearchFrom_rejected_before (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (attempts counter : Nat) (selected : Counter) + (hbound : counter + attempts ≤ 2 ^ counterBits) + (hselected : evalWithAnswerFn f + (encodingSearchFrom parameter lay tree leafIdx message attempts counter) = some selected) + (candidate : Nat) (hlower : counter ≤ candidate) (hbefore : candidate < selected.toNat) : + evalWithAnswerFn f + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits candidate)) = none := by + induction attempts generalizing counter candidate with + | zero => simp [encodingSearchFrom] at hselected + | succ attempts ih => + have hcounterLt : counter < 2 ^ counterBits := by omega + rw [encodingSearchFrom, evalWithAnswerFn_bind] at hselected + cases hencode : evalWithAnswerFn f + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) with + | none => + simp only [hencode] at hselected + by_cases heq : candidate = counter + · subst candidate + exact hencode + · exact ih (counter + 1) (by omega) hselected candidate (by omega) hbefore + | some codeword => + have hselectedEq : BitVec.ofNat counterBits counter = selected := by + simpa only [hencode, evalWithAnswerFn_pure, Option.some.injEq] using hselected + have hselectedNat : selected.toNat = counter := by + rw [← hselectedEq, BitVec.toNat_ofNat, Nat.mod_eq_of_lt hcounterLt] + omega + +theorem encodingSearch_rejected_before (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (selected candidate : Counter) + (hselected : evalWithAnswerFn f + (encodingSearch parameter lay tree leafIdx message) = some selected) + (hbefore : candidate.toNat < selected.toNat) : + evalWithAnswerFn f (encode parameter lay tree leafIdx message candidate) = none := by + have hrejected := encodingSearchFrom_rejected_before f parameter lay tree leafIdx message + encodingAttemptLimit 0 selected (by norm_num [encodingAttemptLimit, counterBits]) + (by simpa only [encodingSearch] using hselected) candidate.toNat (by omega) hbefore + simpa using hrejected + +theorem otsSignFrom_eq_some_of_valid_query (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (secret : ChainIndex → Digest) (message : Digest) (attempts counter : Nat) + (selected : Counter) + (hquery : tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes message ++ counterBytes selected) ∈ + queriedInputs f + (otsSignFrom parameter lay tree leafIdx secret message attempts counter)) + (hvalid : evalWithAnswerFn f + (encode parameter lay tree leafIdx message selected) ≠ none) : + ∃ values : ChainIndex → Digest, + evalWithAnswerFn f + (otsSignFrom parameter lay tree leafIdx secret message attempts counter) = + some (selected, values) := by + induction attempts generalizing counter with + | zero => simp [otsSignFrom] at hquery + | succ attempts ih => + rw [otsSignFrom, queriedInputs_bind] at hquery + cases hencode : evalWithAnswerFn f + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) with + | none => + rcases List.mem_append.mp hquery with hcurrent | hrest + · simp only [encode, queriedInputs_bind, queriedInputs_tweakableHash, + queriedInputs_pure, List.append_nil, List.mem_singleton] at hcurrent + have hpayload := + (tweakableHashInput_injective parameter (by trivial) (by trivial) hcurrent).2 + obtain ⟨_, hcounterBytes⟩ := + List.append_inj hpayload (by simp [digestBytes_length]) + have hselected : selected = BitVec.ofNat counterBits counter := + bytesLE_injective hcounterBytes + rw [hselected] at hvalid + exact (hvalid hencode).elim + · simp only [hencode] at hrest + obtain ⟨values, hvalues⟩ := ih (counter + 1) hrest + exact ⟨values, by simp only [otsSignFrom, evalWithAnswerFn_bind, hencode, hvalues]⟩ + | some codeword => + have hcurrent : tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes message ++ counterBytes selected) = + tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes message ++ counterBytes (BitVec.ofNat counterBits counter)) := by + rcases List.mem_append.mp hquery with hcurrent | hrest + · simpa only [encode, queriedInputs_bind, queriedInputs_tweakableHash, + queriedInputs_pure, List.append_nil, List.mem_singleton] using hcurrent + · have hstructural : QueriesAtPositions parameter f (do + let values ← sequenceFin fun chainIdx => + chainWalk parameter lay tree leafIdx chainIdx 0 + (codeword chainIdx).val (secret chainIdx) + pure (some (BitVec.ofNat counterBits counter, values))) := by + apply QueriesAtPositions.bind + · apply queriesAtPositions_sequenceFin + intro chainIdx + exact queriesAtPositions_chainWalk parameter f lay tree leafIdx chainIdx + 0 _ _ + · exact QueriesAtPositions.pure parameter f _ + simp only [hencode] at hrest + obtain ⟨position, payload, hpayload⟩ := hstructural _ hrest + exact False.elim ((encodingInput_ne_positionInput parameter lay tree leafIdx + (digestBytes message ++ counterBytes selected) position payload) hpayload) + have hpayload := + (tweakableHashInput_injective parameter (by trivial) (by trivial) hcurrent).2 + obtain ⟨_, hcounterBytes⟩ := + List.append_inj hpayload (by simp [digestBytes_length]) + have hselected : selected = BitVec.ofNat counterBits counter := + bytesLE_injective hcounterBytes + subst selected + refine ⟨fun chainIdx => evalWithAnswerFn f + (chainWalk parameter lay tree leafIdx chainIdx 0 (codeword chainIdx).val + (secret chainIdx)), ?_⟩ + simp only [otsSignFrom, evalWithAnswerFn_bind, hencode, + evalWithAnswerFn_sequenceFin, evalWithAnswerFn_pure] + +theorem otsSignFrom_selected_encoding_mem (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (secret : ChainIndex → Digest) (message : Digest) (attempts counter : Nat) + (selected : Counter) (values : ChainIndex → Digest) + (hselected : evalWithAnswerFn f + (otsSignFrom parameter lay tree leafIdx secret message attempts counter) = + some (selected, values)) : + tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes message ++ counterBytes selected) ∈ + queriedInputs f (otsSignFrom parameter lay tree leafIdx secret message attempts counter) := by + induction attempts generalizing counter with + | zero => simp [otsSignFrom] at hselected + | succ attempts ih => + rw [otsSignFrom, evalWithAnswerFn_bind] at hselected + cases hencode : evalWithAnswerFn f + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) with + | none => + simp only [hencode] at hselected + rw [otsSignFrom, queriedInputs_bind] + apply List.mem_append_right + simp only [hencode] + exact ih (counter + 1) hselected + | some codeword => + simp only [hencode, evalWithAnswerFn_bind, evalWithAnswerFn_sequenceFin, + evalWithAnswerFn_pure, Option.some.injEq, Prod.mk.injEq] at hselected + have hcounter : BitVec.ofNat counterBits counter = selected := hselected.1 + subst selected + rw [otsSignFrom, queriedInputs_bind] + apply List.mem_append_left + simp only [encode, queriedInputs_bind, queriedInputs_tweakableHash, + queriedInputs_pure, List.append_nil, List.mem_singleton] + +theorem otsSign_selected_encoding_mem (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (secret : ChainIndex → Digest) (message : Digest) (selected : Counter) + (values : ChainIndex → Digest) + (hselected : evalWithAnswerFn f (otsSign parameter lay tree leafIdx secret message) = + some (selected, values)) : + tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes message ++ counterBytes selected) ∈ + queriedInputs f (otsSign parameter lay tree leafIdx secret message) := by + exact otsSignFrom_selected_encoding_mem f parameter lay tree leafIdx secret message + encodingAttemptLimit 0 selected values (by simpa only [otsSign] using hselected) + +theorem otsSignFrom_encodingSearchFrom_some_cached (f : QueryImpl HashSpec Id) + (cache : QueryCache HashSpec) (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (secret : ChainIndex → Digest) + (message : Digest) (attempts counter : Nat) (resultCounter : Counter) + (values : ChainIndex → Digest) + (hsign : evalWithAnswerFn f + (otsSignFrom parameter lay tree leafIdx secret message attempts counter) = + some (resultCounter, values)) + (hrun : CachedRun cache f + (otsSignFrom parameter lay tree leafIdx secret message attempts counter)) : + evalWithAnswerFn f + (encodingSearchFrom parameter lay tree leafIdx message attempts counter) = + some resultCounter + ∧ CachedRun cache f + (encodingSearchFrom parameter lay tree leafIdx message attempts counter) := by + induction attempts generalizing counter with + | zero => simp [otsSignFrom] at hsign + | succ attempts ih => + rw [otsSignFrom, evalWithAnswerFn_bind] at hsign + rw [otsSignFrom] at hrun + cases hencode : evalWithAnswerFn f + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) with + | none => + simp only [hencode] at hsign + have hrest := ih (counter + 1) hsign (by + have := hrun.bind_right + simpa only [hencode] using this) + refine ⟨?_, ?_⟩ + · simp only [encodingSearchFrom, evalWithAnswerFn_bind, hencode] + exact hrest.1 + · intro input hinput + rw [encodingSearchFrom, queriedInputs_bind] at hinput + rcases List.mem_append.mp hinput with hinput | hinput + · exact hrun.bind_left input hinput + · simp only [hencode] at hinput + exact hrest.2 input hinput + | some codeword => + simp only [hencode, evalWithAnswerFn_bind, evalWithAnswerFn_sequenceFin, + evalWithAnswerFn_pure, Option.some.injEq, Prod.mk.injEq] at hsign + have hcounter : BitVec.ofNat counterBits counter = resultCounter := hsign.1 + subst resultCounter + refine ⟨?_, ?_⟩ + · simp [encodingSearchFrom, evalWithAnswerFn_bind, hencode] + · intro input hinput + rw [encodingSearchFrom, queriedInputs_bind] at hinput + rcases List.mem_append.mp hinput with hinput | hinput + · exact hrun.bind_left input hinput + · simp [hencode] at hinput + +theorem otsSign_encodingSearch_some_cached (f : QueryImpl HashSpec Id) + (cache : QueryCache HashSpec) (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (secret : ChainIndex → Digest) + (message : Digest) (resultCounter : Counter) (values : ChainIndex → Digest) + (hsign : evalWithAnswerFn f + (otsSign parameter lay tree leafIdx secret message) = some (resultCounter, values)) + (hrun : CachedRun cache f (otsSign parameter lay tree leafIdx secret message)) : + evalWithAnswerFn f (encodingSearch parameter lay tree leafIdx message) = some resultCounter + ∧ CachedRun cache f (encodingSearch parameter lay tree leafIdx message) := by + simpa only [otsSign, encodingSearch] using + otsSignFrom_encodingSearchFrom_some_cached f cache parameter lay tree leafIdx secret message + encodingAttemptLimit 0 resultCounter values hsign hrun + +def CachedSignedEncodingPayloadAt (cache : QueryCache HashSpec) (secretKey : SecretKey) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (payload : HashInput) : Prop := + ∃ (index : Index) (counter : Counter), + treeIndexAt index lay = tree + ∧ leafIndexAt index lay = leafIdx + ∧ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (layerMessagePosition index lay) + ∧ CachedRun cache (fromCache cache) + (encodingSearch secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (layerMessagePosition index lay))) + ∧ evalWithAnswerFn (fromCache cache) + (encodingSearch secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (layerMessagePosition index lay))) = some counter + ∧ payload = digestBytes (honestValue (fromCache cache) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret (layerMessagePosition index lay)) ++ + counterBytes counter + ∧ cache (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) payload) ≠ none + +theorem CachedSignedEncodingPayloadAt.target_valid + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {lay : Layer} {tree : TreeIndex} {leafIdx : LeafIndex} {payload : HashInput} + (htarget : CachedSignedEncodingPayloadAt cache secretKey lay tree leafIdx payload) : + TargetSum.ValidDigest (truncateHash (fromCache cache + (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) payload))) := by + obtain ⟨index, counter, htree, hleaf, _, _, heval, hpayload, _⟩ := htarget + have hselected := encodingSearch_selected_encode_ne_none (fromCache cache) + secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index lay)) counter heval + have hvalid := (eval_encode_ne_none_iff_validDigest (fromCache cache) + secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index lay)) counter).mp hselected + rwa [htree, hleaf, ← hpayload] at hvalid + +theorem CachedSignedEncodingPayloadAt.target_least_valid + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {lay : Layer} {tree : TreeIndex} {leafIdx : LeafIndex} {payload : HashInput} + (htarget : CachedSignedEncodingPayloadAt cache secretKey lay tree leafIdx payload) : + ∃ (index : Index) (counter : Counter), + treeIndexAt index lay = tree + ∧ leafIndexAt index lay = leafIdx + ∧ payload = digestBytes (honestValue (fromCache cache) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret (layerMessagePosition index lay)) ++ + counterBytes counter + ∧ TargetSum.ValidDigest (truncateHash (fromCache cache + (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) payload))) + ∧ ∀ candidate : Counter, candidate.toNat < counter.toNat → + ¬ TargetSum.ValidDigest (truncateHash (fromCache cache + (tweakableHashInput secretKey.parameter + (.encoding lay (treeIndexAt index lay) (leafIndexAt index lay)) + (digestBytes (honestValue (fromCache cache) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret (layerMessagePosition index lay)) ++ + counterBytes candidate)))) := by + have htargetData := htarget + obtain ⟨index, counter, htree, hleaf, _, _, heval, hpayload, _⟩ := htargetData + refine ⟨index, counter, htree, hleaf, hpayload, htarget.target_valid, ?_⟩ + intro candidate hbefore hvalid + have hrejected := encodingSearch_rejected_before (fromCache cache) secretKey.parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) + (honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index lay)) counter candidate heval hbefore + have hnonempty := (eval_encode_ne_none_iff_validDigest (fromCache cache) + secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index lay)) candidate).mpr hvalid + exact hnonempty (by rw [hrejected]) + +theorem SignedLayerAt.signedEncodingPayload {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} + {lay : Layer} {tree : TreeIndex} {leafIdx : LeafIndex} + (hsigned : SignedLayerAt f cache secretKey signingLog lay tree leafIdx) : + ∃ payload, SignedEncodingPayloadAt f cache secretKey signingLog lay tree leafIdx payload := by + obtain ⟨entry, signature, index, leaves, hentry, hresponse, hrun, hdigest, htree, hleaf, _⟩ := + hsigned + exact ⟨_, entry, signature, index, leaves, hentry, hresponse, hrun, hdigest, htree, hleaf, rfl⟩ + +theorem SignedEncodingPayloadAt.cached {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} + {lay : Layer} {tree : TreeIndex} {leafIdx : LeafIndex} {payload : HashInput} + (hf : cache.AgreesWithFn f) + (hsigned : SignedEncodingPayloadAt f cache secretKey signingLog lay tree leafIdx payload) : + CachedSignedEncodingPayloadAt cache secretKey lay tree leafIdx payload := by + obtain ⟨_, signature, index, leaves, _, _, hrun, hdigest, htree, hleaf, hpayload⟩ := hsigned + obtain ⟨part, hcounter, _, hlayer⟩ := hrun.layerRun_of_digest hdigest lay + obtain ⟨hotsEval, hotsCached⟩ := hlayer.otsSign_eval_cached + have hselection := otsSign_encodingSearch_some_cached f cache secretKey.parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay)) part.1 part.2.1 hotsEval hotsCached + have hsettled := hrun.layerMessagePosition_settled hf hdigest lay + have hmessage : evalWithAnswerFn f (layerMessage secretKey index lay) = + honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (layerMessagePosition index lay) := by + rw [eval_layerMessage_eq_honestValue] + exact honestValue_eq_of_settled hf hsettled + rw [hmessage] at hselection + have heval := hselection.2.eval_eq hf (agreesWithFn_fromCache cache) + have htargetCached := hrun.signed_encode_cached_of_digest hdigest lay + refine ⟨index, part.1, htree, hleaf, hsettled, + hselection.2.changeAnswerFn hf (agreesWithFn_fromCache cache), ?_, ?_, ?_⟩ + · exact heval.symm.trans hselection.1 + · rw [hpayload, hmessage, hcounter] + · rw [hpayload] + rw [htree, hleaf] at htargetCached + exact htargetCached + +theorem cachedSignedEncodingPayloadAt_unique {cache : QueryCache HashSpec} + {secretKey : SecretKey} {lay : Layer} {tree : TreeIndex} {leafIdx : LeafIndex} + {leftPayload rightPayload : HashInput} + (left : CachedSignedEncodingPayloadAt cache secretKey lay tree leafIdx leftPayload) + (right : CachedSignedEncodingPayloadAt cache secretKey lay tree leafIdx rightPayload) : + leftPayload = rightPayload := by + obtain ⟨leftIndex, leftCounter, leftTree, leftLeaf, _, _, leftEval, rfl, _⟩ := left + obtain ⟨rightIndex, rightCounter, rightTree, rightLeaf, _, _, rightEval, rfl, _⟩ := right + have htree : treeIndexAt leftIndex lay = treeIndexAt rightIndex lay := + leftTree.trans rightTree.symm + have hleaf : leafIndexAt leftIndex lay = leafIndexAt rightIndex lay := + leftLeaf.trans rightLeaf.symm + have hposition := layerMessagePosition_eq_of_position_eq leftIndex rightIndex lay htree hleaf + rw [htree, hleaf, hposition] at leftEval + have hcounter : leftCounter = rightCounter := Option.some.inj (leftEval.symm.trans rightEval) + rw [hposition, hcounter] + +theorem CachedSignedEncodingPayloadAt.mono {cache cache' : QueryCache HashSpec} + {secretKey : SecretKey} {lay : Layer} {tree : TreeIndex} {leafIdx : LeafIndex} + {payload : HashInput} (hle : cache ≤ cache') + (htarget : CachedSignedEncodingPayloadAt cache secretKey lay tree leafIdx payload) : + CachedSignedEncodingPayloadAt cache' secretKey lay tree leafIdx payload := by + obtain ⟨index, counter, htree, hleaf, hsettled, hrun, heval, hpayload, hcached⟩ := htarget + have hagrees : cache.AgreesWithFn (fromCache cache') := agreesWithFn_fromCache_of_le hle + have hvalue := honestValue_eq_of_settled hagrees hsettled + rw [← hvalue] at hrun heval + have hevalEq := hrun.eval_eq (agreesWithFn_fromCache cache) hagrees + have hrun' := (hrun.changeAnswerFn (agreesWithFn_fromCache cache) hagrees).mono hle + refine ⟨index, counter, htree, hleaf, hsettled.mono hle, hrun', + hevalEq.symm.trans heval, ?_, ?_⟩ + · rw [hpayload, hvalue] + · obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hcached + rw [hle hanswer] + simp + +theorem signedEncodingPayloadAt_unique {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} + {lay : Layer} {tree : TreeIndex} {leafIdx : LeafIndex} {leftPayload rightPayload : HashInput} + (left : SignedEncodingPayloadAt f cache secretKey signingLog lay tree leafIdx leftPayload) + (right : SignedEncodingPayloadAt f cache secretKey signingLog lay tree leafIdx rightPayload) : + leftPayload = rightPayload := by + obtain ⟨_, leftSignature, leftIndex, leftLeaves, _, _, leftRun, leftDigest, leftTree, + leftLeaf, rfl⟩ := left + obtain ⟨_, rightSignature, rightIndex, rightLeaves, _, _, rightRun, rightDigest, rightTree, + rightLeaf, rfl⟩ := right + have htree : treeIndexAt leftIndex lay = treeIndexAt rightIndex lay := + leftTree.trans rightTree.symm + have hleaf : leafIndexAt leftIndex lay = leafIndexAt rightIndex lay := + leftLeaf.trans rightLeaf.symm + have hmessage : evalWithAnswerFn f (layerMessage secretKey leftIndex lay) = + evalWithAnswerFn f (layerMessage secretKey rightIndex lay) := + congrArg (evalWithAnswerFn f) + (layerMessage_eq_of_position_eq secretKey leftIndex rightIndex lay htree hleaf) + have hots := successfulSignRun_layer_ots_eq_of_position_eq leftRun rightRun leftDigest + rightDigest lay htree hleaf + rw [hmessage, hots.1] + +def EncodingCollisionAtSignedPayload (f : QueryImpl HashSpec Id) + (cache : QueryCache HashSpec) (secretKey : SecretKey) + (signingLog : QueryLog SigningSpec) : Prop := + ∃ (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (signedPayload forgedPayload : HashInput) (signedAnswer forgedAnswer : HashOutput), + SignedEncodingPayloadAt f cache secretKey signingLog lay tree leafIdx signedPayload + ∧ signedPayload ≠ forgedPayload + ∧ cache (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) signedPayload) = + some signedAnswer + ∧ cache (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) forgedPayload) = + some forgedAnswer + ∧ truncateHash signedAnswer = truncateHash forgedAnswer + +def EncodingBad (cache : QueryCache HashSpec) (secretKey : SecretKey) : Prop := + ∃ (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (signedPayload otherPayload : HashInput) (signedAnswer otherAnswer : HashOutput), + CachedSignedEncodingPayloadAt cache secretKey lay tree leafIdx signedPayload + ∧ signedPayload ≠ otherPayload + ∧ cache (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) signedPayload) = + some signedAnswer + ∧ cache (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) otherPayload) = + some otherAnswer + ∧ truncateHash signedAnswer = truncateHash otherAnswer + +theorem EncodingBad.valid_answers {cache : QueryCache HashSpec} {secretKey : SecretKey} + (hbad : EncodingBad cache secretKey) : + ∃ (signedAnswer otherAnswer : HashOutput), + TargetSum.ValidDigest (truncateHash signedAnswer) + ∧ TargetSum.ValidDigest (truncateHash otherAnswer) := by + obtain ⟨lay, tree, leafIdx, signedPayload, _, signedAnswer, otherAnswer, + htarget, _, hsigned, _, hcollision⟩ := hbad + have hvalid := htarget.target_valid + have hfromCache : fromCache cache + (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) signedPayload) = + signedAnswer := by + simp [fromCache, hsigned] + rw [hfromCache] at hvalid + exact ⟨signedAnswer, otherAnswer, hvalid, hvalid.of_eq hcollision⟩ + +theorem EncodingCollision.at_signed_payload {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} (hf : cache.AgreesWithFn f) + (hcollision : EncodingCollision f cache secretKey signingLog) : + EncodingCollisionAtSignedPayload f cache secretKey signingLog := by + obtain ⟨lay, tree, leafIdx, forgedMessage, forgedCounter, forgedValues, _, entry, signature, + index, leaves, hforgedRun, _, hentry, hresponse, hrun, hdigest, htree, hleaf, _, _, + hsignedCached, hhit⟩ := hcollision + let signedPayload := digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay) + let forgedPayload := digestBytes forgedMessage ++ counterBytes forgedCounter + let signedInput := tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) signedPayload + let forgedInput := tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) forgedPayload + obtain ⟨signedAnswer, hsignedAnswer⟩ := Option.ne_none_iff_exists'.mp hsignedCached + have hforgedCached : cache forgedInput ≠ none := + CachedRun.otsLeaf_encode_cached hforgedRun + obtain ⟨forgedAnswer, hforgedAnswer⟩ := Option.ne_none_iff_exists'.mp hforgedCached + change signedInput ≠ forgedInput ∧ truncateHash (f signedInput) = truncateHash (f forgedInput) + at hhit + refine ⟨lay, tree, leafIdx, signedPayload, forgedPayload, signedAnswer, forgedAnswer, + ⟨entry, signature, index, leaves, hentry, hresponse, hrun, hdigest, htree, hleaf, rfl⟩, + ?_, hsignedAnswer, hforgedAnswer, ?_⟩ + · exact fun heq => hhit.1 (congrArg + (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx)) heq) + · rw [← hf hsignedAnswer, ← hf hforgedAnswer] + exact hhit.2 + +theorem EncodingCollisionAtSignedPayload.encodingBad {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} (hf : cache.AgreesWithFn f) + (hcollision : EncodingCollisionAtSignedPayload f cache secretKey signingLog) : + EncodingBad cache secretKey := by + obtain ⟨lay, tree, leafIdx, signedPayload, otherPayload, signedAnswer, otherAnswer, + hsigned, hne, hsignedCached, hotherCached, hvalue⟩ := hcollision + exact ⟨lay, tree, leafIdx, signedPayload, otherPayload, signedAnswer, otherAnswer, + hsigned.cached hf, hne, hsignedCached, hotherCached, hvalue⟩ + +theorem EncodingCollision.encodingBad {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} (hf : cache.AgreesWithFn f) + (hcollision : EncodingCollision f cache secretKey signingLog) : + EncodingBad cache secretKey := + (hcollision.at_signed_payload hf).encodingBad hf + +theorem EncodingBad.mono {cache cache' : QueryCache HashSpec} {secretKey : SecretKey} + (hle : cache ≤ cache') (hbad : EncodingBad cache secretKey) : EncodingBad cache' secretKey := by + obtain ⟨lay, tree, leafIdx, signedPayload, otherPayload, signedAnswer, otherAnswer, + hsigned, hne, hsignedCached, hotherCached, hvalue⟩ := hbad + exact ⟨lay, tree, leafIdx, signedPayload, otherPayload, signedAnswer, otherAnswer, + hsigned.mono hle, hne, hle hsignedCached, hle hotherCached, hvalue⟩ + +theorem not_encodingBad_empty (secretKey : SecretKey) : ¬ EncodingBad ∅ secretKey := by + rintro ⟨_, _, _, _, _, _, _, _, _, hsignedCached, _⟩ + simp at hsignedCached + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingTerminalLatent.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingTerminalLatent.lean new file mode 100644 index 00000000..ecf209b3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingTerminalLatent.lean @@ -0,0 +1,95 @@ +import SphincsSecurity.Proof.EncodingTraceLatent + +/-! +# Latent encoding creation through final verification + +The fixed encoding position exposed by a terminal collision is traced through the adversary and the final verifier without discarding the fresh query that first creates it. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +namespace Concrete + +inductive FinalLatentEncodingAtOutcome + (secretKey : SecretKey) (position : EncodingPosition) + (trace : FullAdversaryTrace) (adversaryCache finalCache : QueryCache HashSpec) : Prop where + | adversary (source : Fin trace.intervals.length) + (outcome : FirstLatentAtIntervalOutcome secretKey position + (trace.intervals.get source)) + | verifier (cache : QueryCache HashSpec) (input : HashInput) (answer : HashOutput) + (finiteCache : Finite cache) + (adversaryLe : adversaryCache ≤ cache) + (finalLe : cache.cacheQuery input answer ≤ finalCache) + (stepClean : ¬ LatentEncodingBadAt cache secretKey position) + (uncached : cache input = none) + (stepBad : LatentEncodingBadAt + (cache.cacheQuery input answer) secretKey position) + (outcome : LatentEncodingAtStepOutcome cache finiteCache secretKey input answer position) + +theorem firstLatentEncodingAt_finalOutcome + {alpha : Type} {rootCache adversaryCache finalCache : QueryCache HashSpec} + {secretKey : SecretKey} {trace : FullAdversaryTrace} + {position : EncodingPosition} {verification : OracleComp OracleWorld alpha} + {result : alpha} + (hchain : FullAdversaryTrace.CacheChain rootCache trace.intervals adversaryCache) + (hvalid : trace.ValidIntervals secretKey) + (hintervals : trace.IntervalsLe finalCache) + (hfinite : Finite finalCache) + (hstructuralClean : ¬ Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret finalCache) + (hrootClean : ¬ LatentEncodingBadAt rootCache secretKey position) + (hrun : (result, finalCache) ∈ support + ((simulateQ romImpl verification).run adversaryCache)) + (hbad : LatentEncodingBadAt finalCache secretKey position) : + FinalLatentEncodingAtOutcome secretKey position trace adversaryCache finalCache := by + by_cases hadversaryBad : LatentEncodingBadAt adversaryCache secretKey position + · obtain ⟨source, houtcome⟩ := firstLatentAtIntervalOutcome hchain hvalid hintervals + hfinite hstructuralClean hrootClean hadversaryBad + exact .adversary source houtcome + · obtain ⟨cache, input, answer, hadversaryLe, hstepClean, huncached, hstepBad, + hfinalLe⟩ := freshBadStep_of_mem_support + (fun cache => LatentEncodingBadAt cache secretKey position) + verification adversaryCache result finalCache hrun hadversaryBad hbad + have hfiniteCache : Finite cache := + hfinite.of_le ((le_cacheQuery huncached).trans hfinalLe) + have hstepStructuralClean : ¬ Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache := by + intro hbadCache + exact hstructuralClean (Bad.mono secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret ((le_cacheQuery huncached).trans hfinalLe) hbadCache) + exact .verifier cache input answer hfiniteCache hadversaryLe hfinalLe hstepClean + huncached hstepBad + (latentEncodingBadAt_step_paid_or_provisional hfiniteCache hstepStructuralClean + hstepClean huncached hstepBad) + +theorem encodingBad_finalOutcome + {alpha : Type} {rootCache adversaryCache finalCache : QueryCache HashSpec} + {secretKey : SecretKey} {trace : FullAdversaryTrace} + {verification : OracleComp OracleWorld alpha} {result : alpha} + (hchain : FullAdversaryTrace.CacheChain rootCache trace.intervals adversaryCache) + (hvalid : trace.ValidIntervals secretKey) + (hintervals : trace.IntervalsLe finalCache) + (hfinite : Finite finalCache) + (hstructuralClean : ¬ Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret finalCache) + (hrootEncodingNone : ∀ (position : EncodingPosition) (payload : HashInput), + rootCache (tweakableHashInput secretKey.parameter position.domain payload) = none) + (hrun : (result, finalCache) ∈ support + ((simulateQ romImpl verification).run adversaryCache)) + (hbad : EncodingBad finalCache secretKey) : + ∃ position : EncodingPosition, + HasEncodingTarget finalCache secretKey position ∧ + FinalLatentEncodingAtOutcome secretKey position trace adversaryCache finalCache := by + obtain ⟨position, htarget, hlatent⟩ := hbad.latent_with_target + have hrootClean : ¬ LatentEncodingBadAt rootCache secretKey position := by + intro hrootBad + exact not_latentEncodingBad_of_encoding_none hrootEncodingNone ⟨position, hrootBad⟩ + exact ⟨position, htarget, + firstLatentEncodingAt_finalOutcome hchain hvalid hintervals hfinite + hstructuralClean hrootClean hrun hlatent⟩ + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingTerminalView.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingTerminalView.lean new file mode 100644 index 00000000..5316685a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingTerminalView.lean @@ -0,0 +1,213 @@ +import SphincsSecurity.Proof.EncodingTerminalLatent +import SphincsSecurity.Proof.EncodingRisk +import SphincsSecurity.Proof.EncodingSelectionLift +import SphincsSecurity.Proof.TerminalView + +/-! +# Encoding chronology in the viewed terminal game + +The generic final-continuation classifier is instantiated with the exact adversary state and verifier run retained by the observational game. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +namespace Concrete + +theorem ViewedEncodingCollisionWitness.encodingBad + {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {result : (Digest × Forgery × Bool) × ViewedFullTraceState} + (hwitness : ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result) : + EncodingBad result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ := by + obtain ⟨f, digest, hf, hvalid, hnovel, hdigest, hadmissible, hcollision⟩ := hwitness + exact hcollision.encodingBad hf + +noncomputable def viewedCleanEncodingRisk + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : ℝ≥0∞ := + open Classical in + if Bad parameter otsSecret ftsSecret result.2.cache then + 0 + else + encodingTotalRiskPotential result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + +theorem probEvent_clean_viewedEncodingCollision_le_expectedRisk + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (oa : ProbComp ((Digest × Forgery × Bool) × ViewedFullTraceState)) : + Pr[fun result => ¬ Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result | oa] ≤ + ∑' result, Pr[= result | oa] * + viewedCleanEncodingRisk parameter otsSecret ftsSecret result := by + classical + rw [probEvent_eq_tsum_ite] + apply ENNReal.tsum_le_tsum + intro result + by_cases hevent : ¬ Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result + · rw [if_pos hevent, viewedCleanEncodingRisk, if_neg hevent.1] + exact le_mul_of_one_le_right bot_le + (one_le_encodingTotalRiskPotential_of_encodingBad hevent.2.encodingBad) + · rw [if_neg hevent] + exact bot_le + +theorem encodingBad_mk_root_iff + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (cache : QueryCache HashSpec) (leftRoot rightRoot : Digest) : + EncodingBad cache ⟨parameter, leftRoot, otsSecret, ftsSecret⟩ ↔ + EncodingBad cache ⟨parameter, rightRoot, otsSecret, ftsSecret⟩ := by + rfl + +theorem probEvent_clean_viewedEncodingCollision_le + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) + (hq : (gameAfterSecrets adversary parameter otsSecret ftsSecret).IsQueryBoundP + (· matches Sum.inr _) q) : + Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + (44 * q : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + let accountingKey : SecretKey := ⟨parameter, default, otsSecret, ftsSecret⟩ + calc + _ ≤ Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + EncodingBad result.2.cache accountingKey | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + apply probEvent_mono + intro result _ hevent + refine ⟨hevent.1, ?_⟩ + exact (encodingBad_mk_root_iff parameter otsSecret ftsSecret result.2.cache + result.1.1 default).mp hevent.2.encodingBad + _ = Pr[fun result : Bool × QueryCache HashSpec => + ¬Bad parameter otsSecret ftsSecret result.2 ∧ EncodingBad result.2 accountingKey | + (fun result => (result.1.2.2, result.2.cache)) <$> + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + rw [probEvent_map] + rfl + _ = Pr[fun result : Bool × QueryCache HashSpec => + ¬Bad parameter otsSecret ftsSecret result.2 ∧ EncodingBad result.2 accountingKey | + (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅] := by + rw [gameAfterSecretsWithViewTrace_verdictCache_projection] + _ ≤ _ := probEvent_clean_encodingBad_simulateQ_le + (gameAfterSecrets adversary parameter otsSecret ftsSecret) q hq accountingKey + +theorem gameAfterSecretsWithViewTrace_encodingBad_finalOutcome + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hmem : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (hfinite : Finite result.2.cache) + (hstructuralClean : ¬ Bad parameter otsSecret ftsSecret result.2.cache) + (hbad : EncodingBad result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩) : + ∃ (adversaryCache : QueryCache HashSpec) (position : EncodingPosition), + HasEncodingTarget result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ position + ∧ FinalLatentEncodingAtOutcome + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ position result.2.trace + adversaryCache result.2.cache := by + rw [gameAfterSecretsWithViewTrace, mem_support_bind_iff] at hmem + obtain ⟨⟨root, rootCache⟩, hroot, hrest⟩ := hmem + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult, hrest, hpureRoot⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpureRoot + subst result + rw [gameRestWithViewTrace, mem_support_bind_iff] at hrest + obtain ⟨⟨forgery, state⟩, hadversary, hfinish⟩ := hrest + rw [mem_support_bind_iff] at hfinish + obtain ⟨⟨⟨verified, targetView⟩, finalCache⟩, hverify, hpure⟩ := hfinish + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst restResult + let publicKey : PublicKey := ⟨root, parameter⟩ + let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + let initialState : ViewedFullTraceState := + ⟨rootCache, ⟨[], [], []⟩, [], none⟩ + have hrootRun : (root, rootCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅) := by + simpa only [simulateQ_romImpl_liftM] using hroot + have hbase : (forgery, state.base) ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState.base) := by + rw [← viewedFullTracedMappedAdversaryImpl_projection secretKey + (adversary.main publicKey) initialState, support_map] + exact ⟨(forgery, state), by simpa only [initialState, publicKey, secretKey] using hadversary, + rfl⟩ + have hchain : FullAdversaryTrace.CacheChain rootCache state.trace.intervals state.cache := + fullTracedMappedAdversaryImpl_cacheChain secretKey (adversary.main publicKey) + rootCache rootCache ⟨[], [], []⟩ (forgery, state.base) (by rfl) hbase + have hvalid : state.trace.ValidIntervals secretKey := + fullTracedMappedAdversaryImpl_validIntervals secretKey (adversary.main publicKey) + rootCache ⟨[], [], []⟩ (forgery, state.base) + (by simp [FullAdversaryTrace.ValidIntervals]) hbase + have hinvariants := fullTracedMappedAdversaryImpl_interval_invariants secretKey + (adversary.main publicKey) rootCache ⟨[], [], []⟩ (forgery, state.base) + (by simp [FullAdversaryTrace.Consistent]) + (by simp [FullAdversaryTrace.IntervalsLe]) + (by simp [FullAdversaryTrace.Chronological]) hbase + have hverifyLe : state.cache ≤ finalCache := + simulateQ_romImpl_cache_le + (liftM (verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView)) + state.cache ((verified, targetView), finalCache) hverify + have hintervals : state.trace.IntervalsLe finalCache := fun entry hentry => + ⟨(hinvariants.2.1 entry hentry).1.trans hverifyLe, + (hinvariants.2.1 entry hentry).2.trans hverifyLe⟩ + have hrootEncodingNone : ∀ (position : EncodingPosition) (payload : HashInput), + rootCache (tweakableHashInput parameter position.domain payload) = none := by + intro position payload + exact treeRoot_cache_encoding_none parameter topLayer rootTree + (otsSecret topLayer rootTree) root rootCache hrootRun position.lay position.tree + position.leafIdx payload + obtain ⟨position, htarget, houtcome⟩ := encodingBad_finalOutcome hchain hvalid + hintervals hfinite hstructuralClean hrootEncodingNone hverify hbad + exact ⟨state.cache, position, htarget, houtcome⟩ + +theorem gameAfterSecretsWithViewTrace_encodingBad_finalOutcome_of_queryBound + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hmem : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (hstructuralClean : ¬ Bad parameter otsSecret ftsSecret result.2.cache) + (hbad : EncodingBad result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩) : + ∃ (adversaryCache : QueryCache HashSpec) (position : EncodingPosition), + HasEncodingTarget result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ position + ∧ FinalLatentEncodingAtOutcome + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ position result.2.trace + adversaryCache result.2.cache := by + have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hmem, rfl⟩ + have hcard : QueryCache.enncard result.2.cache ≤ q := + gameAfterSecretsWithFullTrace_support_enncard_le adversary q hq parameter hparameter + otsSecret hots ftsSecret hfts (result.1, result.2.base) hbase + exact gameAfterSecretsWithViewTrace_encodingBad_finalOutcome adversary parameter otsSecret + ftsSecret result hmem (Finite.of_enncard_le hcard) hstructuralClean hbad + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/EncodingTraceLatent.lean b/formal/sphincs/SphincsSecurity/Proof/EncodingTraceLatent.lean new file mode 100644 index 00000000..0b4bc2fc --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/EncodingTraceLatent.lean @@ -0,0 +1,244 @@ +import SphincsSecurity.Proof.EncodingSignerLatent + +/-! +# First latent encoding interval + +The full adversary trace groups each direct query and each complete signer invocation into one +cache interval. The first interval that creates a latent encoding collision is either one direct +fresh hash query or a signer interval classified by `EncodingSignerLatent`. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +theorem FullAdversaryTrace.CacheChain.exists_first_event_interval + {start finish : QueryCache HashSpec} {intervals : List AdversaryCacheEntry} + (Event : QueryCache HashSpec → Prop) + (hchain : FullAdversaryTrace.CacheChain start intervals finish) + (hclean : ¬ Event start) (hevent : Event finish) : + ∃ position : Fin intervals.length, + ¬ Event (intervals.get position).initialCache + ∧ Event (intervals.get position).finalCache := by + induction intervals generalizing start finish with + | nil => + change finish = start at hchain + exact (hclean (hchain ▸ hevent)).elim + | cons entry rest ih => + obtain ⟨rfl, hrest⟩ := hchain + by_cases hentry : Event entry.finalCache + · exact ⟨⟨0, by simp⟩, by simpa using hclean, by simpa using hentry⟩ + · obtain ⟨position, hpositionClean, hpositionEvent⟩ := + ih hrest hentry hevent + exact ⟨Fin.succ position, by simpa using hpositionClean, + by simpa using hpositionEvent⟩ + +namespace Concrete + +inductive FirstLatentIntervalOutcome + (secretKey : SecretKey) (entry : AdversaryCacheEntry) : Prop where + | direct (input : HashInput) (answer : HashOutput) + (initialCache finalCache : QueryCache HashSpec) + (entryEq : entry = ⟨.inl (.inr input), answer, initialCache, finalCache⟩) + (finalEq : finalCache = initialCache.cacheQuery input answer) + (finiteInitial : Finite initialCache) + (outcome : LatentEncodingStepOutcome initialCache + finiteInitial secretKey input answer) + | signer (request : SignRequest) (result : Option Signature) + (initialCache finalCache : QueryCache HashSpec) + (entryEq : entry = ⟨.inr request, result, initialCache, finalCache⟩) + (outcome : LatentEncodingSignerIntervalOutcome + initialCache finalCache secretKey) + +theorem firstLatentIntervalOutcome + {rootCache adversaryCache finalCache : QueryCache HashSpec} + {secretKey : SecretKey} {trace : FullAdversaryTrace} + (hchain : FullAdversaryTrace.CacheChain rootCache trace.intervals adversaryCache) + (hvalid : trace.ValidIntervals secretKey) + (hintervals : trace.IntervalsLe finalCache) + (hfinite : Finite finalCache) + (hstructuralClean : ¬ Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret finalCache) + (hclean : ¬ LatentEncodingBad rootCache secretKey) + (hbad : LatentEncodingBad adversaryCache secretKey) : + ∃ position : Fin trace.intervals.length, + FirstLatentIntervalOutcome secretKey (trace.intervals.get position) := by + obtain ⟨selected, hselectedClean, hselectedBad⟩ := + hchain.exists_first_event_interval (LatentEncodingBad · secretKey) hclean hbad + let entry := trace.intervals.get selected + have hentry : entry ∈ trace.intervals := List.get_mem _ selected + have hinitialLe : entry.initialCache ≤ finalCache := (hintervals entry hentry).1 + have hfinalLe : entry.finalCache ≤ finalCache := (hintervals entry hentry).2 + have hfiniteInitial : Finite entry.initialCache := hfinite.of_le hinitialLe + have hfiniteFinal : Finite entry.finalCache := hfinite.of_le hfinalLe + have hinitialStructuralClean : ¬ Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret entry.initialCache := by + intro hbadInitial + exact hstructuralClean (Bad.mono secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret hinitialLe hbadInitial) + have hfinalStructuralClean : ¬ Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret entry.finalCache := by + intro hbadFinal + exact hstructuralClean (Bad.mono secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret hfinalLe hbadFinal) + change ¬ LatentEncodingBad entry.initialCache secretKey at hselectedClean + change LatentEncodingBad entry.finalCache secretKey at hselectedBad + refine ⟨selected, ?_⟩ + change FirstLatentIntervalOutcome secretKey entry + obtain ⟨entryInput, entryOutput, initialCache, intervalFinalCache⟩ := entry + cases entryInput with + | inl worldInput => + cases worldInput with + | inl uniformInput => + exfalso + have hrun := hvalid _ hentry + change (entryOutput, intervalFinalCache) ∈ support + ((unifFwdImpl HashSpec uniformInput).run initialCache) at hrun + have hforward : + (unifFwdImpl HashSpec uniformInput).run initialCache = + (fun sample => (sample, initialCache)) <$> + (liftM (unifSpec.query uniformInput) : ProbComp _) := by + simpa [simulateQ_query] using + (unifFwdImpl.simulateQ_run + (hashSpec := HashSpec) + (liftM (unifSpec.query uniformInput) : ProbComp _) initialCache) + rw [hforward, support_map] at hrun + obtain ⟨sample, hsample, heq⟩ := hrun + have hcacheEq : intervalFinalCache = initialCache := + (congrArg Prod.snd heq).symm + exact hselectedClean (hcacheEq ▸ hselectedBad) + | inr input => + change HashOutput at entryOutput + by_cases hcached : initialCache input = none + · have hfinalEq := FullAdversaryTrace.directHashInterval_eq_cacheQuery_of_fresh + hvalid input entryOutput initialCache intervalFinalCache hentry hcached + have hbadStep : LatentEncodingBad + (initialCache.cacheQuery input entryOutput) secretKey := by + rwa [← hfinalEq] + exact .direct input entryOutput initialCache intervalFinalCache rfl hfinalEq + hfiniteInitial + (latentEncodingBad_step_paid_or_provisional hfiniteInitial + hinitialStructuralClean hselectedClean hcached hbadStep) + · obtain ⟨cachedAnswer, hcachedAnswer⟩ := + Option.ne_none_iff_exists'.mp hcached + have hfinalEq := + (FullAdversaryTrace.directHashInterval_eq_of_cached hvalid input + entryOutput cachedAnswer initialCache intervalFinalCache hentry + hcachedAnswer).2 + exact (hselectedClean (hfinalEq ▸ hselectedBad)).elim + | inr request => + change Option Signature at entryOutput + have hrun := hvalid _ hentry + change (entryOutput, intervalFinalCache) ∈ support + ((simulateQ romImpl (sign secretKey request)).run initialCache) at hrun + exact .signer request entryOutput initialCache intervalFinalCache rfl + (latentEncodingBad_signerInterval_paid_or_pinned hfiniteFinal hrun + hfinalStructuralClean hselectedClean hselectedBad) + +inductive FirstLatentAtIntervalOutcome + (secretKey : SecretKey) (position : EncodingPosition) + (entry : AdversaryCacheEntry) : Prop where + | direct (input : HashInput) (answer : HashOutput) + (initialCache finalCache : QueryCache HashSpec) + (entryEq : entry = ⟨.inl (.inr input), answer, initialCache, finalCache⟩) + (finalEq : finalCache = initialCache.cacheQuery input answer) + (finiteInitial : Finite initialCache) + (outcome : LatentEncodingAtStepOutcome initialCache + finiteInitial secretKey input answer position) + | signer (request : SignRequest) (result : Option Signature) + (initialCache finalCache : QueryCache HashSpec) + (entryEq : entry = ⟨.inr request, result, initialCache, finalCache⟩) + (outcome : LatentEncodingAtSignerIntervalOutcome + initialCache finalCache secretKey position) + +theorem firstLatentAtIntervalOutcome + {rootCache adversaryCache finalCache : QueryCache HashSpec} + {secretKey : SecretKey} {trace : FullAdversaryTrace} + {position : EncodingPosition} + (hchain : FullAdversaryTrace.CacheChain rootCache trace.intervals adversaryCache) + (hvalid : trace.ValidIntervals secretKey) + (hintervals : trace.IntervalsLe finalCache) + (hfinite : Finite finalCache) + (hstructuralClean : ¬ Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret finalCache) + (hclean : ¬ LatentEncodingBadAt rootCache secretKey position) + (hbad : LatentEncodingBadAt adversaryCache secretKey position) : + ∃ intervalPosition : Fin trace.intervals.length, + FirstLatentAtIntervalOutcome secretKey position + (trace.intervals.get intervalPosition) := by + obtain ⟨selected, hselectedClean, hselectedBad⟩ := + hchain.exists_first_event_interval + (fun cache => LatentEncodingBadAt cache secretKey position) hclean hbad + let entry := trace.intervals.get selected + have hentry : entry ∈ trace.intervals := List.get_mem _ selected + have hinitialLe : entry.initialCache ≤ finalCache := (hintervals entry hentry).1 + have hfinalLe : entry.finalCache ≤ finalCache := (hintervals entry hentry).2 + have hfiniteInitial : Finite entry.initialCache := hfinite.of_le hinitialLe + have hfiniteFinal : Finite entry.finalCache := hfinite.of_le hfinalLe + have hinitialStructuralClean : ¬ Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret entry.initialCache := by + intro hbadInitial + exact hstructuralClean (Bad.mono secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret hinitialLe hbadInitial) + have hfinalStructuralClean : ¬ Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret entry.finalCache := by + intro hbadFinal + exact hstructuralClean (Bad.mono secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret hfinalLe hbadFinal) + change ¬ LatentEncodingBadAt entry.initialCache secretKey position at hselectedClean + change LatentEncodingBadAt entry.finalCache secretKey position at hselectedBad + refine ⟨selected, ?_⟩ + change FirstLatentAtIntervalOutcome secretKey position entry + obtain ⟨entryInput, entryOutput, initialCache, intervalFinalCache⟩ := entry + cases entryInput with + | inl worldInput => + cases worldInput with + | inl uniformInput => + exfalso + have hrun := hvalid _ hentry + change (entryOutput, intervalFinalCache) ∈ support + ((unifFwdImpl HashSpec uniformInput).run initialCache) at hrun + have hforward : + (unifFwdImpl HashSpec uniformInput).run initialCache = + (fun sample => (sample, initialCache)) <$> + (liftM (unifSpec.query uniformInput) : ProbComp _) := by + simpa [simulateQ_query] using + (unifFwdImpl.simulateQ_run + (hashSpec := HashSpec) + (liftM (unifSpec.query uniformInput) : ProbComp _) initialCache) + rw [hforward, support_map] at hrun + obtain ⟨sample, hsample, heq⟩ := hrun + have hcacheEq : intervalFinalCache = initialCache := + (congrArg Prod.snd heq).symm + exact hselectedClean (hcacheEq ▸ hselectedBad) + | inr input => + change HashOutput at entryOutput + by_cases hcached : initialCache input = none + · have hfinalEq := FullAdversaryTrace.directHashInterval_eq_cacheQuery_of_fresh + hvalid input entryOutput initialCache intervalFinalCache hentry hcached + have hbadStep : LatentEncodingBadAt + (initialCache.cacheQuery input entryOutput) secretKey position := by + rwa [← hfinalEq] + exact .direct input entryOutput initialCache intervalFinalCache rfl hfinalEq + hfiniteInitial + (latentEncodingBadAt_step_paid_or_provisional hfiniteInitial + hinitialStructuralClean hselectedClean hcached hbadStep) + · obtain ⟨cachedAnswer, hcachedAnswer⟩ := + Option.ne_none_iff_exists'.mp hcached + have hfinalEq := + (FullAdversaryTrace.directHashInterval_eq_of_cached hvalid input + entryOutput cachedAnswer initialCache intervalFinalCache hentry + hcachedAnswer).2 + exact (hselectedClean (hfinalEq ▸ hselectedBad)).elim + | inr request => + change Option Signature at entryOutput + have hrun := hvalid _ hentry + change (entryOutput, intervalFinalCache) ∈ support + ((simulateQ romImpl (sign secretKey request)).run initialCache) at hrun + exact .signer request entryOutput initialCache intervalFinalCache rfl + (latentEncodingBadAt_signerInterval_paid_or_pinned hfiniteFinal hrun + hfinalStructuralClean hselectedClean hselectedBad) + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Eval.lean b/formal/sphincs/SphincsSecurity/Proof/Eval.lean new file mode 100644 index 00000000..bd37c498 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Eval.lean @@ -0,0 +1,34 @@ +import SphincsSecurity.Proof.Chain + +/-! +# Evaluating against a fixed answer function + +The random oracle's support is characterized by total answer functions: a value comes out of the +lazy oracle exactly when some `f : QueryImpl HashSpec Id` agreeing with the cache evaluates the +computation to it (`exists_agreesWithFn_evalWithAnswerFn_eq_iff_mem_support`). So every structural +fact this development needs is a fact about `evalWithAnswerFn f`, where `f` answers each input the +same way however often it is asked and in whatever order. + +That is what makes the shape of the algorithms tractable: under `evalWithAnswerFn f` a family of +independent computations may be assembled in any order, which is false at the level of +computations, `sequenceFin` fixing one. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp + +variable {α : Type} (f : QueryImpl HashSpec Id) + +/-- Assembling a family commutes with evaluation. -/ +@[simp] +theorem evalWithAnswerFn_sequenceFin {n : Nat} (computation : Fin n → OracleComp HashSpec α) : + evalWithAnswerFn f (sequenceFin computation) = fun index => evalWithAnswerFn f (computation index) := by + induction n with + | zero => funext index; exact index.elim0 + | succ n ih => + funext index + simp only [sequenceFin, evalWithAnswerFn_bind, evalWithAnswerFn_pure, ih] + cases index using Fin.cases <;> rfl + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/Execution.lean b/formal/sphincs/SphincsSecurity/Proof/Execution.lean new file mode 100644 index 00000000..56f3814d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Execution.lean @@ -0,0 +1,145 @@ +import SphincsSecurity.Proof.Descent +import SphincsSecurity.Proof.Secrets + +/-! +# Winning execution frame + +A winning support point is split into the honest root computation, the adversary and signing run, +and final verification. The final hash-only run supplies one answer function and its cached query +trace for deterministic extraction. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +theorem simulateQ_romImpl_cache_le {alpha : Type} (oa : OracleComp OracleWorld alpha) + (cache : QueryCache HashSpec) (z : alpha × QueryCache HashSpec) + (hmem : z ∈ support ((simulateQ romImpl oa).run cache)) : cache ≤ z.2 := by + apply OracleComp.simulateQ_run_preservesInv romImpl (cache ≤ ·) _ oa cache le_rfl z hmem + intro input current hle result hresult + cases input with + | inl sample => + change result ∈ support (((unifFwdImpl HashSpec) sample).run current) at hresult + have hrun := unifFwdImpl.simulateQ_run + (hashSpec := HashSpec) (liftM (unifSpec.query sample) : ProbComp _) current + simp only [simulateQ_spec_query] at hrun + rw [hrun, support_map] at hresult + obtain ⟨value, _, heq⟩ := hresult + rw [← (Prod.mk.inj heq).2] + exact hle + | inr hashInput => + change result ∈ support + (((randomOracle : QueryImpl HashSpec _) hashInput).run current) at hresult + exact hle.trans (QueryImpl.withCaching_cache_le uniformSampleImpl hashInput current + result hresult) + +namespace Concrete + +theorem winning_support_extract (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (finalCache : QueryCache HashSpec) + (hwin : (true, finalCache) ∈ support ((simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅)) : + ∃ root rootCache forgery signingLog adversaryCache, + (root, rootCache) ∈ support ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅) + ∧ ((forgery, signingLog), adversaryCache) ∈ support + ((simulateQ romImpl + ((simulateQ (forwardOracles + signingOracle scheme + ⟨parameter, root, otsSecret, ftsSecret⟩) + (adversary.main ⟨root, parameter⟩)).run)).run rootCache) + ∧ (true, finalCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (verify ⟨root, parameter⟩ forgery.message forgery.signature)).run adversaryCache) + ∧ SigningTranscript.Valid signingLog + ∧ ¬SigningTranscript.Contains signingLog forgery + ∧ ∃ f : QueryImpl HashSpec Id, finalCache.AgreesWithFn f + ∧ evalWithAnswerFn f (verify ⟨root, parameter⟩ forgery.message forgery.signature) = true + ∧ CachedRun finalCache f + (verify ⟨root, parameter⟩ forgery.message forgery.signature) + ∧ evalWithAnswerFn f + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree)) = root + ∧ CachedRun finalCache f + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree)) + ∧ Settled parameter otsSecret ftsSecret finalCache + (.node topLayer rootTree ⟨layerHeight topLayer - 1, by decide⟩ ⟨0, by positivity⟩) + ∧ ∃ digest : MessageDigest, + evalWithAnswerFn f + (messageDigest parameter root forgery.message forgery.signature.randomness) = digest + ∧ CachedRun finalCache f + (messageDigest parameter root forgery.message forgery.signature.randomness) + ∧ Admissible digest + ∧ let index := digestIndex digest + let leaves := digestLeaves digest + let ftsPublicKey := evalWithAnswerFn f + (ftsRecover parameter index leaves forgery.signature.ftsSecret + forgery.signature.ftsPath) + CachedRun finalCache f + (ftsRecover parameter index leaves forgery.signature.ftsSecret + forgery.signature.ftsPath) + ∧ (Bad parameter otsSecret ftsSecret finalCache ∨ + HypertreeTopOpening f finalCache parameter otsSecret index forgery.signature + ftsPublicKey root) := by + rw [gameAfterSecrets, simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hwin + obtain ⟨⟨root, rootCache⟩, hroot, hrest⟩ := hwin + have hroot' : (root, rootCache) ∈ support ((simulateQ + (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅) := by + simpa only [simulateQ_romImpl_liftM] using hroot + rw [gameRest, simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hrest + obtain ⟨⟨⟨forgery, signingLog⟩, adversaryCache⟩, hadversary, hfinish⟩ := hrest + rw [simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hfinish + obtain ⟨⟨verified, verifyCache⟩, hverify, hreturn⟩ := hfinish + simp only [simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq] at hreturn + obtain ⟨hresult, rfl⟩ := hreturn + have hverified : verified = true := by + cases verified <;> simp_all + subst verified + have htranscript : SigningTranscript.Valid signingLog + ∧ ¬SigningTranscript.Contains signingLog forgery := by + have h := (show (SigningTranscript.Valid signingLog + ∧ ¬SigningTranscript.Contains signingLog forgery) ∧ True by + simpa only [Bool.and_eq_true, decide_eq_true_eq] using hresult.symm) + exact h.1 + have hverify' : (true, finalCache) ∈ support ((simulateQ + (randomOracle : QueryImpl HashSpec _) + (verify ⟨root, parameter⟩ forgery.message forgery.signature)).run adversaryCache) := by + simpa only [scheme, simulateQ_romImpl_liftM] using hverify + obtain ⟨hverifyLe, f, hf, heval, hqueries⟩ := exists_answerFn_replay_of_mem_support + (verify ⟨root, parameter⟩ forgery.message forgery.signature) adversaryCache true finalCache hverify' + have hadversaryLe : rootCache ≤ adversaryCache := simulateQ_romImpl_cache_le + ((simulateQ (forwardOracles + signingOracle scheme + ⟨parameter, root, otsSecret, ftsSecret⟩) + (adversary.main ⟨root, parameter⟩)).run) rootCache _ hadversary + have hrootLe : rootCache ≤ finalCache := hadversaryLe.trans hverifyLe + obtain ⟨hrootEval, hrootQueries⟩ := replay_of_mem_support_of_le + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree)) ∅ root rootCache finalCache + hroot' hrootLe f hf + have hrootRun : CachedRun finalCache f + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree)) := hrootQueries + have hrootSettled := settled_treeRoot_of_cachedRun + (otsSecret := otsSecret) (ftsSecret := ftsSecret) hf topLayer rootTree hrootRun + obtain ⟨digest, hdigest, hdigestRun, hadmissible, hlayers, hftsRun, hlayersRun⟩ := + verify_extract ⟨root, parameter⟩ forgery.message forgery.signature heval hqueries + let index := digestIndex digest + let leaves := digestLeaves digest + let ftsPublicKey := evalWithAnswerFn f + (ftsRecover parameter index leaves forgery.signature.ftsSecret forgery.signature.ftsPath) + have hhypertree : HypertreeRun f finalCache parameter index forgery.signature + ftsPublicKey root := + hypertreeRun_of_verify index forgery.signature ftsPublicKey root hlayers hlayersRun + have htarget : root = honestNode f parameter topLayer rootTree + (otsSecret topLayer rootTree) (layerHeight topLayer) 0 := by + rw [← hrootEval] + rfl + have htop := hypertree_top_extract_or_bad hf index forgery.signature ftsPublicKey root + hhypertree htarget (by simpa using hrootSettled) + exact ⟨root, rootCache, forgery, signingLog, adversaryCache, hroot', hadversary, hverify', + htranscript.1, htranscript.2, f, hf, heval, hqueries, hrootEval, hrootRun, + by simpa using hrootSettled, digest, hdigest, hdigestRun, hadmissible, hftsRun, htop⟩ + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Extract.lean b/formal/sphincs/SphincsSecurity/Proof/Extract.lean new file mode 100644 index 00000000..16e04834 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Extract.lean @@ -0,0 +1,129 @@ +import SphincsSecurity.Proof.Merkle +import SphincsSecurity.Proof.Bytes + +/-! +# Extracting the first divergence + +The deterministic half of the reduction, for one layer's tree. If a fold on values an adversary +supplies reaches the honest node above the leaf, then either every value it supplied was the honest +one, or at some level it hashed something other than the honest payload to the honest value. The +second is what the union bound charges; the first is what makes the adversary's signature the honest +one, and so no forgery. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp + +variable (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) (leaf : LeafIndex) (path : Nat → Digest) + +/-- The value the honest tree carries at a position. -/ +def honestNode (level nodeIdx : Nat) : Digest := + evalWithAnswerFn f (treeNode parameter lay tree secret level nodeIdx) + +/-- What the fold has reached after `levels` steps. -/ +def foldValue (value : Digest) (levels : Nat) : Digest := + evalWithAnswerFn f (treeFold parameter lay tree leaf path levels value) + +/-- Two children in the order the bit dictates. Written with `Bool.rec` rather than `if`, so that +both cases hold by `rfl` and rewriting the bit needs no reasoning about `Decidable` instances. -/ +def orderedPayload (bit : Bool) (current sibling : Digest) : HashInput := + bit.rec (nodePayload current sibling) (nodePayload sibling current) + +@[simp] theorem orderedPayload_false (current sibling : Digest) : + orderedPayload false current sibling = nodePayload current sibling := rfl + +@[simp] theorem orderedPayload_true (current sibling : Digest) : + orderedPayload true current sibling = nodePayload sibling current := rfl + +/-- The payload the fold hashes on its way from `level` to `level + 1`. -/ +def foldPayload (value : Digest) (level : Nat) : HashInput := + orderedPayload (leaf.val.testBit level) + (foldValue f parameter lay tree leaf path value level) (path level) + +theorem eval_tweakableHash (domain : HashDomain) (payload : HashInput) : + evalWithAnswerFn f (tweakableHash parameter domain payload) + = truncateHash (f (tweakableHashInput parameter domain payload)) := by + simp only [tweakableHash, oracleHash, evalWithAnswerFn_bind, evalWithAnswerFn_query, + evalWithAnswerFn_pure] + +theorem honestNode_succ (level nodeIdx : Nat) : + honestNode f parameter lay tree secret (level + 1) nodeIdx + = truncateHash (f (tweakableHashInput parameter (.node lay tree (level + 1) nodeIdx) + (nodePayload (honestNode f parameter lay tree secret level (2 * nodeIdx)) + (honestNode f parameter lay tree secret level (2 * nodeIdx + 1))))) := by + simp only [honestNode, treeNode_succ_eq, evalWithAnswerFn_bind, eval_tweakableHash] + +theorem foldValue_succ (value : Digest) (level : Nat) : + foldValue f parameter lay tree leaf path value (level + 1) + = truncateHash (f (tweakableHashInput parameter + (.node lay tree (level + 1) (leaf.val / 2 ^ (level + 1))) + (foldPayload f parameter lay tree leaf path value level))) := by + simp only [foldValue, foldPayload, treeFold_succ_eq, evalWithAnswerFn_bind, orderedPayload] + cases leaf.val.testBit level <;> rfl + +/-- A hit at a node position: something other than the honest payload hashing to the honest value +there. Domain separation makes the target a function of the position alone, which is what lets the +union bound charge it. -/ +def NodeHit (level nodeIdx : Nat) (payload : HashInput) : Prop := + payload ≠ nodePayload (honestNode f parameter lay tree secret level (2 * nodeIdx)) + (honestNode f parameter lay tree secret level (2 * nodeIdx + 1)) + ∧ truncateHash (f (tweakableHashInput parameter (.node lay tree (level + 1) nodeIdx) payload)) + = honestNode f parameter lay tree secret (level + 1) nodeIdx + +/-- **The first divergence.** A fold that reaches the honest node above the leaf either used the +honest leaf and the honest siblings throughout, or hit a node value somewhere along the way. -/ +theorem treeFold_extract (value : Digest) (levels : Nat) + (hfold : foldValue f parameter lay tree leaf path value levels + = honestNode f parameter lay tree secret levels (leaf.val / 2 ^ levels)) : + (value = honestNode f parameter lay tree secret 0 leaf.val + ∧ ∀ level, level < levels → path level + = honestNode f parameter lay tree secret level (Nat.xor (leaf.val / 2 ^ level) 1)) + ∨ ∃ level, level < levels + ∧ NodeHit f parameter lay tree secret level (leaf.val / 2 ^ (level + 1)) + (foldPayload f parameter lay tree leaf path value level) := by + induction levels with + | zero => + left + refine ⟨?_, fun level hlevel => absurd hlevel (by omega)⟩ + simpa [foldValue] using hfold + | succ levels ih => + obtain ⟨j, hcase⟩ := index_sibling_cases (leaf.val / 2 ^ levels) + have hj : leaf.val / 2 ^ (levels + 1) = j := by + rw [div_pow_succ] + rcases hcase with ⟨hc, _, _⟩ | ⟨hc, _, _⟩ <;> omega + have hhash : truncateHash (f (tweakableHashInput parameter + (.node lay tree (levels + 1) (leaf.val / 2 ^ (levels + 1))) + (foldPayload f parameter lay tree leaf path value levels))) + = honestNode f parameter lay tree secret (levels + 1) (leaf.val / 2 ^ (levels + 1)) := by + rw [← foldValue_succ] + exact hfold + by_cases hagree : foldPayload f parameter lay tree leaf path value levels + = nodePayload (honestNode f parameter lay tree secret levels (2 * j)) + (honestNode f parameter lay tree secret levels (2 * j + 1)) + · have hstep : foldValue f parameter lay tree leaf path value levels + = honestNode f parameter lay tree secret levels (leaf.val / 2 ^ levels) + ∧ path levels = honestNode f parameter lay tree secret levels + (Nat.xor (leaf.val / 2 ^ levels) 1) := by + rw [foldPayload] at hagree + rcases hcase with ⟨hc, hsibling, hmod⟩ | ⟨hc, hsibling, hmod⟩ + · rw [show leaf.val.testBit levels = false by + rw [Bool.eq_false_iff, ne_eq, testBit_iff_div_mod]; omega] at hagree + obtain ⟨hcur, hsib⟩ := nodePayload_injective hagree + exact ⟨by rw [hcur, hc], by rw [hsib, hsibling]⟩ + · rw [show leaf.val.testBit levels = true by + rw [testBit_iff_div_mod]; omega] at hagree + obtain ⟨hsib, hcur⟩ := nodePayload_injective hagree + exact ⟨by rw [hcur, hc], by rw [hsib, hsibling]⟩ + rcases ih hstep.1 with ⟨hvalue, hpaths⟩ | ⟨level, hlevel, hnode⟩ + · left + refine ⟨hvalue, fun level hlevel => ?_⟩ + rcases Nat.lt_succ_iff_lt_or_eq.mp hlevel with hlt | heq + · exact hpaths level hlt + · subst heq; exact hstep.2 + · exact Or.inr ⟨level, by omega, hnode⟩ + · right + exact ⟨levels, by omega, by rw [hj]; exact hagree, hhash⟩ + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/ExtractChain.lean b/formal/sphincs/SphincsSecurity/Proof/ExtractChain.lean new file mode 100644 index 00000000..711ac8b5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/ExtractChain.lean @@ -0,0 +1,75 @@ +import SphincsSecurity.Proof.Extract + +/-! +# Extracting the first divergence in a chain + +The same argument as for a layer's tree, on a hash chain. If walking from a value the adversary +supplied reaches the honest endpoint, then either that value was the honest one at its position, or +somewhere along the walk it hashed something other than the honest predecessor to the honest +successor. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp + +variable (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leaf : LeafIndex) (chainIdx : ChainIndex) (secret : Digest) + +/-- The honest chain value at a position. -/ +def honestChain (position : Nat) : Digest := + evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx 0 position secret) + +/-- What the walk has reached after `steps` steps from `start`. -/ +def walkValue (start : Nat) (value : Digest) (steps : Nat) : Digest := + evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx start steps value) + +theorem honestChain_succ (position : Nat) (hposition : position < chainLength - 1) : + honestChain f parameter lay tree leaf chainIdx secret (position + 1) + = truncateHash (f (tweakableHashInput parameter + (.chain lay tree leaf chainIdx ⟨position, hposition⟩) + (digestBytes (honestChain f parameter lay tree leaf chainIdx secret position)))) := by + simp only [honestChain, chainWalk, evalWithAnswerFn_bind, Nat.zero_add, dif_pos hposition, + eval_tweakableHash] + +theorem walkValue_succ (start : Nat) (value : Digest) (steps : Nat) + (hrange : start + steps < chainLength - 1) : + walkValue f parameter lay tree leaf chainIdx start value (steps + 1) + = truncateHash (f (tweakableHashInput parameter + (.chain lay tree leaf chainIdx ⟨start + steps, hrange⟩) + (digestBytes (walkValue f parameter lay tree leaf chainIdx start value steps)))) := by + simp only [walkValue, chainWalk, evalWithAnswerFn_bind, dif_pos hrange, eval_tweakableHash] + +/-- A hit at a chain step: something other than the honest value at `position` hashing to the honest +value at `position + 1`. -/ +def ChainHit (position : Nat) (hposition : position < chainLength - 1) (payload : Digest) : Prop := + payload ≠ honestChain f parameter lay tree leaf chainIdx secret position + ∧ truncateHash (f (tweakableHashInput parameter + (.chain lay tree leaf chainIdx ⟨position, hposition⟩) (digestBytes payload))) + = honestChain f parameter lay tree leaf chainIdx secret (position + 1) + +/-- **The first divergence in a chain.** -/ +theorem chainWalk_extract (start : Nat) (value : Digest) (steps : Nat) + (hrange : start + steps ≤ chainLength - 1) + (hwalk : walkValue f parameter lay tree leaf chainIdx start value steps + = honestChain f parameter lay tree leaf chainIdx secret (start + steps)) : + value = honestChain f parameter lay tree leaf chainIdx secret start + ∨ ∃ (offset : Nat) (hoffset : start + offset < chainLength - 1), offset < steps + ∧ ChainHit f parameter lay tree leaf chainIdx secret (start + offset) hoffset + (walkValue f parameter lay tree leaf chainIdx start value offset) := by + induction steps with + | zero => + left + simpa [walkValue, chainWalk] using hwalk + | succ steps ih => + have hlt : start + steps < chainLength - 1 := by omega + by_cases hagree : walkValue f parameter lay tree leaf chainIdx start value steps + = honestChain f parameter lay tree leaf chainIdx secret (start + steps) + · rcases ih (by omega) hagree with hvalue | ⟨offset, hoffset, hlt', hhit⟩ + · exact Or.inl hvalue + · exact Or.inr ⟨offset, hoffset, by omega, hhit⟩ + · refine Or.inr ⟨steps, hlt, by omega, hagree, ?_⟩ + rw [← walkValue_succ f parameter lay tree leaf chainIdx start value steps hlt, hwalk, + show start + (steps + 1) = start + steps + 1 by omega] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/ExtractFts.lean b/formal/sphincs/SphincsSecurity/Proof/ExtractFts.lean new file mode 100644 index 00000000..b17ba612 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/ExtractFts.lean @@ -0,0 +1,138 @@ +import SphincsSecurity.Proof.Extract +import SphincsSecurity.Proof.FewTime +import SphincsSecurity.Proof.Code + +/-! +# Extracting a few-time opening + +The tree argument again, on one tree of the few-time forest, and then on the leaf below it. If a fold +on values an adversary supplied reaches the honest root, either it supplied the honest secret and the +honest siblings, or it hit a node, or it hit the leaf. Supplying the honest secret is the only +alternative that is not a hash break, and it means the secret was revealed by a signature: that is +the leak the parameters are chosen against. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp + +variable (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (index : Index) (tree : FtsTree) + (secret : FtsLeaf → Digest) (leaf : FtsLeaf) (path : Fin ftsTreeHeight → Digest) + +/-- The value the honest few-time tree carries at a position. -/ +def honestFtsNode (level nodeIdx : Nat) : Digest := + evalWithAnswerFn f (ftsNode parameter index tree secret level nodeIdx) + +/-- What the fold has reached after `levels` steps. -/ +def ftsFoldValue (value : Digest) (levels : Nat) : Digest := + evalWithAnswerFn f (ftsFold parameter index tree leaf path levels value) + +/-- The sibling the fold reads at a level, `0` past the tree's height. -/ +def ftsSibling (level : Nat) : Digest := + if hlevel : level < ftsTreeHeight then path ⟨level, hlevel⟩ else 0 + +/-- The payload the fold hashes on its way from `level` to `level + 1`. -/ +def ftsFoldPayload (value : Digest) (level : Nat) : HashInput := + orderedPayload (leaf.val.testBit level) + (ftsFoldValue f parameter index tree leaf path value level) (ftsSibling path level) + +theorem honestFtsNode_succ (level nodeIdx : Nat) : + honestFtsNode f parameter index tree secret (level + 1) nodeIdx + = truncateHash (f (tweakableHashInput parameter (.ftsNode index tree (level + 1) nodeIdx) + (nodePayload (honestFtsNode f parameter index tree secret level (2 * nodeIdx)) + (honestFtsNode f parameter index tree secret level (2 * nodeIdx + 1))))) := by + simp only [honestFtsNode, ftsNode_succ_eq, evalWithAnswerFn_bind, eval_tweakableHash] + +theorem honestFtsNode_zero (leafIdx : FtsLeaf) : + honestFtsNode f parameter index tree secret 0 leafIdx.val + = truncateHash (f (tweakableHashInput parameter (.ftsLeaf index tree leafIdx) + (digestBytes (secret leafIdx)))) := by + simp only [honestFtsNode, ftsNode_zero_eq, ftsLeafOfNat_val, ftsLeafHash, eval_tweakableHash] + +theorem ftsFoldValue_succ (value : Digest) (level : Nat) : + ftsFoldValue f parameter index tree leaf path value (level + 1) + = truncateHash (f (tweakableHashInput parameter + (.ftsNode index tree (level + 1) (leaf.val / 2 ^ (level + 1))) + (ftsFoldPayload f parameter index tree leaf path value level))) := by + simp only [ftsFoldValue, ftsFoldPayload, ftsSibling, ftsFold_succ_eq, evalWithAnswerFn_bind, + orderedPayload] + cases leaf.val.testBit level <;> rfl + +/-- A hit at a few-time node. -/ +def FtsNodeHit (level nodeIdx : Nat) (payload : HashInput) : Prop := + payload ≠ nodePayload (honestFtsNode f parameter index tree secret level (2 * nodeIdx)) + (honestFtsNode f parameter index tree secret level (2 * nodeIdx + 1)) + ∧ truncateHash (f (tweakableHashInput parameter (.ftsNode index tree (level + 1) nodeIdx) + payload)) = honestFtsNode f parameter index tree secret (level + 1) nodeIdx + +/-- A hit at a few-time leaf: something other than the honest secret hashing to the honest leaf. -/ +def FtsLeafHit (leafIdx : FtsLeaf) (candidate : Digest) : Prop := + candidate ≠ secret leafIdx + ∧ truncateHash (f (tweakableHashInput parameter (.ftsLeaf index tree leafIdx) + (digestBytes candidate))) = honestFtsNode f parameter index tree secret 0 leafIdx.val + +/-- **The first divergence in a few-time tree.** -/ +theorem ftsFold_extract (value : Digest) (levels : Nat) (hlevels : levels ≤ ftsTreeHeight) + (hfold : ftsFoldValue f parameter index tree leaf path value levels + = honestFtsNode f parameter index tree secret levels (leaf.val / 2 ^ levels)) : + (value = honestFtsNode f parameter index tree secret 0 leaf.val + ∧ ∀ level, level < levels → ftsSibling path level + = honestFtsNode f parameter index tree secret level (Nat.xor (leaf.val / 2 ^ level) 1)) + ∨ ∃ level, level < levels + ∧ FtsNodeHit f parameter index tree secret level (leaf.val / 2 ^ (level + 1)) + (ftsFoldPayload f parameter index tree leaf path value level) := by + induction levels with + | zero => + left + refine ⟨?_, fun level hlevel => absurd hlevel (by omega)⟩ + simpa [ftsFoldValue] using hfold + | succ levels ih => + obtain ⟨j, hcase⟩ := index_sibling_cases (leaf.val / 2 ^ levels) + have hj : leaf.val / 2 ^ (levels + 1) = j := by + rw [div_pow_succ] + rcases hcase with ⟨hc, _, _⟩ | ⟨hc, _, _⟩ <;> omega + have hhash : truncateHash (f (tweakableHashInput parameter + (.ftsNode index tree (levels + 1) (leaf.val / 2 ^ (levels + 1))) + (ftsFoldPayload f parameter index tree leaf path value levels))) + = honestFtsNode f parameter index tree secret (levels + 1) + (leaf.val / 2 ^ (levels + 1)) := by + rw [← ftsFoldValue_succ] + exact hfold + by_cases hagree : ftsFoldPayload f parameter index tree leaf path value levels + = nodePayload (honestFtsNode f parameter index tree secret levels (2 * j)) + (honestFtsNode f parameter index tree secret levels (2 * j + 1)) + · have hstep : ftsFoldValue f parameter index tree leaf path value levels + = honestFtsNode f parameter index tree secret levels (leaf.val / 2 ^ levels) + ∧ ftsSibling path levels = honestFtsNode f parameter index tree secret levels + (Nat.xor (leaf.val / 2 ^ levels) 1) := by + rw [ftsFoldPayload] at hagree + rcases hcase with ⟨hc, hsibling, hmod⟩ | ⟨hc, hsibling, hmod⟩ + · rw [show leaf.val.testBit levels = false by + rw [Bool.eq_false_iff, ne_eq, testBit_iff_div_mod]; omega] at hagree + obtain ⟨hcur, hsib⟩ := nodePayload_injective hagree + exact ⟨by rw [hcur, hc], by rw [hsib, hsibling]⟩ + · rw [show leaf.val.testBit levels = true by + rw [testBit_iff_div_mod]; omega] at hagree + obtain ⟨hsib, hcur⟩ := nodePayload_injective hagree + exact ⟨by rw [hcur, hc], by rw [hsib, hsibling]⟩ + rcases ih (by omega) hstep.1 with ⟨hvalue, hpaths⟩ | ⟨level, hlevel, hnode⟩ + · left + refine ⟨hvalue, fun level hlevel => ?_⟩ + rcases Nat.lt_succ_iff_lt_or_eq.mp hlevel with hlt | heq + · exact hpaths level hlt + · subst heq; exact hstep.2 + · exact Or.inr ⟨level, by omega, hnode⟩ + · right + exact ⟨levels, by omega, by rw [hj]; exact hagree, hhash⟩ + +/-- **The few-time leaf.** The value the fold starts from is the hash of a secret the adversary +supplied, so either that secret is the honest one or the leaf was hit. -/ +theorem ftsLeaf_extract (candidate : Digest) + (hleaf : truncateHash (f (tweakableHashInput parameter (.ftsLeaf index tree leaf) + (digestBytes candidate))) = honestFtsNode f parameter index tree secret 0 leaf.val) : + candidate = secret leaf ∨ FtsLeafHit f parameter index tree secret leaf candidate := by + by_cases hsecret : candidate = secret leaf + · exact Or.inl hsecret + · exact Or.inr ⟨hsecret, hleaf⟩ + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/ExtractOts.lean b/formal/sphincs/SphincsSecurity/Proof/ExtractOts.lean new file mode 100644 index 00000000..6be21163 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/ExtractOts.lean @@ -0,0 +1,106 @@ +import SphincsSecurity.Proof.ExtractChain +import SphincsSecurity.Proof.Layer +import SphincsSecurity.Proof.Code + +/-! +# Extracting a one-time signature + +If the verifier's half of a one-time signature returns the honest leaf, then either the chain values +the adversary supplied are the honest ones at its codeword's positions, or it hit the leaf value, or +it hit a chain value. The first alternative is what the incomparability of the code turns into "the +signature is the one the signer produced". +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp + +variable (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) (leaf : LeafIndex) + +/-- The honest one-time public values at a leaf. -/ +def honestEndpoints (chainIdx : ChainIndex) : Digest := + honestChain f parameter lay tree leaf chainIdx (secret leaf chainIdx) (chainLength - 1) + +theorem honestEndpoints_def : honestEndpoints f parameter lay tree secret leaf + = fun chainIdx => evalWithAnswerFn f + (chainWalk parameter lay tree leaf chainIdx 0 (chainLength - 1) (secret leaf chainIdx)) := + rfl + +/-- A hit at a leaf: something other than the honest endpoints hashing to the honest leaf. -/ +def LeafHit (payload : HashInput) : Prop := + payload ≠ leafPayload (honestEndpoints f parameter lay tree secret leaf) + ∧ truncateHash (f (tweakableHashInput parameter (.leaf lay tree leaf) payload)) + = honestNode f parameter lay tree secret 0 leaf.val + +theorem honestNode_zero_eq_leafHash : + honestNode f parameter lay tree secret 0 leaf.val + = truncateHash (f (tweakableHashInput parameter (.leaf lay tree leaf) + (leafPayload (honestEndpoints f parameter lay tree secret leaf)))) := by + simp only [honestNode, treeNode_zero_eq, leafOfNat_val, evalWithAnswerFn_bind, leafHash, + eval_tweakableHash, eval_oneTimePublicKey, honestEndpoints_def] + +/-- **The one-time signature.** -/ +theorem otsLeaf_extract (message : Digest) (counter : Counter) (values : ChainIndex → Digest) + (codeword : Encoding) + (hencode : evalWithAnswerFn f (encode parameter lay tree leaf message counter) = some codeword) + (hleaf : evalWithAnswerFn f (otsLeaf parameter lay tree leaf message counter values) + = some (honestNode f parameter lay tree secret 0 leaf.val)) : + (∀ chainIdx, values chainIdx + = honestChain f parameter lay tree leaf chainIdx (secret leaf chainIdx) + (codeword chainIdx).val) + ∨ LeafHit f parameter lay tree secret leaf + (leafPayload fun chainIdx => walkValue f parameter lay tree leaf chainIdx + (codeword chainIdx).val (values chainIdx) (chainLength - 1 - (codeword chainIdx).val)) + ∨ ∃ (chainIdx : ChainIndex) (offset : Nat) + (hoffset : (codeword chainIdx).val + offset < chainLength - 1), offset < chainLength - 1 + - (codeword chainIdx).val + ∧ ChainHit f parameter lay tree leaf chainIdx (secret leaf chainIdx) + ((codeword chainIdx).val + offset) hoffset + (walkValue f parameter lay tree leaf chainIdx (codeword chainIdx).val + (values chainIdx) offset) := by + classical + have hrecovered : evalWithAnswerFn f (leafHash parameter lay tree leaf + (fun chainIdx => walkValue f parameter lay tree leaf chainIdx (codeword chainIdx).val + (values chainIdx) (chainLength - 1 - (codeword chainIdx).val))) + = honestNode f parameter lay tree secret 0 leaf.val := by + simp only [otsLeaf, evalWithAnswerFn_bind, evalWithAnswerFn_pure, hencode, + evalWithAnswerFn_sequenceFin] at hleaf + simpa [walkValue, recoverChain] using hleaf + by_cases hpayload : (leafPayload fun chainIdx => walkValue f parameter lay tree leaf chainIdx + (codeword chainIdx).val (values chainIdx) (chainLength - 1 - (codeword chainIdx).val)) + = leafPayload (honestEndpoints f parameter lay tree secret leaf) + · have hendpoints := TargetSum.leafPayload_injective hpayload + have hchains : ∀ chainIdx : ChainIndex, + values chainIdx = honestChain f parameter lay tree leaf chainIdx (secret leaf chainIdx) + (codeword chainIdx).val + ∨ ∃ (offset : Nat) (hoffset : (codeword chainIdx).val + offset < chainLength - 1), + offset < chainLength - 1 - (codeword chainIdx).val + ∧ ChainHit f parameter lay tree leaf chainIdx (secret leaf chainIdx) + ((codeword chainIdx).val + offset) hoffset + (walkValue f parameter lay tree leaf chainIdx (codeword chainIdx).val + (values chainIdx) offset) := by + intro chainIdx + have hdigit : (codeword chainIdx).val ≤ chainLength - 1 := by + have := (codeword chainIdx).isLt + simp only [chainLength, winternitzBits] at this ⊢ + omega + refine chainWalk_extract f parameter lay tree leaf chainIdx (secret leaf chainIdx) + (codeword chainIdx).val (values chainIdx) (chainLength - 1 - (codeword chainIdx).val) + (by omega) ?_ + have := congrFun hendpoints chainIdx + rw [show (codeword chainIdx).val + (chainLength - 1 - (codeword chainIdx).val) + = chainLength - 1 by omega] + exact this + by_cases hall : ∀ chainIdx, values chainIdx + = honestChain f parameter lay tree leaf chainIdx (secret leaf chainIdx) + (codeword chainIdx).val + · exact Or.inl hall + · obtain ⟨chainIdx, hne⟩ := not_forall.mp hall + rcases hchains chainIdx with hhonest | ⟨offset, hoffset, hlt, hhit⟩ + · exact absurd hhonest hne + · exact Or.inr (Or.inr ⟨chainIdx, offset, hoffset, hlt, hhit⟩) + · exact Or.inr (Or.inl ⟨hpayload, by + rw [← hrecovered, leafHash, eval_tweakableHash]⟩) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTime.lean b/formal/sphincs/SphincsSecurity/Proof/FewTime.lean new file mode 100644 index 00000000..e13692eb --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTime.lean @@ -0,0 +1,69 @@ +import SphincsSecurity.Proof.Merkle + +/-! +# The few-time signature + +`Fts.recover` on an opening of the leaves the digest chooses reproduces `Fts.key`: each tree folds +back to its root, and the roots are hashed the same way on both sides. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp + +variable (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (index : Index) + +theorem ftsLeafOfNat_val (leaf : FtsLeaf) : ftsLeafOfNat leaf.val = leaf := by + ext + simp [ftsLeafOfNat, Nat.mod_eq_of_lt leaf.isLt] + +/-- **Few-time tree correctness.** Folding an opened leaf with its siblings reproduces the tree. -/ +theorem eval_ftsFold (tree : FtsTree) (secret : FtsLeaf → Digest) (leaf : FtsLeaf) (levels : Nat) + (hlevels : levels ≤ ftsTreeHeight) : + evalWithAnswerFn f (ftsFold parameter index tree leaf + (fun level => evalWithAnswerFn f (ftsNode parameter index tree secret level.val + (Nat.xor (leaf.val / 2 ^ level.val) 1))) levels + (evalWithAnswerFn f (ftsLeafHash parameter index tree leaf (secret leaf)))) + = evalWithAnswerFn f (ftsNode parameter index tree secret levels (leaf.val / 2 ^ levels)) := by + induction levels with + | zero => simp [ftsLeafOfNat_val] + | succ levels ih => + obtain ⟨j, hcase⟩ := index_sibling_cases (leaf.val / 2 ^ levels) + have hj : leaf.val / 2 ^ (levels + 1) = j := by + rw [div_pow_succ] + rcases hcase with ⟨hc, _, _⟩ | ⟨hc, _, _⟩ <;> omega + have hlevel : levels < ftsTreeHeight := by omega + rw [ftsFold_succ_eq, ftsNode_succ_eq, evalWithAnswerFn_bind, ih (by omega), hj, + evalWithAnswerFn_bind, evalWithAnswerFn_bind] + rcases hcase with ⟨hc, hsibling, hmod⟩ | ⟨hc, hsibling, hmod⟩ + · have hbit : leaf.val.testBit levels = false := by + rw [Bool.eq_false_iff, ne_eq, testBit_iff_div_mod]; omega + rw [hbit, if_neg (by simp), hc] + simp only [dif_pos hlevel, hsibling] + · have hbit : leaf.val.testBit levels = true := by + rw [testBit_iff_div_mod]; omega + rw [hbit, if_pos rfl, hc] + simp only [dif_pos hlevel, hsibling] + +/-- **Few-time correctness.** The opening a signature carries recovers the few-time public key. -/ +theorem eval_ftsRecover (leaves : DigestTree → FtsLeaf) (secret : FtsTree → FtsLeaf → Digest) : + evalWithAnswerFn f (ftsRecover parameter index leaves + (fun tree => secret tree (leaves (ftsIndexOf tree))) + (evalWithAnswerFn f (ftsOpen parameter index leaves secret))) + = evalWithAnswerFn f (ftsKey parameter index secret) := by + have hroot : ∀ leaf : FtsLeaf, leaf.val / 2 ^ ftsTreeHeight = 0 := fun leaf => + Nat.div_eq_of_lt leaf.isLt + have hfold : ∀ tree : FtsTree, + evalWithAnswerFn f (ftsFold parameter index tree (leaves (ftsIndexOf tree)) + (fun level => evalWithAnswerFn f (ftsNode parameter index tree (secret tree) level.val + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1))) ftsTreeHeight + (evalWithAnswerFn f (ftsLeafHash parameter index tree (leaves (ftsIndexOf tree)) + (secret tree (leaves (ftsIndexOf tree)))))) + = evalWithAnswerFn f (ftsNode parameter index tree (secret tree) ftsTreeHeight 0) := by + intro tree + rw [eval_ftsFold f parameter index tree (secret tree) (leaves (ftsIndexOf tree)) ftsTreeHeight + (le_refl _), hroot] + simp only [ftsRecover, ftsKey, ftsOpen, evalWithAnswerFn_bind, evalWithAnswerFn_sequenceFin, + hfold] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTime125Count.lean b/formal/sphincs/SphincsSecurity/Proof/FewTime125Count.lean new file mode 100644 index 00000000..037031cb --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTime125Count.lean @@ -0,0 +1,243 @@ +import SphincsSecurity.Proof.FewTimeOriginSampler + +/-! Weighted forest-pattern counting for budgets up to `2^125`. The bound retains the number of selected signatures in each origin weight. -/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +set_option exponentiation.threshold 600 + +theorem weightedFewTime125_scaled_certificate : + (∑ d ∈ Finset.Icc 1 14, + (d + 1).ascFactorial (14 - d) * 2 ^ (24 * d) * d ^ 14 * + 5 ^ d * 2 ^ (28 * (14 - d))) ≤ Nat.factorial 14 * 2 ^ 411 := by + decide + +theorem weightedFewTime125_scaled_sum_le {signatures : Nat} + (hsignatures : signatures ≤ signatureLimit) : + Nat.factorial 14 * (∑ d ∈ Finset.Icc 1 14, + Fintype.card (FewTimePattern signatures d) * 5 ^ d * 2 ^ (28 * (14 - d))) ≤ + Nat.factorial 14 * 2 ^ 411 := by + rw [Finset.mul_sum] + apply le_trans (Finset.sum_le_sum fun d hd => ?_) weightedFewTime125_scaled_certificate + have hd14 := (Finset.mem_Icc.mp hd).2 + have hfactorial := Nat.factorial_mul_ascFactorial d (14 - d) + rw [Nat.add_sub_of_le hd14] at hfactorial + calc + _ = (d + 1).ascFactorial (14 - d) * + (Nat.factorial d * Fintype.card (FewTimePattern signatures d)) * + 5 ^ d * 2 ^ (28 * (14 - d)) := by rw [← hfactorial]; ring + _ ≤ (d + 1).ascFactorial (14 - d) * + (2 ^ (24 * d) * d ^ (ftsTrees - 1)) * 5 ^ d * 2 ^ (28 * (14 - d)) := by + exact Nat.mul_le_mul_right _ (Nat.mul_le_mul_right _ (Nat.mul_le_mul_left _ + (fewTimePattern_card_scaled_le_signatureLimit hsignatures))) + _ = _ := by rw [show ftsTrees - 1 = 14 by rfl]; ring + +theorem FewTimePattern.originChoiceMass_le_five_fourths_pow + {signatures distinct q : Nat} (pattern : FewTimePattern signatures distinct) + (hq : q ≤ 2 ^ 125) : + originChoiceMass pattern.selected q ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ≤ + (5 / 4 : ℝ≥0∞) ^ distinct := by + calc + _ ≤ (1 + q * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹) ^ + Fintype.card pattern.selected := originChoiceMass_le _ _ _ + _ = (1 + q * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹) ^ distinct := by + rw [Fintype.card_coe, pattern.card_selected] + _ ≤ _ := by + gcongr + calc + _ ≤ 1 + ((2 ^ 125 : Nat) : ℝ≥0∞) * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ := by + gcongr + _ = 5 / 4 := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_div, + ENNReal.toReal_natCast, ENNReal.toReal_ofNat] + norm_num + +theorem weightedFewTime125_term_common_denominator (signatures d : Nat) + (hd : d ≤ 14) : + (Fintype.card (FewTimePattern signatures d) : ℝ≥0∞) * (5 / 4 : ℝ≥0∞) ^ d * + ((2 ^ (26 * d + 140) : Nat) : ℝ≥0∞)⁻¹ = + (Fintype.card (FewTimePattern signatures d) * 5 ^ d * 2 ^ (28 * (14 - d)) : Nat) * + ((2 ^ 532 : Nat) : ℝ≥0∞)⁻¹ := by + have hden : (4 : ℝ≥0∞) ^ d * ((2 ^ (26 * d + 140) : Nat) : ℝ≥0∞) = + ((2 ^ (28 * d + 140) : Nat) : ℝ≥0∞) := by + simp only [Nat.cast_pow, Nat.cast_ofNat] + rw [show (4 : ℝ≥0∞) = 2 ^ 2 by norm_num, ← pow_mul, ← pow_add] + congr 1 + omega + have hbase : (Fintype.card (FewTimePattern signatures d) : ℝ≥0∞) * (5 / 4 : ℝ≥0∞) ^ d * + ((2 ^ (26 * d + 140) : Nat) : ℝ≥0∞)⁻¹ = + (Fintype.card (FewTimePattern signatures d) * 5 ^ d : Nat) / + ((2 ^ (28 * d + 140) : Nat) : ℝ≥0∞) := by + rw [div_eq_mul_inv, mul_pow] + rw [div_eq_mul_inv, ← hden, ENNReal.mul_inv (by left; positivity) (by right; finiteness)] + simp only [ENNReal.inv_pow, Nat.cast_mul, Nat.cast_pow, Nat.cast_ofNat] + ring + rw [hbase, ← div_eq_mul_inv] + let factor : ℝ≥0∞ := (2 ^ (28 * (14 - d)) : Nat) + have hz : factor ≠ 0 := by positivity + have ht : factor ≠ ∞ := by simp [factor] + rw [← ENNReal.mul_div_mul_right + (Fintype.card (FewTimePattern signatures d) * 5 ^ d : Nat) + ((2 ^ (28 * d + 140) : Nat) : ℝ≥0∞) hz ht] + congr 1 + · simp [factor, Nat.cast_mul] + · dsimp [factor] + rw [← Nat.cast_mul, ← pow_add, show 28 * d + 140 + 28 * (14 - d) = 532 by omega] + norm_num + +theorem weightedFewTimePatternBound_le_inv121_of_queries_le125 {signatures q : Nat} + (hsignatures : signatures ≤ signatureLimit) (hq : q ≤ 2 ^ 125) : + weightedFewTimePatternBound signatures q ≤ ((2 ^ 121 : Nat) : ℝ≥0∞)⁻¹ := by + classical + calc + _ ≤ ∑ d ∈ Finset.Icc 1 14, ∑ _pattern : FewTimePattern signatures d, + (5 / 4 : ℝ≥0∞) ^ d * ((2 ^ (26 * d + 140) : Nat) : ℝ≥0∞)⁻¹ := by + apply Finset.sum_le_sum + intro d hd + apply Finset.sum_le_sum + intro pattern _ + gcongr + exact pattern.originChoiceMass_le_five_fourths_pow hq + _ = ∑ d ∈ Finset.Icc 1 14, + (Fintype.card (FewTimePattern signatures d) * 5 ^ d * 2 ^ (28 * (14 - d)) : Nat) * + ((2 ^ 532 : Nat) : ℝ≥0∞)⁻¹ := by + simp only [Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + apply Finset.sum_congr rfl + intro d hd + rw [← mul_assoc] + exact weightedFewTime125_term_common_denominator signatures d (Finset.mem_Icc.mp hd).2 + _ = ((∑ d ∈ Finset.Icc 1 14, + Fintype.card (FewTimePattern signatures d) * 5 ^ d * 2 ^ (28 * (14 - d)) : Nat) : ℝ≥0∞) * + ((2 ^ 532 : Nat) : ℝ≥0∞)⁻¹ := by rw [← Finset.sum_mul, Nat.cast_sum] + _ ≤ ((2 ^ 411 : Nat) : ℝ≥0∞) * ((2 ^ 532 : Nat) : ℝ≥0∞)⁻¹ := by + gcongr + exact_mod_cast Nat.le_of_mul_le_mul_left (weightedFewTime125_scaled_sum_le hsignatures) + (Nat.factorial_pos 14) + _ = _ := by + rw [show 532 = 411 + 121 by decide, pow_add, Nat.cast_mul, + ENNReal.mul_inv (by left; positivity) (by right; simp), ← mul_assoc, + ENNReal.mul_inv_cancel (by positivity) (by simp), one_mul] + +theorem idealOriginUnionBound_le_inv121_of_queries_le125 {signatures q : Nat} + (hsignatures : signatures ≤ signatureLimit) (hq : q ≤ 2 ^ 125) : + idealOriginUnionBound signatures q ≤ ((2 ^ 121 : Nat) : ℝ≥0∞)⁻¹ := by + rw [idealOriginUnionBound_eq_weightedFewTimePatternBound] + exact weightedFewTimePatternBound_le_inv121_of_queries_le125 hsignatures hq + +abbrev OriginConfiguration.RawTargetSample {signatures distinct : Nat} + {pattern : FewTimePattern signatures distinct} {sources : Nat} + (configuration : OriginConfiguration pattern sources) := + ((pattern.selected → FewTimeView) × HashOutput) × BitVec (127 * configuration.prehit.card) + +def OriginConfiguration.RawTargetHit {signatures distinct : Nat} + {pattern : FewTimePattern signatures distinct} {sources : Nat} + (configuration : OriginConfiguration pattern sources) + (sample : configuration.RawTargetSample) : Prop := + (signAttemptResultOfOutput sample.1.2 ≠ none ∧ + FixedFewTimePatternHit pattern.assignment (sample.1.1, hashOutputFewTimeView sample.1.2)) ∧ + sample.2 = 0 + +theorem probEvent_rawTargetPatternHit_eq_admissible_mul + {Selected : Type} [Fintype Selected] [DecidableEq Selected] [Nonempty Selected] + (assignment : FtsTree → Selected) : + Pr[fun sample : (Selected → FewTimeView) × HashOutput => + signAttemptResultOfOutput sample.2 ≠ none ∧ + FixedFewTimePatternHit assignment (sample.1, hashOutputFewTimeView sample.2) | + ($ᵗ ((Selected → FewTimeView) × HashOutput) : ProbComp _)] = + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + Pr[FixedFewTimePatternHit assignment | + ($ᵗ ((Selected → FewTimeView) × FewTimeView) : ProbComp _)] := by + let rawEvent := fun sample : (Selected → FewTimeView) × HashOutput => + signAttemptResultOfOutput sample.2 ≠ none ∧ + FixedFewTimePatternHit assignment (sample.1, hashOutputFewTimeView sample.2) + have hraw : Pr[rawEvent | ($ᵗ ((Selected → FewTimeView) × HashOutput) : ProbComp _)] = + Pr[rawEvent | (($ᵗ (Selected → FewTimeView) : ProbComp _) >>= fun views => + Prod.mk views <$> ($ᵗ HashOutput : ProbComp _))] := by + apply probEvent_congr' (fun _ _ => Iff.rfl) + simpa only [map_eq_bind_pure_comp, Function.comp_apply, evalDist_bind, evalDist_pure, evalDist_uniformSample] using + (evalDist_independent_uniform_pair (α := Selected → FewTimeView) (β := HashOutput)).symm + have hviews : Pr[FixedFewTimePatternHit assignment | + ($ᵗ ((Selected → FewTimeView) × FewTimeView) : ProbComp _)] = + Pr[FixedFewTimePatternHit assignment | + (($ᵗ (Selected → FewTimeView) : ProbComp _) >>= fun views => + Prod.mk views <$> ($ᵗ FewTimeView : ProbComp _))] := by + apply probEvent_congr' (fun _ _ => Iff.rfl) + simpa only [map_eq_bind_pure_comp, Function.comp_apply, evalDist_bind, evalDist_pure, evalDist_uniformSample] using + (evalDist_independent_uniform_pair (α := Selected → FewTimeView) (β := FewTimeView)).symm + change Pr[rawEvent | _] = _ + rw [hraw, hviews] + dsimp only [rawEvent] + rw [probEvent_bind_eq_tsum, probEvent_bind_eq_tsum] + simp only [probEvent_map, Function.comp_def] + rw [← ENNReal.tsum_mul_left] + apply tsum_congr + intro views + have hview := probEvent_uniformHashOutput_admissible_view + (fun target => FixedFewTimePatternHit assignment (views, target)) + simp only [probEvent_uniformSample] at hview ⊢ + rw [hview] + ring + +theorem probEvent_originConfiguration_rawTargetHit + {signatures distinct : Nat} {pattern : FewTimePattern signatures distinct} {sources : Nat} + (configuration : OriginConfiguration pattern sources) : + Pr[configuration.RawTargetHit | + ($ᵗ configuration.RawTargetSample : ProbComp configuration.RawTargetSample)] = + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + Pr[configuration.Hit | ($ᵗ configuration.Sample : ProbComp configuration.Sample)] := by + classical + letI : Nonempty pattern.selected := ⟨pattern.assignment ⟨0, by decide⟩⟩ + have hraw : Pr[configuration.RawTargetHit | + ($ᵗ configuration.RawTargetSample : ProbComp configuration.RawTargetSample)] = + Pr[fun sample : (pattern.selected → FewTimeView) × HashOutput => + signAttemptResultOfOutput sample.2 ≠ none ∧ + FixedFewTimePatternHit pattern.assignment (sample.1, hashOutputFewTimeView sample.2) | + ($ᵗ ((pattern.selected → FewTimeView) × HashOutput) : ProbComp _)] * + Pr[fun value : BitVec (127 * configuration.prehit.card) => value = 0 | + ($ᵗ BitVec (127 * configuration.prehit.card) : ProbComp _)] := by + apply probEvent_seq_map_eq_mul + intro _ _ _ _ + rfl + have hideal : Pr[configuration.Hit | ($ᵗ configuration.Sample : ProbComp configuration.Sample)] = + Pr[FixedFewTimePatternHit pattern.assignment | + ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : ProbComp _)] * + Pr[fun value : BitVec (127 * configuration.prehit.card) => value = 0 | + ($ᵗ BitVec (127 * configuration.prehit.card) : ProbComp _)] := by + apply probEvent_seq_map_eq_mul + intro _ _ _ _ + rfl + rw [hraw, hideal] + have hpattern := probEvent_rawTargetPatternHit_eq_admissible_mul pattern.assignment + simp only [probEvent_uniformSample] at hpattern ⊢ + rw [hpattern, mul_assoc] + +noncomputable def rawTargetOriginUnionBound (signatures sources : Nat) : ℝ≥0∞ := + ∑ distinct ∈ Finset.Icc 1 14, + ∑ pattern : FewTimePattern signatures distinct, + ∑ configuration : OriginConfiguration pattern sources, + Pr[configuration.RawTargetHit | + ($ᵗ configuration.RawTargetSample : ProbComp configuration.RawTargetSample)] + +theorem rawTargetOriginUnionBound_eq (signatures sources : Nat) : + rawTargetOriginUnionBound signatures sources = + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * idealOriginUnionBound signatures sources := by + classical + unfold rawTargetOriginUnionBound idealOriginUnionBound + simp_rw [probEvent_originConfiguration_rawTargetHit, ← Finset.mul_sum] + +theorem rawTargetOriginUnionBound_le_inv131 {signatures q : Nat} + (hsignatures : signatures ≤ signatureLimit) (hq : q ≤ 2 ^ 125) : + rawTargetOriginUnionBound signatures q ≤ ((2 ^ 131 : Nat) : ℝ≥0∞)⁻¹ := by + rw [rawTargetOriginUnionBound_eq] + calc + _ ≤ ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * ((2 ^ 121 : Nat) : ℝ≥0∞)⁻¹ := + mul_le_mul_right (idealOriginUnionBound_le_inv121_of_queries_le125 hsignatures hq) _ + _ = _ := by + rw [← ENNReal.mul_inv (by left; positivity) (by right; simp), ← Nat.cast_mul, + ← pow_add, show ftsTreeHeight + 121 = 131 by rfl] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTime126Bound.lean b/formal/sphincs/SphincsSecurity/Proof/FewTime126Bound.lean new file mode 100644 index 00000000..3d402f61 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTime126Bound.lean @@ -0,0 +1,62 @@ +import SphincsSecurity.Proof.FewTime126Count +import SphincsSecurity.Proof.FewTimeHonestLeakBound +import SphincsSecurity.Proof.MandatoryQueries + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem probEvent_gameAfterSecretsWithViewTrace_honest_leak_le_twenty_seven_mul_inv133 + (adversary : Adversary) (q : Nat) (hqPos : 1 ≤ q) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + ((27 * q : Nat) : ℝ≥0∞) * ((2 ^ 133 : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ ≤ q * rawTargetOriginUnionBound signatureLimit q + + ((q + 1 : Nat) : ℝ≥0∞) * rawTargetOriginUnionBound signatureLimit q := + probEvent_gameAfterSecretsWithViewTrace_honest_leak_le adversary q hq hqMax + parameter hparameter otsSecret hots ftsSecret hfts + _ = ((2 * q + 1 : Nat) : ℝ≥0∞) * rawTargetOriginUnionBound signatureLimit q := by + push_cast + ring + _ ≤ ((3 * q : Nat) : ℝ≥0∞) * (9 * ((2 ^ 133 : Nat) : ℝ≥0∞)⁻¹) := by + apply mul_le_mul' + · exact_mod_cast (show 2 * q + 1 ≤ 3 * q by omega) + · exact rawTargetOriginUnionBound_le_nine_mul_inv133 le_rfl hqMax + _ = _ := by push_cast; ring + +theorem probEvent_gameAfterSecretsWithViewTrace_honest_leak_le_nineteen_mul_inv133 + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + ((19 * q : Nat) : ℝ≥0∞) * ((2 ^ 133 : Nat) : ℝ≥0∞)⁻¹ := by + have hminimum := numChains_le_of_hasHashQueryBound adversary q hq parameter hparameter otsSecret hots ftsSecret hfts + norm_num [numChains] at hminimum + calc + _ ≤ q * rawTargetOriginUnionBound signatureLimit q + + ((q + 1 : Nat) : ℝ≥0∞) * rawTargetOriginUnionBound signatureLimit q := + probEvent_gameAfterSecretsWithViewTrace_honest_leak_le adversary q hq hqMax + parameter hparameter otsSecret hots ftsSecret hfts + _ = ((2 * q + 1 : Nat) : ℝ≥0∞) * rawTargetOriginUnionBound signatureLimit q := by + push_cast + ring + _ ≤ ((2 * q + 1 : Nat) : ℝ≥0∞) * (9 * ((2 ^ 133 : Nat) : ℝ≥0∞)⁻¹) := + mul_le_mul' le_rfl (rawTargetOriginUnionBound_le_nine_mul_inv133 le_rfl hqMax) + _ = (((2 * q + 1) * 9 : Nat) : ℝ≥0∞) * ((2 ^ 133 : Nat) : ℝ≥0∞)⁻¹ := by + push_cast + ring + _ ≤ _ := mul_le_mul' (Nat.cast_le.mpr (by omega)) le_rfl + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTime126Count.lean b/formal/sphincs/SphincsSecurity/Proof/FewTime126Count.lean new file mode 100644 index 00000000..9d700afe --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTime126Count.lean @@ -0,0 +1,52 @@ +import SphincsSecurity.Proof.FewTimeParametricCount + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +set_option exponentiation.threshold 600 + +theorem weightedFewTime126_scaled_certificate : + (∑ d ∈ Finset.Icc 1 14, + (d + 1).ascFactorial (14 - d) * 2 ^ (24 * d) * d ^ 14 * + 3 ^ d * 2 ^ (27 * (14 - d))) ≤ Nat.factorial 14 * (9 * 2 ^ 395) := by + decide + +theorem weightedFewTimePatternBound_le_nine_mul_inv123_of_queries_le126 + {signatures q : Nat} (hsignatures : signatures ≤ signatureLimit) (hq : q ≤ 2 ^ 126) : + weightedFewTimePatternBound signatures q ≤ 9 * ((2 ^ 123 : Nat) : ℝ≥0∞)⁻¹ := by + have hweight : 1 + (q : ℝ≥0∞) * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ≤ (3 : ℝ≥0∞) / 2 ^ 1 := by + calc + _ ≤ 1 + ((2 ^ 126 : Nat) : ℝ≥0∞) * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ := by gcongr + _ ≤ _ := by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_natCast, + ENNReal.toReal_div, ENNReal.toReal_pow, ENNReal.toReal_ofNat, ENNReal.toReal_one] + norm_num + apply (weightedFewTimePatternBound_le_of_origin_weight hsignatures hweight + weightedFewTime126_scaled_certificate).trans_eq + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_natCast, + ENNReal.toReal_ofNat] + norm_num + +theorem idealOriginUnionBound_le_nine_mul_inv123_of_queries_le126 {signatures q : Nat} + (hsignatures : signatures ≤ signatureLimit) (hq : q ≤ 2 ^ 126) : + idealOriginUnionBound signatures q ≤ 9 * ((2 ^ 123 : Nat) : ℝ≥0∞)⁻¹ := by + rw [idealOriginUnionBound_eq_weightedFewTimePatternBound] + exact weightedFewTimePatternBound_le_nine_mul_inv123_of_queries_le126 hsignatures hq + +theorem rawTargetOriginUnionBound_le_nine_mul_inv133 {signatures q : Nat} + (hsignatures : signatures ≤ signatureLimit) (hq : q ≤ 2 ^ 126) : + rawTargetOriginUnionBound signatures q ≤ 9 * ((2 ^ 133 : Nat) : ℝ≥0∞)⁻¹ := by + rw [rawTargetOriginUnionBound_eq] + calc + _ ≤ ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + (9 * ((2 ^ 123 : Nat) : ℝ≥0∞)⁻¹) := + mul_le_mul' le_rfl (idealOriginUnionBound_le_nine_mul_inv123_of_queries_le126 hsignatures hq) + _ = _ := by + rw [mul_left_comm, ← ENNReal.mul_inv (by left; positivity) (by right; simp), + ← Nat.cast_mul, ← pow_add, show ftsTreeHeight + 123 = 133 by rfl] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeCompare.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeCompare.lean new file mode 100644 index 00000000..1d4072d4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeCompare.lean @@ -0,0 +1,91 @@ +import SphincsSecurity.Proof.LayerCompare + +/-! +# Signing-transcript coverage of few-time openings + +A transcript covers one few-time leaf when some successful signer invocation used the same index +and selected that leaf for the corresponding tree. The leak event is simultaneous coverage of all +fourteen trees, allowing a different transcript entry to cover each tree. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +theorem messageDigest_eq_of_index_leaves_eq {left right : MessageDigest} + (hindex : digestIndex left = digestIndex right) + (hleaves : digestLeaves left = digestLeaves right) : left = right := by + apply BitVec.eq_of_getLsbD_eq + intro bit hbit + by_cases hlow : bit < totalHeight + · have h := congrArg (fun index : Index => (BitVec.ofFin index).getLsbD bit) hindex + simpa only [digestIndex, BitVec.ofFin_toFin, BitVec.getLsbD_extractLsb', hlow, decide_true, + Bool.true_and, Nat.zero_add] using h + · let treeValue := (bit - totalHeight) / ftsTreeHeight + have htreeValue : treeValue < ftsTrees := by + simp only [treeValue, messageDigestBits, totalHeight, ftsTreeHeight, ftsTrees] at hbit ⊢ + omega + let tree : DigestTree := ⟨treeValue, htreeValue⟩ + let offset := bit - (totalHeight + ftsTreeHeight * tree.val) + have hoffset : offset < ftsTreeHeight := by + simp only [offset, tree, treeValue, totalHeight, ftsTreeHeight] + omega + have h := congrArg (fun leaves : DigestTree → FtsLeaf => + (BitVec.ofFin (leaves tree)).getLsbD offset) hleaves + simp only [digestLeaves, BitVec.ofFin_toFin, BitVec.getLsbD_extractLsb', hoffset, + decide_true, Bool.true_and] at h + have heq : totalHeight + ftsTreeHeight * tree.val + offset = bit := by + simp only [offset, tree, treeValue, totalHeight, ftsTreeHeight] + have hlow' : 26 ≤ bit := by simpa only [totalHeight] using Nat.le_of_not_gt hlow + have hmul : 10 * ((bit - 26) / 10) ≤ bit - 26 := Nat.mul_div_le _ _ + omega + rw [heq] at h + exact h + +def SignedFtsLeaf (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (index : Index) + (tree : FtsTree) (leafIdx : FtsLeaf) : Prop := + ∃ (entry : (request : SignRequest) × SigningSpec.Range request) (signature : Signature) + (leaves : DigestTree → FtsLeaf), + entry ∈ signingLog + ∧ entry.2 = some signature + ∧ SuccessfulSignRun f cache secretKey entry.1 signature + ∧ HonestFtsSignAt f cache secretKey entry.1 signature index leaves + ∧ leaves (ftsIndexOf tree) = leafIdx + +def FewTimeLeak (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (index : Index) + (leaves : DigestTree → FtsLeaf) : Prop := + ∀ tree, SignedFtsLeaf f cache secretKey signingLog index tree (leaves (ftsIndexOf tree)) + +theorem signedFtsLeaves_of_signing_entry (f : QueryImpl HashSpec Id) + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (initialCache : QueryCache HashSpec) (value : alpha) (signingLog : QueryLog SigningSpec) + (adversaryCache finalCache : QueryCache HashSpec) + (hmem : ((value, signingLog), adversaryCache) ∈ support + ((simulateQ romImpl + ((simulateQ (forwardOracles + signingOracle scheme secretKey) + computation).run)).run initialCache)) + (hle : adversaryCache ≤ finalCache) (hf : finalCache.AgreesWithFn f) + (entry : (request : SignRequest) × SigningSpec.Range request) (signature : Signature) + (hresponse : entry.2 = some signature) (hentry : entry ∈ signingLog) : + ∃ (index : Index) (leaves : DigestTree → FtsLeaf), ∀ tree, + SignedFtsLeaf f finalCache secretKey signingLog index tree (leaves (ftsIndexOf tree)) := by + have hrun := successfulSignRun_of_signing_entry f secretKey computation initialCache value + signingLog adversaryCache finalCache hmem hle hf entry signature hresponse hentry + obtain ⟨index, leaves, hfts⟩ := hrun.honest_fts_at + exact ⟨index, leaves, fun tree => + ⟨entry, signature, leaves, hentry, hresponse, hrun, hfts, rfl⟩⟩ + +theorem fewTimeLeak_or_uncovered (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (index : Index) + (leaves : DigestTree → FtsLeaf) : + FewTimeLeak f cache secretKey signingLog index leaves + ∨ ∃ tree, ¬ SignedFtsLeaf f cache secretKey signingLog index tree + (leaves (ftsIndexOf tree)) := by + classical + by_cases hleak : FewTimeLeak f cache secretKey signingLog index leaves + · exact Or.inl hleak + · exact Or.inr (not_forall.mp hleak) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeFixedPrehit.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeFixedPrehit.lean new file mode 100644 index 00000000..3af9d887 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeFixedPrehit.lean @@ -0,0 +1,97 @@ +import SphincsSecurity.Proof.FewTimeNumberedSources + +/-! +# Reusing one fixed cached message entry + +Once an origin configuration fixes a direct source, the later signer has to select that source's +one exact message-digest input. Restricting the reference cache to this input turns the cached-entry +factor in the digest race into one. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +def onlyInputCache (cache : QueryCache HashSpec) (target : HashInput) : + QueryCache HashSpec := + fun input => if input = target then cache input else none + +theorem onlyInputCache_le (cache : QueryCache HashSpec) (target : HashInput) : + onlyInputCache cache target ≤ cache := by + intro input output hcached + by_cases hinput : input = target + · simpa [onlyInputCache, hinput] using hcached + · simp [onlyInputCache, hinput] at hcached + +theorem cachedMessageEntryCountWhere_onlyInput_le_one + (cache : QueryCache HashSpec) (target : HashInput) + (parameter : PublicParameter) (root : Digest) (message : Message) + (P : Concrete.FewTimeView → Prop) : + cachedMessageEntryCountWhere (onlyInputCache cache target) parameter root message P ≤ 1 := by + have hsubsingleton : + (cachedMessageInputSetWhere (onlyInputCache cache target) parameter root message P).Subsingleton := by + rintro ⟨leftInput, leftOutput⟩ hleft ⟨rightInput, rightOutput⟩ hright + have hleftInput : leftInput = target := by + by_contra hne + simp [cachedMessageInputSetWhere, cachedMessageInputSet, onlyInputCache, hne] + at hleft + have hrightInput : rightInput = target := by + by_contra hne + simp [cachedMessageInputSetWhere, cachedMessageInputSet, onlyInputCache, hne] + at hright + subst leftInput + subst rightInput + have houtputs : leftOutput = rightOutput := by + apply Option.some.inj + exact hleft.1.1.symm.trans hright.1.1 + subst rightOutput + rfl + have hencard : + (cachedMessageInputSetWhere (onlyInputCache cache target) parameter root message P).encard ≤ 1 := + Set.encard_le_one_iff_subsingleton.2 hsubsingleton + simpa only [cachedMessageEntryCountWhere, ENat.toENNReal_one] using + ENat.toENNReal_mono hencard + +theorem Concrete.probEvent_signWithView_fixedPrehit_le_race + (secretKey : SecretKey) (message : Message) (initialCache : QueryCache HashSpec) + (target : HashInput) (P : FewTimeView → Prop) + (hbudget : QueryCache.enncard initialCache + (digestAttemptLimit : ℝ≥0∞) ≤ + ((2 ^ 127 : Nat) : ℝ≥0∞)) : + Pr[PrehitSuccessfulSignerView (onlyInputCache initialCache target) secretKey message P | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] ≤ + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ := by + calc + Pr[PrehitSuccessfulSignerView (onlyInputCache initialCache target) secretKey message P | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] ≤ + cachedMessageEntryCountWhere (onlyInputCache initialCache target) + secretKey.parameter secretKey.root message P * + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ := + probEvent_signWithView_prehitSuccessful_le_race_reference secretKey message + (onlyInputCache initialCache target) initialCache P + (onlyInputCache_le initialCache target) hbudget + _ ≤ 1 * ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ := by + gcongr + exact cachedMessageEntryCountWhere_onlyInput_le_one initialCache target + secretKey.parameter secretKey.root message P + _ = _ := one_mul _ + +theorem Concrete.probEvent_signWithView_fixedPrehit_le_race_of_enncard_le + (secretKey : SecretKey) (message : Message) (initialCache : QueryCache HashSpec) + (target : HashInput) (P : FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[PrehitSuccessfulSignerView (onlyInputCache initialCache target) secretKey message P | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] ≤ + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ := by + apply probEvent_signWithView_fixedPrehit_le_race + have hq' : (q : ℝ≥0∞) ≤ ((2 ^ 126 : Nat) : ℝ≥0∞) := by + exact_mod_cast hq + calc + QueryCache.enncard initialCache + (digestAttemptLimit : ℝ≥0∞) ≤ + (q : ℝ≥0∞) + (digestAttemptLimit : ℝ≥0∞) := + add_le_add hcache le_rfl + _ ≤ ((2 ^ 126 : Nat) : ℝ≥0∞) + (digestAttemptLimit : ℝ≥0∞) := + add_le_add hq' le_rfl + _ ≤ ((2 ^ 127 : Nat) : ℝ≥0∞) := by + norm_num [digestAttemptLimit] + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeFresh.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeFresh.lean new file mode 100644 index 00000000..3a3c570e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeFresh.lean @@ -0,0 +1,463 @@ +import SphincsSecurity.Proof.FewTimePadding + +/-! +# Fresh signer views + +During a digest retry loop, every message input added after the loop's reference cache contains an +inadmissible answer. Thus a successful input absent from the reference cache is answered freshly, +and its retained few-time view has the uniform distribution even after all failed retries. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +abbrev HashOutputRest := + FtsLeaf × BitVec (hashOutputBits - messageDigestBits) + +def reorderHashOutputCoordinates : + (HashOutputRest × FewTimeView) ≃ HashOutputCoordinates where + toFun value := ((value.2, value.1.1), value.1.2) + invFun value := ((value.1.2, value.2), value.1.1) + left_inv _ := rfl + right_inv _ := rfl + +set_option maxRecDepth 100000 in +theorem evalDist_uniformHashOutputCoordinates_bind_reordered {Result : Type} + (continuation : HashOutputCoordinates → ProbComp Result) : + 𝒟[($ᵗ HashOutputCoordinates : ProbComp HashOutputCoordinates) >>= continuation] = + 𝒟[($ᵗ HashOutputRest : ProbComp HashOutputRest) >>= fun rest => + ($ᵗ FewTimeView : ProbComp FewTimeView) >>= fun view => + continuation ((view, rest.1), rest.2)] := by + let paired : ProbComp (HashOutputRest × FewTimeView) := do + let rest ← $ᵗ HashOutputRest + let view ← $ᵗ FewTimeView + pure (rest, view) + have hpaired : + 𝒟[paired] = 𝒟[($ᵗ (HashOutputRest × FewTimeView) : + ProbComp (HashOutputRest × FewTimeView))] := by + exact evalDist_independent_uniform_pair + have hreordered : + 𝒟[reorderHashOutputCoordinates <$> paired] = + 𝒟[($ᵗ HashOutputCoordinates : ProbComp HashOutputCoordinates)] := by + calc + 𝒟[reorderHashOutputCoordinates <$> paired] = + reorderHashOutputCoordinates <$> 𝒟[paired] := by rw [evalDist_map] + _ = reorderHashOutputCoordinates <$> + 𝒟[($ᵗ (HashOutputRest × FewTimeView) : + ProbComp (HashOutputRest × FewTimeView))] := by rw [hpaired] + _ = 𝒟[reorderHashOutputCoordinates <$> + ($ᵗ (HashOutputRest × FewTimeView) : + ProbComp (HashOutputRest × FewTimeView))] := by rw [evalDist_map] + _ = 𝒟[($ᵗ HashOutputCoordinates : ProbComp HashOutputCoordinates)] := + evalDist_map_bijective_uniform_cross + (α := HashOutputRest × FewTimeView) (β := HashOutputCoordinates) + (reorderHashOutputCoordinates : HashOutputRest × FewTimeView → + HashOutputCoordinates) + reorderHashOutputCoordinates.bijective + calc + 𝒟[($ᵗ HashOutputCoordinates : ProbComp HashOutputCoordinates) >>= continuation] = + 𝒟[(reorderHashOutputCoordinates <$> paired) >>= continuation] := by + rw [evalDist_bind, ← hreordered, ← evalDist_bind] + _ = _ := by + simp only [paired, map_eq_bind_pure_comp, bind_assoc, pure_bind, + reorderHashOutputCoordinates, Function.comp_apply] + rfl + +theorem probEvent_uniformDigestCoordinates_admissible_view + (P : FewTimeView → Prop) : + Pr[fun coordinates : FewTimeView × FtsLeaf => coordinates.2 = 0 ∧ P coordinates.1 | + ($ᵗ (FewTimeView × FtsLeaf) : ProbComp (FewTimeView × FtsLeaf))] = + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + Pr[P | ($ᵗ FewTimeView : ProbComp FewTimeView)] := by + change Pr[fun coordinates : FewTimeView × FtsLeaf => + coordinates.2 = 0 ∧ P coordinates.1 | + Prod.mk <$> ($ᵗ FewTimeView : ProbComp FewTimeView) <*> + ($ᵗ FtsLeaf : ProbComp FtsLeaf)] = _ + calc + _ = Pr[P | ($ᵗ FewTimeView : ProbComp FewTimeView)] * + Pr[fun leaf : FtsLeaf => leaf = 0 | + ($ᵗ FtsLeaf : ProbComp FtsLeaf)] := by + apply probEvent_seq_map_eq_mul + intro view _hview leaf _hleaf + simp [and_comm] + _ = Pr[P | ($ᵗ FewTimeView : ProbComp FewTimeView)] * + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ := by + rw [probEvent_eq_eq_probOutput, probOutput_uniformSample, Fintype.card_fin] + _ = _ := by rw [mul_comm] + +set_option maxRecDepth 100000 in +theorem probEvent_uniformHashOutput_admissible_view + (P : FewTimeView → Prop) : + Pr[fun output : HashOutput => + signAttemptResultOfOutput output ≠ none ∧ P (hashOutputFewTimeView output) | + ($ᵗ HashOutput : ProbComp HashOutput)] = + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + Pr[P | ($ᵗ FewTimeView : ProbComp FewTimeView)] := by + let coordinates : HashOutput → FewTimeView × FtsLeaf := fun output => + digestCoordinates (truncateMessageDigest output) + let event : FewTimeView × FtsLeaf → Prop := fun value => value.2 = 0 ∧ P value.1 + calc + Pr[fun output : HashOutput => + signAttemptResultOfOutput output ≠ none ∧ P (hashOutputFewTimeView output) | + ($ᵗ HashOutput : ProbComp HashOutput)] = + Pr[event | coordinates <$> ($ᵗ HashOutput : ProbComp HashOutput)] := by + rw [probEvent_map] + congr 1 + funext output + rw [signAttemptResultOfOutput_ne_none_iff] + rfl + _ = Pr[event | + ($ᵗ (FewTimeView × FtsLeaf) : ProbComp (FewTimeView × FtsLeaf))] := + probEvent_congr' (fun _ _ => Iff.rfl) (by + simpa only [coordinates] using evalDist_hashOutput_digestCoordinates_uniform) + _ = _ := probEvent_uniformDigestCoordinates_admissible_view P + +theorem probEvent_randomOracle_fresh_admissible_view + (input : HashInput) (cache : QueryCache HashSpec) (hcache : cache input = none) + (P : FewTimeView → Prop) : + Pr[fun result : HashOutput × QueryCache HashSpec => + signAttemptResultOfOutput result.1 ≠ none ∧ + P (hashOutputFewTimeView result.1) | + (randomOracle input).run cache] = + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + Pr[P | ($ᵗ FewTimeView : ProbComp FewTimeView)] := by + rw [OracleSpec.randomOracle, QueryImpl.withCaching_run_none _ hcache] + change Pr[fun result : HashOutput × QueryCache HashSpec => + signAttemptResultOfOutput result.1 ≠ none ∧ + P (hashOutputFewTimeView result.1) | + (fun output : HashOutput => (output, cache.cacheQuery input output)) <$> + ($ᵗ HashOutput : ProbComp HashOutput)] = _ + rw [probEvent_map] + exact probEvent_uniformHashOutput_admissible_view P + +def OnlyRejectedNewMessageEntries (referenceCache workingCache : QueryCache HashSpec) + (secretKey : SecretKey) (message : Message) : Prop := + ∀ randomness output, + referenceCache (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = none → + workingCache (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = some output → + signAttemptResultOfOutput output = none + +theorem onlyRejectedNewMessageEntries_self (cache : QueryCache HashSpec) + (secretKey : SecretKey) (message : Message) : + OnlyRejectedNewMessageEntries cache cache secretKey message := by + intro randomness output hmiss hhit + rw [hmiss] at hhit + simp at hhit + +theorem onlyRejectedNewMessageEntries_cacheRejected + (referenceCache workingCache : QueryCache HashSpec) + (secretKey : SecretKey) (message : Message) (sampled : Randomness) + (output : HashOutput) + (hinvariant : OnlyRejectedNewMessageEntries referenceCache workingCache secretKey message) + (hrejected : signAttemptResultOfOutput output = none) : + OnlyRejectedNewMessageEntries referenceCache + (workingCache.cacheQuery + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message sampled)) output) + secretKey message := by + intro randomness found hreferenceFound hfound + let foundInput := tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness) + let sampledInput := tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message sampled) + by_cases hsame : foundInput = sampledInput + · have hfound' : some output = some found := by + calc + some output = + (workingCache.cacheQuery sampledInput output) sampledInput := by + rw [QueryCache.cacheQuery_self] + _ = (workingCache.cacheQuery sampledInput output) foundInput := by rw [hsame] + _ = some found := by simpa only [foundInput, sampledInput] using hfound + rw [← Option.some.inj hfound'] + exact hrejected + · have hworking : workingCache foundInput = some found := by + rw [QueryCache.cacheQuery_of_ne workingCache output hsame] at hfound + simpa only [foundInput, sampledInput] using hfound + exact hinvariant randomness found hreferenceFound hworking + +set_option maxRecDepth 100000 in +theorem onlyRejectedNewMessageEntries_of_failed_attempt + (referenceCache beforeCache afterCache : QueryCache HashSpec) + (secretKey : SecretKey) (message : Message) (sampled : Randomness) + (hinvariant : OnlyRejectedNewMessageEntries referenceCache beforeCache secretKey message) + (hmem : (none, afterCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAttempt secretKey message sampled)).run beforeCache)) : + OnlyRejectedNewMessageEntries referenceCache afterCache secretKey message := by + intro randomness output hreference hafter + let target := tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness) + let sampledInput := tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message sampled) + by_cases hsame : target = sampledInput + · apply Eq.symm + have hafterSampled : afterCache sampledInput = some output := by + change afterCache target = some output at hafter + rw [← hsame] + exact hafter + change afterCache + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message sampled)) = some output at hafterSampled + exact signAttempt_result_of_cached secretKey message sampled beforeCache afterCache + none output hafterSampled hmem + · by_cases hbefore : beforeCache target = none + · change beforeCache + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = none at hbefore + change (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) ≠ + tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message sampled) at hsame + have hnone := signAttempt_cache_other_none secretKey message sampled beforeCache afterCache + none hmem _ hbefore hsame + rw [hnone] at hafter + simp at hafter + · obtain ⟨prior, hprior⟩ := Option.ne_none_iff_exists'.mp hbefore + have hmemWorld : (none, afterCache) ∈ support + ((simulateQ romImpl + (liftM (signAttempt secretKey message sampled : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))) : + OracleComp OracleWorld (Option (Index × (DigestTree → FtsLeaf))))).run + beforeCache) := by + rw [simulateQ_romImpl_liftM] + exact hmem + have hle : beforeCache ≤ afterCache := + simulateQ_romImpl_cache_le + (liftM (signAttempt secretKey message sampled : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))) : + OracleComp OracleWorld (Option (Index × (DigestTree → FtsLeaf)))) + beforeCache (none, afterCache) hmemWorld + have heq : prior = output := Option.some.inj ((hle hprior).symm.trans hafter) + rw [← heq] + exact hinvariant randomness prior hreference hprior + +def FreshSelectedView (referenceCache : QueryCache HashSpec) + (secretKey : SecretKey) (message : Message) (P : FewTimeView → Prop) + (result : Option (Randomness × Index × (DigestTree → FtsLeaf)) × + QueryCache HashSpec) : Prop := + ∃ randomness index leaves, + result.1 = some (randomness, index, leaves) + ∧ referenceCache (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = none + ∧ P (selectedFewTimeView index leaves) + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 1000000 in +set_option linter.constructorNameAsVariable false in +theorem probEvent_signDigestLoop_freshSelectedView_le_uniform + (attempts : Nat) (secretKey : SecretKey) (message : Message) + (referenceCache workingCache : QueryCache HashSpec) (P : FewTimeView → Prop) + (hinvariant : OnlyRejectedNewMessageEntries referenceCache workingCache secretKey message) : + Pr[FreshSelectedView referenceCache secretKey message P | + (simulateQ romImpl (signDigestLoop attempts secretKey message)).run workingCache] ≤ + Pr[P | ($ᵗ FewTimeView : ProbComp FewTimeView)] := by + induction attempts generalizing workingCache with + | zero => + refine le_of_eq_of_le (probEvent_eq_zero ?_) zero_le + intro result hresult hevent + have hresultEq : result = (none, workingCache) := by + simpa only [signDigestLoop, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hresult + obtain ⟨randomness, index, leaves, hselected, _⟩ := hevent + rw [hresultEq] at hselected + simp at hselected + | succ attempts ih => + rw [signDigestLoop_run_succ_eq] + refine probEvent_bind_le_of_forall_le fun randomness _hrandomness => ?_ + let input := tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness) + by_cases hreference : referenceCache input = none + · by_cases hworking : workingCache input = none + · let continuation := signDigestLoopContinuation attempts secretKey message randomness + have hcoordinates := evalDist_signAttempt_fresh_bind_coordinates + secretKey message randomness workingCache (by simpa only [input] using hworking) + continuation + change Pr[FreshSelectedView referenceCache secretKey message P | + (simulateQ randomOracle + (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf))))).run + workingCache >>= continuation] ≤ _ + have hprobCoordinates := probEvent_congr' + (p := FreshSelectedView referenceCache secretKey message P) + (q := FreshSelectedView referenceCache secretKey message P) + (fun _ _ => Iff.rfl) hcoordinates + rw [hprobCoordinates] + have hreorder := evalDist_uniformHashOutputCoordinates_bind_reordered + (fun coordinates => + let output := hashOutputCoordinatesEquiv.symm coordinates + continuation (signAttemptResultOfOutput output, + workingCache.cacheQuery input output)) + rw [probEvent_congr' (fun _ _ => Iff.rfl) hreorder] + refine probEvent_bind_le_of_forall_le fun rest _hrest => ?_ + by_cases hadmissible : rest.1 = 0 + · refine (probEvent_bind_le_probEvent + (p := P) (q := FreshSelectedView referenceCache secretKey message P) ?_).trans le_rfl + intro view _hview hP + refine probEvent_eq_zero ?_ + intro result hresult hevent + let coordinates : HashOutputCoordinates := ((view, rest.1), rest.2) + let output := hashOutputCoordinatesEquiv.symm coordinates + have hsuccessful : signAttemptResultOfOutput output ≠ none := by + rw [signAttemptResultOfOutput_coordinates_ne_none_iff] + exact hadmissible + obtain ⟨indexLeaves, hindexLeaves⟩ := Option.ne_none_iff_exists'.mp hsuccessful + rcases indexLeaves with ⟨index, leaves⟩ + have hviewEq : selectedFewTimeView index leaves = view := by + exact signAttemptResultOfOutput_coordinates_view coordinates index leaves + (by simpa only [output] using hindexLeaves) + have hresultEq : result = + (some (randomness, index, leaves), + workingCache.cacheQuery input output) := by + simpa only [continuation, signDigestLoopContinuation, hindexLeaves, + support_pure, Set.mem_singleton_iff, coordinates, output] using hresult + obtain ⟨foundRandomness, foundIndex, foundLeaves, hselected, _, hpattern⟩ := hevent + have hselected' : + (foundRandomness, foundIndex, foundLeaves) = + (randomness, index, leaves) := by + apply Option.some.inj + exact hselected.symm.trans (congrArg Prod.fst hresultEq) + obtain ⟨rfl, rfl, rfl⟩ := hselected' + apply hP + rw [hviewEq] at hpattern + exact hpattern + · refine probEvent_bind_le_of_forall_le fun view _hview => ?_ + let coordinates : HashOutputCoordinates := ((view, rest.1), rest.2) + let output := hashOutputCoordinatesEquiv.symm coordinates + have hrejected : signAttemptResultOfOutput output = none := by + apply Option.eq_none_iff_forall_not_mem.mpr + intro selected hselected + have hne : signAttemptResultOfOutput output ≠ none := by + rw [hselected] + simp + rw [signAttemptResultOfOutput_coordinates_ne_none_iff] at hne + exact hadmissible hne + have hinvariant' := onlyRejectedNewMessageEntries_cacheRejected + referenceCache workingCache secretKey message randomness output hinvariant + hrejected + simpa only [coordinates, output, continuation, hrejected, + signDigestLoopContinuation] using + ih (workingCache.cacheQuery input output) hinvariant' + · obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hworking + have hrejected := hinvariant randomness output + (by simpa only [input] using hreference) (by simpa only [input] using houtput) + refine probEvent_bind_le_of_forall_le fun attemptResult hattempt => ?_ + have hle : workingCache ≤ attemptResult.2 := + simulateQ_romImpl_cache_le + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))) : + OracleComp OracleWorld (Option (Index × (DigestTree → FtsLeaf)))) + workingCache attemptResult (by + rw [simulateQ_romImpl_liftM] + exact hattempt) + have hattemptResult : attemptResult.1 = none := + (signAttempt_result_of_cached secretKey message randomness workingCache + attemptResult.2 attemptResult.1 output + (hle (by simpa only [input] using houtput)) hattempt).trans hrejected + have hinvariant' := onlyRejectedNewMessageEntries_of_failed_attempt + referenceCache workingCache attemptResult.2 secretKey message randomness + hinvariant (by + have heq : attemptResult = (none, attemptResult.2) := + Prod.ext hattemptResult rfl + rw [← heq] + exact hattempt) + simpa only [hattemptResult, signDigestLoopContinuation] using + ih attemptResult.2 hinvariant' + · refine probEvent_bind_le_of_forall_le fun attemptResult hattempt => ?_ + cases hattemptResult : attemptResult.1 with + | none => + have hinvariant' := onlyRejectedNewMessageEntries_of_failed_attempt + referenceCache workingCache attemptResult.2 secretKey message randomness + hinvariant (by + have heq : attemptResult = (none, attemptResult.2) := + Prod.ext hattemptResult rfl + rw [← heq] + exact hattempt) + simpa only [hattemptResult, signDigestLoopContinuation] using + ih attemptResult.2 hinvariant' + | some selected => + refine le_of_eq_of_le (probEvent_eq_zero ?_) zero_le + intro result hresult hevent + rcases selected with ⟨index, leaves⟩ + have hresultEq : result = + (some (randomness, index, leaves), attemptResult.2) := by + simpa only [hattemptResult, signDigestLoopContinuation, support_pure, + Set.mem_singleton_iff] using hresult + obtain ⟨foundRandomness, foundIndex, foundLeaves, hselected, hmiss, _⟩ := hevent + have hrandomness : foundRandomness = randomness := by + have htuple : (foundRandomness, foundIndex, foundLeaves) = + (randomness, index, leaves) := + Option.some.inj (hselected.symm.trans (congrArg Prod.fst hresultEq)) + exact congrArg Prod.fst htuple + rw [hrandomness] at hmiss + exact hreference hmiss + +def FreshSuccessfulSignerView (initialCache : QueryCache HashSpec) + (secretKey : SecretKey) (message : Message) (P : FewTimeView → Prop) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) : Prop := + ∃ signature view, + result.1 = (some signature, some view) + ∧ initialCache (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message signature.randomness)) = none + ∧ P view + +set_option maxRecDepth 100000 in +set_option linter.constructorNameAsVariable false in +theorem probEvent_signWithView_freshSuccessful_le_uniform + (secretKey : SecretKey) (message : Message) (initialCache : QueryCache HashSpec) + (P : FewTimeView → Prop) : + Pr[FreshSuccessfulSignerView initialCache secretKey message P | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] ≤ + Pr[P | ($ᵗ FewTimeView : ProbComp FewTimeView)] := by + rw [signWithView, simulateQ_bind, StateT.run_bind] + refine (probEvent_bind_le_probEvent + (p := FreshSelectedView initialCache secretKey message P) ?_).trans + (probEvent_signDigestLoop_freshSelectedView_le_uniform digestAttemptLimit + secretKey message initialCache initialCache P + (onlyRejectedNewMessageEntries_self initialCache secretKey message)) + intro loopResult hloop hnotFresh + cases hloopResult : loopResult.1 with + | none => + refine probEvent_eq_zero ?_ + intro result hresult hevent + have hresultEq : result = ((none, none), loopResult.2) := by + simpa only [hloopResult, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hresult + obtain ⟨signature, view, hsuccessful, _⟩ := hevent + rw [hresultEq] at hsuccessful + simp at hsuccessful + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + refine probEvent_eq_zero ?_ + intro result hresult hevent + rw [simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hresult + obtain ⟨⟨signatureResult, signatureCache⟩, hsignature, hpure⟩ := hresult + have hpureEq : result = + ((signatureResult, some (selectedFewTimeView index leaves)), signatureCache) := by + simpa only [simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hpure + obtain ⟨signature, view, hsuccessful, hmiss, hP⟩ := hevent + have hpureFirst := congrArg Prod.fst hpureEq + have hsignatureResult : signatureResult = some signature := by + have := congrArg Prod.fst (hpureFirst.symm.trans hsuccessful) + simpa using this + have hview : view = selectedFewTimeView index leaves := by + have := congrArg Prod.snd (hpureFirst.symm.trans hsuccessful) + simpa using this.symm + have hsignature' : (some signature, signatureCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest secretKey randomness index leaves)).run loopResult.2) := by + rw [hsignatureResult] at hsignature + simpa only [simulateQ_romImpl_liftM] using hsignature + have hrandomness := signAfterDigest_support_some_randomness secretKey randomness + index leaves loopResult.2 signatureCache signature hsignature' + apply hnotFresh + refine ⟨randomness, index, leaves, hloopResult, ?_, ?_⟩ + · rw [← hrandomness] + exact hmiss + · rw [← hview] + exact hP + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeHonestLeakBound.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeHonestLeakBound.lean new file mode 100644 index 00000000..e7f4e35c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeHonestLeakBound.lean @@ -0,0 +1,170 @@ +import SphincsSecurity.Proof.FewTimeRawTargetFresh +import SphincsSecurity.Proof.OtsProbeGroupedTerminal + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem probEvent_gameAfterSecretsWithViewTrace_honest_leak_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + q * rawTargetOriginUnionBound signatureLimit q + + ((q + 1 : Nat) : ℝ≥0∞) * rawTargetOriginUnionBound signatureLimit q := by + classical + calc + _ ≤ Pr[fun result => + (ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result ∧ + ¬VerifierFreshTarget parameter result) ∨ + (ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result) | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + apply probEvent_mono + intro result _ hproper + by_cases hfresh : VerifierFreshTarget parameter result + · exact Or.inr ⟨hproper, hfresh⟩ + · exact Or.inl ⟨hproper, hfresh⟩ + _ ≤ _ := (probEvent_or_le _ _ _).trans (add_le_add + (probEvent_gameAfterSecretsWithViewTrace_nonfresh_honest_leak_le adversary q hq + hqMax parameter hparameter otsSecret hots ftsSecret hfts) + (probEvent_gameAfterSecretsWithViewTrace_fresh_honest_leak_le adversary q hq + hqMax parameter hparameter otsSecret hots ftsSecret hfts)) + +theorem probEvent_gameAfterSecretsWithViewTrace_honest_leak_le_three_mul_inv131 + (adversary : Adversary) (q : Nat) (hqPos : 1 ≤ q) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 125) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + ((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 131 : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ ≤ q * rawTargetOriginUnionBound signatureLimit q + + ((q + 1 : Nat) : ℝ≥0∞) * rawTargetOriginUnionBound signatureLimit q := + probEvent_gameAfterSecretsWithViewTrace_honest_leak_le adversary q hq (hqMax.trans (by norm_num)) + parameter hparameter otsSecret hots ftsSecret hfts + _ = ((2 * q + 1 : Nat) : ℝ≥0∞) * rawTargetOriginUnionBound signatureLimit q := by + push_cast + ring + _ ≤ _ := by + apply mul_le_mul' + · exact_mod_cast (show 2 * q + 1 ≤ 3 * q by omega) + · exact rawTargetOriginUnionBound_le_inv131 le_rfl hqMax + +theorem viewedWinningHonestLeakTerminalWitness_cases (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hwitness : ViewedWinningTerminalWitnessFor parameter otsSecret ftsSecret HonestLeakTerminalForgeryEvent result) : + ViewedWinningFreshLayerOpeningWitness parameter otsSecret ftsSecret result + ∨ ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result + ∨ ViewedWinningBackwardChainOpeningWitness parameter otsSecret ftsSecret result + ∨ ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result + ∨ ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∨ ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result := by + obtain ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hverified, + hterminal⟩ := hwitness + rcases hterminal with hfresh | hencoding | hbackward | hmessage | hfewTime | huncovered + · exact Or.inl ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hverified, hfresh⟩ + · exact Or.inr (Or.inl + ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hencoding⟩) + · exact Or.inr (Or.inr (Or.inl + ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hverified, hbackward⟩)) + · exact Or.inr (Or.inr (Or.inr (Or.inl + ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hmessage⟩))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inl + ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hfewTime⟩)))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr + ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, huncovered⟩)))) + +theorem probEvent_win_le_grouped_honestLeak_terminal_cases (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + let run := gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + Pr[= true | (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run' ∅] ≤ + Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache | run] + + (Pr[cleanOtsOpeningEvent parameter otsSecret ftsSecret | run] + + (Pr[cleanEncodingEvent parameter otsSecret ftsSecret | run] + + (Pr[cleanMessageEvent parameter otsSecret ftsSecret | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result | run] + + Pr[cleanUncoveredEvent parameter otsSecret ftsSecret | run])))) := by + classical + dsimp only + let run := gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + let opening := cleanOtsOpeningEvent parameter otsSecret ftsSecret + let encoding := cleanEncodingEvent parameter otsSecret ftsSecret + let message := cleanMessageEvent parameter otsSecret ftsSecret + let proper := fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result + let uncovered := cleanUncoveredEvent parameter otsSecret ftsSecret + calc + Pr[= true | (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run' ∅] = + Pr[fun result => result.1.2.2 = true | run] := by + rw [StateT.run'_eq, ← probEvent_eq_eq_probOutput, + ← gameAfterSecretsWithViewTrace_verdictCache_projection adversary parameter otsSecret + ftsSecret, probEvent_map] + rw [probEvent_map] + rfl + _ ≤ Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache ∨ + opening result ∨ encoding result ∨ message result ∨ proper result ∨ + uncovered result | run] := by + apply probEvent_mono + intro result hresult hwin + rcases gameAfterSecretsWithViewTrace_winning_honestLeakTerminal_classify adversary parameter + otsSecret ftsSecret result hresult hwin with hbad | hterminal + · exact Or.inl hbad + · by_cases hbad : Bad parameter otsSecret ftsSecret result.2.cache + · exact Or.inl hbad + · rcases viewedWinningHonestLeakTerminalWitness_cases parameter otsSecret ftsSecret result + hterminal with hfresh | hencoding | hbackward | hmessage | hproper | huncovered + · exact Or.inr (Or.inl (Or.inl ⟨⟨hbad, hwin⟩, hfresh⟩)) + · exact Or.inr (Or.inr (Or.inl ⟨hbad, hencoding⟩)) + · exact Or.inr (Or.inl (Or.inr ⟨⟨hbad, hwin⟩, hbackward⟩)) + · exact Or.inr (Or.inr (Or.inr (Or.inl ⟨hbad, hmessage⟩))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inl ⟨hbad, hproper⟩)))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr ⟨hbad, huncovered⟩)))) + _ ≤ Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache | run] + + Pr[fun result => opening result ∨ encoding result ∨ message result ∨ + proper result ∨ uncovered result | run] := probEvent_or_le _ _ _ + _ ≤ Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache | run] + + (Pr[opening | run] + + (Pr[encoding | run] + + (Pr[message | run] + + (Pr[proper | run] + Pr[uncovered | run])))) := by + gcongr + calc + _ ≤ Pr[opening | run] + + Pr[fun result => encoding result ∨ message result ∨ proper result ∨ + uncovered result | run] := probEvent_or_le _ _ _ + _ ≤ _ := by + gcongr + calc + _ ≤ Pr[encoding | run] + + Pr[fun result => message result ∨ proper result ∨ uncovered result | run] := + probEvent_or_le _ _ _ + _ ≤ _ := by + gcongr + calc + _ ≤ Pr[message | run] + + Pr[fun result => proper result ∨ uncovered result | run] := + probEvent_or_le _ _ _ + _ ≤ _ := by + gcongr + exact probEvent_or_le _ _ _ + _ = _ := by + rfl + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeHonestLeakTerminal.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeHonestLeakTerminal.lean new file mode 100644 index 00000000..173523a9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeHonestLeakTerminal.lean @@ -0,0 +1,232 @@ +import SphincsSecurity.Proof.TerminalView +import SphincsSecurity.Proof.FewTimeSignerCompletion + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +def HonestLeakTerminalForgeryEvent (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (forgery : Forgery) + (index : Index) (leaves : DigestTree → FtsLeaf) : Prop := + SettledForgedFreshLayerOpening f cache secretKey signingLog index leaves forgery.signature + ∨ EncodingCollision f cache secretKey signingLog + ∨ SettledForgedBackwardChainOpening f cache secretKey signingLog index leaves + forgery.signature + ∨ (MessageDigestCollision f cache secretKey signingLog forgery ∧ + FewTimeLeak f cache secretKey signingLog index leaves) + ∨ (ProperFewTimeLeak f cache secretKey signingLog index leaves ∧ + FullyHonestOpening f cache secretKey index leaves forgery.signature) + ∨ UncoveredFtsSecret f cache secretKey signingLog index leaves forgery.signature.ftsSecret + +theorem gameAfterSecretsWithViewTrace_winning_honestLeakTerminal_classify + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (hwin : result.1.2.2 = true) : + Bad parameter otsSecret ftsSecret result.2.cache ∨ + ViewedWinningTerminalWitnessFor parameter otsSecret ftsSecret + HonestLeakTerminalForgeryEvent result := by + rw [gameAfterSecretsWithViewTrace, mem_support_bind_iff] at hresult + obtain ⟨⟨root, rootCache⟩, hroot, hrest⟩ := hresult + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult, hrest, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + rw [gameRestWithViewTrace, mem_support_bind_iff] at hrest + obtain ⟨⟨forgery, state⟩, hadversary, hfinish⟩ := hrest + rw [mem_support_bind_iff] at hfinish + obtain ⟨⟨⟨verified, targetView⟩, finalCache⟩, hverifyView, hpure⟩ := hfinish + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst restResult + have hverified : verified = true := by + cases verified <;> simp_all + subst verified + have htranscript : SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery := by + have h := (show (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) ∧ True by + simpa only [Bool.and_eq_true, decide_eq_true_eq] using hwin) + exact h.1 + have hverify : (true, finalCache) ∈ support + ((simulateQ romImpl + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).run state.cache) := by + rw [← simulateQ_verifyWithView_fst_run ⟨root, parameter⟩ forgery.message + forgery.signature state.cache, support_map] + exact ⟨((true, targetView), finalCache), hverifyView, rfl⟩ + obtain ⟨hverifyLe, f, hf, heval, hqueries⟩ := exists_answerFn_replay_of_mem_support + (verify ⟨root, parameter⟩ forgery.message forgery.signature) state.cache true finalCache + (by simpa only [scheme, simulateQ_romImpl_liftM] using hverify) + have hroot' : (root, rootCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅) := by + simpa only [simulateQ_romImpl_liftM] using hroot + have hbaseAdversary : (forgery, state.base) ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl + ⟨parameter, root, otsSecret, ftsSecret⟩) + (adversary.main ⟨root, parameter⟩)).run + (rootCache, ⟨[], [], []⟩)) := by + let initialState : ViewedFullTraceState := + ⟨rootCache, ⟨[], [], []⟩, [], none⟩ + have hprojection := viewedFullTracedMappedAdversaryImpl_projection + ⟨parameter, root, otsSecret, ftsSecret⟩ (adversary.main ⟨root, parameter⟩) + initialState + have hmapped : (forgery, state.base) ∈ support + (Prod.map id ViewedFullTraceState.base <$> + (simulateQ (viewedFullTracedMappedAdversaryImpl + ⟨parameter, root, otsSecret, ftsSecret⟩) + (adversary.main ⟨root, parameter⟩)).run initialState) := by + rw [support_map] + exact ⟨(forgery, state), by simpa only [initialState] using hadversary, rfl⟩ + rw [hprojection] at hmapped + simpa only [initialState, ViewedFullTraceState.base] using hmapped + have hchain : FullAdversaryTrace.CacheChain rootCache state.trace.intervals state.cache := + fullTracedMappedAdversaryImpl_cacheChain + ⟨parameter, root, otsSecret, ftsSecret⟩ (adversary.main ⟨root, parameter⟩) + rootCache rootCache ⟨[], [], []⟩ (forgery, state.base) rfl hbaseAdversary + have hvalidIntervals : state.trace.ValidIntervals + ⟨parameter, root, otsSecret, ftsSecret⟩ := + fullTracedMappedAdversaryImpl_validIntervals + ⟨parameter, root, otsSecret, ftsSecret⟩ (adversary.main ⟨root, parameter⟩) + rootCache ⟨[], [], []⟩ (forgery, state.base) + (by simp [FullAdversaryTrace.ValidIntervals]) hbaseAdversary + have hrootLe : rootCache ≤ finalCache := + (hchain.start_le_finish hvalidIntervals).trans hverifyLe + obtain ⟨hrootEval, hrootQueries⟩ := replay_of_mem_support_of_le + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree)) ∅ root rootCache finalCache + hroot' hrootLe f hf + have hrootSettled := settled_treeRoot_of_cachedRun + (otsSecret := otsSecret) (ftsSecret := ftsSecret) hf topLayer rootTree hrootQueries + obtain ⟨digest, hdigest, hdigestRun, hadmissible, hlayers, hftsRun, hlayersRun⟩ := + verify_extract ⟨root, parameter⟩ forgery.message forgery.signature heval hqueries + let index := digestIndex digest + let leaves := digestLeaves digest + let ftsPublicKey := evalWithAnswerFn f + (ftsRecover parameter index leaves forgery.signature.ftsSecret forgery.signature.ftsPath) + have hhypertree : HypertreeRun f finalCache parameter index forgery.signature + ftsPublicKey root := + hypertreeRun_of_verify index forgery.signature ftsPublicKey root hlayers hlayersRun + have htarget : root = honestNode f parameter topLayer rootTree + (otsSecret topLayer rootTree) (layerHeight topLayer) 0 := by + rw [← hrootEval] + rfl + have htop := hypertree_top_extract_or_bad hf index forgery.signature ftsPublicKey root + hhypertree htarget (by simpa using hrootSettled) + rcases htop with hbad | htop + · exact Or.inl hbad + · let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + have hclassified := accepted_forgery_classify f finalCache secretKey + state.trace.signing.toSigningLog index forgery.signature leaves ftsPublicKey root hf rfl + htop (by + have htree : treeIndexAt index topLayer = rootTree := by + apply Fin.ext + exact treeIndexAt_topLayer index + unfold LayerRootSettled + rw [htree] + simpa using hrootSettled) hftsRun + rcases hclassified with hbad | hobstacle | hfull + · exact Or.inl hbad + · rcases settledForgedLayerObstacle_classify f finalCache secretKey + state.trace.signing.toSigningLog index leaves forgery.signature hobstacle with + hfresh | hencoding | hbackward + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inl hfresh⟩ + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inl hencoding)⟩ + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inr (Or.inl hbackward))⟩ + · rcases fewTimeLeak_or_uncovered f finalCache secretKey state.trace.signing.toSigningLog + index leaves with hleak | ⟨tree, huncovered⟩ + · rcases fullyHonest_leak_classify f finalCache secretKey + state.trace.signing.toSigningLog forgery digest index leaves hdigest hdigestRun rfl rfl + hfull.1 htranscript.2 hleak with hcollision | hobstacle | hproper + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inr (Or.inr (Or.inl ⟨hcollision, hleak⟩)))⟩ + · rcases settledForgedLayerObstacle_classify f finalCache secretKey + state.trace.signing.toSigningLog index leaves forgery.signature + (hfull.settleObstacle hobstacle) with + hfresh | hencoding | hbackward + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inl hfresh⟩ + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inl hencoding)⟩ + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inr (Or.inl hbackward))⟩ + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inr (Or.inr (Or.inr (Or.inl ⟨hproper, hfull.1⟩))))⟩ + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inr (Or.inr (Or.inr (Or.inr + ⟨tree, huncovered, (hfull.1.2.1 tree).1, by + apply hftsRun + exact ftsRecover_leaf_query_mem f parameter index leaves + forgery.signature.ftsSecret forgery.signature.ftsPath tree⟩))))⟩ + +theorem gameAfterSecretsWithViewTrace_fullyHonest_target_source_direct + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest parameter result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) = digest) + (hadmissible : Admissible digest) + (hproper : ProperFewTimeLeak f result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest)) + (hfull : FullyHonestOpening f result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + (digestIndex digest) (digestLeaves digest) result.1.2.1.signature) + (source : Fin result.2.trace.intervals.length) + (hbefore : (result.2.trace.intervals.get source).initialCache + (tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness)) = none) + (hafter : (result.2.trace.intervals.get source).finalCache + (tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness)) ≠ none) + (hkind : (result.2.trace.intervals.get source).input = .inl (.inr + (tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness))) ∨ + ∃ request, (result.2.trace.intervals.get source).input = .inr request) : + (result.2.trace.intervals.get source).input = .inl (.inr + (tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness))) := by + obtain ⟨output, _, _, houtput, hattempt⟩ := + gameAfterSecretsWithViewTrace_target_source_candidate adversary parameter otsSecret + ftsSecret result hresult f hf digest hdigest hadmissible source hbefore hafter hkind + rcases hkind with hdirect | ⟨request, hsigner⟩ + · exact hdirect + · exfalso + have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hresult, rfl⟩ + have hinvariants := gameAfterSecretsWithFullTrace_support_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hintervals := gameAfterSecretsWithFullTrace_support_interval_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hvalidViews := gameAfterSecretsWithViewTrace_support_validViews adversary parameter + otsSecret ftsSecret result hresult + generalize hentry : result.2.trace.intervals.get source = entry at hsigner hbefore houtput + rcases entry with ⟨entryInput, entryOutput, initialCache, finalCache⟩ + rcases entryInput with worldInput | sourceRequest + · simp at hsigner + · simp only [Sum.inr.injEq] at hsigner + subst sourceRequest + exact hproper.no_signer_target_of_fullyHonest hfull result.2 rfl hvalidViews + hintervals.1 hinvariants.1 hinvariants.2.1 hf source request entryOutput + initialCache finalCache hentry + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) output hbefore houtput hattempt + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeLoop.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeLoop.lean new file mode 100644 index 00000000..ec98dfeb --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeLoop.lean @@ -0,0 +1,378 @@ +import SphincsSecurity.Proof.FewTimeUniform +import SphincsSecurity.Proof.MessagePrehit +import SphincsSecurity.Proof.SignerDigestSource + +/-! +# Fresh successful digest attempts + +An inadmissible answer already cached at a message-digest input remains there throughout the retry +loop and prevents that randomizer from being selected. Consequently, if the randomizer eventually +selected by the loop was absent from the initial cache, its successful attempt queried a fresh +input. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +set_option maxRecDepth 100000 + +def RejectedRandomness (cache : QueryCache HashSpec) (secretKey : SecretKey) + (message : Message) (randomness : Randomness) : Prop := + ∃ output, + cache (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = some output + ∧ signAttemptResultOfOutput output = none + +theorem signAttempt_result_of_cached (secretKey : SecretKey) (message : Message) + (randomness : Randomness) (beforeCache afterCache : QueryCache HashSpec) + (attempt : Option (Index × (DigestTree → FtsLeaf))) (output : HashOutput) + (hcached : afterCache (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = some output) + (hmem : (attempt, afterCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec + (StateT (QueryCache HashSpec) ProbComp)) + (signAttempt secretKey message randomness)).run beforeCache)) : + attempt = signAttemptResultOfOutput output := by + obtain ⟨_, f, hf, heval⟩ := exists_answerFn_agrees_final_of_mem_support + (signAttempt secretKey message randomness) beforeCache attempt afterCache hmem + have hfinput : f (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = output := + hf hcached + simp only [signAttempt, messageDigest, oracleHash, evalWithAnswerFn_bind, + evalWithAnswerFn_query, hfinput] at heval + simp only [signAttemptResultOfOutput] + by_cases hadmissible : Admissible (truncateMessageDigest output) + · simpa only [if_pos hadmissible, evalWithAnswerFn_pure] using heval.symm + · simpa only [if_neg hadmissible, evalWithAnswerFn_pure] using heval.symm + +theorem RejectedRandomness.mono {cache later : QueryCache HashSpec} + {secretKey : SecretKey} {message : Message} {randomness : Randomness} + (hrejected : RejectedRandomness cache secretKey message randomness) + (hle : cache ≤ later) : RejectedRandomness later secretKey message randomness := by + obtain ⟨output, hcached, hresult⟩ := hrejected + exact ⟨output, hle hcached, hresult⟩ + +set_option linter.constructorNameAsVariable false in +theorem signDigestLoop_ne_selected_of_rejected + (attempts : Nat) (secretKey : SecretKey) (message : Message) + (beforeCache afterCache : QueryCache HashSpec) + (rejected : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (hrejected : RejectedRandomness beforeCache secretKey message rejected) + (hmem : (some (rejected, index, leaves), afterCache) ∈ support + ((simulateQ romImpl + (signDigestLoop attempts secretKey message)).run beforeCache)) : False := by + induction attempts generalizing beforeCache afterCache with + | zero => + simp [signDigestLoop] at hmem + | succ attempts ih => + rw [signDigestLoop_run_succ_eq, mem_support_bind_iff] at hmem + obtain ⟨sampledRandomness, _hsampled, hrest⟩ := hmem + rw [mem_support_bind_iff] at hrest + obtain ⟨⟨attempt, attemptCache⟩, hattempt, hfinish⟩ := hrest + have hle : beforeCache ≤ attemptCache := + simulateQ_romImpl_cache_le + (liftM (signAttempt secretKey message sampledRandomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))) : + OracleComp OracleWorld (Option (Index × (DigestTree → FtsLeaf)))) + beforeCache (attempt, attemptCache) (by + simpa only [simulateQ_romImpl_liftM] using hattempt) + cases hresult : attempt with + | none => + apply ih attemptCache afterCache + (hrejected.mono hle) + simpa [signDigestLoopContinuation, hresult] using hfinish + | some selected => + rcases selected with ⟨selectedIndex, selectedLeaves⟩ + have hfinish' : + (some (rejected, index, leaves), afterCache) = + (some (sampledRandomness, selectedIndex, selectedLeaves), attemptCache) := by + simpa [signDigestLoopContinuation, hresult] using hfinish + have hrandomness : sampledRandomness = rejected := by + have hoption := congrArg Prod.fst hfinish' + have hselected := Option.some.inj hoption + exact (congrArg Prod.fst hselected).symm + obtain ⟨output, hcached, hnone⟩ := hrejected + have hcached' : beforeCache + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message sampledRandomness)) = some output := by + rw [hrandomness] + exact hcached + have hattempt' : (attempt, attemptCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec + (StateT (QueryCache HashSpec) ProbComp)) + (signAttempt secretKey message sampledRandomness)).run beforeCache) := by + simpa only [simulateQ_romImpl_liftM] using hattempt + have hattemptResult := signAttempt_result_of_cached secretKey message sampledRandomness + beforeCache attemptCache attempt output (hle hcached') hattempt' + have : attempt = none := hattemptResult.trans hnone + simp [hresult] at this + +set_option linter.constructorNameAsVariable false in +theorem failed_signAttempt_preserves_selected_miss + (attempts : Nat) (secretKey : SecretKey) (message : Message) + (sampled selected : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (beforeCache attemptCache afterCache : QueryCache HashSpec) + (hbefore : beforeCache (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message selected)) = none) + (hattempt : (none, attemptCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec + (StateT (QueryCache HashSpec) ProbComp)) + (signAttempt secretKey message sampled)).run beforeCache)) + (hfuture : (some (selected, index, leaves), afterCache) ∈ support + ((simulateQ romImpl + (signDigestLoop attempts secretKey message)).run attemptCache)) : + attemptCache (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message selected)) = none := by + let selectedInput := tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message selected) + let sampledInput := tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message sampled) + by_cases hsame : selectedInput = sampledInput + · have hrandomness : sampled = selected := by + have hpayload := (tweakableHashInput_injective secretKey.parameter (by trivial) + (by trivial) hsame.symm).2 + exact (messageDigestPayload_injective secretKey.root hpayload).2 + by_cases hmiss : attemptCache selectedInput = none + · exact hmiss + obtain ⟨output, hcached⟩ := Option.ne_none_iff_exists'.mp hmiss + exfalso + apply signDigestLoop_ne_selected_of_rejected attempts secretKey message + attemptCache afterCache selected index leaves + · refine ⟨output, hcached, ?_⟩ + have hcachedSampled : attemptCache + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message sampled)) = some output := by + rw [hrandomness] + exact hcached + have hresult := signAttempt_result_of_cached secretKey message sampled + beforeCache attemptCache none output hcachedSampled hattempt + simpa using hresult.symm + · exact hfuture + · apply signAttempt_cache_other_none secretKey message sampled beforeCache attemptCache + none hattempt selectedInput hbefore + change selectedInput ≠ sampledInput + exact hsame + +set_option linter.constructorNameAsVariable false in +theorem fresh_signAttempt_support_source + (secretKey : SecretKey) (message : Message) (randomness : Randomness) + (index : Index) (leaves : DigestTree → FtsLeaf) + (beforeCache afterCache : QueryCache HashSpec) + (hbefore : beforeCache (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = none) + (hmem : (some (index, leaves), afterCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec + (StateT (QueryCache HashSpec) ProbComp)) + (signAttempt secretKey message randomness)).run beforeCache)) : + ∃ output, signAttemptResultOfOutput output = some (index, leaves) + ∧ afterCache = beforeCache.cacheQuery + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) output := by + let input := tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness) + have hquery : + simulateQ (randomOracle : QueryImpl HashSpec + (StateT (QueryCache HashSpec) ProbComp)) + (oracleHash input : OracleComp HashSpec HashOutput) = + randomOracle input := by + change simulateQ (randomOracle : QueryImpl HashSpec + (StateT (QueryCache HashSpec) ProbComp)) (liftM (HashSpec.query input)) = _ + exact simulateQ_spec_query (impl := (randomOracle : QueryImpl HashSpec + (StateT (QueryCache HashSpec) ProbComp))) input + rw [signAttempt, simulateQ_bind, StateT.run_bind, messageDigest, + simulateQ_bind, StateT.run_bind, hquery] at hmem + simp only [simulateQ_pure, StateT.run_pure, bind_assoc, pure_bind] at hmem + rw [mem_support_bind_iff] at hmem + let hmem' := hmem + obtain ⟨⟨output, queryCache⟩, hquery, hresult⟩ := hmem' + rw [OracleSpec.randomOracle, QueryImpl.withCaching_run_none _ (by simpa [input] using hbefore), + support_map] at hquery + obtain ⟨sampledOutput, _hsampled, heq⟩ := hquery + obtain ⟨rfl, rfl⟩ := heq + by_cases hadmissible : Admissible (truncateMessageDigest output) + · simp only [if_pos hadmissible, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff, Prod.mk.injEq, Option.some.injEq] at hresult + refine ⟨output, ?_, ?_⟩ + · simp only [signAttemptResultOfOutput, if_pos hadmissible] + exact congrArg some (Prod.ext hresult.1.1.symm hresult.1.2.symm) + · simpa [input] using hresult.2 + · simp only [if_neg hadmissible, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff, Prod.mk.injEq, reduceCtorEq, false_and] at hresult + +set_option linter.constructorNameAsVariable false in +theorem signDigestLoop_fresh_selected_attempt + (attempts : Nat) (secretKey : SecretKey) (message : Message) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (initialCache finalCache : QueryCache HashSpec) + (hinitial : initialCache (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = none) + (hmem : (some (randomness, index, leaves), finalCache) ∈ support + ((simulateQ romImpl + (signDigestLoop attempts secretKey message)).run initialCache)) : + ∃ attemptIndex < attempts, ∃ (attemptCache : QueryCache HashSpec) (output : HashOutput), + attemptCache (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = none + ∧ signAttemptResultOfOutput output = some (index, leaves) + ∧ finalCache = attemptCache.cacheQuery + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) output := by + induction attempts generalizing initialCache finalCache with + | zero => + simp [signDigestLoop] at hmem + | succ attempts ih => + rw [signDigestLoop_run_succ_eq, mem_support_bind_iff] at hmem + obtain ⟨sampledRandomness, _hsampled, hrest⟩ := hmem + rw [mem_support_bind_iff] at hrest + obtain ⟨⟨attempt, attemptCache⟩, hattempt, hfinish⟩ := hrest + cases hresult : attempt with + | none => + have hfuture : (some (randomness, index, leaves), finalCache) ∈ support + ((simulateQ romImpl + (signDigestLoop attempts secretKey message)).run attemptCache) := by + simpa [signDigestLoopContinuation, hresult] using hfinish + have hmiss := failed_signAttempt_preserves_selected_miss attempts secretKey message + sampledRandomness randomness index leaves initialCache attemptCache finalCache + hinitial (by simpa only [hresult] using hattempt) hfuture + obtain ⟨attemptIndex, hattemptIndex, sourceCache, output, hsource⟩ := + ih attemptCache finalCache hmiss hfuture + exact ⟨attemptIndex + 1, by omega, sourceCache, output, hsource⟩ + | some selected => + rcases selected with ⟨selectedIndex, selectedLeaves⟩ + have hfinish' : + (some (randomness, index, leaves), finalCache) = + (some (sampledRandomness, selectedIndex, selectedLeaves), attemptCache) := by + simpa [signDigestLoopContinuation, hresult] using hfinish + have htuple := Option.some.inj (congrArg Prod.fst hfinish') + have hrandomness : sampledRandomness = randomness := + (congrArg Prod.fst htuple).symm + have hselected : (selectedIndex, selectedLeaves) = (index, leaves) := + (congrArg Prod.snd htuple).symm + have hcache : attemptCache = finalCache := + (congrArg Prod.snd hfinish').symm + have hinitial' : initialCache + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message sampledRandomness)) = none := by + rw [hrandomness] + exact hinitial + obtain ⟨output, hattemptResult, hattemptCache⟩ := + fresh_signAttempt_support_source secretKey message sampledRandomness + selectedIndex selectedLeaves initialCache attemptCache hinitial' + (by simpa only [hresult] using hattempt) + refine ⟨0, by omega, initialCache, output, hinitial, ?_, ?_⟩ + · rw [← hselected] + exact hattemptResult + · rw [← hcache, ← hrandomness] + exact hattemptCache + +set_option linter.constructorNameAsVariable false in +theorem signDigestLoop_successful_source_is_selected + (attempts : Nat) (secretKey : SecretKey) (message : Message) + (beforeCache afterCache : QueryCache HashSpec) + (result : Option (Randomness × Index × (DigestTree → FtsLeaf))) + (hmem : (result, afterCache) ∈ support + ((simulateQ romImpl + (signDigestLoop attempts secretKey message)).run beforeCache)) + (targetPayload : HashInput) (output : HashOutput) (index : Index) + (leaves : DigestTree → FtsLeaf) + (hbefore : beforeCache + (tweakableHashInput secretKey.parameter .message targetPayload) = none) + (hafter : afterCache + (tweakableHashInput secretKey.parameter .message targetPayload) = some output) + (houtput : signAttemptResultOfOutput output = some (index, leaves)) : + ∃ (attemptIndex : Nat) (randomness : Randomness), + attemptIndex < attempts + ∧ targetPayload = messageDigestPayload secretKey.root message randomness + ∧ result = some (randomness, index, leaves) := by + induction attempts generalizing beforeCache afterCache result with + | zero => + simp only [signDigestLoop, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff, Prod.mk.injEq] at hmem + obtain ⟨rfl, rfl⟩ := hmem + rw [hbefore] at hafter + simp at hafter + | succ attempts ih => + rw [signDigestLoop_run_succ_eq, mem_support_bind_iff] at hmem + obtain ⟨randomness, _hrandomness, hrest⟩ := hmem + rw [mem_support_bind_iff] at hrest + obtain ⟨⟨attempt, attemptCache⟩, hattempt, hfinish⟩ := hrest + have hattempt' : (attempt, attemptCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAttempt secretKey message randomness)).run beforeCache) := by + simpa only [simulateQ_romImpl_liftM] using hattempt + by_cases heqPayload : targetPayload = + messageDigestPayload secretKey.root message randomness + · let targetInput := tweakableHashInput secretKey.parameter .message targetPayload + have hqueried : attemptCache targetInput ≠ none := by + obtain ⟨_, answerFn, _, _, hqueries⟩ := + exists_answerFn_replay_of_mem_support + (signAttempt secretKey message randomness) beforeCache attempt attemptCache + hattempt' + apply hqueries targetInput + rw [queriedInputs_signAttempt] + simp [targetInput, heqPayload] + obtain ⟨attemptOutput, hattemptOutput⟩ := Option.ne_none_iff_exists'.mp hqueried + have hattemptLe : attemptCache ≤ afterCache := by + cases hattemptResult : attempt with + | none => + exact simulateQ_romImpl_cache_le + (signDigestLoop attempts secretKey message) attemptCache + (result, afterCache) (by + simpa [signDigestLoopContinuation, hattemptResult] using hfinish) + | some selected => + have hpure : (result, afterCache) = + (some (randomness, selected.1, selected.2), attemptCache) := by + simpa [signDigestLoopContinuation, hattemptResult] using hfinish + have hcache : afterCache = attemptCache := congrArg Prod.snd hpure + rw [hcache] + have hattemptOutputEq : attemptOutput = output := by + have := hattemptLe hattemptOutput + rw [hafter] at this + exact Option.some.inj this.symm + have hattemptResult : attempt = some (index, leaves) := by + have hattemptOutput' : attemptCache + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = + some attemptOutput := by + rw [← heqPayload] + exact hattemptOutput + rw [signAttempt_result_of_cached secretKey message randomness beforeCache attemptCache + attempt attemptOutput hattemptOutput' hattempt', hattemptOutputEq, houtput] + have hresult : result = some (randomness, index, leaves) := by + have hpure : (result, afterCache) = + (some (randomness, index, leaves), attemptCache) := by + simpa [signDigestLoopContinuation, hattemptResult] using hfinish + exact congrArg Prod.fst hpure + refine ⟨0, randomness, ?_⟩ + constructor + · omega + constructor + · exact heqPayload + · exact hresult + · have hattemptNone : attemptCache + (tweakableHashInput secretKey.parameter .message targetPayload) = none := by + apply signAttempt_cache_other_none secretKey message randomness beforeCache attemptCache + attempt hattempt' _ hbefore + intro hinput + have hpayload := (tweakableHashInput_injective secretKey.parameter (by trivial) + (by trivial) hinput).2 + exact heqPayload hpayload + cases hattemptResult : attempt with + | none => + have hfuture : (result, afterCache) ∈ support + ((simulateQ romImpl + (signDigestLoop attempts secretKey message)).run attemptCache) := by + simpa [signDigestLoopContinuation, hattemptResult] using hfinish + obtain ⟨attemptIndex, sourceRandomness, hattemptIndex, hpayload, hresult⟩ := + ih attemptCache afterCache result hfuture hattemptNone hafter + exact ⟨attemptIndex + 1, sourceRandomness, by omega, hpayload, hresult⟩ + | some selected => + have hcache : afterCache = attemptCache := by + have hpure : (result, afterCache) = + (some (randomness, selected.1, selected.2), attemptCache) := by + simpa [signDigestLoopContinuation, hattemptResult] using hfinish + exact congrArg Prod.snd hpure + rw [hcache, hattemptNone] at hafter + simp at hafter + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeNumberedSources.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeNumberedSources.lean new file mode 100644 index 00000000..bf712421 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeNumberedSources.lean @@ -0,0 +1,377 @@ +import SphincsSecurity.Proof.FewTimeOriginSampler +import SphincsSecurity.Proof.DirectQueryBudget + +/-! +# Numbering direct few-time sources + +The full trace numbers every adversary interval, including signing calls and sampling queries. This +module gives selected prehits a separate injective numbering in the direct hash-query list, which is +the source index space used by the weighted sampler. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +noncomputable def FewTimeCover.precachedPatternSelected {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) : + Finset cover.pattern.selected := + (cover.precachedEntryFinset trace hlog).map cover.entriesEquivPatternSelected.toEmbedding + +noncomputable def FewTimeCover.precachedOfPatternSelected {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (selected : ↑(cover.precachedPatternSelected trace hlog)) : + cover.PrecachedEntries trace hlog := by + classical + let equivalence := cover.entriesEquivPatternSelected + let entry := equivalence.symm selected.1 + refine ⟨entry, ?_⟩ + have hmem : entry ∈ cover.precachedEntryFinset trace hlog := by + obtain ⟨original, horiginal, heq⟩ := Finset.mem_map.1 selected.2 + have horiginalEq : original = entry := by + apply equivalence.injective + rw [equivalence.apply_symm_apply] + exact heq + rw [← horiginalEq] + exact horiginal + exact (Finset.mem_filter.mp hmem).2 + +theorem FewTimeCover.precachedOfPatternSelected_entry {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (selected : ↑(cover.precachedPatternSelected trace hlog)) : + (cover.precachedOfPatternSelected trace hlog selected).1 = + cover.entriesEquivPatternSelected.symm selected.1 := rfl + +theorem FewTimeCover.mem_precachedPatternSelected_iff {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (selected : cover.pattern.selected) : + selected ∈ cover.precachedPatternSelected trace hlog ↔ + cover.EntryDigestPrecached trace hlog + (cover.entriesEquivPatternSelected.symm selected) := by + classical + rw [FewTimeCover.precachedPatternSelected, Finset.mem_map] + constructor + · rintro ⟨entry, hentry, heq⟩ + have hentryEq : entry = cover.entriesEquivPatternSelected.symm selected := by + apply cover.entriesEquivPatternSelected.injective + rw [cover.entriesEquivPatternSelected.apply_symm_apply] + exact heq + rw [← hentryEq] + exact (Finset.mem_filter.mp hentry).2 + · intro hprehit + refine ⟨cover.entriesEquivPatternSelected.symm selected, ?_, ?_⟩ + · exact Finset.mem_filter.2 ⟨Finset.mem_univ _, hprehit⟩ + · exact cover.entriesEquivPatternSelected.apply_symm_apply selected + +noncomputable def FewTimeCover.originConfiguration {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (sources : Nat) + (source : cover.PrecachedEntries trace hlog → Fin sources) + (hsource : Function.Injective source) : OriginConfiguration cover.pattern sources := by + classical + let selectedPrehits := cover.precachedPatternSelected trace hlog + refine ⟨selectedPrehits, + ⟨fun selected => source (cover.precachedOfPatternSelected trace hlog selected), ?_⟩⟩ + intro left right heq + have hasPrecached : cover.precachedOfPatternSelected trace hlog left = + cover.precachedOfPatternSelected trace hlog right := hsource heq + apply Subtype.ext + have hentries := congrArg (fun entry : cover.PrecachedEntries trace hlog => entry.1) + hasPrecached + exact cover.entriesEquivPatternSelected.symm.injective hentries + +theorem FewTimeCover.originConfiguration_source_apply {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (sources : Nat) (source : cover.PrecachedEntries trace hlog → Fin sources) + (hsource : Function.Injective source) + (selected : ↑(cover.originConfiguration trace hlog sources source hsource).prehit) : + (cover.originConfiguration trace hlog sources source hsource).source.1 selected = + source (cover.precachedOfPatternSelected trace hlog selected) := rfl + +theorem FewTimeCover.originConfiguration_prehit_card {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (sources : Nat) + (source : cover.PrecachedEntries trace hlog → Fin sources) + (hsource : Function.Injective source) : + (cover.originConfiguration trace hlog sources source hsource).prehit.card = + (cover.precachedEntryFinset trace hlog).card := by + classical + simp [FewTimeCover.originConfiguration, FewTimeCover.precachedPatternSelected] + +theorem FewTimeCover.precached_entries_have_injective_numbered_sources + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.1.AgreesWithFn f) + (index : Index) (targetLeaves : DigestTree → FtsLeaf) + (cover : FewTimeCover f result.2.1 + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.signing.toSigningLog index targetLeaves) : + ∃ (source : cover.PrecachedEntries result.2.2.signing rfl → + Fin result.2.2.hashQueries.length) + (intervalSource : cover.PrecachedEntries result.2.2.signing rfl → + Fin result.2.2.intervals.length) + (selectedInterval : cover.PrecachedEntries result.2.2.signing rfl → + Fin result.2.2.intervals.length) + (output : cover.PrecachedEntries result.2.2.signing rfl → HashOutput), + Function.Injective source + ∧ Function.Injective intervalSource + ∧ ∀ entry, ∃ hdirect : isDirectHashQuery + (result.2.2.intervals.get (intervalSource entry)).input, + (source entry).val = + (Fin.encodeSubtype (fun position => + isDirectHashQuery (result.2.2.intervals.get position).input) + ⟨intervalSource entry, hdirect⟩).val + ∧ (intervalSource entry).val < (selectedInterval entry).val + ∧ AdversaryCacheEntry.signingEntry? + (result.2.2.intervals.get (selectedInterval entry)) = + some (cover.cacheEntry result.2.2.signing rfl entry.1) + ∧ ((result.2.2.intervals.take (selectedInterval entry).val).filterMap + AdversaryCacheEntry.signingEntry?).length = (cover.logIndex entry.1).val + ∧ (result.2.2.intervals.get (intervalSource entry)).input = + .inl (.inr (cover.entryDigestInput entry.1)) + ∧ (result.2.2.intervals.get (intervalSource entry)).initialCache + (cover.entryDigestInput entry.1) = none + ∧ (output entry, + (result.2.2.intervals.get (intervalSource entry)).finalCache) ∈ support + ((randomOracle (cover.entryDigestInput entry.1)).run + (result.2.2.intervals.get (intervalSource entry)).initialCache) + ∧ signAttemptResultOfOutput (output entry) ≠ none + ∧ hashOutputFewTimeView (output entry) = cover.entryView entry.1 := by + classical + obtain ⟨intervalSource, selectedInterval, output, hintervalInjective, hinterval⟩ := + cover.precached_entries_have_injective_fresh_direct_view_sources adversary parameter + otsSecret ftsSecret result hresult f hf index targetLeaves + let directSource : cover.PrecachedEntries result.2.2.signing rfl → + {position : Fin result.2.2.intervals.length // + isDirectHashQuery (result.2.2.intervals.get position).input} := + fun entry => ⟨intervalSource entry, by rw [(hinterval entry).2.2.2.1]; trivial⟩ + have hdirectInjective : Function.Injective directSource := by + intro left right heq + exact hintervalInjective (congrArg Subtype.val heq) + let encodedSource : cover.PrecachedEntries result.2.2.signing rfl → + Fin (Fin.countP fun position => + isDirectHashQuery (result.2.2.intervals.get position).input) := + fun entry => Fin.encodeSubtype _ (directSource entry) + have hencodedInjective : Function.Injective encodedSource := by + exact Function.Injective.comp + (Function.LeftInverse.injective (Fin.decodeSubtype_encodeSubtype _)) hdirectInjective + have hconsistent := + (gameAfterSecretsWithFullTrace_support_interval_invariants adversary parameter otsSecret + ftsSecret result hresult).1 + have hcount : Fin.countP (fun position => + isDirectHashQuery (result.2.2.intervals.get position).input) = + result.2.2.hashQueries.length := by + rw [FullAdversaryTrace.hashQueries, ← hconsistent.1] + exact adversaryIntervals_directHashCount result.2.2.intervals + let source : cover.PrecachedEntries result.2.2.signing rfl → + Fin result.2.2.hashQueries.length := fun entry => Fin.cast hcount (encodedSource entry) + have hsourceInjective : Function.Injective source := by + exact Function.Injective.comp (Fin.cast_injective hcount) hencodedInjective + refine ⟨source, intervalSource, selectedInterval, output, hsourceInjective, + hintervalInjective, ?_⟩ + intro entry + refine ⟨(directSource entry).2, rfl, hinterval entry⟩ + +private theorem AdversaryCacheEntry.queryEntry_eq_of_direct_hash_runs + (secretKey : SecretKey) (entry : AdversaryCacheEntry) (target : HashInput) + (output : HashOutput) (hinput : entry.input = .inl (.inr target)) + (hvalid : (entry.output, entry.finalCache) ∈ support + ((unloggedMappedAdversaryImpl secretKey entry.input).run entry.initialCache)) + (hrun : (output, entry.finalCache) ∈ support + ((randomOracle target).run entry.initialCache)) : + entry.queryEntry = + (⟨.inl (.inr target), output⟩ : + (query : (OracleWorld + SigningSpec).Domain) × + (OracleWorld + SigningSpec).Range query) := by + rcases entry with ⟨input, entryOutput, initialCache, finalCache⟩ + cases input with + | inr request => simp at hinput + | inl worldInput => + cases worldInput with + | inl uniformInput => simp at hinput + | inr hashInput => + simp only [Sum.inl.injEq, Sum.inr.injEq] at hinput + subst hashInput + change (entryOutput, finalCache) ∈ support + ((randomOracle target).run initialCache) at hvalid + have hcachedEntry := randomOracle_run_output_cached target initialCache finalCache + entryOutput hvalid + have hcachedOutput := randomOracle_run_output_cached target initialCache finalCache + output hrun + have heq : entryOutput = output := + Option.some.inj (hcachedEntry.symm.trans hcachedOutput) + subst output + rfl + +theorem FewTimeCover.precached_entries_have_numbered_source_entries + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.1.AgreesWithFn f) + (index : Index) (targetLeaves : DigestTree → FtsLeaf) + (cover : FewTimeCover f result.2.1 + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.signing.toSigningLog index targetLeaves) : + ∃ (source : cover.PrecachedEntries result.2.2.signing rfl → + Fin result.2.2.hashQueries.length) + (intervalSource : cover.PrecachedEntries result.2.2.signing rfl → + Fin result.2.2.intervals.length) + (output : cover.PrecachedEntries result.2.2.signing rfl → HashOutput), + Function.Injective source + ∧ Function.Injective intervalSource + ∧ ∀ entry, + result.2.2.hashQueries.get (source entry) = + (cover.entryDigestInput entry.1, output entry) + ∧ (result.2.2.intervals.get (intervalSource entry)).input = + .inl (.inr (cover.entryDigestInput entry.1)) + ∧ (result.2.2.intervals.get (intervalSource entry)).initialCache + (cover.entryDigestInput entry.1) = none + ∧ (output entry, + (result.2.2.intervals.get (intervalSource entry)).finalCache) ∈ support + ((randomOracle (cover.entryDigestInput entry.1)).run + (result.2.2.intervals.get (intervalSource entry)).initialCache) + ∧ signAttemptResultOfOutput (output entry) ≠ none + ∧ hashOutputFewTimeView (output entry) = cover.entryView entry.1 := by + classical + obtain ⟨_numberedSource, intervalSource, _selectedInterval, output, _hnumberedInjective, + hintervalInjective, hnumbered⟩ := + cover.precached_entries_have_injective_numbered_sources adversary parameter otsSecret + ftsSecret result hresult f hf index targetLeaves + have hinterval : ∀ entry, + (result.2.2.intervals.get (intervalSource entry)).input = + .inl (.inr (cover.entryDigestInput entry.1)) + ∧ (result.2.2.intervals.get (intervalSource entry)).initialCache + (cover.entryDigestInput entry.1) = none + ∧ (output entry, + (result.2.2.intervals.get (intervalSource entry)).finalCache) ∈ support + ((randomOracle (cover.entryDigestInput entry.1)).run + (result.2.2.intervals.get (intervalSource entry)).initialCache) + ∧ signAttemptResultOfOutput (output entry) ≠ none + ∧ hashOutputFewTimeView (output entry) = cover.entryView entry.1 := by + intro entry + exact (hnumbered entry).choose_spec.2.2.2.2 + have hvalid := gameAfterSecretsWithFullTrace_support_validIntervals adversary parameter + otsSecret ftsSecret result hresult + have hconsistent := (gameAfterSecretsWithFullTrace_support_interval_invariants adversary + parameter otsSecret ftsSecret result hresult).1 + let pair : cover.PrecachedEntries result.2.2.signing rfl → HashInput × HashOutput := + fun entry => (cover.entryDigestInput entry.1, output entry) + have hpairMem : ∀ entry, pair entry ∈ result.2.2.hashQueries := by + intro entry + let interval := result.2.2.intervals.get (intervalSource entry) + have hqueryEntry := AdversaryCacheEntry.queryEntry_eq_of_direct_hash_runs + (⟨parameter, result.1.1, otsSecret, ftsSecret⟩ : SecretKey) interval + (cover.entryDigestInput entry.1) (output entry) (hinterval entry).1 + (hvalid interval (List.get_mem _ _)) (hinterval entry).2.2.1 + rw [FullAdversaryTrace.hashQueries, mem_directHashQueries_iff] + rw [← hconsistent.1] + apply List.mem_map.2 + exact ⟨interval, List.get_mem _ _, hqueryEntry⟩ + let source : cover.PrecachedEntries result.2.2.signing rfl → + Fin result.2.2.hashQueries.length := fun entry => + ⟨result.2.2.hashQueries.idxOf (pair entry), + List.idxOf_lt_length_of_mem (hpairMem entry)⟩ + have hsourceGet : ∀ entry, + result.2.2.hashQueries.get (source entry) = pair entry := by + intro entry + exact List.idxOf_get _ + have hsourceInjective : Function.Injective source := by + intro left right heq + apply Subtype.ext + apply cover.entryDigestInput_injective + have hpairs : pair left = pair right := by + rw [← hsourceGet left, heq, hsourceGet right] + exact congrArg Prod.fst hpairs + exact ⟨source, intervalSource, output, hsourceInjective, hintervalInjective, + fun entry => ⟨hsourceGet entry, hinterval entry⟩⟩ + +theorem FewTimeCover.has_originConfiguration_of_hashQueries_length_le + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.1.AgreesWithFn f) + (index : Index) (targetLeaves : DigestTree → FtsLeaf) + (cover : FewTimeCover f result.2.1 + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.signing.toSigningLog index targetLeaves) + (q : Nat) (hqueries : result.2.2.hashQueries.length ≤ q) : + ∃ configuration : OriginConfiguration cover.pattern q, + configuration.prehit.card = + (cover.precachedEntryFinset result.2.2.signing rfl).card := by + classical + obtain ⟨numberedSource, _intervalSource, _selectedInterval, _output, + hnumberedInjective, _, _⟩ := + cover.precached_entries_have_injective_numbered_sources adversary parameter otsSecret + ftsSecret result hresult f hf index targetLeaves + let source : cover.PrecachedEntries result.2.2.signing rfl → Fin q := + fun entry => Fin.castLE hqueries (numberedSource entry) + have hsourceInjective : Function.Injective source := by + exact Function.Injective.comp (finCastLEEmbedding hqueries).injective hnumberedInjective + let configuration := cover.originConfiguration result.2.2.signing rfl q source + hsourceInjective + exact ⟨configuration, + cover.originConfiguration_prehit_card result.2.2.signing rfl q source hsourceInjective⟩ + +theorem FewTimeCover.has_originConfiguration_of_queryBudget + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.1.AgreesWithFn f) + (index : Index) (targetLeaves : DigestTree → FtsLeaf) + (cover : FewTimeCover f result.2.1 + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.signing.toSigningLog index targetLeaves) : + ∃ configuration : OriginConfiguration cover.pattern q, + configuration.prehit.card = + (cover.precachedEntryFinset result.2.2.signing rfl).card := by + exact cover.has_originConfiguration_of_hashQueries_length_le adversary parameter otsSecret + ftsSecret result hresult f hf index targetLeaves q + (gameAfterSecretsWithFullTrace_hashQueries_length_le adversary q hq parameter hparameter + otsSecret hots ftsSecret hfts result hresult) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeOccupancyCount.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeOccupancyCount.lean new file mode 100644 index 00000000..a4785aa9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeOccupancyCount.lean @@ -0,0 +1,85 @@ +import SphincsSecurity.Proof.FewTimeWeightedHonestLeak +import SphincsSecurity.Proof.MandatoryQueries + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +set_option exponentiation.threshold 600 + +theorem digestOriginInflation_le_eleven_eighths (q : Nat) (hq : q ≤ 2 ^ 126) : + 1 + (q : ℝ≥0∞) * + (((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * digestReuseWeight q) ≤ 11 / 8 := by + rw [digestReuseWeight_source] + have hden : ((2 ^ randomnessBits - (2 ^ 126 + digestAttemptLimit) : Nat) : ℝ≥0∞) ≤ + ((2 ^ randomnessBits : Nat) : ℝ≥0∞) - (q + digestAttemptLimit : Nat) := by + rw [ENNReal.natCast_sub] + exact tsub_le_tsub_left (Nat.cast_le.mpr (Nat.add_le_add_right hq _)) _ + have hinv : ((2 ^ randomnessBits - (2 ^ 126 + digestAttemptLimit) : Nat) : ℝ≥0∞)⁻¹ ≠ ∞ := by + apply ENNReal.inv_ne_top.mpr + norm_num [randomnessBits, digestAttemptLimit] + have hmul : ((2 ^ 126 : Nat) : ℝ≥0∞) * + ((2 ^ randomnessBits - (2 ^ 126 + digestAttemptLimit) : Nat) : ℝ≥0∞)⁻¹ ≠ ∞ := + ENNReal.mul_ne_top (by finiteness) hinv + calc + _ ≤ 1 + ((2 ^ 126 : Nat) : ℝ≥0∞) * + ((2 ^ randomnessBits - (2 ^ 126 + digestAttemptLimit) : Nat) : ℝ≥0∞)⁻¹ := + add_le_add_right (mul_le_mul' (Nat.cast_le.mpr hq) (ENNReal.inv_le_inv.mpr hden)) _ + _ ≤ _ := by + apply (ENNReal.toReal_le_toReal (ENNReal.add_ne_top.mpr ⟨by finiteness, hmul⟩) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) hmul] + norm_num [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_div, + randomnessBits, digestAttemptLimit] + +theorem weightedFewTime_occupancy_scaled_certificate : + (∑ d ∈ Finset.Icc 1 14, + (d + 1).ascFactorial (14 - d) * 2 ^ (24 * d) * d ^ 14 * + 11 ^ d * 2 ^ (29 * (14 - d))) ≤ Nat.factorial 14 * (11 * 2 ^ 422) := by + decide + +theorem weightedRawTargetOriginUnionBound_le_eleven_mul_inv134 + {signatures q : Nat} (hsignatures : signatures ≤ signatureLimit) (hq : q ≤ 2 ^ 126) : + weightedRawTargetOriginUnionBound signatures q (digestReuseWeight q) ≤ + 11 * ((2 ^ 134 : Nat) : ℝ≥0∞)⁻¹ := by + have hweight : 1 + (q : ℝ≥0∞) * + (((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * digestReuseWeight q) ≤ (11 : ℝ≥0∞) / 2 ^ 3 := by + simpa only [show (2 : ℝ≥0∞) ^ 3 = 8 by norm_num] using + digestOriginInflation_le_eleven_eighths q hq + rw [weightedRawTargetOriginUnionBound_eq] + apply (mul_le_mul' le_rfl (parametricFewTimePatternBound_le_of_origin_weight _ + hsignatures hweight weightedFewTime_occupancy_scaled_certificate)).trans_eq + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + norm_num [ENNReal.toReal_mul, ENNReal.toReal_inv, ftsTreeHeight] + +theorem probEvent_gameAfterSecretsWithViewTrace_honest_leak_le_twenty_three_mul_inv134 + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + ((23 * q : Nat) : ℝ≥0∞) * ((2 ^ 134 : Nat) : ℝ≥0∞)⁻¹ := by + have hminimum := numChains_le_of_hasHashQueryBound adversary q hq + parameter hparameter otsSecret hots ftsSecret hfts + norm_num [numChains] at hminimum + calc + _ ≤ q * weightedRawTargetOriginUnionBound signatureLimit q (digestReuseWeight q) + + ((q + 1 : Nat) : ℝ≥0∞) * + weightedRawTargetOriginUnionBound signatureLimit q (digestReuseWeight q) := + probEvent_gameAfterSecretsWithViewTrace_honest_leak_le_weighted adversary q hq + (hqMax.trans (by norm_num)) parameter hparameter otsSecret hots ftsSecret hfts + _ = ((2 * q + 1 : Nat) : ℝ≥0∞) * + weightedRawTargetOriginUnionBound signatureLimit q (digestReuseWeight q) := by + push_cast + ring + _ ≤ ((2 * q + 1 : Nat) : ℝ≥0∞) * (11 * ((2 ^ 134 : Nat) : ℝ≥0∞)⁻¹) := + mul_le_mul' le_rfl (weightedRawTargetOriginUnionBound_le_eleven_mul_inv134 le_rfl hqMax) + _ = (((2 * q + 1) * 11 : Nat) : ℝ≥0∞) * ((2 ^ 134 : Nat) : ℝ≥0∞)⁻¹ := by + push_cast + ring + _ ≤ _ := mul_le_mul' (Nat.cast_le.mpr (by omega)) le_rfl + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginCandidates.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginCandidates.lean new file mode 100644 index 00000000..8d8bf5f8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginCandidates.lean @@ -0,0 +1,204 @@ +import SphincsSecurity.Proof.FewTimeOriginSampler +import SphincsSecurity.Proof.FewTimePadding + +/-! +# Candidate targets for the origin-weighted few-time bound + +The forgery's message-digest view can be identified only after the adversary returns. This module +allows the origin-weighted ideal count to expose a finite table of candidate target views and pays +once for each candidate. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +abbrev OriginConfiguration.CandidateSample {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (candidates : Nat) := + ((pattern.selected → FewTimeView) × (Fin candidates → FewTimeView)) × + BitVec (127 * configuration.prehit.card) + +def OriginConfiguration.HitCandidates {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (candidates : Nat) + (sample : configuration.CandidateSample candidates) : Prop := + ∃ candidate, + FixedFewTimePatternHit pattern.assignment + (sample.1.1, sample.1.2 candidate) ∧ sample.2 = 0 + +noncomputable instance {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (candidates : Nat) : + DecidablePred (configuration.HitCandidates candidates) := + fun sample => Classical.propDecidable (configuration.HitCandidates candidates sample) + +noncomputable def originCandidateViewsSample {signatures distinct : Nat} + (pattern : FewTimePattern signatures distinct) (candidates : Nat) : + ProbComp ((pattern.selected → FewTimeView) × (Fin candidates → FewTimeView)) := do + let views ← $ᵗ (pattern.selected → FewTimeView) + let targets ← $ᵗ (Fin candidates → FewTimeView) + pure (views, targets) + +noncomputable def originCandidateSample {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (candidates : Nat) : + ProbComp (configuration.CandidateSample candidates) := do + let views ← originCandidateViewsSample pattern candidates + let activation ← $ᵗ BitVec (127 * configuration.prehit.card) + pure (views, activation) + +theorem evalDist_originCandidateViews_target {signatures distinct candidates : Nat} + (pattern : FewTimePattern signatures distinct) (candidate : Fin candidates) : + 𝒟[(fun sample => (sample.1, sample.2 candidate)) <$> + originCandidateViewsSample pattern candidates] = + 𝒟[($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : + ProbComp ((pattern.selected → FewTimeView) × FewTimeView))] := by + calc + _ = 𝒟[(do + let views ← $ᵗ (pattern.selected → FewTimeView) + let target ← $ᵗ FewTimeView + pure (views, target))] := by + rw [originCandidateViewsSample] + simp only [map_eq_bind_pure_comp, bind_assoc, pure_bind, Function.comp_apply] + apply evalDist_bind_congr + intro views _ + change 𝒟[(fun targets : Fin candidates → FewTimeView => + (views, targets candidate)) <$> + ($ᵗ (Fin candidates → FewTimeView) : + ProbComp (Fin candidates → FewTimeView))] = + 𝒟[(fun target : FewTimeView => (views, target)) <$> + ($ᵗ FewTimeView : ProbComp FewTimeView)] + calc + _ = 𝒟[(fun target : FewTimeView => (views, target)) <$> + ((fun targets : Fin candidates → FewTimeView => targets candidate) <$> + ($ᵗ (Fin candidates → FewTimeView) : + ProbComp (Fin candidates → FewTimeView)))] := by + simp [Functor.map_map] + _ = _ := by + rw [evalDist_map, evalDist_uniformCandidateFunctionEval candidate, ← evalDist_map] + _ = _ := evalDist_independent_uniform_pair + +theorem evalDist_originCandidateSample_target {signatures distinct sources candidates : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (candidate : Fin candidates) : + 𝒟[(fun sample => ((sample.1.1, sample.1.2 candidate), sample.2)) <$> + originCandidateSample configuration candidates] = + 𝒟[($ᵗ configuration.Sample : ProbComp configuration.Sample)] := by + let activationSampler := + ($ᵗ BitVec (127 * configuration.prehit.card) : + ProbComp (BitVec (127 * configuration.prehit.card))) + calc + _ = 𝒟[(do + let views ← (fun sample : + (pattern.selected → FewTimeView) × (Fin candidates → FewTimeView) => + (sample.1, sample.2 candidate)) <$> + originCandidateViewsSample pattern candidates + let activation ← activationSampler + pure (views, activation))] := by + simp [originCandidateSample, activationSampler, map_eq_bind_pure_comp, bind_assoc] + _ = 𝒟[(do + let views ← $ᵗ ((pattern.selected → FewTimeView) × FewTimeView) + let activation ← activationSampler + pure (views, activation))] := by + rw [evalDist_bind, evalDist_originCandidateViews_target pattern candidate, + ← evalDist_bind] + _ = _ := by + simpa [activationSampler] using + (evalDist_independent_uniform_pair + (α := (pattern.selected → FewTimeView) × FewTimeView) + (β := BitVec (127 * configuration.prehit.card))) + +theorem probEvent_originConfiguration_hitCandidate {signatures distinct sources candidates : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (candidate : Fin candidates) : + Pr[fun sample => + FixedFewTimePatternHit pattern.assignment + (sample.1.1, sample.1.2 candidate) ∧ sample.2 = 0 | + originCandidateSample configuration candidates] = + Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] := by + calc + _ = Pr[configuration.Hit | + (fun sample => ((sample.1.1, sample.1.2 candidate), sample.2)) <$> + originCandidateSample configuration candidates] := by + rw [probEvent_map] + rfl + _ = _ := probEvent_congr' (fun _ _ => Iff.rfl) + (evalDist_originCandidateSample_target configuration candidate) + +theorem probEvent_originConfiguration_hitCandidates_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (candidates : Nat) : + Pr[configuration.HitCandidates candidates | + originCandidateSample configuration candidates] ≤ + candidates * Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] := by + classical + let sampler := originCandidateSample configuration candidates + calc + Pr[configuration.HitCandidates candidates | sampler] = + Pr[fun sample => ∃ candidate ∈ (Finset.univ : Finset (Fin candidates)), + FixedFewTimePatternHit pattern.assignment + (sample.1.1, sample.1.2 candidate) ∧ sample.2 = 0 | sampler] := by + congr 1 + funext sample + simp [OriginConfiguration.HitCandidates] + _ ≤ ∑ candidate ∈ (Finset.univ : Finset (Fin candidates)), + Pr[fun sample => FixedFewTimePatternHit pattern.assignment + (sample.1.1, sample.1.2 candidate) ∧ sample.2 = 0 | sampler] := + probEvent_exists_finset_le_sum Finset.univ sampler + (fun candidate sample => FixedFewTimePatternHit pattern.assignment + (sample.1.1, sample.1.2 candidate) ∧ sample.2 = 0) + _ = ∑ _candidate ∈ (Finset.univ : Finset (Fin candidates)), + Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] := by + apply Finset.sum_congr rfl + intro candidate _ + exact probEvent_originConfiguration_hitCandidate configuration candidate + _ = candidates * Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] := by + rw [Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul] + +noncomputable def idealOriginCandidateUnionBound + (signatures sources candidates : Nat) : ℝ≥0∞ := + ∑ distinct ∈ Finset.Icc 1 14, + ∑ pattern : FewTimePattern signatures distinct, + ∑ configuration : OriginConfiguration pattern sources, + Pr[configuration.HitCandidates candidates | + originCandidateSample configuration candidates] + +theorem idealOriginCandidateUnionBound_le_origin + (signatures sources candidates : Nat) : + idealOriginCandidateUnionBound signatures sources candidates ≤ + candidates * idealOriginUnionBound signatures sources := by + classical + rw [idealOriginCandidateUnionBound, idealOriginUnionBound] + calc + _ ≤ ∑ distinct ∈ Finset.Icc 1 14, + ∑ pattern : FewTimePattern signatures distinct, + ∑ configuration : OriginConfiguration pattern sources, + candidates * Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] := by + apply Finset.sum_le_sum + intro distinct _ + apply Finset.sum_le_sum + intro pattern _ + apply Finset.sum_le_sum + intro configuration _ + exact probEvent_originConfiguration_hitCandidates_le configuration candidates + _ = _ := by + simp_rw [← Finset.mul_sum] + +theorem idealOriginCandidateUnionBound_le {signatures sources candidates : Nat} + (hsignatures : signatures ≤ signatureLimit) (hsources : sources ≤ 2 ^ 120) : + idealOriginCandidateUnionBound signatures sources candidates ≤ + candidates * ((2 ^ 121 : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ ≤ candidates * idealOriginUnionBound signatures sources := + idealOriginCandidateUnionBound_le_origin signatures sources candidates + _ ≤ _ := by + gcongr + exact idealOriginUnionBound_le hsignatures hsources + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginInvariant.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginInvariant.lean new file mode 100644 index 00000000..d2b06d36 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginInvariant.lean @@ -0,0 +1,1140 @@ +import SphincsSecurity.Proof.FewTimeOriginPotential + +/-! +# One-step invariant for the few-time origin monitor + +The partial-observation potential is a supermartingale for every query handled by the monitored +adversary implementation. Configured direct sources and signer calls use the local probabilistic +bounds; unconfigured calls preserve the potential exactly. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +namespace Concrete + +noncomputable def OriginMonitorState.afterDirect {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (input : HashInput) (output : HashOutput) : + OriginMonitorState configuration := + let monitored := monitorDirectSource state input output + { state with + observation := monitored.1 + directOrdinal := state.directOrdinal + 1 + valid := monitored.2 } + +noncomputable def OriginMonitorState.afterSigner {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (request : SignRequest) + (state : OriginMonitorState configuration) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) : + OriginMonitorState configuration := + let monitored := monitorSigner secretKey request state result + { state with + observation := monitored.1 + signerOrdinal := state.signerOrdinal + 1 + valid := monitored.2 } + +theorem OriginMonitorState.potential_afterDirect_of_sourceAt?_eq_none + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (input : HashInput) (output : HashOutput) + (event : (pattern.selected → FewTimeView) → Prop) + (hsource : configuration.sourceAt? state.directOrdinal = none) : + (state.afterDirect input output).potential event = state.potential event := by + classical + simp [OriginMonitorState.afterDirect, monitorDirectSource, hsource, + OriginMonitorState.potential, OriginMonitorState.pendingSources, + OriginMonitorState.pendingReuses, OriginMonitorState.completionMass] + +theorem OriginMonitorState.potential_afterDirect_eq_zero_of_invalid + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (input : HashInput) (output : HashOutput) + (event : (pattern.selected → FewTimeView) → Prop) + (hinvalid : state.valid = false) : + (state.afterDirect input output).potential event = 0 := by + classical + have hafter : (state.afterDirect input output).valid = false := by + cases hsource : configuration.sourceAt? state.directOrdinal with + | none => + simp [OriginMonitorState.afterDirect, monitorDirectSource, hsource, hinvalid] + | some selected => + by_cases hcondition : state.viewed.cache input = none ∧ + signAttemptResultOfOutput output ≠ none + · simp [OriginMonitorState.afterDirect, monitorDirectSource, hsource, hcondition, + hinvalid] + · simp [OriginMonitorState.afterDirect, monitorDirectSource, hsource, hcondition] + simp [OriginMonitorState.potential, hafter] + +theorem OriginMonitorState.potential_afterDirect_eq_zero_of_source_failure + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : ↑configuration.prehit) + (input : HashInput) (output : HashOutput) + (event : (pattern.selected → FewTimeView) → Prop) + (hsource : configuration.sourceAt? state.directOrdinal = some selected) + (hfailure : ¬ (state.viewed.cache input = none ∧ + signAttemptResultOfOutput output ≠ none)) : + (state.afterDirect input output).potential event = 0 := by + classical + simp [OriginMonitorState.afterDirect, monitorDirectSource, hsource, hfailure, + OriginMonitorState.potential] + +theorem OriginMonitorState.potential_afterDirect_eq_recordSourceState + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : ↑configuration.prehit) + (input : HashInput) (output : HashOutput) + (event : (pattern.selected → FewTimeView) → Prop) + (hsource : configuration.sourceAt? state.directOrdinal = some selected) + (hcache : state.viewed.cache input = none) + (hsuccess : signAttemptResultOfOutput output ≠ none) : + (state.afterDirect input output).potential event = + (state.recordSourceState selected input (hashOutputFewTimeView output)).potential event := by + classical + simp [OriginMonitorState.afterDirect, monitorDirectSource, hsource, hcache, hsuccess, + OriginMonitorState.recordSourceState, OriginMonitorState.potential, + OriginMonitorState.pendingSources, OriginMonitorState.pendingReuses, + OriginMonitorState.completionMass] + +theorem OriginMonitorState.expected_potential_afterDirect_le + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (input : HashInput) + (event : (pattern.selected → FewTimeView) → Prop) + (hcoherent : state.ScheduleCoherent) : + (∑' result, Pr[= result | (randomOracle input).run state.viewed.cache] * + (state.afterDirect input result.1).potential event) ≤ state.potential event := by + classical + cases hsource : configuration.sourceAt? state.directOrdinal with + | none => + simp_rw [state.potential_afterDirect_of_sourceAt?_eq_none input _ event hsource] + rw [ENNReal.tsum_mul_right] + calc + (∑' result, Pr[= result | (randomOracle input).run state.viewed.cache]) * + state.potential event ≤ 1 * state.potential event := by + gcongr + exact tsum_probOutput_le_one + _ = _ := one_mul _ + | some selected => + cases hvalid : state.valid with + | false => + simp_rw [state.potential_afterDirect_eq_zero_of_invalid input _ event hvalid] + simp [OriginMonitorState.potential, hvalid] + | true => + by_cases hcache : state.viewed.cache input = none + · calc + (∑' result, + Pr[= result | (randomOracle input).run state.viewed.cache] * + (state.afterDirect input result.1).potential event) ≤ + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (state.recordSourceState selected input view).potential event := by + apply tsum_probOutput_randomOracle_fresh_admissible_view_mul_le_expected + input state.viewed.cache hcache + (fun result => (state.afterDirect input result.1).potential event) + (fun view => (state.recordSourceState selected input view).potential event) + · intro result _ hfailed + apply state.potential_afterDirect_eq_zero_of_source_failure + selected input result.1 event hsource + simp [hcache, hfailed] + · intro result _ hsuccessful + rw [state.potential_afterDirect_eq_recordSourceState selected input result.1 + event hsource hcache hsuccessful] + _ = state.potential event := + state.sum_uniform_potential_recordSourceState selected input event hvalid + (state.sourceAt_not_seenSource selected hcoherent hvalid hsource) + (state.sourceAt_not_seenView selected hcoherent hvalid hsource) + (state.sourceAt_signer_pending selected hcoherent hvalid hsource) + · have hfailure : ∀ output : HashOutput, + ¬ (state.viewed.cache input = none ∧ + signAttemptResultOfOutput output ≠ none) := by + intro output hcondition + exact hcache hcondition.1 + simp_rw [state.potential_afterDirect_eq_zero_of_source_failure selected input _ event + hsource (hfailure _)] + simp + +theorem OriginMonitorState.potential_afterSigner_of_selectedAt?_eq_none + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (request : SignRequest) + (state : OriginMonitorState configuration) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) → Prop) + (hselected : pattern.selectedAt? state.signerOrdinal = none) : + (state.afterSigner secretKey request result).potential event = state.potential event := by + classical + rw [show state.afterSigner secretKey request result = state.advanceSigner by + simp [OriginMonitorState.afterSigner, monitorSigner, hselected, + OriginMonitorState.advanceSigner]] + exact state.potential_advanceSigner_of_selectedAt?_eq_none event hselected + +theorem OriginMonitorState.potential_afterSigner_eq_zero_of_invalid + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (request : SignRequest) + (state : OriginMonitorState configuration) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) → Prop) + (hinvalid : state.valid = false) : + (state.afterSigner secretKey request result).potential event = 0 := by + classical + have hafter : (state.afterSigner secretKey request result).valid = false := by + cases hselected : pattern.selectedAt? state.signerOrdinal with + | none => + simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hinvalid] + | some selected => + by_cases hprehit : selected ∈ configuration.prehit + · let prehit : ↑configuration.prehit := ⟨selected, hprehit⟩ + by_cases hcondition : prehit ∈ state.observation.seenSources ∧ + PrehitSuccessfulSignerView + (onlyInputCache state.viewed.cache (state.observation.sourceInputs prehit)) + secretKey request (fun view => view = state.observation.views selected) result + · simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hprehit, + prehit, hcondition, hinvalid] + · simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hprehit, + prehit, hcondition] + · cases hview : freshSuccessfulView? state.viewed.cache secretKey request result with + | none => + simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hprehit, hview] + | some view => + simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hprehit, hview, + hinvalid] + simp [OriginMonitorState.potential, hafter] + +theorem OriginMonitorState.potential_afterSigner_eq_zero_of_prehit_failure + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (request : SignRequest) + (state : OriginMonitorState configuration) (selected : pattern.selected) + (hprehit : selected ∈ configuration.prehit) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) → Prop) + (hselected : pattern.selectedAt? state.signerOrdinal = some selected) + (hfailure : ¬ ((⟨selected, hprehit⟩ : ↑configuration.prehit) ∈ + state.observation.seenSources ∧ + PrehitSuccessfulSignerView + (onlyInputCache state.viewed.cache + (state.observation.sourceInputs ⟨selected, hprehit⟩)) + secretKey request (fun view => view = state.observation.views selected) result)) : + (state.afterSigner secretKey request result).potential event = 0 := by + classical + simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hprehit, hfailure, + OriginMonitorState.potential] + +theorem OriginMonitorState.potential_afterSigner_eq_advanceSigner_of_prehit + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (request : SignRequest) + (state : OriginMonitorState configuration) (selected : pattern.selected) + (hprehit : selected ∈ configuration.prehit) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) → Prop) + (hselected : pattern.selectedAt? state.signerOrdinal = some selected) + (hseen : (⟨selected, hprehit⟩ : ↑configuration.prehit) ∈ + state.observation.seenSources) + (hsuccess : PrehitSuccessfulSignerView + (onlyInputCache state.viewed.cache + (state.observation.sourceInputs ⟨selected, hprehit⟩)) + secretKey request (fun view => view = state.observation.views selected) result) : + (state.afterSigner secretKey request result).potential event = + state.advanceSigner.potential event := by + classical + rw [show state.afterSigner secretKey request result = state.advanceSigner by + simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hprehit, hseen, hsuccess, + OriginMonitorState.advanceSigner]] + +theorem OriginMonitorState.potential_afterSigner_eq_zero_of_fresh_none + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (request : SignRequest) + (state : OriginMonitorState configuration) (selected : pattern.selected) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) → Prop) + (hselected : pattern.selectedAt? state.signerOrdinal = some selected) + (hnotPrehit : selected ∉ configuration.prehit) + (hnone : freshSuccessfulView? state.viewed.cache secretKey request result = none) : + (state.afterSigner secretKey request result).potential event = 0 := by + classical + simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hnotPrehit, hnone, + OriginMonitorState.potential] + +theorem OriginMonitorState.potential_afterSigner_eq_recordFreshState + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (request : SignRequest) + (state : OriginMonitorState configuration) (selected : pattern.selected) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) + (view : FewTimeView) (event : (pattern.selected → FewTimeView) → Prop) + (hselected : pattern.selectedAt? state.signerOrdinal = some selected) + (hnotPrehit : selected ∉ configuration.prehit) + (hview : freshSuccessfulView? state.viewed.cache secretKey request result = some view) : + (state.afterSigner secretKey request result).potential event = + (state.recordFreshState selected view).potential event := by + classical + rw [show state.afterSigner secretKey request result = + state.recordFreshState selected view by + simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hnotPrehit, hview, + OriginMonitorState.recordFreshState]] + +set_option maxRecDepth 100000 in +theorem OriginMonitorState.expected_potential_afterSigner_le + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (request : SignRequest) + (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) + (hcache : QueryCache.enncard state.viewed.cache ≤ q) + (hcoherent : state.ScheduleCoherent) : + (∑' result, + Pr[= result | + (simulateQ romImpl (signWithView secretKey request)).run state.viewed.cache] * + (state.afterSigner secretKey request result).potential event) ≤ + state.potential event := by + classical + cases hselected : pattern.selectedAt? state.signerOrdinal with + | none => + simp_rw [state.potential_afterSigner_of_selectedAt?_eq_none secretKey request _ event + hselected] + rw [ENNReal.tsum_mul_right] + calc + (∑' result, + Pr[= result | + (simulateQ romImpl (signWithView secretKey request)).run state.viewed.cache]) * + state.potential event ≤ 1 * state.potential event := by + gcongr + exact tsum_probOutput_le_one + _ = _ := one_mul _ + | some selected => + cases hvalid : state.valid with + | false => + simp_rw [state.potential_afterSigner_eq_zero_of_invalid secretKey request _ event + hvalid] + simp [OriginMonitorState.potential, hvalid] + | true => + by_cases hprehit : selected ∈ configuration.prehit + · let prehit : ↑configuration.prehit := ⟨selected, hprehit⟩ + by_cases hseen : prehit ∈ state.observation.seenSources + · calc + (∑' result, + Pr[= result | + (simulateQ romImpl + (signWithView secretKey request)).run state.viewed.cache] * + (state.afterSigner secretKey request result).potential event) ≤ + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * + state.advanceSigner.potential event := by + apply tsum_probOutput_signWithView_fixedPrehit_mul_le_of_enncard_le + secretKey request state.viewed.cache + (state.observation.sourceInputs prehit) + (fun view => view = state.observation.views selected) + q hq hcache + (fun result => + (state.afterSigner secretKey request result).potential event) + (state.advanceSigner.potential event) + · intro result _ hfailure + apply state.potential_afterSigner_eq_zero_of_prehit_failure + secretKey request selected hprehit result event hselected + exact fun hcondition => hfailure hcondition.2 + · intro result _ hsuccess + rw [state.potential_afterSigner_eq_advanceSigner_of_prehit + secretKey request selected hprehit result event hselected hseen hsuccess] + _ = state.potential event := + state.reuseWeight_mul_potential_advanceSigner prehit event hvalid hseen + ((pattern.selectedAt?_eq_some_iff state.signerOrdinal selected).mp hselected) + · have hfailure : ∀ result, + ¬ (prehit ∈ state.observation.seenSources ∧ + PrehitSuccessfulSignerView + (onlyInputCache state.viewed.cache + (state.observation.sourceInputs prehit)) + secretKey request (fun view => view = state.observation.views selected) + result) := by + intro result hcondition + exact hseen hcondition.1 + simp_rw [state.potential_afterSigner_eq_zero_of_prehit_failure + secretKey request selected hprehit _ event hselected (hfailure _)] + simp + · calc + (∑' result, + Pr[= result | + (simulateQ romImpl + (signWithView secretKey request)).run state.viewed.cache] * + (state.afterSigner secretKey request result).potential event) ≤ + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (state.recordFreshState selected view).potential event := by + apply tsum_probOutput_signWithView_fresh_mul_le_expected + secretKey request state.viewed.cache + (fun result => + (state.afterSigner secretKey request result).potential event) + (fun view => (state.recordFreshState selected view).potential event) + · intro result _ hnone + exact state.potential_afterSigner_eq_zero_of_fresh_none + secretKey request selected result event hselected hprehit hnone + · intro result _ view hview + rw [state.potential_afterSigner_eq_recordFreshState + secretKey request selected result view event hselected hprehit hview] + _ = state.potential event := + state.sum_uniform_potential_recordFreshState selected event hvalid + (state.selectedAt_fresh_not_seenView selected hcoherent hvalid hselected hprehit) + ((pattern.selectedAt?_eq_some_iff state.signerOrdinal selected).mp hselected) + hprehit + +theorem originMonitoredAdversaryImpl_direct_result_potential + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (_secretKey : SecretKey) + (state : OriginMonitorState configuration) (input : HashInput) + (result : HashOutput × QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) → Prop) : + let trace := fullAdversaryTraceUpdate (.inl (.inr input)) state.viewed.cache result.1 + result.2 state.viewed.trace + let monitored := monitorDirectSource state input result.1 + (⟨⟨result.2, trace, state.viewed.views, state.viewed.targetView⟩, + monitored.1, state.directOrdinal + 1, state.signerOrdinal, monitored.2⟩ : + OriginMonitorState configuration).potential event = + (state.afterDirect input result.1).potential event := by + rfl + +theorem originMonitoredAdversaryImpl_uniform_result_potential + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (_secretKey : SecretKey) + (state : OriginMonitorState configuration) (uniformInput : Nat) + (result : OracleWorld.Range (.inl uniformInput) × QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) → Prop) : + let trace := fullAdversaryTraceUpdate (.inl (.inl uniformInput)) state.viewed.cache + result.1 result.2 state.viewed.trace + (⟨⟨result.2, trace, state.viewed.views, state.viewed.targetView⟩, + state.observation, state.directOrdinal, state.signerOrdinal, state.valid⟩ : + OriginMonitorState configuration).potential event = state.potential event := by + rfl + +theorem originMonitoredAdversaryImpl_signer_result_potential + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (state : OriginMonitorState configuration) (request : SignRequest) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) → Prop) : + let trace := fullAdversaryTraceUpdate (.inr request) state.viewed.cache result.1.1 + result.2 state.viewed.trace + let monitored := monitorSigner secretKey request state result + (⟨⟨result.2, trace, state.viewed.views ++ [result.1.2], state.viewed.targetView⟩, + monitored.1, state.directOrdinal, state.signerOrdinal + 1, monitored.2⟩ : + OriginMonitorState configuration).potential event = + (state.afterSigner secretKey request result).potential event := by + rfl + +theorem originMonitoredAdversaryImpl_expected_potential_le + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (input : (OracleWorld + SigningSpec).Domain) + (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) + (hcache : QueryCache.enncard state.viewed.cache ≤ q) + (hcoherent : state.ScheduleCoherent) : + (∑' result, + Pr[= result | (originMonitoredAdversaryImpl configuration secretKey input).run state] * + result.2.potential event) ≤ state.potential event := by + classical + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + simp only [originMonitoredAdversaryImpl, StateT.run, tsum_probOutput_bind_mul, + tsum_probOutput_pure_mul] + change (∑' result, + Pr[= result | (romImpl (.inl uniformInput)).run state.viewed.cache] * + state.potential event) ≤ state.potential event + rw [ENNReal.tsum_mul_right] + calc + _ ≤ 1 * state.potential event := by + gcongr + exact tsum_probOutput_le_one + _ = _ := one_mul _ + | inr hashInput => + simp only [originMonitoredAdversaryImpl, StateT.run, tsum_probOutput_bind_mul, + tsum_probOutput_pure_mul] + change (∑' result, + Pr[= result | (randomOracle hashInput).run state.viewed.cache] * + (state.afterDirect hashInput result.1).potential event) ≤ _ + exact state.expected_potential_afterDirect_le hashInput event hcoherent + | inr request => + simp only [originMonitoredAdversaryImpl, StateT.run, tsum_probOutput_bind_mul, + tsum_probOutput_pure_mul] + simp_rw [originMonitoredAdversaryImpl_signer_result_potential] + change (∑' result, + Pr[= result | + (simulateQ romImpl (signWithView secretKey request)).run state.viewed.cache] * + (state.afterSigner secretKey request result).potential event) ≤ _ + exact state.expected_potential_afterSigner_le secretKey request event q hq hcache hcoherent + +theorem OriginMonitorState.scheduleCoherent_afterDirect + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (input : HashInput) (output : HashOutput) + (hcoherent : state.ScheduleCoherent) : + (state.afterDirect input output).ScheduleCoherent := by + classical + intro hafterValid + cases hsource : configuration.sourceAt? state.directOrdinal with + | none => + have hvalid : state.valid = true := by + simpa [OriginMonitorState.afterDirect, monitorDirectSource, hsource] using hafterValid + obtain ⟨hsources, hviews, hsigned⟩ := hcoherent hvalid + simp only [OriginMonitorState.afterDirect, monitorDirectSource, hsource] + constructor + · intro selected + have hne : (configuration.source.1 selected).val ≠ state.directOrdinal := by + intro heq + have hsome := + (configuration.sourceAt?_eq_some_iff state.directOrdinal selected).2 heq + rw [hsource] at hsome + contradiction + change selected ∈ state.observation.seenSources ↔ + (configuration.source.1 selected).val < state.directOrdinal + 1 + rw [hsources selected] + omega + constructor + · intro selected + change selected ∈ state.observation.seenViews ↔ + selected.1.val < state.signerOrdinal ∨ + ∃ hprehit : selected ∈ configuration.prehit, + (configuration.source.1 ⟨selected, hprehit⟩).val < + state.directOrdinal + 1 + rw [hviews selected] + constructor + · rintro (hsigner | ⟨hprehit, hlt⟩) + · exact Or.inl hsigner + · exact Or.inr ⟨hprehit, Nat.lt_succ_of_lt hlt⟩ + · rintro (hsigner | ⟨hprehit, hlt⟩) + · exact Or.inl hsigner + · refine Or.inr ⟨hprehit, ?_⟩ + have hne : (configuration.source.1 ⟨selected, hprehit⟩).val ≠ + state.directOrdinal := by + intro heq + have hsome := (configuration.sourceAt?_eq_some_iff state.directOrdinal + (⟨selected, hprehit⟩ : ↑configuration.prehit)).2 heq + rw [hsource] at hsome + contradiction + omega + · intro selected hprehit hlt + exact Nat.lt_succ_of_lt (hsigned selected hprehit hlt) + | some sourceSelected => + by_cases hcondition : state.viewed.cache input = none ∧ + signAttemptResultOfOutput output ≠ none + · have hvalid : state.valid = true := by + simpa [OriginMonitorState.afterDirect, monitorDirectSource, hsource, hcondition] + using hafterValid + obtain ⟨hsources, hviews, hsigned⟩ := hcoherent hvalid + have hsourceEq : (configuration.source.1 sourceSelected).val = + state.directOrdinal := + (configuration.sourceAt?_eq_some_iff state.directOrdinal sourceSelected).1 hsource + obtain ⟨hcache, hanswer⟩ := hcondition + simp only [OriginMonitorState.afterDirect, monitorDirectSource, hsource, hcache, + true_and, dif_pos hanswer, OriginObservation.recordSource] + constructor + · intro selected + have hcurrent : (configuration.source.1 selected).val = state.directOrdinal ↔ + selected = sourceSelected := by + constructor + · intro heq + have hsome := + (configuration.sourceAt?_eq_some_iff state.directOrdinal selected).2 heq + rw [hsource] at hsome + exact (Option.some.inj hsome).symm + · rintro rfl + exact hsourceEq + change selected ∈ insert sourceSelected state.observation.seenSources ↔ + (configuration.source.1 selected).val < state.directOrdinal + 1 + rw [Finset.mem_insert, hsources selected] + constructor + · rintro (rfl | hlt) + · omega + · omega + · intro hlt + have hle : (configuration.source.1 selected).val ≤ state.directOrdinal := by omega + rcases lt_or_eq_of_le hle with hlt | heq + · exact Or.inr hlt + · exact Or.inl ((hcurrent).1 heq) + constructor + · intro selected + change selected ∈ insert sourceSelected.1 state.observation.seenViews ↔ + selected.1.val < state.signerOrdinal ∨ + ∃ hprehit : selected ∈ configuration.prehit, + (configuration.source.1 ⟨selected, hprehit⟩).val < + state.directOrdinal + 1 + rw [Finset.mem_insert, hviews selected] + constructor + · rintro (heq | hsigner | ⟨hprehit, hlt⟩) + · subst selected + refine Or.inr ⟨sourceSelected.2, ?_⟩ + rw [hsourceEq] + exact Nat.lt_succ_self _ + · exact Or.inl hsigner + · exact Or.inr ⟨hprehit, Nat.lt_succ_of_lt hlt⟩ + · rintro (hsigner | ⟨hprehit, hlt⟩) + · exact Or.inr (Or.inl hsigner) + · have hle : (configuration.source.1 ⟨selected, hprehit⟩).val ≤ + state.directOrdinal := by omega + rcases lt_or_eq_of_le hle with hbefore | hcurrent + · exact Or.inr (Or.inr ⟨hprehit, hbefore⟩) + · have hsome := (configuration.sourceAt?_eq_some_iff state.directOrdinal + (⟨selected, hprehit⟩ : ↑configuration.prehit)).2 hcurrent + rw [hsource] at hsome + have heq : selected = sourceSelected.1 := (congrArg Subtype.val + (Option.some.inj hsome)).symm + exact Or.inl heq + · intro selected hprehit hlt + exact Nat.lt_succ_of_lt (hsigned selected hprehit hlt) + · have : (state.afterDirect input output).valid = false := by + simp [OriginMonitorState.afterDirect, monitorDirectSource, hsource, hcondition] + rw [this] at hafterValid + contradiction + +theorem OriginMonitorState.scheduleCoherent_afterSigner + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (request : SignRequest) + (state : OriginMonitorState configuration) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) + (hcoherent : state.ScheduleCoherent) : + (state.afterSigner secretKey request result).ScheduleCoherent := by + classical + intro hafterValid + cases hselected : pattern.selectedAt? state.signerOrdinal with + | none => + have hvalid : state.valid = true := by + simpa [OriginMonitorState.afterSigner, monitorSigner, hselected] using hafterValid + obtain ⟨hsources, hviews, hsigned⟩ := hcoherent hvalid + simp only [OriginMonitorState.afterSigner, monitorSigner, hselected] + constructor + · exact hsources + constructor + · intro selected + have hne : selected.1.val ≠ state.signerOrdinal := by + intro heq + have hsome := (pattern.selectedAt?_eq_some_iff state.signerOrdinal selected).2 heq + rw [hselected] at hsome + contradiction + change selected ∈ state.observation.seenViews ↔ + selected.1.val < state.signerOrdinal + 1 ∨ + ∃ hprehit : selected ∈ configuration.prehit, + (configuration.source.1 ⟨selected, hprehit⟩).val < state.directOrdinal + rw [hviews selected] + constructor + · rintro (hsigner | hsource) + · exact Or.inl (Nat.lt_succ_of_lt hsigner) + · exact Or.inr hsource + · rintro (hsigner | hsource) + · exact Or.inl (by omega) + · exact Or.inr hsource + · intro selected hprehit hlt + apply hsigned selected hprehit + have hne : selected.1.val ≠ state.signerOrdinal := by + intro heq + have hsome := (pattern.selectedAt?_eq_some_iff state.signerOrdinal selected).2 heq + rw [hselected] at hsome + contradiction + omega + | some selected => + have hselectedEq : selected.1.val = state.signerOrdinal := + (pattern.selectedAt?_eq_some_iff state.signerOrdinal selected).1 hselected + have hcurrent : ∀ candidate : pattern.selected, + candidate.1.val = state.signerOrdinal ↔ candidate = selected := by + intro candidate + constructor + · intro heq + have hsome := (pattern.selectedAt?_eq_some_iff state.signerOrdinal candidate).2 heq + rw [hselected] at hsome + exact (Option.some.inj hsome).symm + · rintro rfl + exact hselectedEq + by_cases hprehit : selected ∈ configuration.prehit + · let prehit : ↑configuration.prehit := ⟨selected, hprehit⟩ + by_cases hcondition : prehit ∈ state.observation.seenSources ∧ + PrehitSuccessfulSignerView + (onlyInputCache state.viewed.cache (state.observation.sourceInputs prehit)) + secretKey request (fun view => view = state.observation.views selected) result + · obtain ⟨hseen, hsuccess⟩ := hcondition + have hvalid : state.valid = true := by + simpa [OriginMonitorState.afterSigner, monitorSigner, hselected, hprehit, + prehit, hseen, hsuccess] using hafterValid + obtain ⟨hsources, hviews, hsigned⟩ := hcoherent hvalid + have hsourceBefore : (configuration.source.1 prehit).val < state.directOrdinal := + (hsources prehit).1 hseen + simp only [OriginMonitorState.afterSigner, monitorSigner, hselected, hprehit, + prehit, hseen, hsuccess, and_self, dif_pos] + constructor + · exact hsources + constructor + · intro candidate + change candidate ∈ state.observation.seenViews ↔ + candidate.1.val < state.signerOrdinal + 1 ∨ + ∃ hcandidate : candidate ∈ configuration.prehit, + (configuration.source.1 ⟨candidate, hcandidate⟩).val < + state.directOrdinal + rw [hviews candidate] + constructor + · rintro (hsigner | hsource) + · exact Or.inl (Nat.lt_succ_of_lt hsigner) + · exact Or.inr hsource + · rintro (hsigner | hsource) + · have hle : candidate.1.val ≤ state.signerOrdinal := by omega + rcases lt_or_eq_of_le hle with hbefore | heq + · exact Or.inl hbefore + · have hcand : candidate = selected := (hcurrent candidate).1 heq + subst candidate + exact Or.inr ⟨hprehit, by simpa [prehit] using hsourceBefore⟩ + · exact Or.inr hsource + · intro candidate hcandidate hlt + have hle : candidate.1.val ≤ state.signerOrdinal := by omega + rcases lt_or_eq_of_le hle with hbefore | heq + · exact hsigned candidate hcandidate hbefore + · have hcand : candidate = selected := (hcurrent candidate).1 heq + subst candidate + simpa [prehit] using hsourceBefore + · have hinvalid : (state.afterSigner secretKey request result).valid = false := by + simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hprehit, + prehit, hcondition] + rw [hinvalid] at hafterValid + contradiction + · cases hview : freshSuccessfulView? state.viewed.cache secretKey request result with + | none => + have hinvalid : (state.afterSigner secretKey request result).valid = false := by + simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hprehit, hview] + rw [hinvalid] at hafterValid + contradiction + | some view => + have hvalid : state.valid = true := by + simpa [OriginMonitorState.afterSigner, monitorSigner, hselected, hprehit, hview] + using hafterValid + obtain ⟨hsources, hviews, hsigned⟩ := hcoherent hvalid + simp only [OriginMonitorState.afterSigner, monitorSigner, hselected, hprehit, hview, + OriginObservation.recordFresh] + constructor + · exact hsources + constructor + · intro candidate + change candidate ∈ insert selected state.observation.seenViews ↔ + candidate.1.val < state.signerOrdinal + 1 ∨ + ∃ hcandidate : candidate ∈ configuration.prehit, + (configuration.source.1 ⟨candidate, hcandidate⟩).val < + state.directOrdinal + rw [Finset.mem_insert, hviews candidate] + constructor + · rintro (rfl | hsigner | hsource) + · exact Or.inl (by omega) + · exact Or.inl (Nat.lt_succ_of_lt hsigner) + · exact Or.inr hsource + · rintro (hsigner | hsource) + · have hle : candidate.1.val ≤ state.signerOrdinal := by omega + rcases lt_or_eq_of_le hle with hbefore | heq + · exact Or.inr (Or.inl hbefore) + · exact Or.inl ((hcurrent candidate).1 heq) + · exact Or.inr (Or.inr hsource) + · intro candidate hcandidate hlt + have hle : candidate.1.val ≤ state.signerOrdinal := by omega + rcases lt_or_eq_of_le hle with hbefore | heq + · exact hsigned candidate hcandidate hbefore + · have hcand : candidate = selected := (hcurrent candidate).1 heq + subst candidate + exact (hprehit hcandidate).elim + +theorem originMonitoredAdversaryImpl_query_scheduleCoherent + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (input : (OracleWorld + SigningSpec).Domain) + (state : OriginMonitorState configuration) + (result : (OracleWorld + SigningSpec).Range input × OriginMonitorState configuration) + (hcoherent : state.ScheduleCoherent) + (hmem : result ∈ support + ((originMonitoredAdversaryImpl configuration secretKey input).run state)) : + result.2.ScheduleCoherent := by + classical + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + rw [originMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, finalCache⟩, _, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + simpa [OriginMonitorState.ScheduleCoherent] using hcoherent + | inr hashInput => + rw [originMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, finalCache⟩, _, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + simpa [OriginMonitorState.ScheduleCoherent, OriginMonitorState.afterDirect] using + state.scheduleCoherent_afterDirect hashInput output hcoherent + | inr request => + rw [originMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨⟨signature, view⟩, finalCache⟩, _, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + simpa [OriginMonitorState.ScheduleCoherent, OriginMonitorState.afterSigner] using + state.scheduleCoherent_afterSigner secretKey request ((signature, view), finalCache) + hcoherent + +theorem originMonitoredAdversaryImpl_scheduleCoherent + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginMonitorState configuration) + (result : α × OriginMonitorState configuration) + (hcoherent : initialState.ScheduleCoherent) + (hmem : result ∈ support + ((simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState)) : + result.2.ScheduleCoherent := by + exact OracleComp.simulateQ_run_preservesInv + (originMonitoredAdversaryImpl configuration secretKey) + OriginMonitorState.ScheduleCoherent + (by + intro input state hstate queryResult hquery + exact originMonitoredAdversaryImpl_query_scheduleCoherent configuration secretKey input + state queryResult hstate hquery) + computation initialState hcoherent result hmem + +theorem originMonitoredAdversaryImpl_query_cache_le + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (input : (OracleWorld + SigningSpec).Domain) + (state : OriginMonitorState configuration) + (result : (OracleWorld + SigningSpec).Range input × OriginMonitorState configuration) + (hmem : result ∈ support + ((originMonitoredAdversaryImpl configuration secretKey input).run state)) : + state.viewed.cache ≤ result.2.viewed.cache := by + classical + cases input with + | inl worldInput => + rw [originMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, finalCache⟩, hquery, hpure⟩ := hmem + cases worldInput with + | inl uniformInput => + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + exact unloggedMappedAdversaryImpl_cache_le secretKey (.inl (.inl uniformInput)) + state.viewed.cache (output, finalCache) hquery + | inr hashInput => + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + exact unloggedMappedAdversaryImpl_cache_le secretKey (.inl (.inr hashInput)) + state.viewed.cache (output, finalCache) hquery + | inr request => + rw [originMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨⟨signature, view⟩, finalCache⟩, hquery, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + exact simulateQ_romImpl_cache_le (signWithView secretKey request) state.viewed.cache + ((signature, view), finalCache) hquery + +noncomputable def OriginMonitorState.cappedPotential {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) : ℝ≥0∞ := by + classical + exact if QueryCache.enncard state.viewed.cache ≤ q then state.potential event else 0 + +theorem OriginMonitorState.cappedPotential_le_potential + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) : + state.cappedPotential q event ≤ state.potential event := by + classical + simp only [OriginMonitorState.cappedPotential] + split_ifs + · exact le_rfl + · exact bot_le + +theorem OriginMonitorState.cappedPotential_eq_of_enncard_le + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (hcache : QueryCache.enncard state.viewed.cache ≤ q) : + state.cappedPotential q event = state.potential event := by + classical + simp [OriginMonitorState.cappedPotential, hcache] + +theorem OriginMonitorState.cappedPotential_eq_zero_of_not_enncard_le + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (hcache : ¬ QueryCache.enncard state.viewed.cache ≤ q) : + state.cappedPotential q event = 0 := by + classical + simp [OriginMonitorState.cappedPotential, hcache] + +theorem originMonitoredAdversaryImpl_expected_cappedPotential_le + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (input : (OracleWorld + SigningSpec).Domain) + (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) + (hcoherent : state.ScheduleCoherent) : + (∑' result, + Pr[= result | (originMonitoredAdversaryImpl configuration secretKey input).run state] * + result.2.cappedPotential q event) ≤ state.cappedPotential q event := by + classical + by_cases hcache : QueryCache.enncard state.viewed.cache ≤ q + · rw [state.cappedPotential_eq_of_enncard_le q event hcache] + calc + (∑' result, + Pr[= result | + (originMonitoredAdversaryImpl configuration secretKey input).run state] * + result.2.cappedPotential q event) ≤ + ∑' result, + Pr[= result | + (originMonitoredAdversaryImpl configuration secretKey input).run state] * + result.2.potential event := by + apply ENNReal.tsum_le_tsum + intro result + exact mul_le_mul' le_rfl (result.2.cappedPotential_le_potential q event) + _ ≤ _ := originMonitoredAdversaryImpl_expected_potential_le configuration secretKey input + state event q hq hcache hcoherent + · rw [state.cappedPotential_eq_zero_of_not_enncard_le q event hcache] + have hzero : (∑' result, + Pr[= result | + (originMonitoredAdversaryImpl configuration secretKey input).run state] * + result.2.cappedPotential q event) = 0 := by + apply ENNReal.tsum_eq_zero.2 + intro result + by_cases hresult : result ∈ support + ((originMonitoredAdversaryImpl configuration secretKey input).run state) + · have hle := originMonitoredAdversaryImpl_query_cache_le configuration secretKey input + state result hresult + have hcard := QueryCache.enncard_mono hle + have hnotFinal : ¬ QueryCache.enncard result.2.viewed.cache ≤ q := fun hfinal => + hcache (hcard.trans hfinal) + rw [result.2.cappedPotential_eq_zero_of_not_enncard_le q event hnotFinal, mul_zero] + · rw [probOutput_eq_zero_of_not_mem_support hresult, zero_mul] + exact hzero.le + +theorem originMonitoredAdversaryImpl_expected_cappedPotential_simulateQ_le + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) + (hcoherent : initialState.ScheduleCoherent) : + (∑' result, + Pr[= result | + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState] * + result.2.cappedPotential q event) ≤ initialState.cappedPotential q event := by + induction computation using OracleComp.inductionOn generalizing initialState with + | pure value => + simp [simulateQ_pure, tsum_probOutput_pure_mul] + | query_bind input next ih => + rw [simulateQ_bind, StateT.run_bind, simulateQ_query, + tsum_probOutput_bind_mul] + simp only [OracleQuery.input_query, OracleQuery.cont_query, id_map] + calc + (∑' result, + Pr[= result | + (originMonitoredAdversaryImpl configuration secretKey input).run initialState] * + ∑' finalResult, + Pr[= finalResult | + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + (next result.1)).run result.2] * + finalResult.2.cappedPotential q event) ≤ + ∑' result, + Pr[= result | + (originMonitoredAdversaryImpl configuration secretKey input).run initialState] * + result.2.cappedPotential q event := by + apply ENNReal.tsum_le_tsum + intro result + by_cases hresult : result ∈ support + ((originMonitoredAdversaryImpl configuration secretKey input).run initialState) + · apply mul_le_mul' le_rfl + exact ih result.1 result.2 + (originMonitoredAdversaryImpl_query_scheduleCoherent configuration secretKey input + initialState result hcoherent hresult) + · rw [probOutput_eq_zero_of_not_mem_support hresult, zero_mul, zero_mul] + _ ≤ _ := originMonitoredAdversaryImpl_expected_cappedPotential_le configuration + secretKey input initialState event q hq hcoherent + +def OriginMonitorState.Complete {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) : Prop := + state.valid = true ∧ state.pendingSources = ∅ ∧ state.pendingReuses = ∅ ∧ + state.observation.seenViews = Finset.univ + +theorem OriginMonitorState.completionMass_eq_one_of_complete + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (hseen : state.observation.seenViews = Finset.univ) + (hevent : event state.observation.views) : + state.completionMass event = 1 := by + classical + have hcomplete : ∀ fallback, + state.observation.completeViews fallback = state.observation.views := by + intro fallback + funext selected + simp [OriginObservation.completeViews, hseen] + rw [OriginMonitorState.completionMass, OriginObservation.completedViews, probEvent_map] + change Pr[fun fallback : pattern.selected → FewTimeView => + event (state.observation.completeViews fallback) | + ($ᵗ (pattern.selected → FewTimeView) : + ProbComp (pattern.selected → FewTimeView))] = 1 + simp_rw [hcomplete] + simp [hevent] + +theorem OriginMonitorState.potential_eq_one_of_complete + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (hcomplete : state.Complete) (hevent : event state.observation.views) : + state.potential event = 1 := by + classical + obtain ⟨hvalid, hsources, hreuses, hviews⟩ := hcomplete + rw [OriginMonitorState.potential, if_pos hvalid, hsources, hreuses] + simp only [Finset.card_empty, pow_zero, one_mul] + exact state.completionMass_eq_one_of_complete event hviews hevent + +theorem OriginMonitorState.cappedPotential_eq_one_of_complete + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (hcache : QueryCache.enncard state.viewed.cache ≤ q) + (hcomplete : state.Complete) (hevent : event state.observation.views) : + state.cappedPotential q event = 1 := by + rw [state.cappedPotential_eq_of_enncard_le q event hcache, + state.potential_eq_one_of_complete event hcomplete hevent] + +theorem OriginMonitorState.complete_of_valid_and_ordinals + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) + (hcoherent : state.ScheduleCoherent) (hvalid : state.valid = true) + (hsources : ∀ selected : ↑configuration.prehit, + (configuration.source.1 selected).val < state.directOrdinal) + (hsigners : ∀ selected : pattern.selected, + selected.1.val < state.signerOrdinal) : + state.Complete := by + classical + have hseenSources : state.observation.seenSources = Finset.univ := by + ext selected + simp only [Finset.mem_univ, iff_true] + exact (hcoherent hvalid).1 selected |>.2 (hsources selected) + have hseenViews : state.observation.seenViews = Finset.univ := by + ext selected + simp only [Finset.mem_univ, iff_true] + exact (hcoherent hvalid).2.1 selected |>.2 (Or.inl (hsigners selected)) + refine ⟨hvalid, ?_, ?_, hseenViews⟩ + · ext selected + simp [OriginMonitorState.pendingSources, hseenSources] + · ext selected + simp [OriginMonitorState.pendingReuses, hseenSources, + Nat.not_le_of_lt (hsigners selected.1)] + +theorem probEvent_originMonitored_complete_le_initial + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) + (hcoherent : initialState.ScheduleCoherent) : + Pr[fun result : α × OriginMonitorState configuration => + result.2.Complete ∧ event result.2.observation.views ∧ + QueryCache.enncard result.2.viewed.cache ≤ q | + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState] ≤ initialState.cappedPotential q event := by + let run := (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState + calc + Pr[fun result : α × OriginMonitorState configuration => + result.2.Complete ∧ event result.2.observation.views ∧ + QueryCache.enncard result.2.viewed.cache ≤ q | run] ≤ + ∑' result, Pr[= result | run] * result.2.cappedPotential q event := by + apply probEvent_le_tsum_probOutput_mul_cost + intro result hresult + rw [result.2.cappedPotential_eq_one_of_complete q event hresult.2.2 + hresult.1 hresult.2.1] + _ ≤ _ := originMonitoredAdversaryImpl_expected_cappedPotential_simulateQ_le + configuration secretKey computation initialState event q hq hcoherent + +theorem probEvent_originMonitored_complete_le_ideal + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) + (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[fun result : α × OriginMonitorState configuration => + result.2.Complete ∧ event result.2.observation.views ∧ + QueryCache.enncard result.2.viewed.cache ≤ q | + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run (OriginMonitorState.initial configuration initialCache)] ≤ + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ configuration.prehit.card * + Pr[event | ($ᵗ (pattern.selected → FewTimeView) : + ProbComp (pattern.selected → FewTimeView))] := by + calc + _ ≤ (OriginMonitorState.initial configuration initialCache).cappedPotential q event := + probEvent_originMonitored_complete_le_initial configuration secretKey computation + (OriginMonitorState.initial configuration initialCache) event q hq + (OriginMonitorState.scheduleCoherent_initial configuration initialCache) + _ = (OriginMonitorState.initial configuration initialCache).potential event := + (OriginMonitorState.initial configuration initialCache).cappedPotential_eq_of_enncard_le + q event hcache + _ = _ := OriginMonitorState.potential_initial configuration initialCache event + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginLift.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginLift.lean new file mode 100644 index 00000000..f036bbab --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginLift.lean @@ -0,0 +1,91 @@ +import SphincsSecurity.Proof.FewTimeOriginTerminal + +/-! +# Probability lift for a realized padded origin + +For a fixed cover and target, the deterministic replay theorem turns every realized viewed trace +into the terminal event bounded by the origin monitor's supermartingale. The monitor projection +then transfers that bound back to the viewed adversary execution. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +namespace Concrete + +def PaddedOriginTerminal {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + {q limit : Nat} (hle : signingLog.length ≤ limit) + (configuration : OriginConfiguration (cover.pattern.pad hle) q) + (state : ViewedFullTraceState) : Prop := + ∃ hlog : state.trace.signing.toSigningLog = signingLog, + configuration.PaddedRealizedBy cover hle state.trace hlog + ∧ state.trace.ValidIntervals secretKey + ∧ FullAdversaryTrace.Chronological state.trace.intervals + ∧ state.trace.signing.CachesLe cache + +noncomputable instance {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + {q limit : Nat} (hle : signingLog.length ≤ limit) + (configuration : OriginConfiguration (cover.pattern.pad hle) q) : + DecidablePred (PaddedOriginTerminal cover hle configuration) := + fun state => Classical.propDecidable (PaddedOriginTerminal cover hle configuration state) + +theorem probEvent_paddedOriginTerminal_le_ideal {f : QueryImpl HashSpec Id} + {cache initialCache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + {sources limit : Nat} (hle : signingLog.length ≤ limit) + (configuration : OriginConfiguration (cover.pattern.pad hle) sources) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (hf : cache.AgreesWithFn f) (q : Nat) (hq : q ≤ 2 ^ 120) + (hinitialCache : QueryCache.enncard initialCache ≤ q) : + Pr[fun result : α × ViewedFullTraceState => + PaddedOriginTerminal cover hle configuration result.2 + ∧ QueryCache.enncard result.2.cache ≤ q | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] ≤ + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ configuration.prehit.card * + Pr[fun views => FixedFewTimePatternHit (cover.pattern.pad hle).assignment + (views, fewTimeTargetView index targetLeaves) | + ($ᵗ ((cover.pattern.pad hle).selected → FewTimeView) : + ProbComp ((cover.pattern.pad hle).selected → FewTimeView))] := by + let initialState := OriginMonitorState.initial configuration initialCache + let event := fun views => + FixedFewTimePatternHit (cover.pattern.pad hle).assignment + (views, fewTimeTargetView index targetLeaves) + let monitoredEvent := fun result : α × OriginMonitorState configuration => + result.2.Complete ∧ event result.2.observation.views + ∧ QueryCache.enncard result.2.viewed.cache ≤ q + calc + _ ≤ Pr[monitoredEvent | + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState] := by + apply probEvent_viewed_le_originMonitoredAdversaryImpl configuration secretKey + computation initialState _ monitoredEvent + intro result hresult hterminal + obtain ⟨⟨hlog, hrealized, hvalidIntervals, hchronological, hcaches⟩, + hcache⟩ := hterminal + have hreplay := originMonitoredAdversaryImpl_replayConsistent + configuration secretKey computation initialState result + (OriginMonitorState.replayConsistent_initial configuration secretKey initialCache) + hresult + have hcomplete := configuration.paddedRealized_complete_and_hit hlog hrealized + hreplay hvalidIntervals hchronological hcaches hf + exact ⟨hcomplete.1, hcomplete.2, hcache⟩ + _ ≤ _ := by + simpa only [initialState, event, monitoredEvent] using + (probEvent_originMonitored_complete_le_ideal configuration secretKey computation + initialCache event q (hq.trans (by norm_num)) hinitialCache) + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginMonitor.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginMonitor.lean new file mode 100644 index 00000000..8a1b34ce --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginMonitor.lean @@ -0,0 +1,184 @@ +import SphincsSecurity.Proof.FewTimeOriginSchedule + +/-! +# Monitoring one padded origin configuration + +This proof-only state follows the viewed traced adversary execution. It records the input and view +at configured direct sources, records fresh selected signer views, and checks fixed-input reuse at +configured prehit signer positions. Forgetting the monitor fields leaves the viewed trace unchanged. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +namespace Concrete + +structure OriginMonitorState {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) where + viewed : ViewedFullTraceState + observation : OriginObservation configuration + directOrdinal : Nat + signerOrdinal : Nat + valid : Bool + +noncomputable def OriginMonitorState.initial {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) + (cache : QueryCache HashSpec) : OriginMonitorState configuration := + ⟨⟨cache, ⟨[], [], []⟩, [], none⟩, OriginObservation.empty configuration, 0, 0, true⟩ + +noncomputable def monitorDirectSource {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (input : HashInput) (output : HashOutput) : + OriginObservation configuration × Bool := by + classical + match configuration.sourceAt? state.directOrdinal with + | none => exact (state.observation, state.valid) + | some selected => + if state.viewed.cache input = none ∧ signAttemptResultOfOutput output ≠ none then + exact (state.observation.recordSource selected input (hashOutputFewTimeView output), + state.valid) + else + exact (state.observation, false) + +noncomputable def monitorSigner {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (request : SignRequest) + (state : OriginMonitorState configuration) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) : + OriginObservation configuration × Bool := by + classical + match pattern.selectedAt? state.signerOrdinal with + | none => exact (state.observation, state.valid) + | some selected => + if hprehit : selected ∈ configuration.prehit then + let prehit : ↑configuration.prehit := ⟨selected, hprehit⟩ + if prehit ∈ state.observation.seenSources ∧ + PrehitSuccessfulSignerView + (onlyInputCache state.viewed.cache (state.observation.sourceInputs prehit)) + secretKey request (fun view => view = state.observation.views selected) result then + exact (state.observation, state.valid) + else + exact (state.observation, false) + else + match freshSuccessfulView? state.viewed.cache secretKey request result with + | none => exact (state.observation, false) + | some view => exact (state.observation.recordFresh selected view, state.valid) + +noncomputable def originMonitoredAdversaryImpl {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) : + QueryImpl (OracleWorld + SigningSpec) (StateT (OriginMonitorState configuration) ProbComp) := by + intro input + cases input with + | inl worldInput => + exact fun state => do + let (output, finalCache) ← (romImpl worldInput).run state.viewed.cache + let trace := fullAdversaryTraceUpdate (.inl worldInput) state.viewed.cache output + finalCache state.viewed.trace + match worldInput with + | .inl _ => + pure (output, ⟨⟨finalCache, trace, state.viewed.views, state.viewed.targetView⟩, + state.observation, state.directOrdinal, state.signerOrdinal, state.valid⟩) + | .inr hashInput => + let monitored := monitorDirectSource state hashInput output + pure (output, ⟨⟨finalCache, trace, state.viewed.views, state.viewed.targetView⟩, + monitored.1, state.directOrdinal + 1, state.signerOrdinal, monitored.2⟩) + | inr request => + exact fun state => do + let (result, finalCache) ← + (simulateQ romImpl (signWithView secretKey request)).run state.viewed.cache + let trace := fullAdversaryTraceUpdate (.inr request) state.viewed.cache result.1 + finalCache state.viewed.trace + let monitored := monitorSigner secretKey request state (result, finalCache) + pure (result.1, ⟨⟨finalCache, trace, state.viewed.views ++ [result.2], + state.viewed.targetView⟩, monitored.1, state.directOrdinal, + state.signerOrdinal + 1, monitored.2⟩) + +theorem originMonitoredAdversaryImpl_query_projection {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (input : (OracleWorld + SigningSpec).Domain) + (state : OriginMonitorState configuration) : + (fun result => (result.1, result.2.viewed)) <$> + ((originMonitoredAdversaryImpl configuration secretKey input).run state) = + (viewedFullTracedMappedAdversaryImpl secretKey input).run state.viewed := by + classical + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + simp only [originMonitoredAdversaryImpl, viewedFullTracedMappedAdversaryImpl, + StateT.run, map_eq_bind_pure_comp, Function.comp_apply, bind_assoc, pure_bind] + | inr hashInput => + simp only [originMonitoredAdversaryImpl, viewedFullTracedMappedAdversaryImpl, + StateT.run, map_eq_bind_pure_comp, Function.comp_apply, bind_assoc, pure_bind] + | inr request => + simp only [originMonitoredAdversaryImpl, viewedFullTracedMappedAdversaryImpl, + StateT.run, map_eq_bind_pure_comp, Function.comp_apply, bind_assoc, pure_bind] + +theorem originMonitoredAdversaryImpl_projection {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginMonitorState configuration) : + Prod.map id OriginMonitorState.viewed <$> + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState = + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run initialState.viewed := by + apply OracleComp.map_run_simulateQ_eq_of_query_map_eq + (originMonitoredAdversaryImpl configuration secretKey) + (viewedFullTracedMappedAdversaryImpl secretKey) + OriginMonitorState.viewed + intro input state + exact originMonitoredAdversaryImpl_query_projection configuration secretKey input state + +theorem probEvent_originMonitoredAdversaryImpl_projection + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginMonitorState configuration) + (event : α × ViewedFullTraceState → Prop) : + Pr[event | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run initialState.viewed] = + Pr[fun result : α × OriginMonitorState configuration => + event (result.1, result.2.viewed) | + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState] := by + rw [← originMonitoredAdversaryImpl_projection configuration secretKey computation + initialState, probEvent_map] + rfl + +theorem probEvent_viewed_le_originMonitoredAdversaryImpl + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginMonitorState configuration) + (viewedEvent : α × ViewedFullTraceState → Prop) + (monitoredEvent : α × OriginMonitorState configuration → Prop) + (himp : ∀ result ∈ support + ((simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState), + viewedEvent (result.1, result.2.viewed) → monitoredEvent result) : + Pr[viewedEvent | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run initialState.viewed] ≤ + Pr[monitoredEvent | + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState] := by + classical + rw [probEvent_originMonitoredAdversaryImpl_projection configuration secretKey + computation initialState viewedEvent] + exact probEvent_mono himp + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginPadding.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginPadding.lean new file mode 100644 index 00000000..6d9b107a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginPadding.lean @@ -0,0 +1,188 @@ +import SphincsSecurity.Proof.FewTimeOriginProbability + +/-! +# Padding few-time origin configurations + +The viewed game pads signer views to `signatureLimit`. Origin configurations use the same embedding +on selected signer positions, while retaining the direct-query source assigned to every prehit. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +noncomputable def FewTimePattern.padSelectedEquiv {small large distinct : Nat} + (pattern : FewTimePattern small distinct) (hle : small ≤ large) : + pattern.selected ≃ (pattern.pad hle).selected := by + classical + let toPadded : pattern.selected → (pattern.pad hle).selected := fun selected => + ⟨finCastLEEmbedding hle selected.1, + Finset.mem_map.2 ⟨selected.1, selected.2, rfl⟩⟩ + refine Equiv.ofBijective toPadded ⟨?_, ?_⟩ + · intro left right heq + apply Subtype.ext + exact (finCastLEEmbedding hle).injective (congrArg Subtype.val heq) + · intro selected + obtain ⟨position, hposition, heq⟩ := Finset.mem_map.1 selected.2 + refine ⟨⟨position, hposition⟩, Subtype.ext ?_⟩ + exact heq + +theorem FewTimePattern.padSelectedEquiv_apply {small large distinct : Nat} + (pattern : FewTimePattern small distinct) (hle : small ≤ large) + (selected : pattern.selected) : + (pattern.padSelectedEquiv hle selected).1 = finCastLEEmbedding hle selected.1 := rfl + +noncomputable def OriginConfiguration.pad {small large distinct sources : Nat} + {pattern : FewTimePattern small distinct} (configuration : OriginConfiguration pattern sources) + (hle : small ≤ large) : OriginConfiguration (pattern.pad hle) sources := by + classical + let selectedEquiv := pattern.padSelectedEquiv hle + let paddedPrehit := configuration.prehit.map selectedEquiv.toEmbedding + let oldSelected : ↑paddedPrehit → ↑configuration.prehit := fun selected => by + let old := selectedEquiv.symm selected.1 + have hold : old ∈ configuration.prehit := by + obtain ⟨candidate, hcandidate, heq⟩ := Finset.mem_map.1 selected.2 + have hcandEq : candidate = old := by + apply selectedEquiv.injective + rw [selectedEquiv.apply_symm_apply] + exact heq + rwa [← hcandEq] + exact ⟨old, hold⟩ + have holdInjective : Function.Injective oldSelected := by + intro left right heq + apply Subtype.ext + apply selectedEquiv.symm.injective + exact congrArg (fun selected : ↑configuration.prehit => selected.1) heq + refine ⟨paddedPrehit, ⟨fun selected => configuration.source.1 (oldSelected selected), ?_⟩⟩ + exact Function.Injective.comp configuration.source.2 holdInjective + +theorem OriginConfiguration.mem_pad_prehit_iff {small large distinct sources : Nat} + {pattern : FewTimePattern small distinct} (configuration : OriginConfiguration pattern sources) + (hle : small ≤ large) (selected : pattern.selected) : + pattern.padSelectedEquiv hle selected ∈ (configuration.pad hle).prehit ↔ + selected ∈ configuration.prehit := by + classical + simp [OriginConfiguration.pad] + +theorem OriginConfiguration.pad_prehit_card {small large distinct sources : Nat} + {pattern : FewTimePattern small distinct} (configuration : OriginConfiguration pattern sources) + (hle : small ≤ large) : + (configuration.pad hle).prehit.card = configuration.prehit.card := by + classical + simp [OriginConfiguration.pad] + +theorem OriginConfiguration.pad_source_apply {small large distinct sources : Nat} + {pattern : FewTimePattern small distinct} (configuration : OriginConfiguration pattern sources) + (hle : small ≤ large) (selected : pattern.selected) + (hselected : selected ∈ configuration.prehit) : + (configuration.pad hle).source.1 + ⟨pattern.padSelectedEquiv hle selected, + (configuration.mem_pad_prehit_iff hle selected).2 hselected⟩ = + configuration.source.1 ⟨selected, hselected⟩ := by + classical + simp only [OriginConfiguration.pad] + apply congrArg configuration.source.1 + apply Subtype.ext + exact (pattern.padSelectedEquiv hle).symm_apply_apply selected + +def OriginConfiguration.PaddedRealizedBy {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + {q limit : Nat} (hle : signingLog.length ≤ limit) + (configuration : OriginConfiguration (cover.pattern.pad hle) q) + (trace : FullAdversaryTrace) (hlog : trace.signing.toSigningLog = signingLog) : Prop := + (∀ selected : cover.pattern.selected, + cover.pattern.padSelectedEquiv hle selected ∈ configuration.prehit ↔ + cover.EntryDigestPrecached trace.signing hlog + (cover.entriesEquivPatternSelected.symm selected)) + ∧ ∀ entry : cover.PrecachedEntries trace.signing hlog, + ∀ hselected : cover.pattern.padSelectedEquiv hle + (cover.entriesEquivPatternSelected entry.1) ∈ configuration.prehit, + ∃ (output : HashOutput) + (sourcePosition : Fin trace.hashQueries.length) + (intervalPosition : Fin trace.intervals.length) + (selectedIntervalPosition : Fin trace.intervals.length) + (hdirect : isDirectHashQuery (trace.intervals.get intervalPosition).input), + sourcePosition.val = + (configuration.source.1 + ⟨cover.pattern.padSelectedEquiv hle + (cover.entriesEquivPatternSelected entry.1), hselected⟩).val + ∧ sourcePosition.val = + (Fin.encodeSubtype (fun position => + isDirectHashQuery (trace.intervals.get position).input) + ⟨intervalPosition, hdirect⟩).val + ∧ intervalPosition.val < selectedIntervalPosition.val + ∧ AdversaryCacheEntry.signingEntry? + (trace.intervals.get selectedIntervalPosition) = + some (cover.cacheEntry trace.signing hlog entry.1) + ∧ ((trace.intervals.take selectedIntervalPosition.val).filterMap + AdversaryCacheEntry.signingEntry?).length = (cover.logIndex entry.1).val + ∧ (trace.intervals.get intervalPosition).input = + .inl (.inr (cover.entryDigestInput entry.1)) + ∧ (trace.intervals.get intervalPosition).initialCache + (cover.entryDigestInput entry.1) = none + ∧ (output, (trace.intervals.get intervalPosition).finalCache) ∈ support + ((randomOracle (cover.entryDigestInput entry.1)).run + (trace.intervals.get intervalPosition).initialCache) + ∧ signAttemptResultOfOutput output ≠ none + ∧ hashOutputFewTimeView output = cover.entryView entry.1 + +theorem OriginConfiguration.RealizedBy.pad {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + {cover : FewTimeCover f cache secretKey signingLog index targetLeaves} + {q limit : Nat} {configuration : OriginConfiguration cover.pattern q} + {trace : FullAdversaryTrace} {hlog : trace.signing.toSigningLog = signingLog} + (hrealized : configuration.RealizedBy cover trace hlog) + (hle : signingLog.length ≤ limit) : + (configuration.pad hle).PaddedRealizedBy cover hle trace hlog := by + constructor + · intro selected + rw [configuration.mem_pad_prehit_iff] + exact hrealized.1 selected + · intro entry hselected + let selected := cover.entriesEquivPatternSelected entry.1 + have hold : selected ∈ configuration.prehit := + (configuration.mem_pad_prehit_iff hle selected).1 hselected + obtain ⟨output, sourcePosition, intervalPosition, selectedIntervalPosition, hdirect, + hsource, hordinal, hrest⟩ := + hrealized.2 entry hold + refine ⟨output, sourcePosition, intervalPosition, selectedIntervalPosition, hdirect, + ?_, hordinal, hrest⟩ + have hpadSource := configuration.pad_source_apply hle selected hold + have hpadSource' : + (configuration.pad hle).source.1 + ⟨cover.pattern.padSelectedEquiv hle selected, hselected⟩ = + configuration.source.1 ⟨selected, hold⟩ := by + convert hpadSource + rw [hpadSource'] + exact hsource + +theorem FewTimeCover.exists_paddedRealized_originConfiguration_of_queryBudget + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.1.AgreesWithFn f) + (index : Index) (targetLeaves : DigestTree → FtsLeaf) + (cover : FewTimeCover f result.2.1 + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.signing.toSigningLog index targetLeaves) + (limit : Nat) (hle : result.2.2.signing.toSigningLog.length ≤ limit) : + ∃ configuration : OriginConfiguration (cover.pattern.pad hle) q, + configuration.PaddedRealizedBy cover hle result.2.2 rfl := by + obtain ⟨configuration, hrealized⟩ := + cover.exists_realized_originConfiguration_of_queryBudget adversary q hq parameter + hparameter otsSecret hots ftsSecret hfts result hresult f hf index targetLeaves + exact ⟨configuration.pad hle, hrealized.pad hle⟩ + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginPotential.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginPotential.lean new file mode 100644 index 00000000..8ededa94 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginPotential.lean @@ -0,0 +1,744 @@ +import SphincsSecurity.Proof.FewTimeOriginMonitor +import SphincsSecurity.Proof.FewTimeOriginWP +import VCVio.OracleComp.QueryTracking.RandomOracle.EagerTable + +/-! +# Partial-observation potential for a few-time origin configuration + +Observed selected views are fixed and every unseen selected position is completed uniformly. The +completion law below is the marginal identity used when a configured fresh source or signer records +one new view. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +namespace Concrete + +noncomputable def OriginObservation.completeViews {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (observation : OriginObservation configuration) + (fallback : pattern.selected → FewTimeView) : pattern.selected → FewTimeView := + fun selected => if selected ∈ observation.seenViews then observation.views selected + else fallback selected + +noncomputable def OriginObservation.completedViews {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (observation : OriginObservation configuration) : + ProbComp (pattern.selected → FewTimeView) := + observation.completeViews <$> ($ᵗ (pattern.selected → FewTimeView) : + ProbComp (pattern.selected → FewTimeView)) + +theorem OriginObservation.completeViews_recordFresh {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (observation : OriginObservation configuration) (selected : pattern.selected) + (view : FewTimeView) (fallback : pattern.selected → FewTimeView) + (hnotSeen : selected ∉ observation.seenViews) : + (observation.recordFresh selected view).completeViews fallback = + observation.completeViews (Function.update fallback selected view) := by + classical + funext other + by_cases hother : other = selected + · subst other + simp [OriginObservation.completeViews, OriginObservation.recordFresh, hnotSeen] + · simp [OriginObservation.completeViews, OriginObservation.recordFresh, hother] + +theorem OriginObservation.completeViews_recordSource {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (observation : OriginObservation configuration) + (selected : ↑configuration.prehit) (input : HashInput) (view : FewTimeView) + (fallback : pattern.selected → FewTimeView) + (hnotSeen : selected.1 ∉ observation.seenViews) : + (observation.recordSource selected input view).completeViews fallback = + observation.completeViews (Function.update fallback selected.1 view) := by + classical + funext other + by_cases hother : other = selected.1 + · subst other + simp [OriginObservation.completeViews, OriginObservation.recordSource, hnotSeen] + · simp [OriginObservation.completeViews, OriginObservation.recordSource, hother] + +theorem OriginObservation.evalDist_uniform_recordFresh_completedViews + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (observation : OriginObservation configuration) (selected : pattern.selected) + (hnotSeen : selected ∉ observation.seenViews) : + 𝒟[do + let view ← ($ᵗ FewTimeView : ProbComp FewTimeView) + (observation.recordFresh selected view).completedViews] = + 𝒟[observation.completedViews] := by + classical + simp only [OriginObservation.completedViews, map_eq_bind_pure_comp] + have hrewrite : + (do + let view ← ($ᵗ FewTimeView : ProbComp FewTimeView) + let fallback ← ($ᵗ (pattern.selected → FewTimeView) : + ProbComp (pattern.selected → FewTimeView)) + pure ((observation.recordFresh selected view).completeViews fallback)) = + (do + let view ← ($ᵗ FewTimeView : ProbComp FewTimeView) + let fallback ← ($ᵗ (pattern.selected → FewTimeView) : + ProbComp (pattern.selected → FewTimeView)) + pure (observation.completeViews (Function.update fallback selected view))) := by + apply bind_congr + intro view + apply bind_congr + intro fallback + rw [observation.completeViews_recordFresh selected view fallback hnotSeen] + change 𝒟[(do + let view ← ($ᵗ FewTimeView : ProbComp FewTimeView) + let fallback ← ($ᵗ (pattern.selected → FewTimeView) : + ProbComp (pattern.selected → FewTimeView)) + pure ((observation.recordFresh selected view).completeViews fallback))] = + 𝒟[(do + let fallback ← ($ᵗ (pattern.selected → FewTimeView) : + ProbComp (pattern.selected → FewTimeView)) + pure (observation.completeViews fallback))] + rw [hrewrite] + exact OracleComp.evalDist_uniformSample_bind_update_map + (R := FewTimeView) selected observation.completeViews + +theorem OriginObservation.evalDist_uniform_recordSource_completedViews + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (observation : OriginObservation configuration) + (selected : ↑configuration.prehit) (input : HashInput) + (hnotSeen : selected.1 ∉ observation.seenViews) : + 𝒟[do + let view ← ($ᵗ FewTimeView : ProbComp FewTimeView) + (observation.recordSource selected input view).completedViews] = + 𝒟[observation.completedViews] := by + classical + simp only [OriginObservation.completedViews, map_eq_bind_pure_comp] + have hrewrite : + (do + let view ← ($ᵗ FewTimeView : ProbComp FewTimeView) + let fallback ← ($ᵗ (pattern.selected → FewTimeView) : + ProbComp (pattern.selected → FewTimeView)) + pure ((observation.recordSource selected input view).completeViews fallback)) = + (do + let view ← ($ᵗ FewTimeView : ProbComp FewTimeView) + let fallback ← ($ᵗ (pattern.selected → FewTimeView) : + ProbComp (pattern.selected → FewTimeView)) + pure (observation.completeViews (Function.update fallback selected.1 view))) := by + apply bind_congr + intro view + apply bind_congr + intro fallback + rw [observation.completeViews_recordSource selected input view fallback hnotSeen] + change 𝒟[(do + let view ← ($ᵗ FewTimeView : ProbComp FewTimeView) + let fallback ← ($ᵗ (pattern.selected → FewTimeView) : + ProbComp (pattern.selected → FewTimeView)) + pure ((observation.recordSource selected input view).completeViews fallback))] = + 𝒟[(do + let fallback ← ($ᵗ (pattern.selected → FewTimeView) : + ProbComp (pattern.selected → FewTimeView)) + pure (observation.completeViews fallback))] + rw [hrewrite] + exact OracleComp.evalDist_uniformSample_bind_update_map + (R := FewTimeView) selected.1 observation.completeViews + +theorem OriginObservation.sum_uniform_prob_completedViews_recordFresh + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (observation : OriginObservation configuration) (selected : pattern.selected) + (hnotSeen : selected ∉ observation.seenViews) + (event : (pattern.selected → FewTimeView) → Prop) : + (∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + Pr[event | (observation.recordFresh selected view).completedViews]) = + Pr[event | observation.completedViews] := by + classical + calc + (∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + Pr[event | (observation.recordFresh selected view).completedViews]) = + ∑' view : FewTimeView, Pr[= view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + Pr[event | (observation.recordFresh selected view).completedViews] := by + simp only [tsum_fintype, probEvent_eq_eq_probOutput] + _ = Pr[event | ($ᵗ FewTimeView : ProbComp FewTimeView) >>= fun view => + (observation.recordFresh selected view).completedViews] := + (probEvent_bind_eq_tsum _ _ _).symm + _ = _ := probEvent_congr' (fun _ _ => Iff.rfl) + (observation.evalDist_uniform_recordFresh_completedViews selected hnotSeen) + +theorem OriginObservation.sum_uniform_prob_completedViews_recordSource + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (observation : OriginObservation configuration) + (selected : ↑configuration.prehit) (input : HashInput) + (hnotSeen : selected.1 ∉ observation.seenViews) + (event : (pattern.selected → FewTimeView) → Prop) : + (∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + Pr[event | (observation.recordSource selected input view).completedViews]) = + Pr[event | observation.completedViews] := by + classical + calc + (∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + Pr[event | (observation.recordSource selected input view).completedViews]) = + ∑' view : FewTimeView, Pr[= view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + Pr[event | (observation.recordSource selected input view).completedViews] := by + simp only [tsum_fintype, probEvent_eq_eq_probOutput] + _ = Pr[event | ($ᵗ FewTimeView : ProbComp FewTimeView) >>= fun view => + (observation.recordSource selected input view).completedViews] := + (probEvent_bind_eq_tsum _ _ _).symm + _ = _ := probEvent_congr' (fun _ _ => Iff.rfl) + (observation.evalDist_uniform_recordSource_completedViews selected input hnotSeen) + +noncomputable def OriginMonitorState.pendingSources {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) : Finset ↑configuration.prehit := by + classical + exact Finset.univ.filter fun selected => selected ∉ state.observation.seenSources + +noncomputable def OriginMonitorState.pendingReuses {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) : Finset ↑configuration.prehit := by + classical + exact Finset.univ.filter fun selected => + selected ∈ state.observation.seenSources ∧ state.signerOrdinal ≤ selected.1.1.val + +noncomputable def OriginMonitorState.completionMass {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) : ℝ≥0∞ := + Pr[event | state.observation.completedViews] + +noncomputable def OriginMonitorState.potential {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) : ℝ≥0∞ := + if state.valid then + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ state.pendingSources.card * + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ ^ state.pendingReuses.card * + state.completionMass event + else 0 + +@[simp] +theorem OriginMonitorState.pendingSources_initial {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) + (cache : QueryCache HashSpec) : + (OriginMonitorState.initial configuration cache).pendingSources.card = + configuration.prehit.card := by + classical + simp [OriginMonitorState.pendingSources, OriginMonitorState.initial, + OriginObservation.empty] + +@[simp] +theorem OriginMonitorState.pendingReuses_initial {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) + (cache : QueryCache HashSpec) : + (OriginMonitorState.initial configuration cache).pendingReuses.card = 0 := by + classical + simp [OriginMonitorState.pendingReuses, OriginMonitorState.initial, + OriginObservation.empty] + +theorem OriginObservation.completedViews_empty {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) : + (OriginObservation.empty configuration).completedViews = + ($ᵗ (pattern.selected → FewTimeView) : + ProbComp (pattern.selected → FewTimeView)) := by + classical + have hcomplete : (OriginObservation.empty configuration).completeViews = id := by + funext fallback selected + simp [OriginObservation.completeViews, OriginObservation.empty] + rw [OriginObservation.completedViews, hcomplete, id_map] + +theorem OriginMonitorState.potential_initial {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) + (cache : QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) → Prop) : + (OriginMonitorState.initial configuration cache).potential event = + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ configuration.prehit.card * + Pr[event | ($ᵗ (pattern.selected → FewTimeView) : + ProbComp (pattern.selected → FewTimeView))] := by + classical + rw [OriginMonitorState.potential] + rw [if_pos (show (OriginMonitorState.initial configuration cache).valid = true from rfl), + OriginMonitorState.pendingSources_initial, + OriginMonitorState.pendingReuses_initial, pow_zero, mul_one] + rw [OriginMonitorState.completionMass] + change ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ configuration.prehit.card * + Pr[event | (OriginObservation.empty configuration).completedViews] = _ + rw [OriginObservation.completedViews_empty] + +noncomputable def OriginMonitorState.recordSourceState {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : ↑configuration.prehit) + (input : HashInput) (view : FewTimeView) : OriginMonitorState configuration := + { state with + observation := state.observation.recordSource selected input view + directOrdinal := state.directOrdinal + 1 } + +noncomputable def OriginMonitorState.recordFreshState {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : pattern.selected) + (view : FewTimeView) : OriginMonitorState configuration := + { state with + observation := state.observation.recordFresh selected view + signerOrdinal := state.signerOrdinal + 1 } + +def OriginMonitorState.advanceSigner {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) : OriginMonitorState configuration := + { state with signerOrdinal := state.signerOrdinal + 1 } + +theorem OriginMonitorState.pendingSources_recordSourceState {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : ↑configuration.prehit) + (input : HashInput) (view : FewTimeView) : + (state.recordSourceState selected input view).pendingSources = + state.pendingSources.erase selected := by + classical + ext other + by_cases hother : other = selected + · subst other + simp [OriginMonitorState.pendingSources, OriginMonitorState.recordSourceState, + OriginObservation.recordSource] + · simp [OriginMonitorState.pendingSources, OriginMonitorState.recordSourceState, + OriginObservation.recordSource, hother] + +theorem OriginMonitorState.pendingSources_recordSourceState_card_add_one + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : ↑configuration.prehit) + (input : HashInput) (view : FewTimeView) + (hnotSeen : selected ∉ state.observation.seenSources) : + (state.recordSourceState selected input view).pendingSources.card + 1 = + state.pendingSources.card := by + classical + rw [state.pendingSources_recordSourceState selected input view] + apply Finset.card_erase_add_one + simp [OriginMonitorState.pendingSources, hnotSeen] + +theorem OriginMonitorState.pendingReuses_recordSourceState {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : ↑configuration.prehit) + (input : HashInput) (view : FewTimeView) + (hpending : state.signerOrdinal ≤ selected.1.1.val) : + (state.recordSourceState selected input view).pendingReuses = + insert selected state.pendingReuses := by + classical + ext other + by_cases hother : other = selected + · subst other + simp [OriginMonitorState.pendingReuses, OriginMonitorState.recordSourceState, + OriginObservation.recordSource, hpending] + · simp [OriginMonitorState.pendingReuses, OriginMonitorState.recordSourceState, + OriginObservation.recordSource, hother] + +theorem OriginMonitorState.pendingReuses_recordSourceState_card + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : ↑configuration.prehit) + (input : HashInput) (view : FewTimeView) + (hnotSeen : selected ∉ state.observation.seenSources) + (hpending : state.signerOrdinal ≤ selected.1.1.val) : + (state.recordSourceState selected input view).pendingReuses.card = + state.pendingReuses.card + 1 := by + classical + rw [state.pendingReuses_recordSourceState selected input view hpending, + Finset.card_insert_of_notMem] + simp [OriginMonitorState.pendingReuses, hnotSeen] + +theorem OriginMonitorState.pendingSources_recordFreshState {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : pattern.selected) + (view : FewTimeView) : + (state.recordFreshState selected view).pendingSources = state.pendingSources := by + rfl + +theorem OriginMonitorState.pendingReuses_recordFreshState {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : pattern.selected) + (view : FewTimeView) (hordinal : selected.1.val = state.signerOrdinal) + (hnotPrehit : selected ∉ configuration.prehit) : + (state.recordFreshState selected view).pendingReuses = state.pendingReuses := by + classical + ext candidate + simp only [OriginMonitorState.pendingReuses, OriginMonitorState.recordFreshState, + Finset.mem_filter, Finset.mem_univ, true_and] + constructor + · rintro ⟨hseen, hle⟩ + exact ⟨hseen, Nat.le_trans (Nat.le_succ _) hle⟩ + · rintro ⟨hseen, hle⟩ + refine ⟨hseen, ?_⟩ + by_contra hnot + have hcandidate : candidate.1.1.val = state.signerOrdinal := by omega + have heq : candidate.1 = selected := by + apply Subtype.ext + apply Fin.ext + exact hcandidate.trans hordinal.symm + exact hnotPrehit (heq ▸ candidate.2) + +theorem OriginMonitorState.pendingSources_advanceSigner {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) : + state.advanceSigner.pendingSources = state.pendingSources := by + rfl + +theorem OriginMonitorState.pendingReuses_advanceSigner {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : ↑configuration.prehit) + (hseen : selected ∈ state.observation.seenSources) + (hordinal : selected.1.1.val = state.signerOrdinal) : + state.advanceSigner.pendingReuses = state.pendingReuses.erase selected := by + classical + ext candidate + by_cases hcandidate : candidate = selected + · subst candidate + simp [OriginMonitorState.pendingReuses, OriginMonitorState.advanceSigner, hseen, + hordinal] + · simp only [OriginMonitorState.pendingReuses, OriginMonitorState.advanceSigner, + Finset.mem_filter, Finset.mem_univ, true_and, Finset.mem_erase] + constructor + · rintro ⟨hcandidateSeen, hle⟩ + exact ⟨hcandidate, hcandidateSeen, Nat.le_trans (Nat.le_succ _) hle⟩ + · rintro ⟨_, hcandidateSeen, hle⟩ + refine ⟨hcandidateSeen, ?_⟩ + by_contra hnot + have hvalue : candidate.1.1.val = state.signerOrdinal := by omega + have heq : candidate = selected := by + apply Subtype.ext + apply Subtype.ext + apply Fin.ext + exact hvalue.trans hordinal.symm + exact hcandidate heq + +theorem OriginMonitorState.pendingReuses_advanceSigner_card_add_one + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : ↑configuration.prehit) + (hseen : selected ∈ state.observation.seenSources) + (hordinal : selected.1.1.val = state.signerOrdinal) : + state.advanceSigner.pendingReuses.card + 1 = state.pendingReuses.card := by + classical + rw [state.pendingReuses_advanceSigner selected hseen hordinal] + apply Finset.card_erase_add_one + simp [OriginMonitorState.pendingReuses, hseen, hordinal] + +theorem OriginMonitorState.pendingReuses_advanceSigner_of_selectedAt?_eq_none + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) + (hselected : pattern.selectedAt? state.signerOrdinal = none) : + state.advanceSigner.pendingReuses = state.pendingReuses := by + classical + ext candidate + simp only [OriginMonitorState.pendingReuses, OriginMonitorState.advanceSigner, + Finset.mem_filter, Finset.mem_univ, true_and] + constructor + · rintro ⟨hseen, hle⟩ + exact ⟨hseen, Nat.le_trans (Nat.le_succ _) hle⟩ + · rintro ⟨hseen, hle⟩ + refine ⟨hseen, ?_⟩ + by_contra hnot + have heq : candidate.1.1.val = state.signerOrdinal := by omega + have hsome : pattern.selectedAt? state.signerOrdinal = some candidate.1 := + (pattern.selectedAt?_eq_some_iff state.signerOrdinal candidate.1).2 heq + rw [hselected] at hsome + contradiction + +theorem OriginMonitorState.potential_advanceSigner_of_selectedAt?_eq_none + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (hselected : pattern.selectedAt? state.signerOrdinal = none) : + state.advanceSigner.potential event = state.potential event := by + classical + rw [OriginMonitorState.potential, OriginMonitorState.potential] + have hvalid : state.advanceSigner.valid = state.valid := rfl + rw [hvalid] + congr 1 + rw [congrArg Finset.card state.pendingSources_advanceSigner, + congrArg Finset.card + (state.pendingReuses_advanceSigner_of_selectedAt?_eq_none hselected)] + rfl + +theorem source_reuse_weighted_sum + {Index : Type} [Fintype Index] (probability mass : Index → ℝ≥0∞) + (sourceCount reuseCount : Nat) (totalMass : ℝ≥0∞) + (hmass : (∑ index, probability index * mass index) = totalMass) : + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + ∑ index, probability index * + (((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ sourceCount * + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ ^ (reuseCount + 1) * mass index) = + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ (sourceCount + 1) * + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ ^ reuseCount * totalMass := by + rw [pow_succ ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹] + have hfactor : + (∑ index, probability index * + (((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ sourceCount * + (((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ ^ reuseCount * + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹) * mass index)) = + (((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ sourceCount * + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ ^ reuseCount * + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹) * + ∑ index, probability index * mass index := by + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro index _ + ring + rw [hfactor, hmass, pow_succ _ sourceCount] + have hweight : + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ = + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ := by + rw [mul_comm, prehit_race_source_weight] + rw [← hweight] + ring + +theorem uniform_weighted_sum + {Index : Type} [Fintype Index] (probability mass : Index → ℝ≥0∞) + (factor totalMass : ℝ≥0∞) + (hmass : (∑ index, probability index * mass index) = totalMass) : + (∑ index, probability index * (factor * mass index)) = factor * totalMass := by + calc + (∑ index, probability index * (factor * mass index)) = + ∑ index, factor * (probability index * mass index) := by + apply Finset.sum_congr rfl + intro index _ + ring + _ = factor * ∑ index, probability index * mass index := by rw [Finset.mul_sum] + _ = _ := by rw [hmass] + +theorem OriginMonitorState.sum_uniform_potential_recordSourceState + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : ↑configuration.prehit) + (input : HashInput) (event : (pattern.selected → FewTimeView) → Prop) + (hvalid : state.valid = true) + (hnotSource : selected ∉ state.observation.seenSources) + (hnotView : selected.1 ∉ state.observation.seenViews) + (hpending : state.signerOrdinal ≤ selected.1.1.val) : + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (state.recordSourceState selected input view).potential event = + state.potential event := by + classical + have hsource := state.pendingSources_recordSourceState_card_add_one + selected input default hnotSource + have hsourceView : ∀ view, + (state.recordSourceState selected input view).pendingSources.card = + (state.recordSourceState selected input default).pendingSources.card := fun view => by + rw [state.pendingSources_recordSourceState selected input view, + state.pendingSources_recordSourceState selected input default] + have hreusesView : ∀ view, + (state.recordSourceState selected input view).pendingReuses.card = + state.pendingReuses.card + 1 := fun view => + state.pendingReuses_recordSourceState_card selected input view hnotSource hpending + have hnextValid : ∀ view, + (state.recordSourceState selected input view).valid = true := fun _ => hvalid + simp_rw [OriginMonitorState.potential, if_pos hvalid] + simp_rw [if_pos (hnextValid _), OriginMonitorState.completionMass, + hsourceView, hreusesView] + rw [← hsource] + apply source_reuse_weighted_sum + exact state.observation.sum_uniform_prob_completedViews_recordSource + selected input hnotView event + +theorem OriginMonitorState.sum_uniform_potential_recordFreshState + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : pattern.selected) + (event : (pattern.selected → FewTimeView) → Prop) + (hvalid : state.valid = true) + (hnotView : selected ∉ state.observation.seenViews) + (hordinal : selected.1.val = state.signerOrdinal) + (hnotPrehit : selected ∉ configuration.prehit) : + (∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (state.recordFreshState selected view).potential event) = + state.potential event := by + classical + have hsources : ∀ view, + (state.recordFreshState selected view).pendingSources.card = + state.pendingSources.card := fun view => congrArg Finset.card + (state.pendingSources_recordFreshState selected view) + have hreuses : ∀ view, + (state.recordFreshState selected view).pendingReuses.card = + state.pendingReuses.card := fun view => congrArg Finset.card + (state.pendingReuses_recordFreshState selected view hordinal hnotPrehit) + have hnextValid : ∀ view, + (state.recordFreshState selected view).valid = true := fun _ => hvalid + simp_rw [OriginMonitorState.potential, if_pos hvalid] + simp_rw [if_pos (hnextValid _), OriginMonitorState.completionMass, hsources, hreuses] + apply uniform_weighted_sum + exact state.observation.sum_uniform_prob_completedViews_recordFresh selected hnotView event + +theorem OriginMonitorState.reuseWeight_mul_potential_advanceSigner + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : ↑configuration.prehit) + (event : (pattern.selected → FewTimeView) → Prop) + (hvalid : state.valid = true) + (hseen : selected ∈ state.observation.seenSources) + (hordinal : selected.1.1.val = state.signerOrdinal) : + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * state.advanceSigner.potential event = + state.potential event := by + classical + have hsources : state.advanceSigner.pendingSources.card = state.pendingSources.card := + congrArg Finset.card state.pendingSources_advanceSigner + have hreuses := state.pendingReuses_advanceSigner_card_add_one selected hseen hordinal + have hnextValid : state.advanceSigner.valid = true := hvalid + rw [OriginMonitorState.potential, if_pos hnextValid, + OriginMonitorState.potential, if_pos hvalid, + hsources, OriginMonitorState.completionMass, OriginMonitorState.completionMass] + change ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * + (((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ state.pendingSources.card * + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ ^ state.advanceSigner.pendingReuses.card * + Pr[event | state.observation.completedViews]) = _ + rw [← hreuses, pow_succ _ state.advanceSigner.pendingReuses.card] + ring + +def OriginMonitorState.ScheduleCoherent {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) : Prop := + state.valid = true → + (∀ selected : ↑configuration.prehit, + selected ∈ state.observation.seenSources ↔ + (configuration.source.1 selected).val < state.directOrdinal) ∧ + (∀ selected : pattern.selected, + selected ∈ state.observation.seenViews ↔ + selected.1.val < state.signerOrdinal ∨ + ∃ hprehit : selected ∈ configuration.prehit, + (configuration.source.1 ⟨selected, hprehit⟩).val < state.directOrdinal) ∧ + ∀ selected : pattern.selected, ∀ hprehit : selected ∈ configuration.prehit, + selected.1.val < state.signerOrdinal → + (configuration.source.1 ⟨selected, hprehit⟩).val < state.directOrdinal + +theorem OriginMonitorState.scheduleCoherent_initial {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) + (cache : QueryCache HashSpec) : + (OriginMonitorState.initial configuration cache).ScheduleCoherent := by + classical + intro _ + constructor + · intro selected + simp [OriginMonitorState.initial, OriginObservation.empty] + constructor + · intro selected + simp [OriginMonitorState.initial, OriginObservation.empty] + · intro selected hprehit hlt + change selected.1.val < 0 at hlt + omega + +theorem OriginMonitorState.sourceAt_not_seenSource {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : ↑configuration.prehit) + (hcoherent : state.ScheduleCoherent) (hvalid : state.valid = true) + (hsource : configuration.sourceAt? state.directOrdinal = some selected) : + selected ∉ state.observation.seenSources := by + intro hseen + have hlt := (hcoherent hvalid).1 selected |>.mp hseen + have heq := (configuration.sourceAt?_eq_some_iff state.directOrdinal selected).mp hsource + omega + +theorem OriginMonitorState.sourceAt_signer_pending {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : ↑configuration.prehit) + (hcoherent : state.ScheduleCoherent) (hvalid : state.valid = true) + (hsource : configuration.sourceAt? state.directOrdinal = some selected) : + state.signerOrdinal ≤ selected.1.1.val := by + by_contra hnot + have hsigned : selected.1.1.val < state.signerOrdinal := by omega + have hlt := (hcoherent hvalid).2.2 selected.1 selected.2 hsigned + have hsame : (⟨selected.1, selected.2⟩ : ↑configuration.prehit) = selected := by + apply Subtype.ext + rfl + rw [hsame] at hlt + have heq := (configuration.sourceAt?_eq_some_iff state.directOrdinal selected).mp hsource + omega + +theorem OriginMonitorState.sourceAt_not_seenView {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : ↑configuration.prehit) + (hcoherent : state.ScheduleCoherent) (hvalid : state.valid = true) + (hsource : configuration.sourceAt? state.directOrdinal = some selected) : + selected.1 ∉ state.observation.seenViews := by + intro hseen + rcases (hcoherent hvalid).2.1 selected.1 |>.mp hseen with hsigned | ⟨hprehit, hlt⟩ + · exact (Nat.not_lt_of_ge + (state.sourceAt_signer_pending selected hcoherent hvalid hsource)) hsigned + · have heqPrehit : (⟨selected.1, hprehit⟩ : ↑configuration.prehit) = selected := by + apply Subtype.ext + rfl + rw [heqPrehit] at hlt + have heq := (configuration.sourceAt?_eq_some_iff state.directOrdinal selected).mp hsource + omega + +theorem OriginMonitorState.selectedAt_fresh_not_seenView {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : pattern.selected) + (hcoherent : state.ScheduleCoherent) (hvalid : state.valid = true) + (hselected : pattern.selectedAt? state.signerOrdinal = some selected) + (hnotPrehit : selected ∉ configuration.prehit) : + selected ∉ state.observation.seenViews := by + intro hseen + rcases (hcoherent hvalid).2.1 selected |>.mp hseen with hsigned | ⟨hprehit, _⟩ + · have heq := (pattern.selectedAt?_eq_some_iff state.signerOrdinal selected).mp hselected + omega + · exact hnotPrehit hprehit + +theorem OriginMonitorState.selectedAt_prehit_seenView {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : pattern.selected) + (hcoherent : state.ScheduleCoherent) (hvalid : state.valid = true) + (hprehit : selected ∈ configuration.prehit) + (hseen : (⟨selected, hprehit⟩ : ↑configuration.prehit) ∈ + state.observation.seenSources) : + selected ∈ state.observation.seenViews := by + apply (hcoherent hvalid).2.1 selected |>.mpr + exact Or.inr ⟨hprehit, (hcoherent hvalid).1 ⟨selected, hprehit⟩ |>.mp hseen⟩ + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginProbability.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginProbability.lean new file mode 100644 index 00000000..0d8ff22d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginProbability.lean @@ -0,0 +1,683 @@ +import SphincsSecurity.Proof.FewTimeOriginRealization +import SphincsSecurity.Proof.FewTimeFixedPrehit + +/-! +# Probability composition for a direct few-time origin + +A realized prehit has a fresh direct random-oracle source. If the rest of the execution can satisfy +an event only after that source returns an admissible answer with a selected view, its probability +is the source probability multiplied by the conditional bound for the rest of the execution. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +theorem probEvent_bind_le_gated_mul + {First Second : Type} {firstComp : ProbComp First} + {continuation : First → ProbComp Second} {gate : First → Prop} + {event : Second → Prop} {epsilon : ℝ≥0∞} + (hoff : ∀ result ∈ support firstComp, ¬ gate result → + Pr[event | continuation result] = 0) + (hon : ∀ result ∈ support firstComp, gate result → + Pr[event | continuation result] ≤ epsilon) : + Pr[event | firstComp >>= continuation] ≤ Pr[gate | firstComp] * epsilon := by + classical + rw [probEvent_bind_eq_tsum] + calc + ∑' result, Pr[= result | firstComp] * Pr[event | continuation result] ≤ + ∑' result, {result | gate result}.indicator + (fun value => Pr[= value | firstComp] * epsilon) result := by + apply ENNReal.tsum_le_tsum + intro result + by_cases hresult : result ∈ support firstComp + · by_cases hgate : gate result + · simpa [hgate] using mul_le_mul' le_rfl (hon result hresult hgate) + · rw [hoff result hresult hgate] + simp [hgate] + · rw [probOutput_eq_zero_of_not_mem_support hresult] + simp + _ = (∑' result, {result | gate result}.indicator + (fun value => Pr[= value | firstComp]) result) * epsilon := by + rw [← ENNReal.tsum_mul_right] + apply tsum_congr + intro result + by_cases hgate : gate result <;> simp [hgate] + _ = Pr[gate | firstComp] * epsilon := by + rw [probEvent_eq_tsum_indicator] + +theorem probEvent_bind_le_classifiedRisk + {First Second Index : Type} [Fintype Index] + {firstComp : ProbComp First} {continuation : First → ProbComp Second} + (classify : First → Option Index) (risk : Index → ℝ≥0∞) + (event : Second → Prop) + (hoff : ∀ result ∈ support firstComp, classify result = none → + Pr[event | continuation result] = 0) + (hon : ∀ result ∈ support firstComp, ∀ index, + classify result = some index → + Pr[event | continuation result] ≤ risk index) : + Pr[event | firstComp >>= continuation] ≤ + ∑ index, Pr[fun result => classify result = some index | firstComp] * risk index := by + classical + rw [probEvent_bind_eq_tsum] + calc + ∑' result, Pr[= result | firstComp] * Pr[event | continuation result] ≤ + ∑' result, ∑ index, + if classify result = some index then + Pr[= result | firstComp] * risk index + else 0 := by + apply ENNReal.tsum_le_tsum + intro result + by_cases hresult : result ∈ support firstComp + · cases hclass : classify result with + | none => + rw [hoff result hresult hclass] + simp + | some index => + calc + Pr[= result | firstComp] * Pr[event | continuation result] ≤ + Pr[= result | firstComp] * risk index := + mul_le_mul' le_rfl (hon result hresult index hclass) + _ = ∑ candidate, + if some index = some candidate then + Pr[= result | firstComp] * risk candidate + else 0 := by + rw [Finset.sum_eq_single index] + · rw [if_pos rfl] + · intro candidate _ hne + rw [if_neg] + exact fun heq => hne (Option.some.inj heq).symm + · intro hnot + exact (hnot (Finset.mem_univ index)).elim + · rw [probOutput_eq_zero_of_not_mem_support hresult] + simp + _ = ∑ index, ∑' result, + if classify result = some index then + Pr[= result | firstComp] * risk index + else 0 := by + calc + (∑' result, ∑ index, + if classify result = some index then + Pr[= result | firstComp] * risk index + else 0) = + ∑' result, ∑' index, + if classify result = some index then + Pr[= result | firstComp] * risk index + else 0 := by simp only [tsum_fintype] + _ = ∑' index, ∑' result, + if classify result = some index then + Pr[= result | firstComp] * risk index + else 0 := ENNReal.tsum_comm + _ = _ := by simp only [tsum_fintype] + _ = ∑ index, Pr[fun result => classify result = some index | firstComp] * + risk index := by + apply Finset.sum_congr rfl + intro index _ + rw [probEvent_eq_tsum_indicator, ← ENNReal.tsum_mul_right] + apply tsum_congr + intro result + by_cases hclass : classify result = some index <;> simp [hclass] + +theorem probEvent_bind_le_uniformClassifiedRisk + {First Second Index : Type} [Fintype Index] + {firstComp : ProbComp First} {continuation : First → ProbComp Second} + (classify : First → Option Index) (uniform : ProbComp Index) + (weight : ℝ≥0∞) (risk : Index → ℝ≥0∞) (event : Second → Prop) + (hpoint : ∀ index, + Pr[fun result => classify result = some index | firstComp] ≤ + weight * Pr[fun value : Index => value = index | uniform]) + (hoff : ∀ result ∈ support firstComp, classify result = none → + Pr[event | continuation result] = 0) + (hon : ∀ result ∈ support firstComp, ∀ index, + classify result = some index → + Pr[event | continuation result] ≤ risk index) : + Pr[event | firstComp >>= continuation] ≤ + weight * ∑ index, Pr[fun value : Index => value = index | uniform] * risk index := by + calc + Pr[event | firstComp >>= continuation] ≤ + ∑ index, Pr[fun result => classify result = some index | firstComp] * risk index := + probEvent_bind_le_classifiedRisk classify risk event hoff hon + _ ≤ ∑ index, + (weight * Pr[fun value : Index => value = index | uniform]) * risk index := by + apply Finset.sum_le_sum + intro index _ + exact mul_le_mul' (hpoint index) le_rfl + _ = ∑ index, weight * + (Pr[fun value : Index => value = index | uniform] * risk index) := by + apply Finset.sum_congr rfl + intro index _ + rw [mul_assoc] + _ = _ := by rw [Finset.mul_sum] + +theorem tsum_probOutput_mul_le_gated + {Value : Type} (computation : ProbComp Value) (gate : Value → Prop) + (cost : Value → ℝ≥0∞) (epsilon : ℝ≥0∞) + (hoff : ∀ value ∈ support computation, ¬ gate value → cost value = 0) + (hon : ∀ value ∈ support computation, gate value → cost value ≤ epsilon) : + (∑' value, Pr[= value | computation] * cost value) ≤ + Pr[gate | computation] * epsilon := by + classical + rw [probEvent_eq_tsum_indicator, ← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro value + by_cases hvalue : value ∈ support computation + · by_cases hgate : gate value + · simpa [hgate] using mul_le_mul' le_rfl (hon value hvalue hgate) + · rw [hoff value hvalue hgate] + simp [hgate] + · rw [probOutput_eq_zero_of_not_mem_support hvalue] + simp + +theorem tsum_probOutput_mul_le_classifiedRisk + {Value Index : Type} [Fintype Index] + (computation : ProbComp Value) (classify : Value → Option Index) + (risk : Index → ℝ≥0∞) (cost : Value → ℝ≥0∞) + (hoff : ∀ value ∈ support computation, classify value = none → cost value = 0) + (hon : ∀ value ∈ support computation, ∀ index, + classify value = some index → cost value ≤ risk index) : + (∑' value, Pr[= value | computation] * cost value) ≤ + ∑ index, Pr[fun value => classify value = some index | computation] * risk index := by + classical + calc + ∑' value, Pr[= value | computation] * cost value ≤ + ∑' value, ∑ index, + if classify value = some index then Pr[= value | computation] * risk index + else 0 := by + apply ENNReal.tsum_le_tsum + intro value + by_cases hvalue : value ∈ support computation + · cases hclass : classify value with + | none => + rw [hoff value hvalue hclass] + simp + | some index => + calc + Pr[= value | computation] * cost value ≤ + Pr[= value | computation] * risk index := + mul_le_mul' le_rfl (hon value hvalue index hclass) + _ = ∑ candidate, + if some index = some candidate then + Pr[= value | computation] * risk candidate + else 0 := by + rw [Finset.sum_eq_single index] + · rw [if_pos rfl] + · intro candidate _ hne + rw [if_neg] + exact fun heq => hne (Option.some.inj heq).symm + · intro hnot + exact (hnot (Finset.mem_univ index)).elim + · rw [probOutput_eq_zero_of_not_mem_support hvalue] + simp + _ = ∑ index, ∑' value, + if classify value = some index then Pr[= value | computation] * risk index + else 0 := by + calc + (∑' value, ∑ index, + if classify value = some index then Pr[= value | computation] * risk index + else 0) = + ∑' value, ∑' index, + if classify value = some index then Pr[= value | computation] * risk index + else 0 := by simp only [tsum_fintype] + _ = ∑' index, ∑' value, + if classify value = some index then Pr[= value | computation] * risk index + else 0 := ENNReal.tsum_comm + _ = _ := by simp only [tsum_fintype] + _ = _ := by + apply Finset.sum_congr rfl + intro index _ + rw [probEvent_eq_tsum_indicator, ← ENNReal.tsum_mul_right] + apply tsum_congr + intro value + by_cases hclass : classify value = some index <;> simp [hclass] + +theorem tsum_probOutput_mul_le_uniformClassifiedRisk + {Value Index : Type} [Fintype Index] + (computation : ProbComp Value) (classify : Value → Option Index) + (uniform : ProbComp Index) (weight : ℝ≥0∞) + (risk : Index → ℝ≥0∞) (cost : Value → ℝ≥0∞) + (hpoint : ∀ index, Pr[fun value => classify value = some index | computation] ≤ + weight * Pr[fun value : Index => value = index | uniform]) + (hoff : ∀ value ∈ support computation, classify value = none → cost value = 0) + (hon : ∀ value ∈ support computation, ∀ index, + classify value = some index → cost value ≤ risk index) : + (∑' value, Pr[= value | computation] * cost value) ≤ + weight * ∑ index, Pr[fun value : Index => value = index | uniform] * risk index := by + calc + ∑' value, Pr[= value | computation] * cost value ≤ + ∑ index, Pr[fun value => classify value = some index | computation] * risk index := + tsum_probOutput_mul_le_classifiedRisk computation classify risk cost hoff hon + _ ≤ ∑ index, + (weight * Pr[fun value : Index => value = index | uniform]) * risk index := by + apply Finset.sum_le_sum + intro index _ + exact mul_le_mul' (hpoint index) le_rfl + _ = ∑ index, weight * + (Pr[fun value : Index => value = index | uniform] * risk index) := by + apply Finset.sum_congr rfl + intro index _ + rw [mul_assoc] + _ = _ := by rw [Finset.mul_sum] + +noncomputable def Concrete.freshSuccessfulView? + (initialCache : QueryCache HashSpec) (secretKey : SecretKey) (message : Message) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) : + Option FewTimeView := by + classical + exact if FreshSuccessfulSignerView initialCache secretKey message (fun _ => True) result then + result.1.2 + else none + +theorem Concrete.freshSuccessfulView?_eq_some_iff + (initialCache : QueryCache HashSpec) (secretKey : SecretKey) (message : Message) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) + (view : FewTimeView) : + freshSuccessfulView? initialCache secretKey message result = some view ↔ + FreshSuccessfulSignerView initialCache secretKey message + (fun value => value = view) result := by + classical + constructor + · intro hview + by_cases hfresh : FreshSuccessfulSignerView initialCache secretKey message + (fun _ => True) result + · rw [freshSuccessfulView?, if_pos hfresh] at hview + obtain ⟨signature, selectedView, hresult, hmiss, _⟩ := hfresh + have hselected : selectedView = view := by + apply Option.some.inj + simpa [hresult] using hview + subst selectedView + exact ⟨signature, view, hresult, hmiss, rfl⟩ + · simp [freshSuccessfulView?, hfresh] at hview + · rintro ⟨signature, selectedView, hresult, hmiss, hview⟩ + subst selectedView + have hfresh : FreshSuccessfulSignerView initialCache secretKey message + (fun _ => True) result := ⟨signature, view, hresult, hmiss, trivial⟩ + simp [freshSuccessfulView?, hfresh, hresult] + +set_option maxRecDepth 100000 in +theorem Concrete.probEvent_signWithView_fresh_bind_le_expected + {Result : Type} (secretKey : SecretKey) (message : Message) + (initialCache : QueryCache HashSpec) + (continuation : (Option Signature × Option FewTimeView) × QueryCache HashSpec → + ProbComp Result) + (event : Result → Prop) (risk : FewTimeView → ℝ≥0∞) + (hoff : ∀ signerResult ∈ support + ((simulateQ romImpl (signWithView secretKey message)).run initialCache), + freshSuccessfulView? initialCache secretKey message signerResult = none → + Pr[event | continuation signerResult] = 0) + (hon : ∀ signerResult ∈ support + ((simulateQ romImpl (signWithView secretKey message)).run initialCache), + ∀ view, freshSuccessfulView? initialCache secretKey message signerResult = some view → + Pr[event | continuation signerResult] ≤ risk view) : + Pr[event | + (simulateQ romImpl (signWithView secretKey message)).run initialCache >>= + continuation] ≤ + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * risk view := by + have hbound := probEvent_bind_le_classifiedRisk + (freshSuccessfulView? initialCache secretKey message) risk event hoff hon + refine hbound.trans ?_ + apply Finset.sum_le_sum + intro view _ + apply mul_le_mul' _ le_rfl + simpa only [freshSuccessfulView?_eq_some_iff] using + probEvent_signWithView_freshSuccessful_le_uniform secretKey message initialCache + (fun value => value = view) + +theorem Concrete.probEvent_signWithView_fixedPrehit_bind_le_mul_of_enncard_le + {Result : Type} (secretKey : SecretKey) (message : Message) + (initialCache : QueryCache HashSpec) (target : HashInput) (P : FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) (hcache : QueryCache.enncard initialCache ≤ q) + (continuation : (Option Signature × Option FewTimeView) × QueryCache HashSpec → + ProbComp Result) + (event : Result → Prop) (epsilon : ℝ≥0∞) + (hoff : ∀ signerResult ∈ support + ((simulateQ romImpl (signWithView secretKey message)).run initialCache), + ¬ PrehitSuccessfulSignerView (onlyInputCache initialCache target) + secretKey message P signerResult → + Pr[event | continuation signerResult] = 0) + (hon : ∀ signerResult ∈ support + ((simulateQ romImpl (signWithView secretKey message)).run initialCache), + PrehitSuccessfulSignerView (onlyInputCache initialCache target) + secretKey message P signerResult → + Pr[event | continuation signerResult] ≤ epsilon) : + Pr[event | + (simulateQ romImpl (signWithView secretKey message)).run initialCache >>= + continuation] ≤ + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * epsilon := by + calc + Pr[event | + (simulateQ romImpl (signWithView secretKey message)).run initialCache >>= + continuation] ≤ + Pr[PrehitSuccessfulSignerView (onlyInputCache initialCache target) + secretKey message P | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] * epsilon := + probEvent_bind_le_gated_mul hoff hon + _ ≤ ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * epsilon := by + apply mul_le_mul' _ le_rfl + exact probEvent_signWithView_fixedPrehit_le_race_of_enncard_le + secretKey message initialCache target P q hq hcache + +theorem Concrete.probEvent_randomOracle_fresh_bind_admissible_view_le_mul + {Result : Type} (input : HashInput) (cache : QueryCache HashSpec) + (hcache : cache input = none) (P : FewTimeView → Prop) + (continuation : HashOutput × QueryCache HashSpec → ProbComp Result) + (event : Result → Prop) (epsilon : ℝ≥0∞) + (hoff : ∀ source ∈ support ((randomOracle input).run cache), + ¬ (signAttemptResultOfOutput source.1 ≠ none ∧ + P (hashOutputFewTimeView source.1)) → + Pr[event | continuation source] = 0) + (hon : ∀ source ∈ support ((randomOracle input).run cache), + signAttemptResultOfOutput source.1 ≠ none ∧ + P (hashOutputFewTimeView source.1) → + Pr[event | continuation source] ≤ epsilon) : + Pr[event | (randomOracle input).run cache >>= continuation] ≤ + (((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + Pr[P | ($ᵗ FewTimeView : ProbComp FewTimeView)]) * epsilon := by + refine (probEvent_bind_le_gated_mul hoff hon).trans_eq ?_ + rw [probEvent_randomOracle_fresh_admissible_view input cache hcache P] + +theorem Concrete.probEvent_randomOracle_fresh_bind_fixedPrehit_le + {Result : Type} (input : HashInput) (cache : QueryCache HashSpec) + (hcache : cache input = none) (P : FewTimeView → Prop) + (continuation : HashOutput × QueryCache HashSpec → ProbComp Result) + (event : Result → Prop) + (hoff : ∀ source ∈ support ((randomOracle input).run cache), + ¬ (signAttemptResultOfOutput source.1 ≠ none ∧ + P (hashOutputFewTimeView source.1)) → + Pr[event | continuation source] = 0) + (hon : ∀ source ∈ support ((randomOracle input).run cache), + signAttemptResultOfOutput source.1 ≠ none ∧ + P (hashOutputFewTimeView source.1) → + Pr[event | continuation source] ≤ + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹) : + Pr[event | (randomOracle input).run cache >>= continuation] ≤ + Pr[P | ($ᵗ FewTimeView : ProbComp FewTimeView)] * + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ := by + calc + Pr[event | (randomOracle input).run cache >>= continuation] ≤ + (((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + Pr[P | ($ᵗ FewTimeView : ProbComp FewTimeView)]) * + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ := + probEvent_randomOracle_fresh_bind_admissible_view_le_mul input cache hcache P + continuation event _ hoff hon + _ = Pr[P | ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹) := by + ac_rfl + _ = Pr[P | ($ᵗ FewTimeView : ProbComp FewTimeView)] * + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ := by + rw [prehit_race_source_weight] + +theorem Concrete.probEvent_randomOracle_fresh_bind_admissible_view_le_expected + {Result : Type} (input : HashInput) (cache : QueryCache HashSpec) + (hcache : cache input = none) + (continuation : HashOutput × QueryCache HashSpec → ProbComp Result) + (event : Result → Prop) (risk : FewTimeView → ℝ≥0∞) + (hoff : ∀ source ∈ support ((randomOracle input).run cache), + signAttemptResultOfOutput source.1 = none → + Pr[event | continuation source] = 0) + (hon : ∀ source ∈ support ((randomOracle input).run cache), + signAttemptResultOfOutput source.1 ≠ none → + Pr[event | continuation source] ≤ + risk (hashOutputFewTimeView source.1)) : + Pr[event | (randomOracle input).run cache >>= continuation] ≤ + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * risk view := by + let classify : HashOutput × QueryCache HashSpec → Option FewTimeView := + fun source => if signAttemptResultOfOutput source.1 = none then none + else some (hashOutputFewTimeView source.1) + have hbound := probEvent_bind_le_classifiedRisk classify risk event + (fun source hsource hnone => by + apply hoff source hsource + by_contra hsuccessful + simp [classify, hsuccessful] at hnone) + (fun source hsource view hsome => by + have hsuccessful : signAttemptResultOfOutput source.1 ≠ none := by + intro hnone + simp [classify, hnone] at hsome + have hview : hashOutputFewTimeView source.1 = view := by + simpa [classify, hsuccessful] using hsome + rw [← hview] + exact hon source hsource hsuccessful) + refine hbound.trans_eq ?_ + calc + ∑ view, Pr[fun source => classify source = some view | + (randomOracle input).run cache] * risk view = + ∑ view, (((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)]) * risk view := by + apply Finset.sum_congr rfl + intro view _ + apply congrArg (fun probability => probability * risk view) + calc + Pr[fun source => classify source = some view | + (randomOracle input).run cache] = + Pr[fun source : HashOutput × QueryCache HashSpec => + signAttemptResultOfOutput source.1 ≠ none ∧ + hashOutputFewTimeView source.1 = view | + (randomOracle input).run cache] := by + apply probEvent_congr' + · intro source _ + simp only [classify] + by_cases hsuccessful : signAttemptResultOfOutput source.1 ≠ none + · simp [hsuccessful] + · simp [not_ne_iff.mp hsuccessful] + · rfl + _ = ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] := + probEvent_randomOracle_fresh_admissible_view input cache hcache + (fun value => value = view) + _ = ∑ view, ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + (Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * risk view) := by + apply Finset.sum_congr rfl + intro view _ + rw [mul_assoc] + _ = _ := by rw [Finset.mul_sum] + +theorem Concrete.probEvent_randomOracle_fresh_bind_fixedPrehit_le_expected + {Result : Type} (input : HashInput) (cache : QueryCache HashSpec) + (hcache : cache input = none) + (continuation : HashOutput × QueryCache HashSpec → ProbComp Result) + (event : Result → Prop) (risk : FewTimeView → ℝ≥0∞) + (hoff : ∀ source ∈ support ((randomOracle input).run cache), + signAttemptResultOfOutput source.1 = none → + Pr[event | continuation source] = 0) + (hon : ∀ source ∈ support ((randomOracle input).run cache), + signAttemptResultOfOutput source.1 ≠ none → + Pr[event | continuation source] ≤ + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * risk (hashOutputFewTimeView source.1)) : + Pr[event | (randomOracle input).run cache >>= continuation] ≤ + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ * + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * risk view := by + calc + Pr[event | (randomOracle input).run cache >>= continuation] ≤ + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * risk view) := + probEvent_randomOracle_fresh_bind_admissible_view_le_expected input cache hcache + continuation event (fun view => ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * risk view) + hoff hon + _ = (((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹) * + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * risk view := by + have hsum : + (∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * risk view)) = + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * risk view := by + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro view _ + ac_rfl + rw [hsum] + ring + _ = _ := by rw [prehit_race_source_weight] + +set_option maxRecDepth 100000 in +theorem Concrete.tsum_probOutput_signWithView_fresh_mul_le_expected + (secretKey : SecretKey) (message : Message) + (initialCache : QueryCache HashSpec) + (cost : ((Option Signature × Option FewTimeView) × QueryCache HashSpec) → ℝ≥0∞) + (risk : FewTimeView → ℝ≥0∞) + (hoff : ∀ signerResult ∈ support + ((simulateQ romImpl (signWithView secretKey message)).run initialCache), + freshSuccessfulView? initialCache secretKey message signerResult = none → + cost signerResult = 0) + (hon : ∀ signerResult ∈ support + ((simulateQ romImpl (signWithView secretKey message)).run initialCache), + ∀ view, freshSuccessfulView? initialCache secretKey message signerResult = some view → + cost signerResult ≤ risk view) : + (∑' signerResult, + Pr[= signerResult | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] * + cost signerResult) ≤ + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * risk view := by + have hbound := tsum_probOutput_mul_le_classifiedRisk + ((simulateQ romImpl (signWithView secretKey message)).run initialCache) + (freshSuccessfulView? initialCache secretKey message) risk cost hoff hon + refine hbound.trans ?_ + apply Finset.sum_le_sum + intro view _ + apply mul_le_mul' _ le_rfl + simpa only [freshSuccessfulView?_eq_some_iff] using + probEvent_signWithView_freshSuccessful_le_uniform secretKey message initialCache + (fun value => value = view) + +theorem Concrete.tsum_probOutput_signWithView_fixedPrehit_mul_le_of_enncard_le + (secretKey : SecretKey) (message : Message) + (initialCache : QueryCache HashSpec) (target : HashInput) (P : FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) (hcache : QueryCache.enncard initialCache ≤ q) + (cost : ((Option Signature × Option FewTimeView) × QueryCache HashSpec) → ℝ≥0∞) + (epsilon : ℝ≥0∞) + (hoff : ∀ signerResult ∈ support + ((simulateQ romImpl (signWithView secretKey message)).run initialCache), + ¬ PrehitSuccessfulSignerView (onlyInputCache initialCache target) + secretKey message P signerResult → cost signerResult = 0) + (hon : ∀ signerResult ∈ support + ((simulateQ romImpl (signWithView secretKey message)).run initialCache), + PrehitSuccessfulSignerView (onlyInputCache initialCache target) + secretKey message P signerResult → cost signerResult ≤ epsilon) : + (∑' signerResult, + Pr[= signerResult | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] * + cost signerResult) ≤ + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * epsilon := by + calc + (∑' signerResult, + Pr[= signerResult | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] * + cost signerResult) ≤ + Pr[PrehitSuccessfulSignerView (onlyInputCache initialCache target) + secretKey message P | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] * epsilon := + tsum_probOutput_mul_le_gated _ _ _ _ hoff hon + _ ≤ ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * epsilon := by + apply mul_le_mul' _ le_rfl + exact probEvent_signWithView_fixedPrehit_le_race_of_enncard_le + secretKey message initialCache target P q hq hcache + +theorem Concrete.tsum_probOutput_randomOracle_fresh_admissible_view_mul_le_expected + (input : HashInput) (cache : QueryCache HashSpec) (hcache : cache input = none) + (cost : HashOutput × QueryCache HashSpec → ℝ≥0∞) + (risk : FewTimeView → ℝ≥0∞) + (hoff : ∀ source ∈ support ((randomOracle input).run cache), + signAttemptResultOfOutput source.1 = none → cost source = 0) + (hon : ∀ source ∈ support ((randomOracle input).run cache), + signAttemptResultOfOutput source.1 ≠ none → + cost source ≤ risk (hashOutputFewTimeView source.1)) : + (∑' source, Pr[= source | (randomOracle input).run cache] * cost source) ≤ + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * risk view := by + let classify : HashOutput × QueryCache HashSpec → Option FewTimeView := + fun source => if signAttemptResultOfOutput source.1 = none then none + else some (hashOutputFewTimeView source.1) + refine tsum_probOutput_mul_le_uniformClassifiedRisk + ((randomOracle input).run cache) classify + ($ᵗ FewTimeView : ProbComp FewTimeView) + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ risk cost ?_ ?_ ?_ + · intro view + calc + Pr[fun source => classify source = some view | (randomOracle input).run cache] = + Pr[fun source : HashOutput × QueryCache HashSpec => + signAttemptResultOfOutput source.1 ≠ none ∧ + hashOutputFewTimeView source.1 = view | + (randomOracle input).run cache] := by + apply probEvent_congr' + · intro source _ + simp only [classify] + by_cases hsuccessful : signAttemptResultOfOutput source.1 ≠ none + · simp [hsuccessful] + · simp [not_ne_iff.mp hsuccessful] + · rfl + _ = ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] := + probEvent_randomOracle_fresh_admissible_view input cache hcache + (fun value => value = view) + _ ≤ _ := le_rfl + · intro source hsource hnone + apply hoff source hsource + by_contra hsuccessful + simp [classify, hsuccessful] at hnone + · intro source hsource view hsome + have hsuccessful : signAttemptResultOfOutput source.1 ≠ none := by + intro hnone + simp [classify, hnone] at hsome + have hview : hashOutputFewTimeView source.1 = view := by + simpa [classify, hsuccessful] using hsome + rw [← hview] + exact hon source hsource hsuccessful + +theorem Concrete.tsum_probOutput_randomOracle_fresh_fixedPrehit_mul_le_expected + (input : HashInput) (cache : QueryCache HashSpec) (hcache : cache input = none) + (cost : HashOutput × QueryCache HashSpec → ℝ≥0∞) + (risk : FewTimeView → ℝ≥0∞) + (hoff : ∀ source ∈ support ((randomOracle input).run cache), + signAttemptResultOfOutput source.1 = none → cost source = 0) + (hon : ∀ source ∈ support ((randomOracle input).run cache), + signAttemptResultOfOutput source.1 ≠ none → + cost source ≤ ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * + risk (hashOutputFewTimeView source.1)) : + (∑' source, Pr[= source | (randomOracle input).run cache] * cost source) ≤ + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ * + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * risk view := by + calc + (∑' source, Pr[= source | (randomOracle input).run cache] * cost source) ≤ + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * risk view) := + tsum_probOutput_randomOracle_fresh_admissible_view_mul_le_expected + input cache hcache cost + (fun view => ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * risk view) hoff hon + _ = (((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹) * + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * risk view := by + have hsum : + (∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * risk view)) = + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * risk view := by + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro view _ + ac_rfl + rw [hsum] + ring + _ = _ := by rw [prehit_race_source_weight] + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginRealization.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginRealization.lean new file mode 100644 index 00000000..4626a363 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginRealization.lean @@ -0,0 +1,122 @@ +import SphincsSecurity.Proof.FewTimeNumberedSources + +/-! +# Concrete realization of an origin configuration + +A realized configuration identifies each selected prehit with its exact direct hash-query slot and +with the fresh full-trace interval that produced the cached answer. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +def OriginConfiguration.RealizedBy {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + {q : Nat} (configuration : OriginConfiguration cover.pattern q) + (trace : FullAdversaryTrace) (hlog : trace.signing.toSigningLog = signingLog) : Prop := + (∀ selected : cover.pattern.selected, + selected ∈ configuration.prehit ↔ + cover.EntryDigestPrecached trace.signing hlog + (cover.entriesEquivPatternSelected.symm selected)) + ∧ ∀ entry : cover.PrecachedEntries trace.signing hlog, + ∀ hselected : cover.entriesEquivPatternSelected entry.1 ∈ configuration.prehit, + ∃ (output : HashOutput) + (sourcePosition : Fin trace.hashQueries.length) + (intervalPosition : Fin trace.intervals.length) + (selectedIntervalPosition : Fin trace.intervals.length) + (hdirect : isDirectHashQuery (trace.intervals.get intervalPosition).input), + sourcePosition.val = + (configuration.source.1 + ⟨cover.entriesEquivPatternSelected entry.1, hselected⟩).val + ∧ sourcePosition.val = + (Fin.encodeSubtype (fun position => + isDirectHashQuery (trace.intervals.get position).input) + ⟨intervalPosition, hdirect⟩).val + ∧ intervalPosition.val < selectedIntervalPosition.val + ∧ AdversaryCacheEntry.signingEntry? + (trace.intervals.get selectedIntervalPosition) = + some (cover.cacheEntry trace.signing hlog entry.1) + ∧ ((trace.intervals.take selectedIntervalPosition.val).filterMap + AdversaryCacheEntry.signingEntry?).length = (cover.logIndex entry.1).val + ∧ (trace.intervals.get intervalPosition).input = + .inl (.inr (cover.entryDigestInput entry.1)) + ∧ (trace.intervals.get intervalPosition).initialCache + (cover.entryDigestInput entry.1) = none + ∧ (output, (trace.intervals.get intervalPosition).finalCache) ∈ support + ((randomOracle (cover.entryDigestInput entry.1)).run + (trace.intervals.get intervalPosition).initialCache) + ∧ signAttemptResultOfOutput output ≠ none + ∧ hashOutputFewTimeView output = cover.entryView entry.1 + +theorem FewTimeCover.exists_realized_originConfiguration_of_hashQueries_length_le + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.1.AgreesWithFn f) + (index : Index) (targetLeaves : DigestTree → FtsLeaf) + (cover : FewTimeCover f result.2.1 + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.signing.toSigningLog index targetLeaves) + (q : Nat) (hqueries : result.2.2.hashQueries.length ≤ q) : + ∃ configuration : OriginConfiguration cover.pattern q, + OriginConfiguration.RealizedBy cover configuration result.2.2 rfl := by + classical + obtain ⟨source, intervalSource, selectedInterval, output, hsourceInjective, + _hintervalInjective, hsource⟩ := + cover.precached_entries_have_injective_numbered_sources adversary parameter + otsSecret ftsSecret result hresult f hf index targetLeaves + let budgetSource : cover.PrecachedEntries result.2.2.signing rfl → Fin q := + fun entry => Fin.castLE hqueries (source entry) + have hbudgetSourceInjective : Function.Injective budgetSource := + Function.Injective.comp (finCastLEEmbedding hqueries).injective hsourceInjective + let configuration := cover.originConfiguration result.2.2.signing rfl q budgetSource + hbudgetSourceInjective + refine ⟨configuration, ?_, ?_⟩ + · intro selected + exact cover.mem_precachedPatternSelected_iff result.2.2.signing rfl selected + · intro entry hselected + let selected : ↑configuration.prehit := + ⟨cover.entriesEquivPatternSelected entry.1, hselected⟩ + have hentry : cover.precachedOfPatternSelected result.2.2.signing rfl selected = entry := by + apply Subtype.ext + rw [cover.precachedOfPatternSelected_entry result.2.2.signing rfl selected] + exact cover.entriesEquivPatternSelected.symm_apply_apply entry.1 + have hconfigurationSource : configuration.source.1 selected = budgetSource entry := by + rw [cover.originConfiguration_source_apply result.2.2.signing rfl q budgetSource + hbudgetSourceInjective selected, hentry] + obtain ⟨hdirect, hordinal, hinterval⟩ := hsource entry + refine ⟨output entry, source entry, intervalSource entry, selectedInterval entry, + hdirect, ?_, hordinal, hinterval⟩ + · exact congrArg Fin.val hconfigurationSource |>.symm + +theorem FewTimeCover.exists_realized_originConfiguration_of_queryBudget + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.1.AgreesWithFn f) + (index : Index) (targetLeaves : DigestTree → FtsLeaf) + (cover : FewTimeCover f result.2.1 + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.signing.toSigningLog index targetLeaves) : + ∃ configuration : OriginConfiguration cover.pattern q, + OriginConfiguration.RealizedBy cover configuration result.2.2 rfl := by + exact cover.exists_realized_originConfiguration_of_hashQueries_length_le adversary parameter + otsSecret ftsSecret result hresult f hf index targetLeaves q + (gameAfterSecretsWithFullTrace_hashQueries_length_le adversary q hq parameter hparameter + otsSecret hots ftsSecret hfts result hresult) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginSampler.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginSampler.lean new file mode 100644 index 00000000..6e28fac5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginSampler.lean @@ -0,0 +1,168 @@ +import SphincsSecurity.Proof.FewTimeWeightedCount + +/-! +# Ideal sampler for a fixed origin configuration + +An origin configuration chooses the selected entries whose views come from earlier direct queries +and injectively assigns those entries to source slots. Its ideal sample contains one uniform view per +selected entry, a uniform target view and one independent `127`-bit activation value per prehit. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +structure OriginConfiguration {signatures distinct : Nat} + (pattern : FewTimePattern signatures distinct) (sources : Nat) where + prehit : Finset pattern.selected + source : InjectiveSources prehit sources + +def originConfigurationEquiv {signatures distinct : Nat} + (pattern : FewTimePattern signatures distinct) (sources : Nat) : + OriginConfiguration pattern sources ≃ + Σ prehit : Finset pattern.selected, InjectiveSources prehit sources where + toFun configuration := ⟨configuration.prehit, configuration.source⟩ + invFun configuration := ⟨configuration.1, configuration.2⟩ + left_inv configuration := by cases configuration; rfl + right_inv configuration := by cases configuration; rfl + +noncomputable instance {signatures distinct : Nat} + (pattern : FewTimePattern signatures distinct) (sources : Nat) : + Fintype (OriginConfiguration pattern sources) := + Fintype.ofEquiv _ (originConfigurationEquiv pattern sources).symm + +abbrev OriginConfiguration.Sample {signatures distinct : Nat} + {pattern : FewTimePattern signatures distinct} {sources : Nat} + (configuration : OriginConfiguration pattern sources) := + ((pattern.selected → FewTimeView) × FewTimeView) × + BitVec (127 * configuration.prehit.card) + +def OriginConfiguration.Hit {signatures distinct : Nat} + {pattern : FewTimePattern signatures distinct} {sources : Nat} + (configuration : OriginConfiguration pattern sources) + (sample : configuration.Sample) : Prop := + FixedFewTimePatternHit pattern.assignment sample.1 + ∧ sample.2 = 0 + +noncomputable instance {signatures distinct : Nat} + {pattern : FewTimePattern signatures distinct} {sources : Nat} + (configuration : OriginConfiguration pattern sources) : + DecidablePred configuration.Hit := + fun sample => Classical.propDecidable (configuration.Hit sample) + +theorem probEvent_uniformOriginActivation_zero (count : Nat) : + Pr[fun value : BitVec (127 * count) => value = 0 | + ($ᵗ BitVec (127 * count) : ProbComp (BitVec (127 * count)))] = + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ count := by + rw [probEvent_eq_eq_probOutput, probOutput_uniformSample, + show Fintype.card (BitVec (127 * count)) = 2 ^ (127 * count) from + card_bitVec (127 * count), pow_mul, Nat.cast_pow, ENNReal.inv_pow] + +set_option maxHeartbeats 1000000 in +theorem probEvent_originConfiguration_hit {signatures distinct : Nat} + {pattern : FewTimePattern signatures distinct} {sources : Nat} + (configuration : OriginConfiguration pattern sources) : + Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] = + ((2 ^ (totalHeight * distinct + ftsTreeHeight * (ftsTrees - 1)) : Nat) : + ℝ≥0∞)⁻¹ * + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ configuration.prehit.card := by + classical + letI : Nonempty pattern.selected := ⟨pattern.assignment ⟨0, by decide⟩⟩ + change Pr[configuration.Hit | + Prod.mk <$> + ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : + ProbComp ((pattern.selected → FewTimeView) × FewTimeView)) <*> + ($ᵗ BitVec (127 * configuration.prehit.card) : + ProbComp (BitVec (127 * configuration.prehit.card)))] = _ + calc + _ = Pr[FixedFewTimePatternHit pattern.assignment | + ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : + ProbComp ((pattern.selected → FewTimeView) × FewTimeView))] * + Pr[fun value : BitVec (127 * configuration.prehit.card) => value = 0 | + ($ᵗ BitVec (127 * configuration.prehit.card) : + ProbComp (BitVec (127 * configuration.prehit.card)))] := by + apply probEvent_seq_map_eq_mul + intro views _hviews activations _hactivations + rfl + _ = ((2 ^ (totalHeight * Fintype.card pattern.selected + + ftsTreeHeight * (ftsTrees - 1)) : Nat) : ℝ≥0∞)⁻¹ * + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ + configuration.prehit.card := by + have hpattern : + Pr[FixedFewTimePatternHit pattern.assignment | + ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : + ProbComp ((pattern.selected → FewTimeView) × FewTimeView))] = + ((2 ^ (totalHeight * Fintype.card pattern.selected + + ftsTreeHeight * (ftsTrees - 1)) : Nat) : ℝ≥0∞)⁻¹ := by + apply probEvent_fixedFewTimePatternHit_eq_inv_of_evalDist pattern.assignment + simp only [evalDist_uniformSample] + have hactivation := probEvent_uniformOriginActivation_zero configuration.prehit.card + exact congrArg₂ (fun left right => left * right) hpattern hactivation + _ = _ := by + rw [Fintype.card_coe, pattern.card_selected] + +theorem sum_probEvent_originConfiguration_hit {signatures distinct sources : Nat} + (pattern : FewTimePattern signatures distinct) : + (∑ configuration : OriginConfiguration pattern sources, + Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)]) = + originChoiceMass pattern.selected sources ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ * + ((2 ^ (totalHeight * distinct + ftsTreeHeight * (ftsTrees - 1)) : Nat) : + ℝ≥0∞)⁻¹ := by + classical + simp_rw [probEvent_originConfiguration_hit] + calc + (∑ configuration : OriginConfiguration pattern sources, + ((2 ^ (totalHeight * distinct + ftsTreeHeight * (ftsTrees - 1)) : Nat) : + ℝ≥0∞)⁻¹ * + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ configuration.prehit.card) = + ∑ data : Σ prehit : Finset pattern.selected, InjectiveSources prehit sources, + ((2 ^ (totalHeight * distinct + ftsTreeHeight * (ftsTrees - 1)) : Nat) : + ℝ≥0∞)⁻¹ * + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ data.1.card := by + apply Fintype.sum_equiv (originConfigurationEquiv pattern sources) + intro configuration + rfl + _ = _ := by + simp only [Fintype.sum_sigma, Finset.sum_const, Finset.card_univ, nsmul_eq_mul, + originChoiceMass] + rw [Finset.sum_mul] + apply Finset.sum_congr rfl + intro prehit _ + ring + +noncomputable def idealOriginUnionBound (signatures sources : Nat) : ℝ≥0∞ := + ∑ distinct ∈ Finset.Icc 1 14, + ∑ pattern : FewTimePattern signatures distinct, + ∑ configuration : OriginConfiguration pattern sources, + Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] + +theorem idealOriginUnionBound_eq_weightedFewTimePatternBound (signatures sources : Nat) : + idealOriginUnionBound signatures sources = + weightedFewTimePatternBound signatures sources := by + classical + rw [idealOriginUnionBound, weightedFewTimePatternBound] + apply Finset.sum_congr rfl + intro distinct _ + apply Finset.sum_congr rfl + intro pattern _ + rw [sum_probEvent_originConfiguration_hit pattern] + simp only [totalHeight, ftsTreeHeight, ftsTrees] + +theorem idealOriginUnionBound_le {signatures sources : Nat} + (hsignatures : signatures ≤ signatureLimit) (hsources : sources ≤ 2 ^ 120) : + idealOriginUnionBound signatures sources ≤ + ((2 ^ 121 : Nat) : ℝ≥0∞)⁻¹ := by + rw [idealOriginUnionBound_eq_weightedFewTimePatternBound] + exact weightedFewTimePatternBound_le hsignatures hsources + +theorem idealOriginUnionBound_le_nine_mul_inv {signatures sources : Nat} + (hsignatures : signatures ≤ signatureLimit) (hsources : sources ≤ 2 ^ 120) : + idealOriginUnionBound signatures sources ≤ + 9 * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹ := by + rw [idealOriginUnionBound_eq_weightedFewTimePatternBound] + exact weightedFewTimePatternBound_le_nine_mul_inv hsignatures hsources + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginSchedule.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginSchedule.lean new file mode 100644 index 00000000..92c02941 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginSchedule.lean @@ -0,0 +1,186 @@ +import SphincsSecurity.Proof.FewTimeOriginPadding + +/-! +# Ordinal schedule for a padded origin configuration + +The adaptive recursion addresses direct queries and signer invocations by their chronological +ordinals. Injectivity of the selected signer positions and prehit source assignment makes the +configured obligation at either kind of ordinal unique. +-/ + +namespace SphincsSecurity.Concrete + +noncomputable def OriginConfiguration.sourceAt? {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (ordinal : Nat) : + Option ↑configuration.prehit := by + classical + exact if h : ∃ selected, (configuration.source.1 selected).val = ordinal then + some (Classical.choose h) + else none + +theorem OriginConfiguration.sourceAt?_eq_some_iff {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (ordinal : Nat) + (selected : ↑configuration.prehit) : + configuration.sourceAt? ordinal = some selected ↔ + (configuration.source.1 selected).val = ordinal := by + classical + constructor + · intro hlookup + by_cases hexists : ∃ candidate, (configuration.source.1 candidate).val = ordinal + · rw [OriginConfiguration.sourceAt?, dif_pos hexists] at hlookup + have hselected : Classical.choose hexists = selected := Option.some.inj hlookup + rw [← hselected] + exact Classical.choose_spec hexists + · simp [OriginConfiguration.sourceAt?, hexists] at hlookup + · intro hsource + have hexists : ∃ candidate, (configuration.source.1 candidate).val = ordinal := + ⟨selected, hsource⟩ + rw [OriginConfiguration.sourceAt?, dif_pos hexists] + congr 1 + apply configuration.source.2 + apply Fin.ext + exact (Classical.choose_spec hexists).trans hsource.symm + +noncomputable def FewTimePattern.selectedAt? {signatures distinct : Nat} + (pattern : FewTimePattern signatures distinct) (ordinal : Nat) : + Option pattern.selected := by + classical + exact if h : ∃ selected : pattern.selected, selected.1.val = ordinal then + some (Classical.choose h) + else none + +theorem FewTimePattern.selectedAt?_eq_some_iff {signatures distinct : Nat} + (pattern : FewTimePattern signatures distinct) (ordinal : Nat) + (selected : pattern.selected) : + pattern.selectedAt? ordinal = some selected ↔ selected.1.val = ordinal := by + classical + constructor + · intro hlookup + by_cases hexists : ∃ candidate : pattern.selected, candidate.1.val = ordinal + · rw [FewTimePattern.selectedAt?, dif_pos hexists] at hlookup + have hselected : Classical.choose hexists = selected := Option.some.inj hlookup + rw [← hselected] + exact Classical.choose_spec hexists + · simp [FewTimePattern.selectedAt?, hexists] at hlookup + · intro hposition + have hexists : ∃ candidate : pattern.selected, candidate.1.val = ordinal := + ⟨selected, hposition⟩ + rw [FewTimePattern.selectedAt?, dif_pos hexists] + congr 1 + apply Subtype.ext + apply Fin.ext + exact (Classical.choose_spec hexists).trans hposition.symm + +structure OriginObservation {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) where + views : pattern.selected → FewTimeView + sourceInputs : ↑configuration.prehit → HashInput + seenViews : Finset pattern.selected + seenSources : Finset ↑configuration.prehit + +noncomputable def OriginObservation.empty {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) : OriginObservation configuration := by + classical + exact ⟨fun _ => default, fun _ => default, ∅, ∅⟩ + +noncomputable def OriginObservation.recordSource {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (observation : OriginObservation configuration) + (selected : ↑configuration.prehit) (input : HashInput) (view : FewTimeView) : + OriginObservation configuration := by + classical + exact ⟨Function.update observation.views selected.1 view, + Function.update observation.sourceInputs selected input, + insert selected.1 observation.seenViews, insert selected observation.seenSources⟩ + +noncomputable def OriginObservation.recordFresh {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (observation : OriginObservation configuration) + (selected : pattern.selected) (view : FewTimeView) : OriginObservation configuration := by + classical + exact ⟨Function.update observation.views selected view, observation.sourceInputs, + insert selected observation.seenViews, observation.seenSources⟩ + +theorem OriginObservation.recordSource_view {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (observation : OriginObservation configuration) + (selected : ↑configuration.prehit) (input : HashInput) (view : FewTimeView) : + (observation.recordSource selected input view).views selected.1 = view := by + classical + simp [OriginObservation.recordSource] + +theorem OriginObservation.recordSource_input {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (observation : OriginObservation configuration) + (selected : ↑configuration.prehit) (input : HashInput) (view : FewTimeView) : + (observation.recordSource selected input view).sourceInputs selected = input := by + classical + simp [OriginObservation.recordSource] + +theorem OriginObservation.recordSource_view_of_ne {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (observation : OriginObservation configuration) + (selected : ↑configuration.prehit) (input : HashInput) (view : FewTimeView) + (other : pattern.selected) (hne : other ≠ selected.1) : + (observation.recordSource selected input view).views other = observation.views other := by + classical + simp [OriginObservation.recordSource, hne] + +theorem OriginObservation.recordSource_input_of_ne {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (observation : OriginObservation configuration) + (selected : ↑configuration.prehit) (input : HashInput) (view : FewTimeView) + (other : ↑configuration.prehit) (hne : other ≠ selected) : + (observation.recordSource selected input view).sourceInputs other = + observation.sourceInputs other := by + classical + simp [OriginObservation.recordSource, hne] + +theorem OriginObservation.recordSource_seen {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (observation : OriginObservation configuration) + (selected : ↑configuration.prehit) (input : HashInput) (view : FewTimeView) : + selected.1 ∈ (observation.recordSource selected input view).seenViews ∧ + selected ∈ (observation.recordSource selected input view).seenSources := by + classical + simp [OriginObservation.recordSource] + +theorem OriginObservation.recordFresh_view {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (observation : OriginObservation configuration) + (selected : pattern.selected) (view : FewTimeView) : + (observation.recordFresh selected view).views selected = view := by + classical + simp [OriginObservation.recordFresh] + +theorem OriginObservation.recordFresh_view_of_ne {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (observation : OriginObservation configuration) + (selected other : pattern.selected) (view : FewTimeView) (hne : other ≠ selected) : + (observation.recordFresh selected view).views other = observation.views other := by + classical + simp [OriginObservation.recordFresh, hne] + +theorem OriginObservation.recordFresh_seen {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (observation : OriginObservation configuration) + (selected : pattern.selected) (view : FewTimeView) : + selected ∈ (observation.recordFresh selected view).seenViews := by + classical + simp [OriginObservation.recordFresh] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginTerminal.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginTerminal.lean new file mode 100644 index 00000000..417bc197 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginTerminal.lean @@ -0,0 +1,1642 @@ +import SphincsSecurity.Proof.FewTimeOriginInvariant +import SphincsSecurity.Proof.FewTimeOriginPadding + +/-! +# Terminal realization of the few-time origin monitor + +The retained viewed trace determines the monitor fields by a pure chronological replay. This +module connects a concretely realized padded cover to the terminal event used by the adaptive +fixed-configuration bound. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +namespace Concrete + +theorem Fin.encodeSubtype_val_lt_of_val_lt {n : Nat} (P : Fin n → Prop) + [DecidablePred P] (left right : {position : Fin n // P position}) + (hlt : left.1.val < right.1.val) : + (Fin.encodeSubtype P left).val < (Fin.encodeSubtype P right).val := by + induction n with + | zero => exact Fin.elim0 left.1 + | succ n ih => + rcases left with ⟨left, hleft⟩ + rcases right with ⟨right, hright⟩ + cases left using Fin.cases with + | zero => + cases right using Fin.cases with + | zero => omega + | succ right => + rw [Fin.encodeSubtype_zero_pos hleft, + Fin.encodeSubtype_succ_pos hleft hright] + simp + | succ left => + cases right using Fin.cases with + | zero => simp at hlt + | succ right => + by_cases hzero : P 0 + · rw [Fin.encodeSubtype_succ_pos hzero hleft, + Fin.encodeSubtype_succ_pos hzero hright] + simpa using ih (fun position => P position.succ) + ⟨left, hleft⟩ ⟨right, hright⟩ (by simpa using hlt) + · rw [Fin.encodeSubtype_succ_neg hzero hleft, + Fin.encodeSubtype_succ_neg hzero hright] + simpa using ih (fun position => P position.succ) + ⟨left, hleft⟩ ⟨right, hright⟩ (by simpa using hlt) + +theorem Fin.encodeSubtype_val_congr {n : Nat} (P Q : Fin n → Prop) + [DecidablePred P] [DecidablePred Q] + (hiff : ∀ position, P position ↔ Q position) + (left : {position : Fin n // P position}) + (right : {position : Fin n // Q position}) + (heq : left.1 = right.1) : + (Fin.encodeSubtype P left).val = (Fin.encodeSubtype Q right).val := by + induction n with + | zero => exact Fin.elim0 left.1 + | succ n ih => + rcases left with ⟨left, hleft⟩ + rcases right with ⟨right, hright⟩ + change left = right at heq + subst right + cases left using Fin.cases with + | zero => + rw [Fin.encodeSubtype_zero_pos hleft, + Fin.encodeSubtype_zero_pos hright] + | succ left => + by_cases hzero : P 0 + · have hzero' : Q 0 := (hiff 0).1 hzero + rw [Fin.encodeSubtype_succ_pos hzero hleft, + Fin.encodeSubtype_succ_pos hzero' hright] + simpa using ih (fun position => P position.succ) + (fun position => Q position.succ) (fun position => hiff position.succ) + ⟨left, hleft⟩ ⟨left, hright⟩ rfl + · have hzero' : ¬Q 0 := fun hq => hzero ((hiff 0).2 hq) + rw [Fin.encodeSubtype_succ_neg hzero hleft, + Fin.encodeSubtype_succ_neg hzero' hright] + simpa using ih (fun position => P position.succ) + (fun position => Q position.succ) (fun position => hiff position.succ) + ⟨left, hleft⟩ ⟨left, hright⟩ rfl + +inductive OriginReplayEvent where + | uniform + | direct (input : HashInput) (output : HashOutput) + (initialCache finalCache : QueryCache HashSpec) + | signer (request : SignRequest) (signature : Option Signature) + (view : Option FewTimeView) (initialCache finalCache : QueryCache HashSpec) + +def OriginReplayEvent.directIncrement : OriginReplayEvent → Nat + | .direct _ _ _ _ => 1 + | _ => 0 + +def OriginReplayEvent.signerIncrement : OriginReplayEvent → Nat + | .signer _ _ _ _ _ => 1 + | _ => 0 + +def OriginReplayEvents.directCount : List OriginReplayEvent → Nat + | [] => 0 + | event :: events => event.directIncrement + OriginReplayEvents.directCount events + +def OriginReplayEvents.signerCount : List OriginReplayEvent → Nat + | [] => 0 + | event :: events => event.signerIncrement + OriginReplayEvents.signerCount events + +structure OriginReplayState {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) where + observation : OriginObservation configuration + directOrdinal : Nat + signerOrdinal : Nat + valid : Bool + +noncomputable def OriginReplayState.initial {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) : OriginReplayState configuration := + ⟨OriginObservation.empty configuration, 0, 0, true⟩ + +def OriginReplayState.asMonitor {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginReplayState configuration) (cache : QueryCache HashSpec) : + OriginMonitorState configuration := + ⟨⟨cache, ⟨[], [], []⟩, [], none⟩, state.observation, state.directOrdinal, + state.signerOrdinal, state.valid⟩ + +noncomputable def OriginReplayState.step {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (state : OriginReplayState configuration) : + OriginReplayEvent → OriginReplayState configuration + | .uniform => state + | .direct input output initialCache _ => + let monitored := monitorDirectSource (state.asMonitor initialCache) input output + ⟨monitored.1, state.directOrdinal + 1, state.signerOrdinal, monitored.2⟩ + | .signer request signature view initialCache finalCache => + let monitored := monitorSigner secretKey request (state.asMonitor initialCache) + ((signature, view), finalCache) + ⟨monitored.1, state.directOrdinal, state.signerOrdinal + 1, monitored.2⟩ + +@[simp] theorem OriginReplayState.step_directOrdinal {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (state : OriginReplayState configuration) + (event : OriginReplayEvent) : + (state.step secretKey event).directOrdinal = + state.directOrdinal + event.directIncrement := by + cases event <;> simp [OriginReplayState.step, OriginReplayEvent.directIncrement] + +@[simp] theorem OriginReplayState.step_signerOrdinal {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (state : OriginReplayState configuration) + (event : OriginReplayEvent) : + (state.step secretKey event).signerOrdinal = + state.signerOrdinal + event.signerIncrement := by + cases event <;> simp [OriginReplayState.step, OriginReplayEvent.signerIncrement] + +noncomputable def replayOriginEvents {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (events : List OriginReplayEvent) : OriginReplayState configuration := + events.foldl (OriginReplayState.step secretKey) (OriginReplayState.initial configuration) + +def originReplayEvents : List AdversaryCacheEntry → List (Option FewTimeView) → + List OriginReplayEvent + | [], _ => [] + | ⟨.inl (.inl _), _, _, _⟩ :: rest, views => + .uniform :: originReplayEvents rest views + | ⟨.inl (.inr input), output, initialCache, finalCache⟩ :: rest, views => + .direct input output initialCache finalCache :: originReplayEvents rest views + | ⟨.inr request, signature, initialCache, finalCache⟩ :: rest, [] => + .signer request signature none initialCache finalCache :: originReplayEvents rest [] + | ⟨.inr request, signature, initialCache, finalCache⟩ :: rest, view :: views => + .signer request signature view initialCache finalCache :: originReplayEvents rest views + +def directIntervalCount (intervals : List AdversaryCacheEntry) : Nat := + (intervals.filter fun entry => isDirectHashQuery entry.input).length + +def signerIntervalCount (intervals : List AdversaryCacheEntry) : Nat := + (intervals.filterMap AdversaryCacheEntry.signingEntry?).length + +theorem originReplayEvents_length (intervals : List AdversaryCacheEntry) + (views : List (Option FewTimeView)) : + (originReplayEvents intervals views).length = intervals.length := by + induction intervals generalizing views with + | nil => rfl + | cons entry intervals ih => + rcases entry with ⟨input, output, initialCache, finalCache⟩ + cases input with + | inl worldInput => + cases worldInput <;> simp [originReplayEvents, ih] + | inr request => + cases views <;> simp [originReplayEvents, ih] + +theorem originReplayEvents_take_counts (intervals : List AdversaryCacheEntry) + (views : List (Option FewTimeView)) (count : Nat) : + OriginReplayEvents.directCount (originReplayEvents intervals views |>.take count) = + directIntervalCount (intervals.take count) + ∧ OriginReplayEvents.signerCount (originReplayEvents intervals views |>.take count) = + signerIntervalCount (intervals.take count) := by + induction intervals generalizing views count with + | nil => simp [originReplayEvents, OriginReplayEvents.directCount, + OriginReplayEvents.signerCount, directIntervalCount, signerIntervalCount] + | cons entry intervals ih => + cases count with + | zero => simp [OriginReplayEvents.directCount, OriginReplayEvents.signerCount, + directIntervalCount, signerIntervalCount] + | succ count => + rcases entry with ⟨input, output, initialCache, finalCache⟩ + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + simpa [originReplayEvents, OriginReplayEvents.directCount, + OriginReplayEvents.signerCount, OriginReplayEvent.directIncrement, + OriginReplayEvent.signerIncrement, directIntervalCount, + signerIntervalCount, isDirectHashQuery, + AdversaryCacheEntry.signingEntry?, Nat.add_comm] using ih views count + | inr hashInput => + simpa [originReplayEvents, OriginReplayEvents.directCount, + OriginReplayEvents.signerCount, OriginReplayEvent.directIncrement, + OriginReplayEvent.signerIncrement, directIntervalCount, + signerIntervalCount, isDirectHashQuery, + AdversaryCacheEntry.signingEntry?, Nat.add_comm] using ih views count + | inr request => + cases views with + | nil => + simpa [originReplayEvents, OriginReplayEvents.directCount, + OriginReplayEvents.signerCount, OriginReplayEvent.directIncrement, + OriginReplayEvent.signerIncrement, directIntervalCount, + signerIntervalCount, isDirectHashQuery, + AdversaryCacheEntry.signingEntry?, Nat.add_comm] using ih [] count + | cons view views => + simpa [originReplayEvents, OriginReplayEvents.directCount, + OriginReplayEvents.signerCount, OriginReplayEvent.directIncrement, + OriginReplayEvent.signerIncrement, directIntervalCount, + signerIntervalCount, isDirectHashQuery, + AdversaryCacheEntry.signingEntry?, Nat.add_comm] using ih views count + +theorem originReplayEvents_counts (intervals : List AdversaryCacheEntry) + (views : List (Option FewTimeView)) : + OriginReplayEvents.directCount (originReplayEvents intervals views) = + directIntervalCount intervals + ∧ OriginReplayEvents.signerCount (originReplayEvents intervals views) = + signerIntervalCount intervals := by + have hcounts := originReplayEvents_take_counts intervals views intervals.length + have htake : (originReplayEvents intervals views).take intervals.length = + originReplayEvents intervals views := by + rw [← originReplayEvents_length intervals views] + exact List.take_length + rw [htake, List.take_length] at hcounts + exact hcounts + +theorem encodeSubtype_directInterval_eq (intervals : List AdversaryCacheEntry) + (position : Fin intervals.length) + (hdirect : isDirectHashQuery (intervals.get position).input) : + (Fin.encodeSubtype (fun candidate => + isDirectHashQuery (intervals.get candidate).input) ⟨position, hdirect⟩).val = + directIntervalCount (intervals.take position.val) := by + induction intervals with + | nil => exact Fin.elim0 position + | cons entry intervals ih => + cases position using Fin.cases with + | zero => + have hzero : isDirectHashQuery + ((entry :: intervals).get (0 : Fin (entry :: intervals).length)).input := + hdirect + rw [Fin.encodeSubtype_zero_pos hzero] + simp [directIntervalCount] + | succ position => + have htail : isDirectHashQuery (intervals.get position).input := by + simpa using hdirect + by_cases hhead : isDirectHashQuery entry.input + · have hzero : isDirectHashQuery + ((entry :: intervals).get (0 : Fin (entry :: intervals).length)).input := by + simpa using hhead + have hencode := Fin.encodeSubtype_val_congr + (fun candidate : Fin intervals.length => + isDirectHashQuery ((entry :: intervals).get candidate.succ).input) + (fun candidate : Fin intervals.length => + isDirectHashQuery (intervals.get candidate).input) + (by intro candidate; simp) + ⟨position, hdirect⟩ ⟨position, htail⟩ rfl + rw [Fin.encodeSubtype_succ_pos hzero hdirect] + simp only [Fin.val_cast, Fin.val_succ] + rw [hencode, ih position htail] + simp [directIntervalCount, hhead, Nat.add_comm] + · have hzero : ¬isDirectHashQuery + ((entry :: intervals).get (0 : Fin (entry :: intervals).length)).input := by + simpa using hhead + have hencode := Fin.encodeSubtype_val_congr + (fun candidate : Fin intervals.length => + isDirectHashQuery ((entry :: intervals).get candidate.succ).input) + (fun candidate : Fin intervals.length => + isDirectHashQuery (intervals.get candidate).input) + (by intro candidate; simp) + ⟨position, hdirect⟩ ⟨position, htail⟩ rfl + rw [Fin.encodeSubtype_succ_neg hzero hdirect] + simp only [Fin.val_cast] + rw [hencode, ih position htail] + simp [directIntervalCount, hhead] + +theorem encodeSubtype_directInterval_lt_count_take + (intervals : List AdversaryCacheEntry) + (position : Fin intervals.length) + (hdirect : isDirectHashQuery (intervals.get position).input) + (later : Nat) (hbefore : position.val < later) : + (Fin.encodeSubtype (fun candidate => + isDirectHashQuery (intervals.get candidate).input) ⟨position, hdirect⟩).val < + directIntervalCount (intervals.take later) := by + have hsucc : directIntervalCount (intervals.take (position.val + 1)) = + directIntervalCount (intervals.take position.val) + 1 := by + have hgetDirect : isDirectHashQuery intervals[position.val].input := by + simpa only [List.get_eq_getElem] using hdirect + rw [List.take_succ_eq_append_getElem position.isLt] + simp only [directIntervalCount, List.filter_append, List.filter_singleton, + hgetDirect, List.length_append] + simp + have hprefix : position.val + 1 ≤ later := by omega + have hsublist := List.take_sublist_take_left (l := intervals) hprefix + have hcount : + (intervals.take (position.val + 1)).countP + (fun entry => decide (isDirectHashQuery entry.input)) ≤ + (intervals.take later).countP + (fun entry => decide (isDirectHashQuery entry.input)) := + hsublist.countP_le + rw [List.countP_eq_length_filter, List.countP_eq_length_filter] at hcount + change directIntervalCount (intervals.take (position.val + 1)) ≤ + directIntervalCount (intervals.take later) at hcount + rw [hsucc, ← encodeSubtype_directInterval_eq intervals position hdirect] at hcount + omega + +def originReplayEventOfEntry (entry : AdversaryCacheEntry) + (view : Option FewTimeView) : OriginReplayEvent := + match entry with + | ⟨.inl (.inl _), _, _, _⟩ => .uniform + | ⟨.inl (.inr input), output, initialCache, finalCache⟩ => + .direct input output initialCache finalCache + | ⟨.inr request, signature, initialCache, finalCache⟩ => + .signer request signature view initialCache finalCache + +theorem originReplayEvents_get (intervals : List AdversaryCacheEntry) + (views : List (Option FewTimeView)) (position : Fin intervals.length) : + (originReplayEvents intervals views).get + ⟨position.val, by rw [originReplayEvents_length]; exact position.isLt⟩ = + originReplayEventOfEntry (intervals.get position) + (views[signerIntervalCount (intervals.take position.val)]?.getD none) := by + induction intervals generalizing views with + | nil => exact Fin.elim0 position + | cons entry intervals ih => + cases position using Fin.cases with + | zero => + rcases entry with ⟨input, output, initialCache, finalCache⟩ + cases input with + | inl worldInput => + cases worldInput <;> + simp [originReplayEvents, originReplayEventOfEntry] + | inr request => + cases views <;> + simp [originReplayEvents, originReplayEventOfEntry, signerIntervalCount] + | succ position => + rcases entry with ⟨input, output, initialCache, finalCache⟩ + cases input with + | inl worldInput => + cases worldInput <;> + simpa [originReplayEvents, originReplayEventOfEntry, + signerIntervalCount, AdversaryCacheEntry.signingEntry?] using + ih views position + | inr request => + cases views with + | nil => + simpa [originReplayEvents, originReplayEventOfEntry, + signerIntervalCount, AdversaryCacheEntry.signingEntry?] using + ih [] position + | cons view views => + simpa [originReplayEvents, originReplayEventOfEntry, + signerIntervalCount, AdversaryCacheEntry.signingEntry?] using + ih views position + +theorem filterMap_getElem?_at_rank {α β : Type} (filter : α → Option β) + (list : List α) (position : Fin list.length) (value : β) + (hvalue : filter (list.get position) = some value) : + (list.filterMap filter)[((list.take position.val).filterMap filter).length]? = + some value := by + induction list with + | nil => exact Fin.elim0 position + | cons head list ih => + cases position using Fin.cases with + | zero => + have hhead : filter head = some value := by simpa using hvalue + simp [hhead] + | succ position => + have htail : filter (list.get position) = some value := by + simpa using hvalue + cases hhead : filter head with + | none => simpa [hhead] using ih position htail + | some headValue => simpa [hhead] using ih position htail + +theorem filterMap_take_length_lt_of_lt {α β : Type} (filter : α → Option β) + (list : List α) (left right : Fin list.length) + (value : β) (hvalue : filter (list.get left) = some value) + (hlt : left.val < right.val) : + ((list.take left.val).filterMap filter).length < + ((list.take right.val).filterMap filter).length := by + have hsucc : ((list.take (left.val + 1)).filterMap filter).length = + ((list.take left.val).filterMap filter).length + 1 := by + rw [List.take_succ_eq_append_getElem left.isLt] + have hvalue' : filter list[left.val] = some value := by + simpa only [List.get_eq_getElem] using hvalue + simp only [List.filterMap_append, List.length_append] + simp [hvalue'] + have hprefix : left.val + 1 ≤ right.val := by omega + have hsublist := List.take_sublist_take_left (l := list) hprefix + have hcount : + (list.take (left.val + 1)).countP (fun entry => (filter entry).isSome) ≤ + (list.take right.val).countP (fun entry => (filter entry).isSome) := + hsublist.countP_le + rw [← List.length_filterMap_eq_countP, + ← List.length_filterMap_eq_countP] at hcount + rw [hsucc] at hcount + omega + +theorem filterMap_take_length_injective_at_some {α β : Type} + (filter : α → Option β) (list : List α) + (left right : Fin list.length) (leftValue rightValue : β) + (hleft : filter (list.get left) = some leftValue) + (hright : filter (list.get right) = some rightValue) + (hrank : ((list.take left.val).filterMap filter).length = + ((list.take right.val).filterMap filter).length) : + left = right := by + apply Fin.ext + rcases lt_trichotomy left.val right.val with hlt | heq | hgt + · have := filterMap_take_length_lt_of_lt filter list left right leftValue hleft hlt + omega + · exact heq + · have := filterMap_take_length_lt_of_lt filter list right left rightValue hright hgt + omega + +theorem FullAdversaryTrace.Chronological.get_finalCache_le_initialCache + {intervals : List AdversaryCacheEntry} + (hchronological : FullAdversaryTrace.Chronological intervals) + (earlier later : Fin intervals.length) (hlt : earlier.val < later.val) : + (intervals.get earlier).finalCache ≤ (intervals.get later).initialCache := by + induction intervals with + | nil => exact Fin.elim0 earlier + | cons head rest ih => + cases earlier using Fin.cases with + | zero => + cases later using Fin.cases with + | zero => simp at hlt + | succ later => + exact hchronological.1 (rest.get later) (List.get_mem rest later) + | succ earlier => + cases later using Fin.cases with + | zero => simp at hlt + | succ later => + exact ih hchronological.2 earlier later (by simpa using hlt) + +noncomputable def FewTimeCover.paddedEntry {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + {limit : Nat} (hle : signingLog.length ≤ limit) + (selected : (cover.pattern.pad hle).selected) : cover.entries := + cover.entriesEquivPatternSelected.symm + ((cover.pattern.padSelectedEquiv hle).symm selected) + +noncomputable def FewTimeCover.paddedExpectedViews {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + {limit : Nat} (hle : signingLog.length ≤ limit) : + (cover.pattern.pad hle).selected → FewTimeView := + fun selected => cover.entryView (cover.paddedEntry hle selected) + +noncomputable def FewTimeCover.paddedExpectedInputs {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + {q limit : Nat} (hle : signingLog.length ≤ limit) + (configuration : OriginConfiguration (cover.pattern.pad hle) q) : + ↑configuration.prehit → HashInput := + fun selected => cover.entryDigestInput (cover.paddedEntry hle selected.1) + +theorem FewTimeCover.paddedExpectedViews_fixedPatternHit {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + {limit : Nat} (hle : signingLog.length ≤ limit) : + FixedFewTimePatternHit (cover.pattern.pad hle).assignment + (cover.paddedExpectedViews hle, fewTimeTargetView index targetLeaves) := by + constructor + · intro selected + change (cover.entryView (cover.paddedEntry hle selected)).1 = index + exact cover.entryDigest_index (cover.paddedEntry hle selected) + · intro tree + have hentry : cover.paddedEntry hle ((cover.pattern.pad hle).assignment tree) = + cover.entryAssignment tree := by + apply cover.entriesEquivPatternSelected.injective + rw [FewTimeCover.paddedEntry, + cover.entriesEquivPatternSelected.apply_symm_apply] + apply (cover.pattern.padSelectedEquiv hle).injective + rw [(cover.pattern.padSelectedEquiv hle).apply_symm_apply] + rfl + change targetLeaves (ftsIndexOf tree) = + (cover.entryView + (cover.paddedEntry hle ((cover.pattern.pad hle).assignment tree))).2 tree + rw [hentry] + exact (cover.entryDigest_assigned_leaf tree).symm + +theorem FewTimeCover.entriesEquivPatternSelected_val {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (entry : cover.entries) : + (cover.entriesEquivPatternSelected entry).1 = cover.logIndex entry := rfl + +theorem FewTimePattern.padSelectedEquiv_symm_val {small large distinct : Nat} + (pattern : FewTimePattern small distinct) (hle : small ≤ large) + (selected : (pattern.pad hle).selected) : + ((pattern.padSelectedEquiv hle).symm selected).1.val = selected.1.val := by + have happly := (pattern.padSelectedEquiv hle).apply_symm_apply selected + have hval := congrArg (fun value => value.1.val) happly + rw [FewTimePattern.padSelectedEquiv_apply] at hval + exact hval + +theorem FewTimeCover.paddedEntry_logIndex_val {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + {limit : Nat} (hle : signingLog.length ≤ limit) + (selected : (cover.pattern.pad hle).selected) : + (cover.logIndex (cover.paddedEntry hle selected)).val = selected.1.val := by + let oldSelected := (cover.pattern.padSelectedEquiv hle).symm selected + have happly := cover.entriesEquivPatternSelected.apply_symm_apply oldSelected + have hval := congrArg (fun value => value.1.val) happly + rw [cover.entriesEquivPatternSelected_val] at hval + exact hval.trans (cover.pattern.padSelectedEquiv_symm_val hle selected) + +theorem FewTimeCover.originReplayEvents_get_signer {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (state : ViewedFullTraceState) + (hlog : state.trace.signing.toSigningLog = signingLog) + (hvalid : state.ValidViews secretKey) + (hconsistent : state.trace.Consistent) + (hcaches : state.trace.signing.CachesLe cache) (hf : cache.AgreesWithFn f) + {limit : Nat} (hle : signingLog.length ≤ limit) + (selected : (cover.pattern.pad hle).selected) + (position : Fin state.trace.intervals.length) + (request : SignRequest) (signature : Option Signature) + (initialCache finalCache : QueryCache HashSpec) + (hinterval : state.trace.intervals.get position = + ⟨.inr request, signature, initialCache, finalCache⟩) + (hrank : signerIntervalCount (state.trace.intervals.take position.val) = + selected.1.val) : + (originReplayEvents state.trace.intervals state.views).get + ⟨position.val, by rw [originReplayEvents_length]; exact position.isLt⟩ = + .signer request signature (some (cover.paddedExpectedViews hle selected)) + initialCache finalCache + ∧ (⟨request, signature, initialCache, finalCache⟩ : SigningCacheEntry) = + cover.cacheEntry state.trace.signing hlog (cover.paddedEntry hle selected) := by + let entry := cover.paddedEntry hle selected + let signingEntry : SigningCacheEntry := + ⟨request, signature, initialCache, finalCache⟩ + have hsigning : AdversaryCacheEntry.signingEntry? + (state.trace.intervals.get position) = some signingEntry := by + rw [hinterval] + rfl + have hfiltered := filterMap_getElem?_at_rank + AdversaryCacheEntry.signingEntry? state.trace.intervals position signingEntry hsigning + rw [hconsistent.2] at hfiltered + have hentryRank : (cover.logIndex entry).val = selected.1.val := + cover.paddedEntry_logIndex_val hle selected + have hcacheEntry : signingEntry = + cover.cacheEntry state.trace.signing hlog entry := by + change state.trace.signing[signerIntervalCount + (state.trace.intervals.take position.val)]? = some signingEntry at hfiltered + rw [hrank, ← hentryRank] at hfiltered + rw [List.getElem?_eq_getElem] at hfiltered + · simpa [entry, signingEntry, FewTimeCover.cacheEntry] using + (Option.some.inj hfiltered).symm + have hview := cover.signingOptionViews_traceIndex_eq_entryView state hlog hvalid + hcaches hf entry + have hviewGet : state.views[(cover.logIndex entry).val]? = + some (some (cover.entryView entry)) := by + rw [List.getElem?_eq_getElem] + · exact congrArg some hview + · rw [← hvalid.length_eq] + have hlength := congrArg List.length hlog + simpa only [SigningCacheTrace.toSigningLog, List.length_map] using + (show (cover.logIndex entry).val < state.trace.signing.toSigningLog.length by + rw [hlength] + exact (cover.logIndex entry).isLt) + constructor + · rw [originReplayEvents_get state.trace.intervals state.views position, hinterval] + simp only [originReplayEventOfEntry] + rw [hrank, ← hentryRank, hviewGet] + rfl + · exact hcacheEntry + +theorem OriginConfiguration.paddedRealized_direct_good {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + {cover : FewTimeCover f cache secretKey signingLog index targetLeaves} + {q limit : Nat} {hle : signingLog.length ≤ limit} + {configuration : OriginConfiguration (cover.pattern.pad hle) q} + {trace : FullAdversaryTrace} {hlog : trace.signing.toSigningLog = signingLog} + (hrealized : configuration.PaddedRealizedBy cover hle trace hlog) + (hvalid : trace.ValidIntervals secretKey) + (position : Fin trace.intervals.length) + (input : HashInput) (output : HashOutput) + (initialCache finalCache : QueryCache HashSpec) + (hinterval : trace.intervals.get position = + ⟨.inl (.inr input), output, initialCache, finalCache⟩) + (directOrdinal : Nat) + (hrank : directIntervalCount (trace.intervals.take position.val) = directOrdinal) + (selected : ↑configuration.prehit) + (hsourceAt : configuration.sourceAt? directOrdinal = some selected) : + input = cover.paddedExpectedInputs hle configuration selected + ∧ initialCache input = none + ∧ signAttemptResultOfOutput output ≠ none + ∧ hashOutputFewTimeView output = + cover.paddedExpectedViews hle selected.1 := by + classical + let oldSelected := (cover.pattern.padSelectedEquiv hle).symm selected.1 + let entry := cover.entriesEquivPatternSelected.symm oldSelected + have hpadded : cover.pattern.padSelectedEquiv hle oldSelected = selected.1 := + (cover.pattern.padSelectedEquiv hle).apply_symm_apply selected.1 + have hselected : cover.pattern.padSelectedEquiv hle + (cover.entriesEquivPatternSelected entry) ∈ configuration.prehit := by + have hentrySelected : cover.entriesEquivPatternSelected entry = oldSelected := + cover.entriesEquivPatternSelected.apply_symm_apply oldSelected + rw [hentrySelected, hpadded] + exact selected.2 + have hprecached : cover.EntryDigestPrecached trace.signing hlog entry := by + apply (hrealized.1 oldSelected).1 + simpa [entry] using hselected + let precached : cover.PrecachedEntries trace.signing hlog := ⟨entry, hprecached⟩ + obtain ⟨sourceOutput, sourcePosition, intervalPosition, selectedIntervalPosition, + hdirect, hsource, hordinal, hbefore, hselectedInterval, hselectedRank, + hinput, hmiss, hrun, hsuccess, hview⟩ := hrealized.2 precached hselected + let realizedSelected : ↑configuration.prehit := + ⟨cover.pattern.padSelectedEquiv hle + (cover.entriesEquivPatternSelected entry), hselected⟩ + have hselectedEq : realizedSelected = selected := by + apply Subtype.ext + change cover.pattern.padSelectedEquiv hle + (cover.entriesEquivPatternSelected entry) = selected.1 + rw [cover.entriesEquivPatternSelected.apply_symm_apply oldSelected, hpadded] + have hsourceValue : sourcePosition.val = + (configuration.source.1 selected).val := by + change sourcePosition.val = (configuration.source.1 realizedSelected).val at hsource + rwa [hselectedEq] at hsource + have hlookup := (configuration.sourceAt?_eq_some_iff directOrdinal selected).1 hsourceAt + have hcurrentEncode := encodeSubtype_directInterval_eq trace.intervals position (by + rw [hinterval] + trivial) + have hsourceEncode : + (Fin.encodeSubtype (fun candidate => + isDirectHashQuery (trace.intervals.get candidate).input) + ⟨intervalPosition, hdirect⟩).val = + (Fin.encodeSubtype (fun candidate => + isDirectHashQuery (trace.intervals.get candidate).input) + ⟨position, by rw [hinterval]; trivial⟩).val := by + calc + _ = sourcePosition.val := hordinal.symm + _ = (configuration.source.1 selected).val := hsourceValue + _ = directOrdinal := hlookup + _ = directIntervalCount (trace.intervals.take position.val) := hrank.symm + _ = _ := hcurrentEncode.symm + have hencoded : Fin.encodeSubtype (fun candidate => + isDirectHashQuery (trace.intervals.get candidate).input) + ⟨intervalPosition, hdirect⟩ = + Fin.encodeSubtype (fun candidate => + isDirectHashQuery (trace.intervals.get candidate).input) + ⟨position, by rw [hinterval]; trivial⟩ := + Fin.ext hsourceEncode + have hpositions := congrArg (Fin.decodeSubtype (fun candidate => + isDirectHashQuery (trace.intervals.get candidate).input)) hencoded + simp only [Fin.decodeSubtype_encodeSubtype] at hpositions + have hposition : intervalPosition = position := congrArg Subtype.val hpositions + subst intervalPosition + have hinput' : input = cover.entryDigestInput entry := by + rw [hinterval] at hinput + simpa using hinput + subst input + have hmiss' : initialCache (cover.entryDigestInput entry) = none := by + rw [hinterval] at hmiss + exact hmiss + have hrun' : (sourceOutput, finalCache) ∈ support + ((randomOracle (cover.entryDigestInput entry)).run initialCache) := by + change (sourceOutput, (trace.intervals.get position).finalCache) ∈ support + ((randomOracle (cover.entryDigestInput entry)).run + (trace.intervals.get position).initialCache) at hrun + rwa [hinterval] at hrun + have hsourceCached := randomOracle_run_output_cached + (cover.entryDigestInput entry) initialCache finalCache sourceOutput hrun' + have hentryMem : (⟨.inl (.inr (cover.entryDigestInput entry)), output, + initialCache, finalCache⟩ : AdversaryCacheEntry) ∈ trace.intervals := by + rw [← hinterval] + exact List.get_mem trace.intervals position + have hactualCached := trace.directHashInterval_cached hvalid + (cover.entryDigestInput entry) output initialCache finalCache hentryMem + have houtput : output = sourceOutput := + Option.some.inj (hactualCached.symm.trans hsourceCached) + subst sourceOutput + have hentryEq : cover.paddedEntry hle selected.1 = entry := rfl + refine ⟨?_, hmiss', hsuccess, ?_⟩ + · change cover.entryDigestInput entry = + cover.entryDigestInput (cover.paddedEntry hle selected.1) + rw [hentryEq] + · change hashOutputFewTimeView output = + cover.entryView (cover.paddedEntry hle selected.1) + rwa [hentryEq] + +theorem OriginConfiguration.paddedRealized_source_lt_directIntervalCount + {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + {cover : FewTimeCover f cache secretKey signingLog index targetLeaves} + {q limit : Nat} {hle : signingLog.length ≤ limit} + {configuration : OriginConfiguration (cover.pattern.pad hle) q} + {trace : FullAdversaryTrace} {hlog : trace.signing.toSigningLog = signingLog} + (hrealized : configuration.PaddedRealizedBy cover hle trace hlog) + (selected : ↑configuration.prehit) : + (configuration.source.1 selected).val < directIntervalCount trace.intervals := by + classical + let oldSelected := (cover.pattern.padSelectedEquiv hle).symm selected.1 + let entry := cover.entriesEquivPatternSelected.symm oldSelected + have hpadded : cover.pattern.padSelectedEquiv hle oldSelected = selected.1 := + (cover.pattern.padSelectedEquiv hle).apply_symm_apply selected.1 + have hselected : cover.pattern.padSelectedEquiv hle + (cover.entriesEquivPatternSelected entry) ∈ configuration.prehit := by + rw [cover.entriesEquivPatternSelected.apply_symm_apply oldSelected, hpadded] + exact selected.2 + have hprecached : cover.EntryDigestPrecached trace.signing hlog entry := by + apply (hrealized.1 oldSelected).1 + simpa [entry] using hselected + let precached : cover.PrecachedEntries trace.signing hlog := ⟨entry, hprecached⟩ + obtain ⟨_, sourcePosition, intervalPosition, _, hdirect, hsource, hordinal, _⟩ := + hrealized.2 precached hselected + let realizedSelected : ↑configuration.prehit := + ⟨cover.pattern.padSelectedEquiv hle + (cover.entriesEquivPatternSelected entry), hselected⟩ + have hselectedEq : realizedSelected = selected := by + apply Subtype.ext + change cover.pattern.padSelectedEquiv hle + (cover.entriesEquivPatternSelected entry) = selected.1 + rw [cover.entriesEquivPatternSelected.apply_symm_apply oldSelected, hpadded] + have hsourceValue : sourcePosition.val = + (configuration.source.1 selected).val := by + change sourcePosition.val = (configuration.source.1 realizedSelected).val at hsource + rwa [hselectedEq] at hsource + have hlt := encodeSubtype_directInterval_lt_count_take trace.intervals + intervalPosition hdirect trace.intervals.length intervalPosition.isLt + rw [List.take_length] at hlt + rw [← hsourceValue, hordinal] + exact hlt + +theorem FewTimeCover.paddedSelected_lt_signingLog_length {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + {limit : Nat} (hle : signingLog.length ≤ limit) + (selected : (cover.pattern.pad hle).selected) : + selected.1.val < signingLog.length := by + let oldSelected := (cover.pattern.padSelectedEquiv hle).symm selected + rw [← cover.pattern.padSelectedEquiv_symm_val hle selected] + exact oldSelected.1.isLt + +def OriginReplayEvent.Good {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (event : OriginReplayEvent) (secretKey : SecretKey) + (directOrdinal signerOrdinal : Nat) + (expectedViews : pattern.selected → FewTimeView) + (expectedInputs : ↑configuration.prehit → HashInput) : Prop := + match event with + | .uniform => True + | .direct input output initialCache _ => + ∀ selected, configuration.sourceAt? directOrdinal = some selected → + input = expectedInputs selected + ∧ initialCache input = none + ∧ signAttemptResultOfOutput output ≠ none + ∧ hashOutputFewTimeView output = expectedViews selected.1 + | .signer request signature view initialCache finalCache => + ∀ selected, pattern.selectedAt? signerOrdinal = some selected → + if hprehit : selected ∈ configuration.prehit then + (configuration.source.1 ⟨selected, hprehit⟩).val < directOrdinal + ∧ PrehitSuccessfulSignerView + (onlyInputCache initialCache (expectedInputs ⟨selected, hprehit⟩)) + secretKey request (fun value => value = expectedViews selected) + ((signature, view), finalCache) + else + FreshSuccessfulSignerView initialCache secretKey request + (fun value => value = expectedViews selected) ((signature, view), finalCache) + +noncomputable def OriginReplayEvents.Good {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) + (expectedViews : pattern.selected → FewTimeView) + (expectedInputs : ↑configuration.prehit → HashInput) : + OriginReplayState configuration → List OriginReplayEvent → Prop + | _, [] => True + | state, event :: events => + event.Good secretKey state.directOrdinal state.signerOrdinal + expectedViews expectedInputs + ∧ OriginReplayEvents.Good secretKey expectedViews expectedInputs + (state.step secretKey event) events + +theorem OriginReplayEvents.good_of_get {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) + (expectedViews : pattern.selected → FewTimeView) + (expectedInputs : ↑configuration.prehit → HashInput) + (state : OriginReplayState configuration) (events : List OriginReplayEvent) + (hgood : ∀ position : Fin events.length, + (events.get position).Good secretKey + (state.directOrdinal + OriginReplayEvents.directCount (events.take position.val)) + (state.signerOrdinal + OriginReplayEvents.signerCount (events.take position.val)) + expectedViews expectedInputs) : + OriginReplayEvents.Good secretKey expectedViews expectedInputs state events := by + induction events generalizing state with + | nil => trivial + | cons event events ih => + constructor + · simpa [OriginReplayEvents.directCount, OriginReplayEvents.signerCount] using + hgood ⟨0, by simp⟩ + · apply ih (state.step secretKey event) + intro position + have hnext := hgood ⟨position.val + 1, Nat.succ_lt_succ position.isLt⟩ + cases event <;> + simpa [OriginReplayEvents.directCount, OriginReplayEvents.signerCount, + OriginReplayEvent.directIncrement, OriginReplayEvent.signerIncrement, + Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] using hnext + +set_option maxHeartbeats 1000000 in +theorem OriginConfiguration.paddedRealized_replay_good {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + {cover : FewTimeCover f cache secretKey signingLog index targetLeaves} + {q limit : Nat} {hle : signingLog.length ≤ limit} + {configuration : OriginConfiguration (cover.pattern.pad hle) q} + {state : ViewedFullTraceState} + (hlog : state.trace.signing.toSigningLog = signingLog) + (hrealized : configuration.PaddedRealizedBy cover hle state.trace hlog) + (hvalidViews : state.ValidViews secretKey) + (hconsistent : state.trace.Consistent) + (hvalidIntervals : state.trace.ValidIntervals secretKey) + (hchronological : FullAdversaryTrace.Chronological state.trace.intervals) + (hcaches : state.trace.signing.CachesLe cache) (hf : cache.AgreesWithFn f) : + OriginReplayEvents.Good secretKey (cover.paddedExpectedViews hle) + (cover.paddedExpectedInputs hle configuration) + (OriginReplayState.initial configuration) + (originReplayEvents state.trace.intervals state.views) := by + classical + apply OriginReplayEvents.good_of_get + intro eventPosition + let intervalPosition : Fin state.trace.intervals.length := + ⟨eventPosition.val, by + rw [← originReplayEvents_length state.trace.intervals state.views] + exact eventPosition.isLt⟩ + have heventPosition : eventPosition = + ⟨intervalPosition.val, by + rw [originReplayEvents_length state.trace.intervals state.views] + exact intervalPosition.isLt⟩ := Fin.ext rfl + have hcounts := originReplayEvents_take_counts state.trace.intervals state.views + intervalPosition.val + have hevent := originReplayEvents_get state.trace.intervals state.views intervalPosition + have heventAt : (originReplayEvents state.trace.intervals state.views).get + eventPosition = originReplayEventOfEntry + (state.trace.intervals.get intervalPosition) + (state.views[signerIntervalCount + (state.trace.intervals.take intervalPosition.val)]?.getD none) := by + rw [heventPosition] + exact hevent + generalize hinterval : state.trace.intervals.get intervalPosition = interval at hevent heventAt + rcases interval with ⟨input, output, initialCache, finalCache⟩ + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + simp [originReplayEventOfEntry] at heventAt + have heventGet : (originReplayEvents state.trace.intervals state.views).get + eventPosition = .uniform := by + simpa only [List.get_eq_getElem] using heventAt + rw [heventGet] + simp only [OriginReplayEvent.Good] + | inr hashInput => + simp only [originReplayEventOfEntry] at heventAt + have heventGet : (originReplayEvents state.trace.intervals state.views).get + eventPosition = .direct hashInput output initialCache finalCache := by + simpa only [List.get_eq_getElem] using heventAt + rw [heventGet] + intro selected hsourceAt + exact configuration.paddedRealized_direct_good hrealized hvalidIntervals + intervalPosition hashInput output initialCache finalCache hinterval + (OriginReplayEvents.directCount + ((originReplayEvents state.trace.intervals state.views).take eventPosition.val)) + hcounts.1.symm selected (by + simpa only [OriginReplayState.initial, zero_add] using hsourceAt) + | inr request => + simp only [originReplayEventOfEntry] at hevent heventAt + have heventGet : (originReplayEvents state.trace.intervals state.views).get + eventPosition = .signer request output + (state.views[signerIntervalCount + (state.trace.intervals.take intervalPosition.val)]?.getD none) + initialCache finalCache := by + simpa only [List.get_eq_getElem] using heventAt + rw [heventGet] + intro selected hselectedAt + have hselectedValue : selected.1.val = + OriginReplayEvents.signerCount + ((originReplayEvents state.trace.intervals state.views).take eventPosition.val) := + (cover.pattern.pad hle).selectedAt?_eq_some_iff _ selected |>.1 (by + simpa [OriginReplayState.initial] using hselectedAt) + have hrank : signerIntervalCount + (state.trace.intervals.take intervalPosition.val) = selected.1.val := by + rw [← hcounts.2, hselectedValue] + have hsigner := cover.originReplayEvents_get_signer state hlog hvalidViews + hconsistent hcaches hf hle selected intervalPosition request output initialCache + finalCache hinterval hrank + have heventEq : OriginReplayEvent.signer request output + (state.views[signerIntervalCount + (state.trace.intervals.take intervalPosition.val)]?.getD none) + initialCache finalCache = + OriginReplayEvent.signer request output + (some (cover.paddedExpectedViews hle selected)) initialCache finalCache := + hevent.symm.trans hsigner.1 + have hviewEq : state.views[signerIntervalCount + (state.trace.intervals.take intervalPosition.val)]?.getD none = + some (cover.paddedExpectedViews hle selected) := by + injection heventEq + rw [hviewEq] + let entry := cover.paddedEntry hle selected + let signingEntry : SigningCacheEntry := + ⟨request, output, initialCache, finalCache⟩ + have hcacheEntry : signingEntry = + cover.cacheEntry state.trace.signing hlog entry := by + simpa [entry, signingEntry] using hsigner.2 + let chosen := cover.select (cover.representativeTree entry) + have hfields := cover.cacheEntry_request_signature state.trace.signing hlog entry + have hrequest : request = chosen.entry.1 := by + have hfield := congrArg SigningCacheEntry.request hcacheEntry + exact hfield.trans hfields.1 + have hsignature : output = some chosen.signature := by + have hfield := congrArg SigningCacheEntry.signature hcacheEntry + exact hfield.trans hfields.2 + have hinitial : initialCache = + (cover.cacheEntry state.trace.signing hlog entry).initialCache := + congrArg SigningCacheEntry.initialCache hcacheEntry + have hinput : tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root request chosen.signature.randomness) = + cover.entryDigestInput entry := by + rw [hrequest] + rfl + by_cases hprehit : selected ∈ configuration.prehit + · simp only [hprehit, dite_true] + let prehit : ↑configuration.prehit := ⟨selected, hprehit⟩ + let oldSelected := (cover.pattern.padSelectedEquiv hle).symm selected + have hentrySelected : cover.entriesEquivPatternSelected entry = oldSelected := by + exact cover.entriesEquivPatternSelected.apply_symm_apply oldSelected + have hpadded : cover.pattern.padSelectedEquiv hle oldSelected = selected := + (cover.pattern.padSelectedEquiv hle).apply_symm_apply selected + have hselected : cover.pattern.padSelectedEquiv hle + (cover.entriesEquivPatternSelected entry) ∈ configuration.prehit := by + rw [hentrySelected, hpadded] + exact hprehit + have hprecached : cover.EntryDigestPrecached state.trace.signing hlog entry := + (hrealized.1 oldSelected).1 (by + rw [← hentrySelected] + exact hselected) + let precached : cover.PrecachedEntries state.trace.signing hlog := + ⟨entry, hprecached⟩ + obtain ⟨sourceOutput, sourcePosition, sourceInterval, selectedInterval, + hdirect, hsource, hordinal, hbefore, hselectedInterval, hselectedRank, + hsourceInput, hsourceMiss, hsourceRun, hsourceSuccess, hsourceView⟩ := + hrealized.2 precached hselected + have hcurrentSigning : AdversaryCacheEntry.signingEntry? + (state.trace.intervals.get intervalPosition) = + some (cover.cacheEntry state.trace.signing hlog entry) := by + rw [hinterval] + change some signingEntry = + some (cover.cacheEntry state.trace.signing hlog entry) + exact congrArg some hcacheEntry + have hselectedPosition : selectedInterval = intervalPosition := by + apply filterMap_take_length_injective_at_some + AdversaryCacheEntry.signingEntry? state.trace.intervals + selectedInterval intervalPosition + (cover.cacheEntry state.trace.signing hlog entry) + (cover.cacheEntry state.trace.signing hlog entry) + · simpa [precached] using hselectedInterval + · exact hcurrentSigning + · exact hselectedRank.trans + ((cover.paddedEntry_logIndex_val hle selected).trans hrank.symm) + have hbeforeCurrent : sourceInterval.val < intervalPosition.val := by + rw [← hselectedPosition] + exact hbefore + have hsourceLt := encodeSubtype_directInterval_lt_count_take + state.trace.intervals sourceInterval hdirect intervalPosition.val hbeforeCurrent + let realizedPrehit : ↑configuration.prehit := + ⟨cover.pattern.padSelectedEquiv hle + (cover.entriesEquivPatternSelected entry), hselected⟩ + have hprehitEq : realizedPrehit = prehit := by + apply Subtype.ext + change cover.pattern.padSelectedEquiv hle + (cover.entriesEquivPatternSelected entry) = selected + rw [hentrySelected, hpadded] + have hsourceValue : sourcePosition.val = + (configuration.source.1 prehit).val := by + change sourcePosition.val = + (configuration.source.1 realizedPrehit).val at hsource + rwa [hprehitEq] at hsource + have hsourceBefore : (configuration.source.1 prehit).val < + OriginReplayEvents.directCount + ((originReplayEvents state.trace.intervals state.views).take + eventPosition.val) := by + rw [hcounts.1] + rw [← hsourceValue, hordinal] + exact hsourceLt + have hsourceCached := randomOracle_run_output_cached + (cover.entryDigestInput entry) + (state.trace.intervals.get sourceInterval).initialCache + (state.trace.intervals.get sourceInterval).finalCache sourceOutput (by + simpa [precached] using hsourceRun) + have hsourceLe := + Concrete.FullAdversaryTrace.Chronological.get_finalCache_le_initialCache + hchronological sourceInterval intervalPosition hbeforeCurrent + have hcached : initialCache (cover.entryDigestInput entry) = + some sourceOutput := by + have := hsourceLe hsourceCached + rwa [hinterval] at this + refine ⟨?_, ?_⟩ + · simpa [OriginReplayState.initial, prehit] using hsourceBefore + · refine ⟨chosen.signature, cover.paddedExpectedViews hle selected, ?_, + sourceOutput, ?_, ?_⟩ + · exact Prod.ext hsignature rfl + · change onlyInputCache initialCache + (cover.paddedExpectedInputs hle configuration prehit) + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root request + chosen.signature.randomness)) = some sourceOutput + rw [hinput] + change onlyInputCache initialCache (cover.entryDigestInput entry) + (cover.entryDigestInput entry) = some sourceOutput + simp [onlyInputCache, hcached] + · change hashOutputFewTimeView sourceOutput = cover.entryView entry + simpa [precached] using hsourceView + · simp only [hprehit, dite_false] + have hnotPrecached : ¬cover.EntryDigestPrecached state.trace.signing hlog entry := by + intro hprecached + apply hprehit + have hprecached' : cover.EntryDigestPrecached state.trace.signing hlog + (cover.entriesEquivPatternSelected.symm + ((cover.pattern.padSelectedEquiv hle).symm selected)) := by + simpa [entry, FewTimeCover.paddedEntry] using hprecached + have hmember := + (hrealized.1 ((cover.pattern.padSelectedEquiv hle).symm selected)).2 hprecached' + rw [(cover.pattern.padSelectedEquiv hle).apply_symm_apply selected] at hmember + exact hmember + refine ⟨chosen.signature, cover.paddedExpectedViews hle selected, ?_, ?_, rfl⟩ + · exact Prod.ext hsignature rfl + · rw [hinput, hinitial] + exact not_ne_iff.mp hnotPrecached + +def viewedOriginReplayEvents (state : ViewedFullTraceState) : + List OriginReplayEvent := + Concrete.originReplayEvents state.trace.intervals state.views + +def appendOriginReplayView (entry : AdversaryCacheEntry) + (views : List (Option FewTimeView)) (view : Option FewTimeView) : + List (Option FewTimeView) := + match entry.input with + | .inr _ => views ++ [view] + | .inl _ => views + +theorem originReplayEvents_append_entry + (intervals : List AdversaryCacheEntry) (views : List (Option FewTimeView)) + (entry : AdversaryCacheEntry) (view : Option FewTimeView) + (haligned : (intervals.filterMap AdversaryCacheEntry.signingEntry?).length = + views.length) : + originReplayEvents (intervals ++ [entry]) (appendOriginReplayView entry views view) = + originReplayEvents intervals views ++ [originReplayEventOfEntry entry view] := by + induction intervals generalizing views with + | nil => + rcases entry with ⟨input, output, initialCache, finalCache⟩ + cases input with + | inl worldInput => cases worldInput <;> rfl + | inr request => + have hlength : views.length = 0 := by simpa using haligned.symm + have hviews : views = [] := List.eq_nil_of_length_eq_zero hlength + subst views + rfl + | cons head rest ih => + rcases head with ⟨input, output, initialCache, finalCache⟩ + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + have htail : (rest.filterMap AdversaryCacheEntry.signingEntry?).length = + views.length := by + simpa [AdversaryCacheEntry.signingEntry?] using haligned + simp only [List.cons_append, originReplayEvents] + rw [ih views htail] + | inr hashInput => + have htail : (rest.filterMap AdversaryCacheEntry.signingEntry?).length = + views.length := by + simpa [AdversaryCacheEntry.signingEntry?] using haligned + simp only [List.cons_append, originReplayEvents] + rw [ih views htail] + | inr request => + cases views with + | nil => simp [AdversaryCacheEntry.signingEntry?] at haligned + | cons headView restViews => + have htail : (rest.filterMap AdversaryCacheEntry.signingEntry?).length = + restViews.length := by + simpa [AdversaryCacheEntry.signingEntry?] using haligned + rcases entry with ⟨entryInput, entryOutput, entryInitial, entryFinal⟩ + cases entryInput with + | inl entryWorldInput => + cases entryWorldInput with + | inl entryUniform => + simpa [appendOriginReplayView, originReplayEvents, + originReplayEventOfEntry] using + congrArg (List.cons (OriginReplayEvent.signer request output headView + initialCache finalCache)) (ih restViews htail) + | inr entryHash => + simpa [appendOriginReplayView, originReplayEvents, + originReplayEventOfEntry] using + congrArg (List.cons (OriginReplayEvent.signer request output headView + initialCache finalCache)) (ih restViews htail) + | inr entryRequest => + simpa [appendOriginReplayView, originReplayEvents, + originReplayEventOfEntry] using + congrArg (List.cons (OriginReplayEvent.signer request output headView + initialCache finalCache)) (ih restViews htail) + +theorem replayOriginEvents_append {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (events : List OriginReplayEvent) (event : OriginReplayEvent) : + replayOriginEvents configuration secretKey (events ++ [event]) = + (replayOriginEvents configuration secretKey events).step secretKey event := by + simp [replayOriginEvents, List.foldl_append] + +theorem replayOriginEvents_ordinals {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (events : List OriginReplayEvent) : + (replayOriginEvents configuration secretKey events).directOrdinal = + OriginReplayEvents.directCount events + ∧ (replayOriginEvents configuration secretKey events).signerOrdinal = + OriginReplayEvents.signerCount events := by + have hfold : ∀ state : OriginReplayState configuration, + (events.foldl (OriginReplayState.step secretKey) state).directOrdinal = + state.directOrdinal + OriginReplayEvents.directCount events + ∧ (events.foldl (OriginReplayState.step secretKey) state).signerOrdinal = + state.signerOrdinal + OriginReplayEvents.signerCount events := by + induction events with + | nil => intro state; simp [OriginReplayEvents.directCount, + OriginReplayEvents.signerCount] + | cons event events ih => + intro state + simpa [OriginReplayEvents.directCount, OriginReplayEvents.signerCount, + Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] using + ih (state.step secretKey event) + simpa [replayOriginEvents, OriginReplayState.initial] using + hfold (OriginReplayState.initial configuration) + +def OriginMonitorState.replayState {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) : OriginReplayState configuration := + ⟨state.observation, state.directOrdinal, state.signerOrdinal, state.valid⟩ + +def OriginMonitorState.ReplayConsistent {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (state : OriginMonitorState configuration) : Prop := + state.viewed.ValidViews secretKey + ∧ state.viewed.trace.Consistent + ∧ state.replayState = + replayOriginEvents configuration secretKey (viewedOriginReplayEvents state.viewed) + +theorem OriginMonitorState.replayConsistent_initial {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (cache : QueryCache HashSpec) : + (OriginMonitorState.initial configuration cache).ReplayConsistent secretKey := by + simp [OriginMonitorState.ReplayConsistent, OriginMonitorState.initial, + ViewedFullTraceState.ValidViews, FullAdversaryTrace.Consistent, + OriginMonitorState.replayState, viewedOriginReplayEvents, + originReplayEvents, replayOriginEvents, OriginReplayState.initial] + +theorem OriginMonitorState.ReplayConsistent.aligned {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + {secretKey : SecretKey} {state : OriginMonitorState configuration} + (hconsistent : state.ReplayConsistent secretKey) : + (state.viewed.trace.intervals.filterMap + AdversaryCacheEntry.signingEntry?).length = state.viewed.views.length := by + rw [hconsistent.2.1.2] + exact hconsistent.1.length_eq + +theorem originMonitoredAdversaryImpl_query_replayConsistent + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (input : (OracleWorld + SigningSpec).Domain) + (state : OriginMonitorState configuration) + (result : (OracleWorld + SigningSpec).Range input × OriginMonitorState configuration) + (hconsistent : state.ReplayConsistent secretKey) + (hmem : result ∈ support + ((originMonitoredAdversaryImpl configuration secretKey input).run state)) : + result.2.ReplayConsistent secretKey := by + classical + have hviewedMem : (result.1, result.2.viewed) ∈ support + ((viewedFullTracedMappedAdversaryImpl secretKey input).run state.viewed) := by + rw [← originMonitoredAdversaryImpl_query_projection configuration secretKey input state, + support_map] + exact ⟨result, hmem, rfl⟩ + have hvalidViews := viewedFullTracedMappedAdversaryImpl_query_validViews secretKey input + state.viewed (result.1, result.2.viewed) hconsistent.1 hviewedMem + have haligned := hconsistent.aligned + have hreplay := hconsistent.2.2 + have hreplay' : state.replayState = replayOriginEvents configuration secretKey + (originReplayEvents state.viewed.trace.intervals state.viewed.views) := by + simpa only [viewedOriginReplayEvents] using hreplay + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + rw [originMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, finalCache⟩, hquery, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + refine ⟨hvalidViews, + fullAdversaryTraceUpdate_consistent (.inl (.inl uniformInput)) state.viewed.cache + output finalCache state.viewed.trace hconsistent.2.1, ?_⟩ + let entry : AdversaryCacheEntry := + ⟨.inl (.inl uniformInput), output, state.viewed.cache, finalCache⟩ + have happend := originReplayEvents_append_entry state.viewed.trace.intervals + state.viewed.views entry none haligned + simp only [appendOriginReplayView] at happend + change state.replayState = replayOriginEvents configuration secretKey + (originReplayEvents (state.viewed.trace.intervals ++ [entry]) state.viewed.views) + rw [happend, replayOriginEvents_append, ← hreplay'] + simp [entry, originReplayEventOfEntry, OriginReplayState.step] + | inr hashInput => + rw [originMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, finalCache⟩, hquery, hpure⟩ := hmem + change HashOutput at output + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + refine ⟨hvalidViews, + fullAdversaryTraceUpdate_consistent (.inl (.inr hashInput)) state.viewed.cache + output finalCache state.viewed.trace hconsistent.2.1, ?_⟩ + let entry : AdversaryCacheEntry := + ⟨.inl (.inr hashInput), output, state.viewed.cache, finalCache⟩ + have happend := originReplayEvents_append_entry state.viewed.trace.intervals + state.viewed.views entry none haligned + simp only [appendOriginReplayView] at happend + change (state.replayState.step secretKey + (.direct hashInput output state.viewed.cache finalCache)) = + replayOriginEvents configuration secretKey + (originReplayEvents (state.viewed.trace.intervals ++ [entry]) state.viewed.views) + rw [happend, replayOriginEvents_append, ← hreplay'] + simp [entry, originReplayEventOfEntry] + | inr request => + rw [originMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨⟨signature, view⟩, finalCache⟩, hquery, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + refine ⟨hvalidViews, + fullAdversaryTraceUpdate_consistent (.inr request) state.viewed.cache signature + finalCache state.viewed.trace hconsistent.2.1, ?_⟩ + let entry : AdversaryCacheEntry := + ⟨.inr request, signature, state.viewed.cache, finalCache⟩ + have happend := originReplayEvents_append_entry state.viewed.trace.intervals + state.viewed.views entry view haligned + simp only [appendOriginReplayView] at happend + change (state.replayState.step secretKey + (.signer request signature view state.viewed.cache finalCache)) = + replayOriginEvents configuration secretKey + (originReplayEvents (state.viewed.trace.intervals ++ [entry]) + (state.viewed.views ++ [view])) + rw [happend, replayOriginEvents_append, ← hreplay'] + simp [entry, originReplayEventOfEntry] + +theorem originMonitoredAdversaryImpl_replayConsistent + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginMonitorState configuration) + (result : α × OriginMonitorState configuration) + (hconsistent : initialState.ReplayConsistent secretKey) + (hmem : result ∈ support + ((simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState)) : + result.2.ReplayConsistent secretKey := by + exact OracleComp.simulateQ_run_preservesInv + (originMonitoredAdversaryImpl configuration secretKey) + (OriginMonitorState.ReplayConsistent secretKey) + (by + intro input state hstate queryResult hquery + exact originMonitoredAdversaryImpl_query_replayConsistent configuration secretKey input + state queryResult hstate hquery) + computation initialState hconsistent result hmem + +def OriginReplayState.Expected {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginReplayState configuration) + (expectedViews : pattern.selected → FewTimeView) + (expectedInputs : ↑configuration.prehit → HashInput) : Prop := + (state.asMonitor ∅).ScheduleCoherent + ∧ state.valid = true + ∧ (∀ selected ∈ state.observation.seenSources, + state.observation.sourceInputs selected = expectedInputs selected + ∧ state.observation.views selected.1 = expectedViews selected.1) + ∧ ∀ selected ∈ state.observation.seenViews, + state.observation.views selected = expectedViews selected + +theorem OriginReplayState.expected_initial {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) + (expectedViews : pattern.selected → FewTimeView) + (expectedInputs : ↑configuration.prehit → HashInput) : + (OriginReplayState.initial configuration).Expected expectedViews expectedInputs := by + refine ⟨?_, rfl, ?_, ?_⟩ + · change (OriginMonitorState.initial configuration + (∅ : QueryCache HashSpec)).ScheduleCoherent + exact OriginMonitorState.scheduleCoherent_initial configuration ∅ + · intro selected hseen + simp [OriginReplayState.initial, OriginObservation.empty] at hseen + · intro selected hseen + simp [OriginReplayState.initial, OriginObservation.empty] at hseen + +theorem OriginReplayState.expected_step {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginReplayState configuration) (secretKey : SecretKey) + (event : OriginReplayEvent) + (expectedViews : pattern.selected → FewTimeView) + (expectedInputs : ↑configuration.prehit → HashInput) + (hexpected : state.Expected expectedViews expectedInputs) + (hgood : event.Good secretKey state.directOrdinal state.signerOrdinal + expectedViews expectedInputs) : + (state.step secretKey event).Expected expectedViews expectedInputs := by + classical + obtain ⟨hcoherent, hvalid, hsources, hviews⟩ := hexpected + cases event with + | uniform => exact ⟨hcoherent, hvalid, hsources, hviews⟩ + | direct input output initialCache finalCache => + have hcoherentAt : (state.asMonitor initialCache).ScheduleCoherent := by + simpa [OriginMonitorState.ScheduleCoherent, OriginReplayState.asMonitor] using hcoherent + have hcoherentAfter := (state.asMonitor initialCache).scheduleCoherent_afterDirect + input output hcoherentAt + cases hsource : configuration.sourceAt? state.directOrdinal with + | none => + have hstep : state.step secretKey + (.direct input output initialCache finalCache) = + ⟨state.observation, state.directOrdinal + 1, state.signerOrdinal, + state.valid⟩ := by + simp [OriginReplayState.step, OriginReplayState.asMonitor, + monitorDirectSource, hsource] + rw [hstep] + refine ⟨?_, hvalid, hsources, hviews⟩ + simpa [OriginReplayState.asMonitor, OriginMonitorState.afterDirect, + OriginMonitorState.ScheduleCoherent, monitorDirectSource, hsource] + using hcoherentAfter + | some selected => + obtain ⟨rfl, hmiss, hsuccess, houtputView⟩ := hgood selected hsource + have hcondition : initialCache (expectedInputs selected) = none ∧ + signAttemptResultOfOutput output ≠ none := ⟨hmiss, hsuccess⟩ + have hstep : state.step secretKey + (.direct (expectedInputs selected) output initialCache finalCache) = + ⟨state.observation.recordSource selected (expectedInputs selected) + (hashOutputFewTimeView output), + state.directOrdinal + 1, state.signerOrdinal, state.valid⟩ := by + simp [OriginReplayState.step, OriginReplayState.asMonitor, + monitorDirectSource, hsource, hcondition] + rw [hstep] + refine ⟨?_, hvalid, ?_, ?_⟩ + · simpa [OriginReplayState.asMonitor, OriginMonitorState.afterDirect, + OriginMonitorState.ScheduleCoherent, monitorDirectSource, hsource, + hcondition] using hcoherentAfter + · intro other hseen + simp only [OriginObservation.recordSource] at hseen ⊢ + rw [Finset.mem_insert] at hseen + rcases hseen with rfl | hseen + · simp [houtputView] + · by_cases heq : other = selected + · subst other + simp [houtputView] + · have hval : other.1 ≠ selected.1 := + fun h => heq (Subtype.ext h) + simpa [heq, hval] using hsources other hseen + · intro other hseen + simp only [OriginObservation.recordSource] at hseen ⊢ + rw [Finset.mem_insert] at hseen + rcases hseen with rfl | hseen + · simp [houtputView] + · by_cases heq : other = selected.1 + · subst other + simp [houtputView] + · simpa [heq] using hviews other hseen + | signer request signature view initialCache finalCache => + have hcoherentAt : (state.asMonitor initialCache).ScheduleCoherent := by + simpa [OriginMonitorState.ScheduleCoherent, OriginReplayState.asMonitor] using hcoherent + have hcoherentAfter := (state.asMonitor initialCache).scheduleCoherent_afterSigner + secretKey request ((signature, view), finalCache) hcoherentAt + cases hselected : pattern.selectedAt? state.signerOrdinal with + | none => + have hstep : state.step secretKey + (.signer request signature view initialCache finalCache) = + ⟨state.observation, state.directOrdinal, state.signerOrdinal + 1, + state.valid⟩ := by + simp [OriginReplayState.step, OriginReplayState.asMonitor, + monitorSigner, hselected] + rw [hstep] + refine ⟨?_, hvalid, hsources, hviews⟩ + simpa [OriginReplayState.asMonitor, OriginMonitorState.afterSigner, + OriginMonitorState.ScheduleCoherent, monitorSigner, hselected] + using hcoherentAfter + | some selected => + by_cases hprehit : selected ∈ configuration.prehit + · let prehit : ↑configuration.prehit := ⟨selected, hprehit⟩ + obtain ⟨hsourceBefore, hsuccess⟩ := by + simpa [hprehit] using hgood selected hselected + have hseenSource : prehit ∈ state.observation.seenSources := + (hcoherentAt hvalid).1 prehit |>.2 hsourceBefore + obtain ⟨hinput, hsourceView⟩ := hsources prehit hseenSource + have hsuccess' : PrehitSuccessfulSignerView + (onlyInputCache initialCache (state.observation.sourceInputs prehit)) + secretKey request (fun value => value = state.observation.views selected) + ((signature, view), finalCache) := by + simpa [prehit, hinput, hsourceView] using hsuccess + have hcondition : prehit ∈ state.observation.seenSources ∧ + PrehitSuccessfulSignerView + (onlyInputCache initialCache (state.observation.sourceInputs prehit)) + secretKey request (fun value => value = state.observation.views selected) + ((signature, view), finalCache) := ⟨hseenSource, hsuccess'⟩ + have hstep : state.step secretKey + (.signer request signature view initialCache finalCache) = + ⟨state.observation, state.directOrdinal, state.signerOrdinal + 1, + state.valid⟩ := by + simp [OriginReplayState.step, OriginReplayState.asMonitor, monitorSigner, + hselected, hprehit, prehit, hcondition] + rw [hstep] + refine ⟨?_, hvalid, hsources, hviews⟩ + simpa [OriginReplayState.asMonitor, OriginMonitorState.afterSigner, + OriginMonitorState.ScheduleCoherent, monitorSigner, hselected, + hprehit, prehit, hcondition] using hcoherentAfter + · have hsuccess : FreshSuccessfulSignerView initialCache secretKey request + (fun value => value = expectedViews selected) + ((signature, view), finalCache) := by + simpa [hprehit] using hgood selected hselected + have hfresh : freshSuccessfulView? initialCache secretKey request + ((signature, view), finalCache) = some (expectedViews selected) := + (freshSuccessfulView?_eq_some_iff initialCache secretKey request + ((signature, view), finalCache) (expectedViews selected)).2 hsuccess + have hstep : state.step secretKey + (.signer request signature view initialCache finalCache) = + ⟨state.observation.recordFresh selected (expectedViews selected), + state.directOrdinal, state.signerOrdinal + 1, state.valid⟩ := by + simp [OriginReplayState.step, OriginReplayState.asMonitor, monitorSigner, + hselected, hprehit, hfresh] + rw [hstep] + refine ⟨?_, hvalid, ?_, ?_⟩ + · simpa [OriginReplayState.asMonitor, OriginMonitorState.afterSigner, + OriginMonitorState.ScheduleCoherent, monitorSigner, hselected, + hprehit, hfresh] using hcoherentAfter + · intro other hseen + have hne : other.1 ≠ selected := by + intro heq + subst selected + exact hprehit other.2 + simpa [OriginObservation.recordFresh, hne] using hsources other hseen + · intro other hseen + simp only [OriginObservation.recordFresh] at hseen ⊢ + rw [Finset.mem_insert] at hseen + rcases hseen with rfl | hseen + · simp + · by_cases heq : other = selected + · subst other + simp + · simpa [heq] using hviews other hseen + +theorem OriginReplayState.expected_foldl {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginReplayState configuration) (secretKey : SecretKey) + (events : List OriginReplayEvent) + (expectedViews : pattern.selected → FewTimeView) + (expectedInputs : ↑configuration.prehit → HashInput) + (hexpected : state.Expected expectedViews expectedInputs) + (hgood : OriginReplayEvents.Good secretKey expectedViews expectedInputs state events) : + (events.foldl (OriginReplayState.step secretKey) state).Expected + expectedViews expectedInputs := by + induction events generalizing state with + | nil => exact hexpected + | cons event events ih => + exact ih (state.step secretKey event) + (state.expected_step secretKey event expectedViews expectedInputs + hexpected hgood.1) hgood.2 + +theorem replayOriginEvents_expected {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (events : List OriginReplayEvent) + (expectedViews : pattern.selected → FewTimeView) + (expectedInputs : ↑configuration.prehit → HashInput) + (hgood : OriginReplayEvents.Good secretKey expectedViews expectedInputs + (OriginReplayState.initial configuration) events) : + (replayOriginEvents configuration secretKey events).Expected + expectedViews expectedInputs := by + exact OriginReplayState.expected_foldl (OriginReplayState.initial configuration) + secretKey events expectedViews expectedInputs + (OriginReplayState.expected_initial configuration expectedViews expectedInputs) hgood + +theorem OriginConfiguration.paddedRealized_replay_expected {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + {cover : FewTimeCover f cache secretKey signingLog index targetLeaves} + {q limit : Nat} {hle : signingLog.length ≤ limit} + {configuration : OriginConfiguration (cover.pattern.pad hle) q} + {state : ViewedFullTraceState} + (hlog : state.trace.signing.toSigningLog = signingLog) + (hrealized : configuration.PaddedRealizedBy cover hle state.trace hlog) + (hvalidViews : state.ValidViews secretKey) + (hconsistent : state.trace.Consistent) + (hvalidIntervals : state.trace.ValidIntervals secretKey) + (hchronological : FullAdversaryTrace.Chronological state.trace.intervals) + (hcaches : state.trace.signing.CachesLe cache) (hf : cache.AgreesWithFn f) : + (replayOriginEvents configuration secretKey + (originReplayEvents state.trace.intervals state.views)).Expected + (cover.paddedExpectedViews hle) + (cover.paddedExpectedInputs hle configuration) := by + apply replayOriginEvents_expected + exact configuration.paddedRealized_replay_good hlog hrealized hvalidViews + hconsistent hvalidIntervals hchronological hcaches hf + +theorem OriginConfiguration.paddedRealized_complete_and_hit {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + {cover : FewTimeCover f cache secretKey signingLog index targetLeaves} + {q limit : Nat} {hle : signingLog.length ≤ limit} + {configuration : OriginConfiguration (cover.pattern.pad hle) q} + {state : OriginMonitorState configuration} + (hlog : state.viewed.trace.signing.toSigningLog = signingLog) + (hrealized : configuration.PaddedRealizedBy cover hle state.viewed.trace hlog) + (hreplay : state.ReplayConsistent secretKey) + (hvalidIntervals : state.viewed.trace.ValidIntervals secretKey) + (hchronological : FullAdversaryTrace.Chronological state.viewed.trace.intervals) + (hcaches : state.viewed.trace.signing.CachesLe cache) + (hf : cache.AgreesWithFn f) : + state.Complete ∧ + FixedFewTimePatternHit (cover.pattern.pad hle).assignment + (state.observation.views, fewTimeTargetView index targetLeaves) := by + have hexpectedReplay := configuration.paddedRealized_replay_expected hlog hrealized + hreplay.1 hreplay.2.1 hvalidIntervals hchronological hcaches hf + have hexpected : state.replayState.Expected + (cover.paddedExpectedViews hle) + (cover.paddedExpectedInputs hle configuration) := by + rw [hreplay.2.2] + exact hexpectedReplay + have hcoherent : state.ScheduleCoherent := by + simpa [OriginReplayState.Expected, OriginMonitorState.replayState, + OriginReplayState.asMonitor, OriginMonitorState.ScheduleCoherent] using hexpected.1 + have hvalid : state.valid = true := hexpected.2.1 + have hordinals := replayOriginEvents_ordinals configuration secretKey + (originReplayEvents state.viewed.trace.intervals state.viewed.views) + have hcounts := originReplayEvents_counts state.viewed.trace.intervals state.viewed.views + have hdirectOrdinal : state.directOrdinal = + directIntervalCount state.viewed.trace.intervals := by + calc + state.directOrdinal = state.replayState.directOrdinal := rfl + _ = (replayOriginEvents configuration secretKey + (originReplayEvents state.viewed.trace.intervals + state.viewed.views)).directOrdinal := congrArg OriginReplayState.directOrdinal + hreplay.2.2 + _ = OriginReplayEvents.directCount + (originReplayEvents state.viewed.trace.intervals state.viewed.views) := hordinals.1 + _ = directIntervalCount state.viewed.trace.intervals := hcounts.1 + have hsignerOrdinal : state.signerOrdinal = + signerIntervalCount state.viewed.trace.intervals := by + calc + state.signerOrdinal = state.replayState.signerOrdinal := rfl + _ = (replayOriginEvents configuration secretKey + (originReplayEvents state.viewed.trace.intervals + state.viewed.views)).signerOrdinal := congrArg OriginReplayState.signerOrdinal + hreplay.2.2 + _ = OriginReplayEvents.signerCount + (originReplayEvents state.viewed.trace.intervals state.viewed.views) := hordinals.2 + _ = signerIntervalCount state.viewed.trace.intervals := hcounts.2 + have hsignerCount : signerIntervalCount state.viewed.trace.intervals = + signingLog.length := by + rw [signerIntervalCount, hreplay.2.1.2] + simpa only [SigningCacheTrace.toSigningLog, List.length_map] using + congrArg List.length hlog + have hcomplete : state.Complete := state.complete_of_valid_and_ordinals + hcoherent hvalid + (fun selected => by + rw [hdirectOrdinal] + exact configuration.paddedRealized_source_lt_directIntervalCount hrealized selected) + (fun selected => by + rw [hsignerOrdinal, hsignerCount] + exact cover.paddedSelected_lt_signingLog_length hle selected) + have hviews : state.observation.views = cover.paddedExpectedViews hle := by + funext selected + exact hexpected.2.2.2 selected (by + change selected ∈ state.observation.seenViews + rw [hcomplete.2.2.2] + simp) + refine ⟨hcomplete, ?_⟩ + rw [hviews] + exact cover.paddedExpectedViews_fixedPatternHit hle +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginWP.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginWP.lean new file mode 100644 index 00000000..c21c527b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeOriginWP.lean @@ -0,0 +1,64 @@ +import SphincsSecurity.Proof.FewTimeOriginProbability + +/-! +# Expected postconditions for stateful oracle simulations + +The origin monitor is proved safe by recursion over the adversary computation. This wrapper gives +that recursion its weakest-precondition form and identifies it with the expected postcondition of +the simulated probabilistic computation. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +noncomputable def simulatedExpectedPost + {ι : Type} {spec : OracleSpec ι} {α state : Type} + (implementation : QueryImpl spec (StateT state ProbComp)) + (computation : OracleComp spec α) (post : α × state → ℝ≥0∞) + (initialState : state) : ℝ≥0∞ := + (OracleComp.recOn (motive := fun _ => (α × state → ℝ≥0∞) → state → ℝ≥0∞) + computation + (fun value post currentState => post (value, currentState)) + (fun input _ continuationPosts post currentState => + ∑' result, Pr[= result | (implementation input).run currentState] * + continuationPosts result.1 post result.2)) post initialState + +@[simp] +theorem simulatedExpectedPost_pure + {ι : Type} {spec : OracleSpec ι} {α state : Type} + (implementation : QueryImpl spec (StateT state ProbComp)) + (value : α) (post : α × state → ℝ≥0∞) (initialState : state) : + simulatedExpectedPost implementation (pure value : OracleComp spec α) post initialState = + post (value, initialState) := by + rfl + +@[simp] +theorem simulatedExpectedPost_query_bind + {ι : Type} {spec : OracleSpec ι} {α state : Type} + (implementation : QueryImpl spec (StateT state ProbComp)) + (input : spec.Domain) (next : spec.Range input → OracleComp spec α) + (post : α × state → ℝ≥0∞) (initialState : state) : + simulatedExpectedPost implementation (liftM (spec.query input) >>= next) post initialState = + ∑' result, Pr[= result | (implementation input).run initialState] * + simulatedExpectedPost implementation (next result.1) post result.2 := by + rfl + +theorem simulatedExpectedPost_eq_tsum + {ι : Type} {spec : OracleSpec ι} {α state : Type} + (implementation : QueryImpl spec (StateT state ProbComp)) + (computation : OracleComp spec α) (post : α × state → ℝ≥0∞) + (initialState : state) : + simulatedExpectedPost implementation computation post initialState = + ∑' result, Pr[= result | (simulateQ implementation computation).run initialState] * + post result := by + induction computation using OracleComp.inductionOn generalizing initialState with + | pure value => + simp [simulateQ_pure, tsum_probOutput_pure_mul] + | query_bind input next ih => + rw [simulatedExpectedPost_query_bind, simulateQ_bind, StateT.run_bind, + simulateQ_query, tsum_probOutput_bind_mul] + simp only [OracleQuery.input_query, OracleQuery.cont_query, id_map] + simp_rw [ih] + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeOrigins.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeOrigins.lean new file mode 100644 index 00000000..e669b61f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeOrigins.lean @@ -0,0 +1,163 @@ +import SphincsSecurity.Proof.FewTimeRace + +/-! +# Origins of selected few-time views + +A selected cover entry always occupies its signer position. If its digest input was already cached, +it additionally has an earlier fresh direct-query source. This module packages those two disjoint +kinds of positions into one injective origin map. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +noncomputable def mixedOriginEmbedding {Entry Signer Source : Type} + (prehit : Entry → Prop) (signer : Entry ↪ Signer) + (source : {entry : Entry // prehit entry} ↪ Source) : + Entry ↪ Signer ⊕ Source := by + classical + refine ⟨fun entry => if h : prehit entry then .inr (source ⟨entry, h⟩) + else .inl (signer entry), ?_⟩ + intro left right heq + by_cases hleft : prehit left <;> by_cases hright : prehit right + · simp only [hleft, hright, ↓reduceDIte, Sum.inr.injEq] at heq + exact congrArg Subtype.val (source.injective heq) + · simp only [hleft, hright, ↓reduceDIte, Sum.inr_ne_inl] at heq + · simp only [hleft, hright, ↓reduceDIte, Sum.inl_ne_inr] at heq + · simp only [hleft, hright, ↓reduceDIte, Sum.inl.injEq] at heq + exact signer.injective heq + +theorem mixedOriginEmbedding_apply_prehit {Entry Signer Source : Type} + (prehit : Entry → Prop) (signer : Entry ↪ Signer) + (source : {entry : Entry // prehit entry} ↪ Source) + (entry : Entry) (hprehit : prehit entry) : + mixedOriginEmbedding prehit signer source entry = .inr (source ⟨entry, hprehit⟩) := by + classical + simp [mixedOriginEmbedding, hprehit] + +theorem mixedOriginEmbedding_apply_fresh {Entry Signer Source : Type} + (prehit : Entry → Prop) (signer : Entry ↪ Signer) + (source : {entry : Entry // prehit entry} ↪ Source) + (entry : Entry) (hfresh : ¬ prehit entry) : + mixedOriginEmbedding prehit signer source entry = .inl (signer entry) := by + classical + simp [mixedOriginEmbedding, hfresh] + +namespace Concrete + +noncomputable def FewTimeCover.logIndexEmbedding {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) : + cover.entries ↪ Fin signingLog.length := + ⟨cover.logIndex, cover.logIndex_injective⟩ + +noncomputable def FewTimeCover.entriesEquivPatternSelected {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) : + cover.entries ≃ cover.pattern.selected := by + classical + let toSelected : cover.entries → cover.pattern.selected := fun entry => + ⟨cover.logIndex entry, by + exact Finset.mem_image.2 ⟨entry, Finset.mem_univ _, rfl⟩⟩ + refine Equiv.ofBijective toSelected ⟨?_, ?_⟩ + · intro left right heq + exact cover.logIndex_injective (congrArg Subtype.val heq) + · intro selected + obtain ⟨entry, _, hentry⟩ := Finset.mem_image.1 selected.2 + refine ⟨entry, Subtype.ext ?_⟩ + exact hentry + +noncomputable def FewTimeCover.originEmbedding {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + {intervals : List AdversaryCacheEntry} + (source : cover.PrecachedEntries trace hlog ↪ Fin intervals.length) : + cover.entries ↪ Fin signingLog.length ⊕ Fin intervals.length := + mixedOriginEmbedding (cover.EntryDigestPrecached trace hlog) + cover.logIndexEmbedding source + +theorem FewTimeCover.originEmbedding_apply_prehit {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + {intervals : List AdversaryCacheEntry} + (source : cover.PrecachedEntries trace hlog ↪ Fin intervals.length) + (entry : cover.entries) + (hprehit : cover.EntryDigestPrecached trace hlog entry) : + cover.originEmbedding trace hlog source entry = .inr (source ⟨entry, hprehit⟩) := by + exact mixedOriginEmbedding_apply_prehit _ _ _ entry hprehit + +theorem FewTimeCover.originEmbedding_apply_fresh {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + {intervals : List AdversaryCacheEntry} + (source : cover.PrecachedEntries trace hlog ↪ Fin intervals.length) + (entry : cover.entries) + (hfresh : ¬ cover.EntryDigestPrecached trace hlog entry) : + cover.originEmbedding trace hlog source entry = .inl (cover.logIndex entry) := by + exact mixedOriginEmbedding_apply_fresh _ _ _ entry hfresh + +theorem FewTimeCover.selected_entries_have_injective_origins + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.1.AgreesWithFn f) + (index : Index) (targetLeaves : DigestTree → FtsLeaf) + (cover : FewTimeCover f result.2.1 + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.signing.toSigningLog index targetLeaves) : + ∃ (origin : cover.entries ↪ + Fin result.2.2.signing.toSigningLog.length ⊕ Fin result.2.2.intervals.length) + (source : cover.PrecachedEntries result.2.2.signing rfl → + Fin result.2.2.intervals.length) + (output : cover.PrecachedEntries result.2.2.signing rfl → HashOutput), + Function.Injective source + ∧ (∀ entry (hprehit : cover.EntryDigestPrecached result.2.2.signing rfl entry), + origin entry = .inr (source ⟨entry, hprehit⟩)) + ∧ (∀ entry, ¬ cover.EntryDigestPrecached result.2.2.signing rfl entry → + origin entry = .inl (cover.logIndex entry)) + ∧ ∀ entry, + (result.2.2.intervals.get (source entry)).input = + .inl (.inr (cover.entryDigestInput entry.1)) + ∧ (result.2.2.intervals.get (source entry)).initialCache + (cover.entryDigestInput entry.1) = none + ∧ (output entry, (result.2.2.intervals.get (source entry)).finalCache) ∈ support + ((randomOracle (cover.entryDigestInput entry.1)).run + (result.2.2.intervals.get (source entry)).initialCache) + ∧ signAttemptResultOfOutput (output entry) ≠ none + ∧ hashOutputFewTimeView (output entry) = cover.entryView entry.1 := by + classical + obtain ⟨source, _selected, output, hsourceInjective, hsource⟩ := + cover.precached_entries_have_injective_fresh_direct_view_sources adversary parameter + otsSecret ftsSecret result hresult f hf index targetLeaves + let sourceEmbedding : cover.PrecachedEntries result.2.2.signing rfl ↪ + Fin result.2.2.intervals.length := ⟨source, hsourceInjective⟩ + let origin := cover.originEmbedding result.2.2.signing rfl sourceEmbedding + refine ⟨origin, source, output, hsourceInjective, ?_, ?_, ?_⟩ + · intro entry hprehit + exact cover.originEmbedding_apply_prehit result.2.2.signing rfl sourceEmbedding + entry hprehit + · intro entry hfresh + exact cover.originEmbedding_apply_fresh result.2.2.signing rfl sourceEmbedding entry hfresh + · intro entry + exact (hsource entry).2.2.2 + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimePadding.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimePadding.lean new file mode 100644 index 00000000..a2676b82 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimePadding.lean @@ -0,0 +1,780 @@ +import SphincsSecurity.Proof.FewTimeViewTrace +import VCVio.OracleComp.QueryTracking.RandomOracle.DeferredSampling + +/-! +# Padding adaptive few-time view sequences + +A run may make fewer than the allowed number of signing queries. Extending its view sequence with +independent unused coordinates embeds every coverage pattern into the fixed signature-limit space. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +noncomputable local instance {α : Type} [Fintype α] [Nonempty α] : SampleableType α := + SampleableType.ofFintype α + +noncomputable def uniformSnocList (α : Type) [SampleableType α] : Nat → ProbComp (List α) + | 0 => pure [] + | count + 1 => do + let prior ← uniformSnocList α count + let next ← $ᵗ α + pure (prior ++ [next]) + +theorem evalDist_independent_uniform_pair + {α β : Type} [Fintype α] [Fintype β] + [SampleableType α] [SampleableType β] : + 𝒟[(do + let left ← $ᵗ α + let right ← $ᵗ β + pure (left, right))] = + 𝒟[($ᵗ (α × β) : ProbComp (α × β))] := by + apply SPMF.ext + intro target + rw [show (do + let left ← $ᵗ α + let right ← $ᵗ β + pure (left, right)) = Prod.mk <$> ($ᵗ α) <*> ($ᵗ β) by + simp [monad_norm]] + change Pr[= target | Prod.mk <$> ($ᵗ α) <*> ($ᵗ β)] = + Pr[= target | $ᵗ (α × β)] + rw [probOutput_seq_map_prod_mk_eq_mul, probOutput_uniformSample, + probOutput_uniformSample, probOutput_uniformSample, Fintype.card_prod, + Nat.cast_mul, + ENNReal.mul_inv (Or.inr (ENNReal.natCast_ne_top _)) + (Or.inl (ENNReal.natCast_ne_top _))] + +theorem uniformSnocList_append (α : Type) [SampleableType α] + (firstLength secondLength : Nat) : + (do + let first ← uniformSnocList α firstLength + let second ← uniformSnocList α secondLength + pure (first ++ second)) = + uniformSnocList α (firstLength + secondLength) := by + induction secondLength with + | zero => simp [uniformSnocList] + | succ secondLength ih => + simp [uniformSnocList, bind_assoc, ← ih, List.append_assoc] + +def finInitLastEquiv (α : Type) (count : Nat) : + ((Fin count → α) × α) ≃ (Fin (count + 1) → α) where + toFun pair := Fin.lastCases pair.2 pair.1 + invFun values := (fun index => values index.castSucc, values (Fin.last count)) + left_inv pair := by + apply Prod.ext + · funext index + simp + · simp + right_inv values := by + funext index + cases index using Fin.lastCases <;> simp + +set_option maxRecDepth 100000 in +theorem evalDist_uniformSnocList_eq_uniformFunction + (α : Type) [Fintype α] [SampleableType α] (count : Nat) : + 𝒟[uniformSnocList α count] = + 𝒟[List.ofFn <$> ($ᵗ (Fin count → α) : ProbComp (Fin count → α))] := by + induction count with + | zero => + rw [uniformSnocList] + symm + rw [map_eq_bind_pure_comp] + calc + 𝒟[($ᵗ (Fin 0 → α) : ProbComp (Fin 0 → α)) >>= fun values => + pure (List.ofFn values)] = + 𝒟[($ᵗ (Fin 0 → α) : ProbComp (Fin 0 → α)) >>= fun _ => pure []] := by + apply evalDist_bind_congr + intro values _ + have hnil : List.ofFn values = [] := + List.eq_nil_of_length_eq_zero (by simp) + rw [hnil] + _ = 𝒟[pure []] := + OracleComp.DeferredSampling.evalDist_bind_const_neverFails + ($ᵗ (Fin 0 → α)) (probFailure_eq_zero' inferInstance) (pure []) + | succ count ih => + rw [uniformSnocList] + calc + _ = 𝒟[(List.ofFn <$> ($ᵗ (Fin count → α) : ProbComp (Fin count → α))) >>= + fun prior => ($ᵗ α) >>= fun next => pure (prior ++ [next])] := by + rw [evalDist_bind, ih, ← evalDist_bind] + _ = 𝒟[List.ofFn <$> (finInitLastEquiv α count <$> (do + let prior ← $ᵗ (Fin count → α) + let next ← $ᵗ α + pure (prior, next)))] := by + congr 1 + simp only [map_eq_bind_pure_comp, bind_assoc, pure_bind, + Function.comp_apply] + apply bind_congr + intro prior + apply bind_congr + intro next + congr 1 + rw [List.ofFn_succ'] + simp [finInitLastEquiv] + _ = 𝒟[List.ofFn <$> (finInitLastEquiv α count <$> + ($ᵗ ((Fin count → α) × α) : ProbComp ((Fin count → α) × α)))] := by + rw [evalDist_map, evalDist_map, evalDist_independent_uniform_pair, + ← evalDist_map, ← evalDist_map] + _ = 𝒟[List.ofFn <$> + ($ᵗ (Fin (count + 1) → α) : ProbComp (Fin (count + 1) → α))] := by + rw [evalDist_map] + rw [evalDist_map_bijective_uniform_cross + (α := (Fin count → α) × α) (β := Fin (count + 1) → α) + (finInitLastEquiv α count) (finInitLastEquiv α count).bijective] + rw [← evalDist_map] + +theorem uniformSnocList_support_length (α : Type) [SampleableType α] + (count : Nat) (values : List α) + (hmem : values ∈ support (uniformSnocList α count)) : values.length = count := by + induction count generalizing values with + | zero => + simp only [uniformSnocList, support_pure, Set.mem_singleton_iff] at hmem + subst values + rfl + | succ count ih => + rw [uniformSnocList, mem_support_bind_iff] at hmem + obtain ⟨prior, hprior, hrest⟩ := hmem + rw [mem_support_bind_iff] at hrest + obtain ⟨next, _, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst values + simp [ih prior hprior] + +inductive CompletesOptionViews : + List (Option FewTimeView) → List FewTimeView → Prop + | nil : CompletesOptionViews [] [] + | none {options views} (view : FewTimeView) + (hrest : CompletesOptionViews options views) : + CompletesOptionViews (none :: options) (view :: views) + | some {options views} (view : FewTimeView) + (hrest : CompletesOptionViews options views) : + CompletesOptionViews (some view :: options) (view :: views) + +theorem CompletesOptionViews.length_eq {options : List (Option FewTimeView)} + {views : List FewTimeView} (hcomplete : CompletesOptionViews options views) : + views.length = options.length := by + induction hcomplete <;> simp_all + +noncomputable def completeOptionViews : + List (Option FewTimeView) → ProbComp (List FewTimeView) + | [] => pure [] + | none :: options => do + let view ← $ᵗ FewTimeView + let views ← completeOptionViews options + pure (view :: views) + | some view :: options => do + let views ← completeOptionViews options + pure (view :: views) + +theorem completeOptionViews_support (options : List (Option FewTimeView)) + (views : List FewTimeView) (hmem : views ∈ support (completeOptionViews options)) : + CompletesOptionViews options views := by + induction options generalizing views with + | nil => + simp only [completeOptionViews, support_pure, Set.mem_singleton_iff] at hmem + subst views + exact .nil + | cons option options ih => + cases option with + | none => + rw [completeOptionViews, mem_support_bind_iff] at hmem + obtain ⟨view, _, hrest⟩ := hmem + rw [mem_support_bind_iff] at hrest + obtain ⟨rest, hrest, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst views + exact .none view (ih rest hrest) + | some view => + rw [completeOptionViews, mem_support_bind_iff] at hmem + obtain ⟨rest, hrest, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst views + exact .some view (ih rest hrest) + +theorem CompletesOptionViews.getElem?_eq_of_getElem?_eq_some + {options : List (Option FewTimeView)} {views : List FewTimeView} + (hcomplete : CompletesOptionViews options views) (position : Nat) + (view : FewTimeView) (hget : options[position]? = Option.some (Option.some view)) : + views[position]? = Option.some view := by + induction hcomplete generalizing position with + | nil => simp at hget + | none head hrest ih => + cases position with + | zero => simp at hget + | succ position => exact ih position (by simpa using hget) + | some head hrest ih => + cases position with + | zero => simpa using hget + | succ position => exact ih position (by simpa using hget) + +noncomputable def completeAndPadViews (limit : Nat) + (options : List (Option FewTimeView)) : ProbComp (List FewTimeView) := do + let views ← completeOptionViews options + let padding ← uniformSnocList FewTimeView (limit - options.length) + pure (views ++ padding) + +theorem completeAndPadViews_support (limit : Nat) + (options : List (Option FewTimeView)) (values : List FewTimeView) + (hmem : values ∈ support (completeAndPadViews limit options)) : + ∃ views padding, + CompletesOptionViews options views + ∧ padding.length = limit - options.length + ∧ values = views ++ padding := by + rw [completeAndPadViews, mem_support_bind_iff] at hmem + obtain ⟨views, hviews, hrest⟩ := hmem + rw [mem_support_bind_iff] at hrest + obtain ⟨padding, hpadding, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + exact ⟨views, padding, completeOptionViews_support options views hviews, + uniformSnocList_support_length FewTimeView _ padding hpadding, hpure⟩ + +theorem completeAndPadViews_support_length (limit : Nat) + (options : List (Option FewTimeView)) (hle : options.length ≤ limit) + (values : List FewTimeView) + (hmem : values ∈ support (completeAndPadViews limit options)) : + values.length = limit := by + obtain ⟨views, padding, hcomplete, hpadding, rfl⟩ := + completeAndPadViews_support limit options values hmem + rw [List.length_append, hcomplete.length_eq, hpadding, Nat.add_sub_of_le hle] + +theorem evalDist_bind_completeAndPadViews_eq_uniformSnocList + (mx : ProbComp (List (Option FewTimeView))) (count limit : Nat) + (hle : count ≤ limit) + (hlength : ∀ options ∈ support mx, options.length = count) + (hcomplete : 𝒟[mx >>= completeOptionViews] = + 𝒟[uniformSnocList FewTimeView count]) : + 𝒟[mx >>= completeAndPadViews limit] = + 𝒟[uniformSnocList FewTimeView limit] := by + calc + 𝒟[mx >>= completeAndPadViews limit] = + 𝒟[(mx >>= completeOptionViews) >>= fun views => + uniformSnocList FewTimeView (limit - count) >>= fun padding => + pure (views ++ padding)] := by + simp only [bind_assoc] + apply evalDist_bind_congr + intro options hoptions + rw [completeAndPadViews] + rw [hlength options hoptions] + _ = 𝒟[uniformSnocList FewTimeView count >>= fun views => + uniformSnocList FewTimeView (limit - count) >>= fun padding => + pure (views ++ padding)] := by + rw [evalDist_bind, hcomplete, ← evalDist_bind] + _ = 𝒟[uniformSnocList FewTimeView + (count + (limit - count))] := by + rw [uniformSnocList_append] + _ = 𝒟[uniformSnocList FewTimeView limit] := by + rw [Nat.add_sub_of_le hle] + +def listToFunction (count : Nat) (values : List FewTimeView) : Fin count → FewTimeView := + fun position => values.getD position.val default + +@[simp] +theorem listToFunction_ofFn (values : Fin count → FewTimeView) : + listToFunction count (List.ofFn values) = values := by + funext position + simp [listToFunction, List.getD] + +theorem listToFunction_eq_get_of_length (values : List FewTimeView) + (hlength : values.length = count) : + listToFunction count values = fun position => + values.get (Fin.cast hlength.symm position) := by + funext position + simp [listToFunction, List.getD, hlength, position.isLt] + +noncomputable def completeOptionView : Option FewTimeView → ProbComp FewTimeView + | none => $ᵗ FewTimeView + | some view => pure view + +theorem completeOptionView_support_some (view completed : FewTimeView) + (hmem : completed ∈ support (completeOptionView (some view))) : completed = view := by + simpa [completeOptionView] using hmem + +noncomputable def gameAfterSecretsWithPaddedViews (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ProbComp (((Digest × Forgery × Bool) × ViewedFullTraceState) × + ((Fin signatureLimit → FewTimeView) × FewTimeView)) := do + let result ← gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + let values ← completeAndPadViews signatureLimit result.2.views + let target ← completeOptionView result.2.targetView + pure (result, (listToFunction signatureLimit values, target)) + +theorem gameAfterSecretsWithPaddedViews_support + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : ((Digest × Forgery × Bool) × ViewedFullTraceState) × + ((Fin signatureLimit → FewTimeView) × FewTimeView)) + (hmem : result ∈ support + (gameAfterSecretsWithPaddedViews adversary parameter otsSecret ftsSecret)) : + ∃ values, + result.1 ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret) + ∧ values ∈ support (completeAndPadViews signatureLimit result.1.2.views) + ∧ result.2.1 = listToFunction signatureLimit values + ∧ result.2.2 ∈ support (completeOptionView result.1.2.targetView) := by + rw [gameAfterSecretsWithPaddedViews, mem_support_bind_iff] at hmem + obtain ⟨viewedResult, hviewed, hrest⟩ := hmem + rw [mem_support_bind_iff] at hrest + obtain ⟨values, hvalues, hrest⟩ := hrest + rw [mem_support_bind_iff] at hrest + obtain ⟨target, htarget, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + exact ⟨values, hviewed, hvalues, rfl, htarget⟩ + +theorem gameAfterSecretsWithPaddedViews_projection + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + 𝒟[(fun result => result.1) <$> + gameAfterSecretsWithPaddedViews adversary parameter otsSecret ftsSecret] = + 𝒟[gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + rw [gameAfterSecretsWithPaddedViews, map_eq_bind_pure_comp, bind_assoc] + calc + _ = 𝒟[gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret >>= + fun result => pure result] := by + apply evalDist_bind_congr + intro result _ + have hnormalize : + ((do + let values ← completeAndPadViews signatureLimit result.2.views + let target ← completeOptionView result.2.targetView + pure (result, (listToFunction signatureLimit values, target))) : + ProbComp (((Digest × Forgery × Bool) × ViewedFullTraceState) × + ((Fin signatureLimit → FewTimeView) × FewTimeView))) >>= + (pure ∘ fun padded => padded.1) = + (do + let _ ← completeAndPadViews signatureLimit result.2.views + let _ ← completeOptionView result.2.targetView + pure result) := by + simp [bind_assoc] + rw [hnormalize] + calc + 𝒟[completeAndPadViews signatureLimit result.2.views >>= fun _ => + completeOptionView result.2.targetView >>= fun _ => pure result] = + 𝒟[completeOptionView result.2.targetView >>= fun _ => pure result] := by + exact OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (completeAndPadViews signatureLimit result.2.views) + (probFailure_eq_zero' inferInstance) _ + _ = 𝒟[pure result] := by + exact OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (completeOptionView result.2.targetView) + (probFailure_eq_zero' inferInstance) _ + _ = _ := by simp + +theorem evalDist_uniformPaddedSample (count : Nat) : + 𝒟[(do + let values ← uniformSnocList FewTimeView count + let target ← $ᵗ FewTimeView + pure (listToFunction count values, target))] = + 𝒟[($ᵗ ((Fin count → FewTimeView) × FewTimeView) : + ProbComp ((Fin count → FewTimeView) × FewTimeView))] := by + calc + _ = 𝒟[(List.ofFn <$> ($ᵗ (Fin count → FewTimeView) : + ProbComp (Fin count → FewTimeView))) >>= fun values => + ($ᵗ FewTimeView) >>= fun target => + pure (listToFunction count values, target)] := by + rw [evalDist_bind, evalDist_uniformSnocList_eq_uniformFunction, ← evalDist_bind] + _ = 𝒟[(do + let values ← $ᵗ (Fin count → FewTimeView) + let target ← $ᵗ FewTimeView + pure (values, target))] := by + simp [map_eq_bind_pure_comp, bind_assoc] + _ = _ := evalDist_independent_uniform_pair + +noncomputable def uniformPaddedSample (count : Nat) : + ProbComp ((Fin count → FewTimeView) × FewTimeView) := do + let values ← uniformSnocList FewTimeView count + let target ← $ᵗ FewTimeView + pure (listToFunction count values, target) + +theorem probEvent_someFewTimePatternHit_uniformPadded_le : + Pr[SomeFewTimePatternHit signatureLimit | + uniformPaddedSample signatureLimit] ≤ + 1 / ((2 ^ 122 : Nat) : ℝ≥0∞) := by + rw [probEvent_congr' (fun _ _ => Iff.rfl) + (show 𝒟[uniformPaddedSample signatureLimit] = _ by + exact evalDist_uniformPaddedSample signatureLimit)] + simpa only [one_div] using probEvent_someFewTimePatternHit_le le_rfl + +def SomeFewTimePatternHitCandidates (signatures candidates : Nat) + (sample : (Fin signatures → FewTimeView) × (Fin candidates → FewTimeView)) : Prop := + ∃ candidate, SomeFewTimePatternHit signatures (sample.1, sample.2 candidate) + +noncomputable instance (signatures candidates : Nat) : + DecidablePred (SomeFewTimePatternHitCandidates signatures candidates) := + fun sample => Classical.propDecidable + (SomeFewTimePatternHitCandidates signatures candidates sample) + +noncomputable def uniformCandidateSample (signatures candidates : Nat) : + ProbComp ((Fin signatures → FewTimeView) × (Fin candidates → FewTimeView)) := do + let views ← $ᵗ (Fin signatures → FewTimeView) + let targets ← $ᵗ (Fin candidates → FewTimeView) + pure (views, targets) + +theorem evalDist_uniformCandidateFunctionEval {candidates : Nat} + (candidate : Fin candidates) : + 𝒟[(fun targets : Fin candidates → FewTimeView => targets candidate) <$> + ($ᵗ (Fin candidates → FewTimeView) : + ProbComp (Fin candidates → FewTimeView))] = + 𝒟[($ᵗ FewTimeView : ProbComp FewTimeView)] := by + let embed : Unit → Fin candidates := fun _ => candidate + have hembed : Function.Injective embed := by + intro left right _ + cases left + cases right + rfl + let evaluate : (Unit → FewTimeView) → FewTimeView := fun table => table () + have hevaluate : Function.Bijective evaluate := by + constructor + · intro left right heq + funext input + cases input + exact heq + · intro value + exact ⟨fun _ => value, rfl⟩ + have hrestrict : + 𝒟[(fun table : Fin candidates → FewTimeView => table ∘ embed) <$> + ($ᵗ (Fin candidates → FewTimeView) : + ProbComp (Fin candidates → FewTimeView))] = + 𝒟[($ᵗ (Unit → FewTimeView) : ProbComp (Unit → FewTimeView))] := by + simpa only [bind_pure_comp] using + evalDist_uniformSample_map_comp_injective (R := FewTimeView) hembed + have hmarginal : + 𝒟[evaluate <$> ((fun table : Fin candidates → FewTimeView => table ∘ embed) <$> + ($ᵗ (Fin candidates → FewTimeView) : + ProbComp (Fin candidates → FewTimeView)))] = + 𝒟[($ᵗ FewTimeView : ProbComp FewTimeView)] := by + rw [evalDist_map, hrestrict, ← evalDist_map] + exact evalDist_map_bijective_uniform_cross + (α := Unit → FewTimeView) (β := FewTimeView) evaluate hevaluate + simpa [map_eq_bind_pure_comp, bind_assoc, evaluate, embed] using hmarginal + +theorem evalDist_uniformCandidateSample_target (signatures candidates : Nat) + (candidate : Fin candidates) : + 𝒟[(fun sample => (sample.1, sample.2 candidate)) <$> + uniformCandidateSample signatures candidates] = + 𝒟[($ᵗ ((Fin signatures → FewTimeView) × FewTimeView) : + ProbComp ((Fin signatures → FewTimeView) × FewTimeView))] := by + letI : Nonempty (Fin candidates) := ⟨candidate⟩ + calc + _ = 𝒟[(do + let views ← $ᵗ (Fin signatures → FewTimeView) + let target ← $ᵗ FewTimeView + pure (views, target))] := by + rw [uniformCandidateSample] + simp only [map_eq_bind_pure_comp, bind_assoc, pure_bind, Function.comp_apply] + apply evalDist_bind_congr + intro views _ + change 𝒟[(fun targets : Fin candidates → FewTimeView => + (views, targets candidate)) <$> + ($ᵗ (Fin candidates → FewTimeView) : + ProbComp (Fin candidates → FewTimeView))] = + 𝒟[(fun target : FewTimeView => (views, target)) <$> + ($ᵗ FewTimeView : ProbComp FewTimeView)] + calc + _ = 𝒟[(fun target : FewTimeView => (views, target)) <$> + ((fun targets : Fin candidates → FewTimeView => targets candidate) <$> + ($ᵗ (Fin candidates → FewTimeView) : + ProbComp (Fin candidates → FewTimeView)))] := by + simp [Functor.map_map] + _ = _ := by + rw [evalDist_map] + rw [evalDist_uniformCandidateFunctionEval candidate, ← evalDist_map] + _ = _ := evalDist_independent_uniform_pair + +theorem probEvent_someFewTimePatternHitCandidates_uniform_le + (signatures candidates : Nat) (hsignatures : signatures ≤ signatureLimit) : + Pr[SomeFewTimePatternHitCandidates signatures candidates | + uniformCandidateSample signatures candidates] ≤ + candidates * ((2 ^ 122 : Nat) : ℝ≥0∞)⁻¹ := by + classical + let sampler := uniformCandidateSample signatures candidates + calc + Pr[SomeFewTimePatternHitCandidates signatures candidates | sampler] = + Pr[fun sample => ∃ candidate ∈ (Finset.univ : Finset (Fin candidates)), + SomeFewTimePatternHit signatures (sample.1, sample.2 candidate) | sampler] := by + congr 1 + funext sample + simp [SomeFewTimePatternHitCandidates] + _ ≤ ∑ candidate ∈ (Finset.univ : Finset (Fin candidates)), + Pr[fun sample => SomeFewTimePatternHit signatures + (sample.1, sample.2 candidate) | sampler] := + probEvent_exists_finset_le_sum Finset.univ sampler + (fun candidate sample => SomeFewTimePatternHit signatures + (sample.1, sample.2 candidate)) + _ = ∑ _candidate ∈ (Finset.univ : Finset (Fin candidates)), + Pr[SomeFewTimePatternHit signatures | + ($ᵗ ((Fin signatures → FewTimeView) × FewTimeView) : + ProbComp ((Fin signatures → FewTimeView) × FewTimeView))] := by + apply Finset.sum_congr rfl + intro candidate _ + calc + Pr[fun sample => SomeFewTimePatternHit signatures + (sample.1, sample.2 candidate) | sampler] = + Pr[SomeFewTimePatternHit signatures | + (fun sample => (sample.1, sample.2 candidate)) <$> sampler] := by + rw [probEvent_map] + rfl + _ = _ := probEvent_congr' (fun _ _ => Iff.rfl) (by + simpa [sampler] using + evalDist_uniformCandidateSample_target signatures candidates candidate) + _ ≤ ∑ _candidate ∈ (Finset.univ : Finset (Fin candidates)), + ((2 ^ 122 : Nat) : ℝ≥0∞)⁻¹ := by + apply Finset.sum_le_sum + intro candidate _ + exact probEvent_someFewTimePatternHit_le hsignatures + _ = candidates * ((2 ^ 122 : Nat) : ℝ≥0∞)⁻¹ := by + rw [Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul] + +theorem completeAndPadViews_getElem?_eq_of_some + (limit : Nat) (options : List (Option FewTimeView)) + (values : List FewTimeView) + (hmem : values ∈ support (completeAndPadViews limit options)) + (position : Nat) (view : FewTimeView) + (hget : options[position]? = Option.some (Option.some view)) : + values[position]? = Option.some view := by + obtain ⟨completed, padding, hcomplete, _, rfl⟩ := + completeAndPadViews_support limit options values hmem + have hcompleted := hcomplete.getElem?_eq_of_getElem?_eq_some position view hget + have hlt : position < completed.length := by + rw [hcomplete.length_eq] + exact List.getElem?_eq_some_iff.1 hget |>.1 + rw [List.getElem?_append_left hlt] + exact hcompleted + +def finCastLEEmbedding {small large : Nat} (hle : small ≤ large) : Fin small ↪ Fin large where + toFun := Fin.castLE hle + inj' := by + intro left right heq + apply Fin.ext + exact congrArg (fun position : Fin large => position.val) heq + +noncomputable def FewTimePattern.pad {small large distinct : Nat} + (pattern : FewTimePattern small distinct) (hle : small ≤ large) : + FewTimePattern large distinct where + selected := pattern.selected.map (finCastLEEmbedding hle) + card_selected := by rw [Finset.card_map, pattern.card_selected] + assignment := fun tree => + ⟨finCastLEEmbedding hle (pattern.assignment tree).1, + Finset.mem_map.2 ⟨(pattern.assignment tree).1, + (pattern.assignment tree).2, rfl⟩⟩ + +theorem FewTimePattern.pad_hit {small large distinct : Nat} + (pattern : FewTimePattern small distinct) (hle : small ≤ large) + (smallViews : Fin small → FewTimeView) (largeViews : Fin large → FewTimeView) + (targetView : FewTimeView) + (hagrees : ∀ position, position ∈ pattern.selected → + largeViews (finCastLEEmbedding hle position) = smallViews position) + (hhit : pattern.Hit (smallViews, targetView)) : + (pattern.pad hle).Hit (largeViews, targetView) := by + constructor + · intro selected + obtain ⟨position, hposition, heq⟩ := Finset.mem_map.1 selected.2 + have hsmall := hhit.1 (⟨position, hposition⟩ : pattern.selected) + change (largeViews selected.1).1 = targetView.1 + rw [← heq, hagrees position hposition] + exact hsmall + · intro tree + change targetView.2 tree = + (largeViews (finCastLEEmbedding hle (pattern.assignment tree).1)).2 tree + rw [hagrees (pattern.assignment tree).1 (pattern.assignment tree).2] + exact hhit.2 tree + +def optionListViews (options : List (Option FewTimeView)) : + Fin options.length → FewTimeView := + fun position => (options.get position).getD default + +def FewTimePattern.HitOptions {signatures distinct : Nat} + (pattern : FewTimePattern signatures distinct) + (options : List (Option FewTimeView)) (hlength : options.length = signatures) + (targetView : FewTimeView) : Prop := + pattern.Hit + (fun position => optionListViews options (Fin.cast hlength.symm position), targetView) + ∧ ∀ position, position ∈ pattern.selected → + ∃ view, options.get (Fin.cast hlength.symm position) = some view + +def SomeFewTimePatternHitOptions (signatures : Nat) + (options : List (Option FewTimeView)) (hlength : options.length = signatures) + (targetView : FewTimeView) : Prop := + ∃ distinct ∈ Finset.Icc 1 14, ∃ pattern : FewTimePattern signatures distinct, + pattern.HitOptions options hlength targetView + +noncomputable instance (signatures : Nat) (options : List (Option FewTimeView)) + (hlength : options.length = signatures) : + DecidablePred (SomeFewTimePatternHitOptions signatures options hlength) := + fun _ => Classical.propDecidable _ + +theorem SomeFewTimePatternHitOptions.completeAndPad + (signatures : Nat) (options : List (Option FewTimeView)) + (hlength : options.length = signatures) (targetView : FewTimeView) + (limit : Nat) (hle : signatures ≤ limit) + (hhit : SomeFewTimePatternHitOptions signatures options hlength targetView) + (values : List FewTimeView) + (hmem : values ∈ support (completeAndPadViews limit options)) : + let hpaddedLength := completeAndPadViews_support_length limit options + (hlength.le.trans hle) values hmem + SomeFewTimePatternHit limit + ((fun position => values.get (Fin.cast hpaddedLength.symm position)), targetView) := by + dsimp only + obtain ⟨distinct, hdistinct, pattern, hpattern, hselected⟩ := hhit + let hpaddedLength := completeAndPadViews_support_length limit options + (hlength.le.trans hle) values hmem + let largeViews : Fin limit → FewTimeView := + fun position => values.get (Fin.cast hpaddedLength.symm position) + let smallViews : Fin signatures → FewTimeView := + fun position => optionListViews options (Fin.cast hlength.symm position) + have hagrees : ∀ position, position ∈ pattern.selected → + largeViews (finCastLEEmbedding hle position) = smallViews position := by + intro position hposition + obtain ⟨view, hoption⟩ := hselected position hposition + let optionPosition : Fin options.length := Fin.cast hlength.symm position + have hoption0 : options.get optionPosition = Option.some view := hoption + have hoption' : options[position.val]? = Option.some (Option.some view) := by + have hpositionLt : position.val < options.length := by + rw [hlength] + exact position.isLt + rw [List.getElem?_eq_getElem hpositionLt] + change Option.some (options.get optionPosition) = _ + exact congrArg Option.some hoption0 + have hvalue' := completeAndPadViews_getElem?_eq_of_some limit options values hmem + position.val view hoption' + have hvalueLt : position.val < values.length := by + rw [hpaddedLength] + exact lt_of_lt_of_le position.isLt hle + rw [List.getElem?_eq_getElem hvalueLt] at hvalue' + have hvalue : values[position.val] = view := Option.some.inj hvalue' + change values[position.val] = (options.get optionPosition).getD default + rw [hvalue, hoption0] + rfl + exact ⟨distinct, hdistinct, pattern.pad hle, + pattern.pad_hit hle smallViews largeViews targetView hagrees hpattern⟩ + +theorem SomeFewTimePatternHit.pad {small large : Nat} (hle : small ≤ large) + (smallViews : Fin small → FewTimeView) (largeViews : Fin large → FewTimeView) + (targetView : FewTimeView) + (hagrees : ∀ position, largeViews (finCastLEEmbedding hle position) = smallViews position) + (hhit : SomeFewTimePatternHit small (smallViews, targetView)) : + SomeFewTimePatternHit large (largeViews, targetView) := by + obtain ⟨distinct, hdistinct, pattern, hpattern⟩ := hhit + exact ⟨distinct, hdistinct, pattern.pad hle, + pattern.pad_hit hle smallViews largeViews targetView (fun position _ => hagrees position) + hpattern⟩ + +theorem gameAfterSecretsWithViewTrace_properLeak_hitOptions + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hmem : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest parameter result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) = digest) + (hproper : ProperFewTimeLeak f result.2.cache + (⟨parameter, result.1.1, otsSecret, ftsSecret⟩ : SecretKey) + result.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest)) : + SomeFewTimePatternHitOptions result.2.trace.signing.toSigningLog.length result.2.views + (by + rw [← (gameAfterSecretsWithViewTrace_support_validViews adversary parameter + otsSecret ftsSecret result hmem).length_eq] + simp [SigningCacheTrace.toSigningLog]) + (result.2.targetView.getD default) := by + let cover := hproper.1.cover + let hvalid := gameAfterSecretsWithViewTrace_support_validViews adversary parameter + otsSecret ftsSecret result hmem + have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hmem, rfl⟩ + have hinvariants := gameAfterSecretsWithFullTrace_support_invariants adversary parameter + otsSecret ftsSecret (result.1, result.2.base) hbase + have htarget := gameAfterSecretsWithViewTrace_targetView_eq adversary parameter otsSecret + ftsSecret result hmem f hf digest hdigest + have hlength : result.2.views.length = result.2.trace.signing.toSigningLog.length := by + rw [← hvalid.length_eq] + simp [SigningCacheTrace.toSigningLog] + refine ⟨cover.entries.card, Finset.mem_Icc.2 + ⟨cover.entries_card_pos, cover.entries_card_le_trees⟩, cover.pattern, ?_, ?_⟩ + · have hhit := cover.viewedPatternHit result.2 rfl hvalid hinvariants.2.1 hf + rw [htarget] + change cover.pattern.Hit + ((fun position => optionListViews result.2.views (Fin.cast hlength.symm position)), + fewTimeTargetView (digestIndex digest) (digestLeaves digest)) + have hfunctions : + (fun position => optionListViews result.2.views (Fin.cast hlength.symm position)) = + hvalid.signingViewsForLog rfl := by + funext position + rfl + rw [hfunctions] + exact hhit + · intro position hposition + obtain ⟨entry, _, hentry⟩ := Finset.mem_image.1 hposition + refine ⟨cover.entryView entry, ?_⟩ + have hoption := cover.signingOptionViews_traceIndex_eq_entryView result.2 rfl hvalid + hinvariants.2.1 hf entry + change hvalid.signingOptionViewsForLog rfl position = some (cover.entryView entry) + rw [← hentry] + change hvalid.signingOptionViews + (cover.traceIndex result.2.trace.signing rfl entry) = some (cover.entryView entry) + exact hoption + +theorem gameAfterSecretsWithPaddedViews_properLeak_patternHit + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : ((Digest × Forgery × Bool) × ViewedFullTraceState) × + ((Fin signatureLimit → FewTimeView) × FewTimeView)) + (hmem : result ∈ support + (gameAfterSecretsWithPaddedViews adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.1.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest parameter result.1.1.1 result.1.1.2.1.message + result.1.1.2.1.signature.randomness) = digest) + (hvalidTranscript : SigningTranscript.Valid result.1.2.trace.signing.toSigningLog) + (hproper : ProperFewTimeLeak f result.1.2.cache + (⟨parameter, result.1.1.1, otsSecret, ftsSecret⟩ : SecretKey) + result.1.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest)) : + SomeFewTimePatternHit signatureLimit result.2 := by + obtain ⟨values, hviewed, hvalues, hresultViews, hresultTarget⟩ := + gameAfterSecretsWithPaddedViews_support adversary parameter otsSecret ftsSecret result hmem + have htarget := gameAfterSecretsWithViewTrace_targetView_eq adversary parameter otsSecret + ftsSecret result.1 hviewed f hf digest hdigest + have hpaddedTarget : result.2.2 = + fewTimeTargetView (digestIndex digest) (digestLeaves digest) := by + rw [htarget] at hresultTarget + exact completeOptionView_support_some _ _ hresultTarget + have hhitOptions := gameAfterSecretsWithViewTrace_properLeak_hitOptions adversary parameter + otsSecret ftsSecret result.1 hviewed f hf digest hdigest hproper + have htargetGetD : result.1.2.targetView.getD default = + fewTimeTargetView (digestIndex digest) (digestLeaves digest) := by + rw [htarget] + rfl + rw [htargetGetD] at hhitOptions + have hviewLength := gameAfterSecretsWithViewTrace_support_validViews adversary parameter + otsSecret ftsSecret result.1 hviewed |>.length_eq + have hoptionsLength : result.1.2.views.length = + result.1.2.trace.signing.toSigningLog.length := by + rw [← hviewLength] + simp [SigningCacheTrace.toSigningLog] + have hle : result.1.2.trace.signing.toSigningLog.length ≤ signatureLimit := + hvalidTranscript + have hhit := hhitOptions.completeAndPad + result.1.2.trace.signing.toSigningLog.length result.1.2.views hoptionsLength + (fewTimeTargetView (digestIndex digest) (digestLeaves digest)) signatureLimit hle + values hvalues + have hpaddedLength := completeAndPadViews_support_length signatureLimit result.1.2.views + (hoptionsLength.le.trans hle) values hvalues + change SomeFewTimePatternHit signatureLimit (result.2.1, result.2.2) + rw [hresultViews, hpaddedTarget] + rw [listToFunction_eq_get_of_length values hpaddedLength] + exact hhit + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeParametricCount.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeParametricCount.lean new file mode 100644 index 00000000..85a38936 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeParametricCount.lean @@ -0,0 +1,118 @@ +import SphincsSecurity.Proof.FewTime125Count + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +set_option exponentiation.threshold 600 + +theorem weightedFewTime_scaled_sum_le {signatures numerator shift budget : Nat} + (hsignatures : signatures ≤ signatureLimit) + (hcertificate : (∑ d ∈ Finset.Icc 1 14, + (d + 1).ascFactorial (14 - d) * 2 ^ (24 * d) * d ^ 14 * + numerator ^ d * 2 ^ ((26 + shift) * (14 - d))) ≤ Nat.factorial 14 * budget) : + (∑ d ∈ Finset.Icc 1 14, + Fintype.card (FewTimePattern signatures d) * numerator ^ d * + 2 ^ ((26 + shift) * (14 - d))) ≤ budget := by + apply Nat.le_of_mul_le_mul_left _ (Nat.factorial_pos 14) + rw [Finset.mul_sum] + apply le_trans (Finset.sum_le_sum fun d hd => ?_) hcertificate + have hd14 := (Finset.mem_Icc.mp hd).2 + have hfactorial := Nat.factorial_mul_ascFactorial d (14 - d) + rw [Nat.add_sub_of_le hd14] at hfactorial + calc + _ = (d + 1).ascFactorial (14 - d) * + (Nat.factorial d * Fintype.card (FewTimePattern signatures d)) * + numerator ^ d * 2 ^ ((26 + shift) * (14 - d)) := by rw [← hfactorial]; ring + _ ≤ (d + 1).ascFactorial (14 - d) * + (2 ^ (24 * d) * d ^ (ftsTrees - 1)) * numerator ^ d * + 2 ^ ((26 + shift) * (14 - d)) := by + exact Nat.mul_le_mul_right _ (Nat.mul_le_mul_right _ (Nat.mul_le_mul_left _ + (fewTimePattern_card_scaled_le_signatureLimit hsignatures))) + _ = _ := by rw [show ftsTrees - 1 = 14 by rfl]; ring + +theorem weightedFewTime_term_common_denominator (signatures d numerator shift : Nat) + (hd : d ≤ 14) : + (Fintype.card (FewTimePattern signatures d) : ℝ≥0∞) * + ((numerator : ℝ≥0∞) / 2 ^ shift) ^ d * + ((2 ^ (26 * d + 140) : Nat) : ℝ≥0∞)⁻¹ = + (Fintype.card (FewTimePattern signatures d) * numerator ^ d * + 2 ^ ((26 + shift) * (14 - d)) : Nat) * + ((2 ^ ((26 + shift) * 14 + 140) : Nat) : ℝ≥0∞)⁻¹ := by + have hden : ((2 : ℝ≥0∞) ^ shift) ^ d * ((2 ^ (26 * d + 140) : Nat) : ℝ≥0∞) = + ((2 ^ ((26 + shift) * d + 140) : Nat) : ℝ≥0∞) := by + simp only [Nat.cast_pow, Nat.cast_ofNat] + rw [← pow_mul, ← pow_add] + congr 1 + ring + have hbase : (Fintype.card (FewTimePattern signatures d) : ℝ≥0∞) * + ((numerator : ℝ≥0∞) / 2 ^ shift) ^ d * + ((2 ^ (26 * d + 140) : Nat) : ℝ≥0∞)⁻¹ = + (Fintype.card (FewTimePattern signatures d) * numerator ^ d : Nat) / + ((2 ^ ((26 + shift) * d + 140) : Nat) : ℝ≥0∞) := by + rw [div_eq_mul_inv, mul_pow] + rw [div_eq_mul_inv, ← hden, ENNReal.mul_inv (by left; positivity) (by right; finiteness)] + simp only [ENNReal.inv_pow, Nat.cast_mul, Nat.cast_pow, Nat.cast_ofNat] + ring + rw [hbase, ← div_eq_mul_inv] + let factor : ℝ≥0∞ := (2 ^ ((26 + shift) * (14 - d)) : Nat) + have hz : factor ≠ 0 := by positivity + have ht : factor ≠ ∞ := by simp [factor] + rw [← ENNReal.mul_div_mul_right + (Fintype.card (FewTimePattern signatures d) * numerator ^ d : Nat) + ((2 ^ ((26 + shift) * d + 140) : Nat) : ℝ≥0∞) hz ht] + congr 1 + · simp [factor, Nat.cast_mul] + · dsimp [factor] + rw [← Nat.cast_mul, ← pow_add] + congr 2 + calc + (26 + shift) * d + 140 + (26 + shift) * (14 - d) = + (26 + shift) * (d + (14 - d)) + 140 := by ring + _ = _ := by rw [Nat.add_sub_of_le hd] + +theorem weightedFewTimePatternBound_le_of_origin_weight + {signatures q numerator shift budget : Nat} + (hsignatures : signatures ≤ signatureLimit) + (hweight : 1 + (q : ℝ≥0∞) * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ≤ + (numerator : ℝ≥0∞) / 2 ^ shift) + (hcertificate : (∑ d ∈ Finset.Icc 1 14, + (d + 1).ascFactorial (14 - d) * 2 ^ (24 * d) * d ^ 14 * + numerator ^ d * 2 ^ ((26 + shift) * (14 - d))) ≤ Nat.factorial 14 * budget) : + weightedFewTimePatternBound signatures q ≤ + (budget : ℝ≥0∞) * ((2 ^ ((26 + shift) * 14 + 140) : Nat) : ℝ≥0∞)⁻¹ := by + classical + calc + _ ≤ ∑ d ∈ Finset.Icc 1 14, ∑ _pattern : FewTimePattern signatures d, + ((numerator : ℝ≥0∞) / 2 ^ shift) ^ d * + ((2 ^ (26 * d + 140) : Nat) : ℝ≥0∞)⁻¹ := by + apply Finset.sum_le_sum + intro d hd + apply Finset.sum_le_sum + intro pattern _ + gcongr + calc + _ ≤ (1 + q * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹) ^ Fintype.card pattern.selected := + originChoiceMass_le _ _ _ + _ = (1 + q * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹) ^ d := by + rw [Fintype.card_coe, pattern.card_selected] + _ ≤ _ := pow_le_pow_left' hweight d + _ = ∑ d ∈ Finset.Icc 1 14, + (Fintype.card (FewTimePattern signatures d) * numerator ^ d * + 2 ^ ((26 + shift) * (14 - d)) : Nat) * + ((2 ^ ((26 + shift) * 14 + 140) : Nat) : ℝ≥0∞)⁻¹ := by + simp only [Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + apply Finset.sum_congr rfl + intro d hd + rw [← mul_assoc] + exact weightedFewTime_term_common_denominator signatures d numerator shift + (Finset.mem_Icc.mp hd).2 + _ = ((∑ d ∈ Finset.Icc 1 14, + Fintype.card (FewTimePattern signatures d) * numerator ^ d * + 2 ^ ((26 + shift) * (14 - d)) : Nat) : ℝ≥0∞) * + ((2 ^ ((26 + shift) * 14 + 140) : Nat) : ℝ≥0∞)⁻¹ := by + rw [← Finset.sum_mul, Nat.cast_sum] + _ ≤ _ := mul_le_mul' (Nat.cast_le.mpr + (weightedFewTime_scaled_sum_le hsignatures hcertificate)) le_rfl + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeParametricRace.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeParametricRace.lean new file mode 100644 index 00000000..d207d28d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeParametricRace.lean @@ -0,0 +1,221 @@ +import SphincsSecurity.Proof.FewTimeRace + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +noncomputable local instance parametricRaceRandomnessSampleable : SampleableType Randomness := SampleableType.ofFintype Randomness + +theorem uniform_randomness_messageInput_cacheMiss_ge_of_budget + (secretKey : SecretKey) (message : Message) (cache : QueryCache HashSpec) + (budget : Nat) (hcache : QueryCache.enncard cache ≤ budget) : + 1 - (budget : ENNReal) * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ ≤ + Pr[fun randomness : Randomness => cache (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message randomness)) = none | $ᵗ Randomness] := by + apply probEvent_one_sub_le_of_compl_le (by simp only [probFailure_of_liftM_PMF]) + calc + _ = Pr[fun randomness : Randomness => ∃ output, + cache (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message randomness)) = some output | $ᵗ Randomness] := by + apply probEvent_congr' + · intro randomness _ + exact Option.ne_none_iff_exists' + · rfl + _ ≤ cachedMessageEntryCount cache secretKey.parameter secretKey.root message * + ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ := + uniform_randomness_messageInput_cacheHit_le_cachedMessageEntryCount secretKey.parameter secretKey.root message cache + _ ≤ _ := mul_le_mul' ((cachedMessageEntryCount_le_enncard cache secretKey.parameter secretKey.root message).trans hcache) le_rfl + +set_option linter.constructorNameAsVariable false in +theorem Concrete.probEvent_signDigestAttemptPrefix_success_ge_of_budget + (secretKey : SecretKey) (message : Message) (cache : QueryCache HashSpec) + (budget : Nat) (hcache : QueryCache.enncard cache ≤ budget) : + (1 - (budget : ENNReal) * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹) * + ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ ≤ + Pr[fun attempt => attempt.2.1 ≠ none | signDigestAttemptPrefix secretKey message cache] := by + rw [signDigestAttemptPrefix] + apply mul_le_probEvent_bind + · exact uniform_randomness_messageInput_cacheMiss_ge_of_budget secretKey message cache budget hcache + · intro randomness _hrandomness hmiss + change ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ ≤ + Pr[fun attempt => attempt.2.1 ≠ none | + (simulateQ (randomOracle : QueryImpl HashSpec _) + (signAttempt secretKey message randomness)).run cache >>= fun result => pure (randomness, result)] + rw [show (fun result => pure (randomness, result)) = pure ∘ fun result => (randomness, result) from rfl, + probEvent_bind_pure_comp] + exact le_of_eq (probEvent_signAttempt_fresh_success_eq secretKey message randomness cache hmiss).symm + +theorem Concrete.probEvent_signDigestAttemptPrefix_retry_le_of_budget + (secretKey : SecretKey) (message : Message) (cache : QueryCache HashSpec) + (budget : Nat) (hcache : QueryCache.enncard cache ≤ budget) + (rate : ENNReal) (hrate : rate ≤ (1 - (budget : ENNReal) * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹) * + ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹) : + Pr[fun attempt => attempt.2.1 = none | signDigestAttemptPrefix secretKey message cache] ≤ 1 - rate := by + have hsuccess := hrate.trans (probEvent_signDigestAttemptPrefix_success_ge_of_budget secretKey message cache budget hcache) + have hrateOne : rate ≤ 1 := hsuccess.trans probEvent_le_one + have hcompl := probEvent_compl_le_of_one_sub_le + (mx := signDigestAttemptPrefix secretKey message cache) (p := fun attempt => attempt.2.1 ≠ none) + (ε := 1 - rate) (by simp [signDigestAttemptPrefix]) (by + rw [ENNReal.sub_sub_cancel (by simp) hrateOne] + exact hsuccess) + simpa only [not_ne_iff] using hcompl + +theorem prehit_race_recurrence_of_weight + (count rate weight : ENNReal) + (hweight : ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ + (1 - rate) * weight ≤ weight) : + count * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ + (1 - rate) * (count * weight) ≤ count * weight := by + calc + _ = count * (((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ + (1 - rate) * weight) := by ring + _ ≤ _ := mul_le_mul' le_rfl hweight + +set_option maxRecDepth 100000 in +set_option linter.constructorNameAsVariable false in +theorem Concrete.probEvent_signDigestLoop_prehitSelectedView_le_parametric_race + (attempts : Nat) (secretKey : SecretKey) (message : Message) + (referenceCache workingCache : QueryCache HashSpec) (P : FewTimeView → Prop) + (hreference : referenceCache ≤ workingCache) + (budget : Nat) (rate weight : ENNReal) + (hrate : rate ≤ (1 - (budget : ENNReal) * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹) * + ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹) + (hweight : ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ + (1 - rate) * weight ≤ weight) + (hbudget : QueryCache.enncard workingCache + (attempts : ℝ≥0∞) ≤ + (budget : ENNReal)) : + Pr[PrehitSelectedView referenceCache secretKey message P | + (simulateQ romImpl + (signDigestLoop attempts secretKey message)).run workingCache] ≤ + cachedMessageEntryCountWhere referenceCache secretKey.parameter secretKey.root message P * + weight := by + induction attempts generalizing workingCache with + | zero => + refine le_of_eq_of_le (probEvent_eq_zero ?_) zero_le + intro result hresult hevent + have hresultEq : result = (none, workingCache) := by + simpa only [signDigestLoop, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hresult + obtain ⟨randomness, index, leaves, hselected, _⟩ := hevent + rw [hresultEq] at hselected + simp at hselected + | succ attempts ih => + rw [signDigestLoop_run_succ_eq_attemptPrefix] + let count := cachedMessageEntryCountWhere referenceCache secretKey.parameter + secretKey.root message P + let epsilon := count * weight + refine (probEvent_bind_le_probEvent_add_mul + (hit := FavorablePrehitAttempt referenceCache secretKey message P) + (retry := fun attempt => attempt.2.1 = none) + (epsilon := epsilon) ?_ ?_).trans ?_ + · intro attempt _hattempt hnotHit hnotRetry + cases hattemptResult : attempt.2.1 with + | none => exact (hnotRetry hattemptResult).elim + | some selected => + rcases selected with ⟨selectedIndex, selectedLeaves⟩ + refine probEvent_eq_zero ?_ + intro result hresult hevent + have hresultEq : result = + (some (attempt.1, selectedIndex, selectedLeaves), attempt.2.2) := by + simpa only [signDigestLoopContinuation, hattemptResult, support_pure, + Set.mem_singleton_iff] using hresult + obtain ⟨foundRandomness, foundIndex, foundLeaves, hfound, output, hcached, + houtputResult, hP⟩ := hevent + have hrandomness : attempt.1 = foundRandomness := by + have htuple : (attempt.1, selectedIndex, selectedLeaves) = + (foundRandomness, foundIndex, foundLeaves) := + Option.some.inj ((congrArg Prod.fst hresultEq).symm.trans hfound) + exact congrArg Prod.fst htuple + apply hnotHit + refine ⟨output, ?_, ?_, hP⟩ + · rw [hrandomness] + exact hcached + · rw [houtputResult] + simp + · intro attempt hattempt hrejected + rw [signDigestAttemptPrefix, mem_support_bind_iff] at hattempt + obtain ⟨randomness, _hrandomness, hattempt⟩ := hattempt + rw [mem_support_bind_iff] at hattempt + obtain ⟨attemptResult, hattemptResult, hpure⟩ := hattempt + simp only [support_pure, Set.mem_singleton_iff] at hpure + have hattemptPair : attempt.2 = attemptResult := congrArg Prod.snd hpure + have hgrowth := signAttempt_enncard_le secretKey message randomness workingCache + attemptResult hattemptResult + have hbudget' : QueryCache.enncard attempt.2.2 + (attempts : ℝ≥0∞) ≤ + (budget : ENNReal) := by + calc + QueryCache.enncard attempt.2.2 + (attempts : ℝ≥0∞) = + QueryCache.enncard attemptResult.2 + (attempts : ℝ≥0∞) := by + rw [hattemptPair] + _ ≤ (QueryCache.enncard workingCache + 1) + (attempts : ℝ≥0∞) := by + exact add_le_add hgrowth le_rfl + _ = QueryCache.enncard workingCache + ((attempts + 1 : Nat) : ℝ≥0∞) := by + push_cast + ring + _ ≤ _ := hbudget + have hmemWorld : attemptResult ∈ support + ((simulateQ romImpl + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))) : + OracleComp OracleWorld (Option (Index × (DigestTree → FtsLeaf))))).run + workingCache) := by + rw [simulateQ_romImpl_liftM] + exact hattemptResult + have hworkingLe : workingCache ≤ attemptResult.2 := + simulateQ_romImpl_cache_le + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))) : + OracleComp OracleWorld (Option (Index × (DigestTree → FtsLeaf)))) + workingCache attemptResult hmemWorld + have hreference' : referenceCache ≤ attempt.2.2 := by + rw [hattemptPair] + exact hreference.trans hworkingLe + simpa only [epsilon, count, hrejected, signDigestLoopContinuation] using + ih attempt.2.2 hreference' hbudget' + · have hworkingBudget : QueryCache.enncard workingCache ≤ + (budget : ENNReal) := + (le_add_right le_rfl).trans hbudget + calc + Pr[FavorablePrehitAttempt referenceCache secretKey message P | + signDigestAttemptPrefix secretKey message workingCache] + + Pr[fun attempt => attempt.2.1 = none | + signDigestAttemptPrefix secretKey message workingCache] * epsilon ≤ + count * ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ + + (1 - rate) * epsilon := by + gcongr + · exact probEvent_signDigestAttemptPrefix_favorablePrehit_le + referenceCache workingCache secretKey message P + · exact probEvent_signDigestAttemptPrefix_retry_le_of_budget + secretKey message workingCache budget hworkingBudget rate hrate + _ ≤ count * weight := by + exact prehit_race_recurrence_of_weight count rate weight hweight + _ = _ := rfl + + +theorem prehit_race_weight_div_success + (rate : ENNReal) (hpositive : rate ≠ 0) (hfinite : rate ≠ ∞) (hrate : rate ≤ 1) : + ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ + + (1 - rate) * (((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ / rate) = + ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ / rate := by + have hcancel : rate * (((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ / rate) = + ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ := by + rw [div_eq_mul_inv, mul_left_comm, ENNReal.mul_inv_cancel hpositive hfinite, mul_one] + calc + _ = (rate + (1 - rate)) * (((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ / rate) := by rw [add_mul, hcancel] + _ = _ := by rw [add_tsub_cancel_of_le hrate, one_mul] + +set_option linter.constructorNameAsVariable false in +theorem Concrete.probEvent_signDigestLoop_prehitSelectedView_le_div_success + (attempts : Nat) (secretKey : SecretKey) (message : Message) + (referenceCache workingCache : QueryCache HashSpec) (P : FewTimeView → Prop) + (hreference : referenceCache ≤ workingCache) (budget : Nat) + (hbudget : QueryCache.enncard workingCache + (attempts : ENNReal) ≤ budget) + (rate : ENNReal) (hpositive : rate ≠ 0) + (hrate : rate ≤ (1 - (budget : ENNReal) * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹) * + ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹) : + Pr[PrehitSelectedView referenceCache secretKey message P | + (simulateQ romImpl (signDigestLoop attempts secretKey message)).run workingCache] ≤ + cachedMessageEntryCountWhere referenceCache secretKey.parameter secretKey.root message P * + (((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ / rate) := by + have hcache : QueryCache.enncard workingCache ≤ budget := (le_add_right le_rfl).trans hbudget + have hrateOne := (hrate.trans (probEvent_signDigestAttemptPrefix_success_ge_of_budget secretKey message workingCache budget hcache)).trans probEvent_le_one + exact probEvent_signDigestLoop_prehitSelectedView_le_parametric_race attempts secretKey message referenceCache workingCache P + hreference budget rate _ hrate (prehit_race_weight_div_success rate hpositive (ne_top_of_le_ne_top (by simp) hrateOne) hrateOne).le hbudget + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeParametricSignerRace.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeParametricSignerRace.lean new file mode 100644 index 00000000..a7546a3f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeParametricSignerRace.lean @@ -0,0 +1,159 @@ +import SphincsSecurity.Proof.FewTimeParametricRace + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +set_option maxRecDepth 100000 in +set_option linter.constructorNameAsVariable false in +theorem Concrete.probEvent_signWithView_prehitSuccessful_le_div_success_reference + (secretKey : SecretKey) (message : Message) + (referenceCache initialCache : QueryCache HashSpec) + (P : FewTimeView → Prop) + (hreference : referenceCache ≤ initialCache) (budget : Nat) + (rate : ENNReal) (hpositive : rate ≠ 0) + (hrate : rate ≤ (1 - (budget : ENNReal) * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹) * + ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹) + (hbudget : QueryCache.enncard initialCache + (digestAttemptLimit : ℝ≥0∞) ≤ + (budget : ENNReal)) : + Pr[PrehitSuccessfulSignerView referenceCache secretKey message P | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] ≤ + cachedMessageEntryCountWhere referenceCache secretKey.parameter secretKey.root message P * + (((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ / rate) := by + rw [signWithView, simulateQ_bind, StateT.run_bind] + refine (probEvent_bind_le_probEvent + (p := PrehitSelectedView referenceCache secretKey message P) ?_).trans + (probEvent_signDigestLoop_prehitSelectedView_le_div_success digestAttemptLimit + secretKey message referenceCache initialCache P hreference budget hbudget rate hpositive hrate) + intro loopResult hloop hnotPrehit + cases hloopResult : loopResult.1 with + | none => + refine probEvent_eq_zero ?_ + intro result hresult hevent + have hresultEq : result = ((none, none), loopResult.2) := by + simpa only [hloopResult, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hresult + obtain ⟨signature, view, hsuccessful, _⟩ := hevent + rw [hresultEq] at hsuccessful + simp at hsuccessful + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + refine probEvent_eq_zero ?_ + intro result hresult hevent + rw [simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hresult + obtain ⟨⟨signatureResult, signatureCache⟩, hsignature, hpure⟩ := hresult + have hpureEq : result = + ((signatureResult, some (selectedFewTimeView index leaves)), signatureCache) := by + simpa only [simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hpure + obtain ⟨signature, view, hsuccessful, output, hcached, hP⟩ := hevent + have hpureFirst := congrArg Prod.fst hpureEq + have hsignatureResult : signatureResult = some signature := by + have hfirst := congrArg Prod.fst (hpureFirst.symm.trans hsuccessful) + simpa using hfirst + have hsignature' : (some signature, signatureCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest secretKey randomness index leaves)).run loopResult.2) := by + rw [hsignatureResult] at hsignature + simpa only [simulateQ_romImpl_liftM] using hsignature + have hrandomness := signAfterDigest_support_some_randomness secretKey randomness + index leaves loopResult.2 signatureCache signature hsignature' + have hcached' : initialCache + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = some output := by + apply hreference + rw [← hrandomness] + exact hcached + have hloop' : (some (randomness, index, leaves), loopResult.2) ∈ support + ((simulateQ romImpl + (signDigestLoop digestAttemptLimit secretKey message)).run initialCache) := by + have heq : loopResult = (some (randomness, index, leaves), loopResult.2) := + Prod.ext hloopResult rfl + rw [← heq] + exact hloop + have hresultOutput := signDigestLoop_initial_cached_result + digestAttemptLimit secretKey message randomness index leaves initialCache loopResult.2 + output hcached' hloop' + apply hnotPrehit + exact ⟨randomness, index, leaves, hloopResult, output, by + rw [← hrandomness] + exact hcached, hresultOutput, hP⟩ + + +theorem digestRaceSuccessRate_ne_zero_of_budget_lt + (budget : Nat) (hbudget : budget < 2 ^ randomnessBits) : + (1 - (budget : ENNReal) * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹) * + ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ ≠ 0 := by + have hfraction : (budget : ENNReal) * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ < 1 := by + rw [← div_eq_mul_inv, ENNReal.div_lt_iff (by left; positivity) (by left; finiteness), one_mul] + exact_mod_cast hbudget + exact mul_ne_zero (ne_of_gt (tsub_pos_iff_lt.mpr hfraction)) (ENNReal.inv_ne_zero.mpr (by finiteness)) + +set_option linter.constructorNameAsVariable false in +theorem Concrete.probEvent_signWithView_prehitSuccessful_le_cacheBudget + (secretKey : SecretKey) (message : Message) (referenceCache initialCache : QueryCache HashSpec) + (P : FewTimeView → Prop) (hreference : referenceCache ≤ initialCache) + (budget : Nat) (hbudget : budget < 2 ^ randomnessBits) + (hcache : QueryCache.enncard initialCache + (digestAttemptLimit : ENNReal) ≤ budget) : + Pr[PrehitSuccessfulSignerView referenceCache secretKey message P | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] ≤ + cachedMessageEntryCountWhere referenceCache secretKey.parameter secretKey.root message P * + (((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ / + ((1 - (budget : ENNReal) * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹) * + ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹)) := + probEvent_signWithView_prehitSuccessful_le_div_success_reference secretKey message referenceCache initialCache P hreference + budget _ (digestRaceSuccessRate_ne_zero_of_budget_lt budget hbudget) le_rfl hcache + +set_option linter.constructorNameAsVariable false in +theorem Concrete.probEvent_signWithView_prehitSuccessful_le_queryBudget127 + (secretKey : SecretKey) (message : Message) (referenceCache initialCache : QueryCache HashSpec) + (P : FewTimeView → Prop) (hreference : referenceCache ≤ initialCache) + (q : Nat) (hq : q ≤ 2 ^ 127) (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[PrehitSuccessfulSignerView referenceCache secretKey message P | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] ≤ + cachedMessageEntryCountWhere referenceCache secretKey.parameter secretKey.root message P * + (((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ / + ((1 - ((q + digestAttemptLimit : Nat) : ENNReal) * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹) * + ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹)) := by + apply probEvent_signWithView_prehitSuccessful_le_cacheBudget secretKey message referenceCache initialCache P hreference + (q + digestAttemptLimit) + · norm_num [digestAttemptLimit, randomnessBits] at * + omega + · simpa only [Nat.cast_add] using add_le_add hcache (le_refl (digestAttemptLimit : ENNReal)) + +theorem digestRaceSuccessRate_ge_two_thirds_of_queryBudget126 : + (2 / 3 : ENNReal) * ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ ≤ + (1 - ((2 ^ 126 + digestAttemptLimit : Nat) : ENNReal) * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹) * + ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ := by + apply mul_le_mul' _ le_rfl + have hfraction : ((2 ^ 126 + digestAttemptLimit : Nat) : ENNReal) * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ ≤ 1 := by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + norm_num [ENNReal.toReal_mul, ENNReal.toReal_inv, digestAttemptLimit, randomnessBits] + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_sub_of_le hfraction (by finiteness)] + norm_num [ENNReal.toReal_div, ENNReal.toReal_mul, ENNReal.toReal_inv, digestAttemptLimit, randomnessBits] + +set_option linter.constructorNameAsVariable false in +theorem Concrete.probEvent_signWithView_prehitSuccessful_le_three_mul_inv119 + (secretKey : SecretKey) (message : Message) (referenceCache initialCache : QueryCache HashSpec) + (P : FewTimeView → Prop) (hreference : referenceCache ≤ initialCache) + (q : Nat) (hq : q ≤ 2 ^ 126) (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[PrehitSuccessfulSignerView referenceCache secretKey message P | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] ≤ + cachedMessageEntryCountWhere referenceCache secretKey.parameter secretKey.root message P * + (3 * ((2 ^ 119 : Nat) : ENNReal)⁻¹) := by + have hbudget : QueryCache.enncard initialCache + (digestAttemptLimit : ENNReal) ≤ + ((2 ^ 126 + digestAttemptLimit : Nat) : ENNReal) := by + rw [Nat.cast_add] + exact add_le_add (hcache.trans (Nat.cast_le.mpr hq)) le_rfl + have hbound := probEvent_signWithView_prehitSuccessful_le_div_success_reference secretKey message referenceCache initialCache P + hreference (2 ^ 126 + digestAttemptLimit) ((2 / 3 : ENNReal) * ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹) + (by norm_num [ftsTreeHeight]) digestRaceSuccessRate_ge_two_thirds_of_queryBudget126 hbudget + have hweight : ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ / + ((2 / 3 : ENNReal) * ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹) = 3 * ((2 ^ 119 : Nat) : ENNReal)⁻¹ := by + have hnonzero : (2 / 3 : ENNReal) * ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ ≠ 0 := by norm_num [ftsTreeHeight] + apply (ENNReal.toReal_eq_toReal_iff' (ENNReal.div_ne_top (by finiteness) hnonzero) (by finiteness)).mp + norm_num [ENNReal.toReal_div, ENNReal.toReal_mul, ENNReal.toReal_inv, randomnessBits, ftsTreeHeight] + simpa only [hweight] using hbound + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimePatterns.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimePatterns.lean new file mode 100644 index 00000000..604f7bea --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimePatterns.lean @@ -0,0 +1,128 @@ +import SphincsSecurity.Proof.FewTimeWitness +import SphincsSecurity.Proof.LeakArith +import Mathlib.Data.Fintype.Powerset + +/-! +# Counting few-time coverage patterns + +A pattern chooses the distinct signing invocations used by a leak and assigns each of the fourteen +few-time trees to one of them. Its exact cardinality is the binomial and power appearing in the +few-time union bound. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +structure FewTimePattern (signatures distinct : Nat) where + selected : Finset (Fin signatures) + card_selected : selected.card = distinct + assignment : FtsTree → selected + +def fewTimePatternEquiv (signatures distinct : Nat) : + FewTimePattern signatures distinct ≃ + Σ selected : {s : Finset (Fin signatures) // s.card = distinct}, FtsTree → selected.1 where + toFun pattern := ⟨⟨pattern.selected, pattern.card_selected⟩, pattern.assignment⟩ + invFun pattern := ⟨pattern.1.1, pattern.1.2, pattern.2⟩ + left_inv pattern := by cases pattern; rfl + right_inv pattern := by cases pattern with | mk selected assignment => cases selected; rfl + +noncomputable instance (signatures distinct : Nat) : Fintype (FewTimePattern signatures distinct) := + Fintype.ofEquiv _ (fewTimePatternEquiv signatures distinct).symm + +theorem fewTimePattern_card (signatures distinct : Nat) : + Fintype.card (FewTimePattern signatures distinct) = + Nat.choose signatures distinct * distinct ^ (ftsTrees - 1) := by + classical + rw [Fintype.card_congr (fewTimePatternEquiv signatures distinct), Fintype.card_sigma] + simp only [Fintype.card_fun, Fintype.card_coe] + have htreeCard : Fintype.card FtsTree = ftsTrees - 1 := Fintype.card_fin _ + simp_rw [htreeCard] + have hselected : ∀ selected : {s : Finset (Fin signatures) // s.card = distinct}, + selected.1.card ^ (ftsTrees - 1) = distinct ^ (ftsTrees - 1) := by + intro selected + rw [selected.2] + simp_rw [hselected] + rw [Finset.sum_const, Finset.card_univ, Fintype.card_finset_len, Fintype.card_fin, + nsmul_eq_mul] + simp + +theorem fewTimePattern_card_le_pow (signatures distinct : Nat) : + Nat.factorial distinct * Fintype.card (FewTimePattern signatures distinct) + ≤ signatures ^ distinct * distinct ^ (ftsTrees - 1) := by + rw [fewTimePattern_card, ← Nat.mul_assoc] + exact Nat.mul_le_mul_right _ (factorial_mul_choose_le_pow signatures distinct) + +theorem fewTimePattern_card_scaled_le_signatureLimit {signatures distinct : Nat} + (hsignatures : signatures ≤ signatureLimit) : + Nat.factorial distinct * Fintype.card (FewTimePattern signatures distinct) ≤ + 2 ^ (24 * distinct) * distinct ^ (ftsTrees - 1) := by + calc + Nat.factorial distinct * Fintype.card (FewTimePattern signatures distinct) + ≤ signatures ^ distinct * distinct ^ (ftsTrees - 1) := + fewTimePattern_card_le_pow signatures distinct + _ ≤ signatureLimit ^ distinct * distinct ^ (ftsTrees - 1) := by + exact Nat.mul_le_mul_right _ (Nat.pow_le_pow_left hsignatures distinct) + _ = 2 ^ (24 * distinct) * distinct ^ (ftsTrees - 1) := by + rw [signatureLimit, pow_mul] + +theorem fewTimePattern_scaled_sum_le {signatures : Nat} + (hsignatures : signatures ≤ signatureLimit) : + Nat.factorial 14 * + ∑ distinct ∈ Finset.Icc 1 14, + Fintype.card (FewTimePattern signatures distinct) * 2 ^ (26 * (14 - distinct)) + ≤ Nat.factorial 14 * 2 ^ 382 := by + rw [Finset.mul_sum] + calc + ∑ distinct ∈ Finset.Icc 1 14, + Nat.factorial 14 * + (Fintype.card (FewTimePattern signatures distinct) * 2 ^ (26 * (14 - distinct))) + ≤ ∑ distinct ∈ Finset.Icc 1 14, + (distinct + 1).ascFactorial (14 - distinct) * 2 ^ (24 * distinct) * + distinct ^ 14 * 2 ^ (26 * (14 - distinct)) := by + apply Finset.sum_le_sum + intro distinct hdistinct + have hle : distinct ≤ 14 := (Finset.mem_Icc.mp hdistinct).2 + have hfactorial : Nat.factorial distinct * + (distinct + 1).ascFactorial (14 - distinct) = Nat.factorial 14 := by + rw [Nat.factorial_mul_ascFactorial, Nat.add_sub_of_le hle] + calc + Nat.factorial 14 * + (Fintype.card (FewTimePattern signatures distinct) * + 2 ^ (26 * (14 - distinct))) = + (distinct + 1).ascFactorial (14 - distinct) * + (Nat.factorial distinct * Fintype.card (FewTimePattern signatures distinct)) * + 2 ^ (26 * (14 - distinct)) := by rw [← hfactorial]; ring + _ ≤ (distinct + 1).ascFactorial (14 - distinct) * + (2 ^ (24 * distinct) * distinct ^ (ftsTrees - 1)) * + 2 ^ (26 * (14 - distinct)) := by + exact Nat.mul_le_mul_right _ (Nat.mul_le_mul_left _ + (fewTimePattern_card_scaled_le_signatureLimit + (signatures := signatures) (distinct := distinct) hsignatures)) + _ = (distinct + 1).ascFactorial (14 - distinct) * 2 ^ (24 * distinct) * + distinct ^ 14 * 2 ^ (26 * (14 - distinct)) := by + rw [show ftsTrees - 1 = 14 by decide] + ring + _ ≤ Nat.factorial 14 * 2 ^ 382 := by exact leak_union_bound_scaled_sum + +theorem fewTimePattern_sum_le {signatures : Nat} + (hsignatures : signatures ≤ signatureLimit) : + (∑ distinct ∈ Finset.Icc 1 14, + Fintype.card (FewTimePattern signatures distinct) * 2 ^ (26 * (14 - distinct))) + ≤ 2 ^ 382 := + Nat.le_of_mul_le_mul_left (fewTimePattern_scaled_sum_le hsignatures) + (Nat.factorial_pos 14) + +noncomputable def FewTimeCover.pattern {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) : + FewTimePattern signingLog.length cover.entries.card where + selected := cover.logIndices + card_selected := cover.logIndices_card + assignment := fun tree => + let entry : cover.entries := ⟨(cover.select tree).entry.flat, cover.entry_mem_entries tree⟩ + ⟨cover.logIndex entry, Finset.mem_image.2 ⟨entry, Finset.mem_univ _, rfl⟩⟩ + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimePrehit.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimePrehit.lean new file mode 100644 index 00000000..abf8cc6f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimePrehit.lean @@ -0,0 +1,369 @@ +import SphincsSecurity.Proof.FewTimeFresh +import SphincsSecurity.Proof.CacheSize + +/-! +# Cached signer views + +The cached-input branch retains the predicate on the cached answer's few-time view. Its randomizer +reuse cost is charged only against cache entries that satisfy that predicate. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +noncomputable local instance : SampleableType Randomness := + SampleableType.ofFintype Randomness + +def cachedMessageInputSetWhere (cache : QueryCache HashSpec) (parameter : PublicParameter) + (root : Digest) (message : Message) (P : Concrete.FewTimeView → Prop) : + Set ((t : HashSpec.Domain) × HashSpec.Range t) := + {entry ∈ cachedMessageInputSet cache parameter root message | + Concrete.signAttemptResultOfOutput entry.2 ≠ none + ∧ P (Concrete.hashOutputFewTimeView entry.2)} + +noncomputable def cachedMessageEntryCountWhere (cache : QueryCache HashSpec) + (parameter : PublicParameter) (root : Digest) (message : Message) + (P : Concrete.FewTimeView → Prop) : ℝ≥0∞ := + (((cachedMessageInputSetWhere cache parameter root message P).encard : ENat) : ℝ≥0∞) + +theorem cachedMessageEntryCountWhere_le_enncard + (cache : QueryCache HashSpec) (parameter : PublicParameter) + (root : Digest) (message : Message) (P : Concrete.FewTimeView → Prop) : + cachedMessageEntryCountWhere cache parameter root message P ≤ + QueryCache.enncard cache := by + have hsubset : cachedMessageInputSetWhere cache parameter root message P ⊆ cache.toSet := by + intro entry hentry + exact hentry.1.1 + simpa only [cachedMessageEntryCountWhere, QueryCache.enncard] using + ENat.toENNReal_mono (Set.encard_le_encard hsubset) + +theorem Concrete.gameAfterSecretsWithFullTrace_support_enncard_le + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound Concrete.scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support Concrete.sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support Concrete.sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support Concrete.sampleFtsSecrets) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (Concrete.gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) : + QueryCache.enncard result.2.1 ≤ q := by + have hprojected : (result.1.2.2, result.2.1) ∈ support + ((fun traced => (traced.1.2.2, traced.2.1)) <$> + Concrete.gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [support_map] + exact ⟨result, hresult, rfl⟩ + rw [Concrete.gameAfterSecretsWithFullTrace_projection] at hprojected + exact simulateQ_romImpl_enncard_le_queryBound + (Concrete.gameAfterSecrets adversary parameter otsSecret ftsSecret) q + (Concrete.isQueryBoundP_gameAfterSecrets adversary q hq hparameter hots hfts) + (result.1.2.2, result.2.1) hprojected + +theorem Concrete.gameAfterSecretsWithFullTrace_signingEntry_cachedCountWhere_le + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound Concrete.scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support Concrete.sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support Concrete.sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support Concrete.sampleFtsSecrets) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (Concrete.gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) + (entry : SigningCacheEntry) (hentry : entry ∈ result.2.2.signing) + (P : Concrete.FewTimeView → Prop) : + cachedMessageEntryCountWhere entry.initialCache parameter result.1.1 entry.request P ≤ q := by + have hinvariants := Concrete.gameAfterSecretsWithFullTrace_support_invariants + adversary parameter otsSecret ftsSecret result hresult + calc + cachedMessageEntryCountWhere entry.initialCache parameter result.1.1 entry.request P ≤ + QueryCache.enncard entry.initialCache := + cachedMessageEntryCountWhere_le_enncard entry.initialCache parameter result.1.1 + entry.request P + _ ≤ QueryCache.enncard result.2.1 := + QueryCache.enncard_mono (hinvariants.2.1 entry hentry).1 + _ ≤ q := Concrete.gameAfterSecretsWithFullTrace_support_enncard_le adversary q hq + parameter hparameter otsSecret hots ftsSecret hfts result hresult + +set_option maxRecDepth 100000 in +theorem uniform_randomness_messageInput_cacheHitWhere_le_cachedCount + (parameter : PublicParameter) (root : Digest) (message : Message) + (cache : QueryCache HashSpec) (P : Concrete.FewTimeView → Prop) : + Pr[fun randomness : Randomness => ∃ output, + cache (tweakableHashInput parameter .message + (Concrete.messageDigestPayload root message randomness)) = some output + ∧ Concrete.signAttemptResultOfOutput output ≠ none + ∧ P (Concrete.hashOutputFewTimeView output) | + $ᵗ Randomness] ≤ + cachedMessageEntryCountWhere cache parameter root message P * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ := by + classical + let hit : Randomness → Prop := fun randomness => ∃ output, + cache (tweakableHashInput parameter .message + (Concrete.messageDigestPayload root message randomness)) = some output + ∧ Concrete.signAttemptResultOfOutput output ≠ none + ∧ P (Concrete.hashOutputFewTimeView output) + let targets : Finset Randomness := Finset.univ.filter hit + let fiber := cachedMessageInputSetWhere cache parameter root message P + have hcard : (targets.card : ℝ≥0∞) ≤ + cachedMessageEntryCountWhere cache parameter root message P := by + let embedding : (targets : Set Randomness) ↪ fiber := + ⟨fun randomness => + ⟨⟨tweakableHashInput parameter .message + (Concrete.messageDigestPayload root message randomness.1), + Classical.choose (Finset.mem_filter.mp randomness.2).2⟩, + ⟨⟨Classical.choose_spec (Finset.mem_filter.mp randomness.2).2 |>.1, + ⟨randomness.1, rfl⟩⟩, + ⟨Classical.choose_spec (Finset.mem_filter.mp randomness.2).2 |>.2.1, + Classical.choose_spec (Finset.mem_filter.mp randomness.2).2 |>.2.2⟩⟩⟩, + fun left right heq => Subtype.ext <| + (Concrete.messageDigestPayload_injective root <| + (tweakableHashInput_injective parameter (by trivial) (by trivial) <| + congrArg (fun entry : fiber => entry.1.1) heq).2).2⟩ + simpa only [cachedMessageEntryCountWhere, fiber, + Set.encard_coe_eq_coe_finsetCard, ENat.toENNReal_coe] using + ENat.toENNReal_mono embedding.encard_le + rw [probEvent_uniformSample, card_randomness, div_eq_mul_inv] + change (targets.card : ℝ≥0∞) * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ ≤ _ + exact mul_le_mul' hcard le_rfl + +def Concrete.PrehitSelectedView (referenceCache : QueryCache HashSpec) + (secretKey : SecretKey) (message : Message) (P : Concrete.FewTimeView → Prop) + (result : Option (Randomness × Index × (DigestTree → FtsLeaf)) × + QueryCache HashSpec) : Prop := + ∃ randomness index leaves, + result.1 = some (randomness, index, leaves) + ∧ ∃ output, referenceCache + (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message randomness)) = some output + ∧ Concrete.signAttemptResultOfOutput output = some (index, leaves) + ∧ P (Concrete.hashOutputFewTimeView output) + +set_option maxRecDepth 100000 in +set_option linter.constructorNameAsVariable false in +theorem Concrete.probEvent_signDigestLoop_prehitSelectedView_le_cachedCount + (attempts : Nat) (secretKey : SecretKey) (message : Message) + (referenceCache workingCache : QueryCache HashSpec) (P : Concrete.FewTimeView → Prop) : + Pr[Concrete.PrehitSelectedView referenceCache secretKey message P | + (simulateQ romImpl + (Concrete.signDigestLoop attempts secretKey message)).run workingCache] ≤ + (attempts : ℝ≥0∞) * + cachedMessageEntryCountWhere referenceCache secretKey.parameter secretKey.root message P * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ := by + induction attempts generalizing workingCache with + | zero => + refine le_of_eq_of_le (probEvent_eq_zero ?_) zero_le + intro result hresult hevent + have hresultEq : result = (none, workingCache) := by + simpa only [Concrete.signDigestLoop, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hresult + obtain ⟨randomness, index, leaves, hselected, _⟩ := hevent + rw [hresultEq] at hselected + simp at hselected + | succ attempts ih => + rw [Concrete.signDigestLoop_run_succ_eq] + refine (probEvent_bind_le_probEvent_add + (p := fun randomness : Randomness => ∃ output, + referenceCache + (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message randomness)) = some output + ∧ Concrete.signAttemptResultOfOutput output ≠ none + ∧ P (Concrete.hashOutputFewTimeView output)) + (ε := (attempts : ℝ≥0∞) * + cachedMessageEntryCountWhere referenceCache secretKey.parameter secretKey.root message P * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹) ?_).trans ?_ + · intro randomness _hrandomness hmiss + refine probEvent_bind_le_of_forall_le fun attemptResult _hattempt => ?_ + cases hresult : attemptResult.1 with + | none => + simpa only [Concrete.signDigestLoopContinuation, hresult] using + ih attemptResult.2 + | some selected => + rcases selected with ⟨selectedIndex, selectedLeaves⟩ + refine le_of_eq_of_le (probEvent_eq_zero ?_) zero_le + intro result hsupport hevent + have hsupport' : result = + (some (randomness, selectedIndex, selectedLeaves), attemptResult.2) := by + simpa only [Concrete.signDigestLoopContinuation, hresult, support_pure, + Set.mem_singleton_iff] using hsupport + obtain ⟨foundRandomness, foundIndex, foundLeaves, hfound, output, hhit, + houtputResult, hP⟩ := hevent + have hrandomness : randomness = foundRandomness := by + have htuple : (randomness, selectedIndex, selectedLeaves) = + (foundRandomness, foundIndex, foundLeaves) := + Option.some.inj ((congrArg Prod.fst hsupport').symm.trans hfound) + exact congrArg Prod.fst htuple + apply hmiss + refine ⟨output, ?_, ?_, hP⟩ + · rw [hrandomness] + exact hhit + · rw [houtputResult] + simp + · calc + _ ≤ cachedMessageEntryCountWhere referenceCache secretKey.parameter + secretKey.root message P * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ + + (attempts : ℝ≥0∞) * + cachedMessageEntryCountWhere referenceCache secretKey.parameter + secretKey.root message P * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ := + add_le_add + (uniform_randomness_messageInput_cacheHitWhere_le_cachedCount + secretKey.parameter secretKey.root message referenceCache P) le_rfl + _ = _ := by + push_cast + ring + +set_option maxRecDepth 100000 in +set_option linter.constructorNameAsVariable false in +theorem Concrete.signDigestLoop_initial_cached_result + (attempts : Nat) (secretKey : SecretKey) (message : Message) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (initialCache finalCache : QueryCache HashSpec) (output : HashOutput) + (hcached : initialCache + (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message randomness)) = some output) + (hmem : (some (randomness, index, leaves), finalCache) ∈ support + ((simulateQ romImpl + (Concrete.signDigestLoop attempts secretKey message)).run initialCache)) : + Concrete.signAttemptResultOfOutput output = some (index, leaves) := by + induction attempts generalizing initialCache finalCache with + | zero => + simp [Concrete.signDigestLoop] at hmem + | succ attempts ih => + rw [Concrete.signDigestLoop_run_succ_eq, mem_support_bind_iff] at hmem + obtain ⟨sampled, _hsampled, hrest⟩ := hmem + rw [mem_support_bind_iff] at hrest + obtain ⟨⟨attempt, attemptCache⟩, hattempt, hfinish⟩ := hrest + have hattempt' : (attempt, attemptCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (Concrete.signAttempt secretKey message sampled)).run initialCache) := by + exact hattempt + have hle : initialCache ≤ attemptCache := + simulateQ_romImpl_cache_le + (liftM (Concrete.signAttempt secretKey message sampled : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))) : + OracleComp OracleWorld (Option (Index × (DigestTree → FtsLeaf)))) + initialCache (attempt, attemptCache) (by + rw [simulateQ_romImpl_liftM] + exact hattempt) + cases hattemptResult : attempt with + | none => + have hfuture : (some (randomness, index, leaves), finalCache) ∈ support + ((simulateQ romImpl + (Concrete.signDigestLoop attempts secretKey message)).run attemptCache) := by + simpa only [Concrete.signDigestLoopContinuation, hattemptResult] using hfinish + exact ih attemptCache finalCache (hle hcached) hfuture + | some selected => + rcases selected with ⟨selectedIndex, selectedLeaves⟩ + have hfinishEq : + (some (randomness, index, leaves), finalCache) = + (some (sampled, selectedIndex, selectedLeaves), attemptCache) := by + simpa only [Concrete.signDigestLoopContinuation, hattemptResult, support_pure, + Set.mem_singleton_iff] using hfinish + have htuple : (randomness, index, leaves) = + (sampled, selectedIndex, selectedLeaves) := + Option.some.inj (congrArg Prod.fst hfinishEq) + have hrandomness : randomness = sampled := congrArg Prod.fst htuple + have hcached' : attemptCache + (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message sampled)) = some output := + hle (by + rw [← hrandomness] + exact hcached) + have hattemptSelected : (some (selectedIndex, selectedLeaves), attemptCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (Concrete.signAttempt secretKey message sampled)).run initialCache) := by + have heq : (attempt, attemptCache) = + (some (selectedIndex, selectedLeaves), attemptCache) := + Prod.ext hattemptResult rfl + rw [← heq] + exact hattempt' + have hselectedResult := + (Concrete.signAttempt_result_of_cached secretKey message sampled initialCache + attemptCache (some (selectedIndex, selectedLeaves)) output hcached' + hattemptSelected).symm + exact hselectedResult.trans (congrArg some (congrArg Prod.snd htuple).symm) + +def Concrete.PrehitSuccessfulSignerView (initialCache : QueryCache HashSpec) + (secretKey : SecretKey) (message : Message) (P : Concrete.FewTimeView → Prop) + (result : (Option Signature × Option Concrete.FewTimeView) × QueryCache HashSpec) : Prop := + ∃ signature view, + result.1 = (some signature, some view) + ∧ ∃ output, initialCache + (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message signature.randomness)) = some output + ∧ P (Concrete.hashOutputFewTimeView output) + +set_option maxRecDepth 100000 in +set_option linter.constructorNameAsVariable false in +theorem Concrete.probEvent_signWithView_prehitSuccessful_le_cachedCount + (secretKey : SecretKey) (message : Message) (initialCache : QueryCache HashSpec) + (P : Concrete.FewTimeView → Prop) : + Pr[Concrete.PrehitSuccessfulSignerView initialCache secretKey message P | + (simulateQ romImpl (Concrete.signWithView secretKey message)).run initialCache] ≤ + (digestAttemptLimit : ℝ≥0∞) * + cachedMessageEntryCountWhere initialCache secretKey.parameter secretKey.root message P * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [Concrete.signWithView, simulateQ_bind, StateT.run_bind] + refine (probEvent_bind_le_probEvent + (p := Concrete.PrehitSelectedView initialCache secretKey message P) ?_).trans + (Concrete.probEvent_signDigestLoop_prehitSelectedView_le_cachedCount + digestAttemptLimit secretKey message initialCache initialCache P) + intro loopResult hloop hnotPrehit + cases hloopResult : loopResult.1 with + | none => + refine probEvent_eq_zero ?_ + intro result hresult hevent + have hresultEq : result = ((none, none), loopResult.2) := by + simpa only [hloopResult, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hresult + obtain ⟨signature, view, hsuccessful, _⟩ := hevent + rw [hresultEq] at hsuccessful + simp at hsuccessful + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + refine probEvent_eq_zero ?_ + intro result hresult hevent + rw [simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hresult + obtain ⟨⟨signatureResult, signatureCache⟩, hsignature, hpure⟩ := hresult + have hpureEq : result = + ((signatureResult, some (Concrete.selectedFewTimeView index leaves)), + signatureCache) := by + simpa only [simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hpure + obtain ⟨signature, view, hsuccessful, output, hcached, hP⟩ := hevent + have hpureFirst := congrArg Prod.fst hpureEq + have hsignatureResult : signatureResult = some signature := by + have := congrArg Prod.fst (hpureFirst.symm.trans hsuccessful) + simpa using this + have hsignature' : (some signature, signatureCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (Concrete.signAfterDigest secretKey randomness index leaves)).run loopResult.2) := by + rw [hsignatureResult] at hsignature + simpa only [simulateQ_romImpl_liftM] using hsignature + have hrandomness := Concrete.signAfterDigest_support_some_randomness secretKey randomness + index leaves loopResult.2 signatureCache signature hsignature' + have hcached' : initialCache + (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message randomness)) = some output := by + rw [← hrandomness] + exact hcached + have hloop' : (some (randomness, index, leaves), loopResult.2) ∈ support + ((simulateQ romImpl + (Concrete.signDigestLoop digestAttemptLimit secretKey message)).run initialCache) := by + have heq : loopResult = (some (randomness, index, leaves), loopResult.2) := + Prod.ext hloopResult rfl + rw [← heq] + exact hloop + have hresultOutput := Concrete.signDigestLoop_initial_cached_result + digestAttemptLimit secretKey message randomness index leaves initialCache loopResult.2 + output hcached' hloop' + apply hnotPrehit + refine ⟨randomness, index, leaves, hloopResult, output, hcached', hresultOutput, ?_⟩ + exact hP + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimePrehitArith.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimePrehitArith.lean new file mode 100644 index 00000000..d5e2ced6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimePrehitArith.lean @@ -0,0 +1,121 @@ +import SphincsSecurity.Proof.FewTimeSourceCount + +/-! +# Arithmetic for cached few-time views + +A selected prehit wins a race against the next fresh admissible answer. A working cache of at most +`2^121` entries leaves at least `2^-11` fresh stopping probability per retry, so one favorable +cached input costs at most `2^-117`. Its fresh source also had to be admissible, restoring a +`2^-127` effective weight. Below the range where the final security bound is already trivial, the +resulting fourteen-entry inflation costs less than one bit. +-/ + +namespace SphincsSecurity.Concrete + +open ENNReal + +theorem prehit_race_source_weight : + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ * + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ = + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_natCast] + norm_num [ftsTreeHeight] + +theorem prehit_effective_slots_le {q : Nat} (hq : q ≤ 2 ^ 120) : + (signatureLimit : ℝ≥0∞) * + (1 + q * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹) ≤ + (signatureLimit : ℝ≥0∞) * (129 / 128) := by + have hq' : (q : ℝ≥0∞) ≤ ((2 ^ 120 : Nat) : ℝ≥0∞) := by + exact_mod_cast hq + gcongr + calc + 1 + (q : ℝ≥0∞) * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ≤ + 1 + ((2 ^ 120 : Nat) : ℝ≥0∞) * + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ := by gcongr + _ = 129 / 128 := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_div, + ENNReal.toReal_natCast, ENNReal.toReal_one] + norm_num + +theorem prehit_effective_slots_inflation_pow : + ((129 / 128 : ℝ≥0∞) ^ 14) ≤ 2 := by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + simp only [ENNReal.toReal_pow, ENNReal.toReal_div] + norm_num + +theorem prehit_effective_slots_inflation_pow_le_nine_eighths : + ((129 / 128 : ℝ≥0∞) ^ 14) ≤ 9 / 8 := by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + simp only [ENNReal.toReal_pow, ENNReal.toReal_div] + norm_num + +theorem prehit_origin_inflation_pow_le {q distinct : Nat} + (hq : q ≤ 2 ^ 120) (hdistinct : distinct ≤ 14) : + (1 + q * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹) ^ distinct ≤ 2 := by + have hbase : 1 + (q : ℝ≥0∞) * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ≤ + 129 / 128 := by + have hq' : (q : ℝ≥0∞) ≤ ((2 ^ 120 : Nat) : ℝ≥0∞) := by + exact_mod_cast hq + calc + 1 + (q : ℝ≥0∞) * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ≤ + 1 + ((2 ^ 120 : Nat) : ℝ≥0∞) * + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ := by gcongr + _ = 129 / 128 := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_div, + ENNReal.toReal_natCast, ENNReal.toReal_one] + norm_num + calc + (1 + q * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹) ^ distinct ≤ + (129 / 128 : ℝ≥0∞) ^ distinct := ENNReal.pow_le_pow_left hbase + _ ≤ (129 / 128 : ℝ≥0∞) ^ 14 := by + exact pow_le_pow_right₀ ((by simp : (1 : ℝ≥0∞) ≤ + 1 + q * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹).trans hbase) hdistinct + _ ≤ 2 := prehit_effective_slots_inflation_pow + +theorem prehit_origin_inflation_pow_le_nine_eighths {q distinct : Nat} + (hq : q ≤ 2 ^ 120) (hdistinct : distinct ≤ 14) : + (1 + q * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹) ^ distinct ≤ 9 / 8 := by + have hbase : 1 + (q : ℝ≥0∞) * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ≤ + 129 / 128 := by + have hq' : (q : ℝ≥0∞) ≤ ((2 ^ 120 : Nat) : ℝ≥0∞) := by + exact_mod_cast hq + calc + 1 + (q : ℝ≥0∞) * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ≤ + 1 + ((2 ^ 120 : Nat) : ℝ≥0∞) * + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ := by gcongr + _ = 129 / 128 := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_div, + ENNReal.toReal_natCast, ENNReal.toReal_one] + norm_num + calc + (1 + q * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹) ^ distinct ≤ + (129 / 128 : ℝ≥0∞) ^ distinct := ENNReal.pow_le_pow_left hbase + _ ≤ (129 / 128 : ℝ≥0∞) ^ 14 := by + exact pow_le_pow_right₀ ((by simp : (1 : ℝ≥0∞) ≤ + 1 + q * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹).trans hbase) hdistinct + _ ≤ 9 / 8 := prehit_effective_slots_inflation_pow_le_nine_eighths + +theorem prehit_effective_slots_pow_le {q : Nat} (hq : q ≤ 2 ^ 120) : + ((signatureLimit : ℝ≥0∞) * + (1 + q * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹)) ^ 14 ≤ + 2 * (signatureLimit : ℝ≥0∞) ^ 14 := by + calc + ((signatureLimit : ℝ≥0∞) * + (1 + q * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹)) ^ 14 ≤ + ((signatureLimit : ℝ≥0∞) * (129 / 128)) ^ 14 := by + exact ENNReal.pow_le_pow_left (prehit_effective_slots_le hq) + _ = (signatureLimit : ℝ≥0∞) ^ 14 * (129 / 128) ^ 14 := by + rw [mul_pow] + _ ≤ (signatureLimit : ℝ≥0∞) ^ 14 * 2 := by + gcongr + exact prehit_effective_slots_inflation_pow + _ = 2 * (signatureLimit : ℝ≥0∞) ^ 14 := by rw [mul_comm] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeProbability.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeProbability.lean new file mode 100644 index 00000000..c0b5396f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeProbability.lean @@ -0,0 +1,461 @@ +import SphincsSecurity.Proof.FewTimePatterns + +/-! +# Probability of a fixed few-time coverage pattern + +The relevant part of an admissible digest is its 26-bit index and its fourteen opened 10-bit leaf +coordinates. For a fixed assignment of trees to distinct signing results, the successful tuples +are in bijection with one free index and one free leaf vector per signing result. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +abbrev FewTimeView := Index × (FtsTree → FtsLeaf) + +noncomputable def FewTimeCover.entryView {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (entry : cover.entries) : FewTimeView := + (digestIndex (cover.entryDigest entry), + fun tree => digestLeaves (cover.entryDigest entry) (ftsIndexOf tree)) + +def fewTimeTargetView (index : Index) (targetLeaves : DigestTree → FtsLeaf) : FewTimeView := + (index, fun tree => targetLeaves (ftsIndexOf tree)) + +def FixedFewTimePatternHit {Selected : Type} (assignment : FtsTree → Selected) + (sample : (Selected → FewTimeView) × FewTimeView) : Prop := + (∀ selected, (sample.1 selected).1 = sample.2.1) + ∧ ∀ tree, sample.2.2 tree = (sample.1 (assignment tree)).2 tree + +theorem FewTimeCover.fixedPatternHit {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) : + FixedFewTimePatternHit cover.entryAssignment + (cover.entryView, fewTimeTargetView index targetLeaves) := by + constructor + · intro entry + exact cover.entryDigest_index entry + · intro tree + exact (cover.entryDigest_assigned_leaf tree).symm + +noncomputable instance {Selected : Type} [DecidableEq Selected] (assignment : FtsTree → Selected) : + DecidablePred (FixedFewTimePatternHit assignment) := by + classical + intro sample + exact inferInstance + +def fixedFewTimePatternHitEquiv {Selected : Type} [Fintype Selected] + (assignment : FtsTree → Selected) : + {sample : (Selected → FewTimeView) × FewTimeView // + FixedFewTimePatternHit assignment sample} ≃ + Index × (Selected → FtsTree → FtsLeaf) where + toFun sample := (sample.1.2.1, fun selected => (sample.1.1 selected).2) + invFun free := ⟨ + (fun selected => (free.1, free.2 selected), + (free.1, fun tree => free.2 (assignment tree) tree)), + ⟨fun _ => rfl, fun _ => rfl⟩⟩ + left_inv sample := by + apply Subtype.ext + apply Prod.ext + · funext selected + apply Prod.ext + · exact (sample.2.1 selected).symm + · rfl + · apply Prod.ext + · rfl + · funext tree + exact (sample.2.2 tree).symm + right_inv free := rfl + +theorem fixedFewTimePatternHit_card {Selected : Type} [Fintype Selected] + [DecidableEq Selected] (assignment : FtsTree → Selected) : + Fintype.card {sample : (Selected → FewTimeView) × FewTimeView // + FixedFewTimePatternHit assignment sample} = + 2 ^ totalHeight * (2 ^ (ftsTreeHeight * (ftsTrees - 1))) ^ Fintype.card Selected := by + rw [Fintype.card_congr (fixedFewTimePatternHitEquiv assignment), Fintype.card_prod, + Fintype.card_fun, Fintype.card_fin] + simp only [FtsTree, FtsLeaf, Fintype.card_fun, Fintype.card_fin] + rw [pow_mul] + +theorem fewTimeView_card : Fintype.card FewTimeView = + 2 ^ (totalHeight + ftsTreeHeight * (ftsTrees - 1)) := by + rw [Fintype.card_prod, Fintype.card_fin, Fintype.card_fun, Fintype.card_fin, + Fintype.card_fin, ← pow_mul, ← pow_add] + +theorem fixedFewTimeSample_card (Selected : Type) [Fintype Selected] [DecidableEq Selected] : + Fintype.card ((Selected → FewTimeView) × FewTimeView) = + (2 ^ (totalHeight + ftsTreeHeight * (ftsTrees - 1))) ^ + (Fintype.card Selected + 1) := by + rw [Fintype.card_prod, Fintype.card_fun, fewTimeView_card, pow_succ] + +noncomputable local instance {R : Type} [Fintype R] [Nonempty R] : SampleableType R := + SampleableType.ofFintype R + +theorem probEvent_fixedFewTimePatternHit {Selected : Type} [Fintype Selected] + [DecidableEq Selected] [Nonempty Selected] (assignment : FtsTree → Selected) : + Pr[FixedFewTimePatternHit assignment | + ($ᵗ ((Selected → FewTimeView) × FewTimeView) : + ProbComp ((Selected → FewTimeView) × FewTimeView))] = + (Fintype.card {sample : (Selected → FewTimeView) × FewTimeView // + FixedFewTimePatternHit assignment sample} : Nat) / + Fintype.card ((Selected → FewTimeView) × FewTimeView) := by + rw [probEvent_uniformSample] + congr 1 + exact_mod_cast (Fintype.card_subtype (FixedFewTimePatternHit assignment)).symm + +theorem fixedFewTimePatternHit_card_ratio_eq_inv {Selected : Type} [Fintype Selected] + [DecidableEq Selected] (assignment : FtsTree → Selected) : + (Fintype.card {sample : (Selected → FewTimeView) × FewTimeView // + FixedFewTimePatternHit assignment sample} : ℝ≥0∞) / + Fintype.card ((Selected → FewTimeView) × FewTimeView) = + ((2 ^ (totalHeight * Fintype.card Selected + + ftsTreeHeight * (ftsTrees - 1)) : Nat) : ℝ≥0∞)⁻¹ := by + rw [fixedFewTimePatternHit_card, fixedFewTimeSample_card] + let d := Fintype.card Selected + have hnum : 2 ^ totalHeight * (2 ^ (ftsTreeHeight * (ftsTrees - 1))) ^ d = + 2 ^ (totalHeight + ftsTreeHeight * (ftsTrees - 1) * d) := by + rw [← pow_mul, pow_add] + have hexponent : + (totalHeight + ftsTreeHeight * (ftsTrees - 1)) * (d + 1) = + (totalHeight + ftsTreeHeight * (ftsTrees - 1) * d) + + (totalHeight * d + ftsTreeHeight * (ftsTrees - 1)) := by + ring + have hden : + (2 ^ (totalHeight + ftsTreeHeight * (ftsTrees - 1))) ^ (d + 1) = + 2 ^ (totalHeight + ftsTreeHeight * (ftsTrees - 1) * d) * + 2 ^ (totalHeight * d + ftsTreeHeight * (ftsTrees - 1)) := by + rw [← pow_mul, hexponent, pow_add] + rw [hnum, hden] + rw [div_eq_mul_inv] + have hzero : + ((2 ^ (totalHeight + ftsTreeHeight * (ftsTrees - 1) * d) : Nat) : ℝ≥0∞) ≠ 0 := by + positivity + have htop : + ((2 ^ (totalHeight + ftsTreeHeight * (ftsTrees - 1) * d) : Nat) : ℝ≥0∞) ≠ ∞ := by + simp + rw [Nat.cast_mul, ENNReal.mul_inv (Or.inl hzero) (Or.inl htop)] + rw [← mul_assoc, ENNReal.mul_inv_cancel hzero htop, one_mul] + +theorem probEvent_fixedFewTimePatternHit_eq_inv {Selected : Type} [Fintype Selected] + [DecidableEq Selected] [Nonempty Selected] (assignment : FtsTree → Selected) : + Pr[FixedFewTimePatternHit assignment | + ($ᵗ ((Selected → FewTimeView) × FewTimeView) : + ProbComp ((Selected → FewTimeView) × FewTimeView))] = + ((2 ^ (totalHeight * Fintype.card Selected + + ftsTreeHeight * (ftsTrees - 1)) : Nat) : ℝ≥0∞)⁻¹ := by + rw [probEvent_fixedFewTimePatternHit] + exact fixedFewTimePatternHit_card_ratio_eq_inv assignment + +theorem probEvent_fixedFewTimePatternHit_eq_inv_of_evalDist {Selected : Type} + [Fintype Selected] [DecidableEq Selected] [Nonempty Selected] + (assignment : FtsTree → Selected) + (sampler : ProbComp ((Selected → FewTimeView) × FewTimeView)) + (hsampler : 𝒟[sampler] = + 𝒟[($ᵗ ((Selected → FewTimeView) × FewTimeView) : + ProbComp ((Selected → FewTimeView) × FewTimeView))]) : + Pr[FixedFewTimePatternHit assignment | sampler] = + ((2 ^ (totalHeight * Fintype.card Selected + + ftsTreeHeight * (ftsTrees - 1)) : Nat) : ℝ≥0∞)⁻¹ := + (probEvent_congr' (fun _ _ => Iff.rfl) hsampler).trans + (probEvent_fixedFewTimePatternHit_eq_inv assignment) + +def splitFunctionEquiv {Domain Range : Type} [DecidableEq Domain] + (selected : Finset Domain) : + (Domain → Range) ≃ (selected → Range) × ({index : Domain // index ∉ selected} → Range) where + toFun table := (fun index => table index.1, fun index => table index.1) + invFun tables := fun index => if h : index ∈ selected then tables.1 ⟨index, h⟩ + else tables.2 ⟨index, h⟩ + left_inv table := by + funext index + by_cases h : index ∈ selected <;> simp [h] + right_inv tables := by + apply Prod.ext <;> funext index + · simp [index.2] + · simp [index.2] + +def splitPatternSampleEquiv {Domain Range : Type} [DecidableEq Domain] + (selected : Finset Domain) : + ((Domain → Range) × Range) ≃ + (((selected → Range) × Range) × + ({index : Domain // index ∉ selected} → Range)) where + toFun sample := + (((splitFunctionEquiv selected sample.1).1, sample.2), + (splitFunctionEquiv selected sample.1).2) + invFun sample := + ((splitFunctionEquiv selected).symm (sample.1.1, sample.2), sample.1.2) + left_inv sample := by + apply Prod.ext + · exact (splitFunctionEquiv selected).symm_apply_apply sample.1 + · rfl + right_inv sample := by + have hsplit := (splitFunctionEquiv selected).apply_symm_apply (sample.1.1, sample.2) + exact congrArg (fun tables => ((tables.1, sample.1.2), tables.2)) hsplit + +def FewTimePattern.restrictSample {signatures distinct : Nat} + (pattern : FewTimePattern signatures distinct) + (sample : (Fin signatures → FewTimeView) × FewTimeView) : + (pattern.selected → FewTimeView) × FewTimeView := + (fun selected => sample.1 selected.1, sample.2) + +def FewTimePattern.Hit {signatures distinct : Nat} + (pattern : FewTimePattern signatures distinct) + (sample : (Fin signatures → FewTimeView) × FewTimeView) : Prop := + FixedFewTimePatternHit pattern.assignment (pattern.restrictSample sample) + +noncomputable instance {signatures distinct : Nat} + (pattern : FewTimePattern signatures distinct) : DecidablePred pattern.Hit := by + classical + intro sample + exact inferInstance + +theorem evalDist_restrictPatternSample_uniform {signatures distinct : Nat} + (pattern : FewTimePattern signatures distinct) : + 𝒟[(pattern.restrictSample <$> ($ᵗ ((Fin signatures → FewTimeView) × FewTimeView) : + ProbComp ((Fin signatures → FewTimeView) × FewTimeView)))] = + 𝒟[($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : + ProbComp ((pattern.selected → FewTimeView) × FewTimeView))] := by + classical + let split := splitPatternSampleEquiv (Range := FewTimeView) pattern.selected + have hrewrite : pattern.restrictSample = Prod.fst ∘ split := by + funext sample + rfl + have hmap : + pattern.restrictSample <$> ($ᵗ ((Fin signatures → FewTimeView) × FewTimeView) : + ProbComp ((Fin signatures → FewTimeView) × FewTimeView)) = + Prod.fst <$> (split <$> ($ᵗ ((Fin signatures → FewTimeView) × FewTimeView) : + ProbComp ((Fin signatures → FewTimeView) × FewTimeView))) := by + simp only [Functor.map_map, hrewrite, Function.comp_def] + rw [hmap] + have hsplit : + 𝒟[(split <$> ($ᵗ ((Fin signatures → FewTimeView) × FewTimeView) : + ProbComp ((Fin signatures → FewTimeView) × FewTimeView)))] = + 𝒟[($ᵗ (((pattern.selected → FewTimeView) × FewTimeView) × + ({index : Fin signatures // index ∉ pattern.selected} → FewTimeView)) : + ProbComp (((pattern.selected → FewTimeView) × FewTimeView) × + ({index : Fin signatures // index ∉ pattern.selected} → FewTimeView)))] := + evalDist_map_bijective_uniform_cross + (α := (Fin signatures → FewTimeView) × FewTimeView) + (β := ((pattern.selected → FewTimeView) × FewTimeView) × + ({index : Fin signatures // index ∉ pattern.selected} → FewTimeView)) + split split.bijective + rw [evalDist_map, hsplit, ← evalDist_map] + exact evalDist_map_fst_uniformSample_prod + +def subtypeProdLeftEquiv {A B : Type} (P : A → Prop) : + {pair : A × B // P pair.1} ≃ {a : A // P a} × B where + toFun pair := (⟨pair.1.1, pair.2⟩, pair.1.2) + invFun pair := ⟨(pair.1.1, pair.2), pair.1.2⟩ + left_inv pair := by cases pair; rfl + right_inv pair := by cases pair with | mk left right => cases left; rfl + +def fewTimePatternHitEquiv {signatures distinct : Nat} + (pattern : FewTimePattern signatures distinct) : + {sample : (Fin signatures → FewTimeView) × FewTimeView // pattern.Hit sample} ≃ + {sample : (pattern.selected → FewTimeView) × FewTimeView // + FixedFewTimePatternHit pattern.assignment sample} × + ({index : Fin signatures // index ∉ pattern.selected} → FewTimeView) := + ((splitPatternSampleEquiv (Range := FewTimeView) pattern.selected).subtypeEquiv + (fun _ => Iff.rfl)).trans (subtypeProdLeftEquiv _) + +theorem probEvent_fewTimePatternHit_eq_inv {signatures distinct : Nat} + (pattern : FewTimePattern signatures distinct) : + Pr[pattern.Hit | + ($ᵗ ((Fin signatures → FewTimeView) × FewTimeView) : + ProbComp ((Fin signatures → FewTimeView) × FewTimeView))] = + ((2 ^ (totalHeight * distinct + ftsTreeHeight * (ftsTrees - 1)) : Nat) : ℝ≥0∞)⁻¹ := by + classical + let complement := {index : Fin signatures // index ∉ pattern.selected} → FewTimeView + have hnum : + Fintype.card {sample : (Fin signatures → FewTimeView) × FewTimeView // + pattern.Hit sample} = + Fintype.card {sample : (pattern.selected → FewTimeView) × FewTimeView // + FixedFewTimePatternHit pattern.assignment sample} * Fintype.card complement := by + rw [Fintype.card_congr (fewTimePatternHitEquiv pattern), Fintype.card_prod] + have hden : Fintype.card ((Fin signatures → FewTimeView) × FewTimeView) = + Fintype.card ((pattern.selected → FewTimeView) × FewTimeView) * + Fintype.card complement := by + rw [Fintype.card_congr (splitPatternSampleEquiv + (Range := FewTimeView) pattern.selected), Fintype.card_prod] + rw [probEvent_uniformSample, ← Fintype.card_subtype pattern.Hit, hnum, hden, + Nat.cast_mul, Nat.cast_mul] + rw [ENNReal.mul_div_mul_right _ _ (by + exact_mod_cast (Fintype.card_ne_zero (α := complement))) (by simp)] + rw [fixedFewTimePatternHit_card_ratio_eq_inv, Fintype.card_coe, + pattern.card_selected] + +def AnyFewTimePatternHit (signatures distinct : Nat) + (sample : (Fin signatures → FewTimeView) × FewTimeView) : Prop := + ∃ pattern : FewTimePattern signatures distinct, pattern.Hit sample + +noncomputable instance (signatures distinct : Nat) : + DecidablePred (AnyFewTimePatternHit signatures distinct) := + fun sample => Classical.propDecidable (AnyFewTimePatternHit signatures distinct sample) + +theorem probEvent_anyFewTimePatternHit_le {signatures distinct : Nat} : + Pr[AnyFewTimePatternHit signatures distinct | + ($ᵗ ((Fin signatures → FewTimeView) × FewTimeView) : + ProbComp ((Fin signatures → FewTimeView) × FewTimeView))] ≤ + (Fintype.card (FewTimePattern signatures distinct) : ℝ≥0∞) * + ((2 ^ (totalHeight * distinct + ftsTreeHeight * (ftsTrees - 1)) : Nat) : ℝ≥0∞)⁻¹ := by + classical + let sampler := ($ᵗ ((Fin signatures → FewTimeView) × FewTimeView) : + ProbComp ((Fin signatures → FewTimeView) × FewTimeView)) + calc + Pr[AnyFewTimePatternHit signatures distinct | sampler] = + Pr[fun sample => ∃ pattern ∈ (Finset.univ : + Finset (FewTimePattern signatures distinct)), pattern.Hit sample | sampler] := by + congr 1 + funext sample + simp [AnyFewTimePatternHit] + _ ≤ ∑ pattern ∈ (Finset.univ : Finset (FewTimePattern signatures distinct)), + Pr[pattern.Hit | sampler] := + probEvent_exists_finset_le_sum Finset.univ sampler + (fun (pattern : FewTimePattern signatures distinct) sample => pattern.Hit sample) + _ = ∑ _pattern ∈ (Finset.univ : Finset (FewTimePattern signatures distinct)), + ((2 ^ (totalHeight * distinct + ftsTreeHeight * (ftsTrees - 1)) : Nat) : ℝ≥0∞)⁻¹ := by + apply Finset.sum_congr rfl + intro pattern _ + exact probEvent_fewTimePatternHit_eq_inv pattern + _ = (Fintype.card (FewTimePattern signatures distinct) : ℝ≥0∞) * + ((2 ^ (totalHeight * distinct + ftsTreeHeight * (ftsTrees - 1)) : Nat) : ℝ≥0∞)⁻¹ := by + rw [Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + +theorem fewTimePattern_term_common_denominator (signatures distinct : Nat) + (hdistinct : distinct ≤ 14) : + (Fintype.card (FewTimePattern signatures distinct) : ℝ≥0∞) * + ((2 ^ (26 * distinct + 140) : Nat) : ℝ≥0∞)⁻¹ = + (Fintype.card (FewTimePattern signatures distinct) * + 2 ^ (26 * (14 - distinct)) : ℕ) * + ((2 ^ 504 : Nat) : ℝ≥0∞)⁻¹ := by + let factor : ℝ≥0∞ := (2 ^ (26 * (14 - distinct)) : ℕ) + have hfactorZero : factor ≠ 0 := by positivity + have hfactorTop : factor ≠ ∞ := by simp [factor] + rw [← div_eq_mul_inv, ← div_eq_mul_inv, + ← ENNReal.mul_div_mul_right + (Fintype.card (FewTimePattern signatures distinct) : ℝ≥0∞) + ((2 ^ (26 * distinct + 140) : Nat) : ℝ≥0∞) hfactorZero hfactorTop] + have hexponent : 26 * distinct + 140 + 26 * (14 - distinct) = 504 := by omega + apply congrArg₂ (· / ·) + · rw [Nat.cast_mul] + · change ((2 ^ (26 * distinct + 140) : Nat) : ℝ≥0∞) * + ((2 ^ (26 * (14 - distinct)) : Nat) : ℝ≥0∞) = + ((2 ^ 504 : Nat) : ℝ≥0∞) + rw [← Nat.cast_mul, ← pow_add, hexponent] + +def SomeFewTimePatternHit (signatures : Nat) + (sample : (Fin signatures → FewTimeView) × FewTimeView) : Prop := + ∃ distinct ∈ Finset.Icc 1 14, AnyFewTimePatternHit signatures distinct sample + +noncomputable instance (signatures : Nat) : DecidablePred (SomeFewTimePatternHit signatures) := + fun sample => Classical.propDecidable (SomeFewTimePatternHit signatures sample) + +set_option exponentiation.threshold 400 in +theorem fewTimePattern_unionBound_le {signatures : Nat} + (hsignatures : signatures ≤ signatureLimit) : + (∑ distinct ∈ Finset.Icc 1 14, + (Fintype.card (FewTimePattern signatures distinct) : ℝ≥0∞) * + ((2 ^ (26 * distinct + 140) : Nat) : ℝ≥0∞)⁻¹) ≤ + ((2 ^ 122 : Nat) : ℝ≥0∞)⁻¹ := by + classical + calc + (∑ distinct ∈ Finset.Icc 1 14, + (Fintype.card (FewTimePattern signatures distinct) : ℝ≥0∞) * + ((2 ^ (26 * distinct + 140) : Nat) : ℝ≥0∞)⁻¹) = + ∑ distinct ∈ Finset.Icc 1 14, + (Fintype.card (FewTimePattern signatures distinct) * + 2 ^ (26 * (14 - distinct)) : Nat) * + ((2 ^ 504 : Nat) : ℝ≥0∞)⁻¹ := by + apply Finset.sum_congr rfl + intro distinct hdistinct + exact fewTimePattern_term_common_denominator signatures distinct + (Finset.mem_Icc.mp hdistinct).2 + _ = ((∑ distinct ∈ Finset.Icc 1 14, + Fintype.card (FewTimePattern signatures distinct) * + 2 ^ (26 * (14 - distinct)) : Nat) : ℝ≥0∞) * + ((2 ^ 504 : Nat) : ℝ≥0∞)⁻¹ := by + rw [← Finset.sum_mul, Nat.cast_sum] + _ ≤ ((2 ^ 382 : Nat) : ℝ≥0∞) * ((2 ^ 504 : Nat) : ℝ≥0∞)⁻¹ := by + gcongr + exact_mod_cast fewTimePattern_sum_le hsignatures + _ = ((2 ^ 122 : Nat) : ℝ≥0∞)⁻¹ := by + have hzero : ((2 ^ 382 : Nat) : ℝ≥0∞) ≠ 0 := by positivity + have htop : ((2 ^ 382 : Nat) : ℝ≥0∞) ≠ ∞ := by simp + rw [show 504 = 382 + 122 by norm_num, pow_add, Nat.cast_mul, + ENNReal.mul_inv (Or.inl hzero) (Or.inl htop), ← mul_assoc, + ENNReal.mul_inv_cancel hzero htop, one_mul] + +set_option exponentiation.threshold 400 in +theorem probEvent_someFewTimePatternHit_le {signatures : Nat} + (hsignatures : signatures ≤ signatureLimit) : + Pr[SomeFewTimePatternHit signatures | + ($ᵗ ((Fin signatures → FewTimeView) × FewTimeView) : + ProbComp ((Fin signatures → FewTimeView) × FewTimeView))] ≤ + ((2 ^ 122 : Nat) : ℝ≥0∞)⁻¹ := by + classical + let sampler := ($ᵗ ((Fin signatures → FewTimeView) × FewTimeView) : + ProbComp ((Fin signatures → FewTimeView) × FewTimeView)) + calc + Pr[SomeFewTimePatternHit signatures | sampler] = + Pr[fun sample => ∃ distinct ∈ Finset.Icc 1 14, + AnyFewTimePatternHit signatures distinct sample | sampler] := rfl + _ ≤ ∑ distinct ∈ Finset.Icc 1 14, + Pr[AnyFewTimePatternHit signatures distinct | sampler] := + probEvent_exists_finset_le_sum (Finset.Icc 1 14) sampler + (fun distinct sample => AnyFewTimePatternHit signatures distinct sample) + _ ≤ ∑ distinct ∈ Finset.Icc 1 14, + (Fintype.card (FewTimePattern signatures distinct) : ℝ≥0∞) * + ((2 ^ (26 * distinct + 140) : Nat) : ℝ≥0∞)⁻¹ := by + apply Finset.sum_le_sum + intro distinct _ + simpa only [totalHeight, ftsTreeHeight, ftsTrees] using + (probEvent_anyFewTimePatternHit_le (signatures := signatures) (distinct := distinct)) + _ ≤ ((2 ^ 122 : Nat) : ℝ≥0∞)⁻¹ := + fewTimePattern_unionBound_le hsignatures + +noncomputable def FewTimeCover.transcriptViews {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) : + Fin signingLog.length → FewTimeView := + Function.extend cover.logIndex cover.entryView (fun _ => default) + +theorem FewTimeCover.patternHit {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) : + cover.pattern.Hit (cover.transcriptViews, fewTimeTargetView index targetLeaves) := by + constructor + · intro selected + obtain ⟨entry, _, hentry⟩ := Finset.mem_image.1 selected.2 + have hview : cover.transcriptViews selected.1 = cover.entryView entry := by + rw [← hentry] + exact cover.logIndex_injective.extend_apply cover.entryView (fun _ => default) entry + change (cover.transcriptViews selected.1).1 = index + rw [hview] + exact cover.entryDigest_index entry + · intro tree + change targetLeaves (ftsIndexOf tree) = + (cover.transcriptViews (cover.logIndex (cover.entryAssignment tree))).2 tree + rw [FewTimeCover.transcriptViews, + cover.logIndex_injective.extend_apply cover.entryView (fun _ => default)] + exact (cover.entryDigest_assigned_leaf tree).symm + +theorem FewTimeCover.somePatternHit {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) : + SomeFewTimePatternHit signingLog.length + (cover.transcriptViews, fewTimeTargetView index targetLeaves) := by + refine ⟨cover.entries.card, Finset.mem_Icc.2 + ⟨cover.entries_card_pos, cover.entries_card_le_trees⟩, cover.pattern, cover.patternHit⟩ + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeRace.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeRace.lean new file mode 100644 index 00000000..7b2a6d6b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeRace.lean @@ -0,0 +1,617 @@ +import SphincsSecurity.Proof.FewTimePrehitArith + +/-! +# A weighted prefix split for the digest race + +The cached branch of a digest retry loop wins immediately, a rejected answer continues, and an +ordinary successful answer ends the event. The weighted split below keeps the continuation +probability instead of paying one full copy of its bound at every retry. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +noncomputable local instance : SampleableType Randomness := + SampleableType.ofFintype Randomness + +theorem cachedMessageEntryCount_le_enncard + (cache : QueryCache HashSpec) (parameter : PublicParameter) + (root : Digest) (message : Message) : + cachedMessageEntryCount cache parameter root message ≤ QueryCache.enncard cache := by + have hsubset : cachedMessageInputSet cache parameter root message ⊆ cache.toSet := by + intro entry hentry + exact hentry.1 + simpa only [cachedMessageEntryCount, QueryCache.enncard] using + ENat.toENNReal_mono (Set.encard_le_encard hsubset) + +set_option maxRecDepth 100000 in +theorem Concrete.probEvent_signAttempt_fresh_success_eq + (secretKey : SecretKey) (message : Message) (randomness : Randomness) + (cache : QueryCache HashSpec) + (hcache : cache (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = none) : + Pr[fun result => result.1 ≠ none | + (simulateQ (randomOracle : QueryImpl HashSpec _) + (signAttempt secretKey message randomness)).run cache] = + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ := by + have hcoordinates := evalDist_signAttempt_fresh_bind_coordinates + secretKey message randomness cache hcache + (fun result => pure result) + simp only [bind_pure] at hcoordinates + rw [probEvent_congr' (fun _ _ => Iff.rfl) hcoordinates] + change Pr[fun result => result.1 ≠ none | + ($ᵗ HashOutputCoordinates : ProbComp HashOutputCoordinates) >>= + pure ∘ fun coordinates => + (signAttemptResultOfOutput (hashOutputCoordinatesEquiv.symm coordinates), + cache.cacheQuery + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) + (hashOutputCoordinatesEquiv.symm coordinates))] = _ + rw [probEvent_bind_pure_comp] + let event : HashOutputCoordinates → Prop := fun coordinates => coordinates.1.2 = 0 + calc + Pr[fun coordinates : HashOutputCoordinates => + (signAttemptResultOfOutput (hashOutputCoordinatesEquiv.symm coordinates), + cache.cacheQuery + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) + (hashOutputCoordinatesEquiv.symm coordinates)).1 ≠ none | + ($ᵗ HashOutputCoordinates : ProbComp HashOutputCoordinates)] = + Pr[event | ($ᵗ HashOutputCoordinates : ProbComp HashOutputCoordinates)] := by + apply probEvent_congr' + · intro coordinates _ + exact signAttemptResultOfOutput_coordinates_ne_none_iff coordinates + · rfl + _ = Pr[fun coordinates : FewTimeView × FtsLeaf => coordinates.2 = 0 | + Prod.fst <$> ($ᵗ HashOutputCoordinates : ProbComp HashOutputCoordinates)] := by + rw [probEvent_map] + rfl + _ = Pr[fun coordinates : FewTimeView × FtsLeaf => coordinates.2 = 0 | + ($ᵗ (FewTimeView × FtsLeaf) : ProbComp (FewTimeView × FtsLeaf))] := by + apply probEvent_congr' + · intro coordinates _ + rfl + · exact evalDist_map_fst_uniformSample_prod + _ = _ := by + simpa only [and_true, probEvent_True_eq_sub, probFailure_of_liftM_PMF, + tsub_zero, mul_one] using + probEvent_uniformDigestCoordinates_admissible_view (fun _ => True) + +theorem Concrete.signAttempt_enncard_le + (secretKey : SecretKey) (message : Message) (randomness : Randomness) + (cache : QueryCache HashSpec) + (result : Option (Index × (DigestTree → FtsLeaf)) × QueryCache HashSpec) + (hresult : result ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAttempt secretKey message randomness)).run cache)) : + QueryCache.enncard result.2 ≤ QueryCache.enncard cache + 1 := by + rw [simulateQ_signAttempt_run_eq, mem_support_bind_iff] at hresult + obtain ⟨oracleResult, horacle, hpure⟩ := hresult + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + exact romImpl_hash_query_enncard_le + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) + cache oracleResult horacle + +set_option maxRecDepth 100000 in +theorem uniform_randomness_messageInput_cacheHit_le_two_neg_seven + (secretKey : SecretKey) (message : Message) (cache : QueryCache HashSpec) + (hcache : QueryCache.enncard cache ≤ ((2 ^ 121 : Nat) : ℝ≥0∞)) : + Pr[fun randomness : Randomness => ∃ output, + cache (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message randomness)) = some output | + $ᵗ Randomness] ≤ ((2 ^ 7 : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ ≤ cachedMessageEntryCount cache secretKey.parameter secretKey.root message * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ := + uniform_randomness_messageInput_cacheHit_le_cachedMessageEntryCount + secretKey.parameter secretKey.root message cache + _ ≤ ((2 ^ 121 : Nat) : ℝ≥0∞) * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ := by + gcongr + exact (cachedMessageEntryCount_le_enncard cache secretKey.parameter + secretKey.root message).trans hcache + _ = ((2 ^ 7 : Nat) : ℝ≥0∞)⁻¹ := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_natCast] + norm_num [randomnessBits] + +set_option maxRecDepth 100000 in +theorem uniform_randomness_messageInput_cacheMiss_ge_one_sub_two_neg_seven + (secretKey : SecretKey) (message : Message) (cache : QueryCache HashSpec) + (hcache : QueryCache.enncard cache ≤ ((2 ^ 121 : Nat) : ℝ≥0∞)) : + 1 - ((2 ^ 7 : Nat) : ℝ≥0∞)⁻¹ ≤ + Pr[fun randomness : Randomness => + cache (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message randomness)) = none | + $ᵗ Randomness] := by + let miss : Randomness → Prop := fun randomness => + cache (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message randomness)) = none + apply probEvent_one_sub_le_of_compl_le (by simp only [probFailure_of_liftM_PMF]) + calc + Pr[fun randomness => ¬ miss randomness | $ᵗ Randomness] = + Pr[fun randomness : Randomness => ∃ output, + cache (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message randomness)) = some output | + $ᵗ Randomness] := by + apply probEvent_congr' + · intro randomness _ + exact Option.ne_none_iff_exists' + · rfl + _ ≤ _ := uniform_randomness_messageInput_cacheHit_le_two_neg_seven + secretKey message cache hcache + +noncomputable def Concrete.signDigestAttemptPrefix + (secretKey : SecretKey) (message : Message) (cache : QueryCache HashSpec) : + ProbComp (Randomness × + (Option (Index × (DigestTree → FtsLeaf)) × QueryCache HashSpec)) := + ($ᵗ Randomness) >>= fun randomness => + (simulateQ (randomOracle : QueryImpl HashSpec _) + (signAttempt secretKey message randomness)).run cache >>= fun result => + pure (randomness, result) + +theorem uniform_randomness_messageInput_cacheHit_le_one_half + (secretKey : SecretKey) (message : Message) (cache : QueryCache HashSpec) + (hcache : QueryCache.enncard cache ≤ ((2 ^ 127 : Nat) : ℝ≥0∞)) : + Pr[fun randomness : Randomness => ∃ output, + cache (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message randomness)) = some output | + $ᵗ Randomness] ≤ ((2 ^ 1 : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ ≤ cachedMessageEntryCount cache secretKey.parameter secretKey.root message * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ := + uniform_randomness_messageInput_cacheHit_le_cachedMessageEntryCount + secretKey.parameter secretKey.root message cache + _ ≤ ((2 ^ 127 : Nat) : ℝ≥0∞) * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ := by + gcongr + exact (cachedMessageEntryCount_le_enncard cache secretKey.parameter + secretKey.root message).trans hcache + _ = ((2 ^ 1 : Nat) : ℝ≥0∞)⁻¹ := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_natCast] + norm_num [randomnessBits] + +set_option maxRecDepth 100000 in +theorem uniform_randomness_messageInput_cacheMiss_ge_one_sub_one_half + (secretKey : SecretKey) (message : Message) (cache : QueryCache HashSpec) + (hcache : QueryCache.enncard cache ≤ ((2 ^ 127 : Nat) : ℝ≥0∞)) : + 1 - ((2 ^ 1 : Nat) : ℝ≥0∞)⁻¹ ≤ + Pr[fun randomness : Randomness => + cache (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message randomness)) = none | + $ᵗ Randomness] := by + let miss : Randomness → Prop := fun randomness => + cache (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message randomness)) = none + apply probEvent_one_sub_le_of_compl_le (by simp only [probFailure_of_liftM_PMF]) + calc + Pr[fun randomness => ¬ miss randomness | $ᵗ Randomness] = + Pr[fun randomness : Randomness => ∃ output, + cache (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message randomness)) = some output | + $ᵗ Randomness] := by + apply probEvent_congr' + · intro randomness _ + exact Option.ne_none_iff_exists' + · rfl + _ ≤ _ := uniform_randomness_messageInput_cacheHit_le_one_half + secretKey message cache hcache + + +set_option maxRecDepth 100000 in +set_option linter.constructorNameAsVariable false in +theorem Concrete.probEvent_signDigestAttemptPrefix_success_ge + (secretKey : SecretKey) (message : Message) (cache : QueryCache HashSpec) + (hcache : QueryCache.enncard cache ≤ ((2 ^ 127 : Nat) : ℝ≥0∞)) : + ((2 ^ 11 : Nat) : ℝ≥0∞)⁻¹ ≤ + Pr[fun attempt => attempt.2.1 ≠ none | + signDigestAttemptPrefix secretKey message cache] := by + have harithmetic : ((2 ^ 11 : Nat) : ℝ≥0∞)⁻¹ ≤ + (1 - ((2 ^ 1 : Nat) : ℝ≥0∞)⁻¹) * + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ := by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_mul, + ENNReal.toReal_sub_of_le (by norm_num) (by finiteness)] + simp only [ENNReal.toReal_inv, ENNReal.toReal_natCast, ENNReal.toReal_one] + norm_num [ftsTreeHeight] + refine harithmetic.trans ?_ + rw [signDigestAttemptPrefix] + apply mul_le_probEvent_bind + · exact uniform_randomness_messageInput_cacheMiss_ge_one_sub_one_half + secretKey message cache hcache + · intro randomness _hrandomness hmiss + change ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ ≤ + Pr[fun attempt => attempt.2.1 ≠ none | + (simulateQ (randomOracle : QueryImpl HashSpec _) + (signAttempt secretKey message randomness)).run cache >>= fun result => + pure (randomness, result)] + rw [show (fun result => pure (randomness, result)) = + pure ∘ fun result => (randomness, result) from rfl, + probEvent_bind_pure_comp] + exact le_of_eq (probEvent_signAttempt_fresh_success_eq + secretKey message randomness cache hmiss).symm + +set_option maxRecDepth 100000 in +set_option linter.constructorNameAsVariable false in +theorem Concrete.probEvent_signDigestAttemptPrefix_retry_le + (secretKey : SecretKey) (message : Message) (cache : QueryCache HashSpec) + (hcache : QueryCache.enncard cache ≤ ((2 ^ 127 : Nat) : ℝ≥0∞)) : + Pr[fun attempt => attempt.2.1 = none | + signDigestAttemptPrefix secretKey message cache] ≤ + 1 - ((2 ^ 11 : Nat) : ℝ≥0∞)⁻¹ := by + have hcompl := probEvent_compl_le_of_one_sub_le + (mx := signDigestAttemptPrefix secretKey message cache) + (p := fun attempt => attempt.2.1 ≠ none) + (ε := 1 - ((2 ^ 11 : Nat) : ℝ≥0∞)⁻¹) + (by simp [signDigestAttemptPrefix]) (by + calc + 1 - (1 - ((2 ^ 11 : Nat) : ℝ≥0∞)⁻¹) = + ((2 ^ 11 : Nat) : ℝ≥0∞)⁻¹ := by + exact ENNReal.sub_sub_cancel (by simp) (by norm_num) + _ ≤ _ := probEvent_signDigestAttemptPrefix_success_ge + secretKey message cache hcache) + simpa only [not_ne_iff] using hcompl + +theorem Concrete.signDigestLoop_run_succ_eq_attemptPrefix + (attempts : Nat) (secretKey : SecretKey) (message : Message) + (cache : QueryCache HashSpec) : + (simulateQ romImpl + (signDigestLoop (attempts + 1) secretKey message)).run cache = + signDigestAttemptPrefix secretKey message cache >>= fun attempt => + signDigestLoopContinuation attempts secretKey message attempt.1 attempt.2 := by + rw [signDigestLoop_run_succ_eq, signDigestAttemptPrefix] + simp only [bind_assoc, pure_bind] + +def Concrete.FavorablePrehitAttempt (referenceCache : QueryCache HashSpec) + (secretKey : SecretKey) (message : Message) (P : FewTimeView → Prop) + (attempt : Randomness × + (Option (Index × (DigestTree → FtsLeaf)) × QueryCache HashSpec)) : Prop := + ∃ output, referenceCache + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message attempt.1)) = some output + ∧ signAttemptResultOfOutput output ≠ none + ∧ P (hashOutputFewTimeView output) + +set_option maxRecDepth 100000 in +set_option linter.constructorNameAsVariable false in +theorem Concrete.probEvent_signDigestAttemptPrefix_favorablePrehit_le + (referenceCache workingCache : QueryCache HashSpec) + (secretKey : SecretKey) (message : Message) (P : FewTimeView → Prop) : + Pr[FavorablePrehitAttempt referenceCache secretKey message P | + signDigestAttemptPrefix secretKey message workingCache] ≤ + cachedMessageEntryCountWhere referenceCache secretKey.parameter secretKey.root message P * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [signDigestAttemptPrefix] + refine (probEvent_bind_le_probEvent + (p := fun randomness : Randomness => ∃ output, + referenceCache + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = some output + ∧ signAttemptResultOfOutput output ≠ none + ∧ P (hashOutputFewTimeView output)) ?_).trans + (uniform_randomness_messageInput_cacheHitWhere_le_cachedCount + secretKey.parameter secretKey.root message referenceCache P) + intro randomness _hrandomness hnotFavorable + refine probEvent_eq_zero ?_ + intro attempt hattempt hevent + rw [mem_support_bind_iff] at hattempt + obtain ⟨attemptResult, _hattemptResult, hpure⟩ := hattempt + simp only [support_pure, Set.mem_singleton_iff] at hpure + obtain ⟨output, hcached, hsuccessful, hP⟩ := hevent + apply hnotFavorable + refine ⟨output, ?_, hsuccessful, hP⟩ + rw [congrArg Prod.fst hpure] at hcached + exact hcached + +theorem probEvent_bind_le_probEvent_add_mul + {m : Type _ → Type _} [Monad m] + [MonadLiftT m SPMF] [LawfulMonadLiftT m SPMF] + [MonadLiftT m SetM] [EvalDistCompatible m] + {alpha beta : Type} {mx : m alpha} {my : alpha → m beta} + {event : beta → Prop} {hit retry : alpha → Prop} {epsilon : ℝ≥0∞} + (hoff : ∀ x ∈ support mx, ¬ hit x → ¬ retry x → + Pr[event | my x] = 0) + (hretry : ∀ x ∈ support mx, retry x → Pr[event | my x] ≤ epsilon) : + Pr[event | mx >>= my] ≤ + Pr[hit | mx] + Pr[retry | mx] * epsilon := by + classical + rw [probEvent_bind_eq_tsum, probEvent_eq_tsum_indicator, + probEvent_eq_tsum_indicator] + calc + ∑' x, Pr[= x | mx] * Pr[event | my x] ≤ + ∑' x, ({x | hit x}.indicator (fun y => Pr[= y | mx]) x + + {x | retry x}.indicator (fun y => Pr[= y | mx] * epsilon) x) := by + apply ENNReal.tsum_le_tsum + intro x + by_cases hx : x ∈ support mx + · by_cases hhit : hit x + · calc + Pr[= x | mx] * Pr[event | my x] ≤ Pr[= x | mx] := by + simpa only [mul_one] using mul_le_mul' le_rfl probEvent_le_one + _ ≤ {x | hit x}.indicator (fun y => Pr[= y | mx]) x + + {x | retry x}.indicator (fun y => Pr[= y | mx] * epsilon) x := by + simp [hhit] + · by_cases hrx : retry x + · calc + Pr[= x | mx] * Pr[event | my x] ≤ + Pr[= x | mx] * epsilon := mul_le_mul' le_rfl (hretry x hx hrx) + _ = {x | hit x}.indicator (fun y => Pr[= y | mx]) x + + {x | retry x}.indicator (fun y => Pr[= y | mx] * epsilon) x := by + simp [hhit, hrx] + · rw [hoff x hx hhit hrx] + simp [hhit, hrx] + · rw [probOutput_eq_zero_of_not_mem_support hx] + simp + _ = (∑' x, {x | hit x}.indicator (fun y => Pr[= y | mx]) x) + + ∑' x, {x | retry x}.indicator (fun y => Pr[= y | mx] * epsilon) x := + ENNReal.tsum_add + _ = (∑' x, {x | hit x}.indicator (fun y => Pr[= y | mx]) x) + + (∑' x, {x | retry x}.indicator (fun y => Pr[= y | mx]) x) * epsilon := by + rw [← ENNReal.tsum_mul_right] + congr 1 + apply tsum_congr + intro x + by_cases hrx : retry x <;> simp [hrx] + +theorem prehit_race_recurrence_arith (count : ℝ≥0∞) (hcount : count ≠ ∞) : + count * ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ + + (1 - ((2 ^ 11 : Nat) : ℝ≥0∞)⁻¹) * + (count * ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹) ≤ + count * ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ := by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul] + rw [ENNReal.toReal_sub_of_le (by norm_num) (by finiteness)] + simp only [ENNReal.toReal_inv, ENNReal.toReal_natCast, ENNReal.toReal_one] + norm_num [randomnessBits] + ring_nf + exact le_rfl + +set_option maxRecDepth 100000 in +set_option linter.constructorNameAsVariable false in +theorem Concrete.probEvent_signDigestLoop_prehitSelectedView_le_race + (attempts : Nat) (secretKey : SecretKey) (message : Message) + (referenceCache workingCache : QueryCache HashSpec) (P : FewTimeView → Prop) + (hreference : referenceCache ≤ workingCache) + (hbudget : QueryCache.enncard workingCache + (attempts : ℝ≥0∞) ≤ + ((2 ^ 127 : Nat) : ℝ≥0∞)) : + Pr[PrehitSelectedView referenceCache secretKey message P | + (simulateQ romImpl + (signDigestLoop attempts secretKey message)).run workingCache] ≤ + cachedMessageEntryCountWhere referenceCache secretKey.parameter secretKey.root message P * + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ := by + induction attempts generalizing workingCache with + | zero => + refine le_of_eq_of_le (probEvent_eq_zero ?_) zero_le + intro result hresult hevent + have hresultEq : result = (none, workingCache) := by + simpa only [signDigestLoop, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hresult + obtain ⟨randomness, index, leaves, hselected, _⟩ := hevent + rw [hresultEq] at hselected + simp at hselected + | succ attempts ih => + rw [signDigestLoop_run_succ_eq_attemptPrefix] + let count := cachedMessageEntryCountWhere referenceCache secretKey.parameter + secretKey.root message P + let epsilon := count * ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ + refine (probEvent_bind_le_probEvent_add_mul + (hit := FavorablePrehitAttempt referenceCache secretKey message P) + (retry := fun attempt => attempt.2.1 = none) + (epsilon := epsilon) ?_ ?_).trans ?_ + · intro attempt _hattempt hnotHit hnotRetry + cases hattemptResult : attempt.2.1 with + | none => exact (hnotRetry hattemptResult).elim + | some selected => + rcases selected with ⟨selectedIndex, selectedLeaves⟩ + refine probEvent_eq_zero ?_ + intro result hresult hevent + have hresultEq : result = + (some (attempt.1, selectedIndex, selectedLeaves), attempt.2.2) := by + simpa only [signDigestLoopContinuation, hattemptResult, support_pure, + Set.mem_singleton_iff] using hresult + obtain ⟨foundRandomness, foundIndex, foundLeaves, hfound, output, hcached, + houtputResult, hP⟩ := hevent + have hrandomness : attempt.1 = foundRandomness := by + have htuple : (attempt.1, selectedIndex, selectedLeaves) = + (foundRandomness, foundIndex, foundLeaves) := + Option.some.inj ((congrArg Prod.fst hresultEq).symm.trans hfound) + exact congrArg Prod.fst htuple + apply hnotHit + refine ⟨output, ?_, ?_, hP⟩ + · rw [hrandomness] + exact hcached + · rw [houtputResult] + simp + · intro attempt hattempt hrejected + rw [signDigestAttemptPrefix, mem_support_bind_iff] at hattempt + obtain ⟨randomness, _hrandomness, hattempt⟩ := hattempt + rw [mem_support_bind_iff] at hattempt + obtain ⟨attemptResult, hattemptResult, hpure⟩ := hattempt + simp only [support_pure, Set.mem_singleton_iff] at hpure + have hattemptPair : attempt.2 = attemptResult := congrArg Prod.snd hpure + have hgrowth := signAttempt_enncard_le secretKey message randomness workingCache + attemptResult hattemptResult + have hbudget' : QueryCache.enncard attempt.2.2 + (attempts : ℝ≥0∞) ≤ + ((2 ^ 127 : Nat) : ℝ≥0∞) := by + calc + QueryCache.enncard attempt.2.2 + (attempts : ℝ≥0∞) = + QueryCache.enncard attemptResult.2 + (attempts : ℝ≥0∞) := by + rw [hattemptPair] + _ ≤ (QueryCache.enncard workingCache + 1) + (attempts : ℝ≥0∞) := by + exact add_le_add hgrowth le_rfl + _ = QueryCache.enncard workingCache + ((attempts + 1 : Nat) : ℝ≥0∞) := by + push_cast + ring + _ ≤ _ := hbudget + have hmemWorld : attemptResult ∈ support + ((simulateQ romImpl + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))) : + OracleComp OracleWorld (Option (Index × (DigestTree → FtsLeaf))))).run + workingCache) := by + rw [simulateQ_romImpl_liftM] + exact hattemptResult + have hworkingLe : workingCache ≤ attemptResult.2 := + simulateQ_romImpl_cache_le + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))) : + OracleComp OracleWorld (Option (Index × (DigestTree → FtsLeaf)))) + workingCache attemptResult hmemWorld + have hreference' : referenceCache ≤ attempt.2.2 := by + rw [hattemptPair] + exact hreference.trans hworkingLe + simpa only [epsilon, count, hrejected, signDigestLoopContinuation] using + ih attempt.2.2 hreference' hbudget' + · have hworkingBudget : QueryCache.enncard workingCache ≤ + ((2 ^ 127 : Nat) : ℝ≥0∞) := + (le_add_right le_rfl).trans hbudget + have hcountLe : count ≤ QueryCache.enncard workingCache := by + exact (cachedMessageEntryCountWhere_le_enncard referenceCache secretKey.parameter + secretKey.root message P).trans (QueryCache.enncard_mono hreference) + calc + Pr[FavorablePrehitAttempt referenceCache secretKey message P | + signDigestAttemptPrefix secretKey message workingCache] + + Pr[fun attempt => attempt.2.1 = none | + signDigestAttemptPrefix secretKey message workingCache] * epsilon ≤ + count * ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ + + (1 - ((2 ^ 11 : Nat) : ℝ≥0∞)⁻¹) * epsilon := by + gcongr + · exact probEvent_signDigestAttemptPrefix_favorablePrehit_le + referenceCache workingCache secretKey message P + · exact probEvent_signDigestAttemptPrefix_retry_le + secretKey message workingCache hworkingBudget + _ ≤ count * ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ := by + exact prehit_race_recurrence_arith count + (ne_top_of_le_ne_top (by finiteness) (hcountLe.trans hworkingBudget)) + _ = _ := rfl + +set_option maxRecDepth 100000 in +set_option linter.constructorNameAsVariable false in +theorem Concrete.probEvent_signWithView_prehitSuccessful_le_race_reference + (secretKey : SecretKey) (message : Message) + (referenceCache initialCache : QueryCache HashSpec) + (P : FewTimeView → Prop) + (hreference : referenceCache ≤ initialCache) + (hbudget : QueryCache.enncard initialCache + (digestAttemptLimit : ℝ≥0∞) ≤ + ((2 ^ 127 : Nat) : ℝ≥0∞)) : + Pr[PrehitSuccessfulSignerView referenceCache secretKey message P | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] ≤ + cachedMessageEntryCountWhere referenceCache secretKey.parameter secretKey.root message P * + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ := by + rw [signWithView, simulateQ_bind, StateT.run_bind] + refine (probEvent_bind_le_probEvent + (p := PrehitSelectedView referenceCache secretKey message P) ?_).trans + (probEvent_signDigestLoop_prehitSelectedView_le_race digestAttemptLimit + secretKey message referenceCache initialCache P hreference hbudget) + intro loopResult hloop hnotPrehit + cases hloopResult : loopResult.1 with + | none => + refine probEvent_eq_zero ?_ + intro result hresult hevent + have hresultEq : result = ((none, none), loopResult.2) := by + simpa only [hloopResult, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hresult + obtain ⟨signature, view, hsuccessful, _⟩ := hevent + rw [hresultEq] at hsuccessful + simp at hsuccessful + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + refine probEvent_eq_zero ?_ + intro result hresult hevent + rw [simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hresult + obtain ⟨⟨signatureResult, signatureCache⟩, hsignature, hpure⟩ := hresult + have hpureEq : result = + ((signatureResult, some (selectedFewTimeView index leaves)), signatureCache) := by + simpa only [simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hpure + obtain ⟨signature, view, hsuccessful, output, hcached, hP⟩ := hevent + have hpureFirst := congrArg Prod.fst hpureEq + have hsignatureResult : signatureResult = some signature := by + have hfirst := congrArg Prod.fst (hpureFirst.symm.trans hsuccessful) + simpa using hfirst + have hsignature' : (some signature, signatureCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest secretKey randomness index leaves)).run loopResult.2) := by + rw [hsignatureResult] at hsignature + simpa only [simulateQ_romImpl_liftM] using hsignature + have hrandomness := signAfterDigest_support_some_randomness secretKey randomness + index leaves loopResult.2 signatureCache signature hsignature' + have hcached' : initialCache + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = some output := by + apply hreference + rw [← hrandomness] + exact hcached + have hloop' : (some (randomness, index, leaves), loopResult.2) ∈ support + ((simulateQ romImpl + (signDigestLoop digestAttemptLimit secretKey message)).run initialCache) := by + have heq : loopResult = (some (randomness, index, leaves), loopResult.2) := + Prod.ext hloopResult rfl + rw [← heq] + exact hloop + have hresultOutput := signDigestLoop_initial_cached_result + digestAttemptLimit secretKey message randomness index leaves initialCache loopResult.2 + output hcached' hloop' + apply hnotPrehit + exact ⟨randomness, index, leaves, hloopResult, output, by + rw [← hrandomness] + exact hcached, hresultOutput, hP⟩ + +theorem Concrete.probEvent_signWithView_prehitSuccessful_le_race + (secretKey : SecretKey) (message : Message) (initialCache : QueryCache HashSpec) + (P : FewTimeView → Prop) + (hbudget : QueryCache.enncard initialCache + (digestAttemptLimit : ℝ≥0∞) ≤ + ((2 ^ 127 : Nat) : ℝ≥0∞)) : + Pr[PrehitSuccessfulSignerView initialCache secretKey message P | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] ≤ + cachedMessageEntryCountWhere initialCache secretKey.parameter secretKey.root message P * + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ := by + exact probEvent_signWithView_prehitSuccessful_le_race_reference secretKey message + initialCache initialCache P le_rfl hbudget + +theorem Concrete.probEvent_signWithView_prehitSuccessful_le_race_of_enncard_le + (secretKey : SecretKey) (message : Message) (initialCache : QueryCache HashSpec) + (P : FewTimeView → Prop) (q : Nat) (hq : q ≤ 2 ^ 120) + (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[PrehitSuccessfulSignerView initialCache secretKey message P | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] ≤ + cachedMessageEntryCountWhere initialCache secretKey.parameter secretKey.root message P * + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ := by + apply probEvent_signWithView_prehitSuccessful_le_race + have hq' : (q : ℝ≥0∞) ≤ ((2 ^ 120 : Nat) : ℝ≥0∞) := by + exact_mod_cast hq + calc + QueryCache.enncard initialCache + (digestAttemptLimit : ℝ≥0∞) ≤ + (q : ℝ≥0∞) + (digestAttemptLimit : ℝ≥0∞) := + add_le_add hcache le_rfl + _ ≤ ((2 ^ 120 : Nat) : ℝ≥0∞) + (digestAttemptLimit : ℝ≥0∞) := + add_le_add hq' le_rfl + _ ≤ ((2 ^ 127 : Nat) : ℝ≥0∞) := by + norm_num [digestAttemptLimit] + +theorem Concrete.probEvent_signWithView_prehitSuccessful_le_race_of_enncard_le125 + (secretKey : SecretKey) (message : Message) (initialCache : QueryCache HashSpec) + (P : FewTimeView → Prop) (q : Nat) (hq : q ≤ 2 ^ 125) + (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[PrehitSuccessfulSignerView initialCache secretKey message P | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] ≤ + cachedMessageEntryCountWhere initialCache secretKey.parameter secretKey.root message P * + ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ := by + apply probEvent_signWithView_prehitSuccessful_le_race + have hq' : (q : ℝ≥0∞) ≤ ((2 ^ 125 : Nat) : ℝ≥0∞) := by + exact_mod_cast hq + calc + QueryCache.enncard initialCache + (digestAttemptLimit : ℝ≥0∞) ≤ + (q : ℝ≥0∞) + (digestAttemptLimit : ℝ≥0∞) := + add_le_add hcache le_rfl + _ ≤ ((2 ^ 125 : Nat) : ℝ≥0∞) + (digestAttemptLimit : ℝ≥0∞) := + add_le_add hq' le_rfl + _ ≤ ((2 ^ 127 : Nat) : ℝ≥0∞) := by + norm_num [digestAttemptLimit] + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetAllowed.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetAllowed.lean new file mode 100644 index 00000000..277a833f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetAllowed.lean @@ -0,0 +1,238 @@ +import SphincsSecurity.Proof.FewTimeRawTargetTrace + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +noncomputable def rawTargetCandidateAllowedAt + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (ordinal : Nat) + (entry : AdversaryCacheEntry) : List Bool := + match entry with + | ⟨.inl (.inr input), output, initialCache, _⟩ => + if initialCache input = none then + [decide (configuration.sourceAt? ordinal = none ∧ + signAttemptResultOfOutput output ≠ none)] + else [] + | _ => [] + +noncomputable def rawTargetCandidateAllowedFrom + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) : Nat → List AdversaryCacheEntry → List Bool + | _, [] => [] + | ordinal, entry :: rest => + rawTargetCandidateAllowedAt configuration ordinal entry ++ + rawTargetCandidateAllowedFrom configuration + (ordinal + if isDirectHashQuery entry.input then 1 else 0) rest + +theorem directIntervalCount_cons (entry : AdversaryCacheEntry) (rest : List AdversaryCacheEntry) : + directIntervalCount (entry :: rest) = + (if isDirectHashQuery entry.input then 1 else 0) + directIntervalCount rest := by + by_cases h : isDirectHashQuery entry.input <;> + simp [directIntervalCount, h, Nat.add_comm] + +theorem directIntervalCount_append (left right : List AdversaryCacheEntry) : + directIntervalCount (left ++ right) = directIntervalCount left + directIntervalCount right := by + simp [directIntervalCount] + +theorem rawTargetCandidateAllowedFrom_append + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (ordinal : Nat) + (left right : List AdversaryCacheEntry) : + rawTargetCandidateAllowedFrom configuration ordinal (left ++ right) = + rawTargetCandidateAllowedFrom configuration ordinal left ++ + rawTargetCandidateAllowedFrom configuration + (ordinal + directIntervalCount left) right := by + induction left generalizing ordinal with + | nil => simp [rawTargetCandidateAllowedFrom, directIntervalCount] + | cons entry rest ih => + simp only [List.cons_append, rawTargetCandidateAllowedFrom, ih, + directIntervalCount_cons, List.append_assoc, Nat.add_assoc] + +def OriginTargetMonitorState.RawAllowedTraceCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) : Prop := + state.origin.directOrdinal = directIntervalCount state.origin.viewed.trace.intervals ∧ + state.candidateAllowed = rawTargetCandidateAllowedFrom configuration 0 + state.origin.viewed.trace.intervals + +theorem OriginTargetMonitorState.rawAllowedTraceCoherent_initial + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (cache : QueryCache HashSpec) : + (OriginTargetMonitorState.initial configuration cache).RawAllowedTraceCoherent := by + exact ⟨rfl, rfl⟩ + +theorem rawTargetMonitoredAdversaryImpl_query_rawAllowedTraceCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) + (result : (OracleWorld + SigningSpec).Range input × OriginTargetMonitorState configuration) + (hcoherent : state.RawAllowedTraceCoherent) + (hmem : result ∈ support + ((rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run state)) : + result.2.RawAllowedTraceCoherent := by + classical + obtain ⟨hcount, hallowed⟩ := hcoherent + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + simp only [rawTargetMonitoredAdversaryImpl, originMonitoredAdversaryImpl, + StateT.run, bind_assoc, pure_bind, mem_support_bind_iff] at hmem + obtain ⟨run, _, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + simpa [OriginTargetMonitorState.RawAllowedTraceCoherent, + OriginTargetMonitorState.advanceOrigin, fullAdversaryTraceUpdate, + rawTargetCandidateAllowedFrom_append, rawTargetCandidateAllowedFrom, + rawTargetCandidateAllowedAt, directIntervalCount_append, directIntervalCount, + isDirectHashQuery] using And.intro hcount hallowed + | inr hashInput => + simp only [rawTargetMonitoredAdversaryImpl, originMonitoredAdversaryImpl, + StateT.run, bind_assoc, pure_bind, mem_support_bind_iff] at hmem + obtain ⟨run, _, hpure⟩ := hmem + by_cases hfresh : state.origin.viewed.cache hashInput = none + · simp only [hfresh, if_true, support_pure, Set.mem_singleton_iff] at hpure + subst result + simp [OriginTargetMonitorState.RawAllowedTraceCoherent, + OriginTargetMonitorState.advanceOrigin, OriginTargetMonitorState.recordCandidate, + fullAdversaryTraceUpdate, rawTargetCandidateAllowedFrom_append, + rawTargetCandidateAllowedFrom, rawTargetCandidateAllowedAt, hfresh, + directIntervalCount, isDirectHashQuery, + hcount, hallowed] + · simp only [hfresh, if_false, support_pure, Set.mem_singleton_iff] at hpure + subst result + simp [OriginTargetMonitorState.RawAllowedTraceCoherent, + OriginTargetMonitorState.advanceOrigin, fullAdversaryTraceUpdate, + rawTargetCandidateAllowedFrom_append, rawTargetCandidateAllowedFrom, + rawTargetCandidateAllowedAt, hfresh, directIntervalCount, isDirectHashQuery, hcount, hallowed] + | inr request => + simp only [rawTargetMonitoredAdversaryImpl, originMonitoredAdversaryImpl, + StateT.run, bind_assoc, pure_bind, mem_support_bind_iff] at hmem + obtain ⟨run, _, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + simpa [OriginTargetMonitorState.RawAllowedTraceCoherent, + OriginTargetMonitorState.advanceOrigin, fullAdversaryTraceUpdate, + rawTargetCandidateAllowedFrom_append, rawTargetCandidateAllowedFrom, + rawTargetCandidateAllowedAt, directIntervalCount_append, directIntervalCount, + isDirectHashQuery] using And.intro hcount hallowed + +theorem rawTargetMonitoredAdversaryImpl_rawAllowedTraceCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (result : α × OriginTargetMonitorState configuration) + (hcoherent : initialState.RawAllowedTraceCoherent) + (hmem : result ∈ support + ((simulateQ (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState)) : result.2.RawAllowedTraceCoherent := by + exact OracleComp.simulateQ_run_preservesInv + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + OriginTargetMonitorState.RawAllowedTraceCoherent + (by + intro input state hstate queryResult hquery + exact rawTargetMonitoredAdversaryImpl_query_rawAllowedTraceCoherent + configuration secretKey targetOrdinal input state queryResult hstate hquery) + computation initialState hcoherent result hmem + +theorem rawTargetCandidateAllowedFrom_length + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (ordinal : Nat) + (intervals : List AdversaryCacheEntry) : + (rawTargetCandidateAllowedFrom configuration ordinal intervals).length = + (rawTargetCandidateViews intervals).length := by + induction intervals generalizing ordinal with + | nil => rfl + | cons entry rest ih => + rcases entry with ⟨input, output, initialCache, finalCache⟩ + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + simpa [rawTargetCandidateAllowedFrom, rawTargetCandidateAllowedAt, + rawTargetCandidateViews, rawTargetCandidateView?, isDirectHashQuery] using ih ordinal + | inr hashInput => + by_cases hfresh : initialCache hashInput = none <;> + simp [rawTargetCandidateAllowedFrom, rawTargetCandidateAllowedAt, + rawTargetCandidateViews, rawTargetCandidateView?, hfresh, ih] + | inr request => + simpa [rawTargetCandidateAllowedFrom, rawTargetCandidateAllowedAt, + rawTargetCandidateViews, rawTargetCandidateView?, isDirectHashQuery] using ih ordinal + +theorem rawTargetCandidateViews_get_direct + (beforeEntries suffix : List AdversaryCacheEntry) (input : HashInput) (output : HashOutput) + (initialCache finalCache : QueryCache HashSpec) (hfresh : initialCache input = none) : + (rawTargetCandidateViews + (beforeEntries ++ ⟨.inl (.inr input), output, initialCache, finalCache⟩ :: suffix))[ + (rawTargetCandidateViews beforeEntries).length]? = some (hashOutputFewTimeView output) := by + rw [rawTargetCandidateViews_append, List.getElem?_append_right (Nat.le_refl _)] + simp [rawTargetCandidateViews, rawTargetCandidateView?, hfresh] + +theorem rawTargetCandidateAllowedFrom_get_direct + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (ordinal : Nat) + (beforeEntries suffix : List AdversaryCacheEntry) (input : HashInput) (output : HashOutput) + (initialCache finalCache : QueryCache HashSpec) (hfresh : initialCache input = none) : + (rawTargetCandidateAllowedFrom configuration ordinal + (beforeEntries ++ ⟨.inl (.inr input), output, initialCache, finalCache⟩ :: suffix))[ + (rawTargetCandidateViews beforeEntries).length]? = + some (decide (configuration.sourceAt? (ordinal + directIntervalCount beforeEntries) = none ∧ + signAttemptResultOfOutput output ≠ none)) := by + rw [rawTargetCandidateAllowedFrom_append, + ← rawTargetCandidateAllowedFrom_length configuration ordinal beforeEntries, + List.getElem?_append_right (Nat.le_refl _)] + simp [rawTargetCandidateAllowedFrom, rawTargetCandidateAllowedAt, hfresh] + +theorem rawTargetMonitoredAdversaryImpl_valid_eq_trace + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) + (result : α × OriginTargetMonitorState configuration) + (hmem : result ∈ support + ((simulateQ (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run (OriginTargetMonitorState.initial configuration initialCache))) : + result.2.valid = + (rawTargetCandidateAllowedFrom configuration 0 + result.2.origin.viewed.trace.intervals)[targetOrdinal]?.getD true := by + have hallowed := rawTargetMonitoredAdversaryImpl_candidateAllowedCoherent configuration secretKey + targetOrdinal computation _ result + (OriginTargetMonitorState.candidateAllowedCoherent_initial configuration initialCache + targetOrdinal) hmem + have htrace := rawTargetMonitoredAdversaryImpl_rawAllowedTraceCoherent configuration secretKey + targetOrdinal computation _ result + (OriginTargetMonitorState.rawAllowedTraceCoherent_initial configuration initialCache) hmem + exact hallowed.2.trans (congrArg (fun allowed => allowed[targetOrdinal]?.getD true) htrace.2) + +theorem rawTargetMonitoredAdversaryImpl_selected_direct + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (beforeEntries suffix : List AdversaryCacheEntry) + (input : HashInput) (output : HashOutput) (before after : QueryCache HashSpec) + (hfresh : before input = none) + (hsource : configuration.sourceAt? (directIntervalCount beforeEntries) = none) + (hadmissible : signAttemptResultOfOutput output ≠ none) + (result : α × OriginTargetMonitorState configuration) + (hmem : result ∈ support + ((simulateQ (rawTargetMonitoredAdversaryImpl configuration secretKey + (rawTargetCandidateViews beforeEntries).length) computation).run + (OriginTargetMonitorState.initial configuration initialCache))) + (htrace : result.2.origin.viewed.trace.intervals = + beforeEntries ++ ⟨.inl (.inr input), output, before, after⟩ :: suffix) : + result.2.valid = true ∧ result.2.targetView = some (hashOutputFewTimeView output) := by + constructor + · rw [rawTargetMonitoredAdversaryImpl_valid_eq_trace configuration secretKey _ computation + initialCache result hmem, htrace, + rawTargetCandidateAllowedFrom_get_direct configuration 0 beforeEntries suffix input output + before after hfresh] + simp [hsource, hadmissible] + · rw [rawTargetMonitoredAdversaryImpl_targetView_eq_trace configuration secretKey _ computation + initialCache result hmem, htrace] + exact rawTargetCandidateViews_get_direct beforeEntries suffix input output before after hfresh + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetBound.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetBound.lean new file mode 100644 index 00000000..13a43ef3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetBound.lean @@ -0,0 +1,276 @@ +import SphincsSecurity.Proof.FewTimeRawTargetMonitor +import SphincsSecurity.Proof.FewTimeTargetTerminal + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem OriginTargetMonitorState.rawPotential_eq_one_of_complete + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hcomplete : state.Complete) + (hevent : ∀ target, state.targetView = some target → + event (state.origin.observation.views, target)) : + state.rawPotential event = 1 := by + obtain ⟨target, htarget⟩ := hcomplete.2.2 + simp only [rawPotential, htarget, reduceCtorEq, ↓reduceIte, one_mul] + exact state.potential_eq_one_of_complete event hcomplete hevent + +noncomputable def OriginTargetMonitorState.cappedRawPotential + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) : ℝ≥0∞ := + if QueryCache.enncard state.origin.viewed.cache ≤ q then state.rawPotential event else 0 + +theorem OriginTargetMonitorState.cappedRawPotential_le_rawPotential + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) : + state.cappedRawPotential q event ≤ state.rawPotential event := by + classical + simp only [OriginTargetMonitorState.cappedRawPotential] + split_ifs + · exact le_rfl + · exact bot_le + +theorem OriginTargetMonitorState.cappedRawPotential_eq_of_enncard_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hcache : QueryCache.enncard state.origin.viewed.cache ≤ q) : + state.cappedRawPotential q event = state.rawPotential event := by + simp [OriginTargetMonitorState.cappedRawPotential, hcache] + +theorem OriginTargetMonitorState.cappedRawPotential_eq_zero_of_not_enncard_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hcache : ¬ QueryCache.enncard state.origin.viewed.cache ≤ q) : + state.cappedRawPotential q event = 0 := by + simp [OriginTargetMonitorState.cappedRawPotential, hcache] + +theorem rawTargetMonitoredAdversaryImpl_expected_cappedRawPotential_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) + (hcoherent : state.JointCoherent targetOrdinal) : + (∑' result, + Pr[= result | + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state] * result.2.cappedRawPotential q event) ≤ + state.cappedRawPotential q event := by + classical + by_cases hcache : QueryCache.enncard state.origin.viewed.cache ≤ q + · rw [state.cappedRawPotential_eq_of_enncard_le q event hcache] + calc + (∑' result, + Pr[= result | + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state] * result.2.cappedRawPotential q event) ≤ + ∑' result, + Pr[= result | + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state] * result.2.rawPotential event := by + apply ENNReal.tsum_le_tsum + intro result + exact mul_le_mul' le_rfl (result.2.cappedRawPotential_le_rawPotential q event) + _ ≤ _ := rawTargetMonitoredAdversaryImpl_expected_rawPotential_le configuration + secretKey targetOrdinal input state event q hq hcache hcoherent.1 hcoherent.2 + · rw [state.cappedRawPotential_eq_zero_of_not_enncard_le q event hcache] + have hzero : (∑' result, + Pr[= result | + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state] * result.2.cappedRawPotential q event) = 0 := by + apply ENNReal.tsum_eq_zero.2 + intro result + by_cases hresult : result ∈ support + ((rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state) + · have hle := rawTargetMonitoredAdversaryImpl_query_cache_le configuration + secretKey targetOrdinal input state result hresult + have hcard := QueryCache.enncard_mono hle + have hnotFinal : ¬ QueryCache.enncard result.2.origin.viewed.cache ≤ q := + fun hfinal => hcache (hcard.trans hfinal) + rw [result.2.cappedRawPotential_eq_zero_of_not_enncard_le q event hnotFinal, + mul_zero] + · rw [probOutput_eq_zero_of_not_mem_support hresult, zero_mul] + exact hzero.le + +theorem rawTargetMonitoredAdversaryImpl_expected_cappedRawPotential_simulateQ_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) + (hcoherent : initialState.JointCoherent targetOrdinal) : + (∑' result, + Pr[= result | + (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState] * + result.2.cappedRawPotential q event) ≤ initialState.cappedRawPotential q event := by + induction computation using OracleComp.inductionOn generalizing initialState with + | pure value => + simp [simulateQ_pure, tsum_probOutput_pure_mul] + | query_bind input next ih => + rw [simulateQ_bind, StateT.run_bind, simulateQ_query, + tsum_probOutput_bind_mul] + simp only [OracleQuery.input_query, OracleQuery.cont_query, id_map] + calc + (∑' result, + Pr[= result | + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + initialState] * + ∑' finalResult, + Pr[= finalResult | + (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + (next result.1)).run result.2] * + finalResult.2.cappedRawPotential q event) ≤ + ∑' result, + Pr[= result | + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + initialState] * result.2.cappedRawPotential q event := by + apply ENNReal.tsum_le_tsum + intro result + by_cases hresult : result ∈ support + ((rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + initialState) + · apply mul_le_mul' le_rfl + exact ih result.1 result.2 + (rawTargetMonitoredAdversaryImpl_query_jointCoherent configuration secretKey + targetOrdinal input initialState result hcoherent hresult) + · rw [probOutput_eq_zero_of_not_mem_support hresult, zero_mul, zero_mul] + _ ≤ _ := rawTargetMonitoredAdversaryImpl_expected_cappedRawPotential_le + configuration secretKey targetOrdinal input initialState event q hq hcoherent + +theorem OriginTargetMonitorState.cappedRawPotential_eq_one_of_complete + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hcache : QueryCache.enncard state.origin.viewed.cache ≤ q) + (hcomplete : state.Complete) + (hevent : ∀ target, state.targetView = some target → + event (state.origin.observation.views, target)) : + state.cappedRawPotential q event = 1 := by + rw [state.cappedRawPotential_eq_of_enncard_le q event hcache, + state.rawPotential_eq_one_of_complete event hcomplete hevent] + +theorem probEvent_rawTargetMonitored_complete_le_initial + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) + (hcoherent : initialState.JointCoherent targetOrdinal) : + Pr[fun result : α × OriginTargetMonitorState configuration => + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + event (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q | + (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState] ≤ initialState.cappedRawPotential q event := by + let run := (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState + calc + Pr[fun result : α × OriginTargetMonitorState configuration => + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + event (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q | run] ≤ + ∑' result, Pr[= result | run] * result.2.cappedRawPotential q event := by + apply probEvent_le_tsum_probOutput_mul_cost + intro result hresult + rw [result.2.cappedRawPotential_eq_one_of_complete q event hresult.2.2 + hresult.1 hresult.2.1] + _ ≤ _ := rawTargetMonitoredAdversaryImpl_expected_cappedRawPotential_simulateQ_le + configuration secretKey targetOrdinal computation initialState event q hq hcoherent + +theorem OriginTargetMonitorState.rawPotential_initial + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) + (cache : QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) : + (OriginTargetMonitorState.initial configuration cache).rawPotential event = + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + (((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ configuration.prehit.card * + Pr[event | ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : ProbComp _)]) := by + rw [rawPotential, potential_initial] + simp only [initial, ↓reduceIte] + +theorem probEvent_rawTargetMonitored_complete_le_ideal + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) + (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[fun result : α × OriginTargetMonitorState configuration => + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + event (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q | + (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run (OriginTargetMonitorState.initial configuration initialCache)] ≤ + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + (((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ configuration.prehit.card * + Pr[event | ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : ProbComp _)]) := by + calc + _ ≤ (OriginTargetMonitorState.initial configuration initialCache).cappedRawPotential + q event := + probEvent_rawTargetMonitored_complete_le_initial configuration secretKey + targetOrdinal computation (OriginTargetMonitorState.initial configuration initialCache) + event q hq + (OriginTargetMonitorState.jointCoherent_initial configuration initialCache + targetOrdinal) + _ = (OriginTargetMonitorState.initial configuration initialCache).rawPotential event := + OriginTargetMonitorState.cappedRawPotential_eq_of_enncard_le q + (OriginTargetMonitorState.initial configuration initialCache) event hcache + _ = _ := OriginTargetMonitorState.rawPotential_initial configuration initialCache event +theorem probEvent_rawTargetMonitored_complete_fixedPattern_le_ideal + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (q : Nat) (hq : q ≤ 2 ^ 126) + (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[fun result : α × OriginTargetMonitorState configuration => + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q | + (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run (OriginTargetMonitorState.initial configuration initialCache)] ≤ + Pr[configuration.RawTargetHit | + ($ᵗ configuration.RawTargetSample : ProbComp configuration.RawTargetSample)] := by + calc + _ ≤ ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + (((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ configuration.prehit.card * + Pr[FixedFewTimePatternHit pattern.assignment | + ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : ProbComp _)]) := + probEvent_rawTargetMonitored_complete_le_ideal configuration secretKey + targetOrdinal computation initialCache + (FixedFewTimePatternHit pattern.assignment) q hq hcache + _ = Pr[configuration.RawTargetHit | + ($ᵗ configuration.RawTargetSample : ProbComp configuration.RawTargetSample)] := by + rw [probEvent_originConfiguration_rawTargetHit, probEvent_originConfiguration_hit_eq_pattern_mul] + ac_rfl + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetClassify.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetClassify.lean new file mode 100644 index 00000000..01fcbf8b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetClassify.lean @@ -0,0 +1,98 @@ +import SphincsSecurity.Proof.FewTimeRawTargetSource + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem gameAfterSecretsWithViewTrace_honestLeak_target_classified_at_adversary_state + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest parameter result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) = digest) + (hadmissible : Admissible digest) + (hproper : ProperFewTimeLeak f result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest)) + (hfull : FullyHonestOpening f result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + (digestIndex digest) (digestLeaves digest) result.1.2.1.signature) + (hle : result.2.trace.signing.toSigningLog.length ≤ signatureLimit) + (rootCache : QueryCache HashSpec) (state : ViewedFullTraceState) + (htrace : result.2.trace = state.trace) + (hstateCache : state.cache ≤ result.2.cache) : + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + VerifierFreshTarget parameter result ∨ + ∃ (distinct : Nat) (_ : distinct ∈ Finset.Icc 1 14) + (pattern : FewTimePattern signatureLimit distinct) + (configuration : OriginConfiguration pattern q) (candidate : Fin q), + FixedRawTargetViewedTerminal secretKey + (adversary.main ⟨result.1.1, parameter⟩) rootCache q + configuration candidate.val (result.1.2.1, state) := by + classical + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + let targetPayload := messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness + let targetInput := tweakableHashInput parameter .message targetPayload + obtain ⟨sourceRootCache, adversaryCache, digestCache, output, hrootNone, hchain, hquery, + hdigestLe, + htargetView, horigin, _⟩ := + gameAfterSecretsWithViewTrace_target_source_kind adversary parameter otsSecret + ftsSecret result hresult + rcases horigin with hverifier | ⟨source, hsourceInitial, hsourceFinal, hkind⟩ + · exact Or.inl ⟨sourceRootCache, adversaryCache, digestCache, output, + hrootNone, hchain, by simpa only [targetInput, targetPayload] using hverifier, + by simpa only [targetInput, targetPayload] using hquery, hdigestLe, htargetView⟩ + · obtain ⟨sourceOutput, before, after, hentry, hfresh, hattempt⟩ := + gameAfterSecretsWithViewTrace_fullyHonest_target_source_entry adversary parameter + otsSecret ftsSecret result hresult f hf digest hdigest hadmissible hproper hfull source + (by simpa only [targetInput, targetPayload] using hsourceInitial) + (by simpa only [targetInput, targetPayload] using hsourceFinal) + (by simpa only [targetInput, targetPayload] using hkind) + have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hresult, rfl⟩ + obtain ⟨configuration, hrealized⟩ := + hproper.1.cover.exists_paddedRealized_originConfiguration_of_queryBudget + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts + (result.1, result.2.base) hbase f hf (digestIndex digest) (digestLeaves digest) + signatureLimit hle + let targetOrdinal := (rawTargetCandidateViews + (result.2.trace.intervals.take source.val)).length + have hordinalLt : targetOrdinal < q := + rawTargetCandidateOrdinal_lt_bound result.2.trace.intervals source _ sourceOutput + before after hentry hfresh q + (gameAfterSecretsWithViewTrace_directIntervalCount_le adversary q hq parameter + hparameter otsSecret hots ftsSecret hfts result hresult) + let candidate : Fin q := ⟨targetOrdinal, hordinalLt⟩ + have hfinalCache : QueryCache.enncard result.2.cache ≤ q := + gameAfterSecretsWithFullTrace_support_enncard_le adversary q hq parameter hparameter + otsSecret hots ftsSecret hfts (result.1, result.2.base) hbase + have hviewedCache : QueryCache.enncard state.cache ≤ q := + (QueryCache.enncard_mono hstateCache).trans hfinalCache + refine Or.inr ⟨hproper.1.cover.entries.card, + Finset.mem_Icc.2 ⟨hproper.1.cover.entries_card_pos, + hproper.1.cover.entries_card_le_trees⟩, + hproper.1.cover.pattern.pad hle, configuration, candidate, hviewedCache, ?_⟩ + intro monitored hmonitored heq + have hstateEq : monitored.2.origin.viewed = state := congrArg Prod.snd heq + have htrace' : result.2.trace = monitored.2.origin.viewed.trace := by + rw [hstateEq] + exact htrace + exact configuration.raw_target_monitored_complete_of_projection adversary parameter + otsSecret ftsSecret result hresult f hf digest hdigest hproper hle hrealized source + sourceOutput before after hentry hfresh hattempt + (adversary.main ⟨result.1.1, parameter⟩) rootCache monitored hmonitored htrace' + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetCompletion.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetCompletion.lean new file mode 100644 index 00000000..ef263c8b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetCompletion.lean @@ -0,0 +1,82 @@ +import SphincsSecurity.Proof.FewTimeRawTargetAllowed +import SphincsSecurity.Proof.FewTimeHonestLeakTerminal + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem rawTargetMonitoredAdversaryImpl_origin_replayConsistent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) + (result : α × OriginTargetMonitorState configuration) + (hmem : result ∈ support + ((simulateQ (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run (OriginTargetMonitorState.initial configuration initialCache))) : + result.2.origin.ReplayConsistent secretKey := by + have horigin : (result.1, result.2.origin) ∈ support + ((simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run (OriginMonitorState.initial configuration initialCache)) := by + change (result.1, result.2.origin) ∈ support + ((simulateQ (originMonitoredAdversaryImpl configuration secretKey) computation).run + (OriginTargetMonitorState.initial configuration initialCache).origin) + rw [← rawTargetMonitoredAdversaryImpl_projection configuration secretKey targetOrdinal + computation (OriginTargetMonitorState.initial configuration initialCache), support_map] + exact ⟨result, hmem, rfl⟩ + exact originMonitoredAdversaryImpl_replayConsistent configuration secretKey computation + (OriginMonitorState.initial configuration initialCache) (result.1, result.2.origin) + (OriginMonitorState.replayConsistent_initial configuration secretKey initialCache) horigin + +theorem OriginConfiguration.raw_target_complete_and_hit + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} {targetLeaves : DigestTree → FtsLeaf} + {cover : FewTimeCover f cache secretKey signingLog index targetLeaves} + {sources limit : Nat} {hle : signingLog.length ≤ limit} + (configuration : OriginConfiguration (cover.pattern.pad hle) sources) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (beforeEntries suffix : List AdversaryCacheEntry) + (input : HashInput) (output : HashOutput) (before after : QueryCache HashSpec) + (hfresh : before input = none) + (hsource : configuration.sourceAt? (directIntervalCount beforeEntries) = none) + (hadmissible : signAttemptResultOfOutput output ≠ none) + (hview : hashOutputFewTimeView output = fewTimeTargetView index targetLeaves) + (result : α × OriginTargetMonitorState configuration) + (hmem : result ∈ support + ((simulateQ (rawTargetMonitoredAdversaryImpl configuration secretKey + (rawTargetCandidateViews beforeEntries).length) computation).run + (OriginTargetMonitorState.initial configuration initialCache))) + (htrace : result.2.origin.viewed.trace.intervals = + beforeEntries ++ ⟨.inl (.inr input), output, before, after⟩ :: suffix) + (hlog : result.2.origin.viewed.trace.signing.toSigningLog = signingLog) + (hrealized : configuration.PaddedRealizedBy cover hle result.2.origin.viewed.trace hlog) + (hvalidIntervals : result.2.origin.viewed.trace.ValidIntervals secretKey) + (hchronological : FullAdversaryTrace.Chronological result.2.origin.viewed.trace.intervals) + (hcaches : result.2.origin.viewed.trace.signing.CachesLe cache) + (hf : cache.AgreesWithFn f) : + result.2.Complete ∧ + ∀ target, result.2.targetView = some target → + FixedFewTimePatternHit (cover.pattern.pad hle).assignment + (result.2.origin.observation.views, target) := by + have hreplay := rawTargetMonitoredAdversaryImpl_origin_replayConsistent configuration secretKey + _ computation initialCache result hmem + obtain ⟨horigin, hhit⟩ := configuration.paddedRealized_complete_and_hit hlog hrealized + hreplay hvalidIntervals hchronological hcaches hf + obtain ⟨hvalid, htarget⟩ := rawTargetMonitoredAdversaryImpl_selected_direct configuration secretKey + computation initialCache beforeEntries suffix input output before after hfresh hsource + hadmissible result hmem htrace + rw [hview] at htarget + constructor + · exact ⟨hvalid, horigin, _, htarget⟩ + · intro target htarget' + have heq := Option.some.inj (htarget'.symm.trans htarget) + simpa only [heq] using hhit + +theorem trace_take_get_drop (intervals : List AdversaryCacheEntry) + (source : Fin intervals.length) : + intervals = intervals.take source.val ++ intervals.get source :: intervals.drop (source.val + 1) := by + conv_lhs => rw [← List.take_append_drop source.val intervals] + rw [List.drop_eq_getElem_cons source.isLt] + rfl + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetExtraction.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetExtraction.lean new file mode 100644 index 00000000..22a63664 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetExtraction.lean @@ -0,0 +1,82 @@ +import SphincsSecurity.Proof.FewTimeRawTargetCompletion + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem OriginConfiguration.raw_target_monitored_complete_of_projection + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest parameter result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) = digest) + (hproper : ProperFewTimeLeak f result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest)) + {limit sources : Nat} (hle : result.2.trace.signing.toSigningLog.length ≤ limit) + (configuration : OriginConfiguration (hproper.1.cover.pattern.pad hle) sources) + (hrealized : configuration.PaddedRealizedBy hproper.1.cover hle result.2.trace rfl) + (source : Fin result.2.trace.intervals.length) + (output : HashOutput) (before after : QueryCache HashSpec) + (hentry : result.2.trace.intervals.get source = + ⟨.inl (.inr (tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness))), output, before, after⟩) + (hfresh : before (tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness)) = none) + (hattempt : signAttemptResultOfOutput output = some (digestIndex digest, digestLeaves digest)) + (computation : OracleComp (OracleWorld + SigningSpec) α) (initialCache : QueryCache HashSpec) + (monitored : α × OriginTargetMonitorState configuration) + (hmonitored : monitored ∈ support + ((simulateQ (rawTargetMonitoredAdversaryImpl configuration + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + (rawTargetCandidateViews (result.2.trace.intervals.take source.val)).length) + computation).run (OriginTargetMonitorState.initial configuration initialCache))) + (htrace : result.2.trace = monitored.2.origin.viewed.trace) : + monitored.2.Complete ∧ + ∀ target, monitored.2.targetView = some target → + FixedFewTimePatternHit (hproper.1.cover.pattern.pad hle).assignment + (monitored.2.origin.observation.views, target) := by + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hresult, rfl⟩ + have hinvariants := gameAfterSecretsWithFullTrace_support_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hintervals := gameAfterSecretsWithFullTrace_support_interval_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hvalid := gameAfterSecretsWithFullTrace_support_validIntervals adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hsource := hproper.direct_target_not_configured_source result.1.2.1 digest hdigest rfl + hle configuration result.2.trace rfl hrealized hvalid source output before after hentry + have hview : hashOutputFewTimeView output = + fewTimeTargetView (digestIndex digest) (digestLeaves digest) := + (signAttemptResultOfOutput_view output _ _ hattempt).symm + have hsplit := trace_take_get_drop result.2.trace.intervals source + rw [hentry] at hsplit + have htraceSplit := (congrArg FullAdversaryTrace.intervals htrace).symm.trans hsplit + obtain ⟨hlogMonitored, hrealizedMonitored⟩ := + configuration.paddedRealized_transport result.2.trace monitored.2.origin.viewed.trace + htrace rfl hrealized + apply configuration.raw_target_complete_and_hit computation initialCache + (result.2.trace.intervals.take source.val) (result.2.trace.intervals.drop (source.val + 1)) + _ output before after hfresh hsource (by rw [hattempt]; simp) hview + monitored hmonitored htraceSplit hlogMonitored hrealizedMonitored + · rw [← htrace] + exact hvalid + · rw [← htrace] + exact hintervals.2.2 + · rw [← htrace] + exact hinvariants.2.1 + · exact hf + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetFresh.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetFresh.lean new file mode 100644 index 00000000..759be6c9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetFresh.lean @@ -0,0 +1,278 @@ +import SphincsSecurity.Proof.FewTimeRawVerifierTarget + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem probEvent_gameRestWithViewTrace_fresh_honest_leak_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (root : Digest) (rootCache : QueryCache HashSpec) + (hroot : (root, rootCache) ∈ support + ((simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅)) : + Pr[fun rest => + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, rest.1.1, rest.1.2), rest.2) + ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∧ VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache] ≤ + ((q + 1 : Nat) : ℝ≥0∞) * rawTargetOriginUnionBound signatureLimit q := by + classical + let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + let publicKey : PublicKey := ⟨root, parameter⟩ + let initialState : ViewedFullTraceState := + ⟨rootCache, ⟨[], [], []⟩, [], none⟩ + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState + let finish : Forgery × ViewedFullTraceState → + ProbComp ((Forgery × Bool) × ViewedFullTraceState) := fun prior => do + let ((verified, targetView), finalCache) ← + (simulateQ romImpl + (liftM (verifyWithView publicKey prior.1.message prior.1.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run prior.2.cache + let log := prior.2.trace.signing.toSigningLog + let verdict := decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log prior.1) && verified + pure ((prior.1, verdict), + ⟨finalCache, prior.2.trace, prior.2.views, some targetView⟩) + let freshEvent := fun rest : (Forgery × Bool) × ViewedFullTraceState => + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, rest.1.1, rest.1.2), rest.2) + ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result + have hrootNone : ∀ payload, + rootCache (tweakableHashInput parameter .message payload) = none := by + have hroot' : (root, rootCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅) := by + simpa only [simulateQ_romImpl_liftM] using hroot + exact fun payload => treeRoot_cache_message_none parameter topLayer rootTree + (otsSecret topLayer rootTree) root rootCache hroot' payload + have hrootCache : QueryCache.enncard rootCache ≤ q := by + have hgameBound := isQueryBoundP_gameAfterSecrets adversary q hq + hparameter hots hfts + rw [gameAfterSecrets] at hgameBound + have hrootBound := OracleComp.IsQueryBoundP.of_bind_left + (p := fun input : OracleWorld.Domain => input matches Sum.inr _) hgameBound + exact simulateQ_romImpl_enncard_le_queryBound + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest) q hrootBound (root, rootCache) hroot + have hprefixBound := + probEvent_exists_fixedRawTargetViewedTerminal_le_idealOrigin_of_candidates + (α := Forgery × HashOutput) (secretKey := secretKey) + (computation := adversaryWithTargetQuery adversary publicKey) + (initialCache := rootCache) (signatures := signatureLimit) (sources := q) + (q := q) (hq := hqMax) (hcache := hrootCache) (candidates := q + 1) + have hgame : gameRestWithViewTrace adversary publicKey secretKey rootCache = + run >>= finish := rfl + rw [show ⟨root, parameter⟩ = publicKey from rfl, + show ⟨parameter, root, otsSecret, ftsSecret⟩ = secretKey from rfl, hgame] + change Pr[freshEvent | run >>= finish] ≤ _ + have hfirst : Pr[freshEvent | run >>= finish] ≤ + Pr[SomeFixedRawTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversaryWithTargetQuery adversary publicKey)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩] := by + rw [adversaryWithTargetQuery_viewed_run] + change Pr[_ | run >>= _] ≤ + Pr[SomeFixedRawTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + run >>= _] + apply probEvent_bind_le_bind_of_forall_le + rintro ⟨forgery, state⟩ hprior + let input := tweakableHashInput parameter .message + (messageDigestPayload root forgery.message forgery.signature.randomness) + change Pr[_ | + (simulateQ romImpl + (liftM (verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run state.cache >>= _] ≤ _ + rw [verifyWithView_split_run] + simp only [bind_assoc] + rw [show tweakableHashInput publicKey.parameter .message + (messageDigestPayload publicKey.root forgery.message + forgery.signature.randomness) = input from rfl] + change _ ≤ Pr[SomeFixedRawTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + (randomOracle input).run state.cache >>= pure ∘ fun source => + ((forgery, source.1), appendDirectTargetViewedState input state.cache + source.1 source.2 state)] + rw [probEvent_bind_pure_comp] + change Pr[_ | (randomOracle input).run state.cache >>= _] ≤ + Pr[fun source => SomeFixedRawTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) + ((forgery, source.1), + appendDirectTargetViewedState input state.cache source.1 source.2 state) | + (randomOracle input).run state.cache] + apply probEvent_bind_le_probEvent + rintro ⟨output, digestCache⟩ hquery hnotPrefix + apply probEvent_eq_zero + intro rest hrest hevent + rw [mem_support_bind_iff] at hrest + obtain ⟨⟨⟨verified, targetView⟩, finalCache⟩, hverifyRest, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst rest + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) + change ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result at hevent + have hverify : ((verified, targetView), finalCache) ∈ support + ((simulateQ romImpl + (liftM (verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run state.cache) := by + rw [verifyWithView_split_run, mem_support_bind_iff] + exact ⟨(output, digestCache), by simpa only [input, publicKey] using hquery, + hverifyRest⟩ + have hrestSupport : + ((forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) ∈ + support (gameRestWithViewTrace adversary publicKey secretKey rootCache) := by + rw [gameRestWithViewTrace, mem_support_bind_iff] + refine ⟨(forgery, state), hprior, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨((verified, targetView), finalCache), hverify, + by simp only [support_pure, Set.mem_singleton_iff]⟩ + have hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret) := by + rw [gameAfterSecretsWithViewTrace, mem_support_bind_iff] + refine ⟨(root, rootCache), hroot, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨_, hrestSupport, by simp [result]⟩ + obtain ⟨f, digest, hf, hvalid, _, hdigest, hadmissible, hproper, _hfull⟩ := hevent.1 + obtain ⟨otherRootCache, adversaryCache, _, _, hotherRootNone, + hotherChain, hadversaryMiss, _, _, _⟩ := hevent.2 + have hbase : (forgery, state.base) ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState.base) := by + rw [← viewedFullTracedMappedAdversaryImpl_projection secretKey + (adversary.main publicKey) initialState, support_map] + exact ⟨(forgery, state), hprior, rfl⟩ + have hchain : FullAdversaryTrace.CacheChain rootCache state.trace.intervals + state.cache := + fullTracedMappedAdversaryImpl_cacheChain secretKey (adversary.main publicKey) + rootCache rootCache ⟨[], [], []⟩ (forgery, state.base) (by rfl) hbase + have hmiss : state.cache input = none := by + have hrootInput : rootCache input = none := by + simpa only [input] using hrootNone + (messageDigestPayload root forgery.message forgery.signature.randomness) + have hotherRootInput : otherRootCache input = none := by + simpa only [input, result] using hotherRootNone + (messageDigestPayload root forgery.message forgery.signature.randomness) + have hlookup := FullAdversaryTrace.CacheChain.finish_lookup_eq input + (hrootInput.trans hotherRootInput.symm) hchain + (by simpa only [result] using hotherChain) + exact hlookup.trans hadversaryMiss + have hdigestLe : digestCache ≤ finalCache := + simulateQ_romImpl_cache_le + (liftM (verifyWithViewAfterOutput publicKey forgery.signature output) : + OracleComp OracleWorld (Bool × FewTimeView)) digestCache + ((verified, targetView), finalCache) hverifyRest + have hcachedDigest : digestCache input = some output := + randomOracle_output_cached input state.cache digestCache output (by + have hquerySim : simulateQ (randomOracle : QueryImpl HashSpec _) + (oracleHash input) = randomOracle input := by + change simulateQ (randomOracle : QueryImpl HashSpec _) + (liftM (HashSpec.query input)) = randomOracle input + rw [simulateQ_spec_query] + rw [hquerySim] + exact hquery) + have hcachedFinal : finalCache input = some output := hdigestLe hcachedDigest + have hanswer : f input = output := hf (by simpa only [result] using hcachedFinal) + have hdigestOutput : truncateMessageDigest output = digest := by + have hdigest' : truncateMessageDigest (f input) = digest := by + simpa only [messageDigest, oracleHash, evalWithAnswerFn_bind, + evalWithAnswerFn_query, evalWithAnswerFn_pure, result, input] using hdigest + rwa [hanswer] at hdigest' + have htargetOutput : hashOutputFewTimeView output = + fewTimeTargetView (digestIndex digest) (digestLeaves digest) := by + simp [hashOutputFewTimeView, fewTimeTargetView, hdigestOutput] + have hfullBase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret + ftsSecret, support_map] + exact ⟨result, hresult, rfl⟩ + obtain ⟨configuration, hrealized⟩ := + hproper.1.cover.exists_paddedRealized_originConfiguration_of_queryBudget + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts + (result.1, result.2.base) hfullBase f hf (digestIndex digest) + (digestLeaves digest) signatureLimit hvalid + have hfinalCache : QueryCache.enncard finalCache ≤ q := by + have hbound := gameAfterSecretsWithFullTrace_support_enncard_le adversary q hq + parameter hparameter otsSecret hots ftsSecret hfts + (result.1, result.2.base) hfullBase + change QueryCache.enncard result.2.cache ≤ q at hbound + simpa only [result] using hbound + have hdigestCard : QueryCache.enncard digestCache ≤ q := + (QueryCache.enncard_mono hdigestLe).trans hfinalCache + have hcountLe : (rawTargetCandidateViews state.trace.intervals).length ≤ q := by + apply (rawTargetCandidateViews_length_le_directIntervalCount state.trace.intervals).trans + exact gameAfterSecretsWithViewTrace_directIntervalCount_le adversary q hq parameter + hparameter otsSecret hots ftsSecret hfts result hresult + let candidate : Fin (q + 1) := + ⟨(rawTargetCandidateViews state.trace.intervals).length, by omega⟩ + unfold SomeFixedRawTargetViewedTerminal at hnotPrefix + apply hnotPrefix + refine ⟨hproper.1.cover.entries.card, + Finset.mem_Icc.2 ⟨hproper.1.cover.entries_card_pos, + hproper.1.cover.entries_card_le_trees⟩, + hproper.1.cover.pattern.pad hvalid, configuration, candidate, ?_⟩ + exact configuration.raw_verifierTarget_fixedTerminal adversary parameter otsSecret + ftsSecret result hresult f hf digest hproper hvalid hrealized + rootCache state hprior rfl rfl input output digestCache rfl hmiss + (by simpa only [input] using hquery) hdigestLe htargetOutput + (by simp [signAttemptResultOfOutput, hdigestOutput, hadmissible]) q hdigestCard + calc + Pr[freshEvent | run >>= finish] ≤ + Pr[SomeFixedRawTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversaryWithTargetQuery adversary publicKey)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩] := hfirst + _ ≤ ((q + 1 : Nat) : ℝ≥0∞) * rawTargetOriginUnionBound signatureLimit q := + hprefixBound + +theorem probEvent_gameAfterSecretsWithViewTrace_fresh_honest_leak_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun result => + ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∧ VerifierFreshTarget parameter result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + ((q + 1 : Nat) : ℝ≥0∞) * rawTargetOriginUnionBound signatureLimit q := by + rw [gameAfterSecretsWithViewTrace] + apply probEvent_bind_le_of_forall_le + rintro ⟨root, rootCache⟩ hroot + let attach := fun rest : (Forgery × Bool) × ViewedFullTraceState => + ((root, rest.1.1, rest.1.2), rest.2) + change Pr[fun result => + ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache >>= pure ∘ attach] ≤ _ + rw [probEvent_bind_pure_comp] + exact probEvent_gameRestWithViewTrace_fresh_honest_leak_le adversary q hq hqMax + parameter hparameter otsSecret hots ftsSecret hfts root rootCache hroot + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetInvariant.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetInvariant.lean new file mode 100644 index 00000000..13ac0710 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetInvariant.lean @@ -0,0 +1,167 @@ +import SphincsSecurity.Proof.FewTimeTargetInvariant +import SphincsSecurity.Proof.FewTime125Count + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +noncomputable def OriginTargetMonitorState.rawPotential + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) : ℝ≥0∞ := + (if state.targetView = none then ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ else 1) * + state.potential event + +noncomputable def OriginTargetMonitorState.afterRawDirect + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (input : HashInput) (output : HashOutput) : OriginTargetMonitorState configuration := + let advanced := state.advanceOrigin (state.origin.afterDirect input output) + if state.origin.viewed.cache input = none then + advanced.recordCandidate targetOrdinal + (decide (configuration.sourceAt? state.origin.directOrdinal = none ∧ + signAttemptResultOfOutput output ≠ none)) + (hashOutputFewTimeView output) + else advanced + +theorem OriginTargetMonitorState.expected_rawPotential_advanceOrigin_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) + (mass : α → ℝ≥0∞) (nextOrigin : α → OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hnext : ∀ target, + (∑' result, mass result * + (nextOrigin result).potential (fun views => event (views, target))) ≤ + state.origin.potential (fun views => event (views, target))) : + (∑' result, mass result * + (state.advanceOrigin (nextOrigin result)).rawPotential event) ≤ + state.rawPotential event := by + have hbound := state.expected_potential_advanceOrigin_le mass nextOrigin event hnext + simp only [advanceOrigin] at hbound + cases htarget : state.targetView with + | none => + simp only [htarget] at hbound + simp only [rawPotential, advanceOrigin, htarget, ↓reduceIte] + simp_rw [mul_left_comm (mass _)] + rw [ENNReal.tsum_mul_left] + exact mul_le_mul_right hbound (((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹) + | some target => + simpa only [rawPotential, advanceOrigin, htarget, reduceCtorEq, ↓reduceIte, one_mul] + using hbound + +theorem OriginTargetMonitorState.rawPotential_afterRawDirect_of_ordinal_ne + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (input : HashInput) (output : HashOutput) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hne : state.candidateOrdinal ≠ targetOrdinal) : + (state.afterRawDirect targetOrdinal input output).rawPotential event = + (state.advanceOrigin (state.origin.afterDirect input output)).rawPotential event := by + by_cases hfresh : state.origin.viewed.cache input = none + · simp [afterRawDirect, hfresh, rawPotential, potential, recordCandidate, advanceOrigin, hne] + · simp [afterRawDirect, hfresh] + +theorem OriginTargetMonitorState.expected_rawPotential_afterRawDirect_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (input : HashInput) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (horigin : state.origin.ScheduleCoherent) + (htarget : state.TargetScheduleCoherent targetOrdinal) : + (∑' result, Pr[= result | (randomOracle input).run state.origin.viewed.cache] * + (state.afterRawDirect targetOrdinal input result.1).rawPotential event) ≤ + state.rawPotential event := by + classical + by_cases hfresh : state.origin.viewed.cache input = none + · by_cases heq : state.candidateOrdinal = targetOrdinal + · cases hsource : configuration.sourceAt? state.origin.directOrdinal with + | some selected => + have hzero : ∀ output, + (state.afterRawDirect targetOrdinal input output).rawPotential event = 0 := by + intro output + simp [afterRawDirect, hfresh, hsource, rawPotential, potential, + recordCandidate, advanceOrigin, heq] + simp_rw [hzero] + simp + | none => + cases hvalid : state.valid with + | false => + have hzero : ∀ output, + (state.afterRawDirect targetOrdinal input output).rawPotential event = 0 := by + intro output + simp [afterRawDirect, hfresh, hsource, rawPotential, potential, + recordCandidate, advanceOrigin, heq, hvalid] + simp_rw [hzero] + simp + | true => + have htargetView : state.targetView = none := + state.targetView_eq_none_of_candidateOrdinal_eq htarget heq + calc + _ ≤ ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + ∑ target, Pr[fun value : FewTimeView => value = target | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + state.origin.potential (fun views => event (views, target)) := by + apply tsum_probOutput_randomOracle_fresh_admissible_view_mul_le_expected + input state.origin.viewed.cache hfresh + · intro result _ hnone + simp [afterRawDirect, hfresh, hsource, rawPotential, potential, + recordCandidate, advanceOrigin, heq, hvalid, hnone] + · intro result _ hsome + simp [afterRawDirect, hfresh, hsource, rawPotential, potential, + recordCandidate, advanceOrigin, heq, hvalid, hsome, + state.origin.potential_afterDirect_of_sourceAt?_eq_none + input result.1 _ hsource] + _ = state.rawPotential event := by + simp [rawPotential, potential, hvalid, htargetView] + · simp_rw [state.rawPotential_afterRawDirect_of_ordinal_ne targetOrdinal input _ event heq] + apply state.expected_rawPotential_advanceOrigin_le + intro target + exact state.origin.expected_potential_afterDirect_le input + (fun views => event (views, target)) horigin + · simp_rw [afterRawDirect, hfresh, if_false] + apply state.expected_rawPotential_advanceOrigin_le + intro target + exact state.origin.expected_potential_afterDirect_le input + (fun views => event (views, target)) horigin + +theorem OriginTargetMonitorState.expected_rawPotential_afterSigner_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) + (secretKey : SecretKey) (request : SignRequest) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) + (hcache : QueryCache.enncard state.origin.viewed.cache ≤ q) + (hcoherent : state.origin.ScheduleCoherent) : + (∑' result, Pr[= result | + (simulateQ romImpl (signWithView secretKey request)).run state.origin.viewed.cache] * + (state.advanceOrigin (state.origin.afterSigner secretKey request result)).rawPotential event) ≤ + state.rawPotential event := by + apply state.expected_rawPotential_advanceOrigin_le + intro target + exact state.origin.expected_potential_afterSigner_le secretKey request + (fun views => event (views, target)) q hq hcache hcoherent + +theorem OriginTargetMonitorState.targetScheduleCoherent_afterRawDirect + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (input : HashInput) (output : HashOutput) + (hcoherent : state.TargetScheduleCoherent targetOrdinal) : + (state.afterRawDirect targetOrdinal input output).TargetScheduleCoherent targetOrdinal := by + by_cases hfresh : state.origin.viewed.cache input = none + · simp only [afterRawDirect, hfresh, if_true] + exact OriginTargetMonitorState.targetScheduleCoherent_recordCandidate targetOrdinal + (state.advanceOrigin (state.origin.afterDirect input output)) _ _ + (state.targetScheduleCoherent_advanceOrigin targetOrdinal _ hcoherent) + · simpa [afterRawDirect, hfresh] using + state.targetScheduleCoherent_advanceOrigin targetOrdinal + (state.origin.afterDirect input output) hcoherent + + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetMonitor.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetMonitor.lean new file mode 100644 index 00000000..ba057f58 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetMonitor.lean @@ -0,0 +1,346 @@ +import SphincsSecurity.Proof.FewTimeRawTargetInvariant + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +noncomputable def rawTargetMonitoredAdversaryImpl + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) : + QueryImpl (OracleWorld + SigningSpec) + (StateT (OriginTargetMonitorState configuration) ProbComp) := by + intro input + cases input with + | inl worldInput => + exact fun state => do + let (output, origin) ← + ((originMonitoredAdversaryImpl configuration secretKey (.inl worldInput)).run + state.origin) + let advanced := state.advanceOrigin origin + match worldInput with + | .inl _ => pure (output, advanced) + | .inr hashInput => + if state.origin.viewed.cache hashInput = none then + pure (output, advanced.recordCandidate targetOrdinal + (decide (configuration.sourceAt? state.origin.directOrdinal = none ∧ + signAttemptResultOfOutput output ≠ none)) + (hashOutputFewTimeView output)) + else pure (output, advanced) + | inr request => + exact fun state => do + let (output, origin) ← + ((originMonitoredAdversaryImpl configuration secretKey (.inr request)).run + state.origin) + pure (output, state.advanceOrigin origin) + +theorem rawTargetMonitoredAdversaryImpl_expected_rawPotential_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) + (hcache : QueryCache.enncard state.origin.viewed.cache ≤ q) + (horigin : state.origin.ScheduleCoherent) + (htarget : state.TargetScheduleCoherent targetOrdinal) : + (∑' result, + Pr[= result | + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state] * result.2.rawPotential event) ≤ + state.rawPotential event := by + classical + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + simp only [rawTargetMonitoredAdversaryImpl, StateT.run, + tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + apply state.expected_rawPotential_advanceOrigin_le + intro target + exact originMonitoredAdversaryImpl_expected_potential_le configuration secretKey + (.inl (.inl uniformInput)) state.origin (fun views => event (views, target)) + q hq hcache horigin + | inr hashInput => + simp only [rawTargetMonitoredAdversaryImpl, StateT.run, + tsum_probOutput_bind_mul, tsum_probOutput_pure_mul, + originMonitoredAdversaryImpl] + by_cases hfresh : state.origin.viewed.cache hashInput = none + · simp only [hfresh, if_true, tsum_probOutput_pure_mul] + have hbound := state.expected_rawPotential_afterRawDirect_le targetOrdinal + hashInput event horigin htarget + simp only [OriginTargetMonitorState.afterRawDirect, hfresh, if_true] at hbound + convert hbound using 1 + apply tsum_congr + intro result + congr 1 + · simp only [hfresh, if_false, tsum_probOutput_pure_mul] + have hbound := state.expected_rawPotential_afterRawDirect_le targetOrdinal + hashInput event horigin htarget + simp only [OriginTargetMonitorState.afterRawDirect, hfresh, if_false] at hbound + convert hbound using 1 + apply tsum_congr + intro result + congr 1 + | inr request => + simp only [rawTargetMonitoredAdversaryImpl, StateT.run, + tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + apply state.expected_rawPotential_advanceOrigin_le + intro target + exact originMonitoredAdversaryImpl_expected_potential_le configuration secretKey + (.inr request) state.origin (fun views => event (views, target)) + q hq hcache horigin + + +theorem rawTargetMonitoredAdversaryImpl_query_projection + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) : + (fun result => (result.1, result.2.origin)) <$> + ((rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run state) = + (originMonitoredAdversaryImpl configuration secretKey input).run state.origin := by + classical + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + simp [rawTargetMonitoredAdversaryImpl, StateT.run, map_eq_bind_pure_comp, + Function.comp_apply, bind_assoc, OriginTargetMonitorState.advanceOrigin] + | inr hashInput => + by_cases hfresh : state.origin.viewed.cache hashInput = none <;> + simp [rawTargetMonitoredAdversaryImpl, StateT.run, map_eq_bind_pure_comp, + Function.comp_apply, bind_assoc, hfresh, OriginTargetMonitorState.advanceOrigin, + OriginTargetMonitorState.recordCandidate] + | inr request => + simp [rawTargetMonitoredAdversaryImpl, StateT.run, map_eq_bind_pure_comp, + Function.comp_apply, bind_assoc, OriginTargetMonitorState.advanceOrigin] + +theorem rawTargetMonitoredAdversaryImpl_query_jointCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) + (result : (OracleWorld + SigningSpec).Range input × + OriginTargetMonitorState configuration) + (hcoherent : state.JointCoherent targetOrdinal) + (hmem : result ∈ support + ((rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state)) : result.2.JointCoherent targetOrdinal := by + classical + rcases hcoherent with ⟨horigin, htarget⟩ + cases input with + | inl worldInput => + rw [rawTargetMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, origin⟩, horiginMem, hpure⟩ := hmem + cases worldInput with + | inl uniformInput => + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + constructor + · exact originMonitoredAdversaryImpl_query_scheduleCoherent configuration secretKey + (.inl (.inl uniformInput)) state.origin (output, origin) horigin horiginMem + · simpa [OriginTargetMonitorState.JointCoherent, + OriginTargetMonitorState.TargetScheduleCoherent, + OriginTargetMonitorState.advanceOrigin] using htarget + | inr hashInput => + by_cases hfresh : state.origin.viewed.cache hashInput = none + · simp only [hfresh, if_true, support_pure, Set.mem_singleton_iff] at hpure + subst result + constructor + · exact originMonitoredAdversaryImpl_query_scheduleCoherent configuration secretKey + (.inl (.inr hashInput)) state.origin (output, origin) horigin horiginMem + · exact OriginTargetMonitorState.targetScheduleCoherent_recordCandidate + targetOrdinal (state.advanceOrigin origin) _ _ + (state.targetScheduleCoherent_advanceOrigin targetOrdinal origin htarget) + · simp only [hfresh, if_false, support_pure, Set.mem_singleton_iff] at hpure + subst result + constructor + · exact originMonitoredAdversaryImpl_query_scheduleCoherent configuration secretKey + (.inl (.inr hashInput)) state.origin (output, origin) horigin horiginMem + · exact state.targetScheduleCoherent_advanceOrigin targetOrdinal origin htarget + | inr request => + rw [rawTargetMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, origin⟩, horiginMem, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + constructor + · exact originMonitoredAdversaryImpl_query_scheduleCoherent configuration secretKey + (.inr request) state.origin (output, origin) horigin horiginMem + · exact state.targetScheduleCoherent_advanceOrigin targetOrdinal origin htarget + +theorem rawTargetMonitoredAdversaryImpl_query_cache_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) + (result : (OracleWorld + SigningSpec).Range input × + OriginTargetMonitorState configuration) + (hmem : result ∈ support + ((rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state)) : state.origin.viewed.cache ≤ result.2.origin.viewed.cache := by + classical + cases input with + | inl worldInput => + rw [rawTargetMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, origin⟩, horiginMem, hpure⟩ := hmem + cases worldInput with + | inl uniformInput => + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + exact originMonitoredAdversaryImpl_query_cache_le configuration secretKey + (.inl (.inl uniformInput)) state.origin (output, origin) horiginMem + | inr hashInput => + by_cases hfresh : state.origin.viewed.cache hashInput = none + · simp only [hfresh, if_true, support_pure, Set.mem_singleton_iff] at hpure + subst result + exact originMonitoredAdversaryImpl_query_cache_le configuration secretKey + (.inl (.inr hashInput)) state.origin (output, origin) horiginMem + · simp only [hfresh, if_false, support_pure, Set.mem_singleton_iff] at hpure + subst result + exact originMonitoredAdversaryImpl_query_cache_le configuration secretKey + (.inl (.inr hashInput)) state.origin (output, origin) horiginMem + | inr request => + rw [rawTargetMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, origin⟩, horiginMem, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + exact originMonitoredAdversaryImpl_query_cache_le configuration secretKey + (.inr request) state.origin (output, origin) horiginMem + +theorem rawTargetMonitoredAdversaryImpl_projection + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) : + Prod.map id OriginTargetMonitorState.origin <$> + (simulateQ (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState = + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState.origin := by + apply OracleComp.map_run_simulateQ_eq_of_query_map_eq + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + (originMonitoredAdversaryImpl configuration secretKey) + OriginTargetMonitorState.origin + intro input state + exact rawTargetMonitoredAdversaryImpl_query_projection configuration secretKey + targetOrdinal input state + +theorem probEvent_rawTargetMonitoredAdversaryImpl_projection + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (event : α × OriginMonitorState configuration → Prop) : + Pr[event | + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState.origin] = + Pr[fun result : α × OriginTargetMonitorState configuration => + event (result.1, result.2.origin) | + (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState] := by + rw [← rawTargetMonitoredAdversaryImpl_projection configuration secretKey + targetOrdinal computation initialState, probEvent_map] + rfl + +theorem probEvent_originMonitored_le_rawTargetMonitored + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (originEvent : α × OriginMonitorState configuration → Prop) + (targetEvent : α × OriginTargetMonitorState configuration → Prop) + (himp : ∀ result ∈ support + ((simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState), + originEvent (result.1, result.2.origin) → targetEvent result) : + Pr[originEvent | + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState.origin] ≤ + Pr[targetEvent | + (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState] := by + classical + rw [probEvent_rawTargetMonitoredAdversaryImpl_projection configuration secretKey + targetOrdinal computation initialState originEvent] + exact probEvent_mono himp +theorem rawTargetMonitoredAdversaryImpl_viewed_projection + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) : + (fun result => (result.1, result.2.origin.viewed)) <$> + (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState = + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run initialState.origin.viewed := by + calc + _ = Prod.map id OriginMonitorState.viewed <$> + (Prod.map id OriginTargetMonitorState.origin <$> + (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState) := by + simp only [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro result + rfl + _ = Prod.map id OriginMonitorState.viewed <$> + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState.origin := by + rw [rawTargetMonitoredAdversaryImpl_projection] + _ = _ := originMonitoredAdversaryImpl_projection configuration secretKey + computation initialState.origin + +theorem exists_rawTargetMonitored_of_viewed_support + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (result : α × ViewedFullTraceState) + (hmem : result ∈ support + ((simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run initialState.origin.viewed)) : + ∃ monitored ∈ support + ((simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState), + monitored.1 = result.1 ∧ monitored.2.origin.viewed = result.2 := by + rw [← rawTargetMonitoredAdversaryImpl_viewed_projection configuration secretKey + targetOrdinal computation initialState, support_map] at hmem + obtain ⟨monitored, hmonitored, heq⟩ := hmem + refine ⟨monitored, hmonitored, ?_⟩ + exact Prod.mk.inj heq + +theorem probEvent_viewed_le_rawTargetMonitoredAdversaryImpl + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (viewedEvent : α × ViewedFullTraceState → Prop) + (monitoredEvent : α × OriginTargetMonitorState configuration → Prop) + (himp : ∀ result ∈ support + ((simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState), + viewedEvent (result.1, result.2.origin.viewed) → monitoredEvent result) : + Pr[viewedEvent | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run initialState.origin.viewed] ≤ + Pr[monitoredEvent | + (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState] := by + classical + rw [← rawTargetMonitoredAdversaryImpl_viewed_projection configuration secretKey + targetOrdinal computation initialState, probEvent_map] + exact probEvent_mono himp + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetNonfresh.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetNonfresh.lean new file mode 100644 index 00000000..030cbc3e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetNonfresh.lean @@ -0,0 +1,213 @@ +import SphincsSecurity.Proof.FewTimeRawTargetClassify + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +def ViewedHonestProperFewTimeLeakWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := + ViewedTerminalWitnessFor parameter otsSecret ftsSecret + fun f cache secretKey signingLog forgery index leaves => + ProperFewTimeLeak f cache secretKey signingLog index leaves ∧ + FullyHonestOpening f cache secretKey index leaves forgery.signature + +noncomputable instance (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + DecidablePred (ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret) := + fun _ => Classical.propDecidable _ + +theorem probEvent_exists_fixedRawTargetViewedTerminal_le_idealOrigin + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q : Nat) + (hq : q ≤ 2 ^ 126) (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[fun result => ∃ distinct ∈ Finset.Icc 1 14, + ∃ pattern : FewTimePattern signatures distinct, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin q, + FixedRawTargetViewedTerminal secretKey computation initialCache q + configuration candidate.val result | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] ≤ + q * rawTargetOriginUnionBound signatures sources := by + apply probEvent_exists_originConfiguration_fixedRawOrdinal_viewedEvent_le_idealOrigin + secretKey computation initialCache signatures sources q hq hcache q + (fun _ _ configuration candidate => + FixedRawTargetViewedTerminal secretKey computation initialCache q + configuration candidate.val) + intro distinct pattern configuration candidate result hresult hevent + obtain ⟨hcacheFinal, hterminal⟩ := hevent + obtain ⟨hcomplete, hhit⟩ := hterminal result hresult rfl + exact ⟨hcomplete, hhit, hcacheFinal⟩ + +theorem probEvent_gameRestWithViewTrace_nonfresh_honest_leak_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (root : Digest) (rootCache : QueryCache HashSpec) + (hroot : (root, rootCache) ∈ support + ((simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅)) : + Pr[fun rest => + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, rest.1.1, rest.1.2), rest.2) + ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∧ ¬VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache] ≤ + q * rawTargetOriginUnionBound signatureLimit q := by + classical + let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + let publicKey : PublicKey := ⟨root, parameter⟩ + let initialState : ViewedFullTraceState := + ⟨rootCache, ⟨[], [], []⟩, [], none⟩ + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState + let finish : Forgery × ViewedFullTraceState → + ProbComp ((Forgery × Bool) × ViewedFullTraceState) := fun prior => do + let ((verified, targetView), finalCache) ← + (simulateQ romImpl + (liftM (verifyWithView publicKey prior.1.message prior.1.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run prior.2.cache + let log := prior.2.trace.signing.toSigningLog + let verdict := decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log prior.1) && verified + pure ((prior.1, verdict), + ⟨finalCache, prior.2.trace, prior.2.views, some targetView⟩) + let prefixEvent := fun prior : Forgery × ViewedFullTraceState => + ∃ distinct ∈ Finset.Icc 1 14, + ∃ pattern : FewTimePattern signatureLimit distinct, + ∃ configuration : OriginConfiguration pattern q, + ∃ candidate : Fin q, + FixedRawTargetViewedTerminal secretKey (adversary.main publicKey) + rootCache q configuration candidate.val prior + have hgame : gameRestWithViewTrace adversary publicKey secretKey rootCache = + run >>= finish := by + rfl + rw [show ⟨root, parameter⟩ = publicKey from rfl, + show ⟨parameter, root, otsSecret, ftsSecret⟩ = secretKey from rfl, hgame] + calc + _ ≤ Pr[prefixEvent | run] := by + apply probEvent_bind_le_probEvent + intro prior hprior hnotPrefix + rcases prior with ⟨forgery, state⟩ + apply probEvent_eq_zero + intro rest hrest hevent + rw [mem_support_bind_iff] at hrest + obtain ⟨⟨⟨verified, targetView⟩, finalCache⟩, hverify, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst rest + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) + have hrestSupport : + ((forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) ∈ + support (gameRestWithViewTrace adversary publicKey secretKey rootCache) := by + rw [hgame, mem_support_bind_iff] + refine ⟨(forgery, state), hprior, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨((verified, targetView), finalCache), hverify, + by simp only [support_pure, Set.mem_singleton_iff]⟩ + have hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret) := by + rw [gameAfterSecretsWithViewTrace, mem_support_bind_iff] + refine ⟨(root, rootCache), hroot, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨_, hrestSupport, by simp [result]⟩ + obtain ⟨f, digest, hf, hvalid, _, hdigest, hadmissible, hproper, hfull⟩ := hevent.1 + have hcacheLe : state.cache ≤ finalCache := + simulateQ_romImpl_cache_le + (liftM (verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView)) state.cache + ((verified, targetView), finalCache) hverify + rcases gameAfterSecretsWithViewTrace_honestLeak_target_classified_at_adversary_state + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts result hresult + f hf digest hdigest hadmissible hproper hfull hvalid rootCache state rfl hcacheLe with + hfresh | hclassified + · exact hevent.2 hfresh + · obtain ⟨distinct, hdistinct, pattern, configuration, candidate, hterminal⟩ := + hclassified + apply hnotPrefix + exact ⟨distinct, hdistinct, pattern, configuration, candidate, hterminal⟩ + _ ≤ _ := probEvent_exists_fixedRawTargetViewedTerminal_le_idealOrigin + secretKey (adversary.main publicKey) rootCache signatureLimit q q hqMax + (by + have hroot' : QueryCache.enncard rootCache ≤ q := by + have hprojected : (root, rootCache) ∈ support + ((simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅) := hroot + have hgameBound := isQueryBoundP_gameAfterSecrets adversary q hq + hparameter hots hfts + rw [gameAfterSecrets] at hgameBound + have hrootBound := OracleComp.IsQueryBoundP.of_bind_left + (p := fun input : OracleWorld.Domain => input matches Sum.inr _) hgameBound + have hbound := simulateQ_romImpl_enncard_le_queryBound + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest) q + hrootBound + (root, rootCache) hprojected + exact hbound + exact hroot') + +theorem probEvent_gameAfterSecretsWithViewTrace_nonfresh_honest_leak_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun result => + ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∧ ¬VerifierFreshTarget parameter result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + q * rawTargetOriginUnionBound signatureLimit q := by + rw [gameAfterSecretsWithViewTrace] + apply probEvent_bind_le_of_forall_le + rintro ⟨root, rootCache⟩ hroot + let attach := fun rest : (Forgery × Bool) × ViewedFullTraceState => + ((root, rest.1.1, rest.1.2), rest.2) + change Pr[fun result => + ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result ∧ + ¬VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache >>= pure ∘ attach] ≤ _ + rw [probEvent_bind_pure_comp] + exact probEvent_gameRestWithViewTrace_nonfresh_honest_leak_le adversary q hq hqMax + parameter hparameter otsSecret hots ftsSecret hfts root rootCache hroot + +theorem probEvent_gameAfterSecretsWithViewTrace_nonfresh_honest_leak_le_mul_inv131 + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 125) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun result => + ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∧ ¬VerifierFreshTarget parameter result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + q * ((2 ^ 131 : Nat) : ℝ≥0∞)⁻¹ := by + exact (probEvent_gameAfterSecretsWithViewTrace_nonfresh_honest_leak_le adversary q hq (hqMax.trans (by norm_num)) + parameter hparameter otsSecret hots ftsSecret hfts).trans + (mul_le_mul' le_rfl (rawTargetOriginUnionBound_le_inv131 le_rfl hqMax)) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetSource.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetSource.lean new file mode 100644 index 00000000..ff1c562f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetSource.lean @@ -0,0 +1,163 @@ +import SphincsSecurity.Proof.FewTimeRawTargetExtraction + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem rawTargetCandidateViews_length_le_directIntervalCount + (intervals : List AdversaryCacheEntry) : + (rawTargetCandidateViews intervals).length ≤ directIntervalCount intervals := by + induction intervals with + | nil => exact le_rfl + | cons entry rest ih => + rcases entry with ⟨input, output, before, after⟩ + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + simpa [rawTargetCandidateViews, rawTargetCandidateView?, directIntervalCount, + isDirectHashQuery] using ih + | inr hashInput => + by_cases hfresh : before hashInput = none <;> + simpa [rawTargetCandidateViews, rawTargetCandidateView?, directIntervalCount, + isDirectHashQuery, hfresh] using (show (rawTargetCandidateViews rest).length + + (if before hashInput = none then 1 else 0) ≤ directIntervalCount rest + 1 by + split_ifs; omega) + | inr request => + simpa [rawTargetCandidateViews, rawTargetCandidateView?, directIntervalCount, + isDirectHashQuery] using ih + +theorem directIntervalCount_eq_directHashQueries_length (intervals : List AdversaryCacheEntry) : + directIntervalCount intervals = + (directHashQueries (intervals.map AdversaryCacheEntry.queryEntry)).length := by + induction intervals with + | nil => rfl + | cons entry rest ih => + rcases entry with ⟨input, output, before, after⟩ + cases input with + | inl worldInput => + cases worldInput <;> + simpa [directIntervalCount, directHashQueries, AdversaryCacheEntry.queryEntry, + isDirectHashQuery] using ih + | inr request => + simpa [directIntervalCount, directHashQueries, AdversaryCacheEntry.queryEntry, + isDirectHashQuery] using ih + +theorem FullAdversaryTrace.directIntervalCount_eq_hashQueries_length + (trace : FullAdversaryTrace) (hconsistent : trace.Consistent) : + directIntervalCount trace.intervals = trace.hashQueries.length := by + rw [directIntervalCount_eq_directHashQueries_length, hconsistent.1] + rfl + +theorem rawTargetCandidateOrdinal_lt_bound + (intervals : List AdversaryCacheEntry) (source : Fin intervals.length) + (input : HashInput) (output : HashOutput) (before after : QueryCache HashSpec) + (hentry : intervals.get source = ⟨.inl (.inr input), output, before, after⟩) + (hfresh : before input = none) (q : Nat) (hq : directIntervalCount intervals ≤ q) : + (rawTargetCandidateViews (intervals.take source.val)).length < q := by + have hsplit := trace_take_get_drop intervals source + rw [hentry] at hsplit + apply lt_of_lt_of_le _ ((rawTargetCandidateViews_length_le_directIntervalCount intervals).trans hq) + conv_rhs => rw [hsplit, rawTargetCandidateViews_append] + simp [rawTargetCandidateViews, rawTargetCandidateView?, hfresh] + +theorem gameAfterSecretsWithViewTrace_directIntervalCount_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) : + directIntervalCount result.2.trace.intervals ≤ q := by + have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hresult, rfl⟩ + have hintervals := gameAfterSecretsWithFullTrace_support_interval_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + rw [FullAdversaryTrace.directIntervalCount_eq_hashQueries_length result.2.trace + (show result.2.trace.Consistent from hintervals.1)] + exact gameAfterSecretsWithFullTrace_hashQueries_length_le adversary q hq parameter hparameter + otsSecret hots ftsSecret hfts (result.1, result.2.base) hbase + +theorem AdversaryCacheEntry.exists_direct_fields (entry : AdversaryCacheEntry) + (input : HashInput) (hinput : entry.input = .inl (.inr input)) : + ∃ output before after, entry = ⟨.inl (.inr input), output, before, after⟩ := by + rcases entry with ⟨entryInput, output, before, after⟩ + rcases entryInput with worldInput | request + · rcases worldInput with uniformInput | hashInput + · simp at hinput + · simp only [Sum.inl.injEq, Sum.inr.injEq] at hinput + subst hashInput + exact ⟨output, before, after, rfl⟩ + · simp at hinput + +theorem gameAfterSecretsWithViewTrace_fullyHonest_target_source_entry + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest parameter result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) = digest) + (hadmissible : Admissible digest) + (hproper : ProperFewTimeLeak f result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest)) + (hfull : FullyHonestOpening f result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + (digestIndex digest) (digestLeaves digest) result.1.2.1.signature) + (source : Fin result.2.trace.intervals.length) + (hbefore : (result.2.trace.intervals.get source).initialCache + (tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness)) = none) + (hafter : (result.2.trace.intervals.get source).finalCache + (tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness)) ≠ none) + (hkind : (result.2.trace.intervals.get source).input = .inl (.inr + (tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness))) ∨ + ∃ request, (result.2.trace.intervals.get source).input = .inr request) : + ∃ output before after, + result.2.trace.intervals.get source = + ⟨.inl (.inr (tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness))), output, before, after⟩ ∧ + before (tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness)) = none ∧ + signAttemptResultOfOutput output = some (digestIndex digest, digestLeaves digest) := by + have hdirect := gameAfterSecretsWithViewTrace_fullyHonest_target_source_direct adversary + parameter otsSecret ftsSecret result hresult f hf digest hdigest hadmissible hproper hfull + source hbefore hafter hkind + obtain ⟨output, _, _, houtput, hattempt⟩ := + gameAfterSecretsWithViewTrace_target_source_candidate adversary parameter otsSecret + ftsSecret result hresult f hf digest hdigest hadmissible source hbefore hafter hkind + obtain ⟨entryOutput, before, after, hentry⟩ := + AdversaryCacheEntry.exists_direct_fields (result.2.trace.intervals.get source) _ hdirect + have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hresult, rfl⟩ + have hvalid := gameAfterSecretsWithFullTrace_support_validIntervals adversary parameter + otsSecret ftsSecret (result.1, result.2.base) hbase + have hcached := result.2.trace.directHashInterval_cached hvalid _ entryOutput before after + (by rw [← hentry]; exact List.get_mem _ source) + rw [hentry] at hbefore houtput + have heq : entryOutput = output := Option.some.inj (hcached.symm.trans houtput) + subst entryOutput + exact ⟨output, before, after, hentry, hbefore, hattempt⟩ + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetTrace.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetTrace.lean new file mode 100644 index 00000000..9369e7ec --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetTrace.lean @@ -0,0 +1,203 @@ +import SphincsSecurity.Proof.FewTimeRawTargetUnion + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +def rawTargetCandidateView? (entry : AdversaryCacheEntry) : Option FewTimeView := + match entry with + | ⟨.inl (.inr input), output, initialCache, _⟩ => + if initialCache input = none then some (hashOutputFewTimeView output) else none + | _ => none + +def rawTargetCandidateViews (intervals : List AdversaryCacheEntry) : List FewTimeView := + intervals.filterMap rawTargetCandidateView? + +theorem rawTargetCandidateViews_append (left right : List AdversaryCacheEntry) : + rawTargetCandidateViews (left ++ right) = + rawTargetCandidateViews left ++ rawTargetCandidateViews right := by + exact List.filterMap_append + +def OriginTargetMonitorState.RawCandidateTraceCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) : Prop := + state.candidateViews = rawTargetCandidateViews state.origin.viewed.trace.intervals + +theorem OriginTargetMonitorState.rawCandidateTraceCoherent_initial + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (cache : QueryCache HashSpec) : + (OriginTargetMonitorState.initial configuration cache).RawCandidateTraceCoherent := rfl + +theorem rawTargetMonitoredAdversaryImpl_query_rawCandidateTraceCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) + (result : (OracleWorld + SigningSpec).Range input × OriginTargetMonitorState configuration) + (hcoherent : state.RawCandidateTraceCoherent) + (hmem : result ∈ support + ((rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run state)) : + result.2.RawCandidateTraceCoherent := by + classical + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + simp only [rawTargetMonitoredAdversaryImpl, originMonitoredAdversaryImpl, + StateT.run, bind_assoc, pure_bind, mem_support_bind_iff] at hmem + obtain ⟨run, _, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + simpa [OriginTargetMonitorState.RawCandidateTraceCoherent, + OriginTargetMonitorState.advanceOrigin, fullAdversaryTraceUpdate, + rawTargetCandidateViews_append, rawTargetCandidateViews, rawTargetCandidateView?] + using hcoherent + | inr hashInput => + simp only [rawTargetMonitoredAdversaryImpl, originMonitoredAdversaryImpl, + StateT.run, bind_assoc, pure_bind, mem_support_bind_iff] at hmem + obtain ⟨run, _, hpure⟩ := hmem + by_cases hfresh : state.origin.viewed.cache hashInput = none + · simp only [hfresh, if_true, support_pure, Set.mem_singleton_iff] at hpure + subst result + simpa [OriginTargetMonitorState.RawCandidateTraceCoherent, + OriginTargetMonitorState.advanceOrigin, OriginTargetMonitorState.recordCandidate, + fullAdversaryTraceUpdate, rawTargetCandidateViews_append, + rawTargetCandidateViews, rawTargetCandidateView?, hfresh] using hcoherent + · simp only [hfresh, if_false, support_pure, Set.mem_singleton_iff] at hpure + subst result + simpa [OriginTargetMonitorState.RawCandidateTraceCoherent, + OriginTargetMonitorState.advanceOrigin, fullAdversaryTraceUpdate, + rawTargetCandidateViews_append, rawTargetCandidateViews, rawTargetCandidateView?, + hfresh] using hcoherent + | inr request => + simp only [rawTargetMonitoredAdversaryImpl, originMonitoredAdversaryImpl, + StateT.run, bind_assoc, pure_bind, mem_support_bind_iff] at hmem + obtain ⟨run, _, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + simpa [OriginTargetMonitorState.RawCandidateTraceCoherent, + OriginTargetMonitorState.advanceOrigin, fullAdversaryTraceUpdate, + rawTargetCandidateViews_append, rawTargetCandidateViews, rawTargetCandidateView?] + using hcoherent + +theorem rawTargetMonitoredAdversaryImpl_rawCandidateTraceCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (result : α × OriginTargetMonitorState configuration) + (hcoherent : initialState.RawCandidateTraceCoherent) + (hmem : result ∈ support + ((simulateQ (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState)) : result.2.RawCandidateTraceCoherent := by + exact OracleComp.simulateQ_run_preservesInv + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + OriginTargetMonitorState.RawCandidateTraceCoherent + (by + intro input state hstate queryResult hquery + exact rawTargetMonitoredAdversaryImpl_query_rawCandidateTraceCoherent + configuration secretKey targetOrdinal input state queryResult hstate hquery) + computation initialState hcoherent result hmem + +theorem rawTargetMonitoredAdversaryImpl_query_preserves_of_advance_record + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (P : OriginTargetMonitorState configuration → Prop) + (hadvance : ∀ state origin, P state → P (state.advanceOrigin origin)) + (hrecord : ∀ state allowed view, P state → + P (state.recordCandidate targetOrdinal allowed view)) + (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) + (result : (OracleWorld + SigningSpec).Range input × OriginTargetMonitorState configuration) + (hstate : P state) + (hmem : result ∈ support + ((rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run state)) : + P result.2 := by + cases input with + | inl worldInput => + simp only [rawTargetMonitoredAdversaryImpl, StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, origin⟩, _, hpure⟩ := hmem + cases worldInput with + | inl uniformInput => + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + exact hadvance state origin hstate + | inr hashInput => + by_cases hfresh : state.origin.viewed.cache hashInput = none + · simp only [hfresh, if_true, support_pure, Set.mem_singleton_iff] at hpure + subst result + exact hrecord _ _ _ (hadvance state origin hstate) + · simp only [hfresh, if_false, support_pure, Set.mem_singleton_iff] at hpure + subst result + exact hadvance state origin hstate + | inr request => + simp only [rawTargetMonitoredAdversaryImpl, StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, origin⟩, _, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + exact hadvance state origin hstate + +theorem rawTargetMonitoredAdversaryImpl_candidateViewsCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (result : α × OriginTargetMonitorState configuration) + (hcoherent : initialState.CandidateViewsCoherent targetOrdinal) + (hmem : result ∈ support + ((simulateQ (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState)) : result.2.CandidateViewsCoherent targetOrdinal := by + apply OracleComp.simulateQ_run_preservesInv + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + (OriginTargetMonitorState.CandidateViewsCoherent targetOrdinal) + _ computation initialState hcoherent result hmem + intro input state hstate queryResult hquery + exact rawTargetMonitoredAdversaryImpl_query_preserves_of_advance_record + configuration secretKey targetOrdinal _ + (fun state origin h => state.candidateViewsCoherent_advanceOrigin targetOrdinal origin h) + (fun state allowed view h => state.candidateViewsCoherent_recordCandidate + targetOrdinal allowed view h) input state queryResult hstate hquery + +theorem rawTargetMonitoredAdversaryImpl_candidateAllowedCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (result : α × OriginTargetMonitorState configuration) + (hcoherent : initialState.CandidateAllowedCoherent targetOrdinal) + (hmem : result ∈ support + ((simulateQ (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState)) : result.2.CandidateAllowedCoherent targetOrdinal := by + apply OracleComp.simulateQ_run_preservesInv + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + (OriginTargetMonitorState.CandidateAllowedCoherent targetOrdinal) + _ computation initialState hcoherent result hmem + intro input state hstate queryResult hquery + exact rawTargetMonitoredAdversaryImpl_query_preserves_of_advance_record + configuration secretKey targetOrdinal _ + (fun state origin h => state.candidateAllowedCoherent_advanceOrigin targetOrdinal origin h) + (fun state allowed view h => state.candidateAllowedCoherent_recordCandidate + targetOrdinal allowed view h) input state queryResult hstate hquery + +theorem rawTargetMonitoredAdversaryImpl_targetView_eq_trace + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) + (result : α × OriginTargetMonitorState configuration) + (hmem : result ∈ support + ((simulateQ (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run (OriginTargetMonitorState.initial configuration initialCache))) : + result.2.targetView = + (rawTargetCandidateViews result.2.origin.viewed.trace.intervals)[targetOrdinal]? := by + have hviews := rawTargetMonitoredAdversaryImpl_candidateViewsCoherent configuration secretKey + targetOrdinal computation _ result + (OriginTargetMonitorState.candidateViewsCoherent_initial configuration initialCache + targetOrdinal) hmem + have htrace := rawTargetMonitoredAdversaryImpl_rawCandidateTraceCoherent configuration secretKey + targetOrdinal computation _ result + (OriginTargetMonitorState.rawCandidateTraceCoherent_initial configuration initialCache) hmem + exact hviews.2.trans (congrArg (fun views => views[targetOrdinal]?) htrace) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetUnion.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetUnion.lean new file mode 100644 index 00000000..6f171355 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawTargetUnion.lean @@ -0,0 +1,269 @@ +import SphincsSecurity.Proof.FewTimeRawTargetBound + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem probEvent_exists_fixedRawOrdinal_viewedEvent_le_ideal + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (q : Nat) (hq : q ≤ 2 ^ 126) + (hcache : QueryCache.enncard initialCache ≤ q) (candidates : Nat) + (viewedEvent : Fin candidates → α × ViewedFullTraceState → Prop) + (himp : ∀ (candidate : Fin candidates) + (result : α × OriginTargetMonitorState configuration), + result ∈ support + ((simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey candidate.val) + computation).run (OriginTargetMonitorState.initial configuration initialCache)) → + viewedEvent candidate (result.1, result.2.origin.viewed) → + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q) : + Pr[fun result => ∃ candidate : Fin candidates, viewedEvent candidate result | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run + (OriginTargetMonitorState.initial configuration initialCache).origin.viewed] ≤ + candidates * Pr[configuration.RawTargetHit | + ($ᵗ configuration.RawTargetSample : ProbComp configuration.RawTargetSample)] := by + classical + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run + (OriginTargetMonitorState.initial configuration initialCache).origin.viewed + calc + Pr[fun result => ∃ candidate : Fin candidates, viewedEvent candidate result | run] = + Pr[fun result => ∃ candidate ∈ (Finset.univ : Finset (Fin candidates)), + viewedEvent candidate result | run] := by + congr 1 + funext result + simp + _ ≤ ∑ candidate ∈ (Finset.univ : Finset (Fin candidates)), + Pr[viewedEvent candidate | run] := + probEvent_exists_finset_le_sum Finset.univ run viewedEvent + _ ≤ ∑ _candidate ∈ (Finset.univ : Finset (Fin candidates)), + Pr[configuration.RawTargetHit | + ($ᵗ configuration.RawTargetSample : ProbComp configuration.RawTargetSample)] := by + apply Finset.sum_le_sum + intro candidate _ + calc + Pr[viewedEvent candidate | run] ≤ + Pr[fun result : α × OriginTargetMonitorState configuration => + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q | + (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey candidate.val) + computation).run + (OriginTargetMonitorState.initial configuration initialCache)] := + probEvent_viewed_le_rawTargetMonitoredAdversaryImpl configuration secretKey + candidate.val computation (OriginTargetMonitorState.initial configuration initialCache) + (viewedEvent candidate) _ (himp candidate) + _ ≤ _ := probEvent_rawTargetMonitored_complete_fixedPattern_le_ideal + configuration secretKey candidate.val computation initialCache q hq hcache + _ = _ := by + rw [Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul] + +theorem probEvent_exists_originConfiguration_fixedRawOrdinal_viewedEvent_le_idealOrigin + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q : Nat) + (hq : q ≤ 2 ^ 126) (hcache : QueryCache.enncard initialCache ≤ q) + (candidates : Nat) + (viewedEvent : ∀ (distinct : Nat) (pattern : FewTimePattern signatures distinct), + OriginConfiguration pattern sources → Fin candidates → + α × ViewedFullTraceState → Prop) + (himp : ∀ (distinct : Nat) (pattern : FewTimePattern signatures distinct) + (configuration : OriginConfiguration pattern sources) (candidate : Fin candidates) + (result : α × OriginTargetMonitorState configuration), + result ∈ support + ((simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey candidate.val) + computation).run (OriginTargetMonitorState.initial configuration initialCache)) → + viewedEvent distinct pattern configuration candidate + (result.1, result.2.origin.viewed) → + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q) : + Pr[fun result => ∃ distinct ∈ Finset.Icc 1 14, + ∃ pattern : FewTimePattern signatures distinct, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] ≤ + candidates * rawTargetOriginUnionBound signatures sources := by + classical + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩ + calc + Pr[fun result => ∃ distinct ∈ Finset.Icc 1 14, + ∃ pattern : FewTimePattern signatures distinct, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | run] ≤ + ∑ distinct ∈ Finset.Icc 1 14, + Pr[fun result => + ∃ pattern : FewTimePattern signatures distinct, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | run] := + probEvent_exists_finset_le_sum (Finset.Icc 1 14) run fun distinct result => + ∃ pattern : FewTimePattern signatures distinct, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result + _ ≤ ∑ distinct ∈ Finset.Icc 1 14, + ∑ pattern : FewTimePattern signatures distinct, + Pr[fun result => + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | run] := by + apply Finset.sum_le_sum + intro distinct _ + calc + _ = Pr[fun result => + ∃ pattern ∈ (Finset.univ : Finset (FewTimePattern signatures distinct)), + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | run] := by + congr 1 + funext result + simp + _ ≤ _ := probEvent_exists_finset_le_sum Finset.univ run fun pattern result => + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result + _ ≤ ∑ distinct ∈ Finset.Icc 1 14, + ∑ pattern : FewTimePattern signatures distinct, + ∑ configuration : OriginConfiguration pattern sources, + Pr[fun result => ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | run] := by + apply Finset.sum_le_sum + intro distinct _ + apply Finset.sum_le_sum + intro pattern _ + calc + _ = Pr[fun result => + ∃ configuration ∈ + (Finset.univ : Finset (OriginConfiguration pattern sources)), + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | run] := by + congr 1 + funext result + simp + _ ≤ _ := probEvent_exists_finset_le_sum Finset.univ run fun configuration result => + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result + _ ≤ ∑ distinct ∈ Finset.Icc 1 14, + ∑ pattern : FewTimePattern signatures distinct, + ∑ configuration : OriginConfiguration pattern sources, + candidates * Pr[configuration.RawTargetHit | + ($ᵗ configuration.RawTargetSample : ProbComp configuration.RawTargetSample)] := by + apply Finset.sum_le_sum + intro distinct _ + apply Finset.sum_le_sum + intro pattern _ + apply Finset.sum_le_sum + intro configuration _ + exact probEvent_exists_fixedRawOrdinal_viewedEvent_le_ideal configuration secretKey + computation initialCache q hq hcache candidates + (viewedEvent distinct pattern configuration) + (himp distinct pattern configuration) + _ = candidates * rawTargetOriginUnionBound signatures sources := by + rw [rawTargetOriginUnionBound] + simp_rw [← Finset.mul_sum] + +def FixedRawTargetViewedTerminal + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (q : Nat) + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (candidate : Nat) + (result : α × ViewedFullTraceState) : Prop := + QueryCache.enncard result.2.cache ≤ q ∧ + ∀ monitored : α × OriginTargetMonitorState configuration, + monitored ∈ support + ((simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey candidate) + computation).run (OriginTargetMonitorState.initial configuration initialCache)) → + (monitored.1, monitored.2.origin.viewed) = result → + monitored.2.Complete ∧ + ∀ target, monitored.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (monitored.2.origin.observation.views, target) + +noncomputable instance + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (q : Nat) + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (candidate : Nat) : + DecidablePred + (FixedRawTargetViewedTerminal secretKey computation initialCache q + configuration candidate) := + fun result => Classical.propDecidable + (FixedRawTargetViewedTerminal secretKey computation initialCache q + configuration candidate result) + +@[irreducible] def SomeFixedRawTargetViewedTerminal + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q candidates : Nat) + (result : α × ViewedFullTraceState) : Prop := + ∃ distinct ∈ Finset.Icc 1 14, + ∃ pattern : FewTimePattern signatures distinct, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + FixedRawTargetViewedTerminal secretKey computation initialCache q + configuration candidate.val result + +noncomputable instance + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q candidates : Nat) : + DecidablePred (SomeFixedRawTargetViewedTerminal secretKey computation + initialCache signatures sources q candidates) := + fun result => Classical.propDecidable + (SomeFixedRawTargetViewedTerminal secretKey computation initialCache + signatures sources q candidates result) + +theorem probEvent_exists_fixedRawTargetViewedTerminal_le_idealOrigin_of_candidates + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q : Nat) + (hq : q ≤ 2 ^ 126) (hcache : QueryCache.enncard initialCache ≤ q) + (candidates : Nat) : + Pr[SomeFixedRawTargetViewedTerminal secretKey computation initialCache + signatures sources q candidates | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] ≤ + candidates * rawTargetOriginUnionBound signatures sources := by + unfold SomeFixedRawTargetViewedTerminal + apply probEvent_exists_originConfiguration_fixedRawOrdinal_viewedEvent_le_idealOrigin + secretKey computation initialCache signatures sources q hq hcache candidates + (fun _ _ configuration candidate => + FixedRawTargetViewedTerminal secretKey computation initialCache q + configuration candidate.val) + intro distinct pattern configuration candidate result hresult hevent + obtain ⟨hcacheFinal, hterminal⟩ := hevent + have hprojection : (result.1, result.2.origin.viewed) = + (result.1, result.2.origin.viewed) := rfl + obtain ⟨hcomplete, hhit⟩ := hterminal result hresult hprojection + exact ⟨hcomplete, hhit, hcacheFinal⟩ + +theorem probEvent_exists_fixedRawTargetViewedTerminal_le_mul_inv131 + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures q candidates : Nat) + (hsignatures : signatures ≤ signatureLimit) + (hq : q ≤ 2 ^ 125) (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[SomeFixedRawTargetViewedTerminal secretKey computation initialCache + signatures q q candidates | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] ≤ + candidates * ((2 ^ 131 : Nat) : ℝ≥0∞)⁻¹ := by + exact (probEvent_exists_fixedRawTargetViewedTerminal_le_idealOrigin_of_candidates + secretKey computation initialCache signatures q q (hq.trans (by norm_num)) hcache candidates).trans + (mul_le_mul' le_rfl (rawTargetOriginUnionBound_le_inv131 hsignatures hq)) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeRawVerifierTarget.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawVerifierTarget.lean new file mode 100644 index 00000000..5d383bc0 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeRawVerifierTarget.lean @@ -0,0 +1,108 @@ +import SphincsSecurity.Proof.FewTimeRawTargetNonfresh + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem OriginConfiguration.raw_verifierTarget_fixedTerminal + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hproper : ProperFewTimeLeak f result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest)) + {limit sources : Nat} (hle : result.2.trace.signing.toSigningLog.length ≤ limit) + (configuration : OriginConfiguration (hproper.1.cover.pattern.pad hle) sources) + (hrealized : configuration.PaddedRealizedBy hproper.1.cover hle result.2.trace rfl) + (rootCache : QueryCache HashSpec) (state : ViewedFullTraceState) + (hadversary : (result.1.2.1, state) ∈ support + ((simulateQ (viewedFullTracedMappedAdversaryImpl + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩) + (adversary.main ⟨result.1.1, parameter⟩)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩)) + (htrace : result.2.trace = state.trace) (_hviews : result.2.views = state.views) + (input : HashInput) (output : HashOutput) (digestCache : QueryCache HashSpec) + (hinput : input = tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness)) + (hmiss : state.cache input = none) + (hquery : (output, digestCache) ∈ support ((randomOracle input).run state.cache)) + (_hdigestCache : digestCache ≤ result.2.cache) + (htargetView : hashOutputFewTimeView output = + fewTimeTargetView (digestIndex digest) (digestLeaves digest)) + (hadmissible : signAttemptResultOfOutput output ≠ none) + (q : Nat) (hcache : QueryCache.enncard digestCache ≤ q) : + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + let publicKey : PublicKey := ⟨result.1.1, parameter⟩ + let appended := appendTargetViewedState (.inl (.inr input)) state.cache output + digestCache none state + let targetOrdinal := (rawTargetCandidateViews state.trace.intervals).length + FixedRawTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache q configuration + targetOrdinal ((result.1.2.1, output), appended) := by + classical + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + let publicKey : PublicKey := ⟨result.1.1, parameter⟩ + let appended := appendTargetViewedState (.inl (.inr input)) state.cache output + digestCache none state + let targetOrdinal := (rawTargetCandidateViews state.trace.intervals).length + have haugmented : ((result.1.2.1, output), appended) ∈ support + ((simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversaryWithTargetQuery adversary publicKey)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩) := by + subst input + exact adversaryWithTargetQuery_viewed_support adversary publicKey secretKey + rootCache result.1.2.1 state hadversary output digestCache hquery + refine ⟨hcache, ?_⟩ + intro monitored hmonitored heq + have hstateEq : monitored.2.origin.viewed = appended := congrArg Prod.snd heq + have hstateTraceEq : appended.trace = monitored.2.origin.viewed.trace := + congrArg ViewedFullTraceState.trace hstateEq.symm + have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hresult, rfl⟩ + have hsourceNone : configuration.sourceAt? (directIntervalCount state.trace.intervals) = none := by + rw [← htrace] + exact configuration.paddedRealized_sourceAt_directIntervalCount_eq_none hrealized + obtain ⟨hlogState, hrealizedState⟩ := + configuration.paddedRealized_transport result.2.trace state.trace htrace rfl hrealized + obtain ⟨hlogAppended, hrealizedAppended⟩ := + configuration.paddedRealized_append_direct state hlogState hrealizedState input output digestCache + obtain ⟨hlogMonitored, hrealizedMonitored⟩ := + configuration.paddedRealized_transport appended.trace monitored.2.origin.viewed.trace + hstateTraceEq hlogAppended hrealizedAppended + have haugmentedIntervals := viewedFullTracedMappedAdversaryImpl_interval_invariants + secretKey (adversaryWithTargetQuery adversary publicKey) rootCache + ((result.1.2.1, output), appended) haugmented + have haugmentedValid := viewedFullTracedMappedAdversaryImpl_validIntervals + secretKey (adversaryWithTargetQuery adversary publicKey) rootCache + ((result.1.2.1, output), appended) haugmented + have hcaches : appended.trace.signing.CachesLe result.2.cache := by + have hcachesState : state.trace.signing.CachesLe result.2.cache := by + rw [← htrace] + exact (gameAfterSecretsWithFullTrace_support_invariants adversary parameter + otsSecret ftsSecret (result.1, result.2.base) hbase).2.1 + simpa [appended, appendTargetViewedState, fullAdversaryTraceUpdate, + signingCacheTraceUpdate] using hcachesState + have htraceSplit : monitored.2.origin.viewed.trace.intervals = + state.trace.intervals ++ [⟨.inl (.inr input), output, state.cache, digestCache⟩] := by + simp [hstateEq, appended, appendTargetViewedState, fullAdversaryTraceUpdate] + apply configuration.raw_target_complete_and_hit (adversaryWithTargetQuery adversary publicKey) + rootCache state.trace.intervals [] input output state.cache digestCache hmiss hsourceNone + hadmissible htargetView monitored hmonitored htraceSplit hlogMonitored hrealizedMonitored + · rw [← hstateTraceEq] + exact haugmentedValid + · rw [← hstateTraceEq] + exact haugmentedIntervals.2.2 + · rw [← hstateTraceEq] + exact hcaches + · exact hf + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeSignerCompletion.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeSignerCompletion.lean new file mode 100644 index 00000000..a7abfe22 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeSignerCompletion.lean @@ -0,0 +1,222 @@ +import SphincsSecurity.Proof.FewTimeTargetView + +/-! A valid counter for every honest layer rules out failure after the signer has selected its message digest. The bounded search covers the entire counter type. -/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +theorem otsSignFrom_ne_none_of_valid_counter (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) + (secret : ChainIndex → Digest) (message : Digest) (attempts start : Nat) + (counter : Counter) + (hlower : start ≤ counter.toNat) (hupper : counter.toNat < start + attempts) + (hvalid : evalWithAnswerFn f (encode parameter lay tree leaf message counter) ≠ none) : + evalWithAnswerFn f (otsSignFrom parameter lay tree leaf secret message attempts start) ≠ none := by + induction attempts generalizing start with + | zero => omega + | succ attempts ih => + rw [otsSignFrom, evalWithAnswerFn_bind] + cases hencode : evalWithAnswerFn f + (encode parameter lay tree leaf message (BitVec.ofNat counterBits start)) with + | some codeword => + simp only [evalWithAnswerFn_bind, evalWithAnswerFn_pure, ne_eq, reduceCtorEq, not_false_eq_true] + | none => + have hne : start ≠ counter.toNat := by + intro heq + apply hvalid + simpa only [heq, BitVec.ofNat_toNat, BitVec.setWidth_eq] using hencode + exact ih (start + 1) (by omega) (by omega) + +theorem otsSign_ne_none_of_valid_counter (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) + (secret : ChainIndex → Digest) (message : Digest) (counter : Counter) + (hvalid : evalWithAnswerFn f (encode parameter lay tree leaf message counter) ≠ none) : + evalWithAnswerFn f (otsSign parameter lay tree leaf secret message) ≠ none := by + apply otsSignFrom_ne_none_of_valid_counter f parameter lay tree leaf secret message + encodingAttemptLimit 0 counter (Nat.zero_le _) _ hvalid + exact counter.isLt + +theorem signLayer_ne_none_of_valid_counter (f : QueryImpl HashSpec Id) + (secretKey : SecretKey) (index : Index) (lay : Layer) (counter : Counter) + (hvalid : evalWithAnswerFn f + (encode secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f (layerMessage secretKey index lay)) counter) ≠ none) : + evalWithAnswerFn f (signLayer secretKey index lay) ≠ none := by + have hots := otsSign_ne_none_of_valid_counter f secretKey.parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay)) counter hvalid + unfold signLayer + simp only [evalWithAnswerFn_bind] + cases hresult : evalWithAnswerFn f + (otsSign secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay))) with + | none => exact (hots hresult).elim + | some values => simp only [evalWithAnswerFn_bind, evalWithAnswerFn_pure, ne_eq, + reduceCtorEq, not_false_eq_true] + +theorem signAfterDigest_ne_none_of_valid_counters (f : QueryImpl HashSpec Id) + (secretKey : SecretKey) (randomness : Randomness) (index : Index) + (leaves : DigestTree → FtsLeaf) (counters : Layer → Counter) + (hvalid : ∀ lay, evalWithAnswerFn f + (encode secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f (layerMessage secretKey index lay)) (counters lay)) ≠ none) : + evalWithAnswerFn f (signAfterDigest secretKey randomness index leaves) ≠ none := by + classical + have hlayers : ∀ lay, ∃ parts, evalWithAnswerFn f (signLayer secretKey index lay) = some parts := by + intro lay + exact Option.ne_none_iff_exists'.mp + (signLayer_ne_none_of_valid_counter f secretKey index lay (counters lay) (hvalid lay)) + choose parts hparts using hlayers + have heq : (fun lay => evalWithAnswerFn f (signLayer secretKey index lay)) = + (fun lay => some (parts lay)) := funext hparts + simp only [signAfterDigest, evalWithAnswerFn_bind, evalWithAnswerFn_sequenceFin, heq, + traverseOption_some, evalWithAnswerFn_pure, ne_eq, reduceCtorEq, not_false_eq_true] + +theorem FullyHonestOpening.signAfterDigest_ne_none + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {index : Index} {leaves : DigestTree → FtsLeaf} {signature : Signature} + (hfull : FullyHonestOpening f cache secretKey index leaves signature) + (randomness : Randomness) : + evalWithAnswerFn f (signAfterDigest secretKey randomness index leaves) ≠ none := by + apply signAfterDigest_ne_none_of_valid_counters f secretKey randomness index leaves signature.counter + intro lay + obtain ⟨codeword, hencode, _⟩ := (hfull.1 lay).1 + rw [hencode] + simp + +theorem signWithView_fresh_admissible_transition_finish + (f : QueryImpl HashSpec Id) (secretKey : SecretKey) (message : Message) + (initialCache finalCache : QueryCache HashSpec) + (signature : Option Signature) (view : Option FewTimeView) + (hmem : ((signature, view), finalCache) ∈ support + ((simulateQ romImpl (signWithView secretKey message)).run initialCache)) + (hf : finalCache.AgreesWithFn f) + (targetPayload : HashInput) (output : HashOutput) (index : Index) + (leaves : DigestTree → FtsLeaf) + (hbefore : initialCache + (tweakableHashInput secretKey.parameter .message targetPayload) = none) + (hafter : finalCache + (tweakableHashInput secretKey.parameter .message targetPayload) = some output) + (houtput : signAttemptResultOfOutput output = some (index, leaves)) : + ∃ randomness, targetPayload = messageDigestPayload secretKey.root message randomness ∧ + evalWithAnswerFn f (signAfterDigest secretKey randomness index leaves) = signature := by + rw [signWithView, simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hmem + obtain ⟨⟨loopResult, loopCache⟩, hloop, hfinish⟩ := hmem + have hloopLe : loopCache ≤ finalCache := by + cases loopResult with + | none => + have heq : ((signature, view), finalCache) = ((none, none), loopCache) := by + simpa only [simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hfinish + rw [show loopCache = finalCache from (congrArg Prod.snd heq).symm] + | some selected => + rcases selected with ⟨randomness, selectedIndex, selectedLeaves⟩ + exact simulateQ_romImpl_cache_le + (do + let signature ← liftM + (signAfterDigest secretKey randomness selectedIndex selectedLeaves) + pure (signature, some (selectedFewTimeView selectedIndex selectedLeaves))) + loopCache ((signature, view), finalCache) hfinish + have hloopHit : loopCache + (tweakableHashInput secretKey.parameter .message targetPayload) ≠ none := by + intro hnone + cases hloopResult : loopResult with + | none => + have heq : ((signature, view), finalCache) = ((none, none), loopCache) := by + simpa only [hloopResult, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hfinish + have hcache : finalCache = loopCache := congrArg Prod.snd heq + rw [hcache, hnone] at hafter + simp at hafter + | some selected => + rcases selected with ⟨randomness, selectedIndex, selectedLeaves⟩ + rw [hloopResult, simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hfinish + obtain ⟨⟨signatureResult, signatureCache⟩, hsignature, hpure⟩ := hfinish + have hpureEq : ((signature, view), finalCache) = + ((signatureResult, some (selectedFewTimeView selectedIndex selectedLeaves)), + signatureCache) := by + simpa only [simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hpure + have hsignature' : (signatureResult, signatureCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest secretKey randomness selectedIndex selectedLeaves)).run + loopCache) := by + simpa only [simulateQ_romImpl_liftM] using hsignature + have hnone' := signAfterDigest_cache_message_none secretKey randomness + selectedIndex selectedLeaves loopCache signatureCache signatureResult hsignature' + targetPayload hnone + have hcache : finalCache = signatureCache := congrArg Prod.snd hpureEq + rw [hcache, hnone'] at hafter + simp at hafter + obtain ⟨loopOutput, hloopOutput⟩ := Option.ne_none_iff_exists'.mp hloopHit + have hloopOutputEq : loopOutput = output := by + have := hloopLe hloopOutput + rw [hafter] at this + exact Option.some.inj this.symm + have hloopOutput' : loopCache + (tweakableHashInput secretKey.parameter .message targetPayload) = some output := by + rw [← hloopOutputEq] + exact hloopOutput + obtain ⟨_, randomness, _, hpayload, hloopResult⟩ := + signDigestLoop_successful_source_is_selected digestAttemptLimit secretKey message + initialCache loopCache loopResult hloop targetPayload output index leaves + hbefore hloopOutput' houtput + rw [hloopResult, simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hfinish + obtain ⟨⟨signatureResult, signatureCache⟩, hsignature, hpure⟩ := hfinish + have hpureEq : ((signature, view), finalCache) = + ((signatureResult, some (selectedFewTimeView index leaves)), signatureCache) := by + simpa only [simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hpure + have hsignature' : (signatureResult, signatureCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest secretKey randomness index leaves)).run loopCache) := by + simpa only [simulateQ_romImpl_liftM] using hsignature + have hcacheEq : finalCache = signatureCache := congrArg Prod.snd hpureEq + have hresultEq : signature = signatureResult := congrArg (fun result => result.1.1) hpureEq + have heval := (replay_of_mem_support + (signAfterDigest secretKey randomness index leaves) loopCache signatureResult signatureCache + hsignature' f (by rwa [← hcacheEq])).2.1 + exact ⟨randomness, hpayload, heval.trans hresultEq.symm⟩ + +theorem ProperFewTimeLeak.no_signer_target_of_fullyHonest + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} + {index : Index} {leaves : DigestTree → FtsLeaf} {forged : Signature} + (hproper : ProperFewTimeLeak f cache secretKey signingLog index leaves) + (hfull : FullyHonestOpening f cache secretKey index leaves forged) + (state : ViewedFullTraceState) + (hlog : state.trace.signing.toSigningLog = signingLog) + (hvalidViews : state.ValidViews secretKey) + (hconsistent : state.trace.Consistent) + (hvalidRuns : state.trace.signing.ValidRuns secretKey) + (hcaches : state.trace.signing.CachesLe cache) (hf : cache.AgreesWithFn f) + (position : Fin state.trace.intervals.length) + (request : SignRequest) (signature : Option Signature) + (initialCache finalCache : QueryCache HashSpec) + (hinterval : state.trace.intervals.get position = + ⟨.inr request, signature, initialCache, finalCache⟩) + (targetPayload : HashInput) (output : HashOutput) + (hbefore : initialCache + (tweakableHashInput secretKey.parameter .message targetPayload) = none) + (hafter : finalCache + (tweakableHashInput secretKey.parameter .message targetPayload) = some output) + (houtput : signAttemptResultOfOutput output = some (index, leaves)) : False := by + have hnone := hproper.signer_target_signature_eq_none state hlog hvalidViews hconsistent + hvalidRuns hcaches hf position request signature initialCache finalCache hinterval + targetPayload output hbefore hafter houtput + obtain ⟨signingPosition, viewPosition, _, _, hentry, hviewRun⟩ := + ViewedFullTraceState.ValidViews.signer_interval hvalidViews hconsistent position + request signature initialCache finalCache hinterval + have hmem : state.trace.signing.get signingPosition ∈ state.trace.signing := + List.get_mem state.trace.signing signingPosition + have hfinalLe : finalCache ≤ cache := by + have h := (hcaches _ hmem).2 + simpa only [hentry] using h + obtain ⟨randomness, _, heval⟩ := signWithView_fresh_admissible_transition_finish f secretKey + request initialCache finalCache signature (state.views.get viewPosition) hviewRun + (fun _ _ hcached => hf (hfinalLe hcached)) targetPayload output index leaves hbefore hafter houtput + exact hfull.signAfterDigest_ne_none randomness (heval.trans hnone) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeSignerView.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeSignerView.lean new file mode 100644 index 00000000..1a08c217 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeSignerView.lean @@ -0,0 +1,201 @@ +import SphincsSecurity.Proof.FewTimeLoop + +/-! +# Signer digest views + +This proof-only signer exposes the few-time view selected by the digest loop alongside the ordinary +signature result. Forgetting the extra component recovers the concrete signer exactly. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +def selectedFewTimeView (index : Index) (leaves : DigestTree → FtsLeaf) : FewTimeView := + (index, fun tree => leaves (ftsIndexOf tree)) + +noncomputable def signWithView (secretKey : SecretKey) (message : Message) : + OracleComp OracleWorld (Option Signature × Option FewTimeView) := do + match ← signDigestLoop digestAttemptLimit secretKey message with + | none => pure (none, none) + | some (randomness, index, leaves) => do + let signature ← liftM (signAfterDigest secretKey randomness index leaves) + pure (signature, some (selectedFewTimeView index leaves)) + +theorem signWithView_fst (secretKey : SecretKey) (message : Message) : + Prod.fst <$> signWithView secretKey message = sign secretKey message := by + rw [sign_eq_digestLoop_afterDigest] + simp only [signWithView, map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro loopResult + cases loopResult with + | none => simp + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + simp + +theorem simulateQ_signWithView_fst_run (secretKey : SecretKey) (message : Message) + (cache : QueryCache HashSpec) : + (fun result => (result.1.1, result.2)) <$> + (simulateQ romImpl (signWithView secretKey message)).run cache = + (simulateQ romImpl (sign secretKey message)).run cache := by + calc + _ = (simulateQ romImpl (Prod.fst <$> signWithView secretKey message)).run cache := by + rw [simulateQ_map, StateT.run_map] + _ = _ := by rw [signWithView_fst] + +def verifyWithView (publicKey : PublicKey) (message : Message) (signature : Signature) : + OracleComp HashSpec (Bool × FewTimeView) := do + let output ← oracleHash (tweakableHashInput publicKey.parameter .message + (messageDigestPayload publicKey.root message signature.randomness)) + let digest := truncateMessageDigest output + let view := hashOutputFewTimeView output + if ¬ Admissible digest then + pure (false, view) + else + let ftsPublicKey ← ftsRecover publicKey.parameter (digestIndex digest) + (digestLeaves digest) signature.ftsSecret signature.ftsPath + match ← verifyLayers publicKey.parameter (digestIndex digest) signature numLayers + ftsPublicKey with + | none => pure (false, view) + | some root => pure (decide (root = publicKey.root), view) + +set_option maxHeartbeats 1000000 in +theorem verifyWithView_fst (publicKey : PublicKey) (message : Message) + (signature : Signature) : + Prod.fst <$> verifyWithView publicKey message signature = + verify publicKey message signature := by + rw [verify_eq] + simp only [verifyWithView, messageDigest, map_eq_bind_pure_comp, bind_assoc, pure_bind] + apply bind_congr + intro output + let digest := truncateMessageDigest output + by_cases hadmissible : Admissible digest + · change Admissible (truncateMessageDigest output) at hadmissible + simp only [hadmissible, not_true_eq_false, ↓reduceIte] + simp only [bind_assoc] + apply bind_congr + intro ftsPublicKey + apply bind_congr + intro root + cases root <;> simp + · change ¬ Admissible (truncateMessageDigest output) at hadmissible + simp [hadmissible] + +theorem simulateQ_verifyWithView_fst_run (publicKey : PublicKey) (message : Message) + (signature : Signature) (cache : QueryCache HashSpec) : + (fun result => (result.1.1, result.2)) <$> + (simulateQ romImpl + (liftM (verifyWithView publicKey message signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run cache = + (simulateQ romImpl + (Concrete.scheme.verify publicKey message signature)).run cache := by + rw [show Concrete.scheme.verify publicKey message signature = + (liftM (verify publicKey message signature) : OracleComp OracleWorld Bool) from rfl] + simp only [simulateQ_romImpl_liftM] + calc + _ = (simulateQ (randomOracle : QueryImpl HashSpec _) + (Prod.fst <$> verifyWithView publicKey message signature)).run cache := by + rw [simulateQ_map, StateT.run_map] + _ = _ := by rw [verifyWithView_fst] + +theorem verifyWithView_support_view (publicKey : PublicKey) (message : Message) + (signature : Signature) (initialCache finalCache : QueryCache HashSpec) + (verified : Bool) (view : FewTimeView) + (hmem : ((verified, view), finalCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (verifyWithView publicKey message signature)).run initialCache)) : + ∃ (output : HashOutput) (digestCache : QueryCache HashSpec), + (output, digestCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (oracleHash (tweakableHashInput publicKey.parameter .message + (messageDigestPayload publicKey.root message signature.randomness)))).run initialCache) + ∧ digestCache ≤ finalCache + ∧ view = hashOutputFewTimeView output := by + rw [verifyWithView, simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hmem + obtain ⟨⟨output, digestCache⟩, houtput, hrest⟩ := hmem + let rest : OracleComp HashSpec (Bool × FewTimeView) := + let digest := truncateMessageDigest output + let view := hashOutputFewTimeView output + if ¬ Admissible digest then + pure (false, view) + else do + let ftsPublicKey ← ftsRecover publicKey.parameter (digestIndex digest) + (digestLeaves digest) signature.ftsSecret signature.ftsPath + match ← verifyLayers publicKey.parameter (digestIndex digest) signature numLayers + ftsPublicKey with + | none => pure (false, view) + | some root => pure (decide (root = publicKey.root), view) + change ((verified, view), finalCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) rest).run digestCache) at hrest + have hrest' : ((verified, view), finalCache) ∈ support + ((simulateQ romImpl (liftM rest : OracleComp OracleWorld _)).run digestCache) := by + simpa only [simulateQ_romImpl_liftM] using hrest + have hcacheLe : digestCache ≤ finalCache := + simulateQ_romImpl_cache_le (liftM rest : OracleComp OracleWorld _) + digestCache ((verified, view), finalCache) hrest' + refine ⟨output, digestCache, ?_, hcacheLe, ?_⟩ + · exact houtput + · by_cases hadmissible : Admissible (truncateMessageDigest output) + · simp only [rest, hadmissible, not_true_eq_false, ↓reduceIte, simulateQ_bind, + StateT.run_bind, mem_support_bind_iff] at hrest + obtain ⟨⟨ftsPublicKey, ftsCache⟩, _, hrest⟩ := hrest + obtain ⟨⟨root, rootCache⟩, _, hresult⟩ := hrest + cases root with + | none => + have heq : ((verified, view), finalCache) = + ((false, hashOutputFewTimeView output), rootCache) := by + simpa only [simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hresult + exact congrArg (fun result => result.1.2) heq + | some root => + have heq : ((verified, view), finalCache) = + ((decide (root = publicKey.root), hashOutputFewTimeView output), rootCache) := by + simpa only [simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hresult + exact congrArg (fun result => result.1.2) heq + · simp only [rest, hadmissible, not_false_eq_true, ↓reduceIte, + simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff] at hrest + exact congrArg (fun result => result.1.2) hrest + +set_option linter.constructorNameAsVariable false in +theorem signWithView_support_some + (secretKey : SecretKey) (message : Message) + (initialCache finalCache : QueryCache HashSpec) + (signature : Signature) (view : Option FewTimeView) + (hmem : ((some signature, view), finalCache) ∈ support + ((simulateQ romImpl (signWithView secretKey message)).run initialCache)) : + ∃ (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (loopCache : QueryCache HashSpec), + (some (randomness, index, leaves), loopCache) ∈ support + ((simulateQ romImpl + (signDigestLoop digestAttemptLimit secretKey message)).run initialCache) + ∧ (some signature, finalCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec + (StateT (QueryCache HashSpec) ProbComp)) + (signAfterDigest secretKey randomness index leaves)).run loopCache) + ∧ view = some (selectedFewTimeView index leaves) := by + rw [signWithView, simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hmem + obtain ⟨⟨loopResult, loopCache⟩, hloop, hfinish⟩ := hmem + cases loopResult with + | none => + simp only [simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq, reduceCtorEq, false_and] at hfinish + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + rw [simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hfinish + obtain ⟨⟨signatureResult, signatureCache⟩, hsignature, hpure⟩ := hfinish + have hpureEq : ((some signature, view), finalCache) = + ((signatureResult, some (selectedFewTimeView index leaves)), signatureCache) := by + simpa only [simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hpure + have hresult : some signature = signatureResult := + congrArg (fun result => result.1.1) hpureEq + have hview : view = some (selectedFewTimeView index leaves) := + congrArg (fun result => result.1.2) hpureEq + have hcache : finalCache = signatureCache := congrArg Prod.snd hpureEq + rw [← hresult, ← hcache] at hsignature + refine ⟨randomness, index, leaves, loopCache, hloop, ?_, hview⟩ + simpa only [simulateQ_romImpl_liftM] using hsignature + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeSource.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeSource.lean new file mode 100644 index 00000000..363ffae8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeSource.lean @@ -0,0 +1,674 @@ +import SphincsSecurity.Proof.FullTrace +import SphincsSecurity.Proof.FewTimeTrace +import SphincsSecurity.Proof.FewTimeLoop +import SphincsSecurity.Proof.SignerDigestSource +import SphincsSecurity.Proof.FewTimeProbability +import Batteries.Data.Fin.Coding + +/-! +# Sources of previously cached selected digests + +If a selected signer digest was already cached when that signer began, the full adversary trace +locates the earlier interval that first inserted it. Key generation is not a possible source. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +theorem traverseOption_some {alpha : Type} {count : Nat} + (values : Fin count → alpha) : + traverseOption (fun position => some (values position)) = some values := by + induction count with + | zero => + rw [traverseOption] + congr + funext position + exact Fin.elim0 position + | succ count ih => + rw [traverseOption, ih] + change some (Fin.cases (values 0) (fun position => values position.succ)) = some values + rw [Option.some.injEq] + funext position + cases position using Fin.cases <;> rfl + +theorem SuccessfulSignRun.eval_signAfterDigest {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} (hrun : SuccessfulSignRun f cache secretKey message signature) : + ∃ (index : Index) (leaves : DigestTree → FtsLeaf), + SuccessfulDigestRun f cache secretKey message signature.randomness index leaves + ∧ evalWithAnswerFn f + (signAfterDigest secretKey signature.randomness index leaves) = some signature := by + obtain ⟨index, leaves, parts, hdigest, hftsSecret, hftsPath, hcounter, hchainValue, + hauthPath, _, hlayers, _⟩ := hrun + refine ⟨index, leaves, hdigest, ?_⟩ + have hlayers' : + (fun lay => evalWithAnswerFn f (signLayer secretKey index lay)) = + (fun lay => some (parts lay)) := by + funext lay + exact hlayers lay + simp only [signAfterDigest, evalWithAnswerFn_bind, evalWithAnswerFn_sequenceFin, + hlayers', traverseOption_some, evalWithAnswerFn_pure, Option.some.injEq] + cases signature + simp_all + +theorem SuccessfulSignRun.cached_digest_source {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} (hrun : SuccessfulSignRun f cache secretKey message signature) + (hf : cache.AgreesWithFn f) {output : HashOutput} + (hcached : cache (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message signature.randomness)) = some output) : + ∃ (index : Index) (leaves : DigestTree → FtsLeaf), + signAttemptResultOfOutput output = some (index, leaves) + ∧ evalWithAnswerFn f + (signAfterDigest secretKey signature.randomness index leaves) = some signature := by + obtain ⟨index, leaves, hdigest, hafter⟩ := hrun.eval_signAfterDigest + obtain ⟨_, digest, heval, hadmissible, hindex, hleaves, _⟩ := hdigest.extract + have hfinput : f (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message signature.randomness)) = output := + hf hcached + have hdigest : digest = truncateMessageDigest output := by + rw [← heval] + simp only [messageDigest, oracleHash, evalWithAnswerFn_bind, evalWithAnswerFn_query, + hfinput, evalWithAnswerFn_pure] + refine ⟨index, leaves, ?_, hafter⟩ + simp only [signAttemptResultOfOutput, ← hdigest, if_pos hadmissible] + rw [hindex, hleaves] + +theorem FewTimeCover.precached_entry_has_earlier_source + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (index : Index) (targetLeaves : DigestTree → FtsLeaf) + (cover : FewTimeCover f result.2.1 + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.signing.toSigningLog index targetLeaves) + (entry : cover.entries) + (hprecached : cover.EntryDigestPrecached result.2.2.signing rfl entry) : + ∃ (source selected : Fin result.2.2.intervals.length), + source.val < selected.val + ∧ AdversaryCacheEntry.signingEntry? (result.2.2.intervals.get selected) = + some (cover.cacheEntry result.2.2.signing rfl entry) + ∧ (result.2.2.intervals.get source).initialCache + (cover.entryDigestInput entry) = none + ∧ (result.2.2.intervals.get source).finalCache + (cover.entryDigestInput entry) ≠ none + ∧ ((result.2.2.intervals.get source).input = + .inl (.inr (cover.entryDigestInput entry)) + ∨ ∃ request, (result.2.2.intervals.get source).input = .inr request) := by + have hintervals := gameAfterSecretsWithFullTrace_support_interval_invariants + adversary parameter otsSecret ftsSecret result hresult + have hvalid := gameAfterSecretsWithFullTrace_support_validIntervals + adversary parameter otsSecret ftsSecret result hresult + obtain ⟨rootCache, adversaryCache, hrootNone, _, hchain, _⟩ := + gameAfterSecretsWithFullTrace_support_cacheChain + adversary parameter otsSecret ftsSecret result hresult + have hstart : rootCache (cover.entryDigestInput entry) = none := by + simpa only [FewTimeCover.entryDigestInput] using hrootNone + (messageDigestPayload result.1.1 + (cover.select (cover.representativeTree entry)).entry.1 + (cover.select (cover.representativeTree entry)).signature.randomness) + obtain ⟨source, selected, hlt, hselected, hmiss, hhit⟩ := + hchain.source_before_signingEntry hintervals.1 + (cover.cacheEntry result.2.2.signing rfl entry) + (cover.cacheEntry_mem result.2.2.signing rfl entry) + (cover.entryDigestInput entry) hstart hprecached + have hkind := FullAdversaryTrace.transition_source_kind hvalid + (result.2.2.intervals.get source) (List.get_mem _ source) + (cover.entryDigestInput entry) hmiss hhit + exact ⟨source, selected, hlt, hselected, hmiss, hhit, hkind⟩ + +theorem FewTimeCover.precached_entry_has_earlier_exact_source + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (index : Index) (targetLeaves : DigestTree → FtsLeaf) + (cover : FewTimeCover f result.2.1 + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.signing.toSigningLog index targetLeaves) + (entry : cover.entries) + (hprecached : cover.EntryDigestPrecached result.2.2.signing rfl entry) : + ∃ (source selected : Fin result.2.2.intervals.length), + source.val < selected.val + ∧ AdversaryCacheEntry.signingEntry? (result.2.2.intervals.get selected) = + some (cover.cacheEntry result.2.2.signing rfl entry) + ∧ ((result.2.2.intervals.take selected.val).filterMap + AdversaryCacheEntry.signingEntry?).length = (cover.logIndex entry).val + ∧ (result.2.2.intervals.get source).initialCache + (cover.entryDigestInput entry) = none + ∧ (result.2.2.intervals.get source).finalCache + (cover.entryDigestInput entry) ≠ none + ∧ ((result.2.2.intervals.get source).input = + .inl (.inr (cover.entryDigestInput entry)) + ∨ ∃ earlier : Fin result.2.2.signing.length, + earlier.val < (cover.logIndex entry).val + ∧ AdversaryCacheEntry.signingEntry? (result.2.2.intervals.get source) = + some (result.2.2.signing.get earlier)) := by + have hintervals := gameAfterSecretsWithFullTrace_support_interval_invariants + adversary parameter otsSecret ftsSecret result hresult + have hvalid := gameAfterSecretsWithFullTrace_support_validIntervals + adversary parameter otsSecret ftsSecret result hresult + obtain ⟨rootCache, adversaryCache, hrootNone, _, hchain, _⟩ := + gameAfterSecretsWithFullTrace_support_cacheChain + adversary parameter otsSecret ftsSecret result hresult + let selectedSigning : Fin result.2.2.signing.length := + ⟨(cover.logIndex entry).val, by + simpa only [SigningCacheTrace.toSigningLog, List.length_map] using + (cover.logIndex entry).isLt⟩ + have hselectedSigning : result.2.2.signing.get selectedSigning = + cover.cacheEntry result.2.2.signing rfl entry := by + rfl + obtain ⟨selected, hselected, hselectedRank, hearlier⟩ := + result.2.2.signingIndex_interval hintervals.1 selectedSigning + have hselected' : AdversaryCacheEntry.signingEntry? + (result.2.2.intervals.get selected) = + some (cover.cacheEntry result.2.2.signing rfl entry) := by + simpa only [hselectedSigning] using hselected + have hstart : rootCache (cover.entryDigestInput entry) = none := by + simpa only [FewTimeCover.entryDigestInput] using hrootNone + (messageDigestPayload result.1.1 + (cover.select (cover.representativeTree entry)).entry.1 + (cover.select (cover.representativeTree entry)).signature.randomness) + have hselectedCache : (result.2.2.intervals.get selected).initialCache + (cover.entryDigestInput entry) ≠ none := by + rw [(result.2.2.intervals.get selected).initialCache_eq_of_signingEntry?_eq_some + hselected'] + exact hprecached + obtain ⟨source, hlt, hmiss, hhit⟩ := + hchain.transition_before (cover.entryDigestInput entry) selected hstart hselectedCache + have hkind := FullAdversaryTrace.transition_source_kind hvalid + (result.2.2.intervals.get source) (List.get_mem _ source) + (cover.entryDigestInput entry) hmiss hhit + refine ⟨source, selected, hlt, hselected', hselectedRank, hmiss, hhit, ?_⟩ + rcases hkind with hdirect | ⟨request, hrequest⟩ + · exact Or.inl hdirect + · right + have hsourceEntry : ∃ sourceEntry : SigningCacheEntry, + AdversaryCacheEntry.signingEntry? (result.2.2.intervals.get source) = + some sourceEntry := by + generalize hsourceInterval : result.2.2.intervals.get source = sourceInterval + rcases sourceInterval with ⟨input, output, initialCache, finalCache⟩ + rw [hsourceInterval] at hrequest + cases input with + | inl worldInput => simp at hrequest + | inr actualRequest => + have hrequest' : actualRequest = request := Sum.inr.inj hrequest + subst request + exact ⟨⟨actualRequest, output, initialCache, finalCache⟩, rfl⟩ + obtain ⟨sourceEntry, hsourceEntry⟩ := hsourceEntry + obtain ⟨earlier, hearlierLt, hearlierEntry⟩ := + hearlier source hlt sourceEntry hsourceEntry + exact ⟨earlier, by simpa only [selectedSigning] using hearlierLt, + hsourceEntry.trans (congrArg some hearlierEntry.symm)⟩ + +theorem FewTimeCover.precached_entry_has_earlier_direct_source + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.1.AgreesWithFn f) + (index : Index) (targetLeaves : DigestTree → FtsLeaf) + (cover : FewTimeCover f result.2.1 + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.signing.toSigningLog index targetLeaves) + (entry : cover.entries) + (hprecached : cover.EntryDigestPrecached result.2.2.signing rfl entry) : + ∃ (source selected : Fin result.2.2.intervals.length), + source.val < selected.val + ∧ AdversaryCacheEntry.signingEntry? (result.2.2.intervals.get selected) = + some (cover.cacheEntry result.2.2.signing rfl entry) + ∧ ((result.2.2.intervals.take selected.val).filterMap + AdversaryCacheEntry.signingEntry?).length = (cover.logIndex entry).val + ∧ (result.2.2.intervals.get source).input = + .inl (.inr (cover.entryDigestInput entry)) + ∧ (result.2.2.intervals.get source).initialCache + (cover.entryDigestInput entry) = none := by + obtain ⟨source, selected, hlt, hselected, hselectedRank, hsourceMiss, hsourceHit, + hkind⟩ := + cover.precached_entry_has_earlier_exact_source adversary parameter otsSecret ftsSecret + result hresult f index targetLeaves entry hprecached + rcases hkind with hdirect | ⟨earlier, hearlier, hsourceEntry⟩ + · exact ⟨source, selected, hlt, hselected, hselectedRank, hdirect, hsourceMiss⟩ + · exfalso + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + let earlierEntry := result.2.2.signing.get earlier + let selected := cover.select (cover.representativeTree entry) + let targetPayload := messageDigestPayload result.1.1 selected.entry.1 + selected.signature.randomness + have hinvariants := gameAfterSecretsWithFullTrace_support_invariants adversary parameter + otsSecret ftsSecret result hresult + have hvalid : earlierEntry.ValidRun secretKey := + hinvariants.1 earlierEntry (List.get_mem _ earlier) + have hcaches := hinvariants.2.1 + have hearlierLe : earlierEntry.finalCache ≤ result.2.1 := + (hcaches earlierEntry (List.get_mem _ earlier)).2 + have hbefore : earlierEntry.initialCache + (tweakableHashInput parameter .message targetPayload) = none := by + have hcacheEq := AdversaryCacheEntry.initialCache_eq_of_signingEntry?_eq_some + (interval := result.2.2.intervals.get source) hsourceEntry + rw [← hcacheEq] + simpa only [FewTimeCover.entryDigestInput, selected, targetPayload] using hsourceMiss + have hafter : earlierEntry.finalCache + (tweakableHashInput parameter .message targetPayload) ≠ none := by + have hcacheEq := AdversaryCacheEntry.finalCache_eq_of_signingEntry?_eq_some + (interval := result.2.2.intervals.get source) hsourceEntry + rw [← hcacheEq] + simpa only [FewTimeCover.entryDigestInput, selected, targetPayload] using hsourceHit + obtain ⟨output, houtputEarlier⟩ := Option.ne_none_iff_exists'.mp hafter + have houtputFinal : result.2.1 + (tweakableHashInput parameter .message targetPayload) = some output := + hearlierLe houtputEarlier + have hselectedRun := cover.cacheEntry_successfulSignRun result.2.2.signing rfl + hinvariants.1 hcaches hf entry + obtain ⟨actualIndex, actualLeaves, hattemptOutput, htailEval⟩ := + hselectedRun.cached_digest_source hf (by + simpa only [FewTimeCover.entryDigestInput, selected, targetPayload] using houtputFinal) + change (earlierEntry.signature, earlierEntry.finalCache) ∈ support + ((simulateQ romImpl (sign secretKey earlierEntry.request)).run + earlierEntry.initialCache) at hvalid + rw [sign_eq_digestLoop_afterDigest, simulateQ_bind, StateT.run_bind, + mem_support_bind_iff] at hvalid + obtain ⟨⟨loopResult, loopCache⟩, hloop, hrest⟩ := hvalid + have hloopHit : loopCache + (tweakableHashInput parameter .message targetPayload) ≠ none := by + intro hloopNone + cases loopResult with + | none => + have hpure : (earlierEntry.signature, earlierEntry.finalCache) = + (none, loopCache) := by + simpa using hrest + have hcache : earlierEntry.finalCache = loopCache := congrArg Prod.snd hpure + rw [hcache, hloopNone] at hafter + exact hafter rfl + | some data => + rcases data with ⟨randomness, sourceIndex, sourceLeaves⟩ + have hrest' : (earlierEntry.signature, earlierEntry.finalCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest secretKey randomness sourceIndex sourceLeaves)).run loopCache) := by + simpa only [simulateQ_romImpl_liftM] using hrest + have hnone := signAfterDigest_cache_message_none secretKey randomness sourceIndex + sourceLeaves loopCache earlierEntry.finalCache earlierEntry.signature hrest' + targetPayload hloopNone + exact hafter hnone + obtain ⟨loopOutput, hloopOutput⟩ := Option.ne_none_iff_exists'.mp hloopHit + have hloopLe : loopCache ≤ earlierEntry.finalCache := by + cases loopResult with + | none => + have hpure : (earlierEntry.signature, earlierEntry.finalCache) = + (none, loopCache) := by + simpa using hrest + have hcache : earlierEntry.finalCache = loopCache := congrArg Prod.snd hpure + rw [hcache] + | some data => + rcases data with ⟨randomness, sourceIndex, sourceLeaves⟩ + exact simulateQ_romImpl_cache_le + (liftM (signAfterDigest secretKey randomness sourceIndex sourceLeaves) : + OracleComp OracleWorld (Option Signature)) loopCache + (earlierEntry.signature, earlierEntry.finalCache) hrest + have hloopOutputEq : loopOutput = output := by + have := hloopLe hloopOutput + rw [houtputEarlier] at this + exact Option.some.inj this.symm + have hattemptOutput' : signAttemptResultOfOutput loopOutput = + some (actualIndex, actualLeaves) := by + rw [hloopOutputEq] + exact hattemptOutput + obtain ⟨_, sourceRandomness, _, hpayload, hloopResult⟩ := + signDigestLoop_successful_source_is_selected digestAttemptLimit secretKey + earlierEntry.request earlierEntry.initialCache loopCache loopResult hloop targetPayload + loopOutput actualIndex actualLeaves hbefore hloopOutput hattemptOutput' + have hpayloadFields := messageDigestPayload_injective result.1.1 hpayload.symm + have hmessage : earlierEntry.request = selected.entry.1 := hpayloadFields.1 + have hrandomness : sourceRandomness = selected.signature.randomness := hpayloadFields.2 + have hrest' : (earlierEntry.signature, earlierEntry.finalCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest secretKey sourceRandomness actualIndex actualLeaves)).run loopCache) := by + rw [hloopResult] at hrest + simpa only [simulateQ_romImpl_liftM] using hrest + have hearlierEval := (replay_of_mem_support_of_le + (signAfterDigest secretKey sourceRandomness actualIndex actualLeaves) loopCache + earlierEntry.signature earlierEntry.finalCache result.2.1 hrest' hearlierLe f hf).1 + have hresponse : earlierEntry.signature = some selected.signature := by + rw [hrandomness] at hearlierEval + exact hearlierEval.symm.trans htailEval + have hne := cover.earlier_successful_digest_input_ne result.2.2.signing rfl + hinvariants.1 hcaches hf entry earlier hearlier selected.signature hresponse + apply hne + rw [hmessage] + rfl + +theorem AdversaryCacheEntry.direct_hash_run + (secretKey : SecretKey) (entry : AdversaryCacheEntry) (target : HashInput) + (hinput : entry.input = .inl (.inr target)) + (hvalid : (entry.output, entry.finalCache) ∈ support + ((unloggedMappedAdversaryImpl secretKey entry.input).run entry.initialCache)) : + ∃ output : HashOutput, + (output, entry.finalCache) ∈ support ((randomOracle target).run entry.initialCache) := by + rcases entry with ⟨input, output, initialCache, finalCache⟩ + cases input with + | inr request => simp at hinput + | inl worldInput => + cases worldInput with + | inl uniformInput => simp at hinput + | inr hashInput => + simp only [Sum.inl.injEq, Sum.inr.injEq] at hinput + subst hashInput + change (output, finalCache) ∈ support + ((randomOracle target).run initialCache) at hvalid + exact ⟨output, hvalid⟩ + +theorem randomOracle_run_output_cached (input : HashInput) + (initialCache finalCache : QueryCache HashSpec) (output : HashOutput) + (hmem : (output, finalCache) ∈ support ((randomOracle input).run initialCache)) : + finalCache input = some output := by + cases hcache : initialCache input with + | none => + rw [OracleSpec.randomOracle, + QueryImpl.withCaching_run_none uniformSampleImpl hcache, support_map] at hmem + obtain ⟨sampledOutput, _, heq⟩ := hmem + obtain ⟨rfl, rfl⟩ := heq + exact QueryCache.cacheQuery_self initialCache input output + | some cachedOutput => + rw [OracleSpec.randomOracle, + QueryImpl.withCaching_run_some uniformSampleImpl hcache, + support_pure, Set.mem_singleton_iff] at hmem + obtain ⟨rfl, rfl⟩ := hmem + exact hcache + +abbrev FewTimeCover.PrecachedEntries {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) := + {entry : cover.entries // cover.EntryDigestPrecached trace hlog entry} + +noncomputable def FewTimeCover.precachedEntryFinset {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) : + Finset cover.entries := by + classical + exact Finset.univ.filter fun entry => cover.EntryDigestPrecached trace hlog entry + +theorem adversaryIntervals_directHashCount + (intervals : List AdversaryCacheEntry) : + Fin.countP (fun position => + isDirectHashQuery (intervals.get position).input) = + (directHashQueries (intervals.map AdversaryCacheEntry.queryEntry)).length := by + induction intervals with + | nil => simp [directHashQueries] + | cons entry rest ih => + rw [Fin.countP_succ] + have htail : Fin.countP (fun position : Fin rest.length => + isDirectHashQuery ((entry :: rest).get position.succ).input) = + Fin.countP (fun position => isDirectHashQuery (rest.get position).input) := by + rfl + rw [htail, ih] + cases hinput : entry.input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + simp [isDirectHashQuery, directHashQueries, AdversaryCacheEntry.queryEntry, + hinput] + | inr hashInput => + rcases entry with ⟨entryInput, entryOutput, initialCache, finalCache⟩ + simp only at hinput + subst entryInput + simp [isDirectHashQuery, directHashQueries, AdversaryCacheEntry.queryEntry, + Nat.add_comm] + | inr request => + simp [isDirectHashQuery, directHashQueries, AdversaryCacheEntry.queryEntry, hinput] + +theorem FewTimeCover.precached_entry_has_fresh_direct_view_source + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.1.AgreesWithFn f) + (index : Index) (targetLeaves : DigestTree → FtsLeaf) + (cover : FewTimeCover f result.2.1 + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.signing.toSigningLog index targetLeaves) + (entry : cover.entries) + (hprecached : cover.EntryDigestPrecached result.2.2.signing rfl entry) : + ∃ (source selected : Fin result.2.2.intervals.length) (output : HashOutput), + source.val < selected.val + ∧ AdversaryCacheEntry.signingEntry? (result.2.2.intervals.get selected) = + some (cover.cacheEntry result.2.2.signing rfl entry) + ∧ ((result.2.2.intervals.take selected.val).filterMap + AdversaryCacheEntry.signingEntry?).length = (cover.logIndex entry).val + ∧ (result.2.2.intervals.get source).input = + .inl (.inr (cover.entryDigestInput entry)) + ∧ (result.2.2.intervals.get source).initialCache + (cover.entryDigestInput entry) = none + ∧ (output, (result.2.2.intervals.get source).finalCache) ∈ support + ((randomOracle (cover.entryDigestInput entry)).run + (result.2.2.intervals.get source).initialCache) + ∧ signAttemptResultOfOutput output ≠ none + ∧ hashOutputFewTimeView output = cover.entryView entry := by + obtain ⟨source, selected, hsourceLt, hselected, hselectedRank, hsourceInput, + hsourceMiss⟩ := + cover.precached_entry_has_earlier_direct_source adversary parameter otsSecret ftsSecret + result hresult f hf index targetLeaves entry hprecached + have hvalid := gameAfterSecretsWithFullTrace_support_validIntervals + adversary parameter otsSecret ftsSecret result hresult + have hintervals := gameAfterSecretsWithFullTrace_support_interval_invariants + adversary parameter otsSecret ftsSecret result hresult + let sourceInterval := result.2.2.intervals.get source + have hsourceRun := hvalid sourceInterval (List.get_mem _ source) + obtain ⟨output, hsourceRun'⟩ := AdversaryCacheEntry.direct_hash_run + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ sourceInterval + (cover.entryDigestInput entry) + (by simpa only [sourceInterval] using hsourceInput) hsourceRun + have hcachedSource : sourceInterval.finalCache (cover.entryDigestInput entry) = some output := + randomOracle_run_output_cached (cover.entryDigestInput entry) + sourceInterval.initialCache sourceInterval.finalCache output hsourceRun' + have hsourceLe : sourceInterval.finalCache ≤ result.2.1 := + (hintervals.2.1 sourceInterval (List.get_mem _ source)).2 + have hfinput : f (cover.entryDigestInput entry) = output := + hf (hsourceLe hcachedSource) + have hdigest : truncateMessageDigest output = cover.entryDigest entry := by + let selected := cover.select (cover.representativeTree entry) + have hentryDigest := (cover.entryDigest_spec entry).1 + have hfinput' : f (tweakableHashInput parameter .message + (messageDigestPayload result.1.1 selected.entry.1 + selected.signature.randomness)) = output := by + simpa only [FewTimeCover.entryDigestInput, selected] using hfinput + have hentryDigest' : truncateMessageDigest + (f (tweakableHashInput parameter .message + (messageDigestPayload result.1.1 selected.entry.1 + selected.signature.randomness))) = cover.entryDigest entry := by + simpa only [messageDigest, oracleHash, evalWithAnswerFn_bind, evalWithAnswerFn_query, + evalWithAnswerFn_pure, selected] using hentryDigest + exact (congrArg truncateMessageDigest hfinput').symm.trans hentryDigest' + have hadmissible : signAttemptResultOfOutput output ≠ none := by + rw [signAttemptResultOfOutput_ne_none_iff, hdigest] + exact (cover.entryDigest_spec entry).2.1 + refine ⟨source, selected, output, hsourceLt, hselected, hselectedRank, hsourceInput, + hsourceMiss, hsourceRun', hadmissible, ?_⟩ + apply Prod.ext + · change digestIndex (truncateMessageDigest output) = digestIndex (cover.entryDigest entry) + rw [hdigest] + · funext tree + change digestLeaves (truncateMessageDigest output) (ftsIndexOf tree) = + digestLeaves (cover.entryDigest entry) (ftsIndexOf tree) + rw [hdigest] + +theorem FewTimeCover.precached_entries_have_injective_fresh_direct_view_sources + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.1.AgreesWithFn f) + (index : Index) (targetLeaves : DigestTree → FtsLeaf) + (cover : FewTimeCover f result.2.1 + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.signing.toSigningLog index targetLeaves) : + ∃ (source : cover.PrecachedEntries result.2.2.signing rfl → + Fin result.2.2.intervals.length) + (selected : cover.PrecachedEntries result.2.2.signing rfl → + Fin result.2.2.intervals.length) + (output : cover.PrecachedEntries result.2.2.signing rfl → HashOutput), + Function.Injective source + ∧ ∀ entry, + (source entry).val < (selected entry).val + ∧ AdversaryCacheEntry.signingEntry? + (result.2.2.intervals.get (selected entry)) = + some (cover.cacheEntry result.2.2.signing rfl entry.1) + ∧ ((result.2.2.intervals.take (selected entry).val).filterMap + AdversaryCacheEntry.signingEntry?).length = (cover.logIndex entry.1).val + ∧ (result.2.2.intervals.get (source entry)).input = + .inl (.inr (cover.entryDigestInput entry.1)) + ∧ (result.2.2.intervals.get (source entry)).initialCache + (cover.entryDigestInput entry.1) = none + ∧ (output entry, (result.2.2.intervals.get (source entry)).finalCache) ∈ support + ((randomOracle (cover.entryDigestInput entry.1)).run + (result.2.2.intervals.get (source entry)).initialCache) + ∧ signAttemptResultOfOutput (output entry) ≠ none + ∧ hashOutputFewTimeView (output entry) = cover.entryView entry.1 := by + classical + choose source selected output hsource using fun entry : + cover.PrecachedEntries result.2.2.signing rfl => + cover.precached_entry_has_fresh_direct_view_source adversary parameter otsSecret ftsSecret + result hresult f hf index targetLeaves entry.1 entry.2 + refine ⟨source, selected, output, ?_, hsource⟩ + intro left right heq + apply Subtype.ext + apply cover.entryDigestInput_injective + have hleft := (hsource left).2.2.2.1 + have hright := (hsource right).2.2.2.1 + rw [heq] at hleft + simpa only [Sum.inl.injEq, Sum.inr.injEq] using hleft.symm.trans hright + +theorem FewTimeCover.precachedEntries_card_le_hashQueries_length + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.1.AgreesWithFn f) + (index : Index) (targetLeaves : DigestTree → FtsLeaf) + (cover : FewTimeCover f result.2.1 + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.signing.toSigningLog index targetLeaves) : + (cover.precachedEntryFinset result.2.2.signing rfl).card ≤ + result.2.2.hashQueries.length := by + classical + obtain ⟨source, _selected, _output, hsourceInjective, hsource⟩ := + cover.precached_entries_have_injective_fresh_direct_view_sources adversary parameter + otsSecret ftsSecret result hresult f hf index targetLeaves + let precached := cover.precachedEntryFinset result.2.2.signing rfl + let asPrecached : ↑precached → cover.PrecachedEntries result.2.2.signing rfl := + fun entry => ⟨entry.1, by + have hmem : entry.1 ∈ cover.precachedEntryFinset result.2.2.signing rfl := by + simpa only [precached] using entry.2 + exact (Finset.mem_filter.mp hmem).2⟩ + let directSource : ↑precached → + {position : Fin result.2.2.intervals.length // + isDirectHashQuery (result.2.2.intervals.get position).input} := + fun entry => ⟨source (asPrecached entry), by + rw [(hsource (asPrecached entry)).2.2.2.1] + trivial⟩ + have hdirectSourceInjective : Function.Injective directSource := by + intro left right heq + have hasPrecached : asPrecached left = asPrecached right := + hsourceInjective (congrArg Subtype.val heq) + apply Subtype.ext + change (asPrecached left).1 = (asPrecached right).1 + exact congrArg Subtype.val hasPrecached + let encodedSource : ↑precached → + Fin (Fin.countP fun position => + isDirectHashQuery (result.2.2.intervals.get position).input) := + fun entry => Fin.encodeSubtype _ (directSource entry) + have hencodedSourceInjective : Function.Injective encodedSource := by + apply Function.Injective.comp + · exact Function.LeftInverse.injective (Fin.decodeSubtype_encodeSubtype _) + · exact hdirectSourceInjective + have hcard := Fintype.card_le_of_injective encodedSource hencodedSourceInjective + have hconsistent := (gameAfterSecretsWithFullTrace_support_interval_invariants adversary + parameter otsSecret ftsSecret result hresult).1 + have hcount : Fin.countP (fun position => + isDirectHashQuery (result.2.2.intervals.get position).input) = + result.2.2.hashQueries.length := by + rw [FullAdversaryTrace.hashQueries, ← hconsistent.1] + exact adversaryIntervals_directHashCount result.2.2.intervals + simpa only [Fintype.card_coe, Fintype.card_fin, hcount, precached] using hcard + +theorem FewTimeCover.precached_entry_has_earlier_sample_source + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (index : Index) (targetLeaves : DigestTree → FtsLeaf) + (cover : FewTimeCover f result.2.1 + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.signing.toSigningLog index targetLeaves) + (entry : cover.entries) + (hprecached : cover.EntryDigestPrecached result.2.2.signing rfl entry) : + (∃ source : Fin result.2.2.intervals.length, + (result.2.2.intervals.get source).input = + .inl (.inr (cover.entryDigestInput entry))) + ∨ ∃ (earlier : Fin result.2.2.signing.length) (attemptIndex : Nat) + (randomness : Randomness), + earlier.val < (cover.logIndex entry).val + ∧ attemptIndex < digestAttemptLimit + ∧ randomness ∈ support sampleRandomness + ∧ cover.entryDigestInput entry = + tweakableHashInput parameter .message + (messageDigestPayload result.1.1 + (result.2.2.signing.get earlier).request randomness) := by + obtain ⟨source, selected, hlt, hselected, _hselectedRank, hmiss, hhit, hkind⟩ := + cover.precached_entry_has_earlier_exact_source adversary parameter otsSecret ftsSecret + result hresult f index targetLeaves entry hprecached + rcases hkind with hdirect | ⟨earlier, hearlier, hsourceEntry⟩ + · exact Or.inl ⟨source, hdirect⟩ + · right + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + let sourceSigningEntry := result.2.2.signing.get earlier + have hinvariants := gameAfterSecretsWithFullTrace_support_invariants + adversary parameter otsSecret ftsSecret result hresult + have hvalid : sourceSigningEntry.ValidRun secretKey := + hinvariants.1 sourceSigningEntry (List.get_mem _ earlier) + let targetPayload := messageDigestPayload result.1.1 + (cover.select (cover.representativeTree entry)).entry.1 + (cover.select (cover.representativeTree entry)).signature.randomness + have htarget : cover.entryDigestInput entry = + tweakableHashInput parameter .message targetPayload := by + rfl + have hbefore : sourceSigningEntry.initialCache + (tweakableHashInput parameter .message targetPayload) = none := by + have hcacheEq := AdversaryCacheEntry.initialCache_eq_of_signingEntry?_eq_some + (interval := result.2.2.intervals.get source) hsourceEntry + rw [← htarget, ← hcacheEq] + exact hmiss + have hafter : sourceSigningEntry.finalCache + (tweakableHashInput parameter .message targetPayload) ≠ none := by + have hcacheEq := AdversaryCacheEntry.finalCache_eq_of_signingEntry?_eq_some + (interval := result.2.2.intervals.get source) hsourceEntry + rw [← htarget, ← hcacheEq] + exact hhit + obtain ⟨attemptIndex, randomness, hattemptIndex, hrandomness, hpayload⟩ := + sign_message_source secretKey sourceSigningEntry.request sourceSigningEntry.initialCache + sourceSigningEntry.finalCache sourceSigningEntry.signature hvalid targetPayload hbefore hafter + exact ⟨earlier, attemptIndex, randomness, hearlier, hattemptIndex, hrandomness, + by rw [htarget, hpayload]⟩ + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeSourceCount.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeSourceCount.lean new file mode 100644 index 00000000..8cf1e615 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeSourceCount.lean @@ -0,0 +1,74 @@ +import SphincsSecurity.Proof.FewTimeSource +import SphincsSecurity.Proof.FewTimePrehit + +/-! +# Query-budget bound for direct few-time sources + +Distinct selected prehits have distinct fresh direct-query inputs. Embedding those inputs into the +final random-oracle cache bounds their number by the complete experiment's hash-query budget. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem FewTimeCover.precachedEntryCount_le_queryBudget + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hresult : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.1.AgreesWithFn f) + (index : Index) (targetLeaves : DigestTree → FtsLeaf) + (cover : FewTimeCover f result.2.1 + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.signing.toSigningLog index targetLeaves) : + ((cover.precachedEntryFinset result.2.2.signing rfl).card : ℝ≥0∞) ≤ q := by + classical + obtain ⟨source, _selected, output, hsourceInjective, hsource⟩ := + cover.precached_entries_have_injective_fresh_direct_view_sources adversary parameter + otsSecret ftsSecret result hresult f hf index targetLeaves + let precached := cover.precachedEntryFinset result.2.2.signing rfl + let asPrecached : ↑precached → cover.PrecachedEntries result.2.2.signing rfl := + fun entry => ⟨entry.1, by + have hmem : entry.1 ∈ cover.precachedEntryFinset result.2.2.signing rfl := by + simpa only [precached] using entry.2 + exact (Finset.mem_filter.mp hmem).2⟩ + have hintervals := gameAfterSecretsWithFullTrace_support_interval_invariants adversary + parameter otsSecret ftsSecret result hresult + let cacheEmbedding : ↑precached ↪ result.2.1.toSet := + ⟨fun entry => + let selected := asPrecached entry + let interval := result.2.2.intervals.get (source selected) + ⟨⟨cover.entryDigestInput selected.1, output selected⟩, by + have hcached : interval.finalCache (cover.entryDigestInput selected.1) = + some (output selected) := + randomOracle_run_output_cached (cover.entryDigestInput selected.1) + interval.initialCache interval.finalCache (output selected) + (hsource selected).2.2.2.2.2.1 + exact (hintervals.2.1 interval (List.get_mem _ (source selected))).2 hcached⟩, + by + intro left right heq + apply Subtype.ext + apply cover.entryDigestInput_injective + have hinput := congrArg + (fun entry : result.2.1.toSet => entry.1.1) heq + change cover.entryDigestInput (asPrecached left).1 = + cover.entryDigestInput (asPrecached right).1 at hinput + exact hinput⟩ + have hencard := cacheEmbedding.encard_le + have hcache : QueryCache.enncard result.2.1 ≤ q := + gameAfterSecretsWithFullTrace_support_enncard_le adversary q hq parameter hparameter + otsSecret hots ftsSecret hfts result hresult + calc + (precached.card : ℝ≥0∞) ≤ QueryCache.enncard result.2.1 := by + simpa only [QueryCache.enncard, Set.encard_coe_eq_coe_finsetCard, + ENat.toENNReal_coe] using ENat.toENNReal_mono hencard + _ ≤ q := hcache + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeTarget125.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeTarget125.lean new file mode 100644 index 00000000..af155435 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeTarget125.lean @@ -0,0 +1,101 @@ +import SphincsSecurity.Proof.FewTimeTargetTerminal + +namespace SphincsSecurity.Concrete.Range125 + +open OracleComp OracleSpec ENNReal + +theorem probEvent_originTargetMonitored_complete_fixedPattern_le_ideal + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (q : Nat) (hq : q ≤ 2 ^ 126) + (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[fun result : α × OriginTargetMonitorState configuration => + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q | + (simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run (OriginTargetMonitorState.initial configuration initialCache)] ≤ + Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] := by + calc + _ ≤ ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ configuration.prehit.card * + Pr[FixedFewTimePatternHit pattern.assignment | + ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : + ProbComp ((pattern.selected → FewTimeView) × FewTimeView))] := + probEvent_originTargetMonitored_complete_le_ideal configuration secretKey + targetOrdinal computation initialCache + (FixedFewTimePatternHit pattern.assignment) q hq hcache + _ = Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] := by + rw [probEvent_originConfiguration_hit_eq_pattern_mul] + ac_rfl + +theorem probEvent_exists_fixedOrdinal_viewedEvent_le_ideal + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (q : Nat) (hq : q ≤ 2 ^ 126) + (hcache : QueryCache.enncard initialCache ≤ q) (candidates : Nat) + (viewedEvent : Fin candidates → α × ViewedFullTraceState → Prop) + (himp : ∀ (candidate : Fin candidates) + (result : α × OriginTargetMonitorState configuration), + result ∈ support + ((simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey candidate.val) + computation).run (OriginTargetMonitorState.initial configuration initialCache)) → + viewedEvent candidate (result.1, result.2.origin.viewed) → + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q) : + Pr[fun result => ∃ candidate : Fin candidates, viewedEvent candidate result | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run + (OriginTargetMonitorState.initial configuration initialCache).origin.viewed] ≤ + candidates * Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] := by + classical + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run + (OriginTargetMonitorState.initial configuration initialCache).origin.viewed + calc + Pr[fun result => ∃ candidate : Fin candidates, viewedEvent candidate result | run] = + Pr[fun result => ∃ candidate ∈ (Finset.univ : Finset (Fin candidates)), + viewedEvent candidate result | run] := by + congr 1 + funext result + simp + _ ≤ ∑ candidate ∈ (Finset.univ : Finset (Fin candidates)), + Pr[viewedEvent candidate | run] := + probEvent_exists_finset_le_sum Finset.univ run viewedEvent + _ ≤ ∑ _candidate ∈ (Finset.univ : Finset (Fin candidates)), + Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] := by + apply Finset.sum_le_sum + intro candidate _ + calc + Pr[viewedEvent candidate | run] ≤ + Pr[fun result : α × OriginTargetMonitorState configuration => + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q | + (simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey candidate.val) + computation).run + (OriginTargetMonitorState.initial configuration initialCache)] := + probEvent_viewed_le_originTargetMonitoredAdversaryImpl configuration secretKey + candidate.val computation (OriginTargetMonitorState.initial configuration initialCache) + (viewedEvent candidate) _ (himp candidate) + _ ≤ _ := probEvent_originTargetMonitored_complete_fixedPattern_le_ideal + configuration secretKey candidate.val computation initialCache q hq hcache + _ = _ := by + rw [Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul] + +end SphincsSecurity.Concrete.Range125 diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetCompletion.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetCompletion.lean new file mode 100644 index 00000000..b9964028 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetCompletion.lean @@ -0,0 +1,286 @@ +import SphincsSecurity.Proof.FewTimeTargetSigner + +/-! +# Completing an optional fresh signer target + +A signer may produce no fresh selected digest. Completing that absent selection with an independent +uniform view keeps the result uniform. This is the optional-candidate form needed by the target +monitor. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +def freshSelectedLoopView? + (referenceCache : QueryCache HashSpec) (secretKey : SecretKey) (message : Message) + (result : Option (Randomness × Index × (DigestTree → FtsLeaf)) × + QueryCache HashSpec) : Option FewTimeView := + match result.1 with + | none => none + | some (randomness, index, leaves) => + if referenceCache (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = none then + some (selectedFewTimeView index leaves) + else none + +noncomputable def completeFreshSelectedLoopView + (referenceCache : QueryCache HashSpec) (secretKey : SecretKey) (message : Message) + (result : Option (Randomness × Index × (DigestTree → FtsLeaf)) × + QueryCache HashSpec) : ProbComp FewTimeView := + match freshSelectedLoopView? referenceCache secretKey message result with + | some view => pure view + | none => $ᵗ FewTimeView + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 1000000 in +set_option linter.constructorNameAsVariable false in +theorem probEvent_completeFreshSelectedLoopView_le_uniform + (attempts : Nat) (secretKey : SecretKey) (message : Message) + (referenceCache workingCache : QueryCache HashSpec) (P : FewTimeView → Prop) + (hinvariant : OnlyRejectedNewMessageEntries referenceCache workingCache secretKey message) : + Pr[P | (simulateQ romImpl (signDigestLoop attempts secretKey message)).run workingCache >>= + completeFreshSelectedLoopView referenceCache secretKey message] ≤ + Pr[P | ($ᵗ FewTimeView : ProbComp FewTimeView)] := by + induction attempts generalizing workingCache with + | zero => + simp [signDigestLoop, completeFreshSelectedLoopView, freshSelectedLoopView?] + | succ attempts ih => + rw [signDigestLoop_run_succ_eq] + rw [bind_assoc] + refine probEvent_bind_le_of_forall_le fun randomness _hrandomness => ?_ + let input := tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness) + by_cases hreference : referenceCache input = none + · by_cases hworking : workingCache input = none + · let continuation := signDigestLoopContinuation attempts secretKey message randomness + have hcoordinates := evalDist_signAttempt_fresh_bind_coordinates + secretKey message randomness workingCache (by simpa only [input] using hworking) + continuation + change Pr[P | + ((simulateQ randomOracle + (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf))))).run + workingCache >>= continuation) >>= + completeFreshSelectedLoopView referenceCache secretKey message] ≤ _ + have hcoordinates' : + 𝒟[((simulateQ randomOracle + (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf))))).run + workingCache >>= continuation) >>= + completeFreshSelectedLoopView referenceCache secretKey message] = + 𝒟[(do + let coordinates ← $ᵗ HashOutputCoordinates + let output := hashOutputCoordinatesEquiv.symm coordinates + continuation (signAttemptResultOfOutput output, + workingCache.cacheQuery input output)) >>= + completeFreshSelectedLoopView referenceCache secretKey message] := by + rw [evalDist_bind, hcoordinates, ← evalDist_bind] + rw [probEvent_congr' (fun _ _ => Iff.rfl) hcoordinates'] + rw [bind_assoc] + have hreorder := evalDist_uniformHashOutputCoordinates_bind_reordered + (fun coordinates => + let output := hashOutputCoordinatesEquiv.symm coordinates + continuation (signAttemptResultOfOutput output, + workingCache.cacheQuery input output) >>= + completeFreshSelectedLoopView referenceCache secretKey message) + rw [probEvent_congr' (fun _ _ => Iff.rfl) hreorder] + refine probEvent_bind_le_of_forall_le fun rest _hrest => ?_ + by_cases hadmissible : rest.1 = 0 + · refine (probEvent_bind_le_probEvent (p := P) (q := P) ?_).trans le_rfl + intro view _hview hnotP + let coordinates : HashOutputCoordinates := ((view, rest.1), rest.2) + let output := hashOutputCoordinatesEquiv.symm coordinates + have hsuccessful : signAttemptResultOfOutput output ≠ none := by + rw [signAttemptResultOfOutput_coordinates_ne_none_iff] + exact hadmissible + obtain ⟨indexLeaves, hindexLeaves⟩ := Option.ne_none_iff_exists'.mp hsuccessful + rcases indexLeaves with ⟨index, leaves⟩ + have hviewEq : selectedFewTimeView index leaves = view := + signAttemptResultOfOutput_coordinates_view coordinates index leaves + (by simpa only [output] using hindexLeaves) + dsimp only + rw [show signAttemptResultOfOutput + (hashOutputCoordinatesEquiv.symm ((view, rest.1), rest.2)) = + some (index, leaves) by + simpa only [coordinates, output] using hindexLeaves] + simp only [continuation, signDigestLoopContinuation, pure_bind] + rw [completeFreshSelectedLoopView, freshSelectedLoopView?] + have hreference' : referenceCache + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = none := by + simpa only [input] using hreference + simp [hreference', hviewEq, hnotP] + · refine probEvent_bind_le_of_forall_le fun view _hview => ?_ + let coordinates : HashOutputCoordinates := ((view, rest.1), rest.2) + let output := hashOutputCoordinatesEquiv.symm coordinates + have hrejected : signAttemptResultOfOutput output = none := by + apply Option.eq_none_iff_forall_not_mem.mpr + intro selected hselected + have hne : signAttemptResultOfOutput output ≠ none := by + rw [hselected] + simp + rw [signAttemptResultOfOutput_coordinates_ne_none_iff] at hne + exact hadmissible hne + have hinvariant' := onlyRejectedNewMessageEntries_cacheRejected + referenceCache workingCache secretKey message randomness output hinvariant + hrejected + simpa only [coordinates, output, continuation, hrejected, + signDigestLoopContinuation] using + ih (workingCache.cacheQuery input output) hinvariant' + · obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hworking + have hrejected := hinvariant randomness output + (by simpa only [input] using hreference) (by simpa only [input] using houtput) + rw [bind_assoc] + refine probEvent_bind_le_of_forall_le fun attemptResult hattempt => ?_ + have hle : workingCache ≤ attemptResult.2 := + simulateQ_romImpl_cache_le + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))) : + OracleComp OracleWorld (Option (Index × (DigestTree → FtsLeaf)))) + workingCache attemptResult (by + rw [simulateQ_romImpl_liftM] + exact hattempt) + have hattemptResult : attemptResult.1 = none := + (signAttempt_result_of_cached secretKey message randomness workingCache + attemptResult.2 attemptResult.1 output + (hle (by simpa only [input] using houtput)) hattempt).trans hrejected + have hinvariant' := onlyRejectedNewMessageEntries_of_failed_attempt + referenceCache workingCache attemptResult.2 secretKey message randomness + hinvariant (by + have heq : attemptResult = (none, attemptResult.2) := + Prod.ext hattemptResult rfl + rw [← heq] + exact hattempt) + simpa only [hattemptResult, signDigestLoopContinuation] using + ih attemptResult.2 hinvariant' + · rw [bind_assoc] + refine probEvent_bind_le_of_forall_le fun attemptResult hattempt => ?_ + cases hattemptResult : attemptResult.1 with + | none => + have hinvariant' := onlyRejectedNewMessageEntries_of_failed_attempt + referenceCache workingCache attemptResult.2 secretKey message randomness + hinvariant (by + have heq : attemptResult = (none, attemptResult.2) := + Prod.ext hattemptResult rfl + rw [← heq] + exact hattempt) + simpa only [hattemptResult, signDigestLoopContinuation] using + ih attemptResult.2 hinvariant' + | some selected => + rcases selected with ⟨index, leaves⟩ + have hreference' : referenceCache + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) ≠ none := by + simpa only [input] using hreference + simp [signDigestLoopContinuation, hattemptResult, + completeFreshSelectedLoopView, freshSelectedLoopView?, hreference'] + +noncomputable def completeFreshTargetSignerView + (initialCache : QueryCache HashSpec) + (result : TargetSignerResult × QueryCache HashSpec) : ProbComp FewTimeView := + match freshTargetSignerView? initialCache result with + | some view => pure view + | none => $ᵗ FewTimeView + +set_option maxRecDepth 100000 in +theorem probEvent_completeFreshTargetSignerView_le_uniform + (secretKey : SecretKey) (message : Message) + (initialCache : QueryCache HashSpec) (P : FewTimeView → Prop) : + Pr[P | (simulateQ romImpl (signWithTargetView secretKey message)).run initialCache >>= + completeFreshTargetSignerView initialCache] ≤ + Pr[P | ($ᵗ FewTimeView : ProbComp FewTimeView)] := by + rw [signWithTargetView, simulateQ_bind, StateT.run_bind, bind_assoc] + calc + _ = Pr[P | + (simulateQ romImpl (signDigestLoop digestAttemptLimit secretKey message)).run + initialCache >>= completeFreshSelectedLoopView initialCache secretKey message] := by + apply probEvent_bind_congr + intro loopResult _hloop + cases hloopResult : loopResult.1 with + | none => + simp [hloopResult, completeFreshTargetSignerView, + freshTargetSignerView?, completeFreshSelectedLoopView, + freshSelectedLoopView?] + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + simp only [simulateQ_bind, StateT.run_bind, bind_assoc, + simulateQ_pure, StateT.run_pure, pure_bind] + simp only [completeFreshTargetSignerView, freshTargetSignerView?] + rw [probEvent_bind_const] + rw [probFailure_eq_zero' inferInstance] + simp only [tsub_zero, one_mul] + by_cases hfresh : initialCache + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = none + · simp [completeFreshSelectedLoopView, freshSelectedLoopView?, + hloopResult, hfresh] + · simp [completeFreshSelectedLoopView, freshSelectedLoopView?, + hloopResult, hfresh] + _ ≤ _ := probEvent_completeFreshSelectedLoopView_le_uniform digestAttemptLimit + secretKey message initialCache initialCache P + (onlyRejectedNewMessageEntries_self initialCache secretKey message) + +theorem tsum_probOutput_signWithTargetView_completed_le_expected + (secretKey : SecretKey) (message : Message) + (initialCache : QueryCache HashSpec) + (cost : (TargetSignerResult × QueryCache HashSpec) → ℝ≥0∞) + (risk : FewTimeView → ℝ≥0∞) + (hnone : ∀ signerResult ∈ support + ((simulateQ romImpl (signWithTargetView secretKey message)).run initialCache), + freshTargetSignerView? initialCache signerResult = none → + cost signerResult ≤ + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * risk view) + (hsome : ∀ signerResult ∈ support + ((simulateQ romImpl (signWithTargetView secretKey message)).run initialCache), + ∀ view, freshTargetSignerView? initialCache signerResult = some view → + cost signerResult ≤ risk view) : + (∑' signerResult, + Pr[= signerResult | + (simulateQ romImpl (signWithTargetView secretKey message)).run initialCache] * + cost signerResult) ≤ + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * risk view := by + let signerComp := + (simulateQ romImpl (signWithTargetView secretKey message)).run initialCache + let uniformRisk := ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * risk view + calc + (∑' signerResult, Pr[= signerResult | signerComp] * cost signerResult) ≤ + ∑' signerResult, Pr[= signerResult | signerComp] * + match freshTargetSignerView? initialCache signerResult with + | some view => risk view + | none => uniformRisk := by + apply ENNReal.tsum_le_tsum + intro signerResult + by_cases hsupport : signerResult ∈ support signerComp + · apply mul_le_mul' le_rfl + cases hview : freshTargetSignerView? initialCache signerResult with + | none => exact hnone signerResult hsupport hview + | some view => exact hsome signerResult hsupport view hview + · rw [probOutput_eq_zero_of_not_mem_support hsupport] + simp + _ = ∑' view, + Pr[= view | signerComp >>= completeFreshTargetSignerView initialCache] * + risk view := by + rw [tsum_probOutput_bind_mul] + apply tsum_congr + intro signerResult + congr 1 + cases hview : freshTargetSignerView? initialCache signerResult with + | none => + simp [completeFreshTargetSignerView, hview, uniformRisk, + probEvent_eq_eq_probOutput, tsum_fintype] + | some view => + simp [completeFreshTargetSignerView, hview] + _ ≤ ∑' view, Pr[= view | ($ᵗ FewTimeView : ProbComp FewTimeView)] * risk view := by + apply ENNReal.tsum_le_tsum + intro view + apply mul_le_mul' _ le_rfl + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput] + exact probEvent_completeFreshTargetSignerView_le_uniform secretKey message + initialCache (fun value => value = view) + _ = _ := by simp only [tsum_fintype, probEvent_eq_eq_probOutput] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetCount.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetCount.lean new file mode 100644 index 00000000..dc8d86c6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetCount.lean @@ -0,0 +1,339 @@ +import SphincsSecurity.Proof.FewTimeTargetSource +import SphincsSecurity.Proof.FewTimePrehit + +/-! +# Counting fresh target-view candidates + +A direct hash interval contributes its queried input. A signer interval contributes its freshly +inserted admissible message-digest input, including the selected digest of a signing invocation +whose later signature construction failed. Distinct candidate intervals embed into distinct entries +of the final random-oracle cache. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +def TargetCandidateInput (secretKey : SecretKey) + (entry : AdversaryCacheEntry) (input : HashInput) (output : HashOutput) : Prop := + (entry.input = .inl (.inr input)) ∨ + ∃ request randomness, + entry.input = .inr request ∧ + input = tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root request randomness) ∧ + signAttemptResultOfOutput output ≠ none + +def FreshTargetCandidate (secretKey : SecretKey) + (entry : AdversaryCacheEntry) : Prop := + ∃ input output, + TargetCandidateInput secretKey entry input output + ∧ entry.initialCache input = none + ∧ entry.finalCache input = some output + +noncomputable instance (secretKey : SecretKey) : + DecidablePred (FreshTargetCandidate secretKey) := + fun entry => Classical.propDecidable (FreshTargetCandidate secretKey entry) + +theorem freshTargetCandidate_of_message_transition + (secretKey : SecretKey) (entry : AdversaryCacheEntry) (targetPayload : HashInput) + (hvalid : (entry.output, entry.finalCache) ∈ support + ((unloggedMappedAdversaryImpl secretKey entry.input).run entry.initialCache)) + (hbefore : entry.initialCache + (tweakableHashInput secretKey.parameter .message targetPayload) = none) + (hafter : entry.finalCache + (tweakableHashInput secretKey.parameter .message targetPayload) ≠ none) + (hadmissible : ∀ output, entry.finalCache + (tweakableHashInput secretKey.parameter .message targetPayload) = some output → + signAttemptResultOfOutput output ≠ none) + (hkind : entry.input = .inl (.inr + (tweakableHashInput secretKey.parameter .message targetPayload)) ∨ + ∃ request, entry.input = .inr request) : + FreshTargetCandidate secretKey entry := by + rcases entry with ⟨input, result, initialCache, finalCache⟩ + rcases input with worldInput | request + · rcases worldInput with uniformInput | hashInput + · rcases hkind with hfalse | ⟨_, hfalse⟩ <;> simp at hfalse + · obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hafter + refine ⟨tweakableHashInput secretKey.parameter .message targetPayload, output, ?_, + hbefore, houtput⟩ + rcases hkind with hdirect | ⟨_, hfalse⟩ + · exact Or.inl hdirect + · simp at hfalse + · obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hafter + change Option Signature at result + change (result, finalCache) ∈ support + ((simulateQ romImpl (scheme.sign secretKey request)).run initialCache) at hvalid + refine ⟨tweakableHashInput secretKey.parameter .message targetPayload, output, ?_, + hbefore, houtput⟩ + rcases hkind with hfalse | ⟨sourceRequest, hrequest⟩ + · simp at hfalse + · have hrequestEq : request = sourceRequest := by injection hrequest + subst sourceRequest + have hsign : (result, finalCache) ∈ support + ((simulateQ romImpl (scheme.sign secretKey request)).run initialCache) := by + exact hvalid + rw [show scheme.sign secretKey request = sign secretKey request from rfl] at hsign + obtain ⟨_, randomness, _, _, hpayload⟩ := + sign_message_source secretKey request initialCache finalCache result hsign + targetPayload hbefore hafter + exact Or.inr ⟨request, randomness, rfl, by rw [hpayload], hadmissible output houtput⟩ + +set_option linter.constructorNameAsVariable false in +theorem signWithView_fresh_admissible_transition_view + (secretKey : SecretKey) (message : Message) + (initialCache finalCache : QueryCache HashSpec) + (signature : Option Signature) (view : Option FewTimeView) + (hmem : ((signature, view), finalCache) ∈ support + ((simulateQ romImpl (signWithView secretKey message)).run initialCache)) + (targetPayload : HashInput) (output : HashOutput) (index : Index) + (leaves : DigestTree → FtsLeaf) + (hbefore : initialCache + (tweakableHashInput secretKey.parameter .message targetPayload) = none) + (hafter : finalCache + (tweakableHashInput secretKey.parameter .message targetPayload) = some output) + (houtput : signAttemptResultOfOutput output = some (index, leaves)) : + ∃ randomness, + targetPayload = messageDigestPayload secretKey.root message randomness + ∧ view = some (hashOutputFewTimeView output) + ∧ ∀ signed, signature = some signed → randomness = signed.randomness := by + rw [signWithView, simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hmem + obtain ⟨⟨loopResult, loopCache⟩, hloop, hfinish⟩ := hmem + have hloopLe : loopCache ≤ finalCache := by + cases loopResult with + | none => + have heq : ((signature, view), finalCache) = ((none, none), loopCache) := by + simpa only [simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hfinish + rw [show loopCache = finalCache from (congrArg Prod.snd heq).symm] + | some selected => + rcases selected with ⟨randomness, selectedIndex, selectedLeaves⟩ + exact simulateQ_romImpl_cache_le + (do + let signature ← liftM + (signAfterDigest secretKey randomness selectedIndex selectedLeaves) + pure (signature, some (selectedFewTimeView selectedIndex selectedLeaves))) + loopCache ((signature, view), finalCache) hfinish + have hloopHit : loopCache + (tweakableHashInput secretKey.parameter .message targetPayload) ≠ none := by + intro hnone + cases hloopResult : loopResult with + | none => + have heq : ((signature, view), finalCache) = ((none, none), loopCache) := by + simpa only [hloopResult, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hfinish + have hcache : finalCache = loopCache := congrArg Prod.snd heq + rw [hcache, hnone] at hafter + simp at hafter + | some selected => + rcases selected with ⟨randomness, selectedIndex, selectedLeaves⟩ + rw [hloopResult, simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hfinish + obtain ⟨⟨signatureResult, signatureCache⟩, hsignature, hpure⟩ := hfinish + have hpureEq : ((signature, view), finalCache) = + ((signatureResult, some (selectedFewTimeView selectedIndex selectedLeaves)), + signatureCache) := by + simpa only [simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hpure + have hsignature' : (signatureResult, signatureCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest secretKey randomness selectedIndex selectedLeaves)).run + loopCache) := by + simpa only [simulateQ_romImpl_liftM] using hsignature + have hnone' := signAfterDigest_cache_message_none secretKey randomness + selectedIndex selectedLeaves loopCache signatureCache signatureResult hsignature' + targetPayload hnone + have hcache : finalCache = signatureCache := congrArg Prod.snd hpureEq + rw [hcache, hnone'] at hafter + simp at hafter + obtain ⟨loopOutput, hloopOutput⟩ := Option.ne_none_iff_exists'.mp hloopHit + have hloopOutputEq : loopOutput = output := by + have := hloopLe hloopOutput + rw [hafter] at this + exact Option.some.inj this.symm + have hloopOutput' : loopCache + (tweakableHashInput secretKey.parameter .message targetPayload) = some output := by + rw [← hloopOutputEq] + exact hloopOutput + obtain ⟨_, randomness, _, hpayload, hloopResult⟩ := + signDigestLoop_successful_source_is_selected digestAttemptLimit secretKey message + initialCache loopCache loopResult hloop targetPayload output index leaves + hbefore hloopOutput' houtput + rw [hloopResult, simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hfinish + obtain ⟨⟨signatureResult, signatureCache⟩, hsignature, hpure⟩ := hfinish + have hpureEq : ((signature, view), finalCache) = + ((signatureResult, some (selectedFewTimeView index leaves)), signatureCache) := by + simpa only [simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hpure + have hview : view = some (selectedFewTimeView index leaves) := + congrArg (fun result => result.1.2) hpureEq + have houtputView := signAttemptResultOfOutput_view output index leaves houtput + refine ⟨randomness, hpayload, hview.trans (by + simpa only [selectedFewTimeView] using congrArg some houtputView), ?_⟩ + intro signed hsigned + have hresult : signatureResult = some signed := by + have := congrArg (fun result => result.1.1) hpureEq + rw [hsigned] at this + exact this.symm + have hsignature' : (some signed, signatureCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest secretKey randomness index leaves)).run loopCache) := by + rw [hresult] at hsignature + simpa only [simulateQ_romImpl_liftM] using hsignature + exact (signAfterDigest_support_some_randomness secretKey randomness index leaves + loopCache signatureCache signed hsignature').symm + +theorem signingCacheEntry_validView_fresh_admissible_transition_view + {secretKey : SecretKey} {entry : SigningCacheEntry} {view : Option FewTimeView} + (hvalid : SigningCacheEntry.ValidView secretKey entry view) + (targetPayload : HashInput) (output : HashOutput) (index : Index) + (leaves : DigestTree → FtsLeaf) + (hbefore : entry.initialCache + (tweakableHashInput secretKey.parameter .message targetPayload) = none) + (hafter : entry.finalCache + (tweakableHashInput secretKey.parameter .message targetPayload) = some output) + (houtput : signAttemptResultOfOutput output = some (index, leaves)) : + ∃ randomness, + targetPayload = messageDigestPayload secretKey.root entry.request randomness + ∧ view = some (hashOutputFewTimeView output) + ∧ ∀ signed, entry.signature = some signed → randomness = signed.randomness := + signWithView_fresh_admissible_transition_view secretKey entry.request + entry.initialCache entry.finalCache entry.signature view hvalid targetPayload output + index leaves hbefore hafter houtput + +noncomputable def freshTargetCandidatePositions + (secretKey : SecretKey) (trace : FullAdversaryTrace) : + Finset (Fin trace.intervals.length) := + Finset.univ.filter fun position => + FreshTargetCandidate secretKey (trace.intervals.get position) + +noncomputable def freshTargetCandidateCount + (secretKey : SecretKey) (trace : FullAdversaryTrace) : Nat := + trace.intervals.countP fun entry => decide (FreshTargetCandidate secretKey entry) + +theorem freshTargetCandidateCount_eq_card + (secretKey : SecretKey) (trace : FullAdversaryTrace) : + freshTargetCandidateCount secretKey trace = + (freshTargetCandidatePositions secretKey trace).card := by + classical + let predicate := fun position : Fin trace.intervals.length => + FreshTargetCandidate secretKey (trace.intervals.get position) + let encoded : {position // predicate position} ≃ + Fin (Fin.countP fun position => decide (predicate position)) := { + toFun := Fin.encodeSubtype predicate + invFun := Fin.decodeSubtype predicate + left_inv := Fin.decodeSubtype_encodeSubtype predicate + right_inv := Fin.encodeSubtype_decodeSubtype predicate } + have hcard := Fintype.card_congr encoded + have hcount : freshTargetCandidateCount secretKey trace = + Fin.countP (fun position => decide (predicate position)) := by + rw [freshTargetCandidateCount, Fin.countP_eq_countP_map_finRange] + calc + trace.intervals.countP + (fun entry => decide (FreshTargetCandidate secretKey entry)) = + ((List.finRange trace.intervals.length).map trace.intervals.get).countP + (fun entry => decide (FreshTargetCandidate secretKey entry)) := by + rw [List.map_get_finRange] + _ = (List.finRange trace.intervals.length).countP + ((fun entry => decide (FreshTargetCandidate secretKey entry)) ∘ + trace.intervals.get) := List.countP_map + _ = _ := by rfl + rw [hcount] + rw [← Fintype.card_fin (Fin.countP fun position => decide (predicate position)), + ← hcard] + let positions := freshTargetCandidatePositions secretKey trace + let subtypeEquiv : {position // predicate position} ≃ ↑positions := { + toFun := fun position => ⟨position.1, Finset.mem_filter.mpr + ⟨Finset.mem_univ _, position.2⟩⟩ + invFun := fun position => ⟨position.1, + (Finset.mem_filter.mp position.2).2⟩ + left_inv := fun position => rfl + right_inv := fun position => rfl } + exact (Fintype.card_congr subtypeEquiv).trans (Fintype.card_coe positions) + +theorem freshTargetCandidateCount_update + (secretKey : SecretKey) (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (finalCache : QueryCache HashSpec) (trace : FullAdversaryTrace) : + freshTargetCandidateCount secretKey + (fullAdversaryTraceUpdate input initialCache output finalCache trace) = + freshTargetCandidateCount secretKey trace + + if FreshTargetCandidate secretKey + ⟨input, output, initialCache, finalCache⟩ then 1 else 0 := by + classical + simp [freshTargetCandidateCount, fullAdversaryTraceUpdate, + List.countP_append, List.countP_cons] + +theorem freshTargetCandidatePositions_card_le_enncard + (secretKey : SecretKey) (trace : FullAdversaryTrace) + (finalCache : QueryCache HashSpec) + (hintervals : trace.IntervalsLe finalCache) + (hchronological : FullAdversaryTrace.Chronological trace.intervals) : + ((freshTargetCandidatePositions secretKey trace).card : ℝ≥0∞) ≤ + QueryCache.enncard finalCache := by + classical + let candidates := freshTargetCandidatePositions secretKey trace + let candidateInput : ↑candidates → HashInput := fun candidate => + Classical.choose ((Finset.mem_filter.mp candidate.2).2) + let candidateOutput : ∀ candidate : ↑candidates, HashOutput := fun candidate => + Classical.choose (Classical.choose_spec ((Finset.mem_filter.mp candidate.2).2)) + have candidateSpec : ∀ candidate : ↑candidates, + TargetCandidateInput secretKey (trace.intervals.get candidate.1) + (candidateInput candidate) (candidateOutput candidate) + ∧ (trace.intervals.get candidate.1).initialCache (candidateInput candidate) = none + ∧ (trace.intervals.get candidate.1).finalCache (candidateInput candidate) = + some (candidateOutput candidate) := by + intro candidate + exact Classical.choose_spec + (Classical.choose_spec ((Finset.mem_filter.mp candidate.2).2)) + let cacheEmbedding : ↑candidates ↪ finalCache.toSet := + ⟨fun candidate => ⟨⟨candidateInput candidate, candidateOutput candidate⟩, + (hintervals (trace.intervals.get candidate.1) + (List.get_mem trace.intervals candidate.1)).2 (candidateSpec candidate).2.2⟩, + by + intro left right heq + have hinput : candidateInput left = candidateInput right := + congrArg (fun entry : finalCache.toSet => entry.1.1) heq + apply Subtype.ext + by_contra hposition + rcases lt_or_gt_of_ne hposition with hlt | hlt + · have hle := hchronological.get_finalCache_le_initialCache left.1 right.1 hlt + have hcached := hle (candidateSpec left).2.2 + rw [hinput, (candidateSpec right).2.1] at hcached + simp at hcached + · have hle := hchronological.get_finalCache_le_initialCache right.1 left.1 hlt + have hcached := hle (candidateSpec right).2.2 + rw [← hinput, (candidateSpec left).2.1] at hcached + simp at hcached⟩ + have hencard := cacheEmbedding.encard_le + simpa only [candidates, QueryCache.enncard, Set.encard_coe_eq_coe_finsetCard, + ENat.toENNReal_coe] using ENat.toENNReal_mono hencard + +theorem gameAfterSecretsWithViewTrace_freshTargetCandidatePositions_card_le + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) : + ((freshTargetCandidatePositions + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ result.2.trace).card : ℝ≥0∞) ≤ q := by + have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hresult, rfl⟩ + have hinvariants := gameAfterSecretsWithFullTrace_support_interval_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + calc + _ ≤ QueryCache.enncard result.2.cache := + freshTargetCandidatePositions_card_le_enncard + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ result.2.trace result.2.cache + hinvariants.2.1 hinvariants.2.2 + _ ≤ q := gameAfterSecretsWithFullTrace_support_enncard_le adversary q hq + parameter hparameter otsSecret hots ftsSecret hfts (result.1, result.2.base) hbase + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetInvariant.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetInvariant.lean new file mode 100644 index 00000000..e8ebcdb3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetInvariant.lean @@ -0,0 +1,1110 @@ +import SphincsSecurity.Proof.FewTimeTargetMonitor +import SphincsSecurity.Proof.FewTimeTargetCompletion + +/-! +# One-step invariant for one adaptive few-time target + +The joint potential lifts the origin supermartingale while a fixed candidate ordinal is pending, +then fixes the candidate's view when that ordinal is reached. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +namespace Concrete + +noncomputable def OriginTargetMonitorState.afterDirect + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (input : HashInput) (output : HashOutput) : OriginTargetMonitorState configuration := + let advanced := state.advanceOrigin (state.origin.afterDirect input output) + if state.origin.viewed.cache input = none then + advanced.recordCandidate targetOrdinal + (decide (configuration.sourceAt? state.origin.directOrdinal = none)) + (hashOutputFewTimeView output) + else advanced + +theorem OriginTargetMonitorState.targetScheduleCoherent_afterDirect + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (input : HashInput) (output : HashOutput) + (hcoherent : state.TargetScheduleCoherent targetOrdinal) : + (state.afterDirect targetOrdinal input output).TargetScheduleCoherent + targetOrdinal := by + by_cases hfresh : state.origin.viewed.cache input = none + · simp only [OriginTargetMonitorState.afterDirect, hfresh, if_true] + exact OriginTargetMonitorState.targetScheduleCoherent_recordCandidate targetOrdinal + (state.advanceOrigin (state.origin.afterDirect input output)) _ _ + (state.targetScheduleCoherent_advanceOrigin targetOrdinal _ hcoherent) + · simpa [OriginTargetMonitorState.afterDirect, hfresh] using + state.targetScheduleCoherent_advanceOrigin targetOrdinal + (state.origin.afterDirect input output) hcoherent + +theorem OriginTargetMonitorState.potential_afterDirect_of_ordinal_ne + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (input : HashInput) (output : HashOutput) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hne : state.candidateOrdinal ≠ targetOrdinal) : + (state.afterDirect targetOrdinal input output).potential event = + (state.advanceOrigin (state.origin.afterDirect input output)).potential event := by + by_cases hfresh : state.origin.viewed.cache input = none + · simp only [OriginTargetMonitorState.afterDirect, hfresh, if_true] + exact OriginTargetMonitorState.potential_recordCandidate_of_ordinal_ne + targetOrdinal _ _ _ event hne + · simp [OriginTargetMonitorState.afterDirect, hfresh] + +theorem OriginTargetMonitorState.potential_advanceOrigin_congr + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) + (left right : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hcongr : ∀ target, + left.potential (fun views => event (views, target)) = + right.potential (fun views => event (views, target))) : + (state.advanceOrigin left).potential event = + (state.advanceOrigin right).potential event := by + classical + simp only [OriginTargetMonitorState.advanceOrigin, + OriginTargetMonitorState.potential] + split + · cases state.targetView with + | none => simp_rw [hcongr] + | some target => exact hcongr target + · rfl + +theorem OriginTargetMonitorState.potential_recordCandidate_advanceOrigin_congr + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (allowed : Bool) (view : FewTimeView) + (left right : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hcongr : ∀ target, + left.potential (fun views => event (views, target)) = + right.potential (fun views => event (views, target))) : + ((state.advanceOrigin left).recordCandidate targetOrdinal allowed view).potential event = + ((state.advanceOrigin right).recordCandidate targetOrdinal allowed view).potential event := by + classical + by_cases heq : state.candidateOrdinal = targetOrdinal + · cases hstate : state.valid <;> cases hallowed : allowed <;> + simp [OriginTargetMonitorState.recordCandidate, + OriginTargetMonitorState.advanceOrigin, OriginTargetMonitorState.potential, + heq, hstate, hcongr] + · by_cases hvalid : state.valid = true + · cases htarget : state.targetView with + | none => + simp [OriginTargetMonitorState.recordCandidate, + OriginTargetMonitorState.advanceOrigin, OriginTargetMonitorState.potential, + heq, hvalid, htarget] + simp_rw [hcongr] + | some target => + simpa [OriginTargetMonitorState.recordCandidate, + OriginTargetMonitorState.advanceOrigin, OriginTargetMonitorState.potential, + heq, hvalid, htarget] using hcongr target + · simp [OriginTargetMonitorState.recordCandidate, + OriginTargetMonitorState.advanceOrigin, OriginTargetMonitorState.potential, + heq, hvalid] + +noncomputable def OriginTargetMonitorState.afterSigner + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (secretKey : SecretKey) (request : SignRequest) + (state : OriginTargetMonitorState configuration) + (targetRun : TargetSignerResult × QueryCache HashSpec) : + OriginTargetMonitorState configuration := + let signerRun := (targetSignerResultView targetRun.1, targetRun.2) + let advanced := state.advanceOrigin + (state.origin.afterSigner secretKey request signerRun) + match targetRun.1.2 with + | none => advanced + | some (input, view) => + if state.origin.viewed.cache input = none then + advanced.recordCandidate targetOrdinal + (decide (pattern.selectedAt? state.origin.signerOrdinal = none)) view + else advanced + +theorem OriginTargetMonitorState.targetScheduleCoherent_afterSigner + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (secretKey : SecretKey) (request : SignRequest) + (state : OriginTargetMonitorState configuration) + (targetRun : TargetSignerResult × QueryCache HashSpec) + (hcoherent : state.TargetScheduleCoherent targetOrdinal) : + (state.afterSigner targetOrdinal secretKey request targetRun).TargetScheduleCoherent + targetOrdinal := by + cases hselection : targetRun.1.2 with + | none => + simpa [OriginTargetMonitorState.afterSigner, hselection] using + state.targetScheduleCoherent_advanceOrigin targetOrdinal + (state.origin.afterSigner secretKey request + (targetSignerResultView targetRun.1, targetRun.2)) hcoherent + | some selection => + rcases selection with ⟨input, view⟩ + by_cases hfresh : state.origin.viewed.cache input = none + · simp only [OriginTargetMonitorState.afterSigner, hselection, hfresh, if_true] + exact OriginTargetMonitorState.targetScheduleCoherent_recordCandidate targetOrdinal + (state.advanceOrigin (state.origin.afterSigner secretKey request + (targetSignerResultView targetRun.1, targetRun.2))) _ _ + (state.targetScheduleCoherent_advanceOrigin targetOrdinal _ hcoherent) + · simpa [OriginTargetMonitorState.afterSigner, hselection, hfresh] using + state.targetScheduleCoherent_advanceOrigin targetOrdinal + (state.origin.afterSigner secretKey request + (targetSignerResultView targetRun.1, targetRun.2)) hcoherent + +theorem OriginTargetMonitorState.potential_afterSigner_of_ordinal_ne + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (secretKey : SecretKey) (request : SignRequest) + (state : OriginTargetMonitorState configuration) + (targetRun : TargetSignerResult × QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hne : state.candidateOrdinal ≠ targetOrdinal) : + (state.afterSigner targetOrdinal secretKey request targetRun).potential event = + (state.advanceOrigin (state.origin.afterSigner secretKey request + (targetSignerResultView targetRun.1, targetRun.2))).potential event := by + cases hselection : targetRun.1.2 with + | none => simp [OriginTargetMonitorState.afterSigner, hselection] + | some selection => + rcases selection with ⟨input, view⟩ + by_cases hfresh : state.origin.viewed.cache input = none + · simp only [OriginTargetMonitorState.afterSigner, hselection, hfresh, if_true] + exact OriginTargetMonitorState.potential_recordCandidate_of_ordinal_ne + targetOrdinal _ _ _ event hne + · simp [OriginTargetMonitorState.afterSigner, hselection, hfresh] + +theorem OriginMonitorState.expected_potential_afterTargetSigner_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (request : SignRequest) + (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) (hcache : QueryCache.enncard state.viewed.cache ≤ q) + (hcoherent : state.ScheduleCoherent) : + (∑' targetRun, + Pr[= targetRun | + (simulateQ romImpl (signWithTargetView secretKey request)).run state.viewed.cache] * + (state.afterSigner secretKey request + (targetSignerResultView targetRun.1, targetRun.2)).potential event) ≤ + state.potential event := by + calc + _ = ∑' signerRun, + Pr[= signerRun | + (simulateQ romImpl (signWithView secretKey request)).run state.viewed.cache] * + (state.afterSigner secretKey request signerRun).potential event := by + rw [← simulateQ_signWithTargetView_projection_run] + rw [tsum_probOutput_map_mul] + _ ≤ _ := state.expected_potential_afterSigner_le secretKey request event q hq + hcache hcoherent + +theorem OriginTargetMonitorState.expected_potential_advanceOrigin_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) + (mass : α → ℝ≥0∞) (nextOrigin : α → OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hnext : ∀ target, + (∑' result, mass result * + (nextOrigin result).potential (fun views => event (views, target))) ≤ + state.origin.potential (fun views => event (views, target))) : + (∑' result, mass result * + (state.advanceOrigin (nextOrigin result)).potential event) ≤ + state.potential event := by + classical + cases hvalid : state.valid with + | false => + simp [OriginTargetMonitorState.potential, + OriginTargetMonitorState.advanceOrigin, hvalid] + | true => + cases htarget : state.targetView with + | some target => + simpa [OriginTargetMonitorState.potential, + OriginTargetMonitorState.advanceOrigin, hvalid, htarget] using hnext target + | none => + simp only [OriginTargetMonitorState.potential, + OriginTargetMonitorState.advanceOrigin, hvalid, htarget, if_true] + calc + (∑' result, mass result * + ∑ target, Pr[fun value : FewTimeView => value = target | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (nextOrigin result).potential (fun views => event (views, target))) = + ∑ target, Pr[fun value : FewTimeView => value = target | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + ∑' result, mass result * + (nextOrigin result).potential + (fun views => event (views, target)) := by + calc + _ = ∑' result, ∑ target, + mass result * + (Pr[fun value : FewTimeView => value = target | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (nextOrigin result).potential + (fun views => event (views, target))) := by + apply tsum_congr + intro result + rw [Finset.mul_sum] + _ = ∑ target, ∑' result, + mass result * + (Pr[fun value : FewTimeView => value = target | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (nextOrigin result).potential + (fun views => event (views, target))) := by + exact Summable.tsum_finsetSum fun _ _ => ENNReal.summable + _ = _ := by + apply Finset.sum_congr rfl + intro target _ + calc + _ = ∑' result, + Pr[fun value : FewTimeView => value = target | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (mass result * + (nextOrigin result).potential + (fun views => event (views, target))) := by + apply tsum_congr + intro result + ac_rfl + _ = _ := ENNReal.tsum_mul_left + _ ≤ _ := by + apply Finset.sum_le_sum + intro target _ + exact mul_le_mul' le_rfl (hnext target) + +theorem OriginTargetMonitorState.expected_potential_afterDirect_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (input : HashInput) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (horigin : state.origin.ScheduleCoherent) + (htarget : state.TargetScheduleCoherent targetOrdinal) : + (∑' result, Pr[= result | (randomOracle input).run state.origin.viewed.cache] * + (state.afterDirect targetOrdinal input result.1).potential event) ≤ + state.potential event := by + classical + by_cases hfresh : state.origin.viewed.cache input = none + · by_cases heq : state.candidateOrdinal = targetOrdinal + · cases hsource : configuration.sourceAt? state.origin.directOrdinal with + | some selected => + have hzero : ∀ output, + (state.afterDirect targetOrdinal input output).potential event = 0 := by + intro output + rw [OriginTargetMonitorState.afterDirect, if_pos hfresh] + rw [show decide + (configuration.sourceAt? state.origin.directOrdinal = none) = false by + simp [hsource]] + apply OriginTargetMonitorState.potential_recordCandidate_eq_of_disallowed + simpa [OriginTargetMonitorState.advanceOrigin] using heq + simp_rw [hzero] + simp + | none => + cases hvalid : state.valid with + | false => + have hzero : ∀ output, + (state.afterDirect targetOrdinal input output).potential event = 0 := by + intro output + rw [OriginTargetMonitorState.afterDirect, if_pos hfresh] + apply OriginTargetMonitorState.potential_eq_zero_of_invalid + simp [OriginTargetMonitorState.recordCandidate, + OriginTargetMonitorState.advanceOrigin, heq, hvalid] + simp_rw [hzero] + simp [OriginTargetMonitorState.potential, hvalid] + | true => + have htargetView : state.targetView = none := + state.targetView_eq_none_of_candidateOrdinal_eq htarget heq + calc + (∑' result, + Pr[= result | (randomOracle input).run state.origin.viewed.cache] * + (state.afterDirect targetOrdinal input result.1).potential event) ≤ + ∑ target, Pr[fun value : FewTimeView => value = target | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + state.origin.potential (fun views => event (views, target)) := by + apply tsum_probOutput_randomOracle_fresh_view_mul_le_expected + input state.origin.viewed.cache hfresh + intro result _ + simp [OriginTargetMonitorState.afterDirect, hfresh, hsource, + OriginTargetMonitorState.recordCandidate, + OriginTargetMonitorState.advanceOrigin, + OriginTargetMonitorState.potential, heq, hvalid, + state.origin.potential_afterDirect_of_sourceAt?_eq_none + input result.1 _ hsource] + _ = state.potential event := by + simp [OriginTargetMonitorState.potential, hvalid, htargetView] + · simp_rw [state.potential_afterDirect_of_ordinal_ne targetOrdinal input _ event heq] + apply state.expected_potential_advanceOrigin_le + intro target + exact state.origin.expected_potential_afterDirect_le input + (fun views => event (views, target)) horigin + · simp_rw [OriginTargetMonitorState.afterDirect, hfresh, if_false] + apply state.expected_potential_advanceOrigin_le + intro target + exact state.origin.expected_potential_afterDirect_le input + (fun views => event (views, target)) horigin + +set_option maxRecDepth 1000000 in +set_option maxHeartbeats 2000000 in +theorem OriginTargetMonitorState.expected_potential_afterSigner_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (secretKey : SecretKey) (request : SignRequest) + (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) + (hcache : QueryCache.enncard state.origin.viewed.cache ≤ q) + (horigin : state.origin.ScheduleCoherent) + (htarget : state.TargetScheduleCoherent targetOrdinal) : + (∑' targetRun, + Pr[= targetRun | + (simulateQ romImpl (signWithTargetView secretKey request)).run + state.origin.viewed.cache] * + (state.afterSigner targetOrdinal secretKey request targetRun).potential event) ≤ + state.potential event := by + classical + by_cases heq : state.candidateOrdinal = targetOrdinal + · cases hselected : pattern.selectedAt? state.origin.signerOrdinal with + | some selected => + calc + (∑' targetRun, + Pr[= targetRun | + (simulateQ romImpl (signWithTargetView secretKey request)).run + state.origin.viewed.cache] * + (state.afterSigner targetOrdinal secretKey request targetRun).potential + event) ≤ + ∑' targetRun, + Pr[= targetRun | + (simulateQ romImpl (signWithTargetView secretKey request)).run + state.origin.viewed.cache] * + (state.advanceOrigin (state.origin.afterSigner secretKey request + (targetSignerResultView targetRun.1, targetRun.2))).potential event := by + apply ENNReal.tsum_le_tsum + intro targetRun + apply mul_le_mul' le_rfl + cases hselection : targetRun.1.2 with + | none => + simp [OriginTargetMonitorState.afterSigner, hselection] + | some selection => + rcases selection with ⟨input, view⟩ + by_cases hfresh : state.origin.viewed.cache input = none + · have hdisallowed : decide + (pattern.selectedAt? state.origin.signerOrdinal = none) = false := by + simp [hselected] + rw [OriginTargetMonitorState.afterSigner] + simp only [hselection] + rw [if_pos hfresh, hdisallowed] + rw [OriginTargetMonitorState.potential_recordCandidate_eq_of_disallowed] + · exact zero_le + · simpa [OriginTargetMonitorState.advanceOrigin] using heq + · simp [OriginTargetMonitorState.afterSigner, hselection, hfresh] + _ ≤ state.potential event := by + apply state.expected_potential_advanceOrigin_le + intro target + exact state.origin.expected_potential_afterTargetSigner_le secretKey request + (fun views => event (views, target)) q hq hcache horigin + | none => + cases hvalid : state.valid with + | false => + have hzero : ∀ targetRun, + (state.afterSigner targetOrdinal secretKey request targetRun).potential + event = 0 := by + intro targetRun + apply OriginTargetMonitorState.potential_eq_zero_of_invalid + cases hselection : targetRun.1.2 with + | none => + simp [OriginTargetMonitorState.afterSigner, hselection, + OriginTargetMonitorState.advanceOrigin, hvalid] + | some selection => + rcases selection with ⟨input, view⟩ + by_cases hfresh : state.origin.viewed.cache input = none + · simp [OriginTargetMonitorState.afterSigner, hselection, hfresh, + OriginTargetMonitorState.recordCandidate, + OriginTargetMonitorState.advanceOrigin, hvalid] + · simp [OriginTargetMonitorState.afterSigner, hselection, hfresh, + OriginTargetMonitorState.advanceOrigin, hvalid] + simp_rw [hzero] + simp [OriginTargetMonitorState.potential, hvalid] + | true => + have htargetView : state.targetView = none := + state.targetView_eq_none_of_candidateOrdinal_eq htarget heq + rw [OriginTargetMonitorState.potential, if_pos hvalid, htargetView] + let signerCost := fun targetRun : TargetSignerResult × QueryCache HashSpec => + (state.afterSigner targetOrdinal secretKey request targetRun).potential event + let signerRisk := fun target : FewTimeView => + state.origin.potential (fun views => event (views, target)) + refine tsum_probOutput_signWithTargetView_completed_le_expected + secretKey request state.origin.viewed.cache signerCost signerRisk ?_ ?_ + · intro targetRun _hsupport hnone + dsimp only [signerCost, signerRisk] + cases hselection : targetRun.1.2 with + | none => + simp [OriginTargetMonitorState.afterSigner, hselection, + OriginTargetMonitorState.potential, + OriginTargetMonitorState.advanceOrigin, hvalid, htargetView, + state.origin.potential_afterSigner_of_selectedAt?_eq_none + secretKey request + (targetSignerResultView targetRun.1, targetRun.2) _ hselected] + | some selection => + rcases selection with ⟨input, view⟩ + have hfresh : state.origin.viewed.cache input ≠ none := by + simpa [freshTargetSignerView?, hselection] using hnone + simp [OriginTargetMonitorState.afterSigner, hselection, hfresh, + OriginTargetMonitorState.potential, + OriginTargetMonitorState.advanceOrigin, hvalid, htargetView, + state.origin.potential_afterSigner_of_selectedAt?_eq_none + secretKey request + (targetSignerResultView targetRun.1, targetRun.2) _ hselected] + · intro targetRun _hsupport target hsome + dsimp only [signerCost, signerRisk] + cases hselection : targetRun.1.2 with + | none => simp [freshTargetSignerView?, hselection] at hsome + | some selection => + rcases selection with ⟨input, view⟩ + have hfresh : state.origin.viewed.cache input = none := by + by_contra hnot + simp [freshTargetSignerView?, hselection, hnot] at hsome + have hview : view = target := by + simpa [freshTargetSignerView?, hselection, hfresh] using hsome + subst view + simp [OriginTargetMonitorState.afterSigner, hselection, hfresh, + OriginTargetMonitorState.recordCandidate, + OriginTargetMonitorState.advanceOrigin, + OriginTargetMonitorState.potential, heq, hvalid, hselected, + state.origin.potential_afterSigner_of_selectedAt?_eq_none + secretKey request + (targetSignerResultView targetRun.1, targetRun.2) _ hselected] + · simp_rw [state.potential_afterSigner_of_ordinal_ne targetOrdinal secretKey request _ + event heq] + apply state.expected_potential_advanceOrigin_le + intro target + exact state.origin.expected_potential_afterTargetSigner_le secretKey request + (fun views => event (views, target)) q hq hcache horigin + +theorem originTargetMonitoredAdversaryImpl_direct_result_potential + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (input : HashInput) (result : HashOutput × QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) : + let trace := fullAdversaryTraceUpdate (.inl (.inr input)) state.origin.viewed.cache + result.1 result.2 state.origin.viewed.trace + let monitored := monitorDirectSource state.origin input result.1 + let origin : OriginMonitorState configuration := + ⟨⟨result.2, trace, state.origin.viewed.views, state.origin.viewed.targetView⟩, + monitored.1, state.origin.directOrdinal + 1, state.origin.signerOrdinal, + monitored.2⟩ + let advanced := state.advanceOrigin origin + (if state.origin.viewed.cache input = none then + advanced.recordCandidate targetOrdinal + (decide (configuration.sourceAt? state.origin.directOrdinal = none)) + (hashOutputFewTimeView result.1) + else advanced).potential event = + (state.afterDirect targetOrdinal input result.1).potential event := by + classical + dsimp only + have horigin : ∀ target, + (⟨⟨result.2, + fullAdversaryTraceUpdate (.inl (.inr input)) state.origin.viewed.cache + result.1 result.2 state.origin.viewed.trace, + state.origin.viewed.views, state.origin.viewed.targetView⟩, + (monitorDirectSource state.origin input result.1).1, + state.origin.directOrdinal + 1, state.origin.signerOrdinal, + (monitorDirectSource state.origin input result.1).2⟩ : + OriginMonitorState configuration).potential + (fun views => event (views, target)) = + (state.origin.afterDirect input result.1).potential + (fun views => event (views, target)) := by + intro target + exact originMonitoredAdversaryImpl_direct_result_potential configuration secretKey + state.origin input result (fun views => event (views, target)) + by_cases hfresh : state.origin.viewed.cache input = none + · simp only [hfresh, if_true, OriginTargetMonitorState.afterDirect] + exact OriginTargetMonitorState.potential_recordCandidate_advanceOrigin_congr + targetOrdinal state _ _ _ _ event horigin + · simp only [hfresh, if_false, OriginTargetMonitorState.afterDirect] + exact state.potential_advanceOrigin_congr _ _ event horigin + +theorem originTargetMonitoredAdversaryImpl_signer_result_potential + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (request : SignRequest) (targetRun : TargetSignerResult × QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) : + let signerRun := (targetSignerResultView targetRun.1, targetRun.2) + let trace := fullAdversaryTraceUpdate (.inr request) state.origin.viewed.cache + signerRun.1.1 signerRun.2 state.origin.viewed.trace + let monitored := monitorSigner secretKey request state.origin signerRun + let origin : OriginMonitorState configuration := + ⟨⟨signerRun.2, trace, state.origin.viewed.views ++ [signerRun.1.2], + state.origin.viewed.targetView⟩, monitored.1, state.origin.directOrdinal, + state.origin.signerOrdinal + 1, monitored.2⟩ + let advanced := state.advanceOrigin origin + (match targetRun.1.2 with + | none => advanced + | some (input, view) => + if state.origin.viewed.cache input = none then + advanced.recordCandidate targetOrdinal + (decide (pattern.selectedAt? state.origin.signerOrdinal = none)) view + else advanced).potential event = + (state.afterSigner targetOrdinal secretKey request targetRun).potential event := by + classical + dsimp only + have horigin : ∀ target, + (⟨⟨targetRun.2, + fullAdversaryTraceUpdate (.inr request) state.origin.viewed.cache + (targetSignerResultView targetRun.1).1 targetRun.2 state.origin.viewed.trace, + state.origin.viewed.views ++ [(targetSignerResultView targetRun.1).2], + state.origin.viewed.targetView⟩, + (monitorSigner secretKey request state.origin + (targetSignerResultView targetRun.1, targetRun.2)).1, + state.origin.directOrdinal, state.origin.signerOrdinal + 1, + (monitorSigner secretKey request state.origin + (targetSignerResultView targetRun.1, targetRun.2)).2⟩ : + OriginMonitorState configuration).potential + (fun views => event (views, target)) = + (state.origin.afterSigner secretKey request + (targetSignerResultView targetRun.1, targetRun.2)).potential + (fun views => event (views, target)) := by + intro target + exact originMonitoredAdversaryImpl_signer_result_potential configuration secretKey + state.origin request (targetSignerResultView targetRun.1, targetRun.2) + (fun views => event (views, target)) + cases hselection : targetRun.1.2 with + | none => + simp only [OriginTargetMonitorState.afterSigner, hselection] + exact state.potential_advanceOrigin_congr _ _ event horigin + | some selection => + rcases selection with ⟨input, view⟩ + by_cases hfresh : state.origin.viewed.cache input = none + · simp only [OriginTargetMonitorState.afterSigner, hselection, hfresh, if_true] + exact OriginTargetMonitorState.potential_recordCandidate_advanceOrigin_congr + targetOrdinal state _ view _ _ event horigin + · simp only [OriginTargetMonitorState.afterSigner, hselection, hfresh, if_false] + exact state.potential_advanceOrigin_congr _ _ event horigin + +theorem originTargetMonitoredAdversaryImpl_expected_potential_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) + (hcache : QueryCache.enncard state.origin.viewed.cache ≤ q) + (horigin : state.origin.ScheduleCoherent) + (htarget : state.TargetScheduleCoherent targetOrdinal) : + (∑' result, + Pr[= result | + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state] * result.2.potential event) ≤ + state.potential event := by + classical + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + simp only [originTargetMonitoredAdversaryImpl, StateT.run, + tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + apply state.expected_potential_advanceOrigin_le + intro target + exact originMonitoredAdversaryImpl_expected_potential_le configuration secretKey + (.inl (.inl uniformInput)) state.origin (fun views => event (views, target)) + q hq hcache horigin + | inr hashInput => + simp only [originTargetMonitoredAdversaryImpl, StateT.run, + tsum_probOutput_bind_mul, tsum_probOutput_pure_mul, + originMonitoredAdversaryImpl] + by_cases hfresh : state.origin.viewed.cache hashInput = none + · simp only [hfresh, if_true, tsum_probOutput_pure_mul] + convert state.expected_potential_afterDirect_le targetOrdinal hashInput event + horigin htarget using 1 + apply tsum_congr + intro result + congr 1 + simpa only [hfresh, if_true] using + (originTargetMonitoredAdversaryImpl_direct_result_potential + configuration secretKey targetOrdinal state hashInput result event) + · simp only [hfresh, if_false, tsum_probOutput_pure_mul] + convert state.expected_potential_afterDirect_le targetOrdinal hashInput event + horigin htarget using 1 + apply tsum_congr + intro result + congr 1 + simpa only [hfresh, if_false] using + (originTargetMonitoredAdversaryImpl_direct_result_potential + configuration secretKey targetOrdinal state hashInput result event) + | inr request => + simp only [originTargetMonitoredAdversaryImpl, StateT.run, + tsum_probOutput_bind_mul] + convert state.expected_potential_afterSigner_le targetOrdinal secretKey request event + q hq hcache horigin htarget using 1 + apply tsum_congr + intro targetRun + congr 1 + cases hselection : targetRun.1.2 with + | none => + simp only [tsum_probOutput_pure_mul] + simpa only [hselection] using + (originTargetMonitoredAdversaryImpl_signer_result_potential + configuration secretKey targetOrdinal state request targetRun event) + | some selection => + rcases selection with ⟨input, view⟩ + by_cases hfresh : state.origin.viewed.cache input = none + · simp only [hfresh, if_true, tsum_probOutput_pure_mul] + simpa only [hselection, hfresh, if_true] using + (originTargetMonitoredAdversaryImpl_signer_result_potential + configuration secretKey targetOrdinal state request targetRun event) + · simp only [hfresh, if_false, tsum_probOutput_pure_mul] + simpa only [hselection, hfresh, if_false] using + (originTargetMonitoredAdversaryImpl_signer_result_potential + configuration secretKey targetOrdinal state request targetRun event) + +def OriginTargetMonitorState.JointCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) : Prop := + state.origin.ScheduleCoherent ∧ state.TargetScheduleCoherent targetOrdinal + +theorem OriginTargetMonitorState.jointCoherent_initial + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (cache : QueryCache HashSpec) + (targetOrdinal : Nat) : + (OriginTargetMonitorState.initial configuration cache).JointCoherent targetOrdinal := by + exact ⟨OriginMonitorState.scheduleCoherent_initial configuration cache, + OriginTargetMonitorState.targetScheduleCoherent_initial configuration cache targetOrdinal⟩ + +theorem originTargetMonitoredAdversaryImpl_query_jointCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) + (result : (OracleWorld + SigningSpec).Range input × + OriginTargetMonitorState configuration) + (hcoherent : state.JointCoherent targetOrdinal) + (hmem : result ∈ support + ((originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state)) : result.2.JointCoherent targetOrdinal := by + classical + rcases hcoherent with ⟨horigin, htarget⟩ + cases input with + | inl worldInput => + rw [originTargetMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, origin⟩, horiginMem, hpure⟩ := hmem + cases worldInput with + | inl uniformInput => + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + constructor + · exact originMonitoredAdversaryImpl_query_scheduleCoherent configuration secretKey + (.inl (.inl uniformInput)) state.origin (output, origin) horigin horiginMem + · simpa [OriginTargetMonitorState.JointCoherent, + OriginTargetMonitorState.TargetScheduleCoherent, + OriginTargetMonitorState.advanceOrigin] using htarget + | inr hashInput => + by_cases hfresh : state.origin.viewed.cache hashInput = none + · simp only [hfresh, if_true, support_pure, Set.mem_singleton_iff] at hpure + subst result + constructor + · exact originMonitoredAdversaryImpl_query_scheduleCoherent configuration secretKey + (.inl (.inr hashInput)) state.origin (output, origin) horigin horiginMem + · exact OriginTargetMonitorState.targetScheduleCoherent_recordCandidate + targetOrdinal (state.advanceOrigin origin) _ _ + (state.targetScheduleCoherent_advanceOrigin targetOrdinal origin htarget) + · simp only [hfresh, if_false, support_pure, Set.mem_singleton_iff] at hpure + subst result + constructor + · exact originMonitoredAdversaryImpl_query_scheduleCoherent configuration secretKey + (.inl (.inr hashInput)) state.origin (output, origin) horigin horiginMem + · exact state.targetScheduleCoherent_advanceOrigin targetOrdinal origin htarget + | inr request => + rw [originTargetMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨targetRun, htargetRun, hpure⟩ := hmem + cases hselection : targetRun.1.2 with + | none => + simp only [hselection, support_pure, Set.mem_singleton_iff] at hpure + subst result + constructor + · simpa [OriginMonitorState.ScheduleCoherent, OriginMonitorState.afterSigner, + OriginTargetMonitorState.advanceOrigin] using + state.origin.scheduleCoherent_afterSigner secretKey request + (targetSignerResultView targetRun.1, targetRun.2) horigin + · exact state.targetScheduleCoherent_advanceOrigin targetOrdinal _ htarget + | some selection => + rcases selection with ⟨selectedInput, view⟩ + by_cases hfresh : state.origin.viewed.cache selectedInput = none + · simp only [hselection, hfresh, if_true, support_pure, + Set.mem_singleton_iff] at hpure + subst result + constructor + · simpa [OriginMonitorState.ScheduleCoherent, OriginMonitorState.afterSigner, + OriginTargetMonitorState.recordCandidate, + OriginTargetMonitorState.advanceOrigin] using + state.origin.scheduleCoherent_afterSigner secretKey request + (targetSignerResultView targetRun.1, targetRun.2) horigin + · exact OriginTargetMonitorState.targetScheduleCoherent_recordCandidate + targetOrdinal _ _ _ + (state.targetScheduleCoherent_advanceOrigin targetOrdinal _ htarget) + · simp only [hselection, hfresh, if_false, support_pure, + Set.mem_singleton_iff] at hpure + subst result + constructor + · simpa [OriginMonitorState.ScheduleCoherent, OriginMonitorState.afterSigner, + OriginTargetMonitorState.advanceOrigin] using + state.origin.scheduleCoherent_afterSigner secretKey request + (targetSignerResultView targetRun.1, targetRun.2) horigin + · exact state.targetScheduleCoherent_advanceOrigin targetOrdinal _ htarget + +theorem originTargetMonitoredAdversaryImpl_query_cache_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) + (result : (OracleWorld + SigningSpec).Range input × + OriginTargetMonitorState configuration) + (hmem : result ∈ support + ((originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state)) : state.origin.viewed.cache ≤ result.2.origin.viewed.cache := by + classical + cases input with + | inl worldInput => + rw [originTargetMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, origin⟩, horiginMem, hpure⟩ := hmem + cases worldInput with + | inl uniformInput => + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + exact originMonitoredAdversaryImpl_query_cache_le configuration secretKey + (.inl (.inl uniformInput)) state.origin (output, origin) horiginMem + | inr hashInput => + by_cases hfresh : state.origin.viewed.cache hashInput = none + · simp only [hfresh, if_true, support_pure, Set.mem_singleton_iff] at hpure + subst result + exact originMonitoredAdversaryImpl_query_cache_le configuration secretKey + (.inl (.inr hashInput)) state.origin (output, origin) horiginMem + · simp only [hfresh, if_false, support_pure, Set.mem_singleton_iff] at hpure + subst result + exact originMonitoredAdversaryImpl_query_cache_le configuration secretKey + (.inl (.inr hashInput)) state.origin (output, origin) horiginMem + | inr request => + rw [originTargetMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨targetRun, htargetRun, hpure⟩ := hmem + have hle := simulateQ_romImpl_cache_le (signWithTargetView secretKey request) + state.origin.viewed.cache targetRun htargetRun + cases hselection : targetRun.1.2 with + | none => + simp only [hselection, support_pure, Set.mem_singleton_iff] at hpure + subst result + exact hle + | some selection => + rcases selection with ⟨selectedInput, view⟩ + by_cases hfresh : state.origin.viewed.cache selectedInput = none + · simp only [hselection, hfresh, if_true, support_pure, + Set.mem_singleton_iff] at hpure + subst result + exact hle + · simp only [hselection, hfresh, if_false, support_pure, + Set.mem_singleton_iff] at hpure + subst result + exact hle + +noncomputable def OriginTargetMonitorState.cappedPotential + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) : ℝ≥0∞ := + if QueryCache.enncard state.origin.viewed.cache ≤ q then state.potential event else 0 + +theorem OriginTargetMonitorState.cappedPotential_le_potential + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) : + state.cappedPotential q event ≤ state.potential event := by + classical + simp only [OriginTargetMonitorState.cappedPotential] + split_ifs + · exact le_rfl + · exact bot_le + +theorem OriginTargetMonitorState.cappedPotential_eq_of_enncard_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hcache : QueryCache.enncard state.origin.viewed.cache ≤ q) : + state.cappedPotential q event = state.potential event := by + simp [OriginTargetMonitorState.cappedPotential, hcache] + +theorem OriginTargetMonitorState.cappedPotential_eq_zero_of_not_enncard_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hcache : ¬ QueryCache.enncard state.origin.viewed.cache ≤ q) : + state.cappedPotential q event = 0 := by + simp [OriginTargetMonitorState.cappedPotential, hcache] + +theorem originTargetMonitoredAdversaryImpl_expected_cappedPotential_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) + (hcoherent : state.JointCoherent targetOrdinal) : + (∑' result, + Pr[= result | + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state] * result.2.cappedPotential q event) ≤ + state.cappedPotential q event := by + classical + by_cases hcache : QueryCache.enncard state.origin.viewed.cache ≤ q + · rw [state.cappedPotential_eq_of_enncard_le q event hcache] + calc + (∑' result, + Pr[= result | + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state] * result.2.cappedPotential q event) ≤ + ∑' result, + Pr[= result | + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state] * result.2.potential event := by + apply ENNReal.tsum_le_tsum + intro result + exact mul_le_mul' le_rfl (result.2.cappedPotential_le_potential q event) + _ ≤ _ := originTargetMonitoredAdversaryImpl_expected_potential_le configuration + secretKey targetOrdinal input state event q hq hcache hcoherent.1 hcoherent.2 + · rw [state.cappedPotential_eq_zero_of_not_enncard_le q event hcache] + have hzero : (∑' result, + Pr[= result | + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state] * result.2.cappedPotential q event) = 0 := by + apply ENNReal.tsum_eq_zero.2 + intro result + by_cases hresult : result ∈ support + ((originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state) + · have hle := originTargetMonitoredAdversaryImpl_query_cache_le configuration + secretKey targetOrdinal input state result hresult + have hcard := QueryCache.enncard_mono hle + have hnotFinal : ¬ QueryCache.enncard result.2.origin.viewed.cache ≤ q := + fun hfinal => hcache (hcard.trans hfinal) + rw [result.2.cappedPotential_eq_zero_of_not_enncard_le q event hnotFinal, + mul_zero] + · rw [probOutput_eq_zero_of_not_mem_support hresult, zero_mul] + exact hzero.le + +theorem originTargetMonitoredAdversaryImpl_expected_cappedPotential_simulateQ_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) + (hcoherent : initialState.JointCoherent targetOrdinal) : + (∑' result, + Pr[= result | + (simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState] * + result.2.cappedPotential q event) ≤ initialState.cappedPotential q event := by + induction computation using OracleComp.inductionOn generalizing initialState with + | pure value => + simp [simulateQ_pure, tsum_probOutput_pure_mul] + | query_bind input next ih => + rw [simulateQ_bind, StateT.run_bind, simulateQ_query, + tsum_probOutput_bind_mul] + simp only [OracleQuery.input_query, OracleQuery.cont_query, id_map] + calc + (∑' result, + Pr[= result | + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + initialState] * + ∑' finalResult, + Pr[= finalResult | + (simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + (next result.1)).run result.2] * + finalResult.2.cappedPotential q event) ≤ + ∑' result, + Pr[= result | + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + initialState] * result.2.cappedPotential q event := by + apply ENNReal.tsum_le_tsum + intro result + by_cases hresult : result ∈ support + ((originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + initialState) + · apply mul_le_mul' le_rfl + exact ih result.1 result.2 + (originTargetMonitoredAdversaryImpl_query_jointCoherent configuration secretKey + targetOrdinal input initialState result hcoherent hresult) + · rw [probOutput_eq_zero_of_not_mem_support hresult, zero_mul, zero_mul] + _ ≤ _ := originTargetMonitoredAdversaryImpl_expected_cappedPotential_le + configuration secretKey targetOrdinal input initialState event q hq hcoherent + +def OriginTargetMonitorState.Complete + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) : Prop := + state.valid = true ∧ state.origin.Complete ∧ ∃ target, state.targetView = some target + +theorem OriginTargetMonitorState.potential_eq_one_of_complete + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hcomplete : state.Complete) + (hevent : ∀ target, state.targetView = some target → + event (state.origin.observation.views, target)) : + state.potential event = 1 := by + rcases hcomplete with ⟨hvalid, horigin, target, htarget⟩ + simp [OriginTargetMonitorState.potential, hvalid, htarget, + state.origin.potential_eq_one_of_complete + (fun views => event (views, target)) horigin (hevent target htarget)] + +theorem OriginTargetMonitorState.cappedPotential_eq_one_of_complete + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hcache : QueryCache.enncard state.origin.viewed.cache ≤ q) + (hcomplete : state.Complete) + (hevent : ∀ target, state.targetView = some target → + event (state.origin.observation.views, target)) : + state.cappedPotential q event = 1 := by + rw [state.cappedPotential_eq_of_enncard_le q event hcache, + state.potential_eq_one_of_complete event hcomplete hevent] + +theorem probEvent_originTargetMonitored_complete_le_initial + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) + (hcoherent : initialState.JointCoherent targetOrdinal) : + Pr[fun result : α × OriginTargetMonitorState configuration => + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + event (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q | + (simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState] ≤ initialState.cappedPotential q event := by + let run := (simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState + calc + Pr[fun result : α × OriginTargetMonitorState configuration => + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + event (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q | run] ≤ + ∑' result, Pr[= result | run] * result.2.cappedPotential q event := by + apply probEvent_le_tsum_probOutput_mul_cost + intro result hresult + rw [result.2.cappedPotential_eq_one_of_complete q event hresult.2.2 + hresult.1 hresult.2.1] + _ ≤ _ := originTargetMonitoredAdversaryImpl_expected_cappedPotential_simulateQ_le + configuration secretKey targetOrdinal computation initialState event q hq hcoherent + +theorem probEvent_uniform_views_target_eq_sum + {signatures distinct : Nat} (pattern : FewTimePattern signatures distinct) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) : + Pr[event | ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : + ProbComp ((pattern.selected → FewTimeView) × FewTimeView))] = + ∑ target, Pr[fun value : FewTimeView => value = target | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + Pr[fun views => event (views, target) | + ($ᵗ (pattern.selected → FewTimeView) : + ProbComp (pattern.selected → FewTimeView))] := by + classical + let viewsComp := ($ᵗ (pattern.selected → FewTimeView) : + ProbComp (pattern.selected → FewTimeView)) + let targetComp := ($ᵗ FewTimeView : ProbComp FewTimeView) + calc + _ = Pr[event | do + let views ← viewsComp + let target ← targetComp + pure (views, target)] := by + apply probEvent_congr' (fun _ _ => Iff.rfl) + exact evalDist_independent_uniform_pair.symm + _ = Pr[event | do + let target ← targetComp + let views ← viewsComp + pure (views, target)] := by + apply probEvent_congr' (fun _ _ => Iff.rfl) + exact OracleComp.DeferredSampling.evalDist_bind_comm viewsComp targetComp + (fun views target => pure (views, target)) + _ = ∑' target, Pr[= target | targetComp] * + Pr[fun views => event (views, target) | viewsComp] := by + rw [probEvent_bind_eq_tsum] + apply tsum_congr + intro target + congr 1 + rw [bind_pure_comp, probEvent_map] + rfl + _ = _ := by + simp only [viewsComp, targetComp, tsum_fintype, + probEvent_eq_eq_probOutput] + +theorem OriginTargetMonitorState.potential_initial + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) + (cache : QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) : + (OriginTargetMonitorState.initial configuration cache).potential event = + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ configuration.prehit.card * + Pr[event | ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : + ProbComp ((pattern.selected → FewTimeView) × FewTimeView))] := by + classical + rw [OriginTargetMonitorState.potential] + simp only [OriginTargetMonitorState.initial, if_true] + simp_rw [OriginMonitorState.potential_initial] + rw [probEvent_uniform_views_target_eq_sum pattern event] + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro target _ + ac_rfl + +theorem probEvent_originTargetMonitored_complete_le_ideal + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 126) + (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[fun result : α × OriginTargetMonitorState configuration => + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + event (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q | + (simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run (OriginTargetMonitorState.initial configuration initialCache)] ≤ + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ configuration.prehit.card * + Pr[event | ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : + ProbComp ((pattern.selected → FewTimeView) × FewTimeView))] := by + calc + _ ≤ (OriginTargetMonitorState.initial configuration initialCache).cappedPotential + q event := + probEvent_originTargetMonitored_complete_le_initial configuration secretKey + targetOrdinal computation (OriginTargetMonitorState.initial configuration initialCache) + event q hq + (OriginTargetMonitorState.jointCoherent_initial configuration initialCache + targetOrdinal) + _ = (OriginTargetMonitorState.initial configuration initialCache).potential event := + OriginTargetMonitorState.cappedPotential_eq_of_enncard_le q + (OriginTargetMonitorState.initial configuration initialCache) event hcache + _ = _ := OriginTargetMonitorState.potential_initial configuration initialCache event + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetMonitor.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetMonitor.lean new file mode 100644 index 00000000..e77e7564 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetMonitor.lean @@ -0,0 +1,552 @@ +import SphincsSecurity.Proof.FewTimeOriginInvariant +import SphincsSecurity.Proof.FewTimeTargetSigner + +/-! +# Monitoring one adaptive target candidate + +This proof-only wrapper follows an origin monitor while retaining the view at one fixed ordinal in +the stream of fresh direct answers and fresh signer selections. Its signer uses +`signWithTargetView`, whose projection is the ordinary viewed signer. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +namespace Concrete + +theorem probEvent_randomOracle_fresh_view + (input : HashInput) (cache : QueryCache HashSpec) (hcache : cache input = none) + (P : FewTimeView → Prop) : + Pr[fun result : HashOutput × QueryCache HashSpec => P (hashOutputFewTimeView result.1) | + (randomOracle input).run cache] = + Pr[P | ($ᵗ FewTimeView : ProbComp FewTimeView)] := by + rw [OracleSpec.randomOracle, QueryImpl.withCaching_run_none _ hcache] + change Pr[fun result : HashOutput × QueryCache HashSpec => + P (hashOutputFewTimeView result.1) | + (fun output : HashOutput => (output, cache.cacheQuery input output)) <$> + ($ᵗ HashOutput : ProbComp HashOutput)] = _ + rw [probEvent_map] + calc + Pr[fun output : HashOutput => P (hashOutputFewTimeView output) | + ($ᵗ HashOutput : ProbComp HashOutput)] = + Pr[P | hashOutputFewTimeView <$> ($ᵗ HashOutput : ProbComp HashOutput)] := + (probEvent_map (mx := ($ᵗ HashOutput : ProbComp HashOutput)) + (f := hashOutputFewTimeView) P).symm + _ = _ := probEvent_congr' (fun _ _ => Iff.rfl) + evalDist_hashOutputFewTimeView_uniform + +theorem tsum_probOutput_randomOracle_fresh_view_mul_le_expected + (input : HashInput) (cache : QueryCache HashSpec) (hcache : cache input = none) + (cost : HashOutput × QueryCache HashSpec → ℝ≥0∞) + (risk : FewTimeView → ℝ≥0∞) + (hon : ∀ source ∈ support ((randomOracle input).run cache), + cost source ≤ risk (hashOutputFewTimeView source.1)) : + (∑' source, Pr[= source | (randomOracle input).run cache] * cost source) ≤ + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * risk view := by + let classify : HashOutput × QueryCache HashSpec → Option FewTimeView := + fun source => some (hashOutputFewTimeView source.1) + have hbound := tsum_probOutput_mul_le_classifiedRisk + ((randomOracle input).run cache) classify risk cost + (by + intro source _ hnone + simp [classify] at hnone) + (by + intro source hsource view hview + have : hashOutputFewTimeView source.1 = view := by + simpa [classify] using hview + rw [← this] + exact hon source hsource) + refine hbound.trans ?_ + apply Finset.sum_le_sum + intro view _ + apply mul_le_mul' _ le_rfl + exact le_of_eq (calc + Pr[fun source => classify source = some view | (randomOracle input).run cache] = + Pr[fun source : HashOutput × QueryCache HashSpec => + hashOutputFewTimeView source.1 = view | (randomOracle input).run cache] := by + apply probEvent_congr' + · intro source _ + simp only [classify, Option.some.injEq] + · rfl + _ = _ := probEvent_randomOracle_fresh_view input cache hcache + (fun value => value = view)) + +theorem tsum_probOutput_signWithTargetView_fresh_mul_le_expected + (secretKey : SecretKey) (message : Message) + (initialCache : QueryCache HashSpec) + (cost : (TargetSignerResult × QueryCache HashSpec) → ℝ≥0∞) + (risk : FewTimeView → ℝ≥0∞) + (hoff : ∀ signerResult ∈ support + ((simulateQ romImpl (signWithTargetView secretKey message)).run initialCache), + freshTargetSignerView? initialCache signerResult = none → cost signerResult = 0) + (hon : ∀ signerResult ∈ support + ((simulateQ romImpl (signWithTargetView secretKey message)).run initialCache), + ∀ view, freshTargetSignerView? initialCache signerResult = some view → + cost signerResult ≤ risk view) : + (∑' signerResult, + Pr[= signerResult | + (simulateQ romImpl (signWithTargetView secretKey message)).run initialCache] * + cost signerResult) ≤ + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * risk view := by + have hbound := tsum_probOutput_mul_le_classifiedRisk + ((simulateQ romImpl (signWithTargetView secretKey message)).run initialCache) + (freshTargetSignerView? initialCache) risk cost hoff hon + refine hbound.trans ?_ + apply Finset.sum_le_sum + intro view _ + exact mul_le_mul' + (probEvent_freshTargetSignerView?_eq_some_le_uniform secretKey message initialCache view) + le_rfl + +structure OriginTargetMonitorState {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) where + origin : OriginMonitorState configuration + candidateOrdinal : Nat + candidateViews : List FewTimeView + candidateAllowed : List Bool + targetView : Option FewTimeView + valid : Bool + +noncomputable def OriginTargetMonitorState.initial + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) + (cache : QueryCache HashSpec) : OriginTargetMonitorState configuration := + ⟨OriginMonitorState.initial configuration cache, 0, [], [], none, true⟩ + +def OriginTargetMonitorState.recordCandidate + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (allowed : Bool) (view : FewTimeView) : OriginTargetMonitorState configuration := + { state with + candidateOrdinal := state.candidateOrdinal + 1 + candidateViews := state.candidateViews ++ [view] + candidateAllowed := state.candidateAllowed ++ [allowed] + targetView := if state.candidateOrdinal = targetOrdinal then some view else state.targetView + valid := if state.candidateOrdinal = targetOrdinal then state.valid && allowed else state.valid } + +def OriginTargetMonitorState.advanceOrigin + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) + (origin : OriginMonitorState configuration) : OriginTargetMonitorState configuration := + { state with origin := origin } + +noncomputable def OriginTargetMonitorState.potential + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) : ℝ≥0∞ := + if state.valid then + match state.targetView with + | some target => state.origin.potential fun views => event (views, target) + | none => ∑ target, Pr[fun value : FewTimeView => value = target | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + state.origin.potential (fun views => event (views, target)) + else 0 + +def OriginTargetMonitorState.TargetScheduleCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) : Prop := + (state.targetView = none) ↔ state.candidateOrdinal ≤ targetOrdinal + +def OriginTargetMonitorState.CandidateViewsCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) : Prop := + state.candidateOrdinal = state.candidateViews.length ∧ + state.targetView = state.candidateViews[targetOrdinal]? + +theorem OriginTargetMonitorState.candidateViewsCoherent_initial + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (cache : QueryCache HashSpec) + (targetOrdinal : Nat) : + (OriginTargetMonitorState.initial configuration cache).CandidateViewsCoherent + targetOrdinal := by + simp [OriginTargetMonitorState.CandidateViewsCoherent, + OriginTargetMonitorState.initial] + +theorem OriginTargetMonitorState.candidateViewsCoherent_advanceOrigin + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (origin : OriginMonitorState configuration) + (hcoherent : state.CandidateViewsCoherent targetOrdinal) : + (state.advanceOrigin origin).CandidateViewsCoherent targetOrdinal := hcoherent + +theorem OriginTargetMonitorState.candidateViewsCoherent_recordCandidate + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (allowed : Bool) (view : FewTimeView) + (hcoherent : state.CandidateViewsCoherent targetOrdinal) : + (state.recordCandidate targetOrdinal allowed view).CandidateViewsCoherent + targetOrdinal := by + rcases hcoherent with ⟨hcount, hview⟩ + by_cases heq : state.candidateOrdinal = targetOrdinal + · constructor + · change state.candidateOrdinal + 1 = (state.candidateViews ++ [view]).length + simpa only [List.length_append, List.length_singleton] using + congrArg (fun value => value + 1) hcount + · simp [OriginTargetMonitorState.recordCandidate, heq, ← hcount] + · constructor + · change state.candidateOrdinal + 1 = (state.candidateViews ++ [view]).length + simpa only [List.length_append, List.length_singleton] using + congrArg (fun value => value + 1) hcount + · by_cases hlt : targetOrdinal < state.candidateViews.length + · simp only [OriginTargetMonitorState.recordCandidate, heq, if_false] + rw [hview, List.getElem?_append_left hlt] + · have hgt : state.candidateViews.length < targetOrdinal := by + omega + simp only [OriginTargetMonitorState.recordCandidate, heq, if_false] + change state.targetView = (state.candidateViews ++ [view])[targetOrdinal]? + rw [hview, List.getElem?_append_right hgt.le] + simp [hlt] + omega + +def OriginTargetMonitorState.CandidateAllowedCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) : Prop := + state.candidateOrdinal = state.candidateAllowed.length ∧ + state.valid = state.candidateAllowed[targetOrdinal]?.getD true + +theorem OriginTargetMonitorState.candidateAllowedCoherent_initial + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (cache : QueryCache HashSpec) + (targetOrdinal : Nat) : + (OriginTargetMonitorState.initial configuration cache).CandidateAllowedCoherent + targetOrdinal := by + simp [OriginTargetMonitorState.CandidateAllowedCoherent, + OriginTargetMonitorState.initial] + +theorem OriginTargetMonitorState.candidateAllowedCoherent_advanceOrigin + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (origin : OriginMonitorState configuration) + (hcoherent : state.CandidateAllowedCoherent targetOrdinal) : + (state.advanceOrigin origin).CandidateAllowedCoherent targetOrdinal := hcoherent + +theorem OriginTargetMonitorState.candidateAllowedCoherent_recordCandidate + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (allowed : Bool) (view : FewTimeView) + (hcoherent : state.CandidateAllowedCoherent targetOrdinal) : + (state.recordCandidate targetOrdinal allowed view).CandidateAllowedCoherent + targetOrdinal := by + rcases hcoherent with ⟨hcount, hvalid⟩ + by_cases heq : state.candidateOrdinal = targetOrdinal + · constructor + · change state.candidateOrdinal + 1 = (state.candidateAllowed ++ [allowed]).length + simpa only [List.length_append, List.length_singleton] using + congrArg (fun value => value + 1) hcount + · have hlookup : state.candidateAllowed[targetOrdinal]? = none := by + rw [← heq, hcount] + simp + have hstateValid : state.valid = true := by + rw [hvalid, hlookup] + rfl + simp [OriginTargetMonitorState.recordCandidate, heq, ← hcount, hstateValid] + · constructor + · change state.candidateOrdinal + 1 = (state.candidateAllowed ++ [allowed]).length + simpa only [List.length_append, List.length_singleton] using + congrArg (fun value => value + 1) hcount + · by_cases hlt : targetOrdinal < state.candidateAllowed.length + · simp only [OriginTargetMonitorState.recordCandidate, heq, if_false] + rw [hvalid, List.getElem?_append_left hlt] + · have hgt : state.candidateAllowed.length < targetOrdinal := by + have hne : state.candidateAllowed.length ≠ targetOrdinal := by + omega + omega + simp only [OriginTargetMonitorState.recordCandidate, heq, if_false] + change state.valid = (state.candidateAllowed ++ [allowed])[targetOrdinal]?.getD true + rw [hvalid, List.getElem?_append_right hgt.le] + have hsub : targetOrdinal - state.candidateAllowed.length ≠ 0 := + Nat.sub_ne_zero_iff_lt.mpr hgt + simp [hlt, hsub] + +theorem OriginTargetMonitorState.targetScheduleCoherent_initial + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (cache : QueryCache HashSpec) + (targetOrdinal : Nat) : + (OriginTargetMonitorState.initial configuration cache).TargetScheduleCoherent + targetOrdinal := by + simp [OriginTargetMonitorState.TargetScheduleCoherent, + OriginTargetMonitorState.initial] + +theorem OriginTargetMonitorState.targetView_eq_none_of_candidateOrdinal_eq + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + {targetOrdinal : Nat} {state : OriginTargetMonitorState configuration} + (hcoherent : state.TargetScheduleCoherent targetOrdinal) + (heq : state.candidateOrdinal = targetOrdinal) : state.targetView = none := by + exact hcoherent.mpr heq.le + +theorem OriginTargetMonitorState.targetScheduleCoherent_advanceOrigin + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (origin : OriginMonitorState configuration) + (hcoherent : state.TargetScheduleCoherent targetOrdinal) : + (state.advanceOrigin origin).TargetScheduleCoherent targetOrdinal := hcoherent + +theorem OriginTargetMonitorState.targetScheduleCoherent_recordCandidate + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (allowed : Bool) (view : FewTimeView) + (hcoherent : state.TargetScheduleCoherent targetOrdinal) : + (state.recordCandidate targetOrdinal allowed view).TargetScheduleCoherent + targetOrdinal := by + by_cases heq : state.candidateOrdinal = targetOrdinal + · simp [OriginTargetMonitorState.TargetScheduleCoherent, + OriginTargetMonitorState.recordCandidate, heq] + · have hview : state.targetView = none ↔ state.candidateOrdinal ≤ targetOrdinal := hcoherent + simp only [OriginTargetMonitorState.TargetScheduleCoherent, + OriginTargetMonitorState.recordCandidate, heq, if_false] + constructor + · intro hnone + have hle : state.candidateOrdinal ≤ targetOrdinal := hview.mp hnone + exact Nat.add_one_le_iff.mpr (lt_of_le_of_ne hle heq) + · intro hle + apply hview.mpr + exact (Nat.le_add_right state.candidateOrdinal 1).trans hle + +theorem OriginTargetMonitorState.potential_eq_zero_of_invalid + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hinvalid : state.valid = false) : state.potential event = 0 := by + simp [OriginTargetMonitorState.potential, hinvalid] + +theorem OriginTargetMonitorState.potential_advanceOrigin + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) + (origin : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) : + (state.advanceOrigin origin).potential event = + if state.valid then + match state.targetView with + | some target => origin.potential fun views => event (views, target) + | none => ∑ target, Pr[fun value : FewTimeView => value = target | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + origin.potential (fun views => event (views, target)) + else 0 := by + rfl + +theorem OriginTargetMonitorState.potential_recordCandidate_of_ordinal_ne + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (allowed : Bool) (view : FewTimeView) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hne : state.candidateOrdinal ≠ targetOrdinal) : + (state.recordCandidate targetOrdinal allowed view).potential event = + state.potential event := by + simp [OriginTargetMonitorState.recordCandidate, OriginTargetMonitorState.potential, hne] + +theorem OriginTargetMonitorState.potential_recordCandidate_eq_of_allowed + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (view : FewTimeView) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (heq : state.candidateOrdinal = targetOrdinal) (hvalid : state.valid = true) : + (state.recordCandidate targetOrdinal true view).potential event = + state.origin.potential (fun views => event (views, view)) := by + simp [OriginTargetMonitorState.recordCandidate, OriginTargetMonitorState.potential, + heq, hvalid] + +theorem OriginTargetMonitorState.potential_recordCandidate_eq_of_disallowed + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (view : FewTimeView) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (heq : state.candidateOrdinal = targetOrdinal) : + (state.recordCandidate targetOrdinal false view).potential event = 0 := by + simp [OriginTargetMonitorState.recordCandidate, OriginTargetMonitorState.potential, heq] + +noncomputable def originTargetMonitoredAdversaryImpl + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) : + QueryImpl (OracleWorld + SigningSpec) + (StateT (OriginTargetMonitorState configuration) ProbComp) := by + intro input + cases input with + | inl worldInput => + exact fun state => do + let (output, origin) ← + ((originMonitoredAdversaryImpl configuration secretKey (.inl worldInput)).run + state.origin) + let advanced := state.advanceOrigin origin + match worldInput with + | .inl _ => pure (output, advanced) + | .inr hashInput => + if state.origin.viewed.cache hashInput = none then + pure (output, advanced.recordCandidate targetOrdinal + (decide (configuration.sourceAt? state.origin.directOrdinal = none)) + (hashOutputFewTimeView output)) + else + pure (output, advanced) + | inr request => + exact fun state => do + let (targetResult, finalCache) ← + (simulateQ romImpl (signWithTargetView secretKey request)).run + state.origin.viewed.cache + let result := targetSignerResultView targetResult + let trace := fullAdversaryTraceUpdate (.inr request) state.origin.viewed.cache result.1 + finalCache state.origin.viewed.trace + let monitored := monitorSigner secretKey request state.origin (result, finalCache) + let origin : OriginMonitorState configuration := + ⟨⟨finalCache, trace, state.origin.viewed.views ++ [result.2], + state.origin.viewed.targetView⟩, monitored.1, state.origin.directOrdinal, + state.origin.signerOrdinal + 1, monitored.2⟩ + let advanced := state.advanceOrigin origin + match targetResult.2 with + | none => pure (result.1, advanced) + | some (input, view) => + if state.origin.viewed.cache input = none then + pure (result.1, advanced.recordCandidate targetOrdinal + (decide (pattern.selectedAt? state.origin.signerOrdinal = none)) view) + else + pure (result.1, advanced) + +theorem originTargetMonitoredAdversaryImpl_query_projection + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) : + (fun result => (result.1, result.2.origin)) <$> + ((originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state) = + (originMonitoredAdversaryImpl configuration secretKey input).run state.origin := by + classical + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + rw [originTargetMonitoredAdversaryImpl] + simp only [StateT.run, map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro result + rfl + | inr hashInput => + rw [originTargetMonitoredAdversaryImpl] + simp only [StateT.run, map_eq_bind_pure_comp, bind_assoc] + by_cases hfresh : state.origin.viewed.cache hashInput = none + · simp [OriginTargetMonitorState.advanceOrigin, + OriginTargetMonitorState.recordCandidate, hfresh, Function.comp_def] + · simp [OriginTargetMonitorState.advanceOrigin, + hfresh, Function.comp_def] + | inr request => + let updateOrigin := fun + run : (Option Signature × Option FewTimeView) × QueryCache HashSpec => + let trace := fullAdversaryTraceUpdate (.inr request) state.origin.viewed.cache + run.1.1 run.2 state.origin.viewed.trace + let monitored := monitorSigner secretKey request state.origin run + (⟨⟨run.2, trace, state.origin.viewed.views ++ [run.1.2], + state.origin.viewed.targetView⟩, monitored.1, state.origin.directOrdinal, + state.origin.signerOrdinal + 1, monitored.2⟩ : OriginMonitorState configuration) + calc + _ = (fun run => (run.1.1, updateOrigin run)) <$> + ((fun run => (targetSignerResultView run.1, run.2)) <$> + (simulateQ romImpl (signWithTargetView secretKey request)).run + state.origin.viewed.cache) := by + rw [originTargetMonitoredAdversaryImpl] + simp only [StateT.run, map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro targetRun + cases hselection : targetRun.1.2 with + | none => + simp only [pure_bind] + rfl + | some selection => + rcases selection with ⟨input, view⟩ + by_cases hfresh : state.origin.viewed.cache input = none + · simp only [hfresh, if_pos, pure_bind] + rfl + · simp only [hfresh] + rfl + _ = (fun run => (run.1.1, updateOrigin run)) <$> + (simulateQ romImpl (signWithView secretKey request)).run + state.origin.viewed.cache := by + rw [simulateQ_signWithTargetView_projection_run] + _ = _ := by + rw [originMonitoredAdversaryImpl] + simp only [StateT.run, map_eq_bind_pure_comp] + rfl + +theorem originTargetMonitoredAdversaryImpl_projection + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) : + Prod.map id OriginTargetMonitorState.origin <$> + (simulateQ (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState = + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState.origin := by + apply OracleComp.map_run_simulateQ_eq_of_query_map_eq + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + (originMonitoredAdversaryImpl configuration secretKey) + OriginTargetMonitorState.origin + intro input state + exact originTargetMonitoredAdversaryImpl_query_projection configuration secretKey + targetOrdinal input state + +theorem probEvent_originTargetMonitoredAdversaryImpl_projection + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (event : α × OriginMonitorState configuration → Prop) : + Pr[event | + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState.origin] = + Pr[fun result : α × OriginTargetMonitorState configuration => + event (result.1, result.2.origin) | + (simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState] := by + rw [← originTargetMonitoredAdversaryImpl_projection configuration secretKey + targetOrdinal computation initialState, probEvent_map] + rfl + +theorem probEvent_originMonitored_le_originTargetMonitored + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (originEvent : α × OriginMonitorState configuration → Prop) + (targetEvent : α × OriginTargetMonitorState configuration → Prop) + (himp : ∀ result ∈ support + ((simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState), + originEvent (result.1, result.2.origin) → targetEvent result) : + Pr[originEvent | + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState.origin] ≤ + Pr[targetEvent | + (simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState] := by + classical + rw [probEvent_originTargetMonitoredAdversaryImpl_projection configuration secretKey + targetOrdinal computation initialState originEvent] + exact probEvent_mono himp + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetSigner.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetSigner.lean new file mode 100644 index 00000000..9bd1b8e5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetSigner.lean @@ -0,0 +1,193 @@ +import SphincsSecurity.Proof.FewTimeFresh + +/-! +# Signer selection witnesses for target monitoring + +This richer proof-only signer retains the exact selected message-digest input. Forgetting that input +recovers `signWithView`. It lets a later monitor recognize a fresh selected view even when signature +construction returns `none`. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +abbrev TargetSignerResult := Option Signature × Option (HashInput × FewTimeView) + +def targetSignerResultView (result : TargetSignerResult) : + Option Signature × Option FewTimeView := + (result.1, result.2.map Prod.snd) + +noncomputable def signWithTargetView (secretKey : SecretKey) (message : Message) : + OracleComp OracleWorld TargetSignerResult := do + match ← signDigestLoop digestAttemptLimit secretKey message with + | none => pure (none, none) + | some (randomness, index, leaves) => do + let signature ← liftM (signAfterDigest secretKey randomness index leaves) + let input := tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness) + pure (signature, some (input, selectedFewTimeView index leaves)) + +theorem signWithTargetView_projection (secretKey : SecretKey) (message : Message) : + targetSignerResultView <$> signWithTargetView secretKey message = + signWithView secretKey message := by + simp only [signWithTargetView, signWithView, map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro loopResult + cases loopResult with + | none => simp [targetSignerResultView] + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + simp [targetSignerResultView] + +theorem simulateQ_signWithTargetView_projection_run + (secretKey : SecretKey) (message : Message) (cache : QueryCache HashSpec) : + (fun result => (targetSignerResultView result.1, result.2)) <$> + (simulateQ romImpl (signWithTargetView secretKey message)).run cache = + (simulateQ romImpl (signWithView secretKey message)).run cache := by + calc + _ = (simulateQ romImpl + (targetSignerResultView <$> signWithTargetView secretKey message)).run cache := by + rw [simulateQ_map, StateT.run_map] + _ = _ := by rw [signWithTargetView_projection] + +def freshTargetSignerView? (initialCache : QueryCache HashSpec) + (result : TargetSignerResult × QueryCache HashSpec) : Option FewTimeView := + match result.1.2 with + | none => none + | some (input, view) => if initialCache input = none then some view else none + +def FreshTargetSignerView (initialCache : QueryCache HashSpec) + (secretKey : SecretKey) (message : Message) (P : FewTimeView → Prop) + (result : TargetSignerResult × QueryCache HashSpec) : Prop := + ∃ randomness index leaves, + result.1.2 = some + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness), + selectedFewTimeView index leaves) + ∧ initialCache (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = none + ∧ P (selectedFewTimeView index leaves) + +theorem freshTargetSignerView?_eq_some_iff + (initialCache : QueryCache HashSpec) (secretKey : SecretKey) (message : Message) + (result : TargetSignerResult × QueryCache HashSpec) (view : FewTimeView) + (hmem : result ∈ support + ((simulateQ romImpl (signWithTargetView secretKey message)).run initialCache)) : + freshTargetSignerView? initialCache result = some view ↔ + FreshTargetSignerView initialCache secretKey message (fun value => value = view) result := by + rw [signWithTargetView, simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hmem + obtain ⟨⟨loopResult, loopCache⟩, _, hfinish⟩ := hmem + cases loopResult with + | none => + have heq : result = ((none, none), loopCache) := by + simpa only [simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hfinish + subst result + simp [freshTargetSignerView?, FreshTargetSignerView] + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + rw [simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hfinish + obtain ⟨⟨signature, signatureCache⟩, _, hpure⟩ := hfinish + have heq : result = + ((signature, some + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness), + selectedFewTimeView index leaves)), signatureCache) := by + simpa only [simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hpure + subst result + simp only [freshTargetSignerView?, FreshTargetSignerView] + by_cases hfresh : initialCache + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = none + · constructor + · intro hclassified + have hview : selectedFewTimeView index leaves = view := by + simpa only [hfresh, if_pos, Option.some.injEq] using hclassified + exact ⟨randomness, index, leaves, rfl, hfresh, hview⟩ + · rintro ⟨foundRandomness, foundIndex, foundLeaves, hselected, hmiss, hview⟩ + have hfields := Prod.mk.inj (Option.some.inj hselected) + rw [hfresh] + exact congrArg some (hfields.2.trans hview) + · constructor + · intro hclassified + simp [hfresh] at hclassified + · rintro ⟨foundRandomness, foundIndex, foundLeaves, hselected, hmiss, _⟩ + have hinput := (Prod.mk.inj (Option.some.inj hselected)).1 + have hpayload := (tweakableHashInput_injective secretKey.parameter + (by trivial) (by trivial) hinput).2 + have hrandomness := (messageDigestPayload_injective secretKey.root hpayload).2 + rw [← hrandomness] at hmiss + exact (hfresh hmiss).elim + +set_option maxRecDepth 100000 in +theorem probEvent_signWithTargetView_fresh_le_uniform + (secretKey : SecretKey) (message : Message) + (initialCache : QueryCache HashSpec) (P : FewTimeView → Prop) : + Pr[FreshTargetSignerView initialCache secretKey message P | + (simulateQ romImpl (signWithTargetView secretKey message)).run initialCache] ≤ + Pr[P | ($ᵗ FewTimeView : ProbComp FewTimeView)] := by + rw [signWithTargetView, simulateQ_bind, StateT.run_bind] + refine (probEvent_bind_le_probEvent + (p := FreshSelectedView initialCache secretKey message P) ?_).trans + (probEvent_signDigestLoop_freshSelectedView_le_uniform digestAttemptLimit + secretKey message initialCache initialCache P + (onlyRejectedNewMessageEntries_self initialCache secretKey message)) + intro loopResult _hloop hnotFresh + cases hloopResult : loopResult.1 with + | none => + refine probEvent_eq_zero ?_ + intro result hresult hevent + have hresultEq : result = ((none, none), loopResult.2) := by + simpa only [hloopResult, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hresult + obtain ⟨randomness, index, leaves, hselected, _, _⟩ := hevent + rw [hresultEq] at hselected + simp at hselected + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + refine probEvent_eq_zero ?_ + intro result hresult hevent + rw [simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hresult + obtain ⟨⟨signature, signatureCache⟩, _, hpure⟩ := hresult + have hpureEq : result = + ((signature, some + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness), + selectedFewTimeView index leaves)), signatureCache) := by + simpa only [simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hpure + obtain ⟨foundRandomness, foundIndex, foundLeaves, hselected, hmiss, hP⟩ := hevent + have hfields := Prod.mk.inj (Option.some.inj (hselected.symm.trans + (congrArg (fun value => value.1.2) hpureEq))) + have hinput := hfields.1 + have hpayload := (tweakableHashInput_injective secretKey.parameter + (by trivial) (by trivial) hinput).2 + have hrandomness := (messageDigestPayload_injective secretKey.root hpayload).2 + have hview : selectedFewTimeView foundIndex foundLeaves = + selectedFewTimeView index leaves := hfields.2 + apply hnotFresh + refine ⟨randomness, index, leaves, hloopResult, ?_, ?_⟩ + · rw [← hrandomness] + exact hmiss + · rw [← hview] + exact hP + +theorem probEvent_freshTargetSignerView?_eq_some_le_uniform + (secretKey : SecretKey) (message : Message) + (initialCache : QueryCache HashSpec) (view : FewTimeView) : + Pr[fun result => freshTargetSignerView? initialCache result = some view | + (simulateQ romImpl (signWithTargetView secretKey message)).run initialCache] ≤ + Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] := by + calc + _ = Pr[FreshTargetSignerView initialCache secretKey message (fun value => value = view) | + (simulateQ romImpl (signWithTargetView secretKey message)).run initialCache] := by + apply probEvent_congr' + · intro result hmem + exact freshTargetSignerView?_eq_some_iff initialCache secretKey message result view hmem + · rfl + _ ≤ _ := probEvent_signWithTargetView_fresh_le_uniform secretKey message initialCache _ + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetSource.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetSource.lean new file mode 100644 index 00000000..c10f9013 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetSource.lean @@ -0,0 +1,176 @@ +import SphincsSecurity.Proof.FewTimeViewTrace +import Batteries.Data.Fin.Coding + +/-! +# Cache origin of the verifier target view + +The message-digest answer used by final verification is either fresh at verification or was first +inserted by one of the retained outer adversary intervals. In the latter case the interval is a +direct hash query at that input or a signer invocation. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +namespace Concrete + +def isTargetCandidateInterval (entry : AdversaryCacheEntry) : Prop := + match entry.input with + | .inl (.inr _) => True + | .inr _ => True + | .inl (.inl _) => False + +instance : DecidablePred isTargetCandidateInterval := fun entry => by + rcases entry with ⟨input, output, initialCache, finalCache⟩ + rcases input with worldInput | request + · rcases worldInput with uniformInput | hashInput + · exact isFalse id + · exact isTrue trivial + · exact isTrue trivial + +abbrev TargetCandidateIntervals (trace : FullAdversaryTrace) := + {position : Fin trace.intervals.length // + isTargetCandidateInterval (trace.intervals.get position)} + +def targetCandidateIntervalCount (trace : FullAdversaryTrace) : Nat := + Fin.countP fun position : Fin trace.intervals.length => + decide (isTargetCandidateInterval (trace.intervals.get position)) + +noncomputable def targetCandidateIntervalOrdinal (trace : FullAdversaryTrace) + (position : Fin trace.intervals.length) + (hcandidate : isTargetCandidateInterval (trace.intervals.get position)) : + Fin (targetCandidateIntervalCount trace) := + Fin.encodeSubtype (fun candidate => + isTargetCandidateInterval (trace.intervals.get candidate)) ⟨position, hcandidate⟩ + +def TargetCandidateAt (trace : FullAdversaryTrace) (input : HashInput) + (adversaryCache : QueryCache HashSpec) + (candidate : Fin (targetCandidateIntervalCount trace + 1)) : Prop := + (∃ (source : Fin trace.intervals.length) + (hcandidate : isTargetCandidateInterval (trace.intervals.get source)), + candidate.val = (targetCandidateIntervalOrdinal trace source hcandidate).val + ∧ (trace.intervals.get source).initialCache input = none + ∧ (trace.intervals.get source).finalCache input ≠ none) + ∨ (candidate.val = targetCandidateIntervalCount trace ∧ + adversaryCache input = none) + +theorem exists_targetCandidateAt_of_source_kind + (trace : FullAdversaryTrace) (input : HashInput) + (adversaryCache : QueryCache HashSpec) + (horigin : adversaryCache input = none ∨ + ∃ source : Fin trace.intervals.length, + (trace.intervals.get source).initialCache input = none + ∧ (trace.intervals.get source).finalCache input ≠ none + ∧ ((trace.intervals.get source).input = .inl (.inr input) + ∨ ∃ request, (trace.intervals.get source).input = .inr request)) : + ∃ candidate : Fin (targetCandidateIntervalCount trace + 1), + TargetCandidateAt trace input adversaryCache candidate := by + rcases horigin with hverifier | ⟨source, hinitial, hfinal, hkind⟩ + · exact ⟨⟨targetCandidateIntervalCount trace, Nat.lt_succ_self _⟩, + Or.inr ⟨rfl, hverifier⟩⟩ + · have hcandidate : isTargetCandidateInterval (trace.intervals.get source) := by + rcases hkind with hdirect | ⟨request, hsigner⟩ + · rw [isTargetCandidateInterval, hdirect] + trivial + · rw [isTargetCandidateInterval, hsigner] + trivial + let ordinal := targetCandidateIntervalOrdinal trace source hcandidate + exact ⟨⟨ordinal.val, Nat.lt_succ_of_lt ordinal.isLt⟩, + Or.inl ⟨source, hcandidate, rfl, hinitial, hfinal⟩⟩ + +theorem gameAfterSecretsWithViewTrace_target_source_kind + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hmem : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) : + let input := tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) + ∃ (rootCache adversaryCache digestCache : QueryCache HashSpec) (output : HashOutput), + (∀ payload, rootCache (tweakableHashInput parameter .message payload) = none) + ∧ FullAdversaryTrace.CacheChain rootCache result.2.trace.intervals adversaryCache + ∧ (output, digestCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) (oracleHash input)).run adversaryCache) + ∧ digestCache ≤ result.2.cache + ∧ result.2.targetView = some (hashOutputFewTimeView output) + ∧ (adversaryCache input = none ∨ + ∃ source : Fin result.2.trace.intervals.length, + (result.2.trace.intervals.get source).initialCache input = none + ∧ (result.2.trace.intervals.get source).finalCache input ≠ none + ∧ ((result.2.trace.intervals.get source).input = .inl (.inr input) + ∨ ∃ request, (result.2.trace.intervals.get source).input = .inr request)) + ∧ ∃ candidate : Fin (targetCandidateIntervalCount result.2.trace + 1), + TargetCandidateAt result.2.trace input adversaryCache candidate := by + rw [gameAfterSecretsWithViewTrace, mem_support_bind_iff] at hmem + obtain ⟨⟨root, rootCache⟩, hroot, hrest⟩ := hmem + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult, hrest, hpureRoot⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpureRoot + subst result + rw [gameRestWithViewTrace, mem_support_bind_iff] at hrest + obtain ⟨⟨forgery, state⟩, hadversary, hfinish⟩ := hrest + rw [mem_support_bind_iff] at hfinish + obtain ⟨⟨⟨verified, targetView⟩, finalCache⟩, hverify, hpure⟩ := hfinish + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst restResult + let publicKey : PublicKey := ⟨root, parameter⟩ + let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + let input := tweakableHashInput parameter .message + (messageDigestPayload root forgery.message forgery.signature.randomness) + have hrootRun : (root, rootCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅) := by + simpa only [simulateQ_romImpl_liftM] using hroot + have hrootNone : ∀ payload, + rootCache (tweakableHashInput parameter .message payload) = none := + fun payload => treeRoot_cache_message_none parameter topLayer rootTree + (otsSecret topLayer rootTree) root rootCache hrootRun payload + let initialState : ViewedFullTraceState := + ⟨rootCache, ⟨[], [], []⟩, [], none⟩ + have hbase : (forgery, state.base) ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState.base) := by + rw [← viewedFullTracedMappedAdversaryImpl_projection secretKey + (adversary.main publicKey) initialState, support_map] + exact ⟨(forgery, state), hadversary, rfl⟩ + have hchain : FullAdversaryTrace.CacheChain rootCache state.trace.intervals state.cache := + fullTracedMappedAdversaryImpl_cacheChain secretKey (adversary.main publicKey) + rootCache rootCache ⟨[], [], []⟩ (forgery, state.base) (by rfl) hbase + have hvalid : state.trace.ValidIntervals secretKey := + fullTracedMappedAdversaryImpl_validIntervals secretKey (adversary.main publicKey) + rootCache ⟨[], [], []⟩ (forgery, state.base) + (by simp [FullAdversaryTrace.ValidIntervals]) hbase + have hverify' : ((verified, targetView), finalCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (verifyWithView publicKey forgery.message forgery.signature)).run state.cache) := by + simpa only [simulateQ_romImpl_liftM] using hverify + obtain ⟨output, digestCache, houtput, hdigestLe, htarget⟩ := + verifyWithView_support_view publicKey forgery.message forgery.signature + state.cache finalCache verified targetView hverify' + refine ⟨rootCache, state.cache, digestCache, output, hrootNone, hchain, + ?_, hdigestLe, congrArg some htarget, ?_⟩ + · simpa only [input, publicKey] using houtput + · have horigin : state.cache input = none ∨ + ∃ source : Fin state.trace.intervals.length, + (state.trace.intervals.get source).initialCache input = none + ∧ (state.trace.intervals.get source).finalCache input ≠ none + ∧ ((state.trace.intervals.get source).input = .inl (.inr input) + ∨ ∃ request, (state.trace.intervals.get source).input = .inr request) := by + by_cases hcached : state.cache input = none + · exact Or.inl hcached + · right + obtain ⟨source, hsourceInitial, hsourceFinal⟩ := + hchain.transition_to_finish input (hrootNone _) hcached + exact ⟨source, hsourceInitial, hsourceFinal, + FullAdversaryTrace.transition_source_kind hvalid + (state.trace.intervals.get source) (List.get_mem _ source) input + hsourceInitial hsourceFinal⟩ + exact ⟨horigin, + exists_targetCandidateAt_of_source_kind state.trace input state.cache horigin⟩ + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetTerminal.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetTerminal.lean new file mode 100644 index 00000000..c228caea --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetTerminal.lean @@ -0,0 +1,4002 @@ +import SphincsSecurity.Proof.FewTimeTargetInvariant +import SphincsSecurity.Proof.FewTimeTargetView +import SphincsSecurity.Proof.FewTimeOriginLift + +/-! +# Terminal alignment for one adaptive few-time target + +The filtered chronological candidate count is exactly the ordinal consumed by the target monitor. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +namespace Concrete + +theorem originTargetMonitoredAdversaryImpl_viewed_projection + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) : + (fun result => (result.1, result.2.origin.viewed)) <$> + (simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState = + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run initialState.origin.viewed := by + calc + _ = Prod.map id OriginMonitorState.viewed <$> + (Prod.map id OriginTargetMonitorState.origin <$> + (simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState) := by + simp only [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro result + rfl + _ = Prod.map id OriginMonitorState.viewed <$> + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState.origin := by + rw [originTargetMonitoredAdversaryImpl_projection] + _ = _ := originMonitoredAdversaryImpl_projection configuration secretKey + computation initialState.origin + +theorem exists_originTargetMonitored_of_viewed_support + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (result : α × ViewedFullTraceState) + (hmem : result ∈ support + ((simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run initialState.origin.viewed)) : + ∃ monitored ∈ support + ((simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState), + monitored.1 = result.1 ∧ monitored.2.origin.viewed = result.2 := by + rw [← originTargetMonitoredAdversaryImpl_viewed_projection configuration secretKey + targetOrdinal computation initialState, support_map] at hmem + obtain ⟨monitored, hmonitored, heq⟩ := hmem + refine ⟨monitored, hmonitored, ?_⟩ + exact Prod.mk.inj heq + +theorem probEvent_viewed_le_originTargetMonitoredAdversaryImpl + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (viewedEvent : α × ViewedFullTraceState → Prop) + (monitoredEvent : α × OriginTargetMonitorState configuration → Prop) + (himp : ∀ result ∈ support + ((simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState), + viewedEvent (result.1, result.2.origin.viewed) → monitoredEvent result) : + Pr[viewedEvent | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run initialState.origin.viewed] ≤ + Pr[monitoredEvent | + (simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState] := by + classical + rw [← originTargetMonitoredAdversaryImpl_viewed_projection configuration secretKey + targetOrdinal computation initialState, probEvent_map] + exact probEvent_mono himp + +theorem gameAfterSecretsWithViewTrace_support_adversary_state + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hmem : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) : + ∃ (rootCache : QueryCache HashSpec) (state : ViewedFullTraceState), + (result.1.1, rootCache) ∈ support + ((simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅) + ∧ (result.1.2.1, state) ∈ support + ((simulateQ + (viewedFullTracedMappedAdversaryImpl + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩) + (adversary.main ⟨result.1.1, parameter⟩)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩) + ∧ result.2.trace = state.trace + ∧ result.2.views = state.views + ∧ state.cache ≤ result.2.cache := by + rw [gameAfterSecretsWithViewTrace, mem_support_bind_iff] at hmem + obtain ⟨⟨root, rootCache⟩, hroot, hrest⟩ := hmem + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult, hrest, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + rw [gameRestWithViewTrace, mem_support_bind_iff] at hrest + obtain ⟨⟨forgery, state⟩, hadversary, hfinish⟩ := hrest + rw [mem_support_bind_iff] at hfinish + obtain ⟨⟨⟨verified, targetView⟩, finalCache⟩, hverify, hpure⟩ := hfinish + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst restResult + refine ⟨rootCache, state, hroot, hadversary, rfl, rfl, ?_⟩ + exact simulateQ_romImpl_cache_le + (liftM (verifyWithView (⟨root, parameter⟩ : PublicKey) + forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView)) + state.cache ((verified, targetView), finalCache) hverify + +theorem gameAfterSecretsWithViewTrace_support_target_monitored_state + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) + (targetOrdinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hmem : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) : + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + ∃ (rootCache : QueryCache HashSpec) + (monitored : Forgery × OriginTargetMonitorState configuration), + (result.1.1, rootCache) ∈ support + ((simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅) + ∧ monitored ∈ support + ((simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + (adversary.main ⟨result.1.1, parameter⟩)).run + (OriginTargetMonitorState.initial configuration rootCache)) + ∧ monitored.1 = result.1.2.1 + ∧ result.2.trace = monitored.2.origin.viewed.trace + ∧ result.2.views = monitored.2.origin.viewed.views + ∧ monitored.2.origin.viewed.cache ≤ result.2.cache := by + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + obtain ⟨rootCache, state, hroot, hadversary, htrace, hviews, hcache⟩ := + gameAfterSecretsWithViewTrace_support_adversary_state adversary parameter otsSecret + ftsSecret result hmem + have hadversary' : (result.1.2.1, state) ∈ support + ((simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversary.main ⟨result.1.1, parameter⟩)).run + (OriginTargetMonitorState.initial configuration rootCache).origin.viewed) := by + simpa only [secretKey, OriginTargetMonitorState.initial, + OriginMonitorState.initial] using hadversary + obtain ⟨monitored, hmonitored, hforgery, hstate⟩ := + exists_originTargetMonitored_of_viewed_support configuration secretKey targetOrdinal + (adversary.main ⟨result.1.1, parameter⟩) + (OriginTargetMonitorState.initial configuration rootCache) + (result.1.2.1, state) hadversary' + refine ⟨rootCache, monitored, hroot, hmonitored, hforgery, ?_, ?_, ?_⟩ + · rw [hstate] + exact htrace + · rw [hstate] + exact hviews + · rw [hstate] + exact hcache + +theorem freshTargetCandidate_uniform_false + (secretKey : SecretKey) (input : unifSpec.Domain) + (output : unifSpec.Range input) (initialCache finalCache : QueryCache HashSpec) : + ¬FreshTargetCandidate secretKey + ⟨.inl (.inl input), output, initialCache, finalCache⟩ := by + rintro ⟨candidateInput, candidateOutput, hkind, _, _⟩ + rcases hkind with hdirect | ⟨request, randomness, hrequest, _⟩ <;> simp at * + +theorem freshTargetCandidate_direct_iff + (secretKey : SecretKey) (input : HashInput) (output : HashOutput) + (initialCache finalCache : QueryCache HashSpec) + (hmem : (output, finalCache) ∈ support ((randomOracle input).run initialCache)) : + FreshTargetCandidate secretKey + ⟨.inl (.inr input), output, initialCache, finalCache⟩ ↔ + initialCache input = none := by + constructor + · rintro ⟨candidateInput, candidateOutput, hkind, hinitial, _⟩ + rcases hkind with hdirect | ⟨request, randomness, hrequest, _⟩ + · have hworld : Sum.inr input = Sum.inr candidateInput := Sum.inl.inj hdirect + have hinput : candidateInput = input := (Sum.inr.inj hworld).symm + rwa [hinput] at hinitial + · simp at hrequest + · intro hinitial + refine ⟨input, output, Or.inl rfl, hinitial, ?_⟩ + exact randomOracle_run_output_cached input initialCache finalCache output hmem + +set_option linter.constructorNameAsVariable false in +theorem freshTargetCandidate_signer_iff + (secretKey : SecretKey) (request : SignRequest) + (initialCache : QueryCache HashSpec) + (targetRun : TargetSignerResult × QueryCache HashSpec) + (hmem : targetRun ∈ support + ((simulateQ romImpl (signWithTargetView secretKey request)).run initialCache)) : + FreshTargetCandidate secretKey + ⟨.inr request, targetRun.1.1, initialCache, targetRun.2⟩ ↔ + ∃ input view, targetRun.1.2 = some (input, view) ∧ initialCache input = none := by + rw [signWithTargetView, simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hmem + obtain ⟨⟨loopResult, loopCache⟩, hloop, hfinish⟩ := hmem + cases hloopResult : loopResult with + | none => + have htargetRun : targetRun = ((none, none), loopCache) := by + simpa only [hloopResult, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hfinish + subst targetRun + constructor + · rintro ⟨input, output, hkind, hinitial, hfinal⟩ + rcases hkind with hdirect | ⟨sourceRequest, randomness, hrequest, hinput, + hadmissible⟩ + · simp at hdirect + · have hrequestEq : request = sourceRequest := by injection hrequest + subst sourceRequest + obtain ⟨indexLeaves, hindexLeaves⟩ := Option.ne_none_iff_exists'.mp hadmissible + rcases indexLeaves with ⟨index, leaves⟩ + obtain ⟨_, _, _, _, hselected⟩ := + signDigestLoop_successful_source_is_selected digestAttemptLimit secretKey request + initialCache loopCache loopResult hloop + (messageDigestPayload secretKey.root request randomness) output index leaves + (by rw [← hinput]; exact hinitial) + (by rw [← hinput]; exact hfinal) hindexLeaves + rw [hloopResult] at hselected + simp at hselected + · rintro ⟨input, view, hselection, _⟩ + simp at hselection + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + rw [hloopResult] at hfinish + rw [simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hfinish + obtain ⟨⟨signature, signatureCache⟩, hsignature, hpure⟩ := hfinish + have htargetRun : targetRun = + ((signature, some + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root request randomness), + selectedFewTimeView index leaves)), signatureCache) := by + simpa only [simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff] using hpure + subst targetRun + let selectedInput := tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root request randomness) + constructor + · rintro ⟨input, output, hkind, hinitial, hfinal⟩ + change initialCache input = none at hinitial + change signatureCache input = some output at hfinal + rcases hkind with hdirect | ⟨sourceRequest, sourceRandomness, hrequest, hinput, + hadmissible⟩ + · simp at hdirect + · have hrequestEq : request = sourceRequest := by injection hrequest + subst sourceRequest + have hsignature' : (signature, signatureCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest secretKey randomness index leaves)).run loopCache) := by + simpa only [simulateQ_romImpl_liftM] using hsignature + have hloopCached : loopCache input ≠ none := by + intro hnone + have hsignatureNone := signAfterDigest_cache_message_none secretKey randomness + index leaves loopCache signatureCache signature hsignature' + (messageDigestPayload secretKey.root request sourceRandomness) + (by rw [← hinput]; exact hnone) + rw [hinput] at hfinal + rw [hfinal] at hsignatureNone + simp at hsignatureNone + obtain ⟨loopOutput, hloopOutput⟩ := Option.ne_none_iff_exists'.mp hloopCached + have hloopLe := simulateQ_romImpl_cache_le + (liftM (signAfterDigest secretKey randomness index leaves) : + OracleComp OracleWorld (Option Signature)) loopCache + (signature, signatureCache) (by simpa only [simulateQ_romImpl_liftM] using hsignature) + have houtputEq : loopOutput = output := by + have hcached := hloopLe hloopOutput + change signatureCache input = some loopOutput at hcached + rw [hfinal] at hcached + exact (Option.some.inj hcached).symm + obtain ⟨indexLeaves, hindexLeaves⟩ := Option.ne_none_iff_exists'.mp hadmissible + rcases indexLeaves with ⟨sourceIndex, sourceLeaves⟩ + have hloopOutput' : loopCache input = some output := by + simpa only [houtputEq] using hloopOutput + obtain ⟨_, selectedRandomness, _, hpayload, hselected⟩ := + signDigestLoop_successful_source_is_selected digestAttemptLimit secretKey request + initialCache loopCache loopResult hloop + (messageDigestPayload secretKey.root request sourceRandomness) output + sourceIndex sourceLeaves (by rw [← hinput]; exact hinitial) + (by rw [← hinput]; exact hloopOutput') hindexLeaves + have hfields := Prod.mk.inj (Option.some.inj (hloopResult.symm.trans hselected)) + have hrandomness : randomness = selectedRandomness := hfields.1 + refine ⟨selectedInput, selectedFewTimeView index leaves, rfl, ?_⟩ + change initialCache (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root request randomness)) = none + rw [hrandomness, ← hpayload, ← hinput] + exact hinitial + · rintro ⟨input, view, hselection, hinitial⟩ + have hfields := Prod.mk.inj (Option.some.inj hselection) + rw [← hfields.1] at hinitial + obtain ⟨_, _, attemptCache, output, hattemptMiss, hattemptOutput, hloopCache⟩ := + signDigestLoop_fresh_selected_attempt digestAttemptLimit secretKey request + randomness index leaves initialCache loopCache hinitial + (by simpa only [hloopResult] using hloop) + have hloopCached : loopCache selectedInput = some output := by + rw [hloopCache] + simp [selectedInput] + have hsignatureLe := simulateQ_romImpl_cache_le + (liftM (signAfterDigest secretKey randomness index leaves) : + OracleComp OracleWorld (Option Signature)) loopCache + (signature, signatureCache) (by simpa only [simulateQ_romImpl_liftM] using hsignature) + refine ⟨selectedInput, output, Or.inr ⟨request, randomness, rfl, rfl, ?_⟩, + hinitial, hsignatureLe hloopCached⟩ + rw [hattemptOutput] + simp + +def OriginTargetMonitorState.CandidateCountCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (state : OriginTargetMonitorState configuration) : Prop := + state.candidateOrdinal = freshTargetCandidateCount secretKey state.origin.viewed.trace + +theorem OriginTargetMonitorState.candidateCountCoherent_initial + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (cache : QueryCache HashSpec) : + (OriginTargetMonitorState.initial configuration cache).CandidateCountCoherent + secretKey := by + rfl + +theorem originTargetMonitoredAdversaryImpl_query_candidateCountCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) + (result : (OracleWorld + SigningSpec).Range input × + OriginTargetMonitorState configuration) + (hcoherent : state.CandidateCountCoherent secretKey) + (hmem : result ∈ support + ((originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state)) : result.2.CandidateCountCoherent secretKey := by + classical + change state.candidateOrdinal = + freshTargetCandidateCount secretKey state.origin.viewed.trace at hcoherent + cases input with + | inl worldInput => + rw [originTargetMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, origin⟩, horiginMem, hpure⟩ := hmem + rw [originMonitoredAdversaryImpl] at horiginMem + simp only [StateT.run, mem_support_bind_iff] at horiginMem + obtain ⟨⟨originOutput, finalCache⟩, hquery, horiginPure⟩ := horiginMem + cases worldInput with + | inl uniformInput => + simp only [support_pure, Set.mem_singleton_iff] at horiginPure hpure + obtain ⟨rfl, rfl⟩ := Prod.mk.inj horiginPure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + simp only [OriginTargetMonitorState.advanceOrigin] + rw [OriginTargetMonitorState.CandidateCountCoherent, + freshTargetCandidateCount_update] + rw [if_neg (freshTargetCandidate_uniform_false secretKey uniformInput output + state.origin.viewed.cache finalCache)] + exact hcoherent + | inr hashInput => + simp only [support_pure, Set.mem_singleton_iff] at horiginPure + obtain ⟨rfl, rfl⟩ := Prod.mk.inj horiginPure + have hquery' : (output, finalCache) ∈ + support ((randomOracle hashInput).run state.origin.viewed.cache) := by + exact hquery + by_cases hfresh : state.origin.viewed.cache hashInput = none + · simp only [hfresh, if_true, support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + simp only [OriginTargetMonitorState.advanceOrigin, + OriginTargetMonitorState.recordCandidate] + rw [OriginTargetMonitorState.CandidateCountCoherent, + freshTargetCandidateCount_update] + rw [if_pos ((freshTargetCandidate_direct_iff secretKey hashInput output + state.origin.viewed.cache finalCache hquery').mpr hfresh)] + change state.candidateOrdinal + 1 = + freshTargetCandidateCount secretKey state.origin.viewed.trace + 1 + rw [hcoherent] + · simp only [hfresh, if_false, support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + simp only [OriginTargetMonitorState.advanceOrigin] + rw [OriginTargetMonitorState.CandidateCountCoherent, + freshTargetCandidateCount_update] + rw [if_neg (fun hcandidate => hfresh + ((freshTargetCandidate_direct_iff secretKey hashInput output + state.origin.viewed.cache finalCache hquery').mp hcandidate))] + exact hcoherent + + | inr request => + rw [originTargetMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨targetRun, htargetRun, hpure⟩ := hmem + have hcand := freshTargetCandidate_signer_iff secretKey request + state.origin.viewed.cache targetRun htargetRun + cases hselection : targetRun.1.2 with + | none => + simp only [hselection, support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + simp only [OriginTargetMonitorState.advanceOrigin] + simp only [targetSignerResultView] + rw [OriginTargetMonitorState.CandidateCountCoherent, + freshTargetCandidateCount_update] + rw [if_neg (fun hcandidate => by + obtain ⟨input, view, hsome, _⟩ := hcand.mp hcandidate + rw [hselection] at hsome + simp at hsome)] + exact hcoherent + | some selection => + rcases selection with ⟨selectedInput, view⟩ + by_cases hfresh : state.origin.viewed.cache selectedInput = none + · simp only [hselection, hfresh, if_true, support_pure, + Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + simp only [OriginTargetMonitorState.advanceOrigin, + OriginTargetMonitorState.recordCandidate] + simp only [targetSignerResultView] + rw [OriginTargetMonitorState.CandidateCountCoherent, + freshTargetCandidateCount_update] + rw [if_pos (hcand.mpr ⟨selectedInput, view, hselection, hfresh⟩)] + change state.candidateOrdinal + 1 = + freshTargetCandidateCount secretKey state.origin.viewed.trace + 1 + rw [hcoherent] + · simp only [hselection, hfresh, if_false, support_pure, + Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + simp only [OriginTargetMonitorState.advanceOrigin] + simp only [targetSignerResultView] + rw [OriginTargetMonitorState.CandidateCountCoherent, + freshTargetCandidateCount_update] + rw [if_neg (fun hcandidate => by + obtain ⟨input, foundView, hsome, hmiss⟩ := hcand.mp hcandidate + have hfields := Prod.mk.inj (Option.some.inj (hselection.symm.trans hsome)) + apply hfresh + rw [hfields.1] + exact hmiss)] + exact hcoherent + +theorem originTargetMonitoredAdversaryImpl_candidateCountCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (result : α × OriginTargetMonitorState configuration) + (hcoherent : initialState.CandidateCountCoherent secretKey) + (hmem : result ∈ support + ((simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState)) : result.2.CandidateCountCoherent secretKey := by + exact OracleComp.simulateQ_run_preservesInv + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + (OriginTargetMonitorState.CandidateCountCoherent secretKey) + (by + intro input state hstate queryResult hquery + exact originTargetMonitoredAdversaryImpl_query_candidateCountCoherent + configuration secretKey targetOrdinal input state queryResult hstate hquery) + computation initialState hcoherent result hmem + +theorem originTargetMonitoredAdversaryImpl_query_candidateViewsCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) + (result : (OracleWorld + SigningSpec).Range input × + OriginTargetMonitorState configuration) + (hcoherent : state.CandidateViewsCoherent targetOrdinal) + (hmem : result ∈ support + ((originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state)) : result.2.CandidateViewsCoherent targetOrdinal := by + classical + cases input with + | inl worldInput => + rw [originTargetMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, origin⟩, _, hpure⟩ := hmem + cases worldInput with + | inl uniformInput => + simp only [support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + exact state.candidateViewsCoherent_advanceOrigin targetOrdinal origin hcoherent + | inr hashInput => + by_cases hfresh : state.origin.viewed.cache hashInput = none + · simp only [hfresh, if_true, support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + exact OriginTargetMonitorState.candidateViewsCoherent_recordCandidate + targetOrdinal (state.advanceOrigin origin) _ _ + (state.candidateViewsCoherent_advanceOrigin targetOrdinal origin hcoherent) + · simp only [hfresh, if_false, support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + exact state.candidateViewsCoherent_advanceOrigin targetOrdinal origin hcoherent + | inr request => + rw [originTargetMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨targetRun, _, hpure⟩ := hmem + cases hselection : targetRun.1.2 with + | none => + simp only [hselection, support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + exact state.candidateViewsCoherent_advanceOrigin targetOrdinal _ hcoherent + | some selection => + rcases selection with ⟨selectedInput, view⟩ + by_cases hfresh : state.origin.viewed.cache selectedInput = none + · simp only [hselection, hfresh, if_true, support_pure, + Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + exact OriginTargetMonitorState.candidateViewsCoherent_recordCandidate + targetOrdinal _ _ _ + (state.candidateViewsCoherent_advanceOrigin targetOrdinal _ hcoherent) + · simp only [hselection, hfresh, if_false, support_pure, + Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + exact state.candidateViewsCoherent_advanceOrigin targetOrdinal _ hcoherent + +theorem originTargetMonitoredAdversaryImpl_candidateViewsCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (result : α × OriginTargetMonitorState configuration) + (hcoherent : initialState.CandidateViewsCoherent targetOrdinal) + (hmem : result ∈ support + ((simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState)) : result.2.CandidateViewsCoherent targetOrdinal := by + exact OracleComp.simulateQ_run_preservesInv + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + (OriginTargetMonitorState.CandidateViewsCoherent targetOrdinal) + (by + intro input state hstate queryResult hquery + exact originTargetMonitoredAdversaryImpl_query_candidateViewsCoherent + configuration secretKey targetOrdinal input state queryResult hstate hquery) + computation initialState hcoherent result hmem + +theorem originTargetMonitoredAdversaryImpl_query_candidateAllowedCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) + (result : (OracleWorld + SigningSpec).Range input × + OriginTargetMonitorState configuration) + (hcoherent : state.CandidateAllowedCoherent targetOrdinal) + (hmem : result ∈ support + ((originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state)) : result.2.CandidateAllowedCoherent targetOrdinal := by + classical + cases input with + | inl worldInput => + rw [originTargetMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, origin⟩, _, hpure⟩ := hmem + cases worldInput with + | inl uniformInput => + simp only [support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + exact state.candidateAllowedCoherent_advanceOrigin targetOrdinal origin hcoherent + | inr hashInput => + by_cases hfresh : state.origin.viewed.cache hashInput = none + · simp only [hfresh, if_true, support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + exact OriginTargetMonitorState.candidateAllowedCoherent_recordCandidate + targetOrdinal (state.advanceOrigin origin) _ _ + (state.candidateAllowedCoherent_advanceOrigin targetOrdinal origin hcoherent) + · simp only [hfresh, if_false, support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + exact state.candidateAllowedCoherent_advanceOrigin targetOrdinal origin hcoherent + | inr request => + rw [originTargetMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨targetRun, _, hpure⟩ := hmem + cases hselection : targetRun.1.2 with + | none => + simp only [hselection, support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + exact state.candidateAllowedCoherent_advanceOrigin targetOrdinal _ hcoherent + | some selection => + rcases selection with ⟨selectedInput, view⟩ + by_cases hfresh : state.origin.viewed.cache selectedInput = none + · simp only [hselection, hfresh, if_true, support_pure, + Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + exact OriginTargetMonitorState.candidateAllowedCoherent_recordCandidate + targetOrdinal _ _ _ + (state.candidateAllowedCoherent_advanceOrigin targetOrdinal _ hcoherent) + · simp only [hselection, hfresh, if_false, support_pure, + Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + exact state.candidateAllowedCoherent_advanceOrigin targetOrdinal _ hcoherent + +theorem originTargetMonitoredAdversaryImpl_candidateAllowedCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (result : α × OriginTargetMonitorState configuration) + (hcoherent : initialState.CandidateAllowedCoherent targetOrdinal) + (hmem : result ∈ support + ((simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState)) : result.2.CandidateAllowedCoherent targetOrdinal := by + exact OracleComp.simulateQ_run_preservesInv + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + (OriginTargetMonitorState.CandidateAllowedCoherent targetOrdinal) + (by + intro input state hstate queryResult hquery + exact originTargetMonitoredAdversaryImpl_query_candidateAllowedCoherent + configuration secretKey targetOrdinal input state queryResult hstate hquery) + computation initialState hcoherent result hmem + +def appendTargetViewedState + (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (finalCache : QueryCache HashSpec) (view : Option FewTimeView) + (state : ViewedFullTraceState) : ViewedFullTraceState := + let entry : AdversaryCacheEntry := ⟨input, output, initialCache, finalCache⟩ + ⟨finalCache, fullAdversaryTraceUpdate input initialCache output finalCache state.trace, + appendOriginReplayView entry state.views view, state.targetView⟩ + +theorem targetCandidateIntervalView_appendTargetViewedState_old + (secretKey : SecretKey) (state : ViewedFullTraceState) + (hvalid : state.ValidViews secretKey) (hconsistent : state.trace.Consistent) + (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (finalCache : QueryCache HashSpec) (view : Option FewTimeView) + (position : Fin state.trace.intervals.length) : + targetCandidateIntervalView + (appendTargetViewedState input initialCache output finalCache view state) + ⟨position.val, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ = + targetCandidateIntervalView state position := by + let oldEntry := state.trace.intervals.get position + have hentry : state.trace.intervals.get position = oldEntry := rfl + rcases oldEntry with ⟨entryInput, entryOutput, entryInitial, entryFinal⟩ + have hentryElem : state.trace.intervals[position.val] = + ⟨entryInput, entryOutput, entryInitial, entryFinal⟩ := by + simpa only [List.get_eq_getElem] using hentry + cases entryInput with + | inl worldInput => + cases worldInput <;> + simp [targetCandidateIntervalView, appendTargetViewedState, + fullAdversaryTraceUpdate, List.getElem_append_left position.isLt, hentryElem] + | inr request => + obtain ⟨_, viewPosition, _, hviewRank, _, _⟩ := + ViewedFullTraceState.ValidViews.signer_interval hvalid hconsistent position request + entryOutput entryInitial entryFinal hentry + have hrankLt : signerIntervalCount + (state.trace.intervals.take position.val) < state.views.length := by + rw [← hviewRank] + exact viewPosition.isLt + have htake (newInput : (OracleWorld + SigningSpec).Domain) + (newOutput : (OracleWorld + SigningSpec).Range newInput) : + (state.trace.intervals ++ + [(⟨newInput, newOutput, initialCache, finalCache⟩ : + AdversaryCacheEntry)]).take position.val = + state.trace.intervals.take position.val := by + rw [List.take_append_of_le_length] + exact position.isLt.le + cases input with + | inl worldInput => + cases worldInput <;> + simp [targetCandidateIntervalView, appendTargetViewedState, + appendOriginReplayView, fullAdversaryTraceUpdate, + List.getElem_append_left position.isLt, hentryElem, htake] + | inr newRequest => + simp only [targetCandidateIntervalView, appendTargetViewedState, + appendOriginReplayView, fullAdversaryTraceUpdate] + simp only [List.get_eq_getElem] + rw [List.getElem_append_left position.isLt, hentryElem, + htake (.inr newRequest) output] + rw [List.getElem?_append_left hrankLt] + +theorem targetCandidateIntervalView_appendTargetViewedState_last + (secretKey : SecretKey) (state : ViewedFullTraceState) + (hvalid : state.ValidViews secretKey) (hconsistent : state.trace.Consistent) + (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (finalCache : QueryCache HashSpec) (view : Option FewTimeView) : + targetCandidateIntervalView + (appendTargetViewedState input initialCache output finalCache view state) + ⟨state.trace.intervals.length, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ = + match input with + | .inl (.inl _) => default + | .inl (.inr _) => hashOutputFewTimeView output + | .inr _ => view.getD default := by + have hrank : signerIntervalCount state.trace.intervals = state.views.length := by + calc + signerIntervalCount state.trace.intervals = state.trace.signing.length := by + exact congrArg List.length hconsistent.2 + _ = state.views.length := hvalid.length_eq + cases input with + | inl worldInput => + cases worldInput <;> + simp [targetCandidateIntervalView, appendTargetViewedState, + fullAdversaryTraceUpdate] + | inr request => + simp [targetCandidateIntervalView, appendTargetViewedState, + appendOriginReplayView, fullAdversaryTraceUpdate, hrank] + +noncomputable def targetCandidateIntervalAllowed + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) + (state : ViewedFullTraceState) + (position : Fin state.trace.intervals.length) : Bool := + match (state.trace.intervals.get position).input with + | .inl (.inl _) => true + | .inl (.inr _) => decide (configuration.sourceAt? + (directIntervalCount (state.trace.intervals.take position.val)) = none) + | .inr _ => decide (pattern.selectedAt? + (signerIntervalCount (state.trace.intervals.take position.val)) = none) + +theorem targetCandidateIntervalAllowed_appendTargetViewedState_old + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) + (state : ViewedFullTraceState) + (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (finalCache : QueryCache HashSpec) (view : Option FewTimeView) + (position : Fin state.trace.intervals.length) : + targetCandidateIntervalAllowed configuration + (appendTargetViewedState input initialCache output finalCache view state) + ⟨position.val, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ = + targetCandidateIntervalAllowed configuration state position := by + have hentry : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals.get + ⟨position.val, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ = + state.trace.intervals.get position := by + have hget : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals[ + position.val]? = state.trace.intervals[position.val]? := by + simp [appendTargetViewedState, fullAdversaryTraceUpdate] + rw [List.getElem?_eq_getElem (by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]), + List.getElem?_eq_getElem position.isLt] at hget + exact Option.some.inj hget + have htake : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals.take + position.val = state.trace.intervals.take position.val := by + change (state.trace.intervals ++ + [(⟨input, output, initialCache, finalCache⟩ : AdversaryCacheEntry)]).take position.val = + state.trace.intervals.take position.val + rw [List.take_append_of_le_length position.isLt.le] + simp only [targetCandidateIntervalAllowed] + rw [hentry, htake] + +theorem targetCandidateIntervalAllowed_appendTargetViewedState_last + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) + (state : ViewedFullTraceState) + (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (finalCache : QueryCache HashSpec) (view : Option FewTimeView) : + targetCandidateIntervalAllowed configuration + (appendTargetViewedState input initialCache output finalCache view state) + ⟨state.trace.intervals.length, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ = + match input with + | .inl (.inl _) => true + | .inl (.inr _) => decide (configuration.sourceAt? + (directIntervalCount state.trace.intervals) = none) + | .inr _ => decide (pattern.selectedAt? + (signerIntervalCount state.trace.intervals) = none) := by + cases input with + | inl worldInput => + cases worldInput <;> + simp [targetCandidateIntervalAllowed, appendTargetViewedState, + fullAdversaryTraceUpdate] + | inr request => + simp [targetCandidateIntervalAllowed, appendTargetViewedState, + fullAdversaryTraceUpdate] + +def CandidateViewsCover (secretKey : SecretKey) (state : ViewedFullTraceState) + (candidateViews : List FewTimeView) : Prop := + ∀ position, FreshTargetCandidate secretKey (state.trace.intervals.get position) → + targetCandidateIntervalView state position ∈ candidateViews + +theorem candidateViewsCover_nil (secretKey : SecretKey) (cache : QueryCache HashSpec) : + CandidateViewsCover secretKey ⟨cache, ⟨[], [], []⟩, [], none⟩ [] := by + intro position + exact Fin.elim0 position + +theorem candidateViewsCover_append_candidate + (secretKey : SecretKey) (state : ViewedFullTraceState) + (hvalid : state.ValidViews secretKey) (hconsistent : state.trace.Consistent) + (candidateViews : List FewTimeView) + (hcover : CandidateViewsCover secretKey state candidateViews) + (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (finalCache : QueryCache HashSpec) (view : Option FewTimeView) + (retained : FewTimeView) + (hlast : targetCandidateIntervalView + (appendTargetViewedState input initialCache output finalCache view state) + ⟨state.trace.intervals.length, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ = retained) : + CandidateViewsCover secretKey + (appendTargetViewedState input initialCache output finalCache view state) + (candidateViews ++ [retained]) := by + intro position hcandidate + by_cases hold : position.val < state.trace.intervals.length + · let oldPosition : Fin state.trace.intervals.length := ⟨position.val, hold⟩ + have hposition : position = ⟨oldPosition.val, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ := Fin.ext rfl + have hentry : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals.get + position = state.trace.intervals.get oldPosition := by + have hget : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals[ + position.val]? = state.trace.intervals[position.val]? := by + simp [appendTargetViewedState, fullAdversaryTraceUpdate, + List.getElem?_append_left hold] + rw [List.getElem?_eq_getElem position.isLt, + List.getElem?_eq_getElem hold] at hget + exact Option.some.inj hget + have holdCandidate : FreshTargetCandidate secretKey + (state.trace.intervals.get oldPosition) := by + rw [← hentry] + exact hcandidate + have holdView := hcover oldPosition holdCandidate + rw [hposition, targetCandidateIntervalView_appendTargetViewedState_old + secretKey state hvalid hconsistent input initialCache output finalCache view oldPosition] + exact List.mem_append_left _ holdView + · have hlastValue : position.val = state.trace.intervals.length := by + have hlt : position.val < state.trace.intervals.length + 1 := by + simpa [appendTargetViewedState, fullAdversaryTraceUpdate] using position.isLt + omega + have hposition : position = ⟨state.trace.intervals.length, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ := Fin.ext hlastValue + rw [hposition, hlast] + simp + +theorem candidateViewsCover_append_noncandidate + (secretKey : SecretKey) (state : ViewedFullTraceState) + (hvalid : state.ValidViews secretKey) (hconsistent : state.trace.Consistent) + (candidateViews : List FewTimeView) + (hcover : CandidateViewsCover secretKey state candidateViews) + (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (finalCache : QueryCache HashSpec) (view : Option FewTimeView) + (hnon : ¬ FreshTargetCandidate secretKey + ⟨input, output, initialCache, finalCache⟩) : + CandidateViewsCover secretKey + (appendTargetViewedState input initialCache output finalCache view state) + candidateViews := by + intro position hcandidate + by_cases hold : position.val < state.trace.intervals.length + · let oldPosition : Fin state.trace.intervals.length := ⟨position.val, hold⟩ + have hposition : position = ⟨oldPosition.val, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ := Fin.ext rfl + have hentry : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals.get + position = state.trace.intervals.get oldPosition := by + have hget : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals[ + position.val]? = state.trace.intervals[position.val]? := by + simp [appendTargetViewedState, fullAdversaryTraceUpdate, + List.getElem?_append_left hold] + rw [List.getElem?_eq_getElem position.isLt, + List.getElem?_eq_getElem hold] at hget + exact Option.some.inj hget + have holdCandidate : FreshTargetCandidate secretKey + (state.trace.intervals.get oldPosition) := by + rw [← hentry] + exact hcandidate + have holdView := hcover oldPosition holdCandidate + rw [hposition, targetCandidateIntervalView_appendTargetViewedState_old + secretKey state hvalid hconsistent input initialCache output finalCache view oldPosition] + exact holdView + · have hlastValue : position.val = state.trace.intervals.length := by + have hlt : position.val < state.trace.intervals.length + 1 := by + simpa [appendTargetViewedState, fullAdversaryTraceUpdate] using position.isLt + omega + have hposition : position = ⟨state.trace.intervals.length, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ := Fin.ext hlastValue + exfalso + apply hnon + simpa [hposition, appendTargetViewedState, fullAdversaryTraceUpdate] using hcandidate + +def CandidateViewsExact (secretKey : SecretKey) (state : ViewedFullTraceState) + (candidateViews : List FewTimeView) : Prop := + CandidateViewsCover secretKey state candidateViews ∧ + candidateViews.length = freshTargetCandidateCount secretKey state.trace ∧ + ∀ position, FreshTargetCandidate secretKey (state.trace.intervals.get position) → + candidateViews[state.trace.intervals.countPBefore + (fun entry => decide (FreshTargetCandidate secretKey entry)) position.val]? = + some (targetCandidateIntervalView state position) + +theorem candidateViewsExact_nil (secretKey : SecretKey) (cache : QueryCache HashSpec) : + CandidateViewsExact secretKey ⟨cache, ⟨[], [], []⟩, [], none⟩ [] := by + refine ⟨candidateViewsCover_nil secretKey cache, rfl, ?_⟩ + intro position + exact Fin.elim0 position + +theorem candidateViewsExact_append_candidate + (secretKey : SecretKey) (state : ViewedFullTraceState) + (hvalid : state.ValidViews secretKey) (hconsistent : state.trace.Consistent) + (candidateViews : List FewTimeView) + (hexact : CandidateViewsExact secretKey state candidateViews) + (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (finalCache : QueryCache HashSpec) (view : Option FewTimeView) + (retained : FewTimeView) + (hcandidate : FreshTargetCandidate secretKey + ⟨input, output, initialCache, finalCache⟩) + (hlast : targetCandidateIntervalView + (appendTargetViewedState input initialCache output finalCache view state) + ⟨state.trace.intervals.length, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ = retained) : + CandidateViewsExact secretKey + (appendTargetViewedState input initialCache output finalCache view state) + (candidateViews ++ [retained]) := by + refine ⟨candidateViewsCover_append_candidate secretKey state hvalid hconsistent + candidateViews hexact.1 input initialCache output finalCache view retained hlast, ?_, ?_⟩ + · simp [freshTargetCandidateCount, appendTargetViewedState, fullAdversaryTraceUpdate, + hcandidate, hexact.2.1] + · intro position hpositionCandidate + by_cases hold : position.val < state.trace.intervals.length + · let oldPosition : Fin state.trace.intervals.length := ⟨position.val, hold⟩ + have hentry : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals.get + position = state.trace.intervals.get oldPosition := by + have hget : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals[ + position.val]? = state.trace.intervals[position.val]? := by + simp [appendTargetViewedState, fullAdversaryTraceUpdate, + List.getElem?_append_left hold] + rw [List.getElem?_eq_getElem position.isLt, + List.getElem?_eq_getElem hold] at hget + exact Option.some.inj hget + have holdCandidate : FreshTargetCandidate secretKey + (state.trace.intervals.get oldPosition) := by + rw [← hentry] + exact hpositionCandidate + have htake : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals.take + position.val = state.trace.intervals.take oldPosition.val := by + change (state.trace.intervals ++ + [(⟨input, output, initialCache, finalCache⟩ : AdversaryCacheEntry)]).take position.val = + state.trace.intervals.take position.val + rw [List.take_append_of_le_length hold.le] + rw [List.countPBefore_eq_countP_take, htake, + ← List.countPBefore_eq_countP_take] + rw [show position = ⟨oldPosition.val, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ from Fin.ext rfl, + targetCandidateIntervalView_appendTargetViewedState_old + secretKey state hvalid hconsistent input initialCache output finalCache view oldPosition] + have holdExact := hexact.2.2 oldPosition holdCandidate + rw [List.getElem?_append_left + (List.getElem?_eq_some_iff.mp holdExact).1] + exact holdExact + · have hlastValue : position.val = state.trace.intervals.length := by + have hlt : position.val < state.trace.intervals.length + 1 := by + simpa [appendTargetViewedState, fullAdversaryTraceUpdate] using position.isLt + omega + have hposition : position = ⟨state.trace.intervals.length, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ := Fin.ext hlastValue + have hviewLast : targetCandidateIntervalView + (appendTargetViewedState input initialCache output finalCache view state) position = + retained := by + rw [hposition] + exact hlast + rw [hviewLast] + rw [List.countPBefore_eq_countP_take, hlastValue] + simp only [appendTargetViewedState, fullAdversaryTraceUpdate] + rw [List.take_append_of_le_length (Nat.le_refl _), List.take_length] + change (candidateViews ++ [retained])[ + freshTargetCandidateCount secretKey state.trace]? = some retained + rw [← hexact.2.1] + simp + +theorem candidateViewsExact_append_noncandidate + (secretKey : SecretKey) (state : ViewedFullTraceState) + (hvalid : state.ValidViews secretKey) (hconsistent : state.trace.Consistent) + (candidateViews : List FewTimeView) + (hexact : CandidateViewsExact secretKey state candidateViews) + (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (finalCache : QueryCache HashSpec) (view : Option FewTimeView) + (hnon : ¬FreshTargetCandidate secretKey + ⟨input, output, initialCache, finalCache⟩) : + CandidateViewsExact secretKey + (appendTargetViewedState input initialCache output finalCache view state) + candidateViews := by + refine ⟨candidateViewsCover_append_noncandidate secretKey state hvalid hconsistent + candidateViews hexact.1 input initialCache output finalCache view hnon, ?_, ?_⟩ + · simp [freshTargetCandidateCount, appendTargetViewedState, fullAdversaryTraceUpdate, + hnon, hexact.2.1] + · intro position hpositionCandidate + by_cases hold : position.val < state.trace.intervals.length + · let oldPosition : Fin state.trace.intervals.length := ⟨position.val, hold⟩ + have hentry : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals.get + position = state.trace.intervals.get oldPosition := by + have hget : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals[ + position.val]? = state.trace.intervals[position.val]? := by + simp [appendTargetViewedState, fullAdversaryTraceUpdate, + List.getElem?_append_left hold] + rw [List.getElem?_eq_getElem position.isLt, + List.getElem?_eq_getElem hold] at hget + exact Option.some.inj hget + have holdCandidate : FreshTargetCandidate secretKey + (state.trace.intervals.get oldPosition) := by + rw [← hentry] + exact hpositionCandidate + have htake : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals.take + position.val = state.trace.intervals.take oldPosition.val := by + change (state.trace.intervals ++ + [(⟨input, output, initialCache, finalCache⟩ : AdversaryCacheEntry)]).take position.val = + state.trace.intervals.take position.val + rw [List.take_append_of_le_length hold.le] + rw [List.countPBefore_eq_countP_take, htake, + ← List.countPBefore_eq_countP_take] + rw [show position = ⟨oldPosition.val, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ from Fin.ext rfl, + targetCandidateIntervalView_appendTargetViewedState_old + secretKey state hvalid hconsistent input initialCache output finalCache view oldPosition] + exact hexact.2.2 oldPosition holdCandidate + · have hlastValue : position.val = state.trace.intervals.length := by + have hlt : position.val < state.trace.intervals.length + 1 := by + simpa [appendTargetViewedState, fullAdversaryTraceUpdate] using position.isLt + omega + have hposition : position = ⟨state.trace.intervals.length, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ := Fin.ext hlastValue + exfalso + apply hnon + simpa [hposition, appendTargetViewedState, fullAdversaryTraceUpdate] using + hpositionCandidate + +def CandidateAllowedExact + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (state : ViewedFullTraceState) (candidateAllowed : List Bool) : Prop := + candidateAllowed.length = freshTargetCandidateCount secretKey state.trace ∧ + ∀ position, FreshTargetCandidate secretKey (state.trace.intervals.get position) → + candidateAllowed[state.trace.intervals.countPBefore + (fun entry => decide (FreshTargetCandidate secretKey entry)) position.val]? = + some (targetCandidateIntervalAllowed configuration state position) + +theorem candidateAllowedExact_nil + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (cache : QueryCache HashSpec) : + CandidateAllowedExact configuration secretKey + ⟨cache, ⟨[], [], []⟩, [], none⟩ [] := by + refine ⟨rfl, ?_⟩ + intro position + exact Fin.elim0 position + +theorem candidateAllowedExact_append_candidate + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (state : ViewedFullTraceState) (candidateAllowed : List Bool) + (hexact : CandidateAllowedExact configuration secretKey state candidateAllowed) + (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (finalCache : QueryCache HashSpec) (view : Option FewTimeView) + (allowed : Bool) + (hcandidate : FreshTargetCandidate secretKey + ⟨input, output, initialCache, finalCache⟩) + (hlast : targetCandidateIntervalAllowed configuration + (appendTargetViewedState input initialCache output finalCache view state) + ⟨state.trace.intervals.length, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ = allowed) : + CandidateAllowedExact configuration secretKey + (appendTargetViewedState input initialCache output finalCache view state) + (candidateAllowed ++ [allowed]) := by + constructor + · simp [freshTargetCandidateCount, appendTargetViewedState, fullAdversaryTraceUpdate, + hcandidate, hexact.1] + · intro position hpositionCandidate + by_cases hold : position.val < state.trace.intervals.length + · let oldPosition : Fin state.trace.intervals.length := ⟨position.val, hold⟩ + have hentry : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals.get + position = state.trace.intervals.get oldPosition := by + have hget : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals[ + position.val]? = state.trace.intervals[position.val]? := by + simp only [appendTargetViewedState, fullAdversaryTraceUpdate] + rw [List.getElem?_append_left hold] + rw [List.getElem?_eq_getElem position.isLt, + List.getElem?_eq_getElem hold] at hget + exact Option.some.inj hget + have holdCandidate : FreshTargetCandidate secretKey + (state.trace.intervals.get oldPosition) := by + rw [← hentry] + exact hpositionCandidate + have htake : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals.take + position.val = state.trace.intervals.take oldPosition.val := by + change (state.trace.intervals ++ + [(⟨input, output, initialCache, finalCache⟩ : AdversaryCacheEntry)]).take position.val = + state.trace.intervals.take position.val + rw [List.take_append_of_le_length hold.le] + rw [List.countPBefore_eq_countP_take, htake, + ← List.countPBefore_eq_countP_take] + rw [show position = ⟨oldPosition.val, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ from Fin.ext rfl, + targetCandidateIntervalAllowed_appendTargetViewedState_old + configuration state input initialCache output finalCache view oldPosition] + have holdExact := hexact.2 oldPosition holdCandidate + rw [List.getElem?_append_left + (List.getElem?_eq_some_iff.mp holdExact).1] + exact holdExact + · have hlastValue : position.val = state.trace.intervals.length := by + have hlt : position.val < state.trace.intervals.length + 1 := by + simpa [appendTargetViewedState, fullAdversaryTraceUpdate] using position.isLt + omega + have hposition : position = ⟨state.trace.intervals.length, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ := Fin.ext hlastValue + have hallowedLast : targetCandidateIntervalAllowed configuration + (appendTargetViewedState input initialCache output finalCache view state) position = + allowed := by + rw [hposition] + exact hlast + rw [hallowedLast, List.countPBefore_eq_countP_take, hlastValue] + simp only [appendTargetViewedState, fullAdversaryTraceUpdate] + rw [List.take_append_of_le_length (Nat.le_refl _), List.take_length] + change (candidateAllowed ++ [allowed])[ + freshTargetCandidateCount secretKey state.trace]? = some allowed + rw [← hexact.1] + simp + +theorem candidateAllowedExact_append_noncandidate + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (state : ViewedFullTraceState) (candidateAllowed : List Bool) + (hexact : CandidateAllowedExact configuration secretKey state candidateAllowed) + (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (finalCache : QueryCache HashSpec) (view : Option FewTimeView) + (hnon : ¬FreshTargetCandidate secretKey + ⟨input, output, initialCache, finalCache⟩) : + CandidateAllowedExact configuration secretKey + (appendTargetViewedState input initialCache output finalCache view state) + candidateAllowed := by + constructor + · simp [freshTargetCandidateCount, appendTargetViewedState, fullAdversaryTraceUpdate, + hnon, hexact.1] + · intro position hpositionCandidate + by_cases hold : position.val < state.trace.intervals.length + · let oldPosition : Fin state.trace.intervals.length := ⟨position.val, hold⟩ + have hentry : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals.get + position = state.trace.intervals.get oldPosition := by + have hget : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals[ + position.val]? = state.trace.intervals[position.val]? := by + simp only [appendTargetViewedState, fullAdversaryTraceUpdate] + rw [List.getElem?_append_left hold] + rw [List.getElem?_eq_getElem position.isLt, + List.getElem?_eq_getElem hold] at hget + exact Option.some.inj hget + have holdCandidate : FreshTargetCandidate secretKey + (state.trace.intervals.get oldPosition) := by + rw [← hentry] + exact hpositionCandidate + have htake : + (appendTargetViewedState input initialCache output finalCache view state).trace.intervals.take + position.val = state.trace.intervals.take oldPosition.val := by + change (state.trace.intervals ++ + [(⟨input, output, initialCache, finalCache⟩ : AdversaryCacheEntry)]).take position.val = + state.trace.intervals.take position.val + rw [List.take_append_of_le_length hold.le] + rw [List.countPBefore_eq_countP_take, htake, + ← List.countPBefore_eq_countP_take] + rw [show position = ⟨oldPosition.val, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ from Fin.ext rfl, + targetCandidateIntervalAllowed_appendTargetViewedState_old + configuration state input initialCache output finalCache view oldPosition] + exact hexact.2 oldPosition holdCandidate + · have hlastValue : position.val = state.trace.intervals.length := by + have hlt : position.val < state.trace.intervals.length + 1 := by + simpa [appendTargetViewedState, fullAdversaryTraceUpdate] using position.isLt + omega + have hposition : position = ⟨state.trace.intervals.length, by + simp [appendTargetViewedState, fullAdversaryTraceUpdate]⟩ := Fin.ext hlastValue + exfalso + apply hnon + simpa [hposition, appendTargetViewedState, fullAdversaryTraceUpdate] using + hpositionCandidate + +theorem OriginMonitorState.ReplayConsistent.directOrdinal_eq + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + {secretKey : SecretKey} {state : OriginMonitorState configuration} + (hconsistent : state.ReplayConsistent secretKey) : + state.directOrdinal = directIntervalCount state.viewed.trace.intervals := by + have hordinals := replayOriginEvents_ordinals configuration secretKey + (originReplayEvents state.viewed.trace.intervals state.viewed.views) + have hcounts := originReplayEvents_counts state.viewed.trace.intervals state.viewed.views + calc + state.directOrdinal = state.replayState.directOrdinal := rfl + _ = (replayOriginEvents configuration secretKey + (originReplayEvents state.viewed.trace.intervals state.viewed.views)).directOrdinal := + congrArg OriginReplayState.directOrdinal hconsistent.2.2 + _ = OriginReplayEvents.directCount + (originReplayEvents state.viewed.trace.intervals state.viewed.views) := hordinals.1 + _ = directIntervalCount state.viewed.trace.intervals := hcounts.1 + +theorem OriginMonitorState.ReplayConsistent.signerOrdinal_eq + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + {secretKey : SecretKey} {state : OriginMonitorState configuration} + (hconsistent : state.ReplayConsistent secretKey) : + state.signerOrdinal = signerIntervalCount state.viewed.trace.intervals := by + have hordinals := replayOriginEvents_ordinals configuration secretKey + (originReplayEvents state.viewed.trace.intervals state.viewed.views) + have hcounts := originReplayEvents_counts state.viewed.trace.intervals state.viewed.views + calc + state.signerOrdinal = state.replayState.signerOrdinal := rfl + _ = (replayOriginEvents configuration secretKey + (originReplayEvents state.viewed.trace.intervals state.viewed.views)).signerOrdinal := + congrArg OriginReplayState.signerOrdinal hconsistent.2.2 + _ = OriginReplayEvents.signerCount + (originReplayEvents state.viewed.trace.intervals state.viewed.views) := hordinals.2 + _ = signerIntervalCount state.viewed.trace.intervals := hcounts.2 + +def OriginTargetMonitorState.CandidateAllowedTraceCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (state : OriginTargetMonitorState configuration) : Prop := + state.origin.ReplayConsistent secretKey ∧ + CandidateAllowedExact configuration secretKey state.origin.viewed state.candidateAllowed + +theorem OriginTargetMonitorState.candidateAllowedTraceCoherent_initial + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (cache : QueryCache HashSpec) : + (OriginTargetMonitorState.initial configuration cache).CandidateAllowedTraceCoherent + secretKey := by + constructor + · exact OriginMonitorState.replayConsistent_initial configuration secretKey cache + · exact candidateAllowedExact_nil configuration secretKey cache + +def OriginTargetMonitorState.CandidateTraceCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (state : OriginTargetMonitorState configuration) : Prop := + state.origin.ReplayConsistent secretKey ∧ + CandidateViewsExact secretKey state.origin.viewed state.candidateViews + +theorem OriginTargetMonitorState.candidateTraceCoherent_initial + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (cache : QueryCache HashSpec) : + (OriginTargetMonitorState.initial configuration cache).CandidateTraceCoherent + secretKey := by + constructor + · exact OriginMonitorState.replayConsistent_initial configuration secretKey cache + · exact candidateViewsExact_nil secretKey cache + +theorem originTargetMonitoredAdversaryImpl_query_candidateTraceCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) + (result : (OracleWorld + SigningSpec).Range input × + OriginTargetMonitorState configuration) + (hcoherent : state.CandidateTraceCoherent secretKey) + (hmem : result ∈ support + ((originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state)) : result.2.CandidateTraceCoherent secretKey := by + classical + have horiginMem : (result.1, result.2.origin) ∈ support + ((originMonitoredAdversaryImpl configuration secretKey input).run state.origin) := by + rw [← originTargetMonitoredAdversaryImpl_query_projection + configuration secretKey targetOrdinal input state, support_map] + exact ⟨result, hmem, rfl⟩ + have hreplay := originMonitoredAdversaryImpl_query_replayConsistent + configuration secretKey input state.origin (result.1, result.2.origin) + hcoherent.1 horiginMem + refine ⟨hreplay, ?_⟩ + have hvalid := hcoherent.1.1 + have hconsistent := hcoherent.1.2.1 + have hexact := hcoherent.2 + cases input with + | inl worldInput => + rw [originTargetMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, origin⟩, horigin, hpure⟩ := hmem + rw [originMonitoredAdversaryImpl] at horigin + simp only [StateT.run, mem_support_bind_iff] at horigin + obtain ⟨⟨originOutput, finalCache⟩, hquery, horiginPure⟩ := horigin + cases worldInput with + | inl uniformInput => + simp only [support_pure, Set.mem_singleton_iff] at horiginPure hpure + obtain ⟨rfl, rfl⟩ := Prod.mk.inj horiginPure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + change CandidateViewsExact secretKey + (appendTargetViewedState (.inl (.inl uniformInput)) + state.origin.viewed.cache output finalCache none state.origin.viewed) + state.candidateViews + exact candidateViewsExact_append_noncandidate secretKey state.origin.viewed + hvalid hconsistent state.candidateViews hexact _ _ _ _ _ + (freshTargetCandidate_uniform_false secretKey uniformInput output + state.origin.viewed.cache finalCache) + | inr hashInput => + simp only [support_pure, Set.mem_singleton_iff] at horiginPure + obtain ⟨rfl, rfl⟩ := Prod.mk.inj horiginPure + have hquery' : (output, finalCache) ∈ + support ((randomOracle hashInput).run state.origin.viewed.cache) := hquery + by_cases hfresh : state.origin.viewed.cache hashInput = none + · simp only [hfresh, if_true, support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + change CandidateViewsExact secretKey + (appendTargetViewedState (.inl (.inr hashInput)) + state.origin.viewed.cache output finalCache none state.origin.viewed) + (state.candidateViews ++ [hashOutputFewTimeView output]) + apply candidateViewsExact_append_candidate secretKey state.origin.viewed + hvalid hconsistent state.candidateViews hexact + · exact (freshTargetCandidate_direct_iff secretKey hashInput output + state.origin.viewed.cache finalCache hquery').mpr hfresh + simpa using targetCandidateIntervalView_appendTargetViewedState_last + secretKey state.origin.viewed hvalid hconsistent (.inl (.inr hashInput)) + state.origin.viewed.cache output finalCache none + · simp only [hfresh, if_false, support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + change CandidateViewsExact secretKey + (appendTargetViewedState (.inl (.inr hashInput)) + state.origin.viewed.cache output finalCache none state.origin.viewed) + state.candidateViews + apply candidateViewsExact_append_noncandidate secretKey state.origin.viewed + hvalid hconsistent state.candidateViews hexact + exact fun hcandidate => hfresh + ((freshTargetCandidate_direct_iff secretKey hashInput output + state.origin.viewed.cache finalCache hquery').mp hcandidate) + | inr request => + rw [originTargetMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨targetRun, htargetRun, hpure⟩ := hmem + have hcand := freshTargetCandidate_signer_iff secretKey request + state.origin.viewed.cache targetRun htargetRun + cases hselection : targetRun.1.2 with + | none => + simp only [hselection, targetSignerResultView, Option.map, + support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + change CandidateViewsExact secretKey + (appendTargetViewedState (.inr request) state.origin.viewed.cache + targetRun.1.1 targetRun.2 none state.origin.viewed) + state.candidateViews + apply candidateViewsExact_append_noncandidate secretKey state.origin.viewed + hvalid hconsistent state.candidateViews hexact + intro hcandidate + obtain ⟨selectedInput, view, hsome, _⟩ := hcand.mp hcandidate + rw [hselection] at hsome + simp at hsome + | some selection => + rcases selection with ⟨selectedInput, view⟩ + by_cases hfresh : state.origin.viewed.cache selectedInput = none + · simp only [hselection, targetSignerResultView, Option.map, hfresh, + if_true, support_pure, + Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + change CandidateViewsExact secretKey + (appendTargetViewedState (.inr request) state.origin.viewed.cache + targetRun.1.1 targetRun.2 (some view) state.origin.viewed) + (state.candidateViews ++ [view]) + apply candidateViewsExact_append_candidate secretKey state.origin.viewed + hvalid hconsistent state.candidateViews hexact + · exact hcand.mpr ⟨selectedInput, view, hselection, hfresh⟩ + simpa using targetCandidateIntervalView_appendTargetViewedState_last + secretKey state.origin.viewed hvalid hconsistent (.inr request) + state.origin.viewed.cache targetRun.1.1 targetRun.2 (some view) + · simp only [hselection, targetSignerResultView, Option.map, hfresh, + if_false, support_pure, + Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + change CandidateViewsExact secretKey + (appendTargetViewedState (.inr request) state.origin.viewed.cache + targetRun.1.1 targetRun.2 (some view) state.origin.viewed) + state.candidateViews + apply candidateViewsExact_append_noncandidate secretKey state.origin.viewed + hvalid hconsistent state.candidateViews hexact + intro hcandidate + obtain ⟨input, foundView, hsome, hmiss⟩ := hcand.mp hcandidate + have hfields := Prod.mk.inj (Option.some.inj (hselection.symm.trans hsome)) + apply hfresh + rw [hfields.1] + exact hmiss + +theorem originTargetMonitoredAdversaryImpl_candidateTraceCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (result : α × OriginTargetMonitorState configuration) + (hcoherent : initialState.CandidateTraceCoherent secretKey) + (hmem : result ∈ support + ((simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState)) : result.2.CandidateTraceCoherent secretKey := by + exact OracleComp.simulateQ_run_preservesInv + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + (OriginTargetMonitorState.CandidateTraceCoherent secretKey) + (by + intro input state hstate queryResult hquery + exact originTargetMonitoredAdversaryImpl_query_candidateTraceCoherent + configuration secretKey targetOrdinal input state queryResult hstate hquery) + computation initialState hcoherent result hmem + +theorem originTargetMonitoredAdversaryImpl_query_candidateAllowedTraceCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) + (result : (OracleWorld + SigningSpec).Range input × + OriginTargetMonitorState configuration) + (hcoherent : state.CandidateAllowedTraceCoherent secretKey) + (hmem : result ∈ support + ((originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state)) : result.2.CandidateAllowedTraceCoherent secretKey := by + classical + have horiginMem : (result.1, result.2.origin) ∈ support + ((originMonitoredAdversaryImpl configuration secretKey input).run state.origin) := by + rw [← originTargetMonitoredAdversaryImpl_query_projection + configuration secretKey targetOrdinal input state, support_map] + exact ⟨result, hmem, rfl⟩ + have hreplay := originMonitoredAdversaryImpl_query_replayConsistent + configuration secretKey input state.origin (result.1, result.2.origin) + hcoherent.1 horiginMem + refine ⟨hreplay, ?_⟩ + have hexact := hcoherent.2 + cases input with + | inl worldInput => + rw [originTargetMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, origin⟩, horigin, hpure⟩ := hmem + rw [originMonitoredAdversaryImpl] at horigin + simp only [StateT.run, mem_support_bind_iff] at horigin + obtain ⟨⟨originOutput, finalCache⟩, hquery, horiginPure⟩ := horigin + cases worldInput with + | inl uniformInput => + simp only [support_pure, Set.mem_singleton_iff] at horiginPure hpure + obtain ⟨rfl, rfl⟩ := Prod.mk.inj horiginPure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + change CandidateAllowedExact configuration secretKey + (appendTargetViewedState (.inl (.inl uniformInput)) + state.origin.viewed.cache output finalCache none state.origin.viewed) + state.candidateAllowed + exact candidateAllowedExact_append_noncandidate configuration secretKey + state.origin.viewed state.candidateAllowed hexact _ _ _ _ _ + (freshTargetCandidate_uniform_false secretKey uniformInput output + state.origin.viewed.cache finalCache) + | inr hashInput => + simp only [support_pure, Set.mem_singleton_iff] at horiginPure + obtain ⟨rfl, rfl⟩ := Prod.mk.inj horiginPure + have hquery' : (output, finalCache) ∈ + support ((randomOracle hashInput).run state.origin.viewed.cache) := hquery + by_cases hfresh : state.origin.viewed.cache hashInput = none + · simp only [hfresh, if_true, support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + change CandidateAllowedExact configuration secretKey + (appendTargetViewedState (.inl (.inr hashInput)) + state.origin.viewed.cache output finalCache none state.origin.viewed) + (state.candidateAllowed ++ + [decide (configuration.sourceAt? state.origin.directOrdinal = none)]) + apply candidateAllowedExact_append_candidate configuration secretKey + state.origin.viewed state.candidateAllowed hexact + · exact (freshTargetCandidate_direct_iff secretKey hashInput output + state.origin.viewed.cache finalCache hquery').mpr hfresh + simpa [hcoherent.1.directOrdinal_eq] using + targetCandidateIntervalAllowed_appendTargetViewedState_last + configuration state.origin.viewed (.inl (.inr hashInput)) + state.origin.viewed.cache output finalCache none + · simp only [hfresh, if_false, support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + change CandidateAllowedExact configuration secretKey + (appendTargetViewedState (.inl (.inr hashInput)) + state.origin.viewed.cache output finalCache none state.origin.viewed) + state.candidateAllowed + apply candidateAllowedExact_append_noncandidate configuration secretKey + state.origin.viewed state.candidateAllowed hexact + exact fun hcandidate => hfresh + ((freshTargetCandidate_direct_iff secretKey hashInput output + state.origin.viewed.cache finalCache hquery').mp hcandidate) + | inr request => + rw [originTargetMonitoredAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨targetRun, htargetRun, hpure⟩ := hmem + have hcand := freshTargetCandidate_signer_iff secretKey request + state.origin.viewed.cache targetRun htargetRun + cases hselection : targetRun.1.2 with + | none => + simp only [hselection, targetSignerResultView, Option.map, + support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + change CandidateAllowedExact configuration secretKey + (appendTargetViewedState (.inr request) state.origin.viewed.cache + targetRun.1.1 targetRun.2 none state.origin.viewed) + state.candidateAllowed + apply candidateAllowedExact_append_noncandidate configuration secretKey + state.origin.viewed state.candidateAllowed hexact + intro hcandidate + obtain ⟨selectedInput, view, hsome, _⟩ := hcand.mp hcandidate + rw [hselection] at hsome + simp at hsome + | some selection => + rcases selection with ⟨selectedInput, view⟩ + by_cases hfresh : state.origin.viewed.cache selectedInput = none + · simp only [hselection, targetSignerResultView, Option.map, hfresh, + if_true, support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + change CandidateAllowedExact configuration secretKey + (appendTargetViewedState (.inr request) state.origin.viewed.cache + targetRun.1.1 targetRun.2 (some view) state.origin.viewed) + (state.candidateAllowed ++ + [decide (pattern.selectedAt? state.origin.signerOrdinal = none)]) + apply candidateAllowedExact_append_candidate configuration secretKey + state.origin.viewed state.candidateAllowed hexact + · exact hcand.mpr ⟨selectedInput, view, hselection, hfresh⟩ + simpa [hcoherent.1.signerOrdinal_eq] using + targetCandidateIntervalAllowed_appendTargetViewedState_last + configuration state.origin.viewed (.inr request) + state.origin.viewed.cache targetRun.1.1 targetRun.2 (some view) + · simp only [hselection, targetSignerResultView, Option.map, hfresh, + if_false, support_pure, Set.mem_singleton_iff] at hpure + have hstateEq := congrArg Prod.snd hpure + rw [hstateEq] + change CandidateAllowedExact configuration secretKey + (appendTargetViewedState (.inr request) state.origin.viewed.cache + targetRun.1.1 targetRun.2 (some view) state.origin.viewed) + state.candidateAllowed + apply candidateAllowedExact_append_noncandidate configuration secretKey + state.origin.viewed state.candidateAllowed hexact + intro hcandidate + obtain ⟨input, foundView, hsome, hmiss⟩ := hcand.mp hcandidate + have hfields := Prod.mk.inj (Option.some.inj (hselection.symm.trans hsome)) + apply hfresh + rw [hfields.1] + exact hmiss + +theorem originTargetMonitoredAdversaryImpl_candidateAllowedTraceCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (result : α × OriginTargetMonitorState configuration) + (hcoherent : initialState.CandidateAllowedTraceCoherent secretKey) + (hmem : result ∈ support + ((simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState)) : + result.2.CandidateAllowedTraceCoherent secretKey := by + exact OracleComp.simulateQ_run_preservesInv + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + (OriginTargetMonitorState.CandidateAllowedTraceCoherent secretKey) + (by + intro input state hstate queryResult hquery + exact originTargetMonitoredAdversaryImpl_query_candidateAllowedTraceCoherent + configuration secretKey targetOrdinal input state queryResult hstate hquery) + computation initialState hcoherent result hmem + +theorem OriginTargetMonitorState.CandidateTraceCoherent.candidateCountCoherent + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + {secretKey : SecretKey} {state : OriginTargetMonitorState configuration} + (hcoherent : state.CandidateTraceCoherent secretKey) + (hviews : state.candidateOrdinal = state.candidateViews.length) : + state.CandidateCountCoherent secretKey := by + rw [OriginTargetMonitorState.CandidateCountCoherent, hviews, + hcoherent.2.2.1] + +theorem OriginTargetMonitorState.targetView_eq_candidateInterval + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (state : OriginTargetMonitorState configuration) + (position : Fin state.origin.viewed.trace.intervals.length) + (hcandidate : FreshTargetCandidate secretKey + (state.origin.viewed.trace.intervals.get position)) + (hviews : state.CandidateViewsCoherent + (state.origin.viewed.trace.intervals.countPBefore + (fun entry => decide (FreshTargetCandidate secretKey entry)) position.val)) + (hexact : CandidateViewsExact secretKey state.origin.viewed state.candidateViews) : + state.targetView = some (targetCandidateIntervalView state.origin.viewed position) := by + rw [hviews.2] + exact hexact.2.2 position hcandidate + +theorem OriginTargetMonitorState.valid_eq_candidateIntervalAllowed + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (state : OriginTargetMonitorState configuration) + (position : Fin state.origin.viewed.trace.intervals.length) + (hcandidate : FreshTargetCandidate secretKey + (state.origin.viewed.trace.intervals.get position)) + (hfixed : state.CandidateAllowedCoherent + (state.origin.viewed.trace.intervals.countPBefore + (fun entry => decide (FreshTargetCandidate secretKey entry)) position.val)) + (hexact : CandidateAllowedExact configuration secretKey + state.origin.viewed state.candidateAllowed) : + state.valid = targetCandidateIntervalAllowed configuration state.origin.viewed position := by + rw [hfixed.2, hexact.2 position hcandidate] + rfl + +theorem ProperFewTimeLeak.direct_target_not_configured_source + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (hproper : ProperFewTimeLeak f cache secretKey signingLog index targetLeaves) + (forgery : Forgery) (forgedDigest : MessageDigest) + (hforgedDigest : evalWithAnswerFn f + (messageDigest secretKey.parameter secretKey.root forgery.message + forgery.signature.randomness) = forgedDigest) + (hleaves : targetLeaves = digestLeaves forgedDigest) + {q limit : Nat} (hle : signingLog.length ≤ limit) + (configuration : OriginConfiguration (hproper.1.cover.pattern.pad hle) q) + (trace : FullAdversaryTrace) + (hlog : trace.signing.toSigningLog = signingLog) + (hrealized : configuration.PaddedRealizedBy hproper.1.cover hle trace hlog) + (hvalid : trace.ValidIntervals secretKey) + (position : Fin trace.intervals.length) (output : HashOutput) + (initialCache finalCache : QueryCache HashSpec) + (hinterval : trace.intervals.get position = + ⟨.inl (.inr (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root forgery.message + forgery.signature.randomness))), output, initialCache, finalCache⟩) : + configuration.sourceAt? + (directIntervalCount (trace.intervals.take position.val)) = none := by + classical + cases hsource : configuration.sourceAt? + (directIntervalCount (trace.intervals.take position.val)) with + | none => rfl + | some selected => + exfalso + have hgood := configuration.paddedRealized_direct_good hrealized hvalid position + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root forgery.message + forgery.signature.randomness)) + output initialCache finalCache hinterval + (directIntervalCount (trace.intervals.take position.val)) rfl selected hsource + have hne := hproper.forged_digest_input_ne_entryDigestInput forgery forgedDigest + hforgedDigest hleaves (hproper.1.cover.paddedEntry hle selected.1) + apply hne + simpa only [FewTimeCover.paddedExpectedInputs] using hgood.1 + +theorem FewTimeCover.failed_signer_not_selectedAt + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (state : ViewedFullTraceState) + (hlog : state.trace.signing.toSigningLog = signingLog) + (hvalid : state.ValidViews secretKey) (hconsistent : state.trace.Consistent) + (hcaches : state.trace.signing.CachesLe cache) (hf : cache.AgreesWithFn f) + {limit : Nat} (hle : signingLog.length ≤ limit) + (position : Fin state.trace.intervals.length) (request : SignRequest) + (initialCache finalCache : QueryCache HashSpec) + (hinterval : state.trace.intervals.get position = + ⟨.inr request, none, initialCache, finalCache⟩) : + (cover.pattern.pad hle).selectedAt? + (signerIntervalCount (state.trace.intervals.take position.val)) = none := by + classical + cases hselected : (cover.pattern.pad hle).selectedAt? + (signerIntervalCount (state.trace.intervals.take position.val)) with + | none => rfl + | some selected => + exfalso + have hrank : signerIntervalCount (state.trace.intervals.take position.val) = + selected.1.val := + ((cover.pattern.pad hle).selectedAt?_eq_some_iff _ selected).mp hselected |>.symm + have hsigner := cover.originReplayEvents_get_signer state hlog hvalid hconsistent + hcaches hf hle selected position request none initialCache finalCache hinterval hrank + let entry := cover.paddedEntry hle selected + have hfields := cover.cacheEntry_request_signature state.trace.signing hlog entry + have hsignature := congrArg SigningCacheEntry.signature hsigner.2 + change none = (cover.cacheEntry state.trace.signing hlog entry).signature at hsignature + rw [hfields.2] at hsignature + simp at hsignature + +theorem ProperFewTimeLeak.signer_target_not_selectedAt + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (hproper : ProperFewTimeLeak f cache secretKey signingLog index targetLeaves) + (state : ViewedFullTraceState) + (hlog : state.trace.signing.toSigningLog = signingLog) + (hvalidViews : state.ValidViews secretKey) + (hconsistent : state.trace.Consistent) + (hvalidRuns : state.trace.signing.ValidRuns secretKey) + (hcaches : state.trace.signing.CachesLe cache) (hf : cache.AgreesWithFn f) + {limit : Nat} (hle : signingLog.length ≤ limit) + (position : Fin state.trace.intervals.length) + (request : SignRequest) (signature : Option Signature) + (initialCache finalCache : QueryCache HashSpec) + (hinterval : state.trace.intervals.get position = + ⟨.inr request, signature, initialCache, finalCache⟩) + (targetPayload : HashInput) (output : HashOutput) + (hbefore : initialCache + (tweakableHashInput secretKey.parameter .message targetPayload) = none) + (hafter : finalCache + (tweakableHashInput secretKey.parameter .message targetPayload) = some output) + (houtput : signAttemptResultOfOutput output = some (index, targetLeaves)) : + (hproper.1.cover.pattern.pad hle).selectedAt? + (signerIntervalCount (state.trace.intervals.take position.val)) = none := by + have hsignature := hproper.signer_target_signature_eq_none state hlog hvalidViews + hconsistent hvalidRuns hcaches hf position request signature initialCache finalCache + hinterval targetPayload output hbefore hafter houtput + subst signature + exact hproper.1.cover.failed_signer_not_selectedAt state hlog hvalidViews hconsistent + hcaches hf hle position request initialCache finalCache hinterval + +theorem ProperFewTimeLeak.target_source_interval_allowed + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (hproper : ProperFewTimeLeak f cache secretKey signingLog index targetLeaves) + (forgery : Forgery) (forgedDigest : MessageDigest) + (hforgedDigest : evalWithAnswerFn f + (messageDigest secretKey.parameter secretKey.root forgery.message + forgery.signature.randomness) = forgedDigest) + (hleaves : targetLeaves = digestLeaves forgedDigest) + (state : ViewedFullTraceState) + (hlog : state.trace.signing.toSigningLog = signingLog) + (hvalidViews : state.ValidViews secretKey) + (hconsistent : state.trace.Consistent) + (hvalidRuns : state.trace.signing.ValidRuns secretKey) + (hcaches : state.trace.signing.CachesLe cache) (hf : cache.AgreesWithFn f) + {q limit : Nat} (hle : signingLog.length ≤ limit) + (configuration : OriginConfiguration (hproper.1.cover.pattern.pad hle) q) + (hrealized : configuration.PaddedRealizedBy hproper.1.cover hle state.trace hlog) + (hvalidIntervals : state.trace.ValidIntervals secretKey) + (position : Fin state.trace.intervals.length) (output : HashOutput) + (hbefore : (state.trace.intervals.get position).initialCache + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root forgery.message + forgery.signature.randomness)) = none) + (hafter : (state.trace.intervals.get position).finalCache + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root forgery.message + forgery.signature.randomness)) = some output) + (houtput : signAttemptResultOfOutput output = some (index, targetLeaves)) + (hkind : (state.trace.intervals.get position).input = .inl (.inr + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root forgery.message + forgery.signature.randomness))) ∨ + ∃ request, (state.trace.intervals.get position).input = .inr request) : + targetCandidateIntervalAllowed configuration state position = true := by + let entry := state.trace.intervals.get position + have hentry : state.trace.intervals.get position = entry := rfl + rcases entry with ⟨entryInput, entryOutput, initialCache, finalCache⟩ + rw [hentry] at hbefore hafter hkind + change initialCache _ = none at hbefore + change finalCache _ = some output at hafter + rcases hkind with hdirect | ⟨request, hsigner⟩ + · change entryInput = .inl (.inr _) at hdirect + subst entryInput + have hnone := hproper.direct_target_not_configured_source forgery forgedDigest + hforgedDigest hleaves hle configuration state.trace hlog hrealized hvalidIntervals + position entryOutput initialCache finalCache hentry + have hinputElem : state.trace.intervals[position.val].input = .inl (.inr + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root forgery.message + forgery.signature.randomness))) := by + simpa only [List.get_eq_getElem] using + congrArg AdversaryCacheEntry.input hentry + simp [targetCandidateIntervalAllowed, hinputElem, hnone] + · change entryInput = .inr request at hsigner + subst entryInput + have hnone := hproper.signer_target_not_selectedAt state hlog hvalidViews hconsistent + hvalidRuns hcaches hf hle position request entryOutput initialCache finalCache hentry + (messageDigestPayload secretKey.root forgery.message + forgery.signature.randomness) output hbefore hafter houtput + have hinputElem : state.trace.intervals[position.val].input = .inr request := by + simpa only [List.get_eq_getElem] using + congrArg AdversaryCacheEntry.input hentry + simp [targetCandidateIntervalAllowed, hinputElem, hnone] + +theorem gameAfterSecretsWithViewTrace_target_source_candidate + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest parameter result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) = digest) + (hadmissible : Admissible digest) + (source : Fin result.2.trace.intervals.length) + (hsourceInitial : (result.2.trace.intervals.get source).initialCache + (tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness)) = none) + (hsourceFinal : (result.2.trace.intervals.get source).finalCache + (tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness)) ≠ none) + (hkind : (result.2.trace.intervals.get source).input = .inl (.inr + (tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness))) ∨ + ∃ request, (result.2.trace.intervals.get source).input = .inr request) : + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + ∃ output, + FreshTargetCandidate secretKey (result.2.trace.intervals.get source) + ∧ targetCandidateIntervalView result.2 source = + fewTimeTargetView (digestIndex digest) (digestLeaves digest) + ∧ (result.2.trace.intervals.get source).finalCache + (tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness)) = some output + ∧ signAttemptResultOfOutput output = + some (digestIndex digest, digestLeaves digest) := by + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + let targetPayload := messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness + let input := tweakableHashInput parameter .message targetPayload + obtain ⟨output, hsourceOutput⟩ := Option.ne_none_iff_exists'.mp hsourceFinal + have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hresult, rfl⟩ + have hintervals := gameAfterSecretsWithFullTrace_support_interval_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hvalidIntervals := gameAfterSecretsWithFullTrace_support_validIntervals adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hvalidViews := gameAfterSecretsWithViewTrace_support_validViews adversary parameter + otsSecret ftsSecret result hresult + let entry := result.2.trace.intervals.get source + have hentry : result.2.trace.intervals.get source = entry := rfl + have hsourceLe : entry.finalCache ≤ result.2.cache := + (hintervals.2.1 entry (List.get_mem _ source)).2 + have hcachedFinal : result.2.cache input = some output := by + exact hsourceLe (by simpa only [entry, input] using hsourceOutput) + have hanswer : f input = output := hf hcachedFinal + have hdigestOutput : truncateMessageDigest output = digest := by + simpa only [messageDigest, oracleHash, evalWithAnswerFn_bind, evalWithAnswerFn_query, + evalWithAnswerFn_pure, input, targetPayload, hanswer] using hdigest + have hattempt : signAttemptResultOfOutput output = + some (digestIndex digest, digestLeaves digest) := by + simp [signAttemptResultOfOutput, hdigestOutput, hadmissible] + have htargetOutput : hashOutputFewTimeView output = + fewTimeTargetView (digestIndex digest) (digestLeaves digest) := by + simp [hashOutputFewTimeView, fewTimeTargetView, hdigestOutput] + have hsourceCandidate : FreshTargetCandidate secretKey entry := + freshTargetCandidate_of_message_transition secretKey entry targetPayload + (hvalidIntervals entry (List.get_mem _ source)) + (by simpa only [secretKey, input, entry] using hsourceInitial) + (by simpa only [secretKey, input, entry, hsourceOutput]) + (by + intro sourceOutput hsourceOutput' + have hcached := hsourceLe (by simpa only [input] using hsourceOutput') + rw [hcachedFinal] at hcached + have hsourceOutputEq : sourceOutput = output := + (Option.some.inj hcached).symm + rw [hsourceOutputEq, hattempt] + simp) + (by simpa only [secretKey, input, entry] using hkind) + refine ⟨output, by simpa only [entry] using hsourceCandidate, ?_, + by simpa only [input] using hsourceOutput, hattempt⟩ + rcases hkind with hdirect | ⟨request, hsigner⟩ + · rcases entry with ⟨entryInput, entryOutput, initialCache, finalCache⟩ + change (result.2.trace.intervals.get source).input = .inl (.inr input) at hdirect + have hentryInput := congrArg AdversaryCacheEntry.input hentry + rw [hentryInput] at hdirect + rcases entryInput with worldInput | sourceRequest + · rcases worldInput with uniformInput | directInput + · simp at hdirect + · simp only [Sum.inl.injEq, Sum.inr.injEq] at hdirect + subst directInput + rw [hentry] at hsourceOutput + change finalCache input = some output at hsourceOutput + have hvalidEntry := hvalidIntervals + (⟨.inl (.inr input), entryOutput, initialCache, finalCache⟩ : + AdversaryCacheEntry) (by rw [← hentry]; exact List.get_mem _ source) + have hdirectRun : (entryOutput, finalCache) ∈ support + ((randomOracle input).run initialCache) := hvalidEntry + have hdirectCached : finalCache input = some entryOutput := + randomOracle_run_output_cached input initialCache finalCache entryOutput hdirectRun + have hentryOutputEq : entryOutput = output := by + rw [hsourceOutput] at hdirectCached + exact (Option.some.inj hdirectCached).symm + rw [targetCandidateIntervalView_direct result.2 source input entryOutput + initialCache finalCache hentry, hentryOutputEq] + exact htargetOutput + · simp at hdirect + · rcases entry with ⟨entryInput, entryOutput, initialCache, finalCache⟩ + change (result.2.trace.intervals.get source).input = .inr request at hsigner + have hentryInput := congrArg AdversaryCacheEntry.input hentry + rw [hentryInput] at hsigner + rcases entryInput with worldInput | sourceRequest + · simp at hsigner + · simp only [Sum.inr.injEq] at hsigner + subst sourceRequest + rw [hentry] at hsourceInitial hsourceOutput + change initialCache input = none at hsourceInitial + change finalCache input = some output at hsourceOutput + have hstored := ViewedFullTraceState.ValidViews.signer_interval_fresh_admissible_view + hvalidViews hintervals.1 source request entryOutput initialCache finalCache + hentry targetPayload output (digestIndex digest) (digestLeaves digest) + (by simpa only [secretKey, input] using hsourceInitial) + (by simpa only [secretKey, input] using hsourceOutput) hattempt + rw [targetCandidateIntervalView_signer result.2 source request entryOutput + initialCache finalCache (hashOutputFewTimeView output) hentry hstored] + exact htargetOutput + +def castTracePosition + (left right : ViewedFullTraceState) (htrace : left.trace = right.trace) + (position : Fin left.trace.intervals.length) : + Fin right.trace.intervals.length := + Fin.cast (congrArg (fun trace : FullAdversaryTrace => trace.intervals.length) htrace) + position + +theorem get_castTracePosition + (left right : ViewedFullTraceState) (htrace : left.trace = right.trace) + (position : Fin left.trace.intervals.length) : + right.trace.intervals.get (castTracePosition left right htrace position) = + left.trace.intervals.get position := by + have hintervals : left.trace.intervals = right.trace.intervals := + congrArg FullAdversaryTrace.intervals htrace + have hright : position.val < right.trace.intervals.length := by + rw [← hintervals] + exact position.isLt + have hget := congrArg (fun intervals : List AdversaryCacheEntry => + intervals[position.val]?) hintervals + rw [List.getElem?_eq_getElem position.isLt, + List.getElem?_eq_getElem hright] at hget + exact (Option.some.inj hget).symm + +theorem take_castTracePosition + (left right : ViewedFullTraceState) (htrace : left.trace = right.trace) + (position : Fin left.trace.intervals.length) : + right.trace.intervals.take (castTracePosition left right htrace position).val = + left.trace.intervals.take position.val := by + have hintervals : left.trace.intervals = right.trace.intervals := + congrArg FullAdversaryTrace.intervals htrace + change right.trace.intervals.take position.val = + left.trace.intervals.take position.val + exact (congrArg (List.take position.val) hintervals).symm + +theorem targetCandidateIntervalView_castTracePosition + (left right : ViewedFullTraceState) (htrace : left.trace = right.trace) + (hviews : left.views = right.views) + (position : Fin left.trace.intervals.length) : + targetCandidateIntervalView right (castTracePosition left right htrace position) = + targetCandidateIntervalView left position := by + simp only [targetCandidateIntervalView] + rw [get_castTracePosition left right htrace position, + take_castTracePosition left right htrace position, ← hviews] + +theorem targetCandidateIntervalAllowed_castTracePosition + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) + (left right : ViewedFullTraceState) (htrace : left.trace = right.trace) + (position : Fin left.trace.intervals.length) : + targetCandidateIntervalAllowed configuration right + (castTracePosition left right htrace position) = + targetCandidateIntervalAllowed configuration left position := by + simp only [targetCandidateIntervalAllowed] + rw [get_castTracePosition left right htrace position, + take_castTracePosition left right htrace position] + +theorem OriginConfiguration.paddedRealized_transport + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + {cover : FewTimeCover f cache secretKey signingLog index targetLeaves} + {q limit : Nat} {hle : signingLog.length ≤ limit} + {configuration : OriginConfiguration (cover.pattern.pad hle) q} + (left right : FullAdversaryTrace) (htrace : left = right) + (hlog : left.signing.toSigningLog = signingLog) + (hrealized : configuration.PaddedRealizedBy cover hle left hlog) : + ∃ hlog' : right.signing.toSigningLog = signingLog, + configuration.PaddedRealizedBy cover hle right hlog' := by + subst right + exact ⟨hlog, hrealized⟩ + +theorem OriginConfiguration.paddedRealized_target_complete_and_hit + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + {cover : FewTimeCover f cache secretKey signingLog index targetLeaves} + {q limit : Nat} {hle : signingLog.length ≤ limit} + {configuration : OriginConfiguration (cover.pattern.pad hle) q} + {state : OriginTargetMonitorState configuration} + (hlog : state.origin.viewed.trace.signing.toSigningLog = signingLog) + (hrealized : configuration.PaddedRealizedBy cover hle + state.origin.viewed.trace hlog) + (hreplay : state.origin.ReplayConsistent secretKey) + (hvalidIntervals : state.origin.viewed.trace.ValidIntervals secretKey) + (hchronological : FullAdversaryTrace.Chronological + state.origin.viewed.trace.intervals) + (hcaches : state.origin.viewed.trace.signing.CachesLe cache) + (hf : cache.AgreesWithFn f) + (position : Fin state.origin.viewed.trace.intervals.length) + (hcandidate : FreshTargetCandidate secretKey + (state.origin.viewed.trace.intervals.get position)) + (hview : targetCandidateIntervalView state.origin.viewed position = + fewTimeTargetView index targetLeaves) + (hallowed : targetCandidateIntervalAllowed configuration + state.origin.viewed position = true) + (hviewsCoherent : state.CandidateViewsCoherent + (state.origin.viewed.trace.intervals.countPBefore + (fun entry => decide (FreshTargetCandidate secretKey entry)) position.val)) + (hviewsExact : CandidateViewsExact secretKey + state.origin.viewed state.candidateViews) + (hallowedCoherent : state.CandidateAllowedCoherent + (state.origin.viewed.trace.intervals.countPBefore + (fun entry => decide (FreshTargetCandidate secretKey entry)) position.val)) + (hallowedExact : CandidateAllowedExact configuration secretKey + state.origin.viewed state.candidateAllowed) : + state.Complete ∧ + ∀ target, state.targetView = some target → + FixedFewTimePatternHit (cover.pattern.pad hle).assignment + (state.origin.observation.views, target) := by + have horigin := configuration.paddedRealized_complete_and_hit hlog hrealized + hreplay hvalidIntervals hchronological hcaches hf + have htarget := state.targetView_eq_candidateInterval secretKey position hcandidate + hviewsCoherent hviewsExact + rw [hview] at htarget + have hvalid := state.valid_eq_candidateIntervalAllowed secretKey position hcandidate + hallowedCoherent hallowedExact + rw [hallowed] at hvalid + constructor + · exact ⟨hvalid, horigin.1, + fewTimeTargetView index targetLeaves, htarget⟩ + · intro target htarget' + have htargetEq : target = fewTimeTargetView index targetLeaves := by + exact Option.some.inj (htarget'.symm.trans htarget) + rw [htargetEq] + exact horigin.2 + +theorem probEvent_originConfiguration_hit_eq_pattern_mul + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) : + Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] = + Pr[FixedFewTimePatternHit pattern.assignment | + ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : + ProbComp ((pattern.selected → FewTimeView) × FewTimeView))] * + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ configuration.prehit.card := by + change Pr[configuration.Hit | + Prod.mk <$> + ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : + ProbComp ((pattern.selected → FewTimeView) × FewTimeView)) <*> + ($ᵗ BitVec (127 * configuration.prehit.card) : + ProbComp (BitVec (127 * configuration.prehit.card)))] = _ + calc + _ = Pr[FixedFewTimePatternHit pattern.assignment | + ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : + ProbComp ((pattern.selected → FewTimeView) × FewTimeView))] * + Pr[fun value : BitVec (127 * configuration.prehit.card) => value = 0 | + ($ᵗ BitVec (127 * configuration.prehit.card) : + ProbComp (BitVec (127 * configuration.prehit.card)))] := by + apply probEvent_seq_map_eq_mul + intro views _ activations _ + rfl + _ = _ := by rw [probEvent_uniformOriginActivation_zero] + +theorem probEvent_originTargetMonitored_complete_fixedPattern_le_ideal + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (q : Nat) (hq : q ≤ 2 ^ 120) + (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[fun result : α × OriginTargetMonitorState configuration => + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q | + (simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run (OriginTargetMonitorState.initial configuration initialCache)] ≤ + Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] := by + calc + _ ≤ ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ^ configuration.prehit.card * + Pr[FixedFewTimePatternHit pattern.assignment | + ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : + ProbComp ((pattern.selected → FewTimeView) × FewTimeView))] := + probEvent_originTargetMonitored_complete_le_ideal configuration secretKey + targetOrdinal computation initialCache + (FixedFewTimePatternHit pattern.assignment) q (hq.trans (by norm_num)) hcache + _ = Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] := by + rw [probEvent_originConfiguration_hit_eq_pattern_mul] + ac_rfl + +theorem probEvent_exists_fixedOrdinal_viewedEvent_le_ideal + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (q : Nat) (hq : q ≤ 2 ^ 120) + (hcache : QueryCache.enncard initialCache ≤ q) (candidates : Nat) + (viewedEvent : Fin candidates → α × ViewedFullTraceState → Prop) + (himp : ∀ (candidate : Fin candidates) + (result : α × OriginTargetMonitorState configuration), + result ∈ support + ((simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey candidate.val) + computation).run (OriginTargetMonitorState.initial configuration initialCache)) → + viewedEvent candidate (result.1, result.2.origin.viewed) → + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q) : + Pr[fun result => ∃ candidate : Fin candidates, viewedEvent candidate result | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run + (OriginTargetMonitorState.initial configuration initialCache).origin.viewed] ≤ + candidates * Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] := by + classical + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run + (OriginTargetMonitorState.initial configuration initialCache).origin.viewed + calc + Pr[fun result => ∃ candidate : Fin candidates, viewedEvent candidate result | run] = + Pr[fun result => ∃ candidate ∈ (Finset.univ : Finset (Fin candidates)), + viewedEvent candidate result | run] := by + congr 1 + funext result + simp + _ ≤ ∑ candidate ∈ (Finset.univ : Finset (Fin candidates)), + Pr[viewedEvent candidate | run] := + probEvent_exists_finset_le_sum Finset.univ run viewedEvent + _ ≤ ∑ _candidate ∈ (Finset.univ : Finset (Fin candidates)), + Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] := by + apply Finset.sum_le_sum + intro candidate _ + calc + Pr[viewedEvent candidate | run] ≤ + Pr[fun result : α × OriginTargetMonitorState configuration => + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q | + (simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey candidate.val) + computation).run + (OriginTargetMonitorState.initial configuration initialCache)] := + probEvent_viewed_le_originTargetMonitoredAdversaryImpl configuration secretKey + candidate.val computation (OriginTargetMonitorState.initial configuration initialCache) + (viewedEvent candidate) _ (himp candidate) + _ ≤ _ := probEvent_originTargetMonitored_complete_fixedPattern_le_ideal + configuration secretKey candidate.val computation initialCache q hq hcache + _ = _ := by + rw [Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul] + +theorem probEvent_exists_originConfiguration_fixedOrdinal_viewedEvent_le_idealOrigin + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q : Nat) + (hq : q ≤ 2 ^ 120) (hcache : QueryCache.enncard initialCache ≤ q) + (candidates : Nat) + (viewedEvent : ∀ (distinct : Nat) (pattern : FewTimePattern signatures distinct), + OriginConfiguration pattern sources → Fin candidates → + α × ViewedFullTraceState → Prop) + (himp : ∀ (distinct : Nat) (pattern : FewTimePattern signatures distinct) + (configuration : OriginConfiguration pattern sources) (candidate : Fin candidates) + (result : α × OriginTargetMonitorState configuration), + result ∈ support + ((simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey candidate.val) + computation).run (OriginTargetMonitorState.initial configuration initialCache)) → + viewedEvent distinct pattern configuration candidate + (result.1, result.2.origin.viewed) → + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q) : + Pr[fun result => ∃ distinct ∈ Finset.Icc 1 14, + ∃ pattern : FewTimePattern signatures distinct, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] ≤ + candidates * idealOriginUnionBound signatures sources := by + classical + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩ + calc + Pr[fun result => ∃ distinct ∈ Finset.Icc 1 14, + ∃ pattern : FewTimePattern signatures distinct, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | run] ≤ + ∑ distinct ∈ Finset.Icc 1 14, + Pr[fun result => + ∃ pattern : FewTimePattern signatures distinct, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | run] := + probEvent_exists_finset_le_sum (Finset.Icc 1 14) run fun distinct result => + ∃ pattern : FewTimePattern signatures distinct, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result + _ ≤ ∑ distinct ∈ Finset.Icc 1 14, + ∑ pattern : FewTimePattern signatures distinct, + Pr[fun result => + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | run] := by + apply Finset.sum_le_sum + intro distinct _ + calc + _ = Pr[fun result => + ∃ pattern ∈ (Finset.univ : Finset (FewTimePattern signatures distinct)), + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | run] := by + congr 1 + funext result + simp + _ ≤ _ := probEvent_exists_finset_le_sum Finset.univ run fun pattern result => + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result + _ ≤ ∑ distinct ∈ Finset.Icc 1 14, + ∑ pattern : FewTimePattern signatures distinct, + ∑ configuration : OriginConfiguration pattern sources, + Pr[fun result => ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | run] := by + apply Finset.sum_le_sum + intro distinct _ + apply Finset.sum_le_sum + intro pattern _ + calc + _ = Pr[fun result => + ∃ configuration ∈ + (Finset.univ : Finset (OriginConfiguration pattern sources)), + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | run] := by + congr 1 + funext result + simp + _ ≤ _ := probEvent_exists_finset_le_sum Finset.univ run fun configuration result => + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result + _ ≤ ∑ distinct ∈ Finset.Icc 1 14, + ∑ pattern : FewTimePattern signatures distinct, + ∑ configuration : OriginConfiguration pattern sources, + candidates * Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] := by + apply Finset.sum_le_sum + intro distinct _ + apply Finset.sum_le_sum + intro pattern _ + apply Finset.sum_le_sum + intro configuration _ + exact probEvent_exists_fixedOrdinal_viewedEvent_le_ideal configuration secretKey + computation initialCache q hq hcache candidates + (viewedEvent distinct pattern configuration) + (himp distinct pattern configuration) + _ = candidates * idealOriginUnionBound signatures sources := by + rw [idealOriginUnionBound] + simp_rw [← Finset.mul_sum] + +def FixedOriginTargetViewedTerminal + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (q : Nat) + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (candidate : Nat) + (result : α × ViewedFullTraceState) : Prop := + QueryCache.enncard result.2.cache ≤ q ∧ + ∀ monitored : α × OriginTargetMonitorState configuration, + monitored ∈ support + ((simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey candidate) + computation).run (OriginTargetMonitorState.initial configuration initialCache)) → + (monitored.1, monitored.2.origin.viewed) = result → + monitored.2.Complete ∧ + ∀ target, monitored.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (monitored.2.origin.observation.views, target) + +noncomputable instance + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (q : Nat) + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (candidate : Nat) : + DecidablePred + (FixedOriginTargetViewedTerminal secretKey computation initialCache q + configuration candidate) := + fun result => Classical.propDecidable + (FixedOriginTargetViewedTerminal secretKey computation initialCache q + configuration candidate result) + +@[irreducible] def SomeFixedOriginTargetViewedTerminal + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q candidates : Nat) + (result : α × ViewedFullTraceState) : Prop := + ∃ distinct ∈ Finset.Icc 1 14, + ∃ pattern : FewTimePattern signatures distinct, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + FixedOriginTargetViewedTerminal secretKey computation initialCache q + configuration candidate.val result + +noncomputable instance + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q candidates : Nat) : + DecidablePred (SomeFixedOriginTargetViewedTerminal secretKey computation + initialCache signatures sources q candidates) := + fun result => Classical.propDecidable + (SomeFixedOriginTargetViewedTerminal secretKey computation initialCache + signatures sources q candidates result) + +theorem probEvent_exists_fixedOriginTargetViewedTerminal_le_idealOrigin_of_candidates + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q : Nat) + (hq : q ≤ 2 ^ 120) (hcache : QueryCache.enncard initialCache ≤ q) + (candidates : Nat) : + Pr[SomeFixedOriginTargetViewedTerminal secretKey computation initialCache + signatures sources q candidates | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] ≤ + candidates * idealOriginUnionBound signatures sources := by + unfold SomeFixedOriginTargetViewedTerminal + apply probEvent_exists_originConfiguration_fixedOrdinal_viewedEvent_le_idealOrigin + secretKey computation initialCache signatures sources q hq hcache candidates + (fun _ _ configuration candidate => + FixedOriginTargetViewedTerminal secretKey computation initialCache q + configuration candidate.val) + intro distinct pattern configuration candidate result hresult hevent + obtain ⟨hcacheFinal, hterminal⟩ := hevent + have hprojection : (result.1, result.2.origin.viewed) = + (result.1, result.2.origin.viewed) := rfl + obtain ⟨hcomplete, hhit⟩ := hterminal result hresult hprojection + exact ⟨hcomplete, hhit, hcacheFinal⟩ + +theorem probEvent_exists_fixedOriginTargetViewedTerminal_le_idealOrigin + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q : Nat) + (hq : q ≤ 2 ^ 120) (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[fun result => ∃ distinct ∈ Finset.Icc 1 14, + ∃ pattern : FewTimePattern signatures distinct, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin q, + FixedOriginTargetViewedTerminal secretKey computation initialCache q + configuration candidate.val result | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] ≤ + q * idealOriginUnionBound signatures sources := by + apply probEvent_exists_originConfiguration_fixedOrdinal_viewedEvent_le_idealOrigin + secretKey computation initialCache signatures sources q hq hcache q + (fun _ _ configuration candidate => + FixedOriginTargetViewedTerminal secretKey computation initialCache q + configuration candidate.val) + intro distinct pattern configuration candidate result hresult hevent + obtain ⟨hcacheFinal, hterminal⟩ := hevent + obtain ⟨hcomplete, hhit⟩ := hterminal result hresult rfl + exact ⟨hcomplete, hhit, hcacheFinal⟩ + +theorem OriginConfiguration.target_monitored_complete_of_projection + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hproper : ProperFewTimeLeak f result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest)) + {limit sources : Nat} (hle : result.2.trace.signing.toSigningLog.length ≤ limit) + (configuration : OriginConfiguration (hproper.1.cover.pattern.pad hle) sources) + (hrealized : configuration.PaddedRealizedBy hproper.1.cover hle result.2.trace rfl) + (source : Fin result.2.trace.intervals.length) + (hcandidate : FreshTargetCandidate + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + (result.2.trace.intervals.get source)) + (hsourceView : targetCandidateIntervalView result.2 source = + fewTimeTargetView (digestIndex digest) (digestLeaves digest)) + (hallowed : targetCandidateIntervalAllowed configuration result.2 source = true) + (targetOrdinal : Nat) + (htargetOrdinal : targetOrdinal = result.2.trace.intervals.countPBefore + (fun entry => decide (FreshTargetCandidate + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ entry)) source.val) + (rootCache : QueryCache HashSpec) + (monitored : Forgery × OriginTargetMonitorState configuration) + (hmonitored : monitored ∈ support + ((simulateQ + (originTargetMonitoredAdversaryImpl configuration + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ targetOrdinal) + (adversary.main ⟨result.1.1, parameter⟩)).run + (OriginTargetMonitorState.initial configuration rootCache))) + (htrace : result.2.trace = monitored.2.origin.viewed.trace) + (hviews : result.2.views = monitored.2.origin.viewed.views) : + monitored.2.Complete ∧ + ∀ target, monitored.2.targetView = some target → + FixedFewTimePatternHit (hproper.1.cover.pattern.pad hle).assignment + (monitored.2.origin.observation.views, target) := by + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + let monitoredPosition := castTracePosition result.2 monitored.2.origin.viewed + htrace source + have hcandidateMonitored : FreshTargetCandidate secretKey + (monitored.2.origin.viewed.trace.intervals.get monitoredPosition) := by + rw [get_castTracePosition result.2 monitored.2.origin.viewed htrace source] + exact hcandidate + have hviewMonitored : targetCandidateIntervalView monitored.2.origin.viewed + monitoredPosition = fewTimeTargetView (digestIndex digest) (digestLeaves digest) := by + rw [targetCandidateIntervalView_castTracePosition result.2 + monitored.2.origin.viewed htrace hviews source] + exact hsourceView + have hallowedMonitored : targetCandidateIntervalAllowed configuration + monitored.2.origin.viewed monitoredPosition = true := by + rw [targetCandidateIntervalAllowed_castTracePosition configuration result.2 + monitored.2.origin.viewed htrace source] + exact hallowed + have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hresult, rfl⟩ + have hinvariants := gameAfterSecretsWithFullTrace_support_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hintervals := gameAfterSecretsWithFullTrace_support_interval_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hvalidIntervals := gameAfterSecretsWithFullTrace_support_validIntervals adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have htraceCoherent := originTargetMonitoredAdversaryImpl_candidateTraceCoherent + configuration secretKey targetOrdinal (adversary.main ⟨result.1.1, parameter⟩) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateTraceCoherent_initial configuration secretKey rootCache) + hmonitored + have hallowedTraceCoherent := + originTargetMonitoredAdversaryImpl_candidateAllowedTraceCoherent + configuration secretKey targetOrdinal (adversary.main ⟨result.1.1, parameter⟩) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateAllowedTraceCoherent_initial + configuration secretKey rootCache) + hmonitored + have hviewsCoherent := originTargetMonitoredAdversaryImpl_candidateViewsCoherent + configuration secretKey targetOrdinal (adversary.main ⟨result.1.1, parameter⟩) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateViewsCoherent_initial configuration rootCache + targetOrdinal) hmonitored + have hallowedCoherent := originTargetMonitoredAdversaryImpl_candidateAllowedCoherent + configuration secretKey targetOrdinal (adversary.main ⟨result.1.1, parameter⟩) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateAllowedCoherent_initial configuration rootCache + targetOrdinal) hmonitored + have htargetOrdinalMonitored : targetOrdinal = + monitored.2.origin.viewed.trace.intervals.countPBefore + (fun entry => decide (FreshTargetCandidate secretKey entry)) + monitoredPosition.val := by + rw [htargetOrdinal] + rw [List.countPBefore_eq_countP_take, List.countPBefore_eq_countP_take, + take_castTracePosition result.2 monitored.2.origin.viewed htrace source] + obtain ⟨hlogMonitored, hrealizedMonitored⟩ := + configuration.paddedRealized_transport result.2.trace + monitored.2.origin.viewed.trace htrace rfl hrealized + have hvalidIntervalsMonitored : + monitored.2.origin.viewed.trace.ValidIntervals secretKey := by + rw [← htrace] + exact hvalidIntervals + have hchronologicalMonitored : FullAdversaryTrace.Chronological + monitored.2.origin.viewed.trace.intervals := by + rw [← htrace] + exact hintervals.2.2 + have hcachesMonitored : monitored.2.origin.viewed.trace.signing.CachesLe + result.2.cache := by + rw [← htrace] + exact hinvariants.2.1 + exact configuration.paddedRealized_target_complete_and_hit + hlogMonitored hrealizedMonitored htraceCoherent.1 hvalidIntervalsMonitored + hchronologicalMonitored hcachesMonitored hf monitoredPosition hcandidateMonitored + hviewMonitored hallowedMonitored (by rwa [← htargetOrdinalMonitored]) + htraceCoherent.2 (by rwa [← htargetOrdinalMonitored]) hallowedTraceCoherent.2 + +theorem FullAdversaryTrace.CacheChain.finish_lookup_eq + (input : HashInput) {leftStart rightStart leftFinish rightFinish : QueryCache HashSpec} + {intervals : List AdversaryCacheEntry} + (hstart : leftStart input = rightStart input) + (hleft : FullAdversaryTrace.CacheChain leftStart intervals leftFinish) + (hright : FullAdversaryTrace.CacheChain rightStart intervals rightFinish) : + leftFinish input = rightFinish input := by + induction intervals generalizing leftStart rightStart with + | nil => + simp only [FullAdversaryTrace.CacheChain] at hleft hright + subst leftFinish + subst rightFinish + exact hstart + | cons entry rest ih => + obtain ⟨_, hleft⟩ := hleft + obtain ⟨_, hright⟩ := hright + exact ih rfl hleft hright + +def VerifierFreshTarget (parameter : PublicParameter) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : Prop := + let input := tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) + ∃ (rootCache adversaryCache digestCache : QueryCache HashSpec) (output : HashOutput), + (∀ payload, rootCache (tweakableHashInput parameter .message payload) = none) + ∧ FullAdversaryTrace.CacheChain rootCache result.2.trace.intervals adversaryCache + ∧ adversaryCache input = none + ∧ (output, digestCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) (oracleHash input)).run + adversaryCache) + ∧ digestCache ≤ result.2.cache + ∧ result.2.targetView = some (hashOutputFewTimeView output) + +noncomputable instance (parameter : PublicParameter) : + DecidablePred (VerifierFreshTarget parameter) := + fun result => Classical.propDecidable (VerifierFreshTarget parameter result) + +def ViewedProperFewTimeLeakWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : Prop := + ∃ (f : QueryImpl HashSpec Id) (digest : MessageDigest), + result.2.cache.AgreesWithFn f + ∧ SigningTranscript.Valid result.2.trace.signing.toSigningLog + ∧ ¬SigningTranscript.Contains result.2.trace.signing.toSigningLog result.1.2.1 + ∧ evalWithAnswerFn f + (messageDigest parameter result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) = digest + ∧ Admissible digest + ∧ ProperFewTimeLeak f result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest) + +noncomputable instance (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + DecidablePred (ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret) := + fun result => Classical.propDecidable + (ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result) + +theorem directHashQueries_append (left right : QueryLog (OracleWorld + SigningSpec)) : + directHashQueries (left ++ right) = + directHashQueries left ++ directHashQueries right := by + induction left with + | nil => rfl + | cons head rest ih => + obtain ⟨input, output⟩ := head + rcases input with worldInput | request + · rcases worldInput with uniformInput | hashInput <;> + simp [directHashQueries, ih] + · simp [directHashQueries, ih] + +theorem OriginConfiguration.paddedRealized_append_direct + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + {cover : FewTimeCover f cache secretKey signingLog index targetLeaves} + {q limit : Nat} {hle : signingLog.length ≤ limit} + {configuration : OriginConfiguration (cover.pattern.pad hle) q} + (state : ViewedFullTraceState) + (hlog : state.trace.signing.toSigningLog = signingLog) + (hrealized : configuration.PaddedRealizedBy cover hle state.trace hlog) + (input : HashInput) (output : HashOutput) (finalCache : QueryCache HashSpec) : + let appended := appendTargetViewedState (.inl (.inr input)) state.cache output + finalCache none state + ∃ hlog' : appended.trace.signing.toSigningLog = signingLog, + configuration.PaddedRealizedBy cover hle appended.trace hlog' := by + classical + let appended := appendTargetViewedState (.inl (.inr input)) state.cache output + finalCache none state + have hlog' : appended.trace.signing.toSigningLog = signingLog := by + simpa [appended, appendTargetViewedState, fullAdversaryTraceUpdate, + signingCacheTraceUpdate] using hlog + refine ⟨hlog', ?_⟩ + have hlogEq : hlog' = hlog := Subsingleton.elim _ _ + subst hlog' + constructor + · exact hrealized.1 + · intro entry hselected + obtain ⟨sourceOutput, sourcePosition, intervalPosition, selectedIntervalPosition, + hdirect, hsource, hordinal, hbefore, hselectedInterval, hselectedRank, + hinput, hinitial, hquery, hadmissible, hview⟩ := hrealized.2 entry hselected + let sourcePosition' : Fin appended.trace.hashQueries.length := + ⟨sourcePosition.val, by + simp [appended, appendTargetViewedState, fullAdversaryTraceUpdate, + FullAdversaryTrace.hashQueries, directHashQueries_append, directHashQueries]⟩ + let intervalPosition' : Fin appended.trace.intervals.length := + ⟨intervalPosition.val, by + simp [appended, appendTargetViewedState, fullAdversaryTraceUpdate]⟩ + let selectedIntervalPosition' : Fin appended.trace.intervals.length := + ⟨selectedIntervalPosition.val, by + simp [appended, appendTargetViewedState, fullAdversaryTraceUpdate]⟩ + have hinterval : appended.trace.intervals.get intervalPosition' = + state.trace.intervals.get intervalPosition := by + simp [appended, appendTargetViewedState, fullAdversaryTraceUpdate, + intervalPosition', List.get_eq_getElem, + List.getElem_append_left intervalPosition.isLt] + have hselectedInterval' : appended.trace.intervals.get selectedIntervalPosition' = + state.trace.intervals.get selectedIntervalPosition := by + simp [appended, appendTargetViewedState, fullAdversaryTraceUpdate, + selectedIntervalPosition', List.get_eq_getElem, + List.getElem_append_left selectedIntervalPosition.isLt] + have hdirect' : isDirectHashQuery + (appended.trace.intervals.get intervalPosition').input := by + rwa [hinterval] + refine ⟨sourceOutput, sourcePosition', intervalPosition', selectedIntervalPosition', + hdirect', ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · exact hsource + · calc + sourcePosition'.val = sourcePosition.val := rfl + _ = (Fin.encodeSubtype (fun position => + isDirectHashQuery (state.trace.intervals.get position).input) + ⟨intervalPosition, hdirect⟩).val := hordinal + _ = directIntervalCount (state.trace.intervals.take intervalPosition.val) := + encodeSubtype_directInterval_eq state.trace.intervals intervalPosition hdirect + _ = directIntervalCount + (appended.trace.intervals.take intervalPosition'.val) := by + simp [appended, appendTargetViewedState, fullAdversaryTraceUpdate, + intervalPosition', List.take_append_of_le_length intervalPosition.isLt.le] + _ = (Fin.encodeSubtype (fun position => + isDirectHashQuery (appended.trace.intervals.get position).input) + ⟨intervalPosition', hdirect'⟩).val := + (encodeSubtype_directInterval_eq appended.trace.intervals + intervalPosition' hdirect').symm + · exact hbefore + · rwa [hselectedInterval'] + · simpa [appended, appendTargetViewedState, fullAdversaryTraceUpdate, + selectedIntervalPosition', List.take_append_of_le_length + selectedIntervalPosition.isLt.le] using hselectedRank + · rwa [hinterval] + · rwa [hinterval] + · rw [hinterval] + exact hquery + · exact hadmissible + · exact hview + +theorem OriginConfiguration.paddedRealized_sourceAt_directIntervalCount_eq_none + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + {cover : FewTimeCover f cache secretKey signingLog index targetLeaves} + {q limit : Nat} {hle : signingLog.length ≤ limit} + {configuration : OriginConfiguration (cover.pattern.pad hle) q} + {trace : FullAdversaryTrace} {hlog : trace.signing.toSigningLog = signingLog} + (hrealized : configuration.PaddedRealizedBy cover hle trace hlog) : + configuration.sourceAt? (directIntervalCount trace.intervals) = none := by + cases hlookup : configuration.sourceAt? (directIntervalCount trace.intervals) with + | none => rfl + | some selected => + have heq := (configuration.sourceAt?_eq_some_iff _ selected).1 hlookup + have hlt := configuration.paddedRealized_source_lt_directIntervalCount + hrealized selected + omega + +def adversaryWithTargetQuery (adversary : Adversary) (publicKey : PublicKey) : + OracleComp (OracleWorld + SigningSpec) (Forgery × HashOutput) := do + let forgery ← adversary.main publicKey + let input := tweakableHashInput publicKey.parameter .message + (messageDigestPayload publicKey.root forgery.message forgery.signature.randomness) + let output ← OracleComp.liftComp + (OracleComp.liftComp + (liftM (HashSpec.query input) : OracleComp HashSpec HashOutput) OracleWorld) + (OracleWorld + SigningSpec) + pure (forgery, output) + +def appendDirectTargetViewedState (input : HashInput) + (initialCache : QueryCache HashSpec) (output : HashOutput) + (finalCache : QueryCache HashSpec) (state : ViewedFullTraceState) : + ViewedFullTraceState := + appendTargetViewedState (.inl (.inr input)) initialCache output finalCache none state + +def verifyWithViewAfterOutput (publicKey : PublicKey) (signature : Signature) + (output : HashOutput) : OracleComp HashSpec (Bool × FewTimeView) := + let digest := truncateMessageDigest output + let view := hashOutputFewTimeView output + if ¬ Admissible digest then + pure (false, view) + else do + let ftsPublicKey ← ftsRecover publicKey.parameter (digestIndex digest) + (digestLeaves digest) signature.ftsSecret signature.ftsPath + match ← verifyLayers publicKey.parameter (digestIndex digest) signature numLayers + ftsPublicKey with + | none => pure (false, view) + | some root => pure (decide (root = publicKey.root), view) + +theorem verifyWithView_split_run (publicKey : PublicKey) (message : Message) + (signature : Signature) (cache : QueryCache HashSpec) : + (simulateQ romImpl + (liftM (verifyWithView publicKey message signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run cache = + (randomOracle (tweakableHashInput publicKey.parameter .message + (messageDigestPayload publicKey.root message signature.randomness))).run cache >>= + fun source => + (simulateQ romImpl + (liftM (verifyWithViewAfterOutput publicKey signature source.1) : + OracleComp OracleWorld (Bool × FewTimeView))).run source.2 := by + let input := tweakableHashInput publicKey.parameter .message + (messageDigestPayload publicKey.root message signature.randomness) + have hqueryRun : + (simulateQ (randomOracle : QueryImpl HashSpec _) + (oracleHash input)).run cache = (randomOracle input).run cache := by + change (simulateQ (randomOracle : QueryImpl HashSpec _) + (liftM (HashSpec.query input))).run cache = _ + rw [simulateQ_spec_query] + simp only [simulateQ_romImpl_liftM] + rw [verifyWithView, simulateQ_bind, StateT.run_bind] + rw [show tweakableHashInput publicKey.parameter .message + (messageDigestPayload publicKey.root message signature.randomness) = input from rfl, + hqueryRun] + rfl + +theorem adversaryWithTargetQuery_viewed_run + (adversary : Adversary) (publicKey : PublicKey) (secretKey : SecretKey) + (rootCache : QueryCache HashSpec) : + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversaryWithTargetQuery adversary publicKey)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩ = (do + let (forgery, state) ← + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run ⟨rootCache, ⟨[], [], []⟩, [], none⟩ + let input := tweakableHashInput publicKey.parameter .message + (messageDigestPayload publicKey.root forgery.message forgery.signature.randomness) + let (output, finalCache) ← (randomOracle input).run state.cache + pure ((forgery, output), appendDirectTargetViewedState input + state.cache output finalCache state)) := by + rw [adversaryWithTargetQuery, simulateQ_bind, StateT.run_bind] + apply bind_congr + rintro ⟨forgery, state⟩ + rw [simulateQ_bind, StateT.run_bind] + let input := tweakableHashInput publicKey.parameter .message + (messageDigestPayload publicKey.root forgery.message forgery.signature.randomness) + have hsingle : + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (OracleComp.liftComp + (OracleComp.liftComp + (liftM (HashSpec.query input) : OracleComp HashSpec HashOutput) OracleWorld) + (OracleWorld + SigningSpec))).run state = + (fun result => (result.1, appendDirectTargetViewedState input state.cache + result.1 result.2 state)) <$> (randomOracle input).run state.cache := by + let worldImpl : QueryImpl OracleWorld (StateT ViewedFullTraceState ProbComp) := + fun worldInput => viewedFullTracedMappedAdversaryImpl secretKey (.inl worldInput) + let signingImpl : QueryImpl SigningSpec (StateT ViewedFullTraceState ProbComp) := + fun request => viewedFullTracedMappedAdversaryImpl secretKey (.inr request) + have houter : viewedFullTracedMappedAdversaryImpl secretKey = + worldImpl + signingImpl := by + funext queryInput + cases queryInput <;> rfl + have houterSim := QueryImpl.simulateQ_add_liftComp_left worldImpl signingImpl + (OracleComp.liftComp + (liftM (HashSpec.query input) : OracleComp HashSpec HashOutput) OracleWorld) + let uniformImpl : QueryImpl unifSpec (StateT ViewedFullTraceState ProbComp) := + fun uniformInput => worldImpl (.inl uniformInput) + let hashImpl : QueryImpl HashSpec (StateT ViewedFullTraceState ProbComp) := + fun hashInput => worldImpl (.inr hashInput) + have hworld : worldImpl = uniformImpl + hashImpl := by + funext worldInput + cases worldInput <;> rfl + have hworldSim := QueryImpl.simulateQ_add_liftComp_right uniformImpl hashImpl + (liftM (HashSpec.query input) : OracleComp HashSpec HashOutput) + let directImpl : QueryImpl HashSpec (StateT ViewedFullTraceState ProbComp) := + fun hashInput current => + (fun queryResult => (queryResult.1, + ⟨queryResult.2, + fullAdversaryTraceUpdate (.inl (.inr hashInput)) current.cache + queryResult.1 queryResult.2 current.trace, + current.views, current.targetView⟩)) <$> + (randomOracle hashInput).run current.cache + have hhash : hashImpl = directImpl := by + funext hashInput current + dsimp [hashImpl, worldImpl] + rw [viewedFullTracedMappedAdversaryImpl] + rfl + calc + _ = (simulateQ (worldImpl + signingImpl) + (OracleComp.liftComp + (OracleComp.liftComp + (liftM (HashSpec.query input) : OracleComp HashSpec HashOutput) OracleWorld) + (OracleWorld + SigningSpec))).run state := by rw [← houter] + _ = (simulateQ worldImpl + (OracleComp.liftComp + (liftM (HashSpec.query input) : OracleComp HashSpec HashOutput) + OracleWorld)).run state := + congrArg (fun computation => computation.run state) houterSim + _ = (simulateQ (uniformImpl + hashImpl) + (OracleComp.liftComp + (liftM (HashSpec.query input) : OracleComp HashSpec HashOutput) + OracleWorld)).run state := by rw [← hworld] + _ = (simulateQ hashImpl + (liftM (HashSpec.query input) : OracleComp HashSpec HashOutput)).run state := + congrArg (fun computation => computation.run state) hworldSim + _ = _ := by + rw [hhash, simulateQ_spec_query] + rfl + rw [hsingle] + simp only [map_eq_bind_pure_comp, bind_assoc, pure_bind, Function.comp_apply] + apply bind_congr + rintro ⟨output, finalCache⟩ + rfl + +theorem adversaryWithTargetQuery_viewed_support + (adversary : Adversary) (publicKey : PublicKey) (secretKey : SecretKey) + (rootCache : QueryCache HashSpec) (forgery : Forgery) (state : ViewedFullTraceState) + (hadversary : (forgery, state) ∈ support + ((simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run ⟨rootCache, ⟨[], [], []⟩, [], none⟩)) + (output : HashOutput) (finalCache : QueryCache HashSpec) + (hquery : (output, finalCache) ∈ support + ((randomOracle (tweakableHashInput publicKey.parameter .message + (messageDigestPayload publicKey.root forgery.message + forgery.signature.randomness))).run state.cache)) : + ((forgery, output), appendTargetViewedState + (.inl (.inr (tweakableHashInput publicKey.parameter .message + (messageDigestPayload publicKey.root forgery.message + forgery.signature.randomness)))) + state.cache output finalCache none state) ∈ support + ((simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversaryWithTargetQuery adversary publicKey)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩) := by + rw [adversaryWithTargetQuery, simulateQ_bind, StateT.run_bind, + mem_support_bind_iff] + refine ⟨(forgery, state), hadversary, ?_⟩ + rw [simulateQ_bind, StateT.run_bind, mem_support_bind_iff] + let appended := appendTargetViewedState + (.inl (.inr (tweakableHashInput publicKey.parameter .message + (messageDigestPayload publicKey.root forgery.message forgery.signature.randomness)))) + state.cache output finalCache none state + refine ⟨(output, appended), ?_, ?_⟩ + · let input := tweakableHashInput publicKey.parameter .message + (messageDigestPayload publicKey.root forgery.message forgery.signature.randomness) + have hsingle : (output, appended) ∈ support + ((simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (OracleComp.liftComp + (OracleComp.liftComp + (liftM (HashSpec.query input) : OracleComp HashSpec HashOutput) OracleWorld) + (OracleWorld + SigningSpec))).run state) := by + let worldImpl : QueryImpl OracleWorld (StateT ViewedFullTraceState ProbComp) := + fun worldInput => viewedFullTracedMappedAdversaryImpl secretKey (.inl worldInput) + let signingImpl : QueryImpl SigningSpec (StateT ViewedFullTraceState ProbComp) := + fun request => viewedFullTracedMappedAdversaryImpl secretKey (.inr request) + have houter : viewedFullTracedMappedAdversaryImpl secretKey = + worldImpl + signingImpl := by + funext queryInput + cases queryInput <;> rfl + rw [houter] + have houterSim := QueryImpl.simulateQ_add_liftComp_left worldImpl signingImpl + (OracleComp.liftComp + (liftM (HashSpec.query input) : OracleComp HashSpec HashOutput) OracleWorld) + have houterRun := congrArg (fun computation => computation.run state) houterSim + have houterSupport := congrArg support houterRun + apply (Set.ext_iff.mp houterSupport (output, appended)).mpr + let uniformImpl : QueryImpl unifSpec (StateT ViewedFullTraceState ProbComp) := + fun uniformInput => worldImpl (.inl uniformInput) + let hashImpl : QueryImpl HashSpec (StateT ViewedFullTraceState ProbComp) := + fun hashInput => worldImpl (.inr hashInput) + have hworld : worldImpl = uniformImpl + hashImpl := by + funext worldInput + cases worldInput <;> rfl + rw [hworld] + have hworldSim := QueryImpl.simulateQ_add_liftComp_right uniformImpl hashImpl + (liftM (HashSpec.query input) : OracleComp HashSpec HashOutput) + have hworldRun := congrArg (fun computation => computation.run state) hworldSim + have hworldSupport := congrArg support hworldRun + apply (Set.ext_iff.mp hworldSupport (output, appended)).mpr + let directImpl : QueryImpl HashSpec (StateT ViewedFullTraceState ProbComp) := + fun hashInput current => + (fun queryResult => (queryResult.1, + ⟨queryResult.2, + fullAdversaryTraceUpdate (.inl (.inr hashInput)) current.cache + queryResult.1 queryResult.2 current.trace, + current.views, current.targetView⟩)) <$> + (randomOracle hashInput).run current.cache + have hhash : hashImpl = directImpl := by + funext hashInput current + dsimp [hashImpl, worldImpl] + rw [viewedFullTracedMappedAdversaryImpl] + rfl + rw [hhash, simulateQ_spec_query] + change (output, appended) ∈ support (directImpl input state) + dsimp only [directImpl] + rw [support_map] + refine ⟨(output, finalCache), hquery, ?_⟩ + simp [input, appendTargetViewedState, appendOriginReplayView, appended] + simpa only [Prod.fst, Prod.snd, input] using hsingle + · simp [appended] + +theorem viewedFullTracedMappedAdversaryImpl_interval_invariants + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (result : α × ViewedFullTraceState) + (hmem : result ∈ support + ((simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) computation).run + ⟨initialCache, ⟨[], [], []⟩, [], none⟩)) : + result.2.trace.Consistent ∧ result.2.trace.IntervalsLe result.2.cache ∧ + FullAdversaryTrace.Chronological result.2.trace.intervals := by + have hprojected : (result.1, result.2.base) ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl secretKey) computation).run + (initialCache, ⟨[], [], []⟩)) := by + have hmap : (result.1, result.2.base) ∈ support + (Prod.map id ViewedFullTraceState.base <$> + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) computation).run + ⟨initialCache, ⟨[], [], []⟩, [], none⟩) := by + rw [support_map] + exact ⟨result, hmem, rfl⟩ + rw [viewedFullTracedMappedAdversaryImpl_projection secretKey computation + ⟨initialCache, ⟨[], [], []⟩, [], none⟩] at hmap + exact hmap + exact fullTracedMappedAdversaryImpl_interval_invariants secretKey computation + initialCache ⟨[], [], []⟩ (result.1, result.2.base) + (by simp [FullAdversaryTrace.Consistent]) + (by simp [FullAdversaryTrace.IntervalsLe]) + (by simp [FullAdversaryTrace.Chronological]) hprojected + +theorem viewedFullTracedMappedAdversaryImpl_validIntervals + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (result : α × ViewedFullTraceState) + (hmem : result ∈ support + ((simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) computation).run + ⟨initialCache, ⟨[], [], []⟩, [], none⟩)) : + result.2.trace.ValidIntervals secretKey := by + have hprojected : (result.1, result.2.base) ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl secretKey) computation).run + (initialCache, ⟨[], [], []⟩)) := by + have hmap : (result.1, result.2.base) ∈ support + (Prod.map id ViewedFullTraceState.base <$> + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) computation).run + ⟨initialCache, ⟨[], [], []⟩, [], none⟩) := by + rw [support_map] + exact ⟨result, hmem, rfl⟩ + rw [viewedFullTracedMappedAdversaryImpl_projection secretKey computation + ⟨initialCache, ⟨[], [], []⟩, [], none⟩] at hmap + exact hmap + exact fullTracedMappedAdversaryImpl_validIntervals secretKey computation + initialCache ⟨[], [], []⟩ (result.1, result.2.base) + (by simp [FullAdversaryTrace.ValidIntervals]) hprojected + +theorem OriginConfiguration.verifierTarget_fixedTerminal + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hproper : ProperFewTimeLeak f result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest)) + {limit sources : Nat} (hle : result.2.trace.signing.toSigningLog.length ≤ limit) + (configuration : OriginConfiguration (hproper.1.cover.pattern.pad hle) sources) + (hrealized : configuration.PaddedRealizedBy hproper.1.cover hle result.2.trace rfl) + (rootCache : QueryCache HashSpec) (state : ViewedFullTraceState) + (hadversary : (result.1.2.1, state) ∈ support + ((simulateQ (viewedFullTracedMappedAdversaryImpl + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩) + (adversary.main ⟨result.1.1, parameter⟩)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩)) + (htrace : result.2.trace = state.trace) (hviews : result.2.views = state.views) + (input : HashInput) (output : HashOutput) (digestCache : QueryCache HashSpec) + (hinput : input = tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness)) + (hmiss : state.cache input = none) + (hquery : (output, digestCache) ∈ support ((randomOracle input).run state.cache)) + (_hdigestCache : digestCache ≤ result.2.cache) + (htargetView : hashOutputFewTimeView output = + fewTimeTargetView (digestIndex digest) (digestLeaves digest)) + (q : Nat) (hcache : QueryCache.enncard digestCache ≤ q) : + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + let publicKey : PublicKey := ⟨result.1.1, parameter⟩ + let appended := appendTargetViewedState (.inl (.inr input)) state.cache output + digestCache none state + let targetOrdinal := freshTargetCandidateCount secretKey state.trace + FixedOriginTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache q configuration + targetOrdinal ((result.1.2.1, output), appended) := by + classical + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + let publicKey : PublicKey := ⟨result.1.1, parameter⟩ + let appended := appendTargetViewedState (.inl (.inr input)) state.cache output + digestCache none state + let targetOrdinal := freshTargetCandidateCount secretKey state.trace + have haugmented : ((result.1.2.1, output), appended) ∈ support + ((simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversaryWithTargetQuery adversary publicKey)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩) := by + subst input + exact adversaryWithTargetQuery_viewed_support adversary publicKey secretKey + rootCache result.1.2.1 state hadversary output digestCache hquery + refine ⟨hcache, ?_⟩ + intro monitored hmonitored heq + have hstateEq : monitored.2.origin.viewed = appended := + congrArg Prod.snd heq + have hstateTraceEq : appended.trace = monitored.2.origin.viewed.trace := + congrArg ViewedFullTraceState.trace hstateEq.symm + have hstateViewsEq : appended.views = monitored.2.origin.viewed.views := + congrArg ViewedFullTraceState.views hstateEq.symm + let appendedPosition : Fin appended.trace.intervals.length := + ⟨state.trace.intervals.length, by + simp [appended, appendTargetViewedState, fullAdversaryTraceUpdate]⟩ + let monitoredPosition := castTracePosition appended monitored.2.origin.viewed + hstateTraceEq appendedPosition + have hcandidateEntry : FreshTargetCandidate secretKey + (⟨.inl (.inr input), output, state.cache, digestCache⟩ : AdversaryCacheEntry) := by + exact (freshTargetCandidate_direct_iff secretKey input output state.cache digestCache + hquery).2 hmiss + have hcandidate : FreshTargetCandidate secretKey + (appended.trace.intervals.get appendedPosition) := by + simpa [appendedPosition, appended, appendTargetViewedState, + fullAdversaryTraceUpdate] using hcandidateEntry + have hcandidateMonitored : FreshTargetCandidate secretKey + (monitored.2.origin.viewed.trace.intervals.get monitoredPosition) := by + rw [get_castTracePosition appended monitored.2.origin.viewed hstateTraceEq + appendedPosition] + exact hcandidate + have hvalidViewsState : state.ValidViews secretKey := by + have hvalid := gameAfterSecretsWithViewTrace_support_validViews adversary parameter + otsSecret ftsSecret result hresult + simpa only [ViewedFullTraceState.ValidViews, htrace, hviews] using hvalid + have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hresult, rfl⟩ + have hgameIntervals := gameAfterSecretsWithFullTrace_support_interval_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hconsistentState : state.trace.Consistent := by + rw [← htrace] + exact hgameIntervals.1 + have hview : targetCandidateIntervalView appended appendedPosition = + fewTimeTargetView (digestIndex digest) (digestLeaves digest) := by + rw [targetCandidateIntervalView_appendTargetViewedState_last secretKey state + hvalidViewsState hconsistentState] + exact htargetView + have hviewMonitored : targetCandidateIntervalView monitored.2.origin.viewed + monitoredPosition = fewTimeTargetView (digestIndex digest) (digestLeaves digest) := by + rw [targetCandidateIntervalView_castTracePosition appended + monitored.2.origin.viewed hstateTraceEq hstateViewsEq appendedPosition] + exact hview + have hsourceNone := configuration.paddedRealized_sourceAt_directIntervalCount_eq_none + hrealized + have hallowed : targetCandidateIntervalAllowed configuration appended appendedPosition = true := by + rw [targetCandidateIntervalAllowed_appendTargetViewedState_last configuration state + (.inl (.inr input)) state.cache output digestCache none] + simpa only [decide_eq_true_eq, htrace] using hsourceNone + have hallowedMonitored : targetCandidateIntervalAllowed configuration + monitored.2.origin.viewed monitoredPosition = true := by + rw [targetCandidateIntervalAllowed_castTracePosition configuration appended + monitored.2.origin.viewed hstateTraceEq appendedPosition] + exact hallowed + have htraceCoherent := originTargetMonitoredAdversaryImpl_candidateTraceCoherent + configuration secretKey targetOrdinal (adversaryWithTargetQuery adversary publicKey) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateTraceCoherent_initial configuration secretKey rootCache) + hmonitored + have hallowedTraceCoherent := + originTargetMonitoredAdversaryImpl_candidateAllowedTraceCoherent + configuration secretKey targetOrdinal (adversaryWithTargetQuery adversary publicKey) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateAllowedTraceCoherent_initial + configuration secretKey rootCache) hmonitored + have hviewsCoherent := originTargetMonitoredAdversaryImpl_candidateViewsCoherent + configuration secretKey targetOrdinal (adversaryWithTargetQuery adversary publicKey) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateViewsCoherent_initial configuration rootCache + targetOrdinal) hmonitored + have hallowedCoherent := originTargetMonitoredAdversaryImpl_candidateAllowedCoherent + configuration secretKey targetOrdinal (adversaryWithTargetQuery adversary publicKey) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateAllowedCoherent_initial configuration rootCache + targetOrdinal) hmonitored + have htargetOrdinal : targetOrdinal = + monitored.2.origin.viewed.trace.intervals.countPBefore + (fun entry => decide (FreshTargetCandidate secretKey entry)) + monitoredPosition.val := by + change freshTargetCandidateCount secretKey state.trace = _ + rw [List.countPBefore_eq_countP_take, + take_castTracePosition appended monitored.2.origin.viewed hstateTraceEq appendedPosition] + simp [appendedPosition, appended, appendTargetViewedState, fullAdversaryTraceUpdate, + freshTargetCandidateCount] + obtain ⟨hlogState, hrealizedState⟩ := + configuration.paddedRealized_transport result.2.trace state.trace htrace rfl hrealized + obtain ⟨hlogAppended, hrealizedAppended⟩ := + configuration.paddedRealized_append_direct state hlogState hrealizedState + input output digestCache + obtain ⟨hlogMonitored, hrealizedMonitored⟩ := + configuration.paddedRealized_transport appended.trace + monitored.2.origin.viewed.trace hstateTraceEq hlogAppended hrealizedAppended + have haugmentedIntervals := viewedFullTracedMappedAdversaryImpl_interval_invariants + secretKey (adversaryWithTargetQuery adversary publicKey) rootCache + ((result.1.2.1, output), appended) haugmented + have haugmentedValid := viewedFullTracedMappedAdversaryImpl_validIntervals + secretKey (adversaryWithTargetQuery adversary publicKey) rootCache + ((result.1.2.1, output), appended) haugmented + have hcaches : appended.trace.signing.CachesLe result.2.cache := by + have hcachesState : state.trace.signing.CachesLe result.2.cache := by + rw [← htrace] + exact (gameAfterSecretsWithFullTrace_support_invariants adversary parameter + otsSecret ftsSecret (result.1, result.2.base) hbase).2.1 + simpa [appended, appendTargetViewedState, fullAdversaryTraceUpdate, + signingCacheTraceUpdate] using hcachesState + have hvalidIntervalsMonitored : + monitored.2.origin.viewed.trace.ValidIntervals secretKey := by + rw [← hstateTraceEq] + exact haugmentedValid + have hchronologicalMonitored : FullAdversaryTrace.Chronological + monitored.2.origin.viewed.trace.intervals := by + rw [← hstateTraceEq] + exact haugmentedIntervals.2.2 + have hcachesMonitored : monitored.2.origin.viewed.trace.signing.CachesLe + result.2.cache := by + rw [← hstateTraceEq] + exact hcaches + exact configuration.paddedRealized_target_complete_and_hit + hlogMonitored hrealizedMonitored htraceCoherent.1 + hvalidIntervalsMonitored hchronologicalMonitored hcachesMonitored hf + monitoredPosition hcandidateMonitored + hviewMonitored hallowedMonitored (by rwa [← htargetOrdinal]) htraceCoherent.2 + (by rwa [← htargetOrdinal]) hallowedTraceCoherent.2 + +theorem gameAfterSecretsWithViewTrace_proper_target_classified_at_adversary_state + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest parameter result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) = digest) + (hadmissible : Admissible digest) + (hproper : ProperFewTimeLeak f result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest)) + (hle : result.2.trace.signing.toSigningLog.length ≤ signatureLimit) + (rootCache : QueryCache HashSpec) (state : ViewedFullTraceState) + (htrace : result.2.trace = state.trace) (hviews : result.2.views = state.views) + (hstateCache : state.cache ≤ result.2.cache) : + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + VerifierFreshTarget parameter result ∨ + ∃ (distinct : Nat) (_ : distinct ∈ Finset.Icc 1 14) + (pattern : FewTimePattern signatureLimit distinct) + (configuration : OriginConfiguration pattern q) (candidate : Fin q), + FixedOriginTargetViewedTerminal secretKey + (adversary.main ⟨result.1.1, parameter⟩) rootCache q + configuration candidate.val (result.1.2.1, state) := by + classical + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + let targetPayload := messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness + let targetInput := tweakableHashInput parameter .message targetPayload + obtain ⟨sourceRootCache, adversaryCache, digestCache, output, hrootNone, hchain, hquery, + hdigestLe, + htargetView, horigin, _⟩ := + gameAfterSecretsWithViewTrace_target_source_kind adversary parameter otsSecret + ftsSecret result hresult + rcases horigin with hverifier | ⟨source, hsourceInitial, hsourceFinal, hkind⟩ + · exact Or.inl ⟨sourceRootCache, adversaryCache, digestCache, output, + hrootNone, hchain, by simpa only [targetInput, targetPayload] using hverifier, + by simpa only [targetInput, targetPayload] using hquery, hdigestLe, htargetView⟩ + · obtain ⟨sourceOutput, hcandidate, hsourceView, hsourceOutput, hattempt⟩ := + gameAfterSecretsWithViewTrace_target_source_candidate adversary parameter otsSecret + ftsSecret result hresult f hf digest hdigest hadmissible source + (by simpa only [targetInput, targetPayload] using hsourceInitial) + (by simpa only [targetInput, targetPayload] using hsourceFinal) + (by simpa only [targetInput, targetPayload] using hkind) + have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hresult, rfl⟩ + obtain ⟨configuration, hrealized⟩ := + hproper.1.cover.exists_paddedRealized_originConfiguration_of_queryBudget + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts + (result.1, result.2.base) hbase f hf (digestIndex digest) (digestLeaves digest) + signatureLimit hle + have hinvariants := gameAfterSecretsWithFullTrace_support_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hintervals := gameAfterSecretsWithFullTrace_support_interval_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hvalidIntervals := gameAfterSecretsWithFullTrace_support_validIntervals adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hvalidViews := gameAfterSecretsWithViewTrace_support_validViews adversary parameter + otsSecret ftsSecret result hresult + have hallowed : targetCandidateIntervalAllowed configuration result.2 source = true := + hproper.target_source_interval_allowed result.1.2.1 digest hdigest rfl result.2 rfl + hvalidViews hintervals.1 hinvariants.1 hinvariants.2.1 hf hle configuration + hrealized hvalidIntervals source sourceOutput + (by simpa only [targetInput, targetPayload] using hsourceInitial) + (by simpa only [targetInput, targetPayload] using hsourceOutput) + hattempt (by simpa only [targetInput, targetPayload] using hkind) + let targetOrdinal := result.2.trace.intervals.countPBefore + (fun entry => decide (FreshTargetCandidate secretKey entry)) source.val + have hordinalLt : targetOrdinal < freshTargetCandidateCount secretKey result.2.trace := by + apply List.countPBefore_lt_countP_of_lt_length_of_pos + exact decide_eq_true hcandidate + have hcountLe : freshTargetCandidateCount secretKey result.2.trace ≤ q := by + rw [freshTargetCandidateCount_eq_card] + have hbound := gameAfterSecretsWithViewTrace_freshTargetCandidatePositions_card_le + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts result hresult + exact_mod_cast hbound + let candidate : Fin q := ⟨targetOrdinal, hordinalLt.trans_le hcountLe⟩ + have hfinalCache : QueryCache.enncard result.2.cache ≤ q := + gameAfterSecretsWithFullTrace_support_enncard_le adversary q hq parameter hparameter + otsSecret hots ftsSecret hfts (result.1, result.2.base) hbase + have hviewedCache : QueryCache.enncard state.cache ≤ q := + (QueryCache.enncard_mono hstateCache).trans hfinalCache + refine Or.inr ⟨hproper.1.cover.entries.card, + Finset.mem_Icc.2 ⟨hproper.1.cover.entries_card_pos, + hproper.1.cover.entries_card_le_trees⟩, + hproper.1.cover.pattern.pad hle, configuration, candidate, hviewedCache, ?_⟩ + intro monitored hmonitored heq + have hstateEq : monitored.2.origin.viewed = state := congrArg Prod.snd heq + have htrace' : result.2.trace = monitored.2.origin.viewed.trace := by + rw [hstateEq] + exact htrace + have hviews' : result.2.views = monitored.2.origin.viewed.views := by + rw [hstateEq] + exact hviews + exact configuration.target_monitored_complete_of_projection adversary parameter + otsSecret ftsSecret result hresult f hf digest hproper hle hrealized source + hcandidate hsourceView hallowed targetOrdinal rfl rootCache monitored hmonitored + htrace' hviews' + +theorem gameAfterSecretsWithViewTrace_proper_target_classified + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest parameter result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) = digest) + (hadmissible : Admissible digest) + (hproper : ProperFewTimeLeak f result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest)) + (hle : result.2.trace.signing.toSigningLog.length ≤ signatureLimit) : + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + VerifierFreshTarget parameter result ∨ + ∃ (rootCache : QueryCache HashSpec) (state : ViewedFullTraceState) + (distinct : Nat) (_ : distinct ∈ Finset.Icc 1 14) + (pattern : FewTimePattern signatureLimit distinct) + (configuration : OriginConfiguration pattern q) (candidate : Fin q), + (result.1.2.1, state) ∈ support + ((simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversary.main ⟨result.1.1, parameter⟩)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩) + ∧ FixedOriginTargetViewedTerminal secretKey + (adversary.main ⟨result.1.1, parameter⟩) rootCache q + configuration candidate.val (result.1.2.1, state) := by + obtain ⟨rootCache, state, _, hadversary, htrace, hviews, hstateCache⟩ := + gameAfterSecretsWithViewTrace_support_adversary_state adversary parameter otsSecret + ftsSecret result hresult + rcases gameAfterSecretsWithViewTrace_proper_target_classified_at_adversary_state + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts result hresult + f hf digest hdigest hadmissible hproper hle rootCache state htrace + hviews hstateCache with hfresh | hclassified + · exact Or.inl hfresh + · obtain ⟨distinct, hdistinct, pattern, configuration, candidate, hterminal⟩ := + hclassified + exact Or.inr ⟨rootCache, state, distinct, hdistinct, pattern, configuration, + candidate, hadversary, hterminal⟩ + +theorem OracleComp.IsQueryBoundP.of_bind_left + {ι : Type} {spec : ι → Type} {oa : OracleComp spec α} + {ob : α → OracleComp spec β} {p : ι → Prop} [DecidablePred p] {q : Nat} + (hbound : (oa >>= ob).IsQueryBoundP p q) : oa.IsQueryBoundP p q := by + induction oa using OracleComp.inductionOn generalizing q with + | pure _ => trivial + | query_bind input continuation ih => + rw [bind_assoc, isQueryBoundP_query_bind_iff] at hbound + rw [isQueryBoundP_query_bind_iff] + exact ⟨hbound.1, fun output => ih output (hbound.2 output)⟩ + +theorem probEvent_bind_le_bind_of_forall_le + {mx : ProbComp α} {left : α → ProbComp β} {right : α → ProbComp γ} + {leftEvent : β → Prop} {rightEvent : γ → Prop} + (h : ∀ value ∈ support mx, + Pr[leftEvent | left value] ≤ Pr[rightEvent | right value]) : + Pr[leftEvent | mx >>= left] ≤ Pr[rightEvent | mx >>= right] := by + rw [probEvent_bind_eq_tsum, probEvent_bind_eq_tsum] + apply ENNReal.tsum_le_tsum + intro value + by_cases hvalue : value ∈ support mx + · exact mul_le_mul' le_rfl (h value hvalue) + · simp [probOutput_eq_zero_of_not_mem_support hvalue] + +theorem probEvent_gameRestWithViewTrace_nonfresh_proper_leak_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (root : Digest) (rootCache : QueryCache HashSpec) + (hroot : (root, rootCache) ∈ support + ((simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅)) : + Pr[fun rest => + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, rest.1.1, rest.1.2), rest.2) + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∧ ¬VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache] ≤ + q * idealOriginUnionBound signatureLimit q := by + classical + let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + let publicKey : PublicKey := ⟨root, parameter⟩ + let initialState : ViewedFullTraceState := + ⟨rootCache, ⟨[], [], []⟩, [], none⟩ + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState + let finish : Forgery × ViewedFullTraceState → + ProbComp ((Forgery × Bool) × ViewedFullTraceState) := fun prior => do + let ((verified, targetView), finalCache) ← + (simulateQ romImpl + (liftM (verifyWithView publicKey prior.1.message prior.1.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run prior.2.cache + let log := prior.2.trace.signing.toSigningLog + let verdict := decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log prior.1) && verified + pure ((prior.1, verdict), + ⟨finalCache, prior.2.trace, prior.2.views, some targetView⟩) + let prefixEvent := fun prior : Forgery × ViewedFullTraceState => + ∃ distinct ∈ Finset.Icc 1 14, + ∃ pattern : FewTimePattern signatureLimit distinct, + ∃ configuration : OriginConfiguration pattern q, + ∃ candidate : Fin q, + FixedOriginTargetViewedTerminal secretKey (adversary.main publicKey) + rootCache q configuration candidate.val prior + have hgame : gameRestWithViewTrace adversary publicKey secretKey rootCache = + run >>= finish := by + rfl + rw [show ⟨root, parameter⟩ = publicKey from rfl, + show ⟨parameter, root, otsSecret, ftsSecret⟩ = secretKey from rfl, hgame] + calc + _ ≤ Pr[prefixEvent | run] := by + apply probEvent_bind_le_probEvent + intro prior hprior hnotPrefix + rcases prior with ⟨forgery, state⟩ + apply probEvent_eq_zero + intro rest hrest hevent + rw [mem_support_bind_iff] at hrest + obtain ⟨⟨⟨verified, targetView⟩, finalCache⟩, hverify, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst rest + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) + have hrestSupport : + ((forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) ∈ + support (gameRestWithViewTrace adversary publicKey secretKey rootCache) := by + rw [hgame, mem_support_bind_iff] + refine ⟨(forgery, state), hprior, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨((verified, targetView), finalCache), hverify, + by simp only [support_pure, Set.mem_singleton_iff]⟩ + have hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret) := by + rw [gameAfterSecretsWithViewTrace, mem_support_bind_iff] + refine ⟨(root, rootCache), hroot, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨_, hrestSupport, by simp [result]⟩ + obtain ⟨f, digest, hf, hvalid, _, hdigest, hadmissible, hproper⟩ := hevent.1 + have hcacheLe : state.cache ≤ finalCache := + simulateQ_romImpl_cache_le + (liftM (verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView)) state.cache + ((verified, targetView), finalCache) hverify + rcases gameAfterSecretsWithViewTrace_proper_target_classified_at_adversary_state + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts result hresult + f hf digest hdigest hadmissible hproper hvalid rootCache state rfl rfl hcacheLe with + hfresh | hclassified + · exact hevent.2 hfresh + · obtain ⟨distinct, hdistinct, pattern, configuration, candidate, hterminal⟩ := + hclassified + apply hnotPrefix + exact ⟨distinct, hdistinct, pattern, configuration, candidate, hterminal⟩ + _ ≤ _ := probEvent_exists_fixedOriginTargetViewedTerminal_le_idealOrigin + secretKey (adversary.main publicKey) rootCache signatureLimit q q hqMax + (by + have hroot' : QueryCache.enncard rootCache ≤ q := by + have hprojected : (root, rootCache) ∈ support + ((simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅) := hroot + have hgameBound := isQueryBoundP_gameAfterSecrets adversary q hq + hparameter hots hfts + rw [gameAfterSecrets] at hgameBound + have hrootBound := OracleComp.IsQueryBoundP.of_bind_left + (p := fun input : OracleWorld.Domain => input matches Sum.inr _) hgameBound + have hbound := simulateQ_romImpl_enncard_le_queryBound + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest) q + hrootBound + (root, rootCache) hprojected + exact hbound + exact hroot') + +set_option maxRecDepth 1000000 in +set_option maxHeartbeats 2000000 in +theorem probEvent_gameRestWithViewTrace_fresh_proper_leak_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (root : Digest) (rootCache : QueryCache HashSpec) + (hroot : (root, rootCache) ∈ support + ((simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅)) : + Pr[fun rest => + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, rest.1.1, rest.1.2), rest.2) + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∧ VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache] ≤ + ((q + 1 : Nat) : ℝ≥0∞) * idealOriginUnionBound signatureLimit q := by + classical + let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + let publicKey : PublicKey := ⟨root, parameter⟩ + let initialState : ViewedFullTraceState := + ⟨rootCache, ⟨[], [], []⟩, [], none⟩ + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState + let finish : Forgery × ViewedFullTraceState → + ProbComp ((Forgery × Bool) × ViewedFullTraceState) := fun prior => do + let ((verified, targetView), finalCache) ← + (simulateQ romImpl + (liftM (verifyWithView publicKey prior.1.message prior.1.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run prior.2.cache + let log := prior.2.trace.signing.toSigningLog + let verdict := decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log prior.1) && verified + pure ((prior.1, verdict), + ⟨finalCache, prior.2.trace, prior.2.views, some targetView⟩) + let freshEvent := fun rest : (Forgery × Bool) × ViewedFullTraceState => + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, rest.1.1, rest.1.2), rest.2) + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result + have hrootNone : ∀ payload, + rootCache (tweakableHashInput parameter .message payload) = none := by + have hroot' : (root, rootCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅) := by + simpa only [simulateQ_romImpl_liftM] using hroot + exact fun payload => treeRoot_cache_message_none parameter topLayer rootTree + (otsSecret topLayer rootTree) root rootCache hroot' payload + have hrootCache : QueryCache.enncard rootCache ≤ q := by + have hgameBound := isQueryBoundP_gameAfterSecrets adversary q hq + hparameter hots hfts + rw [gameAfterSecrets] at hgameBound + have hrootBound := OracleComp.IsQueryBoundP.of_bind_left + (p := fun input : OracleWorld.Domain => input matches Sum.inr _) hgameBound + exact simulateQ_romImpl_enncard_le_queryBound + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest) q hrootBound (root, rootCache) hroot + have hprefixBound := + probEvent_exists_fixedOriginTargetViewedTerminal_le_idealOrigin_of_candidates + (α := Forgery × HashOutput) (secretKey := secretKey) + (computation := adversaryWithTargetQuery adversary publicKey) + (initialCache := rootCache) (signatures := signatureLimit) (sources := q) + (q := q) (hq := hqMax) (hcache := hrootCache) (candidates := q + 1) + have hgame : gameRestWithViewTrace adversary publicKey secretKey rootCache = + run >>= finish := rfl + rw [show ⟨root, parameter⟩ = publicKey from rfl, + show ⟨parameter, root, otsSecret, ftsSecret⟩ = secretKey from rfl, hgame] + change Pr[freshEvent | run >>= finish] ≤ _ + have hfirst : Pr[freshEvent | run >>= finish] ≤ + Pr[SomeFixedOriginTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversaryWithTargetQuery adversary publicKey)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩] := by + rw [adversaryWithTargetQuery_viewed_run] + change Pr[_ | run >>= _] ≤ + Pr[SomeFixedOriginTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + run >>= _] + apply probEvent_bind_le_bind_of_forall_le + rintro ⟨forgery, state⟩ hprior + let input := tweakableHashInput parameter .message + (messageDigestPayload root forgery.message forgery.signature.randomness) + change Pr[_ | + (simulateQ romImpl + (liftM (verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run state.cache >>= _] ≤ _ + rw [verifyWithView_split_run] + simp only [bind_assoc] + rw [show tweakableHashInput publicKey.parameter .message + (messageDigestPayload publicKey.root forgery.message + forgery.signature.randomness) = input from rfl] + change _ ≤ Pr[SomeFixedOriginTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + (randomOracle input).run state.cache >>= pure ∘ fun source => + ((forgery, source.1), appendDirectTargetViewedState input state.cache + source.1 source.2 state)] + rw [probEvent_bind_pure_comp] + change Pr[_ | (randomOracle input).run state.cache >>= _] ≤ + Pr[fun source => SomeFixedOriginTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) + ((forgery, source.1), + appendDirectTargetViewedState input state.cache source.1 source.2 state) | + (randomOracle input).run state.cache] + apply probEvent_bind_le_probEvent + rintro ⟨output, digestCache⟩ hquery hnotPrefix + apply probEvent_eq_zero + intro rest hrest hevent + rw [mem_support_bind_iff] at hrest + obtain ⟨⟨⟨verified, targetView⟩, finalCache⟩, hverifyRest, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst rest + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) + change ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result at hevent + have hverify : ((verified, targetView), finalCache) ∈ support + ((simulateQ romImpl + (liftM (verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run state.cache) := by + rw [verifyWithView_split_run, mem_support_bind_iff] + exact ⟨(output, digestCache), by simpa only [input, publicKey] using hquery, + hverifyRest⟩ + have hrestSupport : + ((forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) ∈ + support (gameRestWithViewTrace adversary publicKey secretKey rootCache) := by + rw [gameRestWithViewTrace, mem_support_bind_iff] + refine ⟨(forgery, state), hprior, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨((verified, targetView), finalCache), hverify, + by simp only [support_pure, Set.mem_singleton_iff]⟩ + have hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret) := by + rw [gameAfterSecretsWithViewTrace, mem_support_bind_iff] + refine ⟨(root, rootCache), hroot, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨_, hrestSupport, by simp [result]⟩ + obtain ⟨f, digest, hf, hvalid, _, hdigest, hadmissible, hproper⟩ := hevent.1 + obtain ⟨otherRootCache, adversaryCache, _, _, hotherRootNone, + hotherChain, hadversaryMiss, _, _, _⟩ := hevent.2 + have hbase : (forgery, state.base) ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState.base) := by + rw [← viewedFullTracedMappedAdversaryImpl_projection secretKey + (adversary.main publicKey) initialState, support_map] + exact ⟨(forgery, state), hprior, rfl⟩ + have hchain : FullAdversaryTrace.CacheChain rootCache state.trace.intervals + state.cache := + fullTracedMappedAdversaryImpl_cacheChain secretKey (adversary.main publicKey) + rootCache rootCache ⟨[], [], []⟩ (forgery, state.base) (by rfl) hbase + have hmiss : state.cache input = none := by + have hrootInput : rootCache input = none := by + simpa only [input] using hrootNone + (messageDigestPayload root forgery.message forgery.signature.randomness) + have hotherRootInput : otherRootCache input = none := by + simpa only [input, result] using hotherRootNone + (messageDigestPayload root forgery.message forgery.signature.randomness) + have hlookup := FullAdversaryTrace.CacheChain.finish_lookup_eq input + (hrootInput.trans hotherRootInput.symm) hchain + (by simpa only [result] using hotherChain) + exact hlookup.trans hadversaryMiss + have hdigestLe : digestCache ≤ finalCache := + simulateQ_romImpl_cache_le + (liftM (verifyWithViewAfterOutput publicKey forgery.signature output) : + OracleComp OracleWorld (Bool × FewTimeView)) digestCache + ((verified, targetView), finalCache) hverifyRest + have hcachedDigest : digestCache input = some output := + randomOracle_output_cached input state.cache digestCache output (by + have hquerySim : simulateQ (randomOracle : QueryImpl HashSpec _) + (oracleHash input) = randomOracle input := by + change simulateQ (randomOracle : QueryImpl HashSpec _) + (liftM (HashSpec.query input)) = randomOracle input + rw [simulateQ_spec_query] + rw [hquerySim] + exact hquery) + have hcachedFinal : finalCache input = some output := hdigestLe hcachedDigest + have hanswer : f input = output := hf (by simpa only [result] using hcachedFinal) + have hdigestOutput : truncateMessageDigest output = digest := by + have hdigest' : truncateMessageDigest (f input) = digest := by + simpa only [messageDigest, oracleHash, evalWithAnswerFn_bind, + evalWithAnswerFn_query, evalWithAnswerFn_pure, result, input] using hdigest + rwa [hanswer] at hdigest' + have htargetOutput : hashOutputFewTimeView output = + fewTimeTargetView (digestIndex digest) (digestLeaves digest) := by + simp [hashOutputFewTimeView, fewTimeTargetView, hdigestOutput] + have hfullBase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret + ftsSecret, support_map] + exact ⟨result, hresult, rfl⟩ + obtain ⟨configuration, hrealized⟩ := + hproper.1.cover.exists_paddedRealized_originConfiguration_of_queryBudget + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts + (result.1, result.2.base) hfullBase f hf (digestIndex digest) + (digestLeaves digest) signatureLimit hvalid + have hfinalCache : QueryCache.enncard finalCache ≤ q := by + have hbound := gameAfterSecretsWithFullTrace_support_enncard_le adversary q hq + parameter hparameter otsSecret hots ftsSecret hfts + (result.1, result.2.base) hfullBase + change QueryCache.enncard result.2.cache ≤ q at hbound + simpa only [result] using hbound + have hdigestCard : QueryCache.enncard digestCache ≤ q := + (QueryCache.enncard_mono hdigestLe).trans hfinalCache + have hcountLe : freshTargetCandidateCount secretKey state.trace ≤ q := by + rw [freshTargetCandidateCount_eq_card] + have hbound := gameAfterSecretsWithViewTrace_freshTargetCandidatePositions_card_le + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts result hresult + simp only [result] at hbound + exact_mod_cast hbound + let candidate : Fin (q + 1) := + ⟨freshTargetCandidateCount secretKey state.trace, by omega⟩ + unfold SomeFixedOriginTargetViewedTerminal at hnotPrefix + apply hnotPrefix + refine ⟨hproper.1.cover.entries.card, + Finset.mem_Icc.2 ⟨hproper.1.cover.entries_card_pos, + hproper.1.cover.entries_card_le_trees⟩, + hproper.1.cover.pattern.pad hvalid, configuration, candidate, ?_⟩ + exact configuration.verifierTarget_fixedTerminal adversary parameter otsSecret + ftsSecret result hresult f hf digest hproper hvalid hrealized + rootCache state hprior rfl rfl input output digestCache rfl hmiss + (by simpa only [input] using hquery) hdigestLe htargetOutput q hdigestCard + calc + Pr[freshEvent | run >>= finish] ≤ + Pr[SomeFixedOriginTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversaryWithTargetQuery adversary publicKey)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩] := hfirst + _ ≤ ((q + 1 : Nat) : ℝ≥0∞) * idealOriginUnionBound signatureLimit q := + hprefixBound + +theorem probEvent_gameAfterSecretsWithViewTrace_nonfresh_proper_leak_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun result => + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∧ ¬VerifierFreshTarget parameter result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + q * idealOriginUnionBound signatureLimit q := by + rw [gameAfterSecretsWithViewTrace] + apply probEvent_bind_le_of_forall_le + rintro ⟨root, rootCache⟩ hroot + let attach := fun rest : (Forgery × Bool) × ViewedFullTraceState => + ((root, rest.1.1, rest.1.2), rest.2) + change Pr[fun result => + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result ∧ + ¬VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache >>= pure ∘ attach] ≤ _ + rw [probEvent_bind_pure_comp] + exact probEvent_gameRestWithViewTrace_nonfresh_proper_leak_le adversary q hq hqMax + parameter hparameter otsSecret hots ftsSecret hfts root rootCache hroot + +theorem probEvent_gameAfterSecretsWithViewTrace_fresh_proper_leak_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun result => + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∧ VerifierFreshTarget parameter result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + ((q + 1 : Nat) : ℝ≥0∞) * idealOriginUnionBound signatureLimit q := by + rw [gameAfterSecretsWithViewTrace] + apply probEvent_bind_le_of_forall_le + rintro ⟨root, rootCache⟩ hroot + let attach := fun rest : (Forgery × Bool) × ViewedFullTraceState => + ((root, rest.1.1, rest.1.2), rest.2) + change Pr[fun result => + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache >>= pure ∘ attach] ≤ _ + rw [probEvent_bind_pure_comp] + exact probEvent_gameRestWithViewTrace_fresh_proper_leak_le adversary q hq hqMax + parameter hparameter otsSecret hots ftsSecret hfts root rootCache hroot + +theorem probEvent_gameAfterSecretsWithViewTrace_proper_leak_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + q * idealOriginUnionBound signatureLimit q + + ((q + 1 : Nat) : ℝ≥0∞) * idealOriginUnionBound signatureLimit q := by + classical + calc + _ ≤ Pr[fun result => + (ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result ∧ + ¬VerifierFreshTarget parameter result) ∨ + (ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result) | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + apply probEvent_mono + intro result _ hproper + by_cases hfresh : VerifierFreshTarget parameter result + · exact Or.inr ⟨hproper, hfresh⟩ + · exact Or.inl ⟨hproper, hfresh⟩ + _ ≤ _ := (probEvent_or_le _ _ _).trans (add_le_add + (probEvent_gameAfterSecretsWithViewTrace_nonfresh_proper_leak_le adversary q hq + hqMax parameter hparameter otsSecret hots ftsSecret hfts) + (probEvent_gameAfterSecretsWithViewTrace_fresh_proper_leak_le adversary q hq + hqMax parameter hparameter otsSecret hots ftsSecret hfts)) + +theorem probEvent_gameAfterSecretsWithViewTrace_proper_leak_le_nine_mul_inv + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + ((2 * q + 1 : Nat) : ℝ≥0∞) * + (9 * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹) := by + calc + _ ≤ q * idealOriginUnionBound signatureLimit q + + ((q + 1 : Nat) : ℝ≥0∞) * idealOriginUnionBound signatureLimit q := + probEvent_gameAfterSecretsWithViewTrace_proper_leak_le adversary q hq hqMax + parameter hparameter otsSecret hots ftsSecret hfts + _ = ((2 * q + 1 : Nat) : ℝ≥0∞) * idealOriginUnionBound signatureLimit q := by + push_cast + ring + _ ≤ _ := by + gcongr + exact idealOriginUnionBound_le_nine_mul_inv le_rfl hqMax + +theorem probEvent_gameAfterSecretsWithViewTrace_nonfresh_proper_leak_le_inv + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun result => + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∧ ¬VerifierFreshTarget parameter result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + q * ((2 ^ 121 : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ ≤ q * idealOriginUnionBound signatureLimit q := + probEvent_gameAfterSecretsWithViewTrace_nonfresh_proper_leak_le adversary q hq + hqMax parameter hparameter otsSecret hots ftsSecret hfts + _ ≤ _ := by + gcongr + exact idealOriginUnionBound_le le_rfl hqMax + +theorem gameAfterSecretsWithViewTrace_proper_target_bridge + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest parameter result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) = digest) + (hadmissible : Admissible digest) + (hproper : ProperFewTimeLeak f result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest)) + {limit : Nat} (hle : result.2.trace.signing.toSigningLog.length ≤ limit) + {sources : Nat} + (configuration : OriginConfiguration (hproper.1.cover.pattern.pad hle) sources) + (hrealized : configuration.PaddedRealizedBy hproper.1.cover hle result.2.trace rfl) : + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + VerifierFreshTarget parameter result ∨ + ∃ (targetOrdinal : Nat) (rootCache : QueryCache HashSpec) + (monitored : Forgery × OriginTargetMonitorState configuration), + targetOrdinal < freshTargetCandidateCount secretKey result.2.trace + ∧ monitored ∈ support + ((simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + (adversary.main ⟨result.1.1, parameter⟩)).run + (OriginTargetMonitorState.initial configuration rootCache)) + ∧ monitored.1 = result.1.2.1 + ∧ monitored.2.Complete + ∧ ∀ target, monitored.2.targetView = some target → + FixedFewTimePatternHit (hproper.1.cover.pattern.pad hle).assignment + (monitored.2.origin.observation.views, target) := by + classical + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + let targetPayload := messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness + let targetInput := tweakableHashInput parameter .message targetPayload + obtain ⟨rootCache₀, adversaryCache, digestCache, verifierOutput, hrootNone, hchain, + hverify, hdigestLe, htargetView, horigin, _⟩ := + gameAfterSecretsWithViewTrace_target_source_kind adversary parameter otsSecret + ftsSecret result hresult + rcases horigin with hverifier | ⟨source, hsourceInitial, hsourceFinal, hkind⟩ + · exact Or.inl ⟨rootCache₀, adversaryCache, digestCache, verifierOutput, + hrootNone, hchain, + by simpa only [targetInput, targetPayload] using hverifier, + by simpa only [targetInput, targetPayload] using hverify, hdigestLe, htargetView⟩ + · obtain ⟨sourceOutput, hcandidate, hsourceView, hsourceOutput, hattempt⟩ := + gameAfterSecretsWithViewTrace_target_source_candidate adversary parameter otsSecret + ftsSecret result hresult f hf digest hdigest hadmissible source + (by simpa only [targetInput, targetPayload] using hsourceInitial) + (by simpa only [targetInput, targetPayload] using hsourceFinal) + (by simpa only [targetInput, targetPayload] using hkind) + let targetOrdinal := result.2.trace.intervals.countPBefore + (fun entry => decide (FreshTargetCandidate secretKey entry)) source.val + obtain ⟨rootCache, monitored, _, hmonitored, hforgery, htrace, hviews, hcache⟩ := + gameAfterSecretsWithViewTrace_support_target_monitored_state configuration + targetOrdinal adversary parameter otsSecret ftsSecret result hresult + let monitoredPosition := castTracePosition result.2 monitored.2.origin.viewed + htrace source + have hcandidateMonitored : FreshTargetCandidate secretKey + (monitored.2.origin.viewed.trace.intervals.get monitoredPosition) := by + rw [get_castTracePosition result.2 monitored.2.origin.viewed htrace source] + exact hcandidate + have hviewMonitored : targetCandidateIntervalView monitored.2.origin.viewed + monitoredPosition = fewTimeTargetView (digestIndex digest) (digestLeaves digest) := by + rw [targetCandidateIntervalView_castTracePosition result.2 + monitored.2.origin.viewed htrace hviews source] + exact hsourceView + have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hresult, rfl⟩ + have hinvariants := gameAfterSecretsWithFullTrace_support_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hintervals := gameAfterSecretsWithFullTrace_support_interval_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hvalidIntervals := gameAfterSecretsWithFullTrace_support_validIntervals adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hvalidViews := gameAfterSecretsWithViewTrace_support_validViews adversary parameter + otsSecret ftsSecret result hresult + have hallowed : targetCandidateIntervalAllowed configuration result.2 source = true := + hproper.target_source_interval_allowed result.1.2.1 digest hdigest rfl result.2 rfl + hvalidViews hintervals.1 hinvariants.1 hinvariants.2.1 hf hle configuration + hrealized hvalidIntervals source sourceOutput + (by simpa only [targetInput, targetPayload] using hsourceInitial) + (by simpa only [targetInput, targetPayload] using hsourceOutput) + hattempt (by simpa only [targetInput, targetPayload] using hkind) + have hallowedMonitored : targetCandidateIntervalAllowed configuration + monitored.2.origin.viewed monitoredPosition = true := by + rw [targetCandidateIntervalAllowed_castTracePosition configuration result.2 + monitored.2.origin.viewed htrace source] + exact hallowed + have htraceCoherent := originTargetMonitoredAdversaryImpl_candidateTraceCoherent + configuration secretKey targetOrdinal (adversary.main ⟨result.1.1, parameter⟩) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateTraceCoherent_initial configuration secretKey rootCache) + hmonitored + have hallowedTraceCoherent := + originTargetMonitoredAdversaryImpl_candidateAllowedTraceCoherent + configuration secretKey targetOrdinal (adversary.main ⟨result.1.1, parameter⟩) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateAllowedTraceCoherent_initial + configuration secretKey rootCache) + hmonitored + have hviewsCoherent := originTargetMonitoredAdversaryImpl_candidateViewsCoherent + configuration secretKey targetOrdinal (adversary.main ⟨result.1.1, parameter⟩) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateViewsCoherent_initial configuration rootCache + targetOrdinal) hmonitored + have hallowedCoherent := originTargetMonitoredAdversaryImpl_candidateAllowedCoherent + configuration secretKey targetOrdinal (adversary.main ⟨result.1.1, parameter⟩) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateAllowedCoherent_initial configuration rootCache + targetOrdinal) hmonitored + have htargetOrdinal : targetOrdinal = + monitored.2.origin.viewed.trace.intervals.countPBefore + (fun entry => decide (FreshTargetCandidate secretKey entry)) + monitoredPosition.val := by + change result.2.trace.intervals.countPBefore + (fun entry => decide (FreshTargetCandidate secretKey entry)) source.val = + monitored.2.origin.viewed.trace.intervals.countPBefore + (fun entry => decide (FreshTargetCandidate secretKey entry)) monitoredPosition.val + rw [List.countPBefore_eq_countP_take, List.countPBefore_eq_countP_take, + take_castTracePosition result.2 monitored.2.origin.viewed htrace source] + obtain ⟨hlogMonitored, hrealizedMonitored⟩ := + configuration.paddedRealized_transport result.2.trace + monitored.2.origin.viewed.trace htrace rfl hrealized + have hvalidIntervalsMonitored : + monitored.2.origin.viewed.trace.ValidIntervals secretKey := by + rw [← htrace] + exact hvalidIntervals + have hchronologicalMonitored : FullAdversaryTrace.Chronological + monitored.2.origin.viewed.trace.intervals := by + rw [← htrace] + exact hintervals.2.2 + have hcachesMonitored : monitored.2.origin.viewed.trace.signing.CachesLe + result.2.cache := by + rw [← htrace] + exact hinvariants.2.1 + have hterminal := configuration.paddedRealized_target_complete_and_hit + hlogMonitored hrealizedMonitored htraceCoherent.1 hvalidIntervalsMonitored + hchronologicalMonitored hcachesMonitored hf monitoredPosition hcandidateMonitored + hviewMonitored hallowedMonitored (by rwa [← htargetOrdinal]) htraceCoherent.2 + (by rwa [← htargetOrdinal]) hallowedTraceCoherent.2 + have hordinalLt : targetOrdinal < freshTargetCandidateCount secretKey result.2.trace := by + apply List.countPBefore_lt_countP_of_lt_length_of_pos + exact decide_eq_true hcandidate + exact Or.inr ⟨targetOrdinal, rootCache, monitored, hordinalLt, hmonitored, + hforgery, hterminal.1, hterminal.2⟩ + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetView.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetView.lean new file mode 100644 index 00000000..17db7735 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeTargetView.lean @@ -0,0 +1,409 @@ +import SphincsSecurity.Proof.FewTimeTargetCount +import SphincsSecurity.Proof.FewTimeOriginTerminal + +/-! +# Verifier target views at fresh candidate intervals + +An admissible message-digest answer first inserted during a signer interval is the digest-loop +answer selected by that invocation. The viewed trace therefore retains exactly the verifier target +view at the corresponding signer rank, even if later signature construction failed. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +namespace Concrete + +def targetCandidateIntervalView (state : ViewedFullTraceState) + (position : Fin state.trace.intervals.length) : FewTimeView := + match state.trace.intervals.get position with + | ⟨.inl (.inl _), _, _, _⟩ => default + | ⟨.inl (.inr _), output, _, _⟩ => hashOutputFewTimeView output + | ⟨.inr _, _, _, _⟩ => + (state.views[signerIntervalCount + (state.trace.intervals.take position.val)]?.getD none).getD default + +noncomputable def freshTargetCandidateViews (secretKey : SecretKey) + (state : ViewedFullTraceState) : + Fin ((freshTargetCandidatePositions secretKey state.trace).card + 1) → FewTimeView := + Fin.lastCases (state.targetView.getD default) fun candidate => + targetCandidateIntervalView state + ((freshTargetCandidatePositions secretKey state.trace).equivFin.symm candidate).1 + +noncomputable def freshTargetCandidateOrdinal (secretKey : SecretKey) + (state : ViewedFullTraceState) (position : Fin state.trace.intervals.length) + (hcandidate : position ∈ freshTargetCandidatePositions secretKey state.trace) : + Fin (freshTargetCandidatePositions secretKey state.trace).card := + (freshTargetCandidatePositions secretKey state.trace).equivFin ⟨position, hcandidate⟩ + +@[simp] theorem freshTargetCandidateViews_last (secretKey : SecretKey) + (state : ViewedFullTraceState) : + freshTargetCandidateViews secretKey state + (Fin.last (freshTargetCandidatePositions secretKey state.trace).card) = + state.targetView.getD default := by + simp [freshTargetCandidateViews] + +@[simp] theorem freshTargetCandidateViews_castSucc (secretKey : SecretKey) + (state : ViewedFullTraceState) + (candidate : Fin (freshTargetCandidatePositions secretKey state.trace).card) : + freshTargetCandidateViews secretKey state candidate.castSucc = + targetCandidateIntervalView state + ((freshTargetCandidatePositions secretKey state.trace).equivFin.symm candidate).1 := by + simp [freshTargetCandidateViews] + +theorem freshTargetCandidateViews_ordinal (secretKey : SecretKey) + (state : ViewedFullTraceState) (position : Fin state.trace.intervals.length) + (hcandidate : position ∈ freshTargetCandidatePositions secretKey state.trace) : + freshTargetCandidateViews secretKey state + (freshTargetCandidateOrdinal secretKey state position hcandidate).castSucc = + targetCandidateIntervalView state position := by + rw [freshTargetCandidateViews_castSucc] + have hinverse := Equiv.symm_apply_apply + (freshTargetCandidatePositions secretKey state.trace).equivFin ⟨position, hcandidate⟩ + exact congrArg (targetCandidateIntervalView state ∘ Subtype.val) hinverse + +theorem targetCandidateIntervalView_direct (state : ViewedFullTraceState) + (position : Fin state.trace.intervals.length) (input : HashInput) + (output : HashOutput) (initialCache finalCache : QueryCache HashSpec) + (hentry : state.trace.intervals.get position = + ⟨.inl (.inr input), output, initialCache, finalCache⟩) : + targetCandidateIntervalView state position = hashOutputFewTimeView output := by + have hentry' : state.trace.intervals[position.val] = + ⟨.inl (.inr input), output, initialCache, finalCache⟩ := by + simpa only [List.get_eq_getElem] using hentry + simp [targetCandidateIntervalView, hentry'] + +theorem targetCandidateIntervalView_signer (state : ViewedFullTraceState) + (position : Fin state.trace.intervals.length) (request : SignRequest) + (signature : Option Signature) (initialCache finalCache : QueryCache HashSpec) + (view : FewTimeView) + (hentry : state.trace.intervals.get position = + ⟨.inr request, signature, initialCache, finalCache⟩) + (hview : state.views[signerIntervalCount + (state.trace.intervals.take position.val)]? = some (some view)) : + targetCandidateIntervalView state position = view := by + have hentry' : state.trace.intervals[position.val] = + ⟨.inr request, signature, initialCache, finalCache⟩ := by + simpa only [List.get_eq_getElem] using hentry + simp [targetCandidateIntervalView, hentry', hview] + +theorem ViewedFullTraceState.ValidViews.signer_interval + {secretKey : SecretKey} {state : ViewedFullTraceState} + (hvalid : state.ValidViews secretKey) (hconsistent : state.trace.Consistent) + (position : Fin state.trace.intervals.length) + (request : SignRequest) (signature : Option Signature) + (initialCache finalCache : QueryCache HashSpec) + (hinterval : state.trace.intervals.get position = + ⟨.inr request, signature, initialCache, finalCache⟩) : + let rank := signerIntervalCount (state.trace.intervals.take position.val) + ∃ (signingPosition : Fin state.trace.signing.length) + (viewPosition : Fin state.views.length), + signingPosition.val = rank + ∧ viewPosition.val = rank + ∧ state.trace.signing.get signingPosition = + ⟨request, signature, initialCache, finalCache⟩ + ∧ SigningCacheEntry.ValidView secretKey + ⟨request, signature, initialCache, finalCache⟩ + (state.views.get viewPosition) := by + let entry : SigningCacheEntry := ⟨request, signature, initialCache, finalCache⟩ + have hsigning : AdversaryCacheEntry.signingEntry? + (state.trace.intervals.get position) = some entry := by + rw [hinterval] + rfl + have hfiltered := filterMap_getElem?_at_rank AdversaryCacheEntry.signingEntry? + state.trace.intervals position entry hsigning + rw [hconsistent.2] at hfiltered + let rank := signerIntervalCount (state.trace.intervals.take position.val) + have hrankLt : rank < state.trace.signing.length := + (List.getElem?_eq_some_iff.mp hfiltered).1 + let signingPosition : Fin state.trace.signing.length := ⟨rank, hrankLt⟩ + have hentry : state.trace.signing.get signingPosition = entry := by + exact (List.getElem?_eq_some_iff.mp hfiltered).2 + let viewPosition : Fin state.views.length := + ⟨rank, by rw [← hvalid.length_eq]; exact hrankLt⟩ + have hviewRun := hvalid.get signingPosition.isLt viewPosition.isLt + rw [hentry] at hviewRun + exact ⟨signingPosition, viewPosition, rfl, rfl, hentry, hviewRun⟩ + +theorem ViewedFullTraceState.ValidViews.signer_interval_fresh_admissible_view + {secretKey : SecretKey} {state : ViewedFullTraceState} + (hvalid : state.ValidViews secretKey) (hconsistent : state.trace.Consistent) + (position : Fin state.trace.intervals.length) + (request : SignRequest) (signature : Option Signature) + (initialCache finalCache : QueryCache HashSpec) + (hinterval : state.trace.intervals.get position = + ⟨.inr request, signature, initialCache, finalCache⟩) + (targetPayload : HashInput) (output : HashOutput) (index : Index) + (leaves : DigestTree → FtsLeaf) + (hbefore : initialCache + (tweakableHashInput secretKey.parameter .message targetPayload) = none) + (hafter : finalCache + (tweakableHashInput secretKey.parameter .message targetPayload) = some output) + (houtput : signAttemptResultOfOutput output = some (index, leaves)) : + state.views[signerIntervalCount + (state.trace.intervals.take position.val)]? = + some (some (hashOutputFewTimeView output)) := by + obtain ⟨signingPosition, viewPosition, hsigningRank, hviewRank, hentry, + hviewRun⟩ := ViewedFullTraceState.ValidViews.signer_interval hvalid hconsistent + position request signature initialCache finalCache hinterval + obtain ⟨_, _, hview, _⟩ := + signingCacheEntry_validView_fresh_admissible_transition_view hviewRun + targetPayload output index leaves hbefore hafter houtput + apply List.getElem?_eq_some_iff.mpr + refine ⟨?_, ?_⟩ + · rw [← hviewRank] + exact viewPosition.isLt + · let rankedViewPosition : Fin state.views.length := + ⟨signerIntervalCount (state.trace.intervals.take position.val), by + rw [← hviewRank] + exact viewPosition.isLt⟩ + have hpositionEq : rankedViewPosition = viewPosition := Fin.ext hviewRank.symm + change state.views.get rankedViewPosition = some (hashOutputFewTimeView output) + rw [hpositionEq] + exact hview + +theorem ProperFewTimeLeak.signer_target_signature_eq_none + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} + {index : Index} {leaves : DigestTree → FtsLeaf} + (hproper : ProperFewTimeLeak f cache secretKey signingLog index leaves) + (state : ViewedFullTraceState) + (hlog : state.trace.signing.toSigningLog = signingLog) + (hvalidViews : state.ValidViews secretKey) + (hconsistent : state.trace.Consistent) + (hvalidRuns : state.trace.signing.ValidRuns secretKey) + (hcaches : state.trace.signing.CachesLe cache) (hf : cache.AgreesWithFn f) + (position : Fin state.trace.intervals.length) + (request : SignRequest) (signature : Option Signature) + (initialCache finalCache : QueryCache HashSpec) + (hinterval : state.trace.intervals.get position = + ⟨.inr request, signature, initialCache, finalCache⟩) + (targetPayload : HashInput) (output : HashOutput) + (hbefore : initialCache + (tweakableHashInput secretKey.parameter .message targetPayload) = none) + (hafter : finalCache + (tweakableHashInput secretKey.parameter .message targetPayload) = some output) + (houtput : signAttemptResultOfOutput output = some (index, leaves)) : + signature = none := by + obtain ⟨signingPosition, viewPosition, _, _, hentry, hviewRun⟩ := + ViewedFullTraceState.ValidViews.signer_interval hvalidViews hconsistent position + request signature initialCache finalCache hinterval + cases hsignature : signature with + | none => rfl + | some signed => + exfalso + have hsigningMem := List.get_mem state.trace.signing signingPosition + let signingEntry : SigningCacheEntry := + ⟨request, some signed, initialCache, finalCache⟩ + have hentry' : state.trace.signing.get signingPosition = signingEntry := by + simpa only [hsignature, signingEntry] using hentry + have hsigningEntryMem : signingEntry ∈ state.trace.signing := by + rw [← hentry'] + exact hsigningMem + have hlogMem : (⟨request, some signed⟩ : + (request : SignRequest) × SigningSpec.Range request) ∈ signingLog := by + rw [← hlog, SigningCacheTrace.toSigningLog, List.mem_map] + exact ⟨signingEntry, hsigningEntryMem, by simp [signingEntry]⟩ + rw [hsignature] at hviewRun + obtain ⟨randomness, hpayload, _, hrandomness⟩ := + signingCacheEntry_validView_fresh_admissible_transition_view hviewRun + targetPayload output index leaves hbefore hafter houtput + have hrandomness' : randomness = signed.randomness := + hrandomness signed rfl + have hvalidRun := hvalidRuns signingEntry hsigningEntryMem + change (some signed, finalCache) ∈ support + ((simulateQ romImpl (scheme.sign secretKey request)).run initialCache) at hvalidRun + rw [show scheme.sign secretKey request = sign secretKey request from rfl] at hvalidRun + have hcacheLe : finalCache ≤ cache := + (hcaches signingEntry hsigningEntryMem).2 + have hfinalAgree : finalCache.AgreesWithFn f := + fun _ _ hcached => hf (hcacheLe hcached) + have hreplay := replayRom_of_mem_support (sign secretKey request) initialCache + (some signed) finalCache hvalidRun f hfinalAgree + have hrun := successfulSignRun_of_mem_support f secretKey request signed + initialCache finalCache cache hreplay hcacheLe hf + have htargetCached : cache + (tweakableHashInput secretKey.parameter .message targetPayload) = some output := + hcacheLe hafter + have htargetAnswer : f + (tweakableHashInput secretKey.parameter .message targetPayload) = output := + hf htargetCached + have hevalTarget : evalWithAnswerFn f + (signAttempt secretKey request signed.randomness) = some (index, leaves) := by + simp only [signAttempt, messageDigest, oracleHash, evalWithAnswerFn_bind, + evalWithAnswerFn_query] + rw [← hrandomness', ← hpayload, htargetAnswer] + by_cases hadmissibleOutput : Admissible (truncateMessageDigest output) + · simpa only [if_pos hadmissibleOutput, evalWithAnswerFn_pure, + signAttemptResultOfOutput] using houtput + · simpa only [if_neg hadmissibleOutput, evalWithAnswerFn_pure, + signAttemptResultOfOutput] using houtput + obtain ⟨actualIndex, actualLeaves, hhonest⟩ := hrun.honest_fts_at + have hpairs : (actualIndex, actualLeaves) = (index, leaves) := by + exact Option.some.inj (hhonest.1.2.1.symm.trans hevalTarget) + obtain ⟨rfl, rfl⟩ := Prod.mk.inj hpairs + exact hproper.2 ⟨request, some signed⟩ signed hlogMem rfl hrun hhonest + +theorem gameAfterSecretsWithViewTrace_target_in_freshCandidateViews + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest parameter result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) = digest) + (hadmissible : Admissible digest) : + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + ∃ candidate, + freshTargetCandidateViews secretKey result.2 candidate = + fewTimeTargetView (digestIndex digest) (digestLeaves digest) := by + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + let targetPayload := messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness + let input := tweakableHashInput parameter .message targetPayload + obtain ⟨rootCache, adversaryCache, digestCache, output, _, _, houtput, + hdigestLe, htargetView, horigin, _⟩ := + gameAfterSecretsWithViewTrace_target_source_kind adversary parameter otsSecret + ftsSecret result hresult + have hcachedDigest : digestCache input = some output := + randomOracle_output_cached input adversaryCache digestCache output (by + simpa only [input, targetPayload] using houtput) + have hcachedFinal : result.2.cache input = some output := hdigestLe hcachedDigest + have hanswer : f input = output := hf hcachedFinal + have hdigestOutput : truncateMessageDigest output = digest := by + simpa only [messageDigest, oracleHash, evalWithAnswerFn_bind, evalWithAnswerFn_query, + evalWithAnswerFn_pure, input, targetPayload, hanswer] using hdigest + have hattempt : signAttemptResultOfOutput output = + some (digestIndex digest, digestLeaves digest) := by + simp [signAttemptResultOfOutput, hdigestOutput, hadmissible] + have htargetOutput : hashOutputFewTimeView output = + fewTimeTargetView (digestIndex digest) (digestLeaves digest) := by + simp [hashOutputFewTimeView, fewTimeTargetView, hdigestOutput] + rcases horigin with hverifier | ⟨source, hsourceInitial, hsourceFinal, hkind⟩ + · refine ⟨Fin.last (freshTargetCandidatePositions secretKey result.2.trace).card, ?_⟩ + rw [freshTargetCandidateViews_last, htargetView] + simpa only [Option.getD_some] using htargetOutput + · have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hresult, rfl⟩ + have hintervals := gameAfterSecretsWithFullTrace_support_interval_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hvalidIntervals := gameAfterSecretsWithFullTrace_support_validIntervals adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hvalidViews := gameAfterSecretsWithViewTrace_support_validViews adversary parameter + otsSecret ftsSecret result hresult + let entry := result.2.trace.intervals.get source + have hentry : result.2.trace.intervals.get source = entry := rfl + have hsourceCandidate : FreshTargetCandidate secretKey entry := + freshTargetCandidate_of_message_transition secretKey entry targetPayload + (hvalidIntervals entry (List.get_mem _ source)) + (by simpa only [secretKey, input] using hsourceInitial) + (by simpa only [secretKey, input] using hsourceFinal) + (by + intro sourceOutput hsourceOutput + have hsourceLe : entry.finalCache ≤ result.2.cache := + (hintervals.2.1 entry (List.get_mem _ source)).2 + have hcached := hsourceLe (by simpa only [input] using hsourceOutput) + rw [hcachedFinal] at hcached + have hsourceOutputEq : sourceOutput = output := + (Option.some.inj hcached).symm + rw [hsourceOutputEq, hattempt] + simp) + (by simpa only [secretKey, input] using hkind) + have hcandidateMem : source ∈ + freshTargetCandidatePositions secretKey result.2.trace := by + exact Finset.mem_filter.mpr ⟨Finset.mem_univ source, by + simpa only [entry] using hsourceCandidate⟩ + let candidate := + (freshTargetCandidateOrdinal secretKey result.2 source hcandidateMem).castSucc + refine ⟨candidate, ?_⟩ + rw [show candidate = + (freshTargetCandidateOrdinal secretKey result.2 source hcandidateMem).castSucc from rfl, + freshTargetCandidateViews_ordinal] + obtain ⟨sourceOutput, hsourceOutput⟩ := Option.ne_none_iff_exists'.mp hsourceFinal + have hsourceLe : entry.finalCache ≤ result.2.cache := + (hintervals.2.1 entry (List.get_mem _ source)).2 + have hsourceOutputEq : sourceOutput = output := by + have hcached := hsourceLe (by simpa only [entry, input] using hsourceOutput) + rw [hcachedFinal] at hcached + exact (Option.some.inj hcached).symm + have hsourceExact : entry.finalCache input = some output := by + simpa only [hsourceOutputEq] using hsourceOutput + have hvalidEntry := hvalidIntervals entry (List.get_mem _ source) + rcases hkind with hdirect | ⟨request, hsigner⟩ + · rcases entry with ⟨entryInput, entryOutput, initialCache, finalCache⟩ + change (result.2.trace.intervals.get source).input = .inl (.inr input) at hdirect + have hentryInput := congrArg AdversaryCacheEntry.input hentry + rw [hentryInput] at hdirect + rcases entryInput with worldInput | sourceRequest + · rcases worldInput with uniformInput | directInput + · simp at hdirect + · simp only [Sum.inl.injEq, Sum.inr.injEq] at hdirect + subst directInput + change finalCache input = some output at hsourceExact + have hdirectRun : (entryOutput, finalCache) ∈ support + ((randomOracle input).run initialCache) := by + have hrun := hvalidEntry + change (entryOutput, finalCache) ∈ support + ((randomOracle input).run initialCache) at hrun + exact hrun + have hdirectCached : finalCache input = some entryOutput := + randomOracle_run_output_cached input initialCache finalCache entryOutput hdirectRun + have hentryOutputEq : entryOutput = output := by + rw [hsourceExact] at hdirectCached + exact (Option.some.inj hdirectCached).symm + rw [targetCandidateIntervalView_direct result.2 source input entryOutput + initialCache finalCache hentry] + rw [hentryOutputEq] + exact htargetOutput + · simp at hdirect + · rcases entry with ⟨entryInput, entryOutput, initialCache, finalCache⟩ + change (result.2.trace.intervals.get source).input = .inr request at hsigner + have hentryInput := congrArg AdversaryCacheEntry.input hentry + rw [hentryInput] at hsigner + rcases entryInput with worldInput | sourceRequest + · simp at hsigner + · simp only [Sum.inr.injEq] at hsigner + subst sourceRequest + rw [hentry] at hsourceInitial + change initialCache input = none at hsourceInitial + change finalCache input = some output at hsourceExact + have hstored := ViewedFullTraceState.ValidViews.signer_interval_fresh_admissible_view + hvalidViews hintervals.1 source request entryOutput initialCache finalCache + hentry targetPayload output + (digestIndex digest) (digestLeaves digest) + (by simpa only [secretKey, input] using hsourceInitial) + (by simpa only [secretKey, input] using hsourceExact) hattempt + rw [targetCandidateIntervalView_signer result.2 source request entryOutput + initialCache finalCache (hashOutputFewTimeView output) + hentry hstored] + exact htargetOutput + +theorem gameAfterSecretsWithViewTrace_freshCandidateViews_count_le + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) : + (freshTargetCandidatePositions + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ result.2.trace).card + 1 ≤ q + 1 := by + apply Nat.succ_le_succ + have hbound := gameAfterSecretsWithViewTrace_freshTargetCandidatePositions_card_le + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts result hresult + exact_mod_cast hbound + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeTrace.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeTrace.lean new file mode 100644 index 00000000..ca5db80a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeTrace.lean @@ -0,0 +1,286 @@ +import SphincsSecurity.Proof.TracedGame +import SphincsSecurity.Proof.FewTimeWitness +import SphincsSecurity.Proof.TerminalCache + +/-! +# Few-time witnesses in the signing cache trace + +The finite cover chooses ordinary signing-log entries. This module locates the corresponding +cache-trace entry, retaining the cache immediately before that signer invocation. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +def signingCacheTraceFlatLog (trace : SigningCacheTrace) : List FlatSigningEntry := + trace.map fun entry => (entry.request, entry.signature) + +theorem signingCacheTraceFlatLog_eq (trace : SigningCacheTrace) : + signingCacheTraceFlatLog trace = trace.toSigningLog.map SigningEntry.flat := by + induction trace with + | nil => rfl + | cons entry rest _ => simp [signingCacheTraceFlatLog, + SigningCacheTrace.toSigningLog, SigningEntry.flat] + +theorem exists_signingCacheEntry_of_flat_mem (trace : SigningCacheTrace) + (entry : FlatSigningEntry) (hentry : entry ∈ signingCacheTraceFlatLog trace) : + ∃ tracedEntry ∈ trace, + (tracedEntry.request, tracedEntry.signature) = entry := by + simpa only [signingCacheTraceFlatLog, List.mem_map] using hentry + +noncomputable def FewTimeCover.cacheEntry {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (entry : cover.entries) : SigningCacheEntry := by + exact trace.get ⟨cover.logIndex entry, by + have hlength := congrArg List.length hlog + simpa only [SigningCacheTrace.toSigningLog, List.length_map] using + (show (cover.logIndex entry).val < trace.toSigningLog.length by + rw [hlength] + exact (cover.logIndex entry).isLt)⟩ + +theorem FewTimeCover.cacheEntry_mem {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (entry : cover.entries) : cover.cacheEntry trace hlog entry ∈ trace := + by + exact List.get_mem trace _ + +theorem FewTimeCover.cacheEntry_flat {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (entry : cover.entries) : + ((cover.cacheEntry trace hlog entry).request, + (cover.cacheEntry trace hlog entry).signature) = entry.1 := + by + let position := (cover.logIndex entry).val + have htraceLength : trace.length = signingLog.length := by + have hlength := congrArg List.length hlog + simpa only [SigningCacheTrace.toSigningLog, List.length_map] using hlength + have htraceLt : position < trace.length := by + rw [htraceLength] + exact (cover.logIndex entry).isLt + have hlists : signingCacheTraceFlatLog trace = signingLog.map SigningEntry.flat := by + rw [signingCacheTraceFlatLog_eq, hlog] + have hget := congrArg (fun list : List FlatSigningEntry => list[position]?) hlists + have hright : (signingLog.map SigningEntry.flat)[position]? = some entry.1 := by + rw [List.getElem?_eq_getElem] + · rw [List.getElem_map] + simpa only [position, List.get_eq_getElem] using + congrArg some (cover.logIndex_spec entry) + · simpa only [position, List.length_map] using (cover.logIndex entry).isLt + have hleft : (signingCacheTraceFlatLog trace)[position]? = some entry.1 := hget.trans hright + rw [List.getElem?_eq_getElem (by + simpa only [signingCacheTraceFlatLog, List.length_map] using htraceLt)] at hleft + have hleft' := Option.some.inj hleft + change (trace.map fun tracedEntry => + (tracedEntry.request, tracedEntry.signature))[position]'(by + simpa only [List.length_map] using htraceLt) = entry.1 at hleft' + rw [List.getElem_map] at hleft' + simpa only [FewTimeCover.cacheEntry, position, List.get_eq_getElem] using hleft' + +theorem FewTimeCover.cacheEntry_first_flat {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (entry : cover.entries) (earlier : Fin trace.length) + (hearlier : earlier.val < (cover.logIndex entry).val) : + ((trace.get earlier).request, (trace.get earlier).signature) ≠ entry.1 := by + classical + have hlists : signingCacheTraceFlatLog trace = signingLog.map SigningEntry.flat := by + rw [signingCacheTraceFlatLog_eq, hlog] + let flatEarlier : Fin (signingCacheTraceFlatLog trace).length := + ⟨earlier.val, by + simpa only [signingCacheTraceFlatLog, List.length_map] using earlier.isLt⟩ + have hidx : (signingCacheTraceFlatLog trace).idxOf entry.1 = + (cover.logIndex entry).val := by + rw [hlists] + rfl + have hlt : flatEarlier.val < (signingCacheTraceFlatLog trace).idxOf entry.1 := by + rw [hidx] + exact hearlier + have hne := List.get_ne_of_lt_idxOf + (signingCacheTraceFlatLog trace) entry.1 flatEarlier hlt + simpa only [flatEarlier, signingCacheTraceFlatLog, List.get_eq_getElem, + List.getElem_map] using hne + +theorem FewTimeCover.earlier_finalCache_le_cacheEntry_initialCache + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (hchronological : trace.Chronological) (entry : cover.entries) + (earlier : Fin trace.length) (hearlier : earlier.val < (cover.logIndex entry).val) : + (trace.get earlier).finalCache ≤ (cover.cacheEntry trace hlog entry).initialCache := by + let selectedPosition : Fin trace.length := ⟨(cover.logIndex entry).val, by + have hlength := congrArg List.length hlog + simpa only [SigningCacheTrace.toSigningLog, List.length_map] using + (show (cover.logIndex entry).val < trace.toSigningLog.length by + rw [hlength] + exact (cover.logIndex entry).isLt)⟩ + have hle := hchronological.get_finalCache_le_initialCache earlier selectedPosition hearlier + simpa only [selectedPosition, FewTimeCover.cacheEntry] using hle + +theorem FewTimeCover.cacheEntry_injective {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) : + Function.Injective (cover.cacheEntry trace hlog) := by + intro left right heq + apply Subtype.ext + rw [← cover.cacheEntry_flat trace hlog left, ← cover.cacheEntry_flat trace hlog right, heq] + +theorem FewTimeCover.cacheEntry_validRun {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (hvalid : trace.ValidRuns secretKey) (entry : cover.entries) : + (cover.cacheEntry trace hlog entry).ValidRun secretKey := + hvalid _ (cover.cacheEntry_mem trace hlog entry) + +theorem FewTimeCover.cacheEntry_cachesLe {f : QueryImpl HashSpec Id} + {cache finalCache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (hcaches : trace.CachesLe finalCache) (entry : cover.entries) : + (cover.cacheEntry trace hlog entry).initialCache ≤ finalCache + ∧ (cover.cacheEntry trace hlog entry).finalCache ≤ finalCache := + hcaches _ (cover.cacheEntry_mem trace hlog entry) + +theorem FewTimeCover.cacheEntry_request_signature {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (entry : cover.entries) : + let selected := cover.select (cover.representativeTree entry) + (cover.cacheEntry trace hlog entry).request = selected.entry.1 + ∧ (cover.cacheEntry trace hlog entry).signature = some selected.signature := by + let selected := cover.select (cover.representativeTree entry) + have hpair : + ((cover.cacheEntry trace hlog entry).request, + (cover.cacheEntry trace hlog entry).signature) = selected.entry.flat := + (cover.cacheEntry_flat trace hlog entry).trans + (cover.representativeTree_spec entry).symm + exact ⟨congrArg Prod.fst hpair, (congrArg Prod.snd hpair).trans selected.response_eq⟩ + +theorem FewTimeCover.cacheEntry_successfulSignRun {f : QueryImpl HashSpec Id} + {cache finalCache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (hvalid : trace.ValidRuns secretKey) (hcaches : trace.CachesLe finalCache) + (hf : finalCache.AgreesWithFn f) (entry : cover.entries) : + let selected := cover.select (cover.representativeTree entry) + SuccessfulSignRun f finalCache secretKey selected.entry.1 selected.signature := by + let selected := cover.select (cover.representativeTree entry) + have hfields := cover.cacheEntry_request_signature trace hlog entry + have hrun := SigningCacheEntry.successfulSignRun + (cover.cacheEntry_validRun trace hlog hvalid entry) hfields.2 + (cover.cacheEntry_cachesLe trace hlog hcaches entry).2 hf + simpa only [hfields.1] using hrun + +theorem FewTimeCover.cacheEntry_digest_cached {f : QueryImpl HashSpec Id} + {cache finalCache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (hvalid : trace.ValidRuns secretKey) (hcaches : trace.CachesLe finalCache) + (hf : finalCache.AgreesWithFn f) (entry : cover.entries) : + (cover.cacheEntry trace hlog entry).finalCache (cover.entryDigestInput entry) ≠ none := by + let tracedEntry := cover.cacheEntry trace hlog entry + let selected := cover.select (cover.representativeTree entry) + have hfields := cover.cacheEntry_request_signature trace hlog entry + have hentryLe := (cover.cacheEntry_cachesLe trace hlog hcaches entry).2 + have hentryAgree : tracedEntry.finalCache.AgreesWithFn f := + fun _ _ hcached => hf (hentryLe hcached) + have hrun := SigningCacheEntry.successfulSignRun + (cover.cacheEntry_validRun trace hlog hvalid entry) hfields.2 le_rfl hentryAgree + have hrun' : SuccessfulSignRun f tracedEntry.finalCache secretKey + selected.entry.1 selected.signature := by + simpa only [tracedEntry, selected, hfields.1] using hrun + obtain ⟨_, _, _, hdigest, _, _, _, _, _, _, _⟩ := hrun'.indexed + have hcached := CachedRun.messageDigest_cached hdigest.extract.2.choose_spec.2.2.2.2 + simpa only [FewTimeCover.entryDigestInput, selected, tracedEntry] using hcached + +def FewTimeCover.EntryDigestPrecached {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (entry : cover.entries) : Prop := + (cover.cacheEntry trace hlog entry).initialCache (cover.entryDigestInput entry) ≠ none + +theorem FewTimeCover.entryDigest_cache_miss_then_hit {f : QueryImpl HashSpec Id} + {cache finalCache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (hvalid : trace.ValidRuns secretKey) (hcaches : trace.CachesLe finalCache) + (hf : finalCache.AgreesWithFn f) (entry : cover.entries) + (hfresh : ¬ cover.EntryDigestPrecached trace hlog entry) : + (cover.cacheEntry trace hlog entry).initialCache (cover.entryDigestInput entry) = none + ∧ (cover.cacheEntry trace hlog entry).finalCache (cover.entryDigestInput entry) ≠ none := by + exact ⟨not_ne_iff.mp hfresh, + cover.cacheEntry_digest_cached trace hlog hvalid hcaches hf entry⟩ + +theorem FewTimeCover.earlier_successful_digest_input_ne + {f : QueryImpl HashSpec Id} {cache finalCache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (hvalid : trace.ValidRuns secretKey) (hcaches : trace.CachesLe finalCache) + (hf : finalCache.AgreesWithFn f) (entry : cover.entries) + (earlier : Fin trace.length) + (hearlier : earlier.val < (cover.logIndex entry).val) + (earlierSignature : Signature) + (hresponse : (trace.get earlier).signature = some earlierSignature) : + tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root (trace.get earlier).request + earlierSignature.randomness) + ≠ cover.entryDigestInput entry := by + intro hinput + let selected := cover.select (cover.representativeTree entry) + have hearlierLe := (hcaches (trace.get earlier) (List.get_mem trace earlier)).2 + have hearlierRun := SigningCacheEntry.successfulSignRun + (hvalid (trace.get earlier) (List.get_mem trace earlier)) hresponse hearlierLe hf + have hselectedRun := cover.cacheEntry_successfulSignRun trace hlog hvalid hcaches hf entry + have hpayload := (tweakableHashInput_injective secretKey.parameter (by trivial) (by trivial) + hinput).2 + obtain ⟨hmessage, hrandomness⟩ := messageDigestPayload_injective secretKey.root hpayload + have hsignature : earlierSignature = selected.signature := + successfulSignRun_signature_eq hearlierRun hselectedRun hmessage hrandomness + have hflat := cover.cacheEntry_first_flat trace hlog entry earlier hearlier + apply hflat + rw [← cover.representativeTree_spec entry] + apply Prod.ext + · exact hmessage + · change (trace.get earlier).signature = selected.entry.2 + exact hresponse.trans ((congrArg some hsignature).trans selected.response_eq.symm) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeUniform.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeUniform.lean new file mode 100644 index 00000000..d3702e35 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeUniform.lean @@ -0,0 +1,488 @@ +import SphincsSecurity.Proof.FewTimeProbability +import SphincsSecurity.Proof.Guess + +/-! +# Uniform few-time views + +The low 166 bits of a fresh oracle answer are exactly the 26-bit index and the fourteen 10-bit +few-time leaf coordinates used by a coverage pattern. Splitting an answer into low and high bits is +bijective, as is decoding those low bits into a few-time view, so the induced view is uniform. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +def splitHashOutput (width : Nat) (output : HashOutput) : + BitVec width × BitVec (hashOutputBits - width) := + (output.extractLsb' 0 width, + output.extractLsb' width (hashOutputBits - width)) + +theorem splitHashOutput_injective {width : Nat} (hwidth : width ≤ hashOutputBits) : + Function.Injective (splitHashOutput width) := by + intro left right heq + apply hashOutput_eq_of_extract hwidth + · exact congrArg Prod.fst heq + · exact congrArg Prod.snd heq + +theorem splitHashOutput_bijective {width : Nat} (hwidth : width ≤ hashOutputBits) : + Function.Bijective (splitHashOutput width) := by + apply (Fintype.bijective_iff_injective_and_card _).2 + refine ⟨splitHashOutput_injective hwidth, ?_⟩ + rw [Fintype.card_prod, card_bitVec, card_bitVec, card_bitVec, ← pow_add] + congr + omega + +noncomputable def splitHashOutputEquiv (width : Nat) (hwidth : width ≤ hashOutputBits) : + HashOutput ≃ BitVec width × BitVec (hashOutputBits - width) := + Equiv.ofBijective (splitHashOutput width) (splitHashOutput_bijective hwidth) + +theorem evalDist_hashOutput_extract_uniform {width : Nat} (hwidth : width ≤ hashOutputBits) : + 𝒟[(fun output : HashOutput => output.extractLsb' 0 width) <$> + ($ᵗ HashOutput : ProbComp HashOutput)] = + 𝒟[($ᵗ BitVec width : ProbComp (BitVec width))] := by + let split := splitHashOutput width + have hmap : + (fun output : HashOutput => output.extractLsb' 0 width) <$> + ($ᵗ HashOutput : ProbComp HashOutput) = + Prod.fst <$> (split <$> ($ᵗ HashOutput : ProbComp HashOutput)) := by + simp [Functor.map_map, split, splitHashOutput] + rw [hmap] + have hsplit : + 𝒟[split <$> ($ᵗ HashOutput : ProbComp HashOutput)] = + 𝒟[($ᵗ (BitVec width × BitVec (hashOutputBits - width)) : + ProbComp (BitVec width × BitVec (hashOutputBits - width)))] := + evalDist_map_bijective_uniform_cross + (α := HashOutput) (β := BitVec width × BitVec (hashOutputBits - width)) + split (splitHashOutput_bijective hwidth) + rw [evalDist_map, hsplit, ← evalDist_map] + exact evalDist_map_fst_uniformSample_prod + +namespace Concrete + +def fewTimeViewBits : Nat := totalHeight + ftsTreeHeight * (ftsTrees - 1) + +def fewTimeViewOfBits (bits : BitVec fewTimeViewBits) : FewTimeView := + ((bits.extractLsb' 0 totalHeight).toFin, + fun tree => + (bits.extractLsb' (totalHeight + ftsTreeHeight * tree.val) ftsTreeHeight).toFin) + +theorem fewTimeViewOfBits_injective : Function.Injective fewTimeViewOfBits := by + intro left right heq + apply BitVec.eq_of_getLsbD_eq + intro position hposition + by_cases hindex : position < totalHeight + · have hcomponent := congrArg (fun view : FewTimeView => BitVec.ofFin view.1) heq + have hbit := congrArg (fun bits : BitVec totalHeight => bits.getLsbD position) hcomponent + simpa [fewTimeViewOfBits, BitVec.getLsbD_extractLsb', hindex] using hbit + · let treeIndex := (position - totalHeight) / ftsTreeHeight + have htreeIndex : treeIndex < ftsTrees - 1 := by + have hposition' : position < 166 := by + simpa [fewTimeViewBits, totalHeight, ftsTreeHeight, ftsTrees] using hposition + have hindex' : 26 ≤ position := by + simpa [totalHeight] using Nat.le_of_not_gt hindex + simp only [treeIndex, ftsTrees, ftsTreeHeight, totalHeight] + omega + let tree : FtsTree := ⟨treeIndex, htreeIndex⟩ + let within := (position - totalHeight) % ftsTreeHeight + have hwithin : within < ftsTreeHeight := by + simp only [within, ftsTreeHeight] + omega + have hoffset : totalHeight + ftsTreeHeight * tree.val + within = position := by + have hindex' : totalHeight ≤ position := Nat.le_of_not_gt hindex + simp only [tree, treeIndex, within] + calc + totalHeight + ftsTreeHeight * ((position - totalHeight) / ftsTreeHeight) + + (position - totalHeight) % ftsTreeHeight = + totalHeight + ((position - totalHeight) % ftsTreeHeight + + ftsTreeHeight * ((position - totalHeight) / ftsTreeHeight)) := by omega + _ = totalHeight + (position - totalHeight) := by rw [Nat.mod_add_div] + _ = position := Nat.add_sub_of_le hindex' + have hcomponent := congrArg (fun view : FewTimeView => BitVec.ofFin (view.2 tree)) heq + change left.extractLsb' (totalHeight + ftsTreeHeight * tree.val) ftsTreeHeight = + right.extractLsb' (totalHeight + ftsTreeHeight * tree.val) ftsTreeHeight at hcomponent + have hcomponent' : + left.extractLsb' (totalHeight + ftsTreeHeight * tree.val) ftsTreeHeight = + right.extractLsb' (totalHeight + ftsTreeHeight * tree.val) ftsTreeHeight := by + exact hcomponent + have hbit := congrArg (fun bits : BitVec ftsTreeHeight => bits.getLsbD within) hcomponent' + simp only [BitVec.getLsbD_extractLsb', hwithin, decide_true, Bool.true_and] at hbit + rwa [hoffset] at hbit + +theorem fewTimeViewOfBits_bijective : Function.Bijective fewTimeViewOfBits := by + apply (Fintype.bijective_iff_injective_and_card _).2 + refine ⟨fewTimeViewOfBits_injective, ?_⟩ + rw [card_bitVec, fewTimeView_card] + rfl + +def hashOutputFewTimeView (output : HashOutput) : FewTimeView := + (digestIndex (truncateMessageDigest output), + fun tree => digestLeaves (truncateMessageDigest output) (ftsIndexOf tree)) + +theorem hashOutputFewTimeView_eq (output : HashOutput) : + hashOutputFewTimeView output = + fewTimeViewOfBits (output.extractLsb' 0 fewTimeViewBits) := by + apply Prod.ext + · change digestIndex (truncateMessageDigest output) = + ((output.extractLsb' 0 fewTimeViewBits).extractLsb' 0 totalHeight).toFin + rw [digestIndex] + apply congrArg BitVec.toFin + apply BitVec.eq_of_getLsbD_eq + intro position hposition + simp only [truncateMessageDigest, BitVec.getLsbD_extractLsb', hposition, + decide_true, Bool.true_and, Nat.zero_add] + have hmessage : position < messageDigestBits := by + simp only [messageDigestBits, totalHeight, ftsTrees, ftsTreeHeight] at hposition ⊢ + omega + have hview : position < fewTimeViewBits := by + simp only [fewTimeViewBits, totalHeight, ftsTrees, ftsTreeHeight] at hposition ⊢ + omega + simp [hmessage, hview] + · funext tree + change digestLeaves (truncateMessageDigest output) (ftsIndexOf tree) = + ((output.extractLsb' 0 fewTimeViewBits).extractLsb' + (totalHeight + ftsTreeHeight * tree.val) ftsTreeHeight).toFin + rw [digestLeaves] + apply congrArg BitVec.toFin + apply BitVec.eq_of_getLsbD_eq + intro position hposition + simp only [truncateMessageDigest, BitVec.getLsbD_extractLsb', hposition, + decide_true, Bool.true_and] + have hoffset : totalHeight + ftsTreeHeight * (ftsIndexOf tree).val = + totalHeight + ftsTreeHeight * tree.val := by rfl + rw [hoffset] + have hmessage : totalHeight + ftsTreeHeight * tree.val + position < + messageDigestBits := by + have htree := tree.isLt + simp only [messageDigestBits, totalHeight, ftsTrees, ftsTreeHeight] at hposition htree ⊢ + omega + have hview : totalHeight + ftsTreeHeight * tree.val + position < + fewTimeViewBits := by + have htree := tree.isLt + simp only [fewTimeViewBits, totalHeight, ftsTrees, ftsTreeHeight] at hposition htree ⊢ + omega + simp [hmessage, hview] + +set_option maxRecDepth 100000 in +theorem evalDist_hashOutputFewTimeView_uniform : + 𝒟[hashOutputFewTimeView <$> ($ᵗ HashOutput : ProbComp HashOutput)] = + 𝒟[($ᵗ FewTimeView : ProbComp FewTimeView)] := by + rw [show hashOutputFewTimeView = fewTimeViewOfBits ∘ + (fun output : HashOutput => output.extractLsb' 0 fewTimeViewBits) from by + funext output + exact hashOutputFewTimeView_eq output] + calc + 𝒟[(fewTimeViewOfBits ∘ + fun output : HashOutput => output.extractLsb' 0 fewTimeViewBits) <$> + ($ᵗ HashOutput : ProbComp HashOutput)] = + fewTimeViewOfBits <$> + 𝒟[(fun output : HashOutput => output.extractLsb' 0 fewTimeViewBits) <$> + ($ᵗ HashOutput : ProbComp HashOutput)] := by + rw [evalDist_map, evalDist_map, Functor.map_map] + change (fun output : HashOutput => + fewTimeViewOfBits (output.extractLsb' 0 fewTimeViewBits)) <$> + 𝒟[($ᵗ HashOutput : ProbComp HashOutput)] = _ + rfl + _ = fewTimeViewOfBits <$> + 𝒟[($ᵗ BitVec fewTimeViewBits : ProbComp (BitVec fewTimeViewBits))] := by + rw [evalDist_hashOutput_extract_uniform + (show fewTimeViewBits ≤ hashOutputBits by decide)] + _ = 𝒟[fewTimeViewOfBits <$> + ($ᵗ BitVec fewTimeViewBits : ProbComp (BitVec fewTimeViewBits))] := by + rw [evalDist_map] + _ = 𝒟[($ᵗ FewTimeView : ProbComp FewTimeView)] := + evalDist_map_bijective_uniform_cross + (α := BitVec fewTimeViewBits) (β := FewTimeView) + fewTimeViewOfBits fewTimeViewOfBits_bijective + +abbrev FullDigestView := Index × (DigestTree → FtsLeaf) + +def fullDigestView (digest : MessageDigest) : FullDigestView := + (digestIndex digest, digestLeaves digest) + +theorem fullDigestView_injective : Function.Injective fullDigestView := by + intro left right heq + apply BitVec.eq_of_getLsbD_eq + intro position hposition + by_cases hindex : position < totalHeight + · have hcomponent := congrArg (fun view : FullDigestView => BitVec.ofFin view.1) heq + have hbit := congrArg (fun bits : BitVec totalHeight => bits.getLsbD position) hcomponent + simpa [fullDigestView, digestIndex, BitVec.getLsbD_extractLsb', hindex] using hbit + · let treeIndex := (position - totalHeight) / ftsTreeHeight + have htreeIndex : treeIndex < ftsTrees := by + have hposition' : position < 176 := by + simpa [messageDigestBits, totalHeight, ftsTrees, ftsTreeHeight] using hposition + have hindex' : 26 ≤ position := by + simpa [totalHeight] using Nat.le_of_not_gt hindex + simp only [treeIndex, ftsTrees, ftsTreeHeight, totalHeight] + omega + let tree : DigestTree := ⟨treeIndex, htreeIndex⟩ + let within := (position - totalHeight) % ftsTreeHeight + have hwithin : within < ftsTreeHeight := by + simp only [within, ftsTreeHeight] + omega + have hoffset : totalHeight + ftsTreeHeight * tree.val + within = position := by + have hindex' : totalHeight ≤ position := Nat.le_of_not_gt hindex + simp only [tree, treeIndex, within] + calc + totalHeight + ftsTreeHeight * ((position - totalHeight) / ftsTreeHeight) + + (position - totalHeight) % ftsTreeHeight = + totalHeight + ((position - totalHeight) % ftsTreeHeight + + ftsTreeHeight * ((position - totalHeight) / ftsTreeHeight)) := by omega + _ = totalHeight + (position - totalHeight) := by rw [Nat.mod_add_div] + _ = position := Nat.add_sub_of_le hindex' + have hcomponent := congrArg (fun view : FullDigestView => BitVec.ofFin (view.2 tree)) heq + change left.extractLsb' (totalHeight + ftsTreeHeight * tree.val) ftsTreeHeight = + right.extractLsb' (totalHeight + ftsTreeHeight * tree.val) ftsTreeHeight at hcomponent + have hbit := congrArg (fun bits : BitVec ftsTreeHeight => bits.getLsbD within) hcomponent + simp only [BitVec.getLsbD_extractLsb', hwithin, decide_true, Bool.true_and] at hbit + rwa [hoffset] at hbit + +theorem fullDigestView_bijective : Function.Bijective fullDigestView := by + apply (Fintype.bijective_iff_injective_and_card _).2 + refine ⟨fullDigestView_injective, ?_⟩ + rw [card_bitVec, Fintype.card_prod, Fintype.card_fin, Fintype.card_fun, + Fintype.card_fin, Fintype.card_fin, ← pow_mul, ← pow_add] + rfl + +def splitFullDigestView (view : FullDigestView) : FewTimeView × FtsLeaf := + ((view.1, fun tree => view.2 (ftsIndexOf tree)), view.2 lastDigestTree) + +theorem splitFullDigestView_injective : Function.Injective splitFullDigestView := by + intro left right heq + apply Prod.ext + · exact congrArg (fun view : FewTimeView × FtsLeaf => view.1.1) heq + · funext tree + rcases digestTree_eq_ftsIndexOf_or_last tree with ⟨ftsTree, rfl⟩ | rfl + · have hfunctions := congrArg (fun view : FewTimeView × FtsLeaf => view.1.2) heq + exact congrFun hfunctions ftsTree + · exact congrArg Prod.snd heq + +theorem splitFullDigestView_bijective : Function.Bijective splitFullDigestView := by + apply (Fintype.bijective_iff_injective_and_card _).2 + refine ⟨splitFullDigestView_injective, ?_⟩ + rw [Fintype.card_prod, Fintype.card_fin, Fintype.card_fun, Fintype.card_fin, + Fintype.card_prod, fewTimeView_card, Fintype.card_fin, ← pow_mul, ← pow_add] + norm_num [totalHeight, ftsTreeHeight, ftsTrees] + +def digestCoordinates (digest : MessageDigest) : FewTimeView × FtsLeaf := + splitFullDigestView (fullDigestView digest) + +theorem digestCoordinates_bijective : Function.Bijective digestCoordinates := + splitFullDigestView_bijective.comp fullDigestView_bijective + +noncomputable def digestCoordinatesEquiv : MessageDigest ≃ FewTimeView × FtsLeaf := + Equiv.ofBijective digestCoordinates digestCoordinates_bijective + +theorem hashOutput_digestCoordinates (output : HashOutput) : + digestCoordinates (truncateMessageDigest output) = + (hashOutputFewTimeView output, + digestLeaves (truncateMessageDigest output) lastDigestTree) := rfl + +set_option maxRecDepth 100000 in +theorem evalDist_hashOutput_digestCoordinates_uniform : + 𝒟[(fun output : HashOutput => digestCoordinates (truncateMessageDigest output)) <$> + ($ᵗ HashOutput : ProbComp HashOutput)] = + 𝒟[($ᵗ (FewTimeView × FtsLeaf) : ProbComp (FewTimeView × FtsLeaf))] := by + calc + 𝒟[(fun output : HashOutput => digestCoordinates (truncateMessageDigest output)) <$> + ($ᵗ HashOutput : ProbComp HashOutput)] = + digestCoordinates <$> + 𝒟[truncateMessageDigest <$> ($ᵗ HashOutput : ProbComp HashOutput)] := by + rw [evalDist_map, evalDist_map, Functor.map_map] + _ = digestCoordinates <$> + 𝒟[($ᵗ MessageDigest : ProbComp MessageDigest)] := by + rw [show truncateMessageDigest = + (fun output : HashOutput => output.extractLsb' 0 messageDigestBits) from rfl, + evalDist_hashOutput_extract_uniform + (show messageDigestBits ≤ hashOutputBits by decide)] + _ = 𝒟[digestCoordinates <$> + ($ᵗ MessageDigest : ProbComp MessageDigest)] := by + rw [evalDist_map] + _ = 𝒟[($ᵗ (FewTimeView × FtsLeaf) : + ProbComp (FewTimeView × FtsLeaf))] := + evalDist_map_bijective_uniform_cross + (α := MessageDigest) (β := FewTimeView × FtsLeaf) + digestCoordinates digestCoordinates_bijective + +abbrev HashOutputCoordinates := + (FewTimeView × FtsLeaf) × BitVec (hashOutputBits - messageDigestBits) + +noncomputable def hashOutputCoordinatesEquiv : HashOutput ≃ HashOutputCoordinates := + (splitHashOutputEquiv messageDigestBits + (show messageDigestBits ≤ hashOutputBits by decide)).trans + (Equiv.prodCongr digestCoordinatesEquiv + (Equiv.refl (BitVec (hashOutputBits - messageDigestBits)))) + +theorem hashOutputCoordinatesEquiv_apply (output : HashOutput) : + hashOutputCoordinatesEquiv output = + ((hashOutputFewTimeView output, + digestLeaves (truncateMessageDigest output) lastDigestTree), + output.extractLsb' messageDigestBits (hashOutputBits - messageDigestBits)) := rfl + +set_option maxRecDepth 100000 in +theorem evalDist_uniformHashOutput_bind_coordinates {Result : Type} + (continuation : HashOutput → ProbComp Result) : + 𝒟[($ᵗ HashOutput : ProbComp HashOutput) >>= continuation] = + 𝒟[($ᵗ HashOutputCoordinates : ProbComp HashOutputCoordinates) >>= + fun coordinates => continuation (hashOutputCoordinatesEquiv.symm coordinates)] := by + have hmap : + 𝒟[hashOutputCoordinatesEquiv <$> ($ᵗ HashOutput : ProbComp HashOutput)] = + 𝒟[($ᵗ HashOutputCoordinates : ProbComp HashOutputCoordinates)] := + evalDist_map_bijective_uniform_cross + (α := HashOutput) (β := HashOutputCoordinates) + hashOutputCoordinatesEquiv hashOutputCoordinatesEquiv.bijective + have hcomputation : + (hashOutputCoordinatesEquiv <$> ($ᵗ HashOutput : ProbComp HashOutput)) >>= + (fun coordinates => + continuation (hashOutputCoordinatesEquiv.symm coordinates)) = + ($ᵗ HashOutput : ProbComp HashOutput) >>= continuation := by + simp [map_eq_bind_pure_comp, bind_assoc] + rw [← hcomputation, evalDist_bind, hmap, ← evalDist_bind] + +set_option maxRecDepth 100000 in +theorem evalDist_randomOracle_fresh_bind_coordinates {Result : Type} + (input : HashInput) (cache : QueryCache HashSpec) (hcache : cache input = none) + (continuation : HashOutput × QueryCache HashSpec → ProbComp Result) : + 𝒟[(randomOracle input).run cache >>= continuation] = + 𝒟[($ᵗ HashOutputCoordinates : ProbComp HashOutputCoordinates) >>= + fun coordinates => + let output := hashOutputCoordinatesEquiv.symm coordinates + continuation (output, cache.cacheQuery input output)] := by + rw [OracleSpec.randomOracle, QueryImpl.withCaching_run_none _ hcache] + change 𝒟[((fun output : HashOutput => (output, cache.cacheQuery input output)) <$> + ($ᵗ HashOutput : ProbComp HashOutput)) >>= continuation] = _ + have hcomputation : + ((fun output : HashOutput => (output, cache.cacheQuery input output)) <$> + ($ᵗ HashOutput : ProbComp HashOutput)) >>= continuation = + ($ᵗ HashOutput : ProbComp HashOutput) >>= fun output => + continuation (output, cache.cacheQuery input output) := by + simp [map_eq_bind_pure_comp, bind_assoc] + rw [hcomputation] + exact evalDist_uniformHashOutput_bind_coordinates fun output => + continuation (output, cache.cacheQuery input output) + +def signAttemptResultOfOutput (output : HashOutput) : + Option (Index × (DigestTree → FtsLeaf)) := + let digest := truncateMessageDigest output + if Admissible digest then some (digestIndex digest, digestLeaves digest) else none + +theorem hashOutputCoordinatesEquiv_symm_digestCoordinates + (coordinates : HashOutputCoordinates) : + digestCoordinates (truncateMessageDigest (hashOutputCoordinatesEquiv.symm coordinates)) = + coordinates.1 := by + have heq := hashOutputCoordinatesEquiv.apply_symm_apply coordinates + rw [hashOutputCoordinatesEquiv_apply] at heq + exact congrArg Prod.fst heq + +theorem hashOutputCoordinatesEquiv_symm_view (coordinates : HashOutputCoordinates) : + hashOutputFewTimeView (hashOutputCoordinatesEquiv.symm coordinates) = coordinates.1.1 := by + change (digestCoordinates + (truncateMessageDigest (hashOutputCoordinatesEquiv.symm coordinates))).1 = coordinates.1.1 + exact congrArg Prod.fst (hashOutputCoordinatesEquiv_symm_digestCoordinates coordinates) + +theorem hashOutputCoordinatesEquiv_symm_lastLeaf (coordinates : HashOutputCoordinates) : + digestLeaves (truncateMessageDigest (hashOutputCoordinatesEquiv.symm coordinates)) + lastDigestTree = coordinates.1.2 := by + change (digestCoordinates + (truncateMessageDigest (hashOutputCoordinatesEquiv.symm coordinates))).2 = coordinates.1.2 + exact congrArg Prod.snd (hashOutputCoordinatesEquiv_symm_digestCoordinates coordinates) + +theorem signAttemptResultOfOutput_ne_none_iff (output : HashOutput) : + signAttemptResultOfOutput output ≠ none ↔ + Admissible (truncateMessageDigest output) := by + simp only [signAttemptResultOfOutput] + split <;> simp_all + +theorem signAttemptResultOfOutput_coordinates_ne_none_iff + (coordinates : HashOutputCoordinates) : + signAttemptResultOfOutput (hashOutputCoordinatesEquiv.symm coordinates) ≠ none ↔ + coordinates.1.2 = 0 := by + rw [signAttemptResultOfOutput_ne_none_iff, Admissible, + hashOutputCoordinatesEquiv_symm_lastLeaf] + +theorem signAttemptResultOfOutput_coordinates_view + (coordinates : HashOutputCoordinates) (index : Index) + (leaves : DigestTree → FtsLeaf) + (hresult : signAttemptResultOfOutput (hashOutputCoordinatesEquiv.symm coordinates) = + some (index, leaves)) : + (index, fun tree => leaves (ftsIndexOf tree)) = coordinates.1.1 := by + let output := hashOutputCoordinatesEquiv.symm coordinates + simp only [signAttemptResultOfOutput] at hresult + split at hresult + · have hpair := Option.some.inj hresult + obtain ⟨rfl, rfl⟩ := Prod.mk.inj hpair + exact hashOutputCoordinatesEquiv_symm_view coordinates + · simp at hresult + +theorem signAttemptResultOfOutput_view (output : HashOutput) (index : Index) + (leaves : DigestTree → FtsLeaf) + (hresult : signAttemptResultOfOutput output = some (index, leaves)) : + (index, fun tree => leaves (ftsIndexOf tree)) = hashOutputFewTimeView output := by + let coordinates := hashOutputCoordinatesEquiv output + calc + (index, fun tree => leaves (ftsIndexOf tree)) = coordinates.1.1 := by + apply signAttemptResultOfOutput_coordinates_view coordinates index leaves + simpa [coordinates] using hresult + _ = hashOutputFewTimeView output := by + dsimp only [coordinates] + rw [hashOutputCoordinatesEquiv_apply] + +theorem simulateQ_signAttempt_run_eq (secretKey : SecretKey) (message : Message) + (randomness : Randomness) (cache : QueryCache HashSpec) : + (simulateQ (randomOracle : QueryImpl HashSpec _) + (signAttempt secretKey message randomness)).run cache = + (randomOracle (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness))).run cache >>= + fun result => pure (signAttemptResultOfOutput result.1, result.2) := by + have hquery : + simulateQ (randomOracle : QueryImpl HashSpec _) + (oracleHash (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) : + OracleComp HashSpec HashOutput) = + randomOracle (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) := by + change simulateQ (randomOracle : QueryImpl HashSpec _) + (liftM (HashSpec.query (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)))) = _ + exact simulateQ_spec_query + (impl := (randomOracle : QueryImpl HashSpec + (StateT (QueryCache HashSpec) ProbComp))) + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) + rw [signAttempt, simulateQ_bind, StateT.run_bind, messageDigest, + simulateQ_bind, StateT.run_bind, hquery] + simp only [signAttemptResultOfOutput, simulateQ_pure, StateT.run_pure] + simp only [bind_assoc, pure_bind] + apply bind_congr + intro result + split <;> rfl + +set_option maxRecDepth 100000 in +theorem evalDist_signAttempt_fresh_bind_coordinates {Result : Type} + (secretKey : SecretKey) (message : Message) (randomness : Randomness) + (cache : QueryCache HashSpec) + (hcache : cache (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) = none) + (continuation : + Option (Index × (DigestTree → FtsLeaf)) × QueryCache HashSpec → + ProbComp Result) : + 𝒟[(simulateQ (randomOracle : QueryImpl HashSpec _) + (signAttempt secretKey message randomness)).run cache >>= continuation] = + 𝒟[($ᵗ HashOutputCoordinates : ProbComp HashOutputCoordinates) >>= + fun coordinates => + let output := hashOutputCoordinatesEquiv.symm coordinates + continuation (signAttemptResultOfOutput output, + cache.cacheQuery + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) output)] := by + rw [simulateQ_signAttempt_run_eq] + simp only [bind_assoc, pure_bind] + exact evalDist_randomOracle_fresh_bind_coordinates + (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) cache hcache + (fun result => continuation (signAttemptResultOfOutput result.1, result.2)) + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeViewTrace.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeViewTrace.lean new file mode 100644 index 00000000..09a5dd1d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeViewTrace.lean @@ -0,0 +1,817 @@ +import SphincsSecurity.Proof.FewTimeSignerView +import SphincsSecurity.Proof.FewTimeTrace +import SphincsSecurity.Proof.FullTrace + +/-! +# Full adversary trace with signer views + +The viewed trace augments the existing full cache trace with one optional digest view per signing +invocation. Its projection is exactly the existing trace, so all deterministic source and cache +invariants remain available unchanged. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +theorem randomOracle_output_cached (input : HashInput) + (initialCache finalCache : QueryCache HashSpec) (output : HashOutput) + (hmem : (output, finalCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (Concrete.oracleHash input)).run initialCache)) : + finalCache input = some output := by + have hquery : simulateQ (randomOracle : QueryImpl HashSpec _) + (Concrete.oracleHash input) = randomOracle input := by + change simulateQ (randomOracle : QueryImpl HashSpec _) + (liftM (HashSpec.query input)) = _ + exact simulateQ_spec_query + (impl := (randomOracle : QueryImpl HashSpec + (StateT (QueryCache HashSpec) ProbComp))) input + rw [hquery] at hmem + cases hcache : initialCache input with + | none => + rw [OracleSpec.randomOracle, + QueryImpl.withCaching_run_none uniformSampleImpl hcache, support_map] at hmem + obtain ⟨sampledOutput, _, heq⟩ := hmem + obtain ⟨rfl, rfl⟩ := heq + exact QueryCache.cacheQuery_self initialCache input output + | some cachedOutput => + rw [OracleSpec.randomOracle, + QueryImpl.withCaching_run_some uniformSampleImpl hcache, + support_pure, Set.mem_singleton_iff] at hmem + obtain ⟨rfl, rfl⟩ := hmem + exact hcache + +structure ViewedFullTraceState where + cache : QueryCache HashSpec + trace : FullAdversaryTrace + views : List (Option Concrete.FewTimeView) + targetView : Option Concrete.FewTimeView + +def ViewedFullTraceState.base (state : ViewedFullTraceState) : + QueryCache HashSpec × FullAdversaryTrace := + (state.cache, state.trace) + +def SigningCacheEntry.ValidView (secretKey : SecretKey) (entry : SigningCacheEntry) + (view : Option Concrete.FewTimeView) : Prop := + ((entry.signature, view), entry.finalCache) ∈ support + ((simulateQ romImpl (Concrete.signWithView secretKey entry.request)).run entry.initialCache) + +def ViewedFullTraceState.ValidViews (secretKey : SecretKey) + (state : ViewedFullTraceState) : Prop := + List.Forall₂ (SigningCacheEntry.ValidView secretKey) state.trace.signing state.views + +theorem ViewedFullTraceState.ValidViews.length_eq {secretKey : SecretKey} + {state : ViewedFullTraceState} (hvalid : state.ValidViews secretKey) : + state.trace.signing.length = state.views.length := + List.Forall₂.length_eq hvalid + +noncomputable def ViewedFullTraceState.ValidViews.signingViews {secretKey : SecretKey} + {state : ViewedFullTraceState} (hvalid : state.ValidViews secretKey) : + Fin state.trace.signing.length → Concrete.FewTimeView := + fun position => + (state.views.get ⟨position.val, by rw [← hvalid.length_eq]; exact position.isLt⟩).getD default + +noncomputable def ViewedFullTraceState.ValidViews.signingOptionViews {secretKey : SecretKey} + {state : ViewedFullTraceState} (hvalid : state.ValidViews secretKey) : + Fin state.trace.signing.length → Option Concrete.FewTimeView := + fun position => + state.views.get ⟨position.val, by rw [← hvalid.length_eq]; exact position.isLt⟩ + +noncomputable def ViewedFullTraceState.ValidViews.signingViewsForLog + {secretKey : SecretKey} {state : ViewedFullTraceState} + (hvalid : state.ValidViews secretKey) {signingLog : QueryLog SigningSpec} + (hlog : state.trace.signing.toSigningLog = signingLog) : + Fin signingLog.length → Concrete.FewTimeView := + fun position => hvalid.signingViews ⟨position.val, by + have hlength := congrArg List.length hlog + simpa only [SigningCacheTrace.toSigningLog, List.length_map] using + (show position.val < state.trace.signing.toSigningLog.length by + rw [hlength] + exact position.isLt)⟩ + +noncomputable def ViewedFullTraceState.ValidViews.signingOptionViewsForLog + {secretKey : SecretKey} {state : ViewedFullTraceState} + (hvalid : state.ValidViews secretKey) {signingLog : QueryLog SigningSpec} + (hlog : state.trace.signing.toSigningLog = signingLog) : + Fin signingLog.length → Option Concrete.FewTimeView := + fun position => hvalid.signingOptionViews ⟨position.val, by + have hlength := congrArg List.length hlog + simpa only [SigningCacheTrace.toSigningLog, List.length_map] using + (show position.val < state.trace.signing.toSigningLog.length by + rw [hlength] + exact position.isLt)⟩ + +theorem ViewedFullTraceState.ValidViews.successful_get {secretKey : SecretKey} + {state : ViewedFullTraceState} (hvalid : state.ValidViews secretKey) + (position : Fin state.trace.signing.length) (signature : Signature) + (hresponse : (state.trace.signing.get position).signature = some signature) : + ∃ (viewPosition : Fin state.views.length) (randomness : Randomness) (index : Index) + (leaves : DigestTree → FtsLeaf) (loopCache : QueryCache HashSpec), + viewPosition.val = position.val + ∧ (some (randomness, index, leaves), loopCache) ∈ support + ((simulateQ romImpl (Concrete.signDigestLoop digestAttemptLimit secretKey + (state.trace.signing.get position).request)).run + (state.trace.signing.get position).initialCache) + ∧ (some signature, (state.trace.signing.get position).finalCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec + (StateT (QueryCache HashSpec) ProbComp)) + (Concrete.signAfterDigest secretKey randomness index leaves)).run loopCache) + ∧ state.views.get viewPosition = + some (Concrete.selectedFewTimeView index leaves) := by + let viewPosition : Fin state.views.length := + ⟨position.val, by rw [← hvalid.length_eq]; exact position.isLt⟩ + have hviewRun := hvalid.get position.isLt viewPosition.isLt + change (((state.trace.signing.get position).signature, state.views.get viewPosition), + (state.trace.signing.get position).finalCache) ∈ support + ((simulateQ romImpl (Concrete.signWithView secretKey + (state.trace.signing.get position).request)).run + (state.trace.signing.get position).initialCache) at hviewRun + rw [hresponse] at hviewRun + obtain ⟨randomness, index, leaves, loopCache, hloop, hfinish, hview⟩ := + Concrete.signWithView_support_some secretKey + (state.trace.signing.get position).request + (state.trace.signing.get position).initialCache + (state.trace.signing.get position).finalCache signature + (state.views.get viewPosition) hviewRun + exact ⟨viewPosition, randomness, index, leaves, loopCache, rfl, + hloop, hfinish, hview⟩ + +theorem ViewedFullTraceState.ValidViews.successful_get_fresh_attempt + {secretKey : SecretKey} {state : ViewedFullTraceState} + (hvalid : state.ValidViews secretKey) + (position : Fin state.trace.signing.length) (signature : Signature) + (hresponse : (state.trace.signing.get position).signature = some signature) + (hmiss : (state.trace.signing.get position).initialCache + (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root + (state.trace.signing.get position).request signature.randomness)) = none) : + ∃ (viewPosition : Fin state.views.length) (randomness : Randomness) (index : Index) + (leaves : DigestTree → FtsLeaf) (attemptIndex : Nat) + (attemptCache : QueryCache HashSpec) (output : HashOutput), + viewPosition.val = position.val + ∧ randomness = signature.randomness + ∧ attemptIndex < digestAttemptLimit + ∧ attemptCache (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root + (state.trace.signing.get position).request randomness)) = none + ∧ Concrete.signAttemptResultOfOutput output = some (index, leaves) + ∧ state.views.get viewPosition = + some (Concrete.hashOutputFewTimeView output) := by + obtain ⟨viewPosition, randomness, index, leaves, loopCache, hposition, + hloop, hfinish, hview⟩ := hvalid.successful_get position signature hresponse + have hrandomness : signature.randomness = randomness := + Concrete.signAfterDigest_support_some_randomness secretKey randomness index leaves + loopCache (state.trace.signing.get position).finalCache signature hfinish + have hmiss' : (state.trace.signing.get position).initialCache + (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root + (state.trace.signing.get position).request randomness)) = none := by + rw [← hrandomness] + exact hmiss + obtain ⟨attemptIndex, hattemptIndex, attemptCache, output, hattemptMiss, + hattemptResult, _⟩ := Concrete.signDigestLoop_fresh_selected_attempt + digestAttemptLimit secretKey (state.trace.signing.get position).request + randomness index leaves (state.trace.signing.get position).initialCache loopCache + hmiss' hloop + have houtputView := Concrete.signAttemptResultOfOutput_view output index leaves hattemptResult + refine ⟨viewPosition, randomness, index, leaves, attemptIndex, attemptCache, output, + hposition, hrandomness.symm, hattemptIndex, hattemptMiss, hattemptResult, ?_⟩ + rw [← houtputView] + exact hview + +theorem ViewedFullTraceState.ValidViews.successful_get_eq_honest_view + {f : QueryImpl HashSpec Id} {secretKey : SecretKey} {state : ViewedFullTraceState} + {finalCache : QueryCache HashSpec} (hvalid : state.ValidViews secretKey) + (position : Fin state.trace.signing.length) (signature : Signature) + (hresponse : (state.trace.signing.get position).signature = some signature) + (hle : (state.trace.signing.get position).finalCache ≤ finalCache) + (hf : finalCache.AgreesWithFn f) (index : Index) (leaves : DigestTree → FtsLeaf) + (hhonest : Concrete.HonestFtsSignAt f finalCache secretKey + (state.trace.signing.get position).request signature index leaves) : + ∃ viewPosition : Fin state.views.length, + viewPosition.val = position.val + ∧ state.views.get viewPosition = + some (Concrete.selectedFewTimeView index leaves) := by + obtain ⟨viewPosition, randomness, actualIndex, actualLeaves, loopCache, hposition, + hloop, hfinish, hview⟩ := hvalid.successful_get position signature hresponse + have hrandomness : signature.randomness = randomness := + Concrete.signAfterDigest_support_some_randomness secretKey randomness actualIndex actualLeaves + loopCache (state.trace.signing.get position).finalCache signature hfinish + have hloopLeEntry : loopCache ≤ (state.trace.signing.get position).finalCache := + simulateQ_romImpl_cache_le + (liftM (Concrete.signAfterDigest secretKey randomness actualIndex actualLeaves) : + OracleComp OracleWorld (Option Signature)) loopCache + (some signature, (state.trace.signing.get position).finalCache) + (by simpa only [simulateQ_romImpl_liftM] using hfinish) + have hloopLeFinal : loopCache ≤ finalCache := hloopLeEntry.trans hle + have hloopAgree : loopCache.AgreesWithFn f := + fun _ _ hcached => hf (hloopLeFinal hcached) + have hloopReplay := replayRom_of_mem_support + (Concrete.signDigestLoop digestAttemptLimit secretKey + (state.trace.signing.get position).request) + (state.trace.signing.get position).initialCache + (some (randomness, actualIndex, actualLeaves)) loopCache hloop f hloopAgree + have hdigest := Concrete.successfulDigestLoop_of_mem_support f secretKey + (state.trace.signing.get position).request digestAttemptLimit randomness actualIndex + actualLeaves (state.trace.signing.get position).initialCache loopCache finalCache + hloopReplay hloopLeFinal hf + rw [← hrandomness] at hdigest + have hpairs : (actualIndex, actualLeaves) = (index, leaves) := + Option.some.inj (hdigest.2.1.symm.trans hhonest.1.2.1) + obtain ⟨rfl, rfl⟩ := Prod.mk.inj hpairs + exact ⟨viewPosition, hposition, hview⟩ + +theorem ViewedFullTraceState.ValidViews.signingViews_eq_honest_view + {f : QueryImpl HashSpec Id} {secretKey : SecretKey} {state : ViewedFullTraceState} + {finalCache : QueryCache HashSpec} (hvalid : state.ValidViews secretKey) + (position : Fin state.trace.signing.length) (signature : Signature) + (hresponse : (state.trace.signing.get position).signature = some signature) + (hle : (state.trace.signing.get position).finalCache ≤ finalCache) + (hf : finalCache.AgreesWithFn f) (index : Index) (leaves : DigestTree → FtsLeaf) + (hhonest : Concrete.HonestFtsSignAt f finalCache secretKey + (state.trace.signing.get position).request signature index leaves) : + hvalid.signingViews position = Concrete.selectedFewTimeView index leaves := by + obtain ⟨viewPosition, hposition, hview⟩ := + hvalid.successful_get_eq_honest_view position signature hresponse hle hf index leaves hhonest + unfold ViewedFullTraceState.ValidViews.signingViews + let canonical : Fin state.views.length := + ⟨position.val, by rw [← hvalid.length_eq]; exact position.isLt⟩ + have heq : canonical = viewPosition := Fin.ext hposition.symm + rw [show (⟨position.val, by rw [← hvalid.length_eq]; exact position.isLt⟩ : + Fin state.views.length) = viewPosition from heq, hview] + rfl + +theorem ViewedFullTraceState.ValidViews.signingOptionViews_eq_honest_view + {f : QueryImpl HashSpec Id} {secretKey : SecretKey} {state : ViewedFullTraceState} + {finalCache : QueryCache HashSpec} (hvalid : state.ValidViews secretKey) + (position : Fin state.trace.signing.length) (signature : Signature) + (hresponse : (state.trace.signing.get position).signature = some signature) + (hle : (state.trace.signing.get position).finalCache ≤ finalCache) + (hf : finalCache.AgreesWithFn f) (index : Index) (leaves : DigestTree → FtsLeaf) + (hhonest : Concrete.HonestFtsSignAt f finalCache secretKey + (state.trace.signing.get position).request signature index leaves) : + hvalid.signingOptionViews position = + some (Concrete.selectedFewTimeView index leaves) := by + obtain ⟨viewPosition, hposition, hview⟩ := + hvalid.successful_get_eq_honest_view position signature hresponse hle hf index leaves hhonest + unfold ViewedFullTraceState.ValidViews.signingOptionViews + have heq : (⟨position.val, by rw [← hvalid.length_eq]; exact position.isLt⟩ : + Fin state.views.length) = viewPosition := Fin.ext hposition.symm + rw [heq] + exact hview + +private theorem forall₂_append_singleton {R : α → β → Prop} + {left : List α} {right : List β} {a : α} {b : β} + (h : List.Forall₂ R left right) (hab : R a b) : + List.Forall₂ R (left ++ [a]) (right ++ [b]) := by + induction left generalizing right with + | nil => + cases h + exact .cons hab .nil + | cons head tail ih => + cases h with + | cons hhead htail => exact .cons hhead (ih htail) + +noncomputable def viewedFullTracedMappedAdversaryImpl (secretKey : SecretKey) : + QueryImpl (OracleWorld + SigningSpec) (StateT ViewedFullTraceState ProbComp) := by + intro input + cases input with + | inl worldInput => + exact fun state => do + let (output, finalCache) ← (romImpl worldInput).run state.cache + let trace := fullAdversaryTraceUpdate (.inl worldInput) state.cache output + finalCache state.trace + pure (output, ⟨finalCache, trace, state.views, state.targetView⟩) + | inr request => + exact fun state => do + let ((signature, view), finalCache) ← + (simulateQ romImpl (Concrete.signWithView secretKey request)).run state.cache + let trace := fullAdversaryTraceUpdate (.inr request) state.cache signature + finalCache state.trace + pure (signature, ⟨finalCache, trace, state.views ++ [view], state.targetView⟩) + +theorem viewedFullTracedMappedAdversaryImpl_query_validViews + (secretKey : SecretKey) (input : (OracleWorld + SigningSpec).Domain) + (state : ViewedFullTraceState) + (result : (OracleWorld + SigningSpec).Range input × ViewedFullTraceState) + (hvalid : state.ValidViews secretKey) + (hmem : result ∈ support + ((viewedFullTracedMappedAdversaryImpl secretKey input).run state)) : + result.2.ValidViews secretKey := by + cases input with + | inl worldInput => + rw [viewedFullTracedMappedAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨output, finalCache⟩, hquery, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + simpa [ViewedFullTraceState.ValidViews, fullAdversaryTraceUpdate, + signingCacheTraceUpdate] using hvalid + | inr request => + rw [viewedFullTracedMappedAdversaryImpl] at hmem + simp only [StateT.run, mem_support_bind_iff] at hmem + obtain ⟨⟨⟨signature, view⟩, finalCache⟩, hquery, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + apply forall₂_append_singleton hvalid + exact hquery + +theorem viewedFullTracedMappedAdversaryImpl_validViews + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : ViewedFullTraceState) + (result : α × ViewedFullTraceState) + (hvalid : initialState.ValidViews secretKey) + (hmem : result ∈ support + ((simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run initialState)) : + result.2.ValidViews secretKey := by + exact OracleComp.simulateQ_run_preservesInv + (viewedFullTracedMappedAdversaryImpl secretKey) + (ViewedFullTraceState.ValidViews secretKey) + (by + intro input state hstate queryResult hquery + exact viewedFullTracedMappedAdversaryImpl_query_validViews secretKey input state + queryResult hstate hquery) + computation initialState hvalid result hmem + +theorem viewedFullTracedMappedAdversaryImpl_query_projection + (secretKey : SecretKey) (input : (OracleWorld + SigningSpec).Domain) + (state : ViewedFullTraceState) : + (fun result => (result.1, result.2.base)) <$> + ((viewedFullTracedMappedAdversaryImpl secretKey input).run state) = + (fullTracedMappedAdversaryImpl secretKey input).run state.base := by + cases input with + | inl worldInput => + rw [viewedFullTracedMappedAdversaryImpl, fullTracedMappedAdversaryImpl, + QueryImpl.extendState_apply, unloggedMappedAdversaryImpl] + simp only [map_eq_bind_pure_comp, ViewedFullTraceState.base] + unfold StateT.run + simp only [Function.comp_apply, bind_assoc, pure_bind] + change (romImpl worldInput state.cache >>= fun result => + pure (result.1, (result.2, fullAdversaryTraceUpdate (.inl worldInput) + state.cache result.1 result.2 state.trace))) = + (romImpl worldInput state.cache >>= fun result => + pure (result.1, (result.2, fullAdversaryTraceUpdate (.inl worldInput) + state.cache result.1 result.2 state.trace))) + rfl + | inr request => + rw [viewedFullTracedMappedAdversaryImpl, fullTracedMappedAdversaryImpl, + QueryImpl.extendState_apply, unloggedMappedAdversaryImpl] + simp only [map_eq_bind_pure_comp, ViewedFullTraceState.base] + unfold StateT.run + simp only [Function.comp_apply, bind_assoc, pure_bind] + change (simulateQ romImpl (Concrete.signWithView secretKey request) state.cache >>= + fun result => pure (result.1.1, + (result.2, fullAdversaryTraceUpdate (.inr request) state.cache result.1.1 + result.2 state.trace))) = + (simulateQ romImpl (Concrete.scheme.sign secretKey request) state.cache >>= + fun result => pure (result.1, + (result.2, fullAdversaryTraceUpdate (.inr request) state.cache result.1 + result.2 state.trace))) + have hrun := Concrete.simulateQ_signWithView_fst_run secretKey request state.cache + change (fun result => (result.1.1, result.2)) <$> + simulateQ romImpl (Concrete.signWithView secretKey request) state.cache = + simulateQ romImpl (Concrete.sign secretKey request) state.cache at hrun + rw [show Concrete.scheme.sign secretKey request = Concrete.sign secretKey request from rfl] + rw [← hrun] + simp [map_eq_bind_pure_comp, bind_assoc] + +theorem viewedFullTracedMappedAdversaryImpl_projection + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : ViewedFullTraceState) : + Prod.map id ViewedFullTraceState.base <$> + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run initialState = + (simulateQ (fullTracedMappedAdversaryImpl secretKey) + computation).run initialState.base := by + apply OracleComp.map_run_simulateQ_eq_of_query_map_eq + (viewedFullTracedMappedAdversaryImpl secretKey) + (fullTracedMappedAdversaryImpl secretKey) + ViewedFullTraceState.base + intro input state + exact viewedFullTracedMappedAdversaryImpl_query_projection secretKey input state + +noncomputable def gameRestWithViewTrace (adversary : Adversary) + (publicKey : PublicKey) (secretKey : SecretKey) (initialCache : QueryCache HashSpec) : + ProbComp ((Forgery × Bool) × ViewedFullTraceState) := do + let (forgery, state) ← + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩ + let ((verified, targetView), finalCache) ← + (simulateQ romImpl + (liftM (Concrete.verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × Concrete.FewTimeView))).run state.cache + let log := state.trace.signing.toSigningLog + let verdict := decide (SigningTranscript.Valid log ∧ + ¬ SigningTranscript.Contains log forgery) && verified + pure ((forgery, verdict), ⟨finalCache, state.trace, state.views, some targetView⟩) + +theorem gameRestWithViewTrace_support_validViews (adversary : Adversary) + (publicKey : PublicKey) (secretKey : SecretKey) (initialCache : QueryCache HashSpec) + (result : (Forgery × Bool) × ViewedFullTraceState) + (hmem : result ∈ support + (gameRestWithViewTrace adversary publicKey secretKey initialCache)) : + result.2.ValidViews secretKey := by + rw [gameRestWithViewTrace, mem_support_bind_iff] at hmem + obtain ⟨⟨forgery, state⟩, hadversary, hfinish⟩ := hmem + rw [mem_support_bind_iff] at hfinish + obtain ⟨⟨verified, finalCache⟩, _, hpure⟩ := hfinish + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + exact viewedFullTracedMappedAdversaryImpl_validViews secretKey + (adversary.main publicKey) ⟨initialCache, ⟨[], [], []⟩, [], none⟩ + (forgery, state) (by simp [ViewedFullTraceState.ValidViews]) hadversary + +theorem gameRestWithViewTrace_support_targetView (adversary : Adversary) + (publicKey : PublicKey) (secretKey : SecretKey) (initialCache : QueryCache HashSpec) + (result : (Forgery × Bool) × ViewedFullTraceState) + (hmem : result ∈ support + (gameRestWithViewTrace adversary publicKey secretKey initialCache)) : + ∃ (adversaryCache : QueryCache HashSpec) (output : HashOutput) + (digestCache : QueryCache HashSpec), + (output, digestCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (Concrete.oracleHash (tweakableHashInput publicKey.parameter .message + (Concrete.messageDigestPayload publicKey.root result.1.1.message + result.1.1.signature.randomness)))).run adversaryCache) + ∧ digestCache ≤ result.2.cache + ∧ result.2.targetView = some (Concrete.hashOutputFewTimeView output) := by + rw [gameRestWithViewTrace, mem_support_bind_iff] at hmem + obtain ⟨⟨forgery, state⟩, _, hfinish⟩ := hmem + rw [mem_support_bind_iff] at hfinish + obtain ⟨⟨⟨verified, targetView⟩, finalCache⟩, hverify, hpure⟩ := hfinish + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + have hverify' : ((verified, targetView), finalCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (Concrete.verifyWithView publicKey forgery.message forgery.signature)).run state.cache) := by + simpa only [simulateQ_romImpl_liftM] using hverify + obtain ⟨output, digestCache, houtput, hle, hview⟩ := + Concrete.verifyWithView_support_view publicKey forgery.message forgery.signature + state.cache finalCache verified targetView hverify' + exact ⟨state.cache, output, digestCache, houtput, hle, congrArg some hview⟩ + +theorem gameRestWithViewTrace_projection (adversary : Adversary) + (publicKey : PublicKey) (secretKey : SecretKey) (initialCache : QueryCache HashSpec) : + (fun result => (result.1, result.2.base)) <$> + gameRestWithViewTrace adversary publicKey secretKey initialCache = + gameRestWithFullTrace adversary publicKey secretKey initialCache := by + let initialState : ViewedFullTraceState := ⟨initialCache, ⟨[], [], []⟩, [], none⟩ + let viewedRun := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState + let baseRun := (simulateQ (fullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState.base + have hprojection : Prod.map id ViewedFullTraceState.base <$> viewedRun = baseRun := + viewedFullTracedMappedAdversaryImpl_projection secretKey + (adversary.main publicKey) initialState + let finishBase : Forgery × (QueryCache HashSpec × FullAdversaryTrace) → + ProbComp ((Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) := + fun result => do + let (verified, finalCache) ← + (simulateQ romImpl + (Concrete.scheme.verify publicKey result.1.message result.1.signature)).run result.2.1 + let log := result.2.2.signing.toSigningLog + let verdict := decide (SigningTranscript.Valid log ∧ + ¬ SigningTranscript.Contains log result.1) && verified + pure ((result.1, verdict), (finalCache, result.2.2)) + calc + (fun result => (result.1, result.2.base)) <$> + gameRestWithViewTrace adversary publicKey secretKey initialCache = + (Prod.map id ViewedFullTraceState.base <$> viewedRun) >>= finishBase := by + simp [gameRestWithViewTrace, viewedRun, finishBase, initialState, + map_eq_bind_pure_comp, bind_assoc, ViewedFullTraceState.base] + apply bind_congr + intro result + rw [← Concrete.simulateQ_verifyWithView_fst_run publicKey result.1.message + result.1.signature result.2.cache] + simp [map_eq_bind_pure_comp, bind_assoc] + rfl + _ = baseRun >>= finishBase := by rw [hprojection] + _ = gameRestWithFullTrace adversary publicKey secretKey initialCache := by + simp [gameRestWithFullTrace, baseRun, finishBase, initialState, + ViewedFullTraceState.base] + +namespace Concrete + +noncomputable def FewTimeCover.traceIndex {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (entry : cover.entries) : Fin trace.length := + ⟨(cover.logIndex entry).val, by + have hlength := congrArg List.length hlog + simpa only [SigningCacheTrace.toSigningLog, List.length_map] using + (show (cover.logIndex entry).val < trace.toSigningLog.length by + rw [hlength] + exact (cover.logIndex entry).isLt)⟩ + +theorem FewTimeCover.get_traceIndex {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (trace : SigningCacheTrace) (hlog : trace.toSigningLog = signingLog) + (entry : cover.entries) : + trace.get (cover.traceIndex trace hlog entry) = cover.cacheEntry trace hlog entry := by + rfl + +theorem FewTimeCover.signingViews_traceIndex_eq_entryView + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (state : ViewedFullTraceState) (hlog : state.trace.signing.toSigningLog = signingLog) + (hvalid : state.ValidViews secretKey) + (hcaches : state.trace.signing.CachesLe cache) (hf : cache.AgreesWithFn f) + (entry : cover.entries) : + hvalid.signingViews (cover.traceIndex state.trace.signing hlog entry) = + cover.entryView entry := by + let selected := cover.select (cover.representativeTree entry) + let position := cover.traceIndex state.trace.signing hlog entry + have hget : state.trace.signing.get position = cover.cacheEntry state.trace.signing hlog entry := + cover.get_traceIndex state.trace.signing hlog entry + have hfields := cover.cacheEntry_request_signature state.trace.signing hlog entry + have hresponse : (state.trace.signing.get position).signature = some selected.signature := by + rw [hget] + exact hfields.2 + have hrequest : (state.trace.signing.get position).request = selected.entry.1 := by + rw [hget] + exact hfields.1 + have hle : (state.trace.signing.get position).finalCache ≤ cache := by + rw [hget] + exact (cover.cacheEntry_cachesLe state.trace.signing hlog hcaches entry).2 + have hhonest : HonestFtsSignAt f cache secretKey + (state.trace.signing.get position).request selected.signature index + selected.signedLeaves := by + rw [hrequest] + exact selected.honest + rw [hvalid.signingViews_eq_honest_view position selected.signature hresponse hle hf + index selected.signedLeaves hhonest] + apply Prod.ext + · exact (cover.entryDigest_spec entry).2.2.1 + · funext tree + have hleaves := cover.entryDigest_spec entry + exact congrFun hleaves.2.2.2 (ftsIndexOf tree) + +theorem FewTimeCover.signingOptionViews_traceIndex_eq_entryView + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (state : ViewedFullTraceState) (hlog : state.trace.signing.toSigningLog = signingLog) + (hvalid : state.ValidViews secretKey) + (hcaches : state.trace.signing.CachesLe cache) (hf : cache.AgreesWithFn f) + (entry : cover.entries) : + hvalid.signingOptionViews (cover.traceIndex state.trace.signing hlog entry) = + some (cover.entryView entry) := by + let selected := cover.select (cover.representativeTree entry) + let position := cover.traceIndex state.trace.signing hlog entry + have hget : state.trace.signing.get position = cover.cacheEntry state.trace.signing hlog entry := + cover.get_traceIndex state.trace.signing hlog entry + have hfields := cover.cacheEntry_request_signature state.trace.signing hlog entry + have hresponse : (state.trace.signing.get position).signature = some selected.signature := by + rw [hget] + exact hfields.2 + have hrequest : (state.trace.signing.get position).request = selected.entry.1 := by + rw [hget] + exact hfields.1 + have hle : (state.trace.signing.get position).finalCache ≤ cache := by + rw [hget] + exact (cover.cacheEntry_cachesLe state.trace.signing hlog hcaches entry).2 + have hhonest : HonestFtsSignAt f cache secretKey + (state.trace.signing.get position).request selected.signature index + selected.signedLeaves := by + rw [hrequest] + exact selected.honest + rw [hvalid.signingOptionViews_eq_honest_view position selected.signature hresponse hle hf + index selected.signedLeaves hhonest] + congr 1 + apply Prod.ext + · exact (cover.entryDigest_spec entry).2.2.1 + · funext tree + exact congrFun (cover.entryDigest_spec entry).2.2.2 (ftsIndexOf tree) + +theorem FewTimeCover.viewedPatternHit + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (state : ViewedFullTraceState) (hlog : state.trace.signing.toSigningLog = signingLog) + (hvalid : state.ValidViews secretKey) + (hcaches : state.trace.signing.CachesLe cache) (hf : cache.AgreesWithFn f) : + cover.pattern.Hit + (hvalid.signingViewsForLog hlog, fewTimeTargetView index targetLeaves) := by + constructor + · intro selected + obtain ⟨entry, _, hentry⟩ := Finset.mem_image.1 selected.2 + have hview : hvalid.signingViewsForLog hlog (cover.logIndex entry) = + cover.entryView entry := by + change hvalid.signingViews (cover.traceIndex state.trace.signing hlog entry) = + cover.entryView entry + exact cover.signingViews_traceIndex_eq_entryView state hlog hvalid hcaches hf entry + change (hvalid.signingViewsForLog hlog selected.1).1 = index + rw [← hentry, hview] + exact cover.entryDigest_index entry + · intro tree + have hview : hvalid.signingViewsForLog hlog + (cover.logIndex (cover.entryAssignment tree)) = + cover.entryView (cover.entryAssignment tree) := by + change hvalid.signingViews + (cover.traceIndex state.trace.signing hlog (cover.entryAssignment tree)) = + cover.entryView (cover.entryAssignment tree) + exact cover.signingViews_traceIndex_eq_entryView state hlog hvalid hcaches hf + (cover.entryAssignment tree) + change targetLeaves (ftsIndexOf tree) = + (hvalid.signingViewsForLog hlog + (cover.logIndex (cover.entryAssignment tree))).2 tree + rw [hview] + exact (cover.entryDigest_assigned_leaf tree).symm + +theorem FewTimeCover.viewedSomePatternHit + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (state : ViewedFullTraceState) (hlog : state.trace.signing.toSigningLog = signingLog) + (hvalid : state.ValidViews secretKey) + (hcaches : state.trace.signing.CachesLe cache) (hf : cache.AgreesWithFn f) : + SomeFewTimePatternHit signingLog.length + (hvalid.signingViewsForLog hlog, fewTimeTargetView index targetLeaves) := by + refine ⟨cover.entries.card, Finset.mem_Icc.2 + ⟨cover.entries_card_pos, cover.entries_card_le_trees⟩, cover.pattern, ?_⟩ + exact cover.viewedPatternHit state hlog hvalid hcaches hf + +noncomputable def gameAfterSecretsWithViewTrace (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ProbComp ((Digest × Forgery × Bool) × ViewedFullTraceState) := do + let (root, rootCache) ← (simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : + OracleComp HashSpec Digest)) : OracleComp OracleWorld Digest)).run ∅ + let result ← gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache + pure ((root, result.1.1, result.1.2), result.2) + +theorem gameAfterSecretsWithViewTrace_projection (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + (fun result => (result.1, result.2.base)) <$> + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret = + gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret := by + rw [gameAfterSecretsWithViewTrace, gameAfterSecretsWithFullTrace] + simp only [map_bind] + apply bind_congr + intro rootResult + rw [← gameRestWithViewTrace_projection adversary + (⟨rootResult.1, parameter⟩ : PublicKey) + (⟨parameter, rootResult.1, otsSecret, ftsSecret⟩ : SecretKey) rootResult.2] + simp + +theorem gameAfterSecretsWithViewTrace_support_validViews (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hmem : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) : + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.ValidViews secretKey := by + rw [gameAfterSecretsWithViewTrace, mem_support_bind_iff] at hmem + obtain ⟨⟨root, rootCache⟩, _, hrest⟩ := hmem + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult, hrest, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + simpa using gameRestWithViewTrace_support_validViews adversary + (⟨root, parameter⟩ : PublicKey) + (⟨parameter, root, otsSecret, ftsSecret⟩ : SecretKey) rootCache restResult hrest + +theorem gameAfterSecretsWithViewTrace_support_targetView (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hmem : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) : + ∃ (adversaryCache : QueryCache HashSpec) (output : HashOutput) + (digestCache : QueryCache HashSpec), + (output, digestCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (oracleHash (tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness)))).run adversaryCache) + ∧ digestCache ≤ result.2.cache + ∧ result.2.targetView = some (hashOutputFewTimeView output) := by + rw [gameAfterSecretsWithViewTrace, mem_support_bind_iff] at hmem + obtain ⟨⟨root, rootCache⟩, _, hrest⟩ := hmem + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult, hrest, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + simpa using gameRestWithViewTrace_support_targetView adversary + (⟨root, parameter⟩ : PublicKey) + (⟨parameter, root, otsSecret, ftsSecret⟩ : SecretKey) rootCache restResult hrest + +theorem gameAfterSecretsWithViewTrace_targetView_eq + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hmem : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest parameter result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) = digest) : + result.2.targetView = + some (fewTimeTargetView (digestIndex digest) (digestLeaves digest)) := by + obtain ⟨_, output, digestCache, houtput, hle, htarget⟩ := + gameAfterSecretsWithViewTrace_support_targetView adversary parameter otsSecret ftsSecret + result hmem + let input := tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) + have hcached : result.2.cache input = some output := + hle (randomOracle_output_cached input _ digestCache output (by simpa [input] using houtput)) + have hanswer : f input = output := hf hcached + have hdigest' : truncateMessageDigest output = digest := by + simpa only [messageDigest, oracleHash, evalWithAnswerFn_bind, evalWithAnswerFn_query, + evalWithAnswerFn_pure, input, hanswer] using hdigest + rw [htarget] + congr 1 + apply Prod.ext + · change digestIndex (truncateMessageDigest output) = digestIndex digest + rw [hdigest'] + · funext tree + change digestLeaves (truncateMessageDigest output) (ftsIndexOf tree) = + digestLeaves digest (ftsIndexOf tree) + rw [hdigest'] + +theorem gameAfterSecretsWithViewTrace_fewTimeLeak_patternHit + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hmem : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest parameter result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) = digest) + (hleak : FewTimeLeak f result.2.cache + (⟨parameter, result.1.1, otsSecret, ftsSecret⟩ : SecretKey) + result.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest)) : + SomeFewTimePatternHit result.2.trace.signing.toSigningLog.length + ((gameAfterSecretsWithViewTrace_support_validViews adversary parameter otsSecret ftsSecret + result hmem).signingViewsForLog rfl, + result.2.targetView.getD default) := by + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hmem, rfl⟩ + have hinvariants := gameAfterSecretsWithFullTrace_support_invariants adversary parameter + otsSecret ftsSecret (result.1, result.2.base) hbase + have hvalid := gameAfterSecretsWithViewTrace_support_validViews adversary parameter + otsSecret ftsSecret result hmem + have htarget := gameAfterSecretsWithViewTrace_targetView_eq adversary parameter otsSecret + ftsSecret result hmem f hf digest hdigest + have hpattern := hleak.cover.viewedSomePatternHit result.2 rfl hvalid + hinvariants.2.1 hf + simpa only [htarget, Option.getD_some] using hpattern + +theorem gameAfterSecretsWithViewTrace_properLeak_patternHit + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hmem : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest parameter result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) = digest) + (hproper : ProperFewTimeLeak f result.2.cache + (⟨parameter, result.1.1, otsSecret, ftsSecret⟩ : SecretKey) + result.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest)) : + SomeFewTimePatternHit result.2.trace.signing.toSigningLog.length + ((gameAfterSecretsWithViewTrace_support_validViews adversary parameter otsSecret ftsSecret + result hmem).signingViewsForLog rfl, + result.2.targetView.getD default) := by + exact gameAfterSecretsWithViewTrace_fewTimeLeak_patternHit adversary parameter otsSecret + ftsSecret result hmem f hf digest hdigest hproper.1 + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedCount.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedCount.lean new file mode 100644 index 00000000..b78bb806 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedCount.lean @@ -0,0 +1,169 @@ +import SphincsSecurity.Proof.FewTimeOrigins +import Mathlib.Algebra.BigOperators.Ring.Finset + +/-! +# Weighted count of fresh and prehit origins + +For a fixed set of selected signer entries, choose the prehit subset and injectively assign its +members to direct-query sources. The total weight is at most `(1 + sources * weight)^selected`. +-/ + +namespace SphincsSecurity.Concrete + +open ENNReal + +abbrev InjectiveSources (Selected : Type) (sources : Nat) := + {source : Selected → Fin sources // Function.Injective source} + +noncomputable instance (Selected : Type) [Fintype Selected] (sources : Nat) : + Fintype (InjectiveSources Selected sources) := + Fintype.ofFinite _ + +theorem injectiveSources_card_le (Selected : Type) [Fintype Selected] [DecidableEq Selected] + (sources : Nat) : + Fintype.card (InjectiveSources Selected sources) ≤ + sources ^ Fintype.card Selected := by + classical + calc + Fintype.card (InjectiveSources Selected sources) ≤ + Fintype.card (Selected → Fin sources) := + Fintype.card_subtype_le _ + _ = sources ^ Fintype.card Selected := by + rw [Fintype.card_fun, Fintype.card_fin] + +noncomputable def originChoiceMass (Selected : Type) [Fintype Selected] [DecidableEq Selected] + (sources : Nat) (weight : ℝ≥0∞) : ℝ≥0∞ := + ∑ prehit : Finset Selected, + Fintype.card (InjectiveSources prehit sources) * weight ^ prehit.card + +theorem sum_finset_pow_card (Selected : Type) [Fintype Selected] [DecidableEq Selected] + (value : ℝ≥0∞) : + (∑ selected : Finset Selected, value ^ selected.card) = + (1 + value) ^ Fintype.card Selected := by + classical + have hprod := Finset.prod_add (fun _ : Selected => value) (fun _ => 1) + (Finset.univ : Finset Selected) + simpa [Finset.prod_const, add_comm] using hprod.symm + +theorem originChoiceMass_le (Selected : Type) [Fintype Selected] [DecidableEq Selected] + (sources : Nat) (weight : ℝ≥0∞) : + originChoiceMass Selected sources weight ≤ + (1 + sources * weight) ^ Fintype.card Selected := by + classical + calc + originChoiceMass Selected sources weight ≤ + ∑ prehit : Finset Selected, + (sources : ℝ≥0∞) ^ prehit.card * weight ^ prehit.card := by + apply Finset.sum_le_sum + intro prehit _ + gcongr + have hcard := injectiveSources_card_le prehit sources + rw [Fintype.card_coe] at hcard + exact_mod_cast hcard + _ = ∑ prehit : Finset Selected, + ((sources : ℝ≥0∞) * weight) ^ prehit.card := by + apply Finset.sum_congr rfl + intro prehit _ + rw [mul_pow] + _ = (1 + sources * weight) ^ Fintype.card Selected := + sum_finset_pow_card Selected ((sources : ℝ≥0∞) * weight) + +theorem FewTimePattern.originChoiceMass_le_two {signatures distinct q : Nat} + (pattern : FewTimePattern signatures distinct) (hq : q ≤ 2 ^ 120) + (hdistinct : distinct ≤ 14) : + originChoiceMass pattern.selected q ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ≤ 2 := by + calc + originChoiceMass pattern.selected q ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ≤ + (1 + q * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹) ^ + Fintype.card pattern.selected := + originChoiceMass_le pattern.selected q ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ + _ = (1 + q * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹) ^ distinct := by + rw [Fintype.card_coe, pattern.card_selected] + _ ≤ 2 := prehit_origin_inflation_pow_le hq hdistinct + +theorem FewTimePattern.originChoiceMass_le_nine_eighths {signatures distinct q : Nat} + (pattern : FewTimePattern signatures distinct) (hq : q ≤ 2 ^ 120) + (hdistinct : distinct ≤ 14) : + originChoiceMass pattern.selected q ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ≤ 9 / 8 := by + calc + originChoiceMass pattern.selected q ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ≤ + (1 + q * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹) ^ + Fintype.card pattern.selected := + originChoiceMass_le pattern.selected q ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ + _ = (1 + q * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹) ^ distinct := by + rw [Fintype.card_coe, pattern.card_selected] + _ ≤ 9 / 8 := prehit_origin_inflation_pow_le_nine_eighths hq hdistinct + +noncomputable def weightedFewTimePatternBound (signatures q : Nat) : ℝ≥0∞ := + ∑ distinct ∈ Finset.Icc 1 14, + ∑ pattern : FewTimePattern signatures distinct, + originChoiceMass pattern.selected q ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ * + ((2 ^ (26 * distinct + 140) : Nat) : ℝ≥0∞)⁻¹ + +theorem weightedFewTimePatternBound_le {signatures q : Nat} + (hsignatures : signatures ≤ signatureLimit) (hq : q ≤ 2 ^ 120) : + weightedFewTimePatternBound signatures q ≤ + ((2 ^ 121 : Nat) : ℝ≥0∞)⁻¹ := by + classical + calc + weightedFewTimePatternBound signatures q ≤ + ∑ distinct ∈ Finset.Icc 1 14, + ∑ _pattern : FewTimePattern signatures distinct, + 2 * ((2 ^ (26 * distinct + 140) : Nat) : ℝ≥0∞)⁻¹ := by + apply Finset.sum_le_sum + intro distinct hdistinct + apply Finset.sum_le_sum + intro pattern _ + gcongr + exact pattern.originChoiceMass_le_two hq (Finset.mem_Icc.mp hdistinct).2 + _ = 2 * (∑ distinct ∈ Finset.Icc 1 14, + (Fintype.card (FewTimePattern signatures distinct) : ℝ≥0∞) * + ((2 ^ (26 * distinct + 140) : Nat) : ℝ≥0∞)⁻¹) := by + simp only [Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro distinct _ + ring + _ ≤ 2 * ((2 ^ 122 : Nat) : ℝ≥0∞)⁻¹ := by + gcongr + exact fewTimePattern_unionBound_le hsignatures + _ = ((2 ^ 121 : Nat) : ℝ≥0∞)⁻¹ := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_natCast] + norm_num + +theorem weightedFewTimePatternBound_le_nine_mul_inv {signatures q : Nat} + (hsignatures : signatures ≤ signatureLimit) (hq : q ≤ 2 ^ 120) : + weightedFewTimePatternBound signatures q ≤ + 9 * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹ := by + classical + calc + weightedFewTimePatternBound signatures q ≤ + ∑ distinct ∈ Finset.Icc 1 14, + ∑ _pattern : FewTimePattern signatures distinct, + (9 / 8) * ((2 ^ (26 * distinct + 140) : Nat) : ℝ≥0∞)⁻¹ := by + apply Finset.sum_le_sum + intro distinct hdistinct + apply Finset.sum_le_sum + intro pattern _ + gcongr + exact pattern.originChoiceMass_le_nine_eighths hq + (Finset.mem_Icc.mp hdistinct).2 + _ = (9 / 8) * (∑ distinct ∈ Finset.Icc 1 14, + (Fintype.card (FewTimePattern signatures distinct) : ℝ≥0∞) * + ((2 ^ (26 * distinct + 140) : Nat) : ℝ≥0∞)⁻¹) := by + simp only [Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro distinct _ + ring + _ ≤ (9 / 8) * ((2 ^ 122 : Nat) : ℝ≥0∞)⁻¹ := by + gcongr + exact fewTimePattern_unionBound_le hsignatures + _ = 9 * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹ := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_div, + ENNReal.toReal_natCast] + norm_num + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedHonestLeak.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedHonestLeak.lean new file mode 100644 index 00000000..4dcf59f7 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedHonestLeak.lean @@ -0,0 +1,503 @@ +import SphincsSecurity.Proof.FewTimeWeightedTargetUnion +import SphincsSecurity.Proof.FewTimeHonestLeakBound + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem probEvent_exists_fixedRawTargetViewedTerminal_le_weightedOrigin + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q : Nat) + (hq : q ≤ 2 ^ 127) (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[fun result => ∃ distinct ∈ Finset.Icc 1 14, + ∃ pattern : FewTimePattern signatures distinct, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin q, + FixedRawTargetViewedTerminal secretKey computation initialCache q + configuration candidate.val result | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] ≤ + q * weightedRawTargetOriginUnionBound signatures sources (digestReuseWeight q) := by + apply probEvent_exists_originConfiguration_fixedRawOrdinal_viewedEvent_le_weightedOrigin + secretKey computation initialCache signatures sources q hq hcache q + (fun _ _ configuration candidate => + FixedRawTargetViewedTerminal secretKey computation initialCache q + configuration candidate.val) + intro distinct pattern configuration candidate result hresult hevent + obtain ⟨hcacheFinal, hterminal⟩ := hevent + obtain ⟨hcomplete, hhit⟩ := hterminal result hresult rfl + exact ⟨hcomplete, hhit, hcacheFinal⟩ + +theorem probEvent_gameRestWithViewTrace_nonfresh_honest_leak_le_weighted + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 127) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (root : Digest) (rootCache : QueryCache HashSpec) + (hroot : (root, rootCache) ∈ support + ((simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅)) : + Pr[fun rest => + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, rest.1.1, rest.1.2), rest.2) + ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∧ ¬VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache] ≤ + q * weightedRawTargetOriginUnionBound signatureLimit q (digestReuseWeight q) := by + classical + let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + let publicKey : PublicKey := ⟨root, parameter⟩ + let initialState : ViewedFullTraceState := + ⟨rootCache, ⟨[], [], []⟩, [], none⟩ + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState + let finish : Forgery × ViewedFullTraceState → + ProbComp ((Forgery × Bool) × ViewedFullTraceState) := fun prior => do + let ((verified, targetView), finalCache) ← + (simulateQ romImpl + (liftM (verifyWithView publicKey prior.1.message prior.1.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run prior.2.cache + let log := prior.2.trace.signing.toSigningLog + let verdict := decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log prior.1) && verified + pure ((prior.1, verdict), + ⟨finalCache, prior.2.trace, prior.2.views, some targetView⟩) + let prefixEvent := fun prior : Forgery × ViewedFullTraceState => + ∃ distinct ∈ Finset.Icc 1 14, + ∃ pattern : FewTimePattern signatureLimit distinct, + ∃ configuration : OriginConfiguration pattern q, + ∃ candidate : Fin q, + FixedRawTargetViewedTerminal secretKey (adversary.main publicKey) + rootCache q configuration candidate.val prior + have hgame : gameRestWithViewTrace adversary publicKey secretKey rootCache = + run >>= finish := by + rfl + rw [show ⟨root, parameter⟩ = publicKey from rfl, + show ⟨parameter, root, otsSecret, ftsSecret⟩ = secretKey from rfl, hgame] + calc + _ ≤ Pr[prefixEvent | run] := by + apply probEvent_bind_le_probEvent + intro prior hprior hnotPrefix + rcases prior with ⟨forgery, state⟩ + apply probEvent_eq_zero + intro rest hrest hevent + rw [mem_support_bind_iff] at hrest + obtain ⟨⟨⟨verified, targetView⟩, finalCache⟩, hverify, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst rest + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) + have hrestSupport : + ((forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) ∈ + support (gameRestWithViewTrace adversary publicKey secretKey rootCache) := by + rw [hgame, mem_support_bind_iff] + refine ⟨(forgery, state), hprior, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨((verified, targetView), finalCache), hverify, + by simp only [support_pure, Set.mem_singleton_iff]⟩ + have hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret) := by + rw [gameAfterSecretsWithViewTrace, mem_support_bind_iff] + refine ⟨(root, rootCache), hroot, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨_, hrestSupport, by simp [result]⟩ + obtain ⟨f, digest, hf, hvalid, _, hdigest, hadmissible, hproper, hfull⟩ := hevent.1 + have hcacheLe : state.cache ≤ finalCache := + simulateQ_romImpl_cache_le + (liftM (verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView)) state.cache + ((verified, targetView), finalCache) hverify + rcases gameAfterSecretsWithViewTrace_honestLeak_target_classified_at_adversary_state + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts result hresult + f hf digest hdigest hadmissible hproper hfull hvalid rootCache state rfl hcacheLe with + hfresh | hclassified + · exact hevent.2 hfresh + · obtain ⟨distinct, hdistinct, pattern, configuration, candidate, hterminal⟩ := + hclassified + apply hnotPrefix + exact ⟨distinct, hdistinct, pattern, configuration, candidate, hterminal⟩ + _ ≤ _ := probEvent_exists_fixedRawTargetViewedTerminal_le_weightedOrigin + secretKey (adversary.main publicKey) rootCache signatureLimit q q hqMax + (by + have hroot' : QueryCache.enncard rootCache ≤ q := by + have hprojected : (root, rootCache) ∈ support + ((simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅) := hroot + have hgameBound := isQueryBoundP_gameAfterSecrets adversary q hq + hparameter hots hfts + rw [gameAfterSecrets] at hgameBound + have hrootBound := OracleComp.IsQueryBoundP.of_bind_left + (p := fun input : OracleWorld.Domain => input matches Sum.inr _) hgameBound + have hbound := simulateQ_romImpl_enncard_le_queryBound + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest) q + hrootBound + (root, rootCache) hprojected + exact hbound + exact hroot') + +theorem probEvent_gameAfterSecretsWithViewTrace_nonfresh_honest_leak_le_weighted + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 127) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun result => + ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∧ ¬VerifierFreshTarget parameter result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + q * weightedRawTargetOriginUnionBound signatureLimit q (digestReuseWeight q) := by + rw [gameAfterSecretsWithViewTrace] + apply probEvent_bind_le_of_forall_le + rintro ⟨root, rootCache⟩ hroot + let attach := fun rest : (Forgery × Bool) × ViewedFullTraceState => + ((root, rest.1.1, rest.1.2), rest.2) + change Pr[fun result => + ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result ∧ + ¬VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache >>= pure ∘ attach] ≤ _ + rw [probEvent_bind_pure_comp] + exact probEvent_gameRestWithViewTrace_nonfresh_honest_leak_le_weighted adversary q hq hqMax + parameter hparameter otsSecret hots ftsSecret hfts root rootCache hroot + +theorem probEvent_gameRestWithViewTrace_fresh_honest_leak_le_weighted + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 127) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (root : Digest) (rootCache : QueryCache HashSpec) + (hroot : (root, rootCache) ∈ support + ((simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅)) : + Pr[fun rest => + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, rest.1.1, rest.1.2), rest.2) + ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∧ VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache] ≤ + ((q + 1 : Nat) : ℝ≥0∞) * weightedRawTargetOriginUnionBound signatureLimit q (digestReuseWeight q) := by + classical + let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + let publicKey : PublicKey := ⟨root, parameter⟩ + let initialState : ViewedFullTraceState := + ⟨rootCache, ⟨[], [], []⟩, [], none⟩ + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState + let finish : Forgery × ViewedFullTraceState → + ProbComp ((Forgery × Bool) × ViewedFullTraceState) := fun prior => do + let ((verified, targetView), finalCache) ← + (simulateQ romImpl + (liftM (verifyWithView publicKey prior.1.message prior.1.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run prior.2.cache + let log := prior.2.trace.signing.toSigningLog + let verdict := decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log prior.1) && verified + pure ((prior.1, verdict), + ⟨finalCache, prior.2.trace, prior.2.views, some targetView⟩) + let freshEvent := fun rest : (Forgery × Bool) × ViewedFullTraceState => + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, rest.1.1, rest.1.2), rest.2) + ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result + have hrootNone : ∀ payload, + rootCache (tweakableHashInput parameter .message payload) = none := by + have hroot' : (root, rootCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅) := by + simpa only [simulateQ_romImpl_liftM] using hroot + exact fun payload => treeRoot_cache_message_none parameter topLayer rootTree + (otsSecret topLayer rootTree) root rootCache hroot' payload + have hrootCache : QueryCache.enncard rootCache ≤ q := by + have hgameBound := isQueryBoundP_gameAfterSecrets adversary q hq + hparameter hots hfts + rw [gameAfterSecrets] at hgameBound + have hrootBound := OracleComp.IsQueryBoundP.of_bind_left + (p := fun input : OracleWorld.Domain => input matches Sum.inr _) hgameBound + exact simulateQ_romImpl_enncard_le_queryBound + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest) q hrootBound (root, rootCache) hroot + have hprefixBound := + probEvent_exists_fixedRawTargetViewedTerminal_le_weightedOrigin_of_candidates + (α := Forgery × HashOutput) (secretKey := secretKey) + (computation := adversaryWithTargetQuery adversary publicKey) + (initialCache := rootCache) (signatures := signatureLimit) (sources := q) + (q := q) (hq := hqMax) (hcache := hrootCache) (candidates := q + 1) + have hgame : gameRestWithViewTrace adversary publicKey secretKey rootCache = + run >>= finish := rfl + rw [show ⟨root, parameter⟩ = publicKey from rfl, + show ⟨parameter, root, otsSecret, ftsSecret⟩ = secretKey from rfl, hgame] + change Pr[freshEvent | run >>= finish] ≤ _ + have hfirst : Pr[freshEvent | run >>= finish] ≤ + Pr[SomeFixedRawTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversaryWithTargetQuery adversary publicKey)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩] := by + rw [adversaryWithTargetQuery_viewed_run] + change Pr[_ | run >>= _] ≤ + Pr[SomeFixedRawTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + run >>= _] + apply probEvent_bind_le_bind_of_forall_le + rintro ⟨forgery, state⟩ hprior + let input := tweakableHashInput parameter .message + (messageDigestPayload root forgery.message forgery.signature.randomness) + change Pr[_ | + (simulateQ romImpl + (liftM (verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run state.cache >>= _] ≤ _ + rw [verifyWithView_split_run] + simp only [bind_assoc] + rw [show tweakableHashInput publicKey.parameter .message + (messageDigestPayload publicKey.root forgery.message + forgery.signature.randomness) = input from rfl] + change _ ≤ Pr[SomeFixedRawTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + (randomOracle input).run state.cache >>= pure ∘ fun source => + ((forgery, source.1), appendDirectTargetViewedState input state.cache + source.1 source.2 state)] + rw [probEvent_bind_pure_comp] + change Pr[_ | (randomOracle input).run state.cache >>= _] ≤ + Pr[fun source => SomeFixedRawTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) + ((forgery, source.1), + appendDirectTargetViewedState input state.cache source.1 source.2 state) | + (randomOracle input).run state.cache] + apply probEvent_bind_le_probEvent + rintro ⟨output, digestCache⟩ hquery hnotPrefix + apply probEvent_eq_zero + intro rest hrest hevent + rw [mem_support_bind_iff] at hrest + obtain ⟨⟨⟨verified, targetView⟩, finalCache⟩, hverifyRest, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst rest + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) + change ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result at hevent + have hverify : ((verified, targetView), finalCache) ∈ support + ((simulateQ romImpl + (liftM (verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run state.cache) := by + rw [verifyWithView_split_run, mem_support_bind_iff] + exact ⟨(output, digestCache), by simpa only [input, publicKey] using hquery, + hverifyRest⟩ + have hrestSupport : + ((forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) ∈ + support (gameRestWithViewTrace adversary publicKey secretKey rootCache) := by + rw [gameRestWithViewTrace, mem_support_bind_iff] + refine ⟨(forgery, state), hprior, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨((verified, targetView), finalCache), hverify, + by simp only [support_pure, Set.mem_singleton_iff]⟩ + have hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret) := by + rw [gameAfterSecretsWithViewTrace, mem_support_bind_iff] + refine ⟨(root, rootCache), hroot, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨_, hrestSupport, by simp [result]⟩ + obtain ⟨f, digest, hf, hvalid, _, hdigest, hadmissible, hproper, _hfull⟩ := hevent.1 + obtain ⟨otherRootCache, adversaryCache, _, _, hotherRootNone, + hotherChain, hadversaryMiss, _, _, _⟩ := hevent.2 + have hbase : (forgery, state.base) ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState.base) := by + rw [← viewedFullTracedMappedAdversaryImpl_projection secretKey + (adversary.main publicKey) initialState, support_map] + exact ⟨(forgery, state), hprior, rfl⟩ + have hchain : FullAdversaryTrace.CacheChain rootCache state.trace.intervals + state.cache := + fullTracedMappedAdversaryImpl_cacheChain secretKey (adversary.main publicKey) + rootCache rootCache ⟨[], [], []⟩ (forgery, state.base) (by rfl) hbase + have hmiss : state.cache input = none := by + have hrootInput : rootCache input = none := by + simpa only [input] using hrootNone + (messageDigestPayload root forgery.message forgery.signature.randomness) + have hotherRootInput : otherRootCache input = none := by + simpa only [input, result] using hotherRootNone + (messageDigestPayload root forgery.message forgery.signature.randomness) + have hlookup := FullAdversaryTrace.CacheChain.finish_lookup_eq input + (hrootInput.trans hotherRootInput.symm) hchain + (by simpa only [result] using hotherChain) + exact hlookup.trans hadversaryMiss + have hdigestLe : digestCache ≤ finalCache := + simulateQ_romImpl_cache_le + (liftM (verifyWithViewAfterOutput publicKey forgery.signature output) : + OracleComp OracleWorld (Bool × FewTimeView)) digestCache + ((verified, targetView), finalCache) hverifyRest + have hcachedDigest : digestCache input = some output := + randomOracle_output_cached input state.cache digestCache output (by + have hquerySim : simulateQ (randomOracle : QueryImpl HashSpec _) + (oracleHash input) = randomOracle input := by + change simulateQ (randomOracle : QueryImpl HashSpec _) + (liftM (HashSpec.query input)) = randomOracle input + rw [simulateQ_spec_query] + rw [hquerySim] + exact hquery) + have hcachedFinal : finalCache input = some output := hdigestLe hcachedDigest + have hanswer : f input = output := hf (by simpa only [result] using hcachedFinal) + have hdigestOutput : truncateMessageDigest output = digest := by + have hdigest' : truncateMessageDigest (f input) = digest := by + simpa only [messageDigest, oracleHash, evalWithAnswerFn_bind, + evalWithAnswerFn_query, evalWithAnswerFn_pure, result, input] using hdigest + rwa [hanswer] at hdigest' + have htargetOutput : hashOutputFewTimeView output = + fewTimeTargetView (digestIndex digest) (digestLeaves digest) := by + simp [hashOutputFewTimeView, fewTimeTargetView, hdigestOutput] + have hfullBase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret + ftsSecret, support_map] + exact ⟨result, hresult, rfl⟩ + obtain ⟨configuration, hrealized⟩ := + hproper.1.cover.exists_paddedRealized_originConfiguration_of_queryBudget + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts + (result.1, result.2.base) hfullBase f hf (digestIndex digest) + (digestLeaves digest) signatureLimit hvalid + have hfinalCache : QueryCache.enncard finalCache ≤ q := by + have hbound := gameAfterSecretsWithFullTrace_support_enncard_le adversary q hq + parameter hparameter otsSecret hots ftsSecret hfts + (result.1, result.2.base) hfullBase + change QueryCache.enncard result.2.cache ≤ q at hbound + simpa only [result] using hbound + have hdigestCard : QueryCache.enncard digestCache ≤ q := + (QueryCache.enncard_mono hdigestLe).trans hfinalCache + have hcountLe : (rawTargetCandidateViews state.trace.intervals).length ≤ q := by + apply (rawTargetCandidateViews_length_le_directIntervalCount state.trace.intervals).trans + exact gameAfterSecretsWithViewTrace_directIntervalCount_le adversary q hq parameter + hparameter otsSecret hots ftsSecret hfts result hresult + let candidate : Fin (q + 1) := + ⟨(rawTargetCandidateViews state.trace.intervals).length, by omega⟩ + unfold SomeFixedRawTargetViewedTerminal at hnotPrefix + apply hnotPrefix + refine ⟨hproper.1.cover.entries.card, + Finset.mem_Icc.2 ⟨hproper.1.cover.entries_card_pos, + hproper.1.cover.entries_card_le_trees⟩, + hproper.1.cover.pattern.pad hvalid, configuration, candidate, ?_⟩ + exact configuration.raw_verifierTarget_fixedTerminal adversary parameter otsSecret + ftsSecret result hresult f hf digest hproper hvalid hrealized + rootCache state hprior rfl rfl input output digestCache rfl hmiss + (by simpa only [input] using hquery) hdigestLe htargetOutput + (by simp [signAttemptResultOfOutput, hdigestOutput, hadmissible]) q hdigestCard + calc + Pr[freshEvent | run >>= finish] ≤ + Pr[SomeFixedRawTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversaryWithTargetQuery adversary publicKey)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩] := hfirst + _ ≤ ((q + 1 : Nat) : ℝ≥0∞) * weightedRawTargetOriginUnionBound signatureLimit q (digestReuseWeight q) := + hprefixBound + +theorem probEvent_gameAfterSecretsWithViewTrace_fresh_honest_leak_le_weighted + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 127) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun result => + ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∧ VerifierFreshTarget parameter result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + ((q + 1 : Nat) : ℝ≥0∞) * weightedRawTargetOriginUnionBound signatureLimit q (digestReuseWeight q) := by + rw [gameAfterSecretsWithViewTrace] + apply probEvent_bind_le_of_forall_le + rintro ⟨root, rootCache⟩ hroot + let attach := fun rest : (Forgery × Bool) × ViewedFullTraceState => + ((root, rest.1.1, rest.1.2), rest.2) + change Pr[fun result => + ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache >>= pure ∘ attach] ≤ _ + rw [probEvent_bind_pure_comp] + exact probEvent_gameRestWithViewTrace_fresh_honest_leak_le_weighted adversary q hq hqMax + parameter hparameter otsSecret hots ftsSecret hfts root rootCache hroot + +theorem probEvent_gameAfterSecretsWithViewTrace_honest_leak_le_weighted + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 127) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + q * weightedRawTargetOriginUnionBound signatureLimit q (digestReuseWeight q) + + ((q + 1 : Nat) : ℝ≥0∞) * weightedRawTargetOriginUnionBound signatureLimit q (digestReuseWeight q) := by + classical + calc + _ ≤ Pr[fun result => + (ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result ∧ + ¬VerifierFreshTarget parameter result) ∨ + (ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result) | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + apply probEvent_mono + intro result _ hproper + by_cases hfresh : VerifierFreshTarget parameter result + · exact Or.inr ⟨hproper, hfresh⟩ + · exact Or.inl ⟨hproper, hfresh⟩ + _ ≤ _ := (probEvent_or_le _ _ _).trans (add_le_add + (probEvent_gameAfterSecretsWithViewTrace_nonfresh_honest_leak_le_weighted adversary q hq + hqMax parameter hparameter otsSecret hots ftsSecret hfts) + (probEvent_gameAfterSecretsWithViewTrace_fresh_honest_leak_le_weighted adversary q hq + hqMax parameter hparameter otsSecret hots ftsSecret hfts)) + +theorem probEvent_sampled_honest_leak_le_weighted + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 127) : + Pr[SampledViewedEvent ViewedHonestProperFewTimeLeakWitness | sampledViewedGame adversary] ≤ + ((2 * q + 1 : Nat) : ℝ≥0∞) * + weightedRawTargetOriginUnionBound signatureLimit q (digestReuseWeight q) := by + rw [sampledViewedGame] + apply probEvent_bind_le_of_forall_le + intro secrets hsecrets + obtain ⟨hparameter, hots, hfts⟩ := secrets.support_components hsecrets + rw [bind_pure_comp, probEvent_map] + change Pr[ViewedHonestProperFewTimeLeakWitness secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret secrets.ftsSecret] ≤ _ + apply (probEvent_gameAfterSecretsWithViewTrace_honest_leak_le_weighted adversary q hq hqMax + secrets.parameter hparameter secrets.otsSecret hots secrets.ftsSecret hfts).trans_eq + push_cast + ring + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedOriginAdaptive.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedOriginAdaptive.lean new file mode 100644 index 00000000..8e17b4f1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedOriginAdaptive.lean @@ -0,0 +1,294 @@ +import SphincsSecurity.Proof.FewTimeWeightedOriginInvariant + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +namespace Concrete + +theorem originMonitoredAdversaryImpl_signer_result_weightedPotential {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (state : OriginMonitorState configuration) (request : SignRequest) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) → Prop) : + let trace := fullAdversaryTraceUpdate (.inr request) state.viewed.cache result.1.1 + result.2 state.viewed.trace + let monitored := monitorSigner secretKey request state result + (⟨⟨result.2, trace, state.viewed.views ++ [result.1.2], state.viewed.targetView⟩, + monitored.1, state.directOrdinal, state.signerOrdinal + 1, monitored.2⟩ : + OriginMonitorState configuration).weightedPotential reuseWeight event = + (state.afterSigner secretKey request result).weightedPotential reuseWeight event := by + rfl + +noncomputable def OriginMonitorState.cappedWeightedPotential {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginMonitorState configuration) (reuseWeight : ℝ≥0∞) + (event : (pattern.selected → FewTimeView) → Prop) : ℝ≥0∞ := by + classical + exact if QueryCache.enncard state.viewed.cache ≤ q then state.weightedPotential reuseWeight event else 0 + +theorem OriginMonitorState.cappedWeightedPotential_le_weightedPotential {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) : + state.cappedWeightedPotential q reuseWeight event ≤ state.weightedPotential reuseWeight event := by + classical + simp only [OriginMonitorState.cappedWeightedPotential] + split_ifs + · exact le_rfl + · exact bot_le + +theorem OriginMonitorState.cappedWeightedPotential_eq_of_enncard_le {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (hcache : QueryCache.enncard state.viewed.cache ≤ q) : + state.cappedWeightedPotential q reuseWeight event = state.weightedPotential reuseWeight event := by + classical + simp [OriginMonitorState.cappedWeightedPotential, hcache] + +theorem OriginMonitorState.cappedWeightedPotential_eq_zero_of_not_enncard_le {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (hcache : ¬ QueryCache.enncard state.viewed.cache ≤ q) : + state.cappedWeightedPotential q reuseWeight event = 0 := by + classical + simp [OriginMonitorState.cappedWeightedPotential, hcache] + +theorem OriginMonitorState.weightedPotential_eq_one_of_complete {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (hcomplete : state.Complete) (hevent : event state.observation.views) : + state.weightedPotential reuseWeight event = 1 := by + classical + obtain ⟨hvalid, hsources, hreuses, hviews⟩ := hcomplete + rw [OriginMonitorState.weightedPotential, if_pos hvalid, hsources, hreuses] + simp only [Finset.card_empty, pow_zero, one_mul] + exact state.completionMass_eq_one_of_complete event hviews hevent + +theorem OriginMonitorState.cappedWeightedPotential_eq_one_of_complete {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (hcache : QueryCache.enncard state.viewed.cache ≤ q) + (hcomplete : state.Complete) (hevent : event state.observation.views) : + state.cappedWeightedPotential q reuseWeight event = 1 := by + rw [state.cappedWeightedPotential_eq_of_enncard_le q event hcache, + state.weightedPotential_eq_one_of_complete event hcomplete hevent] + +theorem originMonitoredAdversaryImpl_expected_weightedPotential_le + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (input : (OracleWorld + SigningSpec).Domain) + (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (q : Nat) (hq : q ≤ 2 ^ 127) + (hcache : QueryCache.enncard state.viewed.cache ≤ q) + (hcoherent : state.ScheduleCoherent) : + (∑' result, + Pr[= result | (originMonitoredAdversaryImpl configuration secretKey input).run state] * + result.2.weightedPotential (digestReuseWeight q) event) ≤ state.weightedPotential (digestReuseWeight q) event := by + classical + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + simp only [originMonitoredAdversaryImpl, StateT.run, tsum_probOutput_bind_mul, + tsum_probOutput_pure_mul] + change (∑' result, + Pr[= result | (romImpl (.inl uniformInput)).run state.viewed.cache] * + state.weightedPotential (digestReuseWeight q) event) ≤ state.weightedPotential (digestReuseWeight q) event + rw [ENNReal.tsum_mul_right] + calc + _ ≤ 1 * state.weightedPotential (digestReuseWeight q) event := by + gcongr + exact tsum_probOutput_le_one + _ = _ := one_mul _ + | inr hashInput => + simp only [originMonitoredAdversaryImpl, StateT.run, tsum_probOutput_bind_mul, + tsum_probOutput_pure_mul] + change (∑' result, + Pr[= result | (randomOracle hashInput).run state.viewed.cache] * + (state.afterDirect hashInput result.1).weightedPotential (digestReuseWeight q) event) ≤ _ + exact state.expected_weightedPotential_afterDirect_le hashInput event hcoherent + | inr request => + simp only [originMonitoredAdversaryImpl, StateT.run, tsum_probOutput_bind_mul, + tsum_probOutput_pure_mul] + simp_rw [originMonitoredAdversaryImpl_signer_result_weightedPotential] + change (∑' result, + Pr[= result | + (simulateQ romImpl (signWithView secretKey request)).run state.viewed.cache] * + (state.afterSigner secretKey request result).weightedPotential (digestReuseWeight q) event) ≤ _ + exact state.expected_weightedPotential_afterSigner_le secretKey request event + (fun target P => probEvent_signWithView_fixedPrehit_le_digestReuseWeight + secretKey request state.viewed.cache target P q hq hcache) hcoherent + +theorem originMonitoredAdversaryImpl_expected_cappedWeightedPotential_le + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (input : (OracleWorld + SigningSpec).Domain) + (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (q : Nat) (hq : q ≤ 2 ^ 127) + (hcoherent : state.ScheduleCoherent) : + (∑' result, + Pr[= result | (originMonitoredAdversaryImpl configuration secretKey input).run state] * + result.2.cappedWeightedPotential q (digestReuseWeight q) event) ≤ state.cappedWeightedPotential q (digestReuseWeight q) event := by + classical + by_cases hcache : QueryCache.enncard state.viewed.cache ≤ q + · rw [state.cappedWeightedPotential_eq_of_enncard_le q event hcache] + calc + (∑' result, + Pr[= result | + (originMonitoredAdversaryImpl configuration secretKey input).run state] * + result.2.cappedWeightedPotential q (digestReuseWeight q) event) ≤ + ∑' result, + Pr[= result | + (originMonitoredAdversaryImpl configuration secretKey input).run state] * + result.2.weightedPotential (digestReuseWeight q) event := by + apply ENNReal.tsum_le_tsum + intro result + exact mul_le_mul' le_rfl (result.2.cappedWeightedPotential_le_weightedPotential q event) + _ ≤ _ := originMonitoredAdversaryImpl_expected_weightedPotential_le configuration secretKey input + state event q hq hcache hcoherent + · rw [state.cappedWeightedPotential_eq_zero_of_not_enncard_le q event hcache] + have hzero : (∑' result, + Pr[= result | + (originMonitoredAdversaryImpl configuration secretKey input).run state] * + result.2.cappedWeightedPotential q (digestReuseWeight q) event) = 0 := by + apply ENNReal.tsum_eq_zero.2 + intro result + by_cases hresult : result ∈ support + ((originMonitoredAdversaryImpl configuration secretKey input).run state) + · have hle := originMonitoredAdversaryImpl_query_cache_le configuration secretKey input + state result hresult + have hcard := QueryCache.enncard_mono hle + have hnotFinal : ¬ QueryCache.enncard result.2.viewed.cache ≤ q := fun hfinal => + hcache (hcard.trans hfinal) + rw [result.2.cappedWeightedPotential_eq_zero_of_not_enncard_le q event hnotFinal, mul_zero] + · rw [probOutput_eq_zero_of_not_mem_support hresult, zero_mul] + exact hzero.le + +theorem originMonitoredAdversaryImpl_expected_cappedWeightedPotential_simulateQ_le + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (q : Nat) (hq : q ≤ 2 ^ 127) + (hcoherent : initialState.ScheduleCoherent) : + (∑' result, + Pr[= result | + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState] * + result.2.cappedWeightedPotential q (digestReuseWeight q) event) ≤ initialState.cappedWeightedPotential q (digestReuseWeight q) event := by + induction computation using OracleComp.inductionOn generalizing initialState with + | pure value => + simp [simulateQ_pure, tsum_probOutput_pure_mul] + | query_bind input next ih => + rw [simulateQ_bind, StateT.run_bind, simulateQ_query, + tsum_probOutput_bind_mul] + simp only [OracleQuery.input_query, OracleQuery.cont_query, id_map] + calc + (∑' result, + Pr[= result | + (originMonitoredAdversaryImpl configuration secretKey input).run initialState] * + ∑' finalResult, + Pr[= finalResult | + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + (next result.1)).run result.2] * + finalResult.2.cappedWeightedPotential q (digestReuseWeight q) event) ≤ + ∑' result, + Pr[= result | + (originMonitoredAdversaryImpl configuration secretKey input).run initialState] * + result.2.cappedWeightedPotential q (digestReuseWeight q) event := by + apply ENNReal.tsum_le_tsum + intro result + by_cases hresult : result ∈ support + ((originMonitoredAdversaryImpl configuration secretKey input).run initialState) + · apply mul_le_mul' le_rfl + exact ih result.1 result.2 + (originMonitoredAdversaryImpl_query_scheduleCoherent configuration secretKey input + initialState result hcoherent hresult) + · rw [probOutput_eq_zero_of_not_mem_support hresult, zero_mul, zero_mul] + _ ≤ _ := originMonitoredAdversaryImpl_expected_cappedWeightedPotential_le configuration + secretKey input initialState event q hq hcoherent + +theorem probEvent_originMonitored_complete_le_weighted_initial + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (q : Nat) (hq : q ≤ 2 ^ 127) + (hcoherent : initialState.ScheduleCoherent) : + Pr[fun result : α × OriginMonitorState configuration => + result.2.Complete ∧ event result.2.observation.views ∧ + QueryCache.enncard result.2.viewed.cache ≤ q | + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState] ≤ initialState.cappedWeightedPotential q (digestReuseWeight q) event := by + let run := (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run initialState + calc + Pr[fun result : α × OriginMonitorState configuration => + result.2.Complete ∧ event result.2.observation.views ∧ + QueryCache.enncard result.2.viewed.cache ≤ q | run] ≤ + ∑' result, Pr[= result | run] * result.2.cappedWeightedPotential q (digestReuseWeight q) event := by + apply probEvent_le_tsum_probOutput_mul_cost + intro result hresult + rw [result.2.cappedWeightedPotential_eq_one_of_complete q event hresult.2.2 + hresult.1 hresult.2.1] + _ ≤ _ := originMonitoredAdversaryImpl_expected_cappedWeightedPotential_simulateQ_le + configuration secretKey computation initialState event q hq hcoherent + +theorem probEvent_originMonitored_complete_le_weighted_ideal + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) → Prop) + (q : Nat) (hq : q ≤ 2 ^ 127) + (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[fun result : α × OriginMonitorState configuration => + result.2.Complete ∧ event result.2.observation.views ∧ + QueryCache.enncard result.2.viewed.cache ≤ q | + (simulateQ (originMonitoredAdversaryImpl configuration secretKey) + computation).run (OriginMonitorState.initial configuration initialCache)] ≤ + (((2 ^ randomnessBits : Nat) : ℝ≥0∞) - (q + digestAttemptLimit : Nat))⁻¹ ^ + configuration.prehit.card * + Pr[event | ($ᵗ (pattern.selected → FewTimeView) : + ProbComp (pattern.selected → FewTimeView))] := by + calc + _ ≤ (OriginMonitorState.initial configuration initialCache).cappedWeightedPotential q (digestReuseWeight q) event := + probEvent_originMonitored_complete_le_weighted_initial configuration secretKey computation + (OriginMonitorState.initial configuration initialCache) event q hq + (OriginMonitorState.scheduleCoherent_initial configuration initialCache) + _ = (OriginMonitorState.initial configuration initialCache).weightedPotential (digestReuseWeight q) event := + (OriginMonitorState.initial configuration initialCache).cappedWeightedPotential_eq_of_enncard_le + q event hcache + _ = _ := by + rw [OriginMonitorState.weightedPotential_initial, digestReuseWeight_source] + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedOriginInvariant.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedOriginInvariant.lean new file mode 100644 index 00000000..ed542d3d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedOriginInvariant.lean @@ -0,0 +1,375 @@ +import SphincsSecurity.Proof.FewTimeWeightedOriginPotential +import SphincsSecurity.Proof.FewTimeWeightedOriginRace + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +namespace Concrete + +theorem OriginMonitorState.weightedPotential_afterDirect_of_sourceAt?_eq_none {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (input : HashInput) (output : HashOutput) + (event : (pattern.selected → FewTimeView) → Prop) + (hsource : configuration.sourceAt? state.directOrdinal = none) : + (state.afterDirect input output).weightedPotential reuseWeight event = state.weightedPotential reuseWeight event := by + classical + simp [OriginMonitorState.afterDirect, monitorDirectSource, hsource, + OriginMonitorState.weightedPotential, OriginMonitorState.pendingSources, + OriginMonitorState.pendingReuses, OriginMonitorState.completionMass] + +theorem OriginMonitorState.weightedPotential_afterDirect_eq_zero_of_invalid {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (input : HashInput) (output : HashOutput) + (event : (pattern.selected → FewTimeView) → Prop) + (hinvalid : state.valid = false) : + (state.afterDirect input output).weightedPotential reuseWeight event = 0 := by + classical + have hafter : (state.afterDirect input output).valid = false := by + cases hsource : configuration.sourceAt? state.directOrdinal with + | none => + simp [OriginMonitorState.afterDirect, monitorDirectSource, hsource, hinvalid] + | some selected => + by_cases hcondition : state.viewed.cache input = none ∧ + signAttemptResultOfOutput output ≠ none + · simp [OriginMonitorState.afterDirect, monitorDirectSource, hsource, hcondition, + hinvalid] + · simp [OriginMonitorState.afterDirect, monitorDirectSource, hsource, hcondition] + simp [OriginMonitorState.weightedPotential, hafter] + +theorem OriginMonitorState.weightedPotential_afterDirect_eq_zero_of_source_failure {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : ↑configuration.prehit) + (input : HashInput) (output : HashOutput) + (event : (pattern.selected → FewTimeView) → Prop) + (hsource : configuration.sourceAt? state.directOrdinal = some selected) + (hfailure : ¬ (state.viewed.cache input = none ∧ + signAttemptResultOfOutput output ≠ none)) : + (state.afterDirect input output).weightedPotential reuseWeight event = 0 := by + classical + simp [OriginMonitorState.afterDirect, monitorDirectSource, hsource, hfailure, + OriginMonitorState.weightedPotential] + +theorem OriginMonitorState.weightedPotential_afterDirect_eq_recordSourceState {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : ↑configuration.prehit) + (input : HashInput) (output : HashOutput) + (event : (pattern.selected → FewTimeView) → Prop) + (hsource : configuration.sourceAt? state.directOrdinal = some selected) + (hcache : state.viewed.cache input = none) + (hsuccess : signAttemptResultOfOutput output ≠ none) : + (state.afterDirect input output).weightedPotential reuseWeight event = + (state.recordSourceState selected input (hashOutputFewTimeView output)).weightedPotential reuseWeight event := by + classical + simp [OriginMonitorState.afterDirect, monitorDirectSource, hsource, hcache, hsuccess, + OriginMonitorState.recordSourceState, OriginMonitorState.weightedPotential, + OriginMonitorState.pendingSources, OriginMonitorState.pendingReuses, + OriginMonitorState.completionMass] + +theorem OriginMonitorState.expected_weightedPotential_afterDirect_le {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (input : HashInput) + (event : (pattern.selected → FewTimeView) → Prop) + (hcoherent : state.ScheduleCoherent) : + (∑' result, Pr[= result | (randomOracle input).run state.viewed.cache] * + (state.afterDirect input result.1).weightedPotential reuseWeight event) ≤ state.weightedPotential reuseWeight event := by + classical + cases hsource : configuration.sourceAt? state.directOrdinal with + | none => + simp_rw [state.weightedPotential_afterDirect_of_sourceAt?_eq_none input _ event hsource] + rw [ENNReal.tsum_mul_right] + calc + (∑' result, Pr[= result | (randomOracle input).run state.viewed.cache]) * + state.weightedPotential reuseWeight event ≤ 1 * state.weightedPotential reuseWeight event := by + gcongr + exact tsum_probOutput_le_one + _ = _ := one_mul _ + | some selected => + cases hvalid : state.valid with + | false => + simp_rw [state.weightedPotential_afterDirect_eq_zero_of_invalid input _ event hvalid] + simp [OriginMonitorState.weightedPotential, hvalid] + | true => + by_cases hcache : state.viewed.cache input = none + · calc + (∑' result, + Pr[= result | (randomOracle input).run state.viewed.cache] * + (state.afterDirect input result.1).weightedPotential reuseWeight event) ≤ + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (state.recordSourceState selected input view).weightedPotential reuseWeight event := by + apply tsum_probOutput_randomOracle_fresh_admissible_view_mul_le_expected + input state.viewed.cache hcache + (fun result => (state.afterDirect input result.1).weightedPotential reuseWeight event) + (fun view => (state.recordSourceState selected input view).weightedPotential reuseWeight event) + · intro result _ hfailed + apply state.weightedPotential_afterDirect_eq_zero_of_source_failure + selected input result.1 event hsource + simp [hcache, hfailed] + · intro result _ hsuccessful + rw [state.weightedPotential_afterDirect_eq_recordSourceState selected input result.1 + event hsource hcache hsuccessful] + _ = state.weightedPotential reuseWeight event := + state.sum_uniform_weightedPotential_recordSourceState selected input event hvalid + (state.sourceAt_not_seenSource selected hcoherent hvalid hsource) + (state.sourceAt_not_seenView selected hcoherent hvalid hsource) + (state.sourceAt_signer_pending selected hcoherent hvalid hsource) + · have hfailure : ∀ output : HashOutput, + ¬ (state.viewed.cache input = none ∧ + signAttemptResultOfOutput output ≠ none) := by + intro output hcondition + exact hcache hcondition.1 + simp_rw [state.weightedPotential_afterDirect_eq_zero_of_source_failure selected input _ event + hsource (hfailure _)] + simp + +theorem OriginMonitorState.weightedPotential_afterSigner_of_selectedAt?_eq_none {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (request : SignRequest) + (state : OriginMonitorState configuration) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) → Prop) + (hselected : pattern.selectedAt? state.signerOrdinal = none) : + (state.afterSigner secretKey request result).weightedPotential reuseWeight event = state.weightedPotential reuseWeight event := by + classical + rw [show state.afterSigner secretKey request result = state.advanceSigner by + simp [OriginMonitorState.afterSigner, monitorSigner, hselected, + OriginMonitorState.advanceSigner]] + exact state.weightedPotential_advanceSigner_of_selectedAt?_eq_none event hselected + +theorem OriginMonitorState.weightedPotential_afterSigner_eq_zero_of_invalid {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (request : SignRequest) + (state : OriginMonitorState configuration) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) → Prop) + (hinvalid : state.valid = false) : + (state.afterSigner secretKey request result).weightedPotential reuseWeight event = 0 := by + classical + have hafter : (state.afterSigner secretKey request result).valid = false := by + cases hselected : pattern.selectedAt? state.signerOrdinal with + | none => + simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hinvalid] + | some selected => + by_cases hprehit : selected ∈ configuration.prehit + · let prehit : ↑configuration.prehit := ⟨selected, hprehit⟩ + by_cases hcondition : prehit ∈ state.observation.seenSources ∧ + PrehitSuccessfulSignerView + (onlyInputCache state.viewed.cache (state.observation.sourceInputs prehit)) + secretKey request (fun view => view = state.observation.views selected) result + · simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hprehit, + prehit, hcondition, hinvalid] + · simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hprehit, + prehit, hcondition] + · cases hview : freshSuccessfulView? state.viewed.cache secretKey request result with + | none => + simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hprehit, hview] + | some view => + simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hprehit, hview, + hinvalid] + simp [OriginMonitorState.weightedPotential, hafter] + +theorem OriginMonitorState.weightedPotential_afterSigner_eq_zero_of_prehit_failure {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (request : SignRequest) + (state : OriginMonitorState configuration) (selected : pattern.selected) + (hprehit : selected ∈ configuration.prehit) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) → Prop) + (hselected : pattern.selectedAt? state.signerOrdinal = some selected) + (hfailure : ¬ ((⟨selected, hprehit⟩ : ↑configuration.prehit) ∈ + state.observation.seenSources ∧ + PrehitSuccessfulSignerView + (onlyInputCache state.viewed.cache + (state.observation.sourceInputs ⟨selected, hprehit⟩)) + secretKey request (fun view => view = state.observation.views selected) result)) : + (state.afterSigner secretKey request result).weightedPotential reuseWeight event = 0 := by + classical + simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hprehit, hfailure, + OriginMonitorState.weightedPotential] + +theorem OriginMonitorState.weightedPotential_afterSigner_eq_advanceSigner_of_prehit {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (request : SignRequest) + (state : OriginMonitorState configuration) (selected : pattern.selected) + (hprehit : selected ∈ configuration.prehit) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) → Prop) + (hselected : pattern.selectedAt? state.signerOrdinal = some selected) + (hseen : (⟨selected, hprehit⟩ : ↑configuration.prehit) ∈ + state.observation.seenSources) + (hsuccess : PrehitSuccessfulSignerView + (onlyInputCache state.viewed.cache + (state.observation.sourceInputs ⟨selected, hprehit⟩)) + secretKey request (fun view => view = state.observation.views selected) result) : + (state.afterSigner secretKey request result).weightedPotential reuseWeight event = + state.advanceSigner.weightedPotential reuseWeight event := by + classical + rw [show state.afterSigner secretKey request result = state.advanceSigner by + simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hprehit, hseen, hsuccess, + OriginMonitorState.advanceSigner]] + +theorem OriginMonitorState.weightedPotential_afterSigner_eq_zero_of_fresh_none {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (request : SignRequest) + (state : OriginMonitorState configuration) (selected : pattern.selected) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) → Prop) + (hselected : pattern.selectedAt? state.signerOrdinal = some selected) + (hnotPrehit : selected ∉ configuration.prehit) + (hnone : freshSuccessfulView? state.viewed.cache secretKey request result = none) : + (state.afterSigner secretKey request result).weightedPotential reuseWeight event = 0 := by + classical + simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hnotPrehit, hnone, + OriginMonitorState.weightedPotential] + +theorem OriginMonitorState.weightedPotential_afterSigner_eq_recordFreshState {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (request : SignRequest) + (state : OriginMonitorState configuration) (selected : pattern.selected) + (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) + (view : FewTimeView) (event : (pattern.selected → FewTimeView) → Prop) + (hselected : pattern.selectedAt? state.signerOrdinal = some selected) + (hnotPrehit : selected ∉ configuration.prehit) + (hview : freshSuccessfulView? state.viewed.cache secretKey request result = some view) : + (state.afterSigner secretKey request result).weightedPotential reuseWeight event = + (state.recordFreshState selected view).weightedPotential reuseWeight event := by + classical + rw [show state.afterSigner secretKey request result = + state.recordFreshState selected view by + simp [OriginMonitorState.afterSigner, monitorSigner, hselected, hnotPrehit, hview, + OriginMonitorState.recordFreshState]] + +set_option maxRecDepth 100000 in +theorem OriginMonitorState.expected_weightedPotential_afterSigner_le {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (secretKey : SecretKey) (request : SignRequest) + (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (hreuse : ∀ target P, + Pr[PrehitSuccessfulSignerView (onlyInputCache state.viewed.cache target) + secretKey request P | + (simulateQ romImpl (signWithView secretKey request)).run state.viewed.cache] ≤ reuseWeight) + (hcoherent : state.ScheduleCoherent) : + (∑' result, + Pr[= result | + (simulateQ romImpl (signWithView secretKey request)).run state.viewed.cache] * + (state.afterSigner secretKey request result).weightedPotential reuseWeight event) ≤ + state.weightedPotential reuseWeight event := by + classical + cases hselected : pattern.selectedAt? state.signerOrdinal with + | none => + simp_rw [state.weightedPotential_afterSigner_of_selectedAt?_eq_none secretKey request _ event + hselected] + rw [ENNReal.tsum_mul_right] + calc + (∑' result, + Pr[= result | + (simulateQ romImpl (signWithView secretKey request)).run state.viewed.cache]) * + state.weightedPotential reuseWeight event ≤ 1 * state.weightedPotential reuseWeight event := by + gcongr + exact tsum_probOutput_le_one + _ = _ := one_mul _ + | some selected => + cases hvalid : state.valid with + | false => + simp_rw [state.weightedPotential_afterSigner_eq_zero_of_invalid secretKey request _ event + hvalid] + simp [OriginMonitorState.weightedPotential, hvalid] + | true => + by_cases hprehit : selected ∈ configuration.prehit + · let prehit : ↑configuration.prehit := ⟨selected, hprehit⟩ + by_cases hseen : prehit ∈ state.observation.seenSources + · calc + (∑' result, + Pr[= result | + (simulateQ romImpl + (signWithView secretKey request)).run state.viewed.cache] * + (state.afterSigner secretKey request result).weightedPotential reuseWeight event) ≤ + reuseWeight * + state.advanceSigner.weightedPotential reuseWeight event := by + apply tsum_probOutput_signWithView_fixedPrehit_mul_le_of_weight + secretKey request state.viewed.cache + (state.observation.sourceInputs prehit) + (fun view => view = state.observation.views selected) + reuseWeight (hreuse _ _) + (fun result => + (state.afterSigner secretKey request result).weightedPotential reuseWeight event) + (state.advanceSigner.weightedPotential reuseWeight event) + · intro result _ hfailure + apply state.weightedPotential_afterSigner_eq_zero_of_prehit_failure + secretKey request selected hprehit result event hselected + exact fun hcondition => hfailure hcondition.2 + · intro result _ hsuccess + rw [state.weightedPotential_afterSigner_eq_advanceSigner_of_prehit + secretKey request selected hprehit result event hselected hseen hsuccess] + _ = state.weightedPotential reuseWeight event := + state.reuseWeight_mul_weightedPotential_advanceSigner prehit event hvalid hseen + ((pattern.selectedAt?_eq_some_iff state.signerOrdinal selected).mp hselected) + · have hfailure : ∀ result, + ¬ (prehit ∈ state.observation.seenSources ∧ + PrehitSuccessfulSignerView + (onlyInputCache state.viewed.cache + (state.observation.sourceInputs prehit)) + secretKey request (fun view => view = state.observation.views selected) + result) := by + intro result hcondition + exact hseen hcondition.1 + simp_rw [state.weightedPotential_afterSigner_eq_zero_of_prehit_failure + secretKey request selected hprehit _ event hselected (hfailure _)] + simp + · calc + (∑' result, + Pr[= result | + (simulateQ romImpl + (signWithView secretKey request)).run state.viewed.cache] * + (state.afterSigner secretKey request result).weightedPotential reuseWeight event) ≤ + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (state.recordFreshState selected view).weightedPotential reuseWeight event := by + apply tsum_probOutput_signWithView_fresh_mul_le_expected + secretKey request state.viewed.cache + (fun result => + (state.afterSigner secretKey request result).weightedPotential reuseWeight event) + (fun view => (state.recordFreshState selected view).weightedPotential reuseWeight event) + · intro result _ hnone + exact state.weightedPotential_afterSigner_eq_zero_of_fresh_none + secretKey request selected result event hselected hprehit hnone + · intro result _ view hview + rw [state.weightedPotential_afterSigner_eq_recordFreshState + secretKey request selected result view event hselected hprehit hview] + _ = state.weightedPotential reuseWeight event := + state.sum_uniform_weightedPotential_recordFreshState selected event hvalid + (state.selectedAt_fresh_not_seenView selected hcoherent hvalid hselected hprehit) + ((pattern.selectedAt?_eq_some_iff state.signerOrdinal selected).mp hselected) + hprehit + + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedOriginPotential.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedOriginPotential.lean new file mode 100644 index 00000000..80a187ca --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedOriginPotential.lean @@ -0,0 +1,177 @@ +import SphincsSecurity.Proof.FewTimeOriginInvariant + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +namespace Concrete + +noncomputable def OriginMonitorState.weightedPotential {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (reuseWeight : ℝ≥0∞) + (event : (pattern.selected → FewTimeView) → Prop) : ℝ≥0∞ := + if state.valid then + (((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * reuseWeight) ^ state.pendingSources.card * + reuseWeight ^ state.pendingReuses.card * + state.completionMass event + else 0 + + +theorem OriginMonitorState.weightedPotential_eq_potential + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) : + state.weightedPotential ((2 ^ 117 : Nat) : ℝ≥0∞)⁻¹ event = state.potential event := by + unfold OriginMonitorState.weightedPotential OriginMonitorState.potential + rw [mul_comm ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹, prehit_race_source_weight] + +theorem source_reuse_parametric_weighted_sum + {Index : Type} [Fintype Index] (probability mass : Index → ℝ≥0∞) + (reuseWeight : ℝ≥0∞) (sourceCount reuseCount : Nat) (totalMass : ℝ≥0∞) + (hmass : (∑ index, probability index * mass index) = totalMass) : + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + ∑ index, probability index * + ((((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * reuseWeight) ^ sourceCount * + reuseWeight ^ (reuseCount + 1) * mass index) = + (((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * reuseWeight) ^ (sourceCount + 1) * + reuseWeight ^ reuseCount * totalMass := by + rw [uniform_weighted_sum probability mass _ totalMass hmass, pow_succ, pow_succ] + ring + +theorem OriginMonitorState.weightedPotential_initial {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) + (cache : QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) → Prop) : + (OriginMonitorState.initial configuration cache).weightedPotential reuseWeight event = + (((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * reuseWeight) ^ configuration.prehit.card * + Pr[event | ($ᵗ (pattern.selected → FewTimeView) : + ProbComp (pattern.selected → FewTimeView))] := by + classical + rw [OriginMonitorState.weightedPotential] + rw [if_pos (show (OriginMonitorState.initial configuration cache).valid = true from rfl), + OriginMonitorState.pendingSources_initial, + OriginMonitorState.pendingReuses_initial, pow_zero, mul_one] + rw [OriginMonitorState.completionMass] + change (((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * reuseWeight) ^ configuration.prehit.card * + Pr[event | (OriginObservation.empty configuration).completedViews] = _ + rw [OriginObservation.completedViews_empty] + +theorem OriginMonitorState.weightedPotential_advanceSigner_of_selectedAt?_eq_none {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) → Prop) + (hselected : pattern.selectedAt? state.signerOrdinal = none) : + state.advanceSigner.weightedPotential reuseWeight event = state.weightedPotential reuseWeight event := by + classical + rw [OriginMonitorState.weightedPotential, OriginMonitorState.weightedPotential] + have hvalid : state.advanceSigner.valid = state.valid := rfl + rw [hvalid] + congr 1 + rw [congrArg Finset.card state.pendingSources_advanceSigner, + congrArg Finset.card + (state.pendingReuses_advanceSigner_of_selectedAt?_eq_none hselected)] + rfl + +theorem OriginMonitorState.sum_uniform_weightedPotential_recordSourceState {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : ↑configuration.prehit) + (input : HashInput) (event : (pattern.selected → FewTimeView) → Prop) + (hvalid : state.valid = true) + (hnotSource : selected ∉ state.observation.seenSources) + (hnotView : selected.1 ∉ state.observation.seenViews) + (hpending : state.signerOrdinal ≤ selected.1.1.val) : + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + ∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (state.recordSourceState selected input view).weightedPotential reuseWeight event = + state.weightedPotential reuseWeight event := by + classical + have hsource := state.pendingSources_recordSourceState_card_add_one + selected input default hnotSource + have hsourceView : ∀ view, + (state.recordSourceState selected input view).pendingSources.card = + (state.recordSourceState selected input default).pendingSources.card := fun view => by + rw [state.pendingSources_recordSourceState selected input view, + state.pendingSources_recordSourceState selected input default] + have hreusesView : ∀ view, + (state.recordSourceState selected input view).pendingReuses.card = + state.pendingReuses.card + 1 := fun view => + state.pendingReuses_recordSourceState_card selected input view hnotSource hpending + have hnextValid : ∀ view, + (state.recordSourceState selected input view).valid = true := fun _ => hvalid + simp_rw [OriginMonitorState.weightedPotential, if_pos hvalid] + simp_rw [if_pos (hnextValid _), OriginMonitorState.completionMass, + hsourceView, hreusesView] + rw [← hsource] + apply source_reuse_parametric_weighted_sum + exact state.observation.sum_uniform_prob_completedViews_recordSource + selected input hnotView event + +theorem OriginMonitorState.sum_uniform_weightedPotential_recordFreshState {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : pattern.selected) + (event : (pattern.selected → FewTimeView) → Prop) + (hvalid : state.valid = true) + (hnotView : selected ∉ state.observation.seenViews) + (hordinal : selected.1.val = state.signerOrdinal) + (hnotPrehit : selected ∉ configuration.prehit) : + (∑ view, Pr[fun value : FewTimeView => value = view | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (state.recordFreshState selected view).weightedPotential reuseWeight event) = + state.weightedPotential reuseWeight event := by + classical + have hsources : ∀ view, + (state.recordFreshState selected view).pendingSources.card = + state.pendingSources.card := fun view => congrArg Finset.card + (state.pendingSources_recordFreshState selected view) + have hreuses : ∀ view, + (state.recordFreshState selected view).pendingReuses.card = + state.pendingReuses.card := fun view => congrArg Finset.card + (state.pendingReuses_recordFreshState selected view hordinal hnotPrehit) + have hnextValid : ∀ view, + (state.recordFreshState selected view).valid = true := fun _ => hvalid + simp_rw [OriginMonitorState.weightedPotential, if_pos hvalid] + simp_rw [if_pos (hnextValid _), OriginMonitorState.completionMass, hsources, hreuses] + apply uniform_weighted_sum + exact state.observation.sum_uniform_prob_completedViews_recordFresh selected hnotView event + +theorem OriginMonitorState.reuseWeight_mul_weightedPotential_advanceSigner {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} + {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginMonitorState configuration) (selected : ↑configuration.prehit) + (event : (pattern.selected → FewTimeView) → Prop) + (hvalid : state.valid = true) + (hseen : selected ∈ state.observation.seenSources) + (hordinal : selected.1.1.val = state.signerOrdinal) : + reuseWeight * state.advanceSigner.weightedPotential reuseWeight event = + state.weightedPotential reuseWeight event := by + classical + have hsources : state.advanceSigner.pendingSources.card = state.pendingSources.card := + congrArg Finset.card state.pendingSources_advanceSigner + have hreuses := state.pendingReuses_advanceSigner_card_add_one selected hseen hordinal + have hnextValid : state.advanceSigner.valid = true := hvalid + rw [OriginMonitorState.weightedPotential, if_pos hnextValid, + OriginMonitorState.weightedPotential, if_pos hvalid, + hsources, OriginMonitorState.completionMass, OriginMonitorState.completionMass] + change reuseWeight * + ((((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * reuseWeight) ^ state.pendingSources.card * + reuseWeight ^ state.advanceSigner.pendingReuses.card * + Pr[event | state.observation.completedViews]) = _ + rw [← hreuses, pow_succ _ state.advanceSigner.pendingReuses.card] + ring + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedOriginRace.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedOriginRace.lean new file mode 100644 index 00000000..a17fec0d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedOriginRace.lean @@ -0,0 +1,89 @@ +import SphincsSecurity.Proof.FewTimeParametricSignerRace +import SphincsSecurity.Proof.FewTimeOriginProbability + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +namespace Concrete + +noncomputable def digestReuseWeight (q : Nat) : ℝ≥0∞ := + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ / + ((1 - ((q + digestAttemptLimit : Nat) : ℝ≥0∞) * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹) * + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹) + +theorem digestReuseWeight_ne_top (q : Nat) (hq : q ≤ 2 ^ 127) : + digestReuseWeight q ≠ ∞ := by + apply ENNReal.div_ne_top (by finiteness) + apply digestRaceSuccessRate_ne_zero_of_budget_lt + norm_num [digestAttemptLimit, randomnessBits] at * + omega + +theorem digestReuseWeight_source (q : Nat) : + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * digestReuseWeight q = + (((2 ^ randomnessBits : Nat) : ℝ≥0∞) - (q + digestAttemptLimit : Nat))⁻¹ := by + let space : ℝ≥0∞ := (2 ^ randomnessBits : Nat) + let admissibility : ℝ≥0∞ := ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ + let budget : ℝ≥0∞ := (q + digestAttemptLimit : Nat) + have hspace : space ≠ 0 := by dsimp [space]; positivity + have hspaceTop : space ≠ ∞ := by dsimp [space]; finiteness + have hadmissibility : admissibility ≠ 0 := by + apply ENNReal.inv_ne_zero.mpr + finiteness + have hadmissibilityTop : admissibility ≠ ∞ := by dsimp [admissibility]; finiteness + change admissibility * (space⁻¹ / ((1 - budget * space⁻¹) * admissibility)) = + (space - budget)⁻¹ + rw [← mul_div_assoc, mul_comm admissibility, + ENNReal.mul_div_mul_right _ _ hadmissibility hadmissibilityTop] + have hfraction : (space - budget) / space = 1 - budget * space⁻¹ := by + rw [ENNReal.sub_div (fun _ _ => hspace), ENNReal.div_self hspace hspaceTop, + div_eq_mul_inv] + rw [← hfraction, div_eq_mul_inv, ENNReal.inv_div (Or.inl hspaceTop) (Or.inl hspace), + ← mul_div_assoc, ENNReal.inv_mul_cancel hspace hspaceTop, one_div] + +set_option linter.constructorNameAsVariable false in +theorem probEvent_signWithView_fixedPrehit_le_digestReuseWeight + (secretKey : SecretKey) (message : Message) (initialCache : QueryCache HashSpec) + (target : HashInput) (P : FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 127) (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[PrehitSuccessfulSignerView (onlyInputCache initialCache target) secretKey message P | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] ≤ + digestReuseWeight q := by + calc + _ ≤ cachedMessageEntryCountWhere (onlyInputCache initialCache target) + secretKey.parameter secretKey.root message P * digestReuseWeight q := + probEvent_signWithView_prehitSuccessful_le_queryBudget127 secretKey message + (onlyInputCache initialCache target) initialCache P + (onlyInputCache_le initialCache target) q hq hcache + _ ≤ 1 * digestReuseWeight q := mul_le_mul' + (cachedMessageEntryCountWhere_onlyInput_le_one initialCache target + secretKey.parameter secretKey.root message P) le_rfl + _ = _ := one_mul _ + +theorem tsum_probOutput_signWithView_fixedPrehit_mul_le_of_weight + (secretKey : SecretKey) (message : Message) + (initialCache : QueryCache HashSpec) (target : HashInput) (P : FewTimeView → Prop) + (reuseWeight : ℝ≥0∞) + (hreuse : Pr[PrehitSuccessfulSignerView (onlyInputCache initialCache target) + secretKey message P | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] ≤ reuseWeight) + (cost : ((Option Signature × Option FewTimeView) × QueryCache HashSpec) → ℝ≥0∞) + (epsilon : ℝ≥0∞) + (hoff : ∀ signerResult ∈ support + ((simulateQ romImpl (signWithView secretKey message)).run initialCache), + ¬ PrehitSuccessfulSignerView (onlyInputCache initialCache target) + secretKey message P signerResult → cost signerResult = 0) + (hon : ∀ signerResult ∈ support + ((simulateQ romImpl (signWithView secretKey message)).run initialCache), + PrehitSuccessfulSignerView (onlyInputCache initialCache target) + secretKey message P signerResult → cost signerResult ≤ epsilon) : + (∑' signerResult, + Pr[= signerResult | + (simulateQ romImpl (signWithView secretKey message)).run initialCache] * + cost signerResult) ≤ reuseWeight * epsilon := + (tsum_probOutput_mul_le_gated _ _ _ _ hoff hon).trans (mul_le_mul' hreuse le_rfl) + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedTargetBound.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedTargetBound.lean new file mode 100644 index 00000000..d66d9ef7 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedTargetBound.lean @@ -0,0 +1,280 @@ +import SphincsSecurity.Proof.FewTimeWeightedTargetPotential + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +noncomputable def OriginTargetMonitorState.cappedRawWeightedPotential + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginTargetMonitorState configuration) (reuseWeight : ℝ≥0∞) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) : ℝ≥0∞ := + if QueryCache.enncard state.origin.viewed.cache ≤ q then state.rawWeightedPotential reuseWeight event else 0 + +theorem OriginTargetMonitorState.cappedRawWeightedPotential_le_rawWeightedPotential {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) : + state.cappedRawWeightedPotential q reuseWeight event ≤ state.rawWeightedPotential reuseWeight event := by + classical + simp only [OriginTargetMonitorState.cappedRawWeightedPotential] + split_ifs + · exact le_rfl + · exact bot_le + +theorem OriginTargetMonitorState.cappedRawWeightedPotential_eq_of_enncard_le {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hcache : QueryCache.enncard state.origin.viewed.cache ≤ q) : + state.cappedRawWeightedPotential q reuseWeight event = state.rawWeightedPotential reuseWeight event := by + simp [OriginTargetMonitorState.cappedRawWeightedPotential, hcache] + +theorem OriginTargetMonitorState.cappedRawWeightedPotential_eq_zero_of_not_enncard_le {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hcache : ¬ QueryCache.enncard state.origin.viewed.cache ≤ q) : + state.cappedRawWeightedPotential q reuseWeight event = 0 := by + simp [OriginTargetMonitorState.cappedRawWeightedPotential, hcache] + +theorem OriginTargetMonitorState.cappedRawWeightedPotential_eq_one_of_complete {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (q : Nat) (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hcache : QueryCache.enncard state.origin.viewed.cache ≤ q) + (hcomplete : state.Complete) + (hevent : ∀ target, state.targetView = some target → + event (state.origin.observation.views, target)) : + state.cappedRawWeightedPotential q reuseWeight event = 1 := by + rw [state.cappedRawWeightedPotential_eq_of_enncard_le q event hcache, + state.rawWeightedPotential_eq_one_of_complete event hcomplete hevent] + +theorem rawTargetMonitoredAdversaryImpl_expected_rawWeightedPotential_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 127) + (hcache : QueryCache.enncard state.origin.viewed.cache ≤ q) + (horigin : state.origin.ScheduleCoherent) + (htarget : state.TargetScheduleCoherent targetOrdinal) : + (∑' result, + Pr[= result | + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state] * result.2.rawWeightedPotential (digestReuseWeight q) event) ≤ + state.rawWeightedPotential (digestReuseWeight q) event := by + classical + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + simp only [rawTargetMonitoredAdversaryImpl, StateT.run, + tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + apply state.expected_rawWeightedPotential_advanceOrigin_le + intro target + exact originMonitoredAdversaryImpl_expected_weightedPotential_le configuration secretKey + (.inl (.inl uniformInput)) state.origin (fun views => event (views, target)) + q hq hcache horigin + | inr hashInput => + simp only [rawTargetMonitoredAdversaryImpl, StateT.run, + tsum_probOutput_bind_mul, tsum_probOutput_pure_mul, + originMonitoredAdversaryImpl] + by_cases hfresh : state.origin.viewed.cache hashInput = none + · simp only [hfresh, if_true, tsum_probOutput_pure_mul] + have hbound := state.expected_rawWeightedPotential_afterRawDirect_le + (reuseWeight := digestReuseWeight q) targetOrdinal + hashInput event horigin htarget + simp only [OriginTargetMonitorState.afterRawDirect, hfresh, if_true] at hbound + convert hbound using 1 + apply tsum_congr + intro result + congr 1 + · simp only [hfresh, if_false, tsum_probOutput_pure_mul] + have hbound := state.expected_rawWeightedPotential_afterRawDirect_le + (reuseWeight := digestReuseWeight q) targetOrdinal + hashInput event horigin htarget + simp only [OriginTargetMonitorState.afterRawDirect, hfresh, if_false] at hbound + convert hbound using 1 + apply tsum_congr + intro result + congr 1 + | inr request => + simp only [rawTargetMonitoredAdversaryImpl, StateT.run, + tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + apply state.expected_rawWeightedPotential_advanceOrigin_le + intro target + exact originMonitoredAdversaryImpl_expected_weightedPotential_le configuration secretKey + (.inr request) state.origin (fun views => event (views, target)) + q hq hcache horigin + +theorem rawTargetMonitoredAdversaryImpl_expected_cappedRawWeightedPotential_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (input : (OracleWorld + SigningSpec).Domain) + (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 127) + (hcoherent : state.JointCoherent targetOrdinal) : + (∑' result, + Pr[= result | + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state] * result.2.cappedRawWeightedPotential q (digestReuseWeight q) event) ≤ + state.cappedRawWeightedPotential q (digestReuseWeight q) event := by + classical + by_cases hcache : QueryCache.enncard state.origin.viewed.cache ≤ q + · rw [state.cappedRawWeightedPotential_eq_of_enncard_le q event hcache] + calc + (∑' result, + Pr[= result | + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state] * result.2.cappedRawWeightedPotential q (digestReuseWeight q) event) ≤ + ∑' result, + Pr[= result | + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state] * result.2.rawWeightedPotential (digestReuseWeight q) event := by + apply ENNReal.tsum_le_tsum + intro result + exact mul_le_mul' le_rfl (result.2.cappedRawWeightedPotential_le_rawWeightedPotential q event) + _ ≤ _ := rawTargetMonitoredAdversaryImpl_expected_rawWeightedPotential_le configuration + secretKey targetOrdinal input state event q hq hcache hcoherent.1 hcoherent.2 + · rw [state.cappedRawWeightedPotential_eq_zero_of_not_enncard_le q event hcache] + have hzero : (∑' result, + Pr[= result | + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state] * result.2.cappedRawWeightedPotential q (digestReuseWeight q) event) = 0 := by + apply ENNReal.tsum_eq_zero.2 + intro result + by_cases hresult : result ∈ support + ((rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + state) + · have hle := rawTargetMonitoredAdversaryImpl_query_cache_le configuration + secretKey targetOrdinal input state result hresult + have hcard := QueryCache.enncard_mono hle + have hnotFinal : ¬ QueryCache.enncard result.2.origin.viewed.cache ≤ q := + fun hfinal => hcache (hcard.trans hfinal) + rw [result.2.cappedRawWeightedPotential_eq_zero_of_not_enncard_le q event hnotFinal, + mul_zero] + · rw [probOutput_eq_zero_of_not_mem_support hresult, zero_mul] + exact hzero.le + +theorem rawTargetMonitoredAdversaryImpl_expected_cappedRawWeightedPotential_simulateQ_le + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 127) + (hcoherent : initialState.JointCoherent targetOrdinal) : + (∑' result, + Pr[= result | + (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState] * + result.2.cappedRawWeightedPotential q (digestReuseWeight q) event) ≤ initialState.cappedRawWeightedPotential q (digestReuseWeight q) event := by + induction computation using OracleComp.inductionOn generalizing initialState with + | pure value => + simp [simulateQ_pure, tsum_probOutput_pure_mul] + | query_bind input next ih => + rw [simulateQ_bind, StateT.run_bind, simulateQ_query, + tsum_probOutput_bind_mul] + simp only [OracleQuery.input_query, OracleQuery.cont_query, id_map] + calc + (∑' result, + Pr[= result | + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + initialState] * + ∑' finalResult, + Pr[= finalResult | + (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + (next result.1)).run result.2] * + finalResult.2.cappedRawWeightedPotential q (digestReuseWeight q) event) ≤ + ∑' result, + Pr[= result | + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + initialState] * result.2.cappedRawWeightedPotential q (digestReuseWeight q) event := by + apply ENNReal.tsum_le_tsum + intro result + by_cases hresult : result ∈ support + ((rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal input).run + initialState) + · apply mul_le_mul' le_rfl + exact ih result.1 result.2 + (rawTargetMonitoredAdversaryImpl_query_jointCoherent configuration secretKey + targetOrdinal input initialState result hcoherent hresult) + · rw [probOutput_eq_zero_of_not_mem_support hresult, zero_mul, zero_mul] + _ ≤ _ := rawTargetMonitoredAdversaryImpl_expected_cappedRawWeightedPotential_le + configuration secretKey targetOrdinal input initialState event q hq hcoherent + +theorem probEvent_rawTargetMonitored_complete_le_weighted_initial + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 127) + (hcoherent : initialState.JointCoherent targetOrdinal) : + Pr[fun result : α × OriginTargetMonitorState configuration => + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + event (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q | + (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState] ≤ initialState.cappedRawWeightedPotential q (digestReuseWeight q) event := by + let run := (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run initialState + calc + Pr[fun result : α × OriginTargetMonitorState configuration => + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + event (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q | run] ≤ + ∑' result, Pr[= result | run] * result.2.cappedRawWeightedPotential q (digestReuseWeight q) event := by + apply probEvent_le_tsum_probOutput_mul_cost + intro result hresult + rw [result.2.cappedRawWeightedPotential_eq_one_of_complete q event hresult.2.2 + hresult.1 hresult.2.1] + _ ≤ _ := rawTargetMonitoredAdversaryImpl_expected_cappedRawWeightedPotential_simulateQ_le + configuration secretKey targetOrdinal computation initialState event q hq hcoherent + +theorem probEvent_rawTargetMonitored_complete_le_weighted_ideal + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (q : Nat) (hq : q ≤ 2 ^ 127) + (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[fun result : α × OriginTargetMonitorState configuration => + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + event (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q | + (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run (OriginTargetMonitorState.initial configuration initialCache)] ≤ + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + ((((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * (digestReuseWeight q)) ^ configuration.prehit.card * + Pr[event | ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : ProbComp _)]) := by + calc + _ ≤ (OriginTargetMonitorState.initial configuration initialCache).cappedRawWeightedPotential + q (digestReuseWeight q) event := + probEvent_rawTargetMonitored_complete_le_weighted_initial configuration secretKey + targetOrdinal computation (OriginTargetMonitorState.initial configuration initialCache) + event q hq + (OriginTargetMonitorState.jointCoherent_initial configuration initialCache + targetOrdinal) + _ = (OriginTargetMonitorState.initial configuration initialCache).rawWeightedPotential (digestReuseWeight q) event := + OriginTargetMonitorState.cappedRawWeightedPotential_eq_of_enncard_le q + (OriginTargetMonitorState.initial configuration initialCache) event hcache + _ = _ := OriginTargetMonitorState.rawWeightedPotential_initial configuration initialCache event + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedTargetCount.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedTargetCount.lean new file mode 100644 index 00000000..423aa3fc --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedTargetCount.lean @@ -0,0 +1,150 @@ +import SphincsSecurity.Proof.FewTimeWeightedTargetBound +import SphincsSecurity.Proof.FewTimeParametricCount + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +noncomputable def OriginConfiguration.rawTargetBound + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (reuseWeight : ℝ≥0∞) : ℝ≥0∞ := + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + ((((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * reuseWeight) ^ configuration.prehit.card * + Pr[FixedFewTimePatternHit pattern.assignment | + ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : ProbComp _)]) + +noncomputable def weightedRawTargetOriginUnionBound + (signatures sources : Nat) (reuseWeight : ℝ≥0∞) : ℝ≥0∞ := + ∑ distinct ∈ Finset.Icc 1 14, + ∑ pattern : FewTimePattern signatures distinct, + ∑ configuration : OriginConfiguration pattern sources, + configuration.rawTargetBound reuseWeight + +theorem probEvent_rawTargetMonitored_complete_fixedPattern_le_weighted + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (targetOrdinal : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (q : Nat) (hq : q ≤ 2 ^ 127) + (hcache : QueryCache.enncard initialCache ≤ q) : + Pr[fun result : α × OriginTargetMonitorState configuration => + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q | + (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey targetOrdinal) + computation).run (OriginTargetMonitorState.initial configuration initialCache)] ≤ + configuration.rawTargetBound (digestReuseWeight q) := + probEvent_rawTargetMonitored_complete_le_weighted_ideal configuration secretKey + targetOrdinal computation initialCache (FixedFewTimePatternHit pattern.assignment) q hq hcache + +theorem OriginConfiguration.rawTargetBound_eq + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (reuseWeight : ℝ≥0∞) : + configuration.rawTargetBound reuseWeight = + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + ((((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * reuseWeight) ^ configuration.prehit.card * + ((2 ^ (totalHeight * distinct + ftsTreeHeight * (ftsTrees - 1)) : Nat) : ℝ≥0∞)⁻¹) := by + classical + letI : Nonempty pattern.selected := ⟨pattern.assignment ⟨0, by decide⟩⟩ + have hpattern : + Pr[FixedFewTimePatternHit pattern.assignment | + ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : ProbComp _)] = + ((2 ^ (totalHeight * distinct + ftsTreeHeight * (ftsTrees - 1)) : Nat) : ℝ≥0∞)⁻¹ := by + have h := probEvent_fixedFewTimePatternHit_eq_inv_of_evalDist pattern.assignment + ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : ProbComp _) + (by simp only [evalDist_uniformSample]) + simpa only [Fintype.card_coe, pattern.card_selected] using h + rw [rawTargetBound, hpattern] + +theorem sum_rawTargetBound_eq {signatures distinct sources : Nat} + (pattern : FewTimePattern signatures distinct) (reuseWeight : ℝ≥0∞) : + (∑ configuration : OriginConfiguration pattern sources, + configuration.rawTargetBound reuseWeight) = + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + (originChoiceMass pattern.selected sources + (((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * reuseWeight) * + ((2 ^ (totalHeight * distinct + ftsTreeHeight * (ftsTrees - 1)) : Nat) : ℝ≥0∞)⁻¹) := by + classical + simp_rw [OriginConfiguration.rawTargetBound_eq] + rw [← Finset.mul_sum] + congr 1 + calc + _ = ∑ data : Σ prehit : Finset pattern.selected, InjectiveSources prehit sources, + (((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * reuseWeight) ^ data.1.card * + ((2 ^ (totalHeight * distinct + ftsTreeHeight * (ftsTrees - 1)) : Nat) : ℝ≥0∞)⁻¹ := by + apply Fintype.sum_equiv (originConfigurationEquiv pattern sources) + intro configuration + rfl + _ = _ := by + simp only [Fintype.sum_sigma, Finset.sum_const, Finset.card_univ, nsmul_eq_mul, + originChoiceMass] + rw [Finset.sum_mul] + apply Finset.sum_congr rfl + intro prehit _ + ring + +noncomputable def parametricFewTimePatternBound + (signatures sources : Nat) (sourceWeight : ℝ≥0∞) : ℝ≥0∞ := + ∑ distinct ∈ Finset.Icc 1 14, + ∑ pattern : FewTimePattern signatures distinct, + originChoiceMass pattern.selected sources sourceWeight * + ((2 ^ (26 * distinct + 140) : Nat) : ℝ≥0∞)⁻¹ + +theorem weightedRawTargetOriginUnionBound_eq + (signatures sources : Nat) (reuseWeight : ℝ≥0∞) : + weightedRawTargetOriginUnionBound signatures sources reuseWeight = + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + parametricFewTimePatternBound signatures sources + (((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * reuseWeight) := by + unfold weightedRawTargetOriginUnionBound parametricFewTimePatternBound + simp_rw [sum_rawTargetBound_eq, ← Finset.mul_sum] + rfl + +theorem parametricFewTimePatternBound_le_of_origin_weight + {signatures q numerator shift budget : Nat} + (sourceWeight : ℝ≥0∞) + (hsignatures : signatures ≤ signatureLimit) + (hweight : 1 + (q : ℝ≥0∞) * sourceWeight ≤ + (numerator : ℝ≥0∞) / 2 ^ shift) + (hcertificate : (∑ d ∈ Finset.Icc 1 14, + (d + 1).ascFactorial (14 - d) * 2 ^ (24 * d) * d ^ 14 * + numerator ^ d * 2 ^ ((26 + shift) * (14 - d))) ≤ Nat.factorial 14 * budget) : + parametricFewTimePatternBound signatures q sourceWeight ≤ + (budget : ℝ≥0∞) * ((2 ^ ((26 + shift) * 14 + 140) : Nat) : ℝ≥0∞)⁻¹ := by + classical + calc + _ ≤ ∑ d ∈ Finset.Icc 1 14, ∑ _pattern : FewTimePattern signatures d, + ((numerator : ℝ≥0∞) / 2 ^ shift) ^ d * + ((2 ^ (26 * d + 140) : Nat) : ℝ≥0∞)⁻¹ := by + apply Finset.sum_le_sum + intro d hd + apply Finset.sum_le_sum + intro pattern _ + gcongr + calc + _ ≤ (1 + q * sourceWeight) ^ Fintype.card pattern.selected := + originChoiceMass_le _ _ _ + _ = (1 + q * sourceWeight) ^ d := by + rw [Fintype.card_coe, pattern.card_selected] + _ ≤ _ := pow_le_pow_left' hweight d + _ = ∑ d ∈ Finset.Icc 1 14, + (Fintype.card (FewTimePattern signatures d) * numerator ^ d * + 2 ^ ((26 + shift) * (14 - d)) : Nat) * + ((2 ^ ((26 + shift) * 14 + 140) : Nat) : ℝ≥0∞)⁻¹ := by + simp only [Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + apply Finset.sum_congr rfl + intro d hd + rw [← mul_assoc] + exact weightedFewTime_term_common_denominator signatures d numerator shift + (Finset.mem_Icc.mp hd).2 + _ = ((∑ d ∈ Finset.Icc 1 14, + Fintype.card (FewTimePattern signatures d) * numerator ^ d * + 2 ^ ((26 + shift) * (14 - d)) : Nat) : ℝ≥0∞) * + ((2 ^ ((26 + shift) * 14 + 140) : Nat) : ℝ≥0∞)⁻¹ := by + rw [← Finset.sum_mul, Nat.cast_sum] + _ ≤ _ := mul_le_mul' (Nat.cast_le.mpr + (weightedFewTime_scaled_sum_le hsignatures hcertificate)) le_rfl + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedTargetPotential.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedTargetPotential.lean new file mode 100644 index 00000000..4b4f2543 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedTargetPotential.lean @@ -0,0 +1,262 @@ +import SphincsSecurity.Proof.FewTimeWeightedOriginAdaptive +import SphincsSecurity.Proof.FewTimeRawTargetBound + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +noncomputable def OriginTargetMonitorState.weightedPotential + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) (reuseWeight : ℝ≥0∞) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) : ℝ≥0∞ := + if state.valid then + match state.targetView with + | some target => state.origin.weightedPotential reuseWeight fun views => event (views, target) + | none => ∑ target, Pr[fun value : FewTimeView => value = target | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + state.origin.weightedPotential reuseWeight (fun views => event (views, target)) + else 0 + +theorem OriginTargetMonitorState.expected_weightedPotential_advanceOrigin_le {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) + (mass : α → ℝ≥0∞) (nextOrigin : α → OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hnext : ∀ target, + (∑' result, mass result * + (nextOrigin result).weightedPotential reuseWeight (fun views => event (views, target))) ≤ + state.origin.weightedPotential reuseWeight (fun views => event (views, target))) : + (∑' result, mass result * + (state.advanceOrigin (nextOrigin result)).weightedPotential reuseWeight event) ≤ + state.weightedPotential reuseWeight event := by + classical + cases hvalid : state.valid with + | false => + simp [OriginTargetMonitorState.weightedPotential, + OriginTargetMonitorState.advanceOrigin, hvalid] + | true => + cases htarget : state.targetView with + | some target => + simpa [OriginTargetMonitorState.weightedPotential, + OriginTargetMonitorState.advanceOrigin, hvalid, htarget] using hnext target + | none => + simp only [OriginTargetMonitorState.weightedPotential, + OriginTargetMonitorState.advanceOrigin, hvalid, htarget, if_true] + calc + (∑' result, mass result * + ∑ target, Pr[fun value : FewTimeView => value = target | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (nextOrigin result).weightedPotential reuseWeight (fun views => event (views, target))) = + ∑ target, Pr[fun value : FewTimeView => value = target | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + ∑' result, mass result * + (nextOrigin result).weightedPotential reuseWeight + (fun views => event (views, target)) := by + calc + _ = ∑' result, ∑ target, + mass result * + (Pr[fun value : FewTimeView => value = target | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (nextOrigin result).weightedPotential reuseWeight + (fun views => event (views, target))) := by + apply tsum_congr + intro result + rw [Finset.mul_sum] + _ = ∑ target, ∑' result, + mass result * + (Pr[fun value : FewTimeView => value = target | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (nextOrigin result).weightedPotential reuseWeight + (fun views => event (views, target))) := by + exact Summable.tsum_finsetSum fun _ _ => ENNReal.summable + _ = _ := by + apply Finset.sum_congr rfl + intro target _ + calc + _ = ∑' result, + Pr[fun value : FewTimeView => value = target | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + (mass result * + (nextOrigin result).weightedPotential reuseWeight + (fun views => event (views, target))) := by + apply tsum_congr + intro result + ac_rfl + _ = _ := ENNReal.tsum_mul_left + _ ≤ _ := by + apply Finset.sum_le_sum + intro target _ + exact mul_le_mul' le_rfl (hnext target) + +theorem OriginTargetMonitorState.weightedPotential_eq_one_of_complete {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hcomplete : state.Complete) + (hevent : ∀ target, state.targetView = some target → + event (state.origin.observation.views, target)) : + state.weightedPotential reuseWeight event = 1 := by + rcases hcomplete with ⟨hvalid, horigin, target, htarget⟩ + simp [OriginTargetMonitorState.weightedPotential, hvalid, htarget, + state.origin.weightedPotential_eq_one_of_complete + (fun views => event (views, target)) horigin (hevent target htarget)] + +theorem OriginTargetMonitorState.weightedPotential_initial {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) + (cache : QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) : + (OriginTargetMonitorState.initial configuration cache).weightedPotential reuseWeight event = + (((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * reuseWeight) ^ configuration.prehit.card * + Pr[event | ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : + ProbComp ((pattern.selected → FewTimeView) × FewTimeView))] := by + classical + rw [OriginTargetMonitorState.weightedPotential] + simp only [OriginTargetMonitorState.initial, if_true] + simp_rw [OriginMonitorState.weightedPotential_initial] + rw [probEvent_uniform_views_target_eq_sum pattern event] + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro target _ + ac_rfl + +noncomputable def OriginTargetMonitorState.rawWeightedPotential + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) (reuseWeight : ℝ≥0∞) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) : ℝ≥0∞ := + (if state.targetView = none then ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ else 1) * + state.weightedPotential reuseWeight event + +theorem OriginTargetMonitorState.expected_rawWeightedPotential_advanceOrigin_le {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) + (mass : α → ℝ≥0∞) (nextOrigin : α → OriginMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hnext : ∀ target, + (∑' result, mass result * + (nextOrigin result).weightedPotential reuseWeight (fun views => event (views, target))) ≤ + state.origin.weightedPotential reuseWeight (fun views => event (views, target))) : + (∑' result, mass result * + (state.advanceOrigin (nextOrigin result)).rawWeightedPotential reuseWeight event) ≤ + state.rawWeightedPotential reuseWeight event := by + have hbound := state.expected_weightedPotential_advanceOrigin_le mass nextOrigin event hnext + simp only [advanceOrigin] at hbound + cases htarget : state.targetView with + | none => + simp only [htarget] at hbound + simp only [rawWeightedPotential, advanceOrigin, htarget, ↓reduceIte] + simp_rw [mul_left_comm (mass _)] + rw [ENNReal.tsum_mul_left] + exact mul_le_mul_right hbound (((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹) + | some target => + simpa only [rawWeightedPotential, advanceOrigin, htarget, reduceCtorEq, ↓reduceIte, one_mul] + using hbound + +theorem OriginTargetMonitorState.rawWeightedPotential_afterRawDirect_of_ordinal_ne {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (input : HashInput) (output : HashOutput) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hne : state.candidateOrdinal ≠ targetOrdinal) : + (state.afterRawDirect targetOrdinal input output).rawWeightedPotential reuseWeight event = + (state.advanceOrigin (state.origin.afterDirect input output)).rawWeightedPotential reuseWeight event := by + by_cases hfresh : state.origin.viewed.cache input = none + · simp [afterRawDirect, hfresh, rawWeightedPotential, weightedPotential, recordCandidate, advanceOrigin, hne] + · simp [afterRawDirect, hfresh] + +theorem OriginTargetMonitorState.expected_rawWeightedPotential_afterRawDirect_le {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (targetOrdinal : Nat) (state : OriginTargetMonitorState configuration) + (input : HashInput) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (horigin : state.origin.ScheduleCoherent) + (htarget : state.TargetScheduleCoherent targetOrdinal) : + (∑' result, Pr[= result | (randomOracle input).run state.origin.viewed.cache] * + (state.afterRawDirect targetOrdinal input result.1).rawWeightedPotential reuseWeight event) ≤ + state.rawWeightedPotential reuseWeight event := by + classical + by_cases hfresh : state.origin.viewed.cache input = none + · by_cases heq : state.candidateOrdinal = targetOrdinal + · cases hsource : configuration.sourceAt? state.origin.directOrdinal with + | some selected => + have hzero : ∀ output, + (state.afterRawDirect targetOrdinal input output).rawWeightedPotential reuseWeight event = 0 := by + intro output + simp [afterRawDirect, hfresh, hsource, rawWeightedPotential, weightedPotential, + recordCandidate, advanceOrigin, heq] + simp_rw [hzero] + simp + | none => + cases hvalid : state.valid with + | false => + have hzero : ∀ output, + (state.afterRawDirect targetOrdinal input output).rawWeightedPotential reuseWeight event = 0 := by + intro output + simp [afterRawDirect, hfresh, hsource, rawWeightedPotential, weightedPotential, + recordCandidate, advanceOrigin, heq, hvalid] + simp_rw [hzero] + simp + | true => + have htargetView : state.targetView = none := + state.targetView_eq_none_of_candidateOrdinal_eq htarget heq + calc + _ ≤ ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + ∑ target, Pr[fun value : FewTimeView => value = target | + ($ᵗ FewTimeView : ProbComp FewTimeView)] * + state.origin.weightedPotential reuseWeight (fun views => event (views, target)) := by + apply tsum_probOutput_randomOracle_fresh_admissible_view_mul_le_expected + input state.origin.viewed.cache hfresh + · intro result _ hnone + simp [afterRawDirect, hfresh, hsource, rawWeightedPotential, weightedPotential, + recordCandidate, advanceOrigin, heq, hvalid, hnone] + · intro result _ hsome + simp [afterRawDirect, hfresh, hsource, rawWeightedPotential, weightedPotential, + recordCandidate, advanceOrigin, heq, hvalid, hsome, + state.origin.weightedPotential_afterDirect_of_sourceAt?_eq_none + input result.1 _ hsource] + _ = state.rawWeightedPotential reuseWeight event := by + simp [rawWeightedPotential, weightedPotential, hvalid, htargetView] + · simp_rw [state.rawWeightedPotential_afterRawDirect_of_ordinal_ne targetOrdinal input _ event heq] + apply state.expected_rawWeightedPotential_advanceOrigin_le + intro target + exact state.origin.expected_weightedPotential_afterDirect_le input + (fun views => event (views, target)) horigin + · simp_rw [afterRawDirect, hfresh, if_false] + apply state.expected_rawWeightedPotential_advanceOrigin_le + intro target + exact state.origin.expected_weightedPotential_afterDirect_le input + (fun views => event (views, target)) horigin + +theorem OriginTargetMonitorState.rawWeightedPotential_eq_one_of_complete {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + {configuration : OriginConfiguration pattern sources} + (state : OriginTargetMonitorState configuration) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) + (hcomplete : state.Complete) + (hevent : ∀ target, state.targetView = some target → + event (state.origin.observation.views, target)) : + state.rawWeightedPotential reuseWeight event = 1 := by + obtain ⟨target, htarget⟩ := hcomplete.2.2 + simp only [rawWeightedPotential, htarget, reduceCtorEq, ↓reduceIte, one_mul] + exact state.weightedPotential_eq_one_of_complete event hcomplete hevent + +theorem OriginTargetMonitorState.rawWeightedPotential_initial {reuseWeight : ℝ≥0∞} + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) + (cache : QueryCache HashSpec) + (event : (pattern.selected → FewTimeView) × FewTimeView → Prop) : + (OriginTargetMonitorState.initial configuration cache).rawWeightedPotential reuseWeight event = + ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * + ((((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹ * reuseWeight) ^ configuration.prehit.card * + Pr[event | ($ᵗ ((pattern.selected → FewTimeView) × FewTimeView) : ProbComp _)]) := by + rw [rawWeightedPotential, weightedPotential_initial] + simp only [initial, ↓reduceIte] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedTargetUnion.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedTargetUnion.lean new file mode 100644 index 00000000..5639dbc7 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeWeightedTargetUnion.lean @@ -0,0 +1,203 @@ +import SphincsSecurity.Proof.FewTimeWeightedTargetCount +import SphincsSecurity.Proof.FewTimeRawTargetUnion + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem probEvent_exists_fixedRawOrdinal_viewedEvent_le_weighted + {signatures distinct sources : Nat} {pattern : FewTimePattern signatures distinct} + (configuration : OriginConfiguration pattern sources) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (q : Nat) (hq : q ≤ 2 ^ 127) + (hcache : QueryCache.enncard initialCache ≤ q) (candidates : Nat) + (viewedEvent : Fin candidates → α × ViewedFullTraceState → Prop) + (himp : ∀ (candidate : Fin candidates) + (result : α × OriginTargetMonitorState configuration), + result ∈ support + ((simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey candidate.val) + computation).run (OriginTargetMonitorState.initial configuration initialCache)) → + viewedEvent candidate (result.1, result.2.origin.viewed) → + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q) : + Pr[fun result => ∃ candidate : Fin candidates, viewedEvent candidate result | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run + (OriginTargetMonitorState.initial configuration initialCache).origin.viewed] ≤ + candidates * configuration.rawTargetBound (digestReuseWeight q) := by + classical + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run + (OriginTargetMonitorState.initial configuration initialCache).origin.viewed + calc + Pr[fun result => ∃ candidate : Fin candidates, viewedEvent candidate result | run] = + Pr[fun result => ∃ candidate ∈ (Finset.univ : Finset (Fin candidates)), + viewedEvent candidate result | run] := by + congr 1 + funext result + simp + _ ≤ ∑ candidate ∈ (Finset.univ : Finset (Fin candidates)), + Pr[viewedEvent candidate | run] := + probEvent_exists_finset_le_sum Finset.univ run viewedEvent + _ ≤ ∑ _candidate ∈ (Finset.univ : Finset (Fin candidates)), + configuration.rawTargetBound (digestReuseWeight q) := by + apply Finset.sum_le_sum + intro candidate _ + calc + Pr[viewedEvent candidate | run] ≤ + Pr[fun result : α × OriginTargetMonitorState configuration => + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q | + (simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey candidate.val) + computation).run + (OriginTargetMonitorState.initial configuration initialCache)] := + probEvent_viewed_le_rawTargetMonitoredAdversaryImpl configuration secretKey + candidate.val computation (OriginTargetMonitorState.initial configuration initialCache) + (viewedEvent candidate) _ (himp candidate) + _ ≤ _ := probEvent_rawTargetMonitored_complete_fixedPattern_le_weighted + configuration secretKey candidate.val computation initialCache q hq hcache + _ = _ := by + rw [Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul] + +theorem probEvent_exists_originConfiguration_fixedRawOrdinal_viewedEvent_le_weightedOrigin + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q : Nat) + (hq : q ≤ 2 ^ 127) (hcache : QueryCache.enncard initialCache ≤ q) + (candidates : Nat) + (viewedEvent : ∀ (distinct : Nat) (pattern : FewTimePattern signatures distinct), + OriginConfiguration pattern sources → Fin candidates → + α × ViewedFullTraceState → Prop) + (himp : ∀ (distinct : Nat) (pattern : FewTimePattern signatures distinct) + (configuration : OriginConfiguration pattern sources) (candidate : Fin candidates) + (result : α × OriginTargetMonitorState configuration), + result ∈ support + ((simulateQ + (rawTargetMonitoredAdversaryImpl configuration secretKey candidate.val) + computation).run (OriginTargetMonitorState.initial configuration initialCache)) → + viewedEvent distinct pattern configuration candidate + (result.1, result.2.origin.viewed) → + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q) : + Pr[fun result => ∃ distinct ∈ Finset.Icc 1 14, + ∃ pattern : FewTimePattern signatures distinct, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] ≤ + candidates * weightedRawTargetOriginUnionBound signatures sources (digestReuseWeight q) := by + classical + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩ + calc + Pr[fun result => ∃ distinct ∈ Finset.Icc 1 14, + ∃ pattern : FewTimePattern signatures distinct, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | run] ≤ + ∑ distinct ∈ Finset.Icc 1 14, + Pr[fun result => + ∃ pattern : FewTimePattern signatures distinct, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | run] := + probEvent_exists_finset_le_sum (Finset.Icc 1 14) run fun distinct result => + ∃ pattern : FewTimePattern signatures distinct, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result + _ ≤ ∑ distinct ∈ Finset.Icc 1 14, + ∑ pattern : FewTimePattern signatures distinct, + Pr[fun result => + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | run] := by + apply Finset.sum_le_sum + intro distinct _ + calc + _ = Pr[fun result => + ∃ pattern ∈ (Finset.univ : Finset (FewTimePattern signatures distinct)), + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | run] := by + congr 1 + funext result + simp + _ ≤ _ := probEvent_exists_finset_le_sum Finset.univ run fun pattern result => + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result + _ ≤ ∑ distinct ∈ Finset.Icc 1 14, + ∑ pattern : FewTimePattern signatures distinct, + ∑ configuration : OriginConfiguration pattern sources, + Pr[fun result => ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | run] := by + apply Finset.sum_le_sum + intro distinct _ + apply Finset.sum_le_sum + intro pattern _ + calc + _ = Pr[fun result => + ∃ configuration ∈ + (Finset.univ : Finset (OriginConfiguration pattern sources)), + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result | run] := by + congr 1 + funext result + simp + _ ≤ _ := probEvent_exists_finset_le_sum Finset.univ run fun configuration result => + ∃ candidate : Fin candidates, + viewedEvent distinct pattern configuration candidate result + _ ≤ ∑ distinct ∈ Finset.Icc 1 14, + ∑ pattern : FewTimePattern signatures distinct, + ∑ configuration : OriginConfiguration pattern sources, + candidates * configuration.rawTargetBound (digestReuseWeight q) := by + apply Finset.sum_le_sum + intro distinct _ + apply Finset.sum_le_sum + intro pattern _ + apply Finset.sum_le_sum + intro configuration _ + exact probEvent_exists_fixedRawOrdinal_viewedEvent_le_weighted configuration secretKey + computation initialCache q hq hcache candidates + (viewedEvent distinct pattern configuration) + (himp distinct pattern configuration) + _ = candidates * weightedRawTargetOriginUnionBound signatures sources (digestReuseWeight q) := by + rw [weightedRawTargetOriginUnionBound] + simp_rw [← Finset.mul_sum] + +theorem probEvent_exists_fixedRawTargetViewedTerminal_le_weightedOrigin_of_candidates + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q : Nat) + (hq : q ≤ 2 ^ 127) (hcache : QueryCache.enncard initialCache ≤ q) + (candidates : Nat) : + Pr[SomeFixedRawTargetViewedTerminal secretKey computation initialCache + signatures sources q candidates | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] ≤ + candidates * weightedRawTargetOriginUnionBound signatures sources (digestReuseWeight q) := by + unfold SomeFixedRawTargetViewedTerminal + apply probEvent_exists_originConfiguration_fixedRawOrdinal_viewedEvent_le_weightedOrigin + secretKey computation initialCache signatures sources q hq hcache candidates + (fun _ _ configuration candidate => + FixedRawTargetViewedTerminal secretKey computation initialCache q + configuration candidate.val) + intro distinct pattern configuration candidate result hresult hevent + obtain ⟨hcacheFinal, hterminal⟩ := hevent + have hprojection : (result.1, result.2.origin.viewed) = + (result.1, result.2.origin.viewed) := rfl + obtain ⟨hcomplete, hhit⟩ := hterminal result hresult hprojection + exact ⟨hcomplete, hhit, hcacheFinal⟩ + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FewTimeWitness.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimeWitness.lean new file mode 100644 index 00000000..42660214 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeWitness.lean @@ -0,0 +1,551 @@ +import SphincsSecurity.Proof.OneTimeEvents + +/-! +# Finite witnesses for the few-time leak + +A leak chooses one successful signing entry for each of the fourteen opened trees. Keeping the +range of that choice as a finset exposes the number of distinct signatures used by the opening. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +abbrev SigningEntry := (request : SignRequest) × SigningSpec.Range request +abbrev FlatSigningEntry := SignRequest × Option Signature + +def SigningEntry.flat (entry : SigningEntry) : FlatSigningEntry := + (entry.1, entry.2) + +structure FtsCoverAt (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (index : Index) + (targetLeaves : DigestTree → FtsLeaf) (tree : FtsTree) where + entry : SigningEntry + signature : Signature + signedLeaves : DigestTree → FtsLeaf + entry_mem : entry ∈ signingLog + response_eq : entry.2 = some signature + successful : SuccessfulSignRun f cache secretKey entry.1 signature + honest : HonestFtsSignAt f cache secretKey entry.1 signature index signedLeaves + leaf_eq : signedLeaves (ftsIndexOf tree) = targetLeaves (ftsIndexOf tree) + +structure FewTimeCover (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (index : Index) + (targetLeaves : DigestTree → FtsLeaf) where + select : ∀ tree, FtsCoverAt f cache secretKey signingLog index targetLeaves tree + +noncomputable def FewTimeLeak.cover {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (hleak : FewTimeLeak f cache secretKey signingLog index targetLeaves) : + FewTimeCover f cache secretKey signingLog index targetLeaves := by + classical + refine ⟨fun tree => ?_⟩ + let entry := Classical.choose (hleak tree) + have hsignatureExists := Classical.choose_spec (hleak tree) + let signature := Classical.choose hsignatureExists + have hleavesExists := Classical.choose_spec hsignatureExists + let signedLeaves := Classical.choose hleavesExists + have hproperties := Classical.choose_spec hleavesExists + exact ⟨entry, signature, signedLeaves, hproperties.1, hproperties.2.1, + hproperties.2.2.1, hproperties.2.2.2.1, hproperties.2.2.2.2⟩ + +noncomputable def FewTimeCover.entries {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) : + Finset FlatSigningEntry := + Finset.univ.image fun tree => (cover.select tree).entry.flat + +theorem FewTimeCover.entry_mem_entries {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) (tree : FtsTree) : + (cover.select tree).entry.flat ∈ cover.entries := by + classical + exact Finset.mem_image.2 ⟨tree, Finset.mem_univ _, rfl⟩ + +theorem FewTimeCover.entries_subset_log {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) : + ↑cover.entries ⊆ ↑(signingLog.map SigningEntry.flat).toFinset := by + classical + intro entry hentry + obtain ⟨tree, _, rfl⟩ := Finset.mem_image.1 hentry + exact List.mem_toFinset.2 (List.mem_map.2 ⟨_, (cover.select tree).entry_mem, rfl⟩) + +theorem FewTimeCover.entries_card_pos {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) : + 0 < cover.entries.card := by + classical + have hmem := cover.entry_mem_entries (⟨0, by decide⟩ : FtsTree) + exact Finset.card_pos.2 ⟨_, hmem⟩ + +theorem FewTimeCover.entries_card_le_trees {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) : + cover.entries.card ≤ ftsTrees - 1 := by + classical + calc + cover.entries.card ≤ (Finset.univ : Finset FtsTree).card := Finset.card_image_le + _ = ftsTrees - 1 := Fintype.card_fin _ + +theorem FewTimeCover.entries_card_le_log_length {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) : + cover.entries.card ≤ signingLog.length := by + classical + calc + cover.entries.card ≤ (signingLog.map SigningEntry.flat).toFinset.card := + Finset.card_le_card cover.entries_subset_log + _ ≤ (signingLog.map SigningEntry.flat).length := + List.toFinset_card_le (signingLog.map SigningEntry.flat) + _ = signingLog.length := List.length_map SigningEntry.flat + +theorem FewTimeCover.entries_card_le_signatureLimit {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (hvalid : SigningTranscript.Valid signingLog) : + cover.entries.card ≤ signatureLimit := + cover.entries_card_le_log_length.trans hvalid + +theorem flatSigningEntry_has_log_index (signingLog : QueryLog SigningSpec) + (entry : FlatSigningEntry) (hentry : entry ∈ signingLog.map SigningEntry.flat) : + ∃ position : Fin signingLog.length, SigningEntry.flat (signingLog.get position) = entry := by + obtain ⟨original, horiginal, rfl⟩ := List.mem_map.1 hentry + obtain ⟨position, hposition⟩ := List.mem_iff_get.1 horiginal + exact ⟨position, congrArg SigningEntry.flat hposition⟩ + +theorem List.get_ne_of_lt_idxOf [BEq α] [LawfulBEq α] (list : List α) (value : α) + (position : Fin list.length) (hlt : position.val < list.idxOf value) : + list.get position ≠ value := by + induction list with + | nil => exact Fin.elim0 position + | cons head rest ih => + obtain ⟨position, hposition⟩ := position + cases position with + | zero => + intro heq + have hhead : head = value := by simpa using heq + subst head + simp at hlt + | succ position => + cases hbeq : head == value with + | true => + have hhead : head = value := by simpa using hbeq + subst head + simp at hlt + | false => + have hhead : head ≠ value := by + intro heq + subst head + simp at hbeq + have hlt' : position < rest.idxOf value := by + simpa [List.idxOf_cons_ne rest hhead] using hlt + simpa using ih ⟨position, by simpa using hposition⟩ hlt' + +noncomputable def FewTimeCover.logIndex {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (entry : cover.entries) : Fin signingLog.length := + ⟨(signingLog.map SigningEntry.flat).idxOf entry.1, by + simpa only [List.length_map] using List.idxOf_lt_length_iff.2 + (List.mem_toFinset.1 (cover.entries_subset_log entry.2))⟩ + +theorem FewTimeCover.logIndex_spec {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (entry : cover.entries) : + SigningEntry.flat (signingLog.get (cover.logIndex entry)) = entry.1 := + by + classical + have hmem : entry.1 ∈ signingLog.map SigningEntry.flat := + List.mem_toFinset.1 (cover.entries_subset_log entry.2) + have hlt := List.idxOf_lt_length_iff.2 hmem + let i := (signingLog.map SigningEntry.flat).idxOf entry.1 + have hi : i < signingLog.length := by simpa only [i, List.length_map] using hlt + have hget : (signingLog.map SigningEntry.flat).get ⟨i, by simpa only [i] using hlt⟩ + = entry.1 := List.idxOf_get _ + have hmap : (signingLog.map SigningEntry.flat).get ⟨i, by simpa only [i] using hlt⟩ = + SigningEntry.flat (signingLog.get ⟨i, hi⟩) := by simp + simpa only [FewTimeCover.logIndex, i] using hmap.symm.trans hget + +theorem FewTimeCover.logIndex_first {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (entry : cover.entries) (position : Fin signingLog.length) + (hposition : position.val < (cover.logIndex entry).val) : + SigningEntry.flat (signingLog.get position) ≠ entry.1 := by + classical + let mappedPosition : Fin (signingLog.map SigningEntry.flat).length := + ⟨position.val, by simpa only [List.length_map] using position.isLt⟩ + have hlt : mappedPosition.val < (signingLog.map SigningEntry.flat).idxOf entry.1 := by + simpa only [mappedPosition, FewTimeCover.logIndex] using hposition + have hne := List.get_ne_of_lt_idxOf + (signingLog.map SigningEntry.flat) entry.1 mappedPosition hlt + simpa only [mappedPosition, List.get_eq_getElem, List.getElem_map] using hne + +theorem FewTimeCover.logIndex_injective {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) : + Function.Injective cover.logIndex := by + intro left right heq + apply Subtype.ext + have hleft := cover.logIndex_spec left + have hright := cover.logIndex_spec right + rw [heq] at hleft + exact hleft.symm.trans hright + +noncomputable def FewTimeCover.logIndices {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) : + Finset (Fin signingLog.length) := + Finset.univ.image cover.logIndex + +theorem FewTimeCover.logIndices_card {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) : + cover.logIndices.card = cover.entries.card := by + classical + rw [FewTimeCover.logIndices, + Finset.card_image_of_injective _ cover.logIndex_injective, + Finset.card_univ, Fintype.card_coe] + +noncomputable def FewTimeCover.representativeTree {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (entry : cover.entries) : FtsTree := + Classical.choose (Finset.mem_image.1 entry.2) + +theorem FewTimeCover.representativeTree_spec {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (entry : cover.entries) : + (cover.select (cover.representativeTree entry)).entry.flat = entry.1 := + (Classical.choose_spec (Finset.mem_image.1 entry.2)).2 + +noncomputable def FewTimeCover.entryDigest {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (entry : cover.entries) : MessageDigest := + Classical.choose (cover.select (cover.representativeTree entry)).honest.1.extract.2 + +noncomputable def FewTimeCover.entryDigestInput {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (entry : cover.entries) : HashInput := + let selected := cover.select (cover.representativeTree entry) + tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root selected.entry.1 selected.signature.randomness) + +theorem FewTimeCover.entryDigest_spec {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (entry : cover.entries) : + let selected := cover.select (cover.representativeTree entry) + evalWithAnswerFn f (messageDigest secretKey.parameter secretKey.root selected.entry.1 + selected.signature.randomness) = cover.entryDigest entry + ∧ Admissible (cover.entryDigest entry) + ∧ index = digestIndex (cover.entryDigest entry) + ∧ selected.signedLeaves = digestLeaves (cover.entryDigest entry) := by + let selected := cover.select (cover.representativeTree entry) + have hspec := Classical.choose_spec selected.honest.1.extract.2 + exact ⟨hspec.1, hspec.2.1, hspec.2.2.1, hspec.2.2.2.1⟩ + +noncomputable def FewTimeCover.entryAssignment {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (tree : FtsTree) : cover.entries := + ⟨(cover.select tree).entry.flat, cover.entry_mem_entries tree⟩ + +theorem FewTimeCover.entryDigest_index {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (entry : cover.entries) : digestIndex (cover.entryDigest entry) = index := + (cover.entryDigest_spec entry).2.2.1.symm + +theorem honestFtsSignAt_index_leaves_unique {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} {leftIndex rightIndex : Index} + {leftLeaves rightLeaves : DigestTree → FtsLeaf} + (hleft : HonestFtsSignAt f cache secretKey message signature leftIndex leftLeaves) + (hright : HonestFtsSignAt f cache secretKey message signature rightIndex rightLeaves) : + leftIndex = rightIndex ∧ leftLeaves = rightLeaves := by + have heq := hleft.1.2.1.symm.trans hright.1.2.1 + exact Prod.mk.inj (Option.some.inj heq) + +theorem successfulSignRun_signature_eq {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {leftMessage rightMessage : Message} {leftSignature rightSignature : Signature} + (hleft : SuccessfulSignRun f cache secretKey leftMessage leftSignature) + (hright : SuccessfulSignRun f cache secretKey rightMessage rightSignature) + (hmessage : leftMessage = rightMessage) + (hrandomness : leftSignature.randomness = rightSignature.randomness) : + leftSignature = rightSignature := by + obtain ⟨leftIndex, leftLeaves, leftParts, leftDigest, leftSecret, leftPath, leftCounter, + leftValues, leftAuth, _, leftLayers, _⟩ := hleft + obtain ⟨rightIndex, rightLeaves, rightParts, rightDigest, rightSecret, rightPath, rightCounter, + rightValues, rightAuth, _, rightLayers, _⟩ := hright + have hdigestEval := leftDigest.2.1 + rw [hmessage, hrandomness] at hdigestEval + have hindexLeaves := Prod.mk.inj (Option.some.inj (hdigestEval.symm.trans rightDigest.2.1)) + have hparts : leftParts = rightParts := by + funext lay + have heval := leftLayers lay + rw [hindexLeaves.1] at heval + exact Option.some.inj (heval.symm.trans (rightLayers lay)) + have hsecret : leftSignature.ftsSecret = rightSignature.ftsSecret := by + rw [leftSecret, rightSecret, hindexLeaves.1, hindexLeaves.2] + have hpath : leftSignature.ftsPath = rightSignature.ftsPath := by + rw [leftPath, rightPath, hindexLeaves.1, hindexLeaves.2] + have hcounter : leftSignature.counter = rightSignature.counter := by + rw [leftCounter, rightCounter, hparts] + have hvalues : leftSignature.chainValue = rightSignature.chainValue := by + rw [leftValues, rightValues, hparts] + have hauth : leftSignature.authPath = rightSignature.authPath := by + rw [leftAuth, rightAuth, hparts] + change Signature.mk leftSignature.randomness leftSignature.ftsSecret leftSignature.ftsPath + leftSignature.counter leftSignature.chainValue leftSignature.authPath = + Signature.mk rightSignature.randomness rightSignature.ftsSecret rightSignature.ftsPath + rightSignature.counter rightSignature.chainValue rightSignature.authPath + rw [Signature.mk.injEq] + exact ⟨hrandomness, hsecret, hpath, hcounter, hvalues, hauth⟩ + +theorem FtsCoverAt.signature_eq_of_flat_entry_eq {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} {leftTree rightTree : FtsTree} + (left : FtsCoverAt f cache secretKey signingLog index targetLeaves leftTree) + (right : FtsCoverAt f cache secretKey signingLog index targetLeaves rightTree) + (hentry : left.entry.flat = right.entry.flat) : left.signature = right.signature := by + have hresponse := congrArg Prod.snd hentry + exact Option.some.inj (left.response_eq.symm.trans (hresponse.trans right.response_eq)) + +theorem FtsCoverAt.signedLeaves_eq_of_flat_entry_eq {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} {leftTree rightTree : FtsTree} + (left : FtsCoverAt f cache secretKey signingLog index targetLeaves leftTree) + (right : FtsCoverAt f cache secretKey signingLog index targetLeaves rightTree) + (hentry : left.entry.flat = right.entry.flat) : + left.signedLeaves = right.signedLeaves := by + have hmessage := congrArg Prod.fst hentry + have hsignature := left.signature_eq_of_flat_entry_eq right hentry + change left.entry.1 = right.entry.1 at hmessage + have heval := left.honest.1.2.1 + rw [hmessage, hsignature] at heval + have hpairs := Option.some.inj (heval.symm.trans right.honest.1.2.1) + exact (Prod.mk.inj hpairs).2 + +theorem FtsCoverAt.bottom_ots_eq {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} {leftTree rightTree : FtsTree} + (left : FtsCoverAt f cache secretKey signingLog index targetLeaves leftTree) + (right : FtsCoverAt f cache secretKey signingLog index targetLeaves rightTree) : + left.signature.counter bottomLayer = right.signature.counter bottomLayer + ∧ left.signature.chainValue bottomLayer = right.signature.chainValue bottomLayer := by + obtain ⟨leftPart, hleftEval, hleftCounter, hleftValues⟩ := + left.successful.signature_part_of_digest left.honest.1 bottomLayer + obtain ⟨rightPart, hrightEval, hrightCounter, hrightValues⟩ := + right.successful.signature_part_of_digest right.honest.1 bottomLayer + have hpart : leftPart = rightPart := Option.some.inj (hleftEval.symm.trans hrightEval) + subst rightPart + exact ⟨hleftCounter.trans hrightCounter.symm, hleftValues.trans hrightValues.symm⟩ + +theorem FtsCoverAt.flat_entry_eq_of_digest_input_eq {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} {leftTree rightTree : FtsTree} + (left : FtsCoverAt f cache secretKey signingLog index targetLeaves leftTree) + (right : FtsCoverAt f cache secretKey signingLog index targetLeaves rightTree) + (hinput : tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root left.entry.1 left.signature.randomness) + = tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root right.entry.1 right.signature.randomness)) : + left.entry.flat = right.entry.flat := by + have hpayload := (tweakableHashInput_injective secretKey.parameter (by trivial) (by trivial) + hinput).2 + obtain ⟨hmessage, hrandomness⟩ := messageDigestPayload_injective secretKey.root hpayload + have hsignature := successfulSignRun_signature_eq left.successful right.successful + hmessage hrandomness + apply Prod.ext + · exact hmessage + · simpa only [SigningEntry.flat] using left.response_eq.trans + ((congrArg some hsignature).trans right.response_eq.symm) + +theorem FtsCoverAt.digest_input_ne_of_flat_entry_ne {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} {leftTree rightTree : FtsTree} + (left : FtsCoverAt f cache secretKey signingLog index targetLeaves leftTree) + (right : FtsCoverAt f cache secretKey signingLog index targetLeaves rightTree) + (hentry : left.entry.flat ≠ right.entry.flat) : + tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root left.entry.1 left.signature.randomness) + ≠ tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root right.entry.1 right.signature.randomness) := by + intro hinput + exact hentry (left.flat_entry_eq_of_digest_input_eq right hinput) + +theorem FewTimeCover.entryDigest_assigned_leaf {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) (tree : FtsTree) : + digestLeaves (cover.entryDigest (cover.entryAssignment tree)) (ftsIndexOf tree) = + targetLeaves (ftsIndexOf tree) := by + let representative := cover.select + (cover.representativeTree (cover.entryAssignment tree)) + have hflat : representative.entry.flat = (cover.select tree).entry.flat := + cover.representativeTree_spec (cover.entryAssignment tree) + have hleaves := representative.signedLeaves_eq_of_flat_entry_eq (cover.select tree) hflat + rw [← (cover.entryDigest_spec (cover.entryAssignment tree)).2.2.2] + rw [congrFun hleaves (ftsIndexOf tree), (cover.select tree).leaf_eq] + +theorem FewTimeCover.entryDigestInput_injective {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) : + Function.Injective cover.entryDigestInput := by + intro left right hinput + let leftSelected := cover.select (cover.representativeTree left) + let rightSelected := cover.select (cover.representativeTree right) + have hflat : leftSelected.entry.flat = rightSelected.entry.flat := + leftSelected.flat_entry_eq_of_digest_input_eq rightSelected hinput + apply Subtype.ext + rw [← cover.representativeTree_spec left, ← cover.representativeTree_spec right] + exact hflat + +theorem digestTree_eq_ftsIndexOf_or_last (tree : DigestTree) : + (∃ ftsTree : FtsTree, tree = ftsIndexOf ftsTree) ∨ tree = lastDigestTree := by + by_cases htree : tree.val < ftsTrees - 1 + · left + let ftsTree : FtsTree := ⟨tree.val, htree⟩ + refine ⟨ftsTree, Fin.ext ?_⟩ + rfl + · right + apply Fin.ext + change tree.val = 14 + change ¬ tree.val < 14 at htree + have hlt := tree.isLt + change tree.val < 15 at hlt + omega + +theorem HonestFtsSignAt.last_leaf_eq_zero {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} {index : Index} {leaves : DigestTree → FtsLeaf} + (hhonest : HonestFtsSignAt f cache secretKey message signature index leaves) : + leaves lastDigestTree = 0 := by + obtain ⟨_, digest, _, hadmissible, _, hleaves, _⟩ := hhonest.1.extract + rw [hleaves, hadmissible] + +theorem ProperFewTimeLeak.forged_digest_input_ne_entryDigestInput + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (hproper : ProperFewTimeLeak f cache secretKey signingLog index targetLeaves) + (forgery : Forgery) (forgedDigest : MessageDigest) + (hforgedDigest : evalWithAnswerFn f + (messageDigest secretKey.parameter secretKey.root forgery.message + forgery.signature.randomness) = forgedDigest) + (hleaves : targetLeaves = digestLeaves forgedDigest) + (entry : hproper.1.cover.entries) : + tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root forgery.message forgery.signature.randomness) + ≠ hproper.1.cover.entryDigestInput entry := by + intro hinput + let cover := hproper.1.cover + let selected := cover.select (cover.representativeTree entry) + have hpayload := (tweakableHashInput_injective secretKey.parameter (by trivial) (by trivial) + hinput).2 + obtain ⟨hmessage, hrandomness⟩ := messageDigestPayload_injective secretKey.root hpayload + have hdigest : cover.entryDigest entry = forgedDigest := by + have hentryDigest := (cover.entryDigest_spec entry).1 + rw [hmessage, hrandomness] at hforgedDigest + exact hentryDigest.symm.trans hforgedDigest + have hsignedLeaves : selected.signedLeaves = targetLeaves := by + calc + selected.signedLeaves = digestLeaves (cover.entryDigest entry) := + (cover.entryDigest_spec entry).2.2.2 + _ = digestLeaves forgedDigest := by rw [hdigest] + _ = targetLeaves := hleaves.symm + apply hproper.2 selected.entry selected.signature selected.entry_mem selected.response_eq + selected.successful + simpa only [hsignedLeaves] using selected.honest + +theorem ProperFewTimeLeak.two_le_cover_entries_card {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (hproper : ProperFewTimeLeak f cache secretKey signingLog index targetLeaves) + (htargetLast : targetLeaves lastDigestTree = 0) : + 2 ≤ hproper.1.cover.entries.card := by + classical + let cover := hproper.1.cover + change 2 ≤ cover.entries.card + by_contra hcard + have hcardOne : cover.entries.card = 1 := by + have hpos := cover.entries_card_pos + omega + let baseTree : FtsTree := ⟨0, by decide⟩ + let base := cover.select baseTree + have hentryEq : ∀ tree, (cover.select tree).entry.flat = base.entry.flat := by + intro tree + apply Finset.card_le_one_iff.1 (Nat.le_of_eq hcardOne) + · exact cover.entry_mem_entries tree + · exact cover.entry_mem_entries baseTree + have hleaves : base.signedLeaves = targetLeaves := by + funext digestTree + rcases digestTree_eq_ftsIndexOf_or_last digestTree with ⟨tree, rfl⟩ | rfl + · have hselected := + (cover.select tree).signedLeaves_eq_of_flat_entry_eq base (hentryEq tree) + rw [← (cover.select tree).leaf_eq] + exact congrFun hselected (ftsIndexOf tree) |>.symm + · exact base.honest.last_leaf_eq_zero.trans htargetLast.symm + have hhonest : HonestFtsSignAt f cache secretKey base.entry.1 base.signature index + targetLeaves := by + simpa only [hleaves] using base.honest + exact hproper.2 base.entry base.signature base.entry_mem base.response_eq base.successful hhonest + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FirstBad.lean b/formal/sphincs/SphincsSecurity/Proof/FirstBad.lean new file mode 100644 index 00000000..1f8ae697 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FirstBad.lean @@ -0,0 +1,132 @@ +import SphincsSecurity.Proof.Execution + +/-! +# First creation of a monotone cache event + +A cache property cannot change on a uniform query or a cached hash query. If a supported run starts +without the property and ends with it, one fresh random-oracle transition is therefore its first +creation point. The witness retains the cache inclusions on both sides of that transition. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +def FreshBadStep (Bad : QueryCache HashSpec → Prop) + (initialCache finalCache : QueryCache HashSpec) : Prop := + ∃ (cache : QueryCache HashSpec) (input : HashInput) (answer : HashOutput), + initialCache ≤ cache + ∧ ¬ Bad cache + ∧ cache input = none + ∧ Bad (cache.cacheQuery input answer) + ∧ cache.cacheQuery input answer ≤ finalCache + +theorem finite_cache_of_mem_support {alpha : Type} + (oa : OracleComp OracleWorld alpha) + (initialCache : QueryCache HashSpec) (result : alpha) + (finalCache : QueryCache HashSpec) + (hrun : (result, finalCache) ∈ support ((simulateQ romImpl oa).run initialCache)) + (hfinite : Finite initialCache) : Finite finalCache := by + induction oa using OracleComp.inductionOn generalizing initialCache result finalCache with + | pure value => + simp only [simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq] at hrun + obtain ⟨rfl, rfl⟩ := hrun + exact hfinite + | query_bind query next ih => + simp only [simulateQ_query_bind, StateT.run_bind, mem_support_bind_iff] at hrun + obtain ⟨⟨answer, middleCache⟩, hquery, hrest⟩ := hrun + apply ih answer middleCache result finalCache hrest + cases query with + | inl uniformInput => + change (answer, middleCache) ∈ support + (((unifFwdImpl HashSpec) uniformInput).run initialCache) at hquery + have hrunUniform : + ((unifFwdImpl HashSpec) uniformInput).run initialCache = + (fun sample => (sample, initialCache)) <$> + (liftM (unifSpec.query uniformInput) : ProbComp _) := by + simpa [simulateQ_query] using + (unifFwdImpl.simulateQ_run + (hashSpec := HashSpec) + (liftM (unifSpec.query uniformInput) : ProbComp _) initialCache) + rw [hrunUniform, support_map] at hquery + obtain ⟨sample, hsample, heq⟩ := hquery + obtain ⟨rfl, rfl⟩ := heq + exact hfinite + | inr input => + change HashOutput at answer + change (answer, middleCache) ∈ support + (((randomOracle : QueryImpl HashSpec _) input).run initialCache) at hquery + cases hcached : initialCache input with + | some cachedAnswer => + rw [QueryImpl.withCaching_run_some uniformSampleImpl hcached, + support_pure, Set.mem_singleton_iff] at hquery + obtain ⟨rfl, rfl⟩ := hquery + exact hfinite + | none => + rw [QueryImpl.withCaching_run_none uniformSampleImpl hcached, support_map] at hquery + obtain ⟨freshAnswer, hfresh, heq⟩ := hquery + obtain ⟨rfl, rfl⟩ := heq + exact finite_cacheQuery hfinite input answer + +theorem freshBadStep_of_mem_support {alpha : Type} + (Bad : QueryCache HashSpec → Prop) (oa : OracleComp OracleWorld alpha) + (initialCache : QueryCache HashSpec) (result : alpha) + (finalCache : QueryCache HashSpec) + (hrun : (result, finalCache) ∈ support ((simulateQ romImpl oa).run initialCache)) + (hclean : ¬ Bad initialCache) (hbad : Bad finalCache) : + FreshBadStep Bad initialCache finalCache := by + classical + induction oa using OracleComp.inductionOn generalizing initialCache result finalCache with + | pure value => + simp only [simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq] at hrun + obtain ⟨rfl, rfl⟩ := hrun + exact (hclean hbad).elim + | query_bind query next ih => + simp only [simulateQ_query_bind, StateT.run_bind, mem_support_bind_iff] at hrun + obtain ⟨⟨answer, middleCache⟩, hquery, hrest⟩ := hrun + cases query with + | inl uniformInput => + change (answer, middleCache) ∈ support + (((unifFwdImpl HashSpec) uniformInput).run initialCache) at hquery + have hrunUniform : + ((unifFwdImpl HashSpec) uniformInput).run initialCache = + (fun sample => (sample, initialCache)) <$> + (liftM (unifSpec.query uniformInput) : ProbComp _) := by + simpa [simulateQ_query] using + (unifFwdImpl.simulateQ_run + (hashSpec := HashSpec) + (liftM (unifSpec.query uniformInput) : ProbComp _) initialCache) + rw [hrunUniform, support_map] at hquery + obtain ⟨sample, hsample, heq⟩ := hquery + obtain ⟨rfl, rfl⟩ := heq + exact ih answer initialCache result finalCache hrest hclean hbad + | inr input => + change HashOutput at answer + change (answer, middleCache) ∈ support + (((randomOracle : QueryImpl HashSpec _) input).run initialCache) at hquery + cases hcached : initialCache input with + | some cachedAnswer => + rw [QueryImpl.withCaching_run_some uniformSampleImpl hcached, + support_pure, Set.mem_singleton_iff] at hquery + obtain ⟨rfl, rfl⟩ := hquery + exact ih answer initialCache result finalCache hrest hclean hbad + | none => + rw [QueryImpl.withCaching_run_none uniformSampleImpl hcached, support_map] at hquery + obtain ⟨freshAnswer, hfresh, heq⟩ := hquery + obtain ⟨rfl, rfl⟩ := heq + by_cases hmiddleBad : Bad (initialCache.cacheQuery input answer) + · exact ⟨initialCache, input, answer, le_rfl, hclean, hcached, + hmiddleBad, + simulateQ_romImpl_cache_le (next answer) + (initialCache.cacheQuery input answer) (result, finalCache) hrest⟩ + · obtain ⟨cache, laterInput, laterAnswer, hprefix, hlaterClean, + hlaterUncached, hlaterBad, hsuffix⟩ := + ih answer (initialCache.cacheQuery input answer) result finalCache + hrest hmiddleBad hbad + exact ⟨cache, laterInput, laterAnswer, + (le_cacheQuery hcached).trans hprefix, hlaterClean, hlaterUncached, + hlaterBad, hsuffix⟩ + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/ForgeryClassify.lean b/formal/sphincs/SphincsSecurity/Proof/ForgeryClassify.lean new file mode 100644 index 00000000..e9ee91a6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/ForgeryClassify.lean @@ -0,0 +1,451 @@ +import SphincsSecurity.Proof.FewTimeCompare + +/-! +# Classifying an accepted forgery + +Descent through the three hypertree layers stops at a bad cache, at a one-time position not covered +exactly by the signing transcript, or at an honest few-time opening. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +def LayerObstacle (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) : Prop := + ∃ (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) + (counter : Counter) (values : ChainIndex → Digest) (path : Nat → Digest), + HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay tree leafIdx message counter + values path + ∧ CachedRun cache f (otsLeaf secretKey.parameter lay tree leafIdx message counter values) + ∧ (¬ SignedLayerAt f cache secretKey signingLog lay tree leafIdx + ∨ LayerComparisonFailure f cache secretKey signingLog lay tree leafIdx message counter) + +def VerifierLayerMessage (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (index : Index) (leaves : DigestTree → FtsLeaf) (signature : Signature) + (lay : Layer) (message : Digest) : Prop := + let ftsPublicKey := evalWithAnswerFn f + (ftsRecover parameter index leaves signature.ftsSecret signature.ftsPath) + ∃ bottomLeaf, + evalWithAnswerFn f (otsLeaf parameter bottomLayer (treeIndexAt index bottomLayer) + (leafIndexAt index bottomLayer) ftsPublicKey (signature.counter bottomLayer) + (signature.chainValue bottomLayer)) = some bottomLeaf + ∧ let middleMessage := foldValue f parameter bottomLayer + (treeIndexAt index bottomLayer) (leafIndexAt index bottomLayer) + (signaturePath signature bottomLayer) bottomLeaf (layerHeight bottomLayer) + ∃ middleLeaf, + evalWithAnswerFn f (otsLeaf parameter middleLayer (treeIndexAt index middleLayer) + (leafIndexAt index middleLayer) middleMessage (signature.counter middleLayer) + (signature.chainValue middleLayer)) = some middleLeaf + ∧ let topMessage := foldValue f parameter middleLayer + (treeIndexAt index middleLayer) (leafIndexAt index middleLayer) + (signaturePath signature middleLayer) middleLeaf (layerHeight middleLayer) + (lay = bottomLayer ∧ message = ftsPublicKey) + ∨ (lay = middleLayer ∧ message = middleMessage) + ∨ (lay = topLayer ∧ message = topMessage) + +def ForgedLayerObstacle (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (index : Index) + (leaves : DigestTree → FtsLeaf) (signature : Signature) : Prop := + ∃ (lay : Layer) (message : Digest), + VerifierLayerMessage f secretKey.parameter index leaves signature lay message + ∧ HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay + (treeIndexAt index lay) (leafIndexAt index lay) message (signature.counter lay) + (signature.chainValue lay) (signaturePath signature lay) + ∧ CachedRun cache f (otsLeaf secretKey.parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message (signature.counter lay) (signature.chainValue lay)) + ∧ (¬ SignedLayerAt f cache secretKey signingLog lay + (treeIndexAt index lay) (leafIndexAt index lay) + ∨ LayerComparisonFailure f cache secretKey signingLog lay + (treeIndexAt index lay) (leafIndexAt index lay) message (signature.counter lay)) + +def LayerRootSettled (cache : QueryCache HashSpec) (secretKey : SecretKey) + (lay : Layer) (tree : TreeIndex) : Prop := + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (.node lay tree ⟨layerHeight lay - 1, by + have hpos : 0 < layerHeight lay := by + unfold layerHeight + split <;> norm_num [maxLayerHeight] + have hle := layerHeight_le lay + omega⟩ ⟨0, by positivity⟩) + +def SettledForgedLayerObstacle (f : QueryImpl HashSpec Id) + (cache : QueryCache HashSpec) (secretKey : SecretKey) + (signingLog : QueryLog SigningSpec) (index : Index) + (leaves : DigestTree → FtsLeaf) (signature : Signature) : Prop := + ∃ (lay : Layer) (message : Digest), + LayerRootSettled cache secretKey lay (treeIndexAt index lay) + ∧ VerifierLayerMessage f secretKey.parameter index leaves signature lay message + ∧ HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay + (treeIndexAt index lay) (leafIndexAt index lay) message (signature.counter lay) + (signature.chainValue lay) (signaturePath signature lay) + ∧ CachedRun cache f (otsLeaf secretKey.parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message (signature.counter lay) (signature.chainValue lay)) + ∧ (¬ SignedLayerAt f cache secretKey signingLog lay + (treeIndexAt index lay) (leafIndexAt index lay) + ∨ LayerComparisonFailure f cache secretKey signingLog lay + (treeIndexAt index lay) (leafIndexAt index lay) message (signature.counter lay)) + +theorem SettledForgedLayerObstacle.toForgedLayerObstacle + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} {index : Index} + {leaves : DigestTree → FtsLeaf} {signature : Signature} + (hobstacle : SettledForgedLayerObstacle f cache secretKey signingLog index leaves signature) : + ForgedLayerObstacle f cache secretKey signingLog index leaves signature := by + obtain ⟨lay, message, _, hverifier, hopening, hcached, hfailure⟩ := hobstacle + exact ⟨lay, message, hverifier, hopening, hcached, hfailure⟩ + +theorem ForgedLayerObstacle.toLayerObstacle + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} {index : Index} + {leaves : DigestTree → FtsLeaf} {signature : Signature} + (hobstacle : ForgedLayerObstacle f cache secretKey signingLog index leaves signature) : + LayerObstacle f cache secretKey signingLog := by + obtain ⟨lay, message, _, hopening, hcached, hfailure⟩ := hobstacle + exact ⟨lay, treeIndexAt index lay, leafIndexAt index lay, message, + signature.counter lay, signature.chainValue lay, signaturePath signature lay, + hopening, hcached, hfailure⟩ + +def UncoveredFtsSecret (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (index : Index) + (leaves : DigestTree → FtsLeaf) (secrets : FtsTree → Digest) : Prop := + ∃ tree, ¬ SignedFtsLeaf f cache secretKey signingLog index tree (leaves (ftsIndexOf tree)) + ∧ secrets tree = secretKey.ftsSecret index tree (leaves (ftsIndexOf tree)) + ∧ cache (tweakableHashInput secretKey.parameter + (.ftsLeaf index tree (leaves (ftsIndexOf tree))) (digestBytes (secrets tree))) ≠ none + +def FullyHonestOpening (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (index : Index) (leaves : DigestTree → FtsLeaf) + (signature : Signature) : Prop := + (∀ lay, HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay + (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f (layerMessage secretKey index lay)) (signature.counter lay) + (signature.chainValue lay) (signaturePath signature lay) + ∧ CachedRun cache f (otsLeaf secretKey.parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) (evalWithAnswerFn f (layerMessage secretKey index lay)) + (signature.counter lay) (signature.chainValue lay))) + ∧ (∀ tree, + signature.ftsSecret tree = secretKey.ftsSecret index tree (leaves (ftsIndexOf tree)) + ∧ ∀ level (hlevel : level < ftsTreeHeight), signature.ftsPath tree ⟨level, hlevel⟩ + = honestFtsNode f secretKey.parameter index tree (secretKey.ftsSecret index tree) level + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level) 1)) + ∧ CachedRun cache f + (ftsRecover secretKey.parameter index leaves signature.ftsSecret signature.ftsPath) + ∧ ∀ lay, VerifierLayerMessage f secretKey.parameter index leaves signature lay + (evalWithAnswerFn f (layerMessage secretKey index lay)) + +def SettledFullyHonestOpening (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (index : Index) (leaves : DigestTree → FtsLeaf) + (signature : Signature) : Prop := + FullyHonestOpening f cache secretKey index leaves signature ∧ + ∀ lay, LayerRootSettled cache secretKey lay (treeIndexAt index lay) + +theorem SettledFullyHonestOpening.settleObstacle + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} {leaves : DigestTree → FtsLeaf} + {signature : Signature} + (hfull : SettledFullyHonestOpening f cache secretKey index leaves signature) + (hobstacle : ForgedLayerObstacle f cache secretKey signingLog index leaves signature) : + SettledForgedLayerObstacle f cache secretKey signingLog index leaves signature := by + obtain ⟨lay, message, hverifier, hopening, hcached, hfailure⟩ := hobstacle + exact ⟨lay, message, hfull.2 lay, hverifier, hopening, hcached, hfailure⟩ + +theorem middleTree_eq_of_top_position_eq (leftIndex rightIndex : Index) + (htree : treeIndexAt leftIndex topLayer = treeIndexAt rightIndex topLayer) + (hleaf : leafIndexAt leftIndex topLayer = leafIndexAt rightIndex topLayer) : + treeIndexAt leftIndex middleLayer = treeIndexAt rightIndex middleLayer := by + apply Fin.ext + rw [layers_link_top leftIndex, layers_link_top rightIndex, congrArg Fin.val htree, + congrArg Fin.val hleaf] + +theorem bottomTree_eq_of_middle_position_eq (leftIndex rightIndex : Index) + (htree : treeIndexAt leftIndex middleLayer = treeIndexAt rightIndex middleLayer) + (hleaf : leafIndexAt leftIndex middleLayer = leafIndexAt rightIndex middleLayer) : + treeIndexAt leftIndex bottomLayer = treeIndexAt rightIndex bottomLayer := by + apply Fin.ext + rw [layers_link_middle leftIndex, layers_link_middle rightIndex, congrArg Fin.val htree, + congrArg Fin.val hleaf] + +theorem exact_top_message_eq_middle_root (f : QueryImpl HashSpec Id) (secretKey : SecretKey) + (signedIndex forgedIndex : Index) (message : Digest) + (htree : treeIndexAt signedIndex topLayer = treeIndexAt forgedIndex topLayer) + (hleaf : leafIndexAt signedIndex topLayer = leafIndexAt forgedIndex topLayer) + (hmessage : evalWithAnswerFn f (layerMessage secretKey signedIndex topLayer) = message) : + message = honestNode f secretKey.parameter middleLayer + (treeIndexAt forgedIndex middleLayer) + (secretKey.otsSecret middleLayer (treeIndexAt forgedIndex middleLayer)) + (layerHeight middleLayer) 0 := by + have hnext := middleTree_eq_of_top_position_eq signedIndex forgedIndex htree hleaf + rw [← hmessage, layerMessage_of_lt secretKey signedIndex topLayer (by decide)] + simp only [show (⟨topLayer.val + 1, by decide⟩ : Layer) = middleLayer from rfl, hnext] + change evalWithAnswerFn f (treeNode secretKey.parameter middleLayer + (treeIndexAt forgedIndex middleLayer) + (secretKey.otsSecret middleLayer (treeIndexAt forgedIndex middleLayer)) + (layerHeight middleLayer) 0) = _ + rfl + +theorem exact_middle_message_eq_bottom_root (f : QueryImpl HashSpec Id) (secretKey : SecretKey) + (signedIndex forgedIndex : Index) (message : Digest) + (htree : treeIndexAt signedIndex middleLayer = treeIndexAt forgedIndex middleLayer) + (hleaf : leafIndexAt signedIndex middleLayer = leafIndexAt forgedIndex middleLayer) + (hmessage : evalWithAnswerFn f (layerMessage secretKey signedIndex middleLayer) = message) : + message = honestNode f secretKey.parameter bottomLayer + (treeIndexAt forgedIndex bottomLayer) + (secretKey.otsSecret bottomLayer (treeIndexAt forgedIndex bottomLayer)) + (layerHeight bottomLayer) 0 := by + have hnext := bottomTree_eq_of_middle_position_eq signedIndex forgedIndex htree hleaf + rw [← hmessage, layerMessage_of_lt secretKey signedIndex middleLayer (by decide)] + simp only [show (⟨middleLayer.val + 1, by decide⟩ : Layer) = bottomLayer from rfl, hnext] + change evalWithAnswerFn f (treeNode secretKey.parameter bottomLayer + (treeIndexAt forgedIndex bottomLayer) + (secretKey.otsSecret bottomLayer (treeIndexAt forgedIndex bottomLayer)) + (layerHeight bottomLayer) 0) = _ + rfl + +theorem exact_bottom_message_eq_fts_key (f : QueryImpl HashSpec Id) (secretKey : SecretKey) + (signedIndex forgedIndex : Index) (message : Digest) + (htree : treeIndexAt signedIndex bottomLayer = treeIndexAt forgedIndex bottomLayer) + (hleaf : leafIndexAt signedIndex bottomLayer = leafIndexAt forgedIndex bottomLayer) + (hmessage : evalWithAnswerFn f (layerMessage secretKey signedIndex bottomLayer) = message) : + message = honestFtsKey f secretKey.parameter forgedIndex (secretKey.ftsSecret forgedIndex) := by + have hindex := index_eq_of_bottom_position_eq htree hleaf + subst signedIndex + rw [← hmessage, layerMessage_bottomLayer] + rfl + +theorem accepted_forgery_classify (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (index : Index) + (signature : Signature) (leaves : DigestTree → FtsLeaf) (ftsPublicKey root : Digest) + (hf : cache.AgreesWithFn f) + (hftsPublicKey : evalWithAnswerFn f + (ftsRecover secretKey.parameter index leaves signature.ftsSecret signature.ftsPath) + = ftsPublicKey) + (htop : HypertreeTopOpening f cache secretKey.parameter secretKey.otsSecret index signature + ftsPublicKey root) + (htopSettled : LayerRootSettled cache secretKey topLayer + (treeIndexAt index topLayer)) + (hftsRun : CachedRun cache f + (ftsRecover secretKey.parameter index leaves signature.ftsSecret signature.ftsPath)) : + Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + ∨ SettledForgedLayerObstacle f cache secretKey signingLog index leaves signature + ∨ SettledFullyHonestOpening f cache secretKey index leaves signature := by + obtain ⟨bottomLeaf, hbottom, middleLeaf, hmiddle, htopOpening, htopRun⟩ := htop + let middleMessage := foldValue f secretKey.parameter bottomLayer + (treeIndexAt index bottomLayer) (leafIndexAt index bottomLayer) + (signaturePath signature bottomLayer) bottomLeaf (layerHeight bottomLayer) + let topMessage := foldValue f secretKey.parameter middleLayer + (treeIndexAt index middleLayer) (leafIndexAt index middleLayer) + (signaturePath signature middleLayer) middleLeaf (layerHeight middleLayer) + have hverifierBottom : VerifierLayerMessage f secretKey.parameter index leaves signature + bottomLayer ftsPublicKey := by + simp only [VerifierLayerMessage, hftsPublicKey] + exact ⟨bottomLeaf, hbottom.1, middleLeaf, hmiddle.1, Or.inl ⟨trivial, trivial⟩⟩ + have hverifierMiddle : VerifierLayerMessage f secretKey.parameter index leaves signature + middleLayer middleMessage := by + simp only [VerifierLayerMessage, hftsPublicKey] + exact ⟨bottomLeaf, hbottom.1, middleLeaf, hmiddle.1, + Or.inr (Or.inl ⟨trivial, rfl⟩)⟩ + have hverifierTop : VerifierLayerMessage f secretKey.parameter index leaves signature + topLayer topMessage := by + simp only [VerifierLayerMessage, hftsPublicKey] + exact ⟨bottomLeaf, hbottom.1, middleLeaf, hmiddle.1, + Or.inr (Or.inr ⟨trivial, rfl⟩)⟩ + by_cases hsignedTop : SignedLayerAt f cache secretKey signingLog topLayer + (treeIndexAt index topLayer) (leafIndexAt index topLayer) + · rcases hsignedTop.exact_or_failure topMessage (signature.counter topLayer) + (signature.chainValue topLayer) (signaturePath signature topLayer) htopOpening with + ⟨_, _, signedTopIndex, _, _, _, _, _, htopTree, htopLeaf, htopMessage, _⟩ | hfailure + · have hmiddleRoot := exact_top_message_eq_middle_root f secretKey signedTopIndex index + topMessage htopTree htopLeaf htopMessage + have htopEval : evalWithAnswerFn f (layerMessage secretKey index topLayer) = topMessage := by + rw [← htopMessage] + congr 1 + exact (layerMessage_eq_of_position_eq secretKey signedTopIndex index topLayer htopTree + htopLeaf).symm + have hmiddleSettled := hsignedTop.settles_middle hf + rcases layer_extract_from_settled_root_or_bad (ftsSecret := secretKey.ftsSecret) hf middleLayer + (treeIndexAt index middleLayer) (leafIndexAt index middleLayer) + (leafIndexAt_lt index middleLayer) middleMessage (signature.counter middleLayer) + (signature.chainValue middleLayer) (signaturePath signature middleLayer) middleLeaf + hmiddle.1 (by simpa only [topMessage] using hmiddleRoot) + hmiddle.2.2.1 hmiddle.2.2.2.1 hmiddleSettled with hbad | hmiddleOpening + · exact Or.inl hbad + · by_cases hsignedMiddle : SignedLayerAt f cache secretKey signingLog middleLayer + (treeIndexAt index middleLayer) (leafIndexAt index middleLayer) + · rcases hsignedMiddle.exact_or_failure middleMessage (signature.counter middleLayer) + (signature.chainValue middleLayer) (signaturePath signature middleLayer) + hmiddleOpening with + ⟨_, _, signedMiddleIndex, _, _, _, _, _, hmiddleTree, hmiddleLeaf, hmiddleMessage, _⟩ | + hfailure + · have hbottomRoot := exact_middle_message_eq_bottom_root f secretKey signedMiddleIndex index + middleMessage hmiddleTree hmiddleLeaf hmiddleMessage + have hmiddleEval : evalWithAnswerFn f (layerMessage secretKey index middleLayer) + = middleMessage := by + rw [← hmiddleMessage] + congr 1 + exact (layerMessage_eq_of_position_eq secretKey signedMiddleIndex index middleLayer + hmiddleTree hmiddleLeaf).symm + have hbottomSettled := hsignedMiddle.settles_bottom hf + rcases layer_extract_from_settled_root_or_bad (ftsSecret := secretKey.ftsSecret) hf + bottomLayer (treeIndexAt index bottomLayer) (leafIndexAt index bottomLayer) + (leafIndexAt_lt index bottomLayer) ftsPublicKey (signature.counter bottomLayer) + (signature.chainValue bottomLayer) (signaturePath signature bottomLayer) bottomLeaf + hbottom.1 (by simpa only [middleMessage] using hbottomRoot) + hbottom.2.2.1 hbottom.2.2.2.1 hbottomSettled with hbad | hbottomOpening + · exact Or.inl hbad + · by_cases hsignedBottom : SignedLayerAt f cache secretKey signingLog bottomLayer + (treeIndexAt index bottomLayer) (leafIndexAt index bottomLayer) + · rcases hsignedBottom.exact_or_failure ftsPublicKey (signature.counter bottomLayer) + (signature.chainValue bottomLayer) (signaturePath signature bottomLayer) + hbottomOpening with + ⟨_, _, signedBottomIndex, _, _, _, _, _, hbottomTree, hbottomLeaf, + hbottomMessage, _⟩ | hfailure + · have hftsKey := exact_bottom_message_eq_fts_key f secretKey signedBottomIndex index + ftsPublicKey hbottomTree hbottomLeaf hbottomMessage + have hbottomEval : evalWithAnswerFn f (layerMessage secretKey index bottomLayer) + = ftsPublicKey := by + rw [← hbottomMessage] + congr 1 + exact (layerMessage_eq_of_position_eq secretKey signedBottomIndex index + bottomLayer hbottomTree hbottomLeaf).symm + have hftsSettled := hsignedBottom.settles_fts hf + rcases ftsRecover_extract_from_settled_roots_or_bad hf index leaves + signature.ftsSecret signature.ftsPath (hftsPublicKey.trans hftsKey) hftsRun + hftsSettled with hbad | hhonest + · exact Or.inl hbad + · right + right + have htopOpening' : HonestLayerOpening f secretKey.parameter + secretKey.otsSecret topLayer (treeIndexAt index topLayer) + (leafIndexAt index topLayer) + (evalWithAnswerFn f (layerMessage secretKey index topLayer)) + (signature.counter topLayer) (signature.chainValue topLayer) + (signaturePath signature topLayer) := by + rw [htopEval] + exact htopOpening + have hmiddleOpening' : HonestLayerOpening f secretKey.parameter + secretKey.otsSecret middleLayer (treeIndexAt index middleLayer) + (leafIndexAt index middleLayer) + (evalWithAnswerFn f (layerMessage secretKey index middleLayer)) + (signature.counter middleLayer) (signature.chainValue middleLayer) + (signaturePath signature middleLayer) := by + rw [hmiddleEval] + exact hmiddleOpening + have hbottomOpening' : HonestLayerOpening f secretKey.parameter + secretKey.otsSecret bottomLayer (treeIndexAt index bottomLayer) + (leafIndexAt index bottomLayer) + (evalWithAnswerFn f (layerMessage secretKey index bottomLayer)) + (signature.counter bottomLayer) (signature.chainValue bottomLayer) + (signaturePath signature bottomLayer) := by + rw [hbottomEval] + exact hbottomOpening + have htopRun' : CachedRun cache f (otsLeaf secretKey.parameter topLayer + (treeIndexAt index topLayer) (leafIndexAt index topLayer) + (evalWithAnswerFn f (layerMessage secretKey index topLayer)) + (signature.counter topLayer) (signature.chainValue topLayer)) := by + rw [htopEval] + exact htopRun + have hmiddleRun' : CachedRun cache f (otsLeaf secretKey.parameter middleLayer + (treeIndexAt index middleLayer) (leafIndexAt index middleLayer) + (evalWithAnswerFn f (layerMessage secretKey index middleLayer)) + (signature.counter middleLayer) (signature.chainValue middleLayer)) := by + rw [hmiddleEval] + exact hmiddle.2.2.1 + have hbottomRun' : CachedRun cache f (otsLeaf secretKey.parameter bottomLayer + (treeIndexAt index bottomLayer) (leafIndexAt index bottomLayer) + (evalWithAnswerFn f (layerMessage secretKey index bottomLayer)) + (signature.counter bottomLayer) (signature.chainValue bottomLayer)) := by + rw [hbottomEval] + exact hbottom.2.2.1 + refine ⟨⟨?_, hhonest, hftsRun, ?_⟩, ?_⟩ + · intro lay + fin_cases lay + · exact ⟨by simpa only [topLayer] using htopOpening', by + simpa only [topLayer] using htopRun'⟩ + · exact ⟨by simpa only [middleLayer] using hmiddleOpening', by + simpa only [middleLayer] using hmiddleRun'⟩ + · exact ⟨by simpa only [bottomLayer, numLayers] using hbottomOpening', by + simpa only [bottomLayer, numLayers] using hbottomRun'⟩ + · intro lay + fin_cases lay + · rw [show (⟨0, by decide⟩ : Layer) = topLayer by rfl, htopEval] + exact hverifierTop + · rw [show (⟨1, by decide⟩ : Layer) = middleLayer by rfl, hmiddleEval] + exact hverifierMiddle + · rw [show (⟨2, by decide⟩ : Layer) = bottomLayer by rfl, hbottomEval] + exact hverifierBottom + · intro lay + fin_cases lay + · simpa only [topLayer] using htopSettled + · unfold LayerRootSettled + simpa only [middleLayer] using hmiddleSettled + · unfold LayerRootSettled + simpa only [bottomLayer, numLayers] using hbottomSettled + · exact Or.inr (Or.inl ⟨bottomLayer, ftsPublicKey, hbottomSettled, + hverifierBottom, hbottomOpening, hbottom.2.2.1, Or.inr hfailure⟩) + · exact Or.inr (Or.inl ⟨bottomLayer, ftsPublicKey, hbottomSettled, + hverifierBottom, hbottomOpening, hbottom.2.2.1, Or.inl hsignedBottom⟩) + · exact Or.inr (Or.inl ⟨middleLayer, middleMessage, hmiddleSettled, + hverifierMiddle, hmiddleOpening, hmiddle.2.2.1, Or.inr hfailure⟩) + · exact Or.inr (Or.inl ⟨middleLayer, middleMessage, hmiddleSettled, + hverifierMiddle, hmiddleOpening, hmiddle.2.2.1, Or.inl hsignedMiddle⟩) + · exact Or.inr (Or.inl ⟨topLayer, topMessage, htopSettled, hverifierTop, htopOpening, + htopRun, Or.inr hfailure⟩) + · exact Or.inr (Or.inl ⟨topLayer, topMessage, htopSettled, hverifierTop, htopOpening, + htopRun, Or.inl hsignedTop⟩) + +theorem winning_support_classify (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (finalCache : QueryCache HashSpec) + (hwin : (true, finalCache) ∈ support ((simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅)) : + Bad parameter otsSecret ftsSecret finalCache + ∨ ∃ root forgery signingLog f digest, + let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + finalCache.AgreesWithFn f + ∧ SigningTranscript.Valid signingLog + ∧ ¬ SigningTranscript.Contains signingLog forgery + ∧ evalWithAnswerFn f + (messageDigest parameter root forgery.message forgery.signature.randomness) = digest + ∧ Admissible digest + ∧ (LayerObstacle f finalCache secretKey signingLog + ∨ FewTimeLeak f finalCache secretKey signingLog (digestIndex digest) + (digestLeaves digest) + ∨ UncoveredFtsSecret f finalCache secretKey signingLog (digestIndex digest) + (digestLeaves digest) forgery.signature.ftsSecret) := by + obtain ⟨root, _, forgery, signingLog, _, _, _, _, hvalid, hnotContains, f, hf, _, _, _, _, + hrootSettled, + digest, hdigest, _, hadmissible, hftsRun, hresult⟩ := + winning_support_extract adversary parameter otsSecret ftsSecret finalCache hwin + rcases hresult with hbad | htop + · exact Or.inl hbad + · + let index := digestIndex digest + let leaves := digestLeaves digest + let ftsPublicKey := evalWithAnswerFn f + (ftsRecover parameter index leaves forgery.signature.ftsSecret forgery.signature.ftsPath) + have hclassified := accepted_forgery_classify f finalCache + (⟨parameter, root, otsSecret, ftsSecret⟩ : SecretKey) signingLog index forgery.signature leaves + ftsPublicKey root hf rfl htop (by + have htree : treeIndexAt index topLayer = rootTree := by + apply Fin.ext + exact treeIndexAt_topLayer index + unfold LayerRootSettled + rw [htree] + simpa using hrootSettled) hftsRun + rcases hclassified with hbad | hobstacle | hfts + · exact Or.inl hbad + · exact Or.inr ⟨root, forgery, signingLog, f, digest, hf, hvalid, hnotContains, hdigest, + hadmissible, Or.inl hobstacle.toForgedLayerObstacle.toLayerObstacle⟩ + · rcases fewTimeLeak_or_uncovered f finalCache + (⟨parameter, root, otsSecret, ftsSecret⟩ : SecretKey) signingLog index leaves with + hleak | ⟨tree, huncovered⟩ + · exact Or.inr ⟨root, forgery, signingLog, f, digest, hf, hvalid, hnotContains, hdigest, + hadmissible, Or.inr (Or.inl hleak)⟩ + · exact Or.inr ⟨root, forgery, signingLog, f, digest, hf, hvalid, hnotContains, hdigest, + hadmissible, Or.inr (Or.inr ⟨tree, huncovered, (hfts.1.2.1 tree).1, by + apply hftsRun + exact ftsRecover_leaf_query_mem f parameter index leaves forgery.signature.ftsSecret + forgery.signature.ftsPath tree⟩)⟩ + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeActualQueryCost.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeActualQueryCost.lean new file mode 100644 index 00000000..7547346b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeActualQueryCost.lean @@ -0,0 +1,39 @@ +import SphincsSecurity.Proof.FtsProbeCostComparison + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +theorem expected_actualRetained_cache_le_queryCharge (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (table : Coordinate → Digest) : + (∑' result, Pr[= result | actualRetainedGameAfterSecrets adversary parameter otsSecret table] * + (probeCachedInputs parameter result.2).ncard) ≤ + expectedQueryCharge (ftsHashQueryCharge parameter) + (gameAfterSecrets adversary parameter otsSecret (fun index tree leafIdx => table (index, tree, leafIdx))) ∅ := by + have hprojection := congrArg + (fun run : ProbComp RetainedGameLogResult => + ∑' result, Pr[= result | run] * (probeCachedInputs parameter result.2.1).ncard) + (gameAfterSecretsWithViewTrace_actualRetained_projection adversary parameter otsSecret table) + simp only [tsum_probOutput_map_mul] at hprojection + have hbound := expected_probeCachedInputs_le_queryCharge parameter + (gameAfterSecrets adversary parameter otsSecret (fun index tree leafIdx => table (index, tree, leafIdx))) + rw [← gameAfterSecretsWithViewTrace_verdictCache_projection, tsum_probOutput_map_mul] at hbound + exact hprojection.symm.le.trans hbound + +theorem sampledActualFtsCacheCount_le_queryCharge (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) : + sampledActualFtsCacheCount adversary parameter otsSecret ≤ + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + expectedQueryCharge (ftsHashQueryCharge parameter) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ := by + unfold sampledActualFtsCacheCount + rw [AdaptiveRevealProbe.expectedCost_congr _ _ _ + (evalDist_sampledConcreteActualRetainedFts_eq adversary parameter otsSecret).symm] + rw [sampledConcreteActualRetainedFts, tsum_probOutput_bind_mul] + simp only [tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + apply ENNReal.tsum_le_tsum + intro ftsSecret + exact mul_le_mul' le_rfl + (expected_actualRetained_cache_le_queryCharge adversary parameter otsSecret (curryFtsTableEquiv ftsSecret)) + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeAdversary.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeAdversary.lean new file mode 100644 index 00000000..8e693b2e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeAdversary.lean @@ -0,0 +1,1288 @@ +import SphincsSecurity.Proof.FtsProbeSigner +import SphincsSecurity.Proof.SecretProbeTerminal + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open OracleComp OracleSpec + +theorem tableHits_eq_false_of_addPending_eq_false + (state : AdaptiveRevealProbe.State Coordinate) (table : Coordinate → Digest) + (coordinate : Coordinate) (candidate : Digest) + (hclean : AdaptiveRevealProbe.tableHits + (state.addPending coordinate candidate) table = false) : + AdaptiveRevealProbe.tableHits state table = false := by + classical + unfold AdaptiveRevealProbe.tableHits at hclean ⊢ + simp only [decide_eq_false_iff_not] at hclean ⊢ + rintro ⟨other, hmem⟩ + apply hclean + refine ⟨other, ?_⟩ + by_cases heq : other = coordinate + · subst other + simp [AdaptiveRevealProbe.State.addPending, hmem] + · simpa [AdaptiveRevealProbe.State.addPending, Function.update_of_ne heq] using hmem + +theorem tableHits_eq_false_of_install_eq_false + (state : AdaptiveRevealProbe.State Coordinate) (table : Coordinate → Digest) + (coordinate : Coordinate) (value : Digest) + (hmiss : table coordinate ∉ state.pending coordinate) + (hclean : AdaptiveRevealProbe.tableHits + (state.install coordinate value) table = false) : + AdaptiveRevealProbe.tableHits state table = false := by + classical + unfold AdaptiveRevealProbe.tableHits at hclean ⊢ + simp only [decide_eq_false_iff_not] at hclean ⊢ + rintro ⟨other, hmem⟩ + by_cases heq : other = coordinate + · subst other + exact hmiss hmem + · apply hclean + refine ⟨other, ?_⟩ + simpa [AdaptiveRevealProbe.State.install, Function.update_of_ne heq] using hmem + +theorem tableHits_false_of_mem_runDetailed_done_false + (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (computation : OracleComp (AdaptiveRevealProbe.World Coordinate) alpha) + (value : alpha) + (hresult : .done false finalState value ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel computation)) : + AdaptiveRevealProbe.tableHits state table = false := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure result => + simp [AdaptiveRevealProbe.runDetailed] at hresult + exact hresult.1 + | query_bind input next ih => + cases input with + | uniform n => + rw [AdaptiveRevealProbe.runDetailed_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output state fuel hrest + | hashOutput => + rw [AdaptiveRevealProbe.runDetailed_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output state fuel hrest + | probe coordinate candidate => + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + cases hrevealed : state.revealed coordinate with + | some revealedValue => + exact ih () state remaining (by simpa [hrevealed] using hresult) + | none => + apply tableHits_eq_false_of_addPending_eq_false state table coordinate candidate + exact ih () (state.addPending coordinate candidate) remaining + (by simpa [hrevealed] using hresult) + | reveal coordinate => + rw [AdaptiveRevealProbe.runDetailed_reveal_query_bind] at hresult + cases hrevealed : state.revealed coordinate with + | some revealedValue => + exact ih revealedValue state fuel (by simpa [hrevealed] using hresult) + | none => + by_cases hhit : table coordinate ∈ state.pending coordinate + · simp [hrevealed, hhit] at hresult + · apply tableHits_eq_false_of_install_eq_false state table coordinate + (table coordinate) hhit + exact ih (table coordinate) + (state.install coordinate (table coordinate)) fuel + (by simpa [hrevealed, hhit] using hresult) + +theorem mem_support_runDetailed_bind_probeFree + (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (left : OracleComp (AdaptiveRevealProbe.World Coordinate) alpha) + (next : alpha → OracleComp (AdaptiveRevealProbe.World Coordinate) beta) + (hprobeFree : left.IsQueryBoundP AdaptiveRevealProbe.IsProbe 0) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (value : beta) + (hresult : .done false finalState value ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel (left >>= next))) : + ∃ leftState leftValue, + .done false leftState leftValue ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel left) ∧ + .done false finalState value ∈ support + (AdaptiveRevealProbe.runDetailed table leftState fuel (next leftValue)) := by + rw [AdaptiveRevealProbe.runDetailed_bind_probeFree table state fuel left next hprobeFree, + mem_support_bind_iff] at hresult + obtain ⟨leftResult, hleft, hnext⟩ := hresult + obtain ⟨leftState, leftValue, heq, hleftClean⟩ := + AdaptiveRevealProbe.runDetailed_probeFree_support table state fuel left hprobeFree hclean + leftResult hleft + subst leftResult + exact ⟨leftState, leftValue, hleft, hnext⟩ + +theorem CoupledAt.mem_support_ordinary + {parameter : PublicParameter} {table : Coordinate → Digest} + {state finalState : AdaptiveRevealProbe.State Coordinate} {fuel : Nat} + {masked : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha} + {ordinary : StateT (QueryCache HashSpec) ProbComp alpha} + {cache finalCache : SplitHashCache} {value : alpha} + (hcoupled : CoupledAt parameter table state fuel masked ordinary cache) + (hresult : .done false finalState (value, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel (masked.run cache))) : + (value, mergedCache parameter table finalCache) ∈ + support (ordinary.run (mergedCache parameter table cache)) := by + have hprojected : some (value, mergedCache parameter table finalCache) ∈ support + (projectDetailedCache parameter table <$> + AdaptiveRevealProbe.runDetailed table state fuel (masked.run cache)) := by + rw [support_map] + exact ⟨.done false finalState (value, finalCache), hresult, rfl⟩ + rw [hcoupled, support_map] at hprojected + obtain ⟨ordinaryResult, hordinary, heq⟩ := hprojected + exact Option.some.inj heq ▸ hordinary + +theorem probingHashQuery_done_false_mem_ordinary + (parameter : PublicParameter) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (input : HashInput) (output : HashOutput) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state cache) + (hresult : .done false finalState (output, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((probingHashQuery parameter input).run cache))) : + (output, mergedCache parameter table finalCache) ∈ support + ((randomOracle input).run (mergedCache parameter table cache)) := by + cases hdecode : decodeProbe? parameter input with + | none => + apply CoupledAt.mem_support_ordinary + (parameter := parameter) (table := table) (state := state) (fuel := fuel) + (masked := probingHashQuery parameter input) (ordinary := randomOracle input) + (cache := cache) (finalState := finalState) (finalCache := finalCache) + (value := output) + · exact runDetailed_probingHashQuery_decode_none parameter table state fuel cache input + hdecode hclean + · exact hresult + | some probe => + cases fuel with + | zero => + rw [probingHashQuery_run_eq, hdecode] at hresult + change .done false finalState (output, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state 0 + ((liftM (OracleSpec.query + (spec := AdaptiveRevealProbe.World Coordinate) + (.probe (probe.index, probe.tree, probe.leafIdx) probe.candidate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Unit) >>= fun _ => + (splitHashQuery (.ordinary input)).run cache)) at hresult + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind] at hresult + simp at hresult + | succ remaining => + cases hrevealed : state.revealed + (probe.index, probe.tree, probe.leafIdx) with + | none => + by_cases hhit : table (probe.index, probe.tree, probe.leafIdx) = probe.candidate + · have := runDetailed_probingHashQuery_hidden_hit parameter table state remaining + cache input probe hdecode hrevealed hhit + (.done false finalState (output, finalCache)) hresult + change false = true at this + simp at this + · apply CoupledAt.mem_support_ordinary + (parameter := parameter) (table := table) (state := state) + (fuel := remaining + 1) (masked := probingHashQuery parameter input) + (ordinary := randomOracle input) (cache := cache) + (finalState := finalState) (finalCache := finalCache) (value := output) + · exact runDetailed_probingHashQuery_hidden_miss parameter table state remaining + cache input probe hdecode hrevealed hclean hhit + · exact hresult + | some value => + by_cases hhit : table (probe.index, probe.tree, probe.leafIdx) = probe.candidate + · apply CoupledAt.mem_support_ordinary + (parameter := parameter) (table := table) (state := state) + (fuel := remaining + 1) (masked := probingHashQuery parameter input) + (ordinary := randomOracle input) (cache := cache) + (finalState := finalState) (finalCache := finalCache) (value := output) + · exact runDetailed_probingHashQuery_revealed_hit parameter table state remaining + cache input probe hdecode value hrevealed hclean hhit hsynced + · exact hresult + · apply CoupledAt.mem_support_ordinary + (parameter := parameter) (table := table) (state := state) + (fuel := remaining + 1) (masked := probingHashQuery parameter input) + (ordinary := randomOracle input) (cache := cache) + (finalState := finalState) (finalCache := finalCache) (value := output) + · exact runDetailed_probingHashQuery_revealed_miss parameter table state remaining + cache input probe hdecode value hrevealed hclean hhit + · exact hresult + +theorem probingHashQuery_done_false_invariants + (parameter : PublicParameter) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (input : HashInput) (output : HashOutput) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hresult : .done false finalState (output, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((probingHashQuery parameter input).run cache))) : + AdaptiveRevealProbe.tableHits finalState table = false ∧ + finalState.revealed = state.revealed := by + cases hdecode : decodeProbe? parameter input with + | none => + rw [probingHashQuery_run_eq, hdecode] at hresult + obtain ⟨value, heq⟩ := AdaptiveRevealProbe.runDetailed_stateFree_support table state fuel + ((splitHashQuery (.ordinary input)).run cache) + (splitHashQuery_stateFree (.ordinary input) cache) hclean + (.done false finalState (output, finalCache)) hresult + have hstate := (AdaptiveRevealProbe.DetailedResult.done.inj heq).2.1 + exact ⟨hstate ▸ hclean, hstate ▸ rfl⟩ + | some probe => + cases fuel with + | zero => + rw [probingHashQuery_run_eq, hdecode] at hresult + change .done false finalState (output, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state 0 + ((liftM (OracleSpec.query + (spec := AdaptiveRevealProbe.World Coordinate) + (.probe (probe.index, probe.tree, probe.leafIdx) probe.candidate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Unit) >>= fun _ => + (splitHashQuery (.ordinary input)).run cache)) at hresult + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind] at hresult + simp at hresult + | succ remaining => + have hresultOriginal := hresult + rw [probingHashQuery_run_eq, hdecode] at hresult + change .done false finalState (output, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((liftM (OracleSpec.query + (spec := AdaptiveRevealProbe.World Coordinate) + (.probe (probe.index, probe.tree, probe.leafIdx) probe.candidate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Unit) >>= fun _ => + (splitHashQuery (.ordinary input)).run cache)) at hresult + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind] at hresult + cases hrevealed : state.revealed + (probe.index, probe.tree, probe.leafIdx) with + | none => + simp only [hrevealed] at hresult + by_cases hhit : table (probe.index, probe.tree, probe.leafIdx) = probe.candidate + · have hhitEq := runDetailed_probingHashQuery_hidden_hit parameter table state + remaining cache input probe hdecode hrevealed hhit + (.done false finalState (output, finalCache)) hresultOriginal + change false = true at hhitEq + simp at hhitEq + · have hnextClean := AdaptiveRevealProbe.tableHits_addPending_eq_false state table + (probe.index, probe.tree, probe.leafIdx) probe.candidate hclean hhit + obtain ⟨value, heq⟩ := + AdaptiveRevealProbe.runDetailed_stateFree_support table + (state.addPending (probe.index, probe.tree, probe.leafIdx) probe.candidate) + remaining ((splitHashQuery (.ordinary input)).run cache) + (splitHashQuery_stateFree (.ordinary input) cache) hnextClean + (.done false finalState (output, finalCache)) hresult + have hstate := (AdaptiveRevealProbe.DetailedResult.done.inj heq).2.1 + refine ⟨hstate ▸ hnextClean, ?_⟩ + rw [hstate] + rfl + | some value => + simp only [hrevealed] at hresult + obtain ⟨resultValue, heq⟩ := + AdaptiveRevealProbe.runDetailed_stateFree_support table state remaining + ((splitHashQuery (.ordinary input)).run cache) + (splitHashQuery_stateFree (.ordinary input) cache) hclean + (.done false finalState (output, finalCache)) hresult + have hstate := (AdaptiveRevealProbe.DetailedResult.done.inj heq).2.1 + exact ⟨hstate ▸ hclean, hstate ▸ rfl⟩ + +theorem probingHashQuery_done_false_clean + (parameter : PublicParameter) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (input : HashInput) (output : HashOutput) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hresult : .done false finalState (output, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((probingHashQuery parameter input).run cache))) : + AdaptiveRevealProbe.tableHits finalState table = false := + (probingHashQuery_done_false_invariants parameter table state finalState fuel cache finalCache + input output hclean hresult).1 + +theorem probingHashQuery_cachePreserving + (parameter : PublicParameter) (input : HashInput) : + CachePreserving (probingHashQuery parameter input) := by + intro initial result hresult + rw [probingHashQuery_run_eq] at hresult + cases hdecode : decodeProbe? parameter input with + | none => + simp only [hdecode] at hresult + exact splitHashQuery_cachePreserving (.ordinary input) initial result hresult + | some probe => + simp only [hdecode, mem_support_bind_iff] at hresult + obtain ⟨probeResult, _hprobe, hresult⟩ := hresult + exact splitHashQuery_cachePreserving (.ordinary input) initial result hresult + +theorem probingHashQuery_done_false_revealedSynced + (parameter : PublicParameter) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (input : HashInput) (output : HashOutput) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state cache) + (hresult : .done false finalState (output, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((probingHashQuery parameter input).run cache))) : + RevealedSynced parameter table finalState finalCache := by + have hrevealed := (probingHashQuery_done_false_invariants parameter table state finalState + fuel cache finalCache input output hclean hresult).2 + have hraw : (output, finalCache) ∈ support ((probingHashQuery parameter input).run cache) := + AdaptiveRevealProbe.mem_support_of_mem_runDetailed_done table state finalState fuel + ((probingHashQuery parameter input).run cache) false (output, finalCache) hresult + have hcacheLe : SplitCacheLE cache finalCache := + probingHashQuery_cachePreserving parameter input cache (output, finalCache) hraw + intro coordinate value hfinalRevealed + have hinitialRevealed : state.revealed coordinate = some value := by + rw [← hrevealed] + exact hfinalRevealed + obtain ⟨hvalue, hiddenOutput, hhidden, hordinary⟩ := + hsynced coordinate value hinitialRevealed + exact ⟨hvalue, hiddenOutput, hcacheLe _ _ hhidden, hcacheLe _ _ hordinary⟩ + +set_option maxRecDepth 2000 in +theorem revealedSynced_of_mem_runDetailed_revealSequence {n : Nat} + (parameter : PublicParameter) (table : Coordinate → Digest) (index : Index) + (coordinates : Fin n → Coordinate) + (hcoordinates : ∀ position, (coordinates position).1 = index) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state cache) + (hcached : HiddenIndexCached index cache) + (values : Fin n → Digest) + (hresult : .done false finalState (values, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((sequenceFin fun position => + revealFtsSecret parameter (coordinates position)).run cache))) : + RevealedSynced parameter table finalState finalCache := by + induction n generalizing state cache finalState finalCache with + | zero => + simp only [sequenceFin, StateT.run_pure] at hresult + simp [AdaptiveRevealProbe.runDetailed, hclean] at hresult + obtain ⟨hstate, hvalues, hcache⟩ := hresult + subst finalState + subst finalCache + exact hsynced + | succ n ih => + rw [sequenceFin, StateT.run_bind] at hresult + obtain ⟨headState, headResult, hhead, hafterHead⟩ := + mem_support_runDetailed_bind_probeFree table state finalState fuel + ((revealFtsSecret parameter (coordinates 0)).run cache) _ + (revealFtsSecret_probeFree parameter (coordinates 0) cache) hclean + (values, finalCache) hresult + rcases headResult with ⟨head, headCache⟩ + have hcoordinateZero : coordinates 0 = + (index, (coordinates 0).2.1, (coordinates 0).2.2) := by + rcases hcoordinate : coordinates 0 with ⟨coordinateIndex, tree, leafIdx⟩ + have hindex := hcoordinates 0 + rw [hcoordinate] at hindex + simpa using hindex + have hhiddenZero : ∃ output, + cache (.hiddenLeaf (coordinates 0)) = some output := by + rw [hcoordinateZero] + exact hcached (coordinates 0).2.1 (coordinates 0).2.2 + have hheadClean : AdaptiveRevealProbe.tableHits headState table = false := + tableHits_false_of_mem_runDetailed_probeFree table state headState fuel + ((revealFtsSecret parameter (coordinates 0)).run cache) + (revealFtsSecret_probeFree parameter (coordinates 0) cache) hclean + (head, headCache) hhead + have hheadSynced : RevealedSynced parameter table headState headCache := + revealedSynced_of_mem_runDetailed_revealFtsSecret parameter table state headState fuel + cache headCache (coordinates 0) head hclean hsynced hhiddenZero hhead + have hheadCached : HiddenIndexCached index headCache := + hiddenIndexCached_of_mem_runDetailed_revealFtsSecret parameter table index state + headState fuel cache headCache (coordinates 0) head hclean hsynced hcached + (hcoordinates 0) hhead + rw [StateT.run_bind] at hafterHead + obtain ⟨tailState, tailResult, htail, hfinish⟩ := + mem_support_runDetailed_bind_probeFree table headState finalState fuel + ((sequenceFin fun position => + revealFtsSecret parameter (coordinates position.succ)).run headCache) _ + (sequenceFin_probeFree + (fun position => revealFtsSecret parameter (coordinates position.succ)) + (fun position => revealFtsSecret_probeFree parameter + (coordinates position.succ)) headCache) + hheadClean (values, finalCache) hafterHead + rcases tailResult with ⟨tail, tailCache⟩ + have htailSynced : RevealedSynced parameter table tailState tailCache := + ih (fun position => coordinates position.succ) + (fun position => hcoordinates position.succ) + (state := headState) (cache := headCache) + (finalState := tailState) (finalCache := tailCache) + hheadClean hheadSynced hheadCached tail htail + have hparts := AdaptiveRevealProbe.DetailedResult.done.inj hfinish + have hfinalState := hparts.2.1 + have hfinalCache := congrArg Prod.snd hparts.2.2 + subst finalState + change finalCache = tailCache at hfinalCache + rw [hfinalCache] + exact htailSynced + +theorem revealedSynced_of_mem_runDetailed_revealSelectedFtsSecrets + (parameter : PublicParameter) (table : Coordinate → Digest) (index : Index) + (leaves : DigestTree → FtsLeaf) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state cache) + (hcached : HiddenIndexCached index cache) + (values : FtsTree → Digest) + (hresult : .done false finalState (values, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((revealSelectedFtsSecrets parameter index leaves).run cache))) : + RevealedSynced parameter table finalState finalCache := by + unfold revealSelectedFtsSecrets at hresult + exact revealedSynced_of_mem_runDetailed_revealSequence parameter table index + (fun tree => (index, tree, leaves (ftsIndexOf tree))) (fun tree => rfl) + state finalState fuel cache finalCache hclean hsynced hcached values hresult + +set_option maxRecDepth 4000 in +theorem revealedSynced_of_mem_runDetailed_maskedSignAfterDigest + (secretKey : SecretKey) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (randomness : Randomness) (index : Index) + (leaves : DigestTree → FtsLeaf) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced secretKey.parameter table state cache) + (signature : Option Signature) + (hresult : .done false finalState (signature, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((maskedSignAfterDigest secretKey randomness index leaves).run cache))) : + RevealedSynced secretKey.parameter table finalState finalCache := by + unfold maskedSignAfterDigest at hresult + rw [StateT.run_bind] at hresult + obtain ⟨pathState, pathResult, hpath, hafterPath⟩ := + mem_support_runDetailed_bind_probeFree table state finalState fuel + ((maskedFtsOpen secretKey.parameter index leaves).run cache) _ + (maskedFtsOpen_probeFree secretKey.parameter index leaves cache) hclean + (signature, finalCache) hresult + rcases pathResult with ⟨ftsPath, pathCache⟩ + have hpathClean : AdaptiveRevealProbe.tableHits pathState table = false := + tableHits_false_of_mem_runDetailed_probeFree table state pathState fuel + ((maskedFtsOpen secretKey.parameter index leaves).run cache) + (maskedFtsOpen_probeFree secretKey.parameter index leaves cache) hclean + (ftsPath, pathCache) hpath + have hpathSynced : RevealedSynced secretKey.parameter table pathState pathCache := + revealedSynced_of_mem_runDetailed_stateFree secretKey.parameter table state pathState + fuel cache pathCache ftsPath (maskedFtsOpen secretKey.parameter index leaves) hclean + hsynced (maskedFtsOpen_stateFree secretKey.parameter index leaves) + (maskedFtsOpen_cachePreserving secretKey.parameter index leaves) hpath + rw [StateT.run_bind] at hafterPath + obtain ⟨layersState, layersResult, hlayers, hafterLayers⟩ := + mem_support_runDetailed_bind_probeFree table pathState finalState fuel + ((sequenceFin fun lay => maskedSignLayer secretKey index lay).run pathCache) _ + (sequenceFin_probeFree (fun lay => maskedSignLayer secretKey index lay) + (fun lay => maskedSignLayer_probeFree secretKey index lay) pathCache) + hpathClean (signature, finalCache) hafterPath + rcases layersResult with ⟨layers, layersCache⟩ + have hlayersClean : AdaptiveRevealProbe.tableHits layersState table = false := + tableHits_false_of_mem_runDetailed_probeFree table pathState layersState fuel + ((sequenceFin fun lay => maskedSignLayer secretKey index lay).run pathCache) + (sequenceFin_probeFree (fun lay => maskedSignLayer secretKey index lay) + (fun lay => maskedSignLayer_probeFree secretKey index lay) pathCache) + hpathClean (layers, layersCache) hlayers + have hlayersSynced : RevealedSynced secretKey.parameter table layersState layersCache := + revealedSynced_of_mem_runDetailed_stateFree secretKey.parameter table pathState layersState + fuel pathCache layersCache layers + (sequenceFin fun lay => maskedSignLayer secretKey index lay) hpathClean hpathSynced + (sequenceFin_stateFree (fun lay => maskedSignLayer secretKey index lay) + (fun lay => maskedSignLayer_stateFree secretKey index lay)) + (sequenceFin_cachePreserving (fun lay => maskedSignLayer secretKey index lay) + (fun lay => maskedSignLayer_cachePreserving secretKey index lay)) hlayers + have hlayersCached : HiddenIndexCached index layersCache := + hiddenIndexCached_of_mem_runDetailed_maskedSignLayers secretKey table pathState + layersState fuel pathCache layersCache index layers hpathClean hlayers + cases hparts : traverseOption layers with + | none => + simp only [hparts] at hafterLayers + simp [AdaptiveRevealProbe.runDetailed, hlayersClean] at hafterLayers + obtain ⟨hstate, hsignature, hvalueCache⟩ := hafterLayers + subst finalState + cases hvalueCache + exact hlayersSynced + | some parts => + simp only [hparts, StateT.run_bind] at hafterLayers + obtain ⟨selectedState, selectedResult, hselected, hfinish⟩ := + mem_support_runDetailed_bind_probeFree table layersState finalState fuel + ((revealSelectedFtsSecrets secretKey.parameter index leaves).run layersCache) _ + (revealSelectedFtsSecrets_probeFree secretKey.parameter index leaves layersCache) + hlayersClean (signature, finalCache) hafterLayers + rcases selectedResult with ⟨selected, selectedCache⟩ + have hselectedSynced : + RevealedSynced secretKey.parameter table selectedState selectedCache := + revealedSynced_of_mem_runDetailed_revealSelectedFtsSecrets secretKey.parameter table + index leaves layersState selectedState fuel layersCache selectedCache hlayersClean + hlayersSynced hlayersCached selected hselected + have hselectedClean : AdaptiveRevealProbe.tableHits selectedState table = false := + tableHits_false_of_mem_runDetailed_probeFree table layersState selectedState fuel + ((revealSelectedFtsSecrets secretKey.parameter index leaves).run layersCache) + (revealSelectedFtsSecrets_probeFree secretKey.parameter index leaves layersCache) + hlayersClean (selected, selectedCache) hselected + simp [AdaptiveRevealProbe.runDetailed, hselectedClean] at hfinish + obtain ⟨hstate, hsignature, hvalueCache⟩ := hfinish + subst finalState + cases hvalueCache + exact hselectedSynced + +set_option maxRecDepth 10000 in +theorem revealedSynced_of_mem_runDetailed_maskedSignWithView + (secretKey : SecretKey) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (message : Message) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced secretKey.parameter table state cache) + (result : Option Signature × Option FewTimeView) + (hresult : .done false finalState (result, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((maskedSignWithView secretKey message).run cache))) : + RevealedSynced secretKey.parameter table finalState finalCache := by + unfold maskedSignWithView at hresult + rw [StateT.run_bind] at hresult + obtain ⟨loopState, loopResult, hloop, hafterLoop⟩ := + mem_support_runDetailed_bind_probeFree table state finalState fuel + ((simulateQ splitRomImpl + (signDigestLoop digestAttemptLimit secretKey message)).run cache) _ + (simulateQ_splitRomImpl_probeFree + (signDigestLoop digestAttemptLimit secretKey message) cache) + hclean (result, finalCache) hresult + rcases loopResult with ⟨selected, loopCache⟩ + have hloopClean : AdaptiveRevealProbe.tableHits loopState table = false := + tableHits_false_of_mem_runDetailed_probeFree table state loopState fuel + ((simulateQ splitRomImpl + (signDigestLoop digestAttemptLimit secretKey message)).run cache) + (simulateQ_splitRomImpl_probeFree + (signDigestLoop digestAttemptLimit secretKey message) cache) + hclean (selected, loopCache) hloop + have hloopSynced : RevealedSynced secretKey.parameter table loopState loopCache := + revealedSynced_of_mem_runDetailed_stateFree secretKey.parameter table state loopState + fuel cache loopCache selected + (simulateQ splitRomImpl (signDigestLoop digestAttemptLimit secretKey message)) + hclean hsynced + (simulateQ_splitRomImpl_stateFree + (signDigestLoop digestAttemptLimit secretKey message)) + (simulateQ_splitRomImpl_cachePreserving + (signDigestLoop digestAttemptLimit secretKey message)) hloop + cases selected with + | none => + simp [AdaptiveRevealProbe.runDetailed, hloopClean] at hafterLoop + obtain ⟨hstate, hvalue, hcache⟩ := hafterLoop + subst finalState + subst finalCache + exact hloopSynced + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + rw [StateT.run_bind] at hafterLoop + obtain ⟨signatureState, signatureResult, hsignature, hfinish⟩ := + mem_support_runDetailed_bind_probeFree table loopState finalState fuel + ((maskedSignAfterDigest secretKey randomness index leaves).run loopCache) _ + (maskedSignAfterDigest_probeFree secretKey randomness index leaves loopCache) + hloopClean (result, finalCache) hafterLoop + rcases signatureResult with ⟨signature, signatureCache⟩ + have hsignatureSynced : + RevealedSynced secretKey.parameter table signatureState signatureCache := + revealedSynced_of_mem_runDetailed_maskedSignAfterDigest secretKey table loopState + signatureState fuel loopCache signatureCache randomness index leaves hloopClean + hloopSynced signature hsignature + have hsignatureClean : AdaptiveRevealProbe.tableHits signatureState table = false := + tableHits_false_of_mem_runDetailed_probeFree table loopState signatureState fuel + ((maskedSignAfterDigest secretKey randomness index leaves).run loopCache) + (maskedSignAfterDigest_probeFree secretKey randomness index leaves loopCache) + hloopClean (signature, signatureCache) hsignature + simp [AdaptiveRevealProbe.runDetailed, hsignatureClean] at hfinish + obtain ⟨hstate, hvalue, hcache⟩ := hfinish + subst finalState + subst finalCache + exact hsignatureSynced + +theorem revealedSynced_of_mem_runDetailed_maskedSigningImpl + (secretKey : SecretKey) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (message : Message) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced secretKey.parameter table state cache) + (signature : Option Signature) + (hresult : .done false finalState (signature, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((maskedSigningImpl secretKey message).run cache))) : + RevealedSynced secretKey.parameter table finalState finalCache := by + unfold maskedSigningImpl at hresult + rw [StateT.run_map] at hresult + change .done false finalState (signature, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + (((fun result : Option Signature × Option FewTimeView => result.1) <$> + maskedSignWithView secretKey message).run cache)) at hresult + rw [StateT.run_map, map_eq_bind_pure_comp, + AdaptiveRevealProbe.runDetailed_bind_probeFree table state fuel + ((maskedSignWithView secretKey message).run cache) _ + (maskedSignWithView_probeFree secretKey message cache), mem_support_bind_iff] at hresult + obtain ⟨viewResult, hviewResult, hfinish⟩ := hresult + obtain ⟨viewState, viewValue, heq, hviewClean⟩ := + AdaptiveRevealProbe.runDetailed_probeFree_support table state fuel + ((maskedSignWithView secretKey message).run cache) + (maskedSignWithView_probeFree secretKey message cache) hclean viewResult hviewResult + subst viewResult + simp [AdaptiveRevealProbe.runDetailed, hviewClean] at hfinish + obtain ⟨hstate, hvalue, hcache⟩ := hfinish + subst finalState + subst finalCache + exact revealedSynced_of_mem_runDetailed_maskedSignWithView secretKey table state viewState + fuel cache viewValue.2 message hclean hsynced viewValue.1 hviewResult + +set_option maxRecDepth 10000 in +theorem maskedExpandedAdversaryImpl_done_false + (secretKey : SecretKey) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) + (input : (OracleWorld + SigningSpec).Domain) + (output : (OracleWorld + SigningSpec).Range input) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced secretKey.parameter table state cache) + (hresult : .done false finalState (output, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((maskedExpandedAdversaryImpl secretKey.parameter secretKey input).run cache))) : + (output, mergedCache secretKey.parameter table finalCache) ∈ support + ((unloggedMappedAdversaryImpl + (secretKeyWithFtsTable secretKey table) input).run + (mergedCache secretKey.parameter table cache)) ∧ + AdaptiveRevealProbe.tableHits finalState table = false ∧ + RevealedSynced secretKey.parameter table finalState finalCache := by + revert output + cases input with + | inl worldInput => + cases worldInput with + | inl n => + intro output hresult + change unifSpec.Range n at output + change .done false finalState (output, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((splitUniformImpl n).run cache)) at hresult + change (output, mergedCache secretKey.parameter table finalCache) ∈ support + ((unifFwdImpl HashSpec n).run + (mergedCache secretKey.parameter table cache)) ∧ + AdaptiveRevealProbe.tableHits finalState table = false ∧ + RevealedSynced secretKey.parameter table finalState finalCache + have hactual := CoupledAt.mem_support_ordinary + (parameter := secretKey.parameter) (table := table) (state := state) + (fuel := fuel) (masked := splitUniformImpl n) (ordinary := unifFwdImpl HashSpec n) + (cache := cache) (finalState := finalState) (finalCache := finalCache) + (value := output) + ((coupled_splitUniformImpl secretKey.parameter table state fuel n hclean).coupledAt + cache) hresult + have hmasked : .done false finalState (output, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((splitUniformImpl n).run cache)) := hresult + have hfinalClean := tableHits_false_of_mem_runDetailed_probeFree table state finalState + fuel ((splitUniformImpl n).run cache) (splitUniformImpl_probeFree n cache) hclean + (output, finalCache) hmasked + have hfinalSynced := revealedSynced_of_mem_runDetailed_stateFree + secretKey.parameter table state finalState fuel cache finalCache output + (splitUniformImpl n) hclean hsynced (splitUniformImpl_stateFree n) + (splitUniformImpl_cachePreserving n) hmasked + refine ⟨?_, hfinalClean, hfinalSynced⟩ + exact hactual + | inr hashInput => + intro output hresult + change HashOutput at output + change .done false finalState (output, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((probingHashQuery secretKey.parameter hashInput).run cache)) at hresult + have hmasked : .done false finalState (output, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((probingHashQuery secretKey.parameter hashInput).run cache)) := hresult + refine ⟨?_, probingHashQuery_done_false_clean secretKey.parameter table state + finalState fuel cache finalCache hashInput output hclean hmasked, ?_⟩ + · change (output, mergedCache secretKey.parameter table finalCache) ∈ support + ((randomOracle hashInput).run + (mergedCache secretKey.parameter table cache)) + exact probingHashQuery_done_false_mem_ordinary secretKey.parameter table state + finalState fuel cache finalCache hashInput output hclean hsynced hmasked + · exact probingHashQuery_done_false_revealedSynced secretKey.parameter table state + finalState fuel cache finalCache hashInput output hclean hsynced hmasked + | inr message => + intro output hresult + change SigningSpec.Range message at output + change .done false finalState (output, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((maskedSigningImpl secretKey message).run cache)) at hresult + change (output, mergedCache secretKey.parameter table finalCache) ∈ support + ((simulateQ romImpl + (scheme.sign (secretKeyWithFtsTable secretKey table) message)).run + (mergedCache secretKey.parameter table cache)) ∧ + AdaptiveRevealProbe.tableHits finalState table = false ∧ + RevealedSynced secretKey.parameter table finalState finalCache + have hmasked : .done false finalState (output, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((maskedSigningImpl secretKey message).run cache)) := hresult + have hactual := CoupledAt.mem_support_ordinary + (parameter := secretKey.parameter) (table := table) (state := state) (fuel := fuel) + (masked := maskedSigningImpl secretKey message) + (ordinary := simulateQ romImpl + (scheme.sign (secretKeyWithFtsTable secretKey table) message)) + (cache := cache) (finalState := finalState) (finalCache := finalCache) + (value := output) + (coupledAt_maskedSigningImpl secretKey table state fuel cache message hclean hsynced) + hmasked + have hfinalClean := tableHits_false_of_mem_runDetailed_probeFree table state finalState + fuel ((maskedSigningImpl secretKey message).run cache) + (by + have hprobeFree : ProbeFree (maskedSigningImpl secretKey message) := by + unfold maskedSigningImpl + exact (maskedSignWithView_probeFree secretKey message).map Prod.fst + exact hprobeFree cache) + hclean (output, finalCache) hmasked + refine ⟨?_, hfinalClean, ?_⟩ + · exact hactual + · exact revealedSynced_of_mem_runDetailed_maskedSigningImpl secretKey table state + finalState fuel cache finalCache message hclean hsynced output hmasked + +set_option maxRecDepth 10000 in +theorem simulateQ_maskedExpandedAdversaryImpl_done_false + (secretKey : SecretKey) (table : Coordinate → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (value : alpha) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced secretKey.parameter table state cache) + (hresult : .done false finalState (value, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + computation).run cache))) : + (value, mergedCache secretKey.parameter table finalCache) ∈ support + ((simulateQ + (unloggedMappedAdversaryImpl (secretKeyWithFtsTable secretKey table)) + computation).run (mergedCache secretKey.parameter table cache)) ∧ + AdaptiveRevealProbe.tableHits finalState table = false ∧ + RevealedSynced secretKey.parameter table finalState finalCache := by + induction computation using OracleComp.inductionOn generalizing + state fuel cache finalState finalCache with + | pure result => + simp [simulateQ_pure, AdaptiveRevealProbe.runDetailed, hclean] at hresult + obtain ⟨hstate, hvalue, hcache⟩ := hresult + subst finalState + subst value + subst finalCache + exact ⟨by simp [simulateQ_pure], hclean, hsynced⟩ + | query_bind input next ih => + rw [simulateQ_query_bind, StateT.run_bind] at hresult + cases input with + | inl worldInput => + cases worldInput with + | inl n => + obtain ⟨queryState, queryResult, hquery, hrest⟩ := + mem_support_runDetailed_bind_probeFree table state finalState fuel + ((splitUniformImpl n).run cache) + (fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (next result.1)).run result.2) + (splitUniformImpl_probeFree n cache) hclean + (value, finalCache) (by + simpa [maskedExpandedAdversaryImpl, probingRomImpl, + probingHashImpl] using hresult) + rcases queryResult with ⟨output, queryCache⟩ + have hstep := maskedExpandedAdversaryImpl_done_false secretKey table state + queryState fuel cache queryCache (.inl (.inl n)) output hclean hsynced hquery + have htail := ih output queryState finalState fuel queryCache finalCache + hstep.2.1 hstep.2.2 hrest + refine ⟨?_, htail.2.1, htail.2.2⟩ + rw [simulateQ_query_bind, StateT.run_bind, mem_support_bind_iff] + exact ⟨(output, mergedCache secretKey.parameter table queryCache), hstep.1, + htail.1⟩ + | inr hashInput => + have hhashResult : .done false finalState (value, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((probingHashQuery secretKey.parameter hashInput).run cache >>= fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (next result.1)).run result.2)) := by + simpa [maskedExpandedAdversaryImpl, probingRomImpl, + probingHashImpl] using hresult + cases hdecode : decodeProbe? secretKey.parameter hashInput with + | none => + have hhashProbeFree : ProbeFree + (probingHashQuery secretKey.parameter hashInput) := by + intro workingCache + rw [probingHashQuery_run_eq, hdecode] + exact splitHashQuery_probeFree (.ordinary hashInput) workingCache + obtain ⟨queryState, queryResult, hquery, hrest⟩ := + mem_support_runDetailed_bind_probeFree table state finalState fuel + ((probingHashQuery secretKey.parameter hashInput).run cache) + (fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (next result.1)).run result.2) + (hhashProbeFree cache) hclean (value, finalCache) hhashResult + rcases queryResult with ⟨output, queryCache⟩ + have hstep := maskedExpandedAdversaryImpl_done_false secretKey table state + queryState fuel cache queryCache (.inl (.inr hashInput)) output hclean + hsynced hquery + have htail := ih output queryState finalState fuel queryCache finalCache + hstep.2.1 hstep.2.2 hrest + refine ⟨?_, htail.2.1, htail.2.2⟩ + rw [simulateQ_query_bind, StateT.run_bind, mem_support_bind_iff] + exact ⟨(output, mergedCache secretKey.parameter table queryCache), hstep.1, + htail.1⟩ + | some probe => + rw [probingHashQuery_run_eq, hdecode] at hhashResult + change .done false finalState (value, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((liftM (OracleSpec.query + (spec := AdaptiveRevealProbe.World Coordinate) + (.probe (probe.index, probe.tree, probe.leafIdx) probe.candidate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Unit) >>= fun _ => + (splitHashQuery (.ordinary hashInput)).run cache >>= fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (next result.1)).run result.2)) at hhashResult + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind] at hhashResult + cases fuel with + | zero => simp at hhashResult + | succ remaining => + cases hrevealed : state.revealed + (probe.index, probe.tree, probe.leafIdx) with + | none => + simp only [hrevealed] at hhashResult + by_cases hhit : table (probe.index, probe.tree, probe.leafIdx) = + probe.candidate + · have hpostClean := tableHits_false_of_mem_runDetailed_done_false + table + (state.addPending + (probe.index, probe.tree, probe.leafIdx) probe.candidate) + finalState remaining + ((splitHashQuery (.ordinary hashInput)).run cache >>= fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (next result.1)).run result.2) + (value, finalCache) hhashResult + have hpostHit := AdaptiveRevealProbe.tableHits_addPending_eq_true + state table (probe.index, probe.tree, probe.leafIdx) + probe.candidate hhit + rw [hpostHit] at hpostClean + simp at hpostClean + · have hpostClean := AdaptiveRevealProbe.tableHits_addPending_eq_false + state table (probe.index, probe.tree, probe.leafIdx) + probe.candidate hclean hhit + obtain ⟨queryState, queryResult, hquery, hrest⟩ := + mem_support_runDetailed_bind_probeFree table + (state.addPending + (probe.index, probe.tree, probe.leafIdx) probe.candidate) + finalState remaining + ((splitHashQuery (.ordinary hashInput)).run cache) + (fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (next result.1)).run result.2) + (splitHashQuery_probeFree (.ordinary hashInput) cache) + hpostClean (value, finalCache) hhashResult + rcases queryResult with ⟨output, queryCache⟩ + have hqueryOriginal : .done false queryState + (output, queryCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((probingHashQuery secretKey.parameter hashInput).run cache)) := by + rw [probingHashQuery_run_eq, hdecode] + change .done false queryState (output, queryCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((liftM (OracleSpec.query + (spec := AdaptiveRevealProbe.World Coordinate) + (.probe (probe.index, probe.tree, probe.leafIdx) + probe.candidate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Unit) >>= + fun _ => + (splitHashQuery (.ordinary hashInput)).run cache)) + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind, hrevealed] + exact hquery + have hstep := maskedExpandedAdversaryImpl_done_false secretKey table + state queryState (remaining + 1) cache queryCache + (.inl (.inr hashInput)) output hclean hsynced hqueryOriginal + have htail := ih output queryState finalState remaining queryCache + finalCache hstep.2.1 hstep.2.2 hrest + refine ⟨?_, htail.2.1, htail.2.2⟩ + rw [simulateQ_query_bind, StateT.run_bind, mem_support_bind_iff] + exact ⟨(output, mergedCache secretKey.parameter table queryCache), + hstep.1, htail.1⟩ + | some revealedValue => + simp only [hrevealed] at hhashResult + obtain ⟨queryState, queryResult, hquery, hrest⟩ := + mem_support_runDetailed_bind_probeFree table state finalState + remaining ((splitHashQuery (.ordinary hashInput)).run cache) + (fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (next result.1)).run result.2) + (splitHashQuery_probeFree (.ordinary hashInput) cache) + hclean (value, finalCache) hhashResult + rcases queryResult with ⟨output, queryCache⟩ + have hqueryOriginal : .done false queryState + (output, queryCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((probingHashQuery secretKey.parameter hashInput).run cache)) := by + rw [probingHashQuery_run_eq, hdecode] + change .done false queryState (output, queryCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((liftM (OracleSpec.query + (spec := AdaptiveRevealProbe.World Coordinate) + (.probe (probe.index, probe.tree, probe.leafIdx) + probe.candidate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Unit) >>= + fun _ => + (splitHashQuery (.ordinary hashInput)).run cache)) + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind, hrevealed] + exact hquery + have hstep := maskedExpandedAdversaryImpl_done_false secretKey table + state queryState (remaining + 1) cache queryCache + (.inl (.inr hashInput)) output hclean hsynced hqueryOriginal + have htail := ih output queryState finalState remaining queryCache + finalCache hstep.2.1 hstep.2.2 hrest + refine ⟨?_, htail.2.1, htail.2.2⟩ + rw [simulateQ_query_bind, StateT.run_bind, mem_support_bind_iff] + exact ⟨(output, mergedCache secretKey.parameter table queryCache), + hstep.1, htail.1⟩ + | inr message => + have hsignProbeFree : ProbeFree (maskedSigningImpl secretKey message) := by + unfold maskedSigningImpl + exact (maskedSignWithView_probeFree secretKey message).map Prod.fst + obtain ⟨queryState, queryResult, hquery, hrest⟩ := + mem_support_runDetailed_bind_probeFree table state finalState fuel + ((maskedSigningImpl secretKey message).run cache) + (fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (next result.1)).run result.2) + (hsignProbeFree cache) + hclean (value, finalCache) (by + simpa [maskedExpandedAdversaryImpl, probingRomImpl, + probingHashImpl] using hresult) + rcases queryResult with ⟨output, queryCache⟩ + have hstep := maskedExpandedAdversaryImpl_done_false secretKey table state + queryState fuel cache queryCache (.inr message) output hclean hsynced hquery + have htail := ih output queryState finalState fuel queryCache finalCache + hstep.2.1 hstep.2.2 hrest + refine ⟨?_, htail.2.1, htail.2.2⟩ + rw [simulateQ_query_bind, StateT.run_bind, mem_support_bind_iff] + exact ⟨(output, mergedCache secretKey.parameter table queryCache), hstep.1, + htail.1⟩ + +def signingTraceComputation + (computation : OracleComp (OracleWorld + SigningSpec) alpha) : + OracleComp (OracleWorld + SigningSpec) (alpha × QueryLog SigningSpec) := + OracleComp.construct + (C := fun _ => OracleComp (OracleWorld + SigningSpec) + (alpha × QueryLog SigningSpec)) + (fun value => pure (value, [])) + (fun input _next recursivelyTrace => do + let output ← liftM ((OracleWorld + SigningSpec).query input) + let result ← recursivelyTrace output + pure (result.1, signingLogFragment input output ++ result.2)) + computation + +theorem simulateQ_withTraceAppend_run_eq_signingTraceComputation + {m : Type → Type} [Monad m] [LawfulMonad m] + (handler : QueryImpl (OracleWorld + SigningSpec) m) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) : + (simulateQ (QueryImpl.withTraceAppend handler signingLogFragment) + computation).run = + simulateQ handler (signingTraceComputation computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp [signingTraceComputation] + | query_bind input next ih => + simp [signingTraceComputation, ih] + +set_option maxRecDepth 10000 in +theorem simulateQ_maskedExpandedAdversaryImpl_withTrace_done_false + (secretKey : SecretKey) (table : Coordinate → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (value : alpha) (log : QueryLog SigningSpec) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced secretKey.parameter table state cache) + (hresult : .done false finalState ((value, log), finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((simulateQ (QueryImpl.withTraceAppend + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + signingLogFragment) computation).run.run cache))) : + ((value, log), mergedCache secretKey.parameter table finalCache) ∈ support + ((simulateQ (QueryImpl.withTraceAppend + (unloggedMappedAdversaryImpl (secretKeyWithFtsTable secretKey table)) + signingLogFragment) computation).run.run + (mergedCache secretKey.parameter table cache)) ∧ + AdaptiveRevealProbe.tableHits finalState table = false ∧ + RevealedSynced secretKey.parameter table finalState finalCache := by + rw [simulateQ_withTraceAppend_run_eq_signingTraceComputation] at hresult ⊢ + exact simulateQ_maskedExpandedAdversaryImpl_done_false secretKey table + (signingTraceComputation computation) state finalState fuel cache finalCache + (value, log) hclean hsynced hresult + +set_option maxRecDepth 10000 in +theorem simulateQ_probingRomImpl_done_false + (secretKey : SecretKey) (table : Coordinate → Digest) + (computation : OracleComp OracleWorld alpha) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (value : alpha) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced secretKey.parameter table state cache) + (hresult : .done false finalState (value, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((simulateQ (probingRomImpl secretKey.parameter) computation).run cache))) : + (value, mergedCache secretKey.parameter table finalCache) ∈ support + ((simulateQ romImpl computation).run + (mergedCache secretKey.parameter table cache)) ∧ + AdaptiveRevealProbe.tableHits finalState table = false ∧ + RevealedSynced secretKey.parameter table finalState finalCache := by + letI directLift : MonadLift (OracleQuery OracleWorld) + (OracleQuery (OracleWorld + SigningSpec)) := + (OracleQuery.subSpec_add_left + (spec₁ := OracleWorld) (spec₂ := SigningSpec)).toMonadLift + let lifted : OracleComp (OracleWorld + SigningSpec) alpha := liftM computation + have hmasked : simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) lifted = + simulateQ (probingRomImpl secretKey.parameter) computation := by + change simulateQ + (probingRomImpl secretKey.parameter + maskedSigningImpl secretKey) + (liftM computation) = _ + simpa [lifted] using + (QueryImpl.simulateQ_add_liftM_left + (probingRomImpl secretKey.parameter) (maskedSigningImpl secretKey) computation) + let signingHandler : QueryImpl SigningSpec + (StateT (QueryCache HashSpec) ProbComp) := + fun message => simulateQ romImpl + (scheme.sign (secretKeyWithFtsTable secretKey table) message) + have hactualHandler : + unloggedMappedAdversaryImpl (secretKeyWithFtsTable secretKey table) = + romImpl + signingHandler := by + funext input + cases input <;> rfl + have hactual : simulateQ + (unloggedMappedAdversaryImpl (secretKeyWithFtsTable secretKey table)) lifted = + simulateQ romImpl computation := by + rw [hactualHandler] + simpa [lifted] using + (QueryImpl.simulateQ_add_liftM_left romImpl signingHandler computation) + rw [← hmasked] at hresult + rw [← hactual] + exact simulateQ_maskedExpandedAdversaryImpl_done_false secretKey table lifted + state finalState fuel cache finalCache value hclean hsynced hresult + +noncomputable def liftOracleWorldLeft + (computation : OracleComp OracleWorld alpha) : + OracleComp (OracleWorld + SigningSpec) alpha := by + letI directLift : MonadLift (OracleQuery OracleWorld) + (OracleQuery (OracleWorld + SigningSpec)) := + (OracleQuery.subSpec_add_left + (spec₁ := OracleWorld) (spec₂ := SigningSpec)).toMonadLift + exact liftM computation + +theorem simulateQ_liftOracleWorldLeft + {m : Type → Type} [Monad m] [LawfulMonad m] + (left : QueryImpl OracleWorld m) (right : QueryImpl SigningSpec m) + (computation : OracleComp OracleWorld alpha) : + simulateQ (left + right) (liftOracleWorldLeft computation) = + simulateQ left computation := by + unfold liftOracleWorldLeft + exact QueryImpl.simulateQ_add_liftM_left left right computation + +noncomputable def tracedGameRestComputation (adversary : Adversary) + (publicKey : PublicKey) : + OracleComp (OracleWorld + SigningSpec) Bool := do + let (forgery, log) ← signingTraceComputation (adversary.main publicKey) + let verified ← liftOracleWorldLeft + (scheme.verify publicKey forgery.message forgery.signature) + pure (decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log forgery) && verified) + +theorem simulateQ_maskedExpanded_tracedGameRestComputation + (adversary : Adversary) (secretKey : SecretKey) : + simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (tracedGameRestComputation adversary ⟨secretKey.root, secretKey.parameter⟩) = (do + let (forgery, log) ← + (simulateQ (QueryImpl.withTraceAppend + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + signingLogFragment) + (adversary.main ⟨secretKey.root, secretKey.parameter⟩)).run + let verified ← simulateQ (probingRomImpl secretKey.parameter) + (scheme.verify ⟨secretKey.root, secretKey.parameter⟩ + forgery.message forgery.signature) + pure (decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log forgery) && verified)) := by + unfold tracedGameRestComputation + rw [simulateQ_bind, + ← simulateQ_withTraceAppend_run_eq_signingTraceComputation] + apply bind_congr + intro result + rcases result with ⟨forgery, log⟩ + rw [simulateQ_bind] + change (do + let verified ← simulateQ + (probingRomImpl secretKey.parameter + maskedSigningImpl secretKey) + (liftOracleWorldLeft + (scheme.verify ⟨secretKey.root, secretKey.parameter⟩ + forgery.message forgery.signature)) + pure (decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log forgery) && verified)) = _ + rw [simulateQ_liftOracleWorldLeft] + +theorem writerTMapBase_expanded_withTraceAppend_eq_unlogged + (secretKey : SecretKey) : + QueryImpl.writerTMapBase romImpl + (QueryImpl.withTraceAppend (expandedAdversaryImpl secretKey) + signingLogFragment) = + QueryImpl.withTraceAppend (unloggedMappedAdversaryImpl secretKey) + signingLogFragment := by + funext input + apply WriterT.ext + simp [QueryImpl.writerTMapBase, + unloggedMappedAdversaryImpl_eq_simulateQ_expanded] + +theorem simulateQ_unloggedMapped_liftOracleWorldLeft + (secretKey : SecretKey) (computation : OracleComp OracleWorld alpha) : + simulateQ (unloggedMappedAdversaryImpl secretKey) + (liftOracleWorldLeft computation) = + simulateQ romImpl computation := by + let signingHandler : QueryImpl SigningSpec + (StateT (QueryCache HashSpec) ProbComp) := + fun message => simulateQ romImpl (scheme.sign secretKey message) + have hhandler : unloggedMappedAdversaryImpl secretKey = + romImpl + signingHandler := by + funext input + cases input <;> rfl + rw [hhandler, simulateQ_liftOracleWorldLeft] + +theorem simulateQ_unloggedMapped_tracedGameRestComputation + (adversary : Adversary) (secretKey : SecretKey) : + simulateQ (unloggedMappedAdversaryImpl secretKey) + (tracedGameRestComputation adversary + ⟨secretKey.root, secretKey.parameter⟩) = + simulateQ romImpl + (gameRest scheme adversary ⟨secretKey.root, secretKey.parameter⟩ secretKey) := by + have hadversary : + simulateQ romImpl + ((simulateQ (forwardOracles + signingOracle scheme secretKey) + (adversary.main ⟨secretKey.root, secretKey.parameter⟩)).run) = + (simulateQ (QueryImpl.withTraceAppend + (unloggedMappedAdversaryImpl secretKey) signingLogFragment) + (adversary.main ⟨secretKey.root, secretKey.parameter⟩)).run := by + rw [forwardOracles_add_signingOracle_eq_withTraceAppend, + QueryImpl.simulateQ_writerTMapBase_run, + writerTMapBase_expanded_withTraceAppend_eq_unlogged] + unfold tracedGameRestComputation gameRest + rw [simulateQ_bind, + ← simulateQ_withTraceAppend_run_eq_signingTraceComputation, + simulateQ_bind, hadversary] + apply bind_congr + intro result + rcases result with ⟨forgery, log⟩ + rw [simulateQ_bind, simulateQ_bind, + simulateQ_unloggedMapped_liftOracleWorldLeft] + rfl + +theorem maskedGameAfterSecrets_eq_tracedGameRestComputation + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) : + maskedGameAfterSecrets adversary parameter otsSecret = (do + let root ← simulateQ ordinaryHashImpl + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree)) + let secretKey : SecretKey := + ⟨parameter, root, otsSecret, fun _index _tree _leafIdx => 0⟩ + simulateQ (maskedExpandedAdversaryImpl parameter secretKey) + (tracedGameRestComputation adversary ⟨root, parameter⟩)) := by + unfold maskedGameAfterSecrets + apply bind_congr + intro root + exact (simulateQ_maskedExpanded_tracedGameRestComputation adversary + ⟨parameter, root, otsSecret, fun _index _tree _leafIdx => 0⟩).symm + +theorem simulateQ_romImpl_gameAfterSecrets_eq_tracedGameRestComputation + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret) = (do + let root ← simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree)) + let secretKey : SecretKey := + ⟨parameter, root, otsSecret, ftsSecret⟩ + simulateQ (unloggedMappedAdversaryImpl secretKey) + (tracedGameRestComputation adversary ⟨root, parameter⟩)) := by + unfold gameAfterSecrets + rw [simulateQ_bind] + have hroot : simulateQ romImpl + (liftM (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : + OracleComp HashSpec Digest)) = + simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree)) := by + change simulateQ (unifFwdImpl HashSpec + randomOracle) + (liftM (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : + OracleComp HashSpec Digest)) = _ + exact QueryImpl.simulateQ_add_liftM_right _ _ _ + rw [hroot] + apply bind_congr + intro root + exact (simulateQ_unloggedMapped_tracedGameRestComputation adversary + ⟨parameter, root, otsSecret, ftsSecret⟩).symm + +set_option maxRecDepth 20000 in +theorem maskedGameAfterSecrets_done_false_mem_gameAfterSecrets + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (table : Coordinate → Digest) + (finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (finalCache : SplitHashCache) (value : Bool) + (hresult : .done false finalState (value, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table AdaptiveRevealProbe.State.empty fuel + ((maskedGameAfterSecrets adversary parameter otsSecret).run + emptySplitHashCache))) : + (value, mergedCache parameter table finalCache) ∈ support + ((simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret + (fun index tree leafIdx => table (index, tree, leafIdx)))).run ∅) ∧ + AdaptiveRevealProbe.tableHits finalState table = false ∧ + RevealedSynced parameter table finalState finalCache := by + let rootComputation : OracleComp HashSpec Digest := + treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) + have hinitialClean : AdaptiveRevealProbe.tableHits + (AdaptiveRevealProbe.State.empty : AdaptiveRevealProbe.State Coordinate) table = false := by + simp [AdaptiveRevealProbe.tableHits, AdaptiveRevealProbe.State.empty] + rw [maskedGameAfterSecrets_eq_tracedGameRestComputation, + StateT.run_bind] at hresult + obtain ⟨rootState, rootResult, hroot, hrest⟩ := + mem_support_runDetailed_bind_probeFree table AdaptiveRevealProbe.State.empty + finalState fuel + ((simulateQ ordinaryHashImpl rootComputation).run emptySplitHashCache) + (fun result => + let secretKey : SecretKey := + ⟨parameter, result.1, otsSecret, fun _index _tree _leafIdx => 0⟩ + (simulateQ (maskedExpandedAdversaryImpl parameter secretKey) + (tracedGameRestComputation adversary ⟨result.1, parameter⟩)).run result.2) + (simulateQ_ordinaryHashImpl_probeFree rootComputation emptySplitHashCache) + hinitialClean (value, finalCache) (by simpa [rootComputation] using hresult) + rcases rootResult with ⟨root, rootCache⟩ + let maskedSecretKey : SecretKey := + ⟨parameter, root, otsSecret, fun _index _tree _leafIdx => 0⟩ + have hrootActual := CoupledAt.mem_support_ordinary + (parameter := parameter) (table := table) + (state := AdaptiveRevealProbe.State.empty) (fuel := fuel) + (masked := simulateQ ordinaryHashImpl rootComputation) + (ordinary := simulateQ (randomOracle : QueryImpl HashSpec _) rootComputation) + (cache := emptySplitHashCache) (finalState := rootState) + (finalCache := rootCache) (value := root) + ((coupled_simulateQ_ordinaryHashImpl parameter table + AdaptiveRevealProbe.State.empty fuel rootComputation hinitialClean + (ordinaryOnly_treeRoot parameter table topLayer rootTree + (otsSecret topLayer rootTree))).coupledAt emptySplitHashCache) hroot + have hrootClean := tableHits_false_of_mem_runDetailed_probeFree table + AdaptiveRevealProbe.State.empty rootState fuel + ((simulateQ ordinaryHashImpl rootComputation).run emptySplitHashCache) + (simulateQ_ordinaryHashImpl_probeFree rootComputation emptySplitHashCache) + hinitialClean (root, rootCache) hroot + have hrootSynced := revealedSynced_of_mem_runDetailed_stateFree parameter table + AdaptiveRevealProbe.State.empty rootState fuel emptySplitHashCache rootCache root + (simulateQ ordinaryHashImpl rootComputation) hinitialClean + (revealedSynced_empty parameter table) + (simulateQ_ordinaryHashImpl_stateFree rootComputation) + (simulateQ_ordinaryHashImpl_cachePreserving rootComputation) hroot + have hrestLift := simulateQ_maskedExpandedAdversaryImpl_done_false + maskedSecretKey table + (tracedGameRestComputation adversary ⟨root, parameter⟩) + rootState finalState fuel rootCache finalCache value hrootClean hrootSynced + (by simpa [maskedSecretKey] using hrest) + refine ⟨?_, hrestLift.2.1, hrestLift.2.2⟩ + rw [simulateQ_romImpl_gameAfterSecrets_eq_tracedGameRestComputation, + StateT.run_bind, mem_support_bind_iff] + refine ⟨(root, mergedCache parameter table rootCache), ?_, ?_⟩ + · simpa [rootComputation] using hrootActual + · simpa [maskedSecretKey, secretKeyWithFtsTable] using hrestLift.1 + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeCacheCharge.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeCacheCharge.lean new file mode 100644 index 00000000..f708775a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeCacheCharge.lean @@ -0,0 +1,252 @@ +import SphincsSecurity.Proof.FtsResidualCharge +import SphincsSecurity.Proof.AdaptiveRevealProbeCostExpectation + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +def ProbeCacheCovered (parameter : PublicParameter) + (state : AdaptiveRevealProbe.State Coordinate) (cache : SplitHashCache) : Prop := + ∀ probe : FtsSecretProbe, cache (.ordinary (probe.input parameter)) ≠ none → + state.revealed (probe.index, probe.tree, probe.leafIdx) ≠ none ∨ + probe.candidate ∈ state.pending (probe.index, probe.tree, probe.leafIdx) + +theorem probeCacheCovered_empty (parameter : PublicParameter) : + ProbeCacheCovered parameter AdaptiveRevealProbe.State.empty emptySplitHashCache := by + intro probe hcached + exact (hcached rfl).elim + +theorem ProbeCacheCovered.addPending {parameter : PublicParameter} + {state : AdaptiveRevealProbe.State Coordinate} {cache : SplitHashCache} + (hcovered : ProbeCacheCovered parameter state cache) (coordinate : Coordinate) (candidate : Digest) : + ProbeCacheCovered parameter (state.addPending coordinate candidate) cache := by + intro probe hcached + rcases hcovered probe hcached with hrevealed | hpending + · exact Or.inl hrevealed + · right + by_cases heq : (probe.index, probe.tree, probe.leafIdx) = coordinate + · simpa only [AdaptiveRevealProbe.State.addPending, heq, Function.update_self, Finset.mem_insert] + using (Or.inr hpending : probe.candidate = candidate ∨ probe.candidate ∈ state.pending _) + · simpa only [AdaptiveRevealProbe.State.addPending, Function.update_of_ne heq] using hpending + +theorem ProbeCacheCovered.install {parameter : PublicParameter} + {state : AdaptiveRevealProbe.State Coordinate} {cache : SplitHashCache} + (hcovered : ProbeCacheCovered parameter state cache) (coordinate : Coordinate) (value : Digest) : + ProbeCacheCovered parameter (state.install coordinate value) cache := by + intro probe hcached + by_cases heq : (probe.index, probe.tree, probe.leafIdx) = coordinate + · left + simp only [AdaptiveRevealProbe.State.install, heq, Function.update_self, ne_eq, reduceCtorEq, not_false_eq_true] + · simpa only [AdaptiveRevealProbe.State.install, Function.update_of_ne heq] using hcovered probe hcached + +theorem ProbeCacheCovered.update_hidden {parameter : PublicParameter} + {state : AdaptiveRevealProbe.State Coordinate} {cache : SplitHashCache} + (hcovered : ProbeCacheCovered parameter state cache) (coordinate : Coordinate) (answer : HashOutput) : + ProbeCacheCovered parameter state (Function.update cache (.hiddenLeaf coordinate) (some answer)) := by + intro probe hcached + apply hcovered probe + simpa only [Function.update_of_ne (by simp : SplitHashKey.ordinary (probe.input parameter) ≠ + SplitHashKey.hiddenLeaf coordinate)] using hcached + +theorem ProbeCacheCovered.update_nonprobe {parameter : PublicParameter} + {state : AdaptiveRevealProbe.State Coordinate} {cache : SplitHashCache} + (hcovered : ProbeCacheCovered parameter state cache) (input : HashInput) (answer : HashOutput) + (hinput : ∀ probe : FtsSecretProbe, probe.input parameter ≠ input) : + ProbeCacheCovered parameter state (Function.update cache (.ordinary input) (some answer)) := by + intro probe hcached + apply hcovered probe + have hne : SplitHashKey.ordinary (probe.input parameter) ≠ .ordinary input := + fun heq => hinput probe (SplitHashKey.ordinary.inj heq) + simpa only [Function.update_of_ne hne] using hcached + +theorem ProbeCacheCovered.update_probed {parameter : PublicParameter} + {state : AdaptiveRevealProbe.State Coordinate} {cache : SplitHashCache} + (hcovered : ProbeCacheCovered parameter state cache) (queried : FtsSecretProbe) (answer : HashOutput) : + ProbeCacheCovered parameter + (state.addPending (queried.index, queried.tree, queried.leafIdx) queried.candidate) + (Function.update cache (.ordinary (queried.input parameter)) (some answer)) := by + intro probe hcached + by_cases heq : probe = queried + · subst probe + right + simp only [AdaptiveRevealProbe.State.addPending, Function.update_self, Finset.mem_insert_self] + · have hne : SplitHashKey.ordinary (probe.input parameter) ≠ .ordinary (queried.input parameter) := by + intro h + exact heq (FtsSecretProbe.input_injective parameter (SplitHashKey.ordinary.inj h)) + apply hcovered.addPending _ _ probe + simpa only [Function.update_of_ne hne] using hcached + +theorem ProbeCacheCovered.fresh_of_unrevealed_new {parameter : PublicParameter} + {state : AdaptiveRevealProbe.State Coordinate} {cache : SplitHashCache} + (hcovered : ProbeCacheCovered parameter state cache) (probe : FtsSecretProbe) + (hhidden : state.revealed (probe.index, probe.tree, probe.leafIdx) = none) + (hnew : probe.candidate ∉ state.pending (probe.index, probe.tree, probe.leafIdx)) : + cache (.ordinary (probe.input parameter)) = none := by + by_contra hcached + exact (hcovered probe hcached).elim (fun h => h hhidden) hnew + +theorem ProbeCacheCovered.ordinary_probe_cached_merged {parameter : PublicParameter} + {table : Coordinate → Digest} {state : AdaptiveRevealProbe.State Coordinate} {cache : SplitHashCache} + (hcovered : ProbeCacheCovered parameter state cache) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state cache) (probe : FtsSecretProbe) + (hcached : cache (.ordinary (probe.input parameter)) ≠ none) : + mergedCache parameter table cache (probe.input parameter) ≠ none := by + unfold mergedCache + rw [decodeProbe?_input] + dsimp only + split_ifs with hhit + · have hrevealed : state.revealed (probe.index, probe.tree, probe.leafIdx) ≠ none := by + rcases hcovered probe hcached with h | hpending + · exact h + · exact (AdaptiveRevealProbe.not_mem_pending_of_tableHits_eq_false state table + (probe.index, probe.tree, probe.leafIdx) hclean + (by simpa only [← hhit] using hpending)).elim + obtain ⟨value, hvalue⟩ := Option.ne_none_iff_exists'.mp hrevealed + obtain ⟨_, answer, hanswer, _⟩ := hsynced _ _ hvalue + rw [hanswer] + simp + · exact hcached + +def probeCachedInputs (parameter : PublicParameter) (cache : QueryCache HashSpec) : Set HashInput := + {input | cache input ≠ none ∧ ∃ probe : FtsSecretProbe, probe.input parameter = input} + +theorem probeCachedInputs_finite (parameter : PublicParameter) {cache : QueryCache HashSpec} + (hfinite : Finite cache) : (probeCachedInputs parameter cache).Finite := + hfinite.subset (fun _ h => h.1) + +theorem ProbeCacheCovered.probeCachedInputs_subset_merged {parameter : PublicParameter} + {table : Coordinate → Digest} {state : AdaptiveRevealProbe.State Coordinate} {cache : SplitHashCache} + (hcovered : ProbeCacheCovered parameter state cache) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state cache) : + probeCachedInputs parameter (fun input => cache (.ordinary input)) ⊆ + probeCachedInputs parameter (mergedCache parameter table cache) := by + rintro input ⟨hcached, probe, rfl⟩ + exact ⟨hcovered.ordinary_probe_cached_merged hclean hsynced probe hcached, probe, rfl⟩ + +theorem ProbeCacheCovered.probeCachedInputs_ncard_le_merged {parameter : PublicParameter} + {table : Coordinate → Digest} {state : AdaptiveRevealProbe.State Coordinate} {cache : SplitHashCache} + (hcovered : ProbeCacheCovered parameter state cache) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state cache) + (hfinite : Finite (mergedCache parameter table cache)) : + (probeCachedInputs parameter (fun input => cache (.ordinary input))).ncard ≤ + (probeCachedInputs parameter (mergedCache parameter table cache)).ncard := + Set.ncard_le_ncard (hcovered.probeCachedInputs_subset_merged hclean hsynced) + (probeCachedInputs_finite parameter hfinite) + +theorem probeCachedInputs_cacheQuery_probe (parameter : PublicParameter) + (cache : QueryCache HashSpec) (probe : FtsSecretProbe) (answer : HashOutput) : + probeCachedInputs parameter (cache.cacheQuery (probe.input parameter) answer) = + insert (probe.input parameter) (probeCachedInputs parameter cache) := by + ext input + by_cases heq : input = probe.input parameter + · rw [heq] + simp only [probeCachedInputs, Set.mem_setOf_eq, QueryCache.cacheQuery_self, + Set.mem_insert_iff, true_or, iff_true] + exact ⟨by simp, probe, rfl⟩ + · simp only [probeCachedInputs, Set.mem_setOf_eq, QueryCache.cacheQuery_of_ne _ _ heq, + Set.mem_insert_iff, heq, false_or] + +theorem probeCachedInputs_update_probed (parameter : PublicParameter) (cache : SplitHashCache) + (probe : FtsSecretProbe) (answer : HashOutput) : + probeCachedInputs parameter + (fun input => Function.update cache (.ordinary (probe.input parameter)) (some answer) (.ordinary input)) = + insert (probe.input parameter) (probeCachedInputs parameter (fun input => cache (.ordinary input))) := by + have heq : (fun input => Function.update cache (.ordinary (probe.input parameter)) (some answer) (.ordinary input)) = + QueryCache.cacheQuery (spec := HashSpec) (fun input => cache (.ordinary input)) + (probe.input parameter) answer := by + funext input + by_cases hi : input = probe.input parameter + · rw [hi, Function.update_self, QueryCache.cacheQuery_self] + · rw [Function.update_of_ne (fun h => hi (SplitHashKey.ordinary.inj h)), + QueryCache.cacheQuery_of_ne _ _ hi] + rw [heq, probeCachedInputs_cacheQuery_probe] + +theorem ProbeCacheCovered.pendingCharge_le_cache_growth {parameter : PublicParameter} + {state : AdaptiveRevealProbe.State Coordinate} {cache : SplitHashCache} + (hcovered : ProbeCacheCovered parameter state cache) (probe : FtsSecretProbe) (answer : HashOutput) + (hhidden : state.revealed (probe.index, probe.tree, probe.leafIdx) = none) + (hfinite : (probeCachedInputs parameter (fun input => cache (.ordinary input))).Finite) : + (probeCachedInputs parameter (fun input => cache (.ordinary input))).ncard + + AdaptiveRevealProbe.pendingProbeCharge state (probe.index, probe.tree, probe.leafIdx) probe.candidate ≤ + (probeCachedInputs parameter + (fun input => Function.update cache (.ordinary (probe.input parameter)) (some answer) (.ordinary input))).ncard := by + rw [probeCachedInputs_update_probed] + by_cases hmem : probe.candidate ∈ state.pending (probe.index, probe.tree, probe.leafIdx) + · rw [AdaptiveRevealProbe.pendingProbeCharge, if_pos hmem, Nat.add_zero] + exact Set.ncard_le_ncard (Set.subset_insert _ _) (hfinite.insert _) + · rw [AdaptiveRevealProbe.pendingProbeCharge, if_neg hmem] + have hfresh := hcovered.fresh_of_unrevealed_new probe hhidden hmem + have hnot : probe.input parameter ∉ probeCachedInputs parameter (fun input => cache (.ordinary input)) := + fun h => h.1 hfresh + rw [Set.ncard_insert_of_notMem hnot hfinite] + +noncomputable def ftsHashQueryCharge (parameter : PublicParameter) + (_cache : QueryCache HashSpec) (input : HashInput) : ℝ≥0∞ := + open Classical in + if ∃ probe : FtsSecretProbe, probe.input parameter = input then 1 else 0 + +theorem probeCachedInputs_cacheQuery_nonprobe (parameter : PublicParameter) + (cache : QueryCache HashSpec) (input : HashInput) (answer : HashOutput) + (hinput : ¬ ∃ probe : FtsSecretProbe, probe.input parameter = input) : + probeCachedInputs parameter (cache.cacheQuery input answer) = probeCachedInputs parameter cache := by + ext other + by_cases heq : other = input + · rw [heq] + simp only [probeCachedInputs, Set.mem_setOf_eq, hinput, and_false] + · simp only [probeCachedInputs, Set.mem_setOf_eq, QueryCache.cacheQuery_of_ne _ _ heq] + +theorem probeCachedInputs_cacheQuery_ncard_le (parameter : PublicParameter) + (cache : QueryCache HashSpec) (input : HashInput) (answer : HashOutput) : + ((probeCachedInputs parameter (cache.cacheQuery input answer)).ncard : ℝ≥0∞) ≤ + (probeCachedInputs parameter cache).ncard + ftsHashQueryCharge parameter cache input := by + classical + unfold ftsHashQueryCharge + split_ifs with hprobe + · obtain ⟨probe, rfl⟩ := hprobe + rw [probeCachedInputs_cacheQuery_probe] + exact_mod_cast Set.ncard_insert_le (probe.input parameter) (probeCachedInputs parameter cache) + · rw [probeCachedInputs_cacheQuery_nonprobe parameter cache input answer hprobe, add_zero] + +theorem expected_probeCachedInputs_le_queryCharge {α : Type} + (parameter : PublicParameter) (computation : OracleComp OracleWorld α) : + (∑' result, Pr[= result | (simulateQ romImpl computation).run ∅] * + ((probeCachedInputs parameter result.2).ncard : ℝ≥0∞)) ≤ + expectedQueryCharge (ftsHashQueryCharge parameter) computation ∅ := by + let potential : QueryCache HashSpec → ℝ≥0∞ := fun cache => (probeCachedInputs parameter cache).ncard + have hstep (query : OracleWorld.Domain) (cache : QueryCache HashSpec) (hfinite : Finite cache) : + (∑' result, Pr[= result | (romImpl query).run cache] * potential result.2) ≤ + potential cache + hashQueryCharge (ftsHashQueryCharge parameter) cache query := by + apply expected_potential_romImpl_le_charge + · intro before hbefore input hfresh + calc + _ ≤ ∑' answer : HashOutput, Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (potential before + ftsHashQueryCharge parameter before input) := + ENNReal.tsum_le_tsum fun answer => mul_le_mul' le_rfl + (probeCachedInputs_cacheQuery_ncard_le parameter before input answer) + _ = _ := by rw [ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul] + · exact hfinite + have h := expected_potential_simulateQ_le_queryCharge potential (ftsHashQueryCharge parameter) + hstep computation ∅ finite_empty + have hempty : probeCachedInputs parameter (∅ : QueryCache HashSpec) = ∅ := by + ext input + simp only [probeCachedInputs, Set.mem_setOf_eq, QueryCache.empty_apply, ne_eq, not_true_eq_false, + false_and, Set.mem_empty_iff_false] + simpa only [potential, hempty, Set.ncard_empty, Nat.cast_zero, zero_add] using h + +theorem ftsHashQueryCharge_mul_two_le_residual (secretKey : SecretKey) + (cache : QueryCache HashSpec) (input : HashInput) : + ftsHashQueryCharge secretKey.parameter cache input * 2 ≤ + residualPrimitiveQueryCharge secretKey cache input := by + classical + unfold ftsHashQueryCharge + split_ifs with hprobe + · obtain ⟨probe, rfl⟩ := hprobe + rw [one_mul] + exact residualPrimitiveQueryCharge_ge_two_ftsProbe secretKey cache probe + · rw [zero_mul] + exact bot_le + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostActions.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostActions.lean new file mode 100644 index 00000000..45ff5195 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostActions.lean @@ -0,0 +1,96 @@ +import SphincsSecurity.Proof.FtsProbeCostInvariant + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +set_option maxRecDepth 10000 in +theorem probeCostInvariant_probingHashQuery (parameter : PublicParameter) (input : HashInput) : + ProbeCostInvariant parameter (probingHashQuery parameter input) := by + intro table state cache fuel hcovered hfinite hit finalState output finalCache cost hresult + rw [probingHashQuery_run_eq] at hresult + cases hdecode : decodeProbe? parameter input with + | none => + have hnot := (decodeProbe?_eq_none_iff parameter input).mp hdecode + apply probeCostInvariant_splitHashQuery_nonprobe parameter input hnot + table state cache fuel hcovered hfinite hit finalState output finalCache cost + simpa only [hdecode] using hresult + | some probe => + have hinput := (decodeProbe?_eq_some_iff parameter input probe).mp hdecode + simp only [hdecode] at hresult + rw [AdaptiveRevealProbe.probeQuery, AdaptiveRevealProbe.runCharged, + OracleComp.construct_query_bind] at hresult + cases fuel with + | zero => + simp only [support_pure, Set.mem_singleton_iff, Prod.mk.injEq, reduceCtorEq, false_and] at hresult + | succ remaining => + cases hrevealed : state.revealed (probe.index, probe.tree, probe.leafIdx) with + | some revealed => + simp only [hrevealed] at hresult + have hsupport := AdaptiveRevealProbe.runCharged_done_mem_support table state finalState remaining + ((splitHashQuery (.ordinary input)).run cache) hit (output, finalCache) cost hresult + obtain ⟨rfl, rfl⟩ := AdaptiveRevealProbe.runCharged_done_stateFree table state finalState remaining + ((splitHashQuery (.ordinary input)).run cache) (splitHashQuery_stateFree _ cache) + hit (output, finalCache) cost hresult + rcases splitHashQuery_support_cache (.ordinary input) cache finalCache output hsupport with + ⟨rfl, _⟩ | rfl + · exact ⟨hcovered, hfinite, by omega⟩ + · rw [← hinput] + have hcoveredAfter := hcovered.update_revealed probe output (by simp [hrevealed]) + have hsets := probeCachedInputs_update_probed parameter cache probe output + refine ⟨hcoveredAfter, ?_, ?_⟩ + · change (probeCachedInputs parameter _).Finite + rw [hsets] + exact hfinite.insert _ + · change _ ≤ (probeCachedInputs parameter _).ncard + rw [hsets, Nat.add_zero] + exact Set.ncard_le_ncard (Set.subset_insert _ _) (hfinite.insert _) + | none => + simp only [hrevealed, support_map, Set.mem_image] at hresult + obtain ⟨⟨previousResult, previousCost⟩, hrest, heq⟩ := hresult + have hfirst : previousResult = .done hit finalState (output, finalCache) := congrArg Prod.fst heq + have hcost : previousCost + AdaptiveRevealProbe.pendingProbeCharge state + (probe.index, probe.tree, probe.leafIdx) probe.candidate = cost := congrArg Prod.snd heq + rw [hfirst] at hrest + have hsupport := AdaptiveRevealProbe.runCharged_done_mem_support table + (state.addPending (probe.index, probe.tree, probe.leafIdx) probe.candidate) finalState remaining + ((splitHashQuery (.ordinary input)).run cache) hit (output, finalCache) previousCost hrest + obtain ⟨rfl, rfl⟩ := AdaptiveRevealProbe.runCharged_done_stateFree table + (state.addPending (probe.index, probe.tree, probe.leafIdx) probe.candidate) finalState remaining + ((splitHashQuery (.ordinary input)).run cache) (splitHashQuery_stateFree _ cache) + hit (output, finalCache) previousCost hrest + rw [Nat.zero_add] at hcost + rw [← hcost] + rcases splitHashQuery_support_cache (.ordinary input) cache finalCache output hsupport with + ⟨rfl, hcached⟩ | rfl + · have hmem : probe.candidate ∈ state.pending (probe.index, probe.tree, probe.leafIdx) := by + apply (hcovered probe ?_).resolve_left + · exact fun h => h hrevealed + · rw [hinput, hcached] + simp + refine ⟨hcovered.addPending _ _, hfinite, ?_⟩ + rw [AdaptiveRevealProbe.pendingProbeCharge, if_pos hmem, Nat.add_zero] + · rw [← hinput] + refine ⟨hcovered.update_probed probe output, ?_, + hcovered.pendingCharge_le_cache_growth probe output hrevealed hfinite⟩ + change (probeCachedInputs parameter _).Finite + rw [probeCachedInputs_update_probed] + exact hfinite.insert _ + +theorem probeCostInvariant_hiddenFtsLeafHash (parameter : PublicParameter) (coordinate : Coordinate) : + ProbeCostInvariant parameter (hiddenFtsLeafHash parameter coordinate) := by + unfold hiddenFtsLeafHash + exact (probeCostInvariant_splitHashQuery_hidden parameter coordinate).bind fun output => + ProbeCostInvariant.pure parameter (truncateHash output) + +theorem probeCostInvariant_ordinaryTweakableHash (parameter : PublicParameter) + (domain : HashDomain) (payload : HashInput) + (hordinary : ∀ table : Coordinate → Digest, + IsOrdinaryInput parameter table (tweakableHashInput parameter domain payload)) : + ProbeCostInvariant parameter (ordinaryTweakableHash parameter domain payload) := by + unfold ordinaryTweakableHash + exact (probeCostInvariant_splitHashQuery_nonprobe parameter _ + (no_probe_of_ordinary_all parameter _ hordinary)).bind fun output => + ProbeCostInvariant.pure parameter (truncateHash output) + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostBound.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostBound.lean new file mode 100644 index 00000000..868721fe --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostBound.lean @@ -0,0 +1,71 @@ +import SphincsSecurity.Proof.FtsProbeActualQueryCost + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +theorem cost_le_four_thirds_of_feedback (cost actual probability : ℝ≥0∞) (q : Nat) + (hcost : cost ≤ q) (hq : q ≤ 2 ^ 126) + (hfeedback : cost ≤ actual + probability * q) + (hprobability : probability ≤ cost * (Fintype.card Digest : ℝ≥0∞)⁻¹) : + cost ≤ (4 / 3 : ℝ≥0∞) * actual := by + classical + rcases Classical.em (actual = ∞) with hactual | hactual + · simp [hactual] + have hfinite : cost ≠ ∞ := ne_top_of_le_ne_top (by finiteness) hcost + let fraction : ℝ≥0∞ := (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + have hbound : cost ≤ actual + cost * fraction := by + apply hfeedback.trans + apply add_le_add le_rfl + apply (mul_le_mul' hprobability le_rfl).trans_eq + dsimp [fraction] + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + ring + have hcoefficient := OtsProbeSimulation.rootBudget_four_thirds hq + change fraction * (4 / 3 : ℝ≥0∞) + 1 ≤ (4 / 3 : ℝ≥0∞) at hcoefficient + have hboundReal := (ENNReal.toReal_le_toReal hfinite (by dsimp [fraction]; finiteness)).mpr hbound + have hcoefficientReal := (ENNReal.toReal_le_toReal (by dsimp [fraction]; finiteness) + (by finiteness)).mpr hcoefficient + rw [ENNReal.toReal_add hactual (by dsimp [fraction]; finiteness), ENNReal.toReal_mul] at hboundReal + rw [ENNReal.toReal_add (by dsimp [fraction]; finiteness) (by norm_num), + ENNReal.toReal_mul, ENNReal.toReal_one] at hcoefficientReal + apply (ENNReal.toReal_le_toReal hfinite (by finiteness)).mp + rw [ENNReal.toReal_mul] + have hscaled := mul_le_mul_of_nonneg_right hboundReal + (show 0 ≤ (4 / 3 : ℝ≥0∞).toReal from ENNReal.toReal_nonneg) + have hcancel := mul_le_mul_of_nonneg_left hcoefficientReal cost.toReal_nonneg + nlinarith + +theorem maskedFtsProbeCharge_le_four_thirds_actual_cache + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (q : Nat) (hq : q ≤ 2 ^ 126) + (hbound : ∀ table : Coordinate → Digest, (gameAfterSecrets adversary parameter otsSecret + (fun index tree leafIdx => table (index, tree, leafIdx))).IsQueryBoundP (· matches Sum.inr _) q) : + maskedFtsProbeCharge adversary parameter otsSecret q ≤ + (4 / 3 : ℝ≥0∞) * sampledActualFtsCacheCount adversary parameter otsSecret := by + letI : Nonempty Coordinate := + ⟨(⟨0, by norm_num [totalHeight]⟩, ⟨0, by norm_num [ftsTrees]⟩, + ⟨0, by norm_num [ftsTreeHeight]⟩)⟩ + apply cost_le_four_thirds_of_feedback _ _ _ q (maskedFtsProbeCharge_le_q _ _ _ _) hq + (maskedFtsProbeCharge_le_actual_cache_add_hit adversary parameter otsSecret q hbound) + simpa only [AdaptiveRevealProbe.chargedExperiment_expectedCost_eq, maskedFtsProbeCharge] using + AdaptiveRevealProbe.chargedExperiment_probability_le_expectedCost q + ((maskedRetainedGameAfterSecrets adversary parameter otsSecret).run emptySplitHashCache) + +theorem maskedFtsProbeCharge_le_four_thirds_queryCharge + (adversary : Adversary) (parameter : PublicParameter) + (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + maskedFtsProbeCharge adversary parameter otsSecret q ≤ + (4 / 3 : ℝ≥0∞) * ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + expectedQueryCharge (ftsHashQueryCharge parameter) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ := by + apply (maskedFtsProbeCharge_le_four_thirds_actual_cache adversary parameter otsSecret q hqMax ?_).trans + · exact mul_le_mul' le_rfl (sampledActualFtsCacheCount_le_queryCharge adversary parameter otsSecret) + · intro table + exact isQueryBoundP_gameAfterSecrets adversary q hq hparameter hots + (mem_support_sampleFtsSecrets (fun index tree leafIdx => table (index, tree, leafIdx))) + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostComparison.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostComparison.lean new file mode 100644 index 00000000..d0b40a35 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostComparison.lean @@ -0,0 +1,69 @@ +import SphincsSecurity.Proof.FtsProbeCostCoupling +import SphincsSecurity.Proof.OtsProbeRootBudget + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +noncomputable def sampledActualFtsCacheCount (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) : ℝ≥0∞ := + ∑' result, Pr[= result | sampledActualRetainedFts adversary parameter otsSecret] * + (probeCachedInputs parameter result.2.2).ncard + +set_option maxRecDepth 30000 in +theorem relTriple_chargedExperiment_cost_le_actual_cache_add_hit + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (q : Nat) + (hbound : ∀ table : Coordinate → Digest, (gameAfterSecrets adversary parameter otsSecret + (fun index tree leafIdx => table (index, tree, leafIdx))).IsQueryBoundP (· matches Sum.inr _) q) : + RelTriple + (AdaptiveRevealProbe.chargedExperiment AdaptiveRevealProbe.State.empty q + ((maskedRetainedGameAfterSecrets adversary parameter otsSecret).run emptySplitHashCache)) + (sampledActualRetainedFts adversary parameter otsSecret) + (fun charged actual => (charged.2 : ℝ≥0∞) ≤ (probeCachedInputs parameter actual.2.2).ncard + + if charged.1.hit = true then (q : ℝ≥0∞) else 0) := by + classical + unfold AdaptiveRevealProbe.chargedExperiment sampledActualRetainedFts + apply relTriple_bind (relTriple_refl (AdaptiveRevealProbe.sampleTable (Coordinate := Coordinate))) + intro table other heq + cases heq + have hextend : AdaptiveRevealProbe.extendTable + (AdaptiveRevealProbe.State.empty : AdaptiveRevealProbe.State Coordinate) table = table := by + funext coordinate + simp [AdaptiveRevealProbe.extendTable, AdaptiveRevealProbe.State.empty] + rw [hextend] + have hrel := relTriple_runCharged_maskedRetainedGameAfterSecrets adversary parameter otsSecret table q (hbound table) + have hcost := relTriple_post_mono hrel (fun {charged actual} h => + runCharged_cost_le_actual_cache_add_hit adversary parameter otsSecret table q charged actual h.1 h.2) + simpa only [id_map, map_eq_bind_pure_comp, Function.comp_def, id_eq, bind_pure] using + (relTriple_map (f := id) (g := fun actual => (table, actual)) + (R := fun (charged : AdaptiveRevealProbe.DetailedResult Coordinate + (RetainedGameResult × SplitHashCache) × Nat) + (actual : (Coordinate → Digest) × (RetainedGameResult × QueryCache HashSpec)) => + (charged.2 : ℝ≥0∞) ≤ (probeCachedInputs parameter actual.2.2).ncard + + if charged.1.hit = true then (q : ℝ≥0∞) else 0) hcost) + +theorem maskedFtsProbeCharge_le_actual_cache_add_hit + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (q : Nat) + (hbound : ∀ table : Coordinate → Digest, (gameAfterSecrets adversary parameter otsSecret + (fun index tree leafIdx => table (index, tree, leafIdx))).IsQueryBoundP (· matches Sum.inr _) q) : + maskedFtsProbeCharge adversary parameter otsSecret q ≤ sampledActualFtsCacheCount adversary parameter otsSecret + + Pr[fun result => result.1.hit = true | + AdaptiveRevealProbe.chargedExperiment AdaptiveRevealProbe.State.empty q + ((maskedRetainedGameAfterSecrets adversary parameter otsSecret).run emptySplitHashCache)] * q := by + classical + have hcost := expected_cost_le_of_relTriple + (relTriple_chargedExperiment_cost_le_actual_cache_add_hit adversary parameter otsSecret q hbound) + (fun charged => (charged.2 : ℝ≥0∞)) (fun actual => (probeCachedInputs parameter actual.2.2).ncard) + (fun charged => if charged.1.hit = true then (q : ℝ≥0∞) else 0) (fun _ _ h => h) + rw [AdaptiveRevealProbe.chargedExperiment_expectedCost_eq] at hcost + apply hcost.trans_eq + congr 1 + rw [probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_right] + apply tsum_congr + intro result + split_ifs <;> simp + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostCoupling.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostCoupling.lean new file mode 100644 index 00000000..582703ed --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostCoupling.lean @@ -0,0 +1,73 @@ +import SphincsSecurity.Proof.FtsProbeCostExecution +import SphincsSecurity.Proof.CoupledQueryCost + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +theorem probeCachedInputs_finite_univ (parameter : PublicParameter) (cache : QueryCache HashSpec) : + (probeCachedInputs parameter cache).Finite := by + let encode := fun pair : Coordinate × Digest => + (⟨pair.1.1, pair.1.2.1, pair.1.2.2, pair.2⟩ : FtsSecretProbe).input parameter + apply (Set.finite_range encode).subset + rintro input ⟨_, probe, rfl⟩ + exact ⟨((probe.index, probe.tree, probe.leafIdx), probe.candidate), rfl⟩ + +set_option maxRecDepth 30000 in +theorem relTriple_runCharged_maskedRetainedGameAfterSecrets + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (table : Coordinate → Digest) (q : Nat) + (hbound : (gameAfterSecrets adversary parameter otsSecret + (fun index tree leafIdx => table (index, tree, leafIdx))).IsQueryBoundP + (· matches Sum.inr _) q) : + RelTriple + (AdaptiveRevealProbe.runCharged table AdaptiveRevealProbe.State.empty q + ((maskedRetainedGameAfterSecrets adversary parameter otsSecret).run emptySplitHashCache)) + (actualRetainedGameAfterSecrets adversary parameter otsSecret table) + (fun charged actual => CleanStepRel parameter table charged.1 actual ∧ + charged ∈ support (AdaptiveRevealProbe.runCharged table AdaptiveRevealProbe.State.empty q + ((maskedRetainedGameAfterSecrets adversary parameter otsSecret).run emptySplitHashCache))) := by + classical + have hgraph := SphincsSecurity.relTriple_of_evalDist_map_eq_with_support_general + (AdaptiveRevealProbe.runCharged table AdaptiveRevealProbe.State.empty q + ((maskedRetainedGameAfterSecrets adversary parameter otsSecret).run emptySplitHashCache)) + (AdaptiveRevealProbe.runDetailed table AdaptiveRevealProbe.State.empty q + ((maskedRetainedGameAfterSecrets adversary parameter otsSecret).run emptySplitHashCache)) + Prod.fst id (by simp only [id_map, AdaptiveRevealProbe.runCharged_result_eq_runDetailed]) + apply relTriple_post_mono (SphincsSecurity.relTriple_trans_exists hgraph + (relTriple_maskedRetainedGameAfterSecrets adversary parameter otsSecret table q hbound)) + rintro charged actual ⟨detailed, ⟨heq, hsupport, _⟩, hclean⟩ + exact ⟨by simpa only [heq, id_eq] using hclean, hsupport⟩ + +theorem runCharged_cost_le_actual_cache_add_hit (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (table : Coordinate → Digest) (q : Nat) + (charged : AdaptiveRevealProbe.DetailedResult Coordinate (RetainedGameResult × SplitHashCache) × Nat) + (actual : RetainedGameResult × QueryCache HashSpec) + (hclean : CleanStepRel parameter table charged.1 actual) + (hsupport : charged ∈ support (AdaptiveRevealProbe.runCharged table AdaptiveRevealProbe.State.empty q + ((maskedRetainedGameAfterSecrets adversary parameter otsSecret).run emptySplitHashCache))) : + (charged.2 : ℝ≥0∞) ≤ (probeCachedInputs parameter actual.2).ncard + + if charged.1.hit = true then (q : ℝ≥0∞) else 0 := by + classical + by_cases hhit : charged.1.hit = true + · rw [if_pos hhit] + exact (Nat.cast_le.mpr (AdaptiveRevealProbe.runCharged_cost_le_fuel _ _ _ _ charged hsupport)).trans + (le_add_left le_rfl) + · rw [if_neg hhit, add_zero] + have hcleanResult := hclean.resolve_left hhit + rcases charged with ⟨detailed, cost⟩ + cases detailed with + | stopped hit => exact hcleanResult.elim + | done hit state result => + obtain ⟨value, cache⟩ := result + obtain ⟨_, rfl, htable, hsynced⟩ := hcleanResult + obtain ⟨hcovered, _, hcost⟩ := runCharged_maskedRetainedGameAfterSecrets_cost_le_cache + adversary parameter otsSecret table q hit state value cache cost hsupport + exact_mod_cast hcost.trans (Set.ncard_le_ncard + (hcovered.probeCachedInputs_subset_merged htable hsynced) + (probeCachedInputs_finite_univ parameter (mergedCache parameter table cache))) + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostExecution.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostExecution.lean new file mode 100644 index 00000000..080fb021 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostExecution.lean @@ -0,0 +1,61 @@ +import SphincsSecurity.Proof.FtsProbeCostSigning + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +theorem probeCostInvariant_probingRomImpl (parameter : PublicParameter) (input : OracleWorld.Domain) : + ProbeCostInvariant parameter (probingRomImpl parameter input) := by + cases input with + | inl n => exact probeCostInvariant_splitUniformImpl parameter n + | inr input => exact probeCostInvariant_probingHashQuery parameter input + +theorem probeCostInvariant_maskedExpandedAdversaryImpl (secretKey : SecretKey) + (input : (OracleWorld + SigningSpec).Domain) : + ProbeCostInvariant secretKey.parameter + (maskedExpandedAdversaryImpl secretKey.parameter secretKey input) := by + cases input with + | inl input => exact probeCostInvariant_probingRomImpl secretKey.parameter input + | inr request => exact probeCostInvariant_maskedSigningImpl secretKey request + +theorem probeCostInvariant_simulateQ_maskedExpandedAdversaryImpl {α : Type} (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + ProbeCostInvariant secretKey.parameter + (simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + rw [simulateQ_pure] + exact ProbeCostInvariant.pure secretKey.parameter value + | query_bind input next ih => + rw [simulateQ_query_bind] + exact (probeCostInvariant_maskedExpandedAdversaryImpl secretKey input).bind ih + +theorem probeCostInvariant_maskedRetainedGameAfterSecrets (adversary : Adversary) + (parameter : PublicParameter) (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) : + ProbeCostInvariant parameter (maskedRetainedGameAfterSecrets adversary parameter otsSecret) := by + unfold maskedRetainedGameAfterSecrets + apply (probeCostInvariant_simulateQ_ordinaryHashImpl parameter _ fun table => + ordinaryOnly_treeRoot parameter table topLayer rootTree (otsSecret topLayer rootTree)).bind + intro root + exact (probeCostInvariant_simulateQ_maskedExpandedAdversaryImpl + (⟨parameter, root, otsSecret, fun _ _ _ => 0⟩ : SecretKey) _).bind fun result => + ProbeCostInvariant.pure parameter (root, result) + +theorem runCharged_maskedRetainedGameAfterSecrets_cost_le_cache (adversary : Adversary) + (parameter : PublicParameter) (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (table : Coordinate → Digest) (q : Nat) (hit : Bool) (state : AdaptiveRevealProbe.State Coordinate) + (value : RetainedGameResult) (cache : SplitHashCache) (cost : Nat) + (hresult : (.done hit state (value, cache), cost) ∈ support + (AdaptiveRevealProbe.runCharged table AdaptiveRevealProbe.State.empty q + ((maskedRetainedGameAfterSecrets adversary parameter otsSecret).run emptySplitHashCache))) : + ProbeCacheCovered parameter state cache ∧ (splitProbeInputs parameter cache).Finite ∧ + cost ≤ (splitProbeInputs parameter cache).ncard := by + have hempty : splitProbeInputs parameter emptySplitHashCache = ∅ := by + ext input + simp [splitProbeInputs, probeCachedInputs, emptySplitHashCache] + have hbound := probeCostInvariant_maskedRetainedGameAfterSecrets adversary parameter otsSecret + table AdaptiveRevealProbe.State.empty emptySplitHashCache q (probeCacheCovered_empty parameter) + (by rw [hempty]; exact Set.finite_empty) hit state value cache cost hresult + simpa only [hempty, Set.ncard_empty, Nat.zero_add] using hbound + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostInvariant.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostInvariant.lean new file mode 100644 index 00000000..df26bc4c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostInvariant.lean @@ -0,0 +1,232 @@ +import SphincsSecurity.Proof.FtsProbeCacheCharge +import SphincsSecurity.Proof.AdaptiveRevealProbeCostBind + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open _root_.OracleComp + +abbrev splitProbeInputs (parameter : PublicParameter) (cache : SplitHashCache) : Set HashInput := + probeCachedInputs parameter (fun input => cache (.ordinary input)) + +def ProbeCostInvariant {α : Type} (parameter : PublicParameter) + (computation : StateT SplitHashCache (OracleComp (AdaptiveRevealProbe.World Coordinate)) α) : Prop := + ∀ table state cache fuel, ProbeCacheCovered parameter state cache → (splitProbeInputs parameter cache).Finite → + ∀ hit finalState value finalCache cost, + (.done hit finalState (value, finalCache), cost) ∈ support + (AdaptiveRevealProbe.runCharged table state fuel (computation.run cache)) → + ProbeCacheCovered parameter finalState finalCache ∧ (splitProbeInputs parameter finalCache).Finite ∧ + (splitProbeInputs parameter cache).ncard + cost ≤ (splitProbeInputs parameter finalCache).ncard + +theorem ProbeCostInvariant.pure {α : Type} (parameter : PublicParameter) (value : α) : + ProbeCostInvariant parameter (pure value) := by + intro table state cache fuel hcovered hfinite hit finalState result finalCache cost hresult + simp only [StateT.run_pure, AdaptiveRevealProbe.runCharged, OracleComp.construct_pure, + support_pure, Set.mem_singleton_iff, Prod.mk.injEq, AdaptiveRevealProbe.DetailedResult.done.injEq] at hresult + obtain ⟨⟨_, rfl, ⟨_, rfl⟩⟩, rfl⟩ := hresult + exact ⟨hcovered, hfinite, by omega⟩ + +theorem ProbeCostInvariant.bind {α β : Type} {parameter : PublicParameter} + {left : StateT SplitHashCache (OracleComp (AdaptiveRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache (OracleComp (AdaptiveRevealProbe.World Coordinate)) β} + (hleft : ProbeCostInvariant parameter left) (hnext : ∀ value, ProbeCostInvariant parameter (next value)) : + ProbeCostInvariant parameter (left >>= next) := by + intro table state cache fuel hcovered hfinite hit finalState value finalCache cost hresult + rw [StateT.run_bind] at hresult + obtain ⟨middleState, ⟨middleValue, middleCache⟩, middleFuel, leftCost, rightCost, + _, hfirst, hsecond, hcost⟩ := + AdaptiveRevealProbe.runCharged_bind_done_support table (left.run cache) + (fun result => (next result.1).run result.2) state fuel hit finalState (value, finalCache) cost hresult + obtain ⟨hcoveredMiddle, hfiniteMiddle, hcountFirst⟩ := + hleft table state cache fuel hcovered hfinite _ middleState middleValue middleCache leftCost hfirst + obtain ⟨hcoveredFinal, hfiniteFinal, hcountSecond⟩ := + hnext middleValue table middleState middleCache middleFuel hcoveredMiddle hfiniteMiddle + hit finalState value finalCache rightCost hsecond + exact ⟨hcoveredFinal, hfiniteFinal, by omega⟩ + +theorem ProbeCostInvariant.map {α β : Type} {parameter : PublicParameter} + {computation : StateT SplitHashCache (OracleComp (AdaptiveRevealProbe.World Coordinate)) α} + (hcomputation : ProbeCostInvariant parameter computation) (transform : α → β) : + ProbeCostInvariant parameter (transform <$> computation) := by + rw [map_eq_bind_pure_comp] + exact hcomputation.bind fun value => ProbeCostInvariant.pure parameter (transform value) + +theorem probeCostInvariant_of_stateFree {α : Type} (parameter : PublicParameter) + (computation : StateT SplitHashCache (OracleComp (AdaptiveRevealProbe.World Coordinate)) α) + (hstateFree : StateFree computation) + (hentries : ∀ cache result, result ∈ support (computation.run cache) → ∀ probe : FtsSecretProbe, + result.2 (.ordinary (probe.input parameter)) = cache (.ordinary (probe.input parameter))) : + ProbeCostInvariant parameter computation := by + intro table state cache fuel hcovered hfinite hit finalState value finalCache cost hresult + have hsupport := AdaptiveRevealProbe.runCharged_done_mem_support table state finalState fuel + (computation.run cache) hit (value, finalCache) cost hresult + obtain ⟨rfl, rfl⟩ := AdaptiveRevealProbe.runCharged_done_stateFree table state finalState fuel + (computation.run cache) (hstateFree cache) hit (value, finalCache) cost hresult + have hsets : splitProbeInputs parameter finalCache = splitProbeInputs parameter cache := by + ext input + constructor + · rintro ⟨hcached, probe, rfl⟩ + have he := hentries cache (value, finalCache) hsupport probe + dsimp only at he + exact ⟨by simpa only [he] using hcached, probe, rfl⟩ + · rintro ⟨hcached, probe, rfl⟩ + have he := hentries cache (value, finalCache) hsupport probe + dsimp only at he + exact ⟨by simpa only [he] using hcached, probe, rfl⟩ + refine ⟨?_, by simpa only [hsets] using hfinite, by rw [hsets, Nat.add_zero]⟩ + intro probe hcached + apply hcovered probe + rwa [← hentries cache (value, finalCache) hsupport probe] + +theorem probeCostInvariant_splitHashQuery_hidden (parameter : PublicParameter) (coordinate : Coordinate) : + ProbeCostInvariant parameter (splitHashQuery (.hiddenLeaf coordinate)) := by + apply probeCostInvariant_of_stateFree parameter _ (splitHashQuery_stateFree _) + intro cache result hresult probe + rw [splitHashQuery_run_eq] at hresult + cases hlookup : cache (.hiddenLeaf coordinate) with + | some answer => + simp only [hlookup, support_pure, Set.mem_singleton_iff] at hresult + rw [hresult] + | none => + simp only [hlookup, mem_support_bind_iff] at hresult + obtain ⟨answer, _, hresult⟩ := hresult + simp only [support_pure, Set.mem_singleton_iff] at hresult + rw [hresult] + exact Function.update_of_ne (by simp : SplitHashKey.ordinary (probe.input parameter) ≠ + SplitHashKey.hiddenLeaf coordinate) (some answer) cache + +theorem probeCostInvariant_splitHashQuery_nonprobe (parameter : PublicParameter) (input : HashInput) + (hinput : ∀ probe : FtsSecretProbe, probe.input parameter ≠ input) : + ProbeCostInvariant parameter (splitHashQuery (.ordinary input)) := by + apply probeCostInvariant_of_stateFree parameter _ (splitHashQuery_stateFree _) + intro cache result hresult probe + rw [splitHashQuery_run_eq] at hresult + cases hlookup : cache (.ordinary input) with + | some answer => + simp only [hlookup, support_pure, Set.mem_singleton_iff] at hresult + rw [hresult] + | none => + simp only [hlookup, mem_support_bind_iff] at hresult + obtain ⟨answer, _, hresult⟩ := hresult + simp only [support_pure, Set.mem_singleton_iff] at hresult + rw [hresult] + exact Function.update_of_ne (fun heq => hinput probe (SplitHashKey.ordinary.inj heq)) (some answer) cache + +theorem probeCostInvariant_splitUniformImpl (parameter : PublicParameter) (n : unifSpec.Domain) : + ProbeCostInvariant parameter (splitUniformImpl n) := by + apply probeCostInvariant_of_stateFree parameter _ (splitUniformImpl_stateFree n) + intro cache result hresult probe + unfold splitUniformImpl at hresult + rw [StateT.run_liftM, mem_support_bind_iff] at hresult + obtain ⟨answer, _, hresult⟩ := hresult + simp only [support_pure, Set.mem_singleton_iff] at hresult + rw [hresult] + +theorem no_probe_of_ordinary_all (parameter : PublicParameter) (input : HashInput) + (hordinary : ∀ table : Coordinate → Digest, IsOrdinaryInput parameter table input) : + ∀ probe : FtsSecretProbe, probe.input parameter ≠ input := by + intro probe heq + exact hordinary (fun _ => probe.candidate) probe + ((decodeProbe?_eq_some_iff parameter input probe).mpr heq) rfl + +theorem probeCostInvariant_simulateQ_ordinaryHashImpl {α : Type} (parameter : PublicParameter) + (computation : OracleComp HashSpec α) + (hordinary : ∀ table : Coordinate → Digest, OrdinaryOnly parameter table computation) : + ProbeCostInvariant parameter (simulateQ ordinaryHashImpl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + rw [simulateQ_pure] + exact ProbeCostInvariant.pure parameter value + | query_bind input next ih => + have hstep (table : Coordinate → Digest) : IsOrdinaryInput parameter table input := by + have hbound := hordinary table + rw [OrdinaryOnly, isQueryBoundP_query_bind_iff] at hbound + by_contra hnot + simpa [NonOrdinaryInput, hnot] using hbound.1 + rw [simulateQ_query_bind] + apply (probeCostInvariant_splitHashQuery_nonprobe parameter input + (no_probe_of_ordinary_all parameter input hstep)).bind + intro output + apply ih output + intro table + have hbound := hordinary table + rw [OrdinaryOnly, isQueryBoundP_query_bind_iff] at hbound + simpa [OrdinaryOnly, NonOrdinaryInput, hstep table] using hbound.2 output + +theorem probeCostInvariant_simulateQ_splitRomImpl {α : Type} (parameter : PublicParameter) + (computation : OracleComp OracleWorld α) + (hordinary : ∀ table : Coordinate → Digest, RomOrdinaryOnly parameter table computation) : + ProbeCostInvariant parameter (simulateQ splitRomImpl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + rw [simulateQ_pure] + exact ProbeCostInvariant.pure parameter value + | query_bind input next ih => + rw [simulateQ_query_bind] + cases input with + | inl n => + apply (probeCostInvariant_splitUniformImpl parameter n).bind + intro output + apply ih output + intro table + have hbound := hordinary table + rw [RomOrdinaryOnly, isQueryBoundP_query_bind_iff] at hbound + simpa [RomOrdinaryOnly] using hbound.2 output + | inr input => + have hstep (table : Coordinate → Digest) : IsOrdinaryInput parameter table input := by + have hbound := hordinary table + rw [RomOrdinaryOnly, isQueryBoundP_query_bind_iff] at hbound + by_contra hnot + simpa [NonOrdinaryInput, hnot] using hbound.1 + apply (probeCostInvariant_splitHashQuery_nonprobe parameter input + (no_probe_of_ordinary_all parameter input hstep)).bind + intro output + apply ih output + intro table + have hbound := hordinary table + rw [RomOrdinaryOnly, isQueryBoundP_query_bind_iff] at hbound + simpa [RomOrdinaryOnly, NonOrdinaryInput, hstep table] using hbound.2 output + +theorem probeCostInvariant_sequenceFin {α : Type} {n : Nat} (parameter : PublicParameter) + (computation : Fin n → StateT SplitHashCache (OracleComp (AdaptiveRevealProbe.World Coordinate)) α) + (hcomputation : ∀ position, ProbeCostInvariant parameter (computation position)) : + ProbeCostInvariant parameter (sequenceFin computation) := by + induction n with + | zero => exact ProbeCostInvariant.pure parameter (Fin.elim0 : Fin 0 → α) + | succ n ih => + rw [sequenceFin] + exact (hcomputation 0).bind fun head => + (ih (fun position => computation position.succ) (fun position => hcomputation position.succ)).bind + fun tail => ProbeCostInvariant.pure parameter (Fin.cases head tail : Fin (n + 1) → α) + +theorem splitHashQuery_support_cache (key : SplitHashKey) (cache finalCache : SplitHashCache) + (output : HashOutput) (hresult : (output, finalCache) ∈ support ((splitHashQuery key).run cache)) : + (finalCache = cache ∧ cache key = some output) ∨ + finalCache = Function.update cache key (some output) := by + rw [splitHashQuery_run_eq] at hresult + cases hlookup : cache key with + | some answer => + simp only [hlookup, support_pure, Set.mem_singleton_iff, Prod.mk.injEq] at hresult + exact Or.inl ⟨hresult.2, by simpa only [hresult.1] using hlookup⟩ + | none => + simp only [hlookup, mem_support_bind_iff] at hresult + obtain ⟨answer, _, hresult⟩ := hresult + simp only [support_pure, Set.mem_singleton_iff, Prod.mk.injEq] at hresult + exact Or.inr (by simpa only [hresult.1] using hresult.2) + +theorem ProbeCacheCovered.update_revealed {parameter : PublicParameter} + {state : AdaptiveRevealProbe.State Coordinate} {cache : SplitHashCache} + (hcovered : ProbeCacheCovered parameter state cache) (queried : FtsSecretProbe) (answer : HashOutput) + (hrevealed : state.revealed (queried.index, queried.tree, queried.leafIdx) ≠ none) : + ProbeCacheCovered parameter state + (Function.update cache (.ordinary (queried.input parameter)) (some answer)) := by + intro probe hcached + by_cases heq : probe = queried + · rw [heq] + exact Or.inl hrevealed + · apply hcovered probe + have hne : SplitHashKey.ordinary (probe.input parameter) ≠ .ordinary (queried.input parameter) := + fun h => heq (FtsSecretProbe.input_injective parameter (SplitHashKey.ordinary.inj h)) + simpa only [Function.update_of_ne hne] using hcached + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostReveal.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostReveal.lean new file mode 100644 index 00000000..16b7d78b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostReveal.lean @@ -0,0 +1,75 @@ +import SphincsSecurity.Proof.FtsProbeCostActions + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +set_option maxRecDepth 10000 in +theorem runCharged_revealTail_bound (parameter : PublicParameter) (coordinate : Coordinate) + (table : Coordinate → Digest) (state : AdaptiveRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (revealedValue : Digest) + (hcovered : ProbeCacheCovered parameter state cache) (hfinite : (splitProbeInputs parameter cache).Finite) + (hknown : state.revealed coordinate ≠ none) + (hit : Bool) (finalState : AdaptiveRevealProbe.State Coordinate) (value : Digest) + (finalCache : SplitHashCache) (cost : Nat) + (hresult : (.done hit finalState (value, finalCache), cost) ∈ support + (AdaptiveRevealProbe.runCharged table state fuel + ((splitHashQuery (.hiddenLeaf coordinate)).run cache >>= fun result => + pure (revealedValue, Function.update result.2 + (.ordinary ((⟨coordinate.1, coordinate.2.1, coordinate.2.2, revealedValue⟩ : FtsSecretProbe).input parameter)) + (some result.1))))) : + ProbeCacheCovered parameter finalState finalCache ∧ (splitProbeInputs parameter finalCache).Finite ∧ + (splitProbeInputs parameter cache).ncard + cost ≤ (splitProbeInputs parameter finalCache).ncard := by + let probe : FtsSecretProbe := ⟨coordinate.1, coordinate.2.1, coordinate.2.2, revealedValue⟩ + obtain ⟨middleState, ⟨answer, middleCache⟩, middleFuel, leftCost, rightCost, + _, hfirst, hsecond, hcost⟩ := AdaptiveRevealProbe.runCharged_bind_done_support table + ((splitHashQuery (.hiddenLeaf coordinate)).run cache) + (fun result => pure (revealedValue, Function.update result.2 (.ordinary (probe.input parameter)) (some result.1))) + state fuel hit finalState (value, finalCache) cost hresult + obtain ⟨hcoveredMiddle, hfiniteMiddle, hcountMiddle⟩ := + probeCostInvariant_splitHashQuery_hidden parameter coordinate table state cache fuel hcovered hfinite + _ middleState answer middleCache leftCost hfirst + have hmiddleState := (AdaptiveRevealProbe.runCharged_done_stateFree table state middleState fuel + ((splitHashQuery (.hiddenLeaf coordinate)).run cache) (splitHashQuery_stateFree _ cache) + _ (answer, middleCache) leftCost hfirst).1 + simp only [AdaptiveRevealProbe.runCharged, OracleComp.construct_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq, AdaptiveRevealProbe.DetailedResult.done.injEq] at hsecond + have hfinalState : finalState = middleState := hsecond.1.2.1 + have hfinalCache : finalCache = Function.update middleCache (.ordinary (probe.input parameter)) (some answer) := + hsecond.1.2.2.2 + have hrightCost : rightCost = 0 := hsecond.2 + rw [hfinalState, hfinalCache] + have hknownMiddle : middleState.revealed (probe.index, probe.tree, probe.leafIdx) ≠ none := by + simpa only [hmiddleState, probe] using hknown + refine ⟨hcoveredMiddle.update_revealed probe answer hknownMiddle, ?_, ?_⟩ + · change (probeCachedInputs parameter _).Finite + rw [probeCachedInputs_update_probed] + exact hfiniteMiddle.insert _ + · change _ ≤ (probeCachedInputs parameter _).ncard + rw [probeCachedInputs_update_probed] + have hmono := Set.ncard_le_ncard (Set.subset_insert (probe.input parameter) + (splitProbeInputs parameter middleCache)) (hfiniteMiddle.insert _) + change _ ≤ (insert (probe.input parameter) (splitProbeInputs parameter middleCache)).ncard + omega + +set_option maxRecDepth 10000 in +theorem probeCostInvariant_revealFtsSecret (parameter : PublicParameter) (coordinate : Coordinate) : + ProbeCostInvariant parameter (revealFtsSecret parameter coordinate) := by + intro table state cache fuel hcovered hfinite hit finalState value finalCache cost hresult + rw [revealFtsSecret_run_eq, AdaptiveRevealProbe.revealQuery, + AdaptiveRevealProbe.runCharged, OracleComp.construct_query_bind] at hresult + cases hrevealed : state.revealed coordinate with + | some revealedValue => + simp only [hrevealed] at hresult + exact runCharged_revealTail_bound parameter coordinate table state cache fuel revealedValue + hcovered hfinite (by simp [hrevealed]) hit finalState value finalCache cost hresult + | none => + simp only [hrevealed] at hresult + split_ifs at hresult with hhit + · simp only [support_pure, Set.mem_singleton_iff, Prod.mk.injEq, reduceCtorEq, false_and] at hresult + · exact runCharged_revealTail_bound parameter coordinate table + (state.install coordinate (table coordinate)) cache fuel (table coordinate) + (hcovered.install coordinate (table coordinate)) hfinite + (by simp [AdaptiveRevealProbe.State.install]) hit finalState value finalCache cost hresult + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostSigning.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostSigning.lean new file mode 100644 index 00000000..60af3204 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeCostSigning.lean @@ -0,0 +1,122 @@ +import SphincsSecurity.Proof.FtsProbeCostReveal + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +theorem probeCostInvariant_maskedFtsNode (parameter : PublicParameter) (index : Index) + (tree : FtsTree) (level nodeIdx : Nat) (hlevel : level ≤ ftsTreeHeight) + (hnodeIdx : 2 ^ level * (nodeIdx + 1) ≤ 2 ^ ftsTreeHeight) : + ProbeCostInvariant parameter (maskedFtsNode parameter index tree level nodeIdx) := by + induction level generalizing nodeIdx with + | zero => exact probeCostInvariant_hiddenFtsLeafHash parameter (index, tree, ftsLeafOfNat nodeIdx) + | succ level ih => + rw [maskedFtsNode] + have hlevelChild : level ≤ ftsTreeHeight := by omega + have hleftNode : 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ ftsTreeHeight := by + rw [pow_succ] at hnodeIdx + nlinarith [Nat.two_pow_pos level] + have hrightNode : 2 ^ level * (2 * nodeIdx + 1 + 1) ≤ 2 ^ ftsTreeHeight := by + rw [pow_succ] at hnodeIdx + nlinarith [Nat.two_pow_pos level] + have hlevelSmall : level + 1 < 2 ^ 32 := by + norm_num [ftsTreeHeight] at hlevel ⊢ + omega + have hnodeSmall : nodeIdx < 2 ^ 32 := by + norm_num [ftsTreeHeight] at hnodeIdx ⊢ + nlinarith [Nat.two_pow_pos (level + 1)] + exact (ih (2 * nodeIdx) hlevelChild hleftNode).bind fun left => + (ih (2 * nodeIdx + 1) hlevelChild hrightNode).bind fun right => + probeCostInvariant_ordinaryTweakableHash parameter + (.ftsNode index tree (level + 1) nodeIdx) (nodePayload left right) fun table => + isOrdinaryInput_ftsNode parameter table index tree (level + 1) nodeIdx + (nodePayload left right) hlevelSmall hnodeSmall + +theorem probeCostInvariant_maskedFtsKey (parameter : PublicParameter) (index : Index) : + ProbeCostInvariant parameter (maskedFtsKey parameter index) := by + unfold maskedFtsKey + apply (probeCostInvariant_sequenceFin parameter _ fun tree => + probeCostInvariant_maskedFtsNode parameter index tree ftsTreeHeight 0 le_rfl (by simp)).bind + intro roots + exact probeCostInvariant_ordinaryTweakableHash parameter (.ftsRoots index) (ftsRootsPayload roots) + fun table => isOrdinaryInput_ftsRoots parameter table index (ftsRootsPayload roots) + +theorem probeCostInvariant_maskedFtsOpen (parameter : PublicParameter) (index : Index) + (leaves : DigestTree → FtsLeaf) : + ProbeCostInvariant parameter (maskedFtsOpen parameter index leaves) := by + unfold maskedFtsOpen + apply probeCostInvariant_sequenceFin + intro tree + apply probeCostInvariant_sequenceFin + intro level + exact probeCostInvariant_maskedFtsNode parameter index tree level.val _ level.isLt.le + (ftsOpen_node_bound (leaves (ftsIndexOf tree)) level) + +theorem probeCostInvariant_maskedLayerMessage (secretKey : SecretKey) (index : Index) (lay : Layer) : + ProbeCostInvariant secretKey.parameter (maskedLayerMessage secretKey index lay) := by + unfold maskedLayerMessage + split + · exact probeCostInvariant_simulateQ_ordinaryHashImpl secretKey.parameter _ fun table => + ordinaryOnly_treeRoot secretKey.parameter table _ _ _ + · exact probeCostInvariant_maskedFtsKey secretKey.parameter index + +theorem probeCostInvariant_maskedSignLayer (secretKey : SecretKey) (index : Index) (lay : Layer) : + ProbeCostInvariant secretKey.parameter (maskedSignLayer secretKey index lay) := by + unfold maskedSignLayer + apply (probeCostInvariant_maskedLayerMessage secretKey index lay).bind + intro message + apply (probeCostInvariant_simulateQ_ordinaryHashImpl secretKey.parameter _ fun table => + ordinaryOnly_otsSign secretKey.parameter table lay (treeIndexAt index lay) + (leafIndexAt index lay) (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) message).bind + intro result + cases result with + | none => exact ProbeCostInvariant.pure secretKey.parameter none + | some result => + obtain ⟨counter, values⟩ := result + apply (probeCostInvariant_simulateQ_ordinaryHashImpl secretKey.parameter _ fun table => + ordinaryOnly_treePath secretKey.parameter table lay (treeIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay)) (leafIndexAt index lay) + (leafIndexAt_lt index lay)).bind + intro path + exact ProbeCostInvariant.pure secretKey.parameter (some (counter, values, path)) + +theorem probeCostInvariant_revealSelectedFtsSecrets (parameter : PublicParameter) (index : Index) + (leaves : DigestTree → FtsLeaf) : + ProbeCostInvariant parameter (revealSelectedFtsSecrets parameter index leaves) := by + exact probeCostInvariant_sequenceFin parameter _ fun tree => + probeCostInvariant_revealFtsSecret parameter (index, tree, leaves (ftsIndexOf tree)) + +theorem probeCostInvariant_maskedSignAfterDigest (secretKey : SecretKey) (randomness : Randomness) + (index : Index) (leaves : DigestTree → FtsLeaf) : + ProbeCostInvariant secretKey.parameter (maskedSignAfterDigest secretKey randomness index leaves) := by + unfold maskedSignAfterDigest + apply (probeCostInvariant_maskedFtsOpen secretKey.parameter index leaves).bind + intro ftsPath + apply (probeCostInvariant_sequenceFin secretKey.parameter _ fun lay => + probeCostInvariant_maskedSignLayer secretKey index lay).bind + intro layers + cases traverseOption layers with + | none => exact ProbeCostInvariant.pure secretKey.parameter none + | some parts => + apply (probeCostInvariant_revealSelectedFtsSecrets secretKey.parameter index leaves).bind + intro selected + exact ProbeCostInvariant.pure secretKey.parameter _ + +theorem probeCostInvariant_maskedSignWithView (secretKey : SecretKey) (message : Message) : + ProbeCostInvariant secretKey.parameter (maskedSignWithView secretKey message) := by + unfold maskedSignWithView + apply (probeCostInvariant_simulateQ_splitRomImpl secretKey.parameter _ fun table => + romOrdinaryOnly_signDigestLoop digestAttemptLimit secretKey table message).bind + intro result + cases result with + | none => exact ProbeCostInvariant.pure secretKey.parameter (none, none) + | some result => + obtain ⟨randomness, index, leaves⟩ := result + exact (probeCostInvariant_maskedSignAfterDigest secretKey randomness index leaves).bind fun signature => + ProbeCostInvariant.pure secretKey.parameter (signature, some (selectedFewTimeView index leaves)) + +theorem probeCostInvariant_maskedSigningImpl (secretKey : SecretKey) (request : SigningSpec.Domain) : + ProbeCostInvariant secretKey.parameter (maskedSigningImpl secretKey request) := + (probeCostInvariant_maskedSignWithView secretKey request).map Prod.fst + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeGame.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeGame.lean new file mode 100644 index 00000000..c186a01f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeGame.lean @@ -0,0 +1,815 @@ +import SphincsSecurity.Proof.FtsProbeLift + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open OracleComp OracleSpec + +def NonOrdinaryInput (parameter : PublicParameter) (table : Coordinate → Digest) : + HashInput → Prop := + fun input => ¬IsOrdinaryInput parameter table input + +noncomputable instance (parameter : PublicParameter) (table : Coordinate → Digest) : + DecidablePred (NonOrdinaryInput parameter table) := + fun _input => Classical.propDecidable _ + +def OrdinaryOnly (parameter : PublicParameter) (table : Coordinate → Digest) + (computation : OracleComp HashSpec alpha) : Prop := + computation.IsQueryBoundP (NonOrdinaryInput parameter table) 0 + +theorem OrdinaryOnly.pure (parameter : PublicParameter) (table : Coordinate → Digest) + (value : alpha) : + OrdinaryOnly parameter table (pure value) := by + simp [OrdinaryOnly] + +theorem OrdinaryOnly.bind + {parameter : PublicParameter} {table : Coordinate → Digest} + {left : OracleComp HashSpec alpha} {next : alpha → OracleComp HashSpec beta} + (hleft : OrdinaryOnly parameter table left) + (hnext : ∀ value, OrdinaryOnly parameter table (next value)) : + OrdinaryOnly parameter table (left >>= next) := by + exact isQueryBoundP_bind (n := 0) (m := 0) hleft fun value _ => hnext value + +theorem coupled_splitHashQuery_ordinary + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) (input : HashInput) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hordinary : IsOrdinaryInput parameter table input) : + Coupled parameter table state fuel (splitHashQuery (.ordinary input)) + (randomOracle input) := by + intro cache + exact runDetailed_splitHashQuery_ordinary parameter table state fuel cache input hclean + hordinary + +theorem coupled_simulateQ_ordinaryHashImpl + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (computation : OracleComp HashSpec alpha) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hordinaryOnly : OrdinaryOnly parameter table computation) : + Coupled parameter table state fuel (simulateQ ordinaryHashImpl computation) + (simulateQ (randomOracle : QueryImpl HashSpec _) computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp only [simulateQ_pure] + exact Coupled.pure parameter table state fuel hclean value + | query_bind input next ih => + rw [OrdinaryOnly, isQueryBoundP_query_bind_iff] at hordinaryOnly + have hordinary : IsOrdinaryInput parameter table input := by + by_contra hnot + have hzero := hordinaryOnly.1 + simp [NonOrdinaryInput, hnot] at hzero + rw [simulateQ_query_bind, simulateQ_query_bind] + exact Coupled.bind hclean (splitHashQuery_stateFree (.ordinary input)) + (coupled_splitHashQuery_ordinary parameter table state fuel input hclean hordinary) + fun output => ih output (by + simpa [OrdinaryOnly, NonOrdinaryInput, hordinary] using hordinaryOnly.2 output) + +theorem isOrdinaryInput_of_domain_ne_ftsLeaf + (parameter : PublicParameter) (table : Coordinate → Digest) + (domain : HashDomain) (payload : HashInput) + (hinRange : domain.InRange) + (hne : ∀ index tree leafIdx, domain ≠ .ftsLeaf index tree leafIdx) : + IsOrdinaryInput parameter table (tweakableHashInput parameter domain payload) := by + apply isOrdinaryInput_of_decode_none + rw [decodeProbe?_eq_none_iff] + intro probe heq + have hdomain := (tweakableHashInput_injective parameter (by trivial) hinRange heq).1 + exact hne probe.index probe.tree probe.leafIdx hdomain.symm + +theorem ordinaryOnly_tweakableHash + (parameter : PublicParameter) (table : Coordinate → Digest) + (domain : HashDomain) (payload : HashInput) + (hinRange : domain.InRange) + (hne : ∀ index tree leafIdx, domain ≠ .ftsLeaf index tree leafIdx) : + OrdinaryOnly parameter table (tweakableHash parameter domain payload) := by + unfold OrdinaryOnly tweakableHash oracleHash + change ((liftM (HashSpec.query (tweakableHashInput parameter domain payload)) : + OracleComp HashSpec HashOutput) >>= fun output => pure (truncateHash output)).IsQueryBoundP + (NonOrdinaryInput parameter table) 0 + rw [isQueryBoundP_query_bind_iff] + constructor + · have hordinary := isOrdinaryInput_of_domain_ne_ftsLeaf parameter table domain payload + hinRange hne + simp [NonOrdinaryInput, hordinary] + · intro output + trivial + +theorem ordinaryOnly_sequenceFin {n : Nat} + (parameter : PublicParameter) (table : Coordinate → Digest) + (computation : Fin n → OracleComp HashSpec alpha) + (hcomputation : ∀ position, OrdinaryOnly parameter table (computation position)) : + OrdinaryOnly parameter table (sequenceFin computation) := by + induction n with + | zero => + simp only [sequenceFin] + exact OrdinaryOnly.pure parameter table Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomputation 0).bind fun head => + (ih (fun position => computation position.succ) + (fun position => hcomputation position.succ)).bind fun tail => + OrdinaryOnly.pure parameter table + (Fin.cases head tail : Fin (n + 1) → alpha) + +theorem ordinaryOnly_chainWalk + (parameter : PublicParameter) (table : Coordinate → Digest) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (start steps : Nat) (value : Digest) : + OrdinaryOnly parameter table + (chainWalk parameter lay tree leafIdx chainIdx start steps value) := by + induction steps with + | zero => exact OrdinaryOnly.pure parameter table value + | succ steps ih => + rw [chainWalk] + exact ih.bind fun previous => by + split + · apply ordinaryOnly_tweakableHash parameter table + · trivial + · intros + simp + · exact OrdinaryOnly.pure parameter table 0 + +theorem ordinaryOnly_encode + (parameter : PublicParameter) (table : Coordinate → Digest) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (counter : Counter) : + OrdinaryOnly parameter table + (encode parameter lay tree leafIdx message counter) := by + unfold encode + exact (ordinaryOnly_tweakableHash parameter table (.encoding lay tree leafIdx) + (digestBytes message ++ counterBytes counter) (by trivial) (by intros; simp)).bind + fun digest => OrdinaryOnly.pure parameter table (TargetSum.decodeDigest digest) + +theorem ordinaryOnly_otsSignFrom + (parameter : PublicParameter) (table : Coordinate → Digest) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (secret : ChainIndex → Digest) (message : Digest) (attempts counter : Nat) : + OrdinaryOnly parameter table + (otsSignFrom parameter lay tree leafIdx secret message attempts counter) := by + induction attempts generalizing counter with + | zero => exact OrdinaryOnly.pure parameter table none + | succ attempts ih => + rw [otsSignFrom] + exact (ordinaryOnly_encode parameter table lay tree leafIdx message + (BitVec.ofNat counterBits counter)).bind fun encoded => by + cases encoded with + | none => exact ih (counter + 1) + | some encoding => + exact (ordinaryOnly_sequenceFin parameter table + (fun chainIdx => chainWalk parameter lay tree leafIdx chainIdx 0 + (encoding chainIdx).val (secret chainIdx)) + (fun chainIdx => ordinaryOnly_chainWalk parameter table lay tree leafIdx + chainIdx 0 (encoding chainIdx).val (secret chainIdx))).bind fun values => + OrdinaryOnly.pure parameter table + (some (BitVec.ofNat counterBits counter, values)) + +theorem ordinaryOnly_otsSign + (parameter : PublicParameter) (table : Coordinate → Digest) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (secret : ChainIndex → Digest) (message : Digest) : + OrdinaryOnly parameter table + (otsSign parameter lay tree leafIdx secret message) := + ordinaryOnly_otsSignFrom parameter table lay tree leafIdx secret message + encodingAttemptLimit 0 + +theorem ordinaryOnly_oneTimePublicKey + (parameter : PublicParameter) (table : Coordinate → Digest) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (secret : ChainIndex → Digest) : + OrdinaryOnly parameter table + (oneTimePublicKey parameter lay tree leafIdx secret) := by + unfold oneTimePublicKey + exact ordinaryOnly_sequenceFin parameter table _ fun chainIdx => + ordinaryOnly_chainWalk parameter table lay tree leafIdx chainIdx 0 + (chainLength - 1) (secret chainIdx) + +theorem ordinaryOnly_leafHash + (parameter : PublicParameter) (table : Coordinate → Digest) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (endpoints : ChainIndex → Digest) : + OrdinaryOnly parameter table (leafHash parameter lay tree leafIdx endpoints) := + ordinaryOnly_tweakableHash parameter table (.leaf lay tree leafIdx) + (leafPayload endpoints) (by trivial) (by intros; simp) + +theorem ordinaryOnly_treeNode + (parameter : PublicParameter) (table : Coordinate → Digest) + (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) (level nodeIdx : Nat) + (hlevel : level ≤ maxLayerHeight) + (hrange : 2 ^ level * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) : + OrdinaryOnly parameter table (treeNode parameter lay tree secret level nodeIdx) := by + induction level generalizing nodeIdx with + | zero => + rw [treeNode_zero_eq] + exact (ordinaryOnly_oneTimePublicKey parameter table lay tree (leafOfNat nodeIdx) + (secret (leafOfNat nodeIdx))).bind fun endpoints => + ordinaryOnly_leafHash parameter table lay tree (leafOfNat nodeIdx) endpoints + | succ level ih => + rw [treeNode_succ_eq] + have hleftRange : 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ maxLayerHeight := by + rw [pow_succ] at hrange + nlinarith [Nat.two_pow_pos level] + have hrightRange : 2 ^ level * (2 * nodeIdx + 1 + 1) ≤ 2 ^ maxLayerHeight := by + rw [pow_succ] at hrange + nlinarith [Nat.two_pow_pos level] + have hlevelSmall : level + 1 < 2 ^ 32 := by + norm_num [maxLayerHeight] at hlevel ⊢ + omega + have hnodeSmall : nodeIdx < 2 ^ 32 := by + norm_num [maxLayerHeight] at hrange ⊢ + nlinarith [Nat.two_pow_pos (level + 1)] + exact (ih (2 * nodeIdx) (by omega) hleftRange).bind fun left => + (ih (2 * nodeIdx + 1) (by omega) hrightRange).bind fun right => + ordinaryOnly_tweakableHash parameter table (.node lay tree (level + 1) nodeIdx) + (nodePayload left right) ⟨hlevelSmall, hnodeSmall⟩ (by intros; simp) + +theorem ordinaryOnly_treeRoot + (parameter : PublicParameter) (table : Coordinate → Digest) + (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) : + OrdinaryOnly parameter table (treeRoot parameter lay tree secret) := by + unfold treeRoot + apply ordinaryOnly_treeNode parameter table lay tree secret (layerHeight lay) 0 + · exact layerHeight_le lay + · simp only [zero_add, mul_one] + exact pow_le_pow_right' (by omega) (layerHeight_le lay) + +theorem sibling_node_bound (height leaf level : Nat) + (hlevel : level < height) (hleaf : leaf < 2 ^ height) : + 2 ^ level * (Nat.xor (leaf / 2 ^ level) 1 + 1) ≤ 2 ^ height := by + let bound := 2 ^ (height - level) + have hquotient : leaf / 2 ^ level < bound := by + apply (Nat.div_lt_iff_lt_mul (Nat.two_pow_pos level)).2 + change leaf < 2 ^ (height - level) * 2 ^ level + rw [← pow_add] + simpa only [Nat.sub_add_cancel (Nat.le_of_lt hlevel)] using hleaf + have hboundEven : ∃ half, bound = 2 * half := by + refine ⟨2 ^ (height - level - 1), ?_⟩ + change 2 ^ (height - level) = _ + rw [show height - level = (height - level - 1) + 1 by omega, pow_succ] + exact Nat.mul_comm _ _ + have hsibling : Nat.xor (leaf / 2 ^ level) 1 < bound := by + obtain ⟨parent, hcase⟩ := index_sibling_cases (leaf / 2 ^ level) + obtain ⟨half, hbound⟩ := hboundEven + rcases hcase with hcase | hcase <;> omega + calc + 2 ^ level * (Nat.xor (leaf / 2 ^ level) 1 + 1) ≤ 2 ^ level * bound := + Nat.mul_le_mul_left _ (Nat.succ_le_iff.mpr hsibling) + _ = 2 ^ height := by + change 2 ^ level * 2 ^ (height - level) = _ + rw [← pow_add] + congr 1 + omega + +theorem ordinaryOnly_treePath + (parameter : PublicParameter) (table : Coordinate → Digest) + (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) (leafIdx : LeafIndex) + (hleaf : leafIdx.val < 2 ^ layerHeight lay) : + OrdinaryOnly parameter table (treePath parameter lay tree secret leafIdx) := by + unfold treePath + apply ordinaryOnly_sequenceFin parameter table + intro level + split <;> rename_i hlevel + · apply ordinaryOnly_treeNode parameter table lay tree secret level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · exact (Nat.le_of_lt hlevel).trans (layerHeight_le lay) + · exact (sibling_node_bound (layerHeight lay) leafIdx.val level.val hlevel hleaf).trans + (pow_le_pow_right' (by omega) (layerHeight_le lay)) + · exact OrdinaryOnly.pure parameter table 0 + +theorem simulateQ_ordinaryHashImpl_stateFree + (computation : OracleComp HashSpec alpha) : + StateFree (simulateQ ordinaryHashImpl computation) := by + intro cache + apply (isQueryBoundP_false computation 0).simulateQ_run_StateT_of_step + intro input workingCache + exact splitHashQuery_stateFree (.ordinary input) workingCache + +def secretKeyWithFtsTable (secretKey : SecretKey) (table : Coordinate → Digest) : SecretKey := + { secretKey with + ftsSecret := fun index tree leafIdx => table (index, tree, leafIdx) } + +@[simp] theorem secretKeyWithFtsTable_parameter + (secretKey : SecretKey) (table : Coordinate → Digest) : + (secretKeyWithFtsTable secretKey table).parameter = secretKey.parameter := rfl + +@[simp] theorem secretKeyWithFtsTable_root + (secretKey : SecretKey) (table : Coordinate → Digest) : + (secretKeyWithFtsTable secretKey table).root = secretKey.root := rfl + +@[simp] theorem secretKeyWithFtsTable_otsSecret + (secretKey : SecretKey) (table : Coordinate → Digest) : + (secretKeyWithFtsTable secretKey table).otsSecret = secretKey.otsSecret := rfl + +@[simp] theorem secretKeyWithFtsTable_ftsSecret + (secretKey : SecretKey) (table : Coordinate → Digest) (index : Index) + (tree : FtsTree) (leafIdx : FtsLeaf) : + (secretKeyWithFtsTable secretKey table).ftsSecret index tree leafIdx = + table (index, tree, leafIdx) := rfl + +theorem maskedLayerMessage_stateFree + (secretKey : SecretKey) (index : Index) (lay : Layer) : + StateFree (maskedLayerMessage secretKey index lay) := by + unfold maskedLayerMessage + split + · exact simulateQ_ordinaryHashImpl_stateFree _ + · exact maskedFtsKey_stateFree secretKey.parameter index + +theorem coupled_maskedLayerMessage + (secretKey : SecretKey) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (index : Index) (lay : Layer) + (hclean : AdaptiveRevealProbe.tableHits state table = false) : + Coupled secretKey.parameter table state fuel (maskedLayerMessage secretKey index lay) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (layerMessage (secretKeyWithFtsTable secretKey table) index lay)) := by + unfold maskedLayerMessage layerMessage + split + · apply coupled_simulateQ_ordinaryHashImpl secretKey.parameter table state fuel _ hclean + exact ordinaryOnly_treeRoot secretKey.parameter table _ _ _ + · simpa only [secretKeyWithFtsTable] using + coupled_maskedFtsKey secretKey.parameter table state fuel index hclean + +theorem maskedSignLayer_stateFree + (secretKey : SecretKey) (index : Index) (lay : Layer) : + StateFree (maskedSignLayer secretKey index lay) := by + unfold maskedSignLayer + exact (maskedLayerMessage_stateFree secretKey index lay).bind fun message => + (simulateQ_ordinaryHashImpl_stateFree + (otsSign secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + message)).bind fun signed => by + cases signed with + | none => exact StateFree.pure none + | some part => + exact (simulateQ_ordinaryHashImpl_stateFree + (treePath secretKey.parameter lay (treeIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay)) + (leafIndexAt index lay))).bind fun path => + StateFree.pure (some (part.1, part.2, path)) + +theorem coupled_maskedSignLayer + (secretKey : SecretKey) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (index : Index) (lay : Layer) + (hclean : AdaptiveRevealProbe.tableHits state table = false) : + Coupled secretKey.parameter table state fuel (maskedSignLayer secretKey index lay) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (signLayer (secretKeyWithFtsTable secretKey table) index lay)) := by + unfold maskedSignLayer signLayer + rw [simulateQ_bind] + refine Coupled.bind hclean (maskedLayerMessage_stateFree secretKey index lay) + (coupled_maskedLayerMessage secretKey table state fuel index lay hclean) ?_ + intro message + rw [simulateQ_bind] + refine Coupled.bind hclean + (simulateQ_ordinaryHashImpl_stateFree + (otsSign secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) message)) + (coupled_simulateQ_ordinaryHashImpl secretKey.parameter table state fuel _ hclean + (ordinaryOnly_otsSign secretKey.parameter table lay (treeIndexAt index lay) + (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) message)) ?_ + intro signed + cases signed with + | none => + exact Coupled.pure secretKey.parameter table state fuel hclean none + | some part => + rw [simulateQ_bind] + refine Coupled.bind hclean + (simulateQ_ordinaryHashImpl_stateFree + (treePath secretKey.parameter lay (treeIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay)) (leafIndexAt index lay))) + (coupled_simulateQ_ordinaryHashImpl secretKey.parameter table state fuel _ hclean + (ordinaryOnly_treePath secretKey.parameter table lay (treeIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay)) (leafIndexAt index lay) + (leafIndexAt_lt index lay))) ?_ + intro path + exact Coupled.pure secretKey.parameter table state fuel hclean + (some (part.1, part.2, path)) + +def SplitCacheLE (initial final : SplitHashCache) : Prop := + ∀ key output, initial key = some output → final key = some output + +theorem SplitCacheLE.refl (cache : SplitHashCache) : SplitCacheLE cache cache := by + intro key output hlookup + exact hlookup + +theorem SplitCacheLE.trans {first second third : SplitHashCache} + (hfirst : SplitCacheLE first second) (hsecond : SplitCacheLE second third) : + SplitCacheLE first third := by + intro key output hlookup + exact hsecond key output (hfirst key output hlookup) + +def CachePreserving + (computation : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha) : Prop := + ∀ initial result, result ∈ support (computation.run initial) → + SplitCacheLE initial result.2 + +theorem CachePreserving.pure (value : alpha) : + CachePreserving (pure value : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha) := by + intro initial result hresult + simp only [StateT.run_pure, support_pure, Set.mem_singleton_iff] at hresult + subst result + exact SplitCacheLE.refl initial + +theorem CachePreserving.bind + {left : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) beta} + (hleft : CachePreserving left) (hnext : ∀ value, CachePreserving (next value)) : + CachePreserving (left >>= next) := by + intro initial result hresult + rw [StateT.run_bind, mem_support_bind_iff] at hresult + obtain ⟨middle, hmiddle, hfinal⟩ := hresult + exact (hleft initial middle hmiddle).trans + (hnext middle.1 middle.2 result hfinal) + +theorem CachePreserving.map + {computation : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha} + (hcomputation : CachePreserving computation) (transform : alpha → beta) : + CachePreserving (transform <$> computation) := by + rw [map_eq_bind_pure_comp] + exact hcomputation.bind fun value => CachePreserving.pure (transform value) + +theorem splitHashQuery_cachePreserving (key : SplitHashKey) : + CachePreserving (splitHashQuery key) := by + intro initial result hresult + rw [splitHashQuery_run_eq] at hresult + cases hlookup : initial key with + | some output => + simp only [hlookup, support_pure, Set.mem_singleton_iff] at hresult + subst result + exact SplitCacheLE.refl initial + | none => + simp only [hlookup, mem_support_bind_iff] at hresult + obtain ⟨sample, hsample, hresult⟩ := hresult + simp only [support_pure, Set.mem_singleton_iff] at hresult + subst result + intro oldKey oldOutput hold + change Function.update initial key (some sample) oldKey = some oldOutput + by_cases heq : oldKey = key + · subst oldKey + rw [hlookup] at hold + simp at hold + · rw [Function.update_of_ne heq] + exact hold + +theorem simulateQ_ordinaryHashImpl_cachePreserving + (computation : OracleComp HashSpec alpha) : + CachePreserving (simulateQ ordinaryHashImpl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp only [simulateQ_pure] + exact CachePreserving.pure value + | query_bind input next ih => + rw [simulateQ_query_bind] + exact (splitHashQuery_cachePreserving (.ordinary input)).bind fun output => ih output + +theorem hiddenFtsLeafHash_cachePreserving + (parameter : PublicParameter) (coordinate : Coordinate) : + CachePreserving (hiddenFtsLeafHash parameter coordinate) := by + unfold hiddenFtsLeafHash + exact (splitHashQuery_cachePreserving (.hiddenLeaf coordinate)).bind fun output => + CachePreserving.pure (truncateHash output) + +theorem ordinaryTweakableHash_cachePreserving + (parameter : PublicParameter) (domain : HashDomain) (payload : HashInput) : + CachePreserving (ordinaryTweakableHash parameter domain payload) := by + unfold ordinaryTweakableHash + exact (splitHashQuery_cachePreserving + (.ordinary (tweakableHashInput parameter domain payload))).bind fun output => + CachePreserving.pure (truncateHash output) + +theorem sequenceFin_cachePreserving {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha) + (hcomputation : ∀ position, CachePreserving (computation position)) : + CachePreserving (sequenceFin computation) := by + induction n with + | zero => + simp only [sequenceFin] + exact CachePreserving.pure Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomputation 0).bind fun head => + (ih (fun position => computation position.succ) + (fun position => hcomputation position.succ)).bind fun tail => + CachePreserving.pure (Fin.cases head tail : Fin (n + 1) → alpha) + +theorem maskedFtsNode_cachePreserving + (parameter : PublicParameter) (index : Index) (tree : FtsTree) + (level nodeIdx : Nat) : + CachePreserving (maskedFtsNode parameter index tree level nodeIdx) := by + induction level generalizing nodeIdx with + | zero => + exact hiddenFtsLeafHash_cachePreserving parameter + (index, tree, ftsLeafOfNat nodeIdx) + | succ level ih => + rw [maskedFtsNode] + exact (ih (2 * nodeIdx)).bind fun left => + (ih (2 * nodeIdx + 1)).bind fun right => + ordinaryTweakableHash_cachePreserving parameter + (.ftsNode index tree (level + 1) nodeIdx) (nodePayload left right) + +theorem maskedFtsKey_cachePreserving (parameter : PublicParameter) (index : Index) : + CachePreserving (maskedFtsKey parameter index) := by + unfold maskedFtsKey + exact (sequenceFin_cachePreserving + (fun tree => maskedFtsNode parameter index tree ftsTreeHeight 0) + (fun tree => maskedFtsNode_cachePreserving parameter index tree ftsTreeHeight 0)).bind + fun roots => ordinaryTweakableHash_cachePreserving parameter (.ftsRoots index) + (ftsRootsPayload roots) + +theorem maskedFtsOpen_cachePreserving + (parameter : PublicParameter) (index : Index) (leaves : DigestTree → FtsLeaf) : + CachePreserving (maskedFtsOpen parameter index leaves) := by + unfold maskedFtsOpen + apply sequenceFin_cachePreserving + intro tree + apply sequenceFin_cachePreserving + intro level + exact maskedFtsNode_cachePreserving parameter index tree level.val + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1) + +theorem maskedLayerMessage_cachePreserving + (secretKey : SecretKey) (index : Index) (lay : Layer) : + CachePreserving (maskedLayerMessage secretKey index lay) := by + unfold maskedLayerMessage + split + · exact simulateQ_ordinaryHashImpl_cachePreserving _ + · exact maskedFtsKey_cachePreserving secretKey.parameter index + +theorem maskedSignLayer_cachePreserving + (secretKey : SecretKey) (index : Index) (lay : Layer) : + CachePreserving (maskedSignLayer secretKey index lay) := by + unfold maskedSignLayer + exact (maskedLayerMessage_cachePreserving secretKey index lay).bind fun message => + (simulateQ_ordinaryHashImpl_cachePreserving + (otsSign secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + message)).bind fun signed => by + cases signed with + | none => exact CachePreserving.pure none + | some part => + exact (simulateQ_ordinaryHashImpl_cachePreserving + (treePath secretKey.parameter lay (treeIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay)) + (leafIndexAt index lay))).bind fun path => + CachePreserving.pure (some (part.1, part.2, path)) + +theorem RevealedSynced.mono + {parameter : PublicParameter} {table : Coordinate → Digest} + {state : AdaptiveRevealProbe.State Coordinate} {initial final : SplitHashCache} + (hsynced : RevealedSynced parameter table state initial) + (hle : SplitCacheLE initial final) : + RevealedSynced parameter table state final := by + intro coordinate value hrevealed + obtain ⟨hvalue, output, hhidden, hordinary⟩ := + hsynced coordinate value hrevealed + exact ⟨hvalue, output, hle _ output hhidden, hle _ output hordinary⟩ + +theorem revealedSynced_of_mem_runDetailed_stateFree + (parameter : PublicParameter) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (initial final : SplitHashCache) (value : alpha) + (computation : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state initial) + (hstateFree : StateFree computation) + (hpreserving : CachePreserving computation) + (hresult : .done false finalState (value, final) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel (computation.run initial))) : + RevealedSynced parameter table finalState final := by + obtain ⟨rawValue, heq⟩ := AdaptiveRevealProbe.runDetailed_stateFree_support + table state fuel (computation.run initial) (hstateFree initial) hclean + (.done false finalState (value, final)) hresult + have hstate : finalState = state := by + exact AdaptiveRevealProbe.DetailedResult.done.inj heq |>.2.1 + have hvalue : (value, final) = rawValue := by + exact AdaptiveRevealProbe.DetailedResult.done.inj heq |>.2.2 + subst finalState + subst rawValue + have hraw : (value, final) ∈ support (computation.run initial) := + AdaptiveRevealProbe.mem_support_of_mem_runDetailed_done table state state fuel + (computation.run initial) false (value, final) hresult + exact hsynced.mono (hpreserving initial (value, final) hraw) + +def HiddenIndexCached (index : Index) (cache : SplitHashCache) : Prop := + ∀ tree leafIdx, ∃ output, + cache (.hiddenLeaf (index, tree, leafIdx)) = some output + +theorem HiddenIndexCached.mono + {index : Index} {initial final : SplitHashCache} + (hcached : HiddenIndexCached index initial) (hle : SplitCacheLE initial final) : + HiddenIndexCached index final := by + intro tree leafIdx + obtain ⟨output, houtput⟩ := hcached tree leafIdx + exact ⟨output, hle _ output houtput⟩ + +set_option maxHeartbeats 800000 in +theorem cacheProperty_of_mem_runDetailed_sequenceFin {n : Nat} + (table : Coordinate → Digest) (property : SplitHashCache → Prop) + (hmono : ∀ {initial final}, property initial → SplitCacheLE initial final → property final) + (computation : Fin n → StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha) + (hstateFree : ∀ position, StateFree (computation position)) + (hpreserving : ∀ position, CachePreserving (computation position)) + (position : Fin n) + (hselected : ∀ state finalState fuel initial final value, + AdaptiveRevealProbe.tableHits state table = false → + .done false finalState (value, final) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((computation position).run initial)) → + property final) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (initial final : SplitHashCache) (values : Fin n → alpha) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hresult : .done false finalState (values, final) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((sequenceFin computation).run initial))) : + property final := by + induction n generalizing state finalState initial final with + | zero => exact position.elim0 + | succ n ih => + rw [sequenceFin, StateT.run_bind] at hresult + obtain ⟨headResult, hhead, hafterHead⟩ := + AdaptiveRevealProbe.mem_support_runDetailed_bind_stateFree + table state finalState fuel ((computation 0).run initial) + (fun result => ((sequenceFin (fun tailPosition => computation tailPosition.succ) >>= fun tail => + pure (Fin.cases result.1 tail : Fin (n + 1) → alpha)).run result.2)) + (hstateFree 0 initial) hclean false (values, final) hresult + rcases headResult with ⟨head, headCache⟩ + rw [StateT.run_bind] at hafterHead + obtain ⟨tailResult, htail, hfinished⟩ := + AdaptiveRevealProbe.mem_support_runDetailed_bind_stateFree + table state finalState fuel + ((sequenceFin (fun tailPosition => computation tailPosition.succ)).run headCache) + (fun result => (pure (Fin.cases head result.1 : Fin (n + 1) → alpha) : + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) (Fin (n + 1) → alpha)).run + result.2) + (sequenceFin_stateFree (fun tailPosition => computation tailPosition.succ) + (fun tailPosition => hstateFree tailPosition.succ) headCache) + hclean false (values, final) hafterHead + rcases tailResult with ⟨tail, tailCache⟩ + change AdaptiveRevealProbe.DetailedResult.done false finalState (values, final) ∈ support + (pure (AdaptiveRevealProbe.DetailedResult.done + (AdaptiveRevealProbe.tableHits state table) state + ((Fin.cases head tail : Fin (n + 1) → alpha), tailCache))) at hfinished + rw [hclean] at hfinished + have hfinishedEq := OracleComp.eq_of_mem_support_pure + (AdaptiveRevealProbe.DetailedResult.done false state + ((Fin.cases head tail : Fin (n + 1) → alpha), tailCache)) hfinished + have hfinalCache : final = tailCache := by + exact (Prod.mk.inj + (AdaptiveRevealProbe.DetailedResult.done.inj hfinishedEq).2.2).2 + subst final + cases position using Fin.cases with + | zero => + have hproperty : property headCache := + hselected state state fuel initial headCache head hclean hhead + have hraw : (tail, tailCache) ∈ support + ((sequenceFin (fun tailPosition => computation tailPosition.succ)).run headCache) := + AdaptiveRevealProbe.mem_support_of_mem_runDetailed_done table state state fuel + ((sequenceFin (fun tailPosition => computation tailPosition.succ)).run headCache) + false (tail, tailCache) htail + exact hmono hproperty + (sequenceFin_cachePreserving + (fun tailPosition => computation tailPosition.succ) + (fun tailPosition => hpreserving tailPosition.succ) + headCache (tail, tailCache) hraw) + | succ position => + exact ih + (computation := fun tailPosition => computation tailPosition.succ) + (hstateFree := fun tailPosition => hstateFree tailPosition.succ) + (hpreserving := fun tailPosition => hpreserving tailPosition.succ) + (position := position) + (hselected := fun selectedState selectedFinalState selectedFuel selectedInitial selectedFinal + selectedValue selectedClean selectedResult => + hselected selectedState selectedFinalState selectedFuel selectedInitial + selectedFinal selectedValue selectedClean selectedResult) + (state := state) (finalState := state) + (initial := headCache) (final := tailCache) (values := tail) hclean htail + +noncomputable def maskedSignLayerAfterMessage + (secretKey : SecretKey) (index : Index) (lay : Layer) (message : Digest) : + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) + (Option (Counter × (ChainIndex → Digest) × (Fin maxLayerHeight → Digest))) := do + let tree := treeIndexAt index lay + let leafIdx := leafIndexAt index lay + match ← simulateQ ordinaryHashImpl + (otsSign secretKey.parameter lay tree leafIdx + (secretKey.otsSecret lay tree leafIdx) message) with + | none => pure none + | some (counter, values) => do + let path ← simulateQ ordinaryHashImpl + (treePath secretKey.parameter lay tree (secretKey.otsSecret lay tree) leafIdx) + pure (some (counter, values, path)) + +theorem maskedSignLayer_eq + (secretKey : SecretKey) (index : Index) (lay : Layer) : + maskedSignLayer secretKey index lay = (do + let message ← maskedLayerMessage secretKey index lay + maskedSignLayerAfterMessage secretKey index lay message) := by + unfold maskedSignLayer maskedSignLayerAfterMessage + rfl + +theorem maskedSignLayerAfterMessage_cachePreserving + (secretKey : SecretKey) (index : Index) (lay : Layer) (message : Digest) : + CachePreserving (maskedSignLayerAfterMessage secretKey index lay message) := by + unfold maskedSignLayerAfterMessage + exact (simulateQ_ordinaryHashImpl_cachePreserving + (otsSign secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + message)).bind fun signed => by + cases signed with + | none => exact CachePreserving.pure none + | some part => + exact (simulateQ_ordinaryHashImpl_cachePreserving + (treePath secretKey.parameter lay (treeIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay)) + (leafIndexAt index lay))).bind fun path => + CachePreserving.pure (some (part.1, part.2, path)) + +theorem maskedLayerMessage_bottomLayer + (secretKey : SecretKey) (index : Index) : + maskedLayerMessage secretKey index bottomLayer = + maskedFtsKey secretKey.parameter index := by + unfold maskedLayerMessage + simp [bottomLayer, numLayers] + +set_option maxHeartbeats 800000 in +theorem hiddenIndexCached_of_mem_runDetailed_maskedSignLayer_bottom + (secretKey : SecretKey) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (initial final : SplitHashCache) (index : Index) + (value : Option (Counter × (ChainIndex → Digest) × (Fin maxLayerHeight → Digest))) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hresult : .done false finalState (value, final) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((maskedSignLayer secretKey index bottomLayer).run initial))) : + HiddenIndexCached index final := by + rw [maskedSignLayer_eq, StateT.run_bind, + AdaptiveRevealProbe.runDetailed_bind_stateFree table state fuel + ((maskedLayerMessage secretKey index bottomLayer).run initial) + (fun result => (maskedSignLayerAfterMessage secretKey index bottomLayer result.1).run + result.2) + (maskedLayerMessage_stateFree secretKey index bottomLayer initial), + mem_support_bind_iff] at hresult + obtain ⟨messageResult, hmessage, hrest⟩ := hresult + obtain ⟨messageCache, hmessageEq⟩ := + AdaptiveRevealProbe.runDetailed_stateFree_support table state fuel + ((maskedLayerMessage secretKey index bottomLayer).run initial) + (maskedLayerMessage_stateFree secretKey index bottomLayer initial) hclean + messageResult hmessage + subst messageResult + simp only at hrest + have hmessage' := hmessage + rw [maskedLayerMessage_bottomLayer] at hmessage' + have hcached : HiddenIndexCached index messageCache.2 := + hiddenLeaves_cached_of_mem_runDetailed_maskedFtsKey secretKey.parameter table state state + fuel initial messageCache.2 index messageCache.1 hclean hmessage' + have hraw : (value, final) ∈ support + ((maskedSignLayerAfterMessage secretKey index bottomLayer messageCache.1).run + messageCache.2) := + AdaptiveRevealProbe.mem_support_of_mem_runDetailed_done table state finalState fuel + ((maskedSignLayerAfterMessage secretKey index bottomLayer messageCache.1).run + messageCache.2) false (value, final) hrest + exact hcached.mono + (maskedSignLayerAfterMessage_cachePreserving secretKey index bottomLayer messageCache.1 + messageCache.2 (value, final) hraw) + +set_option maxHeartbeats 800000 in +theorem hiddenIndexCached_of_mem_runDetailed_maskedSignLayers + (secretKey : SecretKey) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (initial final : SplitHashCache) (index : Index) + (values : Layer → + Option (Counter × (ChainIndex → Digest) × (Fin maxLayerHeight → Digest))) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hresult : .done false finalState (values, final) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((sequenceFin (fun lay => maskedSignLayer secretKey index lay)).run initial))) : + HiddenIndexCached index final := by + exact cacheProperty_of_mem_runDetailed_sequenceFin table (HiddenIndexCached index) + (fun hcached hle => hcached.mono hle) + (fun lay => maskedSignLayer secretKey index lay) + (fun lay => maskedSignLayer_stateFree secretKey index lay) + (fun lay => maskedSignLayer_cachePreserving secretKey index lay) + bottomLayer + (fun selectedState selectedFinalState selectedFuel selectedInitial selectedFinal + selectedValue selectedClean selectedResult => + hiddenIndexCached_of_mem_runDetailed_maskedSignLayer_bottom secretKey table + selectedState selectedFinalState selectedFuel selectedInitial selectedFinal index + selectedValue selectedClean selectedResult) + state finalState fuel initial final values hclean hresult + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeLift.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeLift.lean new file mode 100644 index 00000000..85577879 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeLift.lean @@ -0,0 +1,90 @@ +import SphincsSecurity.Proof.FtsProbeSimulation + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open OracleComp OracleSpec + +theorem ftsNode_leaf_query_mem + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (index : Index) + (tree : FtsTree) (secret : FtsLeaf → Digest) (level nodeIdx : Nat) + (leafIdx : FtsLeaf) + (hlower : nodeIdx * 2 ^ level ≤ leafIdx.val) + (hupper : leafIdx.val < (nodeIdx + 1) * 2 ^ level) : + tweakableHashInput parameter (.ftsLeaf index tree leafIdx) + (digestBytes (secret leafIdx)) ∈ + queriedInputs f (ftsNode parameter index tree secret level nodeIdx) := by + induction level generalizing nodeIdx with + | zero => + have hnodeIdx : nodeIdx = leafIdx.val := by + norm_num at hlower hupper + omega + subst nodeIdx + rw [ftsNode_zero_eq, ftsLeafOfNat_val] + exact Concrete.ftsLeafHash_query_mem f parameter index tree leafIdx (secret leafIdx) + | succ level ih => + rw [ftsNode_succ_eq] + rw [pow_succ] at hlower hupper + by_cases hleft : leafIdx.val < (2 * nodeIdx + 1) * 2 ^ level + · apply queriedInputs_mono_bind_left + exact ih (2 * nodeIdx) (by nlinarith [Nat.two_pow_pos level]) hleft + · apply queriedInputs_mono_bind_right + apply queriedInputs_mono_bind_left + exact ih (2 * nodeIdx + 1) (by omega) + (by nlinarith [Nat.two_pow_pos level]) + +theorem ftsKey_leaf_query_mem + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (index : Index) + (secret : FtsTree → FtsLeaf → Digest) (tree : FtsTree) (leafIdx : FtsLeaf) : + tweakableHashInput parameter (.ftsLeaf index tree leafIdx) + (digestBytes (secret tree leafIdx)) ∈ + queriedInputs f (ftsKey parameter index secret) := by + unfold ftsKey + apply queriedInputs_mono_bind_left + apply Concrete.sequenceFin_component_query_mem f _ tree + exact ftsNode_leaf_query_mem f parameter index tree (secret tree) ftsTreeHeight 0 leafIdx + (by simp) (by simp) + +set_option maxHeartbeats 800000 in +theorem hiddenLeaves_cached_of_mem_runDetailed_maskedFtsKey + (parameter : PublicParameter) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (index : Index) (value : Digest) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hresult : .done false finalState (value, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((maskedFtsKey parameter index).run cache))) : + ∀ tree leafIdx, ∃ output, + finalCache (.hiddenLeaf (index, tree, leafIdx)) = some output := by + have hmapped : some (value, mergedCache parameter table finalCache) ∈ support + (projectDetailedCache parameter table <$> + AdaptiveRevealProbe.runDetailed table state fuel + ((maskedFtsKey parameter index).run cache)) := by + rw [support_map, Set.mem_image] + exact ⟨.done false finalState (value, finalCache), hresult, rfl⟩ + rw [coupled_maskedFtsKey parameter table state fuel index hclean cache] at hmapped + obtain ⟨ordinaryResult, hordinaryResult, hresultEq⟩ := + OracleComp.mem_support_map_peel some + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsKey parameter index (fun tree leafIdx => table (index, tree, leafIdx)))).run + (mergedCache parameter table cache)) hmapped + have hordinaryEq : ordinaryResult = + (value, mergedCache parameter table finalCache) := + Option.some.inj hresultEq.symm + subst ordinaryResult + obtain ⟨answerFn, hagrees⟩ := QueryCache.exists_agreesWithFn + (spec := HashSpec) (mergedCache parameter table finalCache) + have hreplay := replay_of_mem_support + (ftsKey parameter index (fun tree leafIdx => table (index, tree, leafIdx))) + (mergedCache parameter table cache) value (mergedCache parameter table finalCache) + hordinaryResult answerFn hagrees + intro tree leafIdx + have hcached := hreplay.2.2 + (hiddenInput parameter table (index, tree, leafIdx)) + (ftsKey_leaf_query_mem answerFn parameter index + (fun tree leafIdx => table (index, tree, leafIdx)) tree leafIdx) + rw [mergedCache_hiddenInput] at hcached + cases hlookup : finalCache (.hiddenLeaf (index, tree, leafIdx)) with + | none => exact (hcached hlookup).elim + | some output => exact ⟨output, rfl⟩ + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeOrigin.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeOrigin.lean new file mode 100644 index 00000000..f2f5b266 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeOrigin.lean @@ -0,0 +1,1131 @@ +import SphincsSecurity.Proof.FtsProbeAdversary + +namespace SphincsSecurity.AdaptiveRevealProbe + +open OracleComp OracleSpec + +def DetailedResult.mapValue (transform : alpha → beta) : + DetailedResult Coordinate alpha → DetailedResult Coordinate beta + | .stopped hit => .stopped hit + | .done hit state value => .done hit state (transform value) + +variable {Coordinate : Type} [Fintype Coordinate] [DecidableEq Coordinate] + +theorem runDetailed_mapValue (table : Coordinate → Digest) (state : State Coordinate) + (fuel : Nat) (computation : OracleComp (World Coordinate) alpha) + (transform : alpha → beta) : + runDetailed table state fuel (transform <$> computation) = + DetailedResult.mapValue transform <$> + runDetailed table state fuel computation := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + simp [runDetailed, DetailedResult.mapValue] + | query_bind input next ih => + rw [map_bind] + cases input with + | uniform n => + rw [runDetailed_uniform_query_bind, runDetailed_uniform_query_bind, map_bind] + apply bind_congr + intro output + exact ih output state fuel + | hashOutput => + rw [runDetailed_hashOutput_query_bind, runDetailed_hashOutput_query_bind, map_bind] + apply bind_congr + intro output + exact ih output state fuel + | probe coordinate candidate => + rw [runDetailed_probe_query_bind, runDetailed_probe_query_bind] + cases fuel with + | zero => simp [DetailedResult.mapValue] + | succ remaining => + cases hrevealed : state.revealed coordinate with + | none => exact ih () (state.addPending coordinate candidate) remaining + | some value => exact ih () state remaining + | reveal coordinate => + rw [runDetailed_reveal_query_bind, runDetailed_reveal_query_bind] + cases hrevealed : state.revealed coordinate with + | some value => exact ih value state fuel + | none => + by_cases hhit : table coordinate ∈ state.pending coordinate + · simp [hhit, DetailedResult.mapValue] + · simp only [hhit, ↓reduceIte] + exact ih (table coordinate) (state.install coordinate (table coordinate)) fuel + +theorem mem_support_runDetailed_stateT_map + (table : Coordinate → Digest) (state finalState : State Coordinate) + (fuel : Nat) + (computation : StateT sigma (OracleComp (World Coordinate)) alpha) + (transform : alpha → beta) (hit : Bool) (value : beta) (finalSigma : sigma) + (hresult : .done hit finalState (value, finalSigma) ∈ support + (runDetailed table state fuel ((transform <$> computation).run initialSigma))) : + ∃ source, transform source = value ∧ + .done hit finalState (source, finalSigma) ∈ support + (runDetailed table state fuel (computation.run initialSigma)) := by + rw [StateT.run_map, runDetailed_mapValue, support_map] at hresult + obtain ⟨detailed, hdetailed, heq⟩ := hresult + cases detailed with + | stopped stoppedHit => simp [DetailedResult.mapValue] at heq + | done sourceHit sourceState sourceValue => + simp only [DetailedResult.mapValue, DetailedResult.done.injEq] at heq + obtain ⟨hhit, hstate, hvalue⟩ := heq + subst sourceHit + subst sourceState + refine ⟨sourceValue.1, ?_, ?_⟩ + · exact congrArg Prod.fst hvalue + · have hcache := congrArg Prod.snd hvalue + change sourceValue.2 = finalSigma at hcache + rw [← hcache] + change .done hit finalState sourceValue ∈ + support (runDetailed table state fuel (computation.run initialSigma)) + exact hdetailed + +end SphincsSecurity.AdaptiveRevealProbe + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open OracleComp OracleSpec + +def SelectedCoordinate (index : Index) (leaves : DigestTree → FtsLeaf) + (coordinate : Coordinate) : Prop := + coordinate.1 = index ∧ coordinate.2.2 = leaves (ftsIndexOf coordinate.2.1) + +def RevealedOnlyFrom (initial final : AdaptiveRevealProbe.State Coordinate) + (allowed : Coordinate → Prop) : Prop := + ∀ coordinate value, final.revealed coordinate = some value → + initial.revealed coordinate = some value ∨ allowed coordinate + +theorem signingTraceComputation_query_bind + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → + OracleComp (OracleWorld + SigningSpec) alpha) : + signingTraceComputation + ((liftM ((OracleWorld + SigningSpec).query input) : + OracleComp (OracleWorld + SigningSpec) _) >>= next) = (do + let output ← liftM ((OracleWorld + SigningSpec).query input) + (fun result => (result.1, signingLogFragment input output ++ result.2)) <$> + signingTraceComputation (next output)) := by + simp [signingTraceComputation] + +theorem simulateQ_randomOracle_cache_le + (computation : OracleComp HashSpec alpha) (initial final : QueryCache HashSpec) + (value : alpha) + (hresult : (value, final) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) computation).run initial)) : + initial ≤ final := by + exact OracleComp.simulateQ_run_preservesInv + (randomOracle : QueryImpl HashSpec _) + (fun cache => initial ≤ cache) + (QueryImpl.PreservesInv.withCaching_le uniformSampleImpl initial) + computation initial le_rfl (value, final) hresult + +theorem simulateQ_unloggedMappedAdversaryImpl_cache_le + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (initial final : QueryCache HashSpec) (value : alpha) + (hresult : (value, final) ∈ support + ((simulateQ (unloggedMappedAdversaryImpl secretKey) computation).run initial)) : + initial ≤ final := by + apply OracleComp.simulateQ_run_preservesInv + (unloggedMappedAdversaryImpl secretKey) (fun cache => initial ≤ cache) _ + computation initial le_rfl (value, final) hresult + intro input cache hle result hmem + exact hle.trans (unloggedMappedAdversaryImpl_cache_le secretKey input cache result hmem) + +def CoveredByLog (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (log : QueryLog SigningSpec) (coordinate : Coordinate) : Prop := + ∃ (message : Message) (signature : Signature) (index : Index) + (leaves : DigestTree → FtsLeaf), + (⟨message, some signature⟩ : SigningEntry) ∈ log + ∧ SuccessfulDigestRun f cache secretKey message signature.randomness index leaves + ∧ SelectedCoordinate index leaves coordinate + +theorem CoveredByLog.mono_cache + {f : QueryImpl HashSpec Id} {initial final : QueryCache HashSpec} + {secretKey : SecretKey} {log : QueryLog SigningSpec} {coordinate : Coordinate} + (hcovered : CoveredByLog f initial secretKey log coordinate) + (hle : initial ≤ final) : CoveredByLog f final secretKey log coordinate := by + obtain ⟨message, signature, index, leaves, hentry, hdigest, hcoordinate⟩ := hcovered + exact ⟨message, signature, index, leaves, hentry, + ⟨hdigest.1, hdigest.2.1, hdigest.2.2.mono hle⟩, hcoordinate⟩ + +theorem CoveredByLog.mono_log + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {left right : QueryLog SigningSpec} {coordinate : Coordinate} + (hcovered : CoveredByLog f cache secretKey right coordinate) : + CoveredByLog f cache secretKey (left ++ right) coordinate := by + obtain ⟨message, signature, index, leaves, hentry, hdigest, hcoordinate⟩ := hcovered + exact ⟨message, signature, index, leaves, List.mem_append_right left hentry, + hdigest, hcoordinate⟩ + +theorem peel_signingTrace_tail + (secretKey : SecretKey) (table : Coordinate → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (logPrefix : QueryLog SigningSpec) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (value : alpha) (log : QueryLog SigningSpec) + (hresult : .done false finalState ((value, log), finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + ((fun result => (result.1, logPrefix ++ result.2)) <$> + signingTraceComputation computation)).run cache))) : + ∃ tailLog, log = logPrefix ++ tailLog ∧ + .done false finalState ((value, tailLog), finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (signingTraceComputation computation)).run cache)) := by + rw [simulateQ_map] at hresult + obtain ⟨source, hsource, htail⟩ := + AdaptiveRevealProbe.mem_support_runDetailed_stateT_map table state finalState fuel + (simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (signingTraceComputation computation)) + (fun result => (result.1, logPrefix ++ result.2)) false + (value, log) finalCache hresult + rcases source with ⟨sourceValue, tailLog⟩ + have hvalue : sourceValue = value := congrArg Prod.fst hsource + have hlog : logPrefix ++ tailLog = log := congrArg Prod.snd hsource + subst sourceValue + exact ⟨tailLog, hlog.symm, htail⟩ + + +theorem revealedOnlyFrom_revealFtsSecret + (parameter : PublicParameter) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (coordinate : Coordinate) (value : Digest) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state cache) + (hhidden : ∃ output, cache (.hiddenLeaf coordinate) = some output) + (hresult : .done false finalState (value, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((revealFtsSecret parameter coordinate).run cache))) : + RevealedOnlyFrom state finalState (fun other => other = coordinate) := by + cases hrevealed : state.revealed coordinate with + | none => + obtain ⟨output, hhiddenCache⟩ := hhidden + rw [runDetailed_revealFtsSecret_hidden parameter table state fuel cache coordinate output + hrevealed hclean hhiddenCache] at hresult + simp only [support_pure, Set.mem_singleton_iff, + AdaptiveRevealProbe.DetailedResult.done.injEq] at hresult + obtain ⟨hfinalState, _⟩ := hresult.2 + subst finalState + intro other otherValue hother + by_cases heq : other = coordinate + · exact Or.inr heq + · exact Or.inl (by + simpa [AdaptiveRevealProbe.State.install, Function.update_of_ne heq] using hother) + | some revealedValue => + obtain ⟨hvalue, output, hhiddenCache, hordinaryCache⟩ := + hsynced coordinate revealedValue hrevealed + rw [runDetailed_revealFtsSecret_revealed parameter table state fuel cache coordinate + revealedValue output hrevealed hvalue hhiddenCache hordinaryCache hclean] at hresult + simp only [support_pure, Set.mem_singleton_iff, + AdaptiveRevealProbe.DetailedResult.done.injEq] at hresult + obtain ⟨hfinalState, _⟩ := hresult.2 + subst finalState + intro other otherValue hother + exact Or.inl hother + +theorem RevealedOnlyFrom.trans + {initial middle final : AdaptiveRevealProbe.State Coordinate} + {left right : Coordinate → Prop} + (hleft : RevealedOnlyFrom initial middle left) + (hright : RevealedOnlyFrom middle final right) : + RevealedOnlyFrom initial final (fun coordinate => left coordinate ∨ right coordinate) := by + intro coordinate value hrevealed + rcases hright coordinate value hrevealed with hmiddle | hright + · rcases hleft coordinate value hmiddle with hinitial | hleft + · exact Or.inl hinitial + · exact Or.inr (Or.inl hleft) + · exact Or.inr (Or.inr hright) + +theorem hiddenLeaf_eq_of_mem_runDetailed_revealFtsSecret + (parameter : PublicParameter) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (coordinate : Coordinate) (value : Digest) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state cache) + (hhidden : ∃ output, cache (.hiddenLeaf coordinate) = some output) + (hresult : .done false finalState (value, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((revealFtsSecret parameter coordinate).run cache))) : + ∀ other, finalCache (.hiddenLeaf other) = cache (.hiddenLeaf other) := by + cases hrevealed : state.revealed coordinate with + | none => + obtain ⟨output, hhiddenCache⟩ := hhidden + rw [runDetailed_revealFtsSecret_hidden parameter table state fuel cache coordinate output + hrevealed hclean hhiddenCache] at hresult + simp only [support_pure, Set.mem_singleton_iff, + AdaptiveRevealProbe.DetailedResult.done.injEq] at hresult + have hcache : finalCache = Function.update cache + (.ordinary (hiddenInput parameter table coordinate)) (some output) := by + simpa using congrArg Prod.snd hresult.2.2 + intro other + rw [hcache] + simp + | some revealedValue => + obtain ⟨hvalue, output, hhiddenCache, hordinaryCache⟩ := + hsynced coordinate revealedValue hrevealed + rw [runDetailed_revealFtsSecret_revealed parameter table state fuel cache coordinate + revealedValue output hrevealed hvalue hhiddenCache hordinaryCache hclean] at hresult + simp only [support_pure, Set.mem_singleton_iff, + AdaptiveRevealProbe.DetailedResult.done.injEq] at hresult + have hcache : finalCache = cache := by + simpa using congrArg Prod.snd hresult.2.2 + intro other + rw [hcache] + +theorem revealedOnlyFrom_revealSequence {n : Nat} + (parameter : PublicParameter) (table : Coordinate → Digest) (index : Index) + (coordinates : Fin n → Coordinate) + (hcoordinates : ∀ position, (coordinates position).1 = index) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state cache) + (hcached : HiddenIndexCached index cache) + (values : Fin n → Digest) + (hresult : .done false finalState (values, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((sequenceFin fun position => + revealFtsSecret parameter (coordinates position)).run cache))) : + RevealedOnlyFrom state finalState + (fun coordinate => ∃ position, coordinate = coordinates position) := by + induction n generalizing state cache finalState finalCache with + | zero => + simp only [sequenceFin] at hresult + simp [AdaptiveRevealProbe.runDetailed, hclean] at hresult + obtain ⟨hstate, _⟩ := hresult + subst finalState + intro coordinate value hrevealed + exact Or.inl hrevealed + | succ n ih => + rw [sequenceFin, StateT.run_bind] at hresult + obtain ⟨headState, headResult, hhead, hafterHead⟩ := + mem_support_runDetailed_bind_probeFree table state finalState fuel + ((revealFtsSecret parameter (coordinates 0)).run cache) _ + (revealFtsSecret_probeFree parameter (coordinates 0) cache) + hclean (values, finalCache) hresult + rcases headResult with ⟨head, headCache⟩ + have hheadClean : AdaptiveRevealProbe.tableHits headState table = false := + tableHits_false_of_mem_runDetailed_probeFree table state headState fuel + ((revealFtsSecret parameter (coordinates 0)).run cache) + (revealFtsSecret_probeFree parameter (coordinates 0) cache) + hclean (head, headCache) hhead + have hheadSynced : RevealedSynced parameter table headState headCache := + revealedSynced_of_mem_runDetailed_revealFtsSecret parameter table state headState + fuel cache headCache (coordinates 0) head hclean hsynced + (by + have h := hcached (coordinates 0).2.1 (coordinates 0).2.2 + rw [← hcoordinates 0] at h + exact h) + hhead + have hheadOrigin := revealedOnlyFrom_revealFtsSecret parameter table state headState + fuel cache headCache (coordinates 0) head hclean hsynced + (by + have h := hcached (coordinates 0).2.1 (coordinates 0).2.2 + rw [← hcoordinates 0] at h + exact h) + hhead + rw [StateT.run_bind] at hafterHead + obtain ⟨tailState, tailResult, htail, hfinish⟩ := + mem_support_runDetailed_bind_probeFree table headState finalState fuel + ((sequenceFin fun position => + revealFtsSecret parameter (coordinates position.succ)).run headCache) _ + (sequenceFin_probeFree + (fun position => revealFtsSecret parameter (coordinates position.succ)) + (fun position => revealFtsSecret_probeFree parameter + (coordinates position.succ)) headCache) + hheadClean (values, finalCache) hafterHead + rcases tailResult with ⟨tail, tailCache⟩ + have hhiddenEq := hiddenLeaf_eq_of_mem_runDetailed_revealFtsSecret parameter table + state headState fuel cache headCache (coordinates 0) head hclean hsynced + (by + have h := hcached (coordinates 0).2.1 (coordinates 0).2.2 + rw [← hcoordinates 0] at h + exact h) + hhead + have htailCached : HiddenIndexCached index headCache := by + intro tree leafIdx + obtain ⟨output, houtput⟩ := hcached tree leafIdx + exact ⟨output, (hhiddenEq (index, tree, leafIdx)).trans houtput⟩ + have htailOrigin := ih + (coordinates := fun position => coordinates position.succ) + (hcoordinates := fun position => hcoordinates position.succ) + (state := headState) (finalState := tailState) (cache := headCache) + (finalCache := tailCache) (values := tail) + hheadClean hheadSynced htailCached htail + have hparts := AdaptiveRevealProbe.DetailedResult.done.inj hfinish + have hfinalState := hparts.2.1 + subst finalState + intro coordinate value hrevealed + rcases htailOrigin coordinate value hrevealed with hmiddle | ⟨position, hposition⟩ + · rcases hheadOrigin coordinate value hmiddle with hinitial | hzero + · exact Or.inl hinitial + · exact Or.inr ⟨0, hzero⟩ + · exact Or.inr ⟨position.succ, hposition⟩ + +theorem revealedOnlyFrom_revealSelectedFtsSecrets + (parameter : PublicParameter) (table : Coordinate → Digest) (index : Index) + (leaves : DigestTree → FtsLeaf) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state cache) + (hcached : HiddenIndexCached index cache) + (values : FtsTree → Digest) + (hresult : .done false finalState (values, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((revealSelectedFtsSecrets parameter index leaves).run cache))) : + RevealedOnlyFrom state finalState (SelectedCoordinate index leaves) := by + unfold revealSelectedFtsSecrets at hresult + have horigin := revealedOnlyFrom_revealSequence parameter table index + (fun tree => (index, tree, leaves (ftsIndexOf tree))) (fun tree => rfl) + state finalState fuel cache finalCache hclean hsynced hcached values hresult + intro coordinate value hrevealed + rcases horigin coordinate value hrevealed with hinitial | ⟨tree, htree⟩ + · exact Or.inl hinitial + · subst coordinate + exact Or.inr ⟨rfl, rfl⟩ + +set_option maxRecDepth 4000 in +theorem revealedOnlyFrom_maskedSignAfterDigest + (secretKey : SecretKey) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (randomness : Randomness) (index : Index) + (leaves : DigestTree → FtsLeaf) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced secretKey.parameter table state cache) + (signature : Option Signature) + (hresult : .done false finalState (signature, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((maskedSignAfterDigest secretKey randomness index leaves).run cache))) : + ∀ coordinate value, finalState.revealed coordinate = some value → + state.revealed coordinate = some value ∨ + ∃ concrete, signature = some concrete ∧ concrete.randomness = randomness ∧ + SelectedCoordinate index leaves coordinate := by + unfold maskedSignAfterDigest at hresult + rw [StateT.run_bind] at hresult + obtain ⟨pathState, pathResult, hpath, hafterPath⟩ := + mem_support_runDetailed_bind_probeFree table state finalState fuel + ((maskedFtsOpen secretKey.parameter index leaves).run cache) _ + (maskedFtsOpen_probeFree secretKey.parameter index leaves cache) hclean + (signature, finalCache) hresult + rcases pathResult with ⟨ftsPath, pathCache⟩ + have hpathClean : AdaptiveRevealProbe.tableHits pathState table = false := + tableHits_false_of_mem_runDetailed_probeFree table state pathState fuel + ((maskedFtsOpen secretKey.parameter index leaves).run cache) + (maskedFtsOpen_probeFree secretKey.parameter index leaves cache) hclean + (ftsPath, pathCache) hpath + have hpathSynced : RevealedSynced secretKey.parameter table pathState pathCache := + revealedSynced_of_mem_runDetailed_stateFree secretKey.parameter table state pathState + fuel cache pathCache ftsPath (maskedFtsOpen secretKey.parameter index leaves) hclean + hsynced (maskedFtsOpen_stateFree secretKey.parameter index leaves) + (maskedFtsOpen_cachePreserving secretKey.parameter index leaves) hpath + have hpathState : pathState = state := by + obtain ⟨raw, heq⟩ := AdaptiveRevealProbe.runDetailed_stateFree_support table state fuel + ((maskedFtsOpen secretKey.parameter index leaves).run cache) + (maskedFtsOpen_stateFree secretKey.parameter index leaves cache) hclean + (.done false pathState (ftsPath, pathCache)) hpath + exact (AdaptiveRevealProbe.DetailedResult.done.inj heq).2.1 + rw [StateT.run_bind] at hafterPath + obtain ⟨layersState, layersResult, hlayers, hafterLayers⟩ := + mem_support_runDetailed_bind_probeFree table pathState finalState fuel + ((sequenceFin fun lay => maskedSignLayer secretKey index lay).run pathCache) _ + (sequenceFin_probeFree (fun lay => maskedSignLayer secretKey index lay) + (fun lay => maskedSignLayer_probeFree secretKey index lay) pathCache) + hpathClean (signature, finalCache) hafterPath + rcases layersResult with ⟨layers, layersCache⟩ + have hlayersClean : AdaptiveRevealProbe.tableHits layersState table = false := + tableHits_false_of_mem_runDetailed_probeFree table pathState layersState fuel + ((sequenceFin fun lay => maskedSignLayer secretKey index lay).run pathCache) + (sequenceFin_probeFree (fun lay => maskedSignLayer secretKey index lay) + (fun lay => maskedSignLayer_probeFree secretKey index lay) pathCache) + hpathClean (layers, layersCache) hlayers + have hlayersSynced : RevealedSynced secretKey.parameter table layersState layersCache := + revealedSynced_of_mem_runDetailed_stateFree secretKey.parameter table pathState layersState + fuel pathCache layersCache layers + (sequenceFin fun lay => maskedSignLayer secretKey index lay) hpathClean hpathSynced + (sequenceFin_stateFree (fun lay => maskedSignLayer secretKey index lay) + (fun lay => maskedSignLayer_stateFree secretKey index lay)) + (sequenceFin_cachePreserving (fun lay => maskedSignLayer secretKey index lay) + (fun lay => maskedSignLayer_cachePreserving secretKey index lay)) hlayers + have hlayersState : layersState = pathState := by + obtain ⟨raw, heq⟩ := AdaptiveRevealProbe.runDetailed_stateFree_support table pathState fuel + ((sequenceFin fun lay => maskedSignLayer secretKey index lay).run pathCache) + (sequenceFin_stateFree (fun lay => maskedSignLayer secretKey index lay) + (fun lay => maskedSignLayer_stateFree secretKey index lay) pathCache) + hpathClean (.done false layersState (layers, layersCache)) hlayers + exact (AdaptiveRevealProbe.DetailedResult.done.inj heq).2.1 + have hlayersCached : HiddenIndexCached index layersCache := + hiddenIndexCached_of_mem_runDetailed_maskedSignLayers secretKey table pathState + layersState fuel pathCache layersCache index layers hpathClean hlayers + cases hparts : traverseOption layers with + | none => + simp only [hparts] at hafterLayers + simp [AdaptiveRevealProbe.runDetailed, hlayersClean] at hafterLayers + obtain ⟨hstate, _, _⟩ := hafterLayers + subst finalState + intro coordinate value hrevealed + exact Or.inl (by simpa [hlayersState, hpathState] using hrevealed) + | some parts => + simp only [hparts, StateT.run_bind] at hafterLayers + obtain ⟨selectedState, selectedResult, hselected, hfinish⟩ := + mem_support_runDetailed_bind_probeFree table layersState finalState fuel + ((revealSelectedFtsSecrets secretKey.parameter index leaves).run layersCache) _ + (revealSelectedFtsSecrets_probeFree secretKey.parameter index leaves layersCache) + hlayersClean (signature, finalCache) hafterLayers + rcases selectedResult with ⟨selected, selectedCache⟩ + have horigin := revealedOnlyFrom_revealSelectedFtsSecrets secretKey.parameter table + index leaves layersState selectedState fuel layersCache selectedCache hlayersClean + hlayersSynced hlayersCached selected hselected + have hselectedClean : AdaptiveRevealProbe.tableHits selectedState table = false := + tableHits_false_of_mem_runDetailed_probeFree table layersState selectedState fuel + ((revealSelectedFtsSecrets secretKey.parameter index leaves).run layersCache) + (revealSelectedFtsSecrets_probeFree secretKey.parameter index leaves layersCache) + hlayersClean (selected, selectedCache) hselected + simp [AdaptiveRevealProbe.runDetailed, hselectedClean] at hfinish + obtain ⟨hstate, hsignature, _⟩ := hfinish + subst finalState + intro coordinate value hrevealed + rcases horigin coordinate value hrevealed with hold | hselectedCoordinate + · exact Or.inl (by simpa [hlayersState, hpathState] using hold) + · refine Or.inr ⟨_, hsignature, rfl, hselectedCoordinate⟩ + +set_option maxRecDepth 10000 in +theorem revealedOnlyFrom_maskedSignWithView + (secretKey : SecretKey) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (message : Message) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced secretKey.parameter table state cache) + (result : Option Signature × Option FewTimeView) + (f : QueryImpl HashSpec Id) + (hf : (mergedCache secretKey.parameter table finalCache).AgreesWithFn f) + (hresult : .done false finalState (result, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((maskedSignWithView secretKey message).run cache))) : + ∀ coordinate value, finalState.revealed coordinate = some value → + state.revealed coordinate = some value ∨ + ∃ concrete index leaves, + result.1 = some concrete + ∧ SuccessfulDigestRun f (mergedCache secretKey.parameter table finalCache) + (secretKeyWithFtsTable secretKey table) message concrete.randomness index leaves + ∧ SelectedCoordinate index leaves coordinate := by + unfold maskedSignWithView at hresult + rw [StateT.run_bind] at hresult + obtain ⟨loopState, loopResult, hloop, hafterLoop⟩ := + mem_support_runDetailed_bind_probeFree table state finalState fuel + ((simulateQ splitRomImpl + (signDigestLoop digestAttemptLimit secretKey message)).run cache) _ + (simulateQ_splitRomImpl_probeFree + (signDigestLoop digestAttemptLimit secretKey message) cache) + hclean (result, finalCache) hresult + rcases loopResult with ⟨selected, loopCache⟩ + have hloopClean : AdaptiveRevealProbe.tableHits loopState table = false := + tableHits_false_of_mem_runDetailed_probeFree table state loopState fuel + ((simulateQ splitRomImpl + (signDigestLoop digestAttemptLimit secretKey message)).run cache) + (simulateQ_splitRomImpl_probeFree + (signDigestLoop digestAttemptLimit secretKey message) cache) + hclean (selected, loopCache) hloop + have hloopSynced : RevealedSynced secretKey.parameter table loopState loopCache := + revealedSynced_of_mem_runDetailed_stateFree secretKey.parameter table state loopState + fuel cache loopCache selected + (simulateQ splitRomImpl (signDigestLoop digestAttemptLimit secretKey message)) + hclean hsynced + (simulateQ_splitRomImpl_stateFree + (signDigestLoop digestAttemptLimit secretKey message)) + (simulateQ_splitRomImpl_cachePreserving + (signDigestLoop digestAttemptLimit secretKey message)) hloop + have hloopState : loopState = state := by + obtain ⟨raw, heq⟩ := AdaptiveRevealProbe.runDetailed_stateFree_support table state fuel + ((simulateQ splitRomImpl + (signDigestLoop digestAttemptLimit secretKey message)).run cache) + (simulateQ_splitRomImpl_stateFree + (signDigestLoop digestAttemptLimit secretKey message) cache) + hclean (.done false loopState (selected, loopCache)) hloop + exact (AdaptiveRevealProbe.DetailedResult.done.inj heq).2.1 + cases selected with + | none => + simp [AdaptiveRevealProbe.runDetailed, hloopClean] at hafterLoop + obtain ⟨hstate, _, _⟩ := hafterLoop + subst finalState + intro coordinate value hrevealed + exact Or.inl (by simpa [hloopState] using hrevealed) + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + rw [StateT.run_bind] at hafterLoop + obtain ⟨signatureState, signatureResult, hsignature, hfinish⟩ := + mem_support_runDetailed_bind_probeFree table loopState finalState fuel + ((maskedSignAfterDigest secretKey randomness index leaves).run loopCache) _ + (maskedSignAfterDigest_probeFree secretKey randomness index leaves loopCache) + hloopClean (result, finalCache) hafterLoop + rcases signatureResult with ⟨signature, signatureCache⟩ + have hsignatureSynced : + RevealedSynced secretKey.parameter table signatureState signatureCache := + revealedSynced_of_mem_runDetailed_maskedSignAfterDigest secretKey table loopState + signatureState fuel loopCache signatureCache randomness index leaves hloopClean + hloopSynced signature hsignature + have horigin := revealedOnlyFrom_maskedSignAfterDigest secretKey table loopState + signatureState fuel loopCache signatureCache randomness index leaves hloopClean + hloopSynced signature hsignature + have hsignatureClean : AdaptiveRevealProbe.tableHits signatureState table = false := + tableHits_false_of_mem_runDetailed_probeFree table loopState signatureState fuel + ((maskedSignAfterDigest secretKey randomness index leaves).run loopCache) + (maskedSignAfterDigest_probeFree secretKey randomness index leaves loopCache) + hloopClean (signature, signatureCache) hsignature + simp [AdaptiveRevealProbe.runDetailed, hsignatureClean] at hfinish + obtain ⟨hstate, hvalue, hcache⟩ := hfinish + subst finalState + subst finalCache + intro coordinate value hrevealed + rcases horigin coordinate value hrevealed with hold | + ⟨concrete, hsignatureSome, hrandomness, hcoordinate⟩ + · exact Or.inl (by simpa [hloopState] using hold) + · have hafterActual := CoupledAt.mem_support_ordinary + (parameter := secretKey.parameter) (table := table) (state := loopState) + (fuel := fuel) + (masked := maskedSignAfterDigest secretKey randomness index leaves) + (ordinary := simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest (secretKeyWithFtsTable secretKey table) + randomness index leaves)) + (cache := loopCache) (finalState := signatureState) + (finalCache := signatureCache) (value := signature) + (coupledAt_maskedSignAfterDigest secretKey table loopState fuel loopCache + randomness index leaves hloopClean hloopSynced) + hsignature + have hle : mergedCache secretKey.parameter table loopCache ≤ + mergedCache secretKey.parameter table signatureCache := + simulateQ_randomOracle_cache_le + (signAfterDigest (secretKeyWithFtsTable secretKey table) + randomness index leaves) + (mergedCache secretKey.parameter table loopCache) + (mergedCache secretKey.parameter table signatureCache) signature hafterActual + have hloopActualBase := CoupledAt.mem_support_ordinary + (parameter := secretKey.parameter) (table := table) (state := state) + (fuel := fuel) + (masked := simulateQ splitRomImpl + (signDigestLoop digestAttemptLimit secretKey message)) + (ordinary := simulateQ romImpl + (signDigestLoop digestAttemptLimit secretKey message)) + (cache := cache) (finalState := loopState) (finalCache := loopCache) + (value := some (randomness, index, leaves)) + ((coupled_simulateQ_splitRomImpl secretKey.parameter table state fuel + (signDigestLoop digestAttemptLimit secretKey message) hclean + (romOrdinaryOnly_signDigestLoop digestAttemptLimit secretKey table message)).coupledAt + cache) + hloop + have hloopActual : (some (randomness, index, leaves), + mergedCache secretKey.parameter table loopCache) ∈ support + ((simulateQ romImpl + (signDigestLoop digestAttemptLimit + (secretKeyWithFtsTable secretKey table) message)).run + (mergedCache secretKey.parameter table cache)) := by + rw [signDigestLoop_secretKeyWithFtsTable] + exact hloopActualBase + have hloopReplay := replayRom_of_mem_support + (signDigestLoop digestAttemptLimit + (secretKeyWithFtsTable secretKey table) message) + (mergedCache secretKey.parameter table cache) + (some (randomness, index, leaves)) + (mergedCache secretKey.parameter table loopCache) + hloopActual f (fun input output hcached => hf (hle hcached)) + have hdigest := successfulDigestLoop_of_mem_support f + (secretKeyWithFtsTable secretKey table) message digestAttemptLimit + randomness index leaves + (mergedCache secretKey.parameter table cache) + (mergedCache secretKey.parameter table loopCache) + (mergedCache secretKey.parameter table signatureCache) + hloopReplay hle hf + refine Or.inr ⟨concrete, index, leaves, ?_, ?_, hcoordinate⟩ + · simpa [hvalue] using hsignatureSome + · simpa [hrandomness] using hdigest + +set_option maxRecDepth 10000 in +theorem revealedOnlyFrom_maskedSigningImpl + (secretKey : SecretKey) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (message : Message) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced secretKey.parameter table state cache) + (signature : Option Signature) + (f : QueryImpl HashSpec Id) + (hf : (mergedCache secretKey.parameter table finalCache).AgreesWithFn f) + (hresult : .done false finalState (signature, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((maskedSigningImpl secretKey message).run cache))) : + ∀ coordinate value, finalState.revealed coordinate = some value → + state.revealed coordinate = some value ∨ + ∃ concrete index leaves, + signature = some concrete + ∧ SuccessfulDigestRun f (mergedCache secretKey.parameter table finalCache) + (secretKeyWithFtsTable secretKey table) message concrete.randomness index leaves + ∧ SelectedCoordinate index leaves coordinate := by + unfold maskedSigningImpl at hresult + rw [StateT.run_map] at hresult + change .done false finalState (signature, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + (((fun result : Option Signature × Option FewTimeView => result.1) <$> + maskedSignWithView secretKey message).run cache)) at hresult + rw [StateT.run_map, map_eq_bind_pure_comp, + AdaptiveRevealProbe.runDetailed_bind_probeFree table state fuel + ((maskedSignWithView secretKey message).run cache) _ + (maskedSignWithView_probeFree secretKey message cache), mem_support_bind_iff] at hresult + obtain ⟨viewResult, hviewResult, hfinish⟩ := hresult + obtain ⟨viewState, viewValue, heq, hviewClean⟩ := + AdaptiveRevealProbe.runDetailed_probeFree_support table state fuel + ((maskedSignWithView secretKey message).run cache) + (maskedSignWithView_probeFree secretKey message cache) hclean viewResult hviewResult + subst viewResult + simp [AdaptiveRevealProbe.runDetailed, hviewClean] at hfinish + obtain ⟨hstate, hvalue, hcache⟩ := hfinish + subst finalState + subst finalCache + have horigin := revealedOnlyFrom_maskedSignWithView secretKey table state viewState fuel + cache viewValue.2 message hclean hsynced viewValue.1 f hf hviewResult + intro coordinate value hrevealed + rcases horigin coordinate value hrevealed with hold | + ⟨concrete, index, leaves, hsome, hdigest, hcoordinate⟩ + · exact Or.inl hold + · refine Or.inr ⟨concrete, index, leaves, ?_, hdigest, hcoordinate⟩ + simpa [hvalue] using hsome + +set_option maxHeartbeats 1200000 in +set_option maxRecDepth 20000 in +theorem revealedOnlyFrom_signingTraceComputation + (secretKey : SecretKey) (table : Coordinate → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (value : alpha) (log : QueryLog SigningSpec) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced secretKey.parameter table state cache) + (f : QueryImpl HashSpec Id) + (hf : (mergedCache secretKey.parameter table finalCache).AgreesWithFn f) + (hresult : .done false finalState ((value, log), finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (signingTraceComputation computation)).run cache))) : + RevealedOnlyFrom state finalState + (CoveredByLog f (mergedCache secretKey.parameter table finalCache) + (secretKeyWithFtsTable secretKey table) log) := by + induction computation using OracleComp.inductionOn generalizing + state fuel cache finalState finalCache value log with + | pure result => + simp [signingTraceComputation, simulateQ_pure, + AdaptiveRevealProbe.runDetailed, hclean] at hresult + obtain ⟨hstate, hvalue, hlog, hcache⟩ := hresult + subst finalState + obtain ⟨hvalue, hlog'⟩ := hvalue + subst value + subst log + intro coordinate revealedValue hrevealed + exact Or.inl hrevealed + | query_bind input next ih => + rw [signingTraceComputation_query_bind, simulateQ_bind, StateT.run_bind] at hresult + cases input with + | inl worldInput => + cases worldInput with + | inl n => + obtain ⟨queryState, queryResult, hquery, hrest⟩ := + mem_support_runDetailed_bind_probeFree table state finalState fuel + ((splitUniformImpl n).run cache) + (fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + ((fun tail => (tail.1, + signingLogFragment (.inl (.inl n)) result.1 ++ tail.2)) <$> + signingTraceComputation (next result.1))).run result.2) + (splitUniformImpl_probeFree n cache) hclean + ((value, log), finalCache) (by + simpa [maskedExpandedAdversaryImpl, probingRomImpl, + probingHashImpl] using hresult) + rcases queryResult with ⟨output, queryCache⟩ + have hstep := maskedExpandedAdversaryImpl_done_false secretKey table state + queryState fuel cache queryCache (.inl (.inl n)) output hclean hsynced hquery + obtain ⟨tailLog, hlog, htailResult⟩ := peel_signingTrace_tail secretKey table + (next output) (signingLogFragment (.inl (.inl n)) output) + queryState finalState fuel queryCache finalCache value log hrest + have htail := ih output queryState finalState fuel queryCache finalCache value + tailLog hstep.2.1 hstep.2.2 hf htailResult + have hqueryState : queryState = state := by + obtain ⟨raw, heq⟩ := AdaptiveRevealProbe.runDetailed_stateFree_support + table state fuel ((splitUniformImpl n).run cache) + (splitUniformImpl_stateFree n cache) hclean + (.done false queryState (output, queryCache)) hquery + exact (AdaptiveRevealProbe.DetailedResult.done.inj heq).2.1 + intro coordinate revealedValue hrevealed + rcases htail coordinate revealedValue hrevealed with hold | hcovered + · exact Or.inl (by simpa [hqueryState] using hold) + · rw [hlog] + exact Or.inr hcovered.mono_log + | inr hashInput => + have hhashResult : .done false finalState ((value, log), finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((probingHashQuery secretKey.parameter hashInput).run cache >>= fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + ((fun tail => (tail.1, + signingLogFragment (.inl (.inr hashInput)) result.1 ++ tail.2)) <$> + signingTraceComputation (next result.1))).run result.2)) := by + simpa [maskedExpandedAdversaryImpl, probingRomImpl, + probingHashImpl] using hresult + cases hdecode : decodeProbe? secretKey.parameter hashInput with + | none => + have hhashProbeFree : ProbeFree + (probingHashQuery secretKey.parameter hashInput) := by + intro workingCache + rw [probingHashQuery_run_eq, hdecode] + exact splitHashQuery_probeFree (.ordinary hashInput) workingCache + obtain ⟨queryState, queryResult, hquery, hrest⟩ := + mem_support_runDetailed_bind_probeFree table state finalState fuel + ((probingHashQuery secretKey.parameter hashInput).run cache) + (fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + ((fun tail => (tail.1, + signingLogFragment (.inl (.inr hashInput)) result.1 ++ tail.2)) <$> + signingTraceComputation (next result.1))).run result.2) + (hhashProbeFree cache) hclean ((value, log), finalCache) hhashResult + rcases queryResult with ⟨output, queryCache⟩ + have hstep := maskedExpandedAdversaryImpl_done_false secretKey table state + queryState fuel cache queryCache (.inl (.inr hashInput)) output hclean + hsynced hquery + obtain ⟨tailLog, hlog, htailResult⟩ := peel_signingTrace_tail secretKey table + (next output) (signingLogFragment (.inl (.inr hashInput)) output) + queryState finalState fuel queryCache finalCache value log hrest + have htail := ih output queryState finalState fuel queryCache finalCache value + tailLog hstep.2.1 hstep.2.2 hf htailResult + have hrevealedEq := (probingHashQuery_done_false_invariants + secretKey.parameter table state queryState fuel cache queryCache + hashInput output hclean hquery).2 + intro coordinate revealedValue hrevealed + rcases htail coordinate revealedValue hrevealed with hold | hcovered + · exact Or.inl (by simpa [hrevealedEq] using hold) + · rw [hlog] + exact Or.inr hcovered.mono_log + | some probe => + rw [probingHashQuery_run_eq, hdecode] at hhashResult + change .done false finalState ((value, log), finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((liftM (OracleSpec.query + (spec := AdaptiveRevealProbe.World Coordinate) + (.probe (probe.index, probe.tree, probe.leafIdx) probe.candidate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Unit) >>= fun _ => + (splitHashQuery (.ordinary hashInput)).run cache >>= fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + ((fun tail => (tail.1, + signingLogFragment (.inl (.inr hashInput)) result.1 ++ tail.2)) <$> + signingTraceComputation (next result.1))).run result.2)) at hhashResult + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind] at hhashResult + cases fuel with + | zero => simp at hhashResult + | succ remaining => + cases hrevealed : state.revealed + (probe.index, probe.tree, probe.leafIdx) with + | none => + simp only [hrevealed] at hhashResult + by_cases hhit : table (probe.index, probe.tree, probe.leafIdx) = + probe.candidate + · have hpostClean := tableHits_false_of_mem_runDetailed_done_false + table + (state.addPending + (probe.index, probe.tree, probe.leafIdx) probe.candidate) + finalState remaining + ((splitHashQuery (.ordinary hashInput)).run cache >>= fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + ((fun tail => (tail.1, + signingLogFragment (.inl (.inr hashInput)) result.1 ++ + tail.2)) <$> + signingTraceComputation (next result.1))).run result.2) + ((value, log), finalCache) hhashResult + have hpostHit := AdaptiveRevealProbe.tableHits_addPending_eq_true + state table (probe.index, probe.tree, probe.leafIdx) + probe.candidate hhit + rw [hpostHit] at hpostClean + simp at hpostClean + · have hpostClean := AdaptiveRevealProbe.tableHits_addPending_eq_false + state table (probe.index, probe.tree, probe.leafIdx) + probe.candidate hclean hhit + obtain ⟨queryState, queryResult, hquery, hrest⟩ := + mem_support_runDetailed_bind_probeFree table + (state.addPending + (probe.index, probe.tree, probe.leafIdx) probe.candidate) + finalState remaining + ((splitHashQuery (.ordinary hashInput)).run cache) + (fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + ((fun tail => (tail.1, + signingLogFragment (.inl (.inr hashInput)) result.1 ++ + tail.2)) <$> + signingTraceComputation (next result.1))).run result.2) + (splitHashQuery_probeFree (.ordinary hashInput) cache) + hpostClean ((value, log), finalCache) hhashResult + rcases queryResult with ⟨output, queryCache⟩ + have hqueryOriginal : .done false queryState + (output, queryCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((probingHashQuery secretKey.parameter hashInput).run cache)) := by + rw [probingHashQuery_run_eq, hdecode] + change .done false queryState (output, queryCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((liftM (OracleSpec.query + (spec := AdaptiveRevealProbe.World Coordinate) + (.probe (probe.index, probe.tree, probe.leafIdx) + probe.candidate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Unit) >>= + fun _ => + (splitHashQuery (.ordinary hashInput)).run cache)) + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind, hrevealed] + exact hquery + have hstep := maskedExpandedAdversaryImpl_done_false secretKey table + state queryState (remaining + 1) cache queryCache + (.inl (.inr hashInput)) output hclean hsynced hqueryOriginal + obtain ⟨tailLog, hlog, htailResult⟩ := peel_signingTrace_tail + secretKey table (next output) + (signingLogFragment (.inl (.inr hashInput)) output) + queryState finalState remaining queryCache finalCache value log hrest + have htail := ih output queryState finalState remaining queryCache + finalCache value tailLog hstep.2.1 hstep.2.2 hf htailResult + have hrevealedEq := (probingHashQuery_done_false_invariants + secretKey.parameter table state queryState (remaining + 1) + cache queryCache hashInput output hclean hqueryOriginal).2 + intro coordinate revealedValue hfinalRevealed + rcases htail coordinate revealedValue hfinalRevealed with + hold | hcovered + · exact Or.inl (by simpa [hrevealedEq] using hold) + · rw [hlog] + exact Or.inr hcovered.mono_log + | some revealedValue => + simp only [hrevealed] at hhashResult + obtain ⟨queryState, queryResult, hquery, hrest⟩ := + mem_support_runDetailed_bind_probeFree table state finalState + remaining ((splitHashQuery (.ordinary hashInput)).run cache) + (fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + ((fun tail => (tail.1, + signingLogFragment (.inl (.inr hashInput)) result.1 ++ + tail.2)) <$> + signingTraceComputation (next result.1))).run result.2) + (splitHashQuery_probeFree (.ordinary hashInput) cache) + hclean ((value, log), finalCache) hhashResult + rcases queryResult with ⟨output, queryCache⟩ + have hqueryOriginal : .done false queryState + (output, queryCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((probingHashQuery secretKey.parameter hashInput).run cache)) := by + rw [probingHashQuery_run_eq, hdecode] + change .done false queryState (output, queryCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((liftM (OracleSpec.query + (spec := AdaptiveRevealProbe.World Coordinate) + (.probe (probe.index, probe.tree, probe.leafIdx) + probe.candidate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Unit) >>= + fun _ => + (splitHashQuery (.ordinary hashInput)).run cache)) + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind, hrevealed] + exact hquery + have hstep := maskedExpandedAdversaryImpl_done_false secretKey table + state queryState (remaining + 1) cache queryCache + (.inl (.inr hashInput)) output hclean hsynced hqueryOriginal + obtain ⟨tailLog, hlog, htailResult⟩ := peel_signingTrace_tail + secretKey table (next output) + (signingLogFragment (.inl (.inr hashInput)) output) + queryState finalState remaining queryCache finalCache value log hrest + have htail := ih output queryState finalState remaining queryCache + finalCache value tailLog hstep.2.1 hstep.2.2 hf htailResult + have hrevealedEq := (probingHashQuery_done_false_invariants + secretKey.parameter table state queryState (remaining + 1) + cache queryCache hashInput output hclean hqueryOriginal).2 + intro coordinate finalValue hfinalRevealed + rcases htail coordinate finalValue hfinalRevealed with hold | hcovered + · exact Or.inl (by simpa [hrevealedEq] using hold) + · rw [hlog] + exact Or.inr hcovered.mono_log + | inr message => + have hsignProbeFree : ProbeFree (maskedSigningImpl secretKey message) := by + unfold maskedSigningImpl + exact (maskedSignWithView_probeFree secretKey message).map Prod.fst + obtain ⟨queryState, queryResult, hquery, hrest⟩ := + mem_support_runDetailed_bind_probeFree table state finalState fuel + ((maskedSigningImpl secretKey message).run cache) + (fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + ((fun tail => (tail.1, + signingLogFragment (.inr message) result.1 ++ tail.2)) <$> + signingTraceComputation (next result.1))).run result.2) + (hsignProbeFree cache) hclean ((value, log), finalCache) (by + simpa [maskedExpandedAdversaryImpl, probingRomImpl, + probingHashImpl] using hresult) + rcases queryResult with ⟨output, queryCache⟩ + have hstep := maskedExpandedAdversaryImpl_done_false secretKey table state + queryState fuel cache queryCache (.inr message) output hclean hsynced hquery + obtain ⟨tailLog, hlog, htailResult⟩ := peel_signingTrace_tail secretKey table + (next output) (signingLogFragment (.inr message) output) + queryState finalState fuel queryCache finalCache value log hrest + have htail := ih output queryState finalState fuel queryCache finalCache value + tailLog hstep.2.1 hstep.2.2 hf htailResult + have htailActual := simulateQ_maskedExpandedAdversaryImpl_done_false secretKey table + (signingTraceComputation (next output)) queryState finalState fuel queryCache + finalCache (value, tailLog) hstep.2.1 hstep.2.2 htailResult + have hle : mergedCache secretKey.parameter table queryCache ≤ + mergedCache secretKey.parameter table finalCache := + simulateQ_unloggedMappedAdversaryImpl_cache_le + (secretKeyWithFtsTable secretKey table) + (signingTraceComputation (next output)) + (mergedCache secretKey.parameter table queryCache) + (mergedCache secretKey.parameter table finalCache) + (value, tailLog) htailActual.1 + have hqueryOrigin := revealedOnlyFrom_maskedSigningImpl secretKey table state + queryState fuel cache queryCache message hclean hsynced output f + (fun input answer hcached => hf (hle hcached)) hquery + intro coordinate revealedValue hfinalRevealed + rcases htail coordinate revealedValue hfinalRevealed with hqueryRevealed | hcovered + · rcases hqueryOrigin coordinate revealedValue hqueryRevealed with + hinitial | ⟨signature, index, leaves, houtput, hdigest, hcoordinate⟩ + · exact Or.inl hinitial + · rw [hlog] + refine Or.inr ⟨message, signature, index, leaves, ?_, ?_, hcoordinate⟩ + · simp [signingLogFragment, houtput] + · exact ⟨hdigest.1, hdigest.2.1, hdigest.2.2.mono hle⟩ + · rw [hlog] + exact Or.inr hcovered.mono_log + +theorem signedFtsLeaf_of_signing_entry_selected + (f : QueryImpl HashSpec Id) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (initialCache : QueryCache HashSpec) (value : alpha) + (signingLog : QueryLog SigningSpec) (adversaryCache finalCache : QueryCache HashSpec) + (hmem : ((value, signingLog), adversaryCache) ∈ support + ((simulateQ romImpl + ((simulateQ (forwardOracles + signingOracle scheme secretKey) + computation).run)).run initialCache)) + (hle : adversaryCache ≤ finalCache) (hf : finalCache.AgreesWithFn f) + (message : Message) (signature : Signature) (index : Index) + (leaves : DigestTree → FtsLeaf) (coordinate : Coordinate) + (hentry : (⟨message, some signature⟩ : SigningEntry) ∈ signingLog) + (hdigest : SuccessfulDigestRun f finalCache secretKey message signature.randomness + index leaves) + (hselected : SelectedCoordinate index leaves coordinate) : + SignedFtsLeaf f finalCache secretKey signingLog coordinate.1 coordinate.2.1 + coordinate.2.2 := by + have hrun := successfulSignRun_of_signing_entry f secretKey computation initialCache value + signingLog adversaryCache finalCache hmem hle hf + (⟨message, some signature⟩ : SigningEntry) signature rfl hentry + obtain ⟨actualIndex, actualLeaves, hhonest⟩ := hrun.honest_fts_at + have hselection : (actualIndex, actualLeaves) = (index, leaves) := by + apply Option.some.inj + exact hhonest.1.2.1.symm.trans hdigest.2.1 + have hindex : actualIndex = index := congrArg Prod.fst hselection + have hleaves : actualLeaves = leaves := congrArg Prod.snd hselection + subst actualIndex + subst actualLeaves + rw [hselected.1] + refine ⟨⟨message, some signature⟩, signature, leaves, hentry, rfl, hrun, + hhonest, ?_⟩ + exact hselected.2.symm + +theorem simulateQ_unloggedMapped_signingTraceComputation + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) : + simulateQ (unloggedMappedAdversaryImpl secretKey) + (signingTraceComputation computation) = + simulateQ romImpl + ((simulateQ (forwardOracles + signingOracle scheme secretKey) computation).run) := by + rw [← simulateQ_withTraceAppend_run_eq_signingTraceComputation, + ← writerTMapBase_expanded_withTraceAppend_eq_unlogged, + ← QueryImpl.simulateQ_writerTMapBase_run, + ← forwardOracles_add_signingOracle_eq_withTraceAppend] + +theorem CoveredByLog.signedFtsLeaf + {f : QueryImpl HashSpec Id} {secretKey : SecretKey} + {computation : OracleComp (OracleWorld + SigningSpec) alpha} + {initialCache : QueryCache HashSpec} {value : alpha} + {signingLog : QueryLog SigningSpec} {adversaryCache finalCache : QueryCache HashSpec} + {coordinate : Coordinate} + (hcovered : CoveredByLog f finalCache secretKey signingLog coordinate) + (hmem : ((value, signingLog), adversaryCache) ∈ support + ((simulateQ romImpl + ((simulateQ (forwardOracles + signingOracle scheme secretKey) + computation).run)).run initialCache)) + (hle : adversaryCache ≤ finalCache) (hf : finalCache.AgreesWithFn f) : + SignedFtsLeaf f finalCache secretKey signingLog coordinate.1 coordinate.2.1 + coordinate.2.2 := by + obtain ⟨message, signature, index, leaves, hentry, hdigest, hselected⟩ := hcovered + exact signedFtsLeaf_of_signing_entry_selected f secretKey computation initialCache value + signingLog adversaryCache finalCache hmem hle hf message signature index leaves coordinate + hentry hdigest hselected + +set_option maxRecDepth 20000 in +theorem signedFtsLeaf_of_revealed_signingTraceComputation + (secretKey : SecretKey) (table : Coordinate → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (fuel : Nat) (initialCache finalCache : SplitHashCache) + (finalState : AdaptiveRevealProbe.State Coordinate) + (value : alpha) (log : QueryLog SigningSpec) + (hsynced : RevealedSynced secretKey.parameter table + AdaptiveRevealProbe.State.empty initialCache) + (f : QueryImpl HashSpec Id) + (hf : (mergedCache secretKey.parameter table finalCache).AgreesWithFn f) + (hresult : .done false finalState ((value, log), finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table AdaptiveRevealProbe.State.empty fuel + ((simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (signingTraceComputation computation)).run initialCache))) + (coordinate : Coordinate) (revealedValue : Digest) + (hrevealed : finalState.revealed coordinate = some revealedValue) : + SignedFtsLeaf f (mergedCache secretKey.parameter table finalCache) + (secretKeyWithFtsTable secretKey table) log coordinate.1 coordinate.2.1 + coordinate.2.2 := by + have hinitialClean : AdaptiveRevealProbe.tableHits + (AdaptiveRevealProbe.State.empty : AdaptiveRevealProbe.State Coordinate) table = false := by + simp [AdaptiveRevealProbe.tableHits, AdaptiveRevealProbe.State.empty] + have horigin := revealedOnlyFrom_signingTraceComputation secretKey table computation + AdaptiveRevealProbe.State.empty finalState fuel initialCache finalCache value log + hinitialClean hsynced f hf hresult + rcases horigin coordinate revealedValue hrevealed with hinitial | hcovered + · simp [AdaptiveRevealProbe.State.empty] at hinitial + · have hactual := simulateQ_maskedExpandedAdversaryImpl_done_false secretKey table + (signingTraceComputation computation) AdaptiveRevealProbe.State.empty finalState fuel + initialCache finalCache (value, log) hinitialClean hsynced hresult + rw [simulateQ_unloggedMapped_signingTraceComputation] at hactual + exact hcovered.signedFtsLeaf hactual.1 le_rfl hf + +set_option maxRecDepth 20000 in +theorem signedFtsLeaf_of_revealed_signingTraceComputation_at_reference + (secretKey : SecretKey) (table : Coordinate → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (fuel : Nat) (initialCache finalCache : SplitHashCache) + (finalState : AdaptiveRevealProbe.State Coordinate) + (value : alpha) (log : QueryLog SigningSpec) + (hsynced : RevealedSynced secretKey.parameter table + AdaptiveRevealProbe.State.empty initialCache) + (referenceCache : QueryCache HashSpec) + (hle : mergedCache secretKey.parameter table finalCache ≤ referenceCache) + (f : QueryImpl HashSpec Id) (hf : referenceCache.AgreesWithFn f) + (hresult : .done false finalState ((value, log), finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table AdaptiveRevealProbe.State.empty fuel + ((simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (signingTraceComputation computation)).run initialCache))) + (coordinate : Coordinate) (revealedValue : Digest) + (hrevealed : finalState.revealed coordinate = some revealedValue) : + SignedFtsLeaf f referenceCache (secretKeyWithFtsTable secretKey table) log + coordinate.1 coordinate.2.1 coordinate.2.2 := by + have hinitialClean : AdaptiveRevealProbe.tableHits + (AdaptiveRevealProbe.State.empty : AdaptiveRevealProbe.State Coordinate) table = false := by + simp [AdaptiveRevealProbe.tableHits, AdaptiveRevealProbe.State.empty] + have horigin := revealedOnlyFrom_signingTraceComputation secretKey table computation + AdaptiveRevealProbe.State.empty finalState fuel initialCache finalCache value log + hinitialClean hsynced f (fun input output hcached => hf (hle hcached)) hresult + rcases horigin coordinate revealedValue hrevealed with hinitial | hcovered + · simp [AdaptiveRevealProbe.State.empty] at hinitial + · have hactual := simulateQ_maskedExpandedAdversaryImpl_done_false secretKey table + (signingTraceComputation computation) AdaptiveRevealProbe.State.empty finalState fuel + initialCache finalCache (value, log) hinitialClean hsynced hresult + rw [simulateQ_unloggedMapped_signingTraceComputation] at hactual + exact (hcovered.mono_cache hle).signedFtsLeaf hactual.1 hle hf + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeProbability.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeProbability.lean new file mode 100644 index 00000000..be6c057d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeProbability.lean @@ -0,0 +1,964 @@ +import SphincsSecurity.Proof.FtsProbeTerminal +import SphincsSecurity.Proof.DirectQueryBudget +import VCVio.ProgramLogic.Relational.Basic + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem tableHits_addPending_eq_true_of_true + (state : AdaptiveRevealProbe.State Coordinate) (table : Coordinate → Digest) + (coordinate : Coordinate) (candidate : Digest) + (hhit : AdaptiveRevealProbe.tableHits state table = true) : + AdaptiveRevealProbe.tableHits (state.addPending coordinate candidate) table = true := by + classical + rw [AdaptiveRevealProbe.tableHits, decide_eq_true_eq] at hhit ⊢ + obtain ⟨other, hmem⟩ := hhit + refine ⟨other, ?_⟩ + by_cases heq : other = coordinate + · subst other + simp [AdaptiveRevealProbe.State.addPending, hmem] + · simpa [AdaptiveRevealProbe.State.addPending, Function.update_of_ne heq] using hmem + +theorem tableHits_install_eq_true_of_true + (state : AdaptiveRevealProbe.State Coordinate) (table : Coordinate → Digest) + (coordinate : Coordinate) (value : Digest) + (hhit : AdaptiveRevealProbe.tableHits state table = true) + (hmiss : table coordinate ∉ state.pending coordinate) : + AdaptiveRevealProbe.tableHits (state.install coordinate value) table = true := by + classical + rw [AdaptiveRevealProbe.tableHits, decide_eq_true_eq] at hhit ⊢ + obtain ⟨other, hmem⟩ := hhit + have hne : other ≠ coordinate := by + intro heq + subst other + exact hmiss hmem + exact ⟨other, by + simpa [AdaptiveRevealProbe.State.install, Function.update_of_ne hne] using hmem⟩ + +theorem runDetailed_hit_eq_true_of_tableHits_eq_true + (table : Coordinate → Digest) (state : AdaptiveRevealProbe.State Coordinate) + (fuel : Nat) (computation : OracleComp (AdaptiveRevealProbe.World Coordinate) alpha) + (hhit : AdaptiveRevealProbe.tableHits state table = true) : + ∀ result ∈ support (AdaptiveRevealProbe.runDetailed table state fuel computation), + result.hit = true := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure result => + intro detailed hdetailed + simp [AdaptiveRevealProbe.runDetailed, hhit] at hdetailed + subst detailed + rfl + | query_bind input next ih => + intro result hresult + cases input with + | uniform n => + rw [AdaptiveRevealProbe.runDetailed_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output state fuel hhit result hrest + | hashOutput => + rw [AdaptiveRevealProbe.runDetailed_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output state fuel hhit result hrest + | probe coordinate candidate => + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind] at hresult + cases fuel with + | zero => + simp [hhit] at hresult + subst result + rfl + | succ remaining => + cases hrevealed : state.revealed coordinate with + | none => + exact ih () (state.addPending coordinate candidate) remaining + (tableHits_addPending_eq_true_of_true state table coordinate candidate hhit) + result (by simpa [hrevealed] using hresult) + | some value => + exact ih () state remaining hhit result (by simpa [hrevealed] using hresult) + | reveal coordinate => + rw [AdaptiveRevealProbe.runDetailed_reveal_query_bind] at hresult + cases hrevealed : state.revealed coordinate with + | some value => + exact ih value state fuel hhit result (by simpa [hrevealed] using hresult) + | none => + by_cases hcandidate : table coordinate ∈ state.pending coordinate + · simp [hrevealed, hcandidate] at hresult + subst result + rfl + · exact ih (table coordinate) (state.install coordinate (table coordinate)) fuel + (tableHits_install_eq_true_of_true state table coordinate + (table coordinate) hhit hcandidate) + result (by simpa [hrevealed, hcandidate] using hresult) + +theorem relTriple_and_left_support + {left : ProbComp alpha} {right : ProbComp beta} + {relation : alpha → beta → Prop} (hrel : RelTriple left right relation) + (property : alpha → Prop) (hproperty : ∀ result ∈ support left, property result) : + RelTriple left right fun leftResult rightResult => + relation leftResult rightResult ∧ property leftResult := by + rw [relTriple_iff_relWP, relWP_iff_couplingPost] at hrel ⊢ + obtain ⟨coupling, hrelation⟩ := hrel + refine ⟨coupling, fun result hresult => ⟨hrelation result hresult, ?_⟩⟩ + apply hproperty result.1 + rw [mem_support_iff_evalDist_apply_ne_zero] + rw [← SPMF.mem_support_iff] + have hmap : result.1 ∈ support + (Prod.fst <$> coupling.1 : SPMF alpha) := by + rw [support_map] + exact ⟨result, hresult, rfl⟩ + rwa [coupling.2.map_fst] at hmap + +theorem relTriple_and_right_support + {left : ProbComp alpha} {right : ProbComp beta} + {relation : alpha → beta → Prop} (hrel : RelTriple left right relation) : + RelTriple left right fun leftResult rightResult => + relation leftResult rightResult ∧ rightResult ∈ support right := by + rw [relTriple_iff_relWP, relWP_iff_couplingPost] at hrel ⊢ + obtain ⟨coupling, hrelation⟩ := hrel + refine ⟨coupling, fun result hresult => ⟨hrelation result hresult, ?_⟩⟩ + rw [mem_support_iff_evalDist_apply_ne_zero] + rw [← SPMF.mem_support_iff] + have hmap : result.2 ∈ support + (Prod.snd <$> coupling.1 : SPMF beta) := by + rw [support_map] + exact ⟨result, hresult, rfl⟩ + rwa [coupling.2.map_snd] at hmap + +theorem relTriple_of_project_eq_some + (project : alpha → Option beta) (fallback : beta) + (left : ProbComp alpha) (right : ProbComp beta) + (heq : project <$> left = some <$> right) : + RelTriple left right fun leftResult rightResult => + project leftResult = none ∨ project leftResult = some rightResult := by + let recover : alpha → beta := fun result => (project result).getD fallback + have hrecover : recover <$> left = right := by + calc + recover <$> left = (fun result : Option beta => result.getD fallback) <$> + (project <$> left) := by + simp [recover, Functor.map_map] + _ = (fun result : Option beta => result.getD fallback) <$> (some <$> right) := by + rw [heq] + _ = right := by simp + have hself : RelTriple left left fun leftResult rightResult => + project leftResult = none ∨ + project leftResult = some (recover rightResult) := by + apply relTriple_post_mono (relTriple_refl left) + intro leftResult rightResult heqResult + subst rightResult + cases hproject : project leftResult with + | none => exact Or.inl rfl + | some result => + exact Or.inr (by simp [recover, hproject]) + have hmapped := relTriple_map + (R := fun leftResult rightResult => + project leftResult = none ∨ project leftResult = some rightResult) + (f := id) (g := recover) hself + simpa [hrecover] using hmapped + +theorem relTriple_of_project_eq_some_exact + (project : alpha → Option beta) (fallback : beta) + (left : ProbComp alpha) (right : ProbComp beta) + (heq : project <$> left = some <$> right) : + RelTriple left right fun leftResult rightResult => + project leftResult = some rightResult := by + have hweak := relTriple_of_project_eq_some project fallback left right heq + have hpresent : ∀ result ∈ support left, project result ≠ none := by + intro result hresult hnone + have hleftNone : none ∈ support (project <$> left) := by + rw [support_map] + exact ⟨result, hresult, hnone⟩ + rw [heq, support_map] at hleftNone + obtain ⟨rightResult, _hright, hsome⟩ := hleftNone + simp at hsome + apply relTriple_post_mono + (relTriple_and_left_support hweak (fun result => project result ≠ none) hpresent) + intro leftResult rightResult hresult + rcases hresult.1 with hnone | hsome + · exact (hresult.2 hnone).elim + · exact hsome + +theorem relTriple_of_coupledAt [Inhabited alpha] + {parameter : PublicParameter} {table : Coordinate → Digest} + {state : AdaptiveRevealProbe.State Coordinate} {fuel : Nat} + {masked : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha} + {ordinary : StateT (QueryCache HashSpec) ProbComp alpha} + {cache : SplitHashCache} + (hcoupled : CoupledAt parameter table state fuel masked ordinary cache) : + RelTriple + (AdaptiveRevealProbe.runDetailed table state fuel (masked.run cache)) + (ordinary.run (mergedCache parameter table cache)) + fun maskedResult ordinaryResult => + projectDetailedCache parameter table maskedResult = some ordinaryResult := by + exact relTriple_of_project_eq_some_exact + (projectDetailedCache parameter table) + (default, ∅) + (AdaptiveRevealProbe.runDetailed table state fuel (masked.run cache)) + (ordinary.run (mergedCache parameter table cache)) hcoupled + +def CleanResultRel (parameter : PublicParameter) (table : Coordinate → Digest) : + AdaptiveRevealProbe.DetailedResult Coordinate (alpha × SplitHashCache) → + (alpha × QueryCache HashSpec) → Prop + | .stopped _, _ => False + | .done hit finalState (value, finalCache), ordinaryResult => + hit = false ∧ + ordinaryResult = (value, mergedCache parameter table finalCache) ∧ + AdaptiveRevealProbe.tableHits finalState table = false ∧ + RevealedSynced parameter table finalState finalCache + +def CleanStepRel (parameter : PublicParameter) (table : Coordinate → Digest) : + AdaptiveRevealProbe.DetailedResult Coordinate (alpha × SplitHashCache) → + (alpha × QueryCache HashSpec) → Prop := + fun maskedResult ordinaryResult => maskedResult.hit = true ∨ + CleanResultRel parameter table maskedResult ordinaryResult + +theorem relTriple_of_coupledAt_cleanOnly [Inhabited alpha] + {parameter : PublicParameter} {table : Coordinate → Digest} + {state : AdaptiveRevealProbe.State Coordinate} {fuel : Nat} + {masked : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha} + {ordinary : StateT (QueryCache HashSpec) ProbComp alpha} + {cache : SplitHashCache} + (hcoupled : CoupledAt parameter table state fuel masked ordinary cache) + (hinvariants : ∀ finalState value finalCache, + .done false finalState (value, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel (masked.run cache)) → + AdaptiveRevealProbe.tableHits finalState table = false ∧ + RevealedSynced parameter table finalState finalCache) : + RelTriple + (AdaptiveRevealProbe.runDetailed table state fuel (masked.run cache)) + (ordinary.run (mergedCache parameter table cache)) + (CleanResultRel parameter table) := by + let left := AdaptiveRevealProbe.runDetailed table state fuel (masked.run cache) + let right := ordinary.run (mergedCache parameter table cache) + have hproject : RelTriple left right fun maskedResult ordinaryResult => + projectDetailedCache parameter table maskedResult = some ordinaryResult := + relTriple_of_coupledAt hcoupled + have hsupported : ∀ result ∈ support left, + ∀ finalState value finalCache, + result = .done false finalState (value, finalCache) → + AdaptiveRevealProbe.tableHits finalState table = false ∧ + RevealedSynced parameter table finalState finalCache := by + intro result hresult finalState value finalCache hresultEq + subst result + exact hinvariants finalState value finalCache hresult + apply relTriple_post_mono + (relTriple_and_left_support hproject + (fun result => ∀ finalState value finalCache, + result = .done false finalState (value, finalCache) → + AdaptiveRevealProbe.tableHits finalState table = false ∧ + RevealedSynced parameter table finalState finalCache) + hsupported) + intro maskedResult ordinaryResult hresult + cases maskedResult with + | stopped hit => simp [projectDetailedCache] at hresult + | done hit finalState valueCache => + rcases valueCache with ⟨value, finalCache⟩ + cases hit with + | false => + have heq : ordinaryResult = + (value, mergedCache parameter table finalCache) := by + simpa [projectDetailedCache] using hresult.1.symm + exact ⟨rfl, heq, hresult.2 finalState value finalCache rfl⟩ + | true => simp [projectDetailedCache] at hresult + +theorem relTriple_of_coupledAt_clean [Inhabited alpha] + {parameter : PublicParameter} {table : Coordinate → Digest} + {state : AdaptiveRevealProbe.State Coordinate} {fuel : Nat} + {masked : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha} + {ordinary : StateT (QueryCache HashSpec) ProbComp alpha} + {cache : SplitHashCache} + (hcoupled : CoupledAt parameter table state fuel masked ordinary cache) + (hinvariants : ∀ finalState value finalCache, + .done false finalState (value, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel (masked.run cache)) → + AdaptiveRevealProbe.tableHits finalState table = false ∧ + RevealedSynced parameter table finalState finalCache) : + RelTriple + (AdaptiveRevealProbe.runDetailed table state fuel (masked.run cache)) + (ordinary.run (mergedCache parameter table cache)) + (CleanStepRel parameter table) := by + apply relTriple_post_mono + (relTriple_of_coupledAt_cleanOnly hcoupled hinvariants) + intro maskedResult ordinaryResult hresult + exact Or.inr hresult + +theorem relTriple_of_coupledAt_stateFree [Inhabited alpha] + {parameter : PublicParameter} {table : Coordinate → Digest} + {state : AdaptiveRevealProbe.State Coordinate} {fuel : Nat} + {masked : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha} + {ordinary : StateT (QueryCache HashSpec) ProbComp alpha} + {cache : SplitHashCache} + (hcoupled : CoupledAt parameter table state fuel masked ordinary cache) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state cache) + (hstateFree : StateFree masked) (hcache : CachePreserving masked) : + RelTriple + (AdaptiveRevealProbe.runDetailed table state fuel (masked.run cache)) + (ordinary.run (mergedCache parameter table cache)) + (CleanResultRel parameter table) := by + apply relTriple_of_coupledAt_cleanOnly hcoupled + intro finalState value finalCache hresult + obtain ⟨resultValue, heq⟩ := AdaptiveRevealProbe.runDetailed_stateFree_support table state + fuel (masked.run cache) (hstateFree cache) hclean + (.done false finalState (value, finalCache)) hresult + have hstate : finalState = state := + (AdaptiveRevealProbe.DetailedResult.done.inj heq).2.1 + exact ⟨hstate ▸ hclean, + revealedSynced_of_mem_runDetailed_stateFree parameter table state finalState fuel cache + finalCache value masked hclean hsynced hstateFree hcache hresult⟩ + +theorem relTriple_runDetailed_of_tableHits_eq_true + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (left : OracleComp (AdaptiveRevealProbe.World Coordinate) + (alpha × SplitHashCache)) + (right : ProbComp (alpha × QueryCache HashSpec)) + (hhit : AdaptiveRevealProbe.tableHits state table = true) : + RelTriple (AdaptiveRevealProbe.runDetailed table state fuel left) right + (CleanStepRel parameter table) := by + apply relTriple_post_mono + (relTriple_and_left_support + (relTriple_true (AdaptiveRevealProbe.runDetailed table state fuel left) right) + (fun result => result.hit = true) + (runDetailed_hit_eq_true_of_tableHits_eq_true table state fuel left hhit)) + intro leftResult rightResult hresult + exact Or.inl hresult.2 + +theorem relTriple_runDetailed_bind_cleanOnly + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (left : OracleComp (AdaptiveRevealProbe.World Coordinate) + (alpha × SplitHashCache)) + (next : (alpha × SplitHashCache) → + OracleComp (AdaptiveRevealProbe.World Coordinate) (beta × SplitHashCache)) + (ordinaryLeft : ProbComp (alpha × QueryCache HashSpec)) + (ordinaryNext : (alpha × QueryCache HashSpec) → + ProbComp (beta × QueryCache HashSpec)) + (hprobeFree : left.IsQueryBoundP AdaptiveRevealProbe.IsProbe 0) + (hleft : RelTriple + (AdaptiveRevealProbe.runDetailed table state fuel left) ordinaryLeft + (CleanResultRel parameter table)) + (hnext : ∀ finalState value finalCache, + AdaptiveRevealProbe.tableHits finalState table = false → + RevealedSynced parameter table finalState finalCache → + (value, mergedCache parameter table finalCache) ∈ support ordinaryLeft → + RelTriple + (AdaptiveRevealProbe.runDetailed table finalState fuel + (next (value, finalCache))) + (ordinaryNext (value, mergedCache parameter table finalCache)) + (CleanStepRel parameter table)) : + RelTriple + (AdaptiveRevealProbe.runDetailed table state fuel (left >>= next)) + (ordinaryLeft >>= ordinaryNext) + (CleanStepRel parameter table) := by + rw [AdaptiveRevealProbe.runDetailed_bind_probeFree table state fuel left next hprobeFree] + apply relTriple_bind (relTriple_and_right_support hleft) + intro leftResult rightResult hresult + obtain ⟨hresult, hright⟩ := hresult + cases leftResult with + | stopped hit => simp [CleanResultRel] at hresult + | done hit finalState valueCache => + rcases valueCache with ⟨value, finalCache⟩ + simp only [CleanResultRel] at hresult + obtain ⟨rfl, rfl, hclean, hsynced⟩ := hresult + exact hnext finalState value finalCache hclean hsynced hright + +theorem simulateQ_expanded_liftOracleWorldLeft + (secretKey : SecretKey) (computation : OracleComp OracleWorld alpha) : + simulateQ (expandedAdversaryImpl secretKey) + (liftOracleWorldLeft computation) = computation := by + have hhandler : expandedAdversaryImpl secretKey = + QueryImpl.id' OracleWorld + + (fun request => scheme.sign secretKey request) := by + funext input + cases input <;> rfl + rw [hhandler, simulateQ_liftOracleWorldLeft, simulateQ_id'] + +theorem simulateQ_expanded_tracedGameRestComputation + (adversary : Adversary) (secretKey : SecretKey) : + simulateQ (expandedAdversaryImpl secretKey) + (tracedGameRestComputation adversary + ⟨secretKey.root, secretKey.parameter⟩) = + gameRest scheme adversary ⟨secretKey.root, secretKey.parameter⟩ secretKey := by + unfold tracedGameRestComputation gameRest + rw [simulateQ_bind, + ← simulateQ_withTraceAppend_run_eq_signingTraceComputation, + ← forwardOracles_add_signingOracle_eq_withTraceAppend] + apply bind_congr + intro result + rcases result with ⟨forgery, log⟩ + rw [simulateQ_bind, + simulateQ_expanded_liftOracleWorldLeft] + simp [simulateQ_pure] + +set_option maxRecDepth 10000 in +theorem relTriple_maskedExpandedAdversaryImpl_step + (secretKey : SecretKey) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (remaining : Nat) + (cache : SplitHashCache) (input : (OracleWorld + SigningSpec).Domain) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced secretKey.parameter table state cache) : + RelTriple + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((maskedExpandedAdversaryImpl secretKey.parameter secretKey input).run cache)) + ((unloggedMappedAdversaryImpl + (secretKeyWithFtsTable secretKey table) input).run + (mergedCache secretKey.parameter table cache)) + (CleanStepRel secretKey.parameter table) := by + cases input with + | inl worldInput => + cases worldInput with + | inl n => + change RelTriple + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((splitUniformImpl n).run cache)) + ((unifFwdImpl HashSpec n).run + (mergedCache secretKey.parameter table cache)) _ + apply relTriple_of_coupledAt_clean + ((coupled_splitUniformImpl secretKey.parameter table state + (remaining + 1) n hclean).coupledAt cache) + intro finalState output finalCache hresult + exact ⟨tableHits_false_of_mem_runDetailed_probeFree table state finalState + (remaining + 1) ((splitUniformImpl n).run cache) + (splitUniformImpl_probeFree n cache) hclean (output, finalCache) hresult, + revealedSynced_of_mem_runDetailed_stateFree secretKey.parameter table state + finalState (remaining + 1) cache finalCache output (splitUniformImpl n) + hclean hsynced (splitUniformImpl_stateFree n) + (splitUniformImpl_cachePreserving n) hresult⟩ + | inr hashInput => + change RelTriple + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((probingHashQuery secretKey.parameter hashInput).run cache)) + ((randomOracle hashInput).run + (mergedCache secretKey.parameter table cache)) _ + cases hdecode : decodeProbe? secretKey.parameter hashInput with + | none => + apply relTriple_of_coupledAt_clean + (runDetailed_probingHashQuery_decode_none secretKey.parameter table state + (remaining + 1) cache hashInput hdecode hclean) + intro finalState output finalCache hresult + exact ⟨probingHashQuery_done_false_clean secretKey.parameter table state + finalState (remaining + 1) cache finalCache hashInput output hclean hresult, + probingHashQuery_done_false_revealedSynced secretKey.parameter table state + finalState (remaining + 1) cache finalCache hashInput output hclean hsynced + hresult⟩ + | some probe => + cases hrevealed : state.revealed + (probe.index, probe.tree, probe.leafIdx) with + | none => + by_cases hhit : table (probe.index, probe.tree, probe.leafIdx) = + probe.candidate + · have hleft : ∀ result ∈ support + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((probingHashQuery secretKey.parameter hashInput).run cache)), + result.hit = true := by + intro result hresult + exact runDetailed_probingHashQuery_hidden_hit secretKey.parameter table + state remaining cache hashInput probe hdecode hrevealed hhit result hresult + apply relTriple_post_mono + (relTriple_and_left_support + (relTriple_true + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((probingHashQuery secretKey.parameter hashInput).run cache)) + ((randomOracle hashInput).run + (mergedCache secretKey.parameter table cache))) + (fun result => result.hit = true) hleft) + intro maskedResult ordinaryResult hresult + cases maskedResult with + | stopped hit => + left + simpa [AdaptiveRevealProbe.DetailedResult.hit] using hresult.2 + | done hit finalState valueCache => + left + simpa [AdaptiveRevealProbe.DetailedResult.hit] using hresult.2 + · apply relTriple_of_coupledAt_clean + (runDetailed_probingHashQuery_hidden_miss secretKey.parameter table state + remaining cache hashInput probe hdecode hrevealed hclean hhit) + intro finalState output finalCache hresult + exact ⟨probingHashQuery_done_false_clean secretKey.parameter table state + finalState (remaining + 1) cache finalCache hashInput output hclean hresult, + probingHashQuery_done_false_revealedSynced secretKey.parameter table state + finalState (remaining + 1) cache finalCache hashInput output hclean hsynced + hresult⟩ + | some revealedValue => + by_cases hhit : table (probe.index, probe.tree, probe.leafIdx) = + probe.candidate + · apply relTriple_of_coupledAt_clean + (runDetailed_probingHashQuery_revealed_hit secretKey.parameter table state + remaining cache hashInput probe hdecode revealedValue hrevealed hclean + hhit hsynced) + intro finalState output finalCache hresult + exact ⟨probingHashQuery_done_false_clean secretKey.parameter table state + finalState (remaining + 1) cache finalCache hashInput output hclean hresult, + probingHashQuery_done_false_revealedSynced secretKey.parameter table state + finalState (remaining + 1) cache finalCache hashInput output hclean hsynced + hresult⟩ + · apply relTriple_of_coupledAt_clean + (runDetailed_probingHashQuery_revealed_miss secretKey.parameter table state + remaining cache hashInput probe hdecode revealedValue hrevealed hclean + hhit) + intro finalState output finalCache hresult + exact ⟨probingHashQuery_done_false_clean secretKey.parameter table state + finalState (remaining + 1) cache finalCache hashInput output hclean hresult, + probingHashQuery_done_false_revealedSynced secretKey.parameter table state + finalState (remaining + 1) cache finalCache hashInput output hclean hsynced + hresult⟩ + | inr message => + change RelTriple + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((maskedSigningImpl secretKey message).run cache)) + ((simulateQ romImpl + (scheme.sign (secretKeyWithFtsTable secretKey table) message)).run + (mergedCache secretKey.parameter table cache)) _ + apply relTriple_of_coupledAt_clean + (coupledAt_maskedSigningImpl secretKey table state (remaining + 1) cache message + hclean hsynced) + intro finalState output finalCache hresult + exact ⟨tableHits_false_of_mem_runDetailed_probeFree table state finalState + (remaining + 1) ((maskedSigningImpl secretKey message).run cache) + (by + have hprobeFree : ProbeFree (maskedSigningImpl secretKey message) := by + unfold maskedSigningImpl + exact (maskedSignWithView_probeFree secretKey message).map Prod.fst + exact hprobeFree cache) + hclean (output, finalCache) hresult, + revealedSynced_of_mem_runDetailed_maskedSigningImpl secretKey table state finalState + (remaining + 1) cache finalCache message hclean hsynced output hresult⟩ + +set_option maxRecDepth 30000 in +theorem relTriple_simulateQ_maskedExpandedAdversaryImpl + (secretKey : SecretKey) (table : Coordinate → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) + (hbound : (simulateQ + (expandedAdversaryImpl (secretKeyWithFtsTable secretKey table)) + computation).IsQueryBoundP (· matches Sum.inr _) fuel) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced secretKey.parameter table state cache) : + RelTriple + (AdaptiveRevealProbe.runDetailed table state fuel + ((simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + computation).run cache)) + ((simulateQ + (unloggedMappedAdversaryImpl (secretKeyWithFtsTable secretKey table)) + computation).run (mergedCache secretKey.parameter table cache)) + (CleanStepRel secretKey.parameter table) := by + induction computation using OracleComp.inductionOn generalizing state fuel cache with + | pure result => + simp [simulateQ_pure, AdaptiveRevealProbe.runDetailed, hclean, + CleanStepRel, CleanResultRel, hsynced] + | query_bind input next ih => + cases input with + | inl worldInput => + cases worldInput with + | inl n => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [simulateQ_query_bind, simulateQ_query_bind, + StateT.run_bind, StateT.run_bind] + change RelTriple + (AdaptiveRevealProbe.runDetailed table state fuel + ((splitUniformImpl n).run cache >>= fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (next result.1)).run result.2)) + ((unifFwdImpl HashSpec n).run + (mergedCache secretKey.parameter table cache) >>= fun result => + (simulateQ + (unloggedMappedAdversaryImpl + (secretKeyWithFtsTable secretKey table)) + (next result.1)).run result.2) _ + apply relTriple_runDetailed_bind_cleanOnly secretKey.parameter table state fuel + ((splitUniformImpl n).run cache) + (fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (next result.1)).run result.2) + ((unifFwdImpl HashSpec n).run + (mergedCache secretKey.parameter table cache)) + (fun result => + (simulateQ + (unloggedMappedAdversaryImpl + (secretKeyWithFtsTable secretKey table)) + (next result.1)).run result.2) + (splitUniformImpl_probeFree n cache) + · exact relTriple_of_coupledAt_stateFree + ((coupled_splitUniformImpl secretKey.parameter table state fuel n hclean).coupledAt + cache) hclean hsynced (splitUniformImpl_stateFree n) + (splitUniformImpl_cachePreserving n) + · intro finalState output finalCache hfinalClean hfinalSynced _hright + exact ih output finalState fuel finalCache + (hbound.2 output) + hfinalClean hfinalSynced + | inr hashInput => + change HashOutput → OracleComp (OracleWorld + SigningSpec) alpha at next + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + have hpositive : 0 < fuel := by + simpa using hbound.1 + cases fuel with + | zero => omega + | succ remaining => + rw [simulateQ_query_bind, simulateQ_query_bind, + StateT.run_bind, StateT.run_bind] + change RelTriple + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((probingHashQuery secretKey.parameter hashInput).run cache >>= fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (next result.1)).run result.2)) + ((randomOracle hashInput).run + (mergedCache secretKey.parameter table cache) >>= fun result => + (simulateQ + (unloggedMappedAdversaryImpl + (secretKeyWithFtsTable secretKey table)) + (next result.1)).run result.2) _ + cases hdecode : decodeProbe? secretKey.parameter hashInput with + | none => + have hstateFree : StateFree + (probingHashQuery secretKey.parameter hashInput) := by + intro workingCache + rw [probingHashQuery_run_eq, hdecode] + exact splitHashQuery_stateFree (.ordinary hashInput) workingCache + have hprobeFree : ProbeFree + (probingHashQuery secretKey.parameter hashInput) := by + intro workingCache + rw [probingHashQuery_run_eq, hdecode] + exact splitHashQuery_probeFree (.ordinary hashInput) workingCache + apply relTriple_runDetailed_bind_cleanOnly secretKey.parameter table state + (remaining + 1) + ((probingHashQuery secretKey.parameter hashInput).run cache) + (fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (next result.1)).run result.2) + ((randomOracle hashInput).run + (mergedCache secretKey.parameter table cache)) + (fun result => + (simulateQ + (unloggedMappedAdversaryImpl + (secretKeyWithFtsTable secretKey table)) + (next result.1)).run result.2) + (hprobeFree cache) + · exact relTriple_of_coupledAt_stateFree + (runDetailed_probingHashQuery_decode_none secretKey.parameter table state + (remaining + 1) cache hashInput hdecode hclean) + hclean hsynced hstateFree + (probingHashQuery_cachePreserving secretKey.parameter hashInput) + · intro finalState output finalCache hfinalClean hfinalSynced _hright + have htail : (simulateQ + (expandedAdversaryImpl + (secretKeyWithFtsTable secretKey table)) + (next output)).IsQueryBoundP + (fun input => input matches Sum.inr _) remaining := + hbound.2 output + exact ih output finalState (remaining + 1) finalCache + (htail.mono (Nat.le_succ remaining)) hfinalClean hfinalSynced + | some probe => + rw [probingHashQuery_run_eq, hdecode] + change RelTriple + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((AdaptiveRevealProbe.probeQuery + (probe.index, probe.tree, probe.leafIdx) probe.candidate >>= fun _ => + (splitHashQuery (.ordinary hashInput)).run cache >>= fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (next result.1)).run result.2))) _ _ + rw [AdaptiveRevealProbe.probeQuery, + AdaptiveRevealProbe.runDetailed_probe_query_bind] + cases hrevealed : state.revealed + (probe.index, probe.tree, probe.leafIdx) with + | none => + by_cases hhit : table (probe.index, probe.tree, probe.leafIdx) = + probe.candidate + · apply relTriple_runDetailed_of_tableHits_eq_true + secretKey.parameter table + (state.addPending + (probe.index, probe.tree, probe.leafIdx) probe.candidate) + remaining + exact AdaptiveRevealProbe.tableHits_addPending_eq_true state table + (probe.index, probe.tree, probe.leafIdx) probe.candidate hhit + · have hnextClean := AdaptiveRevealProbe.tableHits_addPending_eq_false + state table (probe.index, probe.tree, probe.leafIdx) + probe.candidate hclean hhit + have hordinary : IsOrdinaryInput secretKey.parameter table hashInput := + isOrdinaryInput_of_decode_miss secretKey.parameter table hashInput + probe hdecode (fun heq => hhit heq.symm) + apply relTriple_runDetailed_bind_cleanOnly secretKey.parameter table + (state.addPending + (probe.index, probe.tree, probe.leafIdx) probe.candidate) + remaining ((splitHashQuery (.ordinary hashInput)).run cache) + (fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (next result.1)).run result.2) + ((randomOracle hashInput).run + (mergedCache secretKey.parameter table cache)) + (fun result => + (simulateQ + (unloggedMappedAdversaryImpl + (secretKeyWithFtsTable secretKey table)) + (next result.1)).run result.2) + (splitHashQuery_probeFree (.ordinary hashInput) cache) + · exact relTriple_of_coupledAt_stateFree + (runDetailed_splitHashQuery_ordinary secretKey.parameter table + (state.addPending + (probe.index, probe.tree, probe.leafIdx) probe.candidate) + remaining cache hashInput hnextClean hordinary) + hnextClean + (by + intro coordinate value hvalue + exact hsynced coordinate value (by + simpa [AdaptiveRevealProbe.State.addPending] using hvalue)) + (splitHashQuery_stateFree (.ordinary hashInput)) + (splitHashQuery_cachePreserving (.ordinary hashInput)) + · intro finalState output finalCache hfinalClean hfinalSynced _hright + exact ih output finalState remaining finalCache + (hbound.2 output) + hfinalClean hfinalSynced + | some revealedValue => + have htailBound : ∀ output, + (simulateQ + (expandedAdversaryImpl + (secretKeyWithFtsTable secretKey table)) + (next output)).IsQueryBoundP + (· matches Sum.inr _) remaining := by + intro output + exact hbound.2 output + by_cases hhit : table (probe.index, probe.tree, probe.leafIdx) = + probe.candidate + · have hcoupled := runDetailed_probingHashQuery_revealed_hit + secretKey.parameter table state remaining cache hashInput probe + hdecode revealedValue hrevealed hclean hhit hsynced + rw [probingHashQuery_run_eq, hdecode] at hcoupled + change projectDetailedCache secretKey.parameter table <$> + AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((AdaptiveRevealProbe.probeQuery + (probe.index, probe.tree, probe.leafIdx) probe.candidate >>= fun _ => + (splitHashQuery (.ordinary hashInput)).run cache)) = _ at hcoupled + rw [AdaptiveRevealProbe.probeQuery, + AdaptiveRevealProbe.runDetailed_probe_query_bind, hrevealed] + at hcoupled + apply relTriple_runDetailed_bind_cleanOnly secretKey.parameter table + state remaining ((splitHashQuery (.ordinary hashInput)).run cache) + (fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (next result.1)).run result.2) + ((randomOracle hashInput).run + (mergedCache secretKey.parameter table cache)) + (fun result => + (simulateQ + (unloggedMappedAdversaryImpl + (secretKeyWithFtsTable secretKey table)) + (next result.1)).run result.2) + (splitHashQuery_probeFree (.ordinary hashInput) cache) + · exact relTriple_of_coupledAt_cleanOnly hcoupled fun + finalState output finalCache hresult => + ⟨tableHits_false_of_mem_runDetailed_probeFree table state + finalState remaining + ((splitHashQuery (.ordinary hashInput)).run cache) + (splitHashQuery_probeFree (.ordinary hashInput) cache) + hclean (output, finalCache) hresult, + probingHashQuery_done_false_revealedSynced + secretKey.parameter table state finalState (remaining + 1) + cache finalCache hashInput output hclean hsynced (by + rw [probingHashQuery_run_eq, hdecode] + change .done false finalState (output, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state + (remaining + 1) + (AdaptiveRevealProbe.probeQuery + (probe.index, probe.tree, probe.leafIdx) + probe.candidate >>= fun _ => + (splitHashQuery (.ordinary hashInput)).run cache)) + rw [AdaptiveRevealProbe.probeQuery, + AdaptiveRevealProbe.runDetailed_probe_query_bind, + hrevealed] + exact hresult)⟩ + · intro finalState output finalCache hfinalClean hfinalSynced _hright + exact ih output finalState remaining finalCache + (htailBound output) hfinalClean hfinalSynced + · have hordinary : IsOrdinaryInput secretKey.parameter table hashInput := + isOrdinaryInput_of_decode_miss secretKey.parameter table hashInput + probe hdecode (fun heq => hhit heq.symm) + apply relTriple_runDetailed_bind_cleanOnly secretKey.parameter table + state remaining ((splitHashQuery (.ordinary hashInput)).run cache) + (fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (next result.1)).run result.2) + ((randomOracle hashInput).run + (mergedCache secretKey.parameter table cache)) + (fun result => + (simulateQ + (unloggedMappedAdversaryImpl + (secretKeyWithFtsTable secretKey table)) + (next result.1)).run result.2) + (splitHashQuery_probeFree (.ordinary hashInput) cache) + · exact relTriple_of_coupledAt_stateFree + (runDetailed_splitHashQuery_ordinary secretKey.parameter table state + remaining cache hashInput hclean hordinary) + hclean hsynced (splitHashQuery_stateFree (.ordinary hashInput)) + (splitHashQuery_cachePreserving (.ordinary hashInput)) + · intro finalState output finalCache hfinalClean hfinalSynced _hright + exact ih output finalState remaining finalCache + (htailBound output) hfinalClean hfinalSynced + | inr message => + rw [simulateQ_expandedAdversaryImpl_query_bind_inr] at hbound + rw [simulateQ_query_bind, simulateQ_query_bind, + StateT.run_bind, StateT.run_bind] + change RelTriple + (AdaptiveRevealProbe.runDetailed table state fuel + ((maskedSigningImpl secretKey message).run cache >>= fun result => + (simulateQ + (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (next result.1)).run result.2)) + ((simulateQ romImpl + (scheme.sign (secretKeyWithFtsTable secretKey table) message)).run + (mergedCache secretKey.parameter table cache) >>= fun result => + (simulateQ + (unloggedMappedAdversaryImpl (secretKeyWithFtsTable secretKey table)) + (next result.1)).run result.2) _ + have hprobeFree : ProbeFree (maskedSigningImpl secretKey message) := by + unfold maskedSigningImpl + exact (maskedSignWithView_probeFree secretKey message).map Prod.fst + apply relTriple_runDetailed_bind_cleanOnly secretKey.parameter table state fuel + ((maskedSigningImpl secretKey message).run cache) + (fun result => + (simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (next result.1)).run result.2) + ((simulateQ romImpl + (scheme.sign (secretKeyWithFtsTable secretKey table) message)).run + (mergedCache secretKey.parameter table cache)) + (fun result => + (simulateQ + (unloggedMappedAdversaryImpl (secretKeyWithFtsTable secretKey table)) + (next result.1)).run result.2) + (hprobeFree cache) + · exact relTriple_of_coupledAt_cleanOnly + (coupledAt_maskedSigningImpl secretKey table state fuel cache message hclean hsynced) + fun finalState output finalCache hresult => + ⟨tableHits_false_of_mem_runDetailed_probeFree table state finalState fuel + ((maskedSigningImpl secretKey message).run cache) (hprobeFree cache) + hclean (output, finalCache) hresult, + revealedSynced_of_mem_runDetailed_maskedSigningImpl secretKey table state + finalState fuel cache finalCache message hclean hsynced output hresult⟩ + · intro finalState output finalCache hfinalClean hfinalSynced hright + have houtput := unloggedMappedAdversaryImpl_output_mem_support_expanded + (secretKeyWithFtsTable secretKey table) (.inr message) + (mergedCache secretKey.parameter table cache) + (mergedCache secretKey.parameter table finalCache) output hright + exact ih output finalState fuel finalCache + (isQueryBoundP_of_bind hbound output houtput) hfinalClean hfinalSynced + +set_option maxRecDepth 30000 in +theorem relTriple_maskedGameAfterSecrets + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (table : Coordinate → Digest) (q : Nat) + (hbound : (gameAfterSecrets adversary parameter otsSecret + (fun index tree leafIdx => table (index, tree, leafIdx))).IsQueryBoundP + (· matches Sum.inr _) q) : + RelTriple + (AdaptiveRevealProbe.runDetailed table AdaptiveRevealProbe.State.empty q + ((maskedGameAfterSecrets adversary parameter otsSecret).run + emptySplitHashCache)) + ((simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret + (fun index tree leafIdx => table (index, tree, leafIdx)))).run ∅) + (CleanStepRel parameter table) := by + let rootComputation : OracleComp HashSpec Digest := + treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) + have hinitialClean : AdaptiveRevealProbe.tableHits + (AdaptiveRevealProbe.State.empty : AdaptiveRevealProbe.State Coordinate) table = false := by + simp [AdaptiveRevealProbe.tableHits, AdaptiveRevealProbe.State.empty] + rw [maskedGameAfterSecrets_eq_tracedGameRestComputation, + simulateQ_romImpl_gameAfterSecrets_eq_tracedGameRestComputation, + StateT.run_bind, StateT.run_bind] + apply relTriple_runDetailed_bind_cleanOnly parameter table + AdaptiveRevealProbe.State.empty q + ((simulateQ ordinaryHashImpl rootComputation).run emptySplitHashCache) + (fun result => + let secretKey : SecretKey := + ⟨parameter, result.1, otsSecret, fun _index _tree _leafIdx => 0⟩ + (simulateQ (maskedExpandedAdversaryImpl parameter secretKey) + (tracedGameRestComputation adversary ⟨result.1, parameter⟩)).run result.2) + ((simulateQ (randomOracle : QueryImpl HashSpec _) rootComputation).run ∅) + (fun result => + let secretKey : SecretKey := + ⟨parameter, result.1, otsSecret, + fun index tree leafIdx => table (index, tree, leafIdx)⟩ + (simulateQ (unloggedMappedAdversaryImpl secretKey) + (tracedGameRestComputation adversary ⟨result.1, parameter⟩)).run result.2) + (simulateQ_ordinaryHashImpl_probeFree rootComputation emptySplitHashCache) + · simpa using (relTriple_of_coupledAt_stateFree + ((coupled_simulateQ_ordinaryHashImpl parameter table + AdaptiveRevealProbe.State.empty q rootComputation hinitialClean + (ordinaryOnly_treeRoot parameter table topLayer rootTree + (otsSecret topLayer rootTree))).coupledAt emptySplitHashCache) + hinitialClean (revealedSynced_empty parameter table) + (simulateQ_ordinaryHashImpl_stateFree rootComputation) + (simulateQ_ordinaryHashImpl_cachePreserving rootComputation)) + · intro finalState root finalCache hfinalClean hfinalSynced hright + let maskedSecretKey : SecretKey := + ⟨parameter, root, otsSecret, fun _index _tree _leafIdx => 0⟩ + let actualSecretKey : SecretKey := secretKeyWithFtsTable maskedSecretKey table + have hrootRun : root ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) rootComputation).run' ∅) := by + rw [StateT.run'_eq, support_map] + exact ⟨(root, mergedCache parameter table finalCache), hright, rfl⟩ + have hroot : root ∈ support rootComputation := + OracleComp.support_simulateQ_run'_subset + (randomOracle : QueryImpl HashSpec _) rootComputation ∅ hrootRun + have hrootLift : root ∈ support + (liftM rootComputation : OracleComp OracleWorld Digest) := + by + rw [← OracleComp.liftComp_eq_liftM, + OracleComp.mem_support_liftComp_iff] + exact hroot + have hrest : (gameRest scheme adversary ⟨root, parameter⟩ actualSecretKey).IsQueryBoundP + (· matches Sum.inr _) q := by + apply isQueryBoundP_of_bind hbound root + exact hrootLift + apply relTriple_simulateQ_maskedExpandedAdversaryImpl maskedSecretKey table + (tracedGameRestComputation adversary ⟨root, parameter⟩) + finalState q finalCache + · change (simulateQ (expandedAdversaryImpl actualSecretKey) + (tracedGameRestComputation adversary + ⟨actualSecretKey.root, actualSecretKey.parameter⟩)).IsQueryBoundP + (· matches Sum.inr _) q + rwa [simulateQ_expanded_tracedGameRestComputation adversary actualSecretKey] + · exact hfinalClean + · exact hfinalSynced + +theorem probEvent_right_le_projected_or_missing + (project : alpha → Option beta) (left : ProbComp alpha) (right : ProbComp beta) + (hrel : RelTriple left right fun leftResult rightResult => + project leftResult = none ∨ project leftResult = some rightResult) + (event : beta → Prop) : + Pr[event | right] ≤ + Pr[fun result => project result = none ∨ + ∃ value, project result = some value ∧ event value | left] := by + apply probEvent_le_of_relTriple (relTriple_symm hrel) + intro rightResult leftResult hrelation hevent + rcases hrelation with hmissing | hpresent + · exact Or.inl hmissing + · exact Or.inr ⟨rightResult, hpresent, hevent⟩ + +theorem probEvent_right_le_missing_add_projected + (project : alpha → Option beta) (left : ProbComp alpha) (right : ProbComp beta) + (hrel : RelTriple left right fun leftResult rightResult => + project leftResult = none ∨ project leftResult = some rightResult) + (event : beta → Prop) : + Pr[event | right] ≤ Pr[fun result => project result = none | left] + + Pr[fun result => ∃ value, project result = some value ∧ event value | left] := by + exact (probEvent_right_le_projected_or_missing project left right hrel event).trans + (probEvent_or_le _ _ _) + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeQueryBudget126.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeQueryBudget126.lean new file mode 100644 index 00000000..e0c18d36 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeQueryBudget126.lean @@ -0,0 +1,37 @@ +import SphincsSecurity.Proof.FtsProbeCostBound + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +theorem sampledMaskedFtsProbeCharge_le_four_thirds_queryCharge + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + sampledMaskedFtsProbeCharge adversary q ≤ + (4 / 3 : ℝ≥0∞) * sampledQueryCharge (fun secretKey => ftsHashQueryCharge secretKey.parameter) adversary := by + rw [sampledMaskedFtsProbeCharge, sampledQueryCharge, sampleSecrets, tsum_probOutput_bind_mul] + simp only [tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + rw [← ENNReal.tsum_mul_left] + apply ENNReal.tsum_le_tsum + intro parameter + rw [mul_left_comm (4 / 3)] + by_cases hparameter : parameter ∈ support sampleParameter + · apply mul_le_mul' le_rfl + rw [← ENNReal.tsum_mul_left] + apply ENNReal.tsum_le_tsum + intro otsSecret + rw [mul_left_comm (4 / 3)] + by_cases hots : otsSecret ∈ support sampleOtsSecrets + · exact mul_le_mul' le_rfl + (maskedFtsProbeCharge_le_four_thirds_queryCharge adversary parameter hparameter otsSecret hots q hq hqMax) + · rw [probOutput_eq_zero_of_not_mem_support hots, zero_mul, zero_mul] + · rw [probOutput_eq_zero_of_not_mem_support hparameter, zero_mul, zero_mul] + +theorem probEvent_sampledViewedGame_cleanUncovered_le_queryCharge126 + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary] ≤ + (4 / 3 : ℝ≥0∞) * sampledQueryCharge (fun secretKey => ftsHashQueryCharge secretKey.parameter) adversary * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := + (probEvent_sampledViewedGame_cleanUncovered_le_probeCharge adversary q hq).trans + (mul_le_mul' (sampledMaskedFtsProbeCharge_le_four_thirds_queryCharge adversary q hq hqMax) le_rfl) + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeQueryCharge.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeQueryCharge.lean new file mode 100644 index 00000000..4781873f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeQueryCharge.lean @@ -0,0 +1,142 @@ +import SphincsSecurity.Proof.FtsProbeSampling +import SphincsSecurity.Proof.AdaptiveRevealProbeCharge + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +noncomputable def maskedFtsProbeCharge (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (q : Nat) : ℝ≥0∞ := + AdaptiveRevealProbe.expectedProbeCharge + ((maskedRetainedGameAfterSecrets adversary parameter otsSecret).run emptySplitHashCache) + AdaptiveRevealProbe.State.empty q + +theorem maskedFtsProbeCharge_le_q (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (q : Nat) : + maskedFtsProbeCharge adversary parameter otsSecret q ≤ q := + AdaptiveRevealProbe.expectedProbeCharge_le_fuel _ _ _ + +set_option maxRecDepth 30000 in +set_option linter.constructorNameAsVariable false in +theorem probEvent_sampledActualRetainedFts_uncovered_le_probeCharge + (adversary : Adversary) (parameter : PublicParameter) + (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) : + Pr[SampledRetainedUncoveredFtsSecretWitness parameter otsSecret | + sampledActualRetainedFts adversary parameter otsSecret] ≤ + maskedFtsProbeCharge adversary parameter otsSecret q * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + let maskedRun := + (maskedRetainedGameAfterSecrets adversary parameter otsSecret).run emptySplitHashCache + calc + Pr[SampledRetainedUncoveredFtsSecretWitness parameter otsSecret | + sampledActualRetainedFts adversary parameter otsSecret] ≤ + Pr[fun result : (Coordinate → Digest) × + AdaptiveRevealProbe.DetailedResult Coordinate + (RetainedGameResult × SplitHashCache) => result.2.hit = true | + AdaptiveRevealProbe.detailedExperiment AdaptiveRevealProbe.State.empty q + maskedRun] := by + unfold sampledActualRetainedFts AdaptiveRevealProbe.detailedExperiment + apply probEvent_bind_le_bind_of_forall_le + intro table _htable + have hextend : AdaptiveRevealProbe.extendTable + (AdaptiveRevealProbe.State.empty : AdaptiveRevealProbe.State Coordinate) table = + table := by + funext coordinate + simp [AdaptiveRevealProbe.extendTable, AdaptiveRevealProbe.State.empty] + rw [hextend] + have hfts := mem_support_sampleFtsSecrets + (fun index tree leafIdx => table (index, tree, leafIdx)) + have hbound := isQueryBoundP_gameAfterSecrets adversary q hq hparameter hots hfts + simpa [SampledRetainedUncoveredFtsSecretWitness, + AdaptiveRevealProbe.extendTable, AdaptiveRevealProbe.State.empty, + probEvent_map, Function.comp_def, maskedRun] using + (probEvent_actualRetained_uncovered_le_detailed_hit adversary parameter + otsSecret table q hbound) + _ = Pr[fun hit : Bool => hit = true | + AdaptiveRevealProbe.experiment AdaptiveRevealProbe.State.empty q maskedRun] := by + rw [← AdaptiveRevealProbe.detailedExperiment_hit_eq_experiment] + rw [probEvent_map] + rfl + _ ≤ maskedFtsProbeCharge adversary parameter otsSecret q * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + letI : Nonempty Coordinate := + ⟨(⟨0, by norm_num [totalHeight]⟩, + ⟨0, by norm_num [ftsTrees]⟩, + ⟨0, by norm_num [ftsTreeHeight]⟩)⟩ + exact AdaptiveRevealProbe.experiment_empty_probability_le_expectedProbeCharge q maskedRun + + +theorem probEvent_sampledFtsViewedGame_uncovered_le_probeCharge + (adversary : Adversary) (parameter : PublicParameter) + (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) : + Pr[SampledFtsViewedUncoveredWitness parameter otsSecret | + sampledFtsViewedGame adversary parameter otsSecret] ≤ + maskedFtsProbeCharge adversary parameter otsSecret q * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + calc + Pr[SampledFtsViewedUncoveredWitness parameter otsSecret | + sampledFtsViewedGame adversary parameter otsSecret] ≤ + Pr[SampledRetainedUncoveredFtsSecretWitness parameter otsSecret | + sampledConcreteActualRetainedFts adversary parameter otsSecret] := by + unfold sampledFtsViewedGame sampledConcreteActualRetainedFts + apply probEvent_bind_le_bind_of_forall_le + intro ftsSecret _hfts + let table := curryFtsTableEquiv ftsSecret + simpa [SampledFtsViewedUncoveredWitness, + SampledRetainedUncoveredFtsSecretWitness, table, curryFtsTableEquiv, + probEvent_map, Function.comp_def] using + (probEvent_gameAfterSecretsWithViewTrace_uncovered_le_actualRetained + adversary parameter otsSecret table) + _ = Pr[SampledRetainedUncoveredFtsSecretWitness parameter otsSecret | + sampledActualRetainedFts adversary parameter otsSecret] := by + apply _root_.OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + exact evalDist_sampledConcreteActualRetainedFts_eq adversary parameter otsSecret + _ ≤ maskedFtsProbeCharge adversary parameter otsSecret q * (Fintype.card Digest : ℝ≥0∞)⁻¹ := + probEvent_sampledActualRetainedFts_uncovered_le_probeCharge adversary parameter hparameter + otsSecret hots q hq + + +noncomputable def sampledMaskedFtsProbeCharge (adversary : Adversary) (q : Nat) : ℝ≥0∞ := + ∑' parameter : PublicParameter, Pr[= parameter | sampleParameter] * + ∑' otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest, + Pr[= otsSecret | sampleOtsSecrets] * maskedFtsProbeCharge adversary parameter otsSecret q + +set_option maxRecDepth 30000 in +theorem probEvent_sampledViewedGame_cleanUncovered_le_probeCharge + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) : + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary] ≤ + sampledMaskedFtsProbeCharge adversary q * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + rw [sampledViewedGame, sampleSecrets] + simp only [bind_assoc, pure_bind] + rw [probEvent_bind_eq_tsum, sampledMaskedFtsProbeCharge, ← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro parameter + rw [mul_assoc] + by_cases hparameter : parameter ∈ support sampleParameter + · apply mul_le_mul' le_rfl + rw [probEvent_bind_eq_tsum, ← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro otsSecret + rw [mul_assoc] + by_cases hots : otsSecret ∈ support sampleOtsSecrets + · apply mul_le_mul' le_rfl + let pack : ((Index → FtsTree → FtsLeaf → Digest) × + ((Digest × Forgery × Bool) × ViewedFullTraceState)) → SampledViewedResult := + fun result => ⟨⟨parameter, otsSecret, result.1⟩, result.2⟩ + have hrun : (sampleFtsSecrets >>= fun ftsSecret => + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret >>= fun result => + pure (⟨⟨parameter, otsSecret, ftsSecret⟩, result⟩ : SampledViewedResult)) = + pack <$> sampledFtsViewedGame adversary parameter otsSecret := by + simp [sampledFtsViewedGame, pack] + rw [hrun, probEvent_map] + apply le_trans (probEvent_mono fun result _hresult hevent => hevent.2) + exact probEvent_sampledFtsViewedGame_uncovered_le_probeCharge adversary parameter hparameter + otsSecret hots q hq + · rw [probOutput_eq_zero_of_not_mem_support hots, zero_mul, zero_mul] + · rw [probOutput_eq_zero_of_not_mem_support hparameter, zero_mul, zero_mul] + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeSampling.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeSampling.lean new file mode 100644 index 00000000..236ab798 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeSampling.lean @@ -0,0 +1,1015 @@ +import SphincsSecurity.Proof.FtsProbeProbability + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +namespace Concrete.FtsProbeSimulation + +attribute [local semireducible] sampleFtsSecrets + +abbrev RetainedRestResult := (Forgery × QueryLog SigningSpec) × Bool + +abbrev RetainedGameResult := Digest × RetainedRestResult + +noncomputable def retainedGameRestComputation (adversary : Adversary) + (publicKey : PublicKey) : + OracleComp (OracleWorld + SigningSpec) RetainedRestResult := do + let (forgery, log) ← signingTraceComputation (adversary.main publicKey) + let verified ← liftOracleWorldLeft + (scheme.verify publicKey forgery.message forgery.signature) + pure ((forgery, log), verified) + +theorem retainedGameRestComputation_verdict_projection + (adversary : Adversary) (publicKey : PublicKey) : + (fun result : RetainedRestResult => + decide (SigningTranscript.Valid result.1.2 ∧ + ¬SigningTranscript.Contains result.1.2 result.1.1) && result.2) <$> + retainedGameRestComputation adversary publicKey = + tracedGameRestComputation adversary publicKey := by + simp [retainedGameRestComputation, tracedGameRestComputation] + +theorem simulateQ_probingRomImpl_scheme_verify + (parameter : PublicParameter) (publicKey : PublicKey) + (message : Message) (signature : Signature) : + simulateQ (probingRomImpl parameter) + (scheme.verify publicKey message signature) = + simulateQ (probingHashImpl parameter) + (verify (m := OracleComp HashSpec) publicKey message signature) := by + change simulateQ (splitUniformImpl + probingHashImpl parameter) + (liftM (verify (m := OracleComp HashSpec) publicKey message signature)) = _ + exact QueryImpl.simulateQ_add_liftM_right _ _ _ + +theorem simulateQ_maskedExpanded_retainedGameRestComputation + (adversary : Adversary) (secretKey : SecretKey) : + simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (retainedGameRestComputation adversary + ⟨secretKey.root, secretKey.parameter⟩) = (do + let (forgery, log) ← + simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (signingTraceComputation + (adversary.main ⟨secretKey.root, secretKey.parameter⟩)) + let verified ← simulateQ (probingHashImpl secretKey.parameter) + (verify (m := OracleComp HashSpec) + ⟨secretKey.root, secretKey.parameter⟩ forgery.message forgery.signature) + pure ((forgery, log), verified)) := by + unfold retainedGameRestComputation + rw [simulateQ_bind] + apply bind_congr + intro result + rcases result with ⟨forgery, log⟩ + rw [simulateQ_bind] + change (do + let verified ← simulateQ + (probingRomImpl secretKey.parameter + maskedSigningImpl secretKey) + (liftOracleWorldLeft + (scheme.verify ⟨secretKey.root, secretKey.parameter⟩ + forgery.message forgery.signature)) + pure ((forgery, log), verified)) = _ + rw [simulateQ_liftOracleWorldLeft, simulateQ_probingRomImpl_scheme_verify] + +theorem simulateQ_expanded_retainedGameRestComputation_isQueryBoundP + (adversary : Adversary) (secretKey : SecretKey) (q : Nat) + (hbound : (gameRest scheme adversary + ⟨secretKey.root, secretKey.parameter⟩ secretKey).IsQueryBoundP + (· matches Sum.inr _) q) : + (simulateQ (expandedAdversaryImpl secretKey) + (retainedGameRestComputation adversary + ⟨secretKey.root, secretKey.parameter⟩)).IsQueryBoundP + (· matches Sum.inr _) q := by + let verdict := fun result : RetainedRestResult => + decide (SigningTranscript.Valid result.1.2 ∧ + ¬SigningTranscript.Contains result.1.2 result.1.1) && result.2 + have heq : verdict <$> + simulateQ (expandedAdversaryImpl secretKey) + (retainedGameRestComputation adversary + ⟨secretKey.root, secretKey.parameter⟩) = + simulateQ (expandedAdversaryImpl secretKey) + (tracedGameRestComputation adversary + ⟨secretKey.root, secretKey.parameter⟩) := by + rw [← retainedGameRestComputation_verdict_projection] + simp [verdict] + have hmap : (verdict <$> + simulateQ (expandedAdversaryImpl secretKey) + (retainedGameRestComputation adversary + ⟨secretKey.root, secretKey.parameter⟩)).IsQueryBoundP + (· matches Sum.inr _) q := by + rw [heq, simulateQ_expanded_tracedGameRestComputation adversary secretKey] + exact hbound + exact (isQueryBoundP_map_iff _ verdict q).mp hmap + +noncomputable def maskedRetainedGameAfterSecrets (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) : + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) RetainedGameResult := do + let root ← simulateQ ordinaryHashImpl + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree)) + let secretKey : SecretKey := + ⟨parameter, root, otsSecret, fun _index _tree _leafIdx => 0⟩ + let result ← simulateQ (maskedExpandedAdversaryImpl parameter secretKey) + (retainedGameRestComputation adversary ⟨root, parameter⟩) + pure (root, result) + +noncomputable def actualRetainedGameAfterSecrets (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (table : Coordinate → Digest) : + ProbComp (RetainedGameResult × QueryCache HashSpec) := do + let (root, rootCache) ← + (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅ + let secretKey : SecretKey := + ⟨parameter, root, otsSecret, + fun index tree leafIdx => table (index, tree, leafIdx)⟩ + let (result, finalCache) ← + (simulateQ (unloggedMappedAdversaryImpl secretKey) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).run rootCache + pure ((root, result), finalCache) + +theorem simulateQ_unloggedMapped_signingTraceComputation_run + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (initialCache : QueryCache HashSpec) : + (simulateQ (unloggedMappedAdversaryImpl secretKey) + (signingTraceComputation computation)).run initialCache = + (((simulateQ (mappedAdversaryImpl secretKey) computation).run).run initialCache) := by + rw [simulateQ_unloggedMapped_signingTraceComputation] + rw [mappedAdversaryImpl, QueryImpl.simulateQ_writerTMapBase_run] + +theorem simulateQ_unloggedMapped_retainedGameRestComputation + (adversary : Adversary) (secretKey : SecretKey) (publicKey : PublicKey) : + simulateQ (unloggedMappedAdversaryImpl secretKey) + (retainedGameRestComputation adversary publicKey) = (do + let (forgery, log) ← + simulateQ (unloggedMappedAdversaryImpl secretKey) + (signingTraceComputation + (adversary.main publicKey)) + let verified ← simulateQ romImpl + (scheme.verify publicKey forgery.message forgery.signature) + pure ((forgery, log), verified)) := by + unfold retainedGameRestComputation + rw [simulateQ_bind] + apply bind_congr + intro result + rcases result with ⟨forgery, log⟩ + rw [simulateQ_bind, simulateQ_unloggedMapped_liftOracleWorldLeft] + simp + +abbrev RetainedLogResult := + (Forgery × Bool) × (QueryCache HashSpec × QueryLog SigningSpec) + +def retainedRestLogProjection : + (RetainedRestResult × QueryCache HashSpec) → RetainedLogResult + | (((forgery, log), verified), cache) => + ((forgery, decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log forgery) && verified), (cache, log)) + +def signingRestLogProjection : + ((Forgery × Bool) × (QueryCache HashSpec × SigningCacheTrace)) → RetainedLogResult + | ((forgery, verdict), (cache, trace)) => + ((forgery, verdict), (cache, trace.toSigningLog)) + +theorem retainedGameRest_signing_projection + (adversary : Adversary) (publicKey : PublicKey) (secretKey : SecretKey) + (initialCache : QueryCache HashSpec) : + retainedRestLogProjection <$> + (simulateQ (unloggedMappedAdversaryImpl secretKey) + (retainedGameRestComputation adversary publicKey)).run initialCache = + signingRestLogProjection <$> + gameRestWithSigningTrace adversary publicKey secretKey initialCache := by + let traceRun := (simulateQ (cacheTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run (initialCache, []) + let retainedRun := (simulateQ (unloggedMappedAdversaryImpl secretKey) + (signingTraceComputation (adversary.main publicKey))).run initialCache + let prefixProjection : + (Forgery × QueryLog SigningSpec) × QueryCache HashSpec → + Forgery × (QueryCache HashSpec × QueryLog SigningSpec) := + fun result => (result.1.1, (result.2, result.1.2)) + let traceProjection : + Forgery × (QueryCache HashSpec × SigningCacheTrace) → + Forgery × (QueryCache HashSpec × QueryLog SigningSpec) := + fun result => (result.1, (result.2.1, result.2.2.toSigningLog)) + let finish : Forgery × (QueryCache HashSpec × QueryLog SigningSpec) → + ProbComp RetainedLogResult := fun result => do + let (verified, finalCache) ← + (simulateQ romImpl + (scheme.verify publicKey result.1.message result.1.signature)).run result.2.1 + pure ((result.1, decide (SigningTranscript.Valid result.2.2 ∧ + ¬SigningTranscript.Contains result.2.2 result.1) && verified), + (finalCache, result.2.2)) + have hprefix : traceProjection <$> traceRun = prefixProjection <$> retainedRun := by + rw [show traceProjection = Prod.map id + (fun state : QueryCache HashSpec × SigningCacheTrace => + (state.1, state.2.toSigningLog)) from rfl] + rw [show prefixProjection = fun result : + (Forgery × QueryLog SigningSpec) × QueryCache HashSpec => + (result.1.1, (result.2, result.1.2)) from rfl] + rw [show traceRun = (simulateQ (cacheTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run (initialCache, []) from rfl] + rw [cacheTracedMappedAdversaryImpl_log_projection_eq_mapped] + rw [show retainedRun = (simulateQ (unloggedMappedAdversaryImpl secretKey) + (signingTraceComputation (adversary.main publicKey))).run initialCache from rfl] + rw [simulateQ_unloggedMapped_signingTraceComputation_run] + rw [simulateQ_unloggedMapped_retainedGameRestComputation adversary secretKey publicKey] + calc + retainedRestLogProjection <$> + (do + let result ← retainedRun + let (verified, finalCache) ← + (simulateQ romImpl + (scheme.verify publicKey result.1.1.message result.1.1.signature)).run result.2 + pure ((result.1, verified), finalCache)) = + (prefixProjection <$> retainedRun) >>= finish := by + simp [retainedRestLogProjection, prefixProjection, retainedRun, finish, + bind_map_left, map_bind] + _ = (traceProjection <$> traceRun) >>= finish := by rw [hprefix] + _ = signingRestLogProjection <$> + gameRestWithSigningTrace adversary publicKey secretKey initialCache := by + simp [gameRestWithSigningTrace, traceRun, traceProjection, finish, + signingRestLogProjection, bind_map_left, map_bind] + +abbrev RetainedGameLogResult := + (Digest × Forgery × Bool) × (QueryCache HashSpec × QueryLog SigningSpec) + +def retainedGameLogProjection : + (RetainedGameResult × QueryCache HashSpec) → RetainedGameLogResult + | ((root, ((forgery, log), verified)), cache) => + ((root, forgery, decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log forgery) && verified), (cache, log)) + +def signingGameLogProjection : + ((Digest × Forgery × Bool) × (QueryCache HashSpec × SigningCacheTrace)) → + RetainedGameLogResult + | ((root, forgery, verdict), (cache, trace)) => + ((root, forgery, verdict), (cache, trace.toSigningLog)) + +def viewedGameLogProjection : + ((Digest × Forgery × Bool) × ViewedFullTraceState) → RetainedGameLogResult + | ((root, forgery, verdict), state) => + ((root, forgery, verdict), (state.cache, state.trace.signing.toSigningLog)) + +theorem actualRetainedGameAfterSecrets_signing_projection + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (table : Coordinate → Digest) : + retainedGameLogProjection <$> + actualRetainedGameAfterSecrets adversary parameter otsSecret table = + signingGameLogProjection <$> + gameAfterSecretsWithSigningTrace adversary parameter otsSecret + (fun index tree leafIdx => table (index, tree, leafIdx)) := by + let rootComputation : OracleComp HashSpec Digest := + treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) + have hroot : simulateQ romImpl + (liftM rootComputation : OracleComp OracleWorld Digest) = + simulateQ (randomOracle : QueryImpl HashSpec _ ) rootComputation := by + change simulateQ (unifFwdImpl HashSpec + randomOracle) + (liftM rootComputation : OracleComp OracleWorld Digest) = _ + exact QueryImpl.simulateQ_add_liftM_right _ _ _ + unfold actualRetainedGameAfterSecrets gameAfterSecretsWithSigningTrace + rw [show treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) = + rootComputation from rfl, hroot] + simp only [map_bind] + apply bind_congr + intro rootResult + let secretKey : SecretKey := + ⟨parameter, rootResult.1, otsSecret, + fun index tree leafIdx => table (index, tree, leafIdx)⟩ + have hrest := congrArg + (Functor.map fun result : RetainedLogResult => + ((rootResult.1, result.1.1, result.1.2), result.2)) + (retainedGameRest_signing_projection adversary + (⟨rootResult.1, parameter⟩ : PublicKey) secretKey rootResult.2) + simpa [retainedGameLogProjection, signingGameLogProjection, + retainedRestLogProjection, signingRestLogProjection, secretKey, + Functor.map_map, map_bind, bind_map_left] using hrest + +theorem gameAfterSecretsWithViewTrace_log_projection + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + viewedGameLogProjection <$> + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret = + signingGameLogProjection <$> + gameAfterSecretsWithSigningTrace adversary parameter otsSecret ftsSecret := by + let viewBase := fun result : (Digest × Forgery × Bool) × ViewedFullTraceState => + (result.1, result.2.base) + let fullSigning := fun result : (Digest × Forgery × Bool) × + (QueryCache HashSpec × FullAdversaryTrace) => + (result.1, (result.2.1, result.2.2.signing)) + have hprojection : viewedGameLogProjection = + signingGameLogProjection ∘ fullSigning ∘ viewBase := by + funext result + rcases result with ⟨⟨⟨root, forgery⟩, verdict⟩, state⟩ + rfl + calc + viewedGameLogProjection <$> + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret = + signingGameLogProjection <$> + (fullSigning <$> (viewBase <$> + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) := by + rw [hprojection] + simp [Functor.map_map, Function.comp_def] + _ = signingGameLogProjection <$> + (fullSigning <$> + gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [gameAfterSecretsWithViewTrace_projection] + _ = signingGameLogProjection <$> + gameAfterSecretsWithSigningTrace adversary parameter otsSecret ftsSecret := by + rw [gameAfterSecretsWithFullTrace_signing_projection] + +theorem gameAfterSecretsWithViewTrace_actualRetained_projection + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (table : Coordinate → Digest) : + viewedGameLogProjection <$> + gameAfterSecretsWithViewTrace adversary parameter otsSecret + (fun index tree leafIdx => table (index, tree, leafIdx)) = + retainedGameLogProjection <$> + actualRetainedGameAfterSecrets adversary parameter otsSecret table := by + rw [gameAfterSecretsWithViewTrace_log_projection] + exact (actualRetainedGameAfterSecrets_signing_projection adversary parameter + otsSecret table).symm + +def RetainedUncoveredFtsSecretWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (table : Coordinate → Digest) + (result : RetainedGameResult × QueryCache HashSpec) : Prop := + let root := result.1.1 + let forgery := result.1.2.1.1 + let log := result.1.2.1.2 + ∃ (f : QueryImpl HashSpec Id) (digest : MessageDigest), + result.2.AgreesWithFn f ∧ + evalWithAnswerFn f + (messageDigest parameter root forgery.message forgery.signature.randomness) = digest ∧ + Admissible digest ∧ + UncoveredFtsSecret f result.2 + ⟨parameter, root, otsSecret, + fun index tree leafIdx => table (index, tree, leafIdx)⟩ + log (digestIndex digest) (digestLeaves digest) forgery.signature.ftsSecret + +def RetainedLogUncoveredFtsSecretWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (table : Coordinate → Digest) (result : RetainedGameLogResult) : Prop := + let root := result.1.1 + let forgery := result.1.2.1 + let cache := result.2.1 + let log := result.2.2 + ∃ (f : QueryImpl HashSpec Id) (digest : MessageDigest), + cache.AgreesWithFn f ∧ SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log forgery ∧ + evalWithAnswerFn f + (messageDigest parameter root forgery.message forgery.signature.randomness) = digest ∧ + Admissible digest ∧ + UncoveredFtsSecret f cache + ⟨parameter, root, otsSecret, + fun index tree leafIdx => table (index, tree, leafIdx)⟩ + log (digestIndex digest) (digestLeaves digest) forgery.signature.ftsSecret + +theorem viewedUncovered_iff_logProjection + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (table : Coordinate → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : + ViewedUncoveredFtsSecretWitness parameter otsSecret + (fun index tree leafIdx => table (index, tree, leafIdx)) result ↔ + RetainedLogUncoveredFtsSecretWitness parameter otsSecret table + (viewedGameLogProjection result) := by + rfl + +theorem logProjection_uncovered_imp_retained + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (table : Coordinate → Digest) + (result : RetainedGameResult × QueryCache HashSpec) + (hwitness : RetainedLogUncoveredFtsSecretWitness parameter otsSecret table + (retainedGameLogProjection result)) : + RetainedUncoveredFtsSecretWitness parameter otsSecret table result := by + rcases result with ⟨⟨root, ⟨⟨forgery, log⟩, verified⟩⟩, cache⟩ + rcases hwitness with + ⟨f, digest, hf, _hvalid, _hnotContains, hdigest, hadmissible, huncovered⟩ + exact ⟨f, digest, hf, hdigest, hadmissible, huncovered⟩ + +theorem probEvent_gameAfterSecretsWithViewTrace_uncovered_le_actualRetained + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (table : Coordinate → Digest) : + Pr[ViewedUncoveredFtsSecretWitness parameter otsSecret + (fun index tree leafIdx => table (index, tree, leafIdx)) | + gameAfterSecretsWithViewTrace adversary parameter otsSecret + (fun index tree leafIdx => table (index, tree, leafIdx))] ≤ + Pr[RetainedUncoveredFtsSecretWitness parameter otsSecret table | + actualRetainedGameAfterSecrets adversary parameter otsSecret table] := by + calc + Pr[ViewedUncoveredFtsSecretWitness parameter otsSecret + (fun index tree leafIdx => table (index, tree, leafIdx)) | + gameAfterSecretsWithViewTrace adversary parameter otsSecret + (fun index tree leafIdx => table (index, tree, leafIdx))] = + Pr[RetainedLogUncoveredFtsSecretWitness parameter otsSecret table | + viewedGameLogProjection <$> + gameAfterSecretsWithViewTrace adversary parameter otsSecret + (fun index tree leafIdx => table (index, tree, leafIdx))] := by + rw [probEvent_map] + apply probEvent_congr' + · intro result _hresult + exact viewedUncovered_iff_logProjection parameter otsSecret table result + · rfl + _ = Pr[RetainedLogUncoveredFtsSecretWitness parameter otsSecret table | + retainedGameLogProjection <$> + actualRetainedGameAfterSecrets adversary parameter otsSecret table] := by + apply probEvent_congr' (fun _ _ => Iff.rfl) + exact congrArg evalDist + (gameAfterSecretsWithViewTrace_actualRetained_projection adversary parameter + otsSecret table) + _ ≤ Pr[RetainedUncoveredFtsSecretWitness parameter otsSecret table | + actualRetainedGameAfterSecrets adversary parameter otsSecret table] := by + rw [probEvent_map] + exact probEvent_mono fun result _hresult hwitness => + logProjection_uncovered_imp_retained parameter otsSecret table result hwitness + +set_option maxRecDepth 30000 in +theorem relTriple_maskedRetainedGameAfterSecrets + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (table : Coordinate → Digest) (q : Nat) + (hbound : (gameAfterSecrets adversary parameter otsSecret + (fun index tree leafIdx => table (index, tree, leafIdx))).IsQueryBoundP + (· matches Sum.inr _) q) : + RelTriple + (AdaptiveRevealProbe.runDetailed table AdaptiveRevealProbe.State.empty q + ((maskedRetainedGameAfterSecrets adversary parameter otsSecret).run + emptySplitHashCache)) + (actualRetainedGameAfterSecrets adversary parameter otsSecret table) + (CleanStepRel parameter table) := by + let rootComputation : OracleComp HashSpec Digest := + treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) + have hinitialClean : AdaptiveRevealProbe.tableHits + (AdaptiveRevealProbe.State.empty : AdaptiveRevealProbe.State Coordinate) table = false := by + simp [AdaptiveRevealProbe.tableHits, AdaptiveRevealProbe.State.empty] + rw [maskedRetainedGameAfterSecrets, actualRetainedGameAfterSecrets, + StateT.run_bind] + apply relTriple_runDetailed_bind_cleanOnly parameter table + AdaptiveRevealProbe.State.empty q + ((simulateQ ordinaryHashImpl rootComputation).run emptySplitHashCache) + (fun result => + let secretKey : SecretKey := + ⟨parameter, result.1, otsSecret, fun _index _tree _leafIdx => 0⟩ + ((simulateQ (maskedExpandedAdversaryImpl parameter secretKey) + (retainedGameRestComputation adversary ⟨result.1, parameter⟩)).run result.2 >>= fun + restResult => pure ((result.1, restResult.1), restResult.2))) + ((simulateQ (randomOracle : QueryImpl HashSpec _) rootComputation).run ∅) + (fun result => + let secretKey : SecretKey := + ⟨parameter, result.1, otsSecret, + fun index tree leafIdx => table (index, tree, leafIdx)⟩ + ((simulateQ (unloggedMappedAdversaryImpl secretKey) + (retainedGameRestComputation adversary ⟨result.1, parameter⟩)).run result.2 >>= fun + restResult => pure ((result.1, restResult.1), restResult.2))) + (simulateQ_ordinaryHashImpl_probeFree rootComputation emptySplitHashCache) + · simpa using (relTriple_of_coupledAt_stateFree + ((coupled_simulateQ_ordinaryHashImpl parameter table + AdaptiveRevealProbe.State.empty q rootComputation hinitialClean + (ordinaryOnly_treeRoot parameter table topLayer rootTree + (otsSecret topLayer rootTree))).coupledAt emptySplitHashCache) + hinitialClean (revealedSynced_empty parameter table) + (simulateQ_ordinaryHashImpl_stateFree rootComputation) + (simulateQ_ordinaryHashImpl_cachePreserving rootComputation)) + · intro finalState root finalCache hfinalClean hfinalSynced hright + let maskedSecretKey : SecretKey := + ⟨parameter, root, otsSecret, fun _index _tree _leafIdx => 0⟩ + let actualSecretKey : SecretKey := secretKeyWithFtsTable maskedSecretKey table + have hrootRun : root ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) rootComputation).run' ∅) := by + rw [StateT.run'_eq, support_map] + exact ⟨(root, mergedCache parameter table finalCache), hright, rfl⟩ + have hroot : root ∈ support rootComputation := + OracleComp.support_simulateQ_run'_subset + (randomOracle : QueryImpl HashSpec _) rootComputation ∅ hrootRun + have hrootLift : root ∈ support + (liftM rootComputation : OracleComp OracleWorld Digest) := by + rw [← OracleComp.liftComp_eq_liftM, + OracleComp.mem_support_liftComp_iff] + exact hroot + have hrest : (gameRest scheme adversary ⟨root, parameter⟩ actualSecretKey).IsQueryBoundP + (· matches Sum.inr _) q := by + apply isQueryBoundP_of_bind hbound root + exact hrootLift + have hretained := + simulateQ_expanded_retainedGameRestComputation_isQueryBoundP + adversary actualSecretKey q hrest + have hmapped : ((fun result : RetainedRestResult => (root, result)) <$> + simulateQ (expandedAdversaryImpl actualSecretKey) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (· matches Sum.inr _) q := + (isQueryBoundP_map_iff _ _ q).2 hretained + have hmapped' : (simulateQ + (expandedAdversaryImpl (secretKeyWithFtsTable maskedSecretKey table)) + ((fun result : RetainedRestResult => (root, result)) <$> + retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (· matches Sum.inr _) q := by + simpa [actualSecretKey] using hmapped + simpa [maskedSecretKey, actualSecretKey, secretKeyWithFtsTable, + simulateQ_map, StateT.run_map] using + (relTriple_simulateQ_maskedExpandedAdversaryImpl maskedSecretKey table + ((fun result : RetainedRestResult => (root, result)) <$> + retainedGameRestComputation adversary ⟨root, parameter⟩) + finalState q finalCache hmapped' hfinalClean hfinalSynced) + +set_option maxRecDepth 30000 in +theorem runDetailed_retainedGameRestComputation_clean_decompose + (adversary : Adversary) (secretKey : SecretKey) + (table : Coordinate → Digest) (fuel : Nat) + (initialCache finalCache : SplitHashCache) + (finalState : AdaptiveRevealProbe.State Coordinate) + (forgery : Forgery) (log : QueryLog SigningSpec) (verified : Bool) + (hresult : .done false finalState (((forgery, log), verified), finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table AdaptiveRevealProbe.State.empty fuel + ((simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (retainedGameRestComputation adversary + ⟨secretKey.root, secretKey.parameter⟩)).run initialCache))) : + ∃ prefixState prefixFuel prefixCache verifyFuel, + .done false prefixState ((forgery, log), prefixCache) ∈ support + (AdaptiveRevealProbe.runDetailed table AdaptiveRevealProbe.State.empty prefixFuel + ((simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (signingTraceComputation + (adversary.main ⟨secretKey.root, secretKey.parameter⟩))).run initialCache)) ∧ + .done false finalState (verified, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table prefixState verifyFuel + ((simulateQ (probingHashImpl secretKey.parameter) + (verify (m := OracleComp HashSpec) + ⟨secretKey.root, secretKey.parameter⟩ + forgery.message forgery.signature)).run prefixCache)) := by + obtain ⟨rawResult, hraw, hfinalize⟩ := + AdaptiveRevealProbe.exists_mem_support_runRaw_of_mem_runDetailed table + AdaptiveRevealProbe.State.empty fuel + ((simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (retainedGameRestComputation adversary + ⟨secretKey.root, secretKey.parameter⟩)).run initialCache) + (.done false finalState (((forgery, log), verified), finalCache)) hresult + cases rawResult with + | stopped hit => simp [AdaptiveRevealProbe.RawResult.finalize] at hfinalize + | done rawFinalState remaining value => + have hcleanFinal : AdaptiveRevealProbe.tableHits rawFinalState table = false := + (AdaptiveRevealProbe.DetailedResult.done.inj hfinalize).1 + have hstate : rawFinalState = finalState := + (AdaptiveRevealProbe.DetailedResult.done.inj hfinalize).2.1 + have hvalue : value = (((forgery, log), verified), finalCache) := + (AdaptiveRevealProbe.DetailedResult.done.inj hfinalize).2.2 + subst rawFinalState + subst value + rw [simulateQ_maskedExpanded_retainedGameRestComputation, + StateT.run_bind, AdaptiveRevealProbe.runRaw_bind, + mem_support_bind_iff] at hraw + obtain ⟨prefixRaw, hprefixRaw, htailRaw⟩ := hraw + cases prefixRaw with + | stopped prefixHit => simp at htailRaw + | done prefixState prefixFuel prefixValue => + rcases prefixValue with ⟨⟨prefixForgery, prefixLog⟩, prefixCache⟩ + simp only at htailRaw + rw [StateT.run_bind, AdaptiveRevealProbe.runRaw_bind, + mem_support_bind_iff] at htailRaw + obtain ⟨verifyRaw, hverifyRaw, hfinishRaw⟩ := htailRaw + cases verifyRaw with + | stopped verifyHit => simp at hfinishRaw + | done verifyState verifyFuel verifyValue => + rcases verifyValue with ⟨prefixVerified, prefixFinalCache⟩ + have hfinishEq : + AdaptiveRevealProbe.RawResult.done finalState remaining + (((forgery, log), verified), finalCache) = + AdaptiveRevealProbe.RawResult.done verifyState verifyFuel + (((prefixForgery, prefixLog), prefixVerified), prefixFinalCache) := by + simpa [AdaptiveRevealProbe.runRaw] using hfinishRaw + have hverifyState := + (AdaptiveRevealProbe.RawResult.done.inj hfinishEq).1 + have hverifyFuel := + (AdaptiveRevealProbe.RawResult.done.inj hfinishEq).2.1 + have hverifyOutput := + (AdaptiveRevealProbe.RawResult.done.inj hfinishEq).2.2 + subst verifyState + subst verifyFuel + have houter := Prod.mk.inj hverifyOutput + have hinner := Prod.mk.inj houter.1 + have hforgeryLog := Prod.mk.inj hinner.1 + obtain ⟨hforgery, hlog⟩ := hforgeryLog + have hverified := hinner.2 + have hcache := houter.2 + subst prefixForgery + subst prefixLog + subst prefixVerified + subst prefixFinalCache + have hverifyDetailed : + AdaptiveRevealProbe.DetailedResult.done false finalState + (verified, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table prefixState prefixFuel + ((simulateQ (probingHashImpl secretKey.parameter) + (verify (m := OracleComp HashSpec) + ⟨secretKey.root, secretKey.parameter⟩ + forgery.message forgery.signature)).run prefixCache)) := by + rw [← AdaptiveRevealProbe.finalize_runRaw_eq_runDetailed, support_map] + exact ⟨.done finalState remaining (verified, finalCache), hverifyRaw, by + simp [AdaptiveRevealProbe.RawResult.finalize, hcleanFinal]⟩ + have hprefixClean : + AdaptiveRevealProbe.tableHits prefixState table = false := by + cases hhit : AdaptiveRevealProbe.tableHits prefixState table with + | false => rfl + | true => + have hforced := runDetailed_hit_eq_true_of_tableHits_eq_true table + prefixState prefixFuel + ((simulateQ (probingHashImpl secretKey.parameter) + (verify (m := OracleComp HashSpec) + ⟨secretKey.root, secretKey.parameter⟩ + forgery.message forgery.signature)).run prefixCache) + hhit (.done false finalState (verified, finalCache)) hverifyDetailed + change false = true at hforced + exact Bool.noConfusion hforced + have hprefixDetailed : + AdaptiveRevealProbe.DetailedResult.done false prefixState + ((forgery, log), prefixCache) ∈ support + (AdaptiveRevealProbe.runDetailed table AdaptiveRevealProbe.State.empty + fuel + ((simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (signingTraceComputation + (adversary.main ⟨secretKey.root, secretKey.parameter⟩))).run + initialCache)) := by + rw [← AdaptiveRevealProbe.finalize_runRaw_eq_runDetailed, support_map] + exact ⟨.done prefixState prefixFuel ((forgery, log), prefixCache), + hprefixRaw, by + simp [AdaptiveRevealProbe.RawResult.finalize, hprefixClean]⟩ + exact ⟨prefixState, fuel, prefixCache, prefixFuel, + hprefixDetailed, hverifyDetailed⟩ + +theorem runDetailed_retainedGameRestComputation_not_uncoveredFtsSecret + (adversary : Adversary) (secretKey : SecretKey) + (table : Coordinate → Digest) (fuel : Nat) + (initialCache finalCache : SplitHashCache) + (finalState : AdaptiveRevealProbe.State Coordinate) + (forgery : Forgery) (log : QueryLog SigningSpec) (verified : Bool) + (f : QueryImpl HashSpec Id) + (hf : (mergedCache secretKey.parameter table finalCache).AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest secretKey.parameter secretKey.root forgery.message + forgery.signature.randomness) = digest) + (hadmissible : Admissible digest) + (hsynced : RevealedSynced secretKey.parameter table + AdaptiveRevealProbe.State.empty initialCache) + (hresult : .done false finalState (((forgery, log), verified), finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table AdaptiveRevealProbe.State.empty fuel + ((simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (retainedGameRestComputation adversary + ⟨secretKey.root, secretKey.parameter⟩)).run initialCache))) : + ¬UncoveredFtsSecret f (mergedCache secretKey.parameter table finalCache) + (secretKeyWithFtsTable secretKey table) log (digestIndex digest) + (digestLeaves digest) forgery.signature.ftsSecret := by + obtain ⟨prefixState, prefixFuel, prefixCache, verifyFuel, hprefix, hverify⟩ := + runDetailed_retainedGameRestComputation_clean_decompose adversary secretKey table fuel + initialCache finalCache finalState forgery log verified hresult + exact clean_trace_verify_not_uncoveredFtsSecret secretKey table + (adversary.main ⟨secretKey.root, secretKey.parameter⟩) prefixFuel verifyFuel + initialCache prefixCache finalCache prefixState finalState forgery log verified f hf + digest hdigest hadmissible hsynced hprefix hverify + +set_option maxRecDepth 30000 in +theorem runDetailed_maskedRetainedGameAfterSecrets_not_uncoveredFtsSecret + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (table : Coordinate → Digest) (fuel : Nat) + (finalState : AdaptiveRevealProbe.State Coordinate) + (root : Digest) (forgery : Forgery) (log : QueryLog SigningSpec) + (verified : Bool) (finalCache : SplitHashCache) + (f : QueryImpl HashSpec Id) + (hf : (mergedCache parameter table finalCache).AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest parameter root forgery.message forgery.signature.randomness) = digest) + (hadmissible : Admissible digest) + (hresult : .done false finalState + ((root, ((forgery, log), verified)), finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table AdaptiveRevealProbe.State.empty fuel + ((maskedRetainedGameAfterSecrets adversary parameter otsSecret).run + emptySplitHashCache))) : + ¬UncoveredFtsSecret f (mergedCache parameter table finalCache) + ⟨parameter, root, otsSecret, + fun index tree leafIdx => table (index, tree, leafIdx)⟩ + log (digestIndex digest) (digestLeaves digest) forgery.signature.ftsSecret := by + let rootComputation : OracleComp HashSpec Digest := + treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) + have hinitialClean : AdaptiveRevealProbe.tableHits + (AdaptiveRevealProbe.State.empty : AdaptiveRevealProbe.State Coordinate) table = false := by + simp [AdaptiveRevealProbe.tableHits, AdaptiveRevealProbe.State.empty] + rw [maskedRetainedGameAfterSecrets, StateT.run_bind] at hresult + obtain ⟨rootState, rootValue, hroot, hrest⟩ := + mem_support_runDetailed_bind_probeFree table AdaptiveRevealProbe.State.empty + finalState fuel + ((simulateQ ordinaryHashImpl rootComputation).run emptySplitHashCache) + (fun result => + let secretKey : SecretKey := + ⟨parameter, result.1, otsSecret, fun _index _tree _leafIdx => 0⟩ + ((simulateQ (maskedExpandedAdversaryImpl parameter secretKey) + (retainedGameRestComputation adversary ⟨result.1, parameter⟩)).run result.2 >>= fun + restResult => pure ((result.1, restResult.1), restResult.2))) + (simulateQ_ordinaryHashImpl_probeFree rootComputation emptySplitHashCache) + hinitialClean ((root, ((forgery, log), verified)), finalCache) hresult + rcases rootValue with ⟨actualRoot, rootCache⟩ + obtain ⟨stateFreeValue, hstateFree⟩ := + AdaptiveRevealProbe.runDetailed_stateFree_support table + AdaptiveRevealProbe.State.empty fuel + ((simulateQ ordinaryHashImpl rootComputation).run emptySplitHashCache) + (simulateQ_ordinaryHashImpl_stateFree rootComputation emptySplitHashCache) + hinitialClean (.done false rootState (actualRoot, rootCache)) hroot + have hrootState : rootState = AdaptiveRevealProbe.State.empty := + (AdaptiveRevealProbe.DetailedResult.done.inj hstateFree).2.1 + subst rootState + let maskedSecretKey : SecretKey := + ⟨parameter, actualRoot, otsSecret, fun _index _tree _leafIdx => 0⟩ + let restRun := + (simulateQ (maskedExpandedAdversaryImpl parameter maskedSecretKey) + (retainedGameRestComputation adversary ⟨actualRoot, parameter⟩)).run rootCache + change .done false finalState ((root, ((forgery, log), verified)), finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table AdaptiveRevealProbe.State.empty fuel + ((fun result : RetainedRestResult × SplitHashCache => + ((actualRoot, result.1), result.2)) <$> restRun)) at hrest + rw [AdaptiveRevealProbe.runDetailed_mapValue, support_map] at hrest + obtain ⟨restResult, hrestResult, hrestEq⟩ := hrest + cases restResult with + | stopped hit => simp [AdaptiveRevealProbe.DetailedResult.mapValue] at hrestEq + | done hit restState restValue => + rcases restValue with ⟨retainedResult, restCache⟩ + rcases retainedResult with ⟨⟨restForgery, restLog⟩, restVerified⟩ + change AdaptiveRevealProbe.DetailedResult.done hit restState + ((actualRoot, ((restForgery, restLog), restVerified)), restCache) = + AdaptiveRevealProbe.DetailedResult.done false finalState + ((root, ((forgery, log), verified)), finalCache) at hrestEq + have hhit := (AdaptiveRevealProbe.DetailedResult.done.inj hrestEq).1 + have hrestState := (AdaptiveRevealProbe.DetailedResult.done.inj hrestEq).2.1 + have hrestOutput := (AdaptiveRevealProbe.DetailedResult.done.inj hrestEq).2.2 + subst hit + subst restState + have houter := Prod.mk.inj hrestOutput + have hrootRest := Prod.mk.inj houter.1 + have hretained := Prod.mk.inj hrootRest.2 + have hforgeryLog := Prod.mk.inj hretained.1 + have hrootEq := hrootRest.1 + have hcacheEq := houter.2 + have hforgeryEq := hforgeryLog.1 + have hlogEq := hforgeryLog.2 + have hverifiedEq := hretained.2 + subst actualRoot + subst restForgery + subst restLog + subst restVerified + subst restCache + have hsynced : RevealedSynced parameter table + AdaptiveRevealProbe.State.empty rootCache := by + exact revealedSynced_of_mem_runDetailed_stateFree parameter table + AdaptiveRevealProbe.State.empty AdaptiveRevealProbe.State.empty fuel + emptySplitHashCache rootCache root + (simulateQ ordinaryHashImpl rootComputation) hinitialClean + (revealedSynced_empty parameter table) + (simulateQ_ordinaryHashImpl_stateFree rootComputation) + (simulateQ_ordinaryHashImpl_cachePreserving rootComputation) hroot + have hnot := runDetailed_retainedGameRestComputation_not_uncoveredFtsSecret + adversary maskedSecretKey table fuel rootCache finalCache finalState forgery log verified + f (by simpa [maskedSecretKey] using hf) digest (by + simpa [maskedSecretKey] using hdigest) hadmissible hsynced (by + simpa [restRun, maskedSecretKey] using hrestResult) + simpa [maskedSecretKey, secretKeyWithFtsTable] using hnot + +theorem probEvent_actualRetained_uncovered_le_detailed_hit + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (table : Coordinate → Digest) (q : Nat) + (hbound : (gameAfterSecrets adversary parameter otsSecret + (fun index tree leafIdx => table (index, tree, leafIdx))).IsQueryBoundP + (· matches Sum.inr _) q) : + Pr[RetainedUncoveredFtsSecretWitness parameter otsSecret table | + actualRetainedGameAfterSecrets adversary parameter otsSecret table] ≤ + Pr[fun result : AdaptiveRevealProbe.DetailedResult Coordinate + (RetainedGameResult × SplitHashCache) => result.hit = true | + AdaptiveRevealProbe.runDetailed table AdaptiveRevealProbe.State.empty q + ((maskedRetainedGameAfterSecrets adversary parameter otsSecret).run + emptySplitHashCache)] := by + let left := AdaptiveRevealProbe.runDetailed table AdaptiveRevealProbe.State.empty q + ((maskedRetainedGameAfterSecrets adversary parameter otsSecret).run emptySplitHashCache) + let right := actualRetainedGameAfterSecrets adversary parameter otsSecret table + have hrel := relTriple_maskedRetainedGameAfterSecrets adversary parameter otsSecret table q + hbound + have hrelSupport := relTriple_and_left_support hrel + (fun result => result ∈ support left) (fun result hresult => hresult) + apply probEvent_le_of_relTriple (relTriple_symm hrelSupport) + intro rightResult leftResult hrelation hevent + rcases hrelation.1 with hhit | hclean + · exact hhit + · cases leftResult with + | stopped hit => simp [CleanResultRel] at hclean + | done hit finalState valueCache => + rcases valueCache with ⟨value, finalCache⟩ + simp only [CleanResultRel] at hclean + obtain ⟨rfl, hright, _hfinalClean, _hfinalSynced⟩ := hclean + subst rightResult + rcases value with ⟨root, ⟨⟨forgery, log⟩, verified⟩⟩ + rcases hevent with ⟨f, digest, hf, hdigest, hadmissible, huncovered⟩ + have hnot := + runDetailed_maskedRetainedGameAfterSecrets_not_uncoveredFtsSecret adversary + parameter otsSecret table q finalState root forgery log verified finalCache f hf + digest hdigest hadmissible hrelation.2 + exact (hnot huncovered).elim + +noncomputable def sampledActualRetainedFts (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) : + ProbComp ((Coordinate → Digest) × (RetainedGameResult × QueryCache HashSpec)) := do + let table ← AdaptiveRevealProbe.sampleTable (Coordinate := Coordinate) + let result ← actualRetainedGameAfterSecrets adversary parameter otsSecret table + pure (table, result) + +def SampledRetainedUncoveredFtsSecretWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (result : (Coordinate → Digest) × (RetainedGameResult × QueryCache HashSpec)) : Prop := + RetainedUncoveredFtsSecretWitness parameter otsSecret result.1 result.2 + +theorem mem_support_sampleFtsSecrets + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ftsSecret ∈ support sampleFtsSecrets := by + change ftsSecret ∈ support + (@SampleableType.selectElem (Index → FtsTree → FtsLeaf → Digest) + ftsSecretsSampleableType) + exact ftsSecretsSampleableType.mem_support_selectElem ftsSecret + +set_option maxRecDepth 30000 in +set_option linter.constructorNameAsVariable false in +theorem probEvent_sampledActualRetainedFts_uncovered_le + (adversary : Adversary) (parameter : PublicParameter) + (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) : + Pr[SampledRetainedUncoveredFtsSecretWitness parameter otsSecret | + sampledActualRetainedFts adversary parameter otsSecret] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + let maskedRun := + (maskedRetainedGameAfterSecrets adversary parameter otsSecret).run emptySplitHashCache + calc + Pr[SampledRetainedUncoveredFtsSecretWitness parameter otsSecret | + sampledActualRetainedFts adversary parameter otsSecret] ≤ + Pr[fun result : (Coordinate → Digest) × + AdaptiveRevealProbe.DetailedResult Coordinate + (RetainedGameResult × SplitHashCache) => result.2.hit = true | + AdaptiveRevealProbe.detailedExperiment AdaptiveRevealProbe.State.empty q + maskedRun] := by + unfold sampledActualRetainedFts AdaptiveRevealProbe.detailedExperiment + apply probEvent_bind_le_bind_of_forall_le + intro table _htable + have hextend : AdaptiveRevealProbe.extendTable + (AdaptiveRevealProbe.State.empty : AdaptiveRevealProbe.State Coordinate) table = + table := by + funext coordinate + simp [AdaptiveRevealProbe.extendTable, AdaptiveRevealProbe.State.empty] + rw [hextend] + have hfts := mem_support_sampleFtsSecrets + (fun index tree leafIdx => table (index, tree, leafIdx)) + have hbound := isQueryBoundP_gameAfterSecrets adversary q hq hparameter hots hfts + simpa [SampledRetainedUncoveredFtsSecretWitness, + AdaptiveRevealProbe.extendTable, AdaptiveRevealProbe.State.empty, + probEvent_map, Function.comp_def, maskedRun] using + (probEvent_actualRetained_uncovered_le_detailed_hit adversary parameter + otsSecret table q hbound) + _ = Pr[fun hit : Bool => hit = true | + AdaptiveRevealProbe.experiment AdaptiveRevealProbe.State.empty q maskedRun] := by + rw [← AdaptiveRevealProbe.detailedExperiment_hit_eq_experiment] + rw [probEvent_map] + rfl + _ ≤ (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + letI : Nonempty Coordinate := + ⟨(⟨0, by norm_num [totalHeight]⟩, + ⟨0, by norm_num [ftsTrees]⟩, + ⟨0, by norm_num [ftsTreeHeight]⟩)⟩ + exact AdaptiveRevealProbe.experiment_empty_probability_le_unbounded q maskedRun + +noncomputable def curryFtsTableEquiv : + (Index → FtsTree → FtsLeaf → Digest) ≃ (Coordinate → Digest) where + toFun table coordinate := table coordinate.1 coordinate.2.1 coordinate.2.2 + invFun table index tree leafIdx := table (index, tree, leafIdx) + left_inv _ := rfl + right_inv _ := rfl + +theorem evalDist_uncurry_sampleFtsSecrets : + 𝒟[curryFtsTableEquiv <$> sampleFtsSecrets] = + 𝒟[AdaptiveRevealProbe.sampleTable (Coordinate := Coordinate)] := by + letI : SampleableType (Index → FtsTree → FtsLeaf → Digest) := + ftsSecretsSampleableType + letI : SampleableType (Coordinate → Digest) := + AdaptiveRevealProbe.tableSampleableType + apply evalDist_ext + intro table + change + Pr[= table | curryFtsTableEquiv <$> ($ᵗ (Index → FtsTree → FtsLeaf → Digest))] = + Pr[= table | $ᵗ (Coordinate → Digest)] + exact probOutput_map_bijective_uniform_cross + (Index → FtsTree → FtsLeaf → Digest) curryFtsTableEquiv + curryFtsTableEquiv.bijective table + +noncomputable def sampledConcreteActualRetainedFts (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) : + ProbComp ((Coordinate → Digest) × (RetainedGameResult × QueryCache HashSpec)) := do + let ftsSecret ← sampleFtsSecrets + let table := curryFtsTableEquiv ftsSecret + let result ← actualRetainedGameAfterSecrets adversary parameter otsSecret table + pure (table, result) + +theorem evalDist_sampledConcreteActualRetainedFts_eq + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) : + 𝒟[sampledConcreteActualRetainedFts adversary parameter otsSecret] = + 𝒟[sampledActualRetainedFts adversary parameter otsSecret] := by + have hsource : sampledConcreteActualRetainedFts adversary parameter otsSecret = + (curryFtsTableEquiv <$> sampleFtsSecrets) >>= fun table => + actualRetainedGameAfterSecrets adversary parameter otsSecret table >>= fun result => + pure (table, result) := by + simp [sampledConcreteActualRetainedFts, bind_map_left] + rw [hsource] + unfold sampledActualRetainedFts + change 𝒟[(curryFtsTableEquiv <$> sampleFtsSecrets) >>= fun table => + actualRetainedGameAfterSecrets adversary parameter otsSecret table >>= fun result => + pure (table, result)] = + 𝒟[AdaptiveRevealProbe.sampleTable (Coordinate := Coordinate) >>= fun table => + actualRetainedGameAfterSecrets adversary parameter otsSecret table >>= fun result => + pure (table, result)] + rw [evalDist_bind, evalDist_bind, evalDist_uncurry_sampleFtsSecrets] + +noncomputable def sampledFtsViewedGame (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) : + ProbComp ((Index → FtsTree → FtsLeaf → Digest) × + ((Digest × Forgery × Bool) × ViewedFullTraceState)) := do + let ftsSecret ← sampleFtsSecrets + let result ← gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + pure (ftsSecret, result) + +def SampledFtsViewedUncoveredWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (result : (Index → FtsTree → FtsLeaf → Digest) × + ((Digest × Forgery × Bool) × ViewedFullTraceState)) : Prop := + ViewedUncoveredFtsSecretWitness parameter otsSecret result.1 result.2 + +theorem probEvent_sampledFtsViewedGame_uncovered_le + (adversary : Adversary) (parameter : PublicParameter) + (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) : + Pr[SampledFtsViewedUncoveredWitness parameter otsSecret | + sampledFtsViewedGame adversary parameter otsSecret] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + Pr[SampledFtsViewedUncoveredWitness parameter otsSecret | + sampledFtsViewedGame adversary parameter otsSecret] ≤ + Pr[SampledRetainedUncoveredFtsSecretWitness parameter otsSecret | + sampledConcreteActualRetainedFts adversary parameter otsSecret] := by + unfold sampledFtsViewedGame sampledConcreteActualRetainedFts + apply probEvent_bind_le_bind_of_forall_le + intro ftsSecret _hfts + let table := curryFtsTableEquiv ftsSecret + simpa [SampledFtsViewedUncoveredWitness, + SampledRetainedUncoveredFtsSecretWitness, table, curryFtsTableEquiv, + probEvent_map, Function.comp_def] using + (probEvent_gameAfterSecretsWithViewTrace_uncovered_le_actualRetained + adversary parameter otsSecret table) + _ = Pr[SampledRetainedUncoveredFtsSecretWitness parameter otsSecret | + sampledActualRetainedFts adversary parameter otsSecret] := by + apply probEvent_congr' (fun _ _ => Iff.rfl) + exact evalDist_sampledConcreteActualRetainedFts_eq adversary parameter otsSecret + _ ≤ (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + probEvent_sampledActualRetainedFts_uncovered_le adversary parameter hparameter + otsSecret hots q hq + +set_option maxRecDepth 30000 in +theorem probEvent_sampledViewedGame_cleanUncovered_le + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) : + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [sampledViewedGame, sampleSecrets] + simp only [bind_assoc, pure_bind] + apply probEvent_bind_le_of_forall_le + intro parameter hparameter + apply probEvent_bind_le_of_forall_le + intro otsSecret hots + let pack : ((Index → FtsTree → FtsLeaf → Digest) × + ((Digest × Forgery × Bool) × ViewedFullTraceState)) → SampledViewedResult := + fun result => ⟨⟨parameter, otsSecret, result.1⟩, result.2⟩ + have hrun : (sampleFtsSecrets >>= fun ftsSecret => + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret >>= fun result => + pure (⟨⟨parameter, otsSecret, ftsSecret⟩, result⟩ : SampledViewedResult)) = + pack <$> sampledFtsViewedGame adversary parameter otsSecret := by + simp [sampledFtsViewedGame, pack] + rw [hrun, probEvent_map] + apply le_trans (probEvent_mono fun result _hresult hevent => hevent.2) + exact probEvent_sampledFtsViewedGame_uncovered_le adversary parameter hparameter + otsSecret hots q hq + +end Concrete.FtsProbeSimulation + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeSigner.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeSigner.lean new file mode 100644 index 00000000..1f63790b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeSigner.lean @@ -0,0 +1,585 @@ +import SphincsSecurity.Proof.FtsProbeGame +import VCVio.OracleComp.QueryTracking.SubSpec + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open OracleComp OracleSpec + +noncomputable def RomOrdinaryOnly (parameter : PublicParameter) + (table : Coordinate → Digest) + (computation : OracleComp OracleWorld alpha) : Prop := by + classical + exact computation.IsQueryBoundP + (fun input => match input with + | .inl _ => False + | .inr hashInput => NonOrdinaryInput parameter table hashInput) 0 + +theorem RomOrdinaryOnly.pure (parameter : PublicParameter) (table : Coordinate → Digest) + (value : alpha) : + RomOrdinaryOnly parameter table (pure value) := by + simp [RomOrdinaryOnly] + +theorem RomOrdinaryOnly.bind + {parameter : PublicParameter} {table : Coordinate → Digest} + {left : OracleComp OracleWorld alpha} {next : alpha → OracleComp OracleWorld beta} + (hleft : RomOrdinaryOnly parameter table left) + (hnext : ∀ value, RomOrdinaryOnly parameter table (next value)) : + RomOrdinaryOnly parameter table (left >>= next) := by + classical + unfold RomOrdinaryOnly at hleft hnext ⊢ + exact isQueryBoundP_bind (n := 0) (m := 0) hleft fun value _ => hnext value + +theorem OrdinaryOnly.liftRom + {parameter : PublicParameter} {table : Coordinate → Digest} + {computation : OracleComp HashSpec alpha} + (hordinary : OrdinaryOnly parameter table computation) : + RomOrdinaryOnly parameter table + (liftM computation : OracleComp OracleWorld alpha) := by + classical + unfold OrdinaryOnly at hordinary + unfold RomOrdinaryOnly + exact OracleComp.IsQueryBoundP.liftComp_subSpec + (h := OracleQuery.subSpec_add_right) + (q := fun input : OracleWorld.Domain => match input with + | .inl _ => False + | .inr hashInput => NonOrdinaryInput parameter table hashInput) + (fun _input => Iff.rfl) hordinary + +theorem romOrdinaryOnly_liftProbComp + (parameter : PublicParameter) (table : Coordinate → Digest) + (computation : ProbComp alpha) : + RomOrdinaryOnly parameter table + (liftM computation : OracleComp OracleWorld alpha) := by + classical + unfold RomOrdinaryOnly + exact OracleComp.IsQueryBoundP.liftComp_subSpec + (h := OracleQuery.subSpec_add_left) + (p := fun _ : unifSpec.Domain => False) + (q := fun input : OracleWorld.Domain => match input with + | .inl _ => False + | .inr hashInput => NonOrdinaryInput parameter table hashInput) + (fun _input => Iff.rfl) (isQueryBoundP_false computation 0) + +theorem splitUniformImpl_stateFree (n : unifSpec.Domain) : + StateFree (splitUniformImpl n) := by + intro cache + change (((fun output : Fin (n + 1) => (output, cache)) <$> + AdaptiveRevealProbe.uniformQuery (Coordinate := Coordinate) n).IsQueryBoundP + (AdaptiveRevealProbe.IsStateful (Coordinate := Coordinate)) 0) + rw [isQueryBoundP_map_iff, AdaptiveRevealProbe.uniformQuery, + OracleComp.isQueryBoundP_query_iff] + simp [AdaptiveRevealProbe.IsStateful] + +theorem simulateQ_splitRomImpl_stateFree + (computation : OracleComp OracleWorld alpha) : + StateFree (simulateQ splitRomImpl computation) := by + intro cache + apply (isQueryBoundP_false computation 0).simulateQ_run_StateT_of_step + intro input workingCache + cases input with + | inl n => exact splitUniformImpl_stateFree n workingCache + | inr hashInput => exact splitHashQuery_stateFree (.ordinary hashInput) workingCache + +theorem splitUniformImpl_cachePreserving (n : unifSpec.Domain) : + CachePreserving (splitUniformImpl n) := by + intro initial result hresult + unfold splitUniformImpl at hresult + rw [StateT.run_liftM, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hresult⟩ := hresult + simp only [support_pure, Set.mem_singleton_iff] at hresult + subst result + exact SplitCacheLE.refl initial + +theorem simulateQ_splitRomImpl_cachePreserving + (computation : OracleComp OracleWorld alpha) : + CachePreserving (simulateQ splitRomImpl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp only [simulateQ_pure] + exact CachePreserving.pure value + | query_bind input next ih => + rw [simulateQ_query_bind] + cases input with + | inl n => + exact (splitUniformImpl_cachePreserving n).bind fun output => ih output + | inr hashInput => + exact (splitHashQuery_cachePreserving (.ordinary hashInput)).bind + fun output => ih output + +theorem coupled_splitUniformImpl + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (n : unifSpec.Domain) + (hclean : AdaptiveRevealProbe.tableHits state table = false) : + Coupled parameter table state fuel (splitUniformImpl n) (unifFwdImpl HashSpec n) := by + intro cache + unfold splitUniformImpl + rw [StateT.run_liftM] + change projectDetailedCache parameter table <$> + AdaptiveRevealProbe.runDetailed table state fuel + ((liftM (OracleSpec.query (spec := AdaptiveRevealProbe.World Coordinate) + (.uniform n)) : OracleComp (AdaptiveRevealProbe.World Coordinate) (Fin (n + 1))) >>= + fun output => pure (output, cache)) = _ + rw [AdaptiveRevealProbe.runDetailed_uniform_query_bind] + simp [AdaptiveRevealProbe.runDetailed, projectDetailedCache, hclean, unifFwdImpl] + +theorem coupled_simulateQ_splitRomImpl + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (computation : OracleComp OracleWorld alpha) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hordinaryOnly : RomOrdinaryOnly parameter table computation) : + Coupled parameter table state fuel (simulateQ splitRomImpl computation) + (simulateQ romImpl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp only [simulateQ_pure] + exact Coupled.pure parameter table state fuel hclean value + | query_bind input next ih => + unfold RomOrdinaryOnly at hordinaryOnly + rw [isQueryBoundP_query_bind_iff] at hordinaryOnly + rw [simulateQ_query_bind, simulateQ_query_bind] + cases input with + | inl n => + refine Coupled.bind hclean (splitUniformImpl_stateFree n) + (coupled_splitUniformImpl parameter table state fuel n hclean) ?_ + intro output + exact ih output (by simpa [RomOrdinaryOnly] using hordinaryOnly.2 output) + | inr input => + have hordinary : IsOrdinaryInput parameter table input := by + by_contra hnot + have hzero := hordinaryOnly.1 + simp [NonOrdinaryInput, hnot] at hzero + refine Coupled.bind hclean (splitHashQuery_stateFree (.ordinary input)) + (coupled_splitHashQuery_ordinary parameter table state fuel input hclean + hordinary) ?_ + intro output + exact ih output (by + simpa [RomOrdinaryOnly, NonOrdinaryInput, hordinary] using + hordinaryOnly.2 output) + +theorem ordinaryOnly_messageDigest + (parameter : PublicParameter) (table : Coordinate → Digest) + (root : Digest) (message : Message) (randomness : Randomness) : + OrdinaryOnly parameter table + (messageDigest parameter root message randomness : + OracleComp HashSpec MessageDigest) := by + unfold messageDigest oracleHash OrdinaryOnly + change ((liftM (HashSpec.query (tweakableHashInput parameter .message + (messageDigestPayload root message randomness))) : OracleComp HashSpec HashOutput) >>= + fun output => pure (truncateMessageDigest output)).IsQueryBoundP + (NonOrdinaryInput parameter table) 0 + rw [isQueryBoundP_query_bind_iff] + constructor + · have hordinary : IsOrdinaryInput parameter table + (tweakableHashInput parameter .message + (messageDigestPayload root message randomness)) := + isOrdinaryInput_of_domain_ne_ftsLeaf parameter table .message _ (by trivial) + (by intros; simp) + simp [NonOrdinaryInput, hordinary] + · intro output + trivial + +theorem ordinaryOnly_signAttempt + (secretKey : SecretKey) (table : Coordinate → Digest) + (message : Message) (randomness : Randomness) : + OrdinaryOnly secretKey.parameter table + (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))) := by + unfold signAttempt + exact (ordinaryOnly_messageDigest secretKey.parameter table secretKey.root message + randomness).bind fun digest => by + split <;> exact OrdinaryOnly.pure secretKey.parameter table _ + +theorem romOrdinaryOnly_signDigestLoop + (attempts : Nat) (secretKey : SecretKey) (table : Coordinate → Digest) + (message : Message) : + RomOrdinaryOnly secretKey.parameter table + (signDigestLoop attempts secretKey message) := by + induction attempts with + | zero => + rw [signDigestLoop] + exact RomOrdinaryOnly.pure secretKey.parameter table none + | succ attempts ih => + rw [signDigestLoop] + exact (romOrdinaryOnly_liftProbComp secretKey.parameter table sampleRandomness).bind + fun randomness => + (ordinaryOnly_signAttempt secretKey table message randomness).liftRom.bind + fun attempt => by + cases attempt with + | none => exact ih + | some selected => + exact RomOrdinaryOnly.pure secretKey.parameter table + (some (randomness, selected.1, selected.2)) + +theorem signAttempt_secretKeyWithFtsTable + (secretKey : SecretKey) (table : Coordinate → Digest) + (message : Message) (randomness : Randomness) : + (signAttempt (secretKeyWithFtsTable secretKey table) message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))) = + signAttempt secretKey message randomness := by + unfold signAttempt messageDigest oracleHash + simp only [secretKeyWithFtsTable_parameter, secretKeyWithFtsTable_root] + +theorem signDigestLoop_secretKeyWithFtsTable + (attempts : Nat) (secretKey : SecretKey) (table : Coordinate → Digest) + (message : Message) : + signDigestLoop attempts (secretKeyWithFtsTable secretKey table) message = + signDigestLoop attempts secretKey message := by + induction attempts with + | zero => rw [signDigestLoop, signDigestLoop] + | succ attempts ih => + rw [signDigestLoop, signDigestLoop] + simp only [signAttempt_secretKeyWithFtsTable, ih] + +theorem hiddenIndexCached_of_mem_runDetailed_revealFtsSecret + (parameter : PublicParameter) (table : Coordinate → Digest) (index : Index) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (initial final : SplitHashCache) (coordinate : Coordinate) (value : Digest) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state initial) + (hcached : HiddenIndexCached index initial) + (hcoordinate : coordinate.1 = index) + (hresult : .done false finalState (value, final) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((revealFtsSecret parameter coordinate).run initial))) : + HiddenIndexCached index final := by + rcases coordinate with ⟨coordinateIndex, tree, leafIdx⟩ + simp only at hcoordinate + subst coordinateIndex + have hhidden := hcached tree leafIdx + cases hrevealed : state.revealed (index, tree, leafIdx) with + | none => + obtain ⟨output, hhiddenCache⟩ := hhidden + have hrun := runDetailed_revealFtsSecret_hidden parameter table state fuel initial + (index, tree, leafIdx) output hrevealed hclean hhiddenCache + rw [hrun] at hresult + simp only [support_pure, Set.mem_singleton_iff, + AdaptiveRevealProbe.DetailedResult.done.injEq] at hresult + obtain ⟨hfinalState, hvalueCache⟩ := hresult.2 + subst finalState + cases hvalueCache + intro tree leafIdx + obtain ⟨oldOutput, hold⟩ := hcached tree leafIdx + refine ⟨oldOutput, ?_⟩ + rw [Function.update_of_ne (by simp)] + exact hold + | some revealedValue => + obtain ⟨hvalue, output, hhiddenCache, hordinaryCache⟩ := + hsynced (index, tree, leafIdx) revealedValue hrevealed + have hrun := runDetailed_revealFtsSecret_revealed parameter table state fuel initial + (index, tree, leafIdx) revealedValue output hrevealed hvalue hhiddenCache + hordinaryCache hclean + rw [hrun] at hresult + simp only [support_pure, Set.mem_singleton_iff, + AdaptiveRevealProbe.DetailedResult.done.injEq] at hresult + obtain ⟨hfinalState, hvalueCache⟩ := hresult.2 + subst finalState + cases hvalueCache + exact hcached + +theorem sequenceFin_pure_queryCache_run {n : Nat} (values : Fin n → alpha) + (cache : QueryCache HashSpec) : + (sequenceFin (fun position => + (pure (values position) : StateT (QueryCache HashSpec) ProbComp alpha))).run cache = + pure (values, cache) := by + induction n with + | zero => + rw [sequenceFin, StateT.run_pure] + congr 2 + funext position + exact position.elim0 + | succ n ih => + rw [sequenceFin, StateT.run_bind, StateT.run_pure, pure_bind, + StateT.run_bind, ih (fun position => values position.succ), pure_bind, + StateT.run_pure] + congr 2 + funext position + cases position using Fin.cases <;> rfl + +theorem tableHits_false_of_mem_runDetailed_probeFree + (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (computation : OracleComp (AdaptiveRevealProbe.World Coordinate) alpha) + (hbound : computation.IsQueryBoundP AdaptiveRevealProbe.IsProbe 0) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (value : alpha) + (hresult : .done false finalState value ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel computation)) : + AdaptiveRevealProbe.tableHits finalState table = false := by + obtain ⟨resultState, resultValue, hresultEq, hresultClean⟩ := + AdaptiveRevealProbe.runDetailed_probeFree_support table state fuel computation hbound + hclean (.done false finalState value) hresult + have hstate : finalState = resultState := + (AdaptiveRevealProbe.DetailedResult.done.inj hresultEq).2.1 + subst finalState + exact hresultClean + +theorem coupledAt_revealSequence {n : Nat} + (parameter : PublicParameter) (table : Coordinate → Digest) (index : Index) + (coordinates : Fin n → Coordinate) + (hcoordinates : ∀ position, (coordinates position).1 = index) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state cache) + (hcached : HiddenIndexCached index cache) : + CoupledAt parameter table state fuel + (sequenceFin fun position => revealFtsSecret parameter (coordinates position)) + (sequenceFin fun position => + (pure (table (coordinates position)) : + StateT (QueryCache HashSpec) ProbComp Digest)) cache := by + induction n generalizing state cache with + | zero => + simp only [sequenceFin] + exact (Coupled.pure parameter table state fuel hclean Fin.elim0).coupledAt cache + | succ n ih => + rw [sequenceFin, sequenceFin] + have hcoordinateZero : coordinates 0 = + (index, (coordinates 0).2.1, (coordinates 0).2.2) := by + rcases hcoordinate : coordinates 0 with ⟨coordinateIndex, tree, leafIdx⟩ + have hindex := hcoordinates 0 + rw [hcoordinate] at hindex + simpa using hindex + have hhiddenZero : ∃ output, + cache (.hiddenLeaf (coordinates 0)) = some output := by + rw [hcoordinateZero] + exact hcached (coordinates 0).2.1 (coordinates 0).2.2 + apply CoupledAt.bind_probeFree hclean + (revealFtsSecret_probeFree parameter (coordinates 0)) + (coupledAt_revealFtsSecret parameter table state fuel cache (coordinates 0) hclean + hsynced hhiddenZero) + intro headState headValue headCache hhead + have hheadClean : AdaptiveRevealProbe.tableHits headState table = false := + tableHits_false_of_mem_runDetailed_probeFree table state headState fuel + ((revealFtsSecret parameter (coordinates 0)).run cache) + (revealFtsSecret_probeFree parameter (coordinates 0) cache) hclean + (headValue, headCache) hhead + have hheadSynced : RevealedSynced parameter table headState headCache := + revealedSynced_of_mem_runDetailed_revealFtsSecret parameter table state headState fuel + cache headCache (coordinates 0) headValue hclean hsynced + (hhiddenZero) hhead + have hheadCached : HiddenIndexCached index headCache := + hiddenIndexCached_of_mem_runDetailed_revealFtsSecret parameter table index state + headState fuel cache headCache (coordinates 0) headValue hclean hsynced hcached + (hcoordinates 0) hhead + apply CoupledAt.bind_probeFree hheadClean + (sequenceFin_probeFree + (fun position => revealFtsSecret parameter (coordinates position.succ)) + (fun position => revealFtsSecret_probeFree parameter (coordinates position.succ))) + (ih (fun position => coordinates position.succ) + (fun position => hcoordinates position.succ) headState headCache hheadClean + hheadSynced hheadCached) + intro tailState tailValue tailCache htail + have htailClean : AdaptiveRevealProbe.tableHits tailState table = false := + tableHits_false_of_mem_runDetailed_probeFree table headState tailState fuel + ((sequenceFin fun position => + revealFtsSecret parameter (coordinates position.succ)).run headCache) + (sequenceFin_probeFree + (fun position => revealFtsSecret parameter (coordinates position.succ)) + (fun position => revealFtsSecret_probeFree parameter + (coordinates position.succ)) headCache) + hheadClean (tailValue, tailCache) htail + unfold CoupledAt + simp [AdaptiveRevealProbe.runDetailed, projectDetailedCache, htailClean] + +theorem coupledAt_revealSelectedFtsSecrets + (parameter : PublicParameter) (table : Coordinate → Digest) (index : Index) + (leaves : DigestTree → FtsLeaf) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state cache) + (hcached : HiddenIndexCached index cache) : + CoupledAt parameter table state fuel (revealSelectedFtsSecrets parameter index leaves) + (pure (fun tree => table (index, tree, leaves (ftsIndexOf tree))) : + StateT (QueryCache HashSpec) ProbComp (FtsTree → Digest)) cache := by + unfold revealSelectedFtsSecrets + have hcoupled := coupledAt_revealSequence parameter table index + (fun tree => (index, tree, leaves (ftsIndexOf tree))) (fun tree => rfl) + state fuel cache hclean hsynced hcached + unfold CoupledAt at hcoupled ⊢ + rw [sequenceFin_pure_queryCache_run] at hcoupled + exact hcoupled + +theorem coupledAt_maskedSignAfterDigest + (secretKey : SecretKey) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) (randomness : Randomness) (index : Index) + (leaves : DigestTree → FtsLeaf) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced secretKey.parameter table state cache) : + CoupledAt secretKey.parameter table state fuel + (maskedSignAfterDigest secretKey randomness index leaves) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest (secretKeyWithFtsTable secretKey table) randomness index leaves)) + cache := by + unfold maskedSignAfterDigest signAfterDigest + rw [simulateQ_bind] + apply CoupledAt.bind_probeFree hclean + (maskedFtsOpen_probeFree secretKey.parameter index leaves) + ((coupled_maskedFtsOpen secretKey.parameter table state fuel index leaves hclean).coupledAt + cache) + intro pathState ftsPath pathCache hpath + have hpathClean : AdaptiveRevealProbe.tableHits pathState table = false := + tableHits_false_of_mem_runDetailed_probeFree table state pathState fuel + ((maskedFtsOpen secretKey.parameter index leaves).run cache) + (maskedFtsOpen_probeFree secretKey.parameter index leaves cache) hclean + (ftsPath, pathCache) hpath + have hpathSynced : RevealedSynced secretKey.parameter table pathState pathCache := + revealedSynced_of_mem_runDetailed_stateFree secretKey.parameter table state pathState + fuel cache pathCache ftsPath (maskedFtsOpen secretKey.parameter index leaves) hclean + hsynced (maskedFtsOpen_stateFree secretKey.parameter index leaves) + (maskedFtsOpen_cachePreserving secretKey.parameter index leaves) hpath + rw [simulateQ_bind, simulateQ_randomOracle_sequenceFin] + apply CoupledAt.bind_probeFree hpathClean + (sequenceFin_probeFree (fun lay => maskedSignLayer secretKey index lay) + (fun lay => maskedSignLayer_probeFree secretKey index lay)) + ((coupled_sequenceFin secretKey.parameter table pathState fuel + (fun lay => maskedSignLayer secretKey index lay) + (fun lay => simulateQ (randomOracle : QueryImpl HashSpec _) + (signLayer (secretKeyWithFtsTable secretKey table) index lay)) hpathClean + (fun lay => maskedSignLayer_stateFree secretKey index lay) + (fun lay => coupled_maskedSignLayer secretKey table pathState fuel index lay + hpathClean)).coupledAt pathCache) + intro layersState layers layersCache hlayers + have hlayersClean : AdaptiveRevealProbe.tableHits layersState table = false := + tableHits_false_of_mem_runDetailed_probeFree table pathState layersState fuel + ((sequenceFin fun lay => maskedSignLayer secretKey index lay).run pathCache) + (sequenceFin_probeFree (fun lay => maskedSignLayer secretKey index lay) + (fun lay => maskedSignLayer_probeFree secretKey index lay) pathCache) + hpathClean (layers, layersCache) hlayers + have hlayersSynced : RevealedSynced secretKey.parameter table layersState layersCache := + revealedSynced_of_mem_runDetailed_stateFree secretKey.parameter table pathState layersState + fuel pathCache layersCache layers + (sequenceFin fun lay => maskedSignLayer secretKey index lay) hpathClean hpathSynced + (sequenceFin_stateFree (fun lay => maskedSignLayer secretKey index lay) + (fun lay => maskedSignLayer_stateFree secretKey index lay)) + (sequenceFin_cachePreserving (fun lay => maskedSignLayer secretKey index lay) + (fun lay => maskedSignLayer_cachePreserving secretKey index lay)) hlayers + have hlayersCached : HiddenIndexCached index layersCache := + hiddenIndexCached_of_mem_runDetailed_maskedSignLayers secretKey table pathState + layersState fuel pathCache layersCache index layers hpathClean hlayers + cases hparts : traverseOption layers with + | none => + simp only [simulateQ_pure] + unfold CoupledAt + simp [AdaptiveRevealProbe.runDetailed, projectDetailedCache, hlayersClean] + | some parts => + simp only [simulateQ_pure] + let finish := fun selected : FtsTree → Digest => some (show Signature from + { randomness := randomness + ftsSecret := selected + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (parts lay).2.1 + authPath := flattenPaths fun lay => (parts lay).2.2 }) + change CoupledAt secretKey.parameter table layersState fuel + (revealSelectedFtsSecrets secretKey.parameter index leaves >>= fun selected => + pure (finish selected)) + ((pure (fun tree => table (index, tree, leaves (ftsIndexOf tree))) : + StateT (QueryCache HashSpec) ProbComp (FtsTree → Digest)) >>= fun selected => + pure (finish selected)) layersCache + apply CoupledAt.bind_probeFree hlayersClean + (revealSelectedFtsSecrets_probeFree secretKey.parameter index leaves) + (coupledAt_revealSelectedFtsSecrets secretKey.parameter table index leaves layersState + fuel layersCache hlayersClean hlayersSynced hlayersCached) + intro selectedState selected selectedCache hselected + have hselectedClean : AdaptiveRevealProbe.tableHits selectedState table = false := + tableHits_false_of_mem_runDetailed_probeFree table layersState selectedState fuel + ((revealSelectedFtsSecrets secretKey.parameter index leaves).run layersCache) + (revealSelectedFtsSecrets_probeFree secretKey.parameter index leaves layersCache) + hlayersClean (selected, selectedCache) hselected + unfold CoupledAt + simp [AdaptiveRevealProbe.runDetailed, projectDetailedCache, hselectedClean] + +set_option maxRecDepth 10000 in +theorem coupledAt_maskedSignWithView + (secretKey : SecretKey) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) (message : Message) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced secretKey.parameter table state cache) : + CoupledAt secretKey.parameter table state fuel + (maskedSignWithView secretKey message) + (simulateQ romImpl (signWithView (secretKeyWithFtsTable secretKey table) message)) + cache := by + unfold maskedSignWithView signWithView + rw [signDigestLoop_secretKeyWithFtsTable] + rw [simulateQ_bind] + apply CoupledAt.bind_probeFree hclean + (simulateQ_splitRomImpl_probeFree + (signDigestLoop digestAttemptLimit secretKey message)) + ((coupled_simulateQ_splitRomImpl secretKey.parameter table state fuel + (signDigestLoop digestAttemptLimit secretKey message) hclean + (romOrdinaryOnly_signDigestLoop digestAttemptLimit secretKey table message)).coupledAt + cache) + intro loopState selected loopCache hselected + have hloopClean : AdaptiveRevealProbe.tableHits loopState table = false := + tableHits_false_of_mem_runDetailed_probeFree table state loopState fuel + ((simulateQ splitRomImpl + (signDigestLoop digestAttemptLimit secretKey message)).run cache) + (simulateQ_splitRomImpl_probeFree + (signDigestLoop digestAttemptLimit secretKey message) cache) + hclean (selected, loopCache) hselected + have hloopSynced : RevealedSynced secretKey.parameter table loopState loopCache := + revealedSynced_of_mem_runDetailed_stateFree secretKey.parameter table state loopState + fuel cache loopCache selected + (simulateQ splitRomImpl (signDigestLoop digestAttemptLimit secretKey message)) + hclean hsynced + (simulateQ_splitRomImpl_stateFree + (signDigestLoop digestAttemptLimit secretKey message)) + (simulateQ_splitRomImpl_cachePreserving + (signDigestLoop digestAttemptLimit secretKey message)) hselected + cases selected with + | none => + exact (Coupled.pure secretKey.parameter table loopState fuel hloopClean + (none, none)).coupledAt loopCache + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + rw [simulateQ_bind] + simp only [romImpl, QueryImpl.simulateQ_add_liftM_right, simulateQ_pure] + apply CoupledAt.bind_probeFree hloopClean + (maskedSignAfterDigest_probeFree secretKey randomness index leaves) + (coupledAt_maskedSignAfterDigest secretKey table loopState fuel loopCache randomness + index leaves hloopClean hloopSynced) + intro signatureState signature signatureCache hsignature + have hsignatureClean : + AdaptiveRevealProbe.tableHits signatureState table = false := + tableHits_false_of_mem_runDetailed_probeFree table loopState signatureState fuel + ((maskedSignAfterDigest secretKey randomness index leaves).run loopCache) + (maskedSignAfterDigest_probeFree secretKey randomness index leaves loopCache) + hloopClean (signature, signatureCache) hsignature + unfold CoupledAt + simp [AdaptiveRevealProbe.runDetailed, projectDetailedCache, hsignatureClean] + +set_option maxRecDepth 10000 in +theorem coupledAt_maskedSigningImpl + (secretKey : SecretKey) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) (message : Message) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced secretKey.parameter table state cache) : + CoupledAt secretKey.parameter table state fuel + (maskedSigningImpl secretKey message) + (simulateQ romImpl (scheme.sign (secretKeyWithFtsTable secretKey table) message)) + cache := by + change CoupledAt secretKey.parameter table state fuel + (maskedSigningImpl secretKey message) + (simulateQ romImpl (sign (secretKeyWithFtsTable secretKey table) message)) cache + rw [← signWithView_fst] + unfold maskedSigningImpl + rw [simulateQ_map, map_eq_bind_pure_comp, map_eq_bind_pure_comp] + apply CoupledAt.bind_probeFree hclean + (maskedSignWithView_probeFree secretKey message) + (coupledAt_maskedSignWithView secretKey table state fuel cache message hclean hsynced) + intro finalState result finalCache hresult + have hfinalClean : AdaptiveRevealProbe.tableHits finalState table = false := + tableHits_false_of_mem_runDetailed_probeFree table state finalState fuel + ((maskedSignWithView secretKey message).run cache) + (maskedSignWithView_probeFree secretKey message cache) hclean + (result, finalCache) hresult + unfold CoupledAt + simp [AdaptiveRevealProbe.runDetailed, projectDetailedCache, hfinalClean] + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeSimulation.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeSimulation.lean new file mode 100644 index 00000000..e1ff51c4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeSimulation.lean @@ -0,0 +1,2169 @@ +import SphincsSecurity.Proof.AdaptiveRevealProbe +import SphincsSecurity.Proof.ExtractFts +import SphincsSecurity.Proof.FewTimeSignerView +import SphincsSecurity.Proof.SigningTrace + +/-! +# Split random-oracle keys for hidden few-time leaves + +Before an unrevealed few-time secret is guessed, its honest leaf-hash input is distinct from every +ordinary hash input available to the adversary. This file builds the lazy split-oracle side of that +argument. Ordinary inputs retain their exact keys, while an internal few-time leaf uses its secret +table coordinate as an opaque key. Both kinds receive lazy and consistent uniform answers. +-/ + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +abbrev Coordinate := Index × FtsTree × FtsLeaf + +noncomputable local instance : Nonempty Coordinate := + ⟨(⟨0, by norm_num [totalHeight]⟩, + ⟨0, by norm_num [ftsTrees]⟩, + ⟨0, by norm_num [ftsTreeHeight]⟩)⟩ + +inductive SplitHashKey where + | ordinary (input : HashInput) + | hiddenLeaf (coordinate : Coordinate) +deriving DecidableEq + +abbrev SplitHashCache := SplitHashKey → Option HashOutput + +def emptySplitHashCache : SplitHashCache := fun _ => none + +noncomputable def splitHashQuery (key : SplitHashKey) : + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) HashOutput := do + let cache ← get + match cache key with + | some output => pure output + | none => + let output ← liftM + (AdaptiveRevealProbe.hashOutputQuery (Coordinate := Coordinate)) + set (Function.update cache key (some output)) + pure output + +noncomputable def ordinaryHashImpl : + QueryImpl HashSpec + (StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate))) := + fun input => splitHashQuery (.ordinary input) + +noncomputable def ordinaryTweakableHash (parameter : PublicParameter) + (domain : HashDomain) (payload : HashInput) : + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) Digest := do + let output ← splitHashQuery (.ordinary (tweakableHashInput parameter domain payload)) + pure (truncateHash output) + +noncomputable def hiddenFtsLeafHash (_parameter : PublicParameter) + (coordinate : Coordinate) : + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) Digest := do + let output ← splitHashQuery (.hiddenLeaf coordinate) + pure (truncateHash output) + +noncomputable def maskedFtsNode (parameter : PublicParameter) (index : Index) + (tree : FtsTree) : Nat → Nat → + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) Digest + | 0, nodeIdx => + hiddenFtsLeafHash parameter (index, tree, ftsLeafOfNat nodeIdx) + | level + 1, nodeIdx => do + let left ← maskedFtsNode parameter index tree level (2 * nodeIdx) + let right ← maskedFtsNode parameter index tree level (2 * nodeIdx + 1) + ordinaryTweakableHash parameter (.ftsNode index tree (level + 1) nodeIdx) + (nodePayload left right) + +noncomputable def maskedFtsKey (parameter : PublicParameter) (index : Index) : + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) Digest := do + let roots ← sequenceFin fun tree => + maskedFtsNode parameter index tree ftsTreeHeight 0 + ordinaryTweakableHash parameter (.ftsRoots index) (ftsRootsPayload roots) + +noncomputable def maskedFtsOpen (parameter : PublicParameter) (index : Index) + (leaves : DigestTree → FtsLeaf) : + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) + (FtsTree → Fin ftsTreeHeight → Digest) := + sequenceFin fun tree => + sequenceFin fun level => + maskedFtsNode parameter index tree level.val + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1) + +noncomputable def revealFtsSecret (parameter : PublicParameter) + (coordinate : Coordinate) : + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) Digest := do + let value ← liftM (AdaptiveRevealProbe.revealQuery coordinate) + let output ← splitHashQuery (.hiddenLeaf coordinate) + let probe : FtsSecretProbe := + ⟨coordinate.1, coordinate.2.1, coordinate.2.2, value⟩ + modify fun cache : SplitHashCache => + Function.update cache (.ordinary (probe.input parameter)) (some output) + pure value + +noncomputable def revealSelectedFtsSecrets (parameter : PublicParameter) (index : Index) + (leaves : DigestTree → FtsLeaf) : + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) (FtsTree → Digest) := + sequenceFin fun tree => + revealFtsSecret parameter (index, tree, leaves (ftsIndexOf tree)) + +noncomputable def probeFtsSecret (probe : FtsSecretProbe) : + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) Unit := + liftM (AdaptiveRevealProbe.probeQuery + (probe.index, probe.tree, probe.leafIdx) probe.candidate) + +noncomputable def decodeProbe? (parameter : PublicParameter) (input : HashInput) : + Option FtsSecretProbe := by + classical + exact if hexists : ∃ probe : FtsSecretProbe, probe.input parameter = input then + some hexists.choose + else none + +theorem decodeProbe?_eq_some_iff (parameter : PublicParameter) (input : HashInput) + (probe : FtsSecretProbe) : + decodeProbe? parameter input = some probe ↔ probe.input parameter = input := by + classical + unfold decodeProbe? + split + · rename_i hexists + constructor + · intro heq + have hprobe : hexists.choose = probe := Option.some.inj heq + rw [← hprobe] + exact hexists.choose_spec + · intro hinput + congr 1 + apply FtsSecretProbe.input_injective parameter + exact hexists.choose_spec.trans hinput.symm + · rename_i hnone + constructor + · simp + · intro hinput + exact (hnone ⟨probe, hinput⟩).elim + +theorem decodeProbe?_eq_none_iff (parameter : PublicParameter) (input : HashInput) : + decodeProbe? parameter input = none ↔ + ∀ probe : FtsSecretProbe, probe.input parameter ≠ input := by + constructor + · intro hnone probe hinput + have hsome := (decodeProbe?_eq_some_iff parameter input probe).2 hinput + rw [hnone] at hsome + simp at hsome + · intro hnone + cases hdecode : decodeProbe? parameter input with + | none => rfl + | some probe => + exact (hnone probe ((decodeProbe?_eq_some_iff parameter input probe).1 hdecode)).elim + +@[simp] theorem decodeProbe?_input (parameter : PublicParameter) (probe : FtsSecretProbe) : + decodeProbe? parameter (probe.input parameter) = some probe := + (decodeProbe?_eq_some_iff parameter (probe.input parameter) probe).2 rfl + +noncomputable def probingHashQuery (parameter : PublicParameter) (input : HashInput) : + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) HashOutput := do + match decodeProbe? parameter input with + | some probe => probeFtsSecret probe + | none => pure () + splitHashQuery (.ordinary input) + +noncomputable def probingHashImpl (parameter : PublicParameter) : + QueryImpl HashSpec + (StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate))) := + fun input => probingHashQuery parameter input + +noncomputable def splitUniformImpl : + QueryImpl unifSpec + (StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate))) := + fun n => liftM (AdaptiveRevealProbe.uniformQuery (Coordinate := Coordinate) n) + +noncomputable def splitRomImpl : + QueryImpl OracleWorld + (StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate))) := + splitUniformImpl + ordinaryHashImpl + +noncomputable def probingRomImpl (parameter : PublicParameter) : + QueryImpl OracleWorld + (StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate))) := + splitUniformImpl + probingHashImpl parameter + +noncomputable def maskedLayerMessage (secretKey : SecretKey) (index : Index) + (lay : Layer) : + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) Digest := + if hbelow : lay.val + 1 < numLayers then + let below : Layer := ⟨lay.val + 1, hbelow⟩ + simulateQ ordinaryHashImpl + (treeRoot secretKey.parameter below (treeIndexAt index below) + (secretKey.otsSecret below (treeIndexAt index below))) + else + maskedFtsKey secretKey.parameter index + +noncomputable def maskedSignLayer (secretKey : SecretKey) (index : Index) + (lay : Layer) : + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) + (Option (Counter × (ChainIndex → Digest) × (Fin maxLayerHeight → Digest))) := do + let tree := treeIndexAt index lay + let leafIdx := leafIndexAt index lay + let message ← maskedLayerMessage secretKey index lay + match ← simulateQ ordinaryHashImpl + (otsSign secretKey.parameter lay tree leafIdx + (secretKey.otsSecret lay tree leafIdx) message) with + | none => pure none + | some (counter, values) => do + let path ← simulateQ ordinaryHashImpl + (treePath secretKey.parameter lay tree (secretKey.otsSecret lay tree) leafIdx) + pure (some (counter, values, path)) + +noncomputable def maskedSignAfterDigest (secretKey : SecretKey) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) (Option Signature) := do + let ftsPath ← maskedFtsOpen secretKey.parameter index leaves + let layers ← sequenceFin fun lay => maskedSignLayer secretKey index lay + match traverseOption layers with + | none => pure none + | some parts => do + let selected ← revealSelectedFtsSecrets secretKey.parameter index leaves + pure (some + { randomness := randomness + ftsSecret := selected + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (parts lay).2.1 + authPath := flattenPaths fun lay => (parts lay).2.2 }) + +noncomputable def maskedSignWithView (secretKey : SecretKey) (message : Message) : + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) + (Option Signature × Option FewTimeView) := do + match ← simulateQ splitRomImpl + (signDigestLoop digestAttemptLimit secretKey message) with + | none => pure (none, none) + | some (randomness, index, leaves) => do + let signature ← maskedSignAfterDigest secretKey randomness index leaves + pure (signature, some (selectedFewTimeView index leaves)) + +noncomputable def maskedSigningImpl (secretKey : SecretKey) : + QueryImpl SigningSpec + (StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate))) := + fun request => Prod.fst <$> maskedSignWithView secretKey request + +noncomputable def maskedExpandedAdversaryImpl (parameter : PublicParameter) + (secretKey : SecretKey) : + QueryImpl (OracleWorld + SigningSpec) + (StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate))) := + probingRomImpl parameter + maskedSigningImpl secretKey + +noncomputable def maskedGameAfterSecrets (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) : + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) Bool := do + let root ← simulateQ ordinaryHashImpl + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree)) + let secretKey : SecretKey := + ⟨parameter, root, otsSecret, fun _index _tree _leafIdx => 0⟩ + let (forgery, log) ← + (simulateQ (QueryImpl.withTraceAppend + (maskedExpandedAdversaryImpl parameter secretKey) signingLogFragment) + (adversary.main ⟨root, parameter⟩)).run + let verified ← simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature) + pure (decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log forgery) && verified) + +def tableProbe (table : Coordinate → Digest) (coordinate : Coordinate) : + FtsSecretProbe := + ⟨coordinate.1, coordinate.2.1, coordinate.2.2, table coordinate⟩ + +def hiddenInput (parameter : PublicParameter) (table : Coordinate → Digest) + (coordinate : Coordinate) : HashInput := + (tableProbe table coordinate).input parameter + +noncomputable def mergedCache (parameter : PublicParameter) + (table : Coordinate → Digest) (cache : SplitHashCache) : QueryCache HashSpec := + fun input => + match decodeProbe? parameter input with + | some probe => + let coordinate : Coordinate := (probe.index, probe.tree, probe.leafIdx) + if probe.candidate = table coordinate then cache (.hiddenLeaf coordinate) + else cache (.ordinary input) + | none => cache (.ordinary input) + +@[simp] theorem mergedCache_empty (parameter : PublicParameter) + (table : Coordinate → Digest) : + mergedCache parameter table emptySplitHashCache = ∅ := by + funext input + unfold mergedCache emptySplitHashCache + split <;> simp + +@[simp] theorem mergedCache_probe_input (parameter : PublicParameter) + (table : Coordinate → Digest) (cache : SplitHashCache) (probe : FtsSecretProbe) : + mergedCache parameter table cache (probe.input parameter) = + let coordinate : Coordinate := (probe.index, probe.tree, probe.leafIdx) + if probe.candidate = table coordinate then cache (.hiddenLeaf coordinate) + else cache (.ordinary (probe.input parameter)) := by + rw [mergedCache, decodeProbe?_input] + +@[simp] theorem mergedCache_hiddenInput (parameter : PublicParameter) + (table : Coordinate → Digest) (cache : SplitHashCache) (coordinate : Coordinate) : + mergedCache parameter table cache (hiddenInput parameter table coordinate) = + cache (.hiddenLeaf coordinate) := by + rw [hiddenInput, mergedCache_probe_input] + simp only [tableProbe] + rfl + +theorem probe_eq_tableProbe_of_candidate (table : Coordinate → Digest) + (probe : FtsSecretProbe) + (hcandidate : probe.candidate = + table (probe.index, probe.tree, probe.leafIdx)) : + probe = tableProbe table (probe.index, probe.tree, probe.leafIdx) := by + cases probe + simp only [tableProbe, FtsSecretProbe.mk.injEq, true_and] + exact hcandidate + +theorem mergedCache_update_hiddenLeaf (parameter : PublicParameter) + (table : Coordinate → Digest) (cache : SplitHashCache) + (coordinate : Coordinate) (output : HashOutput) : + mergedCache parameter table + (Function.update cache (.hiddenLeaf coordinate) (some output)) = + (mergedCache parameter table cache).cacheQuery + (hiddenInput parameter table coordinate) output := by + funext input + by_cases heq : input = hiddenInput parameter table coordinate + · subst input + rw [mergedCache_hiddenInput, Function.update_self, + QueryCache.cacheQuery_self] + · rw [QueryCache.cacheQuery_of_ne _ _ heq] + unfold mergedCache + cases hdecode : decodeProbe? parameter input with + | none => + simp only + rw [Function.update_of_ne] + simp + | some probe => + simp only + let probeCoordinate : Coordinate := (probe.index, probe.tree, probe.leafIdx) + by_cases hcandidate : probe.candidate = table probeCoordinate + · rw [if_pos hcandidate] + have hcandidate' : + probe.candidate = table (probe.index, probe.tree, probe.leafIdx) := + hcandidate + have hcoordinate : probeCoordinate ≠ coordinate := by + intro hsame + apply heq + have hprobe := probe_eq_tableProbe_of_candidate table probe hcandidate + have hinput := (decodeProbe?_eq_some_iff parameter input probe).1 hdecode + have hsame' : (probe.index, probe.tree, probe.leafIdx) = coordinate := hsame + rw [← hinput, hprobe, hiddenInput, hsame'] + rw [Function.update_of_ne (by + intro hkey + exact hcoordinate (SplitHashKey.hiddenLeaf.inj hkey))] + simp [hcandidate'] + · have hcandidate' : + probe.candidate ≠ table (probe.index, probe.tree, probe.leafIdx) := + hcandidate + rw [if_neg hcandidate', Function.update_of_ne (by simp)] + simp [hcandidate'] + +def IsOrdinaryInput (parameter : PublicParameter) (table : Coordinate → Digest) + (input : HashInput) : Prop := + ∀ probe : FtsSecretProbe, decodeProbe? parameter input = some probe → + probe.candidate ≠ table (probe.index, probe.tree, probe.leafIdx) + +theorem isOrdinaryInput_of_decode_none (parameter : PublicParameter) + (table : Coordinate → Digest) (input : HashInput) + (hdecode : decodeProbe? parameter input = none) : + IsOrdinaryInput parameter table input := by + intro probe hsome + rw [hdecode] at hsome + simp at hsome + +theorem isOrdinaryInput_of_decode_miss (parameter : PublicParameter) + (table : Coordinate → Digest) (input : HashInput) (probe : FtsSecretProbe) + (hdecode : decodeProbe? parameter input = some probe) + (hmiss : probe.candidate ≠ table (probe.index, probe.tree, probe.leafIdx)) : + IsOrdinaryInput parameter table input := by + intro other hother + have heq : other = probe := Option.some.inj (hother.symm.trans hdecode) + subst other + exact hmiss + +theorem isOrdinaryInput_of_not_hit (parameter : PublicParameter) + (table : Coordinate → Digest) (input : HashInput) + (hmiss : ∀ probe : FtsSecretProbe, decodeProbe? parameter input = some probe → + table (probe.index, probe.tree, probe.leafIdx) ≠ probe.candidate) : + IsOrdinaryInput parameter table input := by + intro probe hdecode + exact (hmiss probe hdecode).symm + +theorem mergedCache_eq_ordinary_of_isOrdinary (parameter : PublicParameter) + (table : Coordinate → Digest) (cache : SplitHashCache) (input : HashInput) + (hordinary : IsOrdinaryInput parameter table input) : + mergedCache parameter table cache input = cache (.ordinary input) := by + unfold mergedCache + cases hdecode : decodeProbe? parameter input with + | none => rfl + | some probe => + simp only + rw [if_neg (hordinary probe hdecode)] + +theorem mergedCache_update_ordinary (parameter : PublicParameter) + (table : Coordinate → Digest) (cache : SplitHashCache) + (input : HashInput) (output : HashOutput) + (hordinary : IsOrdinaryInput parameter table input) : + mergedCache parameter table + (Function.update cache (.ordinary input) (some output)) = + (mergedCache parameter table cache).cacheQuery input output := by + funext other + by_cases heq : other = input + · subst other + rw [mergedCache_eq_ordinary_of_isOrdinary parameter table _ input hordinary, + Function.update_self, QueryCache.cacheQuery_self] + · rw [QueryCache.cacheQuery_of_ne _ _ heq] + unfold mergedCache + cases hdecode : decodeProbe? parameter other with + | none => + rw [Function.update_of_ne] + intro hkey + exact heq (SplitHashKey.ordinary.inj hkey) + | some probe => + simp only + by_cases hcandidate : + probe.candidate = table (probe.index, probe.tree, probe.leafIdx) + · rw [if_pos hcandidate, Function.update_of_ne (by simp)] + simp [hcandidate] + · rw [if_neg hcandidate, Function.update_of_ne] + · simp [hcandidate] + · intro hkey + exact heq (SplitHashKey.ordinary.inj hkey) + +theorem mergedCache_update_hiddenInput_ordinary + (parameter : PublicParameter) (table : Coordinate → Digest) + (cache : SplitHashCache) (coordinate : Coordinate) (output : HashOutput) : + mergedCache parameter table + (Function.update cache (.ordinary (hiddenInput parameter table coordinate)) + (some output)) = + mergedCache parameter table cache := by + funext input + by_cases heq : input = hiddenInput parameter table coordinate + · subst input + rw [mergedCache_hiddenInput, mergedCache_hiddenInput, + Function.update_of_ne (by simp)] + · unfold mergedCache + cases hdecode : decodeProbe? parameter input with + | none => + rw [Function.update_of_ne] + intro hkey + exact heq (SplitHashKey.ordinary.inj hkey) + | some probe => + simp only + by_cases hcandidate : + probe.candidate = table (probe.index, probe.tree, probe.leafIdx) + · rw [if_pos hcandidate, Function.update_of_ne (by simp)] + simp [hcandidate] + · rw [if_neg hcandidate, Function.update_of_ne] + · simp [hcandidate] + · intro hkey + exact heq (SplitHashKey.ordinary.inj hkey) + +noncomputable def projectDetailedCache (parameter : PublicParameter) (table : Coordinate → Digest) : + AdaptiveRevealProbe.DetailedResult Coordinate (alpha × SplitHashCache) → + Option (alpha × QueryCache HashSpec) + | .stopped _ => none + | .done true _ _ => none + | .done false _ (value, cache) => some (value, mergedCache parameter table cache) + +def RevealedSynced (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (cache : SplitHashCache) : Prop := + ∀ coordinate value, state.revealed coordinate = some value → + value = table coordinate ∧ + ∃ output, cache (.hiddenLeaf coordinate) = some output ∧ + cache (.ordinary (hiddenInput parameter table coordinate)) = some output + +theorem revealedSynced_empty (parameter : PublicParameter) (table : Coordinate → Digest) : + RevealedSynced parameter table AdaptiveRevealProbe.State.empty emptySplitHashCache := by + intro coordinate value hvalue + simp [AdaptiveRevealProbe.State.empty] at hvalue + +theorem IsOrdinaryInput.ne_hiddenInput + {parameter : PublicParameter} {table : Coordinate → Digest} {input : HashInput} + (hordinary : IsOrdinaryInput parameter table input) (coordinate : Coordinate) : + input ≠ hiddenInput parameter table coordinate := by + intro heq + subst input + let probe := tableProbe table coordinate + have hdecode : decodeProbe? parameter (hiddenInput parameter table coordinate) = some probe := by + change decodeProbe? parameter ((tableProbe table coordinate).input parameter) = + some (tableProbe table coordinate) + exact decodeProbe?_input parameter (tableProbe table coordinate) + have hne := hordinary probe hdecode + exact hne rfl + +theorem hiddenInput_injective (parameter : PublicParameter) (table : Coordinate → Digest) : + Function.Injective (hiddenInput parameter table) := by + intro left right heq + have hprobe := FtsSecretProbe.input_injective parameter heq + rcases left with ⟨leftIndex, leftTree, leftLeaf⟩ + rcases right with ⟨rightIndex, rightTree, rightLeaf⟩ + simp only [tableProbe, FtsSecretProbe.mk.injEq] at hprobe + cases hprobe.1 + cases hprobe.2.1 + cases hprobe.2.2.1 + rfl + +theorem RevealedSynced.update_ordinary + {parameter : PublicParameter} {table : Coordinate → Digest} + {state : AdaptiveRevealProbe.State Coordinate} {cache : SplitHashCache} + (hsynced : RevealedSynced parameter table state cache) + (input : HashInput) (output : HashOutput) + (hordinary : IsOrdinaryInput parameter table input) : + RevealedSynced parameter table state + (Function.update cache (.ordinary input) (some output)) := by + intro coordinate value hrevealed + obtain ⟨hvalue, oldOutput, hhidden, hordinaryCache⟩ := + hsynced coordinate value hrevealed + refine ⟨hvalue, oldOutput, ?_, ?_⟩ + · rw [Function.update_of_ne (by simp)] + exact hhidden + · rw [Function.update_of_ne] + · exact hordinaryCache + · intro heq + exact hordinary.ne_hiddenInput coordinate (SplitHashKey.ordinary.inj heq).symm + +theorem RevealedSynced.install + {parameter : PublicParameter} {table : Coordinate → Digest} + {state : AdaptiveRevealProbe.State Coordinate} {cache : SplitHashCache} + (hsynced : RevealedSynced parameter table state cache) + (coordinate : Coordinate) (value : Digest) (output : HashOutput) + (hvalue : value = table coordinate) + (hhidden : cache (.hiddenLeaf coordinate) = some output) : + RevealedSynced parameter table (state.install coordinate value) + (Function.update cache (.ordinary (hiddenInput parameter table coordinate)) + (some output)) := by + intro other otherValue hrevealed + by_cases heq : other = coordinate + · subst other + have hotherValue : otherValue = value := by + have hsome : some value = some otherValue := by + simpa [AdaptiveRevealProbe.State.install] using hrevealed + exact (Option.some.inj hsome).symm + subst otherValue + refine ⟨hvalue, output, ?_, ?_⟩ + · rw [Function.update_of_ne (by simp)] + exact hhidden + · rw [Function.update_self] + · have hrevealedOld : state.revealed other = some otherValue := by + simpa [AdaptiveRevealProbe.State.install, Function.update_of_ne heq] using hrevealed + obtain ⟨hotherValue, oldOutput, hhiddenOld, hordinaryOld⟩ := + hsynced other otherValue hrevealedOld + refine ⟨hotherValue, oldOutput, ?_, ?_⟩ + · rw [Function.update_of_ne (by simp)] + exact hhiddenOld + · rw [Function.update_of_ne] + · exact hordinaryOld + · intro hkey + apply heq + apply hiddenInput_injective parameter table + exact SplitHashKey.ordinary.inj hkey + +def fullSplitCache (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → Digest) : SplitHashCache + | .ordinary input => some (f input) + | .hiddenLeaf coordinate => some (f (hiddenInput parameter table coordinate)) + +@[simp] theorem mergedCache_fullSplitCache (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (table : Coordinate → Digest) : + mergedCache parameter table (fullSplitCache f parameter table) = fun input => some (f input) := by + funext input + unfold mergedCache + cases hdecode : decodeProbe? parameter input with + | none => rfl + | some probe => + simp only + by_cases hcandidate : + probe.candidate = table (probe.index, probe.tree, probe.leafIdx) + · rw [if_pos hcandidate] + have hprobe := probe_eq_tableProbe_of_candidate table probe hcandidate + have hinput := (decodeProbe?_eq_some_iff parameter input probe).1 hdecode + rw [fullSplitCache, hiddenInput, ← hinput, hprobe] + exact rfl + · rw [if_neg hcandidate] + rfl + +theorem splitHashQuery_run_eq (key : SplitHashKey) (cache : SplitHashCache) : + (splitHashQuery key).run cache = + match cache key with + | some output => pure (output, cache) + | none => (AdaptiveRevealProbe.hashOutputQuery (Coordinate := Coordinate)) >>= fun output => + pure (output, Function.update cache key (some output)) := by + cases hlookup : cache key <;> simp [splitHashQuery, hlookup] + +theorem revealFtsSecret_run_eq (parameter : PublicParameter) + (coordinate : Coordinate) (cache : SplitHashCache) : + (revealFtsSecret parameter coordinate).run cache = + AdaptiveRevealProbe.revealQuery coordinate >>= fun value => + (splitHashQuery (.hiddenLeaf coordinate)).run cache >>= fun result => + pure (value, Function.update result.2 + (.ordinary ((⟨coordinate.1, coordinate.2.1, coordinate.2.2, + value⟩ : FtsSecretProbe).input parameter)) (some result.1)) := by + simp [revealFtsSecret, StateT.run_bind] + +theorem runDetailed_revealFtsSecret_hidden + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) (coordinate : Coordinate) (output : HashOutput) + (hrevealed : state.revealed coordinate = none) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hhidden : cache (.hiddenLeaf coordinate) = some output) : + AdaptiveRevealProbe.runDetailed table state fuel + ((revealFtsSecret parameter coordinate).run cache) = + pure (.done false (state.install coordinate (table coordinate)) + (table coordinate, Function.update cache + (.ordinary (hiddenInput parameter table coordinate)) (some output))) := by + rw [revealFtsSecret_run_eq, AdaptiveRevealProbe.revealQuery] + change AdaptiveRevealProbe.runDetailed table state fuel + ((liftM (OracleSpec.query (spec := AdaptiveRevealProbe.World Coordinate) + (.reveal coordinate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Digest) >>= fun value => + (splitHashQuery (.hiddenLeaf coordinate)).run cache >>= fun result => + pure (value, Function.update result.2 + (.ordinary ((⟨coordinate.1, coordinate.2.1, coordinate.2.2, + value⟩ : FtsSecretProbe).input parameter)) (some result.1))) = _ + rw [AdaptiveRevealProbe.runDetailed_reveal_query_bind, hrevealed] + rw [if_neg (AdaptiveRevealProbe.not_mem_pending_of_tableHits_eq_false + state table coordinate hclean)] + rw [splitHashQuery_run_eq, hhidden, pure_bind] + simp only [hiddenInput, tableProbe] + simp [AdaptiveRevealProbe.runDetailed, + AdaptiveRevealProbe.tableHits_install_eq_false state table coordinate + (table coordinate) hclean] + +theorem runDetailed_revealFtsSecret_revealed + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) (coordinate : Coordinate) (value : Digest) + (output : HashOutput) + (hrevealed : state.revealed coordinate = some value) + (hvalue : value = table coordinate) + (hhidden : cache (.hiddenLeaf coordinate) = some output) + (hordinary : cache (.ordinary (hiddenInput parameter table coordinate)) = some output) + (hclean : AdaptiveRevealProbe.tableHits state table = false) : + AdaptiveRevealProbe.runDetailed table state fuel + ((revealFtsSecret parameter coordinate).run cache) = + pure (.done false state (table coordinate, cache)) := by + rw [revealFtsSecret_run_eq, AdaptiveRevealProbe.revealQuery] + change AdaptiveRevealProbe.runDetailed table state fuel + ((liftM (OracleSpec.query (spec := AdaptiveRevealProbe.World Coordinate) + (.reveal coordinate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Digest) >>= fun revealedValue => + (splitHashQuery (.hiddenLeaf coordinate)).run cache >>= fun result => + pure (revealedValue, Function.update result.2 + (.ordinary ((⟨coordinate.1, coordinate.2.1, coordinate.2.2, + revealedValue⟩ : FtsSecretProbe).input parameter)) (some result.1))) = _ + rw [AdaptiveRevealProbe.runDetailed_reveal_query_bind, hrevealed] + simp only + rw [splitHashQuery_run_eq, hhidden] + simp only [pure_bind] + simp only [hvalue] + have hupdate : Function.update cache + (.ordinary ((⟨coordinate.1, coordinate.2.1, coordinate.2.2, + table coordinate⟩ : FtsSecretProbe).input parameter)) (some output) = cache := by + have hordinary' : cache + (.ordinary ((⟨coordinate.1, coordinate.2.1, coordinate.2.2, + table coordinate⟩ : FtsSecretProbe).input parameter)) = some output := by + simpa only [hiddenInput, tableProbe] using hordinary + conv_lhs => rw [← hordinary'] + exact Function.update_eq_self _ _ + rw [hupdate] + simp [AdaptiveRevealProbe.runDetailed, hclean] + +theorem runDetailed_splitHashQuery_hiddenLeaf + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) (coordinate : Coordinate) + (hclean : AdaptiveRevealProbe.tableHits state table = false) : + projectDetailedCache parameter table <$> + AdaptiveRevealProbe.runDetailed table state fuel + ((splitHashQuery (.hiddenLeaf coordinate)).run cache) = + some <$> (randomOracle (hiddenInput parameter table coordinate)).run + (mergedCache parameter table cache) := by + rw [splitHashQuery_run_eq] + cases hlookup : cache (.hiddenLeaf coordinate) with + | some output => + have hmerged : mergedCache parameter table cache + (hiddenInput parameter table coordinate) = some output := by + rw [mergedCache_hiddenInput, hlookup] + rw [OracleSpec.randomOracle, QueryImpl.withCaching_run_some _ hmerged] + simp [AdaptiveRevealProbe.runDetailed, projectDetailedCache, hclean] + | none => + have hmerged : mergedCache parameter table cache + (hiddenInput parameter table coordinate) = none := by + rw [mergedCache_hiddenInput, hlookup] + rw [OracleSpec.randomOracle, QueryImpl.withCaching_run_none _ hmerged, + AdaptiveRevealProbe.hashOutputQuery, + AdaptiveRevealProbe.runDetailed_hashOutput_query_bind] + have hsampler : + uniformSampleImpl (spec := HashSpec) + (hiddenInput parameter table coordinate) = + AdaptiveRevealProbe.sampleHashOutput := by + unfold AdaptiveRevealProbe.sampleHashOutput uniformSampleImpl + rfl + let finish := fun output : HashOutput => + (output, (mergedCache parameter table cache).cacheQuery + (hiddenInput parameter table coordinate) output) + calc + projectDetailedCache parameter table <$> + (do + let output ← liftM AdaptiveRevealProbe.sampleHashOutput + AdaptiveRevealProbe.runDetailed table state fuel + (pure (output, Function.update cache (.hiddenLeaf coordinate) (some output)))) = + some <$> finish <$> AdaptiveRevealProbe.sampleHashOutput := by + simp only [AdaptiveRevealProbe.runDetailed, + OracleComp.construct_pure, hclean, map_eq_bind_pure_comp, bind_assoc, + pure_bind] + apply bind_congr + intro output + simp only [Function.comp_apply, projectDetailedCache, pure_bind, finish] + rw [mergedCache_update_hiddenLeaf] + _ = some <$> finish <$> + uniformSampleImpl (spec := HashSpec) + (hiddenInput parameter table coordinate) := by + rw [hsampler] + +theorem runDetailed_splitHashQuery_ordinary + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) (input : HashInput) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hordinary : IsOrdinaryInput parameter table input) : + projectDetailedCache parameter table <$> + AdaptiveRevealProbe.runDetailed table state fuel + ((splitHashQuery (.ordinary input)).run cache) = + some <$> (randomOracle input).run (mergedCache parameter table cache) := by + rw [splitHashQuery_run_eq] + cases hlookup : cache (.ordinary input) with + | some output => + have hmerged : mergedCache parameter table cache input = some output := by + rw [mergedCache_eq_ordinary_of_isOrdinary parameter table cache input hordinary, + hlookup] + rw [OracleSpec.randomOracle, QueryImpl.withCaching_run_some _ hmerged] + simp [AdaptiveRevealProbe.runDetailed, projectDetailedCache, hclean] + | none => + have hmerged : mergedCache parameter table cache input = none := by + rw [mergedCache_eq_ordinary_of_isOrdinary parameter table cache input hordinary, + hlookup] + rw [OracleSpec.randomOracle, QueryImpl.withCaching_run_none _ hmerged, + AdaptiveRevealProbe.hashOutputQuery, + AdaptiveRevealProbe.runDetailed_hashOutput_query_bind] + have hsampler : + uniformSampleImpl (spec := HashSpec) input = + AdaptiveRevealProbe.sampleHashOutput := by + unfold AdaptiveRevealProbe.sampleHashOutput uniformSampleImpl + rfl + let finish := fun output : HashOutput => + (output, (mergedCache parameter table cache).cacheQuery input output) + calc + projectDetailedCache parameter table <$> + (do + let output ← liftM AdaptiveRevealProbe.sampleHashOutput + AdaptiveRevealProbe.runDetailed table state fuel + (pure (output, Function.update cache (.ordinary input) (some output)))) = + some <$> finish <$> AdaptiveRevealProbe.sampleHashOutput := by + simp only [AdaptiveRevealProbe.runDetailed, OracleComp.construct_pure, + hclean, map_eq_bind_pure_comp, bind_assoc, pure_bind] + apply bind_congr + intro output + simp only [Function.comp_apply, projectDetailedCache, pure_bind, finish] + rw [mergedCache_update_ordinary parameter table cache input output hordinary] + _ = some <$> finish <$> uniformSampleImpl (spec := HashSpec) input := by + rw [hsampler] + +theorem runDetailed_ordinaryTweakableHash + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) (domain : HashDomain) (payload : HashInput) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hordinary : IsOrdinaryInput parameter table + (tweakableHashInput parameter domain payload)) : + projectDetailedCache parameter table <$> + AdaptiveRevealProbe.runDetailed table state fuel + ((ordinaryTweakableHash parameter domain payload).run cache) = + some <$> (simulateQ (randomOracle : QueryImpl HashSpec _) + (tweakableHash parameter domain payload)).run + (mergedCache parameter table cache) := by + let input := tweakableHashInput parameter domain payload + have hmergedEq : mergedCache parameter table cache input = cache (.ordinary input) := + mergedCache_eq_ordinary_of_isOrdinary parameter table cache input hordinary + have hqueryRun : + (simulateQ (randomOracle : QueryImpl HashSpec _) + (oracleHash input)).run (mergedCache parameter table cache) = + (randomOracle input).run (mergedCache parameter table cache) := by + change (simulateQ (randomOracle : QueryImpl HashSpec _) + (liftM (HashSpec.query input))).run (mergedCache parameter table cache) = _ + rw [simulateQ_spec_query] + unfold ordinaryTweakableHash tweakableHash + rw [StateT.run_bind, splitHashQuery_run_eq, + simulateQ_bind, StateT.run_bind, hqueryRun] + simp only [simulateQ_pure, StateT.run_pure] + cases hlookup : cache (.ordinary input) with + | some output => + have hmerged : mergedCache parameter table cache input = some output := by + rw [hmergedEq, hlookup] + rw [OracleSpec.randomOracle, QueryImpl.withCaching_run_some _ hmerged] + simp [AdaptiveRevealProbe.runDetailed, projectDetailedCache, hclean, input] + | none => + have hmerged : mergedCache parameter table cache input = none := by + rw [hmergedEq, hlookup] + rw [OracleSpec.randomOracle, QueryImpl.withCaching_run_none _ hmerged] + change projectDetailedCache parameter table <$> + AdaptiveRevealProbe.runDetailed table state fuel + (AdaptiveRevealProbe.hashOutputQuery (Coordinate := Coordinate) >>= fun output => + pure (truncateHash output, + Function.update cache (.ordinary input) (some output))) = _ + rw [AdaptiveRevealProbe.hashOutputQuery, + AdaptiveRevealProbe.runDetailed_hashOutput_query_bind] + have hsampler : uniformSampleImpl (spec := HashSpec) input = + AdaptiveRevealProbe.sampleHashOutput := by + unfold AdaptiveRevealProbe.sampleHashOutput uniformSampleImpl + rfl + let finish := fun output : HashOutput => + (truncateHash output, + (mergedCache parameter table cache).cacheQuery input output) + calc + projectDetailedCache parameter table <$> + (do + let output ← liftM AdaptiveRevealProbe.sampleHashOutput + AdaptiveRevealProbe.runDetailed table state fuel + (pure (truncateHash output, + Function.update cache (.ordinary input) (some output)))) = + some <$> finish <$> AdaptiveRevealProbe.sampleHashOutput := by + simp only [AdaptiveRevealProbe.runDetailed, OracleComp.construct_pure, + hclean, map_eq_bind_pure_comp, bind_assoc, pure_bind] + apply bind_congr + intro output + simp only [Function.comp_apply, projectDetailedCache, pure_bind, finish] + rw [mergedCache_update_ordinary parameter table cache input output hordinary] + _ = some <$> finish <$> uniformSampleImpl (spec := HashSpec) input := by + rw [hsampler] + _ = some <$> (do + let result ← (fun output : HashOutput => + (output, (mergedCache parameter table cache).cacheQuery input output)) <$> + uniformSampleImpl (spec := HashSpec) input + pure (truncateHash result.1, result.2)) := by + simp [map_eq_bind_pure_comp, finish] + +theorem runDetailed_hiddenFtsLeafHash + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) (coordinate : Coordinate) + (hclean : AdaptiveRevealProbe.tableHits state table = false) : + projectDetailedCache parameter table <$> + AdaptiveRevealProbe.runDetailed table state fuel + ((hiddenFtsLeafHash parameter coordinate).run cache) = + some <$> (simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsLeafHash parameter coordinate.1 coordinate.2.1 coordinate.2.2 + (table coordinate))).run (mergedCache parameter table cache) := by + let input := hiddenInput parameter table coordinate + have hqueryRun : + (simulateQ (randomOracle : QueryImpl HashSpec _) + (oracleHash input)).run (mergedCache parameter table cache) = + (randomOracle input).run (mergedCache parameter table cache) := by + change (simulateQ (randomOracle : QueryImpl HashSpec _) + (liftM (HashSpec.query input))).run (mergedCache parameter table cache) = _ + rw [simulateQ_spec_query] + have hinput : tweakableHashInput parameter + (.ftsLeaf coordinate.1 coordinate.2.1 coordinate.2.2) + (digestBytes (table coordinate)) = input := by + rfl + unfold hiddenFtsLeafHash ftsLeafHash tweakableHash + rw [StateT.run_bind, splitHashQuery_run_eq, + simulateQ_bind, StateT.run_bind] + change _ = some <$> (do + let result ← (simulateQ (randomOracle : QueryImpl HashSpec _) + (oracleHash input)).run (mergedCache parameter table cache) + pure (truncateHash result.1, result.2)) + rw [hqueryRun] + simp only [StateT.run_pure] + cases hlookup : cache (.hiddenLeaf coordinate) with + | some output => + have hmerged : mergedCache parameter table cache input = some output := by + change mergedCache parameter table cache + (hiddenInput parameter table coordinate) = some output + rw [mergedCache_hiddenInput, hlookup] + rw [OracleSpec.randomOracle, QueryImpl.withCaching_run_some _ hmerged] + simp [AdaptiveRevealProbe.runDetailed, projectDetailedCache, hclean, input] + | none => + have hmerged : mergedCache parameter table cache input = none := by + change mergedCache parameter table cache + (hiddenInput parameter table coordinate) = none + rw [mergedCache_hiddenInput, hlookup] + rw [OracleSpec.randomOracle, QueryImpl.withCaching_run_none _ hmerged] + change projectDetailedCache parameter table <$> + AdaptiveRevealProbe.runDetailed table state fuel + (AdaptiveRevealProbe.hashOutputQuery (Coordinate := Coordinate) >>= fun output => + pure (truncateHash output, + Function.update cache (.hiddenLeaf coordinate) (some output))) = _ + rw [AdaptiveRevealProbe.hashOutputQuery, + AdaptiveRevealProbe.runDetailed_hashOutput_query_bind] + have hsampler : uniformSampleImpl (spec := HashSpec) input = + AdaptiveRevealProbe.sampleHashOutput := by + unfold AdaptiveRevealProbe.sampleHashOutput uniformSampleImpl + rfl + let finish := fun output : HashOutput => + (truncateHash output, + (mergedCache parameter table cache).cacheQuery input output) + calc + projectDetailedCache parameter table <$> + (do + let output ← liftM AdaptiveRevealProbe.sampleHashOutput + AdaptiveRevealProbe.runDetailed table state fuel + (pure (truncateHash output, + Function.update cache (.hiddenLeaf coordinate) (some output)))) = + some <$> finish <$> AdaptiveRevealProbe.sampleHashOutput := by + simp only [AdaptiveRevealProbe.runDetailed, OracleComp.construct_pure, + hclean, map_eq_bind_pure_comp, bind_assoc, pure_bind] + apply bind_congr + intro output + simp only [Function.comp_apply, projectDetailedCache, pure_bind, finish] + rw [mergedCache_update_hiddenLeaf] + _ = some <$> finish <$> uniformSampleImpl (spec := HashSpec) input := by + rw [hsampler] + _ = some <$> (do + let result ← (fun output : HashOutput => + (output, (mergedCache parameter table cache).cacheQuery input output)) <$> + uniformSampleImpl (spec := HashSpec) input + pure (truncateHash result.1, result.2)) := by + simp [map_eq_bind_pure_comp, finish] + +@[simp] theorem splitHashQuery_run_fullSplitCache + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → Digest) (key : SplitHashKey) : + (splitHashQuery key).run (fullSplitCache f parameter table) = + pure ((match key with + | .ordinary input => f input + | .hiddenLeaf coordinate => f (hiddenInput parameter table coordinate)), + fullSplitCache f parameter table) := by + rw [splitHashQuery_run_eq] + cases key <;> simp [fullSplitCache] + +@[simp] theorem splitHashQuery_run'_fullSplitCache + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → Digest) (key : SplitHashKey) : + (splitHashQuery key).run' (fullSplitCache f parameter table) = + pure (match key with + | .ordinary input => f input + | .hiddenLeaf coordinate => f (hiddenInput parameter table coordinate)) := by + rw [StateT.run'_eq, splitHashQuery_run_eq] + cases key <;> simp [fullSplitCache] + +@[simp] theorem ordinaryTweakableHash_run'_fullSplitCache + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → Digest) (domain : HashDomain) (payload : HashInput) : + (ordinaryTweakableHash parameter domain payload).run' + (fullSplitCache f parameter table) = + pure (truncateHash (f (tweakableHashInput parameter domain payload))) := by + rw [StateT.run'_eq] + change ((fun a => truncateHash a.1) <$> + (splitHashQuery (.ordinary (tweakableHashInput parameter domain payload))).run + (fullSplitCache f parameter table)) = _ + rw [splitHashQuery_run_eq] + simp [fullSplitCache] + +@[simp] theorem ordinaryTweakableHash_run_fullSplitCache + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → Digest) (domain : HashDomain) (payload : HashInput) : + (ordinaryTweakableHash parameter domain payload).run + (fullSplitCache f parameter table) = + pure (truncateHash (f (tweakableHashInput parameter domain payload)), + fullSplitCache f parameter table) := by + simp [ordinaryTweakableHash] + +@[simp] theorem hiddenFtsLeafHash_run'_fullSplitCache + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → Digest) (coordinate : Coordinate) : + (hiddenFtsLeafHash parameter coordinate).run' + (fullSplitCache f parameter table) = + pure (truncateHash (f (hiddenInput parameter table coordinate))) := by + rw [StateT.run'_eq] + change ((fun a => truncateHash a.1) <$> + (splitHashQuery (.hiddenLeaf coordinate)).run + (fullSplitCache f parameter table)) = _ + rw [splitHashQuery_run_eq] + simp [fullSplitCache] + +@[simp] theorem hiddenFtsLeafHash_run_fullSplitCache + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → Digest) (coordinate : Coordinate) : + (hiddenFtsLeafHash parameter coordinate).run + (fullSplitCache f parameter table) = + pure (truncateHash (f (hiddenInput parameter table coordinate)), + fullSplitCache f parameter table) := by + simp [hiddenFtsLeafHash] + +theorem maskedFtsNode_run_fullSplitCache + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → Digest) (index : Index) (tree : FtsTree) + (level nodeIdx : Nat) : + (maskedFtsNode parameter index tree level nodeIdx).run + (fullSplitCache f parameter table) = + pure (honestFtsNode f parameter index tree + (fun leafIdx => table (index, tree, leafIdx)) level nodeIdx, + fullSplitCache f parameter table) := by + induction level generalizing nodeIdx with + | zero => + rw [maskedFtsNode] + simp only [hiddenFtsLeafHash_run_fullSplitCache] + congr 2 + simp only [honestFtsNode, ftsNode_zero_eq, ftsLeafHash, eval_tweakableHash] + rfl + | succ level ih => + rw [maskedFtsNode, StateT.run_bind, ih, pure_bind, + StateT.run_bind, ih, pure_bind, + ordinaryTweakableHash_run_fullSplitCache] + congr 2 + exact (honestFtsNode_succ f parameter index tree + (fun leafIdx => table (index, tree, leafIdx)) level nodeIdx).symm + +theorem sequenceFin_run_of_run_eq_pure {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha) + (values : Fin n → alpha) (cache : SplitHashCache) + (hrun : ∀ position, (computation position).run cache = pure (values position, cache)) : + (sequenceFin computation).run cache = pure (values, cache) := by + induction n with + | zero => + rw [sequenceFin, StateT.run_pure] + congr 2 + funext position + exact Fin.elim0 position + | succ n ih => + rw [sequenceFin, StateT.run_bind, hrun 0, pure_bind, + StateT.run_bind, + ih (fun position => computation position.succ) + (fun position => values position.succ) + (fun position => hrun position.succ), + pure_bind, StateT.run_pure] + congr 2 + funext position + cases position using Fin.cases <;> rfl + +theorem maskedFtsKey_run_fullSplitCache + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → Digest) (index : Index) : + (maskedFtsKey parameter index).run (fullSplitCache f parameter table) = + pure (evalWithAnswerFn f + (ftsKey parameter index (fun tree leafIdx => table (index, tree, leafIdx))), + fullSplitCache f parameter table) := by + unfold maskedFtsKey + rw [StateT.run_bind, + sequenceFin_run_of_run_eq_pure + (values := fun tree => honestFtsNode f parameter index tree + (fun leafIdx => table (index, tree, leafIdx)) ftsTreeHeight 0) + (hrun := fun tree => maskedFtsNode_run_fullSplitCache f parameter table index tree + ftsTreeHeight 0), + pure_bind, ordinaryTweakableHash_run_fullSplitCache] + congr 2 + simp only [ftsKey, evalWithAnswerFn_bind, evalWithAnswerFn_sequenceFin, + eval_tweakableHash, honestFtsNode] + +theorem maskedFtsOpen_run_fullSplitCache + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → Digest) (index : Index) + (leaves : DigestTree → FtsLeaf) : + (maskedFtsOpen parameter index leaves).run (fullSplitCache f parameter table) = + pure (evalWithAnswerFn f + (ftsOpen parameter index leaves + (fun tree leafIdx => table (index, tree, leafIdx))), + fullSplitCache f parameter table) := by + unfold maskedFtsOpen + rw [sequenceFin_run_of_run_eq_pure + (values := fun tree level => honestFtsNode f parameter index tree + (fun leafIdx => table (index, tree, leafIdx)) level.val + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1)) + (hrun := fun tree => sequenceFin_run_of_run_eq_pure + (values := fun level => honestFtsNode f parameter index tree + (fun leafIdx => table (index, tree, leafIdx)) level.val + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1)) + (hrun := fun level => maskedFtsNode_run_fullSplitCache f parameter table index tree + level.val (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1)))] + congr 2 + simp only [ftsOpen, evalWithAnswerFn_sequenceFin, honestFtsNode] + +theorem splitHashQuery_run_isProbeBound (key : SplitHashKey) (cache : SplitHashCache) + (fuel : Nat) : + ((splitHashQuery key).run cache).IsQueryBoundP + (AdaptiveRevealProbe.IsProbe (Coordinate := Coordinate)) fuel := by + rw [splitHashQuery_run_eq] + cases hlookup : cache key with + | some output => simp + | none => + change (((fun output : HashOutput => + (output, Function.update cache key (some output))) <$> + AdaptiveRevealProbe.hashOutputQuery (Coordinate := Coordinate)).IsQueryBoundP + (AdaptiveRevealProbe.IsProbe (Coordinate := Coordinate)) fuel) + rw [isQueryBoundP_map_iff] + exact AdaptiveRevealProbe.hashOutputQuery_isProbeBound + (Coordinate := Coordinate) fuel + +theorem splitHashQuery_run'_isProbeBound (key : SplitHashKey) (cache : SplitHashCache) + (fuel : Nat) : + ((splitHashQuery key).run' cache).IsQueryBoundP + (AdaptiveRevealProbe.IsProbe (Coordinate := Coordinate)) fuel := by + rw [StateT.run'_eq, isQueryBoundP_map_iff] + exact splitHashQuery_run_isProbeBound key cache fuel + +theorem probingHashQuery_run_eq (parameter : PublicParameter) (input : HashInput) + (cache : SplitHashCache) : + (probingHashQuery parameter input).run cache = + match decodeProbe? parameter input with + | some probe => + AdaptiveRevealProbe.probeQuery + (probe.index, probe.tree, probe.leafIdx) probe.candidate >>= fun _ => + (splitHashQuery (.ordinary input)).run cache + | none => (splitHashQuery (.ordinary input)).run cache := by + cases hdecode : decodeProbe? parameter input <;> + simp [probingHashQuery, probeFtsSecret, hdecode] + +theorem runDetailed_probingHashQuery_hidden_miss + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (remaining : Nat) + (cache : SplitHashCache) (input : HashInput) (probe : FtsSecretProbe) + (hdecode : decodeProbe? parameter input = some probe) + (hrevealed : state.revealed (probe.index, probe.tree, probe.leafIdx) = none) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hmiss : table (probe.index, probe.tree, probe.leafIdx) ≠ probe.candidate) : + projectDetailedCache parameter table <$> + AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((probingHashQuery parameter input).run cache) = + some <$> (randomOracle input).run (mergedCache parameter table cache) := by + rw [probingHashQuery_run_eq, hdecode] + change projectDetailedCache parameter table <$> + AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((liftM (OracleSpec.query + (spec := AdaptiveRevealProbe.World Coordinate) + (.probe (probe.index, probe.tree, probe.leafIdx) probe.candidate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Unit) >>= fun _ => + (splitHashQuery (.ordinary input)).run cache) = _ + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind, hrevealed] + exact runDetailed_splitHashQuery_ordinary parameter table + (state.addPending (probe.index, probe.tree, probe.leafIdx) probe.candidate) + remaining cache input + (AdaptiveRevealProbe.tableHits_addPending_eq_false state table + (probe.index, probe.tree, probe.leafIdx) probe.candidate hclean hmiss) + (isOrdinaryInput_of_decode_miss parameter table input probe hdecode hmiss.symm) + +theorem runDetailed_probingHashQuery_decode_none + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) (input : HashInput) + (hdecode : decodeProbe? parameter input = none) + (hclean : AdaptiveRevealProbe.tableHits state table = false) : + projectDetailedCache parameter table <$> + AdaptiveRevealProbe.runDetailed table state fuel + ((probingHashQuery parameter input).run cache) = + some <$> (randomOracle input).run (mergedCache parameter table cache) := by + rw [probingHashQuery_run_eq, hdecode] + exact runDetailed_splitHashQuery_ordinary parameter table state fuel cache input hclean + (isOrdinaryInput_of_decode_none parameter table input hdecode) + +theorem runDetailed_probingHashQuery_revealed_miss + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (remaining : Nat) + (cache : SplitHashCache) (input : HashInput) (probe : FtsSecretProbe) + (hdecode : decodeProbe? parameter input = some probe) + (value : Digest) + (hrevealed : state.revealed (probe.index, probe.tree, probe.leafIdx) = some value) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hmiss : table (probe.index, probe.tree, probe.leafIdx) ≠ probe.candidate) : + projectDetailedCache parameter table <$> + AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((probingHashQuery parameter input).run cache) = + some <$> (randomOracle input).run (mergedCache parameter table cache) := by + rw [probingHashQuery_run_eq, hdecode] + change projectDetailedCache parameter table <$> + AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((liftM (OracleSpec.query + (spec := AdaptiveRevealProbe.World Coordinate) + (.probe (probe.index, probe.tree, probe.leafIdx) probe.candidate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Unit) >>= fun _ => + (splitHashQuery (.ordinary input)).run cache) = _ + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind, hrevealed] + exact runDetailed_splitHashQuery_ordinary parameter table state remaining cache input hclean + (isOrdinaryInput_of_decode_miss parameter table input probe hdecode hmiss.symm) + +theorem runDetailed_probingHashQuery_revealed_hit + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (remaining : Nat) + (cache : SplitHashCache) (input : HashInput) (probe : FtsSecretProbe) + (hdecode : decodeProbe? parameter input = some probe) + (value : Digest) + (hrevealed : state.revealed (probe.index, probe.tree, probe.leafIdx) = some value) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hhit : table (probe.index, probe.tree, probe.leafIdx) = probe.candidate) + (hsynced : RevealedSynced parameter table state cache) : + projectDetailedCache parameter table <$> + AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((probingHashQuery parameter input).run cache) = + some <$> (randomOracle input).run (mergedCache parameter table cache) := by + let coordinate : Coordinate := (probe.index, probe.tree, probe.leafIdx) + have hprobe : probe = tableProbe table coordinate := + probe_eq_tableProbe_of_candidate table probe hhit.symm + have hinput : input = hiddenInput parameter table coordinate := by + have hprobeInput := (decodeProbe?_eq_some_iff parameter input probe).1 hdecode + rw [hprobe] at hprobeInput + exact hprobeInput.symm + obtain ⟨hvalue, output, hhidden, hordinary⟩ := + hsynced coordinate value (by simpa only [coordinate] using hrevealed) + rw [probingHashQuery_run_eq, hdecode] + change projectDetailedCache parameter table <$> + AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((liftM (OracleSpec.query + (spec := AdaptiveRevealProbe.World Coordinate) + (.probe coordinate probe.candidate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Unit) >>= fun _ => + (splitHashQuery (.ordinary input)).run cache) = _ + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind] + simp only [coordinate, hrevealed] + have hmerged : mergedCache parameter table cache + (hiddenInput parameter table coordinate) = some output := by + rw [mergedCache_hiddenInput, hhidden] + rw [splitHashQuery_run_eq, hinput, hordinary, + OracleSpec.randomOracle, QueryImpl.withCaching_run_some _ hmerged] + simp [AdaptiveRevealProbe.runDetailed, projectDetailedCache, hclean] + +theorem runDetailed_probingHashQuery_hidden_hit + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (remaining : Nat) + (cache : SplitHashCache) (input : HashInput) (probe : FtsSecretProbe) + (hdecode : decodeProbe? parameter input = some probe) + (hrevealed : state.revealed (probe.index, probe.tree, probe.leafIdx) = none) + (hhit : table (probe.index, probe.tree, probe.leafIdx) = probe.candidate) + (result : AdaptiveRevealProbe.DetailedResult Coordinate + (HashOutput × SplitHashCache)) + (hresult : result ∈ support + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((probingHashQuery parameter input).run cache))) : + result.hit = true := by + rw [probingHashQuery_run_eq, hdecode] at hresult + change result ∈ support (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((liftM (OracleSpec.query + (spec := AdaptiveRevealProbe.World Coordinate) + (.probe (probe.index, probe.tree, probe.leafIdx) probe.candidate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Unit) >>= fun _ => + (splitHashQuery (.ordinary input)).run cache)) at hresult + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind, hrevealed, + splitHashQuery_run_eq] at hresult + have htableHits := AdaptiveRevealProbe.tableHits_addPending_eq_true state table + (probe.index, probe.tree, probe.leafIdx) probe.candidate hhit + cases hlookup : cache (.ordinary input) with + | some output => + simp [hlookup, AdaptiveRevealProbe.runDetailed, htableHits] at hresult + subst result + rfl + | none => + simp only [hlookup] at hresult + rw [AdaptiveRevealProbe.hashOutputQuery, + AdaptiveRevealProbe.runDetailed_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hresult⟩ := hresult + simp [AdaptiveRevealProbe.runDetailed, htableHits] at hresult + subst result + rfl + +theorem probingHashQuery_run_isProbeBound (parameter : PublicParameter) + (input : HashInput) (cache : SplitHashCache) : + ((probingHashQuery parameter input).run cache).IsQueryBoundP + (AdaptiveRevealProbe.IsProbe (Coordinate := Coordinate)) 1 := by + rw [probingHashQuery_run_eq] + cases hdecode : decodeProbe? parameter input with + | none => exact splitHashQuery_run_isProbeBound (.ordinary input) cache 1 + | some probe => + change ((AdaptiveRevealProbe.probeQuery + (probe.index, probe.tree, probe.leafIdx) probe.candidate >>= fun _ => + (splitHashQuery (.ordinary input)).run cache).IsQueryBoundP + (AdaptiveRevealProbe.IsProbe (Coordinate := Coordinate)) 1) + have hbound := isQueryBoundP_bind (n := 1) (m := 0) + (AdaptiveRevealProbe.probeQuery_isProbeBound + (probe.index, probe.tree, probe.leafIdx) probe.candidate) + (fun _ _ => splitHashQuery_run_isProbeBound (.ordinary input) cache 0) + simpa using hbound + +theorem probingHashQuery_run'_isProbeBound (parameter : PublicParameter) + (input : HashInput) (cache : SplitHashCache) : + ((probingHashQuery parameter input).run' cache).IsQueryBoundP + (AdaptiveRevealProbe.IsProbe (Coordinate := Coordinate)) 1 := by + rw [StateT.run'_eq, isQueryBoundP_map_iff] + exact probingHashQuery_run_isProbeBound parameter input cache + +theorem simulateQ_probingHashImpl_run_isProbeBound (parameter : PublicParameter) + (computation : OracleComp HashSpec alpha) (q : Nat) + (hbound : computation.IsQueryBoundP (fun _ => True) q) + (cache : SplitHashCache) : + ((simulateQ (probingHashImpl parameter) computation).run cache).IsQueryBoundP + (AdaptiveRevealProbe.IsProbe (Coordinate := Coordinate)) q := by + apply hbound.simulateQ_run_StateT_of_step + (q := AdaptiveRevealProbe.IsProbe (Coordinate := Coordinate)) + intro input workingCache + change ((probingHashQuery parameter input).run workingCache).IsQueryBoundP + (AdaptiveRevealProbe.IsProbe (Coordinate := Coordinate)) 1 + exact probingHashQuery_run_isProbeBound parameter input workingCache + +theorem simulateQ_probingHashImpl_run'_isProbeBound (parameter : PublicParameter) + (computation : OracleComp HashSpec alpha) (q : Nat) + (hbound : computation.IsQueryBoundP (fun _ => True) q) + (cache : SplitHashCache) : + ((simulateQ (probingHashImpl parameter) computation).run' cache).IsQueryBoundP + (AdaptiveRevealProbe.IsProbe (Coordinate := Coordinate)) q := by + rw [StateT.run'_eq, isQueryBoundP_map_iff] + exact simulateQ_probingHashImpl_run_isProbeBound parameter computation q hbound cache + +theorem probEvent_probingHashExperiment_le (parameter : PublicParameter) + (computation : OracleComp HashSpec alpha) (q : Nat) + (hbound : computation.IsQueryBoundP (fun _ => True) q) : + Pr[fun hit : Bool => hit = true | + AdaptiveRevealProbe.experiment + (AdaptiveRevealProbe.State.empty : AdaptiveRevealProbe.State Coordinate) q + ((simulateQ (probingHashImpl parameter) computation).run' + emptySplitHashCache)] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply AdaptiveRevealProbe.experiment_empty_probability_le + exact simulateQ_probingHashImpl_run'_isProbeBound parameter computation q hbound + emptySplitHashCache + +def ProbeFree + (computation : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha) : Prop := + ∀ cache, (computation.run cache).IsQueryBoundP + (AdaptiveRevealProbe.IsProbe (Coordinate := Coordinate)) 0 + +theorem ProbeFree.pure (value : alpha) : + ProbeFree (pure value : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha) := by + intro cache + simp + +theorem ProbeFree.modify (update : SplitHashCache → SplitHashCache) : + ProbeFree (modify update : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) Unit) := by + intro cache + simp + +theorem ProbeFree.bind + {left : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) beta} + (hleft : ProbeFree left) (hnext : ∀ value, ProbeFree (next value)) : + ProbeFree (left >>= next) := by + intro cache + rw [StateT.run_bind] + have hbound := isQueryBoundP_bind (n := 0) (m := 0) (hleft cache) + (fun result _ => hnext result.1 result.2) + simpa using hbound + +theorem ProbeFree.map + {computation : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha} + (hcomputation : ProbeFree computation) (transform : alpha → beta) : + ProbeFree (transform <$> computation) := by + rw [map_eq_bind_pure_comp] + exact hcomputation.bind fun value => ProbeFree.pure (transform value) + +def StateFree + (computation : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha) : Prop := + ∀ cache, (computation.run cache).IsQueryBoundP + (AdaptiveRevealProbe.IsStateful (Coordinate := Coordinate)) 0 + +theorem StateFree.pure (value : alpha) : + StateFree (pure value : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha) := by + intro cache + simp + +theorem StateFree.bind + {left : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) beta} + (hleft : StateFree left) (hnext : ∀ value, StateFree (next value)) : + StateFree (left >>= next) := by + intro cache + rw [StateT.run_bind] + have hbound := isQueryBoundP_bind (n := 0) (m := 0) (hleft cache) + (fun result _ => hnext result.1 result.2) + simpa using hbound + +theorem StateFree.map + {computation : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha} + (hcomputation : StateFree computation) (transform : alpha → beta) : + StateFree (transform <$> computation) := by + rw [map_eq_bind_pure_comp] + exact hcomputation.bind fun value => StateFree.pure (transform value) + +theorem splitHashQuery_stateFree (key : SplitHashKey) : + StateFree (splitHashQuery key) := by + intro cache + rw [splitHashQuery_run_eq] + cases hlookup : cache key with + | some output => simp + | none => + change (AdaptiveRevealProbe.hashOutputQuery (Coordinate := Coordinate) >>= fun output => + pure (output, Function.update cache key (some output))).IsQueryBoundP + (AdaptiveRevealProbe.IsStateful (Coordinate := Coordinate)) 0 + rw [AdaptiveRevealProbe.hashOutputQuery, + OracleComp.isQueryBoundP_query_bind_iff] + constructor + · simp [AdaptiveRevealProbe.IsStateful] + · intro output + trivial + +theorem ordinaryTweakableHash_stateFree (parameter : PublicParameter) + (domain : HashDomain) (payload : HashInput) : + StateFree (ordinaryTweakableHash parameter domain payload) := by + unfold ordinaryTweakableHash + exact (splitHashQuery_stateFree (.ordinary + (tweakableHashInput parameter domain payload))).bind fun output => + StateFree.pure (truncateHash output) + +theorem hiddenFtsLeafHash_stateFree (parameter : PublicParameter) + (coordinate : Coordinate) : StateFree (hiddenFtsLeafHash parameter coordinate) := by + unfold hiddenFtsLeafHash + exact (splitHashQuery_stateFree (.hiddenLeaf coordinate)).bind fun output => + StateFree.pure (truncateHash output) + +theorem sequenceFin_stateFree {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha) + (hcomputation : ∀ index, StateFree (computation index)) : + StateFree (sequenceFin computation) := by + induction n with + | zero => + simp only [sequenceFin] + exact StateFree.pure Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomputation 0).bind fun head => + (ih (fun index => computation index.succ) + (fun index => hcomputation index.succ)).bind fun tail => + StateFree.pure (Fin.cases head tail : Fin (n + 1) → alpha) + +theorem maskedFtsNode_stateFree (parameter : PublicParameter) (index : Index) + (tree : FtsTree) (level nodeIdx : Nat) : + StateFree (maskedFtsNode parameter index tree level nodeIdx) := by + induction level generalizing nodeIdx with + | zero => + exact hiddenFtsLeafHash_stateFree parameter + (index, tree, ftsLeafOfNat nodeIdx) + | succ level ih => + rw [maskedFtsNode] + exact (ih (2 * nodeIdx)).bind fun left => + (ih (2 * nodeIdx + 1)).bind fun right => + ordinaryTweakableHash_stateFree parameter + (.ftsNode index tree (level + 1) nodeIdx) (nodePayload left right) + +theorem maskedFtsKey_stateFree (parameter : PublicParameter) (index : Index) : + StateFree (maskedFtsKey parameter index) := by + unfold maskedFtsKey + exact (sequenceFin_stateFree + (fun tree => maskedFtsNode parameter index tree ftsTreeHeight 0) + (fun tree => maskedFtsNode_stateFree parameter index tree ftsTreeHeight 0)).bind + fun roots => ordinaryTweakableHash_stateFree parameter (.ftsRoots index) + (ftsRootsPayload roots) + +theorem maskedFtsOpen_stateFree (parameter : PublicParameter) (index : Index) + (leaves : DigestTree → FtsLeaf) : + StateFree (maskedFtsOpen parameter index leaves) := by + unfold maskedFtsOpen + apply sequenceFin_stateFree + intro tree + apply sequenceFin_stateFree + intro level + exact maskedFtsNode_stateFree parameter index tree level.val + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1) + +def Coupled (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (masked : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha) + (ordinary : StateT (QueryCache HashSpec) ProbComp alpha) : Prop := + ∀ cache, + projectDetailedCache parameter table <$> + AdaptiveRevealProbe.runDetailed table state fuel (masked.run cache) = + some <$> ordinary.run (mergedCache parameter table cache) + +def CoupledAt (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (masked : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha) + (ordinary : StateT (QueryCache HashSpec) ProbComp alpha) + (cache : SplitHashCache) : Prop := + projectDetailedCache parameter table <$> + AdaptiveRevealProbe.runDetailed table state fuel (masked.run cache) = + some <$> ordinary.run (mergedCache parameter table cache) + +theorem Coupled.coupledAt + {parameter : PublicParameter} {table : Coordinate → Digest} + {state : AdaptiveRevealProbe.State Coordinate} {fuel : Nat} + {masked : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha} + {ordinary : StateT (QueryCache HashSpec) ProbComp alpha} + (hcoupled : Coupled parameter table state fuel masked ordinary) + (cache : SplitHashCache) : + CoupledAt parameter table state fuel masked ordinary cache := + hcoupled cache + +theorem CoupledAt.bind_probeFree + {parameter : PublicParameter} {table : Coordinate → Digest} + {state : AdaptiveRevealProbe.State Coordinate} {fuel : Nat} + {left : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) beta} + {ordinaryLeft : StateT (QueryCache HashSpec) ProbComp alpha} + {ordinaryNext : alpha → StateT (QueryCache HashSpec) ProbComp beta} + {cache : SplitHashCache} + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hprobeFree : ProbeFree left) + (hleft : CoupledAt parameter table state fuel left ordinaryLeft cache) + (hnext : ∀ finalState value finalCache, + .done false finalState (value, finalCache) ∈ + support (AdaptiveRevealProbe.runDetailed table state fuel (left.run cache)) → + CoupledAt parameter table finalState fuel (next value) (ordinaryNext value) + finalCache) : + CoupledAt parameter table state fuel (left >>= next) + (ordinaryLeft >>= ordinaryNext) cache := by + let resume : Option (alpha × QueryCache HashSpec) → + ProbComp (Option (beta × QueryCache HashSpec)) + | none => pure none + | some (value, ordinaryCache) => some <$> (ordinaryNext value).run ordinaryCache + unfold CoupledAt at hleft ⊢ + rw [StateT.run_bind, StateT.run_bind, + AdaptiveRevealProbe.runDetailed_bind_probeFree table state fuel + (left.run cache) (fun result => (next result.1).run result.2) + (hprobeFree cache)] + simp only [map_bind] + refine (OracleComp.bind_congr_of_forall_mem_support + (AdaptiveRevealProbe.runDetailed table state fuel (left.run cache)) + (g := fun result => resume (projectDetailedCache parameter table result)) ?_).trans ?_ + · intro result hresult + obtain ⟨finalState, value, hresultEq, hfinalClean⟩ := + AdaptiveRevealProbe.runDetailed_probeFree_support table state fuel + (left.run cache) (hprobeFree cache) hclean result hresult + subst result + simp only [projectDetailedCache, resume] + exact hnext finalState value.1 value.2 hresult + · rw [← bind_map_left, hleft] + simp only [map_eq_bind_pure_comp, bind_assoc, Function.comp_apply, pure_bind, resume] + +theorem coupledAt_revealFtsSecret + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) (coordinate : Coordinate) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state cache) + (hhidden : ∃ output, cache (.hiddenLeaf coordinate) = some output) : + CoupledAt parameter table state fuel (revealFtsSecret parameter coordinate) + (pure (table coordinate) : StateT (QueryCache HashSpec) ProbComp Digest) cache := by + unfold CoupledAt + cases hrevealed : state.revealed coordinate with + | none => + obtain ⟨output, hhidden⟩ := hhidden + rw [runDetailed_revealFtsSecret_hidden parameter table state fuel cache coordinate output + hrevealed hclean hhidden] + simp only [map_pure, projectDetailedCache, StateT.run_pure] + rw [mergedCache_update_hiddenInput_ordinary] + | some value => + obtain ⟨hvalue, output, hhiddenCache, hordinaryCache⟩ := + hsynced coordinate value hrevealed + rw [runDetailed_revealFtsSecret_revealed parameter table state fuel cache coordinate + value output hrevealed hvalue hhiddenCache hordinaryCache hclean] + simp [projectDetailedCache] + +theorem revealedSynced_of_mem_runDetailed_revealFtsSecret + (parameter : PublicParameter) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (coordinate : Coordinate) (value : Digest) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state cache) + (hhidden : ∃ output, cache (.hiddenLeaf coordinate) = some output) + (hresult : .done false finalState (value, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((revealFtsSecret parameter coordinate).run cache))) : + RevealedSynced parameter table finalState finalCache := by + cases hrevealed : state.revealed coordinate with + | none => + obtain ⟨output, hhiddenCache⟩ := hhidden + rw [runDetailed_revealFtsSecret_hidden parameter table state fuel cache coordinate output + hrevealed hclean hhiddenCache] at hresult + simp only [support_pure, Set.mem_singleton_iff, + AdaptiveRevealProbe.DetailedResult.done.injEq] at hresult + obtain ⟨hfinalState, hvalueCache⟩ := hresult.2 + subst finalState + cases hvalueCache + exact RevealedSynced.install hsynced coordinate (table coordinate) output rfl hhiddenCache + | some revealedValue => + obtain ⟨hvalue, output, hhiddenCache, hordinaryCache⟩ := + hsynced coordinate revealedValue hrevealed + rw [runDetailed_revealFtsSecret_revealed parameter table state fuel cache coordinate + revealedValue output hrevealed hvalue hhiddenCache hordinaryCache hclean] at hresult + simp only [support_pure, Set.mem_singleton_iff, + AdaptiveRevealProbe.DetailedResult.done.injEq] at hresult + obtain ⟨hfinalState, hvalueCache⟩ := hresult.2 + subst finalState + cases hvalueCache + exact hsynced + +theorem Coupled.bind + {parameter : PublicParameter} {table : Coordinate → Digest} + {state : AdaptiveRevealProbe.State Coordinate} {fuel : Nat} + {left : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) beta} + {ordinaryLeft : StateT (QueryCache HashSpec) ProbComp alpha} + {ordinaryNext : alpha → StateT (QueryCache HashSpec) ProbComp beta} + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hstateFree : StateFree left) + (hleft : Coupled parameter table state fuel left ordinaryLeft) + (hnext : ∀ value, Coupled parameter table state fuel (next value) + (ordinaryNext value)) : + Coupled parameter table state fuel (left >>= next) + (ordinaryLeft >>= ordinaryNext) := by + intro cache + let resume : Option (alpha × QueryCache HashSpec) → + ProbComp (Option (beta × QueryCache HashSpec)) + | none => pure none + | some (value, ordinaryCache) => some <$> (ordinaryNext value).run ordinaryCache + rw [StateT.run_bind, StateT.run_bind, + AdaptiveRevealProbe.runDetailed_bind_stateFree table state fuel + (left.run cache) (fun result => (next result.1).run result.2) + (hstateFree cache)] + simp only [map_bind] + refine (OracleComp.bind_congr_of_forall_mem_support + (AdaptiveRevealProbe.runDetailed table state fuel (left.run cache)) + (g := fun result => resume (projectDetailedCache parameter table result)) ?_).trans ?_ + · intro result hresult + obtain ⟨value, hresultEq⟩ := + AdaptiveRevealProbe.runDetailed_stateFree_support table state fuel + (left.run cache) (hstateFree cache) hclean result hresult + subst result + simp only [projectDetailedCache, resume] + exact hnext value.1 value.2 + · rw [← bind_map_left, hleft cache] + simp only [map_eq_bind_pure_comp, bind_assoc, Function.comp_apply, pure_bind, resume] + +theorem Coupled.bind_probeFree + {parameter : PublicParameter} {table : Coordinate → Digest} + {state : AdaptiveRevealProbe.State Coordinate} {fuel : Nat} + {left : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) beta} + {ordinaryLeft : StateT (QueryCache HashSpec) ProbComp alpha} + {ordinaryNext : alpha → StateT (QueryCache HashSpec) ProbComp beta} + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hprobeFree : ProbeFree left) + (hleft : Coupled parameter table state fuel left ordinaryLeft) + (hnext : ∀ finalState value, + AdaptiveRevealProbe.tableHits finalState table = false → + Coupled parameter table finalState fuel (next value) (ordinaryNext value)) : + Coupled parameter table state fuel (left >>= next) + (ordinaryLeft >>= ordinaryNext) := by + intro cache + let resume : Option (alpha × QueryCache HashSpec) → + ProbComp (Option (beta × QueryCache HashSpec)) + | none => pure none + | some (value, ordinaryCache) => some <$> (ordinaryNext value).run ordinaryCache + rw [StateT.run_bind, StateT.run_bind, + AdaptiveRevealProbe.runDetailed_bind_probeFree table state fuel + (left.run cache) (fun result => (next result.1).run result.2) + (hprobeFree cache)] + simp only [map_bind] + refine (OracleComp.bind_congr_of_forall_mem_support + (AdaptiveRevealProbe.runDetailed table state fuel (left.run cache)) + (g := fun result => resume (projectDetailedCache parameter table result)) ?_).trans ?_ + · intro result hresult + obtain ⟨finalState, value, hresultEq, hfinalClean⟩ := + AdaptiveRevealProbe.runDetailed_probeFree_support table state fuel + (left.run cache) (hprobeFree cache) hclean result hresult + subst result + simp only [projectDetailedCache, resume] + exact hnext finalState value.1 hfinalClean value.2 + · rw [← bind_map_left, hleft cache] + simp only [map_eq_bind_pure_comp, bind_assoc, Function.comp_apply, pure_bind, resume] + +theorem Coupled.pure + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (hclean : AdaptiveRevealProbe.tableHits state table = false) (value : alpha) : + Coupled parameter table state fuel + (pure value : StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha) + (pure value : StateT (QueryCache HashSpec) ProbComp alpha) := by + intro cache + simp [AdaptiveRevealProbe.runDetailed, projectDetailedCache, hclean] + +theorem isOrdinaryInput_ftsNode (parameter : PublicParameter) + (table : Coordinate → Digest) (index : Index) (tree : FtsTree) + (level nodeIdx : Nat) (payload : HashInput) + (hlevel : level < 2 ^ 32) (hnodeIdx : nodeIdx < 2 ^ 32) : + IsOrdinaryInput parameter table + (tweakableHashInput parameter (.ftsNode index tree level nodeIdx) payload) := by + apply isOrdinaryInput_of_decode_none + rw [decodeProbe?_eq_none_iff] + intro probe heq + have hdomain := (tweakableHashInput_injective parameter (by trivial) + (by exact ⟨hlevel, hnodeIdx⟩) heq).1 + exact HashDomain.noConfusion hdomain + +theorem isOrdinaryInput_ftsRoots (parameter : PublicParameter) + (table : Coordinate → Digest) (index : Index) (payload : HashInput) : + IsOrdinaryInput parameter table + (tweakableHashInput parameter (.ftsRoots index) payload) := by + apply isOrdinaryInput_of_decode_none + rw [decodeProbe?_eq_none_iff] + intro probe heq + have hdomain := (tweakableHashInput_injective parameter (by trivial) (by trivial) heq).1 + exact HashDomain.noConfusion hdomain + +theorem coupled_hiddenFtsLeafHash + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (coordinate : Coordinate) + (hclean : AdaptiveRevealProbe.tableHits state table = false) : + Coupled parameter table state fuel (hiddenFtsLeafHash parameter coordinate) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsLeafHash parameter coordinate.1 coordinate.2.1 coordinate.2.2 + (table coordinate))) := by + intro cache + exact runDetailed_hiddenFtsLeafHash parameter table state fuel cache coordinate hclean + +theorem coupled_ordinaryTweakableHash + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (domain : HashDomain) (payload : HashInput) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hordinary : IsOrdinaryInput parameter table + (tweakableHashInput parameter domain payload)) : + Coupled parameter table state fuel + (ordinaryTweakableHash parameter domain payload) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (tweakableHash parameter domain payload)) := by + intro cache + exact runDetailed_ordinaryTweakableHash parameter table state fuel cache domain payload + hclean hordinary + +theorem coupled_maskedFtsNode + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (index : Index) (tree : FtsTree) (level nodeIdx : Nat) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hlevel : level ≤ ftsTreeHeight) + (hnodeIdx : 2 ^ level * (nodeIdx + 1) ≤ 2 ^ ftsTreeHeight) : + Coupled parameter table state fuel + (maskedFtsNode parameter index tree level nodeIdx) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsNode parameter index tree (fun leafIdx => table (index, tree, leafIdx)) + level nodeIdx)) := by + induction level generalizing nodeIdx with + | zero => + rw [maskedFtsNode, ftsNode_zero_eq] + exact coupled_hiddenFtsLeafHash parameter table state fuel + (index, tree, ftsLeafOfNat nodeIdx) hclean + | succ level ih => + rw [maskedFtsNode, ftsNode_succ_eq, simulateQ_bind] + have hlevelChild : level ≤ ftsTreeHeight := by omega + have hleftNode : 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ ftsTreeHeight := by + rw [pow_succ] at hnodeIdx + nlinarith [Nat.two_pow_pos level] + have hrightNode : 2 ^ level * (2 * nodeIdx + 1 + 1) ≤ 2 ^ ftsTreeHeight := by + rw [pow_succ] at hnodeIdx + nlinarith [Nat.two_pow_pos level] + have hlevelSmall : level + 1 < 2 ^ 32 := by + norm_num [ftsTreeHeight] at hlevel ⊢ + omega + have hnodeSmall : nodeIdx < 2 ^ 32 := by + norm_num [ftsTreeHeight] at hnodeIdx ⊢ + nlinarith [Nat.two_pow_pos (level + 1)] + refine Coupled.bind hclean + (maskedFtsNode_stateFree parameter index tree level (2 * nodeIdx)) + (ih (2 * nodeIdx) hlevelChild hleftNode) ?_ + intro left + rw [simulateQ_bind] + exact Coupled.bind hclean + (maskedFtsNode_stateFree parameter index tree level (2 * nodeIdx + 1)) + (ih (2 * nodeIdx + 1) hlevelChild hrightNode) fun right => + coupled_ordinaryTweakableHash parameter table state fuel + (.ftsNode index tree (level + 1) nodeIdx) (nodePayload left right) hclean + (isOrdinaryInput_ftsNode parameter table index tree (level + 1) nodeIdx + (nodePayload left right) hlevelSmall hnodeSmall) + +theorem coupled_sequenceFin {n : Nat} + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (masked : Fin n → StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha) + (ordinary : Fin n → StateT (QueryCache HashSpec) ProbComp alpha) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hstateFree : ∀ position, StateFree (masked position)) + (hcoupled : ∀ position, + Coupled parameter table state fuel (masked position) (ordinary position)) : + Coupled parameter table state fuel (sequenceFin masked) (sequenceFin ordinary) := by + induction n with + | zero => + simp only [sequenceFin] + exact Coupled.pure parameter table state fuel hclean Fin.elim0 + | succ n ih => + rw [sequenceFin, sequenceFin] + exact Coupled.bind hclean (hstateFree 0) (hcoupled 0) fun head => + Coupled.bind hclean + (sequenceFin_stateFree (fun position => masked position.succ) + (fun position => hstateFree position.succ)) + (ih (fun position => masked position.succ) + (fun position => ordinary position.succ) + (fun position => hstateFree position.succ) + (fun position => hcoupled position.succ)) fun tail => + by + intro cache + simp [AdaptiveRevealProbe.runDetailed, projectDetailedCache, hclean] + +theorem simulateQ_randomOracle_sequenceFin {n : Nat} + (computation : Fin n → OracleComp HashSpec alpha) : + simulateQ (randomOracle : QueryImpl HashSpec _) + (sequenceFin computation) = + sequenceFin fun position => + simulateQ (randomOracle : QueryImpl HashSpec _) (computation position) := by + induction n with + | zero => simp [sequenceFin] + | succ n ih => + simp only [sequenceFin, simulateQ_bind, simulateQ_pure, ih] + +theorem ftsOpen_node_bound (leafIdx : FtsLeaf) (level : Fin ftsTreeHeight) : + 2 ^ level.val * (Nat.xor (leafIdx.val / 2 ^ level.val) 1 + 1) ≤ + 2 ^ ftsTreeHeight := by + let bound := 2 ^ (ftsTreeHeight - level.val) + have hlevel : level.val < ftsTreeHeight := level.isLt + have hquotient : leafIdx.val / 2 ^ level.val < bound := by + apply (Nat.div_lt_iff_lt_mul (Nat.two_pow_pos level.val)).2 + change leafIdx.val < 2 ^ (ftsTreeHeight - level.val) * 2 ^ level.val + rw [← pow_add] + simpa only [Nat.sub_add_cancel (Nat.le_of_lt hlevel)] using leafIdx.isLt + have hboundEven : ∃ half, bound = 2 * half := by + refine ⟨2 ^ (ftsTreeHeight - level.val - 1), ?_⟩ + change 2 ^ (ftsTreeHeight - level.val) = _ + rw [show ftsTreeHeight - level.val = + (ftsTreeHeight - level.val - 1) + 1 by omega, pow_succ] + exact Nat.mul_comm _ _ + have hsibling : Nat.xor (leafIdx.val / 2 ^ level.val) 1 < bound := by + obtain ⟨parent, hcase⟩ := index_sibling_cases (leafIdx.val / 2 ^ level.val) + obtain ⟨half, hbound⟩ := hboundEven + rcases hcase with hcase | hcase <;> omega + calc + 2 ^ level.val * (Nat.xor (leafIdx.val / 2 ^ level.val) 1 + 1) ≤ + 2 ^ level.val * bound := + Nat.mul_le_mul_left _ (Nat.succ_le_iff.mpr hsibling) + _ = 2 ^ ftsTreeHeight := by + change 2 ^ level.val * 2 ^ (ftsTreeHeight - level.val) = _ + rw [← pow_add] + congr 1 + omega + +theorem coupled_maskedFtsKey + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) (index : Index) + (hclean : AdaptiveRevealProbe.tableHits state table = false) : + Coupled parameter table state fuel (maskedFtsKey parameter index) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsKey parameter index (fun tree leafIdx => table (index, tree, leafIdx)))) := by + unfold maskedFtsKey ftsKey + rw [simulateQ_bind, simulateQ_randomOracle_sequenceFin] + exact Coupled.bind hclean + (sequenceFin_stateFree + (fun tree => maskedFtsNode parameter index tree ftsTreeHeight 0) + (fun tree => maskedFtsNode_stateFree parameter index tree ftsTreeHeight 0)) + (coupled_sequenceFin parameter table state fuel + (fun tree => maskedFtsNode parameter index tree ftsTreeHeight 0) + (fun tree => simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsNode parameter index tree (fun leafIdx => table (index, tree, leafIdx)) + ftsTreeHeight 0)) hclean + (fun tree => maskedFtsNode_stateFree parameter index tree ftsTreeHeight 0) + (fun tree => coupled_maskedFtsNode parameter table state fuel index tree + ftsTreeHeight 0 hclean (by rfl) (by simp))) fun roots => + coupled_ordinaryTweakableHash parameter table state fuel (.ftsRoots index) + (ftsRootsPayload roots) hclean + (isOrdinaryInput_ftsRoots parameter table index (ftsRootsPayload roots)) + +theorem coupled_maskedFtsOpen + (parameter : PublicParameter) (table : Coordinate → Digest) + (state : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) (index : Index) + (leaves : DigestTree → FtsLeaf) + (hclean : AdaptiveRevealProbe.tableHits state table = false) : + Coupled parameter table state fuel (maskedFtsOpen parameter index leaves) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsOpen parameter index leaves + (fun tree leafIdx => table (index, tree, leafIdx)))) := by + unfold maskedFtsOpen ftsOpen + rw [simulateQ_randomOracle_sequenceFin] + apply coupled_sequenceFin parameter table state fuel _ _ hclean + · intro tree + exact sequenceFin_stateFree _ fun level => + maskedFtsNode_stateFree parameter index tree level.val + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1) + · intro tree + rw [simulateQ_randomOracle_sequenceFin] + apply coupled_sequenceFin parameter table state fuel _ _ hclean + · intro level + exact maskedFtsNode_stateFree parameter index tree level.val + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1) + · intro level + exact coupled_maskedFtsNode parameter table state fuel index tree level.val + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1) hclean + (Nat.le_of_lt level.isLt) (ftsOpen_node_bound (leaves (ftsIndexOf tree)) level) + +theorem splitUniformImpl_probeFree (n : unifSpec.Domain) : + ProbeFree (splitUniformImpl n) := by + intro cache + change (((fun output : Fin (n + 1) => (output, cache)) <$> + AdaptiveRevealProbe.uniformQuery (Coordinate := Coordinate) n).IsQueryBoundP + (AdaptiveRevealProbe.IsProbe (Coordinate := Coordinate)) 0) + rw [isQueryBoundP_map_iff, AdaptiveRevealProbe.uniformQuery, + OracleComp.isQueryBoundP_query_iff] + simp [AdaptiveRevealProbe.IsProbe] + +theorem simulateQ_splitRomImpl_probeFree + (computation : OracleComp OracleWorld alpha) : + ProbeFree (simulateQ splitRomImpl computation) := by + intro cache + apply (isQueryBoundP_false computation 0).simulateQ_run_StateT_of_step + intro input workingCache + cases input with + | inl n => + exact splitUniformImpl_probeFree n workingCache + | inr hashInput => + exact splitHashQuery_run_isProbeBound (.ordinary hashInput) workingCache 0 + +theorem simulateQ_ordinaryHashImpl_probeFree + (computation : OracleComp HashSpec alpha) : + ProbeFree (simulateQ ordinaryHashImpl computation) := by + intro cache + apply (isQueryBoundP_false computation 0).simulateQ_run_StateT_of_step + intro input workingCache + exact splitHashQuery_run_isProbeBound (.ordinary input) workingCache 0 + +theorem splitHashQuery_probeFree (key : SplitHashKey) : + ProbeFree (splitHashQuery key) := + fun cache => splitHashQuery_run_isProbeBound key cache 0 + +theorem ordinaryTweakableHash_probeFree (parameter : PublicParameter) + (domain : HashDomain) (payload : HashInput) : + ProbeFree (ordinaryTweakableHash parameter domain payload) := by + unfold ordinaryTweakableHash + exact (splitHashQuery_probeFree (.ordinary + (tweakableHashInput parameter domain payload))).bind fun output => + ProbeFree.pure (truncateHash output) + +theorem hiddenFtsLeafHash_probeFree (parameter : PublicParameter) + (coordinate : Coordinate) : ProbeFree (hiddenFtsLeafHash parameter coordinate) := by + unfold hiddenFtsLeafHash + exact (splitHashQuery_probeFree (.hiddenLeaf coordinate)).bind fun output => + ProbeFree.pure (truncateHash output) + +theorem sequenceFin_probeFree {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) alpha) + (hcomputation : ∀ index, ProbeFree (computation index)) : + ProbeFree (sequenceFin computation) := by + induction n with + | zero => + simp only [sequenceFin] + exact ProbeFree.pure Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomputation 0).bind fun head => + (ih (fun index => computation index.succ) + (fun index => hcomputation index.succ)).bind fun tail => + ProbeFree.pure (Fin.cases head tail : Fin (n + 1) → alpha) + +theorem maskedFtsNode_probeFree (parameter : PublicParameter) (index : Index) + (tree : FtsTree) (level nodeIdx : Nat) : + ProbeFree (maskedFtsNode parameter index tree level nodeIdx) := by + induction level generalizing nodeIdx with + | zero => + exact hiddenFtsLeafHash_probeFree parameter + (index, tree, ftsLeafOfNat nodeIdx) + | succ level ih => + rw [maskedFtsNode] + exact (ih (2 * nodeIdx)).bind fun left => + (ih (2 * nodeIdx + 1)).bind fun right => + ordinaryTweakableHash_probeFree parameter + (.ftsNode index tree (level + 1) nodeIdx) (nodePayload left right) + +theorem maskedFtsKey_probeFree (parameter : PublicParameter) (index : Index) : + ProbeFree (maskedFtsKey parameter index) := by + unfold maskedFtsKey + exact (sequenceFin_probeFree + (fun tree => maskedFtsNode parameter index tree ftsTreeHeight 0) + (fun tree => maskedFtsNode_probeFree parameter index tree ftsTreeHeight 0)).bind + fun roots => ordinaryTweakableHash_probeFree parameter (.ftsRoots index) + (ftsRootsPayload roots) + +theorem maskedFtsOpen_probeFree (parameter : PublicParameter) (index : Index) + (leaves : DigestTree → FtsLeaf) : + ProbeFree (maskedFtsOpen parameter index leaves) := by + unfold maskedFtsOpen + apply sequenceFin_probeFree + intro tree + apply sequenceFin_probeFree + intro level + exact maskedFtsNode_probeFree parameter index tree level.val + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1) + +theorem revealQuery_probeFree (coordinate : Coordinate) : + ProbeFree (liftM (AdaptiveRevealProbe.revealQuery coordinate) : + StateT SplitHashCache + (OracleComp (AdaptiveRevealProbe.World Coordinate)) Digest) := by + intro cache + change (((fun value : Digest => (value, cache)) <$> + AdaptiveRevealProbe.revealQuery coordinate).IsQueryBoundP + (AdaptiveRevealProbe.IsProbe (Coordinate := Coordinate)) 0) + rw [isQueryBoundP_map_iff] + exact AdaptiveRevealProbe.revealQuery_isProbeBound coordinate 0 + +theorem revealFtsSecret_probeFree (parameter : PublicParameter) + (coordinate : Coordinate) : ProbeFree (revealFtsSecret parameter coordinate) := by + unfold revealFtsSecret + exact (revealQuery_probeFree coordinate).bind fun value => + (splitHashQuery_probeFree (.hiddenLeaf coordinate)).bind fun output => by + exact (ProbeFree.modify fun cache : SplitHashCache => + Function.update cache + (.ordinary ((⟨coordinate.1, coordinate.2.1, coordinate.2.2, + value⟩ : FtsSecretProbe).input parameter)) (some output)).bind fun _ => + ProbeFree.pure value + +theorem revealSelectedFtsSecrets_probeFree (parameter : PublicParameter) (index : Index) + (leaves : DigestTree → FtsLeaf) : + ProbeFree (revealSelectedFtsSecrets parameter index leaves) := by + unfold revealSelectedFtsSecrets + apply sequenceFin_probeFree + intro tree + exact revealFtsSecret_probeFree parameter (index, tree, leaves (ftsIndexOf tree)) + +theorem maskedLayerMessage_probeFree (secretKey : SecretKey) (index : Index) + (lay : Layer) : ProbeFree (maskedLayerMessage secretKey index lay) := by + unfold maskedLayerMessage + split + · exact simulateQ_ordinaryHashImpl_probeFree _ + · exact maskedFtsKey_probeFree secretKey.parameter index + +theorem maskedSignLayer_probeFree (secretKey : SecretKey) (index : Index) + (lay : Layer) : ProbeFree (maskedSignLayer secretKey index lay) := by + unfold maskedSignLayer + exact (maskedLayerMessage_probeFree secretKey index lay).bind fun message => + (simulateQ_ordinaryHashImpl_probeFree + (otsSign secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + message)).bind fun signed => by + cases signed with + | none => exact ProbeFree.pure none + | some part => + exact (simulateQ_ordinaryHashImpl_probeFree + (treePath secretKey.parameter lay (treeIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay)) + (leafIndexAt index lay))).bind fun path => + ProbeFree.pure (some (part.1, part.2, path)) + +theorem maskedSignAfterDigest_probeFree (secretKey : SecretKey) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + ProbeFree (maskedSignAfterDigest secretKey randomness index leaves) := by + unfold maskedSignAfterDigest + exact (maskedFtsOpen_probeFree secretKey.parameter index leaves).bind fun ftsPath => + (sequenceFin_probeFree (fun lay => maskedSignLayer secretKey index lay) + (fun lay => maskedSignLayer_probeFree secretKey index lay)).bind fun layers => by + cases hparts : traverseOption layers with + | none => exact ProbeFree.pure none + | some parts => + exact (revealSelectedFtsSecrets_probeFree secretKey.parameter index leaves).bind + fun selected => ProbeFree.pure (some + (show Signature from + { randomness := randomness + ftsSecret := selected + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (parts lay).2.1 + authPath := flattenPaths fun lay => (parts lay).2.2 })) + +theorem maskedSignWithView_probeFree (secretKey : SecretKey) (message : Message) : + ProbeFree (maskedSignWithView secretKey message) := by + unfold maskedSignWithView + exact (simulateQ_splitRomImpl_probeFree + (signDigestLoop digestAttemptLimit secretKey message)).bind fun selected => by + cases selected with + | none => exact ProbeFree.pure (none, none) + | some data => + exact (maskedSignAfterDigest_probeFree secretKey data.1 data.2.1 data.2.2).bind + fun signature => ProbeFree.pure + (signature, some (selectedFewTimeView data.2.1 data.2.2)) + +theorem simulateQ_probingRomImpl_run_isProbeBound + (parameter : PublicParameter) (computation : OracleComp OracleWorld alpha) + (q : Nat) + (hbound : computation.IsQueryBoundP (· matches Sum.inr _) q) + (cache : SplitHashCache) : + ((simulateQ (probingRomImpl parameter) computation).run cache).IsQueryBoundP + (AdaptiveRevealProbe.IsProbe (Coordinate := Coordinate)) q := by + apply hbound.simulateQ_run_StateT_of_step + intro input workingCache + cases input with + | inl n => + exact splitUniformImpl_probeFree n workingCache + | inr hashInput => + exact probingHashQuery_run_isProbeBound parameter hashInput workingCache + +theorem simulateQ_probingRomImpl_run'_isProbeBound + (parameter : PublicParameter) (computation : OracleComp OracleWorld alpha) + (q : Nat) + (hbound : computation.IsQueryBoundP (· matches Sum.inr _) q) + (cache : SplitHashCache) : + ((simulateQ (probingRomImpl parameter) computation).run' cache).IsQueryBoundP + (AdaptiveRevealProbe.IsProbe (Coordinate := Coordinate)) q := by + rw [StateT.run'_eq, isQueryBoundP_map_iff] + exact simulateQ_probingRomImpl_run_isProbeBound parameter computation q hbound cache + +theorem probEvent_maskedGame_hit_le (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (q : Nat) + (hbound : ((maskedGameAfterSecrets adversary parameter otsSecret).run' + emptySplitHashCache).IsQueryBoundP + (AdaptiveRevealProbe.IsProbe (Coordinate := Coordinate)) q) : + Pr[fun hit : Bool => hit = true | + AdaptiveRevealProbe.experiment + (AdaptiveRevealProbe.State.empty : AdaptiveRevealProbe.State Coordinate) q + ((maskedGameAfterSecrets adversary parameter otsSecret).run' + emptySplitHashCache)] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply AdaptiveRevealProbe.experiment_empty_probability_le + exact hbound + +@[simp] theorem hiddenFtsLeafHash_parameter_irrelevant + (left right : PublicParameter) (coordinate : Coordinate) : + hiddenFtsLeafHash left coordinate = hiddenFtsLeafHash right coordinate := rfl + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsProbeTerminal.lean b/formal/sphincs/SphincsSecurity/Proof/FtsProbeTerminal.lean new file mode 100644 index 00000000..b6da47ba --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsProbeTerminal.lean @@ -0,0 +1,426 @@ +import SphincsSecurity.Proof.FtsProbeOrigin + +namespace SphincsSecurity.Concrete.FtsProbeSimulation + +open OracleComp OracleSpec + +theorem mergedCache_mono + (parameter : PublicParameter) (table : Coordinate → Digest) + {initial final : SplitHashCache} (hle : SplitCacheLE initial final) : + mergedCache parameter table initial ≤ mergedCache parameter table final := by + intro input output houtput + unfold mergedCache at houtput ⊢ + cases hdecode : decodeProbe? parameter input with + | none => + simp only [hdecode] at houtput ⊢ + exact hle _ output houtput + | some probe => + simp only [hdecode] at houtput ⊢ + by_cases hhit : probe.candidate = table (probe.index, probe.tree, probe.leafIdx) + · simp only [hhit, if_true] at houtput ⊢ + exact hle _ output houtput + · simp only [hhit, if_false] at houtput ⊢ + exact hle _ output houtput + +theorem simulateQ_probingHashImpl_cachePreserving + (parameter : PublicParameter) (computation : OracleComp HashSpec alpha) : + CachePreserving (simulateQ (probingHashImpl parameter) computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp only [simulateQ_pure] + exact CachePreserving.pure value + | query_bind input next ih => + rw [simulateQ_query_bind] + exact (probingHashQuery_cachePreserving parameter input).bind fun output => ih output + +theorem probingHashQuery_done_false_hit_revealed + (parameter : PublicParameter) (table : Coordinate → Digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (input : HashInput) (output : HashOutput) + (probe : FtsSecretProbe) + (hdecode : decodeProbe? parameter input = some probe) + (hhit : probe.Hits (fun index tree leafIdx => table (index, tree, leafIdx))) + (hresult : .done false finalState (output, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((probingHashQuery parameter input).run cache))) : + ∃ value, state.revealed (probe.index, probe.tree, probe.leafIdx) = some value := by + cases fuel with + | zero => + rw [probingHashQuery_run_eq, hdecode] at hresult + change .done false finalState (output, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state 0 + ((liftM (OracleSpec.query + (spec := AdaptiveRevealProbe.World Coordinate) + (.probe (probe.index, probe.tree, probe.leafIdx) probe.candidate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Unit) >>= fun _ => + (splitHashQuery (.ordinary input)).run cache)) at hresult + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind] at hresult + simp at hresult + | succ remaining => + cases hrevealed : state.revealed (probe.index, probe.tree, probe.leafIdx) with + | some value => exact ⟨value, rfl⟩ + | none => + have hcandidate : table (probe.index, probe.tree, probe.leafIdx) = probe.candidate := + hhit + have hforced := runDetailed_probingHashQuery_hidden_hit parameter table state remaining + cache input probe hdecode hrevealed hcandidate + (.done false finalState (output, finalCache)) hresult + change false = true at hforced + simp at hforced + +def HiddenHitsRevealed (parameter : PublicParameter) (table : Coordinate → Digest) + (f : QueryImpl HashSpec Id) (state : AdaptiveRevealProbe.State Coordinate) + (computation : OracleComp HashSpec alpha) : Prop := + ∀ input, input ∈ queriedInputs f computation → + ∀ probe, decodeProbe? parameter input = some probe → + probe.Hits (fun index tree leafIdx => table (index, tree, leafIdx)) → + ∃ value, state.revealed (probe.index, probe.tree, probe.leafIdx) = some value + +set_option maxHeartbeats 800000 in +set_option maxRecDepth 20000 in +theorem hiddenHitsRevealed_of_mem_runDetailed + (parameter : PublicParameter) (table : Coordinate → Digest) + (f : QueryImpl HashSpec Id) (computation : OracleComp HashSpec alpha) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (value : alpha) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state cache) + (hf : (mergedCache parameter table finalCache).AgreesWithFn f) + (hresult : .done false finalState (value, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((simulateQ (probingHashImpl parameter) computation).run cache))) : + HiddenHitsRevealed parameter table f state computation := by + induction computation using OracleComp.inductionOn generalizing + state fuel cache finalState finalCache with + | pure result => + intro input hinput + simp at hinput + | query_bind input next ih => + rw [simulateQ_query_bind, StateT.run_bind] at hresult + cases hdecode : decodeProbe? parameter input with + | none => + have hheadProbeFree : ProbeFree (probingHashQuery parameter input) := by + intro workingCache + rw [probingHashQuery_run_eq, hdecode] + exact splitHashQuery_probeFree (.ordinary input) workingCache + obtain ⟨queryState, queryResult, hquery, hrest⟩ := + mem_support_runDetailed_bind_probeFree table state finalState fuel + ((probingHashQuery parameter input).run cache) + (fun result => + (simulateQ (probingHashImpl parameter) (next result.1)).run result.2) + (hheadProbeFree cache) hclean (value, finalCache) hresult + rcases queryResult with ⟨output, queryCache⟩ + have hstep := probingHashQuery_done_false_invariants parameter table state + queryState fuel cache queryCache input output hclean hquery + have hstepSynced := probingHashQuery_done_false_revealedSynced parameter table state + queryState fuel cache queryCache input output hclean hsynced hquery + have hrawTail := AdaptiveRevealProbe.mem_support_of_mem_runDetailed_done table + queryState finalState fuel + ((simulateQ (probingHashImpl parameter) (next output)).run queryCache) + false (value, finalCache) hrest + have hsplitLe : SplitCacheLE queryCache finalCache := + simulateQ_probingHashImpl_cachePreserving parameter (next output) + queryCache (value, finalCache) hrawTail + have hle := mergedCache_mono parameter table hsplitLe + have hqueryActual := probingHashQuery_done_false_mem_ordinary parameter table state + queryState fuel cache queryCache input output hclean hsynced hquery + have hcached := randomOracle_run_output_cached input + (mergedCache parameter table cache) + (mergedCache parameter table queryCache) output hqueryActual + have houtput : f input = output := hf (hle hcached) + have htail := ih output queryState finalState fuel queryCache finalCache + hstep.1 hstepSynced hf hrest + intro target htarget probe htargetDecode hhit + rw [queriedInputs_query_bind] at htarget + rcases List.mem_cons.mp htarget with htarget | htarget + · subst target + rw [hdecode] at htargetDecode + simp at htargetDecode + · rw [houtput] at htarget + obtain ⟨revealed, hrevealed⟩ := htail target htarget probe htargetDecode hhit + exact ⟨revealed, by simpa [hstep.2] using hrevealed⟩ + | some decoded => + have hwhole : .done false finalState (value, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((probingHashQuery parameter input).run cache >>= fun result => + (simulateQ (probingHashImpl parameter) (next result.1)).run result.2)) := + hresult + rw [probingHashQuery_run_eq, hdecode] at hwhole + change .done false finalState (value, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((liftM (OracleSpec.query + (spec := AdaptiveRevealProbe.World Coordinate) + (.probe (decoded.index, decoded.tree, decoded.leafIdx) decoded.candidate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Unit) >>= fun _ => + (splitHashQuery (.ordinary input)).run cache >>= fun result => + (simulateQ (probingHashImpl parameter) (next result.1)).run result.2)) at hwhole + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind] at hwhole + cases fuel with + | zero => simp at hwhole + | succ remaining => + cases hrevealed : state.revealed + (decoded.index, decoded.tree, decoded.leafIdx) with + | none => + simp only [hrevealed] at hwhole + by_cases hdecodedHit : table (decoded.index, decoded.tree, decoded.leafIdx) = + decoded.candidate + · have hpostClean := tableHits_false_of_mem_runDetailed_done_false table + (state.addPending + (decoded.index, decoded.tree, decoded.leafIdx) decoded.candidate) + finalState remaining + ((splitHashQuery (.ordinary input)).run cache >>= fun result => + (simulateQ (probingHashImpl parameter) (next result.1)).run result.2) + (value, finalCache) hwhole + have hpostHit := AdaptiveRevealProbe.tableHits_addPending_eq_true state table + (decoded.index, decoded.tree, decoded.leafIdx) decoded.candidate hdecodedHit + rw [hpostHit] at hpostClean + simp at hpostClean + · have hpostClean := AdaptiveRevealProbe.tableHits_addPending_eq_false state + table (decoded.index, decoded.tree, decoded.leafIdx) decoded.candidate + hclean hdecodedHit + obtain ⟨queryState, queryResult, hquery, hrest⟩ := + mem_support_runDetailed_bind_probeFree table + (state.addPending + (decoded.index, decoded.tree, decoded.leafIdx) decoded.candidate) + finalState remaining ((splitHashQuery (.ordinary input)).run cache) + (fun result => + (simulateQ (probingHashImpl parameter) (next result.1)).run result.2) + (splitHashQuery_probeFree (.ordinary input) cache) + hpostClean (value, finalCache) hwhole + rcases queryResult with ⟨output, queryCache⟩ + have hqueryOriginal : .done false queryState (output, queryCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((probingHashQuery parameter input).run cache)) := by + rw [probingHashQuery_run_eq, hdecode] + change .done false queryState (output, queryCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((liftM (OracleSpec.query + (spec := AdaptiveRevealProbe.World Coordinate) + (.probe (decoded.index, decoded.tree, decoded.leafIdx) + decoded.candidate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Unit) >>= fun _ => + (splitHashQuery (.ordinary input)).run cache)) + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind, hrevealed] + exact hquery + have hstep := probingHashQuery_done_false_invariants parameter table state + queryState (remaining + 1) cache queryCache input output hclean hqueryOriginal + have hstepSynced := probingHashQuery_done_false_revealedSynced parameter table + state queryState (remaining + 1) cache queryCache input output hclean hsynced + hqueryOriginal + have hrawTail := AdaptiveRevealProbe.mem_support_of_mem_runDetailed_done table + queryState finalState remaining + ((simulateQ (probingHashImpl parameter) (next output)).run queryCache) + false (value, finalCache) hrest + have hsplitLe : SplitCacheLE queryCache finalCache := + simulateQ_probingHashImpl_cachePreserving parameter (next output) + queryCache (value, finalCache) hrawTail + have hle := mergedCache_mono parameter table hsplitLe + have hqueryActual := probingHashQuery_done_false_mem_ordinary parameter table + state queryState (remaining + 1) cache queryCache input output hclean hsynced + hqueryOriginal + have hcached := randomOracle_run_output_cached input + (mergedCache parameter table cache) + (mergedCache parameter table queryCache) output hqueryActual + have houtput : f input = output := hf (hle hcached) + have htail := ih output queryState finalState remaining queryCache finalCache + hstep.1 hstepSynced hf hrest + intro target htarget probe htargetDecode hhit + rw [queriedInputs_query_bind] at htarget + rcases List.mem_cons.mp htarget with htarget | htarget + · subst target + have hprobe : probe = decoded := Option.some.inj + (htargetDecode.symm.trans hdecode) + subst probe + exact (hdecodedHit hhit).elim + · rw [houtput] at htarget + obtain ⟨revealed, hrevealedTail⟩ := + htail target htarget probe htargetDecode hhit + exact ⟨revealed, by simpa [hstep.2] using hrevealedTail⟩ + | some revealedValue => + simp only [hrevealed] at hwhole + obtain ⟨queryState, queryResult, hquery, hrest⟩ := + mem_support_runDetailed_bind_probeFree table state finalState remaining + ((splitHashQuery (.ordinary input)).run cache) + (fun result => + (simulateQ (probingHashImpl parameter) (next result.1)).run result.2) + (splitHashQuery_probeFree (.ordinary input) cache) + hclean (value, finalCache) hwhole + rcases queryResult with ⟨output, queryCache⟩ + have hqueryOriginal : .done false queryState (output, queryCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((probingHashQuery parameter input).run cache)) := by + rw [probingHashQuery_run_eq, hdecode] + change .done false queryState (output, queryCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state (remaining + 1) + ((liftM (OracleSpec.query + (spec := AdaptiveRevealProbe.World Coordinate) + (.probe (decoded.index, decoded.tree, decoded.leafIdx) + decoded.candidate)) : + OracleComp (AdaptiveRevealProbe.World Coordinate) Unit) >>= fun _ => + (splitHashQuery (.ordinary input)).run cache)) + rw [AdaptiveRevealProbe.runDetailed_probe_query_bind, hrevealed] + exact hquery + have hstep := probingHashQuery_done_false_invariants parameter table state + queryState (remaining + 1) cache queryCache input output hclean hqueryOriginal + have hstepSynced := probingHashQuery_done_false_revealedSynced parameter table + state queryState (remaining + 1) cache queryCache input output hclean hsynced + hqueryOriginal + have hrawTail := AdaptiveRevealProbe.mem_support_of_mem_runDetailed_done table + queryState finalState remaining + ((simulateQ (probingHashImpl parameter) (next output)).run queryCache) + false (value, finalCache) hrest + have hsplitLe : SplitCacheLE queryCache finalCache := + simulateQ_probingHashImpl_cachePreserving parameter (next output) + queryCache (value, finalCache) hrawTail + have hle := mergedCache_mono parameter table hsplitLe + have hqueryActual := probingHashQuery_done_false_mem_ordinary parameter table + state queryState (remaining + 1) cache queryCache input output hclean hsynced + hqueryOriginal + have hcached := randomOracle_run_output_cached input + (mergedCache parameter table cache) + (mergedCache parameter table queryCache) output hqueryActual + have houtput : f input = output := hf (hle hcached) + have htail := ih output queryState finalState remaining queryCache finalCache + hstep.1 hstepSynced hf hrest + intro target htarget probe htargetDecode hhit + rw [queriedInputs_query_bind] at htarget + rcases List.mem_cons.mp htarget with htarget | htarget + · subst target + have hprobe : probe = decoded := Option.some.inj + (htargetDecode.symm.trans hdecode) + subst probe + exact ⟨revealedValue, hrevealed⟩ + · rw [houtput] at htarget + obtain ⟨revealed, hrevealedTail⟩ := + htail target htarget probe htargetDecode hhit + exact ⟨revealed, by simpa [hstep.2] using hrevealedTail⟩ + +theorem verify_ftsLeaf_query_mem + (f : QueryImpl HashSpec Id) (publicKey : PublicKey) (message : Message) + (signature : Signature) (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest publicKey.parameter publicKey.root message signature.randomness) = digest) + (hadmissible : Admissible digest) (tree : FtsTree) : + tweakableHashInput publicKey.parameter + (.ftsLeaf (digestIndex digest) tree (digestLeaves digest (ftsIndexOf tree))) + (digestBytes (signature.ftsSecret tree)) ∈ + queriedInputs f + (verify (m := OracleComp HashSpec) publicKey message signature) := by + rw [verify_eq, queriedInputs_bind] + apply List.mem_append_right + rw [hdigest] + simp only [hadmissible, not_true_eq_false, if_false, queriedInputs_bind] + apply List.mem_append_left + exact ftsRecover_leaf_query_mem f publicKey.parameter (digestIndex digest) + (digestLeaves digest) signature.ftsSecret signature.ftsPath tree + +theorem uncoveredFtsSecret_revealed_of_clean_verify + (parameter : PublicParameter) (table : Coordinate → Digest) + (f : QueryImpl HashSpec Id) (root : Digest) (otsSecret : + Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (message : Message) (signature : Signature) (log : QueryLog SigningSpec) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest parameter root message signature.randomness) = digest) + (hadmissible : Admissible digest) + (state finalState : AdaptiveRevealProbe.State Coordinate) (fuel : Nat) + (cache finalCache : SplitHashCache) (verified : Bool) + (hclean : AdaptiveRevealProbe.tableHits state table = false) + (hsynced : RevealedSynced parameter table state cache) + (hf : (mergedCache parameter table finalCache).AgreesWithFn f) + (hverify : .done false finalState (verified, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table state fuel + ((simulateQ (probingHashImpl parameter) + (verify (m := OracleComp HashSpec) ⟨root, parameter⟩ message signature)).run cache))) + (huncovered : UncoveredFtsSecret f (mergedCache parameter table finalCache) + ⟨parameter, root, otsSecret, + fun index tree leafIdx => table (index, tree, leafIdx)⟩ + log (digestIndex digest) (digestLeaves digest) signature.ftsSecret) : + ∃ (probe : FtsSecretProbe) (revealedValue : Digest), + probe.Hits (fun index tree leafIdx => table (index, tree, leafIdx)) + ∧ state.revealed (probe.index, probe.tree, probe.leafIdx) = some revealedValue + ∧ ¬SignedFtsLeaf f (mergedCache parameter table finalCache) + ⟨parameter, root, otsSecret, + fun index tree leafIdx => table (index, tree, leafIdx)⟩ + log probe.index probe.tree probe.leafIdx := by + obtain ⟨tree, hnotSigned, hsecret, _⟩ := huncovered + let probe : FtsSecretProbe := + ⟨digestIndex digest, tree, digestLeaves digest (ftsIndexOf tree), + signature.ftsSecret tree⟩ + have hhit : probe.Hits + (fun index tree leafIdx => table (index, tree, leafIdx)) := hsecret.symm + have hquery : probe.input parameter ∈ queriedInputs f + (verify (m := OracleComp HashSpec) ⟨root, parameter⟩ message signature) := by + simp only [FtsSecretProbe.input, probe] + exact verify_ftsLeaf_query_mem f ⟨root, parameter⟩ message signature digest + hdigest hadmissible tree + have hrevealed := hiddenHitsRevealed_of_mem_runDetailed parameter table f + (verify (m := OracleComp HashSpec) ⟨root, parameter⟩ message signature) + state finalState fuel cache finalCache verified hclean hsynced hf hverify + (probe.input parameter) hquery probe (decodeProbe?_input parameter probe) hhit + obtain ⟨revealedValue, hrevealed⟩ := hrevealed + exact ⟨probe, revealedValue, hhit, hrevealed, by simpa [probe] using hnotSigned⟩ + +set_option maxRecDepth 20000 in +theorem clean_trace_verify_not_uncoveredFtsSecret + (secretKey : SecretKey) (table : Coordinate → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) Forgery) + (prefixFuel verifyFuel : Nat) + (initialCache prefixCache finalCache : SplitHashCache) + (prefixState finalState : AdaptiveRevealProbe.State Coordinate) + (forgery : Forgery) (log : QueryLog SigningSpec) (verified : Bool) + (f : QueryImpl HashSpec Id) + (hf : (mergedCache secretKey.parameter table finalCache).AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest secretKey.parameter secretKey.root forgery.message + forgery.signature.randomness) = digest) + (hadmissible : Admissible digest) + (hsynced : RevealedSynced secretKey.parameter table + AdaptiveRevealProbe.State.empty initialCache) + (hprefix : .done false prefixState ((forgery, log), prefixCache) ∈ support + (AdaptiveRevealProbe.runDetailed table AdaptiveRevealProbe.State.empty prefixFuel + ((simulateQ (maskedExpandedAdversaryImpl secretKey.parameter secretKey) + (signingTraceComputation computation)).run initialCache))) + (hverify : .done false finalState (verified, finalCache) ∈ support + (AdaptiveRevealProbe.runDetailed table prefixState verifyFuel + ((simulateQ (probingHashImpl secretKey.parameter) + (verify (m := OracleComp HashSpec) + ⟨secretKey.root, secretKey.parameter⟩ forgery.message + forgery.signature)).run prefixCache))) : + ¬UncoveredFtsSecret f (mergedCache secretKey.parameter table finalCache) + (secretKeyWithFtsTable secretKey table) log (digestIndex digest) + (digestLeaves digest) forgery.signature.ftsSecret := by + intro huncovered + have hinitialClean : AdaptiveRevealProbe.tableHits + (AdaptiveRevealProbe.State.empty : AdaptiveRevealProbe.State Coordinate) table = false := by + simp [AdaptiveRevealProbe.tableHits, AdaptiveRevealProbe.State.empty] + have hprefixLift := simulateQ_maskedExpandedAdversaryImpl_done_false secretKey table + (signingTraceComputation computation) AdaptiveRevealProbe.State.empty prefixState prefixFuel + initialCache prefixCache (forgery, log) hinitialClean hsynced hprefix + have hrawVerify := AdaptiveRevealProbe.mem_support_of_mem_runDetailed_done table + prefixState finalState verifyFuel + ((simulateQ (probingHashImpl secretKey.parameter) + (verify (m := OracleComp HashSpec) + ⟨secretKey.root, secretKey.parameter⟩ forgery.message forgery.signature)).run + prefixCache) + false (verified, finalCache) hverify + have hsplitLe : SplitCacheLE prefixCache finalCache := + simulateQ_probingHashImpl_cachePreserving secretKey.parameter + (verify (m := OracleComp HashSpec) + ⟨secretKey.root, secretKey.parameter⟩ forgery.message forgery.signature) + prefixCache (verified, finalCache) hrawVerify + have hle := mergedCache_mono secretKey.parameter table hsplitLe + obtain ⟨probe, revealedValue, _, hrevealed, hnotSigned⟩ := + uncoveredFtsSecret_revealed_of_clean_verify secretKey.parameter table f + secretKey.root secretKey.otsSecret forgery.message forgery.signature log digest + hdigest hadmissible prefixState finalState verifyFuel prefixCache finalCache verified + hprefixLift.2.1 hprefixLift.2.2 hf hverify (by + simpa [secretKeyWithFtsTable] using huncovered) + have hsigned := signedFtsLeaf_of_revealed_signingTraceComputation_at_reference + secretKey table computation prefixFuel initialCache prefixCache prefixState forgery log hsynced + (mergedCache secretKey.parameter table finalCache) hle f hf hprefix + (probe.index, probe.tree, probe.leafIdx) revealedValue hrevealed + exact hnotSigned hsigned + +end SphincsSecurity.Concrete.FtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/FtsResidualCharge.lean b/formal/sphincs/SphincsSecurity/Proof/FtsResidualCharge.lean new file mode 100644 index 00000000..ad2271e0 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FtsResidualCharge.lean @@ -0,0 +1,31 @@ +import SphincsSecurity.Proof.JointPrimitiveQueryBudget +import SphincsSecurity.Proof.FtsProbeQueryCharge + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem residualPrimitiveQueryCharge_ge_two_of_children_settled + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) (position : Position) + (hat : AtPosition secretKey.parameter input position) + (hchildren : ∀ child ∈ position.children, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache child) : + 2 ≤ residualPrimitiveQueryCharge secretKey cache input := by + have h := TightEncoding.refinedStructuralEncodingQueryCharge_le_one_of_children_settled + secretKey cache input position hat hchildren + have hsub := tsub_le_tsub_left h (3 : ℝ≥0∞) + have heq : (3 : ℝ≥0∞) - 1 = 2 := by + exact (ENNReal.eq_sub_of_add_eq' (by norm_num) + (show (2 : ℝ≥0∞) + 1 = 3 by norm_num)).symm + rw [heq] at hsub + exact hsub + +theorem residualPrimitiveQueryCharge_ge_two_ftsProbe + (secretKey : SecretKey) (cache : QueryCache HashSpec) (probe : FtsSecretProbe) : + 2 ≤ residualPrimitiveQueryCharge secretKey cache (probe.input secretKey.parameter) := by + apply residualPrimitiveQueryCharge_ge_two_of_children_settled secretKey cache _ + (.ftsLeaf probe.index probe.tree probe.leafIdx) ⟨digestBytes probe.candidate, rfl⟩ + intro child hchild + simp only [Position.children, List.not_mem_nil] at hchild + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/FullTrace.lean b/formal/sphincs/SphincsSecurity/Proof/FullTrace.lean new file mode 100644 index 00000000..f78e8631 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FullTrace.lean @@ -0,0 +1,1208 @@ +import SphincsSecurity.Proof.TracedGame +import SphincsSecurity.Proof.RootCache + +/-! +# Signer intervals and direct adversary queries + +This trace retains the signer cache intervals together with every query issued directly by the +adversary. Projecting the direct-query log recovers the signer-only traced execution exactly. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +structure AdversaryCacheEntry where + input : (OracleWorld + SigningSpec).Domain + output : (OracleWorld + SigningSpec).Range input + initialCache : QueryCache HashSpec + finalCache : QueryCache HashSpec + +structure FullAdversaryTrace where + signing : SigningCacheTrace + direct : QueryLog (OracleWorld + SigningSpec) + intervals : List AdversaryCacheEntry + +def AdversaryCacheEntry.queryEntry (entry : AdversaryCacheEntry) : + (input : (OracleWorld + SigningSpec).Domain) × + (OracleWorld + SigningSpec).Range input := + ⟨entry.input, entry.output⟩ + +def AdversaryCacheEntry.signingEntry? : AdversaryCacheEntry → Option SigningCacheEntry + | ⟨.inl _, _, _, _⟩ => none + | ⟨.inr request, output, initialCache, finalCache⟩ => + some ⟨request, output, initialCache, finalCache⟩ + +def FullAdversaryTrace.Consistent (trace : FullAdversaryTrace) : Prop := + trace.intervals.map AdversaryCacheEntry.queryEntry = trace.direct + ∧ trace.intervals.filterMap AdversaryCacheEntry.signingEntry? = trace.signing + +def FullAdversaryTrace.IntervalsLe + (trace : FullAdversaryTrace) (cache : QueryCache HashSpec) : Prop := + ∀ entry ∈ trace.intervals, entry.initialCache ≤ cache ∧ entry.finalCache ≤ cache + +def FullAdversaryTrace.ValidIntervals + (trace : FullAdversaryTrace) (secretKey : SecretKey) : Prop := + ∀ entry ∈ trace.intervals, + (entry.output, entry.finalCache) ∈ support + ((unloggedMappedAdversaryImpl secretKey entry.input).run entry.initialCache) + +def FullAdversaryTrace.Chronological : List AdversaryCacheEntry → Prop + | [] => True + | entry :: rest => + (∀ later ∈ rest, entry.finalCache ≤ later.initialCache) + ∧ FullAdversaryTrace.Chronological rest + +def FullAdversaryTrace.CacheChain (start : QueryCache HashSpec) : + List AdversaryCacheEntry → QueryCache HashSpec → Prop + | [], finish => finish = start + | entry :: rest, finish => + entry.initialCache = start ∧ + FullAdversaryTrace.CacheChain entry.finalCache rest finish + +theorem FullAdversaryTrace.Chronological.get_finalCache_le_initialCache + {intervals : List AdversaryCacheEntry} + (hchronological : FullAdversaryTrace.Chronological intervals) + (earlier later : Fin intervals.length) (hlt : earlier.val < later.val) : + (intervals.get earlier).finalCache ≤ (intervals.get later).initialCache := by + induction intervals with + | nil => exact Fin.elim0 earlier + | cons head rest ih => + cases earlier using Fin.cases with + | zero => + cases later using Fin.cases with + | zero => omega + | succ later => + exact hchronological.1 (rest.get later) (List.get_mem rest later) + | succ earlier => + cases later using Fin.cases with + | zero => simp at hlt + | succ later => + exact ih hchronological.2 earlier later (by simpa using hlt) + +theorem FullAdversaryTrace.CacheChain.append_singleton + {start current : QueryCache HashSpec} {intervals : List AdversaryCacheEntry} + (hchain : FullAdversaryTrace.CacheChain start intervals current) + (entry : AdversaryCacheEntry) (hinitial : entry.initialCache = current) : + FullAdversaryTrace.CacheChain start (intervals ++ [entry]) entry.finalCache := by + induction intervals generalizing start with + | nil => + change current = start at hchain + change entry.initialCache = start ∧ entry.finalCache = entry.finalCache + exact ⟨hinitial.trans hchain, rfl⟩ + | cons head rest ih => + rw [List.cons_append] + rcases hchain with ⟨rfl, hrest⟩ + exact ⟨rfl, ih hrest⟩ + +theorem FullAdversaryTrace.CacheChain.transition_before + {start finish : QueryCache HashSpec} {intervals : List AdversaryCacheEntry} + (hchain : FullAdversaryTrace.CacheChain start intervals finish) + (input : HashInput) (selected : Fin intervals.length) + (hstart : start input = none) + (hselected : (intervals.get selected).initialCache input ≠ none) : + ∃ source : Fin intervals.length, + source.val < selected.val + ∧ (intervals.get source).initialCache input = none + ∧ (intervals.get source).finalCache input ≠ none := by + induction intervals generalizing start finish with + | nil => exact Fin.elim0 selected + | cons head rest ih => + rcases hchain with ⟨hhead, hrest⟩ + obtain ⟨selected, hselectedLt⟩ := selected + cases selected with + | zero => + exfalso + apply hselected + simp only [List.get_eq_getElem, List.getElem_cons_zero, hhead, hstart] + | succ selected => + by_cases hnext : head.finalCache input = none + · have hselected' : + (rest.get ⟨selected, by simpa using hselectedLt⟩).initialCache input ≠ none := by + simpa only [List.get_eq_getElem, List.getElem_cons_succ] using hselected + obtain ⟨source, hsourceLt, hsourceInitial, hsourceFinal⟩ := + ih hrest ⟨selected, by simpa using hselectedLt⟩ hnext hselected' + refine ⟨⟨source.val + 1, Nat.succ_lt_succ source.isLt⟩, ?_, ?_, ?_⟩ + · change source.val + 1 < selected + 1 + exact Nat.succ_lt_succ hsourceLt + · simpa only [List.get_eq_getElem, List.getElem_cons_succ] using hsourceInitial + · simpa only [List.get_eq_getElem, List.getElem_cons_succ] using hsourceFinal + · refine ⟨⟨0, by simp⟩, ?_, ?_, hnext⟩ + · change 0 < selected + 1 + omega + simp only [List.get_eq_getElem, List.getElem_cons_zero, hhead, hstart] + +theorem FullAdversaryTrace.CacheChain.transition_to_finish + {start finish : QueryCache HashSpec} {intervals : List AdversaryCacheEntry} + (hchain : FullAdversaryTrace.CacheChain start intervals finish) + (input : HashInput) (hstart : start input = none) (hfinish : finish input ≠ none) : + ∃ source : Fin intervals.length, + (intervals.get source).initialCache input = none + ∧ (intervals.get source).finalCache input ≠ none := by + induction intervals generalizing start finish with + | nil => + change finish = start at hchain + rw [hchain, hstart] at hfinish + exact (hfinish rfl).elim + | cons head rest ih => + rcases hchain with ⟨hhead, hrest⟩ + by_cases hnext : head.finalCache input = none + · obtain ⟨source, hsourceInitial, hsourceFinal⟩ := + ih hrest hnext hfinish + exact ⟨⟨source.val + 1, Nat.succ_lt_succ source.isLt⟩, + by simpa only [List.get_eq_getElem, List.getElem_cons_succ] using hsourceInitial, + by simpa only [List.get_eq_getElem, List.getElem_cons_succ] using hsourceFinal⟩ + · exact ⟨⟨0, by simp⟩, + by simpa only [List.get_eq_getElem, List.getElem_cons_zero, hhead] using hstart, + by simpa only [List.get_eq_getElem, List.getElem_cons_zero] using hnext⟩ + +theorem FullAdversaryTrace.CacheChain.start_le_get_initialCache + {start finish : QueryCache HashSpec} {intervals : List AdversaryCacheEntry} + (hchain : FullAdversaryTrace.CacheChain start intervals finish) + (hmono : ∀ entry ∈ intervals, entry.initialCache ≤ entry.finalCache) + (position : Fin intervals.length) : + start ≤ (intervals.get position).initialCache := by + induction intervals generalizing start finish with + | nil => exact Fin.elim0 position + | cons head rest ih => + rcases hchain with ⟨hhead, hrest⟩ + cases position using Fin.cases with + | zero => exact le_of_eq hhead.symm + | succ position => + rw [← hhead] + exact (hmono head (by simp)).trans + (ih hrest (fun entry hentry => hmono entry (by simp [hentry])) position) + +theorem FullAdversaryTrace.CacheChain.transition_after + {start finish : QueryCache HashSpec} {intervals : List AdversaryCacheEntry} + (hchain : FullAdversaryTrace.CacheChain start intervals finish) + (hchronological : FullAdversaryTrace.Chronological intervals) + (hmono : ∀ entry ∈ intervals, entry.initialCache ≤ entry.finalCache) + (selected : Fin intervals.length) (input : HashInput) + (hselected : (intervals.get selected).finalCache input = none) + (hfinish : finish input ≠ none) : + ∃ source : Fin intervals.length, + selected.val < source.val + ∧ (intervals.get source).initialCache input = none + ∧ (intervals.get source).finalCache input ≠ none := by + have hstart : start input = none := by + by_contra hcached + obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hcached + have hle := hchain.start_le_get_initialCache hmono selected + have hinitial := hle hanswer + have hfinal := hmono (intervals.get selected) (List.get_mem _ selected) hinitial + rw [hselected] at hfinal + simp at hfinal + obtain ⟨source, hsourceInitial, hsourceFinal⟩ := + hchain.transition_to_finish input hstart hfinish + refine ⟨source, ?_, hsourceInitial, hsourceFinal⟩ + by_contra hnotAfter + have hle : source.val ≤ selected.val := Nat.le_of_not_gt hnotAfter + rcases hle.eq_or_lt with heq | hlt + · have hsame : source = selected := Fin.ext heq + subst source + exact hsourceFinal hselected + · have hcacheLe := hchronological.get_finalCache_le_initialCache source selected hlt + obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hsourceFinal + have hfinal := hmono (intervals.get selected) (List.get_mem _ selected) + (hcacheLe hanswer) + rw [hselected] at hfinal + simp at hfinal + +theorem FullAdversaryTrace.Chronological.append_singleton + {intervals : List AdversaryCacheEntry} {entry : AdversaryCacheEntry} + (hchronological : FullAdversaryTrace.Chronological intervals) + (hle : ∀ earlier ∈ intervals, earlier.finalCache ≤ entry.initialCache) : + FullAdversaryTrace.Chronological (intervals ++ [entry]) := by + induction intervals with + | nil => simp [FullAdversaryTrace.Chronological] + | cons head rest ih => + rw [List.cons_append] + constructor + · intro later hlater + rw [List.mem_append] at hlater + rcases hlater with hlater | hlater + · exact hchronological.1 later hlater + · simp only [List.mem_singleton] at hlater + subst later + exact hle head (by simp) + · exact ih hchronological.2 (fun earlier hearlier => + hle earlier (List.mem_cons_of_mem head hearlier)) + +def directHashQueries : QueryLog (OracleWorld + SigningSpec) → List (HashInput × HashOutput) + | [] => [] + | ⟨.inl (.inr input), output⟩ :: rest => (input, output) :: directHashQueries rest + | _ :: rest => directHashQueries rest + +theorem mem_directHashQueries_iff (log : QueryLog (OracleWorld + SigningSpec)) + (input : HashInput) (output : HashOutput) : + (input, output) ∈ directHashQueries log ↔ + (⟨.inl (.inr input), output⟩ : + (query : (OracleWorld + SigningSpec).Domain) × + (OracleWorld + SigningSpec).Range query) ∈ log := by + induction log with + | nil => simp [directHashQueries] + | cons head rest ih => + obtain ⟨headInput, headOutput⟩ := head + cases headInput with + | inl worldInput => + cases worldInput with + | inl uniformInput => simp [directHashQueries, ih] + | inr hashInput => simp [directHashQueries, ih] + | inr request => simp [directHashQueries, ih] + +def isDirectHashQuery : (OracleWorld + SigningSpec).Domain → Prop + | .inl (.inr _) => True + | _ => False + +instance : DecidablePred isDirectHashQuery := fun input => by + cases input with + | inl worldInput => + cases worldInput with + | inl _ => exact isFalse id + | inr _ => exact isTrue trivial + | inr _ => exact isFalse id + +theorem directHashQueries_length_eq_countQ + (log : QueryLog (OracleWorld + SigningSpec)) : + (directHashQueries log).length = log.countQ isDirectHashQuery := by + induction log with + | nil => simp [directHashQueries, QueryLog.countQ] + | cons entry rest ih => + obtain ⟨input, output⟩ := entry + rcases input with worldInput | request + · rcases worldInput with uniformInput | hashInput + · simpa [directHashQueries, QueryLog.countQ, QueryLog.getQ_cons, + isDirectHashQuery] using ih + · simpa [directHashQueries, QueryLog.countQ, QueryLog.getQ_cons, + isDirectHashQuery] using congrArg Nat.succ ih + · simpa [directHashQueries, QueryLog.countQ, QueryLog.getQ_cons, + isDirectHashQuery] using ih + +def FullAdversaryTrace.hashQueries (trace : FullAdversaryTrace) : + List (HashInput × HashOutput) := + directHashQueries trace.direct + +theorem directHashQueries_length_le (log : QueryLog (OracleWorld + SigningSpec)) : + (directHashQueries log).length ≤ log.length := by + induction log with + | nil => simp [directHashQueries] + | cons entry rest ih => + obtain ⟨input, output⟩ := entry + rcases input with worldInput | request + · rcases worldInput with uniformInput | hashInput + · simpa [directHashQueries] using Nat.le.step ih + · simpa [directHashQueries] using Nat.succ_le_succ ih + · simpa [directHashQueries] using Nat.le.step ih + +def fullAdversaryTraceUpdate + (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (finalCache : QueryCache HashSpec) + (trace : FullAdversaryTrace) : FullAdversaryTrace where + signing := signingCacheTraceUpdate input initialCache output finalCache trace.signing + direct := trace.direct ++ [⟨input, output⟩] + intervals := trace.intervals ++ [⟨input, output, initialCache, finalCache⟩] + +theorem fullAdversaryTraceUpdate_consistent + (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (finalCache : QueryCache HashSpec) (trace : FullAdversaryTrace) + (hconsistent : trace.Consistent) : + (fullAdversaryTraceUpdate input initialCache output finalCache trace).Consistent := by + rcases hconsistent with ⟨hdirect, hsigning⟩ + constructor + · simp [fullAdversaryTraceUpdate, AdversaryCacheEntry.queryEntry, hdirect] + · rw [fullAdversaryTraceUpdate, List.filterMap_append, hsigning] + cases input with + | inl worldInput => + simp [AdversaryCacheEntry.signingEntry?, signingCacheTraceUpdate] + | inr request => + simp [AdversaryCacheEntry.signingEntry?, signingCacheTraceUpdate] + +theorem fullAdversaryTraceUpdate_intervalsLe_chronological + (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (finalCache : QueryCache HashSpec) (trace : FullAdversaryTrace) + (hintervals : trace.IntervalsLe initialCache) + (hchronological : FullAdversaryTrace.Chronological trace.intervals) + (hle : initialCache ≤ finalCache) : + (fullAdversaryTraceUpdate input initialCache output finalCache trace).IntervalsLe finalCache + ∧ FullAdversaryTrace.Chronological + (fullAdversaryTraceUpdate input initialCache output finalCache trace).intervals := by + constructor + · intro entry hentry + rw [fullAdversaryTraceUpdate, List.mem_append] at hentry + rcases hentry with hentry | hentry + · exact ⟨(hintervals entry hentry).1.trans hle, (hintervals entry hentry).2.trans hle⟩ + · simp only [List.mem_singleton] at hentry + subst entry + exact ⟨hle, le_rfl⟩ + · apply hchronological.append_singleton + exact fun earlier hearlier => (hintervals earlier hearlier).2 + +theorem fullAdversaryTraceUpdate_validIntervals + (secretKey : SecretKey) + (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (finalCache : QueryCache HashSpec) (trace : FullAdversaryTrace) + (hvalid : trace.ValidIntervals secretKey) + (hquery : (output, finalCache) ∈ support + ((unloggedMappedAdversaryImpl secretKey input).run initialCache)) : + (fullAdversaryTraceUpdate input initialCache output finalCache trace).ValidIntervals + secretKey := by + intro entry hentry + rw [fullAdversaryTraceUpdate, List.mem_append] at hentry + rcases hentry with hentry | hentry + · exact hvalid entry hentry + · simp only [List.mem_singleton] at hentry + subst entry + exact hquery + +noncomputable def fullTracedMappedAdversaryImpl (secretKey : SecretKey) : + QueryImpl (OracleWorld + SigningSpec) + (StateT (QueryCache HashSpec × FullAdversaryTrace) ProbComp) := + QueryImpl.extendState (unloggedMappedAdversaryImpl secretKey) fullAdversaryTraceUpdate + +theorem fullTracedMappedAdversaryImpl_signing_projection + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (initialTrace : FullAdversaryTrace) : + Prod.map id (fun state => (state.1, state.2.signing)) <$> + (simulateQ (fullTracedMappedAdversaryImpl secretKey) + computation).run (initialCache, initialTrace) = + (simulateQ (cacheTracedMappedAdversaryImpl secretKey) + computation).run (initialCache, initialTrace.signing) := by + apply OracleComp.map_run_simulateQ_eq_of_query_map_eq + (fullTracedMappedAdversaryImpl secretKey) + (cacheTracedMappedAdversaryImpl secretKey) + (fun state => (state.1, state.2.signing)) + intro input state + rw [fullTracedMappedAdversaryImpl, cacheTracedMappedAdversaryImpl, + QueryImpl.extendState_apply, QueryImpl.extendState_apply, map_bind] + apply bind_congr + intro result + rfl + +theorem fullTracedMappedAdversaryImpl_support_invariants + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (initialTrace : FullAdversaryTrace) + (result : α × (QueryCache HashSpec × FullAdversaryTrace)) + (hcaches : initialTrace.signing.CachesLe initialCache) + (hchronological : initialTrace.signing.Chronological) + (hvalid : initialTrace.signing.ValidRuns secretKey) + (hmem : result ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl secretKey) + computation).run (initialCache, initialTrace))) : + result.2.2.signing.CachesLe result.2.1 + ∧ result.2.2.signing.Chronological + ∧ result.2.2.signing.ValidRuns secretKey := by + have hprojection : + (result.1, (result.2.1, result.2.2.signing)) ∈ support + ((simulateQ (cacheTracedMappedAdversaryImpl secretKey) + computation).run (initialCache, initialTrace.signing)) := by + rw [← fullTracedMappedAdversaryImpl_signing_projection, support_map] + exact ⟨result, hmem, rfl⟩ + have hcacheChronological := cacheTracedMappedAdversaryImpl_cachesLe_chronological secretKey + computation initialCache initialTrace.signing + (result.1, (result.2.1, result.2.2.signing)) hcaches hchronological hprojection + exact ⟨hcacheChronological.1, hcacheChronological.2, + cacheTracedMappedAdversaryImpl_validRuns secretKey computation initialCache + initialTrace.signing (result.1, (result.2.1, result.2.2.signing)) hvalid hprojection⟩ + +theorem fullTracedMappedAdversaryImpl_interval_invariants + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (initialTrace : FullAdversaryTrace) + (result : α × (QueryCache HashSpec × FullAdversaryTrace)) + (hconsistent : initialTrace.Consistent) + (hintervals : initialTrace.IntervalsLe initialCache) + (hchronological : FullAdversaryTrace.Chronological initialTrace.intervals) + (hmem : result ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl secretKey) + computation).run (initialCache, initialTrace))) : + result.2.2.Consistent + ∧ result.2.2.IntervalsLe result.2.1 + ∧ FullAdversaryTrace.Chronological result.2.2.intervals := by + exact OracleComp.simulateQ_run_preservesInv + (fullTracedMappedAdversaryImpl secretKey) + (fun state => state.2.Consistent ∧ state.2.IntervalsLe state.1 + ∧ FullAdversaryTrace.Chronological state.2.intervals) + (by + intro input state hstate queryResult hquery + rw [fullTracedMappedAdversaryImpl, QueryImpl.extendState_apply, + mem_support_bind_iff] at hquery + obtain ⟨underlyingResult, hunderlying, hpure⟩ := hquery + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst queryResult + have hle := unloggedMappedAdversaryImpl_cache_le secretKey input state.1 + underlyingResult hunderlying + have hnext := fullAdversaryTraceUpdate_intervalsLe_chronological input state.1 + underlyingResult.1 underlyingResult.2 state.2 hstate.2.1 hstate.2.2 hle + exact ⟨fullAdversaryTraceUpdate_consistent input state.1 underlyingResult.1 + underlyingResult.2 state.2 hstate.1, + hnext.1, hnext.2⟩) + computation (initialCache, initialTrace) + ⟨hconsistent, hintervals, hchronological⟩ result hmem + +theorem fullTracedMappedAdversaryImpl_validIntervals + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (initialTrace : FullAdversaryTrace) + (result : α × (QueryCache HashSpec × FullAdversaryTrace)) + (hvalid : initialTrace.ValidIntervals secretKey) + (hmem : result ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl secretKey) + computation).run (initialCache, initialTrace))) : + result.2.2.ValidIntervals secretKey := by + exact OracleComp.simulateQ_run_preservesInv + (fullTracedMappedAdversaryImpl secretKey) + (fun state => state.2.ValidIntervals secretKey) + (by + intro input state hstate queryResult hquery + rw [fullTracedMappedAdversaryImpl, QueryImpl.extendState_apply, + mem_support_bind_iff] at hquery + obtain ⟨underlyingResult, hunderlying, hpure⟩ := hquery + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst queryResult + exact fullAdversaryTraceUpdate_validIntervals secretKey input state.1 + underlyingResult.1 underlyingResult.2 state.2 hstate hunderlying) + computation (initialCache, initialTrace) hvalid result hmem + +theorem fullTracedMappedAdversaryImpl_cacheChain + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (start initialCache : QueryCache HashSpec) (initialTrace : FullAdversaryTrace) + (result : α × (QueryCache HashSpec × FullAdversaryTrace)) + (hchain : FullAdversaryTrace.CacheChain start initialTrace.intervals initialCache) + (hmem : result ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl secretKey) + computation).run (initialCache, initialTrace))) : + FullAdversaryTrace.CacheChain start result.2.2.intervals result.2.1 := by + exact OracleComp.simulateQ_run_preservesInv + (fullTracedMappedAdversaryImpl secretKey) + (fun state => FullAdversaryTrace.CacheChain start state.2.intervals state.1) + (by + intro input state hstate queryResult hquery + rw [fullTracedMappedAdversaryImpl, QueryImpl.extendState_apply, + mem_support_bind_iff] at hquery + obtain ⟨underlyingResult, _, hpure⟩ := hquery + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst queryResult + exact hstate.append_singleton + ⟨input, underlyingResult.1, state.1, underlyingResult.2⟩ rfl) + computation (initialCache, initialTrace) hchain result hmem + +theorem fullTracedMappedAdversaryImpl_direct_countQ_le + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + ∀ (q : Nat), computation.IsQueryBoundP isDirectHashQuery q → + ∀ (initialCache : QueryCache HashSpec) (initialTrace : FullAdversaryTrace) + (result : α × (QueryCache HashSpec × FullAdversaryTrace)), + result ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl secretKey) + computation).run (initialCache, initialTrace)) → + result.2.2.direct.countQ isDirectHashQuery ≤ + initialTrace.direct.countQ isDirectHashQuery + q := by + induction computation using OracleComp.inductionOn with + | pure x => + intro q hq initialCache initialTrace result hmem + simp only [simulateQ_pure] at hmem + subst result + simp + | query_bind input continuation ih => + intro q hq initialCache initialTrace result hmem + rw [isQueryBoundP_query_bind_iff] at hq + rw [simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hmem + obtain ⟨queryResult, hquery, hrest⟩ := hmem + have hquery' := hquery + rw [simulateQ_spec_query, fullTracedMappedAdversaryImpl, + QueryImpl.extendState_apply, + mem_support_bind_iff] at hquery' + obtain ⟨underlyingResult, _, hpure⟩ := hquery' + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst queryResult + have htail := ih underlyingResult.1 + (if isDirectHashQuery input then q - 1 else q) (hq.2 underlyingResult.1) + underlyingResult.2 + (fullAdversaryTraceUpdate input initialCache underlyingResult.1 underlyingResult.2 + initialTrace) + result hrest + simp only [fullAdversaryTraceUpdate, QueryLog.countQ_append] at htail + by_cases hinput : isDirectHashQuery input + · have hpos : 0 < q := hq.1.resolve_left (not_not_intro hinput) + simp [QueryLog.countQ, QueryLog.getQ_cons, hinput] at htail + simp only [QueryLog.countQ] + omega + · simp [QueryLog.countQ, QueryLog.getQ_cons, hinput] at htail + simp only [QueryLog.countQ] + omega + +theorem fullTracedMappedAdversaryImpl_hashQueries_length_le + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (q : Nat) + (hq : computation.IsQueryBoundP isDirectHashQuery q) + (initialCache : QueryCache HashSpec) + (result : α × (QueryCache HashSpec × FullAdversaryTrace)) + (hmem : result ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl secretKey) + computation).run (initialCache, ⟨[], [], []⟩))) : + result.2.2.hashQueries.length ≤ q := by + rw [FullAdversaryTrace.hashQueries, directHashQueries_length_eq_countQ] + simpa [QueryLog.countQ] using + fullTracedMappedAdversaryImpl_direct_countQ_le secretKey computation q hq initialCache + ⟨[], [], []⟩ result hmem + +theorem FullAdversaryTrace.directHashInterval_cached + {trace : FullAdversaryTrace} {secretKey : SecretKey} + (hvalid : trace.ValidIntervals secretKey) + (input : HashInput) (answer : HashOutput) + (initialCache finalCache : QueryCache HashSpec) + (hmem : (⟨.inl (.inr input), answer, initialCache, finalCache⟩ : + AdversaryCacheEntry) ∈ trace.intervals) : + finalCache input = some answer := by + have hrun := hvalid _ hmem + change (answer, finalCache) ∈ support ((romImpl (.inr input)).run initialCache) at hrun + change (answer, finalCache) ∈ support + (((uniformSampleImpl.withCaching : QueryImpl HashSpec _) input).run initialCache) at hrun + cases hcache : initialCache input with + | some cachedAnswer => + rw [QueryImpl.withCaching_run_some uniformSampleImpl hcache, + support_pure, Set.mem_singleton_iff] at hrun + obtain ⟨rfl, rfl⟩ := hrun + exact hcache + | none => + rw [QueryImpl.withCaching_run_none uniformSampleImpl hcache, support_map] at hrun + obtain ⟨sampledAnswer, _, heq⟩ := hrun + obtain ⟨rfl, rfl⟩ := heq + exact QueryCache.cacheQuery_self initialCache input answer + +theorem FullAdversaryTrace.directHashInterval_eq_of_cached + {trace : FullAdversaryTrace} {secretKey : SecretKey} + (hvalid : trace.ValidIntervals secretKey) + (input : HashInput) (answer cachedAnswer : HashOutput) + (initialCache finalCache : QueryCache HashSpec) + (hmem : (⟨.inl (.inr input), answer, initialCache, finalCache⟩ : + AdversaryCacheEntry) ∈ trace.intervals) + (hcached : initialCache input = some cachedAnswer) : + answer = cachedAnswer ∧ finalCache = initialCache := by + have hrun := hvalid _ hmem + change (answer, finalCache) ∈ support + (((uniformSampleImpl.withCaching : QueryImpl HashSpec _) input).run initialCache) at hrun + rw [QueryImpl.withCaching_run_some uniformSampleImpl hcached, + support_pure, Set.mem_singleton_iff] at hrun + exact Prod.mk.inj hrun + +theorem FullAdversaryTrace.directHashInterval_eq_cacheQuery_of_fresh + {trace : FullAdversaryTrace} {secretKey : SecretKey} + (hvalid : trace.ValidIntervals secretKey) + (input : HashInput) (answer : HashOutput) + (initialCache finalCache : QueryCache HashSpec) + (hmem : (⟨.inl (.inr input), answer, initialCache, finalCache⟩ : + AdversaryCacheEntry) ∈ trace.intervals) + (hfresh : initialCache input = none) : + finalCache = initialCache.cacheQuery input answer := by + have hrun := hvalid _ hmem + change (answer, finalCache) ∈ support + (((uniformSampleImpl.withCaching : QueryImpl HashSpec _) input).run initialCache) at hrun + rw [QueryImpl.withCaching_run_none uniformSampleImpl hfresh, support_map] at hrun + obtain ⟨sampledAnswer, _, heq⟩ := hrun + obtain ⟨rfl, rfl⟩ := heq + rfl + +theorem FullAdversaryTrace.exists_intervalPosition_of_signingEntry + {trace : FullAdversaryTrace} (hconsistent : trace.Consistent) + (entry : SigningCacheEntry) (hentry : entry ∈ trace.signing) : + ∃ position : Fin trace.intervals.length, + AdversaryCacheEntry.signingEntry? (trace.intervals.get position) = some entry := by + have hfiltered : entry ∈ + trace.intervals.filterMap AdversaryCacheEntry.signingEntry? := by + rw [hconsistent.2] + exact hentry + rw [List.mem_filterMap] at hfiltered + obtain ⟨interval, hinterval, hsigning⟩ := hfiltered + obtain ⟨position, hposition⟩ := List.mem_iff_get.1 hinterval + exact ⟨position, by rw [hposition]; exact hsigning⟩ + +theorem AdversaryCacheEntry.initialCache_eq_of_signingEntry?_eq_some + {interval : AdversaryCacheEntry} {entry : SigningCacheEntry} + (hentry : interval.signingEntry? = some entry) : + interval.initialCache = entry.initialCache := by + rcases interval with ⟨input, output, initialCache, finalCache⟩ + cases input with + | inl worldInput => simp [AdversaryCacheEntry.signingEntry?] at hentry + | inr request => + simp only [AdversaryCacheEntry.signingEntry?, Option.some.injEq] at hentry + exact congrArg SigningCacheEntry.initialCache hentry + +theorem AdversaryCacheEntry.finalCache_eq_of_signingEntry?_eq_some + {interval : AdversaryCacheEntry} {entry : SigningCacheEntry} + (hentry : interval.signingEntry? = some entry) : + interval.finalCache = entry.finalCache := by + rcases interval with ⟨input, output, initialCache, finalCache⟩ + cases input with + | inl worldInput => simp [AdversaryCacheEntry.signingEntry?] at hentry + | inr request => + simp only [AdversaryCacheEntry.signingEntry?, Option.some.injEq] at hentry + exact congrArg SigningCacheEntry.finalCache hentry + +private theorem filterMap_get_order {α β : Type} (filter : α → Option β) + (list : List α) (left right : Fin list.length) (hlt : left.val < right.val) + (leftValue rightValue : β) + (hleft : filter (list.get left) = some leftValue) + (hright : filter (list.get right) = some rightValue) : + ∃ (left' right' : Fin (list.filterMap filter).length), + left'.val < right'.val + ∧ (list.filterMap filter).get left' = leftValue + ∧ (list.filterMap filter).get right' = rightValue := by + induction list with + | nil => exact left.elim0 + | cons head tail ih => + cases left using Fin.cases with + | zero => + cases right using Fin.cases with + | zero => simp at hlt + | succ right => + simp only [List.get_cons_zero] at hleft + have hmem : rightValue ∈ tail.filterMap filter := by + rw [List.mem_filterMap] + exact ⟨tail.get right, List.get_mem tail right, hright⟩ + obtain ⟨right', hright'⟩ := List.mem_iff_get.1 hmem + rw [List.filterMap_cons, hleft] + refine ⟨⟨0, by simp⟩, right'.succ, by simp, by simp, ?_⟩ + simpa using hright' + | succ left => + cases right using Fin.cases with + | zero => simp at hlt + | succ right => + obtain ⟨left', right', hlt', hleft', hright'⟩ := + ih left right (by simpa using hlt) hleft hright + cases hhead : filter head with + | none => + rw [List.filterMap_cons, hhead] + exact ⟨left', right', hlt', hleft', hright'⟩ + | some value => + rw [List.filterMap_cons, hhead] + refine ⟨left'.succ, right'.succ, by simpa using hlt', ?_, ?_⟩ + · simpa using hleft' + · simpa using hright' + +private theorem filterMap_getElem?_preimage_with_earlier {α β : Type} + (filter : α → Option β) (list : List α) (selected : Nat) (selectedValue : β) + (hselected : (list.filterMap filter)[selected]? = some selectedValue) : + ∃ (selectedSource : Nat) (sourceElement : α), + list[selectedSource]? = some sourceElement + ∧ filter sourceElement = some selectedValue + ∧ ((list.take selectedSource).filterMap filter).length = selected + ∧ ∀ (source : Nat) (sourceElement : α) (sourceValue : β), source < selectedSource → + list[source]? = some sourceElement → filter sourceElement = some sourceValue → + ∃ source', source' < selected + ∧ (list.filterMap filter)[source']? = some sourceValue := by + induction list generalizing selected with + | nil => simp at hselected + | cons head tail ih => + cases hhead : filter head with + | none => + simp only [List.filterMap_cons, hhead] at hselected + obtain ⟨selectedSource, sourceElement, hsourceElement, hsourceValue, hrank, + hearlier⟩ := + ih selected hselected + refine ⟨selectedSource + 1, sourceElement, by simpa, hsourceValue, ?_, ?_⟩ + · simpa [List.filterMap_cons, hhead] using hrank + intro source earlierElement earlierValue hlt helement hvalue + cases source with + | zero => + simp only [List.getElem?_cons_zero, Option.some.injEq] at helement + subst earlierElement + rw [hhead] at hvalue + simp at hvalue + | succ source => + simpa [List.filterMap_cons, hhead] using + (hearlier source (sourceElement := earlierElement) + (sourceValue := earlierValue) (by omega) (by simpa using helement) hvalue) + | some headValue => + simp only [List.filterMap_cons, hhead] at hselected + cases selected with + | zero => + simp only [List.getElem?_cons_zero, Option.some.injEq] at hselected + subst selectedValue + refine ⟨0, head, by simp, hhead, by simp, ?_⟩ + intro source _ _ hlt + omega + | succ selected => + simp only [List.getElem?_cons_succ] at hselected + obtain ⟨selectedSource, sourceElement, hsourceElement, hsourceValue, hrank, + hearlier⟩ := + ih selected hselected + refine ⟨selectedSource + 1, sourceElement, by simpa, hsourceValue, ?_, ?_⟩ + · simp [hhead, hrank] + intro source earlierElement earlierValue hlt helement hvalue + cases source with + | zero => + simp only [List.getElem?_cons_zero, Option.some.injEq] at helement + subst earlierElement + have heq : headValue = earlierValue := Option.some.inj (hhead.symm.trans hvalue) + subst earlierValue + exact ⟨0, by omega, by simp [hhead]⟩ + | succ source => + obtain ⟨source', hsourceLt, hsource'⟩ := + hearlier source (sourceElement := earlierElement) + (sourceValue := earlierValue) (by omega) (by simpa using helement) hvalue + exact ⟨source' + 1, by omega, by simpa [hhead] using hsource'⟩ + +theorem FullAdversaryTrace.signingIndex_interval + {trace : FullAdversaryTrace} (hconsistent : trace.Consistent) + (selected : Fin trace.signing.length) : + ∃ selectedSource : Fin trace.intervals.length, + AdversaryCacheEntry.signingEntry? (trace.intervals.get selectedSource) = + some (trace.signing.get selected) + ∧ ((trace.intervals.take selectedSource.val).filterMap + AdversaryCacheEntry.signingEntry?).length = selected.val + ∧ ∀ source : Fin trace.intervals.length, source.val < selectedSource.val → + ∀ sourceEntry : SigningCacheEntry, + AdversaryCacheEntry.signingEntry? (trace.intervals.get source) = some sourceEntry → + ∃ source' : Fin trace.signing.length, + source'.val < selected.val ∧ trace.signing.get source' = sourceEntry := by + have hlength : (trace.intervals.filterMap + AdversaryCacheEntry.signingEntry?).length = trace.signing.length := + congrArg List.length hconsistent.2 + let selected' : Fin (trace.intervals.filterMap + AdversaryCacheEntry.signingEntry?).length := ⟨selected.val, by + rw [hlength] + exact selected.isLt⟩ + have hselectedGet : (trace.intervals.filterMap + AdversaryCacheEntry.signingEntry?)[selected'.val]? = + some ((trace.intervals.filterMap + AdversaryCacheEntry.signingEntry?).get selected') := by + exact List.getElem?_eq_getElem selected'.isLt + obtain ⟨selectedSourceNat, selectedInterval, hselectedInterval, hselectedSource, + hselectedRank, hearlier⟩ := + filterMap_getElem?_preimage_with_earlier AdversaryCacheEntry.signingEntry? + trace.intervals selected'.val + ((trace.intervals.filterMap AdversaryCacheEntry.signingEntry?).get selected') hselectedGet + have hselectedSourceLt : selectedSourceNat < trace.intervals.length := + (List.getElem?_eq_some_iff.1 hselectedInterval).1 + let selectedSource : Fin trace.intervals.length := + ⟨selectedSourceNat, hselectedSourceLt⟩ + have hselectedValue : + (trace.intervals.filterMap AdversaryCacheEntry.signingEntry?).get selected' = + trace.signing.get selected := by + have heq := congrArg (fun list : List SigningCacheEntry => list[selected.val]?) hconsistent.2 + rw [List.getElem?_eq_getElem selected'.isLt, + List.getElem?_eq_getElem selected.isLt] at heq + exact Option.some.inj heq + have hselectedIntervalGet : trace.intervals.get selectedSource = selectedInterval := + (List.getElem?_eq_some_iff.1 hselectedInterval).2 + refine ⟨selectedSource, by + rw [hselectedIntervalGet] + exact hselectedSource.trans (congrArg some hselectedValue), hselectedRank, ?_⟩ + intro source hlt sourceEntry hsource + have hsourceGet : trace.intervals[source.val]? = some (trace.intervals.get source) := + List.getElem?_eq_getElem source.isLt + obtain ⟨sourceNat, hsourceLt, hsourceValue⟩ := + hearlier source.val (trace.intervals.get source) sourceEntry hlt + hsourceGet hsource + have hsourceNatLt : sourceNat < + (trace.intervals.filterMap AdversaryCacheEntry.signingEntry?).length := + (List.getElem?_eq_some_iff.1 hsourceValue).1 + let source' : Fin (trace.intervals.filterMap + AdversaryCacheEntry.signingEntry?).length := ⟨sourceNat, hsourceNatLt⟩ + let source'' : Fin trace.signing.length := ⟨sourceNat, by + rw [← hlength] + exact source'.isLt⟩ + have hsourceValue' : trace.signing.get source'' = sourceEntry := by + have hsourceValueGet : + (trace.intervals.filterMap AdversaryCacheEntry.signingEntry?).get source' = + sourceEntry := (List.getElem?_eq_some_iff.1 hsourceValue).2 + have heq := congrArg (fun list : List SigningCacheEntry => list[sourceNat]?) hconsistent.2 + rw [List.getElem?_eq_getElem source'.isLt, + List.getElem?_eq_getElem source''.isLt] at heq + exact Option.some.inj (heq.symm.trans (congrArg some hsourceValueGet)) + exact ⟨source'', hsourceLt, hsourceValue'⟩ + +theorem FullAdversaryTrace.earlier_signingEntry + {trace : FullAdversaryTrace} (hconsistent : trace.Consistent) + (source selected : Fin trace.intervals.length) (hlt : source.val < selected.val) + (sourceEntry selectedEntry : SigningCacheEntry) + (hsource : AdversaryCacheEntry.signingEntry? (trace.intervals.get source) = + some sourceEntry) + (hselected : AdversaryCacheEntry.signingEntry? (trace.intervals.get selected) = + some selectedEntry) : + ∃ (source' selected' : Fin trace.signing.length), + source'.val < selected'.val + ∧ trace.signing.get source' = sourceEntry + ∧ trace.signing.get selected' = selectedEntry := by + obtain ⟨source', selected', hlt', hsource', hselected'⟩ := + filterMap_get_order AdversaryCacheEntry.signingEntry? trace.intervals source selected hlt + sourceEntry selectedEntry hsource hselected + have hlength : (trace.intervals.filterMap + AdversaryCacheEntry.signingEntry?).length = trace.signing.length := + congrArg List.length hconsistent.2 + let source'' : Fin trace.signing.length := ⟨source'.val, by + rw [← hlength] + exact source'.isLt⟩ + let selected'' : Fin trace.signing.length := ⟨selected'.val, by + rw [← hlength] + exact selected'.isLt⟩ + have hsource'' : trace.signing.get source'' = sourceEntry := by + have heq := congrArg (fun list : List SigningCacheEntry => list[source'.val]?) hconsistent.2 + rw [List.getElem?_eq_getElem source'.isLt] at heq + rw [List.getElem?_eq_getElem source''.isLt] at heq + exact Option.some.inj (((congrArg some hsource').symm.trans heq).symm) + have hselected'' : trace.signing.get selected'' = selectedEntry := by + have heq := congrArg (fun list : List SigningCacheEntry => list[selected'.val]?) hconsistent.2 + rw [List.getElem?_eq_getElem selected'.isLt] at heq + rw [List.getElem?_eq_getElem selected''.isLt] at heq + exact Option.some.inj (((congrArg some hselected').symm.trans heq).symm) + exact ⟨source'', selected'', hlt', hsource'', hselected''⟩ + +theorem FullAdversaryTrace.CacheChain.source_before_signingEntry + {start finish : QueryCache HashSpec} {trace : FullAdversaryTrace} + (hchain : FullAdversaryTrace.CacheChain start trace.intervals finish) + (hconsistent : trace.Consistent) (entry : SigningCacheEntry) + (hentry : entry ∈ trace.signing) (input : HashInput) + (hstart : start input = none) (hcached : entry.initialCache input ≠ none) : + ∃ (source selected : Fin trace.intervals.length), + source.val < selected.val + ∧ AdversaryCacheEntry.signingEntry? (trace.intervals.get selected) = some entry + ∧ (trace.intervals.get source).initialCache input = none + ∧ (trace.intervals.get source).finalCache input ≠ none := by + obtain ⟨selected, hselected⟩ := + FullAdversaryTrace.exists_intervalPosition_of_signingEntry hconsistent entry hentry + have hselectedCache : (trace.intervals.get selected).initialCache input ≠ none := by + rw [(trace.intervals.get selected).initialCache_eq_of_signingEntry?_eq_some hselected] + exact hcached + obtain ⟨source, hlt, hsourceInitial, hsourceFinal⟩ := + hchain.transition_before input selected hstart hselectedCache + exact ⟨source, selected, hlt, hselected, hsourceInitial, hsourceFinal⟩ + +theorem FullAdversaryTrace.transition_source_kind + {trace : FullAdversaryTrace} {secretKey : SecretKey} + (hvalid : trace.ValidIntervals secretKey) (entry : AdversaryCacheEntry) + (hentry : entry ∈ trace.intervals) (target : HashInput) + (hmiss : entry.initialCache target = none) + (hhit : entry.finalCache target ≠ none) : + entry.input = .inl (.inr target) ∨ ∃ request, entry.input = .inr request := by + rcases entry with ⟨input, output, initialCache, finalCache⟩ + change initialCache target = none at hmiss + change finalCache target ≠ none at hhit + cases input with + | inr request => exact Or.inr ⟨request, rfl⟩ + | inl worldInput => + cases worldInput with + | inl uniformInput => + have hrun := hvalid _ hentry + change (output, finalCache) ∈ support + ((unifFwdImpl HashSpec uniformInput).run initialCache) at hrun + have heq : finalCache = initialCache := by + have hforward : + (unifFwdImpl HashSpec uniformInput).run initialCache = + (fun sample => (sample, initialCache)) <$> + (liftM (unifSpec.query uniformInput) : ProbComp _) := by + simpa [simulateQ_query] using + (unifFwdImpl.simulateQ_run + (hashSpec := HashSpec) + (liftM (unifSpec.query uniformInput) : ProbComp _) initialCache) + rw [hforward, support_map] at hrun + obtain ⟨sample, _, hsample⟩ := hrun + exact (congrArg Prod.snd hsample).symm + rw [heq, hmiss] at hhit + exact (hhit rfl).elim + | inr hashInput => + change HashOutput at output + have heqInput : hashInput = target := by + by_contra hne + cases hcached : initialCache hashInput with + | none => + have hfinal := FullAdversaryTrace.directHashInterval_eq_cacheQuery_of_fresh + hvalid hashInput output initialCache finalCache hentry hcached + rw [hfinal, QueryCache.cacheQuery_of_ne _ _ (Ne.symm hne), hmiss] at hhit + exact hhit rfl + | some cachedAnswer => + have hfinal := (FullAdversaryTrace.directHashInterval_eq_of_cached + hvalid hashInput output cachedAnswer initialCache finalCache hentry hcached).2 + rw [hfinal, hmiss] at hhit + exact hhit rfl + exact Or.inl (congrArg (fun value : HashInput => Sum.inl (Sum.inr value)) heqInput) + +noncomputable def gameRestWithFullTrace (adversary : Adversary) + (publicKey : PublicKey) (secretKey : SecretKey) (initialCache : QueryCache HashSpec) : + ProbComp ((Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) := do + let (forgery, adversaryCache, trace) ← + (simulateQ (fullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run (initialCache, ⟨[], [], []⟩) + let (verified, finalCache) ← + (simulateQ romImpl (Concrete.scheme.verify publicKey forgery.message forgery.signature)).run + adversaryCache + let log := trace.signing.toSigningLog + let verdict := decide (SigningTranscript.Valid log ∧ + ¬ SigningTranscript.Contains log forgery) && verified + pure ((forgery, verdict), (finalCache, trace)) + +theorem gameRestWithFullTrace_signing_projection (adversary : Adversary) + (publicKey : PublicKey) (secretKey : SecretKey) (initialCache : QueryCache HashSpec) : + (fun result => (result.1, (result.2.1, result.2.2.signing))) <$> + gameRestWithFullTrace adversary publicKey secretKey initialCache = + gameRestWithSigningTrace adversary publicKey secretKey initialCache := by + let finish : Forgery × (QueryCache HashSpec × SigningCacheTrace) → + ProbComp ((Forgery × Bool) × (QueryCache HashSpec × SigningCacheTrace)) := fun result => do + let (verified, finalCache) ← + (simulateQ romImpl + (Concrete.scheme.verify publicKey result.1.message result.1.signature)).run result.2.1 + let verdict := decide (SigningTranscript.Valid result.2.2.toSigningLog ∧ + ¬ SigningTranscript.Contains result.2.2.toSigningLog result.1) && verified + pure ((result.1, verdict), (finalCache, result.2.2)) + let fullRun := (simulateQ (fullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run (initialCache, ⟨[], [], []⟩) + let signingRun := (simulateQ (cacheTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run (initialCache, []) + have hprojection : + Prod.map id (fun state => (state.1, state.2.signing)) <$> fullRun = signingRun := + fullTracedMappedAdversaryImpl_signing_projection secretKey + (adversary.main publicKey) initialCache ⟨[], [], []⟩ + calc + (fun result => (result.1, (result.2.1, result.2.2.signing))) <$> + gameRestWithFullTrace adversary publicKey secretKey initialCache = + (Prod.map id (fun state => (state.1, state.2.signing)) <$> fullRun) >>= finish := by + simp [gameRestWithFullTrace, fullRun, finish, bind_map_left, map_bind, Prod.map] + rfl + _ = signingRun >>= finish := by rw [hprojection] + _ = gameRestWithSigningTrace adversary publicKey secretKey initialCache := by + simp [gameRestWithSigningTrace, signingRun, finish] + +theorem gameRestWithFullTrace_support_invariants (adversary : Adversary) + (publicKey : PublicKey) (secretKey : SecretKey) (initialCache : QueryCache HashSpec) + (result : (Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hmem : result ∈ support + (gameRestWithFullTrace adversary publicKey secretKey initialCache)) : + result.2.2.signing.ValidRuns secretKey + ∧ result.2.2.signing.CachesLe result.2.1 + ∧ result.2.2.signing.Chronological := by + rw [gameRestWithFullTrace, mem_support_bind_iff] at hmem + obtain ⟨⟨forgery, adversaryCache, trace⟩, hadversary, hfinish⟩ := hmem + rw [mem_support_bind_iff] at hfinish + obtain ⟨⟨verified, finalCache⟩, hverify, hpure⟩ := hfinish + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + have hinvariants := fullTracedMappedAdversaryImpl_support_invariants secretKey + (adversary.main publicKey) initialCache ⟨[], [], []⟩ (forgery, adversaryCache, trace) + (by simp [SigningCacheTrace.CachesLe]) (by simp [SigningCacheTrace.Chronological]) + (by simp [SigningCacheTrace.ValidRuns]) hadversary + exact ⟨hinvariants.2.2, hinvariants.1.mono + (simulateQ_romImpl_cache_le + (Concrete.scheme.verify publicKey forgery.message forgery.signature) + adversaryCache (verified, finalCache) hverify), + hinvariants.2.1⟩ + +theorem gameRestWithFullTrace_support_interval_invariants (adversary : Adversary) + (publicKey : PublicKey) (secretKey : SecretKey) (initialCache : QueryCache HashSpec) + (result : (Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hmem : result ∈ support + (gameRestWithFullTrace adversary publicKey secretKey initialCache)) : + result.2.2.Consistent + ∧ result.2.2.IntervalsLe result.2.1 + ∧ FullAdversaryTrace.Chronological result.2.2.intervals := by + rw [gameRestWithFullTrace, mem_support_bind_iff] at hmem + obtain ⟨⟨forgery, adversaryCache, trace⟩, hadversary, hfinish⟩ := hmem + rw [mem_support_bind_iff] at hfinish + obtain ⟨⟨verified, finalCache⟩, hverify, hpure⟩ := hfinish + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + have hinvariants := fullTracedMappedAdversaryImpl_interval_invariants secretKey + (adversary.main publicKey) initialCache ⟨[], [], []⟩ + (forgery, adversaryCache, trace) + (by simp [FullAdversaryTrace.Consistent]) + (by simp [FullAdversaryTrace.IntervalsLe]) + (by simp [FullAdversaryTrace.Chronological]) hadversary + have hle := simulateQ_romImpl_cache_le + (Concrete.scheme.verify publicKey forgery.message forgery.signature) + adversaryCache (verified, finalCache) hverify + exact ⟨hinvariants.1, fun entry hentry => + ⟨(hinvariants.2.1 entry hentry).1.trans hle, + (hinvariants.2.1 entry hentry).2.trans hle⟩, + hinvariants.2.2⟩ + +theorem gameRestWithFullTrace_support_validIntervals (adversary : Adversary) + (publicKey : PublicKey) (secretKey : SecretKey) (initialCache : QueryCache HashSpec) + (result : (Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hmem : result ∈ support + (gameRestWithFullTrace adversary publicKey secretKey initialCache)) : + result.2.2.ValidIntervals secretKey := by + rw [gameRestWithFullTrace, mem_support_bind_iff] at hmem + obtain ⟨⟨forgery, adversaryCache, trace⟩, hadversary, hfinish⟩ := hmem + rw [mem_support_bind_iff] at hfinish + obtain ⟨_, _, hpure⟩ := hfinish + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + exact fullTracedMappedAdversaryImpl_validIntervals secretKey + (adversary.main publicKey) initialCache ⟨[], [], []⟩ + (forgery, adversaryCache, trace) (by simp [FullAdversaryTrace.ValidIntervals]) hadversary + +theorem gameRestWithFullTrace_support_cacheChain (adversary : Adversary) + (publicKey : PublicKey) (secretKey : SecretKey) (initialCache : QueryCache HashSpec) + (result : (Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hmem : result ∈ support + (gameRestWithFullTrace adversary publicKey secretKey initialCache)) : + ∃ adversaryCache, + FullAdversaryTrace.CacheChain initialCache result.2.2.intervals adversaryCache + ∧ adversaryCache ≤ result.2.1 := by + rw [gameRestWithFullTrace, mem_support_bind_iff] at hmem + obtain ⟨⟨forgery, adversaryCache, trace⟩, hadversary, hfinish⟩ := hmem + rw [mem_support_bind_iff] at hfinish + obtain ⟨⟨verified, finalCache⟩, hverify, hpure⟩ := hfinish + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + refine ⟨adversaryCache, ?_, simulateQ_romImpl_cache_le + (Concrete.scheme.verify publicKey forgery.message forgery.signature) + adversaryCache (verified, finalCache) hverify⟩ + exact fullTracedMappedAdversaryImpl_cacheChain secretKey + (adversary.main publicKey) initialCache initialCache ⟨[], [], []⟩ + (forgery, adversaryCache, trace) rfl hadversary + +namespace Concrete + +noncomputable def gameAfterSecretsWithFullTrace (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ProbComp ((Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) := do + let (root, rootCache) ← (simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : + OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅ + let result ← gameRestWithFullTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache + pure ((root, result.1.1, result.1.2), result.2) + +theorem gameAfterSecretsWithFullTrace_signing_projection (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + (fun result => (result.1, (result.2.1, result.2.2.signing))) <$> + gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret = + gameAfterSecretsWithSigningTrace adversary parameter otsSecret ftsSecret := by + rw [gameAfterSecretsWithFullTrace, gameAfterSecretsWithSigningTrace] + simp only [map_bind] + apply bind_congr + intro rootResult + rw [← gameRestWithFullTrace_signing_projection adversary + (⟨rootResult.1, parameter⟩ : PublicKey) + (⟨parameter, rootResult.1, otsSecret, ftsSecret⟩ : SecretKey) rootResult.2] + simp + +theorem gameAfterSecretsWithFullTrace_projection (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + (fun result => (result.1.2.2, result.2.1)) <$> + gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret = + (simulateQ romImpl (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅ := by + have hprojection := congrArg + (Functor.map (fun result : (Digest × Forgery × Bool) × + (QueryCache HashSpec × SigningCacheTrace) => (result.1.2.2, result.2.1))) + (gameAfterSecretsWithFullTrace_signing_projection adversary parameter otsSecret ftsSecret) + rw [← gameAfterSecretsWithSigningTrace_projection adversary parameter otsSecret ftsSecret] + simpa only [Functor.map_map, Function.comp_def] using hprojection + +theorem gameAfterSecretsWithFullTrace_support_invariants (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hmem : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) : + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.signing.ValidRuns secretKey + ∧ result.2.2.signing.CachesLe result.2.1 + ∧ result.2.2.signing.Chronological := by + rw [gameAfterSecretsWithFullTrace, mem_support_bind_iff] at hmem + obtain ⟨⟨root, rootCache⟩, _, hrest⟩ := hmem + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult, hrest, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + simpa using gameRestWithFullTrace_support_invariants adversary + (⟨root, parameter⟩ : PublicKey) + (⟨parameter, root, otsSecret, ftsSecret⟩ : SecretKey) rootCache restResult hrest + +theorem gameAfterSecretsWithFullTrace_support_interval_invariants (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hmem : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) : + result.2.2.Consistent + ∧ result.2.2.IntervalsLe result.2.1 + ∧ FullAdversaryTrace.Chronological result.2.2.intervals := by + rw [gameAfterSecretsWithFullTrace, mem_support_bind_iff] at hmem + obtain ⟨⟨root, rootCache⟩, _, hrest⟩ := hmem + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult, hrest, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + simpa using gameRestWithFullTrace_support_interval_invariants adversary + (⟨root, parameter⟩ : PublicKey) + (⟨parameter, root, otsSecret, ftsSecret⟩ : SecretKey) rootCache restResult hrest + +theorem gameAfterSecretsWithFullTrace_support_validIntervals (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hmem : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) : + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.ValidIntervals secretKey := by + rw [gameAfterSecretsWithFullTrace, mem_support_bind_iff] at hmem + obtain ⟨⟨root, rootCache⟩, _, hrest⟩ := hmem + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult, hrest, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + simpa using gameRestWithFullTrace_support_validIntervals adversary + (⟨root, parameter⟩ : PublicKey) + (⟨parameter, root, otsSecret, ftsSecret⟩ : SecretKey) rootCache restResult hrest + +theorem gameAfterSecretsWithFullTrace_support_cacheChain (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × FullAdversaryTrace)) + (hmem : result ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret)) : + ∃ rootCache adversaryCache, + (∀ payload, rootCache (tweakableHashInput parameter .message payload) = none) + ∧ (∀ lay tree leafIdx payload, + rootCache (tweakableHashInput parameter (.encoding lay tree leafIdx) payload) = none) + ∧ FullAdversaryTrace.CacheChain rootCache result.2.2.intervals adversaryCache + ∧ adversaryCache ≤ result.2.1 := by + rw [gameAfterSecretsWithFullTrace, mem_support_bind_iff] at hmem + obtain ⟨⟨root, rootCache⟩, hroot, hrest⟩ := hmem + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult, hrest, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + have hroot' : (root, rootCache) ∈ support ((simulateQ + (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅) := by + simpa only [simulateQ_romImpl_liftM] using hroot + obtain ⟨adversaryCache, hchain, hle⟩ := + gameRestWithFullTrace_support_cacheChain adversary + (⟨root, parameter⟩ : PublicKey) + (⟨parameter, root, otsSecret, ftsSecret⟩ : SecretKey) rootCache restResult hrest + exact ⟨rootCache, adversaryCache, + fun payload => treeRoot_cache_message_none parameter topLayer rootTree + (otsSecret topLayer rootTree) root rootCache hroot' payload, + fun lay tree leafIdx payload => treeRoot_cache_encoding_none parameter topLayer rootTree + (otsSecret topLayer rootTree) root rootCache hroot' lay tree leafIdx payload, + hchain, hle⟩ + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Game.lean b/formal/sphincs/SphincsSecurity/Proof/Game.lean new file mode 100644 index 00000000..ba420a21 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Game.lean @@ -0,0 +1,41 @@ +import SphincsSecurity.Proof.QueryBound + +/-! +# Splitting the game at key generation + +Key generation runs first and fixes every honest value, so the reduction reasons about what follows +it against a cache it can treat as given. This module factors the game accordingly: bounding the +advantage reduces to bounding, for each key generation outcome, the winning probability of the rest. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +/-- Everything the game does after key generation: run the adversary against the signing oracle, +verify what it returns, and decide whether that counts as a forgery. -/ +noncomputable def gameRest (scheme : Scheme) (adversary : Adversary) (pk : PublicKey) + (sk : SecretKey) : OracleComp OracleWorld Bool := do + let ((forgery, log) : Forgery × QueryLog SigningSpec) ← + (simulateQ (forwardOracles + signingOracle scheme sk) (adversary.main pk)).run + let verified ← scheme.verify pk forgery.message forgery.signature + return decide (SigningTranscript.Valid log ∧ ¬SigningTranscript.Contains log forgery) && verified + +theorem gameCore_eq (scheme : Scheme) (adversary : Adversary) : + gameCore scheme adversary + = scheme.keygen >>= fun keys => gameRest scheme adversary keys.1 keys.2 := rfl + +/-- **The reduction's frame.** If the rest of the game wins with probability at most `c` from every +cache key generation can leave, the adversary's advantage is at most `c`. -/ +theorem forgeAdvantage_le (scheme : Scheme) (adversary : Adversary) (c : ℝ≥0∞) + (h : ∀ keys : (PublicKey × SecretKey), ∀ cache : QueryCache HashSpec, + (keys, cache) ∈ support ((simulateQ romImpl scheme.keygen).run ∅) → + Pr[fun result => result.1 = true + | (simulateQ romImpl (gameRest scheme adversary keys.1 keys.2)).run cache] ≤ c) : + forgeAdvantage scheme adversary ≤ c := by + rw [forgeAdvantage, gameCore_eq, StateT.run'_eq, probOutput_map, simulateQ_bind, + StateT.run_bind] + refine probEvent_bind_le_of_forall_le fun keysCache hmem => ?_ + exact h keysCache.1 keysCache.2 hmem + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Guess.lean b/formal/sphincs/SphincsSecurity/Proof/Guess.lean new file mode 100644 index 00000000..fa7cc6d2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Guess.lean @@ -0,0 +1,183 @@ +import SphincsSecurity.Proof.Bytes + +/-! +# One guess + +A fresh oracle answer, truncated to the digest length, hits a fixed target with probability at most +`2 ^ -n`. Every per-query bound in the development is an instance of this: the adversary picks the +tweak and so the position, domain separation fixes the target, and this bounds what the answer buys. +-/ + +namespace SphincsSecurity + +open OracleComp ENNReal + +/-- Truncation loses the high half, and nothing else: two answers with the same truncation and the +same high half are the same answer. -/ +theorem hashOutput_eq_of_halves {x y : HashOutput} (hlow : truncateHash x = truncateHash y) + (hhigh : x.extractLsb' digestBits digestBits = y.extractLsb' digestBits digestBits) : x = y := by + apply BitVec.eq_of_getLsbD_eq + intro i hi + by_cases hlt : i < digestBits + · have := congrArg (fun b : Digest => b.getLsbD i) hlow + simpa [truncateHash, BitVec.getLsbD_extractLsb', hlt] using this + · have hshift : i - digestBits < digestBits := by + simp only [digestBits, hashOutputBits] at hi hlt ⊢ + omega + have := congrArg (fun b : Digest => b.getLsbD (i - digestBits)) hhigh + simp only [BitVec.getLsbD_extractLsb', hshift, decide_true, Bool.true_and] at this + rwa [show digestBits + (i - digestBits) = i by omega] at this + +/-- **One guess.** A uniform answer truncated to the digest length hits a fixed target with +probability at most `2 ^ -n`. -/ +theorem probOutput_truncateHash_le (target : Digest) : + Pr[= target | (truncateHash <$> ($ᵗ HashOutput : ProbComp HashOutput))] + ≤ ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + classical + set fiber := Finset.univ.filter fun output : HashOutput => target = truncateHash output with hfiber + have hcard : fiber.card ≤ 2 ^ digestBits := by + have hinj : Set.InjOn (fun output : HashOutput => output.extractLsb' digestBits digestBits) + fiber := by + intro x hx y hy hxy + simp only [hfiber, Finset.coe_filter, Set.mem_setOf_eq, Finset.mem_univ, true_and] at hx hy + exact hashOutput_eq_of_halves (by rw [← hx, ← hy]) hxy + calc fiber.card ≤ (Finset.univ : Finset Digest).card := + Finset.card_le_card_of_injOn _ (by simp) hinj + _ = 2 ^ digestBits := by simp + have hexp : hashOutputBits = digestBits + digestBits := by norm_num [hashOutputBits, digestBits] + have hsplit : ((Fintype.card HashOutput : ℝ≥0∞)) + = ((2 ^ digestBits : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞) := by + rw [show Fintype.card HashOutput = 2 ^ hashOutputBits from card_bitVec hashOutputBits, hexp, + pow_add] + push_cast + ring + have hne : ((2 ^ digestBits : Nat) : ℝ≥0∞) ≠ 0 := by positivity + have htop : ((2 ^ digestBits : Nat) : ℝ≥0∞) ≠ ⊤ := by simp + rw [probOutput_map_eq_sum_fintype_ite] + simp only [probOutput_uniformSample] + rw [← Finset.sum_filter, Finset.sum_const, nsmul_eq_mul, ← hfiber, hsplit, + ENNReal.mul_inv (Or.inl hne) (Or.inl htop)] + calc (fiber.card : ℝ≥0∞) * (((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) + = ((fiber.card : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) + * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by ring + _ ≤ 1 * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + refine mul_le_mul_left ?_ _ + calc (fiber.card : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + ≤ ((2 ^ digestBits : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + mul_le_mul_left (by exact_mod_cast hcard) _ + _ = 1 := ENNReal.mul_inv_cancel hne htop + _ = ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := one_mul _ + +/-! ### The same, at any width + +The digest's index is the low `h` bits of an oracle answer, and the leak argument needs it to be +near-uniform. That is the fiber count above at a different width, so it is worth having once. +-/ + +theorem hashOutput_eq_of_extract {width : Nat} (hwidth : width ≤ hashOutputBits) {x y : HashOutput} + (hlow : x.extractLsb' 0 width = y.extractLsb' 0 width) + (hhigh : x.extractLsb' width (hashOutputBits - width) + = y.extractLsb' width (hashOutputBits - width)) : x = y := by + apply BitVec.eq_of_getLsbD_eq + intro i hi + by_cases hlt : i < width + · have := congrArg (fun b : BitVec width => b.getLsbD i) hlow + simpa [BitVec.getLsbD_extractLsb', hlt] using this + · have hshift : i - width < hashOutputBits - width := by omega + have := congrArg (fun b : BitVec (hashOutputBits - width) => b.getLsbD (i - width)) hhigh + simp only [BitVec.getLsbD_extractLsb', hshift, decide_true, Bool.true_and] at this + rwa [show width + (i - width) = i by omega] at this + +/-- **One guess, at any width.** A uniform answer's low `width` bits hit a fixed target with +probability at most `2 ^ -width`. -/ +theorem probOutput_extract_le {width : Nat} (hwidth : width ≤ hashOutputBits) + (target : BitVec width) : + Pr[= target | ((fun output : HashOutput => output.extractLsb' 0 width) + <$> ($ᵗ HashOutput : ProbComp HashOutput))] + ≤ ((2 ^ width : Nat) : ℝ≥0∞)⁻¹ := by + classical + set fiber := Finset.univ.filter fun output : HashOutput => target = output.extractLsb' 0 width + with hfiber + have hcard : fiber.card ≤ 2 ^ (hashOutputBits - width) := by + have hinj : Set.InjOn + (fun output : HashOutput => output.extractLsb' width (hashOutputBits - width)) fiber := by + intro x hx y hy hxy + simp only [hfiber, Finset.coe_filter, Set.mem_setOf_eq, Finset.mem_univ, true_and] at hx hy + exact hashOutput_eq_of_extract hwidth (by rw [← hx, ← hy]) hxy + calc fiber.card ≤ (Finset.univ : Finset (BitVec (hashOutputBits - width))).card := + Finset.card_le_card_of_injOn _ (by simp) hinj + _ = 2 ^ (hashOutputBits - width) := by simp + obtain ⟨rest, hrest⟩ : ∃ rest, hashOutputBits = width + rest := ⟨hashOutputBits - width, by omega⟩ + have hrest' : hashOutputBits - width = rest := by omega + rw [hrest'] at hcard + have hsplit : ((Fintype.card HashOutput : ℝ≥0∞)) + = ((2 ^ width : Nat) : ℝ≥0∞) * ((2 ^ rest : Nat) : ℝ≥0∞) := by + rw [show Fintype.card HashOutput = 2 ^ hashOutputBits from card_bitVec hashOutputBits, hrest, + pow_add] + push_cast + ring + have hne : ((2 ^ width : Nat) : ℝ≥0∞) ≠ 0 := by positivity + have htop : ((2 ^ width : Nat) : ℝ≥0∞) ≠ ⊤ := by simp + have hne' : ((2 ^ rest : Nat) : ℝ≥0∞) ≠ 0 := by positivity + have htop' : ((2 ^ rest : Nat) : ℝ≥0∞) ≠ ⊤ := by simp + rw [probOutput_map_eq_sum_fintype_ite] + simp only [probOutput_uniformSample] + rw [← Finset.sum_filter, Finset.sum_const, nsmul_eq_mul, ← hfiber, hsplit, + ENNReal.mul_inv (Or.inl hne) (Or.inl htop)] + calc (fiber.card : ℝ≥0∞) + * (((2 ^ width : Nat) : ℝ≥0∞)⁻¹ * ((2 ^ rest : Nat) : ℝ≥0∞)⁻¹) + = ((fiber.card : ℝ≥0∞) * ((2 ^ rest : Nat) : ℝ≥0∞)⁻¹) + * ((2 ^ width : Nat) : ℝ≥0∞)⁻¹ := by ring + _ ≤ 1 * ((2 ^ width : Nat) : ℝ≥0∞)⁻¹ := by + refine mul_le_mul_left ?_ _ + calc (fiber.card : ℝ≥0∞) * ((2 ^ rest : Nat) : ℝ≥0∞)⁻¹ + ≤ ((2 ^ rest : Nat) : ℝ≥0∞) + * ((2 ^ rest : Nat) : ℝ≥0∞)⁻¹ := + mul_le_mul_left (by exact_mod_cast hcard) _ + _ = 1 := ENNReal.mul_inv_cancel hne' htop' + _ = ((2 ^ width : Nat) : ℝ≥0∞)⁻¹ := one_mul _ + +/-- The digest's index is the low `h` bits of the answer, the truncation to `h + k * a` bits having +kept them. -/ +theorem digestIndex_truncate (output : HashOutput) : + Concrete.digestIndex (truncateMessageDigest output) + = (output.extractLsb' 0 totalHeight).toFin := by + rw [Concrete.digestIndex, truncateMessageDigest] + congr 1 + apply BitVec.eq_of_getLsbD_eq + intro i hi + have hlt : i < messageDigestBits := by + have h1 : totalHeight = 26 := rfl + have h2 : messageDigestBits = 176 := rfl + omega + simp [BitVec.getLsbD_extractLsb', hlt] + +/-- **The index a fresh digest selects.** It hits a fixed index with probability at most `2^-h`, +which is what the few-time leak is counted against. -/ +theorem probOutput_digestIndex_le (target : Index) : + Pr[= target | ((fun output : HashOutput => Concrete.digestIndex (truncateMessageDigest output)) + <$> ($ᵗ HashOutput : ProbComp HashOutput))] + ≤ ((2 ^ totalHeight : Nat) : ℝ≥0∞)⁻¹ := by + have hwidth : totalHeight ≤ hashOutputBits := by decide + have hmap : ((fun output : HashOutput => Concrete.digestIndex (truncateMessageDigest output)) + <$> ($ᵗ HashOutput : ProbComp HashOutput)) + = (fun output : HashOutput => (output.extractLsb' 0 totalHeight).toFin) + <$> ($ᵗ HashOutput : ProbComp HashOutput) := by + congr 1 + funext output + exact digestIndex_truncate output + have hevent : ∀ x : BitVec totalHeight, (x.toFin = target) ↔ (x = BitVec.ofFin target) := by + intro x + constructor + · intro h; rw [show x = BitVec.ofFin x.toFin from rfl, h] + · intro h; rw [h] + rw [hmap, probOutput_map, + show (fun output : HashOutput => (output.extractLsb' 0 totalHeight).toFin = target) + = (fun output : HashOutput => output.extractLsb' 0 totalHeight = BitVec.ofFin target) from by + funext output + simp only [eq_iff_iff] + exact hevent _, + ← probOutput_map] + exact probOutput_extract_le hwidth (BitVec.ofFin target) + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/HitBad.lean b/formal/sphincs/SphincsSecurity/Proof/HitBad.lean new file mode 100644 index 00000000..754b7f08 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/HitBad.lean @@ -0,0 +1,86 @@ +import SphincsSecurity.Proof.Charge + +/-! +# Extraction hits are bad + +The extraction lemmas state collisions in the notation of the concrete hash computation. These +adapters identify their structural position and turn a cached hit at a settled position into `Bad`. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +namespace Concrete + +variable {f : QueryImpl HashSpec Id} {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {cache : QueryCache HashSpec} + +theorem bad_of_chainHit (hf : cache.AgreesWithFn f) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (position : Nat) + (hposition : position < chainLength - 1) (payload : Digest) + (hhit : ChainHit f parameter lay tree leafIdx chainIdx + (otsSecret lay tree leafIdx chainIdx) position hposition payload) + (hsettled : Settled parameter otsSecret ftsSecret cache + (.chain lay tree leafIdx chainIdx ⟨position, hposition⟩)) + (hcached : cache (tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx ⟨position, hposition⟩) (digestBytes payload)) ≠ none) : + Bad parameter otsSecret ftsSecret cache := by + apply bad_of_settled_payload_collision parameter otsSecret ftsSecret hf hsettled + (hcached := hcached) + · simpa only [honestPayload] using fun h => hhit.1 (digestBytes_injective h) + · simpa only [Position.domain, honestValue_chain] using hhit.2 + +theorem bad_of_leafHit (hf : cache.AgreesWithFn f) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (payload : HashInput) + (hhit : LeafHit f parameter lay tree (otsSecret lay tree) leafIdx payload) + (hsettled : Settled parameter otsSecret ftsSecret cache (.leaf lay tree leafIdx)) + (hcached : cache (tweakableHashInput parameter (.leaf lay tree leafIdx) payload) ≠ none) : + Bad parameter otsSecret ftsSecret cache := by + apply bad_of_settled_payload_collision parameter otsSecret ftsSecret hf hsettled + (hcached := hcached) + · exact hhit.1 + · simpa only [Position.domain, honestValue_leaf] using hhit.2 + +theorem bad_of_nodeHit (hf : cache.AgreesWithFn f) (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) (hlevel : level < maxLayerHeight) + (hnodeIdx : nodeIdx < 2 ^ maxLayerHeight) (payload : HashInput) + (hhit : NodeHit f parameter lay tree (otsSecret lay tree) level nodeIdx payload) + (hsettled : Settled parameter otsSecret ftsSecret cache + (.node lay tree ⟨level, hlevel⟩ ⟨nodeIdx, hnodeIdx⟩)) + (hcached : cache (tweakableHashInput parameter (.node lay tree (level + 1) nodeIdx) payload) + ≠ none) : Bad parameter otsSecret ftsSecret cache := by + apply bad_of_settled_payload_collision parameter otsSecret ftsSecret hf hsettled + (hcached := hcached) + · exact hhit.1 + · simpa only [Position.domain, honestValue_node] using hhit.2 + +theorem bad_of_ftsLeafHit (hf : cache.AgreesWithFn f) (index : Index) (tree : FtsTree) + (leafIdx : FtsLeaf) (candidate : Digest) + (hhit : FtsLeafHit f parameter index tree (ftsSecret index tree) leafIdx candidate) + (hsettled : Settled parameter otsSecret ftsSecret cache (.ftsLeaf index tree leafIdx)) + (hcached : cache (tweakableHashInput parameter (.ftsLeaf index tree leafIdx) + (digestBytes candidate)) ≠ none) : Bad parameter otsSecret ftsSecret cache := by + apply bad_of_settled_payload_collision parameter otsSecret ftsSecret hf hsettled + (hcached := hcached) + · simpa only [honestPayload] using fun h => hhit.1 (digestBytes_injective h) + · simpa only [Position.domain, honestValue_ftsLeaf] using hhit.2 + +theorem bad_of_ftsNodeHit (hf : cache.AgreesWithFn f) (index : Index) (tree : FtsTree) + (level nodeIdx : Nat) (hlevel : level < ftsTreeHeight) + (hnodeIdx : nodeIdx < 2 ^ ftsTreeHeight) (payload : HashInput) + (hhit : FtsNodeHit f parameter index tree (ftsSecret index tree) level nodeIdx payload) + (hsettled : Settled parameter otsSecret ftsSecret cache + (.ftsNode index tree ⟨level, hlevel⟩ ⟨nodeIdx, hnodeIdx⟩)) + (hcached : cache (tweakableHashInput parameter (.ftsNode index tree (level + 1) nodeIdx) + payload) ≠ none) : Bad parameter otsSecret ftsSecret cache := by + apply bad_of_settled_payload_collision parameter otsSecret ftsSecret hf hsettled + (hcached := hcached) + · exact hhit.1 + · simpa only [Position.domain, honestValue_ftsNode] using hhit.2 + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Honest.lean b/formal/sphincs/SphincsSecurity/Proof/Honest.lean new file mode 100644 index 00000000..c8dbe7a3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Honest.lean @@ -0,0 +1,303 @@ +import SphincsSecurity.Proof.Position +import SphincsSecurity.Proof.ExtractOts +import SphincsSecurity.Proof.ExtractFts + +/-! +# The honest key at a position + +One payload per position, one input, one value, all as functions of an answer function and the +sampled secrets. Nothing here is a recursion: each family reads the honest computation the statement +already defines, `honestChain`, `honestNode` and `honestFtsNode`, so the value at a position is +whatever those say. What the accounting needs of them is `honestPayload_congr`: the payload at a +position is a function of the values at its children, so two answer functions that agree on the +children agree on the input, which is what pins the honest structure to a cache. + +`Valid` excludes the positions `Position` over-approximates, a node whose children would fall +outside the index width. They carry no honest meaning, and excluding them is what keeps +`honestPayload_congr` true of every position the accounting settles. +-/ + +namespace SphincsSecurity + +open OracleComp + +namespace Concrete + +variable (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + +/-- The value the honest forest's root hash carries. -/ +def honestFtsKey (index : Index) (secret : FtsTree → FtsLeaf → Digest) : Digest := + evalWithAnswerFn f (ftsKey parameter index secret) + +theorem honestFtsKey_eq (index : Index) (secret : FtsTree → FtsLeaf → Digest) : + honestFtsKey f parameter index secret + = truncateHash (f (tweakableHashInput parameter (.ftsRoots index) + (ftsRootsPayload fun tree => + honestFtsNode f parameter index tree (secret tree) ftsTreeHeight 0))) := by + simp only [honestFtsKey, ftsKey, evalWithAnswerFn_bind, evalWithAnswerFn_sequenceFin, + eval_tweakableHash, honestFtsNode] + +theorem honestChain_zero (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (secret : Digest) : + honestChain f parameter lay tree leafIdx chainIdx secret 0 = secret := by + simp [honestChain, chainWalk] + +end Concrete + +variable (f g : QueryImpl HashSpec Id) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + +/-- The payload the honest key hashes at a position. -/ +noncomputable def honestPayload : Position → HashInput + | .chain lay tree leafIdx chainIdx step => + Concrete.digestBytes (Concrete.honestChain f parameter lay tree leafIdx chainIdx + (otsSecret lay tree leafIdx chainIdx) step.val) + | .leaf lay tree leafIdx => + Concrete.leafPayload + (Concrete.honestEndpoints f parameter lay tree (otsSecret lay tree) leafIdx) + | .node lay tree level nodeIdx => + Concrete.nodePayload + (Concrete.honestNode f parameter lay tree (otsSecret lay tree) level.val (2 * nodeIdx.val)) + (Concrete.honestNode f parameter lay tree (otsSecret lay tree) level.val + (2 * nodeIdx.val + 1)) + | .ftsLeaf index tree leafIdx => Concrete.digestBytes (ftsSecret index tree leafIdx) + | .ftsNode index tree level nodeIdx => + Concrete.nodePayload + (Concrete.honestFtsNode f parameter index tree (ftsSecret index tree) level.val + (2 * nodeIdx.val)) + (Concrete.honestFtsNode f parameter index tree (ftsSecret index tree) level.val + (2 * nodeIdx.val + 1)) + | .ftsRoots index => + Concrete.ftsRootsPayload fun tree => + Concrete.honestFtsNode f parameter index tree (ftsSecret index tree) ftsTreeHeight 0 + +/-- The input the honest key hashes at a position. -/ +noncomputable def honestInput (p : Position) : HashInput := + tweakableHashInput parameter p.domain (honestPayload f parameter otsSecret ftsSecret p) + +/-- The value the honest key carries at a position. -/ +noncomputable def honestValue (p : Position) : Digest := + truncateHash (f (honestInput f parameter otsSecret ftsSecret p)) + +/-! ### What the value at a position is + +The honest computations of the statement, read off the definitions above. -/ + +theorem honestValue_chain (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (step : ChainStep) : + honestValue f parameter otsSecret ftsSecret (.chain lay tree leafIdx chainIdx step) + = Concrete.honestChain f parameter lay tree leafIdx chainIdx + (otsSecret lay tree leafIdx chainIdx) (step.val + 1) := by + rw [Concrete.honestChain_succ f parameter lay tree leafIdx chainIdx _ step.val step.isLt] + rfl + +theorem honestValue_leaf (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + honestValue f parameter otsSecret ftsSecret (.leaf lay tree leafIdx) + = Concrete.honestNode f parameter lay tree (otsSecret lay tree) 0 leafIdx.val := by + rw [Concrete.honestNode_zero_eq_leafHash f parameter lay tree (otsSecret lay tree) leafIdx] + rfl + +theorem honestValue_node (lay : Layer) (tree : TreeIndex) (level : Fin maxLayerHeight) + (nodeIdx : LeafIndex) : + honestValue f parameter otsSecret ftsSecret (.node lay tree level nodeIdx) + = Concrete.honestNode f parameter lay tree (otsSecret lay tree) (level.val + 1) + nodeIdx.val := by + rw [Concrete.honestNode_succ f parameter lay tree (otsSecret lay tree) level.val nodeIdx.val] + rfl + +theorem honestValue_ftsLeaf (index : Index) (tree : FtsTree) (leafIdx : FtsLeaf) : + honestValue f parameter otsSecret ftsSecret (.ftsLeaf index tree leafIdx) + = Concrete.honestFtsNode f parameter index tree (ftsSecret index tree) 0 leafIdx.val := by + rw [Concrete.honestFtsNode_zero f parameter index tree (ftsSecret index tree) leafIdx] + rfl + +theorem honestValue_ftsNode (index : Index) (tree : FtsTree) (level : Fin ftsTreeHeight) + (nodeIdx : FtsLeaf) : + honestValue f parameter otsSecret ftsSecret (.ftsNode index tree level nodeIdx) + = Concrete.honestFtsNode f parameter index tree (ftsSecret index tree) (level.val + 1) + nodeIdx.val := by + rw [Concrete.honestFtsNode_succ f parameter index tree (ftsSecret index tree) level.val + nodeIdx.val] + rfl + +theorem honestValue_ftsRoots (index : Index) : + honestValue f parameter otsSecret ftsSecret (.ftsRoots index) + = Concrete.honestFtsKey f parameter index (ftsSecret index) := by + rw [Concrete.honestFtsKey_eq f parameter index (ftsSecret index)] + rfl + +/-! ### The payload is a concatenation of the values below + +Every payload of the instance is the same shape: the values at the position's children, written as +`16` bytes each, one after another, or the secret the family starts from. Reading it that way once is +what makes the accounting generic: the payload is a function of the children's values, and it +determines each of them. +-/ + +/-- The positions `Position` over-approximates: a node whose children would fall outside the index +width. Nothing honest lives there, and the accounting never settles one. -/ +def Position.Valid : Position → Prop + | .node _ _ _ nodeIdx => 2 * nodeIdx.val + 1 < 2 ^ maxLayerHeight + | .ftsNode _ _ _ nodeIdx => 2 * nodeIdx.val + 1 < 2 ^ ftsTreeHeight + | _ => True + +/-- The values at a position's children. -/ +noncomputable def childValues (p : Position) : List Digest := + p.children.map (honestValue f parameter otsSecret ftsSecret) + +/-- The values a position's payload concatenates: those at its children, or the secret its family +starts from. -/ +noncomputable def slots : Position → List Digest + | .chain lay tree leafIdx chainIdx step => + if step.val = 0 then [otsSecret lay tree leafIdx chainIdx] + else childValues f parameter otsSecret ftsSecret (.chain lay tree leafIdx chainIdx step) + | .ftsLeaf index tree leafIdx => [ftsSecret index tree leafIdx] + | p => childValues f parameter otsSecret ftsSecret p + +theorem slots_eq_childValues_of_mem {p c : Position} (hc : c ∈ p.children) : + slots f parameter otsSecret ftsSecret p = childValues f parameter otsSecret ftsSecret p := by + cases p with + | chain lay tree leafIdx chainIdx step => + simp only [slots] + rw [if_neg] + intro hstep + simp [Position.children, hstep] at hc + | ftsLeaf => simp [Position.children] at hc + | leaf | node | ftsNode | ftsRoots => rfl + +/-- **The payload is the values below it.** -/ +theorem honestPayload_eq_slots {p : Position} (hvalid : p.Valid) : + honestPayload f parameter otsSecret ftsSecret p + = (slots f parameter otsSecret ftsSecret p).flatMap Concrete.digestBytes := by + cases p with + | chain lay tree leafIdx chainIdx step => + rcases Nat.eq_zero_or_pos step.val with hstep | hstep + · have hslots : slots f parameter otsSecret ftsSecret + (.chain lay tree leafIdx chainIdx step) = [otsSecret lay tree leafIdx chainIdx] := by + simp only [slots, if_pos hstep] + rw [hslots] + simp only [honestPayload, hstep, Concrete.honestChain_zero, List.flatMap_cons, + List.flatMap_nil, List.append_nil] + · obtain ⟨s, hs⟩ : ∃ s, step.val = s + 1 := ⟨step.val - 1, by omega⟩ + have hslt : s < chainLength - 1 := by have := step.isLt; omega + have hchildren : (Position.chain lay tree leafIdx chainIdx step).children + = [.chain lay tree leafIdx chainIdx ⟨s, hslt⟩] := by + rw [Position.children, dif_pos hstep] + simp only [List.cons.injEq, Position.chain.injEq, Fin.mk.injEq, and_true, true_and] + omega + have hslots : slots f parameter otsSecret ftsSecret + (.chain lay tree leafIdx chainIdx step) + = [honestValue f parameter otsSecret ftsSecret + (.chain lay tree leafIdx chainIdx ⟨s, hslt⟩)] := by + simp only [slots, if_neg (by omega : ¬ step.val = 0), childValues, hchildren, + List.map_cons, List.map_nil] + rw [hslots, honestValue_chain] + simp only [honestPayload, List.flatMap_cons, List.flatMap_nil, List.append_nil, hs] + | leaf lay tree leafIdx => + have hslots : slots f parameter otsSecret ftsSecret (.leaf lay tree leafIdx) + = List.ofFn fun chainIdx : ChainIndex => honestValue f parameter otsSecret ftsSecret + (.chain lay tree leafIdx chainIdx Position.lastChainStep) := by + simp only [slots, childValues, Position.children, List.map_ofFn, Function.comp_def] + rw [hslots] + simp only [honestPayload, Concrete.leafPayload] + refine congrArg _ (congrArg _ (funext fun chainIdx => ?_)) + rw [honestValue_chain] + rfl + | node lay tree level nodeIdx => + simp only [Position.Valid] at hvalid + rcases Nat.eq_zero_or_pos level.val with hlevel | hlevel + · have hchildren : (Position.node lay tree level nodeIdx).children + = [.leaf lay tree ⟨2 * nodeIdx.val, by omega⟩, + .leaf lay tree ⟨2 * nodeIdx.val + 1, by omega⟩] := by + rw [Position.children, dif_pos hvalid, dif_neg (by omega)] + simp only [slots, childValues, hchildren, List.map_cons, List.map_nil, List.flatMap_cons, + List.flatMap_nil, List.append_nil, honestPayload, Concrete.nodePayload] + rw [honestValue_leaf, honestValue_leaf, hlevel] + · have hchildren : (Position.node lay tree level nodeIdx).children + = [.node lay tree ⟨level.val - 1, by have := level.isLt; omega⟩ + ⟨2 * nodeIdx.val, by omega⟩, + .node lay tree ⟨level.val - 1, by have := level.isLt; omega⟩ + ⟨2 * nodeIdx.val + 1, by omega⟩] := by + rw [Position.children, dif_pos hvalid, dif_pos hlevel] + simp only [slots, childValues, hchildren, List.map_cons, List.map_nil, List.flatMap_cons, + List.flatMap_nil, List.append_nil, honestPayload, Concrete.nodePayload] + rw [honestValue_node, honestValue_node, show level.val - 1 + 1 = level.val from by omega] + | ftsLeaf index tree leafIdx => + simp [slots, honestPayload] + | ftsNode index tree level nodeIdx => + simp only [Position.Valid] at hvalid + rcases Nat.eq_zero_or_pos level.val with hlevel | hlevel + · have hchildren : (Position.ftsNode index tree level nodeIdx).children + = [.ftsLeaf index tree ⟨2 * nodeIdx.val, by omega⟩, + .ftsLeaf index tree ⟨2 * nodeIdx.val + 1, by omega⟩] := by + rw [Position.children, dif_pos hvalid, dif_neg (by omega)] + simp only [slots, childValues, hchildren, List.map_cons, List.map_nil, List.flatMap_cons, + List.flatMap_nil, List.append_nil, honestPayload, Concrete.nodePayload] + rw [honestValue_ftsLeaf, honestValue_ftsLeaf, hlevel] + · have hchildren : (Position.ftsNode index tree level nodeIdx).children + = [.ftsNode index tree ⟨level.val - 1, by have := level.isLt; omega⟩ + ⟨2 * nodeIdx.val, by omega⟩, + .ftsNode index tree ⟨level.val - 1, by have := level.isLt; omega⟩ + ⟨2 * nodeIdx.val + 1, by omega⟩] := by + rw [Position.children, dif_pos hvalid, dif_pos hlevel] + simp only [slots, childValues, hchildren, List.map_cons, List.map_nil, List.flatMap_cons, + List.flatMap_nil, List.append_nil, honestPayload, Concrete.nodePayload] + rw [honestValue_ftsNode, honestValue_ftsNode, + show level.val - 1 + 1 = level.val from by omega] + | ftsRoots index => + have hslots : slots f parameter otsSecret ftsSecret (.ftsRoots index) + = List.ofFn fun tree : FtsTree => honestValue f parameter otsSecret ftsSecret + (.ftsNode index tree ⟨ftsTreeHeight - 1, by decide⟩ ⟨0, by positivity⟩) := by + simp only [slots, childValues, Position.children, List.map_ofFn, Function.comp_def] + rw [hslots] + simp only [honestPayload, Concrete.ftsRootsPayload] + refine congrArg _ (congrArg _ (funext fun tree => ?_)) + rw [honestValue_ftsNode] + rfl + +set_option linter.unnecessarySeqFocus false in +/-- The slot list has the same length whatever the answer function: it is the children, or one +secret. -/ +theorem slots_length (p : Position) : + (slots f parameter otsSecret ftsSecret p).length + = (slots g parameter otsSecret ftsSecret p).length := by + cases p <;> simp only [slots, childValues, List.length_map] <;> (try split_ifs) <;> simp + +theorem slots_congr {p : Position} + (hchildren : ∀ c ∈ p.children, honestValue f parameter otsSecret ftsSecret c + = honestValue g parameter otsSecret ftsSecret c) : + slots f parameter otsSecret ftsSecret p = slots g parameter otsSecret ftsSecret p := by + have hmap : childValues f parameter otsSecret ftsSecret p + = childValues g parameter otsSecret ftsSecret p := + List.map_congr_left hchildren + cases p <;> simp only [slots] <;> first | rfl | exact hmap | (split_ifs <;> simp [hmap]) + +/-- **The payload is local.** Two answer functions agreeing on the values at a position's children +agree on its payload, and so on its input. -/ +theorem honestPayload_congr {p : Position} (hvalid : p.Valid) + (hchildren : ∀ c ∈ p.children, honestValue f parameter otsSecret ftsSecret c + = honestValue g parameter otsSecret ftsSecret c) : + honestPayload f parameter otsSecret ftsSecret p + = honestPayload g parameter otsSecret ftsSecret p := by + rw [honestPayload_eq_slots f parameter otsSecret ftsSecret hvalid, + honestPayload_eq_slots g parameter otsSecret ftsSecret hvalid, + slots_congr f g parameter otsSecret ftsSecret hchildren] + +/-- **The payload determines the values below it.** -/ +theorem slots_injective {p : Position} (hvalid : p.Valid) + (h : honestPayload f parameter otsSecret ftsSecret p + = honestPayload g parameter otsSecret ftsSecret p) : + slots f parameter otsSecret ftsSecret p = slots g parameter otsSecret ftsSecret p := by + rw [honestPayload_eq_slots f parameter otsSecret ftsSecret hvalid, + honestPayload_eq_slots g parameter otsSecret ftsSecret hvalid] at h + exact TargetSum.flatMap_injective Concrete.digestBytes 16 digestBytes_length + (fun _ _ => digestBytes_injective) (slots_length f g parameter otsSecret ftsSecret p) h + +theorem honestInput_congr {p : Position} (hvalid : p.Valid) + (hchildren : ∀ c ∈ p.children, honestValue f parameter otsSecret ftsSecret c + = honestValue g parameter otsSecret ftsSecret c) : + honestInput f parameter otsSecret ftsSecret p = honestInput g parameter otsSecret ftsSecret p := + congrArg _ (honestPayload_congr f g parameter otsSecret ftsSecret hvalid hchildren) + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Hybrid.lean b/formal/sphincs/SphincsSecurity/Proof/Hybrid.lean new file mode 100644 index 00000000..3fca4c1c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Hybrid.lean @@ -0,0 +1,119 @@ +import SphincsSecurity.Proof.Logged +import VCVio.OracleComp.QueryTracking.ProgrammingOracle +import VCVio.ProgramLogic.Relational.ProgrammingOracle + +/-! +# The programmed game + +The hybrid step: answer chosen hash inputs with values decided in advance, carrying a flag that +records whether the programming was ever observable. The game's distribution changes only when that +flag fires, which is the identical-until-bad pattern; VCVio proves the bound for a computation over +one spec, and this module lifts it to the game's spec, `unifSpec + HashSpec`, where the sampling +summand is passive and the programming acts on the hash summand alone. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +/-- The sampling summand, carrying the flag untouched. -/ +noncomputable def unifFwdFlag : + QueryImpl unifSpec (StateT (QueryCache HashSpec × Bool) ProbComp) := + QueryImpl.extendState (unifFwdImpl HashSpec) fun _ _ _ _ flag => flag + +/-- The random-oracle semantics with a policy programmed into the hash oracle. -/ +noncomputable def romImplProg (policy : OracleSpec.ProgrammingPolicy HashSpec) : + QueryImpl OracleWorld (StateT (QueryCache HashSpec × Bool) ProbComp) := + unifFwdFlag + QueryImpl.withProgramming uniformSampleImpl policy + +/-- The identical-until-bad partner: the same flag, but every answer honest. -/ +noncomputable def romImplTrack (policy : OracleSpec.ProgrammingPolicy HashSpec) : + QueryImpl OracleWorld (StateT (QueryCache HashSpec × Bool) ProbComp) := + unifFwdFlag + QueryImpl.withCachingTrackingPolicy uniformSampleImpl policy + +theorem romImplProg_inl (policy : OracleSpec.ProgrammingPolicy HashSpec) (i : ℕ) : + romImplProg policy (Sum.inl i) = romImplTrack policy (Sum.inl i) := rfl + +/-- The two implementations agree on every outcome that leaves the flag unset. On a sampling query +they are the same implementation; on a hash query they differ only where the policy fires, and there +both produce only flagged outcomes. -/ +theorem romImplProg_agree (policy : OracleSpec.ProgrammingPolicy HashSpec) + (t : OracleWorld.Domain) (cache : QueryCache HashSpec) (u : OracleWorld.Range t) + (cache' : QueryCache HashSpec) : + Pr[= (u, (cache', false)) | (romImplProg policy t).run (cache, false)] + = Pr[= (u, (cache', false)) | (romImplTrack policy t).run (cache, false)] := by + cases t with + | inl i => rw [romImplProg_inl] + | inr input => + simp only [romImplProg, romImplTrack, QueryImpl.add_apply_inr, + QueryImpl.withProgramming_apply, QueryImpl.withCachingTrackingPolicy_apply] + rcases hcache : cache input with _ | v + · rcases hpolicy : policy input with _ | w + · simp [hcache] + · -- the policy fires: both sides flag the outcome, so neither yields an unflagged one + rw [probOutput_eq_zero_of_not_mem_support (by + intro hmem + simp [hcache] at hmem + exact Bool.noConfusion (congrArg + (fun z : OracleWorld.Range (Sum.inr input) × QueryCache HashSpec × Bool => z.2.2) + (Set.mem_singleton_iff.mp hmem))), + probOutput_eq_zero_of_not_mem_support (by + intro hmem + simp [hcache] at hmem + obtain ⟨answer, _, hanswer⟩ := hmem + exact Bool.noConfusion (congrArg + (fun z : OracleWorld.Range (Sum.inr input) × QueryCache HashSpec × Bool => z.2.2) + hanswer))] + · simp [hcache] + +/-- The flag only ever goes up, in either implementation: a sampling query carries it, and the two +hash implementations are monotone by construction. -/ +theorem romImplProg_mono (policy : OracleSpec.ProgrammingPolicy HashSpec) + (t : OracleWorld.Domain) (p : QueryCache HashSpec × Bool) (hp : p.2 = true) : + ∀ z ∈ support ((romImplProg policy t).run p), z.2.2 = true := by + cases t with + | inl i => + intro z hz + rw [show (romImplProg policy (Sum.inl i)).run p + = ((unifFwdImpl HashSpec i).run p.1 >>= fun q => pure (q.1, (q.2, p.2))) from rfl] at hz + obtain ⟨q, _, hz⟩ := (mem_support_bind_iff _ _ _).mp hz + rw [Set.mem_singleton_iff.mp hz] + exact hp + | inr input => + intro z hz + obtain ⟨cache, flag⟩ := p + simp only at hp + subst hp + exact QueryImpl.withProgramming_bad_monotone uniformSampleImpl policy input cache z hz + +theorem romImplTrack_mono (policy : OracleSpec.ProgrammingPolicy HashSpec) + (t : OracleWorld.Domain) (p : QueryCache HashSpec × Bool) (hp : p.2 = true) : + ∀ z ∈ support ((romImplTrack policy t).run p), z.2.2 = true := by + cases t with + | inl i => + intro z hz + rw [show (romImplTrack policy (Sum.inl i)).run p + = ((unifFwdImpl HashSpec i).run p.1 >>= fun q => pure (q.1, (q.2, p.2))) from rfl] at hz + obtain ⟨q, _, hz⟩ := (mem_support_bind_iff _ _ _).mp hz + rw [Set.mem_singleton_iff.mp hz] + exact hp + | inr input => + intro z hz + obtain ⟨cache, flag⟩ := p + simp only at hp + subst hp + exact QueryImpl.withCachingTrackingPolicy_bad_monotone uniformSampleImpl policy input cache z + hz + +/-- **The hybrid step.** Programming the hash oracle moves the game's distribution by at most the +probability that the programming is ever observed. -/ +theorem tvDist_romImplProg_le (policy : OracleSpec.ProgrammingPolicy HashSpec) {α : Type} + (oa : OracleComp OracleWorld α) (cache : QueryCache HashSpec) : + tvDist ((simulateQ (romImplProg policy) oa).run (cache, false)) + ((simulateQ (romImplTrack policy) oa).run (cache, false)) + ≤ Pr[fun z : α × QueryCache HashSpec × Bool => z.2.2 = true + | (simulateQ (romImplProg policy) oa).run (cache, false)].toReal := + ProgramLogic.Relational.tvDist_simulateQ_run_le_probEvent_output_bad _ _ oa cache + (romImplProg_agree policy) (romImplProg_mono policy) (romImplTrack_mono policy) + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree.lean new file mode 100644 index 00000000..f1d1fd4c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree.lean @@ -0,0 +1,91 @@ +import SphincsSecurity.Proof.Layer + +/-! +# The hypertree + +Three layers, bottom first. Each layer's fold produces the root of its tree, which is exactly the +message the layer above it signs, so the layers chain; layer `0`'s fold is the public root. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp + +variable {m : Type → Type} [Monad m] [HasQuery HashSpec m] + +theorem layerMessage_bottomLayer (secretKey : SecretKey) (index : Index) : + layerMessage (m := m) secretKey index bottomLayer + = ftsKey secretKey.parameter index (secretKey.ftsSecret index) := by + rw [layerMessage, dif_neg (by decide)] + +theorem layerMessage_of_lt (secretKey : SecretKey) (index : Index) (lay : Layer) + (hbelow : lay.val + 1 < numLayers) : + layerMessage (m := m) secretKey index lay + = treeRoot secretKey.parameter ⟨lay.val + 1, hbelow⟩ + (treeIndexAt index ⟨lay.val + 1, hbelow⟩) + (secretKey.otsSecret ⟨lay.val + 1, hbelow⟩ (treeIndexAt index ⟨lay.val + 1, hbelow⟩)) := by + rw [layerMessage, dif_pos hbelow] + +/-- Honest leaf indices are in range for their layer, which is what lets a fold reach the root. -/ +theorem leafIndexAt_lt (index : Index) (lay : Layer) : + (leafIndexAt index lay).val < 2 ^ layerHeight lay := by + rw [leafIndexAt_val] + exact Nat.mod_lt _ (Nat.two_pow_pos _) + +/-- **The hypertree.** An honest signature's layers chain from the few-time public key up to the +public root: each layer's fold is the message the layer above signs. -/ +theorem eval_verifyLayers (f : QueryImpl HashSpec Id) (secretKey : SecretKey) (index : Index) + (signature : Signature) (codeword : Layer → Encoding) + (hchain : ∀ lay : Layer, signature.chainValue lay + = fun chainIdx => evalWithAnswerFn f (chainWalk secretKey.parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) chainIdx 0 (codeword lay chainIdx).val + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx))) + (hpath : ∀ (lay : Layer) (level : Nat), level < layerHeight lay → + signaturePath signature lay level = evalWithAnswerFn f (treeNode secretKey.parameter lay + (treeIndexAt index lay) (secretKey.otsSecret lay (treeIndexAt index lay)) level + (Nat.xor ((leafIndexAt index lay).val / 2 ^ level) 1))) + (hencode : ∀ lay : Layer, evalWithAnswerFn f (encode secretKey.parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f (layerMessage secretKey index lay)) (signature.counter lay)) + = some (codeword lay)) : + evalWithAnswerFn f (verifyLayers secretKey.parameter index signature numLayers + (evalWithAnswerFn f (ftsKey secretKey.parameter index (secretKey.ftsSecret index)))) + = some (evalWithAnswerFn f (treeRoot secretKey.parameter topLayer rootTree + (secretKey.otsSecret topLayer rootTree))) := by + have hstep : ∀ (remaining : Nat) (hlayer : remaining < numLayers) (message : Digest), + evalWithAnswerFn f (encode secretKey.parameter ⟨remaining, hlayer⟩ + (treeIndexAt index ⟨remaining, hlayer⟩) (leafIndexAt index ⟨remaining, hlayer⟩) message + (signature.counter ⟨remaining, hlayer⟩)) = some (codeword ⟨remaining, hlayer⟩) → + evalWithAnswerFn f (verifyLayers secretKey.parameter index signature (remaining + 1) message) + = evalWithAnswerFn f (verifyLayers secretKey.parameter index signature remaining + (evalWithAnswerFn f (treeRoot secretKey.parameter ⟨remaining, hlayer⟩ + (treeIndexAt index ⟨remaining, hlayer⟩) + (secretKey.otsSecret ⟨remaining, hlayer⟩ (treeIndexAt index ⟨remaining, hlayer⟩))))) := by + intro remaining hlayer message hmessage + rw [verifyLayers_succ_eq, dif_pos hlayer, hchain ⟨remaining, hlayer⟩] + exact eval_layer f secretKey.parameter ⟨remaining, hlayer⟩ (treeIndexAt index ⟨remaining, hlayer⟩) + (secretKey.otsSecret ⟨remaining, hlayer⟩ (treeIndexAt index ⟨remaining, hlayer⟩)) + (leafIndexAt index ⟨remaining, hlayer⟩) _ _ _ hmessage + (leafIndexAt_lt index ⟨remaining, hlayer⟩) _ + (fun level hlevel => hpath ⟨remaining, hlayer⟩ level hlevel) _ _ + have hbottom := hstep 2 (by decide) + (evalWithAnswerFn f (ftsKey secretKey.parameter index (secretKey.ftsSecret index))) + (hencode ⟨2, by decide⟩) + have hmiddle := hstep 1 (by decide) + (evalWithAnswerFn f (treeRoot secretKey.parameter ⟨2, by decide⟩ + (treeIndexAt index ⟨2, by decide⟩) + (secretKey.otsSecret ⟨2, by decide⟩ (treeIndexAt index ⟨2, by decide⟩)))) + (hencode ⟨1, by decide⟩) + have htop := hstep 0 (by decide) + (evalWithAnswerFn f (treeRoot secretKey.parameter ⟨1, by decide⟩ + (treeIndexAt index ⟨1, by decide⟩) + (secretKey.otsSecret ⟨1, by decide⟩ (treeIndexAt index ⟨1, by decide⟩)))) + (hencode ⟨0, by decide⟩) + have hroot : treeIndexAt index topLayer = rootTree := by + ext + rw [treeIndexAt_topLayer] + rfl + rw [show numLayers = 2 + 1 from rfl, hbottom, hmiddle, htop, verifyLayers_zero_eq, + evalWithAnswerFn_pure, show (⟨0, by decide⟩ : Layer) = topLayer from rfl, hroot] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/JointNativeQueryCharge.lean b/formal/sphincs/SphincsSecurity/Proof/JointNativeQueryCharge.lean new file mode 100644 index 00000000..1e7d58cb --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/JointNativeQueryCharge.lean @@ -0,0 +1,76 @@ +import SphincsSecurity.Proof.OtsProbeNativeDirectBound + +namespace SphincsSecurity.Concrete + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def jointNativeQueryCharge (secretKey : SecretKey) + (cache : QueryCache HashSpec) (input : HashInput) : ENNReal := + (TightEncoding.refinedStructuralEncodingQueryCharge secretKey cache input + ftsOpeningQueryReserve secretKey cache input) + + OtsProbeSimulation.directOtsQueryCharge secretKey.parameter cache input + +theorem jointNativeQueryCharge_le_ten_thirds + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) : + jointNativeQueryCharge secretKey cache input ≤ 10 / 3 := by + unfold jointNativeQueryCharge + apply (add_le_add le_rfl (OtsProbeSimulation.directOtsQueryCharge_le_refinedReserve secretKey cache input)).trans_eq + exact structural_add_refined_openingQueryReserve secretKey cache input + +theorem jointNativeQueryCharge_eq_of_not_ots + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) + (hnot : ¬∃ position : Position, OtsProbeSimulation.IsOtsPosition position ∧ AtPosition secretKey.parameter input position) : + jointNativeQueryCharge secretKey cache input = + TightEncoding.refinedStructuralEncodingQueryCharge secretKey cache input + ftsOpeningQueryReserve secretKey cache input := by + simp [jointNativeQueryCharge, OtsProbeSimulation.directOtsQueryCharge, OtsProbeSimulation.otsHashInputCharge, hnot] + +theorem jointNativeQueryCharge_atEncodingPosition + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) (position : EncodingPosition) + (hat : AtEncodingPosition secretKey.parameter input position) : + jointNativeQueryCharge secretKey cache input = TightEncoding.refinedStructuralEncodingQueryCharge secretKey cache input := by + have hnot : ¬∃ target : Position, OtsProbeSimulation.IsOtsPosition target ∧ AtPosition secretKey.parameter input target := by + rintro ⟨target, _, htarget⟩ + exact hat.not_atPosition target htarget + have hfts : ¬∃ probe : FtsSecretProbe, probe.input secretKey.parameter = input := by + rintro ⟨probe, hinput⟩ + apply hat.not_atPosition (.ftsLeaf probe.index probe.tree probe.leafIdx) + rw [← hinput] + exact ⟨digestBytes probe.candidate, rfl⟩ + rw [jointNativeQueryCharge_eq_of_not_ots secretKey cache input hnot] + simp only [ftsOpeningQueryReserve, FtsProbeSimulation.ftsHashQueryCharge, if_neg hfts, zero_mul, add_zero] + +theorem jointNativeQueryCharge_le_three_atEncodingPosition + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) (position : EncodingPosition) + (hat : AtEncodingPosition secretKey.parameter input position) : + jointNativeQueryCharge secretKey cache input ≤ 3 := by + rw [jointNativeQueryCharge_atEncodingPosition secretKey cache input position hat] + exact TightEncoding.refinedStructuralEncodingQueryCharge_le_three secretKey cache input + +theorem probEvent_sampled_jointPrimitive_le_nativeQueryCharge_add_erasure + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + Pr[SampledViewedEvent jointPrimitiveEvent | sampledViewedGame adversary] ≤ + sampledQueryCharge jointNativeQueryCharge adversary * (Fintype.card Digest : ENNReal)⁻¹ + + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + have hfts := FtsProbeSimulation.probEvent_sampledViewedGame_cleanUncovered_le_queryCharge126 adversary q hq hqMax + rw [← sampled_ftsOpeningQueryReserve_eq] at hfts + apply (probEvent_sampled_jointPrimitive_le_prehit_charge_add_openings adversary).trans + apply (add_le_add le_rfl (add_le_add + (OtsProbeSimulation.probEvent_sampled_prehitFree_residual_le_directCharge_add_erasure adversary q hq hqMax) hfts)).trans_eq + unfold jointNativeQueryCharge + simp only [sampledQueryCharge_add] + ring + +theorem forgeAdvantage_le_nativeQueryCharge_add_remaining126 + (adversary : Adversary) (q : Nat) (hqPos : 1 ≤ q) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + forgeAdvantage scheme adversary ≤ + (sampledQueryCharge jointNativeQueryCharge adversary * (Fintype.card Digest : ENNReal)⁻¹ + + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹) + + ((q : ENNReal) * ((2 ^ 139 : Nat) : ENNReal)⁻¹ + + ((19 * q : Nat) : ENNReal) * ((2 ^ 133 : Nat) : ENNReal)⁻¹) := + (forgeAdvantage_le_sampled_jointPrimitive_add_refined_remaining126 adversary q hqPos hq hqMax).trans + (add_le_add (probEvent_sampled_jointPrimitive_le_nativeQueryCharge_add_erasure adversary q hq hqMax) le_rfl) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/JointPrimitiveQueryBudget.lean b/formal/sphincs/SphincsSecurity/Proof/JointPrimitiveQueryBudget.lean new file mode 100644 index 00000000..0efd9af0 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/JointPrimitiveQueryBudget.lean @@ -0,0 +1,137 @@ +import SphincsSecurity.Proof.JointPrimitiveTerminal +import SphincsSecurity.Proof.TightEncodingRefinedBound + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +def residualPrimitiveEvent (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : Prop := + result.1.2.2 = true ∧ ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ¬ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result ∧ + (cleanOtsOpeningEvent parameter otsSecret ftsSecret result ∨ + cleanUncoveredEvent parameter otsSecret ftsSecret result) + +noncomputable def residualPrimitiveQueryCharge (secretKey : SecretKey) + (cache : QueryCache HashSpec) (input : HashInput) : ℝ≥0∞ := + 3 - TightEncoding.refinedStructuralEncodingQueryCharge secretKey cache input + +noncomputable def sampledQueryCharge + (charge : SecretKey → QueryCache HashSpec → HashInput → ℝ≥0∞) + (adversary : Adversary) : ℝ≥0∞ := + ∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets] * + expectedQueryCharge (charge (primitiveAccountingKey secrets.parameter secrets.otsSecret secrets.ftsSecret)) + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret) ∅ + +theorem structural_add_residual_queryCharge (secretKey : SecretKey) + (cache : QueryCache HashSpec) (input : HashInput) : + TightEncoding.refinedStructuralEncodingQueryCharge secretKey cache input + + residualPrimitiveQueryCharge secretKey cache input = 3 := by + exact add_tsub_cancel_of_le + (TightEncoding.refinedStructuralEncodingQueryCharge_le_three secretKey cache input) + +theorem sampled_structural_add_residual_queryCharge_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) : + sampledQueryCharge TightEncoding.refinedStructuralEncodingQueryCharge adversary + + sampledQueryCharge residualPrimitiveQueryCharge adversary ≤ 3 * q := by + rw [sampledQueryCharge, sampledQueryCharge, ← ENNReal.tsum_add] + calc + _ ≤ ∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets] * (3 * q : ℝ≥0∞) := by + apply ENNReal.tsum_le_tsum + intro secrets + rw [← mul_add, ← expectedQueryCharge_add] + have heq : (fun cache input => + TightEncoding.refinedStructuralEncodingQueryCharge + (primitiveAccountingKey secrets.parameter secrets.otsSecret secrets.ftsSecret) cache input + + residualPrimitiveQueryCharge + (primitiveAccountingKey secrets.parameter secrets.otsSecret secrets.ftsSecret) cache input) = fun _ _ => (3 : ℝ≥0∞) := by + funext cache input + exact structural_add_residual_queryCharge + (primitiveAccountingKey secrets.parameter secrets.otsSecret secrets.ftsSecret) cache input + rw [heq] + by_cases hsecrets : secrets ∈ support sampleSecrets + · obtain ⟨hparameter, hots, hfts⟩ := secrets.support_components hsecrets + exact mul_le_mul' le_rfl (expectedQueryCharge_le_queryBound _ 3 (fun _ _ => le_rfl) + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret) q + (isQueryBoundP_gameAfterSecrets adversary q hq hparameter hots hfts) ∅) + · rw [probOutput_eq_zero_of_not_mem_support hsecrets, zero_mul, zero_mul] + _ ≤ _ := by + rw [ENNReal.tsum_mul_right] + exact mul_le_of_le_one_left (by positivity) tsum_probOutput_le_one + +theorem probEvent_jointPrimitive_le_structural_charge_add_residual + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[jointPrimitiveEvent parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + expectedQueryCharge (TightEncoding.refinedStructuralEncodingQueryCharge + (primitiveAccountingKey parameter otsSecret ftsSecret)) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ * + (Fintype.card Digest : ℝ≥0∞)⁻¹ + + Pr[residualPrimitiveEvent parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + calc + _ ≤ Pr[fun result => + (Bad parameter otsSecret ftsSecret result.2.cache ∨ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result) ∨ + residualPrimitiveEvent parameter otsSecret ftsSecret result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + apply probEvent_mono + intro result _ hevent + obtain ⟨hwin, hevent⟩ := hevent + by_cases hbad : Bad parameter otsSecret ftsSecret result.2.cache + · exact Or.inl (Or.inl hbad) + by_cases hencoding : ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result + · exact Or.inl (Or.inr hencoding) + exact Or.inr ⟨hwin, hbad, hencoding, (hevent.resolve_left hbad).resolve_left hencoding⟩ + _ ≤ _ := (probEvent_or_le _ _ _).trans + (add_le_add (probEvent_bad_or_viewedEncodingCollision_le_refined_queryCharge + adversary parameter otsSecret ftsSecret) le_rfl) + +theorem probEvent_sampled_jointPrimitive_le_charge_add_residual + (adversary : Adversary) : + Pr[SampledViewedEvent jointPrimitiveEvent | sampledViewedGame adversary] ≤ + sampledQueryCharge TightEncoding.refinedStructuralEncodingQueryCharge adversary * + (Fintype.card Digest : ℝ≥0∞)⁻¹ + + Pr[SampledViewedEvent residualPrimitiveEvent | sampledViewedGame adversary] := by + rw [probEvent_sampledViewedGame_eq_weighted, + probEvent_sampledViewedGame_eq_weighted] + calc + _ ≤ ∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets] * + (expectedQueryCharge (TightEncoding.refinedStructuralEncodingQueryCharge + (primitiveAccountingKey secrets.parameter secrets.otsSecret secrets.ftsSecret)) + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret) ∅ * + (Fintype.card Digest : ℝ≥0∞)⁻¹ + + Pr[residualPrimitiveEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret secrets.ftsSecret]) := + ENNReal.tsum_le_tsum fun secrets => mul_le_mul' le_rfl + (probEvent_jointPrimitive_le_structural_charge_add_residual adversary secrets.parameter + secrets.otsSecret secrets.ftsSecret) + _ = _ := by + simp_rw [mul_add, ← mul_assoc, ENNReal.tsum_add, ENNReal.tsum_mul_right] + rfl + +theorem probEvent_sampled_jointPrimitive_le_three_mul_of_residual + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hresidual : Pr[SampledViewedEvent residualPrimitiveEvent | sampledViewedGame adversary] ≤ + sampledQueryCharge residualPrimitiveQueryCharge adversary * + (Fintype.card Digest : ℝ≥0∞)⁻¹) : + Pr[SampledViewedEvent jointPrimitiveEvent | sampledViewedGame adversary] ≤ + ((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹ := by + apply (probEvent_sampled_jointPrimitive_le_charge_add_residual adversary).trans + calc + _ ≤ sampledQueryCharge TightEncoding.refinedStructuralEncodingQueryCharge adversary * + (Fintype.card Digest : ℝ≥0∞)⁻¹ + + sampledQueryCharge residualPrimitiveQueryCharge adversary * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := add_le_add le_rfl hresidual + _ = (sampledQueryCharge TightEncoding.refinedStructuralEncodingQueryCharge adversary + + sampledQueryCharge residualPrimitiveQueryCharge adversary) * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := (add_mul ..).symm + _ ≤ (3 * q : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := + mul_le_mul' (sampled_structural_add_residual_queryCharge_le adversary q hq) le_rfl + _ = _ := by simp [digestBits] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/JointPrimitiveTerminal.lean b/formal/sphincs/SphincsSecurity/Proof/JointPrimitiveTerminal.lean new file mode 100644 index 00000000..46467781 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/JointPrimitiveTerminal.lean @@ -0,0 +1,58 @@ +import SphincsSecurity.Proof.FewTimeHonestLeakBound + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +def jointPrimitiveEvent (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : Prop := + result.1.2.2 = true ∧ + (Bad parameter otsSecret ftsSecret result.2.cache ∨ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result ∨ + cleanOtsOpeningEvent parameter otsSecret ftsSecret result ∨ + cleanUncoveredEvent parameter otsSecret ftsSecret result) + +theorem probEvent_win_le_jointPrimitive_add_message_add_forest (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + let run := gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + Pr[= true | (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run' ∅] ≤ + Pr[jointPrimitiveEvent parameter otsSecret ftsSecret | run] + + (Pr[cleanMessageEvent parameter otsSecret ftsSecret | run] + + Pr[ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret | run]) := by + classical + dsimp only + let run := gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + let primitive := jointPrimitiveEvent parameter otsSecret ftsSecret + let message := cleanMessageEvent parameter otsSecret ftsSecret + let forest := ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret + calc + _ = Pr[fun result => result.1.2.2 = true | run] := by + rw [StateT.run'_eq, ← probEvent_eq_eq_probOutput, + ← gameAfterSecretsWithViewTrace_verdictCache_projection adversary parameter otsSecret + ftsSecret, probEvent_map] + rw [probEvent_map] + rfl + _ ≤ Pr[fun result => primitive result ∨ message result ∨ forest result | run] := by + apply probEvent_mono + intro result hresult hwin + by_cases hbad : Bad parameter otsSecret ftsSecret result.2.cache + · exact Or.inl ⟨hwin, Or.inl hbad⟩ + · have hterminal := + (gameAfterSecretsWithViewTrace_winning_honestLeakTerminal_classify adversary + parameter otsSecret ftsSecret result hresult hwin).resolve_left hbad + rcases viewedWinningHonestLeakTerminalWitness_cases parameter otsSecret ftsSecret + result hterminal with hfresh | hencoding | hbackward | hmessage | hforest | huncovered + · exact Or.inl ⟨hwin, Or.inr (Or.inr (Or.inl (Or.inl ⟨⟨hbad, hwin⟩, hfresh⟩)))⟩ + · exact Or.inl ⟨hwin, Or.inr (Or.inl hencoding)⟩ + · exact Or.inl ⟨hwin, Or.inr (Or.inr (Or.inl (Or.inr ⟨⟨hbad, hwin⟩, hbackward⟩)))⟩ + · exact Or.inr (Or.inl ⟨hbad, hmessage⟩) + · exact Or.inr (Or.inr hforest) + · exact Or.inl ⟨hwin, Or.inr (Or.inr (Or.inr ⟨hbad, huncovered⟩))⟩ + _ ≤ _ := (probEvent_or_le _ _ _).trans (add_le_add le_rfl (probEvent_or_le _ _ _)) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/JointSecretOpeningQueryBudget.lean b/formal/sphincs/SphincsSecurity/Proof/JointSecretOpeningQueryBudget.lean new file mode 100644 index 00000000..1873adac --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/JointSecretOpeningQueryBudget.lean @@ -0,0 +1,94 @@ +import SphincsSecurity.Proof.FtsProbeQueryBudget126 +import SphincsSecurity.Proof.Security126Endpoint + +namespace SphincsSecurity.Concrete + +open _root_.OracleComp OracleSpec ENNReal + +noncomputable def ftsOpeningQueryReserve (secretKey : SecretKey) + (cache : QueryCache HashSpec) (input : HashInput) : ℝ≥0∞ := + FtsProbeSimulation.ftsHashQueryCharge secretKey.parameter cache input * (4 / 3) + +noncomputable def otsOpeningQueryReserve (secretKey : SecretKey) + (cache : QueryCache HashSpec) (input : HashInput) : ℝ≥0∞ := + residualPrimitiveQueryCharge secretKey cache input - ftsOpeningQueryReserve secretKey cache input + +def residualOtsOpeningEvent (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : Prop := + result.1.2.2 = true ∧ ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ¬ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result ∧ + cleanOtsOpeningEvent parameter otsSecret ftsSecret result + +theorem ftsOpeningQueryReserve_le_residual (secretKey : SecretKey) + (cache : QueryCache HashSpec) (input : HashInput) : + ftsOpeningQueryReserve secretKey cache input ≤ residualPrimitiveQueryCharge secretKey cache input := + (mul_le_mul' le_rfl (show (4 / 3 : ℝ≥0∞) ≤ 2 by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + norm_num)).trans + (FtsProbeSimulation.ftsHashQueryCharge_mul_two_le_residual secretKey cache input) + +theorem openingQueryReserve_add (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) : + ftsOpeningQueryReserve secretKey cache input + otsOpeningQueryReserve secretKey cache input = + residualPrimitiveQueryCharge secretKey cache input := + add_tsub_cancel_of_le (ftsOpeningQueryReserve_le_residual secretKey cache input) + +theorem sampled_openingQueryReserve_add (adversary : Adversary) : + sampledQueryCharge ftsOpeningQueryReserve adversary + sampledQueryCharge otsOpeningQueryReserve adversary = + sampledQueryCharge residualPrimitiveQueryCharge adversary := by + rw [sampledQueryCharge, sampledQueryCharge, sampledQueryCharge, ← ENNReal.tsum_add] + apply tsum_congr + intro secrets + rw [← mul_add, ← expectedQueryCharge_add] + congr 2 + funext cache input + exact openingQueryReserve_add _ cache input + +theorem sampled_ftsOpeningQueryReserve_eq (adversary : Adversary) : + sampledQueryCharge ftsOpeningQueryReserve adversary = + (4 / 3 : ℝ≥0∞) * sampledQueryCharge + (fun secretKey => FtsProbeSimulation.ftsHashQueryCharge secretKey.parameter) adversary := by + unfold sampledQueryCharge ftsOpeningQueryReserve + simp only [expectedQueryCharge_mul] + simp_rw [← mul_assoc, ENNReal.tsum_mul_right] + exact mul_comm _ _ + +theorem probEvent_sampled_residual_le_ots_add_fts (adversary : Adversary) : + Pr[SampledViewedEvent residualPrimitiveEvent | sampledViewedGame adversary] ≤ + Pr[SampledViewedEvent residualOtsOpeningEvent | sampledViewedGame adversary] + + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary] := by + apply (probEvent_mono (p := SampledViewedEvent residualPrimitiveEvent) + (q := fun result => SampledViewedEvent residualOtsOpeningEvent result ∨ + SampledViewedEvent cleanUncoveredEvent result) ?_).trans + · exact probEvent_or_le _ _ _ + · intro result _ hresult + obtain ⟨hwin, hbad, hencoding, hots | hfts⟩ := hresult + · exact Or.inl ⟨hwin, hbad, hencoding, hots⟩ + · exact Or.inr hfts + +theorem probEvent_sampled_residual_le_queryCharge_of_ots + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) + (hots : Pr[SampledViewedEvent residualOtsOpeningEvent | sampledViewedGame adversary] ≤ + sampledQueryCharge otsOpeningQueryReserve adversary * (Fintype.card Digest : ℝ≥0∞)⁻¹) : + Pr[SampledViewedEvent residualPrimitiveEvent | sampledViewedGame adversary] ≤ + sampledQueryCharge residualPrimitiveQueryCharge adversary * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + apply (probEvent_sampled_residual_le_ots_add_fts adversary).trans + have hfts := FtsProbeSimulation.probEvent_sampledViewedGame_cleanUncovered_le_queryCharge126 adversary q hq hqMax + rw [← sampled_ftsOpeningQueryReserve_eq] at hfts + apply (add_le_add hots hfts).trans_eq + rw [← add_mul, add_comm, sampled_openingQueryReserve_add] + +/-- The one-time-secret estimate remains an explicit premise. -/ +theorem security126_of_sampled_otsOpening_le_queryReserve + (hots : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ 126 → + Pr[SampledViewedEvent residualOtsOpeningEvent | sampledViewedGame adversary] ≤ + sampledQueryCharge otsOpeningQueryReserve adversary * (Fintype.card Digest : ℝ≥0∞)⁻¹) : + HasClassicalSecurityBits scheme 126 := by + apply security126_of_sampled_residual_le_queryCharge + intro q hqPos adversary hq hqMax + exact probEvent_sampled_residual_le_queryCharge_of_ots adversary q hq hqMax + (hots q hqPos adversary hq hqMax) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/JointTerminalBounds.lean b/formal/sphincs/SphincsSecurity/Proof/JointTerminalBounds.lean new file mode 100644 index 00000000..47bb9f0d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/JointTerminalBounds.lean @@ -0,0 +1,114 @@ +import SphincsSecurity.Proof.TightEncodingTerminal +import SphincsSecurity.Proof.FewTimeHonestLeakBound + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +def jointStructuralEncodingEvent (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : Prop := + Bad parameter otsSecret ftsSecret result.2.cache ∨ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result + +theorem probEvent_win_le_joint_terminal_cases (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + let run := gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + Pr[= true | (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run' ∅] ≤ + Pr[jointStructuralEncodingEvent parameter otsSecret ftsSecret | run] + + (Pr[cleanOtsOpeningEvent parameter otsSecret ftsSecret | run] + + (Pr[cleanMessageEvent parameter otsSecret ftsSecret | run] + + (Pr[ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret | run] + + Pr[cleanUncoveredEvent parameter otsSecret ftsSecret | run]))) := by + classical + dsimp only + let run := gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + let joint := jointStructuralEncodingEvent parameter otsSecret ftsSecret + let opening := cleanOtsOpeningEvent parameter otsSecret ftsSecret + let message := cleanMessageEvent parameter otsSecret ftsSecret + let proper := ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret + let uncovered := cleanUncoveredEvent parameter otsSecret ftsSecret + calc + _ = Pr[fun result => result.1.2.2 = true | run] := by + rw [StateT.run'_eq, ← probEvent_eq_eq_probOutput, + ← gameAfterSecretsWithViewTrace_verdictCache_projection adversary parameter otsSecret + ftsSecret, probEvent_map] + rw [probEvent_map] + rfl + _ ≤ Pr[fun result => joint result ∨ opening result ∨ message result ∨ proper result ∨ + uncovered result | run] := by + apply probEvent_mono + intro result hresult hwin + rcases gameAfterSecretsWithViewTrace_winning_honestLeakTerminal_classify adversary + parameter otsSecret ftsSecret result hresult hwin with hbad | hterminal + · exact Or.inl (Or.inl hbad) + · by_cases hbad : Bad parameter otsSecret ftsSecret result.2.cache + · exact Or.inl (Or.inl hbad) + · rcases viewedWinningHonestLeakTerminalWitness_cases parameter otsSecret ftsSecret + result hterminal with hfresh | hencoding | hbackward | hmessage | hproper | huncovered + · exact Or.inr (Or.inl (Or.inl ⟨⟨hbad, hwin⟩, hfresh⟩)) + · exact Or.inl (Or.inr hencoding) + · exact Or.inr (Or.inl (Or.inr ⟨⟨hbad, hwin⟩, hbackward⟩)) + · exact Or.inr (Or.inr (Or.inl ⟨hbad, hmessage⟩)) + · exact Or.inr (Or.inr (Or.inr (Or.inl hproper))) + · exact Or.inr (Or.inr (Or.inr (Or.inr ⟨hbad, huncovered⟩))) + _ ≤ Pr[joint | run] + + Pr[fun result => opening result ∨ message result ∨ proper result ∨ uncovered result | + run] := probEvent_or_le _ _ _ + _ ≤ _ := by + apply add_le_add le_rfl + calc + _ ≤ Pr[opening | run] + + Pr[fun result => message result ∨ proper result ∨ uncovered result | run] := + probEvent_or_le _ _ _ + _ ≤ _ := by + apply add_le_add le_rfl + calc + _ ≤ Pr[message | run] + + Pr[fun result => proper result ∨ uncovered result | run] := probEvent_or_le _ _ _ + _ ≤ _ := add_le_add le_rfl (probEvent_or_le _ _ _) + +theorem probEvent_win_le_joint_reserved_add_remaining + (adversary : Adversary) (q : Nat) (hqPos : 1 ≤ q) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 125) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + let run := gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + Pr[= true | (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run' ∅] ≤ + ((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹ + + ((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 131 : Nat) : ℝ≥0∞)⁻¹ + + (Pr[cleanOtsOpeningEvent parameter otsSecret ftsSecret | run] + + (Pr[cleanMessageEvent parameter otsSecret ftsSecret | run] + + Pr[cleanUncoveredEvent parameter otsSecret ftsSecret | run])) := by + dsimp only + have hjoint := probEvent_bad_or_viewedEncodingCollision_le_three_mul adversary parameter + otsSecret ftsSecret q (isQueryBoundP_gameAfterSecrets adversary q hq hparameter hots hfts) + have hforest := probEvent_gameAfterSecretsWithViewTrace_honest_leak_le_three_mul_inv131 + adversary q hqPos hq hqMax parameter hparameter otsSecret hots ftsSecret hfts + have hcard : Fintype.card Digest = 2 ^ 128 := by + simpa only [digestBits] using (show Fintype.card Digest = 2 ^ digestBits by simp) + rw [hcard] at hjoint + have hcast : (3 * q : ℝ≥0∞) = ((3 * q : Nat) : ℝ≥0∞) := by push_cast; rfl + rw [hcast] at hjoint + refine (probEvent_win_le_joint_terminal_cases adversary parameter otsSecret ftsSecret).trans ?_ + calc + _ ≤ ((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹ + + (Pr[cleanOtsOpeningEvent parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] + + (Pr[cleanMessageEvent parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] + + (((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 131 : Nat) : ℝ≥0∞)⁻¹ + + Pr[cleanUncoveredEvent parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret]))) := + add_le_add hjoint (add_le_add le_rfl (add_le_add le_rfl (add_le_add hforest le_rfl))) + _ = _ := by ac_rfl + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/JointTerminalSampling.lean b/formal/sphincs/SphincsSecurity/Proof/JointTerminalSampling.lean new file mode 100644 index 00000000..4d875300 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/JointTerminalSampling.lean @@ -0,0 +1,59 @@ +import SphincsSecurity.Proof.JointTerminalBounds + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +noncomputable def jointRemainingRisk (adversary : Adversary) + (secrets : SampledSecrets) : ℝ≥0∞ := + let run := gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret + Pr[cleanOtsOpeningEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | run] + + (Pr[cleanMessageEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | run] + + Pr[cleanUncoveredEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | run]) + +theorem weighted_jointRemainingRisk_eq (adversary : Adversary) : + (∑' secrets : SampledSecrets, + Pr[= secrets | sampleSecrets] * jointRemainingRisk adversary secrets) = + Pr[SampledViewedEvent cleanOtsOpeningEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanMessageEvent | sampledViewedGame adversary] + + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary]) := by + simp only [jointRemainingRisk, mul_add, ENNReal.tsum_add] + rw [← probEvent_sampledViewedGame_eq_weighted adversary cleanOtsOpeningEvent, + ← probEvent_sampledViewedGame_eq_weighted adversary cleanMessageEvent, + ← probEvent_sampledViewedGame_eq_weighted adversary cleanUncoveredEvent] + +theorem forgeAdvantage_le_joint_reserved_add_sampled_remaining + (adversary : Adversary) (q : Nat) (hqPos : 1 ≤ q) + (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 125) : + forgeAdvantage scheme adversary ≤ + ((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹ + + ((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 131 : Nat) : ℝ≥0∞)⁻¹ + + (Pr[SampledViewedEvent cleanOtsOpeningEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanMessageEvent | sampledViewedGame adversary] + + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary])) := by + rw [forgeAdvantage_eq_sampledGame, sampledGame] + calc + _ ≤ ((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹ + + ((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 131 : Nat) : ℝ≥0∞)⁻¹ + + ∑' secrets : SampledSecrets, + Pr[= secrets | sampleSecrets] * jointRemainingRisk adversary secrets := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_const_add_weighted + (oa := sampleSecrets) + (run := fun secrets => (simulateQ romImpl + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret)).run' ∅) + (event := fun verdict => verdict = true) + (cost := ((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹ + + ((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 131 : Nat) : ℝ≥0∞)⁻¹) + (jointRemainingRisk adversary) + intro secrets hsecrets + obtain ⟨hparameter, hots, hfts⟩ := secrets.support_components hsecrets + rw [probEvent_eq_eq_probOutput] + exact probEvent_win_le_joint_reserved_add_remaining adversary q hqPos hq hqMax + secrets.parameter hparameter secrets.otsSecret hots secrets.ftsSecret hfts + _ = _ := by rw [weighted_jointRemainingRisk_eq] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/Layer.lean b/formal/sphincs/SphincsSecurity/Proof/Layer.lean new file mode 100644 index 00000000..41416900 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Layer.lean @@ -0,0 +1,71 @@ +import SphincsSecurity.Proof.OneTime +import SphincsSecurity.Proof.Merkle + +/-! +# One layer of the hypertree + +A layer's verifier half is `Ots.leaf` followed by `Tree.fold`. Together they turn the message the +layer signs into the layer's root, which is the message the layer above signs. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp + +variable (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) (leaf : LeafIndex) + +theorem leafOfNat_val : leafOfNat leaf.val = leaf := by + ext + simp [leafOfNat, Nat.mod_eq_of_lt leaf.isLt] + +/-- The fold reads the path only below the height it folds. -/ +theorem treeFold_congr {m : Type → Type} [Monad m] [HasQuery HashSpec m] (path path' : Nat → Digest) + (levels : Nat) (hpath : ∀ level, level < levels → path level = path' level) (value : Digest) : + treeFold (m := m) parameter lay tree leaf path levels value + = treeFold (m := m) parameter lay tree leaf path' levels value := by + induction levels with + | zero => simp + | succ levels ih => + rw [treeFold_succ_eq, treeFold_succ_eq, ih (fun level hlevel => hpath level (by omega)), + hpath levels (by omega)] + +/-- Folding a leaf's whole path reaches the layer's root. -/ +theorem eval_treeFold_root (hleaf : leaf.val < 2 ^ layerHeight lay) : + evalWithAnswerFn f (treeFold parameter lay tree leaf + (fun level => evalWithAnswerFn f (treeNode parameter lay tree secret level + (Nat.xor (leaf.val / 2 ^ level) 1))) + (layerHeight lay) (evalWithAnswerFn f (treeNode parameter lay tree secret 0 leaf.val))) + = evalWithAnswerFn f (treeRoot parameter lay tree secret) := by + rw [eval_treeFold, treeRoot, Nat.div_eq_of_lt hleaf] + +/-- **A layer.** Given a counter that encodes the message and a path that opens the leaf, the +verifier's half of a layer hands the layer's root to whatever follows it. -/ +theorem eval_layer {α : Type} (message : Digest) (counter : Counter) (codeword : Encoding) + (hencode : evalWithAnswerFn f (encode parameter lay tree leaf message counter) = some codeword) + (hleaf : leaf.val < 2 ^ layerHeight lay) (path : Nat → Digest) + (hpath : ∀ level, level < layerHeight lay → path level + = evalWithAnswerFn f (treeNode parameter lay tree secret level + (Nat.xor (leaf.val / 2 ^ level) 1))) + (fail : OracleComp HashSpec α) (continuation : Digest → OracleComp HashSpec α) : + evalWithAnswerFn f (do + match ← otsLeaf parameter lay tree leaf message counter + (fun chainIdx => evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx 0 + (codeword chainIdx).val (secret leaf chainIdx))) with + | none => fail + | some value => do + let root ← treeFold parameter lay tree leaf path (layerHeight lay) value + continuation root) + = evalWithAnswerFn f (continuation + (evalWithAnswerFn f (treeRoot parameter lay tree secret))) := by + rw [evalWithAnswerFn_bind, eval_otsLeaf f parameter lay tree leaf (secret leaf) message counter + codeword hencode] + rw [evalWithAnswerFn_bind, treeFold_congr parameter lay tree leaf path _ _ hpath] + rw [show evalWithAnswerFn f (do + let endpoints ← oneTimePublicKey parameter lay tree leaf (secret leaf) + leafHash parameter lay tree leaf endpoints) + = evalWithAnswerFn f (treeNode parameter lay tree secret 0 leaf.val) by + rw [treeNode_zero_eq, leafOfNat_val]] + rw [eval_treeFold_root f parameter lay tree secret leaf hleaf] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/LayerCompare.lean b/formal/sphincs/SphincsSecurity/Proof/LayerCompare.lean new file mode 100644 index 00000000..82be8cfa --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/LayerCompare.lean @@ -0,0 +1,354 @@ +import SphincsSecurity.Proof.EncodingCached + +/-! +# Comparing honest layer openings + +Two honest openings at the same one-time position either agree on the signed layer component, use +distinct encoding inputs with the same digest, or the forged codeword starts earlier on some chain. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +def EncodingHit (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (leftMessage rightMessage : Digest) + (leftCounter rightCounter : Counter) : Prop := + let leftInput := tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes leftMessage ++ counterBytes leftCounter) + let rightInput := tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes rightMessage ++ counterBytes rightCounter) + leftInput ≠ rightInput ∧ truncateHash (f leftInput) = truncateHash (f rightInput) + +theorem decode_of_eval_encode_eq_some (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) + (counter : Counter) (codeword : Encoding) + (hencode : evalWithAnswerFn f (encode parameter lay tree leafIdx message counter) + = some codeword) : + TargetSum.decodeDigest (truncateHash (f (tweakableHashInput parameter + (.encoding lay tree leafIdx) (digestBytes message ++ counterBytes counter)))) + = some codeword := by + simpa only [encode, evalWithAnswerFn_bind, evalWithAnswerFn_pure, eval_tweakableHash] using hencode + +theorem valid_of_eval_encode_eq_some (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) + (counter : Counter) (codeword : Encoding) + (hencode : evalWithAnswerFn f (encode parameter lay tree leafIdx message counter) + = some codeword) : TargetSum.Valid codeword := + TargetSum.valid_of_decodeDigest_eq_some + (decode_of_eval_encode_eq_some f parameter lay tree leafIdx message counter codeword hencode) + +theorem eval_encode_ne_none_iff_validDigest (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (counter : Counter) : + evalWithAnswerFn f (encode parameter lay tree leafIdx message counter) ≠ none ↔ + TargetSum.ValidDigest (truncateHash (f (tweakableHashInput parameter + (.encoding lay tree leafIdx) (digestBytes message ++ counterBytes counter)))) := by + simp only [encode, evalWithAnswerFn_bind, evalWithAnswerFn_pure, eval_tweakableHash] + exact TargetSum.validDigest_iff_decodeDigest_ne_none.symm + +theorem honestLayerOpening_compare (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (leftMessage rightMessage : Digest) + (leftCounter rightCounter : Counter) (leftValues rightValues : ChainIndex → Digest) + (leftPath rightPath : Nat → Digest) + (hleft : HonestLayerOpening f parameter otsSecret lay tree leafIdx leftMessage leftCounter + leftValues leftPath) + (hright : HonestLayerOpening f parameter otsSecret lay tree leafIdx rightMessage rightCounter + rightValues rightPath) : + (leftMessage = rightMessage ∧ leftCounter = rightCounter ∧ leftValues = rightValues + ∧ ∀ level, level < layerHeight lay → leftPath level = rightPath level) + ∨ EncodingHit f parameter lay tree leafIdx leftMessage rightMessage leftCounter rightCounter + ∨ ∃ leftCodeword rightCodeword, + evalWithAnswerFn f (encode parameter lay tree leafIdx leftMessage leftCounter) + = some leftCodeword + ∧ evalWithAnswerFn f (encode parameter lay tree leafIdx rightMessage rightCounter) + = some rightCodeword + ∧ ∃ chainIdx, (rightCodeword chainIdx).val < (leftCodeword chainIdx).val := by + obtain ⟨leftCodeword, hleftEncode, hleftValues, hleftPath⟩ := hleft + obtain ⟨rightCodeword, hrightEncode, hrightValues, hrightPath⟩ := hright + by_cases hcodeword : leftCodeword = rightCodeword + · subst rightCodeword + let leftInput := tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes leftMessage ++ counterBytes leftCounter) + let rightInput := tweakableHashInput parameter (.encoding lay tree leafIdx) + (digestBytes rightMessage ++ counterBytes rightCounter) + by_cases hinput : leftInput = rightInput + · have hpayload := (tweakableHashInput_injective parameter (by trivial) (by trivial) hinput).2 + obtain ⟨hmessageBytes, hcounterBytes⟩ := + List.append_inj hpayload (by simp [digestBytes_length]) + have hmessage := digestBytes_injective hmessageBytes + have hcounter := bytesLE_injective hcounterBytes + left + refine ⟨hmessage, hcounter, ?_, ?_⟩ + · funext chainIdx + rw [hleftValues chainIdx, hrightValues chainIdx] + · intro level hlevel + rw [hleftPath level hlevel, hrightPath level hlevel] + · right + left + have hleftDecode := decode_of_eval_encode_eq_some f parameter lay tree leafIdx leftMessage + leftCounter leftCodeword hleftEncode + have hrightDecode := decode_of_eval_encode_eq_some f parameter lay tree leafIdx rightMessage + rightCounter leftCodeword hrightEncode + exact ⟨hinput, TargetSum.decodeDigest_some_injective hleftDecode hrightDecode⟩ + · right + right + refine ⟨leftCodeword, rightCodeword, hleftEncode, hrightEncode, ?_⟩ + by_contra hnot + have hnot' : ∀ chainIdx, + ¬ (rightCodeword chainIdx).val < (leftCodeword chainIdx).val := + not_exists.mp hnot + have hle : ∀ chainIdx, (leftCodeword chainIdx).val ≤ (rightCodeword chainIdx).val := by + intro chainIdx + exact Nat.le_of_not_gt (hnot' chainIdx) + exact hcodeword (TargetSum.eq_of_le_of_valid + (valid_of_eval_encode_eq_some f parameter lay tree leafIdx leftMessage leftCounter leftCodeword + hleftEncode) + (valid_of_eval_encode_eq_some f parameter lay tree leafIdx rightMessage rightCounter rightCodeword + hrightEncode) hle) + +theorem honestLayerOpening_values_path_eq_of_encodingHit + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (leftMessage rightMessage : Digest) (leftCounter rightCounter : Counter) + (leftValues rightValues : ChainIndex → Digest) (leftPath rightPath : Nat → Digest) + (hleft : HonestLayerOpening f parameter otsSecret lay tree leafIdx leftMessage leftCounter + leftValues leftPath) + (hright : HonestLayerOpening f parameter otsSecret lay tree leafIdx rightMessage rightCounter + rightValues rightPath) + (hhit : EncodingHit f parameter lay tree leafIdx leftMessage rightMessage + leftCounter rightCounter) : + leftValues = rightValues ∧ + ∀ level, level < layerHeight lay → leftPath level = rightPath level := by + obtain ⟨leftCodeword, hleftEncode, hleftValues, hleftPath⟩ := hleft + obtain ⟨rightCodeword, hrightEncode, hrightValues, hrightPath⟩ := hright + have hleftDecode := decode_of_eval_encode_eq_some f parameter lay tree leafIdx leftMessage + leftCounter leftCodeword hleftEncode + have hrightDecode := decode_of_eval_encode_eq_some f parameter lay tree leafIdx rightMessage + rightCounter rightCodeword hrightEncode + change _ ≠ _ ∧ truncateHash (f _) = truncateHash (f _) at hhit + rw [hhit.2] at hleftDecode + have hcodeword : leftCodeword = rightCodeword := + Option.some.inj (hleftDecode.symm.trans hrightDecode) + constructor + · funext chainIdx + rw [hleftValues chainIdx, hrightValues chainIdx, hcodeword] + · intro level hlevel + rw [hleftPath level hlevel, hrightPath level hlevel] + +def SignedLayerAt (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) : Prop := + ∃ (entry : (request : SignRequest) × SigningSpec.Range request) (signature : Signature) + (index : Index) (leaves : DigestTree → FtsLeaf), + entry ∈ signingLog + ∧ entry.2 = some signature + ∧ SuccessfulSignRun f cache secretKey entry.1 signature + ∧ SuccessfulDigestRun f cache secretKey entry.1 signature.randomness index leaves + ∧ treeIndexAt index lay = tree + ∧ leafIndexAt index lay = leafIdx + ∧ CachedRun cache f (layerMessage secretKey index lay) + ∧ cache (tweakableHashInput secretKey.parameter + (.encoding lay (treeIndexAt index lay) (leafIndexAt index lay)) + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay))) ≠ none + ∧ HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay + (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f (layerMessage secretKey index lay)) (signature.counter lay) + (signature.chainValue lay) (signaturePath signature lay) + +def LayerComparisonFailure (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (forgedMessage : Digest) + (forgedCounter : Counter) : Prop := + ∃ (entry : (request : SignRequest) × SigningSpec.Range request) (signature : Signature) + (index : Index) (leaves : DigestTree → FtsLeaf), + entry ∈ signingLog + ∧ entry.2 = some signature + ∧ SuccessfulSignRun f cache secretKey entry.1 signature + ∧ SuccessfulDigestRun f cache secretKey entry.1 signature.randomness index leaves + ∧ treeIndexAt index lay = tree + ∧ leafIndexAt index lay = leafIdx + ∧ CachedRun cache f (layerMessage secretKey index lay) + ∧ HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay tree leafIdx + (evalWithAnswerFn f (layerMessage secretKey index lay)) (signature.counter lay) + (signature.chainValue lay) (signaturePath signature lay) + ∧ cache (tweakableHashInput secretKey.parameter + (.encoding lay tree leafIdx) + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay))) ≠ none + ∧ (EncodingHit f secretKey.parameter lay tree leafIdx + (evalWithAnswerFn f (layerMessage secretKey index lay)) forgedMessage + (signature.counter lay) forgedCounter + ∨ ∃ signedCodeword forgedCodeword, + evalWithAnswerFn f (encode secretKey.parameter lay tree leafIdx + (evalWithAnswerFn f (layerMessage secretKey index lay)) (signature.counter lay)) + = some signedCodeword + ∧ evalWithAnswerFn f (encode secretKey.parameter lay tree leafIdx + forgedMessage forgedCounter) = some forgedCodeword + ∧ ∃ chainIdx, (forgedCodeword chainIdx).val < (signedCodeword chainIdx).val) + +theorem signedLayerAt_of_signing_entry (f : QueryImpl HashSpec Id) + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (initialCache : QueryCache HashSpec) (value : alpha) (signingLog : QueryLog SigningSpec) + (adversaryCache finalCache : QueryCache HashSpec) + (hmem : ((value, signingLog), adversaryCache) ∈ support + ((simulateQ romImpl + ((simulateQ (forwardOracles + signingOracle scheme secretKey) + computation).run)).run initialCache)) + (hle : adversaryCache ≤ finalCache) (hf : finalCache.AgreesWithFn f) + (entry : (request : SignRequest) × SigningSpec.Range request) (signature : Signature) + (hresponse : entry.2 = some signature) (hentry : entry ∈ signingLog) (lay : Layer) : + ∃ index, SignedLayerAt f finalCache secretKey signingLog lay + (treeIndexAt index lay) (leafIndexAt index lay) := by + have hrun := successfulSignRun_of_signing_entry f secretKey computation initialCache value + signingLog adversaryCache finalCache hmem hle hf entry signature hresponse hentry + obtain ⟨index, leaves, hfts⟩ := hrun.honest_fts_at + obtain ⟨hmessage, hopening⟩ := hrun.honest_layer_at_of_digest hfts.1 lay + have hencoding := hrun.signed_encode_cached_of_digest hfts.1 lay + exact ⟨index, entry, signature, index, leaves, hentry, hresponse, hrun, hfts.1, rfl, rfl, hmessage, + hencoding, hopening⟩ + +theorem SignedLayerAt.compare_forgery {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} + {lay : Layer} {tree : TreeIndex} {leafIdx : LeafIndex} + (hsigned : SignedLayerAt f cache secretKey signingLog lay tree leafIdx) + (forgedMessage : Digest) (forgedCounter : Counter) + (forgedValues : ChainIndex → Digest) (forgedPath : Nat → Digest) + (hforged : HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay tree leafIdx + forgedMessage forgedCounter forgedValues forgedPath) : + ∃ (entry : (request : SignRequest) × SigningSpec.Range request) (signature : Signature) + (index : Index) (leaves : DigestTree → FtsLeaf), + entry ∈ signingLog + ∧ entry.2 = some signature + ∧ SuccessfulSignRun f cache secretKey entry.1 signature + ∧ SuccessfulDigestRun f cache secretKey entry.1 signature.randomness index leaves + ∧ treeIndexAt index lay = tree + ∧ leafIndexAt index lay = leafIdx + ∧ CachedRun cache f (layerMessage secretKey index lay) + ∧ HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay tree leafIdx + (evalWithAnswerFn f (layerMessage secretKey index lay)) (signature.counter lay) + (signature.chainValue lay) (signaturePath signature lay) + ∧ cache (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay))) ≠ none + ∧ ((evalWithAnswerFn f (layerMessage secretKey index lay) = forgedMessage + ∧ signature.counter lay = forgedCounter + ∧ signature.chainValue lay = forgedValues + ∧ ∀ level, level < layerHeight lay → + signaturePath signature lay level = forgedPath level) + ∨ EncodingHit f secretKey.parameter lay tree leafIdx + (evalWithAnswerFn f (layerMessage secretKey index lay)) forgedMessage + (signature.counter lay) forgedCounter + ∨ ∃ signedCodeword forgedCodeword, + evalWithAnswerFn f (encode secretKey.parameter lay tree leafIdx + (evalWithAnswerFn f (layerMessage secretKey index lay)) (signature.counter lay)) + = some signedCodeword + ∧ evalWithAnswerFn f (encode secretKey.parameter lay tree leafIdx + forgedMessage forgedCounter) = some forgedCodeword + ∧ ∃ chainIdx, (forgedCodeword chainIdx).val < (signedCodeword chainIdx).val) := by + obtain ⟨entry, signature, index, leaves, hentry, hresponse, hrun, hdigest, htree, hleaf, + hmessage, hencoding, hopening⟩ := hsigned + have hopening' : HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay tree leafIdx + (evalWithAnswerFn f (layerMessage secretKey index lay)) (signature.counter lay) + (signature.chainValue lay) (signaturePath signature lay) := by + simpa only [htree, hleaf] using hopening + rw [htree, hleaf] at hencoding + exact ⟨entry, signature, index, leaves, hentry, hresponse, hrun, hdigest, htree, hleaf, + hmessage, hopening', hencoding, + honestLayerOpening_compare f secretKey.parameter secretKey.otsSecret lay tree leafIdx + (evalWithAnswerFn f (layerMessage secretKey index lay)) forgedMessage + (signature.counter lay) forgedCounter (signature.chainValue lay) forgedValues + (signaturePath signature lay) forgedPath hopening' hforged⟩ + +theorem SignedLayerAt.exact_or_failure {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} + {lay : Layer} {tree : TreeIndex} {leafIdx : LeafIndex} + (hsigned : SignedLayerAt f cache secretKey signingLog lay tree leafIdx) + (forgedMessage : Digest) (forgedCounter : Counter) + (forgedValues : ChainIndex → Digest) (forgedPath : Nat → Digest) + (hforged : HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay tree leafIdx + forgedMessage forgedCounter forgedValues forgedPath) : + (∃ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature) (index : Index) (leaves : DigestTree → FtsLeaf), + entry ∈ signingLog + ∧ entry.2 = some signature + ∧ SuccessfulSignRun f cache secretKey entry.1 signature + ∧ SuccessfulDigestRun f cache secretKey entry.1 signature.randomness index leaves + ∧ treeIndexAt index lay = tree + ∧ leafIndexAt index lay = leafIdx + ∧ evalWithAnswerFn f (layerMessage secretKey index lay) = forgedMessage + ∧ signature.counter lay = forgedCounter + ∧ signature.chainValue lay = forgedValues + ∧ ∀ level, level < layerHeight lay → + signaturePath signature lay level = forgedPath level) + ∨ LayerComparisonFailure f cache secretKey signingLog lay tree leafIdx + forgedMessage forgedCounter := by + obtain ⟨entry, signature, index, leaves, hentry, hresponse, hrun, hdigest, htree, hleaf, + hmessage, hopening, hcached, hresult⟩ := + hsigned.compare_forgery forgedMessage forgedCounter forgedValues forgedPath hforged + rcases hresult with hexact | hencoding | hearlier + · exact Or.inl ⟨entry, signature, index, leaves, hentry, hresponse, hrun, hdigest, + htree, hleaf, hexact⟩ + · exact Or.inr ⟨entry, signature, index, leaves, hentry, hresponse, hrun, hdigest, + htree, hleaf, hmessage, hopening, hcached, Or.inl hencoding⟩ + · exact Or.inr ⟨entry, signature, index, leaves, hentry, hresponse, hrun, hdigest, + htree, hleaf, hmessage, hopening, hcached, Or.inr hearlier⟩ + +theorem SignedLayerAt.settles_middle {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} + {forgedIndex : Index} + (hf : cache.AgreesWithFn f) + (hsigned : SignedLayerAt f cache secretKey signingLog topLayer + (treeIndexAt forgedIndex topLayer) (leafIndexAt forgedIndex topLayer)) : + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (.node middleLayer (treeIndexAt forgedIndex middleLayer) + ⟨layerHeight middleLayer - 1, by decide⟩ ⟨0, by positivity⟩) := by + obtain ⟨_, _, signedIndex, _, _, _, _, _, htree, hleaf, hcached, _⟩ := hsigned + have hnext : treeIndexAt signedIndex middleLayer = treeIndexAt forgedIndex middleLayer := by + apply Fin.ext + rw [layers_link_top signedIndex, layers_link_top forgedIndex] + rw [congrArg Fin.val htree, congrArg Fin.val hleaf] + rw [layerMessage_of_lt secretKey signedIndex topLayer (by decide)] at hcached + have hsettled := settled_treeRoot_of_cachedRun (ftsSecret := secretKey.ftsSecret) hf middleLayer + (treeIndexAt signedIndex middleLayer) (by + simpa only [show (⟨topLayer.val + 1, by decide⟩ : Layer) = middleLayer from rfl] using hcached) + simpa only [hnext] using hsettled + +theorem SignedLayerAt.settles_bottom {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} + {forgedIndex : Index} + (hf : cache.AgreesWithFn f) + (hsigned : SignedLayerAt f cache secretKey signingLog middleLayer + (treeIndexAt forgedIndex middleLayer) (leafIndexAt forgedIndex middleLayer)) : + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (.node bottomLayer (treeIndexAt forgedIndex bottomLayer) + ⟨layerHeight bottomLayer - 1, by decide⟩ ⟨0, by positivity⟩) := by + obtain ⟨_, _, signedIndex, _, _, _, _, _, htree, hleaf, hcached, _⟩ := hsigned + have hnext : treeIndexAt signedIndex bottomLayer = treeIndexAt forgedIndex bottomLayer := by + apply Fin.ext + rw [layers_link_middle signedIndex, layers_link_middle forgedIndex] + rw [congrArg Fin.val htree, congrArg Fin.val hleaf] + rw [layerMessage_of_lt secretKey signedIndex middleLayer (by decide)] at hcached + have hsettled := settled_treeRoot_of_cachedRun (ftsSecret := secretKey.ftsSecret) hf bottomLayer + (treeIndexAt signedIndex bottomLayer) (by + simpa only [show (⟨middleLayer.val + 1, by decide⟩ : Layer) = bottomLayer from rfl] using hcached) + simpa only [hnext] using hsettled + +theorem SignedLayerAt.settles_fts {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} + {forgedIndex : Index} + (hf : cache.AgreesWithFn f) + (hsigned : SignedLayerAt f cache secretKey signingLog bottomLayer + (treeIndexAt forgedIndex bottomLayer) (leafIndexAt forgedIndex bottomLayer)) : + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (.ftsRoots forgedIndex) := by + obtain ⟨_, _, signedIndex, _, _, _, _, _, htree, hleaf, hcached, _⟩ := hsigned + have hindex := index_eq_of_bottom_position_eq htree hleaf + subst signedIndex + rw [layerMessage_bottomLayer secretKey forgedIndex] at hcached + exact settled_ftsRoots_of_cachedRun (otsSecret := secretKey.otsSecret) hf forgedIndex hcached + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbe.lean b/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbe.lean new file mode 100644 index 00000000..112b9204 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbe.lean @@ -0,0 +1,1218 @@ +import SphincsSecurity.Proof.EncodingProbability +import VCVio.OracleComp.QueryTracking.RandomOracle.DeferredSampling + +/-! +# Lazy hidden values with selective reveals + +An honest computation may reserve an opaque cell without sampling its value. A later materialization +samples the cell and checks every earlier probe. A separate publication marks values returned by a +successful computation as public. Cells that remain hidden are sampled only when the experiment +finishes. Thus the construction stays lazy: no random-oracle table is sampled in advance. + +Every probe against a hidden cell contributes one candidate. Reveals and finalization consume all +candidates at a cell against one fresh uniform hash output, so the total hit probability is at most +the number of probes times `2^-128`. +-/ + +namespace SphincsSecurity.LazyRevealProbe + +open OracleComp OracleSpec ENNReal + +variable {Coordinate : Type} [DecidableEq Coordinate] + +structure State (Coordinate : Type) where + pending : Finset (Coordinate × Digest) + values : Coordinate → Option HashOutput + revealed : Finset Coordinate + ensured : Finset Coordinate + +def State.empty : State Coordinate := + { pending := ∅ + values := fun _ => none + revealed := ∅ + ensured := ∅ } + +def State.Valid (state : State Coordinate) : Prop := + ∀ coordinate, coordinate ∈ state.revealed ↔ state.values coordinate ≠ none + +omit [DecidableEq Coordinate] in +theorem State.valid_empty : (State.empty : State Coordinate).Valid := by + intro coordinate + simp [State.empty] + +def State.pendingAt (state : State Coordinate) (coordinate : Coordinate) : Finset Digest := + (state.pending.filter fun entry => entry.1 = coordinate).image Prod.snd + +def State.pendingAway (state : State Coordinate) (coordinate : Coordinate) : + Finset (Coordinate × Digest) := + state.pending.filter fun entry => entry.1 ≠ coordinate + +def State.addPending (state : State Coordinate) (coordinate : Coordinate) + (candidate : Digest) : State Coordinate := + { state with pending := insert (coordinate, candidate) state.pending } + +def State.ensure (state : State Coordinate) (coordinate : Coordinate) : State Coordinate := + { state with ensured := insert coordinate state.ensured } + +def State.install (state : State Coordinate) (coordinate : Coordinate) + (output : HashOutput) : State Coordinate := + { pending := state.pendingAway coordinate + values := Function.update state.values coordinate (some output) + revealed := insert coordinate state.revealed + ensured := insert coordinate state.ensured } + +def State.materialize (state : State Coordinate) (coordinate : Coordinate) + (output : HashOutput) : State Coordinate := + { state with + pending := state.pendingAway coordinate + values := Function.update state.values coordinate (some output) + ensured := insert coordinate state.ensured } + +def State.publish (state : State Coordinate) (coordinate : Coordinate) : State Coordinate := + { state with revealed := insert coordinate state.revealed } + +def State.complete (state : State Coordinate) (coordinate : Coordinate) + (output : HashOutput) : State Coordinate := + { state with + pending := state.pendingAway coordinate + values := Function.update state.values coordinate (some output) } + +def State.clearPending (state : State Coordinate) (coordinate : Coordinate) : State Coordinate := + { state with pending := state.pendingAway coordinate } + +def State.coordinates (state : State Coordinate) : Finset Coordinate := + state.ensured ∪ state.pending.image Prod.fst + +def State.hitAt (state : State Coordinate) (coordinate : Coordinate) + (output : HashOutput) : Prop := + truncateHash output ∈ state.pendingAt coordinate + +noncomputable instance (state : State Coordinate) (coordinate : Coordinate) + (output : HashOutput) : Decidable (state.hitAt coordinate output) := + Classical.propDecidable _ + +theorem State.pendingAt_addPending_self (state : State Coordinate) + (coordinate : Coordinate) (candidate : Digest) : + candidate ∈ (state.addPending coordinate candidate).pendingAt coordinate := by + simp [State.pendingAt, State.addPending] + +theorem State.pending_card_addPending_le (state : State Coordinate) + (coordinate : Coordinate) (candidate : Digest) : + (state.addPending coordinate candidate).pending.card ≤ state.pending.card + 1 := by + simpa [State.addPending, Nat.add_comm] using + Finset.card_insert_le (coordinate, candidate) state.pending + +theorem State.pendingAt_card_le (state : State Coordinate) (coordinate : Coordinate) : + (state.pendingAt coordinate).card ≤ + (state.pending.filter fun entry => entry.1 = coordinate).card := by + exact Finset.card_image_le + +theorem State.pendingAway_card_add_filter_card (state : State Coordinate) + (coordinate : Coordinate) : + (state.pendingAway coordinate).card + + (state.pending.filter fun entry => entry.1 = coordinate).card = + state.pending.card := by + simpa [State.pendingAway, add_comm] using + (Finset.card_filter_add_card_filter_not + (s := state.pending) (p := fun entry : Coordinate × Digest => entry.1 = coordinate)) + +theorem State.pendingAway_card_add_pendingAt_card_le (state : State Coordinate) + (coordinate : Coordinate) : + (state.pendingAway coordinate).card + (state.pendingAt coordinate).card ≤ + state.pending.card := by + rw [← state.pendingAway_card_add_filter_card coordinate] + gcongr + exact state.pendingAt_card_le coordinate + +theorem State.Valid.addPending {state : State Coordinate} (hvalid : state.Valid) + (coordinate : Coordinate) (candidate : Digest) : + (state.addPending coordinate candidate).Valid := by + simpa [State.Valid, State.addPending] using hvalid + +theorem State.Valid.ensure {state : State Coordinate} (hvalid : state.Valid) + (coordinate : Coordinate) : (state.ensure coordinate).Valid := by + simpa [State.Valid, State.ensure] using hvalid + +omit [DecidableEq Coordinate] in +theorem State.Valid.value_of_revealed {state : State Coordinate} (hvalid : state.Valid) + {coordinate : Coordinate} (hrevealed : coordinate ∈ state.revealed) : + ∃ output, state.values coordinate = some output := by + exact Option.ne_none_iff_exists'.mp ((hvalid coordinate).mp hrevealed) + +omit [DecidableEq Coordinate] in +theorem State.Valid.not_revealed_value_none {state : State Coordinate} + (hvalid : state.Valid) {coordinate : Coordinate} + (hhidden : coordinate ∉ state.revealed) : state.values coordinate = none := by + cases hvalue : state.values coordinate with + | none => rfl + | some output => + exact (hhidden ((hvalid coordinate).mpr (by simp [hvalue]))).elim + +theorem State.Valid.install {state : State Coordinate} (hvalid : state.Valid) + (coordinate : Coordinate) (output : HashOutput) : + (state.install coordinate output).Valid := by + intro other + by_cases heq : other = coordinate + · subst other + simp [State.install] + · simp only [State.install, Finset.mem_insert, Function.update_of_ne heq, + heq, false_or] + exact hvalid other + +theorem State.pending_card_ensure (state : State Coordinate) (coordinate : Coordinate) : + (state.ensure coordinate).pending.card = state.pending.card := rfl + +theorem State.pending_card_install (state : State Coordinate) (coordinate : Coordinate) + (output : HashOutput) : + (state.install coordinate output).pending.card = (state.pendingAway coordinate).card := rfl + +theorem State.pending_card_materialize (state : State Coordinate) (coordinate : Coordinate) + (output : HashOutput) : + (state.materialize coordinate output).pending.card = + (state.pendingAway coordinate).card := rfl + +theorem State.pending_card_complete (state : State Coordinate) (coordinate : Coordinate) + (output : HashOutput) : + (state.complete coordinate output).pending.card = (state.pendingAway coordinate).card := rfl + +theorem State.pending_card_clearPending (state : State Coordinate) (coordinate : Coordinate) : + (state.clearPending coordinate).pending.card = (state.pendingAway coordinate).card := rfl + +noncomputable def sampleHashOutput : ProbComp HashOutput := + $ᵗ HashOutput + +theorem probEvent_sampleHashOutput_hitAt_le (state : State Coordinate) + (coordinate : Coordinate) : + Pr[state.hitAt coordinate | sampleHashOutput] ≤ + ((state.pendingAt coordinate).card : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + unfold State.hitAt sampleHashOutput + rw [probEvent_uniform_truncateHash_mem] + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + rfl + +inductive Query (Coordinate : Type) where + | uniform (n : Nat) + | hashOutput + | ensure (coordinate : Coordinate) + | probe (coordinate : Coordinate) (candidate : Digest) + | peek (coordinate : Coordinate) + | publish (coordinate : Coordinate) + | reveal (coordinate : Coordinate) + +@[reducible] def World (Coordinate : Type) : OracleSpec (Query Coordinate) := + OracleSpec.ofFn fun + | .uniform n => Fin (n + 1) + | .hashOutput => HashOutput + | .ensure _ => Unit + | .probe _ _ => Unit + | .peek _ => Option HashOutput + | .publish _ => Unit + | .reveal _ => HashOutput + +def IsProbe : (World Coordinate).Domain → Prop + | .uniform _ => False + | .hashOutput => False + | .ensure _ => False + | .probe _ _ => True + | .peek _ => False + | .publish _ => False + | .reveal _ => False + +noncomputable instance : DecidablePred (IsProbe (Coordinate := Coordinate)) := + fun input => match input with + | .uniform _ => isFalse (by simp [IsProbe]) + | .hashOutput => isFalse (by simp [IsProbe]) + | .ensure _ => isFalse (by simp [IsProbe]) + | .probe _ _ => isTrue (by simp [IsProbe]) + | .peek _ => isFalse (by simp [IsProbe]) + | .publish _ => isFalse (by simp [IsProbe]) + | .reveal _ => isFalse (by simp [IsProbe]) + +def uniformQuery (n : Nat) : OracleComp (World Coordinate) (Fin (n + 1)) := + liftM ((World Coordinate).query (.uniform n)) + +def hashOutputQuery : OracleComp (World Coordinate) HashOutput := + liftM ((World Coordinate).query .hashOutput) + +def ensureQuery (coordinate : Coordinate) : OracleComp (World Coordinate) Unit := + liftM ((World Coordinate).query (.ensure coordinate)) + +def probeQuery (coordinate : Coordinate) (candidate : Digest) : + OracleComp (World Coordinate) Unit := + liftM ((World Coordinate).query (.probe coordinate candidate)) + +def peekQuery (coordinate : Coordinate) : + OracleComp (World Coordinate) (Option HashOutput) := + liftM ((World Coordinate).query (.peek coordinate)) + +def publishQuery (coordinate : Coordinate) : OracleComp (World Coordinate) Unit := + liftM ((World Coordinate).query (.publish coordinate)) + +def revealQuery (coordinate : Coordinate) : OracleComp (World Coordinate) HashOutput := + liftM ((World Coordinate).query (.reveal coordinate)) + +def uniformForwardImpl : QueryImpl unifSpec (OracleComp (World Coordinate)) := + fun n => uniformQuery n + +def liftProbComp (computation : ProbComp alpha) : OracleComp (World Coordinate) alpha := + simulateQ uniformForwardImpl computation + +omit [DecidableEq Coordinate] in +theorem liftProbComp_isProbeBound (computation : ProbComp alpha) (fuel : Nat) : + (liftProbComp (Coordinate := Coordinate) computation).IsQueryBoundP IsProbe fuel := by + induction computation using OracleComp.inductionOn with + | pure result => trivial + | query_bind n next ih => + rw [liftProbComp, simulateQ_query_bind] + change (uniformQuery n >>= fun output => + liftProbComp (next output)).IsQueryBoundP IsProbe fuel + rw [uniformQuery, OracleComp.isQueryBoundP_query_bind_iff] + constructor + · simp [IsProbe] + · intro output + simpa [IsProbe] using ih output + +omit [DecidableEq Coordinate] in +theorem ensureQuery_isProbeBound (coordinate : Coordinate) (fuel : Nat) : + (ensureQuery coordinate).IsQueryBoundP IsProbe fuel := by + rw [ensureQuery, OracleComp.isQueryBoundP_query_iff] + simp [IsProbe] + +omit [DecidableEq Coordinate] in +theorem probeQuery_isProbeBound (coordinate : Coordinate) (candidate : Digest) : + (probeQuery coordinate candidate).IsQueryBoundP IsProbe 1 := by + rw [probeQuery, OracleComp.isQueryBoundP_query_iff] + simp [IsProbe] + +omit [DecidableEq Coordinate] in +theorem peekQuery_isProbeBound (coordinate : Coordinate) (fuel : Nat) : + (peekQuery coordinate).IsQueryBoundP IsProbe fuel := by + rw [peekQuery, OracleComp.isQueryBoundP_query_iff] + simp [IsProbe] + +omit [DecidableEq Coordinate] in +theorem publishQuery_isProbeBound (coordinate : Coordinate) (fuel : Nat) : + (publishQuery coordinate).IsQueryBoundP IsProbe fuel := by + rw [publishQuery, OracleComp.isQueryBoundP_query_iff] + simp [IsProbe] + +omit [DecidableEq Coordinate] in +theorem revealQuery_isProbeBound (coordinate : Coordinate) (fuel : Nat) : + (revealQuery coordinate).IsQueryBoundP IsProbe fuel := by + rw [revealQuery, OracleComp.isQueryBoundP_query_iff] + simp [IsProbe] + +omit [DecidableEq Coordinate] in +theorem hashOutputQuery_isProbeBound (fuel : Nat) : + (hashOutputQuery (Coordinate := Coordinate)).IsQueryBoundP IsProbe fuel := by + rw [hashOutputQuery, OracleComp.isQueryBoundP_query_iff] + simp [IsProbe] + +noncomputable def finalizeFrom : List Coordinate → State Coordinate → ProbComp Bool + | [], _ => pure false + | coordinate :: remaining, state => + match state.values coordinate with + | some _ => finalizeFrom remaining (state.clearPending coordinate) + | none => do + let output ← sampleHashOutput + if state.hitAt coordinate output then + pure true + else + finalizeFrom remaining (state.complete coordinate output) + +noncomputable def finalize (state : State Coordinate) : ProbComp Bool := + finalizeFrom state.coordinates.toList state + +theorem finalizeFrom_probability_le (coordinates : List Coordinate) + (state : State Coordinate) : + Pr[fun hit : Bool => hit = true | finalizeFrom coordinates state] ≤ + (state.pending.card : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + induction coordinates generalizing state with + | nil => simp [finalizeFrom] + | cons coordinate remaining ih => + rw [finalizeFrom] + cases hvalue : state.values coordinate with + | some output => + refine (ih (state.clearPending coordinate)).trans ?_ + have hcard : (state.clearPending coordinate).pending.card ≤ state.pending.card := by + rw [State.pending_card_clearPending] + simpa only [State.pendingAway] using + (Finset.card_filter_le (s := state.pending) + (p := fun entry : Coordinate × Digest => entry.1 ≠ coordinate)) + exact mul_le_mul_of_nonneg_right (by exact_mod_cast hcard) zero_le + | none => + refine (probEvent_bind_le_probEvent_add + (mx := sampleHashOutput) + (my := fun output => + if state.hitAt coordinate output then pure true + else finalizeFrom remaining (state.complete coordinate output)) + (q := fun hit : Bool => hit = true) + (p := state.hitAt coordinate) + (ε := ((state.pendingAway coordinate).card : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) ?_).trans ?_ + · intro output _ hmiss + simp only [hmiss, ↓reduceIte] + simpa only [State.pending_card_complete] using + ih (state.complete coordinate output) + · refine add_le_add (probEvent_sampleHashOutput_hitAt_le state coordinate) le_rfl |>.trans ?_ + calc + ((state.pendingAt coordinate).card : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + ((state.pendingAway coordinate).card : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ = + (((state.pendingAt coordinate).card + + (state.pendingAway coordinate).card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + push_cast + ring + _ ≤ (state.pending.card : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + have hcard : (state.pendingAt coordinate).card + + (state.pendingAway coordinate).card ≤ state.pending.card := by + rw [Nat.add_comm] + exact state.pendingAway_card_add_pendingAt_card_le coordinate + exact mul_le_mul_of_nonneg_right (by exact_mod_cast hcard) zero_le + +theorem finalize_probability_le (state : State Coordinate) : + Pr[fun hit : Bool => hit = true | finalize state] ≤ + (state.pending.card : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + finalizeFrom_probability_le state.coordinates.toList state + +noncomputable def finalizeDetailedFrom : + List Coordinate → State Coordinate → ProbComp (Bool × State Coordinate) + | [], state => pure (false, state) + | coordinate :: remaining, state => + match state.values coordinate with + | some _ => finalizeDetailedFrom remaining (state.clearPending coordinate) + | none => do + let output ← sampleHashOutput + if state.hitAt coordinate output then + pure (true, state) + else + finalizeDetailedFrom remaining (state.complete coordinate output) + +noncomputable def finalizeDetailed (state : State Coordinate) : + ProbComp (Bool × State Coordinate) := + finalizeDetailedFrom state.coordinates.toList state + +theorem finalizeDetailedFrom_fst (coordinates : List Coordinate) + (state : State Coordinate) : + Prod.fst <$> finalizeDetailedFrom coordinates state = + finalizeFrom coordinates state := by + induction coordinates generalizing state with + | nil => simp [finalizeDetailedFrom, finalizeFrom] + | cons coordinate remaining ih => + rw [finalizeDetailedFrom, finalizeFrom] + cases hvalue : state.values coordinate with + | some output => exact ih (state.clearPending coordinate) + | none => + simp only [map_bind] + apply bind_congr + intro output + by_cases hhit : state.hitAt coordinate output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + exact ih (state.complete coordinate output) + +theorem finalizeDetailed_fst (state : State Coordinate) : + Prod.fst <$> finalizeDetailed state = finalize state := + finalizeDetailedFrom_fst state.coordinates.toList state + +inductive RawResult (Coordinate : Type) (alpha : Type) where + | stopped (hit : Bool) + | done (state : State Coordinate) (remaining : Nat) (value : alpha) + +noncomputable def runRaw (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) : + ProbComp (RawResult Coordinate alpha) := + OracleComp.construct + (C := fun _ : OracleComp (World Coordinate) alpha => + State Coordinate → Nat → ProbComp (RawResult Coordinate alpha)) + (fun value state remaining => pure (.done state remaining value)) + (fun input _next recursivelyRun state fuel => + match input with + | .uniform n => do + let output ← liftM (unifSpec.query n) + recursivelyRun output state fuel + | .hashOutput => do + let output ← sampleHashOutput + recursivelyRun output state fuel + | .ensure coordinate => + recursivelyRun () (state.ensure coordinate) fuel + | .probe coordinate candidate => + match fuel with + | 0 => pure (.stopped false) + | remaining + 1 => + if coordinate ∈ state.revealed then + recursivelyRun () state remaining + else + recursivelyRun () (state.addPending coordinate candidate) remaining + | .peek coordinate => + recursivelyRun (state.values coordinate) state fuel + | .publish coordinate => + recursivelyRun () (state.publish coordinate) fuel + | .reveal coordinate => + match state.values coordinate with + | some output => recursivelyRun output state fuel + | none => do + let output ← sampleHashOutput + if state.hitAt coordinate output then + pure (.stopped true) + else + recursivelyRun output (state.materialize coordinate output) fuel) + computation state fuel + +theorem runRaw_uniform_query_bind (state : State Coordinate) (fuel n : Nat) + (next : Fin (n + 1) → OracleComp (World Coordinate) alpha) : + runRaw state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.uniform n)) : + OracleComp (World Coordinate) (Fin (n + 1))) >>= next) = (do + let output ← liftM (unifSpec.query n) + runRaw state fuel (next output)) := by + rw [runRaw, OracleComp.construct_query_bind] + rfl + +theorem runRaw_hashOutput_query_bind (state : State Coordinate) (fuel : Nat) + (next : HashOutput → OracleComp (World Coordinate) alpha) : + runRaw state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) .hashOutput) : + OracleComp (World Coordinate) HashOutput) >>= next) = (do + let output ← sampleHashOutput + runRaw state fuel (next output)) := by + rw [runRaw, OracleComp.construct_query_bind] + rfl + +theorem runRaw_ensure_query_bind (state : State Coordinate) (fuel : Nat) + (coordinate : Coordinate) (next : Unit → OracleComp (World Coordinate) alpha) : + runRaw state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.ensure coordinate)) : + OracleComp (World Coordinate) Unit) >>= next) = + runRaw (state.ensure coordinate) fuel (next ()) := by + rw [runRaw, OracleComp.construct_query_bind] + rfl + +theorem runRaw_probe_query_bind (state : State Coordinate) (fuel : Nat) + (coordinate : Coordinate) (candidate : Digest) + (next : Unit → OracleComp (World Coordinate) alpha) : + runRaw state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.probe coordinate candidate)) : + OracleComp (World Coordinate) Unit) >>= next) = + match fuel with + | 0 => pure (.stopped false) + | remaining + 1 => + if coordinate ∈ state.revealed then + runRaw state remaining (next ()) + else + runRaw (state.addPending coordinate candidate) remaining (next ()) := by + rw [runRaw, OracleComp.construct_query_bind] + rfl + +theorem runRaw_peek_query_bind (state : State Coordinate) (fuel : Nat) + (coordinate : Coordinate) + (next : Option HashOutput → OracleComp (World Coordinate) alpha) : + runRaw state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.peek coordinate)) : + OracleComp (World Coordinate) (Option HashOutput)) >>= next) = + runRaw state fuel (next (state.values coordinate)) := by + rw [runRaw, OracleComp.construct_query_bind] + rfl + +theorem runRaw_publish_query_bind (state : State Coordinate) (fuel : Nat) + (coordinate : Coordinate) (next : Unit → OracleComp (World Coordinate) alpha) : + runRaw state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.publish coordinate)) : + OracleComp (World Coordinate) Unit) >>= next) = + runRaw (state.publish coordinate) fuel (next ()) := by + rw [runRaw, OracleComp.construct_query_bind] + rfl + +theorem runRaw_reveal_query_bind (state : State Coordinate) (fuel : Nat) + (coordinate : Coordinate) (next : HashOutput → OracleComp (World Coordinate) alpha) : + runRaw state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.reveal coordinate)) : + OracleComp (World Coordinate) HashOutput) >>= next) = + (match state.values coordinate with + | some output => runRaw state fuel (next output) + | none => do + let output ← sampleHashOutput + if state.hitAt coordinate output then + pure (.stopped true) + else + runRaw (state.materialize coordinate output) fuel (next output)) := by + rw [runRaw, OracleComp.construct_query_bind] + rfl + +theorem runRaw_bind (state : State Coordinate) (fuel : Nat) + (left : OracleComp (World Coordinate) alpha) + (next : alpha → OracleComp (World Coordinate) beta) : + runRaw state fuel (left >>= next) = + runRaw state fuel left >>= fun result => + match result with + | .stopped hit => pure (.stopped hit) + | .done finalState remaining value => + runRaw finalState remaining (next value) := by + induction left using OracleComp.inductionOn generalizing state fuel with + | pure value => simp [runRaw] + | query_bind input continuation ih => + cases input with + | uniform n => + rw [bind_assoc, runRaw_uniform_query_bind, runRaw_uniform_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output state fuel + | hashOutput => + rw [bind_assoc, runRaw_hashOutput_query_bind, runRaw_hashOutput_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output state fuel + | ensure coordinate => + rw [bind_assoc, runRaw_ensure_query_bind, runRaw_ensure_query_bind] + exact ih () (state.ensure coordinate) fuel + | probe coordinate candidate => + rw [bind_assoc, runRaw_probe_query_bind, runRaw_probe_query_bind] + cases fuel with + | zero => simp + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () state remaining + · simp only [hrevealed, ↓reduceIte] + exact ih () (state.addPending coordinate candidate) remaining + | peek coordinate => + rw [bind_assoc, runRaw_peek_query_bind, runRaw_peek_query_bind] + exact ih (state.values coordinate) state fuel + | publish coordinate => + rw [bind_assoc, runRaw_publish_query_bind, runRaw_publish_query_bind] + exact ih () (state.publish coordinate) fuel + | reveal coordinate => + rw [bind_assoc, runRaw_reveal_query_bind, runRaw_reveal_query_bind] + cases hvalue : state.values coordinate with + | some output => exact ih output state fuel + | none => + simp only [bind_assoc] + apply bind_congr + intro output + by_cases hhit : state.hitAt coordinate output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + exact ih output (state.materialize coordinate output) fuel + +theorem stopped_false_not_mem_support_runRaw_bind + (state : State Coordinate) (fuel : Nat) + (left : OracleComp (World Coordinate) alpha) + (next : alpha → OracleComp (World Coordinate) beta) + (hleft : RawResult.stopped false ∉ support (runRaw state fuel left)) + (htail : ∀ finalState remaining value, + RawResult.done finalState remaining value ∈ support (runRaw state fuel left) → + RawResult.stopped false ∉ support (runRaw finalState remaining (next value))) : + RawResult.stopped false ∉ support (runRaw state fuel (left >>= next)) := by + rw [runRaw_bind, mem_support_bind_iff] + rintro ⟨result, hresult, hnext⟩ + cases result with + | stopped hit => + cases hit with + | false => exact hleft hresult + | true => simp at hnext + | done finalState remaining value => + exact htail finalState remaining value hresult hnext + +theorem stopped_false_not_mem_support_runRaw + (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) + (hbound : computation.IsQueryBoundP IsProbe fuel) : + RawResult.stopped false ∉ support (runRaw state fuel computation) := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + simp [runRaw] + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases input with + | uniform n => + rw [runRaw_uniform_query_bind, mem_support_bind_iff] + rintro ⟨output, _houtput, hrest⟩ + exact ih output state fuel (by simpa [IsProbe] using hbound.2 output) hrest + | hashOutput => + rw [runRaw_hashOutput_query_bind, mem_support_bind_iff] + rintro ⟨output, _houtput, hrest⟩ + exact ih output state fuel (by simpa [IsProbe] using hbound.2 output) hrest + | ensure coordinate => + rw [runRaw_ensure_query_bind] + exact ih () (state.ensure coordinate) fuel + (by simpa [IsProbe] using hbound.2 ()) + | probe coordinate candidate => + have hpositive : 0 < fuel := by + simpa [IsProbe] using hbound.1 + cases fuel with + | zero => omega + | succ remaining => + rw [runRaw_probe_query_bind] + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () state remaining + (by simpa [IsProbe] using hbound.2 ()) + · simp only [hrevealed, ↓reduceIte] + exact ih () (state.addPending coordinate candidate) remaining + (by simpa [IsProbe] using hbound.2 ()) + | peek coordinate => + rw [runRaw_peek_query_bind] + exact ih (state.values coordinate) state fuel + (by simpa [IsProbe] using hbound.2 (state.values coordinate)) + | publish coordinate => + rw [runRaw_publish_query_bind] + exact ih () (state.publish coordinate) fuel + (by simpa [IsProbe] using hbound.2 ()) + | reveal coordinate => + rw [runRaw_reveal_query_bind] + cases hvalue : state.values coordinate with + | some output => + exact ih output state fuel + (by simpa [IsProbe] using hbound.2 output) + | none => + rw [mem_support_bind_iff] + rintro ⟨output, _houtput, hrest⟩ + by_cases hhit : state.hitAt coordinate output + · simp [hhit] at hrest + · simp only [hhit, ↓reduceIte] at hrest + exact ih output (state.materialize coordinate output) fuel + (by simpa [IsProbe] using hbound.2 output) hrest + +theorem fuel_le_remaining_add_of_mem_support_runRaw_done + (state finalState : State Coordinate) (fuel remaining bound : Nat) + (computation : OracleComp (World Coordinate) alpha) (value : alpha) + (hbound : computation.IsQueryBoundP IsProbe bound) + (hresult : RawResult.done finalState remaining value ∈ + support (runRaw state fuel computation)) : + fuel ≤ remaining + bound := by + induction computation using OracleComp.inductionOn generalizing state fuel bound with + | pure value => + simp [runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl⟩ + omega + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases input with + | uniform n => + rw [runRaw_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output state fuel bound (by simpa [IsProbe] using hbound.2 output) htail + | hashOutput => + rw [runRaw_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output state fuel bound (by simpa [IsProbe] using hbound.2 output) htail + | ensure coordinate => + rw [runRaw_ensure_query_bind] at hresult + exact ih () (state.ensure coordinate) fuel bound + (by simpa [IsProbe] using hbound.2 ()) hresult + | probe coordinate candidate => + cases fuel with + | zero => simp [runRaw_probe_query_bind] at hresult + | succ nextFuel => + have hboundPositive : 0 < bound := by + simpa [IsProbe] using hbound.1 + rw [runRaw_probe_query_bind] at hresult + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] at hresult + have htail := ih () state nextFuel (bound - 1) + (by simpa [IsProbe] using hbound.2 ()) hresult + omega + · simp only [hrevealed, ↓reduceIte] at hresult + have htail := ih () (state.addPending coordinate candidate) nextFuel + (bound - 1) (by simpa [IsProbe] using hbound.2 ()) hresult + omega + | peek coordinate => + rw [runRaw_peek_query_bind] at hresult + exact ih (state.values coordinate) state fuel bound + (by simpa [IsProbe] using hbound.2 (state.values coordinate)) hresult + | publish coordinate => + rw [runRaw_publish_query_bind] at hresult + exact ih () (state.publish coordinate) fuel bound + (by simpa [IsProbe] using hbound.2 ()) hresult + | reveal coordinate => + rw [runRaw_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + rw [hvalue] at hresult + exact ih output state fuel bound + (by simpa [IsProbe] using hbound.2 output) hresult + | none => + rw [hvalue] at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + by_cases hhit : state.hitAt coordinate output + · simp [hhit] at htail + · simp only [hhit, ↓reduceIte] at htail + exact ih output (state.materialize coordinate output) fuel bound + (by simpa [IsProbe] using hbound.2 output) htail + +theorem stopped_false_not_mem_support_runRaw_bind_of_bound + (state : State Coordinate) (fuel bound : Nat) + (left : OracleComp (World Coordinate) alpha) + (next : alpha → OracleComp (World Coordinate) beta) + (hbound : left.IsQueryBoundP IsProbe bound) + (hleft : RawResult.stopped false ∉ support (runRaw state fuel left)) + (htail : ∀ finalState remaining value, + RawResult.done finalState remaining value ∈ support (runRaw state fuel left) → + fuel ≤ remaining + bound → + RawResult.stopped false ∉ support (runRaw finalState remaining (next value))) : + RawResult.stopped false ∉ support (runRaw state fuel (left >>= next)) := by + apply stopped_false_not_mem_support_runRaw_bind state fuel left next hleft + intro finalState remaining value hresult + exact htail finalState remaining value hresult + (fuel_le_remaining_add_of_mem_support_runRaw_done state finalState fuel remaining bound + left value hbound hresult) + +inductive DetailedResult (Coordinate : Type) (alpha : Type) where + | stopped (hit : Bool) + | done (hit : Bool) (state : State Coordinate) (remaining : Nat) (value : alpha) + +def DetailedResult.hit : DetailedResult Coordinate alpha → Bool + | .stopped hit => hit + | .done hit _ _ _ => hit + +noncomputable def RawResult.finish : RawResult Coordinate alpha → ProbComp Bool + | .stopped hit => pure hit + | .done state _ _ => finalize state + +noncomputable def RawResult.finishDetailed : + RawResult Coordinate alpha → ProbComp (DetailedResult Coordinate alpha) + | .stopped hit => pure (.stopped hit) + | .done state remaining value => do + let (hit, finalState) ← finalizeDetailed state + pure (.done hit finalState remaining value) + +theorem RawResult.finishDetailed_hit (result : RawResult Coordinate alpha) : + DetailedResult.hit <$> result.finishDetailed = result.finish := by + cases result with + | stopped hit => simp [RawResult.finishDetailed, RawResult.finish, DetailedResult.hit] + | done state remaining value => + simpa [RawResult.finishDetailed, RawResult.finish, DetailedResult.hit] using + finalizeDetailed_fst state + +noncomputable def detailedExperiment (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) : + ProbComp (DetailedResult Coordinate alpha) := + runRaw state fuel computation >>= RawResult.finishDetailed + +theorem stopped_false_not_mem_support_detailedExperiment + (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) + (hbound : computation.IsQueryBoundP IsProbe fuel) : + DetailedResult.stopped false ∉ support + (detailedExperiment state fuel computation) := by + unfold detailedExperiment + rw [mem_support_bind_iff] + rintro ⟨raw, hraw, hfinish⟩ + cases raw with + | stopped hit => + cases hit with + | false => + exact stopped_false_not_mem_support_runRaw state fuel computation hbound hraw + | true => simp [RawResult.finishDetailed] at hfinish + | done finalState remaining value => + simp [RawResult.finishDetailed] at hfinish + +theorem stopped_false_not_mem_support_detailedExperiment_of_runRaw + (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) + (hnotStopped : RawResult.stopped false ∉ support (runRaw state fuel computation)) : + DetailedResult.stopped false ∉ support + (detailedExperiment state fuel computation) := by + unfold detailedExperiment + rw [mem_support_bind_iff] + rintro ⟨raw, hraw, hfinish⟩ + cases raw with + | stopped hit => + cases hit with + | false => exact hnotStopped hraw + | true => simp [RawResult.finishDetailed] at hfinish + | done finalState remaining value => + simp [RawResult.finishDetailed] at hfinish + +noncomputable def experiment (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) : ProbComp Bool := + OracleComp.construct + (C := fun _ => State Coordinate → Nat → ProbComp Bool) + (fun _ state _ => finalize state) + (fun input _next recursivelyRun state fuel => + match input with + | .uniform n => do + let output ← liftM (unifSpec.query n) + recursivelyRun output state fuel + | .hashOutput => do + let output ← sampleHashOutput + recursivelyRun output state fuel + | .ensure coordinate => + recursivelyRun () (state.ensure coordinate) fuel + | .probe coordinate candidate => + match fuel with + | 0 => finalize state + | remaining + 1 => + if coordinate ∈ state.revealed then + recursivelyRun () state remaining + else + recursivelyRun () (state.addPending coordinate candidate) remaining + | .peek coordinate => + recursivelyRun (state.values coordinate) state fuel + | .publish coordinate => + recursivelyRun () (state.publish coordinate) fuel + | .reveal coordinate => + match state.values coordinate with + | some output => recursivelyRun output state fuel + | none => do + let output ← sampleHashOutput + if state.hitAt coordinate output then + pure true + else + recursivelyRun output (state.materialize coordinate output) fuel) + computation state fuel + +theorem experiment_uniform_query_bind (state : State Coordinate) (fuel n : Nat) + (next : Fin (n + 1) → OracleComp (World Coordinate) alpha) : + experiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.uniform n)) : + OracleComp (World Coordinate) (Fin (n + 1))) >>= next) = (do + let output ← liftM (unifSpec.query n) + experiment state fuel (next output)) := by + rw [experiment, OracleComp.construct_query_bind] + rfl + +theorem experiment_hashOutput_query_bind (state : State Coordinate) (fuel : Nat) + (next : HashOutput → OracleComp (World Coordinate) alpha) : + experiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) .hashOutput) : + OracleComp (World Coordinate) HashOutput) >>= next) = (do + let output ← sampleHashOutput + experiment state fuel (next output)) := by + rw [experiment, OracleComp.construct_query_bind] + rfl + +theorem experiment_ensure_query_bind (state : State Coordinate) (fuel : Nat) + (coordinate : Coordinate) (next : Unit → OracleComp (World Coordinate) alpha) : + experiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.ensure coordinate)) : + OracleComp (World Coordinate) Unit) >>= next) = + experiment (state.ensure coordinate) fuel (next ()) := by + rw [experiment, OracleComp.construct_query_bind] + rfl + +theorem experiment_probe_query_bind (state : State Coordinate) (fuel : Nat) + (coordinate : Coordinate) (candidate : Digest) + (next : Unit → OracleComp (World Coordinate) alpha) : + experiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.probe coordinate candidate)) : + OracleComp (World Coordinate) Unit) >>= next) = + match fuel with + | 0 => finalize state + | remaining + 1 => + if coordinate ∈ state.revealed then + experiment state remaining (next ()) + else + experiment (state.addPending coordinate candidate) remaining (next ()) := by + rw [experiment, OracleComp.construct_query_bind] + rfl + +theorem experiment_peek_query_bind (state : State Coordinate) (fuel : Nat) + (coordinate : Coordinate) + (next : Option HashOutput → OracleComp (World Coordinate) alpha) : + experiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.peek coordinate)) : + OracleComp (World Coordinate) (Option HashOutput)) >>= next) = + experiment state fuel (next (state.values coordinate)) := by + rw [experiment, OracleComp.construct_query_bind] + rfl + +theorem experiment_publish_query_bind (state : State Coordinate) (fuel : Nat) + (coordinate : Coordinate) (next : Unit → OracleComp (World Coordinate) alpha) : + experiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.publish coordinate)) : + OracleComp (World Coordinate) Unit) >>= next) = + experiment (state.publish coordinate) fuel (next ()) := by + rw [experiment, OracleComp.construct_query_bind] + rfl + +theorem experiment_reveal_query_bind (state : State Coordinate) (fuel : Nat) + (coordinate : Coordinate) (next : HashOutput → OracleComp (World Coordinate) alpha) : + experiment state fuel + ((liftM (OracleSpec.query (spec := World Coordinate) (.reveal coordinate)) : + OracleComp (World Coordinate) HashOutput) >>= next) = + (match state.values coordinate with + | some output => experiment state fuel (next output) + | none => do + let output ← sampleHashOutput + if state.hitAt coordinate output then + pure true + else + experiment (state.materialize coordinate output) fuel (next output)) := by + rw [experiment, OracleComp.construct_query_bind] + rfl + +theorem experiment_eq_runRaw_finish (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) + (hbound : computation.IsQueryBoundP IsProbe fuel) : + experiment state fuel computation = + runRaw state fuel computation >>= RawResult.finish := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => simp [experiment, runRaw, RawResult.finish] + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases input with + | uniform n => + rw [experiment_uniform_query_bind, runRaw_uniform_query_bind, bind_assoc] + apply bind_congr + intro output + exact ih output state fuel (by simpa [IsProbe] using hbound.2 output) + | hashOutput => + rw [experiment_hashOutput_query_bind, runRaw_hashOutput_query_bind, bind_assoc] + apply bind_congr + intro output + exact ih output state fuel (by simpa [IsProbe] using hbound.2 output) + | ensure coordinate => + rw [experiment_ensure_query_bind, runRaw_ensure_query_bind] + exact ih () (state.ensure coordinate) fuel + (by simpa [IsProbe] using hbound.2 ()) + | probe coordinate candidate => + have hpositive : 0 < fuel := by + simpa [IsProbe] using hbound.1 + cases fuel with + | zero => omega + | succ remaining => + rw [experiment_probe_query_bind, runRaw_probe_query_bind] + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () state remaining + (by simpa [IsProbe] using hbound.2 ()) + · simp only [hrevealed, ↓reduceIte] + exact ih () (state.addPending coordinate candidate) remaining + (by simpa [IsProbe] using hbound.2 ()) + | peek coordinate => + rw [experiment_peek_query_bind, runRaw_peek_query_bind] + exact ih (state.values coordinate) state fuel + (by simpa [IsProbe] using hbound.2 (state.values coordinate)) + | publish coordinate => + rw [experiment_publish_query_bind, runRaw_publish_query_bind] + exact ih () (state.publish coordinate) fuel + (by simpa [IsProbe] using hbound.2 ()) + | reveal coordinate => + rw [experiment_reveal_query_bind, runRaw_reveal_query_bind] + cases hvalue : state.values coordinate with + | some output => + exact ih output state fuel + (by simpa [IsProbe] using hbound.2 output) + | none => + simp only [bind_assoc] + apply bind_congr + intro output + by_cases hhit : state.hitAt coordinate output + · simp [hhit, RawResult.finish] + · simp only [hhit, ↓reduceIte] + exact ih output (state.materialize coordinate output) fuel + (by simpa [IsProbe] using hbound.2 output) + +set_option maxRecDepth 100000 in +theorem evalDist_experiment_eq_runRaw_finish_of_not_stopped_false + (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) + (hnotStopped : RawResult.stopped false ∉ support (runRaw state fuel computation)) : + evalDist (experiment state fuel computation) = + evalDist (runRaw state fuel computation >>= RawResult.finish) := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => simp [experiment, runRaw, RawResult.finish] + | query_bind input next ih => + cases input with + | uniform n => + rw [experiment_uniform_query_bind, runRaw_uniform_query_bind, bind_assoc, + evalDist_bind, evalDist_bind] + apply congrArg + funext output + apply ih output state fuel + intro hstopped + apply hnotStopped + rw [runRaw_uniform_query_bind, mem_support_bind_iff] + exact ⟨output, by simp, hstopped⟩ + | hashOutput => + rw [experiment_hashOutput_query_bind, runRaw_hashOutput_query_bind, bind_assoc, + evalDist_bind, evalDist_bind] + apply congrArg + funext output + apply ih output state fuel + intro hstopped + apply hnotStopped + rw [runRaw_hashOutput_query_bind, mem_support_bind_iff] + exact ⟨output, by simp [sampleHashOutput], hstopped⟩ + | ensure coordinate => + rw [experiment_ensure_query_bind, runRaw_ensure_query_bind] + apply ih () (state.ensure coordinate) fuel + simpa [runRaw_ensure_query_bind] using hnotStopped + | probe coordinate candidate => + cases fuel with + | zero => + exfalso + apply hnotStopped + simp [runRaw_probe_query_bind] + | succ remaining => + rw [experiment_probe_query_bind, runRaw_probe_query_bind] + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + apply ih () state remaining + simpa [runRaw_probe_query_bind, hrevealed] using hnotStopped + · simp only [hrevealed, ↓reduceIte] + apply ih () (state.addPending coordinate candidate) remaining + simpa [runRaw_probe_query_bind, hrevealed] using hnotStopped + | peek coordinate => + rw [experiment_peek_query_bind, runRaw_peek_query_bind] + apply ih (state.values coordinate) state fuel + simpa [runRaw_peek_query_bind] using hnotStopped + | publish coordinate => + rw [experiment_publish_query_bind, runRaw_publish_query_bind] + apply ih () (state.publish coordinate) fuel + simpa [runRaw_publish_query_bind] using hnotStopped + | reveal coordinate => + rw [experiment_reveal_query_bind, runRaw_reveal_query_bind] + cases hvalue : state.values coordinate with + | some output => + apply ih output state fuel + simpa [runRaw_reveal_query_bind, hvalue] using hnotStopped + | none => + simp only [bind_assoc, evalDist_bind, evalDist_bind] + apply congrArg + funext output + by_cases hhit : state.hitAt coordinate output + · simp [hhit, RawResult.finish] + · simp only [hhit, ↓reduceIte] + have htail : RawResult.stopped false ∉ support + (runRaw (state.materialize coordinate output) fuel (next output)) := by + intro hstopped + apply hnotStopped + rw [runRaw_reveal_query_bind, hvalue, mem_support_bind_iff] + exact ⟨output, by simp [sampleHashOutput], by simpa [hhit] using hstopped⟩ + simpa [evalDist_bind] using + ih output (state.materialize coordinate output) fuel htail + +theorem evalDist_detailedExperiment_hit_eq_experiment_of_not_stopped_false + (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) + (hnotStopped : RawResult.stopped false ∉ support (runRaw state fuel computation)) : + evalDist (DetailedResult.hit <$> detailedExperiment state fuel computation) = + evalDist (experiment state fuel computation) := by + calc + _ = evalDist (runRaw state fuel computation >>= fun result => + DetailedResult.hit <$> result.finishDetailed) := by + unfold detailedExperiment + rw [map_bind] + _ = evalDist (runRaw state fuel computation >>= RawResult.finish) := by + apply evalDist_bind_congr + intro result _ + exact congrArg evalDist result.finishDetailed_hit + _ = _ := (evalDist_experiment_eq_runRaw_finish_of_not_stopped_false state fuel computation + hnotStopped).symm + +theorem detailedExperiment_hit_eq_experiment (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) + (hbound : computation.IsQueryBoundP IsProbe fuel) : + DetailedResult.hit <$> detailedExperiment state fuel computation = + experiment state fuel computation := by + rw [detailedExperiment, map_bind, experiment_eq_runRaw_finish state fuel computation hbound] + apply bind_congr + intro result + exact result.finishDetailed_hit + +set_option maxRecDepth 100000 in +theorem experiment_probability_le (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) : + Pr[fun hit : Bool => hit = true | experiment state fuel computation] ≤ + ((fuel + state.pending.card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + refine (finalize_probability_le state).trans ?_ + exact mul_le_mul_of_nonneg_right + (by exact_mod_cast Nat.le_add_left state.pending.card fuel) zero_le + | query_bind input next ih => + cases input with + | uniform n => + rw [experiment_uniform_query_bind] + exact probEvent_bind_le_of_forall_le fun output _ => ih output state fuel + | hashOutput => + rw [experiment_hashOutput_query_bind] + exact probEvent_bind_le_of_forall_le fun output _ => ih output state fuel + | ensure coordinate => + rw [experiment_ensure_query_bind] + simpa only [State.pending_card_ensure] using + ih () (state.ensure coordinate) fuel + | probe coordinate candidate => + rw [experiment_probe_query_bind] + cases fuel with + | zero => + simpa using finalize_probability_le state + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + refine (ih () state remaining).trans ?_ + have hnat : remaining + state.pending.card ≤ + remaining + 1 + state.pending.card := by omega + exact mul_le_mul_of_nonneg_right (by exact_mod_cast hnat) zero_le + · simp only [hrevealed, ↓reduceIte] + refine (ih () (state.addPending coordinate candidate) remaining).trans ?_ + have hnat : remaining + + (state.addPending coordinate candidate).pending.card ≤ + remaining + 1 + state.pending.card := by + have := state.pending_card_addPending_le coordinate candidate + omega + exact mul_le_mul_of_nonneg_right (by exact_mod_cast hnat) zero_le + | peek coordinate => + rw [experiment_peek_query_bind] + exact ih (state.values coordinate) state fuel + | publish coordinate => + rw [experiment_publish_query_bind] + exact ih () (state.publish coordinate) fuel + | reveal coordinate => + rw [experiment_reveal_query_bind] + cases hvalue : state.values coordinate with + | some output => exact ih output state fuel + | none => + refine (probEvent_bind_le_probEvent_add + (mx := sampleHashOutput) + (my := fun output => + if state.hitAt coordinate output then pure true + else experiment (state.materialize coordinate output) fuel (next output)) + (q := fun hit : Bool => hit = true) + (p := state.hitAt coordinate) + (ε := ((fuel + (state.pendingAway coordinate).card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) ?_).trans ?_ + · intro output _ hmiss + simp only [hmiss, ↓reduceIte] + simpa only [State.pending_card_materialize] using + ih output (state.materialize coordinate output) fuel + · refine add_le_add + (probEvent_sampleHashOutput_hitAt_le state coordinate) le_rfl |>.trans ?_ + calc + ((state.pendingAt coordinate).card : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + ((fuel + (state.pendingAway coordinate).card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ = + (((state.pendingAt coordinate).card + fuel + + (state.pendingAway coordinate).card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + push_cast + ring + _ ≤ ((fuel + state.pending.card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + have hsplit := + state.pendingAway_card_add_pendingAt_card_le coordinate + have hnat : (state.pendingAt coordinate).card + fuel + + (state.pendingAway coordinate).card ≤ + fuel + state.pending.card := by omega + exact mul_le_mul_of_nonneg_right (by exact_mod_cast hnat) zero_le + +theorem experiment_empty_probability_le (fuel : Nat) + (computation : OracleComp (World Coordinate) alpha) : + Pr[fun hit : Bool => hit = true | + experiment (State.empty : State Coordinate) fuel computation] ≤ + (fuel : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + simpa [State.empty] using + experiment_probability_le (State.empty : State Coordinate) fuel computation + +end SphincsSecurity.LazyRevealProbe diff --git a/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbeCharge.lean b/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbeCharge.lean new file mode 100644 index 00000000..7f0c35ec --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbeCharge.lean @@ -0,0 +1,315 @@ +import SphincsSecurity.Proof.LazyRevealProbePending +import SphincsSecurity.Proof.AdaptiveRevealProbeCharge + +namespace SphincsSecurity.LazyRevealProbe + +open OracleComp OracleSpec ENNReal + +variable {Coordinate : Type} [DecidableEq Coordinate] + +def pendingProbeCharge (state : State Coordinate) (coordinate : Coordinate) (candidate : Digest) : Nat := + if state.values coordinate ≠ none then 0 + else if (coordinate, candidate) ∈ state.pending then 0 else 1 + +theorem pendingProbeCharge_le_one (state : State Coordinate) (coordinate : Coordinate) (candidate : Digest) : + pendingProbeCharge state coordinate candidate ≤ 1 := by + unfold pendingProbeCharge + split_ifs <;> omega + +theorem pendingProbeCharge_eq_zero_of_materialized (state : State Coordinate) + (coordinate : Coordinate) (candidate : Digest) (hvalue : state.values coordinate ≠ none) : + pendingProbeCharge state coordinate candidate = 0 := by + simp only [pendingProbeCharge, if_pos hvalue] + +theorem State.unmaterializedPending_card_addPending_eq_charge (state : State Coordinate) + (coordinate : Coordinate) (candidate : Digest) : + (state.addPending coordinate candidate).unmaterializedPending.card = + state.unmaterializedPending.card + pendingProbeCharge state coordinate candidate := by + by_cases hvalue : state.values coordinate = none + · have hset : (state.addPending coordinate candidate).unmaterializedPending = + insert (coordinate, candidate) state.unmaterializedPending := by + simp [unmaterializedPending, addPending, Finset.filter_insert, hvalue] + rw [hset] + by_cases hmem : (coordinate, candidate) ∈ state.pending + · have hfresh : (coordinate, candidate) ∈ state.unmaterializedPending := by + simp [unmaterializedPending, hmem, hvalue] + simp [Finset.insert_eq_of_mem hfresh, pendingProbeCharge, hvalue, hmem] + · have hfresh : (coordinate, candidate) ∉ state.unmaterializedPending := by + simp [unmaterializedPending, hmem] + simp [Finset.card_insert_of_notMem hfresh, pendingProbeCharge, hvalue, hmem] + · have hset : (state.addPending coordinate candidate).unmaterializedPending = state.unmaterializedPending := by + simp [unmaterializedPending, addPending, Finset.filter_insert, hvalue] + rw [hset, pendingProbeCharge_eq_zero_of_materialized state coordinate candidate hvalue, Nat.add_zero] + +noncomputable def expectedProbeCharge {α : Type} + (computation : OracleComp (World Coordinate) α) : State Coordinate → Nat → ℝ≥0∞ := + OracleComp.construct (fun _ _ _ => 0) + (fun input _ next state fuel => + match input with + | .uniform n => ∑' output, Pr[= output | (liftM (unifSpec.query n) : ProbComp _)] * next output state fuel + | .hashOutput => ∑' output, Pr[= output | sampleHashOutput] * next output state fuel + | .ensure coordinate => next () (state.ensure coordinate) fuel + | .probe coordinate candidate => + match fuel with + | 0 => 0 + | remaining + 1 => + if coordinate ∈ state.revealed then next () state remaining + else (pendingProbeCharge state coordinate candidate : ℝ≥0∞) + + next () (state.addPending coordinate candidate) remaining + | .peek coordinate => next (state.values coordinate) state fuel + | .publish coordinate => next () (state.publish coordinate) fuel + | .reveal coordinate => + match state.values coordinate with + | some output => next output state fuel + | none => ∑' output, Pr[= output | sampleHashOutput] * + if state.hitAt coordinate output then 0 + else next output (state.materialize coordinate output) fuel) + computation + +theorem expectedProbeCharge_query_bind {α : Type} + (input : (World Coordinate).Domain) + (next : (World Coordinate).Range input → OracleComp (World Coordinate) α) + (state : State Coordinate) (fuel : Nat) : + expectedProbeCharge ((liftM (OracleSpec.query input) : OracleComp (World Coordinate) _) >>= next) state fuel = + match input with + | .uniform n => ∑' output, Pr[= output | (liftM (unifSpec.query n) : ProbComp _)] * + expectedProbeCharge (next output) state fuel + | .hashOutput => ∑' output, Pr[= output | sampleHashOutput] * expectedProbeCharge (next output) state fuel + | .ensure coordinate => expectedProbeCharge (next ()) (state.ensure coordinate) fuel + | .probe coordinate candidate => + match fuel with + | 0 => 0 + | remaining + 1 => + if coordinate ∈ state.revealed then expectedProbeCharge (next ()) state remaining + else (pendingProbeCharge state coordinate candidate : ℝ≥0∞) + + expectedProbeCharge (next ()) (state.addPending coordinate candidate) remaining + | .peek coordinate => expectedProbeCharge (next (state.values coordinate)) state fuel + | .publish coordinate => expectedProbeCharge (next ()) (state.publish coordinate) fuel + | .reveal coordinate => + match state.values coordinate with + | some output => expectedProbeCharge (next output) state fuel + | none => ∑' output, Pr[= output | sampleHashOutput] * + if state.hitAt coordinate output then 0 + else expectedProbeCharge (next output) (state.materialize coordinate output) fuel := by + cases input <;> rfl + +theorem materialize_probability_le_charge (state : State Coordinate) (coordinate : Coordinate) (hvalue : state.values coordinate = none) + (resume : HashOutput → State Coordinate → ProbComp Bool) (charge : HashOutput → ℝ≥0∞) + (hresume : ∀ output, + Pr[fun hit : Bool => hit = true | resume output (state.materialize coordinate output)] ≤ + (charge output + ((state.materialize coordinate output).unmaterializedPending.card : ℝ≥0∞)) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + Pr[fun hit : Bool => hit = true | do + let output ← sampleHashOutput + if state.hitAt coordinate output then pure true else resume output (state.materialize coordinate output)] ≤ + ((∑' output, Pr[= output | sampleHashOutput] * + if state.hitAt coordinate output then 0 else charge output) + (state.unmaterializedPending.card : ℝ≥0∞)) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + classical + let eps := ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + let remaining := (state.clearPending coordinate).unmaterializedPending.card + calc + _ ≤ ∑' output, Pr[= output | sampleHashOutput] * + ((if state.hitAt coordinate output then 1 else 0) + + (if state.hitAt coordinate output then 0 else charge output) * eps + + (remaining : ℝ≥0∞) * eps) := by + rw [probEvent_bind_eq_tsum] + apply ENNReal.tsum_le_tsum + intro output + apply mul_le_mul' le_rfl + by_cases hhit : state.hitAt coordinate output + · simp only [hhit, ↓reduceIte, probEvent_pure, zero_mul, add_zero] + exact le_add_right le_rfl + · simp only [hhit, ↓reduceIte, zero_add] + exact (hresume output).trans_eq (by rw [state.unmaterializedPending_materialize, add_mul]) + _ = Pr[state.hitAt coordinate | sampleHashOutput] + + (∑' output, Pr[= output | sampleHashOutput] * + if state.hitAt coordinate output then 0 else charge output) * eps + + (remaining : ℝ≥0∞) * eps := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_add, ENNReal.tsum_mul_right, + tsum_probOutput_of_liftM_PMF, one_mul] + congr 1 + · congr 1 + · rw [probEvent_eq_tsum_ite] + apply tsum_congr + intro output + split_ifs <;> simp + · simp_rw [← mul_assoc] + rw [ENNReal.tsum_mul_right] + _ ≤ ((state.pendingAt coordinate).card : ℝ≥0∞) * eps + + (∑' output, Pr[= output | sampleHashOutput] * + if state.hitAt coordinate output then 0 else charge output) * eps + + (remaining : ℝ≥0∞) * eps := + add_le_add (add_le_add (probEvent_sampleHashOutput_hitAt_le state coordinate) le_rfl) le_rfl + _ ≤ _ := by + have hcard : ((state.pendingAt coordinate).card : ℝ≥0∞) + remaining ≤ state.unmaterializedPending.card := by + exact_mod_cast (Nat.add_comm _ _ ▸ state.unmaterializedPending_card_split_le coordinate hvalue) + calc + _ = ((∑' output, Pr[= output | sampleHashOutput] * + if state.hitAt coordinate output then 0 else charge output) + + (((state.pendingAt coordinate).card : ℝ≥0∞) + remaining)) * eps := by ring + _ ≤ _ := mul_le_mul' (add_le_add le_rfl hcard) le_rfl + +set_option maxRecDepth 100000 in +theorem experiment_probability_le_expectedProbeCharge_unmaterialized {α : Type} + (state : State Coordinate) (fuel : Nat) (computation : OracleComp (World Coordinate) α) : + Pr[fun hit : Bool => hit = true | experiment state fuel computation] ≤ + (expectedProbeCharge computation state fuel + (state.unmaterializedPending.card : ℝ≥0∞)) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + change Pr[_ | finalize state] ≤ (0 + _) * _ + rw [zero_add] + exact finalize_probability_le_unmaterializedPending state + | query_bind input next ih => + rw [expectedProbeCharge_query_bind] + cases input with + | uniform n => + rw [experiment_uniform_query_bind] + exact AdaptiveRevealProbe.probEvent_bind_le_expectedCharge _ _ _ _ _ fun output => ih output state fuel + | hashOutput => + rw [experiment_hashOutput_query_bind] + exact AdaptiveRevealProbe.probEvent_bind_le_expectedCharge _ _ _ _ _ fun output => ih output state fuel + | ensure coordinate => + rw [experiment_ensure_query_bind] + exact ih () (state.ensure coordinate) fuel + | probe coordinate candidate => + rw [experiment_probe_query_bind] + cases fuel with + | zero => simpa only [zero_add] using finalize_probability_le_unmaterializedPending state + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () state remaining + · simp only [hrevealed, ↓reduceIte] + apply (ih () (state.addPending coordinate candidate) remaining).trans_eq + rw [state.unmaterializedPending_card_addPending_eq_charge, Nat.cast_add] + congr 1 + ac_rfl + | peek coordinate => + rw [experiment_peek_query_bind] + exact ih (state.values coordinate) state fuel + | publish coordinate => + rw [experiment_publish_query_bind] + exact ih () (state.publish coordinate) fuel + | reveal coordinate => + rw [experiment_reveal_query_bind] + dsimp only + cases hvalue : state.values coordinate with + | some output => exact ih output state fuel + | none => + exact materialize_probability_le_charge state coordinate hvalue + (fun output nextState => experiment nextState fuel (next output)) _ + (fun output => ih output (state.materialize coordinate output) fuel) + +theorem experiment_probability_le_expectedProbeCharge {α : Type} + (state : State Coordinate) (fuel : Nat) (computation : OracleComp (World Coordinate) α) : + Pr[fun hit : Bool => hit = true | experiment state fuel computation] ≤ + (expectedProbeCharge computation state fuel + (state.pending.card : ℝ≥0∞)) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + (experiment_probability_le_expectedProbeCharge_unmaterialized state fuel computation).trans + (mul_le_mul' (add_le_add le_rfl (Nat.cast_le.mpr state.unmaterializedPending_card_le)) le_rfl) + +theorem experiment_empty_probability_le_expectedProbeCharge {α : Type} + (fuel : Nat) (computation : OracleComp (World Coordinate) α) : + Pr[fun hit : Bool => hit = true | experiment (State.empty : State Coordinate) fuel computation] ≤ + expectedProbeCharge computation State.empty fuel * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + simpa only [State.empty, Finset.card_empty, Nat.cast_zero, add_zero] using + experiment_probability_le_expectedProbeCharge State.empty fuel computation + +theorem expectedProbeCharge_le_fuel {α : Type} + (computation : OracleComp (World Coordinate) α) (state : State Coordinate) (fuel : Nat) : + expectedProbeCharge computation state fuel ≤ fuel := by + have havg {β : Type} (source : ProbComp β) (charge : β → ℝ≥0∞) (cap : ℝ≥0∞) + (hcharge : ∀ value, charge value ≤ cap) : + (∑' value, Pr[= value | source] * charge value) ≤ cap := by + calc + _ ≤ ∑' value, Pr[= value | source] * cap := + ENNReal.tsum_le_tsum fun value => mul_le_mul' le_rfl (hcharge value) + _ ≤ cap := by + rw [ENNReal.tsum_mul_right] + exact mul_le_of_le_one_left (by positivity) tsum_probOutput_le_one + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => exact bot_le + | query_bind input next ih => + rw [expectedProbeCharge_query_bind] + cases input with + | uniform n => exact havg _ _ _ fun output => ih output state fuel + | hashOutput => exact havg _ _ _ fun output => ih output state fuel + | ensure coordinate => exact ih () (state.ensure coordinate) fuel + | peek coordinate => exact ih (state.values coordinate) state fuel + | publish coordinate => exact ih () (state.publish coordinate) fuel + | probe coordinate candidate => + cases fuel with + | zero => simp only [Nat.cast_zero, le_refl] + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + exact (ih () state remaining).trans (Nat.cast_le.mpr (Nat.le_succ remaining)) + · simp only [hrevealed, ↓reduceIte] + calc + _ ≤ 1 + (remaining : ℝ≥0∞) := + add_le_add (by exact_mod_cast pendingProbeCharge_le_one state coordinate candidate) + (ih () (state.addPending coordinate candidate) remaining) + _ = _ := by simp only [Nat.cast_add, Nat.cast_one, add_comm] + | reveal coordinate => + dsimp only + cases hvalue : state.values coordinate with + | some output => exact ih output state fuel + | none => + apply havg + intro output + split_ifs + · exact bot_le + · exact ih output (state.materialize coordinate output) fuel + +theorem expectedProbeCharge_le_queryBound {α : Type} + (computation : OracleComp (World Coordinate) α) (state : State Coordinate) (fuel bound : Nat) + (hbound : computation.IsQueryBoundP IsProbe bound) : expectedProbeCharge computation state fuel ≤ bound := by + have havg {β : Type} (source : ProbComp β) (charge : β → ℝ≥0∞) (cap : ℝ≥0∞) + (hcharge : ∀ value, charge value ≤ cap) : (∑' value, Pr[= value | source] * charge value) ≤ cap := by + apply le_trans (ENNReal.tsum_le_tsum fun value => mul_le_mul' le_rfl (hcharge value)) + rw [ENNReal.tsum_mul_right] + exact mul_le_of_le_one_left (by positivity) tsum_probOutput_le_one + induction computation using OracleComp.inductionOn generalizing state fuel bound with + | pure value => exact bot_le + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [expectedProbeCharge_query_bind] + cases input with + | uniform n => exact havg _ _ _ fun output => ih output state fuel bound (by simpa [IsProbe] using hbound.2 output) + | hashOutput => exact havg _ _ _ fun output => ih output state fuel bound (by simpa [IsProbe] using hbound.2 output) + | ensure coordinate => exact ih () (state.ensure coordinate) fuel bound (by simpa [IsProbe] using hbound.2 ()) + | peek coordinate => exact ih (state.values coordinate) state fuel bound (by simpa [IsProbe] using hbound.2 _) + | publish coordinate => exact ih () (state.publish coordinate) fuel bound (by simpa [IsProbe] using hbound.2 ()) + | probe coordinate candidate => + have hpositive : 0 < bound := by simpa [IsProbe] using hbound.1 + have hnext : (next ()).IsQueryBoundP IsProbe (bound - 1) := by simpa [IsProbe] using hbound.2 () + cases fuel with + | zero => exact bot_le + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + exact (ih () state remaining (bound - 1) hnext).trans (Nat.cast_le.mpr (Nat.sub_le _ _)) + · simp only [hrevealed, ↓reduceIte] + calc + _ ≤ (1 : ℝ≥0∞) + (bound - 1 : Nat) := + add_le_add (by exact_mod_cast pendingProbeCharge_le_one state coordinate candidate) + (ih () (state.addPending coordinate candidate) remaining (bound - 1) hnext) + _ = _ := by + rw [← Nat.cast_one, ← Nat.cast_add] + congr 1 + omega + | reveal coordinate => + dsimp only + cases hvalue : state.values coordinate with + | some output => exact ih output state fuel bound (by simpa [IsProbe] using hbound.2 output) + | none => + apply havg + intro output + split_ifs + · exact bot_le + · exact ih output (state.materialize coordinate output) fuel bound (by simpa [IsProbe] using hbound.2 output) + +end SphincsSecurity.LazyRevealProbe diff --git a/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbeChargeBind.lean b/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbeChargeBind.lean new file mode 100644 index 00000000..3c87885a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbeChargeBind.lean @@ -0,0 +1,100 @@ +import SphincsSecurity.Proof.LazyRevealProbeCostBind + +namespace SphincsSecurity.LazyRevealProbe + +open OracleComp OracleSpec ENNReal + +variable {Coordinate : Type} [DecidableEq Coordinate] + +noncomputable def RawResult.continuationCharge {α β : Type} + (next : α → OracleComp (World Coordinate) β) : RawResult Coordinate α → ℝ≥0∞ + | .stopped _ => 0 + | .done state remaining value => expectedProbeCharge (next value) state remaining + +theorem expectedProbeCharge_bind {α β : Type} + (left : OracleComp (World Coordinate) α) (next : α → OracleComp (World Coordinate) β) + (state : State Coordinate) (fuel : Nat) : + expectedProbeCharge (left >>= next) state fuel = expectedProbeCharge left state fuel + + ∑' result, Pr[= result | runRaw state fuel left] * result.continuationCharge next := by + induction left using OracleComp.inductionOn generalizing state fuel with + | pure value => + simp only [pure_bind, expectedProbeCharge, OracleComp.construct_pure, runRaw, + tsum_probOutput_pure_mul, RawResult.continuationCharge, zero_add] + | query_bind input continuation ih => + rw [bind_assoc, expectedProbeCharge_query_bind, expectedProbeCharge_query_bind] + cases input with + | uniform n => + rw [runRaw_uniform_query_bind, tsum_probOutput_bind_mul] + simp_rw [ih, mul_add, ENNReal.tsum_add] + | hashOutput => + rw [runRaw_hashOutput_query_bind, tsum_probOutput_bind_mul] + simp_rw [ih, mul_add, ENNReal.tsum_add] + | ensure coordinate => + rw [runRaw_ensure_query_bind] + exact ih () (state.ensure coordinate) fuel + | peek coordinate => + rw [runRaw_peek_query_bind] + exact ih (state.values coordinate) state fuel + | publish coordinate => + rw [runRaw_publish_query_bind] + exact ih () (state.publish coordinate) fuel + | probe coordinate candidate => + rw [runRaw_probe_query_bind] + cases fuel with + | zero => simp only [tsum_probOutput_pure_mul, RawResult.continuationCharge, add_zero] + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () state remaining + · simp only [hrevealed, ↓reduceIte] + rw [ih, add_assoc] + | reveal coordinate => + rw [runRaw_reveal_query_bind] + dsimp only + cases hvalue : state.values coordinate with + | some output => exact ih output state fuel + | none => + rw [tsum_probOutput_bind_mul, ← ENNReal.tsum_add] + apply tsum_congr + intro output + by_cases hhit : state.hitAt coordinate output + · simp only [hhit, ↓reduceIte, tsum_probOutput_pure_mul, + RawResult.continuationCharge, mul_zero, add_zero] + · simp only [hhit, ↓reduceIte, ih, mul_add] + +theorem expectedProbeCharge_bind_of_probeFree {α β : Type} + (left : OracleComp (World Coordinate) α) (next : α → OracleComp (World Coordinate) β) + (state : State Coordinate) (fuel : Nat) (hleft : left.IsQueryBoundP IsProbe 0) : + expectedProbeCharge (left >>= next) state fuel = + ∑' result, Pr[= result | runRaw state fuel left] * result.continuationCharge next := by + rw [expectedProbeCharge_bind, expectedProbeCharge_eq_zero_of_probeFree left state fuel hleft, zero_add] + +theorem expectedProbeCharge_bind_pure {α β : Type} + (computation : OracleComp (World Coordinate) α) (f : α → β) + (state : State Coordinate) (fuel : Nat) : + expectedProbeCharge (computation >>= fun value => pure (f value)) state fuel = + expectedProbeCharge computation state fuel := by + rw [expectedProbeCharge_bind] + suffices hzero : (∑' result, Pr[= result | runRaw state fuel computation] * + result.continuationCharge (fun value => pure (f value))) = 0 by rw [hzero, add_zero] + apply ENNReal.tsum_eq_zero.mpr + intro result + cases result <;> simp only [RawResult.continuationCharge, expectedProbeCharge, + OracleComp.construct_pure, mul_zero] + +theorem expectedProbeCharge_bind_of_tail_probeFree {α β : Type} + (left : OracleComp (World Coordinate) α) (next : α → OracleComp (World Coordinate) β) + (state : State Coordinate) (fuel : Nat) (hnext : ∀ value, (next value).IsQueryBoundP IsProbe 0) : + expectedProbeCharge (left >>= next) state fuel = expectedProbeCharge left state fuel := by + rw [expectedProbeCharge_bind] + suffices hzero : (∑' result, Pr[= result | runRaw state fuel left] * result.continuationCharge next) = 0 by + rw [hzero, add_zero] + apply ENNReal.tsum_eq_zero.mpr + intro result + cases result with + | stopped hit => simp only [RawResult.continuationCharge, mul_zero] + | done nextState remaining value => + simp only [RawResult.continuationCharge, + expectedProbeCharge_eq_zero_of_probeFree _ nextState remaining (hnext value), mul_zero] + +end SphincsSecurity.LazyRevealProbe diff --git a/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbeCost.lean b/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbeCost.lean new file mode 100644 index 00000000..9486a2eb --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbeCost.lean @@ -0,0 +1,177 @@ +import SphincsSecurity.Proof.LazyRevealProbeCharge + +namespace SphincsSecurity.LazyRevealProbe + +open OracleComp OracleSpec ENNReal + +variable {Coordinate : Type} [DecidableEq Coordinate] + +noncomputable def runCharged {α : Type} (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) α) : ProbComp (RawResult Coordinate α × Nat) := + OracleComp.construct + (C := fun _ => State Coordinate → Nat → ProbComp (RawResult Coordinate α × Nat)) + (fun value state remaining => pure (.done state remaining value, 0)) + (fun input _ next state fuel => + match input with + | .uniform n => do + let output ← liftM (unifSpec.query n) + next output state fuel + | .hashOutput => do + let output ← sampleHashOutput + next output state fuel + | .ensure coordinate => next () (state.ensure coordinate) fuel + | .probe coordinate candidate => + match fuel with + | 0 => pure (.stopped false, 0) + | remaining + 1 => + if coordinate ∈ state.revealed then next () state remaining + else (fun result => (result.1, result.2 + pendingProbeCharge state coordinate candidate)) <$> + next () (state.addPending coordinate candidate) remaining + | .peek coordinate => next (state.values coordinate) state fuel + | .publish coordinate => next () (state.publish coordinate) fuel + | .reveal coordinate => + match state.values coordinate with + | some output => next output state fuel + | none => do + let output ← sampleHashOutput + if state.hitAt coordinate output then pure (.stopped true, 0) + else next output (state.materialize coordinate output) fuel) + computation state fuel + +theorem runCharged_result_eq_runRaw {α : Type} (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) α) : + Prod.fst <$> runCharged state fuel computation = runRaw state fuel computation := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => simp only [runCharged, runRaw, OracleComp.construct_pure, map_pure] + | query_bind input next ih => + rw [runCharged, runRaw, OracleComp.construct_query_bind, OracleComp.construct_query_bind] + cases input with + | uniform n => + simp only [map_bind] + exact bind_congr fun output => ih output state fuel + | hashOutput => + simp only [map_bind] + exact bind_congr fun output => ih output state fuel + | ensure coordinate => exact ih () (state.ensure coordinate) fuel + | peek coordinate => exact ih (state.values coordinate) state fuel + | publish coordinate => exact ih () (state.publish coordinate) fuel + | probe coordinate candidate => + cases fuel with + | zero => simp only [map_pure] + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simpa only [runCharged, runRaw, hrevealed, ↓reduceIte] using ih () state remaining + · simpa only [runCharged, runRaw, hrevealed, ↓reduceIte, Functor.map_map] using + ih () (state.addPending coordinate candidate) remaining + | reveal coordinate => + dsimp only + cases hvalue : state.values coordinate with + | some output => exact ih output state fuel + | none => + rw [map_bind] + apply bind_congr + intro output + split_ifs with hhit + · simp only [map_pure] + · exact ih output (state.materialize coordinate output) fuel + +theorem runCharged_cost_le_fuel {α : Type} (state : State Coordinate) (fuel : Nat) + (computation : OracleComp (World Coordinate) α) : + ∀ result ∈ support (runCharged state fuel computation), result.2 ≤ fuel := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + intro result hresult + simp only [runCharged, OracleComp.construct_pure, support_pure, Set.mem_singleton_iff] at hresult + rw [hresult] + exact Nat.zero_le _ + | query_bind input next ih => + intro result hresult + rw [runCharged, OracleComp.construct_query_bind] at hresult + cases input with + | uniform n => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _, hrest⟩ := hresult + exact ih output state fuel result hrest + | hashOutput => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _, hrest⟩ := hresult + exact ih output state fuel result hrest + | ensure coordinate => exact ih () (state.ensure coordinate) fuel result hresult + | peek coordinate => exact ih (state.values coordinate) state fuel result hresult + | publish coordinate => exact ih () (state.publish coordinate) fuel result hresult + | probe coordinate candidate => + cases fuel with + | zero => + simp only [support_pure, Set.mem_singleton_iff] at hresult + rw [hresult] + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] at hresult + exact (ih () state remaining result hresult).trans (Nat.le_succ remaining) + · simp only [hrevealed, ↓reduceIte, support_map, Set.mem_image] at hresult + obtain ⟨previous, hprevious, heq⟩ := hresult + rw [← heq] + exact Nat.add_le_add (ih () (state.addPending coordinate candidate) remaining previous hprevious) + (pendingProbeCharge_le_one state coordinate candidate) + | reveal coordinate => + dsimp only at hresult + cases hvalue : state.values coordinate with + | some output => + simp only [hvalue] at hresult + exact ih output state fuel result hresult + | none => + simp only [hvalue, mem_support_bind_iff] at hresult + obtain ⟨output, _, hrest⟩ := hresult + split_ifs at hrest with hhit + · simp only [support_pure, Set.mem_singleton_iff] at hrest + rw [hrest] + exact Nat.zero_le _ + · exact ih output (state.materialize coordinate output) fuel result hrest + +theorem runCharged_expectedCost_eq {α : Type} + (computation : OracleComp (World Coordinate) α) (state : State Coordinate) (fuel : Nat) : + (∑' result, Pr[= result | runCharged state fuel computation] * (result.2 : ℝ≥0∞)) = + expectedProbeCharge computation state fuel := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => simp only [runCharged, expectedProbeCharge, OracleComp.construct_pure, + tsum_probOutput_pure_mul, Nat.cast_zero] + | query_bind input next ih => + rw [expectedProbeCharge_query_bind, runCharged, OracleComp.construct_query_bind] + cases input with + | uniform n => + rw [tsum_probOutput_bind_mul] + exact tsum_congr fun output => congrArg (fun cost => Pr[= output | (liftM (unifSpec.query n) : ProbComp _)] * cost) + (ih output state fuel) + | hashOutput => + rw [tsum_probOutput_bind_mul] + exact tsum_congr fun output => congrArg (fun cost => Pr[= output | sampleHashOutput] * cost) + (ih output state fuel) + | ensure coordinate => exact ih () (state.ensure coordinate) fuel + | peek coordinate => exact ih (state.values coordinate) state fuel + | publish coordinate => exact ih () (state.publish coordinate) fuel + | probe coordinate candidate => + cases fuel with + | zero => simp only [tsum_probOutput_pure_mul, Nat.cast_zero] + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () state remaining + · simp only [hrevealed, ↓reduceIte, tsum_probOutput_map_mul, Nat.cast_add, mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul] + change (∑' result, Pr[= result | runCharged (state.addPending coordinate candidate) remaining + (next ())] * (result.2 : ℝ≥0∞)) + _ = _ + rw [ih, add_comm] + | reveal coordinate => + dsimp only + cases hvalue : state.values coordinate with + | some output => exact ih output state fuel + | none => + rw [tsum_probOutput_bind_mul] + apply tsum_congr + intro output + split_ifs with hhit + · simp only [tsum_probOutput_pure_mul, Nat.cast_zero] + · exact congrArg (fun cost => Pr[= output | sampleHashOutput] * cost) + (ih output (state.materialize coordinate output) fuel) + +end SphincsSecurity.LazyRevealProbe diff --git a/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbeCostBind.lean b/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbeCostBind.lean new file mode 100644 index 00000000..fab4dca6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbeCostBind.lean @@ -0,0 +1,142 @@ +import SphincsSecurity.Proof.LazyRevealProbeCost + +namespace SphincsSecurity.LazyRevealProbe + +open OracleComp OracleSpec ENNReal + +variable {Coordinate : Type} [DecidableEq Coordinate] + +set_option maxRecDepth 10000 in +theorem runCharged_bind_done_support {α β : Type} + (left : OracleComp (World Coordinate) α) (next : α → OracleComp (World Coordinate) β) + (state : State Coordinate) (fuel : Nat) (finalState : State Coordinate) (remaining : Nat) + (value : β) (cost : Nat) + (hresult : (.done finalState remaining value, cost) ∈ support (runCharged state fuel (left >>= next))) : + ∃ middleState middleValue middleFuel leftCost rightCost, + middleFuel ≤ fuel ∧ + (.done middleState middleFuel middleValue, leftCost) ∈ support (runCharged state fuel left) ∧ + (.done finalState remaining value, rightCost) ∈ support (runCharged middleState middleFuel (next middleValue)) ∧ + cost = leftCost + rightCost := by + induction left using OracleComp.inductionOn generalizing state fuel cost with + | pure middleValue => + rw [pure_bind] at hresult + refine ⟨state, middleValue, fuel, 0, cost, le_rfl, ?_, hresult, by omega⟩ + simp only [runCharged, OracleComp.construct_pure, support_pure, Set.mem_singleton_iff] + | query_bind input continuation ih => + rw [bind_assoc, runCharged, OracleComp.construct_query_bind] at hresult + cases input with + | uniform n => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hrest⟩ := hresult + obtain ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, hleft, hright, hcost⟩ := + ih output state fuel cost hrest + refine ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, ?_, hright, hcost⟩ + rw [runCharged, OracleComp.construct_query_bind, mem_support_bind_iff] + exact ⟨output, houtput, hleft⟩ + | hashOutput => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hrest⟩ := hresult + obtain ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, hleft, hright, hcost⟩ := + ih output state fuel cost hrest + refine ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, ?_, hright, hcost⟩ + rw [runCharged, OracleComp.construct_query_bind, mem_support_bind_iff] + exact ⟨output, houtput, hleft⟩ + | ensure coordinate => + simpa only [runCharged, OracleComp.construct_query_bind] using + ih () (state.ensure coordinate) fuel cost hresult + | peek coordinate => + simpa only [runCharged, OracleComp.construct_query_bind] using + ih (state.values coordinate) state fuel cost hresult + | publish coordinate => + simpa only [runCharged, OracleComp.construct_query_bind] using + ih () (state.publish coordinate) fuel cost hresult + | probe coordinate candidate => + cases fuel with + | zero => + simp only [support_pure, Set.mem_singleton_iff, Prod.mk.injEq, reduceCtorEq, false_and] at hresult + | succ restFuel => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] at hresult + obtain ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, hleft, hright, hcost⟩ := + ih () state restFuel cost hresult + refine ⟨middleState, middleValue, middleFuel, leftCost, rightCost, + hbudget.trans (Nat.le_succ _), ?_, hright, hcost⟩ + rw [runCharged, OracleComp.construct_query_bind] + simpa only [hrevealed, ↓reduceIte, runCharged] using hleft + · simp only [hrevealed, ↓reduceIte, support_map, Set.mem_image] at hresult + obtain ⟨⟨previousResult, previousCost⟩, hrest, heq⟩ := hresult + have hresultEq : previousResult = .done finalState remaining value := congrArg Prod.fst heq + have hcostEq : previousCost + pendingProbeCharge state coordinate candidate = cost := congrArg Prod.snd heq + rw [hresultEq] at hrest + obtain ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, hleft, hright, hcost⟩ := + ih () (state.addPending coordinate candidate) restFuel previousCost hrest + refine ⟨middleState, middleValue, middleFuel, leftCost + pendingProbeCharge state coordinate candidate, + rightCost, hbudget.trans (Nat.le_succ _), ?_, hright, by omega⟩ + rw [runCharged, OracleComp.construct_query_bind] + simp only [hrevealed, ↓reduceIte, support_map, Set.mem_image] + exact ⟨(.done middleState middleFuel middleValue, leftCost), hleft, rfl⟩ + | reveal coordinate => + dsimp only at hresult + cases hvalue : state.values coordinate with + | some output => + simp only [hvalue] at hresult + obtain ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, hleft, hright, hcost⟩ := + ih output state fuel cost hresult + refine ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, ?_, hright, hcost⟩ + rw [runCharged, OracleComp.construct_query_bind] + simpa only [hvalue, runCharged] using hleft + | none => + simp only [hvalue, mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hrest⟩ := hresult + split_ifs at hrest with hhit + · simp only [support_pure, Set.mem_singleton_iff, Prod.mk.injEq, reduceCtorEq, false_and] at hrest + · obtain ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, hleft, hright, hcost⟩ := + ih output (state.materialize coordinate output) fuel cost hrest + refine ⟨middleState, middleValue, middleFuel, leftCost, rightCost, hbudget, ?_, hright, hcost⟩ + rw [runCharged, OracleComp.construct_query_bind] + simp only [hvalue, mem_support_bind_iff] + exact ⟨output, houtput, by simpa only [hhit, ↓reduceIte, runCharged] using hleft⟩ + +theorem expectedProbeCharge_eq_zero_of_probeFree {α : Type} + (computation : OracleComp (World Coordinate) α) (state : State Coordinate) (fuel : Nat) + (hbound : computation.IsQueryBoundP IsProbe 0) : expectedProbeCharge computation state fuel = 0 := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => rfl + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [expectedProbeCharge_query_bind] + cases input with + | uniform n => + apply ENNReal.tsum_eq_zero.mpr + intro output + rw [ih output state fuel (by simpa [IsProbe] using hbound.2 output), mul_zero] + | hashOutput => + apply ENNReal.tsum_eq_zero.mpr + intro output + rw [ih output state fuel (by simpa [IsProbe] using hbound.2 output), mul_zero] + | ensure coordinate => exact ih () (state.ensure coordinate) fuel (by simpa [IsProbe] using hbound.2 ()) + | peek coordinate => exact ih (state.values coordinate) state fuel (by simpa [IsProbe] using hbound.2 _) + | publish coordinate => exact ih () (state.publish coordinate) fuel (by simpa [IsProbe] using hbound.2 ()) + | probe coordinate candidate => simpa [IsProbe] using hbound.1 + | reveal coordinate => + dsimp only + cases hvalue : state.values coordinate with + | some output => exact ih output state fuel (by simpa [IsProbe] using hbound.2 output) + | none => + apply ENNReal.tsum_eq_zero.mpr + intro output + rw [ih output (state.materialize coordinate output) fuel (by simpa [IsProbe] using hbound.2 output)] + simp only [ite_self, mul_zero] + +theorem runCharged_cost_eq_zero_of_probeFree {α : Type} + (computation : OracleComp (World Coordinate) α) (state : State Coordinate) (fuel : Nat) + (hbound : computation.IsQueryBoundP IsProbe 0) (result : RawResult Coordinate α × Nat) + (hresult : result ∈ support (runCharged state fuel computation)) : result.2 = 0 := by + have hexpectation := runCharged_expectedCost_eq computation state fuel + rw [expectedProbeCharge_eq_zero_of_probeFree computation state fuel hbound, ENNReal.tsum_eq_zero] at hexpectation + have hterm := hexpectation result + have hmass : Pr[= result | runCharged state fuel computation] ≠ 0 := by + rwa [mem_support_iff_evalDist_apply_ne_zero] at hresult + exact_mod_cast (mul_eq_zero.mp hterm).resolve_left hmass + +end SphincsSecurity.LazyRevealProbe diff --git a/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbePending.lean b/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbePending.lean new file mode 100644 index 00000000..92348fc6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbePending.lean @@ -0,0 +1,92 @@ +import SphincsSecurity.Proof.LazyRevealProbe + +namespace SphincsSecurity.LazyRevealProbe + +open OracleComp OracleSpec ENNReal + +variable {Coordinate : Type} [DecidableEq Coordinate] + +def State.unmaterializedPending (state : State Coordinate) : Finset (Coordinate × Digest) := + state.pending.filter fun entry => state.values entry.1 = none + +omit [DecidableEq Coordinate] in +theorem State.unmaterializedPending_card_le (state : State Coordinate) : + state.unmaterializedPending.card ≤ state.pending.card := Finset.card_filter_le _ _ + +theorem State.unmaterializedPending_clearPending (state : State Coordinate) (coordinate : Coordinate) : + (state.clearPending coordinate).unmaterializedPending = + state.unmaterializedPending.filter (fun entry => entry.1 ≠ coordinate) := by + ext entry + simp only [unmaterializedPending, clearPending, pendingAway, Finset.mem_filter] + tauto + +theorem State.unmaterializedPending_materialize (state : State Coordinate) + (coordinate : Coordinate) (output : HashOutput) : + (state.materialize coordinate output).unmaterializedPending = + (state.clearPending coordinate).unmaterializedPending := by + ext entry + by_cases heq : entry.1 = coordinate + · simp [unmaterializedPending, materialize, clearPending, pendingAway, heq] + · simp [unmaterializedPending, materialize, clearPending, pendingAway, heq] + +theorem State.unmaterializedPending_complete (state : State Coordinate) + (coordinate : Coordinate) (output : HashOutput) : + (state.complete coordinate output).unmaterializedPending = + (state.clearPending coordinate).unmaterializedPending := + state.unmaterializedPending_materialize coordinate output + +theorem State.unmaterializedPending_clearPending_card_le (state : State Coordinate) (coordinate : Coordinate) : + (state.clearPending coordinate).unmaterializedPending.card ≤ state.unmaterializedPending.card := by + rw [state.unmaterializedPending_clearPending] + exact Finset.card_filter_le _ _ + +theorem State.unmaterializedPending_card_split_le (state : State Coordinate) (coordinate : Coordinate) + (hvalue : state.values coordinate = none) : + (state.clearPending coordinate).unmaterializedPending.card + (state.pendingAt coordinate).card ≤ + state.unmaterializedPending.card := by + have hat : state.pending.filter (fun entry => entry.1 = coordinate) = + state.unmaterializedPending.filter (fun entry => entry.1 = coordinate) := by + ext entry + simp only [unmaterializedPending, Finset.mem_filter] + constructor + · rintro ⟨hmem, heq⟩ + exact ⟨⟨hmem, heq ▸ hvalue⟩, heq⟩ + · exact fun h => ⟨h.1.1, h.2⟩ + apply (Nat.add_le_add_left (state.pendingAt_card_le coordinate) _).trans_eq + rw [hat, state.unmaterializedPending_clearPending, Nat.add_comm] + exact Finset.card_filter_add_card_filter_not _ + +theorem finalizeFrom_probability_le_unmaterializedPending (coordinates : List Coordinate) + (state : State Coordinate) : + Pr[fun hit : Bool => hit = true | finalizeFrom coordinates state] ≤ + (state.unmaterializedPending.card : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + induction coordinates generalizing state with + | nil => simp [finalizeFrom] + | cons coordinate remaining ih => + rw [finalizeFrom] + cases hvalue : state.values coordinate with + | some output => + exact (ih (state.clearPending coordinate)).trans + (mul_le_mul' (Nat.cast_le.mpr (state.unmaterializedPending_clearPending_card_le coordinate)) le_rfl) + | none => + refine (probEvent_bind_le_probEvent_add + (mx := sampleHashOutput) + (my := fun output => if state.hitAt coordinate output then pure true + else finalizeFrom remaining (state.complete coordinate output)) + (q := fun hit : Bool => hit = true) (p := state.hitAt coordinate) + (ε := ((state.clearPending coordinate).unmaterializedPending.card : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) ?_).trans ?_ + · intro output _ hmiss + simp only [hmiss, ↓reduceIte] + simpa only [state.unmaterializedPending_complete] using ih (state.complete coordinate output) + · apply (add_le_add (probEvent_sampleHashOutput_hitAt_le state coordinate) le_rfl).trans + rw [← add_mul, ← Nat.cast_add] + apply mul_le_mul' _ le_rfl + exact Nat.cast_le.mpr (by simpa only [Nat.add_comm] using state.unmaterializedPending_card_split_le coordinate hvalue) + +theorem finalize_probability_le_unmaterializedPending (state : State Coordinate) : + Pr[fun hit : Bool => hit = true | finalize state] ≤ + (state.unmaterializedPending.card : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + finalizeFrom_probability_le_unmaterializedPending state.coordinates.toList state + +end SphincsSecurity.LazyRevealProbe diff --git a/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbeSimulationCharge.lean b/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbeSimulationCharge.lean new file mode 100644 index 00000000..d148bad8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/LazyRevealProbeSimulationCharge.lean @@ -0,0 +1,58 @@ +import SphincsSecurity.Proof.LazyRevealProbeChargeBind + +namespace SphincsSecurity.LazyRevealProbe + +open OracleComp OracleSpec ENNReal + +variable {Coordinate Cache ι : Type} [DecidableEq Coordinate] {spec : OracleSpec ι} + +noncomputable def expectedSimulationCharge {α : Type} + (impl : QueryImpl spec (StateT Cache (OracleComp (World Coordinate)))) + (charge : spec.Domain → Cache → State Coordinate → Nat → ℝ≥0∞) + (computation : OracleComp spec α) : Cache → State Coordinate → Nat → ℝ≥0∞ := + OracleComp.construct (fun _ _ _ _ => 0) + (fun input _ next cache state fuel => + charge input cache state fuel + + ∑' result, Pr[= result | runRaw state fuel ((impl input).run cache)] * + match result with + | .stopped _ => 0 + | .done nextState remaining value => next value.1 value.2 nextState remaining) + computation + +theorem expectedSimulationCharge_query_bind {α : Type} + (impl : QueryImpl spec (StateT Cache (OracleComp (World Coordinate)))) + (charge : spec.Domain → Cache → State Coordinate → Nat → ℝ≥0∞) + (input : spec.Domain) (next : spec.Range input → OracleComp spec α) + (cache : Cache) (state : State Coordinate) (fuel : Nat) : + expectedSimulationCharge impl charge (OracleSpec.query input >>= next) cache state fuel = + charge input cache state fuel + + ∑' result, Pr[= result | runRaw state fuel ((impl input).run cache)] * + match result with + | .stopped _ => 0 + | .done nextState remaining value => + expectedSimulationCharge impl charge (next value.1) value.2 nextState remaining := rfl + +theorem expectedProbeCharge_simulateQ_le {α : Type} + (impl : QueryImpl spec (StateT Cache (OracleComp (World Coordinate)))) + (charge : spec.Domain → Cache → State Coordinate → Nat → ℝ≥0∞) + (hcharge : ∀ input cache state fuel, + expectedProbeCharge ((impl input).run cache) state fuel ≤ charge input cache state fuel) + (computation : OracleComp spec α) (cache : Cache) (state : State Coordinate) (fuel : Nat) : + expectedProbeCharge ((simulateQ impl computation).run cache) state fuel ≤ + expectedSimulationCharge impl charge computation cache state fuel := by + induction computation using OracleComp.inductionOn generalizing cache state fuel with + | pure value => + simp only [simulateQ_pure, StateT.run_pure, expectedProbeCharge, expectedSimulationCharge, + OracleComp.construct_pure, le_refl] + | query_bind input next ih => + rw [simulateQ_query_bind, StateT.run_bind, expectedProbeCharge_bind, + expectedSimulationCharge_query_bind] + apply add_le_add (hcharge input cache state fuel) + apply ENNReal.tsum_le_tsum + intro result + apply mul_le_mul' le_rfl + cases result with + | stopped hit => exact le_rfl + | done nextState remaining value => exact ih value.1 value.2 nextState remaining + +end SphincsSecurity.LazyRevealProbe diff --git a/formal/sphincs/SphincsSecurity/Proof/LeakArith.lean b/formal/sphincs/SphincsSecurity/Proof/LeakArith.lean new file mode 100644 index 00000000..a5dbe94b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/LeakArith.lean @@ -0,0 +1,60 @@ +import SphincsSecurity.Statement + +/-! +# The few-time leak, arithmetically + +A forgery through the few-time forest needs, for each of the `k - 1` trees it opens, some signature +at the same index that revealed that tree's leaf. Union bounding over which signatures those are and +which tree each covers gives a *finite* sum, one term per number `d` of distinct signatures involved, +`d` running only to `k - 1` because no more can be needed: + + sum over d of C(q_s, d) * 2^(-h*d) * d^(k-1) * 2^(-a*(k-1)). + +So the leak needs no tail estimate. The true value is about `2^-133.3`, this union bound gives about +`2^-122.9`, and `2^-120` is what the claim needs. + +The statement below clears the denominators and replaces each binomial by `q_s^d / d!`, which loses +nothing that matters and keeps every number a product of literals and powers of two. That is +deliberate: `Nat.choose` at `q_s = 2^24` is not something the kernel can evaluate, its recursion +being on `n`, and asking it to try costs two minutes and then fails. +-/ + +namespace SphincsSecurity + +-- the terms carry exponents past the linter's threshold; `decide` evaluates them, the elaborator need not +set_option exponentiation.threshold 400 + +/-- `d ! * C(n, d) ≤ n ^ d`, which is what lets the binomials go. -/ +theorem factorial_mul_choose_le_pow (n d : Nat) : + Nat.factorial d * Nat.choose n d ≤ n ^ d := by + rw [← Nat.descFactorial_eq_factorial_mul_choose] + exact Nat.descFactorial_le_pow n d + +/-- The leak's union bound, with `14!` and the powers of two cleared through it. The multipliers are +`14! / d!`, written out so that nothing has to evaluate a factorial. The right side retains two +bits of the true `2^-122.9` bound for the final union with the structural event. -/ +theorem leak_union_bound_scaled : + 87178291200 * 2 ^ (24 * 1) * 1 ^ 14 * 2 ^ (26 * 13) + + 43589145600 * 2 ^ (24 * 2) * 2 ^ 14 * 2 ^ (26 * 12) + + 14529715200 * 2 ^ (24 * 3) * 3 ^ 14 * 2 ^ (26 * 11) + + 3632428800 * 2 ^ (24 * 4) * 4 ^ 14 * 2 ^ (26 * 10) + + 726485760 * 2 ^ (24 * 5) * 5 ^ 14 * 2 ^ (26 * 9) + + 121080960 * 2 ^ (24 * 6) * 6 ^ 14 * 2 ^ (26 * 8) + + 17297280 * 2 ^ (24 * 7) * 7 ^ 14 * 2 ^ (26 * 7) + + 2162160 * 2 ^ (24 * 8) * 8 ^ 14 * 2 ^ (26 * 6) + + 240240 * 2 ^ (24 * 9) * 9 ^ 14 * 2 ^ (26 * 5) + + 24024 * 2 ^ (24 * 10) * 10 ^ 14 * 2 ^ (26 * 4) + + 2184 * 2 ^ (24 * 11) * 11 ^ 14 * 2 ^ (26 * 3) + + 182 * 2 ^ (24 * 12) * 12 ^ 14 * 2 ^ (26 * 2) + + 14 * 2 ^ (24 * 13) * 13 ^ 14 * 2 ^ 26 + + 1 * 2 ^ (24 * 14) * 14 ^ 14 + ≤ 87178291200 * 2 ^ 382 := by + decide + +theorem leak_union_bound_scaled_sum : + ∑ d ∈ Finset.Icc 1 14, + (d + 1).ascFactorial (14 - d) * 2 ^ (24 * d) * d ^ 14 * 2 ^ (26 * (14 - d)) + ≤ Nat.factorial 14 * 2 ^ 382 := by + decide + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Logged.lean b/formal/sphincs/SphincsSecurity/Proof/Logged.lean new file mode 100644 index 00000000..cb74bd1d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Logged.lean @@ -0,0 +1,44 @@ +import SphincsSecurity.Proof.Game + +/-! +# The adversary's own queries + +The cache cannot say who asked: it holds key generation's queries, the signer's, and the adversary's +alike. Every remaining step of the reduction needs the distinction, because what has to be charged is +what the *adversary* asked. Wrapping its oracle with a log supplies it, and costs nothing: the log is +discarded, and `fst_map_run_withLogging` says the value distribution is unchanged. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +/-- The rest of the game, with the adversary's queries logged alongside the verdict. -/ +noncomputable def gameRestLogged (scheme : Scheme) (adversary : Adversary) (pk : PublicKey) + (sk : SecretKey) : OracleComp OracleWorld (Bool × QueryLog (OracleWorld + SigningSpec)) := do + let result ← ((simulateQ ((forwardOracles + signingOracle scheme sk).withLogging) + (adversary.main pk)).run).run + let verified ← scheme.verify pk result.1.1.message result.1.1.signature + return (decide (SigningTranscript.Valid result.2 ∧ ¬SigningTranscript.Contains result.2 result.1.1) + && verified, result.1.2) + +/-- Logging the adversary changes no distribution: the verdict is the first component. -/ +theorem gameRest_eq_map_gameRestLogged (scheme : Scheme) (adversary : Adversary) (pk : PublicKey) + (sk : SecretKey) : + gameRest scheme adversary pk sk = Prod.fst <$> gameRestLogged scheme adversary pk sk := by + simp only [gameRest, gameRestLogged, map_bind, map_pure] + rw [← QueryImpl.fst_map_run_withLogging (forwardOracles + signingOracle scheme sk) (adversary.main pk)] + simp [bind_map_left] + +/-- **The reduction's frame, with the adversary's queries in hand.** -/ +theorem forgeAdvantage_le_logged (scheme : Scheme) (adversary : Adversary) (c : ℝ≥0∞) + (h : ∀ keys : (PublicKey × SecretKey), ∀ cache : QueryCache HashSpec, + (keys, cache) ∈ support ((simulateQ romImpl scheme.keygen).run ∅) → + Pr[fun result => result.1.1 = true + | (simulateQ romImpl (gameRestLogged scheme adversary keys.1 keys.2)).run cache] ≤ c) : + forgeAdvantage scheme adversary ≤ c := by + refine forgeAdvantage_le scheme adversary c fun keys cache hmem => ?_ + rw [gameRest_eq_map_gameRestLogged, simulateQ_map, StateT.run_map, probEvent_map] + exact h keys cache hmem + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/MandatoryQueries.lean b/formal/sphincs/SphincsSecurity/Proof/MandatoryQueries.lean new file mode 100644 index 00000000..c7dfd04a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/MandatoryQueries.lean @@ -0,0 +1,169 @@ +import SphincsSecurity.Proof.CacheSize +import SphincsSecurity.Proof.Cached +import SphincsSecurity.Proof.Secrets +import SphincsSecurity.Proof.SettledPath +import SphincsSecurity.Proof.Support + +/-! +# Mandatory hash queries + +The public-key root computation settles a one-time leaf and all of its chains. Their domains differ, +so every root cache has at least `numChains = 42` entries. Consequently every complete-game +hash-query bound is at least 42, which absorbs the constant terms in the final security arithmetic. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +theorem QueryCache.two_le_enncard_of_cached_of_ne + {cache : QueryCache HashSpec} {left right : HashInput} + (hleft : cache left ≠ none) (hright : cache right ≠ none) (hne : left ≠ right) : + (2 : ℝ≥0∞) ≤ QueryCache.enncard cache := by + obtain ⟨leftAnswer, hleftAnswer⟩ := Option.ne_none_iff_exists'.mp hleft + obtain ⟨rightAnswer, hrightAnswer⟩ := Option.ne_none_iff_exists'.mp hright + let leftEntry : (input : HashInput) × HashOutput := ⟨left, leftAnswer⟩ + let rightEntry : (input : HashInput) × HashOutput := ⟨right, rightAnswer⟩ + have hentryNe : leftEntry ≠ rightEntry := by + intro heq + exact hne (congrArg Sigma.fst heq) + have hsubset : ({leftEntry, rightEntry} : Set ((input : HashInput) × HashOutput)) ⊆ + cache.toSet := by + intro entry hentry + rcases hentry with hentry | hentry + · subst entry + exact hleftAnswer + · have hentryEq : entry = rightEntry := by simpa using hentry + subst entry + exact hrightAnswer + have hcard := Set.encard_le_encard hsubset + rw [Set.encard_pair hentryNe] at hcard + simpa only [QueryCache.enncard, ENat.toENNReal_ofNat] using ENat.toENNReal_mono hcard + +theorem cachedInput_ne_of_position_ne + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (cache : QueryCache HashSpec) {left right : Position} (hne : left ≠ right) : + cachedInput parameter otsSecret ftsSecret cache left ≠ + cachedInput parameter otsSecret ftsSecret cache right := by + intro hinput + have hdomain : left.domain = right.domain := + (tweakableHashInput_injective parameter left.domain_inRange right.domain_inRange + (by simpa only [cachedInput, honestInput] using hinput)).1 + exact hne (Position.domain_injective hdomain) + +namespace Concrete + +theorem numChains_le_of_root_queryBound + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (q : Nat) + (hbound : (liftM + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : + OracleComp HashSpec Digest) : OracleComp OracleWorld Digest).IsQueryBoundP + (· matches Sum.inr _) q) : + numChains ≤ q := by + let rootComputation : OracleComp HashSpec Digest := + treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) + let answerFn : QueryImpl HashSpec Id := fromCache ∅ + have hagrees : (∅ : QueryCache HashSpec).AgreesWithFn answerFn := + agreesWithFn_fromCache ∅ + obtain ⟨rootCache, hroot⟩ := + (exists_agreesWithFn_evalWithAnswerFn_eq_iff_mem_support rootComputation ∅ + (evalWithAnswerFn answerFn rootComputation)).mp ⟨answerFn, hagrees, rfl⟩ + obtain ⟨_, replayFn, hreplayAgrees, _, hcached⟩ := + exists_answerFn_replay_of_mem_support rootComputation ∅ + (evalWithAnswerFn answerFn rootComputation) rootCache hroot + let rootPosition : Position := + .node topLayer rootTree ⟨layerHeight topLayer - 1, by decide⟩ ⟨0, by positivity⟩ + have hrootSettled : Settled parameter otsSecret (fun _ _ _ => 0) rootCache rootPosition := by + exact settled_treeRoot_of_cachedRun (ftsSecret := fun _ _ _ => 0) hreplayAgrees + topLayer rootTree hcached + let leafIdx : LeafIndex := 0 + have hleafSettled : + Settled parameter otsSecret (fun _ _ _ => 0) rootCache + (.leaf topLayer rootTree leafIdx) := + (settled_tree_path_of_settled_root topLayer rootTree leafIdx (by + norm_num [leafIdx, layerHeight, topLayer, maxLayerHeight, numLayers]) hrootSettled).1 + let chainPosition : ChainIndex → Position := fun chainIdx => + .chain topLayer rootTree leafIdx chainIdx Position.lastChainStep + have hchainSettled : ∀ chainIdx, + Settled parameter otsSecret (fun _ _ _ => 0) rootCache (chainPosition chainIdx) := by + intro chainIdx + exact settled_chain_of_settled_leaf topLayer rootTree leafIdx hleafSettled chainIdx + Position.lastChainStep.val Position.lastChainStep.isLt + let chainAnswer : ChainIndex → HashOutput := fun chainIdx => + Classical.choose (Option.ne_none_iff_exists'.mp (hchainSettled chainIdx).cached) + have hchainAnswer : ∀ chainIdx, + rootCache (cachedInput parameter otsSecret (fun _ _ _ => 0) rootCache + (chainPosition chainIdx)) = some (chainAnswer chainIdx) := by + intro chainIdx + exact Classical.choose_spec (Option.ne_none_iff_exists'.mp (hchainSettled chainIdx).cached) + let chainEmbedding : (Set.univ : Set ChainIndex) ↪ rootCache.toSet := + ⟨fun chainIdx => ⟨⟨cachedInput parameter otsSecret (fun _ _ _ => 0) rootCache + (chainPosition chainIdx.1), chainAnswer chainIdx.1⟩, hchainAnswer chainIdx.1⟩, + by + intro left right heq + apply Subtype.ext + by_contra hne + have hinput := congrArg (fun entry : rootCache.toSet => entry.1.1) heq + exact cachedInput_ne_of_position_ne parameter otsSecret (fun _ _ _ => 0) rootCache + (by simpa [chainPosition, Fin.ext_iff] using hne) hinput⟩ + have hencard : (Set.univ : Set ChainIndex).encard ≤ rootCache.toSet.encard := + chainEmbedding.encard_le + have hcacheLower : (numChains : ℝ≥0∞) ≤ QueryCache.enncard rootCache := by + have huniv : (Set.univ : Set ChainIndex).encard = (numChains : ENat) := by + rw [Set.encard_univ, ENat.card_eq_coe_fintype_card, Fintype.card_fin] + have hreal := ENat.toENNReal_mono hencard + rw [huniv] at hreal + simpa only [QueryCache.enncard, ENat.toENNReal_coe] using hreal + have hrootLifted : + ((evalWithAnswerFn answerFn rootComputation, rootCache) ∈ support + ((simulateQ romImpl + (liftM rootComputation : OracleComp OracleWorld Digest)).run ∅)) := by + rw [simulateQ_romImpl_liftM] + exact hroot + have hcacheUpper : QueryCache.enncard rootCache ≤ (q : ℝ≥0∞) := + simulateQ_romImpl_enncard_le_queryBound + (liftM rootComputation : OracleComp OracleWorld Digest) q hbound + (evalWithAnswerFn answerFn rootComputation, rootCache) hrootLifted + exact_mod_cast hcacheLower.trans hcacheUpper + +theorem two_le_of_root_queryBound + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (q : Nat) + (hbound : (liftM + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : + OracleComp HashSpec Digest) : OracleComp OracleWorld Digest).IsQueryBoundP + (· matches Sum.inr _) q) : + 2 ≤ q := by + exact (show 2 ≤ numChains by norm_num [numChains]).trans + (numChains_le_of_root_queryBound parameter otsSecret q hbound) + +theorem two_le_of_hasHashQueryBound + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + 2 ≤ q := by + have hgame := isQueryBoundP_gameAfterSecrets adversary q hq hparameter hots hfts + rw [gameAfterSecrets] at hgame + exact two_le_of_root_queryBound parameter otsSecret q (IsQueryBoundP.of_bind_left hgame) + +theorem numChains_le_of_hasHashQueryBound + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + numChains ≤ q := by + have hgame := isQueryBoundP_gameAfterSecrets adversary q hq hparameter hots hfts + rw [gameAfterSecrets] at hgame + exact numChains_le_of_root_queryBound parameter otsSecret q (IsQueryBoundP.of_bind_left hgame) + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/MappedQueryCharge.lean b/formal/sphincs/SphincsSecurity/Proof/MappedQueryCharge.lean new file mode 100644 index 00000000..ec919671 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/MappedQueryCharge.lean @@ -0,0 +1,51 @@ +import SphincsSecurity.Proof.RomQueryChargeBind +import SphincsSecurity.Proof.DirectQueryBudget + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +def outerHashQueryCharge (charge : QueryCache HashSpec → HashInput → ℝ≥0∞) + (input : (OracleWorld + SigningSpec).Domain) (cache : QueryCache HashSpec) : ℝ≥0∞ := + match input with + | .inl query => hashQueryCharge charge cache query + | .inr _ => 0 + +noncomputable def expectedOuterQueryCharge + (secretKey : SecretKey) (charge : QueryCache HashSpec → HashInput → ℝ≥0∞) + (computation : OracleComp (OracleWorld + SigningSpec) α) : QueryCache HashSpec → ℝ≥0∞ := + OracleComp.construct (fun _ _ => 0) + (fun input _ next cache => outerHashQueryCharge charge input cache + + ∑' result, Pr[= result | (unloggedMappedAdversaryImpl secretKey input).run cache] * + next result.1 result.2) computation + +theorem expectedOuterQueryCharge_query_bind + (secretKey : SecretKey) (charge : QueryCache HashSpec → HashInput → ℝ≥0∞) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (cache : QueryCache HashSpec) : + expectedOuterQueryCharge secretKey charge (OracleSpec.query input >>= next) cache = + outerHashQueryCharge charge input cache + + ∑' result, Pr[= result | (unloggedMappedAdversaryImpl secretKey input).run cache] * + expectedOuterQueryCharge secretKey charge (next result.1) result.2 := rfl + +theorem expectedOuterQueryCharge_le_expanded + (secretKey : SecretKey) (charge : QueryCache HashSpec → HashInput → ℝ≥0∞) + (computation : OracleComp (OracleWorld + SigningSpec) α) (cache : QueryCache HashSpec) : + expectedOuterQueryCharge secretKey charge computation cache ≤ + expectedQueryCharge charge (simulateQ (expandedAdversaryImpl secretKey) computation) cache := by + induction computation using OracleComp.inductionOn generalizing cache with + | pure value => simp [expectedOuterQueryCharge] + | query_bind input next ih => + rw [expectedOuterQueryCharge_query_bind] + cases input with + | inl query => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, expectedQueryCharge_query_bind] + apply add_le_add le_rfl + exact ENNReal.tsum_le_tsum (fun result => mul_le_mul' le_rfl (ih result.1 result.2)) + | inr message => + rw [simulateQ_expandedAdversaryImpl_query_bind_inr, expectedQueryCharge_bind] + apply add_le_add (bot_le : (0 : ℝ≥0∞) ≤ _) + exact ENNReal.tsum_le_tsum (fun result => mul_le_mul' le_rfl (ih result.1 result.2)) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/MarginalCoupling.lean b/formal/sphincs/SphincsSecurity/Proof/MarginalCoupling.lean new file mode 100644 index 00000000..d01bd7db --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/MarginalCoupling.lean @@ -0,0 +1,578 @@ +import VCVio.ProgramLogic.Relational.Basic + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +namespace SphincsSecurity + +section GeneralFiberCoupling + +variable {α β γ : Type} [DecidableEq γ] + +noncomputable def generalFiberMass + (p : PMF α) (f : α → γ) (value : γ) : ENNReal := + ∑' candidate, if f candidate = value then p candidate else 0 + +theorem generalFiberMass_eq_map_apply + (p : PMF α) (f : α → γ) (value : γ) : + generalFiberMass p f value = p.map f value := by + rw [generalFiberMass, PMF.map_apply] + apply tsum_congr + intro candidate + by_cases heq : f candidate = value + · simp [heq] + · simp [heq, Ne.symm heq] + +noncomputable def generalFiberCouplingWeight + (p : PMF α) (q : PMF β) + (f : α → γ) (g : β → γ) (pair : α × β) : ENNReal := + if f pair.1 = g pair.2 then + p pair.1 * q pair.2 * (generalFiberMass p f (f pair.1))⁻¹ + else + 0 + +theorem generalFiberMass_ne_zero_of_apply_ne_zero + (p : PMF α) (f : α → γ) (value : α) (hvalue : p value ≠ 0) : + generalFiberMass p f (f value) ≠ 0 := by + unfold generalFiberMass + intro hzero + rw [ENNReal.tsum_eq_zero] at hzero + exact hvalue (by simpa using hzero value) + +theorem generalFiberMass_ne_top + (p : PMF α) (f : α → γ) (value : γ) : + generalFiberMass p f value ≠ ∞ := by + apply ne_top_of_le_ne_top one_ne_top + rw [generalFiberMass_eq_map_apply] + exact PMF.coe_le_one (p.map f) value + +set_option maxHeartbeats 1600000 in +theorem generalFiberCouplingWeight_sum_right + (p : PMF α) (q : PMF β) (f : α → γ) (g : β → γ) + (hmap : p.map f = q.map g) (left : α) : + ∑' right, generalFiberCouplingWeight p q f g (left, right) = + p left := by + simp only [generalFiberCouplingWeight] + calc + (∑' right, + if f left = g right then + p left * q right * (generalFiberMass p f (f left))⁻¹ + else 0) = + p left * ((∑' right, + if g right = f left then q right else 0) * + (generalFiberMass p f (f left))⁻¹) := by + calc + (∑' right, + if f left = g right then + p left * q right * (generalFiberMass p f (f left))⁻¹ + else 0) = + ∑' right, p left * + ((if g right = f left then q right else 0) * + (generalFiberMass p f (f left))⁻¹) := by + apply tsum_congr + intro right + by_cases heq : f left = g right + · rw [if_pos heq, if_pos heq.symm] + ac_rfl + · rw [if_neg heq, if_neg (Ne.symm heq)] + simp + _ = p left * ∑' right, + (if g right = f left then q right else 0) * + (generalFiberMass p f (f left))⁻¹ := + ENNReal.tsum_mul_left + _ = p left * ((∑' right, + if g right = f left then q right else 0) * + (generalFiberMass p f (f left))⁻¹) := by + rw [ENNReal.tsum_mul_right] + _ = p left * (generalFiberMass p f (f left) * + (generalFiberMass p f (f left))⁻¹) := by + congr 2 + calc + (∑' right, if g right = f left then q right else 0) = + generalFiberMass q g (f left) := rfl + _ = q.map g (f left) := generalFiberMass_eq_map_apply q g (f left) + _ = p.map f (f left) := by rw [hmap] + _ = generalFiberMass p f (f left) := + (generalFiberMass_eq_map_apply p f (f left)).symm + _ = p left := by + by_cases hleft : p left = 0 + · simp [hleft] + · rw [ENNReal.mul_inv_cancel + (generalFiberMass_ne_zero_of_apply_ne_zero p f left hleft) + (generalFiberMass_ne_top p f (f left)), mul_one] + +set_option maxHeartbeats 1600000 in +theorem generalFiberCouplingWeight_sum_left + (p : PMF α) (q : PMF β) (f : α → γ) (g : β → γ) + (hmap : p.map f = q.map g) (right : β) : + ∑' left, generalFiberCouplingWeight p q f g (left, right) = + q right := by + simp only [generalFiberCouplingWeight] + calc + (∑' left, + if f left = g right then + p left * q right * (generalFiberMass p f (f left))⁻¹ + else 0) = + q right * ((∑' left, + if f left = g right then p left else 0) * + (generalFiberMass p f (g right))⁻¹) := by + calc + (∑' left, + if f left = g right then + p left * q right * (generalFiberMass p f (f left))⁻¹ + else 0) = + ∑' left, q right * + ((if f left = g right then p left else 0) * + (generalFiberMass p f (g right))⁻¹) := by + apply tsum_congr + intro left + by_cases heq : f left = g right + · rw [if_pos heq, if_pos heq, heq] + ac_rfl + · simp [heq] + _ = q right * ∑' left, + (if f left = g right then p left else 0) * + (generalFiberMass p f (g right))⁻¹ := + ENNReal.tsum_mul_left + _ = q right * ((∑' left, + if f left = g right then p left else 0) * + (generalFiberMass p f (g right))⁻¹) := by + rw [ENNReal.tsum_mul_right] + _ = q right * (generalFiberMass q g (g right) * + (generalFiberMass q g (g right))⁻¹) := by + have hmass : generalFiberMass p f (g right) = + generalFiberMass q g (g right) := + (generalFiberMass_eq_map_apply p f (g right)).trans + ((by rw [hmap]) : p.map f (g right) = q.map g (g right)) |>.trans + (generalFiberMass_eq_map_apply q g (g right)).symm + rw [show (∑' left, if f left = g right then p left else 0) = + generalFiberMass p f (g right) from rfl, hmass] + _ = q right := by + by_cases hright : q right = 0 + · simp [hright] + · rw [ENNReal.mul_inv_cancel + (generalFiberMass_ne_zero_of_apply_ne_zero q g right hright) + (generalFiberMass_ne_top q g (g right)), mul_one] + +set_option maxHeartbeats 1600000 in +theorem generalFiberCouplingWeight_sum_eq_one + (p : PMF α) (q : PMF β) (f : α → γ) (g : β → γ) + (hmap : p.map f = q.map g) : + ∑' pair, generalFiberCouplingWeight p q f g pair = 1 := by + calc + (∑' pair : α × β, generalFiberCouplingWeight p q f g pair) = + ∑' left, ∑' right, + generalFiberCouplingWeight p q f g (left, right) := + by + rw [← ENNReal.tsum_prod] + _ = ∑' left, p left := by + simp_rw [generalFiberCouplingWeight_sum_right p q f g hmap] + _ = 1 := p.tsum_coe + +noncomputable def generalFiberCoupling + (p : PMF α) (q : PMF β) (f : α → γ) (g : β → γ) + (hmap : p.map f = q.map g) : PMF (α × β) := + PMF.normalize (generalFiberCouplingWeight p q f g) + (by rw [generalFiberCouplingWeight_sum_eq_one p q f g hmap]; exact one_ne_zero) + (by rw [generalFiberCouplingWeight_sum_eq_one p q f g hmap]; exact one_ne_top) + +@[simp] +theorem generalFiberCoupling_apply + (p : PMF α) (q : PMF β) (f : α → γ) (g : β → γ) + (hmap : p.map f = q.map g) (pair : α × β) : + generalFiberCoupling p q f g hmap pair = + generalFiberCouplingWeight p q f g pair := by + unfold generalFiberCoupling + rw [PMF.normalize_apply, + generalFiberCouplingWeight_sum_eq_one p q f g hmap] + simp + +theorem generalFiberCoupling_isCoupling + (p : PMF α) (q : PMF β) (f : α → γ) (g : β → γ) + (hmap : p.map f = q.map g) : + PMF.IsCoupling (generalFiberCoupling p q f g hmap) p q := by + classical + constructor + · ext left + rw [PMF.map_apply] + change (∑' pair : α × β, + (fun candidate right => if left = candidate then + generalFiberCoupling p q f g hmap (candidate, right) else 0) + pair.1 pair.2) = p left + calc + (∑' pair : α × β, + (fun candidate right => if left = candidate then + generalFiberCoupling p q f g hmap (candidate, right) else 0) + pair.1 pair.2) = + ∑' candidate, ∑' right, + if left = candidate then + generalFiberCoupling p q f g hmap (candidate, right) else 0 := by + rw [← ENNReal.tsum_prod] + _ = (∑' candidate, ∑' right, + if left = candidate then + generalFiberCouplingWeight p q f g (candidate, right) else 0) := by + simp only [generalFiberCoupling_apply] + _ = + ∑' right, generalFiberCouplingWeight p q f g (left, right) := by + calc + (∑' candidate, ∑' right, + if left = candidate then + generalFiberCouplingWeight p q f g (candidate, right) else 0) = + ∑' candidate, if candidate = left then + (∑' right, + generalFiberCouplingWeight p q f g (candidate, right)) else 0 := by + apply tsum_congr + intro candidate + by_cases heq : candidate = left + · subst candidate + simp + · simp [heq, Ne.symm heq] + _ = ∑' right, + generalFiberCouplingWeight p q f g (left, right) := + tsum_ite_eq left _ + _ = p left := generalFiberCouplingWeight_sum_right p q f g hmap left + · ext right + rw [PMF.map_apply] + change (∑' pair : α × β, + (fun left candidate => if right = candidate then + generalFiberCoupling p q f g hmap (left, candidate) else 0) + pair.1 pair.2) = q right + calc + (∑' pair : α × β, + (fun left candidate => if right = candidate then + generalFiberCoupling p q f g hmap (left, candidate) else 0) + pair.1 pair.2) = + ∑' left, ∑' candidate, + if right = candidate then + generalFiberCoupling p q f g hmap (left, candidate) else 0 := by + rw [← ENNReal.tsum_prod] + _ = (∑' left, ∑' candidate, + if right = candidate then + generalFiberCouplingWeight p q f g (left, candidate) else 0) := by + simp only [generalFiberCoupling_apply] + _ = + ∑' left, generalFiberCouplingWeight p q f g (left, right) := by + apply tsum_congr + intro left + convert tsum_ite_eq right + (fun candidate => generalFiberCouplingWeight p q f g (left, candidate)) + using 1 + apply tsum_congr + intro candidate + by_cases heq : candidate = right + · simp [heq] + · simp [heq, Ne.symm heq] + _ = q right := generalFiberCouplingWeight_sum_left p q f g hmap right + +end GeneralFiberCoupling + +section GeneralRelTriple + +variable {ι₁ ι₂ : Type} {spec₁ : OracleSpec ι₁} {spec₂ : OracleSpec ι₂} + [IsUniformSpec spec₁] [IsUniformSpec spec₂] + {α β γ : Type} [DecidableEq γ] + +noncomputable def generalSuccessPMF + (p : SPMF α) (hfail : p.toPMF none = 0) : PMF α := + PMF.normalize p + (by + have hmass := p.tsum_run_some_eq_one_sub + rw [hfail, tsub_zero] at hmass + have hmass' : (∑' value, p value) = 1 := by + simpa only [SPMF.apply_eq_toPMF_some] using hmass + rw [hmass'] + exact one_ne_zero) + (by + have hmass := p.tsum_run_some_eq_one_sub + rw [hfail, tsub_zero] at hmass + have hmass' : (∑' value, p value) = 1 := by + simpa only [SPMF.apply_eq_toPMF_some] using hmass + rw [hmass'] + exact one_ne_top) + +@[simp] +theorem generalSuccessPMF_apply + (p : SPMF α) (hfail : p.toPMF none = 0) (value : α) : + generalSuccessPMF p hfail value = p value := by + have hmass := p.tsum_run_some_eq_one_sub + rw [hfail, tsub_zero] at hmass + have hmass' : (∑' candidate, p candidate) = 1 := by + simpa only [SPMF.apply_eq_toPMF_some] using hmass + rw [generalSuccessPMF, PMF.normalize_apply, hmass'] + simp + +theorem liftM_generalSuccessPMF_eq + (p : SPMF α) (hfail : p.toPMF none = 0) : + (liftM (generalSuccessPMF p hfail) : SPMF α) = p := by + apply SPMF.ext + intro value + simp + +theorem generalSuccessPMF_map_eq_of_spmf_map_eq + (left : SPMF α) (right : SPMF β) + (f : α → γ) (g : β → γ) + (hleft : left.toPMF none = 0) (hright : right.toPMF none = 0) + (hmap : f <$> left = g <$> right) : + (generalSuccessPMF left hleft).map f = + (generalSuccessPMF right hright).map g := by + have hlift : + (liftM ((generalSuccessPMF left hleft).map f) : SPMF γ) = + f <$> left := by + calc + (liftM ((generalSuccessPMF left hleft).map f) : SPMF γ) = + f <$> (liftM (generalSuccessPMF left hleft) : SPMF α) := + liftM_map f (generalSuccessPMF left hleft) + _ = f <$> left := by rw [liftM_generalSuccessPMF_eq] + have hrightLift : + (liftM ((generalSuccessPMF right hright).map g) : SPMF γ) = + g <$> right := by + calc + (liftM ((generalSuccessPMF right hright).map g) : SPMF γ) = + g <$> (liftM (generalSuccessPMF right hright) : SPMF β) := + liftM_map g (generalSuccessPMF right hright) + _ = g <$> right := by rw [liftM_generalSuccessPMF_eq] + have hspmf : + (liftM ((generalSuccessPMF left hleft).map f) : SPMF γ) = + liftM ((generalSuccessPMF right hright).map g) := + hlift.trans (hmap.trans hrightLift.symm) + apply PMF.ext + intro value + have hpoint : + (liftM ((generalSuccessPMF left hleft).map f) : SPMF γ) value = + (liftM ((generalSuccessPMF right hright).map g) : SPMF γ) value := by + rw [hspmf] + simpa using hpoint + +noncomputable def generalMarginalCoupling + (oa : OracleComp spec₁ α) (ob : OracleComp spec₂ β) + (f : α → γ) (g : β → γ) + (hmap : 𝒟[f <$> oa] = 𝒟[g <$> ob]) : SPMF (α × β) := + let left := 𝒟[oa] + let right := 𝒟[ob] + let hleft : left.toPMF none = 0 := probFailure_eq_zero (mx := oa) + let hright : right.toPMF none = 0 := probFailure_eq_zero (mx := ob) + let hPMFMap : (generalSuccessPMF left hleft).map f = + (generalSuccessPMF right hright).map g := + generalSuccessPMF_map_eq_of_spmf_map_eq left right f g hleft hright (by + simpa [evalDist_map] using hmap) + liftM (generalFiberCoupling + (generalSuccessPMF left hleft) (generalSuccessPMF right hright) + f g hPMFMap) + +theorem generalMarginalCoupling_isCoupling + (oa : OracleComp spec₁ α) (ob : OracleComp spec₂ β) + (f : α → γ) (g : β → γ) + (hmap : 𝒟[f <$> oa] = 𝒟[g <$> ob]) : + SPMF.IsCoupling (generalMarginalCoupling oa ob f g hmap) 𝒟[oa] 𝒟[ob] := by + let left := 𝒟[oa] + let right := 𝒟[ob] + let hleft : left.toPMF none = 0 := probFailure_eq_zero (mx := oa) + let hright : right.toPMF none = 0 := probFailure_eq_zero (mx := ob) + let hPMFMap : (generalSuccessPMF left hleft).map f = + (generalSuccessPMF right hright).map g := + generalSuccessPMF_map_eq_of_spmf_map_eq left right f g hleft hright (by + simpa [evalDist_map] using hmap) + have hcoupling := generalFiberCoupling_isCoupling + (generalSuccessPMF left hleft) (generalSuccessPMF right hright) f g hPMFMap + constructor + · change Prod.fst <$> (liftM (generalFiberCoupling + (generalSuccessPMF left hleft) (generalSuccessPMF right hright) + f g hPMFMap) : SPMF (α × β)) = left + rw [← liftM_map] + have hfst : Prod.fst <$> (generalFiberCoupling + (generalSuccessPMF left hleft) (generalSuccessPMF right hright) + f g hPMFMap) = generalSuccessPMF left hleft := hcoupling.map_fst + rw [hfst, liftM_generalSuccessPMF_eq] + · change Prod.snd <$> (liftM (generalFiberCoupling + (generalSuccessPMF left hleft) (generalSuccessPMF right hright) + f g hPMFMap) : SPMF (α × β)) = right + rw [← liftM_map] + have hsnd : Prod.snd <$> (generalFiberCoupling + (generalSuccessPMF left hleft) (generalSuccessPMF right hright) + f g hPMFMap) = generalSuccessPMF right hright := hcoupling.map_snd + rw [hsnd, liftM_generalSuccessPMF_eq] + +theorem generalMarginalCoupling_support_eq + (oa : OracleComp spec₁ α) (ob : OracleComp spec₂ β) + (f : α → γ) (g : β → γ) + (hmap : 𝒟[f <$> oa] = 𝒟[g <$> ob]) + (pair : α × β) + (hpair : pair ∈ support (generalMarginalCoupling oa ob f g hmap)) : + f pair.1 = g pair.2 := by + let left := 𝒟[oa] + let right := 𝒟[ob] + let hleft : left.toPMF none = 0 := probFailure_eq_zero (mx := oa) + let hright : right.toPMF none = 0 := probFailure_eq_zero (mx := ob) + let hPMFMap : (generalSuccessPMF left hleft).map f = + (generalSuccessPMF right hright).map g := + generalSuccessPMF_map_eq_of_spmf_map_eq left right f g hleft hright (by + simpa [evalDist_map] using hmap) + change pair ∈ support (liftM (generalFiberCoupling + (generalSuccessPMF left hleft) (generalSuccessPMF right hright) + f g hPMFMap)) at hpair + have hpair' : (generalFiberCoupling + (generalSuccessPMF left hleft) (generalSuccessPMF right hright) + f g hPMFMap) pair ≠ 0 := by + have hne : (liftM (generalFiberCoupling + (generalSuccessPMF left hleft) (generalSuccessPMF right hright) + f g hPMFMap) : SPMF (α × β)) pair ≠ 0 := + (SPMF.mem_support_iff _ _).mp hpair + simpa using hne + rw [generalFiberCoupling_apply] at hpair' + unfold generalFiberCouplingWeight at hpair' + split at hpair' + · assumption + · exact (hpair' rfl).elim + +theorem generalMarginalCoupling_support_marginals + (oa : OracleComp spec₁ α) (ob : OracleComp spec₂ β) + (f : α → γ) (g : β → γ) + (hmap : 𝒟[f <$> oa] = 𝒟[g <$> ob]) + (pair : α × β) + (hpair : pair ∈ support (generalMarginalCoupling oa ob f g hmap)) : + pair.1 ∈ support oa ∧ pair.2 ∈ support ob := by + have hcoupling := generalMarginalCoupling_isCoupling oa ob f g hmap + constructor + · have hmapped : pair.1 ∈ support + (Prod.fst <$> generalMarginalCoupling oa ob f g hmap) := by + rw [support_map] + exact ⟨pair, hpair, rfl⟩ + rw [hcoupling.map_fst] at hmapped + rw [mem_support_iff_evalDist_apply_ne_zero] + exact (SPMF.mem_support_iff _ _).mp hmapped + · have hmapped : pair.2 ∈ support + (Prod.snd <$> generalMarginalCoupling oa ob f g hmap) := by + rw [support_map] + exact ⟨pair, hpair, rfl⟩ + rw [hcoupling.map_snd] at hmapped + rw [mem_support_iff_evalDist_apply_ne_zero] + exact (SPMF.mem_support_iff _ _).mp hmapped + +theorem relTriple_of_evalDist_map_eq_general + (oa : OracleComp spec₁ α) (ob : OracleComp spec₂ β) + (f : α → γ) (g : β → γ) + (hmap : 𝒟[f <$> oa] = 𝒟[g <$> ob]) : + RelTriple oa ob (fun left right => f left = g right) := by + rw [relTriple_iff_relWP] + refine ⟨⟨generalMarginalCoupling oa ob f g hmap, + generalMarginalCoupling_isCoupling oa ob f g hmap⟩, ?_⟩ + intro pair hpair + exact generalMarginalCoupling_support_eq oa ob f g hmap pair hpair + +theorem relTriple_of_evalDist_map_eq_with_support_general + (oa : OracleComp spec₁ α) (ob : OracleComp spec₂ β) + (f : α → γ) (g : β → γ) + (hmap : 𝒟[f <$> oa] = 𝒟[g <$> ob]) : + RelTriple oa ob (fun left right => + f left = g right ∧ left ∈ support oa ∧ right ∈ support ob) := by + rw [relTriple_iff_relWP] + refine ⟨⟨generalMarginalCoupling oa ob f g hmap, + generalMarginalCoupling_isCoupling oa ob f g hmap⟩, ?_⟩ + intro pair hpair + exact ⟨generalMarginalCoupling_support_eq oa ob f g hmap pair hpair, + generalMarginalCoupling_support_marginals oa ob f g hmap pair hpair⟩ + +theorem relTriple_trans_exists + {ι₃ : Type} {spec₃ : OracleSpec ι₃} [IsUniformSpec spec₃] + {δ : Type} {oc : OracleComp spec₃ δ} + {oa : OracleComp spec₁ α} {ob : OracleComp spec₂ β} + {R : α → β → Prop} {S : β → δ → Prop} + (hab : RelTriple oa ob R) (hbc : RelTriple ob oc S) : + RelTriple oa oc (fun a c => ∃ b, R a b ∧ S b c) := by + classical + letI : DecidableEq β := Classical.decEq β + rw [relTriple_iff_relWP] at hab hbc ⊢ + obtain ⟨cab, hR⟩ := hab + obtain ⟨cbc, hS⟩ := hbc + have hcabFail : cab.1.toPMF none = 0 := by + have hmap := cab.2.map_fst + rw [SPMF.fmap_eq_map] at hmap + change PMF.map (Option.map Prod.fst) cab.1.toPMF = + (evalDist oa).toPMF at hmap + have h := congrArg (fun p : PMF (Option α) => p none) hmap + rw [PMF.map_apply] at h + simpa using h.trans (probFailure_eq_zero (mx := oa)) + have hcbcFail : cbc.1.toPMF none = 0 := by + have hmap := cbc.2.map_fst + rw [SPMF.fmap_eq_map] at hmap + change PMF.map (Option.map Prod.fst) cbc.1.toPMF = + (evalDist ob).toPMF at hmap + have h := congrArg (fun p : PMF (Option β) => p none) hmap + rw [PMF.map_apply] at h + simpa using h.trans (probFailure_eq_zero (mx := ob)) + let p := generalSuccessPMF cab.1 hcabFail + let q := generalSuccessPMF cbc.1 hcbcFail + have hmiddle : p.map Prod.snd = q.map Prod.fst := by + apply generalSuccessPMF_map_eq_of_spmf_map_eq + exact cab.2.map_snd.trans cbc.2.map_fst.symm + let d := generalFiberCoupling p q Prod.snd Prod.fst hmiddle + let project : (α × β) × (β × δ) → α × δ := + fun pair => (pair.1.1, pair.2.2) + let c : SPMF (α × δ) := liftM (d.map project) + have hd : PMF.IsCoupling d p q := by + simpa [d] using generalFiberCoupling_isCoupling p q Prod.snd Prod.fst hmiddle + refine ⟨⟨c, ?_, ?_⟩, ?_⟩ + · dsimp only [c] + rw [← liftM_map] + change liftM ((d.map project).map Prod.fst) = _ + rw [PMF.map_comp] + change liftM (d.map (Prod.fst ∘ Prod.fst)) = _ + rw [← PMF.map_comp, hd.map_fst] + change liftM ((generalSuccessPMF cab.1 hcabFail).map Prod.fst) = _ + calc + liftM ((generalSuccessPMF cab.1 hcabFail).map Prod.fst) = + Prod.fst <$> (liftM (generalSuccessPMF cab.1 hcabFail) : SPMF (α × β)) := + liftM_map Prod.fst (generalSuccessPMF cab.1 hcabFail) + _ = Prod.fst <$> cab.1 := by rw [liftM_generalSuccessPMF_eq] + _ = evalDist oa := cab.2.map_fst + · dsimp only [c] + rw [← liftM_map] + change liftM ((d.map project).map Prod.snd) = _ + rw [PMF.map_comp] + change liftM (d.map (Prod.snd ∘ Prod.snd)) = _ + rw [← PMF.map_comp, hd.map_snd] + change liftM ((generalSuccessPMF cbc.1 hcbcFail).map Prod.snd) = _ + calc + liftM ((generalSuccessPMF cbc.1 hcbcFail).map Prod.snd) = + Prod.snd <$> (liftM (generalSuccessPMF cbc.1 hcbcFail) : SPMF (β × δ)) := + liftM_map Prod.snd (generalSuccessPMF cbc.1 hcbcFail) + _ = Prod.snd <$> cbc.1 := by rw [liftM_generalSuccessPMF_eq] + _ = evalDist oc := cbc.2.map_snd + · intro pair hpair + change pair ∈ support (liftM (d.map project) : SPMF (α × δ)) at hpair + change pair ∈ (liftM (d.map project) : SPMF (α × δ)).support at hpair + rw [SPMF.support_liftM, PMF.mem_support_map_iff] at hpair + obtain ⟨z, hz, hproject⟩ := hpair + have hweight : generalFiberCouplingWeight p q Prod.snd Prod.fst z ≠ 0 := by + simpa [d, generalFiberCoupling_apply] using + (PMF.mem_support_iff d z).1 hz + have heq : z.1.2 = z.2.1 := by + unfold generalFiberCouplingWeight at hweight + split at hweight + · assumption + · exact (hweight rfl).elim + have hp : p z.1 ≠ 0 := by + intro hpzero + apply hweight + simp [generalFiberCouplingWeight, heq, hpzero] + have hq : q z.2 ≠ 0 := by + intro hqzero + apply hweight + simp [generalFiberCouplingWeight, heq, hqzero] + have hzLeft : z.1 ∈ support cab.1 := by + change z.1 ∈ SPMF.support cab.1 + apply (SPMF.mem_support_iff cab.1 z.1).2 + simpa [p] using hp + have hzRight : z.2 ∈ support cbc.1 := by + change z.2 ∈ SPMF.support cbc.1 + apply (SPMF.mem_support_iff cbc.1 z.2).2 + simpa [q] using hq + have hleft := hR z.1 hzLeft + have hright := hS z.2 hzRight + obtain ⟨rfl, rfl⟩ := hproject + exact ⟨z.1.2, hleft, heq ▸ hright⟩ + +end GeneralRelTriple + + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Merkle.lean b/formal/sphincs/SphincsSecurity/Proof/Merkle.lean new file mode 100644 index 00000000..9fde5ed3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Merkle.lean @@ -0,0 +1,44 @@ +import SphincsSecurity.Proof.Arith +import SphincsSecurity.Proof.Eval +import SphincsSecurity.Proof.StatementLemmas + +/-! +# A layer's tree + +`Tree.fold` on the siblings of a leaf reaches the node the tree builds above it: at each level the +current value and the sibling are the two children of the node one level up, and the bit of the leaf +index that the fold tests is exactly which of them is the left child. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp + +variable (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) (leaf : LeafIndex) + +/-- **Merkle correctness.** Folding a leaf with its siblings reproduces the tree, at every height. -/ +theorem eval_treeFold (levels : Nat) : + evalWithAnswerFn f (treeFold parameter lay tree leaf + (fun level => evalWithAnswerFn f (treeNode parameter lay tree secret level + (Nat.xor (leaf.val / 2 ^ level) 1))) + levels (evalWithAnswerFn f (treeNode parameter lay tree secret 0 leaf.val))) + = evalWithAnswerFn f (treeNode parameter lay tree secret levels (leaf.val / 2 ^ levels)) := by + induction levels with + | zero => simp + | succ levels ih => + obtain ⟨j, hcase⟩ := index_sibling_cases (leaf.val / 2 ^ levels) + have hj : leaf.val / 2 ^ (levels + 1) = j := by + rw [div_pow_succ] + rcases hcase with ⟨hc, _, _⟩ | ⟨hc, _, _⟩ <;> omega + rw [treeFold_succ_eq, treeNode_succ_eq, evalWithAnswerFn_bind, ih, hj, + evalWithAnswerFn_bind, evalWithAnswerFn_bind] + rcases hcase with ⟨hc, hsibling, hmod⟩ | ⟨hc, hsibling, hmod⟩ + · have hbit : leaf.val.testBit levels = false := by + rw [Bool.eq_false_iff, ne_eq, testBit_iff_div_mod]; omega + rw [hbit, if_neg (by simp), hc, xor_one_two_mul] + · have hbit : leaf.val.testBit levels = true := by + rw [testBit_iff_div_mod]; omega + rw [hbit, if_pos rfl, hc, xor_one_two_mul_add_one] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/MessageCollision.lean b/formal/sphincs/SphincsSecurity/Proof/MessageCollision.lean new file mode 100644 index 00000000..90b885d4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/MessageCollision.lean @@ -0,0 +1,1506 @@ +import SphincsSecurity.Proof.TerminalSampling + +/-! +# Message-digest collision witnesses + +A message-digest collision supplies one successful signer whose complete digest is the forged +digest. That signer alone is therefore a few-time cover. The distinct digest inputs make the +cover compatible with the existing target monitor. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +noncomputable def singletonOriginUnionBound (signatures sources : Nat) : ℝ≥0∞ := + ∑ pattern : FewTimePattern signatures 1, + ∑ configuration : OriginConfiguration pattern sources, + Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] + +theorem singletonOriginUnionBound_eq (signatures sources : Nat) : + singletonOriginUnionBound signatures sources = + ∑ pattern : FewTimePattern signatures 1, + originChoiceMass pattern.selected sources + ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ * + ((2 ^ 166 : Nat) : ℝ≥0∞)⁻¹ := by + classical + rw [singletonOriginUnionBound] + apply Finset.sum_congr rfl + intro pattern _ + rw [sum_probEvent_originConfiguration_hit pattern] + norm_num [totalHeight, ftsTreeHeight, ftsTrees] + +theorem singletonOriginUnionBound_le_inv (q : Nat) (hq : q ≤ 2 ^ 120) : + singletonOriginUnionBound signatureLimit q ≤ + ((2 ^ 141 : Nat) : ℝ≥0∞)⁻¹ := by + classical + rw [singletonOriginUnionBound_eq] + calc + (∑ pattern : FewTimePattern signatureLimit 1, + originChoiceMass pattern.selected q ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ * + ((2 ^ 166 : Nat) : ℝ≥0∞)⁻¹) ≤ + ∑ _pattern : FewTimePattern signatureLimit 1, + 2 * ((2 ^ 166 : Nat) : ℝ≥0∞)⁻¹ := by + apply Finset.sum_le_sum + intro pattern _ + have hmass := pattern.originChoiceMass_le_two hq (by decide) + simpa only [mul_comm] using + (mul_le_mul_left hmass ((2 ^ 166 : Nat) : ℝ≥0∞)⁻¹) + _ = (Fintype.card (FewTimePattern signatureLimit 1) : ℝ≥0∞) * + (2 * ((2 ^ 166 : Nat) : ℝ≥0∞)⁻¹) := by + simp only [Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + _ = ((2 ^ 141 : Nat) : ℝ≥0∞)⁻¹ := by + have hcard : Fintype.card (FewTimePattern signatureLimit 1) = signatureLimit := by + simp [fewTimePattern_card] + rw [hcard, signatureLimit] + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_natCast] + norm_num + +theorem probEvent_exists_singletonOriginConfiguration_fixedOrdinal_viewedEvent_le + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q : Nat) + (hq : q ≤ 2 ^ 120) (hcache : QueryCache.enncard initialCache ≤ q) + (candidates : Nat) + (viewedEvent : ∀ pattern : FewTimePattern signatures 1, + OriginConfiguration pattern sources → Fin candidates → + α × ViewedFullTraceState → Prop) + (himp : ∀ (pattern : FewTimePattern signatures 1) + (configuration : OriginConfiguration pattern sources) (candidate : Fin candidates) + (result : α × OriginTargetMonitorState configuration), + result ∈ support + ((simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey candidate.val) + computation).run (OriginTargetMonitorState.initial configuration initialCache)) → + viewedEvent pattern configuration candidate + (result.1, result.2.origin.viewed) → + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q) : + Pr[fun result => ∃ pattern : FewTimePattern signatures 1, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent pattern configuration candidate result | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] ≤ + candidates * singletonOriginUnionBound signatures sources := by + classical + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩ + calc + Pr[fun result => ∃ pattern : FewTimePattern signatures 1, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent pattern configuration candidate result | run] = + Pr[fun result => ∃ pattern ∈ + (Finset.univ : Finset (FewTimePattern signatures 1)), + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent pattern configuration candidate result | run] := by + congr 1 + funext result + simp + _ ≤ ∑ pattern : FewTimePattern signatures 1, + Pr[fun result => + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent pattern configuration candidate result | run] := + probEvent_exists_finset_le_sum Finset.univ run fun pattern result => + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent pattern configuration candidate result + _ ≤ ∑ pattern : FewTimePattern signatures 1, + ∑ configuration : OriginConfiguration pattern sources, + Pr[fun result => ∃ candidate : Fin candidates, + viewedEvent pattern configuration candidate result | run] := by + apply Finset.sum_le_sum + intro pattern _ + calc + _ = Pr[fun result => ∃ configuration ∈ + (Finset.univ : Finset (OriginConfiguration pattern sources)), + ∃ candidate : Fin candidates, + viewedEvent pattern configuration candidate result | run] := by + congr 1 + funext result + simp + _ ≤ _ := probEvent_exists_finset_le_sum Finset.univ run fun configuration result => + ∃ candidate : Fin candidates, + viewedEvent pattern configuration candidate result + _ ≤ ∑ pattern : FewTimePattern signatures 1, + ∑ configuration : OriginConfiguration pattern sources, + candidates * Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] := by + apply Finset.sum_le_sum + intro pattern _ + apply Finset.sum_le_sum + intro configuration _ + exact probEvent_exists_fixedOrdinal_viewedEvent_le_ideal configuration secretKey + computation initialCache q hq hcache candidates + (viewedEvent pattern configuration) (himp pattern configuration) + _ = candidates * singletonOriginUnionBound signatures sources := by + rw [singletonOriginUnionBound] + simp_rw [← Finset.mul_sum] + +@[irreducible] def SomeFixedSingletonOriginTargetViewedTerminal + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q candidates : Nat) + (result : α × ViewedFullTraceState) : Prop := + ∃ pattern : FewTimePattern signatures 1, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + FixedOriginTargetViewedTerminal secretKey computation initialCache q + configuration candidate.val result + +noncomputable instance + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q candidates : Nat) : + DecidablePred (SomeFixedSingletonOriginTargetViewedTerminal secretKey computation + initialCache signatures sources q candidates) := + fun result => Classical.propDecidable + (SomeFixedSingletonOriginTargetViewedTerminal secretKey computation initialCache + signatures sources q candidates result) + +theorem probEvent_someFixedSingletonOriginTargetViewedTerminal_le + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q : Nat) + (hq : q ≤ 2 ^ 120) (hcache : QueryCache.enncard initialCache ≤ q) + (candidates : Nat) : + Pr[SomeFixedSingletonOriginTargetViewedTerminal secretKey computation initialCache + signatures sources q candidates | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] ≤ + candidates * singletonOriginUnionBound signatures sources := by + unfold SomeFixedSingletonOriginTargetViewedTerminal + apply probEvent_exists_singletonOriginConfiguration_fixedOrdinal_viewedEvent_le + secretKey computation initialCache signatures sources q hq hcache candidates + (fun _ configuration candidate => + FixedOriginTargetViewedTerminal secretKey computation initialCache q + configuration candidate.val) + intro pattern configuration candidate result hresult hevent + obtain ⟨hcacheFinal, hterminal⟩ := hevent + obtain ⟨hcomplete, hhit⟩ := hterminal result hresult rfl + exact ⟨hcomplete, hhit, hcacheFinal⟩ + +@[irreducible] def SomeFixedOneOriginTargetViewedTerminal + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q candidates : Nat) + (result : α × ViewedFullTraceState) : Prop := + ∃ distinct : Nat, distinct = 1 ∧ + ∃ pattern : FewTimePattern signatures distinct, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + FixedOriginTargetViewedTerminal secretKey computation initialCache q + configuration candidate.val result + +noncomputable instance + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q candidates : Nat) : + DecidablePred (SomeFixedOneOriginTargetViewedTerminal secretKey computation + initialCache signatures sources q candidates) := + fun result => Classical.propDecidable + (SomeFixedOneOriginTargetViewedTerminal secretKey computation initialCache + signatures sources q candidates result) + +theorem someFixedOneOriginTargetViewedTerminal_iff + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q candidates : Nat) + (result : α × ViewedFullTraceState) : + SomeFixedOneOriginTargetViewedTerminal secretKey computation initialCache + signatures sources q candidates result ↔ + SomeFixedSingletonOriginTargetViewedTerminal secretKey computation initialCache + signatures sources q candidates result := by + unfold SomeFixedOneOriginTargetViewedTerminal + SomeFixedSingletonOriginTargetViewedTerminal + constructor + · rintro ⟨distinct, rfl, pattern, configuration, candidate, hterminal⟩ + exact ⟨pattern, configuration, candidate, hterminal⟩ + · rintro ⟨pattern, configuration, candidate, hterminal⟩ + exact ⟨1, rfl, pattern, configuration, candidate, hterminal⟩ + +theorem probEvent_someFixedOneOriginTargetViewedTerminal_le + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q : Nat) + (hq : q ≤ 2 ^ 120) (hcache : QueryCache.enncard initialCache ≤ q) + (candidates : Nat) : + Pr[SomeFixedOneOriginTargetViewedTerminal secretKey computation initialCache + signatures sources q candidates | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] ≤ + candidates * singletonOriginUnionBound signatures sources := by + calc + _ = Pr[SomeFixedSingletonOriginTargetViewedTerminal secretKey computation initialCache + signatures sources q candidates | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] := by + congr 1 + funext result + exact propext (someFixedOneOriginTargetViewedTerminal_iff secretKey computation + initialCache signatures sources q candidates result) + _ ≤ _ := probEvent_someFixedSingletonOriginTargetViewedTerminal_le + secretKey computation initialCache signatures sources q hq hcache candidates + +theorem SuccessfulSignRun.honest_fts_at_of_digest {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} (hrun : SuccessfulSignRun f cache secretKey message signature) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest secretKey.parameter secretKey.root message signature.randomness) = digest) : + HonestFtsSignAt f cache secretKey message signature + (digestIndex digest) (digestLeaves digest) := by + obtain ⟨index, leaves, hhonest⟩ := hrun.honest_fts_at + obtain ⟨_, actualDigest, hactualDigest, _, hindex, hleaves, _⟩ := hhonest.1.extract + have hdigestEq : actualDigest = digest := hactualDigest.symm.trans hdigest + simpa only [hindex, hleaves, hdigestEq] using hhonest + +noncomputable def SuccessfulSignRun.singletonFewTimeCover {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {message : Message} {signature : Signature} + (hrun : SuccessfulSignRun f cache secretKey message signature) + (hentry : (⟨message, some signature⟩ : SigningEntry) ∈ signingLog) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest secretKey.parameter secretKey.root message signature.randomness) = digest) : + FewTimeCover f cache secretKey signingLog (digestIndex digest) (digestLeaves digest) := + ⟨fun _ => + ⟨⟨message, some signature⟩, signature, digestLeaves digest, hentry, rfl, hrun, + hrun.honest_fts_at_of_digest digest hdigest, rfl⟩⟩ + +@[simp] theorem SuccessfulSignRun.singletonFewTimeCover_entries {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {message : Message} {signature : Signature} + (hrun : SuccessfulSignRun f cache secretKey message signature) + (hentry : (⟨message, some signature⟩ : SigningEntry) ∈ signingLog) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest secretKey.parameter secretKey.root message signature.randomness) = digest) : + (hrun.singletonFewTimeCover hentry digest hdigest).entries = + {⟨message, some signature⟩} := by + classical + ext entry + simp [FewTimeCover.entries, SuccessfulSignRun.singletonFewTimeCover, SigningEntry.flat, + show Nonempty FtsTree from ⟨⟨0, by decide⟩⟩] + +@[simp] theorem SuccessfulSignRun.singletonFewTimeCover_entries_card {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {message : Message} {signature : Signature} + (hrun : SuccessfulSignRun f cache secretKey message signature) + (hentry : (⟨message, some signature⟩ : SigningEntry) ∈ signingLog) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest secretKey.parameter secretKey.root message signature.randomness) = digest) : + (hrun.singletonFewTimeCover hentry digest hdigest).entries.card = 1 := by + rw [hrun.singletonFewTimeCover_entries hentry digest hdigest] + simp + +theorem SuccessfulSignRun.singletonFewTimeCover_entryDigestInput {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {message : Message} {signature : Signature} + (hrun : SuccessfulSignRun f cache secretKey message signature) + (hentry : (⟨message, some signature⟩ : SigningEntry) ∈ signingLog) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest secretKey.parameter secretKey.root message signature.randomness) = digest) + (entry : (hrun.singletonFewTimeCover hentry digest hdigest).entries) : + (hrun.singletonFewTimeCover hentry digest hdigest).entryDigestInput entry = + tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message signature.randomness) := by + classical + simp only [FewTimeCover.entryDigestInput, SuccessfulSignRun.singletonFewTimeCover] + +theorem MessageDigestCollision.exists_singletonFewTimeCover + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} {forgery : Forgery} + (hcollision : MessageDigestCollision f cache secretKey signingLog forgery) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest secretKey.parameter secretKey.root forgery.message + forgery.signature.randomness) = digest) : + ∃ cover : FewTimeCover f cache secretKey signingLog + (digestIndex digest) (digestLeaves digest), + cover.entries.card = 1 ∧ + ∀ entry : cover.entries, + tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root forgery.message + forgery.signature.randomness) ≠ + cover.entryDigestInput entry := by + classical + obtain ⟨entry, signature, hentry, hresponse, hrun, _, hinput, heval⟩ := hcollision + have hflatEntry : (⟨entry.1, some signature⟩ : SigningEntry) ∈ signingLog := by + have hentryEq : (⟨entry.1, some signature⟩ : SigningEntry) = entry := by + cases entry with + | mk request response => + simp only at hresponse ⊢ + subst response + rfl + rw [hentryEq] + exact hentry + have hsignedDigest : evalWithAnswerFn f + (messageDigest secretKey.parameter secretKey.root entry.1 signature.randomness) = digest := + heval.trans hdigest + let cover := hrun.singletonFewTimeCover hflatEntry digest hsignedDigest + refine ⟨cover, hrun.singletonFewTimeCover_entries_card hflatEntry digest hsignedDigest, ?_⟩ + intro selected hsame + have hselectedInput : cover.entryDigestInput selected = + tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root entry.1 signature.randomness) := by + dsimp only [cover] + exact hrun.singletonFewTimeCover_entryDigestInput hflatEntry digest hsignedDigest selected + apply hinput + exact hselectedInput.symm.trans hsame.symm + +theorem FewTimeCover.direct_target_not_configured_source_of_input_ne + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (targetInput : HashInput) + (hne : ∀ entry : cover.entries, targetInput ≠ cover.entryDigestInput entry) + {q limit : Nat} (hle : signingLog.length ≤ limit) + (configuration : OriginConfiguration (cover.pattern.pad hle) q) + (trace : FullAdversaryTrace) (hlog : trace.signing.toSigningLog = signingLog) + (hrealized : configuration.PaddedRealizedBy cover hle trace hlog) + (hvalid : trace.ValidIntervals secretKey) + (position : Fin trace.intervals.length) (output : HashOutput) + (initialCache finalCache : QueryCache HashSpec) + (hinterval : trace.intervals.get position = + ⟨.inl (.inr targetInput), output, initialCache, finalCache⟩) : + configuration.sourceAt? + (directIntervalCount (trace.intervals.take position.val)) = none := by + classical + cases hsource : configuration.sourceAt? + (directIntervalCount (trace.intervals.take position.val)) with + | none => rfl + | some selected => + exfalso + have hgood := configuration.paddedRealized_direct_good hrealized hvalid position + targetInput output initialCache finalCache hinterval + (directIntervalCount (trace.intervals.take position.val)) rfl selected hsource + apply hne (cover.paddedEntry hle selected.1) + simpa only [FewTimeCover.paddedExpectedInputs] using hgood.1 + +theorem FewTimeCover.signer_target_not_selectedAt_of_input_ne + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (state : ViewedFullTraceState) (hlog : state.trace.signing.toSigningLog = signingLog) + (hvalidViews : state.ValidViews secretKey) (hconsistent : state.trace.Consistent) + (hcaches : state.trace.signing.CachesLe cache) (hf : cache.AgreesWithFn f) + {limit : Nat} (hle : signingLog.length ≤ limit) + (position : Fin state.trace.intervals.length) (request : SignRequest) + (signature : Option Signature) (initialCache finalCache : QueryCache HashSpec) + (hinterval : state.trace.intervals.get position = + ⟨.inr request, signature, initialCache, finalCache⟩) + (targetPayload : HashInput) (output : HashOutput) + (hbefore : initialCache + (tweakableHashInput secretKey.parameter .message targetPayload) = none) + (hafter : finalCache + (tweakableHashInput secretKey.parameter .message targetPayload) = some output) + (houtput : signAttemptResultOfOutput output = some (index, targetLeaves)) + (hne : ∀ entry : cover.entries, + tweakableHashInput secretKey.parameter .message targetPayload ≠ + cover.entryDigestInput entry) : + (cover.pattern.pad hle).selectedAt? + (signerIntervalCount (state.trace.intervals.take position.val)) = none := by + classical + cases hselected : (cover.pattern.pad hle).selectedAt? + (signerIntervalCount (state.trace.intervals.take position.val)) with + | none => rfl + | some selected => + exfalso + have hrank : signerIntervalCount (state.trace.intervals.take position.val) = + selected.1.val := + ((cover.pattern.pad hle).selectedAt?_eq_some_iff _ selected).mp hselected |>.symm + have hsigner := cover.originReplayEvents_get_signer state hlog hvalidViews hconsistent + hcaches hf hle selected position request signature initialCache finalCache hinterval hrank + let entry := cover.paddedEntry hle selected + let selectedEntry := cover.select (cover.representativeTree entry) + obtain ⟨signingPosition, viewPosition, _, _, _, hviewRun⟩ := + ViewedFullTraceState.ValidViews.signer_interval hvalidViews hconsistent position + request signature initialCache finalCache hinterval + obtain ⟨randomness, hpayload, _, hrandomness⟩ := + signingCacheEntry_validView_fresh_admissible_transition_view hviewRun targetPayload + output index targetLeaves hbefore hafter houtput + have hfields := cover.cacheEntry_request_signature state.trace.signing hlog entry + have hrequest : request = selectedEntry.entry.1 := by + calc + request = (cover.cacheEntry state.trace.signing hlog entry).request := + congrArg SigningCacheEntry.request hsigner.2 + _ = selectedEntry.entry.1 := hfields.1 + have hsignature : signature = some selectedEntry.signature := by + calc + signature = (cover.cacheEntry state.trace.signing hlog entry).signature := + congrArg SigningCacheEntry.signature hsigner.2 + _ = some selectedEntry.signature := hfields.2 + have hrandomness' : randomness = selectedEntry.signature.randomness := + hrandomness selectedEntry.signature hsignature + apply hne entry + apply congrArg (tweakableHashInput secretKey.parameter .message) + rw [hpayload, hrequest, hrandomness'] + +theorem FewTimeCover.target_source_interval_allowed_of_input_ne + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} {index : Index} + {targetLeaves : DigestTree → FtsLeaf} + (cover : FewTimeCover f cache secretKey signingLog index targetLeaves) + (targetPayload : HashInput) + (hne : ∀ entry : cover.entries, + tweakableHashInput secretKey.parameter .message targetPayload ≠ + cover.entryDigestInput entry) + (state : ViewedFullTraceState) (hlog : state.trace.signing.toSigningLog = signingLog) + (hvalidViews : state.ValidViews secretKey) (hconsistent : state.trace.Consistent) + (hcaches : state.trace.signing.CachesLe cache) (hf : cache.AgreesWithFn f) + {q limit : Nat} (hle : signingLog.length ≤ limit) + (configuration : OriginConfiguration (cover.pattern.pad hle) q) + (hrealized : configuration.PaddedRealizedBy cover hle state.trace hlog) + (hvalidIntervals : state.trace.ValidIntervals secretKey) + (position : Fin state.trace.intervals.length) (output : HashOutput) + (hbefore : (state.trace.intervals.get position).initialCache + (tweakableHashInput secretKey.parameter .message targetPayload) = none) + (hafter : (state.trace.intervals.get position).finalCache + (tweakableHashInput secretKey.parameter .message targetPayload) = some output) + (houtput : signAttemptResultOfOutput output = some (index, targetLeaves)) + (hkind : (state.trace.intervals.get position).input = .inl (.inr + (tweakableHashInput secretKey.parameter .message targetPayload)) ∨ + ∃ request, (state.trace.intervals.get position).input = .inr request) : + targetCandidateIntervalAllowed configuration state position = true := by + let entry := state.trace.intervals.get position + have hentry : state.trace.intervals.get position = entry := rfl + rcases entry with ⟨entryInput, entryOutput, initialCache, finalCache⟩ + rw [hentry] at hbefore hafter hkind + rcases hkind with hdirect | ⟨request, hsigner⟩ + · change entryInput = .inl (.inr + (tweakableHashInput secretKey.parameter .message targetPayload)) at hdirect + subst entryInput + have hnone := cover.direct_target_not_configured_source_of_input_ne + (tweakableHashInput secretKey.parameter .message targetPayload) hne hle + configuration state.trace hlog hrealized hvalidIntervals position entryOutput + initialCache finalCache hentry + have hinputElem : state.trace.intervals[position.val].input = .inl (.inr + (tweakableHashInput secretKey.parameter .message targetPayload)) := by + simpa only [List.get_eq_getElem] using congrArg AdversaryCacheEntry.input hentry + simp [targetCandidateIntervalAllowed, hinputElem, hnone] + · change entryInput = .inr request at hsigner + subst entryInput + have hnone := cover.signer_target_not_selectedAt_of_input_ne state hlog hvalidViews + hconsistent hcaches hf hle position request entryOutput initialCache finalCache hentry + targetPayload output (by simpa using hbefore) (by simpa using hafter) + (by simpa using houtput) hne + have hinputElem : state.trace.intervals[position.val].input = .inr request := by + simpa only [List.get_eq_getElem] using congrArg AdversaryCacheEntry.input hentry + simp [targetCandidateIntervalAllowed, hinputElem, hnone] + +theorem OriginConfiguration.target_monitored_complete_of_projection_for_cover + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (cover : FewTimeCover f result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest)) + {limit sources : Nat} (hle : result.2.trace.signing.toSigningLog.length ≤ limit) + (configuration : OriginConfiguration (cover.pattern.pad hle) sources) + (hrealized : configuration.PaddedRealizedBy cover hle result.2.trace rfl) + (source : Fin result.2.trace.intervals.length) + (hcandidate : FreshTargetCandidate + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + (result.2.trace.intervals.get source)) + (hsourceView : targetCandidateIntervalView result.2 source = + fewTimeTargetView (digestIndex digest) (digestLeaves digest)) + (hallowed : targetCandidateIntervalAllowed configuration result.2 source = true) + (targetOrdinal : Nat) + (htargetOrdinal : targetOrdinal = result.2.trace.intervals.countPBefore + (fun entry => decide (FreshTargetCandidate + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ entry)) source.val) + (rootCache : QueryCache HashSpec) + (monitored : Forgery × OriginTargetMonitorState configuration) + (hmonitored : monitored ∈ support + ((simulateQ + (originTargetMonitoredAdversaryImpl configuration + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ targetOrdinal) + (adversary.main ⟨result.1.1, parameter⟩)).run + (OriginTargetMonitorState.initial configuration rootCache))) + (htrace : result.2.trace = monitored.2.origin.viewed.trace) + (hviews : result.2.views = monitored.2.origin.viewed.views) : + monitored.2.Complete ∧ + ∀ target, monitored.2.targetView = some target → + FixedFewTimePatternHit (cover.pattern.pad hle).assignment + (monitored.2.origin.observation.views, target) := by + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + let monitoredPosition := castTracePosition result.2 monitored.2.origin.viewed + htrace source + have hcandidateMonitored : FreshTargetCandidate secretKey + (monitored.2.origin.viewed.trace.intervals.get monitoredPosition) := by + rw [get_castTracePosition result.2 monitored.2.origin.viewed htrace source] + exact hcandidate + have hviewMonitored : targetCandidateIntervalView monitored.2.origin.viewed + monitoredPosition = fewTimeTargetView (digestIndex digest) (digestLeaves digest) := by + rw [targetCandidateIntervalView_castTracePosition result.2 + monitored.2.origin.viewed htrace hviews source] + exact hsourceView + have hallowedMonitored : targetCandidateIntervalAllowed configuration + monitored.2.origin.viewed monitoredPosition = true := by + rw [targetCandidateIntervalAllowed_castTracePosition configuration result.2 + monitored.2.origin.viewed htrace source] + exact hallowed + have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hresult, rfl⟩ + have hinvariants := gameAfterSecretsWithFullTrace_support_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hintervals := gameAfterSecretsWithFullTrace_support_interval_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hvalidIntervals := gameAfterSecretsWithFullTrace_support_validIntervals adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have htraceCoherent := originTargetMonitoredAdversaryImpl_candidateTraceCoherent + configuration secretKey targetOrdinal (adversary.main ⟨result.1.1, parameter⟩) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateTraceCoherent_initial configuration secretKey rootCache) + hmonitored + have hallowedTraceCoherent := + originTargetMonitoredAdversaryImpl_candidateAllowedTraceCoherent + configuration secretKey targetOrdinal (adversary.main ⟨result.1.1, parameter⟩) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateAllowedTraceCoherent_initial + configuration secretKey rootCache) + hmonitored + have hviewsCoherent := originTargetMonitoredAdversaryImpl_candidateViewsCoherent + configuration secretKey targetOrdinal (adversary.main ⟨result.1.1, parameter⟩) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateViewsCoherent_initial configuration rootCache + targetOrdinal) hmonitored + have hallowedCoherent := originTargetMonitoredAdversaryImpl_candidateAllowedCoherent + configuration secretKey targetOrdinal (adversary.main ⟨result.1.1, parameter⟩) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateAllowedCoherent_initial configuration rootCache + targetOrdinal) hmonitored + have htargetOrdinalMonitored : targetOrdinal = + monitored.2.origin.viewed.trace.intervals.countPBefore + (fun entry => decide (FreshTargetCandidate secretKey entry)) + monitoredPosition.val := by + rw [htargetOrdinal] + rw [List.countPBefore_eq_countP_take, List.countPBefore_eq_countP_take, + take_castTracePosition result.2 monitored.2.origin.viewed htrace source] + obtain ⟨hlogMonitored, hrealizedMonitored⟩ := + configuration.paddedRealized_transport result.2.trace + monitored.2.origin.viewed.trace htrace rfl hrealized + have hvalidIntervalsMonitored : + monitored.2.origin.viewed.trace.ValidIntervals secretKey := by + rw [← htrace] + exact hvalidIntervals + have hchronologicalMonitored : FullAdversaryTrace.Chronological + monitored.2.origin.viewed.trace.intervals := by + rw [← htrace] + exact hintervals.2.2 + have hcachesMonitored : monitored.2.origin.viewed.trace.signing.CachesLe + result.2.cache := by + rw [← htrace] + exact hinvariants.2.1 + exact configuration.paddedRealized_target_complete_and_hit + hlogMonitored hrealizedMonitored htraceCoherent.1 hvalidIntervalsMonitored + hchronologicalMonitored hcachesMonitored hf monitoredPosition hcandidateMonitored + hviewMonitored hallowedMonitored (by rwa [← htargetOrdinalMonitored]) + htraceCoherent.2 (by rwa [← htargetOrdinalMonitored]) hallowedTraceCoherent.2 + +theorem OriginConfiguration.verifierTarget_fixedTerminal_for_cover + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (cover : FewTimeCover f result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest)) + {limit sources : Nat} (hle : result.2.trace.signing.toSigningLog.length ≤ limit) + (configuration : OriginConfiguration (cover.pattern.pad hle) sources) + (hrealized : configuration.PaddedRealizedBy cover hle result.2.trace rfl) + (rootCache : QueryCache HashSpec) (state : ViewedFullTraceState) + (hadversary : (result.1.2.1, state) ∈ support + ((simulateQ (viewedFullTracedMappedAdversaryImpl + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩) + (adversary.main ⟨result.1.1, parameter⟩)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩)) + (htrace : result.2.trace = state.trace) (hviews : result.2.views = state.views) + (input : HashInput) (output : HashOutput) (digestCache : QueryCache HashSpec) + (hinput : input = tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness)) + (hmiss : state.cache input = none) + (hquery : (output, digestCache) ∈ support ((randomOracle input).run state.cache)) + (_hdigestCache : digestCache ≤ result.2.cache) + (htargetView : hashOutputFewTimeView output = + fewTimeTargetView (digestIndex digest) (digestLeaves digest)) + (q : Nat) (hcache : QueryCache.enncard digestCache ≤ q) : + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + let publicKey : PublicKey := ⟨result.1.1, parameter⟩ + let appended := appendTargetViewedState (.inl (.inr input)) state.cache output + digestCache none state + let targetOrdinal := freshTargetCandidateCount secretKey state.trace + FixedOriginTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache q configuration + targetOrdinal ((result.1.2.1, output), appended) := by + classical + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + let publicKey : PublicKey := ⟨result.1.1, parameter⟩ + let appended := appendTargetViewedState (.inl (.inr input)) state.cache output + digestCache none state + let targetOrdinal := freshTargetCandidateCount secretKey state.trace + have haugmented : ((result.1.2.1, output), appended) ∈ support + ((simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversaryWithTargetQuery adversary publicKey)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩) := by + subst input + exact adversaryWithTargetQuery_viewed_support adversary publicKey secretKey + rootCache result.1.2.1 state hadversary output digestCache hquery + refine ⟨hcache, ?_⟩ + intro monitored hmonitored heq + have hstateEq : monitored.2.origin.viewed = appended := congrArg Prod.snd heq + have hstateTraceEq : appended.trace = monitored.2.origin.viewed.trace := + congrArg ViewedFullTraceState.trace hstateEq.symm + have hstateViewsEq : appended.views = monitored.2.origin.viewed.views := + congrArg ViewedFullTraceState.views hstateEq.symm + let appendedPosition : Fin appended.trace.intervals.length := + ⟨state.trace.intervals.length, by + simp [appended, appendTargetViewedState, fullAdversaryTraceUpdate]⟩ + let monitoredPosition := castTracePosition appended monitored.2.origin.viewed + hstateTraceEq appendedPosition + have hcandidateEntry : FreshTargetCandidate secretKey + (⟨.inl (.inr input), output, state.cache, digestCache⟩ : AdversaryCacheEntry) := by + exact (freshTargetCandidate_direct_iff secretKey input output state.cache digestCache + hquery).2 hmiss + have hcandidate : FreshTargetCandidate secretKey + (appended.trace.intervals.get appendedPosition) := by + simpa [appendedPosition, appended, appendTargetViewedState, + fullAdversaryTraceUpdate] using hcandidateEntry + have hcandidateMonitored : FreshTargetCandidate secretKey + (monitored.2.origin.viewed.trace.intervals.get monitoredPosition) := by + rw [get_castTracePosition appended monitored.2.origin.viewed hstateTraceEq + appendedPosition] + exact hcandidate + have hvalidViewsState : state.ValidViews secretKey := by + have hvalid := gameAfterSecretsWithViewTrace_support_validViews adversary parameter + otsSecret ftsSecret result hresult + simpa only [ViewedFullTraceState.ValidViews, htrace, hviews] using hvalid + have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hresult, rfl⟩ + have hgameIntervals := gameAfterSecretsWithFullTrace_support_interval_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hconsistentState : state.trace.Consistent := by + rw [← htrace] + exact hgameIntervals.1 + have hview : targetCandidateIntervalView appended appendedPosition = + fewTimeTargetView (digestIndex digest) (digestLeaves digest) := by + rw [targetCandidateIntervalView_appendTargetViewedState_last secretKey state + hvalidViewsState hconsistentState] + exact htargetView + have hviewMonitored : targetCandidateIntervalView monitored.2.origin.viewed + monitoredPosition = fewTimeTargetView (digestIndex digest) (digestLeaves digest) := by + rw [targetCandidateIntervalView_castTracePosition appended + monitored.2.origin.viewed hstateTraceEq hstateViewsEq appendedPosition] + exact hview + have hsourceNone := configuration.paddedRealized_sourceAt_directIntervalCount_eq_none + hrealized + have hallowed : targetCandidateIntervalAllowed configuration appended appendedPosition = true := by + rw [targetCandidateIntervalAllowed_appendTargetViewedState_last configuration state + (.inl (.inr input)) state.cache output digestCache none] + simpa only [decide_eq_true_eq, htrace] using hsourceNone + have hallowedMonitored : targetCandidateIntervalAllowed configuration + monitored.2.origin.viewed monitoredPosition = true := by + rw [targetCandidateIntervalAllowed_castTracePosition configuration appended + monitored.2.origin.viewed hstateTraceEq appendedPosition] + exact hallowed + have htraceCoherent := originTargetMonitoredAdversaryImpl_candidateTraceCoherent + configuration secretKey targetOrdinal (adversaryWithTargetQuery adversary publicKey) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateTraceCoherent_initial configuration secretKey rootCache) + hmonitored + have hallowedTraceCoherent := + originTargetMonitoredAdversaryImpl_candidateAllowedTraceCoherent + configuration secretKey targetOrdinal (adversaryWithTargetQuery adversary publicKey) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateAllowedTraceCoherent_initial + configuration secretKey rootCache) hmonitored + have hviewsCoherent := originTargetMonitoredAdversaryImpl_candidateViewsCoherent + configuration secretKey targetOrdinal (adversaryWithTargetQuery adversary publicKey) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateViewsCoherent_initial configuration rootCache + targetOrdinal) hmonitored + have hallowedCoherent := originTargetMonitoredAdversaryImpl_candidateAllowedCoherent + configuration secretKey targetOrdinal (adversaryWithTargetQuery adversary publicKey) + (OriginTargetMonitorState.initial configuration rootCache) monitored + (OriginTargetMonitorState.candidateAllowedCoherent_initial configuration rootCache + targetOrdinal) hmonitored + have htargetOrdinal : targetOrdinal = + monitored.2.origin.viewed.trace.intervals.countPBefore + (fun entry => decide (FreshTargetCandidate secretKey entry)) + monitoredPosition.val := by + change freshTargetCandidateCount secretKey state.trace = _ + rw [List.countPBefore_eq_countP_take, + take_castTracePosition appended monitored.2.origin.viewed hstateTraceEq appendedPosition] + simp [appendedPosition, appended, appendTargetViewedState, fullAdversaryTraceUpdate, + freshTargetCandidateCount] + obtain ⟨hlogState, hrealizedState⟩ := + configuration.paddedRealized_transport result.2.trace state.trace htrace rfl hrealized + obtain ⟨hlogAppended, hrealizedAppended⟩ := + configuration.paddedRealized_append_direct state hlogState hrealizedState + input output digestCache + obtain ⟨hlogMonitored, hrealizedMonitored⟩ := + configuration.paddedRealized_transport appended.trace + monitored.2.origin.viewed.trace hstateTraceEq hlogAppended hrealizedAppended + have haugmentedIntervals := viewedFullTracedMappedAdversaryImpl_interval_invariants + secretKey (adversaryWithTargetQuery adversary publicKey) rootCache + ((result.1.2.1, output), appended) haugmented + have haugmentedValid := viewedFullTracedMappedAdversaryImpl_validIntervals + secretKey (adversaryWithTargetQuery adversary publicKey) rootCache + ((result.1.2.1, output), appended) haugmented + have hcaches : appended.trace.signing.CachesLe result.2.cache := by + have hcachesState : state.trace.signing.CachesLe result.2.cache := by + rw [← htrace] + exact (gameAfterSecretsWithFullTrace_support_invariants adversary parameter + otsSecret ftsSecret (result.1, result.2.base) hbase).2.1 + simpa [appended, appendTargetViewedState, fullAdversaryTraceUpdate, + signingCacheTraceUpdate] using hcachesState + have hvalidIntervalsMonitored : + monitored.2.origin.viewed.trace.ValidIntervals secretKey := by + rw [← hstateTraceEq] + exact haugmentedValid + have hchronologicalMonitored : FullAdversaryTrace.Chronological + monitored.2.origin.viewed.trace.intervals := by + rw [← hstateTraceEq] + exact haugmentedIntervals.2.2 + have hcachesMonitored : monitored.2.origin.viewed.trace.signing.CachesLe + result.2.cache := by + rw [← hstateTraceEq] + exact hcaches + exact configuration.paddedRealized_target_complete_and_hit + hlogMonitored hrealizedMonitored htraceCoherent.1 + hvalidIntervalsMonitored hchronologicalMonitored hcachesMonitored hf + monitoredPosition hcandidateMonitored hviewMonitored hallowedMonitored + (by rwa [← htargetOrdinal]) htraceCoherent.2 + (by rwa [← htargetOrdinal]) hallowedTraceCoherent.2 + +theorem gameAfterSecretsWithViewTrace_singletonCover_target_classified_at_adversary_state + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest parameter result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) = digest) + (hadmissible : Admissible digest) + (cover : FewTimeCover f result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest)) + (hcard : cover.entries.card = 1) + (hne : ∀ entry : cover.entries, + tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) ≠ + cover.entryDigestInput entry) + (hle : result.2.trace.signing.toSigningLog.length ≤ signatureLimit) + (rootCache : QueryCache HashSpec) (state : ViewedFullTraceState) + (htrace : result.2.trace = state.trace) (hviews : result.2.views = state.views) + (hstateCache : state.cache ≤ result.2.cache) : + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + VerifierFreshTarget parameter result ∨ + ∃ (distinct : Nat), distinct = 1 ∧ + ∃ (pattern : FewTimePattern signatureLimit distinct) + (configuration : OriginConfiguration pattern q) (candidate : Fin q), + FixedOriginTargetViewedTerminal secretKey + (adversary.main ⟨result.1.1, parameter⟩) rootCache q + configuration candidate.val (result.1.2.1, state) := by + classical + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + let targetPayload := messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness + let targetInput := tweakableHashInput parameter .message targetPayload + obtain ⟨sourceRootCache, adversaryCache, digestCache, output, hrootNone, hchain, hquery, + hdigestLe, htargetView, horigin, _⟩ := + gameAfterSecretsWithViewTrace_target_source_kind adversary parameter otsSecret + ftsSecret result hresult + rcases horigin with hverifier | ⟨source, hsourceInitial, hsourceFinal, hkind⟩ + · exact Or.inl ⟨sourceRootCache, adversaryCache, digestCache, output, + hrootNone, hchain, by simpa only [targetInput, targetPayload] using hverifier, + by simpa only [targetInput, targetPayload] using hquery, hdigestLe, htargetView⟩ + · obtain ⟨sourceOutput, hcandidate, hsourceView, hsourceOutput, hattempt⟩ := + gameAfterSecretsWithViewTrace_target_source_candidate adversary parameter otsSecret + ftsSecret result hresult f hf digest hdigest hadmissible source + (by simpa only [targetInput, targetPayload] using hsourceInitial) + (by simpa only [targetInput, targetPayload] using hsourceFinal) + (by simpa only [targetInput, targetPayload] using hkind) + have hbase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret ftsSecret, + support_map] + exact ⟨result, hresult, rfl⟩ + obtain ⟨configuration, hrealized⟩ := + cover.exists_paddedRealized_originConfiguration_of_queryBudget + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts + (result.1, result.2.base) hbase f hf (digestIndex digest) (digestLeaves digest) + signatureLimit hle + have hinvariants := gameAfterSecretsWithFullTrace_support_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hintervals := gameAfterSecretsWithFullTrace_support_interval_invariants adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hvalidIntervals := gameAfterSecretsWithFullTrace_support_validIntervals adversary + parameter otsSecret ftsSecret (result.1, result.2.base) hbase + have hvalidViews := gameAfterSecretsWithViewTrace_support_validViews adversary parameter + otsSecret ftsSecret result hresult + have hallowed : targetCandidateIntervalAllowed configuration result.2 source = true := + cover.target_source_interval_allowed_of_input_ne targetPayload hne result.2 rfl + hvalidViews hintervals.1 hinvariants.2.1 hf hle configuration hrealized + hvalidIntervals source sourceOutput + (by simpa only [targetInput, targetPayload] using hsourceInitial) + (by simpa only [targetInput, targetPayload] using hsourceOutput) + hattempt (by simpa only [targetInput, targetPayload] using hkind) + let targetOrdinal := result.2.trace.intervals.countPBefore + (fun entry => decide (FreshTargetCandidate secretKey entry)) source.val + have hordinalLt : targetOrdinal < freshTargetCandidateCount secretKey result.2.trace := by + apply List.countPBefore_lt_countP_of_lt_length_of_pos + exact decide_eq_true hcandidate + have hcountLe : freshTargetCandidateCount secretKey result.2.trace ≤ q := by + rw [freshTargetCandidateCount_eq_card] + have hbound := gameAfterSecretsWithViewTrace_freshTargetCandidatePositions_card_le + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts result hresult + exact_mod_cast hbound + let candidate : Fin q := ⟨targetOrdinal, hordinalLt.trans_le hcountLe⟩ + have hfinalCache : QueryCache.enncard result.2.cache ≤ q := + gameAfterSecretsWithFullTrace_support_enncard_le adversary q hq parameter hparameter + otsSecret hots ftsSecret hfts (result.1, result.2.base) hbase + have hviewedCache : QueryCache.enncard state.cache ≤ q := + (QueryCache.enncard_mono hstateCache).trans hfinalCache + refine Or.inr ⟨cover.entries.card, hcard, cover.pattern.pad hle, + configuration, candidate, hviewedCache, ?_⟩ + intro monitored hmonitored heq + have hstateEq : monitored.2.origin.viewed = state := congrArg Prod.snd heq + have htrace' : result.2.trace = monitored.2.origin.viewed.trace := by + rw [hstateEq] + exact htrace + have hviews' : result.2.views = monitored.2.origin.viewed.views := by + rw [hstateEq] + exact hviews + exact configuration.target_monitored_complete_of_projection_for_cover adversary parameter + otsSecret ftsSecret result hresult f hf digest cover hle hrealized source + hcandidate hsourceView hallowed targetOrdinal rfl rootCache monitored hmonitored + htrace' hviews' + +theorem gameAfterSecretsWithViewTrace_singletonCover_target_classified + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (f : QueryImpl HashSpec Id) (hf : result.2.cache.AgreesWithFn f) + (digest : MessageDigest) + (hdigest : evalWithAnswerFn f + (messageDigest parameter result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) = digest) + (hadmissible : Admissible digest) + (cover : FewTimeCover f result.2.cache + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.trace.signing.toSigningLog (digestIndex digest) (digestLeaves digest)) + (hcard : cover.entries.card = 1) + (hne : ∀ entry : cover.entries, + tweakableHashInput parameter .message + (messageDigestPayload result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) ≠ + cover.entryDigestInput entry) + (hle : result.2.trace.signing.toSigningLog.length ≤ signatureLimit) : + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + VerifierFreshTarget parameter result ∨ + ∃ (rootCache : QueryCache HashSpec) (state : ViewedFullTraceState) + (distinct : Nat), distinct = 1 ∧ + ∃ (pattern : FewTimePattern signatureLimit distinct) + (configuration : OriginConfiguration pattern q) (candidate : Fin q), + (result.1.2.1, state) ∈ support + ((simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversary.main ⟨result.1.1, parameter⟩)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩) ∧ + FixedOriginTargetViewedTerminal secretKey + (adversary.main ⟨result.1.1, parameter⟩) rootCache q + configuration candidate.val (result.1.2.1, state) := by + obtain ⟨rootCache, state, _, hadversary, htrace, hviews, hstateCache⟩ := + gameAfterSecretsWithViewTrace_support_adversary_state adversary parameter otsSecret + ftsSecret result hresult + rcases gameAfterSecretsWithViewTrace_singletonCover_target_classified_at_adversary_state + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts result hresult + f hf digest hdigest hadmissible cover hcard hne hle rootCache state htrace + hviews hstateCache with hfresh | hclassified + · exact Or.inl hfresh + · obtain ⟨distinct, hdistinct, pattern, configuration, candidate, hterminal⟩ := + hclassified + exact Or.inr ⟨rootCache, state, distinct, hdistinct, pattern, configuration, + candidate, hadversary, hterminal⟩ + +theorem probEvent_gameRestWithViewTrace_nonfresh_messageCollision_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (root : Digest) (rootCache : QueryCache HashSpec) + (hroot : (root, rootCache) ∈ support + ((simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅)) : + Pr[fun rest => + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, rest.1.1, rest.1.2), rest.2) + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + ¬VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache] ≤ + q * singletonOriginUnionBound signatureLimit q := by + classical + let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + let publicKey : PublicKey := ⟨root, parameter⟩ + let initialState : ViewedFullTraceState := + ⟨rootCache, ⟨[], [], []⟩, [], none⟩ + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState + let finish : Forgery × ViewedFullTraceState → + ProbComp ((Forgery × Bool) × ViewedFullTraceState) := fun prior => do + let ((verified, targetView), finalCache) ← + (simulateQ romImpl + (liftM (verifyWithView publicKey prior.1.message prior.1.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run prior.2.cache + let log := prior.2.trace.signing.toSigningLog + let verdict := decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log prior.1) && verified + pure ((prior.1, verdict), + ⟨finalCache, prior.2.trace, prior.2.views, some targetView⟩) + let prefixEvent := fun prior : Forgery × ViewedFullTraceState => + SomeFixedSingletonOriginTargetViewedTerminal secretKey + (adversary.main publicKey) rootCache signatureLimit q q q prior + have hgame : gameRestWithViewTrace adversary publicKey secretKey rootCache = + run >>= finish := by + rfl + rw [show ⟨root, parameter⟩ = publicKey from rfl, + show ⟨parameter, root, otsSecret, ftsSecret⟩ = secretKey from rfl, hgame] + calc + _ ≤ Pr[prefixEvent | run] := by + apply probEvent_bind_le_probEvent + intro prior hprior hnotPrefix + rcases prior with ⟨forgery, state⟩ + apply probEvent_eq_zero + intro rest hrest hevent + rw [mem_support_bind_iff] at hrest + obtain ⟨⟨⟨verified, targetView⟩, finalCache⟩, hverify, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst rest + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) + have hrestSupport : + ((forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) ∈ + support (gameRestWithViewTrace adversary publicKey secretKey rootCache) := by + rw [hgame, mem_support_bind_iff] + refine ⟨(forgery, state), hprior, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨((verified, targetView), finalCache), hverify, + by simp only [support_pure, Set.mem_singleton_iff]⟩ + have hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret) := by + rw [gameAfterSecretsWithViewTrace, mem_support_bind_iff] + refine ⟨(root, rootCache), hroot, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨_, hrestSupport, by simp [result]⟩ + obtain ⟨f, digest, hf, hvalid, _, hdigest, hadmissible, + hcollision, _⟩ := hevent.1 + obtain ⟨cover, hcard, hne⟩ := + hcollision.exists_singletonFewTimeCover digest hdigest + have hcacheLe : state.cache ≤ finalCache := + simulateQ_romImpl_cache_le + (liftM (verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView)) state.cache + ((verified, targetView), finalCache) hverify + rcases gameAfterSecretsWithViewTrace_singletonCover_target_classified_at_adversary_state + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts result hresult + f hf digest hdigest hadmissible cover hcard hne hvalid rootCache state rfl rfl + hcacheLe with hfresh | hclassified + · exact hevent.2 hfresh + · obtain ⟨distinct, hdistinct, pattern, configuration, candidate, hterminal⟩ := + hclassified + subst distinct + apply hnotPrefix + unfold prefixEvent SomeFixedSingletonOriginTargetViewedTerminal + exact ⟨pattern, configuration, candidate, hterminal⟩ + _ ≤ _ := probEvent_someFixedSingletonOriginTargetViewedTerminal_le + secretKey (adversary.main publicKey) rootCache signatureLimit q q hqMax + (by + have hroot' : QueryCache.enncard rootCache ≤ q := by + have hprojected : (root, rootCache) ∈ support + ((simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅) := hroot + have hgameBound := isQueryBoundP_gameAfterSecrets adversary q hq + hparameter hots hfts + rw [gameAfterSecrets] at hgameBound + have hrootBound := OracleComp.IsQueryBoundP.of_bind_left + (p := fun input : OracleWorld.Domain => input matches Sum.inr _) hgameBound + have hbound := simulateQ_romImpl_enncard_le_queryBound + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest) q hrootBound + (root, rootCache) hprojected + exact hbound + exact hroot') q + +set_option maxRecDepth 1000000 in +set_option maxHeartbeats 2000000 in +theorem probEvent_gameRestWithViewTrace_fresh_messageCollision_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (root : Digest) (rootCache : QueryCache HashSpec) + (hroot : (root, rootCache) ∈ support + ((simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅)) : + Pr[fun rest => + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, rest.1.1, rest.1.2), rest.2) + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache] ≤ + ((q + 1 : Nat) : ℝ≥0∞) * singletonOriginUnionBound signatureLimit q := by + classical + let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + let publicKey : PublicKey := ⟨root, parameter⟩ + let initialState : ViewedFullTraceState := + ⟨rootCache, ⟨[], [], []⟩, [], none⟩ + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState + let finish : Forgery × ViewedFullTraceState → + ProbComp ((Forgery × Bool) × ViewedFullTraceState) := fun prior => do + let ((verified, targetView), finalCache) ← + (simulateQ romImpl + (liftM (verifyWithView publicKey prior.1.message prior.1.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run prior.2.cache + let log := prior.2.trace.signing.toSigningLog + let verdict := decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log prior.1) && verified + pure ((prior.1, verdict), + ⟨finalCache, prior.2.trace, prior.2.views, some targetView⟩) + let freshEvent := fun rest : (Forgery × Bool) × ViewedFullTraceState => + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, rest.1.1, rest.1.2), rest.2) + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result + have hrootNone : ∀ payload, + rootCache (tweakableHashInput parameter .message payload) = none := by + have hroot' : (root, rootCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅) := by + simpa only [simulateQ_romImpl_liftM] using hroot + exact fun payload => treeRoot_cache_message_none parameter topLayer rootTree + (otsSecret topLayer rootTree) root rootCache hroot' payload + have hrootCache : QueryCache.enncard rootCache ≤ q := by + have hgameBound := isQueryBoundP_gameAfterSecrets adversary q hq + hparameter hots hfts + rw [gameAfterSecrets] at hgameBound + have hrootBound := OracleComp.IsQueryBoundP.of_bind_left + (p := fun input : OracleWorld.Domain => input matches Sum.inr _) hgameBound + exact simulateQ_romImpl_enncard_le_queryBound + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest) q hrootBound (root, rootCache) hroot + have hprefixBound := + probEvent_someFixedOneOriginTargetViewedTerminal_le + (α := Forgery × HashOutput) (secretKey := secretKey) + (computation := adversaryWithTargetQuery adversary publicKey) + (initialCache := rootCache) (signatures := signatureLimit) (sources := q) + (q := q) (hq := hqMax) (hcache := hrootCache) (candidates := q + 1) + have hgame : gameRestWithViewTrace adversary publicKey secretKey rootCache = + run >>= finish := rfl + rw [show ⟨root, parameter⟩ = publicKey from rfl, + show ⟨parameter, root, otsSecret, ftsSecret⟩ = secretKey from rfl, hgame] + change Pr[freshEvent | run >>= finish] ≤ _ + have hfirst : Pr[freshEvent | run >>= finish] ≤ + Pr[SomeFixedOneOriginTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversaryWithTargetQuery adversary publicKey)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩] := by + rw [adversaryWithTargetQuery_viewed_run] + change Pr[_ | run >>= _] ≤ + Pr[SomeFixedOneOriginTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + run >>= _] + apply probEvent_bind_le_bind_of_forall_le + rintro ⟨forgery, state⟩ hprior + let input := tweakableHashInput parameter .message + (messageDigestPayload root forgery.message forgery.signature.randomness) + change Pr[_ | + (simulateQ romImpl + (liftM (verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run state.cache >>= _] ≤ _ + rw [verifyWithView_split_run] + simp only [bind_assoc] + rw [show tweakableHashInput publicKey.parameter .message + (messageDigestPayload publicKey.root forgery.message + forgery.signature.randomness) = input from rfl] + change _ ≤ Pr[SomeFixedOneOriginTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + (randomOracle input).run state.cache >>= pure ∘ fun source => + ((forgery, source.1), appendDirectTargetViewedState input state.cache + source.1 source.2 state)] + rw [probEvent_bind_pure_comp] + change Pr[_ | (randomOracle input).run state.cache >>= _] ≤ + Pr[fun source => SomeFixedOneOriginTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) + ((forgery, source.1), + appendDirectTargetViewedState input state.cache source.1 source.2 state) | + (randomOracle input).run state.cache] + apply probEvent_bind_le_probEvent + rintro ⟨output, digestCache⟩ hquery hnotPrefix + apply probEvent_eq_zero + intro rest hrest hevent + rw [mem_support_bind_iff] at hrest + obtain ⟨⟨⟨verified, targetView⟩, finalCache⟩, hverifyRest, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst rest + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) + change ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result at hevent + have hverify : ((verified, targetView), finalCache) ∈ support + ((simulateQ romImpl + (liftM (verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run state.cache) := by + rw [verifyWithView_split_run, mem_support_bind_iff] + exact ⟨(output, digestCache), by simpa only [input, publicKey] using hquery, + hverifyRest⟩ + have hrestSupport : + ((forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) ∈ + support (gameRestWithViewTrace adversary publicKey secretKey rootCache) := by + rw [gameRestWithViewTrace, mem_support_bind_iff] + refine ⟨(forgery, state), hprior, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨((verified, targetView), finalCache), hverify, + by simp only [support_pure, Set.mem_singleton_iff]⟩ + have hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret) := by + rw [gameAfterSecretsWithViewTrace, mem_support_bind_iff] + refine ⟨(root, rootCache), hroot, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨_, hrestSupport, by simp [result]⟩ + obtain ⟨f, digest, hf, hvalid, _, hdigest, _, hcollision, _⟩ := hevent.1 + obtain ⟨cover, hcard, _⟩ := + hcollision.exists_singletonFewTimeCover digest hdigest + obtain ⟨otherRootCache, adversaryCache, _, _, hotherRootNone, + hotherChain, hadversaryMiss, _, _, _⟩ := hevent.2 + have hbase : (forgery, state.base) ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState.base) := by + rw [← viewedFullTracedMappedAdversaryImpl_projection secretKey + (adversary.main publicKey) initialState, support_map] + exact ⟨(forgery, state), hprior, rfl⟩ + have hchain : FullAdversaryTrace.CacheChain rootCache state.trace.intervals + state.cache := + fullTracedMappedAdversaryImpl_cacheChain secretKey (adversary.main publicKey) + rootCache rootCache ⟨[], [], []⟩ (forgery, state.base) (by rfl) hbase + have hmiss : state.cache input = none := by + have hrootInput : rootCache input = none := by + simpa only [input] using hrootNone + (messageDigestPayload root forgery.message forgery.signature.randomness) + have hotherRootInput : otherRootCache input = none := by + simpa only [input, result] using hotherRootNone + (messageDigestPayload root forgery.message forgery.signature.randomness) + have hlookup := FullAdversaryTrace.CacheChain.finish_lookup_eq input + (hrootInput.trans hotherRootInput.symm) hchain + (by simpa only [result] using hotherChain) + exact hlookup.trans hadversaryMiss + have hdigestLe : digestCache ≤ finalCache := + simulateQ_romImpl_cache_le + (liftM (verifyWithViewAfterOutput publicKey forgery.signature output) : + OracleComp OracleWorld (Bool × FewTimeView)) digestCache + ((verified, targetView), finalCache) hverifyRest + have hcachedDigest : digestCache input = some output := + randomOracle_output_cached input state.cache digestCache output (by + have hquerySim : simulateQ (randomOracle : QueryImpl HashSpec _) + (oracleHash input) = randomOracle input := by + change simulateQ (randomOracle : QueryImpl HashSpec _) + (liftM (HashSpec.query input)) = randomOracle input + rw [simulateQ_spec_query] + rw [hquerySim] + exact hquery) + have hcachedFinal : finalCache input = some output := hdigestLe hcachedDigest + have hanswer : f input = output := hf (by simpa only [result] using hcachedFinal) + have hdigestOutput : truncateMessageDigest output = digest := by + have hdigest' : truncateMessageDigest (f input) = digest := by + simpa only [messageDigest, oracleHash, evalWithAnswerFn_bind, + evalWithAnswerFn_query, evalWithAnswerFn_pure, result, input] using hdigest + rwa [hanswer] at hdigest' + have htargetOutput : hashOutputFewTimeView output = + fewTimeTargetView (digestIndex digest) (digestLeaves digest) := by + simp [hashOutputFewTimeView, fewTimeTargetView, hdigestOutput] + have hfullBase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret + ftsSecret, support_map] + exact ⟨result, hresult, rfl⟩ + obtain ⟨configuration, hrealized⟩ := + cover.exists_paddedRealized_originConfiguration_of_queryBudget + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts + (result.1, result.2.base) hfullBase f hf (digestIndex digest) + (digestLeaves digest) signatureLimit hvalid + have hfinalCache : QueryCache.enncard finalCache ≤ q := by + have hbound := gameAfterSecretsWithFullTrace_support_enncard_le adversary q hq + parameter hparameter otsSecret hots ftsSecret hfts + (result.1, result.2.base) hfullBase + change QueryCache.enncard result.2.cache ≤ q at hbound + simpa only [result] using hbound + have hdigestCard : QueryCache.enncard digestCache ≤ q := + (QueryCache.enncard_mono hdigestLe).trans hfinalCache + have hcountLe : freshTargetCandidateCount secretKey state.trace ≤ q := by + rw [freshTargetCandidateCount_eq_card] + have hbound := gameAfterSecretsWithViewTrace_freshTargetCandidatePositions_card_le + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts result hresult + simp only [result] at hbound + exact_mod_cast hbound + let candidate : Fin (q + 1) := + ⟨freshTargetCandidateCount secretKey state.trace, by omega⟩ + unfold SomeFixedOneOriginTargetViewedTerminal at hnotPrefix + apply hnotPrefix + refine ⟨cover.entries.card, hcard, cover.pattern.pad hvalid, + configuration, candidate, ?_⟩ + exact configuration.verifierTarget_fixedTerminal_for_cover adversary parameter otsSecret + ftsSecret result hresult f hf digest cover hvalid hrealized + rootCache state hprior rfl rfl input output digestCache rfl hmiss + (by simpa only [input] using hquery) hdigestLe htargetOutput q hdigestCard + calc + Pr[freshEvent | run >>= finish] ≤ + Pr[SomeFixedOneOriginTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversaryWithTargetQuery adversary publicKey)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩] := hfirst + _ ≤ ((q + 1 : Nat) : ℝ≥0∞) * singletonOriginUnionBound signatureLimit q := + hprefixBound + +theorem probEvent_gameAfterSecretsWithViewTrace_nonfresh_messageCollision_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun result => + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + ¬VerifierFreshTarget parameter result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + q * singletonOriginUnionBound signatureLimit q := by + rw [gameAfterSecretsWithViewTrace] + apply probEvent_bind_le_of_forall_le + rintro ⟨root, rootCache⟩ hroot + let attach := fun rest : (Forgery × Bool) × ViewedFullTraceState => + ((root, rest.1.1, rest.1.2), rest.2) + change Pr[fun result => + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + ¬VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache >>= pure ∘ attach] ≤ _ + rw [probEvent_bind_pure_comp] + exact probEvent_gameRestWithViewTrace_nonfresh_messageCollision_le adversary q hq hqMax + parameter hparameter otsSecret hots ftsSecret hfts root rootCache hroot + +theorem probEvent_gameAfterSecretsWithViewTrace_fresh_messageCollision_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun result => + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + ((q + 1 : Nat) : ℝ≥0∞) * singletonOriginUnionBound signatureLimit q := by + rw [gameAfterSecretsWithViewTrace] + apply probEvent_bind_le_of_forall_le + rintro ⟨root, rootCache⟩ hroot + let attach := fun rest : (Forgery × Bool) × ViewedFullTraceState => + ((root, rest.1.1, rest.1.2), rest.2) + change Pr[fun result => + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache >>= pure ∘ attach] ≤ _ + rw [probEvent_bind_pure_comp] + exact probEvent_gameRestWithViewTrace_fresh_messageCollision_le adversary q hq hqMax + parameter hparameter otsSecret hots ftsSecret hfts root rootCache hroot + +theorem probEvent_gameAfterSecretsWithViewTrace_messageCollision_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + q * singletonOriginUnionBound signatureLimit q + + ((q + 1 : Nat) : ℝ≥0∞) * singletonOriginUnionBound signatureLimit q := by + classical + calc + _ ≤ Pr[fun result => + (ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + ¬VerifierFreshTarget parameter result) ∨ + (ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result) | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + apply probEvent_mono + intro result _ hcollision + by_cases hfresh : VerifierFreshTarget parameter result + · exact Or.inr ⟨hcollision, hfresh⟩ + · exact Or.inl ⟨hcollision, hfresh⟩ + _ ≤ _ := (probEvent_or_le _ _ _).trans (add_le_add + (probEvent_gameAfterSecretsWithViewTrace_nonfresh_messageCollision_le adversary q hq + hqMax parameter hparameter otsSecret hots ftsSecret hfts) + (probEvent_gameAfterSecretsWithViewTrace_fresh_messageCollision_le adversary q hq + hqMax parameter hparameter otsSecret hots ftsSecret hfts)) + +theorem probEvent_gameAfterSecretsWithViewTrace_messageCollision_le_inv + (adversary : Adversary) (q : Nat) (hqPos : 1 ≤ q) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 120) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ ≤ q * singletonOriginUnionBound signatureLimit q + + ((q + 1 : Nat) : ℝ≥0∞) * singletonOriginUnionBound signatureLimit q := + probEvent_gameAfterSecretsWithViewTrace_messageCollision_le adversary q hq hqMax + parameter hparameter otsSecret hots ftsSecret hfts + _ = ((2 * q + 1 : Nat) : ℝ≥0∞) * + singletonOriginUnionBound signatureLimit q := by + push_cast + ring + _ ≤ ((2 * q + 1 : Nat) : ℝ≥0∞) * + ((2 ^ 141 : Nat) : ℝ≥0∞)⁻¹ := by + have hmass := singletonOriginUnionBound_le_inv q hqMax + calc + ((2 * q + 1 : Nat) : ℝ≥0∞) * singletonOriginUnionBound signatureLimit q = + singletonOriginUnionBound signatureLimit q * (2 * q + 1 : Nat) := mul_comm _ _ + _ ≤ ((2 ^ 141 : Nat) : ℝ≥0∞)⁻¹ * (2 * q + 1 : Nat) := + mul_le_mul_left hmass _ + _ = ((2 * q + 1 : Nat) : ℝ≥0∞) * + ((2 ^ 141 : Nat) : ℝ≥0∞)⁻¹ := mul_comm _ _ + _ ≤ ((4 * q : Nat) : ℝ≥0∞) * + ((2 ^ 141 : Nat) : ℝ≥0∞)⁻¹ := by + have hcoeff : ((2 * q + 1 : Nat) : ℝ≥0∞) ≤ (4 * q : Nat) := by + exact_mod_cast (show 2 * q + 1 ≤ 4 * q by omega) + exact mul_le_mul_left hcoeff ((2 ^ 141 : Nat) : ℝ≥0∞)⁻¹ + _ = (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_natCast] + norm_num + ring + +theorem probEvent_sampled_cleanMessage_le + (adversary : Adversary) (q : Nat) (hqPos : 1 ≤ q) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 120) : + Pr[SampledViewedEvent cleanMessageEvent | sampledViewedGame adversary] ≤ + (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ := by + rw [probEvent_sampledViewedGame_eq_weighted] + calc + (∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets] * + Pr[cleanMessageEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret]) ≤ + ∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets] * + ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹) := by + apply ENNReal.tsum_le_tsum + intro secrets + by_cases hsecrets : secrets ∈ support sampleSecrets + · obtain ⟨hparameter, hots, hfts⟩ := secrets.support_components hsecrets + have hrisk : + Pr[cleanMessageEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret] ≤ + (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ := by + apply le_trans (probEvent_mono fun _ _ event => event.2) + exact probEvent_gameAfterSecretsWithViewTrace_messageCollision_le_inv adversary q + hqPos hq hqMax secrets.parameter hparameter secrets.otsSecret hots + secrets.ftsSecret hfts + calc + Pr[= secrets | sampleSecrets] * + Pr[cleanMessageEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret] = + Pr[cleanMessageEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret] * Pr[= secrets | sampleSecrets] := mul_comm _ _ + _ ≤ ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹) * + Pr[= secrets | sampleSecrets] := + mul_le_mul_left hrisk _ + _ = Pr[= secrets | sampleSecrets] * + ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹) := mul_comm _ _ + · rw [probOutput_eq_zero_of_not_mem_support hsecrets, zero_mul, zero_mul] + _ = (∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets]) * + ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹) := by + rw [ENNReal.tsum_mul_right] + _ ≤ 1 * ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹) := + mul_le_mul_left tsum_probOutput_le_one _ + _ = (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ := one_mul _ + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/MessageCollision125.lean b/formal/sphincs/SphincsSecurity/Proof/MessageCollision125.lean new file mode 100644 index 00000000..0f9f1246 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/MessageCollision125.lean @@ -0,0 +1,724 @@ +import SphincsSecurity.Proof.FewTimeTarget125 +import SphincsSecurity.Proof.FewTime125Count +import SphincsSecurity.Proof.MessageCollision + +namespace SphincsSecurity.Concrete.Range125 + +open OracleComp OracleSpec ENNReal + +set_option maxRecDepth 100000 in +theorem singletonOriginUnionBound_le_inv (q : Nat) (hq : q ≤ 2 ^ 126) : + singletonOriginUnionBound signatureLimit q ≤ + ((2 ^ 141 : Nat) : ℝ≥0∞)⁻¹ := by + classical + have hratio : 1 + (q : ℝ≥0∞) * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ≤ 2 := by + calc + _ ≤ 1 + ((2 ^ 126 : Nat) : ℝ≥0∞) * ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ := by gcongr + _ ≤ _ := by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_natCast, + ENNReal.toReal_ofNat, ENNReal.toReal_one] + norm_num + rw [singletonOriginUnionBound_eq] + calc + (∑ pattern : FewTimePattern signatureLimit 1, + originChoiceMass pattern.selected q ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ * + ((2 ^ 166 : Nat) : ℝ≥0∞)⁻¹) ≤ + ∑ _pattern : FewTimePattern signatureLimit 1, + 2 * ((2 ^ 166 : Nat) : ℝ≥0∞)⁻¹ := by + apply Finset.sum_le_sum + intro pattern _ + have hmass := originChoiceMass_le pattern.selected q ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ + rw [Fintype.card_coe, pattern.card_selected, pow_one] at hmass + have hmass : originChoiceMass pattern.selected q ((2 ^ 127 : Nat) : ℝ≥0∞)⁻¹ ≤ 2 := + hmass.trans hratio + simpa only [mul_comm] using + (mul_le_mul_left hmass ((2 ^ 166 : Nat) : ℝ≥0∞)⁻¹) + _ = (Fintype.card (FewTimePattern signatureLimit 1) : ℝ≥0∞) * + (2 * ((2 ^ 166 : Nat) : ℝ≥0∞)⁻¹) := by + simp only [Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + _ = ((2 ^ 141 : Nat) : ℝ≥0∞)⁻¹ := by + have hcard : Fintype.card (FewTimePattern signatureLimit 1) = signatureLimit := by + simp [fewTimePattern_card] + rw [hcard, signatureLimit] + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_natCast] + norm_num + +theorem probEvent_exists_singletonOriginConfiguration_fixedOrdinal_viewedEvent_le + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q : Nat) + (hq : q ≤ 2 ^ 126) (hcache : QueryCache.enncard initialCache ≤ q) + (candidates : Nat) + (viewedEvent : ∀ pattern : FewTimePattern signatures 1, + OriginConfiguration pattern sources → Fin candidates → + α × ViewedFullTraceState → Prop) + (himp : ∀ (pattern : FewTimePattern signatures 1) + (configuration : OriginConfiguration pattern sources) (candidate : Fin candidates) + (result : α × OriginTargetMonitorState configuration), + result ∈ support + ((simulateQ + (originTargetMonitoredAdversaryImpl configuration secretKey candidate.val) + computation).run (OriginTargetMonitorState.initial configuration initialCache)) → + viewedEvent pattern configuration candidate + (result.1, result.2.origin.viewed) → + result.2.Complete ∧ + (∀ target, result.2.targetView = some target → + FixedFewTimePatternHit pattern.assignment + (result.2.origin.observation.views, target)) ∧ + QueryCache.enncard result.2.origin.viewed.cache ≤ q) : + Pr[fun result => ∃ pattern : FewTimePattern signatures 1, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent pattern configuration candidate result | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] ≤ + candidates * singletonOriginUnionBound signatures sources := by + classical + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩ + calc + Pr[fun result => ∃ pattern : FewTimePattern signatures 1, + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent pattern configuration candidate result | run] = + Pr[fun result => ∃ pattern ∈ + (Finset.univ : Finset (FewTimePattern signatures 1)), + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent pattern configuration candidate result | run] := by + congr 1 + funext result + simp + _ ≤ ∑ pattern : FewTimePattern signatures 1, + Pr[fun result => + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent pattern configuration candidate result | run] := + probEvent_exists_finset_le_sum Finset.univ run fun pattern result => + ∃ configuration : OriginConfiguration pattern sources, + ∃ candidate : Fin candidates, + viewedEvent pattern configuration candidate result + _ ≤ ∑ pattern : FewTimePattern signatures 1, + ∑ configuration : OriginConfiguration pattern sources, + Pr[fun result => ∃ candidate : Fin candidates, + viewedEvent pattern configuration candidate result | run] := by + apply Finset.sum_le_sum + intro pattern _ + calc + _ = Pr[fun result => ∃ configuration ∈ + (Finset.univ : Finset (OriginConfiguration pattern sources)), + ∃ candidate : Fin candidates, + viewedEvent pattern configuration candidate result | run] := by + congr 1 + funext result + simp + _ ≤ _ := probEvent_exists_finset_le_sum Finset.univ run fun configuration result => + ∃ candidate : Fin candidates, + viewedEvent pattern configuration candidate result + _ ≤ ∑ pattern : FewTimePattern signatures 1, + ∑ configuration : OriginConfiguration pattern sources, + candidates * Pr[configuration.Hit | + ($ᵗ configuration.Sample : ProbComp configuration.Sample)] := by + apply Finset.sum_le_sum + intro pattern _ + apply Finset.sum_le_sum + intro configuration _ + exact probEvent_exists_fixedOrdinal_viewedEvent_le_ideal configuration secretKey + computation initialCache q hq hcache candidates + (viewedEvent pattern configuration) (himp pattern configuration) + _ = candidates * singletonOriginUnionBound signatures sources := by + rw [singletonOriginUnionBound] + simp_rw [← Finset.mul_sum] + +theorem probEvent_someFixedSingletonOriginTargetViewedTerminal_le + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q : Nat) + (hq : q ≤ 2 ^ 126) (hcache : QueryCache.enncard initialCache ≤ q) + (candidates : Nat) : + Pr[SomeFixedSingletonOriginTargetViewedTerminal secretKey computation initialCache + signatures sources q candidates | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] ≤ + candidates * singletonOriginUnionBound signatures sources := by + unfold SomeFixedSingletonOriginTargetViewedTerminal + apply probEvent_exists_singletonOriginConfiguration_fixedOrdinal_viewedEvent_le + secretKey computation initialCache signatures sources q hq hcache candidates + (fun _ configuration candidate => + FixedOriginTargetViewedTerminal secretKey computation initialCache q + configuration candidate.val) + intro pattern configuration candidate result hresult hevent + obtain ⟨hcacheFinal, hterminal⟩ := hevent + obtain ⟨hcomplete, hhit⟩ := hterminal result hresult rfl + exact ⟨hcomplete, hhit, hcacheFinal⟩ + +theorem probEvent_someFixedOneOriginTargetViewedTerminal_le + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (signatures sources q : Nat) + (hq : q ≤ 2 ^ 126) (hcache : QueryCache.enncard initialCache ≤ q) + (candidates : Nat) : + Pr[SomeFixedOneOriginTargetViewedTerminal secretKey computation initialCache + signatures sources q candidates | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] ≤ + candidates * singletonOriginUnionBound signatures sources := by + calc + _ = Pr[SomeFixedSingletonOriginTargetViewedTerminal secretKey computation initialCache + signatures sources q candidates | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + computation).run ⟨initialCache, ⟨[], [], []⟩, [], none⟩] := by + congr 1 + funext result + exact propext (someFixedOneOriginTargetViewedTerminal_iff secretKey computation + initialCache signatures sources q candidates result) + _ ≤ _ := probEvent_someFixedSingletonOriginTargetViewedTerminal_le + secretKey computation initialCache signatures sources q hq hcache candidates + +theorem probEvent_gameRestWithViewTrace_nonfresh_messageCollision_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (root : Digest) (rootCache : QueryCache HashSpec) + (hroot : (root, rootCache) ∈ support + ((simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅)) : + Pr[fun rest => + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, rest.1.1, rest.1.2), rest.2) + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + ¬VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache] ≤ + q * singletonOriginUnionBound signatureLimit q := by + classical + let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + let publicKey : PublicKey := ⟨root, parameter⟩ + let initialState : ViewedFullTraceState := + ⟨rootCache, ⟨[], [], []⟩, [], none⟩ + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState + let finish : Forgery × ViewedFullTraceState → + ProbComp ((Forgery × Bool) × ViewedFullTraceState) := fun prior => do + let ((verified, targetView), finalCache) ← + (simulateQ romImpl + (liftM (verifyWithView publicKey prior.1.message prior.1.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run prior.2.cache + let log := prior.2.trace.signing.toSigningLog + let verdict := decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log prior.1) && verified + pure ((prior.1, verdict), + ⟨finalCache, prior.2.trace, prior.2.views, some targetView⟩) + let prefixEvent := fun prior : Forgery × ViewedFullTraceState => + SomeFixedSingletonOriginTargetViewedTerminal secretKey + (adversary.main publicKey) rootCache signatureLimit q q q prior + have hgame : gameRestWithViewTrace adversary publicKey secretKey rootCache = + run >>= finish := by + rfl + rw [show ⟨root, parameter⟩ = publicKey from rfl, + show ⟨parameter, root, otsSecret, ftsSecret⟩ = secretKey from rfl, hgame] + calc + _ ≤ Pr[prefixEvent | run] := by + apply probEvent_bind_le_probEvent + intro prior hprior hnotPrefix + rcases prior with ⟨forgery, state⟩ + apply probEvent_eq_zero + intro rest hrest hevent + rw [mem_support_bind_iff] at hrest + obtain ⟨⟨⟨verified, targetView⟩, finalCache⟩, hverify, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst rest + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) + have hrestSupport : + ((forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) ∈ + support (gameRestWithViewTrace adversary publicKey secretKey rootCache) := by + rw [hgame, mem_support_bind_iff] + refine ⟨(forgery, state), hprior, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨((verified, targetView), finalCache), hverify, + by simp only [support_pure, Set.mem_singleton_iff]⟩ + have hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret) := by + rw [gameAfterSecretsWithViewTrace, mem_support_bind_iff] + refine ⟨(root, rootCache), hroot, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨_, hrestSupport, by simp [result]⟩ + obtain ⟨f, digest, hf, hvalid, _, hdigest, hadmissible, + hcollision, _⟩ := hevent.1 + obtain ⟨cover, hcard, hne⟩ := + hcollision.exists_singletonFewTimeCover digest hdigest + have hcacheLe : state.cache ≤ finalCache := + simulateQ_romImpl_cache_le + (liftM (verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView)) state.cache + ((verified, targetView), finalCache) hverify + rcases gameAfterSecretsWithViewTrace_singletonCover_target_classified_at_adversary_state + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts result hresult + f hf digest hdigest hadmissible cover hcard hne hvalid rootCache state rfl rfl + hcacheLe with hfresh | hclassified + · exact hevent.2 hfresh + · obtain ⟨distinct, hdistinct, pattern, configuration, candidate, hterminal⟩ := + hclassified + subst distinct + apply hnotPrefix + unfold prefixEvent SomeFixedSingletonOriginTargetViewedTerminal + exact ⟨pattern, configuration, candidate, hterminal⟩ + _ ≤ _ := probEvent_someFixedSingletonOriginTargetViewedTerminal_le + secretKey (adversary.main publicKey) rootCache signatureLimit q q hqMax + (by + have hroot' : QueryCache.enncard rootCache ≤ q := by + have hprojected : (root, rootCache) ∈ support + ((simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅) := hroot + have hgameBound := isQueryBoundP_gameAfterSecrets adversary q hq + hparameter hots hfts + rw [gameAfterSecrets] at hgameBound + have hrootBound := OracleComp.IsQueryBoundP.of_bind_left + (p := fun input : OracleWorld.Domain => input matches Sum.inr _) hgameBound + have hbound := simulateQ_romImpl_enncard_le_queryBound + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest) q hrootBound + (root, rootCache) hprojected + exact hbound + exact hroot') q + +set_option maxRecDepth 1000000 in +set_option maxHeartbeats 2000000 in + +theorem probEvent_gameRestWithViewTrace_fresh_messageCollision_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (root : Digest) (rootCache : QueryCache HashSpec) + (hroot : (root, rootCache) ∈ support + ((simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅)) : + Pr[fun rest => + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, rest.1.1, rest.1.2), rest.2) + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache] ≤ + ((q + 1 : Nat) : ℝ≥0∞) * singletonOriginUnionBound signatureLimit q := by + classical + let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + let publicKey : PublicKey := ⟨root, parameter⟩ + let initialState : ViewedFullTraceState := + ⟨rootCache, ⟨[], [], []⟩, [], none⟩ + let run := (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState + let finish : Forgery × ViewedFullTraceState → + ProbComp ((Forgery × Bool) × ViewedFullTraceState) := fun prior => do + let ((verified, targetView), finalCache) ← + (simulateQ romImpl + (liftM (verifyWithView publicKey prior.1.message prior.1.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run prior.2.cache + let log := prior.2.trace.signing.toSigningLog + let verdict := decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log prior.1) && verified + pure ((prior.1, verdict), + ⟨finalCache, prior.2.trace, prior.2.views, some targetView⟩) + let freshEvent := fun rest : (Forgery × Bool) × ViewedFullTraceState => + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, rest.1.1, rest.1.2), rest.2) + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result + have hrootNone : ∀ payload, + rootCache (tweakableHashInput parameter .message payload) = none := by + have hroot' : (root, rootCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅) := by + simpa only [simulateQ_romImpl_liftM] using hroot + exact fun payload => treeRoot_cache_message_none parameter topLayer rootTree + (otsSecret topLayer rootTree) root rootCache hroot' payload + have hrootCache : QueryCache.enncard rootCache ≤ q := by + have hgameBound := isQueryBoundP_gameAfterSecrets adversary q hq + hparameter hots hfts + rw [gameAfterSecrets] at hgameBound + have hrootBound := OracleComp.IsQueryBoundP.of_bind_left + (p := fun input : OracleWorld.Domain => input matches Sum.inr _) hgameBound + exact simulateQ_romImpl_enncard_le_queryBound + (liftM ((treeRoot parameter topLayer rootTree + (otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest) q hrootBound (root, rootCache) hroot + have hprefixBound := + probEvent_someFixedOneOriginTargetViewedTerminal_le + (α := Forgery × HashOutput) (secretKey := secretKey) + (computation := adversaryWithTargetQuery adversary publicKey) + (initialCache := rootCache) (signatures := signatureLimit) (sources := q) + (q := q) (hq := hqMax) (hcache := hrootCache) (candidates := q + 1) + have hgame : gameRestWithViewTrace adversary publicKey secretKey rootCache = + run >>= finish := rfl + rw [show ⟨root, parameter⟩ = publicKey from rfl, + show ⟨parameter, root, otsSecret, ftsSecret⟩ = secretKey from rfl, hgame] + change Pr[freshEvent | run >>= finish] ≤ _ + have hfirst : Pr[freshEvent | run >>= finish] ≤ + Pr[SomeFixedOneOriginTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversaryWithTargetQuery adversary publicKey)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩] := by + rw [adversaryWithTargetQuery_viewed_run] + change Pr[_ | run >>= _] ≤ + Pr[SomeFixedOneOriginTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + run >>= _] + apply probEvent_bind_le_bind_of_forall_le + rintro ⟨forgery, state⟩ hprior + let input := tweakableHashInput parameter .message + (messageDigestPayload root forgery.message forgery.signature.randomness) + change Pr[_ | + (simulateQ romImpl + (liftM (verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run state.cache >>= _] ≤ _ + rw [verifyWithView_split_run] + simp only [bind_assoc] + rw [show tweakableHashInput publicKey.parameter .message + (messageDigestPayload publicKey.root forgery.message + forgery.signature.randomness) = input from rfl] + change _ ≤ Pr[SomeFixedOneOriginTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + (randomOracle input).run state.cache >>= pure ∘ fun source => + ((forgery, source.1), appendDirectTargetViewedState input state.cache + source.1 source.2 state)] + rw [probEvent_bind_pure_comp] + change Pr[_ | (randomOracle input).run state.cache >>= _] ≤ + Pr[fun source => SomeFixedOneOriginTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) + ((forgery, source.1), + appendDirectTargetViewedState input state.cache source.1 source.2 state) | + (randomOracle input).run state.cache] + apply probEvent_bind_le_probEvent + rintro ⟨output, digestCache⟩ hquery hnotPrefix + apply probEvent_eq_zero + intro rest hrest hevent + rw [mem_support_bind_iff] at hrest + obtain ⟨⟨⟨verified, targetView⟩, finalCache⟩, hverifyRest, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst rest + let result : (Digest × Forgery × Bool) × ViewedFullTraceState := + ((root, forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) + change ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result at hevent + have hverify : ((verified, targetView), finalCache) ∈ support + ((simulateQ romImpl + (liftM (verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView))).run state.cache) := by + rw [verifyWithView_split_run, mem_support_bind_iff] + exact ⟨(output, digestCache), by simpa only [input, publicKey] using hquery, + hverifyRest⟩ + have hrestSupport : + ((forgery, + decide (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) && + verified), + ⟨finalCache, state.trace, state.views, some targetView⟩) ∈ + support (gameRestWithViewTrace adversary publicKey secretKey rootCache) := by + rw [gameRestWithViewTrace, mem_support_bind_iff] + refine ⟨(forgery, state), hprior, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨((verified, targetView), finalCache), hverify, + by simp only [support_pure, Set.mem_singleton_iff]⟩ + have hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret) := by + rw [gameAfterSecretsWithViewTrace, mem_support_bind_iff] + refine ⟨(root, rootCache), hroot, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨_, hrestSupport, by simp [result]⟩ + obtain ⟨f, digest, hf, hvalid, _, hdigest, _, hcollision, _⟩ := hevent.1 + obtain ⟨cover, hcard, _⟩ := + hcollision.exists_singletonFewTimeCover digest hdigest + obtain ⟨otherRootCache, adversaryCache, _, _, hotherRootNone, + hotherChain, hadversaryMiss, _, _, _⟩ := hevent.2 + have hbase : (forgery, state.base) ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run initialState.base) := by + rw [← viewedFullTracedMappedAdversaryImpl_projection secretKey + (adversary.main publicKey) initialState, support_map] + exact ⟨(forgery, state), hprior, rfl⟩ + have hchain : FullAdversaryTrace.CacheChain rootCache state.trace.intervals + state.cache := + fullTracedMappedAdversaryImpl_cacheChain secretKey (adversary.main publicKey) + rootCache rootCache ⟨[], [], []⟩ (forgery, state.base) (by rfl) hbase + have hmiss : state.cache input = none := by + have hrootInput : rootCache input = none := by + simpa only [input] using hrootNone + (messageDigestPayload root forgery.message forgery.signature.randomness) + have hotherRootInput : otherRootCache input = none := by + simpa only [input, result] using hotherRootNone + (messageDigestPayload root forgery.message forgery.signature.randomness) + have hlookup := FullAdversaryTrace.CacheChain.finish_lookup_eq input + (hrootInput.trans hotherRootInput.symm) hchain + (by simpa only [result] using hotherChain) + exact hlookup.trans hadversaryMiss + have hdigestLe : digestCache ≤ finalCache := + simulateQ_romImpl_cache_le + (liftM (verifyWithViewAfterOutput publicKey forgery.signature output) : + OracleComp OracleWorld (Bool × FewTimeView)) digestCache + ((verified, targetView), finalCache) hverifyRest + have hcachedDigest : digestCache input = some output := + randomOracle_output_cached input state.cache digestCache output (by + have hquerySim : simulateQ (randomOracle : QueryImpl HashSpec _) + (oracleHash input) = randomOracle input := by + change simulateQ (randomOracle : QueryImpl HashSpec _) + (liftM (HashSpec.query input)) = randomOracle input + rw [simulateQ_spec_query] + rw [hquerySim] + exact hquery) + have hcachedFinal : finalCache input = some output := hdigestLe hcachedDigest + have hanswer : f input = output := hf (by simpa only [result] using hcachedFinal) + have hdigestOutput : truncateMessageDigest output = digest := by + have hdigest' : truncateMessageDigest (f input) = digest := by + simpa only [messageDigest, oracleHash, evalWithAnswerFn_bind, + evalWithAnswerFn_query, evalWithAnswerFn_pure, result, input] using hdigest + rwa [hanswer] at hdigest' + have htargetOutput : hashOutputFewTimeView output = + fewTimeTargetView (digestIndex digest) (digestLeaves digest) := by + simp [hashOutputFewTimeView, fewTimeTargetView, hdigestOutput] + have hfullBase : (result.1, result.2.base) ∈ support + (gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret) := by + rw [← gameAfterSecretsWithViewTrace_projection adversary parameter otsSecret + ftsSecret, support_map] + exact ⟨result, hresult, rfl⟩ + obtain ⟨configuration, hrealized⟩ := + cover.exists_paddedRealized_originConfiguration_of_queryBudget + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts + (result.1, result.2.base) hfullBase f hf (digestIndex digest) + (digestLeaves digest) signatureLimit hvalid + have hfinalCache : QueryCache.enncard finalCache ≤ q := by + have hbound := gameAfterSecretsWithFullTrace_support_enncard_le adversary q hq + parameter hparameter otsSecret hots ftsSecret hfts + (result.1, result.2.base) hfullBase + change QueryCache.enncard result.2.cache ≤ q at hbound + simpa only [result] using hbound + have hdigestCard : QueryCache.enncard digestCache ≤ q := + (QueryCache.enncard_mono hdigestLe).trans hfinalCache + have hcountLe : freshTargetCandidateCount secretKey state.trace ≤ q := by + rw [freshTargetCandidateCount_eq_card] + have hbound := gameAfterSecretsWithViewTrace_freshTargetCandidatePositions_card_le + adversary q hq parameter hparameter otsSecret hots ftsSecret hfts result hresult + simp only [result] at hbound + exact_mod_cast hbound + let candidate : Fin (q + 1) := + ⟨freshTargetCandidateCount secretKey state.trace, by omega⟩ + unfold SomeFixedOneOriginTargetViewedTerminal at hnotPrefix + apply hnotPrefix + refine ⟨cover.entries.card, hcard, cover.pattern.pad hvalid, + configuration, candidate, ?_⟩ + exact configuration.verifierTarget_fixedTerminal_for_cover adversary parameter otsSecret + ftsSecret result hresult f hf digest cover hvalid hrealized + rootCache state hprior rfl rfl input output digestCache rfl hmiss + (by simpa only [input] using hquery) hdigestLe htargetOutput q hdigestCard + calc + Pr[freshEvent | run >>= finish] ≤ + Pr[SomeFixedOneOriginTargetViewedTerminal secretKey + (adversaryWithTargetQuery adversary publicKey) rootCache signatureLimit q q (q + 1) | + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) + (adversaryWithTargetQuery adversary publicKey)).run + ⟨rootCache, ⟨[], [], []⟩, [], none⟩] := hfirst + _ ≤ ((q + 1 : Nat) : ℝ≥0∞) * singletonOriginUnionBound signatureLimit q := + hprefixBound + +theorem probEvent_gameAfterSecretsWithViewTrace_nonfresh_messageCollision_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun result => + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + ¬VerifierFreshTarget parameter result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + q * singletonOriginUnionBound signatureLimit q := by + rw [gameAfterSecretsWithViewTrace] + apply probEvent_bind_le_of_forall_le + rintro ⟨root, rootCache⟩ hroot + let attach := fun rest : (Forgery × Bool) × ViewedFullTraceState => + ((root, rest.1.1, rest.1.2), rest.2) + change Pr[fun result => + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + ¬VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache >>= pure ∘ attach] ≤ _ + rw [probEvent_bind_pure_comp] + exact probEvent_gameRestWithViewTrace_nonfresh_messageCollision_le adversary q hq hqMax + parameter hparameter otsSecret hots ftsSecret hfts root rootCache hroot + +theorem probEvent_gameAfterSecretsWithViewTrace_fresh_messageCollision_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun result => + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + ((q + 1 : Nat) : ℝ≥0∞) * singletonOriginUnionBound signatureLimit q := by + rw [gameAfterSecretsWithViewTrace] + apply probEvent_bind_le_of_forall_le + rintro ⟨root, rootCache⟩ hroot + let attach := fun rest : (Forgery × Bool) × ViewedFullTraceState => + ((root, rest.1.1, rest.1.2), rest.2) + change Pr[fun result => + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result | + gameRestWithViewTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache >>= pure ∘ attach] ≤ _ + rw [probEvent_bind_pure_comp] + exact probEvent_gameRestWithViewTrace_fresh_messageCollision_le adversary q hq hqMax + parameter hparameter otsSecret hots ftsSecret hfts root rootCache hroot + +theorem probEvent_gameAfterSecretsWithViewTrace_messageCollision_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + q * singletonOriginUnionBound signatureLimit q + + ((q + 1 : Nat) : ℝ≥0∞) * singletonOriginUnionBound signatureLimit q := by + classical + calc + _ ≤ Pr[fun result => + (ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + ¬VerifierFreshTarget parameter result) ∨ + (ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result ∧ + VerifierFreshTarget parameter result) | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + apply probEvent_mono + intro result _ hcollision + by_cases hfresh : VerifierFreshTarget parameter result + · exact Or.inr ⟨hcollision, hfresh⟩ + · exact Or.inl ⟨hcollision, hfresh⟩ + _ ≤ _ := (probEvent_or_le _ _ _).trans (add_le_add + (probEvent_gameAfterSecretsWithViewTrace_nonfresh_messageCollision_le adversary q hq + hqMax parameter hparameter otsSecret hots ftsSecret hfts) + (probEvent_gameAfterSecretsWithViewTrace_fresh_messageCollision_le adversary q hq + hqMax parameter hparameter otsSecret hots ftsSecret hfts)) + +theorem probEvent_gameAfterSecretsWithViewTrace_messageCollision_le_inv + (adversary : Adversary) (q : Nat) (hqPos : 1 ≤ q) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ ≤ q * singletonOriginUnionBound signatureLimit q + + ((q + 1 : Nat) : ℝ≥0∞) * singletonOriginUnionBound signatureLimit q := + probEvent_gameAfterSecretsWithViewTrace_messageCollision_le adversary q hq hqMax + parameter hparameter otsSecret hots ftsSecret hfts + _ = ((2 * q + 1 : Nat) : ℝ≥0∞) * + singletonOriginUnionBound signatureLimit q := by + push_cast + ring + _ ≤ ((2 * q + 1 : Nat) : ℝ≥0∞) * + ((2 ^ 141 : Nat) : ℝ≥0∞)⁻¹ := by + have hmass := singletonOriginUnionBound_le_inv q hqMax + calc + ((2 * q + 1 : Nat) : ℝ≥0∞) * singletonOriginUnionBound signatureLimit q = + singletonOriginUnionBound signatureLimit q * (2 * q + 1 : Nat) := mul_comm _ _ + _ ≤ ((2 ^ 141 : Nat) : ℝ≥0∞)⁻¹ * (2 * q + 1 : Nat) := + mul_le_mul_left hmass _ + _ = ((2 * q + 1 : Nat) : ℝ≥0∞) * + ((2 ^ 141 : Nat) : ℝ≥0∞)⁻¹ := mul_comm _ _ + _ ≤ ((4 * q : Nat) : ℝ≥0∞) * + ((2 ^ 141 : Nat) : ℝ≥0∞)⁻¹ := by + have hcoeff : ((2 * q + 1 : Nat) : ℝ≥0∞) ≤ (4 * q : Nat) := by + exact_mod_cast (show 2 * q + 1 ≤ 4 * q by omega) + exact mul_le_mul_left hcoeff ((2 ^ 141 : Nat) : ℝ≥0∞)⁻¹ + _ = (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_natCast] + norm_num + ring + +theorem probEvent_sampled_cleanMessage_le + (adversary : Adversary) (q : Nat) (hqPos : 1 ≤ q) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + Pr[SampledViewedEvent cleanMessageEvent | sampledViewedGame adversary] ≤ + (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ := by + rw [probEvent_sampledViewedGame_eq_weighted] + calc + (∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets] * + Pr[cleanMessageEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret]) ≤ + ∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets] * + ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹) := by + apply ENNReal.tsum_le_tsum + intro secrets + by_cases hsecrets : secrets ∈ support sampleSecrets + · obtain ⟨hparameter, hots, hfts⟩ := secrets.support_components hsecrets + have hrisk : + Pr[cleanMessageEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret] ≤ + (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ := by + apply le_trans (probEvent_mono fun _ _ event => event.2) + exact probEvent_gameAfterSecretsWithViewTrace_messageCollision_le_inv adversary q + hqPos hq hqMax secrets.parameter hparameter secrets.otsSecret hots + secrets.ftsSecret hfts + calc + Pr[= secrets | sampleSecrets] * + Pr[cleanMessageEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret] = + Pr[cleanMessageEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret] * Pr[= secrets | sampleSecrets] := mul_comm _ _ + _ ≤ ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹) * + Pr[= secrets | sampleSecrets] := + mul_le_mul_left hrisk _ + _ = Pr[= secrets | sampleSecrets] * + ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹) := mul_comm _ _ + · rw [probOutput_eq_zero_of_not_mem_support hsecrets, zero_mul, zero_mul] + _ = (∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets]) * + ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹) := by + rw [ENNReal.tsum_mul_right] + _ ≤ 1 * ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹) := + mul_le_mul_left tsum_probOutput_le_one _ + _ = (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ := one_mul _ + +end SphincsSecurity.Concrete.Range125 diff --git a/formal/sphincs/SphincsSecurity/Proof/MessagePrehit.lean b/formal/sphincs/SphincsSecurity/Proof/MessagePrehit.lean new file mode 100644 index 00000000..9816d942 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/MessagePrehit.lean @@ -0,0 +1,284 @@ +import SphincsSecurity.Proof.Replay +import SphincsSecurity.Proof.NoMessage +import SphincsSecurity.Proof.StatementLemmas +import Mathlib.Data.Set.Card.Arithmetic + +/-! +# Cached message inputs + +A uniformly sampled signer randomizer addresses an input already in a fixed cache with probability +at most the number of matching cache entries divided by the randomizer space. This is used only +while retaining the few-time coverage event that the cached answer must also satisfy. +-/ + +open OracleComp OracleSpec ENNReal + +namespace SphincsSecurity + +noncomputable local instance : SampleableType Randomness := + SampleableType.ofFintype Randomness + +def cachedMessageInputSet (cache : QueryCache HashSpec) (parameter : PublicParameter) + (root : Digest) (message : Message) : + Set ((t : HashSpec.Domain) × HashSpec.Range t) := + {entry ∈ cache.toSet | ∃ randomness, + entry.1 = tweakableHashInput parameter .message + (Concrete.messageDigestPayload root message randomness)} + +noncomputable def cachedMessageEntryCount (cache : QueryCache HashSpec) + (parameter : PublicParameter) (root : Digest) (message : Message) : ℝ≥0∞ := + (((cachedMessageInputSet cache parameter root message).encard : ENat) : ℝ≥0∞) + +theorem card_randomness : Fintype.card Randomness = 2 ^ randomnessBits := by + simp + +noncomputable def Concrete.signDigestLoopContinuation + (attempts : Nat) (secretKey : SecretKey) (message : Message) + (randomness : Randomness) + (result : Option (Index × (DigestTree → FtsLeaf)) × QueryCache HashSpec) : + ProbComp (Option (Randomness × Index × (DigestTree → FtsLeaf)) × + QueryCache HashSpec) := + match result.1 with + | some (index, leaves) => pure (some (randomness, index, leaves), result.2) + | none => (simulateQ romImpl + (Concrete.signDigestLoop attempts secretKey message)).run result.2 + +attribute [irreducible] Concrete.signDigestLoopContinuation + +theorem Concrete.signDigestLoop_run_succ_eq + (attempts : Nat) (secretKey : SecretKey) (message : Message) + (cache : QueryCache HashSpec) : + (simulateQ romImpl + (Concrete.signDigestLoop (attempts + 1) secretKey message)).run cache = + (($ᵗ Randomness) >>= fun randomness => + (simulateQ randomOracle + (Concrete.signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf))))).run cache >>= + Concrete.signDigestLoopContinuation attempts secretKey message randomness) := by + rw [Concrete.signDigestLoop, simulateQ_bind, StateT.run_bind] + have hsampleRun : + (simulateQ romImpl (liftM Concrete.sampleRandomness)).run cache = + (fun randomness => (randomness, cache)) <$> Concrete.sampleRandomness := by + change (simulateQ (unifFwdImpl HashSpec + + (randomOracle : QueryImpl HashSpec + (StateT (QueryCache HashSpec) ProbComp))) + (liftM Concrete.sampleRandomness)).run cache = _ + exact roSim.run_liftM + (hashSpec := HashSpec) + (randomOracle : QueryImpl HashSpec (StateT (QueryCache HashSpec) ProbComp)) + Concrete.sampleRandomness cache + rw [hsampleRun, Concrete.sampleRandomness_eq] + simp only [map_eq_bind_pure_comp, bind_assoc, Function.comp_apply, pure_bind] + apply bind_congr + intro randomness + rw [simulateQ_bind, StateT.run_bind] + have hroute : + simulateQ romImpl + (liftM (Concrete.signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf))))) = + simulateQ randomOracle + (Concrete.signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))) := by + change simulateQ (unifFwdImpl HashSpec + randomOracle) + (liftM (Concrete.signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf))))) = _ + exact QueryImpl.simulateQ_add_liftM_right (unifFwdImpl HashSpec) + (randomOracle : QueryImpl HashSpec (StateT (QueryCache HashSpec) ProbComp)) + (Concrete.signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))) + rw [hroute] + apply bind_congr + intro result + rcases result with ⟨result, resultCache⟩ + cases result with + | none => simp [Concrete.signDigestLoopContinuation] + | some selected => + rcases selected with ⟨index, leaves⟩ + simp [Concrete.signDigestLoopContinuation] + +set_option maxRecDepth 100000 in +theorem uniform_randomness_messageInput_cacheHit_le_cachedMessageEntryCount + (parameter : PublicParameter) (root : Digest) (message : Message) + (cache : QueryCache HashSpec) : + Pr[fun randomness : Randomness => ∃ output, + cache (tweakableHashInput parameter .message + (Concrete.messageDigestPayload root message randomness)) = some output | + $ᵗ Randomness] ≤ + cachedMessageEntryCount cache parameter root message * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ := by + classical + let hit : Randomness → Prop := fun randomness => ∃ output, + cache (tweakableHashInput parameter .message + (Concrete.messageDigestPayload root message randomness)) = some output + let targets : Finset Randomness := Finset.univ.filter hit + let fiber := cachedMessageInputSet cache parameter root message + have hcard : (targets.card : ℝ≥0∞) ≤ + cachedMessageEntryCount cache parameter root message := by + let embedding : (targets : Set Randomness) ↪ fiber := + ⟨fun randomness => + ⟨⟨tweakableHashInput parameter .message + (Concrete.messageDigestPayload root message randomness.1), + Classical.choose (Finset.mem_filter.mp randomness.2).2⟩, + ⟨Classical.choose_spec (Finset.mem_filter.mp randomness.2).2, + ⟨randomness.1, rfl⟩⟩⟩, + fun left right heq => Subtype.ext <| + (Concrete.messageDigestPayload_injective root <| + (tweakableHashInput_injective parameter (by trivial) (by trivial) <| + congrArg (fun entry : fiber => entry.1.1) heq).2).2⟩ + simpa only [cachedMessageEntryCount, fiber, + Set.encard_coe_eq_coe_finsetCard, ENat.toENNReal_coe] using + ENat.toENNReal_mono embedding.encard_le + rw [probEvent_uniformSample, card_randomness, div_eq_mul_inv] + change (targets.card : ℝ≥0∞) * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ ≤ _ + exact mul_le_mul' hcard le_rfl + +set_option linter.constructorNameAsVariable false in +theorem Concrete.signDigestLoop_messageInput_referenceCache_hit_le_cachedCount + (attempts : Nat) (secretKey : SecretKey) (message : Message) + (referenceCache workingCache : QueryCache HashSpec) : + Pr[fun result : Option (Randomness × Index × (DigestTree → FtsLeaf)) × + QueryCache HashSpec => + ∃ randomness index leaves, result.1 = some (randomness, index, leaves) ∧ + ∃ output, referenceCache + (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message randomness)) = some output | + (simulateQ romImpl + (Concrete.signDigestLoop attempts secretKey message)).run workingCache] ≤ + (attempts : ℝ≥0∞) * + cachedMessageEntryCount referenceCache secretKey.parameter secretKey.root message * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ := by + induction attempts generalizing workingCache with + | zero => + simp [Concrete.signDigestLoop] + | succ attempts ih => + rw [Concrete.signDigestLoop_run_succ_eq] + refine (probEvent_bind_le_probEvent_add + (p := fun randomness : Randomness => ∃ output, + referenceCache + (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message randomness)) = some output) + (ε := (attempts : ℝ≥0∞) * + cachedMessageEntryCount referenceCache secretKey.parameter secretKey.root message * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹) ?_).trans ?_ + · intro randomness _hrandomness hmiss + refine probEvent_bind_le_of_forall_le fun attemptResult _hattempt => ?_ + cases hresult : attemptResult.1 with + | none => + simpa [Concrete.signDigestLoopContinuation, hresult] using + ih attemptResult.2 + | some selected => + rcases selected with ⟨selectedIndex, selectedLeaves⟩ + refine le_of_eq_of_le (probEvent_eq_zero ?_) zero_le + intro result hsupport hevent + have hsupport' : result ∈ support + (pure (some (randomness, selectedIndex, selectedLeaves), attemptResult.2) : + ProbComp (Option (Randomness × Index × (DigestTree → FtsLeaf)) × + QueryCache HashSpec)) := by + simpa [Concrete.signDigestLoopContinuation, hresult] using hsupport + obtain ⟨foundRandomness, foundIndex, foundLeaves, hfound, output, hhit⟩ := hevent + have hreturned : result.1 = + some (randomness, selectedIndex, selectedLeaves) := by + simpa only [support_pure, Set.mem_singleton_iff] using + congrArg Prod.fst hsupport' + have hrandomness : randomness = foundRandomness := congrArg Prod.fst <| + Option.some.inj (hreturned.symm.trans hfound) + apply hmiss + refine ⟨output, ?_⟩ + rw [hrandomness] + exact hhit + · calc + _ ≤ cachedMessageEntryCount referenceCache secretKey.parameter secretKey.root message * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ + + (attempts : ℝ≥0∞) * + cachedMessageEntryCount referenceCache secretKey.parameter secretKey.root message * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ := + add_le_add + (uniform_randomness_messageInput_cacheHit_le_cachedMessageEntryCount + secretKey.parameter secretKey.root message referenceCache) le_rfl + _ = _ := by + push_cast + ring + +theorem Concrete.signAfterDigest_some_randomness (f : QueryImpl HashSpec Id) + (secretKey : SecretKey) (randomness : Randomness) (index : Index) + (leaves : DigestTree → FtsLeaf) (signature : Signature) + (heval : evalWithAnswerFn f + (Concrete.signAfterDigest secretKey randomness index leaves) = some signature) : + signature.randomness = randomness := by + simp only [Concrete.signAfterDigest, evalWithAnswerFn_bind] at heval + split at heval + · simp only [evalWithAnswerFn_pure, reduceCtorEq] at heval + · simp only [evalWithAnswerFn_pure, Option.some.injEq] at heval + subst signature + rfl + +theorem Concrete.signAfterDigest_support_some_randomness + (secretKey : SecretKey) (randomness : Randomness) (index : Index) + (leaves : DigestTree → FtsLeaf) (beforeCache afterCache : QueryCache HashSpec) + (signature : Signature) + (hmem : (some signature, afterCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (Concrete.signAfterDigest secretKey randomness index leaves)).run beforeCache)) : + signature.randomness = randomness := by + obtain ⟨_, answerFn, _, heval⟩ := + exists_answerFn_agrees_final_of_mem_support + (Concrete.signAfterDigest secretKey randomness index leaves) + beforeCache (some signature) afterCache hmem + exact Concrete.signAfterDigest_some_randomness answerFn secretKey randomness index leaves + signature heval + +set_option linter.constructorNameAsVariable false in +theorem Concrete.sign_messageInput_initialCache_hit_le_cachedCount + (secretKey : SecretKey) (message : Message) (cache : QueryCache HashSpec) : + Pr[fun result : Option Signature × QueryCache HashSpec => + ∃ signature, result.1 = some signature ∧ ∃ output, + cache (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message signature.randomness)) = + some output | + (simulateQ romImpl (Concrete.sign secretKey message)).run cache] ≤ + (digestAttemptLimit : ℝ≥0∞) * + cachedMessageEntryCount cache secretKey.parameter secretKey.root message * + ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [Concrete.sign_eq_digestLoop_afterDigest, simulateQ_bind, StateT.run_bind] + refine (probEvent_bind_le_probEvent + (p := fun loopResult : Option (Randomness × Index × (DigestTree → FtsLeaf)) × + QueryCache HashSpec => + ∃ randomness index leaves, loopResult.1 = some (randomness, index, leaves) ∧ + ∃ output, cache + (tweakableHashInput secretKey.parameter .message + (Concrete.messageDigestPayload secretKey.root message randomness)) = some output) + ?_).trans + (Concrete.signDigestLoop_messageInput_referenceCache_hit_le_cachedCount + digestAttemptLimit secretKey message cache cache) + intro loopResult _hloop hmiss + refine probEvent_eq_zero ?_ + intro result hresult hevent + cases hloopResult : loopResult.1 with + | none => + have hresult' : result ∈ support + (pure (none, loopResult.2) : + ProbComp (Option Signature × QueryCache HashSpec)) := by + simpa [hloopResult] using hresult + obtain ⟨signature, hsignature, _⟩ := hevent + have hnone : result.1 = none := by + simpa only [support_pure, Set.mem_singleton_iff] using + congrArg Prod.fst hresult' + simp [hnone] at hsignature + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + obtain ⟨signature, hsignature, output, hhit⟩ := hevent + have hresult' : (some signature, result.2) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (Concrete.signAfterDigest secretKey randomness index leaves)).run loopResult.2) := by + have hpair : result = (some signature, result.2) := Prod.ext hsignature rfl + rw [← hpair] + simpa only [hloopResult, simulateQ_romImpl_liftM] using hresult + have hrandomness := Concrete.signAfterDigest_support_some_randomness secretKey randomness + index leaves loopResult.2 result.2 signature hresult' + apply hmiss + refine ⟨randomness, index, leaves, hloopResult, output, ?_⟩ + rw [← hrandomness] + exact hhit + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/NoMessage.lean b/formal/sphincs/SphincsSecurity/Proof/NoMessage.lean new file mode 100644 index 00000000..f87e6187 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/NoMessage.lean @@ -0,0 +1,264 @@ +import SphincsSecurity.Proof.RootCache + +/-! +# Hash-only computations outside the digest loop make no message query + +After the signer's digest loop has selected an admissible digest, all remaining hash calls use +structural or encoding domains. This module records the corresponding execution-path fact. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +def AvoidsMessageQueries {alpha : Type} (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (oa : OracleComp HashSpec alpha) : Prop := + ∀ payload, tweakableHashInput parameter .message payload ∉ queriedInputs f oa + +theorem AvoidsMessageQueries.pure {alpha : Type} (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (value : alpha) : + AvoidsMessageQueries parameter f (pure value) := by + simp [AvoidsMessageQueries] + +theorem AvoidsMessageQueries.bind {alpha beta : Type} {parameter : PublicParameter} + {f : QueryImpl HashSpec Id} {oa : OracleComp HashSpec alpha} + {next : alpha → OracleComp HashSpec beta} + (hleft : AvoidsMessageQueries parameter f oa) + (hright : AvoidsMessageQueries parameter f (next (evalWithAnswerFn f oa))) : + AvoidsMessageQueries parameter f (oa >>= next) := by + intro payload hmem + rw [queriedInputs_bind] at hmem + rcases List.mem_append.mp hmem with hmem | hmem + · exact hleft payload hmem + · exact hright payload hmem + +theorem AvoidsMessageQueries.tweakableHash (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (domain : HashDomain) (hdomain : domain ≠ .message) + (payload : HashInput) : + AvoidsMessageQueries parameter f + (Concrete.tweakableHash parameter domain payload) := by + intro messagePayload hmem + simp only [queriedInputs_tweakableHash, List.mem_singleton] at hmem + exact tweakableHashInput_ne_message parameter domain hdomain payload messagePayload hmem.symm + +theorem QueriesAtPositions.avoidsMessage {alpha : Type} {parameter : PublicParameter} + {f : QueryImpl HashSpec Id} {oa : OracleComp HashSpec alpha} + (h : QueriesAtPositions parameter f oa) : AvoidsMessageQueries parameter f oa := by + intro payload hmem + obtain ⟨p, structuralPayload, heq⟩ := h _ hmem + exact tweakableHashInput_ne_message parameter p.domain (by cases p <;> simp [Position.domain]) + structuralPayload payload heq.symm + +namespace Concrete + +theorem avoidsMessage_sequenceFin {alpha : Type} {n : Nat} + (parameter : PublicParameter) (f : QueryImpl HashSpec Id) + (computation : Fin n → OracleComp HashSpec alpha) + (hcomputation : ∀ index, AvoidsMessageQueries parameter f (computation index)) : + AvoidsMessageQueries parameter f (sequenceFin computation) := by + induction n with + | zero => exact AvoidsMessageQueries.pure parameter f _ + | succ n ih => + rw [sequenceFin] + apply AvoidsMessageQueries.bind (hcomputation 0) + apply AvoidsMessageQueries.bind + · exact ih (fun index : Fin n => computation index.succ) + (fun index => hcomputation index.succ) + · exact AvoidsMessageQueries.pure parameter f _ + +theorem avoidsMessage_chainWalk (parameter : PublicParameter) (f : QueryImpl HashSpec Id) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (start steps : Nat) (value : Digest) : + AvoidsMessageQueries parameter f + (chainWalk parameter lay tree leafIdx chainIdx start steps value) := + (queriesAtPositions_chainWalk parameter f lay tree leafIdx chainIdx start steps value).avoidsMessage + +theorem avoidsMessage_oneTimePublicKey (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (secret : ChainIndex → Digest) : + AvoidsMessageQueries parameter f + (oneTimePublicKey parameter lay tree leafIdx secret) := + (queriesAtPositions_oneTimePublicKey parameter f lay tree leafIdx secret).avoidsMessage + +theorem avoidsMessage_treeNode (parameter : PublicParameter) (f : QueryImpl HashSpec Id) + (lay : Layer) (tree : TreeIndex) (secret : LeafIndex → ChainIndex → Digest) + (level nodeIdx : Nat) : + AvoidsMessageQueries parameter f (treeNode parameter lay tree secret level nodeIdx) := by + induction level generalizing nodeIdx with + | zero => + rw [treeNode_zero_eq] + apply AvoidsMessageQueries.bind + · exact avoidsMessage_oneTimePublicKey parameter f lay tree (leafOfNat nodeIdx) + (secret (leafOfNat nodeIdx)) + · exact AvoidsMessageQueries.tweakableHash parameter f _ (by simp) _ + | succ level ih => + rw [treeNode_succ_eq] + apply AvoidsMessageQueries.bind (ih (2 * nodeIdx)) + apply AvoidsMessageQueries.bind (ih (2 * nodeIdx + 1)) + exact AvoidsMessageQueries.tweakableHash parameter f _ (by simp) _ + +theorem avoidsMessage_treeRoot (parameter : PublicParameter) (f : QueryImpl HashSpec Id) + (lay : Layer) (tree : TreeIndex) (secret : LeafIndex → ChainIndex → Digest) : + AvoidsMessageQueries parameter f (treeRoot parameter lay tree secret) := by + exact avoidsMessage_treeNode parameter f lay tree secret (layerHeight lay) 0 + +theorem avoidsMessage_treePath (parameter : PublicParameter) (f : QueryImpl HashSpec Id) + (lay : Layer) (tree : TreeIndex) (secret : LeafIndex → ChainIndex → Digest) + (leafIdx : LeafIndex) : + AvoidsMessageQueries parameter f (treePath parameter lay tree secret leafIdx) := by + apply avoidsMessage_sequenceFin + intro level + split + · exact avoidsMessage_treeNode parameter f lay tree secret _ _ + · exact AvoidsMessageQueries.pure parameter f _ + +theorem avoidsMessage_encode (parameter : PublicParameter) (f : QueryImpl HashSpec Id) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (counter : Counter) : + AvoidsMessageQueries parameter f (encode parameter lay tree leafIdx message counter) := by + simp only [encode] + apply AvoidsMessageQueries.bind + · exact AvoidsMessageQueries.tweakableHash parameter f _ (by simp) _ + · exact AvoidsMessageQueries.pure parameter f _ + +theorem avoidsMessage_otsSignFrom (parameter : PublicParameter) (f : QueryImpl HashSpec Id) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (secret : ChainIndex → Digest) (message : Digest) (attempts counter : Nat) : + AvoidsMessageQueries parameter f + (otsSignFrom parameter lay tree leafIdx secret message attempts counter) := by + induction attempts generalizing counter with + | zero => exact AvoidsMessageQueries.pure parameter f _ + | succ attempts ih => + rw [otsSignFrom] + apply AvoidsMessageQueries.bind + · exact avoidsMessage_encode parameter f lay tree leafIdx message _ + split + · apply AvoidsMessageQueries.bind + · apply avoidsMessage_sequenceFin + intro chainIdx + exact avoidsMessage_chainWalk parameter f lay tree leafIdx chainIdx 0 _ _ + · exact AvoidsMessageQueries.pure parameter f _ + · exact ih (counter + 1) + +theorem avoidsMessage_otsSign (parameter : PublicParameter) (f : QueryImpl HashSpec Id) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (secret : ChainIndex → Digest) (message : Digest) : + AvoidsMessageQueries parameter f + (otsSign parameter lay tree leafIdx secret message) := by + exact avoidsMessage_otsSignFrom parameter f lay tree leafIdx secret message + encodingAttemptLimit 0 + +theorem avoidsMessage_ftsLeafHash (parameter : PublicParameter) (f : QueryImpl HashSpec Id) + (index : Index) (tree : FtsTree) (leafIdx : FtsLeaf) (secret : Digest) : + AvoidsMessageQueries parameter f (ftsLeafHash parameter index tree leafIdx secret) := by + exact AvoidsMessageQueries.tweakableHash parameter f _ (by simp) _ + +theorem avoidsMessage_ftsNode (parameter : PublicParameter) (f : QueryImpl HashSpec Id) + (index : Index) (tree : FtsTree) (secret : FtsLeaf → Digest) + (level nodeIdx : Nat) : + AvoidsMessageQueries parameter f (ftsNode parameter index tree secret level nodeIdx) := by + induction level generalizing nodeIdx with + | zero => + rw [ftsNode_zero_eq] + exact avoidsMessage_ftsLeafHash parameter f index tree _ _ + | succ level ih => + rw [ftsNode_succ_eq] + apply AvoidsMessageQueries.bind (ih (2 * nodeIdx)) + apply AvoidsMessageQueries.bind (ih (2 * nodeIdx + 1)) + exact AvoidsMessageQueries.tweakableHash parameter f _ (by simp) _ + +theorem avoidsMessage_ftsKey (parameter : PublicParameter) (f : QueryImpl HashSpec Id) + (index : Index) (secret : FtsTree → FtsLeaf → Digest) : + AvoidsMessageQueries parameter f (ftsKey parameter index secret) := by + rw [ftsKey] + apply AvoidsMessageQueries.bind + · apply avoidsMessage_sequenceFin + intro tree + exact avoidsMessage_ftsNode parameter f index tree (secret tree) ftsTreeHeight 0 + · exact AvoidsMessageQueries.tweakableHash parameter f _ (by simp) _ + +theorem avoidsMessage_ftsOpen (parameter : PublicParameter) (f : QueryImpl HashSpec Id) + (index : Index) (leaves : DigestTree → FtsLeaf) + (secret : FtsTree → FtsLeaf → Digest) : + AvoidsMessageQueries parameter f (ftsOpen parameter index leaves secret) := by + apply avoidsMessage_sequenceFin + intro tree + apply avoidsMessage_sequenceFin + intro level + exact avoidsMessage_ftsNode parameter f index tree (secret tree) level.val _ + +theorem avoidsMessage_layerMessage (f : QueryImpl HashSpec Id) (secretKey : SecretKey) + (index : Index) (lay : Layer) : + AvoidsMessageQueries secretKey.parameter f (layerMessage secretKey index lay) := by + rw [layerMessage] + split + · exact avoidsMessage_treeRoot secretKey.parameter f _ _ _ + · exact avoidsMessage_ftsKey secretKey.parameter f index (secretKey.ftsSecret index) + +theorem avoidsMessage_signLayer (f : QueryImpl HashSpec Id) (secretKey : SecretKey) + (index : Index) (lay : Layer) : + AvoidsMessageQueries secretKey.parameter f (signLayer secretKey index lay) := by + rw [signLayer] + apply AvoidsMessageQueries.bind + · exact avoidsMessage_layerMessage f secretKey index lay + apply AvoidsMessageQueries.bind + · exact avoidsMessage_otsSign secretKey.parameter f lay (treeIndexAt index lay) + (leafIndexAt index lay) _ _ + split + · exact AvoidsMessageQueries.pure secretKey.parameter f _ + · apply AvoidsMessageQueries.bind + · exact avoidsMessage_treePath secretKey.parameter f lay (treeIndexAt index lay) _ + (leafIndexAt index lay) + · exact AvoidsMessageQueries.pure secretKey.parameter f _ + +def signAfterDigest (secretKey : SecretKey) (randomness : Randomness) (index : Index) + (leaves : DigestTree → FtsLeaf) : OracleComp HashSpec (Option Signature) := do + let ftsPath ← ftsOpen secretKey.parameter index leaves (secretKey.ftsSecret index) + let layers ← sequenceFin fun lay => signLayer secretKey index lay + match traverseOption layers with + | none => return none + | some parts => + return some + { randomness := randomness + ftsSecret := fun tree => secretKey.ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (parts lay).2.1 + authPath := flattenPaths fun lay => (parts lay).2.2 } + +theorem avoidsMessage_signAfterDigest (f : QueryImpl HashSpec Id) (secretKey : SecretKey) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + AvoidsMessageQueries secretKey.parameter f + (signAfterDigest secretKey randomness index leaves) := by + rw [signAfterDigest] + apply AvoidsMessageQueries.bind + · exact avoidsMessage_ftsOpen secretKey.parameter f index leaves (secretKey.ftsSecret index) + apply AvoidsMessageQueries.bind + · apply avoidsMessage_sequenceFin + intro lay + exact avoidsMessage_signLayer f secretKey index lay + · split <;> exact AvoidsMessageQueries.pure secretKey.parameter f _ + +theorem sign_eq_digestLoop_afterDigest (secretKey : SecretKey) (message : Message) : + sign secretKey message = (do + match ← signDigestLoop digestAttemptLimit secretKey message with + | none => return none + | some (randomness, index, leaves) => + liftM (signAfterDigest secretKey randomness index leaves)) := by + rw [sign_eq] + apply bind_congr + intro loopResult + cases loopResult with + | none => rfl + | some data => + rcases data with ⟨randomness, index, leaves⟩ + simp only [signAfterDigest, liftM_bind] + apply bind_congr + intro ftsPath + apply bind_congr + intro layers + split <;> simp_all + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/OneTime.lean b/formal/sphincs/SphincsSecurity/Proof/OneTime.lean new file mode 100644 index 00000000..8bcc6eba --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OneTime.lean @@ -0,0 +1,68 @@ +import SphincsSecurity.Proof.Eval + +/-! +# The one-time signature + +`Ots.leaf` recovers the leaf `Ots.sign` committed to. The counter matters only through the codeword +it produces: correctness holds for *any* admissible counter, not just the least one the signer +takes, which is why a second admissible counter for the same codeword is a strong forgery rather +than a break. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp + +variable {α : Type} (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leaf : LeafIndex) + +/-- Steps compose under evaluation. -/ +theorem eval_chainWalk_add (chainIdx : ChainIndex) (start a b : Nat) (value : Digest) : + evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx start (a + b) value) + = evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx (start + a) b + (evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx start a value))) := by + rw [chainWalk_add, evalWithAnswerFn_bind] + +/-- Revealing a chain at its codeword digit and walking the rest reaches the public value. -/ +theorem eval_recoverChain (chainIdx : ChainIndex) (digit : Digit) (value : Digest) : + evalWithAnswerFn f (recoverChain parameter lay tree leaf chainIdx digit + (evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx 0 digit.val value))) + = evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx 0 (chainLength - 1) value) := by + have hdigit : digit.val + (chainLength - 1 - digit.val) = chainLength - 1 := by + have hlt := digit.isLt + simp only [chainLength, winternitzBits] at hlt + simp only [chainLength, winternitzBits] + omega + calc evalWithAnswerFn f (recoverChain parameter lay tree leaf chainIdx digit + (evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx 0 digit.val value))) + = evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx + (0 + digit.val) (chainLength - 1 - digit.val) + (evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx 0 digit.val value))) := by + rw [recoverChain, Nat.zero_add] + _ = evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx 0 + (digit.val + (chainLength - 1 - digit.val)) value) := (eval_chainWalk_add ..).symm + _ = evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx 0 (chainLength - 1) value) := by + rw [hdigit] + +/-- The honest one-time public value of one chain. -/ +theorem eval_oneTimePublicKey (secret : ChainIndex → Digest) : + evalWithAnswerFn f (oneTimePublicKey parameter lay tree leaf secret) + = fun chainIdx => evalWithAnswerFn f + (chainWalk parameter lay tree leaf chainIdx 0 (chainLength - 1) (secret chainIdx)) := by + simp [oneTimePublicKey] + +/-- **One-time correctness.** Given a counter that encodes the message to `codeword`, the chain +values the signer reveals recover the leaf key generation built. -/ +theorem eval_otsLeaf (secret : ChainIndex → Digest) (message : Digest) (counter : Counter) + (codeword : Encoding) + (hencode : evalWithAnswerFn f (encode parameter lay tree leaf message counter) = some codeword) : + evalWithAnswerFn f (otsLeaf parameter lay tree leaf message counter + (fun chainIdx => evalWithAnswerFn f + (chainWalk parameter lay tree leaf chainIdx 0 (codeword chainIdx).val (secret chainIdx)))) + = some (evalWithAnswerFn f (do + let endpoints ← oneTimePublicKey parameter lay tree leaf secret + leafHash parameter lay tree leaf endpoints)) := by + simp only [otsLeaf, evalWithAnswerFn_bind, evalWithAnswerFn_pure, hencode, + evalWithAnswerFn_sequenceFin, eval_recoverChain, eval_oneTimePublicKey] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/OneTimeEvents.lean b/formal/sphincs/SphincsSecurity/Proof/OneTimeEvents.lean new file mode 100644 index 00000000..9235a6f8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OneTimeEvents.lean @@ -0,0 +1,422 @@ +import SphincsSecurity.Proof.Replay + +/-! +# One-time terminal events + +A layer obstacle is either an honest opening at a position the transcript never used, an encoding +collision at a used position, or a codeword that moves backward on at least one used chain. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +def FreshLayerOpening (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) : Prop := + ∃ (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) + (counter : Counter) (values : ChainIndex → Digest) (path : Nat → Digest), + HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay tree leafIdx message counter + values path + ∧ CachedRun cache f (otsLeaf secretKey.parameter lay tree leafIdx message counter values) + ∧ ¬ SignedLayerAt f cache secretKey signingLog lay tree leafIdx + +def EncodingCollision (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) : Prop := + ∃ (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (forgedMessage : Digest) + (forgedCounter : Counter) (forgedValues : ChainIndex → Digest) + (forgedPath : Nat → Digest) + (entry : (request : SignRequest) × SigningSpec.Range request) (signature : Signature) + (index : Index) (leaves : DigestTree → FtsLeaf), + CachedRun cache f (otsLeaf secretKey.parameter lay tree leafIdx forgedMessage forgedCounter + forgedValues) + ∧ HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay tree leafIdx + forgedMessage forgedCounter forgedValues forgedPath + ∧ entry ∈ signingLog + ∧ entry.2 = some signature + ∧ SuccessfulSignRun f cache secretKey entry.1 signature + ∧ SuccessfulDigestRun f cache secretKey entry.1 signature.randomness index leaves + ∧ treeIndexAt index lay = tree + ∧ leafIndexAt index lay = leafIdx + ∧ CachedRun cache f (layerMessage secretKey index lay) + ∧ HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay tree leafIdx + (evalWithAnswerFn f (layerMessage secretKey index lay)) (signature.counter lay) + (signature.chainValue lay) (signaturePath signature lay) + ∧ cache (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay))) ≠ none + ∧ EncodingHit f secretKey.parameter lay tree leafIdx + (evalWithAnswerFn f (layerMessage secretKey index lay)) forgedMessage + (signature.counter lay) forgedCounter + +theorem EncodingCollision.reuses_values_and_path {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} + (hcollision : EncodingCollision f cache secretKey signingLog) : + ∃ (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (forgedMessage : Digest) + (forgedCounter : Counter) (forgedValues : ChainIndex → Digest) + (forgedPath : Nat → Digest) (signature : Signature) (index : Index), + treeIndexAt index lay = tree + ∧ leafIndexAt index lay = leafIdx + ∧ (evalWithAnswerFn f (layerMessage secretKey index lay) ≠ forgedMessage + ∨ signature.counter lay ≠ forgedCounter) + ∧ signature.chainValue lay = forgedValues + ∧ ∀ level, level < layerHeight lay → + signaturePath signature lay level = forgedPath level := by + obtain ⟨lay, tree, leafIdx, forgedMessage, forgedCounter, forgedValues, forgedPath, _, + signature, index, _, _, hforgedOpening, _, _, _, _, htree, hleaf, _, hsignedOpening, _, + hhit⟩ := hcollision + have hreused := honestLayerOpening_values_path_eq_of_encodingHit f secretKey.parameter + secretKey.otsSecret lay tree leafIdx + (evalWithAnswerFn f (layerMessage secretKey index lay)) forgedMessage + (signature.counter lay) forgedCounter (signature.chainValue lay) forgedValues + (signaturePath signature lay) forgedPath hsignedOpening hforgedOpening hhit + have hdifferent : evalWithAnswerFn f (layerMessage secretKey index lay) ≠ forgedMessage + ∨ signature.counter lay ≠ forgedCounter := by + by_contra hequal + simp only [not_or, not_ne_iff] at hequal + apply hhit.1 + rw [hequal.1, hequal.2] + exact ⟨lay, tree, leafIdx, forgedMessage, forgedCounter, forgedValues, forgedPath, signature, + index, htree, hleaf, hdifferent, hreused⟩ + +def BackwardChainOpening (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) : Prop := + ∃ (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (forgedMessage : Digest) + (forgedCounter : Counter) (forgedValues : ChainIndex → Digest) (forgedPath : Nat → Digest) + (entry : (request : SignRequest) × SigningSpec.Range request) (signature : Signature) + (index : Index) (leaves : DigestTree → FtsLeaf) + (signedCodeword forgedCodeword : Encoding), + HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay tree leafIdx forgedMessage + forgedCounter forgedValues forgedPath + ∧ CachedRun cache f (otsLeaf secretKey.parameter lay tree leafIdx forgedMessage forgedCounter + forgedValues) + ∧ entry ∈ signingLog + ∧ entry.2 = some signature + ∧ SuccessfulSignRun f cache secretKey entry.1 signature + ∧ SuccessfulDigestRun f cache secretKey entry.1 signature.randomness index leaves + ∧ treeIndexAt index lay = tree + ∧ leafIndexAt index lay = leafIdx + ∧ CachedRun cache f (layerMessage secretKey index lay) + ∧ HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay tree leafIdx + (evalWithAnswerFn f (layerMessage secretKey index lay)) (signature.counter lay) + (signature.chainValue lay) (signaturePath signature lay) + ∧ cache (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay))) ≠ none + ∧ evalWithAnswerFn f (encode secretKey.parameter lay tree leafIdx + (evalWithAnswerFn f (layerMessage secretKey index lay)) (signature.counter lay)) + = some signedCodeword + ∧ evalWithAnswerFn f + (encode secretKey.parameter lay tree leafIdx forgedMessage forgedCounter) + = some forgedCodeword + ∧ ∃ chainIdx, (forgedCodeword chainIdx).val < (signedCodeword chainIdx).val + +def ForgedFreshLayerOpening (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (index : Index) + (leaves : DigestTree → FtsLeaf) (signature : Signature) : Prop := + ∃ (lay : Layer) (message : Digest), + VerifierLayerMessage f secretKey.parameter index leaves signature lay message + ∧ HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay + (treeIndexAt index lay) (leafIndexAt index lay) message (signature.counter lay) + (signature.chainValue lay) (signaturePath signature lay) + ∧ CachedRun cache f (otsLeaf secretKey.parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message (signature.counter lay) (signature.chainValue lay)) + ∧ ¬SignedLayerAt f cache secretKey signingLog lay + (treeIndexAt index lay) (leafIndexAt index lay) + +def ForgedBackwardChainOpening (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (forgedIndex : Index) + (forgedLeaves : DigestTree → FtsLeaf) (forgedSignature : Signature) : Prop := + ∃ (lay : Layer) (forgedMessage : Digest) + (entry : (request : SignRequest) × SigningSpec.Range request) (signature : Signature) + (index : Index) (leaves : DigestTree → FtsLeaf) + (signedCodeword forgedCodeword : Encoding), + VerifierLayerMessage f secretKey.parameter forgedIndex forgedLeaves forgedSignature lay + forgedMessage + ∧ HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay + (treeIndexAt forgedIndex lay) (leafIndexAt forgedIndex lay) forgedMessage + (forgedSignature.counter lay) (forgedSignature.chainValue lay) + (signaturePath forgedSignature lay) + ∧ CachedRun cache f (otsLeaf secretKey.parameter lay (treeIndexAt forgedIndex lay) + (leafIndexAt forgedIndex lay) forgedMessage (forgedSignature.counter lay) + (forgedSignature.chainValue lay)) + ∧ entry ∈ signingLog + ∧ entry.2 = some signature + ∧ SuccessfulSignRun f cache secretKey entry.1 signature + ∧ SuccessfulDigestRun f cache secretKey entry.1 signature.randomness index leaves + ∧ treeIndexAt index lay = treeIndexAt forgedIndex lay + ∧ leafIndexAt index lay = leafIndexAt forgedIndex lay + ∧ CachedRun cache f (layerMessage secretKey index lay) + ∧ HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay + (treeIndexAt forgedIndex lay) (leafIndexAt forgedIndex lay) + (evalWithAnswerFn f (layerMessage secretKey index lay)) (signature.counter lay) + (signature.chainValue lay) (signaturePath signature lay) + ∧ cache (tweakableHashInput secretKey.parameter + (.encoding lay (treeIndexAt forgedIndex lay) (leafIndexAt forgedIndex lay)) + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay))) ≠ none + ∧ evalWithAnswerFn f (encode secretKey.parameter lay (treeIndexAt forgedIndex lay) + (leafIndexAt forgedIndex lay) (evalWithAnswerFn f (layerMessage secretKey index lay)) + (signature.counter lay)) = some signedCodeword + ∧ evalWithAnswerFn f (encode secretKey.parameter lay (treeIndexAt forgedIndex lay) + (leafIndexAt forgedIndex lay) forgedMessage (forgedSignature.counter lay)) = + some forgedCodeword + ∧ ∃ chainIdx, (forgedCodeword chainIdx).val < (signedCodeword chainIdx).val + +def SettledForgedFreshLayerOpening (f : QueryImpl HashSpec Id) + (cache : QueryCache HashSpec) (secretKey : SecretKey) + (signingLog : QueryLog SigningSpec) (index : Index) + (leaves : DigestTree → FtsLeaf) (signature : Signature) : Prop := + ∃ (lay : Layer) (message : Digest), + LayerRootSettled cache secretKey lay (treeIndexAt index lay) + ∧ VerifierLayerMessage f secretKey.parameter index leaves signature lay message + ∧ HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay + (treeIndexAt index lay) (leafIndexAt index lay) message (signature.counter lay) + (signature.chainValue lay) (signaturePath signature lay) + ∧ CachedRun cache f (otsLeaf secretKey.parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message (signature.counter lay) (signature.chainValue lay)) + ∧ ¬SignedLayerAt f cache secretKey signingLog lay + (treeIndexAt index lay) (leafIndexAt index lay) + +def SettledForgedBackwardChainOpening (f : QueryImpl HashSpec Id) + (cache : QueryCache HashSpec) (secretKey : SecretKey) + (signingLog : QueryLog SigningSpec) (forgedIndex : Index) + (forgedLeaves : DigestTree → FtsLeaf) (forgedSignature : Signature) : Prop := + ∃ (lay : Layer) (forgedMessage : Digest) + (entry : (request : SignRequest) × SigningSpec.Range request) (signature : Signature) + (index : Index) (leaves : DigestTree → FtsLeaf) + (signedCodeword forgedCodeword : Encoding), + LayerRootSettled cache secretKey lay (treeIndexAt forgedIndex lay) + ∧ VerifierLayerMessage f secretKey.parameter forgedIndex forgedLeaves forgedSignature lay + forgedMessage + ∧ HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay + (treeIndexAt forgedIndex lay) (leafIndexAt forgedIndex lay) forgedMessage + (forgedSignature.counter lay) (forgedSignature.chainValue lay) + (signaturePath forgedSignature lay) + ∧ CachedRun cache f (otsLeaf secretKey.parameter lay (treeIndexAt forgedIndex lay) + (leafIndexAt forgedIndex lay) forgedMessage (forgedSignature.counter lay) + (forgedSignature.chainValue lay)) + ∧ entry ∈ signingLog + ∧ entry.2 = some signature + ∧ SuccessfulSignRun f cache secretKey entry.1 signature + ∧ SuccessfulDigestRun f cache secretKey entry.1 signature.randomness index leaves + ∧ treeIndexAt index lay = treeIndexAt forgedIndex lay + ∧ leafIndexAt index lay = leafIndexAt forgedIndex lay + ∧ CachedRun cache f (layerMessage secretKey index lay) + ∧ HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay + (treeIndexAt forgedIndex lay) (leafIndexAt forgedIndex lay) + (evalWithAnswerFn f (layerMessage secretKey index lay)) (signature.counter lay) + (signature.chainValue lay) (signaturePath signature lay) + ∧ cache (tweakableHashInput secretKey.parameter + (.encoding lay (treeIndexAt forgedIndex lay) (leafIndexAt forgedIndex lay)) + (digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay))) ≠ none + ∧ evalWithAnswerFn f (encode secretKey.parameter lay (treeIndexAt forgedIndex lay) + (leafIndexAt forgedIndex lay) (evalWithAnswerFn f (layerMessage secretKey index lay)) + (signature.counter lay)) = some signedCodeword + ∧ evalWithAnswerFn f (encode secretKey.parameter lay (treeIndexAt forgedIndex lay) + (leafIndexAt forgedIndex lay) forgedMessage (forgedSignature.counter lay)) = + some forgedCodeword + ∧ ∃ chainIdx, (forgedCodeword chainIdx).val < (signedCodeword chainIdx).val + +theorem SettledForgedFreshLayerOpening.toForged + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} {leaves : DigestTree → FtsLeaf} + {signature : Signature} + (hfresh : SettledForgedFreshLayerOpening f cache secretKey signingLog index leaves signature) : + ForgedFreshLayerOpening f cache secretKey signingLog index leaves signature := by + obtain ⟨lay, message, _, hverifier, hopening, hcached, hfresh⟩ := hfresh + exact ⟨lay, message, hverifier, hopening, hcached, hfresh⟩ + +theorem SettledForgedBackwardChainOpening.toForged + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} {leaves : DigestTree → FtsLeaf} + {signature : Signature} + (hbackward : SettledForgedBackwardChainOpening f cache secretKey signingLog index leaves + signature) : + ForgedBackwardChainOpening f cache secretKey signingLog index leaves signature := by + obtain ⟨lay, message, entry, signedSignature, signedIndex, signedLeaves, signedCodeword, + forgedCodeword, _, hverifier, hopening, hcached, hentry, hresponse, hrun, hdigest, htree, + hleaf, hlayer, hsignedOpening, hsignedCached, hsigned, hforged, hlt⟩ := hbackward + exact ⟨lay, message, entry, signedSignature, signedIndex, signedLeaves, signedCodeword, + forgedCodeword, hverifier, hopening, hcached, hentry, hresponse, hrun, hdigest, htree, + hleaf, hlayer, hsignedOpening, hsignedCached, hsigned, hforged, hlt⟩ + +theorem forgedLayerObstacle_classify (f : QueryImpl HashSpec Id) + (cache : QueryCache HashSpec) (secretKey : SecretKey) + (signingLog : QueryLog SigningSpec) (index : Index) (leaves : DigestTree → FtsLeaf) + (signature : Signature) + (hobstacle : ForgedLayerObstacle f cache secretKey signingLog index leaves signature) : + ForgedFreshLayerOpening f cache secretKey signingLog index leaves signature + ∨ EncodingCollision f cache secretKey signingLog + ∨ ForgedBackwardChainOpening f cache secretKey signingLog index leaves signature := by + obtain ⟨lay, message, hverifierMessage, hopening, hcached, hfresh | hfailure⟩ := hobstacle + · exact Or.inl ⟨lay, message, hverifierMessage, hopening, hcached, hfresh⟩ + · obtain ⟨entry, signedSignature, signedIndex, leaves, hentry, hresponse, hsignRun, + hdigest, htree, hleaf, hmessage, hsignedOpening, hsignedCached, + hencoding | hbackward⟩ := hfailure + · exact Or.inr (Or.inl ⟨lay, treeIndexAt index lay, leafIndexAt index lay, message, + signature.counter lay, signature.chainValue lay, signaturePath signature lay, + entry, signedSignature, signedIndex, leaves, hcached, hopening, hentry, hresponse, + hsignRun, hdigest, htree, hleaf, hmessage, hsignedOpening, hsignedCached, hencoding⟩) + · obtain ⟨signedCodeword, forgedCodeword, hsigned, hforged, hlt⟩ := hbackward + exact Or.inr (Or.inr ⟨lay, message, entry, signedSignature, signedIndex, leaves, + signedCodeword, forgedCodeword, hverifierMessage, hopening, hcached, hentry, hresponse, + hsignRun, + hdigest, htree, hleaf, hmessage, hsignedOpening, hsignedCached, hsigned, hforged, hlt⟩) + +theorem settledForgedLayerObstacle_classify (f : QueryImpl HashSpec Id) + (cache : QueryCache HashSpec) (secretKey : SecretKey) + (signingLog : QueryLog SigningSpec) (index : Index) (leaves : DigestTree → FtsLeaf) + (signature : Signature) + (hobstacle : SettledForgedLayerObstacle f cache secretKey signingLog index leaves signature) : + SettledForgedFreshLayerOpening f cache secretKey signingLog index leaves signature + ∨ EncodingCollision f cache secretKey signingLog + ∨ SettledForgedBackwardChainOpening f cache secretKey signingLog index leaves + signature := by + obtain ⟨lay, message, hsettled, hverifierMessage, hopening, hcached, + hfresh | hfailure⟩ := hobstacle + · exact Or.inl ⟨lay, message, hsettled, hverifierMessage, hopening, hcached, hfresh⟩ + · obtain ⟨entry, signedSignature, signedIndex, signedLeaves, hentry, hresponse, hsignRun, + hdigest, htree, hleaf, hmessage, hsignedOpening, hsignedCached, + hencoding | hbackward⟩ := hfailure + · exact Or.inr (Or.inl ⟨lay, treeIndexAt index lay, leafIndexAt index lay, message, + signature.counter lay, signature.chainValue lay, signaturePath signature lay, + entry, signedSignature, signedIndex, signedLeaves, hcached, hopening, hentry, hresponse, + hsignRun, hdigest, htree, hleaf, hmessage, hsignedOpening, hsignedCached, hencoding⟩) + · obtain ⟨signedCodeword, forgedCodeword, hsigned, hforged, hlt⟩ := hbackward + exact Or.inr (Or.inr ⟨lay, message, entry, signedSignature, signedIndex, signedLeaves, + signedCodeword, forgedCodeword, hsettled, hverifierMessage, hopening, hcached, hentry, + hresponse, hsignRun, hdigest, htree, hleaf, hmessage, hsignedOpening, hsignedCached, + hsigned, hforged, hlt⟩) + +theorem ForgedFreshLayerOpening.toFreshLayerOpening + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} {leaves : DigestTree → FtsLeaf} + {signature : Signature} + (hfresh : ForgedFreshLayerOpening f cache secretKey signingLog index leaves signature) : + FreshLayerOpening f cache secretKey signingLog := by + obtain ⟨lay, message, _, hopening, hcached, hnotSigned⟩ := hfresh + exact ⟨lay, treeIndexAt index lay, leafIndexAt index lay, message, signature.counter lay, + signature.chainValue lay, signaturePath signature lay, hopening, hcached, hnotSigned⟩ + +theorem ForgedBackwardChainOpening.toBackwardChainOpening + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} {leaves : DigestTree → FtsLeaf} + {signature : Signature} + (hbackward : ForgedBackwardChainOpening f cache secretKey signingLog index leaves signature) : + BackwardChainOpening f cache secretKey signingLog := by + obtain ⟨lay, message, entry, signedSignature, signedIndex, leaves, signedCodeword, + forgedCodeword, _, hopening, hcached, hentry, hresponse, hsignRun, hdigest, htree, hleaf, + hmessage, hsignedOpening, hsignedCached, hsigned, hforged, hlt⟩ := hbackward + exact ⟨lay, treeIndexAt index lay, leafIndexAt index lay, message, signature.counter lay, + signature.chainValue lay, signaturePath signature lay, entry, signedSignature, signedIndex, + leaves, signedCodeword, forgedCodeword, hopening, hcached, hentry, hresponse, hsignRun, + hdigest, htree, hleaf, hmessage, hsignedOpening, hsignedCached, hsigned, hforged, hlt⟩ + +theorem layerObstacle_classify (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) + (hobstacle : LayerObstacle f cache secretKey signingLog) : + FreshLayerOpening f cache secretKey signingLog + ∨ EncodingCollision f cache secretKey signingLog + ∨ BackwardChainOpening f cache secretKey signingLog := by + obtain ⟨lay, tree, leafIdx, message, counter, values, path, hopening, hforgedRun, + hfresh | hfailure⟩ := + hobstacle + · exact Or.inl ⟨lay, tree, leafIdx, message, counter, values, path, hopening, hforgedRun, hfresh⟩ + · obtain ⟨entry, signature, index, leaves, hentry, hresponse, hsignRun, hdigest, htree, hleaf, + hmessage, hsignedOpening, hsignedCached, hencoding | hearlier⟩ := hfailure + · exact Or.inr (Or.inl ⟨lay, tree, leafIdx, message, counter, values, path, entry, signature, + index, leaves, hforgedRun, hopening, hentry, hresponse, hsignRun, hdigest, htree, hleaf, + hmessage, hsignedOpening, hsignedCached, hencoding⟩) + · obtain ⟨signedCodeword, forgedCodeword, hsigned, hforged, hchain⟩ := hearlier + exact Or.inr (Or.inr ⟨lay, tree, leafIdx, message, counter, values, path, entry, + signature, index, leaves, signedCodeword, forgedCodeword, hopening, hforgedRun, hentry, + hresponse, hsignRun, hdigest, htree, hleaf, hmessage, hsignedOpening, hsignedCached, + hsigned, hforged, hchain⟩) + +def TerminalForgeryEvent (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (forgery : Forgery) + (index : Index) (leaves : DigestTree → FtsLeaf) : Prop := + SettledForgedFreshLayerOpening f cache secretKey signingLog index leaves forgery.signature + ∨ EncodingCollision f cache secretKey signingLog + ∨ SettledForgedBackwardChainOpening f cache secretKey signingLog index leaves + forgery.signature + ∨ (MessageDigestCollision f cache secretKey signingLog forgery ∧ + FewTimeLeak f cache secretKey signingLog index leaves) + ∨ ProperFewTimeLeak f cache secretKey signingLog index leaves + ∨ UncoveredFtsSecret f cache secretKey signingLog index leaves forgery.signature.ftsSecret + +theorem winning_support_terminal_classify (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (finalCache : QueryCache HashSpec) + (hwin : (true, finalCache) ∈ support ((simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅)) : + Bad parameter otsSecret ftsSecret finalCache + ∨ ∃ root forgery signingLog f digest, + let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + finalCache.AgreesWithFn f + ∧ SigningTranscript.Valid signingLog + ∧ ¬ SigningTranscript.Contains signingLog forgery + ∧ evalWithAnswerFn f + (messageDigest parameter root forgery.message forgery.signature.randomness) = digest + ∧ Admissible digest + ∧ TerminalForgeryEvent f finalCache secretKey signingLog forgery + (digestIndex digest) (digestLeaves digest) := by + obtain ⟨root, _, forgery, signingLog, _, _, _, _, hvalid, hnotContains, f, hf, _, _, _, _, + hrootSettled, + digest, hdigest, hdigestRun, hadmissible, hftsRun, hresult⟩ := + winning_support_extract adversary parameter otsSecret ftsSecret finalCache hwin + rcases hresult with hbad | htop + · exact Or.inl hbad + · let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + let index := digestIndex digest + let leaves := digestLeaves digest + let ftsPublicKey := evalWithAnswerFn f + (ftsRecover parameter index leaves forgery.signature.ftsSecret forgery.signature.ftsPath) + have hclassified := accepted_forgery_classify f finalCache secretKey signingLog index + forgery.signature leaves ftsPublicKey root hf rfl htop (by + have htree : treeIndexAt index topLayer = rootTree := by + apply Fin.ext + exact treeIndexAt_topLayer index + unfold LayerRootSettled + rw [htree] + simpa using hrootSettled) hftsRun + rcases hclassified with hbad | hobstacle | hfull + · exact Or.inl hbad + · rcases settledForgedLayerObstacle_classify f finalCache secretKey signingLog index leaves + forgery.signature hobstacle with + hfresh | hencoding | hbackward + · exact Or.inr ⟨root, forgery, signingLog, f, digest, hf, hvalid, hnotContains, hdigest, + hadmissible, Or.inl hfresh⟩ + · exact Or.inr ⟨root, forgery, signingLog, f, digest, hf, hvalid, hnotContains, hdigest, + hadmissible, Or.inr (Or.inl hencoding)⟩ + · exact Or.inr ⟨root, forgery, signingLog, f, digest, hf, hvalid, hnotContains, hdigest, + hadmissible, Or.inr (Or.inr (Or.inl hbackward))⟩ + · rcases fewTimeLeak_or_uncovered f finalCache secretKey signingLog index leaves with + hleak | ⟨tree, huncovered⟩ + · rcases fullyHonest_leak_classify f finalCache secretKey signingLog forgery digest index + leaves hdigest hdigestRun rfl rfl hfull.1 hnotContains hleak with + hcollision | hobstacle | hproper + · exact Or.inr ⟨root, forgery, signingLog, f, digest, hf, hvalid, hnotContains, hdigest, + hadmissible, Or.inr (Or.inr (Or.inr (Or.inl ⟨hcollision, hleak⟩)))⟩ + · rcases settledForgedLayerObstacle_classify f finalCache secretKey signingLog index + leaves forgery.signature (hfull.settleObstacle hobstacle) with + hfresh | hencoding | hbackward + · exact Or.inr ⟨root, forgery, signingLog, f, digest, hf, hvalid, hnotContains, hdigest, + hadmissible, Or.inl hfresh⟩ + · exact Or.inr ⟨root, forgery, signingLog, f, digest, hf, hvalid, hnotContains, hdigest, + hadmissible, Or.inr (Or.inl hencoding)⟩ + · exact Or.inr ⟨root, forgery, signingLog, f, digest, hf, hvalid, hnotContains, hdigest, + hadmissible, Or.inr (Or.inr (Or.inl hbackward))⟩ + · exact Or.inr ⟨root, forgery, signingLog, f, digest, hf, hvalid, hnotContains, hdigest, + hadmissible, Or.inr (Or.inr (Or.inr (Or.inr (Or.inl hproper))))⟩ + · exact Or.inr ⟨root, forgery, signingLog, f, digest, hf, hvalid, hnotContains, hdigest, + hadmissible, Or.inr (Or.inr (Or.inr (Or.inr (Or.inr + ⟨tree, huncovered, (hfull.1.2.1 tree).1, by + apply hfull.1.2.2.1 + exact ftsRecover_leaf_query_mem f parameter index leaves forgery.signature.ftsSecret + forgery.signature.ftsPath tree⟩))))⟩ + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsOpeningQueryReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsOpeningQueryReserve.lean new file mode 100644 index 00000000..cb82de21 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsOpeningQueryReserve.lean @@ -0,0 +1,56 @@ +import SphincsSecurity.Proof.JointSecretOpeningQueryBudget +import SphincsSecurity.Proof.OtsProbeQueryCharge + +namespace SphincsSecurity.Concrete + +open _root_.OracleComp OracleSpec ENNReal + +theorem TightEncoding.refinedStructuralEncodingQueryCharge_le_two_of_atPosition + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) (position : Position) + (hat : AtPosition secretKey.parameter input position) : + TightEncoding.refinedStructuralEncodingQueryCharge secretKey cache input ≤ 2 := by + classical + have hnotEncoding : ¬ ∃ candidate : EncodingPosition, AtEncodingPosition secretKey.parameter input candidate := + fun ⟨candidate, hencoding⟩ => hencoding.not_atPosition position hat + have hposition : ∃ position : Position, AtPosition secretKey.parameter input position := ⟨position, hat⟩ + unfold refinedStructuralEncodingQueryCharge + split_ifs <;> simp_all [structuralEncodingQueryCharge] + +theorem ftsOpeningQueryReserve_eq_zero_of_atOtsPosition + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) (position : Position) + (hat : AtPosition secretKey.parameter input position) (hots : OtsProbeSimulation.IsOtsPosition position) : + ftsOpeningQueryReserve secretKey cache input = 0 := by + classical + have hnone : ¬ ∃ probe : FtsSecretProbe, probe.input secretKey.parameter = input := by + rintro ⟨probe, hinput⟩ + have hprobe : AtPosition secretKey.parameter input (.ftsLeaf probe.index probe.tree probe.leafIdx) := by + rw [← hinput] + exact ⟨digestBytes probe.candidate, rfl⟩ + rw [atPosition_unique secretKey.parameter hat hprobe] at hots + exact hots + simp only [ftsOpeningQueryReserve, FtsProbeSimulation.ftsHashQueryCharge, if_neg hnone, zero_mul] + +theorem otsOpeningQueryReserve_ge_one_of_atOtsPosition + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) (position : Position) + (hat : AtPosition secretKey.parameter input position) (hots : OtsProbeSimulation.IsOtsPosition position) : + 1 ≤ otsOpeningQueryReserve secretKey cache input := by + rw [otsOpeningQueryReserve, ftsOpeningQueryReserve_eq_zero_of_atOtsPosition secretKey cache input position hat hots, + tsub_zero] + have hbound := tsub_le_tsub_left + (TightEncoding.refinedStructuralEncodingQueryCharge_le_two_of_atPosition secretKey cache input position hat) + (3 : ℝ≥0∞) + have hone : (3 : ℝ≥0∞) - 2 = 1 := + (ENNReal.eq_sub_of_add_eq' (by norm_num) (show (1 : ℝ≥0∞) + 2 = 3 by norm_num)).symm + simpa only [hone, residualPrimitiveQueryCharge] using hbound + +theorem otsOpeningQueryReserve_ge_two_of_children_settled + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) (position : Position) + (hat : AtPosition secretKey.parameter input position) (hots : OtsProbeSimulation.IsOtsPosition position) + (hchildren : ∀ child ∈ position.children, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache child) : + 2 ≤ otsOpeningQueryReserve secretKey cache input := by + rw [otsOpeningQueryReserve, ftsOpeningQueryReserve_eq_zero_of_atOtsPosition secretKey cache input position hat hots, + tsub_zero] + exact residualPrimitiveQueryCharge_ge_two_of_children_settled secretKey cache input position hat hchildren + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsOpeningRefinedReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsOpeningRefinedReserve.lean new file mode 100644 index 00000000..6f579571 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsOpeningRefinedReserve.lean @@ -0,0 +1,141 @@ +import SphincsSecurity.Proof.Security126RefinedEndpoint +import SphincsSecurity.Proof.OtsProbeRootQueryReserve + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +noncomputable def otsOpeningRefinedQueryReserve (secretKey : SecretKey) + (cache : QueryCache HashSpec) (input : HashInput) : ℝ≥0∞ := + otsOpeningQueryReserve secretKey cache input + 1 / 3 + +theorem sampledQueryCharge_add + (left right : SecretKey → QueryCache HashSpec → HashInput → ℝ≥0∞) (adversary : Adversary) : + sampledQueryCharge (fun secretKey cache input => left secretKey cache input + right secretKey cache input) adversary = + sampledQueryCharge left adversary + sampledQueryCharge right adversary := by + unfold sampledQueryCharge + simp_rw [expectedQueryCharge_add, mul_add, ENNReal.tsum_add] + +theorem sampledQueryCharge_le_const + (charge : SecretKey → QueryCache HashSpec → HashInput → ℝ≥0∞) (bound : ℝ≥0∞) + (hcharge : ∀ secretKey cache input, charge secretKey cache input ≤ bound) + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) : + sampledQueryCharge charge adversary ≤ bound * q := by + unfold sampledQueryCharge + calc + _ ≤ ∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets] * (bound * q) := by + apply ENNReal.tsum_le_tsum + intro secrets + by_cases hsecrets : secrets ∈ support sampleSecrets + · obtain ⟨hparameter, hots, hfts⟩ := secrets.support_components hsecrets + exact mul_le_mul' le_rfl (expectedQueryCharge_le_queryBound _ bound (hcharge _) + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret) q + (isQueryBoundP_gameAfterSecrets adversary q hq hparameter hots hfts) ∅) + · simp [probOutput_eq_zero_of_not_mem_support hsecrets] + _ ≤ _ := by + rw [ENNReal.tsum_mul_right] + exact mul_le_of_le_one_left (by positivity) tsum_probOutput_le_one + +theorem structural_add_refined_openingQueryReserve (secretKey : SecretKey) + (cache : QueryCache HashSpec) (input : HashInput) : + (TightEncoding.refinedStructuralEncodingQueryCharge secretKey cache input + + ftsOpeningQueryReserve secretKey cache input) + otsOpeningRefinedQueryReserve secretKey cache input = 10 / 3 := by + unfold otsOpeningRefinedQueryReserve + rw [add_assoc, ← add_assoc (ftsOpeningQueryReserve secretKey cache input), openingQueryReserve_add, + ← add_assoc, structural_add_residual_queryCharge] + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + norm_num + +theorem sampled_structural_add_refined_openingQueryReserve_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) : + (sampledQueryCharge TightEncoding.refinedStructuralEncodingQueryCharge adversary + + sampledQueryCharge ftsOpeningQueryReserve adversary) + + sampledQueryCharge otsOpeningRefinedQueryReserve adversary ≤ (10 / 3 : ℝ≥0∞) * q := by + rw [← sampledQueryCharge_add, ← sampledQueryCharge_add] + exact sampledQueryCharge_le_const _ _ + (fun secretKey cache input => (structural_add_refined_openingQueryReserve secretKey cache input).le) + adversary q hq + +theorem security126_of_sampled_otsOpening_le_refinedQueryReserve + (hots : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ 126 → + Pr[SampledViewedEvent residualOtsOpeningEvent | sampledViewedGame adversary] ≤ + sampledQueryCharge otsOpeningRefinedQueryReserve adversary * (Fintype.card Digest : ℝ≥0∞)⁻¹) : + HasClassicalSecurityBits scheme 126 := by + apply security126_of_sampled_jointPrimitive_le_ten_thirds_mul + intro q hqPos adversary hq hqMax + have hfts := FtsProbeSimulation.probEvent_sampledViewedGame_cleanUncovered_le_queryCharge126 adversary q hq hqMax + rw [← sampled_ftsOpeningQueryReserve_eq] at hfts + apply (probEvent_sampled_jointPrimitive_le_charge_add_residual adversary).trans + apply (add_le_add le_rfl ((probEvent_sampled_residual_le_ots_add_fts adversary).trans + (add_le_add (hots q hqPos adversary hq hqMax) hfts))).trans + calc + _ = ((sampledQueryCharge TightEncoding.refinedStructuralEncodingQueryCharge adversary + + sampledQueryCharge ftsOpeningQueryReserve adversary) + + sampledQueryCharge otsOpeningRefinedQueryReserve adversary) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by ring + _ ≤ ((10 / 3 : ℝ≥0∞) * q) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := + mul_le_mul' (sampled_structural_add_refined_openingQueryReserve_le adversary q hq) le_rfl + _ = _ := by simp [digestBits] + +theorem otsOpeningRefinedQueryReserve_ge_four_thirds_of_one_le + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) + (hreserve : 1 ≤ otsOpeningQueryReserve secretKey cache input) : + 4 / 3 ≤ otsOpeningRefinedQueryReserve secretKey cache input := by + have heq : (4 / 3 : ℝ≥0∞) = 1 + 1 / 3 := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + norm_num + rw [heq] + exact add_le_add hreserve le_rfl + +theorem otsOpeningRefinedQueryReserve_ge_four_thirds_of_atOtsPosition + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) (position : Position) + (hat : AtPosition secretKey.parameter input position) (hots : OtsProbeSimulation.IsOtsPosition position) : + 4 / 3 ≤ otsOpeningRefinedQueryReserve secretKey cache input := + otsOpeningRefinedQueryReserve_ge_four_thirds_of_one_le secretKey cache input + (otsOpeningQueryReserve_ge_one_of_atOtsPosition secretKey cache input position hat hots) + +theorem otsOpeningRefinedQueryReserve_ge_four_thirds_of_encodingMessageSettled + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) (position : EncodingPosition) + (hat : AtEncodingPosition secretKey.parameter input position) + (hsettled : EncodingMessageSettledAt cache secretKey position) : + 4 / 3 ≤ otsOpeningRefinedQueryReserve secretKey cache input := by + apply otsOpeningRefinedQueryReserve_ge_four_thirds_of_one_le + rw [otsOpeningQueryReserve_atEncodingPosition secretKey cache input position hat] + simp only [hsettled, if_true] + split_ifs <;> norm_num + +namespace OtsProbeSimulation + +theorem probingHashQueryAfterRootAwarePublicPlan_weightedCharge_le_refinedReserve_atOtsPosition + (secretKey : SecretKey) (actualCache : QueryCache HashSpec) (input : HashInput) (position : Position) + (hat : AtPosition secretKey.parameter input position) (hots : IsOtsPosition position) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (cache : SplitHashCache) (context : DeferredContext) (fuel : Nat) : + ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterRootAwarePublicPlan secretKey.parameter input publicState plan).run cache) context fuel + + (materializedCandidateCharge context.state (rootAwareCandidateForPlan? secretKey.parameter input plan) : ℝ≥0∞) * + (4 / 3) ≤ otsOpeningRefinedQueryReserve secretKey actualCache input := + (probingHashQueryAfterRootAwarePublicPlan_weightedCharge_le_four_thirds + secretKey.parameter input publicState plan cache context fuel).trans + (otsOpeningRefinedQueryReserve_ge_four_thirds_of_atOtsPosition secretKey actualCache input position hat hots) + +theorem probingHashQueryAfterRootAwarePublicPlan_weightedCharge_le_refinedReserve_of_encodingMessageSettled + (secretKey : SecretKey) (actualCache : QueryCache HashSpec) (input : HashInput) (position : EncodingPosition) + (hat : AtEncodingPosition secretKey.parameter input position) + (hsettled : EncodingMessageSettledAt actualCache secretKey position) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (cache : SplitHashCache) (context : DeferredContext) (fuel : Nat) : + ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterRootAwarePublicPlan secretKey.parameter input publicState plan).run cache) context fuel + + (materializedCandidateCharge context.state (rootAwareCandidateForPlan? secretKey.parameter input plan) : ℝ≥0∞) * + (4 / 3) ≤ otsOpeningRefinedQueryReserve secretKey actualCache input := + (probingHashQueryAfterRootAwarePublicPlan_weightedCharge_le_four_thirds + secretKey.parameter input publicState plan cache context fuel).trans + (otsOpeningRefinedQueryReserve_ge_four_thirds_of_encodingMessageSettled + secretKey actualCache input position hat hsettled) + +end OtsProbeSimulation + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeBoundaryCompletion.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeBoundaryCompletion.lean new file mode 100644 index 00000000..db71f471 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeBoundaryCompletion.lean @@ -0,0 +1,631 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryWitnessOrdinary +import SphincsSecurity.Proof.OtsProbeVerifierBoundary + +/-! The canonical boundary fails only through a private witness or materialized ordinary failure. Guarded completion identifies the latter with the diagnostic bad event, and the verifier bridge transfers their combined bound to the original experiment. -/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +def ObservedMaterializedDiagnostic.guardedFinal + (outcome : ObservedMaterializedDiagnostic α) : Option (ObservedCleanRunResult α) := + if outcome.wasDoomed then none else outcome.final + +theorem guardedFinal_eq_none_iff (outcome : ObservedMaterializedDiagnostic α) : + outcome.guardedFinal = none ↔ outcome.Bad := by + cases outcome with + | mk before final wasDoomed => + cases wasDoomed <;> + simp [ObservedMaterializedDiagnostic.guardedFinal, ObservedMaterializedDiagnostic.Bad] + +theorem evalDist_guardedFinal_finishObservedMaterializedDiagnostic + (table : OtsSecretIndex → HashOutput) + (result : Option (ObservedCleanRunResult α)) : + evalDist (ObservedMaterializedDiagnostic.guardedFinal <$> + finishObservedMaterializedDiagnostic table result) = + evalDist (finishObservedMaterializedCleanRunFromTable table result) := by + classical + cases result with + | none => rfl + | some result => + by_cases hcomplete : DeferredCompletable table (directDeferredContext result.state) + · simp [finishObservedMaterializedDiagnostic, finishObservedMaterializedCleanRunFromTable, + ObservedMaterializedDiagnostic.guardedFinal, hcomplete] + · simp only [finishObservedMaterializedDiagnostic, finishObservedMaterializedCleanRunFromTable, + ObservedMaterializedDiagnostic.guardedFinal, hcomplete, not_false_eq_true, decide_true, + if_true, if_false, map_bind, map_pure] + exact OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (finishObservedCleanRunFromTable (some result)) (by simp [finishObservedCleanRunFromTable]) + (pure none) + +theorem evalDist_guardedFinal_sampledObservedMaterializedDiagnostic + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (ObservedMaterializedDiagnostic.guardedFinal <$> + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel) = + evalDist (sampledObservedMaterializedClean adversary parameter ftsSecret fuel) := by + unfold sampledObservedMaterializedDiagnostic sampledObservedMaterializedClean + rw [map_bind] + apply evalDist_bind_congr + intro table _ + rw [map_bind] + apply evalDist_bind_congr + intro result _ + exact evalDist_guardedFinal_finishObservedMaterializedDiagnostic table result + +theorem probEvent_sampledMaterializedClean_none_eq_diagnosticBad + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[= none | sampledMaterializedClean adversary parameter ftsSecret fuel] = + Pr[ObservedMaterializedDiagnostic.Bad | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel] := by + rw [← probEvent_sampledObservedMaterializedClean_none_eq_clean] + calc + _ = Pr[= none | ObservedMaterializedDiagnostic.guardedFinal <$> + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel] := + OracleComp.probOutput_congr rfl + (evalDist_guardedFinal_sampledObservedMaterializedDiagnostic adversary parameter + ftsSecret fuel).symm + _ = _ := by + rw [← probEvent_eq_eq_probOutput, probEvent_map] + apply OracleComp.probEvent_congr' + · intro outcome _ + exact guardedFinal_eq_none_iff outcome + · rfl + +theorem probEvent_sampledMaterializedClean_none_le_five_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[= none | sampledMaterializedClean adversary parameter ftsSecret (2 * q)] ≤ + ((5 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + rw [probEvent_sampledMaterializedClean_none_eq_diagnosticBad] + apply probEvent_sampledDiagnostic_bad_le_five_mul adversary parameter ftsSecret q + _ hexpanded hq + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + norm_num [securityBits, digestBits] at hq ⊢ + omega + +theorem evalDist_runDirectDetailedOrdinary_eq_cleanFailureObserve + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + evalDist (runDirectDetailedOrdinaryObserve observe + (directDeferredContext state) fuel table computation) = + evalDist (runCleanFromTable state fuel table computation >>= + finishCleanFailureObserve (fun _ nextState remaining value => + observe (directDeferredContext nextState) remaining value)) := by + unfold runDirectDetailedOrdinaryObserve + rw [← map_projectDirectDetailedClean_run_eq_clean computation state fuel table, + map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro result hresult + have hshape := directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + computation state fuel table result hresult + cases result with + | stopped reason => + cases reason with + | privateStructuralHit => exact False.elim hshape + | ordinaryHit => rfl + | fuelExhausted => rfl + | done result => + simp only [finishDirectDetailedOrdinaryObserve, Function.comp_apply, pure_bind, + projectDirectDetailedClean, DirectDetailedResult.toOption, projectResolvedRunResult, + finishCleanFailureObserve] + change evalDist (observe result.context result.remaining result.value) = + evalDist (observe (directDeferredContext result.context.state) + result.remaining result.value) + rw [show result.context = directDeferredContext result.context.state from hshape] + rfl + +theorem deferredCompletable_of_mem_runCleanFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : CleanRunResult α) + (hstarts : StartTableAgrees state table) + (hresult : some result ∈ support (runCleanFromTable state fuel table computation)) + (hfinal : DeferredCompletable table (directDeferredContext result.state)) : + DeferredCompletable table (directDeferredContext state) := by + rw [← map_projectDirectDetailedClean_run_eq_clean computation state fuel table, + support_map] at hresult + obtain ⟨detailed, hdetailed, hproject⟩ := hresult + have hshape := directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + computation state fuel table detailed hdetailed + cases detailed with + | stopped reason => + simp [projectDirectDetailedClean, DirectDetailedResult.toOption, + projectResolvedRunResult] at hproject + | done detailed => + have heq : result = + ⟨detailed.context.state, detailed.remaining, detailed.value, detailed.table⟩ := + Option.some.inj (by simpa [projectDirectDetailedClean, + DirectDetailedResult.toOption, projectResolvedRunResult] using hproject.symm) + subst result + apply deferredCompletable_of_mem_runDirectResolvedFromTable computation + (directDeferredContext state) fuel table detailed (fun _ _ h => h) hstarts + (mem_support_runDirectResolvedFromTable_of_done_detailed computation + (directDeferredContext state) fuel table detailed hdetailed) + rwa [show detailed.context = directDeferredContext detailed.context.state from hshape] + +theorem completion_of_mem_materializedCleanBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : CleanRunResult (α × SplitHashCache)) + (hstarts : StartTableAgrees state table) + (hresult : some result ∈ support + (materializedCleanBoundary parameter root ftsSecret computation state fuel table cache)) : + result.table = table ∧ StartTableAgrees result.state table ∧ + (DeferredCompletable table (directDeferredContext result.state) → + DeferredCompletable table (directDeferredContext state)) := by + induction computation using OracleComp.inductionOn generalizing state fuel cache with + | pure value => + simp [materializedCleanBoundary] at hresult + subst result + exact ⟨rfl, hstarts, fun h => h⟩ + | query_bind query next ih => + rw [materializedCleanBoundary, OracleComp.construct_query_bind] at hresult + cases query with + | inl world => + cases world with + | inl n => + simp only [mem_support_bind_iff] at hresult + obtain ⟨step, hstep, htail⟩ := hresult + cases step with + | none => simp at htail + | some step => + have hstepStarts := startTableAgrees_of_mem_runCleanFromTable _ state fuel table + hstarts step hstep + have hrest := ih step.value.1 step.state step.remaining step.value.2 hstepStarts.2 htail + exact ⟨hrest.1, hrest.2.1, fun hfinal => + deferredCompletable_of_mem_runCleanFromTable _ state fuel table step hstarts hstep + (hrest.2.2 hfinal)⟩ + | inr input => + simp only [mem_support_bind_iff] at hresult + obtain ⟨step, hstep, htail⟩ := hresult + cases step with + | none => simp at htail + | some step => + have hstepStarts := startTableAgrees_of_mem_runCleanFromTable _ state fuel table + hstarts step hstep + have hrest := ih step.value.1 step.state step.remaining step.value.2 hstepStarts.2 htail + exact ⟨hrest.1, hrest.2.1, fun hfinal => + deferredCompletable_of_mem_runCleanFromTable _ state fuel table step hstarts hstep + (hrest.2.2 hfinal)⟩ + | inr message => + simp only [mem_support_bind_iff] at hresult + obtain ⟨step, hstep, htail⟩ := hresult + cases step with + | none => simp at htail + | some step => + have hstepStarts := startTableAgrees_of_mem_runCleanFromTable _ state fuel table + hstarts step hstep + have hrest := ih step.value.1 step.state step.remaining step.value.2 hstepStarts.2 htail + exact ⟨hrest.1, hrest.2.1, fun hfinal => + deferredCompletable_of_mem_runCleanFromTable _ state fuel table step hstarts hstep + (hrest.2.2 hfinal)⟩ + +theorem evalDist_materializedCleanBoundary_eq_true_of_not_completable + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hstarts : StartTableAgrees state table) + (hdoomed : ¬DeferredCompletable table (directDeferredContext state)) + (hobserve : ∀ nextState remaining value, StartTableAgrees nextState table → + ¬DeferredCompletable table (directDeferredContext nextState) → + evalDist (observe (directDeferredContext nextState) remaining value) = + evalDist (pure true : ProbComp Bool)) : + evalDist (materializedCleanBoundary parameter root ftsSecret computation state fuel table + cache >>= finishCleanFailureObserve (fun _ nextState remaining value => + observe (directDeferredContext nextState) remaining value)) = + evalDist (pure true : ProbComp Bool) := by + calc + _ = evalDist (materializedCleanBoundary parameter root ftsSecret computation state fuel table + cache >>= fun _ => (pure true : ProbComp Bool)) := by + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hcomplete := completion_of_mem_materializedCleanBoundary parameter root + ftsSecret computation state fuel table cache result hstarts hresult + exact hobserve result.state result.remaining result.value hcomplete.2.1 + (fun hfinal => hdoomed (hcomplete.2.2 hfinal)) + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails _ (by simp) _ + +theorem evalDist_rootAwareMaterializedBoundaryOrdinary_eq_clean + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hstarts : StartTableAgrees state table) + (hobserve : ∀ nextState remaining value, StartTableAgrees nextState table → + ¬DeferredCompletable table (directDeferredContext nextState) → + evalDist (observe (directDeferredContext nextState) remaining value) = + evalDist (pure true : ProbComp Bool)) : + evalDist (rootAwareMaterializedDetailedBoundaryOrdinaryObserve parameter root ftsSecret + computation observe (directDeferredContext state) fuel table cache) = + evalDist (materializedCleanBoundary parameter root ftsSecret computation state fuel table + cache >>= finishCleanFailureObserve (fun _ nextState remaining value => + observe (directDeferredContext nextState) remaining value)) := by + induction computation using OracleComp.inductionOn generalizing state fuel cache with + | pure value => + simp [rootAwareMaterializedDetailedBoundaryOrdinaryObserve, materializedCleanBoundary, + finishCleanFailureObserve] + | query_bind query next ih => + rw [rootAwareMaterializedDetailedBoundaryOrdinaryObserve, OracleComp.construct_query_bind, + materializedCleanBoundary, OracleComp.construct_query_bind] + cases query with + | inl world => + cases world with + | inl n => + rw [evalDist_runDirectDetailedOrdinary_eq_cleanFailureObserve, bind_assoc] + apply evalDist_bind_congr + intro step hstep + cases step with + | none => rfl + | some step => + have hstepStarts := startTableAgrees_of_mem_runCleanFromTable _ state fuel table + hstarts step hstep + have hnotPrivate := not_privateStructuralHit_of_directDeferredContext + (directDeferredContext step.state) rfl + simp only [finishCleanFailureObserve] + by_cases hcomplete : DeferredCompletable table (directDeferredContext step.state) + · simp only [classifyDirectDetailedOrdinaryObserve, hnotPrivate, hcomplete, ↓reduceIte] + exact ih step.value.1 step.state step.remaining step.value.2 hstepStarts.2 + · simp only [classifyDirectDetailedOrdinaryObserve, hnotPrivate, hcomplete, ↓reduceIte] + exact (evalDist_materializedCleanBoundary_eq_true_of_not_completable parameter root + ftsSecret (next step.value.1) observe step.state step.remaining table step.value.2 + hstepStarts.2 hcomplete hobserve).symm + | inr input => + rw [evalDist_runDirectDetailedOrdinary_eq_cleanFailureObserve, bind_assoc] + apply evalDist_bind_congr + intro step hstep + cases step with + | none => rfl + | some step => + have hstepStarts := startTableAgrees_of_mem_runCleanFromTable _ state fuel table + hstarts step hstep + have hnotPrivate := not_privateStructuralHit_of_directDeferredContext + (directDeferredContext step.state) rfl + simp only [finishCleanFailureObserve] + by_cases hcomplete : DeferredCompletable table (directDeferredContext step.state) + · simp only [classifyDirectDetailedOrdinaryObserve, hnotPrivate, hcomplete, ↓reduceIte] + exact ih step.value.1 step.state step.remaining step.value.2 hstepStarts.2 + · simp only [classifyDirectDetailedOrdinaryObserve, hnotPrivate, hcomplete, ↓reduceIte] + exact (evalDist_materializedCleanBoundary_eq_true_of_not_completable parameter root + ftsSecret (next step.value.1) observe step.state step.remaining table step.value.2 + hstepStarts.2 hcomplete hobserve).symm + | inr message => + rw [evalDist_runDirectDetailedOrdinary_eq_cleanFailureObserve, bind_assoc] + apply evalDist_bind_congr + intro step hstep + cases step with + | none => rfl + | some step => + have hstepStarts := startTableAgrees_of_mem_runCleanFromTable _ state fuel table + hstarts step hstep + have hnotPrivate := not_privateStructuralHit_of_directDeferredContext + (directDeferredContext step.state) rfl + simp only [finishCleanFailureObserve] + by_cases hcomplete : DeferredCompletable table (directDeferredContext step.state) + · simp only [classifyDirectDetailedOrdinaryObserve, hnotPrivate, hcomplete, ↓reduceIte] + exact ih step.value.1 step.state step.remaining step.value.2 hstepStarts.2 + · simp only [classifyDirectDetailedOrdinaryObserve, hnotPrivate, hcomplete, ↓reduceIte] + exact (evalDist_materializedCleanBoundary_eq_true_of_not_completable parameter root + ftsSecret (next step.value.1) observe step.state step.remaining table step.value.2 + hstepStarts.2 hcomplete hobserve).symm + +theorem evalDist_classifyResolvedFinalization_direct_eq_guarded + (table : OtsSecretIndex → HashOutput) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) (value : α) : + evalDist (classifyDirectOrdinaryObserve table (resolvedFinalizationObserve table) + (directDeferredContext state) fuel value) = + evalDist (Option.isNone <$> + finishMaterializedCleanRunFromTable table (some ⟨state, fuel, value, table⟩)) := by + classical + have hnotPrivate := not_privateStructuralHit_of_directDeferredContext + (directDeferredContext state) rfl + by_cases hcomplete : DeferredCompletable table (directDeferredContext state) + · simp only [classifyDirectOrdinaryObserve, hnotPrivate, hcomplete, ↓reduceIte, + finishMaterializedCleanRunFromTable] + exact evalDist_finishResolvedRunIsNone_eq_finishDirectRunIsNone state fuel value table + hcomplete + · simp [classifyDirectOrdinaryObserve, hnotPrivate, hcomplete, + finishMaterializedCleanRunFromTable] + +theorem retainedFinalizationOrdinary_dooms + (table : OtsSecretIndex → HashOutput) (root : Digest) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) + (hdoomed : ¬DeferredCompletable table (directDeferredContext state)) : + evalDist (retainedResolvedFinalizationOrdinaryObserve table root + (directDeferredContext state) fuel value) = + evalDist (pure true : ProbComp Bool) := by + have hnotPrivate := not_privateStructuralHit_of_directDeferredContext + (directDeferredContext state) rfl + simp [retainedResolvedFinalizationOrdinaryObserve, classifyDirectOrdinaryObserve, + hnotPrivate, hdoomed] + +theorem evalDist_rootAwareRetainedRestOrdinary_eq_guardedClean + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (value : Digest × SplitHashCache) (hstarts : StartTableAgrees state table) : + evalDist (rootAwareMaterializedDetailedRetainedRestOrdinaryObserve adversary parameter + table ftsSecret (directDeferredContext state) fuel value) = + evalDist (do + let result ← materializedCleanBoundary parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) state fuel table value.2 + let final ← finishMaterializedCleanRunFromTable table + (result.map fun (result : CleanRunResult (RetainedRestResult × SplitHashCache)) => + (⟨result.state, result.remaining, ((value.1, result.value.1), result.value.2), + result.table⟩ : CleanRunResult (RetainedGameResult × SplitHashCache))) + pure final.isNone) := by + unfold rootAwareMaterializedDetailedRetainedRestOrdinaryObserve + rw [evalDist_rootAwareMaterializedBoundaryOrdinary_eq_clean parameter value.1 ftsSecret + _ _ state fuel table value.2 hstarts + (fun nextState remaining nextValue _ hdoomed => + retainedFinalizationOrdinary_dooms table value.1 nextState remaining nextValue hdoomed)] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have htable := (completion_of_mem_materializedCleanBoundary parameter value.1 + ftsSecret _ state fuel table value.2 result hstarts hresult).1 + simp only [finishCleanFailureObserve, retainedResolvedFinalizationOrdinaryObserve, + Option.map_some, htable] + exact evalDist_classifyResolvedFinalization_direct_eq_guarded table result.state + result.remaining ((value.1, result.value.1), result.value.2) + +theorem rootAwareRetainedRestOrdinary_dooms + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (value : Digest × SplitHashCache) (hstarts : StartTableAgrees state table) + (hdoomed : ¬DeferredCompletable table (directDeferredContext state)) : + evalDist (rootAwareMaterializedDetailedRetainedRestOrdinaryObserve adversary parameter + table ftsSecret (directDeferredContext state) fuel value) = + evalDist (pure true : ProbComp Bool) := by + unfold rootAwareMaterializedDetailedRetainedRestOrdinaryObserve + have hobserve := fun nextState remaining nextValue (_ : StartTableAgrees nextState table) + (hdoomed : ¬DeferredCompletable table (directDeferredContext nextState)) => + retainedFinalizationOrdinary_dooms table value.1 nextState remaining nextValue hdoomed + rw [evalDist_rootAwareMaterializedBoundaryOrdinary_eq_clean parameter value.1 ftsSecret + _ _ state fuel table value.2 hstarts hobserve] + exact evalDist_materializedCleanBoundary_eq_true_of_not_completable parameter value.1 + ftsSecret _ _ state fuel table value.2 hstarts hdoomed hobserve + +attribute [local irreducible] maskedPublishedTreeRoot in +theorem evalDist_rootAwareMaterializedRetainedOrdinary_eq_clean + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (rootAwareMaterializedBoundaryDetailedRetainedOrdinary adversary parameter table + ftsSecret fuel) = + evalDist (do + let result ← materializedCleanRetainedRunFromTable adversary parameter ftsSecret + (2 * fuel) table + let final ← finishMaterializedCleanRunFromTable table result + pure final.isNone) := by + unfold rootAwareMaterializedBoundaryDetailedRetainedOrdinary + materializedCleanRetainedRunFromTable + rw [evalDist_runDirectDetailedOrdinary_eq_cleanFailureObserve, bind_assoc] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hstarts := (startTableAgrees_of_mem_runCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) LazyRevealProbe.State.empty + (2 * fuel) table (startTableAgrees_empty table) result hresult).2 + have hnotPrivate := not_privateStructuralHit_of_directDeferredContext + (directDeferredContext result.state) rfl + have hrest := evalDist_rootAwareRetainedRestOrdinary_eq_guardedClean adversary parameter + table ftsSecret result.state result.remaining result.value hstarts + simp only [finishCleanFailureObserve] + by_cases hcomplete : DeferredCompletable table (directDeferredContext result.state) + · simp only [classifyDirectDetailedOrdinaryObserve, hnotPrivate, hcomplete, ↓reduceIte] + rw [hrest, bind_assoc] + apply evalDist_bind_congr + intro rest _ + cases rest <;> rfl + · simp only [classifyDirectDetailedOrdinaryObserve, hnotPrivate, hcomplete, ↓reduceIte] + rw [← rootAwareRetainedRestOrdinary_dooms adversary parameter table ftsSecret + result.state result.remaining result.value hstarts hcomplete, hrest, bind_assoc] + apply evalDist_bind_congr + intro rest _ + cases rest <;> rfl + +theorem probEvent_sampledRootAwareRetainedOrdinary_eq_clean + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[= true | sampledRootAwareMaterializedBoundaryDetailedRetainedOrdinary adversary + parameter ftsSecret fuel] = + Pr[= none | sampledMaterializedClean adversary parameter ftsSecret (2 * fuel)] := by + have hdist : evalDist + (sampledRootAwareMaterializedBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret fuel) = + evalDist (Option.isNone <$> + sampledMaterializedClean adversary parameter ftsSecret (2 * fuel)) := by + unfold sampledRootAwareMaterializedBoundaryDetailedRetainedOrdinary sampledMaterializedClean + rw [map_bind] + apply evalDist_bind_congr + intro table _ + rw [map_bind] + exact evalDist_rootAwareMaterializedRetainedOrdinary_eq_clean adversary parameter table + ftsSecret fuel + rw [OracleComp.probOutput_congr rfl hdist, ← probEvent_eq_eq_probOutput, + probEvent_map, ← probEvent_eq_eq_probOutput] + apply OracleComp.probEvent_congr' + · intro result _ + simp + · rfl + +theorem probEvent_sampledRootAwareRetainedOrdinary_le_five_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[= true | sampledRootAwareMaterializedBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret q] ≤ + ((5 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + rw [probEvent_sampledRootAwareRetainedOrdinary_eq_clean] + exact probEvent_sampledMaterializedClean_none_le_five_mul adversary parameter ftsSecret q + hexpanded hq + +theorem probEvent_sampledCanonicalBoundary_failed_le_thirteen_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[fun output => output.outcome.failed = true | + sampledGranularAllCanonicalBoundaryWitnessPlan adversary parameter ftsSecret q] ≤ + ((13 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ Pr[fun output => output.witnessPlan.1.isSome = true | + sampledGranularAllCanonicalBoundaryWitnessPlan adversary parameter ftsSecret q] + + Pr[fun outcome => outcome.ordinary = true | + sampledRootAwareMaterializedBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret q] := + probEvent_sampledCanonicalBoundary_failed_le_witness_add_materializedOrdinary + adversary parameter ftsSecret q hexpanded + _ = Pr[fun output => output.1.isSome = true | + sampledGranularAllCanonicalPrivateWitnessPlan adversary parameter ftsSecret q] + + Pr[= true | sampledRootAwareMaterializedBoundaryDetailedRetainedOrdinary adversary + parameter ftsSecret q] := by + rw [probEvent_witness_sampledGranularAllCanonicalBoundaryWitnessPlan_eq, + probEvent_ordinary_sampledRootAwareMaterializedBoundaryDetailedRetainedOutcome] + _ ≤ ((8 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + ((5 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + add_le_add + (probEvent_sampledCanonical_privateWitnessPlan_le_eight_mul adversary parameter + ftsSecret q hexpanded hq) + (probEvent_sampledRootAwareRetainedOrdinary_le_five_mul adversary parameter + ftsSecret q hexpanded hq) + _ = _ := by + push_cast + ring + +theorem probEvent_sampledCanonicalBoundary_finishIsNone_le_thirteen_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[= true | sampledGranularAllCanonicalBoundaryRetainedFinishIsNone adversary parameter + ftsSecret q] ≤ + ((13 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + have heq := OracleComp.probOutput_congr (show true = true from rfl) + (evalDist_failed_sampledGranularAllCanonicalBoundaryWitnessPlan adversary parameter + ftsSecret q) + rw [← heq, ← probEvent_eq_eq_probOutput, probEvent_map] + exact probEvent_sampledCanonicalBoundary_failed_le_thirteen_mul adversary parameter + ftsSecret q hexpanded hq + +attribute [local irreducible] maskedPublishedTreeRoot in +theorem evalDist_granularAllCanonicalBoundaryRetainedFinishIsNone_eq_allDirect + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (granularAllCanonicalBoundaryRetainedFinishIsNone adversary parameter table ftsSecret fuel) = + evalDist (allDirectBoundaryDeferredRetainedFinishIsNone adversary parameter table ftsSecret fuel) := by + unfold granularAllCanonicalBoundaryRetainedFinishIsNone + allDirectBoundaryDeferredRetainedFinishIsNone runDirectResolvedObserve + apply evalDist_bind_congr + intro rootOption hroot + cases rootOption with + | none => rfl + | some result => + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) emptyWitnessDeferredContext fuel table + result DeferredContext.valid_empty.valuesConsistent (startTableAgrees_empty table) hroot + have hraw := raw_done_of_mem_runDirectResolvedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) emptyWitnessDeferredContext fuel table + result hroot + have hpub := preservesPublishedValues_maskedPublishedTreeRoot + LazyRevealProbe.State.empty emptySplitHashCache fuel result.context.state + result.remaining result.value.1 result.value.2 publishedValues_empty hraw + have hmat : ∀ coordinate, CoordinateMaterializedPublished coordinate result.context.state := by + intro coordinate + exact preservesCoordinateMaterializedPublished_maskedPublishedTreeRoot coordinate + LazyRevealProbe.State.empty emptySplitHashCache fuel result.context.state + result.remaining result.value.1 result.value.2 + (by simp [CoordinateMaterializedPublished, LazyRevealProbe.State.empty]) hraw + have hcanonical := canonicalMaterializedValues_of_published table result.context hcore.2.2 hpub hmat + simp only [finishObserve, canonicalizeObserve, hpub, ↓reduceIte, hcanonical.canonicalize_eq] + exact evalDist_granularRetainedRestObserve_eq_allDirect adversary parameter table ftsSecret + result.context result.remaining result.value hcore.2.1 hcore.2.2 hpub hcanonical + +theorem evalDist_sampledCanonicalBoundary_eq_deferred + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (sampledGranularAllCanonicalBoundaryRetainedFinishIsNone adversary parameter ftsSecret fuel) = + evalDist (sampledCanonicalDeferredFinishIsNone adversary parameter ftsSecret fuel) := by + rw [evalDist_sampledCanonicalDeferredFinishIsNone_eq_allDirect] + unfold sampledGranularAllCanonicalBoundaryRetainedFinishIsNone sampledAllDirectBoundaryFinishIsNone + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro table + exact evalDist_granularAllCanonicalBoundaryRetainedFinishIsNone_eq_allDirect + adversary parameter table ftsSecret fuel + +theorem probEvent_sampledActualRetained_verifyProbe_le_thirteen_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + ((13 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply (probEvent_sampledActualRetainedOtsHashTable_verifyProbe_le_canonicalDeferred + adversary parameter ftsSecret q).trans + rw [← OracleComp.probOutput_congr (show true = true from rfl) + (evalDist_sampledCanonicalBoundary_eq_deferred adversary parameter ftsSecret q)] + exact probEvent_sampledCanonicalBoundary_finishIsNone_le_thirteen_mul + adversary parameter ftsSecret q hexpanded hq + +theorem security_of_completed_canonical_boundary : SphincsSecurityStatement := by + apply security_of_sampledWinningRetainedVerifyProbe_grouped_le_mul 13 (by omega) + intro q _hqPos adversary hq hqMax parameter hparameter ftsSecret hfts + exact probEvent_sampledActualRetained_verifyProbe_le_thirteen_mul adversary parameter ftsSecret q + (fun table root => isQueryBoundP_expandedRetained_all_tables_roots adversary q hq + parameter hparameter table ftsSecret hfts root) hqMax + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCandidateRiskComponents.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCandidateRiskComponents.lean new file mode 100644 index 00000000..a2587f45 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCandidateRiskComponents.lean @@ -0,0 +1,57 @@ +import SphincsSecurity.Proof.OtsProbeWeightedReserve + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem candidateFailureAllowance_eq_components + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) (candidate : Option Probe) + (hpublic : MaterializedStartsPublished context) : + candidateFailureAllowance table context candidate = + unresolvedStartCandidateAllowance table context candidate + + unresolvedPositionCandidateCharge context candidate * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + structuralCandidateFailureAllowance context candidate := by + cases candidate with + | none => simp [candidateFailureAllowance, unresolvedStartCandidateAllowance, + unresolvedPositionCandidateCharge, structuralCandidateFailureAllowance] + | some candidate => + rcases candidate with ⟨coordinate, digest⟩ + cases coordinate with + | position position => + simpa only [unresolvedStartCandidateAllowance, unresolvedPositionCandidateCharge, zero_add] using + candidateFailureAllowance_position_eq table context position digest + | chainStart lay tree leafIdx chainIdx => + by_cases hmissing : context.state.values (.chainStart lay tree leafIdx chainIdx) = none + · simp [unresolvedStartCandidateAllowance, unresolvedPositionCandidateCharge, + structuralCandidateFailureAllowance, hmissing] + · have hrevealed := hpublic ⟨lay, tree, leafIdx, chainIdx⟩ hmissing + simp only [OtsSecretIndex.coordinate] at hrevealed + simp [candidateFailureAllowance, unresolvedStartCandidateAllowance, unresolvedPositionCandidateCharge, + structuralCandidateFailureAllowance, hrevealed, hmissing] + +def KnownStructuralCandidateHit (context : DeferredContext) : Option Probe → Prop + | some ⟨.position position, digest⟩ => + .position position ∉ context.state.revealed ∧ (.position position, digest) ∉ context.state.pending ∧ + ∃ output, context.positionValue position = some output ∧ truncateHash output = digest + | _ => False + +theorem structuralCandidateFailureAllowance_eq_indicator (context : DeferredContext) (candidate : Option Probe) : + structuralCandidateFailureAllowance context candidate = if KnownStructuralCandidateHit context candidate then 1 else 0 := by + cases candidate with + | none => simp [structuralCandidateFailureAllowance, KnownStructuralCandidateHit] + | some candidate => + rcases candidate with ⟨coordinate, digest⟩ + cases coordinate with + | chainStart lay tree leafIdx chainIdx => simp [structuralCandidateFailureAllowance, KnownStructuralCandidateHit] + | position position => + by_cases hrevealed : Coordinate.position position ∈ context.state.revealed + · simp [structuralCandidateFailureAllowance, KnownStructuralCandidateHit, hrevealed] + · by_cases hpending : (Coordinate.position position, digest) ∈ context.state.pending + · simp [structuralCandidateFailureAllowance, KnownStructuralCandidateHit, hpending] + · cases hvalue : context.positionValue position <;> + simp [structuralCandidateFailureAllowance, KnownStructuralCandidateHit, hrevealed, hpending, hvalue] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalCharge.lean new file mode 100644 index 00000000..5e25923a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalCharge.lean @@ -0,0 +1,125 @@ +import SphincsSecurity.Proof.OtsProbeResolvedComputedCoupling +import SphincsSecurity.Proof.MappedQueryCharge +import SphincsSecurity.Proof.CoupledQueryCost + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable + +noncomputable def expectedCanonicalQueryCharge + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ℝ≥0∞) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → ℝ≥0∞ := by + classical + exact OracleComp.construct (fun _ _ _ _ _ => 0) + (fun input _ next context fuel table cache => + if DeferredCompletable table context then + charge input context fuel cache + + ∑' result, Pr[= result | + canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache] * + match result with + | none => 0 + | some result => next result.value.1 result.context result.remaining result.table result.value.2 + else 0) computation + +theorem expectedCanonicalQueryCharge_query_bind + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ℝ≥0∞) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + expectedCanonicalQueryCharge parameter root ftsSecret charge (OracleSpec.query input >>= next) + context fuel table cache = + if DeferredCompletable table context then + charge input context fuel cache + + ∑' result, Pr[= result | + canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache] * + match result with + | none => 0 + | some result => expectedCanonicalQueryCharge parameter root ftsSecret charge (next result.value.1) + result.context result.remaining result.table result.value.2 + else 0 := by + classical + rfl + +theorem expectedCanonicalQueryCharge_eq_zero_of_not_completable + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ℝ≥0∞) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hnot : ¬DeferredCompletable table context) : + expectedCanonicalQueryCharge parameter root ftsSecret charge computation context fuel table cache = 0 := by + induction computation using OracleComp.inductionOn with + | pure value => rfl + | query_bind input next _ => rw [expectedCanonicalQueryCharge_query_bind, if_neg hnot] + +set_option maxRecDepth 100000 in +theorem expectedCanonicalQueryCharge_le_outerQueryCharge + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ℝ≥0∞) + (actualCharge : QueryCache HashSpec → HashInput → ℝ≥0∞) + (hcharge : ∀ input context fuel cache actualCache, + ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache → + VisibleResolvedComputationsCached parameter table context actualCache → + PublishedValues context.state → DeferredComputationsClosed context → + charge input context fuel cache ≤ outerHashQueryCharge actualCharge input actualCache) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + expectedCanonicalQueryCharge parameter root ftsSecret charge computation context fuel table cache ≤ + expectedOuterQueryCharge + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) actualCharge computation actualCache := by + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + change _ ≤ expectedOuterQueryCharge secretKey actualCharge computation actualCache + induction computation using OracleComp.inductionOn generalizing context fuel cache actualCache with + | pure value => exact le_rfl + | query_bind input next ih => + rw [expectedCanonicalQueryCharge_query_bind, if_pos hinvariant.2.2.2.1, + expectedOuterQueryCharge_query_bind] + apply add_le_add (hcharge input context fuel cache actualCache hinvariant hvisible hpublished hcomputed) + have hstep := canonicalReachableResolvedImplCouples_chronologicalAdversaryImpl parameter root table ftsSecret + input context fuel cache actualCache hinvariant hvisible hpublished + have hsupported := FtsProbeSimulation.relTriple_and_left_support hstep + (fun left => ∀ result, left = some result → DeferredComputationsClosed result.context) (by + intro left hleft result heq + subst left + exact hcomputed.of_mem_canonicalChronologicalQuery parameter root table ftsSecret input + context fuel cache result hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hleft) + have hcost := expected_cost_le_of_relTriple hsupported + (fun left => match left with + | none => 0 + | some result => expectedCanonicalQueryCharge parameter root ftsSecret charge (next result.value.1) + result.context result.remaining result.table result.value.2) + (fun right => expectedOuterQueryCharge secretKey actualCharge (next right.1) right.2) + (fun _ => 0) (by + intro left right hrelation + simp only [add_zero] + cases left with + | none => exact bot_le + | some result => + dsimp only + have hresultComputed := hrelation.2 result rfl + rcases hrelation.1 with hclean | hdoomed + · rw [hclean.1, ← hclean.2.1] + exact ih result.value.1 result.context result.remaining result.value.2 right.2 + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 hresultComputed + · rw [expectedCanonicalQueryCharge_eq_zero_of_not_completable parameter root ftsSecret charge + (next result.value.1) result.context result.remaining result.table result.value.2 (by + rw [hdoomed.1] + exact hdoomed.2.2.2)] + exact bot_le) + simpa only [mul_zero, tsum_zero, add_zero] using hcost + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalChargeGame.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalChargeGame.lean new file mode 100644 index 00000000..edbae3c0 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalChargeGame.lean @@ -0,0 +1,51 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalJointCharge + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +theorem expectedQueryCharge_map + (charge : QueryCache HashSpec → HashInput → ℝ≥0∞) + (computation : OracleComp OracleWorld α) (f : α → β) (cache : QueryCache HashSpec) : + expectedQueryCharge charge (f <$> computation) cache = expectedQueryCharge charge computation cache := by + rw [map_eq_bind_pure_comp, expectedQueryCharge_bind] + simp only [Function.comp_apply, expectedQueryCharge_pure, mul_zero, tsum_zero, add_zero] + +namespace Concrete.OtsProbeSimulation + +theorem otsOpeningRefinedQueryReserve_set_root + (secretKey : SecretKey) (root : Digest) : + otsOpeningRefinedQueryReserve { secretKey with root := root } = otsOpeningRefinedQueryReserve secretKey := by + rfl + +theorem gameRest_eq_map_retained + (adversary : Adversary) (secretKey : SecretKey) (publicKey : PublicKey) : + gameRest scheme adversary publicKey secretKey = + (fun result : RetainedRestResult => + decide (SigningTranscript.Valid result.1.2 ∧ ¬SigningTranscript.Contains result.1.2 result.1.1) && result.2) <$> + simulateQ (expandedAdversaryImpl secretKey) (retainedGameRestComputation adversary publicKey) := by + unfold gameRest retainedGameRestComputation + rw [simulateQ_bind, ← simulateQ_withTraceAppend_run_eq_signingTraceComputation, + ← forwardOracles_add_signingOracle_eq_withTraceAppend, map_bind] + apply bind_congr + intro result + rcases result with ⟨forgery, log⟩ + rw [simulateQ_bind] + have hlift : simulateQ (expandedAdversaryImpl secretKey) + (liftOracleWorldLeft (scheme.verify publicKey forgery.message forgery.signature)) = + scheme.verify publicKey forgery.message forgery.signature := + FtsProbeSimulation.simulateQ_expanded_liftOracleWorldLeft secretKey _ + rw [hlift] + simp only [simulateQ_pure, map_bind, map_pure] + +theorem expectedQueryCharge_retained_eq_gameRest + (adversary : Adversary) (secretKey : SecretKey) (publicKey : PublicKey) + (charge : QueryCache HashSpec → HashInput → ℝ≥0∞) (cache : QueryCache HashSpec) : + expectedQueryCharge charge (simulateQ (expandedAdversaryImpl secretKey) + (retainedGameRestComputation adversary publicKey)) cache = + expectedQueryCharge charge (gameRest scheme adversary publicKey secretKey) cache := by + rw [gameRest_eq_map_retained, expectedQueryCharge_map] + +end Concrete.OtsProbeSimulation + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalChargeRoot.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalChargeRoot.lean new file mode 100644 index 00000000..03556dd8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalChargeRoot.lean @@ -0,0 +1,88 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalChargeGame + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def canonicalJointChargeAfterTable + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : ℝ≥0∞ := + ∑' result, Pr[= result | runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)] * + match result with + | none => 0 + | some result => expectedCanonicalQueryCharge parameter result.value.1 ftsSecret + (canonicalJointOuterCharge parameter) + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining table result.value.2 + +set_option maxRecDepth 100000 in +theorem canonicalJointChargeAfterTable_le_gameReserve + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + canonicalJointChargeAfterTable adversary parameter table ftsSecret fuel ≤ + expectedQueryCharge (otsOpeningRefinedQueryReserve + (primitiveAccountingKey parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret)) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) ∅ := by + let otsSecret := fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩) + let accountingKey := primitiveAccountingKey parameter otsSecret ftsSecret + let actualCost := fun result : Digest × QueryCache HashSpec => + expectedQueryCharge (otsOpeningRefinedQueryReserve accountingKey) + (gameRest scheme adversary ⟨result.1, parameter⟩ ⟨parameter, result.1, otsSecret, ftsSecret⟩) result.2 + have hroot := reachableResolvedCouples_maskedPublishedTreeRoot parameter table + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel emptySplitHashCache ∅ (resolvedContextInvariant_empty parameter table) + (visibleResolvedComputationsCached_empty parameter table emptyDeferredStructuralValues ∅) publishedValues_empty + have hsupported := FtsProbeSimulation.relTriple_and_left_support hroot + (fun left => ∀ result, left = some result → DeferredComputationsClosed result.context) (by + intro left hleft result heq + subst left + exact deferredComputationsClosed_empty.of_mem_runResolved _ _ fuel table result hleft) + have hcost : canonicalJointChargeAfterTable adversary parameter table ftsSecret fuel ≤ + ∑' result, Pr[= result | (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅] * actualCost result := by + have hbound := expected_cost_le_of_relTriple hsupported + (fun left => match left with + | none => 0 + | some result => expectedCanonicalQueryCharge parameter result.value.1 ftsSecret + (canonicalJointOuterCharge parameter) + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining table result.value.2) + actualCost (fun _ => 0) (by + intro left right hrelation + simp only [add_zero] + cases left with + | none => exact bot_le + | some result => + dsimp only + rcases hrelation.1 with hclean | hdoomed + · have hcomputed := hrelation.2 result rfl + have hlocal := expectedCanonicalJointCharge_le_actualReserve parameter result.value.1 table ftsSecret + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining result.value.2 right.2 hclean.2.2.1 + hclean.2.2.2.1 hclean.2.2.2.2 hcomputed + have hreserve : otsOpeningRefinedQueryReserve + (⟨parameter, result.value.1, otsSecret, ftsSecret⟩ : SecretKey) = + otsOpeningRefinedQueryReserve accountingKey := + otsOpeningRefinedQueryReserve_set_root accountingKey result.value.1 + rw [hreserve, expectedQueryCharge_retained_eq_gameRest] at hlocal + simpa only [actualCost, ← hclean.2.1] using hlocal + · rw [expectedCanonicalQueryCharge_eq_zero_of_not_completable parameter result.value.1 ftsSecret + (canonicalJointOuterCharge parameter) + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining table result.value.2 hdoomed.2.2.2] + exact bot_le) + simpa only [canonicalJointChargeAfterTable, treeRoot, otsSecret, mul_zero, tsum_zero, add_zero] using hbound + apply hcost.trans + change _ ≤ expectedQueryCharge (otsOpeningRefinedQueryReserve accountingKey) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ + rw [gameAfterSecrets, expectedQueryCharge_bind, simulateQ_romImpl_liftM] + exact le_add_self + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalChargeSampled.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalChargeSampled.lean new file mode 100644 index 00000000..d499b1bb --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalChargeSampled.lean @@ -0,0 +1,36 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalChargeRoot + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +noncomputable def sampledCanonicalJointCharge (adversary : Adversary) (fuel : Nat) : ℝ≥0∞ := + ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' table, Pr[= table | sampleOtsHashTable] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + canonicalJointChargeAfterTable adversary parameter table ftsSecret fuel + +set_option maxRecDepth 100000 in +theorem sampledCanonicalJointCharge_le_refinedReserve (adversary : Adversary) (fuel : Nat) : + sampledCanonicalJointCharge adversary fuel ≤ sampledQueryCharge otsOpeningRefinedQueryReserve adversary := by + unfold sampledCanonicalJointCharge sampledQueryCharge + simp only [sampleSecrets, tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + apply ENNReal.tsum_le_tsum + intro parameter + apply mul_le_mul' le_rfl + have hcoupled := expected_cost_le_of_relTriple relTriple_uniformOtsHashTable_sampleOtsSecrets + (fun table => ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + canonicalJointChargeAfterTable adversary parameter table ftsSecret fuel) + (fun otsSecret => ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + expectedQueryCharge (otsOpeningRefinedQueryReserve (primitiveAccountingKey parameter otsSecret ftsSecret)) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅) + (fun _ => 0) (by + intro table otsSecret hsecrets + simp only [add_zero] + rw [← hsecrets] + apply ENNReal.tsum_le_tsum + intro ftsSecret + exact mul_le_mul' le_rfl (canonicalJointChargeAfterTable_le_gameReserve adversary parameter table ftsSecret fuel)) + simpa only [sampleOtsHashTable, mul_zero, tsum_zero, add_zero] using hcoupled + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalFuel.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalFuel.lean new file mode 100644 index 00000000..669cc807 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalFuel.lean @@ -0,0 +1,310 @@ +import SphincsSecurity.Proof.OtsProbeRetainedPrehitProjection + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +set_option maxRecDepth 100000 in +theorem fuel_bounds_of_mem_runResolvedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (table : OtsSecretIndex → HashOutput) + (result : ResolvedRunResult α) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hresult : some result ∈ support (runResolvedFromTable context fuel table computation)) : + result.remaining ≤ fuel ∧ fuel ≤ result.remaining + bound := by + induction computation using OracleComp.inductionOn generalizing context fuel bound table with + | pure value => + simp only [runResolvedFromTable, OracleComp.construct_pure, mem_support_pure_iff, Option.some.injEq] at hresult + subst result + exact ⟨le_rfl, Nat.le_add_right _ _⟩ + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases input with + | uniform n => + rw [runResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel bound table (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) htail + | hashOutput => + rw [runResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel bound table (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) htail + | ensure coordinate => + rw [runResolvedFromTable_ensure_query_bind] at hresult + exact ih () _ fuel bound table (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) hresult + | probe coordinate candidate => + cases fuel with + | zero => simp [runResolvedFromTable_probe_query_bind] at hresult + | succ fuel => + have hpositive : 0 < bound := by simpa [LazyRevealProbe.IsProbe] using hbound.1 + rw [runResolvedFromTable_probe_query_bind] at hresult + split_ifs at hresult + · have htail := ih () context fuel (bound - 1) table + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) hresult + omega + · have htail := ih () _ fuel (bound - 1) table + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) hresult + omega + | peek coordinate => + rw [runResolvedFromTable_peek_query_bind] at hresult + exact ih _ context fuel bound table (by simpa [LazyRevealProbe.IsProbe] using hbound.2 _) hresult + | publish coordinate => + rw [runResolvedFromTable_publish_query_bind] at hresult + exact ih () _ fuel bound table (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) hresult + | reveal coordinate => + rw [runResolvedFromTable_reveal_query_bind] at hresult + cases coordinate <;> rw [mem_support_bind_iff] at hresult + all_goals + obtain ⟨resolvedOption, _hresolved, htail⟩ := hresult + cases resolvedOption with + | none => simp at htail + | some resolved => + exact ih resolved.output _ fuel bound table (by simpa [LazyRevealProbe.IsProbe] using hbound.2 resolved.output) htail + +def outerHashQueryCount : (OracleWorld + SigningSpec).Domain → Nat + | .inl (.inr _input) => 1 + | _ => 0 + +theorem maskedChronologicalExpandedAdversaryImpl_probeBound + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (cache : SplitHashCache) : + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache).IsQueryBoundP + LazyRevealProbe.IsProbe (outerHashQueryCount input) := by + cases input with + | inl query => + cases query with + | inl n => exact splitUniformImpl_probeFree n cache + | inr input => exact probingHashQuery_run_isProbeBound parameter input cache + | inr message => exact maskedPublishedChronologicalSign_probeFree parameter root ftsSecret message cache + +theorem fuel_bounds_of_mem_canonicalChronologicalQuery + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult ((OracleWorld + SigningSpec).Range input × SplitHashCache)) + (hresult : some result ∈ support + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache)) : + result.remaining ≤ fuel ∧ fuel ≤ result.remaining + outerHashQueryCount input := by + rw [canonicalChronologicalAdversaryImpl_eq_raw_then_canonicalize, mem_support_bind_iff] at hresult + obtain ⟨rawOption, hraw, hcanonical⟩ := hresult + cases rawOption with + | none => simp [canonicalizeResolvedRun] at hcanonical + | some raw => + simp only [canonicalizeResolvedRun, mem_support_pure_iff, Option.some.injEq] at hcanonical + subst result + exact fuel_bounds_of_mem_runResolvedFromTable _ context fuel (outerHashQueryCount input) table raw + (maskedChronologicalExpandedAdversaryImpl_probeBound parameter root ftsSecret input cache) hraw + +theorem remaining_eq_fuel_of_mem_resolved_maskedPublishedTreeRoot + (table : OtsSecretIndex → HashOutput) (fuel : Nat) (result : ResolvedRunResult (Digest × SplitHashCache)) + (hresult : some result ∈ support (runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) : + result.remaining = fuel := by + have hbounds := fuel_bounds_of_mem_runResolvedFromTable _ _ fuel 0 table result + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) hresult + omega + +def canonicalTraceHashCount (history : List CanonicalQuerySelection) : Nat := + (history.map fun entry => outerHashQueryCount entry.input).sum + +def prehitTraceHashCount (history : List PrehitQuerySnapshot) : Nat := + (history.map fun entry => outerHashQueryCount entry.input).sum + +set_option maxRecDepth 100000 in +theorem fuel_le_entry_add_hashCount_of_canonicalQueryTrace + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) + (hrun : result ∈ support (runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache)) : + ∀ entry ∈ result.2, fuel ≤ entry.fuel + canonicalTraceHashCount result.2 := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache result with + | pure value => + simp only [runCanonicalQueryTrace, OracleComp.construct_pure] at hrun + split_ifs at hrun <;> simp only [mem_support_pure_iff] at hrun <;> subst result <;> simp + | query_bind input next ih => + rw [runCanonicalQueryTrace_query_bind] at hrun + split_ifs at hrun with hcomplete + · rw [mem_support_bind_iff] at hrun + obtain ⟨step, hstep, hrun⟩ := hrun + cases step with + | none => + simp only [pure_bind, mem_support_pure_iff] at hrun + subst result + intro entry hentry + simp only [List.mem_singleton] at hentry + subst entry + exact Nat.le_add_right _ _ + | some step => + rw [mem_support_bind_iff] at hrun + obtain ⟨tail, htail, hpure⟩ := hrun + simp only [mem_support_pure_iff] at hpure + subst result + intro entry hentry + rcases List.mem_cons.mp hentry with heq | htailEntry + · subst entry + exact Nat.le_add_right _ _ + · have htailFuel := ih step.value.1 step.context step.remaining step.table step.value.2 tail htail + entry htailEntry + have hstepFuel := fuel_bounds_of_mem_canonicalChronologicalQuery parameter root ftsSecret + input context fuel table cache step hstep + simp only [canonicalTraceHashCount, List.map_cons, List.sum_cons] + unfold canonicalTraceHashCount at htailFuel + omega + · simp only [mem_support_pure_iff] at hrun + subst result + simp + +set_option maxRecDepth 100000 in +theorem prehitTraceHashCount_le_of_expanded + (accountingKey secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (q : Nat) + (hbound : (simulateQ (expandedAdversaryImpl secretKey) computation).IsQueryBoundP (· matches Sum.inr _) q) + (state : ViewedFullTraceState × Bool) + (result : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hrun : result ∈ support (runPrehitQueryTrace accountingKey secretKey computation state)) : + prehitTraceHashCount result.2 ≤ q := by + induction computation using OracleComp.inductionOn generalizing q state result with + | pure value => + simp only [runPrehitQueryTrace, OracleComp.construct_pure, mem_support_pure_iff] at hrun + subst result + simp [prehitTraceHashCount] + | query_bind input next ih => + rw [runPrehitQueryTrace_query_bind, mem_support_bind_iff] at hrun + obtain ⟨step, hstep, hrun⟩ := hrun + rw [mem_support_bind_iff] at hrun + obtain ⟨tail, htail, hpure⟩ := hrun + simp only [mem_support_pure_iff] at hpure + subst result + have hactual : (step.1, step.2.1.cache) ∈ support + ((unloggedMappedAdversaryImpl secretKey input).run state.1.cache) := by + have hprojection := encodingPrehitViewedAdversaryImpl_cache_projection accountingKey secretKey + ((OracleWorld + SigningSpec).query input) state + simp only [simulateQ_spec_query] at hprojection + rw [← hprojection, support_map] + exact ⟨step, hstep, rfl⟩ + have houtput := unloggedMappedAdversaryImpl_output_mem_support_expanded secretKey input + state.1.cache step.2.1.cache step.1 hactual + cases input with + | inl worldInput => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases worldInput with + | inl uniformInput => + have htailBound := ih step.1 q (hbound.2 step.1) step.2 tail htail + simpa [prehitTraceHashCount, outerHashQueryCount] using htailBound + | inr hashInput => + have hpositive : 0 < q := hbound.1.resolve_left (by simp) + have htailBound := ih step.1 (q - 1) (hbound.2 step.1) step.2 tail htail + change 1 + prehitTraceHashCount tail.2 ≤ q + omega + | inr request => + rw [simulateQ_expandedAdversaryImpl_query_bind_inr] at hbound + have htailBound := ih step.1 q (isQueryBoundP_of_bind hbound step.1 houtput) step.2 tail htail + simpa [prehitTraceHashCount, outerHashQueryCount] using htailBound + +theorem CanonicalQueryTraceRel.hashCount_le + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection} + {right : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot} + (hrelation : CanonicalQueryTraceRel parameter table left right) : + canonicalTraceHashCount left.2 ≤ prehitTraceHashCount right.2 := by + have hsum : ∀ (source : List CanonicalQuerySelection) (actual : List PrehitQuerySnapshot), + List.Forall₂ (fun a b => CanonicalQuerySelectionRel parameter table (some a) (some b.actual)) source actual → + canonicalTraceHashCount source = prehitTraceHashCount actual := by + intro source actual hpaired + induction hpaired with + | nil => rfl + | cons hhead _ ih => + simp only [canonicalTraceHashCount, prehitTraceHashCount, List.map_cons, List.sum_cons] at ih ⊢ + rw [hhead.1, ih] + rfl + have heq := hsum _ _ hrelation.2 + rw [heq] + exact ((List.take_sublist _ _).map _).sum_le_sum (fun _ _ => Nat.zero_le _) + +theorem fuel_le_entry_add_hashCount_of_canonicalRetainedQueryTrace + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (result : Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)) × List CanonicalQuerySelection) + (hrun : result ∈ support (canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel)) : + ∀ entry ∈ result.2, fuel ≤ entry.fuel + canonicalTraceHashCount result.2 := by + rw [canonicalRetainedQueryTrace, mem_support_bind_iff] at hrun + obtain ⟨rootOption, hroot, hrun⟩ := hrun + cases rootOption with + | none => + simp only [mem_support_pure_iff] at hrun + subst result + simp + | some root => + rw [mem_support_bind_iff] at hrun + obtain ⟨rest, hrest, hpure⟩ := hrun + simp only [mem_support_pure_iff] at hpure + subst result + have hfuel := remaining_eq_fuel_of_mem_resolved_maskedPublishedTreeRoot table fuel root hroot + simpa only [← hfuel] using fuel_le_entry_add_hashCount_of_canonicalQueryTrace parameter root.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨root.value.1, parameter⟩) + root.context root.remaining root.table root.value.2 rest hrest + +theorem prehitRetainedTraceHashCount_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (result : (RetainedGameResult × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hrun : result ∈ support (prehitRetainedQueryTrace adversary parameter table ftsSecret)) : + prehitTraceHashCount result.2 ≤ q := by + rw [prehitRetainedQueryTrace, mem_support_bind_iff] at hrun + obtain ⟨root, _hroot, hrun⟩ := hrun + rw [mem_support_bind_iff] at hrun + obtain ⟨rest, hrest, hpure⟩ := hrun + simp only [mem_support_pure_iff] at hpure + subst result + exact prehitTraceHashCount_le_of_expanded _ _ _ q + (isQueryBoundP_expandedRetained_all_tables_roots adversary q hq parameter hparameter table ftsSecret hfts root.1.1) + _ rest hrest + +theorem positive_fuel_of_coupled_canonicalRetainedTrace + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (left : Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)) × List CanonicalQuerySelection) + (right : (RetainedGameResult × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hleft : left ∈ support (canonicalRetainedQueryTrace adversary parameter table ftsSecret (q + 1))) + (hright : right ∈ support (prehitRetainedQueryTrace adversary parameter table ftsSecret)) + (hrelation : CanonicalQueryTraceRel parameter table left right) : + ∀ entry ∈ left.2, 0 < entry.fuel := by + intro entry hentry + have hfuel := fuel_le_entry_add_hashCount_of_canonicalRetainedQueryTrace adversary parameter table ftsSecret + (q + 1) left hleft entry hentry + have hsource := hrelation.hashCount_le + have hbudget := prehitRetainedTraceHashCount_le adversary q hq parameter hparameter table ftsSecret hfts right hright + omega + +open OracleComp.ProgramLogic.Relational in +theorem relTriple_canonicalRetainedQueryTrace_prehit_witness_positive_fuel + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + RelTriple (canonicalRetainedQueryTrace adversary parameter table ftsSecret (q + 1)) + (prehitRetainedQueryTrace adversary parameter table ftsSecret) + (fun left right => CanonicalQueryTraceRel parameter table left right ∧ + (WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret + (right.1.1, right.1.2.1.cache) → left.1 = none) ∧ + ∀ entry ∈ left.2, 0 < entry.fuel) := by + have hbase := relTriple_canonicalRetainedQueryTrace_prehit_witness adversary parameter table ftsSecret (q + 1) + have hleft := FtsProbeSimulation.relTriple_and_left_support hbase + (fun left => left ∈ support (canonicalRetainedQueryTrace adversary parameter table ftsSecret (q + 1))) + (fun _ hsupport => hsupport) + have hboth := FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro left right hrelation + exact ⟨hrelation.1.1.1, hrelation.1.1.2, + positive_fuel_of_coupled_canonicalRetainedTrace adversary q hq parameter hparameter table ftsSecret hfts + left right hrelation.1.2 hrelation.2 hrelation.1.1.1⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalJointCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalJointCharge.lean new file mode 100644 index 00000000..95983dac --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalJointCharge.lean @@ -0,0 +1,130 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalReserve + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +theorem purePlan_candidate_none_of_not_atOtsPosition + (parameter : PublicParameter) (input : HashInput) (state : LazyRevealProbe.State Coordinate) + (hnot : ¬∃ position : Position, IsOtsPosition position ∧ AtPosition parameter input position) : + (purePlanProbingHashQuery parameter input state).candidate? = none := by + have hprobe : decodeProbe? parameter input = none := by + cases hdecode : decodeProbe? parameter input with + | none => rfl + | some candidate => + exfalso + rcases decodePosition?_chain_or_leaf_of_decodeProbe? parameter input candidate hdecode with hchain | hleaf + · obtain ⟨lay, tree, leafIdx, chainIdx, step, hposition⟩ := hchain + exact hnot ⟨.chain lay tree leafIdx chainIdx step, trivial, + (decodePosition?_eq_some_iff parameter input _).mp hposition⟩ + · obtain ⟨lay, tree, leafIdx, hposition⟩ := hleaf + exact hnot ⟨.leaf lay tree leafIdx, trivial, + (decodePosition?_eq_some_iff parameter input _).mp hposition⟩ + apply purePlan_candidate_none_of_probe_none_nonnode parameter input state hprobe + rintro ⟨lay, tree, level, nodeIdx, hposition⟩ + exact hnot ⟨.node lay tree level nodeIdx, trivial, + (decodePosition?_eq_some_iff parameter input _).mp hposition⟩ + +theorem probingHashQueryAfterPublicPlan_ordinaryCharge_eq_executeCandidate + (parameter : PublicParameter) (input : HashInput) (publicState : LazyRevealProbe.State Coordinate) + (plan : PlannedHashQuery) (cache : SplitHashCache) (context : DeferredContext) (fuel : Nat) : + ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterPublicPlan parameter input publicState plan).run cache) context fuel = + ordinaryContinuationCharge (fun _ _ _ => 0) ((executeCandidate? plan.candidate?).run cache) context fuel := by + unfold probingHashQueryAfterPublicPlan + rw [StateT.run_bind] + apply ordinaryContinuationCharge_zero_bind_of_tail_probeFree + intro result + exact probingHashQueryPublicAction_probeFree parameter input publicState plan.action result.2 + +theorem probingHashQueryAfterPublicPlan_ordinaryCharge_le_rootAware + (parameter : PublicParameter) (input : HashInput) (publicState : LazyRevealProbe.State Coordinate) + (plan : PlannedHashQuery) (cache : SplitHashCache) (context : DeferredContext) (fuel : Nat) : + ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterPublicPlan parameter input publicState plan).run cache) context fuel ≤ + ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) context fuel := by + cases hcandidate : plan.candidate? with + | none => + rw [probingHashQueryAfterPublicPlan_ordinaryCharge_eq_executeCandidate, hcandidate] + simp [executeCandidate?, ordinaryContinuationCharge] + | some candidate => + have heq : probingHashQueryAfterPublicPlan parameter input publicState plan = + probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan := by + unfold probingHashQueryAfterPublicPlan probingHashQueryAfterRootAwarePublicPlan + simp only [rootAwareCandidateForPlan?, hcandidate] + rfl + rw [heq] + +noncomputable def canonicalJointHashCharge + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) + (fuel : Nat) (cache : SplitHashCache) : ℝ≥0∞ := + ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterPublicPlan parameter input context.state + (purePlanProbingHashQuery parameter input context.state)).run cache) + (materializedDeferredContext context) fuel + + (materializedCandidateCharge (materializedDeferredState context) + (rootAwarePlannedCandidate? parameter input context.state) : ℝ≥0∞) * (4 / 3) + +set_option maxRecDepth 100000 in +theorem canonicalJointHashCharge_le_canonicalOtsHashCharge + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) + (fuel : Nat) (cache : SplitHashCache) : + canonicalJointHashCharge parameter input context fuel cache ≤ canonicalOtsHashCharge parameter input context := by + classical + unfold canonicalOtsHashCharge canonicalJointHashCharge + split_ifs with hots + · apply le_trans (add_le_add + (probingHashQueryAfterPublicPlan_ordinaryCharge_le_rootAware parameter input context.state + (purePlanProbingHashQuery parameter input context.state) cache (materializedDeferredContext context) fuel) le_rfl) + simpa only [rootAwareCandidateForPlan?_purePlan, materializedDeferredContext, directDeferredContext] using + probingHashQueryAfterRootAwarePublicPlan_weightedCharge_le_four_thirds parameter input context.state + (purePlanProbingHashQuery parameter input context.state) cache (materializedDeferredContext context) fuel + · have hnone := purePlan_candidate_none_of_not_atOtsPosition parameter input context.state hots + rw [probingHashQueryAfterPublicPlan_ordinaryCharge_eq_executeCandidate, hnone] + simp [executeCandidate?, ordinaryContinuationCharge, rootAwarePlannedCandidate?, hnone] + +noncomputable def canonicalJointOuterCharge (parameter : PublicParameter) : + (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ℝ≥0∞ + | .inl (.inr input), context, fuel, cache => canonicalJointHashCharge parameter input context fuel cache + | _, _, _, _ => 0 + +set_option maxRecDepth 100000 in +theorem expectedCanonicalJointCharge_le_actualReserve + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + expectedCanonicalQueryCharge parameter root ftsSecret (canonicalJointOuterCharge parameter) + computation context fuel table cache ≤ + expectedQueryCharge + (otsOpeningRefinedQueryReserve + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey)) + (simulateQ (expandedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey)) computation) actualCache := by + apply le_trans ?_ (expectedOuterQueryCharge_le_expanded _ _ computation actualCache) + apply expectedCanonicalQueryCharge_le_outerQueryCharge parameter root table ftsSecret + (canonicalJointOuterCharge parameter) _ ?_ computation context fuel cache actualCache + hinvariant hvisible hpublished hcomputed + intro input nextContext remaining nextCache concreteCache hcontext _hvisible _hpublished hcomputed + cases input with + | inl query => + cases query with + | inl n => exact le_rfl + | inr input => + change canonicalJointHashCharge parameter input nextContext remaining nextCache ≤ + otsOpeningRefinedQueryReserve + (⟨parameter, root, fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey) concreteCache input + exact (canonicalJointHashCharge_le_canonicalOtsHashCharge parameter input nextContext remaining nextCache).trans + (canonicalOtsHashCharge_le_refinedReserve + (secretKey := ⟨parameter, root, fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩) hcontext hcomputed rfl input) + | inr message => exact le_rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalPending.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalPending.lean new file mode 100644 index 00000000..b6698673 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalPending.lean @@ -0,0 +1,432 @@ +import SphincsSecurity.Proof.OtsProbePrehitOpeningProjection + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +set_option maxRecDepth 100000 in +theorem pendingCoveredBy_of_mem_runResolvedFromTable + (candidates : List Probe) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hcovered : PendingCoveredBy candidates context) + (hbound : computation.IsQueryBoundP (IsUncoveredProbe candidates) 0) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table computation)) : + PendingCoveredBy candidates result.context := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runResolvedFromTable] at hresult + subst result + exact hcovered + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases input with + | uniform n => + rw [runResolvedFromTable_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel hcovered (hbound.2 output) htail + | hashOutput => + rw [runResolvedFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel hcovered (hbound.2 output) htail + | ensure coordinate => + rw [runResolvedFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel hcovered + (hbound.2 ()) hresult + | probe coordinate digest => + have hmem : (⟨coordinate, digest⟩ : Probe) ∈ candidates := by + simpa [IsUncoveredProbe] using hbound.1 + have htail : (next ()).IsQueryBoundP (IsUncoveredProbe candidates) 0 := by + simpa [IsUncoveredProbe] using hbound.2 () + cases fuel with + | zero => simp [runResolvedFromTable_probe_query_bind] at hresult + | succ remaining => + rw [runResolvedFromTable_probe_query_bind] at hresult + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] at hresult + exact ih () context remaining hcovered htail hresult + · simp only [hrevealed, ↓reduceIte] at hresult + exact ih () { context with state := context.state.addPending coordinate digest } + remaining (hcovered.addPending_of_mem ⟨coordinate, digest⟩ hmem) htail hresult + | peek coordinate => + rw [runResolvedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hcovered (hbound.2 _) hresult + | publish coordinate => + rw [runResolvedFromTable_publish_query_bind] at hresult + exact ih () { context with state := context.state.publish coordinate } fuel hcovered + (hbound.2 ()) hresult + | reveal coordinate => + rw [runResolvedFromTable_reveal_query_bind] at hresult + cases coordinate <;> rw [mem_support_bind_iff] at hresult + all_goals + obtain ⟨option, _hresolve, htail⟩ := hresult + cases option with + | none => simp at htail + | some resolved => + apply ih resolved.output _ fuel _ (hbound.2 resolved.output) htail + exact hcovered.of_subset (Finset.filter_subset _ _) + +theorem runResolvedFromTable_peekCoordinate + (coordinate : Coordinate) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runResolvedFromTable context fuel table ((peekCoordinate coordinate).run cache) = + pure (some ⟨context, fuel, ((context.state.values coordinate).map truncateHash, cache), table⟩) := by + change runResolvedFromTable context fuel table + (LazyRevealProbe.peekQuery coordinate >>= fun result => pure (result.map truncateHash, cache)) = _ + rw [LazyRevealProbe.peekQuery, runResolvedFromTable_peek_query_bind] + rfl + +theorem runResolved_planFirstMissingInputCoordinate + (state : LazyRevealProbe.State Coordinate) (input : HashInput) : + ∀ slot coordinates context fuel table cache, + context.state = state → + runResolvedFromTable context fuel table + ((planFirstMissingInputCoordinate input slot coordinates).run cache) = + pure (some ⟨context, fuel, + (firstMissingInputCoordinatePlan state input slot coordinates, cache), table⟩) := by + intro slot coordinates + induction coordinates generalizing slot with + | nil => + intro context fuel table cache hstate + simp [planFirstMissingInputCoordinate, firstMissingInputCoordinatePlan, + runResolvedFromTable] + | cons coordinate remaining ih => + intro context fuel table cache hstate + rw [planFirstMissingInputCoordinate, StateT.run_bind, + runResolvedFromTable_bind, + runResolvedFromTable_peekCoordinate] + simp only [pure_bind] + rw [hstate] + cases hvalue : state.values coordinate with + | none => + simp [hvalue, firstMissingInputCoordinatePlan, + runResolvedFromTable] + | some output => + change runResolvedFromTable context fuel table + ((planFirstMissingInputCoordinate input (slot + 1) remaining).run cache) = _ + rw [ih (slot + 1) context fuel table cache hstate] + simp [firstMissingInputCoordinatePlan, hvalue] + +theorem runResolved_planLeafInputProbe + (state : LazyRevealProbe.State Coordinate) + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hstate : context.state = state) : + runResolvedFromTable context fuel table + ((planLeafInputProbe input candidate lay tree leafIdx).run cache) = + pure (some ⟨context, fuel, + (leafInputProbePlan state input candidate lay tree leafIdx, cache), table⟩) := by + rw [planLeafInputProbe, StateT.run_bind, + runResolvedFromTable_bind, + runResolvedFromTable_peekCoordinate] + simp only [pure_bind] + rw [hstate] + cases hvalue : state.values candidate.coordinate with + | none => + simp [hvalue, leafInputProbePlan, runResolvedFromTable] + | some output => + change runResolvedFromTable context fuel table + ((planFirstMissingInputCoordinate input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position)).run cache) = _ + rw [runResolved_planFirstMissingInputCoordinate state input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + context fuel table cache hstate] + simp [leafInputProbePlan, hvalue] + +theorem runResolved_planProbingHashQuery + (parameter : PublicParameter) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hstate : context.state = state) : + runResolvedFromTable context fuel table + ((planProbingHashQuery parameter input).run cache) = + pure (some ⟨context, fuel, + (purePlanProbingHashQuery parameter input state, cache), table⟩) := by + unfold planProbingHashQuery purePlanProbingHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases hposition : decodePosition? parameter input with + | none => simp [runResolvedFromTable] + | some position => + cases position with + | leaf lay tree leafIdx => + rw [StateT.run_bind, + runResolvedFromTable_bind, + runResolved_planLeafInputProbe state input candidate lay tree + leafIdx context fuel table cache hstate] + simp [runResolvedFromTable] + | chain | node | ftsLeaf | ftsNode | ftsRoots => + simp [runResolvedFromTable] + | none => + cases hposition : decodePosition? parameter input with + | none => simp [runResolvedFromTable] + | some position => + cases position with + | node lay tree level nodeIdx => + rw [StateT.run_bind, + runResolvedFromTable_bind, + runResolved_planFirstMissingInputCoordinate state input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position) + context fuel table cache hstate] + simp [runResolvedFromTable] + | chain | leaf | ftsLeaf | ftsNode | ftsRoots => + simp [runResolvedFromTable] + +theorem runResolved_probingHashQuery_eq_afterPlan + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runResolvedFromTable context fuel table ((probingHashQuery parameter input).run cache) = + runResolvedFromTable context fuel table ((probingHashQueryAfterPlan parameter input + (purePlanProbingHashQuery parameter input context.state)).run cache) := by + rw [probingHashQuery_eq_plan_then_afterPlan, StateT.run_bind, runResolvedFromTable_bind, + runResolved_planProbingHashQuery parameter input context.state context fuel table cache rfl] + simp only [pure_bind] + +noncomputable def canonicalQueryCandidates (parameter : PublicParameter) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) : List Probe := + match input with + | .inl (.inr input) => (purePlanProbingHashQuery parameter input context.state).candidate?.toList + | _ => [] + +theorem pendingCoveredBy_of_mem_canonicalChronologicalQuery + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) (prior : List Probe) + (result : ResolvedRunResult ((OracleWorld + SigningSpec).Range input × SplitHashCache)) + (hcovered : PendingCoveredBy prior context) + (hresult : some result ∈ support + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache)) : + PendingCoveredBy (prior ++ canonicalQueryCandidates parameter input context) result.context := by + rw [canonicalChronologicalAdversaryImpl_eq_raw_then_canonicalize, mem_support_bind_iff] at hresult + obtain ⟨rawOption, hraw, hcanonical⟩ := hresult + cases rawOption with + | none => simp [canonicalizeResolvedRun] at hcanonical + | some raw => + simp only [canonicalizeResolvedRun, mem_support_pure_iff, Option.some.injEq] at hcanonical + subst result + change PendingCoveredBy (prior ++ canonicalQueryCandidates parameter input context) raw.context + have hprior : PendingCoveredBy (prior ++ canonicalQueryCandidates parameter input context) context := + hcovered.mono_candidates (List.sublist_append_left _ _) + cases input with + | inl query => + cases query with + | inl n => + exact pendingCoveredBy_of_mem_runResolvedFromTable _ _ context fuel table raw hprior + (OracleComp.IsQueryBoundP.of_imp (isUncoveredProbe_imp_isProbe _) + (splitUniformImpl_probeFree n cache)) hraw + | inr input => + change some raw ∈ support (runResolvedFromTable context fuel table + ((probingHashQuery parameter input).run cache)) at hraw + rw [runResolved_probingHashQuery_eq_afterPlan] at hraw + apply pendingCoveredBy_of_mem_runResolvedFromTable _ _ context fuel table raw hprior _ hraw + apply probingHashQueryAfterPlan_probeBound + intro candidate hcandidate + apply List.mem_append_right + simp [canonicalQueryCandidates, hcandidate] + | inr message => + exact pendingCoveredBy_of_mem_runResolvedFromTable _ _ context fuel table raw hprior + (OracleComp.IsQueryBoundP.of_imp (isUncoveredProbe_imp_isProbe _) + (maskedPublishedChronologicalSign_probeFree parameter root ftsSecret message cache)) hraw + +noncomputable def canonicalTraceCandidates (parameter : PublicParameter) (history : List CanonicalQuerySelection) : List Probe := + history.flatMap fun entry => canonicalQueryCandidates parameter entry.input entry.context + +set_option maxRecDepth 100000 in +theorem pendingCoveredBy_of_mem_canonicalQueryTrace + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (prior : List Probe) (hcovered : PendingCoveredBy prior context) + (result : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) + (hrun : result ∈ support (runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache)) : + (∀ ordinal entry, result.2[ordinal]? = some entry → + PendingCoveredBy (prior ++ canonicalTraceCandidates parameter (result.2.take ordinal)) entry.context) ∧ + (∀ terminal, result.1 = some terminal → + PendingCoveredBy (prior ++ canonicalTraceCandidates parameter result.2) terminal.context) := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache prior result with + | pure value => + simp only [runCanonicalQueryTrace, OracleComp.construct_pure] at hrun + split_ifs at hrun <;> simp only [mem_support_pure_iff] at hrun <;> subst result + · constructor + · intro ordinal entry hentry + simp at hentry + · intro terminal hterminal + simp only [Option.some.injEq] at hterminal + subst terminal + simpa [canonicalTraceCandidates] using hcovered + · simp + | query_bind input next ih => + rw [runCanonicalQueryTrace_query_bind] at hrun + split_ifs at hrun with hcomplete + · rw [mem_support_bind_iff] at hrun + obtain ⟨stepOption, hstep, hrun⟩ := hrun + cases stepOption with + | none => + simp only [pure_bind, mem_support_pure_iff] at hrun + subst result + constructor + · intro ordinal entry hentry + cases ordinal with + | zero => + simp only [List.getElem?_cons_zero, Option.some.injEq] at hentry + subst entry + simpa [canonicalTraceCandidates] using hcovered + | succ ordinal => simp at hentry + · simp + | some step => + rw [mem_support_bind_iff] at hrun + obtain ⟨tail, htail, hpure⟩ := hrun + simp only [mem_support_pure_iff] at hpure + subst result + have hstepCovered := pendingCoveredBy_of_mem_canonicalChronologicalQuery parameter root ftsSecret + input context fuel table cache prior step hcovered hstep + have htailCovered := ih step.value.1 step.context step.remaining step.table step.value.2 + (prior ++ canonicalQueryCandidates parameter input context) hstepCovered tail htail + constructor + · intro ordinal entry hentry + cases ordinal with + | zero => + simp only [List.getElem?_cons_zero, Option.some.injEq] at hentry + subst entry + simpa [canonicalTraceCandidates] using hcovered + | succ ordinal => + simp only [List.getElem?_cons_succ] at hentry + simpa [canonicalTraceCandidates, List.append_assoc] using htailCovered.1 ordinal entry hentry + · intro terminal hterminal + simpa [canonicalTraceCandidates, List.append_assoc] using htailCovered.2 terminal hterminal + · simp only [mem_support_pure_iff] at hrun + subst result + simp + +theorem pendingCoveredBy_of_mem_canonicalRetainedQueryTrace + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (result : Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)) × List CanonicalQuerySelection) + (hrun : result ∈ support (canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel)) : + ∀ ordinal entry, result.2[ordinal]? = some entry → + PendingCoveredBy (canonicalTraceCandidates parameter (result.2.take ordinal)) entry.context := by + rw [canonicalRetainedQueryTrace, mem_support_bind_iff] at hrun + obtain ⟨rootOption, hroot, hrun⟩ := hrun + cases rootOption with + | none => + simp only [mem_support_pure_iff] at hrun + subst result + simp + | some root => + rw [mem_support_bind_iff] at hrun + obtain ⟨rest, hrest, hpure⟩ := hrun + simp only [mem_support_pure_iff] at hpure + subst result + have hcovered := pendingCoveredBy_of_mem_runResolvedFromTable [] _ _ fuel table root pendingCoveredBy_empty + (OracleComp.IsQueryBoundP.of_imp (isUncoveredProbe_imp_isProbe []) + (maskedPublishedTreeRoot_probeFree emptySplitHashCache)) hroot + have htrace := pendingCoveredBy_of_mem_canonicalQueryTrace parameter root.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨root.value.1, parameter⟩) root.context root.remaining root.table + root.value.2 [] hcovered rest hrest + simpa only [List.nil_append] using htrace.1 + +theorem canonicalQueryCandidates_length_le_hashCount + (parameter : PublicParameter) (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) : + (canonicalQueryCandidates parameter input context).length ≤ outerHashQueryCount input := by + cases input with + | inl query => + cases query with + | inl n => exact le_rfl + | inr input => + unfold canonicalQueryCandidates outerHashQueryCount + cases (purePlanProbingHashQuery parameter input context.state).candidate? <;> simp + | inr message => exact le_rfl + +theorem canonicalTraceCandidates_length_le_hashCount + (parameter : PublicParameter) (history : List CanonicalQuerySelection) : + (canonicalTraceCandidates parameter history).length ≤ canonicalTraceHashCount history := by + induction history with + | nil => exact le_rfl + | cons head tail ih => + simpa only [canonicalTraceCandidates, List.flatMap_cons, List.length_append, + canonicalTraceHashCount, List.map_cons, List.sum_cons] using + Nat.add_le_add (canonicalQueryCandidates_length_le_hashCount parameter head.input head.context) ih + +theorem PendingCoveredBy.card_le + {candidates : List Probe} {context : DeferredContext} + (hcovered : PendingCoveredBy candidates context) : + context.state.pending.card ≤ candidates.length := by + classical + have hsubset : context.state.pending ⊆ + (candidates.map fun candidate => (candidate.coordinate, candidate.candidate)).toFinset := by + intro entry hentry + obtain ⟨candidate, hcandidate, hcoordinate, hdigest⟩ := hcovered entry hentry + simp only [List.mem_toFinset, List.mem_map] + exact ⟨candidate, hcandidate, Prod.ext hcoordinate hdigest⟩ + exact (Finset.card_le_card hsubset).trans + (by simpa only [List.length_map] using (List.toFinset_card_le + (candidates.map fun candidate => (candidate.coordinate, candidate.candidate)))) + +theorem canonicalTraceHashCount_take_le + (history : List CanonicalQuerySelection) (ordinal : Nat) : + canonicalTraceHashCount (history.take ordinal) ≤ canonicalTraceHashCount history := by + exact ((List.take_sublist _ _).map _).sum_le_sum (fun _ _ => Nat.zero_le _) + +theorem pending_card_le_of_coupled_canonicalRetainedTrace + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) (fuel : Nat) + (left : Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)) × List CanonicalQuerySelection) + (right : (RetainedGameResult × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hleft : left ∈ support (canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel)) + (hright : right ∈ support (prehitRetainedQueryTrace adversary parameter table ftsSecret)) + (hrelation : CanonicalQueryTraceRel parameter table left right) : + ∀ (ordinal : Nat) (entry : CanonicalQuerySelection), + left.2[ordinal]? = some entry → entry.context.state.pending.card ≤ q := by + intro ordinal entry hentry + have hcovered := pendingCoveredBy_of_mem_canonicalRetainedQueryTrace + adversary parameter table ftsSecret fuel left hleft ordinal entry hentry + exact hcovered.card_le.trans ((canonicalTraceCandidates_length_le_hashCount parameter _).trans + ((canonicalTraceHashCount_take_le _ _).trans (hrelation.hashCount_le.trans + (prehitRetainedTraceHashCount_le adversary q hq parameter hparameter table ftsSecret hfts right hright)))) + +theorem candidate_source_of_mem_canonicalTraceCandidates_take + (parameter : PublicParameter) (history : List CanonicalQuerySelection) (ordinal : Nat) + (candidate : Probe) (hcandidate : candidate ∈ canonicalTraceCandidates parameter (history.take ordinal)) : + ∃ earlier < ordinal, ∃ source, history[earlier]? = some source ∧ + candidate ∈ canonicalQueryCandidates parameter source.input source.context := by + simp only [canonicalTraceCandidates, List.mem_flatMap] at hcandidate + obtain ⟨source, hsource, hcandidate⟩ := hcandidate + obtain ⟨earlier, hearlier⟩ := List.mem_iff_getElem?.mp hsource + have hlt : earlier < ordinal := by + obtain ⟨hindex, _heq⟩ := List.getElem?_eq_some_iff.mp hearlier + have hlength := List.length_take_le ordinal history + omega + refine ⟨earlier, hlt, source, ?_, hcandidate⟩ + simpa only [List.getElem?_take, hlt, ↓reduceIte] using hearlier + +theorem pending_candidate_source_of_canonicalRetainedTrace + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (result : Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)) × List CanonicalQuerySelection) + (hrun : result ∈ support (canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel)) + (ordinal : Nat) (entry : CanonicalQuerySelection) (hentry : result.2[ordinal]? = some entry) + (coordinate : Coordinate) (digest : Digest) + (hpending : (coordinate, digest) ∈ entry.context.state.pending) : + ∃ earlier < ordinal, ∃ source candidate, + result.2[earlier]? = some source ∧ + candidate ∈ canonicalQueryCandidates parameter source.input source.context ∧ + candidate.coordinate = coordinate ∧ candidate.candidate = digest := by + have hcovered := pendingCoveredBy_of_mem_canonicalRetainedQueryTrace + adversary parameter table ftsSecret fuel result hrun ordinal entry hentry + obtain ⟨candidate, hcandidate, hcoordinate, hdigest⟩ := hcovered (coordinate, digest) hpending + obtain ⟨earlier, hlt, source, hsource, hcandidate⟩ := + candidate_source_of_mem_canonicalTraceCandidates_take parameter result.2 ordinal candidate hcandidate + exact ⟨earlier, hlt, source, candidate, hsource, hcandidate, hcoordinate, hdigest⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalPendingHit.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalPendingHit.lean new file mode 100644 index 00000000..a4bc5db6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalPendingHit.lean @@ -0,0 +1,196 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalPending + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +def PendingResolvedHit (table : OtsSecretIndex → HashOutput) (context : DeferredContext) : Prop := + ∃ coordinate output, resolvedCompletionValue table context coordinate = some output ∧ + context.state.hitAt coordinate output + +theorem DeferredCompletable.not_pendingResolvedHit + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hcompletable : DeferredCompletable table context) : ¬PendingResolvedHit table context := by + obtain ⟨completion, hcompletion⟩ := hcompletable + rintro ⟨coordinate, output, hvalue, hhit⟩ + have heq := hcompletion.eq_resolvedCompletionValue coordinate output hvalue + have hpending : (coordinate, truncateHash output) ∈ context.state.pending := by + rwa [← LazyRevealProbe.State.mem_pendingAt_iff] + exact hcompletion.2.2.1 coordinate (truncateHash output) hpending (by rw [heq]) + +theorem deferredCompletable_iff_no_pendingResolvedHit + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcard : context.state.pending.card < Fintype.card Digest) : + DeferredCompletable table context ↔ ¬PendingResolvedHit table context := by + constructor + · exact DeferredCompletable.not_pendingResolvedHit + · intro hclean + have hvalid : context.Valid := by + refine ⟨hconsistent, ?_⟩ + intro coordinate output hvalue hhit + apply hclean + refine ⟨coordinate, output, ?_, hhit⟩ + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + have heq := hstarts ⟨lay, tree, leafIdx, chainIdx⟩ output hvalue + simp [resolvedCompletionValue, heq] + | position position => simp [resolvedCompletionValue, DeferredContext.positionValue, hvalue] + apply deferredCompletable_of_valid_of_no_boundary_hit table context hvalid hstarts + (hcard := hcard) + · rintro ⟨position, output, hhidden, hvalue, hhit⟩ + exact hclean ⟨.position position, output, + by simp [resolvedCompletionValue, DeferredContext.positionValue, hhidden, hvalue], hhit⟩ + · rintro ⟨index, _hhidden, hhit⟩ + exact hclean ⟨index.coordinate, table index, rfl, hhit⟩ + +theorem PendingCoveredBy.resolved_hit_candidate + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} {candidates : List Probe} + (hcovered : PendingCoveredBy candidates context) (hhit : PendingResolvedHit table context) : + ∃ candidate ∈ candidates, ∃ output, + resolvedCompletionValue table context candidate.coordinate = some output ∧ + truncateHash output = candidate.candidate := by + obtain ⟨coordinate, output, hvalue, hhit⟩ := hhit + have hpending : (coordinate, truncateHash output) ∈ context.state.pending := by + rwa [← LazyRevealProbe.State.mem_pendingAt_iff] + obtain ⟨candidate, hcandidate, hcoordinate, hdigest⟩ := hcovered _ hpending + exact ⟨candidate, hcandidate, output, hcoordinate ▸ hvalue, hdigest.symm⟩ + +theorem canonicalQuery_completable_iff_no_pendingResolvedHit + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) + (fuel : Nat) (cache : SplitHashCache) (prior : List Probe) + (result : ResolvedRunResult ((OracleWorld + SigningSpec).Range input × SplitHashCache)) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcovered : PendingCoveredBy prior context) + (hcard : prior.length + outerHashQueryCount input < Fintype.card Digest) + (hrun : some result ∈ support + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache)) : + DeferredCompletable result.table result.context ↔ ¬PendingResolvedHit table result.context := by + have hnextCovered := pendingCoveredBy_of_mem_canonicalChronologicalQuery + parameter root ftsSecret input context fuel table cache prior result hcovered hrun + have hnextCard : result.context.state.pending.card < Fintype.card Digest := by + have hcandidates := canonicalQueryCandidates_length_le_hashCount parameter input context + have hbound := hnextCovered.card_le + simp only [List.length_append] at hbound + omega + have hcore := resolvedCore_of_mem_canonicalChronologicalAdversaryImpl + parameter root table ftsSecret input context fuel cache result hconsistent hstarts hrun + rw [hcore.1] + exact deferredCompletable_iff_no_pendingResolvedHit table result.context hcore.2.1 hcore.2.2 hnextCard + +theorem resolved_hit_candidate_of_canonicalQuery_not_completable + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) + (fuel : Nat) (cache : SplitHashCache) (prior : List Probe) + (result : ResolvedRunResult ((OracleWorld + SigningSpec).Range input × SplitHashCache)) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcovered : PendingCoveredBy prior context) + (hcard : prior.length + outerHashQueryCount input < Fintype.card Digest) + (hrun : some result ∈ support + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache)) + (hstop : ¬DeferredCompletable table result.context) : + ∃ candidate ∈ prior ++ canonicalQueryCandidates parameter input context, ∃ output, + resolvedCompletionValue table result.context candidate.coordinate = some output ∧ + truncateHash output = candidate.candidate := by + have hnextCovered := pendingCoveredBy_of_mem_canonicalChronologicalQuery + parameter root ftsSecret input context fuel table cache prior result hcovered hrun + have hcore := resolvedCore_of_mem_canonicalChronologicalAdversaryImpl + parameter root table ftsSecret input context fuel cache result hconsistent hstarts hrun + apply hnextCovered.resolved_hit_candidate + have hiff := canonicalQuery_completable_iff_no_pendingResolvedHit parameter root table ftsSecret + input context fuel cache prior result hconsistent hstarts hcovered hcard hrun + rw [hcore.1] at hiff + exact Classical.not_not.mp fun hclean => hstop (hiff.mpr hclean) + +def ReturnedPendingResolvedHit (table : OtsSecretIndex → HashOutput) + (result : Option (ResolvedRunResult α)) : Prop := + match result with + | none => False + | some result => PendingResolvedHit table result.context + +theorem probEvent_canonicalQuery_rejected_eq_none_add_pendingHit + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) + (fuel : Nat) (cache : SplitHashCache) (prior : List Probe) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcovered : PendingCoveredBy prior context) + (hcard : prior.length + outerHashQueryCount input < Fintype.card Digest) : + let queryRun := canonicalChronologicalAdversaryImpl parameter root table ftsSecret + input context fuel table cache + Pr[ResolvedQueryRejected | queryRun] = Pr[fun result => result = none | queryRun] + + Pr[ReturnedPendingResolvedHit table | queryRun] := by + classical + dsimp only + simp only [probEvent_eq_tsum_ite, ← ENNReal.tsum_add] + apply tsum_congr + intro option + by_cases hsupported : option ∈ support + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache) + · cases option with + | none => simp [ResolvedQueryRejected, ReturnedPendingResolvedHit] + | some result => + have hiff := canonicalQuery_completable_iff_no_pendingResolvedHit parameter root table ftsSecret + input context fuel cache prior result hconsistent hstarts hcovered hcard hsupported + simp [ResolvedQueryRejected, ReturnedPendingResolvedHit, hiff] + · have hzero := probOutput_eq_zero_of_not_mem_support hsupported + simp [hzero] + +set_option maxHeartbeats 800000 in +theorem canonicalQuery_not_completable_has_query_source + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) (fuel : Nat) + (left : Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)) × List CanonicalQuerySelection) + (right : (RetainedGameResult × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hleft : left ∈ support (canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel)) + (hright : right ∈ support (prehitRetainedQueryTrace adversary parameter table ftsSecret)) + (hrelation : CanonicalQueryTraceRel parameter table left right) + (ordinal : Nat) (entry : CanonicalQuerySelection) (hentry : left.2[ordinal]? = some entry) + (root : Digest) + (result : ResolvedRunResult ((OracleWorld + SigningSpec).Range entry.input × SplitHashCache)) + (hrun : some result ∈ support + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret + entry.input entry.context entry.fuel table entry.cache)) + (hstop : ¬DeferredCompletable table result.context) : + ∃ earlier ≤ ordinal, ∃ source candidate output, + left.2[earlier]? = some source ∧ + candidate ∈ canonicalQueryCandidates parameter source.input source.context ∧ + resolvedCompletionValue table result.context candidate.coordinate = some output ∧ + truncateHash output = candidate.candidate := by + obtain ⟨hindex, hvalue⟩ := List.getElem?_eq_some_iff.mp hentry + have hselected := hrelation.selection_at ⟨ordinal, hindex⟩ + simp only [List.get_eq_getElem, hvalue] at hselected + have hinvariant := hselected.2.2.1 + have hcovered := pendingCoveredBy_of_mem_canonicalRetainedQueryTrace + adversary parameter table ftsSecret fuel left hleft ordinal entry hentry + have hbudget := (canonicalTraceCandidates_length_le_hashCount parameter (left.2.take ordinal)).trans + ((canonicalTraceHashCount_take_le _ _).trans (hrelation.hashCount_le.trans + (prehitRetainedTraceHashCount_le adversary q hq parameter hparameter table ftsSecret hfts right hright))) + have hcount : outerHashQueryCount entry.input ≤ 1 := by + cases entry.input with + | inl query => cases query <;> simp [outerHashQueryCount] + | inr message => exact Nat.zero_le 1 + have hcard : (canonicalTraceCandidates parameter (left.2.take ordinal)).length + + outerHashQueryCount entry.input < Fintype.card Digest := by + have hspace : 2 ^ 126 + 1 < Fintype.card Digest := by norm_num [digestBits] + omega + obtain ⟨candidate, hcandidate, output, houtput, hdigest⟩ := + resolved_hit_candidate_of_canonicalQuery_not_completable parameter root table ftsSecret + entry.input entry.context entry.fuel entry.cache _ result + hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hcovered hcard hrun hstop + rcases List.mem_append.mp hcandidate with hprior | hcurrent + · obtain ⟨earlier, hlt, source, hsource, hcandidate⟩ := + candidate_source_of_mem_canonicalTraceCandidates_take parameter left.2 ordinal candidate hprior + exact ⟨earlier, hlt.le, source, candidate, output, hsource, hcandidate, houtput, hdigest⟩ + · exact ⟨ordinal, le_rfl, entry, candidate, output, hentry, hcurrent, houtput, hdigest⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalPrivateEndpoint.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalPrivateEndpoint.lean new file mode 100644 index 00000000..9a0328ac --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalPrivateEndpoint.lean @@ -0,0 +1,237 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceAssembly +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryFinalAssembly +import SphincsSecurity.Proof.OtsProbeGroupedTerminal + +/-! +# Canonical private-witness endpoint + +The canonical source bound is proved on a snapshot-rich output. This file erases those snapshots +and packages the same eight-unit estimate on the witness-plan output used by the boundary bridge. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +noncomputable def sampledGranularAllCanonicalPrivateWitnessPlan + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp PrivateWitnessPlanOutput := do + let table ← sampleOtsHashTable + granularAllCanonicalPrivateWitnessPlan adversary parameter table ftsSecret fuel + +set_option maxRecDepth 100000 in +theorem map_erase_sampledGranularAllCanonicalPrivateWitnessSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + erasePrivateWitnessSnapshotOutput <$> + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret fuel = + sampledGranularAllCanonicalPrivateWitnessPlan adversary parameter ftsSecret fuel := by + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot + sampledGranularAllCanonicalPrivateWitnessPlan + rw [map_bind] + apply bind_congr + intro table + exact map_erase_granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret fuel + +set_option maxRecDepth 100000 in +theorem probEvent_sampledCanonical_privateWitnessPlan_eq_snapshot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun output => output.1.isSome = true | + sampledGranularAllCanonicalPrivateWitnessPlan adversary parameter ftsSecret fuel] = + Pr[fun output => output.1.isSome = true | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret fuel] := by + calc + _ = Pr[fun output => output.1.isSome = true | + erasePrivateWitnessSnapshotOutput <$> + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret + fuel] := by + rw [map_erase_sampledGranularAllCanonicalPrivateWitnessSnapshot] + _ = _ := by + rw [probEvent_map] + rfl + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_sampledCanonical_privateWitnessPlan_le_eight_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[fun output => output.1.isSome = true | + sampledGranularAllCanonicalPrivateWitnessPlan adversary parameter ftsSecret q] ≤ + ((8 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + rw [probEvent_sampledCanonical_privateWitnessPlan_eq_snapshot] + exact probEvent_sampledCanonical_privateWitness_le_eight_mul adversary parameter ftsSecret q + hexpanded hq + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_sampledActualRetained_verifyProbe_le_ten_mul_of_canonical_boundary + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hqMax : q ≤ 2 ^ securityBits) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hboundaryBridge : + Pr[fun outcome => outcome.failed = true | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret q] ≤ + ((2 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + Pr[fun output => output.1.isSome = true | + sampledGranularAllCanonicalPrivateWitnessPlan adversary parameter ftsSecret q]) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + ((10 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ Pr[fun outcome => outcome.failed = true | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret q] := + probEvent_sampledActualRetainedOtsHashTable_verifyProbe_le_boundary_failed adversary + parameter ftsSecret q + _ ≤ ((2 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + Pr[fun output => output.1.isSome = true | + sampledGranularAllCanonicalPrivateWitnessPlan adversary parameter ftsSecret q] := + hboundaryBridge + _ ≤ ((2 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + ((8 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + exact add_le_add (le_refl _) + (probEvent_sampledCanonical_privateWitnessPlan_le_eight_mul adversary parameter + ftsSecret q hexpanded hqMax) + _ = _ := by + push_cast + ring + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_sampledActualRetained_verifyProbe_le_ten_mul_of_canonical + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hqMax : q ≤ 2 ^ securityBits) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hprivateBridge : + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q] ≤ + Pr[fun output => output.1.isSome = true | + sampledGranularAllCanonicalPrivateWitnessPlan adversary parameter ftsSecret q]) + (hdomination : + Pr[fun outcome => outcome.failed = true | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret q] ≤ + Pr[= true | + sampledFlatDetailedOrdinaryRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledMaterializedGuardedSafeOrdinaryRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledMaterializedCanonicalPrivateRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q]) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + ((10 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ Pr[fun outcome => outcome.failed = true | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret q] := + probEvent_sampledActualRetainedOtsHashTable_verifyProbe_le_boundary_failed adversary + parameter ftsSecret q + _ ≤ Pr[= true | + sampledFlatDetailedOrdinaryRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledMaterializedGuardedSafeOrdinaryRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledMaterializedCanonicalPrivateRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q] := hdomination + _ ≤ ((2 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + 0 + + ((8 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + exact add_le_add + (add_le_add + (probEvent_sampledFlat_add_materializedGuardedOrdinaryRetained_le_two_mul + adversary parameter ftsSecret q) + (probEvent_sampledMaterializedCanonicalPrivateRetained_le_zero adversary parameter + ftsSecret q)) + (hprivateBridge.trans + (probEvent_sampledCanonical_privateWitnessPlan_le_eight_mul adversary parameter + ftsSecret q hexpanded hqMax)) + _ = _ := by + push_cast + ring + +theorem security_of_canonical_private_bridge_and_boundary_domination + (hprivateBridge : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ securityBits → + ∀ parameter ∈ support sampleParameter, + ∀ ftsSecret ∈ support sampleFtsSecrets, + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q] ≤ + Pr[fun output => output.1.isSome = true | + sampledGranularAllCanonicalPrivateWitnessPlan adversary parameter ftsSecret q]) + (hdomination : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ securityBits → + ∀ parameter ∈ support sampleParameter, + ∀ ftsSecret ∈ support sampleFtsSecrets, + Pr[fun outcome => outcome.failed = true | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret q] ≤ + Pr[= true | + sampledFlatDetailedOrdinaryRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledMaterializedGuardedSafeOrdinaryRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledMaterializedCanonicalPrivateRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q]) : + SphincsSecurityStatement := by + apply security_of_sampledWinningRetainedVerifyProbe_grouped_le_mul 10 (by omega) + intro q hqPos adversary hq hqMax parameter hparameter ftsSecret hfts + exact probEvent_sampledActualRetained_verifyProbe_le_ten_mul_of_canonical adversary parameter + ftsSecret q hqMax + (fun table root => + isQueryBoundP_expandedRetained_all_tables_roots adversary q hq parameter hparameter + table ftsSecret hfts root) + (hprivateBridge q hqPos adversary hq hqMax parameter hparameter ftsSecret hfts) + (hdomination q hqPos adversary hq hqMax parameter hparameter ftsSecret hfts) + +theorem security_of_canonical_boundary_bridge + (hboundaryBridge : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ securityBits → + ∀ parameter ∈ support sampleParameter, + ∀ ftsSecret ∈ support sampleFtsSecrets, + Pr[fun outcome => outcome.failed = true | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret q] ≤ + ((2 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + Pr[fun output => output.1.isSome = true | + sampledGranularAllCanonicalPrivateWitnessPlan adversary parameter ftsSecret q]) : + SphincsSecurityStatement := by + apply security_of_sampledWinningRetainedVerifyProbe_grouped_le_mul 10 (by omega) + intro q hqPos adversary hq hqMax parameter hparameter ftsSecret hfts + exact probEvent_sampledActualRetained_verifyProbe_le_ten_mul_of_canonical_boundary + adversary parameter ftsSecret q hqMax + (fun table root => + isQueryBoundP_expandedRetained_all_tables_roots adversary q hq parameter hparameter + table ftsSecret hfts root) + (hboundaryBridge q hqPos adversary hq hqMax parameter hparameter ftsSecret hfts) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalQuerySelection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalQuerySelection.lean new file mode 100644 index 00000000..978b5cc4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalQuerySelection.lean @@ -0,0 +1,103 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalChargeSampled + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +structure CanonicalQuerySelection where + input : (OracleWorld + SigningSpec).Domain + context : DeferredContext + fuel : Nat + table : OtsSecretIndex → HashOutput + cache : SplitHashCache + +/-- Select before executing a query. Ordinals count outer hashing, uniform sampling and signing requests. -/ +noncomputable def canonicalQuerySelection + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + Nat → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp (Option CanonicalQuerySelection) := + OracleComp.construct (fun _ _ _ _ _ _ => pure none) + (fun input _ next ordinal context fuel table cache => + if DeferredCompletable table context then + match ordinal with + | 0 => pure (some ⟨input, context, fuel, table, cache⟩) + | ordinal + 1 => do + let result ← canonicalChronologicalAdversaryImpl parameter root table ftsSecret + input context fuel table cache + match result with + | none => pure none + | some result => next result.value.1 ordinal result.context result.remaining result.table result.value.2 + else pure none) computation + +noncomputable def CanonicalQuerySelection.charge + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ℝ≥0∞) : + Option CanonicalQuerySelection → ℝ≥0∞ + | none => 0 + | some selection => charge selection.input selection.context selection.fuel selection.cache + +theorem canonicalQuerySelection_pure + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (value : α) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + canonicalQuerySelection parameter root ftsSecret (pure value) ordinal context fuel table cache = pure none := rfl + +theorem canonicalQuerySelection_query_bind + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + canonicalQuerySelection parameter root ftsSecret (OracleSpec.query input >>= next) ordinal context fuel table cache = + if DeferredCompletable table context then + match ordinal with + | 0 => pure (some ⟨input, context, fuel, table, cache⟩) + | ordinal + 1 => do + let result ← canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache + match result with + | none => pure none + | some result => + canonicalQuerySelection parameter root ftsSecret (next result.value.1) + ordinal result.context result.remaining result.table result.value.2 + else pure none := rfl + +set_option maxRecDepth 100000 in +theorem tsum_canonicalQuerySelection_charge + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ℝ≥0∞) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + (∑' ordinal, ∑' selection, + Pr[= selection | canonicalQuerySelection parameter root ftsSecret computation ordinal context fuel table cache] * + CanonicalQuerySelection.charge charge selection) = + expectedCanonicalQueryCharge parameter root ftsSecret charge computation context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => + simp only [canonicalQuerySelection_pure, tsum_probOutput_pure_mul, CanonicalQuerySelection.charge, tsum_zero] + rfl + | query_bind input next ih => + rw [expectedCanonicalQueryCharge_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete, tsum_eq_zero_add' ENNReal.summable] + simp only [canonicalQuerySelection_query_bind, hcomplete, ↓reduceIte, + tsum_probOutput_pure_mul, CanonicalQuerySelection.charge] + congr 1 + simp only [tsum_probOutput_bind_mul] + rw [ENNReal.tsum_comm] + apply tsum_congr + intro result + rw [ENNReal.tsum_mul_left] + congr 1 + cases result with + | none => simp only [tsum_probOutput_pure_mul, tsum_zero] + | some result => exact ih result.value.1 result.context result.remaining result.table result.value.2 + · simp only [canonicalQuerySelection_query_bind, hcomplete, ↓reduceIte, + tsum_probOutput_pure_mul, CanonicalQuerySelection.charge, tsum_zero] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalQueryTrace.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalQueryTrace.lean new file mode 100644 index 00000000..a12c2dc5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalQueryTrace.lean @@ -0,0 +1,158 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalSelectionSampled + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open _root_.OracleComp.DeferredSampling + +attribute [local instance] Classical.propDecidable + +noncomputable def runCanonicalQueryTrace + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp (Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) := + OracleComp.construct + (fun value context fuel table cache => + if DeferredCompletable table context then pure (some ⟨context, fuel, (value, cache), table⟩, []) + else pure (none, [])) + (fun input _ next context fuel table cache => + if DeferredCompletable table context then do + let result ← canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache + let tail ← match result with + | none => pure (none, []) + | some result => next result.value.1 result.context result.remaining result.table result.value.2 + pure (tail.1, (⟨input, context, fuel, table, cache⟩ : CanonicalQuerySelection) :: tail.2) + else pure (none, [])) computation + +theorem runCanonicalQueryTrace_query_bind + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runCanonicalQueryTrace parameter root ftsSecret (OracleSpec.query input >>= next) context fuel table cache = + if DeferredCompletable table context then do + let result ← canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache + let tail ← match result with + | none => pure (none, []) + | some result => + runCanonicalQueryTrace parameter root ftsSecret (next result.value.1) + result.context result.remaining result.table result.value.2 + pure (tail.1, (⟨input, context, fuel, table, cache⟩ : CanonicalQuerySelection) :: tail.2) + else pure (none, []) := rfl + +theorem runCanonicalQueryTrace_of_not_completable + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hnot : ¬DeferredCompletable table context) : + runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache = pure (none, []) := by + induction computation using OracleComp.inductionOn with + | pure value => simp only [runCanonicalQueryTrace, OracleComp.construct_pure, hnot, ↓reduceIte] + | query_bind input next _ => rw [runCanonicalQueryTrace_query_bind, if_neg hnot] + +set_option maxRecDepth 100000 in +theorem runCanonicalQueryTrace_selection_projection + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (ordinal : Nat) : + evalDist ((fun result => result.2[ordinal]?) <$> + runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache) = + evalDist (canonicalQuerySelection parameter root ftsSecret computation ordinal context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache ordinal with + | pure value => + simp only [runCanonicalQueryTrace, OracleComp.construct_pure, canonicalQuerySelection_pure] + split_ifs <;> simp + | query_bind input next ih => + rw [runCanonicalQueryTrace_query_bind, canonicalQuerySelection_query_bind] + by_cases hcomplete : DeferredCompletable table context + · simp only [hcomplete, ↓reduceIte, map_bind] + cases ordinal with + | zero => + calc + _ = evalDist (canonicalChronologicalAdversaryImpl parameter root table ftsSecret + input context fuel table cache >>= fun _ => + pure (some (⟨input, context, fuel, table, cache⟩ : CanonicalQuerySelection))) := by + apply evalDist_bind_congr_left + intro result + cases result with + | none => simp + | some result => + simp only [map_bind, map_pure, List.getElem?_cons_zero] + exact evalDist_bind_const_neverFails _ (by simp) _ + _ = _ := evalDist_bind_const_neverFails _ (by simp) _ + | succ ordinal => + apply evalDist_bind_congr_left + intro result + cases result with + | none => simp + | some result => + simp only [map_bind, map_pure, List.getElem?_cons_succ] + simpa only [map_eq_bind_pure_comp, Function.comp_def] using + ih result.value.1 result.context result.remaining result.table result.value.2 ordinal + · simp [hcomplete] + +noncomputable def canonicalTraceCharge + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ℝ≥0∞) + (history : List CanonicalQuerySelection) : ℝ≥0∞ := + (history.map fun selection => CanonicalQuerySelection.charge charge (some selection)).sum + +theorem canonicalTraceCharge_eq_tsum_selection + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ℝ≥0∞) + (history : List CanonicalQuerySelection) : + canonicalTraceCharge charge history = ∑' ordinal : Nat, CanonicalQuerySelection.charge charge (history[ordinal]?) := by + induction history with + | nil => simp [canonicalTraceCharge, CanonicalQuerySelection.charge] + | cons head tail ih => + rw [tsum_eq_zero_add' ENNReal.summable] + simpa only [canonicalTraceCharge, List.map_cons, List.sum_cons, List.getElem?_cons_zero, + List.getElem?_cons_succ] using congrArg (CanonicalQuerySelection.charge charge (some head) + ·) ih + +theorem expectedCanonicalTraceCharge_eq + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ℝ≥0∞) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + (∑' result, Pr[= result | runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache] * + canonicalTraceCharge charge result.2) = + expectedCanonicalQueryCharge parameter root ftsSecret charge computation context fuel table cache := by + simp_rw [canonicalTraceCharge_eq_tsum_selection, ← ENNReal.tsum_mul_left] + rw [ENNReal.tsum_comm, ← tsum_canonicalQuerySelection_charge] + apply tsum_congr + intro ordinal + calc + _ = ∑' selection, Pr[= selection | (fun result => result.2[ordinal]?) <$> + runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache] * + CanonicalQuerySelection.charge charge selection := (tsum_probOutput_map_mul _ _ _).symm + _ = _ := tsum_congr fun selection => congrArg (· * CanonicalQuerySelection.charge charge selection) + (_root_.OracleComp.probOutput_congr rfl (runCanonicalQueryTrace_selection_projection + parameter root ftsSecret computation context fuel table cache ordinal)) + + +set_option maxRecDepth 100000 in +theorem expectedCanonicalJointTraceCharge_le_actualReserve + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + (∑' result, Pr[= result | runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache] * + canonicalTraceCharge (canonicalJointOuterCharge parameter) result.2) ≤ + expectedQueryCharge (otsOpeningRefinedQueryReserve secretKey) + (simulateQ (expandedAdversaryImpl secretKey) computation) actualCache := by + dsimp only + rw [expectedCanonicalTraceCharge_eq] + exact expectedCanonicalJointCharge_le_actualReserve parameter root table ftsSecret computation + context fuel cache actualCache hinvariant hvisible hpublished hcomputed + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalRejectionProbability.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalRejectionProbability.lean new file mode 100644 index 00000000..1b0b95cc --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalRejectionProbability.lean @@ -0,0 +1,179 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalStopping + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def ResolvedQueryRejected (result : Option (ResolvedRunResult α)) : Prop := + match result with + | none => True + | some result => ¬DeferredCompletable result.table result.context + +noncomputable def canonicalQueryRejectionRisk + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (entry : CanonicalQuerySelection) : ℝ≥0∞ := + Pr[ResolvedQueryRejected | canonicalChronologicalAdversaryImpl parameter root entry.table ftsSecret + entry.input entry.context entry.fuel entry.table entry.cache] + +noncomputable def canonicalTraceRejectionRisk + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (history : List CanonicalQuerySelection) : ℝ≥0∞ := + (history.map (canonicalQueryRejectionRisk parameter root ftsSecret)).sum + +private theorem expected_const_add (computation : ProbComp α) (constant : ℝ≥0∞) (cost : α → ℝ≥0∞) : + (∑' result, Pr[= result | computation] * (constant + cost result)) = + constant + ∑' result, Pr[= result | computation] * cost result := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_mul_right, tsum_probOutput_eq_one' (by simp), one_mul] + +theorem expectedCanonicalTraceRejectionRisk_query_bind + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcomplete : DeferredCompletable table context) : + (∑' result, Pr[= result | runCanonicalQueryTrace parameter root ftsSecret + (OracleSpec.query input >>= next) context fuel table cache] * + canonicalTraceRejectionRisk parameter root ftsSecret result.2) = + canonicalQueryRejectionRisk parameter root ftsSecret ⟨input, context, fuel, table, cache⟩ + + ∑' step, Pr[= step | canonicalChronologicalAdversaryImpl parameter root table ftsSecret + input context fuel table cache] * + match step with + | none => 0 + | some step => ∑' tail, Pr[= tail | runCanonicalQueryTrace parameter root ftsSecret + (next step.value.1) step.context step.remaining step.table step.value.2] * + canonicalTraceRejectionRisk parameter root ftsSecret tail.2 := by + rw [runCanonicalQueryTrace_query_bind, if_pos hcomplete, tsum_probOutput_bind_mul] + rw [← expected_const_add] + apply tsum_congr + intro step + congr 1 + cases step with + | none => simp [canonicalTraceRejectionRisk] + | some step => + simp only [tsum_probOutput_bind_mul, tsum_probOutput_pure_mul, + canonicalTraceRejectionRisk, List.map_cons, List.sum_cons] + exact expected_const_add _ _ _ + +theorem probEvent_canonicalTrace_none_query_bind + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcomplete : DeferredCompletable table context) : + Pr[fun result => result.1 = none | runCanonicalQueryTrace parameter root ftsSecret + (OracleSpec.query input >>= next) context fuel table cache] = + ∑' step, Pr[= step | canonicalChronologicalAdversaryImpl parameter root table ftsSecret + input context fuel table cache] * + match step with + | none => 1 + | some step => Pr[fun result => result.1 = none | runCanonicalQueryTrace parameter root ftsSecret + (next step.value.1) step.context step.remaining step.table step.value.2] := by + rw [runCanonicalQueryTrace_query_bind, if_pos hcomplete, probEvent_bind_eq_tsum] + apply tsum_congr + intro step + congr 1 + cases step with + | none => simp + | some step => + simpa only [Function.comp_def] using probEvent_bind_pure_comp + (mx := runCanonicalQueryTrace parameter root ftsSecret (next step.value.1) + step.context step.remaining step.table step.value.2) + (f := fun result => (result.1, (⟨input, context, fuel, table, cache⟩ : CanonicalQuerySelection) :: result.2)) + (fun result => result.1 = none) + +set_option maxRecDepth 100000 in +theorem probEvent_canonicalTrace_none_eq_expected_rejectionRisk + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcomplete : DeferredCompletable table context) : + Pr[fun result => result.1 = none | runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache] = + ∑' result, Pr[= result | runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache] * + canonicalTraceRejectionRisk parameter root ftsSecret result.2 := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => simp [runCanonicalQueryTrace, hcomplete, canonicalTraceRejectionRisk] + | query_bind input next ih => + rw [probEvent_canonicalTrace_none_query_bind parameter root ftsSecret input next context fuel table cache hcomplete, + expectedCanonicalTraceRejectionRisk_query_bind parameter root ftsSecret input next context fuel table cache hcomplete, + canonicalQueryRejectionRisk, probEvent_eq_tsum_ite, ← ENNReal.tsum_add] + apply tsum_congr + intro step + cases step with + | none => simp [ResolvedQueryRejected] + | some step => + dsimp only + by_cases hnext : DeferredCompletable step.table step.context + · simp only [ResolvedQueryRejected, hnext, not_true_eq_false, ↓reduceIte, zero_add] + rw [ih step.value.1 step.context step.remaining step.table step.value.2 hnext] + · rw [runCanonicalQueryTrace_of_not_completable parameter root ftsSecret _ + step.context step.remaining step.table step.value.2 hnext] + simp [ResolvedQueryRejected, hnext, canonicalTraceRejectionRisk] + +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def canonicalRetainedRejectionRisk + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : ℝ≥0∞ := + ∑' root, Pr[= root | runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)] * + match root with + | none => 0 + | some root => ∑' result, Pr[= result | runCanonicalQueryTrace parameter root.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨root.value.1, parameter⟩) + root.context root.remaining root.table root.value.2] * + canonicalTraceRejectionRisk parameter root.value.1 ftsSecret result.2 + +theorem probEvent_canonicalRetainedTrace_none_eq_rejectionRisk + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun result => result.1 = none | canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel] = + canonicalRetainedRejectionRisk adversary parameter table ftsSecret fuel := by + unfold canonicalRetainedQueryTrace canonicalRetainedRejectionRisk + rw [probEvent_bind_eq_tsum] + apply tsum_congr + intro option + by_cases hroot : option ∈ support (runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)) + · cases option with + | none => exact False.elim (none_not_mem_resolved_maskedPublishedTreeRoot table fuel hroot) + | some root => + dsimp only + congr 1 + have hprojection := probEvent_bind_pure_comp + (runCanonicalQueryTrace parameter root.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨root.value.1, parameter⟩) + root.context root.remaining root.table root.value.2) + (fun rest => (rest.1.map (retainedResultWithRoot root.value.1), rest.2)) + (fun result => result.1 = none) + have heq := probEvent_canonicalTrace_none_eq_expected_rejectionRisk parameter root.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨root.value.1, parameter⟩) + root.context root.remaining root.table root.value.2 + (deferredCompletable_of_mem_resolved_maskedPublishedTreeRoot parameter table fuel root hroot) + calc + _ = Pr[fun result => result.1 = none | runCanonicalQueryTrace parameter root.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨root.value.1, parameter⟩) + root.context root.remaining root.table root.value.2] := by + simpa only [Function.comp_def, Option.map_eq_none_iff] using hprojection + _ = _ := heq + · rw [probOutput_eq_zero_of_not_mem_support hroot, zero_mul, zero_mul] + +open OracleComp.ProgramLogic.Relational in +theorem probEvent_retainedVerifyProbe_le_rejectionRisk + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table)] ≤ + canonicalRetainedRejectionRisk adversary parameter table ftsSecret fuel := by + rw [← prehitRetainedQueryTrace_cache_projection, probEvent_map, + ← probEvent_canonicalRetainedTrace_none_eq_rejectionRisk] + exact probEvent_le_of_relTriple + (relTriple_symm (relTriple_canonicalRetainedQueryTrace_prehit_witness adversary parameter table ftsSecret fuel)) + (fun _ _ hrelation hwitness => hrelation.2 hwitness) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalReserve.lean new file mode 100644 index 00000000..9397a659 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalReserve.lean @@ -0,0 +1,88 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +noncomputable def canonicalOtsHashCharge + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) : ℝ≥0∞ := by + classical + exact if ∃ position : Position, IsOtsPosition position ∧ AtPosition parameter input position then 4 / 3 + else (materializedCandidateCharge (materializedDeferredState context) + (decodeEncodingLayerRootCandidate? parameter input) : ℝ≥0∞) * (4 / 3) + +noncomputable def canonicalOtsOuterCharge (parameter : PublicParameter) : + (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ℝ≥0∞ + | .inl (.inr input), context, _, _ => canonicalOtsHashCharge parameter input context + | _, _, _, _ => 0 + +set_option maxRecDepth 100000 in +theorem canonicalOtsHashCharge_le_refinedReserve + {secretKey : SecretKey} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache actualCache : QueryCache HashSpec} + (hinvariant : ResolvedContextInvariant secretKey.parameter table context ordinaryCache actualCache) + (hcomputed : DeferredComputationsClosed context) + (hsecrets : secretKey.otsSecret = fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + (input : HashInput) : + canonicalOtsHashCharge secretKey.parameter input context ≤ + otsOpeningRefinedQueryReserve secretKey actualCache input := by + classical + unfold canonicalOtsHashCharge + split_ifs with hots + · obtain ⟨position, hposition, hat⟩ := hots + exact otsOpeningRefinedQueryReserve_ge_four_thirds_of_atOtsPosition secretKey actualCache input + position hat hposition + · cases hdecode : decodeEncodingLayerRootCandidate? secretKey.parameter input with + | none => simp [materializedCandidateCharge] + | some candidate => + have hcandidate := (decodeEncodingLayerRootCandidate?_eq_some_iff secretKey.parameter input candidate).mp hdecode + obtain ⟨position, hcoordinate, _hroot⟩ := encodingLayerRootCandidateAt_isLayerRoot hcandidate + simp only [materializedCandidateCharge] + split_ifs with hblocked hknown + · simp + · obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hknown + have hvalue : context.positionValue position = some output := by + simpa only [hcoordinate, materializedDeferredState] using houtput + simpa only [Nat.cast_one, one_mul] using + hcomputed.refinedReserve_of_encoding_candidate hinvariant hsecrets hcandidate hcoordinate hvalue + · simp + +set_option maxRecDepth 100000 in +theorem expectedCanonicalOtsCharge_le_actualReserve + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + expectedCanonicalQueryCharge parameter root ftsSecret (canonicalOtsOuterCharge parameter) + computation context fuel table cache ≤ + expectedQueryCharge + (otsOpeningRefinedQueryReserve + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey)) + (simulateQ (expandedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey)) computation) actualCache := by + apply le_trans ?_ (expectedOuterQueryCharge_le_expanded _ _ computation actualCache) + apply expectedCanonicalQueryCharge_le_outerQueryCharge parameter root table ftsSecret + (canonicalOtsOuterCharge parameter) _ ?_ computation context fuel cache actualCache + hinvariant hvisible hpublished hcomputed + intro input nextContext remaining nextCache concreteCache hcontext _hvisible _hpublished hcomputed + cases input with + | inl query => + cases query with + | inl n => exact le_rfl + | inr input => + change canonicalOtsHashCharge parameter input nextContext ≤ + otsOpeningRefinedQueryReserve + (⟨parameter, root, fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey) concreteCache input + exact canonicalOtsHashCharge_le_refinedReserve + (secretKey := ⟨parameter, root, fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩) hcontext hcomputed rfl input + | inr message => exact le_rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalRetainedTrace.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalRetainedTrace.lean new file mode 100644 index 00000000..8330b76f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalRetainedTrace.lean @@ -0,0 +1,271 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalVerifierTrace + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +theorem canonicalMaterializedValues_of_mem_canonicalChronologicalQuery + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult ((OracleWorld + SigningSpec).Range input × SplitHashCache)) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache)) : + CanonicalMaterializedValues table result.context := by + rw [canonicalChronologicalAdversaryImpl_eq_raw_then_canonicalize, mem_support_bind_iff] at hresult + obtain ⟨rawOption, hraw, hcanonical⟩ := hresult + cases rawOption with + | none => simp [canonicalizeResolvedRun] at hcanonical + | some raw => + simp only [canonicalizeResolvedRun, mem_support_pure_iff, Option.some.injEq] at hcanonical + subst result + have hcore := resolvedCore_of_mem_runResolvedFromTable + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) + context fuel table raw hconsistent hstarts hraw + exact canonicalizeMaterializedValues_canonical table raw.context hcore.2.1 + +set_option maxRecDepth 100000 in +theorem canonicalMaterializedValues_of_mem_synchronizedCanonical + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcanonical : CanonicalMaterializedValues table context) + (hresult : some result ∈ support (runSynchronizedResolved + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) computation context fuel table cache)) : + CanonicalMaterializedValues table result.context := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + by_cases hcomplete : DeferredCompletable table context + · rw [runSynchronizedResolved_pure _ value context fuel table cache hcomplete] at hresult + simp only [mem_support_pure_iff, Option.some.injEq] at hresult + subst result + exact hcanonical + · rw [runSynchronizedResolved_pure_of_not_completable _ value context fuel table cache hcomplete] at hresult + simp at hresult + | query_bind input next ih => + rw [runSynchronizedResolved, OracleComp.construct_query_bind] at hresult + by_cases hcomplete : DeferredCompletable table context + · simp only [dif_pos hcomplete, mem_support_bind_iff] at hresult + obtain ⟨stepOption, hstep, htail⟩ := hresult + cases stepOption with + | none => simp at htail + | some step => + have hcore := resolvedCore_of_mem_canonicalChronologicalAdversaryImpl parameter root table ftsSecret input + context fuel cache step hconsistent hstarts hstep + have hstepCanonical := canonicalMaterializedValues_of_mem_canonicalChronologicalQuery parameter root ftsSecret + input context fuel table cache step hconsistent hstarts hstep + change some result ∈ support (runSynchronizedResolved + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) (next step.value.1) + step.context step.remaining step.table step.value.2) at htail + rw [hcore.1] at htail + exact ih step.value.1 step.context step.remaining step.value.2 hcore.2.1 hcore.2.2 hstepCanonical htail + · simp [hcomplete] at hresult + +theorem finishResolvedRunIsNone_value_eq + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (left : α) (right : β) : + finishResolvedRunIsNone (some ⟨context, fuel, left, table⟩) = + finishResolvedRunIsNone (some ⟨context, fuel, right, table⟩) := by + unfold finishResolvedRunIsNone finishResolvedRun + dsimp only + split_ifs + · simp only [map_bind] + apply bind_congr + intro result + cases result <;> simp + · simp + +theorem evalDist_canonicalVerifierFinish_eq_rest_finish + (parameter : PublicParameter) (root : Digest) (forgeryLog : Forgery × QueryLog SigningSpec) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + evalDist (runResolvedFromTable context fuel table ((canonicalVerifierFinish parameter root forgeryLog).run cache) >>= + finishResolvedRunIsNone) = + evalDist (runResolvedFromTable context fuel table + ((simulateQ (probingRomImpl parameter) (do + let verified ← scheme.verify ⟨root, parameter⟩ forgeryLog.1.message forgeryLog.1.signature + pure (forgeryLog, verified))).run cache) >>= finishResolvedRunIsNone) := by + unfold canonicalVerifierFinish + simp only [simulateQ_bind, simulateQ_pure, StateT.run_bind, runResolvedFromTable_bind, bind_assoc] + apply evalDist_bind_congr + intro result _hresult + cases result with + | none => simp [finishResolvedRunIsNone, finishResolvedRun] + | some result => + simp only [StateT.run_pure, runResolvedFromTable, OracleComp.construct_pure, pure_bind] + rw [finishResolvedRunIsNone_value_eq result.context result.remaining result.table + ((root, (forgeryLog, result.value.1)), result.value.2) ((forgeryLog, result.value.1), result.value.2)] + +set_option maxRecDepth 100000 in +theorem evalDist_synchronizedCanonicalRetainedRest_finish_eq_split + (adversary : Adversary) (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) (hcanonical : CanonicalMaterializedValues table context) : + evalDist (runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (retainedGameRestComputation adversary ⟨root, parameter⟩) context fuel table cache >>= finishResolvedRunIsNone) = + evalDist (do + let result ← runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) context fuel table cache + canonicalVerifierContinuation parameter root result >>= finishResolvedRunIsNone) := by + unfold retainedGameRestComputation + rw [runSynchronizedResolved_bind, bind_assoc] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => simp [canonicalVerifierContinuation, finishResolvedRunIsNone, finishResolvedRun] + | some result => + have hcore := resolvedCore_of_mem_runSynchronizedResolved_canonicalChronological parameter root table ftsSecret + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) context fuel cache result + hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hresult + have hnextCanonical := canonicalMaterializedValues_of_mem_synchronizedCanonical parameter root ftsSecret + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) context fuel table cache result + hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hcanonical hresult + have hrel := relTriple_runSynchronizedResolved_reachable + (canonicalReachableResolvedImplCouples_chronologicalAdversaryImpl parameter root table ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) context fuel cache actualCache + hinvariant hvisible hpublished + obtain ⟨actual, _hactual, hrelation⟩ := exists_right_of_relTriple_of_mem_support hrel hresult + dsimp only [canonicalVerifierContinuation] + rw [hcore.1] + rcases hrelation with hclean | hdoomed + · have hlift : liftOracleWorldLeft (do + let verified ← scheme.verify ⟨root, parameter⟩ result.value.1.1.message result.value.1.1.signature + pure (result.value.1, verified)) = (do + let verified ← liftOracleWorldLeft + (scheme.verify ⟨root, parameter⟩ result.value.1.1.message result.value.1.1.signature) + pure ((result.value.1.1, result.value.1.2), verified)) := by + simp only [liftOracleWorldLeft, liftM_bind, liftM_pure] + rw [← hlift] + change evalDist (runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (liftOracleWorldLeft (do + let verified ← scheme.verify ⟨root, parameter⟩ result.value.1.1.message result.value.1.1.signature + pure (result.value.1, verified))) result.context result.remaining table result.value.2 >>= + finishResolvedRunIsNone) = _ + rw [runSynchronizedResolved_liftOracleWorldLeft, + evalDist_synchronizedCanonicalRom_finish_eq_raw parameter root ftsSecret _ result.context result.remaining + table result.value.2 hcore.2.1 hcore.2.2 hnextCanonical hclean.2.2.2.2] + exact (evalDist_canonicalVerifierFinish_eq_rest_finish parameter root result.value.1 + result.context result.remaining table result.value.2).symm + · rw [runSynchronizedResolved_of_not_completable _ _ result.context result.remaining table result.value.2 hdoomed.2.2.2] + simp only [pure_bind, finishResolvedRunIsNone, finishResolvedRun, map_pure, Option.isNone_none] + exact (evalDist_runResolvedFinishIsNone_eq_true_of_not_completable result.context result.remaining table _ + hcore.2.1 hcore.2.2 hdoomed.2.2.2).symm + +def retainedResultWithRoot (root : Digest) (result : ResolvedRunResult (RetainedRestResult × SplitHashCache)) : + ResolvedRunResult (RetainedGameResult × SplitHashCache) := + ⟨result.context, result.remaining, ((root, result.value.1), result.value.2), result.table⟩ + +theorem finishResolvedRunIsNone_retainedRoot + (root : Digest) (result : Option (ResolvedRunResult (RetainedRestResult × SplitHashCache))) : + finishResolvedRunIsNone (result.map (retainedResultWithRoot root)) = finishResolvedRunIsNone result := by + cases result with + | none => simp [finishResolvedRunIsNone, finishResolvedRun] + | some result => exact finishResolvedRunIsNone_value_eq result.context result.remaining result.table _ _ + +noncomputable def canonicalRetainedQueryTrace + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp (Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)) × List CanonicalQuerySelection) := do + let rootResult ← runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure (none, []) + | some result => do + let rest ← runCanonicalQueryTrace parameter result.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining result.table result.value.2 + pure (rest.1.map (retainedResultWithRoot result.value.1), rest.2) + +set_option maxRecDepth 100000 in +theorem evalDist_canonicalRetainedQueryTrace_finish_eq_original + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel >>= + fun result => finishResolvedRunIsNone result.1) = + evalDist (canonicalChronologicalRetainedRunAfterFtsSecrets adversary parameter table ftsSecret fuel >>= + finishResolvedRunIsNone) := by + unfold canonicalRetainedQueryTrace canonicalChronologicalRetainedRunAfterFtsSecrets + simp only [bind_assoc] + apply evalDist_bind_congr + intro rootOption hroot + cases rootOption with + | none => simp [finishResolvedRunIsNone, finishResolvedRun] + | some result => + have hcore := resolvedCore_of_mem_runResolved_maskedPublishedTreeRoot parameter table fuel result hroot + have hcanonical := canonicalMaterializedValues_of_mem_maskedPublishedTreeRoot parameter table fuel result hroot + have hrel := reachableResolvedCouples_maskedPublishedTreeRoot parameter table + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel emptySplitHashCache ∅ (resolvedContextInvariant_empty parameter table) + (visibleResolvedComputationsCached_empty parameter table emptyDeferredStructuralValues ∅) publishedValues_empty + obtain ⟨actual, _hactual, hrelation⟩ := exists_right_of_relTriple_of_mem_support hrel hroot + dsimp only + simp only [bind_assoc, pure_bind, finishResolvedRunIsNone_retainedRoot] + rw [hcore.1, runCanonicalQueryTrace_observer_projection parameter result.value.1 ftsSecret _ + result.context result.remaining table result.value.2 _ hcore.2.1 hcore.2.2] + rcases hrelation with hclean | hdoomed + · simpa only [bind_assoc] using + evalDist_synchronizedCanonicalRetainedRest_finish_eq_split adversary parameter result.value.1 table ftsSecret + result.context result.remaining result.value.2 actual.2 hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 hcanonical + · rw [runSynchronizedResolved_of_not_completable _ _ result.context result.remaining table result.value.2 hdoomed.2.2.2, + runSynchronizedResolved_of_not_completable _ _ result.context result.remaining table result.value.2 hdoomed.2.2.2] + simp [canonicalVerifierContinuation, finishResolvedRunIsNone, finishResolvedRun] + +theorem probEvent_winningRetainedVerifyProbe_le_canonicalQueryTrace_failure + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table)] ≤ + Pr[= true | canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel >>= + fun result => finishResolvedRunIsNone result.1] := by + rw [_root_.OracleComp.probOutput_congr rfl + (evalDist_canonicalRetainedQueryTrace_finish_eq_original adversary parameter table ftsSecret fuel)] + have hbound := probEvent_winningRetainedVerifyProbe_le_canonicalFinishedResolvedRun_none adversary parameter table ftsSecret fuel + rw [probEvent_eq_eq_probOutput, probEvent_finishResolvedRun_none_eq_isNone] at hbound + exact hbound + +theorem expectedCanonicalRetainedQueryTrace_charge_eq + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + (∑' result, Pr[= result | canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel] * + canonicalTraceCharge (canonicalJointOuterCharge parameter) result.2) = + canonicalJointChargeAfterTable adversary parameter table ftsSecret fuel := by + unfold canonicalRetainedQueryTrace canonicalJointChargeAfterTable + rw [tsum_probOutput_bind_mul] + apply tsum_congr + intro result + by_cases hresult : result ∈ support (runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)) + · cases result with + | none => simp [canonicalTraceCharge] + | some result => + have hcore := resolvedCore_of_mem_runResolved_maskedPublishedTreeRoot parameter table fuel result hresult + dsimp only + simp only [tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + rw [hcore.1, expectedCanonicalTraceCharge_eq] + · rw [probOutput_eq_zero_of_not_mem_support hresult] + simp + +theorem expectedCanonicalRetainedQueryTrace_charge_le_gameReserve + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + (∑' result, Pr[= result | canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel] * + canonicalTraceCharge (canonicalJointOuterCharge parameter) result.2) ≤ + expectedQueryCharge (otsOpeningRefinedQueryReserve (primitiveAccountingKey parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret)) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) ∅ := by + rw [expectedCanonicalRetainedQueryTrace_charge_eq] + exact canonicalJointChargeAfterTable_le_gameReserve adversary parameter table ftsSecret fuel + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalSelectionCoupling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalSelectionCoupling.lean new file mode 100644 index 00000000..33a218a4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalSelectionCoupling.lean @@ -0,0 +1,102 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalQuerySelection + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +structure ActualQuerySelection where + input : (OracleWorld + SigningSpec).Domain + cache : QueryCache HashSpec + +noncomputable def actualQuerySelection (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + Nat → QueryCache HashSpec → ProbComp (Option ActualQuerySelection) := + OracleComp.construct (fun _ _ _ => pure none) + (fun input _ next ordinal cache => + match ordinal with + | 0 => pure (some ⟨input, cache⟩) + | ordinal + 1 => do + let result ← (unloggedMappedAdversaryImpl secretKey input).run cache + next result.1 ordinal result.2) computation + +def CanonicalQuerySelectionRel (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) : + Option CanonicalQuerySelection → Option ActualQuerySelection → Prop + | none, _ => True + | some left, some right => left.input = right.input ∧ left.table = table ∧ + ResolvedContextInvariant parameter table left.context (ordinaryQueryCache left.cache) right.cache ∧ + VisibleResolvedComputationsCached parameter table left.context right.cache ∧ + PublishedValues left.context.state ∧ DeferredComputationsClosed left.context + | some _, none => False + +theorem canonicalQuerySelection_eq_none_of_not_completable + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hnot : ¬DeferredCompletable table context) : + canonicalQuerySelection parameter root ftsSecret computation ordinal context fuel table cache = pure none := by + induction computation using OracleComp.inductionOn with + | pure value => rfl + | query_bind input next _ => rw [canonicalQuerySelection_query_bind, if_neg hnot] + +theorem relTriple_none_actualQuerySelection + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (right : ProbComp (Option ActualQuerySelection)) : + RelTriple (pure none : ProbComp (Option CanonicalQuerySelection)) right + (CanonicalQuerySelectionRel parameter table) := by + have hbase := relTriple_true (pure none : ProbComp (Option CanonicalQuerySelection)) right + have hsupported := FtsProbeSimulation.relTriple_and_left_support hbase + (fun selection => selection = none) (by intro selection hselection; simpa using hselection) + apply relTriple_post_mono hsupported + intro left right hrelation + rw [hrelation.2] + trivial + +set_option maxRecDepth 100000 in +theorem relTriple_canonicalQuerySelection_actualQuerySelection + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + RelTriple (canonicalQuerySelection parameter root ftsSecret computation ordinal context fuel table cache) + (actualQuerySelection + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) computation ordinal actualCache) + (CanonicalQuerySelectionRel parameter table) := by + induction computation using OracleComp.inductionOn generalizing ordinal context fuel cache actualCache with + | pure value => exact relTriple_pure_pure trivial + | query_bind input next ih => + rw [canonicalQuerySelection_query_bind, if_pos hinvariant.2.2.2.1, + actualQuerySelection, OracleComp.construct_query_bind] + cases ordinal with + | zero => exact relTriple_pure_pure ⟨rfl, rfl, hinvariant, hvisible, hpublished, hcomputed⟩ + | succ ordinal => + have hstep := canonicalReachableResolvedImplCouples_chronologicalAdversaryImpl + parameter root table ftsSecret input context fuel cache actualCache hinvariant hvisible hpublished + have hsupported := FtsProbeSimulation.relTriple_and_left_support hstep + (fun left => ∀ result, left = some result → DeferredComputationsClosed result.context) (by + intro left hleft result heq + subst left + exact hcomputed.of_mem_canonicalChronologicalQuery parameter root table ftsSecret input context fuel cache + result hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hleft) + apply relTriple_bind hsupported + intro left right hrelation + cases left with + | none => exact relTriple_none_actualQuerySelection parameter table _ + | some result => + dsimp only + rcases hrelation.1 with hclean | hdoomed + · rw [hclean.1, ← hclean.2.1] + exact ih result.value.1 ordinal result.context result.remaining result.value.2 right.2 + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 (hrelation.2 result rfl) + · rw [canonicalQuerySelection_eq_none_of_not_completable parameter root ftsSecret + (next result.value.1) ordinal result.context result.remaining result.table result.value.2 (by + rw [hdoomed.1] + exact hdoomed.2.2.2)] + exact relTriple_none_actualQuerySelection parameter table _ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalSelectionSampled.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalSelectionSampled.lean new file mode 100644 index 00000000..fb82e4c5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalSelectionSampled.lean @@ -0,0 +1,185 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalSelectionCoupling + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def canonicalQuerySelectionAfterTable + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel ordinal : Nat) : + ProbComp (Option CanonicalQuerySelection) := do + let result ← runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + match result with + | none => pure none + | some result => + canonicalQuerySelection parameter result.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + ordinal result.context result.remaining table result.value.2 + +theorem tsum_canonicalQuerySelectionAfterTable_charge + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + (∑' ordinal, ∑' selection, + Pr[= selection | canonicalQuerySelectionAfterTable adversary parameter table ftsSecret fuel ordinal] * + CanonicalQuerySelection.charge (canonicalJointOuterCharge parameter) selection) = + canonicalJointChargeAfterTable adversary parameter table ftsSecret fuel := by + unfold canonicalQuerySelectionAfterTable canonicalJointChargeAfterTable + simp only [tsum_probOutput_bind_mul] + rw [ENNReal.tsum_comm] + apply tsum_congr + intro result + rw [ENNReal.tsum_mul_left] + congr 1 + cases result with + | none => simp only [tsum_probOutput_pure_mul, CanonicalQuerySelection.charge, tsum_zero] + | some result => + exact tsum_canonicalQuerySelection_charge parameter result.value.1 ftsSecret + (canonicalJointOuterCharge parameter) _ result.context result.remaining table result.value.2 + + +noncomputable def actualQuerySelectionAfterSecrets + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (ordinal : Nat) : + ProbComp (Option ActualQuerySelection) := do + let result ← (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅ + actualQuerySelection (⟨parameter, result.1, otsSecret, ftsSecret⟩ : SecretKey) + (retainedGameRestComputation adversary ⟨result.1, parameter⟩) ordinal result.2 + +set_option maxRecDepth 100000 in +theorem relTriple_canonicalQuerySelectionAfterTable_actual + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel ordinal : Nat) : + RelTriple (canonicalQuerySelectionAfterTable adversary parameter table ftsSecret fuel ordinal) + (actualQuerySelectionAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret ordinal) + (CanonicalQuerySelectionRel parameter table) := by + have hroot := reachableResolvedCouples_maskedPublishedTreeRoot parameter table + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel emptySplitHashCache ∅ (resolvedContextInvariant_empty parameter table) + (visibleResolvedComputationsCached_empty parameter table emptyDeferredStructuralValues ∅) publishedValues_empty + have hsupported := FtsProbeSimulation.relTriple_and_left_support hroot + (fun left => ∀ result, left = some result → DeferredComputationsClosed result.context) (by + intro left hleft result heq + subst left + exact deferredComputationsClosed_empty.of_mem_runResolved _ _ fuel table result hleft) + unfold canonicalQuerySelectionAfterTable actualQuerySelectionAfterSecrets + apply relTriple_bind (by simpa only [treeRoot] using hsupported) + intro left right hrelation + cases left with + | none => exact relTriple_none_actualQuerySelection parameter table _ + | some result => + dsimp only + rcases hrelation.1 with hclean | hdoomed + · rw [← hclean.2.1] + exact relTriple_canonicalQuerySelection_actualQuerySelection parameter result.value.1 table ftsSecret + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + ordinal result.context result.remaining result.value.2 right.2 + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 (hrelation.2 result rfl) + · rw [canonicalQuerySelection_eq_none_of_not_completable parameter result.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + ordinal result.context result.remaining table result.value.2 hdoomed.2.2.2] + exact relTriple_none_actualQuerySelection parameter table _ + +noncomputable def sampledCanonicalQuerySelection (adversary : Adversary) (fuel ordinal : Nat) : + ProbComp (PublicParameter × Option CanonicalQuerySelection) := do + let parameter ← sampleParameter + let table ← sampleOtsHashTable + let ftsSecret ← sampleFtsSecrets + (fun selection => (parameter, selection)) <$> + canonicalQuerySelectionAfterTable adversary parameter table ftsSecret fuel ordinal + +theorem tsum_sampledCanonicalQuerySelection_charge + (adversary : Adversary) (fuel : Nat) : + (∑' ordinal, ∑' result, Pr[= result | sampledCanonicalQuerySelection adversary fuel ordinal] * + CanonicalQuerySelection.charge (canonicalJointOuterCharge result.1) result.2) = + sampledCanonicalJointCharge adversary fuel := by + unfold sampledCanonicalQuerySelection sampledCanonicalJointCharge + simp only [tsum_probOutput_bind_mul, tsum_probOutput_map_mul] + rw [ENNReal.tsum_comm] + apply tsum_congr + intro parameter + rw [ENNReal.tsum_mul_left] + congr 1 + rw [ENNReal.tsum_comm] + apply tsum_congr + intro table + rw [ENNReal.tsum_mul_left] + congr 1 + rw [ENNReal.tsum_comm] + apply tsum_congr + intro ftsSecret + rw [ENNReal.tsum_mul_left, tsum_canonicalQuerySelectionAfterTable_charge] + +theorem tsum_sampledCanonicalQuerySelection_charge_le_refinedReserve + (adversary : Adversary) (fuel : Nat) : + (∑' ordinal, ∑' result, Pr[= result | sampledCanonicalQuerySelection adversary fuel ordinal] * + CanonicalQuerySelection.charge (canonicalJointOuterCharge result.1) result.2) ≤ + sampledQueryCharge otsOpeningRefinedQueryReserve adversary := by + rw [tsum_sampledCanonicalQuerySelection_charge] + exact sampledCanonicalJointCharge_le_refinedReserve adversary fuel + + +noncomputable def sampledActualQuerySelection (adversary : Adversary) (ordinal : Nat) : + ProbComp (SampledSecrets × Option ActualQuerySelection) := do + let secrets ← sampleSecrets + (fun selection => (secrets, selection)) <$> + actualQuerySelectionAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret ordinal + +def SampledCanonicalQuerySelectionRel + (left : PublicParameter × Option CanonicalQuerySelection) + (right : SampledSecrets × Option ActualQuerySelection) : Prop := + left.1 = right.1.parameter ∧ ∃ table : OtsSecretIndex → HashOutput, + right.1.otsSecret = (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ∧ + CanonicalQuerySelectionRel left.1 table left.2 right.2 + +set_option maxRecDepth 100000 in +theorem relTriple_sampledCanonicalQuerySelection_actual + (adversary : Adversary) (fuel ordinal : Nat) : + RelTriple (sampledCanonicalQuerySelection adversary fuel ordinal) + (sampledActualQuerySelection adversary ordinal) SampledCanonicalQuerySelectionRel := by + unfold sampledCanonicalQuerySelection sampledActualQuerySelection + simp only [sampleSecrets, bind_assoc, pure_bind] + apply relTriple_bind (relTriple_refl sampleParameter) + intro parameter other hparameter + subst other + apply relTriple_bind (by + simpa only [sampleOtsHashTable] using relTriple_uniformOtsHashTable_sampleOtsSecrets) + intro table otsSecret hsecrets + have hots : otsSecret = fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩) := + hsecrets.symm + rw [hots] + apply relTriple_bind (relTriple_refl sampleFtsSecrets) + intro ftsSecret other hfts + subst other + apply relTriple_map + apply relTriple_post_mono + (relTriple_canonicalQuerySelectionAfterTable_actual adversary parameter table ftsSecret fuel ordinal) + intro left right hrelation + exact ⟨rfl, table, rfl, hrelation⟩ + + +set_option maxRecDepth 100000 in +theorem SampledCanonicalQuerySelectionRel.root_settled_value + {parameter : PublicParameter} {selection : CanonicalQuerySelection} + {secrets : SampledSecrets} {actual : ActualQuerySelection} + (hrelation : SampledCanonicalQuerySelectionRel (parameter, some selection) (secrets, some actual)) + (lay : Layer) (tree : TreeIndex) (output : HashOutput) + (hvalue : selection.context.positionValue (layerRootPosition lay tree) = some output) : + Settled secrets.parameter secrets.otsSecret secrets.ftsSecret actual.cache (layerRootPosition lay tree) ∧ + honestValue (fromCache actual.cache) secrets.parameter secrets.otsSecret secrets.ftsSecret + (layerRootPosition lay tree) = truncateHash output := by + obtain ⟨hparameter, table, hsecrets, hselected⟩ := hrelation + obtain ⟨_hinput, _htable, hinvariant, _hvisible, _hpublished, hcomputed⟩ := hselected + have hroot := hcomputed.root_settled_value hinvariant secrets.ftsSecret lay tree output hvalue + dsimp only at hparameter hsecrets + rw [← hparameter, hsecrets] + exact hroot + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalStopping.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalStopping.lean new file mode 100644 index 00000000..58070014 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalStopping.lean @@ -0,0 +1,283 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalFuel + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +def CanonicalQueryRejects + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (entry : CanonicalQuerySelection) : Prop := + ∃ result ∈ support (canonicalChronologicalAdversaryImpl parameter root entry.table ftsSecret + entry.input entry.context entry.fuel entry.table entry.cache), + match result with + | none => True + | some result => ¬DeferredCompletable result.table result.context + +set_option maxRecDepth 100000 in +theorem last_query_rejects_of_canonicalTrace_none + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (history : List CanonicalQuerySelection) + (hcomplete : DeferredCompletable table context) + (hrun : (none, history) ∈ support + (runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache)) : + ∃ before entry, history = before ++ [entry] ∧ DeferredCompletable entry.table entry.context ∧ + CanonicalQueryRejects parameter root ftsSecret entry := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache history with + | pure value => + simp [runCanonicalQueryTrace, hcomplete] at hrun + | query_bind input next ih => + rw [runCanonicalQueryTrace_query_bind, if_pos hcomplete, mem_support_bind_iff] at hrun + obtain ⟨stepOption, hstep, hrun⟩ := hrun + cases stepOption with + | none => + simp only [pure_bind, mem_support_pure_iff, Prod.mk.injEq, true_and] at hrun + subst history + exact ⟨[], ⟨input, context, fuel, table, cache⟩, rfl, hcomplete, none, hstep, trivial⟩ + | some step => + dsimp only at hrun + by_cases hnext : DeferredCompletable step.table step.context + · rw [mem_support_bind_iff] at hrun + obtain ⟨tail, htail, hpure⟩ := hrun + simp only [mem_support_pure_iff, Prod.mk.injEq] at hpure + have htailNone : tail.1 = none := hpure.1.symm + have htailRun : (none, tail.2) ∈ support + (runCanonicalQueryTrace parameter root ftsSecret (next step.value.1) + step.context step.remaining step.table step.value.2) := by + simpa only [← htailNone] using htail + obtain ⟨before, entry, hlast, hentry, hreject⟩ := ih step.value.1 step.context step.remaining + step.table step.value.2 tail.2 hnext htailRun + refine ⟨⟨input, context, fuel, table, cache⟩ :: before, entry, ?_, hentry, hreject⟩ + rw [hpure.2, hlast] + rfl + · rw [runCanonicalQueryTrace_of_not_completable parameter root ftsSecret _ + step.context step.remaining step.table step.value.2 hnext] at hrun + simp only [pure_bind, mem_support_pure_iff, Prod.mk.injEq, true_and] at hrun + subst history + exact ⟨[], ⟨input, context, fuel, table, cache⟩, rfl, hcomplete, some step, hstep, hnext⟩ + +theorem none_not_mem_resolveDeferredReveal_of_no_pending + (table : OtsSecretIndex → HashOutput) (position : Position) (context : DeferredContext) + (hvalid : context.Valid) (hcovered : PendingCovered [] context) : + none ∉ support (resolveDeferredReveal table position context) := by + intro hnone + have heq := evalDist_map_resolveDeferredReveal_then_finalize table position [] context hvalid hcovered + have hleft : none ∈ support (do + let resolved ← resolveDeferredReveal table position context + match resolved with + | none => (pure none : ProbComp (Option (LazyRevealProbe.State Coordinate))) + | some resolved => projectDeferredState <$> + finalizeResolvedCoordinates [] resolved.toDeferredContext table) := by + rw [mem_support_bind_iff] + exact ⟨none, hnone, by simp⟩ + have hright := (mem_support_iff_of_evalDist_eq heq none).mp hleft + simp [finalizeResolvedCoordinates, projectDeferredState] at hright + +theorem none_not_mem_resolved_revealPublishedPosition_of_no_pending + (table : OtsSecretIndex → HashOutput) (position : Position) (context : DeferredContext) + (fuel : Nat) (cache : SplitHashCache) (hvalid : context.Valid) (hcovered : PendingCovered [] context) : + none ∉ support (runResolvedFromTable context fuel table + ((revealPublishedCoordinate (.position position)).run cache)) := by + intro hnone + unfold revealPublishedCoordinate at hnone + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hnone + obtain ⟨resolvedOption, hresolved, htail⟩ := hnone + cases resolvedOption with + | none => + rw [runResolvedFromTable_revealCoordinate, mem_support_bind_iff] at hresolved + obtain ⟨option, hoption, hpure⟩ := hresolved + cases option with + | none => exact none_not_mem_resolveDeferredReveal_of_no_pending table position context hvalid hcovered hoption + | some result => simp at hpure + | some result => + dsimp only at htail + rw [StateT.run_bind, runResolvedFromTable_bind] at htail + obtain ⟨finalContext, hpublish, _⟩ := (resolvedAdministrative_publishCoordinate (.position position)).run + result.context result.value.2 result.remaining result.table + rw [hpublish] at htail + simp [runResolvedFromTable] at htail + +theorem none_not_mem_resolved_maskedPublishedTreeRoot + (table : OtsSecretIndex → HashOutput) (fuel : Nat) : + none ∉ support (runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + intro hnone + obtain ⟨reserved, hreserve, hpending, hvalues, hdeferred⟩ := + (resolvedAdministrative_ensureTreeNode topLayer rootTree (layerHeight topLayer) 0).run + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } emptySplitHashCache fuel table + unfold maskedPublishedTreeRoot at hnone + rw [StateT.run_bind, runResolvedFromTable_bind, hreserve] at hnone + simp only [pure_bind] at hnone + have hvalid : reserved.Valid := by + constructor + · intro position output hvalue + rw [hvalues] at hvalue + simp [LazyRevealProbe.State.empty] at hvalue + · intro coordinate output _hvalue + simp [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, hpending, LazyRevealProbe.State.empty] + have hcovered : PendingCovered [] reserved := by + intro entry hentry + rw [hpending] at hentry + simp [LazyRevealProbe.State.empty] at hentry + exact none_not_mem_resolved_revealPublishedPosition_of_no_pending table _ reserved fuel emptySplitHashCache + hvalid hcovered hnone + +theorem deferredCompletable_of_no_pending + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcovered : PendingCovered [] context) : DeferredCompletable table context := by + let completion : Coordinate → HashOutput + | .chainStart lay tree leafIdx chainIdx => table ⟨lay, tree, leafIdx, chainIdx⟩ + | .position position => (context.values position).getD 0 + refine ⟨completion, ?_, ?_, ?_, ?_⟩ + · intro coordinate output hvalue + cases coordinate with + | chainStart lay tree leafIdx chainIdx => exact (hstarts ⟨lay, tree, leafIdx, chainIdx⟩ output hvalue).symm + | position position => simp [completion, hconsistent position output hvalue] + · intro position output hvalue + simp [completion, hvalue] + · intro coordinate candidate hmember + exact False.elim (List.not_mem_nil (hcovered _ hmember)) + · intro index + cases index + rfl + +theorem deferredCompletable_of_mem_resolved_maskedPublishedTreeRoot + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) (fuel : Nat) + (result : ResolvedRunResult (Digest × SplitHashCache)) + (hresult : some result ∈ support (runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) : + DeferredCompletable result.table result.context := by + have hcore := resolvedCore_of_mem_runResolved_maskedPublishedTreeRoot parameter table fuel result hresult + have hcovered := valid_pendingCovered_of_mem_runResolvedFromTable_of_probeFree _ _ fuel table result [] + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) DeferredContext.valid_empty + (by intro entry hentry; simp [LazyRevealProbe.State.empty] at hentry) hresult + rw [hcore.1] + exact deferredCompletable_of_no_pending table result.context hcore.2.1 hcore.2.2 hcovered.2 + +open OracleComp.ProgramLogic.Relational + +set_option maxRecDepth 100000 in +theorem relTriple_canonicalRetainedQueryTrace_prehit_last_reject + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + RelTriple (canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel) + (prehitRetainedQueryTrace adversary parameter table ftsSecret) + (fun left right => CanonicalQueryTraceRel parameter table left right ∧ + (left.1 = none → ∃ before entry, left.2 = before ++ [entry] ∧ + DeferredCompletable entry.table entry.context ∧ + CanonicalQueryRejects parameter right.1.1.1 ftsSecret entry)) := by + classical + let otsSecret := fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩) + let accountingKey := primitiveAccountingKey parameter otsSecret ftsSecret + have hroot := reachableResolvedCouples_maskedPublishedTreeRoot parameter table + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel emptySplitHashCache ∅ (resolvedContextInvariant_empty parameter table) + (visibleResolvedComputationsCached_empty parameter table emptyDeferredStructuralValues ∅) publishedValues_empty + have hsupported := FtsProbeSimulation.relTriple_and_left_support hroot + (fun left => left ∈ support (runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) (fun _ hsupport => hsupport) + have hprojection := TightEncoding.runEncodingPrehitMonitor_project accountingKey + (liftM (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : OracleComp HashSpec Digest) : + OracleComp OracleWorld Digest) ∅ false + rw [simulateQ_romImpl_liftM] at hprojection + have hmonitor := relTriple_of_evalDist_map_eq_general + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅) + (TightEncoding.runEncodingPrehitMonitor accountingKey + (liftM (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : OracleComp HashSpec Digest) : + OracleComp OracleWorld Digest) ∅ false) + id Prod.fst (by simpa only [id_map] using congrArg evalDist hprojection.symm) + unfold canonicalRetainedQueryTrace prehitRetainedQueryTrace + apply relTriple_bind (relTriple_trans_exists hsupported hmonitor) + rintro leftRoot rightRoot ⟨actualRoot, hrelation, heq⟩ + have hbase : ReachableResolvedRunRel parameter table leftRoot rightRoot.1 := heq ▸ hrelation.1 + cases leftRoot with + | none => exact False.elim (none_not_mem_resolved_maskedPublishedTreeRoot table fuel hrelation.2) + | some root => + have hcomplete := deferredCompletable_of_mem_resolved_maskedPublishedTreeRoot parameter table fuel root hrelation.2 + have hcomputed := deferredComputationsClosed_empty.of_mem_runResolved _ _ fuel table root hrelation.2 + dsimp only + rcases hbase with hclean | hdoomed + · have hcomplete' : DeferredCompletable table root.context := hclean.1 ▸ hcomplete + rw [hclean.1, ← hclean.2.1] + have htrace := relTriple_canonicalQueryTrace_prehitQueryTrace parameter root.value.1 table ftsSecret accountingKey + (retainedGameRestComputation adversary ⟨root.value.1, parameter⟩) root.context root.remaining root.value.2 + (⟨rightRoot.1.2, ⟨[], [], []⟩, [], none⟩, rightRoot.2) + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 hcomputed + have htraceSupported := FtsProbeSimulation.relTriple_and_left_support htrace + (fun left => left ∈ support (runCanonicalQueryTrace parameter root.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨root.value.1, parameter⟩) + root.context root.remaining table root.value.2)) (fun _ hsupport => hsupport) + have hmap := relTriple_map + (R := fun left right => CanonicalQueryTraceRel parameter table left right ∧ + (left.1 = none → ∃ before entry, left.2 = before ++ [entry] ∧ + DeferredCompletable entry.table entry.context ∧ + CanonicalQueryRejects parameter right.1.1.1 ftsSecret entry)) + (f := fun rest : Option (ResolvedRunResult (RetainedRestResult × SplitHashCache)) × List CanonicalQuerySelection => + (rest.1.map (retainedResultWithRoot root.value.1), rest.2)) + (g := fun rest : (RetainedRestResult × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot => + (((root.value.1, rest.1.1), rest.1.2), rest.2)) + (relTriple_post_mono htraceSupported (by + intro left right hrel + refine ⟨hrel.1.retainedRoot root.value.1, ?_⟩ + intro hnone + have hleftNone : left.1 = none := Option.map_eq_none_iff.mp hnone + exact last_query_rejects_of_canonicalTrace_none parameter root.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨root.value.1, parameter⟩) + root.context root.remaining table root.value.2 left.2 hcomplete' (by + simpa only [← hleftNone] using hrel.2))) + simpa only [map_eq_bind_pure_comp, Function.comp_def] using hmap + · exact False.elim (hdoomed.2.2.2 (hdoomed.1 ▸ hcomplete)) + +set_option maxRecDepth 100000 in +theorem relTriple_retainedVerifyProbe_last_reject_positive_fuel + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + RelTriple (canonicalRetainedQueryTrace adversary parameter table ftsSecret (q + 1)) + (prehitRetainedQueryTrace adversary parameter table ftsSecret) + (fun left right => CanonicalQueryTraceRel parameter table left right ∧ + (∀ entry ∈ left.2, 0 < entry.fuel) ∧ + (WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret + (right.1.1, right.1.2.1.cache) → + left.1 = none ∧ ∃ before entry, left.2 = before ++ [entry] ∧ 0 < entry.fuel ∧ + DeferredCompletable entry.table entry.context ∧ + CanonicalQueryRejects parameter right.1.1.1 ftsSecret entry)) := by + have hbase := relTriple_canonicalRetainedQueryTrace_prehit_last_reject adversary parameter table ftsSecret (q + 1) + have hleft := FtsProbeSimulation.relTriple_and_left_support hbase + (fun left => left ∈ support (canonicalRetainedQueryTrace adversary parameter table ftsSecret (q + 1))) + (fun _ hsupport => hsupport) + have hboth := FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro left right hrelation + have hpositive := positive_fuel_of_coupled_canonicalRetainedTrace adversary q hq parameter hparameter table + ftsSecret hfts left right hrelation.1.2 hrelation.2 hrelation.1.1.1 + refine ⟨hrelation.1.1.1, hpositive, ?_⟩ + intro hwitness + have hnone : left.1 = none := by + have hactual : (right.1.1, right.1.2.1.cache) ∈ support + (actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table)) := by + rw [← prehitRetainedQueryTrace_cache_projection, support_map] + exact ⟨right, hrelation.2, rfl⟩ + rcases left with ⟨option, history⟩ + cases option with + | none => rfl + | some result => + have hterminal := hrelation.1.1.1.1 + have hreachable : ReachableResolvedRunRel parameter table (some result) (right.1.1, right.1.2.1.cache) := + Or.inl ⟨hterminal.1, hterminal.2.1, hterminal.2.2.1, hterminal.2.2.2.1, hterminal.2.2.2.2.1⟩ + exact False.elim (not_winningRetainedVerifyProbe_of_canonicalRetainedTrace_relation adversary parameter table + ftsSecret (q + 1) result history right.1.1 right.1.2.1.cache hrelation.1.2 hactual hreachable hwitness) + obtain ⟨before, entry, hlast, hcomplete, hreject⟩ := hrelation.1.1.2 hnone + exact ⟨hnone, before, entry, hlast, hpositive entry (by rw [hlast]; simp), hcomplete, hreject⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalTraceSupport.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalTraceSupport.lean new file mode 100644 index 00000000..18e3ca6a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalTraceSupport.lean @@ -0,0 +1,264 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalRetainedTrace + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +set_option maxRecDepth 100000 in +theorem mem_support_raw_of_synchronizedCanonicalRom + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp OracleWorld α) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) (result : ResolvedRunResult (α × SplitHashCache)) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcanonical : CanonicalMaterializedValues table context) (hpublished : PublishedValues context.state) + (hresult : some result ∈ support (runSynchronizedResolved + (fun query => canonicalChronologicalAdversaryImpl parameter root table ftsSecret (.inl query)) + computation context fuel table cache)) : + some result ∈ support (runResolvedFromTable context fuel table ((simulateQ (probingRomImpl parameter) computation).run cache)) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + by_cases hcomplete : DeferredCompletable table context + · rw [runSynchronizedResolved_pure _ value context fuel table cache hcomplete] at hresult + simpa [simulateQ_pure, runResolvedFromTable] using hresult + · rw [runSynchronizedResolved_pure_of_not_completable _ value context fuel table cache hcomplete] at hresult + simp at hresult + | query_bind input next ih => + rw [runSynchronizedResolved, OracleComp.construct_query_bind] at hresult + by_cases hcomplete : DeferredCompletable table context + · simp only [dif_pos hcomplete, mem_support_bind_iff] at hresult + obtain ⟨stepOption, hstep, htail⟩ := hresult + have hraw := (mem_support_iff_of_evalDist_eq + (evalDist_canonicalChronologicalAdversaryImpl_oracle_eq_raw parameter root ftsSecret input context fuel table cache + hconsistent hstarts hcanonical hpublished) stepOption).mp hstep + cases stepOption with + | none => simp at htail + | some step => + have hcore := resolvedCore_of_mem_runResolvedFromTable ((probingRomImpl parameter input).run cache) + context fuel table step hconsistent hstarts hraw + have hnextCanonical := canonicalMaterializedValues_of_mem_probingRomImpl parameter input context fuel table cache + step hconsistent hstarts hcanonical hpublished hraw + have hnextPublished := resolvedPreservesPublishedValuesImpl_probingRomImpl parameter input context cache fuel table + step hpublished hraw + change some result ∈ support (runSynchronizedResolved + (fun query => canonicalChronologicalAdversaryImpl parameter root table ftsSecret (.inl query)) + (next step.value.1) step.context step.remaining step.table step.value.2) at htail + rw [hcore.1] at htail + rw [simulateQ_query_bind, StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] + refine ⟨some step, hraw, ?_⟩ + dsimp only + rw [hcore.1] + exact ih step.value.1 step.context step.remaining step.value.2 hcore.2.1 hcore.2.2 hnextCanonical hnextPublished htail + · simp [hcomplete] at hresult + +set_option maxRecDepth 100000 in +theorem deferredCompletable_of_mem_synchronized + (impl : ResolvedQueryImpl spec) (computation : OracleComp spec α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) + (hresult : some result ∈ support (runSynchronizedResolved impl computation context fuel table cache)) : + DeferredCompletable result.table result.context := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => + by_cases hcomplete : DeferredCompletable table context + · rw [runSynchronizedResolved_pure impl value context fuel table cache hcomplete] at hresult + simp only [mem_support_pure_iff, Option.some.injEq] at hresult + subst result + exact hcomplete + · rw [runSynchronizedResolved_pure_of_not_completable impl value context fuel table cache hcomplete] at hresult + simp at hresult + | query_bind input next ih => + rw [runSynchronizedResolved, OracleComp.construct_query_bind] at hresult + split_ifs at hresult + · rw [mem_support_bind_iff] at hresult + obtain ⟨stepOption, _hstep, htail⟩ := hresult + cases stepOption with + | none => simp at htail + | some step => exact ih step.value.1 step.context step.remaining step.table step.value.2 htail + · simp at hresult + +theorem mem_support_synchronized_of_canonicalQueryTrace + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hresult : result ∈ support (runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache)) : + result.1 ∈ support (runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + computation context fuel table cache) := by + apply (mem_support_iff_of_evalDist_eq (runCanonicalQueryTrace_synchronized_projection parameter root ftsSecret + computation context fuel table cache hconsistent hstarts) result.1).mp + rw [support_map] + exact ⟨result, hresult, rfl⟩ + +theorem mem_support_runResolved_map_value + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (mapValue : α → β) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hresult : some result ∈ support (runResolvedFromTable context fuel table computation)) : + some (ResolvedRunResult.mk result.context result.remaining (mapValue result.value) result.table) ∈ + support (runResolvedFromTable context fuel table (mapValue <$> computation)) := by + rw [map_eq_bind_pure_comp, runResolvedFromTable_bind, mem_support_bind_iff] + refine ⟨some result, hresult, ?_⟩ + simp [runResolvedFromTable] + +theorem mem_support_canonicalVerifierFinish_of_rest + (parameter : PublicParameter) (root : Digest) (forgeryLog : Forgery × QueryLog SigningSpec) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (RetainedRestResult × SplitHashCache)) + (hresult : some result ∈ support (runResolvedFromTable context fuel table + ((simulateQ (probingRomImpl parameter) (do + let verified ← scheme.verify ⟨root, parameter⟩ forgeryLog.1.message forgeryLog.1.signature + pure (forgeryLog, verified))).run cache))) : + some (retainedResultWithRoot root result) ∈ support + (runResolvedFromTable context fuel table ((canonicalVerifierFinish parameter root forgeryLog).run cache)) := by + have hmap := mem_support_runResolved_map_value _ (fun value : RetainedRestResult × SplitHashCache => + ((root, value.1), value.2)) context fuel table result hresult + simpa only [retainedResultWithRoot, canonicalVerifierFinish, simulateQ_bind, simulateQ_pure, + StateT.run_bind, StateT.run_pure, map_bind, map_pure] using hmap + +set_option maxRecDepth 100000 in +theorem mem_support_split_of_synchronizedCanonicalRetainedRest + (adversary : Adversary) (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (result : ResolvedRunResult (RetainedRestResult × SplitHashCache)) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) (hcanonical : CanonicalMaterializedValues table context) + (hresult : some result ∈ support (runSynchronizedResolved + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (retainedGameRestComputation adversary ⟨root, parameter⟩) context fuel table cache)) : + some (retainedResultWithRoot root result) ∈ support (do + let step ← runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) context fuel table cache + canonicalVerifierContinuation parameter root step) := by + unfold retainedGameRestComputation at hresult + rw [runSynchronizedResolved_bind, mem_support_bind_iff] at hresult + obtain ⟨stepOption, hstep, htail⟩ := hresult + cases stepOption with + | none => simp at htail + | some step => + have hcore := resolvedCore_of_mem_runSynchronizedResolved_canonicalChronological parameter root table ftsSecret + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) context fuel cache step + hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hstep + have hnextCanonical := canonicalMaterializedValues_of_mem_synchronizedCanonical parameter root ftsSecret + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) context fuel table cache step + hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hcanonical hstep + have hrel := relTriple_runSynchronizedResolved_reachable + (canonicalReachableResolvedImplCouples_chronologicalAdversaryImpl parameter root table ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) context fuel cache actualCache hinvariant hvisible hpublished + obtain ⟨actual, _hactual, hrelation⟩ := exists_right_of_relTriple_of_mem_support hrel hstep + dsimp only at htail + rw [hcore.1] at htail + rcases hrelation with hclean | hdoomed + · have hlift : liftOracleWorldLeft (do + let verified ← scheme.verify ⟨root, parameter⟩ step.value.1.1.message step.value.1.1.signature + pure (step.value.1, verified)) = (do + let verified ← liftOracleWorldLeft + (scheme.verify ⟨root, parameter⟩ step.value.1.1.message step.value.1.1.signature) + pure ((step.value.1.1, step.value.1.2), verified)) := by + simp only [liftOracleWorldLeft, liftM_bind, liftM_pure] + rw [← hlift, runSynchronizedResolved_liftOracleWorldLeft] at htail + have hraw := mem_support_raw_of_synchronizedCanonicalRom parameter root ftsSecret _ step.context step.remaining + table step.value.2 result hcore.2.1 hcore.2.2 hnextCanonical hclean.2.2.2.2 htail + rw [mem_support_bind_iff] + refine ⟨some step, hstep, ?_⟩ + dsimp only [canonicalVerifierContinuation] + rw [hcore.1] + exact mem_support_canonicalVerifierFinish_of_rest parameter root step.value.1 step.context step.remaining + table step.value.2 result hraw + · rw [runSynchronizedResolved_of_not_completable _ _ step.context step.remaining table step.value.2 hdoomed.2.2.2] at htail + simp at htail + +set_option maxRecDepth 100000 in +theorem canonicalChronologicalSupported_of_root_and_retainedTrace + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (rootResult : ResolvedRunResult (Digest × SplitHashCache)) + (result : ResolvedRunResult (RetainedRestResult × SplitHashCache)) (history : List CanonicalQuerySelection) + (hroot : some rootResult ∈ support (runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) + (htrace : (some result, history) ∈ support (runCanonicalQueryTrace parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.context rootResult.remaining rootResult.table rootResult.value.2)) : + CanonicalChronologicalSupported adversary parameter table ftsSecret fuel + (retainedResultWithRoot rootResult.value.1 result) := by + have hcore := resolvedCore_of_mem_runResolved_maskedPublishedTreeRoot parameter table fuel rootResult hroot + rw [hcore.1] at htrace + have hrun := mem_support_synchronized_of_canonicalQueryTrace parameter rootResult.value.1 ftsSecret _ rootResult.context + rootResult.remaining table rootResult.value.2 (some result, history) hcore.2.1 hcore.2.2 htrace + dsimp only at hrun + have hcanonical := canonicalMaterializedValues_of_mem_maskedPublishedTreeRoot parameter table fuel rootResult hroot + have hrel := reachableResolvedCouples_maskedPublishedTreeRoot parameter table + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel emptySplitHashCache ∅ (resolvedContextInvariant_empty parameter table) + (visibleResolvedComputationsCached_empty parameter table emptyDeferredStructuralValues ∅) publishedValues_empty + obtain ⟨actual, _hactual, hrelation⟩ := exists_right_of_relTriple_of_mem_support hrel hroot + rcases hrelation with hclean | hdoomed + · unfold CanonicalChronologicalSupported canonicalChronologicalRetainedRunAfterFtsSecrets + rw [mem_support_bind_iff] + refine ⟨some rootResult, hroot, ?_⟩ + dsimp only + rw [hcore.1] + exact mem_support_split_of_synchronizedCanonicalRetainedRest adversary parameter rootResult.value.1 table ftsSecret + rootResult.context rootResult.remaining rootResult.value.2 actual.2 result hclean.2.2.1 hclean.2.2.2.1 + hclean.2.2.2.2 hcanonical hrun + · rw [runSynchronizedResolved_of_not_completable _ _ rootResult.context rootResult.remaining table rootResult.value.2 + hdoomed.2.2.2] at hrun + simp at hrun + +theorem supported_and_completable_of_mem_canonicalRetainedTrace + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (result : ResolvedRunResult (RetainedGameResult × SplitHashCache)) (history : List CanonicalQuerySelection) + (htrace : (some result, history) ∈ support (canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel)) : + CanonicalChronologicalSupported adversary parameter table ftsSecret fuel result ∧ + DeferredCompletable result.table result.context := by + unfold canonicalRetainedQueryTrace at htrace + rw [mem_support_bind_iff] at htrace + obtain ⟨rootOption, hroot, hrest⟩ := htrace + cases rootOption with + | none => simp at hrest + | some rootResult => + rw [mem_support_bind_iff] at hrest + obtain ⟨⟨restOption, restHistory⟩, hrest, hreturn⟩ := hrest + cases restOption with + | none => simp at hreturn + | some rest => + simp only [Option.map_some, mem_support_pure_iff, Prod.mk.injEq, Option.some.injEq] at hreturn + obtain ⟨rfl, rfl⟩ := hreturn + refine ⟨canonicalChronologicalSupported_of_root_and_retainedTrace adversary parameter table ftsSecret fuel + rootResult rest history hroot hrest, ?_⟩ + have hcore := resolvedCore_of_mem_runResolved_maskedPublishedTreeRoot parameter table fuel rootResult hroot + rw [hcore.1] at hrest + have hrun := mem_support_synchronized_of_canonicalQueryTrace parameter rootResult.value.1 ftsSecret _ rootResult.context + rootResult.remaining table rootResult.value.2 (some rest, history) hcore.2.1 hcore.2.2 hrest + exact deferredCompletable_of_mem_synchronized _ _ _ _ _ _ rest hrun + +theorem not_winningRetainedVerifyProbe_of_canonicalRetainedTrace_relation + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (result : ResolvedRunResult (RetainedGameResult × SplitHashCache)) (history : List CanonicalQuerySelection) + (actualValue : RetainedGameResult) (actualCache : QueryCache HashSpec) + (htrace : (some result, history) ∈ support (canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel)) + (hactual : (actualValue, actualCache) ∈ support + (actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table))) + (hrelation : ReachableResolvedRunRel parameter table (some result) (actualValue, actualCache)) : + ¬WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret (actualValue, actualCache) := by + intro hwitness + obtain ⟨hsupported, hcomplete⟩ := supported_and_completable_of_mem_canonicalRetainedTrace adversary parameter table ftsSecret + fuel result history htrace + have hnot := not_deferredCompletable_of_winningRetainedVerifyProbe_canonical adversary parameter table ftsSecret fuel result + actualValue actualCache hsupported hactual hrelation hwitness + have htable : result.table = table := by + rcases hrelation with hclean | hdoomed + · exact hclean.1 + · exact hdoomed.1 + exact hnot (htable ▸ hcomplete) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalVerifierTrace.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalVerifierTrace.lean new file mode 100644 index 00000000..19f7efbc --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalVerifierTrace.lean @@ -0,0 +1,130 @@ +import SphincsSecurity.Proof.OtsProbePublicHashValues +import SphincsSecurity.Proof.OtsProbeQueryTraceProjection + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem canonicalMaterializedValues_of_mem_probingRomImpl + (parameter : PublicParameter) (query : OracleWorld.Domain) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (OracleWorld.Range query × SplitHashCache)) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcanonical : CanonicalMaterializedValues table context) (hpublished : PublishedValues context.state) + (hresult : some result ∈ support (runResolvedFromTable context fuel table ((probingRomImpl parameter query).run cache))) : + CanonicalMaterializedValues table result.context := by + have hcore := resolvedCore_of_mem_runResolvedFromTable ((probingRomImpl parameter query).run cache) + context fuel table result hconsistent hstarts hresult + exact canonicalMaterializedValues_of_public + (resolvedPreservesPublicMaterialization_probingRomImpl parameter query context cache fuel table result + (.of_canonical hcanonical) hresult) + (resolvedPreservesPublishedValuesImpl_probingRomImpl parameter query context cache fuel table result hpublished hresult) + hcore.2.2 + +theorem evalDist_canonicalChronologicalAdversaryImpl_oracle_eq_raw + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : OracleWorld.Domain) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcanonical : CanonicalMaterializedValues table context) (hpublished : PublishedValues context.state) : + evalDist (canonicalChronologicalAdversaryImpl parameter root table ftsSecret (.inl query) context fuel table cache) = + evalDist (runResolvedFromTable context fuel table ((probingRomImpl parameter query).run cache)) := by + unfold canonicalChronologicalAdversaryImpl + conv_rhs => rw [← bind_pure (runResolvedFromTable context fuel table ((probingRomImpl parameter query).run cache))] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hcanonicalResult := canonicalMaterializedValues_of_mem_probingRomImpl parameter query context fuel table cache + result hconsistent hstarts hcanonical hpublished hresult + simp only [canonicalizeResolvedRun, canonicalizeMaterializedValues_eq_of_canonical table result.context hcanonicalResult] + rfl + +set_option maxRecDepth 100000 in +theorem runSynchronizedResolved_liftOracleWorldLeft + (impl : ResolvedQueryImpl (OracleWorld + SigningSpec)) (computation : OracleComp OracleWorld α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runSynchronizedResolved impl (liftOracleWorldLeft computation) context fuel table cache = + runSynchronizedResolved (fun query => impl (.inl query)) computation context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => rfl + | query_bind input next ih => + change runSynchronizedResolved impl ((liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) (.inl input)) : + OracleComp (OracleWorld + SigningSpec) (OracleWorld.Range input)) >>= fun value => liftOracleWorldLeft (next value)) + context fuel table cache = _ + rw [runSynchronizedResolved, OracleComp.construct_query_bind, + runSynchronizedResolved, OracleComp.construct_query_bind] + split_ifs + · apply bind_congr + intro result + cases result with + | none => rfl + | some result => exact ih result.value.1 result.context result.remaining result.table result.value.2 + · rfl + +set_option maxRecDepth 100000 in +theorem evalDist_synchronizedCanonicalRom_finish_eq_raw + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp OracleWorld α) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcanonical : CanonicalMaterializedValues table context) (hpublished : PublishedValues context.state) : + evalDist (runSynchronizedResolved + (fun query => canonicalChronologicalAdversaryImpl parameter root table ftsSecret (.inl query)) + computation context fuel table cache >>= finishResolvedRunIsNone) = + evalDist (runResolvedFromTable context fuel table ((simulateQ (probingRomImpl parameter) computation).run cache) >>= + finishResolvedRunIsNone) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + by_cases hcomplete : DeferredCompletable table context + · rw [runSynchronizedResolved_pure _ value context fuel table cache hcomplete] + simp [simulateQ_pure, runResolvedFromTable] + · rw [runSynchronizedResolved_pure_of_not_completable _ value context fuel table cache hcomplete] + simp [simulateQ_pure, runResolvedFromTable, finishResolvedRunIsNone, finishResolvedRun, hcomplete] + | query_bind input next ih => + by_cases hcomplete : DeferredCompletable table context + · rw [runSynchronizedResolved, OracleComp.construct_query_bind] + simp only [dif_pos hcomplete, bind_assoc] + rw [simulateQ_query_bind, StateT.run_bind, runResolvedFromTable_bind, bind_assoc] + rw [evalDist_bind, evalDist_canonicalChronologicalAdversaryImpl_oracle_eq_raw parameter root ftsSecret input + context fuel table cache hconsistent hstarts hcanonical hpublished, ← evalDist_bind] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => simp + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable ((probingRomImpl parameter input).run cache) + context fuel table result hconsistent hstarts hresult + have hnextCanonical := canonicalMaterializedValues_of_mem_probingRomImpl parameter input context fuel table cache + result hconsistent hstarts hcanonical hpublished hresult + have hnextPublished := resolvedPreservesPublishedValuesImpl_probingRomImpl parameter input context cache fuel table + result hpublished hresult + dsimp only + rw [hcore.1] + exact ih result.value.1 result.context result.remaining result.value.2 hcore.2.1 hcore.2.2 + hnextCanonical hnextPublished + · rw [runSynchronizedResolved_of_not_completable _ _ context fuel table cache hcomplete] + simp only [pure_bind, finishResolvedRunIsNone, finishResolvedRun, map_pure, Option.isNone_none] + exact (evalDist_runResolvedFinishIsNone_eq_true_of_not_completable context fuel table _ + hconsistent hstarts hcomplete).symm + +theorem evalDist_canonicalQueryTrace_oracle_finish_eq_raw + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp OracleWorld α) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcanonical : CanonicalMaterializedValues table context) (hpublished : PublishedValues context.state) : + evalDist (runCanonicalQueryTrace parameter root ftsSecret (liftOracleWorldLeft computation) context fuel table cache >>= + fun result => finishResolvedRunIsNone result.1) = + evalDist (runResolvedFromTable context fuel table ((simulateQ (probingRomImpl parameter) computation).run cache) >>= + finishResolvedRunIsNone) := by + rw [runCanonicalQueryTrace_observer_projection parameter root ftsSecret _ context fuel table cache _ hconsistent hstarts, + runSynchronizedResolved_liftOracleWorldLeft] + exact evalDist_synchronizedCanonicalRom_finish_eq_raw parameter root ftsSecret computation context fuel table cache + hconsistent hstarts hcanonical hpublished + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalWeightedCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalWeightedCharge.lean new file mode 100644 index 00000000..7728f8f6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCanonicalWeightedCharge.lean @@ -0,0 +1,223 @@ +import SphincsSecurity.Proof.OtsProbeHashCutCharge +import SphincsSecurity.Proof.OtsProbeCanonicalChargeSampled + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def unresolvedPositionCandidateCharge (context : DeferredContext) : Option Probe → ENNReal + | some candidate@⟨.position _, _⟩ => + (unmaterializedCandidateCharge (materializedDeferredState context) (some candidate) : ENNReal) + | _ => 0 + +theorem unresolvedCandidateCharges_sum + (context : DeferredContext) (candidate : Option Probe) : + unresolvedStartCandidateCharge context candidate + unresolvedPositionCandidateCharge context candidate = + (unmaterializedCandidateCharge (materializedDeferredState context) candidate : ENNReal) := by + cases candidate with + | none => simp [unresolvedStartCandidateCharge, unresolvedPositionCandidateCharge, unmaterializedCandidateCharge] + | some candidate => + rcases candidate with ⟨coordinate, digest⟩ + cases coordinate with + | position position => simp [unresolvedStartCandidateCharge, unresolvedPositionCandidateCharge] + | chainStart lay tree leafIdx chainIdx => + by_cases hmissing : context.state.values (.chainStart lay tree leafIdx chainIdx) = none + · simp [unresolvedStartCandidateCharge, unresolvedPositionCandidateCharge, hmissing] + · simp [unresolvedStartCandidateCharge, unresolvedPositionCandidateCharge, hmissing, + unmaterializedCandidateCharge, LazyRevealProbe.pendingProbeCharge, materializedDeferredState] + +noncomputable def canonicalWeightedHashCharge + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) : ENNReal := + (unmaterializedCandidateCharge (materializedDeferredState context) + (purePlanProbingHashQuery parameter input context.state).candidate? : ENNReal) * (4 / 3) + + (materializedCandidateCharge (materializedDeferredState context) + (rootAwarePlannedCandidate? parameter input context.state) : ENNReal) * (4 / 3) + +noncomputable def canonicalWeightedOuterCharge (parameter : PublicParameter) : + (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal + | .inl (.inr input), context, _, _ => canonicalWeightedHashCharge parameter input context + | _, _, _, _ => 0 + +theorem weighted_candidate_components_le + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) : + unresolvedStartCandidateCharge context (purePlanProbingHashQuery parameter input context.state).candidate? * (4 / 3) + + unresolvedPositionCandidateCharge context (purePlanProbingHashQuery parameter input context.state).candidate? + + (materializedCandidateCharge (materializedDeferredState context) + (rootAwarePlannedCandidate? parameter input context.state) : ENNReal) * (4 / 3) ≤ + canonicalWeightedHashCharge parameter input context := by + unfold canonicalWeightedHashCharge + rw [← unresolvedCandidateCharges_sum, add_mul] + apply add_le_add _ le_rfl + apply add_le_add le_rfl + apply le_mul_of_one_le_right' + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + norm_num + +theorem canonicalWeightedHashCharge_le_canonicalOtsHashCharge + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) : + canonicalWeightedHashCharge parameter input context ≤ canonicalOtsHashCharge parameter input context := by + unfold canonicalWeightedHashCharge canonicalOtsHashCharge + split_ifs with hots + · have hsum : + unmaterializedCandidateCharge (materializedDeferredState context) + (purePlanProbingHashQuery parameter input context.state).candidate? + + materializedCandidateCharge (materializedDeferredState context) + (rootAwarePlannedCandidate? parameter input context.state) ≤ 1 := by + cases hcandidate : (purePlanProbingHashQuery parameter input context.state).candidate? with + | none => + have h := candidateCharge_sum_le_one (materializedDeferredState context) (rootAwarePlannedCandidate? parameter input context.state) + simpa only [unmaterializedCandidateCharge, Nat.zero_add] using (Nat.le_add_left _ _).trans h + | some candidate => + rw [rootAwarePlannedCandidate?_eq_of_plan_some hcandidate] + exact candidateCharge_sum_le_one _ _ + rw [← add_mul, ← Nat.cast_add] + simpa only [Nat.cast_one, one_mul] using mul_le_mul' (Nat.cast_le.mpr hsum : + ((unmaterializedCandidateCharge (materializedDeferredState context) + (purePlanProbingHashQuery parameter input context.state).candidate? + + materializedCandidateCharge (materializedDeferredState context) + (rootAwarePlannedCandidate? parameter input context.state) : Nat) : ENNReal) ≤ (1 : Nat)) + (le_refl (4 / 3 : ENNReal)) + · have hnone := purePlan_candidate_none_of_not_atOtsPosition parameter input context.state hots + simp [hnone, unmaterializedCandidateCharge, rootAwarePlannedCandidate?] + +theorem canonicalWeightedOuterCharge_le_ots (parameter : PublicParameter) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + canonicalWeightedOuterCharge parameter input context fuel cache ≤ canonicalOtsOuterCharge parameter input context fuel cache := by + cases input with + | inl input => + cases input with + | inl n => exact le_rfl + | inr input => exact canonicalWeightedHashCharge_le_canonicalOtsHashCharge parameter input context + | inr message => exact le_rfl + +theorem expectedCanonicalQueryCharge_mono + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (left right : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (hle : ∀ input context fuel cache, left input context fuel cache ≤ right input context fuel cache) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + expectedCanonicalQueryCharge parameter root ftsSecret left computation context fuel table cache ≤ + expectedCanonicalQueryCharge parameter root ftsSecret right computation context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => rfl + | query_bind input next ih => + rw [expectedCanonicalQueryCharge_query_bind, expectedCanonicalQueryCharge_query_bind] + split_ifs + · apply add_le_add (hle input context fuel cache) + apply ENNReal.tsum_le_tsum + intro option + cases option with + | none => exact le_rfl + | some result => + exact mul_le_mul' le_rfl (ih result.value.1 result.context result.remaining result.table result.value.2) + · exact le_rfl + +theorem expectedCanonicalWeightedCharge_le_actualReserve + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + expectedCanonicalQueryCharge parameter root ftsSecret (canonicalWeightedOuterCharge parameter) + computation context fuel table cache ≤ + expectedQueryCharge + (otsOpeningRefinedQueryReserve + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey)) + (simulateQ (expandedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey)) computation) actualCache := by + exact (expectedCanonicalQueryCharge_mono parameter root ftsSecret (canonicalWeightedOuterCharge parameter) + (canonicalOtsOuterCharge parameter) (canonicalWeightedOuterCharge_le_ots parameter) + computation context fuel table cache).trans + (expectedCanonicalOtsCharge_le_actualReserve parameter root table ftsSecret computation context fuel cache actualCache + hinvariant hvisible hpublished hcomputed) + +noncomputable def unresolvedPositionOuterCharge (parameter : PublicParameter) : + (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal + | .inl (.inr input), context, _, _ => + unresolvedPositionCandidateCharge context (purePlanProbingHashQuery parameter input context.state).candidate? + | _, _, _, _ => 0 + +noncomputable def materializedOuterCandidateCharge (parameter : PublicParameter) : + (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal + | .inl (.inr input), context, _, _ => + (materializedCandidateCharge (materializedDeferredState context) + (rootAwarePlannedCandidate? parameter input context.state) : ENNReal) + | _, _, _, _ => 0 + +noncomputable def canonicalComponentOuterCharge (parameter : PublicParameter) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : ENNReal := + unresolvedStartOuterCharge parameter input context fuel cache * (4 / 3) + + unresolvedPositionOuterCharge parameter input context fuel cache + + materializedOuterCandidateCharge parameter input context fuel cache * (4 / 3) + +theorem canonicalComponentOuterCharge_le_weighted (parameter : PublicParameter) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + canonicalComponentOuterCharge parameter input context fuel cache ≤ canonicalWeightedOuterCharge parameter input context fuel cache := by + cases input with + | inl input => + cases input with + | inl n => simp [canonicalComponentOuterCharge, unresolvedStartOuterCharge, unresolvedPositionOuterCharge, + materializedOuterCandidateCharge, canonicalWeightedOuterCharge] + | inr input => exact weighted_candidate_components_le parameter input context + | inr message => simp [canonicalComponentOuterCharge, unresolvedStartOuterCharge, unresolvedPositionOuterCharge, + materializedOuterCandidateCharge, canonicalWeightedOuterCharge] + +theorem expectedCanonicalQueryCharge_add + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (left right : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + expectedCanonicalQueryCharge parameter root ftsSecret + (fun input context fuel cache => left input context fuel cache + right input context fuel cache) + computation context fuel table cache = + expectedCanonicalQueryCharge parameter root ftsSecret left computation context fuel table cache + + expectedCanonicalQueryCharge parameter root ftsSecret right computation context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => simp [expectedCanonicalQueryCharge] + | query_bind input next ih => + rw [expectedCanonicalQueryCharge_query_bind, expectedCanonicalQueryCharge_query_bind, expectedCanonicalQueryCharge_query_bind] + split_ifs with hcomplete + · conv_rhs => rw [add_add_add_comm] + congr 1 + rw [← ENNReal.tsum_add] + apply tsum_congr + intro option + cases option with + | none => simp + | some result => + dsimp only + rw [ih result.value.1 result.context result.remaining result.table result.value.2, mul_add] + · simp + +theorem expectedCanonicalQueryCharge_mul + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) (factor : ENNReal) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + expectedCanonicalQueryCharge parameter root ftsSecret + (fun input context fuel cache => charge input context fuel cache * factor) computation context fuel table cache = + expectedCanonicalQueryCharge parameter root ftsSecret charge computation context fuel table cache * factor := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => simp [expectedCanonicalQueryCharge] + | query_bind input next ih => + rw [expectedCanonicalQueryCharge_query_bind, expectedCanonicalQueryCharge_query_bind] + split_ifs + · rw [add_mul, ← ENNReal.tsum_mul_right] + congr 1 + apply tsum_congr + intro option + cases option with + | none => simp + | some result => + dsimp only + rw [ih result.value.1 result.context result.remaining result.table result.value.2, mul_assoc] + · simp + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootAdaptiveRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootAdaptiveRisk.lean new file mode 100644 index 00000000..c7218e96 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootAdaptiveRisk.lean @@ -0,0 +1,125 @@ +import SphincsSecurity.Proof.OtsProbeChargedRootCutRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem probEvent_finishNativeRootHistoryTrace_charged_of_stored + (parameter : PublicParameter) (root : Digest) (target : Position) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) (OuterQueryCut α)) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (event : HashOutput × Option Digest → Prop) (hnone : ∀ output, ¬event (output, none)) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (output : HashOutput) (hknown : context.positionValue target = some output) + (trace : Option (ResolvedRunResult (OuterQueryCut α × SplitHashCache)) × List CanonicalQuerySelection) + (htrace : trace ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) : + Pr[fun b => b = false | finishNativeRootHistoryTrace parameter target table (observeChargedRootCut parameter target event) initialHistory trace] = + Pr[event | (pure (output, if truncateHash output ∉ initialHistory ∧ NativeRootTraceCompatible parameter target output output trace then + chargedNativeRootTraceCutCandidate parameter target trace.1 else none) : ProbComp (HashOutput × Option Digest))] := by + rcases trace with ⟨option, history⟩ + cases option with + | none => simp [finishNativeRootHistoryTrace, NativeRootTraceCompatible, probEvent_pure, hnone] + | some result => + rw [finishNativeRootHistoryTrace_charged_of_stored parameter root target ftsSecret computation context fuel table cache initialHistory event + hconsistent hstarts output hknown result history htrace] + by_cases hhidden : .position target ∉ result.context.state.revealed <;> + by_cases hinitial : truncateHash output ∉ initialHistory <;> + by_cases hhistory : truncateHash output ∉ nativeRootCandidateHistory parameter target history <;> + by_cases hevent : event (output, chargedNativeRootCutCandidate parameter target result.context result.value.1) <;> + simp [NativeRootTraceCompatible, chargedNativeRootTraceCutCandidate, probEvent_pure, Finset.mem_union, + hhidden, hinitial, hhistory, hevent, hnone] + +noncomputable def originalChargedRootCutObservation + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (ordinal : Nat) (event : HashOutput × Option Digest → Prop) : ProbComp Bool := + runNativeQueryTrace parameter root ftsSecret (outerHashQueryCutAt computation ordinal) context fuel table cache >>= + finishNativeRootHistoryTrace parameter target table (observeChargedRootCut parameter target event) initialHistory + +theorem probEvent_originalChargedRootCutObservation_eq_sampled + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (ordinal : Nat) (event : HashOutput × Option Digest → Prop) (hnone : ∀ output, ¬event (output, none)) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hpending : context.state.pendingAt (.position target) ⊆ initialHistory) : + Pr[fun b => b = false | originalChargedRootCutObservation parameter root target ftsSecret computation context fuel table cache initialHistory ordinal event] = + Pr[event | sampleChargedNativeRootCut parameter root target ftsSecret computation + (clearNativeRootPending target context) fuel table cache initialHistory ordinal] := by + have hdist := evalDist_nativeHistoryTrace_eq_uniform parameter root target ftsSecret table (observeChargedRootCut parameter target event) + (outerHashQueryCutAt computation ordinal) context fuel cache initialHistory hvalid hcomplete hensured hstate hvalue + rw [probEvent_eq_eq_probOutput, originalChargedRootCutObservation, _root_.OracleComp.probOutput_congr rfl hdist, + ← probEvent_eq_eq_probOutput, sampleChargedNativeRootCut, probEvent_bind_eq_tsum, probEvent_bind_eq_tsum] + apply tsum_congr + intro output + congr 1 + by_cases hhit : context.state.hitAt (.position target) output + · have hinitial := hpending hhit + simp [hhit, hinitial, probEvent_pure, hnone] + · simp only [if_neg hhit] + have hreplace := replaceNativePosition_clearPending_eq_completePrivatePosition target output context hstate + rw [hreplace] + let stored := (completePrivatePosition target context output).toDeferredContext + change Pr[fun b => b = false | runNativeQueryTrace parameter root ftsSecret (outerHashQueryCutAt computation ordinal) stored fuel table cache >>= _] = _ + have hbase : (clearNativeRootPending target context).ValuesConsistent := hvalid.valuesConsistent + have hconsistent : stored.ValuesConsistent := by + change (completePrivatePosition target context output).toDeferredContext.ValuesConsistent + rw [← hreplace] + exact hbase.of_replaceNativePosition target output + have hstarts : StartTableAgrees stored.state table := (show StartTableAgrees context.state table from startTableAgrees_of_deferredCompletable hcomplete) + have hknown : stored.positionValue target = some output := by + simp [stored, completePrivatePosition, DeferredContext.positionValue, hstate, DeferredStructuralValues.install] + by_cases hinitial : truncateHash output ∈ initialHistory + · rw [if_pos hinitial, probEvent_bind_eq_tsum] + simp only [probEvent_pure, hnone, ↓reduceIte] + apply ENNReal.tsum_eq_zero.mpr + intro trace + by_cases htrace : trace ∈ support (runNativeQueryTrace parameter root ftsSecret (outerHashQueryCutAt computation ordinal) stored fuel table cache) + · rw [probEvent_finishNativeRootHistoryTrace_charged_of_stored parameter root target ftsSecret _ stored fuel table cache initialHistory event hnone + hconsistent hstarts output hknown trace htrace] + simp [hinitial, probEvent_pure, hnone] + · dsimp only [stored] at htrace ⊢ + simp only [probOutput_eq_zero_of_not_mem_support htrace, zero_mul] + · rw [if_neg hinitial, probEvent_bind_eq_tsum, probEvent_bind_eq_tsum] + apply tsum_congr + intro trace + by_cases htrace : trace ∈ support (runNativeQueryTrace parameter root ftsSecret (outerHashQueryCutAt computation ordinal) stored fuel table cache) + · rw [probEvent_finishNativeRootHistoryTrace_charged_of_stored parameter root target ftsSecret _ stored fuel table cache initialHistory event hnone + hconsistent hstarts output hknown trace htrace] + simp only [hinitial, not_false_eq_true, true_and] + rfl + · dsimp only [stored] at htrace ⊢ + simp only [probOutput_eq_zero_of_not_mem_support htrace, zero_mul] + +theorem probEvent_originalChargedRootCutObservation_hit_le_occurrence + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hpending : context.state.pendingAt (.position target) ⊆ initialHistory) + (hcache : ∀ digest, digest ∉ initialHistory → NoEncodingRootGuessCached parameter target digest cache) + (ordinal : Nat) (hbudget : initialHistory.card + ordinal ≤ 2 ^ 126) : + Pr[fun b => b = false | originalChargedRootCutObservation parameter root target ftsSecret computation + context fuel table cache initialHistory ordinal (fun pair => pair.2 = some (truncateHash pair.1))] ≤ + Pr[fun b => b = false | originalChargedRootCutObservation parameter root target ftsSecret computation + context fuel table cache initialHistory ordinal (fun pair => pair.2 ≠ none)] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + rw [probEvent_originalChargedRootCutObservation_eq_sampled parameter root target ftsSecret computation + context fuel table cache initialHistory ordinal _ (by simp) hvalid hcomplete hensured hstate hvalue hpending, + probEvent_originalChargedRootCutObservation_eq_sampled parameter root target ftsSecret computation + context fuel table cache initialHistory ordinal _ (by simp) hvalid hcomplete hensured hstate hvalue hpending] + apply probEvent_sampleChargedNativeRootCut_hit_le_occurrence parameter root target hroot ftsSecret computation + (clearNativeRootPending target context) fuel table cache initialHistory hvalid.valuesConsistent _ hcache ordinal hbudget + intro digest hmem + exact False.elim (not_hitAt_clearPending_self context.state (.position target) (hashOutputOfDigest digest) + (by simpa only [clearNativeRootPending, LazyRevealProbe.State.hitAt, truncateHash_hashOutputOfDigest] using hmem)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootCounting.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootCounting.lean new file mode 100644 index 00000000..e7efacfb --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootCounting.lean @@ -0,0 +1,90 @@ +import SphincsSecurity.Proof.OtsProbeChargedRootSelectionProjection + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def chargedRootOuterCharge (parameter : PublicParameter) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : ENNReal := + knownStructuralRootOuterCharge parameter input context fuel cache * (4 / 3 : ENNReal) + + materializedEncodingRootOuterCharge parameter input context fuel cache + +theorem chargedRootOuterCharge_eq_zero_of_not_hash + (parameter : PublicParameter) (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (hnot : ¬IsOuterHash input) : + chargedRootOuterCharge parameter input context fuel cache = 0 := by + cases input with + | inl query => cases query <;> simp_all [IsOuterHash, chargedRootOuterCharge, knownStructuralRootOuterCharge, materializedEncodingRootOuterCharge] + | inr message => simp [chargedRootOuterCharge, knownStructuralRootOuterCharge, materializedEncodingRootOuterCharge] + +theorem canonicalSelection_chargedRootCharge + (parameter : PublicParameter) (selection : Option CanonicalQuerySelection) : + CanonicalQuerySelection.charge (chargedRootOuterCharge parameter) selection = + CanonicalQuerySelection.charge (knownStructuralRootOuterCharge parameter) selection * (4 / 3 : ENNReal) + + CanonicalQuerySelection.charge (materializedEncodingRootOuterCharge parameter) selection := by + cases selection <;> simp [CanonicalQuerySelection.charge, chargedRootOuterCharge] + +theorem sum_targets_chargedRootSelection_probability_le_charge + (targets : Finset Position) (parameter : PublicParameter) (run : ProbComp (Option CanonicalQuerySelection)) : + (∑ target ∈ targets, Pr[fun selection => chargedNativeRootSelectionCandidate parameter target selection ≠ none | run]) * (4 / 3 : ENNReal) ≤ + ∑' selection, Pr[= selection | run] * CanonicalQuerySelection.charge (chargedRootOuterCharge parameter) selection := by + simp_rw [probEvent_eq_tsum_ite] + rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable), ← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro selection + cases selection with + | none => simp [chargedNativeRootSelectionCandidate, CanonicalQuerySelection.charge] + | some selection => + have hfactor : (∑ target ∈ targets, + if chargedNativeRootSelectionCandidate parameter target (some selection) ≠ none then Pr[= some selection | run] else 0) = + Pr[= some selection | run] * (∑ target ∈ targets, + if chargedNativeRootQueryCandidate parameter target selection.input selection.context ≠ none then (1 : ENNReal) else 0) := by + rw [Finset.mul_sum] + simp [chargedNativeRootSelectionCandidate, mul_ite] + rw [hfactor, mul_assoc] + exact mul_le_mul' le_rfl (sum_targets_chargedRootQueryCandidate_le_charge targets parameter selection.input + selection.context selection.fuel selection.cache) + +theorem sum_targets_hashSelections_chargedRoot_probability_le_charge + (targets : Finset Position) (parameter : PublicParameter) + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp (OracleWorld + SigningSpec) α) (q : Nat) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + (∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[fun selection => chargedNativeRootSelectionCandidate parameter target selection ≠ none | + liveNativeHashQuerySelection impl computation ordinal context fuel table cache]) * (4 / 3 : ENNReal) ≤ + expectedLiveNativeContextCharge impl (chargedRootOuterCharge parameter) computation context fuel table cache := by + rw [Finset.sum_comm, Finset.sum_mul] + apply (Finset.sum_le_sum (fun ordinal _ => sum_targets_chargedRootSelection_probability_le_charge targets parameter + (liveNativeHashQuerySelection impl computation ordinal context fuel table cache))).trans + exact (ENNReal.sum_le_tsum (Finset.range q)).trans_eq + (tsum_liveNativeHashQuerySelection_charge impl _ (chargedRootOuterCharge_eq_zero_of_not_hash parameter) + computation context fuel table cache) + +theorem expectedLiveChargedRootCharge_eq_components + (parameter : PublicParameter) + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + expectedLiveNativeContextCharge impl (chargedRootOuterCharge parameter) computation context fuel table cache = + expectedLiveNativeContextCharge impl (knownStructuralRootOuterCharge parameter) computation context fuel table cache * (4 / 3 : ENNReal) + + expectedLiveNativeContextCharge impl (materializedEncodingRootOuterCharge parameter) computation context fuel table cache := by + have hstructural : ∀ input context fuel cache, ¬IsOuterHash input → knownStructuralRootOuterCharge parameter input context fuel cache = 0 := by + intro input context fuel cache hnot + cases input with + | inl query => cases query <;> simp_all [IsOuterHash, knownStructuralRootOuterCharge] + | inr message => rfl + have hencoding : ∀ input context fuel cache, ¬IsOuterHash input → materializedEncodingRootOuterCharge parameter input context fuel cache = 0 := by + intro input context fuel cache hnot + cases input with + | inl query => cases query <;> simp_all [IsOuterHash, materializedEncodingRootOuterCharge] + | inr message => rfl + rw [← tsum_liveNativeHashQuerySelection_charge impl _ (chargedRootOuterCharge_eq_zero_of_not_hash parameter), + ← tsum_liveNativeHashQuerySelection_charge impl _ hstructural, + ← tsum_liveNativeHashQuerySelection_charge impl _ hencoding] + simp only [canonicalSelection_chargedRootCharge, mul_add, ← mul_assoc, ENNReal.tsum_add, ENNReal.tsum_mul_right] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootCut.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootCut.lean new file mode 100644 index 00000000..c61fb85e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootCut.lean @@ -0,0 +1,79 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootHistoryTraceSampling + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def ChargedNativeRootQuery (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) : Prop := + KnownHiddenStructuralRootQuery parameter input context ∨ MaterializedHiddenEncodingRootQuery parameter input context + +theorem chargedNativeRootQuery_replaceNativePosition + (parameter : PublicParameter) (input : HashInput) (target : Position) (output : HashOutput) (context : DeferredContext) : + ChargedNativeRootQuery parameter input (replaceNativePosition target output context) ↔ ChargedNativeRootQuery parameter input context := by + simp only [ChargedNativeRootQuery, + ← knownHiddenStructuralRootQuery_replaceNativePosition parameter target output context input, materializedHiddenEncodingRootQuery_replaceNativePosition] + +theorem chargedNativeRootQuery_of_visible_state_eq + (parameter : PublicParameter) (input : HashInput) (left right : DeferredContext) + (hvalues : left.state.values = right.state.values) (hrevealed : left.state.revealed = right.state.revealed) : + ChargedNativeRootQuery parameter input left ↔ ChargedNativeRootQuery parameter input right := by + simp only [ChargedNativeRootQuery, KnownHiddenStructuralRootQuery, MaterializedHiddenEncodingRootQuery, + hvalues, hrevealed, purePeekTableInput_eq_of_values_eq parameter hvalues] + +def ChargedNativeRootCut (parameter : PublicParameter) (context : DeferredContext) (cut : OuterQueryCut α) : Prop := + ∃ input, cut.input? = some (.inl (.inr input)) ∧ ChargedNativeRootQuery parameter input context + +noncomputable def chargedNativeRootCutCandidate (parameter : PublicParameter) (target : Position) + (context : DeferredContext) (cut : OuterQueryCut α) : Option Digest := + if ChargedNativeRootCut parameter context cut then nativeRootCutCandidate parameter target context cut else none + +theorem chargedNativeRootCutCandidate_replaceNativePosition + (parameter : PublicParameter) (target : Position) (output : HashOutput) (context : DeferredContext) (cut : OuterQueryCut α) : + chargedNativeRootCutCandidate parameter target (replaceNativePosition target output context) cut = + chargedNativeRootCutCandidate parameter target context cut := by + simp only [chargedNativeRootCutCandidate, ChargedNativeRootCut, chargedNativeRootQuery_replaceNativePosition, + ← nativeRootCutCandidate_replaceNativePosition parameter target output context cut] + +theorem nativeRootCutCandidate_of_visible_state_eq + (parameter : PublicParameter) (target : Position) (left right : DeferredContext) (cut : OuterQueryCut α) + (hvalues : left.state.values = right.state.values) (hrevealed : left.state.revealed = right.state.revealed) : + nativeRootCutCandidate parameter target left cut = nativeRootCutCandidate parameter target right cut := by + unfold nativeRootCutCandidate + apply congrArg (fun next => cut.input?.bind next) + funext input + cases input with + | inl query => + cases query with + | inl n => rfl + | inr input => simp only [nativeRootCandidate_eq_of_visible_state_eq parameter input left right hvalues hrevealed] + | inr message => rfl + +theorem chargedNativeRootCutCandidate_of_visible_state_eq + (parameter : PublicParameter) (target : Position) (left right : DeferredContext) (cut : OuterQueryCut α) + (hvalues : left.state.values = right.state.values) (hrevealed : left.state.revealed = right.state.revealed) : + chargedNativeRootCutCandidate parameter target left cut = chargedNativeRootCutCandidate parameter target right cut := by + simp only [chargedNativeRootCutCandidate, ChargedNativeRootCut, + chargedNativeRootQuery_of_visible_state_eq parameter _ left right hvalues hrevealed, + nativeRootCutCandidate_of_visible_state_eq parameter target left right cut hvalues hrevealed] + +theorem chargedNativeRootCutCandidate_resolvePositionValue + (parameter : PublicParameter) (target position : Position) (context : DeferredContext) (cut : OuterQueryCut α) + (result : DeferredResolution) (hresult : some result ∈ support (resolveDeferredPositionValue position context)) : + chargedNativeRootCutCandidate parameter target result.toDeferredContext cut = chargedNativeRootCutCandidate parameter target context cut := by + apply chargedNativeRootCutCandidate_of_visible_state_eq parameter target result.toDeferredContext context cut + (resolveDeferredPositionValue_preserves_state_values position context result hresult) + rw [resolveDeferredPositionValue_state_eq_clearPending position context result hresult] + rfl + +theorem chargedNativeRootCutCandidate_some + (parameter : PublicParameter) (target : Position) (context : DeferredContext) (cut : OuterQueryCut α) (guess : Digest) + (hguess : chargedNativeRootCutCandidate parameter target context cut = some guess) : + ChargedNativeRootCut parameter context cut ∧ nativeRootCutCandidate parameter target context cut = some guess := by + unfold chargedNativeRootCutCandidate at hguess + split_ifs at hguess with hcharged + exact ⟨hcharged, hguess⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootCutRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootCutRisk.lean new file mode 100644 index 00000000..3409659c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootCutRisk.lean @@ -0,0 +1,82 @@ +import SphincsSecurity.Proof.OtsProbeNativeTraceStoredRoot + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def chargedNativeRootTraceCutCandidate (parameter : PublicParameter) (target : Position) : + Option (ResolvedRunResult (OuterQueryCut α × SplitHashCache)) → Option Digest + | none => none + | some result => chargedNativeRootCutCandidate parameter target result.context result.value.1 + +noncomputable def chargedNativeStoredRootRecordCutCandidate (parameter : PublicParameter) (target : Position) + (record : ResolvedRunResult (OuterQueryCut α) × Finset Digest) : Option Digest := + chargedNativeRootCutCandidate parameter target record.1.context record.1.value + +theorem chargedNativeStoredRootRecordCutCandidate_observe + (parameter : PublicParameter) (target : Position) (before after : HashOutput) + (trace : Option (ResolvedRunResult (OuterQueryCut α × SplitHashCache)) × List CanonicalQuerySelection) : + (observeCompatibleNativeRootTrace parameter target before after trace).bind (chargedNativeStoredRootRecordCutCandidate parameter target) = + if NativeRootTraceCompatible parameter target before after trace then chargedNativeRootTraceCutCandidate parameter target trace.1 else none := by + unfold observeCompatibleNativeRootTrace + split_ifs with hcompatible + · rcases trace with ⟨option, history⟩ + cases option with + | none => contradiction + | some result => + simp only [normalizeNativeRootResult, Option.map_some, Option.bind_some, chargedNativeStoredRootRecordCutCandidate, + chargedNativeRootTraceCutCandidate, chargedNativeRootCutCandidate_replaceNativePosition] + · rfl + +noncomputable def sampleChargedNativeRootCut + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (ordinal : Nat) : ProbComp (HashOutput × Option Digest) := do + let output ← LazyRevealProbe.sampleHashOutput + if truncateHash output ∈ initialHistory then pure (output, none) else + let trace ← runNativeQueryTrace parameter root ftsSecret (outerHashQueryCutAt computation ordinal) + (replaceNativePosition target output context) fuel table cache + pure (output, if NativeRootTraceCompatible parameter target output output trace then + chargedNativeRootTraceCutCandidate parameter target trace.1 else none) + +theorem sampleChargedNativeRootCut_eq_records + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (ordinal : Nat) : + sampleChargedNativeRootCut parameter root target ftsSecret computation context fuel table cache initialHistory ordinal = + samplePrivateHistoryGuess + (runNativeStoredRootRecords parameter root target ftsSecret (outerHashQueryCutAt computation ordinal) + context fuel table cache initialHistory) (chargedNativeStoredRootRecordCutCandidate parameter target) := by + unfold sampleChargedNativeRootCut samplePrivateHistoryGuess + apply bind_congr + intro output + unfold runNativeStoredRootRecords + by_cases hinitial : truncateHash output ∈ initialHistory + · simp [hinitial] + · simp only [hinitial, ↓reduceIte, map_eq_bind_pure_comp, Function.comp_def, bind_assoc, pure_bind, + chargedNativeStoredRootRecordCutCandidate_observe] + +theorem probEvent_sampleChargedNativeRootCut_hit_le_occurrence + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (hconsistent : context.ValuesConsistent) + (hpending : context.state.pendingAt (.position target) ⊆ initialHistory) + (hcache : ∀ digest, digest ∉ initialHistory → NoEncodingRootGuessCached parameter target digest cache) + (ordinal : Nat) (hbudget : initialHistory.card + ordinal ≤ 2 ^ 126) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | + sampleChargedNativeRootCut parameter root target ftsSecret computation context fuel table cache initialHistory ordinal] ≤ + Pr[fun pair => pair.2 ≠ none | + sampleChargedNativeRootCut parameter root target ftsSecret computation context fuel table cache initialHistory ordinal] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + rw [sampleChargedNativeRootCut_eq_records] + exact probEvent_sampleNativeStoredRootRecords_hit_le_occurrence parameter root target hroot ftsSecret + (outerHashQueryCutAt computation ordinal) context fuel table cache initialHistory hconsistent hpending hcache + ordinal (outerHashQueryCutAt_hashBound computation ordinal) hbudget _ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootGlobalRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootGlobalRisk.lean new file mode 100644 index 00000000..15ac0545 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootGlobalRisk.lean @@ -0,0 +1,74 @@ +import SphincsSecurity.Proof.OtsProbeChargedRootCounting + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem sum_targets_originalChargedRootCut_hits_le_charge + (targets : Finset Position) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (q : Nat) (hq : q ≤ 2 ^ 126) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hroot : ∀ target ∈ targets, IsLayerRoot target) + (hensured : ∀ target ∈ targets, .position target ∈ context.state.ensured) + (hstate : ∀ target ∈ targets, context.state.values (.position target) = none) + (hvalue : ∀ target ∈ targets, context.values target = none) + (hpending : ∀ target ∈ targets, context.state.pendingAt (.position target) = ∅) + (hcache : ∀ target ∈ targets, ∀ digest, NoEncodingRootGuessCached parameter target digest cache) : + (∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[fun b => b = false | originalChargedRootCutObservation parameter root target ftsSecret computation + context fuel table cache ∅ ordinal (fun pair => pair.2 = some (truncateHash pair.1))]) ≤ + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (chargedRootOuterCharge parameter) computation context fuel table cache * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ ∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[fun selection => chargedNativeRootSelectionCandidate parameter target selection ≠ none | + liveNativeHashQuerySelection (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + computation ordinal context fuel table cache] * ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply Finset.sum_le_sum + intro target htarget + apply Finset.sum_le_sum + intro ordinal hordinal + have hlocal := probEvent_originalChargedRootCutObservation_hit_le_trace_occurrence parameter root target + (hroot target htarget) ftsSecret computation context fuel table cache ∅ hvalid hcomplete + (hensured target htarget) (hstate target htarget) (hvalue target htarget) + (by rw [hpending target htarget]) (fun digest _ => hcache target htarget digest) ordinal + (by simpa using (Nat.le_of_lt (Finset.mem_range.mp hordinal)).trans hq) + rw [probEvent_chargedNativeRootTraceCutCandidate_occurrence_eq_selection parameter root target ftsSecret + computation ordinal context fuel table cache hvalid.valuesConsistent (startTableAgrees_of_deferredCompletable hcomplete)] at hlocal + exact hlocal + _ = ((∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[fun selection => chargedNativeRootSelectionCandidate parameter target selection ≠ none | + liveNativeHashQuerySelection (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + computation ordinal context fuel table cache]) * (4 / 3 : ENNReal)) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + simp only [Finset.sum_mul, mul_assoc] + _ ≤ _ := mul_le_mul' (sum_targets_hashSelections_chargedRoot_probability_le_charge targets parameter + (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation q context fuel table cache) le_rfl + +theorem chronological_liveProbe_add_chargedRoots_le_refinedReserve + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) + (hmat : LayerRootsMaterialized context) : + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + expectedLiveResolvedQueryCharge nativeProbeQueryCharge + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) context fuel table * (4 / 3 : ENNReal) + + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (chargedRootOuterCharge parameter) computation context fuel table cache ≤ + expectedQueryCharge (otsOpeningRefinedQueryReserve secretKey) + (simulateQ (expandedAdversaryImpl secretKey) computation) actualCache := by + dsimp only + rw [expectedLiveChargedRootCharge_eq_components, ← add_assoc, ← add_mul] + exact chronological_liveProbe_add_materializedRoots_le_refinedReserve parameter root table ftsSecret computation + context fuel cache actualCache hinvariant hvisible hpublished hcomputed hmat + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootInitialization.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootInitialization.lean new file mode 100644 index 00000000..348a934a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootInitialization.lean @@ -0,0 +1,121 @@ +import SphincsSecurity.Proof.OtsProbeChargedRootOccurrence +import SphincsSecurity.Proof.OtsProbeSigningStartValues + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem ResolvedOrdinaryCachePreserving.of_administrative + {computation : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α} {value : α} + (h : ResolvedAdministrative computation value) : ResolvedOrdinaryCachePreserving computation := by + intro context fuel table cache result hresult + obtain ⟨finalContext, hrun, _⟩ := h context cache fuel table + rw [hrun] at hresult + simp only [mem_support_pure_iff, Option.some.injEq] at hresult + subst result + rfl + +theorem resolvedOrdinaryCachePreserving_maskedPublishedTreeRoot : + ResolvedOrdinaryCachePreserving maskedPublishedTreeRoot := by + unfold maskedPublishedTreeRoot + exact (ResolvedOrdinaryCachePreserving.of_administrative + (resolvedAdministrative_ensureTreeNode topLayer rootTree (layerHeight topLayer) 0)).bind fun _ => + resolvedOrdinaryCachePreserving_revealPublishedCoordinate _ + +theorem resolvedPreservesCoordinate_maskedTreeRoot_of_ne + (position : Position) (lay : Layer) (tree : TreeIndex) (hne : position ≠ layerRootPosition lay tree) : + ResolvedPreservesCoordinate (.position position) (maskedTreeRoot lay tree) := by + have hpos : 0 < layerHeight lay := by + unfold layerHeight + split <;> norm_num [maxLayerHeight] + have hlevel : layerHeight lay - 1 < maxLayerHeight := by + have hle := layerHeight_le lay + omega + have hcoordinate : Coordinate.position position ≠ + .position (.node lay tree ⟨layerHeight lay - 1, hlevel⟩ (leafOfNat 0)) := by + intro heq + apply hne + apply Coordinate.position.inj at heq + simpa [layerRootPosition, leafOfNat] using heq + unfold maskedTreeRoot + rw [show layerHeight lay = (layerHeight lay - 1) + 1 by omega, maskedTreeNode] + exact (resolvedPreservesCoordinate_ensureTreeNode (.position position) lay tree + (layerHeight lay - 1 + 1) 0).bind fun _ => by + rw [dif_pos hlevel] + exact resolvedPreservesCoordinate_revealCoordinate_of_ne _ _ hcoordinate + +theorem resolvedPreservesCoordinate_maskedPublishedTreeRoot_of_ne + (position : Position) (hne : position ≠ layerRootPosition topLayer rootTree) : + ResolvedPreservesCoordinate (.position position) maskedPublishedTreeRoot := by + rw [maskedPublishedTreeRoot_eq] + exact (resolvedPreservesCoordinate_maskedTreeRoot_of_ne position topLayer rootTree hne).bind fun _ => + (resolvedPreservesCoordinate_publish_of_ne (.position position) (.position (layerRootPosition topLayer rootTree)) + (fun heq => hne (Coordinate.position.inj heq))).bind fun _ => resolvedPreservesCoordinate_pure _ _ + +attribute [local irreducible] maskedPublishedTreeRoot + +theorem initializedNativeRoot_fresh_facts + (parameter : PublicParameter) (targets : Finset Position) (target : Position) (hmem : target ∈ targets) + (hroot : IsLayerRoot target) (hne : target ≠ layerRootPosition topLayer rootTree) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult (Digest × SplitHashCache)) + (hresult : some result ∈ support (runResolvedFromTable (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache))) : + result.context.Valid ∧ DeferredCompletable table result.context ∧ + .position target ∈ result.context.state.ensured ∧ + result.context.state.values (.position target) = none ∧ result.context.values target = none ∧ + result.context.state.pendingAt (.position target) = ∅ ∧ + ∀ digest, NoEncodingRootGuessCached parameter target digest result.value.2 := by + have hcore := resolvedCore_of_mem_runResolvedFromTable (maskedPublishedTreeRoot.run emptySplitHashCache) + (ensuredInitialContext targets) fuel table result (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table)) hresult + have hcovered := valid_pendingCovered_of_mem_runResolvedFromTable_of_probeFree _ _ fuel table result [] + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) (ensuredInitialContext_valid targets) + (by intro entry hentry; simp [ensuredInitialContext, LazyRevealProbe.State.empty] at hentry) hresult + have hcomplete := deferredCompletable_of_no_pending table result.context hcore.2.1 hcore.2.2 hcovered.2 + have hstate : result.context.state.values (.position target) = none := + (resolvedPreservesCoordinate_maskedPublishedTreeRoot_of_ne target hne (ensuredInitialContext targets) + fuel table emptySplitHashCache result hresult).1 + have hmat := rootMaterializationPreserving_maskedPublishedTreeRoot (ensuredInitialContext targets) fuel table + emptySplitHashCache result (layerRootsMaterialized_ensuredInitialContext targets) (ensuredInitialContext_computed targets) hresult + have haux : result.context.values target = none := by + by_contra hknown + exact hmat target hroot hknown hstate + have hensured := ensuredLE_of_mem_runResolvedFromTable _ _ fuel table result hresult + have hpending : result.context.state.pendingAt (.position target) = ∅ := by + apply Finset.eq_empty_iff_forall_notMem.mpr + intro digest hhit + have hentry : (.position target, digest) ∈ result.context.state.pending := + (LazyRevealProbe.State.mem_pendingAt_iff _ _ _).mp hhit + exact List.not_mem_nil (hcovered.2 _ hentry) + refine ⟨hcovered.1, hcomplete, hensured (ensuredInitialContext_mem_ensured targets target hmem), hstate, haux, hpending, ?_⟩ + have hcache := resolvedOrdinaryCachePreserving_maskedPublishedTreeRoot (ensuredInitialContext targets) fuel table + emptySplitHashCache result hresult + intro digest input _ + change ordinaryQueryCache result.value.2 input = none + rw [hcache] + rfl + +theorem probEvent_chargedRootCut_after_keygen_hit_le_trace_occurrence + (parameter : PublicParameter) (targets : Finset Position) (target : Position) (hmem : target ∈ targets) + (hroot : IsLayerRoot target) (hne : target ≠ layerRootPosition topLayer rootTree) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : Digest → OracleComp (OracleWorld + SigningSpec) α) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult (Digest × SplitHashCache)) + (hresult : some result ∈ support (runResolvedFromTable (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache))) (ordinal : Nat) (hbudget : ordinal ≤ 2 ^ 126) : + Pr[fun b => b = false | originalChargedRootCutObservation parameter result.value.1 target ftsSecret + (computation result.value.1) result.context result.remaining table result.value.2 ∅ ordinal + (fun pair => pair.2 = some (truncateHash pair.1))] ≤ + Pr[fun trace => chargedNativeRootTraceCutCandidate parameter target trace.1 ≠ none | + runNativeQueryTrace parameter result.value.1 ftsSecret (outerHashQueryCutAt (computation result.value.1) ordinal) + result.context result.remaining table result.value.2] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + obtain ⟨hvalid, hcomplete, hensured, hstate, hvalue, hpending, hcache⟩ := + initializedNativeRoot_fresh_facts parameter targets target hmem hroot hne fuel table result hresult + exact probEvent_originalChargedRootCutObservation_hit_le_trace_occurrence parameter result.value.1 target hroot ftsSecret + (computation result.value.1) result.context result.remaining table result.value.2 ∅ hvalid hcomplete hensured hstate hvalue + (by rw [hpending]) (fun digest _ => hcache digest) ordinal (by simpa using hbudget) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootObservation.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootObservation.lean new file mode 100644 index 00000000..8e6a8944 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootObservation.lean @@ -0,0 +1,85 @@ +import SphincsSecurity.Proof.OtsProbeChargedRootCut + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem DeferredCompletable.not_hitAt_of_positionValue + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hcomplete : DeferredCompletable table context) (target : Position) (output : HashOutput) + (hknown : context.positionValue target = some output) : ¬context.state.hitAt (.position target) output := by + obtain ⟨completion, hcompletion⟩ := hcomplete + intro hhit + have hnot := hcompletion.2.2.1 (.position target) (truncateHash output) + (by simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff] using hhit) + exact hnot (congrArg truncateHash (hcompletion.eq_positionValue target output hknown)) + +theorem DeferredCompletable.clearNativeRootPending + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hcomplete : DeferredCompletable table context) (target : Position) : + DeferredCompletable table (clearNativeRootPending target context) := by + obtain ⟨completion, hcompletion⟩ := hcomplete + refine ⟨completion, hcompletion.1, hcompletion.2.1, ?_, hcompletion.2.2.2⟩ + intro coordinate candidate hmem + exact hcompletion.2.2.1 coordinate candidate (Finset.mem_filter.mp hmem).1 + +theorem resolveDeferredPositionValue_eq_clearPending_of_known + (target : Position) (context : DeferredContext) (output : HashOutput) + (hconsistent : context.ValuesConsistent) (hknown : context.positionValue target = some output) + (hmiss : ¬context.state.hitAt (.position target) output) : + resolveDeferredPositionValue target context = pure (some ⟨clearNativeRootPending target context, output⟩) := by + cases hstate : context.state.values (.position target) with + | none => + have haux : context.values target = some output := by simpa [DeferredContext.positionValue, hstate] using hknown + rw [resolveDeferredPositionValue_of_deferred_value target context output hstate haux, if_neg hmiss] + rfl + | some value => + have heq : value = output := by simpa [DeferredContext.positionValue, hstate] using hknown + subst value + have haux := hconsistent target output hstate + have hinstall : context.values.install target output = context.values := by + simp [DeferredStructuralValues.install, ← haux] + rw [resolveDeferredPositionValue_of_state_value target context output hstate, if_neg hmiss, hinstall] + rfl + +noncomputable def observeChargedRootCut + (parameter : PublicParameter) (target : Position) (event : HashOutput × Option Digest → Prop) + (context : DeferredContext) (_fuel : Nat) (value : OuterQueryCut α × SplitHashCache) (history : Finset Digest) : ProbComp Bool := + pure (decide (¬∃ output, context.positionValue target = some output ∧ .position target ∉ context.state.revealed ∧ + truncateHash output ∉ history ∧ event (output, chargedNativeRootCutCandidate parameter target context value.1))) + +theorem observeChargedRootCut_clearPending + (parameter : PublicParameter) (target : Position) (event : HashOutput × Option Digest → Prop) + (context : DeferredContext) (fuel : Nat) (value : OuterQueryCut α × SplitHashCache) (history : Finset Digest) : + observeChargedRootCut parameter target event (clearNativeRootPending target context) fuel value history = + observeChargedRootCut parameter target event context fuel value history := by + simp only [observeChargedRootCut, + chargedNativeRootCutCandidate_of_visible_state_eq parameter target (clearNativeRootPending target context) context value.1 rfl rfl] + rfl + +theorem observeChargedRootCut_of_known + (parameter : PublicParameter) (target : Position) (event : HashOutput × Option Digest → Prop) + (context : DeferredContext) (fuel : Nat) (value : OuterQueryCut α × SplitHashCache) (history : Finset Digest) + (output : HashOutput) (hknown : context.positionValue target = some output) : + observeChargedRootCut parameter target event context fuel value history = + pure (decide (¬(.position target ∉ context.state.revealed ∧ truncateHash output ∉ history ∧ + event (output, chargedNativeRootCutCandidate parameter target context value.1)))) := by + simp [observeChargedRootCut, hknown] + +theorem privateResolutionObserve_chargedRootCut_of_known + (parameter : PublicParameter) (target : Position) (table : OtsSecretIndex → HashOutput) + (event : HashOutput × Option Digest → Prop) (history : Finset Digest) + (context : DeferredContext) (fuel : Nat) (value : OuterQueryCut α × SplitHashCache) + (hconsistent : context.ValuesConsistent) (hcomplete : DeferredCompletable table context) + (output : HashOutput) (hknown : context.positionValue target = some output) : + privateResolutionObserve target table (fun final remaining value => observeChargedRootCut parameter target event final remaining value history) + context fuel value = observeChargedRootCut parameter target event context fuel value history := by + rw [privateResolutionObserve, resolveDeferredPositionValue_eq_clearPending_of_known target context output hconsistent hknown + (hcomplete.not_hitAt_of_positionValue target output hknown)] + simp only [pure_bind, if_pos (hcomplete.clearNativeRootPending target)] + exact observeChargedRootCut_clearPending parameter target event context fuel value history + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootOccurrence.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootOccurrence.lean new file mode 100644 index 00000000..8b94b1cf --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootOccurrence.lean @@ -0,0 +1,61 @@ +import SphincsSecurity.Proof.OtsProbeChargedRootAdaptiveRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem probEvent_originalChargedRootCutObservation_occurrence_le_trace + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (ordinal : Nat) : + Pr[fun b => b = false | originalChargedRootCutObservation parameter root target ftsSecret computation + context fuel table cache initialHistory ordinal (fun pair => pair.2 ≠ none)] ≤ + Pr[fun trace => chargedNativeRootTraceCutCandidate parameter target trace.1 ≠ none | + runNativeQueryTrace parameter root ftsSecret (outerHashQueryCutAt computation ordinal) context fuel table cache] := by + unfold originalChargedRootCutObservation + apply probEvent_bind_le_probEvent + rintro ⟨option, history⟩ _ hmiss + cases option with + | none => simp [finishNativeRootHistoryTrace] + | some result => + have hnone : chargedNativeRootCutCandidate parameter target result.context result.value.1 = none := by + simpa only [chargedNativeRootTraceCutCandidate, not_not] using hmiss + unfold finishNativeRootHistoryTrace privateResolutionObserve + rw [probEvent_bind_eq_tsum] + apply ENNReal.tsum_eq_zero.mpr + intro resolved + by_cases hresolved : resolved ∈ support (resolveDeferredPositionValue target result.context) + · cases resolved with + | none => simp + | some resolved => + by_cases hcomplete : DeferredCompletable table resolved.toDeferredContext + · simp [hcomplete, observeChargedRootCut, + chargedNativeRootCutCandidate_resolvePositionValue parameter target target result.context result.value.1 resolved hresolved, hnone] + · simp [hcomplete] + · simp [probOutput_eq_zero_of_not_mem_support hresolved] + +theorem probEvent_originalChargedRootCutObservation_hit_le_trace_occurrence + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hpending : context.state.pendingAt (.position target) ⊆ initialHistory) + (hcache : ∀ digest, digest ∉ initialHistory → NoEncodingRootGuessCached parameter target digest cache) + (ordinal : Nat) (hbudget : initialHistory.card + ordinal ≤ 2 ^ 126) : + Pr[fun b => b = false | originalChargedRootCutObservation parameter root target ftsSecret computation + context fuel table cache initialHistory ordinal (fun pair => pair.2 = some (truncateHash pair.1))] ≤ + Pr[fun trace => chargedNativeRootTraceCutCandidate parameter target trace.1 ≠ none | + runNativeQueryTrace parameter root ftsSecret (outerHashQueryCutAt computation ordinal) context fuel table cache] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := + (probEvent_originalChargedRootCutObservation_hit_le_occurrence parameter root target hroot ftsSecret computation + context fuel table cache initialHistory hvalid hcomplete hensured hstate hvalue hpending hcache ordinal hbudget).trans + (mul_le_mul_left (probEvent_originalChargedRootCutObservation_occurrence_le_trace parameter root target ftsSecret computation + context fuel table cache initialHistory ordinal) _) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootSelection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootSelection.lean new file mode 100644 index 00000000..c46042fa --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootSelection.lean @@ -0,0 +1,101 @@ +import SphincsSecurity.Proof.OtsProbeInitializedChargedRootRisk +import SphincsSecurity.Proof.OtsProbeLiveHashCut + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem ChargedNativeRootQuery.no_native_candidate + {parameter : PublicParameter} {input : HashInput} {context : DeferredContext} + (h : ChargedNativeRootQuery parameter input context) : + (purePlanProbingHashQuery parameter input context.state).candidate? = none := by + rcases h with h | ⟨candidate, target, hcandidate, _⟩ + · exact h.no_candidate + · exact hcandidate.no_native_candidate context.state + +theorem NativeRootCandidateAt.direct_or_charged_or_unknown_encoding + {parameter : PublicParameter} {input : HashInput} {context : DeferredContext} {candidate : Probe} + (h : NativeRootCandidateAt parameter input context candidate) (target : Position) + (hroot : IsLayerRoot target) (hcoordinate : candidate.coordinate = .position target) + (hhidden : .position target ∉ context.state.revealed) (hmat : LayerRootsMaterialized context) : + (purePlanProbingHashQuery parameter input context.state).candidate? = some candidate ∨ + ChargedNativeRootQuery parameter input context ∨ + (EncodingLayerRootCandidateAt parameter input candidate ∧ context.positionValue target = none) := by + rcases h with hnative | hencoding | ⟨hstructural, _⟩ + · exact Or.inl hnative + · cases hknown : context.positionValue target with + | none => exact Or.inr (Or.inr ⟨hencoding, rfl⟩) + | some output => + apply Or.inr ∘ Or.inl ∘ Or.inr + exact ⟨candidate, target, hencoding, hcoordinate, + by rw [hmat.state_value_of_known target hroot output hknown]; rfl, hhidden⟩ + · exact Or.inr (Or.inl (Or.inl hstructural)) + +noncomputable def chargedNativeRootQueryCandidate (parameter : PublicParameter) (target : Position) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) : Option Digest := + match input with + | .inl (.inr input) => + if ChargedNativeRootQuery parameter input context then do + let candidate ← nativeRootCandidate? parameter input context + if candidate.coordinate = .position target then some candidate.candidate else none + else none + | _ => none + +noncomputable def chargedNativeRootSelectionCandidate (parameter : PublicParameter) (target : Position) + (selection : Option CanonicalQuerySelection) : Option Digest := + selection.bind fun selection => chargedNativeRootQueryCandidate parameter target selection.input selection.context + +theorem chargedNativeRootCutCandidate_eq_query + (parameter : PublicParameter) (target : Position) (context : DeferredContext) (cut : OuterQueryCut α) : + chargedNativeRootCutCandidate parameter target context cut = + cut.input?.bind (fun input => chargedNativeRootQueryCandidate parameter target input context) := by + unfold chargedNativeRootCutCandidate ChargedNativeRootCut nativeRootCutCandidate + cases hinput : cut.input? with + | none => simp + | some input => + cases input with + | inl query => + cases query with + | inl n => simp [chargedNativeRootQueryCandidate] + | inr input => simp [chargedNativeRootQueryCandidate] + | inr message => simp [chargedNativeRootQueryCandidate] + +theorem chargedNativeRootQueryCandidate_eq_none_of_native_candidate + (parameter : PublicParameter) (target : Position) (input : HashInput) (context : DeferredContext) + (hprobe : (purePlanProbingHashQuery parameter input context.state).candidate? ≠ none) : + chargedNativeRootQueryCandidate parameter target (.inl (.inr input)) context = none := by + exact if_neg (fun h => hprobe h.no_native_candidate) + +theorem sum_targets_chargedRootQueryCandidate_le_charge + (targets : Finset Position) (parameter : PublicParameter) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + (∑ target ∈ targets, if chargedNativeRootQueryCandidate parameter target input context ≠ none then (1 : ENNReal) else 0) * (4 / 3 : ENNReal) ≤ + knownStructuralRootOuterCharge parameter input context fuel cache * (4 / 3 : ENNReal) + + materializedEncodingRootOuterCharge parameter input context fuel cache := by + cases input with + | inl query => + cases query with + | inl n => simp [chargedNativeRootQueryCandidate, knownStructuralRootOuterCharge, materializedEncodingRootOuterCharge] + | inr input => + by_cases hcharged : ChargedNativeRootQuery parameter input context + · have hone : (∑ target ∈ targets, + if chargedNativeRootQueryCandidate parameter target (.inl (.inr input)) context ≠ none then (1 : ENNReal) else 0) ≤ 1 := by + cases hcandidate : nativeRootCandidate? parameter input context with + | none => simp [chargedNativeRootQueryCandidate, hcharged, hcandidate] + | some candidate => + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => simp [chargedNativeRootQueryCandidate, hcharged, hcandidate, hcoordinate] + | position position => + by_cases hmem : position ∈ targets <;> + simp [chargedNativeRootQueryCandidate, hcharged, hcandidate, hcoordinate, hmem] + apply (mul_le_mul' hone le_rfl).trans + rcases hcharged with hstructural | hencoding + · simp [knownStructuralRootOuterCharge, hstructural] + · simp [materializedEncodingRootOuterCharge, hencoding] + · simp [chargedNativeRootQueryCandidate, hcharged] + | inr message => simp [chargedNativeRootQueryCandidate, knownStructuralRootOuterCharge, materializedEncodingRootOuterCharge] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootSelectionProjection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootSelectionProjection.lean new file mode 100644 index 00000000..ac89df80 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChargedRootSelectionProjection.lean @@ -0,0 +1,58 @@ +import SphincsSecurity.Proof.OtsProbeChargedRootSelection + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem chargedNativeRootTraceCutCandidate_retain + (parameter : PublicParameter) (target : Position) + (result : Option (ResolvedRunResult (OuterQueryCut α × SplitHashCache))) : + chargedNativeRootTraceCutCandidate parameter target (retainCompletableResult result) = + chargedNativeRootSelectionCandidate parameter target (liveNativeHashCutSelection result) := by + cases result with + | none => rfl + | some result => + simp only [retainCompletableResult, liveNativeHashCutSelection] + by_cases hcomplete : DeferredCompletable result.table result.context + · simp only [if_pos hcomplete, chargedNativeRootTraceCutCandidate, chargedNativeRootCutCandidate_eq_query] + cases hinput : result.value.1.input? <;> simp [chargedNativeRootSelectionCandidate] + · simp [hcomplete, chargedNativeRootTraceCutCandidate, chargedNativeRootSelectionCandidate] + +theorem evalDist_chargedNativeRootTraceCutCandidate_eq_selection + (parameter : PublicParameter) (root : Digest) (target : Position) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + evalDist ((fun trace => chargedNativeRootTraceCutCandidate parameter target trace.1) <$> + runNativeQueryTrace parameter root ftsSecret (outerHashQueryCutAt computation ordinal) context fuel table cache) = + evalDist (chargedNativeRootSelectionCandidate parameter target <$> + liveNativeHashQuerySelection (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + computation ordinal context fuel table cache) := by + have hresult := evalDist_map_eq_of_evalDist_eq + (runNativeQueryTrace_result_projection parameter root ftsSecret (outerHashQueryCutAt computation ordinal) + context fuel table cache hconsistent hstarts) (chargedNativeRootTraceCutCandidate parameter target) + have hselection := evalDist_map_eq_of_evalDist_eq + (evalDist_liveNativeHashQuerySelection_eq_cut (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + computation ordinal context fuel table cache hconsistent hstarts) (chargedNativeRootSelectionCandidate parameter target) + simp only [Functor.map_map, chargedNativeRootTraceCutCandidate_retain] at hresult hselection + exact hresult.trans hselection.symm + +theorem probEvent_chargedNativeRootTraceCutCandidate_occurrence_eq_selection + (parameter : PublicParameter) (root : Digest) (target : Position) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + Pr[fun trace => chargedNativeRootTraceCutCandidate parameter target trace.1 ≠ none | + runNativeQueryTrace parameter root ftsSecret (outerHashQueryCutAt computation ordinal) context fuel table cache] = + Pr[fun selection => chargedNativeRootSelectionCandidate parameter target selection ≠ none | + liveNativeHashQuerySelection (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + computation ordinal context fuel table cache] := by + have hdist := evalDist_chargedNativeRootTraceCutCandidate_eq_selection parameter root target ftsSecret computation ordinal + context fuel table cache hconsistent hstarts + have hprob := probEvent_congr' (fun _ _ => Iff.rfl) hdist (p := fun candidate => candidate ≠ none) + simpa only [probEvent_map, Function.comp_def] using hprob + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeChronologicalProbability.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChronologicalProbability.lean new file mode 100644 index 00000000..2f7eddff --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChronologicalProbability.lean @@ -0,0 +1,452 @@ +import SphincsSecurity.Proof.OtsProbeChronologicalTerminal + +/-! +# Probability boundary for chronological one-time probes + +The resolved coupling supplies a concrete cache that agrees with every clean deferred completion. +This file first packages that support-level fact into the exact terminal contradiction, before +relating failed completion to the lazy-probe probability bound. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedChronologicalRetainedGameAfterFtsSecrets + actualRetainedGameAfterTable + +theorem VerifierLayerMessage.changeAnswerFn_of_cachedVerify + {f g : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {publicKey : PublicKey} {forgedMessage : Message} {signature : Signature} + {digest : MessageDigest} {lay : Layer} {layerMessage : Digest} + (hmessage : VerifierLayerMessage f publicKey.parameter (digestIndex digest) + (digestLeaves digest) signature lay layerMessage) + (hdigest : evalWithAnswerFn f + (messageDigest publicKey.parameter publicKey.root forgedMessage signature.randomness) = + digest) + (hadmissible : Admissible digest) + (hrun : CachedRun cache f (verify publicKey forgedMessage signature)) + (hf : cache.AgreesWithFn f) (hg : cache.AgreesWithFn g) : + VerifierLayerMessage g publicKey.parameter (digestIndex digest) + (digestLeaves digest) signature lay layerMessage := by + simp only [VerifierLayerMessage] at hmessage ⊢ + obtain ⟨bottomLeaf, hbottom, middleLeaf, hmiddle, hposition⟩ := hmessage + have hftsRun : CachedRun cache f + (ftsRecover publicKey.parameter (digestIndex digest) (digestLeaves digest) + signature.ftsSecret signature.ftsPath) := by + intro input hquery + exact hrun input (ftsRecover_query_mem_verify hdigest hadmissible hquery) + have hftsEq := hftsRun.eval_eq hf hg + have hbottomRun : CachedRun cache f + (otsLeaf publicKey.parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (evalWithAnswerFn f + (ftsRecover publicKey.parameter (digestIndex digest) (digestLeaves digest) + signature.ftsSecret signature.ftsPath)) + (signature.counter bottomLayer) (signature.chainValue bottomLayer)) := by + intro input hquery + exact hrun input (bottomOts_query_mem_verify hdigest hadmissible hquery) + have hbottomEq := hbottomRun.eval_eq hf hg + have hbottomFoldRun : CachedRun cache f + (treeFold publicKey.parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath signature bottomLayer) (layerHeight bottomLayer) bottomLeaf) := by + intro input hquery + exact hrun input (bottomFold_query_mem_verify hdigest hadmissible hbottom hquery) + have hbottomFoldEq : + foldValue f publicKey.parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath signature bottomLayer) bottomLeaf (layerHeight bottomLayer) = + foldValue g publicKey.parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath signature bottomLayer) bottomLeaf (layerHeight bottomLayer) := by + exact hbottomFoldRun.eval_eq hf hg + have hmiddleRun : CachedRun cache f + (otsLeaf publicKey.parameter middleLayer + (treeIndexAt (digestIndex digest) middleLayer) + (leafIndexAt (digestIndex digest) middleLayer) + (foldValue f publicKey.parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath signature bottomLayer) bottomLeaf (layerHeight bottomLayer)) + (signature.counter middleLayer) (signature.chainValue middleLayer)) := by + intro input hquery + exact hrun input (middleOts_query_mem_verify hdigest hadmissible hbottom hquery) + have hmiddleEq := hmiddleRun.eval_eq hf hg + have hmiddleFoldRun : CachedRun cache f + (treeFold publicKey.parameter middleLayer + (treeIndexAt (digestIndex digest) middleLayer) + (leafIndexAt (digestIndex digest) middleLayer) + (signaturePath signature middleLayer) (layerHeight middleLayer) middleLeaf) := by + intro input hquery + exact hrun input + (middleFold_query_mem_verify hdigest hadmissible hbottom hmiddle hquery) + have hmiddleFoldEq : + foldValue f publicKey.parameter middleLayer + (treeIndexAt (digestIndex digest) middleLayer) + (leafIndexAt (digestIndex digest) middleLayer) + (signaturePath signature middleLayer) middleLeaf (layerHeight middleLayer) = + foldValue g publicKey.parameter middleLayer + (treeIndexAt (digestIndex digest) middleLayer) + (leafIndexAt (digestIndex digest) middleLayer) + (signaturePath signature middleLayer) middleLeaf (layerHeight middleLayer) := by + exact hmiddleFoldRun.eval_eq hf hg + refine ⟨bottomLeaf, ?_, middleLeaf, ?_, ?_⟩ + · rw [← hftsEq, ← hbottomEq] + exact hbottom + · rw [← hbottomFoldEq, ← hmiddleEq] + exact hmiddle + · rcases hposition with hbottomPosition | hmiddlePosition | htopPosition + · exact Or.inl ⟨hbottomPosition.1, hbottomPosition.2.trans hftsEq⟩ + · exact Or.inr (Or.inl + ⟨hmiddlePosition.1, hmiddlePosition.2.trans hbottomFoldEq⟩) + · exact Or.inr (Or.inr ⟨htopPosition.1, htopPosition.2.trans hmiddleFoldEq⟩) + +set_option maxHeartbeats 2000000 in +theorem VerifyProbeWitnessAt.changeAnswerFn + {f g : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} + {forgedMessage : Message} {signature : Signature} {lay : Layer} + (hprobe : VerifyProbeWitnessAt f cache secretKey signingLog forgedMessage signature lay) + (hrun : CachedRun cache f + (verify ⟨secretKey.root, secretKey.parameter⟩ forgedMessage signature)) + (hf : cache.AgreesWithFn f) (hg : cache.AgreesWithFn g) : + VerifyProbeWitnessAt g cache secretKey signingLog forgedMessage signature lay := by + obtain ⟨digest, layerMessage, codeword, chainIdx, hdigit, probe, input, + hinput, hdigest, hadmissible, hencode, hverifierMessage, hhits, hmatches, hquery, + hcached, hnotCovered, hsourceSettled⟩ := hprobe + have hdigestRun : CachedRun cache f + (messageDigest secretKey.parameter secretKey.root forgedMessage signature.randomness) := by + intro query hquery + exact hrun query (messageDigest_query_mem_verify hquery) + have hdigest' : evalWithAnswerFn g + (messageDigest secretKey.parameter secretKey.root forgedMessage signature.randomness) = + digest := by + rw [← hdigestRun.eval_eq hf hg] + exact hdigest + have hotsRun : CachedRun cache f + (otsLeaf secretKey.parameter lay (treeIndexAt (digestIndex digest) lay) + (leafIndexAt (digestIndex digest) lay) layerMessage (signature.counter lay) + (signature.chainValue lay)) := by + intro query hquery + exact hrun query + (VerifierLayerMessage.otsLeaf_query_mem_verify hdigest hadmissible + hverifierMessage hquery) + have hencodeRun : CachedRun cache f + (encode secretKey.parameter lay (treeIndexAt (digestIndex digest) lay) + (leafIndexAt (digestIndex digest) lay) layerMessage (signature.counter lay)) := + hotsRun.bind_left + have hencode' : evalWithAnswerFn g + (encode secretKey.parameter lay (treeIndexAt (digestIndex digest) lay) + (leafIndexAt (digestIndex digest) lay) layerMessage (signature.counter lay)) = + some codeword := by + rw [← hencodeRun.eval_eq hf hg] + exact hencode + have hverifierMessage' : VerifierLayerMessage g secretKey.parameter + (digestIndex digest) (digestLeaves digest) signature lay layerMessage := by + exact VerifierLayerMessage.changeAnswerFn_of_cachedVerify + (f := f) (g := g) (cache := cache) + (publicKey := ⟨secretKey.root, secretKey.parameter⟩) + (forgedMessage := forgedMessage) (signature := signature) (digest := digest) + (lay := lay) (layerMessage := layerMessage) hverifierMessage hdigest hadmissible + hrun hf hg + have hhits' : probe.Hits g secretKey.parameter secretKey.otsSecret secretKey.ftsSecret := by + unfold Probe.Hits at hhits ⊢ + rw [← probe.target_eq_of_sourceSettled hf hg hsourceSettled] + exact hhits + have hquery' : input ∈ queriedInputs g + (verify ⟨secretKey.root, secretKey.parameter⟩ forgedMessage signature) := by + rw [← hrun.queriedInputs_eq hf hg] + exact hquery + have hnotCovered' : + ¬CoveredChainCoordinate g cache secretKey signingLog probe.coordinate := by + intro hcovered + exact hnotCovered (hcovered.changeAnswerFn hg hf) + refine ⟨digest, layerMessage, codeword, chainIdx, hdigit, probe, input, hinput, ?_⟩ + refine ⟨hdigest', ?_⟩ + refine ⟨hadmissible, ?_⟩ + refine ⟨hencode', ?_⟩ + refine ⟨hverifierMessage', ?_⟩ + refine ⟨hhits', ?_⟩ + refine ⟨hmatches, ?_⟩ + refine ⟨hquery', ?_⟩ + refine ⟨hcached, ?_⟩ + exact ⟨hnotCovered', hsourceSettled⟩ + +theorem VerifyProbeWitness.changeAnswerFn + {f g : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} + {forgedMessage : Message} {signature : Signature} + (hprobe : VerifyProbeWitness f cache secretKey signingLog forgedMessage signature) + (hrun : CachedRun cache f + (verify ⟨secretKey.root, secretKey.parameter⟩ forgedMessage signature)) + (hf : cache.AgreesWithFn f) (hg : cache.AgreesWithFn g) : + VerifyProbeWitness g cache secretKey signingLog forgedMessage signature := by + obtain ⟨lay, hprobe⟩ := hprobe + exact ⟨lay, hprobe.changeAnswerFn hrun hf hg⟩ + +def ResolvedCompletionVerifyProbe (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : ResolvedRunResult (RetainedGameResult × SplitHashCache)) + (actualValue : RetainedGameResult) (actualCache : QueryCache HashSpec) : Prop := + ∃ completion : Coordinate → HashOutput, + DeferredCompletion table result.context completion ∧ + VerifyProbeWitness + (tableAnswer parameter completion (fromCache (ordinaryQueryCache result.value.2))) + actualCache + (⟨parameter, actualValue.1, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + actualValue.2.1.2 actualValue.2.1.1.message actualValue.2.1.1.signature + +set_option maxHeartbeats 2000000 in +theorem resolvedCompletionVerifyProbe_of_winning_of_deferredCompletable + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : ResolvedRunResult (RetainedGameResult × SplitHashCache)) + (actualValue : RetainedGameResult) (actualCache : QueryCache HashSpec) + (hactual : (actualValue, actualCache) ∈ support + (actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table))) + (hrelation : ReachableResolvedRunRel parameter table (some result) + (actualValue, actualCache)) + (hcompletable : DeferredCompletable table result.context) + (hwitness : WinningRetainedVerifyProbeWitness parameter (extendStartTable table) + ftsSecret (actualValue, actualCache)) : + ResolvedCompletionVerifyProbe parameter table ftsSecret result actualValue actualCache := by + rcases hrelation with hclean | hdoomed + · obtain ⟨_, _, hinvariant, _, _⟩ := hclean + obtain ⟨completion, hcompletion⟩ := hcompletable + have hexecuted := winningRetainedVerifyProbe_imp_executed adversary parameter + (extendStartTable table) ftsSecret (actualValue, actualCache) hactual hwitness + obtain ⟨_, f, _, hf, _, _, _, _, _, _, hprobe, hrun⟩ := hexecuted + let fallback : QueryImpl HashSpec Id := + fromCache (ordinaryQueryCache result.value.2) + have hfallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback := + CacheAgreesWithFnOffTable.of_agrees + (agreesWithFn_fromCache (ordinaryQueryCache result.value.2)) + have hagrees : actualCache.AgreesWithFn + (tableAnswer parameter completion fallback) := + hinvariant.concreteCache_agreesWith_tableAnswer_of_fallback completion hcompletion + fallback hfallback + refine ⟨completion, hcompletion, ?_⟩ + exact hprobe.changeAnswerFn hrun hf hagrees + · exact False.elim (hdoomed.2.2.2 hcompletable) + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem not_completionVerifyProbe_of_reachableResolvedRunRel + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (result : ResolvedRunResult (RetainedGameResult × SplitHashCache)) + (actualValue : RetainedGameResult) (actualCache : QueryCache HashSpec) + (hresult : some result ∈ support + (runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table + ((maskedChronologicalRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) + (hactual : (actualValue, actualCache) ∈ support + (actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table))) + (hrelation : ReachableResolvedRunRel parameter table (some result) + (actualValue, actualCache)) + (completion : Coordinate → HashOutput) + (hcompletion : DeferredCompletion table result.context completion) + (hprobe : VerifyProbeWitness + (tableAnswer parameter completion (fromCache (ordinaryQueryCache result.value.2))) + actualCache + (⟨parameter, actualValue.1, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + actualValue.2.1.2 actualValue.2.1.1.message actualValue.2.1.1.signature) : False := by + rcases hrelation with hclean | hdoomed + · obtain ⟨htable, hvalue, hinvariant, _hclosed, _hpublished⟩ := hclean + have hactual' : (result.value.1, actualCache) ∈ support + (actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table)) := by + rw [hvalue] + exact hactual + have hprobe' : VerifyProbeWitness + (tableAnswer parameter completion (fromCache (ordinaryQueryCache result.value.2))) + actualCache + (⟨parameter, result.value.1.1, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + result.value.1.2.1.2 result.value.1.2.1.1.message + result.value.1.2.1.1.signature := by + rw [hvalue] + exact hprobe + let fallback : QueryImpl HashSpec Id := fromCache (ordinaryQueryCache result.value.2) + have hfallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback := + CacheAgreesWithFnOffTable.of_agrees + (agreesWithFn_fromCache (ordinaryQueryCache result.value.2)) + have hagrees : actualCache.AgreesWithFn + (tableAnswer parameter completion fallback) := + hinvariant.concreteCache_agreesWith_tableAnswer_of_fallback completion hcompletion + fallback hfallback + have hlogRuns := successfulSignRuns_of_mem_support_actualRetainedGameAfterTable adversary + (tableAnswer parameter completion fallback) parameter table ftsSecret result.value.1.1 + result.value.1.2.1.1 result.value.1.2.1.2 result.value.1.2.2 actualCache hactual' hagrees + exact not_verifyProbe_of_mem_runResolved_maskedChronologicalRetainedGame adversary parameter + table ftsSecret actualCache completion fallback fuel result hresult hcompletion hfallback + hlogRuns hprobe' + · exact hdoomed.2.2.2 ⟨completion, hcompletion⟩ + +theorem not_resolvedCompletionVerifyProbe_of_reachableResolvedRunRel + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (result : ResolvedRunResult (RetainedGameResult × SplitHashCache)) + (actualValue : RetainedGameResult) (actualCache : QueryCache HashSpec) + (hresult : some result ∈ support + (runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table + ((maskedChronologicalRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) + (hactual : (actualValue, actualCache) ∈ support + (actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table))) + (hrelation : ReachableResolvedRunRel parameter table (some result) + (actualValue, actualCache)) : + ¬ResolvedCompletionVerifyProbe parameter table ftsSecret result actualValue actualCache := by + rintro ⟨completion, hcompletion, hprobe⟩ + exact not_completionVerifyProbe_of_reachableResolvedRunRel adversary parameter table ftsSecret + fuel result actualValue actualCache hresult hactual hrelation completion hcompletion hprobe + +theorem not_deferredCompletable_of_winningRetainedVerifyProbe + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (result : ResolvedRunResult (RetainedGameResult × SplitHashCache)) + (actualValue : RetainedGameResult) (actualCache : QueryCache HashSpec) + (hresult : some result ∈ support + (runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table + ((maskedChronologicalRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) + (hactual : (actualValue, actualCache) ∈ support + (actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table))) + (hrelation : ReachableResolvedRunRel parameter table (some result) + (actualValue, actualCache)) + (hwitness : WinningRetainedVerifyProbeWitness parameter (extendStartTable table) + ftsSecret (actualValue, actualCache)) : + ¬DeferredCompletable table result.context := by + intro hcompletable + have hcompletionProbe := + resolvedCompletionVerifyProbe_of_winning_of_deferredCompletable adversary parameter table + ftsSecret result actualValue actualCache hactual hrelation hcompletable hwitness + exact (not_resolvedCompletionVerifyProbe_of_reachableResolvedRunRel adversary parameter table + ftsSecret fuel result actualValue actualCache hresult hactual hrelation) hcompletionProbe + +def ResolvedCompletionFailure (table : OtsSecretIndex → HashOutput) : + Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)) → Prop + | none => True + | some result => ¬DeferredCompletable table result.context + +theorem probEvent_winningRetainedVerifyProbe_le_resolvedCompletionFailure + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table)] ≤ + Pr[ResolvedCompletionFailure table | + runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table + ((maskedChronologicalRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache)] := by + let resolvedRun := runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table + ((maskedChronologicalRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache) + let actualRun := + actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table) + have hrel := relTriple_runResolvedFromTable_maskedChronologicalRetainedGame adversary parameter + table ftsSecret fuel + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hrel + (fun result => result ∈ support resolvedRun) (fun result hresult => hresult) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply probEvent_le_of_relTriple (relTriple_symm hboth) + intro actualResult resolvedResult hrelation hwitness + cases resolvedResult with + | none => trivial + | some result => + exact not_deferredCompletable_of_winningRetainedVerifyProbe adversary parameter table + ftsSecret fuel result actualResult.1 actualResult.2 hrelation.1.2 hrelation.2 + hrelation.1.1 hwitness + +theorem probEvent_resolvedCompletionFailure_le_finishResolvedRun_none + (table : OtsSecretIndex → HashOutput) + (run : ProbComp + (Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)))) + (htable : ∀ result, some result ∈ support run → result.table = table) : + Pr[ResolvedCompletionFailure table | run] ≤ + Pr[fun result => result = none | run >>= finishResolvedRun] := by + classical + calc + Pr[ResolvedCompletionFailure table | run] = + Pr[ResolvedCompletionFailure table | run >>= pure] := by rw [bind_pure] + _ ≤ Pr[fun result => result = none | run >>= finishResolvedRun] := by + apply probEvent_bind_le_bind_of_forall_le + intro result _hresult + cases result with + | none => simp [ResolvedCompletionFailure, finishResolvedRun] + | some result => + have hresultTable := htable result _hresult + by_cases hcompletable : DeferredCompletable table result.context + · have hfailure : ¬ResolvedCompletionFailure table (some result) := by + simpa [ResolvedCompletionFailure] using hcompletable + rw [probEvent_pure] + simp [hfailure] + · have hdoomed : ¬DeferredCompletable result.table result.context := by + rwa [hresultTable] + rw [finishResolvedRun_of_not_deferredCompletable result hdoomed] + simp [ResolvedCompletionFailure, hcompletable] + +theorem probEvent_winningRetainedVerifyProbe_le_finishedResolvedRun_none + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table)] ≤ + Pr[fun result => result = none | + runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table + ((maskedChronologicalRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache) >>= finishResolvedRun] := by + exact (probEvent_winningRetainedVerifyProbe_le_resolvedCompletionFailure adversary parameter + table ftsSecret fuel).trans + (probEvent_resolvedCompletionFailure_le_finishResolvedRun_none table _ (by + intro result hresult + exact (resolvedCore_of_mem_runResolvedFromTable + ((maskedChronologicalRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache) + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table result DeferredContext.valid_empty.valuesConsistent + (startTableAgrees_empty table) + hresult).1)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeChronologicalTerminal.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChronologicalTerminal.lean new file mode 100644 index 00000000..b3b4e563 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeChronologicalTerminal.lean @@ -0,0 +1,3670 @@ +import SphincsSecurity.Proof.OtsProbeResolvedSampling + +/-! +# Chronological one-time terminal argument + +Private chronological resolution may materialize a chain value without publishing it. The old `ChainState.ValidFor` invariant deliberately identifies materialization with publication, so it is not the right invariant for this game. This file tracks publication separately and uses deferred completions only for the one exact verifier probe supplied by terminal extraction. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec OracleComp.ProgramLogic.Relational + +theorem exists_right_of_relTriple_of_mem_support + {left : ProbComp alpha} {right : ProbComp beta} {relation : alpha → beta → Prop} + (hrel : RelTriple left right relation) {leftResult : alpha} + (hleft : leftResult ∈ support left) : + ∃ rightResult ∈ support right, relation leftResult rightResult := by + rw [relTriple_iff_relWP, relWP_iff_couplingPost] at hrel + obtain ⟨coupling, hrelation⟩ := hrel + have hleftDist : leftResult ∈ support 𝒟[left] := by + apply (mem_support_iff_evalDist_apply_ne_zero 𝒟[left] leftResult).2 + exact (mem_support_iff_evalDist_apply_ne_zero left leftResult).1 hleft + have hleftMapped : leftResult ∈ support (Prod.fst <$> coupling.1) := by + rw [coupling.2.map_fst] + exact hleftDist + rw [support_map] at hleftMapped + obtain ⟨pair, hpair, heq⟩ := hleftMapped + have hrightMapped : pair.2 ∈ support (Prod.snd <$> coupling.1) := by + rw [support_map] + exact ⟨pair, hpair, rfl⟩ + have hrightDist : pair.2 ∈ support 𝒟[right] := by + rw [← coupling.2.map_snd] + exact hrightMapped + have hright : pair.2 ∈ support right := by + apply (mem_support_iff_evalDist_apply_ne_zero right pair.2).2 + exact (mem_support_iff_evalDist_apply_ne_zero 𝒟[right] pair.2).1 hrightDist + exact ⟨pair.2, hright, heq ▸ hrelation pair hpair⟩ + +theorem ReachableResolvedRunRel.clean_of_completion + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {result : ResolvedRunResult (alpha × SplitHashCache)} + {value : alpha} {concreteCache : QueryCache HashSpec} + (hrelation : ReachableResolvedRunRel parameter table (some result) + (value, concreteCache)) + {completion : Coordinate → HashOutput} + (hcompletion : DeferredCompletion table result.context completion) : + result.value.1 = value ∧ + ResolvedContextInvariant parameter table result.context + (ordinaryQueryCache result.value.2) concreteCache ∧ + VisibleResolvedComputationsCached parameter table result.context concreteCache ∧ + PublishedValues result.context.state := by + rcases hrelation with hclean | hdoomed + · exact ⟨hclean.2.1, hclean.2.2.1, hclean.2.2.2.1, hclean.2.2.2.2⟩ + · exact False.elim (hdoomed.2.2.2 ⟨completion, hcompletion⟩) + +def IsPublishQuery : (LazyRevealProbe.World Coordinate).Domain → Prop + | .publish _ => True + | _ => False + +noncomputable instance : DecidablePred IsPublishQuery := fun query => by + exact Classical.propDecidable _ + +def ResolvedNoPublish + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) : Prop := + computation.IsQueryBoundP IsPublishQuery 0 + +theorem resolvedNoPublish_pure (value : alpha) : + ResolvedNoPublish + (pure value : OracleComp (LazyRevealProbe.World Coordinate) alpha) := by + simp [ResolvedNoPublish] + +theorem ResolvedNoPublish.bind + {left : OracleComp (LazyRevealProbe.World Coordinate) alpha} + {next : alpha → OracleComp (LazyRevealProbe.World Coordinate) beta} + (hleft : ResolvedNoPublish left) + (hnext : ∀ value ∈ support left, ResolvedNoPublish (next value)) : + ResolvedNoPublish (left >>= next) := by + simpa [ResolvedNoPublish] using + OracleComp.isQueryBoundP_bind (n := 0) (m := 0) hleft hnext + +theorem ResolvedNoPublish.bind_all + {left : OracleComp (LazyRevealProbe.World Coordinate) alpha} + {next : alpha → OracleComp (LazyRevealProbe.World Coordinate) beta} + (hleft : ResolvedNoPublish left) + (hnext : ∀ value, ResolvedNoPublish (next value)) : + ResolvedNoPublish (left >>= next) := + hleft.bind fun value _ => hnext value + +theorem resolvedNoPublish_simulateQ + (impl : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))) + (himpl : ∀ query cache, ResolvedNoPublish ((impl query).run cache)) + (computation : OracleComp spec alpha) (cache : SplitHashCache) : + ResolvedNoPublish ((simulateQ impl computation).run cache) := by + induction computation using OracleComp.inductionOn generalizing cache with + | pure value => + simp [simulateQ_pure, resolvedNoPublish_pure] + | query_bind query next ih => + rw [simulateQ_query_bind, StateT.run_bind] + exact (himpl query cache).bind_all fun result => + ih result.1 result.2 + +theorem resolvedNoPublish_sequenceFin {n : Nat} + (computation : Fin n → + OracleComp (LazyRevealProbe.World Coordinate) alpha) + (hcomponent : ∀ index, ResolvedNoPublish (computation index)) : + ResolvedNoPublish (sequenceFin computation) := by + induction n with + | zero => + simpa [sequenceFin] using resolvedNoPublish_pure Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomponent 0).bind_all fun head => + (ih (fun index : Fin n => computation index.succ) + (fun index => hcomponent index.succ)).bind_all fun tail => + resolvedNoPublish_pure (Fin.cases head tail : Fin (n + 1) → alpha) + +def NoPublish + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ cache, ResolvedNoPublish (computation.run cache) + +theorem NoPublish.pure (value : alpha) : + NoPublish (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro cache + simpa using resolvedNoPublish_pure (value, cache) + +theorem NoPublish.bind + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : NoPublish left) (hnext : ∀ value, NoPublish (next value)) : + NoPublish (left >>= next) := by + intro cache + rw [StateT.run_bind] + exact (hleft cache).bind_all fun result => hnext result.1 result.2 + +theorem noPublish_sequenceFin {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hcomponent : ∀ index, NoPublish (computation index)) : + NoPublish (sequenceFin computation) := by + induction n with + | zero => + simpa [sequenceFin] using NoPublish.pure Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomponent 0).bind fun head => + (ih (fun index : Fin n => computation index.succ) + (fun index => hcomponent index.succ)).bind fun tail => + NoPublish.pure (Fin.cases head tail : Fin (n + 1) → alpha) + +theorem noPublish_simulateQ + (impl : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))) + (himpl : ∀ query, NoPublish (impl query)) + (computation : OracleComp spec alpha) : + NoPublish (simulateQ impl computation) := by + intro cache + exact resolvedNoPublish_simulateQ impl (fun query cache => himpl query cache) + computation cache + +theorem revealed_eq_of_mem_runResolvedFromTable_of_noPublish + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult alpha) + (hnoPublish : ResolvedNoPublish computation) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table computation)) : + result.context.state.revealed = context.state.revealed := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runResolvedFromTable] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + rfl + | query_bind query next ih => + rw [ResolvedNoPublish, OracleComp.isQueryBoundP_query_bind_iff] at hnoPublish + cases query with + | uniform n => + rw [runResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel (by + simpa [ResolvedNoPublish, IsPublishQuery] using hnoPublish.2 output) hrest + | hashOutput => + rw [runResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel (by + simpa [ResolvedNoPublish, IsPublishQuery] using hnoPublish.2 output) hrest + | ensure coordinate => + rw [runResolvedFromTable_ensure_query_bind] at hresult + exact (ih () { context with state := context.state.ensure coordinate } fuel + (by simpa [ResolvedNoPublish, IsPublishQuery] using hnoPublish.2 ()) hresult).trans (by + rfl) + | probe coordinate candidate => + rw [runResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + simp only at hresult + by_cases hrevealed : coordinate ∈ context.state.revealed + · rw [if_pos hrevealed] at hresult + exact ih () context remaining (by + simpa [ResolvedNoPublish, IsPublishQuery] using hnoPublish.2 ()) hresult + · rw [if_neg hrevealed] at hresult + exact (ih () + { context with state := context.state.addPending coordinate candidate } + remaining (by + simpa [ResolvedNoPublish, IsPublishQuery] using hnoPublish.2 ()) + hresult).trans (by rfl) + | peek coordinate => + rw [runResolvedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel + (by simpa [ResolvedNoPublish, IsPublishQuery] using + hnoPublish.2 (context.state.values coordinate)) hresult + | publish coordinate => + simp [IsPublishQuery] at hnoPublish + | reveal coordinate => + rw [runResolvedFromTable_reveal_query_bind] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [pure_bind] at hresult + cases hresolved : resolveDeferredChainStart table + ⟨lay, tree, leafIdx, chainIdx⟩ context with + | none => simp [hresolved] at hresult + | some resolved => + simp only [hresolved] at hresult + have hfinal := ih resolved.output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) resolved.output + values := resolved.values } + fuel (by + simpa [ResolvedNoPublish, IsPublishQuery] using + hnoPublish.2 resolved.output) hresult + exact hfinal.trans (by rfl) + + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨resolved, _hresolved, hrest⟩ := hresult + cases resolved with + | none => simp at hrest + | some resolved => + have hfinal := ih resolved.output + { state := context.state.materialize (.position position) resolved.output + values := resolved.values } + fuel (by + simpa [ResolvedNoPublish, IsPublishQuery] using + hnoPublish.2 resolved.output) hrest + exact hfinal.trans (by rfl) + +def RevealedChainAllowed (allowed : Coordinate → Prop) + (state : LazyRevealProbe.State Coordinate) : Prop := + ∀ coordinate, IsChainCoordinate coordinate → + coordinate ∈ state.revealed → allowed coordinate + +theorem RevealedChainAllowed.mono + {initial final : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} + (hallowed : RevealedChainAllowed initial state) + (hle : ∀ coordinate, initial coordinate → final coordinate) : + RevealedChainAllowed final state := by + intro coordinate hchain hrevealed + exact hle coordinate (hallowed coordinate hchain hrevealed) + +def ResolvedPreservesChainPublication (allowed : Coordinate → Prop) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ context cache fuel table result completion, + context.ValuesConsistent → + StartTableAgrees context.state table → + RevealedChainAllowed allowed context.state → + some result ∈ support + (runResolvedFromTable context fuel table (computation.run cache)) → + DeferredCompletion table result.context completion → + RevealedChainAllowed allowed result.context.state + +theorem ResolvedPreservesChainPublication.pure + (allowed : Coordinate → Prop) (value : alpha) : + ResolvedPreservesChainPublication allowed + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro context cache fuel table result completion _ _ hallowed hresult _ + simp [runResolvedFromTable] at hresult + subst result + exact hallowed + +theorem ResolvedPreservesChainPublication.bind + {allowed : Coordinate → Prop} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : ResolvedPreservesChainPublication allowed left) + (hnext : ∀ value, ResolvedPreservesChainPublication allowed (next value)) : + ResolvedPreservesChainPublication allowed (left >>= next) := by + intro context cache fuel table result completion hconsistent hstarts hallowed hresult + hcompletion + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨middle, hmiddle, hrest⟩ := hresult + cases middle with + | none => simp at hrest + | some middle => + have hcore := resolvedCore_of_mem_runResolvedFromTable (left.run cache) context fuel table + middle hconsistent hstarts hmiddle + simp only at hrest + rw [hcore.1] at hrest + have hmiddleCompletion : DeferredCompletion table middle.context completion := + hcompletion.of_mem_runResolvedFromTable ((next middle.value.1).run middle.value.2) + middle.context middle.remaining table result completion hcore.2.1 hcore.2.2 hrest + have hmiddleAllowed := hleft context cache fuel table middle completion hconsistent hstarts + hallowed hmiddle hmiddleCompletion + exact hnext middle.value.1 middle.context middle.value.2 middle.remaining table result + completion hcore.2.1 hcore.2.2 hmiddleAllowed hrest hcompletion + +theorem ResolvedPreservesChainPublication.of_noPublish + (allowed : Coordinate → Prop) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hnoPublish : ∀ cache, ResolvedNoPublish (computation.run cache)) : + ResolvedPreservesChainPublication allowed computation := by + intro context cache fuel table result completion _ _ hallowed hresult _ + have hreveal := revealed_eq_of_mem_runResolvedFromTable_of_noPublish + (computation.run cache) context fuel table result (hnoPublish cache) hresult + intro coordinate hchain hrevealed + apply hallowed coordinate hchain + rw [← hreveal] + exact hrevealed + +theorem resolvedPreservesChainPublication_sequenceFin + {allowed : Coordinate → Prop} {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hcomponent : ∀ index, + ResolvedPreservesChainPublication allowed (computation index)) : + ResolvedPreservesChainPublication allowed (sequenceFin computation) := by + induction n with + | zero => + simpa [sequenceFin] using + ResolvedPreservesChainPublication.pure allowed Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomponent 0).bind fun head => + (ih (fun index : Fin n => computation index.succ) + (fun index => hcomponent index.succ)).bind fun tail => + ResolvedPreservesChainPublication.pure allowed + (Fin.cases head tail : Fin (n + 1) → alpha) + +theorem resolvedPreservesChainPublication_simulateQ + {spec : OracleSpec ι} (allowed : Coordinate → Prop) + (impl : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))) + (himpl : ∀ query, ResolvedPreservesChainPublication allowed (impl query)) + (computation : OracleComp spec alpha) : + ResolvedPreservesChainPublication allowed (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp only [simulateQ_pure] + exact ResolvedPreservesChainPublication.pure allowed value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (himpl query).bind fun output => ih output + +theorem resolvedPreservesChainPublication_publishCoordinate + (allowed : Coordinate → Prop) (coordinate : Coordinate) + (hcoordinate : IsChainCoordinate coordinate → allowed coordinate) : + ResolvedPreservesChainPublication allowed (publishCoordinate coordinate) := by + intro context cache fuel table result completion _ _ hallowed hresult _ + unfold publishCoordinate at hresult + rw [StateT.run_liftM, LazyRevealProbe.publishQuery, + runResolvedFromTable_publish_query_bind] at hresult + simp [runResolvedFromTable] at hresult + subst result + intro other hchain hrevealed + simp only [LazyRevealProbe.State.publish, Finset.mem_insert] at hrevealed + rcases hrevealed with rfl | hrevealed + · exact hcoordinate hchain + · exact hallowed other hchain hrevealed + +theorem resolvedNoPublish_splitHashQuery (key : SplitHashKey) (cache : SplitHashCache) : + ResolvedNoPublish ((splitHashQuery key).run cache) := by + unfold splitHashQuery + cases hlookup : cache key <;> + simp [hlookup, ResolvedNoPublish, IsPublishQuery, StateT.run_bind, StateT.run_get, + StateT.run_set, LazyRevealProbe.hashOutputQuery] + +theorem resolvedNoPublish_ensureCoordinate (coordinate : Coordinate) + (cache : SplitHashCache) : + ResolvedNoPublish ((ensureCoordinate coordinate).run cache) := by + simp [ensureCoordinate, ResolvedNoPublish, LazyRevealProbe.ensureQuery, IsPublishQuery] + +theorem resolvedNoPublish_revealCoordinate (coordinate : Coordinate) + (cache : SplitHashCache) : + ResolvedNoPublish ((revealCoordinate coordinate).run cache) := by + rw [revealCoordinate_run] + simp [ResolvedNoPublish, LazyRevealProbe.revealQuery, IsPublishQuery] + +theorem resolvedNoPublish_revealCoordinateOutput (coordinate : Coordinate) + (cache : SplitHashCache) : + ResolvedNoPublish ((revealCoordinateOutput coordinate).run cache) := by + unfold revealCoordinateOutput + simp [ResolvedNoPublish, IsPublishQuery, StateT.run_bind, + StateT.run_modify, LazyRevealProbe.revealQuery] + +theorem resolvedPreservesChainPublication_revealPublishedCoordinate + (allowed : Coordinate → Prop) (coordinate : Coordinate) + (hcoordinate : IsChainCoordinate coordinate → allowed coordinate) : + ResolvedPreservesChainPublication allowed (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + exact (ResolvedPreservesChainPublication.of_noPublish allowed (revealCoordinate coordinate) + fun cache => resolvedNoPublish_revealCoordinate coordinate cache).bind fun _ => + (resolvedPreservesChainPublication_publishCoordinate allowed coordinate hcoordinate).bind + fun _ => ResolvedPreservesChainPublication.pure allowed _ + +theorem resolvedPreservesChainPublication_revealLayerValues + (allowed : Coordinate → Prop) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) + (hallowed : ∀ chainIdx, + allowed (chainValueCoordinate lay (treeIndexAt index lay) + (leafIndexAt index lay) chainIdx (encoding chainIdx))) : + ResolvedPreservesChainPublication allowed + (revealLayerValues index lay encoding) := by + unfold revealLayerValues + apply (resolvedPreservesChainPublication_sequenceFin _ fun chainIdx => + resolvedPreservesChainPublication_revealPublishedCoordinate allowed _ fun _ => + hallowed chainIdx).bind + intro values + let pathComputation : Fin maxLayerHeight → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Digest := fun level => + if level.val < layerHeight lay then + match level.val with + | 0 => revealPublishedCoordinate (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | current + 1 => + if hlevel : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hlevel⟩ + (leafOfNat (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0 + else pure 0 + change ResolvedPreservesChainPublication allowed + (sequenceFin pathComputation >>= fun path => pure (values, path)) + have hpath : ResolvedPreservesChainPublication allowed + (sequenceFin pathComputation) := + resolvedPreservesChainPublication_sequenceFin pathComputation fun level => by + dsimp only [pathComputation] + by_cases hinLayer : level.val < layerHeight lay + · simp only [hinLayer, if_pos] + cases hlevel : level.val with + | zero => + exact resolvedPreservesChainPublication_revealPublishedCoordinate allowed _ + (by simp [IsChainCoordinate]) + | succ current => + by_cases hcurrent : current < maxLayerHeight + · simp only [hcurrent, dite_true] + exact resolvedPreservesChainPublication_revealPublishedCoordinate allowed _ + (by simp [IsChainCoordinate]) + · simp only [hcurrent, dite_false] + exact ResolvedPreservesChainPublication.pure allowed 0 + · simp only [hinLayer, if_false] + exact ResolvedPreservesChainPublication.pure allowed 0 + exact ResolvedPreservesChainPublication.bind + (allowed := allowed) (left := sequenceFin pathComputation) + (next := fun path => pure (values, path)) hpath fun path => + ResolvedPreservesChainPublication.pure allowed (values, path) + +theorem resolvedNoPublish_peekCoordinate (coordinate : Coordinate) + (cache : SplitHashCache) : + ResolvedNoPublish ((peekCoordinate coordinate).run cache) := by + unfold peekCoordinate + rw [StateT.run_bind] + change ResolvedNoPublish + (LazyRevealProbe.peekQuery coordinate >>= fun output => pure (_, cache)) + simp [ResolvedNoPublish, LazyRevealProbe.peekQuery, IsPublishQuery] + +theorem resolvedNoPublish_peekPositionValues (positions : List Position) + (cache : SplitHashCache) : + ResolvedNoPublish ((peekPositionValues positions).run cache) := by + induction positions generalizing cache with + | nil => simp [peekPositionValues, resolvedNoPublish_pure] + | cons position remaining ih => + rw [peekPositionValues, StateT.run_bind] + exact (resolvedNoPublish_peekCoordinate (.position position) cache).bind_all fun result => + match result.1 with + | none => resolvedNoPublish_pure (none, result.2) + | some value => by + rw [StateT.run_bind] + exact (ih result.2).bind_all fun rest => + match rest.1 with + | none => resolvedNoPublish_pure (none, rest.2) + | some values => resolvedNoPublish_pure (some (value :: values), rest.2) + +theorem resolvedNoPublish_peekTableInput (parameter : PublicParameter) + (coordinate : Coordinate) (cache : SplitHashCache) : + ResolvedNoPublish ((peekTableInput parameter coordinate).run cache) := by + have hchildren (position : Position) : ResolvedNoPublish ((do + match ← peekPositionValues position.children with + | none => pure none + | some values => + pure (some (tweakableHashInput parameter position.domain + (values.flatMap digestBytes)))).run cache) := by + rw [StateT.run_bind] + exact (resolvedNoPublish_peekPositionValues position.children cache).bind_all fun result => + match result.1 with + | none => resolvedNoPublish_pure (none, result.2) + | some values => resolvedNoPublish_pure (some + (tweakableHashInput parameter position.domain + (values.flatMap digestBytes)), result.2) + cases coordinate with + | chainStart => simp [peekTableInput, resolvedNoPublish_pure] + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput] + by_cases hzero : step.val = 0 + · rw [if_pos hzero, StateT.run_bind] + exact (resolvedNoPublish_peekCoordinate + (.chainStart lay tree leafIdx chainIdx) cache).bind_all fun result => + match result.1 with + | none => resolvedNoPublish_pure (none, result.2) + | some value => resolvedNoPublish_pure (some + (tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx step) (digestBytes value)), result.2) + · rw [if_neg hzero, StateT.run_bind] + exact (resolvedNoPublish_peekPositionValues + (Position.chain lay tree leafIdx chainIdx step).children cache).bind_all fun result => + match result.1 with + | none => resolvedNoPublish_pure (none, result.2) + | some values => resolvedNoPublish_pure (some + (tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx step) + (values.flatMap digestBytes)), result.2) + | leaf lay tree leafIdx => + rw [peekTableInput] + · exact hchildren (.leaf lay tree leafIdx) + · simp + | node lay tree level nodeIdx => + rw [peekTableInput] + · exact hchildren (.node lay tree level nodeIdx) + · simp + | ftsLeaf index tree leafIdx => + rw [peekTableInput] + · exact hchildren (.ftsLeaf index tree leafIdx) + · simp + | ftsNode index tree level nodeIdx => + rw [peekTableInput] + · exact hchildren (.ftsNode index tree level nodeIdx) + · simp + | ftsRoots index => + rw [peekTableInput] + · exact hchildren (.ftsRoots index) + · simp + +theorem resolvedNoPublish_modify + (update : SplitHashCache → SplitHashCache) (cache : SplitHashCache) : + ResolvedNoPublish + ((modify update : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit).run cache) := by + simp [StateT.run_modify, resolvedNoPublish_pure] + +theorem resolvedPreservesChainPublication_resolveKnownInput + (allowed : Coordinate → Prop) (parameter : PublicParameter) + (coordinate : Coordinate) (input : HashInput) + (hcoordinate : IsChainCoordinate coordinate → allowed coordinate) : + ResolvedPreservesChainPublication allowed + (resolveKnownInput parameter coordinate input) := by + unfold resolveKnownInput + apply (ResolvedPreservesChainPublication.of_noPublish allowed + (peekTableInput parameter coordinate) + fun cache => resolvedNoPublish_peekTableInput parameter coordinate cache).bind + intro known + cases known with + | none => + exact ResolvedPreservesChainPublication.of_noPublish allowed + (splitHashQuery (.ordinary input)) fun cache => + resolvedNoPublish_splitHashQuery (.ordinary input) cache + | some knownInput => + simp only + by_cases heq : knownInput = input + · rw [if_pos heq] + apply (ResolvedPreservesChainPublication.of_noPublish allowed + (revealCoordinateOutput coordinate) + fun cache => resolvedNoPublish_revealCoordinateOutput coordinate cache).bind + intro output + apply (resolvedPreservesChainPublication_publishCoordinate allowed coordinate + hcoordinate).bind + intro _ + apply (ResolvedPreservesChainPublication.of_noPublish allowed + (modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output)) fun cache => + resolvedNoPublish_modify _ cache).bind + intro _ + exact ResolvedPreservesChainPublication.pure allowed output + · rw [if_neg heq] + exact ResolvedPreservesChainPublication.of_noPublish allowed + (splitHashQuery (.ordinary input)) fun cache => + resolvedNoPublish_splitHashQuery (.ordinary input) cache + +theorem revealed_eq_of_mem_runResolvedFromTable_resolveKnownInput_completionOrdinary + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {coordinate : Coordinate} {input : HashInput} + {context : DeferredContext} {fuel : Nat} {cache : SplitHashCache} + {result : ResolvedRunResult (HashOutput × SplitHashCache)} + {completion : Coordinate → HashOutput} + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hots : ∀ position, coordinate = .position position → IsOtsPosition position) + (hordinary : CompletionOrdinaryInput parameter table context input) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((resolveKnownInput parameter coordinate input).run cache))) + (hcompletion : DeferredCompletion table result.context completion) : + result.context.state.revealed = context.state.revealed := by + have hcompletionStart : DeferredCompletion table context completion := + hcompletion.of_mem_runResolvedFromTable + ((resolveKnownInput parameter coordinate input).run cache) context fuel table result + completion hconsistent hstarts hresult + unfold resolveKnownInput at hresult + rw [StateT.run_bind, runResolvedFromTable_bind] at hresult + by_cases havailable : TableInputAvailable completion context.state coordinate + · rw [runResolvedFromTable_peekTableInput_of_available parameter completion context fuel table + cache coordinate havailable] at hresult + simp only [pure_bind] at hresult + have hne : tableInput parameter completion coordinate ≠ input := by + intro heq + cases coordinate with + | chainStart => simp [TableInputAvailable] at havailable + | position position => + exact hordinary completion hcompletionStart position (hots position rfl) heq.symm + rw [if_neg hne] at hresult + exact revealed_eq_of_mem_runResolvedFromTable_of_noPublish + ((splitHashQuery (.ordinary input)).run cache) context fuel table result + (resolvedNoPublish_splitHashQuery (.ordinary input) cache) hresult + · rw [runResolvedFromTable_peekTableInput_of_unavailable parameter completion context fuel table + cache coordinate hcompletionStart hots havailable] at hresult + simp only [pure_bind] at hresult + exact revealed_eq_of_mem_runResolvedFromTable_of_noPublish + ((splitHashQuery (.ordinary input)).run cache) context fuel table result + (resolvedNoPublish_splitHashQuery (.ordinary input) cache) hresult + +theorem resolvedNoPublish_probe (candidate : Probe) (cache : SplitHashCache) : + ResolvedNoPublish ((probe candidate).run cache) := by + unfold probe + rw [StateT.run_liftM] + simp [ResolvedNoPublish, LazyRevealProbe.probeQuery, IsPublishQuery] + +theorem resolvedNoPublish_probeFirstMissingInputCoordinate + (input : HashInput) (slot : Nat) (coordinates : List Coordinate) + (cache : SplitHashCache) : + ResolvedNoPublish + ((probeFirstMissingInputCoordinate input slot coordinates).run cache) := by + induction coordinates generalizing slot cache with + | nil => simp [probeFirstMissingInputCoordinate, resolvedNoPublish_pure] + | cons coordinate remaining ih => + rw [probeFirstMissingInputCoordinate, StateT.run_bind] + exact (resolvedNoPublish_peekCoordinate coordinate cache).bind_all fun result => + match result.1 with + | none => resolvedNoPublish_probe ⟨coordinate, slotDigest slot input⟩ result.2 + | some _ => ih (slot + 1) result.2 + +theorem resolvedNoPublish_prepareLeafInputProbe + (input : HashInput) (candidate : Probe) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (cache : SplitHashCache) : + ResolvedNoPublish + ((prepareLeafInputProbe input candidate lay tree leafIdx).run cache) := by + unfold prepareLeafInputProbe + rw [StateT.run_bind] + exact (resolvedNoPublish_peekCoordinate candidate.coordinate cache).bind_all fun result => + match result.1 with + | none => resolvedNoPublish_probe candidate result.2 + | some _ => resolvedNoPublish_probeFirstMissingInputCoordinate input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) result.2 + +theorem resolvedPreservesChainPublication_probingHashQuery_chain + (allowed : Coordinate → Prop) (parameter : PublicParameter) + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (step : ChainStep) + (hprobe : decodeProbe? parameter input = some candidate) + (hposition : decodePosition? parameter input = + some (.chain lay tree leafIdx chainIdx step)) + (hforward : ChainForwardClosed allowed) : + ResolvedPreservesChainPublication allowed (probingHashQuery parameter input) := by + have hmatches := (decodeProbe?_eq_some_iff parameter input candidate).1 hprobe + have hsourceChain := candidate.isChainCoordinate_of_matchesInput hmatches + have houtput := decodeProbe?_outputCoordinate_eq_position parameter input candidate + (.chain lay tree leafIdx chainIdx step) hprobe hposition + intro context cache fuel table result completion hconsistent hstarts hallowed hresult + hcompletion + unfold probingHashQuery at hresult + rw [hprobe, hposition] at hresult + simp only at hresult + rw [houtput, StateT.run_bind, runResolvedFromTable_bind] at hresult + unfold probe at hresult + rw [StateT.run_liftM, LazyRevealProbe.probeQuery, + runResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + rw [show remaining + 1 = Nat.succ remaining by omega] at hresult + simp only at hresult + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · rw [if_pos hrevealed] at hresult + have houtputAllowed : IsChainCoordinate + (.position (.chain lay tree leafIdx chainIdx step)) → + allowed (.position (.chain lay tree leafIdx chainIdx step)) := by + intro houtputChain + rw [← houtput] + exact hforward candidate (hallowed candidate.coordinate hsourceChain hrevealed) + (houtput ▸ houtputChain) + exact resolvedPreservesChainPublication_resolveKnownInput allowed parameter + (.position (.chain lay tree leafIdx chainIdx step)) input houtputAllowed context cache + remaining table result completion hconsistent hstarts hallowed hresult hcompletion + · rw [if_neg hrevealed] at hresult + simp only [runResolvedFromTable, pure_bind] at hresult + let probeContext : DeferredContext := + { context with state := + context.state.addPending candidate.coordinate candidate.candidate } + change some result ∈ support + (runResolvedFromTable probeContext remaining table + ((resolveKnownInput parameter + (.position (.chain lay tree leafIdx chainIdx step)) input).run cache)) at hresult + have hpending : (candidate.coordinate, candidate.candidate) ∈ + probeContext.state.pending := by + simp [probeContext, LazyRevealProbe.State.addPending] + have hordinary : CompletionOrdinaryInput parameter table probeContext input := + completionOrdinaryInput_of_pending_decodedProbe hprobe hpending + have hreveal := + revealed_eq_of_mem_runResolvedFromTable_resolveKnownInput_completionOrdinary + (parameter := parameter) (table := table) + (coordinate := .position (.chain lay tree leafIdx chainIdx step)) + (context := probeContext) (fuel := remaining) (cache := cache) + (result := result) (completion := completion) + (hconsistent.addPending candidate.coordinate candidate.candidate) + (hstarts.addPending candidate.coordinate candidate.candidate) + (fun position heq => by cases heq; simp [IsOtsPosition]) hordinary + hresult hcompletion + intro coordinate hchain hcoordinateRevealed + apply hallowed coordinate hchain + have hprobeRevealed : coordinate ∈ probeContext.state.revealed := by + rw [← hreveal] + exact hcoordinateRevealed + simpa [probeContext, LazyRevealProbe.State.addPending] using hprobeRevealed + +theorem resolvedPreservesChainPublication_probingHashQuery + (allowed : Coordinate → Prop) (parameter : PublicParameter) + (input : HashInput) (hforward : ChainForwardClosed allowed) : + ResolvedPreservesChainPublication allowed (probingHashQuery parameter input) := by + cases hprobe : decodeProbe? parameter input with + | some candidate => + rcases decodePosition?_chain_or_leaf_of_decodeProbe? parameter input candidate hprobe with + ⟨lay, tree, leafIdx, chainIdx, step, hposition⟩ | + ⟨lay, tree, leafIdx, hposition⟩ + · exact resolvedPreservesChainPublication_probingHashQuery_chain allowed parameter input + candidate lay tree leafIdx chainIdx step hprobe hposition hforward + · have houtput := decodeProbe?_outputCoordinate_eq_position parameter input candidate + (.leaf lay tree leafIdx) hprobe hposition + unfold probingHashQuery + rw [hprobe, hposition] + simp only + apply (ResolvedPreservesChainPublication.of_noPublish allowed + (prepareLeafInputProbe input candidate lay tree leafIdx) fun cache => + resolvedNoPublish_prepareLeafInputProbe input candidate lay tree leafIdx cache).bind + intro _ + rw [houtput] + exact resolvedPreservesChainPublication_resolveKnownInput allowed parameter + (.position (.leaf lay tree leafIdx)) input (by simp [IsChainCoordinate]) + | none => + cases hposition : decodePosition? parameter input with + | none => + exact ResolvedPreservesChainPublication.of_noPublish allowed + (probingHashQuery parameter input) fun cache => by + unfold probingHashQuery + rw [hprobe, hposition] + exact resolvedNoPublish_splitHashQuery (.ordinary input) cache + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + intro context cache fuel table result completion hconsistent hstarts hallowed + hresult hcompletion + have hordinary := completionOrdinaryInput_of_decodeProbe_none_chain + (table := table) (context := context) hprobe hposition + unfold probingHashQuery at hresult + rw [hprobe, hposition] at hresult + have hreveal := + revealed_eq_of_mem_runResolvedFromTable_resolveKnownInput_completionOrdinary + (parameter := parameter) (table := table) + (coordinate := .position (.chain lay tree leafIdx chainIdx step)) + (context := context) (fuel := fuel) (cache := cache) (result := result) + (completion := completion) hconsistent hstarts + (fun other heq => by cases heq; simp [IsOtsPosition]) hordinary hresult + hcompletion + intro coordinate hchain hrevealed + apply hallowed coordinate hchain + rw [← hreveal] + exact hrevealed + | leaf lay tree leafIdx => + intro context cache fuel table result completion hconsistent hstarts hallowed + hresult hcompletion + have hordinary := completionOrdinaryInput_of_decodeProbe_none_leaf + (table := table) (context := context) hprobe hposition + unfold probingHashQuery at hresult + rw [hprobe, hposition] at hresult + have hreveal := + revealed_eq_of_mem_runResolvedFromTable_resolveKnownInput_completionOrdinary + (parameter := parameter) (table := table) + (coordinate := .position (.leaf lay tree leafIdx)) + (context := context) (fuel := fuel) (cache := cache) (result := result) + (completion := completion) hconsistent hstarts + (fun other heq => by cases heq; simp [IsOtsPosition]) hordinary hresult + hcompletion + intro coordinate hchain hrevealed + apply hallowed coordinate hchain + rw [← hreveal] + exact hrevealed + | node lay tree level nodeIdx => + unfold probingHashQuery + rw [hprobe, hposition] + simp only + apply (ResolvedPreservesChainPublication.of_noPublish allowed + (probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)) + fun cache => resolvedNoPublish_probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position) + cache).bind + intro _ + exact resolvedPreservesChainPublication_resolveKnownInput allowed parameter + (.position (.node lay tree level nodeIdx)) input (by simp [IsChainCoordinate]) + | ftsLeaf index tree leafIdx => + exact ResolvedPreservesChainPublication.of_noPublish allowed + (probingHashQuery parameter input) fun cache => by + unfold probingHashQuery + rw [hprobe, hposition] + exact resolvedNoPublish_splitHashQuery (.ordinary input) cache + + | ftsNode index tree level nodeIdx => + exact ResolvedPreservesChainPublication.of_noPublish allowed + (probingHashQuery parameter input) fun cache => by + unfold probingHashQuery + rw [hprobe, hposition] + exact resolvedNoPublish_splitHashQuery (.ordinary input) cache + | ftsRoots index => + exact ResolvedPreservesChainPublication.of_noPublish allowed + (probingHashQuery parameter input) fun cache => by + unfold probingHashQuery + rw [hprobe, hposition] + exact resolvedNoPublish_splitHashQuery (.ordinary input) cache + +theorem resolvedNoPublish_splitUniformImpl (query : Nat) (cache : SplitHashCache) : + ResolvedNoPublish ((splitUniformImpl query).run cache) := by + simp [splitUniformImpl, ResolvedNoPublish, LazyRevealProbe.uniformQuery, IsPublishQuery] + +theorem resolvedNoPublish_ordinaryHashImpl (input : HashInput) (cache : SplitHashCache) : + ResolvedNoPublish ((ordinaryHashImpl input).run cache) := + resolvedNoPublish_splitHashQuery (.ordinary input) cache + +theorem resolvedNoPublish_ordinaryRomImpl (query : OracleWorld.Domain) + (cache : SplitHashCache) : + ResolvedNoPublish ((ordinaryRomImpl query).run cache) := by + cases query with + | inl query => exact resolvedNoPublish_splitUniformImpl query cache + | inr input => exact resolvedNoPublish_ordinaryHashImpl input cache + +theorem noPublish_ensureCoordinate (coordinate : Coordinate) : + NoPublish (ensureCoordinate coordinate) := + resolvedNoPublish_ensureCoordinate coordinate + +theorem noPublish_revealCoordinate (coordinate : Coordinate) : + NoPublish (revealCoordinate coordinate) := + resolvedNoPublish_revealCoordinate coordinate + +theorem noPublish_revealPosition (position : Position) : + NoPublish (revealPosition position) := + noPublish_revealCoordinate (.position position) + +theorem noPublish_simulateQ_ordinaryHashImpl + (computation : OracleComp HashSpec alpha) : + NoPublish (simulateQ ordinaryHashImpl computation) := + noPublish_simulateQ ordinaryHashImpl + (fun input cache => resolvedNoPublish_ordinaryHashImpl input cache) computation + +theorem noPublish_simulateQ_ordinaryRomImpl + (computation : OracleComp OracleWorld alpha) : + NoPublish (simulateQ ordinaryRomImpl computation) := + noPublish_simulateQ ordinaryRomImpl + (fun input cache => resolvedNoPublish_ordinaryRomImpl input cache) computation + +theorem noPublish_ensureFullChain (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + NoPublish (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (noPublish_sequenceFin _ fun step => + noPublish_ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step))).bind + fun _ => NoPublish.pure () + +theorem noPublish_ensureChainPrefix (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + NoPublish (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (noPublish_sequenceFin _ fun step => by + split + · exact noPublish_ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + · exact NoPublish.pure ()).bind fun _ => NoPublish.pure () + +theorem noPublish_ensureOtsLeaf (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : NoPublish (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (noPublish_sequenceFin _ fun chainIdx => + noPublish_ensureFullChain lay tree leafIdx chainIdx).bind fun _ => + noPublish_ensureCoordinate (.position (.leaf lay tree leafIdx)) + +theorem noPublish_ensureTreeNode (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, NoPublish (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => noPublish_ensureOtsLeaf lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (noPublish_ensureTreeNode lay tree level (2 * nodeIdx)).bind fun _ => + (noPublish_ensureTreeNode lay tree level (2 * nodeIdx + 1)).bind fun _ => by + split + · exact noPublish_ensureCoordinate (.position + (.node lay tree ⟨level, by assumption⟩ (leafOfNat nodeIdx))) + · exact NoPublish.pure () + +theorem noPublish_maskedTreeNode (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) : NoPublish (maskedTreeNode lay tree level nodeIdx) := by + cases level with + | zero => + rw [maskedTreeNode] + exact (noPublish_ensureTreeNode lay tree 0 nodeIdx).bind fun _ => + noPublish_revealPosition (.leaf lay tree (leafOfNat nodeIdx)) + | succ current => + rw [maskedTreeNode] + exact (noPublish_ensureTreeNode lay tree (current + 1) nodeIdx).bind fun _ => by + split + · exact noPublish_revealPosition + (.node lay tree ⟨current, by assumption⟩ (leafOfNat nodeIdx)) + · exact NoPublish.pure 0 + +theorem noPublish_maskedTreeRoot (lay : Layer) (tree : TreeIndex) : + NoPublish (maskedTreeRoot lay tree) := + noPublish_maskedTreeNode lay tree (layerHeight lay) 0 + +theorem noPublish_ensureTreePath (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : NoPublish (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (noPublish_sequenceFin _ fun level => by + split + · exact noPublish_ensureTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · exact NoPublish.pure ()).bind fun _ => NoPublish.pure () + +theorem noPublish_maskedOtsSignFrom (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter, + NoPublish (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, _ => NoPublish.pure none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + exact (noPublish_simulateQ_ordinaryHashImpl + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter))).bind fun encoded => by + cases encoded with + | none => + exact noPublish_maskedOtsSignFrom parameter lay tree leafIdx message attempts + (counter + 1) + | some encoding => + exact (noPublish_sequenceFin _ fun chainIdx => + noPublish_ensureChainPrefix lay tree leafIdx chainIdx + (encoding chainIdx)).bind fun _ => NoPublish.pure _ + +theorem noPublish_maskedOtsSign (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + NoPublish (maskedOtsSign parameter lay tree leafIdx message) := + noPublish_maskedOtsSignFrom parameter lay tree leafIdx message encodingAttemptLimit 0 + +theorem noPublish_maskedLayerMessage (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + NoPublish (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + split + · exact noPublish_maskedTreeRoot _ _ + · exact noPublish_simulateQ_ordinaryHashImpl _ + +theorem noPublish_maskedSignLayer (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + NoPublish (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + exact (noPublish_maskedLayerMessage parameter ftsSecret index lay).bind fun message => + (noPublish_maskedOtsSign parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message).bind fun signed => by + cases signed with + | none => exact NoPublish.pure none + | some part => + exact (noPublish_ensureTreePath lay (treeIndexAt index lay) + (leafIndexAt index lay)).bind fun _ => NoPublish.pure (some part) + +theorem resolvedOtsSelectFrom_replay + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter initial final result, + (result, final) ∈ support + ((resolvedOtsSelectFrom parameter lay tree leafIdx message attempts counter).run initial) → + final.AgreesWithFn f → + initial ≤ final ∧ ∀ selectedCounter encoding, result = some (selectedCounter, encoding) → + evalWithAnswerFn f + (encode parameter lay tree leafIdx message selectedCounter) = some encoding ∧ + CachedRun final f (encode parameter lay tree leafIdx message selectedCounter) + | 0, counter, initial, final, result, hresult, _ => by + simp [resolvedOtsSelectFrom] at hresult + rcases hresult with ⟨rfl, rfl⟩ + exact ⟨le_rfl, by simp⟩ + | attempts + 1, counter, initial, final, result, hresult, hf => by + rw [resolvedOtsSelectFrom, StateT.run_bind, mem_support_bind_iff] at hresult + obtain ⟨⟨encoded, encodedCache⟩, hencoded, hrest⟩ := hresult + cases encoded with + | none => + have hqueryLe := FtsProbeSimulation.simulateQ_randomOracle_cache_le + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) + initial encodedCache none hencoded + have htail := resolvedOtsSelectFrom_replay f parameter lay tree leafIdx message attempts + (counter + 1) encodedCache final result hrest hf + exact ⟨hqueryLe.trans htail.1, htail.2⟩ + | some encoding => + simp only [StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq] at hrest + rcases hrest with ⟨rfl, rfl⟩ + obtain ⟨hle, heval, hcached⟩ := replay_of_mem_support + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) + initial (some encoding) final hencoded f hf + refine ⟨hle, ?_⟩ + intro selectedCounter selectedEncoding heq + rcases Option.some.inj heq with ⟨rfl, rfl⟩ + exact ⟨heval, hcached⟩ + +theorem resolvedSignLayer_some_honest_eval + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) + (initial final : QueryCache HashSpec) (counter : Counter) + (encoding : ChainIndex → Digit) + (hresult : (some (counter, encoding), final) ∈ support + ((resolvedSignLayer parameter table ftsSecret index lay).run initial)) + (hf : final.AgreesWithFn f) : + evalWithAnswerFn f + (encode parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f + (layerMessage + (⟨parameter, root, + fun selectedLay selectedTree selectedLeaf selectedChain => + truncateHash + (table ⟨selectedLay, selectedTree, selectedLeaf, selectedChain⟩), + ftsSecret⟩ : SecretKey) + index lay)) counter) = some encoding ∧ + CachedRun final f + (encode parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f + (layerMessage + (⟨parameter, root, + fun selectedLay selectedTree selectedLeaf selectedChain => + truncateHash + (table ⟨selectedLay, selectedTree, selectedLeaf, selectedChain⟩), + ftsSecret⟩ : SecretKey) + index lay)) counter) := by + unfold resolvedSignLayer at hresult + rw [StateT.run_bind, mem_support_bind_iff] at hresult + obtain ⟨⟨message, messageCache⟩, hmessage, hrest⟩ := hresult + rw [StateT.run_bind, mem_support_bind_iff] at hrest + obtain ⟨⟨selected, selectedCache⟩, hselected, hfinish⟩ := hrest + cases selected with + | none => simp at hfinish + | some selected => + rcases selected with ⟨selectedCounter, selectedEncoding⟩ + simp only [StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq, Option.some.injEq] at hfinish + rcases hfinish with ⟨⟨rfl, rfl⟩, rfl⟩ + have hselectedReplay := resolvedOtsSelectFrom_replay f parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) message encodingAttemptLimit 0 + messageCache final (some (counter, encoding)) hselected hf + have hmessageEval : evalWithAnswerFn f + (layerMessage + (⟨parameter, root, + fun selectedLay selectedTree selectedLeaf selectedChain => + truncateHash + (table ⟨selectedLay, selectedTree, selectedLeaf, selectedChain⟩), + ftsSecret⟩ : SecretKey) + index lay) = message := by + rw [resolvedLayerMessage_eq_layerMessage parameter root table ftsSecret index lay] + at hmessage + exact (replay_of_mem_support_of_le _ initial message messageCache final hmessage + hselectedReplay.1 f hf).1 + rw [hmessageEval] + exact hselectedReplay.2 counter encoding rfl + +theorem resolvedChronologicalSignLayer_select_support + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) + (initial final : QueryCache HashSpec) (part : ChronologicalLayerPart) + (hresult : (some part, final) ∈ support + ((resolvedChronologicalSignLayer parameter table ftsSecret index lay).run initial)) : + ∃ selectedCache, + (some (part.counter, part.encoding), selectedCache) ∈ support + ((resolvedSignLayer parameter table ftsSecret index lay).run initial) ∧ + selectedCache ≤ final := by + unfold resolvedChronologicalSignLayer at hresult + rw [StateT.run_bind, mem_support_bind_iff] at hresult + obtain ⟨⟨selected, selectedCache⟩, hselected, hrest⟩ := hresult + cases selected with + | none => simp at hrest + | some selected => + rcases selected with ⟨counter, encoding⟩ + rw [StateT.run_bind, mem_support_bind_iff] at hrest + obtain ⟨⟨values, valuesCache⟩, hvalues, hfinish⟩ := hrest + simp only [StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq, Option.some.injEq] at hfinish + rcases hfinish with ⟨⟨rfl, rfl, rfl, rfl⟩, rfl⟩ + exact ⟨selectedCache, hselected, + resolvedRevealLayerValues_cache_mono parameter table index lay encoding + selectedCache final values hvalues⟩ + +theorem reachableResolvedCouples_maskedChronologicalSignLayers + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) : + ReachableResolvedCouples parameter table + (maskedChronologicalSignLayers parameter ftsSecret index) + (sequenceFin fun lay => + resolvedChronologicalSignLayer parameter table ftsSecret index lay) := by + unfold maskedChronologicalSignLayers + exact reachableResolvedCouples_sequenceFin + (fun lay => maskedChronologicalSignLayer parameter ftsSecret index lay) + (fun lay => resolvedChronologicalSignLayer parameter table ftsSecret index lay) + (fun lay => reachableResolvedCouples_maskedChronologicalSignLayer parameter table ftsSecret + index lay) + +theorem concreteSupport_of_mem_runResolved_maskedChronologicalSignLayer + (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (result : ResolvedRunResult + (Option ChronologicalLayerPart × SplitHashCache)) + (completion : Coordinate → HashOutput) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((maskedChronologicalSignLayer parameter ftsSecret index lay).run cache))) + (hcompletion : DeferredCompletion table result.context completion) : + ∃ rightCache, + (result.value.1, rightCache) ∈ support + ((resolvedChronologicalSignLayer parameter table ftsSecret index lay).run concreteCache) ∧ + ResolvedContextInvariant parameter table result.context + (ordinaryQueryCache result.value.2) rightCache ∧ + VisibleResolvedComputationsCached parameter table result.context rightCache ∧ + PublishedValues result.context.state := by + let left := maskedChronologicalSignLayer parameter ftsSecret index lay + let right := resolvedChronologicalSignLayer parameter table ftsSecret index lay + have hrel : RelTriple + (runResolvedFromTable context fuel table (left.run cache)) + (right.run concreteCache) (ReachableResolvedRunRel parameter table) := + reachableResolvedCouples_maskedChronologicalSignLayer parameter table ftsSecret index lay + context fuel cache concreteCache hinvariant hclosed hpublished + change some result ∈ support + (runResolvedFromTable context fuel table (left.run cache)) at hresult + obtain ⟨rightResult, hrightSupport, hrelation⟩ := + exists_right_of_relTriple_of_mem_support + (relation := ReachableResolvedRunRel parameter table) hrel hresult + rcases rightResult with ⟨rightValue, rightCache⟩ + have hclean := ReachableResolvedRunRel.clean_of_completion hrelation hcompletion + refine ⟨rightCache, ?_, hclean.2.1, hclean.2.2.1, hclean.2.2.2⟩ + rw [hclean.1] + exact hrightSupport + +set_option maxHeartbeats 800000 in +theorem concreteSupport_of_mem_runResolved_chronologicalLayerSequence + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) : + ∀ {n : Nat} (indices : Fin n → Layer) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (result : ResolvedRunResult + ((Fin n → Option ChronologicalLayerPart) × SplitHashCache)) + (completion : Coordinate → HashOutput), + ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache → + VisibleResolvedComputationsCached parameter table context concreteCache → + PublishedValues context.state → + some result ∈ support + (runResolvedFromTable context fuel table + ((sequenceFin fun position => + maskedChronologicalSignLayer parameter ftsSecret index (indices position)).run cache)) → + DeferredCompletion table result.context completion → + ∃ rightCache, + ResolvedContextInvariant parameter table result.context + (ordinaryQueryCache result.value.2) rightCache ∧ + VisibleResolvedComputationsCached parameter table result.context rightCache ∧ + PublishedValues result.context.state ∧ + (result.value.1, rightCache) ∈ support + ((sequenceFin fun position => + resolvedChronologicalSignLayer parameter table ftsSecret index + (indices position)).run concreteCache) + | 0, indices, context, fuel, cache, concreteCache, result, completion, + hinvariant, hclosed, hpublished, hresult, _ => by + simp [sequenceFin, runResolvedFromTable] at hresult + subst result + refine ⟨concreteCache, hinvariant, hclosed, hpublished, ?_⟩ + simp [sequenceFin] + | n + 1, indices, context, fuel, cache, concreteCache, result, completion, + hinvariant, hclosed, hpublished, hresult, hcompletion => by + rw [sequenceFin, StateT.run_bind, runResolvedFromTable_bind, + mem_support_bind_iff] at hresult + obtain ⟨headOption, hhead, hrest⟩ := hresult + cases headOption with + | none => simp at hrest + | some headResult => + have hheadCore := resolvedCore_of_mem_runResolvedFromTable + ((maskedChronologicalSignLayer parameter ftsSecret index (indices 0)).run cache) + context fuel table headResult hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hhead + simp only at hrest + rw [hheadCore.1] at hrest + have hheadCompletion : DeferredCompletion table headResult.context completion := + hcompletion.of_mem_runResolvedFromTable _ headResult.context headResult.remaining table + result completion hheadCore.2.1 hheadCore.2.2 hrest + obtain ⟨rightHeadCache, hrightHead, hheadInvariant, hheadClosed, hheadPublished⟩ := + concreteSupport_of_mem_runResolved_maskedChronologicalSignLayer parameter table + ftsSecret index (indices 0) context fuel cache concreteCache headResult completion + hinvariant hclosed hpublished hhead hheadCompletion + rw [StateT.run_bind, runResolvedFromTable_bind, + mem_support_bind_iff] at hrest + obtain ⟨tailOption, htail, hfinish⟩ := hrest + cases tailOption with + | none => simp at hfinish + | some tailResult => + have htailCore := resolvedCore_of_mem_runResolvedFromTable + ((sequenceFin fun position : Fin n => + maskedChronologicalSignLayer parameter ftsSecret index + (indices position.succ)).run headResult.value.2) + headResult.context headResult.remaining table tailResult + hheadCore.2.1 hheadCore.2.2 htail + simp only at hfinish + rw [htailCore.1] at hfinish + simp [runResolvedFromTable] at hfinish + subst result + obtain ⟨rightTailCache, htailInvariant, htailClosed, htailPublished, + hrightTail⟩ := + concreteSupport_of_mem_runResolved_chronologicalLayerSequence parameter table + ftsSecret index (fun position : Fin n => indices position.succ) + headResult.context headResult.remaining headResult.value.2 rightHeadCache + tailResult completion hheadInvariant hheadClosed hheadPublished htail + hcompletion + refine ⟨rightTailCache, htailInvariant, htailClosed, htailPublished, ?_⟩ + rw [sequenceFin, StateT.run_bind, mem_support_bind_iff] + refine ⟨(headResult.value.1, rightHeadCache), hrightHead, ?_⟩ + rw [StateT.run_bind, mem_support_bind_iff] + exact ⟨(tailResult.value.1, rightTailCache), hrightTail, by simp⟩ + +def LayerEncodingsCached (cache : QueryCache HashSpec) (f : QueryImpl HashSpec Id) + (secretKey : SecretKey) (index : Index) + (parts : Layer → Counter × (ChainIndex → Digit)) : Prop := + ∀ lay, CachedRun cache f + (encode secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f (layerMessage secretKey index lay)) (parts lay).1) + +set_option maxHeartbeats 500000 in +theorem honestLayerParts_of_support_resolvedChronologicalSignLayers + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (initial final : QueryCache HashSpec) + (layers : Layer → Option ChronologicalLayerPart) + (parts : Layer → ChronologicalLayerPart) + (hresult : (layers, final) ∈ support + ((sequenceFin fun lay => + resolvedChronologicalSignLayer parameter table ftsSecret index lay).run initial)) + (hparts : traverseOption layers = some parts) + (hf : final.AgreesWithFn f) : + HonestLayerParts f + (⟨parameter, root, + fun selectedLay selectedTree selectedLeaf selectedChain => + truncateHash (table ⟨selectedLay, selectedTree, selectedLeaf, selectedChain⟩), + ftsSecret⟩ : SecretKey) + index (fun lay => ((parts lay).counter, (parts lay).encoding)) ∧ + LayerEncodingsCached final f + (⟨parameter, root, + fun selectedLay selectedTree selectedLeaf selectedChain => + truncateHash (table ⟨selectedLay, selectedTree, selectedLeaf, selectedChain⟩), + ftsSecret⟩ : SecretKey) + index (fun lay => ((parts lay).counter, (parts lay).encoding)) := by + have hresultAt : ∀ lay, + evalWithAnswerFn f + (encode parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f + (layerMessage + (⟨parameter, root, + fun selectedLay selectedTree selectedLeaf selectedChain => + truncateHash + (table ⟨selectedLay, selectedTree, selectedLeaf, selectedChain⟩), + ftsSecret⟩ : SecretKey) + index lay)) (parts lay).counter) = some (parts lay).encoding ∧ + CachedRun final f + (encode parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f + (layerMessage + (⟨parameter, root, + fun selectedLay selectedTree selectedLeaf selectedChain => + truncateHash + (table ⟨selectedLay, selectedTree, selectedLeaf, selectedChain⟩), + ftsSecret⟩ : SecretKey) + index lay)) (parts lay).counter) := by + intro lay + obtain ⟨componentInitial, componentFinal, componentValue, hcomponent, + hvalue, hcomponentLe⟩ := + queryCache_sequenceFin_component_support + (fun selectedLay => + resolvedChronologicalSignLayer parameter table ftsSecret index selectedLay) + (fun selectedLay => resolvedChronologicalSignLayer_cache_mono parameter table ftsSecret + index selectedLay) initial final layers hresult lay + have hpartsAt := traverseOption_eq_some_apply layers parts hparts lay + have hcomponentValue : componentValue = some (parts lay) := hvalue.symm.trans hpartsAt + rw [hcomponentValue] at hcomponent + obtain ⟨selectedCache, hselected, hselectedLe⟩ := + resolvedChronologicalSignLayer_select_support parameter table ftsSecret index lay + componentInitial componentFinal (parts lay) hcomponent + have hselectedAgrees : selectedCache.AgreesWithFn f := fun input output hcached => + hf (hcomponentLe (hselectedLe hcached)) + have hselectedResult := resolvedSignLayer_some_honest_eval f parameter root table ftsSecret + index lay componentInitial selectedCache (parts lay).counter (parts lay).encoding hselected + hselectedAgrees + exact ⟨hselectedResult.1, hselectedResult.2.mono (hselectedLe.trans hcomponentLe)⟩ + exact ⟨fun lay => (hresultAt lay).1, fun lay => (hresultAt lay).2⟩ + +theorem noPublish_revealPrivateLayerValues (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + NoPublish (revealPrivateLayerValues index lay encoding) := by + unfold revealPrivateLayerValues + apply (noPublish_sequenceFin _ fun chainIdx => + noPublish_revealCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + (encoding chainIdx))).bind + intro values + apply (noPublish_sequenceFin _ fun level => by + by_cases hinLayer : level.val < layerHeight lay + · simp only [hinLayer, if_pos] + cases hvalue : level.val with + | zero => exact noPublish_revealPosition _ + | succ current => + by_cases hcurrent : current < maxLayerHeight + · simp only [hcurrent, dite_true] + exact noPublish_revealPosition _ + · simp only [hcurrent, dite_false] + exact NoPublish.pure 0 + · simp only [hinLayer, if_false] + exact NoPublish.pure 0).bind + intro path + exact NoPublish.pure (values, path) + +theorem noPublish_maskedChronologicalSignLayer + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + NoPublish (maskedChronologicalSignLayer parameter ftsSecret index lay) := by + unfold maskedChronologicalSignLayer + exact (noPublish_maskedSignLayer parameter ftsSecret index lay).bind fun selected => by + cases selected with + | none => exact NoPublish.pure none + | some selected => + rcases selected with ⟨counter, encoding⟩ + exact (noPublish_revealPrivateLayerValues index lay encoding).bind fun values => + NoPublish.pure (some (show ChronologicalLayerPart from + ⟨counter, encoding, values.1, values.2⟩)) + +theorem noPublish_maskedChronologicalSignLayers + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) : + NoPublish (maskedChronologicalSignLayers parameter ftsSecret index) := by + unfold maskedChronologicalSignLayers + exact noPublish_sequenceFin _ fun lay => + noPublish_maskedChronologicalSignLayer parameter ftsSecret index lay + +theorem resolvedPreservesChainPublication_publishChronologicalSignature + (allowed : Coordinate → Prop) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (layers : Layer → Option ChronologicalLayerPart) + (hallowed : ∀ parts, traverseOption layers = some parts → ∀ lay chainIdx, + allowed (chainValueCoordinate lay (treeIndexAt index lay) + (leafIndexAt index lay) chainIdx ((parts lay).encoding chainIdx))) : + ResolvedPreservesChainPublication allowed + (publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers) := by + unfold publishChronologicalSignature + cases hparts : traverseOption layers with + | none => exact ResolvedPreservesChainPublication.pure allowed none + | some parts => + apply (resolvedPreservesChainPublication_sequenceFin _ fun lay => + resolvedPreservesChainPublication_revealLayerValues allowed index lay + (parts lay).encoding (hallowed parts hparts lay)).bind + intro published + exact ResolvedPreservesChainPublication.pure allowed (some (show Signature from + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).counter + chainValue := fun lay => (published lay).1 + authPath := flattenPaths fun lay => (published lay).2 })) + +theorem resolvedPreservesChainPublication_maskedPublishedChronologicalSignAfterDigest + (allowed : Coordinate → Prop) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (hallowed : ∀ (layers : Layer → Option ChronologicalLayerPart) + (parts : Layer → ChronologicalLayerPart), + traverseOption layers = some parts → ∀ lay chainIdx, + allowed (chainValueCoordinate lay (treeIndexAt index lay) + (leafIndexAt index lay) chainIdx ((parts lay).encoding chainIdx))) : + ResolvedPreservesChainPublication allowed + (maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedPublishedChronologicalSignAfterDigest + exact (ResolvedPreservesChainPublication.of_noPublish allowed _ + (noPublish_simulateQ_ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index)))).bind fun ftsPath => + (ResolvedPreservesChainPublication.of_noPublish allowed _ + (noPublish_maskedChronologicalSignLayers parameter ftsSecret index)).bind fun layers => + resolvedPreservesChainPublication_publishChronologicalSignature allowed ftsSecret + randomness index leaves ftsPath layers (hallowed layers) + +theorem resolvedPreservesChainPublication_maskedPublishedChronologicalSign + (allowed : Coordinate → Prop) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (hallowed : ∀ (randomness : Randomness) (index : Index) + (leaves : DigestTree → FtsLeaf) + (layers : Layer → Option ChronologicalLayerPart) + (parts : Layer → ChronologicalLayerPart), + traverseOption layers = some parts → ∀ lay chainIdx, + allowed (chainValueCoordinate lay (treeIndexAt index lay) + (leafIndexAt index lay) chainIdx ((parts lay).encoding chainIdx))) : + ResolvedPreservesChainPublication allowed + (maskedPublishedChronologicalSign parameter root ftsSecret message) := by + unfold maskedPublishedChronologicalSign + apply (ResolvedPreservesChainPublication.of_noPublish allowed _ + (noPublish_simulateQ_ordinaryRomImpl + (signDigestLoop digestAttemptLimit + (⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ : SecretKey) message))).bind + intro selected + cases selected with + | none => exact ResolvedPreservesChainPublication.pure allowed none + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + exact resolvedPreservesChainPublication_maskedPublishedChronologicalSignAfterDigest + allowed parameter ftsSecret randomness index leaves (hallowed randomness index leaves) + +theorem resolvedPreservesChainPublication_probingRomImpl + (allowed : Coordinate → Prop) (parameter : PublicParameter) + (hforward : ChainForwardClosed allowed) (query : OracleWorld.Domain) : + ResolvedPreservesChainPublication allowed (probingRomImpl parameter query) := by + cases query with + | inl n => + exact ResolvedPreservesChainPublication.of_noPublish allowed + (splitUniformImpl n) fun cache => resolvedNoPublish_splitUniformImpl n cache + | inr input => + exact resolvedPreservesChainPublication_probingHashQuery allowed parameter input hforward + +theorem resolvedPreservesChainPublication_probingRom + (allowed : Coordinate → Prop) (parameter : PublicParameter) + (hforward : ChainForwardClosed allowed) + (computation : OracleComp OracleWorld alpha) : + ResolvedPreservesChainPublication allowed + (simulateQ (probingRomImpl parameter) computation) := + resolvedPreservesChainPublication_simulateQ allowed (probingRomImpl parameter) + (resolvedPreservesChainPublication_probingRomImpl allowed parameter hforward) computation + +theorem DeferredCompletion.not_probeHits_of_probingHashQuery_chain + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {fuel : Nat} {cache : SplitHashCache} + {result : ResolvedRunResult (HashOutput × SplitHashCache)} + {completion : Coordinate → HashOutput} {probe : Probe} {input : HashInput} + (fallback : QueryImpl HashSpec Id) + {lay : Layer} {tree : TreeIndex} {leafIdx : LeafIndex} + {chainIdx : ChainIndex} {step : ChainStep} + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hmatches : probe.MatchesInput parameter input) + (hposition : decodePosition? parameter input = + some (.chain lay tree leafIdx chainIdx step)) + (hnotRevealed : probe.coordinate ∉ context.state.revealed) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((probingHashQuery parameter input).run cache))) + (hcompletion : DeferredCompletion table result.context completion) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ¬probe.Hits (tableAnswer parameter completion fallback) + parameter (tableOtsSecret completion) ftsSecret := by + have hprobe : decodeProbe? parameter input = some probe := + (decodeProbe?_eq_some_iff parameter input probe).2 hmatches + unfold probingHashQuery at hresult + rw [hprobe, hposition] at hresult + simp only at hresult + rw [StateT.run_bind, runResolvedFromTable_bind] at hresult + unfold SphincsSecurity.Concrete.OtsProbeSimulation.probe at hresult + rw [StateT.run_liftM, LazyRevealProbe.probeQuery, + runResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + rw [show remaining + 1 = Nat.succ remaining by omega] at hresult + simp only at hresult + rw [if_neg hnotRevealed] at hresult + simp only [runResolvedFromTable] at hresult + let probeContext : DeferredContext := + { context with state := context.state.addPending probe.coordinate probe.candidate } + have hbefore : DeferredCompletion table probeContext completion := + hcompletion.of_mem_runResolvedFromTable _ probeContext remaining table result completion + (hconsistent.addPending probe.coordinate probe.candidate) + (hstarts.addPending probe.coordinate probe.candidate) (by + simpa [probeContext, runResolvedFromTable] using hresult) + apply hbefore.not_probeHits_tableAnswer_of_pending + fallback ftsSecret probe input hmatches + simp [probeContext, LazyRevealProbe.State.addPending] + +def OffTableInput (parameter : PublicParameter) + (completion : Coordinate → HashOutput) (input : HashInput) : Prop := + ∀ position, IsOtsPosition position → + input ≠ tableInput parameter completion (.position position) + +def CacheAgreesWithFnOffTable (parameter : PublicParameter) + (completion : Coordinate → HashOutput) (cache : QueryCache HashSpec) + (f : QueryImpl HashSpec Id) : Prop := + ∀ input output, OffTableInput parameter completion input → + cache input = some output → f input = output + +theorem CacheAgreesWithFnOffTable.of_agrees + {parameter : PublicParameter} {completion : Coordinate → HashOutput} + {cache : QueryCache HashSpec} {f : QueryImpl HashSpec Id} + (hf : cache.AgreesWithFn f) : + CacheAgreesWithFnOffTable parameter completion cache f := by + intro input output _ hcached + exact hf hcached + +theorem offTableInput_of_decodePosition_none + {parameter : PublicParameter} {completion : Coordinate → HashOutput} + {input : HashInput} (hdecode : decodePosition? parameter input = none) : + OffTableInput parameter completion input := by + intro position _ heq + have hsome : decodePosition? parameter input = some position := by + rw [heq] + exact (decodePosition?_eq_some_iff parameter _ position).2 + ⟨tablePayload completion position, rfl⟩ + rw [hdecode] at hsome + simp at hsome + +theorem offTableInput_of_decodePosition_some_ne + {parameter : PublicParameter} {completion : Coordinate → HashOutput} + {input : HashInput} {decoded : Position} + (hdecode : decodePosition? parameter input = some decoded) + (hne : input ≠ tableInput parameter completion (.position decoded)) : + OffTableInput parameter completion input := by + intro position _ heq + have hdecode' : decodePosition? parameter input = some position := by + rw [heq] + exact (decodePosition?_eq_some_iff parameter _ position).2 + ⟨tablePayload completion position, rfl⟩ + have hposition : decoded = position := Option.some.inj (hdecode.symm.trans hdecode') + subst position + exact hne heq + +theorem offTableInput_of_decodePosition_some_not_ots + {parameter : PublicParameter} {completion : Coordinate → HashOutput} + {input : HashInput} {decoded : Position} + (hdecode : decodePosition? parameter input = some decoded) + (hnotOts : ¬IsOtsPosition decoded) : + OffTableInput parameter completion input := by + intro position hots heq + have hdecode' : decodePosition? parameter input = some position := by + rw [heq] + exact (decodePosition?_eq_some_iff parameter _ position).2 + ⟨tablePayload completion position, rfl⟩ + have hposition : decoded = position := Option.some.inj (hdecode.symm.trans hdecode') + exact hnotOts (hposition ▸ hots) + +theorem ResolvedContextInvariant.concreteCache_agreesWith_tableAnswer_of_fallback + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hinvariant : ResolvedContextInvariant parameter table context ordinaryCache concreteCache) + (completion : Coordinate → HashOutput) + (hcompletion : DeferredCompletion table context completion) + (fallback : QueryImpl HashSpec Id) + (hfallback : CacheAgreesWithFnOffTable parameter completion ordinaryCache fallback) : + concreteCache.AgreesWithFn + (tableAnswer parameter completion fallback) := by + intro input output hcached + rcases hinvariant.2.2.2.2.2 input output hcached with hordinary | hfixed + · unfold tableAnswer + cases hdecode : decodePosition? parameter input with + | none => + exact hfallback input output (offTableInput_of_decodePosition_none hdecode) hordinary + | some position => + have hcanonicalOutput (hots : IsOtsPosition position) + (hexact : input = tableInput parameter completion (.position position)) : + completion (.position position) = output := by + have hagrees := hinvariant.1 completion hcompletion position hots + rw [← hexact] at hagrees + unfold ResolveInputAgrees at hagrees + cases hvalue : context.positionValue position with + | none => + rw [hvalue] at hagrees + rw [hcached] at hagrees + simp at hagrees + | some cached => + rw [hvalue] at hagrees + have hcachedEq : cached = output := Option.some.inj (hagrees.symm.trans hcached) + exact (hcompletion.eq_positionValue position cached hvalue).trans hcachedEq + cases position with + | chain lay tree leafIdx chainIdx step => + by_cases hexact : input = tableInput parameter completion + (.position (.chain lay tree leafIdx chainIdx step)) + · rw [tableAnswerDecoded, if_pos hexact] + exact hcanonicalOutput (by trivial) hexact + · rw [tableAnswerDecoded, if_neg hexact] + exact hfallback input output + (offTableInput_of_decodePosition_some_ne hdecode hexact) hordinary + | leaf lay tree leafIdx => + by_cases hexact : input = tableInput parameter completion + (.position (.leaf lay tree leafIdx)) + · rw [tableAnswerDecoded, if_pos hexact] + exact hcanonicalOutput (by trivial) hexact + · rw [tableAnswerDecoded, if_neg hexact] + exact hfallback input output + (offTableInput_of_decodePosition_some_ne hdecode hexact) hordinary + | node lay tree level nodeIdx => + by_cases hexact : input = tableInput parameter completion + (.position (.node lay tree level nodeIdx)) + · rw [tableAnswerDecoded, if_pos hexact] + exact hcanonicalOutput (by trivial) hexact + · rw [tableAnswerDecoded, if_neg hexact] + exact hfallback input output + (offTableInput_of_decodePosition_some_ne hdecode hexact) hordinary + | ftsLeaf | ftsNode | ftsRoots => + exact hfallback input output + (offTableInput_of_decodePosition_some_not_ots hdecode (by simp [IsOtsPosition])) + hordinary + · rcases hfixed with ⟨position, hots, hvalue, hinput⟩ + rw [hinput completion hcompletion, + tableAnswer_tableInput parameter completion fallback position hots, + hcompletion.eq_positionValue position output hvalue] + +theorem ResolvedContextInvariant.concreteCache_agreesWith_tableAnswer + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hinvariant : ResolvedContextInvariant parameter table context ordinaryCache concreteCache) + (completion : Coordinate → HashOutput) + (hcompletion : DeferredCompletion table context completion) : + concreteCache.AgreesWithFn + (tableAnswer parameter completion (fromCache ordinaryCache)) := + hinvariant.concreteCache_agreesWith_tableAnswer_of_fallback completion hcompletion + (fromCache ordinaryCache) + (CacheAgreesWithFnOffTable.of_agrees (agreesWithFn_fromCache ordinaryCache)) + +theorem CacheAgreesWithFnOffTable.of_reachableResolvedCouples + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {right : StateT (QueryCache HashSpec) ProbComp alpha} + {context : DeferredContext} {fuel : Nat} {cache : SplitHashCache} + {concreteCache : QueryCache HashSpec} + {result : ResolvedRunResult (alpha × SplitHashCache)} + {completion : Coordinate → HashOutput} {fallback : QueryImpl HashSpec Id} + (hcoupled : ReachableResolvedCouples parameter table left right) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table (left.run cache))) + (hcompletion : DeferredCompletion table result.context completion) + (hfinal : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback) + (hrightLe : ∀ value finalCache, + (value, finalCache) ∈ support (right.run concreteCache) → + concreteCache ≤ finalCache) : + CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache cache) fallback := by + obtain ⟨rightResult, hrightSupport, hrelation⟩ := + exists_right_of_relTriple_of_mem_support + (hcoupled context fuel cache concreteCache hinvariant hclosed hpublished) hresult + rcases rightResult with ⟨rightValue, rightCache⟩ + obtain ⟨_value, hfinalInvariant, _hfinalClosed, _hfinalPublished⟩ := + hrelation.clean_of_completion hcompletion + intro input output hoff hcached + have hconcrete : concreteCache input = some output := + hinvariant.2.2.2.2.1 input output hcached + have hright : rightCache input = some output := + hrightLe rightValue rightCache hrightSupport hconcrete + rcases hfinalInvariant.2.2.2.2.2 input output hright with hordinary | hfixed + · exact hfinal input output hoff hordinary + · rcases hfixed with ⟨position, hots, _hvalue, hinput⟩ + exact False.elim (hoff position hots (hinput completion hcompletion)) + +section + +attribute [local irreducible] sequenceFin runResolvedFromTable + +set_option maxHeartbeats 800000 in +theorem concreteSupport_of_mem_runResolved_maskedChronologicalSignLayers + (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (result : ResolvedRunResult + ((Layer → Option ChronologicalLayerPart) × SplitHashCache)) + (completion : Coordinate → HashOutput) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((maskedChronologicalSignLayers parameter ftsSecret index).run cache))) + (hcompletion : DeferredCompletion table result.context completion) : + ∃ rightCache, + ResolvedContextInvariant parameter table result.context + (ordinaryQueryCache result.value.2) rightCache ∧ + VisibleResolvedComputationsCached parameter table result.context rightCache ∧ + PublishedValues result.context.state ∧ + (result.value.1, rightCache) ∈ support + ((sequenceFin fun lay => + resolvedChronologicalSignLayer parameter table ftsSecret index lay).run concreteCache) := by + unfold maskedChronologicalSignLayers at hresult + have hbridge0 := + concreteSupport_of_mem_runResolved_chronologicalLayerSequence parameter table ftsSecret index + (n := numLayers) (fun lay : Layer => lay) + have hbridge1 := hbridge0 context fuel cache concreteCache result completion + have hbridge2 := hbridge1 hinvariant + have hbridge3 := hbridge2 hclosed + have hbridge4 : + some result ∈ support + (runResolvedFromTable context fuel table + ((sequenceFin fun lay => + maskedChronologicalSignLayer parameter ftsSecret index lay).run cache)) → + DeferredCompletion table result.context completion → + ∃ rightCache, + ResolvedContextInvariant parameter table result.context + (ordinaryQueryCache result.value.2) rightCache ∧ + VisibleResolvedComputationsCached parameter table result.context rightCache ∧ + PublishedValues result.context.state ∧ + (result.value.1, rightCache) ∈ support + ((sequenceFin fun lay => + resolvedChronologicalSignLayer parameter table ftsSecret index lay).run concreteCache) := + hbridge3 hpublished + have hbridge5 := hbridge4 hresult + exact hbridge5 hcompletion + +set_option maxHeartbeats 500000 in +theorem honestLayerParts_of_mem_runResolved_maskedChronologicalSignLayers + (fallback : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (result : ResolvedRunResult + ((Layer → Option ChronologicalLayerPart) × SplitHashCache)) + (completion : Coordinate → HashOutput) + (parts : Layer → ChronologicalLayerPart) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((maskedChronologicalSignLayers parameter ftsSecret index).run cache))) + (hcompletion : DeferredCompletion table result.context completion) + (hparts : traverseOption result.value.1 = some parts) + (hfallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback) : + HonestLayerParts (tableAnswer parameter completion fallback) + (⟨parameter, root, + fun selectedLay selectedTree selectedLeaf selectedChain => + truncateHash (table ⟨selectedLay, selectedTree, selectedLeaf, selectedChain⟩), + ftsSecret⟩ : SecretKey) + index (fun lay => ((parts lay).counter, (parts lay).encoding)) ∧ + LayerEncodingsCached (ordinaryQueryCache result.value.2) + (tableAnswer parameter completion fallback) + (⟨parameter, root, + fun selectedLay selectedTree selectedLeaf selectedChain => + truncateHash (table ⟨selectedLay, selectedTree, selectedLeaf, selectedChain⟩), + ftsSecret⟩ : SecretKey) + index (fun lay => ((parts lay).counter, (parts lay).encoding)) := by + obtain ⟨rightCache, hfinalInvariant, _hfinalClosed, _hfinalPublished, hright⟩ := + concreteSupport_of_mem_runResolved_maskedChronologicalSignLayers parameter table ftsSecret + index context fuel cache concreteCache result completion hinvariant hclosed hpublished hresult + hcompletion + have hrightAgrees : rightCache.AgreesWithFn + (tableAnswer parameter completion fallback) := + @ResolvedContextInvariant.concreteCache_agreesWith_tableAnswer_of_fallback + parameter table result.context (ordinaryQueryCache result.value.2) rightCache + hfinalInvariant completion hcompletion fallback hfallback + have hrightResult := honestLayerParts_of_support_resolvedChronologicalSignLayers + (tableAnswer parameter completion fallback) parameter root table ftsSecret index concreteCache + rightCache result.value.1 parts hright hparts hrightAgrees + refine ⟨hrightResult.1, ?_⟩ + intro lay input hinput + have hstable := queriesStable_encode (tableAnswer parameter completion fallback) parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn (tableAnswer parameter completion fallback) + (layerMessage + (⟨parameter, root, + fun selectedLay selectedTree selectedLeaf selectedChain => + truncateHash (table ⟨selectedLay, selectedTree, selectedLeaf, selectedChain⟩), + ftsSecret⟩ : SecretKey) + index lay)) (parts lay).counter input hinput + rw [hfinalInvariant.2.2.2.2.eq_of_stable hfinalInvariant.2.2.2.1 input hstable] + exact hrightResult.2 lay input hinput + +end + +theorem DeferredCompletion.tableOtsSecret_eq + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hcompletion : DeferredCompletion table context completion) : + tableOtsSecret completion = + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + funext lay tree leafIdx chainIdx + exact congrArg truncateHash + (hcompletion.2.2.2 ⟨lay, tree, leafIdx, chainIdx⟩) + +def ResolvedOrdinaryCachePreserving + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ context fuel table cache result, + some result ∈ support + (runResolvedFromTable context fuel table (computation.run cache)) → + ordinaryQueryCache result.value.2 = ordinaryQueryCache cache + +theorem ResolvedOrdinaryCachePreserving.pure (value : alpha) : + ResolvedOrdinaryCachePreserving + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro context fuel table cache result hresult + simp [runResolvedFromTable] at hresult + subst result + rfl + +theorem ResolvedOrdinaryCachePreserving.bind + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : ResolvedOrdinaryCachePreserving left) + (hnext : ∀ value, ResolvedOrdinaryCachePreserving (next value)) : + ResolvedOrdinaryCachePreserving (left >>= next) := by + intro context fuel table cache result hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨middle, hmiddle, hrest⟩ := hresult + cases middle with + | none => simp at hrest + | some middle => + simp only at hrest + exact (hnext middle.value.1 middle.context middle.remaining middle.table middle.value.2 result + hrest).trans (hleft context fuel table cache middle hmiddle) + +theorem resolvedOrdinaryCachePreserving_sequenceFin {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hcomponent : ∀ index, ResolvedOrdinaryCachePreserving (computation index)) : + ResolvedOrdinaryCachePreserving (sequenceFin computation) := by + induction n with + | zero => + simpa [sequenceFin] using ResolvedOrdinaryCachePreserving.pure Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomponent 0).bind fun head => + (ih (fun index : Fin n => computation index.succ) + (fun index => hcomponent index.succ)).bind fun tail => + ResolvedOrdinaryCachePreserving.pure + (Fin.cases head tail : Fin (n + 1) → alpha) + +theorem resolvedOrdinaryCachePreserving_revealCoordinate (coordinate : Coordinate) : + ResolvedOrdinaryCachePreserving (revealCoordinate coordinate) := by + intro context fuel table cache result hresult + rw [revealCoordinate_run, LazyRevealProbe.revealQuery, + runResolvedFromTable_reveal_query_bind] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [pure_bind] at hresult + cases hresolved : resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context with + | none => simp [hresolved] at hresult + | some resolved => + simp only [hresolved] at hresult + simp [runResolvedFromTable] at hresult + subst result + exact ordinaryQueryCache_update_hidden cache + (.chainStart lay tree leafIdx chainIdx) resolved.output + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨resolved, _hresolved, hrest⟩ := hresult + cases resolved with + | none => simp at hrest + | some resolved => + simp [runResolvedFromTable] at hrest + subst result + exact ordinaryQueryCache_update_hidden cache (.position position) resolved.output + +theorem resolvedOrdinaryCachePreserving_publishCoordinate (coordinate : Coordinate) : + ResolvedOrdinaryCachePreserving (publishCoordinate coordinate) := by + intro context fuel table cache result hresult + unfold publishCoordinate at hresult + rw [StateT.run_liftM, LazyRevealProbe.publishQuery, + runResolvedFromTable_publish_query_bind] at hresult + simp [runResolvedFromTable] at hresult + subst result + rfl + +theorem resolvedOrdinaryCachePreserving_revealPublishedCoordinate + (coordinate : Coordinate) : + ResolvedOrdinaryCachePreserving (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + exact (resolvedOrdinaryCachePreserving_revealCoordinate coordinate).bind fun _ => + (resolvedOrdinaryCachePreserving_publishCoordinate coordinate).bind fun _ => + ResolvedOrdinaryCachePreserving.pure _ + +theorem resolvedOrdinaryCachePreserving_revealLayerValues + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + ResolvedOrdinaryCachePreserving (revealLayerValues index lay encoding) := by + unfold revealLayerValues + exact (resolvedOrdinaryCachePreserving_sequenceFin _ fun chainIdx => + resolvedOrdinaryCachePreserving_revealPublishedCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx))).bind fun _ => + (resolvedOrdinaryCachePreserving_sequenceFin _ fun level => by + split + · cases hlevelValue : level.val with + | zero => exact resolvedOrdinaryCachePreserving_revealPublishedCoordinate _ + | succ current => + rw [show current + 1 = Nat.succ current by omega] + change ResolvedOrdinaryCachePreserving + (if hlevel : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hlevel⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0) + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact resolvedOrdinaryCachePreserving_revealPublishedCoordinate _ + · rw [dif_neg hlevel] + exact ResolvedOrdinaryCachePreserving.pure 0 + · exact ResolvedOrdinaryCachePreserving.pure 0).bind fun _ => + ResolvedOrdinaryCachePreserving.pure _ + +theorem resolvedOrdinaryCachePreserving_publishChronologicalSignature + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (layers : Layer → Option ChronologicalLayerPart) : + ResolvedOrdinaryCachePreserving + (publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers) := by + unfold publishChronologicalSignature + cases hparts : traverseOption layers with + | none => exact ResolvedOrdinaryCachePreserving.pure none + | some parts => + exact (resolvedOrdinaryCachePreserving_sequenceFin _ fun lay => + resolvedOrdinaryCachePreserving_revealLayerValues index lay + (parts lay).encoding).bind fun _ => + ResolvedOrdinaryCachePreserving.pure _ + +theorem concreteSupport_of_mem_runResolved_ftsOpen + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (leaves : DigestTree → FtsLeaf) + (secret : FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (result : ResolvedRunResult + ((FtsTree → Fin ftsTreeHeight → Digest) × SplitHashCache)) + (completion : Coordinate → HashOutput) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((simulateQ ordinaryHashImpl (ftsOpen parameter index leaves secret)).run cache))) + (hcompletion : DeferredCompletion table result.context completion) : + ∃ rightCache, + ResolvedContextInvariant parameter table result.context + (ordinaryQueryCache result.value.2) rightCache ∧ + VisibleResolvedComputationsCached parameter table result.context rightCache ∧ + PublishedValues result.context.state ∧ + (result.value.1, rightCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsOpen parameter index leaves secret)).run concreteCache) := by + let left := simulateQ ordinaryHashImpl (ftsOpen parameter index leaves secret) + let right := simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsOpen parameter index leaves secret) + have hrel : RelTriple + (runResolvedFromTable context fuel table (left.run cache)) + (right.run concreteCache) (ReachableResolvedRunRel parameter table) := + reachableResolvedCouples_ftsOpen parameter table index leaves secret context fuel cache + concreteCache hinvariant hclosed hpublished + change some result ∈ support + (runResolvedFromTable context fuel table (left.run cache)) at hresult + obtain ⟨rightResult, hrightSupport, hrelation⟩ := + exists_right_of_relTriple_of_mem_support + (relation := ReachableResolvedRunRel parameter table) hrel hresult + rcases rightResult with ⟨rightValue, rightCache⟩ + have hclean := ReachableResolvedRunRel.clean_of_completion hrelation hcompletion + refine ⟨rightCache, hclean.2.1, hclean.2.2.1, hclean.2.2.2, ?_⟩ + rw [hclean.1] + exact hrightSupport + +set_option maxHeartbeats 500000 in +theorem publishedChronologicalSignature_support + (initial : Coordinate → Prop) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (layers : Layer → Option ChronologicalLayerPart) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (table : OtsSecretIndex → HashOutput) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (completion : Coordinate → HashOutput) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hallowed : RevealedChainAllowed initial context.state) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers).run + cache))) + (hcompletion : DeferredCompletion table result.context completion) : + (result.value.1 = none ∧ + RevealedChainAllowed initial result.context.state) ∨ + ∃ (signature : Signature) (parts : Layer → ChronologicalLayerPart), + result.value.1 = some signature ∧ + traverseOption layers = some parts ∧ + signature.randomness = randomness ∧ + signature.counter = (fun lay => (parts lay).counter) ∧ + RevealedChainAllowed + (fun coordinate => initial coordinate ∨ + PublishedByParts index + (fun lay => ((parts lay).counter, (parts lay).encoding)) coordinate) + result.context.state := by + cases hparts : traverseOption layers with + | none => + have hfinalAllowed := + resolvedPreservesChainPublication_publishChronologicalSignature initial ftsSecret + randomness index leaves ftsPath layers + (fun _ hparts' => by simp [hparts] at hparts') context cache fuel table result + completion hconsistent hstarts hallowed hresult hcompletion + unfold publishChronologicalSignature at hresult + rw [hparts] at hresult + simp [runResolvedFromTable] at hresult + subst result + exact Or.inl ⟨rfl, hfinalAllowed⟩ + | some parts => + let allowed := fun coordinate => initial coordinate ∨ + PublishedByParts index + (fun lay => ((parts lay).counter, (parts lay).encoding)) coordinate + have hallowed' : RevealedChainAllowed allowed context.state := + hallowed.mono fun coordinate hcoordinate => Or.inl hcoordinate + have hendpoints : ∀ lay chainIdx, + allowed (chainValueCoordinate lay (treeIndexAt index lay) + (leafIndexAt index lay) chainIdx ((parts lay).encoding chainIdx)) := + fun lay chainIdx => Or.inr (publishedByParts_selected index + (fun selectedLay => + ((parts selectedLay).counter, (parts selectedLay).encoding)) lay chainIdx) + have hfinalAllowed := + resolvedPreservesChainPublication_publishChronologicalSignature allowed ftsSecret + randomness index leaves ftsPath layers + (fun selectedParts hselectedParts => by + have heq : selectedParts = parts := Option.some.inj (hselectedParts.symm.trans hparts) + subst selectedParts + exact hendpoints) context cache fuel table result completion hconsistent hstarts + hallowed' hresult hcompletion + unfold publishChronologicalSignature at hresult + rw [hparts, StateT.run_bind, runResolvedFromTable_bind, + mem_support_bind_iff] at hresult + obtain ⟨publishedResult, hpublished, hfinish⟩ := hresult + cases publishedResult with + | none => simp at hfinish + | some publishedResult => + simp [runResolvedFromTable] at hfinish + subst result + exact Or.inr ⟨_, parts, rfl, rfl, rfl, rfl, hfinalAllowed⟩ + +section + +attribute [local irreducible] sequenceFin runResolvedFromTable + +theorem resolvedCore_of_mem_maskedChronologicalSignLayers + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult + ((Layer → Option ChronologicalLayerPart) × SplitHashCache)) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((maskedChronologicalSignLayers parameter ftsSecret index).run cache))) : + result.table = table ∧ result.context.ValuesConsistent ∧ + StartTableAgrees result.context.state table := by + exact resolvedCore_of_mem_runResolvedFromTable + ((maskedChronologicalSignLayers parameter ftsSecret index).run cache) + context fuel table result hconsistent hstarts hresult + +set_option maxHeartbeats 1000000 in +theorem maskedPublishedChronologicalSignAfterDigest_support + (initial : Coordinate → Prop) + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (completion : Coordinate → HashOutput) + (fallback : QueryImpl HashSpec Id) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hallowed : RevealedChainAllowed initial context.state) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index + leaves).run cache))) + (hcompletion : DeferredCompletion table result.context completion) + (hfallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback) : + (result.value.1 = none ∧ + RevealedChainAllowed initial result.context.state) ∨ + ∃ (signature : Signature) (parts : Layer → ChronologicalLayerPart), + result.value.1 = some signature ∧ + signature.randomness = randomness ∧ + signature.counter = (fun lay => (parts lay).counter) ∧ + HonestLayerParts + (tableAnswer parameter completion fallback) + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + index (fun lay => ((parts lay).counter, (parts lay).encoding)) ∧ + LayerEncodingsCached (ordinaryQueryCache result.value.2) + (tableAnswer parameter completion fallback) + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + index (fun lay => ((parts lay).counter, (parts lay).encoding)) ∧ + RevealedChainAllowed + (fun coordinate => initial coordinate ∨ + PublishedByParts index + (fun lay => ((parts lay).counter, (parts lay).encoding)) coordinate) + result.context.state := by + unfold maskedPublishedChronologicalSignAfterDigest at hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨pathOption, hpath, hafterPath⟩ := hresult + cases pathOption with + | none => simp at hafterPath + | some pathResult => + have hpathCore := resolvedCore_of_mem_runResolvedFromTable + ((simulateQ ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index))).run cache) + context fuel table pathResult hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hpath + simp only at hafterPath + rw [hpathCore.1] at hafterPath + have hpathRevealed := revealed_eq_of_mem_runResolvedFromTable_of_noPublish + (((simulateQ ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index))).run cache)) + context fuel table pathResult + (noPublish_simulateQ_ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index)) cache) hpath + have hpathAllowed : RevealedChainAllowed initial pathResult.context.state := by + intro coordinate hchain hrevealed + apply hallowed coordinate hchain + rw [← hpathRevealed] + exact hrevealed + rw [StateT.run_bind, runResolvedFromTable_bind, + mem_support_bind_iff] at hafterPath + obtain ⟨layersOption, hlayers, hpublish⟩ := hafterPath + cases layersOption with + | none => simp at hpublish + | some layersResult => + have hlayersCore := resolvedCore_of_mem_maskedChronologicalSignLayers parameter table + ftsSecret index pathResult.context pathResult.remaining pathResult.value.2 layersResult + hpathCore.2.1 hpathCore.2.2 hlayers + simp only at hpublish + rw [hlayersCore.1] at hpublish + have hlayersCompletion : DeferredCompletion table layersResult.context completion := + hcompletion.of_mem_runResolvedFromTable _ layersResult.context + layersResult.remaining table result completion hlayersCore.2.1 hlayersCore.2.2 + hpublish + have hpathCompletion : DeferredCompletion table pathResult.context completion := + hlayersCompletion.of_mem_runResolvedFromTable + ((maskedChronologicalSignLayers parameter ftsSecret index).run pathResult.value.2) + pathResult.context pathResult.remaining table layersResult completion hpathCore.2.1 + hpathCore.2.2 hlayers + obtain ⟨pathConcreteCache, hpathInvariant, hpathClosed, hpathPublished, + _hpathConcrete⟩ := + concreteSupport_of_mem_runResolved_ftsOpen parameter table index leaves + (ftsSecret index) context fuel cache concreteCache pathResult completion hinvariant + hclosed hpublished hpath hpathCompletion + have hlayersRevealed := revealed_eq_of_mem_runResolvedFromTable_of_noPublish + ((maskedChronologicalSignLayers parameter ftsSecret index).run pathResult.value.2) + pathResult.context pathResult.remaining table layersResult + (noPublish_maskedChronologicalSignLayers parameter ftsSecret index + pathResult.value.2) hlayers + have hlayersAllowed : RevealedChainAllowed initial layersResult.context.state := by + intro coordinate hchain hrevealed + apply hpathAllowed coordinate hchain + rw [← hlayersRevealed] + exact hrevealed + have hpublishedResult := publishedChronologicalSignature_support initial ftsSecret + randomness index leaves pathResult.value.1 layersResult.value.1 layersResult.context + layersResult.remaining layersResult.value.2 table result completion hlayersCore.2.1 + hlayersCore.2.2 hlayersAllowed hpublish hcompletion + rcases hpublishedResult with ⟨hnone, hfinalAllowed⟩ | + ⟨signature, parts, hsignature, hparts, hrandomness, hcounter, hfinalAllowed⟩ + · exact Or.inl ⟨hnone, hfinalAllowed⟩ + · have hcacheEq := + resolvedOrdinaryCachePreserving_publishChronologicalSignature ftsSecret randomness + index leaves pathResult.value.1 layersResult.value.1 layersResult.context + layersResult.remaining table layersResult.value.2 result hpublish + have hlayersFallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache layersResult.value.2) fallback := by + rw [← hcacheEq] + exact hfallback + have hhonest := + honestLayerParts_of_mem_runResolved_maskedChronologicalSignLayers + fallback parameter root table ftsSecret index pathResult.context + pathResult.remaining pathResult.value.2 pathConcreteCache layersResult + completion parts hpathInvariant hpathClosed hpathPublished hlayers + hlayersCompletion hparts hlayersFallback + have hcachedFinal : LayerEncodingsCached (ordinaryQueryCache result.value.2) + (tableAnswer parameter completion fallback) + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + index (fun lay => ((parts lay).counter, (parts lay).encoding)) := by + rw [hcacheEq] + exact hhonest.2 + exact Or.inr + ⟨signature, parts, hsignature, hrandomness, hcounter, hhonest.1, + hcachedFinal, hfinalAllowed⟩ + +end + +theorem concreteSupport_of_mem_runResolved_signDigestLoop + (table : OtsSecretIndex → HashOutput) (secretKey : SecretKey) + (message : Message) (attempts : Nat) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (result : ResolvedRunResult + (Option (Randomness × Index × (DigestTree → FtsLeaf)) × SplitHashCache)) + (completion : Coordinate → HashOutput) + (hinvariant : ResolvedContextInvariant secretKey.parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached secretKey.parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((simulateQ ordinaryRomImpl + (signDigestLoop attempts secretKey message)).run cache))) + (hcompletion : DeferredCompletion table result.context completion) : + ∃ rightCache, + ResolvedContextInvariant secretKey.parameter table result.context + (ordinaryQueryCache result.value.2) rightCache ∧ + VisibleResolvedComputationsCached secretKey.parameter table result.context rightCache ∧ + PublishedValues result.context.state ∧ + (result.value.1, rightCache) ∈ support + ((simulateQ romImpl (signDigestLoop attempts secretKey message)).run concreteCache) := by + let left := simulateQ ordinaryRomImpl (signDigestLoop attempts secretKey message) + let right := simulateQ romImpl (signDigestLoop attempts secretKey message) + have hrel : RelTriple + (runResolvedFromTable context fuel table (left.run cache)) + (right.run concreteCache) + (ReachableResolvedRunRel secretKey.parameter table) := + reachableResolvedCouples_signDigestLoop table secretKey message attempts context fuel cache + concreteCache hinvariant hclosed hpublished + change some result ∈ support + (runResolvedFromTable context fuel table (left.run cache)) at hresult + obtain ⟨rightResult, hrightSupport, hrelation⟩ := + exists_right_of_relTriple_of_mem_support + (relation := ReachableResolvedRunRel secretKey.parameter table) hrel hresult + rcases rightResult with ⟨rightValue, rightCache⟩ + have hclean := ReachableResolvedRunRel.clean_of_completion hrelation hcompletion + refine ⟨rightCache, hclean.2.1, hclean.2.2.1, hclean.2.2.2, ?_⟩ + rw [hclean.1] + exact hrightSupport + +theorem concreteSupport_of_mem_runResolved_maskedPublishedChronologicalSignAfterDigest + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (completion : Coordinate → HashOutput) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index + leaves).run cache))) + (hcompletion : DeferredCompletion table result.context completion) : + ∃ rightCache, + ResolvedContextInvariant parameter table result.context + (ordinaryQueryCache result.value.2) rightCache ∧ + VisibleResolvedComputationsCached parameter table result.context rightCache ∧ + PublishedValues result.context.state ∧ + (result.value.1, rightCache) ∈ support + ((resolvedImmediateSignAfterDigest parameter table ftsSecret randomness index + leaves).run concreteCache) := by + let left := maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index + leaves + let right := resolvedImmediateSignAfterDigest parameter table ftsSecret randomness index leaves + have hrel : RelTriple + (runResolvedFromTable context fuel table (left.run cache)) + (right.run concreteCache) + (ReachableResolvedRunRel parameter table) := + reachableResolvedCouples_maskedPublishedChronologicalSignAfterDigest_immediate parameter table + ftsSecret randomness index leaves context fuel cache concreteCache hinvariant hclosed + hpublished + change some result ∈ support + (runResolvedFromTable context fuel table (left.run cache)) at hresult + obtain ⟨rightResult, hrightSupport, hrelation⟩ := + exists_right_of_relTriple_of_mem_support + (relation := ReachableResolvedRunRel parameter table) hrel hresult + rcases rightResult with ⟨rightValue, rightCache⟩ + have hclean := ReachableResolvedRunRel.clean_of_completion hrelation hcompletion + refine ⟨rightCache, hclean.2.1, hclean.2.2.1, hclean.2.2.2, ?_⟩ + rw [hclean.1] + exact hrightSupport + +theorem concreteSupport_of_mem_runResolved_of_reachableResolvedCouples + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {right : StateT (QueryCache HashSpec) ProbComp alpha} + {context : DeferredContext} {fuel : Nat} {cache : SplitHashCache} + {concreteCache : QueryCache HashSpec} + {result : ResolvedRunResult (alpha × SplitHashCache)} + {completion : Coordinate → HashOutput} + (hcoupled : ReachableResolvedCouples parameter table left right) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table (left.run cache))) + (hcompletion : DeferredCompletion table result.context completion) : + ∃ rightCache, + ResolvedContextInvariant parameter table result.context + (ordinaryQueryCache result.value.2) rightCache ∧ + VisibleResolvedComputationsCached parameter table result.context rightCache ∧ + PublishedValues result.context.state ∧ + (result.value.1, rightCache) ∈ support (right.run concreteCache) := by + obtain ⟨rightResult, hrightSupport, hrelation⟩ := + exists_right_of_relTriple_of_mem_support + (hcoupled context fuel cache concreteCache hinvariant hclosed hpublished) hresult + rcases rightResult with ⟨rightValue, rightCache⟩ + have hclean := hrelation.clean_of_completion hcompletion + refine ⟨rightCache, hclean.2.1, hclean.2.2.1, hclean.2.2.2, ?_⟩ + rw [hclean.1] + exact hrightSupport + +theorem resolvedCore_of_mem_runResolved_of_reachableResolvedCouples + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {right : StateT (QueryCache HashSpec) ProbComp alpha} + {context : DeferredContext} {fuel : Nat} {cache : SplitHashCache} + {concreteCache : QueryCache HashSpec} + {result : ResolvedRunResult (alpha × SplitHashCache)} + (hcoupled : ReachableResolvedCouples parameter table left right) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table (left.run cache))) : + result.table = table ∧ result.context.ValuesConsistent ∧ + StartTableAgrees result.context.state table := by + obtain ⟨rightResult, _hrightSupport, hrelation⟩ := + exists_right_of_relTriple_of_mem_support + (hcoupled context fuel cache concreteCache hinvariant hclosed hpublished) hresult + rcases rightResult with ⟨rightValue, rightCache⟩ + rcases hrelation with hclean | hdoomed + · exact ⟨hclean.1, hclean.2.2.1.2.1.valuesConsistent, hclean.2.2.1.2.2.1⟩ + · exact ⟨hdoomed.1, hdoomed.2.1, hdoomed.2.2.1⟩ + +theorem successfulDigestRun_changeSecretKey + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {left right : SecretKey} {message : Message} {randomness : Randomness} + {index : Index} {leaves : DigestTree → FtsLeaf} + (hrun : SuccessfulDigestRun f cache left message randomness index leaves) + (hparameter : left.parameter = right.parameter) (hroot : left.root = right.root) : + SuccessfulDigestRun f cache right message randomness index leaves := by + simpa only [SuccessfulDigestRun, signAttempt, hparameter, hroot] using hrun + +theorem simulateQ_randomOracle_cache_le_resolved + (computation : OracleComp HashSpec alpha) (initial final : QueryCache HashSpec) + (value : alpha) + (hresult : (value, final) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) computation).run initial)) : + initial ≤ final := by + exact OracleComp.simulateQ_run_preservesInv + (randomOracle : QueryImpl HashSpec _) + (fun cache => initial ≤ cache) + (QueryImpl.PreservesInv.withCaching_le uniformSampleImpl initial) + computation initial le_rfl (value, final) hresult + +set_option maxHeartbeats 1000000 in +theorem maskedPublishedChronologicalSign_support + (initial : Coordinate → Prop) + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (completion : Coordinate → HashOutput) + (fallback : QueryImpl HashSpec Id) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hallowed : RevealedChainAllowed initial context.state) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache))) + (hcompletion : DeferredCompletion table result.context completion) + (hfallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback) : + (result.value.1 = none ∧ + RevealedChainAllowed initial result.context.state) ∨ + ∃ (signature : Signature) (index : Index) (leaves : DigestTree → FtsLeaf) + (parts : Layer → ChronologicalLayerPart), + result.value.1 = some signature ∧ + SuccessfulDigestRun + (tableAnswer parameter completion fallback) + (ordinaryQueryCache result.value.2) + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + message signature.randomness index leaves ∧ + signature.counter = (fun lay => (parts lay).counter) ∧ + HonestLayerParts + (tableAnswer parameter completion fallback) + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + index (fun lay => ((parts lay).counter, (parts lay).encoding)) ∧ + LayerEncodingsCached (ordinaryQueryCache result.value.2) + (tableAnswer parameter completion fallback) + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + index (fun lay => ((parts lay).counter, (parts lay).encoding)) ∧ + RevealedChainAllowed + (fun coordinate => initial coordinate ∨ + PublishedByParts index + (fun lay => ((parts lay).counter, (parts lay).encoding)) coordinate) + result.context.state := by + let digestSecretKey : SecretKey := + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ + unfold maskedPublishedChronologicalSign at hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨loopOption, hloop, hrest⟩ := hresult + cases loopOption with + | none => simp at hrest + | some loopResult => + have hloopCore := resolvedCore_of_mem_runResolvedFromTable + ((simulateQ ordinaryRomImpl + (signDigestLoop digestAttemptLimit digestSecretKey message)).run cache) + context fuel table loopResult hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hloop + simp only at hrest + rw [hloopCore.1] at hrest + cases selected : loopResult.value.1 with + | none => + simp [selected, runResolvedFromTable] at hrest + subst result + have hloopRevealed := revealed_eq_of_mem_runResolvedFromTable_of_noPublish + ((simulateQ ordinaryRomImpl + (signDigestLoop digestAttemptLimit digestSecretKey message)).run cache) + context fuel table loopResult + (noPublish_simulateQ_ordinaryRomImpl + (signDigestLoop digestAttemptLimit digestSecretKey message) cache) hloop + apply Or.inl + refine ⟨rfl, ?_⟩ + intro coordinate hchain hrevealed + apply hallowed coordinate hchain + rw [← hloopRevealed] + exact hrevealed + | some selectedValue => + rcases selectedValue with ⟨randomness, index, leaves⟩ + have hloopCompletion : DeferredCompletion table loopResult.context completion := + hcompletion.of_mem_runResolvedFromTable + ((maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index + leaves).run loopResult.value.2) + loopResult.context loopResult.remaining table result completion hloopCore.2.1 + hloopCore.2.2 (by simpa [selected] using hrest) + obtain ⟨loopConcreteCache, hloopInvariant, hloopClosed, hloopPublished, + _hloopConcrete⟩ := + concreteSupport_of_mem_runResolved_signDigestLoop table digestSecretKey message + digestAttemptLimit context fuel cache concreteCache loopResult completion hinvariant + hclosed hpublished hloop hloopCompletion + have hloopRevealed := revealed_eq_of_mem_runResolvedFromTable_of_noPublish + ((simulateQ ordinaryRomImpl + (signDigestLoop digestAttemptLimit digestSecretKey message)).run cache) + context fuel table loopResult + (noPublish_simulateQ_ordinaryRomImpl + (signDigestLoop digestAttemptLimit digestSecretKey message) cache) hloop + have hloopAllowed : RevealedChainAllowed initial loopResult.context.state := by + intro coordinate hchain hrevealed + apply hallowed coordinate hchain + rw [← hloopRevealed] + exact hrevealed + have hafterSupport : some result ∈ support + (runResolvedFromTable loopResult.context loopResult.remaining table + ((maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness + index leaves).run loopResult.value.2)) := by + simpa [selected] using hrest + obtain ⟨afterConcreteCache, hafterInvariant, _hafterClosed, _hafterPublished, + hafterConcrete⟩ := + concreteSupport_of_mem_runResolved_maskedPublishedChronologicalSignAfterDigest + parameter table ftsSecret randomness index leaves loopResult.context + loopResult.remaining loopResult.value.2 loopConcreteCache result completion + hloopInvariant hloopClosed hloopPublished hafterSupport hcompletion + have hafter := maskedPublishedChronologicalSignAfterDigest_support initial parameter root + table ftsSecret randomness index leaves loopResult.context loopResult.remaining + loopResult.value.2 loopConcreteCache result completion fallback hloopInvariant + hloopClosed hloopPublished hloopAllowed hafterSupport hcompletion hfallback + rcases hafter with ⟨hnone, hfinalAllowed⟩ | + ⟨signature, parts, hsignature, _hrandomness, hcounter, hhonest, + hcachedEncodings, hfinalAllowed⟩ + · exact Or.inl ⟨hnone, hfinalAllowed⟩ + · let answer := tableAnswer parameter completion fallback + have hafterAgrees : afterConcreteCache.AgreesWithFn answer := + hafterInvariant.concreteCache_agreesWith_tableAnswer_of_fallback completion + hcompletion fallback hfallback + have hafterConcrete' : (result.value.1, afterConcreteCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + randomness index leaves)).run loopConcreteCache) := by + rw [resolvedImmediateSignAfterDigest_eq_concrete parameter root table ftsSecret + randomness index leaves, + concreteSignAfterDigestFromTable_eq_signAfterDigest parameter root table ftsSecret + randomness index leaves] at hafterConcrete + exact hafterConcrete + have hloopLe : loopConcreteCache ≤ afterConcreteCache := + simulateQ_randomOracle_cache_le_resolved + (signAfterDigest + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + randomness index leaves) + loopConcreteCache afterConcreteCache result.value.1 hafterConcrete' + have hloopAgrees : loopConcreteCache.AgreesWithFn answer := + fun input output hcached => hafterAgrees (hloopLe hcached) + have hloopConcrete : + (some (randomness, index, leaves), loopConcreteCache) ∈ support + ((simulateQ romImpl + (signDigestLoop digestAttemptLimit digestSecretKey message)).run + concreteCache) := by + simpa [selected] using _hloopConcrete + have hloopReplay := replayRom_of_mem_support + (signDigestLoop digestAttemptLimit digestSecretKey message) concreteCache + (some (randomness, index, leaves)) loopConcreteCache hloopConcrete answer + hloopAgrees + have hdigest := successfulDigestLoop_of_mem_support answer digestSecretKey message + digestAttemptLimit randomness index leaves concreteCache loopConcreteCache + afterConcreteCache hloopReplay hloopLe hafterAgrees + have hdigest' := successfulDigestRun_changeSecretKey hdigest + (right := (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey)) + rfl rfl + rw [← _hrandomness] at hdigest' + have hdigestLeft : SuccessfulDigestRun answer + (ordinaryQueryCache result.value.2) + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + message signature.randomness index leaves := by + refine ⟨hdigest'.1, hdigest'.2.1, ?_⟩ + intro input hinput + have hstable := queriesStable_signAttempt answer + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + message signature.randomness input hinput + rw [hafterInvariant.2.2.2.2.eq_of_stable + hafterInvariant.2.2.2.1 input hstable] + exact hdigest'.2.2 input hinput + exact Or.inr + ⟨signature, index, leaves, parts, hsignature, hdigestLeft, + hcounter, hhonest, hcachedEncodings, hfinalAllowed⟩ + +theorem revealedChainAllowed_maskedPublishedChronologicalSign_covered + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (targetCache : QueryCache HashSpec) (signingLog : QueryLog SigningSpec) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (completion : Coordinate → HashOutput) + (fallback : QueryImpl HashSpec Id) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hallowed : RevealedChainAllowed + (CoveredChainCoordinate + (tableAnswer parameter completion fallback) + targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + signingLog) + context.state) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache))) + (hcompletion : DeferredCompletion table result.context completion) + (hfallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback) + (hentry : (⟨message, result.value.1⟩ : + (request : SignRequest) × SigningSpec.Range request) ∈ signingLog) + (hrun : ∀ signature, result.value.1 = some signature → + SuccessfulSignRun + (tableAnswer parameter completion fallback) + targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + message signature) : + RevealedChainAllowed + (CoveredChainCoordinate + (tableAnswer parameter completion fallback) + targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + signingLog) + result.context.state := by + let answer := tableAnswer parameter completion fallback + let secretKey : SecretKey := + ⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ + have hclassified := maskedPublishedChronologicalSign_support + (CoveredChainCoordinate answer targetCache secretKey signingLog) + parameter root table ftsSecret message context fuel cache concreteCache result completion + fallback hinvariant hclosed hpublished hallowed hresult hcompletion hfallback + rcases hclassified with ⟨_, hfinal⟩ | + ⟨signature, index, leaves, parts, hsignature, hdigest, hcounter, + hhonest, _hcachedEncodings, hfinal⟩ + · exact hfinal + · change RevealedChainAllowed + (CoveredChainCoordinate answer targetCache secretKey signingLog) result.context.state + refine hfinal.mono + (final := CoveredChainCoordinate answer targetCache secretKey signingLog) ?_ + intro coordinate hcoordinate + rcases hcoordinate with hcovered | hpublishedCoordinate + · exact hcovered + · have hrun' : SuccessfulSignRun answer targetCache secretKey message signature := + hrun signature hsignature + obtain ⟨runIndex, runLeaves, runParts, hrunDigest, hftsSecret, hftsPath, + hrunCounter, hrunValues, hrunPath, hftsCached, hlayers, hlayersCached⟩ := hrun' + have hselected : (index, leaves) = (runIndex, runLeaves) := + Option.some.inj (hdigest.2.1.symm.trans hrunDigest.2.1) + obtain ⟨hindex, hleaves⟩ := Prod.mk.inj hselected + subst runIndex + subst runLeaves + exact (hpublishedCoordinate.toPublishedChainCoordinate + ⟨message, result.value.1⟩ signature leaves hentry hsignature + (hrun signature hsignature) hrunDigest hcounter hhonest).covered + +theorem revealedChainAllowed_maskedChronologicalExpandedAdversaryQuery + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (targetCache : QueryCache HashSpec) (allowedLog : QueryLog SigningSpec) + (completion : Coordinate → HashOutput) (fallback : QueryImpl HashSpec Id) + (hlogRuns : ∀ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), entry ∈ allowedLog → entry.2 = some signature → + SuccessfulSignRun (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + entry.1 signature) + (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (result : ResolvedRunResult + ((OracleWorld + SigningSpec).Range input × SplitHashCache)) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hallowed : RevealedChainAllowed + (CoveredChainCoordinate (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + allowedLog) + context.state) + (hfragment : ∀ entry, entry ∈ signingLogFragment input result.value.1 → + entry ∈ allowedLog) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache))) + (hcompletion : DeferredCompletion table result.context completion) + (hfallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback) : + RevealedChainAllowed + (CoveredChainCoordinate (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + allowedLog) + result.context.state := by + cases input with + | inl query => + exact resolvedPreservesChainPublication_probingRomImpl + (CoveredChainCoordinate (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + allowedLog) + parameter + (coveredChainCoordinate_forwardClosed (tableAnswer parameter completion fallback) + targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + allowedLog) + query context cache fuel table result completion hinvariant.2.1.valuesConsistent + hinvariant.2.2.1 hallowed hresult hcompletion + | inr message => + apply revealedChainAllowed_maskedPublishedChronologicalSign_covered parameter root table + ftsSecret message targetCache allowedLog context fuel cache concreteCache result completion + fallback hinvariant hclosed hpublished hallowed hresult hcompletion hfallback + · exact hfragment ⟨message, result.value.1⟩ (by simp [signingLogFragment]) + · intro signature hsignature + exact hlogRuns ⟨message, result.value.1⟩ signature + (hfragment _ (by simp [signingLogFragment])) hsignature + +set_option maxRecDepth 100000 in +theorem revealedChainAllowed_signingTraceComputation + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (targetCache : QueryCache HashSpec) (allowedLog : QueryLog SigningSpec) + (completion : Coordinate → HashOutput) (fallback : QueryImpl HashSpec Id) + (hlogRuns : ∀ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), entry ∈ allowedLog → entry.2 = some signature → + SuccessfulSignRun (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + entry.1 signature) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (result : ResolvedRunResult ((alpha × QueryLog SigningSpec) × SplitHashCache)) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hallowed : RevealedChainAllowed + (CoveredChainCoordinate (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + allowedLog) + context.state) + (hsub : ∀ entry, entry ∈ result.value.1.2 → entry ∈ allowedLog) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation computation)).run cache))) + (hcompletion : DeferredCompletion table result.context completion) + (hfallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback) : + RevealedChainAllowed + (CoveredChainCoordinate (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + allowedLog) + result.context.state := by + induction computation using OracleComp.inductionOn generalizing + context fuel cache concreteCache result with + | pure value => + simp [signingTraceComputation, runResolvedFromTable] at hresult + subst result + exact hallowed + | query_bind input next ih => + rw [signingTraceComputation_query_bind, simulateQ_bind, simulateQ_spec_query, + StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨queryOption, hquery, hrest⟩ := hresult + cases queryOption with + | none => simp at hrest + | some queryResult => + have hqueryCore := resolvedCore_of_mem_runResolvedFromTable + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) + context fuel table queryResult hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hquery + simp only at hrest + rw [hqueryCore.1, map_eq_bind_pure_comp, simulateQ_bind, StateT.run_bind, + runResolvedFromTable_bind, mem_support_bind_iff] at hrest + obtain ⟨tailOption, htail, hfinish⟩ := hrest + cases tailOption with + | none => simp at hfinish + | some tailResult => + simp [runResolvedFromTable] at hfinish + subst result + have htailCore := resolvedCore_of_mem_runResolvedFromTable + ((simulateQ + (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation (next queryResult.value.1))).run + queryResult.value.2) + queryResult.context queryResult.remaining table tailResult + hqueryCore.2.1 hqueryCore.2.2 htail + have hqueryCompletion : DeferredCompletion table queryResult.context completion := + hcompletion.of_mem_runResolvedFromTable _ queryResult.context + queryResult.remaining table tailResult completion hqueryCore.2.1 hqueryCore.2.2 + htail + obtain ⟨queryConcreteCache, hqueryInvariant, hqueryClosed, hqueryPublished, + _hqueryConcrete⟩ := + concreteSupport_of_mem_runResolved_of_reachableResolvedCouples + (reachableResolvedCouples_maskedChronologicalExpandedAdversaryImpl parameter + root table ftsSecret input) + hinvariant hclosed hpublished hquery hqueryCompletion + let secretKey : SecretKey := + ⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ + have htailCoupled : ReachableResolvedCouples parameter table + (simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation (next queryResult.value.1))) + (simulateQ (unloggedMappedAdversaryImpl secretKey) + (signingTraceComputation (next queryResult.value.1))) := + reachableResolvedCouples_simulateQ + (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (unloggedMappedAdversaryImpl secretKey) + (reachableResolvedCouples_maskedChronologicalExpandedAdversaryImpl parameter + root table ftsSecret) + (signingTraceComputation (next queryResult.value.1)) + have hqueryFallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache queryResult.value.2) fallback := + CacheAgreesWithFnOffTable.of_reachableResolvedCouples htailCoupled + hqueryInvariant hqueryClosed hqueryPublished htail hcompletion hfallback + (fun value finalCache hright => + FtsProbeSimulation.simulateQ_unloggedMappedAdversaryImpl_cache_le secretKey + (signingTraceComputation (next queryResult.value.1)) queryConcreteCache + finalCache value hright) + have hqueryAllowed := + revealedChainAllowed_maskedChronologicalExpandedAdversaryQuery parameter root + table ftsSecret targetCache allowedLog completion fallback hlogRuns input + context fuel cache concreteCache queryResult hinvariant hclosed hpublished + hallowed + (fun entry hentry => hsub entry + (List.mem_append_left tailResult.value.1.2 hentry)) + hquery hqueryCompletion hqueryFallback + apply ih queryResult.value.1 queryResult.context queryResult.remaining + queryResult.value.2 queryConcreteCache tailResult hqueryInvariant hqueryClosed + hqueryPublished hqueryAllowed + · intro entry hentry + exact hsub entry (List.mem_append_right _ hentry) + · exact htail + · exact hcompletion + · exact hfallback + +theorem reachableResolvedCouples_probingHashImpl_query + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) : + ReachableResolvedCouples parameter table (probingHashImpl parameter input) + (randomOracle input) := + reachableResolvedCouples_probingHashQuery parameter table input + +theorem resolvedPreservesChainPublication_probingHashImpl_query + (allowed : Coordinate → Prop) (parameter : PublicParameter) + (input : HashInput) (hforward : ChainForwardClosed allowed) : + ResolvedPreservesChainPublication allowed (probingHashImpl parameter input) := + resolvedPreservesChainPublication_probingHashQuery allowed parameter input hforward + +theorem DeferredCompletion.not_probeHits_of_probingHashImpl_query_chain + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {fuel : Nat} {cache : SplitHashCache} + {result : ResolvedRunResult (HashOutput × SplitHashCache)} + {completion : Coordinate → HashOutput} {probe : Probe} {input : HashInput} + (fallback : QueryImpl HashSpec Id) + {lay : Layer} {tree : TreeIndex} {leafIdx : LeafIndex} + {chainIdx : ChainIndex} {step : ChainStep} + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hmatches : probe.MatchesInput parameter input) + (hposition : decodePosition? parameter input = + some (.chain lay tree leafIdx chainIdx step)) + (hnotRevealed : probe.coordinate ∉ context.state.revealed) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((probingHashImpl parameter input).run cache))) + (hcompletion : DeferredCompletion table result.context completion) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ¬probe.Hits (tableAnswer parameter completion fallback) + parameter (tableOtsSecret completion) ftsSecret := + hcompletion.not_probeHits_of_probingHashQuery_chain fallback hconsistent hstarts hmatches + hposition hnotRevealed hresult ftsSecret + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 1000000 in +theorem not_probeHits_of_mem_runResolved_probingHashImpl + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (allowed : Coordinate → Prop) (hforward : ChainForwardClosed allowed) + (completion : Coordinate → HashOutput) (fallback : QueryImpl HashSpec Id) + (computation : OracleComp HashSpec alpha) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (result : ResolvedRunResult (alpha × SplitHashCache)) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hallowed : RevealedChainAllowed allowed context.state) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((simulateQ (probingHashImpl parameter) computation).run cache))) + (hcompletion : DeferredCompletion table result.context completion) + (hfallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback) + (probe : Probe) (input : HashInput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (step : ChainStep) + (hmatches : probe.MatchesInput parameter input) + (hposition : decodePosition? parameter input = + some (.chain lay tree leafIdx chainIdx step)) + (hnotAllowed : ¬allowed probe.coordinate) + (hquery : input ∈ queriedInputs + (tableAnswer parameter completion fallback) computation) + (hhits : probe.Hits (tableAnswer parameter completion fallback) + parameter (tableOtsSecret completion) ftsSecret) : False := by + induction computation using OracleComp.inductionOn generalizing + context fuel cache concreteCache result with + | pure value => + simp at hquery + | query_bind queried next ih => + rw [simulateQ_query_bind, StateT.run_bind, runResolvedFromTable_bind, + mem_support_bind_iff] at hresult + obtain ⟨queryOption, hqueryRun, hrest⟩ := hresult + cases queryOption with + | none => simp at hrest + | some queryResult => + have hqueryRun' : some queryResult ∈ support + (runResolvedFromTable context fuel table + ((probingHashImpl parameter queried).run cache)) := hqueryRun + have hqueryCore : queryResult.table = table ∧ + queryResult.context.ValuesConsistent ∧ + StartTableAgrees queryResult.context.state table := + resolvedCore_of_mem_runResolved_of_reachableResolvedCouples + (reachableResolvedCouples_probingHashImpl_query parameter table queried) + hinvariant hclosed hpublished hqueryRun' + simp only at hrest + rw [hqueryCore.1] at hrest + have hqueryCompletion : DeferredCompletion table queryResult.context completion := + hcompletion.of_mem_runResolvedFromTable + ((simulateQ (probingHashImpl parameter) (next queryResult.value.1)).run + queryResult.value.2) + queryResult.context queryResult.remaining table result completion hqueryCore.2.1 + hqueryCore.2.2 hrest + obtain ⟨queryConcreteCache, hqueryInvariant, hqueryClosed, hqueryPublished, + hqueryConcrete⟩ := + concreteSupport_of_mem_runResolved_of_reachableResolvedCouples + (reachableResolvedCouples_probingHashImpl_query parameter table queried) + hinvariant hclosed hpublished hqueryRun' hqueryCompletion + have htailCoupled : ReachableResolvedCouples parameter table + (simulateQ (probingHashImpl parameter) (next queryResult.value.1)) + (simulateQ randomOracle (next queryResult.value.1)) := + reachableResolvedCouples_simulateQ (probingHashImpl parameter) randomOracle + (reachableResolvedCouples_probingHashQuery parameter table) + (next queryResult.value.1) + have hqueryFallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache queryResult.value.2) fallback := + CacheAgreesWithFnOffTable.of_reachableResolvedCouples htailCoupled + hqueryInvariant hqueryClosed hqueryPublished hrest hcompletion hfallback + (fun value finalCache hright => + simulateQ_randomOracle_cache_le_resolved (next queryResult.value.1) + queryConcreteCache finalCache value hright) + have hqueryAllowed : RevealedChainAllowed allowed queryResult.context.state := + resolvedPreservesChainPublication_probingHashImpl_query allowed parameter queried + hforward + context cache fuel table queryResult completion + hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hallowed hqueryRun' + hqueryCompletion + have hagrees : queryConcreteCache.AgreesWithFn + (tableAnswer parameter completion fallback) := + hqueryInvariant.concreteCache_agreesWith_tableAnswer_of_fallback + completion hqueryCompletion fallback hqueryFallback + have hcached : queryConcreteCache queried = some queryResult.value.1 := + randomOracle_run_output_cached queried concreteCache queryConcreteCache + queryResult.value.1 hqueryConcrete + have hanswer : tableAnswer parameter completion fallback queried = + queryResult.value.1 := hagrees hcached + rw [queriedInputs_query_bind, hanswer] at hquery + rcases List.mem_cons.mp hquery with hhead | htail + · subst queried + have hnotRevealed : probe.coordinate ∉ context.state.revealed := by + intro hrevealed + exact hnotAllowed + (hallowed probe.coordinate (probe.isChainCoordinate_of_matchesInput hmatches) + hrevealed) + exact (hqueryCompletion.not_probeHits_of_probingHashImpl_query_chain fallback + hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hmatches hposition hnotRevealed + hqueryRun' ftsSecret) hhits + · exact ih queryResult.value.1 queryResult.context queryResult.remaining + queryResult.value.2 queryConcreteCache result hqueryInvariant hqueryClosed + hqueryPublished hqueryAllowed hrest hcompletion hfallback htail + +set_option maxRecDepth 100000 in +theorem not_verifyProbe_of_mem_runResolved_verifier + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (targetCache : QueryCache HashSpec) (root : Digest) (forgery : Forgery) + (signingLog : QueryLog SigningSpec) + (completion : Coordinate → HashOutput) (fallback : QueryImpl HashSpec Id) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (result : ResolvedRunResult (Bool × SplitHashCache)) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hallowed : RevealedChainAllowed + (CoveredChainCoordinate + (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + signingLog) + context.state) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).run cache))) + (hcompletion : DeferredCompletion table result.context completion) + (hfallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback) + (hprobe : VerifyProbeWitness + (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + signingLog forgery.message forgery.signature) : False := by + obtain ⟨lay, digest, layerMessage, codeword, chainIdx, hdigit, probe, input, hinput, + _hdigest, _hadmissible, _hencode, _hverifierMessage, hhits, hmatches, hquery, + _hcached, hnotCovered, _hsourceSettled⟩ := hprobe + have hposition : decodePosition? parameter input = + some (.chain lay (treeIndexAt (digestIndex digest) lay) + (leafIndexAt (digestIndex digest) lay) chainIdx + ⟨(codeword chainIdx).val, hdigit⟩) := + (decodePosition?_eq_some_iff parameter input _).2 + ⟨digestBytes (forgery.signature.chainValue lay chainIdx), hinput⟩ + have hresult' : some result ∈ support + (runResolvedFromTable context fuel table + ((simulateQ (probingHashImpl parameter) + (verify ⟨root, parameter⟩ forgery.message forgery.signature)).run cache)) := by + rw [← simulateQ_probingRom_scheme_verify] + exact hresult + have hhits' : probe.Hits (tableAnswer parameter completion fallback) + parameter (tableOtsSecret completion) ftsSecret := by + rw [hcompletion.tableOtsSecret_eq] + exact hhits + exact not_probeHits_of_mem_runResolved_probingHashImpl parameter table ftsSecret + (CoveredChainCoordinate + (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun selectedLay selectedTree selectedLeaf selectedChain => + truncateHash (table ⟨selectedLay, selectedTree, selectedLeaf, selectedChain⟩), + ftsSecret⟩ : SecretKey) + signingLog) + (coveredChainCoordinate_forwardClosed (tableAnswer parameter completion fallback) + targetCache + (⟨parameter, root, + fun selectedLay selectedTree selectedLeaf selectedChain => + truncateHash (table ⟨selectedLay, selectedTree, selectedLeaf, selectedChain⟩), + ftsSecret⟩ : SecretKey) + signingLog) + completion fallback (verify ⟨root, parameter⟩ forgery.message forgery.signature) + context fuel cache concreteCache result hinvariant hclosed hpublished hallowed hresult' + hcompletion hfallback probe input lay (treeIndexAt (digestIndex digest) lay) + (leafIndexAt (digestIndex digest) lay) chainIdx + ⟨(codeword chainIdx).val, hdigit⟩ hmatches hposition hnotCovered hquery hhits' + +theorem not_uncoveredChainProbe_of_mem_runResolved_verifier + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (targetCache : QueryCache HashSpec) (root : Digest) (forgery : Forgery) + (signingLog : QueryLog SigningSpec) + (completion : Coordinate → HashOutput) (fallback : QueryImpl HashSpec Id) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (result : ResolvedRunResult (Bool × SplitHashCache)) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hallowed : RevealedChainAllowed + (CoveredChainCoordinate + (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + signingLog) + context.state) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).run cache))) + (hcompletion : DeferredCompletion table result.context completion) + (hfallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback) + (probe : Probe) (input : HashInput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (step : ChainStep) + (hmatches : probe.MatchesInput parameter input) + (hposition : decodePosition? parameter input = + some (.chain lay tree leafIdx chainIdx step)) + (hnotCovered : ¬CoveredChainCoordinate + (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun selectedLay selectedTree selectedLeaf selectedChain => + truncateHash (table ⟨selectedLay, selectedTree, selectedLeaf, selectedChain⟩), + ftsSecret⟩ : SecretKey) + signingLog probe.coordinate) + (hquery : input ∈ queriedInputs (tableAnswer parameter completion fallback) + (verify ⟨root, parameter⟩ forgery.message forgery.signature)) + (hhits : probe.Hits (tableAnswer parameter completion fallback) + parameter (tableOtsSecret completion) ftsSecret) : False := by + have hresult' : some result ∈ support + (runResolvedFromTable context fuel table + ((simulateQ (probingHashImpl parameter) + (verify ⟨root, parameter⟩ forgery.message forgery.signature)).run cache)) := by + rw [← simulateQ_probingRom_scheme_verify] + exact hresult + exact not_probeHits_of_mem_runResolved_probingHashImpl parameter table ftsSecret + (CoveredChainCoordinate + (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun selectedLay selectedTree selectedLeaf selectedChain => + truncateHash (table ⟨selectedLay, selectedTree, selectedLeaf, selectedChain⟩), + ftsSecret⟩ : SecretKey) + signingLog) + (coveredChainCoordinate_forwardClosed (tableAnswer parameter completion fallback) + targetCache + (⟨parameter, root, + fun selectedLay selectedTree selectedLeaf selectedChain => + truncateHash (table ⟨selectedLay, selectedTree, selectedLeaf, selectedChain⟩), + ftsSecret⟩ : SecretKey) + signingLog) + completion fallback (verify ⟨root, parameter⟩ forgery.message forgery.signature) + context fuel cache concreteCache result hinvariant hclosed hpublished hallowed hresult' + hcompletion hfallback probe input lay tree leafIdx chainIdx step hmatches hposition + hnotCovered hquery hhits + +set_option maxHeartbeats 1000000 in +theorem resolvedPreservesChainPublication_maskedPublishedTreeRoot + (allowed : Coordinate → Prop) : + ResolvedPreservesChainPublication allowed maskedPublishedTreeRoot := by + unfold maskedPublishedTreeRoot + apply (ResolvedPreservesChainPublication.of_noPublish allowed + (ensureTreeNode topLayer rootTree (layerHeight topLayer) 0) fun cache => + noPublish_ensureTreeNode topLayer rootTree (layerHeight topLayer) 0 cache).bind + intro _ + exact resolvedPreservesChainPublication_revealPublishedCoordinate allowed _ + (by simp [IsChainCoordinate]) + +theorem successfulSignRuns_of_mem_support_unloggedMapped_signingTrace + (f : QueryImpl HashSpec Id) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (initialCache : QueryCache HashSpec) (value : alpha) + (signingLog : QueryLog SigningSpec) (adversaryCache finalCache : QueryCache HashSpec) + (hmem : ((value, signingLog), adversaryCache) ∈ support + ((simulateQ (unloggedMappedAdversaryImpl secretKey) + (signingTraceComputation computation)).run initialCache)) + (hle : adversaryCache ≤ finalCache) (hf : finalCache.AgreesWithFn f) : + ∀ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), entry ∈ signingLog → entry.2 = some signature → + SuccessfulSignRun f finalCache secretKey entry.1 signature := by + rw [← simulateQ_withTraceAppend_run_eq_signingTraceComputation, + ← FtsProbeSimulation.writerTMapBase_expanded_withTraceAppend_eq_unlogged, + ← QueryImpl.simulateQ_writerTMapBase_run, + ← SphincsSecurity.forwardOracles_add_signingOracle_eq_withTraceAppend] at hmem + intro entry signature hentry hresponse + exact successfulSignRun_of_signing_entry f secretKey computation initialCache value signingLog + adversaryCache finalCache hmem hle hf entry signature hresponse hentry + +theorem successfulSignRuns_of_mem_support_concreteRetainedPrefix + (adversary : Adversary) (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (initialCache : QueryCache HashSpec) (root : Digest) (forgery : Forgery) + (signingLog : QueryLog SigningSpec) (prefixCache finalCache : QueryCache HashSpec) + (hmem : ((root, (forgery, signingLog)), prefixCache) ∈ support + ((concreteRetainedPrefixAfterFtsSecrets adversary parameter table ftsSecret).run + initialCache)) + (hle : prefixCache ≤ finalCache) (hf : finalCache.AgreesWithFn f) : + ∀ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), entry ∈ signingLog → entry.2 = some signature → + SuccessfulSignRun f finalCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + entry.1 signature := by + unfold concreteRetainedPrefixAfterFtsSecrets at hmem + rw [StateT.run_bind, mem_support_bind_iff] at hmem + obtain ⟨rootResult, hroot, hrest⟩ := hmem + rcases rootResult with ⟨sampledRoot, rootCache⟩ + rw [StateT.run_bind, mem_support_bind_iff] at hrest + obtain ⟨adversaryResult, hadversary, hfinish⟩ := hrest + rcases adversaryResult with ⟨forgeryLog, adversaryCache⟩ + rcases forgeryLog with ⟨sampledForgery, sampledLog⟩ + simp only [StateT.run_pure, support_pure, Set.mem_singleton_iff, Prod.mk.injEq] at hfinish + obtain ⟨hvalue, hcache⟩ := hfinish + subst adversaryCache + obtain ⟨hrootValue, hforgeryLog⟩ := hvalue + subst sampledRoot + obtain ⟨hforgery, hlog⟩ := hforgeryLog + subst sampledForgery + subst sampledLog + exact successfulSignRuns_of_mem_support_unloggedMapped_signingTrace f + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + (adversary.main ⟨root, parameter⟩) rootCache forgery signingLog prefixCache finalCache + hadversary hle hf + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxHeartbeats 1000000 in +theorem resolvedCore_of_mem_runResolved_maskedPublishedTreeRoot + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (fuel : Nat) + (result : ResolvedRunResult (Digest × SplitHashCache)) + (hresult : some result ∈ support + (runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) : + result.table = table ∧ result.context.ValuesConsistent ∧ + StartTableAgrees result.context.state table := + resolvedCore_of_mem_runResolved_of_reachableResolvedCouples + (reachableResolvedCouples_maskedPublishedTreeRoot parameter table) + (resolvedContextInvariant_empty parameter table) + (visibleResolvedComputationsCached_empty parameter table emptyDeferredStructuralValues ∅) + publishedValues_empty hresult + +set_option maxHeartbeats 1000000 in +theorem concreteSupport_of_mem_runResolved_maskedPublishedTreeRoot + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (fuel : Nat) + (result : ResolvedRunResult (Digest × SplitHashCache)) + (completion : Coordinate → HashOutput) + (hresult : some result ∈ support + (runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hcompletion : DeferredCompletion table result.context completion) : + ∃ concreteCache, + ResolvedContextInvariant parameter table result.context + (ordinaryQueryCache result.value.2) concreteCache ∧ + VisibleResolvedComputationsCached parameter table result.context concreteCache ∧ + PublishedValues result.context.state ∧ + (result.value.1, concreteCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter topLayer rootTree + (fun leafIdx chainIdx => + truncateHash (table ⟨topLayer, rootTree, leafIdx, chainIdx⟩)) + (layerHeight topLayer) 0)).run ∅) := + concreteSupport_of_mem_runResolved_of_reachableResolvedCouples + (reachableResolvedCouples_maskedPublishedTreeRoot parameter table) + (resolvedContextInvariant_empty parameter table) + (visibleResolvedComputationsCached_empty parameter table emptyDeferredStructuralValues ∅) + publishedValues_empty hresult hcompletion + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem revealedChainAllowed_of_mem_runResolved_chronologicalRetainedPrefix + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (targetCache : QueryCache HashSpec) + (completion : Coordinate → HashOutput) (fallback : QueryImpl HashSpec Id) + (fuel : Nat) + (result : ResolvedRunResult + ((Digest × (Forgery × QueryLog SigningSpec)) × SplitHashCache)) + (hresult : some result ∈ support + (runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table + ((maskedChronologicalRetainedPrefixAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) + (hcompletion : DeferredCompletion table result.context completion) + (hfallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback) + (hlogRuns : ∀ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), entry ∈ result.value.1.2.2 → entry.2 = some signature → + SuccessfulSignRun (tableAnswer parameter completion fallback) targetCache + (⟨parameter, result.value.1.1, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + entry.1 signature) : + RevealedChainAllowed + (CoveredChainCoordinate (tableAnswer parameter completion fallback) targetCache + (⟨parameter, result.value.1.1, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + result.value.1.2.2) + result.context.state := by + unfold maskedChronologicalRetainedPrefixAfterFtsSecrets at hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨rootOption, hroot, hrest⟩ := hresult + cases rootOption with + | none => simp at hrest + | some rootResult => + have hrootCore : rootResult.table = table ∧ rootResult.context.ValuesConsistent ∧ + StartTableAgrees rootResult.context.state table := + resolvedCore_of_mem_runResolved_maskedPublishedTreeRoot parameter table fuel rootResult + hroot + simp only at hrest + rw [hrootCore.1] at hrest + have hrootCompletion : DeferredCompletion table rootResult.context completion := + hcompletion.of_mem_runResolvedFromTable _ rootResult.context rootResult.remaining table + result completion hrootCore.2.1 hrootCore.2.2 hrest + obtain ⟨rootConcreteCache, hrootInvariant, hrootClosed, hrootPublished, + _hrootConcrete⟩ := + concreteSupport_of_mem_runResolved_maskedPublishedTreeRoot parameter table fuel rootResult + completion hroot hrootCompletion + have hemptyAllowed : RevealedChainAllowed + (CoveredChainCoordinate (tableAnswer parameter completion fallback) targetCache + (⟨parameter, rootResult.value.1, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + result.value.1.2.2) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) := by + intro coordinate hchain hrevealed + simp [LazyRevealProbe.State.empty] at hrevealed + have hrootAllowed : RevealedChainAllowed + (CoveredChainCoordinate (tableAnswer parameter completion fallback) targetCache + (⟨parameter, rootResult.value.1, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + result.value.1.2.2) + rootResult.context.state := + resolvedPreservesChainPublication_maskedPublishedTreeRoot _ + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + emptySplitHashCache fuel table rootResult completion + (resolvedContextInvariant_empty parameter table).2.1.valuesConsistent + (resolvedContextInvariant_empty parameter table).2.2.1 hemptyAllowed hroot + hrootCompletion + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hrest + obtain ⟨adversaryOption, hadversary, hfinish⟩ := hrest + cases adversaryOption with + | none => simp at hfinish + | some adversaryResult => + simp [runResolvedFromTable] at hfinish + subst result + exact revealedChainAllowed_signingTraceComputation parameter rootResult.value.1 table + ftsSecret targetCache adversaryResult.value.1.2 completion fallback hlogRuns + (adversary.main ⟨rootResult.value.1, parameter⟩) rootResult.context + rootResult.remaining rootResult.value.2 rootConcreteCache adversaryResult + hrootInvariant hrootClosed hrootPublished hrootAllowed (fun entry => id) + hadversary hcompletion hfallback + +theorem successfulSignRuns_of_mem_support_actualRetainedGameAfterTable + (adversary : Adversary) (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (root : Digest) (forgery : Forgery) (signingLog : QueryLog SigningSpec) + (verified : Bool) (finalCache : QueryCache HashSpec) + (hactual : ((root, ((forgery, signingLog), verified)), finalCache) ∈ support + (actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table))) + (hf : finalCache.AgreesWithFn f) : + ∀ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), entry ∈ signingLog → entry.2 = some signature → + SuccessfulSignRun f finalCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + entry.1 signature := by + rw [← concreteRetainedGameAfterFtsSecrets_run_eq_actual] at hactual + unfold concreteRetainedGameAfterFtsSecrets at hactual + rw [StateT.run_bind, mem_support_bind_iff] at hactual + obtain ⟨prefixResult, hprefix, hrest⟩ := hactual + rcases prefixResult with ⟨prefixValue, prefixCache⟩ + rcases prefixValue with ⟨sampledRoot, forgeryLog⟩ + rcases forgeryLog with ⟨sampledForgery, sampledLog⟩ + rw [StateT.run_bind, mem_support_bind_iff] at hrest + obtain ⟨verifierResult, hverifier, hfinish⟩ := hrest + rcases verifierResult with ⟨sampledVerified, verifierCache⟩ + simp only [StateT.run_pure, support_pure, Set.mem_singleton_iff, Prod.mk.injEq] at hfinish + obtain ⟨hvalue, hcache⟩ := hfinish + subst verifierCache + obtain ⟨hroot, hrestValue⟩ := hvalue + subst sampledRoot + obtain ⟨hforgeryLog, hverified⟩ := hrestValue + subst sampledVerified + obtain ⟨hforgery, hlog⟩ := hforgeryLog + subst sampledForgery + subst sampledLog + have hle : prefixCache ≤ finalCache := + simulateQ_romImpl_cache_le + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature) + prefixCache (verified, finalCache) hverifier + exact successfulSignRuns_of_mem_support_concreteRetainedPrefix adversary f parameter table + ftsSecret ∅ root forgery signingLog prefixCache finalCache hprefix hle hf + +theorem SuccessfulDigestRun.changeAnswerFn + {f g : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {message : Message} {randomness : Randomness} + {index : Index} {leaves : DigestTree → FtsLeaf} + (hrun : SuccessfulDigestRun f cache secretKey message randomness index leaves) + (hf : cache.AgreesWithFn f) (hg : cache.AgreesWithFn g) : + SuccessfulDigestRun g cache secretKey message randomness index leaves := by + refine ⟨hrun.1, ?_, hrun.2.2.changeAnswerFn hf hg⟩ + rw [← hrun.2.2.eval_eq hf hg] + exact hrun.2.1 + +theorem SuccessfulSignRun.changeAnswerFn + {f g : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {message : Message} {signature : Signature} + (hrun : SuccessfulSignRun f cache secretKey message signature) + (hf : cache.AgreesWithFn f) (hg : cache.AgreesWithFn g) : + SuccessfulSignRun g cache secretKey message signature := by + obtain ⟨index, leaves, parts, hdigest, hftsSecret, hftsPath, hcounter, hvalues, + hauthPath, hftsCached, hlayers, hlayersCached⟩ := hrun + refine ⟨index, leaves, parts, SuccessfulDigestRun.changeAnswerFn hdigest hf hg, hftsSecret, + ?_, hcounter, + hvalues, hauthPath, hftsCached.changeAnswerFn hf hg, ?_, ?_⟩ + · rw [← hftsCached.eval_eq hf hg] + exact hftsPath + · intro lay + rw [← (hlayersCached lay).eval_eq hf hg] + exact hlayers lay + · intro lay + exact (hlayersCached lay).changeAnswerFn hf hg + +theorem CoveredChainCoordinate.changeAnswerFn + {f g : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} + {coordinate : Coordinate} + (hcovered : CoveredChainCoordinate f cache secretKey signingLog coordinate) + (hf : cache.AgreesWithFn f) (hg : cache.AgreesWithFn g) : + CoveredChainCoordinate g cache secretKey signingLog coordinate := by + obtain ⟨entry, signature, index, leaves, lay, chainIdx, codeword, targetDigit, hentry, + hresponse, hrun, hdigest, hencode, hle, hcoordinate⟩ := hcovered + have hmessageCached : CachedRun cache f (layerMessage secretKey index lay) := by + obtain ⟨runIndex, runLeaves, parts, runDigest, _hftsSecret, _hftsPath, _hcounter, + _hvalues, _hauthPath, _hftsCached, _hlayers, hlayersCached⟩ := hrun + have hselection : (runIndex, runLeaves) = (index, leaves) := by + apply Option.some.inj + exact runDigest.2.1.symm.trans hdigest.2.1 + obtain ⟨rfl, rfl⟩ := Prod.mk.inj hselection + exact (hlayersCached lay).bind_left + have hmessageEq := hmessageCached.eval_eq hf hg + have hencodingInputCached := hrun.signed_encode_cached_of_digest hdigest lay + have hencodeCached : CachedRun cache f + (encode secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f (layerMessage secretKey index lay)) + (signature.counter lay)) := by + intro input hinput + simp only [encode, queriedInputs_bind, queriedInputs_tweakableHash, queriedInputs_pure, + List.append_nil, List.mem_singleton] at hinput + subst input + exact hencodingInputCached + have hencode' : evalWithAnswerFn g + (encode secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn g (layerMessage secretKey index lay)) + (signature.counter lay)) = some codeword := by + rw [← hmessageEq, ← hencodeCached.eval_eq hf hg] + exact hencode + exact ⟨entry, signature, index, leaves, lay, chainIdx, codeword, targetDigit, hentry, + hresponse, SuccessfulSignRun.changeAnswerFn hrun hf hg, + SuccessfulDigestRun.changeAnswerFn hdigest hf hg, hencode', hle, hcoordinate⟩ + +attribute [local irreducible] maskedChronologicalRetainedPrefixAfterFtsSecrets + +theorem resolvedCore_of_mem_runResolved_chronologicalRetainedPrefix + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (result : ResolvedRunResult + ((Digest × (Forgery × QueryLog SigningSpec)) × SplitHashCache)) + (hresult : some result ∈ support + (runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table + ((maskedChronologicalRetainedPrefixAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) : + result.table = table ∧ result.context.ValuesConsistent ∧ + StartTableAgrees result.context.state table := + resolvedCore_of_mem_runResolved_of_reachableResolvedCouples + (reachableResolvedCouples_chronologicalRetainedPrefixAfterFtsSecrets adversary parameter + table ftsSecret) + (resolvedContextInvariant_empty parameter table) + (visibleResolvedComputationsCached_empty parameter table emptyDeferredStructuralValues ∅) + publishedValues_empty hresult + +theorem concreteSupport_of_mem_runResolved_chronologicalRetainedPrefix + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (result : ResolvedRunResult + ((Digest × (Forgery × QueryLog SigningSpec)) × SplitHashCache)) + (completion : Coordinate → HashOutput) + (hresult : some result ∈ support + (runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table + ((maskedChronologicalRetainedPrefixAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) + (hcompletion : DeferredCompletion table result.context completion) : + ∃ concreteCache, + ResolvedContextInvariant parameter table result.context + (ordinaryQueryCache result.value.2) concreteCache ∧ + VisibleResolvedComputationsCached parameter table result.context concreteCache ∧ + PublishedValues result.context.state ∧ + (result.value.1, concreteCache) ∈ support + ((concreteRetainedPrefixAfterFtsSecrets adversary parameter table ftsSecret).run ∅) := + concreteSupport_of_mem_runResolved_of_reachableResolvedCouples + (reachableResolvedCouples_chronologicalRetainedPrefixAfterFtsSecrets adversary parameter + table ftsSecret) + (resolvedContextInvariant_empty parameter table) + (visibleResolvedComputationsCached_empty parameter table emptyDeferredStructuralValues ∅) + publishedValues_empty hresult hcompletion + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem not_verifyProbe_of_mem_runResolved_maskedChronologicalRetainedGame + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (targetCache : QueryCache HashSpec) + (completion : Coordinate → HashOutput) (fallback : QueryImpl HashSpec Id) + (fuel : Nat) + (result : ResolvedRunResult (RetainedGameResult × SplitHashCache)) + (hresult : some result ∈ support + (runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table + ((maskedChronologicalRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) + (hcompletion : DeferredCompletion table result.context completion) + (hfallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback) + (hlogRuns : ∀ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), entry ∈ result.value.1.2.1.2 → entry.2 = some signature → + SuccessfulSignRun (tableAnswer parameter completion fallback) targetCache + (⟨parameter, result.value.1.1, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + entry.1 signature) + (hprobe : VerifyProbeWitness (tableAnswer parameter completion fallback) targetCache + (⟨parameter, result.value.1.1, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + result.value.1.2.1.2 result.value.1.2.1.1.message + result.value.1.2.1.1.signature) : False := by + unfold maskedChronologicalRetainedGameAfterFtsSecrets at hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨prefixOption, hprefix, hrest⟩ := hresult + cases prefixOption with + | none => simp at hrest + | some prefixResult => + have hprefixCore : prefixResult.table = table ∧ + prefixResult.context.ValuesConsistent ∧ + StartTableAgrees prefixResult.context.state table := + resolvedCore_of_mem_runResolved_chronologicalRetainedPrefix adversary parameter table + ftsSecret fuel prefixResult hprefix + simp only at hrest + rw [hprefixCore.1] at hrest + have hprefixCompletion : DeferredCompletion table prefixResult.context completion := + hcompletion.of_mem_runResolvedFromTable _ prefixResult.context prefixResult.remaining table + result completion hprefixCore.2.1 hprefixCore.2.2 hrest + obtain ⟨prefixConcreteCache, hprefixInvariant, hprefixClosed, hprefixPublished, + _hprefixConcrete⟩ := + concreteSupport_of_mem_runResolved_chronologicalRetainedPrefix adversary parameter table + ftsSecret fuel prefixResult completion hprefix hprefixCompletion + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hrest + obtain ⟨verifierOption, hverifier, hfinish⟩ := hrest + cases verifierOption with + | none => simp at hfinish + | some verifierResult => + simp [runResolvedFromTable] at hfinish + subst result + have hprefixAllowed := + revealedChainAllowed_of_mem_runResolved_chronologicalRetainedPrefix adversary + parameter table ftsSecret targetCache completion fallback fuel prefixResult hprefix + hprefixCompletion + (CacheAgreesWithFnOffTable.of_reachableResolvedCouples + (reachableResolvedCouples_probingRom parameter table + (scheme.verify ⟨prefixResult.value.1.1, parameter⟩ + prefixResult.value.1.2.1.message prefixResult.value.1.2.1.signature)) + hprefixInvariant hprefixClosed hprefixPublished hverifier hcompletion hfallback + (fun value finalCache hright => + simulateQ_romImpl_cache_le + (scheme.verify ⟨prefixResult.value.1.1, parameter⟩ + prefixResult.value.1.2.1.message + prefixResult.value.1.2.1.signature) + prefixConcreteCache (value, finalCache) hright)) + hlogRuns + exact not_verifyProbe_of_mem_runResolved_verifier parameter table ftsSecret targetCache + prefixResult.value.1.1 prefixResult.value.1.2.1 prefixResult.value.1.2.2 completion + fallback prefixResult.context prefixResult.remaining prefixResult.value.2 + prefixConcreteCache verifierResult hprefixInvariant hprefixClosed hprefixPublished + hprefixAllowed hverifier hcompletion hfallback hprobe + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCombinedCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCombinedCharge.lean new file mode 100644 index 00000000..282dd3fd --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCombinedCharge.lean @@ -0,0 +1,40 @@ +import SphincsSecurity.Proof.OtsProbeHiddenSelectionCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +noncomputable def combinedOtsProbeCharge (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) : ℝ≥0∞ := + materializedRetainedCharge adversary parameter ftsSecret (2 * q) + + sampledHiddenSelectionCharge adversary parameter ftsSecret q + + sampledResidualSelectionCharge adversary parameter ftsSecret q + +theorem probEvent_sampledActualRetained_verifyProbe_le_combinedCharge126 + (adversary : Adversary) (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + combinedOtsProbeCharge adversary parameter ftsSecret q * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply (probEvent_sampledActualRetained_verifyProbe_le_charge_add_hiddenFailures adversary parameter ftsSecret q hbound).trans + apply (add_le_add + (add_le_add le_rfl (probEvent_sampledDiagnostic_successfulDoomed_le_selectionCharge126 adversary parameter ftsSecret q hbound hq)) + (probEvent_jointResidual_le_selectionCharge126 adversary parameter ftsSecret q hbound hq)).trans_eq + rw [← add_mul, ← add_mul] + rfl + +theorem probEvent_sampledActualRetained_verifyProbe_le_combinedCharge126_of_hashQueryBound + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + combinedOtsProbeCharge adversary parameter ftsSecret q * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + probEvent_sampledActualRetained_verifyProbe_le_combinedCharge126 adversary parameter ftsSecret q + (fun table root => isQueryBoundP_expandedRetained_all_tables_roots adversary q hq parameter hparameter table ftsSecret hfts root) hqMax + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCompletionSampling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCompletionSampling.lean new file mode 100644 index 00000000..fa4a04f0 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCompletionSampling.lean @@ -0,0 +1,907 @@ +import SphincsSecurity.Proof.OtsProbeCoupling + +/-! +# Finite boundary of one-time completion + +The concrete retained game observes a completed hidden table only through its chain-start values. +Those values form the finite `OtsSecretIndex` table already used by the concrete sampler transport. +Structural positions remain dynamic on the masked side and do not enter the distributional target. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def baseStartsOfTable (table : OtsSecretIndex → HashOutput) : + Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput := + fun lay tree leafIdx chainIdx => table ⟨lay, tree, leafIdx, chainIdx⟩ + +def completedStartTable (state : LazyRevealProbe.State Coordinate) + (base : OtsSecretIndex → HashOutput) : OtsSecretIndex → HashOutput := + fun index => (state.values index.coordinate).getD (base index) + +theorem completedStartTable_complete_coordinate + (state : LazyRevealProbe.State Coordinate) (base : OtsSecretIndex → HashOutput) + (index : OtsSecretIndex) (output : HashOutput) : + completedStartTable (state.complete index.coordinate output) base = + Function.update (completedStartTable state base) index output := by + funext other + by_cases heq : other = index + · subst other + simp [completedStartTable, LazyRevealProbe.State.complete] + · have hcoordinate : other.coordinate ≠ index.coordinate := + fun h => heq (OtsSecretIndex.coordinate_injective h) + simp [completedStartTable, LazyRevealProbe.State.complete, heq, hcoordinate] + +theorem completedStartTable_materialize_coordinate + (state : LazyRevealProbe.State Coordinate) (base : OtsSecretIndex → HashOutput) + (index : OtsSecretIndex) (output : HashOutput) : + completedStartTable (state.materialize index.coordinate output) base = + Function.update (completedStartTable state base) index output := by + funext other + by_cases heq : other = index + · subst other + simp [completedStartTable, LazyRevealProbe.State.materialize] + · have hcoordinate : other.coordinate ≠ index.coordinate := + fun h => heq (OtsSecretIndex.coordinate_injective h) + simp [completedStartTable, LazyRevealProbe.State.materialize, heq, hcoordinate] + +@[simp] theorem completedStartTable_complete_position + (state : LazyRevealProbe.State Coordinate) (base : OtsSecretIndex → HashOutput) + (position : Position) (output : HashOutput) : + completedStartTable (state.complete (.position position) output) base = + completedStartTable state base := by + funext index + simp [completedStartTable, LazyRevealProbe.State.complete, OtsSecretIndex.coordinate] + +@[simp] theorem completedStartTable_materialize_position + (state : LazyRevealProbe.State Coordinate) (base : OtsSecretIndex → HashOutput) + (position : Position) (output : HashOutput) : + completedStartTable (state.materialize (.position position) output) base = + completedStartTable state base := by + funext index + simp [completedStartTable, LazyRevealProbe.State.materialize, OtsSecretIndex.coordinate] + +theorem completedStartTable_update_base_of_missing + (state : LazyRevealProbe.State Coordinate) (base : OtsSecretIndex → HashOutput) + (index : OtsSecretIndex) (output : HashOutput) + (hmissing : state.values index.coordinate = none) : + completedStartTable state (Function.update base index output) = + Function.update (completedStartTable state base) index output := by + funext other + by_cases heq : other = index + · subst other + simp [completedStartTable, hmissing] + · simp [completedStartTable, heq] + +@[simp] theorem completedStartTable_clearPending + (state : LazyRevealProbe.State Coordinate) (base : OtsSecretIndex → HashOutput) + (coordinate : Coordinate) : + completedStartTable (state.clearPending coordinate) base = + completedStartTable state base := by + rfl + +@[simp] theorem completedStartTable_ensure + (state : LazyRevealProbe.State Coordinate) (base : OtsSecretIndex → HashOutput) + (coordinate : Coordinate) : + completedStartTable (state.ensure coordinate) base = completedStartTable state base := by + rfl + +@[simp] theorem completedStartTable_publish + (state : LazyRevealProbe.State Coordinate) (base : OtsSecretIndex → HashOutput) + (coordinate : Coordinate) : + completedStartTable (state.publish coordinate) base = completedStartTable state base := by + rfl + +@[simp] theorem completedStartTable_addPending + (state : LazyRevealProbe.State Coordinate) (base : OtsSecretIndex → HashOutput) + (coordinate : Coordinate) (candidate : Digest) : + completedStartTable (state.addPending coordinate candidate) base = + completedStartTable state base := by + rfl + +def extendStartTable (table : OtsSecretIndex → HashOutput) : Coordinate → HashOutput + | .chainStart lay tree leafIdx chainIdx => table ⟨lay, tree, leafIdx, chainIdx⟩ + | .position _ => 0 + +@[simp] theorem tableOtsSecret_extendStartTable + (table : OtsSecretIndex → HashOutput) : + tableOtsSecret (extendStartTable table) = + otsSecretTableEquiv.symm (fun index => truncateHash (table index)) := by + funext lay tree leafIdx chainIdx + rfl + +theorem tableOtsSecret_retainedCompletionTable_eq_completedStartTable + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (base : OtsSecretIndex → HashOutput) : + tableOtsSecret + (retainedCompletionTable parameter state cache (baseStartsOfTable base)) = + otsSecretTableEquiv.symm + (fun index => truncateHash (completedStartTable state base index)) := by + funext lay tree leafIdx chainIdx + rfl + +theorem tableOtsSecret_retainedCompletionTable_eq_extendStartTable + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (base : OtsSecretIndex → HashOutput) : + tableOtsSecret + (retainedCompletionTable parameter state cache (baseStartsOfTable base)) = + tableOtsSecret (extendStartTable (completedStartTable state base)) := by + rw [tableOtsSecret_retainedCompletionTable_eq_completedStartTable, + tableOtsSecret_extendStartTable] + +theorem actualRetainedGameAfterTable_congr_tableOtsSecret + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (left right : Coordinate → HashOutput) + (hsecret : tableOtsSecret left = tableOtsSecret right) : + actualRetainedGameAfterTable adversary parameter ftsSecret left = + actualRetainedGameAfterTable adversary parameter ftsSecret right := by + unfold actualRetainedGameAfterTable + rw [hsecret] + +theorem actualRetainedGameAfterTable_retainedCompletion_eq_finite + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (base : OtsSecretIndex → HashOutput) : + actualRetainedGameAfterTable adversary parameter ftsSecret + (retainedCompletionTable parameter state cache (baseStartsOfTable base)) = + actualRetainedGameAfterTable adversary parameter ftsSecret + (extendStartTable (completedStartTable state base)) := by + apply actualRetainedGameAfterTable_congr_tableOtsSecret + exact tableOtsSecret_retainedCompletionTable_eq_extendStartTable parameter state cache base + +noncomputable def actualRetainedGameAfterOtsSecret (adversary : Adversary) + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) : + ProbComp (RetainedGameResult × QueryCache HashSpec) := do + let (root, rootCache) ← + (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅ + let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + let (result, finalCache) ← + (simulateQ (unloggedMappedAdversaryImpl secretKey) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).run rootCache + pure ((root, result), finalCache) + +theorem actualRetainedGameAfterTable_eq_afterOtsSecret + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : Coordinate → HashOutput) : + actualRetainedGameAfterTable adversary parameter ftsSecret table = + actualRetainedGameAfterOtsSecret adversary parameter ftsSecret + (tableOtsSecret table) := by + rfl + +noncomputable local instance completionSampleableOtsHashTable : + SampleableType (OtsSecretIndex → HashOutput) := + SampleableType.ofFintype (OtsSecretIndex → HashOutput) + +set_option maxRecDepth 10000 in +theorem evalDist_complete_missing_start + (state : LazyRevealProbe.State Coordinate) (index : OtsSecretIndex) + (hmissing : state.values index.coordinate = none) : + 𝒟[do + let output ← LazyRevealProbe.sampleHashOutput + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + pure (completedStartTable (state.complete index.coordinate output) base)] = + 𝒟[completedStartTable state <$> + ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput))] := by + have hupdate := evalDist_uniformSample_bind_update + (R := HashOutput) index + calc + _ = 𝒟[do + let output ← ($ᵗ HashOutput : ProbComp HashOutput) + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + pure (completedStartTable state (Function.update base index output))] := by + apply congrArg evalDist + simp only [LazyRevealProbe.sampleHashOutput] + apply bind_congr + intro output + apply bind_congr + intro base + rw [completedStartTable_complete_coordinate, + completedStartTable_update_base_of_missing state base index output hmissing] + _ = 𝒟[completedStartTable state <$> (do + let output ← ($ᵗ HashOutput : ProbComp HashOutput) + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + pure (Function.update base index output))] := by + simp [map_eq_bind_pure_comp, bind_assoc] + _ = _ := by + rw [evalDist_map, hupdate, ← evalDist_map] + +set_option maxRecDepth 10000 in +theorem evalDist_materialize_missing_start + (state : LazyRevealProbe.State Coordinate) (index : OtsSecretIndex) + (hmissing : state.values index.coordinate = none) : + 𝒟[do + let output ← LazyRevealProbe.sampleHashOutput + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + pure (completedStartTable (state.materialize index.coordinate output) base)] = + 𝒟[completedStartTable state <$> + ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput))] := by + calc + _ = 𝒟[do + let output ← LazyRevealProbe.sampleHashOutput + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + pure (completedStartTable (state.complete index.coordinate output) base)] := by + apply congrArg evalDist + apply bind_congr + intro output + apply bind_congr + intro base + rw [completedStartTable_materialize_coordinate, + completedStartTable_complete_coordinate] + _ = _ := evalDist_complete_missing_start state index hmissing + +set_option maxRecDepth 100000 in +theorem evalDist_completionTable_bind_cell_extract {β : Type} + (index : OtsSecretIndex) + (cont : (OtsSecretIndex → HashOutput) → HashOutput → ProbComp β) : + 𝒟[do + let table ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + cont table (table index)] = + 𝒟[do + let output ← ($ᵗ HashOutput : ProbComp HashOutput) + let table ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + cont (Function.update table index output) output] := by + classical + have hleft : + (do + let table ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + cont table (table index)) = + ((do + let table ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + pure (table, table index)) >>= fun pair => cont pair.1 pair.2) := by + simp + have hright : + (do + let output ← ($ᵗ HashOutput : ProbComp HashOutput) + let table ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + cont (Function.update table index output) output) = + ((do + let output ← ($ᵗ HashOutput : ProbComp HashOutput) + let table ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + pure (Function.update table index output, output)) >>= + fun pair => cont pair.1 pair.2) := by + simp + rw [hleft, hright] + have hpureEq : ∀ (table : OtsSecretIndex → HashOutput) (output : HashOutput), + (Function.update table index output, output) = + ((fun table' : OtsSecretIndex → HashOutput => (table', table' index)) + (Function.update table index output)) := fun _ _ => by simp + have hcore : + 𝒟[do + let output ← ($ᵗ HashOutput : ProbComp HashOutput) + let table ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + pure (Function.update table index output, output)] = + 𝒟[do + let table ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + pure (table, table index)] := by + have hrw : + (do + let output ← ($ᵗ HashOutput : ProbComp HashOutput) + let table ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + pure (Function.update table index output, output)) = + (do + let output ← ($ᵗ HashOutput : ProbComp HashOutput) + let table ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + pure ((fun table' : OtsSecretIndex → HashOutput => (table', table' index)) + (Function.update table index output))) := + bind_congr fun output => bind_congr fun table => by rw [hpureEq table output] + rw [hrw] + exact OracleComp.evalDist_uniformSample_bind_update_map + (R := HashOutput) index (fun table' => (table', table' index)) + refine evalDist_ext fun output => ?_ + rw [probOutput_bind_eq_tsum, probOutput_bind_eq_tsum] + refine tsum_congr fun pair => ?_ + have hprob := OracleComp.probOutput_congr (x := pair) rfl hcore.symm + rw [hprob] + +set_option maxRecDepth 100000 in +theorem evalDist_complete_missing_start_clean + (state : LazyRevealProbe.State Coordinate) (index : OtsSecretIndex) + (hmissing : state.values index.coordinate = none) : + 𝒟[do + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + let table := completedStartTable state base + let output := table index + if state.hitAt index.coordinate output then + pure none + else + pure (some (state.complete index.coordinate output, table))] = + 𝒟[do + let output ← LazyRevealProbe.sampleHashOutput + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + if state.hitAt index.coordinate output then + pure none + else + pure (some (state.complete index.coordinate output, + completedStartTable (state.complete index.coordinate output) base))] := by + let cont := fun table : OtsSecretIndex → HashOutput => fun output : HashOutput => + if state.hitAt index.coordinate output then + (pure none : ProbComp (Option + (LazyRevealProbe.State Coordinate × (OtsSecretIndex → HashOutput)))) + else + pure (some (state.complete index.coordinate output, + completedStartTable state table)) + have hcell := evalDist_completionTable_bind_cell_extract + (β := Option + (LazyRevealProbe.State Coordinate × (OtsSecretIndex → HashOutput))) index cont + calc + _ = 𝒟[do + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + cont base (base index)] := by + apply congrArg evalDist + apply bind_congr + intro base + simp [cont, completedStartTable, hmissing] + _ = 𝒟[do + let output ← ($ᵗ HashOutput : ProbComp HashOutput) + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + cont (Function.update base index output) output] := hcell + _ = _ := by + apply congrArg evalDist + simp only [LazyRevealProbe.sampleHashOutput] + apply bind_congr + intro output + apply bind_congr + intro base + by_cases hhit : state.hitAt index.coordinate output + · simp [cont, hhit] + · simp only [cont, hhit, ↓reduceIte] + rw [completedStartTable_update_base_of_missing state base index output hmissing, + ← completedStartTable_complete_coordinate] + +set_option maxRecDepth 100000 in +theorem evalDist_complete_missing_start_clean_cont {β : Type} + (state : LazyRevealProbe.State Coordinate) (index : OtsSecretIndex) + (hmissing : state.values index.coordinate = none) + (next : LazyRevealProbe.State Coordinate → (OtsSecretIndex → HashOutput) → + ProbComp (Option β)) : + 𝒟[do + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + let table := completedStartTable state base + let output := table index + if state.hitAt index.coordinate output then + pure none + else + next (state.complete index.coordinate output) table] = + 𝒟[do + let output ← LazyRevealProbe.sampleHashOutput + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + if state.hitAt index.coordinate output then + pure none + else + next (state.complete index.coordinate output) + (completedStartTable (state.complete index.coordinate output) base)] := by + let cont := fun table : OtsSecretIndex → HashOutput => fun output : HashOutput => + if state.hitAt index.coordinate output then + (pure none : ProbComp (Option β)) + else + next (state.complete index.coordinate output) (completedStartTable state table) + have hcell := evalDist_completionTable_bind_cell_extract + (β := Option β) index cont + calc + _ = 𝒟[do + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + cont base (base index)] := by + apply congrArg evalDist + apply bind_congr + intro base + by_cases hhit : state.hitAt index.coordinate + (completedStartTable state base index) + · simp [cont, completedStartTable, hmissing] + · have hlookup : completedStartTable state base index = base index := by + simp [completedStartTable, hmissing] + simp only [cont, hlookup] + _ = 𝒟[do + let output ← ($ᵗ HashOutput : ProbComp HashOutput) + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + cont (Function.update base index output) output] := hcell + _ = _ := by + apply congrArg evalDist + simp only [LazyRevealProbe.sampleHashOutput] + apply bind_congr + intro output + apply bind_congr + intro base + by_cases hhit : state.hitAt index.coordinate output + · simp [cont, hhit] + · simp only [cont, hhit, ↓reduceIte] + rw [completedStartTable_update_base_of_missing state base index output hmissing, + ← completedStartTable_complete_coordinate] + +set_option maxRecDepth 100000 in +theorem evalDist_materialize_missing_start_clean + (state : LazyRevealProbe.State Coordinate) (index : OtsSecretIndex) + (hmissing : state.values index.coordinate = none) : + 𝒟[do + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + let table := completedStartTable state base + let output := table index + if state.hitAt index.coordinate output then + pure none + else + pure (some (state.materialize index.coordinate output, table))] = + 𝒟[do + let output ← LazyRevealProbe.sampleHashOutput + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + if state.hitAt index.coordinate output then + pure none + else + pure (some (state.materialize index.coordinate output, + completedStartTable (state.materialize index.coordinate output) base))] := by + let cont := fun table : OtsSecretIndex → HashOutput => fun output : HashOutput => + if state.hitAt index.coordinate output then + (pure none : ProbComp (Option + (LazyRevealProbe.State Coordinate × (OtsSecretIndex → HashOutput)))) + else + pure (some (state.materialize index.coordinate output, + completedStartTable state table)) + have hcell := evalDist_completionTable_bind_cell_extract + (β := Option + (LazyRevealProbe.State Coordinate × (OtsSecretIndex → HashOutput))) index cont + calc + _ = 𝒟[do + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + cont base (base index)] := by + apply congrArg evalDist + apply bind_congr + intro base + simp [cont, completedStartTable, hmissing] + _ = 𝒟[do + let output ← ($ᵗ HashOutput : ProbComp HashOutput) + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + cont (Function.update base index output) output] := hcell + _ = _ := by + apply congrArg evalDist + simp only [LazyRevealProbe.sampleHashOutput] + apply bind_congr + intro output + apply bind_congr + intro base + by_cases hhit : state.hitAt index.coordinate output + · simp [cont, hhit] + · simp only [cont, hhit, ↓reduceIte] + rw [completedStartTable_update_base_of_missing state base index output hmissing, + ← completedStartTable_materialize_coordinate] + +set_option maxRecDepth 100000 in +theorem evalDist_materialize_missing_start_clean_cont {β : Type} + (state : LazyRevealProbe.State Coordinate) (index : OtsSecretIndex) + (hmissing : state.values index.coordinate = none) + (next : LazyRevealProbe.State Coordinate → (OtsSecretIndex → HashOutput) → + ProbComp (Option β)) : + 𝒟[do + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + let table := completedStartTable state base + let output := table index + if state.hitAt index.coordinate output then + pure none + else + next (state.materialize index.coordinate output) table] = + 𝒟[do + let output ← LazyRevealProbe.sampleHashOutput + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + if state.hitAt index.coordinate output then + pure none + else + next (state.materialize index.coordinate output) + (completedStartTable (state.materialize index.coordinate output) base)] := by + let cont := fun table : OtsSecretIndex → HashOutput => fun output : HashOutput => + if state.hitAt index.coordinate output then + (pure none : ProbComp (Option β)) + else + next (state.materialize index.coordinate output) (completedStartTable state table) + have hcell := evalDist_completionTable_bind_cell_extract + (β := Option β) index cont + calc + _ = 𝒟[do + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + cont base (base index)] := by + apply congrArg evalDist + apply bind_congr + intro base + by_cases hhit : state.hitAt index.coordinate + (completedStartTable state base index) + · simp [cont, completedStartTable, hmissing] + · have hlookup : completedStartTable state base index = base index := by + simp [completedStartTable, hmissing] + simp only [cont, hlookup] + _ = 𝒟[do + let output ← ($ᵗ HashOutput : ProbComp HashOutput) + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + cont (Function.update base index output) output] := hcell + _ = _ := by + apply congrArg evalDist + simp only [LazyRevealProbe.sampleHashOutput] + apply bind_congr + intro output + apply bind_congr + intro base + by_cases hhit : state.hitAt index.coordinate output + · simp [cont, hhit] + · simp only [cont, hhit, ↓reduceIte] + rw [completedStartTable_update_base_of_missing state base index output hmissing, + ← completedStartTable_materialize_coordinate] + +noncomputable def finalizeCleanFromTable : + List Coordinate → LazyRevealProbe.State Coordinate → + (OtsSecretIndex → HashOutput) → + ProbComp (Option + (LazyRevealProbe.State Coordinate × (OtsSecretIndex → HashOutput))) + | [], state, table => pure (some (state, table)) + | coordinate :: remaining, state, table => + match state.values coordinate with + | some _ => finalizeCleanFromTable remaining (state.clearPending coordinate) table + | none => + match coordinate with + | .chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + if state.hitAt coordinate output then + pure none + else + finalizeCleanFromTable remaining (state.complete coordinate output) table + | .position _ => do + let output ← LazyRevealProbe.sampleHashOutput + if state.hitAt coordinate output then + pure none + else + finalizeCleanFromTable remaining (state.complete coordinate output) table + +noncomputable def finalizeCleanWithCompletionTable + (coordinates : List Coordinate) (state : LazyRevealProbe.State Coordinate) : + ProbComp (Option + (LazyRevealProbe.State Coordinate × (OtsSecretIndex → HashOutput))) := do + let result ← LazyRevealProbe.finalizeDetailedFrom coordinates state + if result.1 then + pure none + else + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + pure (some (result.2, completedStartTable result.2 base)) + +theorem finalizeCleanWithCompletionTable_cons_of_some + (coordinate : Coordinate) (remaining : List Coordinate) + (state : LazyRevealProbe.State Coordinate) (output : HashOutput) + (hvalue : state.values coordinate = some output) : + finalizeCleanWithCompletionTable (coordinate :: remaining) state = + finalizeCleanWithCompletionTable remaining (state.clearPending coordinate) := by + unfold finalizeCleanWithCompletionTable + rw [LazyRevealProbe.finalizeDetailedFrom, hvalue] + +theorem finalizeCleanWithCompletionTable_cons_of_none + (coordinate : Coordinate) (remaining : List Coordinate) + (state : LazyRevealProbe.State Coordinate) + (hvalue : state.values coordinate = none) : + finalizeCleanWithCompletionTable (coordinate :: remaining) state = (do + let output ← LazyRevealProbe.sampleHashOutput + if state.hitAt coordinate output then + pure none + else + finalizeCleanWithCompletionTable remaining (state.complete coordinate output)) := by + unfold finalizeCleanWithCompletionTable + rw [LazyRevealProbe.finalizeDetailedFrom, hvalue, bind_assoc] + apply bind_congr + intro output + by_cases hhit : state.hitAt coordinate output + · simp [hhit] + · simp [hhit] + +set_option maxRecDepth 100000 in +theorem evalDist_finalizeCleanFromTable_eq_lazy : + ∀ (coordinates : List Coordinate) (state : LazyRevealProbe.State Coordinate), + 𝒟[do + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + finalizeCleanFromTable coordinates state (completedStartTable state base)] = + 𝒟[finalizeCleanWithCompletionTable coordinates state] := by + intro coordinates + induction coordinates with + | nil => + intro state + simp [finalizeCleanFromTable, finalizeCleanWithCompletionTable, + LazyRevealProbe.finalizeDetailedFrom] + | cons coordinate remaining ih => + intro state + cases hvalue : state.values coordinate with + | some output => + have hleft : + (do + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + finalizeCleanFromTable (coordinate :: remaining) state + (completedStartTable state base)) = + (do + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + finalizeCleanFromTable remaining (state.clearPending coordinate) + (completedStartTable (state.clearPending coordinate) base)) := by + apply bind_congr + intro base + simp [finalizeCleanFromTable, hvalue] + rw [congrArg evalDist hleft] + rw [finalizeCleanWithCompletionTable_cons_of_some coordinate remaining state output + hvalue] + exact ih (state.clearPending coordinate) + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + calc + _ = 𝒟[do + let output ← LazyRevealProbe.sampleHashOutput + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + if state.hitAt index.coordinate output then + pure none + else + finalizeCleanFromTable remaining + (state.complete index.coordinate output) + (completedStartTable + (state.complete index.coordinate output) base)] := by + simpa [finalizeCleanFromTable, hvalue, index, + OtsSecretIndex.coordinate] using + evalDist_complete_missing_start_clean_cont + state index hvalue (fun nextState table => + finalizeCleanFromTable remaining nextState table) + _ = _ := by + rw [finalizeCleanWithCompletionTable_cons_of_none + (.chainStart lay tree leafIdx chainIdx) remaining state hvalue] + rw [evalDist_bind, evalDist_bind] + apply congrArg + funext freshOutput + simp only [index, OtsSecretIndex.coordinate] + by_cases hhit : state.hitAt + (.chainStart lay tree leafIdx chainIdx) freshOutput + · + simp only [hhit, ↓reduceIte] + have hdrop := + OracleComp.DeferredSampling.evalDist_bind_const_neverFails + ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + (by simp) (pure none : ProbComp (Option + (LazyRevealProbe.State Coordinate × + (OtsSecretIndex → HashOutput)))) + simpa [finalizeCleanWithCompletionTable] using hdrop + · + simp only [hhit, ↓reduceIte] + exact ih (state.complete + (.chainStart lay tree leafIdx chainIdx) freshOutput) + | position position => + let coordinate : Coordinate := .position position + let tableSample := ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + let outputSample := LazyRevealProbe.sampleHashOutput + calc + _ = 𝒟[tableSample >>= fun base => outputSample >>= fun freshOutput => + if state.hitAt coordinate freshOutput then + pure none + else + finalizeCleanFromTable remaining + (state.complete coordinate freshOutput) + (completedStartTable state base)] := by + apply congrArg evalDist + simp [finalizeCleanFromTable, hvalue, coordinate, tableSample, + outputSample] + _ = 𝒟[outputSample >>= fun freshOutput => tableSample >>= fun base => + if state.hitAt coordinate freshOutput then + pure none + else + finalizeCleanFromTable remaining + (state.complete coordinate freshOutput) + (completedStartTable state base)] := + OracleComp.DeferredSampling.evalDist_bind_comm tableSample outputSample _ + _ = _ := by + rw [finalizeCleanWithCompletionTable_cons_of_none coordinate remaining state + (by simpa [coordinate] using hvalue)] + rw [evalDist_bind, evalDist_bind] + apply congrArg + funext freshOutput + by_cases hhit : state.hitAt coordinate freshOutput + · simp only [hhit, ↓reduceIte] + have hdrop := + OracleComp.DeferredSampling.evalDist_bind_const_neverFails + tableSample (by simp [tableSample]) + (pure none : ProbComp (Option + (LazyRevealProbe.State Coordinate × + (OtsSecretIndex → HashOutput)))) + simpa [finalizeCleanWithCompletionTable] using hdrop + · simp only [hhit, ↓reduceIte] + have hleft : + (tableSample >>= fun base => + finalizeCleanFromTable remaining + (state.complete coordinate freshOutput) + (completedStartTable state base)) = + (tableSample >>= fun base => + finalizeCleanFromTable remaining + (state.complete coordinate freshOutput) + (completedStartTable + (state.complete coordinate freshOutput) base)) := by + apply bind_congr + intro base + rw [completedStartTable_complete_position] + rw [congrArg evalDist hleft] + exact ih (state.complete coordinate freshOutput) + +noncomputable def sampledActualRetainedOtsHashTable (adversary : Adversary) + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ProbComp ((OtsSecretIndex → HashOutput) × + (RetainedGameResult × QueryCache HashSpec)) := do + let table ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + let result ← actualRetainedGameAfterTable adversary parameter ftsSecret + (extendStartTable table) + pure (table, result) + +noncomputable def sampledActualRetainedOtsSecrets (adversary : Adversary) + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ProbComp ((Layer → TreeIndex → LeafIndex → ChainIndex → Digest) × + (RetainedGameResult × QueryCache HashSpec)) := do + let otsSecret ← sampleOtsSecrets + let result ← actualRetainedGameAfterOtsSecret adversary parameter ftsSecret otsSecret + pure (otsSecret, result) + +set_option maxRecDepth 10000 in +theorem relTriple_sampledActualRetainedOtsHashTable_secrets + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + RelTriple + (sampledActualRetainedOtsHashTable adversary parameter ftsSecret) + (sampledActualRetainedOtsSecrets adversary parameter ftsSecret) + fun left right => + otsSecretTableEquiv.symm + (fun index => truncateHash (left.1 index)) = right.1 ∧ + left.2 = right.2 := by + unfold sampledActualRetainedOtsHashTable sampledActualRetainedOtsSecrets + apply relTriple_bind relTriple_uniformOtsHashTable_sampleOtsSecrets + intro table otsSecret hsecret + have hgame : + actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table) = + actualRetainedGameAfterOtsSecret adversary parameter ftsSecret otsSecret := by + rw [actualRetainedGameAfterTable_eq_afterOtsSecret, + tableOtsSecret_extendStartTable, hsecret] + rw [hgame] + have hrun := relTriple_refl + (actualRetainedGameAfterOtsSecret adversary parameter ftsSecret otsSecret) + have hpre : RelTriple + (actualRetainedGameAfterOtsSecret adversary parameter ftsSecret otsSecret) + (actualRetainedGameAfterOtsSecret adversary parameter ftsSecret otsSecret) + (fun left right => + otsSecretTableEquiv.symm (fun index => truncateHash (table index)) = otsSecret ∧ + left = right) := by + apply relTriple_post_mono hrun + intro left right heq + exact ⟨hsecret, heq⟩ + exact relTriple_map + (R := fun left right => + otsSecretTableEquiv.symm (fun index => truncateHash (left.1 index)) = right.1 ∧ + left.2 = right.2) + (f := fun result => (table, result)) (g := fun result => (otsSecret, result)) hpre + +theorem probEvent_sampledActualRetainedOtsHashTable_eq_secrets + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (event : (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) → + (RetainedGameResult × QueryCache HashSpec) → Prop) : + Pr[fun result => event + (otsSecretTableEquiv.symm + (fun index => truncateHash (result.1 index))) result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] = + Pr[fun result => event result.1 result.2 | + sampledActualRetainedOtsSecrets adversary parameter ftsSecret] := by + have hrel := relTriple_sampledActualRetainedOtsHashTable_secrets + adversary parameter ftsSecret + apply le_antisymm + · apply probEvent_le_of_relTriple hrel + intro left right hrelation hevent + rw [hrelation.1, hrelation.2] at hevent + exact hevent + · apply probEvent_le_of_relTriple (relTriple_symm hrel) + intro right left hrelation hevent + rw [hrelation.1, hrelation.2] + exact hevent + +noncomputable def hashOutputOfDigest (digest : Digest) : HashOutput := + (splitHashOutputEquiv digestBits (by decide)).symm (digest, 0) + +@[simp] theorem truncateHash_hashOutputOfDigest (digest : Digest) : + truncateHash (hashOutputOfDigest digest) = digest := by + change (splitHashOutput digestBits + ((splitHashOutputEquiv digestBits (by decide)).symm (digest, 0))).1 = digest + rw [show splitHashOutput digestBits = splitHashOutputEquiv digestBits (by decide) from rfl, + Equiv.apply_symm_apply] + +noncomputable def tableOfOtsSecret + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) : + Coordinate → HashOutput := + extendStartTable fun index => hashOutputOfDigest (otsSecretTableEquiv otsSecret index) + +@[simp] theorem tableOtsSecret_tableOfOtsSecret + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) : + tableOtsSecret (tableOfOtsSecret otsSecret) = otsSecret := by + rw [tableOfOtsSecret, tableOtsSecret_extendStartTable] + simp + +theorem winningRetainedVerifyProbe_congr_tableOtsSecret + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (left right : Coordinate → HashOutput) + (hsecret : tableOtsSecret left = tableOtsSecret right) + (result : RetainedGameResult × QueryCache HashSpec) : + WinningRetainedVerifyProbeWitness parameter left ftsSecret result ↔ + WinningRetainedVerifyProbeWitness parameter right ftsSecret result := by + unfold WinningRetainedVerifyProbeWitness WinningRetainedWitnessFor + rw [hsecret] + +def WinningRetainedVerifyProbeAfterOtsSecret + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : RetainedGameResult × QueryCache HashSpec) : Prop := + WinningRetainedVerifyProbeWitness parameter (tableOfOtsSecret otsSecret) ftsSecret result + +theorem probEvent_sampledWinningRetainedVerifyProbe_eq_secrets + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] = + Pr[fun result => WinningRetainedVerifyProbeAfterOtsSecret parameter result.1 + ftsSecret result.2 | + sampledActualRetainedOtsSecrets adversary parameter ftsSecret] := by + let toSecret := fun table : OtsSecretIndex → HashOutput => + otsSecretTableEquiv.symm (fun index => truncateHash (table index)) + calc + _ = Pr[fun result => WinningRetainedVerifyProbeAfterOtsSecret parameter + (toSecret result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] := by + apply OracleComp.probEvent_congr' fun result _ => + winningRetainedVerifyProbe_congr_tableOtsSecret parameter ftsSecret + (extendStartTable result.1) (tableOfOtsSecret (toSecret result.1)) + (by simp [toSecret]) result.2 + rfl + _ = _ := probEvent_sampledActualRetainedOtsHashTable_eq_secrets adversary parameter + ftsSecret (fun otsSecret result => + WinningRetainedVerifyProbeAfterOtsSecret parameter otsSecret ftsSecret result) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCoupling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCoupling.lean new file mode 100644 index 00000000..500042e8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCoupling.lean @@ -0,0 +1,11019 @@ +import SphincsSecurity.Proof.OtsProbeTrace +import SphincsSecurity.Proof.FtsProbeProbability + +/-! +# Retained one-time game coupling + +The ordinary side of the split probing oracle is exactly the real lazy random oracle. This module +packages that distributional identity as the relational kernel used by the retained-game lift. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def RawOrdinaryResultRel : + LazyRevealProbe.RawResult Coordinate (alpha × SplitHashCache) → + (alpha × QueryCache HashSpec) → Prop + | .stopped _, _ => False + | .done _ _ (value, cache), ordinaryResult => + ordinaryResult = (value, ordinaryQueryCache cache) + +def RawOrdinaryResultRelAt + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) : + LazyRevealProbe.RawResult Coordinate (alpha × SplitHashCache) → + (alpha × QueryCache HashSpec) → Prop + | .stopped _, _ => False + | .done finalState remaining (value, cache), ordinaryResult => + finalState = state ∧ remaining = fuel ∧ + ordinaryResult = (value, ordinaryQueryCache cache) + +def AnswersAgreeOnRun (f g : QueryImpl HashSpec Id) + (computation : OracleComp HashSpec alpha) : Prop := + ∀ input, input ∈ queriedInputs f computation → f input = g input + +theorem AnswersAgreeOnRun.eval_eq_and_queriedInputs_eq + {f g : QueryImpl HashSpec Id} {computation : OracleComp HashSpec alpha} + (hagrees : AnswersAgreeOnRun f g computation) : + evalWithAnswerFn f computation = evalWithAnswerFn g computation ∧ + queriedInputs f computation = queriedInputs g computation := by + induction computation using OracleComp.inductionOn with + | pure value => simp + | query_bind input next ih => + have hinput : f input = g input := by + apply hagrees input + rw [queriedInputs_query_bind] + exact List.mem_cons_self + have htail : AnswersAgreeOnRun f g (next (f input)) := by + intro query hquery + apply hagrees query + rw [queriedInputs_query_bind] + exact List.mem_cons_of_mem input hquery + obtain ⟨heval, hqueries⟩ := ih (f input) htail + constructor + · rw [evalWithAnswerFn_bind, evalWithAnswerFn_bind, + show evalWithAnswerFn f (liftM (HashSpec.query input)) = f input from + simulateQ_spec_query f input, + show evalWithAnswerFn g (liftM (HashSpec.query input)) = g input from + simulateQ_spec_query g input, + ← hinput] + exact heval + · rw [queriedInputs_query_bind, queriedInputs_query_bind, ← hinput, hqueries] + +theorem AnswersAgreeOnRun.eval_eq + {f g : QueryImpl HashSpec Id} {computation : OracleComp HashSpec alpha} + (hagrees : AnswersAgreeOnRun f g computation) : + evalWithAnswerFn f computation = evalWithAnswerFn g computation := + hagrees.eval_eq_and_queriedInputs_eq.1 + +theorem AnswersAgreeOnRun.queriedInputs_eq + {f g : QueryImpl HashSpec Id} {computation : OracleComp HashSpec alpha} + (hagrees : AnswersAgreeOnRun f g computation) : + queriedInputs f computation = queriedInputs g computation := + hagrees.eval_eq_and_queriedInputs_eq.2 + +def CacheAnswersAgreeOnRun (cache : QueryCache HashSpec) + (f : QueryImpl HashSpec Id) (computation : OracleComp HashSpec alpha) : Prop := + ∀ input, input ∈ queriedInputs f computation → + ∀ output, cache input = some output → f input = output + +theorem messageDigest_query_mem_verify + {f : QueryImpl HashSpec Id} {publicKey : PublicKey} {message : Message} + {signature : Signature} {input : HashInput} + (hquery : input ∈ queriedInputs f + (messageDigest publicKey.parameter publicKey.root message signature.randomness)) : + input ∈ queriedInputs f (verify publicKey message signature) := by + rw [verify_eq, queriedInputs_bind] + exact List.mem_append_left _ hquery + +theorem ftsRecover_query_mem_verify + {f : QueryImpl HashSpec Id} {publicKey : PublicKey} {message : Message} + {signature : Signature} {digest : MessageDigest} {input : HashInput} + (hdigest : evalWithAnswerFn f + (messageDigest publicKey.parameter publicKey.root message signature.randomness) = digest) + (hadmissible : Admissible digest) + (hquery : input ∈ queriedInputs f + (ftsRecover publicKey.parameter (digestIndex digest) (digestLeaves digest) + signature.ftsSecret signature.ftsPath)) : + input ∈ queriedInputs f (verify publicKey message signature) := by + rw [verify_eq, queriedInputs_bind] + apply List.mem_append_right + rw [hdigest] + simp only [hadmissible, not_true_eq_false, if_false, queriedInputs_bind] + exact List.mem_append_left _ hquery + +theorem verifyLayers_query_mem_verify + {f : QueryImpl HashSpec Id} {publicKey : PublicKey} {message : Message} + {signature : Signature} {digest : MessageDigest} {input : HashInput} + (hdigest : evalWithAnswerFn f + (messageDigest publicKey.parameter publicKey.root message signature.randomness) = digest) + (hadmissible : Admissible digest) + (hquery : input ∈ queriedInputs f + (verifyLayers publicKey.parameter (digestIndex digest) signature numLayers + (evalWithAnswerFn f + (ftsRecover publicKey.parameter (digestIndex digest) (digestLeaves digest) + signature.ftsSecret signature.ftsPath)))) : + input ∈ queriedInputs f (verify publicKey message signature) := by + rw [verify_eq, queriedInputs_bind] + apply List.mem_append_right + rw [hdigest] + simp only [hadmissible, not_true_eq_false, if_false, queriedInputs_bind] + apply List.mem_append_right + exact List.mem_append_left _ hquery + +theorem bottomOts_query_mem_verify + {f : QueryImpl HashSpec Id} {publicKey : PublicKey} {message : Message} + {signature : Signature} {digest : MessageDigest} {input : HashInput} + (hdigest : evalWithAnswerFn f + (messageDigest publicKey.parameter publicKey.root message signature.randomness) = digest) + (hadmissible : Admissible digest) + (hquery : input ∈ queriedInputs f + (otsLeaf publicKey.parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (evalWithAnswerFn f + (ftsRecover publicKey.parameter (digestIndex digest) (digestLeaves digest) + signature.ftsSecret signature.ftsPath)) + (signature.counter bottomLayer) (signature.chainValue bottomLayer))) : + input ∈ queriedInputs f (verify publicKey message signature) := by + apply verifyLayers_query_mem_verify hdigest hadmissible + rw [show numLayers = bottomLayer.val + 1 by rfl, verifyLayers_succ_eq, + dif_pos bottomLayer.isLt] + exact queriedInputs_mono_bind_left f _ _ hquery + +theorem bottomFold_query_mem_verify + {f : QueryImpl HashSpec Id} {publicKey : PublicKey} {message : Message} + {signature : Signature} {digest : MessageDigest} {bottomLeaf : Digest} + {input : HashInput} + (hdigest : evalWithAnswerFn f + (messageDigest publicKey.parameter publicKey.root message signature.randomness) = digest) + (hadmissible : Admissible digest) + (hbottom : evalWithAnswerFn f + (otsLeaf publicKey.parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (evalWithAnswerFn f + (ftsRecover publicKey.parameter (digestIndex digest) (digestLeaves digest) + signature.ftsSecret signature.ftsPath)) + (signature.counter bottomLayer) (signature.chainValue bottomLayer)) = some bottomLeaf) + (hquery : input ∈ queriedInputs f + (treeFold publicKey.parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath signature bottomLayer) (layerHeight bottomLayer) bottomLeaf)) : + input ∈ queriedInputs f (verify publicKey message signature) := by + apply verifyLayers_query_mem_verify hdigest hadmissible + rw [show numLayers = bottomLayer.val + 1 by rfl, verifyLayers_succ_eq, + dif_pos bottomLayer.isLt] + apply queriedInputs_mono_bind_right + rw [hbottom] + exact queriedInputs_mono_bind_left f _ _ hquery + +theorem middleOts_query_mem_verify + {f : QueryImpl HashSpec Id} {publicKey : PublicKey} {message : Message} + {signature : Signature} {digest : MessageDigest} {bottomLeaf : Digest} + {input : HashInput} + (hdigest : evalWithAnswerFn f + (messageDigest publicKey.parameter publicKey.root message signature.randomness) = digest) + (hadmissible : Admissible digest) + (hbottom : evalWithAnswerFn f + (otsLeaf publicKey.parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (evalWithAnswerFn f + (ftsRecover publicKey.parameter (digestIndex digest) (digestLeaves digest) + signature.ftsSecret signature.ftsPath)) + (signature.counter bottomLayer) (signature.chainValue bottomLayer)) = some bottomLeaf) + (hquery : input ∈ queriedInputs f + (otsLeaf publicKey.parameter middleLayer + (treeIndexAt (digestIndex digest) middleLayer) + (leafIndexAt (digestIndex digest) middleLayer) + (foldValue f publicKey.parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath signature bottomLayer) bottomLeaf (layerHeight bottomLayer)) + (signature.counter middleLayer) (signature.chainValue middleLayer))) : + input ∈ queriedInputs f (verify publicKey message signature) := by + apply verifyLayers_query_mem_verify hdigest hadmissible + rw [show numLayers = bottomLayer.val + 1 by rfl, verifyLayers_succ_eq, + dif_pos bottomLayer.isLt] + apply queriedInputs_mono_bind_right + rw [hbottom] + apply queriedInputs_mono_bind_right + change input ∈ queriedInputs f + (verifyLayers publicKey.parameter (digestIndex digest) signature + (middleLayer.val + 1) + (foldValue f publicKey.parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath signature bottomLayer) bottomLeaf (layerHeight bottomLayer))) + rw [verifyLayers_succ_eq, dif_pos middleLayer.isLt] + simp only [show (⟨middleLayer.val, by exact middleLayer.isLt⟩ : Layer) = middleLayer by + exact Fin.ext rfl] + exact queriedInputs_mono_bind_left f _ _ hquery + +theorem middleFold_query_mem_verify + {f : QueryImpl HashSpec Id} {publicKey : PublicKey} {message : Message} + {signature : Signature} {digest : MessageDigest} {bottomLeaf middleLeaf : Digest} + {input : HashInput} + (hdigest : evalWithAnswerFn f + (messageDigest publicKey.parameter publicKey.root message signature.randomness) = digest) + (hadmissible : Admissible digest) + (hbottom : evalWithAnswerFn f + (otsLeaf publicKey.parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (evalWithAnswerFn f + (ftsRecover publicKey.parameter (digestIndex digest) (digestLeaves digest) + signature.ftsSecret signature.ftsPath)) + (signature.counter bottomLayer) (signature.chainValue bottomLayer)) = some bottomLeaf) + (hmiddle : evalWithAnswerFn f + (otsLeaf publicKey.parameter middleLayer + (treeIndexAt (digestIndex digest) middleLayer) + (leafIndexAt (digestIndex digest) middleLayer) + (foldValue f publicKey.parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath signature bottomLayer) bottomLeaf (layerHeight bottomLayer)) + (signature.counter middleLayer) (signature.chainValue middleLayer)) = some middleLeaf) + (hquery : input ∈ queriedInputs f + (treeFold publicKey.parameter middleLayer + (treeIndexAt (digestIndex digest) middleLayer) + (leafIndexAt (digestIndex digest) middleLayer) + (signaturePath signature middleLayer) (layerHeight middleLayer) middleLeaf)) : + input ∈ queriedInputs f (verify publicKey message signature) := by + apply verifyLayers_query_mem_verify hdigest hadmissible + rw [show numLayers = bottomLayer.val + 1 by rfl, verifyLayers_succ_eq, + dif_pos bottomLayer.isLt] + apply queriedInputs_mono_bind_right + rw [hbottom] + apply queriedInputs_mono_bind_right + change input ∈ queriedInputs f + (verifyLayers publicKey.parameter (digestIndex digest) signature + (middleLayer.val + 1) + (foldValue f publicKey.parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath signature bottomLayer) bottomLeaf (layerHeight bottomLayer))) + rw [verifyLayers_succ_eq, dif_pos middleLayer.isLt] + simp only [show (⟨middleLayer.val, by exact middleLayer.isLt⟩ : Layer) = middleLayer by + exact Fin.ext rfl] + apply queriedInputs_mono_bind_right + rw [hmiddle] + exact queriedInputs_mono_bind_left f _ _ hquery + +noncomputable def traceFallbackAnswer (cache : QueryCache HashSpec) + (f : QueryImpl HashSpec Id) (computation : OracleComp HashSpec alpha) : + QueryImpl HashSpec Id := fun input => + if input ∈ queriedInputs f computation then f input else (cache input).getD 0 + +theorem cache_agreesWithFn_traceFallbackAnswer + (cache : QueryCache HashSpec) (f : QueryImpl HashSpec Id) + (computation : OracleComp HashSpec alpha) + (hagrees : CacheAnswersAgreeOnRun cache f computation) : + cache.AgreesWithFn (traceFallbackAnswer cache f computation) := by + intro input output hcached + unfold traceFallbackAnswer + split_ifs with hmem + · exact hagrees input hmem output hcached + · simp [hcached] + +theorem answersAgreeOnRun_traceFallbackAnswer + (cache : QueryCache HashSpec) (f : QueryImpl HashSpec Id) + (computation : OracleComp HashSpec alpha) : + AnswersAgreeOnRun f (traceFallbackAnswer cache f computation) computation := by + intro input hinput + simp [traceFallbackAnswer, hinput] + +set_option maxRecDepth 10000 in +theorem replay_of_mem_runRaw_verifierHashImpl_of_cacheAnswersAgreeOnRun + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (computation : OracleComp HashSpec alpha) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : alpha) + (hf : CacheAnswersAgreeOnRun (ordinaryQueryCache finalCache) f computation) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ (verifierHashImpl parameter) computation).run cache))) : + evalWithAnswerFn f computation = value ∧ + CachedRun (ordinaryQueryCache finalCache) f computation := by + induction computation using OracleComp.inductionOn generalizing + state cache finalState finalCache fuel remaining value with + | pure result => + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨rfl, by simp [CachedRun]⟩ + | query_bind input next ih => + rw [simulateQ_query_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨queryRaw, hquery, hrest⟩ := hresult + cases queryRaw with + | stopped hit => simp at hrest + | done queryState queryRemaining queryResult => + rcases queryResult with ⟨answer, queryCache⟩ + have hqueryProperty : ReturnsCachedOrdinary input + (verifierHashImpl parameter input) := + returnsCachedOrdinary_verifierHashQuery parameter input + have hcachedQuery : queryCache (.ordinary input) = some answer := + hqueryProperty state cache fuel queryState queryRemaining answer queryCache hquery + have hcachedFinal : finalCache (.ordinary input) = some answer := + (ordinaryEntryPreservingImpl_verifierHashImpl parameter input).simulateQ + (next answer) queryState queryCache queryRemaining finalState remaining value + finalCache answer hcachedQuery hrest + have hfinput : f input = answer := by + apply hf input + · rw [queriedInputs_query_bind] + exact List.mem_cons_self + · exact hcachedFinal + have hfTail : CacheAnswersAgreeOnRun (ordinaryQueryCache finalCache) f + (next answer) := by + intro query hqueryTail output hcached + apply hf query + · rw [queriedInputs_query_bind, hfinput] + exact List.mem_cons_of_mem input hqueryTail + · exact hcached + obtain ⟨htailEval, htailQueries⟩ := ih answer queryState finalState queryCache + finalCache queryRemaining remaining value hfTail hrest + constructor + · rw [evalWithAnswerFn_bind, + show evalWithAnswerFn f (liftM (HashSpec.query input)) = f input from + simulateQ_spec_query f input, hfinput] + exact htailEval + · intro other hother + rw [queriedInputs_query_bind, hfinput] at hother + simp only [List.mem_cons] at hother + rcases hother with rfl | htail + · simp [ordinaryQueryCache, hcachedFinal] + · exact htailQueries other htail + +theorem exists_right_mem_support_of_relTriple + {ι₁ ι₂ : Type} {spec₁ : OracleSpec ι₁} {spec₂ : OracleSpec ι₂} + [IsUniformSpec spec₁] [IsUniformSpec spec₂] + {left : OracleComp spec₁ alpha} {right : OracleComp spec₂ beta} + {relation : alpha → beta → Prop} + (hrel : RelTriple left right relation) {leftResult : alpha} + (hleft : leftResult ∈ support left) : + ∃ rightResult ∈ support right, relation leftResult rightResult := by + rw [relTriple_iff_relWP, relWP_iff_couplingPost] at hrel + obtain ⟨coupling, hcoupled⟩ := hrel + have hleftEval : leftResult ∈ support 𝒟[left] := by + rw [mem_support_iff_evalDist_apply_ne_zero] at hleft ⊢ + exact hleft + have hleftMapped : leftResult ∈ support (Prod.fst <$> coupling.1) := by + rw [coupling.2.map_fst] + exact hleftEval + rw [support_map] at hleftMapped + obtain ⟨jointResult, hjoint, hfst⟩ := hleftMapped + rcases jointResult with ⟨coupledLeft, coupledRight⟩ + simp only at hfst + subst coupledLeft + refine ⟨coupledRight, ?_, hcoupled (leftResult, coupledRight) hjoint⟩ + have hrightMapped : coupledRight ∈ support (Prod.snd <$> coupling.1) := by + rw [support_map] + exact ⟨(leftResult, coupledRight), hjoint, rfl⟩ + rw [coupling.2.map_snd] at hrightMapped + rw [mem_support_iff_evalDist_apply_ne_zero] at hrightMapped ⊢ + exact hrightMapped + +theorem probingHashQuery_eq_splitHashQuery_of_stable + (parameter : PublicParameter) (input : HashInput) + (hstable : StableOrdinaryInput parameter input) : + probingHashQuery parameter input = splitHashQuery (.ordinary input) := by + unfold probingHashQuery + rw [hstable.1] + cases hposition : decodePosition? parameter input with + | none => rfl + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + exact (hstable.2 _ hposition (by trivial)).elim + | leaf lay tree leafIdx => + exact (hstable.2 _ hposition (by trivial)).elim + | node lay tree level nodeIdx => + exact (hstable.2 _ hposition (by trivial)).elim + | ftsLeaf | ftsNode | ftsRoots => rfl + +theorem probingHashImpl_eq_ordinaryHashImpl_of_stable + (parameter : PublicParameter) (input : HashInput) + (hstable : StableOrdinaryInput parameter input) : + probingHashImpl parameter input = ordinaryHashImpl input := + probingHashQuery_eq_splitHashQuery_of_stable parameter input hstable + +theorem tableAnswer_eq_fallback_of_stable + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (fallback : QueryImpl HashSpec Id) (input : HashInput) + (hstable : StableOrdinaryInput parameter input) : + tableAnswer parameter table fallback input = fallback input := by + unfold tableAnswer + cases hposition : decodePosition? parameter input with + | none => rfl + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + exact (hstable.2 _ hposition (by trivial)).elim + | leaf lay tree leafIdx => + exact (hstable.2 _ hposition (by trivial)).elim + | node lay tree level nodeIdx => + exact (hstable.2 _ hposition (by trivial)).elim + | ftsLeaf | ftsNode | ftsRoots => rfl + +theorem stableCacheAgreesWithFn_tableAnswer + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (cache : SplitHashCache) : + StableCacheAgreesWithFn parameter cache + (tableAnswer parameter table (splitFallback cache)) := by + intro input output hstable hcached + rw [tableAnswer_eq_fallback_of_stable parameter table _ input hstable] + simp [splitFallback, hcached] + +theorem tableAnswer_realizes_otsPositions + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (fallback : QueryImpl HashSpec Id) : + ∀ position : Position, IsOtsPosition position → + tableAnswer parameter table fallback + (tableInput parameter table (.position position)) = + table (.position position) := by + intro position hposition + exact tableAnswer_tableInput parameter table fallback position hposition + +theorem mergedCache_extendTable_agreesWith_tableAnswer + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (base : Coordinate → HashOutput) (cache : SplitHashCache) + (hconsistent : HiddenConsistent state cache) : + (mergedCache parameter (extendTable state base) state.ensured cache).AgreesWithFn + (tableAnswer parameter (extendTable state base) (splitFallback cache)) := by + apply mergedCache_agreesWith_tableAnswer + exact completedSplitHashCache_extendTable_consistent state cache base hconsistent + +private theorem attach_flatMap_val {α β : Type*} (xs : List α) (g : α → List β) : + xs.attach.flatMap (fun x => g x.1) = xs.flatMap g := by + calc + _ = (xs.attach.map Subtype.val).flatMap g := by rw [List.flatMap_map] + _ = xs.flatMap g := by rw [List.attach_map_subtype_val] + +private theorem positionDepth_wf : + WellFounded (fun child parent : Position => child.depth < parent.depth) := + (measure Position.depth).wf + +private noncomputable def completedRealizedPositionBody + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (state : LazyRevealProbe.State Coordinate) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (position : Position) + (recurse : ∀ child : Position, child.depth < position.depth → HashOutput) : HashOutput := + match state.values (.position position) with + | some output => output + | none => + show HashOutput from f (tweakableHashInput parameter position.domain <| + match position with + | .chain lay tree leafIdx chainIdx step => + if step.val = 0 then + digestBytes (truncateHash ((state.values + (.chainStart lay tree leafIdx chainIdx)).getD + (baseStarts lay tree leafIdx chainIdx))) + else + (Position.chain lay tree leafIdx chainIdx step).children.attach.flatMap fun child => + digestBytes (truncateHash (recurse child.1 + (Position.depth_lt_of_mem_children child.2))) + | .leaf lay tree leafIdx => + (Position.leaf lay tree leafIdx).children.attach.flatMap fun child => + digestBytes (truncateHash (recurse child.1 + (Position.depth_lt_of_mem_children child.2))) + | .node lay tree level nodeIdx => + (Position.node lay tree level nodeIdx).children.attach.flatMap fun child => + digestBytes (truncateHash (recurse child.1 + (Position.depth_lt_of_mem_children child.2))) + | .ftsLeaf index tree leafIdx => + (Position.ftsLeaf index tree leafIdx).children.attach.flatMap fun child => + digestBytes (truncateHash (recurse child.1 + (Position.depth_lt_of_mem_children child.2))) + | .ftsNode index tree level nodeIdx => + (Position.ftsNode index tree level nodeIdx).children.attach.flatMap fun child => + digestBytes (truncateHash (recurse child.1 + (Position.depth_lt_of_mem_children child.2))) + | .ftsRoots index => + (Position.ftsRoots index).children.attach.flatMap fun child => + digestBytes (truncateHash (recurse child.1 + (Position.depth_lt_of_mem_children child.2)))) + +noncomputable def completedRealizedPositionOutput + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (state : LazyRevealProbe.State Coordinate) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) : + Position → HashOutput := + positionDepth_wf.fix (completedRealizedPositionBody f parameter state baseStarts) + +theorem completedRealizedPositionOutput_eq + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (state : LazyRevealProbe.State Coordinate) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (position : Position) : + completedRealizedPositionOutput f parameter state baseStarts position = + completedRealizedPositionBody f parameter state baseStarts position + (fun child _ => completedRealizedPositionOutput f parameter state baseStarts child) := by + rw [completedRealizedPositionOutput, WellFounded.fix_eq] + +noncomputable def completedRealizedTable + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (state : LazyRevealProbe.State Coordinate) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) : + Coordinate → HashOutput + | coordinate@(.chainStart lay tree leafIdx chainIdx) => + (state.values coordinate).getD (baseStarts lay tree leafIdx chainIdx) + | .position position => + completedRealizedPositionOutput f parameter state baseStarts position + +private theorem completedChildrenPayload_eq + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (state : LazyRevealProbe.State Coordinate) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (positions : List Position) : + (positions.map (tableValue (completedRealizedTable f parameter state baseStarts))).flatMap + digestBytes = + positions.attach.flatMap fun child => + digestBytes (truncateHash + (completedRealizedPositionOutput f parameter state baseStarts child.1)) := by + let payload := fun position : Position => + digestBytes (truncateHash + (completedRealizedPositionOutput f parameter state baseStarts position)) + calc + _ = positions.flatMap payload := by + simp [payload, tableValue, completedRealizedTable, List.flatMap_map] + _ = positions.attach.flatMap (fun child => payload child.1) := + (attach_flatMap_val positions payload).symm + +theorem completedRealizedTable_of_value + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (state : LazyRevealProbe.State Coordinate) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (coordinate : Coordinate) (output : HashOutput) + (hvalue : state.values coordinate = some output) : + completedRealizedTable f parameter state baseStarts coordinate = output := by + cases coordinate with + | chainStart => simp [completedRealizedTable, hvalue] + | position position => + rw [completedRealizedTable, completedRealizedPositionOutput_eq] + unfold completedRealizedPositionBody + rw [hvalue] + +theorem extendTable_completedRealizedTable + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (state : LazyRevealProbe.State Coordinate) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) : + extendTable state (completedRealizedTable f parameter state baseStarts) = + completedRealizedTable f parameter state baseStarts := by + funext coordinate + unfold extendTable + cases hvalue : state.values coordinate with + | none => simp + | some output => + rw [completedRealizedTable_of_value f parameter state baseStarts coordinate output hvalue] + simp + +theorem mergedCache_completedRealizedTable_agreesWith_tableAnswer + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (hconsistent : HiddenConsistent state cache) : + (mergedCache parameter (completedRealizedTable f parameter state baseStarts) + state.ensured cache).AgreesWithFn + (tableAnswer parameter (completedRealizedTable f parameter state baseStarts) + (splitFallback cache)) := by + have hagrees := mergedCache_extendTable_agreesWith_tableAnswer parameter state + (completedRealizedTable f parameter state baseStarts) cache hconsistent + rw [extendTable_completedRealizedTable] at hagrees + exact hagrees + +theorem completedRealizedTable_realizes_of_missing + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (state : LazyRevealProbe.State Coordinate) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (position : Position) (hmissing : state.values (.position position) = none) : + f (tableInput parameter (completedRealizedTable f parameter state baseStarts) + (.position position)) = + completedRealizedTable f parameter state baseStarts (.position position) := by + rw [completedRealizedTable, completedRealizedPositionOutput_eq] + unfold completedRealizedPositionBody + rw [hmissing] + cases position with + | chain lay tree leafIdx chainIdx step => + simp only [tableInput, tablePayload, Position.domain, completedRealizedTable] + rw [completedChildrenPayload_eq] + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp only [tableInput, tablePayload, Position.domain] + rw [completedChildrenPayload_eq] + +theorem tableAnswer_completedRealizedTable_eq_of_missing + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (state : LazyRevealProbe.State Coordinate) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (position : Position) (hots : IsOtsPosition position) + (hmissing : state.values (.position position) = none) : + tableAnswer parameter (completedRealizedTable f parameter state baseStarts) f + (tableInput parameter (completedRealizedTable f parameter state baseStarts) + (.position position)) = + f (tableInput parameter (completedRealizedTable f parameter state baseStarts) + (.position position)) := by + rw [tableAnswer_tableInput parameter _ f position hots] + exact (completedRealizedTable_realizes_of_missing f parameter state baseStarts position + hmissing).symm + +theorem tableAnswer_completedRealizedTable_eq_of_decoded_missing + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (state : LazyRevealProbe.State Coordinate) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (input : HashInput) (position : Position) (hots : IsOtsPosition position) + (hposition : decodePosition? parameter input = some position) + (hmissing : state.values (.position position) = none) : + tableAnswer parameter (completedRealizedTable f parameter state baseStarts) f input = + f input := by + unfold tableAnswer + rw [hposition] + cases position with + | chain | leaf | node => + simp only [tableAnswerDecoded] + split_ifs with hexact + · subst input + exact (completedRealizedTable_realizes_of_missing f parameter state baseStarts _ + hmissing).symm + · rfl + | ftsLeaf | ftsNode | ftsRoots => simp [IsOtsPosition] at hots + +noncomputable def retainedCompletionTable + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) : + Coordinate → HashOutput := + completedRealizedTable (splitFallback cache) parameter state baseStarts + +noncomputable def retainedCompletionAnswer + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) : + QueryImpl HashSpec Id := + tableAnswer parameter (retainedCompletionTable parameter state cache baseStarts) + (splitFallback cache) + +theorem tableOtsSecret_retainedCompletionTable + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + tableOtsSecret (retainedCompletionTable parameter state cache baseStarts) + lay tree leafIdx chainIdx = + truncateHash ((state.values (.chainStart lay tree leafIdx chainIdx)).getD + (baseStarts lay tree leafIdx chainIdx)) := by + rfl + +theorem retainedCompletionAnswer_realizes + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) : + ∀ position : Position, IsOtsPosition position → + retainedCompletionAnswer parameter state cache baseStarts + (tableInput parameter (retainedCompletionTable parameter state cache baseStarts) + (.position position)) = + retainedCompletionTable parameter state cache baseStarts (.position position) := by + exact tableAnswer_realizes_otsPositions parameter + (retainedCompletionTable parameter state cache baseStarts) (splitFallback cache) + +theorem stableCacheAgreesWithFn_retainedCompletionAnswer + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) : + StableCacheAgreesWithFn parameter cache + (retainedCompletionAnswer parameter state cache baseStarts) := by + exact stableCacheAgreesWithFn_tableAnswer parameter + (retainedCompletionTable parameter state cache baseStarts) cache + +theorem mergedCache_agreesWithFn_retainedCompletionAnswer + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (hconsistent : HiddenConsistent state cache) : + (mergedCache parameter (retainedCompletionTable parameter state cache baseStarts) + state.ensured cache).AgreesWithFn + (retainedCompletionAnswer parameter state cache baseStarts) := by + exact mergedCache_completedRealizedTable_agreesWith_tableAnswer + (splitFallback cache) parameter state cache baseStarts hconsistent + +theorem retainedCompletionAnswer_eq_fallback_of_decoded_missing + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (input : HashInput) (position : Position) (hots : IsOtsPosition position) + (hposition : decodePosition? parameter input = some position) + (hmissing : state.values (.position position) = none) : + retainedCompletionAnswer parameter state cache baseStarts input = splitFallback cache input := by + exact tableAnswer_completedRealizedTable_eq_of_decoded_missing + (splitFallback cache) parameter state baseStarts input position hots hposition hmissing + +theorem retainedCompletionAnswer_eq_fallback_or_exact_materialized + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (input : HashInput) : + retainedCompletionAnswer parameter state cache baseStarts input = splitFallback cache input ∨ + ∃ position : Position, + IsOtsPosition position ∧ + decodePosition? parameter input = some position ∧ + input = tableInput parameter + (retainedCompletionTable parameter state cache baseStarts) (.position position) ∧ + state.values (.position position) ≠ none := by + cases hposition : decodePosition? parameter input with + | none => + left + unfold retainedCompletionAnswer tableAnswer + rw [hposition] + rfl + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + let position : Position := .chain lay tree leafIdx chainIdx step + by_cases hexact : input = tableInput parameter + (retainedCompletionTable parameter state cache baseStarts) (.position position) + · by_cases hvalue : state.values (.position position) = none + · left + exact retainedCompletionAnswer_eq_fallback_of_decoded_missing parameter state + cache baseStarts input position (by trivial) (by simp [position, hposition]) + hvalue + · right + exact ⟨position, by trivial, by simp [position], hexact, hvalue⟩ + · left + unfold retainedCompletionAnswer tableAnswer + rw [hposition] + simp only [tableAnswerDecoded] + rw [if_neg hexact] + | leaf lay tree leafIdx => + let position : Position := .leaf lay tree leafIdx + by_cases hexact : input = tableInput parameter + (retainedCompletionTable parameter state cache baseStarts) (.position position) + · by_cases hvalue : state.values (.position position) = none + · left + exact retainedCompletionAnswer_eq_fallback_of_decoded_missing parameter state + cache baseStarts input position (by trivial) (by simp [position, hposition]) + hvalue + · right + exact ⟨position, by trivial, by simp [position], hexact, hvalue⟩ + · left + unfold retainedCompletionAnswer tableAnswer + rw [hposition] + simp only [tableAnswerDecoded] + rw [if_neg hexact] + | node lay tree level nodeIdx => + let position : Position := .node lay tree level nodeIdx + by_cases hexact : input = tableInput parameter + (retainedCompletionTable parameter state cache baseStarts) (.position position) + · by_cases hvalue : state.values (.position position) = none + · left + exact retainedCompletionAnswer_eq_fallback_of_decoded_missing parameter state + cache baseStarts input position (by trivial) (by simp [position, hposition]) + hvalue + · right + exact ⟨position, by trivial, by simp [position], hexact, hvalue⟩ + · left + unfold retainedCompletionAnswer tableAnswer + rw [hposition] + simp only [tableAnswerDecoded] + rw [if_neg hexact] + | ftsLeaf | ftsNode | ftsRoots => + left + unfold retainedCompletionAnswer tableAnswer + rw [hposition] + rfl + +def ExactMaterializedCacheConsistent + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) : Prop := + ∀ (input : HashInput) (position : Position) (output : HashOutput), + IsOtsPosition position → + decodePosition? parameter input = some position → + input = tableInput parameter table (.position position) → + state.values (.position position) ≠ none → + cache (.ordinary input) = some output → output = table (.position position) + +def TraceExactMaterializedCacheConsistent + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (f : QueryImpl HashSpec Id) (computation : OracleComp HashSpec alpha) : Prop := + ∀ (input : HashInput), input ∈ queriedInputs f computation → + ∀ (position : Position) (output : HashOutput), + IsOtsPosition position → + decodePosition? parameter input = some position → + input = tableInput parameter table (.position position) → + state.values (.position position) ≠ none → + cache (.ordinary input) = some output → output = table (.position position) + +theorem cacheAnswersAgreeOnRun_retainedCompletionAnswer_of_trace_exact_materialized + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (computation : OracleComp HashSpec alpha) + (hexact : TraceExactMaterializedCacheConsistent parameter + (retainedCompletionTable parameter state cache baseStarts) state cache + (retainedCompletionAnswer parameter state cache baseStarts) computation) : + CacheAnswersAgreeOnRun (ordinaryQueryCache cache) + (retainedCompletionAnswer parameter state cache baseStarts) computation := by + intro input hquery output hcached + rcases retainedCompletionAnswer_eq_fallback_or_exact_materialized parameter state cache + baseStarts input with hfallback | ⟨position, hots, hposition, hinput, hvalue⟩ + · rw [hfallback] + change cache (.ordinary input) = some output at hcached + simp [splitFallback, hcached] + · rw [hinput, retainedCompletionAnswer_realizes parameter state cache baseStarts position hots] + change cache (.ordinary input) = some output at hcached + exact (hexact input hquery position output hots hposition hinput hvalue hcached).symm + +theorem traceExactMaterializedCacheConsistent_of_cacheAnswersAgreeOnRun + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (computation : OracleComp HashSpec alpha) + (hagrees : CacheAnswersAgreeOnRun (ordinaryQueryCache cache) + (retainedCompletionAnswer parameter state cache baseStarts) computation) : + TraceExactMaterializedCacheConsistent parameter + (retainedCompletionTable parameter state cache baseStarts) state cache + (retainedCompletionAnswer parameter state cache baseStarts) computation := by + intro input hquery position output hots _hposition hinput _hvalue hcached + have hcached' : ordinaryQueryCache cache input = some output := hcached + have hanswer := hagrees input hquery output hcached' + rw [hinput, retainedCompletionAnswer_realizes parameter state cache baseStarts position hots] + at hanswer + exact hanswer.symm + +theorem cacheAnswersAgreeOnRun_retainedCompletionAnswer_iff + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (computation : OracleComp HashSpec alpha) : + CacheAnswersAgreeOnRun (ordinaryQueryCache cache) + (retainedCompletionAnswer parameter state cache baseStarts) computation ↔ + TraceExactMaterializedCacheConsistent parameter + (retainedCompletionTable parameter state cache baseStarts) state cache + (retainedCompletionAnswer parameter state cache baseStarts) computation := by + constructor + · exact traceExactMaterializedCacheConsistent_of_cacheAnswersAgreeOnRun parameter state + cache baseStarts computation + · exact cacheAnswersAgreeOnRun_retainedCompletionAnswer_of_trace_exact_materialized + parameter state cache baseStarts computation + +theorem ordinaryQueryCache_agreesWithFn_retainedCompletionAnswer_of_exact_materialized + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (hexact : ExactMaterializedCacheConsistent parameter + (retainedCompletionTable parameter state cache baseStarts) state cache) : + (ordinaryQueryCache cache).AgreesWithFn + (retainedCompletionAnswer parameter state cache baseStarts) := by + intro input output hcached + rcases retainedCompletionAnswer_eq_fallback_or_exact_materialized parameter state cache + baseStarts input with hfallback | ⟨position, hots, hposition, hinput, hvalue⟩ + · rw [hfallback] + change cache (.ordinary input) = some output at hcached + simp [splitFallback, hcached] + · rw [hinput, retainedCompletionAnswer_realizes parameter state cache baseStarts position hots] + change cache (.ordinary input) = some output at hcached + exact (hexact input position output hots hposition hinput hvalue hcached).symm + +theorem exactMaterializedCacheConsistent_of_ordinaryQueryCache_agreesWithFn + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (hagrees : (ordinaryQueryCache cache).AgreesWithFn + (retainedCompletionAnswer parameter state cache baseStarts)) : + ExactMaterializedCacheConsistent parameter + (retainedCompletionTable parameter state cache baseStarts) state cache := by + intro input position output hots _hposition hinput _hvalue hcached + have hcached' : ordinaryQueryCache cache input = some output := hcached + have hanswer := hagrees hcached' + rw [hinput, retainedCompletionAnswer_realizes parameter state cache baseStarts position hots] + at hanswer + exact hanswer.symm + +theorem ordinaryQueryCache_agreesWithFn_retainedCompletionAnswer_iff + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) : + (ordinaryQueryCache cache).AgreesWithFn + (retainedCompletionAnswer parameter state cache baseStarts) ↔ + ExactMaterializedCacheConsistent parameter + (retainedCompletionTable parameter state cache baseStarts) state cache := by + constructor + · exact exactMaterializedCacheConsistent_of_ordinaryQueryCache_agreesWithFn parameter state + cache baseStarts + · exact ordinaryQueryCache_agreesWithFn_retainedCompletionAnswer_of_exact_materialized + parameter state cache baseStarts + +noncomputable def realizedOtsSecret + (chainStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) : + Layer → TreeIndex → LeafIndex → ChainIndex → Digest := + fun lay tree leafIdx chainIdx => truncateHash (chainStarts lay tree leafIdx chainIdx) + +noncomputable def realizedTable + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (chainStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) : + Coordinate → HashOutput + | .chainStart lay tree leafIdx chainIdx => chainStarts lay tree leafIdx chainIdx + | .position position => + f (honestInput f parameter (realizedOtsSecret chainStarts) (fun _ _ _ => 0) position) + +theorem tableInput_realizedTable + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (chainStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (position : Position) (hots : IsOtsPosition position) (hvalid : position.Valid) : + f (tableInput parameter (realizedTable f parameter chainStarts) (.position position)) = + realizedTable f parameter chainStarts (.position position) := by + let table := realizedTable f parameter chainStarts + let otsSecret := realizedOtsSecret chainStarts + let ftsSecret : Index → FtsTree → FtsLeaf → Digest := fun _ _ _ => 0 + have hvalue (child : Position) : + tableValue table child = honestValue f parameter otsSecret ftsSecret child := by + simp [tableValue, table, realizedTable, honestValue, otsSecret, ftsSecret] + have hpayload : + tablePayload table position = honestPayload f parameter otsSecret ftsSecret position := by + cases position with + | chain lay tree leafIdx chainIdx step => + by_cases hstep : step.val = 0 + · simp [tablePayload, hstep, honestPayload, Concrete.honestChain_zero, table, + realizedTable, otsSecret, realizedOtsSecret] + · rw [tablePayload, if_neg hstep] + rw [honestPayload_eq_slots (f := f) (parameter := parameter) + (otsSecret := otsSecret) (ftsSecret := ftsSecret) hvalid] + simp only [slots, hstep, if_false, childValues] + rfl + | leaf | node => + rw [honestPayload_eq_slots (f := f) (parameter := parameter) + (otsSecret := otsSecret) (ftsSecret := ftsSecret) hvalid] + simp only [tablePayload, slots, childValues] + rfl + | ftsLeaf | ftsNode | ftsRoots => simp [IsOtsPosition] at hots + change f (tweakableHashInput parameter position.domain (tablePayload table position)) = + f (honestInput f parameter otsSecret ftsSecret position) + rw [hpayload] + rfl + +theorem mem_runRaw_peekCoordinate_of_value + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (coordinate : Coordinate) (output : HashOutput) + (hvalue : state.values coordinate = some output) : + LazyRevealProbe.RawResult.done state fuel + (some (truncateHash output), cache) ∈ support + (LazyRevealProbe.runRaw state fuel ((peekCoordinate coordinate).run cache)) := by + change LazyRevealProbe.RawResult.done state fuel + (some (truncateHash output), cache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.peekQuery coordinate >>= fun value => + pure (truncateHash <$> value, cache))) + rw [LazyRevealProbe.peekQuery, LazyRevealProbe.runRaw_peek_query_bind] + simp [hvalue, LazyRevealProbe.runRaw] + +theorem runRaw_peekCoordinate_of_value + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (coordinate : Coordinate) (output : HashOutput) + (hvalue : state.values coordinate = some output) : + LazyRevealProbe.runRaw state fuel ((peekCoordinate coordinate).run cache) = + pure (.done state fuel (some (truncateHash output), cache)) := by + change LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.peekQuery coordinate >>= fun value => + pure (truncateHash <$> value, cache)) = _ + rw [LazyRevealProbe.peekQuery, LazyRevealProbe.runRaw_peek_query_bind] + simp [hvalue, LazyRevealProbe.runRaw] + +theorem runRaw_peekCoordinate_of_none + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (coordinate : Coordinate) + (hvalue : state.values coordinate = none) : + LazyRevealProbe.runRaw state fuel ((peekCoordinate coordinate).run cache) = + pure (.done state fuel (none, cache)) := by + change LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.peekQuery coordinate >>= fun value => + pure (truncateHash <$> value, cache)) = _ + rw [LazyRevealProbe.peekQuery, LazyRevealProbe.runRaw_peek_query_bind] + simp [hvalue, LazyRevealProbe.runRaw] + +theorem mem_runRaw_peekPositionValues_of_values + (table : Coordinate → HashOutput) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (fuel : Nat) : ∀ positions : List Position, + (∀ position, position ∈ positions → + state.values (.position position) = some (table (.position position))) → + LazyRevealProbe.RawResult.done state fuel + (some (positions.map (tableValue table)), cache) ∈ support + (LazyRevealProbe.runRaw state fuel ((peekPositionValues positions).run cache)) + | [], _ => by simp [peekPositionValues, LazyRevealProbe.runRaw] + | position :: remaining, hvalues => by + rw [peekPositionValues, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] + refine ⟨.done state fuel + (some (tableValue table position), cache), ?_, ?_⟩ + · exact mem_runRaw_peekCoordinate_of_value state cache fuel (.position position) + (table (.position position)) (hvalues position (by simp)) + · simp only + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] + refine ⟨.done state fuel + (some (remaining.map (tableValue table)), cache), ?_, ?_⟩ + · exact mem_runRaw_peekPositionValues_of_values table state cache fuel remaining + (fun other hother => hvalues other (by simp [hother])) + · simp [LazyRevealProbe.runRaw] + +theorem runRaw_peekPositionValues_of_values + (table : Coordinate → HashOutput) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (fuel : Nat) : ∀ positions : List Position, + (∀ position, position ∈ positions → + state.values (.position position) = some (table (.position position))) → + LazyRevealProbe.runRaw state fuel ((peekPositionValues positions).run cache) = + pure (.done state fuel (some (positions.map (tableValue table)), cache)) + | [], _ => by simp [peekPositionValues, LazyRevealProbe.runRaw] + | position :: remaining, hvalues => by + rw [peekPositionValues, StateT.run_bind, LazyRevealProbe.runRaw_bind, + runRaw_peekCoordinate_of_value state cache fuel (.position position) + (table (.position position)) (hvalues position (by simp))] + simp only [pure_bind] + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + runRaw_peekPositionValues_of_values table state cache fuel remaining + (fun other hother => hvalues other (by simp [hother]))] + simp [LazyRevealProbe.runRaw, tableValue] + +theorem runRaw_peekPositionValues_of_prefix_values_of_missing + (table : Coordinate → HashOutput) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (fuel : Nat) (prior remaining : List Position) + (position : Position) + (hvalues : ∀ other, other ∈ prior → + state.values (.position other) = some (table (.position other))) + (hmissing : state.values (.position position) = none) : + LazyRevealProbe.runRaw state fuel + ((peekPositionValues (prior ++ position :: remaining)).run cache) = + pure (.done state fuel (none, cache)) := by + induction prior with + | nil => + rw [List.nil_append, peekPositionValues, StateT.run_bind, + LazyRevealProbe.runRaw_bind, + runRaw_peekCoordinate_of_none state cache fuel (.position position) hmissing, + pure_bind] + simp [LazyRevealProbe.runRaw] + | cons head tail ih => + rw [List.cons_append, peekPositionValues, StateT.run_bind, + LazyRevealProbe.runRaw_bind, + runRaw_peekCoordinate_of_value state cache fuel (.position head) + (table (.position head)) (hvalues head (by simp))] + simp only [pure_bind] + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + ih (fun other hother => hvalues other (by simp [hother])), pure_bind] + simp [LazyRevealProbe.runRaw] + +theorem positionValues_or_first_missing + (table : Coordinate → HashOutput) (state : LazyRevealProbe.State Coordinate) + (positions : List Position) + (htable : ∀ position output, + state.values (.position position) = some output → + output = table (.position position)) : + (∀ position, position ∈ positions → + state.values (.position position) = some (table (.position position))) ∨ + ∃ prior position remaining, + positions = prior ++ position :: remaining ∧ + (∀ other, other ∈ prior → + state.values (.position other) = some (table (.position other))) ∧ + state.values (.position position) = none := by + induction positions with + | nil => + left + simp + | cons head tail ih => + cases hvalue : state.values (.position head) with + | none => + right + exact ⟨[], head, tail, by simp, by simp, hvalue⟩ + | some output => + have hhead : state.values (.position head) = + some (table (.position head)) := by + rw [hvalue, htable head output hvalue] + rcases ih with htail | ⟨prior, position, remaining, htail, hprior, hmissing⟩ + · left + intro position hposition + simp only [List.mem_cons] at hposition + rcases hposition with rfl | hposition + · exact hhead + · exact htail position hposition + · right + exact ⟨head :: prior, position, remaining, by simp [htail], + fun other hother => by + simp only [List.mem_cons] at hother + rcases hother with rfl | hother + · exact hhead + · exact hprior other hother, + hmissing⟩ + +def TableInputAvailable (table : Coordinate → HashOutput) + (state : LazyRevealProbe.State Coordinate) : Coordinate → Prop + | .chainStart _ _ _ _ => False + | .position position@(.chain lay tree leafIdx chainIdx step) => + if step.val = 0 then + state.values (.chainStart lay tree leafIdx chainIdx) = + some (table (.chainStart lay tree leafIdx chainIdx)) + else + ∀ child, child ∈ position.children → + state.values (.position child) = some (table (.position child)) + | .position position => + ∀ child, child ∈ position.children → + state.values (.position child) = some (table (.position child)) + +theorem slotDigest_tableInput_node_child + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (lay : Layer) (tree : TreeIndex) (level : Fin maxLayerHeight) + (nodeIdx : LeafIndex) (child : Position) + (hchild : child ∈ (Position.node lay tree level nodeIdx).children) : + slotDigest ((Position.node lay tree level nodeIdx).children.idxOf child) + (tableInput parameter table + (.position (.node lay tree level nodeIdx))) = + truncateHash (table (.position child)) := by + let children := (Position.node lay tree level nodeIdx).children + have hidx : children.idxOf child < children.length := + List.idxOf_lt_length_iff.mpr hchild + change slotDigest (children.idxOf child) + (tweakableHashInput parameter (Position.node lay tree level nodeIdx).domain + ((children.map (tableValue table)).flatMap digestBytes)) = _ + rw [slotDigest_flatMap parameter (Position.node lay tree level nodeIdx).domain + (children.map (tableValue table)) (children.idxOf child) (by simpa using hidx)] + simp [List.getElem_idxOf hidx, tableValue] + +theorem slotDigest_tableInput_node_getElem + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (lay : Layer) (tree : TreeIndex) (level : Fin maxLayerHeight) + (nodeIdx : LeafIndex) (slot : Nat) + (hslot : slot < (Position.node lay tree level nodeIdx).children.length) : + slotDigest slot + (tableInput parameter table + (.position (.node lay tree level nodeIdx))) = + truncateHash (table (.position + (Position.node lay tree level nodeIdx).children[slot])) := by + change slotDigest slot + (tweakableHashInput parameter (Position.node lay tree level nodeIdx).domain + ((((Position.node lay tree level nodeIdx).children.map + (tableValue table))).flatMap digestBytes)) = _ + rw [slotDigest_flatMap parameter (Position.node lay tree level nodeIdx).domain + ((Position.node lay tree level nodeIdx).children.map (tableValue table)) slot + (by simpa using hslot)] + simp [tableValue] + +theorem slotDigest_tableInput_leaf_child + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (child : Position) + (hchild : child ∈ (Position.leaf lay tree leafIdx).children) : + slotDigest ((Position.leaf lay tree leafIdx).children.idxOf child) + (tableInput parameter table (.position (.leaf lay tree leafIdx))) = + truncateHash (table (.position child)) := by + let children := (Position.leaf lay tree leafIdx).children + have hidx : children.idxOf child < children.length := + List.idxOf_lt_length_iff.mpr hchild + change slotDigest (children.idxOf child) + (tweakableHashInput parameter (Position.leaf lay tree leafIdx).domain + ((children.map (tableValue table)).flatMap digestBytes)) = _ + rw [slotDigest_flatMap parameter (Position.leaf lay tree leafIdx).domain + (children.map (tableValue table)) (children.idxOf child) (by simpa using hidx)] + simp [List.getElem_idxOf hidx, tableValue] + +theorem slotDigest_tableInput_leaf_getElem + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (slot : Nat) + (hslot : slot < (Position.leaf lay tree leafIdx).children.length) : + slotDigest slot (tableInput parameter table (.position (.leaf lay tree leafIdx))) = + truncateHash (table (.position (Position.leaf lay tree leafIdx).children[slot])) := by + change slotDigest slot + (tweakableHashInput parameter (Position.leaf lay tree leafIdx).domain + (((Position.leaf lay tree leafIdx).children.map + (tableValue table)).flatMap digestBytes)) = _ + rw [slotDigest_flatMap parameter (Position.leaf lay tree leafIdx).domain + ((Position.leaf lay tree leafIdx).children.map (tableValue table)) slot + (by simpa using hslot)] + simp [tableValue] + +theorem leaf_children_getElem_zero + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (hzero : 0 < (Position.leaf lay tree leafIdx).children.length) : + (Position.leaf lay tree leafIdx).children[0]'hzero = + .chain lay tree leafIdx ⟨0, by norm_num [numChains]⟩ Position.lastChainStep := by + simp [Position.children] + +set_option maxRecDepth 10000 in +theorem decodeProbe?_tableInput_leaf_eq + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (candidate : Probe) + (hdecode : decodeProbe? parameter + (tableInput parameter table (.position (.leaf lay tree leafIdx))) = some candidate) : + candidate = + ⟨.position (.chain lay tree leafIdx ⟨0, by norm_num [numChains]⟩ + Position.lastChainStep), + slotDigest 0 (tableInput parameter table (.position (.leaf lay tree leafIdx)))⟩ := by + apply Probe.matchesInput_unique parameter + (tableInput parameter table (.position (.leaf lay tree leafIdx))) + · exact (decodeProbe?_eq_some_iff parameter _ candidate).1 hdecode + · simp only [Probe.MatchesInput] + rw [dif_neg (by simp [Position.lastChainStep, chainLength, winternitzBits])] + exact ⟨trivial, tablePayload table (.leaf lay tree leafIdx), rfl, trivial⟩ + +theorem TableInputAvailable.monoValues + {table : Coordinate → HashOutput} + {state finalState : LazyRevealProbe.State Coordinate} {coordinate : Coordinate} + (havailable : TableInputAvailable table state coordinate) + (hle : LazyRevealProbe.ValuesLE state finalState) : + TableInputAvailable table finalState coordinate := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [TableInputAvailable] at havailable + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + simp only [TableInputAvailable] + by_cases hzero : step.val = 0 + · rw [if_pos hzero] + exact hle _ _ (by simpa [TableInputAvailable, hzero] using havailable) + · rw [if_neg hzero] + have havailable' : ∀ child, + child ∈ (Position.chain lay tree leafIdx chainIdx step).children → + state.values (.position child) = some (table (.position child)) := by + simpa [TableInputAvailable, hzero] using havailable + intro child hchild + exact hle _ _ (havailable' child hchild) + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + intro child hchild + exact hle _ _ (havailable child hchild) + +theorem runRaw_probeFirstMissingInputCoordinate_of_values + (table : Coordinate → HashOutput) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) (fuel : Nat) : + ∀ (slot : Nat) (coordinates : List Coordinate), + (∀ coordinate, coordinate ∈ coordinates → + state.values coordinate = some (table coordinate)) → + LazyRevealProbe.runRaw state fuel + ((probeFirstMissingInputCoordinate input slot coordinates).run cache) = + pure (.done state fuel ((), cache)) + | _, [], _ => by simp [probeFirstMissingInputCoordinate, LazyRevealProbe.runRaw] + | slot, coordinate :: remaining, hvalues => by + rw [probeFirstMissingInputCoordinate, StateT.run_bind, LazyRevealProbe.runRaw_bind, + runRaw_peekCoordinate_of_value state cache fuel coordinate (table coordinate) + (hvalues coordinate (by simp))] + simp only [pure_bind] + exact runRaw_probeFirstMissingInputCoordinate_of_values table input state cache fuel + (slot + 1) remaining (fun other hother => hvalues other (by simp [hother])) + +set_option maxRecDepth 10000 in +theorem runRaw_probeFirstMissingInputCoordinate_of_prefix_values_of_missing + (table : Coordinate → HashOutput) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel slot : Nat) (prior remaining : List Coordinate) (coordinate : Coordinate) + (hvalues : ∀ other, other ∈ prior → + state.values other = some (table other)) + (hmissing : state.values coordinate = none) + (hnotRevealed : coordinate ∉ state.revealed) : + LazyRevealProbe.runRaw state (fuel + 1) + ((probeFirstMissingInputCoordinate input slot + (prior ++ coordinate :: remaining)).run cache) = + pure (.done + (state.addPending coordinate (slotDigest (slot + prior.length) input)) fuel + ((), cache)) := by + induction prior generalizing slot with + | nil => + rw [List.nil_append, probeFirstMissingInputCoordinate, StateT.run_bind, + LazyRevealProbe.runRaw_bind, + runRaw_peekCoordinate_of_none state cache (fuel + 1) coordinate hmissing, + pure_bind] + change LazyRevealProbe.runRaw state (fuel + 1) + (LazyRevealProbe.probeQuery coordinate (slotDigest slot input) >>= fun result => + pure (result, cache)) = _ + rw [LazyRevealProbe.probeQuery, LazyRevealProbe.runRaw_probe_query_bind, + show fuel + 1 = Nat.succ fuel by omega] + simp [hnotRevealed, LazyRevealProbe.runRaw] + | cons head tail ih => + rw [List.cons_append, probeFirstMissingInputCoordinate, StateT.run_bind, + LazyRevealProbe.runRaw_bind, + runRaw_peekCoordinate_of_value state cache (fuel + 1) head (table head) + (hvalues head (by simp))] + simp only [pure_bind] + have htailValues : ∀ other, other ∈ tail → + state.values other = some (table other) := by + intro other hother + exact hvalues other (by simp [hother]) + rw [ih (slot + 1) htailValues] + congr 4 + simp only [List.length_cons] + omega + +set_option maxRecDepth 10000 in +theorem runRaw_probeFirstMissingInputCoordinate_zero_of_prefix_values_of_missing + (table : Coordinate → HashOutput) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (slot : Nat) (prior remaining : List Coordinate) (coordinate : Coordinate) + (hvalues : ∀ other, other ∈ prior → + state.values other = some (table other)) + (hmissing : state.values coordinate = none) : + LazyRevealProbe.runRaw state 0 + ((probeFirstMissingInputCoordinate input slot + (prior ++ coordinate :: remaining)).run cache) = + pure (.stopped false) := by + induction prior generalizing slot with + | nil => + rw [List.nil_append, probeFirstMissingInputCoordinate, StateT.run_bind, + LazyRevealProbe.runRaw_bind, + runRaw_peekCoordinate_of_none state cache 0 coordinate hmissing, pure_bind] + change LazyRevealProbe.runRaw state 0 + (LazyRevealProbe.probeQuery coordinate (slotDigest slot input) >>= fun result => + pure (result, cache)) = _ + rw [LazyRevealProbe.probeQuery, LazyRevealProbe.runRaw_probe_query_bind] + | cons head tail ih => + rw [List.cons_append, probeFirstMissingInputCoordinate, StateT.run_bind, + LazyRevealProbe.runRaw_bind, + runRaw_peekCoordinate_of_value state cache 0 head (table head) + (hvalues head (by simp))] + simp only [pure_bind] + exact ih (slot + 1) (fun other hother => hvalues other (by simp [hother])) + +theorem runRaw_peekTableInput_of_available + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (coordinate : Coordinate) + (havailable : TableInputAvailable table state coordinate) : + LazyRevealProbe.runRaw state fuel ((peekTableInput parameter coordinate).run cache) = + pure (.done state fuel (some (tableInput parameter table coordinate), cache)) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [TableInputAvailable] at havailable + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput.eq_2] + by_cases hzero : step.val = 0 + · rw [if_pos hzero, StateT.run_bind, LazyRevealProbe.runRaw_bind, + runRaw_peekCoordinate_of_value state cache fuel + (.chainStart lay tree leafIdx chainIdx) + (table (.chainStart lay tree leafIdx chainIdx)) + (by simpa [TableInputAvailable, hzero] using havailable)] + simp [LazyRevealProbe.runRaw, tableInput, tablePayload, hzero] + · rw [if_neg hzero, StateT.run_bind, LazyRevealProbe.runRaw_bind, + runRaw_peekPositionValues_of_values table state cache fuel _ + (by simpa [TableInputAvailable, hzero] using havailable)] + simp [LazyRevealProbe.runRaw, tableInput, tablePayload, hzero] + | leaf lay tree leafIdx => + rw [peekTableInput.eq_3 parameter (.leaf lay tree leafIdx) (by simp), + StateT.run_bind, LazyRevealProbe.runRaw_bind, + runRaw_peekPositionValues_of_values table state cache fuel _ havailable] + simp [LazyRevealProbe.runRaw, tableInput, tablePayload] + | node lay tree level nodeIdx => + rw [peekTableInput.eq_3 parameter (.node lay tree level nodeIdx) (by simp), + StateT.run_bind, LazyRevealProbe.runRaw_bind, + runRaw_peekPositionValues_of_values table state cache fuel _ havailable] + simp [LazyRevealProbe.runRaw, tableInput, tablePayload] + | ftsLeaf index tree leafIdx => + rw [peekTableInput.eq_3 parameter (.ftsLeaf index tree leafIdx) (by simp), + StateT.run_bind, LazyRevealProbe.runRaw_bind, + runRaw_peekPositionValues_of_values table state cache fuel _ havailable] + simp [LazyRevealProbe.runRaw, tableInput, tablePayload] + | ftsNode index tree level nodeIdx => + rw [peekTableInput.eq_3 parameter (.ftsNode index tree level nodeIdx) (by simp), + StateT.run_bind, LazyRevealProbe.runRaw_bind, + runRaw_peekPositionValues_of_values table state cache fuel _ havailable] + simp [LazyRevealProbe.runRaw, tableInput, tablePayload] + | ftsRoots index => + rw [peekTableInput.eq_3 parameter (.ftsRoots index) (by simp), + StateT.run_bind, LazyRevealProbe.runRaw_bind, + runRaw_peekPositionValues_of_values table state cache fuel _ havailable] + simp [LazyRevealProbe.runRaw, tableInput, tablePayload] + +theorem runRaw_peekTableInput_node_of_prefix_values_of_missing + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (lay : Layer) (tree : TreeIndex) (level : Fin maxLayerHeight) + (nodeIdx : LeafIndex) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (fuel : Nat) (prior remaining : List Position) + (child : Position) + (hchildren : (Position.node lay tree level nodeIdx).children = + prior ++ child :: remaining) + (hvalues : ∀ other, other ∈ prior → + state.values (.position other) = some (table (.position other))) + (hmissing : state.values (.position child) = none) : + LazyRevealProbe.runRaw state fuel + ((peekTableInput parameter + (.position (.node lay tree level nodeIdx))).run cache) = + pure (.done state fuel (none, cache)) := by + rw [peekTableInput.eq_3 parameter (.node lay tree level nodeIdx) (by simp), + hchildren, StateT.run_bind, LazyRevealProbe.runRaw_bind, + runRaw_peekPositionValues_of_prefix_values_of_missing table state cache fuel prior + remaining child hvalues hmissing, pure_bind] + simp [LazyRevealProbe.runRaw] + +set_option maxRecDepth 10000 in +theorem probingHashQuery_node_pending_of_prefix_values_of_missing + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (lay : Layer) (tree : TreeIndex) (level : Fin maxLayerHeight) + (nodeIdx : LeafIndex) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remainingFuel : Nat) + (prior remaining : List Position) (child : Position) (output : HashOutput) + (hchildren : (Position.node lay tree level nodeIdx).children = + prior ++ child :: remaining) + (hvalues : ∀ other, other ∈ prior → + state.values (.position other) = some (table (.position other))) + (hmissing : state.values (.position child) = none) + (hnotRevealed : .position child ∉ state.revealed) + (hresult : LazyRevealProbe.RawResult.done finalState remainingFuel + (output, finalCache) ∈ support + (LazyRevealProbe.runRaw state (fuel + 1) + ((probingHashQuery parameter + (tableInput parameter table + (.position (.node lay tree level nodeIdx)))).run cache))) : + finalState = state.addPending (.position child) + (truncateHash (table (.position child))) ∧ + remainingFuel = fuel := by + let position : Position := .node lay tree level nodeIdx + let input := tableInput parameter table (.position position) + have hposition : decodePosition? parameter input = some position := + (decodePosition?_eq_some_iff parameter input position).2 + ⟨tablePayload table position, rfl⟩ + have hprobe : decodeProbe? parameter input = none := by + apply decodeProbe?_tweakableHashInput_of_not_chain_leaf parameter position.domain + (tablePayload table position) position.domain_inRange + · intro otherLay otherTree otherLeaf otherChain otherStep heq + simp [position, Position.domain] at heq + · intro otherLay otherTree otherLeaf heq + simp [position, Position.domain] at heq + let priorCoordinates := prior.map Coordinate.position + let remainingCoordinates := remaining.map Coordinate.position + have hcoordinates : position.children.map Coordinate.position = + priorCoordinates ++ .position child :: remainingCoordinates := by + simp only [position, hchildren, priorCoordinates, remainingCoordinates, List.map_append, + List.map_cons] + have hcoordinateValues : ∀ coordinate, coordinate ∈ priorCoordinates → + state.values coordinate = some (table coordinate) := by + intro coordinate hcoordinate + obtain ⟨other, hother, rfl⟩ := List.mem_map.1 hcoordinate + exact hvalues other hother + have hslot : prior.length < position.children.length := by + simp [position, hchildren] + have hcandidate : slotDigest prior.length input = + truncateHash (table (.position child)) := by + have hread := slotDigest_tableInput_node_getElem parameter table lay tree level nodeIdx + prior.length (by simpa [position] using hslot) + have hget : position.children[prior.length] = child := by + simp [position, hchildren] + simpa [input, position, hget] using hread + have hscan := + runRaw_probeFirstMissingInputCoordinate_of_prefix_values_of_missing table input state cache + fuel 0 priorCoordinates remainingCoordinates (.position child) hcoordinateValues hmissing + hnotRevealed + have hcandidateCoordinates : slotDigest (0 + priorCoordinates.length) input = + truncateHash (table (.position child)) := by + simpa [priorCoordinates] using hcandidate + rw [hcandidateCoordinates] at hscan + change LazyRevealProbe.RawResult.done finalState remainingFuel (output, finalCache) ∈ support + (LazyRevealProbe.runRaw state (fuel + 1) + ((probingHashQuery parameter input).run cache)) at hresult + unfold probingHashQuery at hresult + rw [hprobe, hposition] at hresult + simp only [position] at hresult + rw [hcoordinates, StateT.run_bind, LazyRevealProbe.runRaw_bind, hscan, pure_bind] at hresult + let probeState := state.addPending (.position child) + (truncateHash (table (.position child))) + have hpeek := runRaw_peekTableInput_node_of_prefix_values_of_missing parameter table lay tree + level nodeIdx probeState cache fuel prior remaining child hchildren (by + intro other hother + simpa [probeState, LazyRevealProbe.State.addPending] using hvalues other hother) (by + simpa [probeState, LazyRevealProbe.State.addPending] using hmissing) + change LazyRevealProbe.RawResult.done finalState remainingFuel (output, finalCache) ∈ support + (LazyRevealProbe.runRaw probeState fuel + ((resolveKnownInput parameter (.position position) input).run cache)) at hresult + unfold resolveKnownInput at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, hpeek, pure_bind] at hresult + have hprojection := mem_runRaw_splitHashQuery_ordinary_projects input probeState finalState + cache finalCache fuel remainingFuel output hresult + exact ⟨hprojection.1, hprojection.2.1⟩ + +set_option maxRecDepth 10000 in +theorem runRaw_prepareLeafInputProbe_of_prefix_values_of_missing + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (candidate : Probe) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (prior remaining : List Position) (child : Position) + (hdecode : decodeProbe? parameter + (tableInput parameter table (.position (.leaf lay tree leafIdx))) = some candidate) + (hchildren : (Position.leaf lay tree leafIdx).children = + prior ++ child :: remaining) + (hvalues : ∀ other, other ∈ prior → + state.values (.position other) = some (table (.position other))) + (hmissing : state.values (.position child) = none) + (hnotRevealed : .position child ∉ state.revealed) : + LazyRevealProbe.runRaw state (fuel + 1) + ((prepareLeafInputProbe + (tableInput parameter table (.position (.leaf lay tree leafIdx))) + candidate lay tree leafIdx).run cache) = + pure (.done + (state.addPending (.position child) (truncateHash (table (.position child)))) fuel + ((), cache)) := by + let input := tableInput parameter table (.position (.leaf lay tree leafIdx)) + have hzero : 0 < (Position.leaf lay tree leafIdx).children.length := by + simp [hchildren] + have hcandidate := decodeProbe?_tableInput_leaf_eq parameter table lay tree leafIdx candidate + hdecode + have hfirst := leaf_children_getElem_zero lay tree leafIdx hzero + cases prior with + | nil => + have hfirstChild : (Position.leaf lay tree leafIdx).children[0] = child := by + simp [hchildren] + have hsource : + (.chain lay tree leafIdx ⟨0, by norm_num [numChains]⟩ + Position.lastChainStep : Position) = child := by + rw [← hfirstChild] + exact hfirst.symm + have hdigest : slotDigest 0 input = + truncateHash (table (.position child)) := by + have hread := slotDigest_tableInput_leaf_getElem parameter table lay tree leafIdx 0 hzero + simpa [input, hfirstChild] using hread + rw [hcandidate] + unfold prepareLeafInputProbe + rw [hsource, StateT.run_bind, LazyRevealProbe.runRaw_bind, + runRaw_peekCoordinate_of_none state cache (fuel + 1) (.position child) hmissing, + pure_bind] + change LazyRevealProbe.runRaw state (fuel + 1) + (LazyRevealProbe.probeQuery (.position child) (slotDigest 0 input) >>= fun result => + pure (result, cache)) = _ + rw [hdigest, LazyRevealProbe.probeQuery, LazyRevealProbe.runRaw_probe_query_bind, + show fuel + 1 = Nat.succ fuel by omega] + simp [hnotRevealed, LazyRevealProbe.runRaw] + | cons head tail => + have hfirstChild : (Position.leaf lay tree leafIdx).children[0] = head := by + simp [hchildren] + have hsource : + (.chain lay tree leafIdx ⟨0, by norm_num [numChains]⟩ + Position.lastChainStep : Position) = head := by + rw [← hfirstChild] + exact hfirst.symm + let priorCoordinates := (head :: tail).map Coordinate.position + let remainingCoordinates := remaining.map Coordinate.position + have hcoordinates : (Position.leaf lay tree leafIdx).children.map Coordinate.position = + priorCoordinates ++ .position child :: remainingCoordinates := by + simp only [hchildren, priorCoordinates, remainingCoordinates, List.map_append, + List.map_cons] + have hcoordinateValues : ∀ coordinate, coordinate ∈ priorCoordinates → + state.values coordinate = some (table coordinate) := by + intro coordinate hcoordinate + obtain ⟨other, hother, rfl⟩ := List.mem_map.1 hcoordinate + exact hvalues other hother + have hscan := + runRaw_probeFirstMissingInputCoordinate_of_prefix_values_of_missing table input state cache + fuel 0 priorCoordinates remainingCoordinates (.position child) hcoordinateValues hmissing + hnotRevealed + have hslot : (head :: tail).length < + (Position.leaf lay tree leafIdx).children.length := by + simp [hchildren] + have hdigest : slotDigest (head :: tail).length input = + truncateHash (table (.position child)) := by + have hread := slotDigest_tableInput_leaf_getElem parameter table lay tree leafIdx + (head :: tail).length hslot + simpa [input, hchildren] using hread + have hdigestCoordinates : slotDigest (0 + priorCoordinates.length) input = + truncateHash (table (.position child)) := by + simpa [priorCoordinates] using hdigest + rw [hdigestCoordinates] at hscan + rw [hcandidate] + unfold prepareLeafInputProbe + rw [hsource, StateT.run_bind, LazyRevealProbe.runRaw_bind, + runRaw_peekCoordinate_of_value state cache (fuel + 1) (.position head) + (table (.position head)) (hvalues head (by simp))] + simp only [pure_bind] + rw [hcoordinates, hscan] + +set_option maxRecDepth 10000 in +theorem runRaw_prepareLeafInputProbe_zero_of_prefix_values_of_missing + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (candidate : Probe) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (prior remaining : List Position) (child : Position) + (hdecode : decodeProbe? parameter + (tableInput parameter table (.position (.leaf lay tree leafIdx))) = some candidate) + (hchildren : (Position.leaf lay tree leafIdx).children = + prior ++ child :: remaining) + (hvalues : ∀ other, other ∈ prior → + state.values (.position other) = some (table (.position other))) + (hmissing : state.values (.position child) = none) : + LazyRevealProbe.runRaw state 0 + ((prepareLeafInputProbe + (tableInput parameter table (.position (.leaf lay tree leafIdx))) + candidate lay tree leafIdx).run cache) = + pure (.stopped false) := by + let input := tableInput parameter table (.position (.leaf lay tree leafIdx)) + have hzero : 0 < (Position.leaf lay tree leafIdx).children.length := by + simp [hchildren] + have hcandidate := decodeProbe?_tableInput_leaf_eq parameter table lay tree leafIdx candidate + hdecode + have hfirst := leaf_children_getElem_zero lay tree leafIdx hzero + cases prior with + | nil => + have hfirstChild : (Position.leaf lay tree leafIdx).children[0] = child := by + simp [hchildren] + have hsource : + (.chain lay tree leafIdx ⟨0, by norm_num [numChains]⟩ + Position.lastChainStep : Position) = child := by + rw [← hfirstChild] + exact hfirst.symm + rw [hcandidate] + unfold prepareLeafInputProbe + rw [hsource, StateT.run_bind, LazyRevealProbe.runRaw_bind, + runRaw_peekCoordinate_of_none state cache 0 (.position child) hmissing, pure_bind] + change LazyRevealProbe.runRaw state 0 + (LazyRevealProbe.probeQuery (.position child) (slotDigest 0 input) >>= fun result => + pure (result, cache)) = _ + rw [LazyRevealProbe.probeQuery, LazyRevealProbe.runRaw_probe_query_bind] + | cons head tail => + have hfirstChild : (Position.leaf lay tree leafIdx).children[0] = head := by + simp [hchildren] + have hsource : + (.chain lay tree leafIdx ⟨0, by norm_num [numChains]⟩ + Position.lastChainStep : Position) = head := by + rw [← hfirstChild] + exact hfirst.symm + let priorCoordinates := (head :: tail).map Coordinate.position + let remainingCoordinates := remaining.map Coordinate.position + have hcoordinates : (Position.leaf lay tree leafIdx).children.map Coordinate.position = + priorCoordinates ++ .position child :: remainingCoordinates := by + simp only [hchildren, priorCoordinates, remainingCoordinates, List.map_append, + List.map_cons] + have hcoordinateValues : ∀ coordinate, coordinate ∈ priorCoordinates → + state.values coordinate = some (table coordinate) := by + intro coordinate hcoordinate + obtain ⟨other, hother, rfl⟩ := List.mem_map.1 hcoordinate + exact hvalues other hother + have hscan := + runRaw_probeFirstMissingInputCoordinate_zero_of_prefix_values_of_missing table input state + cache 0 priorCoordinates remainingCoordinates (.position child) hcoordinateValues hmissing + rw [hcandidate] + unfold prepareLeafInputProbe + rw [hsource, StateT.run_bind, LazyRevealProbe.runRaw_bind, + runRaw_peekCoordinate_of_value state cache 0 (.position head) + (table (.position head)) (hvalues head (by simp))] + simp only [pure_bind] + rw [hcoordinates, hscan] + +theorem runRaw_peekTableInput_leaf_of_prefix_values_of_missing + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) (fuel : Nat) + (prior remaining : List Position) (child : Position) + (hchildren : (Position.leaf lay tree leafIdx).children = + prior ++ child :: remaining) + (hvalues : ∀ other, other ∈ prior → + state.values (.position other) = some (table (.position other))) + (hmissing : state.values (.position child) = none) : + LazyRevealProbe.runRaw state fuel + ((peekTableInput parameter (.position (.leaf lay tree leafIdx))).run cache) = + pure (.done state fuel (none, cache)) := by + rw [peekTableInput.eq_3 parameter (.leaf lay tree leafIdx) (by simp), + hchildren, StateT.run_bind, LazyRevealProbe.runRaw_bind, + runRaw_peekPositionValues_of_prefix_values_of_missing table state cache fuel prior + remaining child hvalues hmissing, pure_bind] + simp [LazyRevealProbe.runRaw] + +set_option maxRecDepth 10000 in +theorem probingHashQuery_leaf_pending_of_prefix_values_of_missing + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remainingFuel : Nat) + (prior remaining : List Position) (child : Position) (output : HashOutput) + (hchildren : (Position.leaf lay tree leafIdx).children = + prior ++ child :: remaining) + (hvalues : ∀ other, other ∈ prior → + state.values (.position other) = some (table (.position other))) + (hmissing : state.values (.position child) = none) + (hnotRevealed : .position child ∉ state.revealed) + (hresult : LazyRevealProbe.RawResult.done finalState remainingFuel + (output, finalCache) ∈ support + (LazyRevealProbe.runRaw state (fuel + 1) + ((probingHashQuery parameter + (tableInput parameter table (.position (.leaf lay tree leafIdx)))).run cache))) : + finalState = state.addPending (.position child) + (truncateHash (table (.position child))) ∧ + remainingFuel = fuel := by + let position : Position := .leaf lay tree leafIdx + let input := tableInput parameter table (.position position) + let candidate : Probe := + ⟨.position (.chain lay tree leafIdx ⟨0, by norm_num [numChains]⟩ + Position.lastChainStep), slotDigest 0 input⟩ + have hprobe : decodeProbe? parameter input = some candidate := by + apply (decodeProbe?_eq_some_iff parameter input candidate).2 + simp only [candidate, Probe.MatchesInput] + rw [dif_neg (by simp [Position.lastChainStep, chainLength, winternitzBits])] + exact ⟨trivial, tablePayload table position, rfl, trivial⟩ + have hposition : decodePosition? parameter input = some position := + (decodePosition?_eq_some_iff parameter input position).2 + ⟨tablePayload table position, rfl⟩ + have hprepare := runRaw_prepareLeafInputProbe_of_prefix_values_of_missing parameter table lay + tree leafIdx candidate state cache fuel prior remaining child (by simpa [input, position] + using hprobe) hchildren hvalues hmissing hnotRevealed + change LazyRevealProbe.RawResult.done finalState remainingFuel (output, finalCache) ∈ support + (LazyRevealProbe.runRaw state (fuel + 1) + ((probingHashQuery parameter input).run cache)) at hresult + unfold probingHashQuery at hresult + rw [hprobe, hposition] at hresult + simp only [position] at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, hprepare, pure_bind] at hresult + let probeState := state.addPending (.position child) + (truncateHash (table (.position child))) + have hpeek := runRaw_peekTableInput_leaf_of_prefix_values_of_missing parameter table lay tree + leafIdx probeState cache fuel prior remaining child hchildren (by + intro other hother + simpa [probeState, LazyRevealProbe.State.addPending] using hvalues other hother) (by + simpa [probeState, LazyRevealProbe.State.addPending] using hmissing) + change LazyRevealProbe.RawResult.done finalState remainingFuel (output, finalCache) ∈ support + (LazyRevealProbe.runRaw probeState fuel + ((resolveKnownInput parameter (.position position) input).run cache)) at hresult + unfold resolveKnownInput at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, hpeek, pure_bind] at hresult + have hprojection := mem_runRaw_splitHashQuery_ordinary_projects input probeState finalState + cache finalCache fuel remainingFuel output hresult + exact ⟨hprojection.1, hprojection.2.1⟩ + +theorem mem_runRaw_revealCoordinateOutput_value + (coordinate : Coordinate) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : HashOutput) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((revealCoordinateOutput coordinate).run cache))) : + finalState.values coordinate = some output ∧ + finalCache (.hidden coordinate) = some output := by + rw [revealCoordinateOutput_run, LazyRevealProbe.revealQuery, + LazyRevealProbe.runRaw_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some cached => + rw [hvalue] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨hvalue, by simp [Function.update]⟩ + | none => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨sampled, _, hrest⟩ := hresult + by_cases hhit : state.hitAt coordinate sampled + · rw [if_pos hhit] at hrest + simp at hrest + · rw [if_neg hhit] at hrest + simp [LazyRevealProbe.runRaw] at hrest + rcases hrest with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨by simp [LazyRevealProbe.State.materialize, Function.update], + by simp [Function.update]⟩ + +theorem mem_runRaw_revealCoordinate_value + (coordinate : Coordinate) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : Digest) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((revealCoordinate coordinate).run cache))) : + ∃ output : HashOutput, + value = truncateHash output ∧ finalState.values coordinate = some output := by + rw [revealCoordinate_run, LazyRevealProbe.revealQuery, + LazyRevealProbe.runRaw_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + rw [hvalue] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨output, rfl, hvalue⟩ + | none => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨output, _, hrest⟩ := hresult + by_cases hhit : state.hitAt coordinate output + · rw [if_pos hhit] at hrest + simp at hrest + · rw [if_neg hhit] at hrest + simp [LazyRevealProbe.runRaw] at hrest + rcases hrest with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨output, rfl, by + simp [LazyRevealProbe.State.materialize, Function.update]⟩ + +theorem mem_runRaw_revealPublishedCoordinate_value + (coordinate : Coordinate) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : Digest) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((revealPublishedCoordinate coordinate).run cache))) : + ∃ output : HashOutput, + value = truncateHash output ∧ finalState.values coordinate = some output := by + unfold revealPublishedCoordinate at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hreveal, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done revealState revealRemaining revealResult => + rcases revealResult with ⟨revealed, revealCache⟩ + have hrevealed := mem_runRaw_revealCoordinate_value coordinate state revealState cache + revealCache fuel revealRemaining revealed hreveal + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((publishCoordinate coordinate >>= fun _ => pure revealed).run revealCache) + revealState finalState revealRemaining remaining (value, finalCache) hrest + simp [publishCoordinate, LazyRevealProbe.publishQuery, + LazyRevealProbe.runRaw] at hrest + rcases hrest with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨hrevealed.choose, hrevealed.choose_spec.1, + hvaluesLE coordinate hrevealed.choose hrevealed.choose_spec.2⟩ + +theorem revealLayerValues_eq_table + (table : Coordinate → HashOutput) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (values : (ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (values, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((revealLayerValues index lay encoding).run cache))) : + values.1 = (fun chainIdx => truncateHash (table + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx)))) ∧ + values.2 = (fun level => + if level.val < layerHeight lay then + match level.val with + | 0 => truncateHash (table (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1))))) + | current + 1 => + if hlevel : current < maxLayerHeight then + truncateHash (table (.position (.node lay (treeIndexAt index lay) + ⟨current, hlevel⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1))))) + else 0 + else 0) := by + unfold revealLayerValues at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨chainRaw, hchains, hafterChains⟩ := hresult + cases chainRaw with + | stopped hit => simp at hafterChains + | done chainState chainRemaining chainResult => + rcases chainResult with ⟨chainValues, chainCache⟩ + simp only at hafterChains + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hafterChains + obtain ⟨pathRaw, hpaths, hfinish⟩ := hafterChains + cases pathRaw with + | stopped hit => simp at hfinish + | done pathState pathRemaining pathResult => + rcases pathResult with ⟨pathValues, pathCache⟩ + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨hfinalState, hremaining, hvalues, hfinalCache⟩ + subst finalState + subst remaining + subst values + subst finalCache + have hchainValuesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((sequenceFin fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + match level.val with + | 0 => revealPublishedCoordinate (.position (.leaf lay + (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | current + 1 => + if hlevel : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay + (treeIndexAt index lay) ⟨current, hlevel⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0 + else pure 0).run chainCache) + chainState pathState chainRemaining pathRemaining (pathValues, pathCache) hpaths + constructor + · funext chainIdx + change chainValues chainIdx = _ + obtain ⟨componentState, componentFinalState, componentCache, + componentFinalCache, componentFuel, componentRemaining, componentValue, + hcomponent, hselected, hcomponentLE, _, _⟩ := + sequenceFin_component_run_of_done + (fun chainIdx : ChainIndex => revealPublishedCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) + (leafIndexAt index lay) chainIdx (encoding chainIdx))) + (fun chainIdx => ordinaryCacheIncreasing_revealPublishedCoordinate _) + state chainState cache chainCache fuel chainRemaining chainValues hchains chainIdx + obtain ⟨output, hvalue, hstateValue⟩ := + mem_runRaw_revealPublishedCoordinate_value + (chainValueCoordinate lay (treeIndexAt index lay) + (leafIndexAt index lay) chainIdx (encoding chainIdx)) + componentState componentFinalState componentCache componentFinalCache + componentFuel componentRemaining componentValue hcomponent + rw [hselected, hvalue, htable _ output + (hchainValuesLE _ _ (hcomponentLE _ _ hstateValue))] + · funext level + change pathValues level = _ + obtain ⟨componentState, componentFinalState, componentCache, + componentFinalCache, componentFuel, componentRemaining, componentValue, + hcomponent, hselected, hcomponentLE, _, _⟩ := + sequenceFin_component_run_of_done + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + match level.val with + | 0 => revealPublishedCoordinate (.position (.leaf lay + (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | current + 1 => + if hlevel : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay + (treeIndexAt index lay) ⟨current, hlevel⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / + 2 ^ (current + 1)) 1)))) + else pure 0 + else pure 0) + (fun level => by + split + · split + · exact ordinaryCacheIncreasing_revealPublishedCoordinate _ + · split + · exact ordinaryCacheIncreasing_revealPublishedCoordinate _ + · exact OrdinaryCacheIncreasing.pure 0 + · exact OrdinaryCacheIncreasing.pure 0) + chainState pathState chainCache pathCache chainRemaining pathRemaining + pathValues hpaths level + rw [hselected] + by_cases hinLayer : level.val < layerHeight lay + · rw [if_pos hinLayer] + cases hlevelValue : level.val with + | zero => + have hpositive : 0 < layerHeight lay := by omega + obtain ⟨output, hvalue, hstateValue⟩ := + mem_runRaw_revealPublishedCoordinate_value _ componentState + componentFinalState componentCache componentFinalCache componentFuel + componentRemaining componentValue (by + simpa [hinLayer, hlevelValue, hpositive] using hcomponent) + rw [hvalue, htable _ output (hcomponentLE _ _ hstateValue)] + simp + | succ current => + have hcurrent : current < maxLayerHeight := by omega + have hcurrentLayer : current + 1 < layerHeight lay := by omega + let coordinate : Coordinate := .position (.node lay + (treeIndexAt index lay) ⟨current, hcurrent⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1))) + obtain ⟨output, hvalue, hstateValue⟩ := + mem_runRaw_revealPublishedCoordinate_value coordinate componentState + componentFinalState componentCache componentFinalCache componentFuel + componentRemaining componentValue (by + simpa [coordinate, hlevelValue, hcurrent, hcurrentLayer] using hcomponent) + rw [hvalue, htable coordinate output (hcomponentLE _ _ hstateValue)] + simp [coordinate, hcurrent] + · rw [if_neg hinLayer] + simp [hinLayer, LazyRevealProbe.runRaw] at hcomponent + exact hcomponent.2.2.1 + +theorem maskedOtsSignFrom_some_honest_eval + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (secret : ChainIndex → Digest) + (message : Digest) : ∀ attempts counter + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (selectedCounter : Counter) (encoding : ChainIndex → Digit), + StableCacheAgreesWithFn parameter finalCache f → + LazyRevealProbe.RawResult.done finalState remaining + (some (selectedCounter, encoding), finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedOtsSignFrom parameter lay tree leafIdx message attempts counter).run cache)) → + evalWithAnswerFn f + (otsSignFrom parameter lay tree leafIdx secret message attempts counter) = + some (selectedCounter, fun chainIdx => + honestChain f parameter lay tree leafIdx chainIdx (secret chainIdx) + (encoding chainIdx).val) + | 0, counter, state, finalState, cache, finalCache, fuel, remaining, + selectedCounter, encoding, hf, hresult => by + simp [maskedOtsSignFrom, LazyRevealProbe.runRaw] at hresult + | attempts + 1, counter, state, finalState, cache, finalCache, fuel, remaining, + selectedCounter, encoding, hf, hresult => by + rw [maskedOtsSignFrom, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨raw, hencode, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done encodeState encodeRemaining encodeResult => + rcases encodeResult with ⟨encoded, encodeCache⟩ + simp only at hrest + cases encoded with + | none => + have hordinaryLE := ordinaryCacheIncreasing_maskedOtsSignFrom parameter lay tree + leafIdx message attempts (counter + 1) encodeState encodeCache encodeRemaining + finalState remaining (some (selectedCounter, encoding)) finalCache hrest + have hfEncode : StableCacheAgreesWithFn parameter encodeCache f := + fun input output hstable hcached => hf input output hstable + (hordinaryLE hcached) + have hencoded := (replay_of_mem_runRaw_ordinaryHashImpl_of_stable f parameter + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) + state encodeState cache encodeCache fuel encodeRemaining none hfEncode + (queriesStable_encode f parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter)) hencode).1 + rw [otsSignFrom, evalWithAnswerFn_bind, hencoded] + exact maskedOtsSignFrom_some_honest_eval f parameter lay tree leafIdx secret message + attempts (counter + 1) encodeState finalState encodeCache finalCache + encodeRemaining remaining selectedCounter encoding hf hrest + | some selectedEncoding => + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hrest + obtain ⟨ensureRaw, hensure, hfinish⟩ := hrest + cases ensureRaw with + | stopped hit => simp at hfinish + | done ensureState ensureRemaining ensureResult => + rcases ensureResult with ⟨ensured, ensureCache⟩ + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, hselected, rfl⟩ + rcases hselected with ⟨hcounter, hencoding⟩ + subst selectedCounter + subst encoding + have hordinaryLE := ordinaryCacheIncreasing_sequenceFin + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx + (selectedEncoding chainIdx)) + (fun chainIdx => + (splitCachePreserving_ensureChainPrefix lay tree leafIdx chainIdx + (selectedEncoding chainIdx)).ordinaryCacheIncreasing) + encodeState encodeCache encodeRemaining finalState remaining ensured finalCache + hensure + have hfEncode : StableCacheAgreesWithFn parameter encodeCache f := + fun input output hstable hcached => hf input output hstable + (hordinaryLE hcached) + have hencoded := (replay_of_mem_runRaw_ordinaryHashImpl_of_stable f parameter + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) + state encodeState cache encodeCache fuel encodeRemaining + (some selectedEncoding) hfEncode + (queriesStable_encode f parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter)) hencode).1 + rw [otsSignFrom, evalWithAnswerFn_bind, hencoded, + evalWithAnswerFn_bind, evalWithAnswerFn_sequenceFin, + evalWithAnswerFn_pure] + congr 2 + +theorem maskedOtsSign_some_honest_eval + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (secret : ChainIndex → Digest) + (message : Digest) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (counter : Counter) (encoding : ChainIndex → Digit) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (some (counter, encoding), finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedOtsSign parameter lay tree leafIdx message).run cache))) : + evalWithAnswerFn f (otsSign parameter lay tree leafIdx secret message) = + some (counter, fun chainIdx => + honestChain f parameter lay tree leafIdx chainIdx (secret chainIdx) + (encoding chainIdx).val) := by + exact maskedOtsSignFrom_some_honest_eval f parameter lay tree leafIdx secret message + encodingAttemptLimit 0 state finalState cache finalCache fuel remaining counter encoding + hf hresult + +theorem maskedOtsLayerAfterMessage_some_honest_eval + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (index : Index) (lay : Layer) + (secret : ChainIndex → Digest) (message actualMessage : Digest) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (counter : Counter) (encoding : ChainIndex → Digit) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (hmessage : message = actualMessage) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (some (counter, encoding), finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedOtsLayerAfterMessage parameter index lay message).run cache))) : + evalWithAnswerFn f + (otsSign parameter lay (treeIndexAt index lay) (leafIndexAt index lay) secret + actualMessage) = + some (counter, fun chainIdx => + honestChain f parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (secret chainIdx) (encoding chainIdx).val) := by + unfold maskedOtsLayerAfterMessage at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨otsRaw, hots, hafterOts⟩ := hresult + cases otsRaw with + | stopped hit => simp at hafterOts + | done otsState otsRemaining otsResult => + rcases otsResult with ⟨part, otsCache⟩ + cases part with + | none => simp [LazyRevealProbe.runRaw] at hafterOts + | some selectedPart => + rcases selectedPart with ⟨selectedCounter, selectedEncoding⟩ + simp only at hafterOts + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterOts + obtain ⟨pathRaw, hpath, hfinish⟩ := hafterOts + cases pathRaw with + | stopped hit => simp at hfinish + | done pathState pathRemaining pathResult => + rcases pathResult with ⟨pathUnit, pathCache⟩ + have hpathCache := splitCachePreserving_ensureTreePath lay + (treeIndexAt index lay) (leafIndexAt index lay) otsState otsCache otsRemaining + pathState pathRemaining pathUnit pathCache hpath + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, hpart, rfl⟩ + rcases hpart with ⟨hcounter, hencoding⟩ + subst selectedCounter + subst selectedEncoding + rw [hpathCache] at hf + subst message + exact maskedOtsSign_some_honest_eval f parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) secret actualMessage state + otsState cache otsCache fuel otsRemaining counter encoding hf hots + +theorem maskedSignLayer_some_honest_eval + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (counter : Counter) (encoding : ChainIndex → Digit) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (some (counter, encoding), finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedSignLayer parameter ftsSecret index lay).run cache))) : + evalWithAnswerFn f + (otsSign parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (tableOtsSecret table lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f + (layerMessage + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) index lay))) = + some (counter, fun chainIdx => + honestChain f parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx + (tableOtsSecret table lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx) + (encoding chainIdx).val) := by + unfold maskedSignLayer at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨messageRaw, hmessage, hafterMessage⟩ := hresult + cases messageRaw with + | stopped hit => simp at hafterMessage + | done messageState messageRemaining messageResult => + rcases messageResult with ⟨message, messageCache⟩ + simp only at hafterMessage + change LazyRevealProbe.RawResult.done finalState remaining + (some (counter, encoding), finalCache) ∈ support + (LazyRevealProbe.runRaw messageState messageRemaining + ((maskedOtsLayerAfterMessage parameter index lay message).run messageCache)) + at hafterMessage + by_cases hbelow : lay.val + 1 < numLayers + · let below : Layer := ⟨lay.val + 1, hbelow⟩ + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((maskedOtsLayerAfterMessage parameter index lay message).run messageCache) + messageState finalState messageRemaining remaining + (some (counter, encoding), finalCache) hafterMessage + have hmessageActual := maskedLayerMessage_eq_actual_of_lt + (f := f) (parameter := parameter) (root := root) (table := table) + (ftsSecret := ftsSecret) (index := index) (lay := lay) (below := below) + (hbelow := hbelow) (hbelowEq := rfl) (state := state) + (messageState := messageState) (referenceState := finalState) (cache := cache) + (messageCache := messageCache) (fuel := fuel) (messageRemaining := messageRemaining) + (message := message) hvaluesLE htable hrealizes hmessage + exact maskedOtsLayerAfterMessage_some_honest_eval f parameter index lay + (tableOtsSecret table lay (treeIndexAt index lay) (leafIndexAt index lay)) message + (evalWithAnswerFn f + (layerMessage + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) index lay)) + messageState finalState messageCache finalCache messageRemaining remaining counter + encoding hf hmessageActual hafterMessage + · have hordinaryLE := ordinaryCacheIncreasing_maskedSignLayerAfterMessage parameter index lay + message messageState messageCache messageRemaining finalState remaining + (some (counter, encoding)) finalCache hafterMessage + have hfMessage : StableCacheAgreesWithFn parameter messageCache f := + fun input output hstable hcached => hf input output hstable (hordinaryLE hcached) + have hmessageActual := maskedLayerMessage_eq_actual_of_not_lt f parameter root table + ftsSecret index lay hbelow state messageState cache messageCache fuel messageRemaining + message hfMessage hmessage + exact maskedOtsLayerAfterMessage_some_honest_eval f parameter index lay + (tableOtsSecret table lay (treeIndexAt index lay) (leafIndexAt index lay)) message + (evalWithAnswerFn f + (layerMessage + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) index lay)) + messageState finalState messageCache finalCache messageRemaining remaining counter + encoding hf hmessageActual hafterMessage + +theorem evalWithAnswerFn_treePath_eq_table + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) : + evalWithAnswerFn f + (treePath parameter lay tree (tableOtsSecret table lay tree) leafIdx) = + fun level => + if level.val < layerHeight lay then + match level.val with + | 0 => truncateHash (table (.position (.leaf lay tree + (leafOfNat (Nat.xor leafIdx.val 1))))) + | current + 1 => + if hcurrent : current < maxLayerHeight then + truncateHash (table (.position (.node lay tree ⟨current, hcurrent⟩ + (leafOfNat (Nat.xor (leafIdx.val / 2 ^ (current + 1)) 1))))) + else 0 + else 0 := by + funext level + simp only [treePath, evalWithAnswerFn_sequenceFin] + by_cases hinLayer : level.val < layerHeight lay + · rw [if_pos hinLayer, if_pos hinLayer] + cases hlevelValue : level.val with + | zero => + have hspan := FtsProbeSimulation.sibling_node_bound maxLayerHeight leafIdx.val 0 + (by norm_num [maxLayerHeight]) leafIdx.isLt + have hsibling : Nat.xor leafIdx.val 1 < 2 ^ maxLayerHeight := by + simpa using hspan + have hleafValue : (leafOfNat (Nat.xor leafIdx.val 1)).val = + Nat.xor leafIdx.val 1 := by + change Nat.xor leafIdx.val 1 % 2 ^ maxLayerHeight = Nat.xor leafIdx.val 1 + exact Nat.mod_eq_of_lt hsibling + have hnode := honestNode_zero_eq_table f parameter table lay tree + (leafOfNat (Nat.xor leafIdx.val 1)) hrealizes + rw [hleafValue] at hnode + simpa [honestNode, hlevelValue, tableValue] using hnode + | succ current => + have hcurrent : current < maxLayerHeight := by + have := layerHeight_le lay + omega + have hspan := FtsProbeSimulation.sibling_node_bound maxLayerHeight leafIdx.val + (current + 1) (by omega) leafIdx.isLt + have hnode := honestNode_eq_table_succ f parameter table lay tree hrealizes current + (Nat.xor (leafIdx.val / 2 ^ (current + 1)) 1) hcurrent hspan + simpa [honestNode, hlevelValue, hcurrent, tableValue] using hnode + · simp [hinLayer] + +theorem honestChain_eq_table_chainValueCoordinate + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) : + honestChain f parameter lay tree leafIdx chainIdx + (tableOtsSecret table lay tree leafIdx chainIdx) digit.val = + truncateHash (table (chainValueCoordinate lay tree leafIdx chainIdx digit)) := by + by_cases hzero : digit.val = 0 + · simp [chainValueCoordinate, hzero, honestChain_zero, tableOtsSecret] + · have hstep : digit.val - 1 < chainLength - 1 := by + have := digit.isLt + omega + have hchain := honestChain_eq_table_succ f parameter table lay tree leafIdx chainIdx + hrealizes (digit.val - 1) hstep + have hvalue : digit.val - 1 + 1 = digit.val := by omega + rw [hvalue] at hchain + simpa [chainValueCoordinate, hzero, tableValue] using hchain + +theorem maskedSignLayer_and_reveal_eval + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) (counter : Counter) + (encoding : ChainIndex → Digit) + (signState signFinalState : LazyRevealProbe.State Coordinate) + (signCache signFinalCache : SplitHashCache) (signFuel signRemaining : Nat) + (revealState revealFinalState : LazyRevealProbe.State Coordinate) + (revealCache revealFinalCache : SplitHashCache) (revealFuel revealRemaining : Nat) + (values : (ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) + (hf : StableCacheAgreesWithFn parameter signFinalCache f) + (htableSign : ∀ coordinate output, + signFinalState.values coordinate = some output → output = table coordinate) + (htableReveal : ∀ coordinate output, + revealFinalState.values coordinate = some output → output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hsign : LazyRevealProbe.RawResult.done signFinalState signRemaining + (some (counter, encoding), signFinalCache) ∈ support + (LazyRevealProbe.runRaw signState signFuel + ((maskedSignLayer parameter ftsSecret index lay).run signCache))) + (hreveal : LazyRevealProbe.RawResult.done revealFinalState revealRemaining + (values, revealFinalCache) ∈ support + (LazyRevealProbe.runRaw revealState revealFuel + ((revealLayerValues index lay encoding).run revealCache))) : + evalWithAnswerFn f + (signLayer + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) index lay) = + some (counter, values.1, values.2) := by + have hots := maskedSignLayer_some_honest_eval f parameter root table ftsSecret index lay + signState signFinalState signCache signFinalCache signFuel signRemaining counter encoding hf + htableSign hrealizes hsign + have hotsTable : evalWithAnswerFn f + (otsSign parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (tableOtsSecret table lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f + (layerMessage + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) index lay))) = + some (counter, fun chainIdx => truncateHash (table + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx)))) := by + rw [hots] + congr 2 + funext chainIdx + exact honestChain_eq_table_chainValueCoordinate f parameter table lay + (treeIndexAt index lay) (leafIndexAt index lay) chainIdx (encoding chainIdx) hrealizes + have hpathTable := evalWithAnswerFn_treePath_eq_table f parameter table lay + (treeIndexAt index lay) (leafIndexAt index lay) hrealizes + have hrevealedTable := revealLayerValues_eq_table table index lay encoding revealState + revealFinalState revealCache revealFinalCache revealFuel revealRemaining values htableReveal + hreveal + rw [signLayer, evalWithAnswerFn_bind, evalWithAnswerFn_bind, hotsTable, + evalWithAnswerFn_bind, hpathTable, evalWithAnswerFn_pure, hrevealedTable.1, + hrevealedTable.2] + +theorem mergedCache_tableInput_ne_none_of_ensured + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (position : Position) (hots : IsOtsPosition position) + (hensured : Coordinate.position position ∈ state.ensured) : + mergedCache parameter table state.ensured cache + (tableInput parameter table (.position position)) ≠ none := by + rw [mergedCache_tableInput parameter table state.ensured cache position hots] + cases hhidden : cache (.hidden (.position position)) <;> + simp [completedSplitHashCache, hhidden, hensured] + +theorem mergedCache_eq_ordinary_of_stable + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (ensured : Finset Coordinate) (cache : SplitHashCache) (input : HashInput) + (hstable : StableOrdinaryInput parameter input) : + mergedCache parameter table ensured cache input = cache (.ordinary input) := by + rcases hstable with ⟨_, hstable⟩ + unfold mergedCache + cases hposition : decodePosition? parameter input with + | none => rfl + | some position => + have hnots := hstable position hposition + cases position <;> simp [mergeDecodedPosition, IsOtsPosition] at hnots ⊢ + +theorem mergedCache_eq_ordinary_or_exact + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (ensured : Finset Coordinate) (cache : SplitHashCache) (input : HashInput) : + mergedCache parameter table ensured cache input = cache (.ordinary input) ∨ + ∃ position : Position, IsOtsPosition position ∧ + input = tableInput parameter table (.position position) := by + unfold mergedCache + cases hposition : decodePosition? parameter input with + | none => exact Or.inl rfl + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + by_cases hexact : input = tableInput parameter table + (.position (.chain lay tree leafIdx chainIdx step)) + · refine Or.inr ⟨.chain lay tree leafIdx chainIdx step, ?_, hexact⟩ + exact True.intro + · exact Or.inl (by simp [mergeDecodedPosition, hexact]) + | leaf lay tree leafIdx => + by_cases hexact : input = tableInput parameter table + (.position (.leaf lay tree leafIdx)) + · refine Or.inr ⟨.leaf lay tree leafIdx, ?_, hexact⟩ + exact True.intro + · exact Or.inl (by simp [mergeDecodedPosition, hexact]) + | node lay tree level nodeIdx => + by_cases hexact : input = tableInput parameter table + (.position (.node lay tree level nodeIdx)) + · refine Or.inr ⟨.node lay tree level nodeIdx, ?_, hexact⟩ + exact True.intro + · exact Or.inl (by simp [mergeDecodedPosition, hexact]) + | ftsLeaf | ftsNode | ftsRoots => exact Or.inl (by simp [mergeDecodedPosition]) + +theorem tableAnswer_eq_fallback_or_exact + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (fallback : QueryImpl HashSpec Id) (input : HashInput) : + tableAnswer parameter table fallback input = fallback input ∨ + ∃ position : Position, IsOtsPosition position ∧ + input = tableInput parameter table (.position position) := by + unfold tableAnswer + cases hposition : decodePosition? parameter input with + | none => exact Or.inl rfl + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + by_cases hexact : input = tableInput parameter table + (.position (.chain lay tree leafIdx chainIdx step)) + · refine Or.inr ⟨.chain lay tree leafIdx chainIdx step, ?_, hexact⟩ + exact True.intro + · exact Or.inl (by simp [tableAnswerDecoded, hexact]) + | leaf lay tree leafIdx => + by_cases hexact : input = tableInput parameter table + (.position (.leaf lay tree leafIdx)) + · refine Or.inr ⟨.leaf lay tree leafIdx, ?_, hexact⟩ + exact True.intro + · exact Or.inl (by simp [tableAnswerDecoded, hexact]) + | node lay tree level nodeIdx => + by_cases hexact : input = tableInput parameter table + (.position (.node lay tree level nodeIdx)) + · refine Or.inr ⟨.node lay tree level nodeIdx, ?_, hexact⟩ + exact True.intro + · exact Or.inl (by simp [tableAnswerDecoded, hexact]) + | ftsLeaf | ftsNode | ftsRoots => exact Or.inl (by simp [tableAnswerDecoded]) + +theorem cachedRun_mergedCache_of_stable + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → HashOutput) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (computation : OracleComp HashSpec alpha) + (hstable : QueriesStable parameter f computation) + (hrun : CachedRun (ordinaryQueryCache cache) f computation) : + CachedRun (mergedCache parameter table state.ensured cache) f computation := by + intro input hinput + rw [mergedCache_eq_ordinary_of_stable parameter table state.ensured cache input + (hstable input hinput)] + exact hrun input hinput + +def StableOrdinaryCacheLE (parameter : PublicParameter) + (initial final : SplitHashCache) : Prop := + ∀ input output, StableOrdinaryInput parameter input → + initial (.ordinary input) = some output → final (.ordinary input) = some output + +theorem StableOrdinaryCacheLE.refl (parameter : PublicParameter) (cache : SplitHashCache) : + StableOrdinaryCacheLE parameter cache cache := by + intro input output hstable hcached + exact hcached + +theorem StableOrdinaryCacheLE.trans + {parameter : PublicParameter} {first second third : SplitHashCache} + (hfirst : StableOrdinaryCacheLE parameter first second) + (hsecond : StableOrdinaryCacheLE parameter second third) : + StableOrdinaryCacheLE parameter first third := by + intro input output hstable hcached + exact hsecond input output hstable (hfirst input output hstable hcached) + +theorem StableOrdinaryCacheLE.of_le + {parameter : PublicParameter} {initial final : SplitHashCache} + (hle : ordinaryQueryCache initial ≤ ordinaryQueryCache final) : + StableOrdinaryCacheLE parameter initial final := by + intro input output hstable hcached + exact hle hcached + +theorem CachedRun.mono_stableOrdinary + {f : QueryImpl HashSpec Id} {parameter : PublicParameter} + {initial final : SplitHashCache} {computation : OracleComp HashSpec alpha} + (hstable : QueriesStable parameter f computation) + (hle : StableOrdinaryCacheLE parameter initial final) + (hrun : CachedRun (ordinaryQueryCache initial) f computation) : + CachedRun (ordinaryQueryCache final) f computation := by + intro input hinput + obtain ⟨output, hcached⟩ := Option.ne_none_iff_exists'.mp (hrun input hinput) + change initial (.ordinary input) = some output at hcached + change final (.ordinary input) ≠ none + rw [hle input output (hstable input hinput) hcached] + simp + +theorem cachedRun_chainWalk_of_ensured + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → HashOutput) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) : + ∀ steps : Nat, + (∀ step : ChainStep, step.val < steps → + Coordinate.position (.chain lay tree leafIdx chainIdx step) ∈ state.ensured) → + CachedRun (mergedCache parameter table state.ensured cache) f + (chainWalk parameter lay tree leafIdx chainIdx 0 steps + (tableOtsSecret table lay tree leafIdx chainIdx)) + | 0, _ => CachedRun.pure _ _ _ + | steps + 1, hensured => by + rw [chainWalk] + apply CachedRun.bind + · exact cachedRun_chainWalk_of_ensured f parameter table state cache lay tree leafIdx + chainIdx hrealizes steps (fun step hstep => hensured step (by omega)) + · split_ifs with hstep + · intro input hinput + simp only [queriedInputs_tweakableHash, List.mem_singleton] at hinput + subst input + have hstep' : steps < chainLength - 1 := by omega + let position : ChainStep := ⟨steps, hstep'⟩ + have hinput : + tweakableHashInput parameter (.chain lay tree leafIdx chainIdx position) + (digestBytes (honestChain f parameter lay tree leafIdx chainIdx + (tableOtsSecret table lay tree leafIdx chainIdx) steps)) = + tableInput parameter table + (.position (.chain lay tree leafIdx chainIdx position)) := by + cases steps with + | zero => + simp [honestChain_zero, tableInput, tablePayload, tableOtsSecret, + Position.domain, position] + | succ previous => + have hprevious : previous < chainLength - 1 := by omega + rw [honestChain_eq_table_succ f parameter table lay tree leafIdx chainIdx + hrealizes previous hprevious] + simp [tableInput, tablePayload, Position.children, Position.domain, position] + have hposition : (⟨0 + steps, hstep⟩ : ChainStep) = position := by + apply Fin.ext + simp [position] + change mergedCache parameter table state.ensured cache + (tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx ⟨0 + steps, hstep⟩) + (digestBytes (honestChain f parameter lay tree leafIdx chainIdx + (tableOtsSecret table lay tree leafIdx chainIdx) steps))) ≠ none + rw [hposition, hinput] + exact mergedCache_tableInput_ne_none_of_ensured parameter table state cache + (.chain lay tree leafIdx chainIdx position) (by trivial) + (hensured position (by simp [position])) + · exact CachedRun.pure _ _ _ + +theorem mem_runRaw_ensureCoordinate_mem + (coordinate : Coordinate) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : Unit) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel ((ensureCoordinate coordinate).run cache))) : + coordinate ∈ finalState.ensured := by + simp [ensureCoordinate, LazyRevealProbe.ensureQuery, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + simp [LazyRevealProbe.State.ensure] + +structure EnsuresCoordinate (coordinate : Coordinate) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop where + of_run : ∀ state finalState cache finalCache fuel remaining value, + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + coordinate ∈ finalState.ensured + +theorem EnsuresCoordinate.done + {coordinate : Coordinate} + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + (hensures : EnsuresCoordinate coordinate computation) + {state finalState : LazyRevealProbe.State Coordinate} + {cache finalCache : SplitHashCache} {fuel remaining : Nat} {value : alpha} + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache))) : + coordinate ∈ finalState.ensured := + hensures.of_run state finalState cache finalCache fuel remaining value hresult + +theorem EnsuresCoordinate.bind_preserved + {coordinate : Coordinate} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : EnsuresCoordinate coordinate left) : + EnsuresCoordinate coordinate (left >>= next) := by + constructor + intro state finalState cache finalCache fuel remaining value hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun result => (next result.1).run result.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining middleResult => + rcases middleResult with ⟨middleValue, middleCache⟩ + have hmiddle := hleft.of_run state middleState cache middleCache fuel middleRemaining + middleValue hraw + exact (LazyRevealProbe.ensuredLE_of_mem_runRaw_done + ((next middleValue).run middleCache) middleState finalState middleRemaining remaining + (value, finalCache) hrest) hmiddle + +theorem EnsuresCoordinate.bind_right + {coordinate : Coordinate} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hnext : ∀ value, EnsuresCoordinate coordinate (next value)) : + EnsuresCoordinate coordinate (left >>= next) := by + constructor + intro state finalState cache finalCache fuel remaining value hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun result => (next result.1).run result.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining middleResult => + rcases middleResult with ⟨middleValue, middleCache⟩ + exact (hnext middleValue).of_run middleState finalState middleCache finalCache + middleRemaining remaining value hrest + +theorem ensuresCoordinate_ensureCoordinate (coordinate : Coordinate) : + EnsuresCoordinate coordinate (ensureCoordinate coordinate) := by + constructor + intro state finalState cache finalCache fuel remaining value hresult + exact mem_runRaw_ensureCoordinate_mem coordinate state finalState cache finalCache fuel + remaining value hresult + +theorem EnsuresCoordinate.sequenceFin_component {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (index : Fin n) (hensures : EnsuresCoordinate coordinate (computation index)) : + EnsuresCoordinate coordinate (sequenceFin computation) := by + induction n with + | zero => exact index.elim0 + | succ n ih => + rw [sequenceFin] + cases index using Fin.cases with + | zero => exact hensures.bind_preserved + | succ index => + apply EnsuresCoordinate.bind_right + intro head + exact (ih (fun current : Fin n => computation current.succ) index + hensures).bind_preserved + +def EnsuresCoordinates {n : Nat} (coordinate : Fin n → Coordinate) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ index, EnsuresCoordinate (coordinate index) computation + +theorem ensuresCoordinates_sequenceFin {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (coordinate : Fin n → Coordinate) + (hcomponent : ∀ index, EnsuresCoordinate (coordinate index) (computation index)) : + EnsuresCoordinates coordinate (sequenceFin computation) := by + intro index + exact EnsuresCoordinate.sequenceFin_component computation index (hcomponent index) + +theorem mem_runRaw_ensureChainPrefix_mem + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (digit : Digit) (step : ChainStep) (hstep : step.val < digit.val) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : Unit) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((ensureChainPrefix lay tree leafIdx chainIdx digit).run cache))) : + Coordinate.position (.chain lay tree leafIdx chainIdx step) ∈ finalState.ensured := by + unfold ensureChainPrefix at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hsequence, hfinish⟩ := hresult + cases raw with + | stopped hit => simp at hfinish + | done sequenceState sequenceRemaining sequenceResult => + rcases sequenceResult with ⟨values, sequenceCache⟩ + obtain ⟨componentState, componentFinalState, componentCache, componentFinalCache, + componentFuel, componentRemaining, componentValue, hcomponent, _, _, + hcomponentEnsured, _⟩ := + sequenceFin_component_run_of_done + (fun current : ChainStep => + if current.val < digit.val then + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx current)) + else pure ()) + (fun current => by + split + · exact (splitCachePreserving_ensureCoordinate _).ordinaryCacheIncreasing + · exact OrdinaryCacheIncreasing.pure ()) + state sequenceState cache sequenceCache fuel sequenceRemaining values hsequence step + rw [if_pos hstep] at hcomponent + have hensured := hcomponentEnsured (mem_runRaw_ensureCoordinate_mem _ componentState + componentFinalState componentCache componentFinalCache componentFuel componentRemaining + componentValue hcomponent) + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + exact hensured + +theorem ensuresCoordinate_ensureChainPrefix + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (digit : Digit) (step : ChainStep) (hstep : step.val < digit.val) : + EnsuresCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + constructor + intro state finalState cache finalCache fuel remaining value hresult + exact mem_runRaw_ensureChainPrefix_mem lay tree leafIdx chainIdx digit step hstep state + finalState cache finalCache fuel remaining value hresult + +set_option maxRecDepth 10000 in +theorem cachedRun_otsSignFrom_of_mem_runRaw_maskedOtsSignFrom + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (lay : Layer) + (table : Coordinate → HashOutput) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) : ∀ attempts counter + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (selectedCounter : Counter) (encoding : ChainIndex → Digit) + (targetState : LazyRevealProbe.State Coordinate) (targetCache : SplitHashCache), + StableCacheAgreesWithFn parameter finalCache f → + (∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) → + LazyRevealProbe.RawResult.done finalState remaining + (some (selectedCounter, encoding), finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedOtsSignFrom parameter lay tree leafIdx message attempts counter).run cache)) → + LazyRevealProbe.EnsuredLE finalState targetState → + StableOrdinaryCacheLE parameter finalCache targetCache → + CachedRun (mergedCache parameter table targetState.ensured targetCache) f + (otsSignFrom parameter lay tree leafIdx (tableOtsSecret table lay tree leafIdx) + message attempts counter) + | 0, counter, state, finalState, cache, finalCache, fuel, remaining, + selectedCounter, encoding, targetState, targetCache, hf, hrealizes, hresult, + hensuredTarget, hcacheTarget => by + simp [maskedOtsSignFrom, LazyRevealProbe.runRaw] at hresult + | attempts + 1, counter, state, finalState, cache, finalCache, fuel, remaining, + selectedCounter, encoding, targetState, targetCache, hf, hrealizes, hresult, + hensuredTarget, hcacheTarget => by + rw [maskedOtsSignFrom, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨raw, hencode, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done encodeState encodeRemaining encodeResult => + rcases encodeResult with ⟨encoded, encodeCache⟩ + simp only at hrest + cases encoded with + | none => + have hordinaryLE := ordinaryCacheIncreasing_maskedOtsSignFrom parameter lay tree + leafIdx message attempts (counter + 1) encodeState encodeCache encodeRemaining + finalState remaining (some (selectedCounter, encoding)) finalCache hrest + have hfEncode : StableCacheAgreesWithFn parameter encodeCache f := + fun input output hstable hcached => hf input output hstable + (hordinaryLE hcached) + have hreplay := replay_of_mem_runRaw_ordinaryHashImpl_of_stable f parameter + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) + state encodeState cache encodeCache fuel encodeRemaining none hfEncode + (queriesStable_encode f parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter)) hencode + have hencodeRun := cachedRun_mergedCache_of_stable f parameter table targetState + targetCache _ + (queriesStable_encode f parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter)) + (CachedRun.mono_stableOrdinary + (queriesStable_encode f parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter)) + ((StableOrdinaryCacheLE.of_le hordinaryLE).trans hcacheTarget) hreplay.2) + rw [otsSignFrom] + apply hencodeRun.bind + rw [hreplay.1] + exact cachedRun_otsSignFrom_of_mem_runRaw_maskedOtsSignFrom f parameter lay table tree + leafIdx message attempts (counter + 1) encodeState finalState encodeCache + finalCache encodeRemaining remaining selectedCounter encoding targetState + targetCache hf hrealizes hrest hensuredTarget hcacheTarget + | some selectedEncoding => + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hrest + obtain ⟨ensureRaw, hensure, hfinish⟩ := hrest + cases ensureRaw with + | stopped hit => simp at hfinish + | done ensureState ensureRemaining ensureResult => + rcases ensureResult with ⟨ensured, ensureCache⟩ + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, hselected, rfl⟩ + rcases hselected with ⟨hcounter, hencoding⟩ + subst selectedCounter + subst encoding + have hordinaryLE := ordinaryCacheIncreasing_sequenceFin + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx + (selectedEncoding chainIdx)) + (fun chainIdx => + (splitCachePreserving_ensureChainPrefix lay tree leafIdx chainIdx + (selectedEncoding chainIdx)).ordinaryCacheIncreasing) + encodeState encodeCache encodeRemaining finalState remaining ensured + finalCache hensure + have hfEncode : StableCacheAgreesWithFn parameter encodeCache f := + fun input output hstable hcached => hf input output hstable + (hordinaryLE hcached) + have hreplay := replay_of_mem_runRaw_ordinaryHashImpl_of_stable f parameter + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) + state encodeState cache encodeCache fuel encodeRemaining + (some selectedEncoding) hfEncode + (queriesStable_encode f parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter)) hencode + have hencodeRun := cachedRun_mergedCache_of_stable f parameter table targetState + targetCache _ + (queriesStable_encode f parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter)) + (CachedRun.mono_stableOrdinary + (queriesStable_encode f parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter)) + ((StableOrdinaryCacheLE.of_le hordinaryLE).trans hcacheTarget) hreplay.2) + have hensured : ∀ chainIdx step, step.val < (selectedEncoding chainIdx).val → + Coordinate.position (.chain lay tree leafIdx chainIdx step) ∈ + targetState.ensured := by + intro chainIdx step hstep + exact hensuredTarget ((EnsuresCoordinate.sequenceFin_component + (fun current : ChainIndex => ensureChainPrefix lay tree leafIdx current + (selectedEncoding current)) chainIdx + (ensuresCoordinate_ensureChainPrefix lay tree leafIdx chainIdx + (selectedEncoding chainIdx) step hstep)).of_run encodeState finalState + encodeCache finalCache encodeRemaining remaining ensured hensure) + have hchains : ∀ chainIdx, CachedRun + (mergedCache parameter table targetState.ensured targetCache) f + (chainWalk parameter lay tree leafIdx chainIdx 0 + (selectedEncoding chainIdx).val + (tableOtsSecret table lay tree leafIdx chainIdx)) := by + intro chainIdx + exact cachedRun_chainWalk_of_ensured f parameter table targetState targetCache + lay tree leafIdx chainIdx hrealizes (selectedEncoding chainIdx).val + (fun step hstep => hensured chainIdx step hstep) + rw [otsSignFrom] + apply hencodeRun.bind + rw [hreplay.1] + apply (CachedRun.sequenceFin _ hchains).bind + exact CachedRun.pure _ _ _ + +theorem cachedRun_otsSign_of_mem_runRaw_maskedOtsSign + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (lay : Layer) + (table : Coordinate → HashOutput) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (selectedCounter : Counter) (encoding : ChainIndex → Digit) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (some (selectedCounter, encoding), finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedOtsSign parameter lay tree leafIdx message).run cache))) : + CachedRun (mergedCache parameter table finalState.ensured finalCache) f + (otsSign parameter lay tree leafIdx (tableOtsSecret table lay tree leafIdx) message) := by + exact cachedRun_otsSignFrom_of_mem_runRaw_maskedOtsSignFrom f parameter lay table tree leafIdx + message encodingAttemptLimit 0 state finalState cache finalCache fuel remaining selectedCounter + encoding finalState finalCache hf hrealizes hresult + (LazyRevealProbe.EnsuredLE.refl finalState) + (StableOrdinaryCacheLE.refl parameter finalCache) + +theorem ensuresCoordinate_ensureFullChain + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (step : ChainStep) : + EnsuresCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (EnsuresCoordinate.sequenceFin_component + (fun current : ChainStep => + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx current))) step + (ensuresCoordinate_ensureCoordinate _)).bind_preserved + +theorem ensuresCoordinates_ensureFullChains + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (step : ChainStep) : + EnsuresCoordinates + (fun chainIdx : ChainIndex => + Coordinate.position (.chain lay tree leafIdx chainIdx step)) + (sequenceFin fun chainIdx : ChainIndex => + ensureFullChain lay tree leafIdx chainIdx) := by + exact ensuresCoordinates_sequenceFin + (fun chainIdx : ChainIndex => ensureFullChain lay tree leafIdx chainIdx) + (fun chainIdx : ChainIndex => .position (.chain lay tree leafIdx chainIdx step)) + (fun chainIdx => ensuresCoordinate_ensureFullChain lay tree leafIdx chainIdx step) + +theorem ensuresCoordinate_ensureOtsLeaf_chain + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (step : ChainStep) : + EnsuresCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (ensuresCoordinates_ensureFullChains lay tree leafIdx step chainIdx).bind_preserved + +theorem ensuresCoordinate_ensureOtsLeaf_leaf + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + EnsuresCoordinate (.position (.leaf lay tree leafIdx)) + (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + apply EnsuresCoordinate.bind_right + intro values + exact ensuresCoordinate_ensureCoordinate _ + +theorem mem_runRaw_ensureFullChain_mem + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (step : ChainStep) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : Unit) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((ensureFullChain lay tree leafIdx chainIdx).run cache))) : + Coordinate.position (.chain lay tree leafIdx chainIdx step) ∈ finalState.ensured := by + exact (ensuresCoordinate_ensureFullChain lay tree leafIdx chainIdx step).done hresult + +attribute [local irreducible] ensureFullChain ensureOtsLeaf + +set_option linter.constructorNameAsVariable false in +theorem mem_runRaw_ensureOtsLeaf_mem + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : Unit) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((ensureOtsLeaf lay tree leafIdx).run cache))) : + (∀ chainIdx step, + Coordinate.position (.chain lay tree leafIdx chainIdx step) ∈ finalState.ensured) ∧ + Coordinate.position (.leaf lay tree leafIdx) ∈ finalState.ensured := by + constructor + · intro chainIdx step + exact (ensuresCoordinate_ensureOtsLeaf_chain lay tree leafIdx chainIdx step).of_run + state finalState cache finalCache fuel remaining value hresult + · exact (ensuresCoordinate_ensureOtsLeaf_leaf lay tree leafIdx).of_run + state finalState cache finalCache fuel remaining value hresult + +theorem cachedRun_oneTimePublicKey_of_ensuredOtsLeaf + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → HashOutput) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hensured : ∀ chainIdx step, + Coordinate.position (.chain lay tree leafIdx chainIdx step) ∈ state.ensured) : + CachedRun (mergedCache parameter table state.ensured cache) f + (oneTimePublicKey parameter lay tree leafIdx + (tableOtsSecret table lay tree leafIdx)) := by + apply CachedRun.sequenceFin + intro chainIdx + exact cachedRun_chainWalk_of_ensured f parameter table state cache lay tree leafIdx chainIdx + hrealizes (chainLength - 1) (fun step _ => hensured chainIdx step) + +theorem cachedRun_treeNode_zero_of_ensuredOtsLeaf + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → HashOutput) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (lay : Layer) (tree : TreeIndex) (nodeIdx : Nat) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hchains : ∀ chainIdx step, + Coordinate.position (.chain lay tree (leafOfNat nodeIdx) chainIdx step) ∈ state.ensured) + (hleaf : Coordinate.position (.leaf lay tree (leafOfNat nodeIdx)) ∈ state.ensured) : + CachedRun (mergedCache parameter table state.ensured cache) f + (treeNode parameter lay tree (tableOtsSecret table lay tree) 0 nodeIdx) := by + rw [treeNode_zero_eq] + have hpublic := cachedRun_oneTimePublicKey_of_ensuredOtsLeaf f parameter table state cache lay + tree (leafOfNat nodeIdx) hrealizes hchains + apply hpublic.bind + have hendpoints : evalWithAnswerFn f + (oneTimePublicKey parameter lay tree (leafOfNat nodeIdx) + (tableOtsSecret table lay tree (leafOfNat nodeIdx))) = + fun chainIdx => tableValue table + (.chain lay tree (leafOfNat nodeIdx) chainIdx Position.lastChainStep) := by + rw [eval_oneTimePublicKey] + simpa only [honestEndpoints_def] using + honestEndpoints_eq_table f parameter table lay tree (leafOfNat nodeIdx) hrealizes + intro input hinput + simp only [leafHash, queriedInputs_tweakableHash, List.mem_singleton] at hinput + subst input + rw [hendpoints] + have hinput : tweakableHashInput parameter (.leaf lay tree (leafOfNat nodeIdx)) + (leafPayload fun chainIdx => tableValue table + (.chain lay tree (leafOfNat nodeIdx) chainIdx Position.lastChainStep)) = + tableInput parameter table (.position (.leaf lay tree (leafOfNat nodeIdx))) := by + simp [tableInput, tablePayload, Position.children, Position.domain, leafPayload, + Function.comp_def] + rw [hinput] + exact mergedCache_tableInput_ne_none_of_ensured parameter table state cache + (.leaf lay tree (leafOfNat nodeIdx)) (by trivial) hleaf + +theorem treeNode_succ_input_eq_table + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → HashOutput) (lay : Layer) (tree : TreeIndex) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (level nodeIdx : Nat) (hlevel : level < maxLayerHeight) + (hspan : 2 ^ (level + 1) * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) : + tweakableHashInput parameter (.node lay tree (level + 1) nodeIdx) + (nodePayload + (evalWithAnswerFn f + (treeNode parameter lay tree (tableOtsSecret table lay tree) level (2 * nodeIdx))) + (evalWithAnswerFn f + (treeNode parameter lay tree (tableOtsSecret table lay tree) level + (2 * nodeIdx + 1)))) = + tableInput parameter table + (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) := by + have hnode : nodeIdx < 2 ^ maxLayerHeight := by + have hpow : 0 < 2 ^ (level + 1) := pow_pos (by omega) _ + nlinarith + have hpowTwo : 2 ≤ 2 ^ (level + 1) := by + simpa using Nat.pow_le_pow_right (n := 2) (by omega) (show 1 ≤ level + 1 by omega) + have hleft : 2 * nodeIdx < 2 ^ maxLayerHeight := by nlinarith + have hright : 2 * nodeIdx + 1 < 2 ^ maxLayerHeight := by nlinarith + change tweakableHashInput parameter (.node lay tree (level + 1) nodeIdx) + (nodePayload + (honestNode f parameter lay tree (tableOtsSecret table lay tree) level (2 * nodeIdx)) + (honestNode f parameter lay tree (tableOtsSecret table lay tree) level + (2 * nodeIdx + 1))) = _ + cases level with + | zero => + have hleftValue := honestNode_zero_eq_table f parameter table lay tree + (leafOfNat (2 * nodeIdx)) hrealizes + have hrightValue := honestNode_zero_eq_table f parameter table lay tree + (leafOfNat (2 * nodeIdx + 1)) hrealizes + have hleftIndex : (leafOfNat (2 * nodeIdx)).val = 2 * nodeIdx := by + simp [leafOfNat, Nat.mod_eq_of_lt hleft] + have hrightIndex : (leafOfNat (2 * nodeIdx + 1)).val = 2 * nodeIdx + 1 := by + simp [leafOfNat, Nat.mod_eq_of_lt hright] + rw [hleftIndex] at hleftValue + rw [hrightIndex] at hrightValue + rw [hleftValue, hrightValue] + simp only [tableInput, tablePayload, Position.domain] + rw [Position.children, dif_pos (by + simpa [leafOfNat, Nat.mod_eq_of_lt hnode] using hright), + dif_neg (show ¬0 < (⟨0, hlevel⟩ : Fin maxLayerHeight).val by simp)] + simp [nodePayload, leafOfNat, Nat.mod_eq_of_lt hnode, + Nat.mod_eq_of_lt hleft, Nat.mod_eq_of_lt hright] + | succ previous => + have hleftSpan : 2 ^ (previous + 1) * (2 * nodeIdx + 1) ≤ + 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith + have hrightSpan : 2 ^ (previous + 1) * (2 * nodeIdx + 1 + 1) ≤ + 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith + rw [honestNode_eq_table_succ f parameter table lay tree hrealizes previous + (2 * nodeIdx) (by omega) hleftSpan, + honestNode_eq_table_succ f parameter table lay tree hrealizes previous + (2 * nodeIdx + 1) (by omega) hrightSpan] + simp only [tableInput, tablePayload, Position.domain] + rw [Position.children, dif_pos (by + simpa [leafOfNat, Nat.mod_eq_of_lt hnode] using hright), + dif_pos (show 0 < (⟨previous + 1, hlevel⟩ : Fin maxLayerHeight).val by simp)] + simp [nodePayload, leafOfNat, Nat.mod_eq_of_lt hnode, + Nat.mod_eq_of_lt hleft, Nat.mod_eq_of_lt hright] + +set_option linter.unusedVariables false in +set_option linter.constructorNameAsVariable false in +theorem cachedRun_treeNode_of_mem_runRaw_ensureTreeNode + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → HashOutput) (lay : Layer) (tree : TreeIndex) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) : + ∀ level nodeIdx (hspan : 2 ^ level * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) + (state finalState targetState : LazyRevealProbe.State Coordinate) + (cache finalCache targetCache : SplitHashCache) (fuel remaining : Nat) (value : Unit), + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((ensureTreeNode lay tree level nodeIdx).run cache)) → + LazyRevealProbe.EnsuredLE finalState targetState → + CachedRun (mergedCache parameter table targetState.ensured targetCache) f + (treeNode parameter lay tree (tableOtsSecret table lay tree) level nodeIdx) + | 0, nodeIdx, _, state, finalState, targetState, cache, finalCache, targetCache, + fuel, remaining, value, hresult, htarget => by + have hensured := mem_runRaw_ensureOtsLeaf_mem lay tree (leafOfNat nodeIdx) state + finalState cache finalCache fuel remaining value hresult + exact cachedRun_treeNode_zero_of_ensuredOtsLeaf f parameter table targetState targetCache + lay tree nodeIdx hrealizes (fun chainIdx step => htarget (hensured.1 chainIdx step)) + (htarget hensured.2) + | level + 1, nodeIdx, hspan, state, finalState, targetState, cache, finalCache, + targetCache, fuel, remaining, value, hresult, htarget => by + have hpow : 2 ^ (level + 1) ≤ 2 ^ maxLayerHeight := calc + 2 ^ (level + 1) = 2 ^ (level + 1) * 1 := by simp + _ ≤ 2 ^ (level + 1) * (nodeIdx + 1) := + Nat.mul_le_mul_left _ (by omega) + _ ≤ 2 ^ maxLayerHeight := hspan + have hlevel : level < maxLayerHeight := by + have := (Nat.pow_le_pow_iff_right (by omega : 1 < 2)).mp hpow + omega + rw [ensureTreeNode, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨leftRaw, hleft, hafterLeft⟩ := hresult + cases leftRaw with + | stopped hit => simp at hafterLeft + | done leftState leftRemaining leftResult => + rcases leftResult with ⟨leftValue, leftCache⟩ + simp only at hafterLeft + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterLeft + obtain ⟨rightRaw, hright, hlast⟩ := hafterLeft + cases rightRaw with + | stopped hit => simp at hlast + | done rightState rightRemaining rightResult => + rcases rightResult with ⟨rightValue, rightCache⟩ + rw [dif_pos hlevel] at hlast + have hrightTarget : LazyRevealProbe.EnsuredLE rightState targetState := + (LazyRevealProbe.ensuredLE_of_mem_runRaw_done + ((ensureCoordinate (.position + (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx)))).run rightCache) + rightState finalState rightRemaining remaining (value, finalCache) hlast).trans + htarget + have hleftTarget : LazyRevealProbe.EnsuredLE leftState targetState := + (LazyRevealProbe.ensuredLE_of_mem_runRaw_done + ((ensureTreeNode lay tree level (2 * nodeIdx + 1)).run leftCache) + leftState rightState leftRemaining rightRemaining + (rightValue, rightCache) hright).trans hrightTarget + have hleftSpan : 2 ^ level * (2 * nodeIdx + 1) ≤ + 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith [Nat.zero_le (2 ^ level), Nat.zero_le nodeIdx] + have hrightSpan : 2 ^ level * (2 * nodeIdx + 1 + 1) ≤ + 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith [Nat.zero_le (2 ^ level), Nat.zero_le nodeIdx] + have hleftRun := cachedRun_treeNode_of_mem_runRaw_ensureTreeNode f parameter + table lay tree hrealizes level (2 * nodeIdx) hleftSpan state leftState + targetState cache leftCache targetCache fuel leftRemaining leftValue hleft + hleftTarget + have hrightRun := cachedRun_treeNode_of_mem_runRaw_ensureTreeNode f parameter + table lay tree hrealizes level (2 * nodeIdx + 1) hrightSpan leftState + rightState targetState leftCache rightCache targetCache leftRemaining + rightRemaining rightValue hright hrightTarget + rw [treeNode_succ_eq] + apply hleftRun.bind + apply hrightRun.bind + intro input hinput + simp only [queriedInputs_tweakableHash, List.mem_singleton] at hinput + subst input + rw [treeNode_succ_input_eq_table f parameter table lay tree hrealizes level + nodeIdx hlevel hspan] + exact mergedCache_tableInput_ne_none_of_ensured parameter table targetState + targetCache (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx)) (by trivial) + (htarget (mem_runRaw_ensureCoordinate_mem _ rightState finalState rightCache + finalCache rightRemaining remaining value hlast)) + +set_option maxRecDepth 10000 in +theorem cachedRun_treePath_of_mem_runRaw_ensureTreePath + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : Unit) + (targetState : LazyRevealProbe.State Coordinate) (targetCache : SplitHashCache) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((ensureTreePath lay tree leafIdx).run cache))) + (htarget : LazyRevealProbe.EnsuredLE finalState targetState) : + CachedRun (mergedCache parameter table targetState.ensured targetCache) f + (treePath parameter lay tree (tableOtsSecret table lay tree) leafIdx) := by + unfold ensureTreePath at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨sequenceRaw, hsequence, hfinish⟩ := hresult + cases sequenceRaw with + | stopped hit => simp at hfinish + | done sequenceState sequenceRemaining sequenceResult => + rcases sequenceResult with ⟨values, sequenceCache⟩ + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + unfold treePath + apply CachedRun.sequenceFin + intro level + by_cases hinLayer : level.val < layerHeight lay + · rw [if_pos hinLayer] + obtain ⟨componentState, componentFinalState, componentCache, + componentFinalCache, componentFuel, componentRemaining, componentValue, + hcomponent, _, _, hcomponentEnsured, _⟩ := + sequenceFin_component_run_of_done + (fun current : Fin maxLayerHeight => + if current.val < layerHeight lay then + ensureTreeNode lay tree current.val + (Nat.xor (leafIdx.val / 2 ^ current.val) 1) + else pure ()) + (fun current => by + split + · exact (splitCachePreserving_ensureTreeNode lay tree current.val + (Nat.xor (leafIdx.val / 2 ^ current.val) 1)).ordinaryCacheIncreasing + · exact OrdinaryCacheIncreasing.pure ()) + state finalState cache finalCache fuel remaining values hsequence level + rw [if_pos hinLayer] at hcomponent + have hspan := FtsProbeSimulation.sibling_node_bound maxLayerHeight leafIdx.val + level.val (by omega) leafIdx.isLt + exact cachedRun_treeNode_of_mem_runRaw_ensureTreeNode f parameter table lay tree + hrealizes level.val (Nat.xor (leafIdx.val / 2 ^ level.val) 1) hspan + componentState componentFinalState targetState componentCache componentFinalCache + targetCache componentFuel componentRemaining componentValue hcomponent + (hcomponentEnsured.trans htarget) + · rw [if_neg hinLayer] + exact CachedRun.pure _ _ _ + +theorem cachedRun_treeRoot_of_mem_runRaw_maskedTreeRoot + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → HashOutput) (lay : Layer) (tree : TreeIndex) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (state finalState targetState : LazyRevealProbe.State Coordinate) + (cache finalCache targetCache : SplitHashCache) (fuel remaining : Nat) + (value : Digest) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel ((maskedTreeRoot lay tree).run cache))) + (htarget : LazyRevealProbe.EnsuredLE finalState targetState) : + CachedRun (mergedCache parameter table targetState.ensured targetCache) f + (treeRoot parameter lay tree (tableOtsSecret table lay tree)) := by + have hpositive : 0 < layerHeight lay := by + unfold layerHeight + split <;> norm_num [maxLayerHeight] + have hlevel : layerHeight lay - 1 < maxLayerHeight := by + have hle := layerHeight_le lay + omega + have hlayer : layerHeight lay = layerHeight lay - 1 + 1 := by omega + unfold maskedTreeRoot at hresult + rw [hlayer, maskedTreeNode, dif_pos hlevel, StateT.run_bind, + LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨ensureRaw, hensure, hreveal⟩ := hresult + cases ensureRaw with + | stopped hit => simp at hreveal + | done ensureState ensureRemaining ensureResult => + rcases ensureResult with ⟨ensureValue, ensureCache⟩ + have hensuredTarget : LazyRevealProbe.EnsuredLE ensureState targetState := + (LazyRevealProbe.ensuredLE_of_mem_runRaw_done + ((revealPosition (.node lay tree ⟨layerHeight lay - 1, hlevel⟩ + (leafOfNat 0))).run ensureCache) ensureState finalState ensureRemaining remaining + (value, finalCache) hreveal).trans htarget + have hspan : 2 ^ (layerHeight lay - 1 + 1) * (0 + 1) ≤ + 2 ^ maxLayerHeight := by + rw [← hlayer] + simpa using Nat.pow_le_pow_right (n := 2) (by omega) (layerHeight_le lay) + unfold treeRoot + rw [hlayer] + exact cachedRun_treeNode_of_mem_runRaw_ensureTreeNode f parameter table lay tree + hrealizes (layerHeight lay - 1 + 1) 0 hspan state ensureState targetState cache + ensureCache targetCache fuel ensureRemaining ensureValue hensure hensuredTarget + +set_option maxRecDepth 10000 in +theorem cachedRun_signLayer_of_mem_runRaw_maskedSignLayer + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (counter : Counter) (encoding : ChainIndex → Digit) + (targetState : LazyRevealProbe.State Coordinate) (targetCache : SplitHashCache) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (some (counter, encoding), finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedSignLayer parameter ftsSecret index lay).run cache))) + (hensuredTarget : LazyRevealProbe.EnsuredLE finalState targetState) + (hcacheTarget : StableOrdinaryCacheLE parameter finalCache targetCache) : + CachedRun (mergedCache parameter table targetState.ensured targetCache) f + (signLayer (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + index lay) := by + unfold maskedSignLayer at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨messageRaw, hmessage, hafterMessage⟩ := hresult + cases messageRaw with + | stopped hit => simp at hafterMessage + | done messageState messageRemaining messageResult => + rcases messageResult with ⟨message, messageCache⟩ + simp only at hafterMessage + change LazyRevealProbe.RawResult.done finalState remaining + (some (counter, encoding), finalCache) ∈ support + (LazyRevealProbe.runRaw messageState messageRemaining + ((maskedOtsLayerAfterMessage parameter index lay message).run messageCache)) + at hafterMessage + have hmessageTarget := LazyRevealProbe.ensuredLE_of_mem_runRaw_done + ((maskedOtsLayerAfterMessage parameter index lay message).run messageCache) + messageState finalState messageRemaining remaining + (some (counter, encoding), finalCache) hafterMessage + have hmessageActual : message = evalWithAnswerFn f + (layerMessage + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) index lay) := by + by_cases hbelow : lay.val + 1 < numLayers + · let below : Layer := ⟨lay.val + 1, hbelow⟩ + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((maskedOtsLayerAfterMessage parameter index lay message).run messageCache) + messageState finalState messageRemaining remaining + (some (counter, encoding), finalCache) hafterMessage + exact maskedLayerMessage_eq_actual_of_lt + (f := f) (parameter := parameter) (root := root) (table := table) + (ftsSecret := ftsSecret) (index := index) (lay := lay) (below := below) + (hbelow := hbelow) (hbelowEq := rfl) (state := state) + (messageState := messageState) (referenceState := finalState) (cache := cache) + (messageCache := messageCache) (fuel := fuel) (messageRemaining := messageRemaining) + (message := message) hvaluesLE htable hrealizes hmessage + · have hordinaryLE := ordinaryCacheIncreasing_maskedSignLayerAfterMessage parameter + index lay message messageState messageCache messageRemaining finalState remaining + (some (counter, encoding)) finalCache hafterMessage + have hfMessage : StableCacheAgreesWithFn parameter messageCache f := + fun input output hstable hcached => hf input output hstable (hordinaryLE hcached) + exact maskedLayerMessage_eq_actual_of_not_lt f parameter root table ftsSecret index lay + hbelow state messageState cache messageCache fuel messageRemaining message hfMessage + hmessage + have hmessageRun : CachedRun + (mergedCache parameter table targetState.ensured targetCache) f + (layerMessage + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) index lay) := by + by_cases hbelow : lay.val + 1 < numLayers + · let below : Layer := ⟨lay.val + 1, hbelow⟩ + rw [layerMessage, dif_pos hbelow] + have hmessage' := hmessage + rw [maskedLayerMessage, dif_pos hbelow] at hmessage' + exact cachedRun_treeRoot_of_mem_runRaw_maskedTreeRoot f parameter table below + (treeIndexAt index below) hrealizes state messageState targetState cache messageCache + targetCache fuel messageRemaining message hmessage' + (hmessageTarget.trans hensuredTarget) + · rw [layerMessage, dif_neg hbelow] + have hmessage' := hmessage + rw [maskedLayerMessage, dif_neg hbelow] at hmessage' + have hordinaryLE := ordinaryCacheIncreasing_maskedSignLayerAfterMessage parameter + index lay message messageState messageCache messageRemaining finalState remaining + (some (counter, encoding)) finalCache hafterMessage + have hfMessage : StableCacheAgreesWithFn parameter messageCache f := + fun input output hstable hcached => hf input output hstable (hordinaryLE hcached) + have hreplay := replay_of_mem_runRaw_ordinaryHashImpl_of_stable f parameter + (ftsKey parameter index (ftsSecret index)) state messageState cache messageCache fuel + messageRemaining message hfMessage + (queriesStable_ftsKey f parameter index (ftsSecret index)) hmessage' + exact cachedRun_mergedCache_of_stable f parameter table targetState targetCache _ + (queriesStable_ftsKey f parameter index (ftsSecret index)) + (CachedRun.mono_stableOrdinary + (queriesStable_ftsKey f parameter index (ftsSecret index)) + ((StableOrdinaryCacheLE.of_le hordinaryLE).trans hcacheTarget) hreplay.2) + unfold maskedOtsLayerAfterMessage at hafterMessage + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hafterMessage + obtain ⟨otsRaw, hots, hafterOts⟩ := hafterMessage + cases otsRaw with + | stopped hit => simp at hafterOts + | done otsState otsRemaining otsResult => + rcases otsResult with ⟨part, otsCache⟩ + cases part with + | none => simp [LazyRevealProbe.runRaw] at hafterOts + | some selectedPart => + rcases selectedPart with ⟨selectedCounter, selectedEncoding⟩ + simp only at hafterOts + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterOts + obtain ⟨pathRaw, hpath, hfinish⟩ := hafterOts + cases pathRaw with + | stopped hit => simp at hfinish + | done pathState pathRemaining pathResult => + rcases pathResult with ⟨pathValue, pathCache⟩ + have hpathCache := splitCachePreserving_ensureTreePath lay + (treeIndexAt index lay) (leafIndexAt index lay) otsState otsCache + otsRemaining pathState pathRemaining pathValue pathCache hpath + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, hpart, rfl⟩ + rcases hpart with ⟨hcounter, hencoding⟩ + subst selectedCounter + subst selectedEncoding + have hfOts := hf + rw [hpathCache] at hfOts + have hpathEnsured := LazyRevealProbe.ensuredLE_of_mem_runRaw_done + ((ensureTreePath lay (treeIndexAt index lay) + (leafIndexAt index lay)).run otsCache) otsState finalState otsRemaining + remaining (pathValue, finalCache) hpath + have hotsCacheTarget : StableOrdinaryCacheLE parameter otsCache + targetCache := by + have hotsToFinal : ordinaryQueryCache otsCache ≤ + ordinaryQueryCache finalCache := by rw [hpathCache] + exact (StableOrdinaryCacheLE.of_le hotsToFinal).trans hcacheTarget + have hotsRun := + cachedRun_otsSignFrom_of_mem_runRaw_maskedOtsSignFrom f parameter lay table + (treeIndexAt index lay) (leafIndexAt index lay) message encodingAttemptLimit + 0 messageState otsState messageCache otsCache messageRemaining otsRemaining + counter encoding targetState targetCache hfOts hrealizes hots + (hpathEnsured.trans hensuredTarget) hotsCacheTarget + have hotsEval := maskedOtsSign_some_honest_eval f parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) + (tableOtsSecret table lay (treeIndexAt index lay) (leafIndexAt index lay)) + message messageState otsState messageCache otsCache messageRemaining + otsRemaining counter encoding hfOts hots + have hpathRun := cachedRun_treePath_of_mem_runRaw_ensureTreePath f parameter table + lay (treeIndexAt index lay) (leafIndexAt index lay) hrealizes otsState + finalState otsCache finalCache otsRemaining remaining pathValue targetState + targetCache hpath hensuredTarget + unfold signLayer + apply hmessageRun.bind + rw [← hmessageActual] + apply hotsRun.bind + unfold otsSign at hotsEval + rw [hotsEval] + apply hpathRun.bind + exact CachedRun.pure _ _ _ + +set_option maxRecDepth 10000 in +set_option linter.constructorNameAsVariable false in +theorem successfulSignRun_of_mem_runRaw_maskedSignAfterDigest + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (message : Message) (randomness : Randomness) (index : Index) + (leaves : DigestTree → FtsLeaf) (signature : Signature) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (targetState : LazyRevealProbe.State Coordinate) (targetCache : SplitHashCache) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hdigest : SuccessfulDigestRun f + (mergedCache parameter table targetState.ensured targetCache) + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + message randomness index leaves) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (some signature, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedSignAfterDigest parameter ftsSecret randomness index leaves).run cache))) + (hensuredTarget : LazyRevealProbe.EnsuredLE finalState targetState) + (hcacheTarget : StableOrdinaryCacheLE parameter finalCache targetCache) : + SuccessfulSignRun f (mergedCache parameter table targetState.ensured targetCache) + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + message signature := by + unfold maskedSignAfterDigest at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨pathRaw, hpath, hafterPath⟩ := hresult + cases pathRaw with + | stopped hit => simp at hafterPath + | done pathState pathRemaining pathResult => + rcases pathResult with ⟨ftsPath, pathCache⟩ + simp only at hafterPath + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hafterPath + obtain ⟨layersRaw, hlayers, hafterLayers⟩ := hafterPath + cases layersRaw with + | stopped hit => simp at hafterLayers + | done layersState layersRemaining layersResult => + rcases layersResult with ⟨layers, layersCache⟩ + rw [← maskedSignLayers_eq_sequenceFin parameter ftsSecret index] at hlayers + have hlayersLE := ordinaryCacheIncreasing_maskedSignLayers parameter ftsSecret index + pathState pathCache pathRemaining layersState layersRemaining layers layersCache hlayers + simp only at hafterLayers + cases hparts : traverseOption layers with + | none => + simp [hparts, LazyRevealProbe.runRaw] at hafterLayers + | some parts => + rw [hparts, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterLayers + obtain ⟨revealedRaw, hrevealed, hfinish⟩ := hafterLayers + cases revealedRaw with + | stopped hit => simp at hfinish + | done revealedState revealedRemaining revealedResult => + rcases revealedResult with ⟨revealed, revealedCache⟩ + have hrevealedLE := ordinaryCacheIncreasing_sequenceFin + (fun lay => revealLayerValues index lay (parts lay).2) + (fun lay => ordinaryCacheIncreasing_revealLayerValues index lay (parts lay).2) + layersState layersCache layersRemaining revealedState revealedRemaining + revealed revealedCache hrevealed + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((sequenceFin fun lay => revealLayerValues index lay (parts lay).2).run + layersCache) layersState revealedState layersRemaining revealedRemaining + (revealed, revealedCache) hrevealed + have hensuredLE := LazyRevealProbe.ensuredLE_of_mem_runRaw_done + ((sequenceFin fun lay => revealLayerValues index lay (parts lay).2).run + layersCache) layersState revealedState layersRemaining revealedRemaining + (revealed, revealedCache) hrevealed + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, hsignature, rfl⟩ + have hfPath : StableCacheAgreesWithFn parameter pathCache f := + fun input output hstable hcached => hf input output hstable + (hrevealedLE (hlayersLE hcached)) + have hftsReplay := replay_of_mem_runRaw_ordinaryHashImpl_of_stable f parameter + (ftsOpen parameter index leaves (ftsSecret index)) state pathState cache + pathCache fuel pathRemaining ftsPath hfPath + (queriesStable_ftsOpen f parameter index leaves (ftsSecret index)) hpath + have hftsRun := cachedRun_mergedCache_of_stable f parameter table targetState + targetCache _ (queriesStable_ftsOpen f parameter index leaves (ftsSecret index)) + (CachedRun.mono_stableOrdinary + (queriesStable_ftsOpen f parameter index leaves (ftsSecret index)) + ((StableOrdinaryCacheLE.of_le (hlayersLE.trans hrevealedLE)).trans + hcacheTarget) hftsReplay.2) + rw [hsignature] + refine ⟨index, leaves, + (fun lay => ((parts lay).1, (revealed lay).1, (revealed lay).2)), + hdigest, rfl, hftsReplay.1.symm, rfl, rfl, rfl, hftsRun, ?_, ?_⟩ + · intro lay + obtain ⟨componentState, componentFinalState, componentCache, + componentFinalCache, componentFuel, componentRemaining, part, hcomponent, + hselected, hcomponentValuesLE, hcomponentEnsuredLE, + hcomponentCacheLE⟩ := + maskedSignLayers_component_run parameter ftsSecret index pathState + layersState pathCache layersCache pathRemaining layersRemaining layers + hlayers lay + have hpartsAt := traverseOption_eq_some_apply layers parts hparts lay + have hpart : part = some (parts lay) := hselected.symm.trans hpartsAt + rw [hpart, maskedSignLayerAt_eq] at hcomponent + obtain ⟨revealState, revealFinalState, revealCache, revealFinalCache, + revealFuel, revealRemaining, revealValue, hrevealComponent, + hrevealSelected, hrevealValuesLE, _, _⟩ := + sequenceFin_component_run_of_done + (fun otherLay => revealLayerValues index otherLay (parts otherLay).2) + (fun otherLay => ordinaryCacheIncreasing_revealLayerValues index otherLay + (parts otherLay).2) layersState finalState layersCache finalCache + layersRemaining remaining revealed hrevealed lay + have hfComponent : StableCacheAgreesWithFn parameter componentFinalCache f := + fun input output hstable hcached => hf input output hstable + (hrevealedLE (hcomponentCacheLE hcached)) + have htableComponent : ∀ coordinate output, + componentFinalState.values coordinate = some output → + output = table coordinate := + fun coordinate output hvalue => htable coordinate output + (hvaluesLE coordinate output + (hcomponentValuesLE coordinate output hvalue)) + have htableReveal : ∀ coordinate output, + revealFinalState.values coordinate = some output → + output = table coordinate := + fun coordinate output hvalue => htable coordinate output + (hrevealValuesLE coordinate output hvalue) + change evalWithAnswerFn f + (signLayer + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + index lay) = + some ((parts lay).1, (revealed lay).1, (revealed lay).2) + rw [hrevealSelected] + exact maskedSignLayer_and_reveal_eval f parameter root table ftsSecret index lay + (parts lay).1 (parts lay).2 componentState componentFinalState componentCache + componentFinalCache componentFuel componentRemaining revealState + revealFinalState revealCache revealFinalCache revealFuel revealRemaining + revealValue hfComponent htableComponent htableReveal hrealizes hcomponent + hrevealComponent + · intro lay + obtain ⟨componentState, componentFinalState, componentCache, + componentFinalCache, componentFuel, componentRemaining, part, hcomponent, + hselected, hcomponentValuesLE, hcomponentEnsuredLE, + hcomponentCacheLE⟩ := + maskedSignLayers_component_run parameter ftsSecret index pathState + layersState pathCache layersCache pathRemaining layersRemaining layers + hlayers lay + have hpartsAt := traverseOption_eq_some_apply layers parts hparts lay + have hpart : part = some (parts lay) := hselected.symm.trans hpartsAt + rw [hpart, maskedSignLayerAt_eq] at hcomponent + have hfComponent : StableCacheAgreesWithFn parameter componentFinalCache f := + fun input output hstable hcached => hf input output hstable + (hrevealedLE (hcomponentCacheLE hcached)) + have htableComponent : ∀ coordinate output, + componentFinalState.values coordinate = some output → + output = table coordinate := + fun coordinate output hvalue => htable coordinate output + (hvaluesLE coordinate output (hcomponentValuesLE coordinate output hvalue)) + exact cachedRun_signLayer_of_mem_runRaw_maskedSignLayer f parameter root table + ftsSecret index lay componentState componentFinalState componentCache + componentFinalCache componentFuel componentRemaining (parts lay).1 + (parts lay).2 targetState targetCache hfComponent htableComponent hrealizes + hcomponent ((hcomponentEnsuredLE.trans hensuredLE).trans + hensuredTarget) + ((StableOrdinaryCacheLE.of_le + (hcomponentCacheLE.trans hrevealedLE)).trans hcacheTarget) + +set_option maxRecDepth 10000 in +theorem successfulSignRun_of_mem_runRaw_maskedSign + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (message : Message) (signature : Signature) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (targetState : LazyRevealProbe.State Coordinate) (targetCache : SplitHashCache) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (some signature, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedSign parameter root ftsSecret message).run cache))) + (hensuredTarget : LazyRevealProbe.EnsuredLE finalState targetState) + (hcacheTarget : StableOrdinaryCacheLE parameter finalCache targetCache) : + SuccessfulSignRun f (mergedCache parameter table targetState.ensured targetCache) + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + message signature := by + let secretKey : SecretKey := + ⟨parameter, root, tableOtsSecret table, ftsSecret⟩ + let digestSecretKey : SecretKey := + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ + unfold maskedSign at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨loopRaw, hloop, hrest⟩ := hresult + cases loopRaw with + | stopped hit => simp at hrest + | done loopState loopRemaining loopResult => + rcases loopResult with ⟨selected, loopCache⟩ + simp only at hrest + cases selected with + | none => simp [LazyRevealProbe.runRaw] at hrest + | some selected => + obtain ⟨randomness, index, leaves⟩ := selected + have hcacheLE := ordinaryCacheIncreasing_maskedSignAfterDigest parameter ftsSecret + randomness index leaves loopState loopCache loopRemaining finalState remaining + (some signature) finalCache hrest + have hdigestLoop := successfulDigestLoop_of_mem_runRaw_ordinaryRomImpl f + digestSecretKey message digestAttemptLimit randomness index leaves state loopState + cache loopCache fuel loopRemaining finalCache hcacheLE hf hloop + have hdigest : SuccessfulDigestRun f (ordinaryQueryCache finalCache) secretKey message + randomness index leaves := by + simpa only [SuccessfulDigestRun, signAttempt, digestSecretKey, secretKey] using + hdigestLoop + have hdigestMerged : SuccessfulDigestRun f + (mergedCache parameter table targetState.ensured targetCache) secretKey message + randomness index leaves := + ⟨hdigest.1, hdigest.2.1, + cachedRun_mergedCache_of_stable f parameter table targetState targetCache _ + (queriesStable_signAttempt f secretKey message randomness) + (CachedRun.mono_stableOrdinary + (queriesStable_signAttempt f secretKey message randomness) hcacheTarget + hdigest.2.2)⟩ + exact successfulSignRun_of_mem_runRaw_maskedSignAfterDigest f parameter root table + ftsSecret message randomness index leaves signature loopState finalState loopCache + finalCache loopRemaining remaining targetState targetCache hf htable hrealizes (by + simpa only [secretKey] using hdigestMerged) hrest hensuredTarget hcacheTarget + +set_option maxRecDepth 10000 in +theorem successfulSignRuns_signingTraceComputation + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (value : alpha) (signingLog : QueryLog SigningSpec) + (targetState : LazyRevealProbe.State Coordinate) (targetCache : SplitHashCache) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + ((value, signingLog), finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation computation)).run cache))) + (hensuredTarget : LazyRevealProbe.EnsuredLE finalState targetState) + (hcacheTarget : StableOrdinaryCacheLE parameter finalCache targetCache) : + ∀ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), entry ∈ signingLog → entry.2 = some signature → + SuccessfulSignRun f (mergedCache parameter table targetState.ensured targetCache) + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + entry.1 signature := by + induction computation using OracleComp.inductionOn generalizing signingLog state cache fuel with + | pure result => + simp [signingTraceComputation, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, hvalue, rfl⟩ + rcases hvalue with ⟨rfl, rfl⟩ + intro entry signature hentry + simp at hentry + | query_bind input next ih => + rw [signingTraceComputation_query_bind, simulateQ_bind, simulateQ_spec_query, + StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨queryRaw, hquery, hrest⟩ := hresult + cases queryRaw with + | stopped hit => simp at hrest + | done queryState queryRemaining queryResult => + rcases queryResult with ⟨output, queryCache⟩ + simp only at hrest + rw [map_eq_bind_pure_comp, simulateQ_bind, StateT.run_bind, + LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hrest + obtain ⟨tailRaw, htail, hfinish⟩ := hrest + cases tailRaw with + | stopped hit => simp at hfinish + | done tailState tailRemaining tailResult => + rcases tailResult with ⟨⟨tailValue, tailLog⟩, tailCache⟩ + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, houtputs, rfl⟩ + rcases houtputs with ⟨rfl, rfl⟩ + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation (next output))).run queryCache) + queryState finalState queryRemaining remaining + ((value, tailLog), finalCache) htail + have hensuredLE := LazyRevealProbe.ensuredLE_of_mem_runRaw_done + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation (next output))).run queryCache) + queryState finalState queryRemaining remaining + ((value, tailLog), finalCache) htail + have hstableCacheLE : StableOrdinaryCacheLE parameter queryCache finalCache := by + intro stableInput cached hstable hcached + exact ((ordinaryEntryPreservingImpl_maskedExpandedAdversaryImpl parameter root + ftsSecret stableInput hstable).simulateQ + (signingTraceComputation (next output))) queryState queryCache queryRemaining + finalState remaining (value, tailLog) finalCache cached hcached htail + have htableQuery : ∀ coordinate cached, + queryState.values coordinate = some cached → cached = table coordinate := + fun coordinate cached hcached => + htable coordinate cached (hvaluesLE coordinate cached hcached) + have hfQuery : StableCacheAgreesWithFn parameter queryCache f := + StableCacheAgreesWithFn.of_run + (fun stableInput hstable => + (ordinaryEntryPreservingImpl_maskedExpandedAdversaryImpl parameter root + ftsSecret stableInput hstable).simulateQ + (signingTraceComputation (next output))) + queryState finalState queryCache finalCache queryRemaining remaining + (value, tailLog) hf htail + intro entry signature hentry hsignature + simp only [List.mem_append] at hentry + rcases hentry with hfragment | htailEntry + · cases input with + | inl oracleQuery => simp [signingLogFragment] at hfragment + | inr message => + have hentryEq : entry = ⟨message, output⟩ := by + simpa [signingLogFragment] using hfragment + subst entry + change LazyRevealProbe.RawResult.done queryState queryRemaining + (output, queryCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedSign parameter root ftsSecret message).run cache)) at hquery + change output = some signature at hsignature + subst output + exact successfulSignRun_of_mem_runRaw_maskedSign f parameter root table + ftsSecret message signature state queryState cache queryCache fuel + queryRemaining targetState targetCache hfQuery htableQuery hrealizes hquery + (hensuredLE.trans hensuredTarget) + (hstableCacheLE.trans hcacheTarget) + · exact ih output queryState queryCache queryRemaining tailLog htail entry signature + htailEntry hsignature + +set_option maxRecDepth 10000 in +theorem successfulSignRuns_retainedGameRestComputation + (adversary : Adversary) (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (root : Digest) (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (forgery : Forgery) (signingLog : QueryLog SigningSpec) (verified : Bool) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (((forgery, signingLog), verified), finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).run cache))) : + ∀ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), entry ∈ signingLog → entry.2 = some signature → + SuccessfulSignRun f (mergedCache parameter table finalState.ensured finalCache) + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + entry.1 signature := by + rw [simulateQ_maskedExpanded_retainedGameRestComputation, StateT.run_bind, + LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨prefixRaw, hprefix, hrest⟩ := hresult + cases prefixRaw with + | stopped hit => simp at hrest + | done prefixState prefixRemaining prefixResult => + rcases prefixResult with ⟨⟨prefixForgery, prefixLog⟩, prefixCache⟩ + simp only at hrest + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hrest + obtain ⟨verifyRaw, hverify, hfinish⟩ := hrest + cases verifyRaw with + | stopped hit => simp at hfinish + | done verifyState verifyRemaining verifyResult => + rcases verifyResult with ⟨prefixVerified, verifyCache⟩ + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, houtputs, rfl⟩ + rcases houtputs with ⟨hprefixOutput, rfl⟩ + rcases hprefixOutput with ⟨rfl, rfl⟩ + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).run + prefixCache) prefixState finalState prefixRemaining remaining + (verified, finalCache) hverify + have hensuredLE := LazyRevealProbe.ensuredLE_of_mem_runRaw_done + ((simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).run + prefixCache) prefixState finalState prefixRemaining remaining + (verified, finalCache) hverify + have hstableCacheLE : StableOrdinaryCacheLE parameter prefixCache finalCache := by + intro input output hstable hcached + exact ((ordinaryEntryPreservingImpl_probingRomImpl parameter input hstable).simulateQ + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)) prefixState + prefixCache prefixRemaining finalState remaining verified finalCache output hcached + hverify + have htablePrefix : ∀ coordinate output, + prefixState.values coordinate = some output → output = table coordinate := + fun coordinate output hcached => + htable coordinate output (hvaluesLE coordinate output hcached) + have hfPrefix : StableCacheAgreesWithFn parameter prefixCache f := + StableCacheAgreesWithFn.of_run + (fun input hstable => + (ordinaryEntryPreservingImpl_probingRomImpl parameter input hstable).simulateQ + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)) + prefixState finalState prefixCache finalCache prefixRemaining remaining verified hf + hverify + exact successfulSignRuns_signingTraceComputation f parameter root table ftsSecret + (adversary.main ⟨root, parameter⟩) state prefixState cache prefixCache fuel + prefixRemaining forgery signingLog finalState finalCache hfPrefix htablePrefix + hrealizes hprefix hensuredLE hstableCacheLE + +set_option maxRecDepth 10000 in +set_option linter.constructorNameAsVariable false in +theorem successfulSignRuns_maskedRetainedGameAfterFtsSecrets + (adversary : Adversary) (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel remaining : Nat) (finalState : LazyRevealProbe.State Coordinate) + (finalCache : SplitHashCache) (root : Digest) (forgery : Forgery) + (signingLog : QueryLog SigningSpec) (verified : Bool) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + ((root, ((forgery, signingLog), verified)), finalCache) ∈ support + (LazyRevealProbe.runRaw (LazyRevealProbe.State.empty : + LazyRevealProbe.State Coordinate) fuel + ((maskedRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) : + ∀ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), entry ∈ signingLog → entry.2 = some signature → + SuccessfulSignRun f (mergedCache parameter table finalState.ensured finalCache) + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + entry.1 signature := by + unfold maskedRetainedGameAfterFtsSecrets at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨rootRaw, hroot, hafterRoot⟩ := hresult + cases rootRaw with + | stopped hit => simp at hafterRoot + | done rootState rootRemaining rootResult => + rcases rootResult with ⟨sampledRoot, rootCache⟩ + simp only at hafterRoot + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hafterRoot + obtain ⟨publishRaw, hpublish, hafterPublish⟩ := hafterRoot + cases publishRaw with + | stopped hit => simp at hafterPublish + | done publishState publishRemaining publishResult => + rcases publishResult with ⟨publishedUnit, publishCache⟩ + simp only at hafterPublish + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hafterPublish + obtain ⟨restRaw, hrest, hfinish⟩ := hafterPublish + cases restRaw with + | stopped hit => simp at hfinish + | done restState restRemaining restResult => + rcases restResult with ⟨⟨prefixForgery, prefixLog⟩, restCache⟩ + simp only at hfinish + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hfinish + obtain ⟨verifyRaw, hverify, hreturn⟩ := hfinish + cases verifyRaw with + | stopped hit => simp at hreturn + | done verifyState verifyRemaining verifyResult => + rcases verifyResult with ⟨prefixVerified, verifyCache⟩ + simp [LazyRevealProbe.runRaw] at hreturn + rcases hreturn with ⟨rfl, rfl, houtput, rfl⟩ + rcases houtput with ⟨hrootEq, hrestEq, rfl⟩ + rcases hrestEq with ⟨rfl, rfl⟩ + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((simulateQ (verifierRomImpl parameter) + (scheme.verify ⟨sampledRoot, parameter⟩ forgery.message + forgery.signature)).run restCache) + restState finalState restRemaining remaining (verified, finalCache) hverify + have hensuredLE := LazyRevealProbe.ensuredLE_of_mem_runRaw_done + ((simulateQ (verifierRomImpl parameter) + (scheme.verify ⟨sampledRoot, parameter⟩ forgery.message + forgery.signature)).run restCache) + restState finalState restRemaining remaining (verified, finalCache) hverify + have hstableCacheLE : StableOrdinaryCacheLE parameter restCache finalCache := by + intro input output _ hcached + exact (ordinaryEntryPreservingImpl_verifierRomImpl parameter input).simulateQ + (scheme.verify ⟨sampledRoot, parameter⟩ forgery.message + forgery.signature) restState restCache restRemaining finalState remaining + verified finalCache output hcached hverify + have htableRest : ∀ coordinate output, + restState.values coordinate = some output → output = table coordinate := + fun coordinate output hcached => + htable coordinate output (hvaluesLE coordinate output hcached) + have hfRest : StableCacheAgreesWithFn parameter restCache f := + StableCacheAgreesWithFn.of_run + (fun input _ => + (ordinaryEntryPreservingImpl_verifierRomImpl parameter input).simulateQ + (scheme.verify ⟨sampledRoot, parameter⟩ forgery.message + forgery.signature)) + restState finalState restCache finalCache restRemaining remaining verified hf + hverify + have hruns := successfulSignRuns_signingTraceComputation f parameter sampledRoot + table ftsSecret (adversary.main ⟨sampledRoot, parameter⟩) publishState restState + publishCache restCache publishRemaining restRemaining forgery signingLog + finalState finalCache hfRest htableRest hrealizes hrest hensuredLE + hstableCacheLE + simpa only [hrootEq] using hruns + +set_option maxRecDepth 10000 in +set_option linter.constructorNameAsVariable false in +theorem chainInvariant_maskedRetainedGameAfterFtsSecrets_mergedCache + (adversary : Adversary) (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel remaining : Nat) (finalState : LazyRevealProbe.State Coordinate) + (finalCache : SplitHashCache) (root : Digest) (forgery : Forgery) + (signingLog : QueryLog SigningSpec) (verified : Bool) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + ((root, ((forgery, signingLog), verified)), finalCache) ∈ support + (LazyRevealProbe.runRaw (LazyRevealProbe.State.empty : + LazyRevealProbe.State Coordinate) fuel + ((maskedRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) : + ∃ verifierState verifierFuel verifierCache, + ChainInvariant parameter + (CoveredChainCoordinate f + (mergedCache parameter table finalState.ensured finalCache) + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) signingLog) + verifierState verifierCache ∧ + LazyRevealProbe.RawResult.done finalState remaining (verified, finalCache) ∈ support + (LazyRevealProbe.runRaw verifierState verifierFuel + ((simulateQ (verifierRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).run + verifierCache)) := by + exact chainInvariant_maskedRetainedGameAfterFtsSecrets adversary f parameter table ftsSecret + (mergedCache parameter table finalState.ensured finalCache) fuel remaining finalState + finalCache root forgery signingLog verified + (successfulSignRuns_maskedRetainedGameAfterFtsSecrets adversary f parameter table + ftsSecret fuel remaining finalState finalCache root forgery signingLog verified hf + htable hrealizes hresult) hf htable hrealizes hresult + +theorem revealPositionValues_makes_values + (table : Coordinate → HashOutput) (positions : List Position) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (values : List Digest) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (values, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((revealPositionValues positions).run cache))) : + ∀ position, position ∈ positions → + finalState.values (.position position) = some (table (.position position)) := by + induction positions generalizing state cache fuel values with + | nil => simp + | cons position positions ih => + rw [revealPositionValues, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨headRaw, hhead, hrest⟩ := hresult + cases headRaw with + | stopped hit => simp at hrest + | done headState headRemaining headResult => + rcases headResult with ⟨headValue, headCache⟩ + simp only at hrest + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hrest + obtain ⟨tailRaw, htail, hfinish⟩ := hrest + cases tailRaw with + | stopped hit => simp at hfinish + | done tailState tailRemaining tailResult => + rcases tailResult with ⟨tailValues, tailCache⟩ + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((revealPositionValues positions).run headCache) + headState tailState headRemaining tailRemaining (tailValues, tailCache) htail + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨hstate, hfuel, hvalues, hcache⟩ + subst finalState + subst remaining + subst values + subst finalCache + intro other hmem + simp only [List.mem_cons] at hmem + rcases hmem with heq | hmem + · subst other + obtain ⟨output, _, hvalue⟩ := mem_runRaw_revealCoordinate_value + (.position position) state headState cache headCache fuel headRemaining headValue + (by simpa [revealPosition] using hhead) + rw [hvaluesLE _ _ hvalue, htable _ output (hvaluesLE _ _ hvalue)] + · exact ih headState headCache headRemaining tailValues htail other hmem + +theorem revealTableInputChildren_makes_available + (table : Coordinate → HashOutput) (position : Position) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : Unit) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((revealTableInputChildren (.position position)).run cache))) : + TableInputAvailable table finalState (.position position) := by + cases position with + | chain lay tree leafIdx chainIdx step => + by_cases hzero : step.val = 0 + · simp only [revealTableInputChildren, hzero, ↓reduceIte] at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hreveal, hfinish⟩ := hresult + cases raw with + | stopped hit => simp at hfinish + | done revealState revealRemaining revealResult => + rcases revealResult with ⟨revealed, revealCache⟩ + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + obtain ⟨output, _, hvalue⟩ := mem_runRaw_revealCoordinate_value + (.chainStart lay tree leafIdx chainIdx) state finalState cache finalCache fuel + remaining revealed (by simpa [revealChainStart] using hreveal) + simp only [TableInputAvailable, hzero, ↓reduceIte] + rw [hvalue, htable _ output hvalue] + · simp only [revealTableInputChildren, hzero, ↓reduceIte] at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hvalues, hfinish⟩ := hresult + cases raw with + | stopped hit => simp at hfinish + | done valuesState valuesRemaining valuesResult => + rcases valuesResult with ⟨values, valuesCache⟩ + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + simpa only [TableInputAvailable, hzero, ↓reduceIte] using + revealPositionValues_makes_values table + (Position.chain lay tree leafIdx chainIdx step).children state finalState cache + finalCache fuel remaining values htable hvalues + | leaf lay tree leafIdx => + simp only [revealTableInputChildren] at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hvalues, hfinish⟩ := hresult + cases raw with + | stopped hit => simp at hfinish + | done valuesState valuesRemaining valuesResult => + rcases valuesResult with ⟨values, valuesCache⟩ + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + exact revealPositionValues_makes_values table _ state finalState cache finalCache fuel + remaining values htable hvalues + | node lay tree level nodeIdx => + simp only [revealTableInputChildren] at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hvalues, hfinish⟩ := hresult + cases raw with + | stopped hit => simp at hfinish + | done valuesState valuesRemaining valuesResult => + rcases valuesResult with ⟨values, valuesCache⟩ + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + exact revealPositionValues_makes_values table _ state finalState cache finalCache fuel + remaining values htable hvalues + | ftsLeaf index tree leafIdx => + simp only [revealTableInputChildren] at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hvalues, hfinish⟩ := hresult + cases raw with + | stopped hit => simp at hfinish + | done valuesState valuesRemaining valuesResult => + rcases valuesResult with ⟨values, valuesCache⟩ + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + exact revealPositionValues_makes_values table _ state finalState cache finalCache fuel + remaining values htable hvalues + | ftsNode index tree level nodeIdx => + simp only [revealTableInputChildren] at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hvalues, hfinish⟩ := hresult + cases raw with + | stopped hit => simp at hfinish + | done valuesState valuesRemaining valuesResult => + rcases valuesResult with ⟨values, valuesCache⟩ + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + exact revealPositionValues_makes_values table _ state finalState cache finalCache fuel + remaining values htable hvalues + | ftsRoots index => + simp only [revealTableInputChildren] at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hvalues, hfinish⟩ := hresult + cases raw with + | stopped hit => simp at hfinish + | done valuesState valuesRemaining valuesResult => + rcases valuesResult with ⟨values, valuesCache⟩ + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + exact revealPositionValues_makes_values table _ state finalState cache finalCache fuel + remaining values htable hvalues + +theorem resolveKnownInput_returns_table_of_available + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (coordinate : Coordinate) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : HashOutput) + (havailable : TableInputAvailable table state coordinate) + (htable : ∀ other cached, finalState.values other = some cached → + cached = table other) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((resolveKnownInput parameter coordinate + (tableInput parameter table coordinate)).run cache))) : + output = table coordinate ∧ + finalCache (.ordinary (tableInput parameter table coordinate)) = some output := by + have hcached := returnsCachedOrdinary_resolveKnownInput parameter coordinate + (tableInput parameter table coordinate) state cache fuel finalState remaining output + finalCache hresult + unfold resolveKnownInput at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + runRaw_peekTableInput_of_available parameter table state cache fuel coordinate havailable] + at hresult + simp only [pure_bind, ↓reduceIte] at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨revealRaw, hreveal, hrest⟩ := hresult + cases revealRaw with + | stopped hit => simp at hrest + | done revealState revealRemaining revealResult => + rcases revealResult with ⟨revealed, revealCache⟩ + have hrevealed := mem_runRaw_revealCoordinateOutput_value coordinate state revealState + cache revealCache fuel revealRemaining revealed hreveal + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + (((publishCoordinate coordinate >>= fun _ => do + modify fun workingCache : SplitHashCache => + Function.update workingCache + (.ordinary (tableInput parameter table coordinate)) (some revealed) + pure revealed).run revealCache)) + revealState finalState revealRemaining remaining (output, finalCache) hrest + have hfinalValue := hvaluesLE coordinate revealed hrevealed.1 + have hrevealedTable := htable coordinate revealed hfinalValue + have houtput : output = revealed := by + simp [publishCoordinate, LazyRevealProbe.publishQuery, + StateT.run_modify, LazyRevealProbe.runRaw] at hrest + exact congrArg Prod.fst (LazyRevealProbe.RawResult.done.inj hrest).2.2 + exact ⟨houtput.trans hrevealedTable, hcached⟩ + +theorem resolveVerifierInput_returns_table_of_uncached + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (position : Position) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : HashOutput) + (huncached : cache (.ordinary + (tableInput parameter table (.position position))) = none) + (htable : ∀ coordinate cached, finalState.values coordinate = some cached → + cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((resolveVerifierInput parameter (.position position) + (tableInput parameter table (.position position))).run cache))) : + output = table (.position position) ∧ + finalCache (.ordinary (tableInput parameter table (.position position))) = some output := by + unfold resolveVerifierInput at hresult + simp [StateT.run_get, huncached] at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨revealRaw, hreveal, hresolve⟩ := hresult + cases revealRaw with + | stopped hit => simp at hresolve + | done revealState revealRemaining revealResult => + rcases revealResult with ⟨revealed, revealCache⟩ + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((resolveKnownInput parameter (.position position) + (tableInput parameter table (.position position))).run revealCache) + revealState finalState revealRemaining remaining (output, finalCache) hresolve + have htableReveal : ∀ coordinate cached, + revealState.values coordinate = some cached → cached = table coordinate := + fun coordinate cached hcached => + htable coordinate cached (hvaluesLE coordinate cached hcached) + have havailable := revealTableInputChildren_makes_available table position state revealState + cache revealCache fuel revealRemaining revealed htableReveal hreveal + exact resolveKnownInput_returns_table_of_available parameter table (.position position) + revealState finalState revealCache finalCache revealRemaining remaining output havailable + htable hresolve + +theorem resolveVerifierInput_makes_available_of_uncached + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (position : Position) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : HashOutput) + (huncached : cache (.ordinary + (tableInput parameter table (.position position))) = none) + (htable : ∀ coordinate cached, finalState.values coordinate = some cached → + cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((resolveVerifierInput parameter (.position position) + (tableInput parameter table (.position position))).run cache))) : + TableInputAvailable table finalState (.position position) := by + unfold resolveVerifierInput at hresult + simp [StateT.run_get, huncached] at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨revealRaw, hreveal, hresolve⟩ := hresult + cases revealRaw with + | stopped hit => simp at hresolve + | done revealState revealRemaining revealResult => + rcases revealResult with ⟨revealed, revealCache⟩ + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((resolveKnownInput parameter (.position position) + (tableInput parameter table (.position position))).run revealCache) + revealState finalState revealRemaining remaining (output, finalCache) hresolve + have htableReveal : ∀ coordinate cached, + revealState.values coordinate = some cached → cached = table coordinate := + fun coordinate cached hcached => + htable coordinate cached (hvaluesLE coordinate cached hcached) + exact (revealTableInputChildren_makes_available table position state revealState cache + revealCache fuel revealRemaining revealed htableReveal hreveal).monoValues hvaluesLE + +theorem resolveVerifierInput_makes_available_of_uncached_input + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (position : Position) (input : HashInput) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : HashOutput) + (huncached : cache (.ordinary input) = none) + (htable : ∀ coordinate cached, finalState.values coordinate = some cached → + cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((resolveVerifierInput parameter (.position position) input).run cache))) : + TableInputAvailable table finalState (.position position) := by + unfold resolveVerifierInput at hresult + simp [StateT.run_get, huncached] at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨revealRaw, hreveal, hresolve⟩ := hresult + cases revealRaw with + | stopped hit => simp at hresolve + | done revealState revealRemaining revealResult => + rcases revealResult with ⟨revealed, revealCache⟩ + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((resolveKnownInput parameter (.position position) input).run revealCache) + revealState finalState revealRemaining remaining (output, finalCache) hresolve + have htableReveal : ∀ coordinate cached, + revealState.values coordinate = some cached → cached = table coordinate := + fun coordinate cached hcached => + htable coordinate cached (hvaluesLE coordinate cached hcached) + exact (revealTableInputChildren_makes_available table position state revealState cache + revealCache fuel revealRemaining revealed htableReveal hreveal).monoValues hvaluesLE + +theorem Probe.outputCoordinate_eq_position_of_matchesInput + (parameter : PublicParameter) (probe : Probe) (input : HashInput) + (position : Position) (hmatches : probe.MatchesInput parameter input) + (hposition : AtPosition parameter input position) : + probe.outputCoordinate = .position position := by + have hat : ∃ outputPosition, + probe.outputCoordinate = .position outputPosition ∧ + AtPosition parameter input outputPosition := by + rcases probe with ⟨coordinate, candidate⟩ + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + obtain ⟨step, hzero, hinput⟩ := hmatches + let first : ChainStep := ⟨0, by norm_num [chainLength, winternitzBits]⟩ + have hstep : step = first := Fin.ext hzero + subst step + exact ⟨.chain lay tree leafIdx chainIdx first, rfl, + ⟨digestBytes candidate, hinput⟩⟩ + | position source => + cases source with + | chain lay tree leafIdx chainIdx step => + simp only [Probe.MatchesInput] at hmatches + by_cases hnext : step.val + 1 < chainLength - 1 + · rw [dif_pos hnext] at hmatches + obtain ⟨nextStep, hnextValue, hinput⟩ := hmatches + have hstep : nextStep = ⟨step.val + 1, hnext⟩ := Fin.ext hnextValue + subst nextStep + exact ⟨.chain lay tree leafIdx chainIdx ⟨step.val + 1, hnext⟩, + by simp [Probe.outputCoordinate, hnext], ⟨digestBytes candidate, hinput⟩⟩ + · rw [dif_neg hnext] at hmatches + obtain ⟨_, payload, hinput, _⟩ := hmatches + exact ⟨.leaf lay tree leafIdx, + by simp [Probe.outputCoordinate, hnext], ⟨payload, hinput⟩⟩ + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp [Probe.MatchesInput] at hmatches + obtain ⟨outputPosition, houtput, hatOutput⟩ := hat + rw [houtput] + exact congrArg Coordinate.position (atPosition_unique parameter hatOutput hposition) + +theorem Probe.outputCoordinate_eq_position_of_matchesInput' + (probe : Probe) (parameter : PublicParameter) (input : HashInput) + (hmatches : probe.MatchesInput parameter input) : + ∃ position : Position, probe.outputCoordinate = .position position := by + rcases probe with ⟨coordinate, candidate⟩ + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact ⟨.chain lay tree leafIdx chainIdx + ⟨0, by norm_num [chainLength, winternitzBits]⟩, rfl⟩ + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + by_cases hnext : step.val + 1 < chainLength - 1 + · exact ⟨.chain lay tree leafIdx chainIdx ⟨step.val + 1, hnext⟩, + by simp [Probe.outputCoordinate, hnext]⟩ + · exact ⟨.leaf lay tree leafIdx, by simp [Probe.outputCoordinate, hnext]⟩ + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp [Probe.MatchesInput] at hmatches + +theorem Probe.value_eq_table_of_output_available + (table : Coordinate → HashOutput) (probe : Probe) (parameter : PublicParameter) + (input : HashInput) (state : LazyRevealProbe.State Coordinate) + (hmatches : probe.MatchesInput parameter input) + (havailable : TableInputAvailable table state probe.outputCoordinate) : + state.values probe.coordinate = some (table probe.coordinate) := by + rcases probe with ⟨coordinate, candidate⟩ + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [Probe.outputCoordinate, TableInputAvailable] at havailable + exact havailable + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + simp only [Probe.outputCoordinate] at havailable ⊢ + by_cases hnext : step.val + 1 < chainLength - 1 + · rw [dif_pos hnext] at havailable + have hnonzero : (⟨step.val + 1, hnext⟩ : ChainStep).val ≠ 0 := by + change step.val + 1 ≠ 0 + omega + simp only [TableInputAvailable, if_neg hnonzero] at havailable + apply havailable (.chain lay tree leafIdx chainIdx step) + rw [Position.mem_children_iff, Position.parentOf, dif_pos hnext] + · rw [dif_neg hnext] at havailable + simp only [TableInputAvailable] at havailable + apply havailable (.chain lay tree leafIdx chainIdx step) + rw [Position.mem_children_iff, Position.parentOf, dif_neg hnext] + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp [Probe.MatchesInput] at hmatches + +theorem verifierHashQuery_not_done_of_fresh_correct_probe_of_opaque + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (probe : Probe) (input : HashInput) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : HashOutput) + (hmatches : probe.MatchesInput parameter input) + (hcandidate : probe.candidate = truncateHash (table probe.coordinate)) + (hvalue : state.values probe.coordinate = none) + (hnotRevealed : probe.coordinate ∉ state.revealed) + (huncached : cache (.ordinary input) = none) + (htable : ∀ coordinate cached, finalState.values coordinate = some cached → + cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((verifierHashQuery parameter input).run cache))) : False := by + cases hdecode : decodeProbe? parameter input with + | none => exact ((decodeProbe?_eq_none_iff parameter input).1 hdecode probe hmatches).elim + | some candidate => + have hcandidateMatches := (decodeProbe?_eq_some_iff parameter input candidate).1 hdecode + have heq := Probe.matchesInput_unique parameter input hcandidateMatches hmatches + subst candidate + unfold verifierHashQuery at hresult + rw [hdecode, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨probeRaw, hprobe, hresolve⟩ := hresult + cases probeRaw with + | stopped hit => simp at hresolve + | done probeState probeRemaining probeResult => + rcases probeResult with ⟨probed, probeCache⟩ + change LazyRevealProbe.RawResult.done probeState probeRemaining + (probed, probeCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.probeQuery probe.coordinate probe.candidate >>= fun result => + pure (result, cache))) at hprobe + rw [LazyRevealProbe.probeQuery, + LazyRevealProbe.runRaw_probe_query_bind] at hprobe + cases fuel with + | zero => simp at hprobe + | succ remainingFuel => + simp only at hprobe + rw [if_neg hnotRevealed] at hprobe + simp [LazyRevealProbe.runRaw] at hprobe + rcases hprobe with ⟨rfl, rfl, rfl, rfl⟩ + obtain ⟨position, houtputPosition⟩ := + probe.outputCoordinate_eq_position_of_matchesInput' parameter input hmatches + rw [houtputPosition] at hresolve + have havailable := resolveVerifierInput_makes_available_of_uncached_input parameter + table position input (state.addPending probe.coordinate probe.candidate) finalState + cache finalCache probeRemaining remaining output huncached htable hresolve + rw [← houtputPosition] at havailable + have hsourceValue := probe.value_eq_table_of_output_available table parameter input + finalState hmatches havailable + have hhit : (state.addPending probe.coordinate probe.candidate).hitAt + probe.coordinate (table probe.coordinate) := by + rw [LazyRevealProbe.State.hitAt, ← hcandidate] + exact LazyRevealProbe.State.pendingAt_addPending_self state probe.coordinate + probe.candidate + have hpersist := LazyRevealProbe.pendingHit_preserved_of_mem_runRaw_done + ((resolveVerifierInput parameter probe.outputCoordinate input).run cache) + probe.coordinate (table probe.coordinate) + (state.addPending probe.coordinate probe.candidate) finalState probeRemaining + remaining (output, finalCache) hvalue hhit (htable probe.coordinate) (by + simpa only [houtputPosition] using hresolve) + rw [hpersist.1] at hsourceValue + simp at hsourceValue + +theorem verifierHashQuery_not_done_of_fresh_correct_probe + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (allowed : Coordinate → Prop) (probe : Probe) (input : HashInput) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : HashOutput) + (hvalid : ChainState.ValidFor allowed state) + (hmatches : probe.MatchesInput parameter input) + (hcandidate : probe.candidate = truncateHash (table probe.coordinate)) + (hnotAllowed : ¬allowed probe.coordinate) + (huncached : cache (.ordinary input) = none) + (htable : ∀ coordinate cached, finalState.values coordinate = some cached → + cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((verifierHashQuery parameter input).run cache))) : False := by + have hchain := probe.isChainCoordinate_of_matchesInput hmatches + exact verifierHashQuery_not_done_of_fresh_correct_probe_of_opaque parameter table probe + input state finalState cache finalCache fuel remaining output hmatches hcandidate + (hvalid.value_eq_none_of_not_allowed hchain hnotAllowed) + (hvalid.not_revealed_of_not_allowed hchain hnotAllowed) huncached htable hresult + +theorem simulateQ_verifierHashImpl_tweakableHash_not_done_of_fresh_correct_probe_of_opaque + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (probe : Probe) + (domain : HashDomain) (payload : HashInput) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : Digest) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter domain payload)) + (hcandidate : probe.candidate = truncateHash (table probe.coordinate)) + (hvalue : state.values probe.coordinate = none) + (hnotRevealed : probe.coordinate ∉ state.revealed) + (huncached : cache (.ordinary + (tweakableHashInput parameter domain payload)) = none) + (htable : ∀ coordinate cached, finalState.values coordinate = some cached → + cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ (verifierHashImpl parameter) + (tweakableHash parameter domain payload)).run cache))) : False := by + unfold tweakableHash oracleHash at hresult + rw [simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨queryRaw, hquery, hrest⟩ := hresult + cases queryRaw with + | stopped hit => simp at hrest + | done queryState queryRemaining queryResult => + rcases queryResult with ⟨answer, queryCache⟩ + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((pure (truncateHash answer) : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Digest).run queryCache) + queryState finalState queryRemaining remaining (output, finalCache) hrest + have htableQuery : ∀ coordinate cached, + queryState.values coordinate = some cached → cached = table coordinate := + fun coordinate cached hcached => + htable coordinate cached (hvaluesLE coordinate cached hcached) + have hquery' : LazyRevealProbe.RawResult.done queryState queryRemaining + (answer, queryCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((verifierHashQuery parameter + (tweakableHashInput parameter domain payload)).run cache)) := by + simpa only [HasQuery.instOfMonadLift_query, simulateQ_spec_query, + verifierHashImpl] using hquery + exact verifierHashQuery_not_done_of_fresh_correct_probe_of_opaque parameter table probe + (tweakableHashInput parameter domain payload) state queryState cache queryCache fuel + queryRemaining answer hmatches hcandidate hvalue hnotRevealed huncached htableQuery hquery' + +theorem simulateQ_verifierHashImpl_tweakableHash_not_done_of_fresh_correct_probe + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (allowed : Coordinate → Prop) (probe : Probe) + (domain : HashDomain) (payload : HashInput) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : Digest) + (hvalid : ChainState.ValidFor allowed state) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter domain payload)) + (hcandidate : probe.candidate = truncateHash (table probe.coordinate)) + (hnotAllowed : ¬allowed probe.coordinate) + (huncached : cache (.ordinary + (tweakableHashInput parameter domain payload)) = none) + (htable : ∀ coordinate cached, finalState.values coordinate = some cached → + cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ (verifierHashImpl parameter) + (tweakableHash parameter domain payload)).run cache))) : False := by + have hchain := probe.isChainCoordinate_of_matchesInput hmatches + exact simulateQ_verifierHashImpl_tweakableHash_not_done_of_fresh_correct_probe_of_opaque + parameter table probe domain payload state finalState cache finalCache fuel remaining output + hmatches hcandidate (hvalid.value_eq_none_of_not_allowed hchain hnotAllowed) + (hvalid.not_revealed_of_not_allowed hchain hnotAllowed) huncached htable hresult + +theorem simulateQ_verifierHashImpl_chainWalk_not_done_of_fresh_correct_probe_of_opaque + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (probe : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (start steps : Nat) (initialValue : Digest) + (hpositive : 0 < steps) (hrange : start + steps ≤ chainLength - 1) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : Digest) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx ⟨start, by omega⟩) (digestBytes initialValue))) + (hcandidate : probe.candidate = truncateHash (table probe.coordinate)) + (hvalue : state.values probe.coordinate = none) + (hnotRevealed : probe.coordinate ∉ state.revealed) + (huncached : cache (.ordinary + (tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx ⟨start, by omega⟩) + (digestBytes initialValue))) = none) + (htable : ∀ coordinate cached, finalState.values coordinate = some cached → + cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ (verifierHashImpl parameter) + (chainWalk parameter lay tree leafIdx chainIdx start steps initialValue)).run cache))) : + False := by + induction steps generalizing state finalState cache finalCache fuel remaining output with + | zero => omega + | succ steps ih => + cases steps with + | zero => + have hstep : start < chainLength - 1 := by omega + rw [chainWalk, chainWalk, pure_bind, Nat.add_zero, dif_pos hstep] at hresult + exact simulateQ_verifierHashImpl_tweakableHash_not_done_of_fresh_correct_probe_of_opaque + parameter table probe + (.chain lay tree leafIdx chainIdx ⟨start, hstep⟩) + (digestBytes initialValue) state finalState cache finalCache fuel remaining + output (by simpa only using hmatches) hcandidate hvalue hnotRevealed (by + simpa only using huncached) htable hresult + | succ previous => + rw [chainWalk, simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨prefixRaw, hprefix, hrest⟩ := hresult + cases prefixRaw with + | stopped hit => simp at hrest + | done prefixState prefixRemaining prefixResult => + rcases prefixResult with ⟨prefixValue, prefixCache⟩ + simp only at hrest + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done _ prefixState + finalState prefixRemaining remaining (output, finalCache) hrest + have htablePrefix : ∀ coordinate cached, + prefixState.values coordinate = some cached → cached = table coordinate := + fun coordinate cached hcached => + htable coordinate cached (hvaluesLE coordinate cached hcached) + exact ih (by omega) (by omega) state prefixState cache prefixCache fuel + prefixRemaining prefixValue hmatches hvalue hnotRevealed huncached htablePrefix + hprefix + +theorem simulateQ_verifierHashImpl_chainWalk_not_done_of_fresh_correct_probe + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (allowed : Coordinate → Prop) (probe : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (start steps : Nat) (initialValue : Digest) + (hpositive : 0 < steps) (hrange : start + steps ≤ chainLength - 1) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : Digest) + (hvalid : ChainState.ValidFor allowed state) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx ⟨start, by omega⟩) (digestBytes initialValue))) + (hcandidate : probe.candidate = truncateHash (table probe.coordinate)) + (hnotAllowed : ¬allowed probe.coordinate) + (huncached : cache (.ordinary + (tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx ⟨start, by omega⟩) + (digestBytes initialValue))) = none) + (htable : ∀ coordinate cached, finalState.values coordinate = some cached → + cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ (verifierHashImpl parameter) + (chainWalk parameter lay tree leafIdx chainIdx start steps initialValue)).run cache))) : + False := by + have hchain := probe.isChainCoordinate_of_matchesInput hmatches + exact simulateQ_verifierHashImpl_chainWalk_not_done_of_fresh_correct_probe_of_opaque + parameter table probe lay tree leafIdx chainIdx start steps initialValue hpositive hrange state + finalState cache finalCache fuel remaining output hmatches hcandidate + (hvalid.value_eq_none_of_not_allowed hchain hnotAllowed) + (hvalid.not_revealed_of_not_allowed hchain hnotAllowed) huncached htable hresult + +def PreservesCoordinate (coordinate : Coordinate) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ state cache fuel finalState remaining value finalCache, + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + finalState.values coordinate = state.values coordinate ∧ + (coordinate ∈ finalState.revealed ↔ coordinate ∈ state.revealed) + +theorem PreservesCoordinate.bind + {coordinate : Coordinate} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : PreservesCoordinate coordinate left) + (hnext : ∀ value, PreservesCoordinate coordinate (next value)) : + PreservesCoordinate coordinate (left >>= next) := by + intro state cache fuel finalState remaining result finalCache hresult + change LazyRevealProbe.RawResult.done finalState remaining (result, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun leftResult => (next leftResult.1).run leftResult.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining leftResult => + rcases leftResult with ⟨leftValue, middleCache⟩ + have hmiddle := hleft state cache fuel middleState middleRemaining leftValue middleCache hraw + have hfinal := hnext leftValue middleState middleCache middleRemaining finalState remaining + result finalCache hrest + exact ⟨hfinal.1.trans hmiddle.1, hfinal.2.trans hmiddle.2⟩ + +theorem preservesCoordinate_pure (coordinate : Coordinate) (value : alpha) : + PreservesCoordinate coordinate + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro state cache fuel finalState remaining result finalCache hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨rfl, Iff.rfl⟩ + +theorem preservesCoordinate_splitHashQuery (coordinate : Coordinate) (key : SplitHashKey) : + PreservesCoordinate coordinate (splitHashQuery key) := by + intro state cache fuel finalState remaining value finalCache hresult + rw [splitHashQuery_run_eq] at hresult + cases hlookup : cache key with + | some output => + rw [hlookup] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨rfl, Iff.rfl⟩ + | none => + rw [hlookup] at hresult + dsimp only at hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.hashOutputQuery >>= fun output => + pure (output, Function.update cache key (some output)))) at hresult + rw [LazyRevealProbe.hashOutputQuery, LazyRevealProbe.runRaw_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _, hdone⟩ := hresult + simp [LazyRevealProbe.runRaw] at hdone + rcases hdone with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨rfl, Iff.rfl⟩ + +theorem preservesCoordinate_probe (coordinate : Coordinate) (candidate : Probe) : + PreservesCoordinate coordinate (probe candidate) := by + intro state cache fuel finalState remaining value finalCache hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate >>= fun output => + pure (output, cache))) at hresult + rw [LazyRevealProbe.probeQuery, LazyRevealProbe.runRaw_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remainingFuel => + simp only at hresult + by_cases hrevealed : candidate.coordinate ∈ state.revealed + · rw [if_pos hrevealed] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨rfl, Iff.rfl⟩ + · rw [if_neg hrevealed] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + simp [LazyRevealProbe.State.addPending] + +theorem preservesCoordinate_revealCoordinateOutput_of_ne + (coordinate other : Coordinate) (hne : coordinate ≠ other) : + PreservesCoordinate coordinate (revealCoordinateOutput other) := by + intro state cache fuel finalState remaining value finalCache hresult + rw [revealCoordinateOutput_run, LazyRevealProbe.revealQuery, + LazyRevealProbe.runRaw_reveal_query_bind] at hresult + cases hvalue : state.values other with + | some output => + rw [hvalue] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨rfl, Iff.rfl⟩ + | none => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨output, _, hrest⟩ := hresult + by_cases hhit : state.hitAt other output + · rw [if_pos hhit] at hrest + simp at hrest + · rw [if_neg hhit] at hrest + simp [LazyRevealProbe.runRaw] at hrest + rcases hrest with ⟨rfl, rfl, rfl, rfl⟩ + simp [LazyRevealProbe.State.materialize, Function.update, hne] + +theorem preservesCoordinate_publishCoordinate_of_ne + (coordinate other : Coordinate) (hne : coordinate ≠ other) : + PreservesCoordinate coordinate (publishCoordinate other) := by + intro state cache fuel finalState remaining value finalCache hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.publishQuery other >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.publishQuery, LazyRevealProbe.runRaw_publish_query_bind] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + simp [LazyRevealProbe.State.publish, hne] + +theorem preservesCoordinate_revealCoordinate_of_ne + (coordinate other : Coordinate) (hne : coordinate ≠ other) : + PreservesCoordinate coordinate (revealCoordinate other) := by + unfold revealCoordinate + exact (preservesCoordinate_revealCoordinateOutput_of_ne coordinate other hne).bind fun _ => + preservesCoordinate_pure coordinate _ + +theorem preservesCoordinate_revealPosition_of_ne + (coordinate : Coordinate) (position : Position) + (hne : coordinate ≠ .position position) : + PreservesCoordinate coordinate (revealPosition position) := by + simpa only [revealPosition] using + preservesCoordinate_revealCoordinate_of_ne coordinate (.position position) hne + +theorem preservesCoordinate_revealPositionValues + (coordinate : Coordinate) (positions : List Position) + (hne : ∀ position, position ∈ positions → coordinate ≠ .position position) : + PreservesCoordinate coordinate (revealPositionValues positions) := by + induction positions with + | nil => exact preservesCoordinate_pure coordinate [] + | cons position remaining ih => + rw [revealPositionValues] + exact (preservesCoordinate_revealPosition_of_ne coordinate position + (hne position (by simp))).bind fun value => + (ih (fun other hother => hne other (by simp [hother]))).bind fun values => + preservesCoordinate_pure coordinate (value :: values) + +theorem RawReadOnly.preservesCoordinate + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + (hreadonly : RawReadOnly computation) (coordinate : Coordinate) : + PreservesCoordinate coordinate computation := by + intro state cache fuel finalState remaining value finalCache hresult + obtain ⟨rfl, _, _⟩ := hreadonly state cache fuel finalState remaining value finalCache hresult + exact ⟨rfl, Iff.rfl⟩ + +def PublishedValues (state : LazyRevealProbe.State Coordinate) : Prop := + ∀ coordinate, coordinate ∈ state.revealed → state.values coordinate ≠ none + +def PreservesPublishedValues + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ state cache fuel finalState remaining value finalCache, + PublishedValues state → + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + PublishedValues finalState + +theorem PreservesPublishedValues.pure (value : alpha) : + PreservesPublishedValues + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro state cache fuel finalState remaining result finalCache hpublished hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hpublished + +theorem PreservesPublishedValues.bind + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : PreservesPublishedValues left) + (hnext : ∀ value, PreservesPublishedValues (next value)) : + PreservesPublishedValues (left >>= next) := by + intro state cache fuel finalState remaining value finalCache hpublished hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun result => (next result.1).run result.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining middleResult => + rcases middleResult with ⟨middleValue, middleCache⟩ + exact hnext middleValue middleState middleCache middleRemaining finalState remaining value + finalCache (hleft state cache fuel middleState middleRemaining middleValue middleCache + hpublished hraw) hrest + +theorem PreservesPublishedValues.sequenceFin {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hcomputation : ∀ index, PreservesPublishedValues (computation index)) : + PreservesPublishedValues (sequenceFin computation) := by + induction n with + | zero => exact PreservesPublishedValues.pure Fin.elim0 + | succ n ih => + rw [SphincsSecurity.Concrete.sequenceFin] + exact (hcomputation 0).bind fun _ => + (ih (fun index => computation index.succ) + (fun index => hcomputation index.succ)).bind fun _ => + PreservesPublishedValues.pure _ + +def PreservesPublishedValuesImpl {spec : OracleSpec ι} + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) : Prop := + ∀ query, PreservesPublishedValues (impl query) + +theorem PreservesPublishedValuesImpl.simulateQ {spec : OracleSpec ι} + {impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))} + (himpl : PreservesPublishedValuesImpl impl) + (computation : OracleComp spec alpha) : + PreservesPublishedValues (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => exact PreservesPublishedValues.pure value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (himpl query).bind ih + +theorem PreservesPublishedValues.of_preservesCoordinate + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + (hpreserves : ∀ coordinate, PreservesCoordinate coordinate computation) : + PreservesPublishedValues computation := by + intro state cache fuel finalState remaining value finalCache hpublished hresult coordinate + hrevealed + have hcoordinate := hpreserves coordinate state cache fuel finalState remaining value finalCache + hresult + rw [hcoordinate.1] + exact hpublished coordinate (hcoordinate.2.1 hrevealed) + +theorem RawReadOnly.preservesPublishedValues + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + (hreadonly : RawReadOnly computation) : PreservesPublishedValues computation := + PreservesPublishedValues.of_preservesCoordinate hreadonly.preservesCoordinate + +theorem preservesPublishedValues_ensureCoordinate (coordinate : Coordinate) : + PreservesPublishedValues (ensureCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hpublished hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.ensureQuery coordinate >>= fun result => pure (result, cache))) at hresult + rw [LazyRevealProbe.ensureQuery, LazyRevealProbe.runRaw_ensure_query_bind] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + simpa [PublishedValues, LazyRevealProbe.State.ensure] using hpublished + +theorem preservesPublishedValues_simulateQ_ordinaryHashImpl + (computation : OracleComp HashSpec alpha) : + PreservesPublishedValues (simulateQ ordinaryHashImpl computation) := by + intro state cache fuel finalState remaining value finalCache hpublished hresult + rw [(mem_runRaw_simulateQ_ordinaryHashImpl_projects computation state finalState cache + finalCache fuel remaining value hresult).1] + exact hpublished + +theorem preservesPublishedValues_simulateQ_splitUniformImpl + (computation : ProbComp alpha) : + PreservesPublishedValues (simulateQ splitUniformImpl computation) := by + intro state cache fuel finalState remaining value finalCache hpublished hresult + rw [(mem_runRaw_simulateQ_splitUniformImpl_projects computation state finalState cache + finalCache fuel remaining value hresult).1] + exact hpublished + +theorem preservesPublishedValues_revealCoordinateOutput (coordinate : Coordinate) : + PreservesPublishedValues (revealCoordinateOutput coordinate) := by + intro state cache fuel finalState remaining value finalCache hpublished hresult + rw [revealCoordinateOutput_run, LazyRevealProbe.revealQuery, + LazyRevealProbe.runRaw_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + rw [hvalue] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hpublished + | none => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨output, _, hrest⟩ := hresult + by_cases hhit : state.hitAt coordinate output + · rw [if_pos hhit] at hrest + simp at hrest + · rw [if_neg hhit] at hrest + simp [LazyRevealProbe.runRaw] at hrest + rcases hrest with ⟨rfl, rfl, rfl, rfl⟩ + intro other hrevealed + have hvalueOther := hpublished other (by + simpa [LazyRevealProbe.State.materialize] using hrevealed) + by_cases heq : other = coordinate + · subst other + simp [LazyRevealProbe.State.materialize] + · simpa [LazyRevealProbe.State.materialize, Function.update, heq] using hvalueOther + +theorem preservesPublishedValues_revealCoordinate (coordinate : Coordinate) : + PreservesPublishedValues (revealCoordinate coordinate) := by + unfold revealCoordinate + exact (preservesPublishedValues_revealCoordinateOutput coordinate).bind fun _ => + PreservesPublishedValues.pure _ + +theorem preservesPublishedValues_revealPublishedCoordinate (coordinate : Coordinate) : + PreservesPublishedValues (revealPublishedCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hpublished hresult + unfold revealPublishedCoordinate at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨revealRaw, hreveal, hrest⟩ := hresult + cases revealRaw with + | stopped hit => simp at hrest + | done revealState revealRemaining revealResult => + rcases revealResult with ⟨revealedValue, revealCache⟩ + have hpublishedReveal := preservesPublishedValues_revealCoordinate coordinate state cache + fuel revealState revealRemaining revealedValue revealCache hpublished hreveal + obtain ⟨coordinateOutput, _, hcoordinateValue⟩ := + mem_runRaw_revealCoordinate_value coordinate state revealState cache revealCache fuel + revealRemaining revealedValue hreveal + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw revealState revealRemaining + ((publishCoordinate coordinate).run revealCache >>= fun publishResult => + (pure revealedValue : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Digest).run publishResult.2)) at hrest + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hrest + obtain ⟨publishRaw, hpublish, hreturn⟩ := hrest + cases publishRaw with + | stopped hit => simp at hreturn + | done publishState publishRemaining publishResult => + rcases publishResult with ⟨publishedUnit, publishCache⟩ + change LazyRevealProbe.RawResult.done publishState publishRemaining + (publishedUnit, publishCache) ∈ support + (LazyRevealProbe.runRaw revealState revealRemaining + (LazyRevealProbe.publishQuery coordinate >>= fun result => + pure (result, revealCache))) at hpublish + rw [LazyRevealProbe.publishQuery, LazyRevealProbe.runRaw_publish_query_bind] at hpublish + simp [LazyRevealProbe.runRaw] at hpublish + rcases hpublish with ⟨rfl, rfl, rfl, rfl⟩ + simp [LazyRevealProbe.runRaw] at hreturn + rcases hreturn with ⟨rfl, rfl, rfl, rfl⟩ + intro other hother + by_cases heq : other = coordinate + · subst other + change revealState.values coordinate ≠ none + rw [hcoordinateValue] + simp + · apply hpublishedReveal other + simpa [LazyRevealProbe.State.publish, heq] using hother + +theorem publishedValues_of_mem_runRaw_publishCoordinate + (coordinate : Coordinate) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : Unit) + (hpublished : PublishedValues state) + (hvalue : state.values coordinate ≠ none) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel ((publishCoordinate coordinate).run cache))) : + PublishedValues finalState := by + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.publishQuery coordinate >>= fun result => pure (result, cache))) at hresult + rw [LazyRevealProbe.publishQuery, LazyRevealProbe.runRaw_publish_query_bind] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + intro other hother + by_cases heq : other = coordinate + · subst other + change state.values coordinate ≠ none + exact hvalue + · apply hpublished other + simpa [LazyRevealProbe.State.publish, heq] using hother + +theorem preservesCoordinate_get (coordinate : Coordinate) : + PreservesCoordinate coordinate + (get : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) SplitHashCache) := by + intro state cache fuel finalState remaining value finalCache hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨rfl, Iff.rfl⟩ + +theorem preservesCoordinate_modify (coordinate : Coordinate) + (update : SplitHashCache → SplitHashCache) : + PreservesCoordinate coordinate + (modify update : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit) := by + intro state cache fuel finalState remaining value finalCache hresult + simp [StateT.run_modify, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨rfl, Iff.rfl⟩ + +theorem preservesCoordinate_resolveKnownInput_of_ne + (parameter : PublicParameter) (coordinate other : Coordinate) (input : HashInput) + (hne : coordinate ≠ other) : + PreservesCoordinate coordinate (resolveKnownInput parameter other input) := by + unfold resolveKnownInput + exact (rawReadOnly_peekTableInput parameter other).preservesCoordinate coordinate |>.bind + fun known => match known with + | none => preservesCoordinate_splitHashQuery coordinate (.ordinary input) + | some knownInput => by + simp only + by_cases heq : knownInput = input + · rw [if_pos heq] + exact (preservesCoordinate_revealCoordinateOutput_of_ne coordinate other hne).bind + fun _ => (preservesCoordinate_publishCoordinate_of_ne coordinate other hne).bind + fun _ => (preservesCoordinate_modify coordinate fun cache => + Function.update cache (.ordinary input) (some _)).bind fun _ => + preservesCoordinate_pure coordinate _ + · rw [if_neg heq] + exact preservesCoordinate_splitHashQuery coordinate (.ordinary input) + +theorem preservesPublishedValues_revealCoordinateOutput_publish (coordinate : Coordinate) : + PreservesPublishedValues (do + let output ← revealCoordinateOutput coordinate + publishCoordinate coordinate + pure output) := by + intro state cache fuel finalState remaining value finalCache hpublished hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨revealRaw, hreveal, hrest⟩ := hresult + cases revealRaw with + | stopped hit => simp at hrest + | done revealState revealRemaining revealResult => + rcases revealResult with ⟨revealedOutput, revealCache⟩ + have hpublishedReveal := preservesPublishedValues_revealCoordinateOutput coordinate state + cache fuel revealState revealRemaining revealedOutput revealCache hpublished hreveal + have hcoordinateValue := (mem_runRaw_revealCoordinateOutput_value coordinate state + revealState cache revealCache fuel revealRemaining revealedOutput hreveal).1 + simp [publishCoordinate, LazyRevealProbe.publishQuery, + LazyRevealProbe.runRaw] at hrest + rcases hrest with ⟨rfl, rfl, rfl, rfl⟩ + intro other hother + by_cases heq : other = coordinate + · subst other + change revealState.values coordinate ≠ none + rw [hcoordinateValue] + simp + · apply hpublishedReveal other + simpa [LazyRevealProbe.State.publish, heq] using hother + +theorem preservesPublishedValues_resolveKnownInput + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) : + PreservesPublishedValues (resolveKnownInput parameter coordinate input) := by + unfold resolveKnownInput + exact (rawReadOnly_peekTableInput parameter coordinate).preservesPublishedValues.bind + fun known => match known with + | none => PreservesPublishedValues.of_preservesCoordinate fun other => + preservesCoordinate_splitHashQuery other (.ordinary input) + | some knownInput => by + simp only + by_cases heq : knownInput = input + · rw [if_pos heq] + have hpreserves := + (preservesPublishedValues_revealCoordinateOutput_publish coordinate).bind + fun output => + (PreservesPublishedValues.of_preservesCoordinate fun other => + preservesCoordinate_modify other fun cache => + Function.update cache (.ordinary input) (some output)).bind fun _ => + PreservesPublishedValues.pure output + simpa only [bind_assoc, pure_bind] using hpreserves + · rw [if_neg heq] + exact PreservesPublishedValues.of_preservesCoordinate fun other => + preservesCoordinate_splitHashQuery other (.ordinary input) + +theorem preservesPublishedValues_probeFirstMissingInputCoordinate (input : HashInput) : + ∀ slot coordinates, + PreservesPublishedValues (probeFirstMissingInputCoordinate input slot coordinates) + | _, [] => PreservesPublishedValues.pure () + | slot, coordinate :: remaining => by + rw [probeFirstMissingInputCoordinate] + exact (rawReadOnly_peekCoordinate coordinate).preservesPublishedValues.bind fun value => + match value with + | none => PreservesPublishedValues.of_preservesCoordinate fun other => + preservesCoordinate_probe other ⟨coordinate, slotDigest slot input⟩ + | some _ => preservesPublishedValues_probeFirstMissingInputCoordinate input + (slot + 1) remaining + +theorem preservesPublishedValues_prepareLeafInputProbe + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + PreservesPublishedValues (prepareLeafInputProbe input candidate lay tree leafIdx) := by + unfold prepareLeafInputProbe + apply (rawReadOnly_peekCoordinate candidate.coordinate).preservesPublishedValues.bind + intro value + cases value with + | none => + simp only + exact PreservesPublishedValues.of_preservesCoordinate fun coordinate => + preservesCoordinate_probe coordinate candidate + | some output => + simp only + exact preservesPublishedValues_probeFirstMissingInputCoordinate input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + +theorem preservesPublishedValues_probingHashQuery + (parameter : PublicParameter) (input : HashInput) : + PreservesPublishedValues (probingHashQuery parameter input) := by + unfold probingHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases decodePosition? parameter input with + | some position => + cases position with + | leaf lay tree leafIdx => + exact (preservesPublishedValues_prepareLeafInputProbe input candidate lay tree + leafIdx).bind fun _ => preservesPublishedValues_resolveKnownInput parameter + candidate.outputCoordinate input + | chain | node | ftsLeaf | ftsNode | ftsRoots => + exact (PreservesPublishedValues.of_preservesCoordinate fun coordinate => + preservesCoordinate_probe coordinate candidate).bind fun _ => + preservesPublishedValues_resolveKnownInput parameter + candidate.outputCoordinate input + | none => exact (PreservesPublishedValues.of_preservesCoordinate fun coordinate => + preservesCoordinate_probe coordinate candidate).bind fun _ => + preservesPublishedValues_resolveKnownInput parameter candidate.outputCoordinate input + | none => + cases hposition : decodePosition? parameter input with + | none => exact PreservesPublishedValues.of_preservesCoordinate fun coordinate => + preservesCoordinate_splitHashQuery coordinate (.ordinary input) + | some position => + cases position with + | chain | leaf => exact preservesPublishedValues_resolveKnownInput parameter _ input + | node lay tree level nodeIdx => + exact (preservesPublishedValues_probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)).bind + fun _ => preservesPublishedValues_resolveKnownInput parameter _ input + | ftsLeaf | ftsNode | ftsRoots => + exact PreservesPublishedValues.of_preservesCoordinate fun coordinate => + preservesCoordinate_splitHashQuery coordinate (.ordinary input) + +theorem preservesPublishedValues_ensureFullChain + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + PreservesPublishedValues (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (PreservesPublishedValues.sequenceFin _ fun step => + preservesPublishedValues_ensureCoordinate + (.position (.chain lay tree leafIdx chainIdx step))).bind fun _ => + PreservesPublishedValues.pure () + +theorem preservesPublishedValues_ensureChainPrefix + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (digit : Digit) : + PreservesPublishedValues (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (PreservesPublishedValues.sequenceFin _ fun step => by + split + · exact preservesPublishedValues_ensureCoordinate + (.position (.chain lay tree leafIdx chainIdx step)) + · exact PreservesPublishedValues.pure ()).bind fun _ => + PreservesPublishedValues.pure () + +theorem preservesPublishedValues_ensureOtsLeaf + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + PreservesPublishedValues (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (PreservesPublishedValues.sequenceFin _ fun chainIdx => + preservesPublishedValues_ensureFullChain lay tree leafIdx chainIdx).bind fun _ => + preservesPublishedValues_ensureCoordinate (.position (.leaf lay tree leafIdx)) + +theorem preservesPublishedValues_ensureTreeNode (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, PreservesPublishedValues (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => by + rw [ensureTreeNode] + exact preservesPublishedValues_ensureOtsLeaf lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (preservesPublishedValues_ensureTreeNode lay tree level (2 * nodeIdx)).bind fun _ => + (preservesPublishedValues_ensureTreeNode lay tree level (2 * nodeIdx + 1)).bind fun _ => by + split + · exact preservesPublishedValues_ensureCoordinate _ + · exact PreservesPublishedValues.pure () + +theorem preservesPublishedValues_maskedTreeNode + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) : + PreservesPublishedValues (maskedTreeNode lay tree level nodeIdx) := by + cases level with + | zero => + rw [maskedTreeNode] + exact (preservesPublishedValues_ensureTreeNode lay tree 0 nodeIdx).bind fun _ => + preservesPublishedValues_revealCoordinate _ + | succ current => + rw [maskedTreeNode] + exact (preservesPublishedValues_ensureTreeNode lay tree (current + 1) nodeIdx).bind fun _ => by + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact preservesPublishedValues_revealCoordinate _ + · rw [dif_neg hlevel] + exact PreservesPublishedValues.pure 0 + +theorem preservesPublishedValues_maskedTreeRoot (lay : Layer) (tree : TreeIndex) : + PreservesPublishedValues (maskedTreeRoot lay tree) := + preservesPublishedValues_maskedTreeNode lay tree (layerHeight lay) 0 + +theorem preservesPublishedValues_ensureTreePath + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + PreservesPublishedValues (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (PreservesPublishedValues.sequenceFin _ fun level => by + split + · exact preservesPublishedValues_ensureTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · exact PreservesPublishedValues.pure ()).bind fun _ => + PreservesPublishedValues.pure () + +theorem preservesPublishedValues_revealPositionValues : + ∀ positions, PreservesPublishedValues (revealPositionValues positions) + | [] => PreservesPublishedValues.pure [] + | position :: remaining => by + rw [revealPositionValues] + exact (preservesPublishedValues_revealCoordinate (.position position)).bind fun value => + (preservesPublishedValues_revealPositionValues remaining).bind fun values => + PreservesPublishedValues.pure (value :: values) + +theorem preservesPublishedValues_revealTableInputChildren (coordinate : Coordinate) : + PreservesPublishedValues (revealTableInputChildren coordinate) := by + cases coordinate with + | chainStart => exact PreservesPublishedValues.pure () + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + by_cases hzero : step.val = 0 + · simp only [revealTableInputChildren, hzero, ↓reduceIte] + exact (preservesPublishedValues_revealCoordinate + (.chainStart lay tree leafIdx chainIdx)).bind fun _ => + PreservesPublishedValues.pure () + · simp only [revealTableInputChildren, hzero, ↓reduceIte] + exact (preservesPublishedValues_revealPositionValues _).bind fun _ => + PreservesPublishedValues.pure () + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp only [revealTableInputChildren] + exact (preservesPublishedValues_revealPositionValues _).bind fun _ => + PreservesPublishedValues.pure () + +theorem preservesPublishedValues_resolveVerifierInput + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) : + PreservesPublishedValues (resolveVerifierInput parameter coordinate input) := by + unfold resolveVerifierInput + exact (PreservesPublishedValues.of_preservesCoordinate preservesCoordinate_get).bind fun cache => + match cache (.ordinary input) with + | some output => PreservesPublishedValues.pure output + | none => (preservesPublishedValues_revealTableInputChildren coordinate).bind fun _ => + preservesPublishedValues_resolveKnownInput parameter coordinate input + +theorem preservesPublishedValues_verifierHashQuery + (parameter : PublicParameter) (input : HashInput) : + PreservesPublishedValues (verifierHashQuery parameter input) := by + unfold verifierHashQuery + cases decodeProbe? parameter input with + | some candidate => + exact (PreservesPublishedValues.of_preservesCoordinate fun coordinate => + preservesCoordinate_probe coordinate candidate).bind fun _ => + preservesPublishedValues_resolveVerifierInput parameter candidate.outputCoordinate input + | none => + cases decodePosition? parameter input with + | none => exact PreservesPublishedValues.of_preservesCoordinate fun coordinate => + preservesCoordinate_splitHashQuery coordinate (.ordinary input) + | some position => + cases position with + | chain | leaf | node => exact preservesPublishedValues_resolveVerifierInput parameter _ input + | ftsLeaf | ftsNode | ftsRoots => + exact PreservesPublishedValues.of_preservesCoordinate fun coordinate => + preservesCoordinate_splitHashQuery coordinate (.ordinary input) + +def CoordinateChildrenAvoid (coordinate : Coordinate) : Coordinate → Prop + | .chainStart _ _ _ _ => True + | .position position@(.chain lay tree leafIdx chainIdx step) => + if step.val = 0 then coordinate ≠ .chainStart lay tree leafIdx chainIdx + else ∀ child, child ∈ position.children → coordinate ≠ .position child + | .position position => + ∀ child, child ∈ position.children → coordinate ≠ .position child + +theorem preservesCoordinate_revealTableInputChildren + (coordinate other : Coordinate) + (hne : CoordinateChildrenAvoid coordinate other) : + PreservesCoordinate coordinate (revealTableInputChildren other) := by + cases other with + | chainStart => exact preservesCoordinate_pure coordinate () + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + by_cases hzero : step.val = 0 + · simp only [revealTableInputChildren, hzero, ↓reduceIte] + exact (preservesCoordinate_revealCoordinate_of_ne coordinate + (.chainStart lay tree leafIdx chainIdx) + (by simpa [CoordinateChildrenAvoid, hzero] using hne)).bind fun _ => + preservesCoordinate_pure coordinate () + · simp only [revealTableInputChildren, hzero, ↓reduceIte] + exact (preservesCoordinate_revealPositionValues coordinate _ + (by simpa [CoordinateChildrenAvoid, hzero] using hne)).bind fun _ => + preservesCoordinate_pure coordinate () + | leaf lay tree leafIdx => + simp only [revealTableInputChildren] + exact (preservesCoordinate_revealPositionValues coordinate _ hne).bind fun _ => + preservesCoordinate_pure coordinate () + | node lay tree level nodeIdx => + simp only [revealTableInputChildren] + exact (preservesCoordinate_revealPositionValues coordinate _ hne).bind fun _ => + preservesCoordinate_pure coordinate () + | ftsLeaf index tree leafIdx => + simp only [revealTableInputChildren] + exact (preservesCoordinate_revealPositionValues coordinate _ hne).bind fun _ => + preservesCoordinate_pure coordinate () + | ftsNode index tree level nodeIdx => + simp only [revealTableInputChildren] + exact (preservesCoordinate_revealPositionValues coordinate _ hne).bind fun _ => + preservesCoordinate_pure coordinate () + | ftsRoots index => + simp only [revealTableInputChildren] + exact (preservesCoordinate_revealPositionValues coordinate _ hne).bind fun _ => + preservesCoordinate_pure coordinate () + +theorem preservesCoordinate_resolveVerifierInput + (parameter : PublicParameter) (coordinate other : Coordinate) (input : HashInput) + (hchildren : CoordinateChildrenAvoid coordinate other) + (hother : coordinate ≠ other) : + PreservesCoordinate coordinate (resolveVerifierInput parameter other input) := by + unfold resolveVerifierInput + exact (preservesCoordinate_get coordinate).bind fun cache => + match cache (.ordinary input) with + | some output => preservesCoordinate_pure coordinate output + | none => (preservesCoordinate_revealTableInputChildren coordinate other hchildren).bind + fun _ => preservesCoordinate_resolveKnownInput_of_ne parameter coordinate other input hother + +theorem Probe.coordinate_eq_chain_source_of_matchesInput + (probe : Probe) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (step : ChainStep) (payload : HashInput) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx step) payload)) : + probe.coordinate = .chainStart lay tree leafIdx chainIdx ∨ + ∃ previous : ChainStep, + probe.coordinate = .position (.chain lay tree leafIdx chainIdx previous) := by + rcases probe with ⟨coordinate, candidate⟩ + cases coordinate with + | chainStart sourceLay sourceTree sourceLeaf sourceChain => + obtain ⟨sourceStep, _, hinput⟩ := hmatches + have hdomain := (tweakableHashInput_injective parameter (by trivial) (by trivial) + hinput.symm).1 + cases hdomain + exact Or.inl rfl + | position position => + cases position with + | chain sourceLay sourceTree sourceLeaf sourceChain sourceStep => + simp only [Probe.MatchesInput] at hmatches + split at hmatches + · obtain ⟨nextStep, _, hinput⟩ := hmatches + have hdomain := (tweakableHashInput_injective parameter (by trivial) (by trivial) + hinput.symm).1 + cases hdomain + exact Or.inr ⟨sourceStep, rfl⟩ + · obtain ⟨_, sourcePayload, hinput, _⟩ := hmatches + have hdomain := (tweakableHashInput_injective parameter (by trivial) (by trivial) + hinput.symm).1 + cases hdomain + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp [Probe.MatchesInput] at hmatches + +theorem Probe.coordinate_ne_of_matches_chain_ne + (probe : Probe) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (step : ChainStep) (payload : HashInput) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx step) payload)) + (otherChain : ChainIndex) (hne : otherChain ≠ chainIdx) : + probe.coordinate ≠ .chainStart lay tree leafIdx otherChain ∧ + (∀ otherStep : ChainStep, + probe.coordinate ≠ .position (.chain lay tree leafIdx otherChain otherStep)) := by + rcases probe.coordinate_eq_chain_source_of_matchesInput parameter lay tree leafIdx chainIdx + step payload hmatches with hstart | ⟨previous, hprevious⟩ + · rw [hstart] + constructor + · intro heq + exact hne (Coordinate.chainStart.inj heq).2.2.2.symm + · intro otherStep heq + cases heq + · rw [hprevious] + constructor + · intro heq + cases heq + · intro otherStep heq + exact hne (Position.chain.inj (Coordinate.position.inj heq)).2.2.2.1.symm + +theorem Probe.coordinate_ne_chainStart_of_matches_chain_layer_ne + (probe : Probe) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (step : ChainStep) (payload : HashInput) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx step) payload)) + (otherLay : Layer) (otherTree : TreeIndex) (otherLeaf : LeafIndex) + (otherChain : ChainIndex) (hne : otherLay ≠ lay) : + probe.coordinate ≠ .chainStart otherLay otherTree otherLeaf otherChain := by + rcases probe.coordinate_eq_chain_source_of_matchesInput parameter lay tree leafIdx chainIdx + step payload hmatches with hsource | ⟨previous, hsource⟩ <;> rw [hsource] + · intro heq + exact hne (Coordinate.chainStart.inj heq).1.symm + · intro heq + cases heq + +theorem Probe.coordinate_ne_position_chain_of_matches_chain_layer_ne + (probe : Probe) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (step : ChainStep) (payload : HashInput) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx step) payload)) + (otherLay : Layer) (otherTree : TreeIndex) (otherLeaf : LeafIndex) + (otherChain : ChainIndex) (otherStep : ChainStep) (hne : otherLay ≠ lay) : + probe.coordinate ≠ .position + (.chain otherLay otherTree otherLeaf otherChain otherStep) := by + rcases probe.coordinate_eq_chain_source_of_matchesInput parameter lay tree leafIdx chainIdx + step payload hmatches with hsource | ⟨previous, hsource⟩ <;> rw [hsource] + · intro heq + cases heq + · intro heq + exact hne (Position.chain.inj (Coordinate.position.inj heq)).1.symm + +theorem Probe.coordinate_ne_position_leaf_of_matches_chain_layer_ne + (probe : Probe) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (step : ChainStep) (payload : HashInput) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx step) payload)) + (otherLay : Layer) (otherTree : TreeIndex) (otherLeaf : LeafIndex) + (_hne : otherLay ≠ lay) : + probe.coordinate ≠ .position (.leaf otherLay otherTree otherLeaf) := by + rcases probe.coordinate_eq_chain_source_of_matchesInput parameter lay tree leafIdx chainIdx + step payload hmatches with hsource | ⟨previous, hsource⟩ <;> rw [hsource] <;> + intro heq <;> cases heq + +theorem Probe.coordinate_ne_position_node_of_matches_chain_layer_ne + (probe : Probe) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (step : ChainStep) (payload : HashInput) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx step) payload)) + (otherLay : Layer) (otherTree : TreeIndex) (level : Fin maxLayerHeight) + (nodeIdx : LeafIndex) (_hne : otherLay ≠ lay) : + probe.coordinate ≠ .position (.node otherLay otherTree level nodeIdx) := by + rcases probe.coordinate_eq_chain_source_of_matchesInput parameter lay tree leafIdx chainIdx + step payload hmatches with hsource | ⟨previous, hsource⟩ <;> rw [hsource] <;> + intro heq <;> cases heq + +theorem preservesCoordinate_verifierHashQuery_at_position + (parameter : PublicParameter) (coordinate : Coordinate) + (position : Position) (input : HashInput) + (hat : AtPosition parameter input position) + (hots : IsOtsPosition position) + (hchildren : CoordinateChildrenAvoid coordinate (.position position)) + (hother : coordinate ≠ .position position) : + PreservesCoordinate coordinate (verifierHashQuery parameter input) := by + have hposition : decodePosition? parameter input = some position := + (decodePosition?_eq_some_iff parameter input position).2 hat + cases hdecode : decodeProbe? parameter input with + | none => + unfold verifierHashQuery + rw [hdecode, hposition] + cases position with + | chain lay tree leafIdx chainIdx step => + exact preservesCoordinate_resolveVerifierInput parameter coordinate + (.position (.chain lay tree leafIdx chainIdx step)) input hchildren hother + | leaf lay tree leafIdx => + exact preservesCoordinate_resolveVerifierInput parameter coordinate + (.position (.leaf lay tree leafIdx)) input hchildren hother + | node lay tree level nodeIdx => + exact preservesCoordinate_resolveVerifierInput parameter coordinate + (.position (.node lay tree level nodeIdx)) input hchildren hother + | ftsLeaf | ftsNode | ftsRoots => simp [IsOtsPosition] at hots + | some candidate => + have houtput := candidate.outputCoordinate_eq_position_of_matchesInput parameter input + position ((decodeProbe?_eq_some_iff parameter input candidate).1 hdecode) hat + unfold verifierHashQuery + rw [hdecode] + exact (preservesCoordinate_probe coordinate candidate).bind fun _ => by + rw [houtput] + exact preservesCoordinate_resolveVerifierInput parameter coordinate (.position position) + input hchildren hother + +theorem preservesCoordinate_verifierHashQuery_chain_of_ne + (parameter : PublicParameter) (probe : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx otherChain : ChainIndex) (targetStep currentStep : ChainStep) + (targetValue currentValue : Digest) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx targetStep) + (digestBytes targetValue))) + (hne : otherChain ≠ chainIdx) : + PreservesCoordinate probe.coordinate + (verifierHashQuery parameter + (tweakableHashInput parameter (.chain lay tree leafIdx otherChain currentStep) + (digestBytes currentValue))) := by + let input := tweakableHashInput parameter (.chain lay tree leafIdx otherChain currentStep) + (digestBytes currentValue) + have htargetNe := probe.coordinate_ne_of_matches_chain_ne parameter lay tree leafIdx chainIdx + targetStep (digestBytes targetValue) hmatches otherChain hne + have hposition : decodePosition? parameter input = + some (.chain lay tree leafIdx otherChain currentStep) := + (decodePosition?_eq_some_iff parameter input + (.chain lay tree leafIdx otherChain currentStep)).2 ⟨digestBytes currentValue, rfl⟩ + cases hdecode : decodeProbe? parameter input with + | none => + unfold verifierHashQuery + rw [hdecode, hposition] + apply preservesCoordinate_resolveVerifierInput parameter probe.coordinate + (.position (.chain lay tree leafIdx otherChain currentStep)) input + · unfold CoordinateChildrenAvoid + by_cases hzero : currentStep.val = 0 + · simp only [hzero, if_pos] + exact htargetNe.1 + · have hpositive : 0 < currentStep.val := Nat.pos_of_ne_zero hzero + simp only [hzero] + intro child hchild + simp only [Position.children, dif_pos hpositive, List.mem_singleton] at hchild + subst child + exact htargetNe.2 _ + · exact htargetNe.2 _ + | some candidate => + have hcandidate := (decodeProbe?_eq_some_iff parameter input candidate).1 hdecode + have houtput := candidate.outputCoordinate_eq_position_of_matchesInput parameter input + (.chain lay tree leafIdx otherChain currentStep) hcandidate + ((decodePosition?_eq_some_iff parameter input + (.chain lay tree leafIdx otherChain currentStep)).1 hposition) + unfold verifierHashQuery + rw [hdecode] + exact (preservesCoordinate_probe probe.coordinate candidate).bind fun _ => by + rw [houtput] + apply preservesCoordinate_resolveVerifierInput parameter probe.coordinate + (.position (.chain lay tree leafIdx otherChain currentStep)) input + · unfold CoordinateChildrenAvoid + by_cases hzero : currentStep.val = 0 + · simp only [hzero, if_pos] + exact htargetNe.1 + · have hpositive : 0 < currentStep.val := Nat.pos_of_ne_zero hzero + simp only [hzero] + intro child hchild + simp only [Position.children, dif_pos hpositive, List.mem_singleton] at hchild + subst child + exact htargetNe.2 _ + · exact htargetNe.2 _ + +theorem preservesCoordinate_verifierHashQuery_chain_of_layer_ne + (parameter : PublicParameter) (probe : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (targetStep : ChainStep) (targetValue : Digest) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx targetStep) + (digestBytes targetValue))) + (otherLay : Layer) (otherTree : TreeIndex) (otherLeaf : LeafIndex) + (otherChain : ChainIndex) (otherStep : ChainStep) (value : Digest) + (hne : otherLay ≠ lay) : + PreservesCoordinate probe.coordinate + (verifierHashQuery parameter + (tweakableHashInput parameter + (.chain otherLay otherTree otherLeaf otherChain otherStep) (digestBytes value))) := by + let position := Position.chain otherLay otherTree otherLeaf otherChain otherStep + apply preservesCoordinate_verifierHashQuery_at_position parameter probe.coordinate position _ + ⟨digestBytes value, rfl⟩ (by trivial) + · unfold CoordinateChildrenAvoid position + by_cases hzero : otherStep.val = 0 + · simp only [hzero, if_pos] + exact probe.coordinate_ne_chainStart_of_matches_chain_layer_ne parameter lay tree leafIdx + chainIdx targetStep (digestBytes targetValue) hmatches otherLay otherTree otherLeaf + otherChain hne + · have hpositive : 0 < otherStep.val := Nat.pos_of_ne_zero hzero + simp only [hzero] + intro child hchild + simp only [Position.children, dif_pos hpositive, List.mem_singleton] at hchild + subst child + exact probe.coordinate_ne_position_chain_of_matches_chain_layer_ne parameter lay tree + leafIdx chainIdx targetStep (digestBytes targetValue) hmatches otherLay otherTree + otherLeaf otherChain _ hne + · exact probe.coordinate_ne_position_chain_of_matches_chain_layer_ne parameter lay tree + leafIdx chainIdx targetStep (digestBytes targetValue) hmatches otherLay otherTree otherLeaf + otherChain otherStep hne + +theorem preservesCoordinate_verifierHashQuery_leaf_of_layer_ne + (parameter : PublicParameter) (probe : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (targetStep : ChainStep) (targetValue : Digest) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx targetStep) + (digestBytes targetValue))) + (otherLay : Layer) (otherTree : TreeIndex) (otherLeaf : LeafIndex) + (payload : HashInput) (hne : otherLay ≠ lay) : + PreservesCoordinate probe.coordinate + (verifierHashQuery parameter + (tweakableHashInput parameter (.leaf otherLay otherTree otherLeaf) payload)) := by + let position := Position.leaf otherLay otherTree otherLeaf + apply preservesCoordinate_verifierHashQuery_at_position parameter probe.coordinate position _ + ⟨payload, rfl⟩ (by trivial) + · unfold CoordinateChildrenAvoid position + intro child hchild + simp only [Position.children, List.mem_ofFn] at hchild + obtain ⟨otherChain, rfl⟩ := hchild + exact probe.coordinate_ne_position_chain_of_matches_chain_layer_ne parameter lay tree leafIdx + chainIdx targetStep (digestBytes targetValue) hmatches otherLay otherTree otherLeaf + otherChain Position.lastChainStep hne + · exact probe.coordinate_ne_position_leaf_of_matches_chain_layer_ne parameter lay tree leafIdx + chainIdx targetStep (digestBytes targetValue) hmatches otherLay otherTree otherLeaf hne + +theorem preservesCoordinate_verifierHashQuery_node_of_layer_ne + (parameter : PublicParameter) (probe : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (targetStep : ChainStep) (targetValue : Digest) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx targetStep) + (digestBytes targetValue))) + (otherLay : Layer) (otherTree : TreeIndex) (level : Fin maxLayerHeight) + (nodeIdx : LeafIndex) (payload : HashInput) (hne : otherLay ≠ lay) : + PreservesCoordinate probe.coordinate + (verifierHashQuery parameter + (tweakableHashInput parameter + (.node otherLay otherTree (level.val + 1) nodeIdx.val) payload)) := by + let position := Position.node otherLay otherTree level nodeIdx + apply preservesCoordinate_verifierHashQuery_at_position parameter probe.coordinate position _ + ⟨payload, by simp [position, Position.domain]⟩ (by trivial) + · unfold CoordinateChildrenAvoid position + intro child hchild + simp only [Position.children] at hchild + split_ifs at hchild with hidx hlevel + · rcases List.mem_pair.mp hchild with hleft | hright + · subst child + exact probe.coordinate_ne_position_node_of_matches_chain_layer_ne parameter lay tree + leafIdx chainIdx targetStep (digestBytes targetValue) hmatches otherLay otherTree _ _ hne + · subst child + exact probe.coordinate_ne_position_node_of_matches_chain_layer_ne parameter lay tree + leafIdx chainIdx targetStep (digestBytes targetValue) hmatches otherLay otherTree _ _ hne + · rcases List.mem_pair.mp hchild with hleft | hright + · subst child + exact probe.coordinate_ne_position_leaf_of_matches_chain_layer_ne parameter lay tree + leafIdx chainIdx targetStep (digestBytes targetValue) hmatches otherLay otherTree _ hne + · subst child + exact probe.coordinate_ne_position_leaf_of_matches_chain_layer_ne parameter lay tree + leafIdx chainIdx targetStep (digestBytes targetValue) hmatches otherLay otherTree _ hne + · simp at hchild + · simpa only [position] using + probe.coordinate_ne_position_node_of_matches_chain_layer_ne parameter lay tree leafIdx + chainIdx targetStep (digestBytes targetValue) hmatches otherLay otherTree level nodeIdx hne + +theorem verifierHashQuery_eq_splitHashQuery_of_stable + (parameter : PublicParameter) (input : HashInput) + (hstable : StableOrdinaryInput parameter input) : + verifierHashQuery parameter input = splitHashQuery (.ordinary input) := by + unfold verifierHashQuery + rw [hstable.1] + cases hposition : decodePosition? parameter input with + | none => rfl + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + exact (hstable.2 _ hposition (by trivial)).elim + | leaf lay tree leafIdx => + exact (hstable.2 _ hposition (by trivial)).elim + | node lay tree level nodeIdx => + exact (hstable.2 _ hposition (by trivial)).elim + | ftsLeaf | ftsNode | ftsRoots => rfl + +theorem preservesCoordinate_simulateQ_verifierHashImpl_tweakableHash_of_stable + (parameter : PublicParameter) (coordinate : Coordinate) + (domain : HashDomain) (payload : HashInput) + (hstable : StableOrdinaryInput parameter + (tweakableHashInput parameter domain payload)) : + PreservesCoordinate coordinate + (simulateQ (verifierHashImpl parameter) + (tweakableHash parameter domain payload)) := by + unfold tweakableHash oracleHash + rw [simulateQ_bind] + simp only [HasQuery.instOfMonadLift_query, simulateQ_spec_query] + change PreservesCoordinate coordinate + (verifierHashQuery parameter (tweakableHashInput parameter domain payload) >>= fun output => + pure (truncateHash output)) + rw [verifierHashQuery_eq_splitHashQuery_of_stable parameter _ hstable] + exact (preservesCoordinate_splitHashQuery coordinate _).bind fun _ => + preservesCoordinate_pure coordinate _ + +theorem preservesCoordinate_simulateQ_verifierHashImpl_chainWalk_of_chain_ne + (parameter : PublicParameter) (probe : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx otherChain : ChainIndex) (targetStep : ChainStep) (targetValue : Digest) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx targetStep) + (digestBytes targetValue))) + (hne : otherChain ≠ chainIdx) : + ∀ start steps value, + PreservesCoordinate probe.coordinate + (simulateQ (verifierHashImpl parameter) + (chainWalk parameter lay tree leafIdx otherChain start steps value)) := by + intro start steps value + induction steps with + | zero => + rw [chainWalk, simulateQ_pure] + exact preservesCoordinate_pure probe.coordinate value + | succ steps ih => + rw [chainWalk, simulateQ_bind] + exact ih.bind fun current => by + split + · exact (preservesCoordinate_verifierHashQuery_chain_of_ne parameter probe lay tree + leafIdx chainIdx otherChain targetStep _ targetValue current hmatches hne).bind + fun output => preservesCoordinate_pure probe.coordinate (truncateHash output) + · exact preservesCoordinate_pure probe.coordinate 0 + +theorem preservesCoordinate_simulateQ_verifierHashImpl_recoverChain_of_chain_ne + (parameter : PublicParameter) (probe : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx otherChain : ChainIndex) (targetStep : ChainStep) (targetValue : Digest) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx targetStep) + (digestBytes targetValue))) + (hne : otherChain ≠ chainIdx) (digit : Digit) (value : Digest) : + PreservesCoordinate probe.coordinate + (simulateQ (verifierHashImpl parameter) + (recoverChain parameter lay tree leafIdx otherChain digit value)) := by + unfold recoverChain + exact preservesCoordinate_simulateQ_verifierHashImpl_chainWalk_of_chain_ne parameter probe lay + tree leafIdx chainIdx otherChain targetStep targetValue hmatches hne _ _ _ + +theorem preservesCoordinate_simulateQ_sequenceFin + {spec : OracleSpec ι} (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (coordinate : Coordinate) {n : Nat} (computation : Fin n → OracleComp spec alpha) + (hcomponent : ∀ index, + PreservesCoordinate coordinate (simulateQ impl (computation index))) : + PreservesCoordinate coordinate (simulateQ impl (sequenceFin computation)) := by + induction n with + | zero => + simp only [sequenceFin, simulateQ_pure] + exact preservesCoordinate_pure coordinate Fin.elim0 + | succ n ih => + rw [sequenceFin, simulateQ_bind] + exact (hcomponent 0).bind fun head => by + rw [simulateQ_bind] + exact (ih (fun index : Fin n => computation index.succ) + (fun index => hcomponent index.succ)).bind fun tail => by + rw [simulateQ_pure] + exact preservesCoordinate_pure coordinate + (Fin.cases head tail : Fin (n + 1) → alpha) + +theorem preservesCoordinate_simulateQ_verifierHashImpl_chainWalk_of_layer_ne + (parameter : PublicParameter) (probe : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (targetStep : ChainStep) (targetValue : Digest) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx targetStep) + (digestBytes targetValue))) + (otherLay : Layer) (otherTree : TreeIndex) (otherLeaf : LeafIndex) + (otherChain : ChainIndex) (hne : otherLay ≠ lay) : + ∀ start steps value, + PreservesCoordinate probe.coordinate + (simulateQ (verifierHashImpl parameter) + (chainWalk parameter otherLay otherTree otherLeaf otherChain start steps value)) := by + intro start steps value + induction steps with + | zero => + rw [chainWalk, simulateQ_pure] + exact preservesCoordinate_pure probe.coordinate value + | succ steps ih => + rw [chainWalk, simulateQ_bind] + exact ih.bind fun current => by + split + · exact (preservesCoordinate_verifierHashQuery_chain_of_layer_ne parameter probe lay tree + leafIdx chainIdx targetStep targetValue hmatches otherLay otherTree otherLeaf + otherChain _ current hne).bind fun output => + preservesCoordinate_pure probe.coordinate (truncateHash output) + · exact preservesCoordinate_pure probe.coordinate 0 + +theorem preservesCoordinate_simulateQ_verifierHashImpl_recoverChain_of_layer_ne + (parameter : PublicParameter) (probe : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (targetStep : ChainStep) (targetValue : Digest) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx targetStep) + (digestBytes targetValue))) + (otherLay : Layer) (otherTree : TreeIndex) (otherLeaf : LeafIndex) + (otherChain : ChainIndex) (digit : Digit) (value : Digest) (hne : otherLay ≠ lay) : + PreservesCoordinate probe.coordinate + (simulateQ (verifierHashImpl parameter) + (recoverChain parameter otherLay otherTree otherLeaf otherChain digit value)) := by + unfold recoverChain + exact preservesCoordinate_simulateQ_verifierHashImpl_chainWalk_of_layer_ne parameter probe lay + tree leafIdx chainIdx targetStep targetValue hmatches otherLay otherTree otherLeaf otherChain + hne _ _ _ + +theorem preservesCoordinate_simulateQ_verifierHashImpl_leafHash_of_layer_ne + (parameter : PublicParameter) (probe : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (targetStep : ChainStep) (targetValue : Digest) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx targetStep) + (digestBytes targetValue))) + (otherLay : Layer) (otherTree : TreeIndex) (otherLeaf : LeafIndex) + (values : ChainIndex → Digest) (hne : otherLay ≠ lay) : + PreservesCoordinate probe.coordinate + (simulateQ (verifierHashImpl parameter) + (leafHash parameter otherLay otherTree otherLeaf values)) := by + unfold leafHash tweakableHash oracleHash + rw [simulateQ_bind] + simp only [HasQuery.instOfMonadLift_query, simulateQ_spec_query] + change PreservesCoordinate probe.coordinate + (verifierHashQuery parameter + (tweakableHashInput parameter (.leaf otherLay otherTree otherLeaf) + (leafPayload values)) >>= fun output => pure (truncateHash output)) + exact (preservesCoordinate_verifierHashQuery_leaf_of_layer_ne parameter probe lay tree leafIdx + chainIdx targetStep targetValue hmatches otherLay otherTree otherLeaf (leafPayload values) + hne).bind fun _ => preservesCoordinate_pure probe.coordinate _ + +theorem preservesCoordinate_simulateQ_verifierHashImpl_encode + (parameter : PublicParameter) (coordinate : Coordinate) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (counter : Counter) : + PreservesCoordinate coordinate + (simulateQ (verifierHashImpl parameter) + (encode parameter lay tree leafIdx message counter)) := by + rw [encode, simulateQ_bind] + exact (preservesCoordinate_simulateQ_verifierHashImpl_tweakableHash_of_stable parameter + coordinate (.encoding lay tree leafIdx) _ + (stableOrdinaryInput_tweakableHashInput parameter (.encoding lay tree leafIdx) _ + (by trivial) (by simp) (by simp) (by simp))).bind fun _ => + preservesCoordinate_pure coordinate _ + +theorem preservesCoordinate_simulateQ_verifierHashImpl_otsLeaf_of_layer_ne + (parameter : PublicParameter) (probe : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (targetStep : ChainStep) (targetValue : Digest) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx targetStep) + (digestBytes targetValue))) + (otherLay : Layer) (otherTree : TreeIndex) (otherLeaf : LeafIndex) + (message : Digest) (counter : Counter) (values : ChainIndex → Digest) + (hne : otherLay ≠ lay) : + PreservesCoordinate probe.coordinate + (simulateQ (verifierHashImpl parameter) + (otsLeaf parameter otherLay otherTree otherLeaf message counter values)) := by + unfold otsLeaf + rw [simulateQ_bind] + exact (preservesCoordinate_simulateQ_verifierHashImpl_encode parameter probe.coordinate otherLay + otherTree otherLeaf message counter).bind fun encoded => + match encoded with + | none => preservesCoordinate_pure probe.coordinate none + | some encoding => by + rw [simulateQ_bind] + exact (preservesCoordinate_simulateQ_sequenceFin (verifierHashImpl parameter) + probe.coordinate (fun index => recoverChain parameter otherLay otherTree otherLeaf + index (encoding index) (values index)) fun index => + preservesCoordinate_simulateQ_verifierHashImpl_recoverChain_of_layer_ne parameter + probe lay tree leafIdx chainIdx targetStep targetValue hmatches otherLay otherTree + otherLeaf index (encoding index) (values index) hne).bind fun endpoints => by + rw [simulateQ_bind] + exact (preservesCoordinate_simulateQ_verifierHashImpl_leafHash_of_layer_ne parameter + probe lay tree leafIdx chainIdx targetStep targetValue hmatches otherLay otherTree + otherLeaf endpoints hne).bind fun value => + preservesCoordinate_pure probe.coordinate (some value) + +theorem preservesCoordinate_simulateQ_verifierHashImpl_treeFold_of_layer_ne + (parameter : PublicParameter) (probe : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (targetStep : ChainStep) (targetValue : Digest) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx targetStep) + (digestBytes targetValue))) + (otherLay : Layer) (otherTree : TreeIndex) (otherLeaf : LeafIndex) + (path : Nat → Digest) (hne : otherLay ≠ lay) : + ∀ levels value, levels ≤ maxLayerHeight → + PreservesCoordinate probe.coordinate + (simulateQ (verifierHashImpl parameter) + (treeFold parameter otherLay otherTree otherLeaf path levels value)) + | 0, value, _ => by + rw [treeFold_zero_eq, simulateQ_pure] + exact preservesCoordinate_pure probe.coordinate value + | levels + 1, value, hlevels => by + rw [treeFold_succ_eq, simulateQ_bind] + exact (preservesCoordinate_simulateQ_verifierHashImpl_treeFold_of_layer_ne parameter probe + lay tree leafIdx chainIdx targetStep targetValue hmatches otherLay otherTree otherLeaf path + hne levels value (by omega)).bind fun current => by + let level : Fin maxLayerHeight := ⟨levels, by omega⟩ + let nodeIdx : LeafIndex := ⟨otherLeaf.val / 2 ^ (levels + 1), by + exact lt_of_le_of_lt (Nat.div_le_self _ _) otherLeaf.isLt⟩ + split <;> + exact (preservesCoordinate_verifierHashQuery_node_of_layer_ne parameter probe lay + tree leafIdx chainIdx targetStep targetValue hmatches otherLay otherTree level + nodeIdx _ hne).bind fun output => + preservesCoordinate_pure probe.coordinate (truncateHash output) + +theorem verifierHashQuery_pendingHit_of_cached_correct_probe_of_opaque + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (probe : Probe) (input : HashInput) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output cached : HashOutput) + (hmatches : probe.MatchesInput parameter input) + (hcandidate : probe.candidate = truncateHash (table probe.coordinate)) + (hvalue : state.values probe.coordinate = none) + (hnotRevealed : probe.coordinate ∉ state.revealed) + (hcached : cache (.ordinary input) = some cached) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((verifierHashQuery parameter input).run cache))) : + finalState.values probe.coordinate = none ∧ + finalState.hitAt probe.coordinate (table probe.coordinate) := by + have hdecode : decodeProbe? parameter input = some probe := + (decodeProbe?_eq_some_iff parameter input probe).2 hmatches + unfold verifierHashQuery at hresult + rw [hdecode, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨probeRaw, hprobe, hresolve⟩ := hresult + cases probeRaw with + | stopped hit => simp at hresolve + | done probeState probeRemaining probeResult => + rcases probeResult with ⟨probed, probeCache⟩ + change LazyRevealProbe.RawResult.done probeState probeRemaining + (probed, probeCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.probeQuery probe.coordinate probe.candidate >>= fun result => + pure (result, cache))) at hprobe + rw [LazyRevealProbe.probeQuery, + LazyRevealProbe.runRaw_probe_query_bind] at hprobe + cases fuel with + | zero => simp at hprobe + | succ remainingFuel => + simp only at hprobe + rw [if_neg hnotRevealed] at hprobe + simp [LazyRevealProbe.runRaw] at hprobe + rcases hprobe with ⟨rfl, rfl, rfl, rfl⟩ + unfold resolveVerifierInput at hresolve + simp [hcached, LazyRevealProbe.runRaw] at hresolve + rcases hresolve with ⟨rfl, rfl, rfl, rfl⟩ + constructor + · simpa [LazyRevealProbe.State.addPending] using hvalue + · rw [LazyRevealProbe.State.hitAt, ← hcandidate] + exact LazyRevealProbe.State.pendingAt_addPending_self state probe.coordinate + probe.candidate + +theorem simulateQ_verifierHashImpl_tweakableHash_pendingHit_of_correct_probe_of_opaque + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (probe : Probe) (domain : HashDomain) (payload : HashInput) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : Digest) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter domain payload)) + (hcandidate : probe.candidate = truncateHash (table probe.coordinate)) + (hvalue : state.values probe.coordinate = none) + (hnotRevealed : probe.coordinate ∉ state.revealed) + (htable : ∀ coordinate cached, finalState.values coordinate = some cached → + cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ (verifierHashImpl parameter) + (tweakableHash parameter domain payload)).run cache))) : + finalState.values probe.coordinate = none ∧ + finalState.hitAt probe.coordinate (table probe.coordinate) := by + cases hcached : cache (.ordinary (tweakableHashInput parameter domain payload)) with + | none => + exact (simulateQ_verifierHashImpl_tweakableHash_not_done_of_fresh_correct_probe_of_opaque + parameter table probe domain payload state finalState cache finalCache fuel remaining + output hmatches hcandidate hvalue hnotRevealed hcached htable hresult).elim + | some cached => + unfold tweakableHash oracleHash at hresult + rw [simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨queryRaw, hquery, hrest⟩ := hresult + cases queryRaw with + | stopped hit => simp at hrest + | done queryState queryRemaining queryResult => + rcases queryResult with ⟨answer, queryCache⟩ + simp [LazyRevealProbe.runRaw] at hrest + rcases hrest with ⟨rfl, rfl, rfl, rfl⟩ + have hquery' : LazyRevealProbe.RawResult.done finalState remaining + (answer, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((verifierHashQuery parameter + (tweakableHashInput parameter domain payload)).run cache)) := by + simpa only [HasQuery.instOfMonadLift_query, simulateQ_spec_query, + verifierHashImpl] using hquery + exact verifierHashQuery_pendingHit_of_cached_correct_probe_of_opaque parameter table + probe (tweakableHashInput parameter domain payload) state finalState cache finalCache + fuel remaining answer cached hmatches hcandidate hvalue hnotRevealed hcached hquery' + +theorem simulateQ_verifierHashImpl_chainWalk_pendingHit_of_correct_probe_of_opaque + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (probe : Probe) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (start steps : Nat) (initialValue : Digest) + (hpositive : 0 < steps) (hrange : start + steps ≤ chainLength - 1) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : Digest) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx ⟨start, by omega⟩) (digestBytes initialValue))) + (hcandidate : probe.candidate = truncateHash (table probe.coordinate)) + (hvalue : state.values probe.coordinate = none) + (hnotRevealed : probe.coordinate ∉ state.revealed) + (htable : ∀ coordinate cached, finalState.values coordinate = some cached → + cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ (verifierHashImpl parameter) + (chainWalk parameter lay tree leafIdx chainIdx start steps initialValue)).run cache))) : + finalState.values probe.coordinate = none ∧ + finalState.hitAt probe.coordinate (table probe.coordinate) := by + induction steps generalizing state finalState cache finalCache fuel remaining output with + | zero => omega + | succ steps ih => + cases steps with + | zero => + have hstep : start < chainLength - 1 := by omega + rw [chainWalk, chainWalk, pure_bind, Nat.add_zero, dif_pos hstep] at hresult + exact simulateQ_verifierHashImpl_tweakableHash_pendingHit_of_correct_probe_of_opaque + parameter table probe (.chain lay tree leafIdx chainIdx ⟨start, hstep⟩) + (digestBytes initialValue) state finalState cache finalCache fuel remaining output + (by simpa only using hmatches) hcandidate hvalue hnotRevealed htable hresult + | succ previous => + rw [chainWalk, simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨prefixRaw, hprefix, hrest⟩ := hresult + cases prefixRaw with + | stopped hit => simp at hrest + | done prefixState prefixRemaining prefixResult => + rcases prefixResult with ⟨prefixValue, prefixCache⟩ + simp only at hrest + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done _ prefixState + finalState prefixRemaining remaining (output, finalCache) hrest + have htablePrefix : ∀ coordinate cached, + prefixState.values coordinate = some cached → cached = table coordinate := + fun coordinate cached hcached => + htable coordinate cached (hvaluesLE coordinate cached hcached) + have hpending := ih (by omega) (by omega) state prefixState cache prefixCache fuel + prefixRemaining prefixValue hmatches hvalue hnotRevealed htablePrefix hprefix + exact LazyRevealProbe.pendingHit_preserved_of_mem_runRaw_done _ + probe.coordinate (table probe.coordinate) prefixState finalState prefixRemaining + remaining (output, finalCache) hpending.1 hpending.2 + (htable probe.coordinate) hrest + +theorem simulateQ_sequenceFin_bind_pendingHit_of_component + {spec : OracleSpec ι} (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (coordinate : Coordinate) (table : Coordinate → HashOutput) + {n : Nat} (computation : Fin n → OracleComp spec alpha) (target : Fin n) + (hother : ∀ index, index ≠ target → PreservesCoordinate coordinate + (simulateQ impl (computation index))) + (htarget : ∀ state finalState cache finalCache fuel remaining value, + state.values coordinate = none → coordinate ∉ state.revealed → + (∀ other cached, finalState.values other = some cached → cached = table other) → + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ impl (computation target)).run cache)) → + finalState.values coordinate = none ∧ + finalState.hitAt coordinate (table coordinate)) + (next : (Fin n → alpha) → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : beta) + (hvalue : state.values coordinate = none) + (hnotRevealed : coordinate ∉ state.revealed) + (htable : ∀ other cached, finalState.values other = some cached → cached = table other) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ impl (sequenceFin computation) >>= next).run cache))) : + finalState.values coordinate = none ∧ + finalState.hitAt coordinate (table coordinate) := by + induction n generalizing state finalState cache finalCache fuel remaining value with + | zero => exact target.elim0 + | succ n ih => + rw [sequenceFin, simulateQ_bind, bind_assoc, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨headRaw, hhead, hrest⟩ := hresult + cases headRaw with + | stopped hit => simp at hrest + | done headState headRemaining headResult => + rcases headResult with ⟨head, headCache⟩ + cases target using Fin.cases with + | zero => + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done _ headState + finalState headRemaining remaining (value, finalCache) hrest + have htableHead : ∀ other cached, + headState.values other = some cached → cached = table other := + fun other cached hcached => htable other cached + (hvaluesLE other cached hcached) + have hpending := htarget state headState cache headCache fuel headRemaining head + hvalue hnotRevealed htableHead hhead + exact LazyRevealProbe.pendingHit_preserved_of_mem_runRaw_done _ coordinate + (table coordinate) headState finalState headRemaining remaining + (value, finalCache) hpending.1 hpending.2 (htable coordinate) hrest + | succ target => + have hheadPreserves := hother 0 (by + intro heq + exact (Fin.succ_ne_zero target).symm heq) + have hheadCoordinate := hheadPreserves state cache fuel headState headRemaining head + headCache hhead + have hheadValue : headState.values coordinate = none := by + rw [hheadCoordinate.1, hvalue] + have hheadNotRevealed : coordinate ∉ headState.revealed := by + simpa [hheadCoordinate.2] using hnotRevealed + apply ih (fun index => computation index.succ) target + (fun index hne => hother index.succ (by + intro heq + exact hne (Fin.succ_inj.mp heq))) + (by + intro initial terminal initialCache terminalCache initialFuel terminalFuel + result hinitialValue hinitialRevealed hterminalTable hrun + exact htarget initial terminal initialCache terminalCache initialFuel terminalFuel + result hinitialValue hinitialRevealed hterminalTable hrun) + (fun tail => next (Fin.cases head tail)) headState finalState headCache finalCache + headRemaining remaining value hheadValue hheadNotRevealed htable + simpa only [simulateQ_bind, simulateQ_pure, pure_bind, bind_assoc] using hrest + +set_option maxRecDepth 10000 in +theorem simulateQ_verifierHashImpl_otsLeaf_pendingHit_of_correct_probe + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → HashOutput) (probe : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (counter : Counter) (values : ChainIndex → Digest) + (codeword : Encoding) (chainIdx : ChainIndex) + (hdigit : (codeword chainIdx).val < chainLength - 1) + (hencode : evalWithAnswerFn f + (encode parameter lay tree leafIdx message counter) = some codeword) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (result : Option Digest) + (hmatches : probe.MatchesInput parameter + (tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx ⟨(codeword chainIdx).val, hdigit⟩) + (digestBytes (values chainIdx)))) + (hcandidate : probe.candidate = truncateHash (table probe.coordinate)) + (hvalue : state.values probe.coordinate = none) + (hnotRevealed : probe.coordinate ∉ state.revealed) + (hf : CacheAnswersAgreeOnRun (ordinaryQueryCache finalCache) f + (encode parameter lay tree leafIdx message counter)) + (htable : ∀ coordinate cached, finalState.values coordinate = some cached → + cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (result, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ (verifierHashImpl parameter) + (otsLeaf parameter lay tree leafIdx message counter values)).run cache))) : + finalState.values probe.coordinate = none ∧ + finalState.hitAt probe.coordinate (table probe.coordinate) := by + unfold otsLeaf at hresult + rw [simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨encodeRaw, hencodeRaw, hrest⟩ := hresult + cases encodeRaw with + | stopped hit => simp at hrest + | done encodeState encodeRemaining encodeResult => + rcases encodeResult with ⟨encoded, encodeCache⟩ + have hfEncode : CacheAnswersAgreeOnRun (ordinaryQueryCache encodeCache) f + (encode parameter lay tree leafIdx message counter) := by + intro input hquery output hcached + apply hf input hquery + exact (ordinaryEntryPreservingImpl_verifierHashImpl parameter input).simulateQ _ + encodeState encodeCache encodeRemaining finalState remaining result finalCache output + hcached hrest + have hencoded := + (replay_of_mem_runRaw_verifierHashImpl_of_cacheAnswersAgreeOnRun f parameter + (encode parameter lay tree leafIdx message counter) state encodeState cache encodeCache + fuel encodeRemaining encoded hfEncode hencodeRaw).1 + rw [hencode] at hencoded + subst encoded + simp only at hrest + have hencodeCoordinate := + preservesCoordinate_simulateQ_verifierHashImpl_encode parameter probe.coordinate lay tree + leafIdx message counter state cache fuel encodeState encodeRemaining (some codeword) + encodeCache hencodeRaw + have hencodeValue : encodeState.values probe.coordinate = none := by + rw [hencodeCoordinate.1, hvalue] + have hencodeNotRevealed : probe.coordinate ∉ encodeState.revealed := by + simpa [hencodeCoordinate.2] using hnotRevealed + let chains : ChainIndex → OracleComp HashSpec Digest := fun index => + recoverChain parameter lay tree leafIdx index (codeword index) (values index) + apply simulateQ_sequenceFin_bind_pendingHit_of_component + (verifierHashImpl parameter) probe.coordinate table chains chainIdx + (fun index hne => by + exact preservesCoordinate_simulateQ_verifierHashImpl_recoverChain_of_chain_ne + parameter probe lay tree leafIdx chainIdx index + ⟨(codeword chainIdx).val, hdigit⟩ (values chainIdx) hmatches hne + (codeword index) (values index)) + (by + intro initial terminal initialCache terminalCache initialFuel terminalFuel output + hinitialValue hinitialRevealed hterminalTable hrun + unfold chains recoverChain at hrun + exact simulateQ_verifierHashImpl_chainWalk_pendingHit_of_correct_probe_of_opaque + parameter table probe lay tree leafIdx chainIdx (codeword chainIdx).val + (chainLength - 1 - (codeword chainIdx).val) (values chainIdx) (by omega) + (by omega) initial terminal initialCache terminalCache initialFuel terminalFuel + output hmatches hcandidate hinitialValue hinitialRevealed hterminalTable hrun) + (fun endpoints => do + let value ← simulateQ (verifierHashImpl parameter) + (leafHash parameter lay tree leafIdx endpoints) + pure (some value)) encodeState finalState encodeCache finalCache encodeRemaining + remaining result hencodeValue hencodeNotRevealed htable + simpa only [chains, simulateQ_bind, simulateQ_pure] using hrest + +theorem decodeProbe?_outputCoordinate_eq_position + (parameter : PublicParameter) (input : HashInput) (probe : Probe) + (position : Position) (hprobe : decodeProbe? parameter input = some probe) + (hposition : decodePosition? parameter input = some position) : + probe.outputCoordinate = .position position := by + exact probe.outputCoordinate_eq_position_of_matchesInput parameter input position + ((decodeProbe?_eq_some_iff parameter input probe).1 hprobe) + ((decodePosition?_eq_some_iff parameter input position).1 hposition) + +theorem verifierHashQuery_eq_resolveVerifierInput_of_decodeProbe_none + (parameter : PublicParameter) (input : HashInput) (position : Position) + (hprobe : decodeProbe? parameter input = none) + (hposition : decodePosition? parameter input = some position) + (hots : IsOtsPosition position) : + verifierHashQuery parameter input = + resolveVerifierInput parameter (.position position) input := by + unfold verifierHashQuery + rw [hprobe, hposition] + cases position <;> simp [IsOtsPosition] at hots ⊢ + +set_option maxRecDepth 10000 in +theorem verifierHashQuery_returns_table_of_uncached + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (position : Position) (hots : IsOtsPosition position) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : HashOutput) + (huncached : cache (.ordinary + (tableInput parameter table (.position position))) = none) + (htable : ∀ coordinate cached, finalState.values coordinate = some cached → + cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((verifierHashQuery parameter + (tableInput parameter table (.position position))).run cache))) : + output = table (.position position) ∧ + finalCache (.ordinary (tableInput parameter table (.position position))) = some output := by + let input := tableInput parameter table (.position position) + have hposition : decodePosition? parameter input = some position := + (decodePosition?_eq_some_iff parameter input position).2 ⟨tablePayload table position, rfl⟩ + cases hprobe : decodeProbe? parameter input with + | some candidate => + unfold verifierHashQuery at hresult + rw [hprobe, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨probeRaw, hprobeRun, hrest⟩ := hresult + cases probeRaw with + | stopped hit => simp at hrest + | done probeState probeRemaining probeResult => + rcases probeResult with ⟨probed, probeCache⟩ + have hprobeCache := splitCachePreserving_probe candidate state cache fuel probeState + probeRemaining probed probeCache hprobeRun + subst probeCache + have houtputCoordinate := decodeProbe?_outputCoordinate_eq_position parameter input + candidate position hprobe hposition + rw [houtputCoordinate] at hrest + exact resolveVerifierInput_returns_table_of_uncached parameter table position probeState + finalState cache finalCache probeRemaining remaining output huncached htable hrest + | none => + rw [verifierHashQuery_eq_resolveVerifierInput_of_decodeProbe_none parameter input position + hprobe hposition hots] at hresult + exact resolveVerifierInput_returns_table_of_uncached parameter table position state finalState + cache finalCache fuel remaining output huncached htable hresult + +theorem verifierHashQuery_output_eq_retainedCompletionAnswer_of_uncached + (parameter : PublicParameter) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (input : HashInput) + (state queryState completedState : LazyRevealProbe.State Coordinate) + (cache queryCache rawCache : SplitHashCache) (fuel queryRemaining : Nat) + (output : HashOutput) + (huncached : cache (.ordinary input) = none) + (hquery : LazyRevealProbe.RawResult.done queryState queryRemaining + (output, queryCache) ∈ support + (LazyRevealProbe.runRaw state fuel ((verifierHashQuery parameter input).run cache))) + (hvalues : LazyRevealProbe.ValuesLE queryState completedState) + (hcached : rawCache (.ordinary input) = some output) : + output = retainedCompletionAnswer parameter completedState rawCache baseStarts input := by + let table := retainedCompletionTable parameter completedState rawCache baseStarts + have htableQuery : ∀ coordinate cached, + queryState.values coordinate = some cached → cached = table coordinate := by + intro coordinate cached hvalue + exact (completedRealizedTable_of_value (splitFallback rawCache) parameter completedState + baseStarts coordinate cached (hvalues coordinate cached hvalue)).symm + rcases retainedCompletionAnswer_eq_fallback_or_exact_materialized parameter completedState + rawCache baseStarts input with hfallback | ⟨position, hots, _hposition, hinput, _hvalue⟩ + · rw [hfallback] + simp [splitFallback, hcached] + · subst input + have hreturns := verifierHashQuery_returns_table_of_uncached parameter table position hots + state queryState cache queryCache fuel queryRemaining output huncached htableQuery hquery + rw [retainedCompletionAnswer_realizes parameter completedState rawCache baseStarts position + hots] + exact hreturns.1 + +theorem ordinaryQueryCache_eq_cacheQuery_of_mem_runRaw_splitHashQuery_ordinary + (input : HashInput) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : HashOutput) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((splitHashQuery (.ordinary input)).run cache))) : + ordinaryQueryCache finalCache = (ordinaryQueryCache cache).cacheQuery input output := by + rw [splitHashQuery_run_eq] at hresult + cases hlookup : cache (.ordinary input) with + | some cached => + rw [hlookup] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + funext other + by_cases heq : other = input + · subst other + simp [QueryCache.cacheQuery, ordinaryQueryCache, hlookup] + · simp [QueryCache.cacheQuery, heq] + | none => + rw [hlookup] at hresult + dsimp only at hresult + rw [LazyRevealProbe.hashOutputQuery, + LazyRevealProbe.runRaw_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨sampled, _, hdone⟩ := hresult + simp [LazyRevealProbe.runRaw] at hdone + rcases hdone with ⟨rfl, rfl, rfl, rfl⟩ + exact ordinaryQueryCache_update cache input output + +def OrdinaryCachePreserving + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ state cache fuel finalState remaining value finalCache, + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + ordinaryQueryCache finalCache = ordinaryQueryCache cache + +def OrdinaryCacheQuerying (input : HashInput) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput) : Prop := + ∀ state cache fuel finalState remaining output finalCache, + LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + ordinaryQueryCache finalCache = (ordinaryQueryCache cache).cacheQuery input output + +theorem OrdinaryCachePreserving.of_splitCachePreserving + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + (hpreserves : SplitCachePreserving computation) : + OrdinaryCachePreserving computation := by + intro state cache fuel finalState remaining value finalCache hresult + rw [hpreserves state cache fuel finalState remaining value finalCache hresult] + +theorem RawReadOnly.ordinaryCachePreserving + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + (hreadonly : RawReadOnly computation) : OrdinaryCachePreserving computation := by + intro state cache fuel finalState remaining value finalCache hresult + rw [(hreadonly state cache fuel finalState remaining value finalCache hresult).2.2] + +theorem OrdinaryCachePreserving.bind + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : OrdinaryCachePreserving left) + (hnext : ∀ value, OrdinaryCachePreserving (next value)) : + OrdinaryCachePreserving (left >>= next) := by + intro state cache fuel finalState remaining value finalCache hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun result => (next result.1).run result.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining middleResult => + rcases middleResult with ⟨middleValue, middleCache⟩ + exact (hnext middleValue middleState middleCache middleRemaining finalState remaining value + finalCache hrest).trans + (hleft state cache fuel middleState middleRemaining middleValue middleCache hraw) + +def PreservesOrdinaryAbsence (input : HashInput) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ state cache fuel finalState remaining value finalCache, + cache (.ordinary input) = none → + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + finalCache (.ordinary input) = none + +theorem PreservesOrdinaryAbsence.pure (input : HashInput) (value : alpha) : + PreservesOrdinaryAbsence input + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro state cache fuel finalState remaining result finalCache hnone hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hnone + +theorem PreservesOrdinaryAbsence.bind + {input : HashInput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : PreservesOrdinaryAbsence input left) + (hnext : ∀ value, PreservesOrdinaryAbsence input (next value)) : + PreservesOrdinaryAbsence input (left >>= next) := by + intro state cache fuel finalState remaining value finalCache hnone hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun result => (next result.1).run result.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining middleResult => + rcases middleResult with ⟨middleValue, middleCache⟩ + exact hnext middleValue middleState middleCache middleRemaining finalState remaining value + finalCache (hleft state cache fuel middleState middleRemaining middleValue middleCache + hnone hraw) hrest + +theorem PreservesOrdinaryAbsence.sequenceFin + {input : HashInput} {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hcomputation : ∀ index, PreservesOrdinaryAbsence input (computation index)) : + PreservesOrdinaryAbsence input (sequenceFin computation) := by + induction n with + | zero => exact PreservesOrdinaryAbsence.pure input Fin.elim0 + | succ n ih => + rw [SphincsSecurity.Concrete.sequenceFin] + exact (hcomputation 0).bind fun _ => + (ih (fun index => computation index.succ) + (fun index => hcomputation index.succ)).bind fun _ => + PreservesOrdinaryAbsence.pure input _ + +theorem OrdinaryCachePreserving.preservesAbsence + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + (hpreserves : OrdinaryCachePreserving computation) (input : HashInput) : + PreservesOrdinaryAbsence input computation := by + intro state cache fuel finalState remaining value finalCache hnone hresult + change ordinaryQueryCache finalCache input = none + change ordinaryQueryCache cache input = none at hnone + rw [hpreserves state cache fuel finalState remaining value finalCache hresult] + exact hnone + +theorem preservesOrdinaryAbsence_simulateQ_ordinaryHashImpl_of_stable + (parameter : PublicParameter) (input : HashInput) + (hnotStable : ¬StableOrdinaryInput parameter input) + (computation : OracleComp HashSpec alpha) + (hstable : ∀ f : QueryImpl HashSpec Id, QueriesStable parameter f computation) : + PreservesOrdinaryAbsence input (simulateQ ordinaryHashImpl computation) := by + intro state cache fuel finalState remaining value finalCache hnone hresult + have hprojection := mem_runRaw_simulateQ_ordinaryHashImpl_projects computation state + finalState cache finalCache fuel remaining value hresult + obtain ⟨_, f, hf, _, _⟩ := exists_answerFn_replay_of_mem_support computation + (ordinaryQueryCache cache) value (ordinaryQueryCache finalCache) hprojection.2.2 + have hnot : input ∉ queriedInputs f computation := by + intro hinput + exact hnotStable (hstable f input hinput) + exact cache_eq_none_of_not_mem_queriedInputs computation (ordinaryQueryCache cache) value + (ordinaryQueryCache finalCache) hprojection.2.2 f hf input hnone hnot + +theorem OrdinaryCachePreserving.bind_querying + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput} + {input : HashInput} + (hleft : OrdinaryCachePreserving left) + (hnext : ∀ value, OrdinaryCacheQuerying input (next value)) : + OrdinaryCacheQuerying input (left >>= next) := by + intro state cache fuel finalState remaining output finalCache hresult + change LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun result => (next result.1).run result.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining middleResult => + rcases middleResult with ⟨middleValue, middleCache⟩ + rw [hnext middleValue middleState middleCache middleRemaining finalState remaining output + finalCache hrest, + hleft state cache fuel middleState middleRemaining middleValue middleCache hraw] + +theorem ordinaryCachePreserving_revealCoordinateOutput (coordinate : Coordinate) : + OrdinaryCachePreserving (revealCoordinateOutput coordinate) := by + intro state cache fuel finalState remaining value finalCache hresult + rw [revealCoordinateOutput_run, LazyRevealProbe.revealQuery, + LazyRevealProbe.runRaw_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some existing => + rw [hvalue] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ordinaryQueryCache_update_hidden cache coordinate value + | none => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨sampled, _, hsampled⟩ := hresult + by_cases hhit : state.hitAt coordinate sampled + · rw [if_pos hhit] at hsampled + simp at hsampled + · rw [if_neg hhit] at hsampled + simp [LazyRevealProbe.runRaw] at hsampled + rcases hsampled with ⟨rfl, rfl, rfl, rfl⟩ + exact ordinaryQueryCache_update_hidden cache coordinate value + +theorem ordinaryCachePreserving_revealCoordinate (coordinate : Coordinate) : + OrdinaryCachePreserving (revealCoordinate coordinate) := by + unfold revealCoordinate + exact (ordinaryCachePreserving_revealCoordinateOutput coordinate).bind fun _ => + OrdinaryCachePreserving.of_splitCachePreserving (SplitCachePreserving.pure _) + +theorem ordinaryCachePreserving_revealPositionValues (positions : List Position) : + OrdinaryCachePreserving (revealPositionValues positions) := by + induction positions with + | nil => exact OrdinaryCachePreserving.of_splitCachePreserving (SplitCachePreserving.pure []) + | cons position remaining ih => + rw [revealPositionValues] + exact (ordinaryCachePreserving_revealCoordinate (.position position)).bind fun _ => + ih.bind fun _ => OrdinaryCachePreserving.of_splitCachePreserving + (SplitCachePreserving.pure _) + +theorem ordinaryCachePreserving_revealTableInputChildren (coordinate : Coordinate) : + OrdinaryCachePreserving (revealTableInputChildren coordinate) := by + cases coordinate with + | chainStart => + exact OrdinaryCachePreserving.of_splitCachePreserving (SplitCachePreserving.pure ()) + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + by_cases hzero : step.val = 0 + · simp only [revealTableInputChildren, hzero, ↓reduceIte] + exact (ordinaryCachePreserving_revealCoordinate + (.chainStart lay tree leafIdx chainIdx)).bind fun _ => + OrdinaryCachePreserving.of_splitCachePreserving (SplitCachePreserving.pure ()) + · simp only [revealTableInputChildren, hzero, ↓reduceIte] + exact (ordinaryCachePreserving_revealPositionValues _).bind fun _ => + OrdinaryCachePreserving.of_splitCachePreserving (SplitCachePreserving.pure ()) + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp only [revealTableInputChildren] + exact (ordinaryCachePreserving_revealPositionValues _).bind fun _ => + OrdinaryCachePreserving.of_splitCachePreserving (SplitCachePreserving.pure ()) + +theorem OrdinaryCachePreserving.sequenceFin {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hcomputation : ∀ index, OrdinaryCachePreserving (computation index)) : + OrdinaryCachePreserving (sequenceFin computation) := by + induction n with + | zero => + simp only [SphincsSecurity.Concrete.sequenceFin] + exact OrdinaryCachePreserving.of_splitCachePreserving + (SplitCachePreserving.pure Fin.elim0) + | succ n ih => + rw [SphincsSecurity.Concrete.sequenceFin] + exact (hcomputation 0).bind fun _ => + (ih (fun index => computation index.succ) + (fun index => hcomputation index.succ)).bind fun _ => + OrdinaryCachePreserving.of_splitCachePreserving (SplitCachePreserving.pure _) + +theorem ordinaryCachePreserving_simulateQ_splitUniformImpl + (computation : ProbComp alpha) : + OrdinaryCachePreserving (simulateQ splitUniformImpl computation) := by + intro state cache fuel finalState remaining value finalCache hresult + exact congrArg ordinaryQueryCache + (mem_runRaw_simulateQ_splitUniformImpl_projects computation state finalState cache + finalCache fuel remaining value hresult).2.2.1 + +theorem ordinaryCachePreserving_maskedTreeNode + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) : + OrdinaryCachePreserving (maskedTreeNode lay tree level nodeIdx) := by + cases level with + | zero => + rw [maskedTreeNode] + exact (OrdinaryCachePreserving.of_splitCachePreserving + (splitCachePreserving_ensureTreeNode lay tree 0 nodeIdx)).bind fun _ => + ordinaryCachePreserving_revealCoordinate _ + | succ current => + rw [maskedTreeNode] + exact (OrdinaryCachePreserving.of_splitCachePreserving + (splitCachePreserving_ensureTreeNode lay tree (current + 1) nodeIdx)).bind fun _ => by + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact ordinaryCachePreserving_revealCoordinate _ + · rw [dif_neg hlevel] + exact OrdinaryCachePreserving.of_splitCachePreserving + (SplitCachePreserving.pure 0) + +theorem ordinaryCachePreserving_maskedTreeRoot (lay : Layer) (tree : TreeIndex) : + OrdinaryCachePreserving (maskedTreeRoot lay tree) := + ordinaryCachePreserving_maskedTreeNode lay tree (layerHeight lay) 0 + +theorem ordinaryCachePreserving_revealPublishedCoordinate (coordinate : Coordinate) : + OrdinaryCachePreserving (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + exact (ordinaryCachePreserving_revealCoordinate coordinate).bind fun _ => + (OrdinaryCachePreserving.of_splitCachePreserving + (splitCachePreserving_publishCoordinate coordinate)).bind fun _ => + OrdinaryCachePreserving.of_splitCachePreserving (SplitCachePreserving.pure _) + +theorem preservesOrdinaryAbsence_maskedLayerMessage + (parameter : PublicParameter) (input : HashInput) + (hnotStable : ¬StableOrdinaryInput parameter input) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + PreservesOrdinaryAbsence input (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + split + · exact (ordinaryCachePreserving_maskedTreeRoot _ _).preservesAbsence input + · exact preservesOrdinaryAbsence_simulateQ_ordinaryHashImpl_of_stable parameter input + hnotStable _ (fun f => queriesStable_ftsKey f parameter index (ftsSecret index)) + +theorem preservesOrdinaryAbsence_maskedOtsSignFrom + (parameter : PublicParameter) (input : HashInput) + (hnotStable : ¬StableOrdinaryInput parameter input) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter, + PreservesOrdinaryAbsence input + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, _ => PreservesOrdinaryAbsence.pure input none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + exact (preservesOrdinaryAbsence_simulateQ_ordinaryHashImpl_of_stable parameter input + hnotStable _ (fun f => queriesStable_encode f parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter))).bind fun encoded => + match encoded with + | none => preservesOrdinaryAbsence_maskedOtsSignFrom parameter input hnotStable + lay tree leafIdx message attempts (counter + 1) + | some encoding => + ((OrdinaryCachePreserving.of_splitCachePreserving + (splitCachePreserving_sequenceFin _ fun chainIdx => + splitCachePreserving_ensureChainPrefix lay tree leafIdx chainIdx + (encoding chainIdx))).bind fun _ => + OrdinaryCachePreserving.of_splitCachePreserving + (SplitCachePreserving.pure _)).preservesAbsence input + +theorem preservesOrdinaryAbsence_maskedOtsSign + (parameter : PublicParameter) (input : HashInput) + (hnotStable : ¬StableOrdinaryInput parameter input) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + PreservesOrdinaryAbsence input + (maskedOtsSign parameter lay tree leafIdx message) := + preservesOrdinaryAbsence_maskedOtsSignFrom parameter input hnotStable lay tree leafIdx message + encodingAttemptLimit 0 + +theorem preservesOrdinaryAbsence_maskedSignLayer + (parameter : PublicParameter) (input : HashInput) + (hnotStable : ¬StableOrdinaryInput parameter input) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + PreservesOrdinaryAbsence input (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + exact (preservesOrdinaryAbsence_maskedLayerMessage parameter input hnotStable ftsSecret index + lay).bind fun message => + (preservesOrdinaryAbsence_maskedOtsSign parameter input hnotStable lay + (treeIndexAt index lay) (leafIndexAt index lay) message).bind fun result => + match result with + | none => PreservesOrdinaryAbsence.pure input none + | some _ => + ((OrdinaryCachePreserving.of_splitCachePreserving + (splitCachePreserving_ensureTreePath lay (treeIndexAt index lay) + (leafIndexAt index lay))).bind fun _ => + OrdinaryCachePreserving.of_splitCachePreserving + (SplitCachePreserving.pure _)).preservesAbsence input + +theorem ordinaryCachePreserving_revealLayerValues + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + OrdinaryCachePreserving (revealLayerValues index lay encoding) := by + unfold revealLayerValues + exact (OrdinaryCachePreserving.sequenceFin _ fun chainIdx => + ordinaryCachePreserving_revealPublishedCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + (encoding chainIdx))).bind fun _ => + (OrdinaryCachePreserving.sequenceFin _ fun level => by + split + · cases hlevelValue : level.val with + | zero => exact ordinaryCachePreserving_revealPublishedCoordinate _ + | succ current => + rw [show current + 1 = Nat.succ current by omega] + change OrdinaryCachePreserving + (if hlevel : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hlevel⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0) + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact ordinaryCachePreserving_revealPublishedCoordinate _ + · rw [dif_neg hlevel] + exact OrdinaryCachePreserving.of_splitCachePreserving + (SplitCachePreserving.pure 0) + · exact OrdinaryCachePreserving.of_splitCachePreserving + (SplitCachePreserving.pure 0)).bind fun _ => + OrdinaryCachePreserving.of_splitCachePreserving + (SplitCachePreserving.pure _) + +theorem preservesOrdinaryAbsence_ordinarySignDigestLoop + (secretKey : SecretKey) (input : HashInput) + (hnotStable : ¬StableOrdinaryInput secretKey.parameter input) + (attempts : Nat) (message : Message) : + PreservesOrdinaryAbsence input + (simulateQ ordinaryRomImpl (signDigestLoop attempts secretKey message)) := by + induction attempts with + | zero => + rw [signDigestLoop, simulateQ_pure] + exact PreservesOrdinaryAbsence.pure input none + | succ attempts ih => + rw [signDigestLoop, simulateQ_bind] + have hrandomness : PreservesOrdinaryAbsence input + (simulateQ ordinaryRomImpl (liftM sampleRandomness)) := by + rw [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_left] + exact (ordinaryCachePreserving_simulateQ_splitUniformImpl sampleRandomness).preservesAbsence + input + exact hrandomness.bind fun randomness => by + rw [simulateQ_bind] + have hattempt : PreservesOrdinaryAbsence input + (simulateQ ordinaryRomImpl + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))))) := by + rw [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_right] + exact preservesOrdinaryAbsence_simulateQ_ordinaryHashImpl_of_stable + secretKey.parameter input hnotStable _ + (fun f => queriesStable_signAttempt f secretKey message randomness) + exact hattempt.bind fun attempt => by + cases attempt with + | none => exact ih + | some selected => exact PreservesOrdinaryAbsence.pure input _ + +theorem preservesOrdinaryAbsence_maskedSignAfterDigest + (parameter : PublicParameter) (input : HashInput) + (hnotStable : ¬StableOrdinaryInput parameter input) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + PreservesOrdinaryAbsence input + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest + exact (preservesOrdinaryAbsence_simulateQ_ordinaryHashImpl_of_stable parameter input + hnotStable _ (fun f => queriesStable_ftsOpen f parameter index leaves + (ftsSecret index))).bind fun _ => + (PreservesOrdinaryAbsence.sequenceFin _ fun lay => + preservesOrdinaryAbsence_maskedSignLayer parameter input hnotStable ftsSecret index + lay).bind fun layers => + match hparts : traverseOption layers with + | none => PreservesOrdinaryAbsence.pure input none + | some parts => + ((OrdinaryCachePreserving.sequenceFin _ fun lay => + ordinaryCachePreserving_revealLayerValues index lay + (parts lay).2).bind fun _ => + OrdinaryCachePreserving.of_splitCachePreserving + (SplitCachePreserving.pure _)).preservesAbsence input + +theorem preservesOrdinaryAbsence_maskedSign + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (hnotStable : ¬StableOrdinaryInput parameter input) + (message : Message) : + PreservesOrdinaryAbsence input (maskedSign parameter root ftsSecret message) := by + unfold maskedSign + exact (preservesOrdinaryAbsence_ordinarySignDigestLoop + (⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ : SecretKey) input hnotStable + digestAttemptLimit message).bind fun selected => + match selected with + | none => PreservesOrdinaryAbsence.pure input none + | some data => preservesOrdinaryAbsence_maskedSignAfterDigest parameter input hnotStable + ftsSecret data.1 data.2.1 data.2.2 + +theorem preservesOrdinaryAbsence_maskedSigningImpl + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (hnotStable : ¬StableOrdinaryInput parameter input) : + ∀ message, PreservesOrdinaryAbsence input + (maskedSigningImpl parameter root ftsSecret message) := + fun message => preservesOrdinaryAbsence_maskedSign parameter root ftsSecret input hnotStable + message + +theorem preservesPublishedValues_maskedLayerMessage + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + PreservesPublishedValues (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + split + · exact preservesPublishedValues_maskedTreeRoot _ _ + · exact preservesPublishedValues_simulateQ_ordinaryHashImpl _ + +theorem preservesPublishedValues_maskedOtsSignFrom + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter, + PreservesPublishedValues + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, _ => PreservesPublishedValues.pure none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + exact (preservesPublishedValues_simulateQ_ordinaryHashImpl _).bind fun encoded => + match encoded with + | none => preservesPublishedValues_maskedOtsSignFrom parameter lay tree leafIdx message + attempts (counter + 1) + | some encoding => + (PreservesPublishedValues.sequenceFin _ fun chainIdx => + preservesPublishedValues_ensureChainPrefix lay tree leafIdx chainIdx + (encoding chainIdx)).bind fun _ => PreservesPublishedValues.pure _ + +theorem preservesPublishedValues_maskedOtsSign + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : + PreservesPublishedValues (maskedOtsSign parameter lay tree leafIdx message) := + preservesPublishedValues_maskedOtsSignFrom parameter lay tree leafIdx message + encodingAttemptLimit 0 + +theorem preservesPublishedValues_maskedSignLayer + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + PreservesPublishedValues (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + exact (preservesPublishedValues_maskedLayerMessage parameter ftsSecret index lay).bind + fun message => + (preservesPublishedValues_maskedOtsSign parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message).bind fun result => + match result with + | none => PreservesPublishedValues.pure none + | some _ => (preservesPublishedValues_ensureTreePath lay (treeIndexAt index lay) + (leafIndexAt index lay)).bind fun _ => PreservesPublishedValues.pure _ + +theorem preservesPublishedValues_revealLayerValues + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + PreservesPublishedValues (revealLayerValues index lay encoding) := by + unfold revealLayerValues + exact (PreservesPublishedValues.sequenceFin _ fun chainIdx => + preservesPublishedValues_revealPublishedCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + (encoding chainIdx))).bind fun _ => + (PreservesPublishedValues.sequenceFin _ fun level => by + split + · cases hlevelValue : level.val with + | zero => exact preservesPublishedValues_revealPublishedCoordinate _ + | succ current => + rw [show current + 1 = Nat.succ current by omega] + change PreservesPublishedValues + (if hlevel : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hlevel⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0) + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact preservesPublishedValues_revealPublishedCoordinate _ + · rw [dif_neg hlevel] + exact PreservesPublishedValues.pure 0 + · exact PreservesPublishedValues.pure 0).bind fun _ => + PreservesPublishedValues.pure _ + +theorem preservesPublishedValues_ordinarySignDigestLoop + (secretKey : SecretKey) (attempts : Nat) (message : Message) : + PreservesPublishedValues + (simulateQ ordinaryRomImpl (signDigestLoop attempts secretKey message)) := by + induction attempts with + | zero => + rw [signDigestLoop, simulateQ_pure] + exact PreservesPublishedValues.pure none + | succ attempts ih => + rw [signDigestLoop, simulateQ_bind] + have hrandomness : PreservesPublishedValues + (simulateQ ordinaryRomImpl (liftM sampleRandomness)) := by + rw [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_left] + exact preservesPublishedValues_simulateQ_splitUniformImpl sampleRandomness + exact hrandomness.bind fun randomness => by + rw [simulateQ_bind] + have hattempt : PreservesPublishedValues + (simulateQ ordinaryRomImpl + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))))) := by + rw [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_right] + exact preservesPublishedValues_simulateQ_ordinaryHashImpl _ + exact hattempt.bind fun attempt => by + cases attempt with + | none => exact ih + | some selected => exact PreservesPublishedValues.pure _ + +theorem preservesPublishedValues_maskedSignAfterDigest + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + PreservesPublishedValues + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest + exact (preservesPublishedValues_simulateQ_ordinaryHashImpl _).bind fun _ => + (PreservesPublishedValues.sequenceFin _ fun lay => + preservesPublishedValues_maskedSignLayer parameter ftsSecret index lay).bind fun layers => + match traverseOption layers with + | none => PreservesPublishedValues.pure none + | some parts => (PreservesPublishedValues.sequenceFin _ fun lay => + preservesPublishedValues_revealLayerValues index lay (parts lay).2).bind fun _ => + PreservesPublishedValues.pure _ + +theorem preservesPublishedValues_maskedSign + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + PreservesPublishedValues (maskedSign parameter root ftsSecret message) := by + unfold maskedSign + exact (preservesPublishedValues_ordinarySignDigestLoop + (⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ : SecretKey) digestAttemptLimit + message).bind fun selected => match selected with + | none => PreservesPublishedValues.pure none + | some data => preservesPublishedValues_maskedSignAfterDigest parameter ftsSecret + data.1 data.2.1 data.2.2 + +theorem preservesPublishedValues_maskedSigningImpl + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ∀ message, PreservesPublishedValues (maskedSigningImpl parameter root ftsSecret message) := + fun message => preservesPublishedValues_maskedSign parameter root ftsSecret message + +theorem preservesPublishedValuesImpl_splitUniformImpl : + PreservesPublishedValuesImpl splitUniformImpl := by + intro n + simpa [splitUniformImpl] using preservesPublishedValues_simulateQ_splitUniformImpl + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) + +theorem preservesPublishedValuesImpl_probingHashImpl (parameter : PublicParameter) : + PreservesPublishedValuesImpl (probingHashImpl parameter) := + fun input => preservesPublishedValues_probingHashQuery parameter input + +theorem preservesPublishedValuesImpl_probingRomImpl (parameter : PublicParameter) : + PreservesPublishedValuesImpl (probingRomImpl parameter) := by + intro query + cases query with + | inl query => exact preservesPublishedValuesImpl_splitUniformImpl query + | inr query => exact preservesPublishedValuesImpl_probingHashImpl parameter query + +theorem preservesPublishedValuesImpl_verifierHashImpl (parameter : PublicParameter) : + PreservesPublishedValuesImpl (verifierHashImpl parameter) := + fun input => preservesPublishedValues_verifierHashQuery parameter input + +theorem preservesPublishedValuesImpl_verifierRomImpl (parameter : PublicParameter) : + PreservesPublishedValuesImpl (verifierRomImpl parameter) := by + intro query + cases query with + | inl query => exact preservesPublishedValuesImpl_splitUniformImpl query + | inr query => exact preservesPublishedValuesImpl_verifierHashImpl parameter query + +theorem preservesPublishedValuesImpl_maskedSigningImpl + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + PreservesPublishedValuesImpl (maskedSigningImpl parameter root ftsSecret) := + preservesPublishedValues_maskedSigningImpl parameter root ftsSecret + +theorem preservesPublishedValuesImpl_maskedExpandedAdversaryImpl + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + PreservesPublishedValuesImpl (maskedExpandedAdversaryImpl parameter root ftsSecret) := by + intro query + cases query with + | inl query => exact preservesPublishedValuesImpl_probingRomImpl parameter query + | inr query => exact preservesPublishedValuesImpl_maskedSigningImpl parameter root ftsSecret query + +theorem publishedValues_of_mem_runRaw_maskedRetainedGameAfterFtsSecrets + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel remaining : Nat) (rawState : LazyRevealProbe.State Coordinate) + (rawCache : SplitHashCache) (root : Digest) (forgery : Forgery) + (signingLog : QueryLog SigningSpec) (verified : Bool) + (hresult : LazyRevealProbe.RawResult.done rawState remaining + ((root, ((forgery, signingLog), verified)), rawCache) ∈ support + (LazyRevealProbe.runRaw (LazyRevealProbe.State.empty : + LazyRevealProbe.State Coordinate) fuel + ((maskedRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) : + PublishedValues rawState := by + let rootCoordinate : Coordinate := .position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0) + unfold maskedRetainedGameAfterFtsSecrets at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨rootRaw, hroot, hafterRoot⟩ := hresult + cases rootRaw with + | stopped hit => simp at hafterRoot + | done rootState rootRemaining rootResult => + rcases rootResult with ⟨sampledRoot, rootCache⟩ + simp only at hafterRoot + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hafterRoot + obtain ⟨publishRaw, hpublish, hafterPublish⟩ := hafterRoot + cases publishRaw with + | stopped hit => simp at hafterPublish + | done publishState publishRemaining publishResult => + rcases publishResult with ⟨publishedUnit, publishCache⟩ + simp only at hafterPublish + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterPublish + obtain ⟨restRaw, hrest, hfinish⟩ := hafterPublish + cases restRaw with + | stopped hit => simp at hfinish + | done restState restRemaining restResult => + rcases restResult with ⟨⟨prefixForgery, prefixLog⟩, restCache⟩ + simp only at hfinish + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hfinish + obtain ⟨verifyRaw, hverify, hreturn⟩ := hfinish + cases verifyRaw with + | stopped hit => simp at hreturn + | done verifyState verifyRemaining verifyResult => + rcases verifyResult with ⟨prefixVerified, verifyCache⟩ + simp [LazyRevealProbe.runRaw] at hreturn + rcases hreturn with ⟨rfl, rfl, _, rfl⟩ + have hpublishedEmpty : PublishedValues + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) := by + intro coordinate hcoordinate + simp [LazyRevealProbe.State.empty] at hcoordinate + have hpublishedRoot := preservesPublishedValues_maskedTreeRoot topLayer rootTree + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + emptySplitHashCache fuel rootState rootRemaining sampledRoot rootCache + hpublishedEmpty hroot + obtain ⟨rootOutput, _, hrootValue, _⟩ := + mem_runRaw_maskedTreeRoot_hidden topLayer rootTree + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) rootState + emptySplitHashCache rootCache fuel rootRemaining sampledRoot hroot + have hrootCoordinate : + maskedTreeRootCoordinate topLayer rootTree = rootCoordinate := by + simp [maskedTreeRootCoordinate, maskedTreeRootLevel, rootCoordinate, + layerHeight, topLayer, maxLayerHeight] + have hrootValue' : rootState.values rootCoordinate ≠ none := by + rw [← hrootCoordinate, hrootValue] + simp + have hpublishedPublish := publishedValues_of_mem_runRaw_publishCoordinate + rootCoordinate rootState publishState rootCache publishCache rootRemaining + publishRemaining publishedUnit hpublishedRoot hrootValue' + (by simpa [rootCoordinate] using hpublish) + have hpublishedRest := + (preservesPublishedValuesImpl_maskedExpandedAdversaryImpl parameter sampledRoot + ftsSecret).simulateQ + (signingTraceComputation (adversary.main ⟨sampledRoot, parameter⟩)) + publishState publishCache publishRemaining restState restRemaining + (prefixForgery, prefixLog) restCache hpublishedPublish hrest + exact (preservesPublishedValuesImpl_verifierRomImpl parameter).simulateQ + (scheme.verify ⟨sampledRoot, parameter⟩ prefixForgery.message + prefixForgery.signature) restState restCache restRemaining rawState + remaining prefixVerified rawCache hpublishedRest hverify + +theorem ordinaryCacheQuerying_modifyOrdinary_pure (input : HashInput) (answer : HashOutput) : + OrdinaryCacheQuerying input (do + modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some answer) + pure answer) := by + intro state cache fuel finalState remaining output finalCache hresult + simp [StateT.run_modify, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ordinaryQueryCache_update cache input output + +theorem ordinaryCacheQuerying_splitHashQuery (input : HashInput) : + OrdinaryCacheQuerying input (splitHashQuery (.ordinary input)) := by + intro state cache fuel finalState remaining output finalCache hresult + exact ordinaryQueryCache_eq_cacheQuery_of_mem_runRaw_splitHashQuery_ordinary input state + finalState cache finalCache fuel remaining output hresult + +theorem ordinaryCacheQuerying_resolveKnownInput + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) : + OrdinaryCacheQuerying input (resolveKnownInput parameter coordinate input) := by + unfold resolveKnownInput + apply (rawReadOnly_peekTableInput parameter coordinate).ordinaryCachePreserving.bind_querying + intro knownInput + cases knownInput with + | none => exact ordinaryCacheQuerying_splitHashQuery input + | some knownInput => + simp only + by_cases hexact : knownInput = input + · rw [if_pos hexact] + exact (ordinaryCachePreserving_revealCoordinateOutput coordinate).bind_querying fun answer => + (OrdinaryCachePreserving.of_splitCachePreserving + (splitCachePreserving_publishCoordinate coordinate)).bind_querying fun _ => + ordinaryCacheQuerying_modifyOrdinary_pure input answer + · rw [if_neg hexact] + exact ordinaryCacheQuerying_splitHashQuery input + +theorem ordinaryCachePreserving_prepareLeafInputProbe + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + OrdinaryCachePreserving (prepareLeafInputProbe input candidate lay tree leafIdx) := + OrdinaryCachePreserving.of_splitCachePreserving + (splitCachePreserving_prepareLeafInputProbe input candidate lay tree leafIdx) + +theorem ordinaryCacheQuerying_probingHashQuery + (parameter : PublicParameter) (input : HashInput) : + OrdinaryCacheQuerying input (probingHashQuery parameter input) := by + unfold probingHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases decodePosition? parameter input with + | some position => + cases position with + | leaf lay tree leafIdx => + exact (ordinaryCachePreserving_prepareLeafInputProbe input candidate lay tree + leafIdx).bind_querying fun _ => ordinaryCacheQuerying_resolveKnownInput parameter + candidate.outputCoordinate input + | chain | node | ftsLeaf | ftsNode | ftsRoots => + exact (OrdinaryCachePreserving.of_splitCachePreserving + (splitCachePreserving_probe candidate)).bind_querying fun _ => + ordinaryCacheQuerying_resolveKnownInput parameter + candidate.outputCoordinate input + | none => exact (OrdinaryCachePreserving.of_splitCachePreserving + (splitCachePreserving_probe candidate)).bind_querying fun _ => + ordinaryCacheQuerying_resolveKnownInput parameter candidate.outputCoordinate input + | none => + cases hposition : decodePosition? parameter input with + | none => exact ordinaryCacheQuerying_splitHashQuery input + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + exact ordinaryCacheQuerying_resolveKnownInput parameter + (.position (.chain lay tree leafIdx chainIdx step)) input + | leaf lay tree leafIdx => + exact ordinaryCacheQuerying_resolveKnownInput parameter + (.position (.leaf lay tree leafIdx)) input + | node lay tree level nodeIdx => + exact (OrdinaryCachePreserving.of_splitCachePreserving + (splitCachePreserving_probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map + Coordinate.position))).bind_querying fun _ => + ordinaryCacheQuerying_resolveKnownInput parameter + (.position (.node lay tree level nodeIdx)) input + | ftsLeaf | ftsNode | ftsRoots => exact ordinaryCacheQuerying_splitHashQuery input + +theorem ordinaryQueryCache_eq_cacheQuery_of_mem_runRaw_probingHashImpl + (parameter : PublicParameter) (input : HashInput) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : HashOutput) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((probingHashImpl parameter input).run cache))) : + ordinaryQueryCache finalCache = (ordinaryQueryCache cache).cacheQuery input output := by + exact ordinaryCacheQuerying_probingHashQuery parameter input state cache fuel finalState + remaining output finalCache hresult + +theorem ordinaryCacheQuerying_resolveVerifierInput + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) : + OrdinaryCacheQuerying input (resolveVerifierInput parameter coordinate input) := by + intro state cache fuel finalState remaining output finalCache hresult + unfold resolveVerifierInput at hresult + cases hcached : cache (.ordinary input) with + | some cached => + simp [StateT.run_get, hcached, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + funext other + by_cases heq : other = input + · subst other + simp [QueryCache.cacheQuery, ordinaryQueryCache, hcached] + · simp [QueryCache.cacheQuery, heq] + | none => + simp [StateT.run_get, hcached] at hresult + exact (ordinaryCachePreserving_revealTableInputChildren coordinate).bind_querying + (fun _ => ordinaryCacheQuerying_resolveKnownInput parameter coordinate input) + state cache fuel finalState remaining output finalCache hresult + +theorem ordinaryCacheQuerying_verifierHashQuery + (parameter : PublicParameter) (input : HashInput) : + OrdinaryCacheQuerying input (verifierHashQuery parameter input) := by + unfold verifierHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + exact (OrdinaryCachePreserving.of_splitCachePreserving + (splitCachePreserving_probe candidate)).bind_querying fun _ => + ordinaryCacheQuerying_resolveVerifierInput parameter candidate.outputCoordinate input + | none => + cases hposition : decodePosition? parameter input with + | none => exact ordinaryCacheQuerying_splitHashQuery input + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + exact ordinaryCacheQuerying_resolveVerifierInput parameter + (.position (.chain lay tree leafIdx chainIdx step)) input + | leaf lay tree leafIdx => + exact ordinaryCacheQuerying_resolveVerifierInput parameter + (.position (.leaf lay tree leafIdx)) input + | node lay tree level nodeIdx => + exact ordinaryCacheQuerying_resolveVerifierInput parameter + (.position (.node lay tree level nodeIdx)) input + | ftsLeaf | ftsNode | ftsRoots => exact ordinaryCacheQuerying_splitHashQuery input + +theorem ordinaryQueryCache_eq_cacheQuery_of_mem_runRaw_verifierHashImpl + (parameter : PublicParameter) (input : HashInput) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : HashOutput) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((verifierHashImpl parameter input).run cache))) : + ordinaryQueryCache finalCache = (ordinaryQueryCache cache).cacheQuery input output := by + exact ordinaryCacheQuerying_verifierHashQuery parameter input state cache fuel finalState + remaining output finalCache hresult + +theorem verifierHashImpl_output_eq_of_cached + (parameter : PublicParameter) (input : HashInput) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (output cached : HashOutput) (hcached : cache (.ordinary input) = some cached) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((verifierHashImpl parameter input).run cache))) : + output = cached := by + have hresult' : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((verifierHashQuery parameter input).run cache)) := by + simpa only [verifierHashImpl] using hresult + have hreturned := returnsCachedOrdinary_verifierHashQuery parameter input state cache fuel + finalState remaining output finalCache hresult' + have hpreserved := ordinaryEntryPreserving_verifierHashQuery parameter input input state cache + fuel finalState remaining output finalCache cached hcached hresult' + exact Option.some.inj (hreturned.symm.trans hpreserved) + +theorem verifierHashImpl_output_eq_retainedCompletionAnswer_of_uncached + (parameter : PublicParameter) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (input : HashInput) + (state queryState completedState : LazyRevealProbe.State Coordinate) + (cache queryCache rawCache : SplitHashCache) (fuel queryRemaining : Nat) + (output : HashOutput) + (huncached : cache (.ordinary input) = none) + (hquery : LazyRevealProbe.RawResult.done queryState queryRemaining + (output, queryCache) ∈ support + (LazyRevealProbe.runRaw state fuel ((verifierHashImpl parameter input).run cache))) + (hvalues : LazyRevealProbe.ValuesLE queryState completedState) + (hcached : rawCache (.ordinary input) = some output) : + output = retainedCompletionAnswer parameter completedState rawCache baseStarts input := by + apply verifierHashQuery_output_eq_retainedCompletionAnswer_of_uncached parameter baseStarts + input state queryState completedState cache queryCache rawCache fuel queryRemaining output + huncached + · simpa only [verifierHashImpl] using hquery + · exact hvalues + · exact hcached + +set_option maxRecDepth 50000 in +theorem replay_of_mem_runRaw_verifierHashImpl_of_initial_cacheAnswersAgreeOnRun + (parameter : PublicParameter) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (computation : OracleComp HashSpec alpha) + (state finalState completedState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : alpha) + (hcompleted : LazyRevealProbe.ValuesLE finalState completedState) + (hagrees : CacheAnswersAgreeOnRun (ordinaryQueryCache cache) + (retainedCompletionAnswer parameter completedState finalCache baseStarts) computation) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ (verifierHashImpl parameter) computation).run cache))) : + evalWithAnswerFn (retainedCompletionAnswer parameter completedState finalCache baseStarts) + computation = value ∧ + CachedRun (ordinaryQueryCache finalCache) + (retainedCompletionAnswer parameter completedState finalCache baseStarts) computation ∧ + CacheAnswersAgreeOnRun (ordinaryQueryCache finalCache) + (retainedCompletionAnswer parameter completedState finalCache baseStarts) computation := by + let f := retainedCompletionAnswer parameter completedState finalCache baseStarts + change evalWithAnswerFn f computation = value ∧ + CachedRun (ordinaryQueryCache finalCache) f computation ∧ + CacheAnswersAgreeOnRun (ordinaryQueryCache finalCache) f computation + change CacheAnswersAgreeOnRun (ordinaryQueryCache cache) f computation at hagrees + induction computation using OracleComp.inductionOn generalizing + state cache finalState fuel remaining value with + | pure result => + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨rfl, by simp [CachedRun, CacheAnswersAgreeOnRun]⟩ + | query_bind input next ih => + rw [simulateQ_query_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨queryRaw, hquery, hrest⟩ := hresult + cases queryRaw with + | stopped hit => simp at hrest + | done queryState queryRemaining queryResult => + rcases queryResult with ⟨answer, queryCache⟩ + have hcacheStep : ordinaryQueryCache queryCache = + (ordinaryQueryCache cache).cacheQuery input answer := + ordinaryQueryCache_eq_cacheQuery_of_mem_runRaw_verifierHashImpl parameter input state + queryState cache queryCache fuel queryRemaining answer hquery + have hcachedQuery : queryCache (.ordinary input) = some answer := by + have hpoint := congrFun hcacheStep input + simpa [ordinaryQueryCache, QueryCache.cacheQuery] using hpoint + have hcachedFinal : finalCache (.ordinary input) = some answer := + (ordinaryEntryPreservingImpl_verifierHashImpl parameter input).simulateQ + (next answer) queryState queryCache queryRemaining finalState remaining value + finalCache answer hcachedQuery hrest + have hfinput : f input = answer := by + cases hlookup : cache (.ordinary input) with + | some cached => + have hanswer := verifierHashImpl_output_eq_of_cached parameter input state + queryState cache queryCache fuel queryRemaining answer cached hlookup hquery + rw [hanswer] + exact hagrees input (by rw [queriedInputs_query_bind]; exact List.mem_cons_self) + cached hlookup + | none => + have hvaluesQueryFinal := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((simulateQ (verifierHashImpl parameter) (next answer)).run queryCache) + queryState finalState queryRemaining remaining (value, finalCache) hrest + exact (verifierHashImpl_output_eq_retainedCompletionAnswer_of_uncached parameter + baseStarts input state queryState completedState cache queryCache finalCache fuel + queryRemaining answer hlookup hquery (hvaluesQueryFinal.trans hcompleted) + hcachedFinal).symm + have hagreesTail : CacheAnswersAgreeOnRun (ordinaryQueryCache queryCache) f + (next answer) := by + intro query hqueryTail output hcached + rw [hcacheStep] at hcached + by_cases heq : query = input + · subst query + have houtput : output = answer := by + exact (Option.some.inj + (show some answer = some output by + simpa [QueryCache.cacheQuery] using hcached)).symm + rw [houtput] + exact hfinput + · apply hagrees query + · rw [queriedInputs_query_bind, hfinput] + exact List.mem_cons_of_mem input hqueryTail + · simpa [QueryCache.cacheQuery, heq] using hcached + obtain ⟨htailEval, htailCached, htailAgrees⟩ := ih answer queryState finalState queryCache + queryRemaining remaining value hcompleted hrest hagreesTail + constructor + · rw [evalWithAnswerFn_bind, + show evalWithAnswerFn f (liftM (HashSpec.query input)) = f input from + simulateQ_spec_query f input, hfinput] + exact htailEval + · constructor + · intro other hother + rw [queriedInputs_query_bind, hfinput] at hother + simp only [List.mem_cons] at hother + rcases hother with rfl | htail + · simp [ordinaryQueryCache, hcachedFinal] + · exact htailCached other htail + · intro other hother output hcached + rw [queriedInputs_query_bind, hfinput] at hother + simp only [List.mem_cons] at hother + rcases hother with rfl | htail + · change finalCache (.ordinary other) = some output at hcached + rw [hcachedFinal] at hcached + exact hfinput.trans (Option.some.inj hcached) + · exact htailAgrees other htail output hcached + +theorem verifierHashQuery_returns_table + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → HashOutput) (position : Position) (hots : IsOtsPosition position) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : HashOutput) + (hf : (ordinaryQueryCache finalCache).AgreesWithFn f) + (htable : ∀ coordinate cached, finalState.values coordinate = some cached → + cached = table coordinate) + (hrealizes : f (tableInput parameter table (.position position)) = + table (.position position)) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((verifierHashQuery parameter + (tableInput parameter table (.position position))).run cache))) : + output = table (.position position) ∧ + finalCache (.ordinary (tableInput parameter table (.position position))) = some output := by + cases hcached : cache (.ordinary + (tableInput parameter table (.position position))) with + | none => + exact verifierHashQuery_returns_table_of_uncached parameter table position hots state + finalState cache finalCache fuel remaining output hcached htable hresult + | some cached => + have hreturns := returnsCachedOrdinary_verifierHashQuery parameter + (tableInput parameter table (.position position)) state cache fuel finalState remaining + output finalCache hresult + have hanswer := hf hreturns + exact ⟨hanswer.symm.trans hrealizes, hreturns⟩ + +set_option maxRecDepth 10000 in +theorem probingHashQuery_returns_table_of_available + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (position : Position) (hots : IsOtsPosition position) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : HashOutput) + (havailable : TableInputAvailable table state (.position position)) + (htable : ∀ other cached, finalState.values other = some cached → + cached = table other) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((probingHashQuery parameter + (tableInput parameter table (.position position))).run cache))) : + output = table (.position position) ∧ + finalCache (.ordinary (tableInput parameter table (.position position))) = some output := by + let input := tableInput parameter table (.position position) + have hposition : decodePosition? parameter input = some position := + (decodePosition?_eq_some_iff parameter input position).2 ⟨tablePayload table position, rfl⟩ + change LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel ((probingHashQuery parameter input).run cache)) + at hresult + cases hprobe : decodeProbe? parameter input with + | some candidate => + unfold probingHashQuery at hresult + rw [hprobe, hposition] at hresult + cases position with + | leaf lay tree leafIdx => + simp only at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨probeRaw, hprobeRun, hrest⟩ := hresult + cases probeRaw with + | stopped hit => simp at hrest + | done probeState probeRemaining probeResult => + rcases probeResult with ⟨probed, probeCache⟩ + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((prepareLeafInputProbe input candidate lay tree leafIdx).run cache) state + probeState fuel probeRemaining (probed, probeCache) hprobeRun + have havailableProbe := havailable.monoValues hvaluesLE + have houtputCoordinate := decodeProbe?_outputCoordinate_eq_position parameter input + candidate (.leaf lay tree leafIdx) hprobe hposition + rw [houtputCoordinate] at hrest + exact resolveKnownInput_returns_table_of_available parameter table + (.position (.leaf lay tree leafIdx)) probeState finalState probeCache finalCache + probeRemaining remaining output havailableProbe htable hrest + | chain lay tree leafIdx chainIdx step => + simp only at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨probeRaw, hprobeRun, hrest⟩ := hresult + cases probeRaw with + | stopped hit => simp at hrest + | done probeState probeRemaining probeResult => + rcases probeResult with ⟨probed, probeCache⟩ + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((probe candidate).run cache) state probeState fuel probeRemaining + (probed, probeCache) hprobeRun + have havailableProbe := havailable.monoValues hvaluesLE + have houtputCoordinate := decodeProbe?_outputCoordinate_eq_position parameter input + candidate (.chain lay tree leafIdx chainIdx step) hprobe hposition + rw [houtputCoordinate] at hrest + exact resolveKnownInput_returns_table_of_available parameter table + (.position (.chain lay tree leafIdx chainIdx step)) probeState finalState probeCache + finalCache probeRemaining remaining output havailableProbe htable hrest + | node lay tree level nodeIdx => + have hnone : decodeProbe? parameter input = none := by + apply decodeProbe?_tweakableHashInput_of_not_chain_leaf parameter + (Position.node lay tree level nodeIdx).domain + (tablePayload table (.node lay tree level nodeIdx)) + (Position.domain_inRange (.node lay tree level nodeIdx)) + · intro otherLay otherTree otherLeaf otherChain otherStep heq + simp [Position.domain] at heq + · intro otherLay otherTree otherLeaf heq + simp [Position.domain] at heq + rw [hnone] at hprobe + simp at hprobe + | ftsLeaf | ftsNode | ftsRoots => simp [IsOtsPosition] at hots + | none => + unfold probingHashQuery at hresult + rw [hprobe, hposition] at hresult + cases position with + | chain lay tree leafIdx chainIdx step => + simp only at hresult + exact resolveKnownInput_returns_table_of_available parameter table + (.position (.chain lay tree leafIdx chainIdx step)) state finalState cache finalCache + fuel remaining output havailable htable hresult + | leaf lay tree leafIdx => + simp only at hresult + exact resolveKnownInput_returns_table_of_available parameter table + (.position (.leaf lay tree leafIdx)) state finalState cache finalCache fuel remaining + output havailable htable hresult + | node lay tree level nodeIdx => + simp only at hresult + let coordinates := (Position.node lay tree level nodeIdx).children.map Coordinate.position + have hvalues : ∀ coordinate, coordinate ∈ coordinates → + state.values coordinate = some (table coordinate) := by + intro coordinate hcoordinate + obtain ⟨child, hchild, heq⟩ := List.mem_map.1 hcoordinate + rw [← heq] + exact havailable child hchild + have hscan := runRaw_probeFirstMissingInputCoordinate_of_values table input state cache + fuel 0 coordinates hvalues + change LazyRevealProbe.RawResult.done finalState remaining + (output, finalCache) ∈ support (LazyRevealProbe.runRaw state fuel + ((probeFirstMissingInputCoordinate input 0 coordinates).run cache >>= + fun probeResult => (resolveKnownInput parameter + (.position (.node lay tree level nodeIdx)) input).run probeResult.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, hscan, pure_bind] at hresult + exact resolveKnownInput_returns_table_of_available parameter table + (.position (.node lay tree level nodeIdx)) state finalState cache finalCache fuel + remaining output havailable htable hresult + | ftsLeaf | ftsNode | ftsRoots => simp [IsOtsPosition] at hots + +noncomputable def chainInputSource (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (step : ChainStep) : Coordinate := + if hzero : step.val = 0 then + .chainStart lay tree leafIdx chainIdx + else + .position (.chain lay tree leafIdx chainIdx + ⟨step.val - 1, by have := step.isLt; omega⟩) + +noncomputable def chainInputProbe (table : Coordinate → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (step : ChainStep) : Probe := + ⟨chainInputSource lay tree leafIdx chainIdx step, + truncateHash (table (chainInputSource lay tree leafIdx chainIdx step))⟩ + +theorem chainInputProbe_matchesInput + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (step : ChainStep) : + (chainInputProbe table lay tree leafIdx chainIdx step).MatchesInput parameter + (tableInput parameter table + (.position (.chain lay tree leafIdx chainIdx step))) := by + by_cases hzero : step.val = 0 + · simp only [chainInputProbe, chainInputSource, hzero, ↓reduceDIte, Probe.MatchesInput] + refine ⟨step, hzero, ?_⟩ + simp [tableInput, tablePayload, hzero, Position.domain] + · have hpositive : 0 < step.val := Nat.pos_of_ne_zero hzero + let previous : ChainStep := ⟨step.val - 1, by have := step.isLt; omega⟩ + have hnext : previous.val + 1 < chainLength - 1 := by + simp only [previous] + have := step.isLt + omega + simp only [chainInputProbe, chainInputSource, hzero, ↓reduceDIte, Probe.MatchesInput] + rw [dif_pos hnext] + refine ⟨step, ?_, ?_⟩ + · omega + · simp [tableInput, tablePayload, hzero, Position.children, hpositive, tableValue, + Position.domain] + +@[simp] theorem chainInputProbe_candidate + (table : Coordinate → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (step : ChainStep) : + (chainInputProbe table lay tree leafIdx chainIdx step).candidate = + truncateHash (table (chainInputSource lay tree leafIdx chainIdx step)) := rfl + +set_option maxRecDepth 10000 in +theorem probingHashQuery_chain_returns_table_or_pending + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (step : ChainStep) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remainingFuel : Nat) + (output : HashOutput) + (hstateTable : ∀ coordinate cached, + state.values coordinate = some cached → cached = table coordinate) + (hfinalTable : ∀ coordinate cached, + finalState.values coordinate = some cached → cached = table coordinate) + (hrevealed : PublishedValues state) + (hresult : LazyRevealProbe.RawResult.done finalState remainingFuel + (output, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((probingHashQuery parameter + (tableInput parameter table + (.position (.chain lay tree leafIdx chainIdx step)))).run cache))) : + output = table (.position (.chain lay tree leafIdx chainIdx step)) ∨ + ∃ coordinate : Coordinate, + finalState.values coordinate = none ∧ + finalState.hitAt coordinate (table coordinate) := by + let position : Position := .chain lay tree leafIdx chainIdx step + let input := tableInput parameter table (.position position) + let source := chainInputSource lay tree leafIdx chainIdx step + let candidate := chainInputProbe table lay tree leafIdx chainIdx step + have hmatches : candidate.MatchesInput parameter input := by + simpa [candidate, input, position] using + chainInputProbe_matchesInput parameter table lay tree leafIdx chainIdx step + have hdecode : decodeProbe? parameter input = some candidate := + (decodeProbe?_eq_some_iff parameter input candidate).2 hmatches + have hposition : decodePosition? parameter input = some position := + (decodePosition?_eq_some_iff parameter input position).2 + ⟨tablePayload table position, rfl⟩ + have hsource : candidate.coordinate = source := rfl + cases hvalue : state.values source with + | some value => + left + have hvalue' : state.values source = some (table source) := by + rw [hvalue, hstateTable source value hvalue] + have havailable : TableInputAvailable table state (.position position) := by + by_cases hzero : step.val = 0 + · simpa [TableInputAvailable, position, source, chainInputSource, hzero] using hvalue' + · have hpositive : 0 < step.val := Nat.pos_of_ne_zero hzero + simp only [position, TableInputAvailable, if_neg hzero] + intro child hchild + have hchildEq : .position child = source := by + simp only [Position.children, dif_pos hpositive, + List.mem_singleton] at hchild + subst child + simp [source, chainInputSource, hzero] + rw [hchildEq] + exact hvalue' + exact (probingHashQuery_returns_table_of_available parameter table position (by trivial) + state finalState cache finalCache fuel remainingFuel output havailable hfinalTable + (by simpa [input, position] using hresult)).1 + | none => + have hnotRevealed : source ∉ state.revealed := by + intro hsourceRevealed + exact (hrevealed source hsourceRevealed) hvalue + change LazyRevealProbe.RawResult.done finalState remainingFuel (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((probingHashQuery parameter input).run cache)) at hresult + unfold probingHashQuery at hresult + rw [hdecode, hposition, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨probeRaw, hprobe, hresolve⟩ := hresult + cases probeRaw with + | stopped hit => simp at hresolve + | done probeState probeRemaining probeResult => + rcases probeResult with ⟨probed, probeCache⟩ + change LazyRevealProbe.RawResult.done probeState probeRemaining + (probed, probeCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate >>= + fun result => pure (result, cache))) at hprobe + rw [LazyRevealProbe.probeQuery, + LazyRevealProbe.runRaw_probe_query_bind] at hprobe + cases fuel with + | zero => simp at hprobe + | succ probeFuel => + simp only at hprobe + rw [hsource, if_neg hnotRevealed] at hprobe + simp [LazyRevealProbe.runRaw] at hprobe + rcases hprobe with ⟨rfl, rfl, rfl, rfl⟩ + right + refine ⟨source, ?_⟩ + have hhit : (state.addPending source candidate.candidate).hitAt source + (table source) := by + rw [LazyRevealProbe.State.hitAt, ← chainInputProbe_candidate table lay tree + leafIdx chainIdx step] + exact LazyRevealProbe.State.pendingAt_addPending_self state source + candidate.candidate + exact LazyRevealProbe.pendingHit_preserved_of_mem_runRaw_done + ((resolveKnownInput parameter candidate.outputCoordinate input).run cache) + source (table source) (state.addPending source candidate.candidate) finalState + probeRemaining remainingFuel (output, finalCache) (by + simpa [LazyRevealProbe.State.addPending] using hvalue) hhit + (hfinalTable source) hresolve + +set_option maxRecDepth 10000 in +theorem probingHashQuery_node_returns_table_or_pending + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (lay : Layer) (tree : TreeIndex) (level : Fin maxLayerHeight) + (nodeIdx : LeafIndex) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remainingFuel : Nat) + (output : HashOutput) + (hstateTable : ∀ position cached, + state.values (.position position) = some cached → + cached = table (.position position)) + (hfinalTable : ∀ coordinate cached, + finalState.values coordinate = some cached → cached = table coordinate) + (hrevealed : ∀ coordinate, coordinate ∈ state.revealed → + state.values coordinate ≠ none) + (hresult : LazyRevealProbe.RawResult.done finalState remainingFuel + (output, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((probingHashQuery parameter + (tableInput parameter table + (.position (.node lay tree level nodeIdx)))).run cache))) : + output = table (.position (.node lay tree level nodeIdx)) ∨ + ∃ child : Position, + finalState.values (.position child) = none ∧ + finalState.hitAt (.position child) (table (.position child)) := by + let position : Position := .node lay tree level nodeIdx + let input := tableInput parameter table (.position position) + rcases positionValues_or_first_missing table state position.children hstateTable with + havailable | ⟨prior, child, remaining, hchildren, hprior, hmissing⟩ + · left + exact (probingHashQuery_returns_table_of_available parameter table position (by trivial) + state finalState cache finalCache fuel remainingFuel output (by + intro child hchild + exact havailable child hchild) hfinalTable (by simpa [input, position] using hresult)).1 + · have hnotRevealed : .position child ∉ state.revealed := by + intro hchild + exact (hrevealed (.position child) hchild) hmissing + cases fuel with + | zero => + have hposition : decodePosition? parameter input = some position := + (decodePosition?_eq_some_iff parameter input position).2 + ⟨tablePayload table position, rfl⟩ + have hprobe : decodeProbe? parameter input = none := by + apply decodeProbe?_tweakableHashInput_of_not_chain_leaf parameter position.domain + (tablePayload table position) position.domain_inRange + · intro otherLay otherTree otherLeaf otherChain otherStep heq + simp [position, Position.domain] at heq + · intro otherLay otherTree otherLeaf heq + simp [position, Position.domain] at heq + let priorCoordinates := prior.map Coordinate.position + let remainingCoordinates := remaining.map Coordinate.position + have hcoordinates : position.children.map Coordinate.position = + priorCoordinates ++ .position child :: remainingCoordinates := by + simp only [hchildren, priorCoordinates, remainingCoordinates, List.map_append, + List.map_cons] + have hcoordinateValues : ∀ coordinate, coordinate ∈ priorCoordinates → + state.values coordinate = some (table coordinate) := by + intro coordinate hcoordinate + obtain ⟨other, hother, rfl⟩ := List.mem_map.1 hcoordinate + exact hprior other hother + have hscan := + runRaw_probeFirstMissingInputCoordinate_zero_of_prefix_values_of_missing table input + state cache 0 priorCoordinates remainingCoordinates (.position child) + hcoordinateValues hmissing + change LazyRevealProbe.RawResult.done finalState remainingFuel (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state 0 + ((probingHashQuery parameter input).run cache)) at hresult + unfold probingHashQuery at hresult + rw [hprobe, hposition] at hresult + simp only [position] at hresult + rw [hcoordinates, StateT.run_bind, LazyRevealProbe.runRaw_bind, hscan] at hresult + simp at hresult + | succ fuel => + have hpending := probingHashQuery_node_pending_of_prefix_values_of_missing parameter table + lay tree level nodeIdx state finalState cache finalCache fuel remainingFuel prior + remaining child output hchildren hprior hmissing hnotRevealed (by + simpa [input, position, Nat.succ_eq_add_one] using hresult) + right + refine ⟨child, ?_, ?_⟩ + · rw [hpending.1] + simpa [LazyRevealProbe.State.addPending] using hmissing + · rw [hpending.1, LazyRevealProbe.State.hitAt] + exact LazyRevealProbe.State.pendingAt_addPending_self state (.position child) + (truncateHash (table (.position child))) + +set_option maxRecDepth 10000 in +theorem probingHashQuery_leaf_returns_table_or_pending + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remainingFuel : Nat) + (output : HashOutput) + (hstateTable : ∀ position cached, + state.values (.position position) = some cached → + cached = table (.position position)) + (hfinalTable : ∀ coordinate cached, + finalState.values coordinate = some cached → cached = table coordinate) + (hrevealed : ∀ coordinate, coordinate ∈ state.revealed → + state.values coordinate ≠ none) + (hresult : LazyRevealProbe.RawResult.done finalState remainingFuel + (output, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((probingHashQuery parameter + (tableInput parameter table + (.position (.leaf lay tree leafIdx)))).run cache))) : + output = table (.position (.leaf lay tree leafIdx)) ∨ + ∃ child : Position, + finalState.values (.position child) = none ∧ + finalState.hitAt (.position child) (table (.position child)) := by + let position : Position := .leaf lay tree leafIdx + let input := tableInput parameter table (.position position) + rcases positionValues_or_first_missing table state position.children hstateTable with + havailable | ⟨prior, child, remaining, hchildren, hprior, hmissing⟩ + · left + exact (probingHashQuery_returns_table_of_available parameter table position (by trivial) + state finalState cache finalCache fuel remainingFuel output (by + intro child hchild + exact havailable child hchild) hfinalTable (by simpa [input, position] using hresult)).1 + · have hnotRevealed : .position child ∉ state.revealed := by + intro hchild + exact (hrevealed (.position child) hchild) hmissing + cases fuel with + | zero => + let candidate : Probe := + ⟨.position (.chain lay tree leafIdx ⟨0, by norm_num [numChains]⟩ + Position.lastChainStep), slotDigest 0 input⟩ + have hprobe : decodeProbe? parameter input = some candidate := by + apply (decodeProbe?_eq_some_iff parameter input candidate).2 + simp only [candidate, Probe.MatchesInput] + rw [dif_neg (by simp [Position.lastChainStep, chainLength, winternitzBits])] + exact ⟨trivial, tablePayload table position, rfl, trivial⟩ + have hposition : decodePosition? parameter input = some position := + (decodePosition?_eq_some_iff parameter input position).2 + ⟨tablePayload table position, rfl⟩ + have hprepare := + runRaw_prepareLeafInputProbe_zero_of_prefix_values_of_missing parameter table lay tree + leafIdx candidate state cache prior remaining child (by simpa [input, position] + using hprobe) hchildren hprior hmissing + change LazyRevealProbe.RawResult.done finalState remainingFuel (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state 0 + ((probingHashQuery parameter input).run cache)) at hresult + unfold probingHashQuery at hresult + rw [hprobe, hposition] at hresult + simp only [position] at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, hprepare] at hresult + simp at hresult + | succ fuel => + have hpending := probingHashQuery_leaf_pending_of_prefix_values_of_missing parameter table + lay tree leafIdx state finalState cache finalCache fuel remainingFuel prior remaining child + output hchildren hprior hmissing hnotRevealed (by + simpa [input, position, Nat.succ_eq_add_one] using hresult) + right + refine ⟨child, ?_, ?_⟩ + · rw [hpending.1] + simpa [LazyRevealProbe.State.addPending] using hmissing + · rw [hpending.1, LazyRevealProbe.State.hitAt] + exact LazyRevealProbe.State.pendingAt_addPending_self state (.position child) + (truncateHash (table (.position child))) + +def IsCanonicalOtsPosition : Position → Prop + | .chain _ _ _ _ _ | .leaf _ _ _ | .node _ _ _ _ => True + | _ => False + +def CanonicalInputProtected (table : Coordinate → HashOutput) + (input : HashInput) (position : Position) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) : Prop := + cache (.ordinary input) = none ∨ + cache (.ordinary input) = some (table (.position position)) ∨ + ∃ coordinate : Coordinate, + state.values coordinate = none ∧ + state.hitAt coordinate (table coordinate) + +set_option maxRecDepth 10000 in +theorem canonicalInputProtected_probingHashQuery + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (input query : HashInput) (position : Position) (hkind : IsCanonicalOtsPosition position) + (hinput : input = tableInput parameter table (.position position)) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : HashSpec query) + (hprotected : CanonicalInputProtected table input position state cache) + (hstateTable : ∀ coordinate cached, + state.values coordinate = some cached → cached = table coordinate) + (hfinalTable : ∀ coordinate cached, + finalState.values coordinate = some cached → cached = table coordinate) + (hrevealed : PublishedValues state) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((probingHashQuery parameter query).run cache))) : + CanonicalInputProtected table input position finalState finalCache := by + rcases hprotected with hnone | hexact | ⟨coordinate, hmissing, hhit⟩ + · by_cases heq : query = input + · subst query + have hlocal : output = table (.position position) ∨ + ∃ coordinate : Coordinate, + finalState.values coordinate = none ∧ + finalState.hitAt coordinate (table coordinate) := by + subst input + cases position with + | chain lay tree leafIdx chainIdx step => + exact probingHashQuery_chain_returns_table_or_pending parameter table lay tree leafIdx + chainIdx step state finalState cache finalCache fuel remaining output hstateTable + hfinalTable hrevealed hresult + | leaf lay tree leafIdx => + rcases probingHashQuery_leaf_returns_table_or_pending parameter table lay tree leafIdx + state finalState cache finalCache fuel remaining output (by + intro child cached hcached + exact hstateTable (.position child) cached hcached) hfinalTable hrevealed hresult with + houtput | ⟨child, hmissing, hhit⟩ + · exact Or.inl houtput + · exact Or.inr ⟨.position child, hmissing, hhit⟩ + | node lay tree level nodeIdx => + rcases probingHashQuery_node_returns_table_or_pending parameter table lay tree level + nodeIdx state finalState cache finalCache fuel remaining output (by + intro child cached hcached + exact hstateTable (.position child) cached hcached) hfinalTable hrevealed hresult with + houtput | ⟨child, hmissing, hhit⟩ + · exact Or.inl houtput + · exact Or.inr ⟨.position child, hmissing, hhit⟩ + | ftsLeaf | ftsNode | ftsRoots => simp [IsCanonicalOtsPosition] at hkind + rcases hlocal with houtput | hpending + · right + left + have hcache := ordinaryQueryCache_eq_cacheQuery_of_mem_runRaw_probingHashImpl parameter + input state finalState cache finalCache fuel remaining output hresult + change finalCache (.ordinary input) = some (table (.position position)) + change ordinaryQueryCache finalCache input = some (table (.position position)) + rw [hcache] + simp [QueryCache.cacheQuery, houtput] + · exact Or.inr (Or.inr hpending) + · left + have hcache := ordinaryQueryCache_eq_cacheQuery_of_mem_runRaw_probingHashImpl parameter + query state finalState cache finalCache fuel remaining output hresult + change finalCache (.ordinary input) = none + change ordinaryQueryCache finalCache input = none + rw [hcache] + rw [QueryCache.cacheQuery_of_ne _ _ (Ne.symm heq)] + exact hnone + · by_cases heq : query = input + · subst query + have hlocal : output = table (.position position) ∨ + ∃ coordinate : Coordinate, + finalState.values coordinate = none ∧ + finalState.hitAt coordinate (table coordinate) := by + subst input + cases position with + | chain lay tree leafIdx chainIdx step => + exact probingHashQuery_chain_returns_table_or_pending parameter table lay tree leafIdx + chainIdx step state finalState cache finalCache fuel remaining output hstateTable + hfinalTable hrevealed hresult + | leaf lay tree leafIdx => + rcases probingHashQuery_leaf_returns_table_or_pending parameter table lay tree leafIdx + state finalState cache finalCache fuel remaining output (by + intro child cached hcached + exact hstateTable (.position child) cached hcached) hfinalTable hrevealed hresult with + houtput | ⟨child, hmissing, hhit⟩ + · exact Or.inl houtput + · exact Or.inr ⟨.position child, hmissing, hhit⟩ + | node lay tree level nodeIdx => + rcases probingHashQuery_node_returns_table_or_pending parameter table lay tree level + nodeIdx state finalState cache finalCache fuel remaining output (by + intro child cached hcached + exact hstateTable (.position child) cached hcached) hfinalTable hrevealed hresult with + houtput | ⟨child, hmissing, hhit⟩ + · exact Or.inl houtput + · exact Or.inr ⟨.position child, hmissing, hhit⟩ + | ftsLeaf | ftsNode | ftsRoots => simp [IsCanonicalOtsPosition] at hkind + rcases hlocal with houtput | hpending + · right + left + have hcache := ordinaryQueryCache_eq_cacheQuery_of_mem_runRaw_probingHashImpl parameter + input state finalState cache finalCache fuel remaining output hresult + change finalCache (.ordinary input) = some (table (.position position)) + change ordinaryQueryCache finalCache input = some (table (.position position)) + rw [hcache] + simp [QueryCache.cacheQuery, houtput] + · exact Or.inr (Or.inr hpending) + · right + left + have hcache := ordinaryQueryCache_eq_cacheQuery_of_mem_runRaw_probingHashImpl parameter + query state finalState cache finalCache fuel remaining output hresult + change finalCache (.ordinary input) = some (table (.position position)) + change ordinaryQueryCache finalCache input = some (table (.position position)) + rw [hcache] + rw [QueryCache.cacheQuery_of_ne _ _ (Ne.symm heq)] + exact hexact + · right + right + have hpersist := LazyRevealProbe.pendingHit_preserved_of_mem_runRaw_done + ((probingHashQuery parameter query).run cache) coordinate + (table coordinate) state finalState fuel remaining (output, finalCache) + hmissing hhit (hfinalTable coordinate) hresult + exact ⟨coordinate, hpersist⟩ + +theorem canonicalInputProtected_of_cache_status_preserved + (table : Coordinate → HashOutput) (input : HashInput) (position : Position) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (habsence : PreservesOrdinaryAbsence input computation) + (hentry : OrdinaryEntryPreserving input computation) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : alpha) + (hprotected : CanonicalInputProtected table input position state cache) + (hfinalTable : ∀ coordinate cached, + finalState.values coordinate = some cached → cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache))) : + CanonicalInputProtected table input position finalState finalCache := by + rcases hprotected with hnone | hexact | ⟨coordinate, hmissing, hhit⟩ + · left + exact habsence state cache fuel finalState remaining value finalCache hnone hresult + · right + left + exact hentry state cache fuel finalState remaining value finalCache + (table (.position position)) hexact hresult + · right + right + have hpersist := LazyRevealProbe.pendingHit_preserved_of_mem_runRaw_done + (computation.run cache) coordinate (table coordinate) state finalState fuel + remaining (value, finalCache) hmissing hhit (hfinalTable coordinate) hresult + exact ⟨coordinate, hpersist⟩ + +theorem OrdinaryCachePreserving.entryPreserving + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + (hpreserves : OrdinaryCachePreserving computation) (input : HashInput) : + OrdinaryEntryPreserving input computation := by + intro state cache fuel finalState remaining value finalCache output hcached hresult + change ordinaryQueryCache finalCache input = some output + rw [hpreserves state cache fuel finalState remaining value finalCache hresult] + exact hcached + +theorem not_stableOrdinaryInput_of_canonical_ots_tableInput + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (position : Position) (hkind : IsCanonicalOtsPosition position) : + ¬StableOrdinaryInput parameter + (tableInput parameter table (.position position)) := by + intro hstable + have hposition : decodePosition? parameter + (tableInput parameter table (.position position)) = some position := + (decodePosition?_eq_some_iff parameter _ position).2 + ⟨tablePayload table position, rfl⟩ + apply hstable.2 position hposition + cases position <;> simp [IsCanonicalOtsPosition, IsOtsPosition] at hkind ⊢ + +theorem canonicalInputProtected_splitUniformImpl + (table : Coordinate → HashOutput) (input : HashInput) (position : Position) + (n : Nat) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : unifSpec n) + (hprotected : CanonicalInputProtected table input position state cache) + (hfinalTable : ∀ coordinate cached, + finalState.values coordinate = some cached → cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel ((splitUniformImpl n).run cache))) : + CanonicalInputProtected table input position finalState finalCache := by + have hpreserves : OrdinaryCachePreserving (splitUniformImpl n) := by + have hbase := ordinaryCachePreserving_simulateQ_splitUniformImpl + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) + simpa [splitUniformImpl] using hbase + exact canonicalInputProtected_of_cache_status_preserved table input position + (splitUniformImpl n) (hpreserves.preservesAbsence input) (hpreserves.entryPreserving input) + state finalState cache finalCache fuel remaining output hprotected hfinalTable hresult + +theorem canonicalInputProtected_maskedSigningImpl + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (position : Position) (hkind : IsCanonicalOtsPosition position) + (hinput : input = tableInput parameter table (.position position)) + (message : SignRequest) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (output : SigningSpec message) + (hprotected : CanonicalInputProtected table input position state cache) + (hfinalTable : ∀ coordinate cached, + finalState.values coordinate = some cached → cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((maskedSigningImpl parameter root ftsSecret message).run cache))) : + CanonicalInputProtected table input position finalState finalCache := by + have hnotStable : ¬StableOrdinaryInput parameter input := by + subst input + exact not_stableOrdinaryInput_of_canonical_ots_tableInput parameter table position hkind + exact canonicalInputProtected_of_cache_status_preserved table input position + (maskedSigningImpl parameter root ftsSecret message) + (preservesOrdinaryAbsence_maskedSigningImpl parameter root ftsSecret input hnotStable message) + (ordinaryEntryPreservingImpl_maskedSigningImpl parameter root ftsSecret input message) + state finalState cache finalCache fuel remaining output hprotected hfinalTable hresult + +def PreservesCanonicalInputProtected + (table : Coordinate → HashOutput) (input : HashInput) (position : Position) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ state cache fuel finalState remaining value finalCache, + CanonicalInputProtected table input position state cache → + (∀ coordinate cached, + state.values coordinate = some cached → cached = table coordinate) → + (∀ coordinate cached, + finalState.values coordinate = some cached → cached = table coordinate) → + PublishedValues state → + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + PublishedValues finalState ∧ + CanonicalInputProtected table input position finalState finalCache + +theorem PreservesCanonicalInputProtected.pure + (table : Coordinate → HashOutput) (input : HashInput) (position : Position) + (value : alpha) : + PreservesCanonicalInputProtected table input position + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro state cache fuel finalState remaining result finalCache hprotected _ _ hpublished hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨hpublished, hprotected⟩ + +theorem PreservesCanonicalInputProtected.bind + {table : Coordinate → HashOutput} {input : HashInput} {position : Position} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : PreservesCanonicalInputProtected table input position left) + (hnext : ∀ value, PreservesCanonicalInputProtected table input position (next value)) : + PreservesCanonicalInputProtected table input position (left >>= next) := by + intro state cache fuel finalState remaining value finalCache hprotected hstateTable hfinalTable + hpublished hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun result => (next result.1).run result.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining middleResult => + rcases middleResult with ⟨middleValue, middleCache⟩ + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((next middleValue).run middleCache) middleState finalState middleRemaining remaining + (value, finalCache) hrest + have hmiddleTable : ∀ coordinate cached, + middleState.values coordinate = some cached → cached = table coordinate := by + intro coordinate cached hcached + exact hfinalTable coordinate cached (hvaluesLE coordinate cached hcached) + have hmiddle := hleft state cache fuel middleState middleRemaining middleValue middleCache + hprotected hstateTable hmiddleTable hpublished hraw + exact hnext middleValue middleState middleCache middleRemaining finalState remaining value + finalCache hmiddle.2 hmiddleTable hfinalTable hmiddle.1 hrest + +def PreservesCanonicalInputProtectedImpl {spec : OracleSpec ι} + (table : Coordinate → HashOutput) (input : HashInput) (position : Position) + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) : Prop := + ∀ query, PreservesCanonicalInputProtected table input position (impl query) + +theorem PreservesCanonicalInputProtectedImpl.simulateQ {spec : OracleSpec ι} + {table : Coordinate → HashOutput} {input : HashInput} {position : Position} + {impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))} + (himpl : PreservesCanonicalInputProtectedImpl table input position impl) + (computation : OracleComp spec alpha) : + PreservesCanonicalInputProtected table input position (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => exact PreservesCanonicalInputProtected.pure table input position value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (himpl query).bind ih + +theorem preservesCanonicalInputProtectedImpl_maskedExpandedAdversaryImpl + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (position : Position) (hkind : IsCanonicalOtsPosition position) + (hinput : input = tableInput parameter table (.position position)) : + PreservesCanonicalInputProtectedImpl table input position + (maskedExpandedAdversaryImpl parameter root ftsSecret) := by + intro query + cases query with + | inl query => + cases query with + | inl n => + intro state cache fuel finalState remaining output finalCache hprotected _ hfinalTable + hpublished hresult + refine ⟨(preservesPublishedValuesImpl_splitUniformImpl n state cache fuel finalState + remaining output finalCache hpublished hresult), ?_⟩ + exact canonicalInputProtected_splitUniformImpl table input position n state finalState + cache finalCache fuel remaining output hprotected hfinalTable hresult + | inr query => + intro state cache fuel finalState remaining output finalCache hprotected hstateTable + hfinalTable hpublished hresult + refine ⟨(preservesPublishedValues_probingHashQuery parameter query state cache fuel + finalState remaining output finalCache hpublished hresult), ?_⟩ + exact canonicalInputProtected_probingHashQuery parameter table input query position hkind + hinput state finalState cache finalCache fuel remaining output hprotected hstateTable + hfinalTable hpublished hresult + | inr message => + intro state cache fuel finalState remaining output finalCache hprotected _ hfinalTable + hpublished hresult + refine ⟨(preservesPublishedValues_maskedSigningImpl parameter root ftsSecret message + state cache fuel finalState remaining output finalCache hpublished hresult), ?_⟩ + exact canonicalInputProtected_maskedSigningImpl parameter table root ftsSecret input position + hkind hinput message state finalState cache finalCache fuel remaining output hprotected + hfinalTable hresult + +theorem canonicalInputProtected_simulateQ_maskedExpandedAdversaryImpl + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (position : Position) (hkind : IsCanonicalOtsPosition position) + (hinput : input = tableInput parameter table (.position position)) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : alpha) + (hprotected : CanonicalInputProtected table input position state cache) + (hstateTable : ∀ coordinate cached, + state.values coordinate = some cached → cached = table coordinate) + (hfinalTable : ∀ coordinate cached, + finalState.values coordinate = some cached → cached = table coordinate) + (hrevealed : PublishedValues state) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + computation).run cache))) : + CanonicalInputProtected table input position finalState finalCache := + ((preservesCanonicalInputProtectedImpl_maskedExpandedAdversaryImpl parameter table root + ftsSecret input position hkind hinput).simulateQ computation state cache fuel finalState + remaining value finalCache hprotected hstateTable hfinalTable hrevealed hresult).2 + +set_option maxRecDepth 10000 in +theorem canonicalInputProtected_before_verifier_of_mem_runRaw_maskedRetainedGame + (adversary : Adversary) (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (position : Position) (hkind : IsCanonicalOtsPosition position) + (hinput : input = tableInput parameter table (.position position)) + (fuel remaining : Nat) (rawState : LazyRevealProbe.State Coordinate) + (rawCache : SplitHashCache) (root : Digest) (forgery : Forgery) + (signingLog : QueryLog SigningSpec) (verified : Bool) + (htable : ∀ coordinate output, rawState.values coordinate = some output → + output = table coordinate) + (hresult : LazyRevealProbe.RawResult.done rawState remaining + ((root, ((forgery, signingLog), verified)), rawCache) ∈ support + (LazyRevealProbe.runRaw (LazyRevealProbe.State.empty : + LazyRevealProbe.State Coordinate) fuel + ((maskedRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) : + ∃ verifierState verifierFuel verifierCache, + CanonicalInputProtected table input position verifierState verifierCache ∧ + PublishedValues verifierState ∧ + LazyRevealProbe.RawResult.done rawState remaining (verified, rawCache) ∈ support + (LazyRevealProbe.runRaw verifierState verifierFuel + ((simulateQ (verifierRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).run + verifierCache)) := by + let rootCoordinate : Coordinate := .position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0) + unfold maskedRetainedGameAfterFtsSecrets at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨rootRaw, hroot, hafterRoot⟩ := hresult + cases rootRaw with + | stopped hit => simp at hafterRoot + | done rootState rootRemaining rootResult => + rcases rootResult with ⟨sampledRoot, rootCache⟩ + simp only at hafterRoot + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hafterRoot + obtain ⟨publishRaw, hpublish, hafterPublish⟩ := hafterRoot + cases publishRaw with + | stopped hit => simp at hafterPublish + | done publishState publishRemaining publishResult => + rcases publishResult with ⟨publishedUnit, publishCache⟩ + simp only at hafterPublish + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterPublish + obtain ⟨restRaw, hrest, hfinish⟩ := hafterPublish + cases restRaw with + | stopped hit => simp at hfinish + | done restState restRemaining restResult => + rcases restResult with ⟨⟨prefixForgery, prefixLog⟩, restCache⟩ + simp only at hfinish + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hfinish + obtain ⟨verifyRaw, hverify, hreturn⟩ := hfinish + cases verifyRaw with + | stopped hit => simp at hreturn + | done verifyState verifyRemaining verifyResult => + rcases verifyResult with ⟨prefixVerified, verifyCache⟩ + simp [LazyRevealProbe.runRaw] at hreturn + rcases hreturn with ⟨rfl, rfl, houtput, rfl⟩ + rcases houtput with ⟨hrootEq, hrestEq, rfl⟩ + rcases hrestEq with ⟨rfl, rfl⟩ + have hvaluesRestRaw := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((simulateQ (verifierRomImpl parameter) + (scheme.verify ⟨sampledRoot, parameter⟩ forgery.message + forgery.signature)).run restCache) + restState rawState restRemaining remaining (verified, rawCache) hverify + have htableRest : ∀ coordinate output, + restState.values coordinate = some output → + output = table coordinate := by + intro coordinate output hvalue + exact htable coordinate output (hvaluesRestRaw coordinate output hvalue) + have hvaluesPublishRest := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((simulateQ (maskedExpandedAdversaryImpl parameter sampledRoot ftsSecret) + (signingTraceComputation + (adversary.main ⟨sampledRoot, parameter⟩))).run publishCache) + publishState restState publishRemaining restRemaining + ((forgery, signingLog), restCache) hrest + have htablePublish : ∀ coordinate output, + publishState.values coordinate = some output → + output = table coordinate := by + intro coordinate output hvalue + exact htableRest coordinate output + (hvaluesPublishRest coordinate output hvalue) + have hpublishedEmpty : PublishedValues + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) := by + intro coordinate hcoordinate + simp [LazyRevealProbe.State.empty] at hcoordinate + have hpublishedRoot := preservesPublishedValues_maskedTreeRoot topLayer rootTree + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + emptySplitHashCache fuel rootState rootRemaining sampledRoot rootCache + hpublishedEmpty hroot + obtain ⟨rootOutput, _, hrootValue, _⟩ := + mem_runRaw_maskedTreeRoot_hidden topLayer rootTree + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) rootState + emptySplitHashCache rootCache fuel rootRemaining sampledRoot hroot + have hrootCoordinate : + maskedTreeRootCoordinate topLayer rootTree = rootCoordinate := by + simp [maskedTreeRootCoordinate, maskedTreeRootLevel, rootCoordinate, + layerHeight, topLayer, maxLayerHeight] + have hrootValue' : rootState.values rootCoordinate ≠ none := by + rw [← hrootCoordinate, hrootValue] + simp + have hpublishedPublish := publishedValues_of_mem_runRaw_publishCoordinate + rootCoordinate rootState publishState rootCache publishCache rootRemaining + publishRemaining publishedUnit hpublishedRoot hrootValue' + (by simpa [rootCoordinate] using hpublish) + have hrootOrdinary := ordinaryCachePreserving_maskedTreeRoot topLayer rootTree + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + emptySplitHashCache fuel rootState rootRemaining sampledRoot rootCache hroot + have hpublishCache := splitCachePreserving_publishCoordinate rootCoordinate + rootState rootCache rootRemaining publishState publishRemaining publishedUnit + publishCache (by simpa [rootCoordinate] using hpublish) + have hinitialProtected : CanonicalInputProtected table input position + publishState publishCache := by + left + rw [hpublishCache] + change ordinaryQueryCache rootCache input = none + rw [hrootOrdinary] + simp [ordinaryQueryCache, emptySplitHashCache] + have hprotectedRest := + canonicalInputProtected_simulateQ_maskedExpandedAdversaryImpl parameter table + sampledRoot ftsSecret input position hkind hinput + (signingTraceComputation + (adversary.main ⟨sampledRoot, parameter⟩)) + publishState restState publishCache restCache publishRemaining + restRemaining (forgery, signingLog) hinitialProtected htablePublish + htableRest hpublishedPublish hrest + exact ⟨restState, restRemaining, restCache, hprotectedRest, + (preservesPublishedValuesImpl_maskedExpandedAdversaryImpl parameter sampledRoot + ftsSecret).simulateQ + (signingTraceComputation (adversary.main ⟨sampledRoot, parameter⟩)) + publishState publishCache publishRemaining restState restRemaining + (forgery, signingLog) restCache hpublishedPublish hrest, + by simpa only [hrootEq] using hverify⟩ + +def CanonicalCacheExactOrAbsent (table : Coordinate → HashOutput) + (input : HashInput) (position : Position) (cache : SplitHashCache) : Prop := + cache (.ordinary input) = none ∨ + cache (.ordinary input) = some (table (.position position)) + +theorem canonicalCacheExactOrAbsent_verifierHashQuery + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (input query : HashInput) (position : Position) (hkind : IsCanonicalOtsPosition position) + (hinput : input = tableInput parameter table (.position position)) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : HashSpec query) + (hinitial : CanonicalCacheExactOrAbsent table input position cache) + (hfinalTable : ∀ coordinate cached, + finalState.values coordinate = some cached → cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((verifierHashQuery parameter query).run cache))) : + CanonicalCacheExactOrAbsent table input position finalCache := by + rcases hinitial with hnone | hexact + · by_cases heq : query = input + · subst query + subst input + right + have hots : IsOtsPosition position := by + cases position <;> simp [IsCanonicalOtsPosition, IsOtsPosition] at hkind ⊢ + have hreturns := verifierHashQuery_returns_table_of_uncached parameter table position hots + state finalState cache finalCache fuel remaining output hnone hfinalTable hresult + simpa [hreturns.1] using hreturns.2 + · left + have hcache := ordinaryQueryCache_eq_cacheQuery_of_mem_runRaw_verifierHashImpl parameter + query state finalState cache finalCache fuel remaining output (by + simpa only [verifierHashImpl] using hresult) + change ordinaryQueryCache finalCache input = none + rw [hcache, QueryCache.cacheQuery_of_ne _ _ (Ne.symm heq)] + exact hnone + · right + exact ordinaryEntryPreserving_verifierHashQuery parameter input query state cache fuel + finalState remaining output finalCache (table (.position position)) hexact hresult + +def PreservesCanonicalCacheExactOrAbsent + (table : Coordinate → HashOutput) (input : HashInput) (position : Position) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ state cache fuel finalState remaining value finalCache, + CanonicalCacheExactOrAbsent table input position cache → + (∀ coordinate cached, + finalState.values coordinate = some cached → cached = table coordinate) → + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + CanonicalCacheExactOrAbsent table input position finalCache + +theorem PreservesCanonicalCacheExactOrAbsent.pure + (table : Coordinate → HashOutput) (input : HashInput) (position : Position) + (value : alpha) : + PreservesCanonicalCacheExactOrAbsent table input position + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro state cache fuel finalState remaining result finalCache hinitial _ hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hinitial + +theorem PreservesCanonicalCacheExactOrAbsent.bind + {table : Coordinate → HashOutput} {input : HashInput} {position : Position} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : PreservesCanonicalCacheExactOrAbsent table input position left) + (hnext : ∀ value, PreservesCanonicalCacheExactOrAbsent table input position (next value)) : + PreservesCanonicalCacheExactOrAbsent table input position (left >>= next) := by + intro state cache fuel finalState remaining value finalCache hinitial hfinalTable hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun result => (next result.1).run result.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining middleResult => + rcases middleResult with ⟨middleValue, middleCache⟩ + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((next middleValue).run middleCache) middleState finalState middleRemaining remaining + (value, finalCache) hrest + have hmiddleTable : ∀ coordinate cached, + middleState.values coordinate = some cached → cached = table coordinate := by + intro coordinate cached hcached + exact hfinalTable coordinate cached (hvaluesLE coordinate cached hcached) + exact hnext middleValue middleState middleCache middleRemaining finalState remaining value + finalCache (hleft state cache fuel middleState middleRemaining middleValue middleCache + hinitial hmiddleTable hraw) hfinalTable hrest + +def PreservesCanonicalCacheExactOrAbsentImpl {spec : OracleSpec ι} + (table : Coordinate → HashOutput) (input : HashInput) (position : Position) + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) : Prop := + ∀ query, PreservesCanonicalCacheExactOrAbsent table input position (impl query) + +theorem PreservesCanonicalCacheExactOrAbsentImpl.simulateQ {spec : OracleSpec ι} + {table : Coordinate → HashOutput} {input : HashInput} {position : Position} + {impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))} + (himpl : PreservesCanonicalCacheExactOrAbsentImpl table input position impl) + (computation : OracleComp spec alpha) : + PreservesCanonicalCacheExactOrAbsent table input position (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => exact PreservesCanonicalCacheExactOrAbsent.pure table input position value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (himpl query).bind ih + +theorem preservesCanonicalCacheExactOrAbsentImpl_verifierRomImpl + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (input : HashInput) (position : Position) (hkind : IsCanonicalOtsPosition position) + (hinput : input = tableInput parameter table (.position position)) : + PreservesCanonicalCacheExactOrAbsentImpl table input position + (verifierRomImpl parameter) := by + intro query + cases query with + | inl n => + intro state cache fuel finalState remaining output finalCache hinitial hfinalTable hresult + have hpreserves : OrdinaryCachePreserving (splitUniformImpl n) := by + have hbase := ordinaryCachePreserving_simulateQ_splitUniformImpl + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) + simpa [splitUniformImpl] using hbase + rcases hinitial with hnone | hexact + · left + exact hpreserves.preservesAbsence input state cache fuel finalState remaining output + finalCache hnone hresult + · right + exact hpreserves.entryPreserving input state cache fuel finalState remaining output + finalCache (table (.position position)) hexact hresult + | inr query => + intro state cache fuel finalState remaining output finalCache hinitial hfinalTable hresult + exact canonicalCacheExactOrAbsent_verifierHashQuery parameter table input query position + hkind hinput state finalState cache finalCache fuel remaining output hinitial hfinalTable + hresult + +set_option maxRecDepth 10000 in +theorem cached_tableInput_eq_of_canonical_ots_of_clean_finalize + (adversary : Adversary) (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (position : Position) (hkind : IsCanonicalOtsPosition position) + (hinput : input = tableInput parameter table (.position position)) + (fuel remaining : Nat) + (rawState completedState : LazyRevealProbe.State Coordinate) + (rawCache : SplitHashCache) (root : Digest) (forgery : Forgery) + (signingLog : QueryLog SigningSpec) (verified : Bool) (output : HashOutput) + (hcompletedTable : ∀ coordinate cached, + completedState.values coordinate = some cached → cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done rawState remaining + ((root, ((forgery, signingLog), verified)), rawCache) ∈ support + (LazyRevealProbe.runRaw (LazyRevealProbe.State.empty : + LazyRevealProbe.State Coordinate) fuel + ((maskedRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) + (hfinalize : (false, completedState) ∈ support + (LazyRevealProbe.finalizeDetailed rawState)) + (hcached : rawCache (.ordinary input) = some output) : + output = table (.position position) := by + have hrawTable : ∀ coordinate cached, + rawState.values coordinate = some cached → cached = table coordinate := by + intro coordinate cached hvalue + exact hcompletedTable coordinate cached + (finalizeDetailedFrom_preserves_value rawState.coordinates.toList rawState completedState + coordinate cached hvalue hfinalize) + obtain ⟨verifierState, verifierFuel, verifierCache, hprotected, _, hverify⟩ := + canonicalInputProtected_before_verifier_of_mem_runRaw_maskedRetainedGame adversary parameter + table ftsSecret input position hkind hinput fuel remaining rawState rawCache root forgery + signingLog verified hrawTable hresult + rcases hprotected with hnone | hexact | ⟨coordinate, hmissing, hhit⟩ + · have hterminal := + (preservesCanonicalCacheExactOrAbsentImpl_verifierRomImpl parameter table input position + hkind hinput).simulateQ + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature) + verifierState verifierCache verifierFuel rawState remaining verified rawCache + (Or.inl hnone) hrawTable hverify + rcases hterminal with hterminal | hterminal + · rw [hcached] at hterminal + simp at hterminal + · exact Option.some.inj (hcached.symm.trans hterminal) + · have hterminal := + (preservesCanonicalCacheExactOrAbsentImpl_verifierRomImpl parameter table input position + hkind hinput).simulateQ + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature) + verifierState verifierCache verifierFuel rawState remaining verified rawCache + (Or.inr hexact) hrawTable hverify + rcases hterminal with hterminal | hterminal + · rw [hcached] at hterminal + simp at hterminal + · exact Option.some.inj (hcached.symm.trans hterminal) + · have hpersist := LazyRevealProbe.pendingHit_preserved_of_mem_runRaw_done + ((simulateQ (verifierRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).run + verifierCache) + coordinate (table coordinate) verifierState rawState verifierFuel remaining + (verified, rawCache) hmissing hhit (hrawTable coordinate) hverify + exact (finalizeDetailed_false_of_pending_hit table rawState completedState coordinate + hpersist.1 hpersist.2 (hcompletedTable coordinate) hfinalize).elim + +set_option maxRecDepth 10000 in +theorem exactMaterializedCacheConsistent_of_clean_finalize + (adversary : Adversary) (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel remaining : Nat) + (rawState completedState : LazyRevealProbe.State Coordinate) + (rawCache : SplitHashCache) (root : Digest) (forgery : Forgery) + (signingLog : QueryLog SigningSpec) (verified : Bool) + (hcompletedTable : ∀ coordinate cached, + completedState.values coordinate = some cached → cached = table coordinate) + (hresult : LazyRevealProbe.RawResult.done rawState remaining + ((root, ((forgery, signingLog), verified)), rawCache) ∈ support + (LazyRevealProbe.runRaw (LazyRevealProbe.State.empty : + LazyRevealProbe.State Coordinate) fuel + ((maskedRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) + (hfinalize : (false, completedState) ∈ support + (LazyRevealProbe.finalizeDetailed rawState)) : + ExactMaterializedCacheConsistent parameter table completedState rawCache := by + intro input position output hots _ hinput _ hcached + have hkind : IsCanonicalOtsPosition position := by + cases position <;> simp [IsOtsPosition, IsCanonicalOtsPosition] at hots ⊢ + exact cached_tableInput_eq_of_canonical_ots_of_clean_finalize adversary parameter table + ftsSecret input position hkind hinput fuel remaining rawState completedState rawCache root + forgery signingLog verified output hcompletedTable hresult hfinalize hcached + +theorem simulateQ_probingHashImpl_tweakableHash_eq_ordinaryHashImpl + (parameter : PublicParameter) (domain : HashDomain) (payload : HashInput) + (hinRange : domain.InRange) + (hchain : ∀ lay tree leafIdx chainIdx step, + domain ≠ .chain lay tree leafIdx chainIdx step) + (hleaf : ∀ lay tree leafIdx, domain ≠ .leaf lay tree leafIdx) + (hnode : ∀ lay tree level nodeIdx, domain ≠ .node lay tree level nodeIdx) : + simulateQ (probingHashImpl parameter) (tweakableHash parameter domain payload) = + simulateQ ordinaryHashImpl (tweakableHash parameter domain payload) := by + unfold tweakableHash oracleHash + rw [simulateQ_bind, simulateQ_bind] + simp only [HasQuery.instOfMonadLift_query, simulateQ_spec_query, simulateQ_pure] + rw [probingHashImpl_eq_ordinaryHashImpl_of_stable parameter _ + (stableOrdinaryInput_tweakableHashInput parameter domain payload hinRange + hchain hleaf hnode)] + +theorem simulateQ_probingHashImpl_messageDigest_eq_ordinaryHashImpl + (parameter : PublicParameter) (root : Digest) (message : Message) + (randomness : Randomness) : + simulateQ (probingHashImpl parameter) + (messageDigest parameter root message randomness) = + simulateQ ordinaryHashImpl + (messageDigest parameter root message randomness) := by + unfold messageDigest oracleHash + rw [simulateQ_bind, simulateQ_bind] + simp only [HasQuery.instOfMonadLift_query, simulateQ_spec_query, simulateQ_pure] + rw [probingHashImpl_eq_ordinaryHashImpl_of_stable parameter _ + (stableOrdinaryInput_tweakableHashInput parameter .message _ (by trivial) + (by simp) (by simp) (by simp))] + +theorem simulateQ_probingHashImpl_ftsLeafHash_eq_ordinaryHashImpl + (parameter : PublicParameter) (index : Index) (tree : FtsTree) + (leafIdx : FtsLeaf) (secret : Digest) : + simulateQ (probingHashImpl parameter) + (ftsLeafHash parameter index tree leafIdx secret) = + simulateQ ordinaryHashImpl + (ftsLeafHash parameter index tree leafIdx secret) := by + unfold ftsLeafHash + exact simulateQ_probingHashImpl_tweakableHash_eq_ordinaryHashImpl parameter + (.ftsLeaf index tree leafIdx) (digestBytes secret) (by trivial) + (by simp) (by simp) (by simp) + +theorem simulateQ_probingHashImpl_ftsFold_eq_ordinaryHashImpl + (parameter : PublicParameter) (index : Index) (tree : FtsTree) + (leafIdx : FtsLeaf) (path : Fin ftsTreeHeight → Digest) : + ∀ levels value, levels ≤ ftsTreeHeight → + simulateQ (probingHashImpl parameter) + (ftsFold parameter index tree leafIdx path levels value) = + simulateQ ordinaryHashImpl + (ftsFold parameter index tree leafIdx path levels value) + | 0, value, _ => by simp [ftsFold] + | levels + 1, value, hlevels => by + rw [ftsFold_succ_eq, simulateQ_bind, simulateQ_bind, + simulateQ_probingHashImpl_ftsFold_eq_ordinaryHashImpl parameter index tree + leafIdx path levels value (by omega)] + apply bind_congr + intro current + split <;> split <;> + exact simulateQ_probingHashImpl_tweakableHash_eq_ordinaryHashImpl parameter + (.ftsNode index tree (levels + 1) (leafIdx.val / 2 ^ (levels + 1))) _ + (by + show levels + 1 < 2 ^ 32 ∧ leafIdx.val / 2 ^ (levels + 1) < 2 ^ 32 + constructor + · have hheight : ftsTreeHeight < 2 ^ 32 := by + norm_num [ftsTreeHeight] + omega + · have hleaf : leafIdx.val < 2 ^ 32 := by + exact lt_of_lt_of_le leafIdx.isLt (by norm_num [ftsTreeHeight]) + have hdiv := Nat.div_le_self leafIdx.val (2 ^ (levels + 1)) + omega) + (by simp) (by simp) (by simp) + +theorem simulateQ_probingHashImpl_sequenceFin_eq_ordinaryHashImpl + (parameter : PublicParameter) {n : Nat} + (computation : Fin n → OracleComp HashSpec alpha) + (hcomponent : ∀ position, + simulateQ (probingHashImpl parameter) (computation position) = + simulateQ ordinaryHashImpl (computation position)) : + simulateQ (probingHashImpl parameter) (sequenceFin computation) = + simulateQ ordinaryHashImpl (sequenceFin computation) := by + induction n with + | zero => simp [sequenceFin] + | succ n ih => + rw [sequenceFin, simulateQ_bind, simulateQ_bind, hcomponent 0] + apply bind_congr + intro head + rw [simulateQ_bind, simulateQ_bind] + have htail := ih (fun position : Fin n => computation position.succ) + (fun position => hcomponent position.succ) + rw [htail] + simp only [simulateQ_pure] + +theorem simulateQ_probingHashImpl_ftsRecover_eq_ordinaryHashImpl + (parameter : PublicParameter) (index : Index) + (leaves : DigestTree → FtsLeaf) (secrets : FtsTree → Digest) + (paths : FtsTree → Fin ftsTreeHeight → Digest) : + simulateQ (probingHashImpl parameter) + (ftsRecover parameter index leaves secrets paths) = + simulateQ ordinaryHashImpl + (ftsRecover parameter index leaves secrets paths) := by + unfold ftsRecover + rw [simulateQ_bind, simulateQ_bind] + have hroots := simulateQ_probingHashImpl_sequenceFin_eq_ordinaryHashImpl parameter + (fun tree => do + let leaf := leaves (ftsIndexOf tree) + let value ← ftsLeafHash parameter index tree leaf (secrets tree) + ftsFold parameter index tree leaf (paths tree) ftsTreeHeight value) + (fun tree => by + rw [simulateQ_bind, simulateQ_bind, + simulateQ_probingHashImpl_ftsLeafHash_eq_ordinaryHashImpl] + apply bind_congr + intro value + exact simulateQ_probingHashImpl_ftsFold_eq_ordinaryHashImpl parameter index tree + (leaves (ftsIndexOf tree)) (paths tree) ftsTreeHeight value le_rfl) + rw [hroots] + apply bind_congr + intro roots + exact simulateQ_probingHashImpl_tweakableHash_eq_ordinaryHashImpl parameter + (.ftsRoots index) (ftsRootsPayload roots) (by trivial) + (by simp) (by simp) (by simp) + +theorem simulateQ_verifierHashImpl_tweakableHash_eq_ordinaryHashImpl + (parameter : PublicParameter) (domain : HashDomain) (payload : HashInput) + (hinRange : domain.InRange) + (hchain : ∀ lay tree leafIdx chainIdx step, + domain ≠ .chain lay tree leafIdx chainIdx step) + (hleaf : ∀ lay tree leafIdx, domain ≠ .leaf lay tree leafIdx) + (hnode : ∀ lay tree level nodeIdx, domain ≠ .node lay tree level nodeIdx) : + simulateQ (verifierHashImpl parameter) (tweakableHash parameter domain payload) = + simulateQ ordinaryHashImpl (tweakableHash parameter domain payload) := by + unfold tweakableHash oracleHash + rw [simulateQ_bind, simulateQ_bind] + simp only [HasQuery.instOfMonadLift_query, simulateQ_spec_query, simulateQ_pure] + change (verifierHashQuery parameter (tweakableHashInput parameter domain payload) >>= _) = _ + rw [verifierHashQuery_eq_splitHashQuery_of_stable parameter _ + (stableOrdinaryInput_tweakableHashInput parameter domain payload hinRange + hchain hleaf hnode)] + rfl + +theorem simulateQ_verifierHashImpl_messageDigest_eq_ordinaryHashImpl + (parameter : PublicParameter) (root : Digest) (message : Message) + (randomness : Randomness) : + simulateQ (verifierHashImpl parameter) + (messageDigest parameter root message randomness) = + simulateQ ordinaryHashImpl + (messageDigest parameter root message randomness) := by + unfold messageDigest oracleHash + rw [simulateQ_bind, simulateQ_bind] + simp only [HasQuery.instOfMonadLift_query, simulateQ_spec_query, simulateQ_pure] + change (verifierHashQuery parameter + (tweakableHashInput parameter .message _) >>= _) = _ + rw [verifierHashQuery_eq_splitHashQuery_of_stable parameter _ + (stableOrdinaryInput_tweakableHashInput parameter .message _ (by trivial) + (by simp) (by simp) (by simp))] + rfl + +theorem simulateQ_verifierHashImpl_ftsLeafHash_eq_ordinaryHashImpl + (parameter : PublicParameter) (index : Index) (tree : FtsTree) + (leafIdx : FtsLeaf) (secret : Digest) : + simulateQ (verifierHashImpl parameter) + (ftsLeafHash parameter index tree leafIdx secret) = + simulateQ ordinaryHashImpl + (ftsLeafHash parameter index tree leafIdx secret) := by + unfold ftsLeafHash + exact simulateQ_verifierHashImpl_tweakableHash_eq_ordinaryHashImpl parameter + (.ftsLeaf index tree leafIdx) (digestBytes secret) (by trivial) + (by simp) (by simp) (by simp) + +theorem simulateQ_verifierHashImpl_ftsFold_eq_ordinaryHashImpl + (parameter : PublicParameter) (index : Index) (tree : FtsTree) + (leafIdx : FtsLeaf) (path : Fin ftsTreeHeight → Digest) : + ∀ levels value, levels ≤ ftsTreeHeight → + simulateQ (verifierHashImpl parameter) + (ftsFold parameter index tree leafIdx path levels value) = + simulateQ ordinaryHashImpl + (ftsFold parameter index tree leafIdx path levels value) + | 0, value, _ => by simp [ftsFold] + | levels + 1, value, hlevels => by + rw [ftsFold_succ_eq, simulateQ_bind, simulateQ_bind, + simulateQ_verifierHashImpl_ftsFold_eq_ordinaryHashImpl parameter index tree + leafIdx path levels value (by omega)] + apply bind_congr + intro current + split <;> split <;> + exact simulateQ_verifierHashImpl_tweakableHash_eq_ordinaryHashImpl parameter + (.ftsNode index tree (levels + 1) (leafIdx.val / 2 ^ (levels + 1))) _ + (by + show levels + 1 < 2 ^ 32 ∧ leafIdx.val / 2 ^ (levels + 1) < 2 ^ 32 + constructor + · have hheight : ftsTreeHeight < 2 ^ 32 := by + norm_num [ftsTreeHeight] + omega + · have hleaf : leafIdx.val < 2 ^ 32 := by + exact lt_of_lt_of_le leafIdx.isLt (by norm_num [ftsTreeHeight]) + have hdiv := Nat.div_le_self leafIdx.val (2 ^ (levels + 1)) + omega) + (by simp) (by simp) (by simp) + +theorem simulateQ_verifierHashImpl_sequenceFin_eq_ordinaryHashImpl + (parameter : PublicParameter) {n : Nat} + (computation : Fin n → OracleComp HashSpec alpha) + (hcomponent : ∀ position, + simulateQ (verifierHashImpl parameter) (computation position) = + simulateQ ordinaryHashImpl (computation position)) : + simulateQ (verifierHashImpl parameter) (sequenceFin computation) = + simulateQ ordinaryHashImpl (sequenceFin computation) := by + induction n with + | zero => simp [sequenceFin] + | succ n ih => + rw [sequenceFin, simulateQ_bind, simulateQ_bind, hcomponent 0] + apply bind_congr + intro head + rw [simulateQ_bind, simulateQ_bind] + have htail := ih (fun position : Fin n => computation position.succ) + (fun position => hcomponent position.succ) + rw [htail] + simp only [simulateQ_pure] + +theorem simulateQ_verifierHashImpl_ftsRecover_eq_ordinaryHashImpl + (parameter : PublicParameter) (index : Index) + (leaves : DigestTree → FtsLeaf) (secrets : FtsTree → Digest) + (paths : FtsTree → Fin ftsTreeHeight → Digest) : + simulateQ (verifierHashImpl parameter) + (ftsRecover parameter index leaves secrets paths) = + simulateQ ordinaryHashImpl + (ftsRecover parameter index leaves secrets paths) := by + unfold ftsRecover + rw [simulateQ_bind, simulateQ_bind] + have hroots := simulateQ_verifierHashImpl_sequenceFin_eq_ordinaryHashImpl parameter + (fun tree => do + let leaf := leaves (ftsIndexOf tree) + let value ← ftsLeafHash parameter index tree leaf (secrets tree) + ftsFold parameter index tree leaf (paths tree) ftsTreeHeight value) + (fun tree => by + rw [simulateQ_bind, simulateQ_bind, + simulateQ_verifierHashImpl_ftsLeafHash_eq_ordinaryHashImpl] + apply bind_congr + intro value + exact simulateQ_verifierHashImpl_ftsFold_eq_ordinaryHashImpl parameter index tree + (leaves (ftsIndexOf tree)) (paths tree) ftsTreeHeight value le_rfl) + rw [hroots] + apply bind_congr + intro roots + exact simulateQ_verifierHashImpl_tweakableHash_eq_ordinaryHashImpl parameter + (.ftsRoots index) (ftsRootsPayload roots) (by trivial) + (by simp) (by simp) (by simp) + +set_option maxRecDepth 10000 in +theorem ChainInvariant.not_finalized_false_of_bottom_verifyProbe_verifier + {f : QueryImpl HashSpec Id} {parameter : PublicParameter} + {table : Coordinate → HashOutput} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {targetCache : QueryCache HashSpec} + {initialState rawState completedState : LazyRevealProbe.State Coordinate} + {initialCache rawCache : SplitHashCache} {root : Digest} {forgery : Forgery} + {signingLog : QueryLog SigningSpec} {fuel remaining : Nat} {verified : Bool} + (hinvariant : ChainInvariant parameter + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) signingLog) + initialState initialCache) + (hf : CacheAnswersAgreeOnRun (ordinaryQueryCache rawCache) f + (verify ⟨root, parameter⟩ forgery.message forgery.signature)) + (hcompletedTable : ∀ coordinate output, + completedState.values coordinate = some output → output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hfinalize : (false, completedState) ∈ support + (LazyRevealProbe.finalizeDetailed rawState)) + (hverify : LazyRevealProbe.RawResult.done rawState remaining + (verified, rawCache) ∈ support + (LazyRevealProbe.runRaw initialState fuel + ((simulateQ (verifierRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).run + initialCache))) + (hprobe : VerifyProbeWitnessAt f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + signingLog forgery.message forgery.signature bottomLayer) : False := by + obtain ⟨digest, layerMessage, codeword, chainIdx, hdigit, probe, input, hinput, + hdigest, hadmissible, hencode, hverifierMessage, hhits, hmatches, _, _, + hnotCovered, _hsourceSettled⟩ := hprobe + have hlayerMessage := VerifierLayerMessage.bottom_message hverifierMessage + rw [hlayerMessage] at hencode + have hchain := probe.isChainCoordinate_of_matchesInput hmatches + have hcandidate : probe.candidate = truncateHash (table probe.coordinate) := + hhits.trans (probe.target_eq_truncate_table_of_chain f parameter table ftsSecret hchain + hrealizes) + have hinitialValue := hinvariant.1.value_eq_none_of_not_allowed hchain hnotCovered + have hinitialNotRevealed := hinvariant.1.not_revealed_of_not_allowed hchain hnotCovered + have hrawTable : ∀ coordinate output, rawState.values coordinate = some output → + output = table coordinate := by + intro coordinate output hvalue + exact hcompletedTable coordinate output + (finalizeDetailedFrom_preserves_value rawState.coordinates.toList rawState completedState + coordinate output hvalue hfinalize) + rw [simulateQ_verifierRom_scheme_verify, verify_eq, simulateQ_bind, + StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hverify + obtain ⟨digestRaw, hdigestRaw, hafterDigest⟩ := hverify + cases digestRaw with + | stopped hit => simp at hafterDigest + | done digestState digestRemaining digestResult => + rcases digestResult with ⟨sampledDigest, digestCache⟩ + have hfDigest : CacheAnswersAgreeOnRun (ordinaryQueryCache digestCache) f + (messageDigest parameter root forgery.message forgery.signature.randomness) := by + intro query hquery output hcached + apply hf query + · rw [verify_eq, queriedInputs_bind] + exact List.mem_append_left _ hquery + · exact (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + digestState digestCache digestRemaining rawState remaining verified rawCache output + hcached hafterDigest + have hdigestEval := + (replay_of_mem_runRaw_verifierHashImpl_of_cacheAnswersAgreeOnRun f parameter + (messageDigest parameter root forgery.message forgery.signature.randomness) + initialState digestState initialCache digestCache fuel digestRemaining sampledDigest + hfDigest hdigestRaw).1 + rw [hdigest] at hdigestEval + subst sampledDigest + have hdigestOrdinary := hdigestRaw + rw [simulateQ_verifierHashImpl_messageDigest_eq_ordinaryHashImpl] at hdigestOrdinary + have hdigestState := mem_runRaw_simulateQ_ordinaryHashImpl_projects + (messageDigest parameter root forgery.message forgery.signature.randomness) + initialState digestState initialCache digestCache fuel digestRemaining digest + hdigestOrdinary + simp only [hadmissible, not_true_eq_false, ↓reduceIte] at hafterDigest + rw [simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterDigest + obtain ⟨ftsRaw, hftsRaw, hafterFts⟩ := hafterDigest + cases ftsRaw with + | stopped hit => simp at hafterFts + | done ftsState ftsRemaining ftsResult => + rcases ftsResult with ⟨ftsPublicKey, ftsCache⟩ + have hfFts : CacheAnswersAgreeOnRun (ordinaryQueryCache ftsCache) f + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + forgery.signature.ftsSecret forgery.signature.ftsPath) := by + intro query hquery output hcached + apply hf query + · rw [verify_eq, queriedInputs_bind] + apply List.mem_append_right + rw [hdigest] + simp only [hadmissible, not_true_eq_false, if_false, queriedInputs_bind] + exact List.mem_append_left _ hquery + · exact (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + ftsState ftsCache ftsRemaining rawState remaining verified rawCache output hcached + hafterFts + have hftsEval := + (replay_of_mem_runRaw_verifierHashImpl_of_cacheAnswersAgreeOnRun f parameter + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + forgery.signature.ftsSecret forgery.signature.ftsPath) + digestState ftsState digestCache ftsCache digestRemaining ftsRemaining ftsPublicKey + hfFts hftsRaw).1 + have hftsOrdinary := hftsRaw + rw [simulateQ_verifierHashImpl_ftsRecover_eq_ordinaryHashImpl] at hftsOrdinary + have hftsState := mem_runRaw_simulateQ_ordinaryHashImpl_projects + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + forgery.signature.ftsSecret forgery.signature.ftsPath) + digestState ftsState digestCache ftsCache digestRemaining ftsRemaining ftsPublicKey + hftsOrdinary + subst ftsPublicKey + simp only at hafterFts + rw [simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterFts + obtain ⟨layersRaw, hlayersRaw, hafterLayers⟩ := hafterFts + cases layersRaw with + | stopped hit => simp at hafterLayers + | done layersState layersRemaining layersResult => + rcases layersResult with ⟨verifiedRoot, layersCache⟩ + rw [show numLayers = bottomLayer.val + 1 by rfl, verifyLayers_succ_eq, + dif_pos bottomLayer.isLt, simulateQ_bind, StateT.run_bind, + LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hlayersRaw + obtain ⟨otsRaw, hotsRaw, hafterOts⟩ := hlayersRaw + cases otsRaw with + | stopped hit => simp at hafterOts + | done otsState otsRemaining otsResult => + rcases otsResult with ⟨leafResult, otsCache⟩ + have hfOts : CacheAnswersAgreeOnRun (ordinaryQueryCache otsCache) f + (encode parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (evalWithAnswerFn f + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + forgery.signature.ftsSecret forgery.signature.ftsPath)) + (forgery.signature.counter bottomLayer)) := by + intro query hquery output hcached + apply hf query + · exact VerifierLayerMessage.otsLeaf_query_mem_verify + (publicKey := ⟨root, parameter⟩) (message := forgery.message) + (signature := forgery.signature) hdigest hadmissible hverifierMessage + (by + unfold otsLeaf + rw [queriedInputs_bind] + exact List.mem_append_left _ + (by simpa only [hlayerMessage] using hquery)) + · have hcachedLayers := + (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + otsState otsCache otsRemaining layersState layersRemaining verifiedRoot + layersCache output hcached hafterOts + exact + (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + layersState layersCache layersRemaining rawState remaining verified + rawCache output hcachedLayers hafterLayers + have hvaluesOtsLayers := LazyRevealProbe.valuesLE_of_mem_runRaw_done _ otsState + layersState otsRemaining layersRemaining (verifiedRoot, layersCache) hafterOts + have hvaluesLayersRaw := LazyRevealProbe.valuesLE_of_mem_runRaw_done _ layersState + rawState layersRemaining remaining (verified, rawCache) hafterLayers + have htableOts : ∀ coordinate output, + otsState.values coordinate = some output → output = table coordinate := by + intro coordinate output hvalue + exact hrawTable coordinate output + (hvaluesLayersRaw coordinate output + (hvaluesOtsLayers coordinate output hvalue)) + rw [hinput] at hmatches + have hftsInitial : ftsState = initialState := + hftsState.1.trans hdigestState.1 + have hpendingOts := + simulateQ_verifierHashImpl_otsLeaf_pendingHit_of_correct_probe f parameter + table probe bottomLayer (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (evalWithAnswerFn f + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + forgery.signature.ftsSecret forgery.signature.ftsPath)) + (forgery.signature.counter bottomLayer) + (forgery.signature.chainValue bottomLayer) codeword chainIdx hdigit hencode + ftsState otsState ftsCache otsCache ftsRemaining otsRemaining leafResult + hmatches hcandidate (by simpa [hftsInitial] using hinitialValue) + (by simpa [hftsInitial] using hinitialNotRevealed) hfOts htableOts + hotsRaw + have htableLayers : ∀ output, + layersState.values probe.coordinate = some output → + output = table probe.coordinate := by + intro output hvalue + exact hrawTable probe.coordinate output + (hvaluesLayersRaw probe.coordinate output hvalue) + have hpendingLayers := LazyRevealProbe.pendingHit_preserved_of_mem_runRaw_done _ + probe.coordinate (table probe.coordinate) otsState layersState otsRemaining + layersRemaining (verifiedRoot, layersCache) hpendingOts.1 hpendingOts.2 + htableLayers hafterOts + have hpendingRaw := LazyRevealProbe.pendingHit_preserved_of_mem_runRaw_done _ + probe.coordinate (table probe.coordinate) layersState rawState layersRemaining + remaining (verified, rawCache) hpendingLayers.1 hpendingLayers.2 + (hrawTable probe.coordinate) hafterLayers + exact finalizeDetailed_false_of_pending_hit table rawState completedState + probe.coordinate hpendingRaw.1 hpendingRaw.2 + (hcompletedTable probe.coordinate) hfinalize + +set_option maxRecDepth 10000 in +theorem ChainInvariant.not_finalized_false_of_middle_verifyProbe_verifier + {f : QueryImpl HashSpec Id} {parameter : PublicParameter} + {table : Coordinate → HashOutput} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {targetCache : QueryCache HashSpec} + {initialState rawState completedState : LazyRevealProbe.State Coordinate} + {initialCache rawCache : SplitHashCache} {root : Digest} {forgery : Forgery} + {signingLog : QueryLog SigningSpec} {fuel remaining : Nat} {verified : Bool} + (hinvariant : ChainInvariant parameter + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) signingLog) + initialState initialCache) + (hf : CacheAnswersAgreeOnRun (ordinaryQueryCache rawCache) f + (verify ⟨root, parameter⟩ forgery.message forgery.signature)) + (hcompletedTable : ∀ coordinate output, + completedState.values coordinate = some output → output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hfinalize : (false, completedState) ∈ support + (LazyRevealProbe.finalizeDetailed rawState)) + (hverify : LazyRevealProbe.RawResult.done rawState remaining + (verified, rawCache) ∈ support + (LazyRevealProbe.runRaw initialState fuel + ((simulateQ (verifierRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).run + initialCache))) + (hprobe : VerifyProbeWitnessAt f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + signingLog forgery.message forgery.signature middleLayer) : False := by + obtain ⟨digest, layerMessage, codeword, chainIdx, hdigit, probe, input, hinput, + hdigest, hadmissible, hencode, hverifierMessage, hhits, hmatches, _, _, + hnotCovered, _hsourceSettled⟩ := hprobe + obtain ⟨bottomLeaf, hbottomLeaf, hlayerMessage⟩ := + VerifierLayerMessage.middle_data hverifierMessage + rw [hinput] at hmatches + have hchain := probe.isChainCoordinate_of_matchesInput hmatches + have hcandidate : probe.candidate = truncateHash (table probe.coordinate) := + hhits.trans (probe.target_eq_truncate_table_of_chain f parameter table ftsSecret hchain + hrealizes) + have hinitialValue := hinvariant.1.value_eq_none_of_not_allowed hchain hnotCovered + have hinitialNotRevealed := hinvariant.1.not_revealed_of_not_allowed hchain hnotCovered + have hrawTable : ∀ coordinate output, rawState.values coordinate = some output → + output = table coordinate := by + intro coordinate output hvalue + exact hcompletedTable coordinate output + (finalizeDetailedFrom_preserves_value rawState.coordinates.toList rawState completedState + coordinate output hvalue hfinalize) + rw [simulateQ_verifierRom_scheme_verify, verify_eq, simulateQ_bind, + StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hverify + obtain ⟨digestRaw, hdigestRaw, hafterDigest⟩ := hverify + cases digestRaw with + | stopped hit => simp at hafterDigest + | done digestState digestRemaining digestResult => + rcases digestResult with ⟨sampledDigest, digestCache⟩ + have hfDigest : CacheAnswersAgreeOnRun (ordinaryQueryCache digestCache) f + (messageDigest parameter root forgery.message forgery.signature.randomness) := by + intro query hquery output hcached + apply hf query (messageDigest_query_mem_verify hquery) + exact (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + digestState digestCache digestRemaining rawState remaining verified rawCache output + hcached hafterDigest + have hdigestEval := + (replay_of_mem_runRaw_verifierHashImpl_of_cacheAnswersAgreeOnRun f parameter + (messageDigest parameter root forgery.message forgery.signature.randomness) + initialState digestState initialCache digestCache fuel digestRemaining sampledDigest + hfDigest hdigestRaw).1 + rw [hdigest] at hdigestEval + subst sampledDigest + have hdigestOrdinary := hdigestRaw + rw [simulateQ_verifierHashImpl_messageDigest_eq_ordinaryHashImpl] at hdigestOrdinary + have hdigestState := mem_runRaw_simulateQ_ordinaryHashImpl_projects + (messageDigest parameter root forgery.message forgery.signature.randomness) + initialState digestState initialCache digestCache fuel digestRemaining digest + hdigestOrdinary + simp only [hadmissible, not_true_eq_false, ↓reduceIte] at hafterDigest + rw [simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterDigest + obtain ⟨ftsRaw, hftsRaw, hafterFts⟩ := hafterDigest + cases ftsRaw with + | stopped hit => simp at hafterFts + | done ftsState ftsRemaining ftsResult => + rcases ftsResult with ⟨ftsPublicKey, ftsCache⟩ + have hfFts : CacheAnswersAgreeOnRun (ordinaryQueryCache ftsCache) f + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + forgery.signature.ftsSecret forgery.signature.ftsPath) := by + intro query hquery output hcached + apply hf query (ftsRecover_query_mem_verify hdigest hadmissible hquery) + exact (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + ftsState ftsCache ftsRemaining rawState remaining verified rawCache output hcached + hafterFts + have hftsEval := + (replay_of_mem_runRaw_verifierHashImpl_of_cacheAnswersAgreeOnRun f parameter + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + forgery.signature.ftsSecret forgery.signature.ftsPath) + digestState ftsState digestCache ftsCache digestRemaining ftsRemaining ftsPublicKey + hfFts hftsRaw).1 + have hftsOrdinary := hftsRaw + rw [simulateQ_verifierHashImpl_ftsRecover_eq_ordinaryHashImpl] at hftsOrdinary + have hftsState := mem_runRaw_simulateQ_ordinaryHashImpl_projects + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + forgery.signature.ftsSecret forgery.signature.ftsPath) + digestState ftsState digestCache ftsCache digestRemaining ftsRemaining ftsPublicKey + hftsOrdinary + subst ftsPublicKey + simp only at hafterFts + rw [simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterFts + obtain ⟨layersRaw, hlayersRaw, hafterLayers⟩ := hafterFts + cases layersRaw with + | stopped hit => simp at hafterLayers + | done layersState layersRemaining layersResult => + rcases layersResult with ⟨verifiedRoot, layersCache⟩ + rw [show numLayers = bottomLayer.val + 1 by rfl, verifyLayers_succ_eq, + dif_pos bottomLayer.isLt, simulateQ_bind, StateT.run_bind, + LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hlayersRaw + obtain ⟨bottomOtsRaw, hbottomOtsRaw, hafterBottomOts⟩ := hlayersRaw + cases bottomOtsRaw with + | stopped hit => simp at hafterBottomOts + | done bottomOtsState bottomOtsRemaining bottomOtsResult => + rcases bottomOtsResult with ⟨bottomResult, bottomOtsCache⟩ + have hfBottomOts : + CacheAnswersAgreeOnRun (ordinaryQueryCache bottomOtsCache) f + (otsLeaf parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (evalWithAnswerFn f + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + forgery.signature.ftsSecret forgery.signature.ftsPath)) + (forgery.signature.counter bottomLayer) + (forgery.signature.chainValue bottomLayer)) := by + intro query hquery output hcached + apply hf query (bottomOts_query_mem_verify hdigest hadmissible hquery) + have hcachedLayers := + (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + bottomOtsState bottomOtsCache bottomOtsRemaining layersState + layersRemaining verifiedRoot layersCache output hcached hafterBottomOts + exact (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + layersState layersCache layersRemaining rawState remaining verified rawCache + output hcachedLayers hafterLayers + have hbottomEval := + (replay_of_mem_runRaw_verifierHashImpl_of_cacheAnswersAgreeOnRun f parameter + (otsLeaf parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (evalWithAnswerFn f + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + forgery.signature.ftsSecret forgery.signature.ftsPath)) + (forgery.signature.counter bottomLayer) + (forgery.signature.chainValue bottomLayer)) + ftsState bottomOtsState ftsCache bottomOtsCache ftsRemaining + bottomOtsRemaining bottomResult hfBottomOts hbottomOtsRaw).1 + rw [hbottomLeaf] at hbottomEval + subst bottomResult + have hbottomOtsCoordinate := + preservesCoordinate_simulateQ_verifierHashImpl_otsLeaf_of_layer_ne parameter + probe middleLayer (treeIndexAt (digestIndex digest) middleLayer) + (leafIndexAt (digestIndex digest) middleLayer) chainIdx + ⟨(codeword chainIdx).val, hdigit⟩ + (forgery.signature.chainValue middleLayer chainIdx) hmatches bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (evalWithAnswerFn f + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + forgery.signature.ftsSecret forgery.signature.ftsPath)) + (forgery.signature.counter bottomLayer) + (forgery.signature.chainValue bottomLayer) (by decide) + ftsState ftsCache ftsRemaining bottomOtsState bottomOtsRemaining + (some bottomLeaf) bottomOtsCache hbottomOtsRaw + simp only at hafterBottomOts + rw [simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterBottomOts + obtain ⟨bottomFoldRaw, hbottomFoldRaw, hafterBottomFold⟩ := hafterBottomOts + cases bottomFoldRaw with + | stopped hit => simp at hafterBottomFold + | done bottomFoldState bottomFoldRemaining bottomFoldResult => + rcases bottomFoldResult with ⟨bottomRoot, bottomFoldCache⟩ + have hfBottomFold : + CacheAnswersAgreeOnRun (ordinaryQueryCache bottomFoldCache) f + (treeFold parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath forgery.signature bottomLayer) + (layerHeight bottomLayer) bottomLeaf) := by + intro query hquery output hcached + apply hf query + (bottomFold_query_mem_verify hdigest hadmissible hbottomLeaf hquery) + have hcachedLayers := + (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + bottomFoldState bottomFoldCache bottomFoldRemaining layersState + layersRemaining verifiedRoot layersCache output hcached + hafterBottomFold + exact + (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + layersState layersCache layersRemaining rawState remaining verified + rawCache output hcachedLayers hafterLayers + have hbottomFoldEval := + (replay_of_mem_runRaw_verifierHashImpl_of_cacheAnswersAgreeOnRun f parameter + (treeFold parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath forgery.signature bottomLayer) + (layerHeight bottomLayer) bottomLeaf) + bottomOtsState bottomFoldState bottomOtsCache bottomFoldCache + bottomOtsRemaining bottomFoldRemaining bottomRoot hfBottomFold + hbottomFoldRaw).1 + change foldValue f parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath forgery.signature bottomLayer) bottomLeaf + (layerHeight bottomLayer) = bottomRoot at hbottomFoldEval + rw [← hlayerMessage] at hbottomFoldEval + subst bottomRoot + have hbottomFoldCoordinate := + preservesCoordinate_simulateQ_verifierHashImpl_treeFold_of_layer_ne + parameter probe middleLayer + (treeIndexAt (digestIndex digest) middleLayer) + (leafIndexAt (digestIndex digest) middleLayer) chainIdx + ⟨(codeword chainIdx).val, hdigit⟩ + (forgery.signature.chainValue middleLayer chainIdx) hmatches bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath forgery.signature bottomLayer) (by decide) + (layerHeight bottomLayer) bottomLeaf (layerHeight_le bottomLayer) + bottomOtsState bottomOtsCache bottomOtsRemaining bottomFoldState + bottomFoldRemaining layerMessage bottomFoldCache hbottomFoldRaw + simp only at hafterBottomFold + rw [show bottomLayer.val = middleLayer.val + 1 by rfl, + verifyLayers_succ_eq, dif_pos middleLayer.isLt, simulateQ_bind, + StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterBottomFold + obtain ⟨middleOtsRaw, hmiddleOtsRaw, hafterMiddleOts⟩ := + hafterBottomFold + cases middleOtsRaw with + | stopped hit => simp at hafterMiddleOts + | done middleOtsState middleOtsRemaining middleOtsResult => + rcases middleOtsResult with ⟨middleResult, middleOtsCache⟩ + have hfMiddleOts : + CacheAnswersAgreeOnRun (ordinaryQueryCache middleOtsCache) f + (encode parameter middleLayer + (treeIndexAt (digestIndex digest) middleLayer) + (leafIndexAt (digestIndex digest) middleLayer) layerMessage + (forgery.signature.counter middleLayer)) := by + intro query hquery output hcached + apply hf query + (VerifierLayerMessage.otsLeaf_query_mem_verify hdigest hadmissible + hverifierMessage (by + unfold otsLeaf + rw [queriedInputs_bind] + exact List.mem_append_left _ hquery)) + have hcachedLayers := + (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + middleOtsState middleOtsCache middleOtsRemaining layersState + layersRemaining verifiedRoot layersCache output hcached + hafterMiddleOts + exact + (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + layersState layersCache layersRemaining rawState remaining verified + rawCache output hcachedLayers hafterLayers + have hvaluesMiddleLayers := + LazyRevealProbe.valuesLE_of_mem_runRaw_done _ middleOtsState + layersState middleOtsRemaining layersRemaining + (verifiedRoot, layersCache) hafterMiddleOts + have hvaluesLayersRaw := + LazyRevealProbe.valuesLE_of_mem_runRaw_done _ layersState rawState + layersRemaining remaining (verified, rawCache) hafterLayers + have htableMiddle : ∀ coordinate output, + middleOtsState.values coordinate = some output → + output = table coordinate := by + intro coordinate output hvalue + exact hrawTable coordinate output + (hvaluesLayersRaw coordinate output + (hvaluesMiddleLayers coordinate output hvalue)) + have hftsInitial : ftsState = initialState := + hftsState.1.trans hdigestState.1 + have hmiddleInitialValue : + bottomFoldState.values probe.coordinate = none := by + rw [hbottomFoldCoordinate.1, hbottomOtsCoordinate.1, hftsInitial, + hinitialValue] + have hmiddleInitialNotRevealed : + probe.coordinate ∉ bottomFoldState.revealed := by + rw [hbottomFoldCoordinate.2, hbottomOtsCoordinate.2, hftsInitial] + exact hinitialNotRevealed + have hpendingMiddle := + simulateQ_verifierHashImpl_otsLeaf_pendingHit_of_correct_probe f + parameter table probe middleLayer + (treeIndexAt (digestIndex digest) middleLayer) + (leafIndexAt (digestIndex digest) middleLayer) layerMessage + (forgery.signature.counter middleLayer) + (forgery.signature.chainValue middleLayer) codeword chainIdx hdigit + hencode bottomFoldState middleOtsState bottomFoldCache + middleOtsCache bottomFoldRemaining middleOtsRemaining middleResult + hmatches hcandidate hmiddleInitialValue hmiddleInitialNotRevealed + hfMiddleOts htableMiddle hmiddleOtsRaw + have htableLayers : ∀ output, + layersState.values probe.coordinate = some output → + output = table probe.coordinate := by + intro output hvalue + exact hrawTable probe.coordinate output + (hvaluesLayersRaw probe.coordinate output hvalue) + have hpendingLayers := + LazyRevealProbe.pendingHit_preserved_of_mem_runRaw_done _ + probe.coordinate (table probe.coordinate) middleOtsState layersState + middleOtsRemaining layersRemaining (verifiedRoot, layersCache) + hpendingMiddle.1 hpendingMiddle.2 htableLayers hafterMiddleOts + have hpendingRaw := + LazyRevealProbe.pendingHit_preserved_of_mem_runRaw_done _ + probe.coordinate (table probe.coordinate) layersState rawState + layersRemaining remaining (verified, rawCache) hpendingLayers.1 + hpendingLayers.2 (hrawTable probe.coordinate) hafterLayers + exact finalizeDetailed_false_of_pending_hit table rawState completedState + probe.coordinate hpendingRaw.1 hpendingRaw.2 + (hcompletedTable probe.coordinate) hfinalize + +set_option maxRecDepth 10000 in +theorem ChainInvariant.not_finalized_false_of_top_verifyProbe_verifier + {f : QueryImpl HashSpec Id} {parameter : PublicParameter} + {table : Coordinate → HashOutput} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {targetCache : QueryCache HashSpec} + {initialState rawState completedState : LazyRevealProbe.State Coordinate} + {initialCache rawCache : SplitHashCache} {root : Digest} {forgery : Forgery} + {signingLog : QueryLog SigningSpec} {fuel remaining : Nat} {verified : Bool} + (hinvariant : ChainInvariant parameter + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) signingLog) + initialState initialCache) + (hf : CacheAnswersAgreeOnRun (ordinaryQueryCache rawCache) f + (verify ⟨root, parameter⟩ forgery.message forgery.signature)) + (hcompletedTable : ∀ coordinate output, + completedState.values coordinate = some output → output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hfinalize : (false, completedState) ∈ support + (LazyRevealProbe.finalizeDetailed rawState)) + (hverify : LazyRevealProbe.RawResult.done rawState remaining + (verified, rawCache) ∈ support + (LazyRevealProbe.runRaw initialState fuel + ((simulateQ (verifierRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).run + initialCache))) + (hprobe : VerifyProbeWitnessAt f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + signingLog forgery.message forgery.signature topLayer) : False := by + obtain ⟨digest, layerMessage, codeword, chainIdx, hdigit, probe, input, hinput, + hdigest, hadmissible, hencode, hverifierMessage, hhits, hmatches, _, _, + hnotCovered, _hsourceSettled⟩ := hprobe + obtain ⟨bottomLeaf, middleLeaf, hbottomLeaf, hmiddleLeaf, hlayerMessage⟩ := + VerifierLayerMessage.top_data hverifierMessage + rw [hinput] at hmatches + have hchain := probe.isChainCoordinate_of_matchesInput hmatches + have hcandidate : probe.candidate = truncateHash (table probe.coordinate) := + hhits.trans (probe.target_eq_truncate_table_of_chain f parameter table ftsSecret hchain + hrealizes) + have hinitialValue := hinvariant.1.value_eq_none_of_not_allowed hchain hnotCovered + have hinitialNotRevealed := hinvariant.1.not_revealed_of_not_allowed hchain hnotCovered + have hrawTable : ∀ coordinate output, rawState.values coordinate = some output → + output = table coordinate := by + intro coordinate output hvalue + exact hcompletedTable coordinate output + (finalizeDetailedFrom_preserves_value rawState.coordinates.toList rawState completedState + coordinate output hvalue hfinalize) + rw [simulateQ_verifierRom_scheme_verify, verify_eq, simulateQ_bind, + StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hverify + obtain ⟨digestRaw, hdigestRaw, hafterDigest⟩ := hverify + cases digestRaw with + | stopped hit => simp at hafterDigest + | done digestState digestRemaining digestResult => + rcases digestResult with ⟨sampledDigest, digestCache⟩ + have hfDigest : CacheAnswersAgreeOnRun (ordinaryQueryCache digestCache) f + (messageDigest parameter root forgery.message forgery.signature.randomness) := by + intro query hquery output hcached + apply hf query (messageDigest_query_mem_verify hquery) + exact (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + digestState digestCache digestRemaining rawState remaining verified rawCache output + hcached hafterDigest + have hdigestEval := + (replay_of_mem_runRaw_verifierHashImpl_of_cacheAnswersAgreeOnRun f parameter + (messageDigest parameter root forgery.message forgery.signature.randomness) + initialState digestState initialCache digestCache fuel digestRemaining sampledDigest + hfDigest hdigestRaw).1 + rw [hdigest] at hdigestEval + subst sampledDigest + have hdigestOrdinary := hdigestRaw + rw [simulateQ_verifierHashImpl_messageDigest_eq_ordinaryHashImpl] at hdigestOrdinary + have hdigestState := mem_runRaw_simulateQ_ordinaryHashImpl_projects + (messageDigest parameter root forgery.message forgery.signature.randomness) + initialState digestState initialCache digestCache fuel digestRemaining digest + hdigestOrdinary + simp only [hadmissible, not_true_eq_false, ↓reduceIte] at hafterDigest + rw [simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterDigest + obtain ⟨ftsRaw, hftsRaw, hafterFts⟩ := hafterDigest + cases ftsRaw with + | stopped hit => simp at hafterFts + | done ftsState ftsRemaining ftsResult => + rcases ftsResult with ⟨ftsPublicKey, ftsCache⟩ + have hfFts : CacheAnswersAgreeOnRun (ordinaryQueryCache ftsCache) f + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + forgery.signature.ftsSecret forgery.signature.ftsPath) := by + intro query hquery output hcached + apply hf query (ftsRecover_query_mem_verify hdigest hadmissible hquery) + exact (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + ftsState ftsCache ftsRemaining rawState remaining verified rawCache output hcached + hafterFts + have hftsEval := + (replay_of_mem_runRaw_verifierHashImpl_of_cacheAnswersAgreeOnRun f parameter + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + forgery.signature.ftsSecret forgery.signature.ftsPath) + digestState ftsState digestCache ftsCache digestRemaining ftsRemaining ftsPublicKey + hfFts hftsRaw).1 + have hftsOrdinary := hftsRaw + rw [simulateQ_verifierHashImpl_ftsRecover_eq_ordinaryHashImpl] at hftsOrdinary + have hftsState := mem_runRaw_simulateQ_ordinaryHashImpl_projects + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + forgery.signature.ftsSecret forgery.signature.ftsPath) + digestState ftsState digestCache ftsCache digestRemaining ftsRemaining ftsPublicKey + hftsOrdinary + subst ftsPublicKey + simp only at hafterFts + rw [simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterFts + obtain ⟨layersRaw, hlayersRaw, hafterLayers⟩ := hafterFts + cases layersRaw with + | stopped hit => simp at hafterLayers + | done layersState layersRemaining layersResult => + rcases layersResult with ⟨verifiedRoot, layersCache⟩ + rw [show numLayers = bottomLayer.val + 1 by rfl, verifyLayers_succ_eq, + dif_pos bottomLayer.isLt, simulateQ_bind, StateT.run_bind, + LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hlayersRaw + obtain ⟨bottomOtsRaw, hbottomOtsRaw, hafterBottomOts⟩ := hlayersRaw + cases bottomOtsRaw with + | stopped hit => simp at hafterBottomOts + | done bottomOtsState bottomOtsRemaining bottomOtsResult => + rcases bottomOtsResult with ⟨bottomResult, bottomOtsCache⟩ + have hfBottomOts : + CacheAnswersAgreeOnRun (ordinaryQueryCache bottomOtsCache) f + (otsLeaf parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (evalWithAnswerFn f + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + forgery.signature.ftsSecret forgery.signature.ftsPath)) + (forgery.signature.counter bottomLayer) + (forgery.signature.chainValue bottomLayer)) := by + intro query hquery output hcached + apply hf query (bottomOts_query_mem_verify hdigest hadmissible hquery) + have hcachedLayers := + (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + bottomOtsState bottomOtsCache bottomOtsRemaining layersState + layersRemaining verifiedRoot layersCache output hcached hafterBottomOts + exact (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + layersState layersCache layersRemaining rawState remaining verified rawCache + output hcachedLayers hafterLayers + have hbottomEval := + (replay_of_mem_runRaw_verifierHashImpl_of_cacheAnswersAgreeOnRun f parameter + (otsLeaf parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (evalWithAnswerFn f + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + forgery.signature.ftsSecret forgery.signature.ftsPath)) + (forgery.signature.counter bottomLayer) + (forgery.signature.chainValue bottomLayer)) + ftsState bottomOtsState ftsCache bottomOtsCache ftsRemaining + bottomOtsRemaining bottomResult hfBottomOts hbottomOtsRaw).1 + rw [hbottomLeaf] at hbottomEval + subst bottomResult + have hbottomOtsCoordinate := + preservesCoordinate_simulateQ_verifierHashImpl_otsLeaf_of_layer_ne parameter + probe topLayer (treeIndexAt (digestIndex digest) topLayer) + (leafIndexAt (digestIndex digest) topLayer) chainIdx + ⟨(codeword chainIdx).val, hdigit⟩ + (forgery.signature.chainValue topLayer chainIdx) hmatches bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (evalWithAnswerFn f + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + forgery.signature.ftsSecret forgery.signature.ftsPath)) + (forgery.signature.counter bottomLayer) + (forgery.signature.chainValue bottomLayer) (by decide) + ftsState ftsCache ftsRemaining bottomOtsState bottomOtsRemaining + (some bottomLeaf) bottomOtsCache hbottomOtsRaw + simp only at hafterBottomOts + rw [simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterBottomOts + obtain ⟨bottomFoldRaw, hbottomFoldRaw, hafterBottomFold⟩ := hafterBottomOts + cases bottomFoldRaw with + | stopped hit => simp at hafterBottomFold + | done bottomFoldState bottomFoldRemaining bottomFoldResult => + rcases bottomFoldResult with ⟨bottomRoot, bottomFoldCache⟩ + have hfBottomFold : + CacheAnswersAgreeOnRun (ordinaryQueryCache bottomFoldCache) f + (treeFold parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath forgery.signature bottomLayer) + (layerHeight bottomLayer) bottomLeaf) := by + intro query hquery output hcached + apply hf query + (bottomFold_query_mem_verify hdigest hadmissible hbottomLeaf hquery) + have hcachedLayers := + (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + bottomFoldState bottomFoldCache bottomFoldRemaining layersState + layersRemaining verifiedRoot layersCache output hcached + hafterBottomFold + exact + (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + layersState layersCache layersRemaining rawState remaining verified + rawCache output hcachedLayers hafterLayers + have hbottomFoldEval := + (replay_of_mem_runRaw_verifierHashImpl_of_cacheAnswersAgreeOnRun f parameter + (treeFold parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath forgery.signature bottomLayer) + (layerHeight bottomLayer) bottomLeaf) + bottomOtsState bottomFoldState bottomOtsCache bottomFoldCache + bottomOtsRemaining bottomFoldRemaining bottomRoot hfBottomFold + hbottomFoldRaw).1 + change foldValue f parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath forgery.signature bottomLayer) bottomLeaf + (layerHeight bottomLayer) = bottomRoot at hbottomFoldEval + subst bottomRoot + have hbottomFoldCoordinate := + preservesCoordinate_simulateQ_verifierHashImpl_treeFold_of_layer_ne + parameter probe topLayer (treeIndexAt (digestIndex digest) topLayer) + (leafIndexAt (digestIndex digest) topLayer) chainIdx + ⟨(codeword chainIdx).val, hdigit⟩ + (forgery.signature.chainValue topLayer chainIdx) hmatches bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath forgery.signature bottomLayer) (by decide) + (layerHeight bottomLayer) bottomLeaf (layerHeight_le bottomLayer) + bottomOtsState bottomOtsCache bottomOtsRemaining bottomFoldState + bottomFoldRemaining + (foldValue f parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath forgery.signature bottomLayer) bottomLeaf + (layerHeight bottomLayer)) + bottomFoldCache hbottomFoldRaw + simp only at hafterBottomFold + rw [show bottomLayer.val = middleLayer.val + 1 by rfl, + verifyLayers_succ_eq, dif_pos middleLayer.isLt, simulateQ_bind, + StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterBottomFold + obtain ⟨middleOtsRaw, hmiddleOtsRaw, hafterMiddleOts⟩ := + hafterBottomFold + cases middleOtsRaw with + | stopped hit => simp at hafterMiddleOts + | done middleOtsState middleOtsRemaining middleOtsResult => + rcases middleOtsResult with ⟨middleResult, middleOtsCache⟩ + have hfMiddleOts : + CacheAnswersAgreeOnRun (ordinaryQueryCache middleOtsCache) f + (otsLeaf parameter middleLayer + (treeIndexAt (digestIndex digest) middleLayer) + (leafIndexAt (digestIndex digest) middleLayer) + (foldValue f parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath forgery.signature bottomLayer) bottomLeaf + (layerHeight bottomLayer)) + (forgery.signature.counter middleLayer) + (forgery.signature.chainValue middleLayer)) := by + intro query hquery output hcached + apply hf query + (middleOts_query_mem_verify hdigest hadmissible hbottomLeaf hquery) + have hcachedLayers := + (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + middleOtsState middleOtsCache middleOtsRemaining layersState + layersRemaining verifiedRoot layersCache output hcached + hafterMiddleOts + exact + (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + layersState layersCache layersRemaining rawState remaining verified + rawCache output hcachedLayers hafterLayers + have hmiddleEval := + (replay_of_mem_runRaw_verifierHashImpl_of_cacheAnswersAgreeOnRun f + parameter + (otsLeaf parameter middleLayer + (treeIndexAt (digestIndex digest) middleLayer) + (leafIndexAt (digestIndex digest) middleLayer) + (foldValue f parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath forgery.signature bottomLayer) bottomLeaf + (layerHeight bottomLayer)) + (forgery.signature.counter middleLayer) + (forgery.signature.chainValue middleLayer)) + bottomFoldState middleOtsState bottomFoldCache middleOtsCache + bottomFoldRemaining middleOtsRemaining middleResult hfMiddleOts + hmiddleOtsRaw).1 + rw [hmiddleLeaf] at hmiddleEval + subst middleResult + have hmiddleOtsCoordinate := + preservesCoordinate_simulateQ_verifierHashImpl_otsLeaf_of_layer_ne + parameter probe topLayer + (treeIndexAt (digestIndex digest) topLayer) + (leafIndexAt (digestIndex digest) topLayer) chainIdx + ⟨(codeword chainIdx).val, hdigit⟩ + (forgery.signature.chainValue topLayer chainIdx) hmatches middleLayer + (treeIndexAt (digestIndex digest) middleLayer) + (leafIndexAt (digestIndex digest) middleLayer) + (foldValue f parameter bottomLayer + (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (signaturePath forgery.signature bottomLayer) bottomLeaf + (layerHeight bottomLayer)) + (forgery.signature.counter middleLayer) + (forgery.signature.chainValue middleLayer) (by decide) + bottomFoldState bottomFoldCache bottomFoldRemaining middleOtsState + middleOtsRemaining (some middleLeaf) middleOtsCache hmiddleOtsRaw + simp only at hafterMiddleOts + rw [simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterMiddleOts + obtain ⟨middleFoldRaw, hmiddleFoldRaw, hafterMiddleFold⟩ := + hafterMiddleOts + cases middleFoldRaw with + | stopped hit => simp at hafterMiddleFold + | done middleFoldState middleFoldRemaining middleFoldResult => + rcases middleFoldResult with ⟨middleRoot, middleFoldCache⟩ + have hfMiddleFold : + CacheAnswersAgreeOnRun (ordinaryQueryCache middleFoldCache) f + (treeFold parameter middleLayer + (treeIndexAt (digestIndex digest) middleLayer) + (leafIndexAt (digestIndex digest) middleLayer) + (signaturePath forgery.signature middleLayer) + (layerHeight middleLayer) middleLeaf) := by + intro query hquery output hcached + apply hf query + (middleFold_query_mem_verify hdigest hadmissible hbottomLeaf + hmiddleLeaf hquery) + have hcachedLayers := + (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + middleFoldState middleFoldCache middleFoldRemaining layersState + layersRemaining verifiedRoot layersCache output hcached + hafterMiddleFold + exact + (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + layersState layersCache layersRemaining rawState remaining + verified rawCache output hcachedLayers hafterLayers + have hmiddleFoldEval := + (replay_of_mem_runRaw_verifierHashImpl_of_cacheAnswersAgreeOnRun f + parameter + (treeFold parameter middleLayer + (treeIndexAt (digestIndex digest) middleLayer) + (leafIndexAt (digestIndex digest) middleLayer) + (signaturePath forgery.signature middleLayer) + (layerHeight middleLayer) middleLeaf) + middleOtsState middleFoldState middleOtsCache middleFoldCache + middleOtsRemaining middleFoldRemaining middleRoot hfMiddleFold + hmiddleFoldRaw).1 + change foldValue f parameter middleLayer + (treeIndexAt (digestIndex digest) middleLayer) + (leafIndexAt (digestIndex digest) middleLayer) + (signaturePath forgery.signature middleLayer) middleLeaf + (layerHeight middleLayer) = middleRoot at hmiddleFoldEval + rw [← hlayerMessage] at hmiddleFoldEval + subst middleRoot + have hmiddleFoldCoordinate := + preservesCoordinate_simulateQ_verifierHashImpl_treeFold_of_layer_ne + parameter probe topLayer + (treeIndexAt (digestIndex digest) topLayer) + (leafIndexAt (digestIndex digest) topLayer) chainIdx + ⟨(codeword chainIdx).val, hdigit⟩ + (forgery.signature.chainValue topLayer chainIdx) hmatches + middleLayer (treeIndexAt (digestIndex digest) middleLayer) + (leafIndexAt (digestIndex digest) middleLayer) + (signaturePath forgery.signature middleLayer) (by decide) + (layerHeight middleLayer) middleLeaf (layerHeight_le middleLayer) + middleOtsState middleOtsCache middleOtsRemaining middleFoldState + middleFoldRemaining layerMessage middleFoldCache hmiddleFoldRaw + simp only at hafterMiddleFold + rw [show middleLayer.val = topLayer.val + 1 by rfl, + verifyLayers_succ_eq, dif_pos topLayer.isLt, simulateQ_bind, + StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterMiddleFold + obtain ⟨topOtsRaw, htopOtsRaw, hafterTopOts⟩ := + hafterMiddleFold + cases topOtsRaw with + | stopped hit => simp at hafterTopOts + | done topOtsState topOtsRemaining topOtsResult => + rcases topOtsResult with ⟨topResult, topOtsCache⟩ + have hfTopOts : + CacheAnswersAgreeOnRun (ordinaryQueryCache topOtsCache) f + (encode parameter topLayer + (treeIndexAt (digestIndex digest) topLayer) + (leafIndexAt (digestIndex digest) topLayer) layerMessage + (forgery.signature.counter topLayer)) := by + intro query hquery output hcached + apply hf query + (VerifierLayerMessage.otsLeaf_query_mem_verify hdigest + hadmissible hverifierMessage (by + unfold otsLeaf + rw [queriedInputs_bind] + exact List.mem_append_left _ hquery)) + have hcachedLayers := + (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + topOtsState topOtsCache topOtsRemaining layersState + layersRemaining verifiedRoot layersCache output hcached + hafterTopOts + exact + (ordinaryEntryPreservingImpl_verifierHashImpl parameter query).simulateQ _ + layersState layersCache layersRemaining rawState remaining + verified rawCache output hcachedLayers hafterLayers + have hvaluesTopLayers := + LazyRevealProbe.valuesLE_of_mem_runRaw_done _ topOtsState + layersState topOtsRemaining layersRemaining + (verifiedRoot, layersCache) hafterTopOts + have hvaluesLayersRaw := + LazyRevealProbe.valuesLE_of_mem_runRaw_done _ layersState + rawState layersRemaining remaining (verified, rawCache) + hafterLayers + have htableTop : ∀ coordinate output, + topOtsState.values coordinate = some output → + output = table coordinate := by + intro coordinate output hvalue + exact hrawTable coordinate output + (hvaluesLayersRaw coordinate output + (hvaluesTopLayers coordinate output hvalue)) + have hftsInitial : ftsState = initialState := + hftsState.1.trans hdigestState.1 + have htopInitialValue : + middleFoldState.values probe.coordinate = none := by + rw [hmiddleFoldCoordinate.1, hmiddleOtsCoordinate.1, + hbottomFoldCoordinate.1, hbottomOtsCoordinate.1, + hftsInitial, hinitialValue] + have htopInitialNotRevealed : + probe.coordinate ∉ middleFoldState.revealed := by + rw [hmiddleFoldCoordinate.2, hmiddleOtsCoordinate.2, + hbottomFoldCoordinate.2, hbottomOtsCoordinate.2, hftsInitial] + exact hinitialNotRevealed + have hpendingTop := + simulateQ_verifierHashImpl_otsLeaf_pendingHit_of_correct_probe + f parameter table probe topLayer + (treeIndexAt (digestIndex digest) topLayer) + (leafIndexAt (digestIndex digest) topLayer) layerMessage + (forgery.signature.counter topLayer) + (forgery.signature.chainValue topLayer) codeword chainIdx + hdigit hencode middleFoldState topOtsState middleFoldCache + topOtsCache middleFoldRemaining topOtsRemaining topResult + hmatches hcandidate htopInitialValue htopInitialNotRevealed + hfTopOts htableTop htopOtsRaw + have htableLayers : ∀ output, + layersState.values probe.coordinate = some output → + output = table probe.coordinate := by + intro output hvalue + exact hrawTable probe.coordinate output + (hvaluesLayersRaw probe.coordinate output hvalue) + have hpendingLayers := + LazyRevealProbe.pendingHit_preserved_of_mem_runRaw_done _ + probe.coordinate (table probe.coordinate) topOtsState + layersState topOtsRemaining layersRemaining + (verifiedRoot, layersCache) hpendingTop.1 hpendingTop.2 + htableLayers hafterTopOts + have hpendingRaw := + LazyRevealProbe.pendingHit_preserved_of_mem_runRaw_done _ + probe.coordinate (table probe.coordinate) layersState rawState + layersRemaining remaining (verified, rawCache) + hpendingLayers.1 hpendingLayers.2 + (hrawTable probe.coordinate) hafterLayers + exact finalizeDetailed_false_of_pending_hit table rawState + completedState probe.coordinate hpendingRaw.1 hpendingRaw.2 + (hcompletedTable probe.coordinate) hfinalize + +set_option maxRecDepth 10000 in +theorem ChainInvariant.not_finalized_false_of_verifyProbe_verifier + {f : QueryImpl HashSpec Id} {parameter : PublicParameter} + {table : Coordinate → HashOutput} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {targetCache : QueryCache HashSpec} + {initialState rawState completedState : LazyRevealProbe.State Coordinate} + {initialCache rawCache : SplitHashCache} {root : Digest} {forgery : Forgery} + {signingLog : QueryLog SigningSpec} {fuel remaining : Nat} {verified : Bool} + (hinvariant : ChainInvariant parameter + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) signingLog) + initialState initialCache) + (hf : CacheAnswersAgreeOnRun (ordinaryQueryCache rawCache) f + (verify ⟨root, parameter⟩ forgery.message forgery.signature)) + (hcompletedTable : ∀ coordinate output, + completedState.values coordinate = some output → output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hfinalize : (false, completedState) ∈ support + (LazyRevealProbe.finalizeDetailed rawState)) + (hverify : LazyRevealProbe.RawResult.done rawState remaining + (verified, rawCache) ∈ support + (LazyRevealProbe.runRaw initialState fuel + ((simulateQ (verifierRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).run + initialCache))) + (hprobe : VerifyProbeWitness f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + signingLog forgery.message forgery.signature) : False := by + rcases hprobe.at_bottom_or_middle_or_top with hbottom | hmiddle | htop + · exact hinvariant.not_finalized_false_of_bottom_verifyProbe_verifier hf hcompletedTable + hrealizes hfinalize hverify hbottom + · exact hinvariant.not_finalized_false_of_middle_verifyProbe_verifier hf hcompletedTable + hrealizes hfinalize hverify hmiddle + · exact hinvariant.not_finalized_false_of_top_verifyProbe_verifier hf hcompletedTable + hrealizes hfinalize hverify htop + +set_option maxRecDepth 10000 in +theorem not_verifyProbe_of_mem_runRaw_maskedRetainedGameAfterFtsSecrets + (adversary : Adversary) (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel remaining : Nat) (rawState completedState : LazyRevealProbe.State Coordinate) + (rawCache : SplitHashCache) (root : Digest) (forgery : Forgery) + (signingLog : QueryLog SigningSpec) (verified : Bool) + (hfStable : StableCacheAgreesWithFn parameter rawCache f) + (hfOrdinary : CacheAnswersAgreeOnRun (ordinaryQueryCache rawCache) f + (verify ⟨root, parameter⟩ forgery.message forgery.signature)) + (hrawTable : ∀ coordinate output, rawState.values coordinate = some output → + output = table coordinate) + (hcompletedTable : ∀ coordinate output, + completedState.values coordinate = some output → output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hresult : LazyRevealProbe.RawResult.done rawState remaining + ((root, ((forgery, signingLog), verified)), rawCache) ∈ support + (LazyRevealProbe.runRaw (LazyRevealProbe.State.empty : + LazyRevealProbe.State Coordinate) fuel + ((maskedRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) + (hfinalize : (false, completedState) ∈ support + (LazyRevealProbe.finalizeDetailed rawState)) + (hprobe : VerifyProbeWitness f + (mergedCache parameter table rawState.ensured rawCache) + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + signingLog forgery.message forgery.signature) : False := by + obtain ⟨verifierState, verifierFuel, verifierCache, hinvariant, hverify⟩ := + chainInvariant_maskedRetainedGameAfterFtsSecrets_mergedCache adversary f parameter table + ftsSecret fuel remaining rawState rawCache root forgery signingLog verified hfStable + hrawTable hrealizes hresult + exact hinvariant.not_finalized_false_of_verifyProbe_verifier hfOrdinary hcompletedTable + hrealizes hfinalize hverify hprobe + +theorem finalizeDetailedFrom_ensured_eq : + ∀ (coordinates : List Coordinate) (state finalState : LazyRevealProbe.State Coordinate), + (false, finalState) ∈ support + (LazyRevealProbe.finalizeDetailedFrom coordinates state) → + finalState.ensured = state.ensured := by + intro coordinates + induction coordinates with + | nil => + intro state finalState hresult + simp [LazyRevealProbe.finalizeDetailedFrom] at hresult + exact congrArg LazyRevealProbe.State.ensured hresult + | cons coordinate coordinates ih => + intro state finalState hresult + rw [LazyRevealProbe.finalizeDetailedFrom] at hresult + cases hvalue : state.values coordinate with + | some output => + rw [hvalue] at hresult + exact (ih (state.clearPending coordinate) finalState hresult).trans (by + simp [LazyRevealProbe.State.clearPending]) + | none => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨output, _, hrest⟩ := hresult + by_cases hhit : state.hitAt coordinate output + · rw [if_pos hhit] at hrest + simp at hrest + · rw [if_neg hhit] at hrest + exact (ih (state.complete coordinate output) finalState hrest).trans (by + simp [LazyRevealProbe.State.complete]) + +theorem finalizeDetailed_ensured_eq + (state finalState : LazyRevealProbe.State Coordinate) + (hresult : (false, finalState) ∈ support + (LazyRevealProbe.finalizeDetailed state)) : + finalState.ensured = state.ensured := + finalizeDetailedFrom_ensured_eq state.coordinates.toList state finalState hresult + +theorem retainedCompletion_of_finalize + (parameter : PublicParameter) + (rawState completedState : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (hconsistent : HiddenConsistent rawState cache) + (hfinalize : (false, completedState) ∈ support + (LazyRevealProbe.finalizeDetailed rawState)) : + let table := retainedCompletionTable parameter completedState cache baseStarts + let f := retainedCompletionAnswer parameter completedState cache baseStarts + StableCacheAgreesWithFn parameter cache f ∧ + (mergedCache parameter table rawState.ensured cache).AgreesWithFn f ∧ + (∀ coordinate output, rawState.values coordinate = some output → + output = table coordinate) ∧ + (∀ coordinate output, completedState.values coordinate = some output → + output = table coordinate) ∧ + (∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) := by + let table := retainedCompletionTable parameter completedState cache baseStarts + let f := retainedCompletionAnswer parameter completedState cache baseStarts + have hensured := finalizeDetailed_ensured_eq rawState completedState hfinalize + have hcompletedConsistent := + finalizeDetailed_preservesHidden rawState cache hconsistent completedState hfinalize + have hcompletedTable : ∀ coordinate output, + completedState.values coordinate = some output → output = table coordinate := by + intro coordinate output hvalue + exact (completedRealizedTable_of_value (splitFallback cache) parameter completedState + baseStarts coordinate output hvalue).symm + have hrawTable : ∀ coordinate output, + rawState.values coordinate = some output → output = table coordinate := by + intro coordinate output hvalue + exact hcompletedTable coordinate output + (finalizeDetailedFrom_preserves_value rawState.coordinates.toList rawState completedState + coordinate output hvalue hfinalize) + refine ⟨stableCacheAgreesWithFn_retainedCompletionAnswer parameter completedState cache + baseStarts, ?_, hrawTable, hcompletedTable, + retainedCompletionAnswer_realizes parameter completedState cache baseStarts⟩ + rw [← hensured] + exact mergedCache_agreesWithFn_retainedCompletionAnswer parameter completedState cache + baseStarts hcompletedConsistent + +set_option maxRecDepth 10000 in +theorem not_verifyProbe_of_retainedCompletion + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (fuel remaining : Nat) (rawState completedState : LazyRevealProbe.State Coordinate) + (rawCache : SplitHashCache) (root : Digest) (forgery : Forgery) + (signingLog : QueryLog SigningSpec) (verified : Bool) + (hconsistent : HiddenConsistent rawState rawCache) + (hresult : LazyRevealProbe.RawResult.done rawState remaining + ((root, ((forgery, signingLog), verified)), rawCache) ∈ support + (LazyRevealProbe.runRaw (LazyRevealProbe.State.empty : + LazyRevealProbe.State Coordinate) fuel + ((maskedRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) + (hfinalize : (false, completedState) ∈ support + (LazyRevealProbe.finalizeDetailed rawState)) + (hfOrdinary : CacheAnswersAgreeOnRun (ordinaryQueryCache rawCache) + (retainedCompletionAnswer parameter completedState rawCache baseStarts) + (verify ⟨root, parameter⟩ forgery.message forgery.signature)) + (hprobe : VerifyProbeWitness + (retainedCompletionAnswer parameter completedState rawCache baseStarts) + (mergedCache parameter + (retainedCompletionTable parameter completedState rawCache baseStarts) + completedState.ensured rawCache) + (⟨parameter, root, + tableOtsSecret (retainedCompletionTable parameter completedState rawCache baseStarts), + ftsSecret⟩ : SecretKey) + signingLog forgery.message forgery.signature) : False := by + obtain ⟨hfStable, _hfMerged, hrawTable, hcompletedTable, hrealizes⟩ := + retainedCompletion_of_finalize parameter rawState completedState rawCache baseStarts + hconsistent hfinalize + have hensured := finalizeDetailed_ensured_eq rawState completedState hfinalize + rw [hensured] at hprobe + exact not_verifyProbe_of_mem_runRaw_maskedRetainedGameAfterFtsSecrets adversary + (retainedCompletionAnswer parameter completedState rawCache baseStarts) parameter + (retainedCompletionTable parameter completedState rawCache baseStarts) ftsSecret fuel + remaining rawState completedState rawCache root forgery signingLog verified hfStable + hfOrdinary hrawTable hcompletedTable hrealizes hresult hfinalize hprobe + +set_option maxRecDepth 10000 in +theorem not_verifyProbe_of_retainedCompletion_of_trace_exact_materialized + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (fuel remaining : Nat) (rawState completedState : LazyRevealProbe.State Coordinate) + (rawCache : SplitHashCache) (root : Digest) (forgery : Forgery) + (signingLog : QueryLog SigningSpec) (verified : Bool) + (hconsistent : HiddenConsistent rawState rawCache) + (hresult : LazyRevealProbe.RawResult.done rawState remaining + ((root, ((forgery, signingLog), verified)), rawCache) ∈ support + (LazyRevealProbe.runRaw (LazyRevealProbe.State.empty : + LazyRevealProbe.State Coordinate) fuel + ((maskedRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) + (hfinalize : (false, completedState) ∈ support + (LazyRevealProbe.finalizeDetailed rawState)) + (hexact : TraceExactMaterializedCacheConsistent parameter + (retainedCompletionTable parameter completedState rawCache baseStarts) + completedState rawCache + (retainedCompletionAnswer parameter completedState rawCache baseStarts) + (verify ⟨root, parameter⟩ forgery.message forgery.signature)) + (hprobe : VerifyProbeWitness + (retainedCompletionAnswer parameter completedState rawCache baseStarts) + (mergedCache parameter + (retainedCompletionTable parameter completedState rawCache baseStarts) + completedState.ensured rawCache) + (⟨parameter, root, + tableOtsSecret (retainedCompletionTable parameter completedState rawCache baseStarts), + ftsSecret⟩ : SecretKey) + signingLog forgery.message forgery.signature) : False := by + apply not_verifyProbe_of_retainedCompletion adversary parameter ftsSecret baseStarts fuel + remaining rawState completedState rawCache root forgery signingLog verified hconsistent + hresult hfinalize + · exact cacheAnswersAgreeOnRun_retainedCompletionAnswer_of_trace_exact_materialized + parameter completedState rawCache baseStarts + (verify ⟨root, parameter⟩ forgery.message forgery.signature) hexact + · exact hprobe + +set_option maxRecDepth 10000 in +theorem not_verifyProbe_of_retainedCompletion_of_exact_materialized + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (fuel remaining : Nat) (rawState completedState : LazyRevealProbe.State Coordinate) + (rawCache : SplitHashCache) (root : Digest) (forgery : Forgery) + (signingLog : QueryLog SigningSpec) (verified : Bool) + (hconsistent : HiddenConsistent rawState rawCache) + (hresult : LazyRevealProbe.RawResult.done rawState remaining + ((root, ((forgery, signingLog), verified)), rawCache) ∈ support + (LazyRevealProbe.runRaw (LazyRevealProbe.State.empty : + LazyRevealProbe.State Coordinate) fuel + ((maskedRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) + (hfinalize : (false, completedState) ∈ support + (LazyRevealProbe.finalizeDetailed rawState)) + (hexact : ∀ (input : HashInput) (position : Position) (output : HashOutput), + IsOtsPosition position → + decodePosition? parameter input = some position → + input = tableInput parameter + (retainedCompletionTable parameter completedState rawCache baseStarts) + (.position position) → + completedState.values (.position position) ≠ none → + rawCache (.ordinary input) = some output → + output = retainedCompletionTable parameter completedState rawCache baseStarts + (.position position)) + (hprobe : VerifyProbeWitness + (retainedCompletionAnswer parameter completedState rawCache baseStarts) + (mergedCache parameter + (retainedCompletionTable parameter completedState rawCache baseStarts) + completedState.ensured rawCache) + (⟨parameter, root, + tableOtsSecret (retainedCompletionTable parameter completedState rawCache baseStarts), + ftsSecret⟩ : SecretKey) + signingLog forgery.message forgery.signature) : False := by + apply not_verifyProbe_of_retainedCompletion_of_trace_exact_materialized adversary parameter + ftsSecret baseStarts fuel + remaining rawState completedState rawCache root forgery signingLog verified hconsistent + hresult hfinalize + · intro input _ position output hots hposition hinput hvalue hcached + exact hexact input position output hots hposition hinput hvalue hcached + · exact hprobe + +set_option maxRecDepth 10000 in +theorem not_verifyProbe_of_retainedCompletion_of_clean_finalize + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (fuel remaining : Nat) (rawState completedState : LazyRevealProbe.State Coordinate) + (rawCache : SplitHashCache) (root : Digest) (forgery : Forgery) + (signingLog : QueryLog SigningSpec) (verified : Bool) + (hconsistent : HiddenConsistent rawState rawCache) + (hresult : LazyRevealProbe.RawResult.done rawState remaining + ((root, ((forgery, signingLog), verified)), rawCache) ∈ support + (LazyRevealProbe.runRaw (LazyRevealProbe.State.empty : + LazyRevealProbe.State Coordinate) fuel + ((maskedRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) + (hfinalize : (false, completedState) ∈ support + (LazyRevealProbe.finalizeDetailed rawState)) + (hprobe : VerifyProbeWitness + (retainedCompletionAnswer parameter completedState rawCache baseStarts) + (mergedCache parameter + (retainedCompletionTable parameter completedState rawCache baseStarts) + completedState.ensured rawCache) + (⟨parameter, root, + tableOtsSecret (retainedCompletionTable parameter completedState rawCache baseStarts), + ftsSecret⟩ : SecretKey) + signingLog forgery.message forgery.signature) : False := by + obtain ⟨_, _, _, hcompletedTable, _⟩ := + retainedCompletion_of_finalize parameter rawState completedState rawCache baseStarts + hconsistent hfinalize + apply not_verifyProbe_of_retainedCompletion_of_exact_materialized adversary parameter + ftsSecret baseStarts fuel remaining rawState completedState rawCache root forgery signingLog + verified hconsistent hresult hfinalize + · exact exactMaterializedCacheConsistent_of_clean_finalize adversary parameter + (retainedCompletionTable parameter completedState rawCache baseStarts) ftsSecret fuel + remaining rawState completedState rawCache root forgery signingLog verified + hcompletedTable hresult hfinalize + · exact hprobe + +def RetainedCompletionVerifyProbe (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (completedState : LazyRevealProbe.State Coordinate) (rawCache : SplitHashCache) + (root : Digest) (forgery : Forgery) (signingLog : QueryLog SigningSpec) : Prop := + VerifyProbeWitness + (retainedCompletionAnswer parameter completedState rawCache baseStarts) + (mergedCache parameter + (retainedCompletionTable parameter completedState rawCache baseStarts) + completedState.ensured rawCache) + ⟨parameter, root, + tableOtsSecret (retainedCompletionTable parameter completedState rawCache baseStarts), + ftsSecret⟩ + signingLog forgery.message forgery.signature + +set_option maxRecDepth 10000 in +theorem detailedExperiment_maskedRetainedGame_not_verifyProbe + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (fuel remaining : Nat) (completedState : LazyRevealProbe.State Coordinate) + (rawCache : SplitHashCache) (root : Digest) (forgery : Forgery) + (signingLog : QueryLog SigningSpec) (verified : Bool) + (hresult : LazyRevealProbe.DetailedResult.done false completedState remaining + ((root, ((forgery, signingLog), verified)), rawCache) ∈ support + (LazyRevealProbe.detailedExperiment + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel + ((maskedRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) + (hprobe : RetainedCompletionVerifyProbe parameter ftsSecret baseStarts completedState + rawCache root forgery signingLog) : False := by + change VerifyProbeWitness + (retainedCompletionAnswer parameter completedState rawCache baseStarts) + (mergedCache parameter + (retainedCompletionTable parameter completedState rawCache baseStarts) + completedState.ensured rawCache) + (⟨parameter, root, + tableOtsSecret (retainedCompletionTable parameter completedState rawCache baseStarts), + ftsSecret⟩ : SecretKey) + signingLog forgery.message forgery.signature at hprobe + rw [LazyRevealProbe.detailedExperiment, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hfinish⟩ := hresult + cases raw with + | stopped hit => + simp [LazyRevealProbe.RawResult.finishDetailed] at hfinish + | done rawState rawRemaining rawResult => + rcases rawResult with ⟨rawValue, finalCache⟩ + rcases rawValue with ⟨rawRoot, ⟨⟨rawForgery, rawLog⟩, rawVerified⟩⟩ + rw [LazyRevealProbe.RawResult.finishDetailed, mem_support_bind_iff] at hfinish + obtain ⟨finished, hfinalize, hreturn⟩ := hfinish + rcases finished with ⟨hit, finalState⟩ + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hdone := LazyRevealProbe.DetailedResult.done.inj hreturn + rcases hdone with ⟨rfl, rfl, rfl, hvalue⟩ + have houter := Prod.mk.inj hvalue + have hgame := Prod.mk.inj houter.1 + have hrest := Prod.mk.inj hgame.2 + have hforgeryLog := Prod.mk.inj hrest.1 + have hprobe' := hprobe + rw [hgame.1, hforgeryLog.1, hforgeryLog.2, houter.2] at hprobe' + have hconsistent : HiddenConsistent rawState finalCache := + PreservesHidden.done + (preservesHidden_maskedRetainedGameAfterFtsSecrets adversary parameter ftsSecret) + hiddenConsistent_empty hraw + exact not_verifyProbe_of_retainedCompletion_of_clean_finalize adversary parameter + ftsSecret baseStarts fuel remaining rawState completedState finalCache rawRoot rawForgery + rawLog rawVerified hconsistent hraw hfinalize hprobe' + +theorem detailedExperiment_maskedRetainedGame_excludes_completionVerifyProbe + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (fuel remaining : Nat) (completedState : LazyRevealProbe.State Coordinate) + (rawCache : SplitHashCache) (root : Digest) (forgery : Forgery) + (signingLog : QueryLog SigningSpec) (verified : Bool) + (hresult : LazyRevealProbe.DetailedResult.done false completedState remaining + ((root, ((forgery, signingLog), verified)), rawCache) ∈ support + (LazyRevealProbe.detailedExperiment + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel + ((maskedRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) : + ¬RetainedCompletionVerifyProbe parameter ftsSecret baseStarts completedState rawCache + root forgery signingLog := by + exact fun hprobe => detailedExperiment_maskedRetainedGame_not_verifyProbe adversary parameter + ftsSecret baseStarts fuel remaining completedState rawCache root forgery signingLog verified + hresult hprobe + +theorem detailedExperiment_maskedRetainedGame_excludes_completionVerifyProbe_of_hit_eq_false + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (baseStarts : Layer → TreeIndex → LeafIndex → ChainIndex → HashOutput) + (fuel remaining : Nat) (hit : Bool) + (completedState : LazyRevealProbe.State Coordinate) + (rawCache : SplitHashCache) (root : Digest) (forgery : Forgery) + (signingLog : QueryLog SigningSpec) (verified : Bool) (hhit : hit = false) + (hresult : LazyRevealProbe.DetailedResult.done hit completedState remaining + ((root, ((forgery, signingLog), verified)), rawCache) ∈ support + (LazyRevealProbe.detailedExperiment + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel + ((maskedRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) : + ¬RetainedCompletionVerifyProbe parameter ftsSecret baseStarts completedState rawCache + root forgery signingLog := by + subst hit + exact detailedExperiment_maskedRetainedGame_excludes_completionVerifyProbe adversary parameter + ftsSecret baseStarts fuel remaining completedState rawCache root forgery signingLog verified + hresult + +theorem relTriple_runRaw_splitUniformImpl + (n : Nat) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (fuel : Nat) : + RelTriple + (LazyRevealProbe.runRaw state fuel ((splitUniformImpl n).run cache)) + ((liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) >>= fun output => + pure (output, ordinaryQueryCache cache)) + (RawOrdinaryResultRelAt (alpha := Fin (n + 1)) state fuel) := by + let uniform : ProbComp (Fin (n + 1)) := liftM (unifSpec.query n) + have hself : RelTriple uniform uniform fun left right => left = right := + relTriple_refl uniform + have hpre : RelTriple uniform uniform fun left right => + RawOrdinaryResultRelAt state fuel + (.done state fuel (left, cache)) (right, ordinaryQueryCache cache) := by + apply relTriple_post_mono hself + intro left right heq + subst right + simp [RawOrdinaryResultRelAt] + have hmapped := relTriple_map + (R := RawOrdinaryResultRelAt (alpha := Fin (n + 1)) state fuel) + (f := fun output => LazyRevealProbe.RawResult.done state fuel (output, cache)) + (g := fun output => (output, ordinaryQueryCache cache)) hpre + simpa [uniform, splitUniformImpl, LazyRevealProbe.uniformQuery, + LazyRevealProbe.runRaw_uniform_query_bind, LazyRevealProbe.runRaw, + map_eq_bind_pure_comp] using hmapped + +set_option maxRecDepth 10000 in +theorem relTriple_runRaw_simulateQ_ordinaryHashImpl + [Inhabited alpha] + (computation : OracleComp HashSpec alpha) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) (fuel : Nat) : + RelTriple + (LazyRevealProbe.runRaw state fuel + ((simulateQ ordinaryHashImpl computation).run cache)) + ((simulateQ (randomOracle : QueryImpl HashSpec _) computation).run + (ordinaryQueryCache cache)) + (RawOrdinaryResultRel (alpha := alpha)) := by + have hproject := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_of_project_eq_some_exact + projectRawOrdinary + (default, ∅) + (LazyRevealProbe.runRaw state fuel + ((simulateQ ordinaryHashImpl computation).run cache)) + ((simulateQ (randomOracle : QueryImpl HashSpec _) computation).run + (ordinaryQueryCache cache)) + (projectRawOrdinary_simulateQ_ordinaryHashImpl computation state cache fuel) + apply relTriple_post_mono hproject + intro rawResult ordinaryResult hrelation + cases rawResult with + | stopped hit => simp [projectRawOrdinary] at hrelation + | done finalState remaining valueCache => + rcases valueCache with ⟨value, finalCache⟩ + change ordinaryResult = (value, ordinaryQueryCache finalCache) + exact (Option.some.inj hrelation).symm + +set_option maxRecDepth 10000 in +theorem relTriple_runRaw_simulateQ_ordinaryHashImpl_at + [Inhabited alpha] + (computation : OracleComp HashSpec alpha) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) (fuel : Nat) : + RelTriple + (LazyRevealProbe.runRaw state fuel + ((simulateQ ordinaryHashImpl computation).run cache)) + ((simulateQ (randomOracle : QueryImpl HashSpec _) computation).run + (ordinaryQueryCache cache)) + (RawOrdinaryResultRelAt (alpha := alpha) state fuel) := by + have hbase := relTriple_runRaw_simulateQ_ordinaryHashImpl computation state cache fuel + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => match result with + | .stopped _ => True + | .done finalState remaining _ => finalState = state ∧ remaining = fuel) + (by + intro result hresult + cases result with + | stopped hit => trivial + | done finalState remaining valueCache => + rcases valueCache with ⟨value, finalCache⟩ + have hprojection := mem_runRaw_simulateQ_ordinaryHashImpl_projects computation state + finalState cache finalCache fuel remaining value hresult + exact ⟨hprojection.1, hprojection.2.1⟩) + apply relTriple_post_mono hsupported + intro rawResult ordinaryResult hrelation + cases rawResult with + | stopped hit => exact hrelation.1 + | done finalState remaining valueCache => + rcases valueCache with ⟨value, finalCache⟩ + exact ⟨hrelation.2.1, hrelation.2.2, hrelation.1⟩ + +set_option maxRecDepth 10000 in +theorem relTriple_runRaw_simulateQ_ordinaryRomImpl + [Inhabited alpha] + (computation : OracleComp OracleWorld alpha) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) (fuel : Nat) : + RelTriple + (LazyRevealProbe.runRaw state fuel + ((simulateQ ordinaryRomImpl computation).run cache)) + ((simulateQ romImpl computation).run (ordinaryQueryCache cache)) + (RawOrdinaryResultRelAt (alpha := alpha) state fuel) := by + induction computation using OracleComp.inductionOn generalizing state cache fuel with + | pure value => + simp [LazyRevealProbe.runRaw, RawOrdinaryResultRelAt] + | query_bind query next ih => + rw [simulateQ_query_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + simulateQ_query_bind, StateT.run_bind] + have hquery : RelTriple + (LazyRevealProbe.runRaw state fuel ((ordinaryRomImpl query).run cache)) + ((romImpl query).run (ordinaryQueryCache cache)) + (RawOrdinaryResultRelAt state fuel) := by + cases query with + | inl n => + change RelTriple + (LazyRevealProbe.runRaw state fuel ((splitUniformImpl n).run cache)) + ((unifFwdImpl HashSpec n).run (ordinaryQueryCache cache)) + (RawOrdinaryResultRelAt state fuel) + rw [show (unifFwdImpl HashSpec n).run (ordinaryQueryCache cache) = + (fun output => (output, ordinaryQueryCache cache)) <$> + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) by + simpa using unifFwdImpl.simulateQ_run + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) + (ordinaryQueryCache cache)] + simpa [map_eq_bind_pure_comp] using + relTriple_runRaw_splitUniformImpl n state cache fuel + | inr input => + simpa [ordinaryRomImpl, romImpl] using + relTriple_runRaw_simulateQ_ordinaryHashImpl_at + (liftM (HashSpec.query input)) state cache fuel + apply relTriple_bind hquery + intro rawResult ordinaryResult hrelation + cases rawResult with + | stopped hit => simp [RawOrdinaryResultRelAt] at hrelation + | done finalState remaining valueCache => + rcases valueCache with ⟨value, finalCache⟩ + rcases hrelation with ⟨rfl, rfl, rfl⟩ + exact ih value finalState finalCache remaining + +set_option maxRecDepth 10000 in +theorem evalDist_projectRawOrdinary_simulateQ_ordinaryRomImpl + [Inhabited alpha] + (computation : OracleComp OracleWorld alpha) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) (fuel : Nat) : + 𝒟[projectRawOrdinary <$> + LazyRevealProbe.runRaw state fuel + ((simulateQ ordinaryRomImpl computation).run cache)] = + 𝒟[some <$> + (simulateQ romImpl computation).run (ordinaryQueryCache cache)] := by + refine evalDist_map_eq_of_relTriple (relTriple_post_mono + (relTriple_runRaw_simulateQ_ordinaryRomImpl computation state cache fuel) ?_) + intro rawResult ordinaryResult hrelation + cases rawResult with + | stopped hit => simp [RawOrdinaryResultRelAt] at hrelation + | done finalState remaining valueCache => + rcases valueCache with ⟨value, finalCache⟩ + rcases hrelation with ⟨_, _, rfl⟩ + rfl + +set_option maxRecDepth 10000 in +theorem mem_runRaw_simulateQ_ordinaryRomImpl_projects + [Inhabited alpha] + (computation : OracleComp OracleWorld alpha) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : alpha) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ ordinaryRomImpl computation).run cache))) : + finalState = state ∧ remaining = fuel ∧ + (value, ordinaryQueryCache finalCache) ∈ support + ((simulateQ romImpl computation).run (ordinaryQueryCache cache)) := by + obtain ⟨ordinaryResult, hordinary, hrelation⟩ := + exists_right_mem_support_of_relTriple + (relTriple_runRaw_simulateQ_ordinaryRomImpl computation state cache fuel) hresult + exact ⟨hrelation.1, hrelation.2.1, hrelation.2.2 ▸ hordinary⟩ + +def ProbeFree + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ cache, (computation.run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0 + +theorem ProbeFree.pure (value : alpha) : + ProbeFree (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro cache + simp + +theorem ProbeFree.modify (update : SplitHashCache → SplitHashCache) : + ProbeFree (modify update : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit) := by + intro cache + simp + +theorem ProbeFree.get : + ProbeFree (get : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) SplitHashCache) := by + intro cache + simp + +theorem ProbeFree.bind + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : ProbeFree left) (hnext : ∀ value, ProbeFree (next value)) : + ProbeFree (left >>= next) := by + intro cache + rw [StateT.run_bind] + have hbound := OracleComp.isQueryBoundP_bind (n := 0) (m := 0) (hleft cache) + (fun result _ => hnext result.1 result.2) + simpa using hbound + +theorem ProbeFree.map + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + (hcomputation : ProbeFree computation) (transform : alpha → beta) : + ProbeFree (transform <$> computation) := by + rw [map_eq_bind_pure_comp] + exact hcomputation.bind fun value => ProbeFree.pure (transform value) + +theorem splitHashQuery_run_isProbeBound (key : SplitHashKey) + (cache : SplitHashCache) (fuel : Nat) : + ((splitHashQuery key).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) fuel := by + rw [splitHashQuery_run_eq] + cases hlookup : cache key with + | some output => simp + | none => + change (LazyRevealProbe.hashOutputQuery (Coordinate := Coordinate) >>= fun output => + pure (output, Function.update cache key (some output))).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) fuel + exact OracleComp.isQueryBoundP_bind (n := fuel) (m := 0) + (LazyRevealProbe.hashOutputQuery_isProbeBound fuel) (fun _ _ => by simp) + +theorem splitHashQuery_probeFree (key : SplitHashKey) : + ProbeFree (splitHashQuery key) := + fun cache => splitHashQuery_run_isProbeBound key cache 0 + +theorem splitUniformImpl_probeFree (n : unifSpec.Domain) : + ProbeFree (splitUniformImpl n) := by + intro cache + change (((fun output : Fin (n + 1) => (output, cache)) <$> + LazyRevealProbe.uniformQuery (Coordinate := Coordinate) n).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) + rw [OracleComp.isQueryBoundP_map_iff, LazyRevealProbe.uniformQuery, + OracleComp.isQueryBoundP_query_iff] + simp [LazyRevealProbe.IsProbe] + +theorem peekCoordinate_probeFree (coordinate : Coordinate) : + ProbeFree (peekCoordinate coordinate) := by + intro cache + unfold peekCoordinate + rw [StateT.run_bind] + exact OracleComp.isQueryBoundP_bind (n := 0) (m := 0) + (by + change (LazyRevealProbe.peekQuery coordinate).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0 + exact LazyRevealProbe.peekQuery_isProbeBound coordinate 0) + (fun _ _ => by simp) + +theorem peekPositionValues_probeFree : ∀ positions, + ProbeFree (peekPositionValues positions) + | [] => ProbeFree.pure (some []) + | position :: remaining => by + rw [peekPositionValues] + exact (peekCoordinate_probeFree (.position position)).bind fun value => by + cases value with + | none => exact ProbeFree.pure none + | some value => + exact (peekPositionValues_probeFree remaining).bind fun values => by + cases values with + | none => exact ProbeFree.pure none + | some values => exact ProbeFree.pure (some (value :: values)) + +theorem peekTableInput_probeFree (parameter : PublicParameter) : ∀ coordinate, + ProbeFree (peekTableInput parameter coordinate) + | .chainStart _ _ _ _ => ProbeFree.pure none + | .position position => by + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput] + split + · exact (peekCoordinate_probeFree (.chainStart lay tree leafIdx chainIdx)).bind + fun value => by + cases value with + | none => exact ProbeFree.pure none + | some value => exact ProbeFree.pure _ + · exact (peekPositionValues_probeFree + (Position.chain lay tree leafIdx chainIdx step).children).bind fun values => by + cases values with + | none => exact ProbeFree.pure none + | some values => exact ProbeFree.pure _ + | leaf lay tree leafIdx => + rw [peekTableInput] + exact (peekPositionValues_probeFree + (Position.leaf lay tree leafIdx).children).bind fun values => by + cases values with + | none => exact ProbeFree.pure none + | some values => exact ProbeFree.pure _ + all_goals simp + | node lay tree level nodeIdx => + rw [peekTableInput] + exact (peekPositionValues_probeFree + (Position.node lay tree level nodeIdx).children).bind fun values => by + cases values with + | none => exact ProbeFree.pure none + | some values => exact ProbeFree.pure _ + all_goals simp + | ftsLeaf index tree leafIdx => + rw [peekTableInput] + exact (peekPositionValues_probeFree + (Position.ftsLeaf index tree leafIdx).children).bind fun values => by + cases values with + | none => exact ProbeFree.pure none + | some values => exact ProbeFree.pure _ + all_goals simp + | ftsNode index tree level nodeIdx => + rw [peekTableInput] + exact (peekPositionValues_probeFree + (Position.ftsNode index tree level nodeIdx).children).bind fun values => by + cases values with + | none => exact ProbeFree.pure none + | some values => exact ProbeFree.pure _ + all_goals simp + | ftsRoots index => + rw [peekTableInput] + exact (peekPositionValues_probeFree + (Position.ftsRoots index).children).bind fun values => by + cases values with + | none => exact ProbeFree.pure none + | some values => exact ProbeFree.pure _ + all_goals simp + +theorem revealCoordinateOutput_probeFree (coordinate : Coordinate) : + ProbeFree (revealCoordinateOutput coordinate) := by + intro cache + change (LazyRevealProbe.revealQuery coordinate >>= fun output => + pure (output, Function.update cache (.hidden coordinate) (some output))).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0 + exact OracleComp.isQueryBoundP_bind (n := 0) (m := 0) + (LazyRevealProbe.revealQuery_isProbeBound coordinate 0) (fun _ _ => by simp) + +theorem publishCoordinate_probeFree (coordinate : Coordinate) : + ProbeFree (publishCoordinate coordinate) := by + intro cache + unfold publishCoordinate + change (((fun value : Unit => (value, cache)) <$> + LazyRevealProbe.publishQuery coordinate).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) + rw [OracleComp.isQueryBoundP_map_iff] + exact LazyRevealProbe.publishQuery_isProbeBound coordinate 0 + +theorem resolveKnownInput_probeFree (parameter : PublicParameter) + (coordinate : Coordinate) (input : HashInput) : + ProbeFree (resolveKnownInput parameter coordinate input) := by + unfold resolveKnownInput + exact (peekTableInput_probeFree parameter coordinate).bind fun knownInput => by + cases knownInput with + | none => exact splitHashQuery_probeFree (.ordinary input) + | some knownInput => + change ProbeFree (if knownInput = input then do + let output ← revealCoordinateOutput coordinate + publishCoordinate coordinate + modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output) + pure output + else splitHashQuery (.ordinary input)) + by_cases hknown : knownInput = input + · rw [if_pos hknown] + exact (revealCoordinateOutput_probeFree coordinate).bind fun output => + (publishCoordinate_probeFree coordinate).bind fun _ => by + exact (ProbeFree.modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output)).bind fun _ => + ProbeFree.pure output + · rw [if_neg hknown] + exact splitHashQuery_probeFree (.ordinary input) + +theorem probe_run_isProbeBound (candidate : Probe) (cache : SplitHashCache) : + ((probe candidate).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 := by + unfold probe + change (((fun value : Unit => (value, cache)) <$> + LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1) + rw [OracleComp.isQueryBoundP_map_iff] + exact LazyRevealProbe.probeQuery_isProbeBound candidate.coordinate candidate.candidate + +theorem probeFirstMissingInputCoordinate_run_isProbeBound + (input : HashInput) (slot : Nat) (coordinates : List Coordinate) + (cache : SplitHashCache) : + ((probeFirstMissingInputCoordinate input slot coordinates).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 := by + induction coordinates generalizing slot cache with + | nil => simp [probeFirstMissingInputCoordinate] + | cons coordinate remaining ih => + rw [probeFirstMissingInputCoordinate, StateT.run_bind] + apply OracleComp.isQueryBoundP_bind (n := 0) (m := 1) + · exact peekCoordinate_probeFree coordinate cache + · intro result _ + cases result.1 with + | none => exact probe_run_isProbeBound ⟨coordinate, slotDigest slot input⟩ result.2 + | some value => exact ih (slot + 1) result.2 + +theorem prepareLeafInputProbe_run_isProbeBound + (input : HashInput) (candidate : Probe) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (cache : SplitHashCache) : + ((prepareLeafInputProbe input candidate lay tree leafIdx).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 := by + unfold prepareLeafInputProbe + rw [StateT.run_bind] + apply OracleComp.isQueryBoundP_bind (n := 0) (m := 1) + · exact peekCoordinate_probeFree candidate.coordinate cache + · intro result _ + cases result.1 with + | none => exact probe_run_isProbeBound candidate result.2 + | some value => + exact probeFirstMissingInputCoordinate_run_isProbeBound input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) result.2 + +theorem probingHashQuery_run_isProbeBound (parameter : PublicParameter) + (input : HashInput) (cache : SplitHashCache) : + ((probingHashQuery parameter input).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 := by + unfold probingHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases hposition : decodePosition? parameter input with + | none => + apply OracleComp.isQueryBoundP_bind (n := 1) (m := 0) + · exact probe_run_isProbeBound candidate cache + · intro result _ + exact resolveKnownInput_probeFree parameter candidate.outputCoordinate input result.2 + | some position => + cases position with + | leaf lay tree leafIdx => + apply OracleComp.isQueryBoundP_bind (n := 1) (m := 0) + · exact prepareLeafInputProbe_run_isProbeBound input candidate lay tree leafIdx cache + · intro result _ + exact resolveKnownInput_probeFree parameter candidate.outputCoordinate input result.2 + | chain | node | ftsLeaf | ftsNode | ftsRoots => + apply OracleComp.isQueryBoundP_bind (n := 1) (m := 0) + · exact probe_run_isProbeBound candidate cache + · intro result _ + exact resolveKnownInput_probeFree parameter candidate.outputCoordinate input result.2 + | none => + cases hposition : decodePosition? parameter input with + | none => exact splitHashQuery_run_isProbeBound (.ordinary input) cache 1 + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + change ((resolveKnownInput parameter + (.position (.chain lay tree leafIdx chainIdx step)) input).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 + exact (resolveKnownInput_probeFree parameter + (.position (.chain lay tree leafIdx chainIdx step)) input cache).mono (by omega) + | leaf lay tree leafIdx => + change ((resolveKnownInput parameter + (.position (.leaf lay tree leafIdx)) input).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 + exact (resolveKnownInput_probeFree parameter + (.position (.leaf lay tree leafIdx)) input cache).mono (by omega) + | node lay tree level nodeIdx => + change ((do + probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position) + resolveKnownInput parameter (.position (.node lay tree level nodeIdx)) input).run + cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 + apply OracleComp.isQueryBoundP_bind (n := 1) (m := 0) + · exact probeFirstMissingInputCoordinate_run_isProbeBound input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position) cache + · intro result _ + exact resolveKnownInput_probeFree parameter + (.position (.node lay tree level nodeIdx)) input result.2 + | ftsLeaf | ftsNode | ftsRoots => + exact splitHashQuery_run_isProbeBound (.ordinary input) cache 1 + +theorem simulateQ_probingHashImpl_run_isProbeBound (parameter : PublicParameter) + (computation : OracleComp HashSpec alpha) (q : Nat) + (hbound : computation.IsQueryBoundP (fun _ => True) q) + (cache : SplitHashCache) : + ((simulateQ (probingHashImpl parameter) computation).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) q := by + apply hbound.simulateQ_run_StateT_of_step + (q := LazyRevealProbe.IsProbe (Coordinate := Coordinate)) + intro input workingCache + exact probingHashQuery_run_isProbeBound parameter input workingCache + +theorem revealCoordinate_probeFree (coordinate : Coordinate) : + ProbeFree (revealCoordinate coordinate) := by + unfold revealCoordinate + exact (revealCoordinateOutput_probeFree coordinate).bind fun output => + ProbeFree.pure (truncateHash output) + +theorem revealPosition_probeFree (position : Position) : + ProbeFree (revealPosition position) := + revealCoordinate_probeFree (.position position) + +theorem revealPositionValues_probeFree : ∀ positions, + ProbeFree (revealPositionValues positions) + | [] => ProbeFree.pure [] + | position :: remaining => by + rw [revealPositionValues] + exact (revealPosition_probeFree position).bind fun value => + (revealPositionValues_probeFree remaining).bind fun values => + ProbeFree.pure (value :: values) + +theorem revealTableInputChildren_probeFree : ∀ coordinate, + ProbeFree (revealTableInputChildren coordinate) + | .chainStart _ _ _ _ => ProbeFree.pure () + | .position position => by + cases position with + | chain lay tree leafIdx chainIdx step => + rw [revealTableInputChildren] + split + · exact (revealCoordinate_probeFree + (.chainStart lay tree leafIdx chainIdx)).bind fun _ => + ProbeFree.pure () + · exact (revealPositionValues_probeFree + (Position.chain lay tree leafIdx chainIdx step).children).bind fun _ => + ProbeFree.pure () + | leaf lay tree leafIdx => + rw [revealTableInputChildren] + exact (revealPositionValues_probeFree + (Position.leaf lay tree leafIdx).children).bind fun _ => ProbeFree.pure () + all_goals simp + | node lay tree level nodeIdx => + rw [revealTableInputChildren] + exact (revealPositionValues_probeFree + (Position.node lay tree level nodeIdx).children).bind fun _ => ProbeFree.pure () + all_goals simp + | ftsLeaf index tree leafIdx => + rw [revealTableInputChildren] + exact (revealPositionValues_probeFree + (Position.ftsLeaf index tree leafIdx).children).bind fun _ => ProbeFree.pure () + all_goals simp + | ftsNode index tree level nodeIdx => + rw [revealTableInputChildren] + exact (revealPositionValues_probeFree + (Position.ftsNode index tree level nodeIdx).children).bind fun _ => ProbeFree.pure () + all_goals simp + | ftsRoots index => + rw [revealTableInputChildren] + exact (revealPositionValues_probeFree + (Position.ftsRoots index).children).bind fun _ => ProbeFree.pure () + all_goals simp + +theorem resolveVerifierInput_probeFree (parameter : PublicParameter) + (coordinate : Coordinate) (input : HashInput) : + ProbeFree (resolveVerifierInput parameter coordinate input) := by + unfold resolveVerifierInput + exact ProbeFree.get.bind fun cache => by + cases hcached : cache (.ordinary input) with + | some output => exact ProbeFree.pure output + | none => + exact (revealTableInputChildren_probeFree coordinate).bind fun _ => + resolveKnownInput_probeFree parameter coordinate input + +theorem verifierHashQuery_run_isProbeBound (parameter : PublicParameter) + (input : HashInput) (cache : SplitHashCache) : + ((verifierHashQuery parameter input).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 := by + unfold verifierHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + apply OracleComp.isQueryBoundP_bind (n := 1) (m := 0) + · exact probe_run_isProbeBound candidate cache + · intro result _ + exact resolveVerifierInput_probeFree parameter candidate.outputCoordinate input result.2 + | none => + cases hposition : decodePosition? parameter input with + | none => exact splitHashQuery_run_isProbeBound (.ordinary input) cache 1 + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + change ((resolveVerifierInput parameter + (.position (.chain lay tree leafIdx chainIdx step)) input).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 + exact (resolveVerifierInput_probeFree parameter + (.position (.chain lay tree leafIdx chainIdx step)) input cache).mono (by omega) + | leaf lay tree leafIdx => + change ((resolveVerifierInput parameter + (.position (.leaf lay tree leafIdx)) input).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 + exact (resolveVerifierInput_probeFree parameter + (.position (.leaf lay tree leafIdx)) input cache).mono (by omega) + | node lay tree level nodeIdx => + change ((resolveVerifierInput parameter + (.position (.node lay tree level nodeIdx)) input).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 + exact (resolveVerifierInput_probeFree parameter + (.position (.node lay tree level nodeIdx)) input cache).mono (by omega) + | ftsLeaf | ftsNode | ftsRoots => + exact splitHashQuery_run_isProbeBound (.ordinary input) cache 1 + +theorem simulateQ_verifierHashImpl_run_isProbeBound (parameter : PublicParameter) + (computation : OracleComp HashSpec alpha) (q : Nat) + (hbound : computation.IsQueryBoundP (fun _ => True) q) + (cache : SplitHashCache) : + ((simulateQ (verifierHashImpl parameter) computation).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) q := by + apply hbound.simulateQ_run_StateT_of_step + (q := LazyRevealProbe.IsProbe (Coordinate := Coordinate)) + intro input workingCache + exact verifierHashQuery_run_isProbeBound parameter input workingCache + +theorem simulateQ_ordinaryHashImpl_probeFree + (computation : OracleComp HashSpec alpha) : + ProbeFree (simulateQ ordinaryHashImpl computation) := by + intro cache + apply (OracleComp.isQueryBoundP_false computation 0).simulateQ_run_StateT_of_step + intro input workingCache + exact splitHashQuery_run_isProbeBound (.ordinary input) workingCache 0 + +theorem simulateQ_ordinaryRomImpl_probeFree + (computation : OracleComp OracleWorld alpha) : + ProbeFree (simulateQ ordinaryRomImpl computation) := by + intro cache + apply (OracleComp.isQueryBoundP_false computation 0).simulateQ_run_StateT_of_step + intro input workingCache + cases input with + | inl n => exact splitUniformImpl_probeFree n workingCache + | inr hashInput => exact splitHashQuery_run_isProbeBound (.ordinary hashInput) workingCache 0 + +theorem ensureCoordinate_probeFree (coordinate : Coordinate) : + ProbeFree (ensureCoordinate coordinate) := by + intro cache + unfold ensureCoordinate + change (((fun value : Unit => (value, cache)) <$> + LazyRevealProbe.ensureQuery coordinate).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) + rw [OracleComp.isQueryBoundP_map_iff] + exact LazyRevealProbe.ensureQuery_isProbeBound coordinate 0 + +theorem sequenceFin_probeFree {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hcomputation : ∀ index, ProbeFree (computation index)) : + ProbeFree (sequenceFin computation) := by + induction n with + | zero => + simp only [sequenceFin] + exact ProbeFree.pure Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomputation 0).bind fun head => + (ih (fun index => computation index.succ) + (fun index => hcomputation index.succ)).bind fun tail => + ProbeFree.pure (Fin.cases head tail : Fin (n + 1) → alpha) + +theorem ensureFullChain_probeFree (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ProbeFree (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (sequenceFin_probeFree _ fun step => + ensureCoordinate_probeFree (.position (.chain lay tree leafIdx chainIdx step))).bind + fun _ => ProbeFree.pure () + +theorem ensureChainPrefix_probeFree (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + ProbeFree (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (sequenceFin_probeFree _ fun step => by + split + · exact ensureCoordinate_probeFree (.position (.chain lay tree leafIdx chainIdx step)) + · exact ProbeFree.pure ()).bind fun _ => ProbeFree.pure () + +theorem ensureOtsLeaf_probeFree (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ProbeFree (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (sequenceFin_probeFree _ fun chainIdx => + ensureFullChain_probeFree lay tree leafIdx chainIdx).bind fun _ => + ensureCoordinate_probeFree (.position (.leaf lay tree leafIdx)) + +theorem ensureTreeNode_probeFree (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, ProbeFree (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => ensureOtsLeaf_probeFree lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (ensureTreeNode_probeFree lay tree level (2 * nodeIdx)).bind fun _ => + (ensureTreeNode_probeFree lay tree level (2 * nodeIdx + 1)).bind fun _ => by + split + · exact ensureCoordinate_probeFree (.position + (.node lay tree ⟨level, by assumption⟩ (leafOfNat nodeIdx))) + · exact ProbeFree.pure () + +theorem maskedTreeNode_probeFree (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) : ProbeFree (maskedTreeNode lay tree level nodeIdx) := by + cases level with + | zero => + rw [maskedTreeNode] + exact (ensureTreeNode_probeFree lay tree 0 nodeIdx).bind fun _ => + revealPosition_probeFree (.leaf lay tree (leafOfNat nodeIdx)) + | succ current => + rw [maskedTreeNode] + exact (ensureTreeNode_probeFree lay tree (current + 1) nodeIdx).bind fun _ => by + split + · exact revealPosition_probeFree + (.node lay tree ⟨current, by assumption⟩ (leafOfNat nodeIdx)) + · exact ProbeFree.pure 0 + +theorem maskedTreeRoot_probeFree (lay : Layer) (tree : TreeIndex) : + ProbeFree (maskedTreeRoot lay tree) := + maskedTreeNode_probeFree lay tree (layerHeight lay) 0 + +theorem maskedTreePath_probeFree (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ProbeFree (maskedTreePath lay tree leafIdx) := by + unfold maskedTreePath + apply sequenceFin_probeFree + intro level + split + · exact maskedTreeNode_probeFree lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · exact ProbeFree.pure 0 + +theorem ensureTreePath_probeFree (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ProbeFree (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (sequenceFin_probeFree _ fun level => by + split + · exact ensureTreeNode_probeFree lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · exact ProbeFree.pure ()).bind fun _ => ProbeFree.pure () + +theorem maskedChainValue_probeFree (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + ProbeFree (maskedChainValue lay tree leafIdx chainIdx digit) := by + unfold maskedChainValue + exact (ensureChainPrefix_probeFree lay tree leafIdx chainIdx digit).bind fun _ => by + split + · exact revealCoordinate_probeFree (.chainStart lay tree leafIdx chainIdx) + · exact revealPosition_probeFree (.chain lay tree leafIdx chainIdx ⟨digit.val - 1, by + have := digit.isLt + omega⟩) + +theorem maskedOtsSignFrom_probeFree (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter, + ProbeFree (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, _ => ProbeFree.pure none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + exact (simulateQ_ordinaryHashImpl_probeFree + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter))).bind fun encoded => by + cases encoded with + | none => + exact maskedOtsSignFrom_probeFree parameter lay tree leafIdx message attempts + (counter + 1) + | some encoding => + exact (sequenceFin_probeFree _ fun chainIdx => + ensureChainPrefix_probeFree lay tree leafIdx chainIdx + (encoding chainIdx)).bind fun _ => ProbeFree.pure _ + +theorem maskedOtsSign_probeFree (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ProbeFree (maskedOtsSign parameter lay tree leafIdx message) := + maskedOtsSignFrom_probeFree parameter lay tree leafIdx message encodingAttemptLimit 0 + +theorem maskedLayerMessage_probeFree (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + ProbeFree (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + split + · exact maskedTreeRoot_probeFree _ _ + · exact simulateQ_ordinaryHashImpl_probeFree _ + +theorem maskedSignLayer_probeFree (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + ProbeFree (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + exact (maskedLayerMessage_probeFree parameter ftsSecret index lay).bind fun message => + (maskedOtsSign_probeFree parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message).bind fun signed => by + cases signed with + | none => exact ProbeFree.pure none + | some part => + exact (ensureTreePath_probeFree lay (treeIndexAt index lay) + (leafIndexAt index lay)).bind fun _ => ProbeFree.pure (some part) + +theorem revealPublishedCoordinate_probeFree (coordinate : Coordinate) : + ProbeFree (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + exact (revealCoordinate_probeFree coordinate).bind fun value => + (publishCoordinate_probeFree coordinate).bind fun _ => ProbeFree.pure value + +theorem revealLayerPathValue_probeFree (index : Index) (lay : Layer) + (level : Fin maxLayerHeight) : + ProbeFree (if level.val < layerHeight lay then + match level.val with + | 0 => revealPublishedCoordinate (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | current + 1 => + if hlevel : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hlevel⟩ + (leafOfNat (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0 + else pure 0) := by + by_cases hbelow : level.val < layerHeight lay + · rw [if_pos hbelow] + cases hvalue : level.val with + | zero => + exact revealPublishedCoordinate_probeFree (.position (.leaf lay + (treeIndexAt index lay) (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | succ current => + simp only + split + · exact revealPublishedCoordinate_probeFree (.position (.node lay + (treeIndexAt index lay) ⟨current, by assumption⟩ + (leafOfNat (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + · exact ProbeFree.pure 0 + · rw [if_neg hbelow] + exact ProbeFree.pure 0 + +theorem revealLayerValues_probeFree (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + ProbeFree (revealLayerValues index lay encoding) := by + unfold revealLayerValues + exact (sequenceFin_probeFree _ fun chainIdx => + revealPublishedCoordinate_probeFree + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx))).bind fun values => + (sequenceFin_probeFree _ fun level => + revealLayerPathValue_probeFree index lay level).bind fun path => + ProbeFree.pure (values, path) + +theorem maskedSignAfterDigest_probeFree (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + ProbeFree (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest + exact (simulateQ_ordinaryHashImpl_probeFree + (ftsOpen parameter index leaves (ftsSecret index))).bind fun ftsPath => + (sequenceFin_probeFree _ fun lay => + maskedSignLayer_probeFree parameter ftsSecret index lay).bind fun layers => by + cases hparts : traverseOption layers with + | none => exact ProbeFree.pure none + | some parts => + exact (sequenceFin_probeFree _ fun lay => + revealLayerValues_probeFree index lay (parts lay).2).bind fun revealed => + ProbeFree.pure (some + (show Signature from + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (revealed lay).1 + authPath := flattenPaths fun lay => (revealed lay).2 })) + +theorem maskedSign_probeFree (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + ProbeFree (maskedSign parameter root ftsSecret message) := by + unfold maskedSign + exact (simulateQ_ordinaryRomImpl_probeFree + (signDigestLoop digestAttemptLimit + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ message)).bind fun selected => by + cases selected with + | none => exact ProbeFree.pure none + | some data => + exact maskedSignAfterDigest_probeFree parameter ftsSecret data.1 data.2.1 data.2.2 + +theorem maskedSigningImpl_probeFree (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + ProbeFree (maskedSigningImpl parameter root ftsSecret message) := + maskedSign_probeFree parameter root ftsSecret message + +def IsOuterHash : (OracleWorld + SigningSpec).Domain → Prop + | .inl (.inr _) => True + | _ => False + +instance : DecidablePred IsOuterHash + | .inl (.inl _) => isFalse id + | .inl (.inr _) => isTrue trivial + | .inr _ => isFalse id + +theorem maskedExpandedAdversaryImpl_step_isProbeBound + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (cache : SplitHashCache) : + ((maskedExpandedAdversaryImpl parameter root ftsSecret input).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) + (if IsOuterHash input then 1 else 0) := by + cases input with + | inl worldInput => + cases worldInput with + | inl n => + simpa [maskedExpandedAdversaryImpl, probingRomImpl, IsOuterHash] using + splitUniformImpl_probeFree n cache + | inr hashInput => + simpa [maskedExpandedAdversaryImpl, probingRomImpl, probingHashImpl, + IsOuterHash] using probingHashQuery_run_isProbeBound parameter hashInput cache + | inr message => + simpa [maskedExpandedAdversaryImpl, maskedSigningImpl, IsOuterHash] using + maskedSign_probeFree parameter root ftsSecret message cache + +theorem simulateQ_maskedExpandedAdversaryImpl_run_isProbeBound + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) (q : Nat) + (hbound : computation.IsQueryBoundP IsOuterHash q) + (cache : SplitHashCache) : + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + computation).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) q := by + apply hbound.simulateQ_run_StateT_of_step + (q := LazyRevealProbe.IsProbe (Coordinate := Coordinate)) + exact maskedExpandedAdversaryImpl_step_isProbeBound parameter root ftsSecret + +noncomputable def maskedVerifierExpandedImpl (parameter : PublicParameter) + (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + QueryImpl (OracleWorld + SigningSpec) + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate))) := + verifierRomImpl parameter + maskedSigningImpl parameter root ftsSecret + +theorem maskedVerifierExpandedImpl_step_isProbeBound + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (cache : SplitHashCache) : + ((maskedVerifierExpandedImpl parameter root ftsSecret input).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) + (if IsOuterHash input then 1 else 0) := by + cases input with + | inl worldInput => + cases worldInput with + | inl n => + simpa [maskedVerifierExpandedImpl, verifierRomImpl, IsOuterHash] using + splitUniformImpl_probeFree n cache + | inr hashInput => + simpa [maskedVerifierExpandedImpl, verifierRomImpl, verifierHashImpl, + IsOuterHash] using verifierHashQuery_run_isProbeBound parameter hashInput cache + | inr message => + simpa [maskedVerifierExpandedImpl, maskedSigningImpl, IsOuterHash] using + maskedSign_probeFree parameter root ftsSecret message cache + +theorem isQueryBoundP_simulateQ_run_StateT_then_of_steps + {ι ι' : Type} {spec : OracleSpec ι} {spec' : OracleSpec ι'} + {stateType : Type} {sourcePredicate : ι → Prop} [DecidablePred sourcePredicate] + {targetPredicate : ι' → Prop} [DecidablePred targetPredicate] + {leftImpl rightImpl : QueryImpl spec (StateT stateType (OracleComp spec'))} + {left : OracleComp spec alpha} {next : alpha → OracleComp spec beta} {q : Nat} + (hbound : (left >>= next).IsQueryBoundP sourcePredicate q) + (hleftStep : ∀ input state, + ((leftImpl input).run state).IsQueryBoundP targetPredicate + (if sourcePredicate input then 1 else 0)) + (hrightStep : ∀ input state, + ((rightImpl input).run state).IsQueryBoundP targetPredicate + (if sourcePredicate input then 1 else 0)) + (initialState : stateType) : + ((simulateQ leftImpl left).run initialState >>= fun result => + (simulateQ rightImpl (next result.1)).run result.2).IsQueryBoundP + targetPredicate q := by + induction left using OracleComp.inductionOn generalizing q initialState with + | pure value => + simp only [pure_bind] at hbound + simpa [simulateQ_pure] using + hbound.simulateQ_run_StateT_of_step hrightStep initialState + | query_bind input continuation ih => + rw [bind_assoc, OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [simulateQ_query_bind, StateT.run_bind, bind_assoc] + have hrest : ∀ result ∈ support ((leftImpl input).run initialState), + (((simulateQ leftImpl (continuation result.1)).run result.2) >>= fun nextResult => + (simulateQ rightImpl (next nextResult.1)).run nextResult.2).IsQueryBoundP + targetPredicate + (if sourcePredicate input then q - 1 else q) := by + intro result _ + exact ih result.1 (hbound.2 result.1) result.2 + have hcombined := OracleComp.isQueryBoundP_bind + (hleftStep input initialState) hrest + refine hcombined.mono ?_ + grind + +theorem maskedRetainedGameRest_run_isProbeBound + (adversary : Adversary) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash q) (cache : SplitHashCache) : + ((do + let (forgery, log) ← + simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) + let verified ← simulateQ (verifierRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature) + pure ((forgery, log), verified)).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) q := by + let adversaryPrefix := signingTraceComputation + (adversary.main (⟨root, parameter⟩ : PublicKey)) + let finish : (Forgery × QueryLog SigningSpec) → + OracleComp (OracleWorld + SigningSpec) RetainedRestResult := fun result => do + let verified ← liftOracleWorldLeft + (scheme.verify ⟨root, parameter⟩ result.1.message result.1.signature) + pure (result, verified) + have hsource : (adversaryPrefix >>= finish).IsQueryBoundP IsOuterHash q := by + simpa [adversaryPrefix, finish, retainedGameRestComputation] using hbound + have hmixed := isQueryBoundP_simulateQ_run_StateT_then_of_steps + (leftImpl := maskedExpandedAdversaryImpl parameter root ftsSecret) + (rightImpl := maskedVerifierExpandedImpl parameter root ftsSecret) + hsource + (maskedExpandedAdversaryImpl_step_isProbeBound parameter root ftsSecret) + (maskedVerifierExpandedImpl_step_isProbeBound parameter root ftsSecret) cache + simpa [adversaryPrefix, finish, maskedVerifierExpandedImpl, simulateQ_bind, + simulateQ_liftOracleWorldLeft, StateT.run_bind] using hmixed + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeCouplingObservation.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCouplingObservation.lean new file mode 100644 index 00000000..97d7cb7b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeCouplingObservation.lean @@ -0,0 +1,54 @@ +import SphincsSecurity.Proof.OtsProbeJointSnapshotErasure +import VCVio.ProgramLogic.Relational.Quantitative + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +/-- A comparison of an observation can retain the complete sampled output. -/ +theorem relTriple_lift_left_observation + {left : ProbComp α} {right : ProbComp β} (observe : α → β) + {relation : β → β → Prop} + (h : RelTriple (observe <$> left) right relation) : + RelTriple left right (fun a b => relation (observe a) b) := by + classical + obtain ⟨coupling, hcoupling⟩ := relTriple_iff_relWP.1 h + refine relTriple_iff_relWP.2 + ⟨⟨liftLeftMapCoupling observe coupling, + liftLeftMapCoupling_isCoupling observe coupling⟩, ?_⟩ + intro pair hpair + change pair ∈ support (liftLeftMapCoupling observe coupling) at hpair + unfold liftLeftMapCoupling at hpair + rw [mem_support_bind_iff] at hpair + obtain ⟨observed, hobserved, hpair⟩ := hpair + rw [support_map] at hpair + obtain ⟨value, hvalue, hpair⟩ := hpair + subst pair + have hsupport : observed.1 ∈ support (evalDist (observe <$> left)) := by + rw [← coupling.2.map_fst, support_map] + exact ⟨observed, hobserved, rfl⟩ + let distribution := MonadHom.ofLift _ PMF left + rw [evalDist_map, support_map] at hsupport + obtain ⟨original, horiginal, hmap⟩ := hsupport + change original ∈ (liftM distribution : SPMF α).support at horiginal + rw [SPMF.support_liftM] at horiginal + have hex : ∃ a ∈ {a | observe a = observed.1}, a ∈ distribution.support := + ⟨original, hmap, horiginal⟩ + have hvalue' : value ∈ (PMF.condOnMap distribution observe observed.1).support := by + change value ∈ (liftM (PMF.condOnMap distribution observe observed.1) : SPMF α).support at hvalue + rwa [SPMF.support_liftM] at hvalue + have hmatch : observe value = observed.1 := by + by_contra hne + have hzero := PMF.condOnMap_apply_of_not_mem_fiber distribution observe observed.1 hne hex + exact ((PMF.mem_support_iff _ _).1 hvalue') hzero + simpa [hmatch] using hcoupling observed hobserved + +theorem relTriple_lift_right_observation + {left : ProbComp β} {right : ProbComp α} (observe : α → β) + {relation : β → β → Prop} + (h : RelTriple left (observe <$> right) relation) : + RelTriple left right (fun a b => relation a (observe b)) := + relTriple_symm (relTriple_lift_left_observation observe (relTriple_symm h)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeDelayedRoot125.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeDelayedRoot125.lean new file mode 100644 index 00000000..15e9aa8f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeDelayedRoot125.lean @@ -0,0 +1,228 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootClosed + +namespace SphincsSecurity.Concrete.OtsProbeSimulation.Range125 + +open OracleComp OracleSpec ENNReal + +set_option linter.constructorNameAsVariable false + +attribute [local irreducible] WitnessFirstUsesDelayedLayerRootSnapshotOrdinal + delayedSnapshotLayerRootPosition? DelayedRootGoodForComparisonAt + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? + +theorem ordinal_mul_inv_digest_le_inv_eight + (ordinal q : Nat) (hordinal : ordinal < q) (hq : q ≤ 2 ^ 125) : + (ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ ≤ + (8 : ENNReal)⁻¹ := by + calc + (ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ ≤ + ((2 ^ 125 : Nat) : ENNReal) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + gcongr + exact_mod_cast (Nat.le_of_lt (hordinal.trans_le hq)) + _ ≤ (8 : ENNReal)⁻¹ := by + rw [ENNReal.mul_inv_le_iff (by norm_num) (by norm_num)] + apply (ENNReal.toReal_le_toReal (by norm_num) (by finiteness)).mp + rw [ENNReal.toReal_mul, ENNReal.toReal_inv] + norm_num [digestBits] + +theorem le_eight_sevenths_mul_of_le_add_mul_inv_eight + (probability epsilon : ℝ≥0∞) + (hprobability : probability ≤ 1) (hepsilon : epsilon ≠ ∞) + (hbound : probability ≤ epsilon + probability * (8 : ℝ≥0∞)⁻¹) : + probability ≤ (8 / 7) * epsilon := by + have hprobabilityFinite : probability ≠ ∞ := by + exact ne_top_of_le_ne_top (by norm_num) hprobability + have hfractionFinite : probability * (8 : ℝ≥0∞)⁻¹ ≠ ∞ := by finiteness + have hsumFinite : epsilon + probability * (8 : ℝ≥0∞)⁻¹ ≠ ∞ := by finiteness + have hrightFinite : (8 / 7 : ℝ≥0∞) * epsilon ≠ ∞ := by finiteness + have hreal : probability.toReal ≤ + epsilon.toReal + probability.toReal * (8 : ℝ)⁻¹ := by + have := (ENNReal.toReal_le_toReal hprobabilityFinite hsumFinite).mpr hbound + simpa [ENNReal.toReal_add hepsilon hfractionFinite, ENNReal.toReal_mul, + ENNReal.toReal_inv] using this + apply (ENNReal.toReal_le_toReal hprobabilityFinite hrightFinite).mp + rw [ENNReal.toReal_mul] + norm_num only [ENNReal.toReal_div, ENNReal.toReal_ofNat] + linarith + + +set_option maxRecDepth 100000 in +theorem probEvent_delayedRootFiber_le_eight_sevenths_mul_common + (run : ProbComp PrivateWitnessSnapshotOutput) + (common : ProbComp (Option PermissivePrivateOrdinalSelection)) + (ordinal q : Nat) (target : Position) + (hordinal : ordinal < q) (hq : q ≤ 2 ^ 125) + (hgood : + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + DelayedRootGoodForComparisonAt result.1 ordinal target result.2 | do + let source ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + common] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[fun source => + WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal source ∧ + delayedSnapshotLayerRootPosition? ordinal source = some target | run] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + common] * ((8 / 7) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + let probability := Pr[fun source => + WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal source ∧ + delayedSnapshotLayerRootPosition? ordinal source = some target | run] + let weight := Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + common] + let epsilon := ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + have hsplit : probability ≤ + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + DelayedRootGoodForComparisonAt result.1 ordinal target result.2 | do + let source ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] + + probability * ((ordinal : ENNReal) * epsilon) := by + exact probEvent_delayedRootFiber_le_goodComparison_add_weightedException + run ordinal target + have hfraction : (ordinal : ENNReal) * epsilon ≤ (8 : ENNReal)⁻¹ := by + exact ordinal_mul_inv_digest_le_inv_eight ordinal q hordinal hq + have habsorb : probability ≤ (8 / 7) * (weight * epsilon) := by + apply le_eight_sevenths_mul_of_le_add_mul_inv_eight probability (weight * epsilon) + · exact probEvent_le_one + · apply ne_top_of_le_ne_top (by norm_num : (1 : ENNReal) ≠ ∞) + calc + weight * epsilon ≤ 1 * 1 := by + apply mul_le_mul probEvent_le_one + · simp [epsilon, digestBits] + · exact bot_le + · exact bot_le + _ = 1 := one_mul 1 + · have hweighted : probability * ((ordinal : ENNReal) * epsilon) ≤ + probability * (8 : ENNReal)⁻¹ := mul_le_mul' le_rfl hfraction + exact hsplit.trans (add_le_add hgood hweighted) + change probability ≤ weight * ((8 / 7) * epsilon) + calc + probability ≤ (8 / 7) * (weight * epsilon) := habsorb + _ = weight * ((8 / 7) * epsilon) := by ac_rfl + +theorem probEvent_granularAllCanonical_delayedOrdinal_le_eight_sevenths_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hordinal : ordinal < q) (hq : q ≤ 2 ^ 125) + (hgood : ∀ target, + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + DelayedRootGoodForComparisonAt result.1 ordinal target result.2 | do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret q + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret q table] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q] ≤ + (8 / 7) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_le_of_common_position_fibers + (leftPosition := delayedSnapshotLayerRootPosition? ordinal) + (common := delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret q table) + (commonPosition := permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?) + · intro output hdelayed + obtain ⟨target, htarget⟩ := + delayedSnapshotLayerRootPosition?_eq_some_of_delayed hdelayed + rw [htarget] + simp + · intro target + exact probEvent_delayedRootFiber_le_eight_sevenths_mul_common + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q) + (delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret q table) + ordinal q target hordinal hq (hgood target) + +theorem probEvent_sampledCanonical_delayedOrdinal_le_eight_sevenths_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hordinal : ordinal < q) (hq : q ≤ 2 ^ 125) + (hgood : ∀ table target, + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + DelayedRootGoodForComparisonAt result.1 ordinal target result.2 | do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret q + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret q table] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + (8 / 7) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot + apply probEvent_bind_le_of_forall_le + intro table _htable + exact probEvent_granularAllCanonical_delayedOrdinal_le_eight_sevenths_mul ordinal adversary parameter table + ftsSecret q hordinal hq (hgood table) + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledCanonical_delayed_le_eight_sevenths_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) + (hgood : ∀ (ordinal : Fin q) table target, + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + DelayedRootGoodForComparisonAt result.1 ordinal.val target result.2 | do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret q + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal.val adversary parameter + ftsSecret q table] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[WitnessFirstUsesSomeDelayedLayerRootSnapshot | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + ((8 / 7) * q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ ∑ ordinal : Fin q, + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal.val | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := + probEvent_sampledCanonical_delayed_le_sum_ordinals adversary parameter ftsSecret q hbound + _ ≤ ∑ _ordinal : Fin q, (8 / 7) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + exact Finset.sum_le_sum fun ordinal _ => + probEvent_sampledCanonical_delayedOrdinal_le_eight_sevenths_mul ordinal.val adversary parameter + ftsSecret q ordinal.isLt hq (hgood ordinal) + _ = _ := by + simp + ring + +theorem probEvent_sampledCanonical_delayed_le_eight_sevenths_mul_closed + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[WitnessFirstUsesSomeDelayedLayerRootSnapshot | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + ((8 / 7) * q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_sampledCanonical_delayed_le_eight_sevenths_mul adversary parameter ftsSecret q hbound hq + intro ordinal table target + exact probEvent_delayedGoodComparison_le_common_mul_allTargets ordinal.val adversary parameter + table ftsSecret q target + + +end SphincsSecurity.Concrete.OtsProbeSimulation.Range125 diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeDiagnostic125.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeDiagnostic125.lean new file mode 100644 index 00000000..8d006d35 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeDiagnostic125.lean @@ -0,0 +1,237 @@ +import SphincsSecurity.Proof.OtsProbeDiagnosticClassification125 +import SphincsSecurity.Proof.OtsProbeFinalization125 + +namespace SphincsSecurity.Concrete.OtsProbeSimulation.Range125 + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option linter.constructorNameAsVariable false + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_firstHit_eq_zero_of_q_le_ordinal + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) + (hordinal : q ≤ ordinal) : + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] = 0 := by + apply le_antisymm + · calc + _ ≤ Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenHitAt ordinal | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) + table] := + probEvent_sampledDiagnostic_successfulDoomed_firstExistingHiddenHitAt_le_raw adversary + parameter ftsSecret (2 * q) ordinal + _ ≤ Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := + probEvent_sampledSuccessfulFirstHit_le_selectedSnapshot adversary parameter ftsSecret q + ordinal hexpanded hq + _ = 0 := probEvent_selectedPrivateSnapshotHitAt_eq_zero_of_q_le_ordinal adversary + parameter ftsSecret q ordinal hexpanded hordinal + · exact zero_le + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_firstRoot_eq_zero_of_q_le_ordinal + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) + (hordinal : q ≤ ordinal) : + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] = 0 := by + apply le_antisymm + · calc + _ ≤ Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] := by + apply probEvent_mono + intro outcome _houtcome hevent + exact ⟨hevent.1, outcome.firstExistingHiddenHitAt_of_root hevent.2⟩ + _ = 0 := + probEvent_sampledDiagnostic_successfulDoomed_firstHit_eq_zero_of_q_le_ordinal + adversary parameter ftsSecret q ordinal hexpanded hq hordinal + · exact zero_le + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_firstNonRoot_eq_zero_of_q_le_ordinal + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) + (hordinal : q ≤ ordinal) : + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] = 0 := by + apply le_antisymm + · calc + _ ≤ Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] := by + apply probEvent_mono + intro outcome _houtcome hevent + exact ⟨hevent.1, outcome.firstExistingHiddenHitAt_of_nonRoot hevent.2⟩ + _ = 0 := + probEvent_sampledDiagnostic_successfulDoomed_firstHit_eq_zero_of_q_le_ordinal + adversary parameter ftsSecret q ordinal hexpanded hq hordinal + · exact zero_le + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_le_fifteen_sevenths_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hfuel : 2 * q < Fintype.card Digest) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + ((15 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + classical + let diagnostic := + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q) + let epsilon := ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + calc + _ ≤ ∑ ordinal : Fin (2 * q), + (Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal.val | diagnostic] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal.val | diagnostic]) := + probEvent_sampledDiagnostic_successfulDoomed_le_sum_successfulFirstOrdinals adversary + parameter ftsSecret q (hq.trans (by norm_num)) + _ ≤ ∑ _ordinal : Fin q, (15 / 7) * epsilon := by + simp only [Finset.sum_fin_eq_sum_range] + rw [show 2 * q = q + q by omega, Finset.sum_range_add] + have hfirst : + (∑ ordinal ∈ Finset.range q, if h : ordinal < q + q then + (Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal | diagnostic] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal | diagnostic]) + else 0) ≤ + ∑ _ordinal ∈ Finset.range q, (15 / 7) * epsilon := by + apply Finset.sum_le_sum + intro ordinal hordinalMem + have hordinal : ordinal < q := Finset.mem_range.1 hordinalMem + have hordinal' : ordinal < q + q := hordinal.trans_le (Nat.le_add_right q q) + simp only [hordinal', ↓reduceDIte] + calc + _ ≤ (8 / 7) * epsilon + epsilon := add_le_add + (probEvent_sampledDiagnostic_successfulDoomed_firstRoot_le ordinal adversary + parameter ftsSecret q hordinal hfuel hexpanded hq) + (probEvent_sampledDiagnostic_successfulDoomed_firstNonRoot_le adversary parameter + ftsSecret q ordinal hexpanded (hq.trans (by norm_num))) + _ = (15 / 7) * epsilon := by + rw [← add_one_mul] + have hcoeff : (8 / 7 : ENNReal) + 1 = 15 / 7 := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + norm_num + rw [hcoeff] + have hzero : + (∑ ordinal ∈ Finset.range q, if h : q + ordinal < q + q then + (Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt (q + ordinal) | diagnostic] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt (q + ordinal) | diagnostic]) + else 0) = 0 := by + apply Finset.sum_eq_zero + intro ordinal hordinalMem + have hordinal : ordinal < q := Finset.mem_range.1 hordinalMem + simp only [show q + ordinal < q + q by omega, ↓reduceDIte] + rw [probEvent_sampledDiagnostic_successfulDoomed_firstRoot_eq_zero_of_q_le_ordinal + adversary parameter ftsSecret q (q + ordinal) hexpanded (hq.trans (by norm_num)) (by omega)] + rw [probEvent_sampledDiagnostic_successfulDoomed_firstNonRoot_eq_zero_of_q_le_ordinal + adversary parameter ftsSecret q (q + ordinal) hexpanded (hq.trans (by norm_num)) (by omega)] + simp + calc + _ ≤ (∑ _ordinal ∈ Finset.range q, (15 / 7) * epsilon) + + (∑ ordinal ∈ Finset.range q, if h : q + ordinal < q + q then + (Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt (q + ordinal) | diagnostic] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt (q + ordinal) | diagnostic]) + else 0) := add_le_add hfirst le_rfl + _ = ∑ _ordinal ∈ Finset.range q, (15 / 7) * epsilon := by rw [hzero, add_zero] + _ = ∑ ordinal ∈ Finset.range q, if h : ordinal < q then (15 / 7) * epsilon else 0 := by + apply Finset.sum_congr rfl + intro ordinal hordinalMem + simp [Finset.mem_range.1 hordinalMem] + _ = (q : ENNReal) * ((15 / 7) * epsilon) := by simp + _ = _ := by + simp only [epsilon] + push_cast + ring + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnostic_bad_le_twenty_two_sevenths_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hfuel : 2 * q < Fintype.card Digest) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[ObservedMaterializedDiagnostic.Bad | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + ((22 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let diagnostic := + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q) + calc + _ ≤ Pr[fun outcome => outcome.final = none | diagnostic] + + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | diagnostic] := + probEvent_diagnosticBad_le_finalNone_add_successfulDoomed diagnostic + _ ≤ (q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + ((15 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply add_le_add + · exact probEvent_sampledDiagnostic_final_none_le_queryBound adversary parameter + ftsSecret (2 * q) q hexpanded (by omega) + · exact probEvent_sampledDiagnostic_successfulDoomed_le_fifteen_sevenths_mul adversary parameter + ftsSecret q hfuel hexpanded hq + _ = _ := by + rw [← add_mul, ← one_add_mul] + have hcoeff : (1 : ENNReal) + 15 / 7 = 22 / 7 := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + norm_num + rw [hcoeff] + +end SphincsSecurity.Concrete.OtsProbeSimulation.Range125 diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeDiagnosticCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeDiagnosticCharge.lean new file mode 100644 index 00000000..7fd603ba --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeDiagnosticCharge.lean @@ -0,0 +1,124 @@ +import SphincsSecurity.Proof.OtsProbeMaterializedCharge +import SphincsSecurity.Proof.OtsProbeJointClassification +import SphincsSecurity.Proof.OtsProbeJointSnapshotErasure + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def materializedRetainedCharge (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : ℝ≥0∞ := + ordinaryContinuationCharge + (fun context remaining value => materializedBoundaryCharge parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) context.state remaining value.2) + (maskedPublishedTreeRoot.run emptySplitHashCache) emptyWitnessDeferredContext fuel + +theorem probEvent_sampledMaterializedCleanUnguarded_none_le_charge + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hbudget : q ≤ fuel) : + Pr[= none | sampledMaterializedCleanUnguarded adversary parameter ftsSecret fuel] ≤ + materializedRetainedCharge adversary parameter ftsSecret fuel * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ = Pr[= true | Option.isNone <$> + sampledMaterializedCleanUnguarded adversary parameter ftsSecret fuel] := by + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput, probEvent_map] + exact OracleComp.probEvent_congr' (fun result _ => by cases result <;> simp) rfl + _ = Pr[= true | runDirectDetailedSafeOrdinaryWithCompletionTable + (fun table context remaining value => guardedMaterializedRootContinuation adversary parameter ftsSecret q + table context.state remaining value) + emptyWitnessDeferredContext fuel (maskedPublishedTreeRoot.run emptySplitHashCache)] := + OracleComp.probOutput_congr rfl + (evalDist_sampledMaterializedCleanUnguarded_isNone_eq_safeRoot_of_fuel adversary parameter ftsSecret fuel q hbudget) + _ ≤ _ := by + rw [← probEvent_eq_eq_probOutput] + have hsafe := probEvent_safeOrdinary_le_continuationCharge + (maskedPublishedTreeRoot.run emptySplitHashCache) + (fun table context remaining value => guardedMaterializedRootContinuation adversary parameter ftsSecret q + table context.state remaining value) + (fun context remaining value => materializedBoundaryCharge parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) context.state remaining value.2) + (by + intro context remaining value + rw [probEvent_eq_eq_probOutput] + by_cases hguard : PublishedValues context.state ∧ q ≤ remaining + · simpa [guardedMaterializedRootContinuation, hguard, sampledMaterializedCleanBoundaryFailure] using + (probEvent_sampledMaterializedCleanBoundaryFailure_le_charge parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) context.state remaining q value.2 + (fun table _ => hbound table value.1) hguard.2 hguard.1) + · simp [guardedMaterializedRootContinuation, hguard]) + emptyWitnessDeferredContext fuel + simpa only [materializedRetainedCharge, emptyWitnessDeferredContext, LazyRevealProbe.State.empty, + LazyRevealProbe.State.unmaterializedPending, Finset.filter_empty, Finset.card_empty, Nat.cast_zero, + add_zero] using hsafe + +theorem probEvent_sampledDiagnostic_final_none_le_charge + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hbudget : q ≤ fuel) : + Pr[fun outcome => outcome.final = none | sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel] ≤ + materializedRetainedCharge adversary parameter ftsSecret fuel * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [probEvent_sampledObservedMaterializedDiagnostic_final_none_eq] + exact probEvent_sampledMaterializedCleanUnguarded_none_le_charge adversary parameter ftsSecret fuel q hbound hbudget + +theorem probEvent_sampledDiagnostic_bad_le_charge_add_successfulDoomed + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hbudget : q ≤ fuel) : + Pr[ObservedMaterializedDiagnostic.Bad | sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel] ≤ + materializedRetainedCharge adversary parameter ftsSecret fuel * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel] := + (probEvent_diagnosticBad_le_finalNone_add_successfulDoomed _).trans + (add_le_add (probEvent_sampledDiagnostic_final_none_le_charge adversary parameter ftsSecret fuel q hbound hbudget) le_rfl) + +theorem probEvent_sampledActualRetained_verifyProbe_le_charge_add_hiddenFailures + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + materializedRetainedCharge adversary parameter ftsSecret (2 * q) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] + + Pr[JointSnapshotResidual | sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q] := + (probEvent_sampledActualRetained_verifyProbe_le_jointBoundaryFailed adversary parameter ftsSecret q).trans + ((probEvent_sampledJointSnapshot_failed_le_diagnostic_add_residual adversary parameter ftsSecret q hbound).trans + (add_le_add (probEvent_sampledDiagnostic_bad_le_charge_add_successfulDoomed + adversary parameter ftsSecret (2 * q) q hbound (by omega)) le_rfl)) + +theorem probEvent_sampledActualRetained_verifyProbe_le_charge_add_hiddenFailures_of_hashQueryBound + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + materializedRetainedCharge adversary parameter ftsSecret (2 * q) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] + + Pr[JointSnapshotResidual | sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q] := + probEvent_sampledActualRetained_verifyProbe_le_charge_add_hiddenFailures adversary parameter ftsSecret q + (fun table root => isQueryBoundP_expandedRetained_all_tables_roots adversary q hq parameter hparameter table ftsSecret hfts root) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeDiagnosticClassification125.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeDiagnosticClassification125.lean new file mode 100644 index 00000000..02c7cf1e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeDiagnosticClassification125.lean @@ -0,0 +1,182 @@ +import SphincsSecurity.Proof.OtsProbeStopped125 + +namespace SphincsSecurity.Concrete.OtsProbeSimulation.Range125 + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option linter.constructorNameAsVariable false + +attribute [local irreducible] observedMaterializedRetainedRunFromTable in +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem hasExistingHiddenHit_of_mem_diagnosticFromTable_successfulDoomed + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hq : q ≤ 2 ^ 126) + (outcome : ObservedMaterializedDiagnostic + (RetainedGameResult × SplitHashCache)) + (houtcome : outcome ∈ support + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table >>= + finishObservedMaterializedDiagnostic table)) + (hsuccess : outcome.SuccessfulDoomed) : + outcome.HasExistingHiddenHit := by + classical + rw [mem_support_bind_iff] at houtcome + obtain ⟨before?, hbefore, hfinish⟩ := houtcome + cases before? with + | none => + have houtcomeEq : outcome = ⟨none, none, false⟩ := by + simpa [finishObservedMaterializedDiagnostic] using hfinish + have hfinalNone : outcome.final = none := congrArg + ObservedMaterializedDiagnostic.final houtcomeEq + simp [ObservedMaterializedDiagnostic.SuccessfulDoomed, hfinalNone] at hsuccess + | some before => + unfold finishObservedMaterializedDiagnostic at hfinish + rw [mem_support_bind_iff] at hfinish + obtain ⟨final?, hfinal, hreturn⟩ := hfinish + cases final? with + | none => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hfinalNone : outcome.final = none := by + simpa using congrArg ObservedMaterializedDiagnostic.final hreturn + simp [ObservedMaterializedDiagnostic.SuccessfulDoomed, hfinalNone] at hsuccess + | some finalResult => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hbeforeEq : outcome.before = some before := by + simpa using congrArg ObservedMaterializedDiagnostic.before hreturn + have hdoomedEq : decide + (¬DeferredCompletable table (directDeferredContext before.state)) = true := by + have hfield := congrArg ObservedMaterializedDiagnostic.wasDoomed hreturn + exact hfield.symm.trans hsuccess.2 + have hnotCompletable : + ¬DeferredCompletable table (directDeferredContext before.state) := by + simpa using of_decide_eq_true hdoomedEq + have htracked : + CleanProbeObservationsTrackedBy before.observations before.state := by + simpa only [ObservedMaterializedOutputTracked] using + observedMaterializedOutputTracked_of_mem_retainedRunFromTable adversary parameter + ftsSecret (2 * q) table (some before) hbefore + have hcovered : + CleanProbeObservationsCoverPending before.observations before.state := by + simpa only [ObservedMaterializedOutputCovered] using + observedMaterializedOutputCovered_of_mem_retainedRunFromTable adversary parameter + ftsSecret (2 * q) table (some before) hbefore + have hpending : before.state.pending.card ≤ 2 * q := + pending_card_le_fuel_of_mem_observedMaterializedRetainedRunFromTable adversary parameter + ftsSecret (2 * q) table before hbefore + have htableAndStarts : + before.table = table ∧ StartTableAgrees before.state table := + table_eq_and_startTableAgrees_of_mem_observedMaterializedRetainedRunFromTable + adversary parameter ftsSecret (2 * q) table before hbefore + have hcard : before.state.pending.card < Fintype.card Digest := by + have hq' : 2 * q ≤ 2 ^ (126 + 1) := by + have : 2 * q ≤ 2 * 2 ^ 126 := Nat.mul_le_mul_left 2 hq + simpa [pow_succ, Nat.mul_comm] using this + have hspace : 2 ^ (126 + 1) < Fintype.card Digest := by + norm_num [securityBits, digestBits] + exact hpending.trans_lt (hq'.trans_lt hspace) + have hconsistent : + (directDeferredContext before.state).ValuesConsistent := by + intro position output hvalue + simpa [directDeferredContext, directDeferredValues] using hvalue + have hdoomed : + DoomedResolvedContext table (directDeferredContext before.state) := + ⟨hconsistent, htableAndStarts.2, hnotCompletable⟩ + exact ⟨before, hbeforeEq, hasExistingHiddenHit_of_doomed_finished table before finalResult + htableAndStarts.1 hdoomed htracked hcovered hcard hfinal⟩ + +attribute [local irreducible] observedMaterializedRetainedRunFromTable finishObservedMaterializedDiagnostic in +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem hasExistingHiddenHit_of_mem_sampledDiagnostic_successfulDoomed + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : q ≤ 2 ^ 126) + (outcome : ObservedMaterializedDiagnostic + (RetainedGameResult × SplitHashCache)) + (houtcome : outcome ∈ support + (sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q))) + (hsuccess : outcome.SuccessfulDoomed) : + outcome.HasExistingHiddenHit := by + change outcome ∈ support (sampleOtsHashTable >>= fun table => + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table >>= + finishObservedMaterializedDiagnostic table) at houtcome + rw [mem_support_bind_iff] at houtcome + obtain ⟨table, _htable, hfixed⟩ := houtcome + exact hasExistingHiddenHit_of_mem_diagnosticFromTable_successfulDoomed adversary parameter + ftsSecret q table hq outcome hfixed hsuccess + +attribute [local irreducible] sampledObservedMaterializedDiagnostic in +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_le_sum_successfulFirstOrdinals + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : q ≤ 2 ^ 126) : + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + ∑ ordinal : Fin (2 * q), + (Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal.val | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal.val | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)]) := by + classical + let run := sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q) + calc + _ ≤ Pr[fun outcome => ∃ ordinal ∈ (Finset.univ : Finset (Fin (2 * q))), + (outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal.val) ∨ + (outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal.val) | run] := by + apply probEvent_mono + intro outcome houtcome hsuccess + have hhit := hasExistingHiddenHit_of_mem_sampledDiagnostic_successfulDoomed adversary + parameter ftsSecret q hq outcome houtcome hsuccess + rcases outcome.firstExistingHidden_root_or_nonRoot hhit with hroot | hnonRoot + · obtain ⟨ordinal, result, sourceOrdinal, hbefore, hordinal, hfirst, hroot⟩ := hroot + have hlength := observations_length_le_of_mem_sampledDiagnostic_before adversary parameter + ftsSecret (2 * q) outcome result houtcome hbefore + have hlt : ordinal < 2 * q := by omega + let bounded : Fin (2 * q) := ⟨ordinal, hlt⟩ + have hrootAt : outcome.FirstExistingHiddenRootHitAt ordinal := + outcome.firstExistingHiddenRootHitAt_of_ordinal + ⟨result, sourceOrdinal, hbefore, hordinal, hfirst, hroot⟩ + exact ⟨bounded, Finset.mem_univ bounded, Or.inl ⟨hsuccess, hrootAt⟩⟩ + · obtain ⟨ordinal, result, sourceOrdinal, hbefore, hordinal, hfirst, hnonRoot⟩ := + hnonRoot + have hlength := observations_length_le_of_mem_sampledDiagnostic_before adversary parameter + ftsSecret (2 * q) outcome result houtcome hbefore + have hlt : ordinal < 2 * q := by omega + let bounded : Fin (2 * q) := ⟨ordinal, hlt⟩ + have hnonRootAt : outcome.FirstExistingHiddenNonRootHitAt ordinal := + outcome.firstExistingHiddenNonRootHitAt_of_ordinal + ⟨result, sourceOrdinal, hbefore, hordinal, hfirst, hnonRoot⟩ + exact ⟨bounded, Finset.mem_univ bounded, Or.inr ⟨hsuccess, hnonRootAt⟩⟩ + _ ≤ ∑ ordinal : Fin (2 * q), + Pr[fun outcome => + (outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal.val) ∨ + (outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal.val) | run] := + probEvent_exists_finset_le_sum Finset.univ run fun (ordinal : Fin (2 * q)) outcome => + (outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal.val) ∨ + (outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal.val) + _ ≤ ∑ ordinal : Fin (2 * q), + (Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal.val | run] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal.val | run]) := by + apply Finset.sum_le_sum + intro ordinal _hordinal + exact probEvent_or_le _ _ _ + _ = _ := by simp only [run] + +end SphincsSecurity.Concrete.OtsProbeSimulation.Range125 diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeDiagnosticJoint125.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeDiagnosticJoint125.lean new file mode 100644 index 00000000..37750b84 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeDiagnosticJoint125.lean @@ -0,0 +1,243 @@ +import SphincsSecurity.Proof.OtsProbeSelectionSchedule125 + +namespace SphincsSecurity.Concrete.OtsProbeSimulation.Range125 + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxRecDepth 100000 in +theorem probEvent_diagnosticNonRoot_le_common_mass + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hordinal : ordinal < q) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[PermissiveSelectionNonRoot | + permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret + (2 * q) table] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply (probEvent_observedMaterialized_successfulDoomed_firstNonRoot_le_selectedNonRoot + adversary parameter ftsSecret q ordinal table hbound (hq.trans (by norm_num))).trans + apply (probEvent_granularAllCanonical_nonRoot_le_selectionFire ordinal adversary parameter + table ftsSecret q).trans + apply (probEvent_selectionNonRootFire_le_selected_mass _ + (privateOrdinalSelectionFresh_of_mem_granularAllCanonical ordinal adversary parameter + table ftsSecret q)).trans + apply mul_le_mul' _ le_rfl + exact (probEvent_canonicalNonRootSelection_le_delayedCommon ordinal adversary parameter + table ftsSecret q).trans + (probEvent_delayedCommon_nonRoot_le_rootAwareCommon ordinal adversary parameter ftsSecret + q (2 * q) table hordinal (by omega)) + +set_option maxRecDepth 100000 in +theorem probEvent_diagnosticRawOrdinal_pair_le_eight_sevenths + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hordinal : ordinal < q) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] + + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + (8 / 7 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let common := permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret (2 * q) table + let rootMass := Pr[fun selection => + (permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection).isSome = true | common] + let nonRootMass := Pr[PermissiveSelectionNonRoot | common] + let epsilon := ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + have hroot := probEvent_successfulDoomedFirstRoot_le_selected_mass ordinal adversary parameter + table ftsSecret q hordinal hfuel hbound hq + have hnonRoot := probEvent_diagnosticNonRoot_le_common_mass ordinal adversary parameter + table ftsSecret q hordinal hbound hq + have hcoefficient : epsilon ≤ (8 / 7 : ENNReal) * epsilon := by + calc + epsilon = 1 * epsilon := (one_mul _).symm + _ ≤ _ := mul_le_mul' (by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + norm_num) le_rfl + calc + _ ≤ rootMass * ((8 / 7) * epsilon) + nonRootMass * epsilon := + add_le_add hroot hnonRoot + _ ≤ rootMass * ((8 / 7) * epsilon) + nonRootMass * ((8 / 7) * epsilon) := + add_le_add le_rfl (mul_le_mul' le_rfl hcoefficient) + _ = (rootMass + nonRootMass) * ((8 / 7) * epsilon) := (add_mul ..).symm + _ ≤ 1 * ((8 / 7) * epsilon) := + mul_le_mul' (rootSelection_nonRootSelection_mass_le_one common) le_rfl + _ = _ := one_mul _ + +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnosticOrdinal_pair_le_eight_sevenths + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hordinal : ordinal < q) (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[fun outcome => outcome.SuccessfulDoomed ∧ outcome.FirstExistingHiddenRootHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ outcome.FirstExistingHiddenNonRootHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + (8 / 7 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let epsilon := (8 / 7 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + unfold sampledObservedMaterializedDiagnostic + simp only [probEvent_bind_eq_tsum sampleOtsHashTable, ← ENNReal.tsum_add, ← mul_add] + calc + _ ≤ ∑' table, Pr[= table | sampleOtsHashTable] * epsilon := by + apply ENNReal.tsum_le_tsum + intro table + apply mul_le_mul' le_rfl + apply (add_le_add + (probEvent_finishDiagnostic_successfulDoomed_firstExistingHiddenRootHitAt_le table + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table) + ordinal) + (probEvent_finishDiagnostic_successfulDoomed_firstExistingHiddenNonRootHitAt_le table + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table) + ordinal)).trans + exact probEvent_diagnosticRawOrdinal_pair_le_eight_sevenths ordinal adversary parameter + table ftsSecret q hordinal hfuel (hbound table) hq + _ = (∑' table, Pr[= table | sampleOtsHashTable]) * epsilon := ENNReal.tsum_mul_right + _ ≤ 1 * epsilon := mul_le_mul' tsum_probOutput_le_one le_rfl + _ = _ := one_mul _ + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_le_eight_sevenths_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hfuel : 2 * q < Fintype.card Digest) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + ((8 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + classical + let diagnostic := + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q) + let epsilon := ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + calc + _ ≤ ∑ ordinal : Fin (2 * q), + (Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal.val | diagnostic] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal.val | diagnostic]) := + probEvent_sampledDiagnostic_successfulDoomed_le_sum_successfulFirstOrdinals adversary + parameter ftsSecret q (hq.trans (by norm_num)) + _ ≤ ∑ _ordinal : Fin q, (8 / 7) * epsilon := by + simp only [Finset.sum_fin_eq_sum_range] + rw [show 2 * q = q + q by omega, Finset.sum_range_add] + have hfirst : + (∑ ordinal ∈ Finset.range q, if h : ordinal < q + q then + (Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal | diagnostic] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal | diagnostic]) + else 0) ≤ + ∑ _ordinal ∈ Finset.range q, (8 / 7) * epsilon := by + apply Finset.sum_le_sum + intro ordinal hordinalMem + have hordinal : ordinal < q := Finset.mem_range.1 hordinalMem + have hordinal' : ordinal < q + q := hordinal.trans_le (Nat.le_add_right q q) + simp only [hordinal', ↓reduceDIte] + exact probEvent_sampledDiagnosticOrdinal_pair_le_eight_sevenths ordinal adversary + parameter ftsSecret q hordinal hfuel hexpanded hq + have hzero : + (∑ ordinal ∈ Finset.range q, if h : q + ordinal < q + q then + (Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt (q + ordinal) | diagnostic] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt (q + ordinal) | diagnostic]) + else 0) = 0 := by + apply Finset.sum_eq_zero + intro ordinal hordinalMem + have hordinal : ordinal < q := Finset.mem_range.1 hordinalMem + simp only [show q + ordinal < q + q by omega, ↓reduceDIte] + rw [probEvent_sampledDiagnostic_successfulDoomed_firstRoot_eq_zero_of_q_le_ordinal + adversary parameter ftsSecret q (q + ordinal) hexpanded (hq.trans (by norm_num)) (by omega)] + rw [probEvent_sampledDiagnostic_successfulDoomed_firstNonRoot_eq_zero_of_q_le_ordinal + adversary parameter ftsSecret q (q + ordinal) hexpanded (hq.trans (by norm_num)) (by omega)] + simp + calc + _ ≤ (∑ _ordinal ∈ Finset.range q, (8 / 7) * epsilon) + + (∑ ordinal ∈ Finset.range q, if h : q + ordinal < q + q then + (Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt (q + ordinal) | diagnostic] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt (q + ordinal) | diagnostic]) + else 0) := add_le_add hfirst le_rfl + _ = ∑ _ordinal ∈ Finset.range q, (8 / 7) * epsilon := by rw [hzero, add_zero] + _ = ∑ ordinal ∈ Finset.range q, if h : ordinal < q then (8 / 7) * epsilon else 0 := by + apply Finset.sum_congr rfl + intro ordinal hordinalMem + simp [Finset.mem_range.1 hordinalMem] + _ = (q : ENNReal) * ((8 / 7) * epsilon) := by simp + _ = _ := by + simp only [epsilon] + push_cast + ring + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnostic_bad_le_fifteen_sevenths_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hfuel : 2 * q < Fintype.card Digest) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[ObservedMaterializedDiagnostic.Bad | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + ((15 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let diagnostic := + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q) + calc + _ ≤ Pr[fun outcome => outcome.final = none | diagnostic] + + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | diagnostic] := + probEvent_diagnosticBad_le_finalNone_add_successfulDoomed diagnostic + _ ≤ (q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + ((8 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply add_le_add + · exact probEvent_sampledDiagnostic_final_none_le_queryBound adversary parameter + ftsSecret (2 * q) q hexpanded (by omega) + · exact probEvent_sampledDiagnostic_successfulDoomed_le_eight_sevenths_mul adversary parameter + ftsSecret q hfuel hexpanded hq + _ = _ := by + rw [← add_mul, ← one_add_mul] + have hcoeff : (1 : ENNReal) + 8 / 7 = 15 / 7 := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + norm_num + rw [hcoeff] + +end SphincsSecurity.Concrete.OtsProbeSimulation.Range125 diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeEncodingPrehit.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeEncodingPrehit.lean new file mode 100644 index 00000000..8d201ed1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeEncodingPrehit.lean @@ -0,0 +1,85 @@ +import SphincsSecurity.Proof.EncodingPrehitContinuation +import SphincsSecurity.Proof.OtsOpeningRefinedReserve + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option maxRecDepth 100000 in +theorem EncodingLayerRootCandidateAt.prehit_of_newly_settled + {secretKey : SecretKey} {cache : QueryCache HashSpec} + {previous input : HashInput} {answer : HashOutput} {candidate : Probe} {target : Position} + (hcandidate : EncodingLayerRootCandidateAt secretKey.parameter previous candidate) + (hposition : candidate.coordinate = .position target) + (hcached : cache previous ≠ none) + (hbefore : ¬ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache target) + (hafter : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) target) + (hmatch : candidate.candidate = honestValue (fromCache (cache.cacheQuery input answer)) + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret target) : + EncodingMessagePrehit cache secretKey input answer := by + obtain ⟨position, index, hat, htree, hleaf, _hnotBottom, rfl⟩ := hcandidate + have heq : layerMessagePosition index position.lay = target := Coordinate.position.inj hposition + subst target + exact ⟨position, index, previous, htree, hleaf, hbefore, hafter, hat, hcached, hmatch⟩ + +set_option maxRecDepth 100000 in +theorem EncodingLayerRootCandidateAt.ne_honestValue_of_prehitFree_settlement + {secretKey : SecretKey} {cache : QueryCache HashSpec} + {previous input : HashInput} {answer : HashOutput} {candidate : Probe} {target : Position} + (hcandidate : EncodingLayerRootCandidateAt secretKey.parameter previous candidate) + (hposition : candidate.coordinate = .position target) + (hcached : cache previous ≠ none) (hfresh : cache input = none) + (hbefore : ¬ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache target) + (hafter : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) target) + (hstep : ((answer, cache.cacheQuery input answer), false) ∈ support + (TightEncoding.runEncodingPrehitMonitor secretKey (OracleWorld.query (.inr input)) cache false)) : + candidate.candidate ≠ honestValue (fromCache (cache.cacheQuery input answer)) + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret target := by + intro hmatch + exact TightEncoding.not_encodingMessagePrehit_of_mem_support_query_false secretKey input answer + cache (cache.cacheQuery input answer) false hfresh hstep + (hcandidate.prehit_of_newly_settled hposition hcached hbefore hafter hmatch) + +set_option maxRecDepth 100000 in +theorem EncodingLayerRootCandidateAt.ne_honestValue_of_prehitFree_continuation + {secretKey : SecretKey} {initialCache finalCache : QueryCache HashSpec} + {previous : HashInput} {candidate : Probe} {target : Position} + (hcandidate : EncodingLayerRootCandidateAt secretKey.parameter previous candidate) + (hposition : candidate.coordinate = .position target) + (hcached : initialCache previous ≠ none) + (hbefore : ¬ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret initialCache target) + (hafter : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret finalCache target) + (computation : OracleComp OracleWorld α) (value : α) + (hrun : ((value, finalCache), false) ∈ support + (TightEncoding.runEncodingPrehitMonitor secretKey computation initialCache false)) : + candidate.candidate ≠ honestValue (fromCache finalCache) + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret target := by + obtain ⟨position, index, hat, htree, hleaf, _hnotBottom, rfl⟩ := hcandidate + have heq : layerMessagePosition index position.lay = target := Coordinate.position.inj hposition + subst target + exact TightEncoding.encodingMessage_ne_honestValue_of_prehitFree_continuation + secretKey position index previous htree hleaf hat computation initialCache value finalCache hcached hbefore hafter hrun + +set_option maxRecDepth 100000 in +theorem EncodingLayerRootCandidateAt.refinedReserve_of_prehitFree_matching_query + {secretKey : SecretKey} {initialCache finalCache : QueryCache HashSpec} + {input : HashInput} {candidate : Probe} {target : Position} + (hcandidate : EncodingLayerRootCandidateAt secretKey.parameter input candidate) + (hposition : candidate.coordinate = .position target) + (hafter : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret finalCache target) + (hmatch : candidate.candidate = honestValue (fromCache finalCache) + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret target) + (next : HashOutput → OracleComp OracleWorld α) (value : α) + (hrun : ((value, finalCache), false) ∈ support + (TightEncoding.runEncodingPrehitMonitor secretKey (OracleWorld.query (.inr input) >>= next) initialCache false)) : + (4 / 3 : ℝ≥0∞) ≤ otsOpeningRefinedQueryReserve secretKey initialCache input := by + obtain ⟨position, index, hat, htree, hleaf, _hnotBottom, rfl⟩ := hcandidate + have heq : layerMessagePosition index position.lay = target := Coordinate.position.inj hposition + subst target + exact otsOpeningRefinedQueryReserve_ge_four_thirds_of_encodingMessageSettled secretKey initialCache input position hat + (TightEncoding.encodingMessageSettledAt_of_prehitFree_matching_query secretKey position index input + htree hleaf hat next initialCache value finalCache hafter hmatch hrun) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeEncodingPrehitViewed.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeEncodingPrehitViewed.lean new file mode 100644 index 00000000..3489993f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeEncodingPrehitViewed.lean @@ -0,0 +1,64 @@ +import SphincsSecurity.Proof.OtsProbeEncodingPrehit +import SphincsSecurity.Proof.EncodingPrehitViewedProjection + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option maxRecDepth 100000 in +theorem EncodingLayerRootCandidateAt.ne_honestValue_of_prehitFree_viewed_continuation + {accountingKey : SecretKey} (secretKey : SecretKey) + {initialState finalState : ViewedFullTraceState} + {previous : HashInput} {candidate : Probe} {target : Position} + (hcandidate : EncodingLayerRootCandidateAt accountingKey.parameter previous candidate) + (hposition : candidate.coordinate = .position target) + (hcached : initialState.cache previous ≠ none) + (hbefore : ¬ Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret initialState.cache target) + (hafter : Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret finalState.cache target) + (computation : OracleComp (OracleWorld + SigningSpec) α) (value : α) + (hrun : (value, (finalState, false)) ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run (initialState, false))) : + candidate.candidate ≠ honestValue (fromCache finalState.cache) + accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret target := by + obtain ⟨log, hmonitor, _⟩ := encodingPrehitViewedAdversaryImpl_support_monitor accountingKey secretKey + computation (initialState, false) (value, (finalState, false)) hrun + exact hcandidate.ne_honestValue_of_prehitFree_continuation hposition hcached hbefore hafter + ((simulateQ (forwardOracles + signingOracle scheme secretKey) computation).run) (value, log) hmonitor + +set_option maxRecDepth 100000 in +theorem EncodingLayerRootCandidateAt.refinedReserve_of_prehitFree_viewed_matching_query + {accountingKey : SecretKey} (secretKey : SecretKey) + {initialState finalState : ViewedFullTraceState} + {input : HashInput} {candidate : Probe} {target : Position} + (hcandidate : EncodingLayerRootCandidateAt accountingKey.parameter input candidate) + (hposition : candidate.coordinate = .position target) + (hafter : Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret finalState.cache target) + (hmatch : candidate.candidate = honestValue (fromCache finalState.cache) + accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret target) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) (value : α) + (hrun : (value, (finalState, false)) ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next)).run (initialState, false))) : + (4 / 3 : ℝ≥0∞) ≤ otsOpeningRefinedQueryReserve accountingKey initialState.cache input := by + obtain ⟨log, hmonitor, _⟩ := encodingPrehitViewedAdversaryImpl_support_monitor accountingKey secretKey + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next) (initialState, false) (value, (finalState, false)) hrun + have hcomputation : + ((simulateQ (forwardOracles + signingOracle scheme secretKey) + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next)).run) = + ((liftM (OracleWorld.query (.inr input)) : OracleComp OracleWorld HashOutput) >>= fun answer => + (simulateQ (forwardOracles + signingOracle scheme secretKey) (next answer)).run) := by + have hquery : (((forwardOracles + signingOracle scheme secretKey) (.inl (.inr input))).run) = + (fun output => (output, ([] : QueryLog SigningSpec))) <$> + (liftM (OracleWorld.query (.inr input)) : OracleComp OracleWorld HashOutput) := rfl + rw [simulateQ_bind, WriterT.run_bind', simulateQ_spec_query, hquery] + erw [bind_map_left] + apply bind_congr + intro answer + change (fun result : α × QueryLog SigningSpec => (result.1, [] ++ result.2)) <$> + (simulateQ (forwardOracles + signingOracle scheme secretKey) (next answer)).run = _ + simp + rw [hcomputation] at hmonitor + exact hcandidate.refinedReserve_of_prehitFree_matching_query hposition hafter hmatch + (fun answer => (simulateQ (forwardOracles + signingOracle scheme secretKey) (next answer)).run) (value, log) hmonitor + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeEnsuredExecution.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeEnsuredExecution.lean new file mode 100644 index 00000000..607dc4e3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeEnsuredExecution.lean @@ -0,0 +1,239 @@ +import SphincsSecurity.Proof.OtsProbeProbeFreeRisk +import SphincsSecurity.Proof.OtsProbeEnsuredInitialization + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def DeferredContext.enlargeEnsured (context : DeferredContext) (extra : Finset Coordinate) : DeferredContext := + { context with state := { context.state with ensured := context.state.ensured ∪ extra } } + +def DeferredResolution.enlargeEnsured (result : DeferredResolution) (extra : Finset Coordinate) : DeferredResolution := + ⟨result.toDeferredContext.enlargeEnsured extra, result.output⟩ + +def ResolvedRunResult.enlargeEnsured (result : ResolvedRunResult α) (extra : Finset Coordinate) : ResolvedRunResult α := + { result with context := result.context.enlargeEnsured extra } + +theorem DeferredContext.coreEq_enlargeEnsured (context : DeferredContext) (extra : Finset Coordinate) : + context.CoreEq (context.enlargeEnsured extra) := ⟨rfl, rfl, rfl⟩ + +theorem resolveDeferredPositionValue_enlargeEnsured + (position : Position) (context : DeferredContext) (extra : Finset Coordinate) : + resolveDeferredPositionValue position (context.enlargeEnsured extra) = + Option.map (fun result => result.enlargeEnsured extra) <$> resolveDeferredPositionValue position context := by + unfold resolveDeferredPositionValue + cases hstate : context.state.values (.position position) with + | some output => + by_cases hhit : context.state.hitAt (.position position) output <;> + simp_all [DeferredContext.enlargeEnsured, DeferredResolution.enlargeEnsured, + LazyRevealProbe.State.clearPending, LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, + LazyRevealProbe.State.pendingAway] + | none => + cases hvalue : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output <;> + simp_all [DeferredContext.enlargeEnsured, DeferredResolution.enlargeEnsured, + LazyRevealProbe.State.clearPending, LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, + LazyRevealProbe.State.pendingAway] + | none => + simp only [DeferredContext.enlargeEnsured, hstate, hvalue] + rw [map_bind] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output <;> + simp_all [DeferredResolution.enlargeEnsured, DeferredContext.enlargeEnsured, + LazyRevealProbe.State.clearPending, LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, + LazyRevealProbe.State.pendingAway] + +theorem resolveDeferredChainStart_enlargeEnsured + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) (extra : Finset Coordinate) : + resolveDeferredChainStart table index (context.enlargeEnsured extra) = + (resolveDeferredChainStart table index context).map (fun result => result.enlargeEnsured extra) := by + unfold resolveDeferredChainStart + cases hvalue : context.state.values index.coordinate with + | none => + by_cases hhit : context.state.hitAt index.coordinate (table index) <;> + simp_all [DeferredContext.enlargeEnsured, DeferredResolution.enlargeEnsured, + LazyRevealProbe.State.clearPending, LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, + LazyRevealProbe.State.pendingAway] + | some output => + by_cases hhit : context.state.hitAt index.coordinate output <;> + simp_all [DeferredContext.enlargeEnsured, DeferredResolution.enlargeEnsured, + LazyRevealProbe.State.clearPending, LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, + LazyRevealProbe.State.pendingAway] + +theorem resolveDeferredChainPrefix_enlargeEnsured + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (steps : Nat) (hsteps : steps ≤ chainLength - 1) + (context : DeferredContext) (extra : Finset Coordinate) : + resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps (context.enlargeEnsured extra) = + Option.map (fun result => result.enlargeEnsured extra) <$> + resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context := by + induction steps generalizing context with + | zero => simp only [resolveDeferredChainPrefix, resolveDeferredChainStart_enlargeEnsured, map_pure] + | succ steps ih => + rw [resolveDeferredChainPrefix, ih, bind_map_left, resolveDeferredChainPrefix, map_bind] + apply bind_congr + intro result + cases result with + | none => simp + | some result => exact resolveDeferredPositionValue_enlargeEnsured _ result.toDeferredContext extra + +theorem resolveDeferredChains_enlargeEnsured + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chains : List ChainIndex) (context : DeferredContext) (extra : Finset Coordinate) : + resolveDeferredChains table lay tree leafIdx chains (context.enlargeEnsured extra) = + Option.map (fun result => result.enlargeEnsured extra) <$> resolveDeferredChains table lay tree leafIdx chains context := by + induction chains generalizing context with + | nil => simp [resolveDeferredChains] + | cons chainIdx chains ih => + rw [resolveDeferredChains, resolveDeferredChainPrefix_enlargeEnsured, bind_map_left, + resolveDeferredChains, map_bind] + apply bind_congr + intro result + cases result with + | none => simp + | some result => exact ih result.toDeferredContext + +theorem resolveDeferredOtsLeaf_enlargeEnsured + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (context : DeferredContext) (extra : Finset Coordinate) : + resolveDeferredOtsLeaf table lay tree leafIdx (context.enlargeEnsured extra) = + Option.map (fun result => result.enlargeEnsured extra) <$> resolveDeferredOtsLeaf table lay tree leafIdx context := by + rw [resolveDeferredOtsLeaf, resolveDeferredChains_enlargeEnsured, bind_map_left, resolveDeferredOtsLeaf, map_bind] + apply bind_congr + intro result + cases result with + | none => simp + | some result => exact resolveDeferredPositionValue_enlargeEnsured _ result extra + +theorem resolveDeferredTreeNode_enlargeEnsured + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) (hlevel : level ≤ maxLayerHeight) (context : DeferredContext) (extra : Finset Coordinate) : + resolveDeferredTreeNode table lay tree level nodeIdx hlevel (context.enlargeEnsured extra) = + Option.map (fun result => result.enlargeEnsured extra) <$> + resolveDeferredTreeNode table lay tree level nodeIdx hlevel context := by + induction level generalizing nodeIdx context with + | zero => exact resolveDeferredOtsLeaf_enlargeEnsured table lay tree (leafOfNat nodeIdx) context extra + | succ level ih => + rw [resolveDeferredTreeNode, ih, bind_map_left, resolveDeferredTreeNode, map_bind] + apply bind_congr + intro left + cases left with + | none => simp + | some left => + dsimp only [Option.map, DeferredResolution.enlargeEnsured, Function.comp_def] + rw [ih, bind_map_left, map_bind] + apply bind_congr + intro right + cases right with + | none => simp + | some right => exact resolveDeferredPositionValue_enlargeEnsured _ right.toDeferredContext extra + +theorem resolveDeferredReveal_enlargeEnsured + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (extra : Finset Coordinate) : + resolveDeferredReveal table position (context.enlargeEnsured extra) = + Option.map (fun result => result.enlargeEnsured extra) <$> resolveDeferredReveal table position context := by + unfold resolveDeferredReveal + split_ifs with hposition + · cases position <;> simp only [resolveDeferredPosition, resolveDeferredChainPrefix_enlargeEnsured, + resolveDeferredOtsLeaf_enlargeEnsured, resolveDeferredTreeNode_enlargeEnsured, resolveDeferredPositionValue_enlargeEnsured] + · exact resolveDeferredPositionValue_enlargeEnsured position context extra + +theorem runResolvedFromTable_enlargeEnsured + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (extra : Finset Coordinate) : + runResolvedFromTable (context.enlargeEnsured extra) fuel table computation = + Option.map (fun result => result.enlargeEnsured extra) <$> runResolvedFromTable context fuel table computation := by + induction computation using OracleComp.inductionOn generalizing context fuel table with + | pure value => simp [runResolvedFromTable, ResolvedRunResult.enlargeEnsured] + | query_bind input next ih => + cases input with + | uniform n => + rw [runResolvedFromTable_uniform_query_bind, runResolvedFromTable_uniform_query_bind, map_bind] + exact bind_congr fun output => ih output context fuel table + | hashOutput => + rw [runResolvedFromTable_hashOutput_query_bind, runResolvedFromTable_hashOutput_query_bind, map_bind] + exact bind_congr fun output => ih output context fuel table + | ensure coordinate => + rw [runResolvedFromTable_ensure_query_bind, runResolvedFromTable_ensure_query_bind] + simpa only [DeferredContext.enlargeEnsured, LazyRevealProbe.State.ensure, Finset.insert_union] using + ih () { context with state := context.state.ensure coordinate } fuel table + | probe coordinate candidate => + rw [runResolvedFromTable_probe_query_bind, runResolvedFromTable_probe_query_bind] + cases fuel with + | zero => simp + | succ fuel => + by_cases hrevealed : coordinate ∈ context.state.revealed + · simpa only [DeferredContext.enlargeEnsured, hrevealed, ↓reduceIte] using ih () context fuel table + · simpa only [DeferredContext.enlargeEnsured, hrevealed, ↓reduceIte, LazyRevealProbe.State.addPending] using + ih () { context with state := context.state.addPending coordinate candidate } fuel table + | peek coordinate => + rw [runResolvedFromTable_peek_query_bind, runResolvedFromTable_peek_query_bind] + exact ih (context.state.values coordinate) context fuel table + | publish coordinate => + rw [runResolvedFromTable_publish_query_bind, runResolvedFromTable_publish_query_bind] + exact ih () { context with state := context.state.publish coordinate } fuel table + | reveal coordinate => + rw [runResolvedFromTable_reveal_query_bind, runResolvedFromTable_reveal_query_bind] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [resolveDeferredChainStart_enlargeEnsured, pure_bind] + cases hresolved : resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context with + | none => simp + | some result => + simpa only [Option.map, DeferredResolution.enlargeEnsured, DeferredContext.enlargeEnsured, + LazyRevealProbe.State.materialize, LazyRevealProbe.State.pendingAway, Finset.insert_union] using + ih result.output ⟨context.state.materialize (.chainStart lay tree leafIdx chainIdx) result.output, result.values⟩ fuel table + | position position => + dsimp only + rw [resolveDeferredReveal_enlargeEnsured, bind_map_left, map_bind] + apply bind_congr + intro result + cases result with + | none => simp + | some result => + simpa only [Option.map, DeferredResolution.enlargeEnsured, DeferredContext.enlargeEnsured, + LazyRevealProbe.State.materialize, LazyRevealProbe.State.pendingAway, Finset.insert_union] using + ih result.output ⟨context.state.materialize (.position position) result.output, result.values⟩ fuel table + +theorem evalDist_finishResolvedRunIsNone_enlargeEnsured + (result : ResolvedRunResult α) (extra : Finset Coordinate) + (hconsistent : result.context.ValuesConsistent) (hstarts : StartTableAgrees result.context.state result.table) : + evalDist (finishResolvedRunIsNone (some (result.enlargeEnsured extra))) = + evalDist (finishResolvedRunIsNone (some result)) := by + have heq := result.context.coreEq_enlargeEnsured extra + have hcompleteEq := deferredCompletable_iff_of_coreEq (table := result.table) heq + by_cases hcomplete : DeferredCompletable result.table result.context + · have hvalid := valid_of_resolvedCore_completable result.table result.context hconsistent hstarts hcomplete + rw [finishResolvedRunIsNone_some_eq_finalize (result.enlargeEnsured extra) (hcompleteEq.mp hcomplete), + finishResolvedRunIsNone_some_eq_finalize result hcomplete] + exact (evalDist_finalize_failure_of_coreEq result.table _ _ hvalid hstarts hcomplete heq).symm + · have hright : ¬DeferredCompletable result.table (result.context.enlargeEnsured extra) := + fun h => hcomplete (hcompleteEq.mpr h) + rw [show finishResolvedRunIsNone (some (result.enlargeEnsured extra)) = pure true by + simp [finishResolvedRunIsNone, finishResolvedRun, ResolvedRunResult.enlargeEnsured, hright]] + simp [finishResolvedRunIsNone, finishResolvedRun, hcomplete] + +theorem evalDist_runResolved_finish_enlargeEnsured + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (extra : Finset Coordinate) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + evalDist (runResolvedFromTable (context.enlargeEnsured extra) fuel table computation >>= finishResolvedRunIsNone) = + evalDist (runResolvedFromTable context fuel table computation >>= finishResolvedRunIsNone) := by + rw [runResolvedFromTable_enlargeEnsured, bind_map_left] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable computation context fuel table result + hconsistent hstarts hresult + exact evalDist_finishResolvedRunIsNone_enlargeEnsured result extra hcore.2.1 (by rw [hcore.1]; exact hcore.2.2) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeEnsuredInitialization.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeEnsuredInitialization.lean new file mode 100644 index 00000000..8697eb06 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeEnsuredInitialization.lean @@ -0,0 +1,134 @@ +import SphincsSecurity.Proof.OtsProbeLiveStartCounting + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def ensuredInitialContext (targets : Finset Position) : DeferredContext := + { state := { LazyRevealProbe.State.empty with ensured := targets.image Coordinate.position } + values := emptyDeferredStructuralValues } + +theorem ensuredInitialContext_coreEq (targets : Finset Position) : + ({ state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } : DeferredContext).CoreEq + (ensuredInitialContext targets) := ⟨rfl, rfl, rfl⟩ + +theorem ensuredInitialContext_valid (targets : Finset Position) : (ensuredInitialContext targets).Valid := + DeferredContext.valid_empty.of_coreEq (ensuredInitialContext_coreEq targets) + +theorem ensuredInitialContext_resolvedInvariant + (targets : Finset Position) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) : + ResolvedContextInvariant parameter table (ensuredInitialContext targets) ∅ ∅ := + (resolvedContextInvariant_empty parameter table).of_coreEq (ensuredInitialContext_coreEq targets) + +theorem ensuredInitialContext_completable (targets : Finset Position) (table : OtsSecretIndex → HashOutput) : + DeferredCompletable table (ensuredInitialContext targets) := + (deferredCompletable_iff_of_coreEq (ensuredInitialContext_coreEq targets)).mp (deferredCompletable_empty table) + +theorem ensuredInitialContext_visible + (targets : Finset Position) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) : + VisibleResolvedComputationsCached parameter table (ensuredInitialContext targets) ∅ := by + intro position output _hresolvable hvalue + simp [ensuredInitialContext, LazyRevealProbe.State.empty] at hvalue + +theorem ensuredInitialContext_published (targets : Finset Position) : PublishedValues (ensuredInitialContext targets).state := by + intro coordinate hrevealed + simp [ensuredInitialContext, LazyRevealProbe.State.empty] at hrevealed + +theorem ensuredInitialContext_mem_ensured (targets : Finset Position) (target : Position) (hmem : target ∈ targets) : + .position target ∈ (ensuredInitialContext targets).state.ensured := + Finset.mem_image.mpr ⟨target, hmem, rfl⟩ + +theorem sum_targets_privateHits_ensuredInitial_le_structuralCharge + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q fuel : Nat) (table : OtsSecretIndex → HashOutput) (hq : q ≤ 2 ^ 126) : + (∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table (ensuredInitialContext targets) fuel (privatePositionProbeCutAt target computation ordinal)]) ≤ + expectedLiveResolvedQueryCharge structuralProbeQueryCharge computation (ensuredInitialContext targets) fuel table * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply sum_targets_privateResolvedRawCandidate_hit_le_expectedLiveStructuralCharge targets computation q (ensuredInitialContext targets) fuel table + (ensuredInitialContext_valid targets) (ensuredInitialContext_completable targets table) + (ensuredInitialContext_mem_ensured targets) + · intro target _ + rfl + · intro target _ + rfl + · intro target _ + simp [ensuredInitialContext, LazyRevealProbe.State.empty] + · intro target _ + simpa [ensuredInitialContext, LazyRevealProbe.State.empty, LazyRevealProbe.State.pendingAt] using hq + +noncomputable def sampledEnsuredNativeProbeCut + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel ordinal : Nat) : + ProbComp (Option (ResolvedRunResult (PrivateValueCut α))) := do + let table ← sampleOtsHashTable + runResolvedFromTable (ensuredInitialContext targets) fuel table (nativeProbeCutAt computation ordinal) + +theorem probEvent_sampledEnsuredNativeProbeCut_unresolvedStart_le + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel ordinal : Nat) + (hordinal : ordinal ≤ 2 ^ 126) : + Pr[LiveUnresolvedStartHit nativeCutCandidate | sampledEnsuredNativeProbeCut targets computation fuel ordinal] ≤ + (∑' result, Pr[= result | sampledEnsuredNativeProbeCut targets computation fuel ordinal] * + historyUnresolvedStartCharge nativeCutCandidate (retainCompletableResult result)) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + have hnative := probEvent_live_unresolvedStart_hit_le_native_charge (nativeProbeCutAt computation ordinal) + (ensuredInitialContext targets) fuel ordinal [] nativeCutCandidate (ensuredInitialContext_valid targets).valuesConsistent + (show PendingCoveredBy [] (ensuredInitialContext targets) from pendingCoveredBy_empty) + (nativeProbeCutAt_probeBound computation ordinal) (by simpa only [List.length_nil, Nat.zero_add] using hordinal) + have htable : ∀ base, completedStartTable (ensuredInitialContext targets).state base = base := by + intro base + funext index + rfl + simpa only [sampledEnsuredNativeProbeCut, sampledHistoryFilteredRun, ChainStartHistoryHit, List.not_mem_nil, + false_and, exists_false, ↓reduceIte, htable] using hnative + +theorem sum_sampledEnsuredNativeProbeCut_unresolvedStart_le + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel q : Nat) + (hq : q ≤ 2 ^ 126) : + (∑ ordinal ∈ Finset.range q, + Pr[LiveUnresolvedStartHit nativeCutCandidate | sampledEnsuredNativeProbeCut targets computation fuel ordinal]) ≤ + (∑ ordinal ∈ Finset.range q, ∑' result, + Pr[= result | sampledEnsuredNativeProbeCut targets computation fuel ordinal] * + historyUnresolvedStartCharge nativeCutCandidate (retainCompletableResult result)) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + rw [Finset.sum_mul] + apply Finset.sum_le_sum + intro ordinal hmem + exact probEvent_sampledEnsuredNativeProbeCut_unresolvedStart_le targets computation fuel ordinal + ((Nat.le_of_lt (Finset.mem_range.mp hmem)).trans hq) + +theorem sum_sampledEnsuredNativeProbeCut_unresolvedStart_le_expectedChainStartCharge + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + (∑ ordinal ∈ Finset.range q, + Pr[LiveUnresolvedStartHit nativeCutCandidate | sampledEnsuredNativeProbeCut targets computation fuel ordinal]) ≤ + (∑' table, Pr[= table | sampleOtsHashTable] * + expectedLiveResolvedQueryCharge chainStartProbeQueryCharge computation + (ensuredInitialContext targets) fuel table) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply (sum_sampledEnsuredNativeProbeCut_unresolvedStart_le targets computation fuel q hq).trans + apply mul_le_mul' _ le_rfl + calc + _ ≤ ∑ ordinal ∈ Finset.range q, ∑' result, + Pr[= result | sampledEnsuredNativeProbeCut targets computation fuel ordinal] * liveNativeCutCharge chainStartProbeQueryCharge result := by + apply Finset.sum_le_sum + intro ordinal _ + exact ENNReal.tsum_le_tsum fun result => mul_le_mul' le_rfl (historyUnresolvedStartCharge_le_liveNativeCutCharge result) + _ = ∑' table, Pr[= table | sampleOtsHashTable] * + ∑ ordinal ∈ Finset.range q, expectedLiveNativeCutCharge chainStartProbeQueryCharge + (nativeProbeCutAt computation ordinal) + (ensuredInitialContext targets) fuel table := by + simp only [sampledEnsuredNativeProbeCut, tsum_probOutput_bind_mul] + rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + simp only [← Finset.mul_sum, expectedLiveNativeCutCharge] + _ ≤ _ := by + apply ENNReal.tsum_le_tsum + intro table + exact mul_le_mul' le_rfl (sum_expectedLiveNativeProbeCutCharge_le_expectedCharge chainStartProbeQueryCharge computation q + (ensuredInitialContext targets) fuel table + (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table))) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeExecutionCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeExecutionCharge.lean new file mode 100644 index 00000000..852c1539 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeExecutionCharge.lean @@ -0,0 +1,111 @@ +import SphincsSecurity.Proof.OtsProbeStepCharge +import SphincsSecurity.Proof.LazyRevealProbeSimulationCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def otsHashInputCharge (parameter : PublicParameter) (input : HashInput) : ℝ≥0∞ := + by + classical + exact if ∃ position : Position, IsOtsPosition position ∧ AtPosition parameter input position then 1 else 0 + +noncomputable def otsOuterQueryCharge (parameter : PublicParameter) : + (OracleWorld + SigningSpec).Domain → ℝ≥0∞ + | .inl (.inr input) => otsHashInputCharge parameter input + | _ => 0 + +theorem otsHashInputCharge_le_queryReserve (secretKey : SecretKey) + (actualCache : QueryCache HashSpec) (input : HashInput) : + otsHashInputCharge secretKey.parameter input ≤ otsOpeningQueryReserve secretKey actualCache input := by + classical + unfold otsHashInputCharge + split_ifs with hots + · obtain ⟨position, hposition, hat⟩ := hots + exact otsOpeningQueryReserve_ge_one_of_atOtsPosition secretKey actualCache input position hat hposition + · exact bot_le + +theorem probingHashQuery_expectedCharge_le_otsHashInputCharge (parameter : PublicParameter) + (input : HashInput) (cache : SplitHashCache) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) : + LazyRevealProbe.expectedProbeCharge ((probingHashQuery parameter input).run cache) state fuel ≤ + otsHashInputCharge parameter input := by + classical + unfold otsHashInputCharge + split_ifs with hots + · simpa only [Nat.cast_one] using LazyRevealProbe.expectedProbeCharge_le_queryBound _ state fuel 1 + (probingHashQuery_run_isProbeBound parameter input cache) + · rw [probingHashQuery_eq_split_of_not_atOtsPosition parameter input hots, + LazyRevealProbe.expectedProbeCharge_eq_zero_of_probeFree _ state fuel (splitHashQuery_probeFree _ cache)] + +theorem maskedExpandedAdversaryImpl_expectedCharge_le (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (input : (OracleWorld + SigningSpec).Domain) + (cache : SplitHashCache) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) : + LazyRevealProbe.expectedProbeCharge ((maskedExpandedAdversaryImpl parameter root ftsSecret input).run cache) + state fuel ≤ otsOuterQueryCharge parameter input := by + cases input with + | inl input => + cases input with + | inl n => + change LazyRevealProbe.expectedProbeCharge ((splitUniformImpl n).run cache) state fuel ≤ 0 + rw [LazyRevealProbe.expectedProbeCharge_eq_zero_of_probeFree _ state fuel (splitUniformImpl_probeFree n cache)] + | inr input => exact probingHashQuery_expectedCharge_le_otsHashInputCharge parameter input cache state fuel + | inr message => + change LazyRevealProbe.expectedProbeCharge ((maskedSign parameter root ftsSecret message).run cache) state fuel ≤ 0 + rw [maskedSign_expectedProbeCharge_eq_zero] + +noncomputable def expectedMaskedOtsQueryCount {α : Type} (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (cache : SplitHashCache) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) : ℝ≥0∞ := + LazyRevealProbe.expectedSimulationCharge (maskedExpandedAdversaryImpl parameter root ftsSecret) + (fun input _ _ _ => otsOuterQueryCharge parameter input) computation cache state fuel + +theorem simulateQ_maskedExpanded_expectedCharge_le {α : Type} (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (cache : SplitHashCache) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) : + LazyRevealProbe.expectedProbeCharge + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) state fuel ≤ + expectedMaskedOtsQueryCount parameter root ftsSecret computation cache state fuel := + LazyRevealProbe.expectedProbeCharge_simulateQ_le _ _ + (maskedExpandedAdversaryImpl_expectedCharge_le parameter root ftsSecret) computation cache state fuel + +noncomputable def deferredOtsQueryCount (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : ℝ≥0∞ := + ∑' result, Pr[= result | LazyRevealProbe.runRaw LazyRevealProbe.State.empty fuel + (maskedPublishedTreeRoot.run emptySplitHashCache)] * + match result with + | .stopped _ => 0 + | .done state remaining value => expectedMaskedOtsQueryCount parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) value.2 state remaining + +theorem deferredOtsProbeCharge_le_queryCount (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + deferredOtsProbeCharge adversary parameter ftsSecret fuel ≤ deferredOtsQueryCount adversary parameter ftsSecret fuel := by + unfold deferredOtsProbeCharge deferredCleanRetainedRun + rw [LazyRevealProbe.expectedProbeCharge_bind_of_probeFree _ _ _ _ + (maskedPublishedTreeRoot_probeFree emptySplitHashCache)] + apply ENNReal.tsum_le_tsum + intro result + apply mul_le_mul' le_rfl + cases result with + | stopped hit => exact le_rfl + | done state remaining value => + dsimp only [LazyRevealProbe.RawResult.continuationCharge] + rw [LazyRevealProbe.expectedProbeCharge_bind_pure] + unfold deferredCleanRetainedRest + rw [← simulateQ_maskedExpanded_retainedGameRestComputation] + exact simulateQ_maskedExpanded_expectedCharge_le parameter value.1 ftsSecret _ value.2 state remaining + +theorem probEvent_sampledDeferredCleanFinish_none_le_queryCount + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[= none | sampledRunThenFinalizeClean + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) q + (deferredCleanRetainedRun adversary parameter ftsSecret)] ≤ + deferredOtsQueryCount adversary parameter ftsSecret q * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + (probEvent_sampledDeferredCleanFinish_none_le_expectedCharge adversary q hq parameter hparameter ftsSecret hfts).trans + (mul_le_mul' (deferredOtsProbeCharge_le_queryCount adversary parameter ftsSecret q) le_rfl) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeFinalization125.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeFinalization125.lean new file mode 100644 index 00000000..a28b35e7 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeFinalization125.lean @@ -0,0 +1,72 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassification + +namespace SphincsSecurity.Concrete.OtsProbeSimulation.Range125 + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +theorem relTriple_sampledMaterializedCleanUnguarded_fuelLE + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (leftFuel rightFuel : Nat) (hfuel : rightFuel ≤ leftFuel) : + RelTriple + (sampledMaterializedCleanUnguarded adversary parameter ftsSecret leftFuel) + (sampledMaterializedCleanUnguarded adversary parameter ftsSecret rightFuel) + CleanFinishFailureLE := by + unfold sampledMaterializedCleanUnguarded + apply relTriple_bind (relTriple_refl sampleOtsHashTable) + intro leftTable rightTable htable + subst rightTable + apply relTriple_bind + (relTriple_materializedCleanRetainedRunFromTable_probeLE adversary parameter ftsSecret + leftFuel rightFuel leftTable hfuel) + intro leftResult rightResult hresult + exact relTriple_finishCleanRunFromTable_probeLE leftResult rightResult hresult + +theorem probEvent_sampledMaterializedCleanUnguarded_none_fuel_mono + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (leftFuel rightFuel : Nat) (hfuel : rightFuel ≤ leftFuel) : + Pr[= none | sampledMaterializedCleanUnguarded adversary parameter ftsSecret leftFuel] ≤ + Pr[= none | sampledMaterializedCleanUnguarded adversary parameter ftsSecret rightFuel] := by + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput] + apply probEvent_le_of_relTriple + (relTriple_sampledMaterializedCleanUnguarded_fuelLE adversary parameter ftsSecret + leftFuel rightFuel hfuel) + intro left right hrelation hleft + exact hrelation hleft + +theorem probEvent_sampledMaterializedCleanUnguarded_none_le_queryBound + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hbudget : q ≤ fuel) : + Pr[= none | sampledMaterializedCleanUnguarded adversary parameter ftsSecret fuel] ≤ + (q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + (probEvent_sampledMaterializedCleanUnguarded_none_fuel_mono adversary parameter ftsSecret + fuel q hbudget).trans + (probEvent_sampledMaterializedCleanUnguarded_none_le adversary parameter ftsSecret q hbound) + +theorem probEvent_sampledDiagnostic_final_none_le_queryBound + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hbudget : q ≤ fuel) : + Pr[fun outcome => outcome.final = none | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel] ≤ + (q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + rw [probEvent_sampledObservedMaterializedDiagnostic_final_none_eq] + exact probEvent_sampledMaterializedCleanUnguarded_none_le_queryBound adversary parameter + ftsSecret fuel q hbound hbudget + +end SphincsSecurity.Concrete.OtsProbeSimulation.Range125 diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeFreshGuessRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeFreshGuessRisk.lean new file mode 100644 index 00000000..78b5f886 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeFreshGuessRisk.lean @@ -0,0 +1,186 @@ +import SphincsSecurity.Proof.OtsProbeHashRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option backward.isDefEq.respectTransparency false + +theorem resolvedContextFailureRisk_eq_finalize_coordinates + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) (coordinates : List Coordinate) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hcovered : PendingCovered coordinates context) (hnodup : coordinates.Nodup) + (hcard : context.state.pending.card < Fintype.card Digest) : + resolvedContextFailureRisk table context = + Pr[fun result => result = none | finalizeResolvedCoordinates coordinates context table] := by + have heq := (evalDist_finishResolvedRunIsNone_eq_finalize ⟨context, 0, (), table⟩ hvalid hstarts hcard).trans + (evalDist_finalizeResolvedCoordinates_eq_dynamic table coordinates context hvalid hstarts hcovered hnodup hcard).symm + have hprob := congrArg (fun distribution : SPMF Bool => distribution true) heq + change Pr[= true | _] = Pr[= true | _] at hprob + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput, probEvent_map] at hprob + simpa only [resolvedContextFailureRisk, resolvedFinalizationObserve, Function.comp_def, + Option.isNone_iff_eq_none] using hprob + +theorem completeResolved_addPending_self + (context : DeferredContext) (coordinate : Coordinate) (candidate : Digest) (output : HashOutput) : + ({ context with state := context.state.addPending coordinate candidate } : DeferredContext).completeResolved coordinate output = + context.completeResolved coordinate output := by + cases coordinate <;> + simp [DeferredContext.completeResolved, LazyRevealProbe.State.complete, LazyRevealProbe.State.addPending, + LazyRevealProbe.State.pendingAway, Finset.filter_insert] + +theorem probEvent_finalize_fresh_addPending_le + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) (position : Position) + (candidate : Digest) (remaining : List Coordinate) (hvalue : context.positionValue position = none) : + Pr[fun result => result = none | finalizeResolvedCoordinates (.position position :: remaining) + { context with state := context.state.addPending (.position position) candidate } table] ≤ + Pr[fun result => result = none | finalizeResolvedCoordinates (.position position :: remaining) context table] + + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + classical + have hnextValue : ({ context with state := context.state.addPending (.position position) candidate } : + DeferredContext).positionValue position = none := hvalue + rw [← SphincsSecurity.probEvent_uniform_truncateHash_eq candidate] + change _ ≤ _ + Pr[fun output => truncateHash output = candidate | LazyRevealProbe.sampleHashOutput] + rw [finalizeResolvedCoordinates_cons_position_of_unknown table position remaining _ hnextValue, + finalizeResolvedCoordinates_cons_position_of_unknown table position remaining context hvalue, + probEvent_bind_eq_tsum, probEvent_bind_eq_tsum, probEvent_eq_tsum_ite, ← ENNReal.tsum_add] + apply ENNReal.tsum_le_tsum + intro output + simp only [hitAt_addPending_self_iff, completeResolved_addPending_self] + by_cases hold : context.state.hitAt (.position position) output + · simp only [hold, true_or, ↓reduceIte, probEvent_pure, mul_one] + exact le_add_of_nonneg_right bot_le + · by_cases hnew : truncateHash output = candidate + · simp only [hold, hnew, false_or, ↓reduceIte, probEvent_pure, mul_one] + exact le_add_of_nonneg_left bot_le + · simp [hold, hnew] + +theorem resolvedContextFailureRisk_addPending_unknown_position + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) (position : Position) (candidate : Digest) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcard : context.state.pending.card + 1 < Fintype.card Digest) + (hvalue : context.positionValue position = none) : + resolvedContextFailureRisk table { context with state := context.state.addPending (.position position) candidate } ≤ + resolvedContextFailureRisk table context + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + classical + by_cases hcomplete : DeferredCompletable table context + · have hvalid := valid_of_resolvedCore_completable table context hconsistent hstarts hcomplete + have hmissing : context.state.values (.position position) = none := by + unfold DeferredContext.positionValue at hvalue + cases hstate : context.state.values (.position position) with + | none => rfl + | some output => simp [hstate] at hvalue + let remaining := (context.state.coordinates.erase (.position position)).toList + let coordinates := .position position :: remaining + have hnodup : coordinates.Nodup := by + exact List.nodup_cons.mpr ⟨by simp [remaining], Finset.nodup_toList _⟩ + have hmem : ∀ coordinate ∈ context.state.coordinates, coordinate ∈ coordinates := by + intro coordinate hcoordinate + by_cases heq : coordinate = .position position + · simp [coordinates, heq] + · simp [coordinates, remaining, heq, hcoordinate] + have hcovered : PendingCovered coordinates context := by + intro entry hentry + apply hmem + exact Finset.mem_union_right _ (Finset.mem_image_of_mem _ hentry) + have hnextCovered : PendingCovered coordinates + { context with state := context.state.addPending (.position position) candidate } := by + intro entry hentry + simp only [LazyRevealProbe.State.addPending, Finset.mem_insert] at hentry + rcases hentry with rfl | hentry + · simp [coordinates] + · exact hcovered entry hentry + have hnextCard : (context.state.addPending (.position position) candidate).pending.card < Fintype.card Digest := + (Finset.card_insert_le _ _).trans_lt hcard + rw [resolvedContextFailureRisk_eq_finalize_coordinates table _ coordinates + (hvalid.addPending_of_value_none _ candidate hmissing) (hstarts.addPending _ candidate) + hnextCovered hnodup hnextCard, + resolvedContextFailureRisk_eq_finalize_coordinates table context coordinates hvalid hstarts hcovered hnodup (by omega)] + exact probEvent_finalize_fresh_addPending_le table context position candidate remaining hvalue + · rw [resolvedContextFailureRisk_of_not_completable table context hcomplete] + exact (resolvedContextFailureRisk_le_one table _).trans (le_add_of_nonneg_right bot_le) + +theorem resolvedContextFailureRisk_addPending_unknown + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) (coordinate : Coordinate) (candidate : Digest) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcard : context.state.pending.card + 1 < Fintype.card Digest) + (hvalue : resolvedCompletionValue table context coordinate = none) : + resolvedContextFailureRisk table { context with state := context.state.addPending coordinate candidate } ≤ + resolvedContextFailureRisk table context + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + cases coordinate with + | chainStart => simp [resolvedCompletionValue] at hvalue + | position position => + simpa only [show Fintype.card Digest = 2 ^ digestBits by simp] using + resolvedContextFailureRisk_addPending_unknown_position table context position candidate hconsistent hstarts hcard hvalue + +noncomputable def candidateFailureAllowance + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) : Option Probe → ℝ≥0∞ + | none => 0 + | some candidate => + if candidate.coordinate ∈ context.state.revealed ∨ + (candidate.coordinate, candidate.candidate) ∈ context.state.pending then 0 + else match resolvedCompletionValue table context candidate.coordinate with + | none => ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + | some output => if truncateHash output = candidate.candidate then 1 else 0 + +theorem resolvedContextFailureRisk_afterCandidate_le + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) (candidate : Option Probe) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcard : context.state.pending.card + 1 < Fintype.card Digest) : + resolvedContextFailureRisk table (afterCandidateContext context candidate) ≤ + resolvedContextFailureRisk table context + candidateFailureAllowance table context candidate := by + classical + cases candidate with + | none => simp [afterCandidateContext, candidateFailureAllowance] + | some candidate => + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · simp [afterCandidateContext, candidateFailureAllowance, hrevealed] + · by_cases hduplicate : (candidate.coordinate, candidate.candidate) ∈ context.state.pending + · rw [resolvedContextFailureRisk_afterCandidate_of_duplicate table context candidate hduplicate] + simp [candidateFailureAllowance, hduplicate] + · simp only [afterCandidateContext, hrevealed, candidateFailureAllowance, hduplicate, or_self, ↓reduceIte] + cases hvalue : resolvedCompletionValue table context candidate.coordinate with + | none => + exact resolvedContextFailureRisk_addPending_unknown table context candidate.coordinate + candidate.candidate hconsistent hstarts hcard hvalue + | some output => + dsimp only + by_cases hhit : truncateHash output = candidate.candidate + · rw [if_pos hhit, resolvedContextFailureRisk_addPending_hit table context candidate.coordinate + candidate.candidate output hvalue hhit] + exact le_add_of_nonneg_left bot_le + · rw [if_neg hhit, resolvedContextFailureRisk_addPending_miss table context candidate.coordinate + candidate.candidate output hconsistent hstarts hvalue hhit, add_zero] + +theorem probEvent_canonicalHashQuery_finished_le_initial_add_allowance + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcard : context.state.pending.card + 1 < Fintype.card Digest) : + Pr[fun verdict => verdict = true | + canonicalChronologicalAdversaryImpl parameter root table ftsSecret (.inl (.inr input)) + context (fuel + 1) table cache >>= finishResolvedRunIsNone] ≤ + resolvedContextFailureRisk table context + candidateFailureAllowance table context + (purePlanProbingHashQuery parameter input context.state).candidate? := by + have hdist := evalDist_canonicalHashQuery_finished_eq_candidate parameter root table ftsSecret input + context fuel cache hconsistent hstarts hcard + have hprob := congrArg (fun distribution : SPMF Bool => distribution true) hdist + change Pr[= true | _] = Pr[= true | _] at hprob + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput] at hprob + exact hprob.trans_le (resolvedContextFailureRisk_afterCandidate_le table context _ hconsistent hstarts hcard) + +theorem canonicalHashQueryRejectionRisk_le_initial_add_allowance + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (entry : CanonicalQuerySelection) (input : HashInput) (hinput : entry.input = .inl (.inr input)) + (hfuel : 0 < entry.fuel) + (hconsistent : entry.context.ValuesConsistent) (hstarts : StartTableAgrees entry.context.state entry.table) + (hcard : entry.context.state.pending.card + 1 < Fintype.card Digest) : + canonicalQueryRejectionRisk parameter root ftsSecret entry ≤ + resolvedContextFailureRisk entry.table entry.context + candidateFailureAllowance entry.table entry.context + (purePlanProbingHashQuery parameter input entry.context.state).candidate? := + (canonicalHashQueryRejectionRisk_le_afterCandidate parameter root ftsSecret entry input hinput hfuel + hconsistent hstarts hcard).trans + (resolvedContextFailureRisk_afterCandidate_le entry.table entry.context _ hconsistent hstarts hcard) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeGroupedTerminal.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeGroupedTerminal.lean new file mode 100644 index 00000000..d2448a54 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeGroupedTerminal.lean @@ -0,0 +1,427 @@ +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveClean + +/-! +# Grouped one-time terminal event + +Fresh layer openings and backward chain openings both imply the same retained verifier probe. +Grouping them before the terminal union bound charges that probe event once. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +def cleanOtsOpeningEvent (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : Prop := + cleanFreshEvent parameter otsSecret ftsSecret result ∨ + cleanBackwardEvent parameter otsSecret ftsSecret result + +theorem probEvent_win_le_grouped_terminal_cases (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + let run := gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + Pr[= true | (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run' ∅] ≤ + Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache | run] + + (Pr[cleanOtsOpeningEvent parameter otsSecret ftsSecret | run] + + (Pr[cleanEncodingEvent parameter otsSecret ftsSecret | run] + + (Pr[cleanMessageEvent parameter otsSecret ftsSecret | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result | run] + + Pr[cleanUncoveredEvent parameter otsSecret ftsSecret | run])))) := by + classical + dsimp only + let run := gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + let opening := cleanOtsOpeningEvent parameter otsSecret ftsSecret + let encoding := cleanEncodingEvent parameter otsSecret ftsSecret + let message := cleanMessageEvent parameter otsSecret ftsSecret + let proper := fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result + let uncovered := cleanUncoveredEvent parameter otsSecret ftsSecret + calc + Pr[= true | (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run' ∅] = + Pr[fun result => result.1.2.2 = true | run] := by + rw [StateT.run'_eq, ← probEvent_eq_eq_probOutput, + ← gameAfterSecretsWithViewTrace_verdictCache_projection adversary parameter otsSecret + ftsSecret, probEvent_map] + rw [probEvent_map] + rfl + _ ≤ Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache ∨ + opening result ∨ encoding result ∨ message result ∨ proper result ∨ + uncovered result | run] := by + apply probEvent_mono + intro result hresult hwin + rcases gameAfterSecretsWithViewTrace_winning_terminal_classify adversary parameter + otsSecret ftsSecret result hresult hwin with hbad | hterminal + · exact Or.inl hbad + · by_cases hbad : Bad parameter otsSecret ftsSecret result.2.cache + · exact Or.inl hbad + · rcases viewedWinningTerminalWitness_cases parameter otsSecret ftsSecret result + hterminal with hfresh | hencoding | hbackward | hmessage | hproper | huncovered + · exact Or.inr (Or.inl (Or.inl ⟨⟨hbad, hwin⟩, hfresh⟩)) + · exact Or.inr (Or.inr (Or.inl ⟨hbad, hencoding⟩)) + · exact Or.inr (Or.inl (Or.inr ⟨⟨hbad, hwin⟩, hbackward⟩)) + · exact Or.inr (Or.inr (Or.inr (Or.inl ⟨hbad, hmessage⟩))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inl ⟨hbad, hproper⟩)))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr ⟨hbad, huncovered⟩)))) + _ ≤ Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache | run] + + Pr[fun result => opening result ∨ encoding result ∨ message result ∨ + proper result ∨ uncovered result | run] := probEvent_or_le _ _ _ + _ ≤ Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache | run] + + (Pr[opening | run] + + (Pr[encoding | run] + + (Pr[message | run] + + (Pr[proper | run] + Pr[uncovered | run])))) := by + gcongr + calc + _ ≤ Pr[opening | run] + + Pr[fun result => encoding result ∨ message result ∨ proper result ∨ + uncovered result | run] := probEvent_or_le _ _ _ + _ ≤ _ := by + gcongr + calc + _ ≤ Pr[encoding | run] + + Pr[fun result => message result ∨ proper result ∨ uncovered result | run] := + probEvent_or_le _ _ _ + _ ≤ _ := by + gcongr + calc + _ ≤ Pr[message | run] + + Pr[fun result => proper result ∨ uncovered result | run] := + probEvent_or_le _ _ _ + _ ≤ _ := by + gcongr + exact probEvent_or_le _ _ _ + _ = _ := by + rfl + +theorem probEvent_win_le_grouped_reserved_add_remaining + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + let run := gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + Pr[= true | (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run' ∅] ≤ + ((24 * q : Nat) : ℝ≥0∞) * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹ + + (Pr[cleanOtsOpeningEvent parameter otsSecret ftsSecret | run] + + (Pr[cleanEncodingEvent parameter otsSecret ftsSecret | run] + + (Pr[cleanMessageEvent parameter otsSecret ftsSecret | run] + + Pr[cleanUncoveredEvent parameter otsSecret ftsSecret | run]))) := by + dsimp only + let run := gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + have hgameBound := isQueryBoundP_gameAfterSecrets adversary q hq hparameter hots hfts + have hqMin := numChains_le_of_hasHashQueryBound adversary q hq parameter hparameter otsSecret + hots ftsSecret hfts + have hbad := probEvent_bad_gameAfterSecretsWithViewTrace_le adversary parameter otsSecret + ftsSecret q hgameBound + have hproper := probEvent_clean_properFewTimeLeak_le_nine_mul_inv adversary q hq hqMax + parameter hparameter otsSecret hots ftsSecret hfts + calc + _ ≤ Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache | run] + + (Pr[cleanOtsOpeningEvent parameter otsSecret ftsSecret | run] + + (Pr[cleanEncodingEvent parameter otsSecret ftsSecret | run] + + (Pr[cleanMessageEvent parameter otsSecret ftsSecret | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result | run] + + Pr[cleanUncoveredEvent parameter otsSecret ftsSecret | run])))) := + probEvent_win_le_grouped_terminal_cases adversary parameter otsSecret ftsSecret + _ ≤ (((44 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) + + (Pr[cleanOtsOpeningEvent parameter otsSecret ftsSecret | run] + + (Pr[cleanEncodingEvent parameter otsSecret ftsSecret | run] + + (Pr[cleanMessageEvent parameter otsSecret ftsSecret | run] + + (((2 * q + 1 : Nat) : ℝ≥0∞) * (9 * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹) + + Pr[cleanUncoveredEvent parameter otsSecret ftsSecret | run])))) := by + gcongr + _ = ((((44 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) + + ((2 * q + 1 : Nat) : ℝ≥0∞) * (9 * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹)) + + (Pr[cleanOtsOpeningEvent parameter otsSecret ftsSecret | run] + + (Pr[cleanEncodingEvent parameter otsSecret ftsSecret | run] + + (Pr[cleanMessageEvent parameter otsSecret ftsSecret | run] + + Pr[cleanUncoveredEvent parameter otsSecret ftsSecret | run]))) := by + ac_rfl + _ ≤ _ := by + gcongr + exact structural_add_properFewTime_le hqMin + +noncomputable def groupedRemainingRisk (adversary : Adversary) + (secrets : SampledSecrets) : ℝ≥0∞ := + let run := gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret + Pr[cleanOtsOpeningEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | run] + + (Pr[cleanEncodingEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | run] + + (Pr[cleanMessageEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | run] + + Pr[cleanUncoveredEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | run])) + +theorem weighted_groupedRemainingRisk_eq (adversary : Adversary) : + (∑' secrets : SampledSecrets, + Pr[= secrets | sampleSecrets] * groupedRemainingRisk adversary secrets) = + Pr[SampledViewedEvent cleanOtsOpeningEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanEncodingEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanMessageEvent | sampledViewedGame adversary] + + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary])) := by + simp only [groupedRemainingRisk, mul_add, ENNReal.tsum_add] + rw [← probEvent_sampledViewedGame_eq_weighted adversary cleanOtsOpeningEvent, + ← probEvent_sampledViewedGame_eq_weighted adversary cleanEncodingEvent, + ← probEvent_sampledViewedGame_eq_weighted adversary cleanMessageEvent, + ← probEvent_sampledViewedGame_eq_weighted adversary cleanUncoveredEvent] + +theorem forgeAdvantage_le_grouped_reserved_add_sampled_remaining + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) : + forgeAdvantage scheme adversary ≤ + ((24 * q : Nat) : ℝ≥0∞) * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹ + + (Pr[SampledViewedEvent cleanOtsOpeningEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanEncodingEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanMessageEvent | sampledViewedGame adversary] + + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary]))) := by + rw [forgeAdvantage_eq_sampledGame, sampledGame] + calc + _ ≤ ((24 * q : Nat) : ℝ≥0∞) * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹ + + ∑' secrets : SampledSecrets, + Pr[= secrets | sampleSecrets] * groupedRemainingRisk adversary secrets := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_const_add_weighted + (oa := sampleSecrets) + (run := fun secrets => (simulateQ romImpl + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret)).run' ∅) + (event := fun verdict => verdict = true) + (cost := ((24 * q : Nat) : ℝ≥0∞) * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹) + (groupedRemainingRisk adversary) + intro secrets hsecrets + obtain ⟨hparameter, hots, hfts⟩ := secrets.support_components hsecrets + rw [probEvent_eq_eq_probOutput] + exact probEvent_win_le_grouped_reserved_add_remaining adversary q hq hqMax + secrets.parameter hparameter secrets.otsSecret hots secrets.ftsSecret hfts + _ = _ := by rw [weighted_groupedRemainingRisk_eq] + +theorem forgeAdvantage_le_of_sampled_grouped_remaining_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) + (hremaining : + Pr[SampledViewedEvent cleanOtsOpeningEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanEncodingEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanMessageEvent | sampledViewedGame adversary] + + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary])) ≤ + ((64 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + forgeAdvantage scheme adversary ≤ q / ((2 ^ securityBits : Nat) : ℝ≥0∞) := by + calc + _ ≤ ((24 * q : Nat) : ℝ≥0∞) * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹ + + (Pr[SampledViewedEvent cleanOtsOpeningEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanEncodingEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanMessageEvent | sampledViewedGame adversary] + + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary]))) := + forgeAdvantage_le_grouped_reserved_add_sampled_remaining adversary q hq hqMax + _ ≤ ((24 * q : Nat) : ℝ≥0∞) * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹ + + ((64 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + add_le_add_right hremaining _ + _ = (q : ℝ≥0∞) * + (((24 : Nat) : ℝ≥0∞) * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹ + + ((64 : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) := by + push_cast + ring + _ = (q : ℝ≥0∞) * ((2 ^ securityBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [show securityBits = 120 by rfl, terminal_budget_remainder] + _ = q / ((2 ^ securityBits : Nat) : ℝ≥0∞) := by + rw [div_eq_mul_inv] + +namespace OtsProbeSimulation + +def WinningRetainedOtsOpeningWitness (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := + WinningRetainedWitnessFor parameter table ftsSecret + fun f cache secretKey log forgery index leaves => + ¬Bad parameter (tableOtsSecret table) ftsSecret cache ∧ + (SettledForgedFreshLayerOpening f cache secretKey log index leaves forgery.signature ∨ + SettledForgedBackwardChainOpening f cache secretKey log index leaves forgery.signature) + +theorem probEvent_cleanOtsOpening_le_actualRetained + (adversary : Adversary) (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[cleanOtsOpeningEvent parameter (tableOtsSecret table) ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter (tableOtsSecret table) ftsSecret] ≤ + Pr[WinningRetainedOtsOpeningWitness parameter table ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret table] := by + calc + _ ≤ Pr[fun result => result.1.2.2 = true ∧ + ViewedWinningTerminalWitnessFor parameter (tableOtsSecret table) ftsSecret + (fun f cache secretKey log forgery index leaves => + ¬Bad parameter (tableOtsSecret table) ftsSecret cache ∧ + (SettledForgedFreshLayerOpening f cache secretKey log index leaves + forgery.signature ∨ + SettledForgedBackwardChainOpening f cache secretKey log index leaves + forgery.signature)) result | + gameAfterSecretsWithViewTrace adversary parameter (tableOtsSecret table) + ftsSecret] := by + apply probEvent_mono + intro _ _ hevent + rcases hevent with hfresh | hbackward + · rcases hfresh with ⟨⟨hbad, hverdict⟩, f, digest, hf, hvalid, hnotContains, + hdigest, hadmissible, heval, hfresh⟩ + exact ⟨hverdict, f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, + heval, hbad, Or.inl hfresh⟩ + · rcases hbackward with ⟨⟨hbad, hverdict⟩, f, digest, hf, hvalid, hnotContains, + hdigest, hadmissible, heval, hbackward⟩ + exact ⟨hverdict, f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, + heval, hbad, Or.inr hbackward⟩ + _ ≤ _ := probEvent_viewedWinningWitness_le_actualRetained adversary parameter table ftsSecret + (fun f cache secretKey log forgery index leaves => + ¬Bad parameter (tableOtsSecret table) ftsSecret cache ∧ + (SettledForgedFreshLayerOpening f cache secretKey log index leaves forgery.signature ∨ + SettledForgedBackwardChainOpening f cache secretKey log index leaves + forgery.signature)) + +theorem winningRetainedOtsOpening_imp_verifyProbe + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : RetainedGameResult × QueryCache HashSpec) + (hwitness : WinningRetainedOtsOpeningWitness parameter table ftsSecret result) : + WinningRetainedVerifyProbeWitness parameter table ftsSecret result := by + rcases hwitness with ⟨hverdict, f, digest, hf, hvalid, hnotContains, hdigest, + hadmissible, heval, hbad, hfresh | hbackward⟩ + · exact winningRetainedFresh_imp_verifyProbe parameter table ftsSecret result + ⟨hverdict, f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, heval, + hbad, hfresh⟩ + · exact winningRetainedBackward_imp_verifyProbe parameter table ftsSecret result + ⟨hverdict, f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, heval, + hbad, hbackward⟩ + +theorem probEvent_cleanOtsOpening_le_verifyProbeAfterOtsSecret + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[cleanOtsOpeningEvent parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + Pr[WinningRetainedVerifyProbeAfterOtsSecret parameter otsSecret ftsSecret | + actualRetainedGameAfterOtsSecret adversary parameter ftsSecret otsSecret] := by + let table := tableOfOtsSecret otsSecret + calc + _ ≤ Pr[WinningRetainedOtsOpeningWitness parameter table ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret table] := by + simpa [table, tableOtsSecret_tableOfOtsSecret] using + probEvent_cleanOtsOpening_le_actualRetained adversary parameter table ftsSecret + _ ≤ Pr[WinningRetainedVerifyProbeWitness parameter table ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret table] := + probEvent_mono fun result _ => + winningRetainedOtsOpening_imp_verifyProbe parameter table ftsSecret result + _ = _ := by + rw [actualRetainedGameAfterTable_eq_afterOtsSecret] + simp only [table, tableOtsSecret_tableOfOtsSecret] + rfl + +theorem probEvent_sampledViewedGame_cleanOtsOpening_le_of_sampled + (adversary : Adversary) (bound : ℝ≥0∞) + (hsampled : ∀ parameter ∈ support sampleParameter, + ∀ ftsSecret ∈ support sampleFtsSecrets, + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ bound) : + Pr[SampledViewedEvent cleanOtsOpeningEvent | sampledViewedGame adversary] ≤ bound := by + have hrewrite : + Pr[SampledViewedEvent cleanOtsOpeningEvent | sampledViewedGame adversary] = + Pr[SampledViewedEvent cleanOtsOpeningEvent | sampledViewedGameFtsFirst adversary] := + OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + (evalDist_sampledViewedGame_eq_ftsFirst adversary) + rw [hrewrite] + unfold sampledViewedGameFtsFirst + apply probEvent_bind_le_of_forall_le + intro parameter hparameter + apply probEvent_bind_le_of_forall_le + intro ftsSecret hfts + calc + _ = Pr[fun result => cleanOtsOpeningEvent parameter result.1 ftsSecret result.2 | + sampledViewedOtsSecrets adversary parameter ftsSecret] := by + change Pr[SampledViewedEvent cleanOtsOpeningEvent | + (fun result => + (⟨⟨parameter, result.1, ftsSecret⟩, result.2⟩ : SampledViewedResult)) <$> + sampledViewedOtsSecrets adversary parameter ftsSecret] = _ + rw [probEvent_map] + rfl + _ ≤ Pr[fun result => WinningRetainedVerifyProbeAfterOtsSecret parameter result.1 + ftsSecret result.2 | + sampledActualRetainedOtsSecrets adversary parameter ftsSecret] := by + unfold sampledViewedOtsSecrets sampledActualRetainedOtsSecrets + apply probEvent_bind_le_bind_of_forall_le + intro otsSecret _hots + simpa [probEvent_map, Function.comp_def] using + probEvent_cleanOtsOpening_le_verifyProbeAfterOtsSecret adversary parameter otsSecret + ftsSecret + _ = Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] := + (probEvent_sampledWinningRetainedVerifyProbe_eq_secrets adversary parameter ftsSecret).symm + _ ≤ bound := hsampled parameter hparameter ftsSecret hfts + +theorem security_of_sampledWinningRetainedVerifyProbe_grouped_le_mul + (c : Nat) (hc : c + 46 ≤ 64) + (hprobe : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ securityBits → + ∀ parameter ∈ support sampleParameter, + ∀ ftsSecret ∈ support sampleFtsSecrets, + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + ((c * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + SphincsSecurityStatement := by + intro q hqPos adversary hq + by_cases hqMax : q ≤ 2 ^ securityBits + · have hqMax120 : q ≤ 2 ^ 120 := by simpa only [securityBits] using hqMax + let unitBound := (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + let probeBound := ((c * q : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + have hsampled : ∀ parameter ∈ support sampleParameter, + ∀ ftsSecret ∈ support sampleFtsSecrets, + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ probeBound := by + intro parameter hparameter ftsSecret hfts + exact hprobe q hqPos adversary hq hqMax parameter hparameter ftsSecret hfts + have hopening : + Pr[SampledViewedEvent cleanOtsOpeningEvent | sampledViewedGame adversary] ≤ + probeBound := + probEvent_sampledViewedGame_cleanOtsOpening_le_of_sampled adversary probeBound hsampled + have hencoding : + Pr[SampledViewedEvent cleanEncodingEvent | sampledViewedGame adversary] ≤ + ((44 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + probEvent_sampled_cleanEncoding_le adversary q hq + have hmessage : + Pr[SampledViewedEvent cleanMessageEvent | sampledViewedGame adversary] ≤ unitBound := by + apply (probEvent_sampled_cleanMessage_le adversary q hqPos hq hqMax120).trans + dsimp only [unitBound] + rw [mul_comm (q : ℝ≥0∞), mul_comm (q : ℝ≥0∞)] + apply mul_le_mul_left + rw [show digestBits = 128 by rfl] + norm_num + have huncovered : + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary] ≤ + unitBound := + FtsProbeSimulation.probEvent_sampledViewedGame_cleanUncovered_le adversary q hq + apply forgeAdvantage_le_of_sampled_grouped_remaining_le adversary q hq hqMax120 + calc + _ ≤ probeBound + + (((44 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + (unitBound + unitBound)) := + add_le_add hopening (add_le_add hencoding (add_le_add hmessage huncovered)) + _ = (((c + 46) * q : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + simp only [probeBound, unitBound] + push_cast + ring + _ ≤ ((64 * q : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + gcongr + · exact forgeAdvantage_le_of_security_pow_le adversary q (by omega) + +end OtsProbeSimulation + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeGuardedStartRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeGuardedStartRisk.lean new file mode 100644 index 00000000..1a42545f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeGuardedStartRisk.lean @@ -0,0 +1,83 @@ +import SphincsSecurity.Proof.OtsProbeSampledGuessRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 100000 +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable + +theorem probEvent_completedStartTable_not_completable_le + (context : DeferredContext) (hvalid : context.Valid) (hprivate : ¬PrivateStructuralHit context) + (hcard : context.state.pending.card < Fintype.card Digest) : + Pr[fun base => ¬DeferredCompletable (completedStartTable context.state base) context | sampleOtsHashTable] ≤ + (context.state.pending.card : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply le_trans ?_ (probEvent_missingChainStartHit_completedStartTable_le context) + apply probEvent_mono + intro base _hbase hnot + exact Classical.byContradiction fun hmissing => + hnot (deferredCompletable_of_valid_of_no_boundary_hit _ context hvalid + (startTableAgrees_completedStartTable context.state base) hprivate hmissing hcard) + +theorem probEvent_completedStartTable_completable_ge_three_quarters + (context : DeferredContext) (hvalid : context.Valid) (hprivate : ¬PrivateStructuralHit context) + (hcard : context.state.pending.card ≤ 2 ^ 126) : + (3 / 4 : ℝ≥0∞) ≤ + Pr[fun base => DeferredCompletable (completedStartTable context.state base) context | sampleOtsHashTable] := by + have hspace : 2 ^ 126 < Fintype.card Digest := by norm_num [digestBits] + have hbad := probEvent_completedStartTable_not_completable_le context hvalid hprivate (hcard.trans_lt hspace) + have hquarter : Pr[fun base => ¬DeferredCompletable (completedStartTable context.state base) context | + sampleOtsHashTable] ≤ (1 / 4 : ℝ≥0∞) := by + apply hbad.trans + calc + _ ≤ ((2 ^ 126 : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + mul_le_mul_left (Nat.cast_le.mpr hcard) _ + _ = _ := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + norm_num [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_div, digestBits] + have hgood := probEvent_one_sub_le_of_compl_le (by simp : Pr[⊥ | sampleOtsHashTable] = 0) hquarter + have hsum : (1 : ℝ≥0∞) ≤ + Pr[fun base => DeferredCompletable (completedStartTable context.state base) context | sampleOtsHashTable] + 1 / 4 := + tsub_le_iff_right.mp hgood + have hreal := (ENNReal.toReal_le_toReal (by finiteness) + (ENNReal.add_ne_top.mpr ⟨probEvent_ne_top, by finiteness⟩)).mpr hsum + apply (ENNReal.toReal_le_toReal (by finiteness) probEvent_ne_top).mp + rw [ENNReal.toReal_add probEvent_ne_top (by finiteness)] at hreal + norm_num [ENNReal.toReal_div] at hreal ⊢ + linarith + +theorem expected_guarded_chainStart_allowance_le_four_thirds + (context : DeferredContext) (index : OtsSecretIndex) (digest : Digest) + (hmissing : context.state.values index.coordinate = none) + (hvalid : context.Valid) (hprivate : ¬PrivateStructuralHit context) + (hcard : context.state.pending.card ≤ 2 ^ 126) : + (∑' base, Pr[= base | sampleOtsHashTable] * + if DeferredCompletable (completedStartTable context.state base) context then + candidateFailureAllowance (completedStartTable context.state base) context (some ⟨index.coordinate, digest⟩) + else 0) ≤ + ((unmaterializedCandidateCharge (materializedDeferredState context) (some ⟨index.coordinate, digest⟩) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) * (4 / 3) * + Pr[fun base => DeferredCompletable (completedStartTable context.state base) context | sampleOtsHashTable] := by + classical + let charge : ℝ≥0∞ := + (unmaterializedCandidateCharge (materializedDeferredState context) (some ⟨index.coordinate, digest⟩) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + calc + _ ≤ ∑' base, Pr[= base | sampleOtsHashTable] * + candidateFailureAllowance (completedStartTable context.state base) context (some ⟨index.coordinate, digest⟩) := by + apply ENNReal.tsum_le_tsum + intro base + apply mul_le_mul_right + split_ifs <;> first | exact le_rfl | exact bot_le + _ ≤ charge := expected_candidateFailureAllowance_chainStart_of_missing context index digest hmissing + _ = charge * (4 / 3) * (3 / 4) := by + have hfactor : (4 / 3 : ℝ≥0∞) * (3 / 4) = 1 := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + norm_num [ENNReal.toReal_mul, ENNReal.toReal_div] + rw [mul_assoc, hfactor, mul_one] + _ ≤ _ := mul_le_mul_right + (probEvent_completedStartTable_completable_ge_three_quarters context hvalid hprivate hcard) _ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeGuardedTraceRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeGuardedTraceRisk.lean new file mode 100644 index 00000000..5c7f0b3c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeGuardedTraceRisk.lean @@ -0,0 +1,115 @@ +import SphincsSecurity.Proof.OtsProbeGuardedStartRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot sampleOtsHashTable +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +set_option maxRecDepth 100000 in +theorem valid_no_privateHit_of_mem_canonicalQueryTrace + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (result : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) + (hrun : result ∈ support (runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache)) : + ∀ entry ∈ result.2, entry.context.Valid ∧ ¬PrivateStructuralHit entry.context := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache result with + | pure value => + simp only [runCanonicalQueryTrace, OracleComp.construct_pure] at hrun + split_ifs at hrun <;> simp only [mem_support_pure_iff] at hrun <;> subst result <;> simp + | query_bind input next ih => + rw [runCanonicalQueryTrace_query_bind] at hrun + split_ifs at hrun with hcomplete + · have hcurrent : context.Valid ∧ ¬PrivateStructuralHit context := by + refine ⟨valid_of_resolvedCore_completable table context hconsistent hstarts hcomplete, ?_⟩ + obtain ⟨completion, hcompletion⟩ := hcomplete + exact hcompletion.not_privateStructuralHit + rw [mem_support_bind_iff] at hrun + obtain ⟨stepOption, hstep, hrun⟩ := hrun + cases stepOption with + | none => + simp only [pure_bind, mem_support_pure_iff] at hrun + subst result + intro entry hentry + simp only [List.mem_singleton] at hentry + subst entry + exact hcurrent + | some step => + rw [mem_support_bind_iff] at hrun + obtain ⟨tail, htail, hpure⟩ := hrun + simp only [mem_support_pure_iff] at hpure + subst result + have hcore := resolvedCore_of_mem_canonicalChronologicalAdversaryImpl parameter root table ftsSecret + input context fuel cache step hconsistent hstarts hstep + intro entry hentry + rcases List.mem_cons.mp hentry with heq | htailEntry + · subst entry + exact hcurrent + · rw [hcore.1] at htail + exact ih step.value.1 step.context step.remaining table step.value.2 hcore.2.1 hcore.2.2 + tail htail entry htailEntry + · simp only [mem_support_pure_iff] at hrun + subst result + simp + +theorem valid_no_privateHit_of_mem_canonicalRetainedQueryTrace + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (result : Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)) × List CanonicalQuerySelection) + (hrun : result ∈ support (canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel)) : + ∀ entry ∈ result.2, entry.context.Valid ∧ ¬PrivateStructuralHit entry.context := by + rw [canonicalRetainedQueryTrace, mem_support_bind_iff] at hrun + obtain ⟨rootOption, hroot, hrun⟩ := hrun + cases rootOption with + | none => + simp only [mem_support_pure_iff] at hrun + subst result + simp + | some root => + rw [mem_support_bind_iff] at hrun + obtain ⟨rest, hrest, hpure⟩ := hrun + simp only [mem_support_pure_iff] at hpure + subst result + have hcore := resolvedCore_of_mem_runResolvedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table root (by intro coordinate output hvalue; simp [LazyRevealProbe.State.empty] at hvalue) + (by intro index output hvalue; simp [LazyRevealProbe.State.empty] at hvalue) hroot + rw [hcore.1] at hrest + exact valid_no_privateHit_of_mem_canonicalQueryTrace parameter root.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨root.value.1, parameter⟩) + root.context root.remaining table root.value.2 hcore.2.1 hcore.2.2 rest hrest + +theorem expected_guarded_chainStart_allowance_le_of_coupled_retainedTrace + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) (fuel : Nat) + (left : Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)) × List CanonicalQuerySelection) + (right : (RetainedGameResult × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hleft : left ∈ support (canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel)) + (hright : right ∈ support (prehitRetainedQueryTrace adversary parameter table ftsSecret)) + (hrelation : CanonicalQueryTraceRel parameter table left right) + (ordinal : Nat) (entry : CanonicalQuerySelection) (hentry : left.2[ordinal]? = some entry) + (index : OtsSecretIndex) (digest : Digest) (hmissing : entry.context.state.values index.coordinate = none) : + (∑' base, Pr[= base | sampleOtsHashTable] * + if DeferredCompletable (completedStartTable entry.context.state base) entry.context then + candidateFailureAllowance (completedStartTable entry.context.state base) entry.context + (some ⟨index.coordinate, digest⟩) + else 0) ≤ + ((unmaterializedCandidateCharge (materializedDeferredState entry.context) + (some ⟨index.coordinate, digest⟩) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) * (4 / 3) * + Pr[fun base => DeferredCompletable (completedStartTable entry.context.state base) entry.context | + sampleOtsHashTable] := by + have hclean := valid_no_privateHit_of_mem_canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel + left hleft entry (List.mem_iff_getElem?.mpr ⟨ordinal, hentry⟩) + have hcard := pending_card_le_of_coupled_canonicalRetainedTrace adversary q hq parameter hparameter table ftsSecret + hfts fuel left right hleft hright hrelation ordinal entry hentry + exact expected_guarded_chainStart_allowance_le_four_thirds entry.context index digest hmissing + hclean.1 hclean.2 (hcard.trans hqMax) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHashCutCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHashCutCharge.lean new file mode 100644 index 00000000..2c8c95ab --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHashCutCharge.lean @@ -0,0 +1,301 @@ +import SphincsSecurity.Proof.OtsProbeHashCutRisk +import SphincsSecurity.Proof.OtsProbeCanonicalCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +noncomputable def canonicalHashOrdinalCharge + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + Nat → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → ENNReal := + OracleComp.construct (fun _ _ _ _ _ _ => 0) + (fun input _ next ordinal context fuel table cache => + if DeferredCompletable table context then + if IsOuterHash input ∧ ordinal = 0 then charge input context fuel cache + else ∑' result, Pr[= result | canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache] * + match result with + | none => 0 + | some result => + next result.value.1 (if IsOuterHash input then ordinal - 1 else ordinal) + result.context result.remaining result.table result.value.2 + else 0) computation + +theorem canonicalHashOrdinalCharge_query_bind + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + canonicalHashOrdinalCharge parameter root ftsSecret charge (OracleSpec.query input >>= next) ordinal context fuel table cache = + (if DeferredCompletable table context then + if IsOuterHash input ∧ ordinal = 0 then charge input context fuel cache + else ∑' result, Pr[= result | canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache] * + match result with + | none => 0 + | some result => + canonicalHashOrdinalCharge parameter root ftsSecret charge (next result.value.1) + (if IsOuterHash input then ordinal - 1 else ordinal) result.context result.remaining result.table result.value.2 + else 0) := by + rfl + +theorem sum_canonicalHashOrdinalCharge_le_expected + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + (∑ ordinal ∈ Finset.range q, canonicalHashOrdinalCharge parameter root ftsSecret charge computation ordinal context fuel table cache) ≤ + expectedCanonicalQueryCharge parameter root ftsSecret charge computation context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing q context fuel table cache with + | pure value => simp [canonicalHashOrdinalCharge, expectedCanonicalQueryCharge] + | query_bind input next ih => + rw [expectedCanonicalQueryCharge_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete] + have htail (n : Nat) : + (∑ ordinal ∈ Finset.range n, ∑' result, + Pr[= result | canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache] * + match result with + | none => 0 + | some result => + canonicalHashOrdinalCharge parameter root ftsSecret charge (next result.value.1) + ordinal result.context result.remaining result.table result.value.2) ≤ + ∑' result, Pr[= result | canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache] * + match result with + | none => 0 + | some result => + expectedCanonicalQueryCharge parameter root ftsSecret charge (next result.value.1) + result.context result.remaining result.table result.value.2 := by + rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + apply ENNReal.tsum_le_tsum + intro option + cases option with + | none => simp + | some result => + simp only [← Finset.mul_sum] + exact mul_le_mul' le_rfl (ih result.value.1 n result.context result.remaining result.table result.value.2) + by_cases hhash : IsOuterHash input + · cases q with + | zero => simp + | succ q => + rw [Finset.sum_range_succ'] + simp only [canonicalHashOrdinalCharge_query_bind, if_pos hcomplete, hhash, Nat.add_eq_zero_iff, + Nat.one_ne_zero, and_false, if_false, Nat.add_sub_cancel, and_self, if_true] + exact (add_le_add (htail q) (le_refl (charge input context fuel cache))).trans_eq (add_comm _ _) + · simp only [canonicalHashOrdinalCharge_query_bind, if_pos hcomplete, hhash, false_and, if_false] + exact (htail q).trans (le_add_of_nonneg_left bot_le) + · simp [canonicalHashOrdinalCharge_query_bind, hcomplete] + +noncomputable def cutQueryCharge + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) : + Option (ResolvedRunResult (OuterQueryCut α × SplitHashCache)) → ENNReal + | none => 0 + | some result => + match result.value.1.input? with + | none => 0 + | some input => charge input result.context result.remaining result.value.2 + +theorem runSynchronizedCanonical_query_bind + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (OracleSpec.query input >>= next) context fuel table cache = + (if DeferredCompletable table context then do + let step ← canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache + match step with + | none => pure none + | some result => + runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (next result.value.1) result.context result.remaining result.table result.value.2 + else pure none) := by + rw [runSynchronizedResolved, OracleComp.construct_query_bind] + split_ifs + · apply bind_congr + intro option + cases option <;> rfl + · rfl + +theorem expected_hashCut_eq_canonicalHashOrdinalCharge + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (computation : OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + (∑' result, Pr[= result | runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (outerHashQueryCutAt computation ordinal) context fuel table cache] * cutQueryCharge charge result) = + canonicalHashOrdinalCharge parameter root ftsSecret charge computation ordinal context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing ordinal context fuel table cache with + | pure value => + by_cases hcomplete : DeferredCompletable table context <;> + simp [outerHashQueryCutAt, runSynchronizedResolved, hcomplete, canonicalHashOrdinalCharge, cutQueryCharge, OuterQueryCut.input?] + | query_bind input next ih => + rw [canonicalHashOrdinalCharge_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete] + have htail (n : Nat) : + (∑' final, Pr[= final | (do + let step ← canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache + match step with + | none => pure none + | some result => + runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (outerHashQueryCutAt (next result.value.1) n) result.context result.remaining result.table result.value.2)] * + cutQueryCharge charge final) = + ∑' result, Pr[= result | canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache] * + match result with + | none => 0 + | some result => + canonicalHashOrdinalCharge parameter root ftsSecret charge (next result.value.1) n + result.context result.remaining result.table result.value.2 := by + rw [tsum_probOutput_bind_mul] + apply tsum_congr + intro option + by_cases hsupport : option ∈ support + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache) + · cases option with + | none => simp [cutQueryCharge] + | some result => + have hcore := resolvedCore_of_mem_canonicalChronologicalAdversaryImpl parameter root table ftsSecret input + context fuel cache result hconsistent hstarts hsupport + dsimp only + rw [hcore.1] + rw [ih result.value.1 n result.context result.remaining table result.value.2 hcore.2.1 hcore.2.2] + · simp [probOutput_eq_zero_of_not_mem_support hsupport] + rw [outerHashQueryCutAt_query_bind] + by_cases hhash : IsOuterHash input + · rw [if_pos hhash] + cases ordinal with + | zero => simp [runSynchronizedResolved_pure _ _ _ _ _ _ hcomplete, cutQueryCharge, OuterQueryCut.input?, hhash] + | succ ordinal => + rw [runSynchronizedCanonical_query_bind, if_pos hcomplete] + simpa only [hhash, true_and, Nat.succ_ne_zero, if_false, if_true, Nat.add_sub_cancel] using htail ordinal + · rw [if_neg hhash, runSynchronizedCanonical_query_bind, if_pos hcomplete] + simpa only [hhash, false_and, if_false] using htail ordinal + · rw [if_neg hcomplete, runSynchronizedResolved_of_not_completable _ _ context fuel table cache hcomplete] + simp [cutQueryCharge] + +theorem sum_expected_hashCut_le_canonicalQueryCharge + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (computation : OracleComp (OracleWorld + SigningSpec) α) (q : Nat) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + (∑ ordinal ∈ Finset.range q, ∑' result, + Pr[= result | runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (outerHashQueryCutAt computation ordinal) context fuel table cache] * cutQueryCharge charge result) ≤ + expectedCanonicalQueryCharge parameter root ftsSecret charge computation context fuel table cache := by + simp_rw [expected_hashCut_eq_canonicalHashOrdinalCharge parameter root ftsSecret charge computation _ context fuel table cache + hconsistent hstarts] + exact sum_canonicalHashOrdinalCharge_le_expected parameter root ftsSecret charge computation q context fuel table cache + +noncomputable def sampledCanonicalAccumulatedCharge + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) : ENNReal := + ∑' table, Pr[= table | sampleOtsHashTable] * + ∑' option, Pr[= option | runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)] * + match option with + | none => 0 + | some result => + expectedCanonicalQueryCharge parameter result.value.1 ftsSecret charge (continuation result.value.1) + result.context result.remaining result.table result.value.2 + +theorem sum_expected_sampledHashCut_le_accumulatedCharge + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) : + (∑ ordinal ∈ Finset.range q, ∑' result, + Pr[= result | sampledCanonicalHashCut parameter ftsSecret fuel continuation ordinal] * cutQueryCharge charge result) ≤ + sampledCanonicalAccumulatedCharge parameter ftsSecret fuel continuation charge := by + have hcost (ordinal : Nat) : + (∑' result, Pr[= result | sampledCanonicalHashCut parameter ftsSecret fuel continuation ordinal] * cutQueryCharge charge result) = + ∑' table, Pr[= table | sampleOtsHashTable] * + ∑' option, Pr[= option | runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)] * + match option with + | none => 0 + | some result => + ∑' final, Pr[= final | runSynchronizedResolved + (canonicalChronologicalAdversaryImpl parameter result.value.1 table ftsSecret) + (outerHashQueryCutAt (continuation result.value.1) ordinal) result.context result.remaining table result.value.2] * + cutQueryCharge charge final := by + have hdist := evalDist_sampledCanonicalHashCut_eq_original parameter ftsSecret fuel continuation ordinal + simp_rw [_root_.OracleComp.probOutput_congr rfl hdist] + simp only [tsum_probOutput_bind_mul] + apply tsum_congr + intro table + congr 1 + apply tsum_congr + intro option + cases option <;> simp [cutQueryCharge] + simp_rw [hcost] + rw [sampledCanonicalAccumulatedCharge, ← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + apply ENNReal.tsum_le_tsum + intro table + rw [← Finset.mul_sum] + apply mul_le_mul' le_rfl _ + rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + apply ENNReal.tsum_le_tsum + intro option + rw [← Finset.mul_sum] + by_cases hsupport : option ∈ support (runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)) + · cases option with + | none => simp + | some result => + apply mul_le_mul' le_rfl _ + have hcore := resolvedCore_of_mem_runResolved_maskedPublishedTreeRoot parameter table fuel result hsupport + dsimp only + rw [hcore.1] + exact sum_expected_hashCut_le_canonicalQueryCharge parameter result.value.1 ftsSecret charge + (continuation result.value.1) q result.context result.remaining table result.value.2 hcore.2.1 hcore.2.2 + · simp [probOutput_eq_zero_of_not_mem_support hsupport] + +noncomputable def unresolvedStartOuterCharge (parameter : PublicParameter) : + (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal + | .inl (.inr input), context, _, _ => + unresolvedStartCandidateCharge context (purePlanProbingHashQuery parameter input context.state).candidate? + | _, _, _, _ => 0 + +theorem cutQueryCharge_unresolvedStart + (parameter : PublicParameter) (result : Option (ResolvedRunResult (OuterQueryCut α × SplitHashCache))) : + cutQueryCharge (unresolvedStartOuterCharge parameter) result = historyUnresolvedStartCharge (hashCutCandidate parameter) result := by + cases result with + | none => rfl + | some result => + cases hcut : result.value.1 with + | done value => simp [cutQueryCharge, historyUnresolvedStartCharge, hashCutCandidate, hcut, OuterQueryCut.input?, unresolvedStartCandidateCharge] + | query input next => + cases input with + | inl query => + cases query <;> simp [cutQueryCharge, historyUnresolvedStartCharge, hashCutCandidate, hcut, OuterQueryCut.input?, + unresolvedStartOuterCharge, unresolvedStartCandidateCharge] + | inr message => + simp [cutQueryCharge, historyUnresolvedStartCharge, hashCutCandidate, hcut, OuterQueryCut.input?, + unresolvedStartOuterCharge, unresolvedStartCandidateCharge] + +theorem sum_hashCut_unresolvedStart_le_accumulatedCharge + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) (hq : q ≤ 2 ^ 126) : + (∑ ordinal ∈ Finset.range q, Pr[LiveUnresolvedStartHit (hashCutCandidate parameter) | + sampledCanonicalHashCut parameter ftsSecret fuel continuation ordinal]) ≤ + sampledCanonicalAccumulatedCharge parameter ftsSecret fuel continuation (unresolvedStartOuterCharge parameter) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + have hcharge := sum_expected_sampledHashCut_le_accumulatedCharge parameter ftsSecret fuel q continuation + (unresolvedStartOuterCharge parameter) + simp_rw [cutQueryCharge_unresolvedStart] at hcharge + exact (sum_sampledCanonicalHashCut_unresolvedStart_le parameter ftsSecret fuel q continuation hq).trans + (add_le_add (mul_le_mul' hcharge le_rfl) le_rfl) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHashCutReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHashCutReserve.lean new file mode 100644 index 00000000..a4b1d168 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHashCutReserve.lean @@ -0,0 +1,61 @@ +import SphincsSecurity.Proof.OtsProbeWeightedReserve + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +noncomputable def sampledHashCutUnresolvedStartRisk (adversary : Adversary) (fuel q : Nat) : ENNReal := + ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + ∑ ordinal ∈ Finset.range q, Pr[LiveUnresolvedStartHit (hashCutCandidate parameter) | + sampledCanonicalHashCut parameter ftsSecret fuel + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩) ordinal] + +private theorem expected_affine (computation : ProbComp α) (cost : α → ENNReal) (factor error : ENNReal) : + (∑' result, Pr[= result | computation] * (cost result * factor + error)) = + (∑' result, Pr[= result | computation] * cost result) * factor + error := by + simp_rw [mul_add, ← mul_assoc] + rw [ENNReal.tsum_add, ENNReal.tsum_mul_right, ENNReal.tsum_mul_right, + tsum_probOutput_eq_one' (by simp), one_mul] + +theorem sampledHashCutUnresolvedStartRisk_le_charge + (adversary : Adversary) (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + sampledHashCutUnresolvedStartRisk adversary fuel q ≤ + sampledCanonicalCharge unresolvedStartOuterCharge adversary fuel * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + rw [sampledCanonicalCharge_eq_accumulated] + unfold sampledHashCutUnresolvedStartRisk + rw [← expected_affine] + apply ENNReal.tsum_le_tsum + intro parameter + apply mul_le_mul' le_rfl + rw [← expected_affine] + apply ENNReal.tsum_le_tsum + intro ftsSecret + exact mul_le_mul' le_rfl (sum_hashCut_unresolvedStart_le_accumulatedCharge parameter ftsSecret fuel q + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩) hq) + +theorem sampledHashCutUnresolvedStartRisk_add_components_le_refinedReserve + (adversary : Adversary) (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + sampledHashCutUnresolvedStartRisk adversary fuel q + + sampledCanonicalCharge unresolvedPositionOuterCharge adversary fuel * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + sampledCanonicalCharge materializedOuterCandidateCharge adversary fuel * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) ≤ + sampledQueryCharge otsOpeningRefinedQueryReserve adversary * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ (sampledCanonicalCharge unresolvedStartOuterCharge adversary fuel * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹) + + sampledCanonicalCharge unresolvedPositionOuterCharge adversary fuel * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + sampledCanonicalCharge materializedOuterCandidateCharge adversary fuel * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := + add_le_add (add_le_add (sampledHashCutUnresolvedStartRisk_le_charge adversary fuel q hq) le_rfl) le_rfl + _ = (sampledCanonicalCharge unresolvedStartOuterCharge adversary fuel * (4 / 3) + + sampledCanonicalCharge unresolvedPositionOuterCharge adversary fuel + + sampledCanonicalCharge materializedOuterCandidateCharge adversary fuel * (4 / 3)) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by ring + _ ≤ _ := add_le_add (mul_le_mul' (sampledCanonical_components_le_refinedReserve adversary fuel) le_rfl) le_rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHashCutRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHashCutRisk.lean new file mode 100644 index 00000000..fb9dd9f7 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHashCutRisk.lean @@ -0,0 +1,77 @@ +import SphincsSecurity.Proof.OtsProbeHistoryRootSampling +import SphincsSecurity.Proof.OuterHashQueryCut + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +noncomputable def sampledCanonicalHashCut + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) : + ProbComp (Option (ResolvedRunResult (OuterQueryCut α × SplitHashCache))) := + Prod.fst <$> sampledCanonicalAfterRootTrace parameter ftsSecret fuel fun root => outerHashQueryCutAt (continuation root) ordinal + +theorem probEvent_sampledCanonicalHashCut_unresolvedStart_le + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) + (hordinal : ordinal ≤ 2 ^ 126) : + Pr[LiveUnresolvedStartHit (hashCutCandidate parameter) | sampledCanonicalHashCut parameter ftsSecret fuel continuation ordinal] ≤ + (∑' result, Pr[= result | sampledCanonicalHashCut parameter ftsSecret fuel continuation ordinal] * + historyUnresolvedStartCharge (hashCutCandidate parameter) result) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + exact probEvent_sampledCanonicalAfterRoot_unresolvedStart_le parameter ftsSecret fuel ordinal + (fun root => outerHashQueryCutAt (continuation root) ordinal) (hashCutCandidate parameter) + (fun root => outerHashQueryCutAt_hashBound (continuation root) ordinal) hordinal + +theorem sum_sampledCanonicalHashCut_unresolvedStart_le + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) (hq : q ≤ 2 ^ 126) : + (∑ ordinal ∈ Finset.range q, Pr[LiveUnresolvedStartHit (hashCutCandidate parameter) | + sampledCanonicalHashCut parameter ftsSecret fuel continuation ordinal]) ≤ + (∑ ordinal ∈ Finset.range q, ∑' result, + Pr[= result | sampledCanonicalHashCut parameter ftsSecret fuel continuation ordinal] * + historyUnresolvedStartCharge (hashCutCandidate parameter) result) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ ∑ ordinal ∈ Finset.range q, + ((∑' result, Pr[= result | sampledCanonicalHashCut parameter ftsSecret fuel continuation ordinal] * + historyUnresolvedStartCharge (hashCutCandidate parameter) result) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + ((2 ^ 216 : Nat) : ENNReal)⁻¹) := by + apply Finset.sum_le_sum + intro ordinal hmem + exact probEvent_sampledCanonicalHashCut_unresolvedStart_le parameter ftsSecret fuel continuation ordinal + ((Nat.le_of_lt (Finset.mem_range.mp hmem)).trans hq) + _ = _ := by simp [Finset.sum_add_distrib, Finset.sum_mul] + +theorem evalDist_sampledCanonicalHashCut_eq_original + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) : + evalDist (sampledCanonicalHashCut parameter ftsSecret fuel continuation ordinal) = + evalDist (do + let table ← sampleOtsHashTable + let option ← runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + match option with + | none => pure none + | some result => + runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter result.value.1 table ftsSecret) + (outerHashQueryCutAt (continuation result.value.1) ordinal) result.context result.remaining table result.value.2) := by + simp only [sampledCanonicalHashCut, sampledCanonicalAfterRootTrace, canonicalStartErasureAfterRoot, map_bind] + apply evalDist_bind_congr + intro table _ + apply evalDist_bind_congr + intro option hoption + cases option with + | none => simp + | some result => + have hcore := resolvedCore_of_mem_runResolved_maskedPublishedTreeRoot parameter table fuel result hoption + exact runCanonicalStartErasureTrace_projection parameter result.value.1 table ftsSecret + (outerHashQueryCutAt (continuation result.value.1) ordinal) result.context result.remaining result.value.2 + false hcore.2.1 hcore.2.2 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHashRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHashRisk.lean new file mode 100644 index 00000000..a8200112 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHashRisk.lean @@ -0,0 +1,254 @@ +import SphincsSecurity.Proof.OtsProbeProbeFreeRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option backward.isDefEq.respectTransparency false + +theorem evalDist_runResolvedFinishIsNone_probeFree_of_core + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (value : β) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcard : context.state.pending.card < Fintype.card Digest) : + evalDist (runResolvedFinishIsNone context fuel table computation) = + evalDist (finishResolvedRunIsNone (some ⟨context, fuel, value, table⟩)) := by + by_cases hcomplete : DeferredCompletable table context + · rw [finishResolvedRunIsNone_some_eq_finalize _ hcomplete] + exact evalDist_runResolvedFinishIsNone_of_probeFree computation context fuel table hbound + (valid_of_resolvedCore_completable table context hconsistent hstarts hcomplete) hstarts hcard + · rw [runResolvedFinishIsNone, + evalDist_runResolvedFinishIsNone_eq_true_of_not_completable context fuel table computation hconsistent hstarts hcomplete] + simp [finishResolvedRunIsNone, finishResolvedRun, hcomplete] + +theorem evalDist_runResolvedFinishIsNone_bind_of_probeFree + (left : OracleComp (LazyRevealProbe.World Coordinate) α) + (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hbound : ∀ value, (next value).IsQueryBoundP LazyRevealProbe.IsProbe 0) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcard : ∀ result, some result ∈ support (runResolvedFromTable context fuel table left) → + result.context.state.pending.card < Fintype.card Digest) : + evalDist (runResolvedFinishIsNone context fuel table (left >>= next)) = + evalDist (runResolvedFinishIsNone context fuel table left) := by + rw [runResolvedFinishIsNone, runResolvedFromTable_bind, bind_assoc, runResolvedFinishIsNone] + apply evalDist_bind_congr + intro option hoption + cases option with + | none => simp [finishResolvedRunIsNone, finishResolvedRun] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable left context fuel table result hconsistent hstarts hoption + exact evalDist_runResolvedFinishIsNone_probeFree_of_core (next result.value) + result.context result.remaining result.table result.value (hbound result.value) + hcore.2.1 (hcore.1 ▸ hcore.2.2) (hcard result hoption) + +noncomputable def afterCandidateContext (context : DeferredContext) : Option Probe → DeferredContext + | none => context + | some candidate => if candidate.coordinate ∈ context.state.revealed then context + else { context with state := context.state.addPending candidate.coordinate candidate.candidate } + +theorem runResolvedFromTable_executeCandidate_positive + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) (candidate : Option Probe) : + runResolvedFromTable context (fuel + 1) table ((executeCandidate? candidate).run cache) = + pure (some ⟨afterCandidateContext context candidate, + if candidate.isSome then fuel else fuel + 1, ((), cache), table⟩) := by + cases candidate with + | none => simp [executeCandidate?, afterCandidateContext, runResolvedFromTable] + | some candidate => + change runResolvedFromTable context (fuel + 1) table + (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate >>= fun _ => pure ((), cache)) = _ + rw [LazyRevealProbe.probeQuery, runResolvedFromTable_probe_query_bind] + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed <;> + simp [hrevealed, afterCandidateContext, runResolvedFromTable] + +theorem afterCandidateContext_pending_card_le (context : DeferredContext) (candidate : Option Probe) : + (afterCandidateContext context candidate).state.pending.card ≤ context.state.pending.card + 1 := by + cases candidate with + | none => exact Nat.le_succ _ + | some candidate => + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · simpa only [afterCandidateContext, hrevealed, ↓reduceIte] using Nat.le_succ context.state.pending.card + · simpa only [afterCandidateContext, hrevealed, ↓reduceIte, LazyRevealProbe.State.addPending] using + Finset.card_insert_le (candidate.coordinate, candidate.candidate) context.state.pending + +theorem finishResolvedRunIsNone_metadata_eq + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) + (fuel remaining : Nat) (value : α) (other : β) : + finishResolvedRunIsNone (some ⟨context, fuel, value, table⟩) = + finishResolvedRunIsNone (some ⟨context, remaining, other, table⟩) := by + by_cases hcomplete : DeferredCompletable table context + · rw [finishResolvedRunIsNone_some_eq_finalize _ hcomplete, + finishResolvedRunIsNone_some_eq_finalize _ hcomplete] + · simp [finishResolvedRunIsNone, finishResolvedRun, hcomplete] + +theorem evalDist_probingHashQuery_finished_eq_candidate + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcard : context.state.pending.card + 1 < Fintype.card Digest) : + evalDist (runResolvedFinishIsNone context (fuel + 1) table ((probingHashQuery parameter input).run cache)) = + evalDist (resolvedFinalizationObserve table + (afterCandidateContext context (purePlanProbingHashQuery parameter input context.state).candidate?) 0 ()) := by + let plan := purePlanProbingHashQuery parameter input context.state + have hdrop := evalDist_runResolvedFinishIsNone_bind_of_probeFree + ((executeCandidate? plan.candidate?).run cache) + (fun result : Unit × SplitHashCache => + ((match plan.action with + | .ordinary => splitHashQuery (.ordinary input) + | .resolve coordinate => resolveKnownInput parameter coordinate input)).run result.2) + context (fuel + 1) table (by + intro result + cases plan.action with + | ordinary => exact splitHashQuery_probeFree _ result.2 + | resolve coordinate => exact resolveKnownInput_probeFree parameter coordinate input result.2) + hconsistent hstarts (by + intro result hresult + rw [runResolvedFromTable_executeCandidate_positive] at hresult + simp only [mem_support_pure_iff, Option.some.injEq] at hresult + subst result + exact (afterCandidateContext_pending_card_le context plan.candidate?).trans_lt hcard) + calc + _ = evalDist (runResolvedFinishIsNone context (fuel + 1) table + ((probingHashQueryAfterPlan parameter input plan).run cache)) := by + unfold runResolvedFinishIsNone + rw [runResolved_probingHashQuery_eq_afterPlan] + _ = evalDist (runResolvedFinishIsNone context (fuel + 1) table + ((executeCandidate? plan.candidate?).run cache)) := by + unfold probingHashQueryAfterPlan executePlannedHashQuery + rw [StateT.run_bind] + convert hdrop using 1 + cases plan.action <;> rfl + _ = _ := by + rw [runResolvedFinishIsNone, runResolvedFromTable_executeCandidate_positive, pure_bind] + exact congrArg evalDist (finishResolvedRunIsNone_metadata_eq _ table _ 0 ((), cache) ()) + +theorem evalDist_finish_canonicalizeResolvedRun_of_core + (result : ResolvedRunResult α) (hconsistent : result.context.ValuesConsistent) + (hstarts : StartTableAgrees result.context.state result.table) : + evalDist (finishResolvedRunIsNone (canonicalizeResolvedRun result.table (some result))) = + evalDist (finishResolvedRunIsNone (some result)) := by + by_cases hcomplete : DeferredCompletable result.table result.context + · exact evalDist_finish_canonicalizeResolvedRun result + (valid_of_resolvedCore_completable result.table result.context hconsistent hstarts hcomplete) hstarts + · have hcanonical := doomedResolvedContext_canonicalizeMaterializedValues + (show DoomedResolvedContext result.table result.context from ⟨hconsistent, hstarts, hcomplete⟩) + simp [canonicalizeResolvedRun, finishResolvedRunIsNone, finishResolvedRun, hcomplete, hcanonical.2.2] + +theorem evalDist_canonicalQuery_finished_eq_raw + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + evalDist (canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache >>= + finishResolvedRunIsNone) = + evalDist (runResolvedFinishIsNone context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache)) := by + rw [canonicalChronologicalAdversaryImpl_eq_raw_then_canonicalize, bind_assoc, runResolvedFinishIsNone] + apply evalDist_bind_congr + intro option hoption + simp only [pure_bind] + cases option with + | none => rfl + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table result hconsistent hstarts hoption + have heq := evalDist_finish_canonicalizeResolvedRun_of_core result hcore.2.1 (hcore.1 ▸ hcore.2.2) + simpa only [hcore.1] using heq + +theorem evalDist_canonicalHashQuery_finished_eq_candidate + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcard : context.state.pending.card + 1 < Fintype.card Digest) : + evalDist (canonicalChronologicalAdversaryImpl parameter root table ftsSecret (.inl (.inr input)) + context (fuel + 1) table cache >>= finishResolvedRunIsNone) = + evalDist (resolvedFinalizationObserve table + (afterCandidateContext context (purePlanProbingHashQuery parameter input context.state).candidate?) 0 ()) := by + rw [evalDist_canonicalQuery_finished_eq_raw parameter root table ftsSecret (.inl (.inr input)) + context (fuel + 1) cache hconsistent hstarts] + exact evalDist_probingHashQuery_finished_eq_candidate parameter input context fuel table cache hconsistent hstarts hcard + +noncomputable def resolvedContextFailureRisk + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) : ℝ≥0∞ := + Pr[fun verdict => verdict = true | resolvedFinalizationObserve table context 0 ()] + +theorem resolvedContextFailureRisk_of_not_completable + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hstop : ¬DeferredCompletable table context) : resolvedContextFailureRisk table context = 1 := by + simp [resolvedContextFailureRisk, resolvedFinalizationObserve, finishResolvedRunIsNone, finishResolvedRun, hstop] + +theorem resolvedContextFailureRisk_le_one (table : OtsSecretIndex → HashOutput) (context : DeferredContext) : + resolvedContextFailureRisk table context ≤ 1 := probEvent_le_one + +theorem canonicalHashQueryRejectionRisk_le_afterCandidate + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (entry : CanonicalQuerySelection) (input : HashInput) (hinput : entry.input = .inl (.inr input)) + (hfuel : 0 < entry.fuel) + (hconsistent : entry.context.ValuesConsistent) (hstarts : StartTableAgrees entry.context.state entry.table) + (hcard : entry.context.state.pending.card + 1 < Fintype.card Digest) : + canonicalQueryRejectionRisk parameter root ftsSecret entry ≤ + resolvedContextFailureRisk entry.table + (afterCandidateContext entry.context (purePlanProbingHashQuery parameter input entry.context.state).candidate?) := by + unfold canonicalQueryRejectionRisk + rw [hinput] + apply (probEvent_resolvedQueryRejected_le_finished _).trans_eq + obtain ⟨fuel, heq⟩ := Nat.exists_eq_succ_of_ne_zero (Nat.ne_zero_of_lt hfuel) + have hdist := evalDist_canonicalHashQuery_finished_eq_candidate parameter root entry.table ftsSecret input + entry.context fuel entry.cache hconsistent hstarts hcard + have hprob := congrArg (fun distribution : SPMF Bool => distribution true) hdist + change Pr[= true | _] = Pr[= true | _] at hprob + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput] at hprob + simpa only [heq, resolvedContextFailureRisk] using hprob + +theorem resolvedContextFailureRisk_addPending_hit + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (coordinate : Coordinate) (candidate : Digest) (output : HashOutput) + (hvalue : resolvedCompletionValue table context coordinate = some output) + (hhit : truncateHash output = candidate) : + resolvedContextFailureRisk table { context with state := context.state.addPending coordinate candidate } = 1 := by + apply resolvedContextFailureRisk_of_not_completable + rintro ⟨completion, hcompletion⟩ + have heq := hcompletion.eq_resolvedCompletionValue coordinate output hvalue + have hpending : (coordinate, candidate) ∈ (context.state.addPending coordinate candidate).pending := by + simp [LazyRevealProbe.State.addPending] + exact hcompletion.2.2.1 coordinate candidate hpending (by rw [heq, hhit]) + +theorem resolvedContextFailureRisk_addPending_miss + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (coordinate : Coordinate) (candidate : Digest) (output : HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hvalue : resolvedCompletionValue table context coordinate = some output) + (hmiss : truncateHash output ≠ candidate) : + resolvedContextFailureRisk table { context with state := context.state.addPending coordinate candidate } = + resolvedContextFailureRisk table context := by + by_cases hcomplete : DeferredCompletable table context + · have hvalid := valid_of_resolvedCore_completable table context hconsistent hstarts hcomplete + have hview := FinalizationViewEq.refl table context hvalid hstarts + (fun coordinate output hvalue hhit => hcomplete.not_pendingResolvedHit ⟨coordinate, output, hvalue, hhit⟩) + have hbase : FinalizationContextEq table (some context) (some context) := ⟨hview, hvalid, hvalid, hcomplete⟩ + have hnext := hbase.addPending_left_of_resolved coordinate candidate output hvalue hmiss + have heq := evalDist_finishResolvedRunIsNone_eq_of_finalizationContextEq table _ context 0 () hnext + unfold resolvedContextFailureRisk resolvedFinalizationObserve + rw [probEvent_eq_eq_probOutput, probEvent_eq_eq_probOutput] + exact congrArg (fun distribution : SPMF Bool => distribution true) heq + · have hnext : ¬DeferredCompletable table + { context with state := context.state.addPending coordinate candidate } := by + rintro ⟨completion, hcompletion⟩ + exact hcomplete ⟨completion, hcompletion.of_addPending coordinate candidate⟩ + rw [resolvedContextFailureRisk_of_not_completable _ _ hnext, + resolvedContextFailureRisk_of_not_completable _ _ hcomplete] + +theorem resolvedContextFailureRisk_afterCandidate_of_duplicate + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) (candidate : Probe) + (hduplicate : (candidate.coordinate, candidate.candidate) ∈ context.state.pending) : + resolvedContextFailureRisk table (afterCandidateContext context (some candidate)) = + resolvedContextFailureRisk table context := by + unfold afterCandidateContext + dsimp only + split_ifs with hrevealed + · rfl + · simp only [LazyRevealProbe.State.addPending, Finset.insert_eq_of_mem hduplicate] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHiddenRootCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHiddenRootCharge.lean new file mode 100644 index 00000000..e9d180ca --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHiddenRootCharge.lean @@ -0,0 +1,171 @@ +import SphincsSecurity.Proof.OtsProbeResidualCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_successfulDoomedFirstRootFiber_le_productionCharge126 + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (hordinal : ordinal < q) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[fun observed => + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target (2 * q) table] * + ((4 / 3) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + let run := observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table + let probability := Pr[fun observed => + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed | run] + let weight := Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target (2 * q) table] + let epsilon := ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + have hgood : + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] ≤ weight * epsilon := by + exact Range125.probEvent_observedRootComparison_le_production_mul ordinal adversary parameter table + ftsSecret q target hroot hparent hfuel hbound hq + have hsplit : probability ≤ + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest => + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] + + probability * + ((ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + exact probEvent_successfulDoomedFirstRootFiber_le_goodComparison_add_weightedException + table run ordinal target + have hcoefficient : ((ordinal : ℝ≥0∞) * epsilon) * (4 / 3 : ℝ≥0∞) + 1 ≤ 4 / 3 := by + apply le_trans _ (rootBudget_four_thirds hq) + dsimp only [epsilon] + gcongr + have habsorb : probability ≤ (4 / 3) * (weight * epsilon) := by + have hweight : weight ≠ ∞ := ne_top_of_le_ne_top (by norm_num) probEvent_le_one + have hepsilon : epsilon ≠ ∞ := by dsimp [epsilon]; norm_num [digestBits] + apply le_mul_of_le_add_self_mul probability (weight * epsilon) ((ordinal : ℝ≥0∞) * epsilon) + (4 / 3) probEvent_le_one + (by finiteness) (by finiteness) (by finiteness) hcoefficient + exact hsplit.trans (add_le_add hgood le_rfl) + change probability ≤ weight * ((4 / 3) * epsilon) + calc + probability ≤ (4 / 3) * (weight * epsilon) := habsorb + _ = weight * ((4 / 3) * epsilon) := by ac_rfl + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_successfulDoomedFirstRootFiber_le_commonCharge126 + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (hordinal : ordinal < q) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[fun observed => + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret + (2 * q) table] * + ((4 / 3) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + calc + _ ≤ Pr[fun result => materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target (2 * q) table] * + ((4 / 3) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := + probEvent_successfulDoomedFirstRootFiber_le_productionCharge126 ordinal adversary parameter + table ftsSecret q target hroot hparent hordinal hfuel hbound hq + _ ≤ _ := by + gcongr + exact probEvent_materializedRootAwareProduction_le_commonDetailedFiber ordinal adversary + parameter ftsSecret target hroot hparent (2 * q) table + + +theorem probEvent_successfulDoomedFirstRoot_le_selectedCharge126 + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (hordinal : ordinal < q) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun selection => + (permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection).isSome = true | + permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret + (2 * q) table] * ((4 / 3) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply Range125.probEvent_le_common_selected_mass + (leftPosition := observedFirstLayerRootPosition? ordinal) + (common := permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret (2 * q) table) + (commonPosition := permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?) + · intro observed hevent hnone + exact not_successfulDoomedFirstRoot_of_position_eq_none hnone hevent + · intro target + by_cases hexists : ∃ observed ∈ support + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table), + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal observed ∧ + observedFirstLayerRootPosition? ordinal observed = some target + · have hstructure := + root_and_parent_of_existing_successfulDoomedFirstRootFiber hexists + simpa [ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget] using + probEvent_successfulDoomedFirstRootFiber_le_commonCharge126 ordinal adversary + parameter table ftsSecret q target hstructure.1 hstructure.2 hordinal hfuel hbound hq + · simp only [not_exists, not_and] at hexists + have hzero : Pr[fun observed => + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt + table ordinal observed ∧ + observedFirstLayerRootPosition? ordinal observed = some target | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] = + 0 := by + apply probEvent_eq_zero + intro observed hsupport hevent + exact hexists observed hsupport hevent.1 hevent.2 + rw [hzero] + exact zero_le + + + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHiddenSelectionCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHiddenSelectionCharge.lean new file mode 100644 index 00000000..bbc5e44b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHiddenSelectionCharge.lean @@ -0,0 +1,110 @@ +import SphincsSecurity.Proof.OtsProbeHiddenRootCharge +import SphincsSecurity.Proof.OtsProbeNonRootExclusion + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +noncomputable def hiddenSelectionCharge (common : ProbComp (Option PermissivePrivateOrdinalSelection)) : ℝ≥0∞ := + Pr[fun selection => (permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection).isSome = true | common] * + (4 / 3) + +theorem hiddenSelectionCharge_le_residualSelectionCharge + (common : ProbComp (Option PermissivePrivateOrdinalSelection)) : + hiddenSelectionCharge common ≤ residualSelectionCharge common := by + exact le_self_add + +theorem probEvent_diagnosticOrdinal_pair_le_selectedCharge126 + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) (hordinal : ordinal < q) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] + + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + hiddenSelectionCharge + (permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret (2 * q) table) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [probEvent_observedMaterialized_successfulFirstNonRoot_eq_zero126 + adversary parameter ftsSecret q ordinal table hbound hq, add_zero] + simpa only [hiddenSelectionCharge, mul_assoc] using + probEvent_successfulDoomedFirstRoot_le_selectedCharge126 ordinal adversary parameter table + ftsSecret q hordinal hfuel hbound hq + +noncomputable def sampledHiddenSelectionCharge (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) : ℝ≥0∞ := + ∑ ordinal : Fin q, ∑' table, Pr[= table | sampleOtsHashTable] * + hiddenSelectionCharge + (permissiveDetailedSelectionExperimentAfterTable ordinal.val adversary parameter ftsSecret (2 * q) table) + +theorem probEvent_sampledDiagnosticOrdinal_pair_le_selectedCharge126 + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) (hordinal : ordinal < q) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[fun outcome => outcome.SuccessfulDoomed ∧ outcome.FirstExistingHiddenRootHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ outcome.FirstExistingHiddenNonRootHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + (∑' table, Pr[= table | sampleOtsHashTable] * hiddenSelectionCharge + (permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret (2 * q) table)) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + unfold sampledObservedMaterializedDiagnostic + simp only [probEvent_bind_eq_tsum sampleOtsHashTable, ← ENNReal.tsum_add, ← mul_add] + rw [← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro table + rw [mul_assoc] + apply mul_le_mul' le_rfl + apply (add_le_add + (probEvent_finishDiagnostic_successfulDoomed_firstExistingHiddenRootHitAt_le table _ ordinal) + (probEvent_finishDiagnostic_successfulDoomed_firstExistingHiddenNonRootHitAt_le table _ ordinal)).trans + exact probEvent_diagnosticOrdinal_pair_le_selectedCharge126 ordinal adversary parameter table ftsSecret q hordinal hfuel (hbound table) hq + +theorem probEvent_sampledDiagnostic_successfulDoomed_le_selectionCharge126 + (adversary : Adversary) (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + sampledHiddenSelectionCharge adversary parameter ftsSecret q * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + have hfuel : 2 * q < Fintype.card Digest := by + norm_num [digestBits] at hq ⊢ + omega + let p := fun ordinal => + Pr[fun outcome => outcome.SuccessfulDoomed ∧ outcome.FirstExistingHiddenRootHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ outcome.FirstExistingHiddenNonRootHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] + have hsplit : (∑ ordinal : Fin (2 * q), p ordinal.val) = ∑ ordinal : Fin q, p ordinal.val := by + rw [show 2 * q = q + q by omega, Fin.sum_univ_add] + change (∑ ordinal : Fin q, p ordinal.val) + (∑ ordinal : Fin q, p (q + ordinal.val)) = _ + have hzero : (∑ ordinal : Fin q, p (q + ordinal.val)) = 0 := by + apply Finset.sum_eq_zero + intro ordinal _ + unfold p + rw [Range125.probEvent_sampledDiagnostic_successfulDoomed_firstRoot_eq_zero_of_q_le_ordinal + adversary parameter ftsSecret q (q + ordinal.val) hbound hq (by omega), + Range125.probEvent_sampledDiagnostic_successfulDoomed_firstNonRoot_eq_zero_of_q_le_ordinal + adversary parameter ftsSecret q (q + ordinal.val) hbound hq (by omega), add_zero] + rw [hzero, add_zero] + apply (Range125.probEvent_sampledDiagnostic_successfulDoomed_le_sum_successfulFirstOrdinals + adversary parameter ftsSecret q hq).trans + change (∑ ordinal : Fin (2 * q), p ordinal.val) ≤ _ + rw [hsplit, sampledHiddenSelectionCharge, Finset.sum_mul] + exact Finset.sum_le_sum fun ordinal _ => probEvent_sampledDiagnosticOrdinal_pair_le_selectedCharge126 + ordinal.val adversary parameter ftsSecret q ordinal.isLt hfuel hbound hq + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryAdaptiveInterpreter.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryAdaptiveInterpreter.lean new file mode 100644 index 00000000..94b17070 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryAdaptiveInterpreter.lean @@ -0,0 +1,314 @@ +import SphincsSecurity.Proof.OtsProbeHistoryCandidateSampling + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 1000 + +noncomputable def historyAdaptiveQueryStep + (input : (LazyRevealProbe.World Coordinate).Domain) + (next : (LazyRevealProbe.World Coordinate).Range input → DeferredContext → Nat → List Probe → + ProbComp (Option α)) + (context : DeferredContext) (fuel : Nat) (history : List Probe) : ProbComp (Option α) := + match input with + | .probe coordinate digest => + match fuel with + | 0 => pure none + | remaining + 1 => + if coordinate ∈ context.state.revealed then next () context remaining history + else + next () { context with state := context.state.addPending coordinate digest } remaining + (history ++ [⟨coordinate, digest⟩]) + | input => historyCompletionQueryStep history input (fun output context fuel => next output context fuel history) context fuel + +noncomputable def completeResolvedHistory + (context : DeferredContext) (fuel : Nat) (history : List Probe) (value : α) : + ProbComp (Option (ResolvedRunResult α)) := do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then pure none + else pure (some ⟨context, fuel, value, completedStartTable context.state base⟩) + +noncomputable def runResolvedHistoryAdaptive + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + DeferredContext → Nat → List Probe → ProbComp (Option (ResolvedRunResult α)) := + OracleComp.construct + (fun value context fuel history => completeResolvedHistory context fuel history value) + (fun input _ next => historyAdaptiveQueryStep input next) computation + +theorem runResolvedHistoryAdaptive_query_bind + (input : (LazyRevealProbe.World Coordinate).Domain) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) : + runResolvedHistoryAdaptive (OracleSpec.query input >>= next) context fuel history = + historyAdaptiveQueryStep input (fun output => runResolvedHistoryAdaptive (next output)) context fuel history := rfl + +theorem not_completable_of_new_historyHit_addPending + (context : DeferredContext) (history : List Probe) (coordinate : Coordinate) (digest : Digest) + (base : OtsSecretIndex → HashOutput) + (hprior : ¬ChainStartHistoryHit context history base) + (hnew : ChainStartHistoryHit { context with state := context.state.addPending coordinate digest } + (history ++ [⟨coordinate, digest⟩]) base) : + ¬DeferredCompletable (completedStartTable context.state base) + { context with state := context.state.addPending coordinate digest } := by + obtain ⟨candidate, hcandidate, hmissing, hhit⟩ := hnew + rcases List.mem_append.mp hcandidate with hold | hcurrent + · exact False.elim (hprior ⟨candidate, hold, hmissing, hhit⟩) + · have heq : candidate = ⟨coordinate, digest⟩ := by simpa only [List.mem_singleton] using hcurrent + subst candidate + cases coordinate with + | position position => simp [ChainStartEntryHit] at hhit + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + have hvalue : completedStartTable context.state base index = base index := by + change context.state.values index.coordinate = none at hmissing + simp only [completedStartTable, hmissing, Option.getD_none] + intro hcomplete + apply hcomplete.not_hitAt_chainStart index + unfold LazyRevealProbe.State.hitAt + rw [LazyRevealProbe.State.mem_pendingAt_iff, hvalue] + have hdigest : truncateHash (base index) = digest := hhit + rw [hdigest] + simp [LazyRevealProbe.State.addPending, index, OtsSecretIndex.coordinate] + +theorem valuesConsistent_materialize_chainStart + (context : DeferredContext) (index : OtsSecretIndex) (output : HashOutput) + (hconsistent : context.ValuesConsistent) : + ({ context with state := context.state.materialize index.coordinate output } : DeferredContext).ValuesConsistent := by + intro position value hvalue + apply hconsistent position value + simpa [LazyRevealProbe.State.materialize, OtsSecretIndex.coordinate] using hvalue + +set_option maxHeartbeats 800000 in +theorem evalDist_history_filtered_runResolved_eq_adaptive_observe + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) + (observe : Option (ResolvedRunResult α) → ProbComp β) + (hobserve : ∀ result, result.context.ValuesConsistent → StartTableAgrees result.context.state result.table → + ¬DeferredCompletable result.table result.context → evalDist (observe (some result)) = evalDist (observe none)) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hcard : context.state.pending.card + bound < Fintype.card Digest) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) : + evalDist ((do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then pure none + else runResolvedFromTable context fuel (completedStartTable context.state base) computation) >>= observe) = + evalDist (runResolvedHistoryAdaptive computation context fuel history >>= observe) := by + induction computation using OracleComp.inductionOn generalizing context fuel bound history with + | pure value => + rw [runResolvedHistoryAdaptive, OracleComp.construct_pure, completeResolvedHistory] + apply congrArg evalDist + apply congrArg (fun run => run >>= observe) + apply bind_congr + intro base + split_ifs <;> rfl + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [runResolvedHistoryAdaptive_query_bind] + cases input with + | uniform n => + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep] + simp_rw [runResolvedFromTable_uniform_query_bind] + rw [evalDist_bind, evalDist_history_filtered_draw_swap, ← evalDist_bind, bind_assoc, bind_assoc] + apply evalDist_bind_congr + intro output _houtput + exact ih output context fuel bound history hconsistent hcovered hcard + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + | hashOutput => + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep] + simp_rw [runResolvedFromTable_hashOutput_query_bind] + rw [evalDist_bind, evalDist_history_filtered_draw_swap, ← evalDist_bind, bind_assoc, bind_assoc] + apply evalDist_bind_congr + intro output _houtput + exact ih output context fuel bound history hconsistent hcovered hcard + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + | ensure coordinate => + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep] + simp_rw [runResolvedFromTable_ensure_query_bind] + exact ih () { context with state := context.state.ensure coordinate } fuel bound history hconsistent hcovered hcard + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) + | peek coordinate => + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep] + simp_rw [runResolvedFromTable_peek_query_bind] + exact ih (context.state.values coordinate) context fuel bound history hconsistent hcovered hcard + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 _) + | publish coordinate => + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep] + simp_rw [runResolvedFromTable_publish_query_bind] + exact ih () { context with state := context.state.publish coordinate } fuel bound history hconsistent hcovered hcard + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) + | probe coordinate digest => + have hpositive : 0 < bound := by simpa [LazyRevealProbe.IsProbe] using hbound.1 + have htailBound : (next ()).IsQueryBoundP LazyRevealProbe.IsProbe (bound - 1) := by + simpa [LazyRevealProbe.IsProbe] using hbound.2 () + cases fuel with + | zero => + simp only [historyAdaptiveQueryStep, runResolvedFromTable_probe_query_bind, ite_self, bind_assoc, pure_bind] + exact evalDist_sampleOtsHashTable_bind_const (observe none) + | succ fuel => + simp only [historyAdaptiveQueryStep] + simp_rw [runResolvedFromTable_probe_query_bind] + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [if_pos hrevealed] + exact ih () context fuel (bound - 1) history hconsistent hcovered (by omega) htailBound + · simp only [if_neg hrevealed] + let after : DeferredContext := { context with state := context.state.addPending coordinate digest } + have hcardAfter : after.state.pending.card + (bound - 1) < Fintype.card Digest := by + have hle := Finset.card_insert_le (coordinate, digest) context.state.pending + change (insert (coordinate, digest) context.state.pending).card + (bound - 1) < _ + omega + have hrec := ih () after fuel (bound - 1) (history ++ [⟨coordinate, digest⟩]) + (hconsistent.addPending coordinate digest) (hcovered.addPending_append history context ⟨coordinate, digest⟩) + hcardAfter htailBound + calc + _ = evalDist ((do + let base ← sampleOtsHashTable + if ChainStartHistoryHit after (history ++ [⟨coordinate, digest⟩]) base then pure none + else runResolvedFromTable after fuel (completedStartTable after.state base) (next ())) >>= observe) := by + rw [bind_assoc, bind_assoc] + apply evalDist_bind_congr + intro base _hbase + have htable : completedStartTable after.state base = completedStartTable context.state base := rfl + rw [htable] + by_cases hprior : ChainStartHistoryHit context history base + · have hnew : ChainStartHistoryHit after (history ++ [⟨coordinate, digest⟩]) base := by + obtain ⟨candidate, hmem, hmissing, hhit⟩ := hprior + exact ⟨candidate, List.mem_append_left _ hmem, hmissing, hhit⟩ + simp only [if_pos hprior, if_pos hnew] + · simp only [if_neg hprior] + by_cases hnew : ChainStartHistoryHit after (history ++ [⟨coordinate, digest⟩]) base + · simp only [if_pos hnew, pure_bind] + exact evalDist_runResolved_observe_of_not_completable after fuel _ (next ()) (observe none) observe rfl + hobserve (hconsistent.addPending coordinate digest) + ((startTableAgrees_completedStartTable context.state base).addPending coordinate digest) + (not_completable_of_new_historyHit_addPending context history coordinate digest base hprior hnew) + · simp only [if_neg hnew] + rfl + _ = _ := hrec + | reveal coordinate => + have hcardCurrent : context.state.pending.card < Fintype.card Digest := by omega + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + cases hknown : context.state.values index.coordinate with + | some output => + have hstep := evalDist_history_filtered_runResolved_revealStart_known context history fuel index output next hknown + dsimp only [index, OtsSecretIndex.coordinate] at hstep + rw [evalDist_bind, hstep, ← evalDist_bind] + have hknown' := hknown + dsimp only [index, OtsSecretIndex.coordinate] at hknown' + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep, OtsSecretIndex.coordinate, hknown'] + by_cases hhit : context.state.hitAt (.chainStart lay tree leafIdx chainIdx) output + · simp only [if_pos hhit] + · simp only [if_neg hhit] + apply ih output + { context with state := context.state.materialize (.chainStart lay tree leafIdx chainIdx) output } + fuel bound history (valuesConsistent_materialize_chainStart context index output hconsistent) + (hcovered.of_subset (Finset.filter_subset _ _)) + · have hle := Finset.card_le_card (Finset.filter_subset + (fun entry : Coordinate × Digest => entry.1 ≠ .chainStart lay tree leafIdx chainIdx) context.state.pending) + exact lt_of_le_of_lt (Nat.add_le_add_right hle bound) hcard + · simpa [LazyRevealProbe.IsProbe] using hbound.2 output + | none => + have hstep := evalDist_history_filtered_runResolved_revealStart_missing context history fuel index next hcovered hknown + dsimp only [index, OtsSecretIndex.coordinate] at hstep + rw [evalDist_bind, hstep, ← evalDist_bind] + have hknown' := hknown + dsimp only [index, OtsSecretIndex.coordinate] at hknown' + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep, OtsSecretIndex.coordinate, hknown', bind_assoc] + apply evalDist_bind_congr + intro output _houtput + by_cases hhit : ChainStartHistoryOutputHit history ⟨lay, tree, leafIdx, chainIdx⟩ output + · simp only [if_pos hhit] + · simp only [if_neg hhit] + apply ih output + { context with state := context.state.materialize (.chainStart lay tree leafIdx chainIdx) output } + fuel bound history (valuesConsistent_materialize_chainStart context index output hconsistent) + (hcovered.of_subset (Finset.filter_subset _ _)) + · have hle := Finset.card_le_card (Finset.filter_subset + (fun entry : Coordinate × Digest => entry.1 ≠ .chainStart lay tree leafIdx chainIdx) context.state.pending) + exact lt_of_le_of_lt (Nat.add_le_add_right hle bound) hcard + · simpa [LazyRevealProbe.IsProbe] using hbound.2 output + | position position => + rw [evalDist_bind, evalDist_history_filtered_runResolved_revealPosition context history fuel position next hcovered hcardCurrent, + ← evalDist_bind] + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep, bind_assoc] + apply evalDist_bind_congr + intro option hoption + cases option with + | none => rfl + | some resolved => + apply ih resolved.output + { state := context.state.materialize (.position position) resolved.output, values := resolved.values } + fuel bound history + (hconsistent.materializeResolvedPosition_of (startTableAvoidingPending context) position resolved hoption) + (hcovered.of_subset (Finset.filter_subset _ _)) + · have hle := Finset.card_le_card (Finset.filter_subset + (fun entry : Coordinate × Digest => entry.1 ≠ .position position) context.state.pending) + exact lt_of_le_of_lt (Nat.add_le_add_right hle bound) hcard + · simpa [LazyRevealProbe.IsProbe] using hbound.2 resolved.output + +theorem evalDist_history_filtered_runResolved_eq_adaptive_finished + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hcard : context.state.pending.card + bound < Fintype.card Digest) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) : + evalDist ((do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then pure none + else runResolvedFromTable context fuel (completedStartTable context.state base) computation) >>= finishResolvedRun) = + evalDist (runResolvedHistoryAdaptive computation context fuel history >>= finishResolvedRun) := by + apply evalDist_history_filtered_runResolved_eq_adaptive_observe computation context fuel bound history finishResolvedRun + · intro result _hvalues _hstarts hdoomed + simp [finishResolvedRun, hdoomed] + · exact hconsistent + · exact hcovered + · exact hcard + · exact hbound + +theorem evalDist_history_filtered_runResolved_eq_adaptive_failure + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hcard : context.state.pending.card + bound < Fintype.card Digest) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) : + evalDist ((do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then pure none + else runResolvedFromTable context fuel (completedStartTable context.state base) computation) >>= finishResolvedRunIsNone) = + evalDist (runResolvedHistoryAdaptive computation context fuel history >>= finishResolvedRunIsNone) := by + apply evalDist_history_filtered_runResolved_eq_adaptive_observe computation context fuel bound history finishResolvedRunIsNone + · intro result _hvalues _hstarts hdoomed + simp [finishResolvedRunIsNone, finishResolvedRun, hdoomed] + · exact hconsistent + · exact hcovered + · exact hcard + · exact hbound + +theorem evalDist_sampled_runResolved_empty_eq_adaptive_finished + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel bound : Nat) + (hcard : bound < Fintype.card Digest) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) : + evalDist ((do + let table ← sampleOtsHashTable + runResolvedFromTable { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table computation) >>= finishResolvedRun) = + evalDist (runResolvedHistoryAdaptive computation + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel [] >>= finishResolvedRun) := by + have heq := evalDist_history_filtered_runResolved_eq_adaptive_finished computation + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel bound [] DeferredContext.valid_empty.valuesConsistent pendingCoveredBy_empty + (by simpa [LazyRevealProbe.State.empty] using hcard) hbound + have htable : ∀ base, completedStartTable LazyRevealProbe.State.empty base = base := by + intro base + funext index + rfl + simpa only [ChainStartHistoryHit, List.not_mem_nil, false_and, exists_false, ↓reduceIte, + htable] using heq + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryCandidateSampling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryCandidateSampling.lean new file mode 100644 index 00000000..d50c1652 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryCandidateSampling.lean @@ -0,0 +1,357 @@ +import SphincsSecurity.Proof.OtsProbeHistoryCompletionInterpreter + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 1000 + +theorem afterCandidateContext_values (context : DeferredContext) (candidate : Option Probe) : + (afterCandidateContext context candidate).state.values = context.state.values := by + cases candidate with + | none => rfl + | some candidate => + unfold afterCandidateContext + dsimp only + split_ifs <;> rfl + +theorem completedStartTable_afterCandidateContext + (context : DeferredContext) (candidate : Option Probe) (base : OtsSecretIndex → HashOutput) : + completedStartTable (afterCandidateContext context candidate).state base = + completedStartTable context.state base := by + funext index + simp only [completedStartTable, afterCandidateContext_values] + +theorem PendingCoveredBy.afterCandidate + {history : List Probe} {context : DeferredContext} (hcovered : PendingCoveredBy history context) + (candidate : Option Probe) : + PendingCoveredBy (history ++ candidate.toList) (afterCandidateContext context candidate) := by + cases candidate with + | none => simpa only [Option.toList_none, List.append_nil, afterCandidateContext] using hcovered + | some candidate => + unfold afterCandidateContext + dsimp only + split_ifs + · exact hcovered.mono_candidates (List.sublist_append_left _ _) + · exact hcovered.addPending_append history context candidate + +theorem chainStartHistoryHit_afterCandidate_append_iff + (context : DeferredContext) (history : List Probe) (candidate : Option Probe) + (base : OtsSecretIndex → HashOutput) : + ChainStartHistoryHit (afterCandidateContext context candidate) (history ++ candidate.toList) base ↔ + ChainStartHistoryHit context history base ∨ + ∃ probe ∈ candidate.toList, context.state.values probe.coordinate = none ∧ + ChainStartEntryHit base (probe.coordinate, probe.candidate) := by + unfold ChainStartHistoryHit + simp only [afterCandidateContext_values, List.mem_append, or_and_right, exists_or] + +theorem revealed_chainStart_known_of_canonical + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hcanonical : CanonicalMaterializedValues table context) (index : OtsSecretIndex) + (hrevealed : index.coordinate ∈ context.state.revealed) : + context.state.values index.coordinate ≠ none := by + rw [hcanonical] + simp only [publicMaterializedValues, if_pos hrevealed] + simp [resolvedCompletionValue, OtsSecretIndex.coordinate] + +theorem not_completable_of_new_chainStartHistoryHit + (context : DeferredContext) (history : List Probe) (candidate : Option Probe) + (base : OtsSecretIndex → HashOutput) + (hpublic : ∀ index : OtsSecretIndex, index.coordinate ∈ context.state.revealed → + context.state.values index.coordinate ≠ none) + (hprior : ¬ChainStartHistoryHit context history base) + (hnew : ChainStartHistoryHit (afterCandidateContext context candidate) (history ++ candidate.toList) base) : + ¬DeferredCompletable (completedStartTable context.state base) (afterCandidateContext context candidate) := by + obtain ⟨probe, hprobe, hmissing, hhit⟩ := + (chainStartHistoryHit_afterCandidate_append_iff context history candidate base).mp hnew |>.resolve_left hprior + have hcandidate : candidate = some probe := by simpa only [Option.mem_toList] using hprobe + subst candidate + rcases probe with ⟨coordinate, digest⟩ + cases coordinate with + | position position => simp [ChainStartEntryHit] at hhit + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + have hhidden : Coordinate.chainStart lay tree leafIdx chainIdx ∉ context.state.revealed := + fun h => hpublic index h hmissing + simp only [afterCandidateContext, if_neg hhidden] + intro hcomplete + apply hcomplete.not_hitAt_chainStart index + unfold LazyRevealProbe.State.hitAt + rw [LazyRevealProbe.State.mem_pendingAt_iff] + have hvalue : completedStartTable context.state base index = base index := by + change context.state.values index.coordinate = none at hmissing + simp only [completedStartTable, hmissing, Option.getD_none] + rw [hvalue] + have hdigest : truncateHash (base index) = digest := hhit + rw [hdigest] + simp [LazyRevealProbe.State.addPending, index, OtsSecretIndex.coordinate] + +theorem evalDist_history_filtered_afterCandidate_append + (context : DeferredContext) (history : List Probe) (candidate : Option Probe) + (hpublic : ∀ index : OtsSecretIndex, index.coordinate ∈ context.state.revealed → + context.state.values index.coordinate ≠ none) + (failure : ProbComp α) (next : (OtsSecretIndex → HashOutput) → ProbComp α) + (hstop : ∀ base, ¬DeferredCompletable (completedStartTable context.state base) (afterCandidateContext context candidate) → + evalDist (next (completedStartTable context.state base)) = evalDist failure) : + evalDist (do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then failure + else next (completedStartTable context.state base)) = + evalDist (do + let base ← sampleOtsHashTable + if ChainStartHistoryHit (afterCandidateContext context candidate) (history ++ candidate.toList) base then failure + else next (completedStartTable (afterCandidateContext context candidate).state base)) := by + apply evalDist_bind_congr + intro base _hbase + rw [completedStartTable_afterCandidateContext] + by_cases hprior : ChainStartHistoryHit context history base + · have hnew := (chainStartHistoryHit_afterCandidate_append_iff context history candidate base).mpr (Or.inl hprior) + simp only [if_pos hprior, if_pos hnew] + · simp only [if_neg hprior] + by_cases hnew : ChainStartHistoryHit (afterCandidateContext context candidate) (history ++ candidate.toList) base + · rw [if_pos hnew] + exact hstop base (not_completable_of_new_chainStartHistoryHit context history candidate base hpublic hprior hnew) + · rw [if_neg hnew] + +theorem evalDist_runResolved_observe_of_not_completable + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (failure : ProbComp β) (observe : Option (ResolvedRunResult α) → ProbComp β) + (hnone : evalDist (observe none) = evalDist failure) + (hobserve : ∀ result, result.context.ValuesConsistent → StartTableAgrees result.context.state result.table → + ¬DeferredCompletable result.table result.context → + evalDist (observe (some result)) = evalDist failure) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) : + evalDist (runResolvedFromTable context fuel table computation >>= observe) = evalDist failure := by + calc + _ = evalDist (runResolvedFromTable context fuel table computation >>= fun _ => failure) := by + apply evalDist_bind_congr + intro option hoption + cases option with + | none => exact hnone + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable computation context fuel table result + hconsistent hstarts hoption + apply hobserve result hcore.2.1 (hcore.1 ▸ hcore.2.2) + rw [hcore.1] + exact not_deferredCompletable_of_mem_runResolvedFromTable computation context fuel table result + hconsistent hstarts hoption hdoomed + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails _ (by simp [runResolvedFromTable]) failure + +theorem evalDist_history_filtered_executeCandidate_probeFree + (context : DeferredContext) (history : List Probe) (candidate : Option Probe) + (fuel : Nat) (cache : SplitHashCache) + (next : Unit × SplitHashCache → OracleComp (LazyRevealProbe.World Coordinate) α) + (failure : ProbComp β) (observe : Option (ResolvedRunResult α) → ProbComp β) + (hnone : evalDist (observe none) = evalDist failure) + (hobserve : ∀ result, result.context.ValuesConsistent → StartTableAgrees result.context.state result.table → + ¬DeferredCompletable result.table result.context → + evalDist (observe (some result)) = evalDist failure) + (hconsistent : context.ValuesConsistent) + (hpublic : ∀ index : OtsSecretIndex, index.coordinate ∈ context.state.revealed → + context.state.values index.coordinate ≠ none) + (hcovered : PendingCoveredBy history context) + (hcard : context.state.pending.card + 1 < Fintype.card Digest) + (hbound : (next ((), cache)).IsQueryBoundP LazyRevealProbe.IsProbe 0) : + evalDist (do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then failure + else + runResolvedFromTable context (fuel + 1) (completedStartTable context.state base) + (((executeCandidate? candidate).run cache) >>= next) >>= observe) = + evalDist (runResolvedHistoryCompletion (history ++ candidate.toList) (next ((), cache)) + (afterCandidateContext context candidate) (if candidate.isSome then fuel else fuel + 1) >>= observe) := by + let after := afterCandidateContext context candidate + let remaining := if candidate.isSome then fuel else fuel + 1 + let continuation := fun table => runResolvedFromTable after remaining table (next ((), cache)) >>= observe + have hafter := afterCandidateContext_valuesConsistent context candidate hconsistent + have hstop : ∀ base, ¬DeferredCompletable (completedStartTable context.state base) after → + evalDist (continuation (completedStartTable context.state base)) = evalDist failure := by + intro base hdoomed + exact evalDist_runResolved_observe_of_not_completable after remaining _ _ failure observe hnone hobserve hafter + (afterCandidateContext_startTableAgrees _ context candidate (startTableAgrees_completedStartTable context.state base)) + hdoomed + have hsample := evalDist_history_filtered_runResolved_eq_completion_of_probeFree + (history ++ candidate.toList) (next ((), cache)) after remaining + (hcovered.afterCandidate candidate) ((afterCandidateContext_pending_card_le context candidate).trans_lt hcard) hbound + calc + _ = evalDist (do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then failure + else continuation (completedStartTable context.state base)) := by + apply evalDist_bind_congr + intro base _hbase + split_ifs + · rfl + · simp only [runResolvedFromTable_bind, runResolvedFromTable_executeCandidate_positive, pure_bind] + rfl + _ = evalDist (do + let base ← sampleOtsHashTable + if ChainStartHistoryHit after (history ++ candidate.toList) base then failure + else continuation (completedStartTable after.state base)) := + evalDist_history_filtered_afterCandidate_append context history candidate hpublic failure continuation hstop + _ = evalDist ((do + let base ← sampleOtsHashTable + if ChainStartHistoryHit after (history ++ candidate.toList) base then pure none + else runResolvedFromTable after remaining (completedStartTable after.state base) (next ((), cache))) >>= observe) := by + rw [bind_assoc] + apply evalDist_bind_congr + intro base _hbase + split_ifs + · simpa only [pure_bind] using hnone.symm + · rfl + _ = _ := by rw [evalDist_bind, hsample, ← evalDist_bind] + +noncomputable def runHistoryHashQueryCompletion + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) + (history : List Probe) (fuel : Nat) (cache : SplitHashCache) : + ProbComp (Option (ResolvedRunResult (HashOutput × SplitHashCache))) := + let plan := purePlanProbingHashQuery parameter input context.state + runResolvedHistoryCompletion (history ++ plan.candidate?.toList) + ((match plan.action with + | .ordinary => splitHashQuery (.ordinary input) + | .resolve coordinate => resolveKnownInput parameter coordinate input).run cache) + (afterCandidateContext context plan.candidate?) (if plan.candidate?.isSome then fuel else fuel + 1) + +theorem evalDist_history_filtered_probingHashQuery_observe + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) + (history : List Probe) (fuel : Nat) (cache : SplitHashCache) + (failure : ProbComp α) (observe : Option (ResolvedRunResult (HashOutput × SplitHashCache)) → ProbComp α) + (hnone : evalDist (observe none) = evalDist failure) + (hobserve : ∀ result, result.context.ValuesConsistent → StartTableAgrees result.context.state result.table → + ¬DeferredCompletable result.table result.context → + evalDist (observe (some result)) = evalDist failure) + (hconsistent : context.ValuesConsistent) + (hpublic : ∀ index : OtsSecretIndex, index.coordinate ∈ context.state.revealed → + context.state.values index.coordinate ≠ none) + (hcovered : PendingCoveredBy history context) + (hcard : context.state.pending.card + 1 < Fintype.card Digest) : + evalDist (do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then failure + else + runResolvedFromTable context (fuel + 1) (completedStartTable context.state base) + ((probingHashQuery parameter input).run cache) >>= observe) = + evalDist (runHistoryHashQueryCompletion parameter input context history fuel cache >>= observe) := by + let plan := purePlanProbingHashQuery parameter input context.state + let next := fun result : Unit × SplitHashCache => + (match plan.action with + | .ordinary => splitHashQuery (.ordinary input) + | .resolve coordinate => resolveKnownInput parameter coordinate input).run result.2 + have hbound : (next ((), cache)).IsQueryBoundP LazyRevealProbe.IsProbe 0 := by + dsimp only [next] + cases plan.action with + | ordinary => exact splitHashQuery_probeFree _ cache + | resolve coordinate => exact resolveKnownInput_probeFree parameter coordinate input cache + calc + _ = evalDist (do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then failure + else + runResolvedFromTable context (fuel + 1) (completedStartTable context.state base) + (((executeCandidate? plan.candidate?).run cache) >>= next) >>= observe) := by + apply evalDist_bind_congr + intro base _hbase + split_ifs + · rfl + · rw [runResolved_probingHashQuery_eq_afterPlan] + unfold probingHashQueryAfterPlan executePlannedHashQuery + rw [StateT.run_bind] + rfl + _ = _ := evalDist_history_filtered_executeCandidate_probeFree context history plan.candidate? fuel cache next + failure observe hnone hobserve hconsistent hpublic hcovered hcard hbound + +theorem evalDist_history_filtered_canonicalHashQuery_observe + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (context : DeferredContext) (history : List Probe) (fuel : Nat) (cache : SplitHashCache) + (failure : ProbComp α) (observe : Option (ResolvedRunResult (HashOutput × SplitHashCache)) → ProbComp α) + (hnone : evalDist (observe none) = evalDist failure) + (hobserve : ∀ result, result.context.ValuesConsistent → StartTableAgrees result.context.state result.table → + ¬DeferredCompletable result.table result.context → + evalDist (observe (some result)) = evalDist failure) + (hconsistent : context.ValuesConsistent) + (hpublic : ∀ index : OtsSecretIndex, index.coordinate ∈ context.state.revealed → + context.state.values index.coordinate ≠ none) + (hcovered : PendingCoveredBy history context) + (hcard : context.state.pending.card + 1 < Fintype.card Digest) : + evalDist (do + let base ← sampleOtsHashTable + let table := completedStartTable context.state base + if ChainStartHistoryHit context history base then failure + else + canonicalChronologicalAdversaryImpl parameter root table ftsSecret (.inl (.inr input)) + context (fuel + 1) table cache >>= observe) = + evalDist (runHistoryHashQueryCompletion parameter input context history fuel cache >>= fun option => + match option with + | none => observe none + | some result => observe (canonicalizeResolvedRun result.table (some result))) := by + let rawObserve := fun option : Option (ResolvedRunResult (HashOutput × SplitHashCache)) => + match option with + | none => observe none + | some result => observe (canonicalizeResolvedRun result.table (some result)) + have hraw : ∀ result, result.context.ValuesConsistent → StartTableAgrees result.context.state result.table → + ¬DeferredCompletable result.table result.context → + evalDist (rawObserve (some result)) = evalDist failure := by + intro result hvalues hstarts hdoomed + have hcanonical := doomedResolvedContext_canonicalizeMaterializedValues ⟨hvalues, hstarts, hdoomed⟩ + exact hobserve { result with context := canonicalizeMaterializedValues result.table result.context } + hcanonical.1 hcanonical.2.1 hcanonical.2.2 + calc + _ = evalDist (do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then failure + else + runResolvedFromTable context (fuel + 1) (completedStartTable context.state base) + ((probingHashQuery parameter input).run cache) >>= rawObserve) := by + apply evalDist_bind_congr + intro base _hbase + dsimp only + split_ifs + · rfl + · rw [canonicalChronologicalAdversaryImpl_eq_raw_then_canonicalize, bind_assoc] + apply evalDist_bind_congr + intro option hoption + simp only [pure_bind] + cases option with + | none => rfl + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context (fuel + 1) _ result hconsistent + (startTableAgrees_completedStartTable context.state base) hoption + simp only [rawObserve, hcore.1] + _ = _ := evalDist_history_filtered_probingHashQuery_observe parameter input context history fuel cache + failure rawObserve hnone hraw hconsistent hpublic hcovered hcard + +theorem evalDist_history_filtered_canonicalHashQuery_finished + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (context : DeferredContext) (history : List Probe) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hpublic : ∀ index : OtsSecretIndex, index.coordinate ∈ context.state.revealed → + context.state.values index.coordinate ≠ none) + (hcovered : PendingCoveredBy history context) + (hcard : context.state.pending.card + 1 < Fintype.card Digest) : + evalDist (do + let base ← sampleOtsHashTable + let table := completedStartTable context.state base + if ChainStartHistoryHit context history base then pure true + else + canonicalChronologicalAdversaryImpl parameter root table ftsSecret (.inl (.inr input)) + context (fuel + 1) table cache >>= finishResolvedRunIsNone) = + evalDist (runHistoryHashQueryCompletion parameter input context history fuel cache >>= fun option => + match option with + | none => finishResolvedRunIsNone (none : Option (ResolvedRunResult (HashOutput × SplitHashCache))) + | some result => finishResolvedRunIsNone (canonicalizeResolvedRun result.table (some result))) := by + apply evalDist_history_filtered_canonicalHashQuery_observe parameter root ftsSecret input context history fuel cache + (pure true) finishResolvedRunIsNone + · rfl + · intro result _hvalues _hstarts hdoomed + simp [finishResolvedRunIsNone, finishResolvedRun, hdoomed] + · exact hconsistent + · exact hpublic + · exact hcovered + · exact hcard + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryCanonicalBoundary.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryCanonicalBoundary.lean new file mode 100644 index 00000000..caa091c9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryCanonicalBoundary.lean @@ -0,0 +1,254 @@ +import SphincsSecurity.Proof.OtsProbeHistoryLiveRisk +import SphincsSecurity.Proof.OtsProbeSigningFailureCoupling + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 2000 + +noncomputable def historyCanonicalContext (context : DeferredContext) : DeferredContext := + canonicalizeMaterializedValues (completedStartTable context.state (fun _ => 0)) context + +noncomputable def canonicalHistoryBoundary : Option (ResolvedRunResult α) → Option (ResolvedRunResult α) + | none => none + | some result => + if DeferredCompletable result.table result.context ∧ MaterializedStartsPublished result.context ∧ + PublishedValues result.context.state then + some { result with context := canonicalizeMaterializedValues result.table result.context } + else none + +noncomputable def canonicalHistoryPrefix : Option (HistoryResolvedPrefix α) → Option (HistoryResolvedPrefix α) + | none => none + | some entry => + if entry.context.Valid ∧ ¬PrivateStructuralHit entry.context ∧ MaterializedStartsPublished entry.context ∧ + PublishedValues entry.context.state then + some { entry with context := historyCanonicalContext entry.context } + else none + +theorem completeHistoryResolvedPrefix_canonicalBoundary + (entry : HistoryResolvedPrefix α) (hconsistent : entry.context.ValuesConsistent) + (hcovered : PendingCoveredBy entry.history entry.context) + (hcard : entry.context.state.pending.card < Fintype.card Digest) : + evalDist (completeHistoryResolvedPrefix (some entry) >>= fun result => pure (canonicalHistoryBoundary result)) = + evalDist (completeHistoryResolvedPrefix (canonicalHistoryPrefix (some entry))) := by + by_cases hgood : entry.context.Valid ∧ ¬PrivateStructuralHit entry.context + · by_cases hpublic : MaterializedStartsPublished entry.context ∧ PublishedValues entry.context.state + · have hguard : entry.context.Valid ∧ ¬PrivateStructuralHit entry.context ∧ MaterializedStartsPublished entry.context ∧ + PublishedValues entry.context.state := ⟨hgood.1, hgood.2, hpublic⟩ + simp only [canonicalHistoryPrefix, if_pos hguard, completeHistoryResolvedPrefix] + unfold historyCanonicalContext + rw [← completeResolvedHistory_canonicalize entry.context entry.remaining entry.history entry.value + (fun _ => 0) hpublic.1 hpublic.2] + unfold completeResolvedHistory + simp only [bind_assoc] + apply evalDist_bind_congr + intro base _ + by_cases hhit : ChainStartHistoryHit entry.context entry.history base + · simp [hhit, canonicalHistoryBoundary] + · have hcomplete := (deferredCompletable_history_clean_iff entry.context entry.history base + hconsistent hcovered hcard hhit).mpr hgood + simp [hhit, canonicalHistoryBoundary, hcomplete, hpublic.1, hpublic.2] + · have hguard : ¬(entry.context.Valid ∧ ¬PrivateStructuralHit entry.context ∧ MaterializedStartsPublished entry.context ∧ + PublishedValues entry.context.state) := fun h => hpublic h.2.2 + simp only [canonicalHistoryPrefix, if_neg hguard, completeHistoryResolvedPrefix] + unfold completeResolvedHistory + simp only [bind_assoc] + rw [← evalDist_sampleOtsHashTable_bind_const (pure (none : Option (ResolvedRunResult α)))] + apply evalDist_bind_congr + intro base _ + by_cases hhit : ChainStartHistoryHit entry.context entry.history base + · simp [hhit, canonicalHistoryBoundary] + · have hguard : ¬(DeferredCompletable (completedStartTable entry.context.state base) entry.context ∧ + MaterializedStartsPublished entry.context ∧ PublishedValues entry.context.state) := fun h => hpublic h.2 + simp [hhit, canonicalHistoryBoundary, hguard] + · have hguard : ¬(entry.context.Valid ∧ ¬PrivateStructuralHit entry.context ∧ MaterializedStartsPublished entry.context ∧ + PublishedValues entry.context.state) := fun h => hgood ⟨h.1, h.2.1⟩ + simp only [canonicalHistoryPrefix, if_neg hguard, completeHistoryResolvedPrefix] + unfold completeResolvedHistory + simp only [bind_assoc] + rw [← evalDist_sampleOtsHashTable_bind_const (pure (none : Option (ResolvedRunResult α)))] + apply evalDist_bind_congr + intro base _ + by_cases hhit : ChainStartHistoryHit entry.context entry.history base + · simp [hhit, canonicalHistoryBoundary] + · have hcomplete : ¬DeferredCompletable (completedStartTable entry.context.state base) entry.context := + fun h => hgood ((deferredCompletable_history_clean_iff entry.context entry.history base + hconsistent hcovered hcard hhit).mp h) + simp [hhit, canonicalHistoryBoundary, hcomplete] + +theorem evalDist_sampledHistoryFilteredRun_canonicalBoundary + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ 2 ^ 126) : + evalDist (sampledHistoryFilteredRun computation context fuel history >>= fun result => pure (canonicalHistoryBoundary result)) = + evalDist (runResolvedHistoryPrefix computation context fuel history >>= fun entry => + completeHistoryResolvedPrefix (canonicalHistoryPrefix entry)) := by + have hfirst := evalDist_history_filtered_runResolved_eq_prefix_observe computation context fuel bound history + (fun result => pure (canonicalHistoryBoundary result)) (by + intro result _hvalues _hstarts hdoomed + simp [canonicalHistoryBoundary, hdoomed]) hconsistent hcovered hbound hbudget + change evalDist (sampledHistoryFilteredRun computation context fuel history >>= fun result => pure (canonicalHistoryBoundary result)) = _ at hfirst + rw [hfirst, bind_assoc] + apply evalDist_bind_congr + intro option hsupport + cases option with + | none => simp [canonicalHistoryPrefix, completeHistoryResolvedPrefix, canonicalHistoryBoundary] + | some entry => + have hentry := historyPrefix_invariant_of_mem computation context fuel bound history entry hcovered hbound hsupport + have hvalues := valuesConsistent_of_mem_historyPrefix computation context fuel history entry hconsistent hsupport + have hspace : 2 ^ 126 < Fintype.card Digest := by norm_num [digestBits] + rw [completeHistoryResolvedPrefix_canonicalBoundary entry hvalues hentry.1 + ((hentry.1.card_le.trans (hentry.2.trans hbudget)).trans_lt hspace)] + +theorem canonicalHistoryBoundary_eq_liveCanonical_of_no_erasure + (result : ResolvedRunResult (α × SplitHashCache)) + (hconsistent : result.context.ValuesConsistent) (hstarts : StartTableAgrees result.context.state result.table) + (hpublished : PublishedValues result.context.state) + (hnoErasure : ¬LiveSigningStartErasure result.table (some result)) : + canonicalHistoryBoundary (some result) = retainCompletableResult (canonicalizeResolvedRun result.table (some result)) := by + by_cases hcomplete : DeferredCompletable result.table result.context + · have hpublic : MaterializedStartsPublished result.context := by + intro start hknown + by_contra hnot + apply hnoErasure + refine ⟨hcomplete, start, hknown, ?_⟩ + change (if start.coordinate ∈ result.context.state.revealed then some (result.table start) else none) = none + simp [hnot] + have hcanonicalComplete : DeferredCompletable result.table (canonicalizeMaterializedValues result.table result.context) := by + obtain ⟨completion, hcompletion⟩ := hcomplete + exact ⟨completion, hcompletion.to_canonicalizedMaterializedValues⟩ + simp [canonicalHistoryBoundary, canonicalizeResolvedRun, retainCompletableResult, hcomplete, hpublic, hpublished, + hcanonicalComplete] + · have hcanonicalDead := (doomedResolvedContext_canonicalizeMaterializedValues ⟨hconsistent, hstarts, hcomplete⟩).2.2 + simp [canonicalHistoryBoundary, canonicalizeResolvedRun, retainCompletableResult, hcomplete, hcanonicalDead] + +theorem canonicalHistoryPrefix_history_length + (entry result : HistoryResolvedPrefix α) (hresult : canonicalHistoryPrefix (some entry) = some result) : + result.history = entry.history := by + simp only [canonicalHistoryPrefix] at hresult + split_ifs at hresult + · cases hresult + rfl + +theorem expected_canonicalHistoryBoundary_unresolvedStart_le + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) + (candidate : DeferredContext → α → Option Probe) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ 2 ^ 126) : + (∑' result, Pr[= result | sampledHistoryFilteredRun computation context fuel history] * + historyUnresolvedStartAllowance candidate (canonicalHistoryBoundary result)) ≤ + (∑' result, Pr[= result | sampledHistoryFilteredRun computation context fuel history] * + historyUnresolvedStartCharge candidate (canonicalHistoryBoundary result)) * + ((4 / 3 : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) := by + have hdist := evalDist_sampledHistoryFilteredRun_canonicalBoundary computation context fuel bound history + hconsistent hcovered hbound hbudget + have hcost (cost : Option (ResolvedRunResult α) → ℝ≥0∞) : + (∑' result, Pr[= result | sampledHistoryFilteredRun computation context fuel history] * cost (canonicalHistoryBoundary result)) = + ∑' result, Pr[= result | runResolvedHistoryPrefix computation context fuel history >>= fun entry => + completeHistoryResolvedPrefix (canonicalHistoryPrefix entry)] * cost result := by + have hprob : ∀ result, Pr[= result | sampledHistoryFilteredRun computation context fuel history >>= + fun result => pure (canonicalHistoryBoundary result)] = + Pr[= result | runResolvedHistoryPrefix computation context fuel history >>= fun entry => + completeHistoryResolvedPrefix (canonicalHistoryPrefix entry)] := fun result => _root_.OracleComp.probOutput_congr rfl hdist + calc + _ = ∑' result, Pr[= result | sampledHistoryFilteredRun computation context fuel history >>= + fun result => pure (canonicalHistoryBoundary result)] * cost result := by + simp only [tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + _ = _ := tsum_congr fun result => congrArg (fun p => p * cost result) (hprob result) + rw [hcost, hcost] + simp only [tsum_probOutput_bind_mul] + rw [← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro option + by_cases hsupport : option ∈ support (runResolvedHistoryPrefix computation context fuel history) + · cases option with + | none => simp [canonicalHistoryPrefix, completeHistoryResolvedPrefix, historyUnresolvedStartAllowance, historyUnresolvedStartCharge] + | some entry => + cases hcanonical : canonicalHistoryPrefix (some entry) with + | none => simp [completeHistoryResolvedPrefix, historyUnresolvedStartAllowance, historyUnresolvedStartCharge] + | some result => + have hlength := (historyPrefix_invariant_of_mem computation context fuel bound history entry hcovered hbound hsupport).2 + rw [← canonicalHistoryPrefix_history_length entry result hcanonical] at hlength + have hlocal := expected_completeHistoryResolvedPrefix_unresolvedStart_le result candidate (hlength.trans hbudget) + simpa only [mul_assoc] using mul_le_mul' le_rfl hlocal + · simp [probOutput_eq_zero_of_not_mem_support hsupport] + +theorem retainCompletableResult_canonicalHistoryBoundary (result : Option (ResolvedRunResult α)) : + retainCompletableResult (canonicalHistoryBoundary result) = canonicalHistoryBoundary result := by + cases result with + | none => rfl + | some result => + simp only [canonicalHistoryBoundary] + split_ifs with hguard + · have hcomplete : DeferredCompletable result.table (canonicalizeMaterializedValues result.table result.context) := by + obtain ⟨completion, hcompletion⟩ := hguard.1 + exact ⟨completion, hcompletion.to_canonicalizedMaterializedValues⟩ + simp [retainCompletableResult, hcomplete] + · rfl + +theorem probEvent_canonicalHistoryBoundary_unresolvedStart_le + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) + (candidate : DeferredContext → α → Option Probe) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ 2 ^ 126) : + Pr[LiveUnresolvedStartHit candidate | sampledHistoryFilteredRun computation context fuel history >>= + fun result => pure (canonicalHistoryBoundary result)] ≤ + (∑' result, Pr[= result | sampledHistoryFilteredRun computation context fuel history] * + historyUnresolvedStartCharge candidate (canonicalHistoryBoundary result)) * + ((4 / 3 : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) := by + rw [probEvent_liveUnresolvedStartHit_eq_expected] + simp only [tsum_probOutput_bind_mul, tsum_probOutput_pure_mul, retainCompletableResult_canonicalHistoryBoundary] + exact expected_canonicalHistoryBoundary_unresolvedStart_le computation context fuel bound history candidate + hconsistent hcovered hbound hbudget + +theorem historyCanonicalContext_start_values + (context : DeferredContext) (hpublic : MaterializedStartsPublished context) (hpublished : PublishedValues context.state) + (start : OtsSecretIndex) : + (historyCanonicalContext context).state.values start.coordinate = context.state.values start.coordinate := + canonicalize_start_values_eq_of_materializedStartsPublished _ context hpublic hpublished + (startTableAgrees_completedStartTable context.state (fun _ => 0)) start + +theorem historyCanonicalContext_completedStartTable + (context : DeferredContext) (hpublic : MaterializedStartsPublished context) (hpublished : PublishedValues context.state) + (base : OtsSecretIndex → HashOutput) : + completedStartTable (historyCanonicalContext context).state base = completedStartTable context.state base := by + funext start + unfold completedStartTable + rw [historyCanonicalContext_start_values context hpublic hpublished start] + +theorem historyCanonicalContext_canonical + (context : DeferredContext) (hconsistent : context.ValuesConsistent) + (hpublic : MaterializedStartsPublished context) (hpublished : PublishedValues context.state) + (base : OtsSecretIndex → HashOutput) : + CanonicalMaterializedValues (completedStartTable (historyCanonicalContext context).state base) (historyCanonicalContext context) := by + rw [historyCanonicalContext_completedStartTable context hpublic hpublished base] + have hcontext : historyCanonicalContext context = canonicalizeMaterializedValues (completedStartTable context.state base) context := + canonicalize_completedStartTable_independent context (fun _ => 0) base hpublished + rw [hcontext] + exact canonicalizeMaterializedValues_canonical _ context hconsistent + +theorem canonicalHistoryPrefix_invariant + (entry result : HistoryResolvedPrefix α) (hresult : canonicalHistoryPrefix (some entry) = some result) + (hconsistent : entry.context.ValuesConsistent) (hcovered : PendingCoveredBy entry.history entry.context) : + result.context.ValuesConsistent ∧ PendingCoveredBy result.history result.context ∧ + PublishedValues result.context.state ∧ + ∀ base, CanonicalMaterializedValues (completedStartTable result.context.state base) result.context := by + simp only [canonicalHistoryPrefix] at hresult + split_ifs at hresult with hguard + cases hresult + refine ⟨canonicalizeMaterializedValues_valuesConsistent _ _ hconsistent, ?_, ?_, ?_⟩ + · exact hcovered.of_subset (Finset.Subset.refl _) + · exact hguard.2.2.2.to_canonicalizedMaterializedValues + · exact historyCanonicalContext_canonical entry.context hconsistent hguard.2.2.1 hguard.2.2.2 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryCanonicalRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryCanonicalRisk.lean new file mode 100644 index 00000000..5e4ef059 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryCanonicalRisk.lean @@ -0,0 +1,111 @@ +import SphincsSecurity.Proof.OtsProbeHistoryErasureBridge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable +set_option backward.isDefEq.respectTransparency false + +noncomputable def sampledCanonicalHistoryTrace + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) (cache : SplitHashCache) : + ProbComp (Option (ResolvedRunResult (α × SplitHashCache)) × Bool) := do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then pure (none, false) + else + runCanonicalStartErasureTrace parameter root (completedStartTable context.state base) ftsSecret + computation context fuel cache false + +theorem evalDist_eraseFlagged_historyTrace_eq_guarded + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hpublished : PublishedValues context.state) + (hcanonical : ∀ base, CanonicalMaterializedValues (completedStartTable context.state base) context) : + evalDist (eraseFlaggedResult <$> sampledCanonicalHistoryTrace parameter root ftsSecret computation context fuel history cache) = + evalDist (sampledGuardedCanonicalNative parameter root ftsSecret computation context fuel history cache) := by + simp only [sampledCanonicalHistoryTrace, sampledGuardedCanonicalNative, map_bind] + apply evalDist_bind_congr + intro base _ + split_ifs + · simp [eraseFlaggedResult] + · exact evalDist_eraseFlagged_trace_eq_guardedCanonicalNative parameter root (completedStartTable context.state base) + ftsSecret computation context fuel cache hconsistent (startTableAgrees_completedStartTable context.state base) + hpublished (hcanonical base) + +theorem expected_sampledGuardedCanonical_le_historyTrace + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) (cache : SplitHashCache) + (cost : Option (ResolvedRunResult (α × SplitHashCache)) → ENNReal) (hnone : cost none = 0) + (hconsistent : context.ValuesConsistent) (hpublished : PublishedValues context.state) + (hcanonical : ∀ base, CanonicalMaterializedValues (completedStartTable context.state base) context) : + (∑' result, Pr[= result | sampledGuardedCanonicalNative parameter root ftsSecret computation context fuel history cache] * cost result) ≤ + ∑' result, Pr[= result | Prod.fst <$> sampledCanonicalHistoryTrace parameter root ftsSecret computation context fuel history cache] * + cost result := by + have hdist := evalDist_eraseFlagged_historyTrace_eq_guarded parameter root ftsSecret computation context fuel history cache + hconsistent hpublished hcanonical + have heq : + (∑' result, Pr[= result | sampledGuardedCanonicalNative parameter root ftsSecret computation context fuel history cache] * cost result) = + ∑' result, Pr[= result | eraseFlaggedResult <$> sampledCanonicalHistoryTrace parameter root ftsSecret computation context fuel history cache] * + cost result := by + apply tsum_congr + intro result + rw [_root_.OracleComp.probOutput_congr rfl hdist] + rw [heq] + exact expected_erased_le_fst _ cost hnone + +theorem probEvent_historyCanonical_unresolvedStart_le_charge_add_erasure + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) (cache : SplitHashCache) + (candidate : DeferredContext → (α × SplitHashCache) → Option Probe) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hpublished : PublishedValues context.state) + (hcanonical : ∀ base, CanonicalMaterializedValues (completedStartTable context.state base) context) + (hbound : computation.IsQueryBoundP IsOuterHash bound) (hbudget : history.length + bound ≤ 2 ^ 126) : + Pr[LiveUnresolvedStartHit candidate | + Prod.fst <$> sampledCanonicalHistoryTrace parameter root ftsSecret computation context fuel history cache] ≤ + (∑' result, Pr[= result | Prod.fst <$> + sampledCanonicalHistoryTrace parameter root ftsSecret computation context fuel history cache] * + historyUnresolvedStartCharge candidate result) * ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + + Pr[fun result => result.2 = true | + sampledCanonicalHistoryTrace parameter root ftsSecret computation context fuel history cache] := by + have hcomparison := probEvent_fst_le_erased_add_flag + (sampledCanonicalHistoryTrace parameter root ftsSecret computation context fuel history cache) + (LiveUnresolvedStartHit candidate) + have hdist := evalDist_eraseFlagged_historyTrace_eq_guarded parameter root ftsSecret computation context fuel history cache + hconsistent hpublished hcanonical + rw [OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) hdist] at hcomparison + apply hcomparison.trans + apply add_le_add _ le_rfl + exact (probEvent_guardedCanonical_unresolvedStart_le parameter root ftsSecret computation context fuel bound history cache candidate + hconsistent hcovered hpublished hbound hbudget).trans + (mul_le_mul' (expected_sampledGuardedCanonical_le_historyTrace parameter root ftsSecret computation context fuel history cache + (historyUnresolvedStartCharge candidate) rfl hconsistent hpublished hcanonical) le_rfl) + +theorem evalDist_historyTrace_projection + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) : + evalDist (Prod.fst <$> sampledCanonicalHistoryTrace parameter root ftsSecret computation context fuel history cache) = + evalDist (do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then pure none + else + runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root + (completedStartTable context.state base) ftsSecret) computation context fuel + (completedStartTable context.state base) cache) := by + simp only [sampledCanonicalHistoryTrace, map_bind] + apply evalDist_bind_congr + intro base _ + split_ifs + · simp + · exact runCanonicalStartErasureTrace_projection parameter root (completedStartTable context.state base) ftsSecret computation + context fuel cache false hconsistent (startTableAgrees_completedStartTable context.state base) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryCompletionInterpreter.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryCompletionInterpreter.lean new file mode 100644 index 00000000..813a2f59 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryCompletionInterpreter.lean @@ -0,0 +1,200 @@ +import SphincsSecurity.Proof.OtsProbeHistoryRevealSampling + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 100000 + +noncomputable def historyCompletionQueryStep (history : List Probe) + (input : (LazyRevealProbe.World Coordinate).Domain) + (next : (LazyRevealProbe.World Coordinate).Range input → DeferredContext → Nat → ProbComp (Option α)) + (context : DeferredContext) (fuel : Nat) : ProbComp (Option α) := + match input with + | .uniform n => do + let output ← (liftM (unifSpec.query n) : ProbComp _) + next output context fuel + | .hashOutput => do + let output ← LazyRevealProbe.sampleHashOutput + next output context fuel + | .ensure coordinate => next () { context with state := context.state.ensure coordinate } fuel + | .peek coordinate => next (context.state.values coordinate) context fuel + | .publish coordinate => next () { context with state := context.state.publish coordinate } fuel + | .probe _ _ => pure none + | .reveal (.chainStart lay tree leafIdx chainIdx) => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + match context.state.values index.coordinate with + | some output => + if context.state.hitAt index.coordinate output then pure none + else next output { context with state := context.state.materialize index.coordinate output } fuel + | none => do + let output ← LazyRevealProbe.sampleHashOutput + if ChainStartHistoryOutputHit history index output then pure none + else next output { context with state := context.state.materialize index.coordinate output } fuel + | .reveal (.position position) => do + let option ← resolveDeferredReveal (startTableAvoidingPending context) position context + match option with + | none => pure none + | some resolved => + next resolved.output + { state := context.state.materialize (.position position) resolved.output, values := resolved.values } fuel + +noncomputable def runResolvedHistoryCompletion (history : List Probe) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + DeferredContext → Nat → ProbComp (Option (ResolvedRunResult α)) := + OracleComp.construct + (fun value context fuel => do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then pure none + else pure (some ⟨context, fuel, value, completedStartTable context.state base⟩)) + (fun input _ next => historyCompletionQueryStep history input next) computation + +theorem runResolvedHistoryCompletion_query_bind + (history : List Probe) (input : (LazyRevealProbe.World Coordinate).Domain) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) : + runResolvedHistoryCompletion history (OracleSpec.query input >>= next) context fuel = + historyCompletionQueryStep history input (fun output => runResolvedHistoryCompletion history (next output)) context fuel := rfl + +theorem evalDist_history_filtered_draw_swap + (context : DeferredContext) (history : List Probe) (draw : ProbComp α) + (next : (OtsSecretIndex → HashOutput) → α → ProbComp β) (failure : ProbComp β) : + evalDist (do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then failure + else do let output ← draw; next base output) = + evalDist (do + let output ← draw + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then failure else next base output) := by + calc + _ = evalDist (do + let base ← sampleOtsHashTable + let output ← draw + if ChainStartHistoryHit context history base then failure else next base output) := by + apply evalDist_bind_congr + intro base _hbase + by_cases hhit : ChainStartHistoryHit context history base + · simp only [if_pos hhit] + exact (OracleComp.DeferredSampling.evalDist_bind_const_neverFails draw (by simp) failure).symm + · simp only [if_neg hhit] + _ = _ := evalDist_bind_bind_swap _ _ _ + +set_option maxRecDepth 1000 in +theorem evalDist_history_filtered_runResolved_eq_completion_of_probeFree + (history : List Probe) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (hcovered : PendingCoveredBy history context) + (hcard : context.state.pending.card < Fintype.card Digest) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) : + evalDist (do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then pure none + else runResolvedFromTable context fuel (completedStartTable context.state base) computation) = + evalDist (runResolvedHistoryCompletion history computation context fuel) := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + rw [runResolvedHistoryCompletion, OracleComp.construct_pure] + apply evalDist_bind_congr + intro base _hbase + split_ifs + · rfl + · simp only [runResolvedFromTable, OracleComp.construct_pure] + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [runResolvedHistoryCompletion_query_bind] + cases input with + | probe coordinate digest => simpa [LazyRevealProbe.IsProbe] using hbound.1 + | uniform n => + simp only [historyCompletionQueryStep] + simp_rw [runResolvedFromTable_uniform_query_bind] + rw [evalDist_history_filtered_draw_swap] + apply evalDist_bind_congr + intro output _houtput + exact ih output context fuel hcovered hcard (hbound.2 output) + | hashOutput => + simp only [historyCompletionQueryStep] + simp_rw [runResolvedFromTable_hashOutput_query_bind] + rw [evalDist_history_filtered_draw_swap] + apply evalDist_bind_congr + intro output _houtput + exact ih output context fuel hcovered hcard (hbound.2 output) + | ensure coordinate => + simp only [historyCompletionQueryStep] + simp_rw [runResolvedFromTable_ensure_query_bind] + exact ih () { context with state := context.state.ensure coordinate } fuel hcovered hcard (hbound.2 ()) + | peek coordinate => + simp only [historyCompletionQueryStep] + simp_rw [runResolvedFromTable_peek_query_bind] + exact ih (context.state.values coordinate) context fuel hcovered hcard (hbound.2 _) + | publish coordinate => + simp only [historyCompletionQueryStep] + simp_rw [runResolvedFromTable_publish_query_bind] + exact ih () { context with state := context.state.publish coordinate } fuel hcovered hcard (hbound.2 ()) + | reveal coordinate => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + cases hknown : context.state.values index.coordinate with + | some output => + have hstep := evalDist_history_filtered_runResolved_revealStart_known context history fuel index output next hknown + dsimp only [index, OtsSecretIndex.coordinate] at hstep + rw [hstep] + have hknown' := hknown + dsimp only [index, OtsSecretIndex.coordinate] at hknown' + simp only [historyCompletionQueryStep, OtsSecretIndex.coordinate, hknown'] + change _ = evalDist (if context.state.hitAt (.chainStart lay tree leafIdx chainIdx) output then pure none else + runResolvedHistoryCompletion history (next output) + { context with state := context.state.materialize (.chainStart lay tree leafIdx chainIdx) output } fuel) + by_cases hhit : context.state.hitAt (.chainStart lay tree leafIdx chainIdx) output + · simp only [if_pos hhit] + · simp only [if_neg hhit] + exact ih output + { context with state := context.state.materialize (.chainStart lay tree leafIdx chainIdx) output } + fuel (hcovered.of_subset (Finset.filter_subset _ _)) + ((Finset.card_le_card (Finset.filter_subset _ _)).trans_lt hcard) (hbound.2 output) + | none => + have hstep := evalDist_history_filtered_runResolved_revealStart_missing context history fuel index next hcovered hknown + dsimp only [index, OtsSecretIndex.coordinate] at hstep + rw [hstep] + have hknown' := hknown + dsimp only [index, OtsSecretIndex.coordinate] at hknown' + simp only [historyCompletionQueryStep, OtsSecretIndex.coordinate, hknown'] + change _ = evalDist (do + let output ← LazyRevealProbe.sampleHashOutput + if ChainStartHistoryOutputHit history ⟨lay, tree, leafIdx, chainIdx⟩ output then pure none else + runResolvedHistoryCompletion history (next output) + { context with state := context.state.materialize (.chainStart lay tree leafIdx chainIdx) output } fuel) + apply evalDist_bind_congr + intro output _houtput + by_cases hhit : ChainStartHistoryOutputHit history ⟨lay, tree, leafIdx, chainIdx⟩ output + · simp only [if_pos hhit] + · simp only [if_neg hhit] + exact ih output + { context with state := context.state.materialize (.chainStart lay tree leafIdx chainIdx) output } + fuel (hcovered.of_subset (Finset.filter_subset _ _)) + ((Finset.card_le_card (Finset.filter_subset _ _)).trans_lt hcard) (hbound.2 output) + | position position => + simp only [historyCompletionQueryStep] + rw [evalDist_history_filtered_runResolved_revealPosition context history fuel position next hcovered hcard] + change _ = evalDist (do + let option ← resolveDeferredReveal (startTableAvoidingPending context) position context + match option with + | none => pure none + | some resolved => + runResolvedHistoryCompletion history (next resolved.output) + { state := context.state.materialize (.position position) resolved.output, values := resolved.values } fuel) + apply evalDist_bind_congr + intro option _hoption + cases option with + | none => rfl + | some resolved => + exact ih resolved.output + { state := context.state.materialize (.position position) resolved.output, values := resolved.values } + fuel (hcovered.of_subset (Finset.filter_subset _ _)) + ((Finset.card_le_card (Finset.filter_subset _ _)).trans_lt hcard) (hbound.2 resolved.output) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryErasureBridge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryErasureBridge.lean new file mode 100644 index 00000000..a45f3ec2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryErasureBridge.lean @@ -0,0 +1,288 @@ +import SphincsSecurity.Proof.OtsProbeHistoryOuterComposition +import SphincsSecurity.Proof.OtsProbeStartErasureBound + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot sampleOtsHashTable +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 4000 + +noncomputable def eraseFlaggedResult (result : Option (ResolvedRunResult α) × Bool) : + Option (ResolvedRunResult α) := if result.2 then none else result.1 + +theorem runCanonicalStartErasureTrace_query_bind + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range query → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (flagged : Bool) : + runCanonicalStartErasureTrace parameter root table ftsSecret (OracleSpec.query query >>= next) context fuel cache flagged = + (if DeferredCompletable table context then do + let step ← canonicalStartErasureStep parameter root table ftsSecret query context fuel cache + match step.1 with + | none => pure (none, flagged || step.2) + | some result => + runCanonicalStartErasureTrace parameter root table ftsSecret (next result.value.1) + result.context result.remaining result.value.2 (flagged || step.2) + else pure (none, flagged)) := by + rfl + +theorem runGuardedCanonicalNative_query_bind + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range query → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runGuardedCanonicalNative parameter root ftsSecret (OracleSpec.query query >>= next) context fuel table cache = + (do + let raw ← runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret query).run cache) + match canonicalHistoryBoundary raw with + | none => pure none + | some result => + runGuardedCanonicalNative parameter root ftsSecret (next result.value.1) + result.context result.remaining result.table result.value.2) := by + rfl + +theorem canonicalHistoryBoundary_of_erasure + (result : ResolvedRunResult (α × SplitHashCache)) + (herasure : LiveSigningStartErasure result.table (some result)) : + canonicalHistoryBoundary (some result) = none := by + have hnot : ¬MaterializedStartsPublished result.context := by + intro hpublic + obtain ⟨_, start, hknown, herased⟩ := herasure + have hrevealed := hpublic start hknown + change (if start.coordinate ∈ result.context.state.revealed then some (result.table start) else none) = none at herased + simp [hrevealed] at herased + simp [canonicalHistoryBoundary, hnot] + +theorem resolvedPreservesPublishedValues_maskedChronologicalExpandedAdversaryImpl + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) : + ResolvedPreservesPublished (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret query) := by + cases query with + | inl query => exact resolvedPreservesPublishedValuesImpl_probingRomImpl parameter query + | inr message => exact resolvedPreservesPublishedValues_maskedPublishedChronologicalSign parameter root ftsSecret message + +theorem evalDist_guardedCanonicalNative_of_not_completable + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) : + evalDist (runGuardedCanonicalNative parameter root ftsSecret computation context fuel table cache) = + evalDist (pure none : ProbComp (Option (ResolvedRunResult (α × SplitHashCache)))) := by + induction computation using OracleComp.inductionOn with + | pure value => simp [runGuardedCanonicalNative, canonicalHistoryBoundary, hdoomed] + | query_bind query next ih => + rw [runGuardedCanonicalNative, OracleComp.construct_query_bind] + apply evalDist_runResolved_observe_of_not_completable context fuel table _ (pure none) _ + (by rfl) _ hconsistent hstarts hdoomed + intro result _ _ hdead + simp [canonicalHistoryBoundary, hdead] + +theorem evalDist_eraseFlagged_trace_true + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + evalDist (eraseFlaggedResult <$> runCanonicalStartErasureTrace parameter root table ftsSecret computation context fuel cache true) = + evalDist (pure none : ProbComp (Option (ResolvedRunResult (α × SplitHashCache)))) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + simp only [runCanonicalStartErasureTrace, OracleComp.construct_pure] + split_ifs <;> simp [eraseFlaggedResult] + | query_bind query next ih => + rw [runCanonicalStartErasureTrace_query_bind] + split_ifs + · rw [map_bind] + calc + _ = evalDist (canonicalStartErasureStep parameter root table ftsSecret query context fuel cache >>= fun _ => + (pure none : ProbComp (Option (ResolvedRunResult (α × SplitHashCache))))) := by + apply evalDist_bind_congr + rintro ⟨option, flag⟩ _ + cases option with + | none => simp [eraseFlaggedResult] + | some entry => simpa only [Bool.true_or] using ih entry.value.1 entry.context entry.remaining entry.value.2 + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails _ (by simp [canonicalStartErasureStep, runResolvedFromTable]) _ + · simp [eraseFlaggedResult] + +theorem evalDist_eraseFlagged_trace_eq_guardedCanonicalNative + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) (hcanonical : CanonicalMaterializedValues table context) : + evalDist (eraseFlaggedResult <$> runCanonicalStartErasureTrace parameter root table ftsSecret computation context fuel cache false) = + evalDist (runGuardedCanonicalNative parameter root ftsSecret computation context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + have hpublic := materializedStartsPublished_of_canonical table context hcanonical + simp only [runCanonicalStartErasureTrace, runGuardedCanonicalNative, OracleComp.construct_pure] + by_cases hcomplete : DeferredCompletable table context <;> + simp [eraseFlaggedResult, canonicalHistoryBoundary, hcomplete, hpublic, hpublished, + canonicalizeMaterializedValues_eq_of_canonical table context hcanonical] + | query_bind query next ih => + by_cases hcomplete : DeferredCompletable table context + · rw [runCanonicalStartErasureTrace_query_bind, if_pos hcomplete, runGuardedCanonicalNative_query_bind] + simp only [canonicalStartErasureStep, map_bind, bind_assoc, pure_bind, Bool.false_or] + apply evalDist_bind_congr + intro option hoption + cases option with + | none => simp [canonicalizeResolvedRun, canonicalHistoryBoundary, LiveSigningStartErasure, eraseFlaggedResult] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table result hconsistent hstarts hoption + have hpub := resolvedPreservesPublishedValues_maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret query + context cache fuel table result hpublished hoption + have hcanonicalNext := canonicalizeMaterializedValues_canonical table result.context hcore.2.1 + have hconsistentNext := canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1 + have hstartsNext := canonicalizeMaterializedValues_startTableAgrees table result.context + have hpubNext : PublishedValues (canonicalizeMaterializedValues table result.context).state := hpub.to_canonicalizedMaterializedValues + by_cases herasure : LiveSigningStartErasure table (some result) + · have hboundary := canonicalHistoryBoundary_of_erasure result (hcore.1 ▸ herasure) + simp only [hboundary, decide_true, herasure, canonicalizeResolvedRun] + exact evalDist_eraseFlagged_trace_true parameter root table ftsSecret (next result.value.1) + (canonicalizeMaterializedValues table result.context) result.remaining result.value.2 + · have hboundary := canonicalHistoryBoundary_eq_liveCanonical_of_no_erasure result hcore.2.1 + (hcore.1 ▸ hcore.2.2) hpub (hcore.1 ▸ herasure) + rw [hboundary] + simp only [canonicalizeResolvedRun, hcore.1, decide_eq_false herasure] + by_cases hlive : DeferredCompletable table (canonicalizeMaterializedValues table result.context) + · simp only [retainCompletableResult, if_pos hlive] + exact ih result.value.1 (canonicalizeMaterializedValues table result.context) result.remaining result.value.2 + hconsistentNext hstartsNext hpubNext hcanonicalNext + · simp only [retainCompletableResult, if_neg hlive] + rw [runCanonicalStartErasureTrace_of_not_completable parameter root table ftsSecret (next result.value.1) + (canonicalizeMaterializedValues table result.context) result.remaining result.value.2 false hlive] + simp [eraseFlaggedResult] + · rw [runCanonicalStartErasureTrace_of_not_completable parameter root table ftsSecret _ context fuel cache false hcomplete] + simp only [map_pure, eraseFlaggedResult, Bool.false_eq_true, if_false] + exact (evalDist_guardedCanonicalNative_of_not_completable parameter root ftsSecret _ context fuel table cache + hconsistent hstarts hcomplete).symm + +theorem probEvent_fst_le_erased_add_flag + (run : ProbComp (Option (ResolvedRunResult α) × Bool)) (event : Option (ResolvedRunResult α) → Prop) : + Pr[event | Prod.fst <$> run] ≤ + Pr[event | eraseFlaggedResult <$> run] + Pr[fun result => result.2 = true | run] := by + simp only [probEvent_map] + calc + _ ≤ Pr[fun result => event (eraseFlaggedResult result) ∨ result.2 = true | run] := by + apply probEvent_mono + intro result _ hevent + by_cases hflag : result.2 = true + · exact Or.inr hflag + · exact Or.inl (by simpa [eraseFlaggedResult, hflag] using hevent) + _ ≤ _ := probEvent_or_le _ _ _ + +theorem expected_erased_le_fst + (run : ProbComp (Option (ResolvedRunResult α) × Bool)) + (cost : Option (ResolvedRunResult α) → ENNReal) (hnone : cost none = 0) : + (∑' result, Pr[= result | eraseFlaggedResult <$> run] * cost result) ≤ + ∑' result, Pr[= result | Prod.fst <$> run] * cost result := by + simp only [tsum_probOutput_map_mul] + apply ENNReal.tsum_le_tsum + intro result + apply mul_le_mul' le_rfl + by_cases hflag : result.2 = true + · simp [eraseFlaggedResult, hflag, hnone] + · simp [eraseFlaggedResult, hflag] + +theorem probEvent_canonical_le_guarded_add_erasure + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (event : Option (ResolvedRunResult (α × SplitHashCache)) → Prop) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) (hcanonical : CanonicalMaterializedValues table context) : + Pr[event | runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + computation context fuel table cache] ≤ + Pr[event | runGuardedCanonicalNative parameter root ftsSecret computation context fuel table cache] + + Pr[fun result => result.2 = true | + runCanonicalStartErasureTrace parameter root table ftsSecret computation context fuel cache false] := by + have hprojection := runCanonicalStartErasureTrace_projection parameter root table ftsSecret computation context fuel cache + false hconsistent hstarts + have hguard := evalDist_eraseFlagged_trace_eq_guardedCanonicalNative parameter root table ftsSecret computation context fuel cache + hconsistent hstarts hpublished hcanonical + rw [← OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) hprojection, + ← OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) hguard] + exact probEvent_fst_le_erased_add_flag _ event + +noncomputable def guardedCanonicalAfterRoot + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) : + ProbComp (Option (ResolvedRunResult (α × SplitHashCache))) := do + let root ← runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + match root with + | none => pure none + | some root => + runGuardedCanonicalNative parameter root.value.1 ftsSecret (continuation root.value.1) + root.context root.remaining table root.value.2 + +theorem evalDist_eraseFlagged_afterRoot_eq_guarded + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) : + evalDist (eraseFlaggedResult <$> canonicalStartErasureAfterRoot parameter table ftsSecret fuel continuation) = + evalDist (guardedCanonicalAfterRoot parameter table ftsSecret fuel continuation) := by + simp only [canonicalStartErasureAfterRoot, guardedCanonicalAfterRoot, map_bind] + apply evalDist_bind_congr + intro option hoption + cases option with + | none => simp [eraseFlaggedResult] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ _ fuel table result + DeferredContext.valid_empty.valuesConsistent (startTableAgrees_empty table) hoption + exact evalDist_eraseFlagged_trace_eq_guardedCanonicalNative parameter result.value.1 table ftsSecret + (continuation result.value.1) result.context result.remaining result.value.2 hcore.2.1 hcore.2.2 + (resolvedPreservesPublished_maskedPublishedTreeRoot _ _ _ _ _ publishedValues_empty hoption) + (canonicalMaterializedValues_of_mem_maskedPublishedTreeRoot parameter table fuel result hoption) + +theorem probEvent_canonicalAfterRoot_le_guarded_add_inv216 + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) + (event : Option (ResolvedRunResult (α × SplitHashCache)) → Prop) : + Pr[event | Prod.fst <$> canonicalStartErasureAfterRoot parameter table ftsSecret fuel continuation] ≤ + Pr[event | guardedCanonicalAfterRoot parameter table ftsSecret fuel continuation] + ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + have hguard := evalDist_eraseFlagged_afterRoot_eq_guarded parameter table ftsSecret fuel continuation + rw [← OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) hguard] + exact (probEvent_fst_le_erased_add_flag _ event).trans + (add_le_add le_rfl (probEvent_canonicalStartErasureAfterRoot_le_inv216 parameter table ftsSecret fuel continuation)) + +noncomputable def sampledGuardedCanonicalRetained (adversary : Adversary) (fuel : Nat) : + ProbComp (Option (ResolvedRunResult (RetainedGameResult × SplitHashCache))) := do + let parameter ← sampleParameter + let table ← sampleOtsHashTable + let ftsSecret ← sampleFtsSecrets + guardedCanonicalAfterRoot parameter table ftsSecret fuel fun root => + (fun rest => (root, rest)) <$> retainedGameRestComputation adversary ⟨root, parameter⟩ + +theorem evalDist_eraseFlagged_sampledTrace_eq_guarded (adversary : Adversary) (fuel : Nat) : + evalDist (eraseFlaggedResult <$> sampledCanonicalStartErasureTrace adversary fuel) = + evalDist (sampledGuardedCanonicalRetained adversary fuel) := by + simp only [sampledCanonicalStartErasureTrace, sampledGuardedCanonicalRetained, map_bind] + apply evalDist_bind_congr + intro parameter _ + apply evalDist_bind_congr + intro table _ + apply evalDist_bind_congr + intro ftsSecret _ + exact evalDist_eraseFlagged_afterRoot_eq_guarded parameter table ftsSecret fuel _ + +theorem probEvent_sampledCanonical_le_guarded_add_inv216 + (adversary : Adversary) (fuel : Nat) + (event : Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)) → Prop) : + Pr[event | Prod.fst <$> sampledCanonicalStartErasureTrace adversary fuel] ≤ + Pr[event | sampledGuardedCanonicalRetained adversary fuel] + ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + rw [← OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) (evalDist_eraseFlagged_sampledTrace_eq_guarded adversary fuel)] + exact (probEvent_fst_le_erased_add_flag _ event).trans + (add_le_add le_rfl (probEvent_sampledCanonicalStartErasureTrace_le_inv216 adversary fuel)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryLiveRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryLiveRisk.lean new file mode 100644 index 00000000..3f046d50 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryLiveRisk.lean @@ -0,0 +1,323 @@ +import SphincsSecurity.Proof.OtsProbeHistoryPrefixRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 1000 + +theorem valuesConsistent_of_mem_historyPrefix + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) (result : HistoryResolvedPrefix α) + (hconsistent : context.ValuesConsistent) + (hresult : some result ∈ support (runResolvedHistoryPrefix computation context fuel history)) : + result.context.ValuesConsistent := by + induction computation using OracleComp.inductionOn generalizing context fuel history with + | pure value => + simp only [runResolvedHistoryPrefix, OracleComp.construct_pure, mem_support_pure_iff, Option.some.injEq] at hresult + subst result + exact hconsistent + | query_bind input next ih => + rw [runResolvedHistoryPrefix_query_bind] at hresult + cases input with + | uniform n => + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel history hconsistent htail + | hashOutput => + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel history hconsistent htail + | ensure coordinate => + exact ih () { context with state := context.state.ensure coordinate } fuel history hconsistent hresult + | peek coordinate => + exact ih (context.state.values coordinate) context fuel history hconsistent hresult + | publish coordinate => + exact ih () { context with state := context.state.publish coordinate } fuel history hconsistent hresult + | probe coordinate digest => + cases fuel with + | zero => simp [historyAdaptiveQueryStep] at hresult + | succ remaining => + simp only [historyAdaptiveQueryStep] at hresult + split_ifs at hresult with hrevealed + · exact ih () context remaining history hconsistent hresult + · exact ih () { context with state := context.state.addPending coordinate digest } + remaining (history ++ [⟨coordinate, digest⟩]) (hconsistent.addPending coordinate digest) hresult + | reveal coordinate => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep, OtsSecretIndex.coordinate] at hresult + cases hknown : context.state.values (.chainStart lay tree leafIdx chainIdx) with + | some output => + rw [hknown] at hresult + dsimp only at hresult + split_ifs at hresult with hhit + · simp at hresult + · exact ih output + { context with state := context.state.materialize (.chainStart lay tree leafIdx chainIdx) output } + fuel history (valuesConsistent_materialize_chainStart context ⟨lay, tree, leafIdx, chainIdx⟩ output hconsistent) hresult + | none => + rw [hknown] at hresult + dsimp only at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + split_ifs at htail with hhit + · simp at htail + · exact ih output + { context with state := context.state.materialize (.chainStart lay tree leafIdx chainIdx) output } + fuel history (valuesConsistent_materialize_chainStart context ⟨lay, tree, leafIdx, chainIdx⟩ output hconsistent) htail + | position position => + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep, mem_support_bind_iff] at hresult + obtain ⟨option, hoption, htail⟩ := hresult + cases option with + | none => simp at htail + | some resolved => + exact ih resolved.output + { state := context.state.materialize (.position position) resolved.output, values := resolved.values } + fuel history + (hconsistent.materializeResolvedPosition_of (startTableAvoidingPending context) position resolved hoption) htail + +theorem deferredCompletable_history_clean_iff + (context : DeferredContext) (history : List Probe) (base : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hcard : context.state.pending.card < Fintype.card Digest) + (hclean : ¬ChainStartHistoryHit context history base) : + DeferredCompletable (completedStartTable context.state base) context ↔ + context.Valid ∧ ¬PrivateStructuralHit context := by + constructor + · intro hcomplete + exact ⟨valid_of_resolvedCore_completable _ context hconsistent + (startTableAgrees_completedStartTable context.state base) hcomplete, + not_privateStructuralHit_of_deferredCompletable hcomplete⟩ + · rintro ⟨hvalid, hprivate⟩ + exact deferredCompletable_of_valid_of_no_boundary_hit _ context hvalid + (startTableAgrees_completedStartTable context.state base) hprivate + (no_missingChainStartHit_of_history_clean context history base hcovered hclean) hcard + +noncomputable def retainCompletableResult : Option (ResolvedRunResult α) → Option (ResolvedRunResult α) + | none => none + | some result => if DeferredCompletable result.table result.context then some result else none + +theorem expected_live_historyCompletion_eq_context_guard + (entry : HistoryResolvedPrefix α) (cost : Option (ResolvedRunResult α) → ℝ≥0∞) + (hzero : cost none = 0) (hconsistent : entry.context.ValuesConsistent) + (hcovered : PendingCoveredBy entry.history entry.context) + (hcard : entry.context.state.pending.card < Fintype.card Digest) : + (∑' result, Pr[= result | completeHistoryResolvedPrefix (some entry)] * cost (retainCompletableResult result)) = + if entry.context.Valid ∧ ¬PrivateStructuralHit entry.context then + ∑' result, Pr[= result | completeHistoryResolvedPrefix (some entry)] * cost result + else 0 := by + by_cases hgood : entry.context.Valid ∧ ¬PrivateStructuralHit entry.context + · simp only [if_pos hgood, completeHistoryResolvedPrefix, completeResolvedHistory, tsum_probOutput_bind_mul] + apply tsum_congr + intro base + by_cases hhit : ChainStartHistoryHit entry.context entry.history base + · simp [hhit, retainCompletableResult, hzero] + · have hcomplete := (deferredCompletable_history_clean_iff entry.context entry.history base hconsistent hcovered hcard hhit).mpr hgood + simp [hhit, retainCompletableResult, hcomplete] + · simp only [if_neg hgood, completeHistoryResolvedPrefix, completeResolvedHistory, tsum_probOutput_bind_mul] + apply ENNReal.tsum_eq_zero.mpr + intro base + by_cases hhit : ChainStartHistoryHit entry.context entry.history base + · simp [hhit, retainCompletableResult, hzero] + · have hcomplete : ¬DeferredCompletable (completedStartTable entry.context.state base) entry.context := + fun h => hgood ((deferredCompletable_history_clean_iff entry.context entry.history base hconsistent hcovered hcard hhit).mp h) + simp [hhit, retainCompletableResult, hcomplete, hzero] + +theorem expected_live_historyCompletion_unresolvedStart_le + (entry : HistoryResolvedPrefix α) (candidate : DeferredContext → α → Option Probe) + (hconsistent : entry.context.ValuesConsistent) (hcovered : PendingCoveredBy entry.history entry.context) + (hlength : entry.history.length ≤ 2 ^ 126) : + (∑' result, Pr[= result | completeHistoryResolvedPrefix (some entry)] * historyUnresolvedStartAllowance candidate (retainCompletableResult result)) ≤ + (∑' result, Pr[= result | completeHistoryResolvedPrefix (some entry)] * historyUnresolvedStartCharge candidate (retainCompletableResult result)) * + ((4 / 3 : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) := by + have hspace : 2 ^ 126 < Fintype.card Digest := by norm_num [digestBits] + have hcard := (hcovered.card_le.trans hlength).trans_lt hspace + rw [expected_live_historyCompletion_eq_context_guard entry (historyUnresolvedStartAllowance candidate) rfl hconsistent hcovered hcard, + expected_live_historyCompletion_eq_context_guard entry (historyUnresolvedStartCharge candidate) rfl hconsistent hcovered hcard] + split_ifs + · exact expected_completeHistoryResolvedPrefix_unresolvedStart_le entry candidate hlength + · simp + +theorem expected_live_historyAdaptive_unresolvedStart_le + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) + (candidate : DeferredContext → α → Option Probe) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ 2 ^ 126) : + (∑' result, Pr[= result | runResolvedHistoryAdaptive computation context fuel history] * historyUnresolvedStartAllowance candidate (retainCompletableResult result)) ≤ + (∑' result, Pr[= result | runResolvedHistoryAdaptive computation context fuel history] * historyUnresolvedStartCharge candidate (retainCompletableResult result)) * + ((4 / 3 : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) := by + simp only [runResolvedHistoryAdaptive_eq_prefix_complete, tsum_probOutput_bind_mul] + rw [← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro option + by_cases hsupport : option ∈ support (runResolvedHistoryPrefix computation context fuel history) + · cases option with + | none => simp [completeHistoryResolvedPrefix, retainCompletableResult, historyUnresolvedStartAllowance, historyUnresolvedStartCharge] + | some entry => + have hinvariant := historyPrefix_invariant_of_mem computation context fuel bound history entry hcovered hbound hsupport + have hvalues := valuesConsistent_of_mem_historyPrefix computation context fuel history entry hconsistent hsupport + have hlocal := expected_live_historyCompletion_unresolvedStart_le entry candidate hvalues hinvariant.1 (hinvariant.2.trans hbudget) + simpa only [mul_assoc] using mul_le_mul' le_rfl hlocal + · simp [probOutput_eq_zero_of_not_mem_support hsupport] + +noncomputable def sampledHistoryFilteredRun + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) : ProbComp (Option (ResolvedRunResult α)) := do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then pure none + else runResolvedFromTable context fuel (completedStartTable context.state base) computation + +theorem evalDist_live_sampledHistoryFilteredRun_eq_adaptive + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ 2 ^ 126) : + evalDist (sampledHistoryFilteredRun computation context fuel history >>= fun result => pure (retainCompletableResult result)) = + evalDist (runResolvedHistoryAdaptive computation context fuel history >>= fun result => pure (retainCompletableResult result)) := by + have heq := evalDist_history_filtered_runResolved_eq_prefix_observe computation context fuel bound history + (fun result => pure (retainCompletableResult result)) (by + intro result _hvalues _hstarts hdoomed + simp only [retainCompletableResult, if_neg hdoomed]) hconsistent hcovered hbound hbudget + simpa only [sampledHistoryFilteredRun, runResolvedHistoryAdaptive_eq_prefix_complete] using heq + +theorem expected_live_sampledHistoryFilteredRun_eq_adaptive + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) + (cost : Option (ResolvedRunResult α) → ℝ≥0∞) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ 2 ^ 126) : + (∑' result, Pr[= result | sampledHistoryFilteredRun computation context fuel history] * cost (retainCompletableResult result)) = + ∑' result, Pr[= result | runResolvedHistoryAdaptive computation context fuel history] * cost (retainCompletableResult result) := by + have hdist := evalDist_live_sampledHistoryFilteredRun_eq_adaptive computation context fuel bound history + hconsistent hcovered hbound hbudget + calc + _ = ∑' result, Pr[= result | sampledHistoryFilteredRun computation context fuel history >>= + fun result => pure (retainCompletableResult result)] * cost result := by + simp only [tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + _ = ∑' result, Pr[= result | runResolvedHistoryAdaptive computation context fuel history >>= + fun result => pure (retainCompletableResult result)] * cost result := by + apply tsum_congr + intro result + simp only [probOutput_def, hdist] + _ = _ := by simp only [tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + +theorem expected_live_sampledHistoryFilteredRun_unresolvedStart_le + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) + (candidate : DeferredContext → α → Option Probe) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ 2 ^ 126) : + (∑' result, Pr[= result | sampledHistoryFilteredRun computation context fuel history] * + historyUnresolvedStartAllowance candidate (retainCompletableResult result)) ≤ + (∑' result, Pr[= result | sampledHistoryFilteredRun computation context fuel history] * + historyUnresolvedStartCharge candidate (retainCompletableResult result)) * + ((4 / 3 : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) := by + rw [expected_live_sampledHistoryFilteredRun_eq_adaptive computation context fuel bound history + (historyUnresolvedStartAllowance candidate) hconsistent hcovered hbound hbudget, + expected_live_sampledHistoryFilteredRun_eq_adaptive computation context fuel bound history + (historyUnresolvedStartCharge candidate) hconsistent hcovered hbound hbudget] + exact expected_live_historyAdaptive_unresolvedStart_le computation context fuel bound history candidate + hconsistent hcovered hbound hbudget + +theorem expected_live_sampled_runResolved_empty_unresolvedStart_le + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel bound : Nat) + (candidate : DeferredContext → α → Option Probe) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) (hbudget : bound ≤ 2 ^ 126) : + (∑' result, Pr[= result | do + let table ← sampleOtsHashTable + runResolvedFromTable { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table computation] * historyUnresolvedStartAllowance candidate (retainCompletableResult result)) ≤ + (∑' result, Pr[= result | do + let table ← sampleOtsHashTable + runResolvedFromTable { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table computation] * historyUnresolvedStartCharge candidate (retainCompletableResult result)) * + ((4 / 3 : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) := by + have hnative := expected_live_sampledHistoryFilteredRun_unresolvedStart_le computation + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel bound [] candidate DeferredContext.valid_empty.valuesConsistent pendingCoveredBy_empty hbound + (by simpa only [List.length_nil, Nat.zero_add] using hbudget) + have htable : ∀ base, completedStartTable LazyRevealProbe.State.empty base = base := by + intro base + funext index + rfl + simpa only [sampledHistoryFilteredRun, ChainStartHistoryHit, List.not_mem_nil, false_and, exists_false, ↓reduceIte, + htable] using hnative + +def UnresolvedStartProbeHit (table : OtsSecretIndex → HashOutput) (context : DeferredContext) : Option Probe → Prop + | some ⟨.chainStart lay tree leafIdx chainIdx, digest⟩ => + context.state.values (.chainStart lay tree leafIdx chainIdx) = none ∧ + ¬(.chainStart lay tree leafIdx chainIdx ∈ context.state.revealed ∨ + (.chainStart lay tree leafIdx chainIdx, digest) ∈ context.state.pending) ∧ + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩) = digest + | _ => False + +theorem unresolvedStartCandidateAllowance_eq_indicator + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) (candidate : Option Probe) : + unresolvedStartCandidateAllowance table context candidate = if UnresolvedStartProbeHit table context candidate then 1 else 0 := by + cases candidate with + | none => simp [unresolvedStartCandidateAllowance, UnresolvedStartProbeHit] + | some candidate => + rcases candidate with ⟨coordinate, digest⟩ + cases coordinate with + | position position => simp [unresolvedStartCandidateAllowance, UnresolvedStartProbeHit] + | chainStart lay tree leafIdx chainIdx => + by_cases hmissing : context.state.values (.chainStart lay tree leafIdx chainIdx) = none + · by_cases hseen : .chainStart lay tree leafIdx chainIdx ∈ context.state.revealed ∨ + (.chainStart lay tree leafIdx chainIdx, digest) ∈ context.state.pending + · simp [unresolvedStartCandidateAllowance, UnresolvedStartProbeHit, candidateFailureAllowance, hmissing, hseen] + · simp [unresolvedStartCandidateAllowance, UnresolvedStartProbeHit, candidateFailureAllowance, + resolvedCompletionValue, hmissing, hseen] + · simp [unresolvedStartCandidateAllowance, UnresolvedStartProbeHit, hmissing] + +def LiveUnresolvedStartHit (candidate : DeferredContext → α → Option Probe) : Option (ResolvedRunResult α) → Prop + | none => False + | some result => DeferredCompletable result.table result.context ∧ + UnresolvedStartProbeHit result.table result.context (candidate result.context result.value) + +theorem historyUnresolvedStartAllowance_live_eq_indicator + (candidate : DeferredContext → α → Option Probe) (result : Option (ResolvedRunResult α)) : + historyUnresolvedStartAllowance candidate (retainCompletableResult result) = + if LiveUnresolvedStartHit candidate result then 1 else 0 := by + cases result with + | none => simp [retainCompletableResult, historyUnresolvedStartAllowance, LiveUnresolvedStartHit] + | some result => + by_cases hcomplete : DeferredCompletable result.table result.context + · simp [retainCompletableResult, historyUnresolvedStartAllowance, LiveUnresolvedStartHit, hcomplete, + unresolvedStartCandidateAllowance_eq_indicator] + · simp [retainCompletableResult, historyUnresolvedStartAllowance, LiveUnresolvedStartHit, hcomplete] + +theorem probEvent_liveUnresolvedStartHit_eq_expected + (run : ProbComp (Option (ResolvedRunResult α))) (candidate : DeferredContext → α → Option Probe) : + Pr[LiveUnresolvedStartHit candidate | run] = + ∑' result, Pr[= result | run] * historyUnresolvedStartAllowance candidate (retainCompletableResult result) := by + rw [probEvent_eq_tsum_ite] + apply tsum_congr + intro result + rw [historyUnresolvedStartAllowance_live_eq_indicator] + split_ifs <;> simp + +theorem probEvent_live_unresolvedStart_hit_le_native_charge + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) + (candidate : DeferredContext → α → Option Probe) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ 2 ^ 126) : + Pr[LiveUnresolvedStartHit candidate | sampledHistoryFilteredRun computation context fuel history] ≤ + (∑' result, Pr[= result | sampledHistoryFilteredRun computation context fuel history] * + historyUnresolvedStartCharge candidate (retainCompletableResult result)) * + ((4 / 3 : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) := by + rw [probEvent_liveUnresolvedStartHit_eq_expected] + exact expected_live_sampledHistoryFilteredRun_unresolvedStart_le computation context fuel bound history candidate + hconsistent hcovered hbound hbudget + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryOuterComposition.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryOuterComposition.lean new file mode 100644 index 00000000..d6d51148 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryOuterComposition.lean @@ -0,0 +1,311 @@ +import SphincsSecurity.Proof.OtsProbeHistoryOuterPrefix + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable +set_option backward.isDefEq.respectTransparency false + +noncomputable def runGuardedCanonicalNative + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → ProbComp (Option (ResolvedRunResult (α × SplitHashCache))) := + OracleComp.construct + (fun value context fuel table cache => pure (canonicalHistoryBoundary (some ⟨context, fuel, (value, cache), table⟩))) + (fun query _next recur context fuel table cache => do + let result ← runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret query).run cache) + match canonicalHistoryBoundary result with + | none => pure none + | some result => recur result.value.1 result.context result.remaining result.table result.value.2) computation + +noncomputable def sampledGuardedCanonicalNative + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) (cache : SplitHashCache) : + ProbComp (Option (ResolvedRunResult (α × SplitHashCache))) := do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then pure none + else runGuardedCanonicalNative parameter root ftsSecret computation context fuel (completedStartTable context.state base) cache + +noncomputable def runCanonicalHistoryAdaptive + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + DeferredContext → Nat → List Probe → SplitHashCache → ProbComp (Option (ResolvedRunResult (α × SplitHashCache))) := + OracleComp.construct + (fun value context fuel history cache => + completeHistoryResolvedPrefix (canonicalHistoryPrefix (some ⟨context, fuel, (value, cache), history⟩))) + (fun query _next recur context fuel history cache => do + let option ← runCanonicalHistoryOuterPrefix parameter root ftsSecret query context fuel history cache + match option with + | none => pure none + | some entry => recur entry.value.1 entry.context entry.remaining entry.history entry.value.2) computation + +noncomputable def guardedCanonicalNativeContinuation + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (next : β → OracleComp (OracleWorld + SigningSpec) α) : + Option (ResolvedRunResult (β × SplitHashCache)) → ProbComp (Option (ResolvedRunResult (α × SplitHashCache))) + | none => pure none + | some result => runGuardedCanonicalNative parameter root ftsSecret (next result.value.1) + result.context result.remaining result.table result.value.2 + +theorem completeHistoryResolvedPrefix_guardedContinuation + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (next : β → OracleComp (OracleWorld + SigningSpec) α) (entry : HistoryResolvedPrefix (β × SplitHashCache)) : + (completeHistoryResolvedPrefix (some entry) >>= guardedCanonicalNativeContinuation parameter root ftsSecret next) = + sampledGuardedCanonicalNative parameter root ftsSecret (next entry.value.1) + entry.context entry.remaining entry.history entry.value.2 := by + simp only [completeHistoryResolvedPrefix, completeResolvedHistory, sampledGuardedCanonicalNative, bind_assoc] + apply bind_congr + intro base + split_ifs <;> simp only [pure_bind, guardedCanonicalNativeContinuation] + +theorem sampledGuardedCanonicalNative_query_bind + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range query → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) (cache : SplitHashCache) : + sampledGuardedCanonicalNative parameter root ftsSecret (OracleSpec.query query >>= next) context fuel history cache = + (sampledHistoryFilteredRun ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret query).run cache) + context fuel history >>= fun result => + guardedCanonicalNativeContinuation parameter root ftsSecret next (canonicalHistoryBoundary result)) := by + simp only [sampledGuardedCanonicalNative, sampledHistoryFilteredRun, bind_assoc] + apply bind_congr + intro base + split_ifs + · simp only [pure_bind, canonicalHistoryBoundary, guardedCanonicalNativeContinuation] + · rw [runGuardedCanonicalNative, OracleComp.construct_query_bind] + apply bind_congr + intro result + cases canonicalHistoryBoundary result <;> rfl + +theorem evalDist_sampledGuardedCanonicalNative_eq_historyAdaptive + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hpublished : PublishedValues context.state) + (hbound : computation.IsQueryBoundP IsOuterHash bound) (hbudget : history.length + bound ≤ 2 ^ 126) : + evalDist (sampledGuardedCanonicalNative parameter root ftsSecret computation context fuel history cache) = + evalDist (runCanonicalHistoryAdaptive parameter root ftsSecret computation context fuel history cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel bound history cache with + | pure value => + have hspace : 2 ^ 126 < Fintype.card Digest := by norm_num [digestBits] + have hcard : context.state.pending.card < Fintype.card Digest := + (hcovered.card_le.trans (by omega : history.length ≤ 2 ^ 126)).trans_lt hspace + have h := completeHistoryResolvedPrefix_canonicalBoundary + (⟨context, fuel, (value, cache), history⟩ : HistoryResolvedPrefix (α × SplitHashCache)) hconsistent hcovered hcard + simp only [runCanonicalHistoryAdaptive, OracleComp.construct_pure] + calc + _ = evalDist (completeHistoryResolvedPrefix (some ⟨context, fuel, (value, cache), history⟩) >>= + fun result => pure (canonicalHistoryBoundary result)) := by + simp only [sampledGuardedCanonicalNative, completeHistoryResolvedPrefix, completeResolvedHistory, bind_assoc] + apply evalDist_bind_congr + intro base _ + split_ifs <;> simp only [runGuardedCanonicalNative, OracleComp.construct_pure, pure_bind, canonicalHistoryBoundary] + _ = _ := h + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + have hqueryBudget : history.length + (if IsOuterHash query then 1 else 0) ≤ 2 ^ 126 := by + by_cases hhash : IsOuterHash query + · have hpositive : 0 < bound := hbound.1.resolve_left (not_not.mpr hhash) + simp only [if_pos hhash] + omega + · simp only [if_neg hhash] + omega + have hquery := evalDist_sampledHistoryOuter_canonicalPrefix_observe parameter root ftsSecret query context fuel history cache + (fun _ => guardedCanonicalNativeContinuation parameter root ftsSecret next) hconsistent + (fun index hrevealed => hpublished index.coordinate hrevealed) hcovered hqueryBudget + rw [sampledGuardedCanonicalNative_query_bind] + calc + _ = _ := hquery + _ = _ := by + rw [runCanonicalHistoryAdaptive, OracleComp.construct_query_bind] + apply evalDist_bind_congr + intro option hsupport + cases option with + | none => rfl + | some entry => + dsimp only + rw [completeHistoryResolvedPrefix_guardedContinuation] + have hinvariant := canonicalHistoryOuterPrefix_invariant parameter root ftsSecret query context fuel history cache + entry hconsistent hcovered hsupport + have hlength := canonicalHistoryOuterPrefix_history_length parameter root ftsSecret query context fuel history cache + entry hsupport + have hnextBound := hbound.2 entry.value.1 + apply ih entry.value.1 entry.context entry.remaining + (if IsOuterHash query then bound - 1 else bound) entry.history entry.value.2 + hinvariant.1 hinvariant.2.1 hinvariant.2.2.1 hnextBound + by_cases hhash : IsOuterHash query + · have hpositive : 0 < bound := hbound.1.resolve_left (not_not.mpr hhash) + simp only [if_pos hhash] at hlength ⊢ + omega + · simp only [if_neg hhash] at hlength ⊢ + omega + +noncomputable def runCanonicalHistoryAdaptivePrefix + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + DeferredContext → Nat → List Probe → SplitHashCache → ProbComp (Option (HistoryResolvedPrefix (α × SplitHashCache))) := + OracleComp.construct + (fun value context fuel history cache => pure (canonicalHistoryPrefix (some ⟨context, fuel, (value, cache), history⟩))) + (fun query _next recur context fuel history cache => do + let option ← runCanonicalHistoryOuterPrefix parameter root ftsSecret query context fuel history cache + match option with + | none => pure none + | some entry => recur entry.value.1 entry.context entry.remaining entry.history entry.value.2) computation + +theorem runCanonicalHistoryAdaptive_eq_prefix_complete + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) (cache : SplitHashCache) : + runCanonicalHistoryAdaptive parameter root ftsSecret computation context fuel history cache = + runCanonicalHistoryAdaptivePrefix parameter root ftsSecret computation context fuel history cache >>= completeHistoryResolvedPrefix := by + induction computation using OracleComp.inductionOn generalizing context fuel history cache with + | pure value => simp only [runCanonicalHistoryAdaptive, runCanonicalHistoryAdaptivePrefix, OracleComp.construct_pure, pure_bind] + | query_bind query next ih => + rw [runCanonicalHistoryAdaptive, OracleComp.construct_query_bind, runCanonicalHistoryAdaptivePrefix, + OracleComp.construct_query_bind, bind_assoc] + apply bind_congr + intro option + cases option with + | none => simp only [pure_bind, completeHistoryResolvedPrefix] + | some entry => exact ih entry.value.1 entry.context entry.remaining entry.history entry.value.2 + +theorem canonicalHistoryAdaptivePrefix_history_length + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) (cache : SplitHashCache) + (result : HistoryResolvedPrefix (α × SplitHashCache)) + (hbound : computation.IsQueryBoundP IsOuterHash bound) + (hresult : some result ∈ support (runCanonicalHistoryAdaptivePrefix parameter root ftsSecret computation context fuel history cache)) : + result.history.length ≤ history.length + bound := by + induction computation using OracleComp.inductionOn generalizing context fuel bound history cache with + | pure value => + simp only [runCanonicalHistoryAdaptivePrefix, OracleComp.construct_pure, mem_support_pure_iff] at hresult + have hhistory := canonicalHistoryPrefix_history_length _ result hresult.symm + rw [hhistory] + exact Nat.le_add_right _ _ + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [runCanonicalHistoryAdaptivePrefix, OracleComp.construct_query_bind, mem_support_bind_iff] at hresult + obtain ⟨option, hstep, htail⟩ := hresult + cases option with + | none => simp at htail + | some entry => + have hlength := canonicalHistoryOuterPrefix_history_length parameter root ftsSecret query context fuel history cache entry hstep + have hrest := ih entry.value.1 entry.context entry.remaining + (if IsOuterHash query then bound - 1 else bound) entry.history entry.value.2 (hbound.2 entry.value.1) htail + by_cases hhash : IsOuterHash query + · have hpositive := hbound.1.resolve_left (not_not.mpr hhash) + simp only [if_pos hhash] at hlength hrest + omega + · simp only [if_neg hhash] at hlength hrest + omega + +theorem expected_guardedCanonical_unresolvedStart_le + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) (cache : SplitHashCache) + (candidate : DeferredContext → (α × SplitHashCache) → Option Probe) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hpublished : PublishedValues context.state) + (hbound : computation.IsQueryBoundP IsOuterHash bound) (hbudget : history.length + bound ≤ 2 ^ 126) : + (∑' result, Pr[= result | sampledGuardedCanonicalNative parameter root ftsSecret computation context fuel history cache] * + historyUnresolvedStartAllowance candidate result) ≤ + (∑' result, Pr[= result | sampledGuardedCanonicalNative parameter root ftsSecret computation context fuel history cache] * + historyUnresolvedStartCharge candidate result) * ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + have hdist := evalDist_sampledGuardedCanonicalNative_eq_historyAdaptive parameter root ftsSecret computation context fuel bound + history cache hconsistent hcovered hpublished hbound hbudget + rw [runCanonicalHistoryAdaptive_eq_prefix_complete] at hdist + have hcost (cost : Option (ResolvedRunResult (α × SplitHashCache)) → ENNReal) : + (∑' result, Pr[= result | sampledGuardedCanonicalNative parameter root ftsSecret computation context fuel history cache] * cost result) = + ∑' result, Pr[= result | runCanonicalHistoryAdaptivePrefix parameter root ftsSecret computation context fuel history cache >>= + completeHistoryResolvedPrefix] * cost result := by + apply tsum_congr + intro result + rw [_root_.OracleComp.probOutput_congr rfl hdist] + rw [hcost, hcost] + simp only [tsum_probOutput_bind_mul] + rw [← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro option + by_cases hsupport : option ∈ support (runCanonicalHistoryAdaptivePrefix parameter root ftsSecret computation context fuel history cache) + · cases option with + | none => simp [completeHistoryResolvedPrefix, historyUnresolvedStartAllowance, historyUnresolvedStartCharge] + | some entry => + have hlength := canonicalHistoryAdaptivePrefix_history_length parameter root ftsSecret computation context fuel bound + history cache entry hbound hsupport + have hlocal := expected_completeHistoryResolvedPrefix_unresolvedStart_le entry candidate (hlength.trans hbudget) + simpa only [mul_assoc] using mul_le_mul' le_rfl hlocal + · simp [probOutput_eq_zero_of_not_mem_support hsupport] + +theorem retainCompletableResult_of_mem_guardedCanonicalNative + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : Option (ResolvedRunResult (α × SplitHashCache))) + (hresult : result ∈ support (runGuardedCanonicalNative parameter root ftsSecret computation context fuel table cache)) : + retainCompletableResult result = result := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => + simp only [runGuardedCanonicalNative, OracleComp.construct_pure, mem_support_pure_iff] at hresult + subst result + exact retainCompletableResult_canonicalHistoryBoundary _ + | query_bind query next ih => + rw [runGuardedCanonicalNative, OracleComp.construct_query_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, _, htail⟩ := hresult + cases hboundary : canonicalHistoryBoundary raw with + | none => + simp only [hboundary, mem_support_pure_iff] at htail + subst result + rfl + | some entry => + rw [hboundary] at htail + exact ih entry.value.1 entry.context entry.remaining entry.table entry.value.2 htail + +theorem retainCompletableResult_of_mem_sampledGuardedCanonicalNative + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) (cache : SplitHashCache) + (result : Option (ResolvedRunResult (α × SplitHashCache))) + (hresult : result ∈ support (sampledGuardedCanonicalNative parameter root ftsSecret computation context fuel history cache)) : + retainCompletableResult result = result := by + rw [sampledGuardedCanonicalNative, mem_support_bind_iff] at hresult + obtain ⟨base, _, hresult⟩ := hresult + split_ifs at hresult with hhit + · simp only [mem_support_pure_iff] at hresult + subst result + rfl + · exact retainCompletableResult_of_mem_guardedCanonicalNative parameter root ftsSecret computation context fuel + (completedStartTable context.state base) cache result hresult + +theorem probEvent_guardedCanonical_unresolvedStart_le + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) (cache : SplitHashCache) + (candidate : DeferredContext → (α × SplitHashCache) → Option Probe) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hpublished : PublishedValues context.state) + (hbound : computation.IsQueryBoundP IsOuterHash bound) (hbudget : history.length + bound ≤ 2 ^ 126) : + Pr[LiveUnresolvedStartHit candidate | sampledGuardedCanonicalNative parameter root ftsSecret computation context fuel history cache] ≤ + (∑' result, Pr[= result | sampledGuardedCanonicalNative parameter root ftsSecret computation context fuel history cache] * + historyUnresolvedStartCharge candidate result) * ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + rw [probEvent_liveUnresolvedStartHit_eq_expected] + have hretain : + (∑' result, Pr[= result | sampledGuardedCanonicalNative parameter root ftsSecret computation context fuel history cache] * + historyUnresolvedStartAllowance candidate (retainCompletableResult result)) = + ∑' result, Pr[= result | sampledGuardedCanonicalNative parameter root ftsSecret computation context fuel history cache] * + historyUnresolvedStartAllowance candidate result := by + apply tsum_congr + intro result + by_cases hsupport : result ∈ support (sampledGuardedCanonicalNative parameter root ftsSecret computation context fuel history cache) + · rw [retainCompletableResult_of_mem_sampledGuardedCanonicalNative parameter root ftsSecret computation context fuel history cache result hsupport] + · simp [probOutput_eq_zero_of_not_mem_support hsupport] + rw [hretain] + exact expected_guardedCanonical_unresolvedStart_le parameter root ftsSecret computation context fuel bound history cache candidate + hconsistent hcovered hpublished hbound hbudget + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryOuterPrefix.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryOuterPrefix.lean new file mode 100644 index 00000000..2ef4e854 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryOuterPrefix.lean @@ -0,0 +1,295 @@ +import SphincsSecurity.Proof.OtsProbeHistoryQueryPrefix + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable +set_option backward.isDefEq.respectTransparency false + +theorem runResolvedFromTable_executeCandidate_zero + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) (candidate : Option Probe) : + runResolvedFromTable context 0 table ((executeCandidate? candidate).run cache) = + if candidate.isSome then pure none else pure (some ⟨context, 0, ((), cache), table⟩) := by + cases candidate with + | none => simp [executeCandidate?, runResolvedFromTable] + | some candidate => + change runResolvedFromTable context 0 table + (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate >>= fun _ => pure ((), cache)) = _ + rw [LazyRevealProbe.probeQuery, runResolvedFromTable_probe_query_bind] + rfl + +theorem runResolved_probingHashQuery_zero + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runResolvedFromTable context 0 table ((probingHashQuery parameter input).run cache) = + if (purePlanProbingHashQuery parameter input context.state).candidate?.isSome then pure none + else runResolvedFromTable context 0 table ((historyHashQuerySuffix parameter input context).run cache) := by + rw [runResolved_probingHashQuery_eq_afterPlan] + unfold probingHashQueryAfterPlan executePlannedHashQuery + rw [StateT.run_bind, runResolvedFromTable_bind, runResolvedFromTable_executeCandidate_zero] + split_ifs <;> simp only [pure_bind] + rfl + +noncomputable def runCanonicalHistoryHashPrefixAtFuel + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) + (history : List Probe) (fuel : Nat) (cache : SplitHashCache) : + ProbComp (Option (HistoryResolvedPrefix (HashOutput × SplitHashCache))) := + match fuel with + | 0 => + if (purePlanProbingHashQuery parameter input context.state).candidate?.isSome then pure none + else do + let entry ← runResolvedHistoryPrefix ((historyHashQuerySuffix parameter input context).run cache) context 0 history + pure (canonicalHistoryPrefix entry) + | fuel + 1 => runCanonicalHistoryHashPrefix parameter input context history fuel cache + +theorem evalDist_sampledHistoryHash_canonicalPrefix_all_fuel + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) + (history : List Probe) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hpublic : ∀ index : OtsSecretIndex, index.coordinate ∈ context.state.revealed → context.state.values index.coordinate ≠ none) + (hcovered : PendingCoveredBy history context) (hbudget : history.length + 1 ≤ 2 ^ 126) : + evalDist (sampledHistoryFilteredRun ((probingHashQuery parameter input).run cache) context fuel history >>= + fun result => pure (canonicalHistoryBoundary result)) = + evalDist (runCanonicalHistoryHashPrefixAtFuel parameter input context history fuel cache >>= completeHistoryResolvedPrefix) := by + cases fuel with + | succ fuel => + exact evalDist_sampledHistoryHash_canonicalPrefix parameter input context history fuel cache + hconsistent hpublic hcovered hbudget + | zero => + simp only [runCanonicalHistoryHashPrefixAtFuel] + by_cases hcandidate : (purePlanProbingHashQuery parameter input context.state).candidate?.isSome = true + · simp only [if_pos hcandidate, pure_bind, completeHistoryResolvedPrefix] + unfold sampledHistoryFilteredRun + simp_rw [runResolved_probingHashQuery_zero, if_pos hcandidate] + simp only [ite_self, bind_assoc, pure_bind, canonicalHistoryBoundary] + exact evalDist_sampleOtsHashTable_bind_const (pure none) + · simp only [if_neg hcandidate, bind_assoc, pure_bind] + have hrun : sampledHistoryFilteredRun ((probingHashQuery parameter input).run cache) context 0 history = + sampledHistoryFilteredRun ((historyHashQuerySuffix parameter input context).run cache) context 0 history := by + unfold sampledHistoryFilteredRun + apply bind_congr + intro base + split_ifs + · rfl + · rw [runResolved_probingHashQuery_zero, if_neg hcandidate] + rw [hrun] + exact evalDist_sampledHistoryFilteredRun_canonicalBoundary _ context 0 0 history hconsistent hcovered + (historyHashQuerySuffix_probeFree parameter input context cache) (by omega) + +theorem canonicalHistoryHashPrefix_history_all_fuel + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) + (history : List Probe) (fuel : Nat) (cache : SplitHashCache) + (result : HistoryResolvedPrefix (HashOutput × SplitHashCache)) + (hresult : some result ∈ support (runCanonicalHistoryHashPrefixAtFuel parameter input context history fuel cache)) : + result.history = history ++ (purePlanProbingHashQuery parameter input context.state).candidate?.toList := by + cases fuel with + | succ fuel => exact canonicalHistoryHashPrefix_history parameter input context history fuel cache result hresult + | zero => + simp only [runCanonicalHistoryHashPrefixAtFuel] at hresult + split_ifs at hresult with hcandidate + · simp at hresult + · have hnone : (purePlanProbingHashQuery parameter input context.state).candidate? = none := by + cases hc : (purePlanProbingHashQuery parameter input context.state).candidate? <;> simp_all + rw [hnone, Option.toList_none, List.append_nil] + rw [mem_support_bind_iff] at hresult + obtain ⟨option, hoption, hcanonical⟩ := hresult + simp only [mem_support_pure_iff] at hcanonical + cases option with + | none => simp [canonicalHistoryPrefix] at hcanonical + | some entry => + exact canonicalHistoryPrefix_history_eq_of_probeFree _ _ _ _ entry result + (historyHashQuerySuffix_probeFree parameter input context cache) hoption hcanonical.symm + +noncomputable def runCanonicalHistoryBlockPrefix + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) : ProbComp (Option (HistoryResolvedPrefix α)) := do + let entry ← runResolvedHistoryPrefix computation context fuel history + pure (canonicalHistoryPrefix entry) + +theorem canonicalHistoryBlockPrefix_invariant + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) (result : HistoryResolvedPrefix α) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hresult : some result ∈ support (runCanonicalHistoryBlockPrefix computation context fuel history)) : + result.context.ValuesConsistent ∧ PendingCoveredBy result.history result.context ∧ PublishedValues result.context.state ∧ + ∀ base, CanonicalMaterializedValues (completedStartTable result.context.state base) result.context := by + rw [runCanonicalHistoryBlockPrefix, mem_support_bind_iff] at hresult + obtain ⟨option, hoption, hcanonical⟩ := hresult + simp only [mem_support_pure_iff] at hcanonical + cases option with + | none => simp [canonicalHistoryPrefix] at hcanonical + | some entry => + have hentry := historyPrefix_invariant_of_mem computation context fuel bound history entry hcovered hbound hoption + exact canonicalHistoryPrefix_invariant entry result hcanonical.symm + (valuesConsistent_of_mem_historyPrefix computation context fuel history entry hconsistent hoption) hentry.1 + +theorem canonicalHistoryBlockPrefix_history_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) (result : HistoryResolvedPrefix α) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) + (hresult : some result ∈ support (runCanonicalHistoryBlockPrefix computation context fuel history)) : + result.history = history := by + rw [runCanonicalHistoryBlockPrefix, mem_support_bind_iff] at hresult + obtain ⟨option, hoption, hcanonical⟩ := hresult + simp only [mem_support_pure_iff] at hcanonical + cases option with + | none => simp [canonicalHistoryPrefix] at hcanonical + | some entry => + exact canonicalHistoryPrefix_history_eq_of_probeFree computation context fuel history entry result hbound hoption hcanonical.symm + +theorem canonicalHistoryHashPrefix_invariant_all_fuel + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) + (history : List Probe) (fuel : Nat) (cache : SplitHashCache) + (result : HistoryResolvedPrefix (HashOutput × SplitHashCache)) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hresult : some result ∈ support (runCanonicalHistoryHashPrefixAtFuel parameter input context history fuel cache)) : + result.context.ValuesConsistent ∧ PendingCoveredBy result.history result.context ∧ PublishedValues result.context.state ∧ + ∀ base, CanonicalMaterializedValues (completedStartTable result.context.state base) result.context := by + cases fuel with + | succ fuel => exact canonicalHistoryHashPrefix_invariant parameter input context history fuel cache result hconsistent hcovered hresult + | zero => + simp only [runCanonicalHistoryHashPrefixAtFuel] at hresult + split_ifs at hresult + · simp at hresult + · exact canonicalHistoryBlockPrefix_invariant _ context 0 0 history result hconsistent hcovered + (historyHashQuerySuffix_probeFree parameter input context cache) hresult + +noncomputable def runCanonicalHistoryOuterPrefix + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) (history : List Probe) + (cache : SplitHashCache) : ProbComp (Option (HistoryResolvedPrefix ((OracleWorld + SigningSpec).Range query × SplitHashCache))) := + match query with + | .inl (.inl n) => runCanonicalHistoryBlockPrefix ((splitUniformImpl n).run cache) context fuel history + | .inl (.inr input) => runCanonicalHistoryHashPrefixAtFuel parameter input context history fuel cache + | .inr message => runCanonicalHistoryBlockPrefix ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache) + context fuel history + +theorem evalDist_sampledHistoryOuter_canonicalPrefix + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) (history : List Probe) + (cache : SplitHashCache) (hconsistent : context.ValuesConsistent) + (hpublic : ∀ index : OtsSecretIndex, index.coordinate ∈ context.state.revealed → context.state.values index.coordinate ≠ none) + (hcovered : PendingCoveredBy history context) + (hbudget : history.length + (if IsOuterHash query then 1 else 0) ≤ 2 ^ 126) : + evalDist (sampledHistoryFilteredRun ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret query).run cache) + context fuel history >>= fun result => pure (canonicalHistoryBoundary result)) = + evalDist (runCanonicalHistoryOuterPrefix parameter root ftsSecret query context fuel history cache >>= + completeHistoryResolvedPrefix) := by + cases query with + | inl query => + cases query with + | inl n => + change evalDist (sampledHistoryFilteredRun ((splitUniformImpl n).run cache) context fuel history >>= + fun result => pure (canonicalHistoryBoundary result)) = _ + unfold runCanonicalHistoryOuterPrefix runCanonicalHistoryBlockPrefix + rw [bind_assoc] + simp only [pure_bind] + exact evalDist_sampledHistoryFilteredRun_canonicalBoundary _ context fuel 0 history hconsistent hcovered + (splitUniformImpl_probeFree n cache) (by simpa [IsOuterHash] using hbudget) + | inr input => + exact evalDist_sampledHistoryHash_canonicalPrefix_all_fuel parameter input context history fuel cache + hconsistent hpublic hcovered (by simpa [IsOuterHash] using hbudget) + | inr message => + change evalDist (sampledHistoryFilteredRun ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache) + context fuel history >>= fun result => pure (canonicalHistoryBoundary result)) = _ + unfold runCanonicalHistoryOuterPrefix runCanonicalHistoryBlockPrefix + rw [bind_assoc] + simp only [pure_bind] + exact evalDist_sampledHistoryFilteredRun_canonicalBoundary _ context fuel 0 history hconsistent hcovered + (maskedPublishedChronologicalSign_probeFree parameter root ftsSecret message cache) (by simpa [IsOuterHash] using hbudget) + +theorem canonicalHistoryOuterPrefix_history + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) (history : List Probe) + (cache : SplitHashCache) (result : HistoryResolvedPrefix ((OracleWorld + SigningSpec).Range query × SplitHashCache)) + (hresult : some result ∈ support (runCanonicalHistoryOuterPrefix parameter root ftsSecret query context fuel history cache)) : + result.history = history ++ canonicalQueryCandidates parameter query context := by + cases query with + | inl query => + cases query with + | inl n => + simpa only [canonicalQueryCandidates, List.append_nil] using canonicalHistoryBlockPrefix_history_of_probeFree + _ context fuel history result (splitUniformImpl_probeFree n cache) hresult + | inr input => exact canonicalHistoryHashPrefix_history_all_fuel parameter input context history fuel cache result hresult + | inr message => + simpa only [canonicalQueryCandidates, List.append_nil] using canonicalHistoryBlockPrefix_history_of_probeFree + _ context fuel history result (maskedPublishedChronologicalSign_probeFree parameter root ftsSecret message cache) hresult + +theorem canonicalHistoryOuterPrefix_history_length + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) (history : List Probe) + (cache : SplitHashCache) (result : HistoryResolvedPrefix ((OracleWorld + SigningSpec).Range query × SplitHashCache)) + (hresult : some result ∈ support (runCanonicalHistoryOuterPrefix parameter root ftsSecret query context fuel history cache)) : + result.history.length ≤ history.length + (if IsOuterHash query then 1 else 0) := by + rw [canonicalHistoryOuterPrefix_history parameter root ftsSecret query context fuel history cache result hresult, + List.length_append] + apply Nat.add_le_add_left + cases query with + | inl query => + cases query with + | inl n => simp [canonicalQueryCandidates, IsOuterHash] + | inr input => + simp only [canonicalQueryCandidates, IsOuterHash, if_true] + cases (purePlanProbingHashQuery parameter input context.state).candidate? <;> simp + | inr message => simp [canonicalQueryCandidates, IsOuterHash] + +theorem canonicalHistoryOuterPrefix_invariant + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) (history : List Probe) + (cache : SplitHashCache) (result : HistoryResolvedPrefix ((OracleWorld + SigningSpec).Range query × SplitHashCache)) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hresult : some result ∈ support (runCanonicalHistoryOuterPrefix parameter root ftsSecret query context fuel history cache)) : + result.context.ValuesConsistent ∧ PendingCoveredBy result.history result.context ∧ PublishedValues result.context.state ∧ + ∀ base, CanonicalMaterializedValues (completedStartTable result.context.state base) result.context := by + cases query with + | inl query => + cases query with + | inl n => + exact canonicalHistoryBlockPrefix_invariant _ context fuel 0 history result hconsistent hcovered + (splitUniformImpl_probeFree n cache) hresult + | inr input => + exact canonicalHistoryHashPrefix_invariant_all_fuel parameter input context history fuel cache result hconsistent hcovered hresult + | inr message => + exact canonicalHistoryBlockPrefix_invariant _ context fuel 0 history result hconsistent hcovered + (maskedPublishedChronologicalSign_probeFree parameter root ftsSecret message cache) hresult + +theorem evalDist_sampledHistoryOuter_canonicalPrefix_observe + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) (history : List Probe) + (cache : SplitHashCache) + (observe : List Probe → Option (ResolvedRunResult ((OracleWorld + SigningSpec).Range query × SplitHashCache)) → ProbComp β) + (hconsistent : context.ValuesConsistent) + (hpublic : ∀ index : OtsSecretIndex, index.coordinate ∈ context.state.revealed → context.state.values index.coordinate ≠ none) + (hcovered : PendingCoveredBy history context) + (hbudget : history.length + (if IsOuterHash query then 1 else 0) ≤ 2 ^ 126) : + let updated := history ++ canonicalQueryCandidates parameter query context + evalDist (sampledHistoryFilteredRun ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret query).run cache) + context fuel history >>= fun result => observe updated (canonicalHistoryBoundary result)) = + evalDist (runCanonicalHistoryOuterPrefix parameter root ftsSecret query context fuel history cache >>= fun option => + match option with + | none => observe updated none + | some entry => completeHistoryResolvedPrefix (some entry) >>= observe entry.history) := by + dsimp only + let updated := history ++ canonicalQueryCandidates parameter query context + have hdist := evalDist_sampledHistoryOuter_canonicalPrefix parameter root ftsSecret query context fuel history cache + hconsistent hpublic hcovered hbudget + calc + _ = evalDist ((sampledHistoryFilteredRun ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret query).run cache) + context fuel history >>= fun result => pure (canonicalHistoryBoundary result)) >>= observe updated) := by + simp only [bind_assoc, pure_bind, updated] + _ = evalDist ((runCanonicalHistoryOuterPrefix parameter root ftsSecret query context fuel history cache >>= + completeHistoryResolvedPrefix) >>= observe updated) := by rw [evalDist_bind, hdist, ← evalDist_bind] + _ = _ := by + rw [bind_assoc] + apply evalDist_bind_congr + intro option hsupport + cases option with + | none => simp only [completeHistoryResolvedPrefix, pure_bind, updated] + | some entry => + dsimp only + rw [canonicalHistoryOuterPrefix_history parameter root ftsSecret query context fuel history cache entry hsupport] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryPrefix.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryPrefix.lean new file mode 100644 index 00000000..e2341a85 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryPrefix.lean @@ -0,0 +1,226 @@ +import SphincsSecurity.Proof.OtsProbeHistoryAdaptiveInterpreter + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 1000 + +structure HistoryResolvedPrefix (α : Type) where + context : DeferredContext + remaining : Nat + value : α + history : List Probe + +noncomputable def runResolvedHistoryPrefix + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + DeferredContext → Nat → List Probe → ProbComp (Option (HistoryResolvedPrefix α)) := + OracleComp.construct + (fun value context fuel history => pure (some ⟨context, fuel, value, history⟩)) + (fun input _ next => historyAdaptiveQueryStep input next) computation + +theorem runResolvedHistoryPrefix_query_bind + (input : (LazyRevealProbe.World Coordinate).Domain) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) : + runResolvedHistoryPrefix (OracleSpec.query input >>= next) context fuel history = + historyAdaptiveQueryStep input (fun output => runResolvedHistoryPrefix (next output)) context fuel history := rfl + +noncomputable def completeHistoryResolvedPrefix : + Option (HistoryResolvedPrefix α) → ProbComp (Option (ResolvedRunResult α)) + | none => pure none + | some entry => completeResolvedHistory entry.context entry.remaining entry.history entry.value + +theorem historyCompletionQueryStep_bind + (history : List Probe) (input : (LazyRevealProbe.World Coordinate).Domain) + (next : (LazyRevealProbe.World Coordinate).Range input → DeferredContext → Nat → ProbComp (Option α)) + (context : DeferredContext) (fuel : Nat) (observe : Option α → ProbComp (Option β)) + (hnone : observe none = pure none) : + historyCompletionQueryStep history input next context fuel >>= observe = + historyCompletionQueryStep history input (fun output context fuel => next output context fuel >>= observe) context fuel := by + cases input with + | uniform n => simp only [historyCompletionQueryStep, bind_assoc] + | hashOutput => simp only [historyCompletionQueryStep, bind_assoc] + | ensure coordinate => rfl + | peek coordinate => rfl + | publish coordinate => rfl + | probe coordinate digest => simpa only [historyCompletionQueryStep, pure_bind] using hnone + | reveal coordinate => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [historyCompletionQueryStep, OtsSecretIndex.coordinate] + cases hknown : context.state.values (.chainStart lay tree leafIdx chainIdx) with + | some output => + dsimp only + split_ifs <;> simp only [pure_bind, hnone] + | none => + dsimp only + rw [bind_assoc] + apply bind_congr + intro output + split_ifs <;> simp only [pure_bind, hnone] + | position position => + simp only [historyCompletionQueryStep, bind_assoc] + apply bind_congr + intro option + cases option <;> simp only [pure_bind, hnone] + +theorem historyAdaptiveQueryStep_bind + (input : (LazyRevealProbe.World Coordinate).Domain) + (next : (LazyRevealProbe.World Coordinate).Range input → DeferredContext → Nat → List Probe → ProbComp (Option α)) + (context : DeferredContext) (fuel : Nat) (history : List Probe) (observe : Option α → ProbComp (Option β)) + (hnone : observe none = pure none) : + historyAdaptiveQueryStep input next context fuel history >>= observe = + historyAdaptiveQueryStep input (fun output context fuel history => next output context fuel history >>= observe) + context fuel history := by + cases input + case probe coordinate digest => + cases fuel with + | zero => simpa only [historyAdaptiveQueryStep, pure_bind] using hnone + | succ remaining => + simp only [historyAdaptiveQueryStep] + split_ifs <;> rfl + all_goals + simp only [historyAdaptiveQueryStep] + exact historyCompletionQueryStep_bind history _ _ context fuel observe hnone + +noncomputable def runResolvedHistoryWith + (terminal : HistoryResolvedPrefix α → ProbComp (Option β)) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + DeferredContext → Nat → List Probe → ProbComp (Option β) := + OracleComp.construct + (fun value context fuel history => terminal ⟨context, fuel, value, history⟩) + (fun input _ next => historyAdaptiveQueryStep input next) computation + +theorem runResolvedHistoryWith_eq_prefix + (terminal : HistoryResolvedPrefix α → ProbComp (Option β)) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) : + runResolvedHistoryWith terminal computation context fuel history = + runResolvedHistoryPrefix computation context fuel history >>= fun option => + match option with + | none => pure none + | some entry => terminal entry := by + induction computation using OracleComp.inductionOn generalizing context fuel history with + | pure value => simp only [runResolvedHistoryWith, runResolvedHistoryPrefix, OracleComp.construct_pure, pure_bind] + | query_bind input next ih => + rw [runResolvedHistoryWith, OracleComp.construct_query_bind, runResolvedHistoryPrefix_query_bind, + historyAdaptiveQueryStep_bind input (fun output => runResolvedHistoryPrefix (next output)) + context fuel history (fun option => match option with | none => pure none | some entry => terminal entry) rfl] + apply congrArg (fun next => historyAdaptiveQueryStep input next context fuel history) + funext output context fuel history + exact ih output context fuel history + +theorem runResolvedHistoryAdaptive_eq_prefix_complete + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) : + runResolvedHistoryAdaptive computation context fuel history = + runResolvedHistoryPrefix computation context fuel history >>= completeHistoryResolvedPrefix := by + exact runResolvedHistoryWith_eq_prefix + (fun entry => completeResolvedHistory entry.context entry.remaining entry.history entry.value) + computation context fuel history + +theorem historyPrefix_invariant_of_mem + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) (result : HistoryResolvedPrefix α) + (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hresult : some result ∈ support (runResolvedHistoryPrefix computation context fuel history)) : + PendingCoveredBy result.history result.context ∧ result.history.length ≤ history.length + bound := by + induction computation using OracleComp.inductionOn generalizing context fuel bound history with + | pure value => + simp only [runResolvedHistoryPrefix, OracleComp.construct_pure, mem_support_pure_iff, Option.some.injEq] at hresult + subst result + exact ⟨hcovered, Nat.le_add_right _ _⟩ + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [runResolvedHistoryPrefix_query_bind] at hresult + cases input with + | uniform n => + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel bound history hcovered + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) htail + | hashOutput => + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel bound history hcovered + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) htail + | ensure coordinate => + exact ih () { context with state := context.state.ensure coordinate } fuel bound history hcovered + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) hresult + | peek coordinate => + exact ih (context.state.values coordinate) context fuel bound history hcovered + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 _) hresult + | publish coordinate => + exact ih () { context with state := context.state.publish coordinate } fuel bound history hcovered + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) hresult + | probe coordinate digest => + have hpositive : 0 < bound := by simpa [LazyRevealProbe.IsProbe] using hbound.1 + have htailBound : (next ()).IsQueryBoundP LazyRevealProbe.IsProbe (bound - 1) := by + simpa [LazyRevealProbe.IsProbe] using hbound.2 () + cases fuel with + | zero => simp [historyAdaptiveQueryStep] at hresult + | succ remaining => + simp only [historyAdaptiveQueryStep] at hresult + split_ifs at hresult with hrevealed + · have htail := ih () context remaining (bound - 1) history hcovered htailBound hresult + exact ⟨htail.1, by omega⟩ + · have htail := ih () { context with state := context.state.addPending coordinate digest } + remaining (bound - 1) (history ++ [⟨coordinate, digest⟩]) + (hcovered.addPending_append history context ⟨coordinate, digest⟩) htailBound hresult + refine ⟨htail.1, ?_⟩ + have hlength := htail.2 + simp only [List.length_append, List.length_singleton] at hlength + omega + | reveal coordinate => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep, OtsSecretIndex.coordinate] at hresult + cases hknown : context.state.values (.chainStart lay tree leafIdx chainIdx) with + | some output => + rw [hknown] at hresult + dsimp only at hresult + split_ifs at hresult with hhit + · simp at hresult + · exact ih output + { context with state := context.state.materialize (.chainStart lay tree leafIdx chainIdx) output } + fuel bound history (hcovered.of_subset (Finset.filter_subset _ _)) + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) hresult + | none => + rw [hknown] at hresult + dsimp only at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + split_ifs at htail with hhit + · simp at htail + · exact ih output + { context with state := context.state.materialize (.chainStart lay tree leafIdx chainIdx) output } + fuel bound history (hcovered.of_subset (Finset.filter_subset _ _)) + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) htail + | position position => + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep, mem_support_bind_iff] at hresult + obtain ⟨option, _hoption, htail⟩ := hresult + cases option with + | none => simp at htail + | some resolved => + exact ih resolved.output + { state := context.state.materialize (.position position) resolved.output, values := resolved.values } + fuel bound history (hcovered.of_subset (Finset.filter_subset _ _)) + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 resolved.output) htail + +theorem historyPrefix_history_clean_mass_ge_three_quarters + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) (result : HistoryResolvedPrefix α) + (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ 2 ^ 126) + (hresult : some result ∈ support (runResolvedHistoryPrefix computation context fuel history)) : + (3 / 4 : ℝ≥0∞) ≤ Pr[fun base => ¬ChainStartHistoryHit result.context result.history base | sampleOtsHashTable] := + probEvent_no_chainStartHistoryHit_ge_three_quarters result.context result.history + ((historyPrefix_invariant_of_mem computation context fuel bound history result hcovered hbound hresult).2.trans hbudget) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryPrefixRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryPrefixRisk.lean new file mode 100644 index 00000000..9856ac66 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryPrefixRisk.lean @@ -0,0 +1,230 @@ +import SphincsSecurity.Proof.OtsProbeHistoryPrefix + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 1000 + +theorem probEvent_completeHistoryResolvedPrefix_some (entry : HistoryResolvedPrefix α) : + Pr[fun result => result.isSome = true | completeHistoryResolvedPrefix (some entry)] = + Pr[fun base => ¬ChainStartHistoryHit entry.context entry.history base | sampleOtsHashTable] := by + conv_rhs => rw [probEvent_eq_tsum_ite] + rw [completeHistoryResolvedPrefix, completeResolvedHistory, probEvent_bind_eq_tsum] + apply tsum_congr + intro base + by_cases hhit : ChainStartHistoryHit entry.context entry.history base <;> simp [hhit] + +theorem probEvent_historyAdaptive_some_ge_three_quarters_prefix + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) + (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ 2 ^ 126) : + Pr[fun result => result.isSome = true | runResolvedHistoryPrefix computation context fuel history] * (3 / 4 : ℝ≥0∞) ≤ + Pr[fun result => result.isSome = true | runResolvedHistoryAdaptive computation context fuel history] := by + conv_lhs => rw [probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_right] + rw [runResolvedHistoryAdaptive_eq_prefix_complete, probEvent_bind_eq_tsum] + apply ENNReal.tsum_le_tsum + intro option + by_cases hsupport : option ∈ support (runResolvedHistoryPrefix computation context fuel history) + · cases option with + | none => simp [completeHistoryResolvedPrefix] + | some entry => + simp only [Option.isSome_some, if_true, probEvent_completeHistoryResolvedPrefix_some] + exact mul_le_mul' le_rfl + (historyPrefix_history_clean_mass_ge_three_quarters computation context fuel bound history entry + hcovered hbound hbudget hsupport) + · simp [probOutput_eq_zero_of_not_mem_support hsupport] + +theorem expected_completeHistoryResolvedPrefix_view_cost + (entry : HistoryResolvedPrefix α) (cost : DeferredContext → α → ℝ≥0∞) : + (∑' result, Pr[= result | completeHistoryResolvedPrefix (some entry)] * + match result with + | none => 0 + | some result => cost result.context result.value) = + cost entry.context entry.value * + Pr[fun base => ¬ChainStartHistoryHit entry.context entry.history base | sampleOtsHashTable] := by + rw [completeHistoryResolvedPrefix, completeResolvedHistory, tsum_probOutput_bind_mul] + conv_rhs => rw [probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_left] + apply tsum_congr + intro base + by_cases hhit : ChainStartHistoryHit entry.context entry.history base <;> + simp [hhit, mul_comm] + +noncomputable def historyChainStartAllowance + (index : DeferredContext → α → OtsSecretIndex) (digest : DeferredContext → α → Digest) : + Option (ResolvedRunResult α) → ℝ≥0∞ + | none => 0 + | some result => candidateFailureAllowance result.table result.context + (some ⟨(index result.context result.value).coordinate, digest result.context result.value⟩) + +noncomputable def historyChainStartCharge + (index : DeferredContext → α → OtsSecretIndex) (digest : DeferredContext → α → Digest) : + Option (ResolvedRunResult α) → ℝ≥0∞ + | none => 0 + | some result => (unmaterializedCandidateCharge (materializedDeferredState result.context) + (some ⟨(index result.context result.value).coordinate, digest result.context result.value⟩) : ℝ≥0∞) + +theorem expected_completeHistoryResolvedPrefix_chainStart_allowance_le + (entry : HistoryResolvedPrefix α) + (index : DeferredContext → α → OtsSecretIndex) (digest : DeferredContext → α → Digest) + (hlength : entry.history.length ≤ 2 ^ 126) + (hmissing : entry.context.state.values (index entry.context entry.value).coordinate = none) : + (∑' result, Pr[= result | completeHistoryResolvedPrefix (some entry)] * historyChainStartAllowance index digest result) ≤ + (∑' result, Pr[= result | completeHistoryResolvedPrefix (some entry)] * historyChainStartCharge index digest result) * + ((4 / 3 : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) := by + unfold historyChainStartCharge + rw [expected_completeHistoryResolvedPrefix_view_cost entry (fun context value => + (unmaterializedCandidateCharge (materializedDeferredState context) + (some ⟨(index context value).coordinate, digest context value⟩) : ℝ≥0∞))] + calc + _ = ∑' base, Pr[= base | sampleOtsHashTable] * + if ¬ChainStartHistoryHit entry.context entry.history base then + candidateFailureAllowance (completedStartTable entry.context.state base) entry.context + (some ⟨(index entry.context entry.value).coordinate, digest entry.context entry.value⟩) + else 0 := by + rw [completeHistoryResolvedPrefix, completeResolvedHistory, tsum_probOutput_bind_mul] + apply tsum_congr + intro base + by_cases hhit : ChainStartHistoryHit entry.context entry.history base <;> + simp [hhit, historyChainStartAllowance] + _ ≤ _ := by + have hlocal := expected_history_guarded_chainStart_allowance_le_four_thirds entry.context entry.history hlength + (index entry.context entry.value) (digest entry.context entry.value) hmissing + simpa only [mul_assoc, mul_comm, mul_left_comm] using hlocal + +theorem expected_historyAdaptive_chainStart_allowance_le + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) + (index : DeferredContext → α → OtsSecretIndex) (digest : DeferredContext → α → Digest) + (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ 2 ^ 126) + (hmissing : ∀ entry, some entry ∈ support (runResolvedHistoryPrefix computation context fuel history) → + entry.context.state.values (index entry.context entry.value).coordinate = none) : + (∑' result, Pr[= result | runResolvedHistoryAdaptive computation context fuel history] * historyChainStartAllowance index digest result) ≤ + (∑' result, Pr[= result | runResolvedHistoryAdaptive computation context fuel history] * historyChainStartCharge index digest result) * + ((4 / 3 : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) := by + simp only [runResolvedHistoryAdaptive_eq_prefix_complete, tsum_probOutput_bind_mul] + rw [← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro option + by_cases hsupport : option ∈ support (runResolvedHistoryPrefix computation context fuel history) + · cases option with + | none => simp [completeHistoryResolvedPrefix, historyChainStartAllowance, historyChainStartCharge] + | some entry => + have hlength := (historyPrefix_invariant_of_mem computation context fuel bound history entry hcovered hbound hsupport).2 + have hlocal := expected_completeHistoryResolvedPrefix_chainStart_allowance_le entry index digest + (hlength.trans hbudget) (hmissing entry hsupport) + simpa only [mul_assoc] using mul_le_mul' le_rfl hlocal + · simp [probOutput_eq_zero_of_not_mem_support hsupport] + +theorem expected_completeHistoryResolvedPrefix_function + (entry : HistoryResolvedPrefix α) (cost : (OtsSecretIndex → HashOutput) → DeferredContext → α → ℝ≥0∞) : + (∑' result, Pr[= result | completeHistoryResolvedPrefix (some entry)] * + match result with + | none => 0 + | some result => cost result.table result.context result.value) = + ∑' base, Pr[= base | sampleOtsHashTable] * + if ChainStartHistoryHit entry.context entry.history base then 0 + else cost (completedStartTable entry.context.state base) entry.context entry.value := by + rw [completeHistoryResolvedPrefix, completeResolvedHistory, tsum_probOutput_bind_mul] + apply tsum_congr + intro base + by_cases hhit : ChainStartHistoryHit entry.context entry.history base <;> simp [hhit] + +noncomputable def unresolvedStartCandidateAllowance + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) : Option Probe → ℝ≥0∞ + | some candidate@⟨.chainStart _ _ _ _, _⟩ => + if context.state.values candidate.coordinate = none then candidateFailureAllowance table context (some candidate) else 0 + | _ => 0 + +noncomputable def unresolvedStartCandidateCharge (context : DeferredContext) : Option Probe → ℝ≥0∞ + | some candidate@⟨.chainStart _ _ _ _, _⟩ => + if context.state.values candidate.coordinate = none then + (unmaterializedCandidateCharge (materializedDeferredState context) (some candidate) : ℝ≥0∞) + else 0 + | _ => 0 + +noncomputable def historyUnresolvedStartAllowance (candidate : DeferredContext → α → Option Probe) : + Option (ResolvedRunResult α) → ℝ≥0∞ + | none => 0 + | some result => unresolvedStartCandidateAllowance result.table result.context (candidate result.context result.value) + +noncomputable def historyUnresolvedStartCharge (candidate : DeferredContext → α → Option Probe) : + Option (ResolvedRunResult α) → ℝ≥0∞ + | none => 0 + | some result => unresolvedStartCandidateCharge result.context (candidate result.context result.value) + +theorem expected_completeHistoryResolvedPrefix_unresolvedStart_le + (entry : HistoryResolvedPrefix α) (candidate : DeferredContext → α → Option Probe) + (hlength : entry.history.length ≤ 2 ^ 126) : + (∑' result, Pr[= result | completeHistoryResolvedPrefix (some entry)] * historyUnresolvedStartAllowance candidate result) ≤ + (∑' result, Pr[= result | completeHistoryResolvedPrefix (some entry)] * historyUnresolvedStartCharge candidate result) * + ((4 / 3 : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) := by + unfold historyUnresolvedStartAllowance historyUnresolvedStartCharge + rw [expected_completeHistoryResolvedPrefix_function entry (fun table context value => + unresolvedStartCandidateAllowance table context (candidate context value)), + expected_completeHistoryResolvedPrefix_view_cost entry (fun context value => + unresolvedStartCandidateCharge context (candidate context value))] + cases hcandidate : candidate entry.context entry.value with + | none => simp [unresolvedStartCandidateAllowance, unresolvedStartCandidateCharge] + | some probe => + rcases probe with ⟨coordinate, digest⟩ + cases coordinate with + | position position => simp [unresolvedStartCandidateAllowance, unresolvedStartCandidateCharge] + | chainStart lay tree leafIdx chainIdx => + by_cases hmissing : entry.context.state.values (.chainStart lay tree leafIdx chainIdx) = none + · simp only [unresolvedStartCandidateAllowance, unresolvedStartCandidateCharge, if_pos hmissing] + have hlocal := expected_history_guarded_chainStart_allowance_le_four_thirds entry.context entry.history hlength + ⟨lay, tree, leafIdx, chainIdx⟩ digest hmissing + simpa only [OtsSecretIndex.coordinate, ite_not, mul_assoc, mul_comm, mul_left_comm] using hlocal + · simp [unresolvedStartCandidateAllowance, unresolvedStartCandidateCharge, hmissing] + +theorem expected_historyAdaptive_unresolvedStart_allowance_le + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) + (candidate : DeferredContext → α → Option Probe) + (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ 2 ^ 126) : + (∑' result, Pr[= result | runResolvedHistoryAdaptive computation context fuel history] * historyUnresolvedStartAllowance candidate result) ≤ + (∑' result, Pr[= result | runResolvedHistoryAdaptive computation context fuel history] * historyUnresolvedStartCharge candidate result) * + ((4 / 3 : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) := by + simp only [runResolvedHistoryAdaptive_eq_prefix_complete, tsum_probOutput_bind_mul] + rw [← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro option + by_cases hsupport : option ∈ support (runResolvedHistoryPrefix computation context fuel history) + · cases option with + | none => simp [completeHistoryResolvedPrefix, historyUnresolvedStartAllowance, historyUnresolvedStartCharge] + | some entry => + have hlength := (historyPrefix_invariant_of_mem computation context fuel bound history entry hcovered hbound hsupport).2 + have hlocal := expected_completeHistoryResolvedPrefix_unresolvedStart_le entry candidate (hlength.trans hbudget) + simpa only [mul_assoc] using mul_le_mul' le_rfl hlocal + · simp [probOutput_eq_zero_of_not_mem_support hsupport] + +theorem evalDist_history_filtered_runResolved_eq_prefix_observe + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) + (observe : Option (ResolvedRunResult α) → ProbComp β) + (hobserve : ∀ result, result.context.ValuesConsistent → StartTableAgrees result.context.state result.table → + ¬DeferredCompletable result.table result.context → evalDist (observe (some result)) = evalDist (observe none)) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ 2 ^ 126) : + evalDist ((do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then pure none + else runResolvedFromTable context fuel (completedStartTable context.state base) computation) >>= observe) = + evalDist ((runResolvedHistoryPrefix computation context fuel history >>= completeHistoryResolvedPrefix) >>= observe) := by + rw [← runResolvedHistoryAdaptive_eq_prefix_complete] + have hspace : 2 ^ 126 < Fintype.card Digest := by norm_num [digestBits] + exact evalDist_history_filtered_runResolved_eq_adaptive_observe computation context fuel bound history observe + hobserve hconsistent hcovered (((Nat.add_le_add_right hcovered.card_le bound).trans hbudget).trans_lt hspace) hbound + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryQueryPrefix.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryQueryPrefix.lean new file mode 100644 index 00000000..0b739c6c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryQueryPrefix.lean @@ -0,0 +1,376 @@ +import SphincsSecurity.Proof.OtsProbeHistoryCanonicalBoundary + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable +set_option backward.isDefEq.respectTransparency false + +theorem runResolvedHistoryCompletion_eq_adaptive_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) : + runResolvedHistoryCompletion history computation context fuel = runResolvedHistoryAdaptive computation context fuel history := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => rfl + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [runResolvedHistoryCompletion_query_bind, runResolvedHistoryAdaptive_query_bind] + have hnext : (fun output context fuel => runResolvedHistoryCompletion history (next output) context fuel) = + (fun output context fuel => runResolvedHistoryAdaptive (next output) context fuel history) := by + funext output context fuel + exact ih output context fuel (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + cases input with + | probe coordinate digest => simpa [LazyRevealProbe.IsProbe] using hbound.1 + | uniform n => simp only [historyAdaptiveQueryStep]; rw [hnext] + | hashOutput => simp only [historyAdaptiveQueryStep]; rw [hnext] + | ensure coordinate => simp only [historyAdaptiveQueryStep]; rw [hnext] + | peek coordinate => simp only [historyAdaptiveQueryStep]; rw [hnext] + | publish coordinate => simp only [historyAdaptiveQueryStep]; rw [hnext] + | reveal coordinate => simp only [historyAdaptiveQueryStep]; rw [hnext] + +theorem historyPrefix_history_eq_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) (result : HistoryResolvedPrefix α) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) + (hresult : some result ∈ support (runResolvedHistoryPrefix computation context fuel history)) : + result.history = history := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp only [runResolvedHistoryPrefix, OracleComp.construct_pure, mem_support_pure_iff, Option.some.injEq] at hresult + cases hresult + rfl + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [runResolvedHistoryPrefix_query_bind] at hresult + cases input with + | probe coordinate digest => simpa [LazyRevealProbe.IsProbe] using hbound.1 + | uniform n => + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep, mem_support_bind_iff] at hresult + obtain ⟨output, _, htail⟩ := hresult + exact ih output context fuel (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) htail + | hashOutput => + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep, mem_support_bind_iff] at hresult + obtain ⟨output, _, htail⟩ := hresult + exact ih output context fuel (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) htail + | ensure coordinate => + exact ih () { context with state := context.state.ensure coordinate } fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) hresult + | peek coordinate => + exact ih (context.state.values coordinate) context fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 _) hresult + | publish coordinate => + exact ih () { context with state := context.state.publish coordinate } fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) hresult + | reveal coordinate => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep, OtsSecretIndex.coordinate] at hresult + cases hknown : context.state.values (.chainStart lay tree leafIdx chainIdx) with + | some output => + rw [hknown] at hresult + dsimp only at hresult + split_ifs at hresult with hhit + · simp at hresult + · exact ih output + { context with state := context.state.materialize (.chainStart lay tree leafIdx chainIdx) output } + fuel (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) hresult + | none => + rw [hknown] at hresult + dsimp only at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _, htail⟩ := hresult + split_ifs at htail with hhit + · simp at htail + · exact ih output + { context with state := context.state.materialize (.chainStart lay tree leafIdx chainIdx) output } + fuel (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) htail + | position position => + simp only [historyAdaptiveQueryStep, historyCompletionQueryStep, mem_support_bind_iff] at hresult + obtain ⟨option, _, htail⟩ := hresult + cases option with + | none => simp at htail + | some resolved => + exact ih resolved.output + { state := context.state.materialize (.position position) resolved.output, values := resolved.values } + fuel (by simpa [LazyRevealProbe.IsProbe] using hbound.2 resolved.output) htail + +theorem canonicalHistoryPrefix_history_eq_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) + (entry result : HistoryResolvedPrefix α) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) + (hentry : some entry ∈ support (runResolvedHistoryPrefix computation context fuel history)) + (hcanonical : canonicalHistoryPrefix (some entry) = some result) : result.history = history := + (canonicalHistoryPrefix_history_length entry result hcanonical).trans + (historyPrefix_history_eq_of_probeFree computation context fuel history entry hbound hentry) + +theorem evalDist_probeFree_canonicalBoundary_observe_history + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) + (observe : List Probe → Option (ResolvedRunResult α) → ProbComp β) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) (hbudget : history.length ≤ 2 ^ 126) : + evalDist (sampledHistoryFilteredRun computation context fuel history >>= fun result => + observe history (canonicalHistoryBoundary result)) = + evalDist (runResolvedHistoryPrefix computation context fuel history >>= fun option => + match canonicalHistoryPrefix option with + | none => observe history none + | some entry => completeHistoryResolvedPrefix (some entry) >>= observe entry.history) := by + have hdist := evalDist_sampledHistoryFilteredRun_canonicalBoundary computation context fuel 0 history + hconsistent hcovered hbound (by simpa using hbudget) + calc + _ = evalDist ((sampledHistoryFilteredRun computation context fuel history >>= fun result => + pure (canonicalHistoryBoundary result)) >>= observe history) := by simp only [bind_assoc, pure_bind] + _ = evalDist ((runResolvedHistoryPrefix computation context fuel history >>= fun option => + completeHistoryResolvedPrefix (canonicalHistoryPrefix option)) >>= observe history) := by + rw [evalDist_bind, hdist, ← evalDist_bind] + _ = _ := by + rw [bind_assoc] + apply evalDist_bind_congr + intro option hsupport + cases option with + | none => simp only [canonicalHistoryPrefix, completeHistoryResolvedPrefix, pure_bind] + | some original => + cases hcanonical : canonicalHistoryPrefix (some original) with + | none => simp only [completeHistoryResolvedPrefix, pure_bind] + | some entry => + dsimp only + rw [canonicalHistoryPrefix_history_eq_of_probeFree computation context fuel history original entry + hbound hsupport hcanonical] + +theorem evalDist_historyCompletion_canonicalBoundary + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (history : List Probe) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) (hbudget : history.length ≤ 2 ^ 126) : + evalDist (runResolvedHistoryCompletion history computation context fuel >>= fun result => pure (canonicalHistoryBoundary result)) = + evalDist (runResolvedHistoryPrefix computation context fuel history >>= fun option => + completeHistoryResolvedPrefix (canonicalHistoryPrefix option)) := by + have hspace : 2 ^ 126 < Fintype.card Digest := by norm_num [digestBits] + have hraw := evalDist_history_filtered_runResolved_eq_completion_of_probeFree history computation context fuel + hcovered ((hcovered.card_le.trans hbudget).trans_lt hspace) hbound + have hdist := evalDist_sampledHistoryFilteredRun_canonicalBoundary computation context fuel 0 history + hconsistent hcovered hbound (by simpa using hbudget) + change evalDist (sampledHistoryFilteredRun computation context fuel history) = _ at hraw + rw [evalDist_bind, ← hraw, ← evalDist_bind] + exact hdist + +noncomputable def historyHashQuerySuffix (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) : + StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput := + match (purePlanProbingHashQuery parameter input context.state).action with + | .ordinary => splitHashQuery (.ordinary input) + | .resolve coordinate => resolveKnownInput parameter coordinate input + +theorem historyHashQuerySuffix_probeFree (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) : + ProbeFree (historyHashQuerySuffix parameter input context) := by + unfold historyHashQuerySuffix + cases (purePlanProbingHashQuery parameter input context.state).action with + | ordinary => exact splitHashQuery_probeFree _ + | resolve coordinate => exact resolveKnownInput_probeFree parameter coordinate input + +noncomputable def runCanonicalHistoryHashPrefix + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) + (history : List Probe) (fuel : Nat) (cache : SplitHashCache) : + ProbComp (Option (HistoryResolvedPrefix (HashOutput × SplitHashCache))) := do + let candidate := (purePlanProbingHashQuery parameter input context.state).candidate? + let entry ← runResolvedHistoryPrefix ((historyHashQuerySuffix parameter input context).run cache) + (afterCandidateContext context candidate) (if candidate.isSome then fuel else fuel + 1) (history ++ candidate.toList) + pure (canonicalHistoryPrefix entry) + +theorem evalDist_sampledHistoryHash_canonicalPrefix + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) + (history : List Probe) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hpublic : ∀ index : OtsSecretIndex, index.coordinate ∈ context.state.revealed → context.state.values index.coordinate ≠ none) + (hcovered : PendingCoveredBy history context) (hbudget : history.length + 1 ≤ 2 ^ 126) : + evalDist (sampledHistoryFilteredRun ((probingHashQuery parameter input).run cache) context (fuel + 1) history >>= + fun result => pure (canonicalHistoryBoundary result)) = + evalDist (runCanonicalHistoryHashPrefix parameter input context history fuel cache >>= completeHistoryResolvedPrefix) := by + let candidate := (purePlanProbingHashQuery parameter input context.state).candidate? + have hspace : 2 ^ 126 < Fintype.card Digest := by norm_num [digestBits] + have hcard : context.state.pending.card + 1 < Fintype.card Digest := + ((Nat.add_le_add_right hcovered.card_le 1).trans hbudget).trans_lt hspace + have hraw := evalDist_history_filtered_probingHashQuery_observe parameter input context history fuel cache + (pure (none : Option (ResolvedRunResult (HashOutput × SplitHashCache)))) + (fun result => pure (canonicalHistoryBoundary result)) rfl (by + intro result _ _ hdoomed + simp [canonicalHistoryBoundary, hdoomed]) hconsistent hpublic hcovered hcard + have hlength : (history ++ candidate.toList).length ≤ 2 ^ 126 := by + have hle : candidate.toList.length ≤ 1 := by cases candidate <;> simp + simp only [List.length_append] + omega + have hcompletion := evalDist_historyCompletion_canonicalBoundary ((historyHashQuerySuffix parameter input context).run cache) + (afterCandidateContext context candidate) (if candidate.isSome then fuel else fuel + 1) (history ++ candidate.toList) + (afterCandidateContext_valuesConsistent context candidate hconsistent) (hcovered.afterCandidate candidate) + (historyHashQuerySuffix_probeFree parameter input context cache) hlength + calc + _ = evalDist (runHistoryHashQueryCompletion parameter input context history fuel cache >>= + fun result => pure (canonicalHistoryBoundary result)) := by + calc + _ = _ := ?_ + _ = _ := hraw + unfold sampledHistoryFilteredRun + rw [bind_assoc] + apply evalDist_bind_congr + intro base _ + split_ifs <;> simp only [pure_bind, canonicalHistoryBoundary] + _ = _ := by + unfold runHistoryHashQueryCompletion runCanonicalHistoryHashPrefix + dsimp only + rw [bind_assoc] + simp only [pure_bind] + exact hcompletion + +theorem canonicalHistoryHashPrefix_history + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) + (history : List Probe) (fuel : Nat) (cache : SplitHashCache) + (result : HistoryResolvedPrefix (HashOutput × SplitHashCache)) + (hresult : some result ∈ support (runCanonicalHistoryHashPrefix parameter input context history fuel cache)) : + result.history = history ++ (purePlanProbingHashQuery parameter input context.state).candidate?.toList := by + unfold runCanonicalHistoryHashPrefix at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨option, hoption, hcanonical⟩ := hresult + simp only [mem_support_pure_iff] at hcanonical + cases option with + | none => simp [canonicalHistoryPrefix] at hcanonical + | some entry => + exact canonicalHistoryPrefix_history_eq_of_probeFree _ _ _ _ entry result + (historyHashQuerySuffix_probeFree parameter input context cache) hoption hcanonical.symm + +theorem evalDist_sampledHistoryHash_canonicalPrefix_observe_history + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) + (history : List Probe) (fuel : Nat) (cache : SplitHashCache) + (observe : List Probe → Option (ResolvedRunResult (HashOutput × SplitHashCache)) → ProbComp β) + (hconsistent : context.ValuesConsistent) + (hpublic : ∀ index : OtsSecretIndex, index.coordinate ∈ context.state.revealed → context.state.values index.coordinate ≠ none) + (hcovered : PendingCoveredBy history context) (hbudget : history.length + 1 ≤ 2 ^ 126) : + let updated := history ++ (purePlanProbingHashQuery parameter input context.state).candidate?.toList + evalDist (sampledHistoryFilteredRun ((probingHashQuery parameter input).run cache) context (fuel + 1) history >>= + fun result => observe updated (canonicalHistoryBoundary result)) = + evalDist (runCanonicalHistoryHashPrefix parameter input context history fuel cache >>= fun option => + match option with + | none => observe updated none + | some entry => completeHistoryResolvedPrefix (some entry) >>= observe entry.history) := by + dsimp only + let updated := history ++ (purePlanProbingHashQuery parameter input context.state).candidate?.toList + have hdist := evalDist_sampledHistoryHash_canonicalPrefix parameter input context history fuel cache + hconsistent hpublic hcovered hbudget + calc + _ = evalDist ((sampledHistoryFilteredRun ((probingHashQuery parameter input).run cache) context (fuel + 1) history >>= + fun result => pure (canonicalHistoryBoundary result)) >>= observe updated) := by simp only [bind_assoc, pure_bind, updated] + _ = evalDist ((runCanonicalHistoryHashPrefix parameter input context history fuel cache >>= + completeHistoryResolvedPrefix) >>= observe updated) := by rw [evalDist_bind, hdist, ← evalDist_bind] + _ = _ := by + rw [bind_assoc] + apply evalDist_bind_congr + intro option hsupport + cases option with + | none => simp only [completeHistoryResolvedPrefix, pure_bind, updated] + | some entry => + dsimp only + rw [canonicalHistoryHashPrefix_history parameter input context history fuel cache entry hsupport] + +theorem canonicalHistoryHashPrefix_invariant + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) + (history : List Probe) (fuel : Nat) (cache : SplitHashCache) + (result : HistoryResolvedPrefix (HashOutput × SplitHashCache)) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hresult : some result ∈ support (runCanonicalHistoryHashPrefix parameter input context history fuel cache)) : + result.context.ValuesConsistent ∧ PendingCoveredBy result.history result.context ∧ PublishedValues result.context.state ∧ + ∀ base, CanonicalMaterializedValues (completedStartTable result.context.state base) result.context := by + unfold runCanonicalHistoryHashPrefix at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨option, hoption, hcanonical⟩ := hresult + simp only [mem_support_pure_iff] at hcanonical + cases option with + | none => simp [canonicalHistoryPrefix] at hcanonical + | some entry => + have hafter := afterCandidateContext_valuesConsistent context + (purePlanProbingHashQuery parameter input context.state).candidate? hconsistent + have hentry := historyPrefix_invariant_of_mem _ _ _ 0 _ entry (hcovered.afterCandidate _) + (historyHashQuerySuffix_probeFree parameter input context cache) hoption + exact canonicalHistoryPrefix_invariant entry result hcanonical.symm + (valuesConsistent_of_mem_historyPrefix _ _ _ _ entry hafter hoption) hentry.1 + +theorem evalDist_sampledHistorySign_canonicalPrefix_observe_history + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (history : List Probe) (cache : SplitHashCache) + (observe : List Probe → Option (ResolvedRunResult (Option Signature × SplitHashCache)) → ProbComp β) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) (hbudget : history.length ≤ 2 ^ 126) : + evalDist (sampledHistoryFilteredRun ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache) + context fuel history >>= fun result => observe history (canonicalHistoryBoundary result)) = + evalDist (runResolvedHistoryPrefix ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache) + context fuel history >>= fun option => + match canonicalHistoryPrefix option with + | none => observe history none + | some entry => completeHistoryResolvedPrefix (some entry) >>= observe entry.history) := by + have h := evalDist_probeFree_canonicalBoundary_observe_history + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache) context fuel history observe hconsistent hcovered + (maskedPublishedChronologicalSign_probeFree parameter root ftsSecret message cache) hbudget + convert h using 1 + congr 1 + apply bind_congr + intro option + cases canonicalHistoryPrefix option <;> rfl + +noncomputable def nativeCanonicalHistoryNext + (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) : + Option (ResolvedRunResult α) → ProbComp (Option (ResolvedRunResult β)) + | none => pure none + | some result => do + let final ← runResolvedFromTable result.context result.remaining result.table (next result.value) + pure (canonicalHistoryBoundary final) + +theorem completeHistoryResolvedPrefix_nativeNext + (entry : HistoryResolvedPrefix α) (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) : + (completeHistoryResolvedPrefix (some entry) >>= nativeCanonicalHistoryNext next) = + (sampledHistoryFilteredRun (next entry.value) entry.context entry.remaining entry.history >>= + fun result => pure (canonicalHistoryBoundary result)) := by + simp only [completeHistoryResolvedPrefix, completeResolvedHistory, sampledHistoryFilteredRun, bind_assoc] + apply bind_congr + intro base + split_ifs <;> simp only [pure_bind, nativeCanonicalHistoryNext, canonicalHistoryBoundary] + +theorem evalDist_probeFree_then_block_canonicalPrefix + (first : OracleComp (LazyRevealProbe.World Coordinate) α) + (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) + (context : DeferredContext) (fuel bound : Nat) (history : List Probe) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hfirst : first.IsQueryBoundP LazyRevealProbe.IsProbe 0) + (hnext : ∀ value, (next value).IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ 2 ^ 126) : + evalDist (sampledHistoryFilteredRun first context fuel history >>= fun result => + nativeCanonicalHistoryNext next (canonicalHistoryBoundary result)) = + evalDist (runResolvedHistoryPrefix first context fuel history >>= fun option => + match canonicalHistoryPrefix option with + | none => pure none + | some entry => runResolvedHistoryPrefix (next entry.value) entry.context entry.remaining entry.history >>= fun final => + completeHistoryResolvedPrefix (canonicalHistoryPrefix final)) := by + have hfirstBudget : history.length ≤ 2 ^ 126 := by omega + have hdist := evalDist_probeFree_canonicalBoundary_observe_history first context fuel history + (fun _ => nativeCanonicalHistoryNext next) hconsistent hcovered hfirst hfirstBudget + calc + _ = _ := hdist + _ = _ := by + apply evalDist_bind_congr + intro option hsupport + cases option with + | none => simp only [canonicalHistoryPrefix, nativeCanonicalHistoryNext] + | some original => + cases hcanonical : canonicalHistoryPrefix (some original) with + | none => simp only [nativeCanonicalHistoryNext] + | some entry => + dsimp only + rw [completeHistoryResolvedPrefix_nativeNext] + have hhistory := canonicalHistoryPrefix_history_eq_of_probeFree first context fuel history original entry + hfirst hsupport hcanonical + have horiginal := historyPrefix_invariant_of_mem first context fuel 0 history original hcovered hfirst hsupport + have hinvariant := canonicalHistoryPrefix_invariant original entry hcanonical + (valuesConsistent_of_mem_historyPrefix first context fuel history original hconsistent hsupport) horiginal.1 + exact evalDist_sampledHistoryFilteredRun_canonicalBoundary (next entry.value) entry.context entry.remaining bound + entry.history hinvariant.1 hinvariant.2.1 (hnext entry.value) (by rwa [hhistory]) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryRevealSampling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryRevealSampling.lean new file mode 100644 index 00000000..99eb1174 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryRevealSampling.lean @@ -0,0 +1,223 @@ +import SphincsSecurity.Proof.OtsProbeStartHistorySampling + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 100000 + +noncomputable def startTableAvoidingPending (context : DeferredContext) (index : OtsSecretIndex) : HashOutput := + if h : ∃ digest : Digest, digest ∉ context.state.pendingAt index.coordinate then hashOutputOfDigest (Classical.choose h) + else 0 + +theorem startTableAvoidingPending_no_missingHit (context : DeferredContext) + (hcard : context.state.pending.card < Fintype.card Digest) : + ¬MissingChainStartHit (startTableAvoidingPending context) context := by + rintro ⟨index, _hmissing, hhit⟩ + have hex := exists_digest_not_mem_pendingAt context.state index.coordinate hcard + unfold LazyRevealProbe.State.hitAt startTableAvoidingPending at hhit + rw [dif_pos hex, truncateHash_hashOutputOfDigest] at hhit + exact Classical.choose_spec hex hhit + +theorem chainStartHistoryHit_eq_of_start_values_eq + (before after : DeferredContext) (history : List Probe) (base : OtsSecretIndex → HashOutput) + (hvalues : ∀ index : OtsSecretIndex, after.state.values index.coordinate = before.state.values index.coordinate) : + ChainStartHistoryHit after history base = ChainStartHistoryHit before history base := by + apply propext + unfold ChainStartHistoryHit + apply exists_congr + rintro ⟨coordinate, digest⟩ + cases coordinate with + | position position => simp [ChainStartEntryHit] + | chainStart lay tree leafIdx chainIdx => + have heq := hvalues ⟨lay, tree, leafIdx, chainIdx⟩ + change after.state.values (.chainStart lay tree leafIdx chainIdx) = + before.state.values (.chainStart lay tree leafIdx chainIdx) at heq + rw [heq] + +theorem chainStartHistoryHit_materialize_position + (context : DeferredContext) (history : List Probe) (base : OtsSecretIndex → HashOutput) + (position : Position) (output : HashOutput) (values : DeferredStructuralValues) : + ChainStartHistoryHit { state := context.state.materialize (.position position) output, values := values } history base = + ChainStartHistoryHit context history base := by + apply chainStartHistoryHit_eq_of_start_values_eq + intro index + simp [LazyRevealProbe.State.materialize, OtsSecretIndex.coordinate] + +theorem evalDist_history_filtered_resolve_position_swap + (context : DeferredContext) (history : List Probe) (position : Position) + (reference : OtsSecretIndex → HashOutput) (hreference : ¬MissingChainStartHit reference context) + (hcovered : PendingCoveredBy history context) + (failure : ProbComp α) (next : (OtsSecretIndex → HashOutput) → Option DeferredResolution → ProbComp α) : + evalDist (do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then failure + else do + let resolved ← resolveDeferredReveal (completedStartTable context.state base) position context + next (completedStartTable context.state base) resolved) = + evalDist (do + let resolved ← resolveDeferredReveal reference position context + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then failure + else next (completedStartTable context.state base) resolved) := by + calc + _ = evalDist (do + let base ← sampleOtsHashTable + let resolved ← resolveDeferredReveal reference position context + if ChainStartHistoryHit context history base then failure + else next (completedStartTable context.state base) resolved) := by + apply evalDist_bind_congr + intro base _hbase + by_cases hhit : ChainStartHistoryHit context history base + · simp only [if_pos hhit] + exact (OracleComp.DeferredSampling.evalDist_bind_const_neverFails _ (by simp) failure).symm + · simp only [if_neg hhit] + rw [evalDist_bind, evalDist_bind, + evalDist_resolveDeferredReveal_eq_of_no_missingChainStartHit _ reference position context + (no_missingChainStartHit_of_history_clean context history base hcovered hhit) hreference] + _ = _ := evalDist_bind_bind_swap _ _ _ + +theorem evalDist_history_filtered_runResolved_revealPosition + (context : DeferredContext) (history : List Probe) (fuel : Nat) (position : Position) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) + (hcovered : PendingCoveredBy history context) (hcard : context.state.pending.card < Fintype.card Digest) : + evalDist (do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then pure none + else + runResolvedFromTable context fuel (completedStartTable context.state base) + (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) (.reveal (.position position)) >>= next)) = + evalDist (do + let resolved ← resolveDeferredReveal (startTableAvoidingPending context) position context + match resolved with + | none => pure none + | some resolved => do + let after : DeferredContext := + { state := context.state.materialize (.position position) resolved.output, values := resolved.values } + let base ← sampleOtsHashTable + if ChainStartHistoryHit after history base then pure none + else runResolvedFromTable after fuel (completedStartTable after.state base) (next resolved.output)) := by + let continuation : (OtsSecretIndex → HashOutput) → Option DeferredResolution → ProbComp (Option (ResolvedRunResult α)) := + fun table option => match option with + | none => pure none + | some resolved => runResolvedFromTable + { state := context.state.materialize (.position position) resolved.output, values := resolved.values } + fuel table (next resolved.output) + have hswap := evalDist_history_filtered_resolve_position_swap context history position (startTableAvoidingPending context) + (startTableAvoidingPending_no_missingHit context hcard) hcovered (pure none) continuation + simp_rw [runResolvedFromTable_reveal_query_bind] + change evalDist (do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then pure none + else resolveDeferredReveal (completedStartTable context.state base) position context >>= + continuation (completedStartTable context.state base)) = _ + rw [hswap] + apply evalDist_bind_congr + intro option _hoption + cases option with + | none => + simp only [continuation, ite_self] + exact evalDist_sampleOtsHashTable_bind_const (pure none) + | some resolved => + apply evalDist_bind_congr + intro base _hbase + simp only [continuation, chainStartHistoryHit_materialize_position, completedStartTable_materialize_position] + +theorem evalDist_history_filtered_runResolved_revealStart_missing + (context : DeferredContext) (history : List Probe) (fuel : Nat) (index : OtsSecretIndex) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) + (hcovered : PendingCoveredBy history context) (hmissing : context.state.values index.coordinate = none) : + evalDist (do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then pure none + else + runResolvedFromTable context fuel (completedStartTable context.state base) + (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) (.reveal index.coordinate) >>= next)) = + evalDist (do + let output ← LazyRevealProbe.sampleHashOutput + if ChainStartHistoryOutputHit history index output then pure none + else do + let after : DeferredContext := { context with state := context.state.materialize index.coordinate output } + let base ← sampleOtsHashTable + if ChainStartHistoryHit after history base then pure none + else runResolvedFromTable after fuel (completedStartTable after.state base) (next output)) := by + let continuation : (OtsSecretIndex → HashOutput) → HashOutput → ProbComp (Option (ResolvedRunResult α)) := + fun table output => runResolvedFromTable + { context with state := context.state.materialize index.coordinate output } fuel table (next output) + have hread := evalDist_history_filtered_completionTable_read context history index hmissing (pure none) continuation + calc + _ = evalDist (do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then pure none + else continuation (completedStartTable context.state base) (base index)) := by + apply evalDist_bind_congr + intro base _hbase + by_cases hhit : ChainStartHistoryHit context history base + · simp only [if_pos hhit] + · have hclean := no_missingChainStartHit_of_history_clean context history base hcovered hhit + have hlookup : completedStartTable context.state base index = base index := by + simp [completedStartTable, hmissing] + have hnot : ¬context.state.hitAt index.coordinate (base index) := by + intro hbad + exact hclean ⟨index, hmissing, by rwa [hlookup]⟩ + simp only [if_neg hhit, runResolvedFromTable_reveal_query_bind] + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + simp only [OtsSecretIndex.coordinate] at hmissing hnot ⊢ + simp [resolveDeferredChainStart, OtsSecretIndex.coordinate, hmissing, hlookup, hnot, continuation] + _ = _ := hread + +theorem evalDist_history_filtered_runResolved_revealStart_known + (context : DeferredContext) (history : List Probe) (fuel : Nat) (index : OtsSecretIndex) (output : HashOutput) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) + (hknown : context.state.values index.coordinate = some output) : + evalDist (do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then pure none + else + runResolvedFromTable context fuel (completedStartTable context.state base) + (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) (.reveal index.coordinate) >>= next)) = + evalDist (if context.state.hitAt index.coordinate output then pure none else do + let after : DeferredContext := { context with state := context.state.materialize index.coordinate output } + let base ← sampleOtsHashTable + if ChainStartHistoryHit after history base then pure none + else runResolvedFromTable after fuel (completedStartTable after.state base) (next output)) := by + have hvalues : Function.update context.state.values index.coordinate (some output) = context.state.values := by + rw [← hknown, Function.update_eq_self] + have hhistory (base : OtsSecretIndex → HashOutput) : + ChainStartHistoryHit { context with state := context.state.materialize index.coordinate output } history base = + ChainStartHistoryHit context history base := by + apply chainStartHistoryHit_eq_of_start_values_eq + intro other + simp only [LazyRevealProbe.State.materialize, hvalues] + have htable (base : OtsSecretIndex → HashOutput) : + completedStartTable (context.state.materialize index.coordinate output) base = completedStartTable context.state base := by + funext other + simp only [completedStartTable, LazyRevealProbe.State.materialize, hvalues] + by_cases hhit : context.state.hitAt index.coordinate output + · rw [if_pos hhit] + calc + _ = evalDist (do let _base ← sampleOtsHashTable; pure (none : Option (ResolvedRunResult α))) := by + apply evalDist_bind_congr + intro base _hbase + by_cases hbad : ChainStartHistoryHit context history base + · simp only [if_pos hbad] + · simp only [if_neg hbad, runResolvedFromTable_reveal_query_bind] + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + simp only [OtsSecretIndex.coordinate] at hknown hhit ⊢ + simp [resolveDeferredChainStart, OtsSecretIndex.coordinate, hknown, hhit] + _ = _ := evalDist_sampleOtsHashTable_bind_const _ + · rw [if_neg hhit] + apply evalDist_bind_congr + intro base _hbase + simp only [hhistory, htable] + by_cases hbad : ChainStartHistoryHit context history base + · simp only [if_pos hbad] + · simp only [if_neg hbad, runResolvedFromTable_reveal_query_bind] + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + simp only [OtsSecretIndex.coordinate] at hknown hhit ⊢ + simp [resolveDeferredChainStart, OtsSecretIndex.coordinate, hknown, hhit] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryRootSampling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryRootSampling.lean new file mode 100644 index 00000000..074f2fb8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeHistoryRootSampling.lean @@ -0,0 +1,213 @@ +import SphincsSecurity.Proof.OtsProbeHistoryCanonicalRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 4000 + +noncomputable def canonicalRootHistoryPrefix (fuel : Nat) : ProbComp (Option (HistoryResolvedPrefix (Digest × SplitHashCache))) := + runCanonicalHistoryBlockPrefix (maskedPublishedTreeRoot.run emptySplitHashCache) + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } fuel [] + +noncomputable def guardedRootContinuation + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) : + Option (ResolvedRunResult (Digest × SplitHashCache)) → ProbComp (Option (ResolvedRunResult (α × SplitHashCache))) + | none => pure none + | some result => + runGuardedCanonicalNative parameter result.value.1 ftsSecret (continuation result.value.1) + result.context result.remaining result.table result.value.2 + +noncomputable def guardedRootHistoryContinuation + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) : + Option (HistoryResolvedPrefix (Digest × SplitHashCache)) → ProbComp (Option (ResolvedRunResult (α × SplitHashCache))) + | none => pure none + | some entry => + sampledGuardedCanonicalNative parameter entry.value.1 ftsSecret (continuation entry.value.1) + entry.context entry.remaining entry.history entry.value.2 + +theorem canonicalHistoryBoundary_of_mem_root + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) (fuel : Nat) + (result : ResolvedRunResult (Digest × SplitHashCache)) + (hresult : some result ∈ support (runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) : + canonicalHistoryBoundary (some result) = some result := by + have hcore := resolvedCore_of_mem_runResolved_maskedPublishedTreeRoot parameter table fuel result hresult + have hcanonical := canonicalMaterializedValues_of_mem_maskedPublishedTreeRoot parameter table fuel result hresult + have hcomplete := deferredCompletable_of_mem_resolved_maskedPublishedTreeRoot parameter table fuel result hresult + have hpublished := resolvedPreservesPublished_maskedPublishedTreeRoot _ _ _ _ _ publishedValues_empty hresult + have hpublic := materializedStartsPublished_of_canonical table result.context hcanonical + have hsame : canonicalizeMaterializedValues result.table result.context = result.context := by + rw [hcore.1] + exact canonicalizeMaterializedValues_eq_of_canonical table result.context hcanonical + simp [canonicalHistoryBoundary, hcomplete, hpublic, hpublished, hsame] + +theorem evalDist_guardedAfterRoot_eq_boundary_continuation + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) : + evalDist (guardedCanonicalAfterRoot parameter table ftsSecret fuel continuation) = + evalDist (runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) >>= fun result => + guardedRootContinuation parameter ftsSecret continuation (canonicalHistoryBoundary result)) := by + rw [guardedCanonicalAfterRoot] + apply evalDist_bind_congr + intro option hoption + cases option with + | none => rfl + | some result => + rw [canonicalHistoryBoundary_of_mem_root parameter table fuel result hoption] + simp only [guardedRootContinuation] + rw [(resolvedCore_of_mem_runResolved_maskedPublishedTreeRoot parameter table fuel result hoption).1] + +theorem complete_rootHistory_guardedContinuation + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) + (option : Option (HistoryResolvedPrefix (Digest × SplitHashCache))) : + (completeHistoryResolvedPrefix option >>= guardedRootContinuation parameter ftsSecret continuation) = + guardedRootHistoryContinuation parameter ftsSecret continuation option := by + cases option with + | none => simp [completeHistoryResolvedPrefix, guardedRootContinuation, guardedRootHistoryContinuation] + | some entry => + simp only [completeHistoryResolvedPrefix, completeResolvedHistory, guardedRootHistoryContinuation, + sampledGuardedCanonicalNative, bind_assoc] + apply bind_congr + intro base + split_ifs <;> simp only [pure_bind, guardedRootContinuation] + +theorem evalDist_sampledGuardedAfterRoot_eq_historyPrefix + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) : + evalDist (sampleOtsHashTable >>= fun table => guardedCanonicalAfterRoot parameter table ftsSecret fuel continuation) = + evalDist (canonicalRootHistoryPrefix fuel >>= guardedRootHistoryContinuation parameter ftsSecret continuation) := by + have htable : ∀ base, completedStartTable LazyRevealProbe.State.empty base = base := by + intro base + funext index + rfl + have hsample := evalDist_sampledHistoryFilteredRun_canonicalBoundary + (maskedPublishedTreeRoot.run emptySplitHashCache) + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } fuel 0 [] + DeferredContext.valid_empty.valuesConsistent pendingCoveredBy_empty + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) (by simp) + have hfirst : evalDist (sampleOtsHashTable >>= fun table => guardedCanonicalAfterRoot parameter table ftsSecret fuel continuation) = + evalDist ((sampledHistoryFilteredRun (maskedPublishedTreeRoot.run emptySplitHashCache) + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } fuel [] >>= fun result => + pure (canonicalHistoryBoundary result)) >>= guardedRootContinuation parameter ftsSecret continuation) := by + simp only [sampledHistoryFilteredRun, bind_assoc, pure_bind, ChainStartHistoryHit, List.not_mem_nil, + false_and, exists_false, if_false, htable] + apply evalDist_bind_congr + intro table _ + exact evalDist_guardedAfterRoot_eq_boundary_continuation parameter table ftsSecret fuel continuation + rw [hfirst, evalDist_bind, hsample, ← evalDist_bind] + simp only [canonicalRootHistoryPrefix, runCanonicalHistoryBlockPrefix, bind_assoc, pure_bind] + apply evalDist_bind_congr + intro option _ + exact congrArg evalDist (complete_rootHistory_guardedContinuation parameter ftsSecret continuation (canonicalHistoryPrefix option)) + +theorem canonicalRootHistoryPrefix_invariant (fuel : Nat) (entry : HistoryResolvedPrefix (Digest × SplitHashCache)) + (hentry : some entry ∈ support (canonicalRootHistoryPrefix fuel)) : + entry.context.ValuesConsistent ∧ PendingCoveredBy entry.history entry.context ∧ PublishedValues entry.context.state ∧ + (∀ base, CanonicalMaterializedValues (completedStartTable entry.context.state base) entry.context) ∧ entry.history = [] := by + have hinvariant := canonicalHistoryBlockPrefix_invariant (maskedPublishedTreeRoot.run emptySplitHashCache) + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } fuel 0 [] entry + DeferredContext.valid_empty.valuesConsistent pendingCoveredBy_empty (maskedPublishedTreeRoot_probeFree emptySplitHashCache) hentry + exact ⟨hinvariant.1, hinvariant.2.1, hinvariant.2.2.1, hinvariant.2.2.2, + canonicalHistoryBlockPrefix_history_of_probeFree _ _ fuel [] entry (maskedPublishedTreeRoot_probeFree emptySplitHashCache) hentry⟩ + +theorem probEvent_sampledGuardedAfterRoot_unresolvedStart_le + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel bound : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) + (candidate : DeferredContext → (α × SplitHashCache) → Option Probe) + (hbound : ∀ root, (continuation root).IsQueryBoundP IsOuterHash bound) (hbudget : bound ≤ 2 ^ 126) : + Pr[LiveUnresolvedStartHit candidate | sampleOtsHashTable >>= fun table => + guardedCanonicalAfterRoot parameter table ftsSecret fuel continuation] ≤ + (∑' result, Pr[= result | sampleOtsHashTable >>= fun table => + guardedCanonicalAfterRoot parameter table ftsSecret fuel continuation] * historyUnresolvedStartCharge candidate result) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + have hdist := evalDist_sampledGuardedAfterRoot_eq_historyPrefix parameter ftsSecret fuel continuation + rw [OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) hdist] + have hcost : (∑' result, Pr[= result | sampleOtsHashTable >>= fun table => + guardedCanonicalAfterRoot parameter table ftsSecret fuel continuation] * historyUnresolvedStartCharge candidate result) = + ∑' result, Pr[= result | canonicalRootHistoryPrefix fuel >>= + guardedRootHistoryContinuation parameter ftsSecret continuation] * historyUnresolvedStartCharge candidate result := by + apply tsum_congr + intro result + rw [_root_.OracleComp.probOutput_congr rfl hdist] + rw [hcost, probEvent_bind_eq_tsum, tsum_probOutput_bind_mul, ← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro option + by_cases hsupport : option ∈ support (canonicalRootHistoryPrefix fuel) + · cases option with + | none => simp [guardedRootHistoryContinuation, LiveUnresolvedStartHit, historyUnresolvedStartCharge] + | some entry => + have hinv := canonicalRootHistoryPrefix_invariant fuel entry hsupport + have hlocal := probEvent_guardedCanonical_unresolvedStart_le parameter entry.value.1 ftsSecret + (continuation entry.value.1) entry.context entry.remaining bound entry.history entry.value.2 candidate + hinv.1 hinv.2.1 hinv.2.2.1 (hbound _) (by simpa only [hinv.2.2.2.2, List.length_nil, Nat.zero_add] using hbudget) + simpa only [guardedRootHistoryContinuation, mul_assoc] using mul_le_mul' le_rfl hlocal + · simp [probOutput_eq_zero_of_not_mem_support hsupport] + +noncomputable def sampledCanonicalAfterRootTrace + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) : + ProbComp (Option (ResolvedRunResult (α × SplitHashCache)) × Bool) := do + let table ← sampleOtsHashTable + canonicalStartErasureAfterRoot parameter table ftsSecret fuel continuation + +theorem evalDist_eraseFlagged_sampledAfterRoot_eq_guarded + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) : + evalDist (eraseFlaggedResult <$> sampledCanonicalAfterRootTrace parameter ftsSecret fuel continuation) = + evalDist (sampleOtsHashTable >>= fun table => guardedCanonicalAfterRoot parameter table ftsSecret fuel continuation) := by + simp only [sampledCanonicalAfterRootTrace, map_bind] + apply evalDist_bind_congr + intro table _ + exact evalDist_eraseFlagged_afterRoot_eq_guarded parameter table ftsSecret fuel continuation + +theorem probEvent_sampledAfterRoot_erasure_le_inv216 + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) : + Pr[fun result => result.2 = true | sampledCanonicalAfterRootTrace parameter ftsSecret fuel continuation] ≤ + ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + unfold sampledCanonicalAfterRootTrace + apply probEvent_bind_le_of_forall_le + intro table _ + exact probEvent_canonicalStartErasureAfterRoot_le_inv216 parameter table ftsSecret fuel continuation + +theorem probEvent_sampledCanonicalAfterRoot_unresolvedStart_le + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel bound : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) + (candidate : DeferredContext → (α × SplitHashCache) → Option Probe) + (hbound : ∀ root, (continuation root).IsQueryBoundP IsOuterHash bound) (hbudget : bound ≤ 2 ^ 126) : + Pr[LiveUnresolvedStartHit candidate | Prod.fst <$> sampledCanonicalAfterRootTrace parameter ftsSecret fuel continuation] ≤ + (∑' result, Pr[= result | Prod.fst <$> sampledCanonicalAfterRootTrace parameter ftsSecret fuel continuation] * + historyUnresolvedStartCharge candidate result) * ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + + ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + have hdist := evalDist_eraseFlagged_sampledAfterRoot_eq_guarded parameter ftsSecret fuel continuation + have hcomparison := probEvent_fst_le_erased_add_flag + (sampledCanonicalAfterRootTrace parameter ftsSecret fuel continuation) (LiveUnresolvedStartHit candidate) + rw [OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) hdist] at hcomparison + have hcost := expected_erased_le_fst (sampledCanonicalAfterRootTrace parameter ftsSecret fuel continuation) + (historyUnresolvedStartCharge candidate) rfl + have hcostEq : + (∑' result, Pr[= result | eraseFlaggedResult <$> sampledCanonicalAfterRootTrace parameter ftsSecret fuel continuation] * + historyUnresolvedStartCharge candidate result) = + ∑' result, Pr[= result | sampleOtsHashTable >>= fun table => guardedCanonicalAfterRoot parameter table ftsSecret fuel continuation] * + historyUnresolvedStartCharge candidate result := by + apply tsum_congr + intro result + rw [_root_.OracleComp.probOutput_congr rfl hdist] + rw [hcostEq] at hcost + exact hcomparison.trans (add_le_add + ((probEvent_sampledGuardedAfterRoot_unresolvedStart_le parameter ftsSecret fuel bound continuation candidate hbound hbudget).trans + (mul_le_mul' hcost le_rfl)) + (probEvent_sampledAfterRoot_erasure_le_inv216 parameter ftsSecret fuel continuation)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedChargedRootGlobalRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedChargedRootGlobalRisk.lean new file mode 100644 index 00000000..181971a1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedChargedRootGlobalRisk.lean @@ -0,0 +1,62 @@ +import SphincsSecurity.Proof.OtsProbeChargedRootGlobalRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +noncomputable def initializedChargedRootChargeAfterTable + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : ENNReal := + ∑' result, Pr[= result | runResolvedFromTable (ensuredInitialContext targets) fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)] * + match result with + | none => 0 + | some result => expectedLiveNativeContextCharge + (maskedChronologicalExpandedAdversaryImpl parameter result.value.1 ftsSecret) (chargedRootOuterCharge parameter) + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining table result.value.2 + +theorem sum_roots_initializedChargedRootCut_hits_le_charge + (targets roots : Finset Position) (hsubset : roots ⊆ targets) + (hroot : ∀ target ∈ roots, IsLayerRoot target) + (hne : ∀ target ∈ roots, target ≠ layerRootPosition topLayer rootTree) + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + (∑ target ∈ roots, ∑ ordinal ∈ Finset.range q, + Pr[fun b => b = false | initializedChargedRootCutObservation targets adversary parameter target table ftsSecret fuel ordinal + (fun pair => pair.2 = some (truncateHash pair.1))]) ≤ + initializedChargedRootChargeAfterTable targets adversary parameter table ftsSecret fuel * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + by_cases hempty : roots = ∅ + · simp [hempty] + obtain ⟨selected, hselected⟩ := Finset.nonempty_iff_ne_empty.mpr hempty + unfold initializedChargedRootCutObservation initializedChargedRootChargeAfterTable + simp only [probEvent_bind_eq_tsum] + simp_rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + rw [← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro result + cases result with + | none => simp + | some result => + by_cases hresult : some result ∈ support (runResolvedFromTable (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) + · have hfacts target htarget := initializedNativeRoot_fresh_facts parameter targets target (hsubset htarget) + (hroot target htarget) (hne target htarget) fuel table result hresult + obtain ⟨hvalid, hcomplete, _⟩ := hfacts selected hselected + have hlocal := sum_targets_originalChargedRootCut_hits_le_charge roots parameter result.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) q hq result.context result.remaining table result.value.2 + hvalid hcomplete hroot + (fun target htarget => (hfacts target htarget).2.2.1) + (fun target htarget => (hfacts target htarget).2.2.2.1) + (fun target htarget => (hfacts target htarget).2.2.2.2.1) + (fun target htarget => (hfacts target htarget).2.2.2.2.2.1) + (fun target htarget => (hfacts target htarget).2.2.2.2.2.2) + simpa only [Finset.mul_sum, mul_assoc] using mul_le_mul' + (le_refl (Pr[= some result | runResolvedFromTable (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)])) hlocal + · simp [probOutput_eq_zero_of_not_mem_support hresult] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedChargedRootReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedChargedRootReserve.lean new file mode 100644 index 00000000..cf7fc420 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedChargedRootReserve.lean @@ -0,0 +1,96 @@ +import SphincsSecurity.Proof.OtsProbeInitializedChargedRootGlobalRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +theorem initializedNativeProbe_add_chargedRootCharge_le_gameReserve + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + expectedLiveResolvedQueryCharge nativeProbeQueryCharge (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + (ensuredInitialContext targets) fuel table * (4 / 3 : ENNReal) + + initializedChargedRootChargeAfterTable targets adversary parameter table ftsSecret fuel ≤ + expectedQueryCharge (otsOpeningRefinedQueryReserve + (primitiveAccountingKey parameter (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret)) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) ∅ := by + let otsSecret := fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩) + let accountingKey := primitiveAccountingKey parameter otsSecret ftsSecret + let continuation := fun rootCache : Digest × SplitHashCache => + (simulateQ (maskedChronologicalExpandedAdversaryImpl parameter rootCache.1 ftsSecret) + (retainedGameRestComputation adversary ⟨rootCache.1, parameter⟩)).run rootCache.2 + let rootCharge := fun result : Option (ResolvedRunResult (Digest × SplitHashCache)) => + match result with + | none => 0 + | some result => expectedLiveNativeContextCharge + (maskedChronologicalExpandedAdversaryImpl parameter result.value.1 ftsSecret) (chargedRootOuterCharge parameter) + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) result.context result.remaining table result.value.2 + let actualCost := fun result : Digest × QueryCache HashSpec => + expectedQueryCharge (otsOpeningRefinedQueryReserve accountingKey) + (gameRest scheme adversary ⟨result.1, parameter⟩ ⟨parameter, result.1, otsSecret, ftsSecret⟩) result.2 + have hroot := reachableResolvedCouples_maskedPublishedTreeRoot parameter table (ensuredInitialContext targets) + fuel emptySplitHashCache ∅ (ensuredInitialContext_resolvedInvariant targets parameter table) + (ensuredInitialContext_visible targets parameter table) (ensuredInitialContext_published targets) + have hsupported := FtsProbeSimulation.relTriple_and_left_support hroot + (fun left => ∀ result, left = some result → DeferredComputationsClosed result.context ∧ LayerRootsMaterialized result.context) (by + intro left hleft result heq + subst left + exact ⟨(ensuredInitialContext_computed targets).of_mem_runResolved _ _ fuel table result hleft, + rootMaterializationPreserving_maskedPublishedTreeRoot (ensuredInitialContext targets) fuel table emptySplitHashCache result + (layerRootsMaterialized_ensuredInitialContext targets) (ensuredInitialContext_computed targets) hleft⟩) + have hbound := expected_cost_le_of_relTriple hsupported + (fun left => liveResolvedContinuationCharge nativeProbeQueryCharge continuation left * (4 / 3 : ENNReal) + rootCharge left) + actualCost (fun _ => 0) (by + intro left right hrelation + simp only [add_zero] + cases left with + | none => simp [liveResolvedContinuationCharge, rootCharge] + | some result => + dsimp only [liveResolvedContinuationCharge, rootCharge] + rcases hrelation.1 with hclean | hdoomed + · rw [hclean.1] + have hfacts := hrelation.2 result rfl + have hlocal := chronological_liveProbe_add_chargedRoots_le_refinedReserve parameter result.value.1 table ftsSecret + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) result.context result.remaining result.value.2 right.2 + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 hfacts.1 hfacts.2 + have hreserve : otsOpeningRefinedQueryReserve (⟨parameter, result.value.1, otsSecret, ftsSecret⟩ : SecretKey) = + otsOpeningRefinedQueryReserve accountingKey := otsOpeningRefinedQueryReserve_set_root accountingKey result.value.1 + dsimp only at hlocal + dsimp only [otsSecret] at hreserve + rw [hreserve, expectedQueryCharge_retained_eq_gameRest] at hlocal + simpa only [continuation, actualCost, ← hclean.2.1] using hlocal + · rw [hdoomed.1, expectedLiveResolvedQueryCharge_eq_zero_of_not_completable nativeProbeQueryCharge _ + result.context result.remaining table hdoomed.2.2.2, + expectedLiveNativeContextCharge_eq_zero_of_not_completable _ _ _ _ _ _ _ hdoomed.2.2.2] + simp) + unfold nativeChronologicalRetainedComputation initializedChargedRootChargeAfterTable + rw [expectedLiveResolvedQueryCharge_bind _ _ _ _ fuel table (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table)), + expectedLiveNativeProbeCharge_root_eq_zero, zero_add, ← ENNReal.tsum_mul_right, ← ENNReal.tsum_add] + have hcost : (∑' result, Pr[= result | runResolvedFromTable (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)] * + (liveResolvedContinuationCharge nativeProbeQueryCharge continuation result * (4 / 3 : ENNReal) + rootCharge result)) ≤ + ∑' result, Pr[= result | (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅] * actualCost result := by + simpa only [treeRoot, otsSecret, mul_zero, tsum_zero, add_zero] using hbound + calc + _ = ∑' result, Pr[= result | runResolvedFromTable (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)] * + (liveResolvedContinuationCharge nativeProbeQueryCharge continuation result * (4 / 3 : ENNReal) + rootCharge result) := by + apply tsum_congr + intro result + simp only [continuation, rootCharge, mul_add, mul_assoc] + rfl + _ ≤ ∑' result, Pr[= result | (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅] * actualCost result := hcost + _ ≤ _ := by + change _ ≤ expectedQueryCharge (otsOpeningRefinedQueryReserve accountingKey) (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ + rw [gameAfterSecrets, expectedQueryCharge_bind, simulateQ_romImpl_liftM] + exact le_add_self + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedChargedRootRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedChargedRootRisk.lean new file mode 100644 index 00000000..b1a98e97 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedChargedRootRisk.lean @@ -0,0 +1,61 @@ +import SphincsSecurity.Proof.OtsProbeChargedRootInitialization + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +noncomputable def initializedChargedRootCutObservation + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) (target : Position) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel ordinal : Nat) (event : HashOutput × Option Digest → Prop) : ProbComp Bool := do + let result ← runResolvedFromTable (ensuredInitialContext targets) fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + match result with + | none => pure true + | some result => + originalChargedRootCutObservation parameter result.value.1 target ftsSecret + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining table result.value.2 ∅ ordinal event + +noncomputable def initializedChargedRootCutCandidate + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) (target : Position) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel ordinal : Nat) : ProbComp (Option Digest) := do + let result ← runResolvedFromTable (ensuredInitialContext targets) fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + match result with + | none => pure none + | some result => + (fun trace => chargedNativeRootTraceCutCandidate parameter target trace.1) <$> + runNativeQueryTrace parameter result.value.1 ftsSecret + (outerHashQueryCutAt (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) ordinal) + result.context result.remaining table result.value.2 + +theorem probEvent_initializedChargedRootCut_hit_le_occurrence + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) (target : Position) + (hmem : target ∈ targets) (hroot : IsLayerRoot target) (hne : target ≠ layerRootPosition topLayer rootTree) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel ordinal : Nat) (hbudget : ordinal ≤ 2 ^ 126) : + Pr[fun b => b = false | initializedChargedRootCutObservation targets adversary parameter target table ftsSecret fuel ordinal + (fun pair => pair.2 = some (truncateHash pair.1))] ≤ + Pr[fun candidate => candidate ≠ none | initializedChargedRootCutCandidate targets adversary parameter target table ftsSecret fuel ordinal] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + unfold initializedChargedRootCutObservation initializedChargedRootCutCandidate + rw [probEvent_bind_eq_tsum, probEvent_bind_eq_tsum, ← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro result + rw [mul_assoc] + by_cases hresult : result ∈ support (runResolvedFromTable (ensuredInitialContext targets) fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)) + · apply mul_le_mul' le_rfl + cases result with + | none => simp + | some result => + dsimp only + rw [probEvent_map] + exact probEvent_chargedRootCut_after_keygen_hit_le_trace_occurrence parameter targets target hmem hroot hne ftsSecret + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩) fuel table result hresult ordinal hbudget + · simp [probOutput_eq_zero_of_not_mem_support hresult] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedGameCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedGameCharge.lean new file mode 100644 index 00000000..3dd029ec --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedGameCharge.lean @@ -0,0 +1,186 @@ +import SphincsSecurity.Proof.OtsProbeLiveGameCharge +import SphincsSecurity.Proof.OtsProbeEnsuredInitialization + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +theorem initializedNative_joint_charge_le_gameDirectCharge + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + (expectedLiveResolvedQueryCharge chainStartProbeQueryCharge (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + (ensuredInitialContext targets) fuel table + + expectedLiveResolvedQueryCharge structuralProbeQueryCharge (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + (ensuredInitialContext targets) fuel table) * (4 / 3 : ENNReal) ≤ + expectedQueryCharge (directOtsQueryCharge parameter) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) ∅ := by + let otsSecret := fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩) + let actualCost := fun result : Digest × QueryCache HashSpec => + expectedQueryCharge (directOtsQueryCharge parameter) + (gameRest scheme adversary ⟨result.1, parameter⟩ ⟨parameter, result.1, otsSecret, ftsSecret⟩) result.2 + have hroot := reachableResolvedCouples_maskedPublishedTreeRoot parameter table (ensuredInitialContext targets) + fuel emptySplitHashCache ∅ (ensuredInitialContext_resolvedInvariant targets parameter table) + (ensuredInitialContext_visible targets parameter table) (ensuredInitialContext_published targets) + have hbound := expected_cost_le_of_relTriple hroot + (fun left => liveResolvedContinuationCharge nativeProbeQueryCharge + (fun rootCache : Digest × SplitHashCache => + (simulateQ (maskedChronologicalExpandedAdversaryImpl parameter rootCache.1 ftsSecret) + (retainedGameRestComputation adversary ⟨rootCache.1, parameter⟩)).run rootCache.2) left * (4 / 3 : ENNReal)) + actualCost (fun _ => 0) (by + intro left right hrelation + simp only [add_zero] + cases left with + | none => simp [liveResolvedContinuationCharge] + | some result => + dsimp only [liveResolvedContinuationCharge] + rcases hrelation with hclean | hdoomed + · rw [hclean.1] + have hinvariant := hclean.2.2.1 + have hlocal := chronological_liveChainStart_add_structural_le_liveOuterCharge parameter result.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) result.context result.remaining table result.value.2 + hinvariant.2.1.valuesConsistent hinvariant.2.2.1 + rw [expectedLiveChainStart_add_structural_eq_probeCharge] at hlocal + have hactual := expectedLiveChronologicalOtsCount_mul_le_directCharge parameter result.value.1 table ftsSecret + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) result.context result.remaining result.value.2 right.2 + hinvariant hclean.2.2.2.1 hclean.2.2.2.2 + rw [expectedQueryCharge_retained_eq_gameRest] at hactual + have htotal := (mul_le_mul' hlocal (le_refl (4 / 3 : ENNReal))).trans hactual + simpa only [actualCost, ← hclean.2.1] using htotal + · rw [hdoomed.1, expectedLiveResolvedQueryCharge_eq_zero_of_not_completable nativeProbeQueryCharge _ + result.context result.remaining table hdoomed.2.2.2, zero_mul] + exact bot_le) + rw [expectedLiveChainStart_add_structural_eq_probeCharge] + unfold nativeChronologicalRetainedComputation + rw [expectedLiveResolvedQueryCharge_bind _ _ _ _ fuel table (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table)), + expectedLiveNativeProbeCharge_root_eq_zero, zero_add, ← ENNReal.tsum_mul_right] + have hcost : (∑' result, Pr[= result | runResolvedFromTable (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)] * + liveResolvedContinuationCharge nativeProbeQueryCharge + (fun rootCache => (simulateQ (maskedChronologicalExpandedAdversaryImpl parameter rootCache.1 ftsSecret) + (retainedGameRestComputation adversary ⟨rootCache.1, parameter⟩)).run rootCache.2) result * (4 / 3 : ENNReal)) ≤ + ∑' result, Pr[= result | (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅] * actualCost result := by + simpa only [liveResolvedContinuationCharge, treeRoot, otsSecret, mul_zero, tsum_zero, add_zero, mul_assoc] using hbound + apply hcost.trans + change _ ≤ expectedQueryCharge (directOtsQueryCharge parameter) (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ + rw [gameAfterSecrets, expectedQueryCharge_bind, simulateQ_romImpl_liftM] + exact le_add_self + +noncomputable def initializedNativeDirectRisk + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) : ENNReal := + (∑ ordinal ∈ Finset.range q, Pr[LiveUnresolvedStartHit nativeCutCandidate | + sampledEnsuredNativeProbeCut targets (nativeChronologicalRetainedComputation adversary parameter ftsSecret) fuel ordinal]) + + ∑' table, Pr[= table | sampleOtsHashTable] * + ∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table (ensuredInitialContext targets) fuel + (privatePositionProbeCutAt target (nativeChronologicalRetainedComputation adversary parameter ftsSecret) ordinal)] + +theorem initializedNativeDirectRisk_le_gameDirectCharge + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + initializedNativeDirectRisk targets adversary parameter ftsSecret fuel q ≤ + (∑' table, Pr[= table | sampleOtsHashTable] * + expectedQueryCharge (directOtsQueryCharge parameter) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) ∅) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let computation := nativeChronologicalRetainedComputation adversary parameter ftsSecret + have hstart := sum_sampledEnsuredNativeProbeCut_unresolvedStart_le_expectedChainStartCharge targets computation fuel q hq + have hstruct : (∑' table, Pr[= table | sampleOtsHashTable] * + ∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table (ensuredInitialContext targets) fuel (privatePositionProbeCutAt target computation ordinal)]) ≤ + (∑' table, Pr[= table | sampleOtsHashTable] * + expectedLiveResolvedQueryCharge structuralProbeQueryCharge computation (ensuredInitialContext targets) fuel table) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + rw [← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro table + rw [mul_assoc] + exact mul_le_mul' le_rfl (sum_targets_privateHits_ensuredInitial_le_structuralCharge targets computation q fuel table hq) + apply (add_le_add hstart hstruct).trans + rw [← add_mul, ← ENNReal.tsum_add] + simp only [← mul_add] + rw [← mul_assoc] + apply mul_le_mul' _ le_rfl + rw [← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro table + rw [mul_assoc] + exact mul_le_mul' le_rfl (initializedNative_joint_charge_le_gameDirectCharge targets adversary parameter table ftsSecret fuel) + +theorem uniformTable_gameDirectCharge_le_sampledSecrets + (adversary : Adversary) (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + (∑' table, Pr[= table | sampleOtsHashTable] * + expectedQueryCharge (directOtsQueryCharge parameter) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) ∅) ≤ + ∑' otsSecret, Pr[= otsSecret | sampleOtsSecrets] * + expectedQueryCharge (directOtsQueryCharge parameter) (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ := by + have hbound := expected_cost_le_of_relTriple relTriple_uniformOtsHashTable_sampleOtsSecrets + (fun table => expectedQueryCharge (directOtsQueryCharge parameter) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) ∅) + (fun otsSecret => expectedQueryCharge (directOtsQueryCharge parameter) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅) + (fun _ => 0) (by + intro table otsSecret hsecrets + rw [← hsecrets, add_zero] + exact le_rfl) + simpa only [sampleOtsHashTable, mul_zero, tsum_zero, add_zero] using hbound + +noncomputable def sampledInitializedNativeDirectRisk + (targets : Finset Position) (adversary : Adversary) (fuel q : Nat) : ENNReal := + ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * initializedNativeDirectRisk targets adversary parameter ftsSecret fuel q + +theorem sampledInitializedNativeDirectRisk_le_directCharge + (targets : Finset Position) (adversary : Adversary) (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + sampledInitializedNativeDirectRisk targets adversary fuel q ≤ + sampledQueryCharge (fun secretKey => directOtsQueryCharge secretKey.parameter) adversary * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + ((∑' otsSecret, Pr[= otsSecret | sampleOtsSecrets] * + expectedQueryCharge (directOtsQueryCharge parameter) (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply ENNReal.tsum_le_tsum + intro parameter + apply mul_le_mul' le_rfl + apply ENNReal.tsum_le_tsum + intro ftsSecret + apply mul_le_mul' le_rfl + exact (initializedNativeDirectRisk_le_gameDirectCharge targets adversary parameter ftsSecret fuel q hq).trans + (mul_le_mul' (uniformTable_gameDirectCharge_le_sampledSecrets adversary parameter ftsSecret) le_rfl) + _ = _ := by + unfold sampledQueryCharge + simp only [sampleSecrets, tsum_probOutput_bind_mul, tsum_probOutput_pure_mul, primitiveAccountingKey] + simp only [← ENNReal.tsum_mul_left, ← ENNReal.tsum_mul_right, mul_assoc] + apply tsum_congr + intro parameter + rw [ENNReal.tsum_comm] + apply tsum_congr + intro otsSecret + apply tsum_congr + intro ftsSecret + ring + +theorem sampledInitializedNativeDirectRisk_add_remaining_le_refinedReserve + (targets : Finset Position) (adversary : Adversary) (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + sampledInitializedNativeDirectRisk targets adversary fuel q + + sampledQueryCharge remainingOtsQueryReserve adversary * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ ≤ + sampledQueryCharge otsOpeningRefinedQueryReserve adversary * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply (add_le_add (sampledInitializedNativeDirectRisk_le_directCharge targets adversary fuel q hq) le_rfl).trans_eq + rw [← add_mul, sampled_direct_add_remaining_otsQueryReserve] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedJointRootRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedJointRootRisk.lean new file mode 100644 index 00000000..35aae72d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedJointRootRisk.lean @@ -0,0 +1,82 @@ +import SphincsSecurity.Proof.OtsProbeInitializedChargedRootReserve + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem initializedNativeDirectRisk_le_nativeProbeCharge + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + initializedNativeDirectRisk targets adversary parameter ftsSecret fuel q ≤ + (∑' table, Pr[= table | sampleOtsHashTable] * + expectedLiveResolvedQueryCharge nativeProbeQueryCharge (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + (ensuredInitialContext targets) fuel table) * ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + let computation := nativeChronologicalRetainedComputation adversary parameter ftsSecret + have hstart := sum_sampledEnsuredNativeProbeCut_unresolvedStart_le_expectedChainStartCharge targets computation fuel q hq + have hstruct : (∑' table, Pr[= table | sampleOtsHashTable] * + ∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table (ensuredInitialContext targets) fuel (privatePositionProbeCutAt target computation ordinal)]) ≤ + (∑' table, Pr[= table | sampleOtsHashTable] * + expectedLiveResolvedQueryCharge structuralProbeQueryCharge computation (ensuredInitialContext targets) fuel table) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + rw [← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro table + rw [mul_assoc] + exact mul_le_mul' le_rfl (sum_targets_privateHits_ensuredInitial_le_structuralCharge targets computation q fuel table hq) + apply (add_le_add hstart hstruct).trans_eq + rw [← add_mul, ← ENNReal.tsum_add] + simp only [← mul_add, expectedLiveChainStart_add_structural_eq_probeCharge] + rfl + +noncomputable def initializedChargedRootRisk + (targets roots : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) : ENNReal := + ∑' table, Pr[= table | sampleOtsHashTable] * + ∑ target ∈ roots, ∑ ordinal ∈ Finset.range q, + Pr[fun b => b = false | initializedChargedRootCutObservation targets adversary parameter target table ftsSecret fuel ordinal + (fun pair => pair.2 = some (truncateHash pair.1))] + +theorem initializedChargedRootRisk_le_charge + (targets roots : Finset Position) (hsubset : roots ⊆ targets) + (hroot : ∀ target ∈ roots, IsLayerRoot target) (hne : ∀ target ∈ roots, target ≠ layerRootPosition topLayer rootTree) + (adversary : Adversary) (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + initializedChargedRootRisk targets roots adversary parameter ftsSecret fuel q ≤ + (∑' table, Pr[= table | sampleOtsHashTable] * initializedChargedRootChargeAfterTable targets adversary parameter table ftsSecret fuel) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + unfold initializedChargedRootRisk + rw [← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro table + rw [mul_assoc] + exact mul_le_mul' le_rfl (sum_roots_initializedChargedRootCut_hits_le_charge targets roots hsubset hroot hne + adversary parameter table ftsSecret fuel q hq) + +theorem initializedNativeDirectRisk_add_chargedRootRisk_le_gameReserve + (targets roots : Finset Position) (hsubset : roots ⊆ targets) + (hroot : ∀ target ∈ roots, IsLayerRoot target) (hne : ∀ target ∈ roots, target ≠ layerRootPosition topLayer rootTree) + (adversary : Adversary) (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + initializedNativeDirectRisk targets adversary parameter ftsSecret fuel q + + initializedChargedRootRisk targets roots adversary parameter ftsSecret fuel q ≤ + (∑' table, Pr[= table | sampleOtsHashTable] * + expectedQueryCharge (otsOpeningRefinedQueryReserve + (primitiveAccountingKey parameter (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret)) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) ∅) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply (add_le_add (initializedNativeDirectRisk_le_nativeProbeCharge targets adversary parameter ftsSecret fuel q hq) + (initializedChargedRootRisk_le_charge targets roots hsubset hroot hne adversary parameter ftsSecret fuel q hq)).trans + rw [← mul_assoc, ← add_mul, ← ENNReal.tsum_mul_right, ← ENNReal.tsum_add] + apply mul_le_mul' _ le_rfl + apply ENNReal.tsum_le_tsum + intro table + rw [mul_assoc, ← mul_add] + exact mul_le_mul' le_rfl (initializedNativeProbe_add_chargedRootCharge_le_gameReserve targets adversary parameter table ftsSecret fuel) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedKnownRootCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedKnownRootCharge.lean new file mode 100644 index 00000000..d6ea10c4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedKnownRootCharge.lean @@ -0,0 +1,136 @@ +import SphincsSecurity.Proof.OtsProbeLiveKnownRootCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +theorem rootEncodingQueryCharge_set_root (secretKey : SecretKey) (root : Digest) : + rootEncodingQueryCharge { secretKey with root := root } = rootEncodingQueryCharge secretKey := rfl + +noncomputable def initializedKnownRootChargeAfterTable + (targets : Finset Position) + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : ℝ≥0∞ := + ∑' result, Pr[= result | runResolvedFromTable + (ensuredInitialContext targets) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)] * + match result with + | none => 0 + | some result => expectedLiveNativeContextCharge + (maskedChronologicalExpandedAdversaryImpl parameter result.value.1 ftsSecret) (knownEncodingRootOuterCharge parameter) + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining table result.value.2 + +set_option maxRecDepth 100000 in +theorem initializedKnownRootChargeAfterTable_le_gameRootCharge + (targets : Finset Position) + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + initializedKnownRootChargeAfterTable targets adversary parameter table ftsSecret fuel ≤ + expectedQueryCharge (rootEncodingQueryCharge + (primitiveAccountingKey parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret)) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) ∅ := by + let otsSecret := fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩) + let accountingKey := primitiveAccountingKey parameter otsSecret ftsSecret + let actualCost := fun result : Digest × QueryCache HashSpec => + expectedQueryCharge (rootEncodingQueryCharge accountingKey) + (gameRest scheme adversary ⟨result.1, parameter⟩ ⟨parameter, result.1, otsSecret, ftsSecret⟩) result.2 + have hroot := reachableResolvedCouples_maskedPublishedTreeRoot parameter table + (ensuredInitialContext targets) + fuel emptySplitHashCache ∅ (ensuredInitialContext_resolvedInvariant targets parameter table) + (ensuredInitialContext_visible targets parameter table) (ensuredInitialContext_published targets) + have hsupported := FtsProbeSimulation.relTriple_and_left_support hroot + (fun left => ∀ result, left = some result → DeferredComputationsClosed result.context) (by + intro left hleft result heq + subst left + exact (ensuredInitialContext_computed targets).of_mem_runResolved _ _ fuel table result hleft) + have hcost : initializedKnownRootChargeAfterTable targets adversary parameter table ftsSecret fuel ≤ + ∑' result, Pr[= result | (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅] * actualCost result := by + have hbound := expected_cost_le_of_relTriple hsupported + (fun left => match left with + | none => 0 + | some result => expectedLiveNativeContextCharge + (maskedChronologicalExpandedAdversaryImpl parameter result.value.1 ftsSecret) (knownEncodingRootOuterCharge parameter) + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining table result.value.2) + actualCost (fun _ => 0) (by + intro left right hrelation + simp only [add_zero] + cases left with + | none => exact bot_le + | some result => + dsimp only + rcases hrelation.1 with hclean | hdoomed + · have hcomputed := hrelation.2 result rfl + have hlocal := expectedLiveKnownRootCharge_le_actualRootCharge parameter result.value.1 table ftsSecret + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining result.value.2 right.2 hclean.2.2.1 + hclean.2.2.2.1 hclean.2.2.2.2 hcomputed + have hreserve : rootEncodingQueryCharge + (⟨parameter, result.value.1, otsSecret, ftsSecret⟩ : SecretKey) = + rootEncodingQueryCharge accountingKey := + rootEncodingQueryCharge_set_root accountingKey result.value.1 + rw [hreserve, expectedQueryCharge_retained_eq_gameRest] at hlocal + simpa only [actualCost, ← hclean.2.1] using hlocal + · rw [expectedLiveNativeContextCharge_eq_zero_of_not_completable + (maskedChronologicalExpandedAdversaryImpl parameter result.value.1 ftsSecret) (knownEncodingRootOuterCharge parameter) + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining table result.value.2 hdoomed.2.2.2] + exact bot_le) + simpa only [initializedKnownRootChargeAfterTable, treeRoot, otsSecret, mul_zero, tsum_zero, add_zero] using hbound + apply hcost.trans + change _ ≤ expectedQueryCharge (rootEncodingQueryCharge accountingKey) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ + rw [gameAfterSecrets, expectedQueryCharge_bind, simulateQ_romImpl_liftM] + exact le_add_self + +noncomputable def sampledInitializedKnownRootCharge + (targets : Finset Position) + (adversary : Adversary) (fuel : Nat) : ENNReal := + ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' table, Pr[= table | sampleOtsHashTable] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + initializedKnownRootChargeAfterTable targets adversary parameter table ftsSecret fuel + +theorem sampledInitializedKnownRootCharge_le_rootCharge + (targets : Finset Position) + (adversary : Adversary) (fuel : Nat) : + sampledInitializedKnownRootCharge targets adversary fuel ≤ sampledQueryCharge rootEncodingQueryCharge adversary := by + unfold sampledInitializedKnownRootCharge sampledQueryCharge + simp only [sampleSecrets, tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + apply ENNReal.tsum_le_tsum + intro parameter + apply mul_le_mul' le_rfl + have hcoupled := expected_cost_le_of_relTriple relTriple_uniformOtsHashTable_sampleOtsSecrets + (fun table => ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + initializedKnownRootChargeAfterTable targets adversary parameter table ftsSecret fuel) + (fun otsSecret => ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + expectedQueryCharge (rootEncodingQueryCharge (primitiveAccountingKey parameter otsSecret ftsSecret)) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅) + (fun _ => 0) (by + intro table otsSecret hsecrets + simp only [add_zero] + rw [← hsecrets] + apply ENNReal.tsum_le_tsum + intro ftsSecret + exact mul_le_mul' le_rfl (initializedKnownRootChargeAfterTable_le_gameRootCharge targets + adversary parameter table ftsSecret fuel)) + simpa only [sampleOtsHashTable, mul_zero, tsum_zero, add_zero] using hcoupled + +theorem sampledInitializedNativeDirectRisk_add_knownRootCharge_le_refinedReserve + (targets : Finset Position) (adversary : Adversary) (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + sampledInitializedNativeDirectRisk targets adversary fuel q + + sampledInitializedKnownRootCharge targets adversary fuel * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ ≤ + sampledQueryCharge otsOpeningRefinedQueryReserve adversary * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply (add_le_add le_rfl (mul_le_mul' + (sampledInitializedKnownRootCharge_le_rootCharge targets adversary fuel) le_rfl)).trans + exact sampledInitializedNativeDirectRisk_add_rootEncodingCharge_le_refinedReserve targets adversary fuel q hq + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedRate.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedRate.lean new file mode 100644 index 00000000..eca6e1d7 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedRate.lean @@ -0,0 +1,151 @@ +import SphincsSecurity.Proof.OtsProbeStartAdaptiveRate +import SphincsSecurity.Proof.OtsProbePrivateWeightedGame + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem probEvent_sampledEnsuredNativeProbeCut_unresolvedStart_le_rate + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (fuel ordinal budget : Nat) (hordinal : ordinal ≤ budget) (hspace : budget < Fintype.card Digest) : + Pr[LiveUnresolvedStartHit nativeCutCandidate | sampledEnsuredNativeProbeCut targets computation fuel ordinal] ≤ + (∑' result, Pr[= result | sampledEnsuredNativeProbeCut targets computation fuel ordinal] * + historyUnresolvedStartCharge nativeCutCandidate (retainCompletableResult result)) * + privateHistoryGuessRate budget := by + have hnative := probEvent_live_unresolvedStart_hit_le_native_charge_rate (nativeProbeCutAt computation ordinal) + (ensuredInitialContext targets) fuel ordinal budget [] nativeCutCandidate (ensuredInitialContext_valid targets).valuesConsistent + (show PendingCoveredBy [] (ensuredInitialContext targets) from pendingCoveredBy_empty) + (nativeProbeCutAt_probeBound computation ordinal) + (by simpa only [List.length_nil, Nat.zero_add] using hordinal) hspace + have htable : ∀ base, completedStartTable (ensuredInitialContext targets).state base = base := by + intro base + funext index + rfl + simpa only [sampledEnsuredNativeProbeCut, sampledHistoryFilteredRun, ChainStartHistoryHit, List.not_mem_nil, + false_and, exists_false, ↓reduceIte, htable] using hnative + +theorem sum_sampledEnsuredNativeProbeCut_unresolvedStart_le_rate + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel q : Nat) + (hq : q < Fintype.card Digest) : + (∑ ordinal ∈ Finset.range q, + Pr[LiveUnresolvedStartHit nativeCutCandidate | sampledEnsuredNativeProbeCut targets computation fuel ordinal]) ≤ + (∑ ordinal ∈ Finset.range q, ∑' result, + Pr[= result | sampledEnsuredNativeProbeCut targets computation fuel ordinal] * + historyUnresolvedStartCharge nativeCutCandidate (retainCompletableResult result)) * + privateHistoryGuessRate q := by + rw [Finset.sum_mul] + apply Finset.sum_le_sum + intro ordinal hmem + exact probEvent_sampledEnsuredNativeProbeCut_unresolvedStart_le_rate targets computation fuel ordinal q + (Nat.le_of_lt (Finset.mem_range.mp hmem)) hq + +theorem sum_sampledEnsuredNativeProbeCut_unresolvedStart_le_expectedChainStartCharge_rate + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel q : Nat) + (hq : q < Fintype.card Digest) : + (∑ ordinal ∈ Finset.range q, + Pr[LiveUnresolvedStartHit nativeCutCandidate | sampledEnsuredNativeProbeCut targets computation fuel ordinal]) ≤ + (∑' table, Pr[= table | sampleOtsHashTable] * + expectedLiveResolvedQueryCharge chainStartProbeQueryCharge computation + (ensuredInitialContext targets) fuel table) * privateHistoryGuessRate q := by + apply (sum_sampledEnsuredNativeProbeCut_unresolvedStart_le_rate targets computation fuel q hq).trans + apply mul_le_mul' _ le_rfl + calc + _ ≤ ∑ ordinal ∈ Finset.range q, ∑' result, + Pr[= result | sampledEnsuredNativeProbeCut targets computation fuel ordinal] * liveNativeCutCharge chainStartProbeQueryCharge result := by + apply Finset.sum_le_sum + intro ordinal _ + exact ENNReal.tsum_le_tsum fun result => mul_le_mul' le_rfl (historyUnresolvedStartCharge_le_liveNativeCutCharge result) + _ = ∑' table, Pr[= table | sampleOtsHashTable] * + ∑ ordinal ∈ Finset.range q, expectedLiveNativeCutCharge chainStartProbeQueryCharge + (nativeProbeCutAt computation ordinal) + (ensuredInitialContext targets) fuel table := by + simp only [sampledEnsuredNativeProbeCut, tsum_probOutput_bind_mul] + rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + simp only [← Finset.mul_sum, expectedLiveNativeCutCharge] + _ ≤ _ := by + apply ENNReal.tsum_le_tsum + intro table + exact mul_le_mul' le_rfl (sum_expectedLiveNativeProbeCutCharge_le_expectedCharge chainStartProbeQueryCharge computation q + (ensuredInitialContext targets) fuel table + (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table))) + +theorem initializedNativeDirectRisk_le_actualOtsCount_rate + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) (hq : q < Fintype.card Digest) : + initializedNativeDirectRisk targets adversary parameter ftsSecret fuel q ≤ + (∑' table, Pr[= table | sampleOtsHashTable] * + expectedQueryCharge (fun _ input => otsHashInputCharge parameter input) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) ∅) * + privateHistoryGuessRate q := by + let computation := nativeChronologicalRetainedComputation adversary parameter ftsSecret + have hstart := sum_sampledEnsuredNativeProbeCut_unresolvedStart_le_expectedChainStartCharge_rate targets computation fuel q hq + have hstruct : (∑' table, Pr[= table | sampleOtsHashTable] * + ∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table (ensuredInitialContext targets) fuel (privatePositionProbeCutAt target computation ordinal)]) ≤ + (∑' table, Pr[= table | sampleOtsHashTable] * + expectedLiveResolvedQueryCharge structuralProbeQueryCharge computation (ensuredInitialContext targets) fuel table) * + privateHistoryGuessRate q := by + rw [← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro table + rw [mul_assoc] + exact mul_le_mul' le_rfl (sum_targets_privateHits_ensuredInitial_le_historyRate targets computation q fuel table hq) + apply (add_le_add hstart hstruct).trans + rw [← add_mul, ← ENNReal.tsum_add] + simp only [← mul_add] + apply mul_le_mul' _ le_rfl + apply ENNReal.tsum_le_tsum + intro table + exact mul_le_mul' le_rfl (initializedNative_joint_probe_count_le_actual_ots_count targets adversary parameter table ftsSecret fuel) + +theorem sampledInitializedNativeDirectRisk_le_actualOtsCount_rate + (targets : Finset Position) (adversary : Adversary) (fuel q : Nat) (hq : q < Fintype.card Digest) : + sampledInitializedNativeDirectRisk targets adversary fuel q ≤ + sampledQueryCharge (fun secretKey _ input => otsHashInputCharge secretKey.parameter input) adversary * + privateHistoryGuessRate q := by + calc + _ ≤ ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + ((∑' otsSecret, Pr[= otsSecret | sampleOtsSecrets] * + expectedQueryCharge (fun _ input => otsHashInputCharge parameter input) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅) * privateHistoryGuessRate q) := by + apply ENNReal.tsum_le_tsum + intro parameter + apply mul_le_mul' le_rfl + apply ENNReal.tsum_le_tsum + intro ftsSecret + apply mul_le_mul' le_rfl + exact (initializedNativeDirectRisk_le_actualOtsCount_rate targets adversary parameter ftsSecret fuel q hq).trans + (mul_le_mul' (uniformTable_actualOtsCount_le_sampledSecrets adversary parameter ftsSecret) le_rfl) + _ = _ := by + unfold sampledQueryCharge + simp only [sampleSecrets, tsum_probOutput_bind_mul, tsum_probOutput_pure_mul, primitiveAccountingKey] + simp only [← ENNReal.tsum_mul_left, ← ENNReal.tsum_mul_right, mul_assoc] + apply tsum_congr + intro parameter + rw [ENNReal.tsum_comm] + apply tsum_congr + intro otsSecret + apply tsum_congr + intro ftsSecret + ring + +theorem sampledInitializedNativeDirectRisk_le_queryBudget_rate + (targets : Finset Position) (adversary : Adversary) (fuel q : Nat) + (hq : HasHashQueryBound scheme adversary q) (hqSpace : q < Fintype.card Digest) : + sampledInitializedNativeDirectRisk targets adversary fuel q ≤ (q : ENNReal) * privateHistoryGuessRate q := by + apply (sampledInitializedNativeDirectRisk_le_actualOtsCount_rate targets adversary fuel q hqSpace).trans + apply mul_le_mul' _ le_rfl + simpa only [one_mul] using sampledQueryCharge_le_const + (fun secretKey _ input => otsHashInputCharge secretKey.parameter input) 1 (by + intro secretKey cache input + unfold otsHashInputCharge + split_ifs <;> simp) adversary q hq + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedRootSelection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedRootSelection.lean new file mode 100644 index 00000000..cbee2179 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeInitializedRootSelection.lean @@ -0,0 +1,151 @@ +import SphincsSecurity.Proof.OtsProbeInitializedKnownRootCharge +import SphincsSecurity.Proof.OtsProbeLiveHashCut + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +noncomputable def initializedRootHashQuerySelectionAfterTable + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel ordinal : Nat) : ProbComp (Option CanonicalQuerySelection) := do + let result ← runResolvedFromTable (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + match result with + | none => pure none + | some result => + liveNativeHashQuerySelection + (maskedChronologicalExpandedAdversaryImpl parameter result.value.1 ftsSecret) + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + ordinal result.context result.remaining table result.value.2 + +noncomputable def nativeChronologicalRootHashCut + (adversary : Adversary) (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (ordinal : Nat) : OracleComp (LazyRevealProbe.World Coordinate) (OuterQueryCut RetainedRestResult × SplitHashCache) := do + let (root, cache) ← maskedPublishedTreeRoot.run emptySplitHashCache + (simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (outerHashQueryCutAt (retainedGameRestComputation adversary ⟨root, parameter⟩) ordinal)).run cache + +theorem nativeChronologicalRootHashCut_probeBound + (adversary : Adversary) (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (ordinal : Nat) : + (nativeChronologicalRootHashCut adversary parameter ftsSecret ordinal).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) ordinal := by + unfold nativeChronologicalRootHashCut + have htail : ∀ rootCache ∈ support (maskedPublishedTreeRoot.run emptySplitHashCache), + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter rootCache.1 ftsSecret) + (outerHashQueryCutAt (retainedGameRestComputation adversary ⟨rootCache.1, parameter⟩) ordinal)).run rootCache.2).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) ordinal := by + intro rootCache _ + exact (outerHashQueryCutAt_hashBound _ ordinal).simulateQ_run_StateT_of_step + (maskedChronologicalExpandedAdversaryImpl_step_isProbeBound parameter rootCache.1 ftsSecret) rootCache.2 + simpa only [Nat.zero_add] using OracleComp.isQueryBoundP_bind + (n := 0) (m := ordinal) (maskedPublishedTreeRoot_probeFree emptySplitHashCache) htail + +theorem evalDist_initializedRootHashQuerySelection_eq_cut + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel ordinal : Nat) : + evalDist (initializedRootHashQuerySelectionAfterTable targets adversary parameter table ftsSecret fuel ordinal) = + evalDist (liveNativeHashCutSelection <$> runResolvedFromTable (ensuredInitialContext targets) fuel table + (nativeChronologicalRootHashCut adversary parameter ftsSecret ordinal)) := by + unfold initializedRootHashQuerySelectionAfterTable nativeChronologicalRootHashCut + rw [runResolvedFromTable_bind, map_bind] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => simp [liveNativeHashCutSelection] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable (maskedPublishedTreeRoot.run emptySplitHashCache) + (ensuredInitialContext targets) fuel table result (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table)) hresult + dsimp only + rw [hcore.1] + exact evalDist_liveNativeHashQuerySelection_eq_cut _ _ ordinal result.context result.remaining table + result.value.2 hcore.2.1 hcore.2.2 + +theorem tsum_initializedRootHashQuerySelection_probability_eq_charge + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + (∑' ordinal, Pr[KnownHiddenEncodingRootSelection parameter | + initializedRootHashQuerySelectionAfterTable targets adversary parameter table ftsSecret fuel ordinal]) * (4 / 3 : ENNReal) = + initializedKnownRootChargeAfterTable targets adversary parameter table ftsSecret fuel := by + unfold initializedRootHashQuerySelectionAfterTable initializedKnownRootChargeAfterTable + simp only [probEvent_bind_eq_tsum] + rw [ENNReal.tsum_comm, ← ENNReal.tsum_mul_right] + apply tsum_congr + intro result + rw [ENNReal.tsum_mul_left, mul_assoc] + congr 1 + cases result with + | none => simp [KnownHiddenEncodingRootSelection] + | some result => exact tsum_knownEncodingRootHashSelection_probability_eq_charge parameter _ _ _ _ _ _ + +noncomputable def sampledInitializedRootHashQuerySelection + (targets : Finset Position) (adversary : Adversary) (fuel ordinal : Nat) : + ProbComp (PublicParameter × Option CanonicalQuerySelection) := do + let parameter ← sampleParameter + let table ← sampleOtsHashTable + let ftsSecret ← sampleFtsSecrets + let selection ← initializedRootHashQuerySelectionAfterTable targets adversary parameter table ftsSecret fuel ordinal + pure (parameter, selection) + +def SampledKnownHiddenEncodingRootSelection (result : PublicParameter × Option CanonicalQuerySelection) : Prop := + KnownHiddenEncodingRootSelection result.1 result.2 + +theorem probEvent_sampledInitializedRootHashQuerySelection_eq + (targets : Finset Position) (adversary : Adversary) (fuel ordinal : Nat) : + Pr[SampledKnownHiddenEncodingRootSelection | sampledInitializedRootHashQuerySelection targets adversary fuel ordinal] = + ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' table, Pr[= table | sampleOtsHashTable] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + Pr[KnownHiddenEncodingRootSelection parameter | + initializedRootHashQuerySelectionAfterTable targets adversary parameter table ftsSecret fuel ordinal] := by + simp only [sampledInitializedRootHashQuerySelection, probEvent_bind_eq_tsum, probEvent_pure, + SampledKnownHiddenEncodingRootSelection] + simp only [probEvent_eq_tsum_ite, mul_ite, mul_one, mul_zero] + +theorem tsum_sampledInitializedRootHashQuerySelection_probability_eq_charge + (targets : Finset Position) (adversary : Adversary) (fuel : Nat) : + (∑' ordinal, Pr[SampledKnownHiddenEncodingRootSelection | + sampledInitializedRootHashQuerySelection targets adversary fuel ordinal]) * (4 / 3 : ENNReal) = + sampledInitializedKnownRootCharge targets adversary fuel := by + simp only [probEvent_sampledInitializedRootHashQuerySelection_eq, sampledInitializedKnownRootCharge] + rw [ENNReal.tsum_comm, ← ENNReal.tsum_mul_right] + apply tsum_congr + intro parameter + rw [ENNReal.tsum_mul_left, mul_assoc] + congr 1 + rw [ENNReal.tsum_comm, ← ENNReal.tsum_mul_right] + apply tsum_congr + intro table + rw [ENNReal.tsum_mul_left, mul_assoc] + congr 1 + rw [ENNReal.tsum_comm, ← ENNReal.tsum_mul_right] + apply tsum_congr + intro ftsSecret + rw [ENNReal.tsum_mul_left, mul_assoc, tsum_initializedRootHashQuerySelection_probability_eq_charge] + +theorem sum_sampledInitializedRootHashQuerySelection_probability_le_charge + (targets : Finset Position) (adversary : Adversary) (fuel q : Nat) : + (∑ ordinal ∈ Finset.range q, Pr[SampledKnownHiddenEncodingRootSelection | + sampledInitializedRootHashQuerySelection targets adversary fuel ordinal]) * (4 / 3 : ENNReal) ≤ + sampledInitializedKnownRootCharge targets adversary fuel := by + rw [← tsum_sampledInitializedRootHashQuerySelection_probability_eq_charge] + exact mul_le_mul' (ENNReal.sum_le_tsum (Finset.range q)) le_rfl + +theorem sampledInitializedNativeDirectRisk_add_rootSelectionBudget_le_refinedReserve + (targets : Finset Position) (adversary : Adversary) (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + sampledInitializedNativeDirectRisk targets adversary fuel q + + (∑ ordinal ∈ Finset.range q, Pr[SampledKnownHiddenEncodingRootSelection | + sampledInitializedRootHashQuerySelection targets adversary fuel ordinal]) * (4 / 3 : ENNReal) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ ≤ + sampledQueryCharge otsOpeningRefinedQueryReserve adversary * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply (add_le_add le_rfl (mul_le_mul' + (sum_sampledInitializedRootHashQuerySelection_probability_le_charge targets adversary fuel q) le_rfl)).trans + exact sampledInitializedNativeDirectRisk_add_knownRootCharge_le_refinedReserve targets adversary fuel q hq + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointBound125.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointBound125.lean new file mode 100644 index 00000000..f42cc1dd --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointBound125.lean @@ -0,0 +1,117 @@ +import SphincsSecurity.Proof.OtsProbeJointClassification + +namespace SphincsSecurity.Concrete.OtsProbeSimulation.Range125 + +open OracleComp OracleSpec ENNReal + +set_option linter.constructorNameAsVariable false + +attribute [local irreducible] maskedPublishedTreeRoot + sampledGranularAllCanonicalBoundaryWitnessSnapshot + sampledGranularAllCanonicalPrivateWitnessSnapshot sampledObservedMaterializedDiagnostic + +set_option maxRecDepth 100000 in +theorem probEvent_jointResidual_eq_snapshot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[JointSnapshotResidual | + sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret fuel] = + Pr[fun output => WitnessFirstUsesSomeDelayedLayerRootSnapshot output ∨ + WitnessFirstUsesSomeNonLayerRoot (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret fuel] := by + calc + _ = Pr[fun output => WitnessFirstUsesSomeDelayedLayerRootSnapshot output ∨ + WitnessFirstUsesSomeNonLayerRoot (erasePrivateWitnessSnapshotOutput output) | + BoundaryWitnessSnapshotOutput.witnessSnapshot <$> + sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret fuel] := by + rw [probEvent_map] + rfl + _ = _ := OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + (evalDist_witnessSnapshot_sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary + parameter ftsSecret fuel) + +set_option maxRecDepth 100000 in +theorem probEvent_jointResidual_le_fifteen_sevenths_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[JointSnapshotResidual | + sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q] ≤ + ((15 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + rw [probEvent_jointResidual_eq_snapshot] + apply (probEvent_or_le _ _ _).trans + calc + _ ≤ ((8 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + (q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + add_le_add + (probEvent_sampledCanonical_delayed_le_eight_sevenths_mul_closed adversary parameter + ftsSecret q hbound hq) + (probEvent_sampledCanonical_nonRoot_le_mul adversary parameter ftsSecret q hbound) + _ = _ := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul, ENNReal.toReal_div, ENNReal.toReal_natCast, + ENNReal.toReal_inv, ENNReal.toReal_ofNat] + ring + +set_option maxRecDepth 100000 in +theorem probEvent_jointBoundary_failed_le_thirty_seven_sevenths_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[fun output => output.outcome.failed = true | + sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q] ≤ + ((37 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + have hfuel : 2 * q < Fintype.card Digest := by + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + norm_num [digestBits] at hq ⊢ + omega + apply (probEvent_sampledJointSnapshot_failed_le_diagnostic_add_residual adversary parameter + ftsSecret q hbound).trans + calc + _ ≤ ((22 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + ((15 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + add_le_add + (probEvent_sampledDiagnostic_bad_le_twenty_two_sevenths_mul adversary parameter + ftsSecret q hfuel hbound hq) + (probEvent_jointResidual_le_fifteen_sevenths_mul adversary parameter ftsSecret q hbound hq) + _ = _ := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul, ENNReal.toReal_div, ENNReal.toReal_natCast, + ENNReal.toReal_inv, ENNReal.toReal_ofNat] + ring + +set_option maxRecDepth 100000 in +theorem probEvent_sampledActualRetained_verifyProbe_le_thirty_seven_sevenths_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + ((37 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + (probEvent_sampledActualRetained_verifyProbe_le_jointBoundaryFailed adversary parameter + ftsSecret q).trans + (probEvent_jointBoundary_failed_le_thirty_seven_sevenths_mul adversary parameter + ftsSecret q hbound hq) + +end SphincsSecurity.Concrete.OtsProbeSimulation.Range125 diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointClassification.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointClassification.lean new file mode 100644 index 00000000..33cd6898 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointClassification.lean @@ -0,0 +1,218 @@ +import SphincsSecurity.Proof.OtsProbeJointTop + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option linter.constructorNameAsVariable false + +attribute [local irreducible] maskedPublishedTreeRoot + sampledGranularAllCanonicalBoundaryWitnessSnapshot + sampledGranularAllCanonicalPrivateWitnessSnapshot sampledObservedMaterializedDiagnostic + +attribute [local irreducible] observedMaterializedRetainedRunFromTable in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem tracked_of_mem_diagnosticFromTable_before + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (outcome : ObservedMaterializedDiagnostic + (RetainedGameResult × SplitHashCache)) + (result : ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) + (houtcome : outcome ∈ support + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table >>= + finishObservedMaterializedDiagnostic table)) + (hbefore : outcome.before = some result) : + CleanProbeObservationsTrackedBy result.observations result.state := by + rw [mem_support_bind_iff] at houtcome + obtain ⟨before?, hbeforeSupport, hfinish⟩ := houtcome + cases before? with + | none => + have houtcomeEq : outcome = ⟨none, none, false⟩ := by + simpa [finishObservedMaterializedDiagnostic] using hfinish + rw [houtcomeEq] at hbefore + simp at hbefore + | some before => + unfold finishObservedMaterializedDiagnostic at hfinish + rw [mem_support_bind_iff] at hfinish + obtain ⟨final?, _hfinal, hreturn⟩ := hfinish + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hbeforeEq : outcome.before = some before := by + simpa using congrArg ObservedMaterializedDiagnostic.before hreturn + have heq : before = result := Option.some.inj (hbeforeEq.symm.trans hbefore) + subst result + simpa only [ObservedMaterializedOutputTracked] using + observedMaterializedOutputTracked_of_mem_retainedRunFromTable adversary parameter + ftsSecret fuel table (some before) hbeforeSupport + +attribute [local irreducible] observedMaterializedRetainedRunFromTable in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem tracked_of_mem_sampledDiagnostic_before + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (outcome : ObservedMaterializedDiagnostic + (RetainedGameResult × SplitHashCache)) + (result : ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) + (houtcome : outcome ∈ support + (sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel)) + (hbefore : outcome.before = some result) : + CleanProbeObservationsTrackedBy result.observations result.state := by + unfold sampledObservedMaterializedDiagnostic at houtcome + change outcome ∈ support (sampleOtsHashTable >>= fun table => + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table >>= + finishObservedMaterializedDiagnostic table) at houtcome + rw [mem_support_bind_iff] at houtcome + obtain ⟨table, _htable, hfixed⟩ := houtcome + exact tracked_of_mem_diagnosticFromTable_before adversary parameter ftsSecret + fuel table outcome result hfixed hbefore + + +set_option maxRecDepth 100000 in +theorem witnessSnapshot_mem_support_of_mem_joint + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (output : BoundaryWitnessSnapshotOutput) + (houtput : output ∈ support + (sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret fuel)) : + output.witnessSnapshot ∈ support + (sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret fuel) := by + apply (mem_support_iff_of_evalDist_eq + (evalDist_witnessSnapshot_sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary + parameter ftsSecret fuel) output.witnessSnapshot).1 + rw [support_map] + exact ⟨output, houtput, rfl⟩ + +set_option maxRecDepth 100000 in +theorem sourceSnapshotStopInvariant_of_mem_joint + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (output : BoundaryWitnessSnapshotOutput) + (houtput : output ∈ support + (sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret fuel)) : + SourceSnapshotStopInvariant output.witnessSnapshot := by + have hsource := witnessSnapshot_mem_support_of_mem_joint adversary parameter ftsSecret fuel + output houtput + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot at hsource + rw [mem_support_bind_iff] at hsource + obtain ⟨table, _, hfixed⟩ := hsource + exact sourceSnapshotStopInvariant_of_mem_granularAllCanonical adversary parameter table + ftsSecret fuel output.witnessSnapshot hfixed + +set_option maxRecDepth 100000 in +theorem relTriple_sampledJointSnapshot_diagnostic + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + RelTriple + (sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q) + (sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)) + (fun source diagnostic => ∃ table, BoundarySnapshotDiagnosticRel table source diagnostic) := by + unfold sampledGranularAllCanonicalBoundaryWitnessSnapshot sampledObservedMaterializedDiagnostic + apply relTriple_bind (relTriple_refl sampleOtsHashTable) + intro leftTable rightTable heq + subst rightTable + apply relTriple_post_mono + (relTriple_granularAllJointSnapshot_diagnostic adversary parameter ftsSecret q leftTable + (hbound leftTable)) + intro source diagnostic hrelation + exact ⟨leftTable, hrelation⟩ + +def JointSnapshotResidual (source : BoundaryWitnessSnapshotOutput) : Prop := + WitnessFirstUsesSomeDelayedLayerRootSnapshot source.witnessSnapshot ∨ + WitnessFirstUsesSomeNonLayerRoot (erasePrivateWitnessSnapshotOutput source.witnessSnapshot) + +set_option maxRecDepth 100000 in +theorem BoundarySnapshotDiagnosticRel.failure_classification + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (source : BoundaryWitnessSnapshotOutput) + (diagnostic : ObservedMaterializedDiagnostic (RetainedGameResult × SplitHashCache)) + (hsource : source ∈ support + (sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q)) + (hdiagnostic : diagnostic ∈ support + (sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q))) + (hrelation : BoundarySnapshotDiagnosticRel table source diagnostic) : + diagnostic.Bad ∨ (source.outcome.failed = true → JointSnapshotResidual source) := by + rcases hrelation with hbad | ⟨⟨result, aligned, hbefore, hprefix, haligned, hstored⟩, hprivate⟩ + · exact Or.inl hbad + · right + intro hfailed + have hcovered := privateWitnessCovered_erase_of_mem_sampledGranularAllCanonical adversary + parameter ftsSecret q source.witnessSnapshot + (witnessSnapshot_mem_support_of_mem_joint adversary parameter ftsSecret q source hsource) + have hwitness : (erasePrivateWitnessSnapshotOutput source.witnessSnapshot).1.isSome = true := + hprivate hfailed + rcases witnessFirstUsesSome_root_or_nonRoot hcovered hwitness with hroot | hnonRoot + · have hvalue : SnapshotObservedPrefixValueRel table source.witnessSnapshot diagnostic.before := + Or.inr ⟨result, aligned, hbefore, hprefix, haligned, hstored⟩ + have hrootRel := hvalue.to_rootRel + (sourceSnapshotStopInvariant_of_mem_joint adversary parameter ftsSecret q source hsource) + (fun before hbefore => tracked_of_mem_sampledDiagnostic_before adversary parameter + ftsSecret (2 * q) diagnostic before hdiagnostic hbefore) + rcases hrootRel with hnone | hdelayed + · rw [hbefore] at hnone + cases hnone + · exact Or.inl (hdelayed hroot) + · exact Or.inr hnonRoot + +set_option maxRecDepth 100000 in +theorem relTriple_sampledJointSnapshot_failure_classification + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + RelTriple + (sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q) + (sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)) + (fun source diagnostic => diagnostic.Bad ∨ + (source.outcome.failed = true → JointSnapshotResidual source)) := by + have hbase := relTriple_sampledJointSnapshot_diagnostic adversary parameter ftsSecret q hbound + have hleft := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun output => output ∈ support + (sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q)) + (fun _ houtput => houtput) + have hboth := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro source diagnostic hfacts + obtain ⟨⟨⟨table, hrelation⟩, hsource⟩, hdiagnostic⟩ := hfacts + exact hrelation.failure_classification adversary parameter ftsSecret q table source diagnostic hsource hdiagnostic + +set_option maxRecDepth 100000 in +theorem probEvent_sampledJointSnapshot_failed_le_diagnostic_add_residual + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + Pr[fun output => output.outcome.failed = true | + sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q] ≤ + Pr[ObservedMaterializedDiagnostic.Bad | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] + + Pr[JointSnapshotResidual | + sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q] := by + apply probEvent_le_failure_add_residual_of_relTriple _ _ + (fun source diagnostic => diagnostic.Bad ∨ + (source.outcome.failed = true → JointSnapshotResidual source)) _ _ _ + (relTriple_sampledJointSnapshot_failure_classification adversary parameter ftsSecret q hbound) + intro source diagnostic hrelation hfailed hnotResidual + rcases hrelation with hbad | hresidual + · exact hbad + · exact (hnotResidual (hresidual hfailed)).elim + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointCostCoupling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointCostCoupling.lean new file mode 100644 index 00000000..9f5a7d0d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointCostCoupling.lean @@ -0,0 +1,162 @@ +import SphincsSecurity.Proof.OtsProbeJointExecutionCharge +import SphincsSecurity.Proof.CoupledQueryCost + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +structure JointChargeStateRel (left right : LazyRevealProbe.State Coordinate) : Prop where + values : left.values = right.values + revealed : left.revealed = right.revealed + pending : right.pending ⊆ left.pending + +namespace JointChargeStateRel + +variable {left right : LazyRevealProbe.State Coordinate} (h : JointChargeStateRel left right) + +include h + +theorem ensure (coordinate : Coordinate) : JointChargeStateRel (left.ensure coordinate) (right.ensure coordinate) := + ⟨h.values, h.revealed, h.pending⟩ + +theorem publish (coordinate : Coordinate) : JointChargeStateRel (left.publish coordinate) (right.publish coordinate) := by + exact ⟨h.values, by simp [LazyRevealProbe.State.publish, h.revealed], h.pending⟩ + +theorem addPending (coordinate : Coordinate) (candidate : Digest) : + JointChargeStateRel (left.addPending coordinate candidate) (right.addPending coordinate candidate) := by + exact ⟨h.values, h.revealed, Finset.insert_subset_insert _ h.pending⟩ + +theorem materialize (coordinate : Coordinate) (output : HashOutput) : + JointChargeStateRel (left.materialize coordinate output) (right.materialize coordinate output) := by + refine ⟨by simp [LazyRevealProbe.State.materialize, h.values], h.revealed, ?_⟩ + intro pair hpair + simp only [LazyRevealProbe.State.materialize, LazyRevealProbe.State.pendingAway, Finset.mem_filter] at hpair ⊢ + exact ⟨h.pending hpair.1, hpair.2⟩ + +theorem candidateCharge_le (candidate : Option Probe) : + unmaterializedCandidateCharge left candidate + materializedCandidateCharge left candidate ≤ + unmaterializedCandidateCharge right candidate + materializedCandidateCharge right candidate := by + cases candidate with + | none => exact le_refl 0 + | some candidate => + rw [candidateCharge_sum_eq, candidateCharge_sum_eq] + by_cases hright : candidate.coordinate ∈ right.revealed ∨ + (candidate.coordinate, candidate.candidate) ∈ right.pending + · have hleft : candidate.coordinate ∈ left.revealed ∨ + (candidate.coordinate, candidate.candidate) ∈ left.pending := by + rcases hright with hrevealed | hpending + · exact Or.inl (h.revealed ▸ hrevealed) + · exact Or.inr (h.pending hpending) + simp [hleft, hright] + · simp only [hright, ↓reduceIte] + split_ifs <;> omega + +end JointChargeStateRel + +def JointChargeOptionRel : Option (CleanRunResult α) → Option (CleanRunResult α) → Prop + | none, none => True + | some left, some right => JointChargeStateRel left.state right.state ∧ + left.remaining = right.remaining ∧ left.value = right.value ∧ left.table = right.table + | _, _ => False + +def JointChargedRunRel (left right : Option (CleanRunResult α) × Nat) : Prop := + left.2 ≤ right.2 ∧ JointChargeOptionRel left.1 right.1 + +theorem relTriple_runPermissiveJointChargedFromTable_of_stateRel + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (left right : LazyRevealProbe.State Coordinate) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hstate : JointChargeStateRel left right) : + RelTriple (runPermissiveJointChargedFromTable left fuel table computation) + (runPermissiveJointChargedFromTable right fuel table computation) JointChargedRunRel := by + induction computation using OracleComp.inductionOn generalizing left right fuel with + | pure value => + simp only [runPermissiveJointChargedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨le_refl 0, hstate, rfl, rfl, rfl⟩ + | query_bind input next ih => + rw [runPermissiveJointChargedFromTable, OracleComp.construct_query_bind, + runPermissiveJointChargedFromTable, OracleComp.construct_query_bind] + cases input with + | uniform n => + apply relTriple_bind (relTriple_refl (liftM (unifSpec.query n))) + intro output other heq + subst other + exact ih output left right fuel hstate + | hashOutput => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro output other heq + subst other + exact ih output left right fuel hstate + | ensure coordinate => exact ih () _ _ fuel (hstate.ensure coordinate) + | publish coordinate => exact ih () _ _ fuel (hstate.publish coordinate) + | peek coordinate => + have hvalue := congrFun hstate.values coordinate + simp only + rw [hvalue] + exact ih _ left right fuel hstate + | probe coordinate candidate => + cases fuel with + | zero => exact relTriple_pure_pure ⟨le_refl 0, trivial⟩ + | succ remaining => + have hrevealed : coordinate ∈ left.revealed ↔ coordinate ∈ right.revealed := by rw [hstate.revealed] + by_cases hleft : coordinate ∈ left.revealed + · have hright := hrevealed.mp hleft + simp only [hleft, hright, ↓reduceIte] + exact ih () left right remaining hstate + · have hright : coordinate ∉ right.revealed := fun hright => hleft (hrevealed.mpr hright) + simp only [hleft, hright, ↓reduceIte] + apply relTriple_map + apply relTriple_post_mono (ih () _ _ remaining (hstate.addPending coordinate candidate)) + intro leftResult rightResult hresult + exact ⟨Nat.add_le_add hresult.1 (hstate.candidateCharge_le (some ⟨coordinate, candidate⟩)), hresult.2⟩ + | reveal coordinate => + have hvalue := congrFun hstate.values coordinate + cases hleft : left.values coordinate with + | some output => + have hright : right.values coordinate = some output := hvalue.symm.trans hleft + simp only [hleft, hright] + exact ih output left right fuel hstate + | none => + have hright : right.values coordinate = none := hvalue.symm.trans hleft + simp only [hleft, hright] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact ih _ _ _ fuel (hstate.materialize (.chainStart lay tree leafIdx chainIdx) (table ⟨lay, tree, leafIdx, chainIdx⟩)) + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro output other heq + subst other + exact ih output _ _ fuel (hstate.materialize (.position position) output) + +theorem runPermissiveJointChargedFromTable_expectedCost_le_of_stateRel + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (left right : LazyRevealProbe.State Coordinate) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hstate : JointChargeStateRel left right) : + (∑' result, Pr[= result | runPermissiveJointChargedFromTable left fuel table computation] * + (result.2 : ℝ≥0∞)) ≤ + ∑' result, Pr[= result | runPermissiveJointChargedFromTable right fuel table computation] * + (result.2 : ℝ≥0∞) := by + simpa using SphincsSecurity.expected_cost_le_of_relTriple + (relTriple_runPermissiveJointChargedFromTable_of_stateRel computation left right fuel table hstate) + (fun result => (result.2 : ℝ≥0∞)) (fun result => (result.2 : ℝ≥0∞)) (fun _ => 0) + (fun _ _ hresult => by simpa using (Nat.cast_le.mpr hresult.1 : (_ : ℝ≥0∞) ≤ _)) + +theorem jointChargeStateRel_preload_materialize + (target : Position) (output : HashOutput) (state : LazyRevealProbe.State Coordinate) : + JointChargeStateRel (preloadPositionValue target output state) + (state.materialize (.position target) output) := by + refine ⟨rfl, rfl, ?_⟩ + exact Finset.filter_subset _ _ + +theorem runPermissiveJointChargedFromTable_preload_expectedCost_le_materialize + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (target : Position) (output : HashOutput) (state : LazyRevealProbe.State Coordinate) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + (∑' result, Pr[= result | runPermissiveJointChargedFromTable + (preloadPositionValue target output state) fuel table computation] * (result.2 : ℝ≥0∞)) ≤ + ∑' result, Pr[= result | runPermissiveJointChargedFromTable + (state.materialize (.position target) output) fuel table computation] * (result.2 : ℝ≥0∞) := + runPermissiveJointChargedFromTable_expectedCost_le_of_stateRel computation _ _ fuel table + (jointChargeStateRel_preload_materialize target output state) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointDiagnostic.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointDiagnostic.lean new file mode 100644 index 00000000..85e4675a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointDiagnostic.lean @@ -0,0 +1,150 @@ +import SphincsSecurity.Proof.OtsProbeCouplingObservation + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option linter.constructorNameAsVariable false + +/-- A successful comparison preserves the witness chronology and rules out ordinary source failure. -/ +def BoundarySnapshotDiagnosticRel + (table : OtsSecretIndex → HashOutput) + (source : BoundaryWitnessSnapshotOutput) + (diagnostic : ObservedMaterializedDiagnostic α) : Prop := + diagnostic.Bad ∨ + (∃ result aligned, diagnostic.before = some result ∧ + aligned <+: result.observations ∧ + SnapshotsObservedAt table source.witnessSnapshot.2 aligned ∧ + (∀ witness, source.witnessSnapshot.1 = some witness → + result.state.values (.position witness.position) = some witness.output)) ∧ + (source.outcome.failed = true → source.witnessSnapshot.1.isSome = true) + +theorem relTriple_any_finishDiagnostic_none + (table : OtsSecretIndex → HashOutput) (source : ProbComp BoundaryWitnessSnapshotOutput) : + RelTriple source + (finishObservedMaterializedDiagnostic table + (none : Option (ObservedCleanRunResult α))) + (BoundarySnapshotDiagnosticRel table) := by + apply relTriple_post_mono + (SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support + (relTriple_true source (finishObservedMaterializedDiagnostic table none))) + intro left right hrelation + have heq : right = ⟨none, none, false⟩ := by + simpa [finishObservedMaterializedDiagnostic] using hrelation.2 + subst right + exact Or.inl (Or.inl rfl) + +theorem relTriple_any_finishDiagnostic_doomed + (table : OtsSecretIndex → HashOutput) (source : ProbComp BoundaryWitnessSnapshotOutput) + (result : ObservedCleanRunResult α) + (hdoomed : ¬DeferredCompletable table (directDeferredContext result.state)) : + RelTriple source (finishObservedMaterializedDiagnostic table (some result)) + (BoundarySnapshotDiagnosticRel table) := by + classical + have hbase := relTriple_true source (finishObservedCleanRunFromTable (some result)) + have hstep := relTriple_bind hbase (fun left final _ => + relTriple_pure_pure (R := BoundarySnapshotDiagnosticRel table) + (a := left) + (b := ⟨some result, final, decide + (¬DeferredCompletable table (directDeferredContext result.state))⟩) + (Or.inl (Or.inr (by simp [hdoomed])))) + simpa [finishObservedMaterializedDiagnostic] using hstep + +theorem relTriple_pure_finishDiagnostic_aligned + (table : OtsSecretIndex → HashOutput) (source : BoundaryWitnessSnapshotOutput) + (result : ObservedCleanRunResult α) (aligned : List CleanProbeObservation) + (hprefix : aligned <+: result.observations) + (haligned : SnapshotsObservedAt table source.witnessSnapshot.2 aligned) + (hstored : ∀ witness, source.witnessSnapshot.1 = some witness → + result.state.values (.position witness.position) = some witness.output) + (hprivate : source.outcome.failed = true → source.witnessSnapshot.1.isSome = true) : + RelTriple (pure source : ProbComp BoundaryWitnessSnapshotOutput) + (finishObservedMaterializedDiagnostic table (some result)) + (BoundarySnapshotDiagnosticRel table) := by + classical + have hbase := relTriple_true (pure source : ProbComp BoundaryWitnessSnapshotOutput) + (finishObservedCleanRunFromTable (some result)) + have hleft := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun output => output = source) (by intro output houtput; simpa using houtput) + have hstep := relTriple_bind hleft (fun left final hleft => by + have heq : left = source := hleft.2 + subst left + apply relTriple_pure_pure (R := BoundarySnapshotDiagnosticRel table) + (a := source) (b := ⟨some result, final, decide + (¬DeferredCompletable table (directDeferredContext result.state))⟩) + exact Or.inr ⟨⟨result, aligned, rfl, hprefix, haligned, hstored⟩, hprivate⟩) + simpa [finishObservedMaterializedDiagnostic] using hstep + +set_option maxRecDepth 100000 in +theorem relTriple_any_observedDiagnostic_of_doomed + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (source : ProbComp BoundaryWitnessSnapshotOutput) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hdoomed : DoomedResolvedContext table (directDeferredContext state)) : + RelTriple source + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache >>= finishObservedMaterializedDiagnostic table) + (BoundarySnapshotDiagnosticRel table) := by + have hbase := relTriple_true source + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache) + have hsupported := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + have hstep := relTriple_bind hsupported (fun left observed hsupport => by + cases observed with + | none => exact relTriple_any_finishDiagnostic_none table (pure left) + | some result => + have hnext := materializedDoomed_of_mem_observedMaterializedBoundary parameter root + ftsSecret computation observations state fuel table cache result hdoomed hsupport.2 + exact relTriple_any_finishDiagnostic_doomed table (pure left) result hnext.2.2.2) + simpa using hstep + +set_option maxRecDepth 100000 in +theorem relTriple_pure_snapshot_observedDiagnostic + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (source : BoundaryWitnessSnapshotOutput) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (haligned : SnapshotsObservedAt table source.witnessSnapshot.2 observations) + (hstable : ((∀ witness, source.witnessSnapshot.1 = some witness → + state.values (.position witness.position) = some witness.output) ∧ + (source.outcome.failed = true → source.witnessSnapshot.1.isSome = true)) ∨ + DoomedResolvedContext table (directDeferredContext state)) : + RelTriple (pure source : ProbComp BoundaryWitnessSnapshotOutput) + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache >>= finishObservedMaterializedDiagnostic table) + (BoundarySnapshotDiagnosticRel table) := by + rcases hstable with ⟨hstored, hprivate⟩ | hdoomed + · have hbase := relTriple_true (pure source : ProbComp BoundaryWitnessSnapshotOutput) + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache) + have hleft := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun output => output = source) (by intro output houtput; simpa using houtput) + have hboth := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + have hstep := relTriple_bind hboth (fun left observed hsupport => by + have heq : left = source := hsupport.1.2 + subst left + cases observed with + | none => exact relTriple_any_finishDiagnostic_none table (pure source) + | some result => + apply relTriple_pure_finishDiagnostic_aligned table source result observations + · exact observations_prefix_of_mem_observedMaterializedBoundary parameter root ftsSecret + computation observations state fuel table cache result hsupport.2 + · exact haligned + · intro witness hwitness + exact valuesLE_of_mem_observedMaterializedBoundary parameter root ftsSecret computation + observations state fuel table cache result hsupport.2 _ witness.output + (hstored witness hwitness) + · exact hprivate) + simpa using hstep + · exact relTriple_any_observedDiagnostic_of_doomed parameter root ftsSecret computation + (pure source) observations state fuel table cache hdoomed + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointDisjointCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointDisjointCharge.lean new file mode 100644 index 00000000..dfb4402e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointDisjointCharge.lean @@ -0,0 +1,181 @@ +import SphincsSecurity.Proof.OtsProbeCombinedCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] sampledGranularAllCanonicalBoundaryWitnessSnapshot + sampledObservedMaterializedDiagnostic granularAllCanonicalBoundaryWitnessSnapshot + observedMaterializedRetainedRunFromTable sampledActualRetainedOtsHashTable + +set_option maxRecDepth 100000 + +theorem probEvent_coupling_fst {α β : Type} (left : ProbComp α) (right : ProbComp β) + (law : SPMF (α × β)) (h : SPMF.IsCoupling law (evalDist left) (evalDist right)) (event : α → Prop) : + Pr[fun pair => event pair.1 | law] = Pr[event | left] := by + calc + _ = Pr[event | Prod.fst <$> law] := (probEvent_map law Prod.fst event).symm + _ = Pr[event | evalDist left] := congrArg (fun distribution : SPMF α => probEvent distribution event) h.map_fst + _ = _ := rfl + +theorem probEvent_coupling_snd {α β : Type} (left : ProbComp α) (right : ProbComp β) + (law : SPMF (α × β)) (h : SPMF.IsCoupling law (evalDist left) (evalDist right)) (event : β → Prop) : + Pr[fun pair => event pair.2 | law] = Pr[event | right] := by + calc + _ = Pr[event | Prod.snd <$> law] := (probEvent_map law Prod.snd event).symm + _ = Pr[event | evalDist right] := congrArg (fun distribution : SPMF β => probEvent distribution event) h.map_snd + _ = _ := rfl + +abbrev BoundaryDiagnosticPair := BoundaryWitnessSnapshotOutput × + ObservedMaterializedDiagnostic (RetainedGameResult × SplitHashCache) + +structure BoundaryDiagnosticCoupling (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) where + law : SPMF BoundaryDiagnosticPair + marginals : SPMF.IsCoupling law + (evalDist (sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q)) + (evalDist (sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q))) + aligned : ∀ (pair : BoundaryDiagnosticPair), pair ∈ support law → ∃ table, + BoundarySnapshotDiagnosticRel table pair.1 pair.2 ∧ + pair.1 ∈ support (granularAllCanonicalBoundaryWitnessSnapshot adversary parameter table ftsSecret q) ∧ + pair.2 ∈ support (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table >>= + finishObservedMaterializedDiagnostic table) + +set_option maxRecDepth 100000 in +noncomputable def boundaryDiagnosticCoupling + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + BoundaryDiagnosticCoupling adversary parameter ftsSecret q := by + have hrel : RelTriple + (sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q) + (sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)) + (fun source diagnostic => ∃ table, BoundarySnapshotDiagnosticRel table source diagnostic ∧ + source ∈ support (granularAllCanonicalBoundaryWitnessSnapshot adversary parameter table ftsSecret q) ∧ + diagnostic ∈ support (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table >>= + finishObservedMaterializedDiagnostic table)) := by + unfold sampledGranularAllCanonicalBoundaryWitnessSnapshot sampledObservedMaterializedDiagnostic + apply relTriple_bind (relTriple_refl sampleOtsHashTable) + intro leftTable rightTable heq + subst rightTable + have hbase := relTriple_granularAllJointSnapshot_diagnostic adversary parameter ftsSecret q leftTable (hbound leftTable) + have hleft := FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (granularAllCanonicalBoundaryWitnessSnapshot adversary parameter leftTable ftsSecret q)) + (fun _ hresult => hresult) + apply relTriple_post_mono (FtsProbeSimulation.relTriple_and_right_support hleft) + intro source diagnostic hfacts + exact ⟨leftTable, hfacts.1.1, hfacts.1.2, hfacts.2⟩ + exact ⟨(relTriple_iff_relWP.1 hrel).choose.val, (relTriple_iff_relWP.1 hrel).choose.property, + (relTriple_iff_relWP.1 hrel).choose_spec⟩ + +namespace BoundaryDiagnosticCoupling + +variable {adversary : Adversary} {parameter : PublicParameter} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} {q : Nat} + (joint : BoundaryDiagnosticCoupling adversary parameter ftsSecret q) + +theorem probEvent_source (event : BoundaryWitnessSnapshotOutput → Prop) : + Pr[fun pair => event pair.1 | joint.law] = + Pr[event | sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q] := by + exact probEvent_coupling_fst _ _ joint.law joint.marginals event + +theorem probEvent_diagnostic (event : ObservedMaterializedDiagnostic (RetainedGameResult × SplitHashCache) → Prop) : + Pr[fun pair => event pair.2 | joint.law] = + Pr[event | sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] := by + exact probEvent_coupling_snd _ _ joint.law joint.marginals event + +theorem source_mem_support (pair : BoundaryDiagnosticPair) (hpair : pair ∈ support joint.law) : + pair.1 ∈ support (sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q) := by + apply (mem_support_iff_evalDist_apply_ne_zero _ _).2 + apply (SPMF.mem_support_iff _ _).1 + rw [← joint.marginals.map_fst] + change pair.1 ∈ support (Prod.fst <$> joint.law) + rw [support_map] + exact ⟨pair, hpair, rfl⟩ + +theorem diagnostic_mem_support (pair : BoundaryDiagnosticPair) (hpair : pair ∈ support joint.law) : + pair.2 ∈ support (sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)) := by + apply (mem_support_iff_evalDist_apply_ne_zero _ _).2 + apply (SPMF.mem_support_iff _ _).1 + rw [← joint.marginals.map_snd] + change pair.2 ∈ support (Prod.snd <$> joint.law) + rw [support_map] + exact ⟨pair, hpair, rfl⟩ + +def OrdinaryFailure (pair : BoundaryDiagnosticPair) : Prop := + pair.1.outcome.failed = true ∧ pair.2.final = none + +def HiddenFailure (pair : BoundaryDiagnosticPair) : Prop := + pair.1.outcome.failed = true ∧ pair.2.SuccessfulDoomed + +def ResidualFailure (pair : BoundaryDiagnosticPair) : Prop := + pair.1.outcome.failed = true ∧ ¬pair.2.Bad + +theorem residualFailure_has_witness (pair : BoundaryDiagnosticPair) + (hpair : pair ∈ support joint.law) (hresidual : ResidualFailure pair) : + JointSnapshotResidual pair.1 := by + obtain ⟨table, hrelation, _, _⟩ := joint.aligned pair hpair + rcases hrelation.failure_classification adversary parameter ftsSecret q table pair.1 pair.2 + (joint.source_mem_support pair hpair) (joint.diagnostic_mem_support pair hpair) with hbad | hwitness + · exact (hresidual.2 hbad).elim + · exact hwitness hresidual.1 + +theorem ordinary_hidden_disjoint (pair : BoundaryDiagnosticPair) : + ¬(OrdinaryFailure pair ∧ HiddenFailure pair) := by + rintro ⟨⟨_, hnone⟩, _, hsome, _⟩ + simp [hnone] at hsome + +theorem ordinary_residual_disjoint (pair : BoundaryDiagnosticPair) : + ¬(OrdinaryFailure pair ∧ ResidualFailure pair) := by + rintro ⟨⟨_, hnone⟩, _, hclean⟩ + exact hclean (Or.inl hnone) + +theorem hidden_residual_disjoint (pair : BoundaryDiagnosticPair) : + ¬(HiddenFailure pair ∧ ResidualFailure pair) := by + rintro ⟨⟨_, _, hdoomed⟩, _, hclean⟩ + exact hclean (Or.inr hdoomed) + +theorem probEvent_failed_eq_disjoint_sum : + Pr[fun source => source.outcome.failed = true | + sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q] = + Pr[OrdinaryFailure | joint.law] + Pr[HiddenFailure | joint.law] + + Pr[ResidualFailure | joint.law] := by + classical + rw [← joint.probEvent_source] + simp only [probEvent_eq_tsum_ite, ← ENNReal.tsum_add] + apply tsum_congr + intro pair + by_cases hfailed : pair.1.outcome.failed = true + · cases hfinal : pair.2.final with + | none => simp [OrdinaryFailure, HiddenFailure, ResidualFailure, + ObservedMaterializedDiagnostic.SuccessfulDoomed, ObservedMaterializedDiagnostic.Bad, hfailed, hfinal] + | some result => + by_cases hdoomed : pair.2.wasDoomed = true <;> + simp [OrdinaryFailure, HiddenFailure, ResidualFailure, + ObservedMaterializedDiagnostic.SuccessfulDoomed, ObservedMaterializedDiagnostic.Bad, hfailed, hfinal, hdoomed] + · simp [OrdinaryFailure, HiddenFailure, ResidualFailure, hfailed] + +theorem probEvent_residualFailure_le : + Pr[ResidualFailure | joint.law] ≤ + Pr[JointSnapshotResidual | + sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q] := by + rw [← joint.probEvent_source] + exact probEvent_mono (joint.residualFailure_has_witness) + +theorem probEvent_verifyProbe_le_disjoint_sum : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + Pr[OrdinaryFailure | joint.law] + Pr[HiddenFailure | joint.law] + + Pr[ResidualFailure | joint.law] := by + rw [← joint.probEvent_failed_eq_disjoint_sum] + exact probEvent_sampledActualRetained_verifyProbe_le_jointBoundaryFailed adversary parameter ftsSecret q + +end BoundaryDiagnosticCoupling + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointExecutionCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointExecutionCharge.lean new file mode 100644 index 00000000..594fde8e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointExecutionCharge.lean @@ -0,0 +1,235 @@ +import SphincsSecurity.Proof.OtsProbePreloadCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +noncomputable def runPermissiveJointChargedFromTable + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + ProbComp (Option (CleanRunResult α) × Nat) := + OracleComp.construct + (C := fun _ => LazyRevealProbe.State Coordinate → Nat → ProbComp (Option (CleanRunResult α) × Nat)) + (fun value state remaining => pure (some ⟨state, remaining, value, table⟩, 0)) + (fun input _ next state fuel => + match input with + | .uniform n => do + let output ← liftM (unifSpec.query n) + next output state fuel + | .hashOutput => do + let output ← LazyRevealProbe.sampleHashOutput + next output state fuel + | .ensure coordinate => next () (state.ensure coordinate) fuel + | .probe coordinate candidate => + match fuel with + | 0 => pure (none, 0) + | remaining + 1 => + if coordinate ∈ state.revealed then next () state remaining + else (fun result => (result.1, result.2 + + (unmaterializedCandidateCharge state (some ⟨coordinate, candidate⟩) + + materializedCandidateCharge state (some ⟨coordinate, candidate⟩)))) <$> + next () (state.addPending coordinate candidate) remaining + | .peek coordinate => next (state.values coordinate) state fuel + | .publish coordinate => next () (state.publish coordinate) fuel + | .reveal coordinate => + match state.values coordinate with + | some output => next output state fuel + | none => + match coordinate with + | .chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + next output (state.materialize coordinate output) fuel + | .position _ => do + let output ← LazyRevealProbe.sampleHashOutput + next output (state.materialize coordinate output) fuel) + computation state fuel + +theorem runPermissiveJointChargedFromTable_project + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + Prod.fst <$> runPermissiveJointChargedFromTable state fuel table computation = + runPermissiveFromTable state fuel table computation := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => simp only [runPermissiveJointChargedFromTable, runPermissiveFromTable, + OracleComp.construct_pure, map_pure] + | query_bind input next ih => + rw [runPermissiveJointChargedFromTable, runPermissiveFromTable, + OracleComp.construct_query_bind, OracleComp.construct_query_bind] + cases input with + | uniform n => + rw [map_bind] + exact bind_congr fun output => ih output state fuel + | hashOutput => + rw [map_bind] + exact bind_congr fun output => ih output state fuel + | ensure coordinate => exact ih () (state.ensure coordinate) fuel + | peek coordinate => exact ih (state.values coordinate) state fuel + | publish coordinate => exact ih () (state.publish coordinate) fuel + | probe coordinate candidate => + cases fuel with + | zero => simp only [map_pure] + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simpa only [runPermissiveJointChargedFromTable, runPermissiveFromTable, hrevealed, ↓reduceIte] using ih () state remaining + · simpa only [runPermissiveJointChargedFromTable, runPermissiveFromTable, hrevealed, ↓reduceIte, Functor.map_map] using + ih () (state.addPending coordinate candidate) remaining + | reveal coordinate => + dsimp only + cases hvalue : state.values coordinate with + | some output => exact ih output state fuel + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => exact ih _ _ fuel + | position position => + rw [map_bind] + exact bind_congr fun output => ih output (state.materialize (.position position) output) fuel + +noncomputable def finishPermissiveJointCharged + (table : OtsSecretIndex → HashOutput) (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) + (result : Option (CleanRunResult α) × Nat) : ProbComp (Option (CleanRunResult β) × Nat) := + match result.1 with + | none => pure (none, result.2) + | some before => (fun after => (after.1, result.2 + after.2)) <$> + runPermissiveJointChargedFromTable before.state before.remaining table (next before.value) + +theorem runPermissiveJointChargedFromTable_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (left : OracleComp (LazyRevealProbe.World Coordinate) α) + (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) : + runPermissiveJointChargedFromTable state fuel table (left >>= next) = + runPermissiveJointChargedFromTable state fuel table left >>= finishPermissiveJointCharged table next := by + induction left using OracleComp.inductionOn generalizing state fuel with + | pure value => + simp [runPermissiveJointChargedFromTable, finishPermissiveJointCharged] + | query_bind input continuation ih => + rw [bind_assoc, runPermissiveJointChargedFromTable, runPermissiveJointChargedFromTable, + OracleComp.construct_query_bind, OracleComp.construct_query_bind] + cases input with + | uniform n => + rw [bind_assoc] + exact bind_congr fun output => ih output state fuel + | hashOutput => + rw [bind_assoc] + exact bind_congr fun output => ih output state fuel + | ensure coordinate => exact ih () (state.ensure coordinate) fuel + | peek coordinate => exact ih (state.values coordinate) state fuel + | publish coordinate => exact ih () (state.publish coordinate) fuel + | probe coordinate candidate => + cases fuel with + | zero => simp [finishPermissiveJointCharged] + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simpa only [runPermissiveJointChargedFromTable, hrevealed, ↓reduceIte] using ih () state remaining + · simp only [hrevealed, ↓reduceIte] + simp only [runPermissiveJointChargedFromTable] at ih + rw [ih () (state.addPending coordinate candidate) remaining, map_bind, bind_map_left] + apply bind_congr + intro result + cases result with + | mk before cost => + cases before with + | none => simp [finishPermissiveJointCharged] + | some before => + simp [finishPermissiveJointCharged, Functor.map_map, Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] + | reveal coordinate => + dsimp only + cases hvalue : state.values coordinate with + | some output => exact ih output state fuel + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => exact ih _ _ fuel + | position position => + rw [bind_assoc] + exact bind_congr fun output => ih output (state.materialize (.position position) output) fuel + +theorem runPermissiveJointChargedFromTable_cost_le_probeBound + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (q : Nat) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe q) : + ∀ result ∈ support (runPermissiveJointChargedFromTable state fuel table computation), result.2 ≤ q := by + induction computation using OracleComp.inductionOn generalizing state fuel q with + | pure value => + intro result hresult + simp only [runPermissiveJointChargedFromTable, OracleComp.construct_pure, + mem_support_pure_iff] at hresult + rw [hresult] + exact Nat.zero_le q + | query_bind input next ih => + intro result hresult + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [runPermissiveJointChargedFromTable, OracleComp.construct_query_bind] at hresult + cases input with + | uniform n => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output state fuel q (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) result hrest + | hashOutput => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output state fuel q (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) result hrest + | ensure coordinate => + exact ih () (state.ensure coordinate) fuel q + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) result hresult + | peek coordinate => + exact ih (state.values coordinate) state fuel q + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 (state.values coordinate)) result hresult + | publish coordinate => + exact ih () (state.publish coordinate) fuel q + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) result hresult + | probe coordinate candidate => + have hpositive : 0 < q := by simpa [LazyRevealProbe.IsProbe] using hbound.1 + have hnext : (next ()).IsQueryBoundP LazyRevealProbe.IsProbe (q - 1) := by + simpa [LazyRevealProbe.IsProbe] using hbound.2 () + cases fuel with + | zero => + simp only [mem_support_pure_iff] at hresult + rw [hresult] + exact Nat.zero_le q + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] at hresult + exact (ih () state remaining (q - 1) hnext result hresult).trans (Nat.sub_le q 1) + · simp only [hrevealed, ↓reduceIte, support_map, Set.mem_image] at hresult + obtain ⟨previous, hprevious, heq⟩ := hresult + rw [← heq] + have htail := ih () (state.addPending coordinate candidate) remaining (q - 1) hnext previous hprevious + have hcharge := candidateCharge_sum_le_one state (some ⟨coordinate, candidate⟩) + dsimp only + omega + | reveal coordinate => + dsimp only at hresult + cases hvalue : state.values coordinate with + | some output => + simp only [hvalue] at hresult + exact ih output state fuel q + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) result hresult + | none => + simp only [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact ih _ _ fuel q (by simpa [LazyRevealProbe.IsProbe] using hbound.2 _) result hresult + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output (state.materialize (.position position) output) fuel q + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) result hrest + +theorem runPermissiveJointChargedFromTable_expectedCost_le_probeBound + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (q : Nat) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe q) : + (∑' result, Pr[= result | runPermissiveJointChargedFromTable state fuel table computation] * + (result.2 : ℝ≥0∞)) ≤ q := by + calc + _ ≤ ∑' result, Pr[= result | runPermissiveJointChargedFromTable state fuel table computation] * (q : ℝ≥0∞) := by + apply ENNReal.tsum_le_tsum + intro result + by_cases hresult : result ∈ support (runPermissiveJointChargedFromTable state fuel table computation) + · exact mul_le_mul' le_rfl (Nat.cast_le.mpr + (runPermissiveJointChargedFromTable_cost_le_probeBound state fuel table computation q hbound result hresult)) + · simp [probOutput_eq_zero_of_not_mem_support hresult] + _ ≤ _ := by + rw [ENNReal.tsum_mul_right] + exact mul_le_of_le_one_left (by positivity) tsum_probOutput_le_one + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointFinalization.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointFinalization.lean new file mode 100644 index 00000000..3ea413ac --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointFinalization.lean @@ -0,0 +1,98 @@ +import SphincsSecurity.Proof.OtsProbeJointDiagnostic + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option linter.constructorNameAsVariable false + +set_option maxRecDepth 100000 in +theorem evalDist_finalIsNone_finishDiagnostic_eq_resolved + (table : OtsSecretIndex → HashOutput) (result : ObservedCleanRunResult α) + (htable : result.table = table) + (hcomplete : DeferredCompletable table (directDeferredContext result.state)) : + evalDist ((fun diagnostic => diagnostic.final.isNone) <$> + finishObservedMaterializedDiagnostic table (some result)) = + evalDist (finishResolvedRunIsNone + (some ⟨directDeferredContext result.state, result.remaining, result.value, table⟩)) := by + rw [evalDist_finishResolvedRunIsNone_eq_finishDirectRunIsNone _ _ _ _ hcomplete] + apply congrArg evalDist + simp only [finishObservedMaterializedDiagnostic, finishObservedCleanRunFromTable, + finishDirectRunIsNone, finishCleanRunIsNone, finishCleanRunFromTable, + projectResolvedRunResult, htable, map_bind, bind_assoc] + apply bind_congr + intro final + cases final <;> rfl + +set_option maxRecDepth 100000 in +theorem relTriple_resolvedFinalization_diagnostic + (table : OtsSecretIndex → HashOutput) (left : DeferredContext) + (leftFuel : Nat) (leftValue : α) (right : ObservedCleanRunResult β) + (htable : right.table = table) + (hcontext : FinalizationContextLE table left (directDeferredContext right.state)) : + RelTriple (resolvedFinalizationObserve table left leftFuel leftValue) + (finishObservedMaterializedDiagnostic table (some right)) + (fun failed diagnostic => failed = true → diagnostic.final = none) := by + have hleft : resolvedFinalizationObserve table left leftFuel leftValue = + resolvedFinalizationObserve table left leftFuel right.value := by + unfold resolvedFinalizationObserve + rw [finishResolvedRunIsNone_some_eq_finalize _ hcontext.leftCompletable, + finishResolvedRunIsNone_some_eq_finalize _ hcontext.leftCompletable] + have hbase := relTriple_finishResolvedRunIsNone_of_finalizationContextLE table left + (directDeferredContext right.state) leftFuel right.remaining right.value right.value hcontext + have hright := evalDist_finalIsNone_finishDiagnostic_eq_resolved table right htable + hcontext.rightCompletable + have hmapped := relTriple_of_evalDist_eq_right hright.symm hbase + have hfull := relTriple_lift_right_observation + (fun diagnostic : ObservedMaterializedDiagnostic β => diagnostic.final.isNone) hmapped + rw [hleft] + apply relTriple_post_mono hfull + intro failed diagnostic himp hfailed + exact Option.isNone_iff_eq_none.1 (himp hfailed) + +set_option maxRecDepth 100000 in +theorem relTriple_retainedFinalization_jointDiagnostic + (table : OtsSecretIndex → HashOutput) (root : Digest) + (left : DeferredContext) (leftFuel : Nat) + (leftValue : RetainedRestResult × SplitHashCache) + (right : ObservedCleanRunResult α) + (snapshots : List PlannedProbeSnapshot) + (haligned : SnapshotsObservedAt table snapshots right.observations) + (htable : right.table = table) + (hcontext : FinalizationContextLE table left (directDeferredContext right.state)) : + RelTriple + (retainedResolvedFinalizationBoundaryWitnessSnapshotObserve table root left leftFuel + leftValue snapshots) + (finishObservedMaterializedDiagnostic table (some right)) + (BoundarySnapshotDiagnosticRel table) := by + classical + have hnotPrivate := not_privateStructuralHit_of_deferredCompletable hcontext.leftCompletable + unfold retainedResolvedFinalizationBoundaryWitnessSnapshotObserve + simp only [hnotPrivate, ↓reduceDIte, hcontext.leftCompletable, ↓reduceIte] + have hbase := relTriple_resolvedFinalization_diagnostic table left leftFuel + ((root, leftValue.1), leftValue.2) right htable hcontext + have hsupported := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + have hstep := relTriple_bind hsupported (fun failed diagnostic hrelation => by + apply relTriple_pure_pure (R := BoundarySnapshotDiagnosticRel table) + (a := ⟨DirectBoundaryOutcome.ofFailed failed, none, snapshots⟩) (b := diagnostic) + by_cases hfailed : failed = true + · exact Or.inl (Or.inl (hrelation.1 hfailed)) + · have hbefore : diagnostic.before = some right := by + have hsupport := hrelation.2 + unfold finishObservedMaterializedDiagnostic at hsupport + rw [mem_support_bind_iff] at hsupport + obtain ⟨final, _, hreturn⟩ := hsupport + have heq : diagnostic = ⟨some right, final, + decide (¬DeferredCompletable table (directDeferredContext right.state))⟩ := by + simpa using hreturn + exact congrArg ObservedMaterializedDiagnostic.before heq + right + refine ⟨⟨right, right.observations, hbefore, List.prefix_rfl, haligned, ?_⟩, ?_⟩ + · intro witness hwitness + simp at hwitness + · intro hsource + cases failed <;> simp [DirectBoundaryOutcome.ofFailed, DirectBoundaryOutcome.failed] at hfailed hsource) + simpa using hstep + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointHiddenFailure.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointHiddenFailure.lean new file mode 100644 index 00000000..d1ed1a73 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointHiddenFailure.lean @@ -0,0 +1,156 @@ +import SphincsSecurity.Proof.OtsProbeJointDisjointCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local irreducible] sampledGranularAllCanonicalBoundaryWitnessSnapshot + sampledGranularAllCanonicalPrivateWitnessSnapshot + sampledObservedMaterializedDiagnostic observedMaterializedRetainedRunFromTable + sampledActualRetainedOtsHashTable + +set_option maxRecDepth 100000 + +theorem existingHiddenHit_of_aligned_privateWitness + {output : PrivateWitnessPlanOutput} {result : ObservedCleanRunResult α} + (witness : PrivateHitWitness) (sourceOrdinal : Fin output.2.length) + (hfirst : firstPrivateWitnessOrdinal? witness output.2 = some sourceOrdinal) + (halign : output.2.IsPrefix (result.observations.map CleanProbeObservation.toProbe)) + (htracked : CleanProbeObservationsTrackedBy result.observations result.state) + (hstored : result.state.values (.position witness.position) = some witness.output) + (hselectedHidden : ∀ (observationOrdinal : Fin result.observations.length), + sourceOrdinal.val = observationOrdinal.val → + (result.observations.get observationOrdinal).revealedAtProbe = false) : + result.HasExistingHiddenHit := by + have hlength : output.2.length ≤ result.observations.length := by simpa using halign.length_le + let observationOrdinal : Fin result.observations.length := + ⟨sourceOrdinal.val, sourceOrdinal.isLt.trans_le hlength⟩ + have hprobe : (result.observations.get observationOrdinal).toProbe = output.2.get sourceOrdinal := by + rw [List.get_eq_getElem, List.get_eq_getElem] + change (result.observations[sourceOrdinal.val]).toProbe = output.2[sourceOrdinal.val] + rw [halign.getElem sourceOrdinal.isLt, List.getElem_map] + have hmatch := privateWitnessAtOrdinal_of_firstPrivateWitnessOrdinal?_eq_some hfirst + have hcoordinate : (result.observations.get observationOrdinal).coordinate = .position witness.position := + (congrArg Probe.coordinate hprobe).trans hmatch.1 + have hcandidate : (result.observations.get observationOrdinal).candidate = truncateHash witness.output := + (congrArg Probe.candidate hprobe).trans hmatch.2.symm + have hhidden := hselectedHidden observationOrdinal rfl + have htrackedAt := htracked (result.observations.get observationOrdinal) (List.get_mem _ _) + cases hvalue : (result.observations.get observationOrdinal).valueAtProbe with + | none => + have hfinal : result.state.values (result.observations.get observationOrdinal).coordinate = some witness.output := by + rw [hcoordinate] + exact hstored + exact False.elim ((CleanProbeObservation.resolvedSafe_of_trackedBy htrackedAt + hvalue hhidden witness.output hfinal) hcandidate.symm) + | some stored => + have hstoredAtFinal := htrackedAt.1 stored hvalue + rw [hcoordinate] at hstoredAtFinal + have heq : stored = witness.output := Option.some.inj (hstoredAtFinal.symm.trans hstored) + subst stored + exact ⟨result.observations.get observationOrdinal, List.get_mem _ _, hhidden, + witness.output, hvalue, hcandidate.symm⟩ + +def ObservedMaterializedDiagnostic.SuccessfulHiddenHit + (outcome : ObservedMaterializedDiagnostic α) : Prop := + outcome.final.isSome = true ∧ outcome.HasExistingHiddenHit + +namespace BoundaryDiagnosticCoupling + +variable {adversary : Adversary} {parameter : PublicParameter} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} {q : Nat} + (joint : BoundaryDiagnosticCoupling adversary parameter ftsSecret q) + +theorem residualFailure_has_existingHiddenHit (pair : BoundaryDiagnosticPair) + (hpair : pair ∈ support joint.law) (hresidual : ResidualFailure pair) : + pair.2.HasExistingHiddenHit := by + obtain ⟨table, hrelation, _, _⟩ := joint.aligned pair hpair + rcases hrelation with hbad | ⟨⟨result, aligned, hbefore, hprefix, haligned, hstored⟩, hprivate⟩ + · exact (hresidual.2 hbad).elim + · have hsource := joint.source_mem_support pair hpair + have hcovered := privateWitnessCovered_erase_of_mem_sampledGranularAllCanonical adversary parameter ftsSecret q + pair.1.witnessSnapshot (witnessSnapshot_mem_support_of_mem_joint adversary parameter ftsSecret q pair.1 hsource) + have hwitnessSome := hprivate hresidual.1 + cases hwitness : pair.1.witnessSnapshot.1 with + | none => simp [hwitness] at hwitnessSome + | some witness => + have hwitness' : (erasePrivateWitnessSnapshotOutput pair.1.witnessSnapshot).1 = some witness := hwitness + obtain ⟨sourceOrdinal, hfirst, _⟩ := firstPrivateWitnessOrdinal?_eq_some_of_candidateListHits witness + (erasePrivateWitnessSnapshotOutput pair.1.witnessSnapshot).2 (hcovered witness hwitness') + let trimmed : ObservedCleanRunResult (RetainedGameResult × SplitHashCache) := + { result with observations := aligned } + have htracked : CleanProbeObservationsTrackedBy trimmed.observations trimmed.state := by + intro observation hobservation + exact tracked_of_mem_sampledDiagnostic_before adversary parameter ftsSecret (2 * q) pair.2 result + (joint.diagnostic_mem_support pair hpair) hbefore observation (hprefix.subset hobservation) + have halign : (erasePrivateWitnessSnapshotOutput pair.1.witnessSnapshot).2.IsPrefix + (trimmed.observations.map CleanProbeObservation.toProbe) := by + change pair.1.witnessSnapshot.2.map PlannedProbeSnapshot.toProbe <+: + aligned.map CleanProbeObservation.toProbe + rw [haligned.map_toProbe_eq] + have hhidden := selectedObservationHidden_of_sourceSnapshotStopInvariant + (sourceSnapshotStopInvariant_of_mem_joint adversary parameter ftsSecret q pair.1 hsource) haligned + have hhit := existingHiddenHit_of_aligned_privateWitness witness sourceOrdinal hfirst halign htracked + (hstored witness hwitness) (fun ordinal heq => hhidden witness sourceOrdinal ordinal hwitness' heq hfirst) + obtain ⟨observation, hobservation, hhit⟩ := hhit + exact ⟨result, hbefore, observation, hprefix.subset hobservation, hhit⟩ + +theorem failed_le_finalNone_or_successfulHiddenHit (hq : q ≤ 2 ^ 126) + (pair : BoundaryDiagnosticPair) (hpair : pair ∈ support joint.law) (hfailed : pair.1.outcome.failed = true) : + pair.2.final = none ∨ pair.2.SuccessfulHiddenHit := by + cases hfinal : pair.2.final with + | none => exact Or.inl rfl + | some result => + right + refine ⟨by simp [hfinal], ?_⟩ + by_cases hdoomed : pair.2.wasDoomed = true + · exact Range125.hasExistingHiddenHit_of_mem_sampledDiagnostic_successfulDoomed adversary parameter ftsSecret q hq + pair.2 (joint.diagnostic_mem_support pair hpair) ⟨by simp [hfinal], hdoomed⟩ + · apply joint.residualFailure_has_existingHiddenHit pair hpair + exact ⟨hfailed, by simp [ObservedMaterializedDiagnostic.Bad, hfinal, hdoomed]⟩ + +include joint in +theorem probEvent_failed_le_finalNone_add_successfulHiddenHit (hq : q ≤ 2 ^ 126) : + Pr[fun source => source.outcome.failed = true | + sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q] ≤ + Pr[fun outcome => outcome.final = none | sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] + + Pr[ObservedMaterializedDiagnostic.SuccessfulHiddenHit | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] := by + rw [← joint.probEvent_source, ← joint.probEvent_diagnostic (fun outcome => outcome.final = none), + ← joint.probEvent_diagnostic ObservedMaterializedDiagnostic.SuccessfulHiddenHit] + exact (probEvent_mono (joint.failed_le_finalNone_or_successfulHiddenHit hq)).trans (probEvent_or_le _ _ _) + +end BoundaryDiagnosticCoupling + +theorem probEvent_sampledActualRetained_verifyProbe_le_charge_add_successfulHiddenHit126 + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + materializedRetainedCharge adversary parameter ftsSecret (2 * q) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + Pr[ObservedMaterializedDiagnostic.SuccessfulHiddenHit | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] := by + let joint := boundaryDiagnosticCoupling adversary parameter ftsSecret q hbound + exact (probEvent_sampledActualRetained_verifyProbe_le_jointBoundaryFailed adversary parameter ftsSecret q).trans + ((joint.probEvent_failed_le_finalNone_add_successfulHiddenHit hq).trans + (add_le_add (probEvent_sampledDiagnostic_final_none_le_charge adversary parameter ftsSecret (2 * q) q hbound (by omega)) le_rfl)) + +theorem probEvent_sampledActualRetained_verifyProbe_le_charge_add_successfulHiddenHit126_of_hashQueryBound + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + materializedRetainedCharge adversary parameter ftsSecret (2 * q) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + Pr[ObservedMaterializedDiagnostic.SuccessfulHiddenHit | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] := + probEvent_sampledActualRetained_verifyProbe_le_charge_add_successfulHiddenHit126 adversary parameter ftsSecret q + (fun table root => isQueryBoundP_expandedRetained_all_tables_roots adversary q hq parameter hparameter table ftsSecret hfts root) hqMax + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointLift.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointLift.lean new file mode 100644 index 00000000..c6419dfd --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointLift.lean @@ -0,0 +1,382 @@ +import SphincsSecurity.Proof.OtsProbeJointStep + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option linter.constructorNameAsVariable false + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_directJointSnapshotBoundary_diagnostic + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) RetainedRestResult) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) (q bound : Nat) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) computation).IsQueryBoundP + (fun query => query matches Sum.inr _) bound) + (hcontext : FinalizationContextLE table left right) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hcanonical : CanonicalMaterializedValues table left) + (haligned : SnapshotsObservedAt table snapshots observations) + (hleftLower : bound ≤ leftFuel) (hleftUpper : leftFuel ≤ q) + (hrightLower : q + bound ≤ rightFuel) : + RelTriple + (directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve parameter root ftsSecret + computation (retainedResolvedFinalizationBoundaryWitnessSnapshotObserve table root) + snapshots left leftFuel table leftCache) + (observedMaterializedBoundary parameter root ftsSecret computation observations right.state + rightFuel table rightCache >>= finishObservedMaterializedDiagnostic table) + (BoundarySnapshotDiagnosticRel table) := by + induction computation using OracleComp.inductionOn generalizing + snapshots observations left right leftFuel rightFuel leftCache rightCache bound with + | pure value => + rw [directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve, + OracleComp.construct_pure, observedMaterializedBoundary, OracleComp.construct_pure] + simp only [pure_bind] + apply relTriple_retainedFinalization_jointDiagnostic table root left leftFuel + (value, leftCache) ⟨right.state, rightFuel, (value, rightCache), table, observations⟩ snapshots + haligned rfl + simpa only [← hrightMaterialized] using hcontext + | query_bind query next ih => + rw [directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve, + OracleComp.construct_query_bind, observedMaterializedBoundary, + OracleComp.construct_query_bind] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + simp only [bind_assoc] + let leftObserve : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → List PlannedProbeSnapshot → + ProbComp BoundaryWitnessSnapshotOutput := + fun nextContext remaining value laterSnapshots => + directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve parameter root + ftsSecret (next value.1) + (retainedResolvedFinalizationBoundaryWitnessSnapshotObserve table root) + laterSnapshots nextContext remaining table value.2 + have hbase := (witnessMaterializedStableCouples_splitUniformImpl table n) + left right leftFuel rightFuel leftCache rightCache hcontext (by omega) hcache + hrevealed hvalues hpublished hrightMaterialized + have hlocal := relTriple_runDirectResolvedWitness_observed_of_probeFree table + ((splitUniformImpl n).run leftCache) ((splitUniformImpl n).run rightCache) + observations left right leftFuel rightFuel + hbase (splitUniformImpl_probeFree n rightCache) hrightMaterialized + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hlocal + (fun result => result ∈ support + (runDirectResolvedWitnessFromTable left leftFuel table + ((splitUniformImpl n).run leftCache))) + (fun result hresult => hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support + hleftSupported + unfold runDirectBoundaryWitnessSnapshotObserve + apply relTriple_bind hbothSupported + intro leftResult rightResult hstep + rcases hstep with ⟨⟨hstep, hleftSupport⟩, hrightSupport⟩ + change RelTriple + (finishDirectBoundaryWitnessSnapshotObserve + (canonicalizeDirectBoundaryWitnessSnapshotObserve table leftObserve) snapshots + leftResult) + ((match rightResult with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state result.remaining + table result.value.2) >>= finishObservedMaterializedDiagnostic table) + (BoundarySnapshotDiagnosticRel table) + have hfinish := relTriple_finishJointWitnessObservedStep (α := Fin (n + 1)) + (β := RetainedRestResult) parameter (fun _ => root) ftsSecret next leftObserve + snapshots observations table leftResult rightResult hstep haligned (by + intro nextLeft nextRight hleftEq hrightEq hclean + rw [hleftEq] at hleftSupport + rw [hrightEq] at hrightSupport + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hleftCompletable : DeferredCompletable table canonical := + hcanonicalRun.context_le.leftCompletable + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hleftFuelPreserved : leftFuel ≤ nextLeft.remaining := by + have := fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table nextLeft 0 + (splitUniformImpl_probeFree n leftCache) hleftSupport + omega + have hrightFuelPreserved : rightFuel ≤ nextRight.remaining := by + have := fuel_le_remaining_add_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run rightCache) observations right.state rightFuel table + (observedResolvedResult observations nextRight) 0 + (splitUniformImpl_probeFree n rightCache) hrightSupport + simpa [observedResolvedResult] using this + have hleftRemainingUpper : nextLeft.remaining ≤ leftFuel := + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table nextLeft + (by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩) + unfold canonicalizeDirectBoundaryWitnessSnapshotObserve + classifyDirectBoundaryWitnessSnapshotObserve + simp only [canonical, hnotPrivate, ↓reduceDIte, hclean.left_published, + ↓reduceIte, hleftCompletable] + rw [← hclean.value_eq] + simpa [leftObserve] using + (ih nextLeft.value.1 snapshots observations canonical nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 bound + (hbound.2 nextLeft.value.1) hcanonicalRun.context_le hcanonicalRun.cache_eq + hcanonicalRun.revealed_eq hcanonicalRun.values_le + hcanonicalRun.left_published hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table nextLeft.context + hclean.context_le.view.leftConsistent) + haligned (by omega) (by omega) (by omega))) + convert hfinish using 1 + cases rightResult <;> simp only [pure_bind] + | inr input => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + simp only [bind_assoc] + have hrightValues : + (materializedCanonicalContext table right.state).state.values = + left.state.values := by + unfold materializedCanonicalContext + rw [← hrightMaterialized] + exact canonicalized_right_values_eq_of_finalizationContextLE hcontext + hrevealed hcanonical + have hplanEq : + purePlanProbingHashQuery parameter input + (materializedCanonicalContext table right.state).state = + purePlanProbingHashQuery parameter input left.state := + purePlanProbingHashQuery_eq_of_values_eq hrightValues parameter input + rw [hplanEq] + rw [← rootAwareCandidateForPlan?_purePlan parameter input left.state] + let plan := purePlanProbingHashQuery parameter input left.state + have hpublicExecutor : + probingHashQueryAfterRootAwarePublicPlan parameter input + (materializedCanonicalContext table right.state).state plan = + probingHashQueryAfterRootAwarePublicPlan parameter input left.state plan := + probingHashQueryAfterRootAwarePublicPlan_eq_of_values_eq parameter input + hrightValues plan + rw [hpublicExecutor] + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextSnapshots := appendPlannedSnapshot snapshots candidate? left + let nextObservations := observationsAfterCandidate observations right.state candidate? + have hcontextDirect : + FinalizationContextLE table left (directDeferredContext right.state) := by + rwa [← hrightMaterialized] + have hnextAligned : SnapshotsObservedAt table nextSnapshots nextObservations := by + exact haligned.appendCandidate candidate? hcontextDirect hrevealed hpublished + hcanonical + have houter : IsOuterHash (.inl (.inr input)) := by simp [IsOuterHash] + have hboundPositive : 0 < bound := by + rcases hbound.1 with hnot | hpositive + · exact (hnot (by simp)).elim + · exact hpositive + have hleftPositive : 0 < leftFuel := by omega + have hstrictFuel : leftFuel < rightFuel := by omega + have hlocal := + relTriple_runDirectResolvedWitness_afterPlan_observedMaterialized table parameter + input left.state plan observations left right leftFuel rightFuel leftCache + rightCache rfl hleftPositive hstrictFuel hcontext hcache hrevealed hvalues + hpublished hrightMaterialized + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hlocal + (fun result => result ∈ support + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache))) + (fun result hresult => hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support + hleftSupported + let leftObserve : DeferredContext → Nat → + (HashOutput × SplitHashCache) → List PlannedProbeSnapshot → + ProbComp BoundaryWitnessSnapshotOutput := + fun nextContext remaining value laterSnapshots => + directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve parameter root + ftsSecret (next value.1) + (retainedResolvedFinalizationBoundaryWitnessSnapshotObserve table root) + laterSnapshots nextContext remaining table value.2 + unfold runDirectBoundaryWitnessSnapshotObserve + apply relTriple_bind hbothSupported + intro leftResult rightResult hstep + rcases hstep with ⟨⟨hstep, hleftSupport⟩, hrightSupport⟩ + have hfinish := relTriple_finishJointWitnessObservedStep (α := HashOutput) + (β := RetainedRestResult) parameter (fun _ => root) ftsSecret next leftObserve + nextSnapshots nextObservations table leftResult rightResult hstep hnextAligned (by + intro nextLeft nextRight hleftEq hrightEq hclean + rw [hleftEq] at hleftSupport + rw [hrightEq] at hrightSupport + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hleftCompletable : DeferredCompletable table canonical := + hcanonicalRun.context_le.leftCompletable + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hleftFuelSpent : leftFuel ≤ nextLeft.remaining + 1 := + fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterPlan parameter input plan).run leftCache) left leftFuel + table nextLeft 1 + (probingHashQueryAfterPlan_isProbeBound_one parameter input plan leftCache) + hleftSupport + have hrightFuelSpent : rightFuel ≤ nextRight.remaining + 1 := by + have := fuel_le_remaining_add_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input left.state plan).run + rightCache) observations right.state rightFuel table + (observedResolvedResult nextObservations nextRight) 1 + (probingHashQueryAfterRootAwarePublicPlan_isProbeBound_one parameter input + left.state plan rightCache) hrightSupport + simpa [observedResolvedResult] using this + have hleftRemainingUpper : nextLeft.remaining ≤ leftFuel := + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((probingHashQueryAfterPlan parameter input plan).run leftCache) left leftFuel + table nextLeft (by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterPlan parameter input plan).run leftCache) left + leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩) + unfold canonicalizeDirectBoundaryWitnessSnapshotObserve + classifyDirectBoundaryWitnessSnapshotObserve + simp only [canonical, hnotPrivate, ↓reduceDIte, hclean.left_published, + ↓reduceIte, hleftCompletable] + rw [← hclean.value_eq] + simpa [leftObserve, IsOuterHash] using + (ih nextLeft.value.1 nextSnapshots nextObservations canonical + nextRight.context nextLeft.remaining nextRight.remaining nextLeft.value.2 + nextRight.value.2 (bound - 1) + (by simpa [IsOuterHash] using hbound.2 nextLeft.value.1) + hcanonicalRun.context_le hcanonicalRun.cache_eq hcanonicalRun.revealed_eq + hcanonicalRun.values_le hcanonicalRun.left_published + hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table nextLeft.context + hclean.context_le.view.leftConsistent) + hnextAligned (by omega) (by omega) (by omega))) + convert hfinish using 1 + · rfl + · cases rightResult <;> rfl + | inr message => + rw [simulateQ_expandedAdversaryImpl_query_bind_inr] at hbound + simp only [bind_assoc] + let leftObserve : DeferredContext → Nat → + (Option Signature × SplitHashCache) → List PlannedProbeSnapshot → + ProbComp BoundaryWitnessSnapshotOutput := + fun nextContext remaining value laterSnapshots => + directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve parameter root + ftsSecret (next value.1) + (retainedResolvedFinalizationBoundaryWitnessSnapshotObserve table root) + laterSnapshots nextContext remaining table value.2 + have hbase := (witnessMaterializedStableCouples_maskedSign table parameter root + ftsSecret message) left right leftFuel rightFuel leftCache rightCache hcontext + (by omega) hcache hrevealed hvalues hpublished hrightMaterialized + have hlocal := relTriple_runDirectResolvedWitness_observed_of_probeFree table + ((maskedSign parameter root ftsSecret message).run leftCache) + ((maskedSign parameter root ftsSecret message).run rightCache) + observations left right leftFuel rightFuel hbase + (maskedSign_probeFree parameter root ftsSecret message rightCache) hrightMaterialized + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hlocal + (fun result => result ∈ support + (runDirectResolvedWitnessFromTable left leftFuel table + ((maskedSign parameter root ftsSecret message).run leftCache))) + (fun result hresult => hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support + hleftSupported + unfold runDirectBoundaryWitnessSnapshotObserve + apply relTriple_bind hbothSupported + intro leftResult rightResult hstep + rcases hstep with ⟨⟨hstep, hleftSupport⟩, hrightSupport⟩ + have hfinish := relTriple_finishJointWitnessObservedStep (α := Option Signature) + (β := RetainedRestResult) parameter (fun _ => root) ftsSecret next leftObserve + snapshots observations table leftResult rightResult hstep haligned (by + intro nextLeft nextRight hleftEq hrightEq hclean + rw [hleftEq] at hleftSupport + rw [hrightEq] at hrightSupport + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hleftCompletable : DeferredCompletable table canonical := + hcanonicalRun.context_le.leftCompletable + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hleftFuelPreserved : leftFuel ≤ nextLeft.remaining := by + have := fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) left leftFuel table + nextLeft 0 (maskedSign_probeFree parameter root ftsSecret message leftCache) + hleftSupport + omega + have hrightFuelPreserved : rightFuel ≤ nextRight.remaining := by + have := fuel_le_remaining_add_of_mem_runObservedCleanFromTable + ((maskedSign parameter root ftsSecret message).run rightCache) observations + right.state rightFuel table (observedResolvedResult observations nextRight) 0 + (maskedSign_probeFree parameter root ftsSecret message rightCache) hrightSupport + simpa [observedResolvedResult] using this + have hleftRemainingUpper : nextLeft.remaining ≤ leftFuel := + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) left leftFuel table + nextLeft (by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) left leftFuel + table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩) + unfold canonicalizeDirectBoundaryWitnessSnapshotObserve + classifyDirectBoundaryWitnessSnapshotObserve + simp only [canonical, hnotPrivate, ↓reduceDIte, hclean.left_published, + ↓reduceIte, hleftCompletable] + rw [← hclean.value_eq] + have hdetailed : DirectDetailedResult.done nextLeft ∈ support + (runDirectResolvedDetailedFromTable left leftFuel table + ((maskedSign parameter root ftsSecret message).run leftCache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩ + have hdirect : some nextLeft ∈ support + (runDirectResolvedFromTable left leftFuel table + ((maskedSign parameter root ftsSecret message).run leftCache)) := + mem_support_runDirectResolvedFromTable_of_done_detailed + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table nextLeft hdetailed + have hraw := raw_done_of_mem_runDirectResolvedFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table nextLeft hdirect + have houtput : nextLeft.value.1 ∈ support + (scheme.sign + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey) message) := by + exact maskedSign_done_output_mem_support parameter root table ftsSecret + message left.state nextLeft.context.state leftCache nextLeft.value.2 + leftFuel nextLeft.remaining nextLeft.value.1 + hclean.context_le.view.leftStarts (by + simpa only [SigningSpec, maskedExpandedAdversaryImpl, + maskedSigningImpl] using hraw) + have htailBound := isQueryBoundP_of_bind hbound nextLeft.value.1 houtput + simpa [leftObserve, IsOuterHash] using + (ih nextLeft.value.1 snapshots observations canonical nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 bound + (htailBound.mono (by omega)) + hcanonicalRun.context_le hcanonicalRun.cache_eq hcanonicalRun.revealed_eq + hcanonicalRun.values_le hcanonicalRun.left_published + hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table nextLeft.context + hclean.context_le.view.leftConsistent) + haligned (by omega) (by omega) (by omega))) + convert hfinish using 1 + · rfl + · cases rightResult <;> rfl + + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointPreloadCoupling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointPreloadCoupling.lean new file mode 100644 index 00000000..16fa0460 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointPreloadCoupling.lean @@ -0,0 +1,251 @@ +import SphincsSecurity.Proof.OtsProbeJointCostCoupling + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +def PreloadedJointChargedRunRel (target : Position) + (left right : Option (CleanRunResult α) × Nat) : Prop := + left.2 ≤ right.2 ∧ PreloadedPermissiveCleanRel target left.1 right.1 + +theorem jointChargedRunRel_to_preloadedJointChargedRunRel + (target : Position) {left right : Option (CleanRunResult α) × Nat} + (hrel : JointChargedRunRel left right) : PreloadedJointChargedRunRel target left right := by + refine ⟨hrel.1, permissiveCleanRel_to_preloadedPermissiveCleanRel target ?_⟩ + obtain ⟨left, leftCost⟩ := left + obtain ⟨right, rightCost⟩ := right + have hoption := hrel.2 + cases left <;> cases right + · trivial + · exact False.elim hoption + · exact False.elim hoption + · exact ⟨⟨hoption.1.values, hoption.1.revealed⟩, hoption.2⟩ + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_sample_preload_runPermissiveJointChargedFromTable + (target : Position) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hvalue : state.values (.position target) = none) + (hnoPeek : computation.IsQueryBoundP (IsTargetPeek target) 0) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveJointChargedFromTable (preloadPositionValue target output state) fuel table computation) + (runPermissiveJointChargedFromTable state fuel table computation) + (PreloadedJointChargedRunRel target) := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + simp only [runPermissiveJointChargedFromTable, OracleComp.construct_pure] + apply relTriple_of_evalDist_eq_right + (OracleComp.DeferredSampling.evalDist_bind_const_neverFails + LazyRevealProbe.sampleHashOutput (by simp [LazyRevealProbe.sampleHashOutput]) _) + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro output other heq + subst other + exact relTriple_pure_pure ⟨le_refl 0, rfl, rfl, rfl, + Or.inr (preloadedPositionStateRel_preload target output state hvalue)⟩ + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hnoPeek + have hnext : ∀ output, (next output).IsQueryBoundP (IsTargetPeek target) 0 := by + intro output + simpa using hnoPeek.2 output + cases query with + | uniform n => + simp only [runPermissiveJointChargedFromTable, OracleComp.construct_query_bind] + have hleft : evalDist + (LazyRevealProbe.sampleHashOutput >>= fun targetOutput => + (liftM (unifSpec.query n) >>= fun output => + runPermissiveJointChargedFromTable (preloadPositionValue target targetOutput state) fuel + table (next output))) = + evalDist + (liftM (unifSpec.query n) >>= fun output => + LazyRevealProbe.sampleHashOutput >>= fun targetOutput => + runPermissiveJointChargedFromTable (preloadPositionValue target targetOutput state) fuel + table (next output)) := + OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + apply relTriple_of_evalDist_eq_left hleft + apply relTriple_bind (relTriple_refl (liftM (unifSpec.query n))) + intro leftOutput rightOutput heq + subst rightOutput + exact ih leftOutput state fuel hvalue (hnext leftOutput) + | hashOutput => + simp only [runPermissiveJointChargedFromTable, OracleComp.construct_query_bind] + have hleft : evalDist + (LazyRevealProbe.sampleHashOutput >>= fun targetOutput => + (LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveJointChargedFromTable (preloadPositionValue target targetOutput state) fuel + table (next output))) = + evalDist + (LazyRevealProbe.sampleHashOutput >>= fun output => + LazyRevealProbe.sampleHashOutput >>= fun targetOutput => + runPermissiveJointChargedFromTable (preloadPositionValue target targetOutput state) fuel + table (next output)) := + OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + apply relTriple_of_evalDist_eq_left hleft + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + exact ih leftOutput state fuel hvalue (hnext leftOutput) + | ensure coordinate => + simp only [runPermissiveJointChargedFromTable, OracleComp.construct_query_bind] + change RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveJointChargedFromTable + ((preloadPositionValue target output state).ensure coordinate) + fuel table (next ())) + (runPermissiveJointChargedFromTable (state.ensure coordinate) fuel table (next ())) + (PreloadedJointChargedRunRel target) + simp_rw [← preloadPositionValue_ensure] + exact ih () (state.ensure coordinate) fuel hvalue (hnext ()) + | probe coordinate candidate => + simp only [runPermissiveJointChargedFromTable, OracleComp.construct_query_bind] + cases fuel with + | zero => + apply relTriple_of_evalDist_eq_left + (OracleComp.DeferredSampling.evalDist_bind_const_neverFails + LazyRevealProbe.sampleHashOutput (by simp [LazyRevealProbe.sampleHashOutput]) (pure (none, 0))) + exact relTriple_pure_pure ⟨le_refl 0, trivial⟩ + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [preloadPositionValue_revealed, hrevealed, ↓reduceIte] + exact ih () state remaining hvalue (hnext ()) + · simp only [preloadPositionValue_revealed, hrevealed, ↓reduceIte] + simp_rw [candidateCharge_sum_preload_eq] + rw [← map_bind] + apply relTriple_map + apply relTriple_post_mono + (ih () (state.addPending coordinate candidate) remaining hvalue (hnext ())) + intro left right hrel + exact ⟨Nat.add_le_add_right hrel.1 _, hrel.2⟩ + | peek coordinate => + simp only [runPermissiveJointChargedFromTable, OracleComp.construct_query_bind] + have hne : coordinate ≠ .position target := by + intro heq + subst coordinate + have hnot : ¬IsTargetPeek target + (LazyRevealProbe.Query.peek (.position target)) := by + simpa using hnoPeek.1 + exact hnot (by simp [IsTargetPeek]) + change RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveJointChargedFromTable (preloadPositionValue target output state) fuel table + (next ((preloadPositionValue target output state).values coordinate))) + (runPermissiveJointChargedFromTable state fuel table (next (state.values coordinate))) + (PreloadedJointChargedRunRel target) + simp_rw [preloadPositionValue_values_of_ne target _ state coordinate hne] + exact ih (state.values coordinate) state fuel hvalue + (hnext (state.values coordinate)) + | publish coordinate => + simp only [runPermissiveJointChargedFromTable, OracleComp.construct_query_bind] + change RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveJointChargedFromTable + ((preloadPositionValue target output state).publish coordinate) + fuel table (next ())) + (runPermissiveJointChargedFromTable (state.publish coordinate) fuel table (next ())) + (PreloadedJointChargedRunRel target) + simp_rw [← preloadPositionValue_publish] + exact ih () (state.publish coordinate) fuel hvalue (hnext ()) + | reveal coordinate => + simp only [runPermissiveJointChargedFromTable, OracleComp.construct_query_bind] + by_cases htarget : coordinate = .position target + · subst coordinate + simp only [preloadPositionValue_values_target, hvalue] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + have hstate : JointChargeStateRel + (preloadPositionValue target leftOutput state) + (state.materialize (.position target) leftOutput) := + jointChargeStateRel_preload_materialize target leftOutput state + apply relTriple_post_mono + (relTriple_runPermissiveJointChargedFromTable_of_stateRel (next leftOutput) + (preloadPositionValue target leftOutput state) + (state.materialize (.position target) leftOutput) fuel table hstate) + intro left right hrel + exact jointChargedRunRel_to_preloadedJointChargedRunRel target hrel + · simp_rw [preloadPositionValue_values_of_ne target _ state coordinate htarget] + cases hcoordinateValue : state.values coordinate with + | some output => + simp only + exact ih output state fuel hvalue (hnext output) + | none => + simp only + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only + let coordinate : Coordinate := .chainStart lay tree leafIdx chainIdx + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + have hvalue' : (state.materialize coordinate output).values + (.position target) = none := by + simp [coordinate, LazyRevealProbe.State.materialize, + hvalue] + have hcoupling := + ih output (state.materialize coordinate output) fuel hvalue' + (hnext output) + simp_rw [preloadPositionValue_materialize_of_ne target _ state coordinate + output htarget] at hcoupling + exact hcoupling + | position position => + simp only + have hposition : Coordinate.position position ≠ .position target := htarget + have hvalue' (output : HashOutput) : + (state.materialize (.position position) output).values + (.position target) = none := by + simp [LazyRevealProbe.State.materialize, + Function.update_of_ne (Ne.symm hposition), hvalue] + have hleft : evalDist + (LazyRevealProbe.sampleHashOutput >>= fun targetOutput => + LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveJointChargedFromTable + (preloadPositionValue target targetOutput + (state.materialize (.position position) output)) + fuel table (next output)) = + evalDist + (LazyRevealProbe.sampleHashOutput >>= fun output => + LazyRevealProbe.sampleHashOutput >>= fun targetOutput => + runPermissiveJointChargedFromTable + (preloadPositionValue target targetOutput + (state.materialize (.position position) output)) + fuel table (next output)) := + OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + simp only [preloadPositionValue_materialize_of_ne target _ state + (.position position) _ hposition] at hleft + apply relTriple_of_evalDist_eq_left hleft + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + have hcoupling := + ih leftOutput (state.materialize (.position position) leftOutput) fuel + (hvalue' leftOutput) (hnext leftOutput) + simp_rw [preloadPositionValue_materialize_of_ne target _ state + (.position position) leftOutput hposition] at hcoupling + change RelTriple _ + (runPermissiveJointChargedFromTable + (state.materialize (.position position) leftOutput) fuel table + (next leftOutput)) + (PreloadedJointChargedRunRel target) + exact hcoupling + + +theorem sample_preload_runPermissiveJointChargedFromTable_expectedCost_le + (target : Position) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hvalue : state.values (.position target) = none) + (hnoPeek : computation.IsQueryBoundP (IsTargetPeek target) 0) : + (∑' result, Pr[= result | LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveJointChargedFromTable (preloadPositionValue target output state) + fuel table computation] * (result.2 : ℝ≥0∞)) ≤ + ∑' result, Pr[= result | runPermissiveJointChargedFromTable state fuel table computation] * + (result.2 : ℝ≥0∞) := by + simpa using SphincsSecurity.expected_cost_le_of_relTriple + (relTriple_sample_preload_runPermissiveJointChargedFromTable target computation state fuel table hvalue hnoPeek) + (fun result => (result.2 : ℝ≥0∞)) (fun result => (result.2 : ℝ≥0∞)) (fun _ => 0) + (fun _ _ hresult => by simpa using (Nat.cast_le.mpr hresult.1 : (_ : ℝ≥0∞) ≤ _)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointRootMap.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointRootMap.lean new file mode 100644 index 00000000..f31463a1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointRootMap.lean @@ -0,0 +1,62 @@ +import SphincsSecurity.Proof.OtsProbeJointFinalization + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option linter.constructorNameAsVariable false + +def retainDiagnosticRoot (root : Digest) + (diagnostic : ObservedMaterializedDiagnostic (RetainedRestResult × SplitHashCache)) : + ObservedMaterializedDiagnostic (RetainedGameResult × SplitHashCache) := + ⟨retainObservedRoot root diagnostic.before, retainObservedRoot root diagnostic.final, + diagnostic.wasDoomed⟩ + +theorem retainDiagnosticRoot_bad_iff (root : Digest) + (diagnostic : ObservedMaterializedDiagnostic (RetainedRestResult × SplitHashCache)) : + (retainDiagnosticRoot root diagnostic).Bad ↔ diagnostic.Bad := by + cases diagnostic with + | mk before final wasDoomed => + cases final <;> simp [retainDiagnosticRoot, retainObservedRoot, + ObservedMaterializedDiagnostic.Bad] + +theorem BoundarySnapshotDiagnosticRel.retainRoot + {table : OtsSecretIndex → HashOutput} + {source : BoundaryWitnessSnapshotOutput} + {diagnostic : ObservedMaterializedDiagnostic (RetainedRestResult × SplitHashCache)} + (hrelation : BoundarySnapshotDiagnosticRel table source diagnostic) (root : Digest) : + BoundarySnapshotDiagnosticRel table source (retainDiagnosticRoot root diagnostic) := by + rcases hrelation with hbad | ⟨⟨result, aligned, hresult, hprefix, haligned, hstored⟩, hprivate⟩ + · exact Or.inl ((retainDiagnosticRoot_bad_iff root diagnostic).2 hbad) + · right + refine ⟨⟨{ result with value := ((root, result.value.1), result.value.2) }, aligned, + ?_, hprefix, haligned, hstored⟩, hprivate⟩ + simp [retainDiagnosticRoot, hresult, retainObservedRoot] + +theorem map_retainDiagnosticRoot_finish + (table : OtsSecretIndex → HashOutput) (root : Digest) + (observed : Option (ObservedCleanRunResult (RetainedRestResult × SplitHashCache))) : + retainDiagnosticRoot root <$> finishObservedMaterializedDiagnostic table observed = + finishObservedMaterializedDiagnostic table (retainObservedRoot root observed) := by + classical + cases observed with + | none => simp [finishObservedMaterializedDiagnostic, retainDiagnosticRoot, retainObservedRoot] + | some result => + simp only [finishObservedMaterializedDiagnostic, finishObservedCleanRunFromTable, + retainObservedRoot, map_bind, bind_assoc] + apply bind_congr + intro finalized + cases finalized <;> rfl + +theorem map_retainDiagnosticRoot_bind_finish + (table : OtsSecretIndex → HashOutput) (root : Digest) + (run : ProbComp (Option (ObservedCleanRunResult (RetainedRestResult × SplitHashCache)))) : + retainDiagnosticRoot root <$> (run >>= finishObservedMaterializedDiagnostic table) = + (retainObservedRoot root <$> run) >>= finishObservedMaterializedDiagnostic table := by + rw [map_bind, bind_map_left] + apply bind_congr + intro observed + exact map_retainDiagnosticRoot_finish table root observed + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointSnapshot.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointSnapshot.lean new file mode 100644 index 00000000..dda6e440 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointSnapshot.lean @@ -0,0 +1,158 @@ +import SphincsSecurity.Proof.OtsProbeBoundaryCompletion +import SphincsSecurity.Proof.OtsProbeDiagnostic125 + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +/-- Retains the boundary outcome and candidate contexts for a joint failure analysis. -/ +structure BoundaryWitnessSnapshotOutput where + outcome : DirectBoundaryOutcome + witnessSnapshot : PrivateWitnessSnapshotOutput + +def eraseBoundaryWitnessSnapshotOutput + (output : BoundaryWitnessSnapshotOutput) : BoundaryWitnessPlanOutput := + ⟨output.outcome, erasePrivateWitnessSnapshotOutput output.witnessSnapshot⟩ + +noncomputable def finishDirectBoundaryWitnessSnapshotObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp BoundaryWitnessSnapshotOutput) + (candidates : List PlannedProbeSnapshot) : DirectWitnessResult α → + ProbComp BoundaryWitnessSnapshotOutput + | .stoppedFuel => pure ⟨.ordinaryFailure, none, candidates⟩ + | .stoppedOrdinary => pure ⟨.ordinaryFailure, none, candidates⟩ + | .stoppedPrivate witness => pure ⟨.privateStructuralFailure, some witness, candidates⟩ + | .done result => observe result.context result.remaining result.value candidates + +noncomputable def classifyDirectBoundaryWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp BoundaryWitnessSnapshotOutput) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List PlannedProbeSnapshot) : + ProbComp BoundaryWitnessSnapshotOutput := by + classical + exact if hhit : PrivateStructuralHit context then + pure ⟨.privateStructuralFailure, some (privateHitWitnessOf context hhit), candidates⟩ + else if DeferredCompletable table context then + observe context fuel value candidates + else + pure ⟨.ordinaryFailure, none, candidates⟩ + +noncomputable def canonicalizeDirectBoundaryWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp BoundaryWitnessSnapshotOutput) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List PlannedProbeSnapshot) : + ProbComp BoundaryWitnessSnapshotOutput := by + classical + let canonical := canonicalizeMaterializedValues table context + exact if hhit : PrivateStructuralHit canonical then + pure ⟨.privateStructuralFailure, some (privateHitWitnessOf canonical hhit), candidates⟩ + else if PublishedValues context.state then + classifyDirectBoundaryWitnessSnapshotObserve table observe canonical fuel value candidates + else + pure ⟨.ordinaryFailure, none, candidates⟩ + +noncomputable def runDirectBoundaryWitnessSnapshotObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp BoundaryWitnessSnapshotOutput) + (candidates : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + ProbComp BoundaryWitnessSnapshotOutput := + runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectBoundaryWitnessSnapshotObserve observe candidates + +noncomputable def directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → List PlannedProbeSnapshot → + ProbComp BoundaryWitnessSnapshotOutput) + (candidates : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp BoundaryWitnessSnapshotOutput := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + (DeferredContext → Nat → (α × SplitHashCache) → List PlannedProbeSnapshot → + ProbComp BoundaryWitnessSnapshotOutput) → + List PlannedProbeSnapshot → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → + SplitHashCache → ProbComp BoundaryWitnessSnapshotOutput) + (fun value observe candidates context fuel _table cache => + observe context fuel (value, cache) candidates) + (fun query _next recursivelyRun observe candidates context fuel table cache => + match query with + | .inl (.inl n) => + runDirectBoundaryWitnessSnapshotObserve + (canonicalizeDirectBoundaryWitnessSnapshotObserve table + (fun nextContext remaining value nextCandidates => + recursivelyRun value.1 observe nextCandidates nextContext remaining table + value.2)) + candidates context fuel table ((splitUniformImpl n).run cache) + | .inl (.inr input) => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedSnapshot candidates + (rootAwarePlannedCandidate? parameter input context.state) context + runDirectBoundaryWitnessSnapshotObserve + (canonicalizeDirectBoundaryWitnessSnapshotObserve table + (fun nextContext remaining value laterCandidates => + recursivelyRun value.1 observe laterCandidates nextContext remaining table + value.2)) + nextCandidates context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) + | .inr message => + runDirectBoundaryWitnessSnapshotObserve + (canonicalizeDirectBoundaryWitnessSnapshotObserve table + (fun nextContext remaining value nextCandidates => + recursivelyRun value.1 observe nextCandidates nextContext remaining table + value.2)) + candidates context fuel table ((maskedSign parameter root ftsSecret message).run cache)) + computation observe candidates context fuel table cache + +noncomputable def retainedResolvedFinalizationBoundaryWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) (candidates : List PlannedProbeSnapshot) : + ProbComp BoundaryWitnessSnapshotOutput := by + classical + exact if hhit : PrivateStructuralHit context then + pure ⟨.privateStructuralFailure, some (privateHitWitnessOf context hhit), candidates⟩ + else if DeferredCompletable table context then do + let failed ← resolvedFinalizationObserve table context fuel ((root, value.1), value.2) + pure ⟨DirectBoundaryOutcome.ofFailed failed, none, candidates⟩ + else + pure ⟨.ordinaryFailure, none, candidates⟩ + +noncomputable def granularDetailedRetainedRestNormalizedBoundaryWitnessSnapshotObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List PlannedProbeSnapshot) : + ProbComp BoundaryWitnessSnapshotOutput := + directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationBoundaryWitnessSnapshotObserve table value.1) + candidates context fuel table value.2 + +noncomputable def granularAllCanonicalBoundaryWitnessSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp BoundaryWitnessSnapshotOutput := + runDirectBoundaryWitnessSnapshotObserve + (canonicalizeDirectBoundaryWitnessSnapshotObserve table + (granularDetailedRetainedRestNormalizedBoundaryWitnessSnapshotObserve adversary parameter table + ftsSecret)) + [] emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + +noncomputable def sampledGranularAllCanonicalBoundaryWitnessSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp BoundaryWitnessSnapshotOutput := do + let table ← sampleOtsHashTable + granularAllCanonicalBoundaryWitnessSnapshot adversary parameter table ftsSecret fuel + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointSnapshotErasure.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointSnapshotErasure.lean new file mode 100644 index 00000000..28f390b2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointSnapshotErasure.lean @@ -0,0 +1,287 @@ +import SphincsSecurity.Proof.OtsProbeJointSnapshotProjection + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option linter.constructorNameAsVariable false + +attribute [local simp] erasePrivateWitnessSnapshotOutput + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem map_erase_finishDirectBoundaryWitnessSnapshotObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp BoundaryWitnessSnapshotOutput) + (planObserve : DeferredContext → Nat → α → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (snapshots : List PlannedProbeSnapshot) (result : DirectWitnessResult α) + (hproject : ∀ context fuel value snapshots, + eraseBoundaryWitnessSnapshotOutput <$> observe context fuel value snapshots = + planObserve context fuel value + (snapshots.map PlannedProbeSnapshot.toProbe)) : + eraseBoundaryWitnessSnapshotOutput <$> + finishDirectBoundaryWitnessSnapshotObserve observe snapshots result = + finishDirectBoundaryWitnessPlanObserve planObserve + (snapshots.map PlannedProbeSnapshot.toProbe) result := by + cases result with + | stoppedFuel => simp [finishDirectBoundaryWitnessSnapshotObserve, + finishDirectBoundaryWitnessPlanObserve, eraseBoundaryWitnessSnapshotOutput] + | stoppedOrdinary => simp [finishDirectBoundaryWitnessSnapshotObserve, + finishDirectBoundaryWitnessPlanObserve, eraseBoundaryWitnessSnapshotOutput] + | stoppedPrivate witness => simp [finishDirectBoundaryWitnessSnapshotObserve, + finishDirectBoundaryWitnessPlanObserve, eraseBoundaryWitnessSnapshotOutput] + | done result => exact hproject result.context result.remaining result.value snapshots + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem map_erase_classifyDirectBoundaryWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp BoundaryWitnessSnapshotOutput) + (planObserve : DeferredContext → Nat → α → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (context : DeferredContext) (fuel : Nat) (value : α) + (snapshots : List PlannedProbeSnapshot) + (hproject : ∀ nextContext remaining nextValue nextSnapshots, + eraseBoundaryWitnessSnapshotOutput <$> + observe nextContext remaining nextValue nextSnapshots = + planObserve nextContext remaining nextValue + (nextSnapshots.map PlannedProbeSnapshot.toProbe)) : + eraseBoundaryWitnessSnapshotOutput <$> + classifyDirectBoundaryWitnessSnapshotObserve table observe context fuel value snapshots = + classifyDirectBoundaryWitnessPlanObserve table planObserve context fuel value + (snapshots.map PlannedProbeSnapshot.toProbe) := by + classical + unfold classifyDirectBoundaryWitnessSnapshotObserve classifyDirectBoundaryWitnessPlanObserve + by_cases hhit : PrivateStructuralHit context + · simp [hhit, eraseBoundaryWitnessSnapshotOutput] + · simp only [hhit, ↓reduceDIte] + by_cases hcompletable : DeferredCompletable table context + · simp only [hcompletable, ↓reduceIte] + exact hproject context fuel value snapshots + · simp [hcompletable, eraseBoundaryWitnessSnapshotOutput] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem map_erase_canonicalizeDirectBoundaryWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp BoundaryWitnessSnapshotOutput) + (planObserve : DeferredContext → Nat → α → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (context : DeferredContext) (fuel : Nat) (value : α) + (snapshots : List PlannedProbeSnapshot) + (hproject : ∀ nextContext remaining nextValue nextSnapshots, + eraseBoundaryWitnessSnapshotOutput <$> + observe nextContext remaining nextValue nextSnapshots = + planObserve nextContext remaining nextValue + (nextSnapshots.map PlannedProbeSnapshot.toProbe)) : + eraseBoundaryWitnessSnapshotOutput <$> + canonicalizeDirectBoundaryWitnessSnapshotObserve table observe context fuel value snapshots = + canonicalizeDirectBoundaryWitnessPlanObserve table planObserve context fuel value + (snapshots.map PlannedProbeSnapshot.toProbe) := by + classical + unfold canonicalizeDirectBoundaryWitnessSnapshotObserve canonicalizeDirectBoundaryWitnessPlanObserve + let canonical := canonicalizeMaterializedValues table context + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit, eraseBoundaryWitnessSnapshotOutput] + · simp only [canonical, hhit, ↓reduceDIte] + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + exact map_erase_classifyDirectBoundaryWitnessSnapshotObserve table observe planObserve canonical + fuel value snapshots hproject + · simp [hpublished, eraseBoundaryWitnessSnapshotOutput] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem map_erase_runDirectBoundaryWitnessSnapshotObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp BoundaryWitnessSnapshotOutput) + (planObserve : DeferredContext → Nat → α → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (snapshots : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hproject : ∀ nextContext remaining value nextSnapshots, + eraseBoundaryWitnessSnapshotOutput <$> + observe nextContext remaining value nextSnapshots = + planObserve nextContext remaining value + (nextSnapshots.map PlannedProbeSnapshot.toProbe)) : + eraseBoundaryWitnessSnapshotOutput <$> + runDirectBoundaryWitnessSnapshotObserve observe snapshots context fuel table computation = + runDirectBoundaryWitnessPlanObserve planObserve + (snapshots.map PlannedProbeSnapshot.toProbe) context fuel table computation := by + unfold runDirectBoundaryWitnessSnapshotObserve runDirectBoundaryWitnessPlanObserve + rw [map_bind] + apply bind_congr + intro result + exact map_erase_finishDirectBoundaryWitnessSnapshotObserve observe planObserve snapshots result hproject + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem map_erase_directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → ProbComp BoundaryWitnessSnapshotOutput) + (planObserve : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp BoundaryWitnessPlanOutput) + (snapshots : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hproject : ∀ nextContext remaining value nextSnapshots, + eraseBoundaryWitnessSnapshotOutput <$> + observe nextContext remaining value nextSnapshots = + planObserve nextContext remaining value + (nextSnapshots.map PlannedProbeSnapshot.toProbe)) : + eraseBoundaryWitnessSnapshotOutput <$> + directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve parameter root ftsSecret + computation observe snapshots context fuel table cache = + directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve parameter root ftsSecret + computation planObserve (snapshots.map PlannedProbeSnapshot.toProbe) context fuel table + cache := by + induction computation using OracleComp.inductionOn generalizing snapshots context fuel cache with + | pure value => + rw [directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve, + OracleComp.construct_pure, + directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve, OracleComp.construct_pure] + exact hproject context fuel (value, cache) snapshots + | query_bind query next ih => + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve, + OracleComp.construct_query_bind] + rw [directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve, + OracleComp.construct_query_bind] + apply map_erase_runDirectBoundaryWitnessSnapshotObserve + intro nextContext remaining value nextSnapshots + apply map_erase_canonicalizeDirectBoundaryWitnessSnapshotObserve + intro finalContext finalRemaining finalValue finalSnapshots + exact ih finalValue.1 finalSnapshots finalContext finalRemaining finalValue.2 + | inr input => + rw [directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve, + OracleComp.construct_query_bind] + rw [directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve, + OracleComp.construct_query_bind] + let plan := purePlanProbingHashQuery parameter input context.state + let nextSnapshots := appendPlannedSnapshot snapshots + (rootAwarePlannedCandidate? parameter input context.state) context + dsimp only + rw [← map_toProbe_appendPlannedSnapshot] + apply map_erase_runDirectBoundaryWitnessSnapshotObserve + intro nextContext remaining value laterSnapshots + apply map_erase_canonicalizeDirectBoundaryWitnessSnapshotObserve + intro finalContext finalRemaining finalValue finalSnapshots + exact ih finalValue.1 finalSnapshots finalContext finalRemaining finalValue.2 + | inr message => + rw [directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve, + OracleComp.construct_query_bind] + rw [directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve, + OracleComp.construct_query_bind] + apply map_erase_runDirectBoundaryWitnessSnapshotObserve + intro nextContext remaining value nextSnapshots + apply map_erase_canonicalizeDirectBoundaryWitnessSnapshotObserve + intro finalContext finalRemaining finalValue finalSnapshots + exact ih finalValue.1 finalSnapshots finalContext finalRemaining finalValue.2 + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem map_erase_retainedResolvedFinalizationBoundaryWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) + (snapshots : List PlannedProbeSnapshot) : + eraseBoundaryWitnessSnapshotOutput <$> + retainedResolvedFinalizationBoundaryWitnessSnapshotObserve table root context fuel value + snapshots = + retainedResolvedFinalizationBoundaryWitnessPlanObserve table root context fuel value + (snapshots.map PlannedProbeSnapshot.toProbe) := by + classical + unfold retainedResolvedFinalizationBoundaryWitnessSnapshotObserve + retainedResolvedFinalizationBoundaryWitnessPlanObserve + by_cases hhit : PrivateStructuralHit context <;> + by_cases hcomplete : DeferredCompletable table context <;> + simp [hhit, hcomplete, eraseBoundaryWitnessSnapshotOutput] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem map_erase_granularDetailedRetainedRestNormalizedBoundaryWitnessSnapshotObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (snapshots : List PlannedProbeSnapshot) : + eraseBoundaryWitnessSnapshotOutput <$> + granularDetailedRetainedRestNormalizedBoundaryWitnessSnapshotObserve adversary parameter + table ftsSecret context fuel value snapshots = + granularDetailedRetainedRestNormalizedBoundaryWitnessPlanObserve adversary parameter table + ftsSecret context fuel value (snapshots.map PlannedProbeSnapshot.toProbe) := by + unfold granularDetailedRetainedRestNormalizedBoundaryWitnessSnapshotObserve + granularDetailedRetainedRestNormalizedBoundaryWitnessPlanObserve + apply map_erase_directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve + intro nextContext remaining nextValue nextSnapshots + exact map_erase_retainedResolvedFinalizationBoundaryWitnessSnapshotObserve table value.1 + nextContext remaining nextValue nextSnapshots + +theorem map_erase_granularAllCanonicalBoundaryWitnessSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + eraseBoundaryWitnessSnapshotOutput <$> + granularAllCanonicalBoundaryWitnessSnapshot adversary parameter table ftsSecret fuel = + granularAllCanonicalBoundaryWitnessPlan adversary parameter table ftsSecret fuel := by + unfold granularAllCanonicalBoundaryWitnessSnapshot granularAllCanonicalBoundaryWitnessPlan + apply map_erase_runDirectBoundaryWitnessSnapshotObserve + intro context remaining value snapshots + apply map_erase_canonicalizeDirectBoundaryWitnessSnapshotObserve + intro nextContext nextRemaining nextValue nextSnapshots + exact map_erase_granularDetailedRetainedRestNormalizedBoundaryWitnessSnapshotObserve adversary + parameter table ftsSecret nextContext nextRemaining nextValue nextSnapshots + +theorem map_erase_sampledGranularAllCanonicalBoundaryWitnessSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + eraseBoundaryWitnessSnapshotOutput <$> + sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret fuel = + sampledGranularAllCanonicalBoundaryWitnessPlan adversary parameter ftsSecret fuel := by + unfold sampledGranularAllCanonicalBoundaryWitnessSnapshot + sampledGranularAllCanonicalBoundaryWitnessPlan + rw [map_bind] + apply bind_congr + intro table + exact map_erase_granularAllCanonicalBoundaryWitnessSnapshot adversary parameter table + ftsSecret fuel + +theorem evalDist_failed_sampledGranularAllCanonicalBoundaryWitnessSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist ((fun output => output.outcome.failed) <$> + sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret fuel) = + evalDist (sampledGranularAllCanonicalBoundaryRetainedFinishIsNone adversary parameter + ftsSecret fuel) := by + have h := evalDist_failed_sampledGranularAllCanonicalBoundaryWitnessPlan adversary parameter + ftsSecret fuel + rw [← map_erase_sampledGranularAllCanonicalBoundaryWitnessSnapshot] at h + simpa only [Functor.map_map, Function.comp_def, eraseBoundaryWitnessSnapshotOutput] using h + +theorem probEvent_sampledActualRetained_verifyProbe_le_jointBoundaryFailed + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + Pr[fun output => output.outcome.failed = true | + sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret fuel] := by + have h := probEvent_sampledActualRetainedOtsHashTable_verifyProbe_le_canonicalDeferred + adversary parameter ftsSecret fuel + have heq := evalDist_failed_sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary + parameter ftsSecret fuel + rw [evalDist_sampledCanonicalBoundary_eq_deferred] at heq + rw [← OracleComp.probOutput_congr (show true = true from rfl) heq, + ← probEvent_eq_eq_probOutput, probEvent_map] at h + exact h + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointSnapshotProjection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointSnapshotProjection.lean new file mode 100644 index 00000000..5b9eba69 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointSnapshotProjection.lean @@ -0,0 +1,262 @@ +import SphincsSecurity.Proof.OtsProbeJointSnapshot + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option linter.constructorNameAsVariable false + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_witnessSnapshot_retainedFinalizationBoundaryWitnessSnapshot + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) (candidates : List PlannedProbeSnapshot) : + evalDist (BoundaryWitnessSnapshotOutput.witnessSnapshot <$> + retainedResolvedFinalizationBoundaryWitnessSnapshotObserve table root context fuel value + candidates) = + evalDist + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table root context fuel value + candidates) := by + classical + unfold retainedResolvedFinalizationBoundaryWitnessSnapshotObserve + retainedResolvedFinalizationPrivateWitnessSnapshotObserve + by_cases hhit : PrivateStructuralHit context + · simp [hhit] + · simp only [hhit, ↓reduceDIte, map_eq_bind_pure_comp] + by_cases hcompletable : DeferredCompletable table context + · simp only [hcompletable, ↓reduceIte] + simp only [bind_assoc, pure_bind, Function.comp_apply] + change evalDist + (resolvedFinalizationObserve table context fuel ((root, value.1), value.2) >>= + fun _ => pure (none, candidates)) = + evalDist (pure (none, candidates) : ProbComp PrivateWitnessSnapshotOutput) + exact OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolvedFinalizationObserve table context fuel ((root, value.1), value.2)) + (by simp [resolvedFinalizationObserve]) _ + · simp [hcompletable] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_witnessSnapshot_finishDirectBoundaryWitnessSnapshotObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp BoundaryWitnessSnapshotOutput) + (witnessObserve : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (candidates : List PlannedProbeSnapshot) (result : DirectWitnessResult α) + (hproject : ∀ context fuel value nextCandidates, + evalDist (BoundaryWitnessSnapshotOutput.witnessSnapshot <$> + observe context fuel value nextCandidates) = + evalDist (witnessObserve context fuel value nextCandidates)) : + evalDist (BoundaryWitnessSnapshotOutput.witnessSnapshot <$> + finishDirectBoundaryWitnessSnapshotObserve observe candidates result) = + evalDist (finishDirectWitnessSnapshotObserve witnessObserve candidates result) := by + cases result with + | stoppedFuel => simp [finishDirectBoundaryWitnessSnapshotObserve, finishDirectWitnessSnapshotObserve] + | stoppedOrdinary => + simp [finishDirectBoundaryWitnessSnapshotObserve, finishDirectWitnessSnapshotObserve] + | stoppedPrivate witness => + simp [finishDirectBoundaryWitnessSnapshotObserve, finishDirectWitnessSnapshotObserve] + | done result => exact hproject result.context result.remaining result.value candidates + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_witnessSnapshot_classifyDirectBoundaryWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp BoundaryWitnessSnapshotOutput) + (witnessObserve : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List PlannedProbeSnapshot) + (hproject : ∀ nextContext remaining nextValue nextCandidates, + evalDist (BoundaryWitnessSnapshotOutput.witnessSnapshot <$> + observe nextContext remaining nextValue nextCandidates) = + evalDist (witnessObserve nextContext remaining nextValue nextCandidates)) : + evalDist (BoundaryWitnessSnapshotOutput.witnessSnapshot <$> + classifyDirectBoundaryWitnessSnapshotObserve table observe context fuel value candidates) = + evalDist + (classifyDirectWitnessSnapshotObserve table witnessObserve context fuel value candidates) := by + classical + unfold classifyDirectBoundaryWitnessSnapshotObserve classifyDirectWitnessSnapshotObserve + by_cases hhit : PrivateStructuralHit context + · simp [hhit] + · simp only [hhit, ↓reduceDIte] + by_cases hcompletable : DeferredCompletable table context + · simp only [hcompletable, ↓reduceIte] + exact hproject context fuel value candidates + · simp [hcompletable] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_witnessSnapshot_canonicalizeDirectBoundaryWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp BoundaryWitnessSnapshotOutput) + (witnessObserve : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List PlannedProbeSnapshot) + (hproject : ∀ nextContext remaining nextValue nextCandidates, + evalDist (BoundaryWitnessSnapshotOutput.witnessSnapshot <$> + observe nextContext remaining nextValue nextCandidates) = + evalDist (witnessObserve nextContext remaining nextValue nextCandidates)) : + evalDist (BoundaryWitnessSnapshotOutput.witnessSnapshot <$> + canonicalizeDirectBoundaryWitnessSnapshotObserve table observe context fuel value candidates) = + evalDist + (canonicalizeDirectWitnessSnapshotObserve table witnessObserve context fuel value candidates) := by + classical + unfold canonicalizeDirectBoundaryWitnessSnapshotObserve canonicalizeDirectWitnessSnapshotObserve + let canonical := canonicalizeMaterializedValues table context + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit] + · simp only [canonical, hhit, ↓reduceDIte] + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + exact evalDist_witnessSnapshot_classifyDirectBoundaryWitnessSnapshotObserve table observe + witnessObserve canonical fuel value candidates hproject + · simp [hpublished] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_witnessSnapshot_runDirectBoundaryWitnessSnapshotObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp BoundaryWitnessSnapshotOutput) + (witnessObserve : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (candidates : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hproject : ∀ nextContext remaining value nextCandidates, + evalDist (BoundaryWitnessSnapshotOutput.witnessSnapshot <$> + observe nextContext remaining value nextCandidates) = + evalDist (witnessObserve nextContext remaining value nextCandidates)) : + evalDist (BoundaryWitnessSnapshotOutput.witnessSnapshot <$> + runDirectBoundaryWitnessSnapshotObserve observe candidates context fuel table computation) = + evalDist + (runDirectWitnessSnapshotObserve witnessObserve candidates context fuel table computation) := by + unfold runDirectBoundaryWitnessSnapshotObserve runDirectWitnessSnapshotObserve + rw [map_bind] + apply evalDist_bind_congr + intro result _hresult + exact evalDist_witnessSnapshot_finishDirectBoundaryWitnessSnapshotObserve observe witnessObserve + candidates result hproject + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_witnessSnapshot_directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → List PlannedProbeSnapshot → + ProbComp BoundaryWitnessSnapshotOutput) + (witnessObserve : DeferredContext → Nat → (α × SplitHashCache) → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (candidates : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hproject : ∀ nextContext remaining value nextCandidates, + evalDist (BoundaryWitnessSnapshotOutput.witnessSnapshot <$> + observe nextContext remaining value nextCandidates) = + evalDist (witnessObserve nextContext remaining value nextCandidates)) : + evalDist (BoundaryWitnessSnapshotOutput.witnessSnapshot <$> + directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve parameter root ftsSecret + computation observe candidates context fuel table cache) = + evalDist (directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root ftsSecret + computation witnessObserve candidates context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve, + OracleComp.construct_pure, + directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, OracleComp.construct_pure] + exact hproject context fuel (value, cache) candidates + | query_bind query next ih => + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve, + OracleComp.construct_query_bind, + directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_query_bind] + apply evalDist_witnessSnapshot_runDirectBoundaryWitnessSnapshotObserve + intro nextContext remaining value nextCandidates + apply evalDist_witnessSnapshot_canonicalizeDirectBoundaryWitnessSnapshotObserve + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + | inr input => + rw [directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve, + OracleComp.construct_query_bind, + directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_query_bind] + apply evalDist_witnessSnapshot_runDirectBoundaryWitnessSnapshotObserve + intro nextContext remaining value laterCandidates + apply evalDist_witnessSnapshot_canonicalizeDirectBoundaryWitnessSnapshotObserve + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + | inr message => + rw [directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve, + OracleComp.construct_query_bind, + directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_query_bind] + apply evalDist_witnessSnapshot_runDirectBoundaryWitnessSnapshotObserve + intro nextContext remaining value nextCandidates + apply evalDist_witnessSnapshot_canonicalizeDirectBoundaryWitnessSnapshotObserve + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_witnessSnapshot_granularDetailedRetainedRestNormalizedBoundaryWitnessSnapshotObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List PlannedProbeSnapshot) : + evalDist (BoundaryWitnessSnapshotOutput.witnessSnapshot <$> + granularDetailedRetainedRestNormalizedBoundaryWitnessSnapshotObserve adversary parameter table + ftsSecret context fuel value candidates) = + evalDist + (granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter table + ftsSecret context fuel value candidates) := by + unfold granularDetailedRetainedRestNormalizedBoundaryWitnessSnapshotObserve + granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve + apply evalDist_witnessSnapshot_directDetailedBoundaryNormalizedBoundaryWitnessSnapshotObserve + intro nextContext remaining nextValue nextCandidates + exact evalDist_witnessSnapshot_retainedFinalizationBoundaryWitnessSnapshot table value.1 nextContext + remaining nextValue nextCandidates + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_witnessSnapshot_granularAllCanonicalBoundaryWitnessSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (BoundaryWitnessSnapshotOutput.witnessSnapshot <$> + granularAllCanonicalBoundaryWitnessSnapshot adversary parameter table ftsSecret fuel) = + evalDist + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel) := by + unfold granularAllCanonicalBoundaryWitnessSnapshot granularAllCanonicalPrivateWitnessSnapshot + apply evalDist_witnessSnapshot_runDirectBoundaryWitnessSnapshotObserve + intro context remaining value candidates + apply evalDist_witnessSnapshot_canonicalizeDirectBoundaryWitnessSnapshotObserve + intro nextContext nextRemaining nextValue nextCandidates + exact + evalDist_witnessSnapshot_granularDetailedRetainedRestNormalizedBoundaryWitnessSnapshotObserve + adversary parameter table ftsSecret nextContext nextRemaining nextValue nextCandidates + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_witnessSnapshot_sampledGranularAllCanonicalBoundaryWitnessSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (BoundaryWitnessSnapshotOutput.witnessSnapshot <$> + sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret fuel) = + evalDist + (sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret fuel) := by + unfold sampledGranularAllCanonicalBoundaryWitnessSnapshot + sampledGranularAllCanonicalPrivateWitnessSnapshot + rw [map_bind] + apply evalDist_bind_congr + intro table _htable + exact evalDist_witnessSnapshot_granularAllCanonicalBoundaryWitnessSnapshot adversary parameter table + ftsSecret fuel + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointStep.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointStep.lean new file mode 100644 index 00000000..3b6a063e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointStep.lean @@ -0,0 +1,128 @@ +import SphincsSecurity.Proof.OtsProbeJointFinalization + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option linter.constructorNameAsVariable false + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_finishJointWitnessObservedStep + (parameter : PublicParameter) (rootOf : α → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (next : α → OracleComp (OracleWorld + SigningSpec) β) + (leftObserve : DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → ProbComp BoundaryWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (table : OtsSecretIndex → HashOutput) + (leftResult : DirectWitnessResult (α × SplitHashCache)) + (rightResult : Option (ObservedCleanRunResult (α × SplitHashCache))) + (hrelation : WitnessObservedStepRel table observations leftResult rightResult) + (haligned : SnapshotsObservedAt table snapshots observations) + (hrecursive : ∀ left right, + leftResult = .done left → + rightResult = some (observedResolvedResult observations right) → + OrdinaryMaterializedRunEq table left right → + RelTriple + (canonicalizeDirectBoundaryWitnessSnapshotObserve table leftObserve left.context left.remaining + ((left.value.1, left.value.2)) snapshots) + (observedMaterializedBoundary parameter (rootOf right.value.1) ftsSecret + (next right.value.1) + observations right.context.state right.remaining table right.value.2 >>= finishObservedMaterializedDiagnostic table) + (BoundarySnapshotDiagnosticRel table)) : + RelTriple + (finishDirectBoundaryWitnessSnapshotObserve + (canonicalizeDirectBoundaryWitnessSnapshotObserve table leftObserve) snapshots leftResult) + (match rightResult with + | none => finishObservedMaterializedDiagnostic table none + | some result => + observedMaterializedBoundary parameter (rootOf result.value.1) ftsSecret + (next result.value.1) + result.observations result.state result.remaining table result.value.2 >>= + finishObservedMaterializedDiagnostic table) + (BoundarySnapshotDiagnosticRel table) := by + obtain ⟨detailed, hproject, hstable⟩ := hrelation + cases detailed with + | stopped reason => + have hright : rightResult = none := by + simpa [projectDirectDetailedObserved] using hproject.symm + subst rightResult + exact relTriple_any_finishDiagnostic_none table _ + + | done right => + have hright : rightResult = some + (observedResolvedResult observations right) := by + simpa [projectDirectDetailedObserved, observedResolvedResult] using hproject.symm + subst rightResult + simp only [projectDirectDetailedObserved, finishDirectBoundaryWitnessSnapshotObserve] + cases leftResult with + | stoppedFuel => + change RelTriple (pure ⟨.ordinaryFailure, none, snapshots⟩) + (observedMaterializedBoundary parameter (rootOf right.value.1) ftsSecret + (next right.value.1) + observations right.context.state right.remaining table right.value.2 >>= finishObservedMaterializedDiagnostic table) + (BoundarySnapshotDiagnosticRel table) + exact relTriple_pure_snapshot_observedDiagnostic parameter + (rootOf right.value.1) ftsSecret + (next right.value.1) ⟨.ordinaryFailure, none, snapshots⟩ observations right.context.state + right.remaining table right.value.2 + haligned + (Or.inr (by rw [← hstable.2]; exact hstable.1.2)) + | stoppedOrdinary => + change RelTriple (pure ⟨.ordinaryFailure, none, snapshots⟩) + (observedMaterializedBoundary parameter (rootOf right.value.1) ftsSecret + (next right.value.1) + observations right.context.state right.remaining table right.value.2 >>= finishObservedMaterializedDiagnostic table) + (BoundarySnapshotDiagnosticRel table) + exact relTriple_pure_snapshot_observedDiagnostic parameter + (rootOf right.value.1) ftsSecret + (next right.value.1) ⟨.ordinaryFailure, none, snapshots⟩ observations right.context.state + right.remaining table right.value.2 + haligned + (Or.inr (by rw [← hstable.2]; exact hstable.1.2)) + | stoppedPrivate witness => + change RelTriple (pure ⟨.privateStructuralFailure, some witness, snapshots⟩) + (observedMaterializedBoundary parameter (rootOf right.value.1) ftsSecret + (next right.value.1) + observations right.context.state right.remaining table right.value.2 >>= finishObservedMaterializedDiagnostic table) + (BoundarySnapshotDiagnosticRel table) + rcases hstable with hstored | hdoomed + · exact relTriple_pure_snapshot_observedDiagnostic parameter + (rootOf right.value.1) ftsSecret + (next right.value.1) ⟨.privateStructuralFailure, some witness, snapshots⟩ observations right.context.state + right.remaining table right.value.2 + haligned + (Or.inl ⟨(by + intro other hother + have : other = witness := Option.some.inj hother.symm + subst other + exact hstored.1), (by intro _; rfl)⟩) + · exact relTriple_pure_snapshot_observedDiagnostic parameter + (rootOf right.value.1) ftsSecret + (next right.value.1) ⟨.privateStructuralFailure, some witness, snapshots⟩ observations right.context.state + right.remaining table right.value.2 + haligned + (Or.inr (by rw [← hdoomed.2]; exact hdoomed.1.2)) + | done left => + change RelTriple + (canonicalizeDirectBoundaryWitnessSnapshotObserve table leftObserve left.context + left.remaining left.value snapshots) + (observedMaterializedBoundary parameter (rootOf right.value.1) ftsSecret + (next right.value.1) + observations right.context.state right.remaining table right.value.2 >>= finishObservedMaterializedDiagnostic table) + (BoundarySnapshotDiagnosticRel table) + rcases hstable with hclean | hdoomed + · exact hrecursive left right rfl hright hclean + · exact relTriple_any_observedDiagnostic_of_doomed parameter + (rootOf right.value.1) ftsSecret + (next right.value.1) + (canonicalizeDirectBoundaryWitnessSnapshotObserve table leftObserve left.context + left.remaining left.value snapshots) + observations right.context.state right.remaining table right.value.2 + (by rw [← hdoomed.2]; exact hdoomed.1.2) + + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointTop.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointTop.lean new file mode 100644 index 00000000..c2db4fa5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointTop.lean @@ -0,0 +1,84 @@ +import SphincsSecurity.Proof.OtsProbeJointTopStep + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot +set_option linter.constructorNameAsVariable false + +set_option maxHeartbeats 10000000 in +set_option maxRecDepth 100000 in +theorem relTriple_granularAllJointSnapshot_diagnostic + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + RelTriple + (granularAllCanonicalBoundaryWitnessSnapshot adversary parameter table ftsSecret q) + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table >>= + finishObservedMaterializedDiagnostic table) + (BoundarySnapshotDiagnosticRel table) := by + let initial : DeferredContext := emptyWitnessDeferredContext + have hcontext : FinalizationContextLE table initial + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) := + finalizationContextLE_empty table + have hbase := (witnessMaterializedStableCouples_maskedPublishedTreeRoot table) + initial (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + q (2 * q) emptySplitHashCache emptySplitHashCache hcontext (by omega) rfl rfl + (fun _ _ hvalue => hvalue) publishedValues_empty rfl + have hlocal := relTriple_runDirectResolvedWitness_observed_of_probeFree table + (maskedPublishedTreeRoot.run emptySplitHashCache) + (maskedPublishedTreeRoot.run emptySplitHashCache) [] initial + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + q (2 * q) hbase (maskedPublishedTreeRoot_probeFree emptySplitHashCache) rfl + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hlocal + (fun result => result ∈ support + (runDirectResolvedWitnessFromTable initial q table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (fun result hresult => hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupported + unfold granularAllCanonicalBoundaryWitnessSnapshot + observedMaterializedRetainedRunFromTable runDirectBoundaryWitnessSnapshotObserve + rw [bind_assoc] + change RelTriple + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext q table + (maskedPublishedTreeRoot.run emptySplitHashCache) >>= + finishDirectBoundaryWitnessSnapshotObserve + (canonicalizeDirectBoundaryWitnessSnapshotObserve table + (granularDetailedRetainedRestNormalizedBoundaryWitnessSnapshotObserve adversary parameter + table ftsSecret)) []) + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache) >>= fun rootResult => + (match rootResult with + | none => pure none + | some rootResult => do + let restResult ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table rootResult.value.2 + match restResult with + | none => pure none + | some restResult => pure (some + { restResult with + value := ((rootResult.value.1, restResult.value.1), restResult.value.2) })) >>= + finishObservedMaterializedDiagnostic table) + (BoundarySnapshotDiagnosticRel table) + apply relTriple_bind hbothSupported + intro leftResult rightResult hstep + rcases hstep with ⟨⟨hstep, hleftSupport⟩, hrightSupport⟩ + exact relTriple_finishJointAfterPublishedRoot adversary parameter ftsSecret q table hbound leftResult + rightResult hstep (by simpa [initial] using hleftSupport) hrightSupport + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointTopKernel.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointTopKernel.lean new file mode 100644 index 00000000..1b26e7db --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointTopKernel.lean @@ -0,0 +1,78 @@ +import SphincsSecurity.Proof.OtsProbeJointLift + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot +set_option linter.constructorNameAsVariable false + +noncomputable def retainedJointSnapshotObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + DeferredContext → Nat → (Digest × SplitHashCache) → + List PlannedProbeSnapshot → ProbComp BoundaryWitnessSnapshotOutput := + granularDetailedRetainedRestNormalizedBoundaryWitnessSnapshotObserve adversary parameter table + ftsSecret + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_jointAfterPublishedRoot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (left right : ResolvedRunResult (Digest × SplitHashCache)) + (hleftSupport : DirectWitnessResult.done left ∈ support + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext q table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hrightSupport : some (observedResolvedResult [] right) ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hclean : OrdinaryMaterializedRunEq table left right) : + RelTriple + (canonicalizeDirectBoundaryWitnessSnapshotObserve table + (retainedJointSnapshotObserve adversary parameter table ftsSecret) + left.context left.remaining left.value []) + (observedMaterializedBoundary parameter right.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨right.value.1, parameter⟩) + [] right.context.state right.remaining table right.value.2 >>= + finishObservedMaterializedDiagnostic table) + (BoundarySnapshotDiagnosticRel table) := by + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table left.context + have hleftCompletable : DeferredCompletable table canonical := + hcanonicalRun.context_le.leftCompletable + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hleftFuelPreserved : q ≤ left.remaining := + fuel_le_remaining_of_doneWitness_maskedPublishedTreeRoot table q left hleftSupport + have hrightFuelPreserved : 2 * q ≤ right.remaining := + fuel_le_remaining_of_mem_observed_maskedPublishedTreeRoot table (2 * q) right hrightSupport + have hleftRemainingUpper : left.remaining ≤ q := + remaining_le_fuel_of_doneWitness_maskedPublishedTreeRoot table q left hleftSupport + unfold canonicalizeDirectBoundaryWitnessSnapshotObserve classifyDirectBoundaryWitnessSnapshotObserve + simp only [canonical, hnotPrivate, ↓reduceDIte, hclean.left_published, ↓reduceIte, + hleftCompletable] + rw [← hclean.value_eq] + simpa [retainedJointSnapshotObserve, + granularDetailedRetainedRestNormalizedBoundaryWitnessSnapshotObserve] using + (relTriple_directJointSnapshotBoundary_diagnostic parameter left.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨left.value.1, parameter⟩) + [] [] canonical right.context left.remaining right.remaining table + left.value.2 right.value.2 q q (hbound left.value.1) + hcanonicalRun.context_le hcanonicalRun.cache_eq hcanonicalRun.revealed_eq + hcanonicalRun.values_le hcanonicalRun.left_published hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table left.context + hclean.context_le.view.leftConsistent) + (by simp [SnapshotsObservedAt]) (by omega) (by omega) (by omega)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointTopStep.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointTopStep.lean new file mode 100644 index 00000000..7ad05a55 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeJointTopStep.lean @@ -0,0 +1,88 @@ +import SphincsSecurity.Proof.OtsProbeJointTopKernel +import SphincsSecurity.Proof.OtsProbeJointRootMap + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot +set_option linter.constructorNameAsVariable false + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem relTriple_finishJointAfterPublishedRoot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (leftResult : DirectWitnessResult (Digest × SplitHashCache)) + (rightResult : Option (ObservedCleanRunResult (Digest × SplitHashCache))) + (hstep : WitnessObservedStepRel table [] leftResult rightResult) + (hleftSupport : leftResult ∈ support + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext q table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hrightSupport : rightResult ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache))) : + RelTriple + (finishDirectBoundaryWitnessSnapshotObserve + (canonicalizeDirectBoundaryWitnessSnapshotObserve table + (retainedJointSnapshotObserve adversary parameter table ftsSecret)) [] leftResult) + ((match rightResult with + | none => pure none + | some rootResult => do + let restResult ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table rootResult.value.2 + match restResult with + | none => pure none + | some restResult => pure (some + { restResult with + value := ((rootResult.value.1, restResult.value.1), restResult.value.2) })) >>= + finishObservedMaterializedDiagnostic table) + (BoundarySnapshotDiagnosticRel table) := by + have hfinish := relTriple_finishJointWitnessObservedStep (α := Digest) + (β := RetainedRestResult) parameter id ftsSecret + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩) + (retainedJointSnapshotObserve adversary parameter table ftsSecret) [] [] table leftResult + rightResult hstep (by simp [SnapshotsObservedAt]) (by + intro nextLeft nextRight hleftEq hrightEq hclean + have hleftDone : DirectWitnessResult.done nextLeft ∈ support + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext q table + (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + rw [← hleftEq] + exact hleftSupport + have hrightDone : some (observedResolvedResult [] nextRight) ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + rw [← hrightEq] + exact hrightSupport + exact relTriple_jointAfterPublishedRoot adversary parameter ftsSecret q table hbound nextLeft + nextRight hleftDone hrightDone hclean) + cases rightResult with + | none => + have hretained := relTriple_post_mono hfinish + (fun source observed hrelation => hrelation.retainRoot 0) + have hmapped := relTriple_map (f := id) (g := retainDiagnosticRoot 0) hretained + rw [id_map] at hmapped + simpa only [finishObservedMaterializedDiagnostic, map_pure, retainDiagnosticRoot, + retainObservedRoot, pure_bind] using hmapped + | some rootResult => + have hretained := relTriple_post_mono hfinish + (fun source observed hrelation => hrelation.retainRoot rootResult.value.1) + have hmapped := relTriple_map (f := id) + (g := retainDiagnosticRoot rootResult.value.1) hretained + rw [id_map] at hmapped + rw [map_retainDiagnosticRoot_bind_finish, map_retainObservedRoot_eq] at hmapped + convert hmapped using 1 + simp only [bind_assoc, id_eq] + rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeKnownRootTraceSource.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeKnownRootTraceSource.lean new file mode 100644 index 00000000..226d84a3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeKnownRootTraceSource.lean @@ -0,0 +1,177 @@ +import SphincsSecurity.Proof.OtsProbeRootSourceTrace + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option maxRecDepth 100000 in +theorem CanonicalQueryTraceRel.known_source_of_matching_history_roots + {accountingKey : SecretKey} (secretKey : SecretKey) {table : OtsSecretIndex → HashOutput} + {left : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection} + {right : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot} + (hrelation : CanonicalQueryTraceRel accountingKey.parameter table left right) + (hsecrets : accountingKey.otsSecret = fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) + (hrun : right ∈ support (runPrehitQueryTrace accountingKey secretKey computation state)) + (hfinal : right.1.2.2 = false) + (i j : Fin left.2.length) (hij : i.val < j.val) + (input : HashInput) (candidate : Probe) (lay : Layer) (tree : TreeIndex) (output : HashOutput) + (hinput : (left.2.get i).input = .inl (.inr input)) + (hcandidate : EncodingLayerRootCandidateAt accountingKey.parameter input candidate) + (hposition : candidate.coordinate = .position (layerRootPosition lay tree)) + (hvalue : (left.2.get j).context.positionValue (layerRootPosition lay tree) = some output) + (hmatch : candidate.candidate = truncateHash output) : + ∃ initialOutput, (left.2.get i).context.positionValue (layerRootPosition lay tree) = some initialOutput := by + let actualI : Fin right.2.length := ⟨i.val, i.isLt.trans_le hrelation.length_le⟩ + let actualJ : Fin right.2.length := ⟨j.val, j.isLt.trans_le hrelation.length_le⟩ + have hsource := hrelation.selection_at i + have htarget := hrelation.selection_at j + obtain ⟨_htargetInput, _htable, hinvariant, _hvisible, _hpublished, hcomputed⟩ := htarget + have hroot := hcomputed.root_settled_value hinvariant accountingKey.ftsSecret lay tree output hvalue + have hsettled : Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret + (right.2.get actualJ).state.1.cache (layerRootPosition lay tree) := by + rw [hsecrets] + exact hroot.1 + have hrootValue : honestValue (fromCache (right.2.get actualJ).state.1.cache) + accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret (layerRootPosition lay tree) = + truncateHash output := by + rw [hsecrets] + exact hroot.2 + have hfalse := prehitQueryTrace_entry_false_of_final_false accountingKey secretKey computation state right hrun hfinal + (right.2.get actualJ) (List.get_mem _ _) + have hpairs := prehitQueryTrace_pairwise_encodingSourceSettled accountingKey secretKey computation state right hrun + have hpair := hpairs.rel_get_of_lt (show actualI < actualJ from hij) + have hbefore := hpair input candidate (layerRootPosition lay tree) (hsource.1.symm.trans hinput) + hcandidate hposition hfalse hsettled (hmatch.trans hrootValue.symm) + obtain ⟨initialOutput, houtput, _⟩ := hsource.2.2.1.positionValue_of_settled hsecrets + (by trivial : IsOtsPosition (layerRootPosition lay tree)) hbefore + exact ⟨initialOutput, houtput⟩ + +set_option maxRecDepth 100000 in +theorem CanonicalQueryTraceRel.known_source_of_matching_final_root + {accountingKey : SecretKey} (secretKey : SecretKey) {table : OtsSecretIndex → HashOutput} + {left : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection} + {right : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot} + (hrelation : CanonicalQueryTraceRel accountingKey.parameter table left right) + (hsecrets : accountingKey.otsSecret = fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) + (hrun : right ∈ support (runPrehitQueryTrace accountingKey secretKey computation state)) + (hfinal : right.1.2.2 = false) + (terminal : ResolvedRunResult (α × SplitHashCache)) (hterminal : left.1 = some terminal) + (i : Fin left.2.length) + (input : HashInput) (candidate : Probe) (lay : Layer) (tree : TreeIndex) (output : HashOutput) + (hinput : (left.2.get i).input = .inl (.inr input)) + (hcandidate : EncodingLayerRootCandidateAt accountingKey.parameter input candidate) + (hposition : candidate.coordinate = .position (layerRootPosition lay tree)) + (hvalue : terminal.context.positionValue (layerRootPosition lay tree) = some output) + (hmatch : candidate.candidate = truncateHash output) : + ∃ initialOutput, (left.2.get i).context.positionValue (layerRootPosition lay tree) = some initialOutput := by + have hterminalRelation := hrelation.1 + rw [hterminal] at hterminalRelation + obtain ⟨_htable, _hvalue, hinvariant, _hvisible, _hpublished, hcomputed⟩ := hterminalRelation + have hroot := hcomputed.root_settled_value hinvariant accountingKey.ftsSecret lay tree output hvalue + have hsettled : Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret + right.1.2.1.cache (layerRootPosition lay tree) := by + rw [hsecrets] + exact hroot.1 + have hrootValue : honestValue (fromCache right.1.2.1.cache) + accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret (layerRootPosition lay tree) = + truncateHash output := by + rw [hsecrets] + exact hroot.2 + have hbefore := prehitQueryTrace_encodingSourceSettled_at_final accountingKey secretKey computation state right hrun _ (List.get_mem _ _) + input candidate (layerRootPosition lay tree) ((hrelation.selection_at i).1.symm.trans hinput) + hcandidate hposition hfinal hsettled (hmatch.trans hrootValue.symm) + obtain ⟨initialOutput, houtput, _⟩ := (hrelation.selection_at i).2.2.1.positionValue_of_settled hsecrets + (by trivial : IsOtsPosition (layerRootPosition lay tree)) hbefore + exact ⟨initialOutput, houtput⟩ + +def UnknownSourceStoredRootMatch (parameter : PublicParameter) (history : List CanonicalQuerySelection) : Prop := + ∃ (i j : Fin history.length), i.val < j.val ∧ + ∃ (input : HashInput) (candidate : Probe) (lay : Layer) (tree : TreeIndex) (output : HashOutput), + (history.get i).input = .inl (.inr input) ∧ + EncodingLayerRootCandidateAt parameter input candidate ∧ + candidate.coordinate = .position (layerRootPosition lay tree) ∧ + (history.get j).context.positionValue (layerRootPosition lay tree) = some output ∧ + candidate.candidate = truncateHash output ∧ + (history.get i).context.positionValue (layerRootPosition lay tree) = none + +def UnknownSourceFinalRootMatch (parameter : PublicParameter) + (result : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) : Prop := + ∃ terminal, result.1 = some terminal ∧ ∃ (i : Fin result.2.length), + ∃ (input : HashInput) (candidate : Probe) (lay : Layer) (tree : TreeIndex) (output : HashOutput), + (result.2.get i).input = .inl (.inr input) ∧ + EncodingLayerRootCandidateAt parameter input candidate ∧ + candidate.coordinate = .position (layerRootPosition lay tree) ∧ + terminal.context.positionValue (layerRootPosition lay tree) = some output ∧ + candidate.candidate = truncateHash output ∧ + (result.2.get i).context.positionValue (layerRootPosition lay tree) = none + +theorem CanonicalQueryTraceRel.hit_of_unknown_source_root_match + {accountingKey : SecretKey} (secretKey : SecretKey) {table : OtsSecretIndex → HashOutput} + {left : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection} + {right : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot} + (hrelation : CanonicalQueryTraceRel accountingKey.parameter table left right) + (hsecrets : accountingKey.otsSecret = fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) + (hrun : right ∈ support (runPrehitQueryTrace accountingKey secretKey computation state)) + (hmatch : UnknownSourceStoredRootMatch accountingKey.parameter left.2 ∨ UnknownSourceFinalRootMatch accountingKey.parameter left) : + right.1.2.2 = true := by + by_cases hhit : right.1.2.2 = true + · exact hhit + have hfalse := Bool.eq_false_iff.mpr hhit + rcases hmatch with hhistory | hterminal + · obtain ⟨i, j, hij, input, candidate, lay, tree, output, hinput, hcandidate, hposition, hvalue, hmatch, hnone⟩ := hhistory + obtain ⟨initialOutput, hknown⟩ := hrelation.known_source_of_matching_history_roots secretKey hsecrets + computation state hrun hfalse i j hij input candidate lay tree output hinput hcandidate hposition hvalue hmatch + rw [hnone] at hknown + contradiction + · obtain ⟨terminal, hterminal, i, input, candidate, lay, tree, output, hinput, hcandidate, hposition, hvalue, hmatch, hnone⟩ := hterminal + obtain ⟨initialOutput, hknown⟩ := hrelation.known_source_of_matching_final_root secretKey hsecrets + computation state hrun hfalse terminal hterminal i input candidate lay tree output hinput hcandidate hposition hvalue hmatch + rw [hnone] at hknown + contradiction + +theorem probEvent_unknownSourceRootMatch_le_prehit_of_trace_coupling + (accountingKey secretKey : SecretKey) (table : OtsSecretIndex → HashOutput) + (leftRun : ProbComp (Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection)) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) + (hsecrets : accountingKey.otsSecret = fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + (hcoupling : RelTriple leftRun (runPrehitQueryTrace accountingKey secretKey computation state) + (CanonicalQueryTraceRel accountingKey.parameter table)) : + Pr[fun result => UnknownSourceStoredRootMatch accountingKey.parameter result.2 ∨ + UnknownSourceFinalRootMatch accountingKey.parameter result | leftRun] ≤ + Pr[fun result => result.2.2 = true | + (simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run state] := by + rw [← runPrehitQueryTrace_projection, probEvent_map] + apply probEvent_le_of_relTriple (FtsProbeSimulation.relTriple_and_right_support hcoupling) + intro left right hrelation hmatch + exact hrelation.1.hit_of_unknown_source_root_match secretKey hsecrets computation state hrelation.2 hmatch + +theorem probEvent_canonicalUnknownSourceRootMatch_le_prehit + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (state : ViewedFullTraceState × Bool) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) state.1.cache) + (hvisible : VisibleResolvedComputationsCached parameter table context state.1.cache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + Pr[fun result => UnknownSourceStoredRootMatch parameter result.2 ∨ UnknownSourceFinalRootMatch parameter result | + runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache] ≤ + Pr[fun result => result.2.2 = true | + (simulateQ (encodingPrehitViewedAdversaryImpl secretKey secretKey) computation).run state] := by + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + dsimp only + exact probEvent_unknownSourceRootMatch_le_prehit_of_trace_coupling secretKey secretKey table _ computation state rfl + (relTriple_canonicalQueryTrace_prehitQueryTrace parameter root table ftsSecret secretKey computation context fuel cache state + hinvariant hvisible hpublished hcomputed) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveContextCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveContextCharge.lean new file mode 100644 index 00000000..9eb55c75 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveContextCharge.lean @@ -0,0 +1,185 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootQueryCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def expectedLiveNativeContextCharge + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → ENNReal := + OracleComp.construct (fun _ _ _ _ _ => 0) + (fun input _ next context fuel table cache => + if DeferredCompletable table context then + charge input context fuel cache + ∑' result, Pr[= result | runResolvedFromTable context fuel table ((impl input).run cache)] * + match result with + | none => 0 + | some result => next result.value.1 result.context result.remaining result.table result.value.2 + else 0) computation + +theorem expectedLiveNativeContextCharge_query_bind + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + expectedLiveNativeContextCharge impl charge (OracleSpec.query input >>= next) context fuel table cache = + (if DeferredCompletable table context then + charge input context fuel cache + ∑' result, Pr[= result | runResolvedFromTable context fuel table ((impl input).run cache)] * + match result with + | none => 0 + | some result => expectedLiveNativeContextCharge impl charge (next result.value.1) + result.context result.remaining result.table result.value.2 + else 0) := rfl + +theorem expectedLiveNativeContextCharge_eq_zero_of_not_completable + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hdoomed : ¬DeferredCompletable table context) : + expectedLiveNativeContextCharge impl charge computation context fuel table cache = 0 := by + induction computation using OracleComp.inductionOn with + | pure value => rfl + | query_bind input next _ => rw [expectedLiveNativeContextCharge_query_bind, if_neg hdoomed] + +theorem expectedLiveNativeContextCharge_le_actualOuterCharge + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (actualCharge : QueryCache HashSpec → HashInput → ENNReal) + (himpl : ∀ input, ReachableResolvedCouples parameter table (impl input) + (unloggedMappedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey) input)) + (hcharge : ∀ input context fuel cache actualCache, + ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache → + DeferredComputationsClosed context → + charge input context fuel cache ≤ outerHashQueryCharge actualCharge input actualCache) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + expectedLiveNativeContextCharge impl charge computation context fuel table cache ≤ + expectedOuterQueryCharge + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey) + actualCharge computation actualCache := by + let secretKey : SecretKey := ⟨parameter, root, fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + change _ ≤ expectedOuterQueryCharge secretKey actualCharge computation actualCache + induction computation using OracleComp.inductionOn generalizing context fuel cache actualCache with + | pure value => rfl + | query_bind input next ih => + rw [expectedLiveNativeContextCharge_query_bind, if_pos hinvariant.2.2.2.1, expectedOuterQueryCharge_query_bind] + apply add_le_add (hcharge input context fuel cache actualCache hinvariant hcomputed) + have hstep := FtsProbeSimulation.relTriple_and_left_support + (himpl input context fuel cache actualCache hinvariant hvisible hpublished) + (fun left => ∀ result, left = some result → DeferredComputationsClosed result.context) (by + intro left hleft result heq + subst left + exact hcomputed.of_mem_runResolved ((impl input).run cache) context fuel table result hleft) + have hcost := expected_cost_le_of_relTriple hstep + (fun left => match left with + | none => 0 + | some result => expectedLiveNativeContextCharge impl charge (next result.value.1) + result.context result.remaining result.table result.value.2) + (fun right => expectedOuterQueryCharge secretKey actualCharge (next right.1) right.2) + (fun _ => 0) (by + intro left right hrelation + simp only [add_zero] + cases left with + | none => exact bot_le + | some result => + dsimp only + rcases hrelation.1 with hclean | hdoomed + · rw [hclean.1, ← hclean.2.1] + exact ih result.value.1 result.context result.remaining result.value.2 right.2 + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 (hrelation.2 result rfl) + · rw [expectedLiveNativeContextCharge_eq_zero_of_not_completable impl charge + (next result.value.1) result.context result.remaining result.table result.value.2 (by + rw [hdoomed.1] + exact hdoomed.2.2.2)] + exact bot_le) + simpa only [mul_zero, tsum_zero, add_zero] using hcost + +/-- Select before executing a query. Ordinals count outer hashing, uniform sampling and signing requests. -/ +noncomputable def liveNativeQuerySelection + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + Nat → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp (Option CanonicalQuerySelection) := + OracleComp.construct (fun _ _ _ _ _ _ => pure none) + (fun input _ next ordinal context fuel table cache => + if DeferredCompletable table context then + match ordinal with + | 0 => pure (some ⟨input, context, fuel, table, cache⟩) + | ordinal + 1 => do + let result ← runResolvedFromTable context fuel table ((impl input).run cache) + match result with + | none => pure none + | some result => next result.value.1 ordinal result.context result.remaining result.table result.value.2 + else pure none) computation + +theorem liveNativeQuerySelection_pure + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) (value : α) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + liveNativeQuerySelection impl (pure value) ordinal context fuel table cache = pure none := rfl + +theorem liveNativeQuerySelection_query_bind + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + liveNativeQuerySelection impl (OracleSpec.query input >>= next) ordinal context fuel table cache = + if DeferredCompletable table context then + match ordinal with + | 0 => pure (some ⟨input, context, fuel, table, cache⟩) + | ordinal + 1 => do + let result ← runResolvedFromTable context fuel table ((impl input).run cache) + match result with + | none => pure none + | some result => + liveNativeQuerySelection impl (next result.value.1) + ordinal result.context result.remaining result.table result.value.2 + else pure none := rfl + +set_option maxRecDepth 100000 in +theorem tsum_liveNativeQuerySelection_charge + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ℝ≥0∞) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + (∑' ordinal, ∑' selection, + Pr[= selection | liveNativeQuerySelection impl computation ordinal context fuel table cache] * + CanonicalQuerySelection.charge charge selection) = + expectedLiveNativeContextCharge impl charge computation context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => + simp only [liveNativeQuerySelection_pure, tsum_probOutput_pure_mul, CanonicalQuerySelection.charge, tsum_zero] + rfl + | query_bind input next ih => + rw [expectedLiveNativeContextCharge_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete, tsum_eq_zero_add' ENNReal.summable] + simp only [liveNativeQuerySelection_query_bind, hcomplete, ↓reduceIte, + tsum_probOutput_pure_mul, CanonicalQuerySelection.charge] + congr 1 + simp only [tsum_probOutput_bind_mul] + rw [ENNReal.tsum_comm] + apply tsum_congr + intro result + rw [ENNReal.tsum_mul_left] + congr 1 + cases result with + | none => simp only [tsum_probOutput_pure_mul, tsum_zero] + | some result => exact ih result.value.1 result.context result.remaining result.table result.value.2 + · simp only [liveNativeQuerySelection_query_bind, hcomplete, ↓reduceIte, + tsum_probOutput_pure_mul, CanonicalQuerySelection.charge, tsum_zero] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveGameCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveGameCharge.lean new file mode 100644 index 00000000..58949c88 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveGameCharge.lean @@ -0,0 +1,153 @@ +import SphincsSecurity.Proof.OtsProbeLiveStartCounting +import SphincsSecurity.Proof.OtsProbeLiveSampledReserve + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +noncomputable def nativeChronologicalRetainedComputation + (adversary : Adversary) (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + OracleComp (LazyRevealProbe.World Coordinate) (RetainedRestResult × SplitHashCache) := do + let (root, cache) ← maskedPublishedTreeRoot.run emptySplitHashCache + (simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).run cache + +theorem expectedLiveNativeProbeCharge_root_eq_zero + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + expectedLiveResolvedQueryCharge nativeProbeQueryCharge (maskedPublishedTreeRoot.run cache) context fuel table = 0 := by + have hraw : expectedResolvedQueryCharge nativeProbeQueryCharge (maskedPublishedTreeRoot.run cache) context fuel table ≤ (0 : ENNReal) := by + simpa only [Nat.cast_zero] using expectedResolvedProbeCharge_le_probeBound _ 0 context fuel table (maskedPublishedTreeRoot_probeFree cache) + exact le_antisymm ((expectedLiveResolvedQueryCharge_le_raw nativeProbeQueryCharge _ context fuel table).trans hraw) zero_le + +theorem nativeChronologicalRetained_joint_charge_le_afterTable + (adversary : Adversary) (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + (expectedLiveResolvedQueryCharge chainStartProbeQueryCharge (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } fuel table + + expectedLiveResolvedQueryCharge structuralProbeQueryCharge (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } fuel table) * (4 / 3 : ENNReal) ≤ + liveOtsChargeAfterTable adversary parameter table ftsSecret fuel := by + rw [expectedLiveChainStart_add_structural_eq_probeCharge] + unfold nativeChronologicalRetainedComputation + rw [expectedLiveResolvedQueryCharge_bind _ _ _ _ fuel table DeferredContext.valid_empty.valuesConsistent (startTableAgrees_empty table), + expectedLiveNativeProbeCharge_root_eq_zero, zero_add, ← ENNReal.tsum_mul_right] + unfold liveOtsChargeAfterTable + apply ENNReal.tsum_le_tsum + intro result + by_cases hresult : result ∈ support (runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) + · cases result with + | none => simp [liveResolvedContinuationCharge] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ _ fuel table result + DeferredContext.valid_empty.valuesConsistent (startTableAgrees_empty table) hresult + simp only [liveResolvedContinuationCharge, hcore.1, mul_assoc] + apply mul_le_mul' le_rfl + rw [expectedLiveNativeOuterCharge_mul] + apply mul_le_mul' _ le_rfl + have hlocal := chronological_liveChainStart_add_structural_le_liveOuterCharge parameter result.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) result.context result.remaining table result.value.2 + hcore.2.1 hcore.2.2 + rw [expectedLiveChainStart_add_structural_eq_probeCharge] at hlocal + exact hlocal + · simp [probOutput_eq_zero_of_not_mem_support hresult] + +theorem nativeChronologicalRetained_startHits_add_structuralCharge_le_afterTable + (adversary : Adversary) (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + (∑ ordinal ∈ Finset.range q, Pr[LiveUnresolvedStartHit nativeCutCandidate | + sampledNativeProbeCut (nativeChronologicalRetainedComputation adversary parameter ftsSecret) fuel ordinal]) + + (∑' table, Pr[= table | sampleOtsHashTable] * + expectedLiveResolvedQueryCharge structuralProbeQueryCharge (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } fuel table) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) ≤ + (∑' table, Pr[= table | sampleOtsHashTable] * liveOtsChargeAfterTable adversary parameter table ftsSecret fuel) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply (add_le_add (sum_sampledNativeProbeCut_unresolvedStart_le_expectedChainStartCharge + (nativeChronologicalRetainedComputation adversary parameter ftsSecret) fuel q hq) le_rfl).trans + rw [← add_mul, ← ENNReal.tsum_add] + simp only [← mul_add] + rw [← mul_assoc] + apply mul_le_mul' _ le_rfl + rw [← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro table + rw [mul_assoc] + exact mul_le_mul' le_rfl (nativeChronologicalRetained_joint_charge_le_afterTable adversary parameter ftsSecret fuel table) + +noncomputable def sampledNativeStartRisk (adversary : Adversary) (fuel q : Nat) : ENNReal := + ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + ∑ ordinal ∈ Finset.range q, Pr[LiveUnresolvedStartHit nativeCutCandidate | + sampledNativeProbeCut (nativeChronologicalRetainedComputation adversary parameter ftsSecret) fuel ordinal] + +noncomputable def sampledNativeStructuralCharge (adversary : Adversary) (fuel : Nat) : ENNReal := + ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + ∑' table, Pr[= table | sampleOtsHashTable] * + expectedLiveResolvedQueryCharge structuralProbeQueryCharge (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } fuel table + +theorem sampledNativeStartRisk_add_structuralCharge_le_liveOtsCharge + (adversary : Adversary) (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + sampledNativeStartRisk adversary fuel q + sampledNativeStructuralCharge adversary fuel * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) ≤ + sampledLiveOtsCharge adversary fuel * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let factor : ENNReal := ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + have hbound := fun parameter ftsSecret => nativeChronologicalRetained_startHits_add_structuralCharge_le_afterTable + adversary parameter ftsSecret fuel q hq + calc + _ = ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + ((∑ ordinal ∈ Finset.range q, Pr[LiveUnresolvedStartHit nativeCutCandidate | + sampledNativeProbeCut (nativeChronologicalRetainedComputation adversary parameter ftsSecret) fuel ordinal]) + + (∑' table, Pr[= table | sampleOtsHashTable] * + expectedLiveResolvedQueryCharge structuralProbeQueryCharge (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } fuel table) * ((4 / 3 : ENNReal) * factor)) := by + simp only [sampledNativeStartRisk, sampledNativeStructuralCharge, factor, mul_add, ENNReal.tsum_add, + ← mul_assoc, ENNReal.tsum_mul_right] + _ ≤ ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + ((∑' table, Pr[= table | sampleOtsHashTable] * liveOtsChargeAfterTable adversary parameter table ftsSecret fuel) * factor) := by + apply ENNReal.tsum_le_tsum + intro parameter + apply mul_le_mul' le_rfl + apply ENNReal.tsum_le_tsum + intro ftsSecret + exact mul_le_mul' le_rfl (hbound parameter ftsSecret) + _ = _ := by + unfold sampledLiveOtsCharge + simp only [← ENNReal.tsum_mul_left, ← ENNReal.tsum_mul_right, mul_assoc] + apply tsum_congr + intro parameter + rw [ENNReal.tsum_comm] + apply tsum_congr + intro table + apply tsum_congr + intro ftsSecret + ring + +theorem sampledNativeStartRisk_add_structuralCharge_le_directCharge + (adversary : Adversary) (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + sampledNativeStartRisk adversary fuel q + sampledNativeStructuralCharge adversary fuel * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) ≤ + sampledQueryCharge (fun secretKey => directOtsQueryCharge secretKey.parameter) adversary * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + (sampledNativeStartRisk_add_structuralCharge_le_liveOtsCharge adversary fuel q hq).trans + (mul_le_mul' (sampledLiveOtsCharge_le_directCharge adversary fuel) le_rfl) + +theorem sampledNativeStartRisk_add_structuralCharge_add_remaining_le_refinedReserve + (adversary : Adversary) (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + (sampledNativeStartRisk adversary fuel q + sampledNativeStructuralCharge adversary fuel * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹)) + + sampledQueryCharge remainingOtsQueryReserve adversary * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ ≤ + sampledQueryCharge otsOpeningRefinedQueryReserve adversary * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply (add_le_add (sampledNativeStartRisk_add_structuralCharge_le_directCharge adversary fuel q hq) le_rfl).trans_eq + rw [← add_mul, sampled_direct_add_remaining_otsQueryReserve] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveHashCut.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveHashCut.lean new file mode 100644 index 00000000..4a120f0a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveHashCut.lean @@ -0,0 +1,102 @@ +import SphincsSecurity.Proof.OtsProbeLiveHashSelection +import SphincsSecurity.Proof.OuterHashQueryCut + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def liveNativeHashCutSelection : + Option (ResolvedRunResult (OuterQueryCut α × SplitHashCache)) → Option CanonicalQuerySelection + | none => none + | some result => + if DeferredCompletable result.table result.context then + match result.value.1.input? with + | none => none + | some input => some ⟨input, result.context, result.remaining, result.table, result.value.2⟩ + else none + +theorem evalDist_liveNativeHashCutSelection_eq_none_of_not_completable + (computation : OracleComp (LazyRevealProbe.World Coordinate) (OuterQueryCut α × SplitHashCache)) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) : + evalDist (liveNativeHashCutSelection <$> runResolvedFromTable context fuel table computation) = + evalDist (pure none : ProbComp (Option CanonicalQuerySelection)) := by + rw [map_eq_bind_pure_comp] + calc + _ = evalDist (runResolvedFromTable context fuel table computation >>= fun _ => pure none) := by + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable computation context fuel table result hconsistent hstarts hresult + have hstill := not_deferredCompletable_of_mem_runResolvedFromTable computation context fuel table result + hconsistent hstarts hresult hdoomed + simp [liveNativeHashCutSelection, hcore.1, hstill] + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails _ (by simp [runResolvedFromTable]) (pure none) + +theorem evalDist_liveNativeHashQuerySelection_eq_cut + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + evalDist (liveNativeHashQuerySelection impl computation ordinal context fuel table cache) = + evalDist (liveNativeHashCutSelection <$> runResolvedFromTable context fuel table + ((simulateQ impl (outerHashQueryCutAt computation ordinal)).run cache)) := by + induction computation using OracleComp.inductionOn generalizing ordinal context fuel table cache with + | pure value => + by_cases hcomplete : DeferredCompletable table context <;> + simp [liveNativeHashQuerySelection_pure, outerHashQueryCutAt, runResolvedFromTable, + liveNativeHashCutSelection, OuterQueryCut.input?, hcomplete] + | query_bind input next ih => + by_cases hcomplete : DeferredCompletable table context + · rw [liveNativeHashQuerySelection_query_bind, if_pos hcomplete, outerHashQueryCutAt_query_bind] + have hcontinue (remaining : Nat) : + evalDist (do + let result ← runResolvedFromTable context fuel table ((impl input).run cache) + match result with + | none => pure none + | some result => + liveNativeHashQuerySelection impl (next result.value.1) remaining + result.context result.remaining result.table result.value.2) = + evalDist (liveNativeHashCutSelection <$> runResolvedFromTable context fuel table + ((simulateQ impl ((liftM (OracleSpec.query input) : OracleComp (OracleWorld + SigningSpec) _) >>= + fun output => outerHashQueryCutAt (next output) remaining)).run cache)) := by + simp only [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, + runResolvedFromTable_bind, map_bind] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => simp [liveNativeHashCutSelection] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable ((impl input).run cache) context fuel table result + hconsistent hstarts hresult + exact ih result.value.1 remaining result.context result.remaining result.table result.value.2 hcore.2.1 + (by rw [hcore.1]; exact hcore.2.2) + by_cases hhash : IsOuterHash input + · rw [if_pos hhash] + cases ordinal with + | zero => + simp [hhash, simulateQ_pure, StateT.run_pure, runResolvedFromTable, + liveNativeHashCutSelection, OuterQueryCut.input?, hcomplete] + | succ ordinal => + simp only [hhash, Nat.add_eq_zero_iff, Nat.one_ne_zero, and_false, ↓reduceIte, + Nat.add_sub_cancel] + convert hcontinue ordinal using 1 + apply evalDist_bind_congr + intro result _ + cases result <;> rfl + · rw [if_neg hhash] + simp only [hhash, false_and, ↓reduceIte] + convert hcontinue ordinal using 1 + apply evalDist_bind_congr + intro result _ + cases result <;> rfl + · rw [liveNativeHashQuerySelection_query_bind, if_neg hcomplete] + exact (evalDist_liveNativeHashCutSelection_eq_none_of_not_completable _ context fuel table hconsistent hstarts hcomplete).symm + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveHashSelection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveHashSelection.lean new file mode 100644 index 00000000..1d2591cc --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveHashSelection.lean @@ -0,0 +1,121 @@ +import SphincsSecurity.Proof.OtsProbeLiveKnownRootCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def liveNativeHashQuerySelection + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + Nat → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp (Option CanonicalQuerySelection) := + OracleComp.construct (fun _ _ _ _ _ _ => pure none) + (fun input _ next ordinal context fuel table cache => + if DeferredCompletable table context then + if IsOuterHash input ∧ ordinal = 0 then pure (some ⟨input, context, fuel, table, cache⟩) + else do + let result ← runResolvedFromTable context fuel table ((impl input).run cache) + match result with + | none => pure none + | some result => + next result.value.1 (if IsOuterHash input then ordinal - 1 else ordinal) + result.context result.remaining result.table result.value.2 + else pure none) computation + +theorem liveNativeHashQuerySelection_pure + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (value : α) (ordinal : Nat) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + liveNativeHashQuerySelection impl (pure value) ordinal context fuel table cache = pure none := rfl + +theorem liveNativeHashQuerySelection_query_bind + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + liveNativeHashQuerySelection impl (OracleSpec.query input >>= next) ordinal context fuel table cache = + if DeferredCompletable table context then + if IsOuterHash input ∧ ordinal = 0 then pure (some ⟨input, context, fuel, table, cache⟩) + else do + let result ← runResolvedFromTable context fuel table ((impl input).run cache) + match result with + | none => pure none + | some result => + liveNativeHashQuerySelection impl (next result.value.1) + (if IsOuterHash input then ordinal - 1 else ordinal) result.context result.remaining result.table result.value.2 + else pure none := rfl + +theorem tsum_liveNativeHashQuerySelection_charge + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (hzero : ∀ input context fuel cache, ¬IsOuterHash input → charge input context fuel cache = 0) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + (∑' ordinal, ∑' selection, + Pr[= selection | liveNativeHashQuerySelection impl computation ordinal context fuel table cache] * + CanonicalQuerySelection.charge charge selection) = + expectedLiveNativeContextCharge impl charge computation context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => + simp only [liveNativeHashQuerySelection_pure, tsum_probOutput_pure_mul, CanonicalQuerySelection.charge, tsum_zero] + rfl + | query_bind input next ih => + rw [expectedLiveNativeContextCharge_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete] + by_cases hhash : IsOuterHash input + · rw [tsum_eq_zero_add' ENNReal.summable] + simp only [liveNativeHashQuerySelection_query_bind, hcomplete, hhash, true_and, ↓reduceIte, + Nat.add_eq_zero_iff, Nat.one_ne_zero, and_false, Nat.add_sub_cancel, + tsum_probOutput_pure_mul, CanonicalQuerySelection.charge] + congr 1 + simp only [tsum_probOutput_bind_mul] + rw [ENNReal.tsum_comm] + apply tsum_congr + intro result + rw [ENNReal.tsum_mul_left] + congr 1 + cases result with + | none => simp only [tsum_probOutput_pure_mul, tsum_zero] + | some result => exact ih result.value.1 result.context result.remaining result.table result.value.2 + · rw [hzero input context fuel cache hhash, zero_add] + simp only [liveNativeHashQuerySelection_query_bind, hcomplete, hhash, false_and, ↓reduceIte, + tsum_probOutput_bind_mul] + rw [ENNReal.tsum_comm] + apply tsum_congr + intro result + rw [ENNReal.tsum_mul_left] + congr 1 + cases result with + | none => simp only [tsum_probOutput_pure_mul, CanonicalQuerySelection.charge, tsum_zero] + | some result => exact ih result.value.1 result.context result.remaining result.table result.value.2 + · simp only [liveNativeHashQuerySelection_query_bind, hcomplete, ↓reduceIte, + tsum_probOutput_pure_mul, CanonicalQuerySelection.charge, tsum_zero] + +theorem knownEncodingRootOuterCharge_eq_zero_of_not_hash + (parameter : PublicParameter) (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (hnot : ¬IsOuterHash input) : + knownEncodingRootOuterCharge parameter input context fuel cache = 0 := by + cases input with + | inl input => cases input <;> simp_all [IsOuterHash, knownEncodingRootOuterCharge] + | inr message => rfl + +theorem tsum_knownEncodingRootHashSelection_probability_eq_charge + (parameter : PublicParameter) + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + (∑' ordinal, Pr[KnownHiddenEncodingRootSelection parameter | + liveNativeHashQuerySelection impl computation ordinal context fuel table cache]) * (4 / 3 : ENNReal) = + expectedLiveNativeContextCharge impl (knownEncodingRootOuterCharge parameter) computation context fuel table cache := by + rw [← tsum_liveNativeHashQuerySelection_charge impl _ (knownEncodingRootOuterCharge_eq_zero_of_not_hash parameter), + ← ENNReal.tsum_mul_right] + apply tsum_congr + intro ordinal + exact (expected_knownEncodingRootSelection_charge_eq_probability parameter _).symm + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveJointCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveJointCharge.lean new file mode 100644 index 00000000..c5073e12 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveJointCharge.lean @@ -0,0 +1,121 @@ +import SphincsSecurity.Proof.OtsProbeLiveNativeComposition + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def nativeProbeQueryCharge (input : LazyRevealProbe.Query Coordinate) : ENNReal := + if LazyRevealProbe.IsProbe input then 1 else 0 + +noncomputable def chainStartProbeQueryCharge : LazyRevealProbe.Query Coordinate → ENNReal + | .probe (.chainStart _ _ _ _) _ => 1 + | _ => 0 + +theorem chainStart_add_structural_probeQueryCharge (input : LazyRevealProbe.Query Coordinate) : + chainStartProbeQueryCharge input + structuralProbeQueryCharge input = nativeProbeQueryCharge input := by + cases input with + | probe coordinate digest => + cases coordinate <;> simp [chainStartProbeQueryCharge, structuralProbeQueryCharge, nativeProbeQueryCharge, LazyRevealProbe.IsProbe] + | _ => simp [chainStartProbeQueryCharge, structuralProbeQueryCharge, nativeProbeQueryCharge, LazyRevealProbe.IsProbe] + +theorem expectedLiveResolvedQueryCharge_add + (left right : LazyRevealProbe.Query Coordinate → ENNReal) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedLiveResolvedQueryCharge (fun input => left input + right input) computation context fuel table = + expectedLiveResolvedQueryCharge left computation context fuel table + expectedLiveResolvedQueryCharge right computation context fuel table := by + have hsum := expectedLiveResolvedQueryCharge_finset_sum (Finset.univ : Finset Bool) + (fun index => if index then left else right) computation context fuel table + simpa [Fintype.sum_bool, add_comm] using hsum + +theorem expectedLiveChainStart_add_structural_eq_probeCharge + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedLiveResolvedQueryCharge chainStartProbeQueryCharge computation context fuel table + + expectedLiveResolvedQueryCharge structuralProbeQueryCharge computation context fuel table = + expectedLiveResolvedQueryCharge nativeProbeQueryCharge computation context fuel table := by + rw [← expectedLiveResolvedQueryCharge_add] + simp only [chainStart_add_structural_probeQueryCharge] + +theorem expectedResolvedProbeCharge_le_probeBound + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (bound : Nat) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) : + expectedResolvedQueryCharge nativeProbeQueryCharge computation context fuel table ≤ bound := + expectedResolvedQueryCharge_le_queryBound nativeProbeQueryCharge LazyRevealProbe.IsProbe (fun _ => le_rfl) + computation bound context fuel table hbound + +theorem chronologicalAdversaryImpl_expectedResolvedProbeCharge_le + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (cache : SplitHashCache) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedResolvedQueryCharge nativeProbeQueryCharge ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) + context fuel table ≤ otsOuterQueryCharge parameter input := by + cases input with + | inl query => + cases query with + | inl n => + change expectedResolvedQueryCharge nativeProbeQueryCharge ((splitUniformImpl n).run cache) context fuel table ≤ 0 + simpa only [Nat.cast_zero] using expectedResolvedProbeCharge_le_probeBound _ 0 context fuel table (splitUniformImpl_probeFree n cache) + | inr input => + change expectedResolvedQueryCharge nativeProbeQueryCharge ((probingHashQuery parameter input).run cache) context fuel table ≤ otsHashInputCharge parameter input + unfold otsHashInputCharge + split_ifs with hots + · simpa only [Nat.cast_one] using expectedResolvedProbeCharge_le_probeBound _ 1 context fuel table (probingHashQuery_run_isProbeBound parameter input cache) + · rw [probingHashQuery_eq_split_of_not_atOtsPosition parameter input hots] + simpa only [Nat.cast_zero] using expectedResolvedProbeCharge_le_probeBound _ 0 context fuel table (splitHashQuery_probeFree _ cache) + | inr message => + change expectedResolvedQueryCharge nativeProbeQueryCharge ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache) context fuel table ≤ 0 + simpa only [Nat.cast_zero] using expectedResolvedProbeCharge_le_probeBound _ 0 context fuel table + (maskedPublishedChronologicalSign_probeFree parameter root ftsSecret message cache) + +theorem simulateQ_expectedLiveQueryCharge_le_liveOuterCharge + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (charge : LazyRevealProbe.Query Coordinate → ENNReal) (outerCharge : (OracleWorld + SigningSpec).Domain → ENNReal) + (hstep : ∀ input cache context fuel table, + expectedLiveResolvedQueryCharge charge ((impl input).run cache) context fuel table ≤ outerCharge input) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + expectedLiveResolvedQueryCharge charge ((simulateQ impl computation).run cache) context fuel table ≤ + expectedLiveNativeOuterCharge impl outerCharge computation context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => simp [expectedLiveResolvedQueryCharge, expectedLiveNativeOuterCharge] + | query_bind input next ih => + by_cases hcomplete : DeferredCompletable table context + · rw [simulateQ_query_bind, StateT.run_bind, + expectedLiveResolvedQueryCharge_bind _ _ _ context fuel table hconsistent hstarts, + expectedLiveNativeOuterCharge_query_bind, if_pos hcomplete] + apply add_le_add (hstep input cache context fuel table) + apply ENNReal.tsum_le_tsum + intro result + by_cases hresult : result ∈ support (runResolvedFromTable context fuel table ((impl input).run cache)) + · cases result with + | none => rfl + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table result hconsistent hstarts hresult + exact mul_le_mul' le_rfl (ih result.value.1 result.context result.remaining result.table result.value.2 hcore.2.1 (hcore.1 ▸ hcore.2.2)) + · simp [probOutput_eq_zero_of_not_mem_support hresult] + · rw [expectedLiveResolvedQueryCharge_eq_zero_of_not_completable _ _ context fuel table hcomplete, + expectedLiveNativeOuterCharge_eq_zero_of_not_completable _ _ _ context fuel table cache hcomplete] + +theorem chronological_liveChainStart_add_structural_le_liveOuterCharge + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + expectedLiveResolvedQueryCharge chainStartProbeQueryCharge + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) context fuel table + + expectedLiveResolvedQueryCharge structuralProbeQueryCharge + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) context fuel table ≤ + expectedLiveNativeOuterCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (otsOuterQueryCharge parameter) computation context fuel table cache := by + rw [expectedLiveChainStart_add_structural_eq_probeCharge] + apply simulateQ_expectedLiveQueryCharge_le_liveOuterCharge _ _ _ _ computation context fuel table cache hconsistent hstarts + intro input nextCache nextContext remaining nextTable + exact (expectedLiveResolvedQueryCharge_le_raw nativeProbeQueryCharge _ nextContext remaining nextTable).trans + (chronologicalAdversaryImpl_expectedResolvedProbeCharge_le parameter root ftsSecret input nextCache nextContext remaining nextTable) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveJointReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveJointReserve.lean new file mode 100644 index 00000000..79defd56 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveJointReserve.lean @@ -0,0 +1,154 @@ +import SphincsSecurity.Proof.OtsProbeLiveJointCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def directOtsQueryCharge (parameter : PublicParameter) (_cache : QueryCache HashSpec) (input : HashInput) : ENNReal := + otsHashInputCharge parameter input * (4 / 3) + +noncomputable def remainingOtsQueryReserve (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) : ENNReal := + otsOpeningRefinedQueryReserve secretKey cache input - directOtsQueryCharge secretKey.parameter cache input + +theorem directOtsQueryCharge_le_refinedReserve (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) : + directOtsQueryCharge secretKey.parameter cache input ≤ otsOpeningRefinedQueryReserve secretKey cache input := by + exact weightedOtsOuterQueryCharge_le_refinedReserve secretKey (.inl (.inr input)) cache + +theorem direct_add_remaining_otsQueryReserve (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) : + directOtsQueryCharge secretKey.parameter cache input + remainingOtsQueryReserve secretKey cache input = + otsOpeningRefinedQueryReserve secretKey cache input := by + unfold remainingOtsQueryReserve + exact add_tsub_cancel_of_le (directOtsQueryCharge_le_refinedReserve secretKey cache input) + +theorem remainingOtsQueryReserve_eq_refined_of_not_ots + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) + (hnot : ¬∃ position : Position, IsOtsPosition position ∧ AtPosition secretKey.parameter input position) : + remainingOtsQueryReserve secretKey cache input = otsOpeningRefinedQueryReserve secretKey cache input := by + simp [remainingOtsQueryReserve, directOtsQueryCharge, otsHashInputCharge, hnot] + +theorem expected_direct_add_remaining_otsQueryReserve + (secretKey : SecretKey) (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) : + expectedQueryCharge (directOtsQueryCharge secretKey.parameter) computation cache + + expectedQueryCharge (remainingOtsQueryReserve secretKey) computation cache = + expectedQueryCharge (otsOpeningRefinedQueryReserve secretKey) computation cache := by + rw [← expectedQueryCharge_add] + simp only [direct_add_remaining_otsQueryReserve] + +theorem sampled_direct_add_remaining_otsQueryReserve (adversary : Adversary) : + sampledQueryCharge (fun secretKey => directOtsQueryCharge secretKey.parameter) adversary + + sampledQueryCharge remainingOtsQueryReserve adversary = sampledQueryCharge otsOpeningRefinedQueryReserve adversary := by + rw [← sampledQueryCharge_add] + simp only [direct_add_remaining_otsQueryReserve] + +theorem otsOuterQueryCharge_hash (parameter : PublicParameter) (input : HashInput) : + otsOuterQueryCharge parameter (.inl (.inr input)) = otsHashInputCharge parameter input := rfl + +theorem outerHashQueryCharge_hash (charge : QueryCache HashSpec → HashInput → ENNReal) + (input : HashInput) (cache : QueryCache HashSpec) : + outerHashQueryCharge charge (.inl (.inr input)) cache = charge cache input := rfl + +theorem directOtsQueryCharge_eq (parameter : PublicParameter) (cache : QueryCache HashSpec) (input : HashInput) : + directOtsQueryCharge parameter cache input = otsHashInputCharge parameter input * (4 / 3 : ENNReal) := rfl + +theorem weightedOtsOuterQueryCharge_le_directCharge (parameter : PublicParameter) + (input : (OracleWorld + SigningSpec).Domain) (cache : QueryCache HashSpec) : + otsOuterQueryCharge parameter input * (4 / 3 : ENNReal) ≤ + outerHashQueryCharge (directOtsQueryCharge parameter) input cache := by + cases input with + | inl query => + cases query with + | inl n => exact (zero_mul (4 / 3 : ENNReal)).le + | inr input => rw [otsOuterQueryCharge_hash, outerHashQueryCharge_hash, directOtsQueryCharge_eq] + | inr message => exact (zero_mul (4 / 3 : ENNReal)).le + +theorem expectedLiveChronologicalOtsCharge_le_directCharge + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) : + expectedLiveNativeOuterCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (fun input => otsOuterQueryCharge parameter input * (4 / 3 : ENNReal)) computation context fuel table cache ≤ + expectedQueryCharge (directOtsQueryCharge parameter) + (simulateQ (expandedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey)) computation) actualCache := by + let secretKey : SecretKey := ⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + have hbound : expectedLiveNativeOuterCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (fun input => otsOuterQueryCharge parameter input * (4 / 3 : ENNReal)) computation context fuel table cache ≤ + expectedOuterQueryCharge secretKey (directOtsQueryCharge parameter) computation actualCache := by + exact expectedLiveNativeOuterCharge_le_actualOuterCharge parameter root table ftsSecret + (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (fun input => otsOuterQueryCharge parameter input * (4 / 3 : ENNReal)) + (directOtsQueryCharge parameter) + (reachableResolvedCouples_chronologicalNative_concrete parameter root table ftsSecret) + (weightedOtsOuterQueryCharge_le_directCharge parameter) + computation context fuel cache actualCache hinvariant hvisible hpublished + exact hbound.trans (expectedOuterQueryCharge_le_expanded secretKey (directOtsQueryCharge parameter) computation actualCache) + +theorem expectedLiveChronologicalOtsCount_mul_le_directCharge + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) : + expectedLiveNativeOuterCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (otsOuterQueryCharge parameter) computation context fuel table cache * (4 / 3 : ENNReal) ≤ + expectedQueryCharge (directOtsQueryCharge parameter) + (simulateQ (expandedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey)) computation) actualCache := by + rw [← expectedLiveNativeOuterCharge_mul] + exact expectedLiveChronologicalOtsCharge_le_directCharge parameter root table ftsSecret computation context fuel cache actualCache + hinvariant hvisible hpublished + +theorem liveChainStartCharge_add_structuralHits_le_directCharge + (targets : Finset Position) (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) + (hensured : ∀ target ∈ targets, .position target ∈ context.state.ensured) + (hstate : ∀ target ∈ targets, context.state.values (.position target) = none) + (hvalue : ∀ target ∈ targets, context.values target = none) + (hhidden : ∀ target ∈ targets, .position target ∉ context.state.revealed) + (hcard : ∀ target ∈ targets, (context.state.pendingAt (.position target)).card + q ≤ 2 ^ 126) : + expectedLiveResolvedQueryCharge chainStartProbeQueryCharge + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) context fuel table * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + + (∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) ordinal)]) ≤ + expectedQueryCharge (directOtsQueryCharge parameter) + (simulateQ (expandedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey)) computation) + actualCache * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let native := ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) + let count := expectedLiveNativeOuterCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (otsOuterQueryCharge parameter) computation context fuel table cache + calc + _ ≤ expectedLiveResolvedQueryCharge chainStartProbeQueryCharge native context fuel table * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + + expectedLiveResolvedQueryCharge structuralProbeQueryCharge native context fuel table * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := + add_le_add le_rfl (sum_targets_privateResolvedRawCandidate_hit_le_expectedLiveStructuralCharge targets native q context fuel table + hinvariant.2.1 hinvariant.2.2.2.1 hensured hstate hvalue hhidden hcard) + _ = (expectedLiveResolvedQueryCharge chainStartProbeQueryCharge native context fuel table + + expectedLiveResolvedQueryCharge structuralProbeQueryCharge native context fuel table) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := (add_mul _ _ _).symm + _ ≤ count * ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := + mul_le_mul' (chronological_liveChainStart_add_structural_le_liveOuterCharge parameter root ftsSecret computation context fuel table cache + hinvariant.2.1.valuesConsistent hinvariant.2.2.1) le_rfl + _ = (count * (4 / 3 : ENNReal)) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := (mul_assoc _ _ _).symm + _ ≤ _ := mul_le_mul' (expectedLiveChronologicalOtsCount_mul_le_directCharge parameter root table ftsSecret computation + context fuel cache actualCache hinvariant hvisible hpublished) le_rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveKnownRootCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveKnownRootCharge.lean new file mode 100644 index 00000000..cf239ca7 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveKnownRootCharge.lean @@ -0,0 +1,123 @@ +import SphincsSecurity.Proof.OtsProbeLiveContextCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def KnownHiddenEncodingRootQuery (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) : Prop := + ∃ (candidate : Probe) (target : Position) (output : HashOutput), + EncodingLayerRootCandidateAt parameter input candidate ∧ candidate.coordinate = .position target ∧ + context.positionValue target = some output ∧ .position target ∉ context.state.revealed + +noncomputable def knownEncodingRootOuterCharge (parameter : PublicParameter) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (_fuel : Nat) (_cache : SplitHashCache) : ENNReal := + match input with + | .inl (.inr input) => if KnownHiddenEncodingRootQuery parameter input context then 4 / 3 else 0 + | _ => 0 + +theorem knownEncodingRootOuterCharge_le_actualRootCharge + (secretKey : SecretKey) (table : OtsSecretIndex → HashOutput) + (hsecrets : secretKey.otsSecret = fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant secretKey.parameter table context (ordinaryQueryCache cache) actualCache) + (hcomputed : DeferredComputationsClosed context) : + knownEncodingRootOuterCharge secretKey.parameter input context fuel cache ≤ + outerHashQueryCharge (rootEncodingQueryCharge secretKey) input actualCache := by + cases input with + | inl query => + cases query with + | inl n => simp [knownEncodingRootOuterCharge, outerHashQueryCharge, hashQueryCharge] + | inr input => + rw [outerHashQueryCharge_hash] + simp only [knownEncodingRootOuterCharge] + split_ifs with hknown + · obtain ⟨candidate, target, output, hcandidate, hposition, hvalue, _hhidden⟩ := hknown + rw [hcomputed.rootEncodingQueryCharge_eq_four_thirds hinvariant hsecrets hcandidate hposition hvalue] + · exact zero_le + | inr message => simp [knownEncodingRootOuterCharge, outerHashQueryCharge] + +theorem expectedLiveKnownRootCharge_le_actualRootCharge + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (knownEncodingRootOuterCharge parameter) computation context fuel table cache ≤ + expectedQueryCharge + (rootEncodingQueryCharge + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey)) + (simulateQ (expandedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey)) computation) actualCache := by + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + have hbound : expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (knownEncodingRootOuterCharge parameter) computation context fuel table cache ≤ + expectedOuterQueryCharge secretKey (rootEncodingQueryCharge secretKey) computation actualCache := + expectedLiveNativeContextCharge_le_actualOuterCharge parameter root table ftsSecret + (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) (knownEncodingRootOuterCharge parameter) + (rootEncodingQueryCharge secretKey) + (reachableResolvedCouples_chronologicalNative_concrete parameter root table ftsSecret) + (knownEncodingRootOuterCharge_le_actualRootCharge secretKey table rfl) + computation context fuel cache actualCache hinvariant hvisible hpublished hcomputed + exact hbound.trans (expectedOuterQueryCharge_le_expanded secretKey (rootEncodingQueryCharge secretKey) computation actualCache) + +def KnownHiddenEncodingRootSelection (parameter : PublicParameter) : Option CanonicalQuerySelection → Prop + | none => False + | some selection => match selection.input with + | .inl (.inr input) => KnownHiddenEncodingRootQuery parameter input selection.context + | _ => False + +theorem knownEncodingRootSelection_charge_eq_indicator + (parameter : PublicParameter) (selection : Option CanonicalQuerySelection) : + CanonicalQuerySelection.charge (knownEncodingRootOuterCharge parameter) selection = + if KnownHiddenEncodingRootSelection parameter selection then (4 / 3 : ENNReal) else 0 := by + cases selection with + | none => simp [CanonicalQuerySelection.charge, KnownHiddenEncodingRootSelection] + | some selection => + rcases selection with ⟨input, context, fuel, table, cache⟩ + cases input with + | inl query => cases query <;> simp [CanonicalQuerySelection.charge, knownEncodingRootOuterCharge, KnownHiddenEncodingRootSelection] + | inr message => simp [CanonicalQuerySelection.charge, knownEncodingRootOuterCharge, KnownHiddenEncodingRootSelection] + +theorem expected_knownEncodingRootSelection_charge_eq_probability + (parameter : PublicParameter) (run : ProbComp (Option CanonicalQuerySelection)) : + (∑' selection, Pr[= selection | run] * CanonicalQuerySelection.charge (knownEncodingRootOuterCharge parameter) selection) = + Pr[KnownHiddenEncodingRootSelection parameter | run] * (4 / 3 : ENNReal) := by + rw [probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_right] + apply tsum_congr + intro selection + rw [knownEncodingRootSelection_charge_eq_indicator] + split_ifs <;> simp + +theorem tsum_knownEncodingRootSelection_probability_eq_charge + (parameter : PublicParameter) + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + (∑' ordinal, Pr[KnownHiddenEncodingRootSelection parameter | + liveNativeQuerySelection impl computation ordinal context fuel table cache]) * (4 / 3 : ENNReal) = + expectedLiveNativeContextCharge impl (knownEncodingRootOuterCharge parameter) computation context fuel table cache := by + rw [← tsum_liveNativeQuerySelection_charge, ← ENNReal.tsum_mul_right] + apply tsum_congr + intro ordinal + exact (expected_knownEncodingRootSelection_charge_eq_probability parameter _).symm + +theorem sum_knownEncodingRootSelection_probability_le_charge + (parameter : PublicParameter) + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp (OracleWorld + SigningSpec) α) (q : Nat) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + (∑ ordinal ∈ Finset.range q, Pr[KnownHiddenEncodingRootSelection parameter | + liveNativeQuerySelection impl computation ordinal context fuel table cache]) * (4 / 3 : ENNReal) ≤ + expectedLiveNativeContextCharge impl (knownEncodingRootOuterCharge parameter) computation context fuel table cache := by + rw [← tsum_knownEncodingRootSelection_probability_eq_charge] + exact mul_le_mul' (ENNReal.sum_le_tsum (Finset.range q)) le_rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveNativeComposition.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveNativeComposition.lean new file mode 100644 index 00000000..c6331e53 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveNativeComposition.lean @@ -0,0 +1,145 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueLiveProbeCounting + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem expectedLiveResolvedQueryCharge_le_raw + (charge : LazyRevealProbe.Query Coordinate → ENNReal) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedLiveResolvedQueryCharge charge computation context fuel table ≤ expectedResolvedQueryCharge charge computation context fuel table := by + induction computation using OracleComp.inductionOn generalizing context fuel table with + | pure value => rfl + | query_bind input next ih => + rw [expectedLiveResolvedQueryCharge_query_bind, expectedResolvedQueryCharge_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete] + apply add_le_add le_rfl + apply ENNReal.tsum_le_tsum + intro result + cases result with + | none => rfl + | some result => exact mul_le_mul' le_rfl (ih result.value result.context result.remaining result.table) + · simp [hcomplete] + +noncomputable def liveResolvedContinuationCharge + (charge : LazyRevealProbe.Query Coordinate → ENNReal) + (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) : Option (ResolvedRunResult α) → ENNReal + | none => 0 + | some result => expectedLiveResolvedQueryCharge charge (next result.value) result.context result.remaining result.table + +theorem expectedLiveResolvedQueryCharge_bind + (charge : LazyRevealProbe.Query Coordinate → ENNReal) + (left : OracleComp (LazyRevealProbe.World Coordinate) α) (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + expectedLiveResolvedQueryCharge charge (left >>= next) context fuel table = + expectedLiveResolvedQueryCharge charge left context fuel table + + ∑' result, Pr[= result | runResolvedFromTable context fuel table left] * liveResolvedContinuationCharge charge next result := by + induction left using OracleComp.inductionOn generalizing context fuel table with + | pure value => simp [expectedLiveResolvedQueryCharge, runResolvedFromTable, liveResolvedContinuationCharge] + | query_bind input continuation ih => + by_cases hcomplete : DeferredCompletable table context + · rw [bind_assoc, expectedLiveResolvedQueryCharge_query_bind, expectedLiveResolvedQueryCharge_query_bind, + if_pos hcomplete, if_pos hcomplete, runResolvedFromTable_bind, tsum_probOutput_bind_mul, add_assoc, ← ENNReal.tsum_add] + congr 1 + apply tsum_congr + intro result + by_cases hresult : result ∈ support (runResolvedFromTable context fuel table (liftM (OracleSpec.query input))) + · cases result with + | none => simp [liveResolvedContinuationCharge] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable (liftM (OracleSpec.query input)) context fuel table result hconsistent hstarts hresult + dsimp only + rw [ih result.value result.context result.remaining result.table hcore.2.1 (hcore.1 ▸ hcore.2.2), mul_add, ← ENNReal.tsum_mul_left] + · simp [probOutput_eq_zero_of_not_mem_support hresult] + · rw [expectedLiveResolvedQueryCharge_eq_zero_of_not_completable charge _ context fuel table hcomplete, + expectedLiveResolvedQueryCharge_eq_zero_of_not_completable charge _ context fuel table hcomplete, zero_add] + symm + apply ENNReal.tsum_eq_zero.mpr + intro result + by_cases hresult : result ∈ support (runResolvedFromTable context fuel table + ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= continuation)) + · cases result with + | none => simp [liveResolvedContinuationCharge] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table result hconsistent hstarts hresult + have hdoomed := not_deferredCompletable_of_mem_runResolvedFromTable _ context fuel table result hconsistent hstarts hresult hcomplete + simp only [liveResolvedContinuationCharge, hcore.1, + expectedLiveResolvedQueryCharge_eq_zero_of_not_completable charge _ _ _ _ hdoomed, mul_zero] + · simp [probOutput_eq_zero_of_not_mem_support hresult] + +theorem chronological_expectedLiveStructuralCharge_le_liveOuterCharge + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + expectedLiveResolvedQueryCharge structuralProbeQueryCharge + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) context fuel table ≤ + expectedLiveNativeOuterCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (otsOuterQueryCharge parameter) computation context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => simp [expectedLiveResolvedQueryCharge, expectedLiveNativeOuterCharge] + | query_bind input next ih => + by_cases hcomplete : DeferredCompletable table context + · rw [simulateQ_query_bind, StateT.run_bind, + expectedLiveResolvedQueryCharge_bind _ _ _ context fuel table hconsistent hstarts, + expectedLiveNativeOuterCharge_query_bind, if_pos hcomplete] + apply add_le_add ((expectedLiveResolvedQueryCharge_le_raw structuralProbeQueryCharge _ context fuel table).trans + (chronologicalAdversaryImpl_expectedResolvedStructuralCharge_le parameter root ftsSecret input cache context fuel table)) + apply ENNReal.tsum_le_tsum + intro result + by_cases hresult : result ∈ support (runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache)) + · cases result with + | none => rfl + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table result hconsistent hstarts hresult + exact mul_le_mul' le_rfl (ih result.value.1 result.context result.remaining result.table result.value.2 hcore.2.1 (hcore.1 ▸ hcore.2.2)) + · simp [probOutput_eq_zero_of_not_mem_support hresult] + · rw [expectedLiveResolvedQueryCharge_eq_zero_of_not_completable _ _ context fuel table hcomplete, + expectedLiveNativeOuterCharge_eq_zero_of_not_completable _ _ _ context fuel table cache hcomplete] + + +theorem sum_targets_privateResolvedRawCandidate_hit_le_actualReserve + (targets : Finset Position) (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) + (hensured : ∀ target ∈ targets, .position target ∈ context.state.ensured) + (hstate : ∀ target ∈ targets, context.state.values (.position target) = none) + (hvalue : ∀ target ∈ targets, context.values target = none) + (hhidden : ∀ target ∈ targets, .position target ∉ context.state.revealed) + (hcard : ∀ target ∈ targets, (context.state.pendingAt (.position target)).card + q ≤ 2 ^ 126) : + (∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) ordinal)]) ≤ + expectedQueryCharge + (otsOpeningRefinedQueryReserve + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey)) + (simulateQ (expandedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey)) computation) + actualCache * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let native := ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) + let count := expectedLiveNativeOuterCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (otsOuterQueryCharge parameter) computation context fuel table cache + calc + _ ≤ expectedLiveResolvedQueryCharge structuralProbeQueryCharge native context fuel table * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := + sum_targets_privateResolvedRawCandidate_hit_le_expectedLiveStructuralCharge targets native q context fuel table + hinvariant.2.1 hinvariant.2.2.2.1 hensured hstate hvalue hhidden hcard + _ ≤ count * ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := + mul_le_mul' (chronological_expectedLiveStructuralCharge_le_liveOuterCharge parameter root ftsSecret computation + context fuel table cache hinvariant.2.1.valuesConsistent hinvariant.2.2.1) le_rfl + _ = (count * (4 / 3 : ENNReal)) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := (mul_assoc _ _ _).symm + _ ≤ _ := mul_le_mul' (expectedLiveChronologicalOtsCount_mul_le_actualReserve parameter root table ftsSecret computation + context fuel cache actualCache hinvariant hvisible hpublished) le_rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveNativeReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveNativeReserve.lean new file mode 100644 index 00000000..e8360b6b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveNativeReserve.lean @@ -0,0 +1,217 @@ +import SphincsSecurity.Proof.OtsProbeNativeQueryCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def expectedLiveNativeOuterCharge + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (charge : (OracleWorld + SigningSpec).Domain → ENNReal) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → ENNReal := + OracleComp.construct (fun _ _ _ _ _ => 0) + (fun input _ next context fuel table cache => + if DeferredCompletable table context then + charge input + ∑' result, Pr[= result | runResolvedFromTable context fuel table ((impl input).run cache)] * + match result with + | none => 0 + | some result => next result.value.1 result.context result.remaining result.table result.value.2 + else 0) computation + +theorem expectedLiveNativeOuterCharge_query_bind + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (charge : (OracleWorld + SigningSpec).Domain → ENNReal) (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + expectedLiveNativeOuterCharge impl charge (OracleSpec.query input >>= next) context fuel table cache = + (if DeferredCompletable table context then + charge input + ∑' result, Pr[= result | runResolvedFromTable context fuel table ((impl input).run cache)] * + match result with + | none => 0 + | some result => expectedLiveNativeOuterCharge impl charge (next result.value.1) + result.context result.remaining result.table result.value.2 + else 0) := rfl + +theorem expectedLiveNativeOuterCharge_eq_zero_of_not_completable + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (charge : (OracleWorld + SigningSpec).Domain → ENNReal) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hdoomed : ¬DeferredCompletable table context) : + expectedLiveNativeOuterCharge impl charge computation context fuel table cache = 0 := by + induction computation using OracleComp.inductionOn with + | pure value => rfl + | query_bind input next _ => rw [expectedLiveNativeOuterCharge_query_bind, if_neg hdoomed] + +theorem expectedLiveNativeOuterCharge_le_actualOuterCharge + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (charge : (OracleWorld + SigningSpec).Domain → ENNReal) + (actualCharge : QueryCache HashSpec → HashInput → ENNReal) + (himpl : ∀ input, ReachableResolvedCouples parameter table (impl input) + (unloggedMappedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey) input)) + (hcharge : ∀ input actualCache, charge input ≤ outerHashQueryCharge actualCharge input actualCache) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) : + expectedLiveNativeOuterCharge impl charge computation context fuel table cache ≤ + expectedOuterQueryCharge + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey) + actualCharge computation actualCache := by + let secretKey : SecretKey := ⟨parameter, root, fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + change _ ≤ expectedOuterQueryCharge secretKey actualCharge computation actualCache + induction computation using OracleComp.inductionOn generalizing context fuel cache actualCache with + | pure value => rfl + | query_bind input next ih => + rw [expectedLiveNativeOuterCharge_query_bind, if_pos hinvariant.2.2.2.1, expectedOuterQueryCharge_query_bind] + apply add_le_add (hcharge input actualCache) + have hstep := himpl input context fuel cache actualCache hinvariant hvisible hpublished + have hcost := expected_cost_le_of_relTriple hstep + (fun left => match left with + | none => 0 + | some result => expectedLiveNativeOuterCharge impl charge (next result.value.1) + result.context result.remaining result.table result.value.2) + (fun right => expectedOuterQueryCharge secretKey actualCharge (next right.1) right.2) + (fun _ => 0) (by + intro left right hrelation + simp only [add_zero] + cases left with + | none => exact bot_le + | some result => + dsimp only + rcases hrelation with hclean | hdoomed + · rw [hclean.1, ← hclean.2.1] + exact ih result.value.1 result.context result.remaining result.value.2 right.2 + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 + · rw [expectedLiveNativeOuterCharge_eq_zero_of_not_completable impl charge + (next result.value.1) result.context result.remaining result.table result.value.2 (by + rw [hdoomed.1] + exact hdoomed.2.2.2)] + exact bot_le) + simpa only [mul_zero, tsum_zero, add_zero] using hcost + +theorem reachableResolvedCouples_chronologicalNative_concrete + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (input : (OracleWorld + SigningSpec).Domain) : + ReachableResolvedCouples parameter table (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input) + (unloggedMappedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey) input) := by + cases input with + | inl query => exact reachableResolvedCouples_probingRomImpl parameter table query + | inr message => exact reachableResolvedCouples_maskedPublishedChronologicalSign_concrete parameter root table ftsSecret message + +theorem weightedOtsOuterQueryCharge_le_refinedReserve (secretKey : SecretKey) + (input : (OracleWorld + SigningSpec).Domain) (actualCache : QueryCache HashSpec) : + otsOuterQueryCharge secretKey.parameter input * (4 / 3 : ENNReal) ≤ + outerHashQueryCharge (otsOpeningRefinedQueryReserve secretKey) input actualCache := by + cases input with + | inl query => + cases query with + | inl n => simp [otsOuterQueryCharge, outerHashQueryCharge, hashQueryCharge] + | inr input => + change otsHashInputCharge secretKey.parameter input * (4 / 3 : ENNReal) ≤ otsOpeningRefinedQueryReserve secretKey actualCache input + unfold otsHashInputCharge + split_ifs with hots + · obtain ⟨position, hposition, hat⟩ := hots + simpa only [one_mul] using otsOpeningRefinedQueryReserve_ge_four_thirds_of_atOtsPosition secretKey actualCache input position hat hposition + · simp + | inr message => simp [otsOuterQueryCharge, outerHashQueryCharge] + +theorem expectedLiveChronologicalOtsCharge_le_actualReserve + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) : + expectedLiveNativeOuterCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (fun input => otsOuterQueryCharge parameter input * (4 / 3 : ENNReal)) computation context fuel table cache ≤ + expectedQueryCharge + (otsOpeningRefinedQueryReserve + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey)) + (simulateQ (expandedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey)) computation) actualCache := by + let secretKey : SecretKey := ⟨parameter, root, fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + have hbound : expectedLiveNativeOuterCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (fun input => otsOuterQueryCharge parameter input * (4 / 3 : ENNReal)) computation context fuel table cache ≤ + expectedOuterQueryCharge secretKey (otsOpeningRefinedQueryReserve secretKey) computation actualCache := by + exact expectedLiveNativeOuterCharge_le_actualOuterCharge parameter root table ftsSecret + (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (fun input => otsOuterQueryCharge parameter input * (4 / 3 : ENNReal)) + (otsOpeningRefinedQueryReserve secretKey) + (reachableResolvedCouples_chronologicalNative_concrete parameter root table ftsSecret) + (weightedOtsOuterQueryCharge_le_refinedReserve secretKey) computation context fuel cache actualCache hinvariant hvisible hpublished + exact hbound.trans (expectedOuterQueryCharge_le_expanded secretKey (otsOpeningRefinedQueryReserve secretKey) computation actualCache) + + +theorem expectedLiveNativeOuterCharge_mul + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (charge : (OracleWorld + SigningSpec).Domain → ENNReal) (factor : ENNReal) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + expectedLiveNativeOuterCharge impl (fun input => charge input * factor) computation context fuel table cache = + expectedLiveNativeOuterCharge impl charge computation context fuel table cache * factor := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => simp [expectedLiveNativeOuterCharge] + | query_bind input next ih => + rw [expectedLiveNativeOuterCharge_query_bind, expectedLiveNativeOuterCharge_query_bind] + by_cases hcomplete : DeferredCompletable table context + · simp only [if_pos hcomplete, add_mul] + congr 1 + rw [← ENNReal.tsum_mul_right] + apply tsum_congr + intro result + cases result with + | none => simp + | some result => simp only [ih, mul_assoc] + · simp [hcomplete] + +theorem expectedLiveChronologicalOtsCount_mul_le_actualReserve + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) : + expectedLiveNativeOuterCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (otsOuterQueryCharge parameter) computation context fuel table cache * (4 / 3 : ENNReal) ≤ + expectedQueryCharge + (otsOpeningRefinedQueryReserve + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey)) + (simulateQ (expandedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey)) computation) actualCache := by + rw [← expectedLiveNativeOuterCharge_mul] + exact expectedLiveChronologicalOtsCharge_le_actualReserve parameter root table ftsSecret computation context fuel cache actualCache + hinvariant hvisible hpublished + +theorem chronologicalAdversaryImpl_expectedResolvedStructuralCharge_le + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (cache : SplitHashCache) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedResolvedQueryCharge structuralProbeQueryCharge ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) + context fuel table ≤ otsOuterQueryCharge parameter input := by + cases input with + | inl query => + cases query with + | inl n => + change expectedResolvedQueryCharge structuralProbeQueryCharge ((splitUniformImpl n).run cache) context fuel table ≤ 0 + rw [expectedResolvedStructuralCharge_eq_zero_of_probeFree _ context fuel table (splitUniformImpl_probeFree n cache)] + | inr input => exact probingHashQuery_expectedResolvedStructuralCharge_le parameter input cache context fuel table + | inr message => + change expectedResolvedQueryCharge structuralProbeQueryCharge ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache) + context fuel table ≤ 0 + rw [expectedResolvedStructuralCharge_eq_zero_of_probeFree _ context fuel table + (maskedPublishedChronologicalSign_probeFree parameter root ftsSecret message cache)] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeLivePrivateAllowanceCounting.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLivePrivateAllowanceCounting.lean new file mode 100644 index 00000000..55142edf --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLivePrivateAllowanceCounting.lean @@ -0,0 +1,74 @@ +import SphincsSecurity.Proof.OtsProbeLiveStartAllowanceCounting + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem sum_privateLiveProbeOrdinalAllowance_eq_of_liveBound + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hbound : LiveResolvedQueryBound (IsPrivatePositionProbe target) computation q context fuel table) : + (∑ ordinal ∈ Finset.range q, privateLiveProbeOrdinalAllowance target computation ordinal context fuel table) = + privateLiveProbeAllowance target computation context fuel table := by + induction computation using OracleComp.inductionOn generalizing q context fuel table with + | pure value => simp [privateLiveProbeOrdinalAllowance, privateLiveProbeAllowance] + | query_bind input next ih => + rw [privateLiveProbeAllowance_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete] + have hbound := (liveResolvedQueryBound_query_bind _ _ _ _ _ _ _).mp hbound hcomplete + by_cases hdisclose : IsPrivatePositionDisclosure target input + · simp [privateLiveProbeOrdinalAllowance_query_bind, hcomplete, hdisclose] + · rw [if_neg hdisclose] + have htail (n : Nat) (hnext : ∀ result, some result ∈ support (runResolvedFromTable context fuel table (liftM (OracleSpec.query input))) → + LiveResolvedQueryBound (IsPrivatePositionProbe target) (next result.value) n result.context result.remaining result.table) : + (∑ ordinal ∈ Finset.range n, ∑' result, + Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => privateLiveProbeOrdinalAllowance target (next result.value) ordinal result.context result.remaining result.table) = + ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => privateLiveProbeAllowance target (next result.value) result.context result.remaining result.table := by + rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + apply tsum_congr + intro result + by_cases hresult : result ∈ support (runResolvedFromTable context fuel table (liftM (OracleSpec.query input))) + · cases result with + | none => simp + | some result => + simp only [← Finset.mul_sum] + rw [ih result.value n result.context result.remaining result.table (hnext result hresult)] + · simp [probOutput_eq_zero_of_not_mem_support hresult] + by_cases hprobe : IsPrivatePositionProbe target input + · cases q with + | zero => have := hbound.1 hprobe; omega + | succ q => + rw [Finset.sum_range_succ'] + simp only [privateLiveProbeOrdinalAllowance_query_bind, if_pos hcomplete, if_neg hdisclose, + hprobe, Nat.add_eq_zero_iff, Nat.one_ne_zero, and_false, if_false, Nat.add_sub_cancel, and_self, if_true] + exact (congrArg (fun value => value + privateProbeInputAllowance target table context input) + (htail q (fun result hresult => by simpa only [if_pos hprobe, Nat.add_sub_cancel] using hbound.2 result hresult))).trans (add_comm _ _) + · simp only [privateLiveProbeOrdinalAllowance_query_bind, if_pos hcomplete, if_neg hdisclose, + hprobe, false_and, if_false, privateProbeInputAllowance_of_not_probe target table context input hprobe, zero_add] + exact htail q (fun result hresult => by simpa only [if_neg hprobe] using hbound.2 result hresult) + · simp [privateLiveProbeOrdinalAllowance_query_bind, hcomplete] + +theorem sum_privateProbeCut_hits_eq_liveAllowance_of_liveBound + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hhidden : .position target ∉ context.state.revealed) + (hbound : LiveResolvedQueryBound (IsPrivatePositionProbe target) computation q context fuel table) : + (∑ ordinal ∈ Finset.range q, + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target computation ordinal)]) = + privateLiveProbeAllowance target computation context fuel table := by + simp_rw [probEvent_privateProbeCut_hit_eq_ordinalAllowance target computation _ context fuel table hconsistent hstarts hhidden] + exact sum_privateLiveProbeOrdinalAllowance_eq_of_liveBound target computation q context fuel table hbound + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveResolvedBudget.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveResolvedBudget.lean new file mode 100644 index 00000000..de6c9706 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveResolvedBudget.lean @@ -0,0 +1,125 @@ +import SphincsSecurity.Proof.OtsProbeNativeSupportedRootReserve + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def LiveResolvedQueryBound (predicate : LazyRevealProbe.Query Coordinate → Prop) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + Nat → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → Prop := + OracleComp.construct (fun _ _ _ _ _ => True) + (fun input _ next q context fuel table => DeferredCompletable table context → + (predicate input → 0 < q) ∧ + ∀ result, some result ∈ support (runResolvedFromTable context fuel table (liftM (OracleSpec.query input))) → + next result.value (if predicate input then q - 1 else q) result.context result.remaining result.table) computation + +theorem liveResolvedQueryBound_query_bind + (predicate : LazyRevealProbe.Query Coordinate → Prop) (input : LazyRevealProbe.Query Coordinate) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + LiveResolvedQueryBound predicate ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= next) + q context fuel table ↔ + (DeferredCompletable table context → (predicate input → 0 < q) ∧ + ∀ result, some result ∈ support (runResolvedFromTable context fuel table (liftM (OracleSpec.query input))) → + LiveResolvedQueryBound predicate (next result.value) (if predicate input then q - 1 else q) + result.context result.remaining result.table) := Iff.rfl + +theorem liveResolvedQueryBound_of_not_completable + (predicate : LazyRevealProbe.Query Coordinate → Prop) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hnot : ¬DeferredCompletable table context) : LiveResolvedQueryBound predicate computation q context fuel table := by + induction computation using OracleComp.inductionOn with + | pure value => trivial + | query_bind input next _ => intro hcomplete; exact (hnot hcomplete).elim + +theorem LiveResolvedQueryBound.mono + {predicate : LazyRevealProbe.Query Coordinate → Prop} {computation : OracleComp (LazyRevealProbe.World Coordinate) α} + {q r : Nat} {context : DeferredContext} {fuel : Nat} {table : OtsSecretIndex → HashOutput} + (hbound : LiveResolvedQueryBound predicate computation q context fuel table) (hle : q ≤ r) : + LiveResolvedQueryBound predicate computation r context fuel table := by + induction computation using OracleComp.inductionOn generalizing q r context fuel table with + | pure value => trivial + | query_bind input next ih => + rw [liveResolvedQueryBound_query_bind] at hbound ⊢ + intro hcomplete + have hbound := hbound hcomplete + refine ⟨fun hinput => (hbound.1 hinput).trans_le hle, ?_⟩ + intro result hresult + exact ih result.value (hbound.2 result hresult) (by split_ifs <;> omega) + +theorem liveResolvedQueryBound_of_syntactic + (predicate : LazyRevealProbe.Query Coordinate → Prop) [DecidablePred predicate] (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q : Nat) (hbound : computation.IsQueryBoundP predicate q) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + LiveResolvedQueryBound predicate computation q context fuel table := by + induction computation using OracleComp.inductionOn generalizing q context fuel table with + | pure value => trivial + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [liveResolvedQueryBound_query_bind] + intro _ + refine ⟨fun hinput => hbound.1.resolve_left (not_not.mpr hinput), ?_⟩ + intro result _ + by_cases hinput : predicate input + · simp only [if_pos hinput] at hbound ⊢ + exact ih result.value _ (hbound.2 result.value) result.context result.remaining result.table + · simp only [if_neg hinput] at hbound ⊢ + exact ih result.value _ (hbound.2 result.value) result.context result.remaining result.table + +theorem liveResolvedQueryBound_bind_of_syntactic_prefix + (predicate : LazyRevealProbe.Query Coordinate → Prop) [DecidablePred predicate] + (left : OracleComp (LazyRevealProbe.World Coordinate) α) (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) + (q r : Nat) (hleft : left.IsQueryBoundP predicate q) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hnext : ∀ result, some result ∈ support (runResolvedFromTable context fuel table left) → + LiveResolvedQueryBound predicate (next result.value) r result.context result.remaining result.table) : + LiveResolvedQueryBound predicate (left >>= next) (q + r) context fuel table := by + induction left using OracleComp.inductionOn generalizing q context fuel table with + | pure value => + exact (hnext ⟨context, fuel, value, table⟩ (by simp [runResolvedFromTable])).mono (Nat.le_add_left _ _) + | query_bind input continuation ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hleft + rw [bind_assoc, liveResolvedQueryBound_query_bind] + intro _ + have hpositive : predicate input → 0 < q := by intro hinput; simpa [hinput] using hleft.1 + refine ⟨fun hinput => by have := hpositive hinput; omega, ?_⟩ + intro middle hmiddle + have htail : LiveResolvedQueryBound predicate (continuation middle.value >>= next) + ((if predicate input then q - 1 else q) + r) middle.context middle.remaining middle.table := by + apply ih middle.value _ (hleft.2 middle.value) middle.context middle.remaining middle.table + intro result hresult + apply hnext result + rw [runResolvedFromTable_bind, mem_support_bind_iff] + exact ⟨some middle, hmiddle, hresult⟩ + convert htail using 1 + by_cases hinput : predicate input + · simp only [if_pos hinput] + have := hpositive hinput + omega + · simp only [if_neg hinput] + +theorem LiveResolvedQueryBound.of_imp + {predicate weaker : LazyRevealProbe.Query Coordinate → Prop} {computation : OracleComp (LazyRevealProbe.World Coordinate) α} + {q : Nat} {context : DeferredContext} {fuel : Nat} {table : OtsSecretIndex → HashOutput} + (himp : ∀ input, weaker input → predicate input) + (hbound : LiveResolvedQueryBound predicate computation q context fuel table) : + LiveResolvedQueryBound weaker computation q context fuel table := by + induction computation using OracleComp.inductionOn generalizing q context fuel table with + | pure value => trivial + | query_bind input next ih => + rw [liveResolvedQueryBound_query_bind] at hbound ⊢ + intro hcomplete + have hbound := hbound hcomplete + refine ⟨fun hinput => hbound.1 (himp input hinput), ?_⟩ + intro result hresult + apply (ih result.value (hbound.2 result hresult)).mono + by_cases hweaker : weaker input + · simp only [if_pos hweaker, if_pos (himp input hweaker)] + exact le_rfl + · simp only [if_neg hweaker] + split_ifs <;> omega + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveSampledReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveSampledReserve.lean new file mode 100644 index 00000000..df355dc8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveSampledReserve.lean @@ -0,0 +1,112 @@ +import SphincsSecurity.Proof.OtsProbeLiveJointReserve + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def liveOtsChargeAfterTable + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : ENNReal := + ∑' result, Pr[= result | runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)] * + match result with + | none => 0 + | some result => expectedLiveNativeOuterCharge + (maskedChronologicalExpandedAdversaryImpl parameter result.value.1 ftsSecret) + (fun input => otsOuterQueryCharge parameter input * (4 / 3 : ENNReal)) + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining table result.value.2 + +theorem liveOtsChargeAfterTable_le_gameDirectCharge + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + liveOtsChargeAfterTable adversary parameter table ftsSecret fuel ≤ + expectedQueryCharge (directOtsQueryCharge parameter) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) ∅ := by + let otsSecret := fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩) + let actualCost := fun result : Digest × QueryCache HashSpec => + expectedQueryCharge (directOtsQueryCharge parameter) + (gameRest scheme adversary ⟨result.1, parameter⟩ ⟨parameter, result.1, otsSecret, ftsSecret⟩) result.2 + have hroot := reachableResolvedCouples_maskedPublishedTreeRoot parameter table + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel emptySplitHashCache ∅ (resolvedContextInvariant_empty parameter table) + (visibleResolvedComputationsCached_empty parameter table emptyDeferredStructuralValues ∅) publishedValues_empty + have hcost : liveOtsChargeAfterTable adversary parameter table ftsSecret fuel ≤ + ∑' result, Pr[= result | (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅] * actualCost result := by + have hbound := expected_cost_le_of_relTriple hroot + (fun left => match left with + | none => 0 + | some result => expectedLiveNativeOuterCharge + (maskedChronologicalExpandedAdversaryImpl parameter result.value.1 ftsSecret) + (fun input => otsOuterQueryCharge parameter input * (4 / 3 : ENNReal)) + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining table result.value.2) + actualCost (fun _ => 0) (by + intro left right hrelation + simp only [add_zero] + cases left with + | none => exact bot_le + | some result => + dsimp only + rcases hrelation with hclean | hdoomed + · have hlocal := expectedLiveChronologicalOtsCharge_le_directCharge parameter result.value.1 table ftsSecret + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining result.value.2 right.2 hclean.2.2.1 + hclean.2.2.2.1 hclean.2.2.2.2 + rw [expectedQueryCharge_retained_eq_gameRest] at hlocal + simpa only [actualCost, ← hclean.2.1] using hlocal + · rw [expectedLiveNativeOuterCharge_eq_zero_of_not_completable + (maskedChronologicalExpandedAdversaryImpl parameter result.value.1 ftsSecret) + (fun input => otsOuterQueryCharge parameter input * (4 / 3 : ENNReal)) + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining table result.value.2 hdoomed.2.2.2] + exact bot_le) + simpa only [liveOtsChargeAfterTable, treeRoot, otsSecret, mul_zero, tsum_zero, add_zero] using hbound + apply hcost.trans + change _ ≤ expectedQueryCharge (directOtsQueryCharge parameter) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ + rw [gameAfterSecrets, expectedQueryCharge_bind, simulateQ_romImpl_liftM] + exact le_add_self + +noncomputable def sampledLiveOtsCharge (adversary : Adversary) (fuel : Nat) : ENNReal := + ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' table, Pr[= table | sampleOtsHashTable] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + liveOtsChargeAfterTable adversary parameter table ftsSecret fuel + +theorem sampledLiveOtsCharge_le_directCharge (adversary : Adversary) (fuel : Nat) : + sampledLiveOtsCharge adversary fuel ≤ + sampledQueryCharge (fun secretKey => directOtsQueryCharge secretKey.parameter) adversary := by + unfold sampledLiveOtsCharge sampledQueryCharge + simp only [sampleSecrets, tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + apply ENNReal.tsum_le_tsum + intro parameter + apply mul_le_mul' le_rfl + have hcoupled := expected_cost_le_of_relTriple relTriple_uniformOtsHashTable_sampleOtsSecrets + (fun table => ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + liveOtsChargeAfterTable adversary parameter table ftsSecret fuel) + (fun otsSecret => ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + expectedQueryCharge (directOtsQueryCharge parameter) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅) + (fun _ => 0) (by + intro table otsSecret hsecrets + simp only [add_zero] + rw [← hsecrets] + apply ENNReal.tsum_le_tsum + intro ftsSecret + exact mul_le_mul' le_rfl (liveOtsChargeAfterTable_le_gameDirectCharge adversary parameter table ftsSecret fuel)) + simpa only [sampleOtsHashTable, mul_zero, tsum_zero, add_zero, primitiveAccountingKey] using hcoupled + +theorem sampledLiveOtsCharge_add_remaining_le_refinedReserve (adversary : Adversary) (fuel : Nat) : + sampledLiveOtsCharge adversary fuel + sampledQueryCharge remainingOtsQueryReserve adversary ≤ + sampledQueryCharge otsOpeningRefinedQueryReserve adversary := by + exact (add_le_add (sampledLiveOtsCharge_le_directCharge adversary fuel) le_rfl).trans_eq + (sampled_direct_add_remaining_otsQueryReserve adversary) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveStartAllowanceCounting.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveStartAllowanceCounting.lean new file mode 100644 index 00000000..e593d6a3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveStartAllowanceCounting.lean @@ -0,0 +1,76 @@ +import SphincsSecurity.Proof.OtsProbeNativeLiveBudget + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem sum_expectedLiveStartProbeCutAllowance_eq_of_liveBound + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (q : Nat) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hbound : LiveResolvedQueryBound LazyRevealProbe.IsProbe computation q context fuel table) : + (∑ ordinal ∈ Finset.range q, expectedLiveStartCutAllowance (nativeProbeCutAt computation ordinal) context fuel table) = + liveStartProbeAllowance computation context fuel table := by + induction computation using OracleComp.inductionOn generalizing q context fuel table with + | pure value => + simp [nativeProbeCutAt, expectedLiveStartCutAllowance_pure, nativeCutCandidate, unresolvedStartCandidateAllowance, liveStartProbeAllowance] + | query_bind input next ih => + rw [liveStartProbeAllowance_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete] + have hbound := (liveResolvedQueryBound_query_bind _ _ _ _ _ _ _).mp hbound hcomplete + have htail (n : Nat) (hnext : ∀ result, some result ∈ support (runResolvedFromTable context fuel table (liftM (OracleSpec.query input))) → + LiveResolvedQueryBound LazyRevealProbe.IsProbe (next result.value) n result.context result.remaining result.table) : + (∑ ordinal ∈ Finset.range n, expectedLiveStartCutAllowance + ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= + fun output => nativeProbeCutAt (next output) ordinal) context fuel table) = + ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => liveStartProbeAllowance (next result.value) result.context result.remaining result.table := by + simp only [expectedLiveStartCutAllowance_bind] + rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + apply tsum_congr + intro result + by_cases hresult : result ∈ support (runResolvedFromTable context fuel table (liftM (OracleSpec.query input))) + · cases result with + | none => simp + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable (liftM (OracleSpec.query input)) context fuel table result hconsistent hstarts hresult + simp only [← Finset.mul_sum] + rw [ih result.value n result.context result.remaining result.table hcore.2.1 (hcore.1 ▸ hcore.2.2) (hnext result hresult)] + · simp [probOutput_eq_zero_of_not_mem_support hresult] + by_cases hprobe : LazyRevealProbe.IsProbe input + · cases q with + | zero => have := hbound.1 hprobe; omega + | succ q => + rw [Finset.sum_range_succ'] + simp only [nativeProbeCutAt_query_bind, if_pos hprobe, expectedLiveStartCutAllowance_pure, if_pos hcomplete] + have hweight : unresolvedStartCandidateAllowance table context (nativeCutCandidate context (.query input next)) = + startProbeInputAllowance table context input := by + cases input <;> simp [nativeCutCandidate, startProbeInputAllowance, unresolvedStartCandidateAllowance] + rw [hweight] + exact (congrArg (fun value => value + startProbeInputAllowance table context input) + (htail q (fun result hresult => by simpa only [if_pos hprobe, Nat.add_sub_cancel] using hbound.2 result hresult))).trans (add_comm _ _) + · simp only [nativeProbeCutAt_query_bind, if_neg hprobe, + startProbeInputAllowance_of_not_probe table context input hprobe, zero_add] + exact htail q (fun result hresult => by simpa only [if_neg hprobe] using hbound.2 result hresult) + · rw [if_neg hcomplete] + simp only [expectedLiveStartCutAllowance_eq_zero_of_not_completable _ context fuel table hconsistent hstarts hcomplete, + Finset.sum_const_zero] + +theorem sum_nativeProbeCut_startHits_eq_liveAllowance_of_liveBound + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (q : Nat) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hbound : LiveResolvedQueryBound LazyRevealProbe.IsProbe computation q context fuel table) : + (∑ ordinal ∈ Finset.range q, Pr[LiveUnresolvedStartHit nativeCutCandidate | + runResolvedFromTable context fuel table (nativeProbeCutAt computation ordinal)]) = + liveStartProbeAllowance computation context fuel table := by + simp_rw [← expectedLiveStartCutAllowance_eq_hitProbability] + exact sum_expectedLiveStartProbeCutAllowance_eq_of_liveBound computation q context fuel table hconsistent hstarts hbound + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveStartCounting.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveStartCounting.lean new file mode 100644 index 00000000..7ef82e56 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveStartCounting.lean @@ -0,0 +1,171 @@ +import SphincsSecurity.Proof.OtsProbeLiveStartCut + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def nativeCutQueryCharge (charge : LazyRevealProbe.Query Coordinate → ENNReal) : PrivateValueCut α → ENNReal + | .done _ => 0 + | .query input _ => charge input + +noncomputable def liveNativeCutCharge (charge : LazyRevealProbe.Query Coordinate → ENNReal) + (result : Option (ResolvedRunResult (PrivateValueCut α))) : ENNReal := + match retainCompletableResult result with + | none => 0 + | some result => nativeCutQueryCharge charge result.value + +noncomputable def expectedLiveNativeCutCharge (charge : LazyRevealProbe.Query Coordinate → ENNReal) + (computation : OracleComp (LazyRevealProbe.World Coordinate) (PrivateValueCut α)) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : ENNReal := + ∑' result, Pr[= result | runResolvedFromTable context fuel table computation] * liveNativeCutCharge charge result + +theorem expectedLiveNativeCutCharge_pure (charge : LazyRevealProbe.Query Coordinate → ENNReal) + (value : PrivateValueCut α) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedLiveNativeCutCharge charge (pure value) context fuel table = + if DeferredCompletable table context then nativeCutQueryCharge charge value else 0 := by + by_cases hcomplete : DeferredCompletable table context <;> + simp [expectedLiveNativeCutCharge, runResolvedFromTable, liveNativeCutCharge, retainCompletableResult, hcomplete] + +theorem expectedLiveNativeCutCharge_bind (charge : LazyRevealProbe.Query Coordinate → ENNReal) + (computation : OracleComp (LazyRevealProbe.World Coordinate) β) + (next : β → OracleComp (LazyRevealProbe.World Coordinate) (PrivateValueCut α)) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedLiveNativeCutCharge charge (computation >>= next) context fuel table = + ∑' result, Pr[= result | runResolvedFromTable context fuel table computation] * + match result with + | none => 0 + | some result => expectedLiveNativeCutCharge charge (next result.value) result.context result.remaining result.table := by + unfold expectedLiveNativeCutCharge + rw [runResolvedFromTable_bind, tsum_probOutput_bind_mul] + apply tsum_congr + intro result + cases result with + | none => simp [liveNativeCutCharge, retainCompletableResult] + | some result => rfl + +theorem expectedLiveNativeCutCharge_eq_zero_of_not_completable + (charge : LazyRevealProbe.Query Coordinate → ENNReal) + (computation : OracleComp (LazyRevealProbe.World Coordinate) (PrivateValueCut α)) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) : + expectedLiveNativeCutCharge charge computation context fuel table = 0 := by + apply ENNReal.tsum_eq_zero.mpr + intro result + by_cases hresult : result ∈ support (runResolvedFromTable context fuel table computation) + · cases result with + | none => simp [liveNativeCutCharge, retainCompletableResult] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable computation context fuel table result hconsistent hstarts hresult + have hstill := not_deferredCompletable_of_mem_runResolvedFromTable computation context fuel table result hconsistent hstarts hresult hdoomed + simp [liveNativeCutCharge, retainCompletableResult, hcore.1, hstill] + · simp [probOutput_eq_zero_of_not_mem_support hresult] + +theorem sum_expectedLiveNativeProbeCutCharge_le_expectedCharge + (charge : LazyRevealProbe.Query Coordinate → ENNReal) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (q : Nat) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + (∑ ordinal ∈ Finset.range q, expectedLiveNativeCutCharge charge (nativeProbeCutAt computation ordinal) context fuel table) ≤ + expectedLiveResolvedQueryCharge charge computation context fuel table := by + induction computation using OracleComp.inductionOn generalizing q context fuel table with + | pure value => simp [nativeProbeCutAt, expectedLiveNativeCutCharge_pure, nativeCutQueryCharge, expectedLiveResolvedQueryCharge] + | query_bind input next ih => + rw [expectedLiveResolvedQueryCharge_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete] + have htail (n : Nat) : + (∑ ordinal ∈ Finset.range n, expectedLiveNativeCutCharge charge + ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= + fun output => nativeProbeCutAt (next output) ordinal) context fuel table) ≤ + ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => expectedLiveResolvedQueryCharge charge (next result.value) result.context result.remaining result.table := by + simp only [expectedLiveNativeCutCharge_bind] + rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + apply ENNReal.tsum_le_tsum + intro result + by_cases hresult : result ∈ support (runResolvedFromTable context fuel table (liftM (OracleSpec.query input))) + · cases result with + | none => simp + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable (liftM (OracleSpec.query input)) context fuel table result hconsistent hstarts hresult + simp only [← Finset.mul_sum] + exact mul_le_mul' le_rfl (ih result.value n result.context result.remaining result.table hcore.2.1 (hcore.1 ▸ hcore.2.2)) + · simp [probOutput_eq_zero_of_not_mem_support hresult] + by_cases hprobe : LazyRevealProbe.IsProbe input + · cases q with + | zero => simp + | succ q => + rw [Finset.sum_range_succ'] + simp only [nativeProbeCutAt_query_bind, if_pos hprobe, expectedLiveNativeCutCharge_pure, + if_pos hcomplete, nativeCutQueryCharge] + exact (add_le_add (htail q) le_rfl).trans_eq (add_comm _ _) + · simp only [nativeProbeCutAt_query_bind, if_neg hprobe] + exact (htail q).trans le_add_self + · rw [if_neg hcomplete] + simp only [expectedLiveNativeCutCharge_eq_zero_of_not_completable charge _ context fuel table hconsistent hstarts hcomplete, + Finset.sum_const_zero, le_refl] + +theorem unresolvedStartCandidateCharge_nativeCut_le + (context : DeferredContext) (cut : PrivateValueCut α) : + unresolvedStartCandidateCharge context (nativeCutCandidate context cut) ≤ nativeCutQueryCharge chainStartProbeQueryCharge cut := by + cases cut with + | done value => simp [nativeCutCandidate, unresolvedStartCandidateCharge, nativeCutQueryCharge] + | query input next => + cases input with + | probe coordinate digest => + cases coordinate with + | position position => simp [nativeCutCandidate, unresolvedStartCandidateCharge, nativeCutQueryCharge, chainStartProbeQueryCharge] + | chainStart lay tree leafIdx chainIdx => + simp only [nativeCutCandidate, unresolvedStartCandidateCharge, nativeCutQueryCharge, chainStartProbeQueryCharge] + split_ifs + · have h := candidateCharge_sum_le_one (materializedDeferredState context) (some ⟨.chainStart lay tree leafIdx chainIdx, digest⟩) + exact_mod_cast (Nat.le_add_right _ _).trans h + · exact zero_le + | _ => simp [nativeCutCandidate, unresolvedStartCandidateCharge, nativeCutQueryCharge, chainStartProbeQueryCharge] + +theorem historyUnresolvedStartCharge_le_liveNativeCutCharge + (result : Option (ResolvedRunResult (PrivateValueCut α))) : + historyUnresolvedStartCharge nativeCutCandidate (retainCompletableResult result) ≤ + liveNativeCutCharge chainStartProbeQueryCharge result := by + unfold liveNativeCutCharge + cases hresult : retainCompletableResult result with + | none => simp [historyUnresolvedStartCharge] + | some result => exact unresolvedStartCandidateCharge_nativeCut_le result.context result.value + +theorem sum_sampledNativeProbeCut_unresolvedStart_le_expectedChainStartCharge + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + (∑ ordinal ∈ Finset.range q, + Pr[LiveUnresolvedStartHit nativeCutCandidate | sampledNativeProbeCut computation fuel ordinal]) ≤ + (∑' table, Pr[= table | sampleOtsHashTable] * + expectedLiveResolvedQueryCharge chainStartProbeQueryCharge computation + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } fuel table) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply (sum_sampledNativeProbeCut_unresolvedStart_le computation fuel q hq).trans + apply mul_le_mul' _ le_rfl + calc + _ ≤ ∑ ordinal ∈ Finset.range q, ∑' result, + Pr[= result | sampledNativeProbeCut computation fuel ordinal] * liveNativeCutCharge chainStartProbeQueryCharge result := by + apply Finset.sum_le_sum + intro ordinal _ + exact ENNReal.tsum_le_tsum fun result => mul_le_mul' le_rfl (historyUnresolvedStartCharge_le_liveNativeCutCharge result) + _ = ∑' table, Pr[= table | sampleOtsHashTable] * + ∑ ordinal ∈ Finset.range q, expectedLiveNativeCutCharge chainStartProbeQueryCharge + (nativeProbeCutAt computation ordinal) + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } fuel table := by + simp only [sampledNativeProbeCut, tsum_probOutput_bind_mul] + rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + simp only [← Finset.mul_sum, expectedLiveNativeCutCharge] + _ ≤ _ := by + apply ENNReal.tsum_le_tsum + intro table + exact mul_le_mul' le_rfl (sum_expectedLiveNativeProbeCutCharge_le_expectedCharge chainStartProbeQueryCharge computation q + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } fuel table + DeferredContext.valid_empty.valuesConsistent (startTableAgrees_empty table)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveStartCut.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveStartCut.lean new file mode 100644 index 00000000..5cf55502 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeLiveStartCut.lean @@ -0,0 +1,103 @@ +import SphincsSecurity.Proof.OtsProbeLiveJointCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def nativeProbeCutAt (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + Nat → OracleComp (LazyRevealProbe.World Coordinate) (PrivateValueCut α) := + OracleComp.construct (fun value _ => pure (.done value)) + (fun input next recursivelyCut ordinal => + if LazyRevealProbe.IsProbe input then + match ordinal with + | 0 => pure (.query input next) + | ordinal + 1 => (liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= fun output => recursivelyCut output ordinal + else (liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= fun output => recursivelyCut output ordinal) computation + +theorem nativeProbeCutAt_query_bind + (input : (LazyRevealProbe.World Coordinate).Domain) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) (ordinal : Nat) : + nativeProbeCutAt ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= next) ordinal = + (if LazyRevealProbe.IsProbe input then + match ordinal with + | 0 => pure (.query input next) + | ordinal + 1 => (liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= fun output => nativeProbeCutAt (next output) ordinal + else (liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= fun output => nativeProbeCutAt (next output) ordinal) := rfl + +theorem nativeProbeCutAt_resume (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (ordinal : Nat) : + nativeProbeCutAt computation ordinal >>= PrivateValueCut.resume = computation := by + induction computation using OracleComp.inductionOn generalizing ordinal with + | pure value => rfl + | query_bind input next ih => + rw [nativeProbeCutAt_query_bind] + split_ifs + · cases ordinal with + | zero => rfl + | succ ordinal => + rw [bind_assoc] + exact bind_congr fun output => ih output ordinal + · rw [bind_assoc] + exact bind_congr fun output => ih output ordinal + +theorem nativeProbeCutAt_probeBound (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (ordinal : Nat) : + (nativeProbeCutAt computation ordinal).IsQueryBoundP LazyRevealProbe.IsProbe ordinal := by + induction computation using OracleComp.inductionOn generalizing ordinal with + | pure value => simp [nativeProbeCutAt] + | query_bind input next ih => + rw [nativeProbeCutAt_query_bind] + by_cases hprobe : LazyRevealProbe.IsProbe input + · rw [if_pos hprobe] + cases ordinal with + | zero => simp + | succ ordinal => + rw [OracleComp.isQueryBoundP_query_bind_iff] + exact ⟨Or.inr (by omega), fun output => by simpa only [if_pos hprobe, Nat.add_sub_cancel] using ih output ordinal⟩ + · rw [if_neg hprobe, OracleComp.isQueryBoundP_query_bind_iff] + exact ⟨Or.inl hprobe, fun output => by simpa only [if_neg hprobe] using ih output ordinal⟩ + +def nativeCutCandidate (_context : DeferredContext) : PrivateValueCut α → Option Probe + | .query (.probe coordinate digest) _ => some ⟨coordinate, digest⟩ + | _ => none + +noncomputable def sampledNativeProbeCut + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel ordinal : Nat) : + ProbComp (Option (ResolvedRunResult (PrivateValueCut α))) := do + let table ← sampleOtsHashTable + runResolvedFromTable { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (nativeProbeCutAt computation ordinal) + +theorem probEvent_sampledNativeProbeCut_unresolvedStart_le + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel ordinal : Nat) + (hordinal : ordinal ≤ 2 ^ 126) : + Pr[LiveUnresolvedStartHit nativeCutCandidate | sampledNativeProbeCut computation fuel ordinal] ≤ + (∑' result, Pr[= result | sampledNativeProbeCut computation fuel ordinal] * + historyUnresolvedStartCharge nativeCutCandidate (retainCompletableResult result)) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + rw [probEvent_liveUnresolvedStartHit_eq_expected] + exact expected_live_sampled_runResolved_empty_unresolvedStart_le (nativeProbeCutAt computation ordinal) + fuel ordinal nativeCutCandidate (nativeProbeCutAt_probeBound computation ordinal) hordinal + +theorem sum_sampledNativeProbeCut_unresolvedStart_le + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel q : Nat) + (hq : q ≤ 2 ^ 126) : + (∑ ordinal ∈ Finset.range q, + Pr[LiveUnresolvedStartHit nativeCutCandidate | sampledNativeProbeCut computation fuel ordinal]) ≤ + (∑ ordinal ∈ Finset.range q, ∑' result, + Pr[= result | sampledNativeProbeCut computation fuel ordinal] * + historyUnresolvedStartCharge nativeCutCandidate (retainCompletableResult result)) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + calc + _ ≤ ∑ ordinal ∈ Finset.range q, + (∑' result, Pr[= result | sampledNativeProbeCut computation fuel ordinal] * + historyUnresolvedStartCharge nativeCutCandidate (retainCompletableResult result)) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply Finset.sum_le_sum + intro ordinal hmem + exact probEvent_sampledNativeProbeCut_unresolvedStart_le computation fuel ordinal + ((Nat.le_of_lt (Finset.mem_range.mp hmem)).trans hq) + _ = _ := (Finset.sum_mul _ _ _).symm + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeMaterializedCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeMaterializedCharge.lean new file mode 100644 index 00000000..b05a6f15 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeMaterializedCharge.lean @@ -0,0 +1,430 @@ +import SphincsSecurity.Proof.OtsProbeOrdinaryCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +noncomputable def materializedChargeHandler (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (input : (OracleWorld + SigningSpec).Domain) + (state : LazyRevealProbe.State Coordinate) : + StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) ((OracleWorld + SigningSpec).Range input) := + match input with + | .inl (.inl n) => splitUniformImpl n + | .inl (.inr input) => + let publicState := canonicalPublicProbeState state + let plan := purePlanProbingHashQuery parameter input publicState + probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan + | .inr message => maskedSign parameter root ftsSecret message + +noncomputable def materializedBoundaryCharge {α : Type} (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) : + LazyRevealProbe.State Coordinate → Nat → SplitHashCache → ℝ≥0∞ := + OracleComp.construct (fun _ _ _ _ => 0) + (fun input _ next state fuel cache => + ordinaryContinuationCharge (fun context remaining value => next value.1 context.state remaining value.2) + ((materializedChargeHandler parameter root ftsSecret input state).run cache) + (directDeferredContext state) fuel) computation + +theorem materializedBoundaryCharge_query_bind {α : Type} (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) (cache : SplitHashCache) : + materializedBoundaryCharge parameter root ftsSecret (OracleSpec.query input >>= next) state fuel cache = + ordinaryContinuationCharge (fun context remaining value => + materializedBoundaryCharge parameter root ftsSecret (next value.1) context.state remaining value.2) + ((materializedChargeHandler parameter root ftsSecret input state).run cache) + (directDeferredContext state) fuel := rfl + +theorem probEvent_sampledRunThenFinalizeClean_none_le_unmaterializedCharge + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe fuel) : + Pr[= none | sampledRunThenFinalizeClean state fuel computation] ≤ + (LazyRevealProbe.expectedProbeCharge computation state fuel + (state.unmaterializedPending.card : ℝ≥0∞)) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ = Pr[= none | detailedExperimentCleanWithCompletionTable state fuel computation] := + probOutput_congr rfl (by + unfold sampledRunThenFinalizeClean + exact evalDist_runThenFinalizeCleanFromTable_eq_detailed computation state fuel) + _ = Pr[= true | LazyRevealProbe.experiment state fuel computation] := + probEvent_detailedExperimentClean_none_eq_hit computation state fuel hbound + _ ≤ _ := by + rw [← probEvent_eq_eq_probOutput] + exact LazyRevealProbe.experiment_probability_le_expectedProbeCharge_unmaterialized state fuel computation + +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_sampledMaterializedCleanBoundaryFailure_le_charge + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (state : LazyRevealProbe.State Coordinate) (fuel bound : Nat) + (cache : SplitHashCache) + (hbound : ∀ table, + StartTableAgrees state table → + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + computation).IsQueryBoundP (fun query => query matches Sum.inr _) bound) + (hbudget : bound ≤ fuel) + (hpublished : PublishedValues state) : + Pr[= true | + sampledMaterializedCleanBoundaryFailure parameter root ftsSecret computation state fuel + cache] ≤ + (materializedBoundaryCharge parameter root ftsSecret computation state fuel cache + + (state.unmaterializedPending.card : ENNReal)) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + induction computation using OracleComp.inductionOn generalizing state fuel bound cache with + | pure value => + have hdist : + 𝒟[Option.isNone <$> sampledRunThenFinalizeClean state fuel + (pure (value, cache) : OracleComp (LazyRevealProbe.World Coordinate) + (α × SplitHashCache))] = + 𝒟[sampledMaterializedCleanBoundaryFailure parameter root ftsSecret + (pure value) state fuel cache] := by + unfold sampledRunThenFinalizeClean sampledMaterializedCleanBoundaryFailure + materializedCleanBoundaryFailureFromTable + rw [map_bind] + apply evalDist_bind_congr + intro base _hbase + rw [runCleanFromTable_pure_oracle] + simp [materializedCleanBoundary] + calc + _ = Pr[= true | Option.isNone <$> sampledRunThenFinalizeClean state fuel + (pure (value, cache) : OracleComp (LazyRevealProbe.World Coordinate) + (α × SplitHashCache))] := + OracleComp.probOutput_congr rfl hdist.symm + _ = Pr[= none | sampledRunThenFinalizeClean state fuel + (pure (value, cache) : OracleComp (LazyRevealProbe.World Coordinate) + (α × SplitHashCache))] := by + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput, probEvent_map] + apply OracleComp.probEvent_congr' + · intro result _hresult + cases result <;> simp + · rfl + _ ≤ _ := probEvent_sampledRunThenFinalizeClean_none_le_unmaterializedCharge + (pure (value, cache) : OracleComp (LazyRevealProbe.World Coordinate) + (α × SplitHashCache)) state fuel (by simp) + | query_bind query next ih => + rw [materializedBoundaryCharge_query_bind] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + have hinnerBound : ((splitUniformImpl n).run cache).IsQueryBoundP + LazyRevealProbe.IsProbe 0 := splitUniformImpl_probeFree n cache + have hstep := evalDist_sampledCleanStep_eq_safeSupportedGuardedContinuation + parameter root ftsSecret next (splitUniformImpl n) state fuel cache 0 bound + (fun _ _ ↦ True) hpublished hinnerBound + (preservesPublishedValuesImpl_splitUniformImpl n) (by simp) (by omega) + have hdist : + 𝒟[sampledMaterializedCleanBoundaryFailure parameter root ftsSecret + ((liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (.inl (.inl n)))) >>= next) state fuel cache] = + 𝒟[runDirectDetailedSafeOrdinaryWithCompletionTable + (supportedGuardedMaterializedCleanContinuation parameter root ftsSecret next + bound state (fun _ _ ↦ True)) + (directDeferredContext state) fuel ((splitUniformImpl n).run cache)] := by + calc + _ = 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable state base + let result ← runCleanFromTable state fuel table + ((splitUniformImpl n).run cache) + finishCleanFailureObserve + (fun nextTable nextState remaining value => + materializedCleanBoundaryFailureFromTable parameter root ftsSecret + (next (value : Fin (n + 1) × SplitHashCache).1) nextState remaining + nextTable value.2) + result] := by + unfold sampledMaterializedCleanBoundaryFailure + apply evalDist_bind_congr + intro base _hbase + exact materializedCleanBoundaryFailureFromTable_uniform_query_bind parameter + root ftsSecret n next state fuel (completedStartTable state base) cache + (startTableAgrees_completedStartTable state base) + _ = _ := hstep + calc + _ = Pr[= true | runDirectDetailedSafeOrdinaryWithCompletionTable + (supportedGuardedMaterializedCleanContinuation parameter root ftsSecret next + bound state (fun _ _ ↦ True)) + (directDeferredContext state) fuel ((splitUniformImpl n).run cache)] := + OracleComp.probOutput_congr rfl hdist + _ ≤ _ := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_safeOrdinary_le_continuationCharge + intro nextContext remaining value + rw [probEvent_eq_eq_probOutput] + by_cases hguard : PublishedValues nextContext.state ∧ bound ≤ remaining ∧ + LazyRevealProbe.ValuesLE state nextContext.state + · rcases hguard with ⟨hnextPublished, hnextBudget, hvalues⟩ + have hinitial : ∀ base, + StartTableAgrees state (completedStartTable nextContext.state base) := by + intro base index output hvalue + exact startTableAgrees_completedStartTable nextContext.state base index output + (hvalues index.coordinate output hvalue) + simpa [supportedGuardedMaterializedCleanContinuation, hnextPublished, + hnextBudget, hvalues, hinitial, + startTableAgrees_completedStartTable, + sampledMaterializedCleanBoundaryFailure] using + (ih value.1 nextContext.state remaining bound value.2 + (by + intro table hagrees + have hinitial' : StartTableAgrees state table := by + intro index output hvalue + exact hagrees index output (hvalues index.coordinate output hvalue) + have hsource := hbound table hinitial' + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hsource + exact hsource.2 value.1) + hnextBudget hnextPublished) + · have hcondition : ∀ base, + ¬(PublishedValues nextContext.state ∧ bound ≤ remaining ∧ + LazyRevealProbe.ValuesLE state nextContext.state ∧ + StartTableAgrees state + (completedStartTable nextContext.state base) ∧ + StartTableAgrees nextContext.state + (completedStartTable nextContext.state base) ∧ True) := by + intro base hfull + exact hguard ⟨hfull.1, hfull.2.1, hfull.2.2.1⟩ + simp only [supportedGuardedMaterializedCleanContinuation] + simp_rw [if_neg (hcondition _)] + have hdist : 𝒟[(do + let _base ← sampleOtsHashTable + pure false : ProbComp Bool)] = 𝒟[(pure false : ProbComp Bool)] := + evalDist_sampleOtsHashTable_bind_const _ + have hpure : Pr[= true | (pure false : ProbComp Bool)] ≤ + (materializedBoundaryCharge parameter root ftsSecret (next value.1) nextContext.state remaining value.2 + (nextContext.state.unmaterializedPending.card : ENNReal)) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + simpa only [probOutput_pure, Bool.true_eq_false, ↓reduceIte] using + (zero_le : (0 : ENNReal) ≤ + (materializedBoundaryCharge parameter root ftsSecret (next value.1) nextContext.state remaining value.2 + (nextContext.state.unmaterializedPending.card : ENNReal)) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + exact (OracleComp.probOutput_congr rfl hdist).le.trans hpure + | inr input => + let publicState := canonicalPublicProbeState state + let plan := purePlanProbingHashQuery parameter input publicState + let inner := probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan + let nextBound := bound - 1 + have hpositive : 0 < bound := by + let table := completedStartTable state (fun _ ↦ 0) + have hsource := hbound table (startTableAgrees_completedStartTable state _) + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hsource + rcases hsource.1 with hnot | hpositive + · exact (hnot (by simp)).elim + · exact hpositive + have hinnerBound : (inner.run cache).IsQueryBoundP + LazyRevealProbe.IsProbe 1 := + probingHashQueryAfterRootAwarePublicPlan_isProbeBound_one parameter input + publicState plan cache + have hstep := evalDist_sampledCleanStep_eq_safeSupportedGuardedContinuation + parameter root ftsSecret next inner state fuel cache 1 nextBound + (fun _ _ ↦ True) hpublished hinnerBound + (preservesPublishedValues_probingHashQueryAfterRootAwarePublicPlan parameter input + publicState plan) + (by simp) + (by dsimp only [nextBound]; omega) + have hdist : + 𝒟[sampledMaterializedCleanBoundaryFailure parameter root ftsSecret + ((liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (.inl (.inr input)))) >>= next) state fuel cache] = + 𝒟[runDirectDetailedSafeOrdinaryWithCompletionTable + (supportedGuardedMaterializedCleanContinuation parameter root ftsSecret next + nextBound state (fun _ _ ↦ True)) + (directDeferredContext state) fuel (inner.run cache)] := by + calc + _ = 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable state base + let result ← runCleanFromTable state fuel table (inner.run cache) + finishCleanFailureObserve + (fun nextTable nextState remaining value => + materializedCleanBoundaryFailureFromTable parameter root ftsSecret + (next (value : HashOutput × SplitHashCache).1) nextState remaining + nextTable value.2) + result] := by + unfold sampledMaterializedCleanBoundaryFailure + apply evalDist_bind_congr + intro base _hbase + simpa only [publicState, plan, inner] using + (materializedCleanBoundaryFailureFromTable_hash_query_bind parameter root + ftsSecret input next state fuel (completedStartTable state base) cache + (startTableAgrees_completedStartTable state base) hpublished) + _ = _ := hstep + calc + _ = Pr[= true | runDirectDetailedSafeOrdinaryWithCompletionTable + (supportedGuardedMaterializedCleanContinuation parameter root ftsSecret next + nextBound state (fun _ _ ↦ True)) + (directDeferredContext state) fuel (inner.run cache)] := + OracleComp.probOutput_congr rfl hdist + _ ≤ _ := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_safeOrdinary_le_continuationCharge + intro nextContext remaining value + rw [probEvent_eq_eq_probOutput] + by_cases hguard : PublishedValues nextContext.state ∧ + nextBound ≤ remaining ∧ + LazyRevealProbe.ValuesLE state nextContext.state + · rcases hguard with ⟨hnextPublished, hnextBudget, hvalues⟩ + have hinitial : ∀ base, + StartTableAgrees state (completedStartTable nextContext.state base) := by + intro base index output hvalue + exact startTableAgrees_completedStartTable nextContext.state base index output + (hvalues index.coordinate output hvalue) + simpa [supportedGuardedMaterializedCleanContinuation, hnextPublished, + hnextBudget, hvalues, hinitial, + startTableAgrees_completedStartTable, + sampledMaterializedCleanBoundaryFailure] using + (ih value.1 nextContext.state remaining nextBound value.2 + (by + intro table hagrees + have hinitial' : StartTableAgrees state table := by + intro index output hvalue + exact hagrees index output (hvalues index.coordinate output hvalue) + have hsource := hbound table hinitial' + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hsource + dsimp only [nextBound] + simpa using hsource.2 value.1) + hnextBudget hnextPublished) + · have hcondition : ∀ base, + ¬(PublishedValues nextContext.state ∧ nextBound ≤ remaining ∧ + LazyRevealProbe.ValuesLE state nextContext.state ∧ + StartTableAgrees state + (completedStartTable nextContext.state base) ∧ + StartTableAgrees nextContext.state + (completedStartTable nextContext.state base) ∧ True) := by + intro base hfull + exact hguard ⟨hfull.1, hfull.2.1, hfull.2.2.1⟩ + simp only [supportedGuardedMaterializedCleanContinuation] + simp_rw [if_neg (hcondition _)] + have hdist : 𝒟[(do + let _base ← sampleOtsHashTable + pure false : ProbComp Bool)] = 𝒟[(pure false : ProbComp Bool)] := + evalDist_sampleOtsHashTable_bind_const _ + have hpure : Pr[= true | (pure false : ProbComp Bool)] ≤ + (materializedBoundaryCharge parameter root ftsSecret (next value.1) nextContext.state remaining value.2 + (nextContext.state.unmaterializedPending.card : ENNReal)) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + simpa only [probOutput_pure, Bool.true_eq_false, ↓reduceIte] using + (zero_le : (0 : ENNReal) ≤ + (materializedBoundaryCharge parameter root ftsSecret (next value.1) nextContext.state remaining value.2 + (nextContext.state.unmaterializedPending.card : ENNReal)) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + exact (OracleComp.probOutput_congr rfl hdist).le.trans hpure + | inr message => + have hinnerBound : ((maskedSign parameter root ftsSecret message).run cache).IsQueryBoundP + LazyRevealProbe.IsProbe 0 := + maskedSign_probeFree parameter root ftsSecret message cache + let admissible := fun (finalState : LazyRevealProbe.State Coordinate) + (output : (OracleWorld + SigningSpec).Range (.inr message)) ↦ ∀ table, + StartTableAgrees finalState table → + output ∈ support + (scheme.sign + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey) + message) + have hstep := evalDist_sampledCleanStep_eq_safeSupportedGuardedContinuation + parameter root ftsSecret next (maskedSign parameter root ftsSecret message) + state fuel cache 0 bound admissible hpublished hinnerBound + (preservesPublishedValues_maskedSign parameter root ftsSecret message) + (by + intro table result _hstarts hresult nextTable hnextStarts + have hraw := mem_support_runRaw_done_of_mem_runCleanFromTable_some + ((maskedSign parameter root ftsSecret message).run cache) state fuel table result + hresult + exact maskedSign_done_output_mem_support parameter root nextTable ftsSecret message + state result.state cache result.value.2 fuel result.remaining result.value.1 + hnextStarts hraw) + (by omega) + have hdist : + 𝒟[sampledMaterializedCleanBoundaryFailure parameter root ftsSecret + ((liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (.inr message))) >>= next) state fuel cache] = + 𝒟[runDirectDetailedSafeOrdinaryWithCompletionTable + (supportedGuardedMaterializedCleanContinuation parameter root ftsSecret next + bound state admissible) + (directDeferredContext state) fuel + ((maskedSign parameter root ftsSecret message).run cache)] := by + calc + _ = 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable state base + let result ← runCleanFromTable state fuel table + ((maskedSign parameter root ftsSecret message).run cache) + finishCleanFailureObserve + (fun nextTable nextState remaining value => + materializedCleanBoundaryFailureFromTable parameter root ftsSecret + (next (value : Option Signature × SplitHashCache).1) nextState remaining + nextTable value.2) + result] := by + unfold sampledMaterializedCleanBoundaryFailure + apply evalDist_bind_congr + intro base _hbase + exact materializedCleanBoundaryFailureFromTable_sign_query_bind parameter root + ftsSecret message next state fuel (completedStartTable state base) cache + (startTableAgrees_completedStartTable state base) + _ = _ := hstep + calc + _ = Pr[= true | runDirectDetailedSafeOrdinaryWithCompletionTable + (supportedGuardedMaterializedCleanContinuation parameter root ftsSecret next + bound state admissible) + (directDeferredContext state) fuel + ((maskedSign parameter root ftsSecret message).run cache)] := + OracleComp.probOutput_congr rfl hdist + _ ≤ _ := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_safeOrdinary_le_continuationCharge + intro nextContext remaining value + rw [probEvent_eq_eq_probOutput] + by_cases hguard : PublishedValues nextContext.state ∧ bound ≤ remaining ∧ + LazyRevealProbe.ValuesLE state nextContext.state ∧ + admissible nextContext.state value.1 + · rcases hguard with + ⟨hnextPublished, hnextBudget, hvalues, hallowed⟩ + have hinitial : ∀ base, + StartTableAgrees state (completedStartTable nextContext.state base) := by + intro base index output hvalue + exact startTableAgrees_completedStartTable nextContext.state base index output + (hvalues index.coordinate output hvalue) + simpa [supportedGuardedMaterializedCleanContinuation, hnextPublished, + hnextBudget, hvalues, hinitial, startTableAgrees_completedStartTable, + hallowed, sampledMaterializedCleanBoundaryFailure] using + (ih value.1 nextContext.state remaining bound value.2 + (by + intro table hagrees + have hinitial' : StartTableAgrees state table := by + intro index output hvalue + exact hagrees index output (hvalues index.coordinate output hvalue) + have hsource := hbound table hinitial' + rw [simulateQ_expandedAdversaryImpl_query_bind_inr] at hsource + exact isQueryBoundP_of_bind hsource value.1 (hallowed table hagrees)) + hnextBudget hnextPublished) + · have hcondition : ∀ base, + ¬(PublishedValues nextContext.state ∧ bound ≤ remaining ∧ + LazyRevealProbe.ValuesLE state nextContext.state ∧ + StartTableAgrees state (completedStartTable nextContext.state base) ∧ + StartTableAgrees nextContext.state + (completedStartTable nextContext.state base) ∧ + admissible nextContext.state value.1) := by + intro base hfull + exact hguard + ⟨hfull.1, hfull.2.1, hfull.2.2.1, hfull.2.2.2.2.2⟩ + simp only [supportedGuardedMaterializedCleanContinuation] + simp_rw [if_neg (hcondition _)] + have hdist : 𝒟[(do + let _base ← sampleOtsHashTable + pure false : ProbComp Bool)] = 𝒟[(pure false : ProbComp Bool)] := + evalDist_sampleOtsHashTable_bind_const _ + have hpure : Pr[= true | (pure false : ProbComp Bool)] ≤ + (materializedBoundaryCharge parameter root ftsSecret (next value.1) nextContext.state remaining value.2 + (nextContext.state.unmaterializedPending.card : ENNReal)) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + simpa only [probOutput_pure, Bool.true_eq_false, ↓reduceIte] using + (zero_le : (0 : ENNReal) ≤ + (materializedBoundaryCharge parameter root ftsSecret (next value.1) nextContext.state remaining value.2 + (nextContext.state.unmaterializedPending.card : ENNReal)) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + exact (OracleComp.probOutput_congr rfl hdist).le.trans hpure + + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeMaterializedRootCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeMaterializedRootCharge.lean new file mode 100644 index 00000000..5f290a02 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeMaterializedRootCharge.lean @@ -0,0 +1,95 @@ +import SphincsSecurity.Proof.OtsProbeNativeComputedRootMaterialization + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def MaterializedHiddenEncodingRootQuery (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) : Prop := + ∃ (candidate : Probe) (target : Position), + EncodingLayerRootCandidateAt parameter input candidate ∧ candidate.coordinate = .position target ∧ + (context.state.values (.position target)).isSome = true ∧ .position target ∉ context.state.revealed + +theorem MaterializedHiddenEncodingRootQuery.known + {parameter : PublicParameter} {input : HashInput} {context : DeferredContext} + (h : MaterializedHiddenEncodingRootQuery parameter input context) : + KnownHiddenEncodingRootQuery parameter input context := by + obtain ⟨candidate, target, hcandidate, hposition, hvalue, hhidden⟩ := h + cases hstate : context.state.values (.position target) with + | none => simp [hstate] at hvalue + | some output => + exact ⟨candidate, target, output, hcandidate, hposition, + by simp [DeferredContext.positionValue, hstate], hhidden⟩ + +theorem materializedHiddenEncodingRootQuery_iff_known + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) + (hmat : LayerRootsMaterialized context) : + MaterializedHiddenEncodingRootQuery parameter input context ↔ KnownHiddenEncodingRootQuery parameter input context := by + refine ⟨fun h => h.known, ?_⟩ + rintro ⟨candidate, target, output, hcandidate, hposition, hvalue, hhidden⟩ + obtain ⟨rootPosition, hcoordinate, hroot⟩ := encodingLayerRootCandidateAt_isLayerRoot hcandidate + have heq : rootPosition = target := Coordinate.position.inj (hcoordinate.symm.trans hposition) + subst rootPosition + refine ⟨candidate, target, hcandidate, hposition, ?_, hhidden⟩ + rw [hmat.state_value_of_known target hroot output hvalue] + rfl + +theorem materializedHiddenEncodingRootQuery_replaceNativePosition + (parameter : PublicParameter) (input : HashInput) (target : Position) (output : HashOutput) (context : DeferredContext) : + MaterializedHiddenEncodingRootQuery parameter input (replaceNativePosition target output context) ↔ + MaterializedHiddenEncodingRootQuery parameter input context := by + simp only [MaterializedHiddenEncodingRootQuery, ← replaceNativePosition_values_isSome target output context] + rfl + +noncomputable def materializedEncodingRootOuterCharge (parameter : PublicParameter) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (_fuel : Nat) (_cache : SplitHashCache) : ENNReal := + match input with + | .inl (.inr input) => if MaterializedHiddenEncodingRootQuery parameter input context then 4 / 3 else 0 + | _ => 0 + +theorem materializedEncodingRootOuterCharge_le_known + (parameter : PublicParameter) (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + materializedEncodingRootOuterCharge parameter input context fuel cache ≤ + knownEncodingRootOuterCharge parameter input context fuel cache := by + cases input with + | inl query => + cases query with + | inl n => rfl + | inr input => + simp only [materializedEncodingRootOuterCharge, knownEncodingRootOuterCharge] + split_ifs with hmat hknown hknown + · rfl + · exact False.elim (hknown hmat.known) + · exact zero_le + · rfl + | inr message => rfl + +theorem materializedEncodingRootOuterCharge_eq_known + (parameter : PublicParameter) (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (hmat : LayerRootsMaterialized context) : + materializedEncodingRootOuterCharge parameter input context fuel cache = + knownEncodingRootOuterCharge parameter input context fuel cache := by + cases input with + | inl query => + cases query with + | inl n => rfl + | inr input => simp only [materializedEncodingRootOuterCharge, knownEncodingRootOuterCharge, + materializedHiddenEncodingRootQuery_iff_known parameter input context hmat] + | inr message => rfl + +theorem materializedEncodingRootOuterCharge_replaceNativePosition + (parameter : PublicParameter) (input : (OracleWorld + SigningSpec).Domain) + (target : Position) (output : HashOutput) (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + materializedEncodingRootOuterCharge parameter input (replaceNativePosition target output context) fuel cache = + materializedEncodingRootOuterCharge parameter input context fuel cache := by + cases input with + | inl query => + cases query with + | inl n => rfl + | inr input => simp only [materializedEncodingRootOuterCharge, materializedHiddenEncodingRootQuery_replaceNativePosition] + | inr message => rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeMaterializedRootReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeMaterializedRootReserve.lean new file mode 100644 index 00000000..ef475deb --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeMaterializedRootReserve.lean @@ -0,0 +1,99 @@ +import SphincsSecurity.Proof.OtsProbeRootMaterializationChronological +import SphincsSecurity.Proof.OtsProbeNativeQueryTraceProjection +import SphincsSecurity.Proof.OtsProbeNativeRootJointReserve + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +theorem canonicalTraceCharge_materialized_eq_known + (parameter : PublicParameter) (history : List CanonicalQuerySelection) + (hmat : ∀ selection ∈ history, LayerRootsMaterialized selection.context) : + canonicalTraceCharge (materializedEncodingRootOuterCharge parameter) history = + canonicalTraceCharge (knownEncodingRootOuterCharge parameter) history := by + unfold canonicalTraceCharge + apply congrArg List.sum + apply List.map_congr_left + intro selection hselection + exact materializedEncodingRootOuterCharge_eq_known parameter selection.input selection.context selection.fuel selection.cache + (hmat selection hselection) + +theorem expectedLiveMaterializedRootCharge_eq_known + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hmat : LayerRootsMaterialized context) (hclosed : DeferredComputationsClosed context) : + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (materializedEncodingRootOuterCharge parameter) computation context fuel table cache = + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (knownEncodingRootOuterCharge parameter) computation context fuel table cache := by + rw [← expectedNativeTraceCharge_eq, ← expectedNativeTraceCharge_eq] + apply tsum_congr + intro trace + by_cases htrace : trace ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache) + · rw [canonicalTraceCharge_materialized_eq_known parameter trace.2 + (layerRootsMaterialized_runNativeQueryTrace parameter root ftsSecret computation context fuel table cache trace hmat hclosed htrace).2] + · rw [probOutput_eq_zero_of_not_mem_support htrace] + simp + +theorem chronological_liveProbe_add_materializedRoots_le_refinedReserve + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) + (hmat : LayerRootsMaterialized context) : + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + (expectedLiveResolvedQueryCharge nativeProbeQueryCharge + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) context fuel table + + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (knownStructuralRootOuterCharge parameter) computation context fuel table cache) * (4 / 3 : ENNReal) + + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (materializedEncodingRootOuterCharge parameter) computation context fuel table cache ≤ + expectedQueryCharge (otsOpeningRefinedQueryReserve secretKey) + (simulateQ (expandedAdversaryImpl secretKey) computation) actualCache := by + dsimp only + rw [expectedLiveMaterializedRootCharge_eq_known parameter root ftsSecret computation context fuel table cache hmat hcomputed] + exact chronological_liveProbe_add_knownRoots_le_refinedReserve parameter root table ftsSecret computation context fuel cache actualCache + hinvariant hvisible hpublished hcomputed + +noncomputable def initializedMaterializedRootChargeAfterTable + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : ENNReal := + ∑' result, Pr[= result | runResolvedFromTable (ensuredInitialContext targets) fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)] * + match result with + | none => 0 + | some result => expectedLiveNativeContextCharge + (maskedChronologicalExpandedAdversaryImpl parameter result.value.1 ftsSecret) (materializedEncodingRootOuterCharge parameter) + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining table result.value.2 + +theorem initializedMaterializedRootChargeAfterTable_eq_known + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + initializedMaterializedRootChargeAfterTable targets adversary parameter table ftsSecret fuel = + initializedKnownRootChargeAfterTable targets adversary parameter table ftsSecret fuel := by + unfold initializedMaterializedRootChargeAfterTable initializedKnownRootChargeAfterTable + apply tsum_congr + intro result + cases result with + | none => rfl + | some result => + simp only + by_cases hresult : some result ∈ support + (runResolvedFromTable (ensuredInitialContext targets) fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)) + · have hmat := rootMaterializationPreserving_maskedPublishedTreeRoot (ensuredInitialContext targets) fuel table emptySplitHashCache result + (layerRootsMaterialized_ensuredInitialContext targets) (ensuredInitialContext_computed targets) hresult + have hclosed := (ensuredInitialContext_computed targets).of_mem_runResolved _ _ fuel table result hresult + rw [expectedLiveMaterializedRootCharge_eq_known parameter result.value.1 ftsSecret _ _ _ _ _ hmat hclosed] + · rw [probOutput_eq_zero_of_not_mem_support hresult] + simp + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeAfterRootAllowance.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeAfterRootAllowance.lean new file mode 100644 index 00000000..82d51adc --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeAfterRootAllowance.lean @@ -0,0 +1,86 @@ +import SphincsSecurity.Proof.OtsProbeNativeLiveAllowanceReserve + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot instFintypePosition +set_option backward.isDefEq.respectTransparency false + +theorem expected_nativeStartTraceCharge_eq_liveAllowance + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + (∑' trace, Pr[= trace | nativeChainTraceAfterRoot targets parameter table ftsSecret fuel + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)] * + canonicalTraceCharge (nativeStartCharge parameter table) trace.2) = + liveStartProbeAllowance (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + (ensuredInitialContext targets) fuel table := by + unfold nativeChainTraceAfterRoot nativeChronologicalRetainedComputation + rw [tsum_probOutput_bind_mul, liveStartProbeAllowance_bind _ _ (ensuredInitialContext targets) fuel table + (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table)), + liveStartProbeAllowance_eq_zero_of_probeFree _ _ fuel table (maskedPublishedTreeRoot_probeFree emptySplitHashCache), zero_add] + apply tsum_congr + intro root + by_cases hroot : root ∈ support (runResolvedFromTable (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) + · cases root with + | none => simp [startContinuationAllowance, canonicalTraceCharge] + | some root => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ (ensuredInitialContext targets) fuel table root + (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table)) hroot + simp only [startContinuationAllowance, hcore.1, expectedNativeTraceCharge_eq] + rw [startAllowance_chronological_eq_nativeCharge parameter root.value.1 ftsSecret _ root.context root.remaining table root.value.2 + hcore.2.1 hcore.2.2] + · simp [probOutput_eq_zero_of_not_mem_support hroot] + +theorem expected_nativeStructuralTraceCharge_eq_liveAllowance + (targets : Finset Position) (target : Position) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + (∑' trace, Pr[= trace | nativeChainTraceAfterRoot targets parameter table ftsSecret fuel + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)] * + canonicalTraceCharge (nativeMissingStructuralCharge target parameter table) trace.2) = + privateLiveMissingProbeAllowance target (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + (ensuredInitialContext targets) fuel table := by + unfold nativeChainTraceAfterRoot nativeChronologicalRetainedComputation + rw [tsum_probOutput_bind_mul, privateLiveMissingProbeAllowance_bind target _ _ (ensuredInitialContext targets) fuel table + (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table)), + privateLiveMissingProbeAllowance_eq_zero_of_probeFree target _ _ fuel table (maskedPublishedTreeRoot_probeFree emptySplitHashCache), zero_add] + apply tsum_congr + intro root + by_cases hroot : root ∈ support (runResolvedFromTable (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) + · cases root with + | none => simp [privateMissingContinuationAllowance, canonicalTraceCharge] + | some root => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ (ensuredInitialContext targets) fuel table root + (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table)) hroot + simp only [privateMissingContinuationAllowance, hcore.1, expectedNativeTraceCharge_eq] + rw [privateMissingAllowance_chronological_eq_nativeCharge target parameter root.value.1 ftsSecret _ root.context root.remaining table root.value.2 + hcore.2.1 hcore.2.2] + · simp [probOutput_eq_zero_of_not_mem_support hroot] + +theorem expected_nativeMissingTraceCharges_eq_liveAllowances + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + (∑' trace, Pr[= trace | nativeChainTraceAfterRoot targets parameter table ftsSecret fuel + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)] * + (canonicalTraceCharge (nativeStartCharge parameter table) trace.2 + + ∑ target ∈ targets, canonicalTraceCharge (nativeMissingStructuralCharge target parameter table) trace.2)) = + liveStartProbeAllowance (nativeChronologicalRetainedComputation adversary parameter ftsSecret) (ensuredInitialContext targets) fuel table + + ∑ target ∈ targets, privateLiveMissingProbeAllowance target + (nativeChronologicalRetainedComputation adversary parameter ftsSecret) (ensuredInitialContext targets) fuel table := by + simp only [mul_add, ENNReal.tsum_add] + rw [expected_nativeStartTraceCharge_eq_liveAllowance] + congr 1 + simp only [Finset.mul_sum] + rw [Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + apply Finset.sum_congr rfl + intro target _ + exact expected_nativeStructuralTraceCharge_eq_liveAllowance targets target adversary parameter table ftsSecret fuel + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeAfterRootRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeAfterRootRisk.lean new file mode 100644 index 00000000..8c8f99f1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeAfterRootRisk.lean @@ -0,0 +1,90 @@ +import SphincsSecurity.Proof.OtsProbeNativeAfterRootAllowance + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot instFintypePosition +set_option backward.isDefEq.respectTransparency false + +theorem expectedOutcomeRisk_probeFree_eq_initial + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcard : context.state.pending.card < Fintype.card Digest) : + (∑' result, Pr[= result | runResolvedFromTable context fuel table computation] * resolvedOutcomeFailureRisk result) = + resolvedContextFailureRisk table context := by + rw [← probEvent_finished_eq_expected_outcomeRisk] + have heq := probEvent_congr' (fun _ _ => Iff.rfl) + (evalDist_runResolvedFinishIsNone_probeFree_of_core computation context fuel table () hbound hconsistent hstarts hcard) + (p := fun verdict => verdict = true) + change Pr[fun verdict => verdict = true | runResolvedFinishIsNone context fuel table computation] = _ + rw [heq, finishResolvedRunIsNone_metadata_eq context table fuel 0 () ()] + rfl + +theorem expectedOutcomeRisk_initializedRoot_eq_zero + (targets : Finset Position) (table : OtsSecretIndex → HashOutput) (fuel : Nat) : + (∑' result, Pr[= result | runResolvedFromTable (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)] * resolvedOutcomeFailureRisk result) = 0 := by + have hstarts := startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table) + rw [expectedOutcomeRisk_probeFree_eq_initial _ (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) (ensuredInitialContext_valid targets).valuesConsistent hstarts + (by simp [ensuredInitialContext, LazyRevealProbe.State.empty])] + exact resolvedContextFailureRisk_of_no_pending table (ensuredInitialContext targets) (ensuredInitialContext_valid targets) hstarts + (by intro entry hentry; simp [ensuredInitialContext, LazyRevealProbe.State.empty] at hentry) + +theorem expectedNativeTerminalRisk_afterRoot_le_guessCharge + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + (∑' trace, Pr[= trace | nativeChainTraceAfterRoot targets parameter table ftsSecret fuel + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)] * resolvedOutcomeFailureRisk trace.1) ≤ + (∑' trace, Pr[= trace | nativeChainTraceAfterRoot targets parameter table ftsSecret fuel + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)] * + canonicalTraceCharge (canonicalGuessCharge parameter table) trace.2) := by + have hbound : + (∑' trace, Pr[= trace | nativeChainTraceAfterRoot targets parameter table ftsSecret fuel + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)] * resolvedOutcomeFailureRisk trace.1) ≤ + (∑' result, Pr[= result | runResolvedFromTable (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)] * resolvedOutcomeFailureRisk result) + + (∑' trace, Pr[= trace | nativeChainTraceAfterRoot targets parameter table ftsSecret fuel + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)] * + canonicalTraceCharge (canonicalGuessCharge parameter table) trace.2) := by + simp only [nativeChainTraceAfterRoot, tsum_probOutput_bind_mul] + rw [← ENNReal.tsum_add] + apply ENNReal.tsum_le_tsum + intro root + by_cases hroot : root ∈ support (runResolvedFromTable (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) + · rw [← mul_add] + apply mul_le_mul_right + cases root with + | none => simp [canonicalTraceCharge, resolvedOutcomeFailureRisk] + | some root => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ (ensuredInitialContext targets) fuel table root + (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table)) hroot + simp only [resolvedOutcomeFailureRisk, hcore.1, expectedNativeTraceCharge_eq] + exact expectedNativeTerminalRisk_le_initial_add_guessCharge parameter root.value.1 table ftsSecret + (retainedGameRestComputation adversary ⟨root.value.1, parameter⟩) root.context root.remaining root.value.2 hcore.2.1 hcore.2.2 + · simp [probOutput_eq_zero_of_not_mem_support hroot] + simpa only [expectedOutcomeRisk_initializedRoot_eq_zero, zero_add] using hbound + +theorem expectedNativeTerminalRisk_afterRoot_le_missing_add_erasure + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + (∑' trace, Pr[= trace | nativeChainTraceAfterRoot Finset.univ parameter table ftsSecret (q + 1) + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)] * resolvedOutcomeFailureRisk trace.1) ≤ + liveStartProbeAllowance (nativeChronologicalRetainedComputation adversary parameter ftsSecret) (ensuredInitialContext Finset.univ) (q + 1) table + + (∑ target : Position, privateLiveMissingProbeAllowance target + (nativeChronologicalRetainedComputation adversary parameter ftsSecret) (ensuredInitialContext Finset.univ) (q + 1) table) + + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + have hbound := (expectedNativeTerminalRisk_afterRoot_le_guessCharge Finset.univ adversary parameter table ftsSecret (q + 1)).trans + (expected_nativeRetainedGuessCharge_le_missing_add_erasure Finset.univ adversary q hq hqMax parameter hparameter table ftsSecret hfts) + rw [expected_nativeMissingTraceCharges_eq_liveAllowances] at hbound + exact hbound + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeCandidateComponents.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeCandidateComponents.lean new file mode 100644 index 00000000..95623565 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeCandidateComponents.lean @@ -0,0 +1,86 @@ +import SphincsSecurity.Proof.OtsProbeNativeStartCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def materializedCandidateAllowance (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) : Option Probe → ENNReal + | none => 0 + | some candidate => if context.state.values candidate.coordinate = none then 0 + else candidateFailureAllowance table context (some candidate) + +theorem candidateFailureAllowance_eq_native_components + (targets : Finset Position) (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (candidate : Option Probe) + (hcoverage : ∀ target digest, candidate = some ⟨.position target, digest⟩ → target ∈ targets) : + candidateFailureAllowance table context candidate = + unresolvedStartCandidateAllowance table context candidate + + (∑ target ∈ targets, privateMissingCandidateAllowance target table context candidate) + + materializedCandidateAllowance table context candidate := by + cases candidate with + | none => simp [candidateFailureAllowance, unresolvedStartCandidateAllowance, + privateMissingCandidateAllowance, materializedCandidateAllowance] + | some candidate => + rcases candidate with ⟨coordinate, digest⟩ + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + by_cases hmissing : context.state.values (.chainStart lay tree leafIdx chainIdx) = none <;> + simp [unresolvedStartCandidateAllowance, privateMissingCandidateAllowance, + privateMissingProbeInputAllowance, privateProbeInputAllowance, materializedCandidateAllowance, hmissing] + | position position => + have hposition := hcoverage position digest rfl + have hsum : (∑ target ∈ targets, privateMissingCandidateAllowance target table context + (some ⟨.position position, digest⟩)) = + if context.state.values (.position position) = none then + candidateFailureAllowance table context (some ⟨.position position, digest⟩) else 0 := by + rw [Finset.sum_eq_single position] + · simp [privateMissingCandidateAllowance, privateMissingProbeInputAllowance, privateProbeInputAllowance] + · intro target _ hne + simp [privateMissingCandidateAllowance, privateMissingProbeInputAllowance, privateProbeInputAllowance, Ne.symm hne] + · simp [hposition] + rw [hsum] + by_cases hmissing : context.state.values (.position position) = none <;> + simp [unresolvedStartCandidateAllowance, materializedCandidateAllowance, hmissing] + +theorem candidateFailureAllowance_le_one + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) (candidate : Option Probe) : + candidateFailureAllowance table context candidate ≤ 1 := by + cases candidate with + | none => simp [candidateFailureAllowance] + | some candidate => + simp only [candidateFailureAllowance] + split_ifs + · exact bot_le + · split + · norm_num [digestBits] + · split_ifs <;> simp + +theorem materializedCandidateAllowance_le_one + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) (candidate : Option Probe) : + materializedCandidateAllowance table context candidate ≤ 1 := by + cases candidate with + | none => simp [materializedCandidateAllowance] + | some candidate => + simp only [materializedCandidateAllowance] + split_ifs + · exact bot_le + · exact candidateFailureAllowance_le_one table context _ + +theorem materializedCandidateAllowance_plan_eq_zero_of_chainsPublished + (parameter : PublicParameter) (input : HashInput) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (hpublic : MaterializedChainsPublished context) : + materializedCandidateAllowance table context + (purePlanProbingHashQuery parameter input context.state).candidate? = 0 := by + cases hplan : (purePlanProbingHashQuery parameter input context.state).candidate? with + | none => rfl + | some candidate => + simp only [materializedCandidateAllowance] + split_ifs with hmissing + · rfl + · exact hpublic.candidate_allowance_eq_zero_of_known parameter input candidate table hplan hmissing + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeCandidateRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeCandidateRisk.lean new file mode 100644 index 00000000..da0dca64 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeCandidateRisk.lean @@ -0,0 +1,148 @@ +import SphincsSecurity.Proof.OtsProbeNativeRiskAccumulation + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem probEvent_privateResolutionResult_candidate_eq_resolver + (target : Position) (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (remaining : Nat) (value : α) (candidate : Digest) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) : + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (fun _ _ => some candidate) <$> + privateResolutionResult target table context remaining value] = + Pr[PrivateCandidatePairHit | (fun option => option.map (fun result => (result.output, candidate))) <$> + resolveDeferredPositionValue target context] := by + rw [probEvent_map, privateResolutionResult, probEvent_bind_eq_tsum, probEvent_map, probEvent_eq_tsum_ite] + apply tsum_congr + intro option + by_cases hoption : option ∈ support (resolveDeferredPositionValue target context) + · cases option with + | none => simp [privateResolvedSelectedCandidate, PrivateCandidatePairHit] + | some result => + have hnext := hcomplete.of_resolveDeferredPositionValue hvalid target result hoption + have hvalue := resolveDeferredPositionValue_resolves target context result hoption + simp [hnext, privateResolvedSelectedCandidate, hvalue, PrivateCandidatePairHit] + · simp [probOutput_eq_zero_of_not_mem_support hoption] + +theorem candidateFailureAllowance_position_eq_resolutionHit + (target : Position) (table : OtsSecretIndex → HashOutput) (context : DeferredContext) (candidate : Digest) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hhidden : .position target ∉ context.state.revealed) : + candidateFailureAllowance table context (some ⟨.position target, candidate⟩) = + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (fun _ (_ : Unit) => some candidate) <$> + privateResolutionResult target table context 0 ()] := by + rw [probEvent_privateResolutionResult_candidate_eq_resolver target table context 0 () candidate hvalid hcomplete, + resolveDeferredPositionValue_eq_bind_output, probEvent_map, probEvent_bind_eq_tsum] + have hterm (output : HashOutput) : + Pr[fun option => PrivateCandidatePairHit (option.map (fun result => (result.output, candidate))) | + resolvePrivatePositionWithOutput target context output] = + if candidate = truncateHash output ∧ (.position target, candidate) ∉ context.state.pending then 1 else 0 := by + by_cases hhit : context.state.hitAt (.position target) output + · by_cases heq : candidate = truncateHash output + · have hpending : (.position target, candidate) ∈ context.state.pending := by + rw [heq, ← LazyRevealProbe.State.mem_pendingAt_iff] + exact hhit + simp [resolvePrivatePositionWithOutput, hhit, PrivateCandidatePairHit, hpending] + · simp [resolvePrivatePositionWithOutput, hhit, PrivateCandidatePairHit, heq] + · by_cases heq : candidate = truncateHash output + · have hpending : (.position target, candidate) ∉ context.state.pending := by + rw [heq, ← LazyRevealProbe.State.mem_pendingAt_iff] + exact hhit + have hpending' : (.position target, truncateHash output) ∉ context.state.pending := by simpa only [heq] using hpending + simp [resolvePrivatePositionWithOutput, hhit, completePrivatePosition, PrivateCandidatePairHit, heq, hpending'] + · simp [resolvePrivatePositionWithOutput, hhit, completePrivatePosition, PrivateCandidatePairHit, heq] + simp_rw [Function.comp_def, hterm] + by_cases hduplicate : (.position target, candidate) ∈ context.state.pending + · simp [candidateFailureAllowance, hduplicate] + · simp only [candidateFailureAllowance, hhidden, hduplicate, or_self, ↓reduceIte, not_false_eq_true, and_true] + simp only [mul_ite, mul_one, mul_zero] + rw [← probEvent_eq_tsum_ite] + cases hvalue : context.positionValue target with + | none => + simp only [resolvedCompletionValue, hvalue, deferredPositionOutput] + simpa only [show Fintype.card Digest = 2 ^ digestBits by simp, LazyRevealProbe.sampleHashOutput, eq_comm] using + (SphincsSecurity.probEvent_uniform_truncateHash_eq candidate).symm + | some output => + simp [resolvedCompletionValue, hvalue, deferredPositionOutput, eq_comm] + +theorem privateResolutionResult_selected_eq_constant + (target : Position) (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (remaining : Nat) (value : α) (select : Nat → α → Option Digest) : + privateResolvedSelectedCandidate target select <$> privateResolutionResult target table context remaining value = + privateResolvedSelectedCandidate target (fun _ _ => select remaining value) <$> + privateResolutionResult target table context remaining value := by + unfold privateResolutionResult + simp only [map_bind] + congr 1 + funext option + cases option with + | none => rfl + | some result => + dsimp only + split_ifs <;> simp [privateResolvedSelectedCandidate] + +theorem probEvent_privateResolutionResult_selected_eq_allowance + (target : Position) (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (remaining : Nat) (value : α) (select : Nat → α → Option Digest) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hhidden : select remaining value ≠ none → .position target ∉ context.state.revealed) : + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target select <$> + privateResolutionResult target table context remaining value] = + candidateFailureAllowance table context ((select remaining value).map (fun digest => ⟨.position target, digest⟩)) := by + rw [privateResolutionResult_selected_eq_constant] + cases hselect : select remaining value with + | none => + have hnone : privateResolvedSelectedCandidate target (fun (_ : Nat) (_ : α) => none) = fun _ => none := by + funext option + cases option with + | none => rfl + | some pair => + rcases pair with ⟨final, rest, value⟩ + cases hv : final.positionValue target <;> simp [privateResolvedSelectedCandidate, hv] + rw [hnone, probEvent_map] + simp [PrivateCandidatePairHit, candidateFailureAllowance] + | some candidate => + rw [probEvent_privateResolutionResult_candidate_eq_resolver target table context remaining value candidate hvalid hcomplete] + simp only [Option.map_some] + rw [candidateFailureAllowance_position_eq_resolutionHit target table context candidate hvalid hcomplete (hhidden (by simp [hselect]))] + exact (probEvent_privateResolutionResult_candidate_eq_resolver target table context 0 () candidate hvalid hcomplete).symm + +theorem probEvent_privateResolvedView_selected_eq_expectedAllowance + (target : Position) (table : OtsSecretIndex → HashOutput) (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (select : Nat → α → Option Digest) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hhidden : ∀ result, some result ∈ support (runResolvedFromTable context fuel table computation) → + select result.remaining result.value ≠ none → .position target ∉ result.context.state.revealed) : + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target select <$> + runPrivateResolvedView target table context fuel computation] = + ∑' option, Pr[= option | runResolvedFromTable context fuel table computation] * + match option with + | none => 0 + | some result => if DeferredCompletable table result.context then + candidateFailureAllowance table result.context + ((select result.remaining result.value).map (fun digest => ⟨.position target, digest⟩)) else 0 := by + unfold runPrivateResolvedView + rw [map_bind, probEvent_bind_eq_tsum] + apply tsum_congr + intro option + by_cases hoption : option ∈ support (runResolvedFromTable context fuel table computation) + · cases option with + | none => simp [privateResolvedSelectedCandidate, PrivateCandidatePairHit] + | some result => + dsimp only + have hcore := resolvedCore_of_mem_runResolvedFromTable computation context fuel table result hconsistent hstarts hoption + by_cases hcomplete : DeferredCompletable table result.context + · rw [if_pos hcomplete, probEvent_privateResolutionResult_selected_eq_allowance target table result.context result.remaining result.value select + (valid_of_resolvedCore_completable table result.context hcore.2.1 hcore.2.2 hcomplete) hcomplete (hhidden result hoption)] + · have heq := evalDist_map_eq_of_evalDist_eq + (evalDist_privateResolutionResult_eq_none_of_not_completable target table result.context result.remaining result.value hcore.2.1 hcomplete) + (privateResolvedSelectedCandidate target select) + have hprob := probEvent_congr' (fun _ _ => Iff.rfl) heq (p := PrivateCandidatePairHit) + rw [hprob] + simp [hcomplete, privateResolvedSelectedCandidate, PrivateCandidatePairHit] + · simp [probOutput_eq_zero_of_not_mem_support hoption] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeChainBound.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeChainBound.lean new file mode 100644 index 00000000..d1c7ad85 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeChainBound.lean @@ -0,0 +1,128 @@ +import SphincsSecurity.Proof.OtsProbeNativeChainTrace +import SphincsSecurity.Proof.OtsProbeStartErasureBound + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +noncomputable def nativeChainTraceAfterRoot + (targets : Finset Position) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) : + ProbComp (Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) := do + let root ← runResolvedFromTable (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + match root with + | none => pure (none, []) + | some root => + runNativeQueryTrace parameter root.value.1 ftsSecret (continuation root.value.1) + root.context root.remaining root.table root.value.2 + +theorem relTriple_nativeChainTraceAfterRoot + (targets : Finset Position) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) : + RelTriple (nativeChainTraceAfterRoot targets parameter table ftsSecret fuel continuation) + ((simulateQ romImpl (concreteAfterRootComputation parameter table ftsSecret continuation)).run ∅) + NativeChainTraceRel := by + have hroot := reachableResolvedCouples_maskedPublishedTreeRoot parameter table (ensuredInitialContext targets) + fuel emptySplitHashCache ∅ (ensuredInitialContext_resolvedInvariant targets parameter table) + (ensuredInitialContext_visible targets parameter table) (ensuredInitialContext_published targets) + have hsupported := FtsProbeSimulation.relTriple_and_left_support hroot + (fun left => ∀ result, left = some result → MaterializedChainsPublished result.context) (by + intro left hleft result heq + subst left + exact materializedChainsPublished_of_mem_initializedRoot targets fuel table result hleft) + rw [nativeChainTraceAfterRoot, concreteAfterRootComputation, simulateQ_bind, StateT.run_bind, + simulateQ_romImpl_liftM] + apply relTriple_bind hsupported + intro left right hrel + rw [← simulateQ_unloggedMapped_eq_expanded] + cases left with + | none => + apply relTriple_nativeChainTrace_of_public + intro trace htrace + simp only [mem_support_pure_iff] at htrace + subst trace + exact ⟨by simp, by simp⟩ + | some result => + dsimp only + have hchain := hrel.2 result rfl + rcases hrel.1 with hclean | hdoomed + · rcases right with ⟨root, actualCache⟩ + have hvalue : result.value.1 = root := hclean.2.1 + subst root + rw [hclean.1] + exact relTriple_nativeTrace_chainPublication parameter result.value.1 table ftsSecret (continuation result.value.1) + result.context result.remaining result.value.2 actualCache hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 hchain + · rw [runNativeQueryTrace_of_not_completable parameter result.value.1 ftsSecret (continuation result.value.1) + result.context result.remaining result.table result.value.2 (by rw [hdoomed.1]; exact hdoomed.2.2.2)] + apply relTriple_nativeChainTrace_of_public + intro trace htrace + simp only [mem_support_pure_iff] at htrace + subst trace + exact ⟨by simp, by simp⟩ + +theorem probEvent_nativeChainTraceAfterRoot_failure_le_inv216 + (targets : Finset Position) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) : + Pr[fun trace => ¬NativeChainsPublished trace | nativeChainTraceAfterRoot targets parameter table ftsSecret fuel continuation] ≤ + ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + apply (probEvent_le_of_relTriple (relTriple_nativeChainTraceAfterRoot targets parameter table ftsSecret fuel continuation) + (p := fun trace => ¬NativeChainsPublished trace) (q := fun result => AnyEncodingInputsExhausted result.2) ?_).trans + (probEvent_anyEncodingInputsExhausted_le_inv216 (concreteAfterRootComputation parameter table ftsSecret continuation)) + intro trace result hrel hfailure + exact hrel.resolve_left hfailure + +def NativeMaterializedCandidateRisk (parameter : PublicParameter) + (trace : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) : Prop := + ∃ selection ∈ trace.2, ∃ input candidate, + selection.input = .inl (.inr input) ∧ + (purePlanProbingHashQuery parameter input selection.context.state).candidate? = some candidate ∧ + selection.context.state.values candidate.coordinate ≠ none ∧ + candidateFailureAllowance selection.table selection.context (some candidate) ≠ 0 + +theorem NativeMaterializedCandidateRisk.not_chainsPublished + {parameter : PublicParameter} + {trace : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection} + (hrisk : NativeMaterializedCandidateRisk parameter trace) : ¬NativeChainsPublished trace := by + obtain ⟨selection, hselection, input, candidate, _, hplan, hknown, hnonzero⟩ := hrisk + intro hpublic + exact hnonzero ((hpublic.2 selection hselection).candidate_allowance_eq_zero_of_known + parameter input candidate selection.table hplan hknown) + +theorem probEvent_nativeMaterializedCandidateRisk_afterRoot_le_inv216 + (targets : Finset Position) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) : + Pr[NativeMaterializedCandidateRisk parameter | nativeChainTraceAfterRoot targets parameter table ftsSecret fuel continuation] ≤ + ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + apply (probEvent_mono fun _ _ hrisk => hrisk.not_chainsPublished).trans + (probEvent_nativeChainTraceAfterRoot_failure_le_inv216 targets parameter table ftsSecret fuel continuation) + +noncomputable def sampledNativeChainTrace (targets : Finset Position) (adversary : Adversary) (fuel : Nat) : + ProbComp (Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)) × List CanonicalQuerySelection) := do + let parameter ← sampleParameter + let table ← sampleOtsHashTable + let ftsSecret ← sampleFtsSecrets + nativeChainTraceAfterRoot targets parameter table ftsSecret fuel fun root => + (fun rest => (root, rest)) <$> retainedGameRestComputation adversary ⟨root, parameter⟩ + +theorem probEvent_sampledNativeChainTrace_failure_le_inv216 + (targets : Finset Position) (adversary : Adversary) (fuel : Nat) : + Pr[fun trace => ¬NativeChainsPublished trace | sampledNativeChainTrace targets adversary fuel] ≤ + ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + unfold sampledNativeChainTrace + apply probEvent_bind_le_of_forall_le + intro parameter _ + apply probEvent_bind_le_of_forall_le + intro table _ + apply probEvent_bind_le_of_forall_le + intro ftsSecret _ + exact probEvent_nativeChainTraceAfterRoot_failure_le_inv216 targets parameter table ftsSecret fuel _ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeChainMaterialization.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeChainMaterialization.lean new file mode 100644 index 00000000..4983802d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeChainMaterialization.lean @@ -0,0 +1,146 @@ +import SphincsSecurity.Proof.OtsProbeNativeMaterializedCandidate + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec + +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +theorem MaterializedChainsPublished.of_public + {context : DeferredContext} (hpublic : MaterializedValuesPublished context.state) : + MaterializedChainsPublished context := by + intro coordinate _ hknown + obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hknown + exact hpublic coordinate output houtput + +theorem materializedChainsPublished_ensuredInitial (targets : Finset Position) : + MaterializedChainsPublished (ensuredInitialContext targets) := by + intro coordinate _ hknown + simp [ensuredInitialContext, LazyRevealProbe.State.empty] at hknown + +theorem materializedChainsPublished_of_mem_initializedRoot + (targets : Finset Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : ResolvedRunResult (Digest × SplitHashCache)) + (hresult : some result ∈ support (runResolvedFromTable (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache))) : MaterializedChainsPublished result.context := by + have hpreserves : ResolvedPreservesPublicMaterialization maskedPublishedTreeRoot := by + unfold maskedPublishedTreeRoot + exact (resolvedPreservesPublicMaterialization_ensureTreeNode topLayer rootTree (layerHeight topLayer) 0).bind + fun _ => resolvedPreservesPublicMaterialization_revealPublishedCoordinate _ + apply MaterializedChainsPublished.of_public + apply hpreserves _ emptySplitHashCache fuel table result _ hresult + intro coordinate output hvalue + simp [ensuredInitialContext, LazyRevealProbe.State.empty] at hvalue + +def ResolvedPreservesChainMaterialization + (computation : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ context cache fuel table result, MaterializedChainsPublished context → + some result ∈ support (runResolvedFromTable context fuel table (computation.run cache)) → + MaterializedChainsPublished result.context + +theorem ResolvedPreservesChainMaterialization.of_preservesCoordinate + {computation : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α} + (hpreserves : ∀ coordinate, ResolvedPreservesCoordinate coordinate computation) : + ResolvedPreservesChainMaterialization computation := by + intro context cache fuel table result hpublic hresult coordinate hchain hvalue + have hcoordinate := hpreserves coordinate context fuel table cache result hresult + exact hcoordinate.2.mpr (hpublic coordinate hchain (by rwa [hcoordinate.1] at hvalue)) + +theorem ResolvedPreservesChainMaterialization.pure (value : α) : + ResolvedPreservesChainMaterialization (pure value) := + .of_preservesCoordinate fun coordinate => resolvedPreservesCoordinate_pure coordinate value + +theorem ResolvedPreservesChainMaterialization.bind + {left : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : ResolvedPreservesChainMaterialization left) + (hnext : ∀ value, ResolvedPreservesChainMaterialization (next value)) : + ResolvedPreservesChainMaterialization (left >>= next) := by + intro context cache fuel table result hpublic hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨leftOption, hleftSupport, hrest⟩ := hresult + cases leftOption with + | none => simp at hrest + | some leftResult => + exact hnext leftResult.value.1 leftResult.context leftResult.value.2 leftResult.remaining + leftResult.table result (hleft context cache fuel table leftResult hpublic hleftSupport) hrest + +theorem resolvedPreservesChainMaterialization_reveal_publish (coordinate : Coordinate) : + ResolvedPreservesChainMaterialization (do + let output ← revealCoordinateOutput coordinate + publishCoordinate coordinate + pure output) := by + intro context cache fuel table result hpublic hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨revealOption, hreveal, hrest⟩ := hresult + cases revealOption with + | none => simp at hrest + | some revealResult => + simp only at hrest + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hrest + obtain ⟨publishOption, hpublish, hreturn⟩ := hrest + cases publishOption with + | none => simp at hreturn + | some publishResult => + simp [runResolvedFromTable] at hreturn + subst result + change some publishResult ∈ support (runResolvedFromTable revealResult.context + revealResult.remaining revealResult.table + (LazyRevealProbe.publishQuery coordinate >>= fun output => pure (output, revealResult.value.2))) at hpublish + rw [LazyRevealProbe.publishQuery, runResolvedFromTable_publish_query_bind] at hpublish + simp [runResolvedFromTable] at hpublish + subst publishResult + intro other hchain hvalue + by_cases heq : other = coordinate + · subst other + simp [LazyRevealProbe.State.publish] + · have hpreserved := resolvedPreservesCoordinate_revealCoordinateOutput_of_ne other coordinate heq + context fuel table cache revealResult hreveal + have hbefore : context.state.values other ≠ none := by + rw [← hpreserved.1] + exact hvalue + have hrevealed := hpreserved.2.mpr (hpublic other hchain hbefore) + simpa [LazyRevealProbe.State.publish, heq] using hrevealed + +theorem resolvedPreservesChainMaterialization_resolveKnownInput + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) : + ResolvedPreservesChainMaterialization (resolveKnownInput parameter coordinate input) := by + unfold resolveKnownInput + apply (ResolvedPreservesChainMaterialization.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_peekTableInput parameter other coordinate).bind + intro known + cases known with + | none => exact .of_preservesCoordinate fun other => resolvedPreservesCoordinate_splitHashQuery other (.ordinary input) + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + have hpreserves := (resolvedPreservesChainMaterialization_reveal_publish coordinate).bind fun output => + (ResolvedPreservesChainMaterialization.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_modify other fun cache => + Function.update cache (.ordinary input) (some output)).bind fun _ => + ResolvedPreservesChainMaterialization.pure output + simpa only [bind_assoc, pure_bind] using hpreserves + · simp only [heq, ↓reduceIte] + exact .of_preservesCoordinate fun other => resolvedPreservesCoordinate_splitHashQuery other (.ordinary input) + +theorem resolvedPreservesChainMaterialization_probingHashQuery + (parameter : PublicParameter) (input : HashInput) : + ResolvedPreservesChainMaterialization (probingHashQuery parameter input) := by + intro context cache fuel table result hpublic hresult + rw [runResolved_probingHashQuery_eq_afterPlan] at hresult + let plan := purePlanProbingHashQuery parameter input context.state + have hcandidate : ResolvedPreservesChainMaterialization (executeCandidate? plan.candidate?) := by + cases plan.candidate? with + | none => exact .pure () + | some candidate => exact .of_preservesCoordinate fun other => resolvedPreservesCoordinate_probe other candidate + have haction : ResolvedPreservesChainMaterialization (probingHashQueryAfterPlan parameter input plan) := by + unfold probingHashQueryAfterPlan executePlannedHashQuery + apply hcandidate.bind + intro _ + cases plan.action with + | ordinary => exact .of_preservesCoordinate fun other => resolvedPreservesCoordinate_splitHashQuery other (.ordinary input) + | resolve coordinate => exact resolvedPreservesChainMaterialization_resolveKnownInput parameter coordinate input + exact haction context cache fuel table result hpublic hresult + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeChainQuery.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeChainQuery.lean new file mode 100644 index 00000000..b2c3bc88 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeChainQuery.lean @@ -0,0 +1,86 @@ +import SphincsSecurity.Proof.OtsProbeSigningChainFailureCoupling + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +theorem relTriple_chainFailure_of_preserves + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (left : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) + (right : StateT (QueryCache HashSpec) ProbComp α) + (hbase : ReachableResolvedCouples parameter table left right) + (hpreserves : ResolvedPreservesChainMaterialization left) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) (hchain : MaterializedChainsPublished context) : + RelTriple (runResolvedFromTable context fuel table (left.run cache)) (right.run concreteCache) + (SigningChainFailureRunRel parameter table) := by + have hsupported := FtsProbeSimulation.relTriple_and_left_support + (hbase context fuel cache concreteCache hinvariant hvisible hpublished) + (fun result => result ∈ support (runResolvedFromTable context fuel table (left.run cache))) (fun _ h => h) + apply relTriple_post_mono hsupported + intro leftResult rightResult hrel + refine ⟨hrel.1, ?_⟩ + intro result heq _ + subst leftResult + exact Or.inl (hpreserves context cache fuel table result hchain hrel.2) + +theorem relTriple_nativeQuery_chainFailure + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) (hchain : MaterializedChainsPublished context) : + RelTriple + (runResolvedFromTable context fuel table ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache)) + ((unloggedMappedAdversaryImpl + ⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ input).run concreteCache) + (SigningChainFailureRunRel parameter table) := by + cases input with + | inl input => + apply relTriple_chainFailure_of_preserves parameter table _ _ + (reachableResolvedCouples_maskedChronologicalExpandedAdversaryImpl parameter root table ftsSecret _) _ + context fuel cache concreteCache hinvariant hvisible hpublished hchain + cases input with + | inl n => + exact .of_preservesCoordinate fun coordinate => resolvedPreservesCoordinate_splitUniformImpl coordinate n + | inr hashInput => exact resolvedPreservesChainMaterialization_probingHashQuery parameter hashInput + | inr message => + exact relTriple_sign_chainFailure_concrete parameter root table ftsSecret message context fuel cache concreteCache + hinvariant hvisible hpublished hchain + +def LiveChainPublicationFailure (table : OtsSecretIndex → HashOutput) : + Option (ResolvedRunResult (α × SplitHashCache)) → Prop + | none => False + | some result => DeferredCompletable table result.context ∧ ¬MaterializedChainsPublished result.context + +theorem SigningChainFailureRunRel.encoding_failure_of_chain_failure + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left : Option (ResolvedRunResult (α × SplitHashCache))} {right : α × QueryCache HashSpec} + (hrel : SigningChainFailureRunRel parameter table left right) (hfailure : LiveChainPublicationFailure table left) : + CachedOtsEncodingFailure right.2 := by + cases left with + | none => exact False.elim hfailure + | some result => exact (hrel.2 result rfl hfailure.1).resolve_left hfailure.2 + +theorem probEvent_nativeQuery_chainFailure_le_cachedFailure + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) (hchain : MaterializedChainsPublished context) : + Pr[LiveChainPublicationFailure table | runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache)] ≤ + Pr[fun result => CachedOtsEncodingFailure result.2 | (unloggedMappedAdversaryImpl + ⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ input).run concreteCache] := by + apply probEvent_le_of_relTriple (relTriple_nativeQuery_chainFailure parameter root table ftsSecret input context fuel + cache concreteCache hinvariant hvisible hpublished hchain) + intro left right hrel hfailure + exact hrel.encoding_failure_of_chain_failure hfailure + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeChainTrace.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeChainTrace.lean new file mode 100644 index 00000000..310a5295 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeChainTrace.lean @@ -0,0 +1,117 @@ +import SphincsSecurity.Proof.OtsProbeNativeChainQuery + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +def NativeChainsPublished (trace : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) : Prop := + (∀ result, trace.1 = some result → MaterializedChainsPublished result.context) ∧ + ∀ selection ∈ trace.2, MaterializedChainsPublished selection.context + +def NativeChainTraceRel + (left : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) + (right : α × QueryCache HashSpec) : Prop := + NativeChainsPublished left ∨ AnyEncodingInputsExhausted right.2 + +theorem relTriple_nativeChainTrace_of_public + (left : ProbComp (Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection)) + (right : ProbComp (α × QueryCache HashSpec)) + (hpublic : ∀ trace ∈ support left, NativeChainsPublished trace) : + RelTriple left right NativeChainTraceRel := by + apply relTriple_post_mono (FtsProbeSimulation.relTriple_and_left_support (relTriple_true left right) _ hpublic) + intro trace result hrel + exact Or.inl hrel.2 + +theorem relTriple_nativeChainTrace_of_exhausted + (left : ProbComp (Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection)) + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) (cache : QueryCache HashSpec) + (hexhausted : AnyEncodingInputsExhausted cache) : + RelTriple left ((simulateQ (unloggedMappedAdversaryImpl secretKey) computation).run cache) NativeChainTraceRel := by + apply relTriple_post_mono (FtsProbeSimulation.relTriple_and_right_support (relTriple_true left _)) + intro trace result hrel + exact Or.inr (hexhausted.mono (FtsProbeSimulation.simulateQ_unloggedMappedAdversaryImpl_cache_le + secretKey computation cache result.2 result.1 hrel.2)) + +theorem relTriple_nativeTrace_chainPublication + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) (hchain : MaterializedChainsPublished context) : + RelTriple (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache) + ((simulateQ (unloggedMappedAdversaryImpl + ⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩) + computation).run concreteCache) NativeChainTraceRel := by + induction computation using OracleComp.inductionOn generalizing context fuel cache concreteCache with + | pure value => + simp only [runNativeQueryTrace, OracleComp.construct_pure, if_pos hinvariant.2.2.2.1, + simulateQ_pure, StateT.run_pure] + apply relTriple_pure_pure + exact Or.inl ⟨by intro result heq; cases heq; exact hchain, by simp⟩ + | query_bind input next ih => + rw [runNativeQueryTrace_query_bind, if_pos hinvariant.2.2.2.1, simulateQ_bind, simulateQ_spec_query, StateT.run_bind] + apply relTriple_bind (relTriple_nativeQuery_chainFailure parameter root table ftsSecret input context fuel + cache concreteCache hinvariant hvisible hpublished hchain) + intro option right hrel + by_cases hexhausted : AnyEncodingInputsExhausted right.2 + · exact relTriple_nativeChainTrace_of_exhausted _ _ (next right.1) right.2 hexhausted + · cases option with + | none => + apply relTriple_nativeChainTrace_of_public + intro trace htrace + simp only [pure_bind, mem_support_pure_iff] at htrace + subst trace + exact ⟨by simp, by simpa using hchain⟩ + | some result => + dsimp only + rcases hrel.1 with hclean | hdoomed + · rcases right with ⟨value, actualCache⟩ + have hvalue : result.value.1 = value := hclean.2.1 + subst value + have hnextChain : MaterializedChainsPublished result.context := by + rcases hrel.2 result rfl hclean.2.2.1.2.2.2.1 with hpublic | hfailure + · exact hpublic + · exact False.elim (hexhausted (anyEncodingInputsExhausted_of_cachedOtsEncodingFailure actualCache hfailure)) + have hnext := ih result.value.1 result.context result.remaining result.value.2 actualCache + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 hnextChain + let prepend := fun trace : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection => + (trace.1, (⟨input, context, fuel, table, cache⟩ : CanonicalQuerySelection) :: trace.2) + have hpost := relTriple_post_mono hnext (R' := fun trace final => NativeChainTraceRel (prepend trace) final) (by + intro trace final htrace + rcases htrace with htrace | hfailure + · exact Or.inl ⟨htrace.1, by + intro selection hselection + rcases List.mem_cons.mp hselection with rfl | hmem + · exact hchain + · exact htrace.2 selection hmem⟩ + · exact Or.inr hfailure) + have hmapped := relTriple_map (f := prepend) (g := id) hpost + simpa only [hclean.1, prepend, map_eq_bind_pure_comp, Function.comp_def, id_eq, bind_pure] using hmapped + · rw [runNativeQueryTrace_of_not_completable parameter root ftsSecret (next result.value.1) + result.context result.remaining result.table result.value.2 (by rw [hdoomed.1]; exact hdoomed.2.2.2)] + apply relTriple_nativeChainTrace_of_public + intro trace htrace + simp only [pure_bind, mem_support_pure_iff] at htrace + subst trace + exact ⟨by simp, by simpa using hchain⟩ + +theorem probEvent_nativeTrace_chainFailure_le_exhaustion + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) (hchain : MaterializedChainsPublished context) : + Pr[fun trace => ¬NativeChainsPublished trace | runNativeQueryTrace parameter root ftsSecret computation context fuel table cache] ≤ + Pr[fun result => AnyEncodingInputsExhausted result.2 | (simulateQ (unloggedMappedAdversaryImpl + ⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩) + computation).run concreteCache] := by + apply probEvent_le_of_relTriple (relTriple_nativeTrace_chainPublication parameter root table ftsSecret computation + context fuel cache concreteCache hinvariant hvisible hpublished hchain) + intro trace result hrel hfailure + exact hrel.resolve_left hfailure + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeChronologicalRootSigner.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeChronologicalRootSigner.lean new file mode 100644 index 00000000..f9ff809e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeChronologicalRootSigner.lean @@ -0,0 +1,212 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootSigner + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +theorem rootEncodingNativeCouples_revealPrivateLayerValues + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (revealPrivateLayerValues index lay encoding) := by + unfold revealPrivateLayerValues + apply (rootEncodingNativeCouples_sequenceFin parameter target leftRoot rightRoot _ + fun chainIdx => rootEncodingNativeCouples_revealCoordinate parameter target + leftRoot rightRoot + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + (encoding chainIdx))).bind + intro values + apply (rootEncodingNativeCouples_sequenceFin parameter target leftRoot rightRoot _ + fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + cases hzero : level.val with + | zero => + exact rootEncodingNativeCouples_revealCoordinate parameter target leftRoot + rightRoot (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | succ current => + rw [Nat.add_one] + simp only + by_cases hcurrent : current < maxLayerHeight + · rw [dif_pos hcurrent] + exact rootEncodingNativeCouples_revealCoordinate parameter target leftRoot + rightRoot (.position (.node lay (treeIndexAt index lay) ⟨current, hcurrent⟩ + (leafOfNat (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + · rw [dif_neg hcurrent] + exact rootEncodingNativeCouples_pure parameter target leftRoot rightRoot 0 + · rw [if_neg hlevel] + exact rootEncodingNativeCouples_pure parameter target leftRoot rightRoot 0).bind + intro path + exact rootEncodingNativeCouples_pure parameter target leftRoot rightRoot (values, path) + +noncomputable def maskedChronologicalSignLayerWithTargetComparison + (parameter : PublicParameter) (target : Position) (comparisonRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) + (Option ChronologicalLayerPart) := do + match ← maskedSignLayerWithTargetComparison parameter target comparisonRoot ftsSecret index lay with + | none => pure none + | some (counter, encoding) => do + let values ← revealPrivateLayerValues index lay encoding + pure (some ⟨counter, encoding, values.1, values.2⟩) + +theorem rootEncodingNativeRelatesStored_maskedChronologicalSignLayer_targetComparison + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + RootEncodingNativeRelatesStored parameter target leftRoot rightRoot + (maskedChronologicalSignLayer parameter ftsSecret index lay) + (maskedChronologicalSignLayerWithTargetComparison parameter target rightRoot ftsSecret index lay) := by + unfold maskedChronologicalSignLayer maskedChronologicalSignLayerWithTargetComparison + apply (rootEncodingNativeRelatesStored_maskedSignLayer_targetComparison parameter target hroot + leftRoot rightRoot ftsSecret index lay).bind + intro leftSelected rightSelected heq + subst rightSelected + cases leftSelected with + | none => exact (rootEncodingNativeCouples_pure parameter target leftRoot rightRoot none).relates.toStored + | some selected => + apply (rootEncodingNativeCouples_revealPrivateLayerValues parameter target leftRoot rightRoot + index lay selected.2).relates.toStored.bind + intro leftValues rightValues heq + subst rightValues + exact (rootEncodingNativeCouples_pure parameter target leftRoot rightRoot + (some (⟨selected.1, selected.2, leftValues.1, leftValues.2⟩ : ChronologicalLayerPart))).relates.toStored + +theorem rootEncodingNativeCouples_publishChronologicalSignature + (parameter : PublicParameter) (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (layers : Layer → Option ChronologicalLayerPart) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers) := by + unfold publishChronologicalSignature + cases hparts : traverseOption layers with + | none => exact rootEncodingNativeCouples_pure parameter target leftRoot rightRoot none + | some parts => + exact (rootEncodingNativeCouples_sequenceFin parameter target leftRoot rightRoot + (fun lay => revealLayerValues index lay (parts lay).encoding) + (fun lay => rootEncodingNativeCouples_revealLayerValues parameter target leftRoot rightRoot + index lay (parts lay).encoding)).bind fun published => + rootEncodingNativeCouples_pure parameter target leftRoot rightRoot _ + +noncomputable def maskedPublishedChronologicalSignAfterDigestWithTargetComparison + (parameter : PublicParameter) (target : Position) (comparisonRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature) := do + let ftsPath ← simulateQ ordinaryHashImpl (ftsOpen parameter index leaves (ftsSecret index)) + let layers ← sequenceFin fun lay => + maskedChronologicalSignLayerWithTargetComparison parameter target comparisonRoot ftsSecret index lay + publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers + +theorem rootEncodingNativeRelatesStored_maskedPublishedChronologicalSignAfterDigest_targetComparison + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + RootEncodingNativeRelatesStored parameter target leftRoot rightRoot + (maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves) + (maskedPublishedChronologicalSignAfterDigestWithTargetComparison parameter target rightRoot + ftsSecret randomness index leaves) := by + unfold maskedPublishedChronologicalSignAfterDigest + maskedPublishedChronologicalSignAfterDigestWithTargetComparison maskedChronologicalSignLayers + apply (rootEncodingNativeCouples_ftsOpen parameter target leftRoot rightRoot index leaves + (ftsSecret index)).relates.toStored.bind + intro leftPath rightPath hpath + subst rightPath + apply (rootEncodingNativeRelatesStored_sequenceFin parameter target leftRoot rightRoot _ _ + (fun lay => rootEncodingNativeRelatesStored_maskedChronologicalSignLayer_targetComparison + parameter target hroot leftRoot rightRoot ftsSecret index lay)).bind + intro leftLayers rightLayers hlayers + subst rightLayers + exact (rootEncodingNativeCouples_publishChronologicalSignature parameter target leftRoot rightRoot + ftsSecret randomness index leaves leftPath leftLayers).relates.toStored + +noncomputable def maskedPublishedChronologicalSignWithTargetComparison + (parameter : PublicParameter) (root : Digest) (target : Position) (comparisonRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature) := do + let secretKey : SecretKey := ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ + match ← simulateQ ordinaryRomImpl (signDigestLoop digestAttemptLimit secretKey message) with + | none => pure none + | some (randomness, index, leaves) => + maskedPublishedChronologicalSignAfterDigestWithTargetComparison parameter target comparisonRoot + ftsSecret randomness index leaves + +theorem rootEncodingNativeRelatesStored_maskedPublishedChronologicalSign_targetComparison + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + RootEncodingNativeRelatesStored parameter target leftRoot rightRoot + (maskedPublishedChronologicalSign parameter root ftsSecret message) + (maskedPublishedChronologicalSignWithTargetComparison parameter root target rightRoot ftsSecret message) := by + unfold maskedPublishedChronologicalSign maskedPublishedChronologicalSignWithTargetComparison + apply (rootEncodingNativeCouples_signDigestLoop target leftRoot rightRoot + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ message digestAttemptLimit).relates.toStored.bind + intro leftSelected rightSelected heq + subst rightSelected + cases leftSelected with + | none => exact (rootEncodingNativeCouples_pure parameter target leftRoot rightRoot none).relates.toStored + | some selected => + exact rootEncodingNativeRelatesStored_maskedPublishedChronologicalSignAfterDigest_targetComparison + parameter target hroot leftRoot rightRoot ftsSecret selected.1 selected.2.1 selected.2.2 + +def eraseNativeSplitCache (result : Option (ResolvedRunResult (α × SplitHashCache))) : + Option (ResolvedRunResult α) := + result.map fun value => ⟨value.context, value.remaining, value.value.1, value.table⟩ + +theorem RootEncodingNativeSameRel.eraseSplitCache + {parameter : PublicParameter} {target : Position} {leftRoot rightRoot : Digest} + {left right : Option (ResolvedRunResult (α × SplitHashCache))} + (hrel : RootEncodingNativeSameRel parameter target leftRoot rightRoot left right) : + eraseNativeSplitCache left = eraseNativeSplitCache right := by + cases left with + | none => + cases right with + | none => rfl + | some right => contradiction + | some left => + cases right with + | none => contradiction + | some right => + rcases hrel with ⟨hcontext, hfuel, htable, hvalue, _⟩ + simp only [eraseNativeSplitCache, Option.map_some, hcontext, hfuel, htable, hvalue] + +theorem evalDist_nativeChronologicalRootComparison_eraseCache + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hstored : StoredNativeLayerRoot context target leftRoot) : + evalDist (eraseNativeSplitCache <$> + runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run leftCache)) = + evalDist (eraseNativeSplitCache <$> + runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSignWithTargetComparison parameter root target rightRoot + ftsSecret message).run rightCache)) := by + apply evalDist_map_eq_of_relTriple + apply relTriple_post_mono + (rootEncodingNativeRelatesStored_maskedPublishedChronologicalSign_targetComparison + parameter root target hroot leftRoot rightRoot ftsSecret message + leftCache rightCache hcache context fuel table hstored) + intro left right hrel + cases left with + | none => + cases right with + | none => rfl + | some right => contradiction + | some left => + cases right with + | none => contradiction + | some right => exact hrel.1.eraseSplitCache + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeComputedRootMaterialization.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeComputedRootMaterialization.lean new file mode 100644 index 00000000..3ff90cf2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeComputedRootMaterialization.lean @@ -0,0 +1,196 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootMaterialization + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem DeferredPositionComputed.known {context : DeferredContext} {position : Position} + (h : DeferredPositionComputed context position) : ∃ output, context.positionValue position = some output := by + cases h with + | intro _ _ _ hknown _ => exact hknown + +theorem DeferredPositionComputed.treeNode_children + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) (hlevel : level + 1 ≤ maxLayerHeight) + (hspan : 2 ^ (level + 1) * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) (context : DeferredContext) + (h : DeferredPositionComputed context (deferredTreePosition lay tree (level + 1) nodeIdx hlevel)) : + DeferredPositionComputed context (deferredTreePosition lay tree level (2 * nodeIdx) (by omega)) ∧ + DeferredPositionComputed context (deferredTreePosition lay tree level (2 * nodeIdx + 1) (by omega)) := by + have hpow : 1 ≤ 2 ^ level := Nat.one_le_pow _ _ (by omega) + have hnode : 2 * nodeIdx + 1 < 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith + have hidx : nodeIdx < 2 ^ maxLayerHeight := by omega + have hleft : 2 * nodeIdx < 2 ^ maxLayerHeight := by omega + cases h with + | intro _ _ _ _ hchildren => + constructor + · apply hchildren + cases level <;> simp [deferredTreePosition, Position.children, leafOfNat, Nat.mod_eq_of_lt hidx, + Nat.mod_eq_of_lt hleft, hnode] + · apply hchildren + cases level <;> simp [deferredTreePosition, Position.children, leafOfNat, Nat.mod_eq_of_lt hidx, + Nat.mod_eq_of_lt hnode, hnode] + +theorem LayerRootsMaterialized.of_resolveTreeNode_computed + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel, + 2 ^ level * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight → + ∀ context result, + LayerRootsMaterialized context → + DeferredPositionComputed context (deferredTreePosition lay tree level nodeIdx hlevel) → + some result ∈ support (resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) → + LayerRootsMaterialized result.toDeferredContext + | 0, nodeIdx, _, _, context, result, hmat, _, hresult => + hmat.of_resolveOtsLeaf table lay tree (leafOfNat nodeIdx) result hresult + | level + 1, nodeIdx, hlevel, hspan, context, result, hmat, hcomputed, hresult => by + have hchildren := hcomputed.treeNode_children lay tree level nodeIdx hlevel hspan context + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨left, hleft, htail⟩ := hresult + cases left with + | none => simp at htail + | some left => + rw [mem_support_bind_iff] at htail + obtain ⟨right, hright, htail⟩ := htail + cases right with + | none => simp at htail + | some right => + have hleftSpan : 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith [pow_pos (by omega : 0 < (2 : Nat)) level] + have hrightSpan : 2 ^ level * (2 * nodeIdx + 1 + 1) ≤ 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith + have hleftMat := hmat.of_resolveTreeNode_computed table lay tree level (2 * nodeIdx) (by omega) + hleftSpan context left hchildren.1 hleft + have hrightComputed := hchildren.2.mono (fun position output hvalue => + resolveDeferredTreeNode_preserves_positionValue table lay tree level (2 * nodeIdx) (by omega) + context left position output hvalue hleft) + have hrightMat := hleftMat.of_resolveTreeNode_computed table lay tree level (2 * nodeIdx + 1) (by omega) + hrightSpan left.toDeferredContext right hrightComputed hright + apply hrightMat.of_resolvePositionValue_known_root _ result ?_ htail + intro _ + obtain ⟨output, houtput⟩ := hcomputed.known + exact ⟨output, resolveDeferredTreeNode_preserves_positionValue table lay tree level (2 * nodeIdx + 1) (by omega) + left.toDeferredContext right _ output + (resolveDeferredTreeNode_preserves_positionValue table lay tree level (2 * nodeIdx) (by omega) + context left _ output houtput hleft) hright⟩ + +theorem LayerRootsMaterialized.materialize_of_resolveTreeNode_children_computed + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) (hlevel : level + 1 ≤ maxLayerHeight) + (hspan : 2 ^ (level + 1) * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) + (context : DeferredContext) (result : DeferredResolution) (hmat : LayerRootsMaterialized context) + (hleftComputed : DeferredPositionComputed context (deferredTreePosition lay tree level (2 * nodeIdx) (by omega))) + (hrightComputed : DeferredPositionComputed context (deferredTreePosition lay tree level (2 * nodeIdx + 1) (by omega))) + (hresult : some result ∈ support (resolveDeferredTreeNode table lay tree (level + 1) nodeIdx hlevel context)) : + LayerRootsMaterialized (materializeResolvedPosition context (deferredTreePosition lay tree (level + 1) nodeIdx hlevel) result) := by + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨left, hleft, htail⟩ := hresult + cases left with + | none => simp at htail + | some left => + rw [mem_support_bind_iff] at htail + obtain ⟨right, hright, htail⟩ := htail + cases right with + | none => simp at htail + | some right => + have hleftSpan : 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith [pow_pos (by omega : 0 < (2 : Nat)) level] + have hrightSpan : 2 ^ level * (2 * nodeIdx + 1 + 1) ≤ 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith + have hleftMat := hmat.of_resolveTreeNode_computed table lay tree level (2 * nodeIdx) (by omega) + hleftSpan context left hleftComputed hleft + have hrightComputed' := hrightComputed.mono (fun position output hvalue => + resolveDeferredTreeNode_preserves_positionValue table lay tree level (2 * nodeIdx) (by omega) + context left position output hvalue hleft) + have hrightMat := hleftMat.of_resolveTreeNode_computed table lay tree level (2 * nodeIdx + 1) (by omega) + hrightSpan left.toDeferredContext right hrightComputed' hright + have hfinal := hrightMat.materialize_of_other_roots_eq + (deferredTreePosition lay tree (level + 1) nodeIdx hlevel) result + (fun target _ hne => resolveDeferredPositionValue_preserves_other _ target right.toDeferredContext result hne htail) + refine LayerRootsMaterialized.of_values_eq + (after := materializeResolvedPosition context (deferredTreePosition lay tree (level + 1) nodeIdx hlevel) result) + hfinal ?_ rfl + change (context.state.materialize _ result.output).values = (right.state.materialize _ result.output).values + simp only [LazyRevealProbe.State.materialize] + rw [resolveDeferredTreeNode_preserves_state_values table lay tree level (2 * nodeIdx + 1) (by omega) + left.toDeferredContext right hright, + resolveDeferredTreeNode_preserves_state_values table lay tree level (2 * nodeIdx) (by omega) context left hleft] + +theorem DeferredComputationsClosed.treeNode_children_of_peek + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) + (hlevel : level + 1 ≤ maxLayerHeight) + (hspan : 2 ^ (level + 1) * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) + (context : DeferredContext) (hclosed : DeferredComputationsClosed context) + (hpeek : purePeekTableInput parameter context.state + (.position (deferredTreePosition lay tree (level + 1) nodeIdx hlevel)) ≠ none) : + DeferredPositionComputed context (deferredTreePosition lay tree level (2 * nodeIdx) (by omega)) ∧ + DeferredPositionComputed context (deferredTreePosition lay tree level (2 * nodeIdx + 1) (by omega)) := by + have hpow : 1 ≤ 2 ^ level := Nat.one_le_pow _ _ (by omega) + have hnode : 2 * nodeIdx + 1 < 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith + have hidx : nodeIdx < 2 ^ maxLayerHeight := by omega + have hleftIdx : 2 * nodeIdx < 2 ^ maxLayerHeight := by omega + have hknown : ∀ child ∈ (deferredTreePosition lay tree (level + 1) nodeIdx hlevel).children, + ∃ output, context.positionValue child = some output := by + intro child hchild + have hvalues : purePeekPositionValues context.state + (deferredTreePosition lay tree (level + 1) nodeIdx hlevel).children ≠ none := by + intro heq + apply hpeek + simp only [purePeekTableInput, deferredTreePosition] at * + rw [heq] + have hstate : context.state.values (.position child) ≠ none := by + intro heq + exact hvalues ((purePeekPositionValues_eq_none_iff_missing context.state _).mpr ⟨child, hchild, heq⟩) + cases heq : context.state.values (.position child) with + | none => exact False.elim (hstate heq) + | some output => exact ⟨output, by simp [DeferredContext.positionValue, heq]⟩ + have hleftSpan : 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith + have hrightSpan : 2 ^ level * (2 * nodeIdx + 1 + 1) ≤ 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith + constructor + · apply hclosed _ (resolvableOtsPosition_deferredTreePosition lay tree level (2 * nodeIdx) (by omega) hleftSpan) + apply hknown + cases level <;> simp [deferredTreePosition, Position.children, leafOfNat, Nat.mod_eq_of_lt hidx, + Nat.mod_eq_of_lt hleftIdx, hnode] + · apply hclosed _ (resolvableOtsPosition_deferredTreePosition lay tree level (2 * nodeIdx + 1) (by omega) hrightSpan) + apply hknown + cases level <;> simp [deferredTreePosition, Position.children, leafOfNat, Nat.mod_eq_of_lt hidx, + Nat.mod_eq_of_lt hnode, hnode] + +theorem LayerRootsMaterialized.of_resolveReveal_peek + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (position : Position) (context : DeferredContext) (result : DeferredResolution) + (hmat : LayerRootsMaterialized context) (hclosed : DeferredComputationsClosed context) + (hpeek : purePeekTableInput parameter context.state (.position position) ≠ none) + (hresult : some result ∈ support (resolveDeferredReveal table position context)) : + LayerRootsMaterialized (materializeResolvedPosition context position result) := by + by_cases hbounded : LayerBoundedPosition position + · exact hmat.of_resolveReveal_bounded table position result hbounded hresult + · unfold resolveDeferredReveal at hresult + split_ifs at hresult with hresolvable + · cases position with + | node lay tree level nodeIdx => + have hlevel : level.val + 1 ≤ maxLayerHeight := by have := level.isLt; omega + have hposition : deferredTreePosition lay tree (level.val + 1) nodeIdx hlevel = .node lay tree level nodeIdx := by + simp [deferredTreePosition, leafOfNat, Nat.mod_eq_of_lt nodeIdx.isLt] + have hchildren := hclosed.treeNode_children_of_peek parameter lay tree level nodeIdx hlevel hresolvable context + (by simpa only [hposition] using hpeek) + have hfinal := hmat.materialize_of_resolveTreeNode_children_computed table lay tree level nodeIdx hlevel + hresolvable context result hchildren.1 hchildren.2 hresult + simpa only [hposition] using hfinal + | chain | leaf | ftsLeaf | ftsNode | ftsRoots => exact False.elim (hbounded trivial) + · exact hmat.materialize_of_other_roots_eq position result + (fun target _ hne => resolveDeferredPositionValue_preserves_other position target context result hne hresult) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeDirectBound.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeDirectBound.lean new file mode 100644 index 00000000..2862c04b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeDirectBound.lean @@ -0,0 +1,30 @@ +import SphincsSecurity.Proof.Security126Completion + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local irreducible] instFintypePosition +set_option backward.isDefEq.respectTransparency false + +theorem sampledNativeTerminalRisk_le_directCharge_add_erasure + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + sampledNativeTerminalRisk adversary (q + 1) ≤ + sampledQueryCharge (fun secretKey => directOtsQueryCharge secretKey.parameter) adversary * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + apply (sampledNativeTerminalRisk_le_missing_add_erasure adversary q hq hqMax).trans + apply add_le_add _ le_rfl + exact (sampledNativeMissingAllowances_le_directRisk Finset.univ adversary q hq (q + 1)).trans + (sampledInitializedNativeDirectRisk_le_directCharge Finset.univ adversary (q + 1) q hqMax) + +theorem probEvent_sampled_prehitFree_residual_le_directCharge_add_erasure + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + Pr[prehitFreeResidualOtsOpeningEvent | sampledEncodingPrehitViewedGame adversary] ≤ + sampledQueryCharge (fun secretKey => directOtsQueryCharge secretKey.parameter) adversary * + (Fintype.card Digest : ENNReal)⁻¹ + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + apply (probEvent_sampled_prehitFree_residual_le_nativeTerminalFailure adversary (q + 1)).trans + rw [probEvent_sampledNativeTerminalFailure_eq_risk] + simpa only [show Fintype.card Digest = 2 ^ digestBits by simp] using + sampledNativeTerminalRisk_le_directCharge_add_erasure adversary q hq hqMax + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeHashHistorySelection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeHashHistorySelection.lean new file mode 100644 index 00000000..2016689a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeHashHistorySelection.lean @@ -0,0 +1,138 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootFirstMatch + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec +open _root_.OracleComp.DeferredSampling + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def nativeHashHistorySelection (history : List CanonicalQuerySelection) (ordinal : Nat) : + Option (List CanonicalQuerySelection × CanonicalQuerySelection) := + ((nativeHashQueryHistory history)[ordinal]?).map fun selection => + ((nativeHashQueryHistory history).take ordinal, selection) + +noncomputable def nativeTraceHashCutHistory : + Option (ResolvedRunResult (OuterQueryCut α × SplitHashCache)) × List CanonicalQuerySelection → + Option (List CanonicalQuerySelection × CanonicalQuerySelection) + | (none, _) => none + | (some result, history) => result.value.1.input?.map fun input => + (nativeHashQueryHistory history, ⟨input, result.context, result.remaining, result.table, result.value.2⟩) + +theorem nativeHashHistorySelection_cons_hash_zero + (selection : CanonicalQuerySelection) (history : List CanonicalQuerySelection) + (hhash : IsOuterHash selection.input) : + nativeHashHistorySelection (selection :: history) 0 = some ([], selection) := by + simp [nativeHashHistorySelection, nativeHashQueryHistory, hhash] + +theorem nativeHashHistorySelection_cons_hash_succ + (selection : CanonicalQuerySelection) (history : List CanonicalQuerySelection) (ordinal : Nat) + (hhash : IsOuterHash selection.input) : + nativeHashHistorySelection (selection :: history) (ordinal + 1) = + (nativeHashHistorySelection history ordinal).map (fun pair => (selection :: pair.1, pair.2)) := by + simp [nativeHashHistorySelection, nativeHashQueryHistory, hhash, Option.map_map, Function.comp_def] + +theorem nativeHashHistorySelection_cons_not_hash + (selection : CanonicalQuerySelection) (history : List CanonicalQuerySelection) (ordinal : Nat) + (hhash : ¬IsOuterHash selection.input) : + nativeHashHistorySelection (selection :: history) ordinal = nativeHashHistorySelection history ordinal := by + simp [nativeHashHistorySelection, nativeHashQueryHistory, hhash] + +theorem nativeTraceHashCutHistory_cons + (selection : CanonicalQuerySelection) + (trace : Option (ResolvedRunResult (OuterQueryCut α × SplitHashCache)) × List CanonicalQuerySelection) : + nativeTraceHashCutHistory (trace.1, selection :: trace.2) = + (nativeTraceHashCutHistory trace).map (fun pair => + (if IsOuterHash selection.input then selection :: pair.1 else pair.1, pair.2)) := by + rcases trace with ⟨option, history⟩ + cases option with + | none => rfl + | some result => + by_cases hhash : IsOuterHash selection.input <;> + simp [nativeTraceHashCutHistory, nativeHashQueryHistory, hhash, Option.map_map, Function.comp_def] + +theorem runNativeQueryTrace_hashHistory_projection + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + evalDist ((fun trace => nativeHashHistorySelection trace.2 ordinal) <$> + runNativeQueryTrace parameter root ftsSecret computation context fuel table cache) = + evalDist (nativeTraceHashCutHistory <$> + runNativeQueryTrace parameter root ftsSecret (outerHashQueryCutAt computation ordinal) context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing ordinal context fuel table cache with + | pure value => + simp only [outerHashQueryCutAt, OracleComp.construct_pure, runNativeQueryTrace] + split_ifs <;> simp [nativeHashHistorySelection, nativeHashQueryHistory, nativeTraceHashCutHistory, OuterQueryCut.input?] + | query_bind input next ih => + rw [runNativeQueryTrace_query_bind, outerHashQueryCutAt_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete] + by_cases hhash : IsOuterHash input + · rw [if_pos hhash] + cases ordinal with + | zero => + simp only [map_bind] + calc + _ = evalDist (runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) >>= fun _ => + pure (some ([], (⟨input, context, fuel, table, cache⟩ : CanonicalQuerySelection)))) := by + apply evalDist_bind_congr_left + intro result + cases result with + | none => simp [nativeHashHistorySelection_cons_hash_zero ⟨input, context, fuel, table, cache⟩ _ hhash] + | some result => + simp only [map_bind, map_pure, nativeHashHistorySelection_cons_hash_zero ⟨input, context, fuel, table, cache⟩ _ hhash] + exact evalDist_bind_const_neverFails _ (by simp) _ + _ = _ := by + rw [evalDist_bind_const_neverFails _ (by simp) _] + simp [runNativeQueryTrace, OracleComp.construct_pure, hcomplete, nativeTraceHashCutHistory, + nativeHashQueryHistory, OuterQueryCut.input?] + | succ ordinal => + rw [runNativeQueryTrace_query_bind, if_pos hcomplete] + simp only [map_bind] + apply evalDist_bind_congr_left + intro result + cases result with + | none => simp [nativeHashHistorySelection, nativeHashQueryHistory, nativeTraceHashCutHistory, hhash] + | some result => + simp only [map_bind, map_pure, nativeHashHistorySelection_cons_hash_succ ⟨input, context, fuel, table, cache⟩ _ _ hhash, + nativeTraceHashCutHistory_cons, hhash, ↓reduceIte] + have hmap := evalDist_map_eq_of_evalDist_eq + (ih result.value.1 ordinal result.context result.remaining result.table result.value.2) + (Option.map (fun pair : List CanonicalQuerySelection × CanonicalQuerySelection => + ((⟨input, context, fuel, table, cache⟩ : CanonicalQuerySelection) :: pair.1, pair.2))) + simpa only [Functor.map_map, map_eq_bind_pure_comp, Function.comp_def, bind_assoc, pure_bind] using hmap + · rw [if_neg hhash, runNativeQueryTrace_query_bind, if_pos hcomplete] + simp only [map_bind] + apply evalDist_bind_congr_left + intro result + cases result with + | none => simp [nativeHashHistorySelection, nativeHashQueryHistory, nativeTraceHashCutHistory, hhash] + | some result => + simp only [map_bind, map_pure, nativeHashHistorySelection_cons_not_hash ⟨input, context, fuel, table, cache⟩ _ _ hhash, + nativeTraceHashCutHistory_cons, hhash, ↓reduceIte] + simpa only [Prod.mk.eta, Option.map_id_fun', id_eq, map_eq_bind_pure_comp, Function.comp_def] using + ih result.value.1 ordinal result.context result.remaining result.table result.value.2 + · rw [if_neg hcomplete] + by_cases hhash : IsOuterHash input + · rw [if_pos hhash] + cases ordinal <;> simp [runNativeQueryTrace, OracleComp.construct_pure, OracleComp.construct_query_bind, + hcomplete, nativeHashHistorySelection, nativeHashQueryHistory, nativeTraceHashCutHistory] + · rw [if_neg hhash, runNativeQueryTrace_query_bind, if_neg hcomplete] + simp [nativeHashHistorySelection, nativeHashQueryHistory, nativeTraceHashCutHistory] + +theorem nativeHashHistorySelection_append_hash + (prior : List CanonicalQuerySelection) (selection : CanonicalQuerySelection) (suffix : List CanonicalQuerySelection) + (hhash : IsOuterHash selection.input) : + nativeHashHistorySelection (prior ++ selection :: suffix) (nativeHashQueryHistory prior).length = + some (nativeHashQueryHistory prior, selection) := by + simp [nativeHashHistorySelection, nativeHashQueryHistory, List.filter_append, hhash] + +theorem nativeRootCandidateHistory_hashHistory + (parameter : PublicParameter) (target : Position) (history : List CanonicalQuerySelection) : + nativeRootCandidateHistory parameter target (nativeHashQueryHistory history) = + nativeRootCandidateHistory parameter target history := by + simp [nativeRootCandidateHistory, nativeHashQueryHistory, List.filter_filter] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeLiveAllowanceReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeLiveAllowanceReserve.lean new file mode 100644 index 00000000..813819c6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeLiveAllowanceReserve.lean @@ -0,0 +1,114 @@ +import SphincsSecurity.Proof.OtsProbeLivePrivateAllowanceCounting + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem sum_sampledEnsuredNativeProbeCut_startHits_eq_liveAllowance_of_liveBound + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel q : Nat) + (hbound : ∀ table, LiveResolvedQueryBound LazyRevealProbe.IsProbe computation q (ensuredInitialContext targets) fuel table) : + (∑ ordinal ∈ Finset.range q, + Pr[LiveUnresolvedStartHit nativeCutCandidate | sampledEnsuredNativeProbeCut targets computation fuel ordinal]) = + ∑' table, Pr[= table | sampleOtsHashTable] * liveStartProbeAllowance computation (ensuredInitialContext targets) fuel table := by + simp only [sampledEnsuredNativeProbeCut, probEvent_bind_eq_tsum] + rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + simp only [← Finset.mul_sum] + apply tsum_congr + intro table + rw [sum_nativeProbeCut_startHits_eq_liveAllowance_of_liveBound computation q (ensuredInitialContext targets) fuel table + (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table)) (hbound table)] + +theorem sum_privateHits_ensuredInitial_eq_liveAllowance_of_liveBound + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (fuel q : Nat) (table : OtsSecretIndex → HashOutput) + (hbound : LiveResolvedQueryBound LazyRevealProbe.IsProbe computation q (ensuredInitialContext targets) fuel table) : + (∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table (ensuredInitialContext targets) fuel (privatePositionProbeCutAt target computation ordinal)]) = + ∑ target ∈ targets, privateLiveProbeAllowance target computation (ensuredInitialContext targets) fuel table := by + apply Finset.sum_congr rfl + intro target _ + apply sum_privateProbeCut_hits_eq_liveAllowance_of_liveBound target computation q (ensuredInitialContext targets) fuel table + (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table)) + (by simp [ensuredInitialContext, LazyRevealProbe.State.empty]) + apply LiveResolvedQueryBound.of_imp _ hbound + intro input hinput + cases input <;> simp_all [IsPrivatePositionProbe, LazyRevealProbe.IsProbe] + +theorem initializedNativeDirectRisk_eq_allowances_of_gameBudget + (targets : Finset Position) (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (hfts : ftsSecret ∈ support sampleFtsSecrets) (fuel : Nat) : + initializedNativeDirectRisk targets adversary parameter ftsSecret fuel q = + ∑' table, Pr[= table | sampleOtsHashTable] * + (liveStartProbeAllowance (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + (ensuredInitialContext targets) fuel table + + ∑ target ∈ targets, privateLiveProbeAllowance target + (nativeChronologicalRetainedComputation adversary parameter ftsSecret) (ensuredInitialContext targets) fuel table) := by + have hbound := fun table => liveResolvedProbeBound_nativeRetained_of_gameBudget targets adversary q hq + parameter hparameter table ftsSecret hfts fuel + unfold initializedNativeDirectRisk + rw [sum_sampledEnsuredNativeProbeCut_startHits_eq_liveAllowance_of_liveBound targets _ fuel q hbound] + simp_rw [sum_privateHits_ensuredInitial_eq_liveAllowance_of_liveBound targets _ fuel q _ (hbound _)] + simp only [mul_add, ENNReal.tsum_add] + +theorem nativeMissingAllowances_le_directRisk_of_gameBudget + (targets : Finset Position) (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (hfts : ftsSecret ∈ support sampleFtsSecrets) (fuel : Nat) : + (∑' table, Pr[= table | sampleOtsHashTable] * + (liveStartProbeAllowance (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + (ensuredInitialContext targets) fuel table + + ∑ target ∈ targets, privateLiveMissingProbeAllowance target + (nativeChronologicalRetainedComputation adversary parameter ftsSecret) (ensuredInitialContext targets) fuel table)) ≤ + initializedNativeDirectRisk targets adversary parameter ftsSecret fuel q := by + rw [initializedNativeDirectRisk_eq_allowances_of_gameBudget targets adversary q hq parameter hparameter ftsSecret hfts fuel] + apply ENNReal.tsum_le_tsum + intro table + apply mul_le_mul_right + apply add_le_add le_rfl + apply Finset.sum_le_sum + intro target _ + exact privateLiveMissingProbeAllowance_le_stoppedAllowance target _ (ensuredInitialContext targets) fuel table + +noncomputable def sampledNativeMissingAllowances + (targets : Finset Position) (adversary : Adversary) (fuel : Nat) : ENNReal := + ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + ∑' table, Pr[= table | sampleOtsHashTable] * + (liveStartProbeAllowance (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + (ensuredInitialContext targets) fuel table + + ∑ target ∈ targets, privateLiveMissingProbeAllowance target + (nativeChronologicalRetainedComputation adversary parameter ftsSecret) (ensuredInitialContext targets) fuel table) + +theorem sampledNativeMissingAllowances_le_directRisk + (targets : Finset Position) (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (fuel : Nat) : + sampledNativeMissingAllowances targets adversary fuel ≤ sampledInitializedNativeDirectRisk targets adversary fuel q := by + unfold sampledNativeMissingAllowances sampledInitializedNativeDirectRisk + apply ENNReal.tsum_le_tsum + intro parameter + by_cases hparameter : parameter ∈ support sampleParameter + · apply mul_le_mul_right + apply ENNReal.tsum_le_tsum + intro ftsSecret + by_cases hfts : ftsSecret ∈ support sampleFtsSecrets + · apply mul_le_mul_right + exact nativeMissingAllowances_le_directRisk_of_gameBudget targets adversary q hq parameter hparameter ftsSecret hfts fuel + · simp [probOutput_eq_zero_of_not_mem_support hfts] + · simp [probOutput_eq_zero_of_not_mem_support hparameter] + +theorem sampledNativeMissingAllowances_add_rootMatch_le_refinedReserve + (targets roots : Finset Position) (hsubset : roots ⊆ targets) + (hroots : ∀ target ∈ roots, IsLayerRoot target) (hne : ∀ target ∈ roots, target ≠ layerRootPosition topLayer rootTree) + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) (fuel : Nat) : + sampledNativeMissingAllowances targets adversary fuel + sampledNativeFinalRootMatchRisk targets roots adversary fuel ≤ + sampledQueryCharge otsOpeningRefinedQueryReserve adversary * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + exact (add_le_add (sampledNativeMissingAllowances_le_directRisk targets adversary q hq fuel) le_rfl).trans + (sampledNativeDirectRisk_add_finalRootMatch_le_refinedReserve targets roots hsubset hroots hne adversary q hq hqMax fuel) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeLiveBudget.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeLiveBudget.lean new file mode 100644 index 00000000..5b892c31 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeLiveBudget.lean @@ -0,0 +1,104 @@ +import SphincsSecurity.Proof.OtsProbeLiveResolvedBudget + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +theorem expandedQuery_hashBudget + (secretKey : SecretKey) (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (q : Nat) (hbound : (simulateQ (expandedAdversaryImpl secretKey) (OracleSpec.query input >>= next)).IsQueryBoundP + (· matches Sum.inr _) q) : + outerHashQueryCount input ≤ q ∧ ∀ reply ∈ support (expandedAdversaryImpl secretKey input), + (simulateQ (expandedAdversaryImpl secretKey) (next reply)).IsQueryBoundP (· matches Sum.inr _) + (q - outerHashQueryCount input) := by + cases input with + | inl input => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases input with + | inl n => exact ⟨Nat.zero_le _, fun reply _ => hbound.2 reply⟩ + | inr input => + exact ⟨hbound.1.resolve_left (by simp), fun reply _ => hbound.2 reply⟩ + | inr message => + rw [simulateQ_expandedAdversaryImpl_query_bind_inr] at hbound + exact ⟨Nat.zero_le _, fun reply hreply => isQueryBoundP_of_bind hbound reply hreply⟩ + +theorem liveResolvedProbeBound_nativeExpanded_of_gameBudget + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (q : Nat) + (hbound : (simulateQ (expandedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey)) + computation).IsQueryBoundP (· matches Sum.inr _) q) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) : + LiveResolvedQueryBound LazyRevealProbe.IsProbe + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) + q context fuel table := by + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + induction computation using OracleComp.inductionOn generalizing q context fuel cache actualCache with + | pure value => trivial + | query_bind input next ih => + have hbudget := expandedQuery_hashBudget secretKey input next q hbound + rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind] + have hnext : ∀ result, some result ∈ support (runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache)) → + LiveResolvedQueryBound LazyRevealProbe.IsProbe + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) (next result.value.1)).run result.value.2) + (q - outerHashQueryCount input) result.context result.remaining result.table := by + intro result hresult + obtain ⟨actual, hactual, hrel⟩ := exists_right_of_relTriple_of_mem_support + (reachableResolvedCouples_maskedChronologicalExpandedAdversaryImpl parameter root table ftsSecret input + context fuel cache actualCache hinvariant hvisible hpublished) hresult + rcases hrel with hclean | hdoomed + · rw [hclean.1] + have hreply := unloggedMappedAdversaryImpl_output_mem_support_expanded secretKey input actualCache actual.2 actual.1 hactual + apply ih result.value.1 (q - outerHashQueryCount input) _ result.context result.remaining result.value.2 actual.2 + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 + rw [hclean.2.1] + exact hbudget.2 actual.1 hreply + · apply liveResolvedQueryBound_of_not_completable + rw [hdoomed.1] + exact hdoomed.2.2.2 + have hcombined := liveResolvedQueryBound_bind_of_syntactic_prefix LazyRevealProbe.IsProbe + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) + (fun result => (simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) (next result.1)).run result.2) + (outerHashQueryCount input) (q - outerHashQueryCount input) + (maskedChronologicalExpandedAdversaryImpl_probeBound parameter root ftsSecret input cache) context fuel table hnext + simpa only [Nat.add_sub_of_le hbudget.1] using hcombined + +theorem liveResolvedProbeBound_nativeRetained_of_gameBudget + (targets : Finset Position) (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) (fuel : Nat) : + LiveResolvedQueryBound LazyRevealProbe.IsProbe (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + q (ensuredInitialContext targets) fuel table := by + unfold nativeChronologicalRetainedComputation + simpa only [Nat.zero_add] using + (liveResolvedQueryBound_bind_of_syntactic_prefix LazyRevealProbe.IsProbe + (maskedPublishedTreeRoot.run emptySplitHashCache) _ 0 q (maskedPublishedTreeRoot_probeFree emptySplitHashCache) + (ensuredInitialContext targets) fuel table (by + intro result hresult + obtain ⟨actual, _, hrel⟩ := exists_right_of_relTriple_of_mem_support + (reachableResolvedCouples_maskedPublishedTreeRoot parameter table (ensuredInitialContext targets) + fuel emptySplitHashCache ∅ (ensuredInitialContext_resolvedInvariant targets parameter table) + (ensuredInitialContext_visible targets parameter table) (ensuredInitialContext_published targets)) hresult + rcases hrel with hclean | hdoomed + · rw [hclean.1] + exact liveResolvedProbeBound_nativeExpanded_of_gameBudget parameter result.value.1 table ftsSecret + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) q + (isQueryBoundP_expandedRetained_all_tables_roots adversary q hq parameter hparameter table ftsSecret hfts result.value.1) + result.context result.remaining result.value.2 actual.2 hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 + · apply liveResolvedQueryBound_of_not_completable + rw [hdoomed.1] + exact hdoomed.2.2.2)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeMaterializedAllowance.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeMaterializedAllowance.lean new file mode 100644 index 00000000..f491aff8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeMaterializedAllowance.lean @@ -0,0 +1,150 @@ +import SphincsSecurity.Proof.OtsProbeNativeCandidateComponents + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +noncomputable def nativeMaterializedCharge + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (_fuel : Nat) (_cache : SplitHashCache) : ENNReal := + match input with + | .inl (.inr input) => materializedCandidateAllowance table context + (purePlanProbingHashQuery parameter input context.state).candidate? + | _ => 0 + +theorem nativeMaterializedCharge_le_hashIndicator + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + nativeMaterializedCharge parameter table input context fuel cache ≤ if IsOuterHash input then 1 else 0 := by + cases input with + | inl input => + cases input with + | inl n => simp [nativeMaterializedCharge, IsOuterHash] + | inr input => exact materializedCandidateAllowance_le_one table context _ + | inr message => simp [nativeMaterializedCharge, IsOuterHash] + +theorem nativeMaterializedCharge_eq_zero_of_chainsPublished + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hpublic : MaterializedChainsPublished context) : nativeMaterializedCharge parameter table input context fuel cache = 0 := by + cases input with + | inl input => + cases input with + | inl n => rfl + | inr input => exact materializedCandidateAllowance_plan_eq_zero_of_chainsPublished parameter input table context hpublic + | inr message => rfl + +theorem nativeMaterializedTraceCharge_le_hashLength + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) (history : List CanonicalQuerySelection) : + canonicalTraceCharge (nativeMaterializedCharge parameter table) history ≤ (nativeHashQueryHistory history).length := by + induction history with + | nil => simp [canonicalTraceCharge, nativeHashQueryHistory] + | cons head tail ih => + simp only [canonicalTraceCharge, List.map_cons, List.sum_cons, CanonicalQuerySelection.charge] at ih ⊢ + have hstep := add_le_add (nativeMaterializedCharge_le_hashIndicator parameter table head.input head.context head.fuel head.cache) ih + by_cases hhash : IsOuterHash head.input <;> + simpa [nativeHashQueryHistory, hhash, add_comm] using hstep + +theorem nativeMaterializedTraceCharge_eq_zero_of_chainsPublished + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (history : List CanonicalQuerySelection) (hpublic : ∀ selection ∈ history, MaterializedChainsPublished selection.context) : + canonicalTraceCharge (nativeMaterializedCharge parameter table) history = 0 := by + induction history with + | nil => rfl + | cons head tail ih => + simp only [canonicalTraceCharge, List.map_cons, List.sum_cons, CanonicalQuerySelection.charge] + rw [nativeMaterializedCharge_eq_zero_of_chainsPublished parameter table head.input head.context head.fuel head.cache + (hpublic head (by simp)), zero_add] + simpa only [canonicalTraceCharge, CanonicalQuerySelection.charge] using + ih (fun selection hselection => hpublic selection (by simp [hselection])) + +theorem nativeChainTraceAfterRoot_hash_length_le + (targets : Finset Position) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) + (hbound : ∀ root, (continuation root).IsQueryBoundP IsOuterHash q) + (trace : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) + (htrace : trace ∈ support (nativeChainTraceAfterRoot targets parameter table ftsSecret fuel continuation)) : + (nativeHashQueryHistory trace.2).length ≤ q := by + rw [nativeChainTraceAfterRoot, mem_support_bind_iff] at htrace + obtain ⟨root, _, htrace⟩ := htrace + cases root with + | none => + simp only [mem_support_pure_iff] at htrace + subst trace + simp [nativeHashQueryHistory] + | some root => + exact runNativeQueryTrace_hash_length_le parameter root.value.1 ftsSecret (continuation root.value.1) + root.context root.remaining root.table root.value.2 q (hbound root.value.1) trace htrace + +theorem expected_nativeMaterializedTraceCharge_afterRoot_le + (targets : Finset Position) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) + (hbound : ∀ root, (continuation root).IsQueryBoundP IsOuterHash q) : + (∑' trace, Pr[= trace | nativeChainTraceAfterRoot targets parameter table ftsSecret fuel continuation] * + canonicalTraceCharge (nativeMaterializedCharge parameter table) trace.2) ≤ + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ (q : ENNReal) * Pr[fun trace => ¬NativeChainsPublished trace | + nativeChainTraceAfterRoot targets parameter table ftsSecret fuel continuation] := by + rw [probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_left] + apply ENNReal.tsum_le_tsum + intro trace + by_cases htrace : trace ∈ support (nativeChainTraceAfterRoot targets parameter table ftsSecret fuel continuation) + · by_cases hpublic : NativeChainsPublished trace + · rw [nativeMaterializedTraceCharge_eq_zero_of_chainsPublished parameter table trace.2 hpublic.2] + simp [hpublic] + · simp only [hpublic, not_false_eq_true, ite_true] + rw [mul_comm (q : ENNReal)] + apply mul_le_mul_right + exact (nativeMaterializedTraceCharge_le_hashLength parameter table trace.2).trans + (by exact_mod_cast nativeChainTraceAfterRoot_hash_length_le targets parameter table ftsSecret fuel q continuation hbound trace htrace) + · simp [probOutput_eq_zero_of_not_mem_support htrace] + _ ≤ _ := mul_le_mul_right (probEvent_nativeChainTraceAfterRoot_failure_le_inv216 targets parameter table ftsSecret fuel continuation) _ + +theorem canonicalGuessCharge_eq_native_components_of_safe + (targets : Finset Position) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hsafe : 0 < fuel ∧ context.state.pending.card + 1 < Fintype.card Digest) + (hcoverage : ∀ hashInput, input = .inl (.inr hashInput) → ∀ target digest, + (purePlanProbingHashQuery parameter hashInput context.state).candidate? = some ⟨.position target, digest⟩ → target ∈ targets) : + canonicalGuessCharge parameter table input context fuel cache = + nativeStartCharge parameter table input context fuel cache + + (∑ target ∈ targets, nativeMissingStructuralCharge target parameter table input context fuel cache) + + nativeMaterializedCharge parameter table input context fuel cache := by + simp only [canonicalGuessCharge, if_pos hsafe] + cases input with + | inl input => + cases input with + | inl n => simp [nativeStartCharge, nativeMissingStructuralCharge, nativeMaterializedCharge] + | inr input => exact candidateFailureAllowance_eq_native_components targets table context _ (hcoverage input rfl) + | inr message => simp [nativeStartCharge, nativeMissingStructuralCharge, nativeMaterializedCharge] + +theorem expected_nativeMaterializedCharge_afterRoot_le + (targets : Finset Position) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) + (hbound : ∀ root, (continuation root).IsQueryBoundP IsOuterHash q) : + (∑' root, Pr[= root | runResolvedFromTable (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)] * + match root with + | none => 0 + | some root => expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root.value.1 ftsSecret) + (nativeMaterializedCharge parameter table) (continuation root.value.1) + root.context root.remaining root.table root.value.2) ≤ + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + have hbound := expected_nativeMaterializedTraceCharge_afterRoot_le targets parameter table ftsSecret fuel q continuation hbound + rw [nativeChainTraceAfterRoot, tsum_probOutput_bind_mul] at hbound + convert hbound using 1 + apply tsum_congr + intro root + cases root with + | none => simp [canonicalTraceCharge] + | some root => rw [expectedNativeTraceCharge_eq] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeMaterializedCandidate.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeMaterializedCandidate.lean new file mode 100644 index 00000000..15d6a270 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeMaterializedCandidate.lean @@ -0,0 +1,75 @@ +import SphincsSecurity.Proof.OtsProbePrivateAllowanceReserve +import SphincsSecurity.Proof.OtsProbeSigningStartValues + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem purePlan_candidate_missing_or_chain + (parameter : PublicParameter) (input : HashInput) (state : LazyRevealProbe.State Coordinate) + (candidate : Probe) + (hplan : (purePlanProbingHashQuery parameter input state).candidate? = some candidate) : + state.values candidate.coordinate = none ∨ IsChainCoordinate candidate.coordinate := by + have hchain : ∀ decoded, decodeProbe? parameter input = some decoded → IsChainCoordinate decoded.coordinate := by + intro decoded hdecode + exact Probe.isChainCoordinate_of_matchesInput ((decodeProbe?_eq_some_iff parameter input decoded).mp hdecode) + unfold purePlanProbingHashQuery at hplan + generalize decodeProbe? parameter input = decoded at hchain hplan + generalize decodePosition? parameter input = position at hplan + cases decoded with + | some decoded => + have hdecoded := hchain decoded rfl + cases position with + | none => exact Or.inr ((Option.some.inj hplan) ▸ hdecoded) + | some position => + cases position + case leaf lay tree leafIdx => + exact Or.inl (leafInputProbePlan_some_value_none state input decoded candidate lay tree leafIdx hplan) + all_goals exact Or.inr ((Option.some.inj hplan) ▸ hdecoded) + | none => + cases position with + | none => simp at hplan + | some position => + cases position + case node lay tree level nodeIdx => + exact Or.inl (firstMissingInputCoordinatePlan_some_value_none state input 0 _ candidate hplan) + all_goals simp at hplan + +theorem purePlan_materialized_candidate_is_chain + (parameter : PublicParameter) (input : HashInput) (state : LazyRevealProbe.State Coordinate) + (candidate : Probe) + (hplan : (purePlanProbingHashQuery parameter input state).candidate? = some candidate) + (hknown : state.values candidate.coordinate ≠ none) : IsChainCoordinate candidate.coordinate := + (purePlan_candidate_missing_or_chain parameter input state candidate hplan).resolve_left hknown + +def MaterializedChainsPublished (context : DeferredContext) : Prop := + ∀ coordinate, IsChainCoordinate coordinate → context.state.values coordinate ≠ none → coordinate ∈ context.state.revealed + +theorem MaterializedChainsPublished.starts + {context : DeferredContext} (hpublic : MaterializedChainsPublished context) : MaterializedStartsPublished context := by + intro start hknown + exact hpublic start.coordinate (by cases start; trivial) hknown + +theorem MaterializedChainsPublished.candidate_missing_of_hidden + {context : DeferredContext} (hpublic : MaterializedChainsPublished context) + (parameter : PublicParameter) (input : HashInput) (candidate : Probe) + (hplan : (purePlanProbingHashQuery parameter input context.state).candidate? = some candidate) + (hhidden : candidate.coordinate ∉ context.state.revealed) : context.state.values candidate.coordinate = none := by + by_contra hknown + exact hhidden (hpublic candidate.coordinate + (purePlan_materialized_candidate_is_chain parameter input context.state candidate hplan hknown) hknown) + +theorem MaterializedChainsPublished.candidate_allowance_eq_zero_of_known + {context : DeferredContext} (hpublic : MaterializedChainsPublished context) + (parameter : PublicParameter) (input : HashInput) (candidate : Probe) (table : OtsSecretIndex → HashOutput) + (hplan : (purePlanProbingHashQuery parameter input context.state).candidate? = some candidate) + (hknown : context.state.values candidate.coordinate ≠ none) : + candidateFailureAllowance table context (some candidate) = 0 := by + have hrevealed := hpublic candidate.coordinate + (purePlan_materialized_candidate_is_chain parameter input context.state candidate hplan hknown) hknown + simp [candidateFailureAllowance, hrevealed] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeMissingStructuralCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeMissingStructuralCharge.lean new file mode 100644 index 00000000..4c4869da --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeMissingStructuralCharge.lean @@ -0,0 +1,93 @@ +import SphincsSecurity.Proof.OtsProbePrivateMissingHash + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def nativeMissingStructuralCharge + (target : Position) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (_fuel : Nat) (_cache : SplitHashCache) : ENNReal := + match input with + | .inl (.inr input) => privateMissingCandidateAllowance target table context + (purePlanProbingHashQuery parameter input context.state).candidate? + | _ => 0 + +theorem privateMissingAllowance_chronologicalQuery + (target : Position) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + privateLiveMissingProbeAllowance target ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) + context fuel table = + if DeferredCompletable table context then nativeMissingStructuralCharge target parameter table input context fuel cache else 0 := by + cases input with + | inl input => + cases input with + | inl n => + simpa [nativeMissingStructuralCharge, maskedChronologicalExpandedAdversaryImpl, probingRomImpl, maskedChronologicalSigningImpl] using + (privateLiveMissingProbeAllowance_eq_zero_of_probeFree target _ context fuel table (splitUniformImpl_probeFree n cache)) + | inr hashInput => exact privateMissingAllowance_probingHashQuery target parameter hashInput cache context fuel table hconsistent hstarts + | inr message => + simpa [nativeMissingStructuralCharge, maskedChronologicalExpandedAdversaryImpl, probingRomImpl, maskedChronologicalSigningImpl] using + (privateLiveMissingProbeAllowance_eq_zero_of_probeFree target _ context fuel table + (maskedPublishedChronologicalSign_probeFree parameter root ftsSecret message cache)) + +theorem privateMissingAllowance_chronological_eq_nativeCharge + (target : Position) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + privateLiveMissingProbeAllowance target + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) context fuel table = + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (nativeMissingStructuralCharge target parameter table) computation context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => simp [privateLiveMissingProbeAllowance, expectedLiveNativeContextCharge] + | query_bind input next ih => + by_cases hcomplete : DeferredCompletable table context + · rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, + privateLiveMissingProbeAllowance_bind target _ _ context fuel table hconsistent hstarts, + privateMissingAllowance_chronologicalQuery target parameter root ftsSecret input context fuel table cache hconsistent hstarts, + if_pos hcomplete, expectedLiveNativeContextCharge_query_bind, if_pos hcomplete] + congr 1 + apply tsum_congr + intro option + by_cases hoption : option ∈ support (runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache)) + · cases option with + | none => simp [privateMissingContinuationAllowance] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table result hconsistent hstarts hoption + dsimp only [privateMissingContinuationAllowance] + rw [hcore.1, ih result.value.1 result.context result.remaining table result.value.2 hcore.2.1 hcore.2.2] + · simp [probOutput_eq_zero_of_not_mem_support hoption] + · rw [privateLiveMissingProbeAllowance_eq_zero_of_not_completable target _ context fuel table hcomplete, + expectedLiveNativeContextCharge_eq_zero_of_not_completable _ _ _ context fuel table cache hcomplete] + +theorem sum_nativeMissingStructuralCharge_ensuredInitial_le_structuralCharge + (targets : Finset Position) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (q fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) (hq : q ≤ 2 ^ 126) + (hbound : ∀ target ∈ targets, + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache).IsQueryBoundP + (IsPrivatePositionProbe target) q) : + (∑ target ∈ targets, expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (nativeMissingStructuralCharge target parameter table) computation (ensuredInitialContext targets) fuel table cache) ≤ + expectedLiveResolvedQueryCharge structuralProbeQueryCharge + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) + (ensuredInitialContext targets) fuel table * ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + calc + _ = ∑ target ∈ targets, privateLiveMissingProbeAllowance target + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) + (ensuredInitialContext targets) fuel table := by + apply Finset.sum_congr rfl + intro target _ + exact (privateMissingAllowance_chronological_eq_nativeCharge target parameter root ftsSecret computation + (ensuredInitialContext targets) fuel table cache (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table))).symm + _ ≤ _ := sum_privateLiveMissingProbeAllowance_ensuredInitial_le_structuralCharge targets _ q fuel table hq hbound + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeOrdinaryCache.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeOrdinaryCache.lean new file mode 100644 index 00000000..0d69ef74 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeOrdinaryCache.lean @@ -0,0 +1,243 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootSwap + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +def OrdinarySplitCacheEq (left right : SplitHashCache) : Prop := + ∀ input, left (.ordinary input) = right (.ordinary input) + +theorem OrdinarySplitCacheEq.update {left right : SplitHashCache} + (h : OrdinarySplitCacheEq left right) (key : SplitHashKey) (output : HashOutput) : + OrdinarySplitCacheEq (Function.update left key (some output)) (Function.update right key (some output)) := by + intro input + by_cases heq : SplitHashKey.ordinary input = key + · simp [heq] + · simp [Function.update_of_ne heq, h input] + +def OrdinaryCacheNativeSameRel : + Option (ResolvedRunResult (α × SplitHashCache)) → + Option (ResolvedRunResult (α × SplitHashCache)) → Prop + | some left, some right => + left.context = right.context ∧ left.remaining = right.remaining ∧ + left.table = right.table ∧ left.value.1 = right.value.1 ∧ + OrdinarySplitCacheEq left.value.2 right.value.2 + | none, none => True + | _, _ => False + +def OrdinaryCacheNativeCouples + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftCache rightCache, + OrdinarySplitCacheEq leftCache rightCache → + ∀ state fuel table, + RelTriple + (runResolvedFromTable state fuel table (computation.run leftCache)) + (runResolvedFromTable state fuel table (computation.run rightCache)) + OrdinaryCacheNativeSameRel + +theorem ordinaryCacheNativeCouples_pure + (value : α) : + OrdinaryCacheNativeCouples + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := by + intro leftCache rightCache hcache state fuel table + simp only [StateT.run_pure, runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem ordinaryCacheNativeCouples_ensureCoordinate + (coordinate : Coordinate) : + OrdinaryCacheNativeCouples + (ensureCoordinate coordinate) := by + intro leftCache rightCache hcache state fuel table + change RelTriple + (runResolvedFromTable state fuel table (LazyRevealProbe.ensureQuery coordinate >>= fun value => pure (value, leftCache))) + (runResolvedFromTable state fuel table (LazyRevealProbe.ensureQuery coordinate >>= fun value => pure (value, rightCache))) _ + rw [LazyRevealProbe.ensureQuery, runResolvedFromTable_ensure_query_bind, runResolvedFromTable_ensure_query_bind] + simp only [runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem OrdinaryCacheNativeCouples.bind + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : OrdinaryCacheNativeCouples left) + (hnext : ∀ value, + OrdinaryCacheNativeCouples (next value)) : + OrdinaryCacheNativeCouples (left >>= next) := by + intro leftCache rightCache hcache state fuel table + rw [StateT.run_bind, StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_bind] + apply relTriple_bind (hleft leftCache rightCache hcache state fuel table) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [OrdinaryCacheNativeSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [OrdinaryCacheNativeSameRel] at hresult + | some rightResult => + rcases hresult with ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + simp only + rw [← hstate, ← hremaining, ← htable, ← hvalue] + exact hnext leftResult.value.1 leftResult.value.2 rightResult.value.2 hnextCache + leftResult.context leftResult.remaining leftResult.table + +theorem ordinaryCacheNativeCouples_sequenceFin + {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, + OrdinaryCacheNativeCouples (computation index)) : + OrdinaryCacheNativeCouples + (sequenceFin computation) := by + induction n with + | zero => + simp only [sequenceFin] + exact ordinaryCacheNativeCouples_pure Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomponent 0).bind fun _ => + (ih (fun index : Fin n => computation index.succ) + (fun index => hcomponent index.succ)).bind fun _ => + ordinaryCacheNativeCouples_pure _ + +theorem ordinaryCacheNativeCouples_ensureChainPrefix + (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + OrdinaryCacheNativeCouples + (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (ordinaryCacheNativeCouples_sequenceFin _ + fun step => by + by_cases hstep : step.val < digit.val + · rw [if_pos hstep] + exact ordinaryCacheNativeCouples_ensureCoordinate _ + · rw [if_neg hstep] + exact ordinaryCacheNativeCouples_pure ()).bind fun _ => + ordinaryCacheNativeCouples_pure () + +theorem ordinaryCacheNativeCouples_worldStep + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (finish : α → SplitHashCache → β × SplitHashCache) + (hfinish : ∀ output leftCache rightCache, + OrdinarySplitCacheEq leftCache rightCache → + (finish output leftCache).1 = (finish output rightCache).1 ∧ + OrdinarySplitCacheEq + (finish output leftCache).2 (finish output rightCache).2) : + OrdinaryCacheNativeCouples + (fun cache => computation >>= fun output => pure (finish output cache)) := by + intro leftCache rightCache hcache context fuel table + change RelTriple + (runResolvedFromTable context fuel table (computation >>= fun output => pure (finish output leftCache))) + (runResolvedFromTable context fuel table (computation >>= fun output => pure (finish output rightCache))) _ + rw [runResolvedFromTable_bind, runResolvedFromTable_bind] + apply relTriple_bind (relTriple_refl (runResolvedFromTable context fuel table computation)) + intro leftResult rightResult heq + subst rightResult + cases leftResult with + | none => exact relTriple_pure_pure trivial + | some result => + simp only [runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, hfinish result.value leftCache rightCache hcache⟩ + +theorem ordinaryCacheNativeCouples_revealCoordinateOutput (coordinate : Coordinate) : + OrdinaryCacheNativeCouples (revealCoordinateOutput coordinate) := by + have heq : revealCoordinateOutput coordinate = + (fun cache : SplitHashCache => LazyRevealProbe.revealQuery coordinate >>= fun output => + pure (output, Function.update cache (.hidden coordinate) (some output))) := by + funext cache + exact revealCoordinateOutput_run_eq coordinate cache + rw [heq] + exact ordinaryCacheNativeCouples_worldStep _ _ fun output left right h => ⟨rfl, h.update _ output⟩ + +theorem ordinaryCacheNativeCouples_revealCoordinate (coordinate : Coordinate) : + OrdinaryCacheNativeCouples (revealCoordinate coordinate) := by + unfold revealCoordinate + exact (ordinaryCacheNativeCouples_revealCoordinateOutput coordinate).bind fun output => + ordinaryCacheNativeCouples_pure (truncateHash output) + +theorem ordinaryCacheNativeCouples_revealPosition (position : Position) : + OrdinaryCacheNativeCouples (revealPosition position) := + ordinaryCacheNativeCouples_revealCoordinate (.position position) + +theorem ordinaryCacheNativeCouples_publishCoordinate (coordinate : Coordinate) : + OrdinaryCacheNativeCouples (publishCoordinate coordinate) := by + unfold publishCoordinate + exact ordinaryCacheNativeCouples_worldStep _ _ fun _ _ _ h => ⟨rfl, h⟩ + +theorem ordinaryCacheNativeCouples_peekCoordinate (coordinate : Coordinate) : + OrdinaryCacheNativeCouples (peekCoordinate coordinate) := by + intro left right h context fuel table + rw [peekCoordinate_run_eq, peekCoordinate_run_eq, LazyRevealProbe.peekQuery, + runResolvedFromTable_peek_query_bind, runResolvedFromTable_peek_query_bind] + simp only [runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, h⟩ + +theorem ordinaryCacheNativeCouples_probe (candidate : Probe) : + OrdinaryCacheNativeCouples (probe candidate) := by + unfold probe + exact ordinaryCacheNativeCouples_worldStep _ _ fun _ _ _ h => ⟨rfl, h⟩ + +theorem ordinaryCacheNativeCouples_splitUniformImpl (n : Nat) : + OrdinaryCacheNativeCouples (splitUniformImpl n) := by + unfold splitUniformImpl + exact ordinaryCacheNativeCouples_worldStep _ _ fun _ _ _ h => ⟨rfl, h⟩ + +theorem ordinaryCacheNativeCouples_splitHashQuery (input : HashInput) : + OrdinaryCacheNativeCouples (splitHashQuery (.ordinary input)) := by + intro left right h context fuel table + have hlookup := h input + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + cases hleft : left (.ordinary input) with + | some output => + have hright : right (.ordinary input) = some output := hlookup.symm.trans hleft + simp only [hright, runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, h⟩ + | none => + have hright : right (.ordinary input) = none := hlookup.symm.trans hleft + simp only [hright] + unfold LazyRevealProbe.hashOutputQuery + rw [runResolvedFromTable_hashOutput_query_bind, runResolvedFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + simp only [runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, h.update _ leftOutput⟩ + +theorem ordinaryCacheNativeCouples_modifyOrdinary (input : HashInput) (output : HashOutput) : + OrdinaryCacheNativeCouples + (modify fun cache : SplitHashCache => Function.update cache (.ordinary input) (some output)) := by + intro left right h context fuel table + simp only [StateT.run_modify, runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, h.update _ output⟩ + +theorem ordinaryCacheNativeCouples_simulateQ {spec : OracleSpec ι} + (impl : QueryImpl spec (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (himpl : ∀ query, OrdinaryCacheNativeCouples (impl query)) + (computation : OracleComp spec α) : OrdinaryCacheNativeCouples (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => simpa only [simulateQ_pure] using ordinaryCacheNativeCouples_pure value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (himpl query).bind ih + +theorem ordinaryCacheNativeCouples_ordinaryHash (computation : OracleComp HashSpec α) : + OrdinaryCacheNativeCouples (simulateQ ordinaryHashImpl computation) := + ordinaryCacheNativeCouples_simulateQ ordinaryHashImpl ordinaryCacheNativeCouples_splitHashQuery computation + +theorem ordinaryCacheNativeCouples_ordinaryRom (computation : OracleComp OracleWorld α) : + OrdinaryCacheNativeCouples (simulateQ ordinaryRomImpl computation) := by + apply ordinaryCacheNativeCouples_simulateQ + intro query + cases query with + | inl n => exact ordinaryCacheNativeCouples_splitUniformImpl n + | inr input => exact ordinaryCacheNativeCouples_splitHashQuery input + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeOrdinaryCacheHash.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeOrdinaryCacheHash.lean new file mode 100644 index 00000000..1251e30e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeOrdinaryCacheHash.lean @@ -0,0 +1,153 @@ +import SphincsSecurity.Proof.OtsProbeNativeOrdinaryCacheSigner + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +set_option backward.isDefEq.respectTransparency false + +theorem ordinaryCacheNativeCouples_peekPositionValues + : ∀ positions, + OrdinaryCacheNativeCouples + (peekPositionValues positions) + | [] => by + rw [peekPositionValues] + exact ordinaryCacheNativeCouples_pure (some []) + | position :: remaining => by + rw [peekPositionValues] + apply (ordinaryCacheNativeCouples_peekCoordinate + (.position position)).bind + intro value + cases value with + | none => exact ordinaryCacheNativeCouples_pure none + | some value => + apply (ordinaryCacheNativeCouples_peekPositionValues + remaining).bind + intro values + cases values with + | none => exact ordinaryCacheNativeCouples_pure none + | some values => + exact ordinaryCacheNativeCouples_pure + (some (value :: values)) + +theorem ordinaryCacheNativeCouples_peekTableInput + (parameter : PublicParameter) (coordinate : Coordinate) : + OrdinaryCacheNativeCouples + (peekTableInput parameter coordinate) := by + cases coordinate with + | chainStart => + exact ordinaryCacheNativeCouples_pure none + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput] + by_cases hzero : step.val = 0 + · rw [if_pos hzero] + exact (ordinaryCacheNativeCouples_peekCoordinate + (.chainStart lay tree leafIdx chainIdx)).bind fun value => + match value with + | none => ordinaryCacheNativeCouples_pure none + | some _ => ordinaryCacheNativeCouples_pure _ + · rw [if_neg hzero] + exact (ordinaryCacheNativeCouples_peekPositionValues + (Position.chain lay tree leafIdx chainIdx step).children).bind fun values => + match values with + | none => ordinaryCacheNativeCouples_pure none + | some _ => ordinaryCacheNativeCouples_pure _ + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp only [peekTableInput] + exact (ordinaryCacheNativeCouples_peekPositionValues + _).bind fun values => + match values with + | none => ordinaryCacheNativeCouples_pure none + | some _ => ordinaryCacheNativeCouples_pure _ + +theorem ordinaryCacheNativeCouples_resolveKnownInput + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) : + OrdinaryCacheNativeCouples (resolveKnownInput parameter coordinate input) := by + unfold resolveKnownInput + apply (ordinaryCacheNativeCouples_peekTableInput parameter coordinate).bind + intro knownInput + cases knownInput with + | none => exact ordinaryCacheNativeCouples_splitHashQuery input + | some knownInput => + simp only + by_cases heq : knownInput = input + · rw [if_pos heq] + exact (ordinaryCacheNativeCouples_revealCoordinateOutput coordinate).bind fun output => + (ordinaryCacheNativeCouples_publishCoordinate coordinate).bind fun _ => + (ordinaryCacheNativeCouples_modifyOrdinary input output).bind fun _ => + ordinaryCacheNativeCouples_pure output + · rw [if_neg heq] + exact ordinaryCacheNativeCouples_splitHashQuery input + +theorem ordinaryCacheNativeCouples_probeFirstMissingInputCoordinate (input : HashInput) : + ∀ slot coordinates, OrdinaryCacheNativeCouples (probeFirstMissingInputCoordinate input slot coordinates) + | _, [] => ordinaryCacheNativeCouples_pure () + | slot, coordinate :: remaining => by + rw [probeFirstMissingInputCoordinate] + apply (ordinaryCacheNativeCouples_peekCoordinate coordinate).bind + intro value + cases value with + | none => exact ordinaryCacheNativeCouples_probe _ + | some value => exact ordinaryCacheNativeCouples_probeFirstMissingInputCoordinate input (slot + 1) remaining + +theorem ordinaryCacheNativeCouples_prepareLeafInputProbe + (input : HashInput) (candidate : Probe) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + OrdinaryCacheNativeCouples (prepareLeafInputProbe input candidate lay tree leafIdx) := by + unfold prepareLeafInputProbe + apply (ordinaryCacheNativeCouples_peekCoordinate candidate.coordinate).bind + intro value + cases value with + | none => exact ordinaryCacheNativeCouples_probe candidate + | some value => exact ordinaryCacheNativeCouples_probeFirstMissingInputCoordinate input 0 _ + +theorem ordinaryCacheNativeCouples_probingHashQuery + (parameter : PublicParameter) (input : HashInput) : + OrdinaryCacheNativeCouples (probingHashQuery parameter input) := by + unfold probingHashQuery + cases hprobe : decodeProbe? parameter input with + | none => + cases hposition : decodePosition? parameter input with + | none => exact ordinaryCacheNativeCouples_splitHashQuery input + | some position => + cases position with + | chain | leaf => exact ordinaryCacheNativeCouples_resolveKnownInput parameter _ input + | node => + exact (ordinaryCacheNativeCouples_probeFirstMissingInputCoordinate input 0 _).bind fun _ => + ordinaryCacheNativeCouples_resolveKnownInput parameter _ input + | ftsLeaf | ftsNode | ftsRoots => exact ordinaryCacheNativeCouples_splitHashQuery input + | some candidate => + cases hposition : decodePosition? parameter input with + | none => + exact (ordinaryCacheNativeCouples_probe candidate).bind fun _ => + ordinaryCacheNativeCouples_resolveKnownInput parameter _ input + | some position => + cases position with + | leaf lay tree leafIdx => + exact (ordinaryCacheNativeCouples_prepareLeafInputProbe input candidate lay tree leafIdx).bind fun _ => + ordinaryCacheNativeCouples_resolveKnownInput parameter _ input + | chain | node | ftsLeaf | ftsNode | ftsRoots => + exact (ordinaryCacheNativeCouples_probe candidate).bind fun _ => + ordinaryCacheNativeCouples_resolveKnownInput parameter _ input + +theorem ordinaryCacheNativeCouples_chronologicalOuterQuery + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) : + OrdinaryCacheNativeCouples (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input) := by + cases input with + | inl input => + cases input with + | inl n => exact ordinaryCacheNativeCouples_splitUniformImpl n + | inr input => exact ordinaryCacheNativeCouples_probingHashQuery parameter input + | inr message => exact ordinaryCacheNativeCouples_chronologicalSign parameter root ftsSecret message + +theorem ordinaryCacheNativeCouples_chronologicalOuterComputation + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + OrdinaryCacheNativeCouples + (simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation) := + ordinaryCacheNativeCouples_simulateQ _ + (ordinaryCacheNativeCouples_chronologicalOuterQuery parameter root ftsSecret) computation + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeOrdinaryCacheSelection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeOrdinaryCacheSelection.lean new file mode 100644 index 00000000..8b8db7ee --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeOrdinaryCacheSelection.lean @@ -0,0 +1,102 @@ +import SphincsSecurity.Proof.OtsProbeNativeOrdinaryCacheHash +import SphincsSecurity.Proof.OtsProbeLiveHashSelection + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def OrdinaryCacheSelectionRel : Option CanonicalQuerySelection → Option CanonicalQuerySelection → Prop + | some left, some right => + left.input = right.input ∧ left.context = right.context ∧ left.fuel = right.fuel ∧ + left.table = right.table ∧ OrdinarySplitCacheEq left.cache right.cache + | none, none => True + | _, _ => False + +theorem relTriple_liveNativeHashQuerySelection_ordinaryCache + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (himpl : ∀ input, OrdinaryCacheNativeCouples (impl input)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) (hcache : OrdinarySplitCacheEq leftCache rightCache) : + RelTriple (liveNativeHashQuerySelection impl computation ordinal context fuel table leftCache) + (liveNativeHashQuerySelection impl computation ordinal context fuel table rightCache) + OrdinaryCacheSelectionRel := by + induction computation using OracleComp.inductionOn generalizing ordinal context fuel table leftCache rightCache with + | pure value => exact relTriple_pure_pure trivial + | query_bind input next ih => + rw [liveNativeHashQuerySelection_query_bind, liveNativeHashQuerySelection_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete, if_pos hcomplete] + by_cases hselected : IsOuterHash input ∧ ordinal = 0 + · rw [if_pos hselected, if_pos hselected] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + · rw [if_neg hselected, if_neg hselected] + apply relTriple_bind (himpl input leftCache rightCache hcache context fuel table) + intro left right hrel + cases left with + | none => + cases right with + | none => exact relTriple_pure_pure trivial + | some right => contradiction + | some left => + cases right with + | none => contradiction + | some right => + rcases hrel with ⟨hcontext, hfuel, htable, hvalue, hcaches⟩ + simp only + rw [← hcontext, ← hfuel, ← htable, ← hvalue] + exact ih left.value.1 _ left.context left.remaining left.table left.value.2 right.value.2 hcaches + · rw [if_neg hcomplete, if_neg hcomplete] + exact relTriple_pure_pure trivial + +def eraseHiddenSplitCache (cache : SplitHashCache) : SplitHashCache + | .ordinary input => cache (.ordinary input) + | .hidden _ => none + +def eraseHiddenSelectionCache (selection : Option CanonicalQuerySelection) : Option CanonicalQuerySelection := + selection.map fun selection => { selection with cache := eraseHiddenSplitCache selection.cache } + +theorem OrdinaryCacheSelectionRel.eraseHiddenCache + {left right : Option CanonicalQuerySelection} (h : OrdinaryCacheSelectionRel left right) : + eraseHiddenSelectionCache left = eraseHiddenSelectionCache right := by + cases left with + | none => + cases right with + | none => rfl + | some right => contradiction + | some left => + cases right with + | none => contradiction + | some right => + rcases h with ⟨hinput, hcontext, hfuel, htable, hcache⟩ + have hcaches : eraseHiddenSplitCache left.cache = eraseHiddenSplitCache right.cache := by + funext key + cases key with + | ordinary input => exact hcache input + | hidden coordinate => rfl + simp only [eraseHiddenSelectionCache, Option.map_some, hinput, hcontext, hfuel, htable, hcaches] + +theorem evalDist_nativeChronologicalHashSelection_eraseHiddenCache + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) (hcache : OrdinarySplitCacheEq leftCache rightCache) : + evalDist (eraseHiddenSelectionCache <$> + liveNativeHashQuerySelection (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + computation ordinal context fuel table leftCache) = + evalDist (eraseHiddenSelectionCache <$> + liveNativeHashQuerySelection (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + computation ordinal context fuel table rightCache) := by + apply evalDist_map_eq_of_relTriple + apply relTriple_post_mono + (relTriple_liveNativeHashQuerySelection_ordinaryCache _ + (ordinaryCacheNativeCouples_chronologicalOuterQuery parameter root ftsSecret) + computation ordinal context fuel table leftCache rightCache hcache) + intro left right hrel + exact hrel.eraseHiddenCache + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeOrdinaryCacheSigner.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeOrdinaryCacheSigner.lean new file mode 100644 index 00000000..2b21e4ca --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeOrdinaryCacheSigner.lean @@ -0,0 +1,267 @@ +import SphincsSecurity.Proof.OtsProbeNativeOrdinaryCache + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +set_option backward.isDefEq.respectTransparency false + +theorem ordinaryCacheNativeCouples_ensureFullChain + (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + OrdinaryCacheNativeCouples + (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (ordinaryCacheNativeCouples_sequenceFin _ + fun step => ordinaryCacheNativeCouples_ensureCoordinate + (.position (.chain lay tree leafIdx chainIdx step))).bind fun _ => + ordinaryCacheNativeCouples_pure () + +theorem ordinaryCacheNativeCouples_ensureOtsLeaf + (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + OrdinaryCacheNativeCouples + (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (ordinaryCacheNativeCouples_sequenceFin _ + fun chainIdx => ordinaryCacheNativeCouples_ensureFullChain + lay tree leafIdx chainIdx).bind fun _ => + ordinaryCacheNativeCouples_ensureCoordinate + (.position (.leaf lay tree leafIdx)) + +theorem ordinaryCacheNativeCouples_ensureTreeNode + (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, + OrdinaryCacheNativeCouples + (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => by + rw [ensureTreeNode] + exact ordinaryCacheNativeCouples_ensureOtsLeaf lay tree + (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (ordinaryCacheNativeCouples_ensureTreeNode lay tree + level (2 * nodeIdx)).bind fun _ => + (ordinaryCacheNativeCouples_ensureTreeNode lay tree + level (2 * nodeIdx + 1)).bind fun _ => by + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact ordinaryCacheNativeCouples_ensureCoordinate (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact ordinaryCacheNativeCouples_pure () + +theorem ordinaryCacheNativeCouples_ensureTreePath + (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + OrdinaryCacheNativeCouples + (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (ordinaryCacheNativeCouples_sequenceFin _ + fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + exact ordinaryCacheNativeCouples_ensureTreeNode lay tree + level.val (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · rw [if_neg hlevel] + exact ordinaryCacheNativeCouples_pure ()).bind fun _ => + ordinaryCacheNativeCouples_pure () + +theorem ordinaryCacheNativeCouples_revealPublishedCoordinate + (coordinate : Coordinate) : + OrdinaryCacheNativeCouples + (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + exact (ordinaryCacheNativeCouples_revealCoordinate + coordinate).bind fun _ => + (ordinaryCacheNativeCouples_publishCoordinate + coordinate).bind fun _ => + ordinaryCacheNativeCouples_pure _ + +theorem ordinaryCacheNativeCouples_revealLayerValues + (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + OrdinaryCacheNativeCouples + (revealLayerValues index lay encoding) := by + unfold revealLayerValues + apply (ordinaryCacheNativeCouples_sequenceFin _ + fun chainIdx => ordinaryCacheNativeCouples_revealPublishedCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + (encoding chainIdx))).bind + intro values + apply (ordinaryCacheNativeCouples_sequenceFin _ + fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + cases hzero : level.val with + | zero => + exact ordinaryCacheNativeCouples_revealPublishedCoordinate (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | succ current => + rw [Nat.add_one] + simp only + by_cases hcurrent : current < maxLayerHeight + · rw [dif_pos hcurrent] + exact ordinaryCacheNativeCouples_revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) ⟨current, hcurrent⟩ + (leafOfNat (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + · rw [dif_neg hcurrent] + exact ordinaryCacheNativeCouples_pure 0 + · rw [if_neg hlevel] + exact ordinaryCacheNativeCouples_pure 0).bind + intro path + exact ordinaryCacheNativeCouples_pure (values, path) + +theorem ordinaryCacheNativeCouples_maskedTreeNode + (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, + OrdinaryCacheNativeCouples + (maskedTreeNode lay tree level nodeIdx) + | level, nodeIdx => by + unfold maskedTreeNode + apply (ordinaryCacheNativeCouples_ensureTreeNode lay tree + level nodeIdx).bind + intro _ + cases level with + | zero => + exact ordinaryCacheNativeCouples_revealPosition + (.leaf lay tree (leafOfNat nodeIdx)) + | succ current => + rw [Nat.add_one] + simp only + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact ordinaryCacheNativeCouples_revealPosition + (.node lay tree ⟨current, hlevel⟩ (leafOfNat nodeIdx)) + · rw [dif_neg hlevel] + exact ordinaryCacheNativeCouples_pure 0 + +theorem ordinaryCacheNativeCouples_maskedTreeRoot + (lay : Layer) (tree : TreeIndex) : + OrdinaryCacheNativeCouples + (maskedTreeRoot lay tree) := + ordinaryCacheNativeCouples_maskedTreeNode lay tree + (layerHeight lay) 0 + +theorem ordinaryCacheNativeCouples_revealPrivateLayerValues + (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + OrdinaryCacheNativeCouples + (revealPrivateLayerValues index lay encoding) := by + unfold revealPrivateLayerValues + apply (ordinaryCacheNativeCouples_sequenceFin _ + fun chainIdx => ordinaryCacheNativeCouples_revealCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + (encoding chainIdx))).bind + intro values + apply (ordinaryCacheNativeCouples_sequenceFin _ + fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + cases hzero : level.val with + | zero => + exact ordinaryCacheNativeCouples_revealCoordinate (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | succ current => + rw [Nat.add_one] + simp only + by_cases hcurrent : current < maxLayerHeight + · rw [dif_pos hcurrent] + exact ordinaryCacheNativeCouples_revealCoordinate (.position (.node lay (treeIndexAt index lay) ⟨current, hcurrent⟩ + (leafOfNat (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + · rw [dif_neg hcurrent] + exact ordinaryCacheNativeCouples_pure 0 + · rw [if_neg hlevel] + exact ordinaryCacheNativeCouples_pure 0).bind + intro path + exact ordinaryCacheNativeCouples_pure (values, path) + +theorem ordinaryCacheNativeCouples_maskedLayerMessage (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + OrdinaryCacheNativeCouples (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + by_cases hbelow : lay.val + 1 < numLayers + · rw [dif_pos hbelow] + exact ordinaryCacheNativeCouples_maskedTreeRoot _ _ + · rw [dif_neg hbelow] + exact ordinaryCacheNativeCouples_ordinaryHash _ + +theorem ordinaryCacheNativeCouples_maskedOtsSignFrom (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter, OrdinaryCacheNativeCouples + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom] + exact ordinaryCacheNativeCouples_pure none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + apply (ordinaryCacheNativeCouples_ordinaryHash _).bind + intro encoded + cases encoded with + | none => exact ordinaryCacheNativeCouples_maskedOtsSignFrom parameter lay tree leafIdx message attempts (counter + 1) + | some encoding => + exact (ordinaryCacheNativeCouples_sequenceFin _ + (fun chainIdx => ordinaryCacheNativeCouples_ensureChainPrefix lay tree leafIdx chainIdx (encoding chainIdx))).bind + fun _ => ordinaryCacheNativeCouples_pure _ + +theorem ordinaryCacheNativeCouples_maskedSignLayer (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + OrdinaryCacheNativeCouples (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + apply (ordinaryCacheNativeCouples_maskedLayerMessage parameter ftsSecret index lay).bind + intro message + apply (ordinaryCacheNativeCouples_maskedOtsSignFrom parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message encodingAttemptLimit 0).bind + intro selected + cases selected with + | none => exact ordinaryCacheNativeCouples_pure none + | some selected => + exact (ordinaryCacheNativeCouples_ensureTreePath lay (treeIndexAt index lay) (leafIndexAt index lay)).bind + fun _ => ordinaryCacheNativeCouples_pure (some selected) + +theorem ordinaryCacheNativeCouples_chronologicalSignLayer (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + OrdinaryCacheNativeCouples (maskedChronologicalSignLayer parameter ftsSecret index lay) := by + unfold maskedChronologicalSignLayer + apply (ordinaryCacheNativeCouples_maskedSignLayer parameter ftsSecret index lay).bind + intro selected + cases selected with + | none => exact ordinaryCacheNativeCouples_pure none + | some selected => + exact (ordinaryCacheNativeCouples_revealPrivateLayerValues index lay selected.2).bind + fun values => ordinaryCacheNativeCouples_pure _ + +theorem ordinaryCacheNativeCouples_publishChronologicalSignature + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) (layers : Layer → Option ChronologicalLayerPart) : + OrdinaryCacheNativeCouples (publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers) := by + unfold publishChronologicalSignature + cases hparts : traverseOption layers with + | none => exact ordinaryCacheNativeCouples_pure none + | some parts => + exact (ordinaryCacheNativeCouples_sequenceFin _ + (fun lay => ordinaryCacheNativeCouples_revealLayerValues index lay (parts lay).encoding)).bind + fun published => ordinaryCacheNativeCouples_pure _ + +theorem ordinaryCacheNativeCouples_chronologicalSignAfterDigest (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + OrdinaryCacheNativeCouples + (maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedPublishedChronologicalSignAfterDigest maskedChronologicalSignLayers + exact (ordinaryCacheNativeCouples_ordinaryHash _).bind fun ftsPath => + (ordinaryCacheNativeCouples_sequenceFin _ + (fun lay => ordinaryCacheNativeCouples_chronologicalSignLayer parameter ftsSecret index lay)).bind + fun layers => ordinaryCacheNativeCouples_publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers + +theorem ordinaryCacheNativeCouples_chronologicalSign (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + OrdinaryCacheNativeCouples (maskedPublishedChronologicalSign parameter root ftsSecret message) := by + unfold maskedPublishedChronologicalSign + apply (ordinaryCacheNativeCouples_ordinaryRom _).bind + intro selected + cases selected with + | none => exact ordinaryCacheNativeCouples_pure none + | some selected => + exact ordinaryCacheNativeCouples_chronologicalSignAfterDigest parameter ftsSecret selected.1 selected.2.1 selected.2.2 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeOuterCut.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeOuterCut.lean new file mode 100644 index 00000000..26c9dd43 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeOuterCut.lean @@ -0,0 +1,104 @@ +import SphincsSecurity.Proof.OtsProbeNativeOrdinaryCacheHash +import SphincsSecurity.Proof.OuterQueryCut + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def runNativeOuterCut + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (safe : (OracleWorld + SigningSpec).Domain → DeferredContext → Prop) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp (Option (ResolvedRunResult (OuterQueryCut α × SplitHashCache))) := + OracleComp.construct + (fun value context fuel table cache => pure (some ⟨context, fuel, (.done value, cache), table⟩)) + (fun input next recursivelyRun context fuel table cache => + if safe input context then do + let result ← runResolvedFromTable context fuel table ((impl input).run cache) + match result with + | none => pure none + | some result => recursivelyRun result.value.1 result.context result.remaining result.table result.value.2 + else pure (some ⟨context, fuel, (.query input next, cache), table⟩)) computation + +theorem runNativeOuterCut_query_bind + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (safe : (OracleWorld + SigningSpec).Domain → DeferredContext → Prop) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runNativeOuterCut impl safe (OracleSpec.query input >>= next) context fuel table cache = + if safe input context then do + let result ← runResolvedFromTable context fuel table ((impl input).run cache) + match result with + | none => pure none + | some result => runNativeOuterCut impl safe (next result.value.1) result.context result.remaining result.table result.value.2 + else pure (some ⟨context, fuel, (.query input next, cache), table⟩) := rfl + +noncomputable def resumeNativeOuterCut + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) : + Option (ResolvedRunResult (OuterQueryCut α × SplitHashCache)) → ProbComp (Option (ResolvedRunResult (α × SplitHashCache))) + | none => pure none + | some result => runResolvedFromTable result.context result.remaining result.table + ((simulateQ impl result.value.1.resume).run result.value.2) + +theorem runNativeOuterCut_resume + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (safe : (OracleWorld + SigningSpec).Domain → DeferredContext → Prop) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runNativeOuterCut impl safe computation context fuel table cache >>= resumeNativeOuterCut impl = + runResolvedFromTable context fuel table ((simulateQ impl computation).run cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => rfl + | query_bind input next ih => + rw [runNativeOuterCut_query_bind] + by_cases hsafe : safe input context + · rw [if_pos hsafe, bind_assoc] + simp only [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, runResolvedFromTable_bind] + apply bind_congr + intro result + cases result with + | none => rfl + | some result => exact ih result.value.1 result.context result.remaining result.table result.value.2 + · rw [if_neg hsafe, pure_bind] + rfl + +theorem relTriple_runNativeOuterCut_ordinaryCache + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (himpl : ∀ input, OrdinaryCacheNativeCouples (impl input)) + (safe : (OracleWorld + SigningSpec).Domain → DeferredContext → Prop) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) (hcache : OrdinarySplitCacheEq leftCache rightCache) : + RelTriple (runNativeOuterCut impl safe computation context fuel table leftCache) + (runNativeOuterCut impl safe computation context fuel table rightCache) OrdinaryCacheNativeSameRel := by + induction computation using OracleComp.inductionOn generalizing context fuel table leftCache rightCache with + | pure value => exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + | query_bind input next ih => + rw [runNativeOuterCut_query_bind, runNativeOuterCut_query_bind] + by_cases hsafe : safe input context + · rw [if_pos hsafe, if_pos hsafe] + apply relTriple_bind (himpl input leftCache rightCache hcache context fuel table) + intro left right hrel + cases left with + | none => + cases right with + | none => exact relTriple_pure_pure trivial + | some right => contradiction + | some left => + cases right with + | none => contradiction + | some right => + rcases hrel with ⟨hcontext, hfuel, htable, hvalue, hcaches⟩ + simp only + rw [← hcontext, ← hfuel, ← htable, ← hvalue] + exact ih left.value.1 left.context left.remaining left.table left.value.2 right.value.2 hcaches + · rw [if_neg hsafe, if_neg hsafe] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativePeekInput.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativePeekInput.lean new file mode 100644 index 00000000..2004dc65 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativePeekInput.lean @@ -0,0 +1,95 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootSwapOrdinaryCache + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +set_option backward.isDefEq.respectTransparency false + +theorem runResolvedFromTable_peekPositionValues_eq_pure + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ∀ positions, + runResolvedFromTable context fuel table + ((peekPositionValues positions).run cache) = + pure (some ⟨context, fuel, + (purePeekPositionValues context.state positions, cache), table⟩) + | [] => by + simp [peekPositionValues, purePeekPositionValues, + runResolvedFromTable] + | position :: remaining => by + rw [peekPositionValues, StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekCoordinate] + cases hvalue : context.state.values (.position position) with + | none => + simp [purePeekPositionValues, hvalue, runResolvedFromTable] + | some value => + simp only [pure_bind, Option.map_some] + rw [StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekPositionValues_eq_pure context fuel table cache + remaining] + cases htail : purePeekPositionValues context.state remaining <;> + simp [purePeekPositionValues, hvalue, htail, runResolvedFromTable] + +set_option maxRecDepth 100000 in +theorem runResolvedFromTable_peekTableInput_eq_pure + (parameter : PublicParameter) (coordinate : Coordinate) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runResolvedFromTable context fuel table + ((peekTableInput parameter coordinate).run cache) = + pure (some ⟨context, fuel, + (purePeekTableInput parameter context.state coordinate, cache), table⟩) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [peekTableInput, purePeekTableInput, runResolvedFromTable] + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput.eq_2] + by_cases hzero : step.val = 0 + · rw [if_pos hzero] + rw [StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekCoordinate] + cases hvalue : context.state.values (.chainStart lay tree leafIdx chainIdx) <;> + simp [purePeekTableInput, hzero, hvalue, + runResolvedFromTable] + · rw [if_neg hzero] + rw [StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekPositionValues_eq_pure] + cases hvalues : purePeekPositionValues context.state + (Position.chain lay tree leafIdx chainIdx step).children <;> + simp [purePeekTableInput, hzero, hvalues, + runResolvedFromTable] + | leaf lay tree leafIdx => + simp only [peekTableInput] + rw [StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekPositionValues_eq_pure] + cases hvalues : purePeekPositionValues context.state _ <;> + simp [purePeekTableInput, hvalues, runResolvedFromTable] + | node lay tree level nodeIdx => + simp only [peekTableInput] + rw [StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekPositionValues_eq_pure] + cases hvalues : purePeekPositionValues context.state _ <;> + simp [purePeekTableInput, hvalues, runResolvedFromTable] + | ftsLeaf index tree leafIdx => + simp only [peekTableInput] + rw [StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekPositionValues_eq_pure] + cases hvalues : purePeekPositionValues context.state _ <;> + simp [purePeekTableInput, hvalues, runResolvedFromTable] + | ftsNode index tree level nodeIdx => + simp only [peekTableInput] + rw [StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekPositionValues_eq_pure] + cases hvalues : purePeekPositionValues context.state _ <;> + simp [purePeekTableInput, hvalues, runResolvedFromTable] + | ftsRoots index => + simp only [peekTableInput] + rw [StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekPositionValues_eq_pure] + cases hvalues : purePeekPositionValues context.state _ <;> + simp [purePeekTableInput, hvalues, runResolvedFromTable] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativePlannedReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativePlannedReserve.lean new file mode 100644 index 00000000..1f13c604 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativePlannedReserve.lean @@ -0,0 +1,120 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootInputObservation + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem probingHashQueryAfterPlan_probeFree_of_none + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (hnone : plan.candidate? = none) (cache : SplitHashCache) : + ((probingHashQueryAfterPlan parameter input plan).run cache).IsQueryBoundP LazyRevealProbe.IsProbe 0 := by + simp only [probingHashQueryAfterPlan, executePlannedHashQuery, hnone, executeCandidate?, pure_bind] + cases plan.action with + | ordinary => exact splitHashQuery_probeFree _ cache + | resolve coordinate => exact resolveKnownInput_probeFree parameter coordinate input cache + +theorem expectedResolvedProbeCharge_eq_zero_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hfree : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) : + expectedResolvedQueryCharge nativeProbeQueryCharge computation context fuel table = 0 := + le_antisymm (by simpa only [Nat.cast_zero] using + expectedResolvedProbeCharge_le_probeBound computation 0 context fuel table hfree) zero_le + +theorem probingHashQuery_expectedResolvedProbeCharge_eq_zero_of_no_candidate + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hnone : (purePlanProbingHashQuery parameter input context.state).candidate? = none) : + expectedResolvedQueryCharge nativeProbeQueryCharge ((probingHashQuery parameter input).run cache) + context fuel table = 0 := by + rw [probingHashQuery_eq_plan_then_afterPlan, StateT.run_bind, expectedResolvedQueryCharge_bind, + expectedResolvedProbeCharge_eq_zero_of_probeFree _ context fuel table + (planProbingHashQuery_probeFree parameter input cache), zero_add, + runResolved_planProbingHashQuery parameter input context.state context fuel table cache rfl, + tsum_probOutput_pure_mul] + simp only [resolvedContinuationCharge] + exact expectedResolvedProbeCharge_eq_zero_of_probeFree _ context fuel table + (probingHashQueryAfterPlan_probeFree_of_none parameter input _ hnone cache) + +noncomputable def nativePlannedProbeOuterCharge (parameter : PublicParameter) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) + (_fuel : Nat) (_cache : SplitHashCache) : ENNReal := + match input with + | .inl (.inr input) => + if (purePlanProbingHashQuery parameter input context.state).candidate? = none then 0 + else otsHashInputCharge parameter input + | _ => 0 + +noncomputable def nativeUnusedProbeOuterCharge (parameter : PublicParameter) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) + (_fuel : Nat) (_cache : SplitHashCache) : ENNReal := + match input with + | .inl (.inr input) => + if (purePlanProbingHashQuery parameter input context.state).candidate? = none then otsHashInputCharge parameter input + else 0 + | _ => 0 + +theorem nativePlanned_add_unusedProbeOuterCharge + (parameter : PublicParameter) (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + nativePlannedProbeOuterCharge parameter input context fuel cache + + nativeUnusedProbeOuterCharge parameter input context fuel cache = otsOuterQueryCharge parameter input := by + cases input with + | inl input => + cases input with + | inl n => simp [nativePlannedProbeOuterCharge, nativeUnusedProbeOuterCharge, otsOuterQueryCharge] + | inr input => + simp only [nativePlannedProbeOuterCharge, nativeUnusedProbeOuterCharge, otsOuterQueryCharge] + split_ifs <;> simp + | inr message => simp [nativePlannedProbeOuterCharge, nativeUnusedProbeOuterCharge, otsOuterQueryCharge] + +theorem chronologicalAdversaryImpl_expectedResolvedProbeCharge_le_planned + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (cache : SplitHashCache) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedResolvedQueryCharge nativeProbeQueryCharge + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) context fuel table ≤ + nativePlannedProbeOuterCharge parameter input context fuel cache := by + have hbase := chronologicalAdversaryImpl_expectedResolvedProbeCharge_le parameter root ftsSecret input cache context fuel table + cases input with + | inl query => + cases query with + | inl n => exact hbase + | inr input => + change expectedResolvedQueryCharge nativeProbeQueryCharge ((probingHashQuery parameter input).run cache) + context fuel table ≤ _ + simp only [nativePlannedProbeOuterCharge] + split_ifs with hnone + · rw [probingHashQuery_expectedResolvedProbeCharge_eq_zero_of_no_candidate parameter input context fuel table cache hnone] + · exact hbase + | inr message => exact hbase + +theorem chronologicalAdversaryImpl_probeCharge_add_unused_le_ots + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (cache : SplitHashCache) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedLiveResolvedQueryCharge nativeProbeQueryCharge + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) context fuel table + + nativeUnusedProbeOuterCharge parameter input context fuel cache ≤ otsOuterQueryCharge parameter input := by + apply (add_le_add ((expectedLiveResolvedQueryCharge_le_raw nativeProbeQueryCharge _ context fuel table).trans + (chronologicalAdversaryImpl_expectedResolvedProbeCharge_le_planned parameter root ftsSecret input cache context fuel table)) le_rfl).trans_eq + exact nativePlanned_add_unusedProbeOuterCharge parameter input context fuel cache + +theorem nativeUnusedProbeOuterCharge_replace_root + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) (parameter : PublicParameter) + (input : (OracleWorld + SigningSpec).Domain) (leftFuel rightFuel : Nat) (leftCache rightCache : SplitHashCache) : + nativeUnusedProbeOuterCharge parameter input left leftFuel leftCache = + nativeUnusedProbeOuterCharge parameter input right rightFuel rightCache := by + cases input with + | inl input => + cases input with + | inl n => rfl + | inr input => + simp only [nativeUnusedProbeOuterCharge, purePlanProbingHashQuery_eq_of_nativeRootContextRel h] + | inr message => rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativePlannedReserveComposition.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativePlannedReserveComposition.lean new file mode 100644 index 00000000..738b150e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativePlannedReserveComposition.lean @@ -0,0 +1,86 @@ +import SphincsSecurity.Proof.OtsProbeNativePlannedReserve + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem simulateQ_expectedLiveQueryCharge_add_contextCharge_le_outer + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (charge : LazyRevealProbe.Query Coordinate → ENNReal) + (extra : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (outer : (OracleWorld + SigningSpec).Domain → ENNReal) + (hstep : ∀ input cache context fuel table, + expectedLiveResolvedQueryCharge charge ((impl input).run cache) context fuel table + + extra input context fuel cache ≤ outer input) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + expectedLiveResolvedQueryCharge charge ((simulateQ impl computation).run cache) context fuel table + + expectedLiveNativeContextCharge impl extra computation context fuel table cache ≤ + expectedLiveNativeOuterCharge impl outer computation context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => simp [expectedLiveResolvedQueryCharge, expectedLiveNativeContextCharge, expectedLiveNativeOuterCharge] + | query_bind input next ih => + by_cases hcomplete : DeferredCompletable table context + · simp only [simulateQ_bind, simulateQ_spec_query, StateT.run_bind] + rw [expectedLiveResolvedQueryCharge_bind _ _ _ context fuel table hconsistent hstarts, + expectedLiveNativeContextCharge_query_bind, expectedLiveNativeOuterCharge_query_bind, + if_pos hcomplete, if_pos hcomplete, add_add_add_comm, ← ENNReal.tsum_add] + apply add_le_add (hstep input cache context fuel table) + apply ENNReal.tsum_le_tsum + intro result + rw [← mul_add] + by_cases hresult : result ∈ support (runResolvedFromTable context fuel table ((impl input).run cache)) + · cases result with + | none => simp [liveResolvedContinuationCharge] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table result hconsistent hstarts hresult + exact mul_le_mul' le_rfl (ih result.value.1 result.context result.remaining result.table result.value.2 + hcore.2.1 (hcore.1 ▸ hcore.2.2)) + · simp [probOutput_eq_zero_of_not_mem_support hresult] + · rw [expectedLiveResolvedQueryCharge_eq_zero_of_not_completable _ _ context fuel table hcomplete, + expectedLiveNativeContextCharge_eq_zero_of_not_completable _ _ _ context fuel table cache hcomplete, + expectedLiveNativeOuterCharge_eq_zero_of_not_completable _ _ _ context fuel table cache hcomplete] + simp + +theorem chronological_liveProbe_add_unused_le_liveOuterCharge + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + expectedLiveResolvedQueryCharge nativeProbeQueryCharge + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) context fuel table + + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (nativeUnusedProbeOuterCharge parameter) computation context fuel table cache ≤ + expectedLiveNativeOuterCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (otsOuterQueryCharge parameter) computation context fuel table cache := + simulateQ_expectedLiveQueryCharge_add_contextCharge_le_outer _ _ _ _ + (chronologicalAdversaryImpl_probeCharge_add_unused_le_ots parameter root ftsSecret) + computation context fuel table cache hconsistent hstarts + +theorem chronological_liveProbe_add_unused_mul_le_directCharge + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) : + (expectedLiveResolvedQueryCharge nativeProbeQueryCharge + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) context fuel table + + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (nativeUnusedProbeOuterCharge parameter) computation context fuel table cache) * (4 / 3 : ENNReal) ≤ + expectedQueryCharge (directOtsQueryCharge parameter) + (simulateQ (expandedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey)) + computation) actualCache := by + exact (mul_le_mul' + (chronological_liveProbe_add_unused_le_liveOuterCharge parameter root ftsSecret computation context fuel table cache + hinvariant.2.1.valuesConsistent hinvariant.2.2.1) le_rfl).trans + (expectedLiveChronologicalOtsCount_mul_le_directCharge parameter root table ftsSecret computation context fuel cache actualCache + hinvariant hvisible hpublished) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeQueryCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeQueryCharge.lean new file mode 100644 index 00000000..07455cfe --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeQueryCharge.lean @@ -0,0 +1,139 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueProbeCounting + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def resolvedContinuationCharge + (charge : LazyRevealProbe.Query Coordinate → ENNReal) + (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) : Option (ResolvedRunResult α) → ENNReal + | none => 0 + | some result => expectedResolvedQueryCharge charge (next result.value) result.context result.remaining result.table + +theorem expectedResolvedQueryCharge_bind + (charge : LazyRevealProbe.Query Coordinate → ENNReal) + (left : OracleComp (LazyRevealProbe.World Coordinate) α) (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedResolvedQueryCharge charge (left >>= next) context fuel table = + expectedResolvedQueryCharge charge left context fuel table + + ∑' result, Pr[= result | runResolvedFromTable context fuel table left] * resolvedContinuationCharge charge next result := by + induction left using OracleComp.inductionOn generalizing context fuel table with + | pure value => simp [expectedResolvedQueryCharge, runResolvedFromTable, resolvedContinuationCharge] + | query_bind input continuation ih => + rw [bind_assoc, expectedResolvedQueryCharge_query_bind, expectedResolvedQueryCharge_query_bind, + runResolvedFromTable_bind, tsum_probOutput_bind_mul, add_assoc, ← ENNReal.tsum_add] + congr 1 + apply tsum_congr + intro result + cases result with + | none => simp [resolvedContinuationCharge] + | some result => + dsimp only + rw [ih, mul_add, ← ENNReal.tsum_mul_left] + +theorem expectedResolvedStructuralCharge_eq_zero_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hfree : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) : + expectedResolvedQueryCharge structuralProbeQueryCharge computation context fuel table = 0 := by + have hle : expectedResolvedQueryCharge structuralProbeQueryCharge computation context fuel table ≤ (0 : ENNReal) := by + simpa only [Nat.cast_zero] using expectedResolvedStructuralCharge_le_probeBound computation 0 context fuel table hfree + exact le_antisymm hle zero_le + +theorem probingHashQuery_expectedResolvedStructuralCharge_le + (parameter : PublicParameter) (input : HashInput) (cache : SplitHashCache) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedResolvedQueryCharge structuralProbeQueryCharge ((probingHashQuery parameter input).run cache) context fuel table ≤ + otsHashInputCharge parameter input := by + unfold otsHashInputCharge + split_ifs with hots + · simpa only [Nat.cast_one] using expectedResolvedStructuralCharge_le_probeBound _ 1 context fuel table (probingHashQuery_run_isProbeBound parameter input cache) + · rw [probingHashQuery_eq_split_of_not_atOtsPosition parameter input hots, + expectedResolvedStructuralCharge_eq_zero_of_probeFree _ context fuel table (splitHashQuery_probeFree _ cache)] + +theorem maskedExpandedAdversaryImpl_expectedResolvedStructuralCharge_le + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (cache : SplitHashCache) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedResolvedQueryCharge structuralProbeQueryCharge ((maskedExpandedAdversaryImpl parameter root ftsSecret input).run cache) + context fuel table ≤ otsOuterQueryCharge parameter input := by + cases input with + | inl input => + cases input with + | inl n => + change expectedResolvedQueryCharge structuralProbeQueryCharge ((splitUniformImpl n).run cache) context fuel table ≤ 0 + rw [expectedResolvedStructuralCharge_eq_zero_of_probeFree _ context fuel table (splitUniformImpl_probeFree n cache)] + | inr input => exact probingHashQuery_expectedResolvedStructuralCharge_le parameter input cache context fuel table + | inr message => + change expectedResolvedQueryCharge structuralProbeQueryCharge ((maskedSign parameter root ftsSecret message).run cache) context fuel table ≤ 0 + rw [expectedResolvedStructuralCharge_eq_zero_of_probeFree _ context fuel table (maskedSign_probeFree parameter root ftsSecret message cache)] + + +noncomputable def expectedNativeOuterQueryCharge + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (charge : (OracleWorld + SigningSpec).Domain → ENNReal) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → ENNReal := + OracleComp.construct (fun _ _ _ _ _ => 0) + (fun input _ next context fuel table cache => + charge input + ∑' result, + Pr[= result | runResolvedFromTable context fuel table ((maskedExpandedAdversaryImpl parameter root ftsSecret input).run cache)] * + match result with + | none => 0 + | some result => next result.value.1 result.context result.remaining result.table result.value.2) computation + +theorem expectedNativeOuterQueryCharge_query_bind + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (charge : (OracleWorld + SigningSpec).Domain → ENNReal) (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + expectedNativeOuterQueryCharge parameter root ftsSecret charge (OracleSpec.query input >>= next) context fuel table cache = + charge input + ∑' result, + Pr[= result | runResolvedFromTable context fuel table ((maskedExpandedAdversaryImpl parameter root ftsSecret input).run cache)] * + match result with + | none => 0 + | some result => expectedNativeOuterQueryCharge parameter root ftsSecret charge (next result.value.1) + result.context result.remaining result.table result.value.2 := rfl + +theorem simulateQ_maskedExpanded_expectedResolvedStructuralCharge_le + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + expectedResolvedQueryCharge structuralProbeQueryCharge + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) context fuel table ≤ + expectedNativeOuterQueryCharge parameter root ftsSecret (otsOuterQueryCharge parameter) computation context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => simp [expectedResolvedQueryCharge, expectedNativeOuterQueryCharge] + | query_bind input next ih => + rw [simulateQ_query_bind, StateT.run_bind, expectedResolvedQueryCharge_bind, expectedNativeOuterQueryCharge_query_bind] + apply add_le_add (maskedExpandedAdversaryImpl_expectedResolvedStructuralCharge_le parameter root ftsSecret input cache context fuel table) + apply ENNReal.tsum_le_tsum + intro result + cases result with + | none => rfl + | some result => exact mul_le_mul' le_rfl (ih result.value.1 result.context result.remaining result.table result.value.2) + +theorem sum_targets_privateResolvedRawCandidate_hit_le_nativeOtsQueryCharge + (targets : Finset Position) (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : ∀ target ∈ targets, .position target ∈ context.state.ensured) + (hstate : ∀ target ∈ targets, context.state.values (.position target) = none) + (hvalue : ∀ target ∈ targets, context.values target = none) + (hhidden : ∀ target ∈ targets, .position target ∉ context.state.revealed) + (hcard : ∀ target ∈ targets, (context.state.pendingAt (.position target)).card + q ≤ 2 ^ 126) : + (∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) ordinal)]) ≤ + expectedNativeOuterQueryCharge parameter root ftsSecret (otsOuterQueryCharge parameter) computation context fuel table cache * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply (sum_targets_privateResolvedRawCandidate_hit_le_expectedStructuralCharge targets _ q context fuel table + hvalid hcomplete hensured hstate hvalue hhidden hcard).trans + exact mul_le_mul' (simulateQ_maskedExpanded_expectedResolvedStructuralCharge_le parameter root ftsSecret computation context fuel table cache) le_rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeQueryTrace.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeQueryTrace.lean new file mode 100644 index 00000000..eca12b38 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeQueryTrace.lean @@ -0,0 +1,60 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootReserve +import SphincsSecurity.Proof.OtsProbeKnownRootTraceSource + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open _root_.OracleComp.DeferredSampling + +attribute [local instance] Classical.propDecidable + +noncomputable def runNativeQueryTrace + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp (Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) := + OracleComp.construct + (fun value context fuel table cache => + if DeferredCompletable table context then pure (some ⟨context, fuel, (value, cache), table⟩, []) + else pure (none, [])) + (fun input _ next context fuel table cache => + if DeferredCompletable table context then do + let result ← runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) + let tail ← match result with + | none => pure (none, []) + | some result => next result.value.1 result.context result.remaining result.table result.value.2 + pure (tail.1, (⟨input, context, fuel, table, cache⟩ : CanonicalQuerySelection) :: tail.2) + else pure (none, [])) computation + +theorem runNativeQueryTrace_query_bind + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runNativeQueryTrace parameter root ftsSecret (OracleSpec.query input >>= next) context fuel table cache = + if DeferredCompletable table context then do + let result ← runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) + let tail ← match result with + | none => pure (none, []) + | some result => + runNativeQueryTrace parameter root ftsSecret (next result.value.1) + result.context result.remaining result.table result.value.2 + pure (tail.1, (⟨input, context, fuel, table, cache⟩ : CanonicalQuerySelection) :: tail.2) + else pure (none, []) := rfl + +theorem runNativeQueryTrace_of_not_completable + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hnot : ¬DeferredCompletable table context) : + runNativeQueryTrace parameter root ftsSecret computation context fuel table cache = pure (none, []) := by + induction computation using OracleComp.inductionOn with + | pure value => simp only [runNativeQueryTrace, OracleComp.construct_pure, hnot, ↓reduceIte] + | query_bind input next _ => rw [runNativeQueryTrace_query_bind, if_neg hnot] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeQueryTraceCoupling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeQueryTraceCoupling.lean new file mode 100644 index 00000000..03c2082d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeQueryTraceCoupling.lean @@ -0,0 +1,85 @@ +import SphincsSecurity.Proof.OtsProbeNativeQueryTrace + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +theorem relTriple_nativeChronologicalQuery_prehit + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (accountingKey : SecretKey) + (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (state : ViewedFullTraceState × Bool) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) state.1.cache) + (hvisible : VisibleResolvedComputationsCached parameter table context state.1.cache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + RelTriple (runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache)) + ((encodingPrehitViewedAdversaryImpl accountingKey secretKey input).run state) + (fun left right => ReachableResolvedRunRel parameter table left (right.1, right.2.1.cache) ∧ + ∀ result, left = some result → DeferredComputationsClosed result.context) := by + have h := relTriple_nativeChronological_computed_prehit parameter root table ftsSecret accountingKey + ((OracleWorld + SigningSpec).query input) context fuel cache state hinvariant hvisible hpublished hcomputed + simpa only [simulateQ_spec_query] using + relTriple_post_mono h (fun _ _ hrel => ⟨hrel.1, hrel.2.1⟩) + +set_option maxRecDepth 100000 in +theorem relTriple_nativeQueryTrace_prehitQueryTrace + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (accountingKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (state : ViewedFullTraceState × Bool) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) state.1.cache) + (hvisible : VisibleResolvedComputationsCached parameter table context state.1.cache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + RelTriple (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache) + (runPrehitQueryTrace accountingKey secretKey computation state) (CanonicalQueryTraceRel parameter table) := by + dsimp only + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + induction computation using OracleComp.inductionOn generalizing context fuel cache state with + | pure value => + rw [runNativeQueryTrace, OracleComp.construct_pure, if_pos hinvariant.2.2.2.1] + exact relTriple_pure_pure ⟨⟨rfl, rfl, hinvariant, hvisible, hpublished, hcomputed⟩, List.Forall₂.nil⟩ + | query_bind input next ih => + rw [runNativeQueryTrace_query_bind, if_pos hinvariant.2.2.2.1, runPrehitQueryTrace_query_bind] + apply relTriple_bind (relTriple_nativeChronologicalQuery_prehit parameter root table ftsSecret accountingKey + input context fuel cache state hinvariant hvisible hpublished hcomputed) + intro left right hrelation + have htail : RelTriple + (match left with + | none => pure (none, []) + | some result => runNativeQueryTrace parameter root ftsSecret (next result.value.1) + result.context result.remaining result.table result.value.2) + (runPrehitQueryTrace accountingKey secretKey (next right.1) right.2) + (CanonicalQueryTraceRel parameter table) := by + cases left with + | none => exact relTriple_empty_canonicalTrace_any parameter table _ + | some result => + dsimp only + rcases hrelation.1 with hclean | hdoomed + · rw [hclean.1, ← hclean.2.1] + exact ih result.value.1 result.context result.remaining result.value.2 right.2 + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 (hrelation.2 result rfl) + · rw [runNativeQueryTrace_of_not_completable parameter root ftsSecret + (next result.value.1) result.context result.remaining result.table result.value.2 (by + rw [hdoomed.1] + exact hdoomed.2.2.2)] + exact relTriple_empty_canonicalTrace_any parameter table _ + have hmap := relTriple_map + (f := fun tail : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection => + (tail.1, (⟨input, context, fuel, table, cache⟩ : CanonicalQuerySelection) :: tail.2)) + (g := fun tail : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot => + (tail.1, (⟨input, state⟩ : PrehitQuerySnapshot) :: tail.2)) + (relTriple_post_mono htail (fun leftTail rightTail htailRelation => + htailRelation.prepend ⟨input, context, fuel, table, cache⟩ ⟨input, state⟩ + ⟨rfl, rfl, hinvariant, hvisible, hpublished, hcomputed⟩)) + cases left <;> simpa only [map_eq_bind_pure_comp, Function.comp_def] using hmap + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeQueryTraceProjection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeQueryTraceProjection.lean new file mode 100644 index 00000000..d0d31fd4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeQueryTraceProjection.lean @@ -0,0 +1,80 @@ +import SphincsSecurity.Proof.OtsProbeNativeQueryTraceSelection +import SphincsSecurity.Proof.OtsProbeHistoryCandidateSampling + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem evalDist_retainCompletableResult_eq_none_of_not_completable + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) : + evalDist (retainCompletableResult <$> runResolvedFromTable context fuel table computation) = + evalDist (pure none : ProbComp (Option (ResolvedRunResult α))) := by + rw [map_eq_bind_pure_comp] + exact evalDist_runResolved_observe_of_not_completable context fuel table computation (pure none) + (fun result => pure (retainCompletableResult result)) rfl + (fun result _ _ hnot => by simp [retainCompletableResult, hnot]) hconsistent hstarts hdoomed + +theorem runNativeQueryTrace_result_projection + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + evalDist (Prod.fst <$> runNativeQueryTrace parameter root ftsSecret computation context fuel table cache) = + evalDist (retainCompletableResult <$> runResolvedFromTable context fuel table + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache)) := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => + simp only [runNativeQueryTrace, OracleComp.construct_pure, simulateQ_pure, StateT.run_pure, + runResolvedFromTable] + split_ifs with hcomplete <;> simp [retainCompletableResult, hcomplete] + | query_bind input next ih => + by_cases hcomplete : DeferredCompletable table context + · rw [runNativeQueryTrace_query_bind, if_pos hcomplete] + simp only [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, + runResolvedFromTable_bind, map_bind] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => simp [retainCompletableResult] + | some result => + simp only + have hcore := resolvedCore_of_mem_runResolvedFromTable + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) + context fuel table result hconsistent hstarts hresult + simpa only [map_eq_bind_pure_comp, Function.comp_def, bind_assoc, pure_bind] using + ih result.value.1 result.context result.remaining result.table result.value.2 + hcore.2.1 (by rw [hcore.1]; exact hcore.2.2) + · rw [runNativeQueryTrace_of_not_completable parameter root ftsSecret _ context fuel table cache hcomplete] + simp only [map_pure] + exact (evalDist_retainCompletableResult_eq_none_of_not_completable context fuel table _ + hconsistent hstarts hcomplete).symm + +theorem expectedNativeTraceCharge_eq + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + (∑' result, Pr[= result | runNativeQueryTrace parameter root ftsSecret computation context fuel table cache] * + canonicalTraceCharge charge result.2) = + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + charge computation context fuel table cache := by + simp_rw [canonicalTraceCharge_eq_tsum_selection, ← ENNReal.tsum_mul_left] + rw [ENNReal.tsum_comm, ← tsum_liveNativeQuerySelection_charge] + apply tsum_congr + intro ordinal + calc + _ = ∑' selection, Pr[= selection | (fun result => result.2[ordinal]?) <$> + runNativeQueryTrace parameter root ftsSecret computation context fuel table cache] * + CanonicalQuerySelection.charge charge selection := (tsum_probOutput_map_mul _ _ _).symm + _ = _ := tsum_congr fun selection => congrArg (· * CanonicalQuerySelection.charge charge selection) + (_root_.OracleComp.probOutput_congr rfl (runNativeQueryTrace_selection_projection + parameter root ftsSecret computation context fuel table cache ordinal)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeQueryTraceSelection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeQueryTraceSelection.lean new file mode 100644 index 00000000..c734e13e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeQueryTraceSelection.lean @@ -0,0 +1,116 @@ +import SphincsSecurity.Proof.OtsProbeNativeQueryTrace +import SphincsSecurity.Proof.OtsProbeLiveHashSelection + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open _root_.OracleComp.DeferredSampling + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +set_option maxRecDepth 100000 in +theorem runNativeQueryTrace_selection_projection + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (ordinal : Nat) : + evalDist ((fun result => result.2[ordinal]?) <$> + runNativeQueryTrace parameter root ftsSecret computation context fuel table cache) = + evalDist (liveNativeQuerySelection (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation ordinal context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache ordinal with + | pure value => + simp only [runNativeQueryTrace, OracleComp.construct_pure, liveNativeQuerySelection_pure] + split_ifs <;> simp + | query_bind input next ih => + rw [runNativeQueryTrace_query_bind, liveNativeQuerySelection_query_bind] + by_cases hcomplete : DeferredCompletable table context + · simp only [hcomplete, ↓reduceIte, map_bind] + cases ordinal with + | zero => + calc + _ = evalDist (runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) >>= fun _ => + pure (some (⟨input, context, fuel, table, cache⟩ : CanonicalQuerySelection))) := by + apply evalDist_bind_congr_left + intro result + cases result with + | none => simp + | some result => + simp only [map_bind, map_pure, List.getElem?_cons_zero] + exact evalDist_bind_const_neverFails _ (by simp) _ + _ = _ := evalDist_bind_const_neverFails _ (by simp) _ + | succ ordinal => + apply evalDist_bind_congr_left + intro result + cases result with + | none => simp + | some result => + simp only [map_bind, map_pure, List.getElem?_cons_succ] + simpa only [map_eq_bind_pure_comp, Function.comp_def] using + ih result.value.1 result.context result.remaining result.table result.value.2 ordinal + · simp [hcomplete] + +noncomputable def nativeHashQueryHistory (history : List CanonicalQuerySelection) : List CanonicalQuerySelection := + history.filter fun selection => IsOuterHash selection.input + +theorem runNativeQueryTrace_hashSelection_projection + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (ordinal : Nat) : + evalDist ((fun result => (nativeHashQueryHistory result.2)[ordinal]?) <$> + runNativeQueryTrace parameter root ftsSecret computation context fuel table cache) = + evalDist (liveNativeHashQuerySelection (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + computation ordinal context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache ordinal with + | pure value => + simp only [runNativeQueryTrace, OracleComp.construct_pure, liveNativeHashQuerySelection_pure] + split_ifs <;> simp [nativeHashQueryHistory] + | query_bind input next ih => + rw [runNativeQueryTrace_query_bind, liveNativeHashQuerySelection_query_bind] + by_cases hcomplete : DeferredCompletable table context + · simp only [hcomplete, ↓reduceIte, map_bind] + by_cases hhash : IsOuterHash input + · cases ordinal with + | zero => + simp only [hhash, and_self, ↓reduceIte] + calc + _ = evalDist (runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) >>= fun _ => + pure (some (⟨input, context, fuel, table, cache⟩ : CanonicalQuerySelection))) := by + apply evalDist_bind_congr_left + intro result + cases result with + | none => simp [nativeHashQueryHistory, hhash] + | some result => + simp only [map_bind, map_pure, nativeHashQueryHistory, List.filter_cons, + hhash, decide_true, Bool.true_eq, ↓reduceIte, List.getElem?_cons_zero] + exact evalDist_bind_const_neverFails _ (by simp) _ + _ = _ := evalDist_bind_const_neverFails _ (by simp [runResolvedFromTable]) _ + | succ ordinal => + simp only [hhash, Nat.add_eq_zero_iff, Nat.one_ne_zero, and_false, ↓reduceIte, + Nat.add_sub_cancel] + apply evalDist_bind_congr_left + intro result + cases result with + | none => simp [nativeHashQueryHistory, hhash] + | some result => + simp only [map_bind, map_pure, nativeHashQueryHistory, List.filter_cons, + hhash, decide_true, Bool.true_eq, ↓reduceIte, List.getElem?_cons_succ] + simpa only [nativeHashQueryHistory, map_eq_bind_pure_comp, Function.comp_def] using + ih result.value.1 result.context result.remaining result.table result.value.2 ordinal + · simp only [hhash, false_and, ↓reduceIte] + apply evalDist_bind_congr_left + intro result + cases result with + | none => simp [nativeHashQueryHistory, hhash] + | some result => + simp only [map_bind, map_pure, nativeHashQueryHistory, List.filter_cons, + hhash, decide_false, Bool.false_eq_true, ↓reduceIte] + simpa only [nativeHashQueryHistory, map_eq_bind_pure_comp, Function.comp_def] using + ih result.value.1 result.context result.remaining result.table result.value.2 ordinal + · simp [hcomplete, nativeHashQueryHistory] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeQueryTraceSource.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeQueryTraceSource.lean new file mode 100644 index 00000000..ed0e974e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeQueryTraceSource.lean @@ -0,0 +1,28 @@ +import SphincsSecurity.Proof.OtsProbeNativeQueryTraceCoupling + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +theorem probEvent_nativeUnknownSourceRootMatch_le_prehit + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (state : ViewedFullTraceState × Bool) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) state.1.cache) + (hvisible : VisibleResolvedComputationsCached parameter table context state.1.cache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + Pr[fun result => UnknownSourceStoredRootMatch parameter result.2 ∨ UnknownSourceFinalRootMatch parameter result | + runNativeQueryTrace parameter root ftsSecret computation context fuel table cache] ≤ + Pr[fun result => result.2.2 = true | + (simulateQ (encodingPrehitViewedAdversaryImpl secretKey secretKey) computation).run state] := by + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + dsimp only + exact probEvent_unknownSourceRootMatch_le_prehit_of_trace_coupling secretKey secretKey table _ computation state rfl + (relTriple_nativeQueryTrace_prehitQueryTrace parameter root table ftsSecret secretKey computation context fuel cache state + hinvariant hvisible hpublished hcomputed) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRateBound.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRateBound.lean new file mode 100644 index 00000000..5e7068f2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRateBound.lean @@ -0,0 +1,42 @@ +import SphincsSecurity.Proof.OtsProbeInitializedRate +import SphincsSecurity.Proof.OtsProbeNativeDirectBound + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local irreducible] instFintypePosition +set_option backward.isDefEq.respectTransparency false + +theorem sampled_actualOtsCount_rate_le_directCharge + (adversary : Adversary) (q : Nat) (hqMax : q ≤ 2 ^ 126) : + sampledQueryCharge (fun secretKey _ input => otsHashInputCharge secretKey.parameter input) adversary * + privateHistoryGuessRate q ≤ + sampledQueryCharge (fun secretKey => directOtsQueryCharge secretKey.parameter) adversary * + (Fintype.card Digest : ENNReal)⁻¹ := by + apply (mul_le_mul' le_rfl (privateHistoryGuessRate_le_four_thirds hqMax)).trans_eq + unfold sampledQueryCharge directOtsQueryCharge + simp_rw [expectedQueryCharge_mul, ← mul_assoc, ENNReal.tsum_mul_right] + simp only [show Fintype.card Digest = 2 ^ digestBits by simp, mul_assoc] + +theorem sampledNativeTerminalRisk_le_actualOtsCount_rate_add_erasure + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + sampledNativeTerminalRisk adversary (q + 1) ≤ + sampledQueryCharge (fun secretKey _ input => otsHashInputCharge secretKey.parameter input) adversary * + privateHistoryGuessRate q + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + apply (sampledNativeTerminalRisk_le_missing_add_erasure adversary q hq hqMax).trans + apply add_le_add _ le_rfl + exact (sampledNativeMissingAllowances_le_directRisk Finset.univ adversary q hq (q + 1)).trans + (sampledInitializedNativeDirectRisk_le_actualOtsCount_rate Finset.univ adversary (q + 1) q + (hqMax.trans_lt (by norm_num [digestBits]))) + +theorem probEvent_sampled_prehitFree_residual_le_actualOtsCount_rate_add_erasure + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + Pr[prehitFreeResidualOtsOpeningEvent | sampledEncodingPrehitViewedGame adversary] ≤ + sampledQueryCharge (fun secretKey _ input => otsHashInputCharge secretKey.parameter input) adversary * + privateHistoryGuessRate q + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + apply (probEvent_sampled_prehitFree_residual_le_nativeTerminalFailure adversary (q + 1)).trans + rw [probEvent_sampledNativeTerminalFailure_eq_risk] + exact sampledNativeTerminalRisk_le_actualOtsCount_rate_add_erasure adversary q hq hqMax + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRejectionProbability.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRejectionProbability.lean new file mode 100644 index 00000000..d5c8a662 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRejectionProbability.lean @@ -0,0 +1,113 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootHitProjection + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def nativeQueryRejectionRisk + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (entry : CanonicalQuerySelection) : ℝ≥0∞ := + Pr[ResolvedQueryRejected | runResolvedFromTable entry.context entry.fuel entry.table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret entry.input).run entry.cache)] + +noncomputable def nativeTraceRejectionRisk + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (history : List CanonicalQuerySelection) : ℝ≥0∞ := + (history.map (nativeQueryRejectionRisk parameter root ftsSecret)).sum + +private theorem expected_const_add (computation : ProbComp α) (constant : ℝ≥0∞) (cost : α → ℝ≥0∞) : + (∑' result, Pr[= result | computation] * (constant + cost result)) = + constant + ∑' result, Pr[= result | computation] * cost result := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_mul_right, tsum_probOutput_eq_one' (by simp), one_mul] + +theorem expectedNativeTraceRejectionRisk_query_bind + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcomplete : DeferredCompletable table context) : + (∑' result, Pr[= result | runNativeQueryTrace parameter root ftsSecret + (OracleSpec.query input >>= next) context fuel table cache] * + nativeTraceRejectionRisk parameter root ftsSecret result.2) = + nativeQueryRejectionRisk parameter root ftsSecret ⟨input, context, fuel, table, cache⟩ + + ∑' step, Pr[= step | runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache)] * + match step with + | none => 0 + | some step => ∑' tail, Pr[= tail | runNativeQueryTrace parameter root ftsSecret + (next step.value.1) step.context step.remaining step.table step.value.2] * + nativeTraceRejectionRisk parameter root ftsSecret tail.2 := by + rw [runNativeQueryTrace_query_bind, if_pos hcomplete, tsum_probOutput_bind_mul] + rw [← expected_const_add] + apply tsum_congr + intro step + congr 1 + cases step with + | none => simp [nativeTraceRejectionRisk] + | some step => + simp only [tsum_probOutput_bind_mul, tsum_probOutput_pure_mul, + nativeTraceRejectionRisk, List.map_cons, List.sum_cons] + exact expected_const_add _ _ _ + +theorem probEvent_nativeTrace_none_query_bind + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcomplete : DeferredCompletable table context) : + Pr[fun result => result.1 = none | runNativeQueryTrace parameter root ftsSecret + (OracleSpec.query input >>= next) context fuel table cache] = + ∑' step, Pr[= step | runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache)] * + match step with + | none => 1 + | some step => Pr[fun result => result.1 = none | runNativeQueryTrace parameter root ftsSecret + (next step.value.1) step.context step.remaining step.table step.value.2] := by + rw [runNativeQueryTrace_query_bind, if_pos hcomplete, probEvent_bind_eq_tsum] + apply tsum_congr + intro step + congr 1 + cases step with + | none => simp + | some step => + simpa only [Function.comp_def] using probEvent_bind_pure_comp + (mx := runNativeQueryTrace parameter root ftsSecret (next step.value.1) + step.context step.remaining step.table step.value.2) + (f := fun result => (result.1, (⟨input, context, fuel, table, cache⟩ : CanonicalQuerySelection) :: result.2)) + (fun result => result.1 = none) + +set_option maxRecDepth 100000 in +theorem probEvent_nativeTrace_none_eq_expected_rejectionRisk + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcomplete : DeferredCompletable table context) : + Pr[fun result => result.1 = none | runNativeQueryTrace parameter root ftsSecret computation context fuel table cache] = + ∑' result, Pr[= result | runNativeQueryTrace parameter root ftsSecret computation context fuel table cache] * + nativeTraceRejectionRisk parameter root ftsSecret result.2 := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => simp [runNativeQueryTrace, hcomplete, nativeTraceRejectionRisk] + | query_bind input next ih => + rw [probEvent_nativeTrace_none_query_bind parameter root ftsSecret input next context fuel table cache hcomplete, + expectedNativeTraceRejectionRisk_query_bind parameter root ftsSecret input next context fuel table cache hcomplete, + nativeQueryRejectionRisk, probEvent_eq_tsum_ite, ← ENNReal.tsum_add] + apply tsum_congr + intro step + cases step with + | none => simp [ResolvedQueryRejected] + | some step => + dsimp only + by_cases hnext : DeferredCompletable step.table step.context + · simp only [ResolvedQueryRejected, hnext, not_true_eq_false, ↓reduceIte, zero_add] + rw [ih step.value.1 step.context step.remaining step.table step.value.2 hnext] + · rw [runNativeQueryTrace_of_not_completable parameter root ftsSecret _ + step.context step.remaining step.table step.value.2 hnext] + simp [ResolvedQueryRejected, hnext, nativeTraceRejectionRisk] + +attribute [local irreducible] maskedPublishedTreeRoot + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeResolvedRootCutRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeResolvedRootCutRisk.lean new file mode 100644 index 00000000..d8a00151 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeResolvedRootCutRisk.lean @@ -0,0 +1,86 @@ +import SphincsSecurity.Proof.OtsProbeNativeStoredRootCutRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def clearNativeRootPending (target : Position) (context : DeferredContext) : DeferredContext := + { context with state := context.state.clearPending (.position target) } + +theorem replaceNativePosition_clearPending_eq_completePrivatePosition + (target : Position) (output : HashOutput) (context : DeferredContext) + (hstate : context.state.values (.position target) = none) : + replaceNativePosition target output (clearNativeRootPending target context) = + (completePrivatePosition target context output).toDeferredContext := by + rw [replaceNativePosition_of_private target output (clearNativeRootPending target context) hstate] + rfl + +noncomputable def runResolvedNativeRootCut + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (ordinal : Nat) : ProbComp (HashOutput × Option Digest) := do + let resolved ← resolveDeferredPositionValue target context + match resolved with + | none => pure (0, none) + | some resolved => + if truncateHash resolved.output ∈ initialHistory then pure (resolved.output, none) else + let trace ← runNativeQueryTrace parameter root ftsSecret (outerHashQueryCutAt computation ordinal) + resolved.toDeferredContext fuel table cache + pure (resolved.output, if NativeRootTraceCompatible parameter target resolved.output resolved.output trace then + nativeRootTraceCutCandidate parameter target trace.1 else none) + +theorem probEvent_runResolvedNativeRootCut_eq_sampled + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (ordinal : Nat) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hpending : context.state.pendingAt (.position target) ⊆ initialHistory) + (event : HashOutput × Option Digest → Prop) (hnone : ∀ output, ¬event (output, none)) : + Pr[event | runResolvedNativeRootCut parameter root target ftsSecret computation context fuel table cache initialHistory ordinal] = + Pr[event | sampleNativeStoredRootCut parameter root target ftsSecret computation + (clearNativeRootPending target context) fuel table cache initialHistory ordinal] := by + simp only [runResolvedNativeRootCut, resolveDeferredPositionValue, hstate, hvalue, bind_assoc, sampleNativeStoredRootCut] + rw [probEvent_bind_eq_tsum, probEvent_bind_eq_tsum] + apply tsum_congr + intro output + congr 1 + by_cases hhit : context.state.hitAt (.position target) output + · have hinitial := hpending hhit + simp [hhit, hinitial, probEvent_pure, hnone] + · simp only [hhit, ↓reduceIte, pure_bind] + by_cases hinitial : truncateHash output ∈ initialHistory + · simp [hinitial] + · simp only [hinitial, ↓reduceIte] + rw [replaceNativePosition_clearPending_eq_completePrivatePosition target output context hstate] + rfl + +theorem probEvent_runResolvedNativeRootCut_hit_le_occurrence + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (hconsistent : context.ValuesConsistent) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hpending : context.state.pendingAt (.position target) ⊆ initialHistory) + (hcache : ∀ digest, digest ∉ initialHistory → NoEncodingRootGuessCached parameter target digest cache) + (ordinal : Nat) (hbudget : initialHistory.card + ordinal ≤ 2 ^ 126) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | + runResolvedNativeRootCut parameter root target ftsSecret computation context fuel table cache initialHistory ordinal] ≤ + Pr[fun pair => pair.2 ≠ none | + runResolvedNativeRootCut parameter root target ftsSecret computation context fuel table cache initialHistory ordinal] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + rw [probEvent_runResolvedNativeRootCut_eq_sampled parameter root target ftsSecret computation context fuel table cache initialHistory ordinal + hstate hvalue hpending _ (by simp), + probEvent_runResolvedNativeRootCut_eq_sampled parameter root target ftsSecret computation context fuel table cache initialHistory ordinal + hstate hvalue hpending _ (by simp)] + apply probEvent_sampleNativeStoredRootCut_hit_le_occurrence parameter root target hroot ftsSecret computation + (clearNativeRootPending target context) fuel table cache initialHistory hconsistent _ hcache ordinal hbudget + intro digest hmem + exact False.elim (not_hitAt_clearPending_self context.state (.position target) (hashOutputOfDigest digest) + (by simpa only [clearNativeRootPending, LazyRevealProbe.State.hitAt, truncateHash_hashOutputOfDigest] using hmem)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRetainedProjection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRetainedProjection.lean new file mode 100644 index 00000000..4a4df205 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRetainedProjection.lean @@ -0,0 +1,139 @@ +import SphincsSecurity.Proof.OtsProbeNativeTerminalExperiment +import SphincsSecurity.Proof.OtsProbeChronologicalProbability +import SphincsSecurity.Proof.OtsProbeEnsuredExecution + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot instFintypePosition +set_option backward.isDefEq.respectTransparency false + +theorem simulateQ_chronological_retainedGameRestComputation + (adversary : Adversary) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (retainedGameRestComputation adversary ⟨root, parameter⟩) = (do + let (forgery, log) ← simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) + let verified ← simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature) + pure ((forgery, log), verified)) := by + unfold retainedGameRestComputation + rw [simulateQ_bind] + apply bind_congr + intro result + rcases result with ⟨forgery, log⟩ + rw [simulateQ_bind] + change (simulateQ (probingRomImpl parameter + maskedChronologicalSigningImpl parameter root ftsSecret) + (liftOracleWorldLeft _) >>= _) = _ + rw [simulateQ_liftOracleWorldLeft] + simp + +theorem nativeChronologicalRetainedComputation_eq_chronological_projection + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + nativeChronologicalRetainedComputation adversary parameter ftsSecret = + (fun result => (result.1.2, result.2)) <$> + (maskedChronologicalRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run emptySplitHashCache := by + simp only [nativeChronologicalRetainedComputation, simulateQ_chronological_retainedGameRestComputation, + maskedChronologicalRetainedGameAfterFtsSecrets, maskedChronologicalRetainedPrefixAfterFtsSecrets, + StateT.run_bind, StateT.run_pure, bind_assoc, pure_bind, map_bind, map_pure] + +theorem finishResolvedRunIsNone_retainCompletableResult + (result : Option (ResolvedRunResult α)) : + finishResolvedRunIsNone (retainCompletableResult result) = finishResolvedRunIsNone result := by + cases result with + | none => rfl + | some result => + by_cases hcomplete : DeferredCompletable result.table result.context + · simp [retainCompletableResult, hcomplete] + · rw [show retainCompletableResult (some result) = none from if_neg hcomplete] + simp [finishResolvedRunIsNone, finishResolvedRun, hcomplete] + +theorem evalDist_nativeQueryTrace_finish_eq_raw + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + evalDist (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache >>= + fun trace => finishResolvedRunIsNone trace.1) = + evalDist (runResolvedFromTable context fuel table + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) >>= + finishResolvedRunIsNone) := by + have hprojection := runNativeQueryTrace_result_projection parameter root ftsSecret computation + context fuel table cache hconsistent hstarts + calc + _ = evalDist ((Prod.fst <$> runNativeQueryTrace parameter root ftsSecret computation context fuel table cache) >>= + finishResolvedRunIsNone) := by simp only [bind_map_left] + _ = evalDist ((retainCompletableResult <$> runResolvedFromTable context fuel table + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache)) >>= + finishResolvedRunIsNone) := by rw [evalDist_bind, hprojection, ← evalDist_bind] + _ = _ := by simp only [bind_map_left, finishResolvedRunIsNone_retainCompletableResult] + +theorem evalDist_nativeTerminalFailureAfterRoot_eq_raw + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (nativeTerminalFailureAfterRoot targets adversary parameter table ftsSecret fuel) = + evalDist (runResolvedFromTable (ensuredInitialContext targets) fuel table + (nativeChronologicalRetainedComputation adversary parameter ftsSecret) >>= finishResolvedRunIsNone) := by + simp only [nativeTerminalFailureAfterRoot, nativeChainTraceAfterRoot, + nativeChronologicalRetainedComputation, runResolvedFromTable_bind, bind_assoc] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => simp + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ _ fuel table result + (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table)) hresult + exact evalDist_nativeQueryTrace_finish_eq_raw parameter result.value.1 ftsSecret _ + result.context result.remaining result.table result.value.2 hcore.2.1 (by rw [hcore.1]; exact hcore.2.2) + +theorem runResolved_finish_map_value + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (project : α → β) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + (runResolvedFromTable context fuel table (project <$> computation) >>= finishResolvedRunIsNone) = + (runResolvedFromTable context fuel table computation >>= finishResolvedRunIsNone) := by + rw [map_eq_bind_pure_comp, runResolvedFromTable_bind, bind_assoc] + apply bind_congr + intro result + cases result with + | none => simp [finishResolvedRunIsNone, finishResolvedRun] + | some result => + simpa only [Function.comp_def, runResolvedFromTable, OracleComp.construct_pure, pure_bind] using + finishResolvedRunIsNone_value_eq result.context result.remaining result.table (project result.value) result.value + +theorem evalDist_nativeTerminalFailureAfterRoot_eq_chronological + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (nativeTerminalFailureAfterRoot targets adversary parameter table ftsSecret fuel) = + evalDist (runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table ((maskedChronologicalRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run emptySplitHashCache) >>= + finishResolvedRunIsNone) := by + rw [evalDist_nativeTerminalFailureAfterRoot_eq_raw, + nativeChronologicalRetainedComputation_eq_chronological_projection, runResolved_finish_map_value] + have hinitial : ensuredInitialContext targets = + ({ state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } : DeferredContext).enlargeEnsured + (targets.image Coordinate.position) := by + simp [ensuredInitialContext, DeferredContext.enlargeEnsured, LazyRevealProbe.State.empty] + rw [hinitial] + exact evalDist_runResolved_finish_enlargeEnsured _ _ fuel table _ DeferredContext.valid_empty.valuesConsistent + (startTableAgrees_empty table) + +theorem probEvent_winningRetainedVerifyProbe_le_nativeTerminalFailure + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table)] ≤ + Pr[fun verdict => verdict = true | nativeTerminalFailureAfterRoot targets adversary parameter table ftsSecret fuel] := by + have hfailure := probEvent_winningRetainedVerifyProbe_le_finishedResolvedRun_none adversary parameter table ftsSecret fuel + have heq := evalDist_nativeTerminalFailureAfterRoot_eq_chronological targets adversary parameter table ftsSecret fuel + rw [_root_.OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) heq] + unfold finishResolvedRunIsNone + rw [← map_bind, probEvent_map] + simpa only [Function.comp_def, Option.isNone_iff_eq_none] using hfailure + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRiskAccumulation.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRiskAccumulation.lean new file mode 100644 index 00000000..923f4d6c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRiskAccumulation.lean @@ -0,0 +1,130 @@ +import SphincsSecurity.Proof.OtsProbeNativeRejectionProbability + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem probEvent_nativeQuery_finished_le_guessCharge + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + Pr[fun verdict => verdict = true | runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) >>= finishResolvedRunIsNone] ≤ + resolvedContextFailureRisk table context + canonicalGuessCharge parameter table input context fuel cache := by + have hdist := evalDist_canonicalQuery_finished_eq_raw parameter root table ftsSecret input context fuel cache hconsistent hstarts + have heq := probEvent_congr' (fun _ _ => Iff.rfl) hdist (p := fun verdict => verdict = true) + exact heq ▸ probEvent_canonicalQuery_finished_le_guessCharge parameter root table ftsSecret input context fuel cache hconsistent hstarts + +noncomputable def expectedNativeTerminalRisk + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : ℝ≥0∞ := + ∑' result, Pr[= result | runNativeQueryTrace parameter root ftsSecret computation context fuel table cache] * + resolvedOutcomeFailureRisk result.1 + +theorem expectedNativeTerminalRisk_query_bind + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcomplete : DeferredCompletable table context) : + expectedNativeTerminalRisk parameter root ftsSecret (OracleSpec.query input >>= next) context fuel table cache = + ∑' option, Pr[= option | runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache)] * + match option with + | none => 1 + | some result => expectedNativeTerminalRisk parameter root ftsSecret (next result.value.1) + result.context result.remaining result.table result.value.2 := by + rw [expectedNativeTerminalRisk, runNativeQueryTrace_query_bind, if_pos hcomplete, tsum_probOutput_bind_mul] + apply tsum_congr + intro option + cases option with + | none => simp [resolvedOutcomeFailureRisk] + | some result => + simp only [tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + rfl + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 800000 in +theorem expectedNativeTerminalRisk_le_initial_add_guessCharge + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + expectedNativeTerminalRisk parameter root ftsSecret computation context fuel table cache ≤ + resolvedContextFailureRisk table context + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (canonicalGuessCharge parameter table) computation context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + by_cases hcomplete : DeferredCompletable table context + · simp [expectedNativeTerminalRisk, runNativeQueryTrace, expectedLiveNativeContextCharge, + resolvedOutcomeFailureRisk, hcomplete] + · simp [expectedNativeTerminalRisk, runNativeQueryTrace, expectedLiveNativeContextCharge, + resolvedOutcomeFailureRisk, hcomplete, resolvedContextFailureRisk_of_not_completable table context hcomplete] + | query_bind input next ih => + by_cases hcomplete : DeferredCompletable table context + · rw [expectedNativeTerminalRisk_query_bind parameter root ftsSecret input next context fuel table cache hcomplete] + let queryRun := runResolvedFromTable context fuel table ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) + let tailCharge := fun option : Option (ResolvedRunResult ((OracleWorld + SigningSpec).Range input × SplitHashCache)) => + match option with + | none => (0 : ℝ≥0∞) + | some result => expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) (canonicalGuessCharge parameter table) + (next result.value.1) result.context result.remaining result.table result.value.2 + have hstep := probEvent_nativeQuery_finished_le_guessCharge parameter root table ftsSecret input + context fuel cache hconsistent hstarts + rw [probEvent_finished_eq_expected_outcomeRisk] at hstep + calc + _ ≤ ∑' option, Pr[= option | queryRun] * (resolvedOutcomeFailureRisk option + tailCharge option) := by + apply ENNReal.tsum_le_tsum + intro option + by_cases hoption : option ∈ support queryRun + · cases option with + | none => simp [queryRun, resolvedOutcomeFailureRisk, tailCharge] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) context fuel table result hconsistent hstarts hoption + simp only [resolvedOutcomeFailureRisk, tailCharge, hcore.1] + exact mul_le_mul' le_rfl (ih result.value.1 result.context result.remaining result.value.2 + hcore.2.1 hcore.2.2) + · have hzero := probOutput_eq_zero_of_not_mem_support hoption + change Pr[= option | queryRun] * _ ≤ _ + simp only [hzero, zero_mul, le_refl] + _ = (∑' option, Pr[= option | queryRun] * resolvedOutcomeFailureRisk option) + + ∑' option, Pr[= option | queryRun] * tailCharge option := by + simp_rw [mul_add] + rw [ENNReal.tsum_add] + _ ≤ (resolvedContextFailureRisk table context + canonicalGuessCharge parameter table input context fuel cache) + + ∑' option, Pr[= option | queryRun] * tailCharge option := add_le_add hstep le_rfl + _ = _ := by + rw [expectedLiveNativeContextCharge_query_bind, if_pos hcomplete] + exact add_assoc _ _ _ + · rw [expectedNativeTerminalRisk, runNativeQueryTrace_of_not_completable parameter root ftsSecret _ + context fuel table cache hcomplete, tsum_probOutput_pure_mul, + expectedLiveNativeContextCharge_eq_zero_of_not_completable (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) _ _ + context fuel table cache hcomplete, + resolvedContextFailureRisk_of_not_completable table context hcomplete] + simp only [resolvedOutcomeFailureRisk, add_zero, le_refl] + +theorem probEvent_nativeTrace_none_le_initial_add_guessCharge + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + Pr[fun result => result.1 = none | + runNativeQueryTrace parameter root ftsSecret computation context fuel table cache] ≤ + resolvedContextFailureRisk table context + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (canonicalGuessCharge parameter table) computation context fuel table cache := by + apply le_trans ?_ (expectedNativeTerminalRisk_le_initial_add_guessCharge parameter root table ftsSecret + computation context fuel cache hconsistent hstarts) + rw [probEvent_eq_tsum_ite, expectedNativeTerminalRisk] + apply ENNReal.tsum_le_tsum + intro result + cases result.1 <;> simp [resolvedOutcomeFailureRisk] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootCache.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootCache.lean new file mode 100644 index 00000000..ba8d2b25 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootCache.lean @@ -0,0 +1,596 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootEncoding + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +theorem rootEncodingNativeCouples_worldStep + (parameter : PublicParameter) (target : Position) (leftRoot rightRoot : Digest) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (finish : α → SplitHashCache → β × SplitHashCache) + (hfinish : ∀ output leftCache rightCache, + RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache → + (finish output leftCache).1 = (finish output rightCache).1 ∧ + RootEncodingCacheRel parameter target leftRoot rightRoot + (finish output leftCache).2 (finish output rightCache).2) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (fun cache => computation >>= fun output => pure (finish output cache)) := by + intro leftCache rightCache hcache context fuel table + change RelTriple + (runResolvedFromTable context fuel table (computation >>= fun output => pure (finish output leftCache))) + (runResolvedFromTable context fuel table (computation >>= fun output => pure (finish output rightCache))) _ + rw [runResolvedFromTable_bind, runResolvedFromTable_bind] + apply relTriple_bind (relTriple_refl (runResolvedFromTable context fuel table computation)) + intro leftResult rightResult heq + subst rightResult + cases leftResult with + | none => exact relTriple_pure_pure trivial + | some result => + simp only [runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, hfinish result.value leftCache rightCache hcache⟩ + +theorem rootEncodingNativeCouples_ensureFullChain + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (rootEncodingNativeCouples_sequenceFin parameter target leftRoot rightRoot _ + fun step => rootEncodingNativeCouples_ensureCoordinate parameter target leftRoot rightRoot + (.position (.chain lay tree leafIdx chainIdx step))).bind fun _ => + rootEncodingNativeCouples_pure parameter target leftRoot rightRoot () + +theorem rootEncodingNativeCouples_ensureOtsLeaf + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (rootEncodingNativeCouples_sequenceFin parameter target leftRoot rightRoot _ + fun chainIdx => rootEncodingNativeCouples_ensureFullChain parameter target leftRoot rightRoot + lay tree leafIdx chainIdx).bind fun _ => + rootEncodingNativeCouples_ensureCoordinate parameter target leftRoot rightRoot + (.position (.leaf lay tree leafIdx)) + +theorem rootEncodingNativeCouples_ensureTreeNode + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, + RootEncodingNativeCouples parameter target leftRoot rightRoot + (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => by + rw [ensureTreeNode] + exact rootEncodingNativeCouples_ensureOtsLeaf parameter target leftRoot rightRoot lay tree + (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (rootEncodingNativeCouples_ensureTreeNode parameter target leftRoot rightRoot lay tree + level (2 * nodeIdx)).bind fun _ => + (rootEncodingNativeCouples_ensureTreeNode parameter target leftRoot rightRoot lay tree + level (2 * nodeIdx + 1)).bind fun _ => by + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact rootEncodingNativeCouples_ensureCoordinate parameter target leftRoot + rightRoot (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact rootEncodingNativeCouples_pure parameter target leftRoot rightRoot () + +theorem rootEncodingNativeCouples_ensureTreePath + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (rootEncodingNativeCouples_sequenceFin parameter target leftRoot rightRoot _ + fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + exact rootEncodingNativeCouples_ensureTreeNode parameter target leftRoot rightRoot lay tree + level.val (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · rw [if_neg hlevel] + exact rootEncodingNativeCouples_pure parameter target leftRoot rightRoot ()).bind fun _ => + rootEncodingNativeCouples_pure parameter target leftRoot rightRoot () + +theorem relTriple_native_splitHashQuery_same_nonroot + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (key : SplitHashKey) + (hkey : ¬RootEncodingKey parameter target key) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (state : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + RelTriple + (runResolvedFromTable state fuel table ((splitHashQuery key).run leftCache)) + (runResolvedFromTable state fuel table ((splitHashQuery key).run rightCache)) + (RootEncodingNativeSameRel parameter target leftRoot rightRoot) := by + have hlookup := hcache.lookup_nonroot key hkey + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + cases hleft : leftCache key with + | some output => + have hright : rightCache key = some output := by + rw [← hlookup] + exact hleft + simp only [hright, runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + | none => + have hright : rightCache key = none := by + rw [← hlookup] + exact hleft + simp only [hright] + unfold LazyRevealProbe.hashOutputQuery + rw [runResolvedFromTable_hashOutput_query_bind, + runResolvedFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_nonroot key leftOutput hkey⟩ + +theorem rootEncodingNativeCouples_splitHashQuery_same_nonroot + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (key : SplitHashKey) + (hkey : ¬RootEncodingKey parameter target key) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (splitHashQuery key) := by + intro leftCache rightCache hcache state fuel table + exact relTriple_native_splitHashQuery_same_nonroot parameter target leftRoot rightRoot key hkey + leftCache rightCache hcache state fuel table + +theorem rootEncodingNativeCouples_splitUniformImpl + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (n : Nat) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (splitUniformImpl n) := by + intro leftCache rightCache hcache state fuel table + unfold splitUniformImpl LazyRevealProbe.uniformQuery + rw [StateT.run_liftM, StateT.run_liftM, + runResolvedFromTable_uniform_query_bind, runResolvedFromTable_uniform_query_bind] + apply relTriple_bind + (relTriple_refl (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem rootEncodingNativeCouples_simulateQ_splitUniformImpl + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (computation : ProbComp α) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (simulateQ splitUniformImpl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + rw [simulateQ_pure] + exact rootEncodingNativeCouples_pure parameter target leftRoot rightRoot value + | query_bind n next ih => + rw [simulateQ_query_bind] + exact (rootEncodingNativeCouples_splitUniformImpl parameter target leftRoot rightRoot n).bind + fun output => ih output + +theorem rootEncodingNativeCouples_messageDigest + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (publicRoot : Digest) + (message : Message) (randomness : Randomness) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl + (messageDigest parameter publicRoot message randomness)) := by + unfold messageDigest oracleHash + simp only [simulateQ_bind, HasQuery.instOfMonadLift_query, simulateQ_spec_query, + simulateQ_pure, ordinaryHashImpl] + exact (rootEncodingNativeCouples_splitHashQuery_same_nonroot parameter target leftRoot + rightRoot (.ordinary (tweakableHashInput parameter .message + (messageDigestPayload publicRoot message randomness))) + (not_encodingInputNamesRoot_tweakableHashInput_of_not_encoding parameter target .message + _ (by trivial) (by simp))).bind fun output => + rootEncodingNativeCouples_pure parameter target leftRoot rightRoot + (truncateMessageDigest output) + +theorem rootEncodingNativeCouples_signAttempt + (target : Position) (leftRoot rightRoot : Digest) + (secretKey : SecretKey) (message : Message) (randomness : Randomness) : + RootEncodingNativeCouples secretKey.parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl (signAttempt secretKey message randomness)) := by + unfold signAttempt + simp only [simulateQ_bind] + exact (rootEncodingNativeCouples_messageDigest secretKey.parameter target leftRoot rightRoot + secretKey.root message randomness).bind fun digest => by + split <;> exact rootEncodingNativeCouples_pure secretKey.parameter target leftRoot rightRoot _ + +theorem rootEncodingNativeCouples_signDigestLoop + (target : Position) (leftRoot rightRoot : Digest) + (secretKey : SecretKey) (message : Message) : ∀ attempts, + RootEncodingNativeCouples secretKey.parameter target leftRoot rightRoot + (simulateQ ordinaryRomImpl (signDigestLoop attempts secretKey message)) + | 0 => by + rw [signDigestLoop, simulateQ_pure] + exact rootEncodingNativeCouples_pure secretKey.parameter target leftRoot rightRoot none + | attempts + 1 => by + rw [signDigestLoop, simulateQ_bind] + have hrandomness : RootEncodingNativeCouples secretKey.parameter target leftRoot rightRoot + (simulateQ ordinaryRomImpl (liftM sampleRandomness)) := by + rw [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_left] + exact rootEncodingNativeCouples_simulateQ_splitUniformImpl secretKey.parameter target + leftRoot rightRoot sampleRandomness + exact hrandomness.bind fun randomness => by + rw [simulateQ_bind] + have hattempt : RootEncodingNativeCouples secretKey.parameter target leftRoot rightRoot + (simulateQ ordinaryRomImpl + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))))) := by + rw [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_right] + exact rootEncodingNativeCouples_signAttempt target leftRoot rightRoot secretKey message + randomness + exact hattempt.bind fun attempt => by + cases attempt with + | none => + exact rootEncodingNativeCouples_signDigestLoop target leftRoot rightRoot secretKey + message attempts + | some selected => + rw [simulateQ_pure] + exact rootEncodingNativeCouples_pure secretKey.parameter target leftRoot rightRoot + (some (randomness, selected.1, selected.2)) + +theorem rootEncodingNativeCouples_tweakableHash_of_not_encoding + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (domain : HashDomain) (payload : HashInput) + (hinRange : domain.InRange) + (hnotEncoding : ∀ lay tree leafIdx, domain ≠ .encoding lay tree leafIdx) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl (tweakableHash parameter domain payload)) := by + unfold tweakableHash oracleHash + simp only [simulateQ_bind, HasQuery.instOfMonadLift_query, simulateQ_spec_query, + simulateQ_pure] + exact (rootEncodingNativeCouples_splitHashQuery_same_nonroot parameter target leftRoot + rightRoot (.ordinary (tweakableHashInput parameter domain payload)) + (not_encodingInputNamesRoot_tweakableHashInput_of_not_encoding parameter target domain + payload hinRange hnotEncoding)).bind fun _ => + rootEncodingNativeCouples_pure parameter target leftRoot rightRoot _ + +theorem rootEncodingNativeCouples_ftsLeafHash + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) (tree : FtsTree) + (leafIdx : FtsLeaf) (secret : Digest) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl + (ftsLeafHash parameter index tree leafIdx secret)) := by + unfold ftsLeafHash + exact rootEncodingNativeCouples_tweakableHash_of_not_encoding parameter target leftRoot + rightRoot (.ftsLeaf index tree leafIdx) (digestBytes secret) (by trivial) (by simp) + +theorem rootEncodingNativeCouples_ftsNode + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) (tree : FtsTree) + (secret : FtsLeaf → Digest) : ∀ level nodeIdx, + level ≤ ftsTreeHeight → + 2 ^ level * (nodeIdx + 1) ≤ 2 ^ ftsTreeHeight → + RootEncodingNativeCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl + (ftsNode parameter index tree secret level nodeIdx)) + | 0, nodeIdx, _hlevel, _hspan => by + rw [ftsNode_zero_eq] + exact rootEncodingNativeCouples_ftsLeafHash parameter target leftRoot rightRoot index tree + (ftsLeafOfNat nodeIdx) (secret (ftsLeafOfNat nodeIdx)) + | level + 1, nodeIdx, hlevel, hspan => by + rw [ftsNode_succ_eq] + simp only [simulateQ_bind] + have hleftSpan : 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ ftsTreeHeight := by + rw [pow_succ] at hspan + calc + 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ level * (2 * (nodeIdx + 1)) := + Nat.mul_le_mul_left _ (by omega) + _ = 2 ^ level * 2 * (nodeIdx + 1) := by ring + _ ≤ 2 ^ ftsTreeHeight := hspan + have hrightSpan : 2 ^ level * (2 * nodeIdx + 1 + 1) ≤ 2 ^ ftsTreeHeight := by + rw [pow_succ] at hspan + calc + 2 ^ level * (2 * nodeIdx + 1 + 1) = 2 ^ level * 2 * (nodeIdx + 1) := by ring + _ ≤ 2 ^ ftsTreeHeight := hspan + have hinRange : (HashDomain.ftsNode index tree (level + 1) nodeIdx).InRange := by + show level + 1 < 2 ^ 32 ∧ nodeIdx < 2 ^ 32 + constructor + · have : ftsTreeHeight < 2 ^ 32 := by norm_num [ftsTreeHeight] + omega + · have hnode : nodeIdx < 2 ^ ftsTreeHeight := by + have hpow : 0 < 2 ^ (level + 1) := Nat.two_pow_pos _ + nlinarith + have : 2 ^ ftsTreeHeight ≤ 2 ^ 32 := Nat.pow_le_pow_right (by omega) (by + norm_num [ftsTreeHeight]) + omega + exact (rootEncodingNativeCouples_ftsNode parameter target leftRoot rightRoot index tree + secret level (2 * nodeIdx) (by omega) hleftSpan).bind fun left => + (rootEncodingNativeCouples_ftsNode parameter target leftRoot rightRoot index tree + secret level (2 * nodeIdx + 1) (by omega) hrightSpan).bind fun right => + rootEncodingNativeCouples_tweakableHash_of_not_encoding parameter target leftRoot + rightRoot (.ftsNode index tree (level + 1) nodeIdx) (nodePayload left right) + hinRange (by simp) + +theorem rootEncodingNativeCouples_ftsKey + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) + (secret : FtsTree → FtsLeaf → Digest) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl (ftsKey parameter index secret)) := by + unfold ftsKey + rw [simulateQ_bind, simulateQ_ordinaryHashImpl_sequenceFin] + exact (rootEncodingNativeCouples_sequenceFin parameter target leftRoot rightRoot _ + fun tree => rootEncodingNativeCouples_ftsNode parameter target leftRoot rightRoot index tree + (secret tree) ftsTreeHeight 0 le_rfl (by simp)).bind fun roots => + rootEncodingNativeCouples_tweakableHash_of_not_encoding parameter target leftRoot + rightRoot (.ftsRoots index) (ftsRootsPayload roots) (by trivial) (by simp) + +theorem rootEncodingNativeCouples_ftsOpen + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) + (leaves : DigestTree → FtsLeaf) + (secret : FtsTree → FtsLeaf → Digest) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl (ftsOpen parameter index leaves secret)) := by + unfold ftsOpen + rw [simulateQ_ordinaryHashImpl_sequenceFin] + apply rootEncodingNativeCouples_sequenceFin + intro tree + rw [simulateQ_ordinaryHashImpl_sequenceFin] + apply rootEncodingNativeCouples_sequenceFin + intro level + exact rootEncodingNativeCouples_ftsNode parameter target leftRoot rightRoot index tree + (secret tree) level.val (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1) + (Nat.le_of_lt level.isLt) + (FtsProbeSimulation.ftsOpen_node_bound (leaves (ftsIndexOf tree)) level) + +theorem rootEncodingNativeCouples_revealCoordinateOutput + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (coordinate : Coordinate) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (revealCoordinateOutput coordinate) := by + have heq : revealCoordinateOutput coordinate = + (fun cache : SplitHashCache => LazyRevealProbe.revealQuery coordinate >>= fun output => + pure (output, Function.update cache (.hidden coordinate) (some output))) := by + funext cache + exact revealCoordinateOutput_run_eq coordinate cache + rw [heq] + exact rootEncodingNativeCouples_worldStep parameter target leftRoot rightRoot _ _ + fun output leftCache rightCache hcache => + ⟨rfl, hcache.update_same_nonroot (.hidden coordinate) output + (not_rootEncodingKey_hidden parameter target coordinate)⟩ + +theorem rootEncodingNativeCouples_revealCoordinate + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (coordinate : Coordinate) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (revealCoordinate coordinate) := by + have heq : revealCoordinate coordinate = + (fun cache : SplitHashCache => LazyRevealProbe.revealQuery coordinate >>= fun output => + pure (truncateHash output, Function.update cache (.hidden coordinate) (some output))) := by + funext cache + exact revealCoordinate_run coordinate cache + rw [heq] + exact rootEncodingNativeCouples_worldStep parameter target leftRoot rightRoot _ _ + fun output leftCache rightCache hcache => + ⟨rfl, hcache.update_same_nonroot (.hidden coordinate) output + (not_rootEncodingKey_hidden parameter target coordinate)⟩ + +theorem rootEncodingNativeCouples_publishCoordinate + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (coordinate : Coordinate) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (publishCoordinate coordinate) := by + unfold publishCoordinate + exact rootEncodingNativeCouples_worldStep parameter target leftRoot rightRoot _ _ + fun output leftCache rightCache hcache => ⟨rfl, hcache⟩ + +theorem rootEncodingNativeCouples_revealPosition + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (position : Position) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (revealPosition position) := + rootEncodingNativeCouples_revealCoordinate parameter target leftRoot rightRoot + (.position position) + +theorem rootEncodingNativeCouples_revealPublishedCoordinate + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (coordinate : Coordinate) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + exact (rootEncodingNativeCouples_revealCoordinate parameter target leftRoot rightRoot + coordinate).bind fun _ => + (rootEncodingNativeCouples_publishCoordinate parameter target leftRoot rightRoot + coordinate).bind fun _ => + rootEncodingNativeCouples_pure parameter target leftRoot rightRoot _ + +theorem rootEncodingNativeCouples_revealLayerValues + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (revealLayerValues index lay encoding) := by + unfold revealLayerValues + apply (rootEncodingNativeCouples_sequenceFin parameter target leftRoot rightRoot _ + fun chainIdx => rootEncodingNativeCouples_revealPublishedCoordinate parameter target + leftRoot rightRoot + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + (encoding chainIdx))).bind + intro values + apply (rootEncodingNativeCouples_sequenceFin parameter target leftRoot rightRoot _ + fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + cases hzero : level.val with + | zero => + exact rootEncodingNativeCouples_revealPublishedCoordinate parameter target leftRoot + rightRoot (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | succ current => + rw [Nat.add_one] + simp only + by_cases hcurrent : current < maxLayerHeight + · rw [dif_pos hcurrent] + exact rootEncodingNativeCouples_revealPublishedCoordinate parameter target leftRoot + rightRoot (.position (.node lay (treeIndexAt index lay) ⟨current, hcurrent⟩ + (leafOfNat (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + · rw [dif_neg hcurrent] + exact rootEncodingNativeCouples_pure parameter target leftRoot rightRoot 0 + · rw [if_neg hlevel] + exact rootEncodingNativeCouples_pure parameter target leftRoot rightRoot 0).bind + intro path + exact rootEncodingNativeCouples_pure parameter target leftRoot rightRoot (values, path) + +theorem rootEncodingNativeCouples_maskedTreeNode + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, + RootEncodingNativeCouples parameter target leftRoot rightRoot + (maskedTreeNode lay tree level nodeIdx) + | level, nodeIdx => by + unfold maskedTreeNode + apply (rootEncodingNativeCouples_ensureTreeNode parameter target leftRoot rightRoot lay tree + level nodeIdx).bind + intro _ + cases level with + | zero => + exact rootEncodingNativeCouples_revealPosition parameter target leftRoot rightRoot + (.leaf lay tree (leafOfNat nodeIdx)) + | succ current => + rw [Nat.add_one] + simp only + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact rootEncodingNativeCouples_revealPosition parameter target leftRoot rightRoot + (.node lay tree ⟨current, hlevel⟩ (leafOfNat nodeIdx)) + · rw [dif_neg hlevel] + exact rootEncodingNativeCouples_pure parameter target leftRoot rightRoot 0 + +theorem rootEncodingNativeCouples_maskedTreeRoot + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (maskedTreeRoot lay tree) := + rootEncodingNativeCouples_maskedTreeNode parameter target leftRoot rightRoot lay tree + (layerHeight lay) 0 + +theorem rootEncodingNativeCouples_maskedLayerMessage + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + by_cases hbelow : lay.val + 1 < numLayers + · rw [dif_pos hbelow] + exact rootEncodingNativeCouples_maskedTreeRoot parameter target leftRoot rightRoot + ⟨lay.val + 1, hbelow⟩ (treeIndexAt index ⟨lay.val + 1, hbelow⟩) + · rw [dif_neg hbelow] + exact rootEncodingNativeCouples_ftsKey parameter target leftRoot rightRoot index + (ftsSecret index) + +set_option maxHeartbeats 1000000 in +theorem rootEncodingNativeCouples_encode_of_not_positionNames + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (position : EncodingPosition) + (message : Digest) (counter : Nat) + (hnotPosition : ¬EncodingPositionNamesRoot target position) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl + (encode parameter position.lay position.tree position.leafIdx message + (BitVec.ofNat counterBits counter))) := by + unfold encode tweakableHash oracleHash + simp only [simulateQ_bind, HasQuery.instOfMonadLift_query, simulateQ_spec_query, + simulateQ_pure, ordinaryHashImpl, bind_assoc, pure_bind] + exact (rootEncodingNativeCouples_splitHashQuery_same_nonroot parameter target leftRoot + rightRoot (.ordinary (encodingRetryInput parameter position message counter)) + (not_encodingInputNamesRoot_encodingRetryInput_of_not_positionNames hnotPosition message + counter)).bind fun output => + rootEncodingNativeCouples_pure parameter target leftRoot rightRoot + (TargetSum.decodeDigest (truncateHash output)) + +set_option maxHeartbeats 1000000 in +theorem rootEncodingNativeCouples_maskedOtsSignFrom_of_not_positionNames + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) + (hnotPosition : ¬EncodingPositionNamesRoot target ⟨lay, tree, leafIdx⟩) : + ∀ attempts counter, + RootEncodingNativeCouples parameter target leftRoot rightRoot + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom] + exact rootEncodingNativeCouples_pure parameter target leftRoot rightRoot none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + apply (rootEncodingNativeCouples_encode_of_not_positionNames parameter target leftRoot + rightRoot ⟨lay, tree, leafIdx⟩ message counter hnotPosition).bind + intro encoded + cases encoded with + | none => + exact rootEncodingNativeCouples_maskedOtsSignFrom_of_not_positionNames parameter target + leftRoot rightRoot lay tree leafIdx message hnotPosition attempts (counter + 1) + | some encoding => + exact (rootEncodingNativeCouples_sequenceFin parameter target leftRoot rightRoot + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx (encoding chainIdx)) + (fun chainIdx => rootEncodingNativeCouples_ensureChainPrefix parameter target + leftRoot rightRoot lay tree leafIdx chainIdx (encoding chainIdx))).bind fun _ => + rootEncodingNativeCouples_pure parameter target leftRoot rightRoot + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem rootEncodingNativeCouples_maskedOtsSign_of_not_positionNames + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) + (hnotPosition : ¬EncodingPositionNamesRoot target ⟨lay, tree, leafIdx⟩) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (maskedOtsSign parameter lay tree leafIdx message) := + rootEncodingNativeCouples_maskedOtsSignFrom_of_not_positionNames parameter target leftRoot + rightRoot lay tree leafIdx message hnotPosition encodingAttemptLimit 0 + +theorem rootEncodingNativeCouples_maskedOtsLayerAfterMessage_of_not_positionNames + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) (lay : Layer) + (message : Digest) + (hnotPosition : ¬EncodingPositionNamesRoot target + ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (maskedOtsLayerAfterMessage parameter index lay message) := by + unfold maskedOtsLayerAfterMessage + apply (rootEncodingNativeCouples_maskedOtsSign_of_not_positionNames parameter target leftRoot + rightRoot lay (treeIndexAt index lay) (leafIndexAt index lay) message hnotPosition).bind + intro selected + cases selected with + | none => exact rootEncodingNativeCouples_pure parameter target leftRoot rightRoot none + | some selected => + exact (rootEncodingNativeCouples_ensureTreePath parameter target leftRoot rightRoot lay + (treeIndexAt index lay) (leafIndexAt index lay)).bind fun _ => + rootEncodingNativeCouples_pure parameter target leftRoot rightRoot (some selected) + +theorem rootEncodingNativeRelates_maskedOtsLayerAfterMessage + (parameter : PublicParameter) (index : Index) (lay : Layer) + (hnotBottom : lay ≠ bottomLayer) (leftRoot rightRoot : Digest) : + RootEncodingNativeRelates parameter (layerMessagePosition index lay) leftRoot rightRoot + (maskedOtsLayerAfterMessage parameter index lay leftRoot) + (maskedOtsLayerAfterMessage parameter index lay rightRoot) := by + have hposition : EncodingPositionNamesRoot (layerMessagePosition index lay) + ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩ := + ⟨index, rfl, rfl, hnotBottom, rfl⟩ + unfold maskedOtsLayerAfterMessage + apply (rootEncodingNativeRelates_maskedOtsSign parameter (layerMessagePosition index lay) + leftRoot rightRoot lay (treeIndexAt index lay) (leafIndexAt index lay) hposition).bind + intro leftSelected rightSelected hselected + subst rightSelected + cases leftSelected with + | none => + exact (rootEncodingNativeCouples_pure parameter (layerMessagePosition index lay) + leftRoot rightRoot none).relates + | some selected => + exact ((rootEncodingNativeCouples_ensureTreePath parameter + (layerMessagePosition index lay) leftRoot rightRoot lay (treeIndexAt index lay) + (leafIndexAt index lay)).bind fun _ => + rootEncodingNativeCouples_pure parameter (layerMessagePosition index lay) + leftRoot rightRoot (some selected)).relates + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootCandidate.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootCandidate.lean new file mode 100644 index 00000000..1afac1d5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootCandidate.lean @@ -0,0 +1,129 @@ +import SphincsSecurity.Proof.OtsProbeNativeStructuralRootGuess + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem EncodingLayerRootCandidateAt.no_native_candidate + {parameter : PublicParameter} {input : HashInput} {candidate : Probe} + (h : EncodingLayerRootCandidateAt parameter input candidate) (state : LazyRevealProbe.State Coordinate) : + (purePlanProbingHashQuery parameter input state).candidate? = none := by + obtain ⟨position, index, hat, _⟩ := h + rw [purePlanProbingHashQuery, decodeProbe?_eq_none_of_atEncodingPosition hat, + decodePosition?_eq_none_of_atEncodingPosition hat] + +theorem EncodingLayerRootCandidateAt.not_structural + {parameter : PublicParameter} {input : HashInput} {encoding structural : Probe} + (h : EncodingLayerRootCandidateAt parameter input encoding) : + ¬StructuralLayerRootCandidateAt parameter input structural := by + obtain ⟨position, index, hat, _⟩ := h + rintro ⟨parent, target, hparent, _⟩ + exact hat.not_atPosition parent hparent + +def NativeRootCandidateAt (parameter : PublicParameter) (input : HashInput) + (context : DeferredContext) (candidate : Probe) : Prop := + (purePlanProbingHashQuery parameter input context.state).candidate? = some candidate ∨ + EncodingLayerRootCandidateAt parameter input candidate ∨ + (KnownHiddenStructuralRootQuery parameter input context ∧ StructuralLayerRootCandidateAt parameter input candidate) + +theorem nativeRootCandidateAt_unique + {parameter : PublicParameter} {input : HashInput} {context : DeferredContext} {left right : Probe} + (hleft : NativeRootCandidateAt parameter input context left) + (hright : NativeRootCandidateAt parameter input context right) : left = right := by + rcases hleft with hleft | hleft | ⟨hleftKnown, hleft⟩ + · rcases hright with hright | hright | ⟨hrightKnown, hright⟩ + · exact Option.some.inj (hleft.symm.trans hright) + · rw [hright.no_native_candidate context.state] at hleft + contradiction + · rw [hrightKnown.no_candidate] at hleft + contradiction + · rcases hright with hright | hright | ⟨hrightKnown, hright⟩ + · rw [hleft.no_native_candidate context.state] at hright + contradiction + · exact encodingLayerRootCandidateAt_unique hleft hright + · exact False.elim (hleft.not_structural hright) + · rcases hright with hright | hright | ⟨hrightKnown, hright⟩ + · rw [hleftKnown.no_candidate] at hright + contradiction + · exact False.elim (hright.not_structural hleft) + · exact structuralLayerRootCandidateAt_unique hleft hright + +noncomputable def nativeRootCandidate? (parameter : PublicParameter) (input : HashInput) + (context : DeferredContext) : Option Probe := + if h : ∃ candidate, NativeRootCandidateAt parameter input context candidate then some h.choose else none + +theorem nativeRootCandidate?_eq_some_iff + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) (candidate : Probe) : + nativeRootCandidate? parameter input context = some candidate ↔ NativeRootCandidateAt parameter input context candidate := by + unfold nativeRootCandidate? + split + next hexists => + constructor + · intro heq + have hchosen : hexists.choose = candidate := Option.some.inj heq + simpa only [← hchosen] using hexists.choose_spec + · intro hcandidate + exact congrArg some (nativeRootCandidateAt_unique hexists.choose_spec hcandidate) + next hnone => + constructor + · intro heq; contradiction + · intro hcandidate + exact False.elim (hnone ⟨candidate, hcandidate⟩) + +theorem NativeRootContextRel.candidateAt_iff + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) + (parameter : PublicParameter) (input : HashInput) (candidate : Probe) : + NativeRootCandidateAt parameter input left candidate ↔ NativeRootCandidateAt parameter input right candidate := by + unfold NativeRootCandidateAt + rw [purePlanProbingHashQuery_eq_of_nativeRootContextRel h, + knownHiddenStructuralRootQuery_replace_root_iff h parameter input] + +theorem NativeRootContextRel.candidate_eq + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) + (parameter : PublicParameter) (input : HashInput) : + nativeRootCandidate? parameter input left = nativeRootCandidate? parameter input right := by + cases hleft : nativeRootCandidate? parameter input left with + | none => + cases hright : nativeRootCandidate? parameter input right with + | none => rfl + | some candidate => + have hcandidate := (h.candidateAt_iff parameter input candidate).mpr + ((nativeRootCandidate?_eq_some_iff parameter input right candidate).mp hright) + have heq := (nativeRootCandidate?_eq_some_iff parameter input left candidate).mpr hcandidate + rw [hleft] at heq + contradiction + | some candidate => + have hcandidate := (h.candidateAt_iff parameter input candidate).mp + ((nativeRootCandidate?_eq_some_iff parameter input left candidate).mp hleft) + exact ((nativeRootCandidate?_eq_some_iff parameter input right candidate).mpr hcandidate).symm + +theorem nativeRootHashSafe_failure_of_hidden_result_candidate + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) (before after : HashOutput) + (input : HashInput) (context : DeferredContext) (h : NativePositionReplaceable target before after context) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hunsafe : ¬NativeRootHashSafe parameter target before after input context) + (result : ResolvedRunResult (HashOutput × SplitHashCache)) + (hresult : some result ∈ support (runResolvedFromTable context fuel table ((probingHashQuery parameter input).run cache))) + (hhidden : .position target ∉ result.context.state.revealed) : + ∃ candidate, nativeRootCandidate? parameter input context = some candidate ∧ + candidate.coordinate = .position target ∧ + (candidate.candidate = truncateHash before ∨ candidate.candidate = truncateHash after) := by + have hfailure := nativeRootHashSafe_failure_of_hidden_result_guesses parameter target hroot before after input context h + fuel table cache hunsafe result hresult hhidden + rcases hfailure with (hencoding | hencoding) | ⟨candidate, hplan, hexposure⟩ | ⟨hknown, candidate, hcandidate, hcoordinate, hguess⟩ + · refine ⟨⟨.position target, truncateHash before⟩, ?_, rfl, Or.inl rfl⟩ + apply (nativeRootCandidate?_eq_some_iff parameter input context _).mpr + exact Or.inr (Or.inl ((decodeEncodingLayerRootCandidate?_eq_some_iff parameter input _).mp hencoding)) + · refine ⟨⟨.position target, truncateHash after⟩, ?_, rfl, Or.inr rfl⟩ + apply (nativeRootCandidate?_eq_some_iff parameter input context _).mpr + exact Or.inr (Or.inl ((decodeEncodingLayerRootCandidate?_eq_some_iff parameter input _).mp hencoding)) + · exact ⟨candidate, (nativeRootCandidate?_eq_some_iff parameter input context candidate).mpr (Or.inl hplan), hexposure⟩ + · exact ⟨candidate, (nativeRootCandidate?_eq_some_iff parameter input context candidate).mpr + (Or.inr (Or.inr ⟨hknown, hcandidate⟩)), hcoordinate, hguess⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootCandidateHistory.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootCandidateHistory.lean new file mode 100644 index 00000000..d4a117ca --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootCandidateHistory.lean @@ -0,0 +1,103 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootCandidate +import SphincsSecurity.Proof.OtsProbeNativeQueryTraceSelection +import SphincsSecurity.Proof.OtsProbePrivateValueHistoryRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def nativeRootSelectionCandidate? (parameter : PublicParameter) (selection : CanonicalQuerySelection) : Option Probe := + match selection.input with + | .inl (.inr input) => nativeRootCandidate? parameter input selection.context + | _ => none + +noncomputable def nativeRootSelectionGuess? (parameter : PublicParameter) (target : Position) + (selection : CanonicalQuerySelection) : Option Digest := do + let candidate ← nativeRootSelectionCandidate? parameter selection + if candidate.coordinate = .position target then some candidate.candidate else none + +noncomputable def nativeRootCandidateHistory (parameter : PublicParameter) (target : Position) + (history : List CanonicalQuerySelection) : Finset Digest := + ((nativeHashQueryHistory history).filterMap (nativeRootSelectionGuess? parameter target)).toFinset + +theorem nativeRootCandidateHistory_card_le_hash_length + (parameter : PublicParameter) (target : Position) (history : List CanonicalQuerySelection) : + (nativeRootCandidateHistory parameter target history).card ≤ (nativeHashQueryHistory history).length := by + exact (List.toFinset_card_le _).trans (List.length_filterMap_le _ _) + +theorem runNativeQueryTrace_hash_length_le + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (bound : Nat) (hbound : computation.IsQueryBoundP IsOuterHash bound) + (result : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) + (hresult : result ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) : + (nativeHashQueryHistory result.2).length ≤ bound := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache bound result with + | pure value => + simp only [runNativeQueryTrace, OracleComp.construct_pure] at hresult + split_ifs at hresult <;> + simp only [mem_support_pure_iff] at hresult <;> + subst result <;> simp [nativeHashQueryHistory] + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [runNativeQueryTrace_query_bind] at hresult + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete, mem_support_bind_iff] at hresult + obtain ⟨middle, hmiddle, htail⟩ := hresult + have hstep (history : List CanonicalQuerySelection) + (hlength : (nativeHashQueryHistory history).length ≤ if IsOuterHash input then bound - 1 else bound) : + (nativeHashQueryHistory (⟨input, context, fuel, table, cache⟩ :: history)).length ≤ bound := by + by_cases hhash : IsOuterHash input + · have hpositive := hbound.1.resolve_left (not_not.mpr hhash) + simp only [if_pos hhash] at hlength + simpa only [nativeHashQueryHistory, List.filter_cons, hhash, decide_true, Bool.true_eq, ↓reduceIte, + List.length_cons] using (show (nativeHashQueryHistory history).length + 1 ≤ bound by omega) + · simpa only [nativeHashQueryHistory, List.filter_cons, hhash, decide_false, Bool.false_eq_true, ↓reduceIte] + using hlength + cases middle with + | none => + simp only [pure_bind, mem_support_pure_iff] at htail + subst result + exact hstep [] (by simp [nativeHashQueryHistory]) + | some middle => + simp only [mem_support_bind_iff] at htail + obtain ⟨tail, htail, hresult⟩ := htail + simp only [mem_support_pure_iff] at hresult + subst result + exact hstep tail.2 (ih middle.value.1 middle.context middle.remaining middle.table middle.value.2 + (if IsOuterHash input then bound - 1 else bound) (hbound.2 middle.value.1) tail htail) + · rw [if_neg hcomplete, mem_support_pure_iff] at hresult + subst result + simp [nativeHashQueryHistory] + +theorem runNativeQueryTrace_root_history_card_le + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (bound : Nat) (hbound : computation.IsQueryBoundP IsOuterHash bound) + (result : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) + (hresult : result ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) : + (nativeRootCandidateHistory parameter target result.2).card ≤ bound := + (nativeRootCandidateHistory_card_le_hash_length parameter target result.2).trans + (runNativeQueryTrace_hash_length_le parameter root ftsSecret computation context fuel table cache bound hbound result hresult) + +theorem probEvent_uniform_avoids_native_root_history_ge_three_quarters + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (bound : Nat) (hbound : computation.IsQueryBoundP IsOuterHash bound) + (initialHistory : Finset Digest) (hbudget : initialHistory.card + bound ≤ 2 ^ 126) + (result : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) + (hresult : result ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) : + (3 / 4 : ENNReal) ≤ Pr[fun output => truncateHash output ∉ + initialHistory ∪ nativeRootCandidateHistory parameter target result.2 | LazyRevealProbe.sampleHashOutput] := by + apply probEvent_uniform_avoids_private_history_ge_three_quarters + exact (Finset.card_union_le _ _).trans ((Nat.add_le_add_left + (runNativeQueryTrace_root_history_card_le parameter root ftsSecret target computation context fuel table cache bound hbound result hresult) + initialHistory.card).trans hbudget) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootCandidateNormalization.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootCandidateNormalization.lean new file mode 100644 index 00000000..19e45d76 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootCandidateNormalization.lean @@ -0,0 +1,168 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootCandidate + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem firstMissingInputCoordinatePlan_eq_of_value_presence + (left right : LazyRevealProbe.State Coordinate) + (hrel : ∀ coordinate, (left.values coordinate).isSome = (right.values coordinate).isSome) + (input : HashInput) : ∀ slot coordinates, + firstMissingInputCoordinatePlan left input slot coordinates = + firstMissingInputCoordinatePlan right input slot coordinates := by + intro slot coordinates + induction coordinates generalizing slot with + | nil => rfl + | cons coordinate remaining ih => + rw [firstMissingInputCoordinatePlan, firstMissingInputCoordinatePlan] + have hpresent := hrel coordinate + cases hleft : left.values coordinate with + | none => + cases hright : right.values coordinate with + | none => rfl + | some rightValue => simp [hleft, hright] at hpresent + | some leftValue => + cases hright : right.values coordinate with + | none => simp [hleft, hright] at hpresent + | some rightValue => + exact ih (slot + 1) + +theorem leafInputProbePlan_eq_of_value_presence + (left right : LazyRevealProbe.State Coordinate) + (hrel : ∀ coordinate, (left.values coordinate).isSome = (right.values coordinate).isSome) + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + leafInputProbePlan left input candidate lay tree leafIdx = + leafInputProbePlan right input candidate lay tree leafIdx := by + unfold leafInputProbePlan + have hpresent := hrel candidate.coordinate + cases hleft : left.values candidate.coordinate with + | none => + cases hright : right.values candidate.coordinate with + | none => rfl + | some rightValue => simp [hleft, hright] at hpresent + | some leftValue => + cases hright : right.values candidate.coordinate with + | none => simp [hleft, hright] at hpresent + | some rightValue => + exact firstMissingInputCoordinatePlan_eq_of_value_presence left right hrel input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + +theorem purePlanProbingHashQuery_eq_of_value_presence + (left right : LazyRevealProbe.State Coordinate) + (hrel : ∀ coordinate, (left.values coordinate).isSome = (right.values coordinate).isSome) + (parameter : PublicParameter) (input : HashInput) : + purePlanProbingHashQuery parameter input left = + purePlanProbingHashQuery parameter input right := by + unfold purePlanProbingHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases hposition : decodePosition? parameter input with + | none => rfl + | some position => + cases position with + | leaf lay tree leafIdx => + simp only + rw [leafInputProbePlan_eq_of_value_presence left right hrel] + | chain | node | ftsLeaf | ftsNode | ftsRoots => rfl + | none => + cases hposition : decodePosition? parameter input with + | none => rfl + | some position => + cases position with + | node lay tree level nodeIdx => + simp only + rw [firstMissingInputCoordinatePlan_eq_of_value_presence left right hrel] + | chain | leaf | ftsLeaf | ftsNode | ftsRoots => rfl + +theorem replaceNativePosition_values_isSome + (target : Position) (output : HashOutput) (context : DeferredContext) (coordinate : Coordinate) : + (context.state.values coordinate).isSome = ((replaceNativePosition target output context).state.values coordinate).isSome := by + by_cases heq : coordinate = .position target + · subst coordinate + simp [replaceNativePosition] + · simp [replaceNativePosition, Function.update_of_ne heq] + +theorem purePlanProbingHashQuery_replaceNativePosition + (parameter : PublicParameter) (input : HashInput) (target : Position) (output : HashOutput) (context : DeferredContext) : + purePlanProbingHashQuery parameter input context.state = + purePlanProbingHashQuery parameter input (replaceNativePosition target output context).state := + purePlanProbingHashQuery_eq_of_value_presence _ _ (replaceNativePosition_values_isSome target output context) parameter input + +theorem purePeekPositionValues_none_replaceNativePosition + (target : Position) (output : HashOutput) (context : DeferredContext) (positions : List Position) : + purePeekPositionValues context.state positions = none ↔ + purePeekPositionValues (replaceNativePosition target output context).state positions = none := by + have hnone (coordinate) : context.state.values coordinate = none ↔ + (replaceNativePosition target output context).state.values coordinate = none := by + have h := replaceNativePosition_values_isSome target output context coordinate + cases hleft : context.state.values coordinate <;> + cases hright : (replaceNativePosition target output context).state.values coordinate <;> simp_all + simp only [purePeekPositionValues_eq_none_iff_missing, hnone] + +theorem purePeekTableInput_none_replaceNativePosition + (parameter : PublicParameter) (target : Position) (output : HashOutput) (context : DeferredContext) (coordinate : Coordinate) : + purePeekTableInput parameter context.state coordinate = none ↔ + purePeekTableInput parameter (replaceNativePosition target output context).state coordinate = none := by + cases coordinate with + | chainStart => rfl + | position position => + have hchildren := purePeekPositionValues_none_replaceNativePosition target output context position.children + cases position with + | chain lay tree leafIdx chainIdx step => + by_cases hzero : step.val = 0 + · have hstart : (replaceNativePosition target output context).state.values (.chainStart lay tree leafIdx chainIdx) = + context.state.values (.chainStart lay tree leafIdx chainIdx) := by simp [replaceNativePosition] + simp only [purePeekTableInput, if_pos hzero, hstart] + · simp only [purePeekTableInput, if_neg hzero] + cases hleft : purePeekPositionValues context.state _ <;> + cases hright : purePeekPositionValues (replaceNativePosition target output context).state _ <;> simp_all + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp only [purePeekTableInput] + cases hleft : purePeekPositionValues context.state _ <;> + cases hright : purePeekPositionValues (replaceNativePosition target output context).state _ <;> simp_all + +theorem knownHiddenStructuralRootQuery_replaceNativePosition + (parameter : PublicParameter) (target : Position) (output : HashOutput) (context : DeferredContext) (input : HashInput) : + KnownHiddenStructuralRootQuery parameter input context ↔ + KnownHiddenStructuralRootQuery parameter input (replaceNativePosition target output context) := by + constructor + · rintro ⟨parent, rootPosition, hat, hroot, hmem, hhidden, hknown⟩ + refine ⟨parent, rootPosition, hat, hroot, hmem, hhidden, ?_⟩ + intro hnone + exact hknown ((purePeekTableInput_none_replaceNativePosition parameter target output context (.position parent)).mpr hnone) + · rintro ⟨parent, rootPosition, hat, hroot, hmem, hhidden, hknown⟩ + refine ⟨parent, rootPosition, hat, hroot, hmem, hhidden, ?_⟩ + intro hnone + exact hknown ((purePeekTableInput_none_replaceNativePosition parameter target output context (.position parent)).mp hnone) + +theorem nativeRootCandidateAt_replaceNativePosition + (parameter : PublicParameter) (target : Position) (output : HashOutput) (context : DeferredContext) (input : HashInput) (candidate : Probe) : + NativeRootCandidateAt parameter input context candidate ↔ + NativeRootCandidateAt parameter input (replaceNativePosition target output context) candidate := by + unfold NativeRootCandidateAt + rw [purePlanProbingHashQuery_replaceNativePosition parameter input target output context, + knownHiddenStructuralRootQuery_replaceNativePosition parameter target output context input] + +theorem nativeRootCandidate_replaceNativePosition + (parameter : PublicParameter) (target : Position) (output : HashOutput) (context : DeferredContext) (input : HashInput) : + nativeRootCandidate? parameter input context = nativeRootCandidate? parameter input (replaceNativePosition target output context) := by + cases hleft : nativeRootCandidate? parameter input context with + | none => + cases hright : nativeRootCandidate? parameter input (replaceNativePosition target output context) with + | none => rfl + | some candidate => + have hcandidate := (nativeRootCandidateAt_replaceNativePosition parameter target output context input candidate).mpr + ((nativeRootCandidate?_eq_some_iff parameter input _ candidate).mp hright) + have heq := (nativeRootCandidate?_eq_some_iff parameter input context candidate).mpr hcandidate + rw [hleft] at heq + contradiction + | some candidate => + have hcandidate := (nativeRootCandidateAt_replaceNativePosition parameter target output context input candidate).mp + ((nativeRootCandidate?_eq_some_iff parameter input context candidate).mp hleft) + exact ((nativeRootCandidate?_eq_some_iff parameter input _ candidate).mpr hcandidate).symm + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootCompatibleTrace.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootCompatibleTrace.lean new file mode 100644 index 00000000..a53fd481 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootCompatibleTrace.lean @@ -0,0 +1,155 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootTraceSafety + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open _root_.OracleComp.DeferredSampling + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def insertNativeRootGuess (guess : Option Digest) (history : Finset Digest) : Finset Digest := + match guess with + | none => history + | some guess => insert guess history + +theorem nativeRootCandidateHistory_cons + (parameter : PublicParameter) (target : Position) (selection : CanonicalQuerySelection) (history : List CanonicalQuerySelection) : + nativeRootCandidateHistory parameter target (selection :: history) = + insertNativeRootGuess (nativeRootSelectionGuess? parameter target selection) (nativeRootCandidateHistory parameter target history) := by + cases hinput : selection.input with + | inl query => + cases query with + | inl n => simp [nativeRootCandidateHistory, nativeHashQueryHistory, IsOuterHash, hinput, + nativeRootSelectionGuess?, nativeRootSelectionCandidate?, insertNativeRootGuess] + | inr input => + cases hguess : nativeRootSelectionGuess? parameter target selection <;> + simp [nativeRootCandidateHistory, nativeHashQueryHistory, IsOuterHash, hinput, hguess, insertNativeRootGuess] + | inr message => simp [nativeRootCandidateHistory, nativeHashQueryHistory, IsOuterHash, hinput, + nativeRootSelectionGuess?, nativeRootSelectionCandidate?, insertNativeRootGuess] + +noncomputable def observeCompatibleNativeRootTrace + (parameter : PublicParameter) (target : Position) (before after : HashOutput) + (trace : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) : + Option (ResolvedRunResult α × Finset Digest) := + if NativeRootTraceCompatible parameter target before after trace then + (normalizeNativeRootResult target trace.1).map fun result => (result, nativeRootCandidateHistory parameter target trace.2) + else none + +noncomputable def prependCompatibleNativeRootGuess (before after : HashOutput) (guess : Option Digest) : + Option (ResolvedRunResult α × Finset Digest) → Option (ResolvedRunResult α × Finset Digest) + | none => none + | some (result, history) => + if truncateHash before ∉ insertNativeRootGuess guess history ∧ truncateHash after ∉ insertNativeRootGuess guess history then + some (result, insertNativeRootGuess guess history) + else none + +theorem observeCompatibleNativeRootTrace_prepend + (parameter : PublicParameter) (target : Position) (before after : HashOutput) + (selection : CanonicalQuerySelection) + (trace : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) : + observeCompatibleNativeRootTrace parameter target before after (trace.1, selection :: trace.2) = + prependCompatibleNativeRootGuess before after (nativeRootSelectionGuess? parameter target selection) + (observeCompatibleNativeRootTrace parameter target before after trace) := by + rcases trace with ⟨option, history⟩ + cases option with + | none => simp [observeCompatibleNativeRootTrace, NativeRootTraceCompatible, prependCompatibleNativeRootGuess] + | some result => + cases hguess : nativeRootSelectionGuess? parameter target selection <;> + by_cases hhidden : .position target ∉ result.context.state.revealed <;> + by_cases hbefore : truncateHash before ∈ nativeRootCandidateHistory parameter target history <;> + by_cases hafter : truncateHash after ∈ nativeRootCandidateHistory parameter target history <;> + simp [observeCompatibleNativeRootTrace, NativeRootTraceCompatible, nativeRootCandidateHistory_cons, + prependCompatibleNativeRootGuess, insertNativeRootGuess, hguess, hhidden, hbefore, hafter, + normalizeNativeRootResult] + +theorem observeCompatibleNativeRootTrace_eq_none_of_not_compatible + (parameter : PublicParameter) (target : Position) (before after : HashOutput) + (trace : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) + (h : ¬NativeRootTraceCompatible parameter target before after trace) : + observeCompatibleNativeRootTrace parameter target before after trace = none := by + simp [observeCompatibleNativeRootTrace, h] + +theorem evalDist_observeCompatibleNativeRootTrace_eq_none_of_unsafe + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (before after : HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (h : NativePositionReplaceable target before after context) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hunsafe : ¬NativeRootOuterSafe parameter target before after input context) : + evalDist (observeCompatibleNativeRootTrace parameter target before after <$> + runNativeQueryTrace parameter root ftsSecret (OracleSpec.query input >>= next) context fuel table cache) = + evalDist (pure none : ProbComp (Option (ResolvedRunResult α × Finset Digest))) := by + have hzero := probEvent_nativeRootTraceCompatible_eq_zero_of_unsafe parameter root target hroot before after ftsSecret + input next context h fuel table cache hunsafe + have hnot := probEvent_eq_zero_iff.mp hzero + rw [map_eq_bind_pure_comp] + calc + _ = evalDist (runNativeQueryTrace parameter root ftsSecret (OracleSpec.query input >>= next) context fuel table cache >>= + fun _ => pure none) := by + apply evalDist_bind_congr + intro trace htrace + rw [Function.comp_apply, observeCompatibleNativeRootTrace_eq_none_of_not_compatible parameter target before after trace (hnot trace htrace)] + _ = _ := evalDist_bind_const_neverFails _ (by simp [runNativeQueryTrace]) _ + +theorem NativeRootContextRel.symm + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) : + NativeRootContextRel target after before right left := by + rw [h.right_eq] + exact ⟨h.replaceable.reverse, (replaceNativePosition_inverse h.replaceable).symm⟩ + +theorem nativeRootActionSafe_symm + (parameter : PublicParameter) (target : Position) (input : HashInput) + (left right : DeferredContext) (action : PlannedHashAction) : + NativeRootActionSafe parameter target input left right action ↔ + NativeRootActionSafe parameter target input right left action := by + cases action with + | ordinary => rfl + | resolve coordinate => simp only [NativeRootActionSafe, eq_comm, and_comm] + +theorem NativeRootContextRel.hashSafe_swap_iff + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) (parameter : PublicParameter) (input : HashInput) : + NativeRootHashSafe parameter target before after input left ↔ NativeRootHashSafe parameter target after before input right := by + have hreverse := h.symm + simp only [NativeRootHashSafe, h.replaceable.replace_self, hreverse.replaceable.replace_self, + ← h.right_eq, ← hreverse.right_eq] + rw [← purePlanProbingHashQuery_eq_of_nativeRootContextRel h] + have hprobe (candidate : Probe) : + IsPrivateValueExposure target before after (.probe candidate.coordinate candidate.candidate) ↔ + IsPrivateValueExposure target after before (.probe candidate.coordinate candidate.candidate) := by + simp only [IsPrivateValueExposure, or_comm] + have haction := nativeRootActionSafe_symm parameter target input left right + (purePlanProbingHashQuery parameter input left.state).action + constructor + · rintro ⟨hencoding, hprobes, hsafe⟩ + exact ⟨⟨hencoding.2, hencoding.1⟩, + fun candidate hcandidate hexposure => hprobes candidate hcandidate ((hprobe candidate).mpr hexposure), haction.mp hsafe⟩ + · rintro ⟨hencoding, hprobes, hsafe⟩ + exact ⟨⟨hencoding.2, hencoding.1⟩, + fun candidate hcandidate hexposure => hprobes candidate hcandidate ((hprobe candidate).mp hexposure), haction.mpr hsafe⟩ + +theorem NativeRootContextRel.outerSafe_swap_iff + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) (parameter : PublicParameter) + (input : (OracleWorld + SigningSpec).Domain) : + NativeRootOuterSafe parameter target before after input left ↔ NativeRootOuterSafe parameter target after before input right := by + cases input with + | inl query => + cases query with + | inl n => rfl + | inr input => exact h.hashSafe_swap_iff parameter input + | inr message => rfl + +theorem observeCompatibleNativeRootTrace_swap + (parameter : PublicParameter) (target : Position) (before after : HashOutput) + (trace : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) : + observeCompatibleNativeRootTrace parameter target before after trace = observeCompatibleNativeRootTrace parameter target after before trace := by + have heq : NativeRootTraceCompatible parameter target before after trace ↔ NativeRootTraceCompatible parameter target after before trace := by + rcases trace with ⟨option, history⟩ + cases option <;> simp only [NativeRootTraceCompatible, and_comm] + simp only [observeCompatibleNativeRootTrace, heq] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootEncoding.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootEncoding.lean new file mode 100644 index 00000000..09210b16 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootEncoding.lean @@ -0,0 +1,378 @@ +import SphincsSecurity.Proof.OtsProbeInitializedRootSelection + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +def RootEncodingNativeSameRel + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) : + Option (ResolvedRunResult (α × SplitHashCache)) → + Option (ResolvedRunResult (α × SplitHashCache)) → Prop + | some left, some right => + left.context = right.context ∧ left.remaining = right.remaining ∧ + left.table = right.table ∧ left.value.1 = right.value.1 ∧ + RootEncodingCacheRel parameter target leftRoot rightRoot left.value.2 right.value.2 + | none, none => True + | _, _ => False + +def RootEncodingNativeCouples + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftCache rightCache, + RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache → + ∀ state fuel table, + RelTriple + (runResolvedFromTable state fuel table (computation.run leftCache)) + (runResolvedFromTable state fuel table (computation.run rightCache)) + (RootEncodingNativeSameRel parameter target leftRoot rightRoot) + +def RootEncodingNativeRelates + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftCache rightCache, + RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache → + ∀ state fuel table, + RelTriple + (runResolvedFromTable state fuel table (left.run leftCache)) + (runResolvedFromTable state fuel table (right.run rightCache)) + (RootEncodingNativeSameRel parameter target leftRoot rightRoot) + +theorem RootEncodingNativeCouples.relates + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + (hcouples : RootEncodingNativeCouples parameter target leftRoot rightRoot computation) : + RootEncodingNativeRelates parameter target leftRoot rightRoot computation computation := + hcouples + +theorem rootEncodingNativeCouples_pure + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (value : α) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := by + intro leftCache rightCache hcache state fuel table + simp only [StateT.run_pure, runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem rootEncodingNativeCouples_ensureCoordinate + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (coordinate : Coordinate) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (ensureCoordinate coordinate) := by + intro leftCache rightCache hcache state fuel table + change RelTriple + (runResolvedFromTable state fuel table (LazyRevealProbe.ensureQuery coordinate >>= fun value => pure (value, leftCache))) + (runResolvedFromTable state fuel table (LazyRevealProbe.ensureQuery coordinate >>= fun value => pure (value, rightCache))) _ + rw [LazyRevealProbe.ensureQuery, runResolvedFromTable_ensure_query_bind, runResolvedFromTable_ensure_query_bind] + simp only [runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + + +theorem RootEncodingNativeCouples.bind + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : RootEncodingNativeCouples parameter target leftRoot rightRoot left) + (hnext : ∀ value, + RootEncodingNativeCouples parameter target leftRoot rightRoot (next value)) : + RootEncodingNativeCouples parameter target leftRoot rightRoot (left >>= next) := by + intro leftCache rightCache hcache state fuel table + rw [StateT.run_bind, StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_bind] + apply relTriple_bind (hleft leftCache rightCache hcache state fuel table) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [RootEncodingNativeSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootEncodingNativeSameRel] at hresult + | some rightResult => + rcases hresult with ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + simp only + rw [← hstate, ← hremaining, ← htable, ← hvalue] + exact hnext leftResult.value.1 leftResult.value.2 rightResult.value.2 hnextCache + leftResult.context leftResult.remaining leftResult.table + + +theorem RootEncodingNativeRelates.bind + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {leftNext rightNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hfirst : RootEncodingNativeRelates parameter target leftRoot rightRoot left right) + (hnext : ∀ leftValue rightValue, leftValue = rightValue → + RootEncodingNativeRelates parameter target leftRoot rightRoot + (leftNext leftValue) (rightNext rightValue)) : + RootEncodingNativeRelates parameter target leftRoot rightRoot + (left >>= leftNext) (right >>= rightNext) := by + intro leftCache rightCache hcache state fuel table + rw [StateT.run_bind, StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_bind] + apply relTriple_bind (hfirst leftCache rightCache hcache state fuel table) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [RootEncodingNativeSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootEncodingNativeSameRel] at hresult + | some rightResult => + rcases hresult with ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + simp only + rw [← hstate, ← hremaining, ← htable, ← hvalue] + exact hnext leftResult.value.1 leftResult.value.1 rfl + leftResult.value.2 rightResult.value.2 hnextCache + leftResult.context leftResult.remaining leftResult.table + +theorem rootEncodingNativeCouples_sequenceFin + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, + RootEncodingNativeCouples parameter target leftRoot rightRoot (computation index)) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (sequenceFin computation) := by + induction n with + | zero => + simp only [sequenceFin] + exact rootEncodingNativeCouples_pure parameter target leftRoot rightRoot Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomponent 0).bind fun _ => + (ih (fun index : Fin n => computation index.succ) + (fun index => hcomponent index.succ)).bind fun _ => + rootEncodingNativeCouples_pure parameter target leftRoot rightRoot _ + +theorem rootEncodingNativeRelates_sequenceFin + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) {n : Nat} + (left right : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, + RootEncodingNativeRelates parameter target leftRoot rightRoot + (left index) (right index)) : + RootEncodingNativeRelates parameter target leftRoot rightRoot + (sequenceFin left) (sequenceFin right) := by + induction n with + | zero => + simp only [sequenceFin] + exact (rootEncodingNativeCouples_pure parameter target leftRoot rightRoot Fin.elim0).relates + | succ n ih => + rw [sequenceFin, sequenceFin] + exact (hcomponent 0).bind fun leftHead rightHead hhead => + (ih (fun index : Fin n => left index.succ) (fun index : Fin n => right index.succ) + (fun index => hcomponent index.succ)).bind fun leftTail rightTail htail => by + subst rightHead + subst rightTail + exact (rootEncodingNativeCouples_pure parameter target leftRoot rightRoot + (Fin.cases leftHead leftTail : Fin (n + 1) → α)).relates + +theorem rootEncodingNativeCouples_ensureChainPrefix + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (rootEncodingNativeCouples_sequenceFin parameter target leftRoot rightRoot _ + fun step => by + by_cases hstep : step.val < digit.val + · rw [if_pos hstep] + exact rootEncodingNativeCouples_ensureCoordinate parameter target leftRoot rightRoot _ + · rw [if_neg hstep] + exact rootEncodingNativeCouples_pure parameter target leftRoot rightRoot ()).bind fun _ => + rootEncodingNativeCouples_pure parameter target leftRoot rightRoot () + + +theorem relTriple_native_splitHashQuery_encodingRetryInput + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (position : EncodingPosition) (counter : Nat) + (hposition : EncodingPositionNamesRoot target position) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (state : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + RelTriple + (runResolvedFromTable state fuel table + ((splitHashQuery (.ordinary + (encodingRetryInput parameter position leftRoot counter))).run leftCache)) + (runResolvedFromTable state fuel table + ((splitHashQuery (.ordinary + (encodingRetryInput parameter position rightRoot counter))).run rightCache)) + (RootEncodingNativeSameRel parameter target leftRoot rightRoot) := by + let leftInput := encodingRetryInput parameter position leftRoot counter + let rightInput := encodingRetryInput parameter position rightRoot counter + have hlookup := hcache.retry position counter hposition + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + cases hleft : leftCache (.ordinary leftInput) with + | some output => + have hright : rightCache (.ordinary rightInput) = some output := by + rw [← hlookup] + exact hleft + simp only [rightInput, hright] + simp only [runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + | none => + have hright : rightCache (.ordinary rightInput) = none := by + rw [← hlookup] + exact hleft + simp only [rightInput, hright] + unfold LazyRevealProbe.hashOutputQuery + rw [runResolvedFromTable_hashOutput_query_bind, + runResolvedFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_retry position counter hposition leftOutput⟩ + + +def RootEncodingNativeAttemptRel + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) : + Option (ResolvedRunResult (Option Encoding × SplitHashCache)) → + Option (ResolvedRunResult (Option Encoding × SplitHashCache)) → Prop := + RootEncodingNativeSameRel parameter target leftRoot rightRoot + +theorem relTriple_native_rootEncodingAttemptRun + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (position : EncodingPosition) (counter : Nat) + (hposition : EncodingPositionNamesRoot target position) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (state : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + RelTriple + (runResolvedFromTable state fuel table + (rootEncodingAttemptRun parameter position leftRoot counter leftCache)) + (runResolvedFromTable state fuel table + (rootEncodingAttemptRun parameter position rightRoot counter rightCache)) + (RootEncodingNativeAttemptRel parameter target leftRoot rightRoot) := by + unfold rootEncodingAttemptRun + rw [runResolvedFromTable_bind, runResolvedFromTable_bind] + apply relTriple_bind + (relTriple_native_splitHashQuery_encodingRetryInput parameter target leftRoot rightRoot position + counter hposition leftCache rightCache hcache state fuel table) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => + simp [RootEncodingNativeSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootEncodingNativeSameRel] at hresult + | some rightResult => + rcases hresult with ⟨hstate, hremaining, htable, houtput, hnextCache⟩ + simp only + rw [← hstate, ← hremaining, ← htable, ← houtput] + simp only [runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hnextCache⟩ + +theorem relTriple_native_simulateQ_encode_roots + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (position : EncodingPosition) (counter : Nat) + (hposition : EncodingPositionNamesRoot target position) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (state : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + RelTriple + (runResolvedFromTable state fuel table + ((simulateQ ordinaryHashImpl + (encode parameter position.lay position.tree position.leafIdx leftRoot + (BitVec.ofNat counterBits counter))).run leftCache)) + (runResolvedFromTable state fuel table + ((simulateQ ordinaryHashImpl + (encode parameter position.lay position.tree position.leafIdx rightRoot + (BitVec.ofNat counterBits counter))).run rightCache)) + (RootEncodingNativeSameRel parameter target leftRoot rightRoot) := by + rw [← rootEncodingAttemptRun_eq_encode parameter position leftRoot counter leftCache, + ← rootEncodingAttemptRun_eq_encode parameter position rightRoot counter rightCache] + simpa [RootEncodingNativeAttemptRel, RootEncodingNativeSameRel] using + (relTriple_native_rootEncodingAttemptRun parameter target leftRoot rightRoot position counter + hposition leftCache rightCache hcache state fuel table) + +theorem rootEncodingNativeRelates_encode + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (position : EncodingPosition) (counter : Nat) + (hposition : EncodingPositionNamesRoot target position) : + RootEncodingNativeRelates parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl + (encode parameter position.lay position.tree position.leafIdx leftRoot + (BitVec.ofNat counterBits counter))) + (simulateQ ordinaryHashImpl + (encode parameter position.lay position.tree position.leafIdx rightRoot + (BitVec.ofNat counterBits counter))) := by + intro leftCache rightCache hcache state fuel table + exact relTriple_native_simulateQ_encode_roots parameter target leftRoot rightRoot position counter + hposition leftCache rightCache hcache state fuel table + +theorem rootEncodingNativeRelates_maskedOtsSignFrom + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) + (hposition : EncodingPositionNamesRoot target ⟨lay, tree, leafIdx⟩) : + ∀ attempts counter, + RootEncodingNativeRelates parameter target leftRoot rightRoot + (maskedOtsSignFrom parameter lay tree leafIdx leftRoot attempts counter) + (maskedOtsSignFrom parameter lay tree leafIdx rightRoot attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom, maskedOtsSignFrom] + exact (rootEncodingNativeCouples_pure parameter target leftRoot rightRoot none).relates + | attempts + 1, counter => by + rw [maskedOtsSignFrom, maskedOtsSignFrom] + apply (rootEncodingNativeRelates_encode parameter target leftRoot rightRoot + ⟨lay, tree, leafIdx⟩ counter hposition).bind + intro leftEncoded rightEncoded hencoded + subst rightEncoded + cases leftEncoded with + | none => + exact rootEncodingNativeRelates_maskedOtsSignFrom parameter target leftRoot rightRoot + lay tree leafIdx hposition attempts (counter + 1) + | some encoding => + exact ((rootEncodingNativeCouples_sequenceFin parameter target leftRoot rightRoot + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx (encoding chainIdx)) + (fun chainIdx => rootEncodingNativeCouples_ensureChainPrefix parameter target + leftRoot rightRoot lay tree leafIdx chainIdx (encoding chainIdx))).bind fun _ => + rootEncodingNativeCouples_pure parameter target leftRoot rightRoot + (some (BitVec.ofNat counterBits counter, encoding))).relates + +theorem rootEncodingNativeRelates_maskedOtsSign + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) + (hposition : EncodingPositionNamesRoot target ⟨lay, tree, leafIdx⟩) : + RootEncodingNativeRelates parameter target leftRoot rightRoot + (maskedOtsSign parameter lay tree leafIdx leftRoot) + (maskedOtsSign parameter lay tree leafIdx rightRoot) := + rootEncodingNativeRelates_maskedOtsSignFrom parameter target leftRoot rightRoot lay tree leafIdx + hposition encodingAttemptLimit 0 + + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootEncodingHash.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootEncodingHash.lean new file mode 100644 index 00000000..7e5f09ab --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootEncodingHash.lean @@ -0,0 +1,109 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootHashInput + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +theorem rootEncodingNativeCouples_splitHashQuery_avoids + (parameter : PublicParameter) (target : Position) (leftRoot rightRoot : Digest) + (input : HashInput) (havoid : RootInputAvoids parameter target leftRoot rightRoot input) : + RootEncodingNativeCouples parameter target leftRoot rightRoot (splitHashQuery (.ordinary input)) := by + intro leftCache rightCache hcache context fuel table + have hlookup := hcache.lookup_avoids input havoid + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + cases hleft : leftCache (.ordinary input) with + | some output => + have hright : rightCache (.ordinary input) = some output := hlookup.symm.trans hleft + simp only [hright, runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + | none => + have hright : rightCache (.ordinary input) = none := hlookup.symm.trans hleft + simp only [hright] + unfold LazyRevealProbe.hashOutputQuery + rw [runResolvedFromTable_hashOutput_query_bind, runResolvedFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + simp only [runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache.update_same_avoids input havoid leftOutput⟩ + +theorem rootEncodingNativeCouples_modifyOrdinary_avoids + (parameter : PublicParameter) (target : Position) (leftRoot rightRoot : Digest) + (input : HashInput) (havoid : RootInputAvoids parameter target leftRoot rightRoot input) (output : HashOutput) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (modify fun cache : SplitHashCache => Function.update cache (.ordinary input) (some output)) := by + intro leftCache rightCache hcache context fuel table + simp only [StateT.run_modify, runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache.update_same_avoids input havoid output⟩ + +theorem rootEncodingNativeCouples_peekTableInput + (parameter : PublicParameter) (target : Position) (leftRoot rightRoot : Digest) (coordinate : Coordinate) : + RootEncodingNativeCouples parameter target leftRoot rightRoot (peekTableInput parameter coordinate) := by + intro leftCache rightCache hcache context fuel table + rw [runResolvedFromTable_peekTableInput_eq_pure, runResolvedFromTable_peekTableInput_eq_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem rootEncodingNativeCouples_resolveKnownInput_avoids + (parameter : PublicParameter) (target : Position) (leftRoot rightRoot : Digest) + (coordinate : Coordinate) (input : HashInput) (havoid : RootInputAvoids parameter target leftRoot rightRoot input) : + RootEncodingNativeCouples parameter target leftRoot rightRoot (resolveKnownInput parameter coordinate input) := by + unfold resolveKnownInput + apply (rootEncodingNativeCouples_peekTableInput parameter target leftRoot rightRoot coordinate).bind + intro known + cases known with + | none => exact rootEncodingNativeCouples_splitHashQuery_avoids parameter target leftRoot rightRoot input havoid + | some known => + simp only + by_cases hmatch : known = input + · rw [if_pos hmatch] + exact (rootEncodingNativeCouples_revealCoordinateOutput parameter target leftRoot rightRoot coordinate).bind fun output => + (rootEncodingNativeCouples_publishCoordinate parameter target leftRoot rightRoot coordinate).bind fun _ => + (rootEncodingNativeCouples_modifyOrdinary_avoids parameter target leftRoot rightRoot input havoid output).bind fun _ => + rootEncodingNativeCouples_pure parameter target leftRoot rightRoot output + · rw [if_neg hmatch] + exact rootEncodingNativeCouples_splitHashQuery_avoids parameter target leftRoot rightRoot input havoid + +theorem rootEncodingNativeCouples_planProbingHashQuery + (parameter : PublicParameter) (target : Position) (leftRoot rightRoot : Digest) (input : HashInput) : + RootEncodingNativeCouples parameter target leftRoot rightRoot (planProbingHashQuery parameter input) := by + intro leftCache rightCache hcache context fuel table + rw [runResolved_planProbingHashQuery parameter input context.state context fuel table leftCache rfl, + runResolved_planProbingHashQuery parameter input context.state context fuel table rightCache rfl] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem rootEncodingNativeCouples_probe + (parameter : PublicParameter) (target : Position) (leftRoot rightRoot : Digest) (candidate : Probe) : + RootEncodingNativeCouples parameter target leftRoot rightRoot (probe candidate) := by + unfold probe + exact rootEncodingNativeCouples_worldStep parameter target leftRoot rightRoot _ _ fun _ _ _ h => ⟨rfl, h⟩ + +theorem rootEncodingNativeCouples_executeCandidate + (parameter : PublicParameter) (target : Position) (leftRoot rightRoot : Digest) (candidate : Option Probe) : + RootEncodingNativeCouples parameter target leftRoot rightRoot (executeCandidate? candidate) := by + cases candidate with + | none => exact rootEncodingNativeCouples_pure parameter target leftRoot rightRoot () + | some candidate => exact rootEncodingNativeCouples_probe parameter target leftRoot rightRoot candidate + +theorem rootEncodingNativeCouples_probingHashQueryAfterPlan_avoids + (parameter : PublicParameter) (target : Position) (leftRoot rightRoot : Digest) + (input : HashInput) (havoid : RootInputAvoids parameter target leftRoot rightRoot input) (plan : PlannedHashQuery) : + RootEncodingNativeCouples parameter target leftRoot rightRoot (probingHashQueryAfterPlan parameter input plan) := by + unfold probingHashQueryAfterPlan executePlannedHashQuery + apply (rootEncodingNativeCouples_executeCandidate parameter target leftRoot rightRoot plan.candidate?).bind + intro _ + cases plan.action with + | ordinary => exact rootEncodingNativeCouples_splitHashQuery_avoids parameter target leftRoot rightRoot input havoid + | resolve coordinate => exact rootEncodingNativeCouples_resolveKnownInput_avoids parameter target leftRoot rightRoot coordinate input havoid + +theorem rootEncodingNativeCouples_probingHashQuery_avoids + (parameter : PublicParameter) (target : Position) (leftRoot rightRoot : Digest) + (input : HashInput) (havoid : RootInputAvoids parameter target leftRoot rightRoot input) : + RootEncodingNativeCouples parameter target leftRoot rightRoot (probingHashQuery parameter input) := by + rw [probingHashQuery_eq_plan_then_afterPlan] + exact (rootEncodingNativeCouples_planProbingHashQuery parameter target leftRoot rightRoot input).bind + (rootEncodingNativeCouples_probingHashQueryAfterPlan_avoids parameter target leftRoot rightRoot input havoid) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootExposure.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootExposure.lean new file mode 100644 index 00000000..954b269f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootExposure.lean @@ -0,0 +1,127 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootUnsafeAction + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem nativeRootActionSafe_target_failure_input + (parameter : PublicParameter) (target : Position) (before after : HashOutput) (input : HashInput) + (left right : DeferredContext) (hcontext : NativeRootContextRel target before after left right) + (hunsafe : ¬NativeRootActionSafe parameter target input left right (.resolve (.position target))) : + purePeekTableInput parameter left.state (.position target) = some input := by + have hnot : target ∉ target.children := fun hmem => Nat.lt_irrefl _ (Position.depth_lt_of_mem_children hmem) + have heq := hcontext.purePeekTableInput_eq_of_not_mem_children parameter target hnot + by_contra hleft + apply hunsafe + exact Or.inr ⟨hleft, by rw [← heq]; exact hleft⟩ + +theorem published_of_mem_runResolved_publish_then + (coordinate : Coordinate) (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hresult : some result ∈ support (runResolvedFromTable context fuel table + (LazyRevealProbe.publishQuery coordinate >>= next))) : + coordinate ∈ result.context.state.revealed := by + rw [LazyRevealProbe.publishQuery, runResolvedFromTable_publish_query_bind] at hresult + apply revealed_subset_of_mem_runResolvedFromTable _ _ fuel table result hresult + exact Finset.mem_insert_self _ _ + +theorem published_of_mem_runResolved_resolveKnownInput_of_match + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hmatch : purePeekTableInput parameter context.state coordinate = some input) + (result : ResolvedRunResult (HashOutput × SplitHashCache)) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table ((resolveKnownInput parameter coordinate input).run cache))) : + coordinate ∈ result.context.state.revealed := by + rw [runResolvedFromTable_resolveKnownInput_eq_public] at hresult + simp only [resolvePublicKnownInput, hmatch, ↓reduceIte] at hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨middle, hmiddle, htail⟩ := hresult + cases middle with + | none => simp at htail + | some middle => + simp only [StateT.run_bind, publishCoordinate, StateT.run_liftM, bind_assoc, pure_bind] at htail + exact published_of_mem_runResolved_publish_then coordinate _ middle.context middle.remaining middle.table result htail + +theorem nativeRootHash_target_action_failure_publishes + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) (before after : HashOutput) + (input : HashInput) (left right : DeferredContext) (hcontext : NativeRootContextRel target before after left right) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (haction : (purePlanProbingHashQuery parameter input left.state).action = .resolve (.position target)) + (hunsafe : ¬NativeRootActionSafe parameter target input left right (.resolve (.position target))) + (result : ResolvedRunResult (HashOutput × SplitHashCache)) + (hresult : some result ∈ support (runResolvedFromTable left fuel table ((probingHashQuery parameter input).run cache))) : + .position target ∈ result.context.state.revealed := by + have hmatch := nativeRootActionSafe_target_failure_input parameter target before after input left right hcontext hunsafe + have hnone : (purePlanProbingHashQuery parameter input left.state).candidate? = none := by + obtain ⟨lay, tree, rfl⟩ := hroot + unfold layerRootPosition at hmatch + apply purePlanProbingHashQuery_candidate_none_of_known_node parameter input left.state lay tree _ _ + (purePeekTableInput_node_some_atPosition parameter left.state lay tree _ _ input hmatch) + rw [hmatch] + simp + rw [runResolved_probingHashQuery_eq_afterPlan] at hresult + simp only [probingHashQueryAfterPlan, executePlannedHashQuery, hnone, executeCandidate?, pure_bind, haction] at hresult + exact published_of_mem_runResolved_resolveKnownInput_of_match parameter (.position target) input left fuel table cache hmatch result hresult + +theorem nativeRootHashSafe_failure_of_hidden_result + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) (before after : HashOutput) + (input : HashInput) (context : DeferredContext) (h : NativePositionReplaceable target before after context) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hunsafe : ¬NativeRootHashSafe parameter target before after input context) + (result : ResolvedRunResult (HashOutput × SplitHashCache)) + (hresult : some result ∈ support (runResolvedFromTable context fuel table ((probingHashQuery parameter input).run cache))) + (hhidden : .position target ∉ result.context.state.revealed) : + (EncodingInputGuessesRoot parameter target (truncateHash before) input ∨ + EncodingInputGuessesRoot parameter target (truncateHash after) input) ∨ + (∃ candidate, (purePlanProbingHashQuery parameter input context.state).candidate? = some candidate ∧ + IsPrivateValueExposure target before after (.probe candidate.coordinate candidate.candidate)) ∨ + KnownHiddenStructuralRootQuery parameter input context := by + have hinitial : .position target ∉ context.state.revealed := fun hmem => + hhidden (revealed_subset_of_mem_runResolvedFromTable _ context fuel table result hresult hmem) + have hfailure := nativeRootHashSafe_failure_classify parameter target before after input context hunsafe + rw [h.replace_self] at hfailure + rcases hfailure with hencoding | hprobe | haction + · apply Or.inl + by_cases hleft : EncodingInputGuessesRoot parameter target (truncateHash before) input + · exact Or.inl hleft + · apply Or.inr + by_contra hright + exact hencoding ⟨hleft, hright⟩ + · exact Or.inr (Or.inl hprobe) + · rcases nativeRootActionSafe_failure_exposure_or_structuralCharge parameter target hroot before after input _ + context (replaceNativePosition target after context) ⟨h, rfl⟩ hinitial haction with htarget | hstructural + · rw [htarget] at haction + exact False.elim (hhidden (nativeRootHash_target_action_failure_publishes parameter target hroot before after input + context (replaceNativePosition target after context) ⟨h, rfl⟩ fuel table cache htarget haction result hresult)) + · exact Or.inr (Or.inr hstructural) + +theorem nativeRootHashSafe_failure_of_hidden_continuation + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) (before after : HashOutput) + (input : HashInput) (context : DeferredContext) (h : NativePositionReplaceable target before after context) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (next : HashOutput → StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hunsafe : ¬NativeRootHashSafe parameter target before after input context) + (result : ResolvedRunResult (α × SplitHashCache)) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table ((probingHashQuery parameter input >>= next).run cache))) + (hhidden : .position target ∉ result.context.state.revealed) : + (EncodingInputGuessesRoot parameter target (truncateHash before) input ∨ + EncodingInputGuessesRoot parameter target (truncateHash after) input) ∨ + (∃ candidate, (purePlanProbingHashQuery parameter input context.state).candidate? = some candidate ∧ + IsPrivateValueExposure target before after (.probe candidate.coordinate candidate.candidate)) ∨ + KnownHiddenStructuralRootQuery parameter input context := by + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨middle, hmiddle, htail⟩ := hresult + cases middle with + | none => simp at htail + | some middle => + apply nativeRootHashSafe_failure_of_hidden_result parameter target hroot before after input context h fuel table cache + hunsafe middle hmiddle + intro hmem + exact hhidden (revealed_subset_of_mem_runResolvedFromTable _ _ _ _ result htail hmem) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootFirstMatch.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootFirstMatch.lean new file mode 100644 index 00000000..0d3efb41 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootFirstMatch.lean @@ -0,0 +1,138 @@ +import SphincsSecurity.Proof.OtsProbeNativeTraceCompletion + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem nativeRootSelectionGuess_some_iff + (parameter : PublicParameter) (target : Position) (selection : CanonicalQuerySelection) (guess : Digest) : + nativeRootSelectionGuess? parameter target selection = some guess ↔ + ∃ input candidate, selection.input = .inl (.inr input) ∧ + NativeRootCandidateAt parameter input selection.context candidate ∧ + candidate.coordinate = .position target ∧ candidate.candidate = guess := by + cases hinput : selection.input with + | inl query => + cases query with + | inl n => simp [nativeRootSelectionGuess?, nativeRootSelectionCandidate?, hinput] + | inr input => + simp only [nativeRootSelectionGuess?, nativeRootSelectionCandidate?, hinput] + change (nativeRootCandidate? parameter input selection.context).bind + (fun candidate => if candidate.coordinate = .position target then some candidate.candidate else none) = some guess ↔ _ + cases hcand : nativeRootCandidate? parameter input selection.context with + | none => + simp only [Option.bind_none, reduceCtorEq, false_iff] + rintro ⟨otherInput, candidate, heq, hat, _, _⟩ + cases heq + rw [(nativeRootCandidate?_eq_some_iff parameter input selection.context candidate).mpr hat] at hcand + contradiction + | some candidate => + have hat := (nativeRootCandidate?_eq_some_iff parameter input selection.context candidate).mp hcand + constructor + · intro hguess + simp only [Option.bind_some] at hguess + split_ifs at hguess with hcoordinate + · exact ⟨input, candidate, rfl, hat, hcoordinate, Option.some.inj hguess⟩ + · rintro ⟨otherInput, other, heq, hother, hcoordinate, hguess⟩ + cases heq + have heq := nativeRootCandidateAt_unique hat hother + subst other + simp [hcoordinate, hguess] + | inr message => simp [nativeRootSelectionGuess?, nativeRootSelectionCandidate?, hinput] + +theorem nativeRootCandidateHistory_first_match + (parameter : PublicParameter) (target : Position) (history : List CanonicalQuerySelection) + (guess : Digest) (hmatch : guess ∈ nativeRootCandidateHistory parameter target history) : + ∃ prior selection suffix, history = prior ++ selection :: suffix ∧ + guess ∉ nativeRootCandidateHistory parameter target prior ∧ + nativeRootSelectionGuess? parameter target selection = some guess := by + induction history with + | nil => simp [nativeRootCandidateHistory, nativeHashQueryHistory] at hmatch + | cons selection history ih => + by_cases hhead : nativeRootSelectionGuess? parameter target selection = some guess + · exact ⟨[], selection, history, rfl, by simp [nativeRootCandidateHistory, nativeHashQueryHistory], hhead⟩ + · have htail : guess ∈ nativeRootCandidateHistory parameter target history := by + rw [nativeRootCandidateHistory_cons] at hmatch + cases hg : nativeRootSelectionGuess? parameter target selection <;> simp_all [insertNativeRootGuess, eq_comm] + obtain ⟨prior, selected, suffix, rfl, hbefore, hselected⟩ := ih htail + refine ⟨selection :: prior, selected, suffix, rfl, ?_, hselected⟩ + rw [nativeRootCandidateHistory_cons] + cases hg : nativeRootSelectionGuess? parameter target selection <;> simp_all [insertNativeRootGuess, eq_comm] + +theorem ChargedNativeRootQuery.candidate_known + {parameter : PublicParameter} {input : HashInput} {context : DeferredContext} {candidate : Probe} + (hcharged : ChargedNativeRootQuery parameter input context) + (hcandidate : NativeRootCandidateAt parameter input context candidate) (target : Position) + (hcoordinate : candidate.coordinate = .position target) : + ∃ output, context.positionValue target = some output := by + rcases hcharged with hstructural | hencoding + · have hquery := hstructural + obtain ⟨parent, knownTarget, hat, hroot, hmem, _, hknown⟩ := hstructural + have hstruct : StructuralLayerRootCandidateAt parameter input + ⟨.position knownTarget, slotDigest (parent.children.idxOf knownTarget) input⟩ := + ⟨parent, knownTarget, hat, hroot, hmem, rfl⟩ + have heq := nativeRootCandidateAt_unique hcandidate + (Or.inr (Or.inr ⟨hquery, hstruct⟩)) + have htarget : target = knownTarget := Coordinate.position.inj (hcoordinate.symm.trans (congrArg Probe.coordinate heq)) + subst target + obtain ⟨lay, tree, level, nodeIdx, rfl⟩ := exists_node_of_layerRoot_mem_children hroot hmem + have hchildren : purePeekPositionValues context.state (Position.node lay tree level nodeIdx).children ≠ none := by + intro hnone + exact hknown (by simp [purePeekTableInput, hnone]) + cases hstate : context.state.values (.position knownTarget) with + | none => exact False.elim (hchildren ((purePeekPositionValues_eq_none_iff_missing _ _).mpr ⟨knownTarget, hmem, hstate⟩)) + | some output => exact ⟨output, by simp [DeferredContext.positionValue, hstate]⟩ + · obtain ⟨encoding, knownTarget, output, hat, hposition, hknown, _⟩ := hencoding.known + have heq := nativeRootCandidateAt_unique hcandidate (Or.inr (Or.inl hat)) + have htarget : target = knownTarget := Coordinate.position.inj + (hcoordinate.symm.trans ((congrArg Probe.coordinate heq).trans hposition)) + subst target + exact ⟨output, hknown⟩ + +theorem nativeTrace_rootHistoryMatch_firstCharged + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) (history : List CanonicalQuerySelection) + (completion : Coordinate → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hmat : LayerRootsMaterialized context) (hclosed : DeferredComputationsClosed context) + (hresult : (some result, history) ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) + (hcompletion : DeferredCompletion table result.context completion) + (hsource : ¬UnknownSourceFinalRootMatch parameter (some result, history)) + (lay : Layer) (tree : TreeIndex) (output : HashOutput) + (hvalue : result.context.positionValue (layerRootPosition lay tree) = some output) + (hhidden : .position (layerRootPosition lay tree) ∉ result.context.state.revealed) + (hmatch : truncateHash output ∈ nativeRootCandidateHistory parameter (layerRootPosition lay tree) history) : + ∃ prior selection suffix, history = prior ++ selection :: suffix ∧ + truncateHash output ∉ nativeRootCandidateHistory parameter (layerRootPosition lay tree) prior ∧ + selection.context.positionValue (layerRootPosition lay tree) = some output ∧ + .position (layerRootPosition lay tree) ∉ selection.context.state.revealed ∧ + chargedNativeRootQueryCandidate parameter (layerRootPosition lay tree) selection.input selection.context = some (truncateHash output) := by + obtain ⟨prior, selection, suffix, hhistory, hprior, hguess⟩ := + nativeRootCandidateHistory_first_match parameter (layerRootPosition lay tree) history (truncateHash output) hmatch + have hmem : selection ∈ history := by rw [hhistory]; simp + obtain ⟨i, hi⟩ := List.mem_iff_get.mp hmem + obtain ⟨input, candidate, hinput, hcandidate, hcoordinate, hguess⟩ := + (nativeRootSelectionGuess_some_iff parameter (layerRootPosition lay tree) selection (truncateHash output)).mp hguess + have hselectionMat := (layerRootsMaterialized_runNativeQueryTrace parameter root ftsSecret computation context fuel table cache + (some result, history) hmat hclosed hresult).2 selection hmem + have hcharged := nativeTrace_matchingFinalRoot_charged parameter root ftsSecret computation context fuel table cache result history completion + hconsistent hstarts hresult hcompletion hsource i input candidate lay tree output + (by simpa only [hi] using hinput) (by simpa only [hi] using hcandidate) hcoordinate hvalue hguess hhidden + (by simpa only [hi] using hselectionMat) + rw [hi] at hcharged + have hfacts := (nativeTrace_completion_facts parameter root ftsSecret computation context fuel table cache result history completion + hconsistent hstarts hresult hcompletion).2 selection hmem + obtain ⟨stored, hstored⟩ := hcharged.candidate_known hcandidate (layerRootPosition lay tree) hcoordinate + have heq : stored = output := (hfacts.2.2.1.eq_positionValue _ stored hstored).symm.trans + (hcompletion.eq_positionValue _ output hvalue) + subst stored + refine ⟨prior, selection, suffix, hhistory, hprior, hstored, fun h => hhidden (hfacts.2.2.2 h), ?_⟩ + rw [hinput] + simp [chargedNativeRootQueryCandidate, hcharged, + (nativeRootCandidate?_eq_some_iff parameter input selection.context candidate).mpr hcandidate, hcoordinate, hguess] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootHashAction.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootHashAction.lean new file mode 100644 index 00000000..a007ab79 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootHashAction.lean @@ -0,0 +1,112 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootEncodingHash + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +theorem runResolvedFromTable_resolveKnownInput_eq_public + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runResolvedFromTable context fuel table ((resolveKnownInput parameter coordinate input).run cache) = + runResolvedFromTable context fuel table ((resolvePublicKnownInput parameter context.state coordinate input).run cache) := by + rw [resolveKnownInput, StateT.run_bind, runResolvedFromTable_bind, runResolvedFromTable_peekTableInput_eq_pure] + simp only [pure_bind] + rfl + +theorem nativeRootRelates_resolvePublicKnownInput_of_ne + (parameter : PublicParameter) (target : Position) (before after : HashOutput) + (publicState : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) (hne : coordinate ≠ .position target) + (input : HashInput) : + NativeRootRelates target before after + (resolvePublicKnownInput parameter publicState coordinate input) (resolvePublicKnownInput parameter publicState coordinate input) := by + unfold resolvePublicKnownInput + cases hknown : purePeekTableInput parameter publicState coordinate with + | none => exact nativeRootRelates_splitHashQuery_ordinary target before after input + | some knownInput => + simp only + by_cases hmatch : knownInput = input + · rw [if_pos hmatch] + apply (nativeRootRelates_revealCoordinateOutput_of_ne target before after coordinate hne).bind + intro leftOutput rightOutput heq + subst rightOutput + apply (nativeRootRelates_publishCoordinate target before after coordinate).bind + intro _ _ _ + apply (nativeRootRelates_modifyOrdinary target before after input leftOutput).bind + intro _ _ _ + exact nativeRootRelates_pure target before after leftOutput + · rw [if_neg hmatch] + exact nativeRootRelates_splitHashQuery_ordinary target before after input + +theorem relTriple_nativeRoot_resolveKnownInput_of_eq + (parameter : PublicParameter) (target : Position) (before after : HashOutput) (coordinate : Coordinate) (input : HashInput) + (left right : DeferredContext) (hcontext : NativeRootContextRel target before after left right) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target before after leftCache rightCache) + (hne : coordinate ≠ .position target) + (heq : purePeekTableInput parameter left.state coordinate = purePeekTableInput parameter right.state coordinate) : + RelTriple + (runResolvedFromTable left fuel table ((resolveKnownInput parameter coordinate input).run leftCache)) + (runResolvedFromTable right fuel table ((resolveKnownInput parameter coordinate input).run rightCache)) + (NativeRootSameRel target before after) := by + rw [runResolvedFromTable_resolveKnownInput_eq_public, runResolvedFromTable_resolveKnownInput_eq_public] + have hcomp : resolvePublicKnownInput parameter left.state coordinate input = + resolvePublicKnownInput parameter right.state coordinate input := by + unfold resolvePublicKnownInput + rw [heq] + rw [← hcomp] + exact nativeRootRelates_resolvePublicKnownInput_of_ne parameter target before after left.state coordinate hne input + left right hcontext fuel table leftCache rightCache hcache + +def NativeRootActionSafe (parameter : PublicParameter) (target : Position) (input : HashInput) + (left right : DeferredContext) : PlannedHashAction → Prop + | .ordinary => True + | .resolve coordinate => + (coordinate ≠ .position target ∧ + purePeekTableInput parameter left.state coordinate = purePeekTableInput parameter right.state coordinate) ∨ + (purePeekTableInput parameter left.state coordinate ≠ some input ∧ + purePeekTableInput parameter right.state coordinate ≠ some input) + +theorem NativeRootActionSafe.of_values_eq + {parameter : PublicParameter} {target : Position} {input : HashInput} + {left right newLeft newRight : DeferredContext} {action : PlannedHashAction} + (h : NativeRootActionSafe parameter target input left right action) + (hleft : newLeft.state.values = left.state.values) (hright : newRight.state.values = right.state.values) : + NativeRootActionSafe parameter target input newLeft newRight action := by + cases action with + | ordinary => trivial + | resolve coordinate => + have hl := purePeekTableInput_eq_of_values_eq parameter hleft coordinate + have hr := purePeekTableInput_eq_of_values_eq parameter hright coordinate + simpa only [NativeRootActionSafe, hl, hr] using h + +theorem relTriple_nativeRoot_hashAction_of_safe + (parameter : PublicParameter) (target : Position) (before after : HashOutput) (input : HashInput) (action : PlannedHashAction) + (left right : DeferredContext) (hcontext : NativeRootContextRel target before after left right) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target before after leftCache rightCache) + (hsafe : NativeRootActionSafe parameter target input left right action) : + RelTriple + (runResolvedFromTable left fuel table + ((match action with + | .ordinary => splitHashQuery (.ordinary input) + | .resolve coordinate => resolveKnownInput parameter coordinate input).run leftCache)) + (runResolvedFromTable right fuel table + ((match action with + | .ordinary => splitHashQuery (.ordinary input) + | .resolve coordinate => resolveKnownInput parameter coordinate input).run rightCache)) + (NativeRootSameRel target before after) := by + cases action with + | ordinary => + exact nativeRootRelates_splitHashQuery_ordinary target before after input + left right hcontext fuel table leftCache rightCache hcache + | resolve coordinate => + rcases hsafe with ⟨hne, heq⟩ | ⟨hleft, hright⟩ + · exact relTriple_nativeRoot_resolveKnownInput_of_eq parameter target before after coordinate input + left right hcontext fuel table leftCache rightCache hcache hne heq + · exact relTriple_nativeRoot_resolveKnownInput_of_miss parameter target before after coordinate input + left right hcontext fuel table leftCache rightCache hcache hleft hright + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootHashInput.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootHashInput.lean new file mode 100644 index 00000000..5163d5cc --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootHashInput.lean @@ -0,0 +1,118 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootProbe + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +theorem relTriple_nativeRoot_peekTableInput_of_eq + (parameter : PublicParameter) (target : Position) (before after : HashOutput) (coordinate : Coordinate) + (left right : DeferredContext) (hcontext : NativeRootContextRel target before after left right) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target before after leftCache rightCache) + (hinput : purePeekTableInput parameter left.state coordinate = purePeekTableInput parameter right.state coordinate) : + RelTriple + (runResolvedFromTable left fuel table ((peekTableInput parameter coordinate).run leftCache)) + (runResolvedFromTable right fuel table ((peekTableInput parameter coordinate).run rightCache)) + (NativeRootSameRel target before after) := by + rw [runResolvedFromTable_peekTableInput_eq_pure, runResolvedFromTable_peekTableInput_eq_pure] + exact relTriple_pure_pure ⟨hcontext, rfl, rfl, hinput, hcache⟩ + +theorem nativeRootRelates_peekTableInput_of_not_mem_children + (parameter : PublicParameter) (target : Position) (before after : HashOutput) + (position : Position) (hnot : target ∉ position.children) : + NativeRootRelates target before after + (peekTableInput parameter (.position position)) (peekTableInput parameter (.position position)) := by + intro left right hcontext fuel table leftCache rightCache hcache + exact relTriple_nativeRoot_peekTableInput_of_eq parameter target before after (.position position) + left right hcontext fuel table leftCache rightCache hcache + (hcontext.purePeekTableInput_eq_of_not_mem_children parameter position hnot) + +theorem nativeRootRelates_revealCoordinateOutput_of_ne + (target : Position) (before after : HashOutput) (coordinate : Coordinate) + (hne : coordinate ≠ .position target) : + NativeRootRelates target before after (revealCoordinateOutput coordinate) (revealCoordinateOutput coordinate) := by + intro left right hcontext fuel table leftCache rightCache hcache + apply relTriple_post_mono + (relTriple_nativeRoot_revealCoordinateOutput target before after coordinate + left right hcontext fuel table leftCache rightCache hcache) + intro leftResult rightResult hrel + cases leftResult with + | none => + cases rightResult with + | none => trivial + | some rightResult => contradiction + | some leftResult => + cases rightResult with + | none => contradiction + | some rightResult => + rcases hrel with ⟨hcontext, hfuel, htable, hvalue, _, hcache⟩ + exact ⟨hcontext, hfuel, htable, (by simpa [hne] using hvalue.symm), hcache⟩ + +theorem nativeRootRelates_modifyOrdinary + (target : Position) (before after : HashOutput) (input : HashInput) (output : HashOutput) : + NativeRootRelates target before after + (modify fun cache : SplitHashCache => Function.update cache (.ordinary input) (some output)) + (modify fun cache : SplitHashCache => Function.update cache (.ordinary input) (some output)) := by + intro left right hcontext fuel table leftCache rightCache hcache + simp only [StateT.run_modify, runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hcontext, rfl, rfl, rfl, hcache.update_same_ordinary input output⟩ + +theorem nativeRootRelates_resolveKnownInput_of_not_mem_children + (parameter : PublicParameter) (target : Position) (before after : HashOutput) + (position : Position) (hnot : target ∉ position.children) (hne : position ≠ target) (input : HashInput) : + NativeRootRelates target before after + (resolveKnownInput parameter (.position position) input) (resolveKnownInput parameter (.position position) input) := by + unfold resolveKnownInput + apply (nativeRootRelates_peekTableInput_of_not_mem_children parameter target before after position hnot).bind + intro left right heq + subst right + cases left with + | none => exact nativeRootRelates_splitHashQuery_ordinary target before after input + | some knownInput => + simp only + by_cases hmatch : knownInput = input + · rw [if_pos hmatch] + apply (nativeRootRelates_revealCoordinateOutput_of_ne target before after (.position position) (by simpa using hne)).bind + intro leftOutput rightOutput heq + subst rightOutput + apply (nativeRootRelates_publishCoordinate target before after (.position position)).bind + intro _ _ _ + apply (nativeRootRelates_modifyOrdinary target before after input leftOutput).bind + intro _ _ _ + exact nativeRootRelates_pure target before after leftOutput + · rw [if_neg hmatch] + exact nativeRootRelates_splitHashQuery_ordinary target before after input + +theorem runResolvedFromTable_resolveKnownInput_of_miss + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hmiss : purePeekTableInput parameter context.state coordinate ≠ some input) : + runResolvedFromTable context fuel table ((resolveKnownInput parameter coordinate input).run cache) = + runResolvedFromTable context fuel table ((splitHashQuery (.ordinary input)).run cache) := by + rw [resolveKnownInput, StateT.run_bind, runResolvedFromTable_bind, runResolvedFromTable_peekTableInput_eq_pure] + simp only [pure_bind] + cases hknown : purePeekTableInput parameter context.state coordinate with + | none => rfl + | some knownInput => + have hne : knownInput ≠ input := by intro heq; exact hmiss (hknown.trans (congrArg some heq)) + simp only [if_neg hne] + +theorem relTriple_nativeRoot_resolveKnownInput_of_miss + (parameter : PublicParameter) (target : Position) (before after : HashOutput) (coordinate : Coordinate) (input : HashInput) + (left right : DeferredContext) (hcontext : NativeRootContextRel target before after left right) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target before after leftCache rightCache) + (hleft : purePeekTableInput parameter left.state coordinate ≠ some input) + (hright : purePeekTableInput parameter right.state coordinate ≠ some input) : + RelTriple + (runResolvedFromTable left fuel table ((resolveKnownInput parameter coordinate input).run leftCache)) + (runResolvedFromTable right fuel table ((resolveKnownInput parameter coordinate input).run rightCache)) + (NativeRootSameRel target before after) := by + rw [runResolvedFromTable_resolveKnownInput_of_miss parameter coordinate input left fuel table leftCache hleft, + runResolvedFromTable_resolveKnownInput_of_miss parameter coordinate input right fuel table rightCache hright] + exact nativeRootRelates_splitHashQuery_ordinary target before after input left right hcontext fuel table leftCache rightCache hcache + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootHashPlan.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootHashPlan.lean new file mode 100644 index 00000000..d2471189 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootHashPlan.lean @@ -0,0 +1,77 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootHashAction + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem NativeRootContextRel.afterCandidate + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) (candidate : Option Probe) + (hsafe : ∀ value, candidate = some value → + ¬IsPrivateValueExposure target before after (.probe value.coordinate value.candidate)) : + NativeRootContextRel target before after (afterCandidateContext left candidate) (afterCandidateContext right candidate) := by + cases candidate with + | none => exact h + | some candidate => + simp only [afterCandidateContext, ← h.revealed_eq] + by_cases hrevealed : candidate.coordinate ∈ left.state.revealed + · rw [if_pos hrevealed, if_pos hrevealed] + exact h + · rw [if_neg hrevealed, if_neg hrevealed] + exact h.addPending candidate.coordinate candidate.candidate (hsafe candidate rfl) + +theorem relTriple_nativeRoot_probingHashQueryAfterPlan_of_safe + (parameter : PublicParameter) (target : Position) (before after : HashOutput) (input : HashInput) (plan : PlannedHashQuery) + (left right : DeferredContext) (hcontext : NativeRootContextRel target before after left right) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target before after leftCache rightCache) + (hprobe : ∀ candidate, plan.candidate? = some candidate → + ¬IsPrivateValueExposure target before after (.probe candidate.coordinate candidate.candidate)) + (haction : NativeRootActionSafe parameter target input left right plan.action) : + RelTriple + (runResolvedFromTable left fuel table ((probingHashQueryAfterPlan parameter input plan).run leftCache)) + (runResolvedFromTable right fuel table ((probingHashQueryAfterPlan parameter input plan).run rightCache)) + (NativeRootSameRel target before after) := by + unfold probingHashQueryAfterPlan executePlannedHashQuery + rw [StateT.run_bind, StateT.run_bind, runResolvedFromTable_bind, runResolvedFromTable_bind] + cases fuel with + | zero => + rw [runResolvedFromTable_executeCandidate_zero, runResolvedFromTable_executeCandidate_zero] + by_cases hsome : plan.candidate?.isSome + · rw [if_pos hsome, if_pos hsome] + exact relTriple_pure_pure trivial + · rw [if_neg hsome, if_neg hsome] + simp only [pure_bind] + exact relTriple_nativeRoot_hashAction_of_safe parameter target before after input plan.action + left right hcontext 0 table leftCache rightCache hcache haction + | succ fuel => + rw [runResolvedFromTable_executeCandidate_positive, runResolvedFromTable_executeCandidate_positive] + simp only [pure_bind] + exact relTriple_nativeRoot_hashAction_of_safe parameter target before after input plan.action + (afterCandidateContext left plan.candidate?) (afterCandidateContext right plan.candidate?) + (hcontext.afterCandidate plan.candidate? hprobe) _ table leftCache rightCache hcache + (haction.of_values_eq (afterCandidateContext_values left plan.candidate?) (afterCandidateContext_values right plan.candidate?)) + +theorem relTriple_nativeRoot_probingHashQuery_of_safe + (parameter : PublicParameter) (target : Position) (before after : HashOutput) (input : HashInput) + (left right : DeferredContext) (hcontext : NativeRootContextRel target before after left right) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target before after leftCache rightCache) + (hprobe : ∀ candidate, (purePlanProbingHashQuery parameter input left.state).candidate? = some candidate → + ¬IsPrivateValueExposure target before after (.probe candidate.coordinate candidate.candidate)) + (haction : NativeRootActionSafe parameter target input left right + (purePlanProbingHashQuery parameter input left.state).action) : + RelTriple + (runResolvedFromTable left fuel table ((probingHashQuery parameter input).run leftCache)) + (runResolvedFromTable right fuel table ((probingHashQuery parameter input).run rightCache)) + (NativeRootSameRel target before after) := by + rw [runResolved_probingHashQuery_eq_afterPlan, runResolved_probingHashQuery_eq_afterPlan, + ← purePlanProbingHashQuery_eq_of_nativeRootContextRel hcontext] + exact relTriple_nativeRoot_probingHashQueryAfterPlan_of_safe parameter target before after input _ + left right hcontext fuel table leftCache rightCache hcache hprobe haction + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootHistoryObserver.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootHistoryObserver.lean new file mode 100644 index 00000000..acf4666b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootHistoryObserver.lean @@ -0,0 +1,184 @@ +import SphincsSecurity.Proof.OtsProbeMaterializedRootReserve + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem nativeRootCandidate_eq_of_visible_state_eq + (parameter : PublicParameter) (input : HashInput) (left right : DeferredContext) + (hvalues : left.state.values = right.state.values) (hrevealed : left.state.revealed = right.state.revealed) : + nativeRootCandidate? parameter input left = nativeRootCandidate? parameter input right := by + have hplan := purePlanProbingHashQuery_eq_of_value_presence left.state right.state + (fun coordinate => congrArg Option.isSome (congrFun hvalues coordinate)) parameter input + have hstruct : KnownHiddenStructuralRootQuery parameter input left ↔ KnownHiddenStructuralRootQuery parameter input right := by + unfold KnownHiddenStructuralRootQuery + simp only [hrevealed, purePeekTableInput_eq_of_values_eq parameter hvalues] + have hat (candidate : Probe) : NativeRootCandidateAt parameter input left candidate ↔ NativeRootCandidateAt parameter input right candidate := by + simp only [NativeRootCandidateAt, hplan, hstruct] + cases hleft : nativeRootCandidate? parameter input left with + | none => + cases hright : nativeRootCandidate? parameter input right with + | none => rfl + | some candidate => + have heq := (nativeRootCandidate?_eq_some_iff parameter input left candidate).mpr + ((hat candidate).mpr ((nativeRootCandidate?_eq_some_iff parameter input right candidate).mp hright)) + rw [hleft] at heq + contradiction + | some candidate => + exact ((nativeRootCandidate?_eq_some_iff parameter input right candidate).mpr + ((hat candidate).mp ((nativeRootCandidate?_eq_some_iff parameter input left candidate).mp hleft))).symm + +theorem nativeRootSelectionGuess_resolvePositionValue + (parameter : PublicParameter) (target position : Position) (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : DeferredResolution) (hresult : some result ∈ support (resolveDeferredPositionValue position context)) : + nativeRootSelectionGuess? parameter target ⟨input, result.toDeferredContext, fuel, table, cache⟩ = + nativeRootSelectionGuess? parameter target ⟨input, context, fuel, table, cache⟩ := by + have hvalues := resolveDeferredPositionValue_preserves_state_values position context result hresult + have hstate := resolveDeferredPositionValue_state_eq_clearPending position context result hresult + have hrevealed : result.state.revealed = context.state.revealed := by rw [hstate]; rfl + unfold nativeRootSelectionGuess? nativeRootSelectionCandidate? + cases input with + | inl query => + cases query with + | inl n => rfl + | inr input => simp only [nativeRootCandidate_eq_of_visible_state_eq parameter input _ _ hvalues hrevealed] + | inr message => rfl + +noncomputable def runNativeRootHistoryObserve + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → (α × SplitHashCache) → Finset Digest → ProbComp Bool) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + DeferredContext → Nat → SplitHashCache → Finset Digest → ProbComp Bool := + OracleComp.construct + (fun value context fuel cache history => + if DeferredCompletable table context then + privateResolutionObserve target table (fun final remaining value => observe final remaining (value, cache) history) context fuel value + else pure true) + (fun input _ next context fuel cache history => + if DeferredCompletable table context then + runResolvedObserve + (fun final remaining value => next value.1 final remaining value.2 + (insertNativeRootGuess (nativeRootSelectionGuess? parameter target ⟨input, context, fuel, table, cache⟩) history)) + context fuel table ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) + else pure true) computation + +theorem runNativeRootHistoryObserve_of_not_completable + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → (α × SplitHashCache) → Finset Digest → ProbComp Bool) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (history : Finset Digest) + (hnot : ¬DeferredCompletable table context) : + runNativeRootHistoryObserve parameter root target ftsSecret table observe computation context fuel cache history = pure true := by + induction computation using OracleComp.inductionOn with + | pure value => simp only [runNativeRootHistoryObserve, OracleComp.construct_pure, hnot, ↓reduceIte] + | query_bind input next _ => simp only [runNativeRootHistoryObserve, OracleComp.construct_query_bind, hnot, ↓reduceIte] + +theorem evalDist_runNativeRootHistoryObserve_query + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → (α × SplitHashCache) → Finset Digest → ProbComp Bool) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (history : Finset Digest) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + evalDist (runNativeRootHistoryObserve parameter root target ftsSecret table observe (OracleSpec.query input >>= next) context fuel cache history) = + evalDist (runResolvedObserve + (fun final remaining value => runNativeRootHistoryObserve parameter root target ftsSecret table observe (next value.1) final remaining value.2 + (insertNativeRootGuess (nativeRootSelectionGuess? parameter target ⟨input, context, fuel, table, cache⟩) history)) + context fuel table ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache)) := by + simp only [runNativeRootHistoryObserve, OracleComp.construct_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete] + · rw [if_neg hcomplete] + symm + apply evalDist_runResolvedObserve_eq_true_of_not_completable _ context fuel table _ hconsistent hstarts hcomplete + intro final remaining value _ _ hnot + exact congrArg evalDist (runNativeRootHistoryObserve_of_not_completable parameter root target ftsSecret table observe + (next value.1) final remaining value.2 _ hnot) + +theorem evalDist_runNativeRootHistoryObserve_pure + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → (α × SplitHashCache) → Finset Digest → ProbComp Bool) (value : α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (history : Finset Digest) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + evalDist (runNativeRootHistoryObserve parameter root target ftsSecret table observe (pure value) context fuel cache history) = + evalDist (privateResolutionObserve target table (fun final remaining value => observe final remaining (value, cache) history) context fuel value) := by + simp only [runNativeRootHistoryObserve, OracleComp.construct_pure] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete] + · rw [if_neg hcomplete] + exact (ObserverDooms.eq_true context fuel value hconsistent hstarts hcomplete).symm + +theorem runNativeRootHistoryObserve_neutral + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → (α × SplitHashCache) → Finset Digest → ProbComp Bool) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + ∀ history, ObserverPositionNeutralAt table target + (fun context fuel cache => runNativeRootHistoryObserve parameter root target ftsSecret table observe computation context fuel cache history) := by + induction computation using OracleComp.inductionOn with + | pure value => + intro history context fuel cache hvalid hcomplete hensured + have hstarts := startTableAgrees_of_deferredCompletable hcomplete + calc + _ = evalDist (resolveDeferredPositionValue target context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => privateResolutionObserve target table + (fun final remaining value => observe final remaining (value, cache) history) resolved.toDeferredContext fuel value) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + exact evalDist_runNativeRootHistoryObserve_pure parameter root target ftsSecret table observe value _ fuel cache history + (hvalid.of_resolveDeferredPositionValue target resolved hresolved).valuesConsistent + (hstarts.of_state_values_eq (resolveDeferredPositionValue_preserves_state_values target context resolved hresolved)) + _ = _ := (privateResolutionObserve_neutral target table + (fun final remaining value => observe final remaining (value, cache) history) context fuel value hvalid hcomplete hensured).trans + (evalDist_runNativeRootHistoryObserve_pure parameter root target ftsSecret table observe value context fuel cache history + hvalid.valuesConsistent hstarts).symm + | query_bind input next ih => + intro history context fuel cache hvalid hcomplete hensured + have hstarts := startTableAgrees_of_deferredCompletable hcomplete + let nextHistory := insertNativeRootGuess (nativeRootSelectionGuess? parameter target ⟨input, context, fuel, table, cache⟩) history + let after : DeferredContext → Nat → ((OracleWorld + SigningSpec).Range input × SplitHashCache) → ProbComp Bool := + fun final remaining value => runNativeRootHistoryObserve parameter root target ftsSecret table observe + (next value.1) final remaining value.2 nextHistory + have hneutral : ObserverPositionNeutralAt table target after := by + intro final remaining value hvalid hcomplete hensured + exact ih value.1 nextHistory final remaining value.2 hvalid hcomplete hensured + letI : ObserverDooms table after := ⟨by + intro final remaining value _ _ hnot + exact congrArg evalDist (runNativeRootHistoryObserve_of_not_completable parameter root target ftsSecret table observe + (next value.1) final remaining value.2 nextHistory hnot)⟩ + calc + _ = evalDist (resolveDeferredPositionValue target context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => runResolvedObserve after resolved.toDeferredContext fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache)) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hquery := evalDist_runNativeRootHistoryObserve_query parameter root target ftsSecret table observe input next + resolved.toDeferredContext fuel cache history (hvalid.of_resolveDeferredPositionValue target resolved hresolved).valuesConsistent + (hstarts.of_state_values_eq (resolveDeferredPositionValue_preserves_state_values target context resolved hresolved)) + simpa only [nativeRootSelectionGuess_resolvePositionValue parameter target target input context fuel table cache resolved hresolved, + after, nextHistory] using hquery + _ = evalDist (runResolvedObserve after context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache)) := + evalDist_resolveDeferredPositionValue_then_runResolvedObserve_auto_at target _ context fuel table hvalid hcomplete hensured hneutral + _ = _ := (evalDist_runNativeRootHistoryObserve_query parameter root target ftsSecret table observe input next + context fuel cache history hvalid.valuesConsistent hstarts).symm + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootHistoryTraceSampling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootHistoryTraceSampling.lean new file mode 100644 index 00000000..153185f2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootHistoryTraceSampling.lean @@ -0,0 +1,131 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootHistoryObserver + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def finishNativeRootHistoryTrace + (parameter : PublicParameter) (target : Position) (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → (α × SplitHashCache) → Finset Digest → ProbComp Bool) + (history : Finset Digest) : + Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection → ProbComp Bool + | (none, _) => pure true + | (some result, trace) => privateResolutionObserve target table + (fun final remaining value => observe final remaining value (history ∪ nativeRootCandidateHistory parameter target trace)) + result.context result.remaining result.value + +theorem finishNativeRootHistoryTrace_cons + (parameter : PublicParameter) (target : Position) (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → (α × SplitHashCache) → Finset Digest → ProbComp Bool) + (history : Finset Digest) (selection : CanonicalQuerySelection) + (trace : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) : + finishNativeRootHistoryTrace parameter target table observe history (trace.1, selection :: trace.2) = + finishNativeRootHistoryTrace parameter target table observe + (insertNativeRootGuess (nativeRootSelectionGuess? parameter target selection) history) trace := by + rcases trace with ⟨option, trace⟩ + cases option with + | none => rfl + | some result => + simp only [finishNativeRootHistoryTrace, nativeRootCandidateHistory_cons] + have hhistory : history ∪ insertNativeRootGuess (nativeRootSelectionGuess? parameter target selection) + (nativeRootCandidateHistory parameter target trace) = + insertNativeRootGuess (nativeRootSelectionGuess? parameter target selection) history ∪ + nativeRootCandidateHistory parameter target trace := by + cases nativeRootSelectionGuess? parameter target selection <;> simp [insertNativeRootGuess] + rw [hhistory] + +theorem evalDist_runNativeRootHistoryObserve_eq_trace + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → (α × SplitHashCache) → Finset Digest → ProbComp Bool) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (history : Finset Digest) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + evalDist (runNativeRootHistoryObserve parameter root target ftsSecret table observe computation context fuel cache history) = + evalDist (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache >>= + finishNativeRootHistoryTrace parameter target table observe history) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache history with + | pure value => + simp only [runNativeRootHistoryObserve, runNativeQueryTrace, OracleComp.construct_pure] + split_ifs <;> simp [finishNativeRootHistoryTrace, nativeRootCandidateHistory, nativeHashQueryHistory, privateResolutionObserve] + | query_bind input next ih => + rw [runNativeQueryTrace_query_bind] + simp only [runNativeRootHistoryObserve, OracleComp.construct_query_bind] + by_cases hcomplete : DeferredCompletable table context + · simp only [if_pos hcomplete, runResolvedObserve, bind_assoc] + apply evalDist_bind_congr + intro middle hmiddle + cases middle with + | none => simp [finishObserve, finishNativeRootHistoryTrace] + | some middle => + simp only [finishObserve, bind_assoc, pure_bind] + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table middle hconsistent hstarts hmiddle + rw [hcore.1] + have htail := ih middle.value.1 middle.context middle.remaining middle.value.2 + (insertNativeRootGuess (nativeRootSelectionGuess? parameter target ⟨input, context, fuel, table, cache⟩) history) + hcore.2.1 hcore.2.2 + simpa only [runNativeRootHistoryObserve, runResolvedObserve, finishNativeRootHistoryTrace_cons] using htail + · simp [if_neg hcomplete, finishNativeRootHistoryTrace] + +theorem evalDist_resolveRoot_then_nativeHistoryTrace + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → (α × SplitHashCache) → Finset Digest → ProbComp Bool) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (history : Finset Digest) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) : + evalDist (do + let resolved ← resolveDeferredPositionValue target context + match resolved with + | none => pure true + | some resolved => runNativeQueryTrace parameter root ftsSecret computation resolved.toDeferredContext fuel table cache >>= + finishNativeRootHistoryTrace parameter target table observe history) = + evalDist (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache >>= + finishNativeRootHistoryTrace parameter target table observe history) := by + have hstarts := startTableAgrees_of_deferredCompletable hcomplete + calc + _ = evalDist (resolveDeferredPositionValue target context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => runNativeRootHistoryObserve parameter root target ftsSecret table observe computation resolved.toDeferredContext fuel cache history) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + exact (evalDist_runNativeRootHistoryObserve_eq_trace parameter root target ftsSecret table observe computation + resolved.toDeferredContext fuel cache history (hvalid.of_resolveDeferredPositionValue target resolved hresolved).valuesConsistent + (hstarts.of_state_values_eq (resolveDeferredPositionValue_preserves_state_values target context resolved hresolved))).symm + _ = _ := (runNativeRootHistoryObserve_neutral parameter root target ftsSecret table observe computation history + context fuel cache hvalid hcomplete hensured).trans + (evalDist_runNativeRootHistoryObserve_eq_trace parameter root target ftsSecret table observe computation context fuel cache history + hvalid.valuesConsistent hstarts) + +theorem evalDist_nativeHistoryTrace_eq_uniform + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → (α × SplitHashCache) → Finset Digest → ProbComp Bool) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (history : Finset Digest) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) : + evalDist (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache >>= + finishNativeRootHistoryTrace parameter target table observe history) = + evalDist (do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt (.position target) output then pure true else + runNativeQueryTrace parameter root ftsSecret computation (completePrivatePosition target context output).toDeferredContext fuel table cache >>= + finishNativeRootHistoryTrace parameter target table observe history) := by + rw [← evalDist_resolveRoot_then_nativeHistoryTrace parameter root target ftsSecret table observe computation + context fuel cache history hvalid hcomplete hensured] + simp only [resolveDeferredPositionValue, hstate, hvalue, bind_assoc] + apply evalDist_bind_congr + intro output _ + split_ifs <;> simp [completePrivatePosition] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootHitProjection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootHitProjection.lean new file mode 100644 index 00000000..6f80aee8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootHitProjection.lean @@ -0,0 +1,204 @@ +import SphincsSecurity.Proof.OtsProbeNativeHashHistorySelection + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem nativeTrace_finalCore + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) (history : List CanonicalQuerySelection) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (htrace : (some result, history) ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) : + result.table = table ∧ result.context.ValuesConsistent ∧ DeferredCompletable table result.context := by + have hm : some result ∈ support (Prod.fst <$> + runNativeQueryTrace parameter root ftsSecret computation context fuel table cache) := by + rw [support_map] + exact ⟨(some result, history), htrace, rfl⟩ + rw [mem_support_iff_of_evalDist_eq (runNativeQueryTrace_result_projection parameter root ftsSecret computation context fuel table cache + hconsistent hstarts)] at hm + rw [support_map] at hm + obtain ⟨raw, hraw, hretain⟩ := hm + cases raw with + | none => simp [retainCompletableResult] at hretain + | some raw => + simp only [retainCompletableResult] at hretain + split_ifs at hretain with hcomplete + · have heq := Option.some.inj hretain + subst result + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table raw hconsistent hstarts hraw + exact ⟨hcore.1, hcore.2.1, by simpa only [hcore.1] using hcomplete⟩ + +def NativeRootHistorySelectionHit (parameter : PublicParameter) (target : Position) + (selected : Option (List CanonicalQuerySelection × CanonicalQuerySelection)) : Prop := + ∃ prior selection output, selected = some (prior, selection) ∧ + selection.context.positionValue target = some output ∧ .position target ∉ selection.context.state.revealed ∧ + truncateHash output ∉ nativeRootCandidateHistory parameter target prior ∧ + chargedNativeRootQueryCandidate parameter target selection.input selection.context = some (truncateHash output) + +theorem nativeTrace_rootHistoryMatch_selectedHit + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) (history : List CanonicalQuerySelection) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hmat : LayerRootsMaterialized context) (hclosed : DeferredComputationsClosed context) + (hresult : (some result, history) ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) + (hsource : ¬UnknownSourceFinalRootMatch parameter (some result, history)) + (lay : Layer) (tree : TreeIndex) (output : HashOutput) + (hvalue : result.context.positionValue (layerRootPosition lay tree) = some output) + (hhidden : .position (layerRootPosition lay tree) ∉ result.context.state.revealed) + (hmatch : truncateHash output ∈ nativeRootCandidateHistory parameter (layerRootPosition lay tree) history) + (q : Nat) (hbound : computation.IsQueryBoundP IsOuterHash q) : + ∃ ordinal ∈ Finset.range q, + NativeRootHistorySelectionHit parameter (layerRootPosition lay tree) (nativeHashHistorySelection history ordinal) := by + obtain ⟨completion, hcompletion⟩ := (nativeTrace_finalCore parameter root ftsSecret computation context fuel table cache result history + hconsistent hstarts hresult).2.2 + obtain ⟨prior, selection, suffix, hhistory, hprior, hstored, hhidden, hcandidate⟩ := + nativeTrace_rootHistoryMatch_firstCharged parameter root ftsSecret computation context fuel table cache result history completion + hconsistent hstarts hmat hclosed hresult hcompletion hsource lay tree output hvalue hhidden hmatch + have hhash : IsOuterHash selection.input := by + cases hinput : selection.input with + | inl query => + cases query with + | inl n => simp [chargedNativeRootQueryCandidate, hinput] at hcandidate + | inr input => trivial + | inr message => simp [chargedNativeRootQueryCandidate, hinput] at hcandidate + have hlength := runNativeQueryTrace_hash_length_le parameter root ftsSecret computation context fuel table cache q hbound + (some result, history) hresult + have hpriorLength : (nativeHashQueryHistory prior).length < q := by + rw [hhistory] at hlength + simp only [nativeHashQueryHistory, List.filter_append, List.filter_cons, hhash, decide_true, ↓reduceIte, + List.length_append, List.length_cons] at hlength ⊢ + omega + refine ⟨(nativeHashQueryHistory prior).length, Finset.mem_range.mpr hpriorLength, + nativeHashQueryHistory prior, selection, output, ?_, hstored, hhidden, ?_, hcandidate⟩ + · rw [hhistory] + exact nativeHashHistorySelection_append_hash prior selection suffix hhash + · simpa only [nativeRootCandidateHistory_hashHistory] using hprior + +theorem nativeTraceHashCutHistory_hit_finishes_false + (parameter : PublicParameter) (root : Digest) (target : Position) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) (OuterQueryCut α)) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (trace : Option (ResolvedRunResult (OuterQueryCut α × SplitHashCache)) × List CanonicalQuerySelection) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (htrace : trace ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) + (hhit : NativeRootHistorySelectionHit parameter target (nativeTraceHashCutHistory trace)) : + finishNativeRootHistoryTrace parameter target table + (observeChargedRootCut parameter target (fun pair => pair.2 = some (truncateHash pair.1))) ∅ trace = pure false := by + rcases trace with ⟨option, history⟩ + cases option with + | none => simp [NativeRootHistorySelectionHit, nativeTraceHashCutHistory] at hhit + | some result => + obtain ⟨prior, selection, output, hselected, hknown, hhidden, hprior, hcandidate⟩ := hhit + cases hinput : result.value.1.input? with + | none => simp [nativeTraceHashCutHistory, hinput] at hselected + | some input => + simp only [nativeTraceHashCutHistory, hinput, Option.map_some, Option.some.injEq, Prod.mk.injEq] at hselected + obtain ⟨rfl, rfl⟩ := hselected + have hfacts := nativeTrace_finalCore parameter root ftsSecret computation context fuel table cache result history + hconsistent hstarts htrace + have hcut : chargedNativeRootCutCandidate parameter target result.context result.value.1 = some (truncateHash output) := by + rw [chargedNativeRootCutCandidate_eq_query, hinput, Option.bind_some] + exact hcandidate + rw [finishNativeRootHistoryTrace, privateResolutionObserve_chargedRootCut_of_known parameter target table _ _ + result.context result.remaining result.value hfacts.2.1 hfacts.2.2 output hknown, + observeChargedRootCut_of_known parameter target _ _ _ _ _ output hknown] + simp only [nativeRootCandidateHistory_hashHistory] at hprior + simp [hhidden, hcut, hprior] + + +theorem probEvent_nativeHistorySelectionHit_le_originalChargedRootCut + (parameter : PublicParameter) (root : Digest) (target : Position) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + Pr[fun trace => NativeRootHistorySelectionHit parameter target (nativeHashHistorySelection trace.2 ordinal) | + runNativeQueryTrace parameter root ftsSecret computation context fuel table cache] ≤ + Pr[fun b => b = false | originalChargedRootCutObservation parameter root target ftsSecret computation + context fuel table cache ∅ ordinal (fun pair => pair.2 = some (truncateHash pair.1))] := by + have hdist := runNativeQueryTrace_hashHistory_projection parameter root ftsSecret computation ordinal context fuel table cache + have hprob := probEvent_congr' (fun _ _ => Iff.rfl) hdist (p := NativeRootHistorySelectionHit parameter target) + simp only [probEvent_map, Function.comp_def] at hprob + rw [hprob, originalChargedRootCutObservation, probEvent_bind_eq_tsum, probEvent_eq_tsum_ite] + apply ENNReal.tsum_le_tsum + intro trace + by_cases htrace : trace ∈ support (runNativeQueryTrace parameter root ftsSecret (outerHashQueryCutAt computation ordinal) context fuel table cache) + · by_cases hhit : NativeRootHistorySelectionHit parameter target (nativeTraceHashCutHistory trace) + · rw [if_pos hhit, nativeTraceHashCutHistory_hit_finishes_false parameter root target ftsSecret _ context fuel table cache trace + hconsistent hstarts htrace hhit] + simp + · simp [hhit] + · simp [probOutput_eq_zero_of_not_mem_support htrace] + +def NativeFinalRootHistoryMatch (parameter : PublicParameter) (target : Position) + (trace : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) : Prop := + ∃ result output, trace.1 = some result ∧ result.context.positionValue target = some output ∧ + .position target ∉ result.context.state.revealed ∧ + truncateHash output ∈ nativeRootCandidateHistory parameter target trace.2 ∧ + ¬UnknownSourceFinalRootMatch parameter trace + +theorem probEvent_nativeFinalRootHistoryMatch_le_cutHitSum + (parameter : PublicParameter) (root : Digest) (lay : Layer) (tree : TreeIndex) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hmat : LayerRootsMaterialized context) (hclosed : DeferredComputationsClosed context) + (q : Nat) (hbound : computation.IsQueryBoundP IsOuterHash q) : + Pr[NativeFinalRootHistoryMatch parameter (layerRootPosition lay tree) | + runNativeQueryTrace parameter root ftsSecret computation context fuel table cache] ≤ + ∑ ordinal ∈ Finset.range q, + Pr[fun b => b = false | originalChargedRootCutObservation parameter root (layerRootPosition lay tree) ftsSecret computation + context fuel table cache ∅ ordinal (fun pair => pair.2 = some (truncateHash pair.1))] := by + calc + _ ≤ Pr[fun trace => ∃ ordinal ∈ Finset.range q, + NativeRootHistorySelectionHit parameter (layerRootPosition lay tree) (nativeHashHistorySelection trace.2 ordinal) | + runNativeQueryTrace parameter root ftsSecret computation context fuel table cache] := by + apply probEvent_mono + rintro ⟨option, history⟩ htrace ⟨result, output, heq, hvalue, hhidden, hmatch, hsource⟩ + dsimp only at heq + subst option + exact nativeTrace_rootHistoryMatch_selectedHit parameter root ftsSecret computation context fuel table cache result history + hconsistent hstarts hmat hclosed htrace hsource lay tree output hvalue hhidden hmatch q hbound + _ ≤ ∑ ordinal ∈ Finset.range q, + Pr[fun trace => NativeRootHistorySelectionHit parameter (layerRootPosition lay tree) (nativeHashHistorySelection trace.2 ordinal) | + runNativeQueryTrace parameter root ftsSecret computation context fuel table cache] := + probEvent_exists_finset_le_sum (Finset.range q) _ _ + _ ≤ _ := by + apply Finset.sum_le_sum + intro ordinal _ + exact probEvent_nativeHistorySelectionHit_le_originalChargedRootCut parameter root (layerRootPosition lay tree) ftsSecret computation ordinal + context fuel table cache hconsistent hstarts + +theorem probEvent_exists_nativeFinalRootHistoryMatch_le_charge + (targets : Finset Position) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (q : Nat) (hq : q ≤ 2 ^ 126) (hbound : computation.IsQueryBoundP IsOuterHash q) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hmat : LayerRootsMaterialized context) (hclosed : DeferredComputationsClosed context) + (hroot : ∀ target ∈ targets, IsLayerRoot target) + (hensured : ∀ target ∈ targets, .position target ∈ context.state.ensured) + (hstate : ∀ target ∈ targets, context.state.values (.position target) = none) + (hvalue : ∀ target ∈ targets, context.values target = none) + (hpending : ∀ target ∈ targets, context.state.pendingAt (.position target) = ∅) + (hcache : ∀ target ∈ targets, ∀ digest, NoEncodingRootGuessCached parameter target digest cache) : + Pr[fun trace => ∃ target ∈ targets, NativeFinalRootHistoryMatch parameter target trace | + runNativeQueryTrace parameter root ftsSecret computation context fuel table cache] ≤ + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (chargedRootOuterCharge parameter) computation context fuel table cache * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply (probEvent_exists_finset_le_sum targets _ _).trans + apply le_trans _ (sum_targets_originalChargedRootCut_hits_le_charge targets parameter root ftsSecret computation q hq context fuel table cache + hvalid hcomplete hroot hensured hstate hvalue hpending hcache) + apply Finset.sum_le_sum + intro target htarget + obtain ⟨lay, tree, rfl⟩ := hroot target htarget + exact probEvent_nativeFinalRootHistoryMatch_le_cutHitSum parameter root lay tree ftsSecret computation context fuel table cache + hvalid.valuesConsistent (startTableAgrees_of_deferredCompletable hcomplete) hmat hclosed q hbound + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootInputObservation.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootInputObservation.lean new file mode 100644 index 00000000..88f85828 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootInputObservation.lean @@ -0,0 +1,213 @@ +import SphincsSecurity.Proof.OtsProbeNativePeekInput + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +set_option backward.isDefEq.respectTransparency false + +theorem NativeRootContextRel.other_values + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) + (coordinate : Coordinate) (hne : coordinate ≠ .position target) : + left.state.values coordinate = right.state.values coordinate := by + rw [h.right_eq] + simp [replaceNativePosition, Function.update_of_ne hne] + +theorem NativeRootContextRel.values_isSome_eq + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) (coordinate : Coordinate) : + (left.state.values coordinate).isSome = (right.state.values coordinate).isSome := by + by_cases heq : coordinate = .position target + · subst coordinate + rw [h.right_eq] + simp [replaceNativePosition] + · rw [h.other_values coordinate heq] + +theorem firstMissingInputCoordinatePlan_eq_of_nativeRootContextRel + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : NativeRootContextRel target leftOutput rightOutput left right) + (input : HashInput) : ∀ slot coordinates, + firstMissingInputCoordinatePlan left.state input slot coordinates = + firstMissingInputCoordinatePlan right.state input slot coordinates := by + intro slot coordinates + induction coordinates generalizing slot with + | nil => rfl + | cons coordinate remaining ih => + rw [firstMissingInputCoordinatePlan, firstMissingInputCoordinatePlan] + have hpresent := hrel.values_isSome_eq coordinate + cases hleft : left.state.values coordinate with + | none => + cases hright : right.state.values coordinate with + | none => rfl + | some rightValue => simp [hleft, hright] at hpresent + | some leftValue => + cases hright : right.state.values coordinate with + | none => simp [hleft, hright] at hpresent + | some rightValue => + exact ih (slot + 1) + +theorem leafInputProbePlan_eq_of_nativeRootContextRel + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : NativeRootContextRel target leftOutput rightOutput left right) + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + leafInputProbePlan left.state input candidate lay tree leafIdx = + leafInputProbePlan right.state input candidate lay tree leafIdx := by + unfold leafInputProbePlan + have hpresent := hrel.values_isSome_eq candidate.coordinate + cases hleft : left.state.values candidate.coordinate with + | none => + cases hright : right.state.values candidate.coordinate with + | none => rfl + | some rightValue => simp [hleft, hright] at hpresent + | some leftValue => + cases hright : right.state.values candidate.coordinate with + | none => simp [hleft, hright] at hpresent + | some rightValue => + exact firstMissingInputCoordinatePlan_eq_of_nativeRootContextRel hrel input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + +theorem purePlanProbingHashQuery_eq_of_nativeRootContextRel + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : NativeRootContextRel target leftOutput rightOutput left right) + (parameter : PublicParameter) (input : HashInput) : + purePlanProbingHashQuery parameter input left.state = + purePlanProbingHashQuery parameter input right.state := by + unfold purePlanProbingHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases hposition : decodePosition? parameter input with + | none => rfl + | some position => + cases position with + | leaf lay tree leafIdx => + simp only + rw [leafInputProbePlan_eq_of_nativeRootContextRel hrel] + | chain | node | ftsLeaf | ftsNode | ftsRoots => rfl + | none => + cases hposition : decodePosition? parameter input with + | none => rfl + | some position => + cases position with + | node lay tree level nodeIdx => + simp only + rw [firstMissingInputCoordinatePlan_eq_of_nativeRootContextRel hrel] + | chain | leaf | ftsLeaf | ftsNode | ftsRoots => rfl + +theorem purePeekPositionValues_eq_none_iff_missing + (state : LazyRevealProbe.State Coordinate) (positions : List Position) : + purePeekPositionValues state positions = none ↔ + ∃ position ∈ positions, state.values (.position position) = none := by + induction positions with + | nil => simp [purePeekPositionValues] + | cons position remaining ih => + cases hhead : state.values (.position position) with + | none => simp [purePeekPositionValues, hhead] + | some output => + cases htail : purePeekPositionValues state remaining <;> + simpa [purePeekPositionValues, hhead, htail] using ih + +theorem purePeekPositionValues_eq_of_values_eq_on + (left right : LazyRevealProbe.State Coordinate) (positions : List Position) + (h : ∀ position ∈ positions, left.values (.position position) = right.values (.position position)) : + purePeekPositionValues left positions = purePeekPositionValues right positions := by + induction positions with + | nil => rfl + | cons position remaining ih => + have hhead := h position (List.mem_cons_self) + have htail := ih (fun other hmem => h other (List.mem_cons_of_mem position hmem)) + simp only [purePeekPositionValues, hhead, htail] + +theorem NativeRootContextRel.values_none_iff + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) (coordinate : Coordinate) : + left.state.values coordinate = none ↔ right.state.values coordinate = none := by + have hpresent := h.values_isSome_eq coordinate + cases hleft : left.state.values coordinate <;> cases hright : right.state.values coordinate <;> + simp_all + +theorem NativeRootContextRel.purePeekPositionValues_none_iff + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) (positions : List Position) : + purePeekPositionValues left.state positions = none ↔ purePeekPositionValues right.state positions = none := by + simp only [purePeekPositionValues_eq_none_iff_missing, h.values_none_iff] + +theorem NativeRootContextRel.purePeekPositionValues_eq_of_not_mem + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) (positions : List Position) (hnot : target ∉ positions) : + purePeekPositionValues left.state positions = purePeekPositionValues right.state positions := by + apply purePeekPositionValues_eq_of_values_eq_on + intro position hmem + apply h.other_values + intro heq + have hposition : position = target := Coordinate.position.inj heq + exact hnot (hposition ▸ hmem) + +theorem NativeRootContextRel.purePeekTableInput_eq_of_not_mem_children + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) (parameter : PublicParameter) + (position : Position) (hnot : target ∉ position.children) : + purePeekTableInput parameter left.state (.position position) = + purePeekTableInput parameter right.state (.position position) := by + have hchildren := h.purePeekPositionValues_eq_of_not_mem position.children hnot + cases position with + | chain lay tree leafIdx chainIdx step => + have hstart := h.other_values (.chainStart lay tree leafIdx chainIdx) (by simp) + simp only [purePeekTableInput, hstart, hchildren] + | leaf | node | ftsLeaf | ftsNode | ftsRoots => simp only [purePeekTableInput, hchildren] + +theorem NativeRootContextRel.purePeekTableInput_none_iff + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) (parameter : PublicParameter) + (coordinate : Coordinate) : + purePeekTableInput parameter left.state coordinate = none ↔ + purePeekTableInput parameter right.state coordinate = none := by + cases coordinate with + | chainStart => rfl + | position position => + have hchildren := h.purePeekPositionValues_none_iff position.children + cases position with + | chain lay tree leafIdx chainIdx step => + by_cases hzero : step.val = 0 + · have hstart := h.other_values (.chainStart lay tree leafIdx chainIdx) (by simp) + simp only [purePeekTableInput, if_pos hzero, hstart] + · simp only [purePeekTableInput, if_neg hzero] + cases hleft : purePeekPositionValues left.state _ <;> + cases hright : purePeekPositionValues right.state _ <;> simp_all + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp only [purePeekTableInput] + cases hleft : purePeekPositionValues left.state _ <;> + cases hright : purePeekPositionValues right.state _ <;> simp_all + +theorem NativeRootContextRel.purePeekTableInput_ne_imp_known_child + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) (parameter : PublicParameter) + (coordinate : Coordinate) + (hne : purePeekTableInput parameter left.state coordinate ≠ purePeekTableInput parameter right.state coordinate) : + ∃ position leftInput rightInput, coordinate = .position position ∧ target ∈ position.children ∧ + purePeekTableInput parameter left.state coordinate = some leftInput ∧ + purePeekTableInput parameter right.state coordinate = some rightInput := by + cases coordinate with + | chainStart => exact False.elim (hne rfl) + | position position => + have hmem : target ∈ position.children := by + by_contra hnot + exact hne (h.purePeekTableInput_eq_of_not_mem_children parameter position hnot) + have hnone := h.purePeekTableInput_none_iff parameter (.position position) + cases hleft : purePeekTableInput parameter left.state (.position position) with + | none => + have hright := hnone.mp hleft + exact False.elim (hne (hleft.trans hright.symm)) + | some leftInput => + cases hright : purePeekTableInput parameter right.state (.position position) with + | none => + have hleftNone := hnone.mpr hright + rw [hleft] at hleftNone + contradiction + | some rightInput => exact ⟨position, leftInput, rightInput, rfl, hmem, rfl, rfl⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootJointReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootJointReserve.lean new file mode 100644 index 00000000..fe8173d2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootJointReserve.lean @@ -0,0 +1,61 @@ +import SphincsSecurity.Proof.OtsProbeNativeStoredRootStructuralCharge +import SphincsSecurity.Proof.OtsProbeLiveKnownRootCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +set_option backward.isDefEq.respectTransparency false + +theorem chronological_liveProbe_add_knownStructural_mul_le_directCharge + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) : + (expectedLiveResolvedQueryCharge nativeProbeQueryCharge + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) context fuel table + + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (knownStructuralRootOuterCharge parameter) computation context fuel table cache) * (4 / 3 : ENNReal) ≤ + expectedQueryCharge (directOtsQueryCharge parameter) + (simulateQ (expandedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey)) + computation) actualCache := by + exact (mul_le_mul' + (chronological_liveProbe_add_knownStructural_le_liveOuterCharge parameter root ftsSecret computation context fuel table cache + hinvariant.2.1.valuesConsistent hinvariant.2.2.1) le_rfl).trans + (expectedLiveChronologicalOtsCount_mul_le_directCharge parameter root table ftsSecret computation context fuel cache actualCache + hinvariant hvisible hpublished) + +theorem chronological_liveProbe_add_knownRoots_le_refinedReserve + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + (expectedLiveResolvedQueryCharge nativeProbeQueryCharge + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) context fuel table + + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (knownStructuralRootOuterCharge parameter) computation context fuel table cache) * (4 / 3 : ENNReal) + + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (knownEncodingRootOuterCharge parameter) computation context fuel table cache ≤ + expectedQueryCharge (otsOpeningRefinedQueryReserve secretKey) + (simulateQ (expandedAdversaryImpl secretKey) computation) actualCache := by + dsimp only + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + apply (add_le_add + (chronological_liveProbe_add_knownStructural_mul_le_directCharge parameter root table ftsSecret + computation context fuel cache actualCache hinvariant hvisible hpublished) + (expectedLiveKnownRootCharge_le_actualRootCharge parameter root table ftsSecret computation context fuel cache actualCache + hinvariant hvisible hpublished hcomputed)).trans + rw [← expectedQueryCharge_add] + exact expectedQueryCharge_mono _ _ (direct_add_rootEncodingQueryCharge_le_refinedReserve secretKey) _ actualCache + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootMaterialization.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootMaterialization.lean new file mode 100644 index 00000000..78fa1cd8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootMaterialization.lean @@ -0,0 +1,233 @@ +import SphincsSecurity.Proof.OtsProbeNativeResolvedRootCutRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def LayerRootsMaterialized (context : DeferredContext) : Prop := + ∀ target, IsLayerRoot target → context.values target ≠ none → context.state.values (.position target) ≠ none + +theorem LayerRootsMaterialized.of_values_eq + {before after : DeferredContext} (h : LayerRootsMaterialized before) + (hstate : after.state.values = before.state.values) (hvalues : after.values = before.values) : + LayerRootsMaterialized after := by + intro target hroot hknown + rw [hstate] + exact h target hroot (by simpa only [hvalues] using hknown) + +theorem LayerRootsMaterialized.state_value_of_known + {context : DeferredContext} (h : LayerRootsMaterialized context) (target : Position) (hroot : IsLayerRoot target) + (output : HashOutput) (hknown : context.positionValue target = some output) : + context.state.values (.position target) = some output := by + cases hstate : context.state.values (.position target) with + | none => + have haux : context.values target = some output := by simpa [DeferredContext.positionValue, hstate] using hknown + exact False.elim (h target hroot (by rw [haux]; simp) hstate) + | some value => + have heq : value = output := by simpa [DeferredContext.positionValue, hstate] using hknown + exact congrArg some heq + +theorem LayerRootsMaterialized.materialize_of_other_roots_eq + {context : DeferredContext} (h : LayerRootsMaterialized context) (position : Position) (result : DeferredResolution) + (hvalues : ∀ target, IsLayerRoot target → target ≠ position → result.values target = context.values target) : + LayerRootsMaterialized (materializeResolvedPosition context position result) := by + intro target hroot hknown + by_cases heq : target = position + · subst target + simp [materializeResolvedPosition, LazyRevealProbe.State.materialize] + · have hbefore : context.values target ≠ none := by + change result.values target ≠ none at hknown + rwa [hvalues target hroot heq] at hknown + have hstate := h target hroot hbefore + simpa [materializeResolvedPosition, LazyRevealProbe.State.materialize, heq] using hstate + +theorem not_isLayerRoot_chain (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) (step : ChainStep) : + ¬IsLayerRoot (.chain lay tree leafIdx chainIdx step) := by + rintro ⟨otherLay, otherTree, h⟩ + cases h + +theorem not_isLayerRoot_leaf (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ¬IsLayerRoot (.leaf lay tree leafIdx) := by + rintro ⟨otherLay, otherTree, h⟩ + cases h + +theorem not_isLayerRoot_node_below (lay : Layer) (tree : TreeIndex) (level : Fin maxLayerHeight) (nodeIdx : LeafIndex) + (hbelow : level.val + 1 < layerHeight lay) : ¬IsLayerRoot (.node lay tree level nodeIdx) := by + rintro ⟨otherLay, otherTree, h⟩ + simp only [layerRootPosition, Position.node.injEq] at h + obtain ⟨rfl, rfl, hlevel, _⟩ := h + have heq := congrArg Fin.val hlevel + dsimp only at heq + omega + +theorem resolveDeferredChainPrefix_preserves_root_values + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps context result, + some result ∈ support (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) → + ∀ target, IsLayerRoot target → result.values target = context.values target + | 0, hsteps, context, result, hresult, target, _ => by + simp only [resolveDeferredChainPrefix, support_pure, Set.mem_singleton_iff] at hresult + exact congrFun (resolveDeferredChainStart_deferred_values_eq table ⟨lay, tree, leafIdx, chainIdx⟩ context result hresult.symm) target + | steps + 1, hsteps, context, result, hresult, target, hroot => by + rw [resolveDeferredChainPrefix, mem_support_bind_iff] at hresult + obtain ⟨previous, hprevious, htail⟩ := hresult + cases previous with + | none => simp at htail + | some previous => + have hmiddle := resolveDeferredChainPrefix_preserves_root_values table lay tree leafIdx chainIdx steps (by omega) + context previous hprevious target hroot + exact (resolveDeferredPositionValue_preserves_other (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) target + previous.toDeferredContext result (fun heq => not_isLayerRoot_chain lay tree leafIdx chainIdx _ (heq ▸ hroot)) htail).trans hmiddle + +theorem resolveDeferredChains_preserves_root_values + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ∀ chains context result, some result ∈ support (resolveDeferredChains table lay tree leafIdx chains context) → + ∀ target, IsLayerRoot target → result.values target = context.values target + | [], context, result, hresult, target, _ => by + simp only [resolveDeferredChains, mem_support_pure_iff, Option.some.injEq] at hresult + subst result + rfl + | chainIdx :: chains, context, result, hresult, target, hroot => by + rw [resolveDeferredChains, mem_support_bind_iff] at hresult + obtain ⟨head, hhead, htail⟩ := hresult + cases head with + | none => simp at htail + | some head => + exact (resolveDeferredChains_preserves_root_values table lay tree leafIdx chains head.toDeferredContext result htail target hroot).trans + (resolveDeferredChainPrefix_preserves_root_values table lay tree leafIdx chainIdx (chainLength - 1) (by omega) + context head hhead target hroot) + +theorem resolveDeferredOtsLeaf_preserves_root_values + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support (resolveDeferredOtsLeaf table lay tree leafIdx context)) + (target : Position) (hroot : IsLayerRoot target) : result.values target = context.values target := by + rw [resolveDeferredOtsLeaf, mem_support_bind_iff] at hresult + obtain ⟨chains, hchains, htail⟩ := hresult + cases chains with + | none => simp at htail + | some chains => + exact (resolveDeferredPositionValue_preserves_other (.leaf lay tree leafIdx) target chains result + (fun heq => not_isLayerRoot_leaf lay tree leafIdx (heq ▸ hroot)) htail).trans + (resolveDeferredChains_preserves_root_values table lay tree leafIdx _ context chains hchains target hroot) + +theorem resolveDeferredTreeNode_preserves_root_values_below + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel context result, level < layerHeight lay → + some result ∈ support (resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) → + ∀ target, IsLayerRoot target → result.values target = context.values target + | 0, nodeIdx, hlevel, context, result, _, hresult, target, hroot => + resolveDeferredOtsLeaf_preserves_root_values table lay tree (leafOfNat nodeIdx) context result hresult target hroot + | level + 1, nodeIdx, hlevel, context, result, hbelow, hresult, target, hroot => by + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨left, hleft, htail⟩ := hresult + cases left with + | none => simp at htail + | some left => + rw [mem_support_bind_iff] at htail + obtain ⟨right, hright, htail⟩ := htail + cases right with + | none => simp at htail + | some right => + have hleftEq := resolveDeferredTreeNode_preserves_root_values_below table lay tree level (2 * nodeIdx) (by omega) + context left (by omega) hleft target hroot + have hrightEq := resolveDeferredTreeNode_preserves_root_values_below table lay tree level (2 * nodeIdx + 1) (by omega) + left.toDeferredContext right (by omega) hright target hroot + exact (resolveDeferredPositionValue_preserves_other (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) target + right.toDeferredContext result + (fun heq => not_isLayerRoot_node_below lay tree _ _ hbelow (heq ▸ hroot)) htail).trans (hrightEq.trans hleftEq) + +theorem resolveDeferredTreeNode_preserves_other_root_values_bounded + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) (hlevel : level ≤ maxLayerHeight) (context : DeferredContext) (result : DeferredResolution) + (hbounded : level ≤ layerHeight lay) + (hresult : some result ∈ support (resolveDeferredTreeNode table lay tree level nodeIdx hlevel context)) + (target : Position) (hroot : IsLayerRoot target) + (hne : target ≠ deferredTreePosition lay tree level nodeIdx hlevel) : + result.values target = context.values target := by + cases level with + | zero => exact resolveDeferredOtsLeaf_preserves_root_values table lay tree (leafOfNat nodeIdx) context result hresult target hroot + | succ level => + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨left, hleft, htail⟩ := hresult + cases left with + | none => simp at htail + | some left => + rw [mem_support_bind_iff] at htail + obtain ⟨right, hright, htail⟩ := htail + cases right with + | none => simp at htail + | some right => + have hleftEq := resolveDeferredTreeNode_preserves_root_values_below table lay tree level (2 * nodeIdx) (by omega) + context left (by omega) hleft target hroot + have hrightEq := resolveDeferredTreeNode_preserves_root_values_below table lay tree level (2 * nodeIdx + 1) (by omega) + left.toDeferredContext right (by omega) hright target hroot + exact (resolveDeferredPositionValue_preserves_other (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) target + right.toDeferredContext result hne htail).trans (hrightEq.trans hleftEq) + +def LayerBoundedPosition : Position → Prop + | .node lay _ level _ => level.val + 1 ≤ layerHeight lay + | _ => True + +theorem resolveDeferredReveal_preserves_other_root_values_bounded + (table : OtsSecretIndex → HashOutput) (position : Position) (context : DeferredContext) (result : DeferredResolution) + (hbounded : LayerBoundedPosition position) + (hresult : some result ∈ support (resolveDeferredReveal table position context)) + (target : Position) (hroot : IsLayerRoot target) (hne : target ≠ position) : + result.values target = context.values target := by + unfold resolveDeferredReveal at hresult + split_ifs at hresult with hresolvable + · cases position with + | chain lay tree leafIdx chainIdx step => + exact resolveDeferredChainPrefix_preserves_root_values table lay tree leafIdx chainIdx _ _ context result hresult target hroot + | leaf lay tree leafIdx => + exact resolveDeferredOtsLeaf_preserves_root_values table lay tree leafIdx context result hresult target hroot + | node lay tree level nodeIdx => + apply resolveDeferredTreeNode_preserves_other_root_values_bounded table lay tree (level.val + 1) nodeIdx + (by have := level.isLt; omega) context result hbounded hresult target hroot + simpa [deferredTreePosition, leafOfNat, Nat.mod_eq_of_lt nodeIdx.isLt] using hne + | ftsLeaf | ftsNode | ftsRoots => contradiction + · exact resolveDeferredPositionValue_preserves_other position target context result hne hresult + +theorem LayerRootsMaterialized.of_resolveReveal_bounded + {context : DeferredContext} (h : LayerRootsMaterialized context) + (table : OtsSecretIndex → HashOutput) (position : Position) (result : DeferredResolution) + (hbounded : LayerBoundedPosition position) + (hresult : some result ∈ support (resolveDeferredReveal table position context)) : + LayerRootsMaterialized (materializeResolvedPosition context position result) := + h.materialize_of_other_roots_eq position result + (resolveDeferredReveal_preserves_other_root_values_bounded table position context result hbounded hresult) + +theorem LayerRootsMaterialized.of_resolvePositionValue_known_root + {context : DeferredContext} (h : LayerRootsMaterialized context) + (position : Position) (result : DeferredResolution) + (hknown : IsLayerRoot position → ∃ output, context.positionValue position = some output) + (hresult : some result ∈ support (resolveDeferredPositionValue position context)) : + LayerRootsMaterialized result.toDeferredContext := by + intro target hroot haux + rw [resolveDeferredPositionValue_preserves_state_values position context result hresult] + by_cases heq : target = position + · subst target + obtain ⟨output, houtput⟩ := hknown hroot + rw [h.state_value_of_known position hroot output houtput] + simp + · apply h target hroot + change result.values target ≠ none at haux + rwa [resolveDeferredPositionValue_preserves_other position target context result heq hresult] at haux + +theorem LayerRootsMaterialized.of_resolveOtsLeaf + {context : DeferredContext} (h : LayerRootsMaterialized context) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (result : DeferredResolution) + (hresult : some result ∈ support (resolveDeferredOtsLeaf table lay tree leafIdx context)) : + LayerRootsMaterialized result.toDeferredContext := by + intro target hroot haux + rw [resolveDeferredOtsLeaf_preserves_state_values table lay tree leafIdx context result hresult] + apply h target hroot + change result.values target ≠ none at haux + rwa [resolveDeferredOtsLeaf_preserves_root_values table lay tree leafIdx context result hresult target hroot] at haux + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootOuterCut.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootOuterCut.lean new file mode 100644 index 00000000..589de7c9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootOuterCut.lean @@ -0,0 +1,103 @@ +import SphincsSecurity.Proof.OtsProbeNativeOuterCut +import SphincsSecurity.Proof.OtsProbeNativeRootSwapStep + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem relTriple_nativeRootSwap_outerCut + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (before after : HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (left right : DeferredContext) (hcontext : NativeRootContextRel target before after left right) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : NativeRootSwapCacheRel parameter target before after leftCache rightCache) : + RelTriple + (runNativeOuterCut (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (NativeRootOuterSafe parameter target before after) computation left fuel table leftCache) + (runNativeOuterCut (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (NativeRootOuterSafe parameter target before after) computation right fuel table rightCache) + (NativeRootSwapSameRel parameter target before after) := by + induction computation using OracleComp.inductionOn generalizing left right fuel table leftCache rightCache with + | pure value => exact relTriple_pure_pure ⟨hcontext, rfl, rfl, rfl, hcache⟩ + | query_bind input next ih => + rw [runNativeOuterCut_query_bind, runNativeOuterCut_query_bind] + by_cases hsafe : NativeRootOuterSafe parameter target before after input left + · have hright := (hcontext.outerSafe_iff parameter input).mp hsafe + rw [if_pos hsafe, if_pos hright] + apply relTriple_bind (relTriple_nativeRootSwap_outerQuery_of_safe parameter root target hroot before after ftsSecret input + left right hcontext fuel table leftCache rightCache hcache hsafe) + intro leftResult rightResult hrel + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => contradiction + | some leftResult => + cases rightResult with + | none => contradiction + | some rightResult => + rcases hrel with ⟨hnextContext, hfuel, htable, hvalue, hnextCache⟩ + simp only + rw [← hfuel, ← htable, ← hvalue] + exact ih leftResult.value.1 leftResult.context rightResult.context hnextContext leftResult.remaining + leftResult.table leftResult.value.2 rightResult.value.2 hnextCache + · have hright : ¬NativeRootOuterSafe parameter target before after input right := + fun h => hsafe ((hcontext.outerSafe_iff parameter input).mpr h) + rw [if_neg hsafe, if_neg hright] + exact relTriple_pure_pure ⟨hcontext, rfl, rfl, rfl, hcache⟩ + +theorem evalDist_nativeRootSwap_outerCut_live_of_stored + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (before after : HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (h : NativePositionReplaceable target before after context) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + evalDist (normalizeLiveNativeRootResult target <$> + runNativeOuterCut (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (NativeRootOuterSafe parameter target before after) computation context fuel table cache) = + evalDist (normalizeLiveNativeRootResult target <$> + runNativeOuterCut (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (NativeRootOuterSafe parameter target before after) computation (replaceNativePosition target after context) fuel table + (fullSwapRootCache parameter target (truncateHash before) (truncateHash after) after cache)) := by + have hpadding : + evalDist (normalizeLiveNativeRootResult target <$> + runNativeOuterCut (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (NativeRootOuterSafe parameter target before after) computation context fuel table cache) = + evalDist (normalizeLiveNativeRootResult target <$> + runNativeOuterCut (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (NativeRootOuterSafe parameter target before after) computation context fuel table + (replaceHiddenRootCache target before cache)) := by + apply evalDist_map_eq_of_relTriple + apply relTriple_post_mono + (relTriple_runNativeOuterCut_ordinaryCache _ + (ordinaryCacheNativeCouples_chronologicalOuterQuery parameter root ftsSecret) _ computation context fuel table + cache (replaceHiddenRootCache target before cache) (ordinarySplitCacheEq_replaceHiddenRootCache target before cache)) + intro left right hrel + exact hrel.normalizeLive target + have hswap : + evalDist (normalizeLiveNativeRootResult target <$> + runNativeOuterCut (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (NativeRootOuterSafe parameter target before after) computation context fuel table + (replaceHiddenRootCache target before cache)) = + evalDist (normalizeLiveNativeRootResult target <$> + runNativeOuterCut (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (NativeRootOuterSafe parameter target before after) computation (replaceNativePosition target after context) fuel table + (fullSwapRootCache parameter target (truncateHash before) (truncateHash after) after + (replaceHiddenRootCache target before cache))) := by + apply evalDist_map_eq_of_relTriple + apply relTriple_post_mono + (relTriple_nativeRootSwap_outerCut parameter root target hroot before after ftsSecret computation context + (replaceNativePosition target after context) ⟨h, rfl⟩ fuel table (replaceHiddenRootCache target before cache) _ + (nativeRootSwapCacheRel_fullSwap parameter target before after (replaceHiddenRootCache target before cache) + (by simp [replaceHiddenRootCache]))) + intro left right hrel + exact hrel.normalizeLive + rw [fullSwapRootCache_replaceHiddenRootCache] at hswap + exact hpadding.trans hswap + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootOuterCutStop.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootOuterCutStop.lean new file mode 100644 index 00000000..c754e952 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootOuterCutStop.lean @@ -0,0 +1,78 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootOuterCut + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem runNativeOuterCut_query_is_unsafe + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (safe : (OracleWorld + SigningSpec).Domain → DeferredContext → Prop) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (OuterQueryCut α × SplitHashCache)) + (hresult : some result ∈ support (runNativeOuterCut impl safe computation context fuel table cache)) + (input : (OracleWorld + SigningSpec).Domain) (hinput : result.value.1.input? = some input) : + ¬safe input result.context := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => + simp only [runNativeOuterCut, OracleComp.construct_pure, mem_support_pure_iff, Option.some.injEq] at hresult + subst result + contradiction + | query_bind query next ih => + rw [runNativeOuterCut_query_bind] at hresult + by_cases hsafe : safe query context + · rw [if_pos hsafe, mem_support_bind_iff] at hresult + obtain ⟨middle, hmiddle, htail⟩ := hresult + cases middle with + | none => simp at htail + | some middle => exact ih middle.value.1 middle.context middle.remaining middle.table middle.value.2 htail + · rw [if_neg hsafe] at hresult + simp only [mem_support_pure_iff, Option.some.injEq] at hresult + subst result + have heq : query = input := Option.some.inj hinput + subst input + exact hsafe + +theorem nativeRootOuterCut_query_is_unsafe_hash + (parameter : PublicParameter) (root : Digest) (target : Position) (before after : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (OuterQueryCut α × SplitHashCache)) + (hresult : some result ∈ support + (runNativeOuterCut (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (NativeRootOuterSafe parameter target before after) computation context fuel table cache)) + (input : (OracleWorld + SigningSpec).Domain) (hinput : result.value.1.input? = some input) : + ∃ hashInput, input = .inl (.inr hashInput) ∧ + ¬NativeRootHashSafe parameter target before after hashInput result.context := by + have hunsafe := runNativeOuterCut_query_is_unsafe _ _ computation context fuel table cache result hresult input hinput + cases input with + | inl query => + cases query with + | inl n => exact False.elim (hunsafe trivial) + | inr hashInput => exact ⟨hashInput, rfl, hunsafe⟩ + | inr message => exact False.elim (hunsafe trivial) + +theorem nativeRootHashSafe_failure_classify + (parameter : PublicParameter) (target : Position) (before after : HashOutput) + (input : HashInput) (context : DeferredContext) + (hunsafe : ¬NativeRootHashSafe parameter target before after input context) : + ¬RootInputAvoids parameter target (truncateHash before) (truncateHash after) input ∨ + (∃ candidate, (purePlanProbingHashQuery parameter input (replaceNativePosition target before context).state).candidate? = some candidate ∧ + IsPrivateValueExposure target before after (.probe candidate.coordinate candidate.candidate)) ∨ + ¬NativeRootActionSafe parameter target input (replaceNativePosition target before context) + (replaceNativePosition target after context) + (purePlanProbingHashQuery parameter input (replaceNativePosition target before context).state).action := by + unfold NativeRootHashSafe at hunsafe + by_cases hencoding : RootInputAvoids parameter target (truncateHash before) (truncateHash after) input + · by_cases hprobe : ∀ candidate, + (purePlanProbingHashQuery parameter input (replaceNativePosition target before context).state).candidate? = some candidate → + ¬IsPrivateValueExposure target before after (.probe candidate.coordinate candidate.candidate) + · exact Or.inr (Or.inr (fun haction => hunsafe ⟨hencoding, hprobe, haction⟩)) + · push Not at hprobe + exact Or.inr (Or.inl hprobe) + · exact Or.inl hencoding + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootProbe.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootProbe.lean new file mode 100644 index 00000000..45da06ee --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootProbe.lean @@ -0,0 +1,78 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootInputObservation + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem NativePositionReplaceable.addPending + {target : Position} {before after : HashOutput} {context : DeferredContext} + (h : NativePositionReplaceable target before after context) (coordinate : Coordinate) (digest : Digest) + (hsafe : ¬IsPrivateValueExposure target before after (.probe coordinate digest)) : + NativePositionReplaceable target before after + { context with state := context.state.addPending coordinate digest } := by + refine ⟨h.known, h.consistent.addPending coordinate digest, ?_, ?_⟩ + all_goals + intro hhit + simp only [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff, + LazyRevealProbe.State.addPending, Finset.mem_insert] at hhit + rcases hhit with hhit | hhit + · apply hsafe + obtain ⟨hcoordinate, hdigest⟩ := Prod.mk.inj hhit + exact ⟨hcoordinate.symm, by first | exact Or.inl hdigest.symm | exact Or.inr hdigest.symm⟩ + · first + | apply h.beforeMiss + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff] using hhit + | apply h.afterMiss + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff] using hhit + +theorem NativeRootContextRel.addPending + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) (coordinate : Coordinate) (digest : Digest) + (hsafe : ¬IsPrivateValueExposure target before after (.probe coordinate digest)) : + NativeRootContextRel target before after + { left with state := left.state.addPending coordinate digest } + { right with state := right.state.addPending coordinate digest } := by + refine ⟨h.replaceable.addPending coordinate digest hsafe, ?_⟩ + rw [h.right_eq] + rfl + +theorem NativeRootContextRel.revealed_eq + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) : left.state.revealed = right.state.revealed := by + rw [h.right_eq] + rfl + +theorem nativeRootRelates_probe_of_safe + (target : Position) (before after : HashOutput) (candidate : Probe) + (hsafe : ¬IsPrivateValueExposure target before after (.probe candidate.coordinate candidate.candidate)) : + NativeRootRelates target before after (probe candidate) (probe candidate) := by + intro left right hcontext fuel table leftCache rightCache hcache + unfold probe + rw [StateT.run_liftM, StateT.run_liftM] + unfold LazyRevealProbe.probeQuery + rw [runResolvedFromTable_probe_query_bind, runResolvedFromTable_probe_query_bind] + cases fuel with + | zero => exact relTriple_pure_pure trivial + | succ fuel => + simp only + rw [← hcontext.revealed_eq] + by_cases hrevealed : candidate.coordinate ∈ left.state.revealed + · rw [if_pos hrevealed, if_pos hrevealed] + exact relTriple_pure_pure ⟨hcontext, rfl, rfl, rfl, hcache⟩ + · rw [if_neg hrevealed, if_neg hrevealed] + exact relTriple_pure_pure ⟨hcontext.addPending candidate.coordinate candidate.candidate hsafe, rfl, rfl, rfl, hcache⟩ + +theorem nativeRootRelates_executeCandidate_of_safe + (target : Position) (before after : HashOutput) (candidate : Option Probe) + (hsafe : ∀ value, candidate = some value → + ¬IsPrivateValueExposure target before after (.probe value.coordinate value.candidate)) : + NativeRootRelates target before after (executeCandidate? candidate) (executeCandidate? candidate) := by + cases candidate with + | none => exact nativeRootRelates_pure target before after () + | some candidate => exact nativeRootRelates_probe_of_safe target before after candidate (hsafe candidate rfl) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootQueryCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootQueryCharge.lean new file mode 100644 index 00000000..edc3bb90 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootQueryCharge.lean @@ -0,0 +1,134 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootReserve + +namespace SphincsSecurity + +open _root_.OracleComp OracleSpec ENNReal + +theorem expectedQueryCharge_mono + (left right : QueryCache HashSpec → HashInput → ENNReal) + (hle : ∀ cache input, left cache input ≤ right cache input) + (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) : + expectedQueryCharge left computation cache ≤ expectedQueryCharge right computation cache := by + calc + _ ≤ expectedQueryCharge left computation cache + + expectedQueryCharge (fun cache input => right cache input - left cache input) computation cache := le_self_add + _ = expectedQueryCharge (fun cache input => left cache input + (right cache input - left cache input)) computation cache := + (expectedQueryCharge_add _ _ computation cache).symm + _ = _ := by + congr 1 + funext cache input + exact add_tsub_cancel_of_le (hle cache input) + +namespace Concrete + +theorem sampledQueryCharge_mono + (left right : SecretKey → QueryCache HashSpec → HashInput → ENNReal) + (hle : ∀ secretKey cache input, left secretKey cache input ≤ right secretKey cache input) + (adversary : Adversary) : + sampledQueryCharge left adversary ≤ sampledQueryCharge right adversary := by + unfold sampledQueryCharge + apply ENNReal.tsum_le_tsum + intro secrets + exact mul_le_mul' le_rfl (expectedQueryCharge_mono _ _ (hle _) _ _) + +namespace OtsProbeSimulation + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def rootEncodingQueryCharge (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) : ENNReal := + if (∃ candidate, EncodingLayerRootCandidateAt secretKey.parameter input candidate) ∧ + (4 / 3 : ENNReal) ≤ remainingOtsQueryReserve secretKey cache input then 4 / 3 else 0 + +theorem rootEncodingQueryCharge_le_remainingReserve + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) : + rootEncodingQueryCharge secretKey cache input ≤ remainingOtsQueryReserve secretKey cache input := by + unfold rootEncodingQueryCharge + split_ifs with hcharge + · exact hcharge.2 + · exact zero_le + +theorem rootEncodingQueryCharge_eq_four_thirds + {secretKey : SecretKey} (cache : QueryCache HashSpec) {input : HashInput} {candidate : Probe} + (hcandidate : EncodingLayerRootCandidateAt secretKey.parameter input candidate) + (hreserve : (4 / 3 : ENNReal) ≤ remainingOtsQueryReserve secretKey cache input) : + rootEncodingQueryCharge secretKey cache input = 4 / 3 := by + unfold rootEncodingQueryCharge + exact if_pos ⟨⟨candidate, hcandidate⟩, hreserve⟩ + +theorem rootEncodingQueryCharge_eq_zero_iff_insufficient + {secretKey : SecretKey} (cache : QueryCache HashSpec) {input : HashInput} {candidate : Probe} + (hcandidate : EncodingLayerRootCandidateAt secretKey.parameter input candidate) : + rootEncodingQueryCharge secretKey cache input = 0 ↔ remainingOtsQueryReserve secretKey cache input < (4 / 3 : ENNReal) := by + by_cases hreserve : (4 / 3 : ENNReal) ≤ remainingOtsQueryReserve secretKey cache input + · rw [rootEncodingQueryCharge_eq_four_thirds cache hcandidate hreserve] + simp only [not_lt_of_ge hreserve, iff_false] + norm_num + · have hlt := lt_of_not_ge hreserve + simp [rootEncodingQueryCharge, hreserve, hlt] + +theorem DeferredComputationsClosed.rootEncodingQueryCharge_eq_four_thirds + {secretKey : SecretKey} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache actualCache : QueryCache HashSpec} + (hclosed : DeferredComputationsClosed context) + (hinvariant : ResolvedContextInvariant secretKey.parameter table context ordinaryCache actualCache) + (hsecrets : secretKey.otsSecret = fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + {input : HashInput} {candidate : Probe} {target : Position} {output : HashOutput} + (hcandidate : EncodingLayerRootCandidateAt secretKey.parameter input candidate) + (hposition : candidate.coordinate = .position target) (hvalue : context.positionValue target = some output) : + rootEncodingQueryCharge secretKey actualCache input = 4 / 3 := + SphincsSecurity.Concrete.OtsProbeSimulation.rootEncodingQueryCharge_eq_four_thirds actualCache hcandidate + (hclosed.remainingReserve_of_encoding_candidate hinvariant hsecrets hcandidate hposition hvalue) + +theorem rootEncodingQueryCharge_eq_four_thirds_of_native_matching_query + (secretKey : SecretKey) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (ordinaryCache : QueryCache HashSpec) + (initialState finalState : ViewedFullTraceState) + (hclosed : DeferredComputationsClosed context) + (hinvariant : ResolvedContextInvariant secretKey.parameter table context ordinaryCache finalState.cache) + (hsecrets : secretKey.otsSecret = fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + (input : HashInput) (candidate : Probe) (lay : Layer) (tree : TreeIndex) (output : HashOutput) + (hcandidate : EncodingLayerRootCandidateAt secretKey.parameter input candidate) + (hposition : candidate.coordinate = .position (layerRootPosition lay tree)) + (hvalue : context.positionValue (layerRootPosition lay tree) = some output) + (hmatch : candidate.candidate = truncateHash output) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) (value : α) + (hrun : (value, (finalState, false)) ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl secretKey secretKey) + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next)).run (initialState, false))) : + rootEncodingQueryCharge secretKey initialState.cache input = 4 / 3 := by + have hroot := hclosed.root_settled_value hinvariant secretKey.ftsSecret lay tree output hvalue + have hsettled : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret finalState.cache (layerRootPosition lay tree) := by + simpa only [hsecrets] using hroot.1 + have hrootValue : honestValue (fromCache finalState.cache) secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (layerRootPosition lay tree) = truncateHash output := by + simpa only [hsecrets] using hroot.2 + apply rootEncodingQueryCharge_eq_four_thirds initialState.cache hcandidate + rw [hcandidate.remainingReserve_eq_refined (secretKey := secretKey) initialState.cache] + exact hcandidate.refinedReserve_of_prehitFree_viewed_matching_query secretKey + hposition hsettled (hmatch.trans hrootValue.symm) next value hrun + +theorem direct_add_rootEncodingQueryCharge_le_refinedReserve + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) : + directOtsQueryCharge secretKey.parameter cache input + rootEncodingQueryCharge secretKey cache input ≤ + otsOpeningRefinedQueryReserve secretKey cache input := + (add_le_add le_rfl (rootEncodingQueryCharge_le_remainingReserve secretKey cache input)).trans_eq + (direct_add_remaining_otsQueryReserve secretKey cache input) + +theorem sampled_direct_add_rootEncodingQueryCharge_le_refinedReserve (adversary : Adversary) : + sampledQueryCharge (fun secretKey => directOtsQueryCharge secretKey.parameter) adversary + + sampledQueryCharge rootEncodingQueryCharge adversary ≤ sampledQueryCharge otsOpeningRefinedQueryReserve adversary := by + rw [← sampledQueryCharge_add] + exact sampledQueryCharge_mono _ _ direct_add_rootEncodingQueryCharge_le_refinedReserve adversary + +theorem sampledInitializedNativeDirectRisk_add_rootEncodingCharge_le_refinedReserve + (targets : Finset Position) (adversary : Adversary) (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + sampledInitializedNativeDirectRisk targets adversary fuel q + + sampledQueryCharge rootEncodingQueryCharge adversary * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ ≤ + sampledQueryCharge otsOpeningRefinedQueryReserve adversary * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply (add_le_add le_rfl (mul_le_mul' (sampledQueryCharge_mono _ _ rootEncodingQueryCharge_le_remainingReserve adversary) le_rfl)).trans + exact sampledInitializedNativeDirectRisk_add_remaining_le_refinedReserve targets adversary fuel q hq + +end OtsProbeSimulation +end Concrete +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootRecordLikelihood.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootRecordLikelihood.lean new file mode 100644 index 00000000..d6d3e2e3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootRecordLikelihood.lean @@ -0,0 +1,69 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootTraceCoupling +import SphincsSecurity.Proof.OtsProbePrivateValueProbeRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem observeCompatibleNativeRootTrace_eq_filter + (parameter : PublicParameter) (target : Position) (before after : HashOutput) + (trace : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) : + observeCompatibleNativeRootTrace parameter target before after trace = + (observeCompatibleNativeRootTrace parameter target before before trace).filter + (fun record => @decide (truncateHash after ∉ record.2) (Classical.propDecidable _)) := by + rcases trace with ⟨option, history⟩ + cases option with + | none => simp [observeCompatibleNativeRootTrace, NativeRootTraceCompatible] + | some result => + by_cases hhidden : .position target ∉ result.context.state.revealed <;> + by_cases hbefore : truncateHash before ∈ nativeRootCandidateHistory parameter target history <;> + by_cases hafter : truncateHash after ∈ nativeRootCandidateHistory parameter target history <;> + simp [observeCompatibleNativeRootTrace, NativeRootTraceCompatible, hhidden, hbefore, hafter, + normalizeNativeRootResult, Option.filter] + +theorem probOutput_observeCompatibleNativeRootTrace_eq_of_compatible + (parameter : PublicParameter) (target : Position) (before after : HashOutput) + (run : ProbComp (Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection)) + (record : ResolvedRunResult α × Finset Digest) (hafter : truncateHash after ∉ record.2) : + Pr[= some record | observeCompatibleNativeRootTrace parameter target before after <$> run] = + Pr[= some record | observeCompatibleNativeRootTrace parameter target before before <$> run] := by + have heq : observeCompatibleNativeRootTrace parameter target before after = + (fun result => result.filter (fun value => @decide (truncateHash after ∉ value.2) (Classical.propDecidable _))) ∘ + observeCompatibleNativeRootTrace parameter target before before (α := α) := + funext (observeCompatibleNativeRootTrace_eq_filter parameter target before after) + rw [heq] + simpa only [Functor.map_map, Function.comp_def] using + (probOutput_filter_some_of_predicate (observeCompatibleNativeRootTrace parameter target before before <$> run) + (fun value => truncateHash after ∉ value.2) record hafter) + +theorem probOutput_nativeRootTraceRecord_eq_of_compatible + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (before after : HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (left right : DeferredContext) (hcontext : NativeRootContextRel target before after left right) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : NativeRootSwapCacheRel parameter target before after leftCache rightCache) + (record : ResolvedRunResult α × Finset Digest) + (hbefore : truncateHash before ∉ record.2) (hafter : truncateHash after ∉ record.2) : + Pr[= some record | observeCompatibleNativeRootTrace parameter target before before <$> + runNativeQueryTrace parameter root ftsSecret computation left fuel table leftCache] = + Pr[= some record | observeCompatibleNativeRootTrace parameter target after after <$> + runNativeQueryTrace parameter root ftsSecret computation right fuel table rightCache] := by + have hdist := evalDist_nativeRootSwap_compatibleTrace parameter root target hroot before after ftsSecret computation + left right hcontext fuel table leftCache rightCache hcache + have hprob := congrArg (fun distribution => distribution (some record)) hdist + change Pr[= some record | observeCompatibleNativeRootTrace parameter target before after <$> + runNativeQueryTrace parameter root ftsSecret computation left fuel table leftCache] = + Pr[= some record | observeCompatibleNativeRootTrace parameter target before after <$> + runNativeQueryTrace parameter root ftsSecret computation right fuel table rightCache] at hprob + rw [probOutput_observeCompatibleNativeRootTrace_eq_of_compatible parameter target before after _ record hafter] at hprob + have hswap : observeCompatibleNativeRootTrace parameter target before after (α := α) = + observeCompatibleNativeRootTrace parameter target after before := + funext (observeCompatibleNativeRootTrace_swap parameter target before after) + rw [hswap, probOutput_observeCompatibleNativeRootTrace_eq_of_compatible parameter target after before _ record hbefore] at hprob + exact hprob + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootReserve.lean new file mode 100644 index 00000000..46227c67 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootReserve.lean @@ -0,0 +1,133 @@ +import SphincsSecurity.Proof.OtsProbeInitializedGameCharge +import SphincsSecurity.Proof.OtsProbeSelectedRootPrehit + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem remainingOtsQueryReserve_eq_refined_of_atEncodingPosition + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) + (position : EncodingPosition) (hat : AtEncodingPosition secretKey.parameter input position) : + remainingOtsQueryReserve secretKey cache input = otsOpeningRefinedQueryReserve secretKey cache input := by + apply remainingOtsQueryReserve_eq_refined_of_not_ots + rintro ⟨target, _hots, htarget⟩ + exact hat.not_atPosition target htarget + +theorem EncodingLayerRootCandidateAt.remainingReserve_eq_refined + {secretKey : SecretKey} (cache : QueryCache HashSpec) {input : HashInput} {candidate : Probe} + (hcandidate : EncodingLayerRootCandidateAt secretKey.parameter input candidate) : + remainingOtsQueryReserve secretKey cache input = otsOpeningRefinedQueryReserve secretKey cache input := by + obtain ⟨position, index, hat, _⟩ := hcandidate + exact remainingOtsQueryReserve_eq_refined_of_atEncodingPosition secretKey cache input position hat + +theorem DeferredComputationsClosed.remainingReserve_of_encoding_candidate + {secretKey : SecretKey} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache actualCache : QueryCache HashSpec} + (hclosed : DeferredComputationsClosed context) + (hinvariant : ResolvedContextInvariant secretKey.parameter table context ordinaryCache actualCache) + (hsecrets : secretKey.otsSecret = fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + {input : HashInput} {candidate : Probe} {target : Position} {output : HashOutput} + (hcandidate : EncodingLayerRootCandidateAt secretKey.parameter input candidate) + (hposition : candidate.coordinate = .position target) (hvalue : context.positionValue target = some output) : + (4 / 3 : ENNReal) ≤ remainingOtsQueryReserve secretKey actualCache input := by + rw [hcandidate.remainingReserve_eq_refined actualCache] + exact hclosed.refinedReserve_of_encoding_candidate hinvariant hsecrets hcandidate hposition hvalue + +theorem ensuredInitialContext_computed (targets : Finset Position) : + DeferredComputationsClosed (ensuredInitialContext targets) := + deferredComputationsClosed_empty.of_positionValue_eq (fun _ => rfl) + +theorem relTriple_nativeChronological_computed_prehit + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (accountingKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (state : ViewedFullTraceState × Bool) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) state.1.cache) + (hvisible : VisibleResolvedComputationsCached parameter table context state.1.cache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + RelTriple + (runResolvedFromTable context fuel table + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache)) + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run state) + (fun left right => ReachableResolvedRunRel parameter table left (right.1, right.2.1.cache) ∧ + (∀ result, left = some result → DeferredComputationsClosed result.context) ∧ + right ∈ support ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run state)) := by + dsimp only + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + have hnative := reachableResolvedCouples_simulateQ + (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) (unloggedMappedAdversaryImpl secretKey) + (reachableResolvedCouples_chronologicalNative_concrete parameter root table ftsSecret) computation + context fuel cache state.1.cache hinvariant hvisible hpublished + have hsupported := FtsProbeSimulation.relTriple_and_left_support hnative + (fun left => ∀ result, left = some result → DeferredComputationsClosed result.context) (by + intro left hleft result heq + subst left + exact hcomputed.of_mem_runResolved _ context fuel table result hleft) + have hprojection := encodingPrehitViewedAdversaryImpl_cache_projection accountingKey secretKey computation state + have hmonitor := relTriple_of_evalDist_map_eq_with_support_general + ((simulateQ (unloggedMappedAdversaryImpl secretKey) computation).run state.1.cache) + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run state) + id (fun result => (result.1, result.2.1.cache)) (by + simpa only [id_map] using congrArg evalDist hprojection.symm) + apply relTriple_post_mono (relTriple_trans_exists hsupported hmonitor) + rintro left right ⟨actual, hrelation, heq, _hactual, hsupport⟩ + exact ⟨heq ▸ hrelation.1, hrelation.2, hsupport⟩ + +def LiveNativeStoredRootMatch (lay : Layer) (tree : TreeIndex) (candidate : Digest) : + Option (ResolvedRunResult α) → Prop + | none => False + | some result => DeferredCompletable result.table result.context ∧ + ∃ output, result.context.positionValue (layerRootPosition lay tree) = some output ∧ truncateHash output = candidate + +theorem probEvent_nativeStoredRootMatch_le_prehit_of_insufficientRemainingReserve + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (candidate : Probe) (lay : Layer) (tree : TreeIndex) + (hcandidate : EncodingLayerRootCandidateAt parameter input candidate) + (hposition : candidate.coordinate = .position (layerRootPosition lay tree)) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (state : ViewedFullTraceState) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) state.cache) + (hvisible : VisibleResolvedComputationsCached parameter table context state.cache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + remainingOtsQueryReserve secretKey state.cache input < (4 / 3 : ENNReal) → + Pr[LiveNativeStoredRootMatch lay tree candidate.candidate | runResolvedFromTable context fuel table + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next)).run cache)] ≤ + Pr[fun result => result.2.2 = true | + (simulateQ (encodingPrehitViewedAdversaryImpl secretKey secretKey) + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next)).run (state, false)] := by + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + dsimp only + intro hreserve + have hcoupling := relTriple_nativeChronological_computed_prehit parameter root table ftsSecret secretKey + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next) context fuel cache (state, false) + hinvariant hvisible hpublished hcomputed + apply probEvent_le_of_relTriple hcoupling + rintro result ⟨value, finalState, hit⟩ hrelation hmatch + cases hit with + | true => rfl + | false => + cases result with + | none => exact False.elim hmatch + | some result => + obtain ⟨hcomplete, output, hvalue, hmatch⟩ := hmatch + rcases hrelation.1 with hclean | hdoomed + · have hroot := (hrelation.2.1 result rfl).root_settled_value hclean.2.2.1 ftsSecret lay tree output hvalue + have hallowance := hcandidate.refinedReserve_of_prehitFree_viewed_matching_query secretKey + (accountingKey := secretKey) hposition hroot.1 (hmatch.symm.trans hroot.2.symm) next value hrelation.2.2 + rw [← hcandidate.remainingReserve_eq_refined (secretKey := secretKey) state.cache] at hallowance + exact False.elim ((not_le_of_gt hreserve) hallowance) + · exact False.elim (hdoomed.2.2.2 (hdoomed.1 ▸ hcomplete)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootSigner.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootSigner.lean new file mode 100644 index 00000000..08ededec --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootSigner.lean @@ -0,0 +1,274 @@ +import SphincsSecurity.Proof.OtsProbeNativeStoredRoot + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +def RootEncodingStoredNativeSameRel + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) : + Option (ResolvedRunResult (α × SplitHashCache)) → + Option (ResolvedRunResult (α × SplitHashCache)) → Prop + | some left, some right => + RootEncodingNativeSameRel parameter target leftRoot rightRoot (some left) (some right) ∧ + StoredNativeLayerRoot left.context target leftRoot + | none, none => True + | _, _ => False + +def RootEncodingNativeRelatesStored + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftCache rightCache, + RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache → + ∀ state fuel table, StoredNativeLayerRoot state target leftRoot → + RelTriple + (runResolvedFromTable state fuel table (left.run leftCache)) + (runResolvedFromTable state fuel table (right.run rightCache)) + (RootEncodingStoredNativeSameRel parameter target leftRoot rightRoot) + +theorem relTriple_native_rootEncoding_add_stored + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (leftCache rightCache : SplitHashCache) + (state : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hrelation : RelTriple + (runResolvedFromTable state fuel table (left.run leftCache)) + (runResolvedFromTable state fuel table (right.run rightCache)) + (RootEncodingNativeSameRel parameter target leftRoot rightRoot)) + (hstored : StoredNativeLayerRoot state target leftRoot) : + RelTriple + (runResolvedFromTable state fuel table (left.run leftCache)) + (runResolvedFromTable state fuel table (right.run rightCache)) + (RootEncodingStoredNativeSameRel parameter target leftRoot rightRoot) := by + let leftRun := runResolvedFromTable state fuel table (left.run leftCache) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hrelation + (fun result => result ∈ support leftRun) (fun result hresult => hresult) + apply relTriple_post_mono hsupported + intro leftResult rightResult hresult + rcases hresult with ⟨hrel, hleftSupport⟩ + cases leftResult with + | none => + cases rightResult with + | none => trivial + | some rightResult => simp [RootEncodingNativeSameRel] at hrel + | some leftResult => + cases rightResult with + | none => simp [RootEncodingNativeSameRel] at hrel + | some rightResult => + exact ⟨hrel, storedNativeLayerRoot_of_mem_runResolved (left.run leftCache) + state fuel table leftResult target leftRoot hstored hleftSupport⟩ + +theorem RootEncodingNativeRelates.toStored + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} + {left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + (hrel : RootEncodingNativeRelates parameter target leftRoot rightRoot left right) : + RootEncodingNativeRelatesStored parameter target leftRoot rightRoot left right := by + intro leftCache rightCache hcache state fuel table hstored + exact relTriple_native_rootEncoding_add_stored parameter target leftRoot rightRoot left right + leftCache rightCache state fuel table + (hrel leftCache rightCache hcache state fuel table) hstored + +theorem RootEncodingNativeRelatesStored.bind + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {leftNext rightNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hfirst : RootEncodingNativeRelatesStored parameter target leftRoot rightRoot left right) + (hnext : ∀ leftValue rightValue, leftValue = rightValue → + RootEncodingNativeRelatesStored parameter target leftRoot rightRoot + (leftNext leftValue) (rightNext rightValue)) : + RootEncodingNativeRelatesStored parameter target leftRoot rightRoot + (left >>= leftNext) (right >>= rightNext) := by + intro leftCache rightCache hcache state fuel table hstored + rw [StateT.run_bind, StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_bind] + apply relTriple_bind (hfirst leftCache rightCache hcache state fuel table hstored) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [RootEncodingStoredNativeSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootEncodingStoredNativeSameRel] at hresult + | some rightResult => + rcases hresult with + ⟨⟨hstate, hremaining, htable, hvalue, hnextCache⟩, hnextStored⟩ + simp only + rw [← hstate, ← hremaining, ← htable, ← hvalue] + exact hnext leftResult.value.1 leftResult.value.1 rfl leftResult.value.2 + rightResult.value.2 hnextCache leftResult.context leftResult.remaining + leftResult.table hnextStored + +theorem rootEncodingNativeRelatesStored_sequenceFin + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) {n : Nat} + (left right : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, + RootEncodingNativeRelatesStored parameter target leftRoot rightRoot + (left index) (right index)) : + RootEncodingNativeRelatesStored parameter target leftRoot rightRoot + (sequenceFin left) (sequenceFin right) := by + induction n with + | zero => + simp only [sequenceFin] + exact ((rootEncodingNativeCouples_pure parameter target leftRoot rightRoot + Fin.elim0).relates).toStored + | succ n ih => + rw [sequenceFin, sequenceFin] + exact (hcomponent 0).bind fun leftHead rightHead hhead => + (ih (fun index : Fin n => left index.succ) (fun index : Fin n => right index.succ) + (fun index => hcomponent index.succ)).bind fun leftTail rightTail htail => by + subst rightHead + subst rightTail + exact ((rootEncodingNativeCouples_pure parameter target leftRoot rightRoot + (Fin.cases leftHead leftTail : Fin (n + 1) → α)).relates).toStored + +theorem rootEncodingNativeCouples_maskedSignLayer_of_layerMessagePosition_ne + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) + (hne : layerMessagePosition index lay ≠ target) : + RootEncodingNativeCouples parameter target leftRoot rightRoot + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + apply (rootEncodingNativeCouples_maskedLayerMessage parameter target leftRoot rightRoot + ftsSecret index lay).bind + intro message + exact rootEncodingNativeCouples_maskedOtsLayerAfterMessage_of_not_positionNames parameter + target leftRoot rightRoot index lay message + (not_encodingPositionNamesRoot_of_layerMessagePosition_ne target index lay hne) + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_native_maskedSignLayer_comparisonRoot_of_message + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) (hnotBottom : lay ≠ bottomLayer) + (leftRoot rightRoot : Digest) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter (layerMessagePosition index lay) + leftRoot rightRoot leftCache rightCache) + (state : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hmessageRoot : ∀ result, + some result ∈ support (runResolvedFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run leftCache)) → + result.value.1 = leftRoot) : + RelTriple + (runResolvedFromTable state fuel table + ((maskedSignLayer parameter ftsSecret index lay).run leftCache)) + (runResolvedFromTable state fuel table + ((maskedSignLayerWithComparisonRoot parameter ftsSecret index lay rightRoot).run + rightCache)) + (RootEncodingNativeSameRel parameter (layerMessagePosition index lay) + leftRoot rightRoot) := by + unfold maskedSignLayer maskedSignLayerWithComparisonRoot + change RelTriple + (runResolvedFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay >>= fun message => + maskedOtsLayerAfterMessage parameter index lay message).run leftCache)) + (runResolvedFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay >>= fun _ => + maskedOtsLayerAfterMessage parameter index lay rightRoot).run rightCache)) _ + rw [StateT.run_bind, StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_bind] + let leftMessageRun := runResolvedFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run leftCache) + have hmessages := rootEncodingNativeCouples_maskedLayerMessage parameter + (layerMessagePosition index lay) leftRoot rightRoot ftsSecret index lay + leftCache rightCache hcache state fuel table + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hmessages + (fun result => result ∈ support leftMessageRun) (fun result hresult => hresult) + apply relTriple_bind hsupported + intro leftResult rightResult hresult + rcases hresult with ⟨hrelation, hleftSupport⟩ + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [RootEncodingNativeSameRel] at hrelation + | some leftResult => + cases rightResult with + | none => simp [RootEncodingNativeSameRel] at hrelation + | some rightResult => + rcases hrelation with ⟨hstate, hremaining, htable, _hmessage, hnextCache⟩ + have hactual := hmessageRoot leftResult hleftSupport + simp only + rw [← hstate, ← hremaining, ← htable, hactual] + exact rootEncodingNativeRelates_maskedOtsLayerAfterMessage parameter index lay + hnotBottom leftRoot rightRoot leftResult.value.2 rightResult.value.2 hnextCache + leftResult.context leftResult.remaining leftResult.table + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_native_maskedSignLayer_targetComparison + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (state : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hmessageRoot : layerMessagePosition index lay = target → ∀ result, + some result ∈ support (runResolvedFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run leftCache)) → + result.value.1 = leftRoot) : + RelTriple + (runResolvedFromTable state fuel table + ((maskedSignLayer parameter ftsSecret index lay).run leftCache)) + (runResolvedFromTable state fuel table + ((maskedSignLayerWithTargetComparison parameter target rightRoot ftsSecret index lay).run + rightCache)) + (RootEncodingNativeSameRel parameter target leftRoot rightRoot) := by + by_cases htarget : layerMessagePosition index lay = target + · rw [maskedSignLayerWithTargetComparison, if_pos htarget] + rw [← htarget] at hcache ⊢ + exact relTriple_native_maskedSignLayer_comparisonRoot_of_message parameter ftsSecret index lay + (layer_ne_bottom_of_layerMessagePosition_isLayerRoot htarget hroot) leftRoot rightRoot + leftCache rightCache hcache state fuel table (hmessageRoot htarget) + · rw [maskedSignLayerWithTargetComparison, if_neg htarget] + exact (rootEncodingNativeCouples_maskedSignLayer_of_layerMessagePosition_ne parameter target + leftRoot rightRoot ftsSecret index lay htarget).relates leftCache rightCache hcache + state fuel table + +theorem rootEncodingNativeRelatesStored_maskedSignLayer_targetComparison + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + RootEncodingNativeRelatesStored parameter target leftRoot rightRoot + (maskedSignLayer parameter ftsSecret index lay) + (maskedSignLayerWithTargetComparison parameter target rightRoot ftsSecret index lay) := by + intro leftCache rightCache hcache state fuel table hstored + have hbase := relTriple_native_maskedSignLayer_targetComparison parameter target hroot leftRoot + rightRoot ftsSecret index lay leftCache rightCache hcache state fuel table + (fun htarget result hresult => + maskedLayerMessage_value_eq_of_stored_native parameter ftsSecret target hroot leftRoot + index lay state leftCache fuel table result hstored htarget hresult) + exact relTriple_native_rootEncoding_add_stored parameter target leftRoot rightRoot + (maskedSignLayer parameter ftsSecret index lay) + (maskedSignLayerWithTargetComparison parameter target rightRoot ftsSecret index lay) + leftCache rightCache state fuel table hbase hstored + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootSource.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootSource.lean new file mode 100644 index 00000000..68785ceb --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootSource.lean @@ -0,0 +1,206 @@ +import SphincsSecurity.Proof.OtsProbeSettledNativeValue +import SphincsSecurity.Proof.OtsProbeLiveKnownRootCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +set_option maxRecDepth 100000 in +theorem EncodingLayerRootCandidateAt.settled_of_prehitFree_matching_query + {secretKey : SecretKey} {initialCache finalCache : QueryCache HashSpec} + {input : HashInput} {candidate : Probe} {target : Position} + (hcandidate : EncodingLayerRootCandidateAt secretKey.parameter input candidate) + (hposition : candidate.coordinate = .position target) + (hafter : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret finalCache target) + (hmatch : candidate.candidate = honestValue (fromCache finalCache) + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret target) + (next : HashOutput → OracleComp OracleWorld α) (value : α) + (hrun : ((value, finalCache), false) ∈ support + (TightEncoding.runEncodingPrehitMonitor secretKey (OracleWorld.query (.inr input) >>= next) initialCache false)) : + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret initialCache target := by + obtain ⟨position, index, hat, htree, hleaf, _hnotBottom, rfl⟩ := hcandidate + have heq : layerMessagePosition index position.lay = target := Coordinate.position.inj hposition + subst target + obtain ⟨otherIndex, hotherTree, hotherLeaf, hsettled⟩ := + TightEncoding.encodingMessageSettledAt_of_prehitFree_matching_query secretKey position index input + htree hleaf hat next initialCache value finalCache hafter hmatch hrun + have hsame := layerMessagePosition_eq_of_position_eq otherIndex index position.lay + (hotherTree.trans htree.symm) (hotherLeaf.trans hleaf.symm) + rwa [hsame] at hsettled + +theorem EncodingLayerRootCandidateAt.settled_of_prehitFree_viewed_matching_query + {accountingKey : SecretKey} (secretKey : SecretKey) + {initialState finalState : ViewedFullTraceState} + {input : HashInput} {candidate : Probe} {target : Position} + (hcandidate : EncodingLayerRootCandidateAt accountingKey.parameter input candidate) + (hposition : candidate.coordinate = .position target) + (hafter : Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret finalState.cache target) + (hmatch : candidate.candidate = honestValue (fromCache finalState.cache) + accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret target) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) (value : α) + (hrun : (value, (finalState, false)) ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next)).run (initialState, false))) : + Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret initialState.cache target := by + obtain ⟨log, hmonitor, _⟩ := encodingPrehitViewedAdversaryImpl_support_monitor accountingKey secretKey + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next) (initialState, false) (value, (finalState, false)) hrun + have hcomputation : + ((simulateQ (forwardOracles + signingOracle scheme secretKey) + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next)).run) = + ((liftM (OracleWorld.query (.inr input)) : OracleComp OracleWorld HashOutput) >>= fun answer => + (simulateQ (forwardOracles + signingOracle scheme secretKey) (next answer)).run) := by + have hquery : (((forwardOracles + signingOracle scheme secretKey) (.inl (.inr input))).run) = + (fun output => (output, ([] : QueryLog SigningSpec))) <$> + (liftM (OracleWorld.query (.inr input)) : OracleComp OracleWorld HashOutput) := rfl + rw [simulateQ_bind, WriterT.run_bind', simulateQ_spec_query, hquery] + erw [bind_map_left] + apply bind_congr + intro answer + change (fun result : α × QueryLog SigningSpec => (result.1, [] ++ result.2)) <$> + (simulateQ (forwardOracles + signingOracle scheme secretKey) (next answer)).run = _ + simp + rw [hcomputation] at hmonitor + exact hcandidate.settled_of_prehitFree_matching_query hposition hafter hmatch + (fun answer => (simulateQ (forwardOracles + signingOracle scheme secretKey) (next answer)).run) (value, log) hmonitor + +theorem knownNativeRoot_at_source_of_prehitFree_matching_query + (secretKey : SecretKey) (table : OtsSecretIndex → HashOutput) + (initialContext finalContext : DeferredContext) (initialOrdinaryCache finalOrdinaryCache : QueryCache HashSpec) + (initialState finalState : ViewedFullTraceState) + (hinitial : ResolvedContextInvariant secretKey.parameter table initialContext initialOrdinaryCache initialState.cache) + (hfinal : ResolvedContextInvariant secretKey.parameter table finalContext finalOrdinaryCache finalState.cache) + (hcomputed : DeferredComputationsClosed finalContext) + (hsecrets : secretKey.otsSecret = fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + (input : HashInput) (candidate : Probe) (lay : Layer) (tree : TreeIndex) (output : HashOutput) + (hcandidate : EncodingLayerRootCandidateAt secretKey.parameter input candidate) + (hposition : candidate.coordinate = .position (layerRootPosition lay tree)) + (hvalue : finalContext.positionValue (layerRootPosition lay tree) = some output) + (hmatch : candidate.candidate = truncateHash output) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) (value : α) + (hrun : (value, (finalState, false)) ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl secretKey secretKey) + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next)).run (initialState, false))) : + ∃ initialOutput, initialContext.positionValue (layerRootPosition lay tree) = some initialOutput ∧ + candidate.candidate = truncateHash initialOutput := by + have hroot := hcomputed.root_settled_value hfinal secretKey.ftsSecret lay tree output hvalue + have hsettled : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret finalState.cache (layerRootPosition lay tree) := by + simpa only [hsecrets] using hroot.1 + have hrootValue : honestValue (fromCache finalState.cache) secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (layerRootPosition lay tree) = truncateHash output := by + simpa only [hsecrets] using hroot.2 + have hbefore := hcandidate.settled_of_prehitFree_viewed_matching_query secretKey hposition hsettled + (hmatch.trans hrootValue.symm) next value hrun + obtain ⟨initialOutput, houtput, hinitialValue⟩ := hinitial.positionValue_of_settled hsecrets + (by trivial : IsOtsPosition (layerRootPosition lay tree)) hbefore + obtain ⟨log, hmonitor, _⟩ := encodingPrehitViewedAdversaryImpl_support_monitor secretKey secretKey + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next) (initialState, false) (value, (finalState, false)) hrun + have hcacheLe := TightEncoding.cache_le_of_mem_runEncodingPrehitMonitor _ _ _ _ _ hmonitor + have hvalueEq := honestValue_eq_of_settled (agreesWithFn_fromCache_of_le hcacheLe) hbefore + exact ⟨initialOutput, houtput, hmatch.trans (hrootValue.symm.trans (hvalueEq.trans hinitialValue))⟩ + +theorem probEvent_nativeStoredRootMatch_le_prehit_of_no_initial_match + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (candidate : Probe) (lay : Layer) (tree : TreeIndex) + (hcandidate : EncodingLayerRootCandidateAt parameter input candidate) + (hposition : candidate.coordinate = .position (layerRootPosition lay tree)) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (state : ViewedFullTraceState) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) state.cache) + (hvisible : VisibleResolvedComputationsCached parameter table context state.cache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) + (hnomatch : ∀ output, context.positionValue (layerRootPosition lay tree) = some output → + candidate.candidate ≠ truncateHash output) : + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + Pr[LiveNativeStoredRootMatch lay tree candidate.candidate | runResolvedFromTable context fuel table + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next)).run cache)] ≤ + Pr[fun result => result.2.2 = true | + (simulateQ (encodingPrehitViewedAdversaryImpl secretKey secretKey) + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next)).run (state, false)] := by + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + dsimp only + have hcoupling := relTriple_nativeChronological_computed_prehit parameter root table ftsSecret secretKey + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next) context fuel cache (state, false) + hinvariant hvisible hpublished hcomputed + apply probEvent_le_of_relTriple hcoupling + rintro result ⟨value, finalState, hit⟩ hrelation hmatch + cases hit with + | true => rfl + | false => + cases result with + | none => exact False.elim hmatch + | some result => + obtain ⟨hcomplete, output, hvalue, hmatch⟩ := hmatch + rcases hrelation.1 with hclean | hdoomed + · obtain ⟨initialOutput, houtput, heq⟩ := knownNativeRoot_at_source_of_prehitFree_matching_query + secretKey table context result.context (ordinaryQueryCache cache) (ordinaryQueryCache result.value.2) + state finalState hinvariant hclean.2.2.1 (hrelation.2.1 result rfl) rfl input candidate lay tree output + hcandidate hposition hvalue hmatch.symm next value hrelation.2.2 + exact False.elim (hnomatch initialOutput houtput heq) + · rw [hdoomed.1] at hcomplete + exact False.elim (hdoomed.2.2.2 hcomplete) + +def LiveNativeHiddenRootMatch (lay : Layer) (tree : TreeIndex) (candidate : Digest) + (result : Option (ResolvedRunResult α)) : Prop := + LiveNativeStoredRootMatch lay tree candidate result ∧ + match result with + | none => False + | some result => .position (layerRootPosition lay tree) ∉ result.context.state.revealed + +theorem probEvent_nativeHiddenRootMatch_le_prehit_of_not_known_source + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (candidate : Probe) (lay : Layer) (tree : TreeIndex) + (hcandidate : EncodingLayerRootCandidateAt parameter input candidate) + (hposition : candidate.coordinate = .position (layerRootPosition lay tree)) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (state : ViewedFullTraceState) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) state.cache) + (hvisible : VisibleResolvedComputationsCached parameter table context state.cache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) + (hnot : ¬KnownHiddenEncodingRootQuery parameter input context) : + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + Pr[LiveNativeHiddenRootMatch lay tree candidate.candidate | runResolvedFromTable context fuel table + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next)).run cache)] ≤ + Pr[fun result => result.2.2 = true | + (simulateQ (encodingPrehitViewedAdversaryImpl secretKey secretKey) + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next)).run (state, false)] := by + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + dsimp only + have hbase := relTriple_nativeChronological_computed_prehit parameter root table ftsSecret secretKey + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next) context fuel cache (state, false) + hinvariant hvisible hpublished hcomputed + have hcoupling := FtsProbeSimulation.relTriple_and_left_support hbase + (fun left => ∀ result, left = some result → context.state.revealed ⊆ result.context.state.revealed) (by + intro left hleft result heq + subst left + exact revealed_subset_of_mem_runResolvedFromTable _ context fuel table result hleft) + apply probEvent_le_of_relTriple hcoupling + rintro result ⟨value, finalState, hit⟩ hrelation hmatch + cases hit with + | true => rfl + | false => + cases result with + | none => exact False.elim hmatch.1 + | some result => + obtain ⟨⟨hcomplete, output, hvalue, hmatch⟩, hhidden⟩ := hmatch + rcases hrelation.1.1 with hclean | hdoomed + · obtain ⟨initialOutput, houtput, _heq⟩ := knownNativeRoot_at_source_of_prehitFree_matching_query + secretKey table context result.context (ordinaryQueryCache cache) (ordinaryQueryCache result.value.2) + state finalState hinvariant hclean.2.2.1 (hrelation.1.2.1 result rfl) rfl input candidate lay tree output + hcandidate hposition hvalue hmatch.symm next value hrelation.1.2.2 + exact False.elim (hnot ⟨candidate, layerRootPosition lay tree, initialOutput, hcandidate, hposition, + houtput, fun hrevealed => hhidden (hrelation.2 result rfl hrevealed)⟩) + · rw [hdoomed.1] at hcomplete + exact False.elim (hdoomed.2.2.2 hcomplete) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootState.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootState.lean new file mode 100644 index 00000000..fc47cdeb --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootState.lean @@ -0,0 +1,158 @@ +import SphincsSecurity.Proof.OtsProbeNativeValueObservation + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +structure NativeRootContextRel (target : Position) (before after : HashOutput) + (left right : DeferredContext) : Prop where + replaceable : NativePositionReplaceable target before after left + right_eq : right = replaceNativePosition target after left + +theorem NativeRootContextRel.ensure + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) (coordinate : Coordinate) : + NativeRootContextRel target before after + { left with state := left.state.ensure coordinate } + { right with state := right.state.ensure coordinate } := by + refine ⟨⟨h.replaceable.known, h.replaceable.consistent.ensure coordinate, + h.replaceable.beforeMiss, h.replaceable.afterMiss⟩, ?_⟩ + rw [h.right_eq] + rfl + +theorem NativeRootContextRel.publish + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) (coordinate : Coordinate) : + NativeRootContextRel target before after + { left with state := left.state.publish coordinate } + { right with state := right.state.publish coordinate } := by + refine ⟨⟨h.replaceable.known, h.replaceable.consistent.publish coordinate, + h.replaceable.beforeMiss, h.replaceable.afterMiss⟩, ?_⟩ + rw [h.right_eq] + rfl + +theorem RootHiddenCacheRel.right_eq_replace + {target : Position} {before after : HashOutput} {left right : SplitHashCache} + (h : RootHiddenCacheRel target before after left right) : + right = replaceHiddenRootCache target after left := by + funext key + cases key with + | ordinary input => simpa [replaceHiddenRootCache] using (h.ordinary input).symm + | hidden coordinate => + by_cases heq : coordinate = .position target + · subst coordinate + simpa [replaceHiddenRootCache] using h.right_target + · simpa [replaceHiddenRootCache, heq] using (h.other_hidden coordinate heq).symm + +theorem NativePositionReplaceable.of_materialized_chainStart + {target : Position} {before after : HashOutput} {context : DeferredContext} + (h : NativePositionReplaceable target before after context) + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + NativePositionReplaceable target before after (materializeResolvedChainStart context index result) := by + refine ⟨?_, h.consistent.materializeResolvedChainStart_of table index result hresult, ?_, ?_⟩ + · rw [materializeResolvedChainStart_positionValue_eq table index context result hresult] + exact h.known + all_goals + intro hhit + simp only [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff, + materializeResolvedChainStart, LazyRevealProbe.State.materialize, + LazyRevealProbe.State.pendingAway, Finset.mem_filter] at hhit + first + | apply h.beforeMiss + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff] using hhit.1 + | apply h.afterMiss + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff] using hhit.1 + +theorem nativeRevealOutput_support + (target : Position) (before after : HashOutput) (context : DeferredContext) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (cache : SplitHashCache) (h : NativePositionReplaceable target before after context) + (result : ResolvedRunResult (HashOutput × SplitHashCache)) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table ((revealCoordinateOutput coordinate).run cache))) : + NativePositionReplaceable target before after result.context ∧ + result.value.2 = Function.update cache (.hidden coordinate) (some result.value.1) := by + rw [runResolvedFromTable_revealCoordinateOutput] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + cases hresolved : resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context with + | none => simp [hresolved] at hresult + | some resolved => + simp [hresolved] at hresult + subst result + exact ⟨h.of_materialized_chainStart table ⟨lay, tree, leafIdx, chainIdx⟩ resolved hresolved, rfl⟩ + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + simp at hrest + subst result + exact ⟨h.of_materialized_reveal position table resolved hresolved, rfl⟩ + +def NativeRootRevealOutputRel (target : Position) (before after : HashOutput) (coordinate : Coordinate) : + Option (ResolvedRunResult (HashOutput × SplitHashCache)) → + Option (ResolvedRunResult (HashOutput × SplitHashCache)) → Prop + | some left, some right => + NativeRootContextRel target before after left.context right.context ∧ + left.remaining = right.remaining ∧ left.table = right.table ∧ + right.value.1 = (if coordinate = .position target then after else left.value.1) ∧ + (coordinate = .position target → left.value.1 = before) ∧ + RootHiddenCacheRel target before after left.value.2 right.value.2 + | none, none => True + | _, _ => False + +theorem relTriple_nativeRoot_revealCoordinateOutput + (target : Position) (before after : HashOutput) (coordinate : Coordinate) + (left right : DeferredContext) (hcontext : NativeRootContextRel target before after left right) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target before after leftCache rightCache) : + RelTriple + (runResolvedFromTable left fuel table ((revealCoordinateOutput coordinate).run leftCache)) + (runResolvedFromTable right fuel table ((revealCoordinateOutput coordinate).run rightCache)) + (NativeRootRevealOutputRel target before after coordinate) := by + rw [hcontext.right_eq, hcache.right_eq_replace] + apply relTriple_of_evalDist_eq_right + (evalDist_revealCoordinateOutput_replaceNativePosition target before after left fuel table + coordinate leftCache hcontext.replaceable).symm + let run := runResolvedFromTable left fuel table ((revealCoordinateOutput coordinate).run leftCache) + have hcoupling := FtsProbeSimulation.relTriple_and_left_support (relTriple_refl run) + (fun result => result ∈ support run) (fun _ hresult => hresult) + have hpost : RelTriple run run (fun leftResult rightResult => + NativeRootRevealOutputRel target before after coordinate leftResult + (Option.map (replaceNativeRevealRunResult target after coordinate) rightResult)) := by + apply relTriple_post_mono hcoupling + intro leftResult rightResult hrel + rcases hrel with ⟨heq, hsupported⟩ + subst rightResult + cases leftResult with + | none => trivial + | some result => + obtain ⟨hnext, hnextCache⟩ := nativeRevealOutput_support target before after left fuel table + coordinate leftCache hcontext.replaceable result hsupported + have hvalue : coordinate = .position target → result.value.1 = before := by + intro heq + subst coordinate + have hstate := value_of_mem_runResolvedFromTable_revealCoordinateOutput left fuel table + (.position target) leftCache result hsupported + simpa [DeferredContext.positionValue, hstate] using hnext.known + have hcached : result.value.2 (.hidden (.position target)) = some before := by + rw [hnextCache] + by_cases heq : coordinate = .position target + · simp [heq, hvalue heq] + · have hkey : SplitHashKey.hidden (.position target) ≠ .hidden coordinate := by + simpa using Ne.symm heq + rw [Function.update_of_ne hkey] + exact hcache.left_target + exact ⟨⟨hnext, rfl⟩, rfl, rfl, rfl, hvalue, + rootHiddenCacheRel_replace target before after result.value.2 hcached⟩ + simpa only [id_map] using + (relTriple_map (f := id) (g := Option.map (replaceNativeRevealRunResult target after coordinate)) hpost) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootStateChronological.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootStateChronological.lean new file mode 100644 index 00000000..362997ef --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootStateChronological.lean @@ -0,0 +1,137 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootStateSigner + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +theorem nativeRootRelates_revealPrivateLayerValues + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + NativeRootRelates target leftOutput rightOutput + (revealPrivateLayerValues index lay encoding) (revealPrivateLayerValues index lay encoding) := by + unfold revealPrivateLayerValues + apply (nativeRootRelates_sequenceFin target leftOutput rightOutput _ _ fun chainIdx => + nativeRootRelates_revealCoordinate_of_ne target leftOutput rightOutput + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + (encoding chainIdx)) + (chainValueCoordinate_ne_layerRoot hroot lay (treeIndexAt index lay) + (leafIndexAt index lay) chainIdx (encoding chainIdx))).bind + intro leftValues rightValues hvalues + subst rightValues + apply (nativeRootRelates_sequenceFin target leftOutput rightOutput _ _ fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + cases hzero : level.val with + | zero => + exact nativeRootRelates_revealCoordinate_of_ne target leftOutput rightOutput + (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) (by + obtain ⟨rootLay, rootTree, rfl⟩ := hroot + simp [layerRootPosition]) + | succ current => + rw [Nat.add_one] + simp only + by_cases hcurrent : current < maxLayerHeight + · rw [dif_pos hcurrent] + exact nativeRootRelates_revealCoordinate_of_ne target leftOutput rightOutput + (.position (.node lay (treeIndexAt index lay) ⟨current, hcurrent⟩ + (leafOfNat (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + (by + intro heq + exact (pathNode_ne_layerRoot hroot lay (treeIndexAt index lay) current hcurrent _ + (by omega)) (Coordinate.position.inj heq)) + · rw [dif_neg hcurrent] + exact nativeRootRelates_pure target leftOutput rightOutput 0 + · rw [if_neg hlevel] + exact nativeRootRelates_pure target leftOutput rightOutput 0).bind + intro leftPath rightPath hpath + subst rightPath + exact nativeRootRelates_pure target leftOutput rightOutput (leftValues, leftPath) + +theorem nativeRootRelates_chronologicalSignLayer_comparison_actual + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) + (before after : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + NativeRootRelates target before after + (maskedChronologicalSignLayerWithTargetComparison parameter target (truncateHash after) ftsSecret index lay) + (maskedChronologicalSignLayer parameter ftsSecret index lay) := by + unfold maskedChronologicalSignLayer maskedChronologicalSignLayerWithTargetComparison + apply (nativeRootRelates_maskedSignLayerWithTargetComparison_actual parameter ftsSecret target hroot + before after index lay).bind + intro leftSelected rightSelected heq + subst rightSelected + cases leftSelected with + | none => exact nativeRootRelates_pure target before after none + | some selected => + apply (nativeRootRelates_revealPrivateLayerValues target hroot before after index lay selected.2).bind + intro leftValues rightValues heq + subst rightValues + exact nativeRootRelates_pure target before after + (some (⟨selected.1, selected.2, leftValues.1, leftValues.2⟩ : ChronologicalLayerPart)) + +theorem nativeRootRelates_publishChronologicalSignature + (target : Position) (hroot : IsLayerRoot target) (before after : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (layers : Layer → Option ChronologicalLayerPart) : + NativeRootRelates target before after + (publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers) + (publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers) := by + unfold publishChronologicalSignature + cases hparts : traverseOption layers with + | none => exact nativeRootRelates_pure target before after none + | some parts => + apply (nativeRootRelates_sequenceFin target before after _ _ + (fun lay => nativeRootRelates_revealLayerValues target hroot before after index lay (parts lay).encoding)).bind + intro leftValues rightValues heq + subst rightValues + exact nativeRootRelates_pure target before after _ + +theorem nativeRootRelates_chronologicalSignAfterDigest_comparison_actual + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) + (before after : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + NativeRootRelates target before after + (maskedPublishedChronologicalSignAfterDigestWithTargetComparison parameter target (truncateHash after) + ftsSecret randomness index leaves) + (maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedPublishedChronologicalSignAfterDigest + maskedPublishedChronologicalSignAfterDigestWithTargetComparison maskedChronologicalSignLayers + apply (nativeRootRelates_simulateQ target before after ordinaryHashImpl ordinaryHashImpl + (nativeRootRelates_ordinaryHashImpl target before after) (ftsOpen parameter index leaves (ftsSecret index))).bind + intro leftPath rightPath hpath + subst rightPath + apply (nativeRootRelates_sequenceFin target before after _ _ + (fun lay => nativeRootRelates_chronologicalSignLayer_comparison_actual + parameter target hroot before after ftsSecret index lay)).bind + intro leftLayers rightLayers hlayers + subst rightLayers + exact nativeRootRelates_publishChronologicalSignature target hroot before after + ftsSecret randomness index leaves leftPath leftLayers + +theorem nativeRootRelates_chronologicalSign_comparison_actual + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (before after : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + NativeRootRelates target before after + (maskedPublishedChronologicalSignWithTargetComparison parameter root target (truncateHash after) ftsSecret message) + (maskedPublishedChronologicalSign parameter root ftsSecret message) := by + unfold maskedPublishedChronologicalSign maskedPublishedChronologicalSignWithTargetComparison + apply (nativeRootRelates_simulateQ target before after ordinaryRomImpl ordinaryRomImpl + (nativeRootRelates_ordinaryRomImpl target before after) + (signDigestLoop digestAttemptLimit ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ message)).bind + intro leftSelected rightSelected heq + subst rightSelected + cases leftSelected with + | none => exact nativeRootRelates_pure target before after none + | some selected => + exact nativeRootRelates_chronologicalSignAfterDigest_comparison_actual parameter target hroot + before after ftsSecret selected.1 selected.2.1 selected.2.2 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootStateCoupling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootStateCoupling.lean new file mode 100644 index 00000000..546d5ffe --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootStateCoupling.lean @@ -0,0 +1,232 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootState + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +def NativeRootSameRel + (target : Position) (leftOutput rightOutput : HashOutput) : + Option (ResolvedRunResult (α × SplitHashCache)) → + Option (ResolvedRunResult (α × SplitHashCache)) → Prop + | some left, some right => + NativeRootContextRel target leftOutput rightOutput left.context right.context ∧ + left.remaining = right.remaining ∧ left.table = right.table ∧ + left.value.1 = right.value.1 ∧ + RootHiddenCacheRel target leftOutput rightOutput left.value.2 right.value.2 + | none, none => True + | _, _ => False + +def NativeRootRelates + (target : Position) (leftOutput rightOutput : HashOutput) + (left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftState rightState, + NativeRootContextRel target leftOutput rightOutput leftState rightState → + ∀ fuel table leftCache rightCache, + RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache → + RelTriple + (runResolvedFromTable leftState fuel table (left.run leftCache)) + (runResolvedFromTable rightState fuel table (right.run rightCache)) + (NativeRootSameRel target leftOutput rightOutput) + +theorem nativeRootRelates_pure + (target : Position) (leftOutput rightOutput : HashOutput) (value : α) : + NativeRootRelates target leftOutput rightOutput + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + simp only [StateT.run_pure, runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, rfl, hcache⟩ + +theorem NativeRootRelates.bind + {target : Position} {leftOutput rightOutput : HashOutput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {leftNext rightNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hfirst : NativeRootRelates target leftOutput rightOutput left right) + (hnext : ∀ leftValue rightValue, leftValue = rightValue → + NativeRootRelates target leftOutput rightOutput + (leftNext leftValue) (rightNext rightValue)) : + NativeRootRelates target leftOutput rightOutput + (left >>= leftNext) (right >>= rightNext) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + rw [StateT.run_bind, StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_bind] + apply relTriple_bind + (hfirst leftState rightState hstate fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [NativeRootSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [NativeRootSameRel] at hresult + | some rightResult => + rcases hresult with ⟨hnextState, hremaining, htable, hvalue, hnextCache⟩ + simp only + rw [← hremaining, ← htable, ← hvalue] + exact hnext leftResult.value.1 leftResult.value.1 rfl + leftResult.context rightResult.context hnextState leftResult.remaining + leftResult.table leftResult.value.2 rightResult.value.2 hnextCache + +theorem nativeRootRelates_splitUniformImpl + (target : Position) (leftOutput rightOutput : HashOutput) (n : Nat) : + NativeRootRelates target leftOutput rightOutput + (splitUniformImpl n) (splitUniformImpl n) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + unfold splitUniformImpl LazyRevealProbe.uniformQuery + rw [StateT.run_liftM, StateT.run_liftM, + runResolvedFromTable_uniform_query_bind, runResolvedFromTable_uniform_query_bind] + apply relTriple_bind + (relTriple_refl (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))) + intro leftValue rightValue hvalue + subst rightValue + simp only [runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, rfl, hcache⟩ + +theorem nativeRootRelates_splitHashQuery_ordinary + (target : Position) (leftOutput rightOutput : HashOutput) + (input : HashInput) : + NativeRootRelates target leftOutput rightOutput + (splitHashQuery (.ordinary input)) (splitHashQuery (.ordinary input)) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + have hlookup := hcache.ordinary input + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + cases hleft : leftCache (.ordinary input) with + | some output => + have hright : rightCache (.ordinary input) = some output := by + rw [← hlookup] + exact hleft + simp only [hright, runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, rfl, hcache⟩ + | none => + have hright : rightCache (.ordinary input) = none := by + rw [← hlookup] + exact hleft + simp only [hright] + unfold LazyRevealProbe.hashOutputQuery + rw [runResolvedFromTable_hashOutput_query_bind, + runResolvedFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftSample rightSample hsample + subst rightSample + simp only [runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, rfl, + hcache.update_same_ordinary input leftSample⟩ + +theorem nativeRootRelates_ensureCoordinate + (target : Position) (before after : HashOutput) (coordinate : Coordinate) : + NativeRootRelates target before after (ensureCoordinate coordinate) (ensureCoordinate coordinate) := by + intro left right hstate fuel table leftCache rightCache hcache + change RelTriple + (runResolvedFromTable left fuel table (LazyRevealProbe.ensureQuery coordinate >>= fun value => pure (value, leftCache))) + (runResolvedFromTable right fuel table (LazyRevealProbe.ensureQuery coordinate >>= fun value => pure (value, rightCache))) _ + rw [LazyRevealProbe.ensureQuery, runResolvedFromTable_ensure_query_bind, runResolvedFromTable_ensure_query_bind] + simp only [runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate.ensure coordinate, rfl, rfl, rfl, hcache⟩ + +theorem nativeRootRelates_revealCoordinate_of_ne + (target : Position) (before after : HashOutput) (coordinate : Coordinate) + (hne : coordinate ≠ .position target) : + NativeRootRelates target before after (revealCoordinate coordinate) (revealCoordinate coordinate) := by + intro left right hstate fuel table leftCache rightCache hcache + unfold revealCoordinate + rw [StateT.run_bind, StateT.run_bind, runResolvedFromTable_bind, runResolvedFromTable_bind] + apply relTriple_bind + (relTriple_nativeRoot_revealCoordinateOutput target before after coordinate left right hstate + fuel table leftCache rightCache hcache) + intro leftResult rightResult hrel + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => contradiction + | some leftResult => + cases rightResult with + | none => contradiction + | some rightResult => + rcases hrel with ⟨hcontext, hfuel, htable, houtput, _, hnextCache⟩ + have heq : rightResult.value.1 = leftResult.value.1 := by simpa [hne] using houtput + simp only [StateT.run_pure, runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hcontext, hfuel, htable, congrArg truncateHash heq.symm, hnextCache⟩ + +theorem nativeRootRelates_revealPosition_of_ne + (target : Position) (before after : HashOutput) (position : Position) + (hne : position ≠ target) : + NativeRootRelates target before after (revealPosition position) (revealPosition position) := + nativeRootRelates_revealCoordinate_of_ne target before after (.position position) (by simpa using hne) + +theorem nativeRootRelates_publishCoordinate + (target : Position) (before after : HashOutput) (coordinate : Coordinate) : + NativeRootRelates target before after (publishCoordinate coordinate) (publishCoordinate coordinate) := by + intro left right hstate fuel table leftCache rightCache hcache + unfold publishCoordinate LazyRevealProbe.publishQuery + rw [StateT.run_liftM, StateT.run_liftM, + runResolvedFromTable_publish_query_bind, runResolvedFromTable_publish_query_bind] + simp only [runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate.publish coordinate, rfl, rfl, rfl, hcache⟩ + +theorem nativeRootRelates_revealPublishedCoordinate_of_ne + (target : Position) (before after : HashOutput) (coordinate : Coordinate) + (hne : coordinate ≠ .position target) : + NativeRootRelates target before after + (revealPublishedCoordinate coordinate) (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + apply (nativeRootRelates_revealCoordinate_of_ne target before after coordinate hne).bind + intro leftValue rightValue heq + subst rightValue + exact (nativeRootRelates_publishCoordinate target before after coordinate).bind fun _ _ _ => + nativeRootRelates_pure target before after leftValue + +def NativeRootTargetRevealRel (target : Position) (before after : HashOutput) : + Option (ResolvedRunResult (Digest × SplitHashCache)) → + Option (ResolvedRunResult (Digest × SplitHashCache)) → Prop + | some left, some right => + NativeRootContextRel target before after left.context right.context ∧ + left.remaining = right.remaining ∧ left.table = right.table ∧ + left.value.1 = truncateHash before ∧ right.value.1 = truncateHash after ∧ + RootHiddenCacheRel target before after left.value.2 right.value.2 + | none, none => True + | _, _ => False + +theorem relTriple_nativeRoot_revealPosition_target + (target : Position) (before after : HashOutput) + (left right : DeferredContext) (hstate : NativeRootContextRel target before after left right) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target before after leftCache rightCache) : + RelTriple + (runResolvedFromTable left fuel table ((revealPosition target).run leftCache)) + (runResolvedFromTable right fuel table ((revealPosition target).run rightCache)) + (NativeRootTargetRevealRel target before after) := by + unfold revealPosition revealCoordinate + rw [StateT.run_bind, StateT.run_bind, runResolvedFromTable_bind, runResolvedFromTable_bind] + apply relTriple_bind + (relTriple_nativeRoot_revealCoordinateOutput target before after (.position target) left right hstate + fuel table leftCache rightCache hcache) + intro leftResult rightResult hrel + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => contradiction + | some leftResult => + cases rightResult with + | none => contradiction + | some rightResult => + rcases hrel with ⟨hcontext, hfuel, htable, hright, hleft, hnextCache⟩ + have hrightValue : rightResult.value.1 = after := by simpa using hright + simp only [StateT.run_pure, runResolvedFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hcontext, hfuel, htable, congrArg truncateHash (hleft rfl), + congrArg truncateHash hrightValue, hnextCache⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootStateSigner.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootStateSigner.lean new file mode 100644 index 00000000..8b3a55ab --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootStateSigner.lean @@ -0,0 +1,438 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootStateCoupling + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +theorem nativeRootRelates_sequenceFin + (target : Position) (leftOutput rightOutput : HashOutput) {n : Nat} + (left right : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, + NativeRootRelates target leftOutput rightOutput (left index) (right index)) : + NativeRootRelates target leftOutput rightOutput + (sequenceFin left) (sequenceFin right) := by + induction n with + | zero => + simp only [sequenceFin] + exact nativeRootRelates_pure target leftOutput rightOutput Fin.elim0 + | succ n ih => + rw [sequenceFin, sequenceFin] + exact (hcomponent 0).bind fun leftHead rightHead hhead => + (ih (fun index : Fin n => left index.succ) (fun index : Fin n => right index.succ) + (fun index => hcomponent index.succ)).bind fun leftTail rightTail htail => by + subst rightHead + subst rightTail + exact nativeRootRelates_pure target leftOutput rightOutput + (Fin.cases leftHead leftTail : Fin (n + 1) → α) + +theorem nativeRootRelates_ensureFullChain + (target : Position) (leftOutput rightOutput : HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + NativeRootRelates target leftOutput rightOutput + (ensureFullChain lay tree leafIdx chainIdx) + (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (nativeRootRelates_sequenceFin target leftOutput rightOutput _ _ + (fun step => nativeRootRelates_ensureCoordinate target leftOutput rightOutput + (.position (.chain lay tree leafIdx chainIdx step)))).bind fun _ _ _ => + nativeRootRelates_pure target leftOutput rightOutput () + +theorem nativeRootRelates_ensureOtsLeaf + (target : Position) (leftOutput rightOutput : HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + NativeRootRelates target leftOutput rightOutput + (ensureOtsLeaf lay tree leafIdx) (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (nativeRootRelates_sequenceFin target leftOutput rightOutput _ _ + (fun chainIdx => nativeRootRelates_ensureFullChain target leftOutput rightOutput + lay tree leafIdx chainIdx)).bind fun _ _ _ => + nativeRootRelates_ensureCoordinate target leftOutput rightOutput + (.position (.leaf lay tree leafIdx)) + +theorem nativeRootRelates_ensureTreeNode + (target : Position) (leftOutput rightOutput : HashOutput) + (lay : Layer) (tree : TreeIndex) : ∀ level nodeIdx, + NativeRootRelates target leftOutput rightOutput + (ensureTreeNode lay tree level nodeIdx) + (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => by + rw [ensureTreeNode] + exact nativeRootRelates_ensureOtsLeaf target leftOutput rightOutput lay tree + (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (nativeRootRelates_ensureTreeNode target leftOutput rightOutput lay tree level + (2 * nodeIdx)).bind fun _ _ _ => + (nativeRootRelates_ensureTreeNode target leftOutput rightOutput lay tree level + (2 * nodeIdx + 1)).bind fun _ _ _ => by + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact nativeRootRelates_ensureCoordinate target leftOutput rightOutput + (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact nativeRootRelates_pure target leftOutput rightOutput () + +theorem nativeRootRelates_ensureChainPrefix + (target : Position) (leftOutput rightOutput : HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) : + NativeRootRelates target leftOutput rightOutput + (ensureChainPrefix lay tree leafIdx chainIdx digit) + (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (nativeRootRelates_sequenceFin target leftOutput rightOutput _ _ + (fun step => by + by_cases hstep : step.val < digit.val + · rw [if_pos hstep] + exact nativeRootRelates_ensureCoordinate target leftOutput rightOutput + (.position (.chain lay tree leafIdx chainIdx step)) + · rw [if_neg hstep] + exact nativeRootRelates_pure target leftOutput rightOutput ())).bind fun _ _ _ => + nativeRootRelates_pure target leftOutput rightOutput () + +theorem nativeRootRelates_ensureTreePath + (target : Position) (leftOutput rightOutput : HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + NativeRootRelates target leftOutput rightOutput + (ensureTreePath lay tree leafIdx) (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (nativeRootRelates_sequenceFin target leftOutput rightOutput _ _ + (fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + exact nativeRootRelates_ensureTreeNode target leftOutput rightOutput lay tree + level.val (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · rw [if_neg hlevel] + exact nativeRootRelates_pure target leftOutput rightOutput ())).bind fun _ _ _ => + nativeRootRelates_pure target leftOutput rightOutput () + +theorem nativeRootRelates_simulateQ + {spec : OracleSpec ι} + (target : Position) (leftOutput rightOutput : HashOutput) + (leftImpl rightImpl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (himpl : ∀ query, + NativeRootRelates target leftOutput rightOutput + (leftImpl query) (rightImpl query)) + (computation : OracleComp spec α) : + NativeRootRelates target leftOutput rightOutput + (simulateQ leftImpl computation) (simulateQ rightImpl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + rw [simulateQ_pure, simulateQ_pure] + exact nativeRootRelates_pure target leftOutput rightOutput value + | query_bind query next ih => + rw [simulateQ_query_bind, simulateQ_query_bind] + exact (himpl query).bind fun leftValue rightValue hvalue => by + subst rightValue + exact ih leftValue + +theorem nativeRootRelates_ordinaryHashImpl + (target : Position) (leftOutput rightOutput : HashOutput) + (input : HashInput) : + NativeRootRelates target leftOutput rightOutput + (ordinaryHashImpl input) (ordinaryHashImpl input) := + nativeRootRelates_splitHashQuery_ordinary target leftOutput rightOutput input + +theorem nativeRootRelates_maskedOtsSignFrom + (target : Position) (leftOutput rightOutput : HashOutput) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : ∀ attempts counter, + NativeRootRelates target leftOutput rightOutput + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom] + exact nativeRootRelates_pure target leftOutput rightOutput none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + apply (nativeRootRelates_simulateQ target leftOutput rightOutput + ordinaryHashImpl ordinaryHashImpl + (nativeRootRelates_ordinaryHashImpl target leftOutput rightOutput) + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter))).bind + intro leftEncoded rightEncoded hencoded + subst rightEncoded + cases leftEncoded with + | none => + exact nativeRootRelates_maskedOtsSignFrom target leftOutput rightOutput parameter + lay tree leafIdx message attempts (counter + 1) + | some encoding => + exact (nativeRootRelates_sequenceFin target leftOutput rightOutput _ _ + (fun chainIdx => nativeRootRelates_ensureChainPrefix target leftOutput rightOutput + lay tree leafIdx chainIdx (encoding chainIdx))).bind fun _ _ _ => + nativeRootRelates_pure target leftOutput rightOutput + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem nativeRootRelates_maskedOtsSign + (target : Position) (leftOutput rightOutput : HashOutput) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : + NativeRootRelates target leftOutput rightOutput + (maskedOtsSign parameter lay tree leafIdx message) + (maskedOtsSign parameter lay tree leafIdx message) := + nativeRootRelates_maskedOtsSignFrom target leftOutput rightOutput parameter lay tree leafIdx + message encodingAttemptLimit 0 + +theorem nativeRootRelates_maskedOtsLayerAfterMessage + (target : Position) (leftOutput rightOutput : HashOutput) + (parameter : PublicParameter) (index : Index) (lay : Layer) (message : Digest) : + NativeRootRelates target leftOutput rightOutput + (maskedOtsLayerAfterMessage parameter index lay message) + (maskedOtsLayerAfterMessage parameter index lay message) := by + unfold maskedOtsLayerAfterMessage + apply (nativeRootRelates_maskedOtsSign target leftOutput rightOutput parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) message).bind + intro leftResult rightResult hresult + subst rightResult + cases leftResult with + | none => exact nativeRootRelates_pure target leftOutput rightOutput none + | some part => + exact (nativeRootRelates_ensureTreePath target leftOutput rightOutput lay + (treeIndexAt index lay) (leafIndexAt index lay)).bind fun _ _ _ => + nativeRootRelates_pure target leftOutput rightOutput (some part) + +theorem relTriple_nativeRoot_maskedTreeRoot_target + (lay : Layer) (tree : TreeIndex) + (leftOutput rightOutput : HashOutput) + (leftState rightState : DeferredContext) + (hstate : NativeRootContextRel (layerRootPosition lay tree) leftOutput rightOutput + leftState rightState) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel (layerRootPosition lay tree) leftOutput rightOutput + leftCache rightCache) : + RelTriple + (runResolvedFromTable leftState fuel table ((maskedTreeRoot lay tree).run leftCache)) + (runResolvedFromTable rightState fuel table ((maskedTreeRoot lay tree).run rightCache)) + (NativeRootTargetRevealRel (layerRootPosition lay tree) leftOutput rightOutput) := by + rw [maskedTreeRoot_eq_ensure_reveal, StateT.run_bind, StateT.run_bind, + runResolvedFromTable_bind, runResolvedFromTable_bind] + apply relTriple_bind + (nativeRootRelates_ensureTreeNode (layerRootPosition lay tree) leftOutput rightOutput + lay tree (layerHeight lay) 0 leftState rightState hstate fuel table leftCache rightCache + hcache) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [NativeRootSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [NativeRootSameRel] at hresult + | some rightResult => + rcases hresult with ⟨hnextState, hremaining, htable, _hvalue, hnextCache⟩ + simp only + rw [← hremaining, ← htable] + exact relTriple_nativeRoot_revealPosition_target (layerRootPosition lay tree) + leftOutput rightOutput leftResult.context rightResult.context hnextState + leftResult.remaining leftResult.table leftResult.value.2 rightResult.value.2 + hnextCache + +theorem relTriple_nativeRoot_maskedLayerMessage_target + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (index : Index) (lay : Layer) + (htarget : layerMessagePosition index lay = target) + (leftOutput rightOutput : HashOutput) + (leftState rightState : DeferredContext) + (hstate : NativeRootContextRel target leftOutput rightOutput leftState rightState) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache) : + RelTriple + (runResolvedFromTable leftState fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run leftCache)) + (runResolvedFromTable rightState fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run rightCache)) + (NativeRootTargetRevealRel target leftOutput rightOutput) := by + obtain ⟨below, hcomputation, hposition⟩ := + layerMessage_root_witness_of_isLayerRoot parameter ftsSecret target hroot index lay htarget + have htargetRoot : target = layerRootPosition below (treeIndexAt index below) := + htarget.symm.trans hposition + rw [hcomputation] + rw [htargetRoot] at hstate hcache ⊢ + exact relTriple_nativeRoot_maskedTreeRoot_target below (treeIndexAt index below) + leftOutput rightOutput leftState rightState hstate fuel table leftCache rightCache hcache + +theorem nativeRootRelates_maskedSignLayer_comparison_actual + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (index : Index) (lay : Layer) + (htarget : layerMessagePosition index lay = target) + (leftOutput rightOutput : HashOutput) : + NativeRootRelates target leftOutput rightOutput + (maskedSignLayerWithComparisonRoot parameter ftsSecret index lay + (truncateHash rightOutput)) + (maskedSignLayer parameter ftsSecret index lay) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + unfold maskedSignLayerWithComparisonRoot maskedSignLayer + rw [StateT.run_bind, StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_bind] + apply relTriple_bind + (relTriple_nativeRoot_maskedLayerMessage_target parameter ftsSecret target hroot index lay + htarget leftOutput rightOutput leftState rightState hstate fuel table leftCache rightCache + hcache) + intro leftMessage rightMessage hmessage + cases leftMessage with + | none => + cases rightMessage with + | none => exact relTriple_pure_pure trivial + | some rightMessage => simp [NativeRootTargetRevealRel] at hmessage + | some leftMessage => + cases rightMessage with + | none => simp [NativeRootTargetRevealRel] at hmessage + | some rightMessage => + rcases hmessage with ⟨hnextState, hremaining, htable, _hleftMessage, + hrightMessage, hnextCache⟩ + simp only + rw [← hremaining, ← htable, hrightMessage] + exact nativeRootRelates_maskedOtsLayerAfterMessage target leftOutput rightOutput + parameter index lay (truncateHash rightOutput) leftMessage.context rightMessage.context + hnextState leftMessage.remaining leftMessage.table leftMessage.value.2 + rightMessage.value.2 hnextCache + +theorem nativeRootRelates_maskedTreeRoot_of_ne + (target : Position) (leftOutput rightOutput : HashOutput) + (lay : Layer) (tree : TreeIndex) + (hne : layerRootPosition lay tree ≠ target) : + NativeRootRelates target leftOutput rightOutput + (maskedTreeRoot lay tree) (maskedTreeRoot lay tree) := by + rw [maskedTreeRoot_eq_ensure_reveal] + exact (nativeRootRelates_ensureTreeNode target leftOutput rightOutput lay tree + (layerHeight lay) 0).bind fun _ _ _ => + nativeRootRelates_revealPosition_of_ne target leftOutput rightOutput + (layerRootPosition lay tree) hne + +theorem nativeRootRelates_maskedLayerMessage_of_ne + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (leftOutput rightOutput : HashOutput) + (index : Index) (lay : Layer) + (hne : layerMessagePosition index lay ≠ target) : + NativeRootRelates target leftOutput rightOutput + (maskedLayerMessage parameter ftsSecret index lay) + (maskedLayerMessage parameter ftsSecret index lay) := by + fin_cases lay + · rw [maskedLayerMessage, dif_pos (by decide)] + apply nativeRootRelates_maskedTreeRoot_of_ne + simpa [layerMessagePosition_top, layerRootPosition] + · rw [maskedLayerMessage, dif_pos (by decide)] + apply nativeRootRelates_maskedTreeRoot_of_ne + simpa [layerMessagePosition_middle, layerRootPosition] + · rw [maskedLayerMessage, dif_neg (by decide)] + exact nativeRootRelates_simulateQ target leftOutput rightOutput ordinaryHashImpl + ordinaryHashImpl (nativeRootRelates_ordinaryHashImpl target leftOutput rightOutput) + (ftsKey parameter index (ftsSecret index)) + +theorem nativeRootRelates_maskedSignLayer_of_ne + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (leftOutput rightOutput : HashOutput) + (index : Index) (lay : Layer) + (hne : layerMessagePosition index lay ≠ target) : + NativeRootRelates target leftOutput rightOutput + (maskedSignLayer parameter ftsSecret index lay) + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + exact (nativeRootRelates_maskedLayerMessage_of_ne parameter ftsSecret target leftOutput + rightOutput index lay hne).bind fun leftMessage rightMessage hmessage => by + subst rightMessage + exact nativeRootRelates_maskedOtsLayerAfterMessage target leftOutput rightOutput + parameter index lay leftMessage + +theorem nativeRootRelates_maskedSignLayerWithTargetComparison_actual + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (index : Index) (lay : Layer) : + NativeRootRelates target leftOutput rightOutput + (maskedSignLayerWithTargetComparison parameter target (truncateHash rightOutput) + ftsSecret index lay) + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayerWithTargetComparison + by_cases htarget : layerMessagePosition index lay = target + · rw [if_pos htarget] + exact nativeRootRelates_maskedSignLayer_comparison_actual parameter ftsSecret target hroot + index lay htarget leftOutput rightOutput + · rw [if_neg htarget] + exact nativeRootRelates_maskedSignLayer_of_ne parameter ftsSecret target leftOutput + rightOutput index lay htarget + +theorem nativeRootRelates_maskedSignLayersWithTargetComparison_actual + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) (index : Index) : + NativeRootRelates target leftOutput rightOutput + (maskedSignLayersWithTargetComparison parameter target (truncateHash rightOutput) + ftsSecret index) + (sequenceFin fun lay => maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayersWithTargetComparison + exact nativeRootRelates_sequenceFin target leftOutput rightOutput _ _ fun lay => + nativeRootRelates_maskedSignLayerWithTargetComparison_actual parameter ftsSecret target + hroot leftOutput rightOutput index lay + +theorem nativeRootRelates_revealLayerValues + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + NativeRootRelates target leftOutput rightOutput + (revealLayerValues index lay encoding) (revealLayerValues index lay encoding) := by + unfold revealLayerValues + apply (nativeRootRelates_sequenceFin target leftOutput rightOutput _ _ fun chainIdx => + nativeRootRelates_revealPublishedCoordinate_of_ne target leftOutput rightOutput + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + (encoding chainIdx)) + (chainValueCoordinate_ne_layerRoot hroot lay (treeIndexAt index lay) + (leafIndexAt index lay) chainIdx (encoding chainIdx))).bind + intro leftValues rightValues hvalues + subst rightValues + apply (nativeRootRelates_sequenceFin target leftOutput rightOutput _ _ fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + cases hzero : level.val with + | zero => + exact nativeRootRelates_revealPublishedCoordinate_of_ne target leftOutput rightOutput + (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) (by + obtain ⟨rootLay, rootTree, rfl⟩ := hroot + simp [layerRootPosition]) + | succ current => + rw [Nat.add_one] + simp only + by_cases hcurrent : current < maxLayerHeight + · rw [dif_pos hcurrent] + exact nativeRootRelates_revealPublishedCoordinate_of_ne target leftOutput rightOutput + (.position (.node lay (treeIndexAt index lay) ⟨current, hcurrent⟩ + (leafOfNat (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + (by + intro heq + exact (pathNode_ne_layerRoot hroot lay (treeIndexAt index lay) current hcurrent _ + (by omega)) (Coordinate.position.inj heq)) + · rw [dif_neg hcurrent] + exact nativeRootRelates_pure target leftOutput rightOutput 0 + · rw [if_neg hlevel] + exact nativeRootRelates_pure target leftOutput rightOutput 0).bind + intro leftPath rightPath hpath + subst rightPath + exact nativeRootRelates_pure target leftOutput rightOutput (leftValues, leftPath) + +theorem nativeRootRelates_ordinaryRomImpl + (target : Position) (leftOutput rightOutput : HashOutput) + (query : OracleWorld.Domain) : + NativeRootRelates target leftOutput rightOutput + (ordinaryRomImpl query) (ordinaryRomImpl query) := by + cases query with + | inl n => exact nativeRootRelates_splitUniformImpl target leftOutput rightOutput n + | inr input => exact nativeRootRelates_ordinaryHashImpl target leftOutput rightOutput input + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootSwap.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootSwap.lean new file mode 100644 index 00000000..c849365a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootSwap.lean @@ -0,0 +1,151 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootStateChronological + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def NativeRootSwapCacheRel (parameter : PublicParameter) (target : Position) + (before after : HashOutput) (left right : SplitHashCache) : Prop := + ∃ middle, RootEncodingCacheRel parameter target (truncateHash before) (truncateHash after) left middle ∧ + RootHiddenCacheRel target before after middle right + +def NativeRootSwapSameRel (parameter : PublicParameter) (target : Position) (before after : HashOutput) : + Option (ResolvedRunResult (α × SplitHashCache)) → + Option (ResolvedRunResult (α × SplitHashCache)) → Prop + | some left, some right => + NativeRootContextRel target before after left.context right.context ∧ + left.remaining = right.remaining ∧ left.table = right.table ∧ left.value.1 = right.value.1 ∧ + NativeRootSwapCacheRel parameter target before after left.value.2 right.value.2 + | none, none => True + | _, _ => False + +theorem nativeRootSwapCacheRel_fullSwap + (parameter : PublicParameter) (target : Position) (before after : HashOutput) + (cache : SplitHashCache) (hcache : cache (.hidden (.position target)) = some before) : + NativeRootSwapCacheRel parameter target before after cache + (fullSwapRootCache parameter target (truncateHash before) (truncateHash after) after cache) := + ⟨swapCanonicalRootEncodingCache parameter target (truncateHash before) (truncateHash after) cache, + rootEncodingCacheRel_swapCanonical parameter target (truncateHash before) (truncateHash after) cache, + rootHiddenCacheRel_fullSwapRootCache parameter target before after cache hcache⟩ + +theorem relTriple_nativeRootSwap_chronologicalSign + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (before after : HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (left right : DeferredContext) (hcontext : NativeRootContextRel target before after left right) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : NativeRootSwapCacheRel parameter target before after leftCache rightCache) : + RelTriple + (runResolvedFromTable left fuel table ((maskedPublishedChronologicalSign parameter root ftsSecret message).run leftCache)) + (runResolvedFromTable right fuel table ((maskedPublishedChronologicalSign parameter root ftsSecret message).run rightCache)) + (NativeRootSwapSameRel parameter target before after) := by + obtain ⟨middleCache, hencoding, hhidden⟩ := hcache + have hfirst := rootEncodingNativeRelatesStored_maskedPublishedChronologicalSign_targetComparison + parameter root target hroot (truncateHash before) (truncateHash after) ftsSecret message + leftCache middleCache hencoding left fuel table ⟨before, hcontext.replaceable.known, rfl⟩ + have hsecond := nativeRootRelates_chronologicalSign_comparison_actual parameter root target hroot + before after ftsSecret message left right hcontext fuel table middleCache rightCache hhidden + apply relTriple_post_mono (SphincsSecurity.relTriple_trans_exists hfirst hsecond) + intro leftResult rightResult hrel + obtain ⟨middleResult, hfirst, hsecond⟩ := hrel + cases leftResult with + | none => + cases middleResult with + | some middleResult => contradiction + | none => + cases rightResult with + | none => trivial + | some rightResult => contradiction + | some leftResult => + cases middleResult with + | none => contradiction + | some middleResult => + cases rightResult with + | none => contradiction + | some rightResult => + rcases hfirst.1 with ⟨hcontextEq, hfuel₁, htable₁, hvalue₁, hcache₁⟩ + rcases hsecond with ⟨hcontext₂, hfuel₂, htable₂, hvalue₂, hcache₂⟩ + refine ⟨?_, hfuel₁.trans hfuel₂, htable₁.trans htable₂, hvalue₁.trans hvalue₂, + middleResult.value.2, hcache₁, hcache₂⟩ + rw [hcontextEq] + exact hcontext₂ + +def normalizeNativeRootResult (target : Position) (result : Option (ResolvedRunResult (α × SplitHashCache))) : + Option (ResolvedRunResult α) := + result.map fun result => ⟨replaceNativePosition target 0 result.context, result.remaining, result.value.1, result.table⟩ + +noncomputable def normalizeLiveNativeRootResult (target : Position) : + Option (ResolvedRunResult (α × SplitHashCache)) → Option (ResolvedRunResult α) + | none => none + | some result => + if DeferredCompletable result.table result.context then normalizeNativeRootResult target (some result) else none + +theorem NativeRootContextRel.completable_iff + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) (table : OtsSecretIndex → HashOutput) : + DeferredCompletable table right ↔ DeferredCompletable table left := by + rw [h.right_eq] + exact deferredCompletable_replaceNativePosition_iff target before after left table h.replaceable + +theorem NativeRootSwapSameRel.normalize + {parameter : PublicParameter} {target : Position} {before after : HashOutput} + {left right : Option (ResolvedRunResult (α × SplitHashCache))} + (h : NativeRootSwapSameRel parameter target before after left right) : + normalizeNativeRootResult target left = normalizeNativeRootResult target right := by + cases left with + | none => + cases right with + | none => rfl + | some right => contradiction + | some left => + cases right with + | none => contradiction + | some right => + rcases h with ⟨hcontext, hfuel, htable, hvalue, _⟩ + simp only [normalizeNativeRootResult, Option.map_some, hcontext.right_eq, + replaceNativePosition_idem, hfuel, htable, hvalue] + +theorem NativeRootSwapSameRel.normalizeLive + {parameter : PublicParameter} {target : Position} {before after : HashOutput} + {left right : Option (ResolvedRunResult (α × SplitHashCache))} + (h : NativeRootSwapSameRel parameter target before after left right) : + normalizeLiveNativeRootResult target left = normalizeLiveNativeRootResult target right := by + cases left with + | none => + cases right with + | none => rfl + | some right => contradiction + | some left => + cases right with + | none => contradiction + | some right => + have hnormalize := h.normalize + rcases h with ⟨hcontext, _, htable, _, _⟩ + simp only [normalizeLiveNativeRootResult, ← htable, hcontext.completable_iff, + hnormalize] + +theorem evalDist_nativeRootSwap_chronologicalSign_live + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (before after : HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (h : NativePositionReplaceable target before after context) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcache : cache (.hidden (.position target)) = some before) : + evalDist (normalizeLiveNativeRootResult target <$> + runResolvedFromTable context fuel table ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache)) = + evalDist (normalizeLiveNativeRootResult target <$> + runResolvedFromTable (replaceNativePosition target after context) fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run + (fullSwapRootCache parameter target (truncateHash before) (truncateHash after) after cache))) := by + apply evalDist_map_eq_of_relTriple + apply relTriple_post_mono + (relTriple_nativeRootSwap_chronologicalSign parameter root target hroot before after ftsSecret message + context (replaceNativePosition target after context) ⟨h, rfl⟩ fuel table cache + (fullSwapRootCache parameter target (truncateHash before) (truncateHash after) after cache) + (nativeRootSwapCacheRel_fullSwap parameter target before after cache hcache)) + intro left right hrel + exact hrel.normalizeLive + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootSwapHash.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootSwapHash.lean new file mode 100644 index 00000000..44f91cd6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootSwapHash.lean @@ -0,0 +1,101 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootHashPlan +import SphincsSecurity.Proof.OtsProbeNativeOrdinaryCacheHash + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +theorem relTriple_nativeRootSwap_probingHashQuery + (parameter : PublicParameter) (target : Position) (before after : HashOutput) (input : HashInput) + (left right : DeferredContext) (hcontext : NativeRootContextRel target before after left right) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : NativeRootSwapCacheRel parameter target before after leftCache rightCache) + (havoid : RootInputAvoids parameter target (truncateHash before) (truncateHash after) input) + (hprobe : ∀ candidate, (purePlanProbingHashQuery parameter input left.state).candidate? = some candidate → + ¬IsPrivateValueExposure target before after (.probe candidate.coordinate candidate.candidate)) + (haction : NativeRootActionSafe parameter target input left right + (purePlanProbingHashQuery parameter input left.state).action) : + RelTriple + (runResolvedFromTable left fuel table ((probingHashQuery parameter input).run leftCache)) + (runResolvedFromTable right fuel table ((probingHashQuery parameter input).run rightCache)) + (NativeRootSwapSameRel parameter target before after) := by + obtain ⟨middleCache, hencoding, hhidden⟩ := hcache + have hfirst := rootEncodingNativeCouples_probingHashQuery_avoids parameter target + (truncateHash before) (truncateHash after) input havoid leftCache middleCache hencoding left fuel table + have hsecond := relTriple_nativeRoot_probingHashQuery_of_safe parameter target before after input + left right hcontext fuel table middleCache rightCache hhidden hprobe haction + apply relTriple_post_mono (SphincsSecurity.relTriple_trans_exists hfirst hsecond) + intro leftResult rightResult hrel + obtain ⟨middleResult, hfirst, hsecond⟩ := hrel + cases leftResult with + | none => + cases middleResult with + | some middleResult => contradiction + | none => + cases rightResult with + | none => trivial + | some rightResult => contradiction + | some leftResult => + cases middleResult with + | none => contradiction + | some middleResult => + cases rightResult with + | none => contradiction + | some rightResult => + rcases hfirst with ⟨hcontextEq, hfuel₁, htable₁, hvalue₁, hcache₁⟩ + rcases hsecond with ⟨hcontext₂, hfuel₂, htable₂, hvalue₂, hcache₂⟩ + refine ⟨?_, hfuel₁.trans hfuel₂, htable₁.trans htable₂, hvalue₁.trans hvalue₂, + middleResult.value.2, hcache₁, hcache₂⟩ + rw [hcontextEq] + exact hcontext₂ +theorem evalDist_nativeRootSwap_hashQuery_live_of_stored + (parameter : PublicParameter) (target : Position) (before after : HashOutput) (input : HashInput) + (context : DeferredContext) (h : NativePositionReplaceable target before after context) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (havoid : RootInputAvoids parameter target (truncateHash before) (truncateHash after) input) + (hprobe : ∀ candidate, (purePlanProbingHashQuery parameter input context.state).candidate? = some candidate → + ¬IsPrivateValueExposure target before after (.probe candidate.coordinate candidate.candidate)) + (haction : NativeRootActionSafe parameter target input context (replaceNativePosition target after context) + (purePlanProbingHashQuery parameter input context.state).action) : + evalDist (normalizeLiveNativeRootResult target <$> + runResolvedFromTable context fuel table ((probingHashQuery parameter input).run cache)) = + evalDist (normalizeLiveNativeRootResult target <$> + runResolvedFromTable (replaceNativePosition target after context) fuel table + ((probingHashQuery parameter input).run + (fullSwapRootCache parameter target (truncateHash before) (truncateHash after) after cache))) := by + have hpadding : + evalDist (normalizeLiveNativeRootResult target <$> + runResolvedFromTable context fuel table ((probingHashQuery parameter input).run cache)) = + evalDist (normalizeLiveNativeRootResult target <$> + runResolvedFromTable context fuel table ((probingHashQuery parameter input).run + (replaceHiddenRootCache target before cache))) := by + apply evalDist_map_eq_of_relTriple + apply relTriple_post_mono + (ordinaryCacheNativeCouples_probingHashQuery parameter input cache (replaceHiddenRootCache target before cache) + (ordinarySplitCacheEq_replaceHiddenRootCache target before cache) context fuel table) + intro left right hrel + exact hrel.normalizeLive target + have hswap : + evalDist (normalizeLiveNativeRootResult target <$> + runResolvedFromTable context fuel table ((probingHashQuery parameter input).run + (replaceHiddenRootCache target before cache))) = + evalDist (normalizeLiveNativeRootResult target <$> + runResolvedFromTable (replaceNativePosition target after context) fuel table + ((probingHashQuery parameter input).run + (fullSwapRootCache parameter target (truncateHash before) (truncateHash after) after + (replaceHiddenRootCache target before cache)))) := by + apply evalDist_map_eq_of_relTriple + apply relTriple_post_mono + (relTriple_nativeRootSwap_probingHashQuery parameter target before after input context + (replaceNativePosition target after context) ⟨h, rfl⟩ fuel table (replaceHiddenRootCache target before cache) _ + (nativeRootSwapCacheRel_fullSwap parameter target before after (replaceHiddenRootCache target before cache) + (by simp [replaceHiddenRootCache])) havoid hprobe haction) + intro left right hrel + exact hrel.normalizeLive + rw [fullSwapRootCache_replaceHiddenRootCache] at hswap + exact hpadding.trans hswap + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootSwapOrdinaryCache.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootSwapOrdinaryCache.lean new file mode 100644 index 00000000..aed79f3e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootSwapOrdinaryCache.lean @@ -0,0 +1,79 @@ +import SphincsSecurity.Proof.OtsProbeNativeOrdinaryCacheSigner + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +theorem ordinarySplitCacheEq_replaceHiddenRootCache + (target : Position) (output : HashOutput) (cache : SplitHashCache) : + OrdinarySplitCacheEq cache (replaceHiddenRootCache target output cache) := by + intro input + simp [replaceHiddenRootCache] + +theorem fullSwapRootCache_replaceHiddenRootCache + (parameter : PublicParameter) (target : Position) (leftRoot rightRoot : Digest) + (before after : HashOutput) (cache : SplitHashCache) : + fullSwapRootCache parameter target leftRoot rightRoot after + (replaceHiddenRootCache target before cache) = + fullSwapRootCache parameter target leftRoot rightRoot after cache := by + funext key + cases key with + | ordinary input => + simp [fullSwapRootCache, replaceHiddenRootCache, swapCanonicalRootEncodingCache] + | hidden coordinate => + by_cases h : coordinate = .position target + · simp [fullSwapRootCache, replaceHiddenRootCache, h] + · simp [fullSwapRootCache, replaceHiddenRootCache, swapCanonicalRootEncodingCache, h] + +theorem OrdinaryCacheNativeSameRel.normalizeLive + {left right : Option (ResolvedRunResult (α × SplitHashCache))} + (h : OrdinaryCacheNativeSameRel left right) (target : Position) : + normalizeLiveNativeRootResult target left = normalizeLiveNativeRootResult target right := by + cases left with + | none => + cases right with + | none => rfl + | some right => contradiction + | some left => + cases right with + | none => contradiction + | some right => + rcases h with ⟨hcontext, hfuel, htable, hvalue, _⟩ + simp only [normalizeLiveNativeRootResult, normalizeNativeRootResult, + Option.map_some, hcontext, hfuel, htable, hvalue] + rw [hcontext, htable] + +theorem evalDist_nativeRootSwap_chronologicalSign_live_of_stored + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (before after : HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (h : NativePositionReplaceable target before after context) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + evalDist (normalizeLiveNativeRootResult target <$> + runResolvedFromTable context fuel table ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache)) = + evalDist (normalizeLiveNativeRootResult target <$> + runResolvedFromTable (replaceNativePosition target after context) fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run + (fullSwapRootCache parameter target (truncateHash before) (truncateHash after) after cache))) := by + have hpadding : + evalDist (normalizeLiveNativeRootResult target <$> + runResolvedFromTable context fuel table ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache)) = + evalDist (normalizeLiveNativeRootResult target <$> + runResolvedFromTable context fuel table ((maskedPublishedChronologicalSign parameter root ftsSecret message).run + (replaceHiddenRootCache target before cache))) := by + apply evalDist_map_eq_of_relTriple + apply relTriple_post_mono + (ordinaryCacheNativeCouples_chronologicalSign parameter root ftsSecret message + cache (replaceHiddenRootCache target before cache) + (ordinarySplitCacheEq_replaceHiddenRootCache target before cache) context fuel table) + intro left right hrel + exact hrel.normalizeLive target + have hswap := evalDist_nativeRootSwap_chronologicalSign_live parameter root target hroot + before after ftsSecret message context h fuel table (replaceHiddenRootCache target before cache) + (by simp [replaceHiddenRootCache]) + rw [fullSwapRootCache_replaceHiddenRootCache] at hswap + exact hpadding.trans hswap + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootSwapStep.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootSwapStep.lean new file mode 100644 index 00000000..88904598 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootSwapStep.lean @@ -0,0 +1,123 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootSwapHash + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +theorem nativeRootSwapSameRel_of_middle + {parameter : PublicParameter} {target : Position} {before after : HashOutput} + {left middle right : Option (ResolvedRunResult (α × SplitHashCache))} + (hfirst : RootEncodingNativeSameRel parameter target (truncateHash before) (truncateHash after) left middle) + (hsecond : NativeRootSameRel target before after middle right) : + NativeRootSwapSameRel parameter target before after left right := by + cases left with + | none => + cases middle with + | some middle => contradiction + | none => + cases right with + | none => trivial + | some right => contradiction + | some left => + cases middle with + | none => contradiction + | some middle => + cases right with + | none => contradiction + | some right => + rcases hfirst with ⟨hcontextEq, hfuel₁, htable₁, hvalue₁, hcache₁⟩ + rcases hsecond with ⟨hcontext₂, hfuel₂, htable₂, hvalue₂, hcache₂⟩ + refine ⟨?_, hfuel₁.trans hfuel₂, htable₁.trans htable₂, hvalue₁.trans hvalue₂, + middle.value.2, hcache₁, hcache₂⟩ + rw [hcontextEq] + exact hcontext₂ + +theorem relTriple_nativeRootSwap_uniform + (parameter : PublicParameter) (target : Position) (before after : HashOutput) (n : Nat) + (left right : DeferredContext) (hcontext : NativeRootContextRel target before after left right) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : NativeRootSwapCacheRel parameter target before after leftCache rightCache) : + RelTriple + (runResolvedFromTable left fuel table ((splitUniformImpl n).run leftCache)) + (runResolvedFromTable right fuel table ((splitUniformImpl n).run rightCache)) + (NativeRootSwapSameRel parameter target before after) := by + obtain ⟨middleCache, hencoding, hhidden⟩ := hcache + have hfirst := rootEncodingNativeCouples_splitUniformImpl parameter target + (truncateHash before) (truncateHash after) n leftCache middleCache hencoding left fuel table + have hsecond := nativeRootRelates_splitUniformImpl target before after n + left right hcontext fuel table middleCache rightCache hhidden + apply relTriple_post_mono (SphincsSecurity.relTriple_trans_exists hfirst hsecond) + rintro _ _ ⟨_, hfirst, hsecond⟩ + exact nativeRootSwapSameRel_of_middle hfirst hsecond + +theorem NativePositionReplaceable.replace_self + {target : Position} {before after : HashOutput} {context : DeferredContext} + (h : NativePositionReplaceable target before after context) : replaceNativePosition target before context = context := by + have hinverse := replaceNativePosition_inverse h + rwa [replaceNativePosition_idem] at hinverse + +def NativeRootHashSafe (parameter : PublicParameter) (target : Position) (before after : HashOutput) + (input : HashInput) (context : DeferredContext) : Prop := + let left := replaceNativePosition target before context + let right := replaceNativePosition target after context + RootInputAvoids parameter target (truncateHash before) (truncateHash after) input ∧ + (∀ candidate, (purePlanProbingHashQuery parameter input left.state).candidate? = some candidate → + ¬IsPrivateValueExposure target before after (.probe candidate.coordinate candidate.candidate)) ∧ + NativeRootActionSafe parameter target input left right (purePlanProbingHashQuery parameter input left.state).action + +def NativeRootOuterSafe (parameter : PublicParameter) (target : Position) (before after : HashOutput) : + (OracleWorld + SigningSpec).Domain → DeferredContext → Prop + | .inl (.inr input), context => NativeRootHashSafe parameter target before after input context + | _, _ => True + +theorem nativeRootOuterSafe_replace_iff + (parameter : PublicParameter) (target : Position) (before after output : HashOutput) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) : + NativeRootOuterSafe parameter target before after input (replaceNativePosition target output context) ↔ + NativeRootOuterSafe parameter target before after input context := by + cases input with + | inl input => + cases input with + | inl n => rfl + | inr input => simp only [NativeRootOuterSafe, NativeRootHashSafe, replaceNativePosition_idem] + | inr message => rfl + +theorem NativeRootContextRel.outerSafe_iff + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) (parameter : PublicParameter) + (input : (OracleWorld + SigningSpec).Domain) : + NativeRootOuterSafe parameter target before after input left ↔ NativeRootOuterSafe parameter target before after input right := by + rw [h.right_eq] + exact (nativeRootOuterSafe_replace_iff parameter target before after after input left).symm + +theorem relTriple_nativeRootSwap_outerQuery_of_safe + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (before after : HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) + (left right : DeferredContext) (hcontext : NativeRootContextRel target before after left right) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : NativeRootSwapCacheRel parameter target before after leftCache rightCache) + (hsafe : NativeRootOuterSafe parameter target before after input left) : + RelTriple + (runResolvedFromTable left fuel table ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run leftCache)) + (runResolvedFromTable right fuel table ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run rightCache)) + (NativeRootSwapSameRel parameter target before after) := by + cases input with + | inl input => + cases input with + | inl n => + exact relTriple_nativeRootSwap_uniform parameter target before after n + left right hcontext fuel table leftCache rightCache hcache + | inr input => + change NativeRootHashSafe parameter target before after input left at hsafe + simp only [NativeRootHashSafe, hcontext.replaceable.replace_self, ← hcontext.right_eq] at hsafe + exact relTriple_nativeRootSwap_probingHashQuery parameter target before after input + left right hcontext fuel table leftCache rightCache hcache hsafe.1 hsafe.2.1 hsafe.2.2 + | inr message => + exact relTriple_nativeRootSwap_chronologicalSign parameter root target hroot before after ftsSecret message + left right hcontext fuel table leftCache rightCache hcache + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootTraceCoupling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootTraceCoupling.lean new file mode 100644 index 00000000..ea149577 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootTraceCoupling.lean @@ -0,0 +1,116 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootCompatibleTrace + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open _root_.OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem nativeRootSelectionGuess_eq_of_rootRel + (parameter : PublicParameter) (target : Position) (before after : HashOutput) + (input : (OracleWorld + SigningSpec).Domain) (left right : DeferredContext) + (hcontext : NativeRootContextRel target before after left right) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) : + nativeRootSelectionGuess? parameter target ⟨input, left, fuel, table, leftCache⟩ = + nativeRootSelectionGuess? parameter target ⟨input, right, fuel, table, rightCache⟩ := by + cases input with + | inl query => + cases query with + | inl n => rfl + | inr input => simp only [nativeRootSelectionGuess?, nativeRootSelectionCandidate?, hcontext.candidate_eq parameter input] + | inr message => rfl + +theorem observeCompatibleNativeRootTrace_eq_of_rel + {parameter : PublicParameter} {target : Position} {before after : HashOutput} + {left right : Option (ResolvedRunResult (α × SplitHashCache))} + (hrel : NativeRootSwapSameRel parameter target before after left right) + (leftHistory rightHistory : List CanonicalQuerySelection) + (hhistory : nativeRootCandidateHistory parameter target leftHistory = nativeRootCandidateHistory parameter target rightHistory) : + observeCompatibleNativeRootTrace parameter target before after (left, leftHistory) = + observeCompatibleNativeRootTrace parameter target before after (right, rightHistory) := by + have hnormalize := hrel.normalize + have hcompatible : NativeRootTraceCompatible parameter target before after (left, leftHistory) ↔ + NativeRootTraceCompatible parameter target before after (right, rightHistory) := by + cases left with + | none => + cases right with + | none => rfl + | some right => contradiction + | some left => + cases right with + | none => contradiction + | some right => simp only [NativeRootTraceCompatible, hrel.1.revealed_eq, hhistory] + simp only [observeCompatibleNativeRootTrace, hcompatible, hnormalize, hhistory] + +theorem evalDist_nativeRootSwap_compatibleTrace + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (before after : HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (left right : DeferredContext) (hcontext : NativeRootContextRel target before after left right) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : NativeRootSwapCacheRel parameter target before after leftCache rightCache) : + evalDist (observeCompatibleNativeRootTrace parameter target before after <$> + runNativeQueryTrace parameter root ftsSecret computation left fuel table leftCache) = + evalDist (observeCompatibleNativeRootTrace parameter target before after <$> + runNativeQueryTrace parameter root ftsSecret computation right fuel table rightCache) := by + induction computation using OracleComp.inductionOn generalizing left right fuel table leftCache rightCache with + | pure value => + simp only [runNativeQueryTrace, OracleComp.construct_pure, hcontext.completable_iff] + split_ifs with hcomplete + · simp only [map_pure] + congr 1 + have hrel : NativeRootSwapSameRel parameter target before after + (some (⟨left, fuel, (value, leftCache), table⟩ : ResolvedRunResult (α × SplitHashCache))) + (some (⟨right, fuel, (value, rightCache), table⟩ : ResolvedRunResult (α × SplitHashCache))) := + ⟨hcontext, rfl, rfl, rfl, hcache⟩ + exact congrArg pure (observeCompatibleNativeRootTrace_eq_of_rel hrel [] [] rfl) + · simp [observeCompatibleNativeRootTrace, NativeRootTraceCompatible] + | query_bind input next ih => + by_cases hcomplete : DeferredCompletable table left + · have hrightComplete := (hcontext.completable_iff table).mpr hcomplete + by_cases hsafe : NativeRootOuterSafe parameter target before after input left + · rw [runNativeQueryTrace_query_bind, runNativeQueryTrace_query_bind, if_pos hcomplete, if_pos hrightComplete] + simp only [map_bind] + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (relTriple_nativeRootSwap_outerQuery_of_safe parameter root target hroot before after ftsSecret input + left right hcontext fuel table leftCache rightCache hcache hsafe) + intro leftResult rightResult hrel + cases leftResult with + | none => + cases rightResult with + | none => simp [observeCompatibleNativeRootTrace, NativeRootTraceCompatible] + | some rightResult => contradiction + | some leftResult => + cases rightResult with + | none => contradiction + | some rightResult => + rcases hrel with ⟨hnext, hfuel, htable, hvalue, hnextCache⟩ + simp only + rw [← hfuel, ← htable, ← hvalue] + have htail := ih leftResult.value.1 leftResult.context rightResult.context hnext leftResult.remaining + leftResult.table leftResult.value.2 rightResult.value.2 hnextCache + have hguess := nativeRootSelectionGuess_eq_of_rootRel parameter target before after input left right hcontext + fuel table leftCache rightCache + have hmapped := evalDist_map_eq_of_evalDist_eq htail + (prependCompatibleNativeRootGuess before after + (nativeRootSelectionGuess? parameter target ⟨input, left, fuel, table, leftCache⟩)) + simpa only [map_eq_bind_pure_comp, Function.comp_def, bind_assoc, pure_bind, + observeCompatibleNativeRootTrace_prepend, hguess] using hmapped + · rw [evalDist_observeCompatibleNativeRootTrace_eq_none_of_unsafe parameter root target hroot before after ftsSecret + input next left hcontext.replaceable fuel table leftCache hsafe] + have hrightUnsafe : ¬NativeRootOuterSafe parameter target after before input right := + fun h => hsafe ((hcontext.outerSafe_swap_iff parameter input).mpr h) + have hzero := evalDist_observeCompatibleNativeRootTrace_eq_none_of_unsafe parameter root target hroot after before ftsSecret + input next right hcontext.symm.replaceable fuel table rightCache hrightUnsafe + have hswap : (observeCompatibleNativeRootTrace parameter target after before (α := α)) = + observeCompatibleNativeRootTrace parameter target before after := + funext (observeCompatibleNativeRootTrace_swap parameter target after before) + rw [hswap] at hzero + exact hzero.symm + · have hrightNot : ¬DeferredCompletable table right := fun h => hcomplete ((hcontext.completable_iff table).mp h) + rw [runNativeQueryTrace_of_not_completable parameter root ftsSecret _ left fuel table leftCache hcomplete, + runNativeQueryTrace_of_not_completable parameter root ftsSecret _ right fuel table rightCache hrightNot] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootTraceOrdinaryCache.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootTraceOrdinaryCache.lean new file mode 100644 index 00000000..63c4e65f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootTraceOrdinaryCache.lean @@ -0,0 +1,95 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootRecordLikelihood + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open _root_.OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem evalDist_nativeRootCompatibleTrace_ordinaryCache + (parameter : PublicParameter) (root : Digest) (target : Position) (before after : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) (hcache : OrdinarySplitCacheEq leftCache rightCache) : + evalDist (observeCompatibleNativeRootTrace parameter target before after <$> + runNativeQueryTrace parameter root ftsSecret computation context fuel table leftCache) = + evalDist (observeCompatibleNativeRootTrace parameter target before after <$> + runNativeQueryTrace parameter root ftsSecret computation context fuel table rightCache) := by + induction computation using OracleComp.inductionOn generalizing context fuel table leftCache rightCache with + | pure value => + simp only [runNativeQueryTrace, OracleComp.construct_pure] + split_ifs <;> simp [observeCompatibleNativeRootTrace, NativeRootTraceCompatible, normalizeNativeRootResult] + | query_bind input next ih => + by_cases hcomplete : DeferredCompletable table context + · rw [runNativeQueryTrace_query_bind, runNativeQueryTrace_query_bind, if_pos hcomplete, if_pos hcomplete] + simp only [map_bind] + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (ordinaryCacheNativeCouples_chronologicalOuterQuery parameter root ftsSecret input + leftCache rightCache hcache context fuel table) + intro leftResult rightResult hrel + cases leftResult with + | none => + cases rightResult with + | none => simp [observeCompatibleNativeRootTrace, NativeRootTraceCompatible] + | some rightResult => contradiction + | some leftResult => + cases rightResult with + | none => contradiction + | some rightResult => + rcases hrel with ⟨hcontext, hfuel, htable, hvalue, hnextCache⟩ + simp only + rw [← hcontext, ← hfuel, ← htable, ← hvalue] + have htail := ih leftResult.value.1 leftResult.context leftResult.remaining leftResult.table + leftResult.value.2 rightResult.value.2 hnextCache + have hmapped := evalDist_map_eq_of_evalDist_eq htail + (prependCompatibleNativeRootGuess before after + (nativeRootSelectionGuess? parameter target ⟨input, context, fuel, table, leftCache⟩)) + simpa only [map_eq_bind_pure_comp, Function.comp_def, bind_assoc, pure_bind, + observeCompatibleNativeRootTrace_prepend, nativeRootSelectionGuess?, nativeRootSelectionCandidate?] using hmapped + · rw [runNativeQueryTrace_of_not_completable parameter root ftsSecret _ context fuel table leftCache hcomplete, + runNativeQueryTrace_of_not_completable parameter root ftsSecret _ context fuel table rightCache hcomplete] + +theorem nativeRootSwapCacheRel_padded_of_no_guesses + (parameter : PublicParameter) (target : Position) (before after : HashOutput) (cache : SplitHashCache) + (hbefore : NoEncodingRootGuessCached parameter target (truncateHash before) cache) + (hafter : NoEncodingRootGuessCached parameter target (truncateHash after) cache) : + NativeRootSwapCacheRel parameter target before after + (replaceHiddenRootCache target before cache) (replaceHiddenRootCache target after cache) := by + refine ⟨replaceHiddenRootCache target before cache, ?_, ?_⟩ + · apply RootEncodingCacheRel.of_same_of_no_guesses + · intro input hinput + simpa [replaceHiddenRootCache] using hbefore input hinput + · intro input hinput + simpa [replaceHiddenRootCache] using hafter input hinput + · have hrel := rootHiddenCacheRel_replace target before after (replaceHiddenRootCache target before cache) + (by simp [replaceHiddenRootCache]) + simpa only [replaceHiddenRootCache, Function.update_idem] using hrel + +theorem probOutput_nativeRootTraceRecord_sameCache_eq_of_compatible + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (before after : HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (left right : DeferredContext) (hcontext : NativeRootContextRel target before after left right) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hbeforeCache : NoEncodingRootGuessCached parameter target (truncateHash before) cache) + (hafterCache : NoEncodingRootGuessCached parameter target (truncateHash after) cache) + (record : ResolvedRunResult α × Finset Digest) + (hbefore : truncateHash before ∉ record.2) (hafter : truncateHash after ∉ record.2) : + Pr[= some record | observeCompatibleNativeRootTrace parameter target before before <$> + runNativeQueryTrace parameter root ftsSecret computation left fuel table cache] = + Pr[= some record | observeCompatibleNativeRootTrace parameter target after after <$> + runNativeQueryTrace parameter root ftsSecret computation right fuel table cache] := by + have hleft := congrArg (fun distribution => distribution (some record)) + (evalDist_nativeRootCompatibleTrace_ordinaryCache parameter root target before before ftsSecret computation left fuel table + cache (replaceHiddenRootCache target before cache) (ordinarySplitCacheEq_replaceHiddenRootCache target before cache)) + have hright := congrArg (fun distribution => distribution (some record)) + (evalDist_nativeRootCompatibleTrace_ordinaryCache parameter root target after after ftsSecret computation right fuel table + cache (replaceHiddenRootCache target after cache) (ordinarySplitCacheEq_replaceHiddenRootCache target after cache)) + exact hleft.trans ((probOutput_nativeRootTraceRecord_eq_of_compatible parameter root target hroot before after ftsSecret + computation left right hcontext fuel table _ _ + (nativeRootSwapCacheRel_padded_of_no_guesses parameter target before after cache hbeforeCache hafterCache) + record hbefore hafter).trans hright.symm) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootTraceSafety.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootTraceSafety.lean new file mode 100644 index 00000000..23a7887c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootTraceSafety.lean @@ -0,0 +1,153 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootCandidateHistory + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem nativeRootSelectionGuess_mem_history + (parameter : PublicParameter) (target : Position) (selection : CanonicalQuerySelection) + (history : List CanonicalQuerySelection) (hmem : selection ∈ history) (guess : Digest) + (hguess : nativeRootSelectionGuess? parameter target selection = some guess) : + guess ∈ nativeRootCandidateHistory parameter target history := by + have hhash : IsOuterHash selection.input := by + cases hinput : selection.input with + | inl query => + cases query with + | inl n => simp [nativeRootSelectionGuess?, nativeRootSelectionCandidate?, hinput] at hguess + | inr input => trivial + | inr message => simp [nativeRootSelectionGuess?, nativeRootSelectionCandidate?, hinput] at hguess + simp only [nativeRootCandidateHistory, List.mem_toFinset, List.mem_filterMap] + refine ⟨selection, ?_, hguess⟩ + simpa only [nativeHashQueryHistory, List.mem_filter, decide_eq_true_eq] using And.intro hmem hhash + +theorem revealed_subset_of_mem_runNativeQueryTrace + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) (history : List CanonicalQuerySelection) + (hresult : (some result, history) ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) : + context.state.revealed ⊆ result.context.state.revealed := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache history with + | pure value => + simp only [runNativeQueryTrace, OracleComp.construct_pure] at hresult + split_ifs at hresult <;> simp only [mem_support_pure_iff, Prod.mk.injEq, Option.some.injEq] at hresult + · obtain ⟨rfl, _⟩ := hresult + exact Finset.Subset.refl _ + · simp at hresult + | query_bind input next ih => + rw [runNativeQueryTrace_query_bind] at hresult + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete, mem_support_bind_iff] at hresult + obtain ⟨middle, hmiddle, htail⟩ := hresult + cases middle with + | none => simp at htail + | some middle => + simp only [mem_support_bind_iff] at htail + obtain ⟨tail, htail, hresult⟩ := htail + simp only [mem_support_pure_iff, Prod.mk.injEq] at hresult + have htrace : (some result, tail.2) ∈ support + (runNativeQueryTrace parameter root ftsSecret (next middle.value.1) + middle.context middle.remaining middle.table middle.value.2) := by + simpa only [hresult.1] using htail + exact (revealed_subset_of_mem_runResolvedFromTable _ context fuel table middle hmiddle).trans + (ih middle.value.1 middle.context middle.remaining middle.table middle.value.2 tail.2 htrace) + · rw [if_neg hcomplete] at hresult + simp at hresult + +theorem nativeRootHashSafe_of_hidden_trace_avoids + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (before after : HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (h : NativePositionReplaceable target before after context) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) (history : List CanonicalQuerySelection) + (hresult : (some result, history) ∈ support (runNativeQueryTrace parameter root ftsSecret + (OracleSpec.query (spec := OracleWorld + SigningSpec) (.inl (.inr input)) >>= next) context fuel table cache)) + (hhidden : .position target ∉ result.context.state.revealed) + (hbefore : truncateHash before ∉ nativeRootCandidateHistory parameter target history) + (hafter : truncateHash after ∉ nativeRootCandidateHistory parameter target history) : + NativeRootHashSafe parameter target before after input context := by + rw [runNativeQueryTrace_query_bind] at hresult + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete, mem_support_bind_iff] at hresult + obtain ⟨middle, hmiddle, htail⟩ := hresult + cases middle with + | none => simp at htail + | some middle => + simp only [mem_support_bind_iff] at htail + obtain ⟨tail, htail, hresult⟩ := htail + simp only [mem_support_pure_iff, Prod.mk.injEq] at hresult + have htrace : (some result, tail.2) ∈ support + (runNativeQueryTrace parameter root ftsSecret (next middle.value.1) + middle.context middle.remaining middle.table middle.value.2) := by + simpa only [hresult.1] using htail + have hmiddleHidden : .position target ∉ middle.context.state.revealed := fun hmem => + hhidden (revealed_subset_of_mem_runNativeQueryTrace parameter root ftsSecret _ _ _ _ _ result tail.2 htrace hmem) + by_contra hunsafe + obtain ⟨candidate, hcandidate, hcoordinate, hguess⟩ := + nativeRootHashSafe_failure_of_hidden_result_candidate parameter target hroot before after input context h + fuel table cache hunsafe middle hmiddle hmiddleHidden + have hselection : nativeRootSelectionGuess? parameter target ⟨.inl (.inr input), context, fuel, table, cache⟩ = + some candidate.candidate := by + simp [nativeRootSelectionGuess?, nativeRootSelectionCandidate?, hcandidate, hcoordinate] + have hmem := nativeRootSelectionGuess_mem_history parameter target _ history + (by rw [hresult.2]; exact List.mem_cons_self) candidate.candidate hselection + rcases hguess with heq | heq + · exact hbefore (heq ▸ hmem) + · exact hafter (heq ▸ hmem) + · rw [if_neg hcomplete] at hresult + simp at hresult + +theorem nativeRootOuterSafe_of_hidden_trace_avoids + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (before after : HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (h : NativePositionReplaceable target before after context) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) (history : List CanonicalQuerySelection) + (hresult : (some result, history) ∈ support (runNativeQueryTrace parameter root ftsSecret + (OracleSpec.query input >>= next) context fuel table cache)) + (hhidden : .position target ∉ result.context.state.revealed) + (hbefore : truncateHash before ∉ nativeRootCandidateHistory parameter target history) + (hafter : truncateHash after ∉ nativeRootCandidateHistory parameter target history) : + NativeRootOuterSafe parameter target before after input context := by + cases input with + | inl query => + cases query with + | inl n => trivial + | inr input => + exact nativeRootHashSafe_of_hidden_trace_avoids parameter root target hroot before after ftsSecret input next context h + fuel table cache result history hresult hhidden hbefore hafter + | inr message => trivial + +def NativeRootTraceCompatible (parameter : PublicParameter) (target : Position) (before after : HashOutput) : + (Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) → Prop + | (none, _) => False + | (some result, history) => + .position target ∉ result.context.state.revealed ∧ + truncateHash before ∉ nativeRootCandidateHistory parameter target history ∧ + truncateHash after ∉ nativeRootCandidateHistory parameter target history + +theorem probEvent_nativeRootTraceCompatible_eq_zero_of_unsafe + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (before after : HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (h : NativePositionReplaceable target before after context) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hunsafe : ¬NativeRootOuterSafe parameter target before after input context) : + Pr[NativeRootTraceCompatible parameter target before after | + runNativeQueryTrace parameter root ftsSecret (OracleSpec.query input >>= next) context fuel table cache] = 0 := by + rw [probEvent_eq_zero_iff] + rintro ⟨option, history⟩ htrace hcompatible + cases option with + | none => exact hcompatible + | some result => + exact hunsafe (nativeRootOuterSafe_of_hidden_trace_avoids parameter root target hroot before after ftsSecret input next context h + fuel table cache result history htrace hcompatible.1 hcompatible.2.1 hcompatible.2.2) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootUnsafeAction.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootUnsafeAction.lean new file mode 100644 index 00000000..ca70d2c6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeRootUnsafeAction.lean @@ -0,0 +1,76 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootOuterCutStop +import SphincsSecurity.Proof.OtsProbeNativeStoredRootStructuralCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem purePeekTableInput_node_some_atPosition + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (lay : Layer) (tree : TreeIndex) (level : Fin maxLayerHeight) (nodeIdx : LeafIndex) (input : HashInput) + (hinput : purePeekTableInput parameter state (.position (.node lay tree level nodeIdx)) = some input) : + AtPosition parameter input (.node lay tree level nodeIdx) := by + simp only [purePeekTableInput] at hinput + cases hvalues : purePeekPositionValues state (Position.node lay tree level nodeIdx).children with + | none => simp [hvalues] at hinput + | some values => + simp only [hvalues, Option.some.injEq] at hinput + exact ⟨values.flatMap digestBytes, hinput.symm⟩ + +theorem nativeRootActionSafe_failure_exposure_or_structuralCharge + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) (before after : HashOutput) + (input : HashInput) (action : PlannedHashAction) (left right : DeferredContext) + (hcontext : NativeRootContextRel target before after left right) + (hhidden : .position target ∉ left.state.revealed) + (hunsafe : ¬NativeRootActionSafe parameter target input left right action) : + action = .resolve (.position target) ∨ KnownHiddenStructuralRootQuery parameter input left := by + cases action with + | ordinary => exact False.elim (hunsafe trivial) + | resolve coordinate => + by_cases htarget : coordinate = .position target + · exact Or.inl (congrArg PlannedHashAction.resolve htarget) + · have hne : purePeekTableInput parameter left.state coordinate ≠ purePeekTableInput parameter right.state coordinate := + fun heq => hunsafe (Or.inl ⟨htarget, heq⟩) + obtain ⟨parent, leftInput, rightInput, hcoordinate, hmem, hleft, hright⟩ := + hcontext.purePeekTableInput_ne_imp_known_child parameter coordinate hne + subst coordinate + obtain ⟨lay, tree, level, nodeIdx, hparent⟩ := exists_node_of_layerRoot_mem_children hroot hmem + have hat : AtPosition parameter input parent := by + by_cases hmatch : purePeekTableInput parameter left.state (.position parent) = some input + · rw [hparent] at hmatch ⊢ + exact purePeekTableInput_node_some_atPosition parameter left.state lay tree level nodeIdx input hmatch + · have hmatchRight : purePeekTableInput parameter right.state (.position parent) = some input := by + by_contra hmiss + exact hunsafe (Or.inr ⟨hmatch, hmiss⟩) + rw [hparent] at hmatchRight ⊢ + exact purePeekTableInput_node_some_atPosition parameter right.state lay tree level nodeIdx input hmatchRight + exact Or.inr ⟨parent, target, hat, hroot, hmem, hhidden, by rw [hleft]; simp⟩ + +theorem nativeRootHashSafe_failure_exposure_or_charged_query + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) (before after : HashOutput) + (input : HashInput) (context : DeferredContext) (h : NativePositionReplaceable target before after context) + (hhidden : .position target ∉ context.state.revealed) + (hunsafe : ¬NativeRootHashSafe parameter target before after input context) : + (EncodingInputGuessesRoot parameter target (truncateHash before) input ∨ + EncodingInputGuessesRoot parameter target (truncateHash after) input) ∨ + (∃ candidate, (purePlanProbingHashQuery parameter input context.state).candidate? = some candidate ∧ + IsPrivateValueExposure target before after (.probe candidate.coordinate candidate.candidate)) ∨ + (purePlanProbingHashQuery parameter input context.state).action = .resolve (.position target) ∨ + KnownHiddenStructuralRootQuery parameter input context := by + have hfailure := nativeRootHashSafe_failure_classify parameter target before after input context hunsafe + rw [h.replace_self] at hfailure + rcases hfailure with hencoding | hprobe | haction + · apply Or.inl + by_cases hleft : EncodingInputGuessesRoot parameter target (truncateHash before) input + · exact Or.inl hleft + · apply Or.inr + by_contra hright + exact hencoding ⟨hleft, hright⟩ + · exact Or.inr (Or.inl hprobe) + · exact Or.inr (Or.inr (nativeRootActionSafe_failure_exposure_or_structuralCharge parameter target hroot before after input _ + context (replaceNativePosition target after context) ⟨h, rfl⟩ hhidden haction)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStartCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStartCharge.lean new file mode 100644 index 00000000..e90ed336 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStartCharge.lean @@ -0,0 +1,136 @@ +import SphincsSecurity.Proof.OtsProbeStartAllowanceHash +import SphincsSecurity.Proof.OtsProbeStartAllowanceCounting + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def nativeStartCharge + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (_fuel : Nat) (_cache : SplitHashCache) : ENNReal := + match input with + | .inl (.inr input) => unresolvedStartCandidateAllowance table context + (purePlanProbingHashQuery parameter input context.state).candidate? + | _ => 0 + +theorem startAllowance_chronologicalQuery + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + liveStartProbeAllowance ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) + context fuel table = + if DeferredCompletable table context then nativeStartCharge parameter table input context fuel cache else 0 := by + cases input with + | inl input => + cases input with + | inl n => + simpa [nativeStartCharge, maskedChronologicalExpandedAdversaryImpl, probingRomImpl, maskedChronologicalSigningImpl] using + (liveStartProbeAllowance_eq_zero_of_probeFree _ context fuel table (splitUniformImpl_probeFree n cache)) + | inr hashInput => exact startAllowance_probingHashQuery parameter hashInput cache context fuel table hconsistent hstarts + | inr message => + simpa [nativeStartCharge, maskedChronologicalExpandedAdversaryImpl, probingRomImpl, maskedChronologicalSigningImpl] using + (liveStartProbeAllowance_eq_zero_of_probeFree _ context fuel table + (maskedPublishedChronologicalSign_probeFree parameter root ftsSecret message cache)) + +theorem startAllowance_chronological_eq_nativeCharge + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + liveStartProbeAllowance + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) context fuel table = + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (nativeStartCharge parameter table) computation context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => simp [liveStartProbeAllowance, expectedLiveNativeContextCharge] + | query_bind input next ih => + by_cases hcomplete : DeferredCompletable table context + · rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, + liveStartProbeAllowance_bind _ _ context fuel table hconsistent hstarts, + startAllowance_chronologicalQuery parameter root ftsSecret input context fuel table cache hconsistent hstarts, + if_pos hcomplete, expectedLiveNativeContextCharge_query_bind, if_pos hcomplete] + congr 1 + apply tsum_congr + intro option + by_cases hoption : option ∈ support (runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache)) + · cases option with + | none => simp [startContinuationAllowance] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table result hconsistent hstarts hoption + dsimp only [startContinuationAllowance] + rw [hcore.1, ih result.value.1 result.context result.remaining table result.value.2 hcore.2.1 hcore.2.2] + · simp [probOutput_eq_zero_of_not_mem_support hoption] + · rw [liveStartProbeAllowance_eq_zero_of_not_completable _ context fuel table hcomplete, + expectedLiveNativeContextCharge_eq_zero_of_not_completable _ _ _ context fuel table cache hcomplete] + +theorem sampled_nativeStartCharge_ensuredInitial_le_chainStartCharge + (targets : Finset Position) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (q fuel : Nat) (cache : SplitHashCache) (hq : q ≤ 2 ^ 126) + (hbound : ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache).IsQueryBoundP + LazyRevealProbe.IsProbe q) : + (∑' table, Pr[= table | sampleOtsHashTable] * + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (nativeStartCharge parameter table) computation (ensuredInitialContext targets) fuel table cache) ≤ + (∑' table, Pr[= table | sampleOtsHashTable] * expectedLiveResolvedQueryCharge chainStartProbeQueryCharge + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) + (ensuredInitialContext targets) fuel table) * ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + calc + _ = ∑' table, Pr[= table | sampleOtsHashTable] * liveStartProbeAllowance + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) + (ensuredInitialContext targets) fuel table := by + apply tsum_congr + intro table + rw [startAllowance_chronological_eq_nativeCharge parameter root ftsSecret computation + (ensuredInitialContext targets) fuel table cache (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table))] + _ ≤ _ := sampledEnsuredLiveStartAllowance_le_chainStartCharge targets _ fuel q hq hbound + +theorem initializedNativeDirectRisk_eq_startAllowance_add_privateAllowance + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) + (hbound : (nativeChronologicalRetainedComputation adversary parameter ftsSecret).IsQueryBoundP + LazyRevealProbe.IsProbe q) : + initializedNativeDirectRisk targets adversary parameter ftsSecret fuel q = + ∑' table, Pr[= table | sampleOtsHashTable] * + (liveStartProbeAllowance (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + (ensuredInitialContext targets) fuel table + + ∑ target ∈ targets, privateLiveProbeAllowance target + (nativeChronologicalRetainedComputation adversary parameter ftsSecret) (ensuredInitialContext targets) fuel table) := by + have hprivate : ∀ target ∈ targets, + (nativeChronologicalRetainedComputation adversary parameter ftsSecret).IsQueryBoundP + (IsPrivatePositionProbe target) q := by + intro target _ + apply OracleComp.IsQueryBoundP.of_imp _ hbound + intro input hinput + cases input <;> simp_all [IsPrivatePositionProbe, LazyRevealProbe.IsProbe] + rw [initializedNativeDirectRisk_eq_startHits_add_privateAllowance targets adversary parameter ftsSecret fuel q hprivate, + sum_sampledEnsuredNativeProbeCut_startHits_eq_liveAllowance targets _ fuel q hbound] + simp only [mul_add, ENNReal.tsum_add] + +theorem sampled_nativeMissingAllowances_le_initializedNativeDirectRisk + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) + (hbound : (nativeChronologicalRetainedComputation adversary parameter ftsSecret).IsQueryBoundP + LazyRevealProbe.IsProbe q) : + (∑' table, Pr[= table | sampleOtsHashTable] * + (liveStartProbeAllowance (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + (ensuredInitialContext targets) fuel table + + ∑ target ∈ targets, privateLiveMissingProbeAllowance target + (nativeChronologicalRetainedComputation adversary parameter ftsSecret) (ensuredInitialContext targets) fuel table)) ≤ + initializedNativeDirectRisk targets adversary parameter ftsSecret fuel q := by + rw [initializedNativeDirectRisk_eq_startAllowance_add_privateAllowance targets adversary parameter ftsSecret fuel q hbound] + apply ENNReal.tsum_le_tsum + intro table + apply mul_le_mul_right + apply add_le_add le_rfl + apply Finset.sum_le_sum + intro target _ + exact privateLiveMissingProbeAllowance_le_stoppedAllowance target _ (ensuredInitialContext targets) fuel table + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStoredRoot.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStoredRoot.lean new file mode 100644 index 00000000..a4a9d27a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStoredRoot.lean @@ -0,0 +1,218 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootCache + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +theorem resolveDeferredReveal_preserves_native_value + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (result : DeferredResolution) + (target : Position) (output : HashOutput) + (hknown : context.positionValue target = some output) + (hresult : some result ∈ support (resolveDeferredReveal table position context)) : + result.toDeferredContext.positionValue target = some output := by + unfold resolveDeferredReveal at hresult + split_ifs at hresult + · exact resolveDeferredPosition_preserves_positionValue table position context result target output hknown hresult + · exact resolveDeferredPositionValue_preserves_positionValue position target context result output hknown hresult + +set_option maxRecDepth 100000 in +theorem positionValue_of_mem_runResolved + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : ResolvedRunResult α) (target : Position) (output : HashOutput) + (hknown : context.positionValue target = some output) + (hresult : some result ∈ support (runResolvedFromTable context fuel table computation)) : + result.context.positionValue target = some output := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runResolvedFromTable] at hresult + subst result + exact hknown + | query_bind input next ih => + cases input with + | uniform n => + rw [runResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hknown hrest + | hashOutput => + rw [runResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hknown hrest + | ensure coordinate => + rw [runResolvedFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel + hknown hresult + | probe coordinate candidate => + rw [runResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · exact ih () context remaining hknown (by simpa [hrevealed] using hresult) + · exact ih () { context with state := context.state.addPending coordinate candidate } + remaining hknown (by simpa [hrevealed] using hresult) + | peek coordinate => + rw [runResolvedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hknown hresult + | publish coordinate => + rw [runResolvedFromTable_publish_query_bind] at hresult + exact ih () { context with state := context.state.publish coordinate } fuel + hknown hresult + | reveal coordinate => + rw [runResolvedFromTable_reveal_query_bind] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + simp only [mem_support_bind_iff, support_pure, Set.mem_singleton_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hresolvedEq : resolveDeferredChainStart table index context = some resolved := by + simpa [index] using hresolved.symm + exact ih resolved.output (materializeResolvedChainStart context index resolved) fuel + (by rwa [materializeResolvedChainStart_positionValue_eq table index context resolved hresolvedEq]) + (by simpa [index, OtsSecretIndex.coordinate, materializeResolvedChainStart] using hrest) + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hpreserved := resolveDeferredReveal_preserves_native_value + table position context resolved target output hknown hresolved + have hstate := resolveDeferredReveal_preserves_state_values table position context resolved hresolved + have hvalue := resolveDeferredReveal_resolves table position context resolved hresolved + exact ih resolved.output (materializeResolvedPosition context position resolved) fuel + (by + rw [materializeResolvedPosition_positionValue_eq context position resolved hstate hvalue] + exact hpreserved) + (by simpa [materializeResolvedPosition] using hrest) + +def StoredNativeLayerRoot (context : DeferredContext) (target : Position) (root : Digest) : Prop := + ∃ output, context.positionValue target = some output ∧ truncateHash output = root + +theorem storedNativeLayerRoot_of_mem_runResolved + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : ResolvedRunResult α) (target : Position) (root : Digest) + (hroot : StoredNativeLayerRoot context target root) + (hresult : some result ∈ support (runResolvedFromTable context fuel table computation)) : + StoredNativeLayerRoot result.context target root := by + obtain ⟨output, hknown, hroot⟩ := hroot + exact ⟨output, positionValue_of_mem_runResolved computation context fuel table result target output hknown hresult, hroot⟩ + +theorem revealPosition_value_of_stored_native + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (position : Position) (cache : SplitHashCache) (root : Digest) + (result : ResolvedRunResult (Digest × SplitHashCache)) + (hroot : StoredNativeLayerRoot context position root) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table ((revealCoordinate (.position position)).run cache))) : + result.value.1 = root := by + rw [runResolvedFromTable_revealCoordinate, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + simp only [mem_support_pure_iff, Option.some.injEq] at hrest + subst result + obtain ⟨output, hknown, htruncate⟩ := hroot + have hpreserved := resolveDeferredReveal_preserves_native_value table position context resolved position output hknown hresolved + have hvalue := resolveDeferredReveal_resolves table position context resolved hresolved + have heq : resolved.output = output := Option.some.inj (hvalue.symm.trans hpreserved) + exact heq ▸ htruncate + +set_option maxRecDepth 100000 in +theorem maskedTreeRoot_eq_of_stored_native + (lay : Layer) (tree : TreeIndex) + (state : DeferredContext) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : ResolvedRunResult (Digest × SplitHashCache)) (root : Digest) + (hroot : StoredNativeLayerRoot state (layerRootPosition lay tree) root) + (hresult : some result ∈ support + (runResolvedFromTable state fuel table ((maskedTreeRoot lay tree).run cache))) : + result.value.1 = root ∧ StoredNativeLayerRoot result.context (layerRootPosition lay tree) root := by + have horiginal := hresult + have hpos : 0 < layerHeight lay := by + unfold layerHeight + split <;> norm_num [maxLayerHeight] + have hlevel : layerHeight lay - 1 < maxLayerHeight := by + have hle := layerHeight_le lay + omega + unfold maskedTreeRoot at hresult + rw [show layerHeight lay = (layerHeight lay - 1) + 1 by omega, + maskedTreeNode, StateT.run_bind, runResolvedFromTable_bind, + mem_support_bind_iff] at hresult + obtain ⟨administrative, hadministrative, hreveal⟩ := hresult + cases administrative with + | none => simp at hreveal + | some administrative => + have hmiddleRoot := storedNativeLayerRoot_of_mem_runResolved + ((ensureTreeNode lay tree (layerHeight lay - 1 + 1) 0).run cache) + state fuel table administrative (layerRootPosition lay tree) root hroot + hadministrative + simp only at hreveal + rw [dif_pos hlevel] at hreveal + obtain ⟨output, hstored, htruncate⟩ := hmiddleRoot + change some result ∈ support + (runResolvedFromTable administrative.context administrative.remaining administrative.table + ((revealCoordinate (.position (layerRootPosition lay tree))).run + administrative.value.2)) at hreveal + exact ⟨revealPosition_value_of_stored_native administrative.context administrative.remaining + administrative.table (layerRootPosition lay tree) administrative.value.2 root result + ⟨output, hstored, htruncate⟩ hreveal, + storedNativeLayerRoot_of_mem_runResolved + ((maskedTreeRoot lay tree).run cache) state fuel table result + (layerRootPosition lay tree) root hroot horiginal⟩ + + +theorem maskedLayerMessage_eq_of_stored_native_of_eq + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay below : Layer) + (hcomputation : maskedLayerMessage parameter ftsSecret index lay = + maskedTreeRoot below (treeIndexAt index below)) + (hposition : layerMessagePosition index lay = + layerRootPosition below (treeIndexAt index below)) + (state : DeferredContext) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : ResolvedRunResult (Digest × SplitHashCache)) (root : Digest) + (hroot : StoredNativeLayerRoot state (layerMessagePosition index lay) root) + (hresult : some result ∈ support + (runResolvedFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run cache))) : + result.value.1 = root ∧ + StoredNativeLayerRoot result.context (layerMessagePosition index lay) root := by + rw [hcomputation] at hresult + rw [hposition] at hroot ⊢ + exact maskedTreeRoot_eq_of_stored_native below (treeIndexAt index below) + state cache fuel table result root hroot hresult + +theorem maskedLayerMessage_value_eq_of_stored_native + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) (root : Digest) + (index : Index) (lay : Layer) + (state : DeferredContext) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : ResolvedRunResult (Digest × SplitHashCache)) + (hstored : StoredNativeLayerRoot state target root) + (htarget : layerMessagePosition index lay = target) + (hresult : some result ∈ support + (runResolvedFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run cache))) : + result.value.1 = root := by + obtain ⟨below, hcomputation, hposition⟩ := + layerMessage_root_witness_of_isLayerRoot parameter ftsSecret target hroot index lay htarget + have hstoredMessage : StoredNativeLayerRoot state (layerMessagePosition index lay) root := by + rw [htarget] + exact hstored + exact (maskedLayerMessage_eq_of_stored_native_of_eq parameter ftsSecret index lay below + hcomputation hposition state cache fuel table result root hstoredMessage hresult).1 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStoredRootCutRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStoredRootCutRisk.lean new file mode 100644 index 00000000..631b8a43 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStoredRootCutRisk.lean @@ -0,0 +1,110 @@ +import SphincsSecurity.Proof.OtsProbeNativeStoredRootRisk +import SphincsSecurity.Proof.OtsProbeNativeRootCandidateNormalization +import SphincsSecurity.Proof.OuterHashQueryCut + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def nativeRootCutCandidate (parameter : PublicParameter) (target : Position) + (context : DeferredContext) (cut : OuterQueryCut α) : Option Digest := do + let input ← cut.input? + match input with + | .inl (.inr input) => + let candidate ← nativeRootCandidate? parameter input context + if candidate.coordinate = .position target then some candidate.candidate else none + | _ => none + +theorem nativeRootCutCandidate_replaceNativePosition + (parameter : PublicParameter) (target : Position) (output : HashOutput) (context : DeferredContext) (cut : OuterQueryCut α) : + nativeRootCutCandidate parameter target context cut = + nativeRootCutCandidate parameter target (replaceNativePosition target output context) cut := by + unfold nativeRootCutCandidate + apply congrArg (fun next => cut.input?.bind next) + funext input + cases input with + | inl query => + cases query with + | inl n => rfl + | inr input => + simp only + rw [nativeRootCandidate_replaceNativePosition parameter target output context input] + | inr message => rfl + +noncomputable def nativeRootTraceCutCandidate (parameter : PublicParameter) (target : Position) : + Option (ResolvedRunResult (OuterQueryCut α × SplitHashCache)) → Option Digest + | none => none + | some result => nativeRootCutCandidate parameter target result.context result.value.1 + +noncomputable def nativeStoredRootRecordCutCandidate (parameter : PublicParameter) (target : Position) + (record : ResolvedRunResult (OuterQueryCut α) × Finset Digest) : Option Digest := + nativeRootCutCandidate parameter target record.1.context record.1.value + +theorem nativeStoredRootRecordCutCandidate_observe + (parameter : PublicParameter) (target : Position) (before after : HashOutput) + (trace : Option (ResolvedRunResult (OuterQueryCut α × SplitHashCache)) × List CanonicalQuerySelection) : + (observeCompatibleNativeRootTrace parameter target before after trace).bind (nativeStoredRootRecordCutCandidate parameter target) = + if NativeRootTraceCompatible parameter target before after trace then nativeRootTraceCutCandidate parameter target trace.1 else none := by + unfold observeCompatibleNativeRootTrace + split_ifs with hcompatible + · rcases trace with ⟨option, history⟩ + cases option with + | none => contradiction + | some result => + simp only [normalizeNativeRootResult, Option.map_some, Option.bind_some, nativeStoredRootRecordCutCandidate, + nativeRootTraceCutCandidate] + exact (nativeRootCutCandidate_replaceNativePosition parameter target 0 result.context result.value.1).symm + · rfl + +noncomputable def sampleNativeStoredRootCut + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (ordinal : Nat) : ProbComp (HashOutput × Option Digest) := do + let output ← LazyRevealProbe.sampleHashOutput + if truncateHash output ∈ initialHistory then pure (output, none) else + let trace ← runNativeQueryTrace parameter root ftsSecret (outerHashQueryCutAt computation ordinal) + (replaceNativePosition target output context) fuel table cache + pure (output, if NativeRootTraceCompatible parameter target output output trace then + nativeRootTraceCutCandidate parameter target trace.1 else none) + +theorem sampleNativeStoredRootCut_eq_records + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (ordinal : Nat) : + sampleNativeStoredRootCut parameter root target ftsSecret computation context fuel table cache initialHistory ordinal = + samplePrivateHistoryGuess + (runNativeStoredRootRecords parameter root target ftsSecret (outerHashQueryCutAt computation ordinal) + context fuel table cache initialHistory) (nativeStoredRootRecordCutCandidate parameter target) := by + unfold sampleNativeStoredRootCut samplePrivateHistoryGuess + apply bind_congr + intro output + unfold runNativeStoredRootRecords + by_cases hinitial : truncateHash output ∈ initialHistory + · simp [hinitial] + · simp only [hinitial, ↓reduceIte, map_eq_bind_pure_comp, Function.comp_def, bind_assoc, pure_bind, + nativeStoredRootRecordCutCandidate_observe] + +theorem probEvent_sampleNativeStoredRootCut_hit_le_occurrence + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (hconsistent : context.ValuesConsistent) + (hpending : context.state.pendingAt (.position target) ⊆ initialHistory) + (hcache : ∀ digest, digest ∉ initialHistory → NoEncodingRootGuessCached parameter target digest cache) + (ordinal : Nat) (hbudget : initialHistory.card + ordinal ≤ 2 ^ 126) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | + sampleNativeStoredRootCut parameter root target ftsSecret computation context fuel table cache initialHistory ordinal] ≤ + Pr[fun pair => pair.2 ≠ none | + sampleNativeStoredRootCut parameter root target ftsSecret computation context fuel table cache initialHistory ordinal] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + rw [sampleNativeStoredRootCut_eq_records] + exact probEvent_sampleNativeStoredRootRecords_hit_le_occurrence parameter root target hroot ftsSecret + (outerHashQueryCutAt computation ordinal) context fuel table cache initialHistory hconsistent hpending hcache + ordinal (outerHashQueryCutAt_hashBound computation ordinal) hbudget _ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStoredRootRecords.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStoredRootRecords.lean new file mode 100644 index 00000000..0b6c5a58 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStoredRootRecords.lean @@ -0,0 +1,94 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootTraceOrdinaryCache + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def runNativeStoredRootRecords + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (output : HashOutput) : ProbComp (Option (ResolvedRunResult α × Finset Digest)) := + if truncateHash output ∈ initialHistory then pure none else + observeCompatibleNativeRootTrace parameter target output output <$> + runNativeQueryTrace parameter root ftsSecret computation (replaceNativePosition target output context) fuel table cache + +theorem nativeRootContextRel_replacements + (target : Position) (before after : HashOutput) (context : DeferredContext) + (hconsistent : context.ValuesConsistent) + (hbefore : ¬context.state.hitAt (.position target) before) + (hafter : ¬context.state.hitAt (.position target) after) : + NativeRootContextRel target before after (replaceNativePosition target before context) (replaceNativePosition target after context) := by + refine ⟨⟨replaceNativePosition_positionValue target before context, + hconsistent.of_replaceNativePosition target before, hbefore, hafter⟩, ?_⟩ + rw [replaceNativePosition_idem] + +theorem probOutput_nativeStoredRootRecords_eq_of_compatible + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (hconsistent : context.ValuesConsistent) + (hpending : context.state.pendingAt (.position target) ⊆ initialHistory) + (hcache : ∀ digest, digest ∉ initialHistory → NoEncodingRootGuessCached parameter target digest cache) + (before after : HashOutput) (record : ResolvedRunResult α × Finset Digest) + (hbefore : truncateHash before ∉ initialHistory ∪ record.2) + (hafter : truncateHash after ∉ initialHistory ∪ record.2) : + Pr[= some record | runNativeStoredRootRecords parameter root target ftsSecret computation context fuel table cache initialHistory before] = + Pr[= some record | runNativeStoredRootRecords parameter root target ftsSecret computation context fuel table cache initialHistory after] := by + have hbeforeInitial : truncateHash before ∉ initialHistory := fun hmem => hbefore (Finset.mem_union_left _ hmem) + have hafterInitial : truncateHash after ∉ initialHistory := fun hmem => hafter (Finset.mem_union_left _ hmem) + have hbeforeHistory : truncateHash before ∉ record.2 := fun hmem => hbefore (Finset.mem_union_right _ hmem) + have hafterHistory : truncateHash after ∉ record.2 := fun hmem => hafter (Finset.mem_union_right _ hmem) + rw [runNativeStoredRootRecords, if_neg hbeforeInitial, runNativeStoredRootRecords, if_neg hafterInitial] + apply probOutput_nativeRootTraceRecord_sameCache_eq_of_compatible parameter root target hroot before after ftsSecret computation + _ _ (nativeRootContextRel_replacements target before after context hconsistent + (fun hhit => hbeforeInitial (hpending hhit)) (fun hhit => hafterInitial (hpending hhit))) fuel table cache + (hcache _ hbeforeInitial) (hcache _ hafterInitial) record hbeforeHistory hafterHistory + +theorem nativeStoredRootRecords_supported_history + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (output : HashOutput) (bound : Nat) + (hbound : computation.IsQueryBoundP IsOuterHash bound) (record : ResolvedRunResult α × Finset Digest) + (hrecord : some record ∈ support (runNativeStoredRootRecords parameter root target ftsSecret computation context fuel table cache initialHistory output)) : + truncateHash output ∉ initialHistory ∪ record.2 ∧ record.2.card ≤ bound := by + unfold runNativeStoredRootRecords at hrecord + by_cases hinitial : truncateHash output ∈ initialHistory + · rw [if_pos hinitial] at hrecord + simp at hrecord + · rw [if_neg hinitial, support_map, Set.mem_image] at hrecord + obtain ⟨trace, htrace, heq⟩ := hrecord + rcases trace with ⟨option, history⟩ + cases option with + | none => simp [observeCompatibleNativeRootTrace, NativeRootTraceCompatible] at heq + | some result => + unfold observeCompatibleNativeRootTrace at heq + split_ifs at heq with hcompatible + · simp only [normalizeNativeRootResult, Option.map_some, Option.some.injEq] at heq + have hhistory := congrArg Prod.snd heq + have hclean : truncateHash output ∉ record.2 := by + rw [← hhistory] + exact hcompatible.2.1 + refine ⟨by simpa only [Finset.mem_union, not_or] using And.intro hinitial hclean, ?_⟩ + rw [← hhistory] + exact runNativeQueryTrace_root_history_card_le parameter root ftsSecret target computation + (replaceNativePosition target output context) fuel table cache bound hbound (some result, history) htrace + +theorem probOutput_nativeStoredRootRecords_eq_zero_of_history_hit + (parameter : PublicParameter) (root : Digest) (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (output : HashOutput) (bound : Nat) + (hbound : computation.IsQueryBoundP IsOuterHash bound) (record : ResolvedRunResult α × Finset Digest) + (hhit : truncateHash output ∈ initialHistory ∪ record.2) : + Pr[= some record | runNativeStoredRootRecords parameter root target ftsSecret computation context fuel table cache initialHistory output] = 0 := by + apply probOutput_eq_zero_of_not_mem_support + intro hrecord + exact (nativeStoredRootRecords_supported_history parameter root target ftsSecret computation context fuel table cache initialHistory + output bound hbound record hrecord).1 hhit + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStoredRootRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStoredRootRisk.lean new file mode 100644 index 00000000..c62c8202 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStoredRootRisk.lean @@ -0,0 +1,36 @@ +import SphincsSecurity.Proof.OtsProbeNativeStoredRootRecords + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem probEvent_sampleNativeStoredRootRecords_hit_le_occurrence + (parameter : PublicParameter) (root : Digest) (target : Position) (hroot : IsLayerRoot target) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (hconsistent : context.ValuesConsistent) + (hpending : context.state.pendingAt (.position target) ⊆ initialHistory) + (hcache : ∀ digest, digest ∉ initialHistory → NoEncodingRootGuessCached parameter target digest cache) + (bound : Nat) (hbound : computation.IsQueryBoundP IsOuterHash bound) + (hbudget : initialHistory.card + bound ≤ 2 ^ 126) + (candidate : ResolvedRunResult α × Finset Digest → Option Digest) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | samplePrivateHistoryGuess + (runNativeStoredRootRecords parameter root target ftsSecret computation context fuel table cache initialHistory) candidate] ≤ + Pr[fun pair => pair.2 ≠ none | samplePrivateHistoryGuess + (runNativeStoredRootRecords parameter root target ftsSecret computation context fuel table cache initialHistory) candidate] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply probEvent_samplePrivateHistoryGuess_hit_le_of_supported_compatible _ candidate (fun record => initialHistory ∪ record.2) + · exact probOutput_nativeStoredRootRecords_eq_of_compatible parameter root target hroot ftsSecret computation context fuel table cache + initialHistory hconsistent hpending hcache + · intro output record hhit + exact probOutput_nativeStoredRootRecords_eq_zero_of_history_hit parameter root target ftsSecret computation context fuel table cache + initialHistory output bound hbound record hhit + · intro output record hrecord + have hcard := (nativeStoredRootRecords_supported_history parameter root target ftsSecret computation context fuel table cache + initialHistory output bound hbound record hrecord).2 + exact (Finset.card_union_le _ _).trans ((Nat.add_le_add_left hcard initialHistory.card).trans hbudget) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStoredRootStructuralCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStoredRootStructuralCharge.lean new file mode 100644 index 00000000..55b12dad --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStoredRootStructuralCharge.lean @@ -0,0 +1,137 @@ +import SphincsSecurity.Proof.OtsProbeNativePlannedReserveComposition + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem exists_node_of_layerRoot_mem_children + {target parent : Position} (hroot : IsLayerRoot target) (hmem : target ∈ parent.children) : + ∃ lay tree level nodeIdx, parent = .node lay tree level nodeIdx := by + obtain ⟨lay, tree, rfl⟩ := hroot + have hparent := Position.mem_children_iff.mp hmem + simp only [layerRootPosition, Position.parentOf] at hparent + split_ifs at hparent with hlevel + · exact ⟨lay, tree, _, _, (Option.some.inj hparent).symm⟩ + +theorem firstMissingInputCoordinatePlan_eq_none_of_known + (state : LazyRevealProbe.State Coordinate) (input : HashInput) (coordinates : List Coordinate) + (hknown : ∀ coordinate ∈ coordinates, state.values coordinate ≠ none) (slot : Nat) : + firstMissingInputCoordinatePlan state input slot coordinates = none := by + induction coordinates generalizing slot with + | nil => rfl + | cons coordinate remaining ih => + cases hvalue : state.values coordinate with + | none => exact False.elim (hknown coordinate List.mem_cons_self hvalue) + | some value => + simp only [firstMissingInputCoordinatePlan, hvalue] + exact ih (fun other hmem => hknown other (List.mem_cons_of_mem coordinate hmem)) (slot + 1) + +theorem decodeProbe_eq_none_of_at_node + (parameter : PublicParameter) (input : HashInput) + (lay : Layer) (tree : TreeIndex) (level : Fin maxLayerHeight) (nodeIdx : LeafIndex) + (hat : AtPosition parameter input (.node lay tree level nodeIdx)) : + decodeProbe? parameter input = none := by + obtain ⟨payload, hinput⟩ := hat + rw [hinput] + exact decodeProbe?_tweakableHashInput_of_not_chain_leaf parameter + (Position.node lay tree level nodeIdx).domain payload + (Position.domain_inRange (.node lay tree level nodeIdx)) + (by intro _ _ _ _ _ heq; cases heq) + (by intro _ _ _ heq; cases heq) + +theorem purePlanProbingHashQuery_candidate_none_of_known_node + (parameter : PublicParameter) (input : HashInput) (state : LazyRevealProbe.State Coordinate) + (lay : Layer) (tree : TreeIndex) (level : Fin maxLayerHeight) (nodeIdx : LeafIndex) + (hat : AtPosition parameter input (.node lay tree level nodeIdx)) + (hknown : purePeekTableInput parameter state (.position (.node lay tree level nodeIdx)) ≠ none) : + (purePlanProbingHashQuery parameter input state).candidate? = none := by + have hdecode := (decodePosition?_eq_some_iff parameter input (.node lay tree level nodeIdx)).mpr hat + have hprobe := decodeProbe_eq_none_of_at_node parameter input lay tree level nodeIdx hat + have hchildren : purePeekPositionValues state (Position.node lay tree level nodeIdx).children ≠ none := by + intro hnone + exact hknown (by simp [purePeekTableInput, hnone]) + have hvalues : ∀ coordinate ∈ (Position.node lay tree level nodeIdx).children.map Coordinate.position, + state.values coordinate ≠ none := by + intro coordinate hmem hnone + obtain ⟨position, hposition, rfl⟩ := List.mem_map.mp hmem + exact hchildren ((purePeekPositionValues_eq_none_iff_missing state _).mpr ⟨position, hposition, hnone⟩) + rw [purePlanProbingHashQuery, hprobe, hdecode] + exact firstMissingInputCoordinatePlan_eq_none_of_known state input _ hvalues 0 + +def KnownHiddenStructuralRootQuery (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) : Prop := + ∃ parent target, AtPosition parameter input parent ∧ IsLayerRoot target ∧ target ∈ parent.children ∧ + .position target ∉ context.state.revealed ∧ purePeekTableInput parameter context.state (.position parent) ≠ none + +theorem KnownHiddenStructuralRootQuery.no_candidate + {parameter : PublicParameter} {input : HashInput} {context : DeferredContext} + (h : KnownHiddenStructuralRootQuery parameter input context) : + (purePlanProbingHashQuery parameter input context.state).candidate? = none := by + obtain ⟨parent, target, hat, hroot, hmem, _, hknown⟩ := h + obtain ⟨lay, tree, level, nodeIdx, rfl⟩ := exists_node_of_layerRoot_mem_children hroot hmem + exact purePlanProbingHashQuery_candidate_none_of_known_node parameter input context.state lay tree level nodeIdx hat hknown + +theorem KnownHiddenStructuralRootQuery.otsHashInputCharge + {parameter : PublicParameter} {input : HashInput} {context : DeferredContext} + (h : KnownHiddenStructuralRootQuery parameter input context) : otsHashInputCharge parameter input = 1 := by + obtain ⟨parent, target, hat, hroot, hmem, _, _⟩ := h + obtain ⟨lay, tree, level, nodeIdx, rfl⟩ := exists_node_of_layerRoot_mem_children hroot hmem + exact if_pos ⟨.node lay tree level nodeIdx, trivial, hat⟩ + +noncomputable def knownStructuralRootOuterCharge (parameter : PublicParameter) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (_fuel : Nat) (_cache : SplitHashCache) : ENNReal := + match input with + | .inl (.inr input) => if KnownHiddenStructuralRootQuery parameter input context then 1 else 0 + | _ => 0 + +theorem knownStructuralRootOuterCharge_le_unused + (parameter : PublicParameter) (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + knownStructuralRootOuterCharge parameter input context fuel cache ≤ + nativeUnusedProbeOuterCharge parameter input context fuel cache := by + cases input with + | inl input => + cases input with + | inl n => rfl + | inr input => + simp only [knownStructuralRootOuterCharge] + split_ifs with hknown + · simp [nativeUnusedProbeOuterCharge, hknown.no_candidate, hknown.otsHashInputCharge] + · exact zero_le + | inr message => rfl + +theorem knownHiddenStructuralRootQuery_replace_root_iff + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativeRootContextRel target before after left right) (parameter : PublicParameter) (input : HashInput) : + KnownHiddenStructuralRootQuery parameter input left ↔ KnownHiddenStructuralRootQuery parameter input right := by + have hrevealed : left.state.revealed = right.state.revealed := by rw [h.right_eq]; rfl + constructor + · rintro ⟨parent, rootPosition, hat, hroot, hmem, hhidden, hknown⟩ + refine ⟨parent, rootPosition, hat, hroot, hmem, hrevealed ▸ hhidden, ?_⟩ + intro hnone + exact hknown ((h.purePeekTableInput_none_iff parameter (.position parent)).mpr hnone) + · rintro ⟨parent, rootPosition, hat, hroot, hmem, hhidden, hknown⟩ + refine ⟨parent, rootPosition, hat, hroot, hmem, hrevealed.symm ▸ hhidden, ?_⟩ + intro hnone + exact hknown ((h.purePeekTableInput_none_iff parameter (.position parent)).mp hnone) + +theorem chronological_liveProbe_add_knownStructural_le_liveOuterCharge + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + expectedLiveResolvedQueryCharge nativeProbeQueryCharge + ((simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation).run cache) context fuel table + + expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (knownStructuralRootOuterCharge parameter) computation context fuel table cache ≤ + expectedLiveNativeOuterCharge (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (otsOuterQueryCharge parameter) computation context fuel table cache := by + apply simulateQ_expectedLiveQueryCharge_add_contextCharge_le_outer _ _ _ _ _ + computation context fuel table cache hconsistent hstarts + intro input nextCache nextContext remaining nextTable + exact (add_le_add le_rfl (knownStructuralRootOuterCharge_le_unused parameter input nextContext remaining nextCache)).trans + (chronologicalAdversaryImpl_probeCharge_add_unused_le_ots parameter root ftsSecret input nextCache nextContext remaining nextTable) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStructuralRootGuess.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStructuralRootGuess.lean new file mode 100644 index 00000000..2aa77ab5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeStructuralRootGuess.lean @@ -0,0 +1,178 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootExposure +import SphincsSecurity.Proof.Slot + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem purePeekPositionValues_some_eq_map + (state : LazyRevealProbe.State Coordinate) (positions : List Position) (values : List Digest) + (hvalues : purePeekPositionValues state positions = some values) : + values = positions.map (fun position => truncateHash ((state.values (.position position)).getD 0)) := by + induction positions generalizing values with + | nil => simpa [purePeekPositionValues] using hvalues.symm + | cons position remaining ih => + cases hhead : state.values (.position position) with + | none => simp [purePeekPositionValues, hhead] at hvalues + | some output => + cases htail : purePeekPositionValues state remaining with + | none => simp [purePeekPositionValues, hhead, htail] at hvalues + | some tail => + simp [purePeekPositionValues, hhead, htail] at hvalues + rw [← hvalues, ih tail htail] + simp [hhead] + +theorem slotDigest_purePeek_node_child + (parameter : PublicParameter) (context : DeferredContext) + (lay : Layer) (tree : TreeIndex) (level : Fin maxLayerHeight) (nodeIdx : LeafIndex) + (target : Position) (output : HashOutput) (input : HashInput) + (hmem : target ∈ (Position.node lay tree level nodeIdx).children) + (hknown : context.positionValue target = some output) + (hinput : purePeekTableInput parameter context.state (.position (.node lay tree level nodeIdx)) = some input) : + slotDigest ((Position.node lay tree level nodeIdx).children.idxOf target) input = truncateHash output := by + simp only [purePeekTableInput] at hinput + cases hvalues : purePeekPositionValues context.state (Position.node lay tree level nodeIdx).children with + | none => simp [hvalues] at hinput + | some values => + simp only [hvalues, Option.some.injEq] at hinput + have hmap := purePeekPositionValues_some_eq_map context.state _ values hvalues + have hidx := List.idxOf_lt_length_iff.mpr hmem + have hvalue : context.state.values (.position target) = some output := by + cases hstate : context.state.values (.position target) with + | none => + have hmissing := (purePeekPositionValues_eq_none_iff_missing context.state _).mpr ⟨target, hmem, hstate⟩ + rw [hvalues] at hmissing + contradiction + | some actual => + have heq : actual = output := by simpa [DeferredContext.positionValue, hstate] using hknown + exact congrArg some heq + rw [← hinput, slotDigest_flatMap parameter _ values _ (by simpa [hmap] using hidx)] + simp [hmap, List.getElem_idxOf hidx, hvalue] + +theorem nativeRootActionSafe_failure_structural_guess + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) (before after : HashOutput) + (input : HashInput) (coordinate : Coordinate) (left right : DeferredContext) + (hcontext : NativeRootContextRel target before after left right) + (hneTarget : coordinate ≠ .position target) + (hunsafe : ¬NativeRootActionSafe parameter target input left right (.resolve coordinate)) : + ∃ lay tree level nodeIdx, + coordinate = .position (.node lay tree level nodeIdx) ∧ + target ∈ (Position.node lay tree level nodeIdx).children ∧ + AtPosition parameter input (.node lay tree level nodeIdx) ∧ + (slotDigest ((Position.node lay tree level nodeIdx).children.idxOf target) input = truncateHash before ∨ + slotDigest ((Position.node lay tree level nodeIdx).children.idxOf target) input = truncateHash after) := by + have hne : purePeekTableInput parameter left.state coordinate ≠ purePeekTableInput parameter right.state coordinate := + fun heq => hunsafe (Or.inl ⟨hneTarget, heq⟩) + obtain ⟨parent, leftInput, rightInput, hcoordinate, hmem, hleft, hright⟩ := + hcontext.purePeekTableInput_ne_imp_known_child parameter coordinate hne + subst coordinate + obtain ⟨lay, tree, level, nodeIdx, rfl⟩ := exists_node_of_layerRoot_mem_children hroot hmem + refine ⟨lay, tree, level, nodeIdx, rfl, hmem, ?_⟩ + by_cases hmatch : purePeekTableInput parameter left.state (.position (.node lay tree level nodeIdx)) = some input + · exact ⟨purePeekTableInput_node_some_atPosition parameter left.state lay tree level nodeIdx input hmatch, + Or.inl (slotDigest_purePeek_node_child parameter left lay tree level nodeIdx target before input hmem + hcontext.replaceable.known hmatch)⟩ + · have hmatchRight : purePeekTableInput parameter right.state (.position (.node lay tree level nodeIdx)) = some input := by + by_contra hmiss + exact hunsafe (Or.inr ⟨hmatch, hmiss⟩) + refine ⟨purePeekTableInput_node_some_atPosition parameter right.state lay tree level nodeIdx input hmatchRight, Or.inr ?_⟩ + apply slotDigest_purePeek_node_child parameter right lay tree level nodeIdx target after input hmem _ hmatchRight + rw [hcontext.right_eq] + exact replaceNativePosition_positionValue target after left + +theorem layerRoot_unique_of_mem_children + {left right parent : Position} (hleft : IsLayerRoot left) (hright : IsLayerRoot right) + (hleftMem : left ∈ parent.children) (hrightMem : right ∈ parent.children) : left = right := by + obtain ⟨leftLay, leftTree, rfl⟩ := hleft + obtain ⟨rightLay, rightTree, rfl⟩ := hright + have hleftParent := Position.mem_children_iff.mp hleftMem + have hrightParent := Position.mem_children_iff.mp hrightMem + simp only [layerRootPosition, Position.parentOf] at hleftParent hrightParent + split_ifs at hleftParent with hleftLevel + split_ifs at hrightParent with hrightLevel + have heq := (Option.some.inj hleftParent).trans (Option.some.inj hrightParent).symm + obtain ⟨rfl, rfl, _, _⟩ := Position.node.inj heq + rfl + +def StructuralLayerRootCandidateAt (parameter : PublicParameter) (input : HashInput) (candidate : Probe) : Prop := + ∃ parent target, AtPosition parameter input parent ∧ IsLayerRoot target ∧ target ∈ parent.children ∧ + candidate = ⟨.position target, slotDigest (parent.children.idxOf target) input⟩ + +theorem structuralLayerRootCandidateAt_unique + {parameter : PublicParameter} {input : HashInput} {left right : Probe} + (hleft : StructuralLayerRootCandidateAt parameter input left) + (hright : StructuralLayerRootCandidateAt parameter input right) : left = right := by + obtain ⟨leftParent, leftTarget, hleftAt, hleftRoot, hleftMem, rfl⟩ := hleft + obtain ⟨rightParent, rightTarget, hrightAt, hrightRoot, hrightMem, rfl⟩ := hright + have hparent := atPosition_unique parameter hleftAt hrightAt + subst rightParent + have htarget := layerRoot_unique_of_mem_children hleftRoot hrightRoot hleftMem hrightMem + subst rightTarget + rfl + +theorem nativeRootActionSafe_failure_structural_candidate + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) (before after : HashOutput) + (input : HashInput) (coordinate : Coordinate) (left right : DeferredContext) + (hcontext : NativeRootContextRel target before after left right) + (hneTarget : coordinate ≠ .position target) + (hunsafe : ¬NativeRootActionSafe parameter target input left right (.resolve coordinate)) : + ∃ candidate, StructuralLayerRootCandidateAt parameter input candidate ∧ + candidate.coordinate = .position target ∧ + (candidate.candidate = truncateHash before ∨ candidate.candidate = truncateHash after) := by + obtain ⟨lay, tree, level, nodeIdx, _, hmem, hat, hguess⟩ := + nativeRootActionSafe_failure_structural_guess parameter target hroot before after input coordinate left right hcontext hneTarget hunsafe + let parent := Position.node lay tree level nodeIdx + let candidate : Probe := ⟨.position target, slotDigest (parent.children.idxOf target) input⟩ + refine ⟨candidate, ?_, ?_, ?_⟩ + · exact ⟨parent, target, hat, hroot, hmem, rfl⟩ + · rfl + · simpa only [candidate, parent] using hguess + +theorem nativeRootHashSafe_failure_of_hidden_result_guesses + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) (before after : HashOutput) + (input : HashInput) (context : DeferredContext) (h : NativePositionReplaceable target before after context) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hunsafe : ¬NativeRootHashSafe parameter target before after input context) + (result : ResolvedRunResult (HashOutput × SplitHashCache)) + (hresult : some result ∈ support (runResolvedFromTable context fuel table ((probingHashQuery parameter input).run cache))) + (hhidden : .position target ∉ result.context.state.revealed) : + (EncodingInputGuessesRoot parameter target (truncateHash before) input ∨ + EncodingInputGuessesRoot parameter target (truncateHash after) input) ∨ + (∃ candidate, (purePlanProbingHashQuery parameter input context.state).candidate? = some candidate ∧ + IsPrivateValueExposure target before after (.probe candidate.coordinate candidate.candidate)) ∨ + (KnownHiddenStructuralRootQuery parameter input context ∧ + ∃ candidate, StructuralLayerRootCandidateAt parameter input candidate ∧ + candidate.coordinate = .position target ∧ + (candidate.candidate = truncateHash before ∨ candidate.candidate = truncateHash after)) := by + have hinitial : .position target ∉ context.state.revealed := fun hmem => + hhidden (revealed_subset_of_mem_runResolvedFromTable _ context fuel table result hresult hmem) + have hfailure := nativeRootHashSafe_failure_classify parameter target before after input context hunsafe + rw [h.replace_self] at hfailure + rcases hfailure with hencoding | hprobe | haction + · apply Or.inl + by_cases hleft : EncodingInputGuessesRoot parameter target (truncateHash before) input + · exact Or.inl hleft + · apply Or.inr + by_contra hright + exact hencoding ⟨hleft, hright⟩ + · exact Or.inr (Or.inl hprobe) + · have hrel : NativeRootContextRel target before after context (replaceNativePosition target after context) := ⟨h, rfl⟩ + cases hplan : (purePlanProbingHashQuery parameter input context.state).action with + | ordinary => rw [hplan] at haction; exact False.elim (haction trivial) + | resolve coordinate => + rw [hplan] at haction + by_cases htarget : coordinate = .position target + · subst coordinate + exact False.elim (hhidden (nativeRootHash_target_action_failure_publishes parameter target hroot before after input + context _ hrel fuel table cache hplan haction result hresult)) + · have hstructural := nativeRootActionSafe_failure_exposure_or_structuralCharge parameter target hroot before after input + (.resolve coordinate) context _ hrel hinitial haction + have hcharge : KnownHiddenStructuralRootQuery parameter input context := hstructural.resolve_left + (fun heq => htarget (PlannedHashAction.resolve.inj heq)) + exact Or.inr (Or.inr ⟨hcharge, nativeRootActionSafe_failure_structural_candidate parameter target hroot before after + input coordinate context _ hrel htarget haction⟩) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeSupportedAllowances.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeSupportedAllowances.lean new file mode 100644 index 00000000..7471b178 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeSupportedAllowances.lean @@ -0,0 +1,129 @@ +import SphincsSecurity.Proof.OtsProbeNativeTraceSafety + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot instFintypePosition +set_option backward.isDefEq.respectTransparency false + +theorem expected_nativeMaterializedRetainedTraceCharge_le + (targets : Finset Position) (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) (fuel : Nat) : + (∑' trace, Pr[= trace | nativeChainTraceAfterRoot targets parameter table ftsSecret fuel (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)] * + canonicalTraceCharge (nativeMaterializedCharge parameter table) trace.2) ≤ + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ (q : ENNReal) * Pr[fun trace => ¬NativeChainsPublished trace | + nativeChainTraceAfterRoot targets parameter table ftsSecret fuel (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)] := by + rw [probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_left] + apply ENNReal.tsum_le_tsum + intro trace + by_cases htrace : trace ∈ support (nativeChainTraceAfterRoot targets parameter table ftsSecret fuel (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)) + · by_cases hpublic : NativeChainsPublished trace + · rw [nativeMaterializedTraceCharge_eq_zero_of_chainsPublished parameter table trace.2 hpublic.2] + simp [hpublic] + · simp only [hpublic, not_false_eq_true, ite_true] + rw [mul_comm (q : ENNReal)] + apply mul_le_mul_right + exact (nativeMaterializedTraceCharge_le_hashLength parameter table trace.2).trans + (by exact_mod_cast (by + rw [← canonicalTraceHashCount_eq_nativeHashLength] + exact nativeRetainedTraceAfterRoot_hashCount_le targets adversary q hq parameter hparameter table ftsSecret hfts fuel trace htrace : + (nativeHashQueryHistory trace.2).length ≤ q)) + · simp [probOutput_eq_zero_of_not_mem_support htrace] + _ ≤ _ := mul_le_mul_right (probEvent_nativeChainTraceAfterRoot_failure_le_inv216 targets parameter table ftsSecret fuel (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)) _ + +theorem expected_nativeMaterializedRetainedCharge_le + (targets : Finset Position) (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) (fuel : Nat) : + (∑' root, Pr[= root | runResolvedFromTable (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)] * + match root with + | none => 0 + | some root => expectedLiveNativeContextCharge (maskedChronologicalExpandedAdversaryImpl parameter root.value.1 ftsSecret) + (nativeMaterializedCharge parameter table) (retainedGameRestComputation adversary ⟨root.value.1, parameter⟩) + root.context root.remaining root.table root.value.2) ≤ + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + have hbound := expected_nativeMaterializedRetainedTraceCharge_le targets adversary q hq parameter hparameter table ftsSecret hfts fuel + rw [nativeChainTraceAfterRoot, tsum_probOutput_bind_mul] at hbound + convert hbound using 1 + apply tsum_congr + intro root + cases root with + | none => simp [canonicalTraceCharge] + | some root => rw [expectedNativeTraceCharge_eq] + +theorem canonicalTraceCharge_eq_native_components_of_safe + (targets : Finset Position) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) (history : List CanonicalQuerySelection) + (hsafe : ∀ entry ∈ history, 0 < entry.fuel ∧ entry.context.state.pending.card + 1 < Fintype.card Digest) + (hcoverage : ∀ entry ∈ history, ∀ input, entry.input = .inl (.inr input) → ∀ target digest, + (purePlanProbingHashQuery parameter input entry.context.state).candidate? = some ⟨.position target, digest⟩ → target ∈ targets) : + canonicalTraceCharge (canonicalGuessCharge parameter table) history = + canonicalTraceCharge (nativeStartCharge parameter table) history + + (∑ target ∈ targets, canonicalTraceCharge (nativeMissingStructuralCharge target parameter table) history) + + canonicalTraceCharge (nativeMaterializedCharge parameter table) history := by + induction history with + | nil => simp [canonicalTraceCharge] + | cons head tail ih => + have hhead := canonicalGuessCharge_eq_native_components_of_safe targets parameter table head.input head.context head.fuel head.cache + (hsafe head (by simp)) (hcoverage head (by simp)) + have htail := ih (fun entry hentry => hsafe entry (by simp [hentry])) + (fun entry hentry => hcoverage entry (by simp [hentry])) + simp only [canonicalTraceCharge, List.map_cons, List.sum_cons, CanonicalQuerySelection.charge] at htail ⊢ + rw [hhead, htail, Finset.sum_add_distrib] + ac_rfl + +theorem nativeRetainedTraceCharge_eq_components + (targets : Finset Position) (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (trace : Option (ResolvedRunResult (RetainedRestResult × SplitHashCache)) × List CanonicalQuerySelection) + (htrace : trace ∈ support (nativeChainTraceAfterRoot targets parameter table ftsSecret (q + 1) + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩))) : + canonicalTraceCharge (canonicalGuessCharge parameter table) trace.2 = + canonicalTraceCharge (nativeStartCharge parameter table) trace.2 + + (∑ target : Position, canonicalTraceCharge (nativeMissingStructuralCharge target parameter table) trace.2) + + canonicalTraceCharge (nativeMaterializedCharge parameter table) trace.2 := by + exact canonicalTraceCharge_eq_native_components_of_safe Finset.univ parameter table trace.2 + (nativeRetainedTraceAfterRoot_entry_safe targets adversary q hq hqMax parameter hparameter table ftsSecret hfts trace htrace) + (by intro entry hentry input heq target digest hcandidate; exact Finset.mem_univ target) + +theorem expected_nativeRetainedGuessCharge_le_missing_add_erasure + (targets : Finset Position) (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + (∑' trace, Pr[= trace | nativeChainTraceAfterRoot targets parameter table ftsSecret (q + 1) + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)] * + canonicalTraceCharge (canonicalGuessCharge parameter table) trace.2) ≤ + (∑' trace, Pr[= trace | nativeChainTraceAfterRoot targets parameter table ftsSecret (q + 1) + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)] * + (canonicalTraceCharge (nativeStartCharge parameter table) trace.2 + + ∑ target : Position, canonicalTraceCharge (nativeMissingStructuralCharge target parameter table) trace.2)) + + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + let traceRun := nativeChainTraceAfterRoot targets parameter table ftsSecret (q + 1) + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩) + have heq : (∑' trace, Pr[= trace | traceRun] * canonicalTraceCharge (canonicalGuessCharge parameter table) trace.2) = + ∑' trace, Pr[= trace | traceRun] * + ((canonicalTraceCharge (nativeStartCharge parameter table) trace.2 + + ∑ target : Position, canonicalTraceCharge (nativeMissingStructuralCharge target parameter table) trace.2) + + canonicalTraceCharge (nativeMaterializedCharge parameter table) trace.2) := by + apply tsum_congr + intro trace + by_cases htrace : trace ∈ support traceRun + · rw [nativeRetainedTraceCharge_eq_components targets adversary q hq hqMax parameter hparameter table ftsSecret hfts trace htrace] + · simp [probOutput_eq_zero_of_not_mem_support htrace] + change _ ≤ _ + _ + rw [heq] + simp only [mul_add, ENNReal.tsum_add] + apply add_le_add le_rfl + exact expected_nativeMaterializedRetainedTraceCharge_le targets adversary q hq parameter hparameter table ftsSecret hfts (q + 1) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeSupportedBudget.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeSupportedBudget.lean new file mode 100644 index 00000000..8822390b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeSupportedBudget.lean @@ -0,0 +1,93 @@ +import SphincsSecurity.Proof.OtsProbeNativeMaterializedAllowance +import SphincsSecurity.Proof.OtsProbeNativeQueryTraceCoupling + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +theorem canonicalTraceHashCount_eq_nativeHashLength (history : List CanonicalQuerySelection) : + canonicalTraceHashCount history = (nativeHashQueryHistory history).length := by + induction history with + | nil => rfl + | cons head tail ih => + simp only [canonicalTraceHashCount, List.map_cons, List.sum_cons] at ih ⊢ + cases hinput : head.input with + | inl input => + cases input <;> simp [nativeHashQueryHistory, hinput, IsOuterHash, outerHashQueryCount] at ih ⊢ <;> omega + | inr message => simpa [nativeHashQueryHistory, hinput, IsOuterHash, outerHashQueryCount] using ih + +theorem nativeTrace_hashCount_le_of_expanded + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel q : Nat) (cache : SplitHashCache) (actualCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) actualCache) + (hvisible : VisibleResolvedComputationsCached parameter table context actualCache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) + (hbound : (simulateQ (expandedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey)) + computation).IsQueryBoundP (· matches Sum.inr _) q) + (trace : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) + (htrace : trace ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) : + canonicalTraceHashCount trace.2 ≤ q := by + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + let state : ViewedFullTraceState × Bool := (⟨actualCache, ⟨[], [], []⟩, [], none⟩, false) + obtain ⟨actual, hactual, hrel⟩ := exists_right_of_relTriple_of_mem_support + (relTriple_nativeQueryTrace_prehitQueryTrace parameter root table ftsSecret secretKey computation context fuel cache state + hinvariant hvisible hpublished hcomputed) htrace + exact hrel.hashCount_le.trans (prehitTraceHashCount_le_of_expanded secretKey secretKey computation q hbound state actual hactual) + +theorem nativeChainTraceAfterRoot_hashCount_le_of_expanded + (targets : Finset Position) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) + (hbound : ∀ root, (simulateQ (expandedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ : SecretKey)) + (continuation root)).IsQueryBoundP (· matches Sum.inr _) q) + (trace : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) + (htrace : trace ∈ support (nativeChainTraceAfterRoot targets parameter table ftsSecret fuel continuation)) : + canonicalTraceHashCount trace.2 ≤ q := by + rw [nativeChainTraceAfterRoot, mem_support_bind_iff] at htrace + obtain ⟨root, hroot, htrace⟩ := htrace + cases root with + | none => + simp only [mem_support_pure_iff] at htrace + subst trace + simp [canonicalTraceHashCount] + | some root => + have hrel := reachableResolvedCouples_maskedPublishedTreeRoot parameter table (ensuredInitialContext targets) + fuel emptySplitHashCache ∅ (ensuredInitialContext_resolvedInvariant targets parameter table) + (ensuredInitialContext_visible targets parameter table) (ensuredInitialContext_published targets) + obtain ⟨actual, _, hrel⟩ := exists_right_of_relTriple_of_mem_support hrel hroot + rcases hrel with hclean | hdoomed + · dsimp only at htrace + rw [hclean.1] at htrace + exact nativeTrace_hashCount_le_of_expanded parameter root.value.1 table ftsSecret (continuation root.value.1) + root.context root.remaining q root.value.2 actual.2 hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 + ((ensuredInitialContext_computed targets).of_mem_runResolved _ _ fuel table root hroot) + (hbound root.value.1) trace htrace + · dsimp only at htrace + rw [runNativeQueryTrace_of_not_completable parameter root.value.1 ftsSecret (continuation root.value.1) + root.context root.remaining root.table root.value.2 (by rw [hdoomed.1]; exact hdoomed.2.2.2)] at htrace + simp only [mem_support_pure_iff] at htrace + subst trace + simp [canonicalTraceHashCount] + +theorem nativeRetainedTraceAfterRoot_hashCount_le + (targets : Finset Position) (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) (fuel : Nat) + (trace : Option (ResolvedRunResult (RetainedRestResult × SplitHashCache)) × List CanonicalQuerySelection) + (htrace : trace ∈ support (nativeChainTraceAfterRoot targets parameter table ftsSecret fuel + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩))) : + canonicalTraceHashCount trace.2 ≤ q := by + apply nativeChainTraceAfterRoot_hashCount_le_of_expanded targets parameter table ftsSecret fuel q _ _ trace htrace + intro root + exact isQueryBoundP_expandedRetained_all_tables_roots adversary q hq parameter hparameter table ftsSecret hfts root + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeSupportedRootProjection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeSupportedRootProjection.lean new file mode 100644 index 00000000..f088108f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeSupportedRootProjection.lean @@ -0,0 +1,139 @@ +import SphincsSecurity.Proof.OtsProbeNativeSupportedAllowances +import SphincsSecurity.Proof.OtsProbeNativeRootHitProjection + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +theorem nativeTrace_rootHistoryMatch_selectedHit_of_hashLength + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) (history : List CanonicalQuerySelection) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hmat : LayerRootsMaterialized context) (hclosed : DeferredComputationsClosed context) + (hresult : (some result, history) ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) + (hsource : ¬UnknownSourceFinalRootMatch parameter (some result, history)) + (lay : Layer) (tree : TreeIndex) (output : HashOutput) + (hvalue : result.context.positionValue (layerRootPosition lay tree) = some output) + (hhidden : .position (layerRootPosition lay tree) ∉ result.context.state.revealed) + (hmatch : truncateHash output ∈ nativeRootCandidateHistory parameter (layerRootPosition lay tree) history) + (q : Nat) (hlength : (nativeHashQueryHistory history).length ≤ q) : + ∃ ordinal ∈ Finset.range q, + NativeRootHistorySelectionHit parameter (layerRootPosition lay tree) (nativeHashHistorySelection history ordinal) := by + obtain ⟨completion, hcompletion⟩ := (nativeTrace_finalCore parameter root ftsSecret computation context fuel table cache result history + hconsistent hstarts hresult).2.2 + obtain ⟨prior, selection, suffix, hhistory, hprior, hstored, hhidden, hcandidate⟩ := + nativeTrace_rootHistoryMatch_firstCharged parameter root ftsSecret computation context fuel table cache result history completion + hconsistent hstarts hmat hclosed hresult hcompletion hsource lay tree output hvalue hhidden hmatch + have hhash : IsOuterHash selection.input := by + cases hinput : selection.input with + | inl query => + cases query with + | inl n => simp [chargedNativeRootQueryCandidate, hinput] at hcandidate + | inr input => trivial + | inr message => simp [chargedNativeRootQueryCandidate, hinput] at hcandidate + have hpriorLength : (nativeHashQueryHistory prior).length < q := by + rw [hhistory] at hlength + simp only [nativeHashQueryHistory, List.filter_append, List.filter_cons, hhash, decide_true, ↓reduceIte, + List.length_append, List.length_cons] at hlength ⊢ + omega + refine ⟨(nativeHashQueryHistory prior).length, Finset.mem_range.mpr hpriorLength, + nativeHashQueryHistory prior, selection, output, ?_, hstored, hhidden, ?_, hcandidate⟩ + · rw [hhistory] + exact nativeHashHistorySelection_append_hash prior selection suffix hhash + · simpa only [nativeRootCandidateHistory_hashHistory] using hprior + +theorem probEvent_nativeFinalRootHistoryMatch_le_cutHitSum_of_supportedCount + (parameter : PublicParameter) (root : Digest) (lay : Layer) (tree : TreeIndex) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hmat : LayerRootsMaterialized context) (hclosed : DeferredComputationsClosed context) + (q : Nat) (hbound : ∀ trace ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache), + canonicalTraceHashCount trace.2 ≤ q) : + Pr[NativeFinalRootHistoryMatch parameter (layerRootPosition lay tree) | + runNativeQueryTrace parameter root ftsSecret computation context fuel table cache] ≤ + ∑ ordinal ∈ Finset.range q, + Pr[fun b => b = false | originalChargedRootCutObservation parameter root (layerRootPosition lay tree) ftsSecret computation + context fuel table cache ∅ ordinal (fun pair => pair.2 = some (truncateHash pair.1))] := by + calc + _ ≤ Pr[fun trace => ∃ ordinal ∈ Finset.range q, + NativeRootHistorySelectionHit parameter (layerRootPosition lay tree) (nativeHashHistorySelection trace.2 ordinal) | + runNativeQueryTrace parameter root ftsSecret computation context fuel table cache] := by + apply probEvent_mono + rintro ⟨option, history⟩ htrace ⟨result, output, heq, hvalue, hhidden, hmatch, hsource⟩ + dsimp only at heq + subst option + exact nativeTrace_rootHistoryMatch_selectedHit_of_hashLength parameter root ftsSecret computation context fuel table cache result history + hconsistent hstarts hmat hclosed htrace hsource lay tree output hvalue hhidden hmatch q (by rw [← canonicalTraceHashCount_eq_nativeHashLength]; exact hbound (some result, history) htrace) + _ ≤ ∑ ordinal ∈ Finset.range q, + Pr[fun trace => NativeRootHistorySelectionHit parameter (layerRootPosition lay tree) (nativeHashHistorySelection trace.2 ordinal) | + runNativeQueryTrace parameter root ftsSecret computation context fuel table cache] := + probEvent_exists_finset_le_sum (Finset.range q) _ _ + _ ≤ _ := by + apply Finset.sum_le_sum + intro ordinal _ + exact probEvent_nativeHistorySelectionHit_le_originalChargedRootCut parameter root (layerRootPosition lay tree) ftsSecret computation ordinal + context fuel table cache hconsistent hstarts + +theorem probEvent_nativeRetainedFinalRootMatch_le_initializedCutHitSum + (targets : Finset Position) (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) (fuel : Nat) (lay : Layer) (tree : TreeIndex) : + Pr[NativeFinalRootHistoryMatch parameter (layerRootPosition lay tree) | + nativeChainTraceAfterRoot targets parameter table ftsSecret fuel (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)] ≤ + ∑ ordinal ∈ Finset.range q, + Pr[fun b => b = false | initializedChargedRootCutObservation targets adversary parameter (layerRootPosition lay tree) + table ftsSecret fuel ordinal (fun pair => pair.2 = some (truncateHash pair.1))] := by + unfold nativeChainTraceAfterRoot initializedChargedRootCutObservation + simp only [probEvent_bind_eq_tsum] + rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + apply ENNReal.tsum_le_tsum + intro root + by_cases hroot : root ∈ support (runResolvedFromTable (ensuredInitialContext targets) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) + · cases root with + | none => simp [NativeFinalRootHistoryMatch] + | some root => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ (ensuredInitialContext targets) fuel table root + (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table)) hroot + have hmat := rootMaterializationPreserving_maskedPublishedTreeRoot (ensuredInitialContext targets) fuel table emptySplitHashCache root + (layerRootsMaterialized_ensuredInitialContext targets) (ensuredInitialContext_computed targets) hroot + have hclosed := (ensuredInitialContext_computed targets).of_mem_runResolved _ _ fuel table root hroot + simp only [← Finset.mul_sum, hcore.1] + apply mul_le_mul_right + apply probEvent_nativeFinalRootHistoryMatch_le_cutHitSum_of_supportedCount parameter root.value.1 lay tree ftsSecret + (retainedGameRestComputation adversary ⟨root.value.1, parameter⟩) root.context root.remaining table root.value.2 + hcore.2.1 hcore.2.2 hmat hclosed q + intro trace htrace + apply nativeRetainedTraceAfterRoot_hashCount_le targets adversary q hq parameter hparameter table ftsSecret hfts fuel trace + rw [nativeChainTraceAfterRoot, mem_support_bind_iff] + refine ⟨some root, hroot, ?_⟩ + simpa only [hcore.1] using htrace + · simp [probOutput_eq_zero_of_not_mem_support hroot] + +theorem probEvent_exists_nativeRetainedFinalRootMatch_le_initializedCutHitSum + (targets roots : Finset Position) (hroots : ∀ target ∈ roots, IsLayerRoot target) + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) (fuel : Nat) : + Pr[fun trace => ∃ target ∈ roots, NativeFinalRootHistoryMatch parameter target trace | + nativeChainTraceAfterRoot targets parameter table ftsSecret fuel (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)] ≤ + ∑ target ∈ roots, ∑ ordinal ∈ Finset.range q, + Pr[fun b => b = false | initializedChargedRootCutObservation targets adversary parameter target + table ftsSecret fuel ordinal (fun pair => pair.2 = some (truncateHash pair.1))] := by + apply (probEvent_exists_finset_le_sum roots _ _).trans + apply Finset.sum_le_sum + intro target htarget + obtain ⟨lay, tree, rfl⟩ := hroots target htarget + exact probEvent_nativeRetainedFinalRootMatch_le_initializedCutHitSum targets adversary q hq parameter hparameter table ftsSecret hfts fuel lay tree + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeSupportedRootReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeSupportedRootReserve.lean new file mode 100644 index 00000000..5622979a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeSupportedRootReserve.lean @@ -0,0 +1,51 @@ +import SphincsSecurity.Proof.OtsProbeNativeSupportedRootProjection +import SphincsSecurity.Proof.OtsProbeSampledJointRootRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def sampledNativeFinalRootMatchRisk + (targets roots : Finset Position) (adversary : Adversary) (fuel : Nat) : ENNReal := + ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + ∑' table, Pr[= table | sampleOtsHashTable] * + Pr[fun trace => ∃ target ∈ roots, NativeFinalRootHistoryMatch parameter target trace | + nativeChainTraceAfterRoot targets parameter table ftsSecret fuel + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)] + +theorem sampledNativeFinalRootMatchRisk_le_chargedRootRisk + (targets roots : Finset Position) (hroots : ∀ target ∈ roots, IsLayerRoot target) + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (fuel : Nat) : + sampledNativeFinalRootMatchRisk targets roots adversary fuel ≤ + sampledInitializedChargedRootRisk targets roots adversary fuel q := by + unfold sampledNativeFinalRootMatchRisk sampledInitializedChargedRootRisk initializedChargedRootRisk + apply ENNReal.tsum_le_tsum + intro parameter + by_cases hparameter : parameter ∈ support sampleParameter + · apply mul_le_mul_right + apply ENNReal.tsum_le_tsum + intro ftsSecret + by_cases hfts : ftsSecret ∈ support sampleFtsSecrets + · apply mul_le_mul_right + apply ENNReal.tsum_le_tsum + intro table + apply mul_le_mul_right + exact probEvent_exists_nativeRetainedFinalRootMatch_le_initializedCutHitSum targets roots hroots adversary q hq + parameter hparameter table ftsSecret hfts fuel + · simp [probOutput_eq_zero_of_not_mem_support hfts] + · simp [probOutput_eq_zero_of_not_mem_support hparameter] + +theorem sampledNativeDirectRisk_add_finalRootMatch_le_refinedReserve + (targets roots : Finset Position) (hsubset : roots ⊆ targets) + (hroots : ∀ target ∈ roots, IsLayerRoot target) (hne : ∀ target ∈ roots, target ≠ layerRootPosition topLayer rootTree) + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) (fuel : Nat) : + sampledInitializedNativeDirectRisk targets adversary fuel q + sampledNativeFinalRootMatchRisk targets roots adversary fuel ≤ + sampledQueryCharge otsOpeningRefinedQueryReserve adversary * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + exact (add_le_add le_rfl (sampledNativeFinalRootMatchRisk_le_chargedRootRisk targets roots hroots adversary q hq fuel)).trans + (sampledInitializedNativeDirectRisk_add_chargedRootRisk_le_refinedReserve targets roots hsubset hroots hne adversary fuel q hqMax) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeTerminalExperiment.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeTerminalExperiment.lean new file mode 100644 index 00000000..b29fa926 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeTerminalExperiment.lean @@ -0,0 +1,53 @@ +import SphincsSecurity.Proof.OtsProbeNativeTerminalReserve + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot instFintypePosition +set_option backward.isDefEq.respectTransparency false + +noncomputable def nativeTerminalFailureAfterRoot + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : ProbComp Bool := do + let trace ← nativeChainTraceAfterRoot targets parameter table ftsSecret fuel + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩) + finishResolvedRunIsNone trace.1 + +theorem probEvent_nativeTerminalFailureAfterRoot_eq_risk + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun verdict => verdict = true | nativeTerminalFailureAfterRoot targets adversary parameter table ftsSecret fuel] = + ∑' trace, Pr[= trace | nativeChainTraceAfterRoot targets parameter table ftsSecret fuel + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)] * resolvedOutcomeFailureRisk trace.1 := by + rw [nativeTerminalFailureAfterRoot, probEvent_bind_eq_tsum] + apply tsum_congr + intro trace + have heq := probEvent_finished_eq_expected_outcomeRisk (pure trace.1) + simp only [pure_bind, tsum_probOutput_pure_mul] at heq + rw [heq] + +noncomputable def sampledNativeTerminalFailure (adversary : Adversary) (fuel : Nat) : ProbComp Bool := do + let parameter ← sampleParameter + let ftsSecret ← sampleFtsSecrets + let table ← sampleOtsHashTable + nativeTerminalFailureAfterRoot Finset.univ adversary parameter table ftsSecret fuel + +theorem probEvent_sampledNativeTerminalFailure_eq_risk (adversary : Adversary) (fuel : Nat) : + Pr[fun verdict => verdict = true | sampledNativeTerminalFailure adversary fuel] = sampledNativeTerminalRisk adversary fuel := by + simp only [sampledNativeTerminalFailure, probEvent_bind_eq_tsum, probEvent_nativeTerminalFailureAfterRoot_eq_risk, + sampledNativeTerminalRisk] + +theorem probEvent_sampledNativeTerminalFailure_add_rootMatch_le_refinedReserve + (roots : Finset Position) (hroots : ∀ target ∈ roots, IsLayerRoot target) + (hne : ∀ target ∈ roots, target ≠ layerRootPosition topLayer rootTree) + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + Pr[fun verdict => verdict = true | sampledNativeTerminalFailure adversary (q + 1)] + + sampledNativeFinalRootMatchRisk Finset.univ roots adversary (q + 1) ≤ + sampledQueryCharge otsOpeningRefinedQueryReserve adversary * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + rw [probEvent_sampledNativeTerminalFailure_eq_risk] + exact sampledNativeTerminalRisk_add_rootMatch_le_refinedReserve roots hroots hne adversary q hq hqMax + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeTerminalReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeTerminalReserve.lean new file mode 100644 index 00000000..44ba4bd1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeTerminalReserve.lean @@ -0,0 +1,72 @@ +import SphincsSecurity.Proof.OtsProbeNativeAfterRootRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot instFintypePosition +set_option backward.isDefEq.respectTransparency false + +noncomputable def sampledNativeTerminalRisk (adversary : Adversary) (fuel : Nat) : ENNReal := + ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + ∑' table, Pr[= table | sampleOtsHashTable] * + ∑' trace, Pr[= trace | nativeChainTraceAfterRoot Finset.univ parameter table ftsSecret fuel + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩)] * resolvedOutcomeFailureRisk trace.1 + +theorem sampledNativeTerminalRisk_le_missing_add_erasure + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + sampledNativeTerminalRisk adversary (q + 1) ≤ sampledNativeMissingAllowances Finset.univ adversary (q + 1) + + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + unfold sampledNativeTerminalRisk sampledNativeMissingAllowances + calc + _ ≤ ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + ∑' table, Pr[= table | sampleOtsHashTable] * + ((liveStartProbeAllowance (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + (ensuredInitialContext Finset.univ) (q + 1) table + + ∑ target : Position, privateLiveMissingProbeAllowance target + (nativeChronologicalRetainedComputation adversary parameter ftsSecret) (ensuredInitialContext Finset.univ) (q + 1) table) + + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹) := by + apply ENNReal.tsum_le_tsum + intro parameter + by_cases hparameter : parameter ∈ support sampleParameter + · apply mul_le_mul_right + apply ENNReal.tsum_le_tsum + intro ftsSecret + by_cases hfts : ftsSecret ∈ support sampleFtsSecrets + · apply mul_le_mul_right + apply ENNReal.tsum_le_tsum + intro table + apply mul_le_mul_right + exact expectedNativeTerminalRisk_afterRoot_le_missing_add_erasure adversary q hq hqMax + parameter hparameter table ftsSecret hfts + · simp [probOutput_eq_zero_of_not_mem_support hfts] + · simp [probOutput_eq_zero_of_not_mem_support hparameter] + _ = _ := by + simp only [mul_add, ENNReal.tsum_add, ENNReal.tsum_mul_right] + rw [tsum_probOutput_eq_one' (mx := sampleParameter) (by simp), + tsum_probOutput_eq_one' (mx := sampleFtsSecrets) (by simp), + tsum_probOutput_eq_one' (mx := sampleOtsHashTable) (by simp)] + simp only [one_mul] + +theorem sampledNativeTerminalRisk_add_rootMatch_le_refinedReserve + (roots : Finset Position) (hroots : ∀ target ∈ roots, IsLayerRoot target) + (hne : ∀ target ∈ roots, target ≠ layerRootPosition topLayer rootTree) + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + sampledNativeTerminalRisk adversary (q + 1) + sampledNativeFinalRootMatchRisk Finset.univ roots adversary (q + 1) ≤ + sampledQueryCharge otsOpeningRefinedQueryReserve adversary * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + have hreserve := sampledNativeMissingAllowances_add_rootMatch_le_refinedReserve Finset.univ roots + (fun target _ => Finset.mem_univ target) hroots hne adversary q hq hqMax (q + 1) + calc + _ ≤ (sampledNativeMissingAllowances Finset.univ adversary (q + 1) + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹) + + sampledNativeFinalRootMatchRisk Finset.univ roots adversary (q + 1) := + add_le_add (sampledNativeTerminalRisk_le_missing_add_erasure adversary q hq hqMax) le_rfl + _ = (sampledNativeMissingAllowances Finset.univ adversary (q + 1) + + sampledNativeFinalRootMatchRisk Finset.univ roots adversary (q + 1)) + + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by ac_rfl + _ ≤ _ := add_le_add hreserve le_rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeTraceCompletion.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeTraceCompletion.lean new file mode 100644 index 00000000..0ef2cd4d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeTraceCompletion.lean @@ -0,0 +1,187 @@ +import SphincsSecurity.Proof.OtsProbeSampledJointRootRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem nativeTrace_completion_facts + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) (history : List CanonicalQuerySelection) + (completion : Coordinate → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hresult : (some result, history) ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) + (hcompletion : DeferredCompletion table result.context completion) : + DeferredCompletion table context completion ∧ + ∀ selection ∈ history, selection.table = table ∧ selection.context.ValuesConsistent ∧ + DeferredCompletion table selection.context completion ∧ selection.context.state.revealed ⊆ result.context.state.revealed := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache history with + | pure value => + simp only [runNativeQueryTrace, OracleComp.construct_pure] at hresult + split_ifs at hresult <;> simp only [mem_support_pure_iff, Prod.mk.injEq, Option.some.injEq] at hresult + · obtain ⟨rfl, rfl⟩ := hresult + exact ⟨hcompletion, by simp⟩ + · simp at hresult + | query_bind input next ih => + rw [runNativeQueryTrace_query_bind] at hresult + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete, mem_support_bind_iff] at hresult + obtain ⟨middle, hmiddle, htail⟩ := hresult + cases middle with + | none => simp at htail + | some middle => + simp only [mem_support_bind_iff] at htail + obtain ⟨tail, htail, hreturn⟩ := htail + simp only [mem_support_pure_iff, Prod.mk.injEq] at hreturn + have htrace : (some result, tail.2) ∈ support + (runNativeQueryTrace parameter root ftsSecret (next middle.value.1) + middle.context middle.remaining middle.table middle.value.2) := by + simpa only [hreturn.1] using htail + have hcore := resolvedCore_of_mem_runResolvedFromTable + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) + context fuel table middle hconsistent hstarts hmiddle + have htailFacts := ih middle.value.1 middle.context middle.remaining middle.table middle.value.2 tail.2 + hcore.2.1 (by rw [hcore.1]; exact hcore.2.2) htrace (by rw [hcore.1]; exact hcompletion) + rw [hcore.1] at htailFacts + have hbefore := DeferredCompletion.of_mem_runResolvedFromTable _ context fuel table middle completion + hconsistent hstarts hmiddle htailFacts.1 + refine ⟨hbefore, ?_⟩ + intro selection hselection + rw [hreturn.2] at hselection + rcases List.mem_cons.mp hselection with rfl | hselection + · exact ⟨rfl, hconsistent, hbefore, + (revealed_subset_of_mem_runResolvedFromTable _ context fuel table middle hmiddle).trans + (revealed_subset_of_mem_runNativeQueryTrace parameter root ftsSecret _ _ _ _ _ result tail.2 htrace)⟩ + · exact htailFacts.2 selection hselection + · rw [if_neg hcomplete] at hresult + simp at hresult + +theorem DeferredCompletion.plannedCandidate_ne + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (HashOutput × SplitHashCache)) + (completion : Coordinate → HashOutput) (candidate : Probe) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcandidate : (purePlanProbingHashQuery parameter input context.state).candidate? = some candidate) + (hhidden : candidate.coordinate ∉ context.state.revealed) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table ((probingHashQuery parameter input).run cache))) + (hcompletion : DeferredCompletion table result.context completion) : + truncateHash (completion candidate.coordinate) ≠ candidate.candidate := by + rw [runResolved_probingHashQuery_eq_afterPlan] at hresult + unfold probingHashQueryAfterPlan executePlannedHashQuery at hresult + rw [hcandidate] at hresult + simp only [executeCandidate?] at hresult + rw [StateT.run_bind, runResolvedFromTable_bind] at hresult + unfold SphincsSecurity.Concrete.OtsProbeSimulation.probe at hresult + rw [StateT.run_liftM, LazyRevealProbe.probeQuery, + runResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + simp only [if_neg hhidden] at hresult + let probeContext : DeferredContext := + { context with state := context.state.addPending candidate.coordinate candidate.candidate } + have hbefore : DeferredCompletion table probeContext completion := + hcompletion.of_mem_runResolvedFromTable _ probeContext remaining table result completion + (hconsistent.addPending candidate.coordinate candidate.candidate) + (hstarts.addPending candidate.coordinate candidate.candidate) (by + simpa [probeContext, runResolvedFromTable] using hresult) + exact hbefore.2.2.1 candidate.coordinate candidate.candidate + (by simp [probeContext, LazyRevealProbe.State.addPending]) + +theorem nativeTrace_plannedCandidate_ne + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) (history : List CanonicalQuerySelection) + (completion : Coordinate → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hresult : (some result, history) ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) + (hcompletion : DeferredCompletion table result.context completion) : + ∀ selection ∈ history, ∀ input candidate, + selection.input = .inl (.inr input) → + (purePlanProbingHashQuery parameter input selection.context.state).candidate? = some candidate → + candidate.coordinate ∉ result.context.state.revealed → + truncateHash (completion candidate.coordinate) ≠ candidate.candidate := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache history with + | pure value => + simp only [runNativeQueryTrace, OracleComp.construct_pure] at hresult + split_ifs at hresult <;> simp only [mem_support_pure_iff, Prod.mk.injEq, Option.some.injEq] at hresult + · obtain ⟨rfl, rfl⟩ := hresult + simp + · simp at hresult + | query_bind query next ih => + rw [runNativeQueryTrace_query_bind] at hresult + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete, mem_support_bind_iff] at hresult + obtain ⟨middle, hmiddle, htail⟩ := hresult + cases middle with + | none => simp at htail + | some middle => + simp only [mem_support_bind_iff] at htail + obtain ⟨tail, htail, hreturn⟩ := htail + simp only [mem_support_pure_iff, Prod.mk.injEq] at hreturn + have htrace : (some result, tail.2) ∈ support + (runNativeQueryTrace parameter root ftsSecret (next middle.value.1) + middle.context middle.remaining middle.table middle.value.2) := by + simpa only [hreturn.1] using htail + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table middle hconsistent hstarts hmiddle + have hmiddleStarts : StartTableAgrees middle.context.state middle.table := by + rw [hcore.1]; exact hcore.2.2 + have hfinal : DeferredCompletion middle.table result.context completion := by + rw [hcore.1]; exact hcompletion + intro selection hselection input candidate hinput hcandidate hhidden + rw [hreturn.2] at hselection + rcases List.mem_cons.mp hselection with rfl | hselection + · have hbefore := (nativeTrace_completion_facts parameter root ftsSecret _ _ _ _ _ result tail.2 completion + hcore.2.1 hmiddleStarts htrace hfinal).1 + rw [hcore.1] at hbefore + have hrevealed := (revealed_subset_of_mem_runResolvedFromTable _ context fuel table middle hmiddle).trans + (revealed_subset_of_mem_runNativeQueryTrace parameter root ftsSecret _ _ _ _ _ result tail.2 htrace) + cases hinput + exact hbefore.plannedCandidate_ne parameter input context fuel table cache middle completion candidate + hconsistent hstarts hcandidate (fun h => hhidden (hrevealed h)) hmiddle + · exact ih middle.value.1 middle.context middle.remaining middle.table middle.value.2 tail.2 + hcore.2.1 hmiddleStarts htrace hfinal selection hselection input candidate hinput hcandidate hhidden + · rw [if_neg hcomplete] at hresult + simp at hresult + +theorem nativeTrace_matchingFinalRoot_charged + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) (history : List CanonicalQuerySelection) + (completion : Coordinate → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hresult : (some result, history) ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) + (hcompletion : DeferredCompletion table result.context completion) + (hsource : ¬UnknownSourceFinalRootMatch parameter (some result, history)) + (i : Fin history.length) (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (output : HashOutput) + (hinput : (history.get i).input = .inl (.inr input)) + (hcandidate : NativeRootCandidateAt parameter input (history.get i).context candidate) + (hcoordinate : candidate.coordinate = .position (layerRootPosition lay tree)) + (hvalue : result.context.positionValue (layerRootPosition lay tree) = some output) + (hmatch : candidate.candidate = truncateHash output) + (hhidden : .position (layerRootPosition lay tree) ∉ result.context.state.revealed) + (hmat : LayerRootsMaterialized (history.get i).context) : + ChargedNativeRootQuery parameter input (history.get i).context := by + have hfacts := (nativeTrace_completion_facts parameter root ftsSecret computation context fuel table cache result history completion + hconsistent hstarts hresult hcompletion).2 (history.get i) (List.get_mem _ _) + rcases hcandidate.direct_or_charged_or_unknown_encoding (layerRootPosition lay tree) + ⟨lay, tree, rfl⟩ hcoordinate (fun h => hhidden (hfacts.2.2.2 h)) hmat with hdirect | hcharged | ⟨hencoding, hunknown⟩ + · have hmiss := nativeTrace_plannedCandidate_ne parameter root ftsSecret computation context fuel table cache result history completion + hconsistent hstarts hresult hcompletion (history.get i) (List.get_mem _ _) input candidate hinput hdirect + (by rw [hcoordinate]; exact hhidden) + rw [hcoordinate, hcompletion.eq_positionValue _ output hvalue] at hmiss + exact False.elim (hmiss hmatch.symm) + · exact hcharged + · exact False.elim (hsource ⟨result, rfl, i, input, candidate, lay, tree, output, + hinput, hencoding, hcoordinate, hvalue, hmatch, hunknown⟩) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeTraceSafety.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeTraceSafety.lean new file mode 100644 index 00000000..a8752b9b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeTraceSafety.lean @@ -0,0 +1,225 @@ +import SphincsSecurity.Proof.OtsProbeNativeSupportedBudget + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +theorem pendingCoveredBy_of_mem_nativeChronologicalQuery + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) (prior : List Probe) + (result : ResolvedRunResult ((OracleWorld + SigningSpec).Range input × SplitHashCache)) + (hcovered : PendingCoveredBy prior context) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache))) : + PendingCoveredBy (prior ++ canonicalQueryCandidates parameter input context) result.context := by + have hprior : PendingCoveredBy (prior ++ canonicalQueryCandidates parameter input context) context := + hcovered.mono_candidates (List.sublist_append_left _ _) + cases input with + | inl query => + cases query with + | inl n => + exact pendingCoveredBy_of_mem_runResolvedFromTable _ _ context fuel table result hprior + (OracleComp.IsQueryBoundP.of_imp (isUncoveredProbe_imp_isProbe _) + (splitUniformImpl_probeFree n cache)) hresult + | inr input => + change some result ∈ support (runResolvedFromTable context fuel table + ((probingHashQuery parameter input).run cache)) at hresult + rw [runResolved_probingHashQuery_eq_afterPlan] at hresult + apply pendingCoveredBy_of_mem_runResolvedFromTable _ _ context fuel table result hprior _ hresult + apply probingHashQueryAfterPlan_probeBound + intro candidate hcandidate + apply List.mem_append_right + simp [canonicalQueryCandidates, hcandidate] + | inr message => + exact pendingCoveredBy_of_mem_runResolvedFromTable _ _ context fuel table result hprior + (OracleComp.IsQueryBoundP.of_imp (isUncoveredProbe_imp_isProbe _) + (maskedPublishedChronologicalSign_probeFree parameter root ftsSecret message cache)) hresult + +set_option maxRecDepth 100000 in +theorem pendingCoveredBy_of_mem_nativeQueryTrace + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (prior : List Probe) (hcovered : PendingCoveredBy prior context) + (result : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) + (hrun : result ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) : + (∀ ordinal entry, result.2[ordinal]? = some entry → + PendingCoveredBy (prior ++ canonicalTraceCandidates parameter (result.2.take ordinal)) entry.context) ∧ + (∀ terminal, result.1 = some terminal → + PendingCoveredBy (prior ++ canonicalTraceCandidates parameter result.2) terminal.context) := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache prior result with + | pure value => + simp only [runNativeQueryTrace, OracleComp.construct_pure] at hrun + split_ifs at hrun <;> simp only [mem_support_pure_iff] at hrun <;> subst result + · constructor + · intro ordinal entry hentry + simp at hentry + · intro terminal hterminal + simp only [Option.some.injEq] at hterminal + subst terminal + simpa [canonicalTraceCandidates] using hcovered + · simp + | query_bind input next ih => + rw [runNativeQueryTrace_query_bind] at hrun + split_ifs at hrun with hcomplete + · rw [mem_support_bind_iff] at hrun + obtain ⟨stepOption, hstep, hrun⟩ := hrun + cases stepOption with + | none => + simp only [pure_bind, mem_support_pure_iff] at hrun + subst result + constructor + · intro ordinal entry hentry + cases ordinal with + | zero => + simp only [List.getElem?_cons_zero, Option.some.injEq] at hentry + subst entry + simpa [canonicalTraceCandidates] using hcovered + | succ ordinal => simp at hentry + · simp + | some step => + rw [mem_support_bind_iff] at hrun + obtain ⟨tail, htail, hpure⟩ := hrun + simp only [mem_support_pure_iff] at hpure + subst result + have hstepCovered := pendingCoveredBy_of_mem_nativeChronologicalQuery parameter root ftsSecret + input context fuel table cache prior step hcovered hstep + have htailCovered := ih step.value.1 step.context step.remaining step.table step.value.2 + (prior ++ canonicalQueryCandidates parameter input context) hstepCovered tail htail + constructor + · intro ordinal entry hentry + cases ordinal with + | zero => + simp only [List.getElem?_cons_zero, Option.some.injEq] at hentry + subst entry + simpa [canonicalTraceCandidates] using hcovered + | succ ordinal => + simp only [List.getElem?_cons_succ] at hentry + simpa [canonicalTraceCandidates, List.append_assoc] using htailCovered.1 ordinal entry hentry + · intro terminal hterminal + simpa [canonicalTraceCandidates, List.append_assoc] using htailCovered.2 terminal hterminal + · simp only [mem_support_pure_iff] at hrun + subst result + simp + +set_option maxRecDepth 100000 in +theorem fuel_le_entry_add_hashCount_of_nativeQueryTrace + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) + (hrun : result ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) : + ∀ entry ∈ result.2, fuel ≤ entry.fuel + canonicalTraceHashCount result.2 := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache result with + | pure value => + simp only [runNativeQueryTrace, OracleComp.construct_pure] at hrun + split_ifs at hrun <;> simp only [mem_support_pure_iff] at hrun <;> subst result <;> simp + | query_bind input next ih => + rw [runNativeQueryTrace_query_bind] at hrun + split_ifs at hrun with hcomplete + · rw [mem_support_bind_iff] at hrun + obtain ⟨step, hstep, hrun⟩ := hrun + cases step with + | none => + simp only [pure_bind, mem_support_pure_iff] at hrun + subst result + intro entry hentry + simp only [List.mem_singleton] at hentry + subst entry + exact Nat.le_add_right _ _ + | some step => + rw [mem_support_bind_iff] at hrun + obtain ⟨tail, htail, hpure⟩ := hrun + simp only [mem_support_pure_iff] at hpure + subst result + intro entry hentry + rcases List.mem_cons.mp hentry with heq | htailEntry + · subst entry + exact Nat.le_add_right _ _ + · have htailFuel := ih step.value.1 step.context step.remaining step.table step.value.2 tail htail + entry htailEntry + have hstepFuel := fuel_bounds_of_mem_runResolvedFromTable _ context fuel (outerHashQueryCount input) table step + (maskedChronologicalExpandedAdversaryImpl_probeBound parameter root ftsSecret input cache) hstep + simp only [canonicalTraceHashCount, List.map_cons, List.sum_cons] + unfold canonicalTraceHashCount at htailFuel + omega + · simp only [mem_support_pure_iff] at hrun + subst result + simp + +theorem nativeChainTraceAfterRoot_entry_resources + (targets : Finset Position) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) + (trace : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) + (htrace : trace ∈ support (nativeChainTraceAfterRoot targets parameter table ftsSecret fuel continuation)) : + ∀ entry ∈ trace.2, fuel ≤ entry.fuel + canonicalTraceHashCount trace.2 ∧ + entry.context.state.pending.card ≤ canonicalTraceHashCount trace.2 := by + rw [nativeChainTraceAfterRoot, mem_support_bind_iff] at htrace + obtain ⟨root, hroot, htrace⟩ := htrace + cases root with + | none => + simp only [mem_support_pure_iff] at htrace + subst trace + simp + | some root => + have hrootFuel := fuel_bounds_of_mem_runResolvedFromTable _ (ensuredInitialContext targets) fuel 0 table root + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) hroot + have hrootCovered := pendingCoveredBy_of_mem_runResolvedFromTable [] _ (ensuredInitialContext targets) fuel table root + (by intro entry hentry; simp [ensuredInitialContext, LazyRevealProbe.State.empty] at hentry) + (OracleComp.IsQueryBoundP.of_imp (isUncoveredProbe_imp_isProbe []) + (maskedPublishedTreeRoot_probeFree emptySplitHashCache)) hroot + have hcovered := pendingCoveredBy_of_mem_nativeQueryTrace parameter root.value.1 ftsSecret (continuation root.value.1) + root.context root.remaining root.table root.value.2 [] hrootCovered trace htrace + intro entry hentry + have hfuel := fuel_le_entry_add_hashCount_of_nativeQueryTrace parameter root.value.1 ftsSecret (continuation root.value.1) + root.context root.remaining root.table root.value.2 trace htrace entry hentry + refine ⟨by omega, ?_⟩ + obtain ⟨ordinal, hordinal⟩ := List.mem_iff_getElem?.mp hentry + have hpending := (hcovered.1 ordinal entry hordinal).card_le + simp only [List.nil_append] at hpending + exact hpending.trans ((canonicalTraceCandidates_length_le_hashCount parameter _).trans + (canonicalTraceHashCount_take_le trace.2 ordinal)) + +theorem nativeRetainedTraceAfterRoot_entry_safe + (targets : Finset Position) (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (trace : Option (ResolvedRunResult (RetainedRestResult × SplitHashCache)) × List CanonicalQuerySelection) + (htrace : trace ∈ support (nativeChainTraceAfterRoot targets parameter table ftsSecret (q + 1) + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩))) : + ∀ entry ∈ trace.2, 0 < entry.fuel ∧ entry.context.state.pending.card + 1 < Fintype.card Digest := by + have hcount := nativeRetainedTraceAfterRoot_hashCount_le targets adversary q hq parameter hparameter table ftsSecret hfts (q + 1) trace htrace + have hresources := nativeChainTraceAfterRoot_entry_resources targets parameter table ftsSecret (q + 1) _ trace htrace + intro entry hentry + have hentry := hresources entry hentry + have hspace : 2 ^ 126 + 1 < Fintype.card Digest := by norm_num [digestBits] + constructor <;> omega + +theorem canonicalGuessCharge_of_nativeRetainedTraceAfterRoot + (targets : Finset Position) (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (trace : Option (ResolvedRunResult (RetainedRestResult × SplitHashCache)) × List CanonicalQuerySelection) + (htrace : trace ∈ support (nativeChainTraceAfterRoot targets parameter table ftsSecret (q + 1) + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩))) + (entry : CanonicalQuerySelection) (hentry : entry ∈ trace.2) : + canonicalGuessCharge parameter table entry.input entry.context entry.fuel entry.cache = + match entry.input with + | .inl (.inr input) => candidateFailureAllowance table entry.context + (purePlanProbingHashQuery parameter input entry.context.state).candidate? + | _ => 0 := by + have hsafe := nativeRetainedTraceAfterRoot_entry_safe targets adversary q hq hqMax parameter hparameter table ftsSecret hfts trace htrace entry hentry + simp only [canonicalGuessCharge, if_pos hsafe] + cases entry.input with + | inl input => cases input <;> rfl + | inr message => rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeTraceStoredRoot.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeTraceStoredRoot.lean new file mode 100644 index 00000000..4644910e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeTraceStoredRoot.lean @@ -0,0 +1,69 @@ +import SphincsSecurity.Proof.OtsProbeChargedRootObservation + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem nativeTrace_storedRoot_facts + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (output : HashOutput) (result : ResolvedRunResult (α × SplitHashCache)) (history : List CanonicalQuerySelection) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hknown : context.positionValue target = some output) + (htrace : (some result, history) ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) : + result.table = table ∧ result.context.ValuesConsistent ∧ StartTableAgrees result.context.state table ∧ + DeferredCompletable table result.context ∧ result.context.positionValue target = some output := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache history with + | pure value => + simp only [runNativeQueryTrace, OracleComp.construct_pure] at htrace + split_ifs at htrace with hcomplete <;> simp only [mem_support_pure_iff, Prod.mk.injEq, Option.some.injEq] at htrace + · obtain ⟨rfl, _⟩ := htrace + exact ⟨rfl, hconsistent, hstarts, hcomplete, hknown⟩ + · simp at htrace + | query_bind input next ih => + rw [runNativeQueryTrace_query_bind] at htrace + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete, mem_support_bind_iff] at htrace + obtain ⟨middle, hmiddle, htail⟩ := htrace + cases middle with + | none => simp at htail + | some middle => + simp only [mem_support_bind_iff] at htail + obtain ⟨tail, htail, hreturn⟩ := htail + simp only [mem_support_pure_iff, Prod.mk.injEq] at hreturn + have htrace : (some result, tail.2) ∈ support + (runNativeQueryTrace parameter root ftsSecret (next middle.value.1) + middle.context middle.remaining middle.table middle.value.2) := by + simpa only [hreturn.1] using htail + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table middle hconsistent hstarts hmiddle + have hvalue := positionValue_of_mem_runResolved _ context fuel table middle target output hknown hmiddle + have hfacts := ih middle.value.1 middle.context middle.remaining middle.table middle.value.2 tail.2 + hcore.2.1 (by rw [hcore.1]; exact hcore.2.2) hvalue htrace + simpa only [hcore.1] using hfacts + · rw [if_neg hcomplete] at htrace + simp at htrace + +theorem finishNativeRootHistoryTrace_charged_of_stored + (parameter : PublicParameter) (root : Digest) (target : Position) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) (OuterQueryCut α)) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (initialHistory : Finset Digest) (event : HashOutput × Option Digest → Prop) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (output : HashOutput) (hknown : context.positionValue target = some output) + (result : ResolvedRunResult (OuterQueryCut α × SplitHashCache)) (history : List CanonicalQuerySelection) + (htrace : (some result, history) ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) : + finishNativeRootHistoryTrace parameter target table (observeChargedRootCut parameter target event) initialHistory (some result, history) = + pure (decide (¬(.position target ∉ result.context.state.revealed ∧ + truncateHash output ∉ initialHistory ∪ nativeRootCandidateHistory parameter target history ∧ + event (output, chargedNativeRootCutCandidate parameter target result.context result.value.1)))) := by + have hfacts := nativeTrace_storedRoot_facts parameter root ftsSecret computation context fuel table cache target output result history + hconsistent hstarts hknown htrace + rw [finishNativeRootHistoryTrace, + privateResolutionObserve_chargedRootCut_of_known parameter target table event _ _ _ _ hfacts.2.1 hfacts.2.2.2.1 output hfacts.2.2.2.2] + exact observeChargedRootCut_of_known parameter target event result.context result.remaining result.value _ output hfacts.2.2.2.2 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeValueCompletion.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeValueCompletion.lean new file mode 100644 index 00000000..3ff26275 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeValueCompletion.lean @@ -0,0 +1,91 @@ +import SphincsSecurity.Proof.OtsProbeNativeValueReplacement + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem DeferredCompletable.of_replaceNativePosition + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hcomplete : DeferredCompletable table context) (target : Position) (output : HashOutput) + (hclean : ¬context.state.hitAt (.position target) output) : + DeferredCompletable table (replaceNativePosition target output context) := by + obtain ⟨completion, hcompletion⟩ := hcomplete + refine ⟨Function.update completion (.position target) output, ?_, ?_, ?_, ?_⟩ + · intro coordinate value hvalue + change Function.update context.state.values (.position target) + ((context.state.values (.position target)).map fun _ => output) coordinate = some value at hvalue + by_cases heq : coordinate = .position target + · subst coordinate + rw [Function.update_self] at hvalue + have hsame : output = value := by + cases hstate : context.state.values (.position target) <;> simp_all + simpa using hsame + · rw [Function.update_of_ne heq] at hvalue ⊢ + exact hcompletion.1 coordinate value hvalue + · intro position value hvalue + change Function.update context.values target (some output) position = some value at hvalue + by_cases heq : position = target + · subst position + simp only [Function.update_self, Option.some.injEq] at hvalue + simp [hvalue] + · rw [Function.update_of_ne heq] at hvalue + rw [Function.update_of_ne (by simpa using heq)] + exact hcompletion.2.1 position value hvalue + · intro coordinate candidate hpending + change (coordinate, candidate) ∈ context.state.pending at hpending + by_cases heq : coordinate = .position target + · subst coordinate + rw [Function.update_self] + intro hhit + apply hclean + change truncateHash output ∈ context.state.pendingAt (.position target) + rw [LazyRevealProbe.State.mem_pendingAt_iff, hhit] + exact hpending + · rw [Function.update_of_ne heq] + exact hcompletion.2.2.1 coordinate candidate hpending + · intro index + rw [Function.update_of_ne (by cases index; simp [OtsSecretIndex.coordinate])] + exact hcompletion.2.2.2 index + +theorem deferredCompletable_replaceNativePosition_iff + (target : Position) (before after : HashOutput) (context : DeferredContext) + (table : OtsSecretIndex → HashOutput) + (h : NativePositionReplaceable target before after context) : + DeferredCompletable table (replaceNativePosition target after context) ↔ + DeferredCompletable table context := by + constructor + · intro hcomplete + have hback := hcomplete.of_replaceNativePosition target before h.beforeMiss + simpa only [replaceNativePosition_inverse h] using hback + · intro hcomplete + exact hcomplete.of_replaceNativePosition target after h.afterMiss + +theorem NativePositionReplaceable.reverse + {target : Position} {before after : HashOutput} {context : DeferredContext} + (h : NativePositionReplaceable target before after context) : + NativePositionReplaceable target after before (replaceNativePosition target after context) := + ⟨replaceNativePosition_positionValue target after context, + h.consistent.of_replaceNativePosition target after, h.afterMiss, h.beforeMiss⟩ + +theorem DeferredContext.Valid.of_replaceNativePosition + {context : DeferredContext} (h : context.Valid) (target : Position) (output : HashOutput) + (hclean : ¬context.state.hitAt (.position target) output) : + (replaceNativePosition target output context).Valid := by + refine ⟨h.valuesConsistent.of_replaceNativePosition target output, ?_⟩ + intro coordinate value hvalue + change Function.update context.state.values (.position target) + ((context.state.values (.position target)).map fun _ => output) coordinate = some value at hvalue + change ¬context.state.hitAt coordinate value + by_cases heq : coordinate = .position target + · subst coordinate + rw [Function.update_self] at hvalue + have hsame : output = value := by + cases hstate : context.state.values (.position target) <;> simp_all + exact hsame ▸ hclean + · rw [Function.update_of_ne heq] at hvalue + exact h.2 coordinate value hvalue + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeValueMaterialization.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeValueMaterialization.lean new file mode 100644 index 00000000..4781ace5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeValueMaterialization.lean @@ -0,0 +1,132 @@ +import SphincsSecurity.Proof.OtsProbeNativeValueResolver + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem replaceNativePosition_materializePosition + (target position : Position) (after : HashOutput) (context : DeferredContext) + (result : DeferredResolution) : + materializeResolvedPosition (replaceNativePosition target after context) position + (replaceNativeResolution target after (some position) result) = + replaceNativePosition target after (materializeResolvedPosition context position result) := by + by_cases heq : position = target + · subst position + simp [materializeResolvedPosition, replaceNativeResolution, replaceNativePosition, + LazyRevealProbe.State.materialize, LazyRevealProbe.State.pendingAway] + · have hcoordinate : Coordinate.position position ≠ .position target := by simpa using heq + have hcomm := Function.update_comm (Ne.symm hcoordinate) + ((context.state.values (.position target)).map fun _ => after) (some result.output) + context.state.values + simp [materializeResolvedPosition, replaceNativeResolution, replaceNativePosition, heq, + Ne.symm hcoordinate, LazyRevealProbe.State.materialize, LazyRevealProbe.State.pendingAway, hcomm] + +theorem replaceNativePosition_materializeChainStart + (target : Position) (after : HashOutput) (context : DeferredContext) + (index : OtsSecretIndex) (result : DeferredResolution) : + materializeResolvedChainStart (replaceNativePosition target after context) index + (replaceNativeResolution target after none result) = + replaceNativePosition target after (materializeResolvedChainStart context index result) := by + have hcoordinate : index.coordinate ≠ Coordinate.position target := by + cases index + simp [OtsSecretIndex.coordinate] + have hcomm := Function.update_comm (Ne.symm hcoordinate) + ((context.state.values (.position target)).map fun _ => after) (some result.output) + context.state.values + simp [materializeResolvedChainStart, replaceNativeResolution, replaceNativePosition, + Ne.symm hcoordinate, LazyRevealProbe.State.materialize, LazyRevealProbe.State.pendingAway, hcomm] + +theorem NativePositionReplaceable.of_materialized_reveal + {target : Position} {before after : HashOutput} {context : DeferredContext} + (h : NativePositionReplaceable target before after context) + (position : Position) (table : OtsSecretIndex → HashOutput) (result : DeferredResolution) + (hresult : some result ∈ support (resolveDeferredReveal table position context)) : + NativePositionReplaceable target before after (materializeResolvedPosition context position result) := by + have hstate := resolveDeferredReveal_preserves_state_values table position context result hresult + have hvalue := resolveDeferredReveal_resolves table position context result hresult + have hknown := resolveDeferredReveal_preserves_native_value table position context result target before h.known hresult + refine ⟨?_, ?_, ?_, ?_⟩ + · rw [materializeResolvedPosition_positionValue_eq context position result hstate hvalue] + exact hknown + · exact h.consistent.materializeResolvedPosition_of table position result hresult + all_goals + intro hhit + simp only [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff, + materializeResolvedPosition, LazyRevealProbe.State.materialize, + LazyRevealProbe.State.pendingAway, Finset.mem_filter] at hhit + first + | apply h.beforeMiss + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff] using hhit.1 + | apply h.afterMiss + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff] using hhit.1 + +def replaceNativeRevealRunResult (target : Position) (after : HashOutput) (coordinate : Coordinate) + (result : ResolvedRunResult (HashOutput × SplitHashCache)) : + ResolvedRunResult (HashOutput × SplitHashCache) := + { context := replaceNativePosition target after result.context + remaining := result.remaining + value := (if coordinate = .position target then after else result.value.1, + replaceHiddenRootCache target after result.value.2) + table := result.table } + +theorem replaceHiddenRootCache_update_reveal + (target : Position) (after : HashOutput) (coordinate : Coordinate) (output : HashOutput) + (cache : SplitHashCache) : + Function.update (replaceHiddenRootCache target after cache) (.hidden coordinate) + (some (if coordinate = .position target then after else output)) = + replaceHiddenRootCache target after (Function.update cache (.hidden coordinate) (some output)) := by + by_cases heq : coordinate = .position target + · simp [heq, replaceHiddenRootCache] + · have hkey : SplitHashKey.hidden coordinate ≠ .hidden (.position target) := by simpa using heq + simp only [if_neg heq, replaceHiddenRootCache] + exact Function.update_comm (Ne.symm hkey) _ _ _ + +theorem evalDist_revealCoordinateOutput_replaceNativePosition + (target : Position) (before after : HashOutput) (context : DeferredContext) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (cache : SplitHashCache) (h : NativePositionReplaceable target before after context) : + evalDist (runResolvedFromTable (replaceNativePosition target after context) fuel table + ((revealCoordinateOutput coordinate).run (replaceHiddenRootCache target after cache))) = + evalDist (Option.map (replaceNativeRevealRunResult target after coordinate) <$> + runResolvedFromTable context fuel table ((revealCoordinateOutput coordinate).run cache)) := by + rw [runResolvedFromTable_revealCoordinateOutput, runResolvedFromTable_revealCoordinateOutput] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [resolveDeferredChainStart_replaceNativePosition, pure_bind] + cases hresolved : resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context with + | none => simp + | some resolved => + simp only [Option.map_some, map_pure] + change evalDist (pure (some (⟨ + materializeResolvedChainStart (replaceNativePosition target after context) + ⟨lay, tree, leafIdx, chainIdx⟩ (replaceNativeResolution target after none resolved), + fuel, (resolved.output, Function.update (replaceHiddenRootCache target after cache) + (.hidden (.chainStart lay tree leafIdx chainIdx)) (some resolved.output)), table⟩ : + ResolvedRunResult (HashOutput × SplitHashCache)))) = _ + rw [replaceNativePosition_materializeChainStart] + simp [replaceNativeRevealRunResult, materializeResolvedChainStart, + ← replaceHiddenRootCache_update_reveal, OtsSecretIndex.coordinate] + | position position => + rw [map_bind, evalDist_bind, evalDist_resolveDeferredReveal_replaceNativePosition target position before after table + context h, ← evalDist_bind, bind_map_left] + apply evalDist_bind_congr + intro resolvedOption _ + cases resolvedOption with + | none => simp + | some resolved => + simp only [Option.map_some, map_pure] + change evalDist (pure (some (⟨ + materializeResolvedPosition (replaceNativePosition target after context) position + (replaceNativeResolution target after (some position) resolved), + fuel, ((replaceNativeResolution target after (some position) resolved).output, + Function.update (replaceHiddenRootCache target after cache) (.hidden (.position position)) + (some (replaceNativeResolution target after (some position) resolved).output)), table⟩ : + ResolvedRunResult (HashOutput × SplitHashCache)))) = _ + rw [replaceNativePosition_materializePosition] + simp [replaceNativeRevealRunResult, materializeResolvedPosition, replaceNativeResolution, + ← replaceHiddenRootCache_update_reveal] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeValueObservation.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeValueObservation.lean new file mode 100644 index 00000000..93094e6f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeValueObservation.lean @@ -0,0 +1,67 @@ +import SphincsSecurity.Proof.OtsProbeNativeValueMaterialization + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem replaceNativePosition_positionValue_of_ne + (target position : Position) (output : HashOutput) (context : DeferredContext) + (hne : position ≠ target) : + (replaceNativePosition target output context).positionValue position = context.positionValue position := by + have hcoordinate : Coordinate.position position ≠ .position target := by simpa using hne + simp [replaceNativePosition, DeferredContext.positionValue, DeferredStructuralValues.install, + hne, hcoordinate] + +theorem replaceNativePosition_known_iff + (target position : Position) (before after : HashOutput) (context : DeferredContext) + (hknown : context.positionValue target = some before) : + (∃ output, (replaceNativePosition target after context).positionValue position = some output) ↔ + ∃ output, context.positionValue position = some output := by + by_cases heq : position = target + · subst position + exact ⟨fun _ => ⟨before, hknown⟩, + fun _ => ⟨after, replaceNativePosition_positionValue target after context⟩⟩ + · rw [replaceNativePosition_positionValue_of_ne target position after context heq] + +theorem knownHiddenEncodingRootQuery_replaceNativePosition_iff + (parameter : PublicParameter) (input : HashInput) (target : Position) + (before after : HashOutput) (context : DeferredContext) + (hknown : context.positionValue target = some before) : + KnownHiddenEncodingRootQuery parameter input (replaceNativePosition target after context) ↔ + KnownHiddenEncodingRootQuery parameter input context := by + constructor + · rintro ⟨candidate, position, output, hcandidate, hcoordinate, hvalue, hhidden⟩ + obtain ⟨original, horiginal⟩ := + (replaceNativePosition_known_iff target position before after context hknown).1 ⟨output, hvalue⟩ + exact ⟨candidate, position, original, hcandidate, hcoordinate, horiginal, hhidden⟩ + · rintro ⟨candidate, position, output, hcandidate, hcoordinate, hvalue, hhidden⟩ + obtain ⟨replaced, hreplaced⟩ := + (replaceNativePosition_known_iff target position before after context hknown).2 ⟨output, hvalue⟩ + exact ⟨candidate, position, replaced, hcandidate, hcoordinate, hreplaced, hhidden⟩ + +theorem knownEncodingRootOuterCharge_replaceNativePosition + (parameter : PublicParameter) (input : (OracleWorld + SigningSpec).Domain) + (target : Position) (before after : HashOutput) (context : DeferredContext) + (fuel : Nat) (leftCache rightCache : SplitHashCache) + (hknown : context.positionValue target = some before) : + knownEncodingRootOuterCharge parameter input (replaceNativePosition target after context) fuel rightCache = + knownEncodingRootOuterCharge parameter input context fuel leftCache := by + cases input with + | inl query => + cases query with + | inl n => rfl + | inr input => + simp only [knownEncodingRootOuterCharge, + knownHiddenEncodingRootQuery_replaceNativePosition_iff parameter input target before after context hknown] + | inr message => rfl + +theorem replaceNativePosition_idem + (target : Position) (first second : HashOutput) (context : DeferredContext) : + replaceNativePosition target second (replaceNativePosition target first context) = + replaceNativePosition target second context := by + simp [replaceNativePosition, Function.comp_def, DeferredStructuralValues.install] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeValueReplacement.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeValueReplacement.lean new file mode 100644 index 00000000..a15a5250 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeValueReplacement.lean @@ -0,0 +1,167 @@ +import SphincsSecurity.Proof.OtsProbeNativeChronologicalRootSigner + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def replaceNativePosition (target : Position) (output : HashOutput) + (context : DeferredContext) : DeferredContext := + { state := { context.state with + values := Function.update context.state.values (.position target) + ((context.state.values (.position target)).map fun _ => output) } + values := context.values.install target output } + +def replaceNativeResolution (target : Position) (output : HashOutput) (position : Option Position) + (result : DeferredResolution) : DeferredResolution := + ⟨replaceNativePosition target output result.toDeferredContext, + if position = some target then output else result.output⟩ + +structure NativePositionReplaceable (target : Position) (before after : HashOutput) + (context : DeferredContext) : Prop where + known : context.positionValue target = some before + consistent : context.ValuesConsistent + beforeMiss : ¬context.state.hitAt (.position target) before + afterMiss : ¬context.state.hitAt (.position target) after + +theorem NativePositionReplaceable.auxiliary + {target : Position} {before after : HashOutput} {context : DeferredContext} + (h : NativePositionReplaceable target before after context) : + context.values target = some before := by + cases hstate : context.state.values (.position target) with + | none => simpa [DeferredContext.positionValue, hstate] using h.known + | some output => + have heq : output = before := by simpa [DeferredContext.positionValue, hstate] using h.known + subst output + exact h.consistent target before hstate + +theorem NativePositionReplaceable.state_value + {target : Position} {before after : HashOutput} {context : DeferredContext} + (h : NativePositionReplaceable target before after context) : + context.state.values (.position target) = none ∨ + context.state.values (.position target) = some before := by + cases hstate : context.state.values (.position target) with + | none => exact Or.inl rfl + | some output => + right + have heq : output = before := by simpa [DeferredContext.positionValue, hstate] using h.known + exact congrArg some heq + +theorem NativePositionReplaceable.of_transition + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : NativePositionReplaceable target before after left) + (hknown : right.positionValue target = left.positionValue target) + (hpending : right.state.pending ⊆ left.state.pending) + (hconsistent : right.ValuesConsistent) : + NativePositionReplaceable target before after right := by + refine ⟨hknown.trans h.known, hconsistent, ?_, ?_⟩ + all_goals + intro hhit + simp only [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff] at hhit + have hmem := hpending hhit + first + | apply h.beforeMiss + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff] using hmem + | apply h.afterMiss + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff] using hmem + +theorem replaceNativePosition_of_private + (target : Position) (output : HashOutput) (context : DeferredContext) + (hstate : context.state.values (.position target) = none) : + replaceNativePosition target output context = replacePrivatePosition target output context := by + simp only [replaceNativePosition, replacePrivatePosition, hstate, Option.map_none] + rw [← hstate, Function.update_eq_self] + +theorem replaceNativePosition_positionValue + (target : Position) (output : HashOutput) (context : DeferredContext) : + (replaceNativePosition target output context).positionValue target = some output := by + cases hstate : context.state.values (.position target) <;> + simp [replaceNativePosition, DeferredContext.positionValue, DeferredStructuralValues.install, hstate] + +theorem replaceNativePosition_inverse + {target : Position} {before after : HashOutput} {context : DeferredContext} + (h : NativePositionReplaceable target before after context) : + replaceNativePosition target before (replaceNativePosition target after context) = context := by + have haux : context.values.install target before = context.values := by + unfold DeferredStructuralValues.install + rw [← h.auxiliary, Function.update_eq_self] + have hstate : Function.update context.state.values (.position target) + ((context.state.values (.position target)).map fun _ => before) = context.state.values := by + rcases h.state_value with hnone | hsome + · rw [hnone, Option.map_none, ← hnone, Function.update_eq_self] + · rw [hsome, Option.map_some, ← hsome, Function.update_eq_self] + simp only [replaceNativePosition, Function.update_self, Option.map_map, + Function.comp_def, Function.update_idem, DeferredStructuralValues.install] + rw [hstate, ← DeferredStructuralValues.install, haux] + +theorem DeferredContext.ValuesConsistent.of_replaceNativePosition + {context : DeferredContext} (h : context.ValuesConsistent) + (target : Position) (output : HashOutput) : + (replaceNativePosition target output context).ValuesConsistent := by + intro position value hvalue + by_cases heq : position = target + · subst position + simp only [replaceNativePosition, Function.update_self] at hvalue + have heq : output = value := by + cases hstate : context.state.values (.position target) <;> simp_all + simp [replaceNativePosition, DeferredStructuralValues.install, heq] + · have hcoordinate : Coordinate.position position ≠ .position target := by simpa using heq + change Function.update context.state.values (.position target) + ((context.state.values (.position target)).map fun _ => output) (.position position) = some value at hvalue + rw [Function.update_of_ne hcoordinate] at hvalue + simpa [replaceNativePosition, DeferredStructuralValues.install, heq] using h position value hvalue + +theorem nativeValueUpdate_hitAt (state : LazyRevealProbe.State Coordinate) + (values : Coordinate → Option HashOutput) (coordinate : Coordinate) (output : HashOutput) : + ({ state with values := values } : LazyRevealProbe.State Coordinate).hitAt coordinate output ↔ + state.hitAt coordinate output := Iff.rfl + +theorem nativeValueUpdate_clearPending (state : LazyRevealProbe.State Coordinate) + (values : Coordinate → Option HashOutput) (coordinate : Coordinate) : + ({ state with values := values } : LazyRevealProbe.State Coordinate).clearPending coordinate = + { state.clearPending coordinate with values := values } := rfl + +attribute [local simp] nativeValueUpdate_hitAt nativeValueUpdate_clearPending + +theorem resolveDeferredPositionValue_replaceNativePosition + (target position : Position) (before after : HashOutput) (context : DeferredContext) + (h : NativePositionReplaceable target before after context) : + resolveDeferredPositionValue position (replaceNativePosition target after context) = + Option.map (replaceNativeResolution target after (some position)) <$> + resolveDeferredPositionValue position context := by + by_cases heq : position = target + · subst position + rcases h.state_value with hstate | hstate <;> + simp [resolveDeferredPositionValue, replaceNativePosition, replaceNativeResolution, + DeferredStructuralValues.install, hstate, h.auxiliary, h.beforeMiss, h.afterMiss, + LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway] + · have hcoordinate : Coordinate.position position ≠ .position target := by simpa using heq + have hcomm (output : HashOutput) : + (context.values.install target after).install position output = + (context.values.install position output).install target after := by + exact Function.update_comm (Ne.symm heq) (some after) (some output) context.values + cases hstate : context.state.values (.position position) with + | some output => + by_cases hhit : context.state.hitAt (.position position) output <;> + simp [resolveDeferredPositionValue, replaceNativePosition, replaceNativeResolution, + hstate, hhit, heq, hcoordinate, hcomm, LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway] + | none => + cases hvalue : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output <;> + simp [resolveDeferredPositionValue, replaceNativePosition, replaceNativeResolution, + DeferredStructuralValues.install, hstate, hvalue, hhit, heq, hcoordinate, + LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway] + | none => + simp only [resolveDeferredPositionValue, replaceNativePosition, DeferredStructuralValues.install, + Function.update_of_ne hcoordinate, hstate, Function.update_of_ne heq, hvalue, map_bind] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] + · simpa [hhit, replaceNativeResolution, replaceNativePosition, heq, + DeferredStructuralValues.install, LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway] using hcomm output + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeValueResolver.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeValueResolver.lean new file mode 100644 index 00000000..c430a44d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNativeValueResolver.lean @@ -0,0 +1,181 @@ +import SphincsSecurity.Proof.OtsProbeNativeValueCompletion + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem resolveDeferredChainStart_replaceNativePosition + (target : Position) (after : HashOutput) (table : OtsSecretIndex → HashOutput) + (index : OtsSecretIndex) (context : DeferredContext) : + resolveDeferredChainStart table index (replaceNativePosition target after context) = + (resolveDeferredChainStart table index context).map (replaceNativeResolution target after none) := by + have hcoordinate : index.coordinate ≠ Coordinate.position target := by + cases index + simp [OtsSecretIndex.coordinate] + cases hstate : context.state.values index.coordinate <;> + simp [resolveDeferredChainStart, replaceNativePosition, hcoordinate, + nativeValueUpdate_hitAt, hstate] <;> + split_ifs <;> rfl + +theorem evalDist_resolveDeferredChainPrefix_replaceNativePosition + (target : Position) (before after : HashOutput) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps context, NativePositionReplaceable target before after context → + evalDist (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps + (replaceNativePosition target after context)) = + evalDist (Option.map (replaceNativeResolution target after + (chainPrefixResultPosition lay tree leafIdx chainIdx steps hsteps)) <$> + resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) + | 0, hsteps, context, h => by + simp only [resolveDeferredChainPrefix, chainPrefixResultPosition, map_pure, + resolveDeferredChainStart_replaceNativePosition] + | steps + 1, hsteps, context, h => by + simp only [resolveDeferredChainPrefix, chainPrefixResultPosition] + rw [evalDist_bind, + evalDist_resolveDeferredChainPrefix_replaceNativePosition target before after table lay tree leafIdx chainIdx + steps (by omega) context h, ← evalDist_bind, bind_map_left, map_bind] + apply evalDist_bind_congr + intro option hoption + cases option with + | none => simp + | some result => + have hnext := h.of_transition + ((resolveDeferredChainPrefix_preserves_positionValue table lay tree leafIdx chainIdx steps (by omega) + context result target before h.known hoption).trans h.known.symm) + (resolveDeferredChainPrefix_pending_subset table lay tree leafIdx chainIdx steps (by omega) + context result hoption) + (h.consistent.of_resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps (by omega) + result hoption) + exact congrArg evalDist (resolveDeferredPositionValue_replaceNativePosition target + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) before after result.toDeferredContext hnext) + +theorem evalDist_resolveDeferredChains_replaceNativePosition + (target : Position) (before after : HashOutput) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ∀ chains context, NativePositionReplaceable target before after context → + evalDist (resolveDeferredChains table lay tree leafIdx chains (replaceNativePosition target after context)) = + evalDist (Option.map (replaceNativePosition target after) <$> + resolveDeferredChains table lay tree leafIdx chains context) + | [], context, _ => by simp [resolveDeferredChains] + | chainIdx :: remaining, context, h => by + simp only [resolveDeferredChains] + rw [evalDist_bind, + evalDist_resolveDeferredChainPrefix_replaceNativePosition target before after table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context h, ← evalDist_bind, bind_map_left, map_bind] + apply evalDist_bind_congr + intro option hoption + cases option with + | none => simp + | some result => + have hnext := h.of_transition + ((resolveDeferredChainPrefix_preserves_positionValue table lay tree leafIdx chainIdx (chainLength - 1) (by omega) + context result target before h.known hoption).trans h.known.symm) + (resolveDeferredChainPrefix_pending_subset table lay tree leafIdx chainIdx (chainLength - 1) (by omega) + context result hoption) + (h.consistent.of_resolveDeferredChainPrefix table lay tree leafIdx chainIdx (chainLength - 1) (by omega) + result hoption) + exact evalDist_resolveDeferredChains_replaceNativePosition target before after table lay tree leafIdx + remaining result.toDeferredContext hnext + +theorem evalDist_resolveDeferredOtsLeaf_replaceNativePosition + (target : Position) (before after : HashOutput) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (context : DeferredContext) + (h : NativePositionReplaceable target before after context) : + evalDist (resolveDeferredOtsLeaf table lay tree leafIdx (replaceNativePosition target after context)) = + evalDist (Option.map (replaceNativeResolution target after (some (.leaf lay tree leafIdx))) <$> + resolveDeferredOtsLeaf table lay tree leafIdx context) := by + unfold resolveDeferredOtsLeaf + rw [evalDist_bind, evalDist_resolveDeferredChains_replaceNativePosition target before after table lay tree leafIdx + _ context h, ← evalDist_bind, bind_map_left, map_bind] + apply evalDist_bind_congr + intro option hoption + cases option with + | none => simp + | some result => + have hnext := h.of_transition + ((resolveDeferredChains_preserves_positionValue table lay tree leafIdx _ context result target before + h.known hoption).trans h.known.symm) + (resolveDeferredChains_pending_subset table lay tree leafIdx _ context result hoption) + (h.consistent.of_resolveDeferredChains table lay tree leafIdx _ result hoption) + exact congrArg evalDist (resolveDeferredPositionValue_replaceNativePosition target (.leaf lay tree leafIdx) + before after result hnext) + +theorem evalDist_resolveDeferredTreeNode_replaceNativePosition + (target : Position) (before after : HashOutput) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel context, NativePositionReplaceable target before after context → + evalDist (resolveDeferredTreeNode table lay tree level nodeIdx hlevel (replaceNativePosition target after context)) = + evalDist (Option.map (replaceNativeResolution target after (some (deferredTreePosition lay tree level nodeIdx hlevel))) <$> + resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) + | 0, nodeIdx, hlevel, context, h => + evalDist_resolveDeferredOtsLeaf_replaceNativePosition target before after table lay tree (leafOfNat nodeIdx) context h + | level + 1, nodeIdx, hlevel, context, h => by + simp only [resolveDeferredTreeNode, deferredTreePosition] + rw [evalDist_bind, + evalDist_resolveDeferredTreeNode_replaceNativePosition target before after table lay tree + level (2 * nodeIdx) (by omega) context h, ← evalDist_bind, bind_map_left, map_bind] + apply evalDist_bind_congr + intro leftOption hleft + cases leftOption with + | none => simp + | some left => + have hnext := h.of_transition + ((resolveDeferredTreeNode_preserves_positionValue table lay tree level (2 * nodeIdx) (by omega) + context left target before h.known hleft).trans h.known.symm) + (resolveDeferredTreeNode_pending_subset table lay tree level (2 * nodeIdx) (by omega) context left hleft) + (h.consistent.of_resolveDeferredTreeNode table lay tree level (2 * nodeIdx) (by omega) left hleft) + dsimp only [Option.map, replaceNativeResolution] + rw [evalDist_bind, + evalDist_resolveDeferredTreeNode_replaceNativePosition target before after table lay tree + level (2 * nodeIdx + 1) (by omega) left.toDeferredContext hnext, + ← evalDist_bind, bind_map_left, map_bind] + apply evalDist_bind_congr + intro rightOption hright + cases rightOption with + | none => simp + | some right => + have hfinal := hnext.of_transition + ((resolveDeferredTreeNode_preserves_positionValue table lay tree level (2 * nodeIdx + 1) (by omega) + left.toDeferredContext right target before hnext.known hright).trans hnext.known.symm) + (resolveDeferredTreeNode_pending_subset table lay tree level (2 * nodeIdx + 1) (by omega) + left.toDeferredContext right hright) + (hnext.consistent.of_resolveDeferredTreeNode table lay tree level (2 * nodeIdx + 1) (by omega) + right hright) + exact congrArg evalDist (resolveDeferredPositionValue_replaceNativePosition target + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) before after right.toDeferredContext hfinal) + +theorem evalDist_resolveDeferredPosition_replaceNativePosition + (target position : Position) (before after : HashOutput) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (h : NativePositionReplaceable target before after context) : + evalDist (resolveDeferredPosition table position (replaceNativePosition target after context)) = + evalDist (Option.map (replaceNativeResolution target after (some position)) <$> + resolveDeferredPosition table position context) := by + cases position with + | chain lay tree leafIdx chainIdx step => + simpa only [resolveDeferredPosition, chainPrefixResultPosition] using + evalDist_resolveDeferredChainPrefix_replaceNativePosition target before after table lay tree leafIdx chainIdx + (step.val + 1) (by have := step.isLt; omega) context h + | leaf lay tree leafIdx => + exact evalDist_resolveDeferredOtsLeaf_replaceNativePosition target before after table lay tree leafIdx context h + | node lay tree level nodeIdx => + simpa only [resolveDeferredPosition, deferredTreePosition, leafOfNat, Nat.mod_eq_of_lt nodeIdx.isLt, Fin.eta] using + evalDist_resolveDeferredTreeNode_replaceNativePosition target before after table lay tree + (level.val + 1) nodeIdx (by have := level.isLt; omega) context h + | ftsLeaf | ftsNode | ftsRoots => + exact congrArg evalDist (resolveDeferredPositionValue_replaceNativePosition target _ before after context h) + +theorem evalDist_resolveDeferredReveal_replaceNativePosition + (target position : Position) (before after : HashOutput) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (h : NativePositionReplaceable target before after context) : + evalDist (resolveDeferredReveal table position (replaceNativePosition target after context)) = + evalDist (Option.map (replaceNativeResolution target after (some position)) <$> + resolveDeferredReveal table position context) := by + unfold resolveDeferredReveal + split_ifs + · exact evalDist_resolveDeferredPosition_replaceNativePosition target position before after table context h + · exact congrArg evalDist (resolveDeferredPositionValue_replaceNativePosition target position before after context h) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNonRootExclusion.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNonRootExclusion.lean new file mode 100644 index 00000000..22eb1d11 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNonRootExclusion.lean @@ -0,0 +1,70 @@ +import SphincsSecurity.Proof.OtsProbeNonRootSelectionMass125 +import SphincsSecurity.Proof.OtsProbeStopped125 + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] granularAllCanonicalPrivateOrdinalSelection + granularAllCanonicalPrivateWitnessSnapshot observedMaterializedRetainedRunFromTable + +set_option maxRecDepth 100000 +set_option maxHeartbeats 2000000 + +theorem PrivateOrdinalSelectionFresh.not_goodForActualRoot_nonRoot + {selection : PrivateOrdinalSelection} + (hfresh : PrivateOrdinalSelectionFresh (some selection)) + (target : Position) (output : HashOutput) (ordinal : Nat) + (hnonRoot : ¬IsLayerRoot target) : + ¬selection.GoodForActualRoot target output ordinal := by + intro hgood + obtain ⟨parent, hparent⟩ : ∃ parent, Position.parentOf target = some parent := by + simpa [Probe.HasStructuralParent, hgood.1] using hfresh.1 + rcases hfresh.2 target parent hparent hgood.2.2.1 with hmissing | hroot + · have hvalue := hmissing.2 + rw [hgood.2.2.2.1] at hvalue + contradiction + · exact hnonRoot hroot + +theorem probEvent_granularAllCanonical_selectedNonRoot_eq_zero + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun source => SelectedPrivateSnapshotNonRootHitAt source ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel] = 0 := by + apply le_antisymm _ bot_le + calc + _ ≤ Pr[fun _ => False | + granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret fuel] := by + apply probEvent_le_of_relTriple + (relTriple_granularAllCanonicalSnapshot_privateOrdinalSelection_supported ordinal adversary + parameter table ftsSecret fuel) + intro source selection hrelation hhit + have hfresh := privateOrdinalSelectionFresh_of_mem_granularAllCanonical ordinal adversary + parameter table ftsSecret fuel selection hrelation.2 + obtain ⟨selected, target, output, _hordinal, hselected, hgood, hnonRoot⟩ := hhit + have heq : selection = some (privateOrdinalSelectionOfSnapshot selected) := + hrelation.1.symm.trans hselected + rw [heq] at hfresh + exact hfresh.not_goodForActualRoot_nonRoot target output ordinal hnonRoot hgood + _ = 0 := by simp + +theorem probEvent_observedMaterialized_successfulFirstNonRoot_eq_zero126 + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] = 0 := by + apply le_antisymm _ bot_le + exact (Range125.probEvent_observedMaterialized_successfulDoomed_firstNonRoot_le_selectedNonRoot + adversary parameter ftsSecret q ordinal table hbound hq).trans_eq + (probEvent_granularAllCanonical_selectedNonRoot_eq_zero ordinal adversary parameter table ftsSecret q) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeNonRootSelectionMass125.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNonRootSelectionMass125.lean new file mode 100644 index 00000000..6c7fbb4a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeNonRootSelectionMass125.lean @@ -0,0 +1,233 @@ +import SphincsSecurity.Proof.OtsProbeRootSelectionMass125 + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot + +/-- Every selected non-root candidate still has an unexposed output at selection time. -/ +def PrivateOrdinalSelectionFresh : Option PrivateOrdinalSelection → Prop + | none => True + | some selection => selection.candidate.HasStructuralParent ∧ + CandidatePositionsFreshExceptLayerRoots selection.context + +theorem privateOrdinalSelectionFresh_of_mem_finish + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (candidates : List Probe) (result : DirectWitnessResult α) + (output : Option PrivateOrdinalSelection) + (houtput : output ∈ support + (finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table observe) candidates result)) + (hobserve : ∀ resolved, + result = .done resolved → PublishedValues resolved.context.state → + ∀ selected, selected ∈ support + (observe (canonicalizeMaterializedValues table resolved.context) + resolved.remaining resolved.value candidates) → + PrivateOrdinalSelectionFresh selected) : + PrivateOrdinalSelectionFresh output := by + classical + cases result with + | stoppedFuel => + simp [finishDirectPrivateOrdinalSelection] at houtput + subst output + trivial + | stoppedOrdinary => + simp [finishDirectPrivateOrdinalSelection] at houtput + subst output + trivial + | stoppedPrivate witness => + simp [finishDirectPrivateOrdinalSelection] at houtput + subst output + trivial + | done resolved => + change output ∈ support (canonicalizeDirectPrivateOrdinalSelection table observe + resolved.context resolved.remaining resolved.value candidates) at houtput + unfold canonicalizeDirectPrivateOrdinalSelection at houtput + by_cases hprivate : PrivateStructuralHit + (canonicalizeMaterializedValues table resolved.context) + · simp [hprivate] at houtput + subst output + trivial + · simp only [hprivate, ↓reduceIte] at houtput + by_cases hpublished : PublishedValues resolved.context.state + · simp only [hpublished, ↓reduceIte] at houtput + by_cases hcomplete : DeferredCompletable table + (canonicalizeMaterializedValues table resolved.context) + · simp only [hcomplete, ↓reduceIte] at houtput + exact hobserve resolved rfl hpublished output houtput + · simp [hcomplete] at houtput + subst output + trivial + · simp [hpublished] at houtput + subst output + trivial + +set_option maxRecDepth 100000 in +theorem privateOrdinalSelectionFresh_of_mem_direct + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hparents : CandidatesHaveStructuralParent candidates) + (hfresh : CandidatePositionsFreshExceptLayerRoots context) + (hpublishedContext : PublishedValues context.state) + (output : Option PrivateOrdinalSelection) + (houtput : output ∈ support + (directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret computation + candidates context fuel table cache)) : + PrivateOrdinalSelectionFresh output := by + induction computation using OracleComp.inductionOn generalizing + candidates context fuel cache output with + | pure value => + rw [directDetailedBoundaryPrivateOrdinalSelection, OracleComp.construct_pure] at houtput + simp only [support_pure, Set.mem_singleton_iff] at houtput + subst output + unfold selectedPrivateOrdinal? + split + · exact ⟨candidateHasStructuralParent_get hparents _ _, hfresh⟩ + · trivial + | query_bind query next ih => + rw [directDetailedBoundaryPrivateOrdinalSelection, + OracleComp.construct_query_bind] at houtput + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte, support_pure, Set.mem_singleton_iff] at houtput + subst output + exact ⟨candidateHasStructuralParent_get hparents _ _, hfresh⟩ + · simp only [hselected, ↓reduceDIte] at houtput + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + apply privateOrdinalSelectionFresh_of_mem_finish table _ candidates result + output hfinish + intro resolved heq hpublished selected hselected + subst result + exact ih resolved.value.1 candidates + (canonicalizeMaterializedValues table resolved.context) resolved.remaining + resolved.value.2 hparents + (candidatePositionsFreshExceptLayerRoots_uniformStep n context fuel table cache + resolved hfresh hresult) + hpublished.to_canonicalizedMaterializedValues selected hselected + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + have hnextParents : CandidatesHaveStructuralParent nextCandidates := by + apply hparents.appendPlanned + (rootAwarePlannedCandidate? parameter input context.state) + intro candidate hcandidate + exact rootAwarePlannedCandidate?_hasStructuralParent hcandidate + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := + hnextSelected + simp only [hactual, ↓reduceDIte, support_pure, + Set.mem_singleton_iff] at houtput + subst output + exact ⟨candidateHasStructuralParent_get hnextParents _ _, hfresh⟩ + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := + hnextSelected + simp only [hactual, ↓reduceDIte] at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + apply privateOrdinalSelectionFresh_of_mem_finish table _ nextCandidates result + output hfinish + intro resolved heq hpublished selected hselected + subst result + exact ih resolved.value.1 nextCandidates + (canonicalizeMaterializedValues table resolved.context) resolved.remaining + resolved.value.2 hnextParents + (candidatePositionsFreshExceptLayerRoots_hashStep parameter input plan context + fuel table cache resolved hfresh hpublishedContext hresult) + hpublished.to_canonicalizedMaterializedValues selected hselected + | inr message => + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + apply privateOrdinalSelectionFresh_of_mem_finish table _ candidates result + output hfinish + intro resolved heq hpublished selected hselected + subst result + exact ih resolved.value.1 candidates + (canonicalizeMaterializedValues table resolved.context) resolved.remaining + resolved.value.2 hparents + (candidatePositionsFreshExceptLayerRoots_signStep parameter root ftsSecret message + context fuel table cache resolved hfresh hpublishedContext hresult) + hpublished.to_canonicalizedMaterializedValues selected hselected + +set_option maxRecDepth 100000 in +theorem privateOrdinalSelectionFresh_of_mem_granularAllCanonical + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (output : Option PrivateOrdinalSelection) + (houtput : output ∈ support + (granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret + fuel)) : + PrivateOrdinalSelectionFresh output := by + unfold granularAllCanonicalPrivateOrdinalSelection at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + apply privateOrdinalSelectionFresh_of_mem_finish table _ [] result output hfinish + intro resolved heq hpublished selected hselected + subst result + exact privateOrdinalSelectionFresh_of_mem_direct ordinal parameter resolved.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨resolved.value.1, parameter⟩) [] + (canonicalizeMaterializedValues table resolved.context) resolved.remaining table + resolved.value.2 candidatesHaveStructuralParent_nil + (candidatePositionsFreshExceptLayerRoots_of_done_maskedPublishedTreeRoot fuel table resolved + hresult) hpublished.to_canonicalizedMaterializedValues selected hselected + +def PrivateOrdinalSelectionNonRoot : Option PrivateOrdinalSelection → Prop + | none => False + | some selection => ¬selection.candidate.IsLayerRoot + +theorem probEvent_selectionNonRootFire_le_selected_mass + (selection : ProbComp (Option PrivateOrdinalSelection)) + (hfresh : ∀ output ∈ support selection, PrivateOrdinalSelectionFresh output) : + Pr[fun hit => hit = true | selection >>= privateOrdinalSelectionNonRootFire] ≤ + Pr[PrivateOrdinalSelectionNonRoot | selection] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + classical + rw [probEvent_bind_eq_tsum, probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro output + by_cases hsupport : output ∈ support selection + · have hvalid := hfresh output hsupport + cases output with + | none => simp [privateOrdinalSelectionNonRootFire, PrivateOrdinalSelectionNonRoot] + | some selected => + by_cases hroot : selected.candidate.IsLayerRoot + · simp [PrivateOrdinalSelectionNonRoot, privateOrdinalSelectionNonRootFire, + nonRootHiddenPrivateCandidateFire, hroot] + · simp only [PrivateOrdinalSelectionNonRoot, hroot, not_false_eq_true, if_true] + apply mul_le_mul' le_rfl + exact probEvent_nonRootHiddenPrivateCandidateFire_le selected.candidate selected.context + hvalid.1 hvalid.2 + · simp [probOutput_eq_zero_of_not_mem_support hsupport] + +set_option maxRecDepth 100000 in +theorem probEvent_granularNonRootRisk_le_selected_mass + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun hit => hit = true | + granularAllCanonicalPrivateOrdinalNonRootRisk ordinal adversary parameter table ftsSecret + fuel] ≤ + Pr[PrivateOrdinalSelectionNonRoot | + granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret + fuel] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + rw [← granularAllCanonicalPrivateOrdinalSelection_bind_nonRootFire] + apply probEvent_selectionNonRootFire_le_selected_mass + exact privateOrdinalSelectionFresh_of_mem_granularAllCanonical ordinal adversary parameter + table ftsSecret fuel + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeOrdinaryCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeOrdinaryCharge.lean new file mode 100644 index 00000000..f3830ca8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeOrdinaryCharge.lean @@ -0,0 +1,260 @@ +import SphincsSecurity.Proof.OtsProbePlannedCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +noncomputable def ordinaryChargeStep (input : (LazyRevealProbe.World Coordinate).Domain) + (next : (LazyRevealProbe.World Coordinate).Range input → DeferredContext → Nat → ℝ≥0∞) + (context : DeferredContext) (fuel : Nat) : ℝ≥0∞ := + match input with + | .uniform n => ∑' output, Pr[= output | (liftM (unifSpec.query n) : ProbComp _)] * next output context fuel + | .hashOutput => ∑' output, Pr[= output | LazyRevealProbe.sampleHashOutput] * next output context fuel + | .ensure coordinate => next () { context with state := context.state.ensure coordinate } fuel + | .probe coordinate candidate => + match fuel with + | 0 => 0 + | remaining + 1 => + if coordinate ∈ context.state.revealed then next () context remaining + else (LazyRevealProbe.pendingProbeCharge context.state coordinate candidate : ℝ≥0∞) + + next () { context with state := context.state.addPending coordinate candidate } remaining + | .peek coordinate => next (context.state.values coordinate) context fuel + | .publish coordinate => next () { context with state := context.state.publish coordinate } fuel + | .reveal coordinate => + match context.state.values coordinate with + | some output => next output context fuel + | none => + match coordinate with + | .chainStart _ _ _ _ => ∑' output, Pr[= output | LazyRevealProbe.sampleHashOutput] * + if context.state.hitAt coordinate output then 0 + else next output { context with state := context.state.materialize coordinate output } fuel + | .position position => + match context.values position with + | some output => + if context.state.hitAt coordinate output then 0 + else next output { context with state := context.state.materialize coordinate output } fuel + | none => ∑' output, Pr[= output | LazyRevealProbe.sampleHashOutput] * + if context.state.hitAt coordinate output then 0 + else next output + { state := context.state.materialize coordinate output + values := context.values.install position output } fuel + +noncomputable def ordinaryContinuationCharge {α : Type} + (post : DeferredContext → Nat → α → ℝ≥0∞) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : DeferredContext → Nat → ℝ≥0∞ := + OracleComp.construct (fun value context fuel => post context fuel value) + (fun input _ next => ordinaryChargeStep input next) computation + +theorem ordinaryContinuationCharge_query_bind {α : Type} + (post : DeferredContext → Nat → α → ℝ≥0∞) (input : (LazyRevealProbe.World Coordinate).Domain) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) : + ordinaryContinuationCharge post (OracleSpec.query input >>= next) context fuel = + ordinaryChargeStep input (fun output => ordinaryContinuationCharge post (next output)) context fuel := rfl + +theorem ordinaryContinuationCharge_bind {α β : Type} + (post : DeferredContext → Nat → β → ℝ≥0∞) + (left : OracleComp (LazyRevealProbe.World Coordinate) α) + (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) (context : DeferredContext) (fuel : Nat) : + ordinaryContinuationCharge post (left >>= next) context fuel = + ordinaryContinuationCharge (fun context fuel value => ordinaryContinuationCharge post (next value) context fuel) + left context fuel := by + induction left using OracleComp.inductionOn generalizing context fuel with + | pure value => simp only [pure_bind, ordinaryContinuationCharge, OracleComp.construct_pure] + | query_bind input continuation ih => + rw [bind_assoc, ordinaryContinuationCharge_query_bind, ordinaryContinuationCharge_query_bind] + apply congrArg (fun tail => ordinaryChargeStep input tail context fuel) + funext output nextContext remaining + exact ih output nextContext remaining + +theorem ordinaryContinuationCharge_zero_of_probeFree {α : Type} + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) (context : DeferredContext) (fuel : Nat) : + ordinaryContinuationCharge (fun _ _ _ => 0) computation context fuel = 0 := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => rfl + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [ordinaryContinuationCharge_query_bind, ordinaryChargeStep.eq_def] + cases input with + | uniform n => + apply ENNReal.tsum_eq_zero.mpr + intro output + dsimp only + rw [ih output (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) context fuel, mul_zero] + | hashOutput => + apply ENNReal.tsum_eq_zero.mpr + intro output + dsimp only + rw [ih output (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) context fuel, mul_zero] + | ensure coordinate => + exact ih () (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) + { context with state := context.state.ensure coordinate } fuel + | peek coordinate => + exact ih _ (by simpa [LazyRevealProbe.IsProbe] using hbound.2 _ ) context fuel + | publish coordinate => + exact ih () (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) + { context with state := context.state.publish coordinate } fuel + | probe coordinate candidate => simpa [LazyRevealProbe.IsProbe] using hbound.1 + | reveal coordinate => + dsimp only + cases hvalue : context.state.values coordinate with + | some output => exact ih output (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) context fuel + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + apply ENNReal.tsum_eq_zero.mpr + intro output + dsimp only + rw [ih output (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output)] + simp only [ite_self, mul_zero] + | position position => + dsimp only + cases hprivate : context.values position with + | some output => + dsimp only + rw [ih output (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output)] + exact ite_self _ + | none => + apply ENNReal.tsum_eq_zero.mpr + intro output + rw [ih output (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output)] + simp only [ite_self, mul_zero] + +theorem ordinaryContinuationCharge_zero_bind_of_tail_probeFree {α β : Type} + (left : OracleComp (LazyRevealProbe.World Coordinate) α) + (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) + (hnext : ∀ value, (next value).IsQueryBoundP LazyRevealProbe.IsProbe 0) + (context : DeferredContext) (fuel : Nat) : + ordinaryContinuationCharge (fun _ _ _ => 0) (left >>= next) context fuel = + ordinaryContinuationCharge (fun _ _ _ => 0) left context fuel := by + rw [ordinaryContinuationCharge_bind] + have hpost : (fun context fuel value => ordinaryContinuationCharge (fun _ _ _ => 0) (next value) context fuel) = + (fun _ _ _ => 0) := by + funext context fuel value + exact ordinaryContinuationCharge_zero_of_probeFree (next value) (hnext value) context fuel + rw [hpost] + +theorem executeCandidate_ordinaryCharge_le (candidate : Option Probe) (cache : SplitHashCache) + (context : DeferredContext) (fuel : Nat) : + ordinaryContinuationCharge (fun _ _ _ => 0) ((executeCandidate? candidate).run cache) context fuel ≤ + unmaterializedCandidateCharge context.state candidate := by + cases candidate with + | none => simp [executeCandidate?, ordinaryContinuationCharge, unmaterializedCandidateCharge] + | some candidate => + change ordinaryContinuationCharge (fun _ _ _ => 0) + (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate >>= fun _ => pure ((), cache)) context fuel ≤ _ + rw [LazyRevealProbe.probeQuery, ordinaryContinuationCharge_query_bind, ordinaryChargeStep.eq_def] + cases fuel with + | zero => exact bot_le + | succ remaining => + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte, unmaterializedCandidateCharge, ordinaryContinuationCharge, + OracleComp.construct_pure, Nat.cast_zero, le_refl] + · simp only [hrevealed, ↓reduceIte, unmaterializedCandidateCharge, ordinaryContinuationCharge, + OracleComp.construct_pure, add_zero, le_refl] + +theorem probingHashQueryAfterRootAwarePublicPlan_ordinaryCharge_add_materialized_le_one + (parameter : PublicParameter) (input : HashInput) (publicState : LazyRevealProbe.State Coordinate) + (plan : PlannedHashQuery) (cache : SplitHashCache) (context : DeferredContext) (fuel : Nat) : + ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) context fuel + + (materializedCandidateCharge context.state (rootAwareCandidateForPlan? parameter input plan) : ℝ≥0∞) ≤ 1 := by + unfold probingHashQueryAfterRootAwarePublicPlan + rw [StateT.run_bind, ordinaryContinuationCharge_zero_bind_of_tail_probeFree _ + (fun result : Unit × SplitHashCache => (probingHashQueryPublicAction parameter input publicState plan.action).run result.2) + (fun result => probingHashQueryPublicAction_probeFree parameter input publicState plan.action result.2)] + apply (add_le_add (executeCandidate_ordinaryCharge_le _ cache context fuel) le_rfl).trans + rw [← Nat.cast_add, ← Nat.cast_one] + exact Nat.cast_le.mpr (candidateCharge_sum_le_one context.state _) + +theorem probEvent_safeOrdinary_le_continuationCharge {α : Type} + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observe : (OtsSecretIndex → HashOutput) → DeferredContext → Nat → α → ProbComp Bool) + (post : DeferredContext → Nat → α → ℝ≥0∞) + (hpost : ∀ context fuel value, + Pr[fun hit : Bool => hit = true | do + let base ← sampleOtsHashTable + observe (completedStartTable context.state base) context fuel value] ≤ + (post context fuel value + (context.state.unmaterializedPending.card : ℝ≥0∞)) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) + (context : DeferredContext) (fuel : Nat) : + Pr[fun hit : Bool => hit = true | + runDirectDetailedSafeOrdinaryWithCompletionTable observe context fuel computation] ≤ + (ordinaryContinuationCharge post computation context fuel + + (context.state.unmaterializedPending.card : ℝ≥0∞)) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + rw [runDirectDetailedSafeOrdinaryWithCompletionTable_pure] + exact hpost context fuel value + | query_bind input next ih => + rw [ordinaryContinuationCharge_query_bind, ordinaryChargeStep.eq_def] + cases input with + | uniform n => + rw [runDirectDetailedSafeOrdinaryWithCompletionTable_uniform_query_bind] + exact AdaptiveRevealProbe.probEvent_bind_le_expectedCharge _ _ _ _ _ fun output => ih output context fuel + | hashOutput => + rw [runDirectDetailedSafeOrdinaryWithCompletionTable_hashOutput_query_bind] + exact AdaptiveRevealProbe.probEvent_bind_le_expectedCharge _ _ _ _ _ fun output => ih output context fuel + | ensure coordinate => + rw [runDirectDetailedSafeOrdinaryWithCompletionTable_ensure_query_bind] + exact ih () { context with state := context.state.ensure coordinate } fuel + | peek coordinate => + rw [runDirectDetailedSafeOrdinaryWithCompletionTable_peek_query_bind] + exact ih (context.state.values coordinate) context fuel + | publish coordinate => + rw [runDirectDetailedSafeOrdinaryWithCompletionTable_publish_query_bind] + exact ih () { context with state := context.state.publish coordinate } fuel + | probe coordinate candidate => + rw [runDirectDetailedSafeOrdinaryWithCompletionTable_probe_query_bind] + cases fuel with + | zero => simp + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () context remaining + · simp only [hrevealed, ↓reduceIte] + apply (ih () { context with state := context.state.addPending coordinate candidate } remaining).trans_eq + rw [context.state.unmaterializedPending_card_addPending_eq_charge, Nat.cast_add] + change (ordinaryContinuationCharge post (next ()) + { context with state := context.state.addPending coordinate candidate } remaining + + ((context.state.unmaterializedPending.card : ℝ≥0∞) + + LazyRevealProbe.pendingProbeCharge context.state coordinate candidate)) * _ = + ((LazyRevealProbe.pendingProbeCharge context.state coordinate candidate : ℝ≥0∞) + + ordinaryContinuationCharge post (next ()) + { context with state := context.state.addPending coordinate candidate } remaining + + context.state.unmaterializedPending.card) * _ + congr 1 + ac_rfl + | reveal coordinate => + rw [runDirectDetailedSafeOrdinaryWithCompletionTable_reveal_query_bind] + dsimp only + cases hvalue : context.state.values coordinate with + | some output => exact ih output context fuel + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact LazyRevealProbe.materialize_probability_le_charge context.state _ hvalue + (fun output state => runDirectDetailedSafeOrdinaryWithCompletionTable observe + { context with state := state } fuel (next output)) _ + (fun output => ih output { context with state := context.state.materialize _ output } fuel) + | position position => + dsimp only + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp only [hhit, ↓reduceIte, probEvent_pure, Bool.false_eq_true] + exact bot_le + · simp only [hhit, ↓reduceIte] + apply (ih output { context with state := context.state.materialize (.position position) output } fuel).trans + apply mul_le_mul' (add_le_add le_rfl _) le_rfl + rw [context.state.unmaterializedPending_materialize] + exact Nat.cast_le.mpr (context.state.unmaterializedPending_clearPending_card_le _) + | none => + exact LazyRevealProbe.materialize_probability_le_charge context.state _ hvalue + (fun output state => runDirectDetailedSafeOrdinaryWithCompletionTable observe + { state := state, values := context.values.install position output } fuel (next output)) _ + (fun output => ih output + { state := context.state.materialize _ output, values := context.values.install position output } fuel) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeOrigin.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeOrigin.lean new file mode 100644 index 00000000..cc03cbc1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeOrigin.lean @@ -0,0 +1,7284 @@ +import SphincsSecurity.Proof.OtsProbeRetained + +/-! +# Origins of published one-time chain values + +Every chain value published by the masked signer belongs to one successful signing-log entry. This +module packages that semantic endpoint and proves the incompatibilities needed by the exact forged +opening events. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +def IsChainCoordinate : Coordinate → Prop + | .chainStart _ _ _ _ => True + | .position (.chain _ _ _ _ _) => True + | _ => False + +def ChainForwardClosed (allowed : Coordinate → Prop) : Prop := + ∀ candidate : Probe, allowed candidate.coordinate → + IsChainCoordinate candidate.outputCoordinate → allowed candidate.outputCoordinate + +def ordinaryQueryCache (cache : SplitHashCache) : QueryCache HashSpec := + fun input => cache (.ordinary input) + +def projectRawOrdinary : LazyRevealProbe.RawResult Coordinate (alpha × SplitHashCache) → + Option (alpha × QueryCache HashSpec) + | .stopped _ => none + | .done _ _ (value, cache) => some (value, ordinaryQueryCache cache) + +theorem ordinaryQueryCache_update (cache : SplitHashCache) (input : HashInput) + (output : HashOutput) : + ordinaryQueryCache (Function.update cache (.ordinary input) (some output)) = + (ordinaryQueryCache cache).cacheQuery input output := by + funext other + by_cases heq : other = input + · subst other + simp [ordinaryQueryCache, QueryCache.cacheQuery, Function.update] + · simp [ordinaryQueryCache, QueryCache.cacheQuery, Function.update, heq] + +theorem ordinaryQueryCache_update_hidden (cache : SplitHashCache) + (coordinate : Coordinate) (output : HashOutput) : + ordinaryQueryCache (Function.update cache (.hidden coordinate) (some output)) = + ordinaryQueryCache cache := by + funext input + simp [ordinaryQueryCache, Function.update] + +theorem projectRawOrdinary_splitHashQuery + (input : HashInput) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (fuel : Nat) : + projectRawOrdinary <$> + LazyRevealProbe.runRaw state fuel + ((splitHashQuery (.ordinary input)).run cache) = + some <$> + (randomOracle (spec := HashSpec) input).run (ordinaryQueryCache cache) := by + rw [splitHashQuery_run_eq] + cases hlookup : cache (.ordinary input) with + | some output => + simp only + have hordinary : ordinaryQueryCache cache input = some output := hlookup + rw [QueryImpl.withCaching_run_some uniformSampleImpl hordinary] + simp [LazyRevealProbe.runRaw, projectRawOrdinary] + | none => + simp only + have hordinary : ordinaryQueryCache cache input = none := hlookup + rw [QueryImpl.withCaching_run_none uniformSampleImpl hordinary] + rw [LazyRevealProbe.hashOutputQuery, + LazyRevealProbe.runRaw_hashOutput_query_bind] + simp only [map_bind, Functor.map_map] + change (LazyRevealProbe.sampleHashOutput >>= fun output => + projectRawOrdinary <$> + LazyRevealProbe.runRaw state fuel + (pure (output, + Function.update cache (.ordinary input) (some output)))) = + (fun output => some + (output, (ordinaryQueryCache cache).cacheQuery input output)) <$> + LazyRevealProbe.sampleHashOutput + rw [map_eq_bind_pure_comp] + apply bind_congr + intro output + simp [LazyRevealProbe.runRaw, projectRawOrdinary, ordinaryQueryCache_update] + +set_option maxRecDepth 10000 in +theorem projectRawOrdinary_simulateQ_ordinaryHashImpl + (computation : OracleComp HashSpec alpha) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) (fuel : Nat) : + projectRawOrdinary <$> + LazyRevealProbe.runRaw state fuel + ((simulateQ ordinaryHashImpl computation).run cache) = + some <$> + (simulateQ (randomOracle : QueryImpl HashSpec _) computation).run + (ordinaryQueryCache cache) := by + induction computation using OracleComp.inductionOn generalizing state cache fuel with + | pure value => + simp [LazyRevealProbe.runRaw, projectRawOrdinary] + | query_bind input next ih => + simp only [simulateQ_bind, simulateQ_query, OracleQuery.cont_query, id_map, + OracleQuery.input_query, StateT.run_bind, LazyRevealProbe.runRaw_bind] + rw [show ordinaryHashImpl input = splitHashQuery (.ordinary input) by rfl] + rw [splitHashQuery_run_eq] + cases hlookup : cache (.ordinary input) with + | some output => + simp only + have hordinary : ordinaryQueryCache cache input = some output := hlookup + rw [QueryImpl.withCaching_run_some uniformSampleImpl hordinary] + simp only [LazyRevealProbe.runRaw, pure_bind] + exact ih output state cache fuel + | none => + simp only + have hordinary : ordinaryQueryCache cache input = none := hlookup + rw [QueryImpl.withCaching_run_none uniformSampleImpl hordinary] + rw [LazyRevealProbe.hashOutputQuery, + LazyRevealProbe.runRaw_hashOutput_query_bind] + simp only [map_bind, bind_assoc] + change (LazyRevealProbe.sampleHashOutput >>= fun output => + projectRawOrdinary <$> + LazyRevealProbe.runRaw state fuel + ((simulateQ ordinaryHashImpl (next output)).run + (Function.update cache (.ordinary input) (some output)))) = + (LazyRevealProbe.sampleHashOutput >>= fun output => + some <$> + (simulateQ (randomOracle : QueryImpl HashSpec _) (next output)).run + ((ordinaryQueryCache cache).cacheQuery input output)) + apply bind_congr + intro output + rw [← ordinaryQueryCache_update] + exact ih output state (Function.update cache (.ordinary input) (some output)) fuel + +def LazyRevealProbe.ValuesLE (initial final : LazyRevealProbe.State Coordinate) : Prop := + ∀ coordinate output, initial.values coordinate = some output → + final.values coordinate = some output + +theorem LazyRevealProbe.ValuesLE.refl (state : LazyRevealProbe.State Coordinate) : + LazyRevealProbe.ValuesLE state state := by + intro coordinate output hvalue + exact hvalue + +theorem LazyRevealProbe.ValuesLE.trans + {first second third : LazyRevealProbe.State Coordinate} + (hleft : LazyRevealProbe.ValuesLE first second) + (hright : LazyRevealProbe.ValuesLE second third) : + LazyRevealProbe.ValuesLE first third := by + intro coordinate output hvalue + exact hright coordinate output (hleft coordinate output hvalue) + +def LazyRevealProbe.EnsuredLE (initial final : LazyRevealProbe.State Coordinate) : Prop := + initial.ensured ⊆ final.ensured + +theorem LazyRevealProbe.EnsuredLE.refl (state : LazyRevealProbe.State Coordinate) : + LazyRevealProbe.EnsuredLE state state := by + exact fun _ hcoordinate => hcoordinate + +theorem LazyRevealProbe.EnsuredLE.trans + {first second third : LazyRevealProbe.State Coordinate} + (hleft : LazyRevealProbe.EnsuredLE first second) + (hright : LazyRevealProbe.EnsuredLE second third) : + LazyRevealProbe.EnsuredLE first third := by + exact fun coordinate hcoordinate => hright (hleft hcoordinate) + +theorem LazyRevealProbe.ensuredLE_ensure (state : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) : LazyRevealProbe.EnsuredLE state (state.ensure coordinate) := by + intro other hother + simp [LazyRevealProbe.State.ensure, hother] + +theorem LazyRevealProbe.ensuredLE_addPending (state : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) (candidate : Digest) : + LazyRevealProbe.EnsuredLE state (state.addPending coordinate candidate) := by + exact fun _ hcoordinate => hcoordinate + +theorem LazyRevealProbe.ensuredLE_publish (state : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) : LazyRevealProbe.EnsuredLE state (state.publish coordinate) := by + exact fun _ hcoordinate => hcoordinate + +theorem LazyRevealProbe.ensuredLE_materialize (state : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) (sampled : HashOutput) : + LazyRevealProbe.EnsuredLE state (state.materialize coordinate sampled) := by + intro other hother + simp [LazyRevealProbe.State.materialize, hother] + +theorem LazyRevealProbe.valuesLE_ensure (state : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) : LazyRevealProbe.ValuesLE state (state.ensure coordinate) := by + intro other output hvalue + exact hvalue + +theorem LazyRevealProbe.valuesLE_addPending (state : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) (candidate : Digest) : + LazyRevealProbe.ValuesLE state (state.addPending coordinate candidate) := by + intro other output hvalue + exact hvalue + +theorem LazyRevealProbe.valuesLE_publish (state : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) : LazyRevealProbe.ValuesLE state (state.publish coordinate) := by + intro other output hvalue + exact hvalue + +theorem LazyRevealProbe.valuesLE_materialize_of_none + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (sampled : HashOutput) (hnone : state.values coordinate = none) : + LazyRevealProbe.ValuesLE state (state.materialize coordinate sampled) := by + intro other output hvalue + by_cases heq : other = coordinate + · subst other + rw [hnone] at hvalue + simp at hvalue + · simpa [LazyRevealProbe.State.materialize, Function.update, heq] using hvalue + +theorem LazyRevealProbe.valuesLE_of_mem_runRaw_done + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (state finalState : LazyRevealProbe.State Coordinate) (fuel remaining : Nat) + (value : alpha) + (hresult : LazyRevealProbe.RawResult.done finalState remaining value ∈ + support (LazyRevealProbe.runRaw state fuel computation)) : + LazyRevealProbe.ValuesLE state finalState := by + induction computation using OracleComp.inductionOn generalizing + state finalState fuel remaining value with + | pure result => + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl⟩ + exact fun _ _ hvalue => hvalue + | query_bind input next ih => + cases input with + | uniform n => + rw [LazyRevealProbe.runRaw_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _, htail⟩ := hresult + exact ih output state finalState fuel remaining value htail + | hashOutput => + rw [LazyRevealProbe.runRaw_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _, htail⟩ := hresult + exact ih output state finalState fuel remaining value htail + | ensure coordinate => + rw [LazyRevealProbe.runRaw_ensure_query_bind] at hresult + exact (LazyRevealProbe.valuesLE_ensure state coordinate).trans + (ih () (state.ensure coordinate) finalState fuel remaining value hresult) + | probe coordinate candidate => + rw [LazyRevealProbe.runRaw_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remainingFuel => + simp only at hresult + by_cases hrevealed : coordinate ∈ state.revealed + · rw [if_pos hrevealed] at hresult + exact ih () state finalState remainingFuel remaining value hresult + · rw [if_neg hrevealed] at hresult + exact (LazyRevealProbe.valuesLE_addPending state coordinate candidate).trans + (ih () (state.addPending coordinate candidate) finalState remainingFuel + remaining value hresult) + | peek coordinate => + rw [LazyRevealProbe.runRaw_peek_query_bind] at hresult + exact ih (state.values coordinate) state finalState fuel remaining value hresult + | publish coordinate => + rw [LazyRevealProbe.runRaw_publish_query_bind] at hresult + exact (LazyRevealProbe.valuesLE_publish state coordinate).trans + (ih () (state.publish coordinate) finalState fuel remaining value hresult) + | reveal coordinate => + rw [LazyRevealProbe.runRaw_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + rw [hvalue] at hresult + exact ih output state finalState fuel remaining value hresult + | none => + rw [hvalue] at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _, htail⟩ := hresult + by_cases hhit : state.hitAt coordinate output + · rw [if_pos hhit] at htail + simp at htail + · rw [if_neg hhit] at htail + exact (LazyRevealProbe.valuesLE_materialize_of_none state coordinate output + hvalue).trans (ih output (state.materialize coordinate output) finalState fuel + remaining value htail) + +theorem LazyRevealProbe.pendingHit_preserved_of_mem_runRaw_done + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (coordinate : Coordinate) (target : HashOutput) + (state finalState : LazyRevealProbe.State Coordinate) (fuel remaining : Nat) + (value : alpha) + (hvalue : state.values coordinate = none) + (hhit : state.hitAt coordinate target) + (hfinal : ∀ output, finalState.values coordinate = some output → output = target) + (hresult : LazyRevealProbe.RawResult.done finalState remaining value ∈ + support (LazyRevealProbe.runRaw state fuel computation)) : + finalState.values coordinate = none ∧ finalState.hitAt coordinate target := by + induction computation using OracleComp.inductionOn generalizing + state finalState fuel remaining value with + | pure result => + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl⟩ + exact ⟨hvalue, hhit⟩ + | query_bind input next ih => + cases input with + | uniform n => + rw [LazyRevealProbe.runRaw_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _, htail⟩ := hresult + exact ih output state finalState fuel remaining value hvalue hhit hfinal htail + | hashOutput => + rw [LazyRevealProbe.runRaw_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _, htail⟩ := hresult + exact ih output state finalState fuel remaining value hvalue hhit hfinal htail + | ensure other => + rw [LazyRevealProbe.runRaw_ensure_query_bind] at hresult + exact ih () (state.ensure other) finalState fuel remaining value hvalue hhit hfinal + hresult + | probe other candidate => + rw [LazyRevealProbe.runRaw_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remainingFuel => + simp only at hresult + by_cases hrevealed : other ∈ state.revealed + · rw [if_pos hrevealed] at hresult + exact ih () state finalState remainingFuel remaining value hvalue hhit hfinal + hresult + · rw [if_neg hrevealed] at hresult + have hhit' : (state.addPending other candidate).hitAt coordinate target := by + simp [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, + LazyRevealProbe.State.addPending] + exact Or.inr (by + simpa [LazyRevealProbe.State.hitAt, + LazyRevealProbe.State.pendingAt] using hhit) + exact ih () (state.addPending other candidate) finalState remainingFuel remaining + value hvalue hhit' hfinal hresult + | peek other => + rw [LazyRevealProbe.runRaw_peek_query_bind] at hresult + exact ih (state.values other) state finalState fuel remaining value hvalue hhit hfinal + hresult + | publish other => + rw [LazyRevealProbe.runRaw_publish_query_bind] at hresult + exact ih () (state.publish other) finalState fuel remaining value hvalue hhit hfinal + hresult + | reveal other => + rw [LazyRevealProbe.runRaw_reveal_query_bind] at hresult + cases hotherValue : state.values other with + | some output => + rw [hotherValue] at hresult + exact ih output state finalState fuel remaining value hvalue hhit hfinal hresult + | none => + rw [hotherValue, mem_support_bind_iff] at hresult + obtain ⟨output, _, htail⟩ := hresult + by_cases hsampledHit : state.hitAt other output + · rw [if_pos hsampledHit] at htail + simp at htail + · rw [if_neg hsampledHit] at htail + by_cases heq : other = coordinate + · subst other + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + (next output) (state.materialize coordinate output) finalState fuel remaining + value htail + have hfinalValue : finalState.values coordinate = some output := + hvaluesLE coordinate output (by + simp [LazyRevealProbe.State.materialize, Function.update]) + have : state.hitAt coordinate output := by + rw [hfinal output hfinalValue] + exact hhit + exact (hsampledHit this).elim + · have hvalue' : (state.materialize other output).values coordinate = none := by + have hne : coordinate ≠ other := Ne.symm heq + simpa [LazyRevealProbe.State.materialize, Function.update, hne] using hvalue + have hhit' : (state.materialize other output).hitAt coordinate target := by + have hne : coordinate ≠ other := Ne.symm heq + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, + LazyRevealProbe.State.materialize, LazyRevealProbe.State.pendingAway, + hne] using hhit + exact ih output (state.materialize other output) finalState fuel remaining value + hvalue' hhit' hfinal htail + +theorem LazyRevealProbe.ensuredLE_of_mem_runRaw_done + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (state finalState : LazyRevealProbe.State Coordinate) (fuel remaining : Nat) + (value : alpha) + (hresult : LazyRevealProbe.RawResult.done finalState remaining value ∈ + support (LazyRevealProbe.runRaw state fuel computation)) : + LazyRevealProbe.EnsuredLE state finalState := by + induction computation using OracleComp.inductionOn generalizing + state finalState fuel remaining value with + | pure result => + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl⟩ + exact fun _ hcoordinate => hcoordinate + | query_bind input next ih => + cases input with + | uniform n => + rw [LazyRevealProbe.runRaw_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _, htail⟩ := hresult + exact ih output state finalState fuel remaining value htail + | hashOutput => + rw [LazyRevealProbe.runRaw_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _, htail⟩ := hresult + exact ih output state finalState fuel remaining value htail + | ensure coordinate => + rw [LazyRevealProbe.runRaw_ensure_query_bind] at hresult + exact (LazyRevealProbe.ensuredLE_ensure state coordinate).trans + (ih () (state.ensure coordinate) finalState fuel remaining value hresult) + | probe coordinate candidate => + rw [LazyRevealProbe.runRaw_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remainingFuel => + simp only at hresult + by_cases hrevealed : coordinate ∈ state.revealed + · rw [if_pos hrevealed] at hresult + exact ih () state finalState remainingFuel remaining value hresult + · rw [if_neg hrevealed] at hresult + exact (LazyRevealProbe.ensuredLE_addPending state coordinate candidate).trans + (ih () (state.addPending coordinate candidate) finalState remainingFuel + remaining value hresult) + | peek coordinate => + rw [LazyRevealProbe.runRaw_peek_query_bind] at hresult + exact ih (state.values coordinate) state finalState fuel remaining value hresult + | publish coordinate => + rw [LazyRevealProbe.runRaw_publish_query_bind] at hresult + exact (LazyRevealProbe.ensuredLE_publish state coordinate).trans + (ih () (state.publish coordinate) finalState fuel remaining value hresult) + | reveal coordinate => + rw [LazyRevealProbe.runRaw_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + rw [hvalue] at hresult + exact ih output state finalState fuel remaining value hresult + | none => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨output, _, htail⟩ := hresult + by_cases hhit : state.hitAt coordinate output + · rw [if_pos hhit] at htail + simp at htail + · rw [if_neg hhit] at htail + exact (LazyRevealProbe.ensuredLE_materialize state coordinate output).trans + (ih output (state.materialize coordinate output) finalState fuel remaining + value htail) + +theorem mem_runRaw_splitHashQuery_ordinary_projects + (input : HashInput) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (output : HashOutput) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((splitHashQuery (.ordinary input)).run cache))) : + finalState = state ∧ remaining = fuel ∧ + (output, ordinaryQueryCache finalCache) ∈ support + ((randomOracle (spec := HashSpec) input).run (ordinaryQueryCache cache)) := by + rw [splitHashQuery_run_eq] at hresult + cases hlookup : cache (.ordinary input) with + | some cached => + rw [hlookup] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + refine ⟨rfl, rfl, ?_⟩ + have hordinary : ordinaryQueryCache finalCache input = some output := hlookup + rw [QueryImpl.withCaching_run_some uniformSampleImpl hordinary] + simp + | none => + rw [hlookup] at hresult + dsimp only at hresult + change LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.hashOutputQuery >>= fun sampled => + pure (sampled, Function.update cache (.ordinary input) (some sampled)))) at hresult + rw [LazyRevealProbe.hashOutputQuery, + LazyRevealProbe.runRaw_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨sampled, _, hdone⟩ := hresult + simp [LazyRevealProbe.runRaw] at hdone + rcases hdone with ⟨rfl, rfl, rfl, rfl⟩ + refine ⟨rfl, rfl, ?_⟩ + have hordinary : ordinaryQueryCache cache input = none := hlookup + rw [QueryImpl.withCaching_run_none uniformSampleImpl hordinary, support_map, + ordinaryQueryCache_update] + exact ⟨output, by simp [uniformSampleImpl], rfl⟩ + +theorem mem_runRaw_simulateQ_ordinaryHashImpl_projects + (computation : OracleComp HashSpec alpha) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : alpha) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ ordinaryHashImpl computation).run cache))) : + finalState = state ∧ remaining = fuel ∧ + (value, ordinaryQueryCache finalCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) computation).run + (ordinaryQueryCache cache)) := by + induction computation using OracleComp.inductionOn generalizing + state cache finalState finalCache fuel remaining value with + | pure result => + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨rfl, rfl, by simp⟩ + | query_bind input next ih => + rw [simulateQ_query_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨raw, hquery, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done queryState queryRemaining queryResult => + rcases queryResult with ⟨answer, queryCache⟩ + have hqueryProjection := mem_runRaw_splitHashQuery_ordinary_projects input state + queryState cache queryCache fuel queryRemaining answer hquery + obtain ⟨rfl, rfl, hqueryActual⟩ := hqueryProjection + have htailProjection := ih answer queryState finalState queryCache finalCache + queryRemaining remaining value hrest + obtain ⟨rfl, rfl, htailActual⟩ := htailProjection + refine ⟨rfl, rfl, ?_⟩ + rw [simulateQ_query_bind, StateT.run_bind, mem_support_bind_iff] + exact ⟨(answer, ordinaryQueryCache queryCache), hqueryActual, htailActual⟩ + +theorem mem_runRaw_simulateQ_splitUniformImpl_projects + (computation : ProbComp alpha) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : alpha) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ splitUniformImpl computation).run cache))) : + finalState = state ∧ remaining = fuel ∧ finalCache = cache ∧ + value ∈ support computation := by + induction computation using OracleComp.inductionOn generalizing + state cache finalState finalCache fuel remaining value with + | pure result => + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨rfl, rfl, rfl, by simp⟩ + | query_bind n next ih => + rw [simulateQ_query_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨raw, hquery, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done queryState queryRemaining queryResult => + rcases queryResult with ⟨output, queryCache⟩ + change Fin (n + 1) at output + change LazyRevealProbe.RawResult.done queryState queryRemaining + (output, queryCache) ∈ support + ((liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) >>= fun sampled => + pure (LazyRevealProbe.RawResult.done state fuel (sampled, cache))) at hquery + rw [mem_support_bind_iff] at hquery + obtain ⟨sampled, hsampled, hdone⟩ := hquery + simp at hdone + rcases hdone with ⟨rfl, rfl, rfl, rfl⟩ + obtain ⟨rfl, rfl, rfl, htail⟩ := ih output queryState finalState queryCache + finalCache queryRemaining remaining value hrest + refine ⟨rfl, rfl, rfl, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨output, hsampled, htail⟩ + +theorem evalWithAnswerFn_eq_of_mem_runRaw_ordinaryHashImpl + (f : QueryImpl HashSpec Id) (computation : OracleComp HashSpec alpha) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : alpha) + (hf : (ordinaryQueryCache finalCache).AgreesWithFn f) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ ordinaryHashImpl computation).run cache))) : + evalWithAnswerFn f computation = value := by + have hprojection := mem_runRaw_simulateQ_ordinaryHashImpl_projects computation state + finalState cache finalCache fuel remaining value hresult + exact (replay_of_mem_support computation (ordinaryQueryCache cache) value + (ordinaryQueryCache finalCache) hprojection.2.2 f hf).2.1 + +def SplitCachePreserving + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ state cache fuel finalState remaining value finalCache, + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + finalCache = cache + +def OrdinaryCacheIncreasing + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ state cache fuel finalState remaining value finalCache, + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + ordinaryQueryCache cache ≤ ordinaryQueryCache finalCache + +def OrdinaryEntryPreserving (input : HashInput) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ state cache fuel finalState remaining value finalCache output, + cache (.ordinary input) = some output → + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + finalCache (.ordinary input) = some output + +def CachesOrdinaryInput (input : HashInput) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ state cache fuel finalState remaining value finalCache, + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + finalCache (.ordinary input) ≠ none + +def ReturnsCachedOrdinary (input : HashInput) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput) : Prop := + ∀ state cache fuel finalState remaining output finalCache, + LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + finalCache (.ordinary input) = some output + +def PreservesOrdinaryPresence (input : HashInput) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ state cache fuel finalState remaining value finalCache, + cache (.ordinary input) ≠ none → + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + finalCache (.ordinary input) ≠ none + +theorem ReturnsCachedOrdinary.bind_right + {input : HashInput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput} + (hnext : ∀ value, ReturnsCachedOrdinary input (next value)) : + ReturnsCachedOrdinary input (left >>= next) := by + intro state cache fuel finalState remaining output finalCache hresult + change LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun leftResult => (next leftResult.1).run leftResult.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, _, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining leftResult => + rcases leftResult with ⟨leftValue, middleCache⟩ + exact hnext leftValue middleState middleCache middleRemaining finalState remaining output + finalCache hrest + +theorem PreservesOrdinaryPresence.pure (input : HashInput) (value : alpha) : + PreservesOrdinaryPresence input + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro state cache fuel finalState remaining result finalCache hcached hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hcached + +theorem PreservesOrdinaryPresence.bind + {input : HashInput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : PreservesOrdinaryPresence input left) + (hnext : ∀ value, PreservesOrdinaryPresence input (next value)) : + PreservesOrdinaryPresence input (left >>= next) := by + intro state cache fuel finalState remaining result finalCache hcached hresult + change LazyRevealProbe.RawResult.done finalState remaining (result, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun leftResult => (next leftResult.1).run leftResult.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining leftResult => + rcases leftResult with ⟨leftValue, middleCache⟩ + exact hnext leftValue middleState middleCache middleRemaining finalState remaining result + finalCache (hleft state cache fuel middleState middleRemaining leftValue middleCache + hcached hraw) hrest + +theorem CachesOrdinaryInput.bind_right + {input : HashInput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hnext : ∀ value, CachesOrdinaryInput input (next value)) : + CachesOrdinaryInput input (left >>= next) := by + intro state cache fuel finalState remaining result finalCache hresult + change LazyRevealProbe.RawResult.done finalState remaining (result, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun leftResult => (next leftResult.1).run leftResult.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, _, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining leftResult => + rcases leftResult with ⟨leftValue, middleCache⟩ + exact hnext leftValue middleState middleCache middleRemaining finalState remaining result + finalCache hrest + +theorem CachesOrdinaryInput.bind_preserving + {input : HashInput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : CachesOrdinaryInput input left) + (hnext : ∀ value, OrdinaryEntryPreserving input (next value)) : + CachesOrdinaryInput input (left >>= next) := by + intro state cache fuel finalState remaining result finalCache hresult + change LazyRevealProbe.RawResult.done finalState remaining (result, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun leftResult => (next leftResult.1).run leftResult.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining leftResult => + rcases leftResult with ⟨leftValue, middleCache⟩ + obtain ⟨output, hcached⟩ := Option.ne_none_iff_exists'.mp + (hleft state cache fuel middleState middleRemaining leftValue middleCache hraw) + exact Option.ne_none_iff_exists'.2 ⟨output, + hnext leftValue middleState middleCache middleRemaining finalState remaining result + finalCache output hcached hrest⟩ + +theorem CachesOrdinaryInput.bind_presence + {input : HashInput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : CachesOrdinaryInput input left) + (hnext : ∀ value, PreservesOrdinaryPresence input (next value)) : + CachesOrdinaryInput input (left >>= next) := by + intro state cache fuel finalState remaining result finalCache hresult + change LazyRevealProbe.RawResult.done finalState remaining (result, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun leftResult => (next leftResult.1).run leftResult.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining leftResult => + rcases leftResult with ⟨leftValue, middleCache⟩ + exact hnext leftValue middleState middleCache middleRemaining finalState remaining result + finalCache (hleft state cache fuel middleState middleRemaining leftValue middleCache hraw) + hrest + +def StableOrdinaryInput (parameter : PublicParameter) (input : HashInput) : Prop := + decodeProbe? parameter input = none ∧ + ∀ position, decodePosition? parameter input = some position → ¬IsOtsPosition position + +def StableCacheAgreesWithFn (parameter : PublicParameter) (cache : SplitHashCache) + (f : QueryImpl HashSpec Id) : Prop := + ∀ input output, StableOrdinaryInput parameter input → + cache (.ordinary input) = some output → f input = output + +theorem StableCacheAgreesWithFn.of_agrees + {parameter : PublicParameter} {cache : SplitHashCache} {f : QueryImpl HashSpec Id} + (hf : (ordinaryQueryCache cache).AgreesWithFn f) : + StableCacheAgreesWithFn parameter cache f := by + intro input output _ hcached + exact hf hcached + +theorem StableCacheAgreesWithFn.of_run + {parameter : PublicParameter} {f : QueryImpl HashSpec Id} + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + (hpreserving : ∀ input, StableOrdinaryInput parameter input → + OrdinaryEntryPreserving input computation) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : alpha) + (hfinal : StableCacheAgreesWithFn parameter finalCache f) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache))) : + StableCacheAgreesWithFn parameter cache f := by + intro input output hstable hcached + exact hfinal input output hstable + (hpreserving input hstable state cache fuel finalState remaining value finalCache output + hcached hresult) + +def QueriesStable (parameter : PublicParameter) (f : QueryImpl HashSpec Id) + (computation : OracleComp HashSpec alpha) : Prop := + ∀ input, input ∈ queriedInputs f computation → StableOrdinaryInput parameter input + +theorem QueriesStable.pure + (parameter : PublicParameter) (f : QueryImpl HashSpec Id) (value : alpha) : + QueriesStable parameter f (pure value : OracleComp HashSpec alpha) := by + intro input hinput + simp at hinput + +theorem QueriesStable.bind + {parameter : PublicParameter} {f : QueryImpl HashSpec Id} + {left : OracleComp HashSpec alpha} {next : alpha → OracleComp HashSpec beta} + (hleft : QueriesStable parameter f left) + (hnext : QueriesStable parameter f (next (evalWithAnswerFn f left))) : + QueriesStable parameter f (left >>= next) := by + intro input hinput + rw [queriedInputs_bind] at hinput + rcases List.mem_append.mp hinput with hinput | hinput + · exact hleft input hinput + · exact hnext input hinput + +theorem QueriesStable.sequenceFin + {parameter : PublicParameter} {f : QueryImpl HashSpec Id} {n : Nat} + (computation : Fin n → OracleComp HashSpec alpha) + (hcomputation : ∀ index, QueriesStable parameter f (computation index)) : + QueriesStable parameter f (sequenceFin computation) := by + induction n with + | zero => exact QueriesStable.pure parameter f Fin.elim0 + | succ n ih => + rw [SphincsSecurity.Concrete.sequenceFin] + exact (hcomputation 0).bind <| + (ih (fun index => computation index.succ) fun index => hcomputation index.succ).bind + (QueriesStable.pure parameter f _) + +theorem replay_of_mem_support_of_stable + (parameter : PublicParameter) (computation : OracleComp HashSpec alpha) + (cache : QueryCache HashSpec) (value : alpha) (finalCache : QueryCache HashSpec) + (hresult : (value, finalCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) computation).run cache)) + (f : QueryImpl HashSpec Id) + (hfinal : ∀ input output, StableOrdinaryInput parameter input → + finalCache input = some output → f input = output) + (hstable : QueriesStable parameter f computation) : + cache ≤ finalCache ∧ evalWithAnswerFn f computation = value ∧ + CachedRun finalCache f computation := by + classical + induction computation using OracleComp.inductionOn generalizing cache value finalCache with + | pure result => + simp only [simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq] at hresult + obtain ⟨rfl, rfl⟩ := hresult + refine ⟨le_rfl, rfl, ?_⟩ + simp [CachedRun] + | query_bind input next ih => + simp only [simulateQ_query_bind, StateT.run_bind, mem_support_bind_iff] at hresult + obtain ⟨⟨answer, middleCache⟩, hquery, hrest⟩ := hresult + change (answer, middleCache) ∈ support ((randomOracle input).run cache) at hquery + have hcached : middleCache input = some answer := by + cases hcache : cache input with + | some old => + rw [QueryImpl.withCaching_run_some uniformSampleImpl hcache, support_pure, + Set.mem_singleton_iff] at hquery + obtain ⟨rfl, rfl⟩ := hquery + exact hcache + | none => + rw [QueryImpl.withCaching_run_none uniformSampleImpl hcache, support_map] at hquery + obtain ⟨sampled, _, heq⟩ := hquery + obtain ⟨rfl, rfl⟩ := heq + exact QueryCache.cacheQuery_self cache input answer + have hinputStable : StableOrdinaryInput parameter input := by + apply hstable input + rw [queriedInputs_query_bind] + simp + have hmiddleLe : middleCache ≤ finalCache := + FtsProbeSimulation.simulateQ_randomOracle_cache_le (next answer) middleCache finalCache + value hrest + have hcachedFinal : finalCache input = some answer := hmiddleLe hcached + have hfinput : f input = answer := hfinal input answer hinputStable hcachedFinal + have htailStable : QueriesStable parameter f (next answer) := by + intro other hother + apply hstable other + rw [queriedInputs_query_bind, hfinput] + exact List.mem_cons_of_mem input hother + obtain ⟨hle, heval, hqueries⟩ := ih answer middleCache value finalCache hrest + hfinal htailStable + refine ⟨(QueryImpl.withCaching_cache_le uniformSampleImpl input cache + (answer, middleCache) hquery).trans hle, ?_, ?_⟩ + · rw [evalWithAnswerFn_bind, + show evalWithAnswerFn f (liftM (HashSpec.query input)) = f input from + simulateQ_spec_query f input, hfinput] + exact heval + · intro other hqueried + rw [queriedInputs_query_bind, hfinput] at hqueried + simp only [List.mem_cons] at hqueried + rcases hqueried with rfl | htail + · + simp [hcachedFinal] + · exact hqueries other htail + +theorem replay_of_mem_runRaw_ordinaryHashImpl_of_stable + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (computation : OracleComp HashSpec alpha) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : alpha) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (hstable : QueriesStable parameter f computation) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ ordinaryHashImpl computation).run cache))) : + evalWithAnswerFn f computation = value ∧ + CachedRun (ordinaryQueryCache finalCache) f computation := by + have hprojection := mem_runRaw_simulateQ_ordinaryHashImpl_projects computation state + finalState cache finalCache fuel remaining value hresult + have hreplay := replay_of_mem_support_of_stable parameter computation + (ordinaryQueryCache cache) value (ordinaryQueryCache finalCache) hprojection.2.2 f + (fun input output hinput hcached => hf input output hinput hcached) hstable + exact ⟨hreplay.2.1, hreplay.2.2⟩ + +theorem OrdinaryEntryPreserving.pure (input : HashInput) (value : alpha) : + OrdinaryEntryPreserving input + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro state cache fuel finalState remaining result finalCache output hcached hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hcached + +theorem OrdinaryEntryPreserving.bind + {input : HashInput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : OrdinaryEntryPreserving input left) + (hnext : ∀ value, OrdinaryEntryPreserving input (next value)) : + OrdinaryEntryPreserving input (left >>= next) := by + intro state cache fuel finalState remaining result finalCache output hcached hresult + change LazyRevealProbe.RawResult.done finalState remaining (result, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun leftResult => (next leftResult.1).run leftResult.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining leftResult => + rcases leftResult with ⟨leftValue, middleCache⟩ + exact hnext leftValue middleState middleCache middleRemaining finalState remaining result + finalCache output (hleft state cache fuel middleState middleRemaining leftValue middleCache + output hcached hraw) hrest + +theorem OrdinaryCacheIncreasing.entryPreserving + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + (hincreasing : OrdinaryCacheIncreasing computation) (input : HashInput) : + OrdinaryEntryPreserving input computation := by + intro state cache fuel finalState remaining value finalCache output hcached hresult + exact hincreasing state cache fuel finalState remaining value finalCache hresult hcached + +theorem OrdinaryCacheIncreasing.pure (value : alpha) : + OrdinaryCacheIncreasing + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro state cache fuel finalState remaining result finalCache hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact le_rfl + +theorem OrdinaryCacheIncreasing.bind + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : OrdinaryCacheIncreasing left) + (hnext : ∀ value, OrdinaryCacheIncreasing (next value)) : + OrdinaryCacheIncreasing (left >>= next) := by + intro state cache fuel finalState remaining result finalCache hresult + change LazyRevealProbe.RawResult.done finalState remaining (result, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun leftResult => (next leftResult.1).run leftResult.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining leftResult => + rcases leftResult with ⟨leftValue, middleCache⟩ + exact (hleft state cache fuel middleState middleRemaining leftValue middleCache hraw).trans + (hnext leftValue middleState middleCache middleRemaining finalState remaining result + finalCache hrest) + +theorem ordinaryCacheIncreasing_simulateQ_ordinaryHashImpl + (computation : OracleComp HashSpec alpha) : + OrdinaryCacheIncreasing (simulateQ ordinaryHashImpl computation) := by + intro state cache fuel finalState remaining value finalCache hresult + have hprojection := mem_runRaw_simulateQ_ordinaryHashImpl_projects computation state + finalState cache finalCache fuel remaining value hresult + exact FtsProbeSimulation.simulateQ_randomOracle_cache_le computation + (ordinaryQueryCache cache) (ordinaryQueryCache finalCache) value hprojection.2.2 + +theorem ordinaryCacheIncreasing_splitHashQuery_ordinary (input : HashInput) : + OrdinaryCacheIncreasing (splitHashQuery (.ordinary input)) := by + have hincreasing := ordinaryCacheIncreasing_simulateQ_ordinaryHashImpl + (liftM (HashSpec.query input) : OracleComp HashSpec HashOutput) + simpa [ordinaryHashImpl] using hincreasing + +theorem returnsCachedOrdinary_splitHashQuery (input : HashInput) : + ReturnsCachedOrdinary input (splitHashQuery (.ordinary input)) := by + intro state cache fuel finalState remaining output finalCache hresult + rw [splitHashQuery_run_eq] at hresult + cases hlookup : cache (.ordinary input) with + | some cached => + rw [hlookup] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + simp [hlookup] + | none => + rw [hlookup] at hresult + dsimp only at hresult + change LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.hashOutputQuery >>= fun sampled => + pure (sampled, Function.update cache (.ordinary input) (some sampled)))) at hresult + rw [LazyRevealProbe.hashOutputQuery, + LazyRevealProbe.runRaw_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨sampled, _, hdone⟩ := hresult + simp [LazyRevealProbe.runRaw] at hdone + rcases hdone with ⟨rfl, rfl, rfl, rfl⟩ + simp [Function.update] + +theorem cachesOrdinaryInput_splitHashQuery (input : HashInput) : + CachesOrdinaryInput input (splitHashQuery (.ordinary input)) := by + intro state cache fuel finalState remaining output finalCache hresult + rw [returnsCachedOrdinary_splitHashQuery input state cache fuel finalState remaining output + finalCache hresult] + simp + +theorem ordinaryCacheIncreasing_simulateQ_splitUniformImpl + (computation : ProbComp alpha) : + OrdinaryCacheIncreasing (simulateQ splitUniformImpl computation) := by + intro state cache fuel finalState remaining value finalCache hresult + have hprojection := mem_runRaw_simulateQ_splitUniformImpl_projects computation state + finalState cache finalCache fuel remaining value hresult + rw [hprojection.2.2.1] + +theorem SplitCachePreserving.pure (value : alpha) : + SplitCachePreserving + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro state cache fuel finalState remaining result finalCache hresult + simp [LazyRevealProbe.runRaw] at hresult + exact hresult.2.2.2 + +theorem SplitCachePreserving.bind + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : SplitCachePreserving left) + (hnext : ∀ value, SplitCachePreserving (next value)) : + SplitCachePreserving (left >>= next) := by + intro state cache fuel finalState remaining result finalCache hresult + change LazyRevealProbe.RawResult.done finalState remaining (result, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun leftResult => (next leftResult.1).run leftResult.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining leftResult => + rcases leftResult with ⟨leftValue, middleCache⟩ + exact (hnext leftValue middleState middleCache middleRemaining finalState remaining result + finalCache hrest).trans (hleft state cache fuel middleState middleRemaining leftValue + middleCache hraw) + +theorem SplitCachePreserving.ordinaryCacheIncreasing + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + (hpreserves : SplitCachePreserving computation) : + OrdinaryCacheIncreasing computation := by + intro state cache fuel finalState remaining value finalCache hresult + rw [hpreserves state cache fuel finalState remaining value finalCache hresult] + +theorem SplitCachePreserving.entryPreserving + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + (hpreserves : SplitCachePreserving computation) (input : HashInput) : + OrdinaryEntryPreserving input computation := + hpreserves.ordinaryCacheIncreasing.entryPreserving input + +theorem splitCachePreserving_ensureCoordinate (coordinate : Coordinate) : + SplitCachePreserving (ensureCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.ensureQuery coordinate >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.ensureQuery, LazyRevealProbe.runRaw_ensure_query_bind] at hresult + simp [LazyRevealProbe.runRaw] at hresult + exact hresult.2.2 + +theorem splitCachePreserving_sequenceFin {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hcomputation : ∀ index, SplitCachePreserving (computation index)) : + SplitCachePreserving (sequenceFin computation) := by + induction n with + | zero => + simp only [sequenceFin] + exact SplitCachePreserving.pure Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomputation 0).bind fun _ => + (ih (fun index => computation index.succ) + (fun index => hcomputation index.succ)).bind fun _ => + SplitCachePreserving.pure _ + +theorem splitCachePreserving_ensureChainPrefix + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (digit : Digit) : + SplitCachePreserving (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (splitCachePreserving_sequenceFin _ fun step => by + split + · exact splitCachePreserving_ensureCoordinate _ + · exact SplitCachePreserving.pure ()).bind fun _ => SplitCachePreserving.pure () + +theorem splitCachePreserving_ensureFullChain + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + SplitCachePreserving (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (splitCachePreserving_sequenceFin _ fun _ => + splitCachePreserving_ensureCoordinate _).bind fun _ => SplitCachePreserving.pure () + +theorem splitCachePreserving_ensureOtsLeaf + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + SplitCachePreserving (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (splitCachePreserving_sequenceFin _ fun chainIdx => + splitCachePreserving_ensureFullChain lay tree leafIdx chainIdx).bind fun _ => + splitCachePreserving_ensureCoordinate _ + +theorem splitCachePreserving_ensureTreeNode (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, SplitCachePreserving (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => splitCachePreserving_ensureOtsLeaf lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (splitCachePreserving_ensureTreeNode lay tree level (2 * nodeIdx)).bind fun _ => + (splitCachePreserving_ensureTreeNode lay tree level (2 * nodeIdx + 1)).bind fun _ => by + split + · exact splitCachePreserving_ensureCoordinate _ + · exact SplitCachePreserving.pure () + +theorem splitCachePreserving_ensureTreePath + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + SplitCachePreserving (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (splitCachePreserving_sequenceFin _ fun level => by + split + · exact splitCachePreserving_ensureTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · exact SplitCachePreserving.pure ()).bind fun _ => SplitCachePreserving.pure () + +theorem ordinaryCacheIncreasing_sequenceFin {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hcomputation : ∀ index, OrdinaryCacheIncreasing (computation index)) : + OrdinaryCacheIncreasing (sequenceFin computation) := by + induction n with + | zero => + simp only [sequenceFin] + exact OrdinaryCacheIncreasing.pure Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomputation 0).bind fun _ => + (ih (fun index => computation index.succ) + (fun index => hcomputation index.succ)).bind fun _ => + OrdinaryCacheIncreasing.pure _ + +theorem isChainCoordinate_chainValueCoordinate (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + IsChainCoordinate (chainValueCoordinate lay tree leafIdx chainIdx digit) := by + unfold chainValueCoordinate + split <;> trivial + +def ChainState.ValidFor (allowed : Coordinate → Prop) + (state : LazyRevealProbe.State Coordinate) : Prop := + ∀ coordinate, IsChainCoordinate coordinate → + (state.values coordinate ≠ none → coordinate ∈ state.revealed) ∧ + (coordinate ∈ state.revealed → state.values coordinate ≠ none) ∧ + (coordinate ∈ state.revealed → allowed coordinate) + +def ChainProbeAccounted (parameter : PublicParameter) (allowed : Coordinate → Prop) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) : Prop := + ∀ (probe : Probe) (input : HashInput), probe.MatchesInput parameter input → + cache (.ordinary input) ≠ none → + ¬allowed probe.coordinate → probe.candidate ∈ state.pendingAt probe.coordinate + +theorem chainProbeAccounted_empty (parameter : PublicParameter) (allowed : Coordinate → Prop) : + ChainProbeAccounted parameter allowed + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) emptySplitHashCache := by + intro probe input hmatch hcached + simp [emptySplitHashCache] at hcached + +theorem Probe.target_eq_truncate_table_of_chain + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (probe : Probe) + (hchain : IsChainCoordinate probe.coordinate) + (hf : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) : + probe.target f parameter (tableOtsSecret table) ftsSecret = + truncateHash (table probe.coordinate) := by + rcases probe with ⟨coordinate, candidate⟩ + cases coordinate with + | chainStart lay tree leafIdx chainIdx => simp [Probe.target, tableOtsSecret] + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + change honestValue f parameter (tableOtsSecret table) ftsSecret + (.chain lay tree leafIdx chainIdx step) = + truncateHash (table (.position (.chain lay tree leafIdx chainIdx step))) + rw [honestValue_chain, + honestChain_eq_table_succ f parameter table lay tree leafIdx chainIdx hf + step.val step.isLt] + rfl + | leaf => simp [IsChainCoordinate] at hchain + | node => simp [IsChainCoordinate] at hchain + | ftsLeaf => simp [IsChainCoordinate] at hchain + | ftsNode => simp [IsChainCoordinate] at hchain + | ftsRoots => simp [IsChainCoordinate] at hchain + +theorem ChainProbeAccounted.hitAt + {parameter : PublicParameter} {allowed : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (haccounted : ChainProbeAccounted parameter allowed state cache) + (f : QueryImpl HashSpec Id) (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (probe : Probe) (input : HashInput) + (hchain : IsChainCoordinate probe.coordinate) + (hf : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hhits : probe.Hits f parameter (tableOtsSecret table) ftsSecret) + (hmatches : probe.MatchesInput parameter input) (hcached : cache (.ordinary input) ≠ none) + (hnotAllowed : ¬allowed probe.coordinate) : state.hitAt probe.coordinate (table probe.coordinate) := by + have hpending := haccounted probe input hmatches hcached hnotAllowed + rw [LazyRevealProbe.State.hitAt] + rw [← probe.target_eq_truncate_table_of_chain f parameter table ftsSecret hchain hf, + ← hhits] + exact hpending + +theorem Probe.isChainCoordinate_of_matchesInput + {parameter : PublicParameter} {probe : Probe} {input : HashInput} + (hmatches : probe.MatchesInput parameter input) : + IsChainCoordinate probe.coordinate := by + rcases probe with ⟨coordinate, candidate⟩ + cases coordinate with + | chainStart => trivial + | position position => + cases position with + | chain => trivial + | leaf => simp [Probe.MatchesInput] at hmatches + | node => simp [Probe.MatchesInput] at hmatches + | ftsLeaf => simp [Probe.MatchesInput] at hmatches + | ftsNode => simp [Probe.MatchesInput] at hmatches + | ftsRoots => simp [Probe.MatchesInput] at hmatches + +theorem decodeProbe?_tweakableHashInput_of_not_chain_leaf + (parameter : PublicParameter) (domain : HashDomain) (payload : HashInput) + (hinRange : domain.InRange) + (hchain : ∀ lay tree leafIdx chainIdx step, + domain ≠ .chain lay tree leafIdx chainIdx step) + (hleaf : ∀ lay tree leafIdx, domain ≠ .leaf lay tree leafIdx) : + decodeProbe? parameter (tweakableHashInput parameter domain payload) = none := by + rw [decodeProbe?_eq_none_iff] + rintro ⟨coordinate, candidate⟩ hmatches + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + obtain ⟨step, hstep, hinput⟩ := hmatches + have hdomain := (tweakableHashInput_injective parameter hinRange (by trivial) hinput).1 + exact hchain lay tree leafIdx chainIdx step hdomain + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + simp only [Probe.MatchesInput] at hmatches + split at hmatches + · obtain ⟨nextStep, hnext, hinput⟩ := hmatches + have hdomain := + (tweakableHashInput_injective parameter hinRange (by trivial) hinput).1 + exact hchain lay tree leafIdx chainIdx nextStep hdomain + · obtain ⟨hchainZero, leafPayload, hinput, hslot⟩ := hmatches + have hdomain := + (tweakableHashInput_injective parameter hinRange (by trivial) hinput).1 + exact hleaf lay tree leafIdx hdomain + | leaf => simp [Probe.MatchesInput] at hmatches + | node => simp [Probe.MatchesInput] at hmatches + | ftsLeaf => simp [Probe.MatchesInput] at hmatches + | ftsNode => simp [Probe.MatchesInput] at hmatches + | ftsRoots => simp [Probe.MatchesInput] at hmatches + +theorem stableOrdinaryInput_tweakableHashInput + (parameter : PublicParameter) (domain : HashDomain) (payload : HashInput) + (hinRange : domain.InRange) + (hchain : ∀ lay tree leafIdx chainIdx step, + domain ≠ .chain lay tree leafIdx chainIdx step) + (hleaf : ∀ lay tree leafIdx, domain ≠ .leaf lay tree leafIdx) + (hnode : ∀ lay tree level nodeIdx, domain ≠ .node lay tree level nodeIdx) : + StableOrdinaryInput parameter (tweakableHashInput parameter domain payload) := by + refine ⟨decodeProbe?_tweakableHashInput_of_not_chain_leaf parameter domain payload hinRange + hchain hleaf, ?_⟩ + intro position hposition hots + have hat := (decodePosition?_eq_some_iff parameter _ position).1 hposition + obtain ⟨positionPayload, hinput⟩ := hat + have hdomain := (tweakableHashInput_injective parameter hinRange position.domain_inRange + hinput).1 + cases position with + | chain lay tree leafIdx chainIdx step => exact hchain lay tree leafIdx chainIdx step hdomain + | leaf lay tree leafIdx => exact hleaf lay tree leafIdx hdomain + | node lay tree level nodeIdx => + exact hnode lay tree (level.val + 1) nodeIdx.val hdomain + | ftsLeaf | ftsNode | ftsRoots => simp [IsOtsPosition] at hots + +theorem queriesStable_tweakableHash + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (domain : HashDomain) (payload : HashInput) (hinRange : domain.InRange) + (hchain : ∀ lay tree leafIdx chainIdx step, + domain ≠ .chain lay tree leafIdx chainIdx step) + (hleaf : ∀ lay tree leafIdx, domain ≠ .leaf lay tree leafIdx) + (hnode : ∀ lay tree level nodeIdx, domain ≠ .node lay tree level nodeIdx) : + QueriesStable parameter f (tweakableHash parameter domain payload) := by + intro input hinput + rw [queriedInputs_tweakableHash] at hinput + simp only [List.mem_singleton] at hinput + subst input + exact stableOrdinaryInput_tweakableHashInput parameter domain payload hinRange hchain hleaf + hnode + +theorem queriesStable_ftsLeafHash + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (index : Index) (tree : FtsTree) (leafIdx : FtsLeaf) (secret : Digest) : + QueriesStable parameter f (ftsLeafHash parameter index tree leafIdx secret) := by + unfold ftsLeafHash + exact queriesStable_tweakableHash f parameter (.ftsLeaf index tree leafIdx) _ (by trivial) + (by simp) (by simp) (by simp) + +theorem queriesStable_ftsNode + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (index : Index) (tree : FtsTree) (secret : FtsLeaf → Digest) : + ∀ level nodeIdx, level ≤ ftsTreeHeight → + 2 ^ level * (nodeIdx + 1) ≤ 2 ^ ftsTreeHeight → QueriesStable parameter f + (ftsNode parameter index tree secret level nodeIdx) + | 0, nodeIdx, hlevel, hspan => by + rw [ftsNode_zero_eq] + exact queriesStable_ftsLeafHash f parameter index tree _ _ + | level + 1, nodeIdx, hlevel, hspan => by + rw [ftsNode_succ_eq] + have hleftSpan : 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ ftsTreeHeight := by + rw [pow_succ] at hspan + calc + 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ level * (2 * (nodeIdx + 1)) := + Nat.mul_le_mul_left _ (by omega) + _ = 2 ^ level * 2 * (nodeIdx + 1) := by ring + _ ≤ 2 ^ ftsTreeHeight := hspan + have hrightSpan : 2 ^ level * (2 * nodeIdx + 1 + 1) ≤ 2 ^ ftsTreeHeight := by + rw [pow_succ] at hspan + calc + 2 ^ level * (2 * nodeIdx + 1 + 1) = 2 ^ level * 2 * (nodeIdx + 1) := by + ring + _ ≤ 2 ^ ftsTreeHeight := hspan + have hinRange : (HashDomain.ftsNode index tree (level + 1) nodeIdx).InRange := by + show level + 1 < 2 ^ 32 ∧ nodeIdx < 2 ^ 32 + constructor + · have : ftsTreeHeight < 2 ^ 32 := by norm_num [ftsTreeHeight] + omega + · have hnode : nodeIdx < 2 ^ ftsTreeHeight := by + have hpow : 0 < 2 ^ (level + 1) := Nat.two_pow_pos _ + nlinarith + have : 2 ^ ftsTreeHeight ≤ 2 ^ 32 := Nat.pow_le_pow_right (by omega) (by + norm_num [ftsTreeHeight]) + omega + exact (queriesStable_ftsNode f parameter index tree secret level (2 * nodeIdx) + (by omega) hleftSpan).bind <| + (queriesStable_ftsNode f parameter index tree secret level (2 * nodeIdx + 1) + (by omega) hrightSpan).bind <| + queriesStable_tweakableHash f parameter (.ftsNode index tree (level + 1) nodeIdx) _ + hinRange (by simp) (by simp) (by simp) + +theorem queriesStable_ftsKey + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (index : Index) (secret : FtsTree → FtsLeaf → Digest) : + QueriesStable parameter f (ftsKey parameter index secret) := by + unfold ftsKey + exact (QueriesStable.sequenceFin + (fun tree => ftsNode parameter index tree (secret tree) ftsTreeHeight 0) + (fun tree => queriesStable_ftsNode f parameter index tree (secret tree) ftsTreeHeight 0 + le_rfl (by simp))).bind + (queriesStable_tweakableHash f parameter (.ftsRoots index) _ (by trivial) + (by simp) (by simp) (by simp)) + +theorem queriesStable_ftsOpen + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (index : Index) + (leaves : DigestTree → FtsLeaf) (secret : FtsTree → FtsLeaf → Digest) : + QueriesStable parameter f (ftsOpen parameter index leaves secret) := by + unfold ftsOpen + exact QueriesStable.sequenceFin _ fun tree => + QueriesStable.sequenceFin _ fun level => + queriesStable_ftsNode f parameter index tree (secret tree) level.val + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1) + (Nat.le_of_lt level.isLt) + (FtsProbeSimulation.ftsOpen_node_bound (leaves (ftsIndexOf tree)) level) + +theorem queriesStable_encode + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (counter : Counter) : + QueriesStable parameter f (encode parameter lay tree leafIdx message counter) := by + unfold encode + exact (queriesStable_tweakableHash f parameter (.encoding lay tree leafIdx) _ (by trivial) + (by simp) (by simp) (by simp)).bind (QueriesStable.pure parameter f _) + +theorem queriesStable_messageDigest + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (message : Message) (randomness : Randomness) : + QueriesStable parameter f (messageDigest parameter root message randomness) := by + unfold messageDigest oracleHash + intro input hinput + change input ∈ queriedInputs f + ((liftM (HashSpec.query (tweakableHashInput parameter .message + (messageDigestPayload root message randomness))) : OracleComp HashSpec HashOutput) >>= + fun output => pure (truncateMessageDigest output)) at hinput + rw [queriedInputs_query_bind, queriedInputs_pure] at hinput + simp only [List.mem_cons, List.not_mem_nil, or_false] at hinput + subst input + exact stableOrdinaryInput_tweakableHashInput parameter .message _ (by trivial) + (by simp) (by simp) (by simp) + +theorem queriesStable_signAttempt + (f : QueryImpl HashSpec Id) (secretKey : SecretKey) (message : Message) + (randomness : Randomness) : + QueriesStable secretKey.parameter f (signAttempt secretKey message randomness) := by + unfold signAttempt + exact (queriesStable_messageDigest f secretKey.parameter secretKey.root message randomness).bind + (by split <;> exact QueriesStable.pure secretKey.parameter f _) + +theorem maskedOtsSignFrom_some_eval + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (selectedCounter : Counter) (encoding : ChainIndex → Digit), + StableCacheAgreesWithFn parameter finalCache f → + LazyRevealProbe.RawResult.done finalState remaining + (some (selectedCounter, encoding), finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedOtsSignFrom parameter lay tree leafIdx message attempts counter).run cache)) → + evalWithAnswerFn f + (encode parameter lay tree leafIdx message selectedCounter) = some encoding + | 0, counter, state, finalState, cache, finalCache, fuel, remaining, + selectedCounter, encoding, hf, hresult => by + simp [maskedOtsSignFrom, LazyRevealProbe.runRaw] at hresult + | attempts + 1, counter, state, finalState, cache, finalCache, fuel, remaining, + selectedCounter, encoding, hf, hresult => by + rw [maskedOtsSignFrom, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨raw, hencode, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done encodeState encodeRemaining encodeResult => + rcases encodeResult with ⟨encoded, encodeCache⟩ + simp only at hrest + cases encoded with + | none => + exact maskedOtsSignFrom_some_eval f parameter lay tree leafIdx message attempts + (counter + 1) encodeState finalState encodeCache finalCache encodeRemaining + remaining selectedCounter encoding hf hrest + | some selectedEncoding => + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hrest + obtain ⟨ensureRaw, hensure, hfinish⟩ := hrest + cases ensureRaw with + | stopped hit => simp at hfinish + | done ensureState ensureRemaining ensureResult => + rcases ensureResult with ⟨ensured, ensureCache⟩ + have hcache := splitCachePreserving_sequenceFin + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx + (selectedEncoding chainIdx)) + (fun chainIdx => splitCachePreserving_ensureChainPrefix lay tree leafIdx + chainIdx (selectedEncoding chainIdx)) encodeState encodeCache + encodeRemaining ensureState ensureRemaining ensured ensureCache hensure + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, hremaining, houtput, hfinalCache⟩ + rcases houtput with ⟨hselectedCounter, hencoding⟩ + subst selectedCounter + subst encoding + subst finalCache + rw [hcache] at hf + exact (replay_of_mem_runRaw_ordinaryHashImpl_of_stable f parameter + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter)) state encodeState cache encodeCache fuel + encodeRemaining (some selectedEncoding) hf + (queriesStable_encode f parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter)) hencode).1 + +theorem maskedOtsSign_some_eval + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (counter : Counter) (encoding : ChainIndex → Digit) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (some (counter, encoding), finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedOtsSign parameter lay tree leafIdx message).run cache))) : + evalWithAnswerFn f (encode parameter lay tree leafIdx message counter) = some encoding := by + exact maskedOtsSignFrom_some_eval f parameter lay tree leafIdx message encodingAttemptLimit 0 + state finalState cache finalCache fuel remaining counter encoding hf hresult + +theorem tweakableHashInput_ftsNode_ne_chain + (parameter : PublicParameter) (index : Index) (tree : FtsTree) + (level nodeIdx : Nat) (payload : HashInput) (lay : Layer) (otsTree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (step : ChainStep) + (chainPayload : HashInput) : + tweakableHashInput parameter (.ftsNode index tree level nodeIdx) payload ≠ + tweakableHashInput parameter (.chain lay otsTree leafIdx chainIdx step) chainPayload := by + intro hinput + simp only [tweakableHashInput] at hinput + obtain ⟨hprefix, _⟩ := List.append_inj hinput + (by simp [tweakBytes_length, bytesLE_length]) + obtain ⟨htweak, _⟩ := List.append_inj' hprefix (by simp [bytesLE_length]) + rw [tweakBytes_eq_iff] at htweak + simp [hashDomainFields, TweakFields.mk.injEq] at htweak + +theorem tweakableHashInput_ftsNode_ne_leaf + (parameter : PublicParameter) (index : Index) (tree : FtsTree) + (level nodeIdx : Nat) (payload : HashInput) (lay : Layer) (otsTree : TreeIndex) + (leafIdx : LeafIndex) (leafPayload : HashInput) : + tweakableHashInput parameter (.ftsNode index tree level nodeIdx) payload ≠ + tweakableHashInput parameter (.leaf lay otsTree leafIdx) leafPayload := by + intro hinput + simp only [tweakableHashInput] at hinput + obtain ⟨hprefix, _⟩ := List.append_inj hinput + (by simp [tweakBytes_length, bytesLE_length]) + obtain ⟨htweak, _⟩ := List.append_inj' hprefix (by simp [bytesLE_length]) + rw [tweakBytes_eq_iff] at htweak + simp [hashDomainFields, TweakFields.mk.injEq] at htweak + +theorem decodeProbe?_tweakableHashInput_ftsNode + (parameter : PublicParameter) (index : Index) (tree : FtsTree) + (level nodeIdx : Nat) (payload : HashInput) : + decodeProbe? parameter + (tweakableHashInput parameter (.ftsNode index tree level nodeIdx) payload) = none := by + rw [decodeProbe?_eq_none_iff] + rintro ⟨coordinate, candidate⟩ hmatches + cases coordinate with + | chainStart lay otsTree leafIdx chainIdx => + obtain ⟨step, hstep, hinput⟩ := hmatches + exact tweakableHashInput_ftsNode_ne_chain parameter index tree level nodeIdx payload lay + otsTree leafIdx chainIdx step _ hinput + | position position => + cases position with + | chain lay otsTree leafIdx chainIdx step => + simp only [Probe.MatchesInput] at hmatches + split at hmatches + · obtain ⟨nextStep, hnext, hinput⟩ := hmatches + exact tweakableHashInput_ftsNode_ne_chain parameter index tree level nodeIdx payload + lay otsTree leafIdx chainIdx nextStep _ hinput + · obtain ⟨hchainZero, candidatePayload, hinput, hslot⟩ := hmatches + exact tweakableHashInput_ftsNode_ne_leaf parameter index tree level nodeIdx payload lay + otsTree leafIdx candidatePayload hinput + | leaf => simp [Probe.MatchesInput] at hmatches + | node => simp [Probe.MatchesInput] at hmatches + | ftsLeaf => simp [Probe.MatchesInput] at hmatches + | ftsNode => simp [Probe.MatchesInput] at hmatches + | ftsRoots => simp [Probe.MatchesInput] at hmatches + +theorem ChainProbeAccounted.ensure + {parameter : PublicParameter} {allowed : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (haccounted : ChainProbeAccounted parameter allowed state cache) + (coordinate : Coordinate) : + ChainProbeAccounted parameter allowed (state.ensure coordinate) cache := by + change ChainProbeAccounted parameter allowed state cache + exact haccounted + +theorem ChainProbeAccounted.addPending + {parameter : PublicParameter} {allowed : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (haccounted : ChainProbeAccounted parameter allowed state cache) + (coordinate : Coordinate) (candidate : Digest) : + ChainProbeAccounted parameter allowed (state.addPending coordinate candidate) cache := by + intro probe input hmatches hcached hnotAllowed + have hpending := haccounted probe input hmatches hcached hnotAllowed + simp [LazyRevealProbe.State.pendingAt] at hpending + simp [LazyRevealProbe.State.pendingAt, LazyRevealProbe.State.addPending] + exact Or.inr hpending + +theorem ChainProbeAccounted.publish + {parameter : PublicParameter} {allowed : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (haccounted : ChainProbeAccounted parameter allowed state cache) + (coordinate : Coordinate) : + ChainProbeAccounted parameter allowed (state.publish coordinate) cache := by + change ChainProbeAccounted parameter allowed state cache + exact haccounted + +theorem ChainProbeAccounted.updateHidden + {parameter : PublicParameter} {allowed : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (haccounted : ChainProbeAccounted parameter allowed state cache) + (coordinate : Coordinate) (output : HashOutput) : + ChainProbeAccounted parameter allowed state + (Function.update cache (.hidden coordinate) (some output)) := by + intro probe input hmatches hcached hnotAllowed + simp [Function.update] at hcached + exact haccounted probe input hmatches hcached hnotAllowed + +theorem ChainProbeAccounted.materialize + {parameter : PublicParameter} {allowed : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (haccounted : ChainProbeAccounted parameter allowed state cache) + (coordinate : Coordinate) (output : HashOutput) + (hallowed : IsChainCoordinate coordinate → allowed coordinate) : + ChainProbeAccounted parameter allowed (state.materialize coordinate output) cache := by + intro probe input hmatches hcached hnotAllowed + have hpending := haccounted probe input hmatches hcached hnotAllowed + have hne : probe.coordinate ≠ coordinate := by + intro heq + rw [heq] at hnotAllowed + exact hnotAllowed (hallowed (heq ▸ probe.isChainCoordinate_of_matchesInput hmatches)) + simpa [LazyRevealProbe.State.pendingAt, LazyRevealProbe.State.materialize, + LazyRevealProbe.State.pendingAway, hne] using hpending + +theorem ChainProbeAccounted.materialize_publish + {parameter : PublicParameter} {allowed : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (haccounted : ChainProbeAccounted parameter allowed state cache) + (coordinate : Coordinate) (output : HashOutput) + (hallowed : IsChainCoordinate coordinate → allowed coordinate) : + ChainProbeAccounted parameter allowed + ((state.materialize coordinate output).publish coordinate) cache := by + intro probe input hmatches hcached hnotAllowed + have hpending := haccounted probe input hmatches hcached hnotAllowed + have hne : probe.coordinate ≠ coordinate := by + intro heq + rw [heq] at hnotAllowed + exact hnotAllowed (hallowed (heq ▸ probe.isChainCoordinate_of_matchesInput hmatches)) + simpa [LazyRevealProbe.State.pendingAt, LazyRevealProbe.State.materialize, + LazyRevealProbe.State.publish, LazyRevealProbe.State.pendingAway, hne] using hpending + +theorem secured_materialize_publish + {allowed : Coordinate → Prop} {state : LazyRevealProbe.State Coordinate} + (candidate : Probe) (coordinate : Coordinate) (output : HashOutput) + (hsourceChain : IsChainCoordinate candidate.coordinate) + (hallowed : IsChainCoordinate coordinate → allowed coordinate) + (hsecured : allowed candidate.coordinate ∨ + candidate.candidate ∈ state.pendingAt candidate.coordinate) : + allowed candidate.coordinate ∨ candidate.candidate ∈ + ((state.materialize coordinate output).publish coordinate).pendingAt candidate.coordinate := by + rcases hsecured with hcovered | hpending + · exact Or.inl hcovered + · by_cases heq : candidate.coordinate = coordinate + · exact Or.inl (heq ▸ hallowed (heq ▸ hsourceChain)) + · right + simpa [LazyRevealProbe.State.pendingAt, LazyRevealProbe.State.materialize, + LazyRevealProbe.State.publish, LazyRevealProbe.State.pendingAway, heq] using hpending + +theorem ChainProbeAccounted.updateOrdinary_of_decode_none + {parameter : PublicParameter} {allowed : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (haccounted : ChainProbeAccounted parameter allowed state cache) + (input : HashInput) (output : HashOutput) (hdecode : decodeProbe? parameter input = none) : + ChainProbeAccounted parameter allowed state + (Function.update cache (.ordinary input) (some output)) := by + intro probe other hmatches hcached hnotAllowed + by_cases heq : other = input + · subst other + exact ((decodeProbe?_eq_none_iff parameter input).1 hdecode probe hmatches).elim + · simp [Function.update, heq] at hcached + exact haccounted probe other hmatches hcached hnotAllowed + +theorem ChainProbeAccounted.addDecodedPending_updateOrdinary + {parameter : PublicParameter} {allowed : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (haccounted : ChainProbeAccounted parameter allowed state cache) + (candidate : Probe) (input : HashInput) (output : HashOutput) + (hdecode : decodeProbe? parameter input = some candidate) : + ChainProbeAccounted parameter allowed + (state.addPending candidate.coordinate candidate.candidate) + (Function.update cache (.ordinary input) (some output)) := by + intro probe other hmatches hcached hnotAllowed + by_cases heq : other = input + · subst other + have hcandidateMatches := (decodeProbe?_eq_some_iff parameter input candidate).1 hdecode + have hprobe : probe = candidate := + Probe.matchesInput_unique parameter input hmatches hcandidateMatches + subst probe + exact LazyRevealProbe.State.pendingAt_addPending_self state candidate.coordinate + candidate.candidate + · simp [Function.update, heq] at hcached + exact haccounted.addPending candidate.coordinate candidate.candidate probe other hmatches + hcached hnotAllowed + +theorem ChainProbeAccounted.updateOrdinary_of_decoded_allowed + {parameter : PublicParameter} {allowed : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (haccounted : ChainProbeAccounted parameter allowed state cache) + (candidate : Probe) (input : HashInput) (output : HashOutput) + (hdecode : decodeProbe? parameter input = some candidate) + (hallowed : allowed candidate.coordinate) : + ChainProbeAccounted parameter allowed state + (Function.update cache (.ordinary input) (some output)) := by + intro probe other hmatches hcached hnotAllowed + by_cases heq : other = input + · subst other + have hcandidateMatches := (decodeProbe?_eq_some_iff parameter input candidate).1 hdecode + have hprobe : probe = candidate := + Probe.matchesInput_unique parameter input hmatches hcandidateMatches + subst probe + exact (hnotAllowed hallowed).elim + · simp [Function.update, heq] at hcached + exact haccounted probe other hmatches hcached hnotAllowed + +theorem ChainProbeAccounted.updateOrdinary_of_decoded_secured + {parameter : PublicParameter} {allowed : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (haccounted : ChainProbeAccounted parameter allowed state cache) + (candidate : Probe) (input : HashInput) (output : HashOutput) + (hdecode : decodeProbe? parameter input = some candidate) + (hsecured : allowed candidate.coordinate ∨ + candidate.candidate ∈ state.pendingAt candidate.coordinate) : + ChainProbeAccounted parameter allowed state + (Function.update cache (.ordinary input) (some output)) := by + rcases hsecured with hallowed | hpending + · exact haccounted.updateOrdinary_of_decoded_allowed candidate input output hdecode hallowed + · intro probe other hmatches hcached hnotAllowed + by_cases heq : other = input + · subst other + have hcandidateMatches := (decodeProbe?_eq_some_iff parameter input candidate).1 hdecode + have hprobe : probe = candidate := + Probe.matchesInput_unique parameter input hmatches hcandidateMatches + subst probe + exact hpending + · simp [Function.update, heq] at hcached + exact haccounted probe other hmatches hcached hnotAllowed + +def ChainInvariant (parameter : PublicParameter) (allowed : Coordinate → Prop) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) : Prop := + ChainState.ValidFor allowed state ∧ ChainProbeAccounted parameter allowed state cache + +theorem ChainState.ValidFor.mono + {initial final : Coordinate → Prop} {state : LazyRevealProbe.State Coordinate} + (hvalid : ChainState.ValidFor initial state) + (hle : ∀ coordinate, initial coordinate → final coordinate) : + ChainState.ValidFor final state := by + intro coordinate hchain + have hcoordinate := hvalid coordinate hchain + exact ⟨hcoordinate.1, hcoordinate.2.1, + fun hrevealed => hle coordinate (hcoordinate.2.2 hrevealed)⟩ + +theorem ChainProbeAccounted.mono + {parameter : PublicParameter} {initial final : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (haccounted : ChainProbeAccounted parameter initial state cache) + (hle : ∀ coordinate, initial coordinate → final coordinate) : + ChainProbeAccounted parameter final state cache := by + intro probe input hmatches hcached hnotAllowed + exact haccounted probe input hmatches hcached + (fun hinitial => hnotAllowed (hle probe.coordinate hinitial)) + +theorem ChainInvariant.mono + {parameter : PublicParameter} {initial final : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (hinvariant : ChainInvariant parameter initial state cache) + (hle : ∀ coordinate, initial coordinate → final coordinate) : + ChainInvariant parameter final state cache := + ⟨hinvariant.1.mono hle, hinvariant.2.mono hle⟩ + +def PreservesChainInvariant (parameter : PublicParameter) (allowed : Coordinate → Prop) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ state cache fuel finalState remaining value finalCache, + ChainInvariant parameter allowed state cache → + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + ChainInvariant parameter allowed finalState finalCache + +theorem PreservesChainInvariant.bind + {parameter : PublicParameter} {allowed : Coordinate → Prop} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : PreservesChainInvariant parameter allowed left) + (hnext : ∀ value, PreservesChainInvariant parameter allowed (next value)) : + PreservesChainInvariant parameter allowed (left >>= next) := by + intro state cache fuel finalState remaining result finalCache hinvariant hresult + change LazyRevealProbe.RawResult.done finalState remaining (result, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun leftResult => (next leftResult.1).run leftResult.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining leftResult => + rcases leftResult with ⟨leftValue, middleCache⟩ + exact hnext leftValue middleState middleCache middleRemaining finalState remaining result + finalCache (hleft state cache fuel middleState middleRemaining leftValue middleCache + hinvariant hraw) hrest + +theorem preservesChainInvariant_pure + (parameter : PublicParameter) (allowed : Coordinate → Prop) (value : alpha) : + PreservesChainInvariant parameter allowed + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro state cache fuel finalState remaining result finalCache hinvariant hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hinvariant + +theorem preservesChainInvariant_probe + (parameter : PublicParameter) (allowed : Coordinate → Prop) (candidate : Probe) : + PreservesChainInvariant parameter allowed (probe candidate) := by + intro state cache fuel finalState remaining value finalCache hinvariant hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate >>= fun output => + pure (output, cache))) at hresult + rw [LazyRevealProbe.probeQuery, LazyRevealProbe.runRaw_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remainingFuel => + simp only at hresult + by_cases hrevealed : candidate.coordinate ∈ state.revealed + · rw [if_pos hrevealed] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hinvariant + · rw [if_neg hrevealed] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + refine ⟨?_, hinvariant.2.addPending candidate.coordinate candidate.candidate⟩ + simpa [ChainState.ValidFor, LazyRevealProbe.State.addPending] using hinvariant.1 + +theorem preservesChainInvariant_ensureCoordinate + (parameter : PublicParameter) (allowed : Coordinate → Prop) (coordinate : Coordinate) : + PreservesChainInvariant parameter allowed (ensureCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hinvariant hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.ensureQuery coordinate >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.ensureQuery, LazyRevealProbe.runRaw_ensure_query_bind] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + refine ⟨?_, hinvariant.2.ensure coordinate⟩ + simpa [ChainState.ValidFor, LazyRevealProbe.State.ensure] using hinvariant.1 + +theorem preservesChainInvariant_peekCoordinate + (parameter : PublicParameter) (allowed : Coordinate → Prop) (coordinate : Coordinate) : + PreservesChainInvariant parameter allowed (peekCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hinvariant hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.peekQuery coordinate >>= fun output => + pure (truncateHash <$> output, cache))) at hresult + rw [LazyRevealProbe.peekQuery, LazyRevealProbe.runRaw_peek_query_bind] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hinvariant + +theorem preservesChainInvariant_peekPositionValues + (parameter : PublicParameter) (allowed : Coordinate → Prop) (positions : List Position) : + PreservesChainInvariant parameter allowed (peekPositionValues positions) := by + induction positions with + | nil => exact preservesChainInvariant_pure parameter allowed (some []) + | cons position remaining ih => + rw [peekPositionValues] + exact (preservesChainInvariant_peekCoordinate parameter allowed (.position position)).bind + fun value => match value with + | none => preservesChainInvariant_pure parameter allowed none + | some _ => ih.bind fun values => + match values with + | none => preservesChainInvariant_pure parameter allowed none + | some _ => preservesChainInvariant_pure parameter allowed _ + +theorem preservesChainInvariant_peekTableInput + (parameter : PublicParameter) (allowed : Coordinate → Prop) (coordinate : Coordinate) : + PreservesChainInvariant parameter allowed (peekTableInput parameter coordinate) := by + cases coordinate with + | chainStart => exact preservesChainInvariant_pure parameter allowed none + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput] + by_cases hzero : step.val = 0 + · rw [if_pos hzero] + exact (preservesChainInvariant_peekCoordinate parameter allowed + (.chainStart lay tree leafIdx chainIdx)).bind fun value => + match value with + | none => preservesChainInvariant_pure parameter allowed none + | some _ => preservesChainInvariant_pure parameter allowed _ + · rw [if_neg hzero] + exact (preservesChainInvariant_peekPositionValues parameter allowed + (Position.chain lay tree leafIdx chainIdx step).children).bind fun values => + match values with + | none => preservesChainInvariant_pure parameter allowed none + | some _ => preservesChainInvariant_pure parameter allowed _ + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp only [peekTableInput] + exact (preservesChainInvariant_peekPositionValues parameter allowed _).bind fun values => + match values with + | none => preservesChainInvariant_pure parameter allowed none + | some _ => preservesChainInvariant_pure parameter allowed _ + +def RawReadOnly + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ state cache fuel finalState remaining value finalCache, + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + finalState = state ∧ remaining = fuel ∧ finalCache = cache + +theorem RawReadOnly.pure (value : alpha) : + RawReadOnly + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro state cache fuel finalState remaining result finalCache hresult + simp [LazyRevealProbe.runRaw] at hresult + exact ⟨hresult.1, hresult.2.1, hresult.2.2.2⟩ + +theorem RawReadOnly.bind + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : RawReadOnly left) (hnext : ∀ value, RawReadOnly (next value)) : + RawReadOnly (left >>= next) := by + intro state cache fuel finalState remaining result finalCache hresult + change LazyRevealProbe.RawResult.done finalState remaining (result, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun leftResult => (next leftResult.1).run leftResult.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining leftResult => + rcases leftResult with ⟨leftValue, middleCache⟩ + obtain ⟨hfinalState, hremaining, hfinalCache⟩ := hnext leftValue middleState + middleCache middleRemaining finalState remaining result finalCache hrest + obtain ⟨hmiddleState, hmiddleRemaining, hmiddleCache⟩ := hleft state cache fuel + middleState middleRemaining leftValue middleCache hraw + exact ⟨hfinalState.trans hmiddleState, hremaining.trans hmiddleRemaining, + hfinalCache.trans hmiddleCache⟩ + +theorem RawReadOnly.entryPreserving + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + (hreadonly : RawReadOnly computation) (input : HashInput) : + OrdinaryEntryPreserving input computation := by + intro state cache fuel finalState remaining value finalCache output hcached hresult + rw [hreadonly state cache fuel finalState remaining value finalCache hresult |>.2.2] + exact hcached + +theorem RawReadOnly.splitCachePreserving + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + (hreadonly : RawReadOnly computation) : + SplitCachePreserving computation := by + intro state cache fuel finalState remaining value finalCache hresult + exact hreadonly state cache fuel finalState remaining value finalCache hresult |>.2.2 + +theorem rawReadOnly_peekCoordinate (coordinate : Coordinate) : + RawReadOnly (peekCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.peekQuery coordinate >>= fun output => + pure (truncateHash <$> output, cache))) at hresult + rw [LazyRevealProbe.peekQuery, LazyRevealProbe.runRaw_peek_query_bind] at hresult + simp [LazyRevealProbe.runRaw] at hresult + exact ⟨hresult.1, hresult.2.1, hresult.2.2.2⟩ + +theorem rawReadOnly_peekPositionValues (positions : List Position) : + RawReadOnly (peekPositionValues positions) := by + induction positions with + | nil => exact RawReadOnly.pure (some []) + | cons position remaining ih => + rw [peekPositionValues] + exact (rawReadOnly_peekCoordinate (.position position)).bind fun value => + match value with + | none => RawReadOnly.pure none + | some _ => ih.bind fun values => + match values with + | none => RawReadOnly.pure none + | some _ => RawReadOnly.pure _ + +theorem rawReadOnly_peekTableInput (parameter : PublicParameter) (coordinate : Coordinate) : + RawReadOnly (peekTableInput parameter coordinate) := by + cases coordinate with + | chainStart => exact RawReadOnly.pure none + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput] + by_cases hzero : step.val = 0 + · rw [if_pos hzero] + exact (rawReadOnly_peekCoordinate (.chainStart lay tree leafIdx chainIdx)).bind + fun value => match value with + | none => RawReadOnly.pure none + | some _ => RawReadOnly.pure _ + · rw [if_neg hzero] + exact (rawReadOnly_peekPositionValues + (Position.chain lay tree leafIdx chainIdx step).children).bind fun values => + match values with + | none => RawReadOnly.pure none + | some _ => RawReadOnly.pure _ + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp only [peekTableInput] + exact (rawReadOnly_peekPositionValues _).bind fun values => + match values with + | none => RawReadOnly.pure none + | some _ => RawReadOnly.pure _ + +theorem ordinaryEntryPreserving_revealCoordinateOutput + (input : HashInput) (coordinate : Coordinate) : + OrdinaryEntryPreserving input (revealCoordinateOutput coordinate) := by + intro state cache fuel finalState remaining value finalCache output hcached hresult + rw [revealCoordinateOutput_run, LazyRevealProbe.revealQuery, + LazyRevealProbe.runRaw_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some existing => + rw [hvalue] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + simpa [Function.update] using hcached + | none => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨sampled, _, hsampled⟩ := hresult + by_cases hhit : state.hitAt coordinate sampled + · rw [if_pos hhit] at hsampled + simp at hsampled + · rw [if_neg hhit] at hsampled + simp [LazyRevealProbe.runRaw] at hsampled + rcases hsampled with ⟨rfl, rfl, rfl, rfl⟩ + simpa [Function.update] using hcached + +theorem ordinaryEntryPreserving_revealCoordinate + (input : HashInput) (coordinate : Coordinate) : + OrdinaryEntryPreserving input (revealCoordinate coordinate) := by + unfold revealCoordinate + exact (ordinaryEntryPreserving_revealCoordinateOutput input coordinate).bind fun output => + OrdinaryEntryPreserving.pure input (truncateHash output) + +theorem ordinaryEntryPreserving_modifyOrdinary_of_ne + (input other : HashInput) (answer : HashOutput) (hne : input ≠ other) : + OrdinaryEntryPreserving input + (modify fun cache : SplitHashCache => + Function.update cache (.ordinary other) (some answer)) := by + intro state cache fuel finalState remaining value finalCache output hcached hresult + simp [StateT.run_modify, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + simpa [Function.update, hne] using hcached + +theorem cachesOrdinaryInput_modifyOrdinary + (input : HashInput) (answer : HashOutput) : + CachesOrdinaryInput input + (modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some answer)) := by + intro state cache fuel finalState remaining value finalCache hresult + simp [StateT.run_modify, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + simp [Function.update] + +theorem returnsCachedOrdinary_modify_pure + (input : HashInput) (answer : HashOutput) : + ReturnsCachedOrdinary input (do + modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some answer) + pure answer) := by + intro state cache fuel finalState remaining output finalCache hresult + simp [StateT.run_modify, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + simp [Function.update] + +theorem ordinaryEntryPreserving_probe (input : HashInput) (candidate : Probe) : + OrdinaryEntryPreserving input (probe candidate) := by + intro state cache fuel finalState remaining value finalCache output hcached hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate >>= fun result => + pure (result, cache))) at hresult + rw [LazyRevealProbe.probeQuery, LazyRevealProbe.runRaw_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remainingFuel => + rw [show remainingFuel + 1 = Nat.succ remainingFuel by omega] at hresult + simp only at hresult + by_cases hrevealed : candidate.coordinate ∈ state.revealed + · rw [if_pos hrevealed] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hcached + · rw [if_neg hrevealed] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hcached + +theorem splitCachePreserving_probe (candidate : Probe) : + SplitCachePreserving (probe candidate) := by + intro state cache fuel finalState remaining value finalCache hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate >>= fun result => + pure (result, cache))) at hresult + rw [LazyRevealProbe.probeQuery, LazyRevealProbe.runRaw_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remainingFuel => + rw [show remainingFuel + 1 = Nat.succ remainingFuel by omega] at hresult + simp only at hresult + by_cases hrevealed : candidate.coordinate ∈ state.revealed + · rw [if_pos hrevealed] at hresult + simp [LazyRevealProbe.runRaw] at hresult + exact hresult.2.2 + · rw [if_neg hrevealed] at hresult + simp [LazyRevealProbe.runRaw] at hresult + exact hresult.2.2 + +theorem splitCachePreserving_probeFirstMissingInputCoordinate (input : HashInput) : + ∀ (slot : Nat) (coordinates : List Coordinate), + SplitCachePreserving (probeFirstMissingInputCoordinate input slot coordinates) + | _, [] => SplitCachePreserving.pure () + | slot, coordinate :: remaining => by + rw [probeFirstMissingInputCoordinate] + exact (rawReadOnly_peekCoordinate coordinate).splitCachePreserving.bind fun value => + match value with + | none => splitCachePreserving_probe ⟨coordinate, slotDigest slot input⟩ + | some _ => splitCachePreserving_probeFirstMissingInputCoordinate input (slot + 1) remaining + +theorem splitCachePreserving_prepareLeafInputProbe + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + SplitCachePreserving (prepareLeafInputProbe input candidate lay tree leafIdx) := by + unfold prepareLeafInputProbe + apply (rawReadOnly_peekCoordinate candidate.coordinate).splitCachePreserving.bind + intro value + cases value with + | none => + simp only + exact splitCachePreserving_probe candidate + | some output => + simp only + exact splitCachePreserving_probeFirstMissingInputCoordinate input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + +theorem ordinaryEntryPreserving_publishCoordinate + (input : HashInput) (coordinate : Coordinate) : + OrdinaryEntryPreserving input (publishCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache output hcached hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.publishQuery coordinate >>= fun result => pure (result, cache))) at hresult + rw [LazyRevealProbe.publishQuery, LazyRevealProbe.runRaw_publish_query_bind] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hcached + +theorem ordinaryEntryPreserving_revealPositionValues + (input : HashInput) (positions : List Position) : + OrdinaryEntryPreserving input (revealPositionValues positions) := by + induction positions with + | nil => exact OrdinaryEntryPreserving.pure input [] + | cons position remaining ih => + rw [revealPositionValues] + exact (ordinaryEntryPreserving_revealCoordinate input (.position position)).bind + fun value => ih.bind fun values => OrdinaryEntryPreserving.pure input (value :: values) + +theorem ordinaryEntryPreserving_revealTableInputChildren + (input : HashInput) (coordinate : Coordinate) : + OrdinaryEntryPreserving input (revealTableInputChildren coordinate) := by + cases coordinate with + | chainStart => exact OrdinaryEntryPreserving.pure input () + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + by_cases hzero : step.val = 0 + · simp only [revealTableInputChildren, hzero, ↓reduceIte] + exact (ordinaryEntryPreserving_revealCoordinate input + (.chainStart lay tree leafIdx chainIdx)).bind fun _ => + OrdinaryEntryPreserving.pure input () + · simp only [revealTableInputChildren, hzero, ↓reduceIte] + exact (ordinaryEntryPreserving_revealPositionValues input _).bind fun _ => + OrdinaryEntryPreserving.pure input () + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp only [revealTableInputChildren] + exact (ordinaryEntryPreserving_revealPositionValues input _).bind fun _ => + OrdinaryEntryPreserving.pure input () + +theorem ordinaryEntryPreserving_resolveKnownInput_of_ne + (parameter : PublicParameter) (input query : HashInput) (coordinate : Coordinate) + (hne : input ≠ query) : + OrdinaryEntryPreserving input (resolveKnownInput parameter coordinate query) := by + unfold resolveKnownInput + exact (rawReadOnly_peekTableInput parameter coordinate).entryPreserving input |>.bind + fun knownInput => match knownInput with + | none => (ordinaryCacheIncreasing_splitHashQuery_ordinary query).entryPreserving input + | some knownInput => by + simp only + by_cases hexact : knownInput = query + · rw [if_pos hexact] + exact (ordinaryEntryPreserving_revealCoordinateOutput input coordinate).bind fun answer => + (ordinaryEntryPreserving_publishCoordinate input coordinate).bind + fun _ => (ordinaryEntryPreserving_modifyOrdinary_of_ne input query answer hne).bind + fun _ => OrdinaryEntryPreserving.pure input answer + · rw [if_neg hexact] + exact (ordinaryCacheIncreasing_splitHashQuery_ordinary query).entryPreserving input + +theorem ordinaryEntryPreserving_resolveVerifierInput + (parameter : PublicParameter) (input query : HashInput) (coordinate : Coordinate) : + OrdinaryEntryPreserving input (resolveVerifierInput parameter coordinate query) := by + intro state cache fuel finalState remaining value finalCache output hcached hresult + unfold resolveVerifierInput at hresult + by_cases heq : input = query + · subst query + simp [StateT.run_get, hcached, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hcached + · cases hquery : cache (.ordinary query) with + | some cached => + simp [StateT.run_get, hquery, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hcached + | none => + simp [hquery] at hresult + exact ((ordinaryEntryPreserving_revealTableInputChildren input coordinate).bind fun _ => + ordinaryEntryPreserving_resolveKnownInput_of_ne parameter input query coordinate heq) + state cache fuel finalState remaining value finalCache output hcached hresult + +theorem ordinaryEntryPreserving_verifierHashQuery + (parameter : PublicParameter) (input query : HashInput) : + OrdinaryEntryPreserving input (verifierHashQuery parameter query) := by + unfold verifierHashQuery + cases hprobe : decodeProbe? parameter query with + | some candidate => + exact (ordinaryEntryPreserving_probe input candidate).bind fun _ => + ordinaryEntryPreserving_resolveVerifierInput parameter input query + candidate.outputCoordinate + | none => + cases hposition : decodePosition? parameter query with + | none => exact (ordinaryCacheIncreasing_splitHashQuery_ordinary query).entryPreserving input + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + exact ordinaryEntryPreserving_resolveVerifierInput parameter input query + (.position (.chain lay tree leafIdx chainIdx step)) + | leaf lay tree leafIdx => + exact ordinaryEntryPreserving_resolveVerifierInput parameter input query + (.position (.leaf lay tree leafIdx)) + | node lay tree level nodeIdx => + exact ordinaryEntryPreserving_resolveVerifierInput parameter input query + (.position (.node lay tree level nodeIdx)) + | ftsLeaf | ftsNode | ftsRoots => + exact (ordinaryCacheIncreasing_splitHashQuery_ordinary query).entryPreserving input + +theorem cachesOrdinaryInput_resolveKnownInput + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) : + CachesOrdinaryInput input (resolveKnownInput parameter coordinate input) := by + unfold resolveKnownInput + apply CachesOrdinaryInput.bind_right + intro knownInput + cases knownInput with + | none => exact cachesOrdinaryInput_splitHashQuery input + | some knownInput => + simp only + by_cases hexact : knownInput = input + · rw [if_pos hexact] + apply CachesOrdinaryInput.bind_right + intro answer + apply CachesOrdinaryInput.bind_right + intro _ + exact (cachesOrdinaryInput_modifyOrdinary input answer).bind_preserving fun _ => + OrdinaryEntryPreserving.pure input answer + · rw [if_neg hexact] + exact cachesOrdinaryInput_splitHashQuery input + +theorem returnsCachedOrdinary_resolveKnownInput + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) : + ReturnsCachedOrdinary input (resolveKnownInput parameter coordinate input) := by + unfold resolveKnownInput + apply ReturnsCachedOrdinary.bind_right + intro knownInput + cases knownInput with + | none => exact returnsCachedOrdinary_splitHashQuery input + | some knownInput => + simp only + by_cases hexact : knownInput = input + · rw [if_pos hexact] + apply ReturnsCachedOrdinary.bind_right + intro answer + apply ReturnsCachedOrdinary.bind_right + intro _ + exact returnsCachedOrdinary_modify_pure input answer + · rw [if_neg hexact] + exact returnsCachedOrdinary_splitHashQuery input + +theorem returnsCachedOrdinary_resolveVerifierInput + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) : + ReturnsCachedOrdinary input (resolveVerifierInput parameter coordinate input) := by + intro state cache fuel finalState remaining output finalCache hresult + unfold resolveVerifierInput at hresult + cases hcached : cache (.ordinary input) with + | some cached => + simp [StateT.run_get, hcached, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hcached + | none => + simp [hcached] at hresult + exact (ReturnsCachedOrdinary.bind_right fun _ => + returnsCachedOrdinary_resolveKnownInput parameter coordinate input) + state cache fuel finalState remaining output finalCache hresult + +theorem returnsCachedOrdinary_verifierHashQuery + (parameter : PublicParameter) (input : HashInput) : + ReturnsCachedOrdinary input (verifierHashQuery parameter input) := by + unfold verifierHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + exact ReturnsCachedOrdinary.bind_right fun _ => + returnsCachedOrdinary_resolveVerifierInput parameter candidate.outputCoordinate input + | none => + cases hposition : decodePosition? parameter input with + | none => exact returnsCachedOrdinary_splitHashQuery input + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + exact returnsCachedOrdinary_resolveVerifierInput parameter + (.position (.chain lay tree leafIdx chainIdx step)) input + | leaf lay tree leafIdx => + exact returnsCachedOrdinary_resolveVerifierInput parameter + (.position (.leaf lay tree leafIdx)) input + | node lay tree level nodeIdx => + exact returnsCachedOrdinary_resolveVerifierInput parameter + (.position (.node lay tree level nodeIdx)) input + | ftsLeaf | ftsNode | ftsRoots => exact returnsCachedOrdinary_splitHashQuery input + +theorem cachesOrdinaryInput_probingHashQuery + (parameter : PublicParameter) (input : HashInput) : + CachesOrdinaryInput input (probingHashQuery parameter input) := by + unfold probingHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases decodePosition? parameter input with + | some position => + cases position with + | leaf => exact CachesOrdinaryInput.bind_right fun _ => + cachesOrdinaryInput_resolveKnownInput parameter candidate.outputCoordinate input + | chain | node | ftsLeaf | ftsNode | ftsRoots => + exact CachesOrdinaryInput.bind_right fun _ => + cachesOrdinaryInput_resolveKnownInput parameter candidate.outputCoordinate input + | none => exact CachesOrdinaryInput.bind_right fun _ => + cachesOrdinaryInput_resolveKnownInput parameter candidate.outputCoordinate input + | none => + cases hposition : decodePosition? parameter input with + | none => exact cachesOrdinaryInput_splitHashQuery input + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + exact cachesOrdinaryInput_resolveKnownInput parameter + (.position (.chain lay tree leafIdx chainIdx step)) input + | leaf lay tree leafIdx => + exact cachesOrdinaryInput_resolveKnownInput parameter + (.position (.leaf lay tree leafIdx)) input + | node lay tree level nodeIdx => + exact CachesOrdinaryInput.bind_right fun _ => + cachesOrdinaryInput_resolveKnownInput parameter + (.position (.node lay tree level nodeIdx)) input + | ftsLeaf | ftsNode | ftsRoots => exact cachesOrdinaryInput_splitHashQuery input + +theorem returnsCachedOrdinary_probingHashQuery + (parameter : PublicParameter) (input : HashInput) : + ReturnsCachedOrdinary input (probingHashQuery parameter input) := by + unfold probingHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases decodePosition? parameter input with + | some position => + cases position with + | leaf => exact ReturnsCachedOrdinary.bind_right fun _ => + returnsCachedOrdinary_resolveKnownInput parameter candidate.outputCoordinate input + | chain | node | ftsLeaf | ftsNode | ftsRoots => + exact ReturnsCachedOrdinary.bind_right fun _ => + returnsCachedOrdinary_resolveKnownInput parameter candidate.outputCoordinate input + | none => exact ReturnsCachedOrdinary.bind_right fun _ => + returnsCachedOrdinary_resolveKnownInput parameter candidate.outputCoordinate input + | none => + cases hposition : decodePosition? parameter input with + | none => exact returnsCachedOrdinary_splitHashQuery input + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + exact returnsCachedOrdinary_resolveKnownInput parameter + (.position (.chain lay tree leafIdx chainIdx step)) input + | leaf lay tree leafIdx => + exact returnsCachedOrdinary_resolveKnownInput parameter + (.position (.leaf lay tree leafIdx)) input + | node lay tree level nodeIdx => + exact ReturnsCachedOrdinary.bind_right fun _ => + returnsCachedOrdinary_resolveKnownInput parameter + (.position (.node lay tree level nodeIdx)) input + | ftsLeaf | ftsNode | ftsRoots => exact returnsCachedOrdinary_splitHashQuery input + +theorem returnsCachedOrdinary_probingHashImpl + (parameter : PublicParameter) (input : HashInput) : + ReturnsCachedOrdinary input (probingHashImpl parameter input) := + returnsCachedOrdinary_probingHashQuery parameter input + +theorem ordinaryEntryPreserving_probingHashQuery_self + (parameter : PublicParameter) (input : HashInput) + (hstable : StableOrdinaryInput parameter input) : + OrdinaryEntryPreserving input (probingHashQuery parameter input) := by + unfold probingHashQuery + rw [hstable.1] + cases hposition : decodePosition? parameter input with + | none => exact (ordinaryCacheIncreasing_splitHashQuery_ordinary input).entryPreserving input + | some position => + cases position with + | chain | leaf | node => exact (hstable.2 _ hposition (by trivial)).elim + | ftsLeaf | ftsNode | ftsRoots => + exact (ordinaryCacheIncreasing_splitHashQuery_ordinary input).entryPreserving input + +theorem ordinaryEntryPreserving_probingHashQuery_of_ne + (parameter : PublicParameter) (input query : HashInput) (hne : input ≠ query) : + OrdinaryEntryPreserving input (probingHashQuery parameter query) := by + unfold probingHashQuery + cases hprobe : decodeProbe? parameter query with + | some candidate => + cases decodePosition? parameter query with + | some position => + cases position with + | leaf lay tree leafIdx => + exact ((splitCachePreserving_prepareLeafInputProbe query candidate lay tree leafIdx) + |>.entryPreserving input).bind (fun _ => + ordinaryEntryPreserving_resolveKnownInput_of_ne parameter input query + candidate.outputCoordinate hne) + | chain | node | ftsLeaf | ftsNode | ftsRoots => + exact (ordinaryEntryPreserving_probe input candidate).bind (fun _ => + ordinaryEntryPreserving_resolveKnownInput_of_ne parameter input query + candidate.outputCoordinate hne) + | none => exact (ordinaryEntryPreserving_probe input candidate).bind (fun _ => + ordinaryEntryPreserving_resolveKnownInput_of_ne parameter input query + candidate.outputCoordinate hne) + | none => + cases hposition : decodePosition? parameter query with + | none => + exact (ordinaryCacheIncreasing_splitHashQuery_ordinary query).entryPreserving input + | some position => + cases position with + | chain | leaf => + exact ordinaryEntryPreserving_resolveKnownInput_of_ne parameter input query _ hne + | node lay tree level nodeIdx => + exact (splitCachePreserving_probeFirstMissingInputCoordinate query 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)).entryPreserving input |>.bind + fun _ => ordinaryEntryPreserving_resolveKnownInput_of_ne parameter input query _ hne + | ftsLeaf | ftsNode | ftsRoots => + exact (ordinaryCacheIncreasing_splitHashQuery_ordinary query).entryPreserving input + +theorem ordinaryEntryPreserving_probingHashQuery + (parameter : PublicParameter) (input query : HashInput) + (hstable : StableOrdinaryInput parameter input) : + OrdinaryEntryPreserving input (probingHashQuery parameter query) := by + by_cases heq : input = query + · subst query + exact ordinaryEntryPreserving_probingHashQuery_self parameter input hstable + · exact ordinaryEntryPreserving_probingHashQuery_of_ne parameter input query heq + +theorem preservesOrdinaryPresence_probingHashQuery + (parameter : PublicParameter) (input query : HashInput) : + PreservesOrdinaryPresence input (probingHashQuery parameter query) := by + intro state cache fuel finalState remaining output finalCache hcached hresult + by_cases heq : input = query + · subst query + rw [returnsCachedOrdinary_probingHashQuery parameter input state cache fuel finalState + remaining output finalCache hresult] + simp + · exact Option.ne_none_iff_exists'.2 <| by + obtain ⟨cached, hvalue⟩ := Option.ne_none_iff_exists'.1 hcached + exact ⟨cached, ordinaryEntryPreserving_probingHashQuery_of_ne parameter input query heq + state cache fuel finalState remaining output finalCache cached hvalue hresult⟩ + +def PreservesOrdinaryPresenceImpl {spec : OracleSpec ι} (input : HashInput) + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) : Prop := + ∀ query, PreservesOrdinaryPresence input (impl query) + +theorem PreservesOrdinaryPresenceImpl.simulateQ {spec : OracleSpec ι} + {input : HashInput} + {impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))} + (himpl : PreservesOrdinaryPresenceImpl input impl) + (computation : OracleComp spec alpha) : + PreservesOrdinaryPresence input (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => exact PreservesOrdinaryPresence.pure input value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (himpl query).bind ih + +theorem preservesOrdinaryPresenceImpl_probingHashImpl + (parameter : PublicParameter) (input : HashInput) : + PreservesOrdinaryPresenceImpl input (probingHashImpl parameter) := + fun query => preservesOrdinaryPresence_probingHashQuery parameter input query + +theorem cachesOrdinaryInput_simulateQ_tweakableHash + (parameter : PublicParameter) (domain : HashDomain) (payload : HashInput) : + CachesOrdinaryInput (tweakableHashInput parameter domain payload) + (simulateQ (probingHashImpl parameter) + (tweakableHash parameter domain payload)) := by + unfold tweakableHash oracleHash + rw [simulateQ_bind] + simp only [HasQuery.instOfMonadLift_query, simulateQ_spec_query, simulateQ_pure] + exact (cachesOrdinaryInput_probingHashQuery parameter + (tweakableHashInput parameter domain payload)).bind_preserving fun _ => + OrdinaryEntryPreserving.pure _ _ + +theorem cachesOrdinaryInput_simulateQ_chainWalk_first + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (start steps : Nat) + (value : Digest) (hpositive : 0 < steps) + (hrange : start + steps ≤ chainLength - 1) : + CachesOrdinaryInput + (tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx ⟨start, by omega⟩) (digestBytes value)) + (simulateQ (probingHashImpl parameter) + (chainWalk parameter lay tree leafIdx chainIdx start steps value)) := by + induction steps with + | zero => omega + | succ steps ih => + rw [chainWalk] + have hstep : start + steps < chainLength - 1 := by omega + rw [simulateQ_bind] + simp only [dif_pos hstep] + cases steps with + | zero => + simp only [chainWalk, simulateQ_pure, pure_bind, Nat.add_zero] + exact cachesOrdinaryInput_simulateQ_tweakableHash parameter + (.chain lay tree leafIdx chainIdx ⟨start, by omega⟩) (digestBytes value) + | succ previous => + have hleft := ih (by omega) (by omega) + exact hleft.bind_presence fun _ => + (preservesOrdinaryPresenceImpl_probingHashImpl parameter _).simulateQ _ + +theorem cachesOrdinaryInput_simulateQ_sequenceFin_component + (parameter : PublicParameter) (input : HashInput) {n : Nat} + (computation : Fin n → OracleComp HashSpec alpha) (index : Fin n) + (hcomponent : CachesOrdinaryInput input + (simulateQ (probingHashImpl parameter) (computation index))) : + CachesOrdinaryInput input + (simulateQ (probingHashImpl parameter) (sequenceFin computation)) := by + induction n with + | zero => exact index.elim0 + | succ n ih => + rw [sequenceFin, simulateQ_bind] + cases index using Fin.cases with + | zero => + apply hcomponent.bind_presence + intro _ + rw [simulateQ_bind] + exact ((preservesOrdinaryPresenceImpl_probingHashImpl parameter input).simulateQ + (sequenceFin fun index : Fin n => computation index.succ)).bind fun _ => + PreservesOrdinaryPresence.pure input _ + | succ index => + apply CachesOrdinaryInput.bind_right + intro _ + rw [simulateQ_bind] + have htail := ih (fun index : Fin n => computation index.succ) index hcomponent + exact htail.bind_presence fun _ => PreservesOrdinaryPresence.pure input _ + +def OrdinaryEntryPreservingImpl {spec : OracleSpec ι} (input : HashInput) + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) : Prop := + ∀ query, OrdinaryEntryPreserving input (impl query) + +theorem OrdinaryEntryPreservingImpl.simulateQ {spec : OracleSpec ι} + {input : HashInput} + {impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))} + (himpl : OrdinaryEntryPreservingImpl input impl) + (computation : OracleComp spec alpha) : + OrdinaryEntryPreserving input (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => exact OrdinaryEntryPreserving.pure input value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (himpl query).bind ih + +theorem ordinaryEntryPreservingImpl_splitUniformImpl (input : HashInput) : + OrdinaryEntryPreservingImpl input splitUniformImpl := by + intro n + have hincreasing := ordinaryCacheIncreasing_simulateQ_splitUniformImpl + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) + simpa [splitUniformImpl] using hincreasing.entryPreserving input + +theorem ordinaryEntryPreservingImpl_probingHashImpl + (parameter : PublicParameter) (input : HashInput) + (hstable : StableOrdinaryInput parameter input) : + OrdinaryEntryPreservingImpl input (probingHashImpl parameter) := + fun query => ordinaryEntryPreserving_probingHashQuery parameter input query hstable + +theorem ordinaryEntryPreservingImpl_probingRomImpl + (parameter : PublicParameter) (input : HashInput) + (hstable : StableOrdinaryInput parameter input) : + OrdinaryEntryPreservingImpl input (probingRomImpl parameter) := by + intro query + cases query with + | inl query => exact ordinaryEntryPreservingImpl_splitUniformImpl input query + | inr query => + exact ordinaryEntryPreservingImpl_probingHashImpl parameter input hstable query + +theorem ordinaryEntryPreservingImpl_verifierHashImpl + (parameter : PublicParameter) (input : HashInput) : + OrdinaryEntryPreservingImpl input (verifierHashImpl parameter) := + fun query => ordinaryEntryPreserving_verifierHashQuery parameter input query + +theorem ordinaryEntryPreservingImpl_verifierRomImpl + (parameter : PublicParameter) (input : HashInput) : + OrdinaryEntryPreservingImpl input (verifierRomImpl parameter) := by + intro query + cases query with + | inl query => exact ordinaryEntryPreservingImpl_splitUniformImpl input query + | inr query => exact ordinaryEntryPreservingImpl_verifierHashImpl parameter input query + +set_option maxRecDepth 10000 in +theorem replay_of_mem_runRaw_verifierHashImpl + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (computation : OracleComp HashSpec alpha) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : alpha) + (hf : (ordinaryQueryCache finalCache).AgreesWithFn f) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ (verifierHashImpl parameter) computation).run cache))) : + evalWithAnswerFn f computation = value ∧ + CachedRun (ordinaryQueryCache finalCache) f computation := by + induction computation using OracleComp.inductionOn generalizing + state cache finalState finalCache fuel remaining value with + | pure result => + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨rfl, by simp [CachedRun]⟩ + | query_bind input next ih => + rw [simulateQ_query_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨queryRaw, hquery, hrest⟩ := hresult + cases queryRaw with + | stopped hit => simp at hrest + | done queryState queryRemaining queryResult => + rcases queryResult with ⟨answer, queryCache⟩ + have hqueryProperty : ReturnsCachedOrdinary input + (verifierHashImpl parameter input) := + returnsCachedOrdinary_verifierHashQuery parameter input + have hcachedQuery : queryCache (.ordinary input) = some answer := + hqueryProperty state cache fuel queryState queryRemaining answer queryCache hquery + have hcachedFinal : finalCache (.ordinary input) = some answer := + (ordinaryEntryPreservingImpl_verifierHashImpl parameter input).simulateQ + (next answer) queryState queryCache queryRemaining finalState remaining value + finalCache answer hcachedQuery hrest + have hfinput : f input = answer := hf hcachedFinal + obtain ⟨htailEval, htailQueries⟩ := ih answer queryState finalState queryCache finalCache queryRemaining + remaining value hf hrest + constructor + · rw [evalWithAnswerFn_bind, + show evalWithAnswerFn f (liftM (HashSpec.query input)) = f input from + simulateQ_spec_query f input, hfinput] + exact htailEval + · intro other hother + rw [queriedInputs_query_bind, hfinput] at hother + simp only [List.mem_cons] at hother + rcases hother with rfl | htail + · simp [ordinaryQueryCache, hcachedFinal] + · exact htailQueries other htail + +set_option maxRecDepth 10000 in +theorem replay_of_mem_runRaw_probingHashImpl_of_stable + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (computation : OracleComp HashSpec alpha) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : alpha) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (hstable : QueriesStable parameter f computation) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ (probingHashImpl parameter) computation).run cache))) : + evalWithAnswerFn f computation = value ∧ + CachedRun (ordinaryQueryCache finalCache) f computation := by + induction computation using OracleComp.inductionOn generalizing + state cache finalState finalCache fuel remaining value with + | pure result => + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨rfl, by simp [CachedRun]⟩ + | query_bind input next ih => + rw [simulateQ_query_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨raw, hquery, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done queryState queryRemaining queryResult => + rcases queryResult with ⟨answer, queryCache⟩ + have hinputStable : StableOrdinaryInput parameter input := by + apply hstable input + rw [queriedInputs_query_bind] + exact List.mem_cons_self + have hqueryProperty : ReturnsCachedOrdinary input + (probingHashImpl parameter input) := + returnsCachedOrdinary_probingHashImpl parameter input + have hqueryCached : queryCache (.ordinary input) = some answer := + hqueryProperty state cache fuel queryState queryRemaining answer queryCache hquery + have hfinalCached : finalCache (.ordinary input) = some answer := + (ordinaryEntryPreservingImpl_probingHashImpl parameter input hinputStable).simulateQ + (next answer) queryState queryCache queryRemaining finalState remaining value + finalCache answer hqueryCached hrest + have hfinput : f input = answer := hf input answer hinputStable hfinalCached + have htailStable : QueriesStable parameter f (next answer) := by + intro other hother + apply hstable other + rw [queriedInputs_query_bind, hfinput] + exact List.mem_cons_of_mem input hother + obtain ⟨heval, hqueries⟩ := ih answer queryState finalState queryCache finalCache + queryRemaining remaining value hf htailStable hrest + constructor + · rw [evalWithAnswerFn_bind, + show evalWithAnswerFn f (liftM (HashSpec.query input)) = f input from + simulateQ_spec_query f input, hfinput] + exact heval + · intro other hother + rw [queriedInputs_query_bind, hfinput] at hother + simp only [List.mem_cons] at hother + rcases hother with rfl | htail + · simp [ordinaryQueryCache, hfinalCached] + · exact hqueries other htail + +set_option maxRecDepth 10000 in +theorem cached_forged_chain_query_of_mem_runRaw_otsLeaf + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (counter : Counter) (values : ChainIndex → Digest) + (codeword : Encoding) + (hencode : evalWithAnswerFn f + (encode parameter lay tree leafIdx message counter) = some codeword) + (chainIdx : ChainIndex) + (hdigit : (codeword chainIdx).val < chainLength - 1) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (result : Option Digest) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (result, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((simulateQ (probingHashImpl parameter) + (otsLeaf parameter lay tree leafIdx message counter values)).run cache))) : + finalCache (.ordinary (tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx ⟨(codeword chainIdx).val, hdigit⟩) + (digestBytes (values chainIdx)))) ≠ none := by + let target := tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx ⟨(codeword chainIdx).val, hdigit⟩) + (digestBytes (values chainIdx)) + unfold otsLeaf at hresult + rw [simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨encodeRaw, hencodeRaw, hrest⟩ := hresult + cases encodeRaw with + | stopped hit => simp at hrest + | done encodeState encodeRemaining encodeResult => + rcases encodeResult with ⟨encoded, encodeCache⟩ + have hfEncode : StableCacheAgreesWithFn parameter encodeCache f := + StableCacheAgreesWithFn.of_run + (fun input hstable => + (ordinaryEntryPreservingImpl_probingHashImpl parameter input hstable).simulateQ _) + encodeState finalState encodeCache finalCache encodeRemaining remaining result hf hrest + have hencoded := (replay_of_mem_runRaw_probingHashImpl_of_stable f parameter + (encode parameter lay tree leafIdx message counter) state encodeState cache encodeCache + fuel encodeRemaining encoded hfEncode + (queriesStable_encode f parameter lay tree leafIdx message counter) hencodeRaw).1 + rw [hencode] at hencoded + subst encoded + simp only at hrest + let chains : ChainIndex → OracleComp HashSpec Digest := fun chainIdx => + recoverChain parameter lay tree leafIdx chainIdx (codeword chainIdx) (values chainIdx) + have hcomponent : CachesOrdinaryInput target + (simulateQ (probingHashImpl parameter) (chains chainIdx)) := by + simpa only [target, chains, recoverChain] using + (cachesOrdinaryInput_simulateQ_chainWalk_first parameter lay tree leafIdx chainIdx + (codeword chainIdx).val (chainLength - 1 - (codeword chainIdx).val) + (values chainIdx) (by omega) (by omega)) + have hchains : CachesOrdinaryInput target + (simulateQ (probingHashImpl parameter) (sequenceFin chains)) := + cachesOrdinaryInput_simulateQ_sequenceFin_component parameter target chains chainIdx + hcomponent + have htail : CachesOrdinaryInput target + (simulateQ (probingHashImpl parameter) (do + let endpoints ← sequenceFin chains + let value ← leafHash parameter lay tree leafIdx endpoints + pure (some value))) := by + rw [simulateQ_bind] + exact hchains.bind_presence fun endpoints => + (preservesOrdinaryPresenceImpl_probingHashImpl parameter target).simulateQ _ + exact htail encodeState encodeCache encodeRemaining finalState remaining result finalCache + hrest + +theorem TargetSum.Valid.exists_digit_lt_last + {codeword : Encoding} (hvalid : TargetSum.Valid codeword) : + ∃ chainIdx : ChainIndex, (codeword chainIdx).val < chainLength - 1 := by + by_contra hnone + have hall : ∀ chainIdx : ChainIndex, + (codeword chainIdx).val = chainLength - 1 := by + intro chainIdx + have hge := not_lt.mp (not_exists.mp hnone chainIdx) + have hle := (codeword chainIdx).isLt + simp only [chainLength, winternitzBits] at hge hle ⊢ + omega + have hsum : TargetSum.sum codeword = numChains * (chainLength - 1) := by + unfold TargetSum.sum + simp_rw [hall] + simp + rw [hvalid] at hsum + norm_num [targetSum, numChains, chainLength, winternitzBits] at hsum + +theorem chainInvariant_splitHashQuery_ordinary_of_decoded_secured + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (candidate : Probe) (input : HashInput) + (hdecode : decodeProbe? parameter input = some candidate) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) (fuel : Nat) + (finalState : LazyRevealProbe.State Coordinate) (remaining : Nat) + (value : HashOutput) (finalCache : SplitHashCache) + (hinvariant : ChainInvariant parameter allowed state cache) + (hsecured : allowed candidate.coordinate ∨ + candidate.candidate ∈ state.pendingAt candidate.coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((splitHashQuery (.ordinary input)).run cache))) : + ChainInvariant parameter allowed finalState finalCache := by + rw [splitHashQuery_run_eq] at hresult + cases hlookup : cache (.ordinary input) with + | some output => + rw [hlookup] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hinvariant + | none => + rw [hlookup] at hresult + dsimp only at hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.hashOutputQuery >>= fun output => + pure (output, Function.update cache (.ordinary input) (some output)))) at hresult + rw [LazyRevealProbe.hashOutputQuery, + LazyRevealProbe.runRaw_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _, hdone⟩ := hresult + simp [LazyRevealProbe.runRaw] at hdone + rcases hdone with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨hinvariant.1, + hinvariant.2.updateOrdinary_of_decoded_secured candidate input value hdecode hsecured⟩ + +theorem preservesChainInvariant_splitHashQuery_ordinary_of_decode_none + (parameter : PublicParameter) (allowed : Coordinate → Prop) (input : HashInput) + (hdecode : decodeProbe? parameter input = none) : + PreservesChainInvariant parameter allowed (splitHashQuery (.ordinary input)) := by + intro state cache fuel finalState remaining value finalCache hinvariant hresult + rw [splitHashQuery_run_eq] at hresult + cases hlookup : cache (.ordinary input) with + | some output => + rw [hlookup] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hinvariant + | none => + rw [hlookup] at hresult + dsimp only at hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.hashOutputQuery >>= fun output => + pure (output, Function.update cache (.ordinary input) (some output)))) at hresult + rw [LazyRevealProbe.hashOutputQuery, + LazyRevealProbe.runRaw_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _, hdone⟩ := hresult + simp [LazyRevealProbe.runRaw] at hdone + rcases hdone with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨hinvariant.1, + hinvariant.2.updateOrdinary_of_decode_none input value hdecode⟩ + +theorem ChainState.ValidFor.value_eq_none_of_not_allowed + {allowed : Coordinate → Prop} {state : LazyRevealProbe.State Coordinate} + (hvalid : ChainState.ValidFor allowed state) {coordinate : Coordinate} + (hchain : IsChainCoordinate coordinate) (hnotAllowed : ¬allowed coordinate) : + state.values coordinate = none := by + by_contra hvalue + exact hnotAllowed ((hvalid coordinate hchain).2.2 ((hvalid coordinate hchain).1 hvalue)) + +theorem ChainState.ValidFor.not_revealed_of_not_allowed + {allowed : Coordinate → Prop} {state : LazyRevealProbe.State Coordinate} + (hvalid : ChainState.ValidFor allowed state) {coordinate : Coordinate} + (hchain : IsChainCoordinate coordinate) (hnotAllowed : ¬allowed coordinate) : + coordinate ∉ state.revealed := by + intro hrevealed + exact hnotAllowed ((hvalid coordinate hchain).2.2 hrevealed) + +theorem ChainState.validFor_empty (allowed : Coordinate → Prop) : + ChainState.ValidFor allowed (LazyRevealProbe.State.empty : + LazyRevealProbe.State Coordinate) := by + intro coordinate hchain + simp [LazyRevealProbe.State.empty] + +theorem ChainState.ValidFor.ensure {allowed : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} (hvalid : ChainState.ValidFor allowed state) + (coordinate : Coordinate) : ChainState.ValidFor allowed (state.ensure coordinate) := by + simpa [ChainState.ValidFor, LazyRevealProbe.State.ensure] using hvalid + +theorem ChainState.ValidFor.addPending {allowed : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} (hvalid : ChainState.ValidFor allowed state) + (coordinate : Coordinate) (candidate : Digest) : + ChainState.ValidFor allowed (state.addPending coordinate candidate) := by + simpa [ChainState.ValidFor, LazyRevealProbe.State.addPending] using hvalid + +theorem ChainState.ValidFor.clearPending {allowed : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} (hvalid : ChainState.ValidFor allowed state) + (coordinate : Coordinate) : ChainState.ValidFor allowed (state.clearPending coordinate) := by + simpa [ChainState.ValidFor, LazyRevealProbe.State.clearPending] using hvalid + +theorem ChainState.ValidFor.materialize_of_not_chain {allowed : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} (hvalid : ChainState.ValidFor allowed state) + (coordinate : Coordinate) (output : HashOutput) (hnotChain : ¬IsChainCoordinate coordinate) : + ChainState.ValidFor allowed (state.materialize coordinate output) := by + intro other hchain + have hne : other ≠ coordinate := by + intro heq + exact hnotChain (heq ▸ hchain) + simpa [LazyRevealProbe.State.materialize, Function.update, hne] using hvalid other hchain + +theorem ChainState.ValidFor.publish {allowed : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} (hvalid : ChainState.ValidFor allowed state) + (coordinate : Coordinate) (hvalue : state.values coordinate ≠ none) + (hallowed : IsChainCoordinate coordinate → allowed coordinate) : + ChainState.ValidFor allowed (state.publish coordinate) := by + intro other hchain + by_cases heq : other = coordinate + · subst other + have hrevealed : coordinate ∈ (state.publish coordinate).revealed := by + simp [LazyRevealProbe.State.publish] + exact ⟨fun _ => hrevealed, fun _ => hvalue, fun _ => hallowed hchain⟩ + · have hold := hvalid other hchain + simpa [LazyRevealProbe.State.publish, heq] using hold + +theorem ChainState.ValidFor.materialize_publish {allowed : Coordinate → Prop} + {state : LazyRevealProbe.State Coordinate} (hvalid : ChainState.ValidFor allowed state) + (coordinate : Coordinate) (output : HashOutput) + (hallowed : IsChainCoordinate coordinate → allowed coordinate) : + ChainState.ValidFor allowed ((state.materialize coordinate output).publish coordinate) := by + intro other hchain + by_cases heq : other = coordinate + · subst other + simp [LazyRevealProbe.State.materialize, LazyRevealProbe.State.publish, Function.update, + hallowed hchain] + · have hold := hvalid other hchain + simpa [LazyRevealProbe.State.materialize, LazyRevealProbe.State.publish, Function.update, + heq] using hold + +def PreservesChainValid (allowed : Coordinate → Prop) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ state cache fuel finalState remaining value finalCache, + ChainState.ValidFor allowed state → + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + ChainState.ValidFor allowed finalState + +theorem PreservesChainValid.bind + {allowed : Coordinate → Prop} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : PreservesChainValid allowed left) + (hnext : ∀ value, PreservesChainValid allowed (next value)) : + PreservesChainValid allowed (left >>= next) := by + intro state cache fuel finalState remaining result finalCache hvalid hresult + change LazyRevealProbe.RawResult.done finalState remaining (result, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun leftResult => (next leftResult.1).run leftResult.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining leftResult => + rcases leftResult with ⟨leftValue, middleCache⟩ + exact hnext leftValue middleState middleCache middleRemaining finalState remaining result + finalCache (hleft state cache fuel middleState middleRemaining leftValue middleCache + hvalid hraw) hrest + +theorem preservesChainValid_pure (allowed : Coordinate → Prop) (value : alpha) : + PreservesChainValid allowed + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro state cache fuel finalState remaining result finalCache hvalid hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hvalid + +theorem preservesChainValid_splitHashQuery_ordinary (allowed : Coordinate → Prop) + (input : HashInput) : PreservesChainValid allowed (splitHashQuery (.ordinary input)) := by + intro state cache fuel finalState remaining value finalCache hvalid hresult + rw [splitHashQuery_run_eq] at hresult + cases hlookup : cache (.ordinary input) with + | some output => + rw [hlookup] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hvalid + | none => + rw [hlookup] at hresult + dsimp only at hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.hashOutputQuery >>= fun output => + pure (output, Function.update cache (.ordinary input) (some output)))) at hresult + rw [LazyRevealProbe.hashOutputQuery, + LazyRevealProbe.runRaw_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _, hdone⟩ := hresult + simp [LazyRevealProbe.runRaw] at hdone + rcases hdone with ⟨rfl, rfl, rfl, rfl⟩ + exact hvalid + +theorem preservesChainValid_ensureCoordinate (allowed : Coordinate → Prop) + (coordinate : Coordinate) : PreservesChainValid allowed (ensureCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hvalid hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.ensureQuery coordinate >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.ensureQuery, LazyRevealProbe.runRaw_ensure_query_bind] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hvalid.ensure coordinate + +theorem preservesChainValid_probe (allowed : Coordinate → Prop) (candidate : Probe) : + PreservesChainValid allowed (probe candidate) := by + intro state cache fuel finalState remaining value finalCache hvalid hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate >>= fun output => + pure (output, cache))) at hresult + rw [LazyRevealProbe.probeQuery, LazyRevealProbe.runRaw_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remainingFuel => + simp only at hresult + by_cases hrevealed : candidate.coordinate ∈ state.revealed + · rw [if_pos hrevealed] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hvalid + · rw [if_neg hrevealed] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hvalid.addPending candidate.coordinate candidate.candidate + +theorem preservesChainValid_peekCoordinate (allowed : Coordinate → Prop) + (coordinate : Coordinate) : PreservesChainValid allowed (peekCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hvalid hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.peekQuery coordinate >>= fun output => + pure (truncateHash <$> output, cache))) at hresult + rw [LazyRevealProbe.peekQuery, LazyRevealProbe.runRaw_peek_query_bind] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hvalid + +theorem mem_runRaw_peekCoordinate_some + (coordinate : Coordinate) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : Digest) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (some value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel ((peekCoordinate coordinate).run cache))) : + finalState = state ∧ remaining = fuel ∧ finalCache = cache ∧ + state.values coordinate ≠ none := by + change LazyRevealProbe.RawResult.done finalState remaining (some value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.peekQuery coordinate >>= fun output => + pure (truncateHash <$> output, cache))) at hresult + rw [LazyRevealProbe.peekQuery, LazyRevealProbe.runRaw_peek_query_bind] at hresult + cases hvalue : state.values coordinate with + | none => simp [hvalue, LazyRevealProbe.runRaw] at hresult + | some output => + simp [hvalue, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨rfl, rfl, rfl, by simp⟩ + +theorem mem_runRaw_peekCoordinate_none + (coordinate : Coordinate) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (none, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel ((peekCoordinate coordinate).run cache))) : + finalState = state ∧ remaining = fuel ∧ finalCache = cache ∧ + state.values coordinate = none := by + change LazyRevealProbe.RawResult.done finalState remaining (none, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.peekQuery coordinate >>= fun output => + pure (truncateHash <$> output, cache))) at hresult + rw [LazyRevealProbe.peekQuery, LazyRevealProbe.runRaw_peek_query_bind] at hresult + cases hvalue : state.values coordinate with + | none => + simp [hvalue, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨rfl, rfl, rfl, rfl⟩ + | some output => simp [hvalue, LazyRevealProbe.runRaw] at hresult + +theorem preservesChainValid_peekPositionValues (allowed : Coordinate → Prop) + (positions : List Position) : PreservesChainValid allowed (peekPositionValues positions) := by + induction positions with + | nil => exact preservesChainValid_pure allowed (some []) + | cons position remaining ih => + rw [peekPositionValues] + exact (preservesChainValid_peekCoordinate allowed (.position position)).bind fun value => + match value with + | none => preservesChainValid_pure allowed none + | some _ => ih.bind fun values => + match values with + | none => preservesChainValid_pure allowed none + | some _ => preservesChainValid_pure allowed _ + +theorem preservesChainValid_peekTableInput (allowed : Coordinate → Prop) + (parameter : PublicParameter) (coordinate : Coordinate) : + PreservesChainValid allowed (peekTableInput parameter coordinate) := by + cases coordinate with + | chainStart => exact preservesChainValid_pure allowed none + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput] + by_cases hzero : step.val = 0 + · rw [if_pos hzero] + exact (preservesChainValid_peekCoordinate allowed + (.chainStart lay tree leafIdx chainIdx)).bind fun value => + match value with + | none => preservesChainValid_pure allowed none + | some _ => preservesChainValid_pure allowed _ + · rw [if_neg hzero] + exact (preservesChainValid_peekPositionValues allowed + (Position.chain lay tree leafIdx chainIdx step).children).bind fun values => + match values with + | none => preservesChainValid_pure allowed none + | some _ => preservesChainValid_pure allowed _ + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp only [peekTableInput] + exact (preservesChainValid_peekPositionValues allowed _).bind fun values => + match values with + | none => preservesChainValid_pure allowed none + | some _ => preservesChainValid_pure allowed _ + +theorem mem_runRaw_peekTableInput_chain_some_imp_source + (parameter : PublicParameter) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (step : ChainStep) (knownInput : HashInput) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (some knownInput, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((peekTableInput parameter + (.position (.chain lay tree leafIdx chainIdx step))).run cache))) : + ∃ candidate : Probe, + candidate.outputCoordinate = .position (.chain lay tree leafIdx chainIdx step) ∧ + IsChainCoordinate candidate.coordinate ∧ state.values candidate.coordinate ≠ none := by + by_cases hzero : step.val = 0 + · rw [peekTableInput, if_pos hzero, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨raw, hpeek, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done peekState peekRemaining peekResult => + rcases peekResult with ⟨peekValue, peekCache⟩ + cases peekValue with + | none => simp [LazyRevealProbe.runRaw] at hrest + | some value => + have hvalue := mem_runRaw_peekCoordinate_some + (.chainStart lay tree leafIdx chainIdx) state peekState cache peekCache fuel + peekRemaining value hpeek + refine ⟨⟨.chainStart lay tree leafIdx chainIdx, 0⟩, ?_, trivial, + hvalue.2.2.2⟩ + have hstep : (⟨0, by norm_num [chainLength, winternitzBits]⟩ : ChainStep) = step := + Fin.ext hzero.symm + simpa [Probe.outputCoordinate] using congrArg + (fun nextStep => Coordinate.position + (Position.chain lay tree leafIdx chainIdx nextStep)) hstep + · have hpositive : 0 < step.val := Nat.pos_of_ne_zero hzero + let previous : ChainStep := ⟨step.val - 1, by + have := step.isLt + omega⟩ + have hchildren : (Position.chain lay tree leafIdx chainIdx step).children = + [.chain lay tree leafIdx chainIdx previous] := by + rw [Position.children, dif_pos hpositive] + rw [peekTableInput, if_neg hzero, hchildren] at hresult + simp only [peekPositionValues] at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hvalues, hfinish⟩ := hresult + cases raw with + | stopped hit => simp at hfinish + | done valuesState valuesRemaining valuesResult => + rcases valuesResult with ⟨values, valuesCache⟩ + cases values with + | none => simp [LazyRevealProbe.runRaw] at hfinish + | some values => + change LazyRevealProbe.RawResult.done valuesState valuesRemaining + (some values, valuesCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((peekPositionValues + [.chain lay tree leafIdx chainIdx previous]).run cache)) at hvalues + rw [peekPositionValues, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hvalues + obtain ⟨peekRaw, hpeek, hvaluesRest⟩ := hvalues + cases peekRaw with + | stopped hit => simp at hvaluesRest + | done peekState peekRemaining peekResult => + rcases peekResult with ⟨peekValue, peekCache⟩ + cases peekValue with + | none => simp [LazyRevealProbe.runRaw] at hvaluesRest + | some value => + have hvalue := mem_runRaw_peekCoordinate_some + (.position (.chain lay tree leafIdx chainIdx previous)) state peekState + cache peekCache fuel peekRemaining value hpeek + refine ⟨⟨.position (.chain lay tree leafIdx chainIdx previous), 0⟩, + ?_, trivial, hvalue.2.2.2⟩ + simp only [Probe.outputCoordinate] + rw [dif_pos (by dsimp [previous]; omega)] + congr 3 + dsimp [previous] + omega + +theorem preservesChainValid_revealPublishOrdinary + (allowed : Coordinate → Prop) (coordinate : Coordinate) (input : HashInput) + (hallowed : IsChainCoordinate coordinate → allowed coordinate) : + PreservesChainValid allowed (do + let output ← revealCoordinateOutput coordinate + publishCoordinate coordinate + modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output) + pure output) := by + intro state cache fuel finalState remaining value finalCache hvalid hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hreveal, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done revealState revealRemaining revealResult => + rcases revealResult with ⟨revealedOutput, revealCache⟩ + have hrevealShape : + (state.values coordinate ≠ none ∧ revealState = state) ∨ + ∃ output, revealState = state.materialize coordinate output := by + rw [revealCoordinateOutput_run, LazyRevealProbe.revealQuery, + LazyRevealProbe.runRaw_reveal_query_bind] at hreveal + cases hvalue : state.values coordinate with + | some existing => + rw [hvalue] at hreveal + simp [LazyRevealProbe.runRaw] at hreveal + rcases hreveal with ⟨rfl, rfl, rfl, rfl⟩ + exact Or.inl ⟨by simp, rfl⟩ + | none => + rw [hvalue, mem_support_bind_iff] at hreveal + obtain ⟨output, _, hsampled⟩ := hreveal + by_cases hhit : state.hitAt coordinate output + · rw [if_pos hhit] at hsampled + simp at hsampled + · rw [if_neg hhit] at hsampled + simp [LazyRevealProbe.runRaw] at hsampled + rcases hsampled with ⟨rfl, rfl, rfl, rfl⟩ + exact Or.inr ⟨revealedOutput, rfl⟩ + simp only at hrest + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hrest + obtain ⟨publishRaw, hpublish, hfinish⟩ := hrest + cases publishRaw with + | stopped hit => simp at hfinish + | done publishState publishRemaining publishResult => + rcases publishResult with ⟨publishedUnit, publishCache⟩ + change LazyRevealProbe.RawResult.done publishState publishRemaining + (publishedUnit, publishCache) ∈ support + (LazyRevealProbe.runRaw revealState revealRemaining + (LazyRevealProbe.publishQuery coordinate >>= fun output => + pure (output, revealCache))) at hpublish + rw [LazyRevealProbe.publishQuery, + LazyRevealProbe.runRaw_publish_query_bind] at hpublish + simp [LazyRevealProbe.runRaw] at hpublish + rcases hpublish with ⟨rfl, rfl, rfl, rfl⟩ + simp [StateT.run_modify, LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + rcases hrevealShape with ⟨hvalue, rfl⟩ | ⟨output, rfl⟩ + · exact hvalid.publish coordinate hvalue hallowed + · exact hvalid.materialize_publish coordinate output hallowed + +theorem chainInvariant_revealPublishOrdinary_of_decoded_secured + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (coordinate : Coordinate) (input : HashInput) (candidate : Probe) + (hdecode : decodeProbe? parameter input = some candidate) + (hallowed : IsChainCoordinate coordinate → allowed coordinate) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) (fuel : Nat) + (finalState : LazyRevealProbe.State Coordinate) (remaining : Nat) + (value : HashOutput) (finalCache : SplitHashCache) + (hinvariant : ChainInvariant parameter allowed state cache) + (hsecured : allowed candidate.coordinate ∨ + candidate.candidate ∈ state.pendingAt candidate.coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel ((do + let output ← revealCoordinateOutput coordinate + publishCoordinate coordinate + modify fun workingCache : SplitHashCache => + Function.update workingCache (.ordinary input) (some output) + pure output).run cache))) : + ChainInvariant parameter allowed finalState finalCache := by + have hfinalValid := preservesChainValid_revealPublishOrdinary allowed coordinate input hallowed + state cache fuel finalState remaining value finalCache hinvariant.1 hresult + have hcandidateMatches := (decodeProbe?_eq_some_iff parameter input candidate).1 hdecode + have hsourceChain := candidate.isChainCoordinate_of_matchesInput hcandidateMatches + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hreveal, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done revealState revealRemaining revealResult => + rcases revealResult with ⟨revealedOutput, revealCache⟩ + rw [revealCoordinateOutput_run, LazyRevealProbe.revealQuery, + LazyRevealProbe.runRaw_reveal_query_bind] at hreveal + cases hvalue : state.values coordinate with + | some existing => + rw [hvalue] at hreveal + simp [LazyRevealProbe.runRaw] at hreveal + rcases hreveal with ⟨rfl, rfl, rfl, rfl⟩ + simp only at hrest + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hrest + obtain ⟨publishRaw, hpublish, hfinish⟩ := hrest + cases publishRaw with + | stopped hit => simp at hfinish + | done publishState publishRemaining publishResult => + rcases publishResult with ⟨publishedUnit, publishCache⟩ + change LazyRevealProbe.RawResult.done publishState publishRemaining + (publishedUnit, publishCache) ∈ support + (LazyRevealProbe.runRaw _ _ + (LazyRevealProbe.publishQuery coordinate >>= fun output => + pure (output, _))) + at hpublish + rw [LazyRevealProbe.publishQuery, + LazyRevealProbe.runRaw_publish_query_bind] at hpublish + simp [LazyRevealProbe.runRaw] at hpublish + rcases hpublish with ⟨rfl, rfl, rfl, rfl⟩ + simp [StateT.run_modify, LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + refine ⟨hfinalValid, ?_⟩ + exact ((hinvariant.2.updateHidden coordinate value).publish coordinate).updateOrdinary_of_decoded_secured + candidate input value hdecode hsecured + | none => + rw [hvalue, mem_support_bind_iff] at hreveal + obtain ⟨sampled, _, hsampled⟩ := hreveal + by_cases hhit : state.hitAt coordinate sampled + · rw [if_pos hhit] at hsampled + simp at hsampled + · rw [if_neg hhit] at hsampled + simp [LazyRevealProbe.runRaw] at hsampled + rcases hsampled with ⟨rfl, rfl, rfl, rfl⟩ + simp only at hrest + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hrest + obtain ⟨publishRaw, hpublish, hfinish⟩ := hrest + cases publishRaw with + | stopped hit => simp at hfinish + | done publishState publishRemaining publishResult => + rcases publishResult with ⟨publishedUnit, publishCache⟩ + change LazyRevealProbe.RawResult.done publishState publishRemaining + (publishedUnit, publishCache) ∈ support + (LazyRevealProbe.runRaw _ _ + (LazyRevealProbe.publishQuery coordinate >>= fun output => + pure (output, _))) + at hpublish + rw [LazyRevealProbe.publishQuery, + LazyRevealProbe.runRaw_publish_query_bind] at hpublish + simp [LazyRevealProbe.runRaw] at hpublish + rcases hpublish with ⟨rfl, rfl, rfl, rfl⟩ + simp [StateT.run_modify, LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + refine ⟨hfinalValid, ?_⟩ + have haccounted := (hinvariant.2.updateHidden coordinate value).materialize_publish + coordinate value hallowed + have hsecuredFinal := secured_materialize_publish candidate coordinate + value hsourceChain hallowed hsecured + exact haccounted.updateOrdinary_of_decoded_secured candidate input + value hdecode hsecuredFinal + +theorem chainInvariant_revealPublishOrdinary_of_decode_none + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (coordinate : Coordinate) (input : HashInput) + (hdecode : decodeProbe? parameter input = none) + (hallowed : IsChainCoordinate coordinate → allowed coordinate) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) (fuel : Nat) + (finalState : LazyRevealProbe.State Coordinate) (remaining : Nat) + (value : HashOutput) (finalCache : SplitHashCache) + (hinvariant : ChainInvariant parameter allowed state cache) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel ((do + let output ← revealCoordinateOutput coordinate + publishCoordinate coordinate + modify fun workingCache : SplitHashCache => + Function.update workingCache (.ordinary input) (some output) + pure output).run cache))) : + ChainInvariant parameter allowed finalState finalCache := by + have hfinalValid := preservesChainValid_revealPublishOrdinary allowed coordinate input hallowed + state cache fuel finalState remaining value finalCache hinvariant.1 hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hreveal, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done revealState revealRemaining revealResult => + rcases revealResult with ⟨revealedOutput, revealCache⟩ + rw [revealCoordinateOutput_run, LazyRevealProbe.revealQuery, + LazyRevealProbe.runRaw_reveal_query_bind] at hreveal + cases hvalue : state.values coordinate with + | some existing => + rw [hvalue] at hreveal + simp [LazyRevealProbe.runRaw] at hreveal + rcases hreveal with ⟨rfl, rfl, rfl, rfl⟩ + simp only at hrest + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hrest + obtain ⟨publishRaw, hpublish, hfinish⟩ := hrest + cases publishRaw with + | stopped hit => simp at hfinish + | done publishState publishRemaining publishResult => + rcases publishResult with ⟨publishedUnit, publishCache⟩ + change LazyRevealProbe.RawResult.done publishState publishRemaining + (publishedUnit, publishCache) ∈ support + (LazyRevealProbe.runRaw _ _ + (LazyRevealProbe.publishQuery coordinate >>= fun output => + pure (output, _))) + at hpublish + rw [LazyRevealProbe.publishQuery, + LazyRevealProbe.runRaw_publish_query_bind] at hpublish + simp [LazyRevealProbe.runRaw] at hpublish + rcases hpublish with ⟨rfl, rfl, rfl, rfl⟩ + simp [StateT.run_modify, LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + refine ⟨hfinalValid, ?_⟩ + exact ChainProbeAccounted.updateOrdinary_of_decode_none + ((hinvariant.2.updateHidden coordinate value).publish coordinate) + input value hdecode + | none => + rw [hvalue, mem_support_bind_iff] at hreveal + obtain ⟨sampled, _, hsampled⟩ := hreveal + by_cases hhit : state.hitAt coordinate sampled + · rw [if_pos hhit] at hsampled + simp at hsampled + · rw [if_neg hhit] at hsampled + simp [LazyRevealProbe.runRaw] at hsampled + rcases hsampled with ⟨rfl, rfl, rfl, rfl⟩ + simp only at hrest + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hrest + obtain ⟨publishRaw, hpublish, hfinish⟩ := hrest + cases publishRaw with + | stopped hit => simp at hfinish + | done publishState publishRemaining publishResult => + rcases publishResult with ⟨publishedUnit, publishCache⟩ + change LazyRevealProbe.RawResult.done publishState publishRemaining + (publishedUnit, publishCache) ∈ support + (LazyRevealProbe.runRaw _ _ + (LazyRevealProbe.publishQuery coordinate >>= fun output => + pure (output, _))) + at hpublish + rw [LazyRevealProbe.publishQuery, + LazyRevealProbe.runRaw_publish_query_bind] at hpublish + simp [LazyRevealProbe.runRaw] at hpublish + rcases hpublish with ⟨rfl, rfl, rfl, rfl⟩ + simp [StateT.run_modify, LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + refine ⟨hfinalValid, ?_⟩ + exact ((hinvariant.2.updateHidden coordinate value).materialize_publish + coordinate value hallowed).updateOrdinary_of_decode_none input value hdecode + +theorem chainInvariant_resolveKnownInput_of_decoded_secured + (allowed : Coordinate → Prop) (hclosed : ChainForwardClosed allowed) + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) + (candidate : Probe) (hdecode : decodeProbe? parameter input = some candidate) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) (fuel : Nat) + (finalState : LazyRevealProbe.State Coordinate) (remaining : Nat) + (value : HashOutput) (finalCache : SplitHashCache) + (hinvariant : ChainInvariant parameter allowed state cache) + (hsecured : allowed candidate.coordinate ∨ + candidate.candidate ∈ state.pendingAt candidate.coordinate) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((resolveKnownInput parameter coordinate input).run cache))) : + ChainInvariant parameter allowed finalState finalCache := by + unfold resolveKnownInput at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hpeek, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done peekState peekRemaining peekResult => + rcases peekResult with ⟨known, peekCache⟩ + simp only at hrest + have hpeekInvariant := preservesChainInvariant_peekTableInput parameter allowed coordinate + state cache fuel peekState peekRemaining known peekCache hinvariant hpeek + obtain ⟨hpeekState, hpeekRemaining, hpeekCache⟩ := + rawReadOnly_peekTableInput parameter coordinate state cache fuel peekState peekRemaining + known peekCache hpeek + have hsecuredPeek : allowed candidate.coordinate ∨ + candidate.candidate ∈ peekState.pendingAt candidate.coordinate := by + simpa [hpeekState] using hsecured + cases known with + | none => + simp only at hrest + exact chainInvariant_splitHashQuery_ordinary_of_decoded_secured parameter allowed + candidate input hdecode peekState peekCache peekRemaining finalState remaining value + finalCache hpeekInvariant hsecuredPeek hrest + | some knownInput => + simp only at hrest + by_cases heq : knownInput = input + · rw [if_pos heq] at hrest + have hallowed : IsChainCoordinate coordinate → allowed coordinate := by + intro hchain + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [peekTableInput, LazyRevealProbe.runRaw] at hpeek + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + obtain ⟨source, houtput, hsourceChain, hsourceValue⟩ := + mem_runRaw_peekTableInput_chain_some_imp_source parameter state peekState + cache peekCache fuel peekRemaining lay tree leafIdx chainIdx step + knownInput hpeek + have hsourceValid := hinvariant.1 source.coordinate hsourceChain + have hsourceAllowed := hsourceValid.2.2 (hsourceValid.1 hsourceValue) + exact houtput ▸ hclosed source hsourceAllowed (houtput.symm ▸ hchain) + | leaf => simp [IsChainCoordinate] at hchain + | node => simp [IsChainCoordinate] at hchain + | ftsLeaf => simp [IsChainCoordinate] at hchain + | ftsNode => simp [IsChainCoordinate] at hchain + | ftsRoots => simp [IsChainCoordinate] at hchain + exact chainInvariant_revealPublishOrdinary_of_decoded_secured parameter allowed + coordinate input candidate hdecode hallowed peekState peekCache peekRemaining + finalState remaining value finalCache hpeekInvariant hsecuredPeek hrest + · rw [if_neg heq] at hrest + exact chainInvariant_splitHashQuery_ordinary_of_decoded_secured parameter allowed + candidate input hdecode peekState peekCache peekRemaining finalState remaining value + finalCache hpeekInvariant hsecuredPeek hrest + +theorem preservesChainInvariant_resolveKnownInput_of_decode_none + (allowed : Coordinate → Prop) (hclosed : ChainForwardClosed allowed) + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) + (hdecode : decodeProbe? parameter input = none) : + PreservesChainInvariant parameter allowed + (resolveKnownInput parameter coordinate input) := by + intro state cache fuel finalState remaining value finalCache hinvariant hresult + unfold resolveKnownInput at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hpeek, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done peekState peekRemaining peekResult => + rcases peekResult with ⟨known, peekCache⟩ + simp only at hrest + have hpeekInvariant := preservesChainInvariant_peekTableInput parameter allowed coordinate + state cache fuel peekState peekRemaining known peekCache hinvariant hpeek + cases known with + | none => + simp only at hrest + exact preservesChainInvariant_splitHashQuery_ordinary_of_decode_none parameter allowed + input hdecode peekState peekCache peekRemaining finalState remaining value finalCache + hpeekInvariant hrest + | some knownInput => + simp only at hrest + by_cases heq : knownInput = input + · rw [if_pos heq] at hrest + have hallowed : IsChainCoordinate coordinate → allowed coordinate := by + intro hchain + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [peekTableInput, LazyRevealProbe.runRaw] at hpeek + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + obtain ⟨source, houtput, hsourceChain, hsourceValue⟩ := + mem_runRaw_peekTableInput_chain_some_imp_source parameter state peekState + cache peekCache fuel peekRemaining lay tree leafIdx chainIdx step + knownInput hpeek + have hsourceValid := hinvariant.1 source.coordinate hsourceChain + have hsourceAllowed := hsourceValid.2.2 (hsourceValid.1 hsourceValue) + exact houtput ▸ hclosed source hsourceAllowed (houtput.symm ▸ hchain) + | leaf => simp [IsChainCoordinate] at hchain + | node => simp [IsChainCoordinate] at hchain + | ftsLeaf => simp [IsChainCoordinate] at hchain + | ftsNode => simp [IsChainCoordinate] at hchain + | ftsRoots => simp [IsChainCoordinate] at hchain + exact chainInvariant_revealPublishOrdinary_of_decode_none parameter allowed + coordinate input hdecode hallowed peekState peekCache peekRemaining finalState + remaining value finalCache hpeekInvariant hrest + · rw [if_neg heq] at hrest + exact preservesChainInvariant_splitHashQuery_ordinary_of_decode_none parameter allowed + input hdecode peekState peekCache peekRemaining finalState remaining value finalCache + hpeekInvariant hrest + +theorem preservesChainInvariant_probe_resolveKnownInput + (allowed : Coordinate → Prop) (hclosed : ChainForwardClosed allowed) + (parameter : PublicParameter) (input : HashInput) (candidate : Probe) + (hdecode : decodeProbe? parameter input = some candidate) : + PreservesChainInvariant parameter allowed (do + probe candidate + resolveKnownInput parameter candidate.outputCoordinate input) := by + intro state cache fuel finalState remaining value finalCache hinvariant hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((probe candidate).run cache >>= fun probeResult => + (resolveKnownInput parameter candidate.outputCoordinate input).run probeResult.2)) + at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hprobe, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done probeState probeRemaining probeResult => + rcases probeResult with ⟨probedUnit, probeCache⟩ + cases probedUnit + have hprobeInvariant := preservesChainInvariant_probe parameter allowed candidate state cache + fuel probeState probeRemaining () probeCache hinvariant hprobe + have hmatches := (decodeProbe?_eq_some_iff parameter input candidate).1 hdecode + have hchain := candidate.isChainCoordinate_of_matchesInput hmatches + have hsecured : allowed candidate.coordinate ∨ + candidate.candidate ∈ probeState.pendingAt candidate.coordinate := by + have hprobe' := hprobe + change LazyRevealProbe.RawResult.done probeState probeRemaining ((), probeCache) ∈ + support (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate >>= fun output => + pure (output, cache))) at hprobe' + rw [LazyRevealProbe.probeQuery, LazyRevealProbe.runRaw_probe_query_bind] at hprobe' + cases fuel with + | zero => simp at hprobe' + | succ remainingFuel => + simp only at hprobe' + by_cases hrevealed : candidate.coordinate ∈ state.revealed + · rw [if_pos hrevealed] at hprobe' + simp [LazyRevealProbe.runRaw] at hprobe' + rcases hprobe' with ⟨rfl, rfl, rfl⟩ + exact Or.inl ((hinvariant.1 candidate.coordinate hchain).2.2 hrevealed) + · rw [if_neg hrevealed] at hprobe' + simp [LazyRevealProbe.runRaw] at hprobe' + rcases hprobe' with ⟨rfl, rfl, rfl⟩ + exact Or.inr (LazyRevealProbe.State.pendingAt_addPending_self state + candidate.coordinate candidate.candidate) + exact chainInvariant_resolveKnownInput_of_decoded_secured allowed hclosed parameter + candidate.outputCoordinate input candidate hdecode probeState probeCache probeRemaining + finalState remaining value finalCache hprobeInvariant hsecured hrest + +theorem preservesChainInvariant_probeFirstMissingInputCoordinate + (parameter : PublicParameter) (allowed : Coordinate → Prop) (input : HashInput) : + ∀ (slot : Nat) (coordinates : List Coordinate), + PreservesChainInvariant parameter allowed + (probeFirstMissingInputCoordinate input slot coordinates) + | _, [] => preservesChainInvariant_pure parameter allowed () + | slot, coordinate :: remaining => by + rw [probeFirstMissingInputCoordinate] + exact (preservesChainInvariant_peekCoordinate parameter allowed coordinate).bind fun value => + match value with + | none => preservesChainInvariant_probe parameter allowed + ⟨coordinate, slotDigest slot input⟩ + | some _ => preservesChainInvariant_probeFirstMissingInputCoordinate parameter allowed input + (slot + 1) remaining + +theorem chainInvariant_prepareLeafInputProbe_secures + (allowed : Coordinate → Prop) (parameter : PublicParameter) + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (hdecode : decodeProbe? parameter input = some candidate) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : Unit) + (hinvariant : ChainInvariant parameter allowed state cache) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((prepareLeafInputProbe input candidate lay tree leafIdx).run cache))) : + ChainInvariant parameter allowed finalState finalCache ∧ + (allowed candidate.coordinate ∨ + candidate.candidate ∈ finalState.pendingAt candidate.coordinate) := by + unfold prepareLeafInputProbe at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨peekRaw, hpeek, hrest⟩ := hresult + cases peekRaw with + | stopped hit => simp at hrest + | done peekState peekRemaining peekResult => + rcases peekResult with ⟨peeked, peekCache⟩ + cases peeked with + | none => + simp only at hrest + obtain ⟨rfl, rfl, rfl, hmissing⟩ := mem_runRaw_peekCoordinate_none + candidate.coordinate state peekState cache peekCache fuel peekRemaining hpeek + have hmatches := (decodeProbe?_eq_some_iff parameter input candidate).1 hdecode + have hchain := candidate.isChainCoordinate_of_matchesInput hmatches + have hnotRevealed : candidate.coordinate ∉ peekState.revealed := by + intro hrevealed + exact ((hinvariant.1 candidate.coordinate hchain).2.1 hrevealed) hmissing + have hfinalInvariant := preservesChainInvariant_probe parameter allowed candidate peekState + peekCache peekRemaining finalState remaining value finalCache hinvariant hrest + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw peekState peekRemaining + (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate >>= + fun result => pure (result, peekCache))) at hrest + rw [LazyRevealProbe.probeQuery, LazyRevealProbe.runRaw_probe_query_bind] at hrest + cases peekRemaining with + | zero => simp at hrest + | succ remainingFuel => + simp only at hrest + rw [if_neg hnotRevealed] at hrest + simp [LazyRevealProbe.runRaw] at hrest + rcases hrest with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨hfinalInvariant, Or.inr + (LazyRevealProbe.State.pendingAt_addPending_self peekState candidate.coordinate + candidate.candidate)⟩ + | some output => + simp only at hrest + obtain ⟨rfl, rfl, rfl, hvalue⟩ := mem_runRaw_peekCoordinate_some + candidate.coordinate state peekState cache peekCache fuel peekRemaining output hpeek + have hmatches := (decodeProbe?_eq_some_iff parameter input candidate).1 hdecode + have hchain := candidate.isChainCoordinate_of_matchesInput hmatches + have hallowed : allowed candidate.coordinate := + (hinvariant.1 candidate.coordinate hchain).2.2 + ((hinvariant.1 candidate.coordinate hchain).1 hvalue) + exact ⟨preservesChainInvariant_probeFirstMissingInputCoordinate parameter allowed + input 0 ((Position.leaf lay tree leafIdx).children.map Coordinate.position) peekState + peekCache peekRemaining finalState remaining value finalCache hinvariant hrest, + Or.inl hallowed⟩ + +theorem preservesChainInvariant_prepareLeafInputProbe_resolveKnownInput + (allowed : Coordinate → Prop) (hclosed : ChainForwardClosed allowed) + (parameter : PublicParameter) (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (hdecode : decodeProbe? parameter input = some candidate) : + PreservesChainInvariant parameter allowed (do + prepareLeafInputProbe input candidate lay tree leafIdx + resolveKnownInput parameter candidate.outputCoordinate input) := by + intro state cache fuel finalState remaining value finalCache hinvariant hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨probeRaw, hprobe, hresolve⟩ := hresult + cases probeRaw with + | stopped hit => simp at hresolve + | done probeState probeRemaining probeResult => + rcases probeResult with ⟨probedUnit, probeCache⟩ + obtain ⟨hprobeInvariant, hsecured⟩ := chainInvariant_prepareLeafInputProbe_secures + allowed parameter input candidate lay tree leafIdx hdecode state probeState cache probeCache + fuel probeRemaining probedUnit hinvariant hprobe + exact chainInvariant_resolveKnownInput_of_decoded_secured allowed hclosed parameter + candidate.outputCoordinate input candidate hdecode probeState probeCache probeRemaining + finalState remaining value finalCache hprobeInvariant hsecured hresolve + +theorem preservesChainInvariant_probingHashQuery + (allowed : Coordinate → Prop) (hclosed : ChainForwardClosed allowed) + (parameter : PublicParameter) (input : HashInput) : + PreservesChainInvariant parameter allowed (probingHashQuery parameter input) := by + unfold probingHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases hposition : decodePosition? parameter input with + | some position => + cases position with + | leaf lay tree leafIdx => + simp only + exact preservesChainInvariant_prepareLeafInputProbe_resolveKnownInput allowed + hclosed parameter input candidate lay tree leafIdx hprobe + | chain | node | ftsLeaf | ftsNode | ftsRoots => + simp only + exact preservesChainInvariant_probe_resolveKnownInput allowed hclosed parameter input + candidate hprobe + | none => + simp only + exact preservesChainInvariant_probe_resolveKnownInput allowed hclosed parameter input + candidate hprobe + | none => + cases hposition : decodePosition? parameter input with + | none => + exact preservesChainInvariant_splitHashQuery_ordinary_of_decode_none parameter allowed + input hprobe + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + exact preservesChainInvariant_resolveKnownInput_of_decode_none allowed hclosed + parameter (.position (.chain lay tree leafIdx chainIdx step)) input hprobe + | leaf lay tree leafIdx => + exact preservesChainInvariant_resolveKnownInput_of_decode_none allowed hclosed + parameter (.position (.leaf lay tree leafIdx)) input hprobe + | node lay tree level nodeIdx => + exact (preservesChainInvariant_probeFirstMissingInputCoordinate parameter allowed + input 0 ((Position.node lay tree level nodeIdx).children.map + Coordinate.position)).bind fun _ => + preservesChainInvariant_resolveKnownInput_of_decode_none allowed hclosed + parameter (.position (.node lay tree level nodeIdx)) input hprobe + | ftsLeaf | ftsNode | ftsRoots => + exact preservesChainInvariant_splitHashQuery_ordinary_of_decode_none parameter + allowed input hprobe + +theorem preservesChainInvariant_splitUniformImpl + (parameter : PublicParameter) (allowed : Coordinate → Prop) (n : Nat) : + PreservesChainInvariant parameter allowed (splitUniformImpl n) := by + intro state cache fuel finalState remaining value finalCache hinvariant hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.uniformQuery n >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.uniformQuery, LazyRevealProbe.runRaw_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _, hdone⟩ := hresult + simp [LazyRevealProbe.runRaw] at hdone + rcases hdone with ⟨rfl, rfl, rfl, rfl⟩ + exact hinvariant + +def PreservesChainInvariantImpl {spec : OracleSpec ι} (parameter : PublicParameter) + (allowed : Coordinate → Prop) + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) : Prop := + ∀ query, PreservesChainInvariant parameter allowed (impl query) + +theorem PreservesChainInvariantImpl.simulateQ {spec : OracleSpec ι} + {parameter : PublicParameter} {allowed : Coordinate → Prop} + {impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))} + (himpl : PreservesChainInvariantImpl parameter allowed impl) + (computation : OracleComp spec alpha) : + PreservesChainInvariant parameter allowed (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => exact preservesChainInvariant_pure parameter allowed value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (himpl query).bind ih + +theorem preservesChainInvariantImpl_ordinaryHashImpl + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (hdecode : ∀ input, decodeProbe? parameter input = none) : + PreservesChainInvariantImpl parameter allowed ordinaryHashImpl := by + intro input + exact preservesChainInvariant_splitHashQuery_ordinary_of_decode_none parameter allowed input + (hdecode input) + +theorem preservesChainInvariant_ordinaryTweakableHash_of_decode_none + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (domain : HashDomain) (payload : HashInput) + (hdecode : decodeProbe? parameter (tweakableHashInput parameter domain payload) = none) : + PreservesChainInvariant parameter allowed + (simulateQ ordinaryHashImpl (tweakableHash parameter domain payload)) := by + change PreservesChainInvariant parameter allowed (do + let output ← splitHashQuery + (.ordinary (tweakableHashInput parameter domain payload)) + pure (truncateHash output)) + exact (preservesChainInvariant_splitHashQuery_ordinary_of_decode_none parameter allowed _ + hdecode).bind fun _ => preservesChainInvariant_pure parameter allowed _ + +theorem preservesChainInvariant_ordinaryTweakableHash + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (domain : HashDomain) (payload : HashInput) (hinRange : domain.InRange) + (hchain : ∀ lay tree leafIdx chainIdx step, + domain ≠ .chain lay tree leafIdx chainIdx step) + (hleaf : ∀ lay tree leafIdx, domain ≠ .leaf lay tree leafIdx) : + PreservesChainInvariant parameter allowed + (simulateQ ordinaryHashImpl (tweakableHash parameter domain payload)) := by + exact preservesChainInvariant_ordinaryTweakableHash_of_decode_none parameter allowed domain + payload (decodeProbe?_tweakableHashInput_of_not_chain_leaf parameter domain payload hinRange + hchain hleaf) + +theorem preservesChainInvariantImpl_splitUniformImpl + (parameter : PublicParameter) (allowed : Coordinate → Prop) : + PreservesChainInvariantImpl parameter allowed splitUniformImpl := + preservesChainInvariant_splitUniformImpl parameter allowed + +theorem preservesChainInvariantImpl_probingHashImpl + (allowed : Coordinate → Prop) (hclosed : ChainForwardClosed allowed) + (parameter : PublicParameter) : + PreservesChainInvariantImpl parameter allowed (probingHashImpl parameter) := + preservesChainInvariant_probingHashQuery allowed hclosed parameter + +theorem preservesChainInvariantImpl_probingRomImpl + (allowed : Coordinate → Prop) (hclosed : ChainForwardClosed allowed) + (parameter : PublicParameter) : + PreservesChainInvariantImpl parameter allowed (probingRomImpl parameter) := by + intro query + cases query with + | inl query => exact preservesChainInvariantImpl_splitUniformImpl parameter allowed query + | inr query => exact preservesChainInvariantImpl_probingHashImpl allowed hclosed parameter query + +theorem preservesChainInvariant_sequenceFin + (parameter : PublicParameter) (allowed : Coordinate → Prop) {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hcomputation : ∀ index, PreservesChainInvariant parameter allowed (computation index)) : + PreservesChainInvariant parameter allowed (sequenceFin computation) := by + induction n with + | zero => + simp only [sequenceFin] + exact preservesChainInvariant_pure parameter allowed Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomputation 0).bind fun head => + (ih (fun index => computation index.succ) + (fun index => hcomputation index.succ)).bind fun tail => + preservesChainInvariant_pure parameter allowed + (Fin.cases head tail : Fin (n + 1) → alpha) + +theorem chainInvariant_sequenceFin_of_done + (parameter : PublicParameter) (allowed : Coordinate → Prop) {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hcomputation : ∀ index state cache fuel finalState remaining value finalCache, + ChainInvariant parameter allowed state cache → + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel ((computation index).run cache)) → + ChainInvariant parameter allowed finalState finalCache) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (values : Fin n → alpha) + (hinvariant : ChainInvariant parameter allowed state cache) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (values, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel ((sequenceFin computation).run cache))) : + ChainInvariant parameter allowed finalState finalCache := by + induction n generalizing state finalState cache finalCache fuel remaining with + | zero => + simp [sequenceFin, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hinvariant + | succ n ih => + rw [sequenceFin, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨headRaw, hhead, hafterHead⟩ := hresult + cases headRaw with + | stopped stoppedHit => simp at hafterHead + | done headState headRemaining headResult => + rcases headResult with ⟨head, headCache⟩ + simp only at hafterHead + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterHead + obtain ⟨tailRaw, htail, hfinish⟩ := hafterHead + cases tailRaw with + | stopped stoppedHit => simp at hfinish + | done tailState tailRemaining tailResult => + rcases tailResult with ⟨tail, tailCache⟩ + have hheadInvariant := hcomputation 0 state cache fuel headState headRemaining + head headCache hinvariant hhead + have htailInvariant := ih + (computation := fun index => computation index.succ) + (hcomputation := fun index => hcomputation index.succ) + (values := tail) (state := headState) (finalState := tailState) + (cache := headCache) (finalCache := tailCache) (fuel := headRemaining) + (remaining := tailRemaining) hheadInvariant htail + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + exact htailInvariant + +theorem chainInvariant_layerSequence_of_done + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (computation : Layer → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hcomputation : ∀ index state cache fuel finalState remaining value finalCache, + ChainInvariant parameter allowed state cache → + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel ((computation index).run cache)) → + ChainInvariant parameter allowed finalState finalCache) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (values : Layer → alpha) + (hinvariant : ChainInvariant parameter allowed state cache) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (values, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel ((sequenceFin computation).run cache))) : + ChainInvariant parameter allowed finalState finalCache := + chainInvariant_sequenceFin_of_done (n := numLayers) parameter allowed computation hcomputation + state finalState cache finalCache fuel remaining values hinvariant hresult + +theorem sequenceFin_component_run_of_done {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hincreasing : ∀ index, OrdinaryCacheIncreasing (computation index)) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (values : Fin n → alpha) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (values, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel ((sequenceFin computation).run cache))) + (position : Fin n) : + ∃ (componentState componentFinalState : LazyRevealProbe.State Coordinate) + (componentCache componentFinalCache : SplitHashCache) + (componentFuel componentRemaining : Nat) (componentValue : alpha), + LazyRevealProbe.RawResult.done componentFinalState componentRemaining + (componentValue, componentFinalCache) ∈ support + (LazyRevealProbe.runRaw componentState componentFuel + ((computation position).run componentCache)) + ∧ values position = componentValue + ∧ LazyRevealProbe.ValuesLE componentFinalState finalState + ∧ LazyRevealProbe.EnsuredLE componentFinalState finalState + ∧ ordinaryQueryCache componentFinalCache ≤ ordinaryQueryCache finalCache := by + induction n generalizing state finalState cache finalCache fuel remaining with + | zero => exact position.elim0 + | succ n ih => + rw [sequenceFin, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨headRaw, hhead, hafterHead⟩ := hresult + cases headRaw with + | stopped stoppedHit => simp at hafterHead + | done headState headRemaining headResult => + rcases headResult with ⟨head, headCache⟩ + simp only at hafterHead + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterHead + obtain ⟨tailRaw, htail, hfinish⟩ := hafterHead + cases tailRaw with + | stopped stoppedHit => simp at hfinish + | done tailState tailRemaining tailResult => + rcases tailResult with ⟨tail, tailCache⟩ + have htailValues := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((sequenceFin fun tailPosition => computation tailPosition.succ).run headCache) + headState tailState headRemaining tailRemaining (tail, tailCache) htail + have htailEnsured := LazyRevealProbe.ensuredLE_of_mem_runRaw_done + ((sequenceFin fun tailPosition => computation tailPosition.succ).run headCache) + headState tailState headRemaining tailRemaining (tail, tailCache) htail + have htailCache := ordinaryCacheIncreasing_sequenceFin + (fun tailPosition => computation tailPosition.succ) + (fun tailPosition => hincreasing tailPosition.succ) + headState headCache headRemaining tailState tailRemaining tail tailCache htail + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + cases position using Fin.cases with + | zero => + exact ⟨state, headState, cache, headCache, fuel, headRemaining, head, + hhead, rfl, htailValues, htailEnsured, htailCache⟩ + | succ tailPosition => + exact ih + (computation := fun position => computation position.succ) + (hincreasing := fun position => hincreasing position.succ) + (values := tail) (state := headState) (finalState := finalState) + (cache := headCache) (finalCache := finalCache) (fuel := headRemaining) + (remaining := remaining) htail tailPosition + +theorem preservesChainInvariant_ordinaryEncode + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (counter : Counter) : + PreservesChainInvariant parameter allowed + (simulateQ ordinaryHashImpl (encode parameter lay tree leafIdx message counter)) := by + rw [encode, simulateQ_bind] + exact (preservesChainInvariant_ordinaryTweakableHash parameter allowed + (.encoding lay tree leafIdx) _ (by trivial) (by simp) (by simp)).bind fun _ => + preservesChainInvariant_pure parameter allowed _ + +theorem preservesChainInvariant_ordinaryMessageDigest + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (root : Digest) (message : Message) (randomness : Randomness) : + PreservesChainInvariant parameter allowed + (simulateQ ordinaryHashImpl (messageDigest parameter root message randomness)) := by + rw [messageDigest, simulateQ_bind] + have hquery : simulateQ ordinaryHashImpl + (oracleHash (tweakableHashInput parameter .message + (messageDigestPayload root message randomness))) = + splitHashQuery (.ordinary (tweakableHashInput parameter .message + (messageDigestPayload root message randomness))) := by + simp [oracleHash, ordinaryHashImpl] + rw [hquery] + change PreservesChainInvariant parameter allowed + (splitHashQuery (.ordinary (tweakableHashInput parameter .message + (messageDigestPayload root message randomness))) >>= fun output => pure _) + exact (preservesChainInvariant_splitHashQuery_ordinary_of_decode_none parameter allowed _ + (decodeProbe?_tweakableHashInput_of_not_chain_leaf parameter .message _ (by trivial) + (by simp) (by simp))).bind fun _ => preservesChainInvariant_pure parameter allowed _ + +theorem preservesChainInvariant_ordinarySignAttempt + (allowed : Coordinate → Prop) (secretKey : SecretKey) + (message : Message) (randomness : Randomness) : + PreservesChainInvariant secretKey.parameter allowed + (simulateQ ordinaryHashImpl (signAttempt secretKey message randomness)) := by + rw [signAttempt, simulateQ_bind] + exact (preservesChainInvariant_ordinaryMessageDigest secretKey.parameter allowed secretKey.root message + randomness).bind fun digest => by + split <;> simpa only [simulateQ_pure] using + (preservesChainInvariant_pure secretKey.parameter allowed _) + +theorem preservesChainInvariant_ordinarySignDigestLoop + (allowed : Coordinate → Prop) (attempts : Nat) + (secretKey : SecretKey) (message : Message) : + PreservesChainInvariant secretKey.parameter allowed + (simulateQ ordinaryRomImpl (signDigestLoop attempts secretKey message)) := by + induction attempts with + | zero => + rw [signDigestLoop, simulateQ_pure] + exact preservesChainInvariant_pure secretKey.parameter allowed none + | succ attempts ih => + rw [signDigestLoop, simulateQ_bind] + have hrandomness : PreservesChainInvariant secretKey.parameter allowed + (simulateQ ordinaryRomImpl (liftM sampleRandomness)) := by + rw [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_left] + exact (preservesChainInvariantImpl_splitUniformImpl secretKey.parameter allowed).simulateQ + sampleRandomness + exact hrandomness.bind fun randomness => by + rw [simulateQ_bind] + have hattempt : PreservesChainInvariant secretKey.parameter allowed + (simulateQ ordinaryRomImpl + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))))) := by + rw [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_right] + exact preservesChainInvariant_ordinarySignAttempt allowed secretKey message randomness + exact hattempt.bind fun attempt => by + cases attempt with + | none => exact ih + | some selected => exact preservesChainInvariant_pure secretKey.parameter allowed _ + +theorem ordinaryCacheIncreasing_ordinarySignDigestLoop + (attempts : Nat) (secretKey : SecretKey) (message : Message) : + OrdinaryCacheIncreasing + (simulateQ ordinaryRomImpl (signDigestLoop attempts secretKey message)) := by + induction attempts with + | zero => + rw [signDigestLoop, simulateQ_pure] + exact OrdinaryCacheIncreasing.pure none + | succ attempts ih => + rw [signDigestLoop, simulateQ_bind] + have hrandomness : OrdinaryCacheIncreasing + (simulateQ ordinaryRomImpl (liftM sampleRandomness)) := by + rw [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_left] + exact ordinaryCacheIncreasing_simulateQ_splitUniformImpl sampleRandomness + exact hrandomness.bind fun randomness => by + rw [simulateQ_bind] + have hattempt : OrdinaryCacheIncreasing + (simulateQ ordinaryRomImpl + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))))) := by + rw [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_right] + exact ordinaryCacheIncreasing_simulateQ_ordinaryHashImpl + (signAttempt secretKey message randomness) + exact hattempt.bind fun attempt => by + cases attempt with + | none => exact ih + | some selected => exact OrdinaryCacheIncreasing.pure _ + +theorem successfulDigestLoop_of_mem_runRaw_ordinaryRomImpl + (f : QueryImpl HashSpec Id) (secretKey : SecretKey) (message : Message) + (attempts : Nat) (randomness : Randomness) (index : Index) + (leaves : DigestTree → FtsLeaf) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (targetCache : SplitHashCache) + (hleFinal : ordinaryQueryCache finalCache ≤ ordinaryQueryCache targetCache) + (hf : StableCacheAgreesWithFn secretKey.parameter targetCache f) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (some (randomness, index, leaves), finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((simulateQ ordinaryRomImpl + (signDigestLoop attempts secretKey message)).run cache))) : + SuccessfulDigestRun f (ordinaryQueryCache targetCache) secretKey message randomness index + leaves := by + induction attempts generalizing state cache finalState finalCache fuel remaining randomness + index leaves with + | zero => + simp [signDigestLoop, LazyRevealProbe.runRaw] at hresult + | succ attempts ih => + rw [signDigestLoop, simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨randomnessRaw, hsample, hrest⟩ := hresult + cases randomnessRaw with + | stopped hit => simp at hrest + | done randomnessState randomnessRemaining randomnessResult => + rcases randomnessResult with ⟨sampledRandomness, randomnessCache⟩ + have hsample' : LazyRevealProbe.RawResult.done randomnessState randomnessRemaining + (sampledRandomness, randomnessCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((simulateQ splitUniformImpl sampleRandomness).run cache)) := by + simpa only [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_left] using hsample + obtain ⟨_, _, _, hsampled⟩ := + mem_runRaw_simulateQ_splitUniformImpl_projects sampleRandomness state + randomnessState cache randomnessCache fuel randomnessRemaining sampledRandomness + hsample' + simp only at hrest + rw [simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hrest + obtain ⟨attemptRaw, hattempt, hfinish⟩ := hrest + cases attemptRaw with + | stopped hit => simp at hfinish + | done attemptState attemptRemaining attemptResult => + rcases attemptResult with ⟨attempt, attemptCache⟩ + have hattempt' : LazyRevealProbe.RawResult.done attemptState attemptRemaining + (attempt, attemptCache) ∈ support + (LazyRevealProbe.runRaw randomnessState randomnessRemaining + ((simulateQ ordinaryHashImpl + (signAttempt secretKey message sampledRandomness)).run randomnessCache)) := by + simpa only [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_right] using hattempt + have hattemptProjection := mem_runRaw_simulateQ_ordinaryHashImpl_projects + (signAttempt secretKey message sampledRandomness) randomnessState attemptState + randomnessCache attemptCache randomnessRemaining attemptRemaining attempt + hattempt' + obtain ⟨_, _, hattemptSupport⟩ := hattemptProjection + cases attempt with + | none => + exact ih randomness index leaves attemptState finalState attemptCache finalCache + attemptRemaining remaining hleFinal hfinish + | some selected => + obtain ⟨selectedIndex, selectedLeaves⟩ := selected + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨hfinalState, hfinalRemaining, hselected, hfinalCache⟩ + subst finalState + subst remaining + subst finalCache + obtain ⟨hrandomness, hindex, hleaves⟩ := hselected + subst randomness + subst index + subst leaves + have hfAttempt : StableCacheAgreesWithFn secretKey.parameter attemptCache f := + fun input output hstable hcached => + hf input output hstable (hleFinal hcached) + have hreplay := replay_of_mem_runRaw_ordinaryHashImpl_of_stable f + secretKey.parameter (signAttempt secretKey message sampledRandomness) + randomnessState attemptState randomnessCache attemptCache randomnessRemaining + attemptRemaining (some (selectedIndex, selectedLeaves)) hfAttempt + (queriesStable_signAttempt f secretKey message sampledRandomness) hattempt' + exact ⟨hsampled, hreplay.1, CachedRun.mono hleFinal hreplay.2⟩ + +theorem preservesChainInvariant_simulateQ_sequenceFin {spec : OracleSpec ι} + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + {n : Nat} (computation : Fin n → OracleComp spec alpha) + (hcomputation : ∀ index, + PreservesChainInvariant parameter allowed (simulateQ impl (computation index))) : + PreservesChainInvariant parameter allowed (simulateQ impl (sequenceFin computation)) := by + induction n with + | zero => + simp only [sequenceFin, simulateQ_pure] + exact preservesChainInvariant_pure parameter allowed Fin.elim0 + | succ n ih => + rw [sequenceFin, simulateQ_bind] + exact (hcomputation 0).bind fun head => by + rw [simulateQ_bind] + exact (ih (fun index => computation index.succ) + (fun index => hcomputation index.succ)).bind fun tail => by + simp only [simulateQ_pure] + exact preservesChainInvariant_pure parameter allowed + (Fin.cases head tail : Fin (n + 1) → alpha) + +theorem preservesChainInvariant_ordinaryFtsLeafHash + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (index : Index) (tree : FtsTree) (leafIdx : FtsLeaf) (secret : Digest) : + PreservesChainInvariant parameter allowed + (simulateQ ordinaryHashImpl (ftsLeafHash parameter index tree leafIdx secret)) := by + unfold ftsLeafHash + exact preservesChainInvariant_ordinaryTweakableHash parameter allowed + (.ftsLeaf index tree leafIdx) _ (by trivial) (by simp) (by simp) + +theorem preservesChainInvariant_ordinaryFtsNode + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (index : Index) (tree : FtsTree) (secret : FtsLeaf → Digest) : + ∀ level nodeIdx, PreservesChainInvariant parameter allowed + (simulateQ ordinaryHashImpl (ftsNode parameter index tree secret level nodeIdx)) + | 0, nodeIdx => by + rw [ftsNode_zero_eq] + exact preservesChainInvariant_ordinaryFtsLeafHash parameter allowed index tree + (ftsLeafOfNat nodeIdx) (secret (ftsLeafOfNat nodeIdx)) + | level + 1, nodeIdx => by + rw [ftsNode_succ_eq, simulateQ_bind] + exact (preservesChainInvariant_ordinaryFtsNode parameter allowed index tree secret level + (2 * nodeIdx)).bind fun left => by + rw [simulateQ_bind] + exact (preservesChainInvariant_ordinaryFtsNode parameter allowed index tree secret level + (2 * nodeIdx + 1)).bind fun right => + preservesChainInvariant_ordinaryTweakableHash_of_decode_none parameter allowed + (.ftsNode index tree (level + 1) nodeIdx) (nodePayload left right) + (decodeProbe?_tweakableHashInput_ftsNode parameter index tree (level + 1) + nodeIdx (nodePayload left right)) + +theorem preservesChainInvariant_ordinaryFtsKey + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (index : Index) (secret : FtsTree → FtsLeaf → Digest) : + PreservesChainInvariant parameter allowed + (simulateQ ordinaryHashImpl (ftsKey parameter index secret)) := by + rw [ftsKey, simulateQ_bind] + exact (preservesChainInvariant_simulateQ_sequenceFin parameter allowed ordinaryHashImpl + (fun tree => ftsNode parameter index tree (secret tree) ftsTreeHeight 0) + (fun tree => preservesChainInvariant_ordinaryFtsNode parameter allowed index tree + (secret tree) ftsTreeHeight 0)).bind fun roots => + preservesChainInvariant_ordinaryTweakableHash parameter allowed (.ftsRoots index) + (ftsRootsPayload roots) (by trivial) (by simp) (by simp) + +theorem preservesChainInvariant_ordinaryFtsOpen + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (index : Index) (leaves : DigestTree → FtsLeaf) + (secret : FtsTree → FtsLeaf → Digest) : + PreservesChainInvariant parameter allowed + (simulateQ ordinaryHashImpl (ftsOpen parameter index leaves secret)) := by + unfold ftsOpen + exact preservesChainInvariant_simulateQ_sequenceFin parameter allowed ordinaryHashImpl _ + fun tree => preservesChainInvariant_simulateQ_sequenceFin parameter allowed ordinaryHashImpl _ + fun level => preservesChainInvariant_ordinaryFtsNode parameter allowed index tree + (secret tree) level.val + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1) + +theorem preservesChainValid_resolveKnownInput + (allowed : Coordinate → Prop) (hclosed : ChainForwardClosed allowed) + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) : + PreservesChainValid allowed (resolveKnownInput parameter coordinate input) := by + intro state cache fuel finalState remaining value finalCache hvalid hresult + unfold resolveKnownInput at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hpeek, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done peekState peekRemaining peekResult => + rcases peekResult with ⟨known, peekCache⟩ + simp only at hrest + have hpeekValid := preservesChainValid_peekTableInput allowed parameter coordinate state cache + fuel peekState peekRemaining known peekCache hvalid hpeek + cases known with + | none => + simp only at hrest + exact preservesChainValid_splitHashQuery_ordinary allowed input peekState peekCache + peekRemaining finalState remaining value finalCache hpeekValid hrest + | some knownInput => + simp only at hrest + by_cases heq : knownInput = input + · rw [if_pos heq] at hrest + have hallowed : IsChainCoordinate coordinate → allowed coordinate := by + intro hchain + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [peekTableInput, LazyRevealProbe.runRaw] at hpeek + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + obtain ⟨candidate, houtput, hsourceChain, hsourceValue⟩ := + mem_runRaw_peekTableInput_chain_some_imp_source parameter state peekState + cache peekCache fuel peekRemaining lay tree leafIdx chainIdx step + knownInput hpeek + have hsourceValid := hvalid candidate.coordinate hsourceChain + have hsourceAllowed := hsourceValid.2.2 (hsourceValid.1 hsourceValue) + exact houtput ▸ hclosed candidate hsourceAllowed (houtput.symm ▸ hchain) + | leaf => simp [IsChainCoordinate] at hchain + | node => simp [IsChainCoordinate] at hchain + | ftsLeaf => simp [IsChainCoordinate] at hchain + | ftsNode => simp [IsChainCoordinate] at hchain + | ftsRoots => simp [IsChainCoordinate] at hchain + exact preservesChainValid_revealPublishOrdinary allowed coordinate input hallowed + peekState peekCache peekRemaining finalState remaining value finalCache hpeekValid hrest + · rw [if_neg heq] at hrest + exact preservesChainValid_splitHashQuery_ordinary allowed input peekState peekCache + peekRemaining finalState remaining value finalCache hpeekValid hrest + +theorem preservesChainValid_probeFirstMissingInputCoordinate + (allowed : Coordinate → Prop) (input : HashInput) : + ∀ (slot : Nat) (coordinates : List Coordinate), + PreservesChainValid allowed (probeFirstMissingInputCoordinate input slot coordinates) + | _, [] => preservesChainValid_pure allowed () + | slot, coordinate :: remaining => by + rw [probeFirstMissingInputCoordinate] + exact (preservesChainValid_peekCoordinate allowed coordinate).bind fun value => + match value with + | none => preservesChainValid_probe allowed ⟨coordinate, slotDigest slot input⟩ + | some _ => preservesChainValid_probeFirstMissingInputCoordinate allowed input + (slot + 1) remaining + +theorem preservesChainValid_prepareLeafInputProbe + (allowed : Coordinate → Prop) (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + PreservesChainValid allowed (prepareLeafInputProbe input candidate lay tree leafIdx) := by + unfold prepareLeafInputProbe + apply (preservesChainValid_peekCoordinate allowed candidate.coordinate).bind + intro value + cases value with + | none => + simp only + exact preservesChainValid_probe allowed candidate + | some output => + simp only + exact preservesChainValid_probeFirstMissingInputCoordinate allowed input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + +theorem preservesChainValid_probingHashQuery + (allowed : Coordinate → Prop) (hclosed : ChainForwardClosed allowed) + (parameter : PublicParameter) (input : HashInput) : + PreservesChainValid allowed (probingHashQuery parameter input) := by + unfold probingHashQuery + cases decodeProbe? parameter input with + | some candidate => + cases hposition : decodePosition? parameter input with + | some position => + cases position with + | leaf lay tree leafIdx => + simp only + exact (preservesChainValid_prepareLeafInputProbe allowed input candidate lay tree + leafIdx).bind (fun _ => preservesChainValid_resolveKnownInput allowed hclosed + parameter candidate.outputCoordinate input) + | chain | node | ftsLeaf | ftsNode | ftsRoots => + simp only + exact (preservesChainValid_probe allowed candidate).bind (fun _ => + preservesChainValid_resolveKnownInput allowed hclosed parameter + candidate.outputCoordinate input) + | none => + simp only + exact (preservesChainValid_probe allowed candidate).bind (fun _ => + preservesChainValid_resolveKnownInput allowed hclosed parameter + candidate.outputCoordinate input) + | none => + cases decodePosition? parameter input with + | none => exact preservesChainValid_splitHashQuery_ordinary allowed input + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + exact preservesChainValid_resolveKnownInput allowed hclosed parameter + (.position (.chain lay tree leafIdx chainIdx step)) input + | leaf lay tree leafIdx => + exact preservesChainValid_resolveKnownInput allowed hclosed parameter + (.position (.leaf lay tree leafIdx)) input + | node lay tree level nodeIdx => + exact (preservesChainValid_probeFirstMissingInputCoordinate allowed input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)).bind + fun _ => preservesChainValid_resolveKnownInput allowed hclosed parameter + (.position (.node lay tree level nodeIdx)) input + | ftsLeaf | ftsNode | ftsRoots => + exact preservesChainValid_splitHashQuery_ordinary allowed input + +theorem preservesChainValid_splitUniformImpl (allowed : Coordinate → Prop) (n : Nat) : + PreservesChainValid allowed (splitUniformImpl n) := by + intro state cache fuel finalState remaining value finalCache hvalid hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.uniformQuery n >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.uniformQuery, LazyRevealProbe.runRaw_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _, hdone⟩ := hresult + simp [LazyRevealProbe.runRaw] at hdone + rcases hdone with ⟨rfl, rfl, rfl, rfl⟩ + exact hvalid + +def PreservesChainValidImpl {spec : OracleSpec ι} (allowed : Coordinate → Prop) + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) : Prop := + ∀ query, PreservesChainValid allowed (impl query) + +theorem PreservesChainValidImpl.simulateQ {spec : OracleSpec ι} + {allowed : Coordinate → Prop} + {impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))} + (himpl : PreservesChainValidImpl allowed impl) (computation : OracleComp spec alpha) : + PreservesChainValid allowed (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => exact preservesChainValid_pure allowed value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (himpl query).bind ih + +theorem preservesChainValidImpl_ordinaryHashImpl (allowed : Coordinate → Prop) : + PreservesChainValidImpl allowed ordinaryHashImpl := by + intro input + exact preservesChainValid_splitHashQuery_ordinary allowed input + +theorem preservesChainValidImpl_splitUniformImpl (allowed : Coordinate → Prop) : + PreservesChainValidImpl allowed splitUniformImpl := + preservesChainValid_splitUniformImpl allowed + +theorem preservesChainValidImpl_ordinaryRomImpl (allowed : Coordinate → Prop) : + PreservesChainValidImpl allowed ordinaryRomImpl := by + intro query + cases query with + | inl query => exact preservesChainValidImpl_splitUniformImpl allowed query + | inr query => exact preservesChainValidImpl_ordinaryHashImpl allowed query + +theorem preservesChainValidImpl_probingHashImpl + (allowed : Coordinate → Prop) (hclosed : ChainForwardClosed allowed) + (parameter : PublicParameter) : + PreservesChainValidImpl allowed (probingHashImpl parameter) := + preservesChainValid_probingHashQuery allowed hclosed parameter + +theorem preservesChainValidImpl_probingRomImpl + (allowed : Coordinate → Prop) (hclosed : ChainForwardClosed allowed) + (parameter : PublicParameter) : + PreservesChainValidImpl allowed (probingRomImpl parameter) := by + intro query + cases query with + | inl query => exact preservesChainValidImpl_splitUniformImpl allowed query + | inr query => exact preservesChainValidImpl_probingHashImpl allowed hclosed parameter query + +theorem preservesChainValid_sequenceFin (allowed : Coordinate → Prop) {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hcomputation : ∀ index, PreservesChainValid allowed (computation index)) : + PreservesChainValid allowed (sequenceFin computation) := by + induction n with + | zero => + simp only [sequenceFin] + exact preservesChainValid_pure allowed Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomputation 0).bind fun head => + (ih (fun index => computation index.succ) + (fun index => hcomputation index.succ)).bind fun tail => + preservesChainValid_pure allowed (Fin.cases head tail : Fin (n + 1) → alpha) + +theorem mem_runRaw_revealCoordinate_state + (coordinate : Coordinate) (state finalState : LazyRevealProbe.State Coordinate) + (fuel remaining : Nat) (cache finalCache : SplitHashCache) (value : Digest) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel ((revealCoordinate coordinate).run cache))) : + (state.values coordinate ≠ none ∧ finalState = state) ∨ + ∃ output, finalState = state.materialize coordinate output := by + rw [revealCoordinate_run, LazyRevealProbe.revealQuery, + LazyRevealProbe.runRaw_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some existing => + rw [hvalue] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact Or.inl ⟨by simp, rfl⟩ + | none => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨sampled, _, hsampled⟩ := hresult + by_cases hhit : state.hitAt coordinate sampled + · rw [if_pos hhit] at hsampled + simp at hsampled + · rw [if_neg hhit] at hsampled + simp [LazyRevealProbe.runRaw] at hsampled + rcases hsampled with ⟨rfl, rfl, rfl, rfl⟩ + exact Or.inr ⟨sampled, rfl⟩ + +theorem ordinaryCacheIncreasing_revealCoordinate (coordinate : Coordinate) : + OrdinaryCacheIncreasing (revealCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hresult + rw [revealCoordinate_run, LazyRevealProbe.revealQuery, + LazyRevealProbe.runRaw_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some existing => + rw [hvalue] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + rw [ordinaryQueryCache_update_hidden] + | none => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨output, _, hsampled⟩ := hresult + by_cases hhit : state.hitAt coordinate output + · rw [if_pos hhit] at hsampled + simp at hsampled + · rw [if_neg hhit] at hsampled + simp [LazyRevealProbe.runRaw] at hsampled + rcases hsampled with ⟨rfl, rfl, rfl, rfl⟩ + rw [ordinaryQueryCache_update_hidden] + +theorem splitCachePreserving_publishCoordinate (coordinate : Coordinate) : + SplitCachePreserving (publishCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.publishQuery coordinate >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.publishQuery, LazyRevealProbe.runRaw_publish_query_bind] at hresult + simp [LazyRevealProbe.runRaw] at hresult + exact hresult.2.2 + +theorem ordinaryCacheIncreasing_revealPublishedCoordinate (coordinate : Coordinate) : + OrdinaryCacheIncreasing (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + exact (ordinaryCacheIncreasing_revealCoordinate coordinate).bind fun _ => + (splitCachePreserving_publishCoordinate coordinate).ordinaryCacheIncreasing.bind fun _ => + OrdinaryCacheIncreasing.pure _ + +theorem preservesChainValid_revealCoordinate_of_not_chain + (allowed : Coordinate → Prop) (coordinate : Coordinate) + (hnotChain : ¬IsChainCoordinate coordinate) : + PreservesChainValid allowed (revealCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hvalid hresult + rcases mem_runRaw_revealCoordinate_state coordinate state finalState fuel remaining cache + finalCache value hresult with ⟨hvalue, rfl⟩ | ⟨output, rfl⟩ + · exact hvalid + · exact hvalid.materialize_of_not_chain coordinate output hnotChain + +theorem preservesChainInvariant_revealCoordinate_of_not_chain + (parameter : PublicParameter) (allowed : Coordinate → Prop) (coordinate : Coordinate) + (hnotChain : ¬IsChainCoordinate coordinate) : + PreservesChainInvariant parameter allowed (revealCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hinvariant hresult + have hfinalValid := preservesChainValid_revealCoordinate_of_not_chain allowed coordinate + hnotChain state cache fuel finalState remaining value finalCache hinvariant.1 hresult + rw [revealCoordinate_run, LazyRevealProbe.revealQuery, + LazyRevealProbe.runRaw_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some existing => + rw [hvalue] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact ⟨hfinalValid, hinvariant.2.updateHidden coordinate existing⟩ + | none => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨output, _, hsampled⟩ := hresult + by_cases hhit : state.hitAt coordinate output + · rw [if_pos hhit] at hsampled + simp at hsampled + · rw [if_neg hhit] at hsampled + simp [LazyRevealProbe.runRaw] at hsampled + rcases hsampled with ⟨rfl, rfl, rfl, rfl⟩ + refine ⟨hfinalValid, ?_⟩ + exact (hinvariant.2.updateHidden coordinate output).materialize coordinate output + (fun hchain => (hnotChain hchain).elim) + +theorem preservesChainValid_ensureFullChain (allowed : Coordinate → Prop) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + PreservesChainValid allowed (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (preservesChainValid_sequenceFin allowed _ fun step => + preservesChainValid_ensureCoordinate allowed + (.position (.chain lay tree leafIdx chainIdx step))).bind fun _ => + preservesChainValid_pure allowed () + +theorem preservesChainValid_ensureChainPrefix (allowed : Coordinate → Prop) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (digit : Digit) : + PreservesChainValid allowed (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (preservesChainValid_sequenceFin allowed _ fun step => by + split + · exact preservesChainValid_ensureCoordinate allowed + (.position (.chain lay tree leafIdx chainIdx step)) + · exact preservesChainValid_pure allowed ()).bind fun _ => + preservesChainValid_pure allowed () + +theorem preservesChainValid_ensureOtsLeaf (allowed : Coordinate → Prop) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + PreservesChainValid allowed (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (preservesChainValid_sequenceFin allowed _ fun chainIdx => + preservesChainValid_ensureFullChain allowed lay tree leafIdx chainIdx).bind fun _ => + preservesChainValid_ensureCoordinate allowed (.position (.leaf lay tree leafIdx)) + +theorem preservesChainValid_ensureTreeNode (allowed : Coordinate → Prop) + (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, PreservesChainValid allowed (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => preservesChainValid_ensureOtsLeaf allowed lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (preservesChainValid_ensureTreeNode allowed lay tree level (2 * nodeIdx)).bind + fun _ => + (preservesChainValid_ensureTreeNode allowed lay tree level + (2 * nodeIdx + 1)).bind fun _ => by + split + · exact preservesChainValid_ensureCoordinate allowed _ + · exact preservesChainValid_pure allowed () + +theorem preservesChainValid_maskedTreeNode (allowed : Coordinate → Prop) + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) : + PreservesChainValid allowed (maskedTreeNode lay tree level nodeIdx) := by + cases level with + | zero => + rw [maskedTreeNode] + exact (preservesChainValid_ensureTreeNode allowed lay tree 0 nodeIdx).bind fun _ => + preservesChainValid_revealCoordinate_of_not_chain allowed + (.position (.leaf lay tree (leafOfNat nodeIdx))) (by simp [IsChainCoordinate]) + | succ current => + rw [maskedTreeNode] + exact (preservesChainValid_ensureTreeNode allowed lay tree (current + 1) nodeIdx).bind + fun _ => by + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact preservesChainValid_revealCoordinate_of_not_chain allowed + (.position (.node lay tree ⟨current, hlevel⟩ (leafOfNat nodeIdx))) + (by simp [IsChainCoordinate]) + · rw [dif_neg hlevel] + exact preservesChainValid_pure allowed 0 + +theorem preservesChainValid_maskedTreeRoot (allowed : Coordinate → Prop) + (lay : Layer) (tree : TreeIndex) : + PreservesChainValid allowed (maskedTreeRoot lay tree) := + preservesChainValid_maskedTreeNode allowed lay tree (layerHeight lay) 0 + +theorem preservesChainValid_ensureTreePath (allowed : Coordinate → Prop) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + PreservesChainValid allowed (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (preservesChainValid_sequenceFin allowed _ fun level => by + split + · exact preservesChainValid_ensureTreeNode allowed lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · exact preservesChainValid_pure allowed ()).bind fun _ => + preservesChainValid_pure allowed () + +theorem preservesChainValid_maskedOtsSignFrom (allowed : Coordinate → Prop) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) : ∀ attempts counter, + PreservesChainValid allowed + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => preservesChainValid_pure allowed none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + exact ((preservesChainValidImpl_ordinaryHashImpl allowed).simulateQ + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter))).bind fun encoded => + match encoded with + | none => preservesChainValid_maskedOtsSignFrom allowed parameter lay tree leafIdx + message attempts (counter + 1) + | some encoding => + (preservesChainValid_sequenceFin allowed _ fun chainIdx => + preservesChainValid_ensureChainPrefix allowed lay tree leafIdx chainIdx + (encoding chainIdx)).bind fun _ => + preservesChainValid_pure allowed + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem preservesChainValid_maskedOtsSign (allowed : Coordinate → Prop) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) : + PreservesChainValid allowed (maskedOtsSign parameter lay tree leafIdx message) := + preservesChainValid_maskedOtsSignFrom allowed parameter lay tree leafIdx message + encodingAttemptLimit 0 + +theorem preservesChainValid_maskedLayerMessage (allowed : Coordinate → Prop) + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + PreservesChainValid allowed (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + split + · exact preservesChainValid_maskedTreeRoot allowed _ _ + · exact (preservesChainValidImpl_ordinaryHashImpl allowed).simulateQ + (ftsKey parameter index (ftsSecret index)) + +theorem preservesChainValid_maskedSignLayer (allowed : Coordinate → Prop) + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + PreservesChainValid allowed (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + exact (preservesChainValid_maskedLayerMessage allowed parameter ftsSecret index lay).bind + fun message => + (preservesChainValid_maskedOtsSign allowed parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message).bind fun result => + match result with + | none => preservesChainValid_pure allowed none + | some part => + (preservesChainValid_ensureTreePath allowed lay (treeIndexAt index lay) + (leafIndexAt index lay)).bind fun _ => + preservesChainValid_pure allowed (some part) + +theorem preservesChainInvariant_ensureFullChain + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + PreservesChainInvariant parameter allowed (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (preservesChainInvariant_sequenceFin parameter allowed _ fun step => + preservesChainInvariant_ensureCoordinate parameter allowed + (.position (.chain lay tree leafIdx chainIdx step))).bind fun _ => + preservesChainInvariant_pure parameter allowed () + +theorem preservesChainInvariant_ensureChainPrefix + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (digit : Digit) : + PreservesChainInvariant parameter allowed + (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (preservesChainInvariant_sequenceFin parameter allowed _ fun step => by + split + · exact preservesChainInvariant_ensureCoordinate parameter allowed + (.position (.chain lay tree leafIdx chainIdx step)) + · exact preservesChainInvariant_pure parameter allowed ()).bind fun _ => + preservesChainInvariant_pure parameter allowed () + +theorem preservesChainInvariant_ensureOtsLeaf + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + PreservesChainInvariant parameter allowed (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (preservesChainInvariant_sequenceFin parameter allowed _ fun chainIdx => + preservesChainInvariant_ensureFullChain parameter allowed lay tree leafIdx chainIdx).bind + fun _ => preservesChainInvariant_ensureCoordinate parameter allowed + (.position (.leaf lay tree leafIdx)) + +theorem preservesChainInvariant_ensureTreeNode + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, + PreservesChainInvariant parameter allowed (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => preservesChainInvariant_ensureOtsLeaf parameter allowed lay tree + (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (preservesChainInvariant_ensureTreeNode parameter allowed lay tree level + (2 * nodeIdx)).bind fun _ => + (preservesChainInvariant_ensureTreeNode parameter allowed lay tree level + (2 * nodeIdx + 1)).bind fun _ => by + split + · exact preservesChainInvariant_ensureCoordinate parameter allowed _ + · exact preservesChainInvariant_pure parameter allowed () + +theorem preservesChainInvariant_maskedTreeNode + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) : + PreservesChainInvariant parameter allowed (maskedTreeNode lay tree level nodeIdx) := by + cases level with + | zero => + rw [maskedTreeNode] + exact (preservesChainInvariant_ensureTreeNode parameter allowed lay tree 0 nodeIdx).bind + fun _ => preservesChainInvariant_revealCoordinate_of_not_chain parameter allowed + (.position (.leaf lay tree (leafOfNat nodeIdx))) (by simp [IsChainCoordinate]) + | succ current => + rw [maskedTreeNode] + exact (preservesChainInvariant_ensureTreeNode parameter allowed lay tree (current + 1) + nodeIdx).bind fun _ => by + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact preservesChainInvariant_revealCoordinate_of_not_chain parameter allowed + (.position (.node lay tree ⟨current, hlevel⟩ (leafOfNat nodeIdx))) + (by simp [IsChainCoordinate]) + · rw [dif_neg hlevel] + exact preservesChainInvariant_pure parameter allowed 0 + +theorem preservesChainInvariant_maskedTreeRoot + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (lay : Layer) (tree : TreeIndex) : + PreservesChainInvariant parameter allowed (maskedTreeRoot lay tree) := + preservesChainInvariant_maskedTreeNode parameter allowed lay tree (layerHeight lay) 0 + +theorem chainInvariant_maskedTreeRoot_empty + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (lay : Layer) (tree : TreeIndex) (fuel remaining : Nat) + (finalState : LazyRevealProbe.State Coordinate) (value : Digest) + (finalCache : SplitHashCache) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (value, finalCache) ∈ support + (LazyRevealProbe.runRaw (LazyRevealProbe.State.empty : + LazyRevealProbe.State Coordinate) fuel + ((maskedTreeRoot lay tree).run emptySplitHashCache))) : + ChainInvariant parameter allowed finalState finalCache := by + have hpreserves : PreservesChainInvariant parameter allowed (maskedTreeRoot lay tree) := + preservesChainInvariant_maskedTreeRoot parameter allowed lay tree + exact hpreserves (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + emptySplitHashCache fuel finalState remaining value finalCache + ⟨ChainState.validFor_empty allowed, chainProbeAccounted_empty parameter allowed⟩ hresult + +theorem preservesChainInvariant_ensureTreePath + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + PreservesChainInvariant parameter allowed (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (preservesChainInvariant_sequenceFin parameter allowed _ fun level => by + split + · exact preservesChainInvariant_ensureTreeNode parameter allowed lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · exact preservesChainInvariant_pure parameter allowed ()).bind fun _ => + preservesChainInvariant_pure parameter allowed () + +theorem preservesChainInvariant_maskedOtsSignFrom + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter, + PreservesChainInvariant parameter allowed + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => preservesChainInvariant_pure parameter allowed none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + exact (preservesChainInvariant_ordinaryEncode parameter allowed lay tree leafIdx message + (BitVec.ofNat counterBits counter)).bind fun encoded => + match encoded with + | none => preservesChainInvariant_maskedOtsSignFrom parameter allowed lay tree leafIdx + message attempts (counter + 1) + | some encoding => + (preservesChainInvariant_sequenceFin parameter allowed _ fun chainIdx => + preservesChainInvariant_ensureChainPrefix parameter allowed lay tree leafIdx + chainIdx (encoding chainIdx)).bind fun _ => + preservesChainInvariant_pure parameter allowed + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem preservesChainInvariant_maskedOtsSign + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + PreservesChainInvariant parameter allowed + (maskedOtsSign parameter lay tree leafIdx message) := + preservesChainInvariant_maskedOtsSignFrom parameter allowed lay tree leafIdx message + encodingAttemptLimit 0 + +theorem preservesChainInvariant_maskedLayerMessage + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + PreservesChainInvariant parameter allowed + (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + split + · exact preservesChainInvariant_maskedTreeRoot parameter allowed _ _ + · exact preservesChainInvariant_ordinaryFtsKey parameter allowed index (ftsSecret index) + +theorem preservesChainInvariant_maskedSignLayer + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + PreservesChainInvariant parameter allowed + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + exact (preservesChainInvariant_maskedLayerMessage parameter allowed ftsSecret index lay).bind + fun message => + (preservesChainInvariant_maskedOtsSign parameter allowed lay (treeIndexAt index lay) + (leafIndexAt index lay) message).bind fun result => + match result with + | none => preservesChainInvariant_pure parameter allowed none + | some part => + (preservesChainInvariant_ensureTreePath parameter allowed lay + (treeIndexAt index lay) (leafIndexAt index lay)).bind fun _ => + preservesChainInvariant_pure parameter allowed (some part) + +theorem chainInvariant_of_mem_runRaw_maskedSignLayer + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (part : Option (Counter × (ChainIndex → Digit))) + (hinvariant : ChainInvariant parameter allowed state cache) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (part, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((maskedSignLayer parameter ftsSecret index lay).run cache))) : + ChainInvariant parameter allowed finalState finalCache := + preservesChainInvariant_maskedSignLayer parameter allowed ftsSecret index lay state cache fuel + finalState remaining part finalCache hinvariant hresult + +@[irreducible] noncomputable def maskedSignLayerAt + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) + (Option (Counter × (ChainIndex → Digit))) := + maskedSignLayer parameter ftsSecret index lay + +theorem maskedSignLayerAt_eq + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + maskedSignLayerAt parameter ftsSecret index lay = + maskedSignLayer parameter ftsSecret index lay := by + unfold maskedSignLayerAt + rfl + +@[irreducible] noncomputable def maskedSignLayers + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) : + StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) + (Layer → Option (Counter × (ChainIndex → Digit))) := + sequenceFin (maskedSignLayerAt parameter ftsSecret index) + +theorem maskedSignLayers_eq + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) : + maskedSignLayers parameter ftsSecret index = + sequenceFin (maskedSignLayerAt parameter ftsSecret index) := by + unfold maskedSignLayers + rfl + +theorem maskedSignLayers_eq_sequenceFin + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) : + maskedSignLayers parameter ftsSecret index = + sequenceFin fun lay => maskedSignLayer parameter ftsSecret index lay := by + rw [maskedSignLayers_eq] + congr 1 + funext lay + exact maskedSignLayerAt_eq parameter ftsSecret index lay + +theorem preservesChainInvariant_maskedSignLayerAt + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + PreservesChainInvariant parameter allowed + (maskedSignLayerAt parameter ftsSecret index lay) := by + rw [maskedSignLayerAt_eq] + exact preservesChainInvariant_maskedSignLayer parameter allowed ftsSecret index lay + +theorem preservesChainInvariant_maskedSignLayers + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) : + PreservesChainInvariant parameter allowed + (maskedSignLayers parameter ftsSecret index) := by + rw [maskedSignLayers_eq] + exact preservesChainInvariant_sequenceFin parameter allowed _ + (preservesChainInvariant_maskedSignLayerAt parameter allowed ftsSecret index) + +theorem chainInvariant_of_mem_runRaw_maskedSignLayers + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (layers : Layer → Option (Counter × (ChainIndex → Digit))) + (hinvariant : ChainInvariant parameter allowed state cache) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (layers, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((maskedSignLayers parameter ftsSecret index).run cache))) : + ChainInvariant parameter allowed finalState finalCache := by + have hpreserves := preservesChainInvariant_maskedSignLayers parameter allowed ftsSecret index + unfold PreservesChainInvariant at hpreserves + exact hpreserves state cache fuel finalState remaining layers finalCache hinvariant hresult + +theorem ordinaryCacheIncreasing_maskedTreeNode + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) : + OrdinaryCacheIncreasing (maskedTreeNode lay tree level nodeIdx) := by + cases level with + | zero => + rw [maskedTreeNode] + exact (SplitCachePreserving.ordinaryCacheIncreasing + (splitCachePreserving_ensureTreeNode lay tree 0 nodeIdx)).bind fun _ => + ordinaryCacheIncreasing_revealCoordinate _ + | succ current => + rw [maskedTreeNode] + exact (SplitCachePreserving.ordinaryCacheIncreasing + (splitCachePreserving_ensureTreeNode lay tree (current + 1) nodeIdx)).bind fun _ => by + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact ordinaryCacheIncreasing_revealCoordinate _ + · rw [dif_neg hlevel] + exact OrdinaryCacheIncreasing.pure 0 + +theorem ordinaryCacheIncreasing_maskedTreeRoot (lay : Layer) (tree : TreeIndex) : + OrdinaryCacheIncreasing (maskedTreeRoot lay tree) := + ordinaryCacheIncreasing_maskedTreeNode lay tree (layerHeight lay) 0 + +def maskedTreeRootLevel (lay : Layer) : Fin maxLayerHeight := + ⟨layerHeight lay - 1, by + have hpos : 0 < layerHeight lay := by + unfold layerHeight + split <;> norm_num [maxLayerHeight] + have hle := layerHeight_le lay + omega⟩ + +def maskedTreeRootCoordinate (lay : Layer) (tree : TreeIndex) : Coordinate := + .position (.node lay tree (maskedTreeRootLevel lay) 0) + +theorem mem_runRaw_maskedTreeRoot_hidden + (lay : Layer) (tree : TreeIndex) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : Digest) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel ((maskedTreeRoot lay tree).run cache))) : + ∃ output : HashOutput, + value = truncateHash output ∧ + finalState.values (maskedTreeRootCoordinate lay tree) = some output ∧ + finalCache (.hidden (maskedTreeRootCoordinate lay tree)) = some output := by + have hpos : 0 < layerHeight lay := by + unfold layerHeight + split <;> norm_num [maxLayerHeight] + have hlevel : layerHeight lay - 1 < maxLayerHeight := by + have hle := layerHeight_le lay + omega + unfold maskedTreeRoot at hresult + rw [show layerHeight lay = (layerHeight lay - 1) + 1 by omega, maskedTreeNode, + dif_pos hlevel] at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hensured, hreveal⟩ := hresult + cases raw with + | stopped hit => simp at hreveal + | done ensuredState ensuredRemaining ensuredResult => + rcases ensuredResult with ⟨ensuredUnit, ensuredCache⟩ + have hcache := splitCachePreserving_ensureTreeNode lay tree (layerHeight lay - 1 + 1) 0 + state cache fuel ensuredState ensuredRemaining ensuredUnit ensuredCache hensured + subst ensuredCache + simp only at hreveal + rw [revealPosition_run, LazyRevealProbe.revealQuery, + LazyRevealProbe.runRaw_reveal_query_bind] at hreveal + let coordinate : Coordinate := + .position (.node lay tree ⟨layerHeight lay - 1, hlevel⟩ (leafOfNat 0)) + cases hvalue : ensuredState.values coordinate with + | some output => + rw [hvalue] at hreveal + simp [LazyRevealProbe.runRaw] at hreveal + rcases hreveal with ⟨rfl, rfl, rfl, rfl⟩ + have hleaf : leafOfNat 0 = (0 : LeafIndex) := by + apply Fin.ext + simp [leafOfNat] + exact ⟨output, rfl, by + change finalState.values coordinate = some output + exact hvalue, by + simp [Function.update, maskedTreeRootCoordinate, maskedTreeRootLevel, hleaf]⟩ + | none => + rw [hvalue, mem_support_bind_iff] at hreveal + obtain ⟨output, _, hsampled⟩ := hreveal + by_cases hhit : ensuredState.hitAt coordinate output + · rw [if_pos hhit] at hsampled + simp at hsampled + · rw [if_neg hhit] at hsampled + simp [LazyRevealProbe.runRaw] at hsampled + rcases hsampled with ⟨rfl, rfl, rfl, rfl⟩ + have hleaf : leafOfNat 0 = (0 : LeafIndex) := by + apply Fin.ext + simp [leafOfNat] + exact ⟨output, rfl, by + simp [LazyRevealProbe.State.materialize, Function.update, + maskedTreeRootCoordinate, maskedTreeRootLevel, hleaf], by + simp [Function.update, maskedTreeRootCoordinate, maskedTreeRootLevel, hleaf]⟩ + +theorem maskedTreeRoot_eq_actual + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (lay : Layer) (tree : TreeIndex) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : Digest) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((maskedTreeRoot lay tree).run cache))) : + value = evalWithAnswerFn f + (treeRoot parameter lay tree (tableOtsSecret table lay tree)) := by + obtain ⟨output, hvalue, hstateValue, _⟩ := mem_runRaw_maskedTreeRoot_hidden lay tree state + finalState cache finalCache fuel remaining value hresult + have houtput := htable _ output hstateValue + have hpositive : 0 < layerHeight lay := by + unfold layerHeight + split <;> norm_num [maxLayerHeight] + have hlevel : layerHeight lay - 1 < maxLayerHeight := by + have hle := layerHeight_le lay + omega + have hspan : 2 ^ ((layerHeight lay - 1) + 1) * (0 + 1) ≤ + 2 ^ maxLayerHeight := by + rw [show layerHeight lay - 1 + 1 = layerHeight lay by omega] + simpa only [Nat.zero_add, Nat.mul_one] using + Nat.pow_le_pow_right (by omega : 0 < 2) (layerHeight_le lay) + have hnode := honestNode_eq_table_succ f parameter table lay tree hrealizes + (layerHeight lay - 1) 0 hlevel hspan + rw [show layerHeight lay - 1 + 1 = layerHeight lay by omega] at hnode + change value = honestNode f parameter lay tree (tableOtsSecret table lay tree) + (layerHeight lay) 0 + rw [hvalue, houtput] + simpa [tableValue, maskedTreeRootCoordinate, maskedTreeRootLevel, leafOfNat] using hnode.symm + +theorem ordinaryCacheIncreasing_maskedOtsSignFrom + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) : ∀ attempts counter, + OrdinaryCacheIncreasing + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => OrdinaryCacheIncreasing.pure none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + exact (ordinaryCacheIncreasing_simulateQ_ordinaryHashImpl + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter))).bind fun encoded => + match encoded with + | none => ordinaryCacheIncreasing_maskedOtsSignFrom parameter lay tree leafIdx + message attempts (counter + 1) + | some encoding => + (ordinaryCacheIncreasing_sequenceFin _ fun chainIdx => + (splitCachePreserving_ensureChainPrefix lay tree leafIdx chainIdx + (encoding chainIdx)).ordinaryCacheIncreasing).bind fun _ => + OrdinaryCacheIncreasing.pure _ + +theorem ordinaryCacheIncreasing_maskedOtsSign + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) : + OrdinaryCacheIncreasing (maskedOtsSign parameter lay tree leafIdx message) := + ordinaryCacheIncreasing_maskedOtsSignFrom parameter lay tree leafIdx message + encodingAttemptLimit 0 + +theorem ordinaryCacheIncreasing_maskedLayerMessage + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + OrdinaryCacheIncreasing (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + split + · exact ordinaryCacheIncreasing_maskedTreeRoot _ _ + · exact ordinaryCacheIncreasing_simulateQ_ordinaryHashImpl + (ftsKey parameter index (ftsSecret index)) + +theorem ordinaryCacheIncreasing_maskedSignLayer + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + OrdinaryCacheIncreasing (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + exact (ordinaryCacheIncreasing_maskedLayerMessage parameter ftsSecret index lay).bind + fun _ => (ordinaryCacheIncreasing_maskedOtsSign parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) _).bind fun result => + match result with + | none => OrdinaryCacheIncreasing.pure none + | some part => + ((splitCachePreserving_ensureTreePath lay (treeIndexAt index lay) + (leafIndexAt index lay)).ordinaryCacheIncreasing).bind fun _ => + OrdinaryCacheIncreasing.pure (some part) + +theorem ordinaryCacheIncreasing_maskedSignLayers + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) : OrdinaryCacheIncreasing (maskedSignLayers parameter ftsSecret index) := by + rw [maskedSignLayers_eq] + exact ordinaryCacheIncreasing_sequenceFin _ fun lay => by + rw [maskedSignLayerAt_eq] + exact ordinaryCacheIncreasing_maskedSignLayer parameter ftsSecret index lay + +theorem maskedSignLayers_component_run + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (layers : Layer → Option (Counter × (ChainIndex → Digit))) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (layers, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((maskedSignLayers parameter ftsSecret index).run cache))) + (lay : Layer) : + ∃ (componentState componentFinalState : LazyRevealProbe.State Coordinate) + (componentCache componentFinalCache : SplitHashCache) + (componentFuel componentRemaining : Nat) + (part : Option (Counter × (ChainIndex → Digit))), + LazyRevealProbe.RawResult.done componentFinalState componentRemaining + (part, componentFinalCache) ∈ support + (LazyRevealProbe.runRaw componentState componentFuel + ((maskedSignLayerAt parameter ftsSecret index lay).run componentCache)) + ∧ layers lay = part + ∧ LazyRevealProbe.ValuesLE componentFinalState finalState + ∧ LazyRevealProbe.EnsuredLE componentFinalState finalState + ∧ ordinaryQueryCache componentFinalCache ≤ ordinaryQueryCache finalCache := by + rw [maskedSignLayers_eq] at hresult + exact sequenceFin_component_run_of_done + (computation := maskedSignLayerAt parameter ftsSecret index) + (hincreasing := fun position => by + rw [maskedSignLayerAt_eq] + exact ordinaryCacheIncreasing_maskedSignLayer parameter ftsSecret index position) + (state := state) (finalState := finalState) (cache := cache) (finalCache := finalCache) + (fuel := fuel) (remaining := remaining) (values := layers) hresult lay + +noncomputable def maskedOtsLayerAfterMessage + (parameter : PublicParameter) (index : Index) (lay : Layer) (message : Digest) : + StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) + (Option (Counter × (ChainIndex → Digit))) := do + let result ← maskedOtsSign parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message + match result with + | none => pure none + | some (counter, encoding) => do + ensureTreePath lay (treeIndexAt index lay) (leafIndexAt index lay) + pure (some (counter, encoding)) + +theorem ordinaryCacheIncreasing_maskedSignLayerAfterMessage + (parameter : PublicParameter) (index : Index) (lay : Layer) (message : Digest) : + OrdinaryCacheIncreasing (maskedOtsLayerAfterMessage parameter index lay message) := by + unfold maskedOtsLayerAfterMessage + exact + (ordinaryCacheIncreasing_maskedOtsSign parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message).bind fun result => + match result with + | none => OrdinaryCacheIncreasing.pure none + | some (counter, encoding) => + ((splitCachePreserving_ensureTreePath lay (treeIndexAt index lay) + (leafIndexAt index lay)).ordinaryCacheIncreasing).bind fun _ => + OrdinaryCacheIncreasing.pure (some (counter, encoding)) + +theorem maskedTreeRoot_eq_layerMessage_of_lt + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay below : Layer) (hbelow : lay.val + 1 < numLayers) + (hbelowEq : below = ⟨lay.val + 1, hbelow⟩) + (state finalState referenceState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : Digest) + (hle : LazyRevealProbe.ValuesLE finalState referenceState) + (htable : ∀ coordinate output, referenceState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((maskedTreeRoot below (treeIndexAt index below)).run cache))) : + value = evalWithAnswerFn f + (layerMessage (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + index lay) := by + have htableFinal : ∀ coordinate output, + finalState.values coordinate = some output → output = table coordinate := + fun coordinate output hvalue => htable coordinate output (hle coordinate output hvalue) + have hroot := maskedTreeRoot_eq_actual + (f := f) (parameter := parameter) (table := table) (lay := below) + (tree := treeIndexAt index below) (state := state) (finalState := finalState) + (cache := cache) (finalCache := finalCache) (fuel := fuel) (remaining := remaining) + (value := value) htableFinal hrealizes hresult + rw [layerMessage_of_lt _ _ _ hbelow] + rw [← hbelowEq] + exact hroot + +theorem maskedLayerMessage_eq_actual_of_not_lt + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) (hbelow : ¬lay.val + 1 < numLayers) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (value : Digest) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((maskedLayerMessage parameter ftsSecret index lay).run cache))) : + value = evalWithAnswerFn f + (layerMessage (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + index lay) := by + unfold maskedLayerMessage at hresult + rw [dif_neg hbelow] at hresult + have heval := replay_of_mem_runRaw_ordinaryHashImpl_of_stable f parameter + (ftsKey parameter index (ftsSecret index)) state finalState cache finalCache fuel remaining + value hf (queriesStable_ftsKey f parameter index (ftsSecret index)) hresult + rw [layerMessage, dif_neg hbelow] + exact heval.1.symm + +theorem maskedSignLayerAfterMessage_some_eval + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (index : Index) (lay : Layer) + (message actualMessage : Digest) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (counter : Counter) (encoding : ChainIndex → Digit) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (hmessage : message = actualMessage) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (some (counter, encoding), finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedOtsLayerAfterMessage parameter index lay message).run cache))) : + evalWithAnswerFn f + (encode parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + actualMessage counter) = some encoding := by + unfold maskedOtsLayerAfterMessage at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨otsRaw, hots, hafterOts⟩ := hresult + cases otsRaw with + | stopped stoppedHit => simp at hafterOts + | done otsState otsRemaining otsResult => + rcases otsResult with ⟨part, otsCache⟩ + cases part with + | none => simp [LazyRevealProbe.runRaw] at hafterOts + | some selectedPart => + rcases selectedPart with ⟨selectedCounter, selectedEncoding⟩ + simp only at hafterOts + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterOts + obtain ⟨pathRaw, hpath, hfinish⟩ := hafterOts + cases pathRaw with + | stopped stoppedHit => simp at hfinish + | done pathState pathRemaining pathResult => + rcases pathResult with ⟨pathUnit, pathCache⟩ + have hpathCache := splitCachePreserving_ensureTreePath lay + (treeIndexAt index lay) (leafIndexAt index lay) otsState otsCache otsRemaining + pathState pathRemaining pathUnit pathCache hpath + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, hpart, rfl⟩ + obtain ⟨hcounter, hencoding⟩ := hpart + subst selectedCounter + subst selectedEncoding + rw [hpathCache] at hf + have hencoded := maskedOtsSign_some_eval f parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) message state otsState cache + otsCache fuel otsRemaining counter encoding hf hots + rw [hmessage] at hencoded + exact hencoded + +theorem maskedLayerMessage_eq_of_lt + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) (hbelow : lay.val + 1 < numLayers) : + maskedLayerMessage parameter ftsSecret index lay = + maskedTreeRoot ⟨lay.val + 1, hbelow⟩ + (treeIndexAt index ⟨lay.val + 1, hbelow⟩) := by + unfold maskedLayerMessage + rw [dif_pos hbelow] + +theorem maskedLayerMessage_eq_of_lt' + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay below : Layer) (hbelow : lay.val + 1 < numLayers) + (hbelowEq : below = ⟨lay.val + 1, hbelow⟩) : + maskedLayerMessage parameter ftsSecret index lay = + maskedTreeRoot below (treeIndexAt index below) := by + subst below + exact maskedLayerMessage_eq_of_lt parameter ftsSecret index lay hbelow + +theorem maskedLayerMessage_eq_actual_of_lt + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay below : Layer) (hbelow : lay.val + 1 < numLayers) + (hbelowEq : below = ⟨lay.val + 1, hbelow⟩) + (state messageState referenceState : LazyRevealProbe.State Coordinate) + (cache messageCache : SplitHashCache) (fuel messageRemaining : Nat) + (message : Digest) + (hle : LazyRevealProbe.ValuesLE messageState referenceState) + (htable : ∀ coordinate output, referenceState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hmessage : LazyRevealProbe.RawResult.done messageState messageRemaining + (message, messageCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedLayerMessage parameter ftsSecret index lay).run cache))) : + message = evalWithAnswerFn f + (layerMessage (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + index lay) := by + rw [maskedLayerMessage_eq_of_lt' parameter ftsSecret index lay below hbelow hbelowEq] at hmessage + exact maskedTreeRoot_eq_layerMessage_of_lt + (f := f) (parameter := parameter) (root := root) (table := table) + (ftsSecret := ftsSecret) (index := index) (lay := lay) (below := below) + (hbelow := hbelow) (hbelowEq := hbelowEq) (state := state) + (finalState := messageState) (referenceState := referenceState) (cache := cache) + (finalCache := messageCache) (fuel := fuel) (remaining := messageRemaining) + (value := message) hle htable hrealizes hmessage + +theorem maskedSignLayerParts_some_eval_of_lt + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay below : Layer) (hbelow : lay.val + 1 < numLayers) + (hbelowEq : below = ⟨lay.val + 1, hbelow⟩) + (state messageState finalState : LazyRevealProbe.State Coordinate) + (cache messageCache finalCache : SplitHashCache) (fuel messageRemaining remaining : Nat) + (message : Digest) (counter : Counter) (encoding : ChainIndex → Digit) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hmessage : LazyRevealProbe.RawResult.done messageState messageRemaining + (message, messageCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedLayerMessage parameter ftsSecret index lay).run cache))) + (hafter : LazyRevealProbe.RawResult.done finalState remaining + (some (counter, encoding), finalCache) ∈ support + (LazyRevealProbe.runRaw messageState messageRemaining + ((maskedOtsLayerAfterMessage parameter index lay message).run messageCache))) : + evalWithAnswerFn f + (encode parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f + (layerMessage (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + index lay)) counter) = some encoding := by + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((maskedOtsLayerAfterMessage parameter index lay message).run messageCache) + messageState finalState messageRemaining remaining + (some (counter, encoding), finalCache) hafter + have hmessageActual := maskedLayerMessage_eq_actual_of_lt + (f := f) (parameter := parameter) (root := root) (table := table) + (ftsSecret := ftsSecret) (index := index) (lay := lay) (below := below) + (hbelow := hbelow) (hbelowEq := hbelowEq) (state := state) + (messageState := messageState) (referenceState := finalState) + (cache := cache) (messageCache := messageCache) (fuel := fuel) + (messageRemaining := messageRemaining) (message := message) hvaluesLE htable hrealizes hmessage + exact maskedSignLayerAfterMessage_some_eval + (f := f) (parameter := parameter) (index := index) (lay := lay) (message := message) + (actualMessage := _) (state := messageState) (finalState := finalState) + (cache := messageCache) (finalCache := finalCache) (fuel := messageRemaining) + (remaining := remaining) (counter := counter) (encoding := encoding) hf hmessageActual hafter + +theorem maskedSignLayer_some_eval_of_lt + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) (hbelow : lay.val + 1 < numLayers) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (counter : Counter) (encoding : ChainIndex → Digit) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (some (counter, encoding), finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedSignLayer parameter ftsSecret index lay).run cache))) : + evalWithAnswerFn f + (encode parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f + (layerMessage (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + index lay)) counter) = some encoding := by + unfold maskedSignLayer at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨messageRaw, hmessage, hafterMessage⟩ := hresult + cases messageRaw with + | stopped stoppedHit => simp at hafterMessage + | done messageState messageRemaining messageResult => + rcases messageResult with ⟨message, messageCache⟩ + simp only at hafterMessage + change LazyRevealProbe.RawResult.done finalState remaining + (some (counter, encoding), finalCache) ∈ support + (LazyRevealProbe.runRaw messageState messageRemaining + ((maskedOtsLayerAfterMessage parameter index lay message).run messageCache)) at hafterMessage + let below : Layer := ⟨lay.val + 1, hbelow⟩ + exact maskedSignLayerParts_some_eval_of_lt + (f := f) (parameter := parameter) (root := root) (table := table) + (ftsSecret := ftsSecret) (index := index) (lay := lay) (below := below) + (hbelow := hbelow) (hbelowEq := rfl) + (state := state) (messageState := messageState) (finalState := finalState) + (cache := cache) (messageCache := messageCache) (finalCache := finalCache) + (fuel := fuel) (messageRemaining := messageRemaining) (remaining := remaining) + (message := message) (counter := counter) (encoding := encoding) hf htable hrealizes + hmessage hafterMessage + +theorem maskedSignLayer_some_eval_of_not_lt + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) (hbelow : ¬lay.val + 1 < numLayers) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (counter : Counter) (encoding : ChainIndex → Digit) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (some (counter, encoding), finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedSignLayer parameter ftsSecret index lay).run cache))) : + evalWithAnswerFn f + (encode parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f + (layerMessage (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + index lay)) counter) = some encoding := by + unfold maskedSignLayer at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨messageRaw, hmessage, hafterMessage⟩ := hresult + cases messageRaw with + | stopped stoppedHit => simp at hafterMessage + | done messageState messageRemaining messageResult => + rcases messageResult with ⟨message, messageCache⟩ + simp only at hafterMessage + change LazyRevealProbe.RawResult.done finalState remaining + (some (counter, encoding), finalCache) ∈ support + (LazyRevealProbe.runRaw messageState messageRemaining + ((maskedOtsLayerAfterMessage parameter index lay message).run messageCache)) at hafterMessage + have hordinaryLE := ordinaryCacheIncreasing_maskedSignLayerAfterMessage parameter index lay + message messageState messageCache messageRemaining finalState remaining + (some (counter, encoding)) finalCache hafterMessage + have hfMessage : StableCacheAgreesWithFn parameter messageCache f := + fun input output hstable hcached => hf input output hstable (hordinaryLE hcached) + have hmessageActual := maskedLayerMessage_eq_actual_of_not_lt f parameter root table + ftsSecret index lay hbelow state messageState cache messageCache fuel messageRemaining + message hfMessage hmessage + exact maskedSignLayerAfterMessage_some_eval f parameter index lay message _ messageState + finalState messageCache finalCache messageRemaining remaining counter encoding hf + hmessageActual hafterMessage + +def HonestLayerParts (f : QueryImpl HashSpec Id) (secretKey : SecretKey) (index : Index) + (parts : Layer → Counter × (ChainIndex → Digit)) : Prop := + ∀ lay, evalWithAnswerFn f + (encode secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f (layerMessage secretKey index lay)) (parts lay).1) = + some (parts lay).2 + +theorem maskedSignLayers_parts_eval + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (layers : Layer → Option (Counter × (ChainIndex → Digit))) + (parts : Layer → Counter × (ChainIndex → Digit)) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (layers, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((maskedSignLayers parameter ftsSecret index).run cache))) + (hparts : traverseOption layers = some parts) : + HonestLayerParts f + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) index parts := by + intro lay + obtain ⟨componentState, componentFinalState, componentCache, componentFinalCache, + componentFuel, componentRemaining, part, hcomponent, hselected, hvaluesLE, _, hcacheLE⟩ := + maskedSignLayers_component_run parameter ftsSecret index state finalState cache finalCache + fuel remaining layers hresult lay + have hpartsAt := traverseOption_eq_some_apply layers parts hparts lay + have hpart : part = some (parts lay) := hselected.symm.trans hpartsAt + have hcomponent' := hcomponent + rw [hpart, maskedSignLayerAt_eq] at hcomponent' + have hfComponent : StableCacheAgreesWithFn parameter componentFinalCache f := + fun input output hstable hcached => hf input output hstable (hcacheLE hcached) + have htableComponent : ∀ coordinate output, + componentFinalState.values coordinate = some output → output = table coordinate := + fun coordinate output hvalue => htable coordinate output + (hvaluesLE coordinate output hvalue) + by_cases hbelow : lay.val + 1 < numLayers + · exact maskedSignLayer_some_eval_of_lt f parameter root table ftsSecret index lay hbelow + componentState componentFinalState componentCache componentFinalCache componentFuel + componentRemaining (parts lay).1 (parts lay).2 hfComponent htableComponent hrealizes + hcomponent' + · exact maskedSignLayer_some_eval_of_not_lt f parameter root table ftsSecret index lay hbelow + componentState componentFinalState componentCache componentFinalCache componentFuel + componentRemaining (parts lay).1 (parts lay).2 hfComponent hcomponent' + +theorem ordinaryCacheIncreasing_revealLayerValues + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + OrdinaryCacheIncreasing (revealLayerValues index lay encoding) := by + unfold revealLayerValues + exact (ordinaryCacheIncreasing_sequenceFin _ fun chainIdx => + ordinaryCacheIncreasing_revealPublishedCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx))).bind fun _ => + (ordinaryCacheIncreasing_sequenceFin _ fun level => by + split + · cases hlevelValue : level.val with + | zero => exact ordinaryCacheIncreasing_revealPublishedCoordinate _ + | succ current => + rw [show current + 1 = Nat.succ current by omega] + change OrdinaryCacheIncreasing + (if hlevel : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hlevel⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0) + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact ordinaryCacheIncreasing_revealPublishedCoordinate _ + · rw [dif_neg hlevel] + exact OrdinaryCacheIncreasing.pure 0 + · exact OrdinaryCacheIncreasing.pure 0).bind fun _ => OrdinaryCacheIncreasing.pure _ + +theorem ordinaryCacheIncreasing_maskedSignAfterDigest + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + OrdinaryCacheIncreasing + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest + exact (ordinaryCacheIncreasing_simulateQ_ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index))).bind fun _ => + (ordinaryCacheIncreasing_sequenceFin _ fun lay => + ordinaryCacheIncreasing_maskedSignLayer parameter ftsSecret index lay).bind fun layers => + match hparts : traverseOption layers with + | none => OrdinaryCacheIncreasing.pure none + | some parts => + (ordinaryCacheIncreasing_sequenceFin _ fun lay => + ordinaryCacheIncreasing_revealLayerValues index lay (parts lay).2).bind fun _ => + OrdinaryCacheIncreasing.pure _ + +theorem ordinaryCacheIncreasing_maskedSign + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + OrdinaryCacheIncreasing (maskedSign parameter root ftsSecret message) := by + unfold maskedSign + exact (ordinaryCacheIncreasing_ordinarySignDigestLoop digestAttemptLimit + (⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ : SecretKey) message).bind fun selected => + match selected with + | none => OrdinaryCacheIncreasing.pure none + | some data => ordinaryCacheIncreasing_maskedSignAfterDigest parameter ftsSecret + data.1 data.2.1 data.2.2 + +theorem ordinaryEntryPreservingImpl_maskedSigningImpl + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (input : HashInput) : + OrdinaryEntryPreservingImpl input (maskedSigningImpl parameter root ftsSecret) := by + intro message + exact (ordinaryCacheIncreasing_maskedSign parameter root ftsSecret message).entryPreserving + input + +theorem ordinaryEntryPreservingImpl_maskedExpandedAdversaryImpl + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (input : HashInput) + (hstable : StableOrdinaryInput parameter input) : + OrdinaryEntryPreservingImpl input + (maskedExpandedAdversaryImpl parameter root ftsSecret) := by + intro query + cases query with + | inl query => exact ordinaryEntryPreservingImpl_probingRomImpl parameter input hstable query + | inr query => + exact ordinaryEntryPreservingImpl_maskedSigningImpl parameter root ftsSecret input query + +theorem preservesChainValid_revealPublishedCoordinate + (allowed : Coordinate → Prop) (coordinate : Coordinate) + (hallowed : IsChainCoordinate coordinate → allowed coordinate) : + PreservesChainValid allowed (revealPublishedCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hvalid hresult + unfold revealPublishedCoordinate at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hreveal, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done revealState revealRemaining revealResult => + rcases revealResult with ⟨revealedValue, revealCache⟩ + have hrevealShape : + (state.values coordinate ≠ none ∧ revealState = state) ∨ + ∃ output, revealState = state.materialize coordinate output := by + change LazyRevealProbe.RawResult.done revealState revealRemaining + (revealedValue, revealCache) ∈ support + (LazyRevealProbe.runRaw state fuel ((revealCoordinate coordinate).run cache)) at hreveal + rw [revealCoordinate_run, LazyRevealProbe.revealQuery, + LazyRevealProbe.runRaw_reveal_query_bind] at hreveal + cases hvalue : state.values coordinate with + | some existing => + rw [hvalue] at hreveal + simp [LazyRevealProbe.runRaw] at hreveal + rcases hreveal with ⟨rfl, rfl, rfl, rfl⟩ + exact Or.inl ⟨by simp, rfl⟩ + | none => + rw [hvalue, mem_support_bind_iff] at hreveal + obtain ⟨sampled, _, hsampled⟩ := hreveal + by_cases hhit : state.hitAt coordinate sampled + · rw [if_pos hhit] at hsampled + simp at hsampled + · rw [if_neg hhit] at hsampled + simp [LazyRevealProbe.runRaw] at hsampled + rcases hsampled with ⟨rfl, rfl, rfl, rfl⟩ + exact Or.inr ⟨sampled, rfl⟩ + simp only at hrest + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hrest + obtain ⟨publishRaw, hpublish, hfinish⟩ := hrest + cases publishRaw with + | stopped hit => simp at hfinish + | done publishState publishRemaining publishResult => + rcases publishResult with ⟨publishedUnit, publishCache⟩ + change LazyRevealProbe.RawResult.done publishState publishRemaining + (publishedUnit, publishCache) ∈ support + (LazyRevealProbe.runRaw revealState revealRemaining + (LazyRevealProbe.publishQuery coordinate >>= fun output => + pure (output, revealCache))) at hpublish + rw [LazyRevealProbe.publishQuery, + LazyRevealProbe.runRaw_publish_query_bind] at hpublish + simp [LazyRevealProbe.runRaw] at hpublish + rcases hpublish with ⟨rfl, rfl, rfl, rfl⟩ + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + rcases hrevealShape with ⟨hvalue, rfl⟩ | ⟨output, rfl⟩ + · exact hvalid.publish coordinate hvalue hallowed + · exact hvalid.materialize_publish coordinate output hallowed + +theorem preservesChainInvariant_revealPublishedCoordinate + (parameter : PublicParameter) (allowed : Coordinate → Prop) (coordinate : Coordinate) + (hallowed : IsChainCoordinate coordinate → allowed coordinate) : + PreservesChainInvariant parameter allowed (revealPublishedCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hinvariant hresult + have hfinalValid := preservesChainValid_revealPublishedCoordinate allowed coordinate hallowed + state cache fuel finalState remaining value finalCache hinvariant.1 hresult + unfold revealPublishedCoordinate at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hreveal, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done revealState revealRemaining revealResult => + rcases revealResult with ⟨revealedValue, revealCache⟩ + have hrevealShape : + (∃ output, state.values coordinate = some output ∧ + revealedValue = truncateHash output ∧ revealState = state ∧ + revealCache = Function.update cache (.hidden coordinate) (some output)) ∨ + ∃ output, revealedValue = truncateHash output ∧ + revealState = state.materialize coordinate output ∧ + revealCache = Function.update cache (.hidden coordinate) (some output) := by + rw [revealCoordinate_run, LazyRevealProbe.revealQuery, + LazyRevealProbe.runRaw_reveal_query_bind] at hreveal + cases hvalue : state.values coordinate with + | some existing => + rw [hvalue] at hreveal + simp [LazyRevealProbe.runRaw] at hreveal + rcases hreveal with ⟨rfl, rfl, rfl, rfl⟩ + exact Or.inl ⟨existing, rfl, rfl, rfl, rfl⟩ + | none => + rw [hvalue, mem_support_bind_iff] at hreveal + obtain ⟨output, _, hsampled⟩ := hreveal + by_cases hhit : state.hitAt coordinate output + · rw [if_pos hhit] at hsampled + simp at hsampled + · rw [if_neg hhit] at hsampled + simp [LazyRevealProbe.runRaw] at hsampled + rcases hsampled with ⟨rfl, rfl, rfl, rfl⟩ + exact Or.inr ⟨output, rfl, rfl, rfl⟩ + simp only at hrest + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hrest + obtain ⟨publishRaw, hpublish, hfinish⟩ := hrest + cases publishRaw with + | stopped hit => simp at hfinish + | done publishState publishRemaining publishResult => + rcases publishResult with ⟨publishedUnit, publishCache⟩ + change LazyRevealProbe.RawResult.done publishState publishRemaining + (publishedUnit, publishCache) ∈ support + (LazyRevealProbe.runRaw revealState revealRemaining + (LazyRevealProbe.publishQuery coordinate >>= fun output => + pure (output, revealCache))) at hpublish + rw [LazyRevealProbe.publishQuery, + LazyRevealProbe.runRaw_publish_query_bind] at hpublish + simp [LazyRevealProbe.runRaw] at hpublish + rcases hpublish with ⟨rfl, rfl, rfl, rfl⟩ + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + refine ⟨hfinalValid, ?_⟩ + rcases hrevealShape with ⟨output, hvalue, rfl, rfl, rfl⟩ | + ⟨output, rfl, rfl, rfl⟩ + · exact (hinvariant.2.updateHidden coordinate output).publish coordinate + · exact (hinvariant.2.updateHidden coordinate output).materialize_publish + coordinate output hallowed + +def PublishedByParts (index : Index) + (parts : Layer → Counter × (ChainIndex → Digit)) + (coordinate : Coordinate) : Prop := + ∃ lay chainIdx, + coordinate = chainValueCoordinate lay (treeIndexAt index lay) + (leafIndexAt index lay) chainIdx ((parts lay).2 chainIdx) + +theorem publishedByParts_selected (index : Index) + (parts : Layer → Counter × (ChainIndex → Digit)) + (lay : Layer) (chainIdx : ChainIndex) : + PublishedByParts index parts + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx ((parts lay).2 chainIdx)) := + ⟨lay, chainIdx, rfl⟩ + +theorem preservesChainValid_revealLayerValues (allowed : Coordinate → Prop) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) + (hallowed : ∀ chainIdx, allowed (chainValueCoordinate lay (treeIndexAt index lay) + (leafIndexAt index lay) chainIdx (encoding chainIdx))) : + PreservesChainValid allowed (revealLayerValues index lay encoding) := by + unfold revealLayerValues + exact (preservesChainValid_sequenceFin allowed _ fun chainIdx => + preservesChainValid_revealPublishedCoordinate allowed + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx)) (fun _ => hallowed chainIdx)).bind fun values => + (preservesChainValid_sequenceFin allowed _ fun level => by + split + · cases hlevelValue : level.val with + | zero => + exact preservesChainValid_revealPublishedCoordinate allowed _ + (by simp [IsChainCoordinate]) + | succ current => + rw [show current + 1 = Nat.succ current by omega] + change PreservesChainValid allowed + (if hlevel : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hlevel⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0) + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact preservesChainValid_revealPublishedCoordinate allowed _ + (by simp [IsChainCoordinate]) + · rw [dif_neg hlevel] + exact preservesChainValid_pure allowed 0 + · exact preservesChainValid_pure allowed 0).bind fun path => + preservesChainValid_pure allowed (values, path) + +theorem preservesChainInvariant_revealLayerValues + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) + (hallowed : ∀ chainIdx, allowed (chainValueCoordinate lay (treeIndexAt index lay) + (leafIndexAt index lay) chainIdx (encoding chainIdx))) : + PreservesChainInvariant parameter allowed (revealLayerValues index lay encoding) := by + unfold revealLayerValues + exact (preservesChainInvariant_sequenceFin parameter allowed _ fun chainIdx => + preservesChainInvariant_revealPublishedCoordinate parameter allowed + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx)) (fun _ => hallowed chainIdx)).bind fun values => + (preservesChainInvariant_sequenceFin parameter allowed _ fun level => by + split + · cases hlevelValue : level.val with + | zero => + exact preservesChainInvariant_revealPublishedCoordinate parameter allowed _ + (by simp [IsChainCoordinate]) + | succ current => + rw [show current + 1 = Nat.succ current by omega] + change PreservesChainInvariant parameter allowed + (if hlevel : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hlevel⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0) + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact preservesChainInvariant_revealPublishedCoordinate parameter allowed _ + (by simp [IsChainCoordinate]) + · rw [dif_neg hlevel] + exact preservesChainInvariant_pure parameter allowed 0 + · exact preservesChainInvariant_pure parameter allowed 0).bind fun path => + preservesChainInvariant_pure parameter allowed (values, path) + +theorem chainInvariant_revealLayersForParts + (parameter : PublicParameter) (initial : Coordinate → Prop) + (index : Index) (parts : Layer → Counter × (ChainIndex → Digit)) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (values : Layer → (ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) + (hinvariant : ChainInvariant parameter initial state cache) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (values, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((sequenceFin fun lay => revealLayerValues index lay (parts lay).2).run cache))) : + ChainInvariant parameter + (fun coordinate => initial coordinate ∨ PublishedByParts index parts coordinate) + finalState finalCache := by + let allowed := fun coordinate => initial coordinate ∨ PublishedByParts index parts coordinate + have hinvariantAllowed : ChainInvariant parameter allowed state cache := + hinvariant.mono fun coordinate hcoordinate => Or.inl hcoordinate + exact preservesChainInvariant_sequenceFin parameter allowed _ + (fun lay => preservesChainInvariant_revealLayerValues parameter allowed index lay + (parts lay).2 fun chainIdx => Or.inr (publishedByParts_selected index parts lay chainIdx)) + state cache fuel finalState remaining values finalCache hinvariantAllowed hresult + +set_option linter.constructorNameAsVariable false in +theorem chainInvariant_maskedSignAfterDigest + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (initial : Coordinate → Prop) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (result : Option Signature) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hinvariant : ChainInvariant parameter initial state cache) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (result, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((maskedSignAfterDigest parameter ftsSecret randomness index leaves).run cache))) : + (result = none ∧ ChainInvariant parameter initial finalState finalCache) ∨ + ∃ (signature : Signature) (parts : Layer → Counter × (ChainIndex → Digit)), + result = some signature + ∧ signature.randomness = randomness + ∧ signature.counter = (fun lay => (parts lay).1) + ∧ HonestLayerParts f + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) index parts + ∧ ChainInvariant parameter + (fun coordinate => initial coordinate ∨ PublishedByParts index parts coordinate) + finalState finalCache := by + unfold maskedSignAfterDigest at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨pathRaw, hpath, hafterPath⟩ := hresult + cases pathRaw with + | stopped stoppedHit => simp at hafterPath + | done pathState pathRemaining pathResult => + rcases pathResult with ⟨ftsPath, pathCache⟩ + have hpathInvariant := preservesChainInvariant_ordinaryFtsOpen parameter initial index leaves + (ftsSecret index) state cache fuel pathState pathRemaining ftsPath pathCache hinvariant hpath + simp only at hafterPath + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hafterPath + obtain ⟨layersRaw, hlayers, hafterLayers⟩ := hafterPath + cases layersRaw with + | stopped stoppedHit => simp at hafterLayers + | done layersState layersRemaining layersResult => + rcases layersResult with ⟨layers, layersCache⟩ + rw [← maskedSignLayers_eq_sequenceFin parameter ftsSecret index] at hlayers + have hlayersInvariant := chainInvariant_of_mem_runRaw_maskedSignLayers + (parameter := parameter) (allowed := initial) (ftsSecret := ftsSecret) + (index := index) (state := pathState) (finalState := layersState) + (cache := pathCache) (finalCache := layersCache) (fuel := pathRemaining) + (remaining := layersRemaining) (layers := layers) hpathInvariant hlayers + simp only at hafterLayers + cases hparts : traverseOption layers with + | none => + rw [hparts] at hafterLayers + simp [LazyRevealProbe.runRaw] at hafterLayers + rcases hafterLayers with ⟨rfl, rfl, rfl, rfl⟩ + exact Or.inl ⟨rfl, hlayersInvariant⟩ + | some parts => + rw [hparts, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterLayers + obtain ⟨revealedRaw, hrevealed, hfinish⟩ := hafterLayers + cases revealedRaw with + | stopped stoppedHit => simp at hfinish + | done revealedState revealedRemaining revealedResult => + rcases revealedResult with ⟨revealed, revealedCache⟩ + have hrevealedValues := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((sequenceFin fun lay => revealLayerValues index lay (parts lay).2).run + layersCache) layersState revealedState layersRemaining revealedRemaining + (revealed, revealedCache) hrevealed + have hrevealedCache := ordinaryCacheIncreasing_sequenceFin + (fun lay => revealLayerValues index lay (parts lay).2) + (fun lay => ordinaryCacheIncreasing_revealLayerValues index lay (parts lay).2) + layersState layersCache layersRemaining revealedState revealedRemaining + revealed revealedCache hrevealed + have hrevealedInvariant := chainInvariant_revealLayersForParts parameter initial + index parts layersState revealedState layersCache revealedCache layersRemaining + revealedRemaining revealed hlayersInvariant hrevealed + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl⟩ + have hfLayers : StableCacheAgreesWithFn parameter layersCache f := + fun input output hstable hcached => + hf input output hstable (hrevealedCache hcached) + have htableLayers : ∀ coordinate output, + layersState.values coordinate = some output → output = table coordinate := + fun coordinate output hvalue => htable coordinate output + (hrevealedValues coordinate output hvalue) + have hhonestParts := maskedSignLayers_parts_eval f parameter root table ftsSecret + index pathState layersState pathCache layersCache pathRemaining layersRemaining + layers parts hfLayers htableLayers hrealizes hlayers hparts + exact Or.inr ⟨_, parts, rfl, rfl, rfl, hhonestParts, hrevealedInvariant⟩ + +theorem chainInvariant_maskedSign + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (message : Message) (initial : Coordinate → Prop) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (result : Option Signature) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hinvariant : ChainInvariant parameter initial state cache) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (result, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((maskedSign parameter root ftsSecret message).run cache))) : + (result = none ∧ ChainInvariant parameter initial finalState finalCache) ∨ + ∃ (signature : Signature) (index : Index) (leaves : DigestTree → FtsLeaf) + (parts : Layer → Counter × (ChainIndex → Digit)), + result = some signature + ∧ SuccessfulDigestRun f (ordinaryQueryCache finalCache) + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + message signature.randomness index leaves + ∧ signature.counter = (fun lay => (parts lay).1) + ∧ HonestLayerParts f + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) index parts + ∧ ChainInvariant parameter + (fun coordinate => initial coordinate ∨ PublishedByParts index parts coordinate) + finalState finalCache := by + let secretKey : SecretKey := + ⟨parameter, root, tableOtsSecret table, ftsSecret⟩ + let digestSecretKey : SecretKey := + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ + unfold maskedSign at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨loopRaw, hloop, hrest⟩ := hresult + cases loopRaw with + | stopped stoppedHit => simp at hrest + | done loopState loopRemaining loopResult => + rcases loopResult with ⟨selected, loopCache⟩ + have hloopInvariant := preservesChainInvariant_ordinarySignDigestLoop initial + digestAttemptLimit digestSecretKey message state cache fuel loopState loopRemaining + selected loopCache hinvariant hloop + simp only at hrest + cases selected with + | none => + simp [LazyRevealProbe.runRaw] at hrest + rcases hrest with ⟨rfl, rfl, rfl, rfl⟩ + exact Or.inl ⟨rfl, hloopInvariant⟩ + | some selected => + obtain ⟨randomness, index, leaves⟩ := selected + have hcacheLE := ordinaryCacheIncreasing_maskedSignAfterDigest parameter ftsSecret + randomness index leaves loopState loopCache loopRemaining finalState remaining result + finalCache hrest + have hdigestLoop := successfulDigestLoop_of_mem_runRaw_ordinaryRomImpl f + digestSecretKey message digestAttemptLimit randomness index leaves state loopState + cache loopCache fuel loopRemaining finalCache hcacheLE hf hloop + have hdigest : SuccessfulDigestRun f (ordinaryQueryCache finalCache) secretKey message + randomness index leaves := by + simpa only [SuccessfulDigestRun, signAttempt, digestSecretKey, secretKey] using + hdigestLoop + have hafter := chainInvariant_maskedSignAfterDigest f parameter root table ftsSecret + randomness index leaves initial loopState finalState loopCache finalCache loopRemaining + remaining result hf htable hrealizes hloopInvariant hrest + rcases hafter with ⟨rfl, hfinalInvariant⟩ | + ⟨signature, parts, hsignature, hrandomness, hcounter, hhonest, + hfinalInvariant⟩ + · exact Or.inl ⟨rfl, hfinalInvariant⟩ + · subst result + have hdigestSignature : SuccessfulDigestRun f (ordinaryQueryCache finalCache) + secretKey message signature.randomness index leaves := by + rw [hrandomness] + exact hdigest + exact Or.inr ⟨signature, index, leaves, parts, rfl, hdigestSignature, hcounter, + hhonest, hfinalInvariant⟩ + +theorem chainInvariant_maskedSign_of_published + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (message : Message) (allowed : Coordinate → Prop) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (result : Option Signature) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hinvariant : ChainInvariant parameter allowed state cache) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (result, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((maskedSign parameter root ftsSecret message).run cache))) + (hpublished : ∀ signature index leaves parts, + result = some signature → + SuccessfulDigestRun f (ordinaryQueryCache finalCache) + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + message signature.randomness index leaves → + signature.counter = (fun lay => (parts lay).1) → + HonestLayerParts f + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) index parts → + ∀ coordinate, PublishedByParts index parts coordinate → allowed coordinate) : + ChainInvariant parameter allowed finalState finalCache := by + rcases chainInvariant_maskedSign f parameter root table ftsSecret message allowed state + finalState cache finalCache fuel remaining result hf htable hrealizes hinvariant hresult with + ⟨_, hfinal⟩ | ⟨signature, index, leaves, parts, hsignature, hdigest, hcounter, + hhonest, hfinal⟩ + · exact hfinal + · exact hfinal.mono fun coordinate hcoordinate => + hcoordinate.elim id (hpublished signature index leaves parts hsignature hdigest hcounter + hhonest coordinate) + +def PublishedChainCoordinate (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (coordinate : Coordinate) : Prop := + ∃ (entry : (request : SignRequest) × SigningSpec.Range request) (signature : Signature) + (index : Index) (leaves : DigestTree → FtsLeaf) (lay : Layer) (chainIdx : ChainIndex) + (codeword : Encoding), + entry ∈ signingLog + ∧ entry.2 = some signature + ∧ SuccessfulSignRun f cache secretKey entry.1 signature + ∧ SuccessfulDigestRun f cache secretKey entry.1 signature.randomness index leaves + ∧ evalWithAnswerFn f (encode secretKey.parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) (evalWithAnswerFn f (layerMessage secretKey index lay)) + (signature.counter lay)) = some codeword + ∧ coordinate = chainValueCoordinate lay (treeIndexAt index lay) + (leafIndexAt index lay) chainIdx (codeword chainIdx) + +theorem PublishedByParts.toPublishedChainCoordinate + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} + {parts : Layer → Counter × (ChainIndex → Digit)} {coordinate : Coordinate} + (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature) (leaves : DigestTree → FtsLeaf) + (hentry : entry ∈ signingLog) (hresponse : entry.2 = some signature) + (hrun : SuccessfulSignRun f cache secretKey entry.1 signature) + (hdigest : SuccessfulDigestRun f cache secretKey entry.1 signature.randomness index leaves) + (hcounter : signature.counter = fun lay => (parts lay).1) + (hhonest : HonestLayerParts f secretKey index parts) + (hpublished : PublishedByParts index parts coordinate) : + PublishedChainCoordinate f cache secretKey signingLog coordinate := by + obtain ⟨lay, chainIdx, hcoordinate⟩ := hpublished + have hcounterAt := congrFun hcounter lay + have hencode := hhonest lay + rw [← hcounterAt] at hencode + exact ⟨entry, signature, index, leaves, lay, chainIdx, (parts lay).2, hentry, hresponse, + hrun, hdigest, hencode, hcoordinate⟩ + +theorem successfulDigestRun_mono_cache + {f : QueryImpl HashSpec Id} {initial final : QueryCache HashSpec} + {secretKey : SecretKey} {message : Message} {randomness : Randomness} + {index : Index} {leaves : DigestTree → FtsLeaf} + (hrun : SuccessfulDigestRun f initial secretKey message randomness index leaves) + (hle : initial ≤ final) : + SuccessfulDigestRun f final secretKey message randomness index leaves := + ⟨hrun.1, hrun.2.1, hrun.2.2.mono hle⟩ + +theorem successfulSignRun_mono_cache + {f : QueryImpl HashSpec Id} {initial final : QueryCache HashSpec} + {secretKey : SecretKey} {message : Message} {signature : Signature} + (hrun : SuccessfulSignRun f initial secretKey message signature) + (hle : initial ≤ final) : SuccessfulSignRun f final secretKey message signature := by + obtain ⟨index, leaves, parts, hdigest, hftsSecret, hftsPath, hcounter, hvalues, + hauthPath, hftsCached, hlayers, hlayersCached⟩ := hrun + exact ⟨index, leaves, parts, successfulDigestRun_mono_cache hdigest hle, hftsSecret, + hftsPath, hcounter, hvalues, hauthPath, hftsCached.mono hle, hlayers, + fun lay => (hlayersCached lay).mono hle⟩ + +def CoveredChainCoordinate (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (coordinate : Coordinate) : Prop := + ∃ (entry : (request : SignRequest) × SigningSpec.Range request) (signature : Signature) + (index : Index) (leaves : DigestTree → FtsLeaf) (lay : Layer) (chainIdx : ChainIndex) + (codeword : Encoding) (targetDigit : Digit), + entry ∈ signingLog + ∧ entry.2 = some signature + ∧ SuccessfulSignRun f cache secretKey entry.1 signature + ∧ SuccessfulDigestRun f cache secretKey entry.1 signature.randomness index leaves + ∧ evalWithAnswerFn f (encode secretKey.parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) (evalWithAnswerFn f (layerMessage secretKey index lay)) + (signature.counter lay)) = some codeword + ∧ (codeword chainIdx).val ≤ targetDigit.val + ∧ coordinate = chainValueCoordinate lay (treeIndexAt index lay) + (leafIndexAt index lay) chainIdx targetDigit + +theorem CoveredChainCoordinate.mono_cache + {f : QueryImpl HashSpec Id} {initial final : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} {coordinate : Coordinate} + (hcovered : CoveredChainCoordinate f initial secretKey signingLog coordinate) + (hle : initial ≤ final) : CoveredChainCoordinate f final secretKey signingLog coordinate := by + obtain ⟨entry, signature, index, leaves, lay, chainIdx, codeword, targetDigit, hentry, + hresponse, hrun, hdigest, hencode, hleDigit, hcoordinate⟩ := hcovered + exact ⟨entry, signature, index, leaves, lay, chainIdx, codeword, targetDigit, hentry, + hresponse, successfulSignRun_mono_cache hrun hle, + successfulDigestRun_mono_cache hdigest hle, hencode, hleDigit, hcoordinate⟩ + +theorem CoveredChainCoordinate.mono_log + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {left right : QueryLog SigningSpec} {coordinate : Coordinate} + (hcovered : CoveredChainCoordinate f cache secretKey right coordinate) : + CoveredChainCoordinate f cache secretKey (left ++ right) coordinate := by + obtain ⟨entry, signature, index, leaves, lay, chainIdx, codeword, targetDigit, hentry, + hresponse, hrun, hdigest, hencode, hleDigit, hcoordinate⟩ := hcovered + exact ⟨entry, signature, index, leaves, lay, chainIdx, codeword, targetDigit, + List.mem_append_right left hentry, hresponse, hrun, hdigest, hencode, hleDigit, hcoordinate⟩ + +theorem PublishedChainCoordinate.covered + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {coordinate : Coordinate} + (hpublished : PublishedChainCoordinate f cache secretKey signingLog coordinate) : + CoveredChainCoordinate f cache secretKey signingLog coordinate := by + obtain ⟨entry, signature, index, leaves, lay, chainIdx, codeword, hentry, hresponse, + hrun, hdigest, hencode, hcoordinate⟩ := hpublished + exact ⟨entry, signature, index, leaves, lay, chainIdx, codeword, codeword chainIdx, + hentry, hresponse, hrun, hdigest, hencode, le_rfl, hcoordinate⟩ + +theorem chainInvariant_maskedSign_covered + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (message : Message) (targetCache : QueryCache HashSpec) + (signingLog : QueryLog SigningSpec) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (result : Option Signature) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hinvariant : ChainInvariant parameter + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) signingLog) + state cache) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (result, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + ((maskedSign parameter root ftsSecret message).run cache))) + (hentry : (⟨message, result⟩ : (request : SignRequest) × SigningSpec.Range request) ∈ + signingLog) + (hrun : ∀ signature, result = some signature → + SuccessfulSignRun f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + message signature) : + ChainInvariant parameter + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) signingLog) + finalState finalCache := by + apply chainInvariant_maskedSign_of_published f parameter root table ftsSecret message + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) signingLog) + state finalState cache finalCache fuel remaining result hf htable hrealizes hinvariant hresult + intro signature index leaves parts hsignature hdigest hcounter hhonest coordinate hpublished + have hrun' := hrun signature hsignature + obtain ⟨runIndex, runLeaves, runParts, hrunDigest, hftsSecret, hftsPath, hrunCounter, + hrunValues, hrunPath, hftsCached, hlayers, hlayersCached⟩ := hrun' + have hselected : (index, leaves) = (runIndex, runLeaves) := + Option.some.inj (hdigest.2.1.symm.trans hrunDigest.2.1) + obtain ⟨hindex, hleaves⟩ := Prod.mk.inj hselected + subst runIndex + subst runLeaves + exact (hpublished.toPublishedChainCoordinate ⟨message, result⟩ signature leaves hentry + hsignature (hrun signature hsignature) hrunDigest hcounter hhonest).covered + +theorem CoveredChainCoordinate.forward + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {lay : Layer} {tree : TreeIndex} + {leafIdx : LeafIndex} {chainIdx : ChainIndex} {digit later : Digit} + (hcovered : CoveredChainCoordinate f cache secretKey signingLog + (chainValueCoordinate lay tree leafIdx chainIdx digit)) + (hle : digit.val ≤ later.val) : + CoveredChainCoordinate f cache secretKey signingLog + (chainValueCoordinate lay tree leafIdx chainIdx later) := by + obtain ⟨entry, signature, index, leaves, publishedLay, publishedChain, codeword, + targetDigit, hentry, hresponse, hrun, hdigest, hencode, hpublishedLe, + hcoordinate⟩ := hcovered + have hparts := chainValueCoordinate_injective hcoordinate + obtain ⟨rfl, htree, hleaf, rfl, hdigit⟩ := hparts + subst targetDigit + exact ⟨entry, signature, index, leaves, lay, chainIdx, codeword, later, hentry, hresponse, + hrun, hdigest, hencode, hpublishedLe.trans hle, by rw [htree, hleaf]⟩ + +theorem CoveredChainCoordinate.outputCoordinate + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {probe : Probe} + (hcovered : CoveredChainCoordinate f cache secretKey signingLog probe.coordinate) + (hchain : IsChainCoordinate probe.outputCoordinate) : + CoveredChainCoordinate f cache secretKey signingLog probe.outputCoordinate := by + rcases probe with ⟨coordinate, candidate⟩ + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let digit : Digit := ⟨0, by norm_num [chainLength, winternitzBits]⟩ + let later : Digit := ⟨1, by norm_num [chainLength, winternitzBits]⟩ + have hstart : chainValueCoordinate lay tree leafIdx chainIdx digit = + .chainStart lay tree leafIdx chainIdx := by + simp [chainValueCoordinate, digit] + have hnext : chainValueCoordinate lay tree leafIdx chainIdx later = + .position (.chain lay tree leafIdx chainIdx + ⟨0, by norm_num [chainLength, winternitzBits]⟩) := by + simp [chainValueCoordinate, later] + change CoveredChainCoordinate f cache secretKey signingLog + (.chainStart lay tree leafIdx chainIdx) at hcovered + rw [← hstart] at hcovered + have hforward := CoveredChainCoordinate.forward (digit := digit) (later := later) + hcovered (by norm_num [digit, later]) + change CoveredChainCoordinate f cache secretKey signingLog + (.position (.chain lay tree leafIdx chainIdx + ⟨0, by norm_num [chainLength, winternitzBits]⟩)) + rw [← hnext] + exact hforward + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + by_cases hnext : step.val + 1 < chainLength - 1 + · let digit : Digit := ⟨step.val + 1, by + have := step.isLt + omega⟩ + let later : Digit := ⟨step.val + 2, by omega⟩ + have hcurrent : chainValueCoordinate lay tree leafIdx chainIdx digit = + .position (.chain lay tree leafIdx chainIdx step) := by + unfold chainValueCoordinate + rw [dif_neg (by simp [digit])] + congr 3 + have houtput : chainValueCoordinate lay tree leafIdx chainIdx later = + .position (.chain lay tree leafIdx chainIdx + ⟨step.val + 1, hnext⟩) := by + unfold chainValueCoordinate + rw [dif_neg (by simp [later])] + congr 3 + change CoveredChainCoordinate f cache secretKey signingLog + (.position (.chain lay tree leafIdx chainIdx step)) at hcovered + rw [← hcurrent] at hcovered + have hforward := CoveredChainCoordinate.forward (digit := digit) (later := later) + hcovered (by norm_num [digit, later]) + change CoveredChainCoordinate f cache secretKey signingLog + (if _hnext : step.val + 1 < chainLength - 1 then + .position (.chain lay tree leafIdx chainIdx ⟨step.val + 1, _hnext⟩) + else .position (.leaf lay tree leafIdx)) + rw [dif_pos hnext, ← houtput] + exact hforward + · simp [Probe.outputCoordinate, hnext, IsChainCoordinate] at hchain + | leaf => simp [Probe.outputCoordinate, IsChainCoordinate] at hchain + | node => simp [Probe.outputCoordinate, IsChainCoordinate] at hchain + | ftsLeaf => simp [Probe.outputCoordinate, IsChainCoordinate] at hchain + | ftsNode => simp [Probe.outputCoordinate, IsChainCoordinate] at hchain + | ftsRoots => simp [Probe.outputCoordinate, IsChainCoordinate] at hchain + +theorem coveredChainCoordinate_forwardClosed + (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) (secretKey : SecretKey) + (signingLog : QueryLog SigningSpec) : + ChainForwardClosed (CoveredChainCoordinate f cache secretKey signingLog) := by + intro candidate hcovered hchain + exact hcovered.outputCoordinate hchain + +theorem PublishedChainCoordinate.signedLayerAt + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {coordinate : Coordinate} + (hpublished : PublishedChainCoordinate f cache secretKey signingLog coordinate) : + ∃ lay tree leafIdx, SignedLayerAt f cache secretKey signingLog lay tree leafIdx := by + obtain ⟨entry, signature, index, leaves, lay, chainIdx, codeword, hentry, hresponse, + hrun, hdigest, hencode, hcoordinate⟩ := hpublished + obtain ⟨hmessage, hopening⟩ := hrun.honest_layer_at_of_digest hdigest lay + have hcached := hrun.signed_encode_cached_of_digest hdigest lay + exact ⟨lay, treeIndexAt index lay, leafIndexAt index lay, entry, signature, index, leaves, + hentry, hresponse, hrun, hdigest, rfl, rfl, hmessage, hcached, hopening⟩ + +theorem VerifierLayerMessage.otsLeaf_query_mem_verifyLayers + {f : QueryImpl HashSpec Id} {parameter : PublicParameter} {index : Index} + {leaves : DigestTree → FtsLeaf} {signature : Signature} {lay : Layer} + {message : Digest} {input : HashInput} + (hmessage : VerifierLayerMessage f parameter index leaves signature lay message) + (hquery : input ∈ queriedInputs f + (otsLeaf parameter lay (treeIndexAt index lay) (leafIndexAt index lay) message + (signature.counter lay) (signature.chainValue lay))) : + input ∈ queriedInputs f + (verifyLayers parameter index signature numLayers + (evalWithAnswerFn f + (ftsRecover parameter index leaves signature.ftsSecret signature.ftsPath))) := by + simp only [VerifierLayerMessage] at hmessage + obtain ⟨bottomLeaf, hbottom, middleLeaf, hmiddle, hposition⟩ := hmessage + rcases hposition with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ + · rw [show numLayers = bottomLayer.val + 1 by rfl, verifyLayers_succ_eq, + dif_pos bottomLayer.isLt] + exact queriedInputs_mono_bind_left f _ _ hquery + · rw [show numLayers = bottomLayer.val + 1 by rfl, verifyLayers_succ_eq, + dif_pos bottomLayer.isLt] + apply queriedInputs_mono_bind_right + rw [hbottom] + apply queriedInputs_mono_bind_right + change input ∈ queriedInputs f + (verifyLayers parameter index signature (middleLayer.val + 1) + (foldValue f parameter bottomLayer (treeIndexAt index bottomLayer) + (leafIndexAt index bottomLayer) (signaturePath signature bottomLayer) bottomLeaf + (layerHeight bottomLayer))) + rw [verifyLayers_succ_eq, dif_pos middleLayer.isLt] + simp only [show (⟨middleLayer.val, by exact middleLayer.isLt⟩ : Layer) = middleLayer by + exact Fin.ext rfl] + exact queriedInputs_mono_bind_left f _ _ hquery + · rw [show numLayers = bottomLayer.val + 1 by rfl, verifyLayers_succ_eq, + dif_pos bottomLayer.isLt] + apply queriedInputs_mono_bind_right + rw [hbottom] + apply queriedInputs_mono_bind_right + change input ∈ queriedInputs f + (verifyLayers parameter index signature (middleLayer.val + 1) + (foldValue f parameter bottomLayer (treeIndexAt index bottomLayer) + (leafIndexAt index bottomLayer) (signaturePath signature bottomLayer) bottomLeaf + (layerHeight bottomLayer))) + rw [verifyLayers_succ_eq, dif_pos middleLayer.isLt] + simp only [show (⟨middleLayer.val, by exact middleLayer.isLt⟩ : Layer) = middleLayer by + exact Fin.ext rfl] + apply queriedInputs_mono_bind_right + rw [hmiddle] + apply queriedInputs_mono_bind_right + change input ∈ queriedInputs f + (verifyLayers parameter index signature (topLayer.val + 1) + (foldValue f parameter middleLayer (treeIndexAt index middleLayer) + (leafIndexAt index middleLayer) (signaturePath signature middleLayer) middleLeaf + (layerHeight middleLayer))) + rw [verifyLayers_succ_eq, dif_pos topLayer.isLt] + simp only [show (⟨topLayer.val, by exact topLayer.isLt⟩ : Layer) = topLayer by + exact Fin.ext rfl] + exact queriedInputs_mono_bind_left f _ _ hquery + +theorem VerifierLayerMessage.otsLeaf_query_mem_verify + {f : QueryImpl HashSpec Id} {publicKey : PublicKey} {message : Message} + {signature : Signature} {digest : MessageDigest} {lay : Layer} + {layerMessage : Digest} {input : HashInput} + (hdigest : evalWithAnswerFn f + (messageDigest publicKey.parameter publicKey.root message signature.randomness) = digest) + (hadmissible : Admissible digest) + (hlayer : VerifierLayerMessage f publicKey.parameter (digestIndex digest) + (digestLeaves digest) signature lay layerMessage) + (hquery : input ∈ queriedInputs f + (otsLeaf publicKey.parameter lay (treeIndexAt (digestIndex digest) lay) + (leafIndexAt (digestIndex digest) lay) layerMessage (signature.counter lay) + (signature.chainValue lay))) : + input ∈ queriedInputs f (verify publicKey message signature) := by + rw [verify_eq, queriedInputs_bind] + apply List.mem_append_right + rw [hdigest] + simp only [hadmissible, not_true_eq_false, if_false, queriedInputs_bind] + apply List.mem_append_right + apply List.mem_append_left + exact VerifierLayerMessage.otsLeaf_query_mem_verifyLayers hlayer hquery + +def VerifyProbeWitnessAt (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) + (forgedMessage : Message) (signature : Signature) (lay : Layer) : Prop := + ∃ (digest : MessageDigest) (layerMessage : Digest) + (codeword : Encoding) (chainIdx : ChainIndex) + (_hdigit : (codeword chainIdx).val < chainLength - 1) + (probe : Probe) (input : HashInput), + input = tweakableHashInput secretKey.parameter + (.chain lay (treeIndexAt (digestIndex digest) lay) + (leafIndexAt (digestIndex digest) lay) chainIdx + ⟨(codeword chainIdx).val, _hdigit⟩) + (digestBytes (signature.chainValue lay chainIdx)) + ∧ evalWithAnswerFn f (messageDigest secretKey.parameter secretKey.root + forgedMessage signature.randomness) = digest + ∧ Admissible digest + ∧ evalWithAnswerFn f (encode secretKey.parameter lay + (treeIndexAt (digestIndex digest) lay) (leafIndexAt (digestIndex digest) lay) + layerMessage (signature.counter lay)) = some codeword + ∧ VerifierLayerMessage f secretKey.parameter (digestIndex digest) + (digestLeaves digest) signature lay layerMessage + ∧ probe.Hits f secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + ∧ probe.MatchesInput secretKey.parameter input + ∧ input ∈ queriedInputs f + (verify ⟨secretKey.root, secretKey.parameter⟩ forgedMessage signature) + ∧ cache input ≠ none + ∧ ¬CoveredChainCoordinate f cache secretKey signingLog probe.coordinate + ∧ probe.SourceSettled cache secretKey + +def VerifyProbeWitness (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) + (forgedMessage : Message) (signature : Signature) : Prop := + ∃ lay, VerifyProbeWitnessAt f cache secretKey signingLog forgedMessage signature lay + +theorem ForgedFreshLayerOpening.exists_uncovered_matching_probe + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} {leaves : DigestTree → FtsLeaf} + {signature : Signature} + (hfresh : ForgedFreshLayerOpening f cache secretKey signingLog index leaves signature) : + ∃ (probe : Probe) (input : HashInput), + probe.Hits f secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + ∧ probe.MatchesInput secretKey.parameter input + ∧ cache input ≠ none + ∧ ¬CoveredChainCoordinate f cache secretKey signingLog probe.coordinate := by + obtain ⟨valueProbe, input, hhit, hnotSigned, hmatch, hcached⟩ := + hfresh.toFreshLayerOpening.exists_hit_probe_cached + refine ⟨toProbe valueProbe, input, toProbe_hits hhit, + toProbe_matchesInput secretKey.parameter valueProbe input hmatch, hcached, ?_⟩ + intro hcovered + obtain ⟨entry, publishedSignature, publishedIndex, leaves, publishedLay, chainIdx, + codeword, targetDigit, hentry, hresponse, hrun, hdigest, hencode, hle, + hcoordinate⟩ := hcovered + obtain ⟨hmessage, hopening⟩ := hrun.honest_layer_at_of_digest hdigest publishedLay + have hcachedEncode := hrun.signed_encode_cached_of_digest hdigest publishedLay + have hsigned : SignedLayerAt f cache secretKey signingLog publishedLay + (treeIndexAt publishedIndex publishedLay) (leafIndexAt publishedIndex publishedLay) := + ⟨entry, publishedSignature, publishedIndex, leaves, hentry, hresponse, hrun, hdigest, + rfl, rfl, hmessage, hcachedEncode, hopening⟩ + have hparts := chainValueCoordinate_injective + (hcoordinate.symm.trans (toProbe_coordinate valueProbe)) + exact hnotSigned (hparts.1 ▸ hparts.2.1 ▸ hparts.2.2.1 ▸ hsigned) + +theorem SettledForgedFreshLayerOpening.exists_uncovered_matching_chain_probe + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} {leaves : DigestTree → FtsLeaf} + {signature : Signature} + (hfresh : SettledForgedFreshLayerOpening f cache secretKey signingLog index leaves signature) : + ∃ (lay : Layer) (message : Digest) (codeword : Encoding) + (chainIdx : ChainIndex) (_hdigit : (codeword chainIdx).val < chainLength - 1) + (probe : Probe) (input : HashInput), + input = tweakableHashInput secretKey.parameter + (.chain lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + ⟨(codeword chainIdx).val, _hdigit⟩) + (digestBytes (signature.chainValue lay chainIdx)) + ∧ evalWithAnswerFn f (encode secretKey.parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message (signature.counter lay)) = some codeword + ∧ VerifierLayerMessage f secretKey.parameter index leaves signature lay message + ∧ input ∈ queriedInputs f + (otsLeaf secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + message (signature.counter lay) (signature.chainValue lay)) + ∧ probe.Hits f secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + ∧ probe.MatchesInput secretKey.parameter input + ∧ cache input ≠ none + ∧ ¬CoveredChainCoordinate f cache secretKey signingLog probe.coordinate + ∧ probe.SourceSettled cache secretKey := by + obtain ⟨lay, message, hroot, hverifierMessage, hopening, hforgedRun, hnotSigned⟩ := hfresh + obtain ⟨codeword, hencode, hvalues, _⟩ := hopening + have hvalid := valid_of_eval_encode_eq_some f secretKey.parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) message (signature.counter lay) + codeword hencode + obtain ⟨chainIdx, hdigit⟩ := TargetSum.Valid.exists_digit_lt_last hvalid + let valueProbe : OtsValueProbe := + ⟨lay, treeIndexAt index lay, leafIndexAt index lay, chainIdx, + codeword chainIdx, signature.chainValue lay chainIdx⟩ + let step : ChainStep := ⟨(codeword chainIdx).val, hdigit⟩ + let input := tweakableHashInput secretKey.parameter + (.chain lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx step) + (digestBytes (signature.chainValue lay chainIdx)) + have hquery : input ∈ queriedInputs f + (otsLeaf secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + message (signature.counter lay) (signature.chainValue lay)) := by + simpa only [input, step, Nat.add_zero, walkValue, chainWalk, + evalWithAnswerFn_pure] using + otsLeaf_chain_query_mem f secretKey.parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message (signature.counter lay) (signature.chainValue lay) + codeword hencode chainIdx 0 (by omega) hdigit + have hhit : valueProbe.Hits f secretKey.parameter secretKey.otsSecret := by + simpa only [OtsValueProbe.Hits, OtsValueProbe.target, valueProbe] using hvalues chainIdx + have hmatch : (toProbe valueProbe).MatchesInput secretKey.parameter input := by + apply toProbe_matchesInput secretKey.parameter valueProbe input + exact Or.inl ⟨step, by simp [valueProbe, step], rfl⟩ + refine ⟨lay, message, codeword, chainIdx, hdigit, toProbe valueProbe, input, rfl, hencode, + hverifierMessage, hquery, toProbe_hits hhit, hmatch, hforgedRun input hquery, ?_, ?_⟩ + · intro hcovered + obtain ⟨entry, publishedSignature, publishedIndex, publishedLeaves, publishedLay, + publishedChainIdx, publishedCodeword, targetDigit, hentry, hresponse, hrun, hdigest, + hpublishedEncode, hle, hcoordinate⟩ := hcovered + obtain ⟨hmessage, hopening⟩ := hrun.honest_layer_at_of_digest hdigest publishedLay + have hcachedEncode := hrun.signed_encode_cached_of_digest hdigest publishedLay + have hsigned : SignedLayerAt f cache secretKey signingLog publishedLay + (treeIndexAt publishedIndex publishedLay) (leafIndexAt publishedIndex publishedLay) := + ⟨entry, publishedSignature, publishedIndex, publishedLeaves, hentry, hresponse, hrun, + hdigest, rfl, rfl, hmessage, hcachedEncode, hopening⟩ + have hparts := chainValueCoordinate_injective + (hcoordinate.symm.trans (toProbe_coordinate valueProbe)) + dsimp only [valueProbe] at hparts + obtain ⟨rfl, htree, hleaf, _, _⟩ := hparts + rw [htree, hleaf] at hsigned + exact hnotSigned hsigned + · exact toProbe_sourceSettled_of_layerRootSettled (leafIndexAt_lt index lay) hroot + +set_option maxHeartbeats 400000 in +theorem SettledForgedFreshLayerOpening.toVerifyProbeWitness + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {forgedMessage : Message} {digest : MessageDigest} + {signature : Signature} + (hdigest : evalWithAnswerFn f (messageDigest secretKey.parameter secretKey.root + forgedMessage signature.randomness) = digest) + (hadmissible : Admissible digest) + (hfresh : SettledForgedFreshLayerOpening f cache secretKey signingLog (digestIndex digest) + (digestLeaves digest) signature) : + VerifyProbeWitness f cache secretKey signingLog forgedMessage signature := by + obtain ⟨lay, message, codeword, chainIdx, hdigit, probe, input, hinput, hencode, + hverifierMessage, hquery, hhit, hmatch, hcached, huncovered, hsettled⟩ := + SettledForgedFreshLayerOpening.exists_uncovered_matching_chain_probe hfresh + exact ⟨lay, digest, message, codeword, chainIdx, hdigit, probe, input, hinput, + hdigest, hadmissible, hencode, + hverifierMessage, hhit, hmatch, + VerifierLayerMessage.otsLeaf_query_mem_verify hdigest hadmissible hverifierMessage hquery, + hcached, huncovered, hsettled⟩ + +theorem SettledForgedBackwardChainOpening.exists_uncovered_matching_probe + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {forgedIndex : Index} + {forgedLeaves : DigestTree → FtsLeaf} + {forgedSignature : Signature} + (hbackward : SettledForgedBackwardChainOpening f cache secretKey signingLog forgedIndex + forgedLeaves forgedSignature) : + ∃ (lay : Layer) (forgedMessage : Digest) (codeword : Encoding) + (chainIdx : ChainIndex) (_hdigit : (codeword chainIdx).val < chainLength - 1) + (probe : Probe) (input : HashInput), + input = tweakableHashInput secretKey.parameter + (.chain lay (treeIndexAt forgedIndex lay) (leafIndexAt forgedIndex lay) chainIdx + ⟨(codeword chainIdx).val, _hdigit⟩) + (digestBytes (forgedSignature.chainValue lay chainIdx)) + ∧ evalWithAnswerFn f + (encode secretKey.parameter lay (treeIndexAt forgedIndex lay) + (leafIndexAt forgedIndex lay) forgedMessage (forgedSignature.counter lay)) = + some codeword + ∧ VerifierLayerMessage f secretKey.parameter forgedIndex forgedLeaves forgedSignature lay + forgedMessage + ∧ input ∈ queriedInputs f + (otsLeaf secretKey.parameter lay (treeIndexAt forgedIndex lay) + (leafIndexAt forgedIndex lay) forgedMessage (forgedSignature.counter lay) + (forgedSignature.chainValue lay)) + ∧ probe.Hits f secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + ∧ probe.MatchesInput secretKey.parameter input + ∧ cache input ≠ none + ∧ ¬CoveredChainCoordinate f cache secretKey signingLog probe.coordinate + ∧ probe.SourceSettled cache secretKey := by + obtain ⟨lay, forgedMessage, entry, signedSignature, signedIndex, leaves, signedCodeword, + forgedCodeword, hroot, hverifierMessage, hforgedOpening, hforgedRun, hentry, hresponse, + hsignRun, hdigest, + htree, hleaf, hmessage, hsignedOpening, hsignedCached, hsigned, hforged, + chainIdx, hlt⟩ := hbackward + obtain ⟨openingCodeword, hopeningEncode, hforgedValues, hpath⟩ := hforgedOpening + have hopeningCodeword : openingCodeword = forgedCodeword := + Option.some.inj (hopeningEncode.symm.trans hforged) + let valueProbe : OtsValueProbe := + ⟨lay, treeIndexAt forgedIndex lay, leafIndexAt forgedIndex lay, chainIdx, + forgedCodeword chainIdx, forgedSignature.chainValue lay chainIdx⟩ + have hhit : valueProbe.Hits f secretKey.parameter secretKey.otsSecret := by + simpa only [OtsValueProbe.Hits, OtsValueProbe.target, valueProbe, + hopeningCodeword] using hforgedValues chainIdx + have hdigit : (forgedCodeword chainIdx).val < chainLength - 1 := by + have hsignedLt := (signedCodeword chainIdx).isLt + omega + have hopeningDigit : (openingCodeword chainIdx).val < chainLength - 1 := by + rw [hopeningCodeword] + exact hdigit + let step : ChainStep := ⟨(openingCodeword chainIdx).val, hopeningDigit⟩ + let input := tweakableHashInput secretKey.parameter + (.chain lay (treeIndexAt forgedIndex lay) (leafIndexAt forgedIndex lay) chainIdx step) + (digestBytes (forgedSignature.chainValue lay chainIdx)) + have hquery : input ∈ queriedInputs f + (otsLeaf secretKey.parameter lay (treeIndexAt forgedIndex lay) + (leafIndexAt forgedIndex lay) forgedMessage (forgedSignature.counter lay) + (forgedSignature.chainValue lay)) := by + simpa only [input, step, Nat.add_zero, walkValue, chainWalk, + evalWithAnswerFn_pure] using + otsLeaf_chain_query_mem f secretKey.parameter lay (treeIndexAt forgedIndex lay) + (leafIndexAt forgedIndex lay) forgedMessage (forgedSignature.counter lay) + (forgedSignature.chainValue lay) openingCodeword hopeningEncode chainIdx 0 + (by omega) hopeningDigit + have hmatch : (toProbe valueProbe).MatchesInput secretKey.parameter input := by + apply toProbe_matchesInput secretKey.parameter valueProbe input + exact Or.inl ⟨step, by simp [valueProbe, step, hopeningCodeword], rfl⟩ + refine ⟨lay, forgedMessage, openingCodeword, chainIdx, hopeningDigit, + toProbe valueProbe, input, rfl, hopeningEncode, hverifierMessage, hquery, + toProbe_hits hhit, hmatch, hforgedRun input hquery, ?_, ?_⟩ + · intro hcovered + obtain ⟨publishedEntry, publishedSignature, publishedIndex, publishedLeaves, publishedLay, + publishedChain, publishedCodeword, targetDigit, hpublishedEntry, hpublishedResponse, + hpublishedRun, hpublishedDigest, hpublishedEncode, hcoveredDigit, hcoordinate⟩ := hcovered + have hparts := chainValueCoordinate_injective + (hcoordinate.symm.trans (toProbe_coordinate valueProbe)) + dsimp only [valueProbe] at hparts + obtain ⟨hlay, htreePublished, hleafPublished, hchainPublished, htargetDigit⟩ := hparts + subst publishedLay + have htreeSame : treeIndexAt publishedIndex lay = treeIndexAt signedIndex lay := + htreePublished.trans htree.symm + have hleafSame : leafIndexAt publishedIndex lay = leafIndexAt signedIndex lay := + hleafPublished.trans hleaf.symm + have hpartsSame := successfulSignRun_layer_ots_eq_of_position_eq hpublishedRun hsignRun + hpublishedDigest hdigest lay htreeSame hleafSame + have hlayerMessage := congrArg (evalWithAnswerFn f) + (layerMessage_eq_of_position_eq secretKey publishedIndex signedIndex lay + htreeSame hleafSame) + have hpublishedEncode' := hpublishedEncode + rw [htreePublished, hleafPublished, hlayerMessage, hpartsSame.1] at hpublishedEncode' + have hcodeword : publishedCodeword = signedCodeword := + Option.some.inj (hpublishedEncode'.symm.trans hsigned) + subst publishedChain + rw [hcodeword] at hcoveredDigit + have hdigitValue := congrArg Fin.val htargetDigit + omega + · exact toProbe_sourceSettled_of_layerRootSettled (leafIndexAt_lt forgedIndex lay) hroot + +set_option maxHeartbeats 400000 in +theorem SettledForgedBackwardChainOpening.toVerifyProbeWitness + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {forgedMessage : Message} {digest : MessageDigest} + {signature : Signature} + (hdigest : evalWithAnswerFn f (messageDigest secretKey.parameter secretKey.root + forgedMessage signature.randomness) = digest) + (hadmissible : Admissible digest) + (hbackward : SettledForgedBackwardChainOpening f cache secretKey signingLog + (digestIndex digest) + (digestLeaves digest) signature) : + VerifyProbeWitness f cache secretKey signingLog forgedMessage signature := by + obtain ⟨lay, layerMessage, codeword, chainIdx, hdigit, probe, input, hinput, hencode, + hverifierMessage, hquery, hhit, hmatch, hcached, huncovered, hsettled⟩ := + SettledForgedBackwardChainOpening.exists_uncovered_matching_probe hbackward + exact ⟨lay, digest, layerMessage, codeword, chainIdx, hdigit, probe, input, hinput, + hdigest, hadmissible, hencode, hverifierMessage, hhit, hmatch, + VerifierLayerMessage.otsLeaf_query_mem_verify hdigest hadmissible hverifierMessage hquery, + hcached, huncovered, hsettled⟩ + +theorem signingTraceComputation_query_bind + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → + OracleComp (OracleWorld + SigningSpec) alpha) : + signingTraceComputation + ((liftM ((OracleWorld + SigningSpec).query input) : + OracleComp (OracleWorld + SigningSpec) _) >>= next) = (do + let output ← liftM ((OracleWorld + SigningSpec).query input) + (fun result => (result.1, signingLogFragment input output ++ result.2)) <$> + signingTraceComputation (next output)) := by + simp [signingTraceComputation] + +theorem chainInvariant_maskedExpandedAdversaryQuery + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (targetCache : QueryCache HashSpec) (allowedLog : QueryLog SigningSpec) + (hlogRuns : ∀ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), entry ∈ allowedLog → entry.2 = some signature → + SuccessfulSignRun f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + entry.1 signature) : + ∀ (input : (OracleWorld + SigningSpec).Domain) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (output : (OracleWorld + SigningSpec).Range input), + StableCacheAgreesWithFn parameter finalCache f → + (∀ coordinate cached, finalState.values coordinate = some cached → + cached = table coordinate) → + (∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) → + ChainInvariant parameter + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) allowedLog) + state cache → + (∀ entry, entry ∈ signingLogFragment input output → entry ∈ allowedLog) → + LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedExpandedAdversaryImpl parameter root ftsSecret input).run cache)) → + ChainInvariant parameter + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) allowedLog) + finalState finalCache := by + intro input + cases input with + | inl oracleQuery => + intro state finalState cache finalCache fuel remaining output hf htable hrealizes + hinvariant hfragment hresult + change LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + (support (LazyRevealProbe.runRaw state fuel + ((probingRomImpl parameter oracleQuery).run cache)) : + Set (LazyRevealProbe.RawResult Coordinate + (OracleWorld.Range oracleQuery × SplitHashCache))) at hresult + exact (preservesChainInvariantImpl_probingRomImpl + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) allowedLog) + (coveredChainCoordinate_forwardClosed f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) allowedLog) + parameter oracleQuery) state cache fuel finalState remaining output finalCache hinvariant + hresult + | inr message => + intro state finalState cache finalCache fuel remaining output hf htable hrealizes + hinvariant hfragment hresult + change LazyRevealProbe.RawResult.done finalState remaining (output, finalCache) ∈ + (support (LazyRevealProbe.runRaw state fuel + ((maskedSign parameter root ftsSecret message).run cache)) : + Set (LazyRevealProbe.RawResult Coordinate + (SigningSpec.Range message × SplitHashCache))) at hresult + apply chainInvariant_maskedSign_covered f parameter root table ftsSecret message targetCache + allowedLog state finalState cache finalCache fuel remaining output hf htable hrealizes + hinvariant + · exact hresult + · exact hfragment ⟨message, output⟩ (by simp [signingLogFragment]) + · intro signature hsignature + exact hlogRuns ⟨message, output⟩ signature + (hfragment _ (by simp [signingLogFragment])) hsignature + +theorem chainInvariant_signingTraceComputation + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (root : Digest) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (targetCache : QueryCache HashSpec) (allowedLog signingLog : QueryLog SigningSpec) + (hlogRuns : ∀ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), entry ∈ allowedLog → entry.2 = some signature → + SuccessfulSignRun f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + entry.1 signature) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (value : alpha) + (hsub : ∀ entry, entry ∈ signingLog → entry ∈ allowedLog) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hinvariant : ChainInvariant parameter + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) allowedLog) + state cache) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + ((value, signingLog), finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation computation)).run cache))) : + ChainInvariant parameter + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) allowedLog) + finalState finalCache := by + induction computation using OracleComp.inductionOn generalizing signingLog state cache fuel with + | pure result => + simp [signingTraceComputation, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, hvalue, rfl⟩ + exact hinvariant + | query_bind input next ih => + rw [signingTraceComputation_query_bind, simulateQ_bind, simulateQ_spec_query, + StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨queryRaw, hquery, hrest⟩ := hresult + cases queryRaw with + | stopped hit => simp at hrest + | done queryState queryRemaining queryResult => + rcases queryResult with ⟨output, queryCache⟩ + simp only at hrest + rw [map_eq_bind_pure_comp, simulateQ_bind, StateT.run_bind, + LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hrest + obtain ⟨tailRaw, htail, hfinish⟩ := hrest + cases tailRaw with + | stopped hit => simp at hfinish + | done tailState tailRemaining tailResult => + rcases tailResult with ⟨⟨tailValue, tailLog⟩, tailCache⟩ + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, houtputs, rfl⟩ + rcases houtputs with ⟨rfl, rfl⟩ + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation (next output))).run queryCache) + queryState finalState queryRemaining remaining + ((value, tailLog), finalCache) htail + have htableQuery : ∀ coordinate cached, + queryState.values coordinate = some cached → cached = table coordinate := + fun coordinate cached hcached => + htable coordinate cached (hvaluesLE coordinate cached hcached) + have hfQuery : StableCacheAgreesWithFn parameter queryCache f := + StableCacheAgreesWithFn.of_run + (fun stableInput hstable => + (ordinaryEntryPreservingImpl_maskedExpandedAdversaryImpl parameter root + ftsSecret stableInput hstable).simulateQ + (signingTraceComputation (next output))) + queryState finalState queryCache finalCache queryRemaining remaining + (value, tailLog) hf htail + have hqueryInvariant := chainInvariant_maskedExpandedAdversaryQuery f parameter + root table ftsSecret targetCache allowedLog hlogRuns input state queryState cache + queryCache fuel queryRemaining output hfQuery htableQuery hrealizes hinvariant + (fun entry hentry => hsub entry + (List.mem_append_left tailLog hentry)) hquery + apply ih output tailLog queryState queryCache queryRemaining + · intro entry hentry + exact hsub entry (List.mem_append_right _ hentry) + · exact hqueryInvariant + · exact htail + +theorem chainInvariant_retainedGameRestComputation + (adversary : Adversary) (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (root : Digest) (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (targetCache : QueryCache HashSpec) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (forgery : Forgery) (signingLog : QueryLog SigningSpec) (verified : Bool) + (hlogRuns : ∀ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), entry ∈ signingLog → entry.2 = some signature → + SuccessfulSignRun f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + entry.1 signature) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hinvariant : ChainInvariant parameter + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) signingLog) + state cache) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (((forgery, signingLog), verified), finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).run cache))) : + ChainInvariant parameter + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) signingLog) + finalState finalCache := by + rw [simulateQ_maskedExpanded_retainedGameRestComputation, StateT.run_bind, + LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨prefixRaw, hprefix, hrest⟩ := hresult + cases prefixRaw with + | stopped hit => simp at hrest + | done prefixState prefixRemaining prefixResult => + rcases prefixResult with ⟨⟨prefixForgery, prefixLog⟩, prefixCache⟩ + simp only at hrest + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hrest + obtain ⟨verifyRaw, hverify, hfinish⟩ := hrest + cases verifyRaw with + | stopped hit => simp at hfinish + | done verifyState verifyRemaining verifyResult => + rcases verifyResult with ⟨prefixVerified, verifyCache⟩ + simp [LazyRevealProbe.runRaw] at hfinish + rcases hfinish with ⟨rfl, rfl, houtputs, rfl⟩ + rcases houtputs with ⟨hprefixOutput, rfl⟩ + rcases hprefixOutput with ⟨rfl, rfl⟩ + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).run + prefixCache) prefixState finalState prefixRemaining remaining + (verified, finalCache) hverify + have htablePrefix : ∀ coordinate output, + prefixState.values coordinate = some output → output = table coordinate := + fun coordinate output hcached => + htable coordinate output (hvaluesLE coordinate output hcached) + have hfPrefix : StableCacheAgreesWithFn parameter prefixCache f := + StableCacheAgreesWithFn.of_run + (fun input hstable => + (ordinaryEntryPreservingImpl_probingRomImpl parameter input hstable).simulateQ + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)) + prefixState finalState prefixCache finalCache prefixRemaining remaining verified hf + hverify + have hprefixInvariant := chainInvariant_signingTraceComputation f parameter root table + ftsSecret targetCache signingLog signingLog hlogRuns + (adversary.main ⟨root, parameter⟩) state prefixState cache prefixCache fuel + prefixRemaining forgery (fun entry => id) hfPrefix htablePrefix hrealizes + hinvariant hprefix + exact (preservesChainInvariantImpl_probingRomImpl + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) signingLog) + (coveredChainCoordinate_forwardClosed f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) signingLog) + parameter).simulateQ + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature) + prefixState prefixCache prefixRemaining finalState remaining verified finalCache + hprefixInvariant hverify + +theorem preservesChainInvariant_publishCoordinate_of_not_chain + (parameter : PublicParameter) (allowed : Coordinate → Prop) (coordinate : Coordinate) + (hnotChain : ¬IsChainCoordinate coordinate) : + PreservesChainInvariant parameter allowed (publishCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hinvariant hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.publishQuery coordinate >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.publishQuery, LazyRevealProbe.runRaw_publish_query_bind] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + refine ⟨?_, hinvariant.2.publish coordinate⟩ + intro other hchain + have hne : other ≠ coordinate := by + intro heq + exact hnotChain (heq ▸ hchain) + simpa [LazyRevealProbe.State.publish, hne] using hinvariant.1 other hchain + +theorem finalizeDetailedFrom_preserves_value + (coordinates : List Coordinate) : + ∀ (state finalState : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (output : HashOutput), state.values coordinate = some output → + (false, finalState) ∈ support + (LazyRevealProbe.finalizeDetailedFrom coordinates state) → + finalState.values coordinate = some output := by + induction coordinates with + | nil => + intro state finalState coordinate output hvalue hresult + simp [LazyRevealProbe.finalizeDetailedFrom] at hresult + subst finalState + exact hvalue + | cons current remaining ih => + intro state finalState coordinate output hvalue hresult + rw [LazyRevealProbe.finalizeDetailedFrom] at hresult + cases hcurrent : state.values current with + | some currentOutput => + rw [hcurrent] at hresult + apply ih (state.clearPending current) finalState coordinate output + · exact hvalue + · exact hresult + | none => + rw [hcurrent, mem_support_bind_iff] at hresult + obtain ⟨sampled, _, hrest⟩ := hresult + by_cases hhit : state.hitAt current sampled + · rw [if_pos hhit] at hrest + simp at hrest + · rw [if_neg hhit] at hrest + apply ih (state.complete current sampled) finalState coordinate output + · have hne : coordinate ≠ current := by + intro heq + subst current + rw [hcurrent] at hvalue + simp at hvalue + simpa [LazyRevealProbe.State.complete, Function.update, hne] using hvalue + · exact hrest + +theorem finalizeDetailedFrom_materializes_mem : + ∀ (coordinates : List Coordinate) + (state finalState : LazyRevealProbe.State Coordinate) (coordinate : Coordinate), + coordinate ∈ coordinates → + (false, finalState) ∈ support + (LazyRevealProbe.finalizeDetailedFrom coordinates state) → + finalState.values coordinate ≠ none := by + intro coordinates + induction coordinates with + | nil => + intro state finalState coordinate hmem + simp at hmem + | cons current remaining ih => + intro state finalState coordinate hmem hresult + rw [LazyRevealProbe.finalizeDetailedFrom] at hresult + cases hcurrent : state.values current with + | some output => + rw [hcurrent] at hresult + rcases List.mem_cons.mp hmem with heq | htail + · subst coordinate + exact Option.ne_none_iff_exists'.2 ⟨output, + finalizeDetailedFrom_preserves_value remaining + (state.clearPending current) finalState current output + (by simpa [LazyRevealProbe.State.clearPending] using hcurrent) hresult⟩ + · exact ih (state.clearPending current) finalState coordinate htail hresult + | none => + rw [hcurrent, mem_support_bind_iff] at hresult + obtain ⟨output, _, hrest⟩ := hresult + by_cases hhit : state.hitAt current output + · rw [if_pos hhit] at hrest + simp at hrest + · rw [if_neg hhit] at hrest + rcases List.mem_cons.mp hmem with heq | htail + · subst coordinate + exact Option.ne_none_iff_exists'.2 ⟨output, + finalizeDetailedFrom_preserves_value remaining + (state.complete current output) finalState current output + (by simp [LazyRevealProbe.State.complete]) hrest⟩ + · exact ih (state.complete current output) finalState coordinate htail hrest + +theorem finalizeDetailed_materializes_coordinate + (state finalState : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (hcoordinate : coordinate ∈ state.coordinates) + (hresult : (false, finalState) ∈ support + (LazyRevealProbe.finalizeDetailed state)) : + finalState.values coordinate ≠ none := by + exact finalizeDetailedFrom_materializes_mem state.coordinates.toList state finalState + coordinate (by simpa using hcoordinate) hresult + +theorem finalizeDetailed_materializes_ensured + (state finalState : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (hcoordinate : coordinate ∈ state.ensured) + (hresult : (false, finalState) ∈ support + (LazyRevealProbe.finalizeDetailed state)) : + finalState.values coordinate ≠ none := by + apply finalizeDetailed_materializes_coordinate state finalState coordinate + · simp [LazyRevealProbe.State.coordinates, hcoordinate] + · exact hresult + +theorem completedSplitHashCache_eq_table_of_finalize + (table : Coordinate → HashOutput) + (state finalState : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (coordinate : Coordinate) (hcoordinate : coordinate ∈ state.coordinates) + (hconsistent : HiddenConsistent state cache) + (htable : ∀ other output, finalState.values other = some output → + output = table other) + (hresult : (false, finalState) ∈ support + (LazyRevealProbe.finalizeDetailed state)) : + completedSplitHashCache table state.coordinates cache (.hidden coordinate) = + some (table coordinate) := by + unfold completedSplitHashCache + change (match cache (.hidden coordinate) with + | some output => some output + | none => if coordinate ∈ state.coordinates then some (table coordinate) else none) = + some (table coordinate) + cases hcache : cache (.hidden coordinate) with + | none => simp [hcoordinate] + | some output => + have hstateValue := hconsistent coordinate output hcache + have hfinalValue := finalizeDetailedFrom_preserves_value state.coordinates.toList + state finalState coordinate output hstateValue hresult + rw [htable coordinate output hfinalValue] + +theorem mergedCache_tableInput_eq_table_of_finalize + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (state finalState : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (position : Position) (hots : IsOtsPosition position) + (hcoordinate : Coordinate.position position ∈ state.coordinates) + (hconsistent : HiddenConsistent state cache) + (htable : ∀ other output, finalState.values other = some output → + output = table other) + (hresult : (false, finalState) ∈ support + (LazyRevealProbe.finalizeDetailed state)) : + mergedCache parameter table state.coordinates cache + (tableInput parameter table (.position position)) = + some (table (.position position)) := by + rw [mergedCache_tableInput parameter table state.coordinates cache position hots] + exact completedSplitHashCache_eq_table_of_finalize table state finalState cache + (.position position) hcoordinate hconsistent htable hresult + +theorem finalizeDetailedFrom_false_of_pending_hit + (table : Coordinate → HashOutput) : + ∀ (coordinates : List Coordinate) (state finalState : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate), coordinate ∈ coordinates → + state.values coordinate = none → state.hitAt coordinate (table coordinate) → + (∀ output, finalState.values coordinate = some output → output = table coordinate) → + (false, finalState) ∈ support + (LazyRevealProbe.finalizeDetailedFrom coordinates state) → False := by + intro coordinates + induction coordinates with + | nil => + intro state finalState coordinate hmem + simp at hmem + | cons current remaining ih => + intro state finalState coordinate hmem hvalue hhit htable hresult + rw [LazyRevealProbe.finalizeDetailedFrom] at hresult + by_cases heq : current = coordinate + · subst current + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨sampled, _, hrest⟩ := hresult + by_cases hsampledHit : state.hitAt coordinate sampled + · rw [if_pos hsampledHit] at hrest + simp at hrest + · rw [if_neg hsampledHit] at hrest + have hcompleted : (state.complete coordinate sampled).values coordinate = + some sampled := by + simp [LazyRevealProbe.State.complete] + have hfinalValue := finalizeDetailedFrom_preserves_value remaining + (state.complete coordinate sampled) finalState coordinate sampled hcompleted hrest + have hsampled := htable sampled hfinalValue + subst sampled + exact hsampledHit hhit + · have htailMem : coordinate ∈ remaining := by + simp only [List.mem_cons] at hmem + rcases hmem with hcurrentEq | htail + · exact (heq hcurrentEq.symm).elim + · exact htail + have hne : coordinate ≠ current := fun hcoordinate => heq hcoordinate.symm + have hpending : (coordinate, truncateHash (table coordinate)) ∈ state.pending := by + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt] using hhit + cases hcurrent : state.values current with + | some currentOutput => + rw [hcurrent] at hresult + apply ih (state.clearPending current) finalState coordinate htailMem + · exact hvalue + · simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, + LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway, + hne] using And.intro hpending hne + · exact htable + · exact hresult + | none => + rw [hcurrent, mem_support_bind_iff] at hresult + obtain ⟨sampled, _, hrest⟩ := hresult + by_cases hsampledHit : state.hitAt current sampled + · rw [if_pos hsampledHit] at hrest + simp at hrest + · rw [if_neg hsampledHit] at hrest + apply ih (state.complete current sampled) finalState coordinate htailMem + · simp [LazyRevealProbe.State.complete, Function.update, hne, hvalue] + · simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, + LazyRevealProbe.State.complete, LazyRevealProbe.State.pendingAway, + hne] using And.intro hpending hne + · exact htable + · exact hrest + +theorem finalizeDetailed_false_of_pending_hit + (table : Coordinate → HashOutput) (state finalState : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) (hvalue : state.values coordinate = none) + (hhit : state.hitAt coordinate (table coordinate)) + (htable : ∀ output, finalState.values coordinate = some output → + output = table coordinate) + (hresult : (false, finalState) ∈ support + (LazyRevealProbe.finalizeDetailed state)) : False := by + apply finalizeDetailedFrom_false_of_pending_hit table state.coordinates.toList state finalState + coordinate + · have hpending : ∃ candidate, (coordinate, candidate) ∈ state.pending := by + rw [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt] at hhit + simp only [Finset.mem_image, Finset.mem_filter] at hhit + obtain ⟨entry, ⟨hentry, hcoordinate⟩, _⟩ := hhit + exact ⟨entry.2, hcoordinate ▸ hentry⟩ + simp [LazyRevealProbe.State.coordinates, hpending] + · exact hvalue + · exact hhit + · exact htable + · exact hresult + +theorem ChainInvariant.not_finalized_false_of_uncovered_probe + {f : QueryImpl HashSpec Id} {parameter : PublicParameter} + {table : Coordinate → HashOutput} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {allowed : Coordinate → Prop} {state finalState : LazyRevealProbe.State Coordinate} + {cache : SplitHashCache} (hinvariant : ChainInvariant parameter allowed state cache) + (probe : Probe) (input : HashInput) + (hhits : probe.Hits f parameter (tableOtsSecret table) ftsSecret) + (hmatches : probe.MatchesInput parameter input) + (hcached : cache (.ordinary input) ≠ none) (hnotAllowed : ¬allowed probe.coordinate) + (htable : ∀ output, finalState.values probe.coordinate = some output → + output = table probe.coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hfinalize : (false, finalState) ∈ support + (LazyRevealProbe.finalizeDetailed state)) : False := by + have hchain := probe.isChainCoordinate_of_matchesInput hmatches + have hhit := hinvariant.2.hitAt f table ftsSecret probe input hchain hrealizes hhits hmatches + hcached hnotAllowed + have hvalue := hinvariant.1.value_eq_none_of_not_allowed hchain hnotAllowed + exact finalizeDetailed_false_of_pending_hit table state finalState probe.coordinate hvalue hhit + htable hfinalize + +theorem ChainInvariant.not_finalized_false_of_uncovered_probe_through + {f : QueryImpl HashSpec Id} {parameter : PublicParameter} + {table : Coordinate → HashOutput} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {allowed : Coordinate → Prop} + {initialState rawState completedState : LazyRevealProbe.State Coordinate} + {initialCache rawCache : SplitHashCache} + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {fuel remaining : Nat} {value : alpha} + (hinvariant : ChainInvariant parameter allowed initialState initialCache) + (probe : Probe) (input : HashInput) + (hhits : probe.Hits f parameter (tableOtsSecret table) ftsSecret) + (hmatches : probe.MatchesInput parameter input) + (hcached : initialCache (.ordinary input) ≠ none) + (hnotAllowed : ¬allowed probe.coordinate) + (hcompletedTable : ∀ output, + completedState.values probe.coordinate = some output → + output = table probe.coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (htransition : LazyRevealProbe.RawResult.done rawState remaining (value, rawCache) ∈ + support (LazyRevealProbe.runRaw initialState fuel (computation.run initialCache))) + (hfinalize : (false, completedState) ∈ support + (LazyRevealProbe.finalizeDetailed rawState)) : False := by + have hchain := probe.isChainCoordinate_of_matchesInput hmatches + have hhit := hinvariant.2.hitAt f table ftsSecret probe input hchain hrealizes hhits hmatches + hcached hnotAllowed + have hvalue := hinvariant.1.value_eq_none_of_not_allowed hchain hnotAllowed + have htableRaw : ∀ output, rawState.values probe.coordinate = some output → + output = table probe.coordinate := by + intro output hraw + apply hcompletedTable output + exact finalizeDetailedFrom_preserves_value rawState.coordinates.toList rawState completedState + probe.coordinate output hraw hfinalize + have hpersist := LazyRevealProbe.pendingHit_preserved_of_mem_runRaw_done + (computation.run initialCache) probe.coordinate (table probe.coordinate) initialState rawState + fuel remaining (value, rawCache) hvalue hhit htableRaw htransition + exact finalizeDetailed_false_of_pending_hit table rawState completedState probe.coordinate + hpersist.1 hpersist.2 hcompletedTable hfinalize + +set_option maxRecDepth 10000 in +set_option linter.constructorNameAsVariable false in +theorem chainInvariant_maskedRetainedGameAfterFtsSecrets + (adversary : Adversary) (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (targetCache : QueryCache HashSpec) (fuel remaining : Nat) + (finalState : LazyRevealProbe.State Coordinate) (finalCache : SplitHashCache) + (root : Digest) (forgery : Forgery) (signingLog : QueryLog SigningSpec) + (verified : Bool) + (hlogRuns : ∀ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), entry ∈ signingLog → entry.2 = some signature → + SuccessfulSignRun f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + entry.1 signature) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (htable : ∀ coordinate output, finalState.values coordinate = some output → + output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + ((root, ((forgery, signingLog), verified)), finalCache) ∈ support + (LazyRevealProbe.runRaw (LazyRevealProbe.State.empty : + LazyRevealProbe.State Coordinate) fuel + ((maskedRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache))) : + ∃ verifierState verifierFuel verifierCache, + ChainInvariant parameter + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) signingLog) + verifierState verifierCache ∧ + LazyRevealProbe.RawResult.done finalState remaining (verified, finalCache) ∈ support + (LazyRevealProbe.runRaw verifierState verifierFuel + ((simulateQ (verifierRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).run + verifierCache)) := by + let rootCoordinate : Coordinate := .position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0) + unfold maskedRetainedGameAfterFtsSecrets at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨rootRaw, hroot, hafterRoot⟩ := hresult + cases rootRaw with + | stopped hit => simp at hafterRoot + | done rootState rootRemaining rootResult => + rcases rootResult with ⟨sampledRoot, rootCache⟩ + change LazyRevealProbe.RawResult.done rootState rootRemaining + (sampledRoot, rootCache) ∈ support + (LazyRevealProbe.runRaw (LazyRevealProbe.State.empty : + LazyRevealProbe.State Coordinate) fuel + ((maskedTreeRoot topLayer rootTree).run emptySplitHashCache)) at hroot + generalize topLayer = rootLay at hroot + generalize rootTree = rootTreeIndex at hroot + simp only at hafterRoot + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hafterRoot + obtain ⟨publishRaw, hpublish, hafterPublish⟩ := hafterRoot + cases publishRaw with + | stopped hit => simp at hafterPublish + | done publishState publishRemaining publishResult => + rcases publishResult with ⟨publishedUnit, publishCache⟩ + simp only at hafterPublish + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterPublish + obtain ⟨restRaw, hrest, hfinish⟩ := hafterPublish + cases restRaw with + | stopped hit => simp at hfinish + | done restState restRemaining restResult => + rcases restResult with ⟨⟨prefixForgery, prefixLog⟩, restCache⟩ + simp only at hfinish + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hfinish + obtain ⟨verifyRaw, hverify, hreturn⟩ := hfinish + cases verifyRaw with + | stopped hit => simp at hreturn + | done verifyState verifyRemaining verifyResult => + rcases verifyResult with ⟨prefixVerified, verifyCache⟩ + simp [LazyRevealProbe.runRaw] at hreturn + rcases hreturn with ⟨rfl, rfl, houtput, rfl⟩ + rcases houtput with ⟨hrootEq, hrestEq, rfl⟩ + rcases hrestEq with ⟨rfl, rfl⟩ + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((simulateQ (verifierRomImpl parameter) + (scheme.verify ⟨sampledRoot, parameter⟩ forgery.message + forgery.signature)).run restCache) + restState finalState restRemaining remaining (verified, finalCache) hverify + have htableRest : ∀ coordinate output, + restState.values coordinate = some output → output = table coordinate := + fun coordinate output hcached => + htable coordinate output (hvaluesLE coordinate output hcached) + have hfRest : StableCacheAgreesWithFn parameter restCache f := + StableCacheAgreesWithFn.of_run + (fun input _ => + (ordinaryEntryPreservingImpl_verifierRomImpl parameter input).simulateQ + (scheme.verify ⟨sampledRoot, parameter⟩ forgery.message + forgery.signature)) + restState finalState restCache finalCache restRemaining remaining verified hf + hverify + have hlogRunsSampled : + ∀ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), entry ∈ signingLog → + entry.2 = some signature → + SuccessfulSignRun f targetCache + (⟨parameter, sampledRoot, tableOtsSecret table, + ftsSecret⟩ : SecretKey) entry.1 signature := by + simpa only [hrootEq] using hlogRuns + let allowed := CoveredChainCoordinate f targetCache + (⟨parameter, sampledRoot, tableOtsSecret table, + ftsSecret⟩ : SecretKey) signingLog + have hrootInvariantEmpty := chainInvariant_maskedTreeRoot_empty + (parameter := parameter) (allowed := fun _ => False) (lay := rootLay) + (tree := rootTreeIndex) fuel rootRemaining rootState sampledRoot rootCache hroot + have hrootInvariant : ChainInvariant parameter allowed rootState rootCache := + hrootInvariantEmpty.mono (by simp) + have hpublishInvariant := + preservesChainInvariant_publishCoordinate_of_not_chain parameter allowed + rootCoordinate (by simp [rootCoordinate, IsChainCoordinate]) + (state := rootState) (cache := rootCache) (fuel := rootRemaining) + (finalState := publishState) (remaining := publishRemaining) + (value := publishedUnit) (finalCache := publishCache) hrootInvariant + (by simpa [rootCoordinate] using hpublish) + have hverifierInvariant := chainInvariant_signingTraceComputation f parameter + sampledRoot table ftsSecret targetCache signingLog signingLog hlogRunsSampled + (adversary.main ⟨sampledRoot, parameter⟩) publishState restState publishCache + restCache publishRemaining restRemaining forgery (fun entry => id) hfRest + htableRest hrealizes hpublishInvariant hrest + refine ⟨restState, restRemaining, restCache, ?_, ?_⟩ + · simpa only [hrootEq] using hverifierInvariant + · simpa only [hrootEq] using hverify + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePermissiveFuel125.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePermissiveFuel125.lean new file mode 100644 index 00000000..77dca797 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePermissiveFuel125.lean @@ -0,0 +1,234 @@ +import SphincsSecurity.Proof.OtsProbeResidual125 + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +def PermissiveCleanFuelRel (leftFuel rightFuel : Nat) : + Option (CleanRunResult α) → Option (CleanRunResult α) → Prop + | some left, some right => PermissiveStateRel left.state right.state ∧ + left.remaining = leftFuel ∧ right.remaining = rightFuel ∧ + left.value = right.value ∧ left.table = right.table + | _, _ => False + +set_option maxRecDepth 100000 in +theorem relTriple_runPermissive_probeFree_of_stateRel + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (left right : LazyRevealProbe.State Coordinate) (leftFuel rightFuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hstate : PermissiveStateRel left right) + (hfree : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) : + RelTriple + (runPermissiveFromTable left leftFuel table computation) + (runPermissiveFromTable right rightFuel table computation) + (PermissiveCleanFuelRel leftFuel rightFuel) := by + induction computation using OracleComp.inductionOn generalizing left right leftFuel rightFuel with + | pure value => + simp [runPermissiveFromTable, PermissiveCleanFuelRel, hstate] + | query_bind query next ih => + rw [runPermissiveFromTable, OracleComp.construct_query_bind, + runPermissiveFromTable, OracleComp.construct_query_bind] + rw [OracleComp.isQueryBoundP_query_bind_iff] at hfree + have hnext : ∀ output, (next output).IsQueryBoundP LazyRevealProbe.IsProbe 0 := by + intro output + simpa using hfree.2 output + have ih := fun output left right leftFuel rightFuel hstate => + ih output left right leftFuel rightFuel hstate (hnext output) + cases query with + | uniform n => + apply relTriple_bind (relTriple_refl (liftM (unifSpec.query n))) + intro leftOutput rightOutput heq + subst rightOutput + exact ih leftOutput left right leftFuel rightFuel hstate + | hashOutput => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + exact ih leftOutput left right leftFuel rightFuel hstate + | ensure coordinate => + exact ih () (left.ensure coordinate) (right.ensure coordinate) leftFuel rightFuel + (hstate.ensure coordinate) + | probe coordinate candidate => + simpa [LazyRevealProbe.IsProbe] using hfree.1 + | peek coordinate => + have hvalue := congrFun hstate.values coordinate + simp only + rw [hvalue] + exact ih (right.values coordinate) left right leftFuel rightFuel hstate + | publish coordinate => + exact ih () (left.publish coordinate) (right.publish coordinate) leftFuel rightFuel + (hstate.publish coordinate) + | reveal coordinate => + have hvalue := congrFun hstate.values coordinate + cases hleft : left.values coordinate with + | some output => + have hright : right.values coordinate = some output := by + rw [← hvalue] + exact hleft + simp only [hleft, hright] + exact ih output left right leftFuel rightFuel hstate + | none => + have hright : right.values coordinate = none := by + rw [← hvalue] + exact hleft + simp only [hleft, hright] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact ih (table ⟨lay, tree, leafIdx, chainIdx⟩) + (left.materialize (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩)) + (right.materialize (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩)) leftFuel rightFuel + (hstate.materialize (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩)) + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + exact ih leftOutput (left.materialize (.position position) leftOutput) + (right.materialize (.position position) leftOutput) leftFuel rightFuel + (hstate.materialize (.position position) leftOutput) + +noncomputable def afterOptionalPermissiveProbe + (state : LazyRevealProbe.State Coordinate) : Option Probe → LazyRevealProbe.State Coordinate + | none => state + | some candidate => + if candidate.coordinate ∈ state.revealed then state + else state.addPending candidate.coordinate candidate.candidate + +theorem afterOptionalPermissiveProbe_stateRel + (left right : LazyRevealProbe.State Coordinate) (leftCandidate rightCandidate : Option Probe) + (hstate : PermissiveStateRel left right) : + PermissiveStateRel (afterOptionalPermissiveProbe left leftCandidate) + (afterOptionalPermissiveProbe right rightCandidate) := by + classical + cases leftCandidate <;> cases rightCandidate <;> + simp only [afterOptionalPermissiveProbe] <;> + (try split_ifs) <;> exact ⟨hstate.values, hstate.revealed⟩ + +set_option maxRecDepth 100000 in +theorem runPermissive_optionalProbe + (candidate : Option Probe) + (computation : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hfuel : candidate.isSome.toNat ≤ fuel) : + runPermissiveFromTable state fuel table ((executeCandidate? candidate >>= fun _ => computation).run cache) = + runPermissiveFromTable (afterOptionalPermissiveProbe state candidate) + (fuel - candidate.isSome.toNat) table (computation.run cache) := by + classical + cases candidate with + | none => simp [afterOptionalPermissiveProbe] + | some candidate => + cases fuel with + | zero => simp at hfuel + | succ remaining => + change runPermissiveFromTable state (remaining + 1) table + (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate >>= fun _ => + computation.run cache) = _ + simp only [LazyRevealProbe.probeQuery, runPermissiveFromTable, + OracleComp.construct_query_bind, Option.isSome_some, Bool.toNat_true, + Nat.add_sub_cancel, afterOptionalPermissiveProbe] + split_ifs <;> rfl + +def PermissiveStepRel (leftFuel rightFuel charge : Nat) : + Option (CleanRunResult α) → Option (CleanRunResult α) → Prop + | some left, some right => PermissiveStateRel left.state right.state ∧ + leftFuel ≤ left.remaining + charge ∧ rightFuel ≤ right.remaining + charge ∧ + left.value = right.value ∧ left.table = right.table + | _, _ => False + +set_option maxRecDepth 100000 in +theorem relTriple_permissive_optionalProbe + (leftCandidate rightCandidate : Option Probe) + (computation : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) + (left right : LazyRevealProbe.State Coordinate) (leftFuel rightFuel charge : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hstate : PermissiveStateRel left right) + (hfree : (computation.run cache).IsQueryBoundP LazyRevealProbe.IsProbe 0) + (hleftCost : leftCandidate.isSome.toNat ≤ charge) + (hrightCost : rightCandidate.isSome.toNat ≤ charge) + (hleftFuel : charge ≤ leftFuel) (hrightFuel : charge ≤ rightFuel) : + RelTriple + (runPermissiveFromTable left leftFuel table + ((executeCandidate? leftCandidate >>= fun _ => computation).run cache)) + (runPermissiveFromTable right rightFuel table + ((executeCandidate? rightCandidate >>= fun _ => computation).run cache)) + (PermissiveStepRel leftFuel rightFuel charge) := by + rw [runPermissive_optionalProbe leftCandidate computation left leftFuel table cache + (hleftCost.trans hleftFuel), + runPermissive_optionalProbe rightCandidate computation right rightFuel table cache + (hrightCost.trans hrightFuel)] + apply relTriple_post_mono + (relTriple_runPermissive_probeFree_of_stateRel (computation.run cache) _ _ _ _ table + (afterOptionalPermissiveProbe_stateRel left right leftCandidate rightCandidate hstate) hfree) + intro leftResult rightResult hresult + cases leftResult with + | none => exact False.elim hresult + | some leftResult => + cases rightResult with + | none => exact False.elim hresult + | some rightResult => + rcases hresult with ⟨hstate, hleft, hright, hvalue, htable⟩ + exact ⟨hstate, by omega, by omega, hvalue, htable⟩ + +theorem appendPlannedCandidate_length + (candidates : List Probe) (candidate : Option Probe) : + (appendPlannedCandidate candidates candidate).length = + candidates.length + candidate.isSome.toNat := by + cases candidate <;> simp [appendPlannedCandidate] + +set_option maxRecDepth 100000 in +theorem relTriple_delayed_rootAware_permissivePublicAction + (parameter : PublicParameter) (input : HashInput) + (left right : LazyRevealProbe.State Coordinate) (leftFuel rightFuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hstate : PermissiveStateRel left right) + (hleftFuel : 1 ≤ leftFuel) (hrightFuel : 1 ≤ rightFuel) : + RelTriple + (runPermissiveFromTable left leftFuel table + (delayedPermissivePublicAction parameter input table left cache)) + (runPermissiveFromTable right rightFuel table + (permissiveRootAwarePublicAction parameter input table right cache)) + (PermissiveStepRel leftFuel rightFuel + (rootAwareCandidateForPlan? parameter input + (permissiveRootAwarePlan parameter input table left)).isSome.toNat) := by + classical + have hvalues := materializedCanonicalContext_values_eq_of_permissiveStateRel table hstate + have hplan := purePlanProbingHashQuery_eq_of_values_eq hvalues parameter input + let publicState := (materializedCanonicalContext table left).state + let plan := permissiveRootAwarePlan parameter input table left + have hrightAction : permissiveRootAwarePublicAction parameter input table right cache = + (probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache := by + unfold permissiveRootAwarePublicAction permissiveRootAwarePublicActionWithPlan + permissiveRootAwarePlan + rw [← hplan] + exact congrArg (fun action => action.run cache) + (probingHashQueryAfterRootAwarePublicPlan_eq_of_values_eq parameter input hvalues.symm _) + rw [hrightAction] + have hleftAction : delayedPermissivePublicAction parameter input table left cache = + ((executeCandidate? plan.candidate? >>= fun _ => + probingHashQueryPublicAction parameter input publicState plan.action).run cache) := by + unfold delayedPermissivePublicAction + change (probingHashQueryAfterPublicPlan parameter input publicState plan).run cache = _ + unfold probingHashQueryAfterPublicPlan probingHashQueryPublicAction + rfl + rw [hleftAction] + change RelTriple _ + (runPermissiveFromTable right rightFuel table + ((executeCandidate? (rootAwareCandidateForPlan? parameter input plan) >>= fun _ => + probingHashQueryPublicAction parameter input publicState plan.action).run cache)) _ + have hcost : (rootAwareCandidateForPlan? parameter input plan).isSome.toNat ≤ 1 := by + cases rootAwareCandidateForPlan? parameter input plan <;> simp + apply relTriple_permissive_optionalProbe _ _ _ left right leftFuel rightFuel _ table cache + hstate (probingHashQueryPublicAction_probeFree parameter input publicState plan.action cache) + · unfold rootAwareCandidateForPlan? + cases plan.candidate? <;> simp + · exact le_rfl + · exact hcost.trans hleftFuel + · exact hcost.trans hrightFuel + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePlannedCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePlannedCharge.lean new file mode 100644 index 00000000..c6865ccd --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePlannedCharge.lean @@ -0,0 +1,134 @@ +import SphincsSecurity.Proof.OtsProbeExecutionCharge +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalOperational +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassification + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +def unmaterializedCandidateCharge (state : LazyRevealProbe.State Coordinate) : Option Probe → Nat + | none => 0 + | some candidate => if candidate.coordinate ∈ state.revealed then 0 + else LazyRevealProbe.pendingProbeCharge state candidate.coordinate candidate.candidate + +def materializedCandidateCharge (state : LazyRevealProbe.State Coordinate) : Option Probe → Nat + | none => 0 + | some candidate => if candidate.coordinate ∈ state.revealed ∨ + (candidate.coordinate, candidate.candidate) ∈ state.pending then 0 + else if state.values candidate.coordinate ≠ none then 1 else 0 + +theorem candidateCharge_sum_le_one (state : LazyRevealProbe.State Coordinate) (candidate : Option Probe) : + unmaterializedCandidateCharge state candidate + materializedCandidateCharge state candidate ≤ 1 := by + cases candidate with + | none => exact Nat.zero_le 1 + | some candidate => + simp only [unmaterializedCandidateCharge, materializedCandidateCharge, LazyRevealProbe.pendingProbeCharge] + split_ifs <;> omega + +theorem unmaterializedCandidateCharge_eq_zero_of_existingHiddenHit + (state : LazyRevealProbe.State Coordinate) (candidate : Probe) + (hhit : (cleanProbeObservation state candidate.coordinate candidate.candidate).ExistingHiddenHit) : + unmaterializedCandidateCharge state (some candidate) = 0 := by + obtain ⟨_, output, hvalue, _⟩ := hhit + change state.values candidate.coordinate = some output at hvalue + simp [unmaterializedCandidateCharge, LazyRevealProbe.pendingProbeCharge, hvalue] + +theorem materializedCandidateCharge_eq_one_of_existingHiddenHit + (state : LazyRevealProbe.State Coordinate) (candidate : Probe) + (hhit : (cleanProbeObservation state candidate.coordinate candidate.candidate).ExistingHiddenHit) + (hfresh : (candidate.coordinate, candidate.candidate) ∉ state.pending) : + materializedCandidateCharge state (some candidate) = 1 := by + obtain ⟨hrevealed, output, hvalue, _⟩ := hhit + have hhidden : candidate.coordinate ∉ state.revealed := by + simpa only [cleanProbeObservation, decide_eq_false_iff_not] using hrevealed + change state.values candidate.coordinate = some output at hvalue + simp [materializedCandidateCharge, hhidden, hfresh, hvalue] + +theorem materializedCandidateCharge_eq_one_of_first_existingHiddenHit + (state : LazyRevealProbe.State Coordinate) (candidate : Probe) (observations : List CleanProbeObservation) + (htracked : CleanProbeObservationsTrackedBy observations state) + (hcovered : CleanProbeObservationsCoverPending observations state) + (hprior : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hhit : (cleanProbeObservation state candidate.coordinate candidate.candidate).ExistingHiddenHit) : + materializedCandidateCharge state (some candidate) = 1 := by + apply materializedCandidateCharge_eq_one_of_existingHiddenHit state candidate hhit + intro hpending + let result : ObservedCleanRunResult Unit := ⟨state, 0, (), fun _ => 0, observations⟩ + have hvalid := directDeferredContext_valid_of_no_existingHiddenHit result htracked hcovered (by + rintro ⟨observation, hobservation, hearlier⟩ + exact hprior observation hobservation hearlier) + obtain ⟨_, output, hvalue, hcandidate⟩ := hhit + change state.values candidate.coordinate = some output at hvalue + apply hvalid.2 candidate.coordinate output hvalue + change truncateHash output ∈ state.pendingAt candidate.coordinate + rw [hcandidate] + exact (LazyRevealProbe.State.mem_pendingAt_iff state candidate.coordinate candidate.candidate).2 hpending + +theorem executeCandidate_expectedCharge_le (candidate : Option Probe) (cache : SplitHashCache) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) : + LazyRevealProbe.expectedProbeCharge ((executeCandidate? candidate).run cache) state fuel ≤ + unmaterializedCandidateCharge state candidate := by + cases candidate with + | none => simp [executeCandidate?, LazyRevealProbe.expectedProbeCharge, unmaterializedCandidateCharge] + | some candidate => + change LazyRevealProbe.expectedProbeCharge + ((LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate) >>= fun _ => pure ((), cache)) + state fuel ≤ _ + rw [LazyRevealProbe.probeQuery, LazyRevealProbe.expectedProbeCharge_query_bind] + cases fuel with + | zero => exact bot_le + | succ remaining => + by_cases hrevealed : candidate.coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte, unmaterializedCandidateCharge, + LazyRevealProbe.expectedProbeCharge, OracleComp.construct_pure, Nat.cast_zero, le_refl] + · simp only [hrevealed, ↓reduceIte, unmaterializedCandidateCharge, + LazyRevealProbe.expectedProbeCharge, OracleComp.construct_pure, add_zero, le_refl] + +theorem probingHashQueryAfterRootAwarePlan_expectedCharge_le + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) (cache : SplitHashCache) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) : + LazyRevealProbe.expectedProbeCharge ((probingHashQueryAfterRootAwarePlan parameter input plan).run cache) + state fuel ≤ unmaterializedCandidateCharge state (rootAwareCandidateForPlan? parameter input plan) := by + unfold probingHashQueryAfterRootAwarePlan + rw [StateT.run_bind, LazyRevealProbe.expectedProbeCharge_bind_of_tail_probeFree] + · exact executeCandidate_expectedCharge_le _ cache state fuel + · intro result + cases plan.action with + | ordinary => exact splitHashQuery_probeFree _ result.2 + | resolve coordinate => exact resolveKnownInput_probeFree parameter coordinate input result.2 + +theorem probingHashQueryAfterRootAwarePublicPlan_expectedCharge_le + (parameter : PublicParameter) (input : HashInput) (publicState : LazyRevealProbe.State Coordinate) + (plan : PlannedHashQuery) (cache : SplitHashCache) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) : + LazyRevealProbe.expectedProbeCharge + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) state fuel ≤ + unmaterializedCandidateCharge state (rootAwareCandidateForPlan? parameter input plan) := by + unfold probingHashQueryAfterRootAwarePublicPlan + rw [StateT.run_bind, LazyRevealProbe.expectedProbeCharge_bind_of_tail_probeFree] + · exact executeCandidate_expectedCharge_le _ cache state fuel + · intro result + exact probingHashQueryPublicAction_probeFree parameter input publicState plan.action result.2 + +theorem probingHashQueryAfterRootAwarePublicPlan_charge_add_materialized_le_one + (parameter : PublicParameter) (input : HashInput) (publicState : LazyRevealProbe.State Coordinate) + (plan : PlannedHashQuery) (cache : SplitHashCache) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) : + LazyRevealProbe.expectedProbeCharge + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) state fuel + + (materializedCandidateCharge state (rootAwareCandidateForPlan? parameter input plan) : ℝ≥0∞) ≤ 1 := by + apply (add_le_add (probingHashQueryAfterRootAwarePublicPlan_expectedCharge_le + parameter input publicState plan cache state fuel) le_rfl).trans + rw [← Nat.cast_add, ← Nat.cast_one] + exact Nat.cast_le.mpr (candidateCharge_sum_le_one state _) + +theorem probingHashQueryAfterRootAwarePublicPlan_charge_eq_zero_of_existingHiddenHit + (parameter : PublicParameter) (input : HashInput) (publicState : LazyRevealProbe.State Coordinate) + (plan : PlannedHashQuery) (cache : SplitHashCache) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (candidate : Probe) (hcandidate : rootAwareCandidateForPlan? parameter input plan = some candidate) + (hhit : (cleanProbeObservation state candidate.coordinate candidate.candidate).ExistingHiddenHit) : + LazyRevealProbe.expectedProbeCharge + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) state fuel = 0 := by + have hbound := probingHashQueryAfterRootAwarePublicPlan_expectedCharge_le parameter input publicState plan cache state fuel + rw [hcandidate, unmaterializedCandidateCharge_eq_zero_of_existingHiddenHit state candidate hhit, Nat.cast_zero] at hbound + exact le_antisymm hbound zero_le + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrehitOpeningProjection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrehitOpeningProjection.lean new file mode 100644 index 00000000..80ba9413 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrehitOpeningProjection.lean @@ -0,0 +1,186 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalRejectionProbability +import SphincsSecurity.Proof.EncodingPrehitViewedBound + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal TightEncoding + +set_option backward.isDefEq.respectTransparency false + +def retainedRestWithVerdict (result : RetainedRestResult) : RetainedRestResult := + (result.1, retainedRestVerdict result) + +def viewedPrehitRetainedProjection + (result : (Digest × Forgery × Bool) × (ViewedFullTraceState × Bool)) : + (RetainedGameResult × QueryCache HashSpec) × Bool := + (((result.1.1, ((result.1.2.1, result.2.1.trace.signing.toSigningLog), result.1.2.2)), result.2.1.cache), result.2.2) + +def tracePrehitRetainedProjection + (result : (RetainedGameResult × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) : + (RetainedGameResult × QueryCache HashSpec) × Bool := + (((result.1.1.1, retainedRestWithVerdict result.1.1.2), result.1.2.1.cache), result.1.2.2) + +theorem simulateQ_expanded_retained_eq_logged + (adversary : Adversary) (publicKey : PublicKey) (secretKey : SecretKey) : + simulateQ (expandedAdversaryImpl secretKey) (retainedGameRestComputation adversary publicKey) = (do + let (forgery, log) ← (simulateQ (forwardOracles + signingOracle scheme secretKey) (adversary.main publicKey)).run + let verified ← scheme.verify publicKey forgery.message forgery.signature + pure ((forgery, log), verified)) := by + unfold retainedGameRestComputation + rw [simulateQ_bind, ← simulateQ_withTraceAppend_run_eq_signingTraceComputation, + ← forwardOracles_add_signingOracle_eq_withTraceAppend] + apply bind_congr + rintro ⟨forgery, log⟩ + rw [simulateQ_bind] + have hlift : simulateQ (expandedAdversaryImpl secretKey) + (liftOracleWorldLeft (scheme.verify publicKey forgery.message forgery.signature)) = + scheme.verify publicKey forgery.message forgery.signature := + FtsProbeSimulation.simulateQ_expanded_liftOracleWorldLeft secretKey _ + rw [hlift] + simp only [simulateQ_pure] + +theorem gameRestWithEncodingPrehitView_retained_projection + (adversary : Adversary) (accountingKey : SecretKey) (publicKey : PublicKey) (secretKey : SecretKey) + (initialCache : QueryCache HashSpec) (hit : Bool) : + (fun result => ((((result.1.1, result.2.1.trace.signing.toSigningLog), result.1.2), result.2.1.cache), result.2.2)) <$> + gameRestWithEncodingPrehitView adversary accountingKey publicKey secretKey initialCache hit = + (fun result => ((retainedRestWithVerdict result.1.1, result.1.2), result.2)) <$> + runEncodingPrehitMonitor accountingKey + (simulateQ (expandedAdversaryImpl secretKey) (retainedGameRestComputation adversary publicKey)) initialCache hit := by + let finish : Forgery × ((QueryCache HashSpec × Bool) × QueryLog SigningSpec) → + ProbComp ((RetainedRestResult × QueryCache HashSpec) × Bool) := fun result => do + let verified ← runEncodingPrehitMonitor accountingKey + (scheme.verify publicKey result.1.message result.1.signature) result.2.1.1 result.2.1.2 + pure ((((result.1, result.2.2), decide (SigningTranscript.Valid result.2.2 ∧ + ¬SigningTranscript.Contains result.2.2 result.1) && verified.1.1), verified.1.2), verified.2) + let state : ViewedFullTraceState × Bool := (⟨initialCache, ⟨[], [], []⟩, [], none⟩, hit) + calc + _ = (Prod.map id encodingPrehitViewedLogState <$> + (simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) + (adversary.main publicKey)).run state) >>= finish := by + simp [gameRestWithEncodingPrehitView, state, finish, encodingPrehitViewedLogState, + runEncodingPrehitMonitor_verifyWithView_fst, map_bind, bind_map_left, Prod.map] + _ = _ := by + rw [encodingPrehitViewedAdversaryImpl_log_projection, simulateQ_expanded_retained_eq_logged] + simp only [runEncodingPrehitMonitor_bind, runEncodingPrehitMonitor_pure] + simp [finish, state, SigningCacheTrace.toSigningLog, bind_map_left, + retainedRestWithVerdict, retainedRestVerdict, map_bind] + +theorem prehitViewedGame_retainedTrace_projection + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + viewedPrehitRetainedProjection <$> gameAfterSecretsWithEncodingPrehitView adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret = + tracePrehitRetainedProjection <$> prehitRetainedQueryTrace adversary parameter table ftsSecret := by + unfold gameAfterSecretsWithEncodingPrehitView prehitRetainedQueryTrace + simp only [map_bind, map_pure] + apply bind_congr + intro root + have hview := gameRestWithEncodingPrehitView_retained_projection adversary + (primitiveAccountingKey parameter (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) + ⟨root.1.1, parameter⟩ ⟨parameter, root.1.1, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + root.1.2 root.2 + rw [← runPrehitQueryTrace_monitor_projection _ _ _ (⟨root.1.2, ⟨[], [], []⟩, [], none⟩, root.2), + Functor.map_map] at hview + have hroot := congrArg (fun run => (fun result : (RetainedRestResult × QueryCache HashSpec) × Bool => + (((root.1.1, result.1.1), result.1.2), result.2)) <$> run) hview + simpa only [Functor.map_map, Function.comp_def, map_eq_bind_pure_comp, + viewedPrehitRetainedProjection, tracePrehitRetainedProjection, bind_assoc, pure_bind] using hroot + +theorem clean_viewed_opening_imp_retained_projection_probe + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × (ViewedFullTraceState × Bool)) + (hclean : cleanOtsOpeningEvent parameter (tableOtsSecret (extendStartTable table)) ftsSecret (result.1, result.2.1)) : + WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret + (viewedPrehitRetainedProjection result).1 := by + apply winningRetainedOtsOpening_imp_verifyProbe + rcases hclean with hfresh | hbackward + · rcases hfresh with ⟨⟨hbad, hverdict⟩, f, digest, hf, hvalid, hnotContains, + hdigest, hadmissible, heval, hfresh⟩ + exact ⟨hverdict, f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, heval, hbad, Or.inl hfresh⟩ + · rcases hbackward with ⟨⟨hbad, hverdict⟩, f, digest, hf, hvalid, hnotContains, + hdigest, hadmissible, heval, hbackward⟩ + exact ⟨hverdict, f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, heval, hbad, Or.inr hbackward⟩ + +theorem retained_projection_probe_imp_probe + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (RetainedGameResult × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hwitness : WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret + (tracePrehitRetainedProjection result).1) : + WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret (result.1.1, result.1.2.1.cache) := by + rcases hwitness with ⟨hverdict, hwitness⟩ + refine ⟨?_, hwitness⟩ + cases hverified : result.1.1.2.2 with + | false => simp [tracePrehitRetainedProjection, retainedRestWithVerdict, retainedRestVerdict, hverified] at hverdict + | true => rfl + +def prehitFreeRetainedVerifyProbeEvent + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (RetainedGameResult × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) : Prop := + result.1.2.2 = false ∧ + WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret (result.1.1, result.1.2.1.cache) + +theorem probEvent_prehitFree_residual_le_retainedVerifyProbe + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[fun result => result.2.2 = false ∧ + residualOtsOpeningEvent parameter (tableOtsSecret (extendStartTable table)) ftsSecret (result.1, result.2.1) | + gameAfterSecretsWithEncodingPrehitView adversary parameter (tableOtsSecret (extendStartTable table)) ftsSecret] ≤ + Pr[prehitFreeRetainedVerifyProbeEvent parameter table ftsSecret | + prehitRetainedQueryTrace adversary parameter table ftsSecret] := by + let event : (RetainedGameResult × QueryCache HashSpec) × Bool → Prop := fun result => + result.2 = false ∧ WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret result.1 + calc + _ ≤ Pr[event ∘ viewedPrehitRetainedProjection | gameAfterSecretsWithEncodingPrehitView adversary parameter + (tableOtsSecret (extendStartTable table)) ftsSecret] := by + apply probEvent_mono + intro result _hresult hevent + exact ⟨hevent.1, clean_viewed_opening_imp_retained_projection_probe parameter table ftsSecret result hevent.2.2.2.2⟩ + _ = Pr[event ∘ tracePrehitRetainedProjection | prehitRetainedQueryTrace adversary parameter table ftsSecret] := by + rw [← probEvent_map, ← probEvent_map] + exact congrArg (fun run => Pr[event | run]) + (prehitViewedGame_retainedTrace_projection adversary parameter table ftsSecret) + _ ≤ _ := by + apply probEvent_mono + intro result _hresult hevent + exact ⟨hevent.1, retained_projection_probe_imp_probe parameter table ftsSecret result hevent.2⟩ + +noncomputable def sampledPrehitFreeRetainedVerifyProbeRisk (adversary : Adversary) : ℝ≥0∞ := + ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' table, Pr[= table | sampleOtsHashTable] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + Pr[prehitFreeRetainedVerifyProbeEvent parameter table ftsSecret | + prehitRetainedQueryTrace adversary parameter table ftsSecret] + +open OracleComp.ProgramLogic.Relational in +set_option maxRecDepth 100000 in +theorem probEvent_sampled_prehitFree_residual_le_retainedVerifyProbe + (adversary : Adversary) : + Pr[prehitFreeResidualOtsOpeningEvent | sampledEncodingPrehitViewedGame adversary] ≤ + sampledPrehitFreeRetainedVerifyProbeRisk adversary := by + unfold sampledEncodingPrehitViewedGame sampledPrehitFreeRetainedVerifyProbeRisk + simp only [sampleSecrets, bind_assoc, pure_bind, probEvent_bind_eq_tsum, probEvent_map, + Function.comp_def, prehitFreeResidualOtsOpeningEvent, SampledViewedEvent] + apply ENNReal.tsum_le_tsum + intro parameter + apply mul_le_mul' le_rfl + have hcoupled := expected_cost_le_of_relTriple (relTriple_symm relTriple_uniformOtsHashTable_sampleOtsSecrets) + (fun otsSecret => ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + Pr[fun result => result.2.2 = false ∧ residualOtsOpeningEvent parameter otsSecret ftsSecret (result.1, result.2.1) | + gameAfterSecretsWithEncodingPrehitView adversary parameter otsSecret ftsSecret]) + (fun table => ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + Pr[prehitFreeRetainedVerifyProbeEvent parameter table ftsSecret | + prehitRetainedQueryTrace adversary parameter table ftsSecret]) + (fun _ => 0) (by + intro otsSecret table hsecrets + simp only [add_zero] + rw [← hsecrets] + apply ENNReal.tsum_le_tsum + intro ftsSecret + exact mul_le_mul' le_rfl (probEvent_prehitFree_residual_le_retainedVerifyProbe adversary parameter table ftsSecret)) + simpa only [sampleOtsHashTable, mul_zero, tsum_zero, add_zero] using hcoupled + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrehitQueryTrace.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrehitQueryTrace.lean new file mode 100644 index 00000000..b27870ee --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrehitQueryTrace.lean @@ -0,0 +1,118 @@ +import SphincsSecurity.Proof.OtsProbeSelectedRootPrehit + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +structure PrehitQuerySnapshot where + input : (OracleWorld + SigningSpec).Domain + state : ViewedFullTraceState × Bool + +def PrehitQuerySnapshot.actual (entry : PrehitQuerySnapshot) : ActualQuerySelection := + ⟨entry.input, entry.state.1.cache⟩ + +noncomputable def runPrehitQueryTrace (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + ViewedFullTraceState × Bool → + ProbComp ((α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) := + OracleComp.construct (fun value state => pure ((value, state), [])) + (fun input _ next state => do + let result ← (encodingPrehitViewedAdversaryImpl accountingKey secretKey input).run state + let tail ← next result.1 result.2 + pure (tail.1, (⟨input, state⟩ : PrehitQuerySnapshot) :: tail.2)) computation + +theorem runPrehitQueryTrace_query_bind (accountingKey secretKey : SecretKey) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (state : ViewedFullTraceState × Bool) : + runPrehitQueryTrace accountingKey secretKey (OracleSpec.query input >>= next) state = (do + let result ← (encodingPrehitViewedAdversaryImpl accountingKey secretKey input).run state + let tail ← runPrehitQueryTrace accountingKey secretKey (next result.1) result.2 + pure (tail.1, (⟨input, state⟩ : PrehitQuerySnapshot) :: tail.2)) := rfl + +theorem runPrehitQueryTrace_projection (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) : + Prod.fst <$> runPrehitQueryTrace accountingKey secretKey computation state = + (simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run state := by + induction computation using OracleComp.inductionOn generalizing state with + | pure value => simp [runPrehitQueryTrace] + | query_bind input next ih => + rw [runPrehitQueryTrace_query_bind] + simp only [map_bind, map_pure, simulateQ_bind, simulateQ_spec_query, StateT.run_bind] + apply bind_congr + intro result + simpa only [map_eq_bind_pure_comp, Function.comp_def] using ih result.1 result.2 + +theorem mem_support_prehitRun_of_trace (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) + (result : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hrun : result ∈ support (runPrehitQueryTrace accountingKey secretKey computation state)) : + result.1 ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run state) := by + rw [← runPrehitQueryTrace_projection, support_map] + exact ⟨result, hrun, rfl⟩ + +set_option maxRecDepth 100000 in +theorem queryCut_support_of_mem_prehitQueryTrace + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) + (result : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hrun : result ∈ support (runPrehitQueryTrace accountingKey secretKey computation state)) + (entry : PrehitQuerySnapshot) (hentry : entry ∈ result.2) : + ∃ ordinal : Nat, ∃ cut : OuterQueryCut α, + cut.input? = some entry.input ∧ + (cut, entry.state) ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) + (outerQueryCutAt computation ordinal)).run state) := by + induction computation using OracleComp.inductionOn generalizing state result with + | pure value => + simp only [runPrehitQueryTrace, OracleComp.construct_pure, mem_support_pure_iff] at hrun + subst result + simp at hentry + | query_bind input next ih => + rw [runPrehitQueryTrace_query_bind, mem_support_bind_iff] at hrun + obtain ⟨step, hstep, hrun⟩ := hrun + rw [mem_support_bind_iff] at hrun + obtain ⟨tail, htail, hresult⟩ := hrun + simp only [mem_support_pure_iff] at hresult + subst result + rcases List.mem_cons.mp hentry with heq | htailEntry + · subst entry + refine ⟨0, .query input next, rfl, ?_⟩ + simp [outerQueryCutAt] + · obtain ⟨ordinal, cut, hinput, hcut⟩ := ih step.1 step.2 tail htail htailEntry + refine ⟨ordinal + 1, cut, hinput, ?_⟩ + rw [outerQueryCutAt, OracleComp.construct_query_bind] + simp only [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, mem_support_bind_iff] + exact ⟨step, hstep, hcut⟩ + +set_option maxRecDepth 100000 in +theorem prehitQueryTrace_entry_false_of_final_false + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) + (result : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hrun : result ∈ support (runPrehitQueryTrace accountingKey secretKey computation state)) + (hfinal : result.1.2.2 = false) (entry : PrehitQuerySnapshot) (hentry : entry ∈ result.2) : + entry.state.2 = false := by + induction computation using OracleComp.inductionOn generalizing state result with + | pure value => + simp only [runPrehitQueryTrace, OracleComp.construct_pure, mem_support_pure_iff] at hrun + subst result + simp at hentry + | query_bind input next ih => + have hproject := mem_support_prehitRun_of_trace accountingKey secretKey _ state result hrun + rw [runPrehitQueryTrace_query_bind, mem_support_bind_iff] at hrun + obtain ⟨step, hstep, hrun⟩ := hrun + rw [mem_support_bind_iff] at hrun + obtain ⟨tail, htail, hresult⟩ := hrun + simp only [mem_support_pure_iff] at hresult + subst result + rcases List.mem_cons.mp hentry with heq | htailEntry + · subst entry + exact encodingPrehitViewedAdversaryImpl_initial_false_of_mem_support accountingKey secretKey + (OracleSpec.query input >>= next) state.1 tail.1.2.1 state.2 tail.1.1 (by + dsimp only at hfinal + simpa only [← hfinal] using hproject) + · exact ih step.1 step.2 tail htail hfinal htailEntry + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrehitTracePairs.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrehitTracePairs.lean new file mode 100644 index 00000000..418fd56e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrehitTracePairs.lean @@ -0,0 +1,98 @@ +import SphincsSecurity.Proof.OtsProbePrehitQueryTrace + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +def PrehitQuerySnapshot.EncodingReserveTo (accountingKey : SecretKey) + (before after : PrehitQuerySnapshot) : Prop := + ∀ (input : HashInput) (candidate : Probe) (target : Position), + before.input = .inl (.inr input) → + EncodingLayerRootCandidateAt accountingKey.parameter input candidate → + candidate.coordinate = .position target → after.state.2 = false → + Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret after.state.1.cache target → + candidate.candidate = honestValue (fromCache after.state.1.cache) + accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret target → + (4 / 3 : ℝ≥0∞) ≤ otsOpeningRefinedQueryReserve accountingKey before.state.1.cache input + +set_option maxRecDepth 100000 in +theorem prehitQueryTrace_pairwise_encodingReserve + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) + (result : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hrun : result ∈ support (runPrehitQueryTrace accountingKey secretKey computation state)) : + result.2.Pairwise (PrehitQuerySnapshot.EncodingReserveTo accountingKey) := by + induction computation using OracleComp.inductionOn generalizing state result with + | pure value => + simp only [runPrehitQueryTrace, OracleComp.construct_pure, mem_support_pure_iff] at hrun + subst result + exact List.Pairwise.nil + | query_bind query next ih => + rw [runPrehitQueryTrace_query_bind, mem_support_bind_iff] at hrun + obtain ⟨step, hstep, hrun⟩ := hrun + rw [mem_support_bind_iff] at hrun + obtain ⟨tail, htail, hresult⟩ := hrun + simp only [mem_support_pure_iff] at hresult + subst result + apply List.Pairwise.cons ?_ (ih step.1 step.2 tail htail) + intro entry hentry input candidate target hinput hcandidate hposition hfalse hsettled hmatch + change query = .inl (.inr input) at hinput + subst query + obtain ⟨ordinal, cut, _hcutInput, hcut⟩ := queryCut_support_of_mem_prehitQueryTrace + accountingKey secretKey (next step.1) step.2 tail htail entry hentry + let segment : OracleComp (OracleWorld + SigningSpec) (OuterQueryCut α) := + (OracleWorld + SigningSpec).query (.inl (.inr input)) >>= fun answer => outerQueryCutAt (next answer) ordinal + have hprefix : (cut, entry.state) ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) segment).run state) := by + dsimp only [segment] + rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, mem_support_bind_iff] + exact ⟨step, hstep, hcut⟩ + have hprefixFalse : (cut, (entry.state.1, false)) ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) segment).run (state.1, state.2)) := by + simpa only [← hfalse] using hprefix + have hinitial := encodingPrehitViewedAdversaryImpl_initial_false_of_mem_support accountingKey secretKey + segment state.1 entry.state.1 state.2 cut hprefixFalse + rw [hinitial] at hprefixFalse + exact hcandidate.refinedReserve_of_prehitFree_viewed_matching_query secretKey hposition hsettled hmatch + (fun answer => outerQueryCutAt (next answer) ordinal) cut hprefixFalse + +def UnpaidEncodingRootMatch (accountingKey : SecretKey) (history : List PrehitQuerySnapshot) : Prop := + ∃ (i j : Fin history.length), i.val < j.val ∧ + ∃ (input : HashInput) (candidate : Probe) (target : Position), + (history.get i).input = .inl (.inr input) ∧ + EncodingLayerRootCandidateAt accountingKey.parameter input candidate ∧ + candidate.coordinate = .position target ∧ + Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret (history.get j).state.1.cache target ∧ + candidate.candidate = honestValue (fromCache (history.get j).state.1.cache) + accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret target ∧ + otsOpeningRefinedQueryReserve accountingKey (history.get i).state.1.cache input < (4 / 3 : ℝ≥0∞) + +theorem prehitQueryTrace_hit_of_unpaidEncodingRootMatch + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) + (result : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hrun : result ∈ support (runPrehitQueryTrace accountingKey secretKey computation state)) + (hmatch : UnpaidEncodingRootMatch accountingKey result.2) : result.1.2.2 = true := by + by_cases hhit : result.1.2.2 = true + · exact hhit + have hfalse := Bool.eq_false_iff.mpr hhit + obtain ⟨i, j, hij, input, candidate, target, hinput, hcandidate, hposition, hsettled, hmatch, hreserve⟩ := hmatch + have hpairs := prehitQueryTrace_pairwise_encodingReserve accountingKey secretKey computation state result hrun + have hpair := hpairs.rel_get_of_lt hij + have hentryFalse := prehitQueryTrace_entry_false_of_final_false accountingKey secretKey computation state result + hrun hfalse (result.2.get j) (List.get_mem _ _) + exact False.elim ((not_le_of_gt hreserve) + (hpair input candidate target hinput hcandidate hposition hentryFalse hsettled hmatch)) + +theorem probEvent_unpaidEncodingRootMatch_le_prehit + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) : + Pr[fun result => UnpaidEncodingRootMatch accountingKey result.2 | + runPrehitQueryTrace accountingKey secretKey computation state] ≤ + Pr[fun result => result.2.2 = true | + (simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run state] := by + rw [← runPrehitQueryTrace_projection, probEvent_map] + exact probEvent_mono fun result hresult hmatch => + prehitQueryTrace_hit_of_unpaidEncodingRootMatch accountingKey secretKey computation state result hresult hmatch + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrehitTraceTerminal.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrehitTraceTerminal.lean new file mode 100644 index 00000000..a4688ddf --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrehitTraceTerminal.lean @@ -0,0 +1,90 @@ +import SphincsSecurity.Proof.OtsProbePrehitTracePairs + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option maxRecDepth 100000 in +theorem prehitQueryTrace_encodingReserve_at_final + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) + (result : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hrun : result ∈ support (runPrehitQueryTrace accountingKey secretKey computation state)) + (entry : PrehitQuerySnapshot) (hentry : entry ∈ result.2) + (input : HashInput) (candidate : Probe) (target : Position) + (hinput : entry.input = .inl (.inr input)) + (hcandidate : EncodingLayerRootCandidateAt accountingKey.parameter input candidate) + (hposition : candidate.coordinate = .position target) (hfinal : result.1.2.2 = false) + (hsettled : Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret result.1.2.1.cache target) + (hmatch : candidate.candidate = honestValue (fromCache result.1.2.1.cache) + accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret target) : + (4 / 3 : ℝ≥0∞) ≤ otsOpeningRefinedQueryReserve accountingKey entry.state.1.cache input := by + induction computation using OracleComp.inductionOn generalizing state result with + | pure value => + simp only [runPrehitQueryTrace, OracleComp.construct_pure, mem_support_pure_iff] at hrun + subst result + simp at hentry + | query_bind query next ih => + have hproject := mem_support_prehitRun_of_trace accountingKey secretKey _ state result hrun + rw [runPrehitQueryTrace_query_bind, mem_support_bind_iff] at hrun + obtain ⟨step, hstep, hrun⟩ := hrun + rw [mem_support_bind_iff] at hrun + obtain ⟨tail, htail, hresult⟩ := hrun + simp only [mem_support_pure_iff] at hresult + subst result + rcases List.mem_cons.mp hentry with heq | htailEntry + · subst entry + change query = .inl (.inr input) at hinput + subst query + have hrunFalse : (tail.1.1, (tail.1.2.1, false)) ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next)).run (state.1, state.2)) := by + dsimp only at hfinal + simpa only [← hfinal] using hproject + have hinitial := encodingPrehitViewedAdversaryImpl_initial_false_of_mem_support accountingKey secretKey + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next) + state.1 tail.1.2.1 state.2 tail.1.1 hrunFalse + rw [hinitial] at hrunFalse + exact hcandidate.refinedReserve_of_prehitFree_viewed_matching_query secretKey hposition hsettled hmatch + next tail.1.1 hrunFalse + · exact ih step.1 step.2 tail htail htailEntry hfinal hsettled hmatch + +def UnpaidFinalEncodingRootMatch (accountingKey : SecretKey) + (result : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) : Prop := + ∃ entry ∈ result.2, ∃ (input : HashInput) (candidate : Probe) (target : Position), + entry.input = .inl (.inr input) ∧ + EncodingLayerRootCandidateAt accountingKey.parameter input candidate ∧ + candidate.coordinate = .position target ∧ + Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret result.1.2.1.cache target ∧ + candidate.candidate = honestValue (fromCache result.1.2.1.cache) + accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret target ∧ + otsOpeningRefinedQueryReserve accountingKey entry.state.1.cache input < (4 / 3 : ℝ≥0∞) + +theorem prehitQueryTrace_hit_of_unpaidFinalEncodingRootMatch + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) + (result : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hrun : result ∈ support (runPrehitQueryTrace accountingKey secretKey computation state)) + (hmatch : UnpaidFinalEncodingRootMatch accountingKey result) : result.1.2.2 = true := by + by_cases hhit : result.1.2.2 = true + · exact hhit + obtain ⟨entry, hentry, input, candidate, target, hinput, hcandidate, hposition, hsettled, hmatch, hreserve⟩ := hmatch + exact False.elim ((not_le_of_gt hreserve) (prehitQueryTrace_encodingReserve_at_final accountingKey secretKey + computation state result hrun entry hentry input candidate target hinput hcandidate hposition + (Bool.eq_false_iff.mpr hhit) hsettled hmatch)) + +theorem probEvent_unpaidTraceRootMatch_le_prehit + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) : + Pr[fun result => UnpaidEncodingRootMatch accountingKey result.2 ∨ UnpaidFinalEncodingRootMatch accountingKey result | + runPrehitQueryTrace accountingKey secretKey computation state] ≤ + Pr[fun result => result.2.2 = true | + (simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run state] := by + rw [← runPrehitQueryTrace_projection, probEvent_map] + apply probEvent_mono + intro result hresult hmatch + rcases hmatch with hpairs | hfinal + · exact prehitQueryTrace_hit_of_unpaidEncodingRootMatch accountingKey secretKey computation state result hresult hpairs + · exact prehitQueryTrace_hit_of_unpaidFinalEncodingRootMatch accountingKey secretKey computation state result hresult hfinal + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePreloadCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePreloadCharge.lean new file mode 100644 index 00000000..b75781c3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePreloadCharge.lean @@ -0,0 +1,118 @@ +import SphincsSecurity.Proof.OtsProbeRootQueryReserve +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonFactorization + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +theorem candidateCharge_sum_eq (state : LazyRevealProbe.State Coordinate) (candidate : Probe) : + unmaterializedCandidateCharge state (some candidate) + materializedCandidateCharge state (some candidate) = + if candidate.coordinate ∈ state.revealed ∨ (candidate.coordinate, candidate.candidate) ∈ state.pending then 0 else 1 := by + classical + simp only [unmaterializedCandidateCharge, materializedCandidateCharge, LazyRevealProbe.pendingProbeCharge] + split_ifs <;> simp_all + +theorem candidateCharge_sum_eq_of_pending_revealed_eq + (left right : LazyRevealProbe.State Coordinate) (candidate : Option Probe) + (hpending : left.pending = right.pending) (hrevealed : left.revealed = right.revealed) : + unmaterializedCandidateCharge left candidate + materializedCandidateCharge left candidate = + unmaterializedCandidateCharge right candidate + materializedCandidateCharge right candidate := by + cases candidate with + | none => rfl + | some candidate => rw [candidateCharge_sum_eq, candidateCharge_sum_eq, hpending, hrevealed] + +theorem candidateCharge_sum_preload_eq + (state : LazyRevealProbe.State Coordinate) (candidate : Option Probe) + (target : Position) (output : HashOutput) : + unmaterializedCandidateCharge (preloadPositionValue target output state) candidate + + materializedCandidateCharge (preloadPositionValue target output state) candidate = + unmaterializedCandidateCharge state candidate + materializedCandidateCharge state candidate := + candidateCharge_sum_eq_of_pending_revealed_eq _ _ candidate rfl rfl + +theorem materializedCandidateCharge_preload_eq_unmaterialized + (state : LazyRevealProbe.State Coordinate) (target : Position) (output : HashOutput) (candidate : Digest) + (hvalue : state.values (.position target) = none) : + materializedCandidateCharge (preloadPositionValue target output state) (some ⟨.position target, candidate⟩) = + unmaterializedCandidateCharge state (some ⟨.position target, candidate⟩) := by + classical + simp [materializedCandidateCharge, unmaterializedCandidateCharge, LazyRevealProbe.pendingProbeCharge, + preloadPositionValue, hvalue] + split_ifs <;> simp_all + +theorem unmaterializedCandidateCharge_preload_target_eq_zero + (state : LazyRevealProbe.State Coordinate) (target : Position) (output : HashOutput) (candidate : Digest) : + unmaterializedCandidateCharge (preloadPositionValue target output state) (some ⟨.position target, candidate⟩) = 0 := by + classical + simp [unmaterializedCandidateCharge, LazyRevealProbe.pendingProbeCharge, preloadPositionValue] + +theorem probingHashQueryAfterRootAwarePublicPlan_preloadedCharge_le_originalCharge + (parameter : PublicParameter) (input : HashInput) (publicState : LazyRevealProbe.State Coordinate) + (plan : PlannedHashQuery) (cache : SplitHashCache) (context : DeferredContext) (fuel : Nat) + (target : Position) (output : HashOutput) : + ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) + { context with state := preloadPositionValue target output context.state } fuel + + (materializedCandidateCharge (preloadPositionValue target output context.state) + (rootAwareCandidateForPlan? parameter input plan) : ℝ≥0∞) ≤ + ((unmaterializedCandidateCharge context.state (rootAwareCandidateForPlan? parameter input plan) + + materializedCandidateCharge context.state (rootAwareCandidateForPlan? parameter input plan) : Nat) : ℝ≥0∞) := by + unfold probingHashQueryAfterRootAwarePublicPlan + rw [StateT.run_bind, ordinaryContinuationCharge_zero_bind_of_tail_probeFree _ + (fun result : Unit × SplitHashCache => (probingHashQueryPublicAction parameter input publicState plan.action).run result.2) + (fun result => probingHashQueryPublicAction_probeFree parameter input publicState plan.action result.2)] + apply (add_le_add (executeCandidate_ordinaryCharge_le _ cache _ fuel) le_rfl).trans_eq + rw [← Nat.cast_add] + exact congrArg (fun value : Nat => (value : ℝ≥0∞)) (candidateCharge_sum_preload_eq context.state _ target output) + +theorem probingHashQueryAfterRootAwarePublicPlan_preloadedWeightedCharge_le_originalCharge + (parameter : PublicParameter) (input : HashInput) (publicState : LazyRevealProbe.State Coordinate) + (plan : PlannedHashQuery) (cache : SplitHashCache) (context : DeferredContext) (fuel : Nat) + (target : Position) (output : HashOutput) : + ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) + { context with state := preloadPositionValue target output context.state } fuel + + (materializedCandidateCharge (preloadPositionValue target output context.state) + (rootAwareCandidateForPlan? parameter input plan) : ℝ≥0∞) * (4 / 3) ≤ + ((unmaterializedCandidateCharge context.state (rootAwareCandidateForPlan? parameter input plan) + + materializedCandidateCharge context.state (rootAwareCandidateForPlan? parameter input plan) : Nat) : ℝ≥0∞) * + (4 / 3) := by + have hfactor : (1 : ℝ≥0∞) ≤ 4 / 3 := by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + norm_num + calc + _ ≤ (ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) + { context with state := preloadPositionValue target output context.state } fuel + + (materializedCandidateCharge (preloadPositionValue target output context.state) + (rootAwareCandidateForPlan? parameter input plan) : ℝ≥0∞)) * (4 / 3) := by + rw [add_mul] + exact add_le_add (by simpa only [mul_one] using mul_le_mul' le_rfl hfactor) le_rfl + _ ≤ _ := mul_le_mul' (probingHashQueryAfterRootAwarePublicPlan_preloadedCharge_le_originalCharge + parameter input publicState plan cache context fuel target output) le_rfl + +theorem canonicalPreloadedQuery_weightedCharge_le_originalCharge + (parameter : PublicParameter) (input : HashInput) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) (context : DeferredContext) (fuel : Nat) + (target : Position) (output : HashOutput) + (hhidden : Coordinate.position target ∉ context.state.revealed) : + let preloaded := preloadPositionValue target output context.state + let publicState := (materializedCanonicalContext table preloaded).state + let plan := purePlanProbingHashQuery parameter input publicState + let originalPlan := purePlanProbingHashQuery parameter input (materializedCanonicalContext table context.state).state + ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) + { context with state := preloaded } fuel + + (materializedCandidateCharge preloaded (rootAwareCandidateForPlan? parameter input plan) : ℝ≥0∞) * (4 / 3) ≤ + ((unmaterializedCandidateCharge context.state (rootAwareCandidateForPlan? parameter input originalPlan) + + materializedCandidateCharge context.state (rootAwareCandidateForPlan? parameter input originalPlan) : Nat) : ℝ≥0∞) * + (4 / 3) := by + dsimp only + have hplan := purePlanProbingHashQuery_eq_of_values_eq + (materializedCanonicalContext_values_preload_hidden table context.state target output hhidden) parameter input + rw [hplan] + exact probingHashQueryAfterRootAwarePublicPlan_preloadedWeightedCharge_le_originalCharge parameter input + (materializedCanonicalContext table (preloadPositionValue target output context.state)).state + (purePlanProbingHashQuery parameter input (materializedCanonicalContext table context.state).state) + cache context fuel target output + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateAllowanceCounting.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateAllowanceCounting.lean new file mode 100644 index 00000000..1af1da9c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateAllowanceCounting.lean @@ -0,0 +1,128 @@ +import SphincsSecurity.Proof.OtsProbeNativeCandidateRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def privateProbeInputAllowance (target : Position) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) : LazyRevealProbe.Query Coordinate → ENNReal + | .probe coordinate digest => if coordinate = .position target then + candidateFailureAllowance table context (some ⟨coordinate, digest⟩) else 0 + | _ => 0 + +theorem privateProbeInputAllowance_of_not_probe + (target : Position) (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (input : LazyRevealProbe.Query Coordinate) (hprobe : ¬IsPrivatePositionProbe target input) : + privateProbeInputAllowance target table context input = 0 := by + cases input <;> simp_all [privateProbeInputAllowance, IsPrivatePositionProbe] + +noncomputable def privateLiveProbeAllowance + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → ENNReal := + OracleComp.construct (fun _ _ _ _ => 0) + (fun input _ next context fuel table => + if DeferredCompletable table context then + if IsPrivatePositionDisclosure target input then 0 + else privateProbeInputAllowance target table context input + + ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => next result.value result.context result.remaining result.table + else 0) computation + +noncomputable def privateLiveProbeOrdinalAllowance + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + Nat → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → ENNReal := + OracleComp.construct (fun _ _ _ _ _ => 0) + (fun input _ next ordinal context fuel table => + if DeferredCompletable table context then + if IsPrivatePositionDisclosure target input then 0 + else if IsPrivatePositionProbe target input ∧ ordinal = 0 then privateProbeInputAllowance target table context input + else ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => next result.value (if IsPrivatePositionProbe target input then ordinal - 1 else ordinal) + result.context result.remaining result.table + else 0) computation + +theorem privateLiveProbeAllowance_query_bind + (target : Position) (input : LazyRevealProbe.Query Coordinate) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + privateLiveProbeAllowance target ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= next) context fuel table = + (if DeferredCompletable table context then + if IsPrivatePositionDisclosure target input then 0 + else privateProbeInputAllowance target table context input + + ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => privateLiveProbeAllowance target (next result.value) result.context result.remaining result.table + else 0) := rfl + +theorem privateLiveProbeOrdinalAllowance_query_bind + (target : Position) (input : LazyRevealProbe.Query Coordinate) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + privateLiveProbeOrdinalAllowance target ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= next) ordinal context fuel table = + (if DeferredCompletable table context then + if IsPrivatePositionDisclosure target input then 0 + else if IsPrivatePositionProbe target input ∧ ordinal = 0 then privateProbeInputAllowance target table context input + else ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => privateLiveProbeOrdinalAllowance target (next result.value) + (if IsPrivatePositionProbe target input then ordinal - 1 else ordinal) result.context result.remaining result.table + else 0) := rfl + +theorem sum_privateLiveProbeOrdinalAllowance_eq + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hbound : computation.IsQueryBoundP (IsPrivatePositionProbe target) q) : + (∑ ordinal ∈ Finset.range q, privateLiveProbeOrdinalAllowance target computation ordinal context fuel table) = + privateLiveProbeAllowance target computation context fuel table := by + induction computation using OracleComp.inductionOn generalizing q context fuel table with + | pure value => simp [privateLiveProbeOrdinalAllowance, privateLiveProbeAllowance] + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [privateLiveProbeAllowance_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete] + by_cases hdisclose : IsPrivatePositionDisclosure target input + · simp [privateLiveProbeOrdinalAllowance_query_bind, hcomplete, hdisclose] + · rw [if_neg hdisclose] + have htail (n : Nat) (hnext : ∀ reply, (next reply).IsQueryBoundP (IsPrivatePositionProbe target) n) : + (∑ ordinal ∈ Finset.range n, ∑' result, + Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => privateLiveProbeOrdinalAllowance target (next result.value) ordinal result.context result.remaining result.table) = + ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => privateLiveProbeAllowance target (next result.value) result.context result.remaining result.table := by + rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + apply tsum_congr + intro result + cases result with + | none => simp + | some result => + simp only [← Finset.mul_sum] + rw [ih result.value n result.context result.remaining result.table (hnext result.value)] + by_cases hprobe : IsPrivatePositionProbe target input + · cases q with + | zero => simp [hprobe] at hbound + | succ q => + rw [Finset.sum_range_succ'] + simp only [privateLiveProbeOrdinalAllowance_query_bind, if_pos hcomplete, if_neg hdisclose, + hprobe, Nat.add_eq_zero_iff, Nat.one_ne_zero, and_false, if_false, Nat.add_sub_cancel, and_self, if_true] + exact (congrArg (fun value => value + privateProbeInputAllowance target table context input) + (htail q (fun reply => by simpa only [if_pos hprobe, Nat.add_sub_cancel] using hbound.2 reply))).trans (add_comm _ _) + · simp only [privateLiveProbeOrdinalAllowance_query_bind, if_pos hcomplete, if_neg hdisclose, + hprobe, false_and, if_false, privateProbeInputAllowance_of_not_probe target table context input hprobe, zero_add] + exact htail q (fun reply => by simpa only [if_neg hprobe] using hbound.2 reply) + · simp [privateLiveProbeOrdinalAllowance_query_bind, hcomplete] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateAllowanceCut.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateAllowanceCut.lean new file mode 100644 index 00000000..1ac5454f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateAllowanceCut.lean @@ -0,0 +1,95 @@ +import SphincsSecurity.Proof.OtsProbePrivateAllowanceCounting + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def privateProbeCutAllowance (target : Position) : Option (ResolvedRunResult (PrivateValueCut α)) → ENNReal + | none => 0 + | some result => if DeferredCompletable result.table result.context then + candidateFailureAllowance result.table result.context + ((privateRawCutCandidate target result.remaining result.value).map (fun digest => ⟨.position target, digest⟩)) else 0 + +theorem expected_privateProbeCutAllowance_eq_zero_of_not_completable + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) (PrivateValueCut α)) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) : + (∑' result, Pr[= result | runResolvedFromTable context fuel table computation] * privateProbeCutAllowance target result) = 0 := by + apply ENNReal.tsum_eq_zero.mpr + intro option + by_cases hoption : option ∈ support (runResolvedFromTable context fuel table computation) + · cases option with + | none => simp [privateProbeCutAllowance] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable computation context fuel table result hconsistent hstarts hoption + have hstop := not_deferredCompletable_of_mem_runResolvedFromTable computation context fuel table result hconsistent hstarts hoption hdoomed + simp [privateProbeCutAllowance, hcore.1, hstop] + · simp [probOutput_eq_zero_of_not_mem_support hoption] + +theorem expected_privateProbeCutAllowance_eq_ordinalAllowance + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + (∑' result, Pr[= result | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)] * privateProbeCutAllowance target result) = + privateLiveProbeOrdinalAllowance target computation ordinal context fuel table := by + induction computation using OracleComp.inductionOn generalizing ordinal context fuel table with + | pure value => + by_cases hcomplete : DeferredCompletable table context <;> + simp [privatePositionProbeCutAt, runResolvedFromTable, privateLiveProbeOrdinalAllowance, + privateProbeCutAllowance, hcomplete, privateRawCutCandidate, privatePositionAccessCandidate, candidateFailureAllowance, privateProbeInputAllowance] + | query_bind input next ih => + by_cases hcomplete : DeferredCompletable table context + · rw [privatePositionProbeCutAt_query_bind, privateLiveProbeOrdinalAllowance_query_bind, if_pos hcomplete] + by_cases hdisclose : IsPrivatePositionDisclosure target input + · rw [if_pos hdisclose, if_pos hdisclose] + cases input <;> simp [IsPrivatePositionDisclosure] at hdisclose <;> + simp [runResolvedFromTable, privateProbeCutAllowance, hcomplete, + privateRawCutCandidate, privatePositionAccessCandidate, candidateFailureAllowance] + · rw [if_neg hdisclose, if_neg hdisclose] + have htail (n : Nat) : + (∑' result, Pr[= result | runResolvedFromTable context fuel table + ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= + fun reply => privatePositionProbeCutAt target (next reply) n)] * privateProbeCutAllowance target result) = + ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => privateLiveProbeOrdinalAllowance target (next result.value) n result.context result.remaining result.table := by + rw [runResolvedFromTable_bind, tsum_probOutput_bind_mul] + apply tsum_congr + intro result + by_cases hresult : result ∈ support (runResolvedFromTable context fuel table (liftM (OracleSpec.query input))) + · cases result with + | none => simp [privateProbeCutAllowance, privateRawCutCandidate, privatePositionAccessCandidate, candidateFailureAllowance] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable (liftM (OracleSpec.query input)) context fuel table result hconsistent hstarts hresult + dsimp only + rw [ih result.value n result.context result.remaining result.table hcore.2.1 (hcore.1 ▸ hcore.2.2)] + · simp [probOutput_eq_zero_of_not_mem_support hresult] + by_cases hprobe : IsPrivatePositionProbe target input + · rw [if_pos hprobe] + cases ordinal with + | zero => + simp only [hprobe, and_self, if_true] + cases input <;> simp [IsPrivatePositionProbe] at hprobe + subst_vars + simp [runResolvedFromTable, privateProbeCutAllowance, hcomplete, + privateRawCutCandidate, privatePositionAccessCandidate, candidateFailureAllowance, privateProbeInputAllowance] + | succ ordinal => + simp only [hprobe, Nat.add_eq_zero_iff, Nat.one_ne_zero, and_false, if_false, if_true, Nat.add_sub_cancel] + rw [htail ordinal] + apply tsum_congr + intro result + cases result <;> rfl + · simp only [hprobe, false_and, if_false] + rw [htail ordinal] + apply tsum_congr + intro result + cases result <;> rfl + · rw [expected_privateProbeCutAllowance_eq_zero_of_not_completable target (privatePositionProbeCutAt target _ ordinal) context fuel table hconsistent hstarts hcomplete, + privateLiveProbeOrdinalAllowance_query_bind, if_neg hcomplete] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateAllowanceHit.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateAllowanceHit.lean new file mode 100644 index 00000000..4fa735eb --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateAllowanceHit.lean @@ -0,0 +1,100 @@ +import SphincsSecurity.Proof.OtsProbePrivateAllowanceCut + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem hidden_of_mem_runResolved_no_disclosure + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hsafe : computation.IsQueryBoundP (IsPrivatePositionDisclosure target) 0) + (hhidden : .position target ∉ context.state.revealed) + (hresult : some result ∈ support (runResolvedFromTable context fuel table computation)) : + .position target ∉ result.context.state.revealed := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp only [runResolvedFromTable, OracleComp.construct_pure, mem_support_pure_iff, Option.some.injEq] at hresult + subst result + exact hhidden + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hsafe + have hquery : ¬IsPrivatePositionDisclosure target input := by simpa using hsafe.1 + have hnext : ∀ reply, (next reply).IsQueryBoundP (IsPrivatePositionDisclosure target) 0 := by + intro reply + simpa using hsafe.2 reply + cases input with + | uniform n => + rw [runResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨reply, _, htail⟩ := hresult + exact ih reply context fuel (hnext reply) hhidden htail + | hashOutput => + rw [runResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨reply, _, htail⟩ := hresult + exact ih reply context fuel (hnext reply) hhidden htail + | ensure coordinate => + rw [runResolvedFromTable_ensure_query_bind] at hresult + exact ih () _ fuel (hnext ()) (by exact hhidden) hresult + | peek coordinate => + rw [runResolvedFromTable_peek_query_bind] at hresult + exact ih _ context fuel (hnext _) hhidden hresult + | publish coordinate => + rw [runResolvedFromTable_publish_query_bind] at hresult + apply ih () _ fuel (hnext ()) _ hresult + simpa [LazyRevealProbe.State.publish, IsPrivatePositionDisclosure, ne_comm] using And.intro hquery hhidden + | probe coordinate digest => + rw [runResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + dsimp only at hresult + split_ifs at hresult + · exact ih () context remaining (hnext ()) hhidden hresult + · exact ih () _ remaining (hnext ()) (by exact hhidden) hresult + | reveal coordinate => + rw [runResolvedFromTable_reveal_query_bind] at hresult + cases coordinate <;> rw [mem_support_bind_iff] at hresult + all_goals + obtain ⟨resolved, _, htail⟩ := hresult + cases resolved with + | none => simp at htail + | some resolved => exact ih resolved.output _ fuel (hnext resolved.output) (by exact hhidden) htail + +theorem probEvent_privateProbeCut_hit_eq_ordinalAllowance + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hhidden : .position target ∉ context.state.revealed) : + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target computation ordinal)] = + privateLiveProbeOrdinalAllowance target computation ordinal context fuel table := by + rw [probEvent_privateResolvedView_selected_eq_expectedAllowance target table context fuel _ _ hconsistent hstarts + (fun result hresult _ => hidden_of_mem_runResolved_no_disclosure target _ context fuel table result + (privatePositionProbeCutAt_no_disclosure target computation ordinal) hhidden hresult)] + apply Eq.trans _ (expected_privateProbeCutAllowance_eq_ordinalAllowance target computation ordinal context fuel table hconsistent hstarts) + apply tsum_congr + intro option + by_cases hoption : option ∈ support (runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)) + · cases option with + | none => simp [privateProbeCutAllowance] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table result hconsistent hstarts hoption + simp [privateProbeCutAllowance, hcore.1] + · simp [probOutput_eq_zero_of_not_mem_support hoption] + +theorem sum_privateProbeCut_hits_eq_liveAllowance + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hhidden : .position target ∉ context.state.revealed) + (hbound : computation.IsQueryBoundP (IsPrivatePositionProbe target) q) : + (∑ ordinal ∈ Finset.range q, + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target computation ordinal)]) = + privateLiveProbeAllowance target computation context fuel table := by + simp_rw [probEvent_privateProbeCut_hit_eq_ordinalAllowance target computation _ context fuel table hconsistent hstarts hhidden] + exact sum_privateLiveProbeOrdinalAllowance_eq target computation q context fuel table hbound + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateAllowanceReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateAllowanceReserve.lean new file mode 100644 index 00000000..ffc021c7 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateAllowanceReserve.lean @@ -0,0 +1,67 @@ +import SphincsSecurity.Proof.OtsProbePrivateAllowanceHit +import SphincsSecurity.Proof.OtsProbeInitializedJointRootRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem sum_targets_privateHits_eq_liveAllowance + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hhidden : ∀ target ∈ targets, .position target ∉ context.state.revealed) + (hbound : ∀ target ∈ targets, computation.IsQueryBoundP (IsPrivatePositionProbe target) q) : + (∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target computation ordinal)]) = + ∑ target ∈ targets, privateLiveProbeAllowance target computation context fuel table := by + apply Finset.sum_congr rfl + intro target htarget + exact sum_privateProbeCut_hits_eq_liveAllowance target computation q context fuel table + hconsistent hstarts (hhidden target htarget) (hbound target htarget) + +theorem sum_targets_privateHits_ensuredInitial_eq_liveAllowance + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hbound : ∀ target ∈ targets, computation.IsQueryBoundP (IsPrivatePositionProbe target) q) : + (∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table (ensuredInitialContext targets) fuel (privatePositionProbeCutAt target computation ordinal)]) = + ∑ target ∈ targets, privateLiveProbeAllowance target computation (ensuredInitialContext targets) fuel table := by + apply sum_targets_privateHits_eq_liveAllowance targets computation q (ensuredInitialContext targets) fuel table + (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table)) _ hbound + intro target _ + simp [ensuredInitialContext, LazyRevealProbe.State.empty] + +theorem sum_privateLiveProbeAllowance_ensuredInitial_le_structuralCharge + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q fuel : Nat) (table : OtsSecretIndex → HashOutput) (hq : q ≤ 2 ^ 126) + (hbound : ∀ target ∈ targets, computation.IsQueryBoundP (IsPrivatePositionProbe target) q) : + (∑ target ∈ targets, privateLiveProbeAllowance target computation (ensuredInitialContext targets) fuel table) ≤ + expectedLiveResolvedQueryCharge structuralProbeQueryCharge computation (ensuredInitialContext targets) fuel table * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + rw [← sum_targets_privateHits_ensuredInitial_eq_liveAllowance targets computation q fuel table hbound] + exact sum_targets_privateHits_ensuredInitial_le_structuralCharge targets computation q fuel table hq + +theorem initializedNativeDirectRisk_eq_startHits_add_privateAllowance + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) + (hbound : ∀ target ∈ targets, (nativeChronologicalRetainedComputation adversary parameter ftsSecret).IsQueryBoundP + (IsPrivatePositionProbe target) q) : + initializedNativeDirectRisk targets adversary parameter ftsSecret fuel q = + (∑ ordinal ∈ Finset.range q, Pr[LiveUnresolvedStartHit nativeCutCandidate | + sampledEnsuredNativeProbeCut targets (nativeChronologicalRetainedComputation adversary parameter ftsSecret) fuel ordinal]) + + ∑' table, Pr[= table | sampleOtsHashTable] * + ∑ target ∈ targets, privateLiveProbeAllowance target + (nativeChronologicalRetainedComputation adversary parameter ftsSecret) (ensuredInitialContext targets) fuel table := by + unfold initializedNativeDirectRisk + congr 1 + apply tsum_congr + intro table + rw [sum_targets_privateHits_ensuredInitial_eq_liveAllowance targets _ q fuel table hbound] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateHistoryRate.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateHistoryRate.lean new file mode 100644 index 00000000..2a677b8d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateHistoryRate.lean @@ -0,0 +1,173 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueHistoryRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def privateHistoryGuessRate (excluded : Nat) : ENNReal := + ((Fintype.card Digest - excluded : Nat) : ENNReal)⁻¹ + +theorem privateHistoryGuessRate_mono {a b : Nat} (hle : a ≤ b) : + privateHistoryGuessRate a ≤ privateHistoryGuessRate b := by + apply ENNReal.inv_le_inv.mpr + exact Nat.cast_le.mpr (Nat.sub_le_sub_left hle _) + +theorem privateHistoryGuessRate_ne_top {excluded : Nat} (hsmall : excluded < Fintype.card Digest) : + privateHistoryGuessRate excluded ≠ ⊤ := by + apply ENNReal.inv_ne_top.mpr + exact_mod_cast Nat.sub_ne_zero_of_lt hsmall + +theorem privateHistoryGuessRate_le_four_thirds {excluded : Nat} (hsmall : excluded ≤ 2 ^ 126) : + privateHistoryGuessRate excluded ≤ (4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply (privateHistoryGuessRate_mono hsmall).trans_eq + apply (ENNReal.toReal_eq_toReal_iff' + (privateHistoryGuessRate_ne_top (by norm_num [digestBits])) (by finiteness)).mp + norm_num [privateHistoryGuessRate, digestBits, ENNReal.toReal_inv, ENNReal.toReal_mul, ENNReal.toReal_div] + +theorem privateHistoryGuessRate_le_two {excluded : Nat} (hsmall : excluded ≤ 2 ^ 127) : + privateHistoryGuessRate excluded ≤ (2 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply (privateHistoryGuessRate_mono hsmall).trans_eq + apply (ENNReal.toReal_eq_toReal_iff' + (privateHistoryGuessRate_ne_top (by norm_num [digestBits])) (by finiteness)).mp + norm_num [privateHistoryGuessRate, digestBits, ENNReal.toReal_inv, ENNReal.toReal_mul, ENNReal.toReal_div] + +theorem probEvent_uniform_avoids_private_history_eq (history : Finset Digest) : + Pr[fun output => truncateHash output ∉ history | LazyRevealProbe.sampleHashOutput] = + ((Fintype.card Digest - history.card : Nat) : ENNReal) * (Fintype.card Digest : ENNReal)⁻¹ := by + simpa only [LazyRevealProbe.sampleHashOutput, Finset.mem_compl, Finset.card_compl, div_eq_mul_inv] using + SphincsSecurity.probEvent_uniform_truncateHash_mem historyᶜ + +theorem privateValue_history_row_hit_le_historyRate + (history : Finset Digest) (weight : ENNReal) (likelihood : HashOutput → ENNReal) (candidate : Digest) + (hrow : ∀ output, likelihood output = if truncateHash output ∉ history then weight else 0) + (hcard : history.card < Fintype.card Digest) : + (∑' output, if truncateHash output = candidate then + Pr[= output | LazyRevealProbe.sampleHashOutput] * likelihood output else 0) ≤ + (∑' output, Pr[= output | LazyRevealProbe.sampleHashOutput] * likelihood output) * + privateHistoryGuessRate history.card := by + have hhit : (∑' output, if truncateHash output = candidate then + Pr[= output | LazyRevealProbe.sampleHashOutput] * likelihood output else 0) ≤ + (Fintype.card Digest : ENNReal)⁻¹ * weight := by + calc + _ ≤ ∑' output, if truncateHash output = candidate then + Pr[= output | LazyRevealProbe.sampleHashOutput] * weight else 0 := by + apply ENNReal.tsum_le_tsum + intro output + have hle : likelihood output ≤ weight := by rw [hrow]; split_ifs <;> simp + split_ifs + · exact mul_le_mul' le_rfl hle + · rfl + _ = Pr[fun output => truncateHash output = candidate | LazyRevealProbe.sampleHashOutput] * weight := by + rw [probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_right] + apply tsum_congr + intro output + split_ifs <;> simp + _ = _ := by + rw [show Pr[fun output => truncateHash output = candidate | LazyRevealProbe.sampleHashOutput] = + (Fintype.card Digest : ENNReal)⁻¹ by + simpa only [LazyRevealProbe.sampleHashOutput] using + SphincsSecurity.probEvent_uniform_truncateHash_eq candidate] + rw [privateValue_compatible_row_mass (fun output => truncateHash output ∉ history) weight likelihood + (fun output => by + by_cases hclean : truncateHash output ∉ history <;> + simpa only [if_pos hclean, if_neg hclean] using hrow output), + probEvent_uniform_avoids_private_history_eq] + apply hhit.trans_eq + have hnonzero : ((Fintype.card Digest - history.card : Nat) : ENNReal) ≠ 0 := by + exact_mod_cast Nat.sub_ne_zero_of_lt hcard + have hcancel := ENNReal.mul_inv_cancel hnonzero (by simp) + unfold privateHistoryGuessRate + calc + _ = (((Fintype.card Digest - history.card : Nat) : ENNReal) * + ((Fintype.card Digest - history.card : Nat) : ENNReal)⁻¹) * + ((Fintype.card Digest : ENNReal)⁻¹ * weight) := by rw [hcancel, one_mul] + _ = _ := by ring + +theorem privateValue_history_row_hit_le_historyRate_of_compatible + (history : Finset Digest) (likelihood : HashOutput → ENNReal) (candidate : Digest) + (hcompatible : ∀ before after, truncateHash before ∉ history → truncateHash after ∉ history → + likelihood before = likelihood after) + (hreject : ∀ output, truncateHash output ∈ history → likelihood output = 0) + (hcard : history.card < Fintype.card Digest) : + (∑' output, if truncateHash output = candidate then + Pr[= output | LazyRevealProbe.sampleHashOutput] * likelihood output else 0) ≤ + (∑' output, Pr[= output | LazyRevealProbe.sampleHashOutput] * likelihood output) * + privateHistoryGuessRate history.card := by + obtain ⟨digest, hmiss⟩ : ∃ digest : Digest, digest ∉ history := by + by_contra hnone + push Not at hnone + have huniv := Finset.eq_univ_iff_forall.mpr hnone + simp only [huniv, Finset.card_univ, lt_self_iff_false] at hcard + let reference := hashOutputOfDigest digest + apply privateValue_history_row_hit_le_historyRate history (likelihood reference) likelihood candidate _ hcard + intro output + by_cases hclean : truncateHash output ∉ history + · rw [if_pos hclean] + exact hcompatible output reference hclean (by simpa only [reference, truncateHash_hashOutputOfDigest] using hmiss) + · rw [if_neg hclean] + exact hreject output (not_not.mp hclean) + +noncomputable def privateHistoryWeightedOccurrence + (run : HashOutput → ProbComp (Option α)) (candidate : α → Option Digest) + (history : α → Finset Digest) : ENNReal := + ∑' record : α, if candidate record ≠ none then + (∑' output, Pr[= output | LazyRevealProbe.sampleHashOutput] * Pr[= some record | run output]) * + privateHistoryGuessRate (history record).card else 0 + +theorem probEvent_samplePrivateHistoryGuess_hit_le_weighted + (run : HashOutput → ProbComp (Option α)) (candidate : α → Option Digest) (history : α → Finset Digest) + (hcompatible : ∀ before after record, truncateHash before ∉ history record → truncateHash after ∉ history record → + Pr[= some record | run before] = Pr[= some record | run after]) + (hreject : ∀ output record, truncateHash output ∈ history record → Pr[= some record | run output] = 0) + (hcard : ∀ output record, some record ∈ support (run output) → (history record).card < Fintype.card Digest) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | samplePrivateHistoryGuess run candidate] ≤ + privateHistoryWeightedOccurrence run candidate history := by + rw [probEvent_samplePrivateHistoryGuess_eq_rows, tsum_option (hf := ENNReal.summable)] + simp only [Option.bind_none, reduceCtorEq, if_false, tsum_zero, zero_add] + unfold privateHistoryWeightedOccurrence + apply ENNReal.tsum_le_tsum + intro record + cases hcandidate : candidate record with + | none => simp [hcandidate] + | some digest => + simp only [Option.bind_some, hcandidate] + by_cases hsmall : (history record).card < Fintype.card Digest + · simpa only [Option.some.injEq, eq_comm, ne_eq, reduceCtorEq, not_false_eq_true, if_true] using + privateValue_history_row_hit_le_historyRate_of_compatible (history record) + (fun output => Pr[= some record | run output]) digest + (fun before after => hcompatible before after record) (fun output => hreject output record) hsmall + · have hzero : ∀ output, Pr[= some record | run output] = 0 := by + intro output + apply probOutput_eq_zero_of_not_mem_support + intro hsupport + exact hsmall (hcard output record hsupport) + simp [hzero] + +theorem privateHistoryWeightedOccurrence_le_budget + (run : HashOutput → ProbComp (Option α)) (candidate : α → Option Digest) (history : α → Finset Digest) + (budget : Nat) + (hcard : ∀ output record, some record ∈ support (run output) → (history record).card ≤ budget) : + privateHistoryWeightedOccurrence run candidate history ≤ + Pr[fun pair => pair.2 ≠ none | samplePrivateHistoryGuess run candidate] * privateHistoryGuessRate budget := by + rw [probEvent_samplePrivateHistoryGuess_eq_rows, tsum_option (hf := ENNReal.summable)] + simp only [Option.bind_none, ne_eq, not_true_eq_false, if_false, tsum_zero, zero_add] + rw [← ENNReal.tsum_mul_right] + unfold privateHistoryWeightedOccurrence + apply ENNReal.tsum_le_tsum + intro record + by_cases hcandidate : candidate record = none + · simp [hcandidate] + · simp only [Option.bind_some, hcandidate, not_false_eq_true, if_true, if_pos hcandidate] + by_cases hsmall : (history record).card ≤ budget + · exact mul_le_mul' le_rfl (privateHistoryGuessRate_mono hsmall) + · have hzero : ∀ output, Pr[= some record | run output] = 0 := by + intro output + apply probOutput_eq_zero_of_not_mem_support + intro hsupport + exact hsmall (hcard output record hsupport) + simp [hzero] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateInactive.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateInactive.lean new file mode 100644 index 00000000..59d31064 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateInactive.lean @@ -0,0 +1,99 @@ +import SphincsSecurity.Proof.OtsProbeNativeChainBound + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem known_coordinate_of_mem_runResolvedFromTable + (target : Coordinate) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : ResolvedRunResult α) + (hresult : some result ∈ support (runResolvedFromTable context fuel table computation)) + (hknown : context.state.values target ≠ none) : result.context.state.values target ≠ none := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runResolvedFromTable] at hresult + subst result + exact hknown + | query_bind input next ih => + cases input with + | uniform n => + rw [runResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel htail hknown + | hashOutput => + rw [runResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel htail hknown + | ensure coordinate => + rw [runResolvedFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel hresult hknown + | probe coordinate digest => + cases fuel with + | zero => simp [runResolvedFromTable_probe_query_bind] at hresult + | succ remaining => + rw [runResolvedFromTable_probe_query_bind] at hresult + by_cases hrevealed : coordinate ∈ context.state.revealed + · exact ih () context remaining (by simpa only [hrevealed, ↓reduceIte] using hresult) hknown + · exact ih () { context with state := context.state.addPending coordinate digest } remaining + (by simpa only [hrevealed, ↓reduceIte] using hresult) hknown + | peek coordinate => + rw [runResolvedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hresult hknown + | publish coordinate => + rw [runResolvedFromTable_publish_query_bind] at hresult + exact ih () { context with state := context.state.publish coordinate } fuel hresult hknown + | reveal coordinate => + rw [runResolvedFromTable_reveal_query_bind] at hresult + cases coordinate <;> rw [mem_support_bind_iff] at hresult + all_goals + obtain ⟨option, _hresolve, htail⟩ := hresult + cases option with + | none => simp at htail + | some resolved => + apply ih resolved.output _ fuel htail + simp only [LazyRevealProbe.State.materialize, Function.update_apply] + split_ifs <;> simp_all + +def PrivateTargetInactive (target : Position) (context : DeferredContext) : Prop := + context.state.values (.position target) ≠ none ∨ .position target ∈ context.state.revealed + +theorem PrivateTargetInactive.of_mem_runResolved + {target : Position} {context : DeferredContext} (hinactive : PrivateTargetInactive target context) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : ResolvedRunResult α) + (hresult : some result ∈ support (runResolvedFromTable context fuel table computation)) : + PrivateTargetInactive target result.context := by + rcases hinactive with hknown | hpublic + · exact Or.inl (known_coordinate_of_mem_runResolvedFromTable _ computation context fuel table result hresult hknown) + · exact Or.inr ((revealed_subset_of_mem_runResolvedFromTable computation context fuel table result hresult) hpublic) + +theorem privateTargetInactive_of_disclosure + (target : Position) (input : LazyRevealProbe.Query Coordinate) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hdisclose : IsPrivatePositionDisclosure target input) + (hresult : some result ∈ support (runResolvedFromTable context fuel table + ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= next))) : + PrivateTargetInactive target result.context := by + cases input <;> simp only [IsPrivatePositionDisclosure] at hdisclose + case publish coordinate => + subst coordinate + rw [runResolvedFromTable_publish_query_bind] at hresult + apply PrivateTargetInactive.of_mem_runResolved (context := { context with state := context.state.publish (.position target) }) + (Or.inr (by simp [LazyRevealProbe.State.publish])) _ fuel table result hresult + case reveal coordinate => + subst coordinate + rw [runResolvedFromTable_reveal_query_bind, mem_support_bind_iff] at hresult + obtain ⟨resolved, _, htail⟩ := hresult + cases resolved with + | none => simp at htail + | some resolved => + apply PrivateTargetInactive.of_mem_runResolved (context := + { state := context.state.materialize (.position target) resolved.output, values := resolved.values }) + (Or.inl (by simp [LazyRevealProbe.State.materialize])) _ fuel table result htail + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateMissingAllowance.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateMissingAllowance.lean new file mode 100644 index 00000000..cb025c7a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateMissingAllowance.lean @@ -0,0 +1,131 @@ +import SphincsSecurity.Proof.OtsProbePrivateInactive + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def privateMissingProbeInputAllowance (target : Position) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (input : LazyRevealProbe.Query Coordinate) : ENNReal := + if context.state.values (.position target) = none then privateProbeInputAllowance target table context input else 0 + +theorem privateMissingProbeInputAllowance_le (target : Position) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (input : LazyRevealProbe.Query Coordinate) : + privateMissingProbeInputAllowance target table context input ≤ privateProbeInputAllowance target table context input := by + unfold privateMissingProbeInputAllowance + split_ifs <;> simp + +theorem privateMissingProbeInputAllowance_eq_zero_of_inactive + (target : Position) (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (input : LazyRevealProbe.Query Coordinate) (hinactive : PrivateTargetInactive target context) : + privateMissingProbeInputAllowance target table context input = 0 := by + rcases hinactive with hknown | hpublic + · simp [privateMissingProbeInputAllowance, hknown] + · cases input <;> simp only [privateMissingProbeInputAllowance, privateProbeInputAllowance] + all_goals try simp + case probe coordinate digest => + by_cases heq : coordinate = .position target + · subst coordinate + simp [candidateFailureAllowance, hpublic] + · simp [heq] + +noncomputable def privateLiveMissingProbeAllowance + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → ENNReal := + OracleComp.construct (fun _ _ _ _ => 0) + (fun input _ next context fuel table => + if DeferredCompletable table context then + privateMissingProbeInputAllowance target table context input + + ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => next result.value result.context result.remaining result.table + else 0) computation + +theorem privateLiveMissingProbeAllowance_query_bind + (target : Position) (input : LazyRevealProbe.Query Coordinate) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + privateLiveMissingProbeAllowance target ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= next) context fuel table = + (if DeferredCompletable table context then + privateMissingProbeInputAllowance target table context input + + ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => privateLiveMissingProbeAllowance target (next result.value) result.context result.remaining result.table + else 0) := rfl + +theorem privateLiveMissingProbeAllowance_eq_zero_of_inactive + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hinactive : PrivateTargetInactive target context) : + privateLiveMissingProbeAllowance target computation context fuel table = 0 := by + induction computation using OracleComp.inductionOn generalizing context fuel table with + | pure value => rfl + | query_bind input next ih => + rw [privateLiveMissingProbeAllowance_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete, privateMissingProbeInputAllowance_eq_zero_of_inactive target table context input hinactive, zero_add] + apply ENNReal.tsum_eq_zero.mpr + intro option + by_cases hoption : option ∈ support (runResolvedFromTable context fuel table (liftM (OracleSpec.query input))) + · cases option with + | none => simp + | some result => + dsimp only + rw [ih result.value result.context result.remaining result.table (hinactive.of_mem_runResolved _ fuel table result hoption), mul_zero] + · simp [probOutput_eq_zero_of_not_mem_support hoption] + · rw [if_neg hcomplete] + +theorem privateLiveMissingProbeAllowance_le_stoppedAllowance + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + privateLiveMissingProbeAllowance target computation context fuel table ≤ privateLiveProbeAllowance target computation context fuel table := by + induction computation using OracleComp.inductionOn generalizing context fuel table with + | pure value => exact le_rfl + | query_bind input next ih => + rw [privateLiveMissingProbeAllowance_query_bind, privateLiveProbeAllowance_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete, if_pos hcomplete] + by_cases hdisclose : IsPrivatePositionDisclosure target input + · rw [if_pos hdisclose] + have hnotProbe : ¬IsPrivatePositionProbe target input := by + cases input <;> simp_all [IsPrivatePositionDisclosure, IsPrivatePositionProbe] + rw [show privateMissingProbeInputAllowance target table context input = 0 by + simp [privateMissingProbeInputAllowance, privateProbeInputAllowance_of_not_probe target table context input hnotProbe], zero_add] + apply le_of_eq + apply ENNReal.tsum_eq_zero.mpr + intro option + by_cases hoption : option ∈ support (runResolvedFromTable context fuel table (liftM (OracleSpec.query input))) + · cases option with + | none => simp + | some result => + have hinactive := privateTargetInactive_of_disclosure target input pure context fuel table result hdisclose + (by simpa only [bind_pure] using hoption) + dsimp only + rw [privateLiveMissingProbeAllowance_eq_zero_of_inactive target _ result.context result.remaining result.table hinactive, mul_zero] + · simp [probOutput_eq_zero_of_not_mem_support hoption] + · rw [if_neg hdisclose] + apply add_le_add (privateMissingProbeInputAllowance_le target table context input) + apply ENNReal.tsum_le_tsum + intro option + apply mul_le_mul' le_rfl + cases option with + | none => exact le_rfl + | some result => exact ih result.value result.context result.remaining result.table + · rw [if_neg hcomplete, if_neg hcomplete] + +theorem sum_privateLiveMissingProbeAllowance_ensuredInitial_le_structuralCharge + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q fuel : Nat) (table : OtsSecretIndex → HashOutput) (hq : q ≤ 2 ^ 126) + (hbound : ∀ target ∈ targets, computation.IsQueryBoundP (IsPrivatePositionProbe target) q) : + (∑ target ∈ targets, privateLiveMissingProbeAllowance target computation (ensuredInitialContext targets) fuel table) ≤ + expectedLiveResolvedQueryCharge structuralProbeQueryCharge computation (ensuredInitialContext targets) fuel table * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply (Finset.sum_le_sum fun target _ => privateLiveMissingProbeAllowance_le_stoppedAllowance + target computation (ensuredInitialContext targets) fuel table).trans + (sum_privateLiveProbeAllowance_ensuredInitial_le_structuralCharge targets computation q fuel table hq hbound) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateMissingComposition.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateMissingComposition.lean new file mode 100644 index 00000000..07032e2e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateMissingComposition.lean @@ -0,0 +1,66 @@ +import SphincsSecurity.Proof.OtsProbePrivateMissingAllowance + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem privateLiveMissingProbeAllowance_eq_zero_of_not_completable + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hcomplete : ¬DeferredCompletable table context) : + privateLiveMissingProbeAllowance target computation context fuel table = 0 := by + induction computation using OracleComp.inductionOn with + | pure value => rfl + | query_bind input next _ => rw [privateLiveMissingProbeAllowance_query_bind, if_neg hcomplete] + +noncomputable def privateMissingContinuationAllowance + (target : Position) + (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) : Option (ResolvedRunResult α) → ENNReal + | none => 0 + | some result => privateLiveMissingProbeAllowance target (next result.value) result.context result.remaining result.table + +theorem privateLiveMissingProbeAllowance_bind + (target : Position) + (left : OracleComp (LazyRevealProbe.World Coordinate) α) (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + privateLiveMissingProbeAllowance target (left >>= next) context fuel table = + privateLiveMissingProbeAllowance target left context fuel table + + ∑' result, Pr[= result | runResolvedFromTable context fuel table left] * privateMissingContinuationAllowance target next result := by + induction left using OracleComp.inductionOn generalizing context fuel table with + | pure value => simp [privateLiveMissingProbeAllowance, runResolvedFromTable, privateMissingContinuationAllowance] + | query_bind input continuation ih => + by_cases hcomplete : DeferredCompletable table context + · rw [bind_assoc, privateLiveMissingProbeAllowance_query_bind, privateLiveMissingProbeAllowance_query_bind, + if_pos hcomplete, if_pos hcomplete, runResolvedFromTable_bind, tsum_probOutput_bind_mul, add_assoc, ← ENNReal.tsum_add] + congr 1 + apply tsum_congr + intro result + by_cases hresult : result ∈ support (runResolvedFromTable context fuel table (liftM (OracleSpec.query input))) + · cases result with + | none => simp [privateMissingContinuationAllowance] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable (liftM (OracleSpec.query input)) context fuel table result hconsistent hstarts hresult + dsimp only + rw [ih result.value result.context result.remaining result.table hcore.2.1 (hcore.1 ▸ hcore.2.2), mul_add, ← ENNReal.tsum_mul_left] + · simp [probOutput_eq_zero_of_not_mem_support hresult] + · rw [privateLiveMissingProbeAllowance_eq_zero_of_not_completable target _ context fuel table hcomplete, + privateLiveMissingProbeAllowance_eq_zero_of_not_completable target _ context fuel table hcomplete, zero_add] + symm + apply ENNReal.tsum_eq_zero.mpr + intro result + by_cases hresult : result ∈ support (runResolvedFromTable context fuel table + ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= continuation)) + · cases result with + | none => simp [privateMissingContinuationAllowance] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table result hconsistent hstarts hresult + have hdoomed := not_deferredCompletable_of_mem_runResolvedFromTable _ context fuel table result hconsistent hstarts hresult hcomplete + simp only [privateMissingContinuationAllowance, hcore.1, + privateLiveMissingProbeAllowance_eq_zero_of_not_completable target _ _ _ _ hdoomed, mul_zero] + · simp [probOutput_eq_zero_of_not_mem_support hresult] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateMissingHash.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateMissingHash.lean new file mode 100644 index 00000000..3567ca54 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateMissingHash.lean @@ -0,0 +1,109 @@ +import SphincsSecurity.Proof.OtsProbePrivateMissingComposition + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem privateLiveMissingProbeAllowance_eq_zero_of_probeFree + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hfree : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) : + privateLiveMissingProbeAllowance target computation context fuel table = 0 := by + induction computation using OracleComp.inductionOn generalizing context fuel table with + | pure value => rfl + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hfree + have hinput : ¬LazyRevealProbe.IsProbe input := by simpa using hfree.1 + have hnext : ∀ reply, (next reply).IsQueryBoundP LazyRevealProbe.IsProbe 0 := by + intro reply + simpa using hfree.2 reply + have hweight : privateMissingProbeInputAllowance target table context input = 0 := by + cases input <;> simp_all [LazyRevealProbe.IsProbe, privateMissingProbeInputAllowance, privateProbeInputAllowance] + rw [privateLiveMissingProbeAllowance_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete, hweight, zero_add] + apply ENNReal.tsum_eq_zero.mpr + intro result + cases result with + | none => simp + | some result => + dsimp only + rw [ih result.value result.context result.remaining result.table (hnext result.value), mul_zero] + · rw [if_neg hcomplete] + +theorem privateLiveMissingProbeAllowance_bind_of_tail_probeFree + (target : Position) (left : OracleComp (LazyRevealProbe.World Coordinate) α) + (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hfree : ∀ value, (next value).IsQueryBoundP LazyRevealProbe.IsProbe 0) : + privateLiveMissingProbeAllowance target (left >>= next) context fuel table = + privateLiveMissingProbeAllowance target left context fuel table := by + rw [privateLiveMissingProbeAllowance_bind target left next context fuel table hconsistent hstarts] + suffices hzero : (∑' result, Pr[= result | runResolvedFromTable context fuel table left] * + privateMissingContinuationAllowance target next result) = 0 by rw [hzero, add_zero] + apply ENNReal.tsum_eq_zero.mpr + intro result + cases result with + | none => simp [privateMissingContinuationAllowance] + | some result => + rw [privateMissingContinuationAllowance, privateLiveMissingProbeAllowance_eq_zero_of_probeFree + target (next result.value) result.context result.remaining result.table (hfree result.value), mul_zero] + +noncomputable def privateMissingCandidateAllowance (target : Position) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) : Option Probe → ENNReal + | none => 0 + | some candidate => privateMissingProbeInputAllowance target table context (.probe candidate.coordinate candidate.candidate) + +theorem privateMissingAllowance_executeCandidate + (target : Position) (candidate : Option Probe) (cache : SplitHashCache) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + privateLiveMissingProbeAllowance target ((executeCandidate? candidate).run cache) context fuel table = + if DeferredCompletable table context then privateMissingCandidateAllowance target table context candidate else 0 := by + cases candidate with + | none => simp [executeCandidate?, privateLiveMissingProbeAllowance, privateMissingCandidateAllowance] + | some candidate => + simp [executeCandidate?, probe, LazyRevealProbe.probeQuery, privateLiveMissingProbeAllowance, + privateMissingCandidateAllowance, map_eq_bind_pure_comp] + split_ifs + · calc + _ = privateMissingProbeInputAllowance target table context (.probe candidate.coordinate candidate.candidate) + 0 := by + congr 1 + apply ENNReal.tsum_eq_zero.mpr + intro result + cases result <;> simp + _ = _ := add_zero _ + · rfl + +theorem privateMissingAllowance_probingHashQueryAfterPlan + (target : Position) (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (cache : SplitHashCache) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + privateLiveMissingProbeAllowance target ((probingHashQueryAfterPlan parameter input plan).run cache) context fuel table = + if DeferredCompletable table context then privateMissingCandidateAllowance target table context plan.candidate? else 0 := by + unfold probingHashQueryAfterPlan executePlannedHashQuery + rw [StateT.run_bind, privateLiveMissingProbeAllowance_bind_of_tail_probeFree target _ _ context fuel table hconsistent hstarts] + · exact privateMissingAllowance_executeCandidate target plan.candidate? cache context fuel table + · intro result + cases plan.action with + | ordinary => exact splitHashQuery_probeFree _ result.2 + | resolve coordinate => exact resolveKnownInput_probeFree parameter coordinate input result.2 + +theorem privateMissingAllowance_probingHashQuery + (target : Position) (parameter : PublicParameter) (input : HashInput) + (cache : SplitHashCache) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + privateLiveMissingProbeAllowance target ((probingHashQuery parameter input).run cache) context fuel table = + if DeferredCompletable table context then privateMissingCandidateAllowance target table context + (purePlanProbingHashQuery parameter input context.state).candidate? else 0 := by + rw [probingHashQuery_eq_plan_then_afterPlan, StateT.run_bind, + privateLiveMissingProbeAllowance_bind target _ _ context fuel table hconsistent hstarts, + privateLiveMissingProbeAllowance_eq_zero_of_probeFree target _ context fuel table (planProbingHashQuery_probeFree parameter input cache), + zero_add, runResolved_planProbingHashQuery parameter input context.state context fuel table cache rfl, + tsum_probOutput_pure_mul] + exact privateMissingAllowance_probingHashQueryAfterPlan target parameter input _ cache context fuel table hconsistent hstarts + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueAdaptiveSampling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueAdaptiveSampling.lean new file mode 100644 index 00000000..38507ec7 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueAdaptiveSampling.lean @@ -0,0 +1,188 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueFirstAccessCharge +import SphincsSecurity.Proof.OtsProbeResolvedPrivateObserver + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def privateResolutionObserve + (target : Position) (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : α) : ProbComp Bool := do + let resolved ← resolveDeferredPositionValue target context + match resolved with + | none => pure true + | some resolved => + if DeferredCompletable table resolved.toDeferredContext then observe resolved.toDeferredContext fuel value + else pure true + +instance privateResolutionObserve_dooms + (target : Position) (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → ProbComp Bool) : + ObserverDooms table (privateResolutionObserve target table observe) where + eq_true context fuel value hconsistent _hstarts hdoomed := by + unfold privateResolutionObserve + calc + _ = evalDist (resolveDeferredPositionValue target context >>= fun _ => pure true) := by + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hstillDoomed : ¬DeferredCompletable table result.toDeferredContext := by + rintro ⟨completion, hcompletion⟩ + have hback := (deferredCompletion_resolveDeferredPositionValue_iff target result + hconsistent hresult completion).mp hcompletion + exact hdoomed ⟨completion, hback.1⟩ + simp [hstillDoomed] + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolveDeferredPositionValue target context) (by simp [resolveDeferredPositionValue, LazyRevealProbe.sampleHashOutput]) + (pure true) + +theorem privateResolutionObserve_neutral + (target : Position) (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → ProbComp Bool) : + ObserverPositionNeutralAt table target (privateResolutionObserve target table observe) := by + intro context fuel value _hvalid _hcomplete _hensured + unfold privateResolutionObserve + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + dsimp only + rw [resolveDeferredPositionValue_of_resolved target context result hresult] + simp + +theorem evalDist_resolvePrivate_then_run_privateResolutionObserve + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) : + evalDist (do + let resolved ← resolveDeferredPositionValue target context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve (privateResolutionObserve target table observe) resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedObserve (privateResolutionObserve target table observe) context fuel table computation) := by + exact evalDist_resolveDeferredPositionValue_then_runResolvedObserve_auto_at target computation context fuel table + hvalid hcomplete hensured (privateResolutionObserve_neutral target table observe) + +noncomputable def privateResolutionResult + (target : Position) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (fuel : Nat) (value : α) : ProbComp (Option (DeferredContext × Nat × α)) := do + let resolved ← resolveDeferredPositionValue target context + match resolved with + | none => pure none + | some resolved => + if DeferredCompletable table resolved.toDeferredContext then pure (some (resolved.toDeferredContext, fuel, value)) + else pure none + +noncomputable def runPrivateResolvedView + (target : Position) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (fuel : Nat) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + ProbComp (Option (DeferredContext × Nat × α)) := do + let result ← runResolvedFromTable context fuel table computation + match result with + | none => pure none + | some result => privateResolutionResult target table result.context result.remaining result.value + +theorem privateResolutionObserve_eq_map + (target : Position) (table : OtsSecretIndex → HashOutput) + (test : Option (DeferredContext × Nat × α) → Bool) (htest : test none = true) + (context : DeferredContext) (fuel : Nat) (value : α) : + privateResolutionObserve target table (fun context fuel value => pure (test (some (context, fuel, value)))) + context fuel value = test <$> privateResolutionResult target table context fuel value := by + unfold privateResolutionObserve privateResolutionResult + rw [map_bind] + apply bind_congr + intro result + cases result with + | none => simp [htest] + | some result => + by_cases hcomplete : DeferredCompletable table result.toDeferredContext <;> simp [hcomplete, htest] + +theorem runPrivateResolvedView_observe_eq + (target : Position) (table : OtsSecretIndex → HashOutput) + (test : Option (DeferredContext × Nat × α) → Bool) (htest : test none = true) + (context : DeferredContext) (fuel : Nat) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + runResolvedObserve + (privateResolutionObserve target table (fun context fuel value => pure (test (some (context, fuel, value))))) + context fuel table computation = test <$> runPrivateResolvedView target table context fuel computation := by + unfold runResolvedObserve runPrivateResolvedView + rw [map_bind] + apply bind_congr + intro result + cases result with + | none => simp [finishObserve, htest] + | some result => exact privateResolutionObserve_eq_map target table test htest result.context result.remaining result.value + +theorem evalDist_eq_of_bool_tests_none (left right : ProbComp (Option α)) + (htests : ∀ test : Option α → Bool, test none = true → evalDist (test <$> left) = evalDist (test <$> right)) : + evalDist left = evalDist right := by + apply evalDist_ext + intro result + cases result with + | none => + have hp : Pr[fun output => output = true | Option.isNone <$> left] = + Pr[fun output => output = true | Option.isNone <$> right] := + probEvent_congr' (fun _ _ => Iff.rfl) (htests Option.isNone rfl) + rw [probEvent_map, probEvent_map] at hp + simpa only [Function.comp_def, Option.isNone_iff_eq_none, probEvent_eq_eq_probOutput] using hp + | some value => + let test := fun result : Option α => decide (result ≠ some value) + have hp : Pr[fun output => output = false | test <$> left] = + Pr[fun output => output = false | test <$> right] := + probEvent_congr' (fun _ _ => Iff.rfl) (htests test (by simp [test])) + rw [probEvent_map, probEvent_map] at hp + simpa only [Function.comp_def, test, decide_eq_false_iff_not, not_not, probEvent_eq_eq_probOutput] using hp + +theorem evalDist_resolvePrivate_then_runPrivateResolvedView + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) : + evalDist (do + let resolved ← resolveDeferredPositionValue target context + match resolved with + | none => pure none + | some resolved => runPrivateResolvedView target table resolved.toDeferredContext fuel computation) = + evalDist (runPrivateResolvedView target table context fuel computation) := by + apply evalDist_eq_of_bool_tests_none + intro test htest + have hdist := evalDist_resolvePrivate_then_run_privateResolutionObserve target computation + (fun context fuel value => pure (test (some (context, fuel, value)))) context fuel table hvalid hcomplete hensured + rw [runPrivateResolvedView_observe_eq target table test htest] at hdist + rw [map_bind] + apply Eq.trans _ hdist + apply evalDist_bind_congr + intro result _ + cases result with + | none => simp [htest] + | some result => + exact congrArg evalDist (runPrivateResolvedView_observe_eq target table test htest result.toDeferredContext fuel computation).symm + +theorem evalDist_runPrivateResolvedView_eq_uniform + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) : + evalDist (runPrivateResolvedView target table context fuel computation) = + evalDist (do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt (.position target) output then pure none + else runPrivateResolvedView target table (completePrivatePosition target context output).toDeferredContext fuel computation) := by + rw [← evalDist_resolvePrivate_then_runPrivateResolvedView target computation context fuel table hvalid hcomplete hensured] + unfold resolveDeferredPositionValue + simp only [hstate, hvalue, bind_assoc] + apply evalDist_bind_congr + intro output _ + by_cases hhit : context.state.hitAt (.position target) output <;> simp [hhit, completePrivatePosition] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueCompatibleRecords.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueCompatibleRecords.lean new file mode 100644 index 00000000..3db0e1e8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueCompatibleRecords.lean @@ -0,0 +1,266 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueRecordReplacement + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def PrivateRecordCompatible (target : Position) (before after : HashOutput) (record : ResolvedRunResult α) : Prop := + ¬record.context.state.hitAt (.position target) before ∧ ¬record.context.state.hitAt (.position target) after + +noncomputable def privateCompatibleRecordedResult + (target : Position) (before after : HashOutput) (result : Option (ResolvedRunResult α)) : Option (ResolvedRunResult α) := + (privateRecordedResult target result).filter (fun record => decide (PrivateRecordCompatible target before after record)) + +noncomputable def runPrivateCompatibleRecords + (target : Position) (before after : HashOutput) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + ProbComp (Option (ResolvedRunResult α)) := + privateCompatibleRecordedResult target before after <$> runResolvedFromTable context fuel table computation + +theorem privateCompatibleRecordedResult_eq_none_of_initial_hit + (target : Position) (output before after : HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (pending : Finset Digest) (bound : Nat) + (h : PrivateTargetState target output pending context) + (hsafe : computation.IsQueryBoundP (IsPrivatePositionDisclosure target) 0) + (hcount : computation.IsQueryBoundP (IsPrivatePositionProbe target) bound) + (hhit : truncateHash before ∈ pending ∨ truncateHash after ∈ pending) + (result : Option (ResolvedRunResult α)) (hresult : result ∈ support (runResolvedFromTable context fuel table computation)) : + privateCompatibleRecordedResult target before after result = none := by + cases result with + | none => rfl + | some result => + have hhistory := h.history_of_mem_runResolved computation context fuel table pending bound result hsafe hcount hresult + have hincompatible : ¬PrivateRecordCompatible target before after (replacePrivateRunResult target 0 result) := by + intro hcompatible + rcases hhit with hhit | hhit + · apply hcompatible.1 + exact hhistory.2.1 hhit + · apply hcompatible.2 + exact hhistory.2.1 hhit + by_cases hcomplete : DeferredCompletable result.table result.context <;> + simp [privateCompatibleRecordedResult, privateRecordedResult, retainCompletableResult, hcomplete] + exact hincompatible + +theorem evalDist_runPrivateCompatibleRecords_eq_none_of_initial_hit + (target : Position) (output before after : HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (pending : Finset Digest) (bound : Nat) + (h : PrivateTargetState target output pending context) + (hsafe : computation.IsQueryBoundP (IsPrivatePositionDisclosure target) 0) + (hcount : computation.IsQueryBoundP (IsPrivatePositionProbe target) bound) + (hhit : truncateHash before ∈ pending ∨ truncateHash after ∈ pending) : + evalDist (runPrivateCompatibleRecords target before after context fuel table computation) = + evalDist (pure none : ProbComp (Option (ResolvedRunResult α))) := by + unfold runPrivateCompatibleRecords + rw [map_eq_bind_pure_comp] + calc + _ = evalDist (runResolvedFromTable context fuel table computation >>= fun _ => pure none) := by + apply evalDist_bind_congr + intro result hresult + simp only [Function.comp_apply, privateCompatibleRecordedResult_eq_none_of_initial_hit target output before after + computation context fuel table pending bound h hsafe hcount hhit result hresult] + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (runResolvedFromTable context fuel table computation) (by simp [runResolvedFromTable]) (pure none) + +def privateExposureDoneResult : Option (ResolvedRunResult (PrivateValueCut α)) → Option (ResolvedRunResult α) + | none => none + | some result => + match result.value with + | .done value => some ⟨result.context, result.remaining, value, result.table⟩ + | .query _ _ => none + +theorem privateExposureDoneResult_recorded + (target : Position) (result : Option (ResolvedRunResult (PrivateValueCut α))) : + privateExposureDoneResult (privateRecordedResult target result) = + privateRecordedResult target (privateExposureDoneResult result) := by + cases result with + | none => rfl + | some result => + cases hvalue : result.value with + | done value => + by_cases hcomplete : DeferredCompletable result.table result.context <;> + simp [privateExposureDoneResult, privateRecordedResult, retainCompletableResult, hcomplete, replacePrivateRunResult, hvalue] + | query input next => + by_cases hcomplete : DeferredCompletable result.table result.context <;> + simp [privateExposureDoneResult, privateRecordedResult, retainCompletableResult, hcomplete, replacePrivateRunResult, hvalue] + +theorem privateExposureDoneResult_compatible + (target : Position) (before after : HashOutput) (result : Option (ResolvedRunResult (PrivateValueCut α))) : + privateExposureDoneResult (privateCompatibleRecordedResult target before after result) = + privateCompatibleRecordedResult target before after (privateExposureDoneResult result) := by + unfold privateCompatibleRecordedResult + rw [← privateExposureDoneResult_recorded target result] + cases privateRecordedResult target result with + | none => rfl + | some record => + cases hvalue : record.value with + | done value => + conv_rhs => rw [privateExposureDoneResult, hvalue] + dsimp only + simp only [Option.filter] + have heq : PrivateRecordCompatible target before after + (⟨record.context, record.remaining, value, record.table⟩ : ResolvedRunResult α) = + PrivateRecordCompatible target before after record := rfl + simp only [heq] + by_cases hcompatible : PrivateRecordCompatible target before after record <;> + simp [hcompatible, privateExposureDoneResult, hvalue] + | query input next => + simp only [Option.filter] + by_cases hcompatible : PrivateRecordCompatible target before after record <;> + simp [hcompatible, privateExposureDoneResult, hvalue] + +theorem runPrivateCompatibleRecords_eq_filter + (target : Position) (before after : HashOutput) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + runPrivateCompatibleRecords target before after context fuel table computation = + (fun result => result.filter (fun record => decide (PrivateRecordCompatible target before after record))) <$> + runPrivateRecords target context fuel table computation := by + unfold runPrivateCompatibleRecords runPrivateRecords privateCompatibleRecordedResult + rw [Functor.map_map] + +theorem evalDist_runPrivateCompatibleRecords_eq_exposure_cut + (target : Position) (output before after : HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (pending : Finset Digest) (bound : Nat) + (h : PrivateTargetState target output pending context) + (hsafe : computation.IsQueryBoundP (IsPrivatePositionDisclosure target) 0) + (hcount : computation.IsQueryBoundP (IsPrivatePositionProbe target) bound) : + evalDist (runPrivateCompatibleRecords target before after context fuel table computation) = + evalDist (privateExposureDoneResult <$> + runPrivateCompatibleRecords target before after context fuel table (privateValueExposureCut target before after computation)) := by + induction computation using OracleComp.inductionOn generalizing context fuel pending bound with + | pure value => + change evalDist (pure (privateCompatibleRecordedResult target before after + (some ⟨context, fuel, value, table⟩))) = evalDist (pure (privateExposureDoneResult + (privateCompatibleRecordedResult target before after (some ⟨context, fuel, .done value, table⟩)))) + rw [privateExposureDoneResult_compatible] + rfl + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hsafe hcount + have hquery : ¬IsPrivatePositionDisclosure target query := by simpa using hsafe.1 + have hnext : ∀ reply, (next reply).IsQueryBoundP (IsPrivatePositionDisclosure target) 0 := by + intro reply + simpa using hsafe.2 reply + rw [privateValueExposureCut_query_bind] + by_cases hexposure : IsPrivateValueExposure target before after query + · rw [if_pos hexposure] + have hright : evalDist (privateExposureDoneResult <$> + runPrivateCompatibleRecords target before after context fuel table (pure (.query query next))) = + evalDist (pure none : ProbComp (Option (ResolvedRunResult α))) := by + change evalDist (pure (privateExposureDoneResult (privateCompatibleRecordedResult target before after + (some ⟨context, fuel, .query query next, table⟩)))) = _ + rw [privateExposureDoneResult_compatible] + rfl + rw [hright] + cases query with + | uniform n => simp [IsPrivateValueExposure] at hexposure + | hashOutput => simp [IsPrivateValueExposure] at hexposure + | ensure coordinate => simp [IsPrivateValueExposure] at hexposure + | peek coordinate => simp [IsPrivateValueExposure] at hexposure + | publish coordinate => exact False.elim (hquery hexposure) + | reveal coordinate => exact False.elim (hquery hexposure) + | probe coordinate digest => + obtain ⟨rfl, hmatch⟩ := hexposure + cases fuel with + | zero => simp [runPrivateCompatibleRecords, runResolvedFromTable_probe_query_bind, + privateCompatibleRecordedResult, privateRecordedResult, retainCompletableResult] + | succ remaining => + have hhit : truncateHash before ∈ insert digest pending ∨ truncateHash after ∈ insert digest pending := by + rcases hmatch with hmatch | hmatch <;> simp [← hmatch] + have hzero := evalDist_runPrivateCompatibleRecords_eq_none_of_initial_hit target output before after (next ()) + { context with state := context.state.addPending (.position target) digest } remaining table (insert digest pending) _ + (h.probe_target digest) (hnext ()) (hcount.2 ()) hhit + simpa only [runPrivateCompatibleRecords, runResolvedFromTable_probe_query_bind, if_neg h.2.2.1] using hzero + · rw [if_neg hexposure] + cases query with + | uniform n => + simp only [runPrivateCompatibleRecords, runResolvedFromTable_uniform_query_bind, map_bind] + apply evalDist_bind_congr + intro reply _ + exact ih reply context fuel pending bound h (hnext reply) (by simpa [IsPrivatePositionProbe] using hcount.2 reply) + | hashOutput => + simp only [runPrivateCompatibleRecords, runResolvedFromTable_hashOutput_query_bind, map_bind] + apply evalDist_bind_congr + intro reply _ + exact ih reply context fuel pending bound h (hnext reply) (by simpa [IsPrivatePositionProbe] using hcount.2 reply) + | ensure coordinate => + simp only [runPrivateCompatibleRecords, runResolvedFromTable_ensure_query_bind] + exact ih () { context with state := context.state.ensure coordinate } fuel pending bound h (hnext ()) + (by simpa [IsPrivatePositionProbe] using hcount.2 ()) + | peek coordinate => + simp only [runPrivateCompatibleRecords, runResolvedFromTable_peek_query_bind] + exact ih _ context fuel pending bound h (hnext _) (by simpa [IsPrivatePositionProbe] using hcount.2 _) + | publish coordinate => + simp only [runPrivateCompatibleRecords, runResolvedFromTable_publish_query_bind] + exact ih () _ fuel pending bound (h.publish_other coordinate hquery) (hnext ()) + (by simpa [IsPrivatePositionProbe] using hcount.2 ()) + | probe coordinate digest => + simp only [runPrivateCompatibleRecords, runResolvedFromTable_probe_query_bind] + cases fuel with + | zero => simp [privateCompatibleRecordedResult, privateRecordedResult, + retainCompletableResult, privateExposureDoneResult] + | succ remaining => + dsimp only + split_ifs + · exact ih () context remaining pending _ h (hnext ()) (hcount.2 ()) + · by_cases htarget : coordinate = .position target + · subst coordinate + exact ih () _ remaining (insert digest pending) _ (h.probe_target digest) (hnext ()) (hcount.2 ()) + · exact ih () _ remaining pending _ (h.probe_other coordinate digest htarget) (hnext ()) (hcount.2 ()) + | reveal coordinate => + have hbound (reply) : (next reply).IsQueryBoundP (IsPrivatePositionProbe target) bound := by + simpa [IsPrivatePositionProbe] using hcount.2 reply + simp only [runPrivateCompatibleRecords, runResolvedFromTable_reveal_query_bind] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [pure_bind] + cases hresolved : resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context with + | none => simp [privateCompatibleRecordedResult, privateRecordedResult, + retainCompletableResult, privateExposureDoneResult] + | some middle => + have hvalues := resolveDeferredChainStart_deferred_values_eq table ⟨lay, tree, leafIdx, chainIdx⟩ context middle hresolved + exact ih middle.output _ fuel pending bound + (h.materialize_other _ middle.output middle.values (by simp) (hvalues ▸ h.2.1)) + (hnext middle.output) (hbound middle.output) + | position position => + dsimp only + simp only [map_bind] + apply evalDist_bind_congr + intro option hresolve + cases option with + | none => simp [privateCompatibleRecordedResult, privateRecordedResult, + retainCompletableResult, privateExposureDoneResult] + | some middle => + have hvalue := privateValue_preserved_by_resolveDeferredReveal target position output table context middle h.1 h.2.1 hresolve + exact ih middle.output _ fuel pending bound (h.materialize_other _ middle.output middle.values hquery hvalue) + (hnext middle.output) (hbound middle.output) + + +theorem evalDist_runPrivateCompatibleRecords_preload_eq + (target : Position) (before after : HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (bound : Nat) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (hbefore : ¬context.state.hitAt (.position target) before) (hafter : ¬context.state.hitAt (.position target) after) + (hsafe : computation.IsQueryBoundP (IsPrivatePositionDisclosure target) 0) + (hcount : computation.IsQueryBoundP (IsPrivatePositionProbe target) bound) : + evalDist (runPrivateCompatibleRecords target before after (replacePrivatePosition target before context) fuel table computation) = + evalDist (runPrivateCompatibleRecords target before after (replacePrivatePosition target after context) fuel table computation) := by + have hinitial (output : HashOutput) : PrivateTargetState target output (context.state.pendingAt (.position target)) + (replacePrivatePosition target output context) := + ⟨hstate, by simp [replacePrivatePosition, DeferredStructuralValues.install], hhidden, rfl⟩ + rw [evalDist_runPrivateCompatibleRecords_eq_exposure_cut target before before after computation _ fuel table _ bound + (hinitial before) hsafe hcount, + evalDist_runPrivateCompatibleRecords_eq_exposure_cut target after before after computation _ fuel table _ bound + (hinitial after) hsafe hcount] + apply evalDist_map_eq_of_evalDist_eq + simp only [runPrivateCompatibleRecords_eq_filter] + apply evalDist_map_eq_of_evalDist_eq + have hdist := evalDist_privateExposureRecords_preload_swap target before after computation context fuel table hstate hbefore hafter + rwa [privateValueExposureCut_swap target after before computation] at hdist + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueCompletion.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueCompletion.lean new file mode 100644 index 00000000..9d166c6c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueCompletion.lean @@ -0,0 +1,63 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueReplacement + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem DeferredCompletable.replacePrivatePosition + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hcomplete : DeferredCompletable table context) (target : Position) (output : HashOutput) + (hstate : context.state.values (.position target) = none) (hclean : ¬context.state.hitAt (.position target) output) : + DeferredCompletable table (replacePrivatePosition target output context) := by + obtain ⟨completion, hcompletion⟩ := hcomplete + refine ⟨Function.update completion (.position target) output, ?_, ?_, ?_, ?_⟩ + · intro coordinate value hvalue + change context.state.values coordinate = some value at hvalue + by_cases heq : coordinate = .position target + · subst coordinate + simp [hstate] at hvalue + · rw [Function.update_of_ne heq] + exact hcompletion.1 coordinate value hvalue + · intro position value hvalue + change Function.update context.values target (some output) position = some value at hvalue + by_cases heq : position = target + · subst position + simp only [Function.update_self, Option.some.injEq] at hvalue + simp [hvalue] + · rw [Function.update_of_ne heq] at hvalue + rw [Function.update_of_ne (by simpa using heq)] + exact hcompletion.2.1 position value hvalue + · intro coordinate candidate hpending + change (coordinate, candidate) ∈ context.state.pending at hpending + by_cases heq : coordinate = .position target + · subst coordinate + rw [Function.update_self] + intro hhit + apply hclean + change truncateHash output ∈ context.state.pendingAt (.position target) + rw [LazyRevealProbe.State.mem_pendingAt_iff, hhit] + exact hpending + · rw [Function.update_of_ne heq] + exact hcompletion.2.2.1 coordinate candidate hpending + · intro index + rw [Function.update_of_ne (by cases index; simp [OtsSecretIndex.coordinate])] + exact hcompletion.2.2.2 index + +theorem deferredCompletable_replacePrivatePosition_iff + (target : Position) (before after : HashOutput) (context : DeferredContext) (table : OtsSecretIndex → HashOutput) + (hreplaceable : PrivatePositionReplaceable target before after context) : + DeferredCompletable table (replacePrivatePosition target after context) ↔ DeferredCompletable table context := by + constructor + · intro hcomplete + have hback := hcomplete.replacePrivatePosition target before hreplaceable.1 hreplaceable.2.2.1 + have hupdate : Function.update context.values target (some before) = context.values := by + rw [← hreplaceable.2.1] + exact Function.update_eq_self _ _ + simpa only [replacePrivatePosition, DeferredStructuralValues.install, Function.update_idem, hupdate] using hback + · intro hcomplete + exact hcomplete.replacePrivatePosition target after hreplaceable.1 hreplaceable.2.2.2 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueCut.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueCut.lean new file mode 100644 index 00000000..1d3bdfb4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueCut.lean @@ -0,0 +1,118 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueExecution + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +inductive PrivateValueCut (α : Type) where + | done (value : α) + | query (input : LazyRevealProbe.Query Coordinate) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) + +def PrivateValueCut.resume : PrivateValueCut α → OracleComp (LazyRevealProbe.World Coordinate) α + | .done value => pure value + | .query input next => (liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= next + +noncomputable def privateValueExposureCut + (target : Position) (before after : HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + OracleComp (LazyRevealProbe.World Coordinate) (PrivateValueCut α) := + OracleComp.construct (fun value => pure (.done value)) + (fun input next recursivelyCut => + if IsPrivateValueExposure target before after input then pure (.query input next) + else (liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= recursivelyCut) computation + +theorem privateValueExposureCut_query_bind + (target : Position) (before after : HashOutput) (input : LazyRevealProbe.Query Coordinate) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) : + privateValueExposureCut target before after ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= next) = + (if IsPrivateValueExposure target before after input then pure (.query input next) + else (liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= + fun output => privateValueExposureCut target before after (next output)) := rfl + +theorem privateValueExposureCut_resume + (target : Position) (before after : HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + privateValueExposureCut target before after computation >>= PrivateValueCut.resume = computation := by + induction computation using OracleComp.inductionOn with + | pure value => rfl + | query_bind input next ih => + rw [privateValueExposureCut_query_bind] + split_ifs + · rfl + · rw [bind_assoc] + exact bind_congr ih + +theorem privateValueExposureCut_no_exposure + (target : Position) (before after : HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + (privateValueExposureCut target before after computation).IsQueryBoundP + (IsPrivateValueExposure target before after) 0 := by + induction computation using OracleComp.inductionOn with + | pure value => simp [privateValueExposureCut] + | query_bind input next ih => + rw [privateValueExposureCut_query_bind] + split_ifs with hinput + · simp + · rw [OracleComp.isQueryBoundP_query_bind_iff] + exact ⟨Or.inl hinput, fun output => by simpa only [if_neg hinput] using ih output⟩ + +theorem privateValueExposureCut_swap + (target : Position) (before after : HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + privateValueExposureCut target before after computation = privateValueExposureCut target after before computation := by + induction computation using OracleComp.inductionOn with + | pure value => rfl + | query_bind input next ih => + have hexposure : IsPrivateValueExposure target before after input ↔ IsPrivateValueExposure target after before input := by + cases input <;> simp [IsPrivateValueExposure, or_comm] + rw [privateValueExposureCut_query_bind, privateValueExposureCut_query_bind, propext hexposure] + split_ifs + · rfl + · exact bind_congr ih + +theorem evalDist_privateValueExposureCut_replace + (target : Position) (before after : HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (h : PrivatePositionReplaceable target before after context) : + evalDist (runResolvedFromTable (replacePrivatePosition target after context) fuel table + (privateValueExposureCut target before after computation)) = + evalDist (Option.map (replacePrivateRunResult target after) <$> + runResolvedFromTable context fuel table (privateValueExposureCut target before after computation)) := + evalDist_runResolved_replacePrivatePosition target before after _ context fuel table h + (privateValueExposureCut_no_exposure target before after computation) + +theorem evalDist_privateValueExposureCut_value_replace + (target : Position) (before after : HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (h : PrivatePositionReplaceable target before after context) : + evalDist (Option.map ResolvedRunResult.value <$> runResolvedFromTable (replacePrivatePosition target after context) + fuel table (privateValueExposureCut target before after computation)) = + evalDist (Option.map ResolvedRunResult.value <$> + runResolvedFromTable context fuel table (privateValueExposureCut target before after computation)) := by + rw [evalDist_map, evalDist_privateValueExposureCut_replace target before after computation context fuel table h, + ← evalDist_map, Functor.map_map] + congr 1 + apply congrArg (fun f => f <$> runResolvedFromTable context fuel table + (privateValueExposureCut target before after computation)) + funext result + cases result <;> rfl + +theorem evalDist_privateValueExposureCut_preload_swap + (target : Position) (before after : HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hstate : context.state.values (.position target) = none) + (hbefore : ¬context.state.hitAt (.position target) before) + (hafter : ¬context.state.hitAt (.position target) after) : + evalDist (Option.map ResolvedRunResult.value <$> runResolvedFromTable (replacePrivatePosition target before context) + fuel table (privateValueExposureCut target before after computation)) = + evalDist (Option.map ResolvedRunResult.value <$> runResolvedFromTable (replacePrivatePosition target after context) + fuel table (privateValueExposureCut target after before computation)) := by + have hreplaceable : PrivatePositionReplaceable target before after (replacePrivatePosition target before context) := by + exact ⟨hstate, by simp [replacePrivatePosition, DeferredStructuralValues.install], hbefore, hafter⟩ + have hreplace := evalDist_privateValueExposureCut_value_replace target before after computation + (replacePrivatePosition target before context) fuel table hreplaceable + rw [privateValueExposureCut_swap target after before computation] + simpa [replacePrivatePosition, DeferredStructuralValues.install] using hreplace.symm + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueExecution.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueExecution.lean new file mode 100644 index 00000000..14cfc4aa --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueExecution.lean @@ -0,0 +1,152 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueReplacement + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def IsPrivateValueExposure (target : Position) (before after : HashOutput) : LazyRevealProbe.Query Coordinate → Prop + | .reveal coordinate | .publish coordinate => coordinate = .position target + | .probe coordinate digest => coordinate = .position target ∧ + (digest = truncateHash before ∨ digest = truncateHash after) + | _ => False + +def replacePrivateRunResult (target : Position) (output : HashOutput) (result : ResolvedRunResult α) : ResolvedRunResult α := + { result with context := replacePrivatePosition target output result.context } + +theorem PrivatePositionReplaceable.addPending + {target : Position} {before after : HashOutput} {context : DeferredContext} + (h : PrivatePositionReplaceable target before after context) (coordinate : Coordinate) (digest : Digest) + (hsafe : ¬IsPrivateValueExposure target before after (.probe coordinate digest)) : + PrivatePositionReplaceable target before after + { context with state := context.state.addPending coordinate digest } := by + refine ⟨h.1, h.2.1, ?_, ?_⟩ + all_goals + intro hhit + simp only [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff, + LazyRevealProbe.State.addPending, Finset.mem_insert] at hhit + rcases hhit with hhit | hhit + · apply hsafe + obtain ⟨hcoordinate, hdigest⟩ := Prod.mk.inj hhit + exact ⟨hcoordinate.symm, by first | exact Or.inl hdigest.symm | exact Or.inr hdigest.symm⟩ + · first + | apply h.2.2.1 + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff] using hhit + | apply h.2.2.2 + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff] using hhit + +theorem PrivatePositionReplaceable.materialize_other + {target : Position} {before after : HashOutput} {context : DeferredContext} + (h : PrivatePositionReplaceable target before after context) + (coordinate : Coordinate) (output : HashOutput) (values : DeferredStructuralValues) + (hne : coordinate ≠ .position target) (hvalue : values target = some before) : + PrivatePositionReplaceable target before after + { state := context.state.materialize coordinate output, values := values } := by + refine ⟨?_, hvalue, ?_, ?_⟩ + · simpa [LazyRevealProbe.State.materialize, Function.update_of_ne (Ne.symm hne)] using h.1 + all_goals + intro hhit + simp only [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff, + LazyRevealProbe.State.materialize, LazyRevealProbe.State.pendingAway, Finset.mem_filter] at hhit + first + | apply h.2.2.1 + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff] using hhit.1 + | apply h.2.2.2 + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff] using hhit.1 + +theorem privateValue_preserved_by_resolveDeferredReveal + (target position : Position) (before : HashOutput) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (result : DeferredResolution) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = some before) + (hresult : some result ∈ support (resolveDeferredReveal table position context)) : + result.values target = some before := by + have hknown : context.positionValue target = some before := by simp [DeferredContext.positionValue, hstate, hvalue] + have hpreserved : result.toDeferredContext.positionValue target = some before := by + unfold resolveDeferredReveal at hresult + split_ifs at hresult + · exact resolveDeferredPosition_preserves_positionValue table position context result target before hknown hresult + · exact resolveDeferredPositionValue_preserves_positionValue position target context result before hknown hresult + have hstates := resolveDeferredReveal_preserves_state_values table position context result hresult + simpa [DeferredContext.positionValue, hstates, hstate] using hpreserved + +theorem evalDist_runResolved_replacePrivatePosition + (target : Position) (before after : HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (h : PrivatePositionReplaceable target before after context) + (hsafe : computation.IsQueryBoundP (IsPrivateValueExposure target before after) 0) : + evalDist (runResolvedFromTable (replacePrivatePosition target after context) fuel table computation) = + evalDist (Option.map (replacePrivateRunResult target after) <$> runResolvedFromTable context fuel table computation) := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => simp [runResolvedFromTable, replacePrivateRunResult] + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hsafe + have hquery : ¬IsPrivateValueExposure target before after query := by simpa using hsafe.1 + have hnext : ∀ output, (next output).IsQueryBoundP (IsPrivateValueExposure target before after) 0 := by + intro output + simpa using hsafe.2 output + cases query with + | uniform n => + rw [runResolvedFromTable_uniform_query_bind, runResolvedFromTable_uniform_query_bind, map_bind] + apply evalDist_bind_congr + intro output _ + exact ih output context fuel h (hnext output) + | hashOutput => + rw [runResolvedFromTable_hashOutput_query_bind, runResolvedFromTable_hashOutput_query_bind, map_bind] + apply evalDist_bind_congr + intro output _ + exact ih output context fuel h (hnext output) + | ensure coordinate => + rw [runResolvedFromTable_ensure_query_bind, runResolvedFromTable_ensure_query_bind] + exact ih () { context with state := context.state.ensure coordinate } fuel h (hnext ()) + | peek coordinate => + rw [runResolvedFromTable_peek_query_bind, runResolvedFromTable_peek_query_bind] + exact ih _ context fuel h (hnext _) + | publish coordinate => + rw [runResolvedFromTable_publish_query_bind, runResolvedFromTable_publish_query_bind] + exact ih () { context with state := context.state.publish coordinate } fuel h (hnext ()) + | probe coordinate digest => + rw [runResolvedFromTable_probe_query_bind, runResolvedFromTable_probe_query_bind] + cases fuel with + | zero => simp + | succ remaining => + dsimp only [replacePrivatePosition] + split_ifs with hrevealed + · exact ih () context remaining h (hnext ()) + · exact ih () { context with state := context.state.addPending coordinate digest } remaining + (h.addPending coordinate digest hquery) (hnext ()) + | reveal coordinate => + rw [runResolvedFromTable_reveal_query_bind, runResolvedFromTable_reveal_query_bind] + have hne : coordinate ≠ .position target := hquery + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [resolveDeferredChainStart_replacePrivatePosition, pure_bind] + cases hresolved : resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context with + | none => simp + | some result => + have hvalues : result.values = context.values := by + unfold resolveDeferredChainStart at hresolved + dsimp only at hresolved + split at hresolved <;> split_ifs at hresolved <;> simp_all + all_goals rw [← hresolved] + have hcontinue := h.materialize_other (.chainStart lay tree leafIdx chainIdx) result.output result.values + (by simp) (hvalues ▸ h.2.1) + exact ih result.output _ fuel hcontinue (hnext result.output) + | position position => + have hposition : position ≠ target := fun heq => hne (congrArg Coordinate.position heq) + rw [evalDist_bind, evalDist_resolveDeferredReveal_replacePrivatePosition target position before after table + context h, ← evalDist_bind, bind_map_left, map_bind] + apply evalDist_bind_congr + intro option hoption + cases option with + | none => simp + | some result => + have hvalue := privateValue_preserved_by_resolveDeferredReveal target position before table context result + h.1 h.2.1 hoption + have hcontinue := h.materialize_other (.position position) result.output result.values hne hvalue + simpa only [Option.map, replacePrivateResolution, replacePrivatePosition, Option.some.injEq, hposition, ↓reduceIte] using + ih result.output _ fuel hcontinue (hnext result.output) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueFirstAccess.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueFirstAccess.lean new file mode 100644 index 00000000..37a03008 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueFirstAccess.lean @@ -0,0 +1,127 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueCut + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def IsPrivatePositionAccess (target : Position) : LazyRevealProbe.Query Coordinate → Prop + | .reveal coordinate | .publish coordinate | .probe coordinate _ => coordinate = .position target + | _ => False + +noncomputable def privatePositionAccessCut + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + OracleComp (LazyRevealProbe.World Coordinate) (PrivateValueCut α) := + OracleComp.construct (fun value => pure (.done value)) + (fun input next recursivelyCut => + if IsPrivatePositionAccess target input then pure (.query input next) + else (liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= recursivelyCut) computation + +theorem privatePositionAccessCut_query_bind + (target : Position) (input : LazyRevealProbe.Query Coordinate) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) : + privatePositionAccessCut target ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= next) = + (if IsPrivatePositionAccess target input then pure (.query input next) + else (liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= + fun output => privatePositionAccessCut target (next output)) := rfl + +theorem privatePositionAccessCut_resume + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + privatePositionAccessCut target computation >>= PrivateValueCut.resume = computation := by + induction computation using OracleComp.inductionOn with + | pure value => rfl + | query_bind input next ih => + rw [privatePositionAccessCut_query_bind] + split_ifs + · rfl + · rw [bind_assoc] + exact bind_congr ih + +theorem privatePositionAccessCut_no_access + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + (privatePositionAccessCut target computation).IsQueryBoundP (IsPrivatePositionAccess target) 0 := by + induction computation using OracleComp.inductionOn with + | pure value => simp [privatePositionAccessCut] + | query_bind input next ih => + rw [privatePositionAccessCut_query_bind] + split_ifs with hinput + · simp + · rw [OracleComp.isQueryBoundP_query_bind_iff] + exact ⟨Or.inl hinput, fun output => by simpa only [if_neg hinput] using ih output⟩ + +theorem privatePositionAccessCut_no_exposure + (target : Position) (before after : HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + (privatePositionAccessCut target computation).IsQueryBoundP (IsPrivateValueExposure target before after) 0 := by + induction computation using OracleComp.inductionOn with + | pure value => simp [privatePositionAccessCut] + | query_bind input next ih => + rw [privatePositionAccessCut_query_bind] + split_ifs with hinput + · simp + · have hsafe : ¬IsPrivateValueExposure target before after input := by + cases input <;> simp_all [IsPrivatePositionAccess, IsPrivateValueExposure] + rw [OracleComp.isQueryBoundP_query_bind_iff] + exact ⟨Or.inl hsafe, fun output => by simpa only [if_neg hsafe] using ih output⟩ + +def privatePositionAccessCandidate (target : Position) : Option (PrivateValueCut α) → Option Digest + | some (.query (.probe coordinate digest) _) => if coordinate = .position target then some digest else none + | _ => none + +noncomputable def privatePositionFirstCandidate + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (output : HashOutput) : ProbComp (Option Digest) := + (fun result => (privatePositionAccessCandidate target (result.map ResolvedRunResult.value)).filter + (fun digest => digest ∉ context.state.pendingAt (.position target))) <$> + runResolvedFromTable (replacePrivatePosition target output context) fuel table (privatePositionAccessCut target computation) + +theorem privatePositionFirstCandidate_fresh + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (output : HashOutput) (digest : Digest) + (hresult : some digest ∈ support (privatePositionFirstCandidate target computation context fuel table output)) : + digest ∉ context.state.pendingAt (.position target) := by + unfold privatePositionFirstCandidate at hresult + rw [support_map, Set.mem_image] at hresult + obtain ⟨result, _, hresult⟩ := hresult + cases hcandidate : privatePositionAccessCandidate target (result.map ResolvedRunResult.value) with + | none => simp [hcandidate] at hresult + | some candidate => + simp [hcandidate] at hresult + exact hresult.2 + +theorem evalDist_privatePositionFirstCandidate_eq + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (before after : HashOutput) + (hstate : context.state.values (.position target) = none) + (hbefore : ¬context.state.hitAt (.position target) before) + (hafter : ¬context.state.hitAt (.position target) after) : + evalDist (privatePositionFirstCandidate target computation context fuel table before) = + evalDist (privatePositionFirstCandidate target computation context fuel table after) := by + have hreplaceable : PrivatePositionReplaceable target before after (replacePrivatePosition target before context) := + ⟨hstate, by simp [replacePrivatePosition, DeferredStructuralValues.install], hbefore, hafter⟩ + have hreplace := evalDist_runResolved_replacePrivatePosition target before after + (privatePositionAccessCut target computation) (replacePrivatePosition target before context) fuel table hreplaceable + (privatePositionAccessCut_no_exposure target before after computation) + have hdist : evalDist (runResolvedFromTable (replacePrivatePosition target after context) fuel table + (privatePositionAccessCut target computation)) = + evalDist (Option.map (replacePrivateRunResult target after) <$> + runResolvedFromTable (replacePrivatePosition target before context) fuel table + (privatePositionAccessCut target computation)) := by + simpa [replacePrivatePosition, DeferredStructuralValues.install] using hreplace + unfold privatePositionFirstCandidate + rw [evalDist_map, evalDist_map, hdist, evalDist_map, Functor.map_map] + congr 1 + funext result + cases result <;> rfl + +noncomputable def sampledPrivatePositionFirstCandidate + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : ProbComp (HashOutput × Option Digest) := do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt (.position target) output then pure (output, none) + else + let candidate ← privatePositionFirstCandidate target computation context fuel table output + pure (output, candidate) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueFirstAccessCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueFirstAccessCharge.lean new file mode 100644 index 00000000..798f71d0 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueFirstAccessCharge.lean @@ -0,0 +1,233 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueFirstAccessRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def PrivateTargetState (target : Position) (output : HashOutput) (pending : Finset Digest) + (context : DeferredContext) : Prop := + context.state.values (.position target) = none ∧ context.values target = some output ∧ + .position target ∉ context.state.revealed ∧ context.state.pendingAt (.position target) = pending + +theorem PrivateTargetState.probe_other + {target : Position} {output : HashOutput} {pending : Finset Digest} {context : DeferredContext} + (h : PrivateTargetState target output pending context) (coordinate : Coordinate) (digest : Digest) + (hne : coordinate ≠ .position target) : + PrivateTargetState target output pending { context with state := context.state.addPending coordinate digest } := by + refine ⟨h.1, h.2.1, h.2.2.1, ?_⟩ + rw [← h.2.2.2] + ext candidate + simp [LazyRevealProbe.State.mem_pendingAt_iff, LazyRevealProbe.State.addPending, Ne.symm hne] + +theorem PrivateTargetState.publish_other + {target : Position} {output : HashOutput} {pending : Finset Digest} {context : DeferredContext} + (h : PrivateTargetState target output pending context) (coordinate : Coordinate) (hne : coordinate ≠ .position target) : + PrivateTargetState target output pending { context with state := context.state.publish coordinate } := by + refine ⟨h.1, h.2.1, ?_, h.2.2.2⟩ + simpa [LazyRevealProbe.State.publish, Ne.symm hne] using h.2.2.1 + +theorem PrivateTargetState.materialize_other + {target : Position} {output : HashOutput} {pending : Finset Digest} {context : DeferredContext} + (h : PrivateTargetState target output pending context) (coordinate : Coordinate) (value : HashOutput) + (values : DeferredStructuralValues) (hne : coordinate ≠ .position target) (hvalue : values target = some output) : + PrivateTargetState target output pending { state := context.state.materialize coordinate value, values := values } := by + refine ⟨?_, hvalue, h.2.2.1, ?_⟩ + · simpa [LazyRevealProbe.State.materialize, Function.update_of_ne (Ne.symm hne)] using h.1 + · rw [← h.2.2.2] + ext candidate + simp [LazyRevealProbe.State.mem_pendingAt_iff, LazyRevealProbe.State.materialize, + LazyRevealProbe.State.pendingAway, Ne.symm hne] + +theorem PrivateTargetState.of_mem_runResolved_no_access + {target : Position} {output : HashOutput} {pending : Finset Digest} + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (h : PrivateTargetState target output pending context) + (hsafe : computation.IsQueryBoundP (IsPrivatePositionAccess target) 0) + (hresult : some result ∈ support (runResolvedFromTable context fuel table computation)) : + PrivateTargetState target output pending result.context := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runResolvedFromTable] at hresult + subst result + exact h + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hsafe + have hquery : ¬IsPrivatePositionAccess target query := by simpa using hsafe.1 + have hnext : ∀ reply, (next reply).IsQueryBoundP (IsPrivatePositionAccess target) 0 := by + intro reply + simpa using hsafe.2 reply + cases query with + | uniform n => + rw [runResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨reply, _, htail⟩ := hresult + exact ih reply context fuel h (hnext reply) htail + | hashOutput => + rw [runResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨reply, _, htail⟩ := hresult + exact ih reply context fuel h (hnext reply) htail + | ensure coordinate => + rw [runResolvedFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel h (hnext ()) hresult + | peek coordinate => + rw [runResolvedFromTable_peek_query_bind] at hresult + exact ih _ context fuel h (hnext _) hresult + | publish coordinate => + rw [runResolvedFromTable_publish_query_bind] at hresult + exact ih () _ fuel (h.publish_other coordinate hquery) (hnext ()) hresult + | probe coordinate digest => + rw [runResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + split_ifs at hresult + · exact ih () context remaining h (hnext ()) hresult + · exact ih () _ remaining (h.probe_other coordinate digest hquery) (hnext ()) hresult + | reveal coordinate => + rw [runResolvedFromTable_reveal_query_bind] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [pure_bind] at hresult + cases hresolved : resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context with + | none => simp [hresolved] at hresult + | some middle => + simp only [hresolved] at hresult + have hvalues := resolveDeferredChainStart_deferred_values_eq table ⟨lay, tree, leafIdx, chainIdx⟩ + context middle hresolved + exact ih middle.output _ fuel + (h.materialize_other _ middle.output middle.values (by simp) (hvalues ▸ h.2.1)) + (hnext middle.output) hresult + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨option, hresolve, htail⟩ := hresult + cases option with + | none => simp at htail + | some middle => + have hvalue := privateValue_preserved_by_resolveDeferredReveal target position output table context middle + h.1 h.2.1 hresolve + exact ih middle.output _ fuel (h.materialize_other _ middle.output middle.values hquery hvalue) + (hnext middle.output) htail + +theorem PrivateTargetState.materializedCandidateCharge_eq + {target : Position} {output : HashOutput} {pending : Finset Digest} {context : DeferredContext} + (h : PrivateTargetState target output pending context) (digest : Digest) : + materializedCandidateCharge (materializedDeferredState context) (some ⟨.position target, digest⟩) = + if digest ∈ pending then 0 else 1 := by + have hpending : (.position target, digest) ∈ context.state.pending ↔ digest ∈ pending := by + rw [← LazyRevealProbe.State.mem_pendingAt_iff, h.2.2.2] + simp [materializedCandidateCharge, h.2.2.1, hpending, DeferredContext.positionValue, h.1, h.2.1] + +noncomputable def privatePositionCutCharge (target : Position) : + Option (ResolvedRunResult (PrivateValueCut α)) → ENNReal + | none => 0 + | some result => + match privatePositionAccessCandidate target (some result.value) with + | none => 0 + | some digest => materializedCandidateCharge (materializedDeferredState result.context) (some ⟨.position target, digest⟩) + +theorem privatePositionCutCharge_eq_indicator + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (output : HashOutput) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (result : Option (ResolvedRunResult (PrivateValueCut α))) + (hresult : result ∈ support (runResolvedFromTable (replacePrivatePosition target output context) fuel table + (privatePositionAccessCut target computation))) : + privatePositionCutCharge target result = + if (privatePositionAccessCandidate target (result.map ResolvedRunResult.value)).filter + (fun digest => digest ∉ context.state.pendingAt (.position target)) ≠ none then 1 else 0 := by + cases result with + | none => simp [privatePositionCutCharge, privatePositionAccessCandidate] + | some result => + have hinitial : PrivateTargetState target output (context.state.pendingAt (.position target)) + (replacePrivatePosition target output context) := + ⟨hstate, by simp [replacePrivatePosition, DeferredStructuralValues.install], hhidden, rfl⟩ + have hfinal := PrivateTargetState.of_mem_runResolved_no_access (privatePositionAccessCut target computation) + (replacePrivatePosition target output context) fuel table result hinitial + (privatePositionAccessCut_no_access target computation) hresult + have hcandidate (candidate : Option Digest) : + (match candidate with + | none => (0 : ENNReal) + | some digest => (materializedCandidateCharge (materializedDeferredState result.context) + (some ⟨.position target, digest⟩) : ENNReal)) = + if candidate.filter (fun digest => digest ∉ context.state.pendingAt (.position target)) ≠ none then 1 else 0 := by + cases candidate with + | none => simp + | some digest => + dsimp only + rw [hfinal.materializedCandidateCharge_eq] + by_cases hfresh : digest ∈ context.state.pendingAt (.position target) <;> simp [hfresh] + exact hcandidate (privatePositionAccessCandidate target (some result.value)) + +theorem probEvent_privatePositionFirstCandidate_eq_expected_charge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (output : HashOutput) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) : + Pr[fun candidate => candidate ≠ none | privatePositionFirstCandidate target computation context fuel table output] = + ∑' result, Pr[= result | runResolvedFromTable (replacePrivatePosition target output context) fuel table + (privatePositionAccessCut target computation)] * privatePositionCutCharge target result := by + unfold privatePositionFirstCandidate + rw [probEvent_map, probEvent_eq_tsum_ite] + apply tsum_congr + intro result + by_cases hresult : result ∈ support (runResolvedFromTable (replacePrivatePosition target output context) fuel table + (privatePositionAccessCut target computation)) + · rw [privatePositionCutCharge_eq_indicator target computation context fuel table output hstate hhidden result hresult] + split_ifs <;> simp_all + · simp [probOutput_eq_zero_of_not_mem_support hresult] + +noncomputable def sampledPrivatePositionFirstCharge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : ENNReal := + ∑' output, Pr[= output | LazyRevealProbe.sampleHashOutput] * + if context.state.hitAt (.position target) output then 0 + else ∑' result, Pr[= result | runResolvedFromTable (replacePrivatePosition target output context) fuel table + (privatePositionAccessCut target computation)] * privatePositionCutCharge target result + +theorem probEvent_sampledPrivatePositionFirstCandidate_eq_expected_charge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) : + Pr[fun pair => pair.2 ≠ none | sampledPrivatePositionFirstCandidate target computation context fuel table] = + sampledPrivatePositionFirstCharge target computation context fuel table := by + unfold sampledPrivatePositionFirstCandidate sampledPrivatePositionFirstCharge + rw [probEvent_bind_eq_tsum] + apply tsum_congr + intro output + by_cases hhit : context.state.hitAt (.position target) output + · simp [hhit] + · rw [if_neg hhit] + have hmap : Pr[fun pair : HashOutput × Option Digest => pair.2 ≠ none | + privatePositionFirstCandidate target computation context fuel table output >>= fun candidate => pure (output, candidate)] = + Pr[fun candidate => candidate ≠ none | privatePositionFirstCandidate target computation context fuel table output] := + probEvent_bind_pure_comp (privatePositionFirstCandidate target computation context fuel table output) + (fun candidate => (output, candidate)) (fun pair => pair.2 ≠ none) + rw [hmap, probEvent_privatePositionFirstCandidate_eq_expected_charge target computation context fuel table output hstate hhidden, + if_neg hhit] + +theorem probEvent_sampledPrivatePositionFirstCandidate_hit_le_charge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (hcard : context.state.pending.card ≤ 2 ^ 126) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | + sampledPrivatePositionFirstCandidate target computation context fuel table] ≤ + sampledPrivatePositionFirstCharge target computation context fuel table * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + rw [← probEvent_sampledPrivatePositionFirstCandidate_eq_expected_charge target computation context fuel table hstate hhidden] + exact probEvent_sampledPrivatePositionFirstCandidate_hit_le_four_thirds target computation context fuel table hstate hcard + +theorem probEvent_sampledPrivatePositionFirstCandidate_hit_le_charge_of_no_pending + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (hpending : context.state.pendingAt (.position target) = ∅) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | + sampledPrivatePositionFirstCandidate target computation context fuel table] ≤ + sampledPrivatePositionFirstCharge target computation context fuel table * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + rw [← probEvent_sampledPrivatePositionFirstCandidate_eq_expected_charge target computation context fuel table hstate hhidden] + exact probEvent_sampledPrivatePositionFirstCandidate_hit_le_of_no_pending target computation context fuel table hstate hpending + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueFirstAccessRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueFirstAccessRisk.lean new file mode 100644 index 00000000..7f2f8847 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueFirstAccessRisk.lean @@ -0,0 +1,182 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueFirstAccess + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +private theorem probEvent_bind_return (computation : ProbComp α) (f : α → β) (event : β → Prop) : + Pr[event | computation >>= fun value => pure (f value)] = Pr[fun value => event (f value) | computation] := + probEvent_bind_pure_comp computation f event + +noncomputable def filteredPrivateGuess (allowed : HashOutput → Prop) + (run : HashOutput → ProbComp (Option Digest)) : ProbComp (HashOutput × Option Digest) := do + let output ← LazyRevealProbe.sampleHashOutput + if allowed output then + let candidate ← run output + pure (output, candidate) + else pure (output, none) + +theorem probEvent_uniform_private_guess_eq (common : ProbComp (Option Digest)) : + Pr[fun pair : HashOutput × Option Digest => pair.2 = some (truncateHash pair.1) | do + let output ← LazyRevealProbe.sampleHashOutput + let candidate ← common + pure (output, candidate)] = + Pr[fun candidate => candidate ≠ none | common] * (Fintype.card Digest : ENNReal)⁻¹ := by + rw [probEvent_congr' (fun _ _ => Iff.rfl) (OracleComp.DeferredSampling.evalDist_bind_comm _ _ _)] + rw [probEvent_bind_eq_tsum, probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_right] + apply tsum_congr + intro candidate + cases candidate with + | none => simp + | some digest => + rw [probEvent_bind_return] + simp only [Option.some.injEq] + congr 1 + simpa only [LazyRevealProbe.sampleHashOutput, eq_comm] using SphincsSecurity.probEvent_uniform_truncateHash_eq digest + +theorem probEvent_filteredPrivateGuess_hit_le_common + (allowed : HashOutput → Prop) (run : HashOutput → ProbComp (Option Digest)) (common : ProbComp (Option Digest)) + (hsame : ∀ output, allowed output → evalDist (run output) = evalDist common) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | filteredPrivateGuess allowed run] ≤ + Pr[fun candidate => candidate ≠ none | common] * (Fintype.card Digest : ENNReal)⁻¹ := by + rw [← probEvent_uniform_private_guess_eq common] + unfold filteredPrivateGuess + rw [probEvent_bind_eq_tsum, probEvent_bind_eq_tsum] + apply ENNReal.tsum_le_tsum + intro output + by_cases hallowed : allowed output + · rw [if_pos hallowed, probEvent_bind_return, probEvent_bind_return] + exact le_of_eq (congrArg (fun probability => Pr[= output | LazyRevealProbe.sampleHashOutput] * probability) + (probEvent_congr' (fun _ _ => Iff.rfl) (hsame output hallowed))) + · simp [hallowed] + +theorem probEvent_filteredPrivateGuess_hasCandidate_eq + (allowed : HashOutput → Prop) (run : HashOutput → ProbComp (Option Digest)) (common : ProbComp (Option Digest)) + (hsame : ∀ output, allowed output → evalDist (run output) = evalDist common) : + Pr[fun pair => pair.2 ≠ none | filteredPrivateGuess allowed run] = + Pr[allowed | LazyRevealProbe.sampleHashOutput] * Pr[fun candidate => candidate ≠ none | common] := by + unfold filteredPrivateGuess + rw [probEvent_bind_eq_tsum, probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_right] + apply tsum_congr + intro output + by_cases hallowed : allowed output + · rw [if_pos hallowed, if_pos hallowed, probEvent_bind_return] + exact congrArg (fun probability => Pr[= output | LazyRevealProbe.sampleHashOutput] * probability) + (probEvent_congr' (fun _ _ => Iff.rfl) (hsame output hallowed)) + · simp [hallowed] + +theorem probEvent_filteredPrivateGuess_hit_le_four_thirds + (allowed : HashOutput → Prop) (run : HashOutput → ProbComp (Option Digest)) (common : ProbComp (Option Digest)) + (hsame : ∀ output, allowed output → evalDist (run output) = evalDist common) + (hgood : (3 / 4 : ENNReal) ≤ Pr[allowed | LazyRevealProbe.sampleHashOutput]) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | filteredPrivateGuess allowed run] ≤ + Pr[fun pair => pair.2 ≠ none | filteredPrivateGuess allowed run] * + ((4 / 3 : ENNReal) * (Fintype.card Digest : ENNReal)⁻¹) := by + rw [probEvent_filteredPrivateGuess_hasCandidate_eq allowed run common hsame] + apply (probEvent_filteredPrivateGuess_hit_le_common allowed run common hsame).trans + calc + _ = ((3 / 4 : ENNReal) * Pr[fun candidate => candidate ≠ none | common]) * + ((4 / 3 : ENNReal) * (Fintype.card Digest : ENNReal)⁻¹) := by + have hfactor : (3 / 4 : ENNReal) * (4 / 3) = 1 := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + norm_num [ENNReal.toReal_mul, ENNReal.toReal_div] + calc + _ = ((3 / 4 : ENNReal) * (4 / 3)) * + (Pr[fun candidate => candidate ≠ none | common] * (Fintype.card Digest : ENNReal)⁻¹) := by rw [hfactor, one_mul] + _ = _ := by ring + _ ≤ _ := mul_le_mul' (mul_le_mul' hgood le_rfl) le_rfl + +theorem probEvent_no_private_pendingHit_ge_three_quarters + (context : DeferredContext) (target : Position) (hcard : context.state.pending.card ≤ 2 ^ 126) : + (3 / 4 : ENNReal) ≤ Pr[fun output => ¬context.state.hitAt (.position target) output | LazyRevealProbe.sampleHashOutput] := by + have hquarter : Pr[context.state.hitAt (.position target) | LazyRevealProbe.sampleHashOutput] ≤ (1 / 4 : ENNReal) := by + apply (LazyRevealProbe.probEvent_sampleHashOutput_hitAt_le context.state (.position target)).trans + have htargetCard : (context.state.pendingAt (.position target)).card ≤ 2 ^ 126 := by + have := context.state.pendingAway_card_add_pendingAt_card_le (.position target) + omega + calc + _ ≤ ((2 ^ 126 : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + mul_le_mul' (Nat.cast_le.mpr htargetCard) le_rfl + _ = _ := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + norm_num [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_div, digestBits] + have hdouble : Pr[fun output => ¬¬context.state.hitAt (.position target) output | LazyRevealProbe.sampleHashOutput] ≤ + (1 / 4 : ENNReal) := by simpa only [not_not] using hquarter + have hgood := probEvent_one_sub_le_of_compl_le (by simp : Pr[⊥ | LazyRevealProbe.sampleHashOutput] = 0) hdouble + have hsum : (1 : ENNReal) ≤ + Pr[fun output => ¬context.state.hitAt (.position target) output | LazyRevealProbe.sampleHashOutput] + 1 / 4 := + tsub_le_iff_right.mp hgood + have hreal := (ENNReal.toReal_le_toReal (by finiteness) + (ENNReal.add_ne_top.mpr ⟨probEvent_ne_top, by finiteness⟩)).mpr hsum + apply (ENNReal.toReal_le_toReal (by finiteness) probEvent_ne_top).mp + rw [ENNReal.toReal_add probEvent_ne_top (by finiteness)] at hreal + norm_num [ENNReal.toReal_div] at hreal ⊢ + linarith + +theorem sampledPrivatePositionFirstCandidate_eq_filtered + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + sampledPrivatePositionFirstCandidate target computation context fuel table = + filteredPrivateGuess (fun output => ¬context.state.hitAt (.position target) output) + (privatePositionFirstCandidate target computation context fuel table) := by + unfold sampledPrivatePositionFirstCandidate filteredPrivateGuess + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position target) output <;> simp [hhit] + +theorem probEvent_sampledPrivatePositionFirstCandidate_hit_le_four_thirds + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hstate : context.state.values (.position target) = none) (hcard : context.state.pending.card ≤ 2 ^ 126) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | + sampledPrivatePositionFirstCandidate target computation context fuel table] ≤ + Pr[fun pair => pair.2 ≠ none | sampledPrivatePositionFirstCandidate target computation context fuel table] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + have hsmall : context.state.pending.card < Fintype.card Digest := + hcard.trans_lt (by norm_num [digestBits]) + obtain ⟨digest, hmiss⟩ := exists_digest_not_mem_pendingAt context.state (.position target) hsmall + let reference := hashOutputOfDigest digest + have hclean : ¬context.state.hitAt (.position target) reference := by + simpa only [LazyRevealProbe.State.hitAt, reference, truncateHash_hashOutputOfDigest] using hmiss + rw [sampledPrivatePositionFirstCandidate_eq_filtered] + simpa only [show Fintype.card Digest = 2 ^ digestBits by simp] using + probEvent_filteredPrivateGuess_hit_le_four_thirds + (fun output => ¬context.state.hitAt (.position target) output) + (privatePositionFirstCandidate target computation context fuel table) + (privatePositionFirstCandidate target computation context fuel table reference) + (fun output houtput => evalDist_privatePositionFirstCandidate_eq target computation context fuel table + output reference hstate houtput hclean) + (probEvent_no_private_pendingHit_ge_three_quarters context target hcard) + +theorem probEvent_sampledPrivatePositionFirstCandidate_hit_le_of_no_pending + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hstate : context.state.values (.position target) = none) + (hpending : context.state.pendingAt (.position target) = ∅) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | + sampledPrivatePositionFirstCandidate target computation context fuel table] ≤ + Pr[fun pair => pair.2 ≠ none | sampledPrivatePositionFirstCandidate target computation context fuel table] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let allowed := fun output => ¬context.state.hitAt (.position target) output + let run := privatePositionFirstCandidate target computation context fuel table + have hclean (output : HashOutput) : allowed output := by + simp [allowed, LazyRevealProbe.State.hitAt, hpending] + have hsame : ∀ output, allowed output → evalDist (run output) = evalDist (run 0) := by + intro output _ + exact evalDist_privatePositionFirstCandidate_eq target computation context fuel table output 0 hstate + (hclean output) (hclean 0) + have hgood : Pr[allowed | LazyRevealProbe.sampleHashOutput] = 1 := by + simp [allowed, LazyRevealProbe.State.hitAt, hpending] + have hgate := probEvent_filteredPrivateGuess_hasCandidate_eq allowed run (run 0) hsame + rw [hgood, one_mul] at hgate + rw [sampledPrivatePositionFirstCandidate_eq_filtered] + change Pr[fun pair => pair.2 = some (truncateHash pair.1) | filteredPrivateGuess allowed run] ≤ + Pr[fun pair => pair.2 ≠ none | filteredPrivateGuess allowed run] * _ + rw [hgate] + simpa only [show Fintype.card Digest = 2 ^ digestBits by simp] using + probEvent_filteredPrivateGuess_hit_le_common allowed run (run 0) hsame + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueFirstAccessTransport.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueFirstAccessTransport.lean new file mode 100644 index 00000000..d80ec2c5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueFirstAccessTransport.lean @@ -0,0 +1,191 @@ +import SphincsSecurity.Proof.OtsProbePrivateValuePendingCleanup + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem clearPending_eq_self_of_pendingAt_empty + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) (hempty : state.pendingAt coordinate = ∅) : + state.clearPending coordinate = state := by + have hpending : state.pendingAway coordinate = state.pending := by + apply Finset.filter_eq_self.mpr + intro pair hpair heq + have hmem : pair.2 ∈ state.pendingAt coordinate := by + rw [LazyRevealProbe.State.mem_pendingAt_iff] + simpa only [← heq, Prod.mk.eta] using hpair + simp [hempty] at hmem + cases state + simp_all [LazyRevealProbe.State.clearPending] + +theorem PrivateTargetState.resolve_of_no_pending + {target : Position} {output : HashOutput} {context : DeferredContext} + (h : PrivateTargetState target output ∅ context) : + resolveDeferredPositionValue target context = pure (some (DeferredResolution.mk context output)) := by + have hclear := clearPending_eq_self_of_pendingAt_empty context.state (.position target) h.2.2.2 + simp [resolveDeferredPositionValue, h.1, h.2.1, LazyRevealProbe.State.hitAt, h.2.2.2, hclear] + +def privateResolvedCandidate (target : Position) (pending : Finset Digest) : + Option (DeferredContext × Nat × PrivateValueCut α) → Option (HashOutput × Digest) + | none => none + | some (context, remaining, cut) => do + let output ← context.positionValue target + let candidate ← privateLiveCandidateProjection target pending (some (remaining, cut)) + pure (output, candidate) + +theorem evalDist_privateResolvedCandidate_of_preloaded_cut + (target : Position) (output : HashOutput) (pending : Finset Digest) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (h : PrivateTargetState target output ∅ context) : + evalDist (privateResolvedCandidate target pending <$> + runPrivateResolvedView target table context fuel (privatePositionAccessCut target computation)) = + evalDist ((fun candidate => candidate.map (fun digest => (output, digest))) <$> + (privateLiveCandidateProjection target pending <$> + runResolvedLiveValue table context fuel (privatePositionAccessCut target computation))) := by + unfold runPrivateResolvedView runResolvedLiveValue + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hfinal := PrivateTargetState.of_mem_runResolved_no_access (privatePositionAccessCut target computation) + context fuel table result h (privatePositionAccessCut_no_access target computation) hresult + have hknown : result.context.positionValue target = some output := by + simp [DeferredContext.positionValue, hfinal.1, hfinal.2.1] + dsimp only + unfold privateResolutionResult + rw [hfinal.resolve_of_no_pending] + simp only [pure_bind] + by_cases hcomplete : DeferredCompletable table result.context + · simp only [if_pos hcomplete, pure_bind, Function.comp_apply, privateResolvedCandidate, hknown] + cases privateLiveCandidateProjection target pending (some (result.remaining, result.value)) <;> rfl + · simp [hcomplete, privateResolvedCandidate, privateLiveCandidateProjection, privatePositionAccessCandidate] + +theorem evalDist_privateResolvedCandidate_completePrivatePosition + (target : Position) (output : HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (hclean : ¬context.state.hitAt (.position target) output) : + evalDist (privateResolvedCandidate target (context.state.pendingAt (.position target)) <$> + runPrivateResolvedView target table (completePrivatePosition target context output).toDeferredContext fuel + (privatePositionAccessCut target computation)) = + evalDist ((fun candidate => candidate.map (fun digest => (output, digest))) <$> + privatePositionFirstLiveCandidate target computation context fuel table output) := by + have hinitial : PrivateTargetState target output ∅ (completePrivatePosition target context output).toDeferredContext := by + refine ⟨hstate, ?_, hhidden, ?_⟩ + · simp [completePrivatePosition, DeferredStructuralValues.install] + · ext digest + simp [completePrivatePosition, LazyRevealProbe.State.pendingAt, LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway] + rw [evalDist_privateResolvedCandidate_of_preloaded_cut target output _ computation _ fuel table hinitial] + exact evalDist_map_eq_of_evalDist_eq + (evalDist_privatePositionFirstLiveCandidate_clearPending target computation context fuel table output hvalid hcomplete hstate hclean).symm _ + +def privateSampledCandidatePair (pair : HashOutput × Option Digest) : Option (HashOutput × Digest) := + pair.2.map (fun digest => (pair.1, digest)) + +theorem evalDist_privateResolvedCandidate_eq_sampled_first + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hhidden : .position target ∉ context.state.revealed) : + evalDist (privateResolvedCandidate target (context.state.pendingAt (.position target)) <$> + runPrivateResolvedView target table context fuel (privatePositionAccessCut target computation)) = + evalDist (privateSampledCandidatePair <$> sampledPrivatePositionFirstLiveCandidate target computation context fuel table) := by + have hdist := evalDist_runPrivateResolvedView_eq_uniform target (privatePositionAccessCut target computation) + context fuel table hvalid hcomplete hensured hstate hvalue + calc + _ = evalDist (privateResolvedCandidate target (context.state.pendingAt (.position target)) <$> (do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt (.position target) output then pure none + else + runPrivateResolvedView target table (completePrivatePosition target context output).toDeferredContext fuel + (privatePositionAccessCut target computation))) := by + rw [evalDist_map, evalDist_map, hdist] + _ = _ := by + unfold sampledPrivatePositionFirstLiveCandidate filteredPrivateGuess + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro output _ + by_cases hhit : context.state.hitAt (.position target) output + · simp [hhit, privateResolvedCandidate, privateSampledCandidatePair] + · simp only [if_neg hhit, if_pos hhit] + have htransport := evalDist_privateResolvedCandidate_completePrivatePosition target output computation + context fuel table hvalid hcomplete hstate hhidden hhit + simpa only [map_eq_bind_pure_comp, bind_assoc, Function.comp_def, pure_bind, privateSampledCandidatePair] using htransport + +def PrivateCandidatePairHit : Option (HashOutput × Digest) → Prop + | none => False + | some (output, candidate) => candidate = truncateHash output + +theorem probEvent_privateResolvedCandidate_hit_le_charge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hhidden : .position target ∉ context.state.revealed) (hcard : context.state.pending.card ≤ 2 ^ 126) : + Pr[PrivateCandidatePairHit | privateResolvedCandidate target (context.state.pendingAt (.position target)) <$> + runPrivateResolvedView target table context fuel (privatePositionAccessCut target computation)] ≤ + sampledPrivatePositionFirstLiveCharge target computation context fuel table * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + have hdist := evalDist_privateResolvedCandidate_eq_sampled_first target computation context fuel table + hvalid hcomplete hensured hstate hvalue hhidden + rw [probEvent_congr' (fun _ _ => Iff.rfl) hdist, probEvent_map] + have hevent (pair : HashOutput × Option Digest) : PrivateCandidatePairHit (privateSampledCandidatePair pair) ↔ + pair.2 = some (truncateHash pair.1) := by + rcases pair with ⟨output, candidate⟩ + cases candidate <;> simp [privateSampledCandidatePair, PrivateCandidatePairHit] + have hprob := probEvent_congr' (fun pair _ => hevent pair) + (rfl : evalDist (sampledPrivatePositionFirstLiveCandidate target computation context fuel table) = _) + simp only [Function.comp_def] + rw [hprob] + exact probEvent_sampledPrivatePositionFirstLiveCandidate_hit_le_charge target computation context fuel table hstate hhidden hcard + +theorem probEvent_privateResolvedCandidate_exists_eq_charge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hhidden : .position target ∉ context.state.revealed) : + Pr[fun pair => pair ≠ none | privateResolvedCandidate target (context.state.pendingAt (.position target)) <$> + runPrivateResolvedView target table context fuel (privatePositionAccessCut target computation)] = + sampledPrivatePositionFirstLiveCharge target computation context fuel table := by + have hdist := evalDist_privateResolvedCandidate_eq_sampled_first target computation context fuel table + hvalid hcomplete hensured hstate hvalue hhidden + rw [probEvent_congr' (fun _ _ => Iff.rfl) hdist, probEvent_map] + have hevent (pair : HashOutput × Option Digest) : privateSampledCandidatePair pair ≠ none ↔ pair.2 ≠ none := by + rcases pair with ⟨output, candidate⟩ + cases candidate <;> simp [privateSampledCandidatePair] + have hprob := probEvent_congr' (fun pair _ => hevent pair) + (rfl : evalDist (sampledPrivatePositionFirstLiveCandidate target computation context fuel table) = _) + simp only [Function.comp_def] + rw [hprob] + exact probEvent_sampledPrivatePositionFirstLiveCandidate_eq_charge target computation context fuel table hstate hhidden + +theorem probEvent_privateResolvedCandidate_hit_le_occurrence + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hhidden : .position target ∉ context.state.revealed) (hcard : context.state.pending.card ≤ 2 ^ 126) : + Pr[PrivateCandidatePairHit | privateResolvedCandidate target (context.state.pendingAt (.position target)) <$> + runPrivateResolvedView target table context fuel (privatePositionAccessCut target computation)] ≤ + Pr[fun pair => pair ≠ none | privateResolvedCandidate target (context.state.pendingAt (.position target)) <$> + runPrivateResolvedView target table context fuel (privatePositionAccessCut target computation)] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + rw [probEvent_privateResolvedCandidate_exists_eq_charge target computation context fuel table + hvalid hcomplete hensured hstate hvalue hhidden] + exact probEvent_privateResolvedCandidate_hit_le_charge target computation context fuel table + hvalid hcomplete hensured hstate hvalue hhidden hcard + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueHistoryRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueHistoryRisk.lean new file mode 100644 index 00000000..c58ebd11 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueHistoryRisk.lean @@ -0,0 +1,222 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueFirstAccessTransport + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem privateValue_compatible_row_mass + (allowed : HashOutput → Prop) (weight : ENNReal) (likelihood : HashOutput → ENNReal) + (hrow : ∀ output, likelihood output = if allowed output then weight else 0) : + (∑' output, Pr[= output | LazyRevealProbe.sampleHashOutput] * likelihood output) = + Pr[allowed | LazyRevealProbe.sampleHashOutput] * weight := by + rw [probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_right] + apply tsum_congr + intro output + rw [hrow] + by_cases hallowed : allowed output <;> simp [hallowed] + +theorem privateValue_compatible_row_hit_le + (allowed : HashOutput → Prop) (weight : ENNReal) (likelihood : HashOutput → ENNReal) (candidate : Digest) + (hrow : ∀ output, likelihood output = if allowed output then weight else 0) + (hallowed : (3 / 4 : ENNReal) ≤ Pr[allowed | LazyRevealProbe.sampleHashOutput]) : + (∑' output, if truncateHash output = candidate then + Pr[= output | LazyRevealProbe.sampleHashOutput] * likelihood output else 0) ≤ + (∑' output, Pr[= output | LazyRevealProbe.sampleHashOutput] * likelihood output) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + have hhit : (∑' output, if truncateHash output = candidate then + Pr[= output | LazyRevealProbe.sampleHashOutput] * likelihood output else 0) ≤ + weight * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ ∑' output, if truncateHash output = candidate then + Pr[= output | LazyRevealProbe.sampleHashOutput] * weight else 0 := by + apply ENNReal.tsum_le_tsum + intro output + have hle : likelihood output ≤ weight := by rw [hrow]; split_ifs <;> simp + split_ifs + · exact mul_le_mul' le_rfl hle + · rfl + _ = Pr[fun output => truncateHash output = candidate | LazyRevealProbe.sampleHashOutput] * weight := by + rw [probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_right] + apply tsum_congr + intro output + split_ifs <;> simp + _ = _ := by + rw [show Pr[fun output => truncateHash output = candidate | LazyRevealProbe.sampleHashOutput] = + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ by + simpa only [LazyRevealProbe.sampleHashOutput, show Fintype.card Digest = 2 ^ digestBits by simp] using + SphincsSecurity.probEvent_uniform_truncateHash_eq candidate] + exact mul_comm _ _ + rw [privateValue_compatible_row_mass allowed weight likelihood hrow] + apply hhit.trans + have hfactor : (3 / 4 : ENNReal) * (4 / 3) = 1 := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + norm_num [ENNReal.toReal_mul, ENNReal.toReal_div] + calc + _ = ((3 / 4 : ENNReal) * weight) * ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + calc + _ = ((3 / 4 : ENNReal) * (4 / 3)) * (weight * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by rw [hfactor, one_mul] + _ = _ := by ring + _ ≤ _ := mul_le_mul' (mul_le_mul' hallowed le_rfl) le_rfl + +theorem probEvent_uniform_avoids_private_history_ge_three_quarters + (history : Finset Digest) (hcard : history.card ≤ 2 ^ 126) : + (3 / 4 : ENNReal) ≤ Pr[fun output => truncateHash output ∉ history | LazyRevealProbe.sampleHashOutput] := by + have hbad : Pr[fun output => truncateHash output ∈ history | LazyRevealProbe.sampleHashOutput] ≤ (1 / 4 : ENNReal) := by + calc + _ = (history.card : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + simpa only [LazyRevealProbe.sampleHashOutput, div_eq_mul_inv, show Fintype.card Digest = 2 ^ digestBits by simp] using + SphincsSecurity.probEvent_uniform_truncateHash_mem history + _ ≤ ((2 ^ 126 : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + mul_le_mul' (Nat.cast_le.mpr hcard) le_rfl + _ = _ := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + norm_num [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_div, digestBits] + have hdouble : Pr[fun output => ¬truncateHash output ∉ history | LazyRevealProbe.sampleHashOutput] ≤ (1 / 4 : ENNReal) := by + simpa only [not_not] using hbad + have hgood := probEvent_one_sub_le_of_compl_le (by simp : Pr[⊥ | LazyRevealProbe.sampleHashOutput] = 0) hdouble + have hsum : (1 : ENNReal) ≤ Pr[fun output => truncateHash output ∉ history | LazyRevealProbe.sampleHashOutput] + 1 / 4 := + tsub_le_iff_right.mp hgood + have hreal := (ENNReal.toReal_le_toReal (by finiteness) + (ENNReal.add_ne_top.mpr ⟨probEvent_ne_top, by finiteness⟩)).mpr hsum + apply (ENNReal.toReal_le_toReal (by finiteness) probEvent_ne_top).mp + rw [ENNReal.toReal_add probEvent_ne_top (by finiteness)] at hreal + norm_num [ENNReal.toReal_div] at hreal ⊢ + linarith + +theorem privateValue_history_row_hit_le + (history : Finset Digest) (weight : ENNReal) (likelihood : HashOutput → ENNReal) (candidate : Digest) + (hrow : ∀ output, likelihood output = if truncateHash output ∉ history then weight else 0) + (hcard : history.card ≤ 2 ^ 126) : + (∑' output, if truncateHash output = candidate then + Pr[= output | LazyRevealProbe.sampleHashOutput] * likelihood output else 0) ≤ + (∑' output, Pr[= output | LazyRevealProbe.sampleHashOutput] * likelihood output) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := + privateValue_compatible_row_hit_le (fun output => truncateHash output ∉ history) weight likelihood candidate + (fun output => by + by_cases hclean : truncateHash output ∉ history <;> simpa only [if_pos hclean, if_neg hclean] using hrow output) + (probEvent_uniform_avoids_private_history_ge_three_quarters history hcard) + +noncomputable def samplePrivateHistoryGuess + (run : HashOutput → ProbComp (Option α)) (candidate : α → Option Digest) : ProbComp (HashOutput × Option Digest) := do + let output ← LazyRevealProbe.sampleHashOutput + let record ← run output + pure (output, record.bind candidate) + +theorem probEvent_samplePrivateHistoryGuess_eq_rows + (run : HashOutput → ProbComp (Option α)) (candidate : α → Option Digest) + (event : HashOutput × Option Digest → Prop) : + Pr[event | samplePrivateHistoryGuess run candidate] = + ∑' record, ∑' output, if event (output, record.bind candidate) then + Pr[= output | LazyRevealProbe.sampleHashOutput] * Pr[= record | run output] else 0 := by + unfold samplePrivateHistoryGuess + simp_rw [probEvent_bind_eq_tsum, probEvent_pure] + calc + _ = ∑' output, ∑' record, if event (output, record.bind candidate) then + Pr[= output | LazyRevealProbe.sampleHashOutput] * Pr[= record | run output] else 0 := by + apply tsum_congr + intro output + rw [← ENNReal.tsum_mul_left] + apply tsum_congr + intro record + split_ifs <;> simp + _ = _ := ENNReal.tsum_comm + +theorem probEvent_samplePrivateHistoryGuess_hit_le + (run : HashOutput → ProbComp (Option α)) (candidate : α → Option Digest) + (history : α → Finset Digest) (weight : α → ENNReal) + (hrows : ∀ output record, Pr[= some record | run output] = + if truncateHash output ∉ history record then weight record else 0) + (hcard : ∀ record, (history record).card ≤ 2 ^ 126) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | samplePrivateHistoryGuess run candidate] ≤ + Pr[fun pair => pair.2 ≠ none | samplePrivateHistoryGuess run candidate] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + rw [probEvent_samplePrivateHistoryGuess_eq_rows, probEvent_samplePrivateHistoryGuess_eq_rows, ← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro record + cases record with + | none => simp + | some record => + cases hcandidate : candidate record with + | none => simp [hcandidate] + | some digest => + simp only [Option.bind_some, hcandidate, Option.some.injEq, ne_eq, Option.some_ne_none, not_false_eq_true, if_true] + simpa only [eq_comm] using privateValue_history_row_hit_le (history record) (weight record) + (fun output => Pr[= some record | run output]) digest (fun output => hrows output record) (hcard record) + +theorem probEvent_samplePrivateHistoryGuess_hit_le_of_compatible + (run : HashOutput → ProbComp (Option α)) (candidate : α → Option Digest) (history : α → Finset Digest) + (hcompatible : ∀ before after record, truncateHash before ∉ history record → truncateHash after ∉ history record → + Pr[= some record | run before] = Pr[= some record | run after]) + (hreject : ∀ output record, truncateHash output ∈ history record → Pr[= some record | run output] = 0) + (hcard : ∀ record, (history record).card ≤ 2 ^ 126) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | samplePrivateHistoryGuess run candidate] ≤ + Pr[fun pair => pair.2 ≠ none | samplePrivateHistoryGuess run candidate] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + have hexists : ∀ record, ∃ digest : Digest, digest ∉ history record := by + intro record + by_contra hnone + push Not at hnone + have huniv : history record = Finset.univ := Finset.eq_univ_iff_forall.mpr hnone + have hlarge := hcard record + rw [huniv, Finset.card_univ] at hlarge + norm_num [digestBits] at hlarge + choose digest hmiss using hexists + let reference := fun record => hashOutputOfDigest (digest record) + let weight := fun record => Pr[= some record | run (reference record)] + apply probEvent_samplePrivateHistoryGuess_hit_le run candidate history weight _ hcard + intro output record + by_cases hclean : truncateHash output ∉ history record + · rw [if_pos hclean] + exact hcompatible output (reference record) record hclean (by + simpa only [reference, truncateHash_hashOutputOfDigest] using hmiss record) + · rw [if_neg hclean] + exact hreject output record (not_not.mp hclean) + +theorem privateValue_history_row_hit_eq_zero_of_mem + (history : Finset Digest) (weight : ENNReal) (likelihood : HashOutput → ENNReal) (candidate : Digest) + (hrow : ∀ output, likelihood output = if truncateHash output ∉ history then weight else 0) + (hmem : candidate ∈ history) : + (∑' output, if truncateHash output = candidate then + Pr[= output | LazyRevealProbe.sampleHashOutput] * likelihood output else 0) = 0 := by + apply ENNReal.tsum_eq_zero.mpr + intro output + by_cases heq : truncateHash output = candidate + · rw [if_pos heq, hrow] + simp [heq, hmem] + · simp [heq] + +theorem probEvent_samplePrivateHistoryGuess_hit_le_of_supported_compatible + (run : HashOutput → ProbComp (Option α)) (candidate : α → Option Digest) (history : α → Finset Digest) + (hcompatible : ∀ before after record, truncateHash before ∉ history record → truncateHash after ∉ history record → + Pr[= some record | run before] = Pr[= some record | run after]) + (hreject : ∀ output record, truncateHash output ∈ history record → Pr[= some record | run output] = 0) + (hcard : ∀ output record, some record ∈ support (run output) → (history record).card ≤ 2 ^ 126) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | samplePrivateHistoryGuess run candidate] ≤ + Pr[fun pair => pair.2 ≠ none | samplePrivateHistoryGuess run candidate] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + have hzero (record) (hlarge : ¬(history record).card ≤ 2 ^ 126) (output) : Pr[= some record | run output] = 0 := by + apply probOutput_eq_zero_of_not_mem_support + intro hsupport + exact hlarge (hcard output record hsupport) + let boundedHistory := fun record => if (history record).card ≤ 2 ^ 126 then history record else ∅ + apply probEvent_samplePrivateHistoryGuess_hit_le_of_compatible run candidate boundedHistory + · intro before after record hbefore hafter + by_cases hsmall : (history record).card ≤ 2 ^ 126 + · exact hcompatible before after record + (by simpa only [boundedHistory, if_pos hsmall] using hbefore) + (by simpa only [boundedHistory, if_pos hsmall] using hafter) + · rw [hzero record hsmall before, hzero record hsmall after] + · intro output record hmem + by_cases hsmall : (history record).card ≤ 2 ^ 126 + · exact hreject output record (by simpa only [boundedHistory, if_pos hsmall] using hmem) + · exact hzero record hsmall output + · intro record + by_cases hsmall : (history record).card ≤ 2 ^ 126 + · simpa only [boundedHistory, if_pos hsmall] using hsmall + · simp only [boundedHistory, if_neg hsmall, Finset.card_empty] + exact Nat.zero_le _ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueHistoryTracking.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueHistoryTracking.lean new file mode 100644 index 00000000..89b4ae19 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueHistoryTracking.lean @@ -0,0 +1,159 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueProbeRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def privateProbeHistoryStep (target : Position) (pending : Finset Digest) : + LazyRevealProbe.Query Coordinate → Finset Digest + | .probe coordinate digest => if coordinate = .position target then insert digest pending else pending + | _ => pending + +noncomputable def trackPrivateProbeHistory + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + Finset Digest → OracleComp (LazyRevealProbe.World Coordinate) (Finset Digest × α) := + OracleComp.construct (fun value pending => pure (pending, value)) + (fun input _ recursivelyTrack pending => + (liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= + fun reply => recursivelyTrack reply (privateProbeHistoryStep target pending input)) computation + +theorem trackPrivateProbeHistory_query_bind + (target : Position) (input : LazyRevealProbe.Query Coordinate) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) + (pending : Finset Digest) : + trackPrivateProbeHistory target ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= next) pending = + (liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= + fun reply => trackPrivateProbeHistory target (next reply) (privateProbeHistoryStep target pending input) := rfl + +theorem trackPrivateProbeHistory_erase + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (pending : Finset Digest) : + Prod.snd <$> trackPrivateProbeHistory target computation pending = computation := by + induction computation using OracleComp.inductionOn generalizing pending with + | pure value => rfl + | query_bind input next ih => + rw [trackPrivateProbeHistory_query_bind, map_bind] + exact bind_congr fun reply => ih reply _ + +theorem trackPrivateProbeHistory_query_bound + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (pending : Finset Digest) + (predicate : LazyRevealProbe.Query Coordinate → Prop) (bound : Nat) + (hbound : computation.IsQueryBoundP predicate bound) : + (trackPrivateProbeHistory target computation pending).IsQueryBoundP predicate bound := by + induction computation using OracleComp.inductionOn generalizing pending bound with + | pure value => simp [trackPrivateProbeHistory] + | query_bind input next ih => + rw [trackPrivateProbeHistory_query_bind, OracleComp.isQueryBoundP_query_bind_iff] + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + exact ⟨hbound.1, fun reply => ih reply _ _ (hbound.2 reply)⟩ + +def recordPrivateHistory (target : Position) (result : ResolvedRunResult α) : ResolvedRunResult (Finset Digest × α) := + ⟨result.context, result.remaining, (result.context.state.pendingAt (.position target), result.value), result.table⟩ + +theorem evalDist_runResolved_trackPrivateProbeHistory + (target : Position) (output : HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (pending : Finset Digest) + (h : PrivateTargetState target output pending context) + (hsafe : computation.IsQueryBoundP (IsPrivatePositionDisclosure target) 0) : + evalDist (runResolvedFromTable context fuel table (trackPrivateProbeHistory target computation pending)) = + evalDist (Option.map (recordPrivateHistory target) <$> runResolvedFromTable context fuel table computation) := by + induction computation using OracleComp.inductionOn generalizing context fuel pending with + | pure value => + change evalDist (pure (some ⟨context, fuel, (pending, value), table⟩)) = + evalDist (pure (some (recordPrivateHistory target ⟨context, fuel, value, table⟩))) + simp [recordPrivateHistory, h.2.2.2] + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hsafe + have hquery : ¬IsPrivatePositionDisclosure target query := by simpa using hsafe.1 + have hnext : ∀ reply, (next reply).IsQueryBoundP (IsPrivatePositionDisclosure target) 0 := by + intro reply + simpa using hsafe.2 reply + rw [trackPrivateProbeHistory_query_bind] + cases query with + | uniform n => + simp only [runResolvedFromTable_uniform_query_bind, map_bind, privateProbeHistoryStep] + apply evalDist_bind_congr + intro reply _ + exact ih reply context fuel pending h (hnext reply) + | hashOutput => + simp only [runResolvedFromTable_hashOutput_query_bind, map_bind, privateProbeHistoryStep] + apply evalDist_bind_congr + intro reply _ + exact ih reply context fuel pending h (hnext reply) + | ensure coordinate => + simp only [runResolvedFromTable_ensure_query_bind, privateProbeHistoryStep] + exact ih () { context with state := context.state.ensure coordinate } fuel pending h (hnext ()) + | peek coordinate => + simp only [runResolvedFromTable_peek_query_bind, privateProbeHistoryStep] + exact ih _ context fuel pending h (hnext _) + | publish coordinate => + simp only [runResolvedFromTable_publish_query_bind, privateProbeHistoryStep] + exact ih () _ fuel pending (h.publish_other coordinate hquery) (hnext ()) + | probe coordinate digest => + simp only [runResolvedFromTable_probe_query_bind, privateProbeHistoryStep] + cases fuel with + | zero => simp + | succ remaining => + dsimp only + by_cases htarget : coordinate = .position target + · subst coordinate + simp only [if_neg h.2.2.1, if_true] + exact ih () _ remaining (insert digest pending) (h.probe_target digest) (hnext ()) + · rw [if_neg htarget] + split_ifs + · exact ih () context remaining pending h (hnext ()) + · exact ih () _ remaining pending (h.probe_other coordinate digest htarget) (hnext ()) + | reveal coordinate => + simp only [runResolvedFromTable_reveal_query_bind, privateProbeHistoryStep] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [pure_bind] + cases hresolved : resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context with + | none => simp + | some middle => + have hvalues := resolveDeferredChainStart_deferred_values_eq table ⟨lay, tree, leafIdx, chainIdx⟩ context middle hresolved + exact ih middle.output _ fuel pending + (h.materialize_other _ middle.output middle.values (by simp) (hvalues ▸ h.2.1)) (hnext middle.output) + | position position => + dsimp only + simp only [map_bind] + apply evalDist_bind_congr + intro option hresolve + cases option with + | none => simp + | some middle => + have hvalue := privateValue_preserved_by_resolveDeferredReveal target position output table context middle h.1 h.2.1 hresolve + exact ih middle.output _ fuel pending (h.materialize_other _ middle.output middle.values hquery hvalue) (hnext middle.output) + + +def privateHistoryValue (target : Position) (result : Option (ResolvedRunResult α)) : Option (Nat × Finset Digest × α) := + result.map (fun record => (record.remaining, record.context.state.pendingAt (.position target), record.value)) + +theorem evalDist_runResolvedLiveValue_trackPrivateProbeHistory + (target : Position) (output : HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (pending : Finset Digest) + (h : PrivateTargetState target output pending context) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hsafe : computation.IsQueryBoundP (IsPrivatePositionDisclosure target) 0) : + evalDist (runResolvedLiveValue table context fuel (trackPrivateProbeHistory target computation pending)) = + evalDist ((fun result => privateHistoryValue target (retainCompletableResult result)) <$> + runResolvedFromTable context fuel table computation) := by + rw [evalDist_runResolvedLiveValue_eq_retained_value table context fuel _ hconsistent hstarts] + have hdist := evalDist_runResolved_trackPrivateProbeHistory target output computation context fuel table pending h hsafe + calc + _ = evalDist ((fun result => (retainCompletableResult result).map (fun result => (result.remaining, result.value))) <$> + (Option.map (recordPrivateHistory target) <$> runResolvedFromTable context fuel table computation)) := + evalDist_map_eq_of_evalDist_eq hdist _ + _ = _ := by + rw [Functor.map_map] + congr 2 + funext result + cases result with + | none => rfl + | some result => + by_cases hcomplete : DeferredCompletable result.table result.context <;> + simp [retainCompletableResult, recordPrivateHistory, privateHistoryValue, hcomplete] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueLiveCut.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueLiveCut.lean new file mode 100644 index 00000000..d047a5d6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueLiveCut.lean @@ -0,0 +1,162 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueAdaptiveSampling +import SphincsSecurity.Proof.OtsProbePrivateValueCompletion + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem retainCompletableResult_replacePrivateRunResult + (target : Position) (before after : HashOutput) (result : ResolvedRunResult α) + (hreplaceable : PrivatePositionReplaceable target before after result.context) : + retainCompletableResult (some (replacePrivateRunResult target after result)) = + (retainCompletableResult (some result)).map (replacePrivateRunResult target after) := by + have hcomplete := deferredCompletable_replacePrivatePosition_iff target before after result.context result.table hreplaceable + simp only [retainCompletableResult, replacePrivateRunResult] + rw [hcomplete] + split_ifs <;> rfl + +noncomputable def privatePositionFirstLiveCandidate + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (output : HashOutput) : ProbComp (Option Digest) := + (fun result => (privatePositionAccessCandidate target ((retainCompletableResult result).map ResolvedRunResult.value)).filter + (fun digest => digest ∉ context.state.pendingAt (.position target))) <$> + runResolvedFromTable (replacePrivatePosition target output context) fuel table (privatePositionAccessCut target computation) + +theorem evalDist_privatePositionFirstLiveCandidate_eq + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (before after : HashOutput) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (hbefore : ¬context.state.hitAt (.position target) before) (hafter : ¬context.state.hitAt (.position target) after) : + evalDist (privatePositionFirstLiveCandidate target computation context fuel table before) = + evalDist (privatePositionFirstLiveCandidate target computation context fuel table after) := by + have hreplaceable : PrivatePositionReplaceable target before after (replacePrivatePosition target before context) := + ⟨hstate, by simp [replacePrivatePosition, DeferredStructuralValues.install], hbefore, hafter⟩ + have hreplace := evalDist_runResolved_replacePrivatePosition target before after + (privatePositionAccessCut target computation) (replacePrivatePosition target before context) fuel table hreplaceable + (privatePositionAccessCut_no_exposure target before after computation) + have hdist : evalDist (runResolvedFromTable (replacePrivatePosition target after context) fuel table + (privatePositionAccessCut target computation)) = + evalDist (Option.map (replacePrivateRunResult target after) <$> + runResolvedFromTable (replacePrivatePosition target before context) fuel table + (privatePositionAccessCut target computation)) := by + simpa [replacePrivatePosition, DeferredStructuralValues.install] using hreplace + unfold privatePositionFirstLiveCandidate + symm + calc + _ = evalDist ((fun result => (privatePositionAccessCandidate target + ((retainCompletableResult result).map ResolvedRunResult.value)).filter + (fun digest => digest ∉ context.state.pendingAt (.position target))) <$> + (Option.map (replacePrivateRunResult target after) <$> + runResolvedFromTable (replacePrivatePosition target before context) fuel table + (privatePositionAccessCut target computation))) := by + rw [evalDist_map, evalDist_map, hdist] + _ = _ := by + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hinitial : PrivateTargetState target before (context.state.pendingAt (.position target)) + (replacePrivatePosition target before context) := + ⟨hstate, by simp [replacePrivatePosition, DeferredStructuralValues.install], hhidden, rfl⟩ + have hfinal := PrivateTargetState.of_mem_runResolved_no_access (privatePositionAccessCut target computation) + (replacePrivatePosition target before context) fuel table result hinitial + (privatePositionAccessCut_no_access target computation) hresult + have hbefore' : ¬result.context.state.hitAt (.position target) before := by + simpa only [LazyRevealProbe.State.hitAt, hfinal.2.2.2] using hbefore + have hafter' : ¬result.context.state.hitAt (.position target) after := by + simpa only [LazyRevealProbe.State.hitAt, hfinal.2.2.2] using hafter + have hretain := retainCompletableResult_replacePrivateRunResult target before after result + ⟨hfinal.1, hfinal.2.1, hbefore', hafter'⟩ + simp only [pure_bind, Function.comp_apply, Option.map_some, hretain, Option.map_map] + rfl + +noncomputable def privatePositionFirstLiveCharge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (output : HashOutput) : ENNReal := + ∑' result, Pr[= result | runResolvedFromTable (replacePrivatePosition target output context) fuel table + (privatePositionAccessCut target computation)] * privatePositionCutCharge target (retainCompletableResult result) + +theorem probEvent_privatePositionFirstLiveCandidate_eq_charge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (output : HashOutput) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) : + Pr[fun candidate => candidate ≠ none | privatePositionFirstLiveCandidate target computation context fuel table output] = + privatePositionFirstLiveCharge target computation context fuel table output := by + unfold privatePositionFirstLiveCandidate privatePositionFirstLiveCharge + rw [probEvent_map, probEvent_eq_tsum_ite] + apply tsum_congr + intro result + by_cases hresult : result ∈ support (runResolvedFromTable (replacePrivatePosition target output context) fuel table + (privatePositionAccessCut target computation)) + · cases result with + | none => simp [retainCompletableResult, privatePositionAccessCandidate, privatePositionCutCharge] + | some result => + by_cases hcomplete : DeferredCompletable result.table result.context + · simp only [retainCompletableResult, if_pos hcomplete] + rw [privatePositionCutCharge_eq_indicator target computation context fuel table output hstate hhidden (some result) hresult] + split_ifs <;> simp_all + · simp [retainCompletableResult, hcomplete, privatePositionAccessCandidate, privatePositionCutCharge] + · simp [probOutput_eq_zero_of_not_mem_support hresult] + +noncomputable def sampledPrivatePositionFirstLiveCandidate + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : ProbComp (HashOutput × Option Digest) := + filteredPrivateGuess (fun output => ¬context.state.hitAt (.position target) output) + (privatePositionFirstLiveCandidate target computation context fuel table) + +noncomputable def sampledPrivatePositionFirstLiveCharge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : ENNReal := + ∑' output, Pr[= output | LazyRevealProbe.sampleHashOutput] * + if ¬context.state.hitAt (.position target) output then privatePositionFirstLiveCharge target computation context fuel table output else 0 + +theorem probEvent_sampledPrivatePositionFirstLiveCandidate_eq_charge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) : + Pr[fun pair => pair.2 ≠ none | sampledPrivatePositionFirstLiveCandidate target computation context fuel table] = + sampledPrivatePositionFirstLiveCharge target computation context fuel table := by + unfold sampledPrivatePositionFirstLiveCandidate filteredPrivateGuess sampledPrivatePositionFirstLiveCharge + rw [probEvent_bind_eq_tsum] + apply tsum_congr + intro output + by_cases hclean : ¬context.state.hitAt (.position target) output + · rw [if_pos hclean, if_pos hclean] + have hmap : Pr[fun pair : HashOutput × Option Digest => pair.2 ≠ none | + privatePositionFirstLiveCandidate target computation context fuel table output >>= fun candidate => pure (output, candidate)] = + Pr[fun candidate => candidate ≠ none | privatePositionFirstLiveCandidate target computation context fuel table output] := + probEvent_bind_pure_comp (privatePositionFirstLiveCandidate target computation context fuel table output) + (fun candidate => (output, candidate)) (fun pair => pair.2 ≠ none) + rw [hmap, probEvent_privatePositionFirstLiveCandidate_eq_charge target computation context fuel table output hstate hhidden] + · simp [hclean] + +theorem probEvent_sampledPrivatePositionFirstLiveCandidate_hit_le_charge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (hcard : context.state.pending.card ≤ 2 ^ 126) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | + sampledPrivatePositionFirstLiveCandidate target computation context fuel table] ≤ + sampledPrivatePositionFirstLiveCharge target computation context fuel table * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + have hsmall : context.state.pending.card < Fintype.card Digest := hcard.trans_lt (by norm_num [digestBits]) + obtain ⟨digest, hmiss⟩ := exists_digest_not_mem_pendingAt context.state (.position target) hsmall + let reference := hashOutputOfDigest digest + have hclean : ¬context.state.hitAt (.position target) reference := by + simpa only [LazyRevealProbe.State.hitAt, reference, truncateHash_hashOutputOfDigest] using hmiss + rw [← probEvent_sampledPrivatePositionFirstLiveCandidate_eq_charge target computation context fuel table hstate hhidden] + simpa only [sampledPrivatePositionFirstLiveCandidate, show Fintype.card Digest = 2 ^ digestBits by simp] using + probEvent_filteredPrivateGuess_hit_le_four_thirds + (fun output => ¬context.state.hitAt (.position target) output) + (privatePositionFirstLiveCandidate target computation context fuel table) + (privatePositionFirstLiveCandidate target computation context fuel table reference) + (fun output houtput => evalDist_privatePositionFirstLiveCandidate_eq target computation context fuel table + output reference hstate hhidden houtput hclean) + (probEvent_no_private_pendingHit_ge_three_quarters context target hcard) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueLiveProbeCounting.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueLiveProbeCounting.lean new file mode 100644 index 00000000..38189917 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueLiveProbeCounting.lean @@ -0,0 +1,274 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueLiveProbeCut +import SphincsSecurity.Proof.OtsProbeLiveNativeReserve + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def expectedLiveResolvedQueryCharge + (charge : LazyRevealProbe.Query Coordinate → ENNReal) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → ENNReal := + OracleComp.construct (fun _ _ _ _ => 0) + (fun input _ next context fuel table => + if DeferredCompletable table context then + charge input + ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => next result.value result.context result.remaining result.table + else 0) computation + +theorem expectedLiveResolvedQueryCharge_query_bind + (charge : LazyRevealProbe.Query Coordinate → ENNReal) (input : LazyRevealProbe.Query Coordinate) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedLiveResolvedQueryCharge charge ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= next) + context fuel table = + (if DeferredCompletable table context then + charge input + ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => expectedLiveResolvedQueryCharge charge (next result.value) result.context result.remaining result.table + else 0) := rfl + +theorem expectedLiveResolvedQueryCharge_eq_zero_of_not_completable + (charge : LazyRevealProbe.Query Coordinate → ENNReal) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (hdoomed : ¬DeferredCompletable table context) : + expectedLiveResolvedQueryCharge charge computation context fuel table = 0 := by + induction computation using OracleComp.inductionOn with + | pure value => rfl + | query_bind input next _ => rw [expectedLiveResolvedQueryCharge_query_bind, if_neg hdoomed] + +noncomputable def privateLiveProbeOrdinalMass + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + Nat → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → ENNReal := + OracleComp.construct (fun _ _ _ _ _ => 0) + (fun input _ next ordinal context fuel table => + if DeferredCompletable table context then + if IsPrivatePositionDisclosure target input then 0 + else if IsPrivatePositionProbe target input ∧ ordinal = 0 then 1 + else ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => next result.value (if IsPrivatePositionProbe target input then ordinal - 1 else ordinal) + result.context result.remaining result.table + else 0) computation + +theorem privateLiveProbeOrdinalMass_query_bind + (target : Position) (input : LazyRevealProbe.Query Coordinate) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + privateLiveProbeOrdinalMass target ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= next) + ordinal context fuel table = + (if DeferredCompletable table context then + if IsPrivatePositionDisclosure target input then 0 + else if IsPrivatePositionProbe target input ∧ ordinal = 0 then 1 + else ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => privateLiveProbeOrdinalMass target (next result.value) + (if IsPrivatePositionProbe target input then ordinal - 1 else ordinal) result.context result.remaining result.table + else 0) := rfl + +theorem probEvent_livePrivateProbeCutReached_eq_ordinalMass + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + Pr[LivePrivateProbeCutReached target | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)] = + privateLiveProbeOrdinalMass target computation ordinal context fuel table := by + induction computation using OracleComp.inductionOn generalizing ordinal context fuel table with + | pure value => + by_cases hcomplete : DeferredCompletable table context <;> + simp [privatePositionProbeCutAt, runResolvedFromTable, privateLiveProbeOrdinalMass, + LivePrivateProbeCutReached, retainCompletableResult, hcomplete, PrivateProbeCutReached, privatePositionAccessCandidate] + | query_bind input next ih => + by_cases hcomplete : DeferredCompletable table context + · rw [privatePositionProbeCutAt_query_bind, privateLiveProbeOrdinalMass_query_bind, if_pos hcomplete] + by_cases hdisclose : IsPrivatePositionDisclosure target input + · rw [if_pos hdisclose, if_pos hdisclose] + cases input <;> simp [IsPrivatePositionDisclosure] at hdisclose <;> + simp [runResolvedFromTable, LivePrivateProbeCutReached, retainCompletableResult, hcomplete, + PrivateProbeCutReached, privatePositionAccessCandidate] + · rw [if_neg hdisclose, if_neg hdisclose] + have htail (n : Nat) : + Pr[LivePrivateProbeCutReached target | runResolvedFromTable context fuel table + ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= + fun reply => privatePositionProbeCutAt target (next reply) n)] = + ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => privateLiveProbeOrdinalMass target (next result.value) n result.context result.remaining result.table := by + rw [runResolvedFromTable_bind, probEvent_bind_eq_tsum] + apply tsum_congr + intro result + by_cases hresult : result ∈ support (runResolvedFromTable context fuel table (liftM (OracleSpec.query input))) + · cases result with + | none => simp [LivePrivateProbeCutReached, retainCompletableResult, PrivateProbeCutReached, privatePositionAccessCandidate] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable (liftM (OracleSpec.query input)) context fuel table result hconsistent hstarts hresult + dsimp only + rw [ih result.value n result.context result.remaining result.table hcore.2.1 (hcore.1 ▸ hcore.2.2)] + · simp [probOutput_eq_zero_of_not_mem_support hresult] + by_cases hprobe : IsPrivatePositionProbe target input + · rw [if_pos hprobe] + cases ordinal with + | zero => + simp only [hprobe, and_self, if_true] + cases input <;> simp [IsPrivatePositionProbe] at hprobe + subst_vars + simp [runResolvedFromTable, LivePrivateProbeCutReached, retainCompletableResult, hcomplete, + PrivateProbeCutReached, privatePositionAccessCandidate] + | succ ordinal => + simp only [hprobe, Nat.add_eq_zero_iff, Nat.one_ne_zero, and_false, if_false, if_true, Nat.add_sub_cancel] + rw [htail ordinal] + apply tsum_congr + intro result + cases result <;> rfl + · simp only [hprobe, false_and, if_false] + rw [htail ordinal] + apply tsum_congr + intro result + cases result <;> rfl + · rw [probEvent_livePrivateProbeCutReached_eq_zero_of_not_completable target _ context fuel table ordinal hconsistent hstarts hcomplete, + privateLiveProbeOrdinalMass_query_bind, if_neg hcomplete] + + +theorem sum_privateLiveProbeOrdinalMass_le_expectedCharge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + (∑ ordinal ∈ Finset.range q, privateLiveProbeOrdinalMass target computation ordinal context fuel table) ≤ + expectedLiveResolvedQueryCharge (privatePositionProbeQueryCharge target) computation context fuel table := by + induction computation using OracleComp.inductionOn generalizing q context fuel table with + | pure value => simp [privateLiveProbeOrdinalMass, expectedLiveResolvedQueryCharge] + | query_bind input next ih => + rw [expectedLiveResolvedQueryCharge_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete] + by_cases hdisclose : IsPrivatePositionDisclosure target input + · simp [privateLiveProbeOrdinalMass_query_bind, hcomplete, hdisclose] + · have htail (n : Nat) : + (∑ ordinal ∈ Finset.range n, ∑' result, + Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => privateLiveProbeOrdinalMass target (next result.value) ordinal result.context result.remaining result.table) ≤ + ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => expectedLiveResolvedQueryCharge (privatePositionProbeQueryCharge target) + (next result.value) result.context result.remaining result.table := by + rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + apply ENNReal.tsum_le_tsum + intro result + cases result with + | none => simp + | some result => + simp only [← Finset.mul_sum] + exact mul_le_mul' le_rfl (ih result.value n result.context result.remaining result.table) + by_cases hprobe : IsPrivatePositionProbe target input + · cases q with + | zero => simp + | succ q => + rw [Finset.sum_range_succ'] + simp only [privateLiveProbeOrdinalMass_query_bind, if_pos hcomplete, if_neg hdisclose, hprobe, Nat.add_eq_zero_iff, + Nat.one_ne_zero, and_false, if_false, Nat.add_sub_cancel, and_self, if_true, + privatePositionProbeQueryCharge] + exact (add_le_add (htail q) (le_refl 1)).trans_eq (add_comm _ _) + · simp only [privateLiveProbeOrdinalMass_query_bind, if_pos hcomplete, if_neg hdisclose, hprobe, false_and, if_false, + privatePositionProbeQueryCharge, zero_add] + exact htail q + · simp [privateLiveProbeOrdinalMass_query_bind, hcomplete] + + +theorem expectedLiveResolvedQueryCharge_mono + (left right : LazyRevealProbe.Query Coordinate → ENNReal) (hle : ∀ input, left input ≤ right input) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedLiveResolvedQueryCharge left computation context fuel table ≤ expectedLiveResolvedQueryCharge right computation context fuel table := by + induction computation using OracleComp.inductionOn generalizing context fuel table with + | pure value => rfl + | query_bind input next ih => + rw [expectedLiveResolvedQueryCharge_query_bind, expectedLiveResolvedQueryCharge_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete, if_pos hcomplete] + apply add_le_add (hle input) + apply ENNReal.tsum_le_tsum + intro result + cases result with + | none => rfl + | some result => exact mul_le_mul' le_rfl (ih result.value result.context result.remaining result.table) + · simp [hcomplete] + +theorem expectedLiveResolvedQueryCharge_finset_sum + (indices : Finset ι) (charge : ι → LazyRevealProbe.Query Coordinate → ENNReal) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedLiveResolvedQueryCharge (fun input => ∑ index ∈ indices, charge index input) computation context fuel table = + ∑ index ∈ indices, expectedLiveResolvedQueryCharge (charge index) computation context fuel table := by + induction computation using OracleComp.inductionOn generalizing context fuel table with + | pure value => simp [expectedLiveResolvedQueryCharge] + | query_bind input next ih => + by_cases hcomplete : DeferredCompletable table context + · simp only [expectedLiveResolvedQueryCharge_query_bind, if_pos hcomplete, Finset.sum_add_distrib] + congr 1 + rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + apply tsum_congr + intro result + cases result with + | none => simp + | some result => + simp only [← Finset.mul_sum] + rw [ih] + · simp [expectedLiveResolvedQueryCharge_query_bind, hcomplete] + +theorem sum_targets_livePrivateProbeCutReached_le_expectedStructuralCharge + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + (∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[LivePrivateProbeCutReached target | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)]) ≤ + expectedLiveResolvedQueryCharge structuralProbeQueryCharge computation context fuel table := by + simp_rw [probEvent_livePrivateProbeCutReached_eq_ordinalMass _ _ _ _ _ _ hconsistent hstarts] + calc + _ ≤ ∑ target ∈ targets, expectedLiveResolvedQueryCharge (privatePositionProbeQueryCharge target) computation context fuel table := + Finset.sum_le_sum (fun target _ => sum_privateLiveProbeOrdinalMass_le_expectedCharge target computation q context fuel table) + _ = expectedLiveResolvedQueryCharge (fun input => ∑ target ∈ targets, privatePositionProbeQueryCharge target input) computation context fuel table := + (expectedLiveResolvedQueryCharge_finset_sum targets privatePositionProbeQueryCharge computation context fuel table).symm + _ ≤ _ := expectedLiveResolvedQueryCharge_mono _ _ (sum_privatePositionProbeQueryCharge_le_structural targets) computation context fuel table + + +theorem sum_targets_privateResolvedRawCandidate_hit_le_expectedLiveStructuralCharge + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : ∀ target ∈ targets, .position target ∈ context.state.ensured) + (hstate : ∀ target ∈ targets, context.state.values (.position target) = none) + (hvalue : ∀ target ∈ targets, context.values target = none) + (hhidden : ∀ target ∈ targets, .position target ∉ context.state.revealed) + (hcard : ∀ target ∈ targets, (context.state.pendingAt (.position target)).card + q ≤ 2 ^ 126) : + (∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target computation ordinal)]) ≤ + expectedLiveResolvedQueryCharge structuralProbeQueryCharge computation context fuel table * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + calc + _ ≤ ∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[LivePrivateProbeCutReached target | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply Finset.sum_le_sum + intro target htarget + apply Finset.sum_le_sum + intro ordinal hordinal + apply probEvent_privateResolvedRawCandidate_hit_le_live_cut target computation context fuel table ordinal hvalid hcomplete + (hensured target htarget) (hstate target htarget) (hvalue target htarget) (hhidden target htarget) + exact (Nat.add_le_add_left (Nat.le_of_lt (Finset.mem_range.mp hordinal)) _).trans (hcard target htarget) + _ = (∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[LivePrivateProbeCutReached target | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)]) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by simp only [Finset.sum_mul] + _ ≤ _ := mul_le_mul' (sum_targets_livePrivateProbeCutReached_le_expectedStructuralCharge targets computation q context fuel table + hvalid.valuesConsistent (startTableAgrees_of_deferredCompletable hcomplete)) le_rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueLiveProbeCut.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueLiveProbeCut.lean new file mode 100644 index 00000000..139b9dd9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueLiveProbeCut.lean @@ -0,0 +1,121 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueRawProbeRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem evalDist_privateResolutionResult_eq_none_of_not_completable + (target : Position) (table : OtsSecretIndex → HashOutput) (context : DeferredContext) (fuel : Nat) (value : α) + (hconsistent : context.ValuesConsistent) (hdoomed : ¬DeferredCompletable table context) : + evalDist (privateResolutionResult target table context fuel value) = + evalDist (pure none : ProbComp (Option (DeferredContext × Nat × α))) := by + unfold privateResolutionResult + calc + _ = evalDist (resolveDeferredPositionValue target context >>= fun _ => pure none) := by + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hstillDoomed : ¬DeferredCompletable table result.toDeferredContext := by + rintro ⟨completion, hcompletion⟩ + have hback := (deferredCompletion_resolveDeferredPositionValue_iff target result hconsistent hresult completion).mp hcompletion + exact hdoomed ⟨completion, hback.1⟩ + simp [hstillDoomed] + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolveDeferredPositionValue target context) (by simp [resolveDeferredPositionValue, LazyRevealProbe.sampleHashOutput]) (pure none) + +noncomputable def LivePrivateProbeCutReached + (target : Position) (result : Option (ResolvedRunResult (PrivateValueCut α))) : Prop := + PrivateProbeCutReached target (retainCompletableResult result) + +theorem probEvent_privateResolvedRawCandidate_occurrence_le_live_cut + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + Pr[fun pair => pair ≠ none | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target computation ordinal)] ≤ + Pr[LivePrivateProbeCutReached target | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)] := by + unfold runPrivateResolvedView + rw [map_bind] + apply probEvent_bind_le_probEvent + intro result hresult hmiss + cases result with + | none => simp [privateResolvedSelectedCandidate] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable (privatePositionProbeCutAt target computation ordinal) + context fuel table result hconsistent hstarts hresult + dsimp only + by_cases hcomplete : DeferredCompletable table result.context + · have hnone : privateRawCutCandidate target result.remaining result.value = none := by + simpa only [LivePrivateProbeCutReached, retainCompletableResult, hcore.1, if_pos hcomplete, + PrivateProbeCutReached, Option.map_some, privateRawCutCandidate, not_not] using hmiss + unfold privateResolutionResult + rw [map_bind, probEvent_bind_eq_tsum] + apply ENNReal.tsum_eq_zero.mpr + intro resolved + cases resolved with + | none => simp [privateResolvedSelectedCandidate] + | some resolved => + by_cases hresolved : DeferredCompletable table resolved.toDeferredContext + · simp only [if_pos hresolved, map_pure, privateResolvedSelectedCandidate, hnone] + cases resolved.toDeferredContext.positionValue target <;> simp + · simp [hresolved, privateResolvedSelectedCandidate] + · have hdist := evalDist_privateResolutionResult_eq_none_of_not_completable target table result.context + result.remaining result.value hcore.2.1 hcomplete + have hmapped := evalDist_map_eq_of_evalDist_eq hdist (privateResolvedSelectedCandidate target (privateRawCutCandidate target)) + rw [probEvent_congr' (fun _ _ => Iff.rfl) hmapped] + simp [privateResolvedSelectedCandidate] + +theorem sampledPrivateProbeCharge_le_live_cut + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hhidden : .position target ∉ context.state.revealed) : + sampledPrivateProbeCharge target computation context fuel table ordinal ≤ + Pr[LivePrivateProbeCutReached target | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)] := + (sampledPrivateProbeCharge_le_raw_occurrence target computation context fuel table ordinal + hvalid hcomplete hensured hstate hvalue hhidden).trans + (probEvent_privateResolvedRawCandidate_occurrence_le_live_cut target computation context fuel table ordinal + hvalid.valuesConsistent (startTableAgrees_of_deferredCompletable hcomplete)) + +theorem probEvent_privateResolvedRawCandidate_hit_le_live_cut + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hhidden : .position target ∉ context.state.revealed) + (hcard : (context.state.pendingAt (.position target)).card + ordinal ≤ 2 ^ 126) : + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target computation ordinal)] ≤ + Pr[LivePrivateProbeCutReached target | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply (probEvent_privateResolvedRawCandidate_hit_le_charge target computation context fuel table ordinal + hvalid hcomplete hensured hstate hvalue hhidden hcard).trans + exact mul_le_mul' (sampledPrivateProbeCharge_le_live_cut target computation context fuel table ordinal + hvalid hcomplete hensured hstate hvalue hhidden) le_rfl + +theorem probEvent_livePrivateProbeCutReached_eq_zero_of_not_completable + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) : + Pr[LivePrivateProbeCutReached target | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)] = 0 := by + rw [probEvent_eq_zero_iff] + intro result hresult + cases result with + | none => simp [LivePrivateProbeCutReached, retainCompletableResult, PrivateProbeCutReached, privatePositionAccessCandidate] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable (privatePositionProbeCutAt target computation ordinal) context fuel table result + hconsistent hstarts hresult + have hstillDoomed := not_deferredCompletable_of_mem_runResolvedFromTable (privatePositionProbeCutAt target computation ordinal) + context fuel table result hconsistent hstarts hresult hdoomed + simp [LivePrivateProbeCutReached, retainCompletableResult, hcore.1, hstillDoomed, PrivateProbeCutReached, privatePositionAccessCandidate] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueMaterializedCommutation.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueMaterializedCommutation.lean new file mode 100644 index 00000000..178ae5a6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueMaterializedCommutation.lean @@ -0,0 +1,202 @@ +import SphincsSecurity.Proof.OtsProbeResolvedPrivateInterpreter + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem evalDist_resolveDeferredPositionValue_rebase_state + (target : Position) (table : OtsSecretIndex → HashOutput) (left right : DeferredContext) + (hview : FinalizationViewEq table left right) (hleft : left.Valid) (hright : right.Valid) + (hcomplete : DeferredCompletable table left) (hvalues : left.values = right.values) : + evalDist (Option.map (fun result : DeferredResolution => + { result with state := right.state.clearPending (.position target) }) <$> + resolveDeferredPositionValue target left) = + evalDist (resolveDeferredPositionValue target right) := by + have hbase := relTriple_resolveDeferredPositionValue_of_finalizationViewEq table target + left right hview hleft hright hcomplete + have hleftSupport := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support (resolveDeferredPositionValue target left)) (fun _ hresult => hresult) + have hboth := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupport + have hequal : RelTriple (resolveDeferredPositionValue target left) (resolveDeferredPositionValue target right) + (fun leftResult rightResult => leftResult.map (fun result : DeferredResolution => + { result with state := right.state.clearPending (.position target) }) = rightResult) := by + apply relTriple_post_mono hboth + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hrelation, hleftResult⟩, hrightResult⟩ + cases leftResult with + | none => + cases rightResult with + | none => rfl + | some rightResult => simp [FinalizationResolutionEq] at hrelation + | some leftResult => + cases rightResult with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResult => + have houtputs : leftResult.output = rightResult.output := hrelation.1 + have haux := resolveDeferredPositionValue_values_eq_of_values_eq target left right + leftResult rightResult hleftResult hrightResult hvalues houtputs + have hstate := resolveDeferredPositionValue_state_eq_clearPending target right rightResult hrightResult + cases leftResult with + | mk leftContext leftOutput => + cases rightResult with + | mk rightContext rightOutput => + cases leftContext + cases rightContext + simp_all + have hmapped := relTriple_map (R := Eq) (g := id) hequal + simpa using evalDist_eq_of_relTriple_eqRel hmapped + +theorem evalDist_resolveDeferredPositionValue_materialized_reveal + (target revealed : Position) (context : DeferredContext) + (revealedResult : DeferredResolution) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hrevealed : some revealedResult ∈ support (resolveDeferredReveal table revealed context)) : + evalDist (Option.map (fun result : DeferredResolution => + { result with state := + (context.state.clearPending (.position target)).materialize (.position revealed) revealedResult.output }) <$> + resolveDeferredPositionValue target revealedResult.toDeferredContext) = + evalDist (resolveDeferredPositionValue target (materializeResolvedPosition context revealed revealedResult)) := by + let materialized := materializeResolvedPosition context revealed revealedResult + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hrevealedValid := hvalid.of_resolveDeferredReveal table revealed revealedResult hrevealed + have hstateValues := resolveDeferredReveal_preserves_state_values table revealed context revealedResult hrevealed + have hresolved := resolveDeferredReveal_resolves table revealed context revealedResult hrevealed + have hmaterializedValid := hvalid.materializeResolvedPosition_of revealed revealedResult + hrevealedValid hstateValues hresolved + have hrevealedCompletable := hcompletable.of_resolveDeferredReveal hvalid revealed revealedResult hrevealed + have hmaterializedCompletable : DeferredCompletable table materialized := by + obtain ⟨completion, hcompletion⟩ := hrevealedCompletable + exact ⟨completion, (deferredCompletion_materializeResolvedReveal_iff revealed revealedResult hvalid + hstarts hrevealed).2 hcompletion⟩ + have hview : FinalizationViewEq table materialized revealedResult.toDeferredContext := + finalizationViewEq_materializeResolvedReveal revealed revealedResult hvalid hstarts hrevealed hmaterializedCompletable + have hdist := evalDist_resolveDeferredPositionValue_rebase_state target table revealedResult.toDeferredContext + materialized hview.symm hrevealedValid hmaterializedValid hrevealedCompletable rfl + simpa only [materialized, materializeResolvedPosition, ← clearPending_materialize_comm] using hdist + +theorem evalDist_resolveDeferredPositionValue_materialized_chainStart + (target : Position) (index : OtsSecretIndex) (context : DeferredContext) + (revealedResult : DeferredResolution) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hrevealed : resolveDeferredChainStart table index context = some revealedResult) : + evalDist (Option.map (fun result : DeferredResolution => + { result with state := + (context.state.clearPending (.position target)).materialize index.coordinate revealedResult.output }) <$> + resolveDeferredPositionValue target revealedResult.toDeferredContext) = + evalDist (resolveDeferredPositionValue target (materializeResolvedChainStart context index revealedResult)) := by + let materialized := materializeResolvedChainStart context index revealedResult + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hrevealedValid := hvalid.of_resolveDeferredChainStart table index revealedResult hrevealed + have hstateValues := resolveDeferredChainStart_state_values_eq table index context revealedResult hrevealed + have hdeferredValues := resolveDeferredChainStart_deferred_values_eq table index context revealedResult hrevealed + have hrevealedCompletable := hcompletable.of_resolveDeferredChainStart index revealedResult hrevealed + have houtput := resolveDeferredChainStart_output_of_agrees table index context revealedResult hstarts hrevealed + have hmaterializedValid : materialized.Valid := by + dsimp only [materialized] + rw [materializeResolvedChainStart, hdeferredValues] + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + exact hvalid.materialize_chainStart lay tree leafIdx chainIdx revealedResult.output + have hmaterializedCompletable : DeferredCompletable table materialized := by + obtain ⟨completion, hcompletion⟩ := hrevealedCompletable + exact ⟨completion, (deferredCompletion_materializeResolvedChainStart_iff index revealedResult hstarts + houtput hstateValues hdeferredValues + (resolveDeferredChainStart_pending_eq table index context revealedResult hrevealed)).2 hcompletion⟩ + have hview : FinalizationViewEq table materialized revealedResult.toDeferredContext := + finalizationViewEq_materializeResolvedChainStart index revealedResult hvalid hstarts hrevealed hmaterializedCompletable + have hdist := evalDist_resolveDeferredPositionValue_rebase_state target table revealedResult.toDeferredContext + materialized hview.symm hrevealedValid hmaterializedValid hrevealedCompletable rfl + simpa only [materialized, materializeResolvedChainStart, ← clearPending_materialize_comm] using hdist + +noncomputable def resolvePrivateThenMaterializedReveal + (target revealed : Position) (table : OtsSecretIndex → HashOutput) (context : DeferredContext) : + ProbComp (Option RevealedResolution) := do + let privateResult ← resolveDeferredPositionValue target context + match privateResult with + | none => pure none + | some privateResult => + let revealedResult ← resolveDeferredReveal table revealed privateResult.toDeferredContext + pure (revealedResult.map fun result => + ⟨materializeResolvedPosition privateResult.toDeferredContext revealed result, result.output⟩) + +noncomputable def resolveMaterializedRevealThenPrivate + (target revealed : Position) (table : OtsSecretIndex → HashOutput) (context : DeferredContext) : + ProbComp (Option RevealedResolution) := do + let revealedResult ← resolveDeferredReveal table revealed context + match revealedResult with + | none => pure none + | some revealedResult => + let privateResult ← resolveDeferredPositionValue target (materializeResolvedPosition context revealed revealedResult) + pure (privateResult.map fun result => ⟨result.toDeferredContext, revealedResult.output⟩) + +def materializePrivateRevealed (target revealed : Position) (context : DeferredContext) + (result : RevealedResolution) : RevealedResolution := + ⟨{ state := (context.state.clearPending (.position target)).materialize (.position revealed) result.output + values := result.context.values }, result.output⟩ + +theorem evalDist_resolvePrivateThenMaterializedReveal_eq_map + (target revealed : Position) (table : OtsSecretIndex → HashOutput) (context : DeferredContext) : + evalDist (resolvePrivateThenMaterializedReveal target revealed table context) = + evalDist (Option.map (materializePrivateRevealed target revealed context) <$> + resolvePositionThenResolver target (resolveDeferredReveal table revealed) context) := by + unfold resolvePrivateThenMaterializedReveal resolvePositionThenResolver + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro privateResult hprivate + cases privateResult with + | none => simp + | some privateResult => + have hstate := resolveDeferredPositionValue_state_eq_clearPending target context privateResult hprivate + simp only + rw [bind_assoc] + apply evalDist_bind_congr + intro revealedResult _ + cases revealedResult with + | none => rfl + | some revealedResult => + simp only [pure_bind, Function.comp_apply, Option.map_some, materializePrivateRevealed, materializeResolvedPosition] + rw [hstate] + +theorem evalDist_resolveMaterializedRevealThenPrivate_eq_map + (target revealed : Position) (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (resolveMaterializedRevealThenPrivate target revealed table context) = + evalDist (Option.map (materializePrivateRevealed target revealed context) <$> + resolveResolverThenPosition target (resolveDeferredReveal table revealed) context) := by + unfold resolveMaterializedRevealThenPrivate resolveResolverThenPosition + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro revealedResult hrevealed + cases revealedResult with + | none => simp + | some revealedResult => + have hdist := evalDist_resolveDeferredPositionValue_materialized_reveal target revealed context revealedResult table + hvalid hcompletable hrevealed + let observe := Option.map (fun result : DeferredResolution => + (⟨result.toDeferredContext, revealedResult.output⟩ : RevealedResolution)) + have hmapped : evalDist (observe <$> resolveDeferredPositionValue target + (materializeResolvedPosition context revealed revealedResult)) = + evalDist (observe <$> (Option.map (fun result : DeferredResolution => + { result with state := + (context.state.clearPending (.position target)).materialize (.position revealed) revealedResult.output }) <$> + resolveDeferredPositionValue target revealedResult.toDeferredContext)) := by + rw [evalDist_map, evalDist_map, hdist] + simp only [map_eq_bind_pure_comp, bind_assoc] at hmapped + apply hmapped.trans + simp only + rw [bind_assoc] + apply evalDist_bind_congr + intro privateResult _ + cases privateResult <;> rfl + +theorem evalDist_resolvePrivateThenMaterializedReveal + (target revealed : Position) (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (resolvePrivateThenMaterializedReveal target revealed table context) = + evalDist (resolveMaterializedRevealThenPrivate target revealed table context) := by + rw [evalDist_resolvePrivateThenMaterializedReveal_eq_map, + evalDist_resolveMaterializedRevealThenPrivate_eq_map target revealed table context hvalid hcompletable, + evalDist_map, evalDist_map] + exact congrArg _ (positionResolutionCommutes_reveal target table revealed context hvalid hcompletable) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValuePendingCleanup.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValuePendingCleanup.lean new file mode 100644 index 00000000..ef7e6210 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValuePendingCleanup.lean @@ -0,0 +1,173 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueLiveCut + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def liveValueObserve + (table : OtsSecretIndex → HashOutput) (observe : Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : α) : ProbComp Bool := + if DeferredCompletable table context then observe fuel value else pure true + +instance liveValueObserve_dooms + (table : OtsSecretIndex → HashOutput) (observe : Nat → α → ProbComp Bool) : + ObserverDooms table (liveValueObserve table observe) where + eq_true _ _ _ _ _ hdoomed := by simp [liveValueObserve, hdoomed] + +instance liveValueObserve_synchronized + (table : OtsSecretIndex → HashOutput) (observe : Nat → α → ProbComp Bool) : + ObserverSynchronized table (liveValueObserve table observe) where + eq_of_synchronized left right fuel value hcontext _ _ := by + have hleft := hcontext.2.2.2 + have hright : DeferredCompletable table right := by + obtain ⟨completion, hcompletion⟩ := hleft + exact ⟨completion, (hcontext.1.deferredCompletion_iff completion).mp hcompletion⟩ + simp [liveValueObserve, hleft, hright] + +noncomputable def runResolvedLiveValue + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : ProbComp (Option (Nat × α)) := do + let result ← runResolvedFromTable context fuel table computation + match result with + | none => pure none + | some result => + if DeferredCompletable table result.context then pure (some (result.remaining, result.value)) else pure none + +theorem runResolvedLiveValue_observe_eq + (table : OtsSecretIndex → HashOutput) (test : Option (Nat × α) → Bool) (htest : test none = true) + (context : DeferredContext) (fuel : Nat) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + runResolvedObserve (liveValueObserve table (fun remaining value => pure (test (some (remaining, value))))) + context fuel table computation = test <$> runResolvedLiveValue table context fuel computation := by + unfold runResolvedObserve runResolvedLiveValue + rw [map_bind] + apply bind_congr + intro result + cases result with + | none => simp [finishObserve, htest] + | some result => + by_cases hcomplete : DeferredCompletable table result.context <;> simp [finishObserve, liveValueObserve, hcomplete, htest] + +theorem evalDist_runResolvedLiveValue_of_finalizationSynchronized + (table : OtsSecretIndex → HashOutput) (left right : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) (hrevealed : left.state.revealed = right.state.revealed) : + evalDist (runResolvedLiveValue table left fuel computation) = evalDist (runResolvedLiveValue table right fuel computation) := by + apply evalDist_eq_of_bool_tests_none + intro test htest + rw [← runResolvedLiveValue_observe_eq table test htest, ← runResolvedLiveValue_observe_eq table test htest] + exact evalDist_runResolvedObserve_eq_of_finalizationSynchronized computation left right fuel table hcontext hvalues hrevealed + +theorem finalizationViewEq_clearPending_known + (target : Position) (output : HashOutput) (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hknown : context.positionValue target = some output) : + FinalizationViewEq table context { context with state := context.state.clearPending (.position target) } := by + have hstarts := startTableAgrees_of_deferredCompletable hcomplete + obtain ⟨completion, hcompletion⟩ := hcomplete + have hclean := clean_of_deferredCompletion hcompletion + refine ⟨hvalid.valuesConsistent, (hvalid.clearPending (.position target)).valuesConsistent, + hstarts, hstarts, rfl, hclean, ?_, ?_⟩ + · intro coordinate value hvalue + by_cases heq : coordinate = .position target + · subst coordinate + exact not_hitAt_clearPending_self context.state (.position target) value + · exact (hitAt_clearPending_of_ne context.state (.position target) coordinate value heq).not.mpr + (hclean coordinate value hvalue) + · intro coordinate hvalue + have hne : coordinate ≠ .position target := by + intro heq + subst coordinate + change context.positionValue target = none at hvalue + rw [hknown] at hvalue + contradiction + exact (pendingAt_clearPending_of_ne context.state (.position target) coordinate hne).symm + +theorem evalDist_runResolvedLiveValue_clearPending_known + (target : Position) (output : HashOutput) (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (fuel : Nat) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hknown : context.positionValue target = some output) : + evalDist (runResolvedLiveValue table context fuel computation) = + evalDist (runResolvedLiveValue table { context with state := context.state.clearPending (.position target) } fuel computation) := by + apply evalDist_runResolvedLiveValue_of_finalizationSynchronized + · exact ⟨finalizationViewEq_clearPending_known target output table context hvalid hcomplete hknown, + hvalid, hvalid.clearPending (.position target), hcomplete⟩ + · rfl + · rfl + +theorem DeferredContext.Valid.replacePrivatePosition + {context : DeferredContext} (hvalid : context.Valid) (target : Position) (output : HashOutput) + (hstate : context.state.values (.position target) = none) : + (replacePrivatePosition target output context).Valid := by + refine ⟨?_, hvalid.2⟩ + intro position value hvalue + change context.state.values (.position position) = some value at hvalue + by_cases heq : position = target + · subst position + simp [hstate] at hvalue + · change Function.update context.values target (some output) position = some value + rw [Function.update_of_ne heq] + exact hvalid.1 position value hvalue + +theorem evalDist_runResolvedLiveValue_eq_retained_value + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + evalDist (runResolvedLiveValue table context fuel computation) = + evalDist ((fun result => (retainCompletableResult result).map (fun result => (result.remaining, result.value))) <$> + runResolvedFromTable context fuel table computation) := by + unfold runResolvedLiveValue + rw [map_eq_bind_pure_comp] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable computation context fuel table result hconsistent hstarts hresult + by_cases hcomplete : DeferredCompletable table result.context <;> simp [retainCompletableResult, hcore.1, hcomplete] + +def privateLiveCandidateProjection (target : Position) (pending : Finset Digest) : + Option (Nat × PrivateValueCut α) → Option Digest := + fun result => (privatePositionAccessCandidate target (result.map Prod.snd)).filter (fun digest => digest ∉ pending) + +theorem evalDist_privatePositionFirstLiveCandidate_eq_projection + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (output : HashOutput) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hstate : context.state.values (.position target) = none) : + evalDist (privatePositionFirstLiveCandidate target computation context fuel table output) = + evalDist (privateLiveCandidateProjection target (context.state.pendingAt (.position target)) <$> + runResolvedLiveValue table (replacePrivatePosition target output context) fuel (privatePositionAccessCut target computation)) := by + have hnewValid := hvalid.replacePrivatePosition target output hstate + have hstarts := startTableAgrees_of_deferredCompletable hcomplete + have hdist := evalDist_runResolvedLiveValue_eq_retained_value table (replacePrivatePosition target output context) fuel + (privatePositionAccessCut target computation) hnewValid.valuesConsistent hstarts + unfold privatePositionFirstLiveCandidate + rw [evalDist_map, evalDist_map, hdist, evalDist_map, Functor.map_map] + congr 1 + funext result + unfold privateLiveCandidateProjection + cases retainCompletableResult result <;> rfl + +theorem evalDist_privatePositionFirstLiveCandidate_clearPending + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (output : HashOutput) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hstate : context.state.values (.position target) = none) (hclean : ¬context.state.hitAt (.position target) output) : + evalDist (privatePositionFirstLiveCandidate target computation context fuel table output) = + evalDist (privateLiveCandidateProjection target (context.state.pendingAt (.position target)) <$> + runResolvedLiveValue table (completePrivatePosition target context output).toDeferredContext fuel + (privatePositionAccessCut target computation)) := by + rw [evalDist_privatePositionFirstLiveCandidate_eq_projection target computation context fuel table output hvalid hcomplete hstate, + evalDist_map, evalDist_map] + apply congrArg _ + exact evalDist_runResolvedLiveValue_clearPending_known target output table (replacePrivatePosition target output context) fuel + (privatePositionAccessCut target computation) (hvalid.replacePrivatePosition target output hstate) + (hcomplete.replacePrivatePosition target output hstate hclean) + (by simp [replacePrivatePosition, DeferredContext.positionValue, hstate, DeferredStructuralValues.install]) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueProbeCounting.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueProbeCounting.lean new file mode 100644 index 00000000..be3a89f8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueProbeCounting.lean @@ -0,0 +1,313 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueRawProbeRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def expectedResolvedQueryCharge + (charge : LazyRevealProbe.Query Coordinate → ENNReal) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → ENNReal := + OracleComp.construct (fun _ _ _ _ => 0) + (fun input _ next context fuel table => + charge input + ∑' result, + Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => next result.value result.context result.remaining result.table) computation + +theorem expectedResolvedQueryCharge_query_bind + (charge : LazyRevealProbe.Query Coordinate → ENNReal) (input : LazyRevealProbe.Query Coordinate) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedResolvedQueryCharge charge ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= next) + context fuel table = charge input + ∑' result, + Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => expectedResolvedQueryCharge charge (next result.value) result.context result.remaining result.table := rfl + +noncomputable def privateProbeOrdinalMass + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + Nat → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → ENNReal := + OracleComp.construct (fun _ _ _ _ _ => 0) + (fun input _ next ordinal context fuel table => + if IsPrivatePositionDisclosure target input then 0 + else if IsPrivatePositionProbe target input ∧ ordinal = 0 then 1 + else ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => next result.value (if IsPrivatePositionProbe target input then ordinal - 1 else ordinal) + result.context result.remaining result.table) computation + +theorem privateProbeOrdinalMass_query_bind + (target : Position) (input : LazyRevealProbe.Query Coordinate) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + privateProbeOrdinalMass target ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= next) + ordinal context fuel table = + (if IsPrivatePositionDisclosure target input then 0 + else if IsPrivatePositionProbe target input ∧ ordinal = 0 then 1 + else ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => privateProbeOrdinalMass target (next result.value) + (if IsPrivatePositionProbe target input then ordinal - 1 else ordinal) result.context result.remaining result.table) := rfl + +theorem probEvent_privateProbeCutReached_eq_ordinalMass + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + Pr[PrivateProbeCutReached target | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)] = + privateProbeOrdinalMass target computation ordinal context fuel table := by + induction computation using OracleComp.inductionOn generalizing ordinal context fuel table with + | pure value => simp [privatePositionProbeCutAt, runResolvedFromTable, privateProbeOrdinalMass, + PrivateProbeCutReached, privatePositionAccessCandidate] + | query_bind input next ih => + rw [privatePositionProbeCutAt_query_bind, privateProbeOrdinalMass_query_bind] + by_cases hdisclose : IsPrivatePositionDisclosure target input + · rw [if_pos hdisclose, if_pos hdisclose] + cases input <;> simp [IsPrivatePositionDisclosure] at hdisclose <;> + simp [runResolvedFromTable, PrivateProbeCutReached, privatePositionAccessCandidate] + · rw [if_neg hdisclose, if_neg hdisclose] + have htail (n : Nat) : + Pr[PrivateProbeCutReached target | runResolvedFromTable context fuel table + ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= + fun reply => privatePositionProbeCutAt target (next reply) n)] = + ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => privateProbeOrdinalMass target (next result.value) n result.context result.remaining result.table := by + rw [runResolvedFromTable_bind, probEvent_bind_eq_tsum] + apply tsum_congr + intro result + cases result with + | none => simp [PrivateProbeCutReached, privatePositionAccessCandidate] + | some result => simp only [ih] + by_cases hprobe : IsPrivatePositionProbe target input + · rw [if_pos hprobe] + cases ordinal with + | zero => + simp only [hprobe, and_self, if_true] + cases input <;> simp [IsPrivatePositionProbe] at hprobe + subst_vars + simp [runResolvedFromTable, PrivateProbeCutReached, privatePositionAccessCandidate] + | succ ordinal => + simp only [hprobe, Nat.add_eq_zero_iff, Nat.one_ne_zero, and_false, if_false, if_true, Nat.add_sub_cancel] + rw [htail ordinal] + apply tsum_congr + intro result + cases result <;> rfl + · simp only [hprobe, false_and, if_false] + rw [htail ordinal] + apply tsum_congr + intro result + cases result <;> rfl + +noncomputable def privatePositionProbeQueryCharge (target : Position) (input : LazyRevealProbe.Query Coordinate) : ENNReal := + if IsPrivatePositionProbe target input then 1 else 0 + +theorem sum_privateProbeOrdinalMass_le_expectedCharge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + (∑ ordinal ∈ Finset.range q, privateProbeOrdinalMass target computation ordinal context fuel table) ≤ + expectedResolvedQueryCharge (privatePositionProbeQueryCharge target) computation context fuel table := by + induction computation using OracleComp.inductionOn generalizing q context fuel table with + | pure value => simp [privateProbeOrdinalMass, expectedResolvedQueryCharge] + | query_bind input next ih => + rw [expectedResolvedQueryCharge_query_bind] + by_cases hdisclose : IsPrivatePositionDisclosure target input + · simp [privateProbeOrdinalMass_query_bind, hdisclose] + · have htail (n : Nat) : + (∑ ordinal ∈ Finset.range n, ∑' result, + Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => privateProbeOrdinalMass target (next result.value) ordinal result.context result.remaining result.table) ≤ + ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => expectedResolvedQueryCharge (privatePositionProbeQueryCharge target) + (next result.value) result.context result.remaining result.table := by + rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + apply ENNReal.tsum_le_tsum + intro result + cases result with + | none => simp + | some result => + simp only [← Finset.mul_sum] + exact mul_le_mul' le_rfl (ih result.value n result.context result.remaining result.table) + by_cases hprobe : IsPrivatePositionProbe target input + · cases q with + | zero => simp + | succ q => + rw [Finset.sum_range_succ'] + simp only [privateProbeOrdinalMass_query_bind, if_neg hdisclose, hprobe, Nat.add_eq_zero_iff, + Nat.one_ne_zero, and_false, if_false, Nat.add_sub_cancel, and_self, if_true, + privatePositionProbeQueryCharge] + exact (add_le_add (htail q) (le_refl 1)).trans_eq (add_comm _ _) + · simp only [privateProbeOrdinalMass_query_bind, if_neg hdisclose, hprobe, false_and, if_false, + privatePositionProbeQueryCharge, zero_add] + exact htail q + +theorem sum_probEvent_privateProbeCutReached_le_expectedCharge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + (∑ ordinal ∈ Finset.range q, + Pr[PrivateProbeCutReached target | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)]) ≤ + expectedResolvedQueryCharge (privatePositionProbeQueryCharge target) computation context fuel table := by + simp_rw [probEvent_privateProbeCutReached_eq_ordinalMass] + exact sum_privateProbeOrdinalMass_le_expectedCharge target computation q context fuel table + + +theorem expectedResolvedQueryCharge_mono + (left right : LazyRevealProbe.Query Coordinate → ENNReal) (hle : ∀ input, left input ≤ right input) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedResolvedQueryCharge left computation context fuel table ≤ expectedResolvedQueryCharge right computation context fuel table := by + induction computation using OracleComp.inductionOn generalizing context fuel table with + | pure value => rfl + | query_bind input next ih => + rw [expectedResolvedQueryCharge_query_bind, expectedResolvedQueryCharge_query_bind] + apply add_le_add (hle input) + apply ENNReal.tsum_le_tsum + intro result + cases result with + | none => rfl + | some result => exact mul_le_mul' le_rfl (ih result.value result.context result.remaining result.table) + +theorem expectedResolvedQueryCharge_finset_sum + (indices : Finset ι) (charge : ι → LazyRevealProbe.Query Coordinate → ENNReal) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedResolvedQueryCharge (fun input => ∑ index ∈ indices, charge index input) computation context fuel table = + ∑ index ∈ indices, expectedResolvedQueryCharge (charge index) computation context fuel table := by + induction computation using OracleComp.inductionOn generalizing context fuel table with + | pure value => simp [expectedResolvedQueryCharge] + | query_bind input next ih => + simp only [expectedResolvedQueryCharge_query_bind, Finset.sum_add_distrib] + congr 1 + rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + apply tsum_congr + intro result + cases result with + | none => simp + | some result => + simp only [← Finset.mul_sum] + rw [ih] + +noncomputable def structuralProbeQueryCharge : LazyRevealProbe.Query Coordinate → ENNReal + | .probe (.position _) _ => 1 + | _ => 0 + +theorem sum_privatePositionProbeQueryCharge_le_structural + (targets : Finset Position) (input : LazyRevealProbe.Query Coordinate) : + (∑ target ∈ targets, privatePositionProbeQueryCharge target input) ≤ structuralProbeQueryCharge input := by + cases input with + | uniform n => simp [privatePositionProbeQueryCharge, IsPrivatePositionProbe, structuralProbeQueryCharge] + | hashOutput => simp [privatePositionProbeQueryCharge, IsPrivatePositionProbe, structuralProbeQueryCharge] + | ensure coordinate => simp [privatePositionProbeQueryCharge, IsPrivatePositionProbe, structuralProbeQueryCharge] + | peek coordinate => simp [privatePositionProbeQueryCharge, IsPrivatePositionProbe, structuralProbeQueryCharge] + | publish coordinate => simp [privatePositionProbeQueryCharge, IsPrivatePositionProbe, structuralProbeQueryCharge] + | reveal coordinate => simp [privatePositionProbeQueryCharge, IsPrivatePositionProbe, structuralProbeQueryCharge] + | probe coordinate digest => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => simp [privatePositionProbeQueryCharge, IsPrivatePositionProbe, structuralProbeQueryCharge] + | position position => + simp only [privatePositionProbeQueryCharge, IsPrivatePositionProbe, Coordinate.position.injEq, structuralProbeQueryCharge] + rw [Finset.sum_ite_eq] + split_ifs <;> simp + +theorem sum_targets_privateProbeCutReached_le_expectedStructuralCharge + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + (∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateProbeCutReached target | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)]) ≤ + expectedResolvedQueryCharge structuralProbeQueryCharge computation context fuel table := by + calc + _ ≤ ∑ target ∈ targets, expectedResolvedQueryCharge (privatePositionProbeQueryCharge target) computation context fuel table := + Finset.sum_le_sum (fun target _ => sum_probEvent_privateProbeCutReached_le_expectedCharge target computation q context fuel table) + _ = expectedResolvedQueryCharge (fun input => ∑ target ∈ targets, privatePositionProbeQueryCharge target input) computation context fuel table := + (expectedResolvedQueryCharge_finset_sum targets privatePositionProbeQueryCharge computation context fuel table).symm + _ ≤ _ := expectedResolvedQueryCharge_mono _ _ (sum_privatePositionProbeQueryCharge_le_structural targets) computation context fuel table + + +theorem expectedResolvedQueryCharge_le_queryBound + (charge : LazyRevealProbe.Query Coordinate → ENNReal) (predicate : LazyRevealProbe.Query Coordinate → Prop) [DecidablePred predicate] + (hcharge : ∀ input, charge input ≤ if predicate input then 1 else 0) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (bound : Nat) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hbound : computation.IsQueryBoundP predicate bound) : + expectedResolvedQueryCharge charge computation context fuel table ≤ bound := by + induction computation using OracleComp.inductionOn generalizing bound context fuel table with + | pure value => simp [expectedResolvedQueryCharge] + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [expectedResolvedQueryCharge_query_bind] + let remaining := if predicate input then bound - 1 else bound + have htail : + (∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => expectedResolvedQueryCharge charge (next result.value) result.context result.remaining result.table) ≤ remaining := by + calc + _ ≤ ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * (remaining : ENNReal) := by + apply ENNReal.tsum_le_tsum + intro result + apply mul_le_mul' le_rfl + cases result with + | none => exact bot_le + | some result => exact ih result.value remaining result.context result.remaining result.table (hbound.2 result.value) + _ = _ := by + rw [ENNReal.tsum_mul_right, tsum_probOutput_eq_one' (by simp [runResolvedFromTable]), one_mul] + apply (add_le_add (hcharge input) htail).trans + by_cases hquery : predicate input + · have hpositive : 0 < bound := hbound.1.resolve_left (not_not.mpr hquery) + cases bound with + | zero => omega + | succ bound => simp [remaining, hquery, Nat.cast_add, add_comm] + · simp [remaining, hquery] + +theorem expectedResolvedStructuralCharge_le_probeBound + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (bound : Nat) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) : + expectedResolvedQueryCharge structuralProbeQueryCharge computation context fuel table ≤ bound := by + apply expectedResolvedQueryCharge_le_queryBound structuralProbeQueryCharge LazyRevealProbe.IsProbe _ computation bound context fuel table hbound + intro input + cases input <;> simp [structuralProbeQueryCharge, LazyRevealProbe.IsProbe] + split <;> simp + +theorem sum_targets_privateResolvedRawCandidate_hit_le_expectedStructuralCharge + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : ∀ target ∈ targets, .position target ∈ context.state.ensured) + (hstate : ∀ target ∈ targets, context.state.values (.position target) = none) + (hvalue : ∀ target ∈ targets, context.values target = none) + (hhidden : ∀ target ∈ targets, .position target ∉ context.state.revealed) + (hcard : ∀ target ∈ targets, (context.state.pendingAt (.position target)).card + q ≤ 2 ^ 126) : + (∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target computation ordinal)]) ≤ + expectedResolvedQueryCharge structuralProbeQueryCharge computation context fuel table * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + calc + _ ≤ ∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateProbeCutReached target | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply Finset.sum_le_sum + intro target htarget + apply Finset.sum_le_sum + intro ordinal hordinal + apply probEvent_privateResolvedRawCandidate_hit_le_cut_reached target computation context fuel table ordinal hvalid hcomplete + (hensured target htarget) (hstate target htarget) (hvalue target htarget) (hhidden target htarget) + exact (Nat.add_le_add_left (Nat.le_of_lt (Finset.mem_range.mp hordinal)) _).trans (hcard target htarget) + _ = (∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateProbeCutReached target | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)]) * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by simp only [Finset.sum_mul] + _ ≤ _ := mul_le_mul' (sum_targets_privateProbeCutReached_le_expectedStructuralCharge targets computation q context fuel table) le_rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueProbeCut.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueProbeCut.lean new file mode 100644 index 00000000..8f5314a9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueProbeCut.lean @@ -0,0 +1,114 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueHistoryRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def IsPrivatePositionDisclosure (target : Position) : LazyRevealProbe.Query Coordinate → Prop + | .reveal coordinate | .publish coordinate => coordinate = .position target + | _ => False + +def IsPrivatePositionProbe (target : Position) : LazyRevealProbe.Query Coordinate → Prop + | .probe coordinate _ => coordinate = .position target + | _ => False + +noncomputable def privatePositionProbeCutAt + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + Nat → OracleComp (LazyRevealProbe.World Coordinate) (PrivateValueCut α) := + OracleComp.construct (fun value _ => pure (.done value)) + (fun input next recursivelyCut ordinal => + if IsPrivatePositionDisclosure target input then pure (.query input next) + else if IsPrivatePositionProbe target input then + match ordinal with + | 0 => pure (.query input next) + | ordinal + 1 => (liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= + fun output => recursivelyCut output ordinal + else (liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= + fun output => recursivelyCut output ordinal) computation + +theorem privatePositionProbeCutAt_query_bind + (target : Position) (input : LazyRevealProbe.Query Coordinate) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) (ordinal : Nat) : + privatePositionProbeCutAt target ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= next) ordinal = + (if IsPrivatePositionDisclosure target input then pure (.query input next) + else if IsPrivatePositionProbe target input then + match ordinal with + | 0 => pure (.query input next) + | ordinal + 1 => (liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= + fun output => privatePositionProbeCutAt target (next output) ordinal + else (liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= + fun output => privatePositionProbeCutAt target (next output) ordinal) := rfl + +theorem privatePositionProbeCutAt_resume + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (ordinal : Nat) : + privatePositionProbeCutAt target computation ordinal >>= PrivateValueCut.resume = computation := by + induction computation using OracleComp.inductionOn generalizing ordinal with + | pure value => rfl + | query_bind input next ih => + rw [privatePositionProbeCutAt_query_bind] + split_ifs + · rfl + · cases ordinal with + | zero => rfl + | succ ordinal => + rw [bind_assoc] + exact bind_congr fun output => ih output ordinal + · rw [bind_assoc] + exact bind_congr fun output => ih output ordinal + +theorem privatePositionProbeCutAt_no_disclosure + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (ordinal : Nat) : + (privatePositionProbeCutAt target computation ordinal).IsQueryBoundP (IsPrivatePositionDisclosure target) 0 := by + induction computation using OracleComp.inductionOn generalizing ordinal with + | pure value => simp [privatePositionProbeCutAt] + | query_bind input next ih => + rw [privatePositionProbeCutAt_query_bind] + split_ifs with hdisclose hprobe + · simp + · cases ordinal with + | zero => simp + | succ ordinal => + rw [OracleComp.isQueryBoundP_query_bind_iff] + exact ⟨Or.inl hdisclose, fun output => by simpa only [if_neg hdisclose] using ih output ordinal⟩ + · rw [OracleComp.isQueryBoundP_query_bind_iff] + exact ⟨Or.inl hdisclose, fun output => by simpa only [if_neg hdisclose] using ih output ordinal⟩ + +theorem privatePositionProbeCutAt_probe_bound + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (ordinal : Nat) : + (privatePositionProbeCutAt target computation ordinal).IsQueryBoundP (IsPrivatePositionProbe target) ordinal := by + induction computation using OracleComp.inductionOn generalizing ordinal with + | pure value => simp [privatePositionProbeCutAt] + | query_bind input next ih => + rw [privatePositionProbeCutAt_query_bind] + split_ifs with hdisclose hprobe + · simp + · cases ordinal with + | zero => simp + | succ ordinal => + rw [OracleComp.isQueryBoundP_query_bind_iff] + exact ⟨Or.inr (by omega), fun output => by simpa only [if_pos hprobe, Nat.add_sub_cancel] using ih output ordinal⟩ + · rw [OracleComp.isQueryBoundP_query_bind_iff] + exact ⟨Or.inl hprobe, fun output => by simpa only [if_neg hprobe] using ih output ordinal⟩ + +theorem privatePositionProbeCutAt_zero + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + privatePositionProbeCutAt target computation 0 = privatePositionAccessCut target computation := by + induction computation using OracleComp.inductionOn with + | pure value => rfl + | query_bind input next ih => + rw [privatePositionProbeCutAt_query_bind, privatePositionAccessCut_query_bind] + have haccess : IsPrivatePositionAccess target input ↔ + IsPrivatePositionDisclosure target input ∨ IsPrivatePositionProbe target input := by + cases input <;> simp [IsPrivatePositionAccess, IsPrivatePositionDisclosure, IsPrivatePositionProbe] + rw [propext haccess] + by_cases hdisclose : IsPrivatePositionDisclosure target input + · simp [hdisclose] + · by_cases hprobe : IsPrivatePositionProbe target input + · simp [hdisclose, hprobe] + · simp only [if_neg hdisclose, if_neg hprobe, if_neg (not_or.mpr ⟨hdisclose, hprobe⟩)] + exact bind_congr ih + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueProbeHistory.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueProbeHistory.lean new file mode 100644 index 00000000..3397f77d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueProbeHistory.lean @@ -0,0 +1,140 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueProbeCut + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem PrivateTargetState.probe_target + {target : Position} {output : HashOutput} {pending : Finset Digest} {context : DeferredContext} + (h : PrivateTargetState target output pending context) (digest : Digest) : + PrivateTargetState target output (insert digest pending) + { context with state := context.state.addPending (.position target) digest } := by + refine ⟨h.1, h.2.1, h.2.2.1, ?_⟩ + rw [← h.2.2.2] + ext candidate + simp [LazyRevealProbe.State.mem_pendingAt_iff, LazyRevealProbe.State.addPending] + +theorem PrivateTargetState.history_of_mem_runResolved + {target : Position} {output : HashOutput} + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (pending : Finset Digest) (bound : Nat) (result : ResolvedRunResult α) + (h : PrivateTargetState target output pending context) + (hsafe : computation.IsQueryBoundP (IsPrivatePositionDisclosure target) 0) + (hcount : computation.IsQueryBoundP (IsPrivatePositionProbe target) bound) + (hresult : some result ∈ support (runResolvedFromTable context fuel table computation)) : + PrivateTargetState target output (result.context.state.pendingAt (.position target)) result.context ∧ + pending ⊆ result.context.state.pendingAt (.position target) ∧ + (result.context.state.pendingAt (.position target)).card ≤ pending.card + bound := by + induction computation using OracleComp.inductionOn generalizing context fuel pending bound with + | pure value => + simp [runResolvedFromTable] at hresult + subst result + simpa only [h.2.2.2] using And.intro h (And.intro (Finset.Subset.refl pending) (Nat.le_add_right pending.card bound)) + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hsafe hcount + have hquery : ¬IsPrivatePositionDisclosure target query := by simpa using hsafe.1 + have hnext : ∀ reply, (next reply).IsQueryBoundP (IsPrivatePositionDisclosure target) 0 := by + intro reply + simpa using hsafe.2 reply + cases query with + | uniform n => + rw [runResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨reply, _, htail⟩ := hresult + exact ih reply context fuel pending bound h (hnext reply) + (by simpa [IsPrivatePositionProbe] using hcount.2 reply) htail + | hashOutput => + rw [runResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨reply, _, htail⟩ := hresult + exact ih reply context fuel pending bound h (hnext reply) + (by simpa [IsPrivatePositionProbe] using hcount.2 reply) htail + | ensure coordinate => + rw [runResolvedFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel pending bound h (hnext ()) + (by simpa [IsPrivatePositionProbe] using hcount.2 ()) hresult + | peek coordinate => + rw [runResolvedFromTable_peek_query_bind] at hresult + exact ih _ context fuel pending bound h (hnext _) + (by simpa [IsPrivatePositionProbe] using hcount.2 _) hresult + | publish coordinate => + rw [runResolvedFromTable_publish_query_bind] at hresult + exact ih () _ fuel pending bound (h.publish_other coordinate hquery) (hnext ()) + (by simpa [IsPrivatePositionProbe] using hcount.2 ()) hresult + | probe coordinate digest => + rw [runResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + dsimp only at hresult + by_cases htarget : coordinate = .position target + · subst coordinate + cases bound with + | zero => simpa [IsPrivatePositionProbe] using hcount.1 + | succ bound => + rw [if_neg h.2.2.1] at hresult + have htail := ih () _ remaining (insert digest pending) bound (h.probe_target digest) (hnext ()) + (by simpa [IsPrivatePositionProbe] using hcount.2 ()) hresult + refine ⟨htail.1, ?_, ?_⟩ + · exact (Finset.subset_insert digest pending).trans htail.2.1 + · have hcard := Finset.card_insert_le digest pending + have htailCard := htail.2.2 + omega + · have hbound : (next ()).IsQueryBoundP (IsPrivatePositionProbe target) bound := by + simpa [IsPrivatePositionProbe, htarget] using hcount.2 () + split_ifs at hresult + · exact ih () context remaining pending bound h (hnext ()) hbound hresult + · exact ih () _ remaining pending bound (h.probe_other coordinate digest htarget) (hnext ()) hbound hresult + | reveal coordinate => + have hbound (reply) : (next reply).IsQueryBoundP (IsPrivatePositionProbe target) bound := by + simpa [IsPrivatePositionProbe] using hcount.2 reply + rw [runResolvedFromTable_reveal_query_bind] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [pure_bind] at hresult + cases hresolved : resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context with + | none => simp [hresolved] at hresult + | some middle => + simp only [hresolved] at hresult + have hvalues := resolveDeferredChainStart_deferred_values_eq table ⟨lay, tree, leafIdx, chainIdx⟩ context middle hresolved + exact ih middle.output _ fuel pending bound + (h.materialize_other _ middle.output middle.values (by simp) (hvalues ▸ h.2.1)) + (hnext middle.output) (hbound middle.output) hresult + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨option, hresolve, htail⟩ := hresult + cases option with + | none => simp at htail + | some middle => + have hvalue := privateValue_preserved_by_resolveDeferredReveal target position output table context middle h.1 h.2.1 hresolve + exact ih middle.output _ fuel pending bound (h.materialize_other _ middle.output middle.values hquery hvalue) + (hnext middle.output) (hbound middle.output) htail + +theorem privatePositionProbeCutAt_history_bound + (target : Position) (output : HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (pending : Finset Digest) (ordinal : Nat) + (h : PrivateTargetState target output pending context) (result : ResolvedRunResult (PrivateValueCut α)) + (hresult : some result ∈ support (runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal))) : + PrivateTargetState target output (result.context.state.pendingAt (.position target)) result.context ∧ + pending ⊆ result.context.state.pendingAt (.position target) ∧ + (result.context.state.pendingAt (.position target)).card ≤ pending.card + ordinal := + h.history_of_mem_runResolved (privatePositionProbeCutAt target computation ordinal) context fuel table pending ordinal result + (privatePositionProbeCutAt_no_disclosure target computation ordinal) (privatePositionProbeCutAt_probe_bound target computation ordinal) hresult + +theorem privatePositionProbeCutAt_live_history_avoids_output + (target : Position) (output : HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (pending : Finset Digest) (ordinal : Nat) + (h : PrivateTargetState target output pending context) (result : ResolvedRunResult (PrivateValueCut α)) + (hresult : some result ∈ support (runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal))) + (hcomplete : DeferredCompletable table result.context) : + truncateHash output ∉ result.context.state.pendingAt (.position target) := by + have hfinal := (privatePositionProbeCutAt_history_bound target output computation context fuel table pending ordinal h result hresult).1 + obtain ⟨completion, hcompletion⟩ := hcomplete + have houtput := hcompletion.2.1 target output hfinal.2.1 + intro hmem + have hpending := (LazyRevealProbe.State.mem_pendingAt_iff result.context.state (.position target) (truncateHash output)).mp hmem + exact hcompletion.2.2.1 (.position target) (truncateHash output) hpending (by rw [houtput]) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueProbeRecords.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueProbeRecords.lean new file mode 100644 index 00000000..7fd3d543 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueProbeRecords.lean @@ -0,0 +1,90 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueProbeHistory + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def privateRecordedResult (target : Position) (result : Option (ResolvedRunResult α)) : + Option (ResolvedRunResult α) := + (retainCompletableResult result).map (replacePrivateRunResult target 0) + +noncomputable def runPrivateRecords + (target : Position) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : ProbComp (Option (ResolvedRunResult α)) := + privateRecordedResult target <$> runResolvedFromTable context fuel table computation + +theorem mem_support_runPrivateRecords_iff + (target : Position) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (record : ResolvedRunResult α) : + some record ∈ support (runPrivateRecords target context fuel table computation) ↔ + ∃ result, some result ∈ support (runResolvedFromTable context fuel table computation) ∧ + DeferredCompletable result.table result.context ∧ record = replacePrivateRunResult target 0 result := by + unfold runPrivateRecords + rw [support_map, Set.mem_image] + constructor + · rintro ⟨result, hresult, heq⟩ + cases result with + | none => simp [privateRecordedResult, retainCompletableResult] at heq + | some result => + by_cases hcomplete : DeferredCompletable result.table result.context + · simp only [privateRecordedResult, retainCompletableResult, if_pos hcomplete, Option.map_some, Option.some.injEq] at heq + exact ⟨result, hresult, hcomplete, heq.symm⟩ + · simp [privateRecordedResult, retainCompletableResult, hcomplete] at heq + · rintro ⟨result, hresult, hcomplete, rfl⟩ + exact ⟨some result, hresult, by simp [privateRecordedResult, retainCompletableResult, hcomplete]⟩ + +noncomputable def runPrivateProbeRecords + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (output : HashOutput) : + ProbComp (Option (ResolvedRunResult (PrivateValueCut α))) := + runPrivateRecords target (replacePrivatePosition target output context) fuel table (privatePositionProbeCutAt target computation ordinal) + +theorem runPrivateProbeRecords_supported_history + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (output : HashOutput) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (record : ResolvedRunResult (PrivateValueCut α)) + (hrecord : some record ∈ support (runPrivateProbeRecords target computation context fuel table ordinal output)) : + context.state.pendingAt (.position target) ⊆ record.context.state.pendingAt (.position target) ∧ + (record.context.state.pendingAt (.position target)).card ≤ (context.state.pendingAt (.position target)).card + ordinal ∧ + truncateHash output ∉ record.context.state.pendingAt (.position target) := by + obtain ⟨result, hresult, hcomplete, rfl⟩ := (mem_support_runPrivateRecords_iff target + (replacePrivatePosition target output context) fuel table (privatePositionProbeCutAt target computation ordinal) record).mp hrecord + have hinitial : PrivateTargetState target output (context.state.pendingAt (.position target)) + (replacePrivatePosition target output context) := + ⟨hstate, by simp [replacePrivatePosition, DeferredStructuralValues.install], hhidden, rfl⟩ + have hhistory := privatePositionProbeCutAt_history_bound target output computation + (replacePrivatePosition target output context) fuel table _ ordinal hinitial result hresult + refine ⟨hhistory.2.1, hhistory.2.2, ?_⟩ + obtain ⟨completion, hcompletion⟩ := hcomplete + have houtput := hcompletion.2.1 target output hhistory.1.2.1 + intro hhit + change truncateHash output ∈ result.context.state.pendingAt (.position target) at hhit + have hpending := (LazyRevealProbe.State.mem_pendingAt_iff result.context.state (.position target) (truncateHash output)).mp hhit + exact hcompletion.2.2.1 (.position target) (truncateHash output) hpending (by rw [houtput]) + +theorem probOutput_runPrivateProbeRecords_eq_zero_of_history_hit + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (output : HashOutput) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (record : ResolvedRunResult (PrivateValueCut α)) (hhit : truncateHash output ∈ record.context.state.pendingAt (.position target)) : + Pr[= some record | runPrivateProbeRecords target computation context fuel table ordinal output] = 0 := by + apply probOutput_eq_zero_of_not_mem_support + intro hrecord + exact (runPrivateProbeRecords_supported_history target computation context fuel table ordinal output hstate hhidden record hrecord).2.2 hhit + +theorem probOutput_runPrivateProbeRecords_eq_zero_of_missing_initial_pending + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (output : HashOutput) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (record : ResolvedRunResult (PrivateValueCut α)) + (hmissing : ¬context.state.pendingAt (.position target) ⊆ record.context.state.pendingAt (.position target)) : + Pr[= some record | runPrivateProbeRecords target computation context fuel table ordinal output] = 0 := by + apply probOutput_eq_zero_of_not_mem_support + intro hrecord + exact hmissing (runPrivateProbeRecords_supported_history target computation context fuel table ordinal output hstate hhidden record hrecord).1 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueProbeRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueProbeRisk.lean new file mode 100644 index 00000000..17ce22ed --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueProbeRisk.lean @@ -0,0 +1,145 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueCompatibleRecords +import SphincsSecurity.Proof.OtsProbePrivateValueHistoryRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem probOutput_filter_some_of_predicate + (run : ProbComp (Option α)) (predicate : α → Prop) (record : α) (hrecord : predicate record) : + Pr[= some record | (fun result => result.filter (fun value => decide (predicate value))) <$> run] = + Pr[= some record | run] := by + apply probOutput_map_eq_single (some record) + · intro result _ heq + cases result with + | none => simp at heq + | some value => + by_cases hvalue : predicate value + · simpa [Option.filter, hvalue] using heq + · simp [Option.filter, hvalue] at heq + · simp [Option.filter, hrecord] + +theorem probOutput_runPrivateProbeRecords_eq_of_compatible + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (before after : HashOutput) (record : ResolvedRunResult (PrivateValueCut α)) + (hbefore : truncateHash before ∉ record.context.state.pendingAt (.position target)) + (hafter : truncateHash after ∉ record.context.state.pendingAt (.position target)) : + Pr[= some record | runPrivateProbeRecords target computation context fuel table ordinal before] = + Pr[= some record | runPrivateProbeRecords target computation context fuel table ordinal after] := by + by_cases hsubset : context.state.pendingAt (.position target) ⊆ record.context.state.pendingAt (.position target) + · have hcompatible : PrivateRecordCompatible target before after record := ⟨hbefore, hafter⟩ + have hdist := evalDist_runPrivateCompatibleRecords_preload_eq target before after + (privatePositionProbeCutAt target computation ordinal) context fuel table ordinal hstate hhidden + (fun hhit => hbefore (hsubset hhit)) (fun hhit => hafter (hsubset hhit)) + (privatePositionProbeCutAt_no_disclosure target computation ordinal) + (privatePositionProbeCutAt_probe_bound target computation ordinal) + simp only [runPrivateCompatibleRecords_eq_filter] at hdist + have hprob := congrArg (fun distribution => distribution (some record)) hdist + change Pr[= some record | (fun result => result.filter (fun value => decide (PrivateRecordCompatible target before after value))) <$> + runPrivateProbeRecords target computation context fuel table ordinal before] = + Pr[= some record | (fun result => result.filter (fun value => decide (PrivateRecordCompatible target before after value))) <$> + runPrivateProbeRecords target computation context fuel table ordinal after] at hprob + simpa only [probOutput_filter_some_of_predicate _ _ record hcompatible] using hprob + · rw [probOutput_runPrivateProbeRecords_eq_zero_of_missing_initial_pending target computation context fuel table ordinal before + hstate hhidden record hsubset, + probOutput_runPrivateProbeRecords_eq_zero_of_missing_initial_pending target computation context fuel table ordinal after + hstate hhidden record hsubset] + +theorem probEvent_samplePrivateProbeRecords_hit_le_occurrence + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (candidate : ResolvedRunResult (PrivateValueCut α) → Option Digest) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (hcard : (context.state.pendingAt (.position target)).card + ordinal ≤ 2 ^ 126) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | + samplePrivateHistoryGuess (runPrivateProbeRecords target computation context fuel table ordinal) candidate] ≤ + Pr[fun pair => pair.2 ≠ none | + samplePrivateHistoryGuess (runPrivateProbeRecords target computation context fuel table ordinal) candidate] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply probEvent_samplePrivateHistoryGuess_hit_le_of_supported_compatible _ candidate + (fun record => record.context.state.pendingAt (.position target)) + · exact probOutput_runPrivateProbeRecords_eq_of_compatible target computation context fuel table ordinal hstate hhidden + · intro output record hhit + exact probOutput_runPrivateProbeRecords_eq_zero_of_history_hit target computation context fuel table ordinal output hstate hhidden record hhit + · intro output record hrecord + exact (runPrivateProbeRecords_supported_history target computation context fuel table ordinal output hstate hhidden record hrecord).2.1.trans hcard + + +noncomputable def privateProbeRecordCandidate (target : Position) (record : ResolvedRunResult (PrivateValueCut α)) : Option Digest := + (privatePositionAccessCandidate target (some record.value)).filter + (fun digest => digest ∉ record.context.state.pendingAt (.position target)) + +theorem privatePositionCutCharge_probe_record_eq_indicator + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (output : HashOutput) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (record : Option (ResolvedRunResult (PrivateValueCut α))) + (hrecord : record ∈ support (runPrivateProbeRecords target computation context fuel table ordinal output)) : + privatePositionCutCharge target record = if record.bind (privateProbeRecordCandidate target) ≠ none then 1 else 0 := by + cases record with + | none => simp [privatePositionCutCharge] + | some record => + obtain ⟨result, hresult, _, rfl⟩ := (mem_support_runPrivateRecords_iff target + (replacePrivatePosition target output context) fuel table (privatePositionProbeCutAt target computation ordinal) record).mp hrecord + have hinitial : PrivateTargetState target output (context.state.pendingAt (.position target)) + (replacePrivatePosition target output context) := + ⟨hstate, by simp [replacePrivatePosition, DeferredStructuralValues.install], hhidden, rfl⟩ + have hfinal := (privatePositionProbeCutAt_history_bound target output computation + (replacePrivatePosition target output context) fuel table _ ordinal hinitial result hresult).1 + have herased : PrivateTargetState target 0 (result.context.state.pendingAt (.position target)) + (replacePrivateRunResult target 0 result).context := + ⟨hfinal.1, by simp [replacePrivateRunResult, replacePrivatePosition, DeferredStructuralValues.install], hfinal.2.2.1, rfl⟩ + simp only [privatePositionCutCharge, Option.bind_some, privateProbeRecordCandidate] + cases hcandidate : privatePositionAccessCandidate target (some (replacePrivateRunResult target 0 result).value) with + | none => simp + | some digest => + dsimp only + rw [herased.materializedCandidateCharge_eq] + by_cases hmem : digest ∈ result.context.state.pendingAt (.position target) <;> + simp [replacePrivateRunResult, replacePrivatePosition, hmem] + +noncomputable def sampledPrivateProbeCharge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) : ENNReal := + ∑' output, Pr[= output | LazyRevealProbe.sampleHashOutput] * + ∑' record, Pr[= record | runPrivateProbeRecords target computation context fuel table ordinal output] * privatePositionCutCharge target record + +theorem probEvent_samplePrivateProbeRecords_occurrence_eq_charge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) : + Pr[fun pair => pair.2 ≠ none | samplePrivateHistoryGuess + (runPrivateProbeRecords target computation context fuel table ordinal) (privateProbeRecordCandidate target)] = + sampledPrivateProbeCharge target computation context fuel table ordinal := by + unfold samplePrivateHistoryGuess sampledPrivateProbeCharge + rw [probEvent_bind_eq_tsum] + apply tsum_congr + intro output + congr 1 + rw [probEvent_bind_eq_tsum] + apply tsum_congr + intro record + by_cases hrecord : record ∈ support (runPrivateProbeRecords target computation context fuel table ordinal output) + · rw [privatePositionCutCharge_probe_record_eq_indicator target computation context fuel table ordinal output hstate hhidden record hrecord] + simp only [probEvent_pure] + · simp [probOutput_eq_zero_of_not_mem_support hrecord] + +theorem probEvent_samplePrivateProbeRecords_hit_le_charge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (hcard : (context.state.pendingAt (.position target)).card + ordinal ≤ 2 ^ 126) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | samplePrivateHistoryGuess + (runPrivateProbeRecords target computation context fuel table ordinal) (privateProbeRecordCandidate target)] ≤ + sampledPrivateProbeCharge target computation context fuel table ordinal * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + rw [← probEvent_samplePrivateProbeRecords_occurrence_eq_charge target computation context fuel table ordinal hstate hhidden] + exact probEvent_samplePrivateProbeRecords_hit_le_occurrence target computation context fuel table ordinal + (privateProbeRecordCandidate target) hstate hhidden hcard + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueProbeTransport.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueProbeTransport.lean new file mode 100644 index 00000000..2fcdf14c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueProbeTransport.lean @@ -0,0 +1,286 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueHistoryTracking + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def privateResolvedSelectedCandidate (target : Position) (select : Nat → α → Option Digest) : + Option (DeferredContext × Nat × α) → Option (HashOutput × Digest) + | none => none + | some (context, remaining, value) => do + let output ← context.positionValue target + let candidate ← select remaining value + pure (output, candidate) + +theorem privateResolutionResult_known_candidate + (target : Position) (output : HashOutput) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (remaining : Nat) (value : α) (select : Nat → α → Option Digest) + (hconsistent : context.ValuesConsistent) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = some output) : + privateResolvedSelectedCandidate target select <$> privateResolutionResult target table context remaining value = + pure (if DeferredCompletable table context then (select remaining value).map (fun digest => (output, digest)) else none) := by + have hknown : context.positionValue target = some output := by simp [DeferredContext.positionValue, hstate, hvalue] + by_cases hhit : context.state.hitAt (.position target) output + · have hdoomed : ¬DeferredCompletable table context := by + rintro ⟨completion, hcompletion⟩ + have houtput := hcompletion.2.1 target output hvalue + have hpending := (LazyRevealProbe.State.mem_pendingAt_iff context.state (.position target) (truncateHash output)).mp hhit + exact hcompletion.2.2.1 _ _ hpending (by rw [houtput]) + simp [privateResolutionResult, resolveDeferredPositionValue, hstate, hvalue, hhit, hdoomed, privateResolvedSelectedCandidate] + · have hresolve : resolveDeferredPositionValue target context = pure (some (completePrivatePosition target context output)) := by + have hinstall : context.values.install target output = context.values := by + unfold DeferredStructuralValues.install + rw [← hvalue] + exact Function.update_eq_self target context.values + simp [resolveDeferredPositionValue, hstate, hvalue, hhit, completePrivatePosition, hinstall] + have hsupport : some (completePrivatePosition target context output) ∈ support (resolveDeferredPositionValue target context) := by + rw [hresolve] + simp + have hcomplete : DeferredCompletable table (completePrivatePosition target context output).toDeferredContext ↔ + DeferredCompletable table context := by + constructor + · rintro ⟨completion, hcompletion⟩ + exact ⟨completion, ((deferredCompletion_resolveDeferredPositionValue_iff target _ hconsistent hsupport completion).mp hcompletion).1⟩ + · rintro ⟨completion, hcompletion⟩ + exact ⟨completion, (deferredCompletion_resolveDeferredPositionValue_iff target _ hconsistent hsupport completion).mpr + ⟨hcompletion, hcompletion.2.1 target output hvalue⟩⟩ + have hresolvedValue := resolveDeferredPositionValue_resolves target context (completePrivatePosition target context output) hsupport + unfold privateResolutionResult + rw [hresolve] + simp only [pure_bind] + by_cases hcompletable : DeferredCompletable table context + · simp only [if_pos hcompletable, if_pos (hcomplete.mpr hcompletable), map_pure, privateResolvedSelectedCandidate, hresolvedValue] + cases select remaining value <;> rfl + · simp [hcompletable, hcomplete, privateResolvedSelectedCandidate] + +theorem evalDist_privateResolvedSelectedCandidate_preloaded + (target : Position) (output : HashOutput) (select : Nat → α → Option Digest) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (pending : Finset Digest) (bound : Nat) + (h : PrivateTargetState target output pending context) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hsafe : computation.IsQueryBoundP (IsPrivatePositionDisclosure target) 0) + (hcount : computation.IsQueryBoundP (IsPrivatePositionProbe target) bound) : + evalDist (privateResolvedSelectedCandidate target select <$> runPrivateResolvedView target table context fuel computation) = + evalDist ((fun result => result.bind (fun pair => (select pair.1 pair.2).map (fun digest => (output, digest)))) <$> + runResolvedLiveValue table context fuel computation) := by + unfold runPrivateResolvedView runResolvedLiveValue + simp only [map_bind] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hfinal := (h.history_of_mem_runResolved computation context fuel table pending bound result hsafe hcount hresult).1 + have hcore := resolvedCore_of_mem_runResolvedFromTable computation context fuel table result hconsistent hstarts hresult + dsimp only + rw [privateResolutionResult_known_candidate target output table result.context result.remaining result.value select hcore.2.1 hfinal.1 hfinal.2.1] + by_cases hcomplete : DeferredCompletable table result.context <;> simp [hcomplete] + + +def privateTrackedCandidate (target : Position) (remaining : Nat) (value : Finset Digest × PrivateValueCut α) : Option Digest := + privateLiveCandidateProjection target value.1 (some (remaining, value.2)) + +theorem evalDist_privateProbeRecords_candidate_eq_tracked + (target : Position) (output : HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) : + evalDist ((fun record => record.bind (privateProbeRecordCandidate target)) <$> + runPrivateProbeRecords target computation context fuel table ordinal output) = + evalDist ((fun result => result.bind (fun pair => privateTrackedCandidate target pair.1 pair.2)) <$> + runResolvedLiveValue table (replacePrivatePosition target output context) fuel + (trackPrivateProbeHistory target (privatePositionProbeCutAt target computation ordinal) (context.state.pendingAt (.position target)))) := by + have hinitial : PrivateTargetState target output (context.state.pendingAt (.position target)) + (replacePrivatePosition target output context) := + ⟨hstate, by simp [replacePrivatePosition, DeferredStructuralValues.install], hhidden, rfl⟩ + have hdist := evalDist_runResolvedLiveValue_trackPrivateProbeHistory target output + (privatePositionProbeCutAt target computation ordinal) (replacePrivatePosition target output context) fuel table _ hinitial + (hvalid.replacePrivatePosition target output hstate).valuesConsistent (show StartTableAgrees context.state table from startTableAgrees_of_deferredCompletable hcomplete) + (privatePositionProbeCutAt_no_disclosure target computation ordinal) + calc + _ = evalDist ((fun result => (privateHistoryValue target (retainCompletableResult result)).bind + (fun pair => privateTrackedCandidate target pair.1 pair.2)) <$> + runResolvedFromTable (replacePrivatePosition target output context) fuel table (privatePositionProbeCutAt target computation ordinal)) := by + unfold runPrivateProbeRecords runPrivateRecords + rw [Functor.map_map] + congr 2 + funext result + unfold privateRecordedResult privateHistoryValue + cases retainCompletableResult result <;> rfl + _ = _ := by + simpa only [Functor.map_map, Function.comp_def] using + (evalDist_map_eq_of_evalDist_eq hdist (fun result => result.bind (fun pair => privateTrackedCandidate target pair.1 pair.2))).symm + +theorem evalDist_privateResolvedTrackedCandidate_completePrivatePosition + (target : Position) (output : HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (hclean : ¬context.state.hitAt (.position target) output) : + evalDist (privateResolvedSelectedCandidate target (privateTrackedCandidate target) <$> + runPrivateResolvedView target table (completePrivatePosition target context output).toDeferredContext fuel + (trackPrivateProbeHistory target (privatePositionProbeCutAt target computation ordinal) (context.state.pendingAt (.position target)))) = + evalDist ((fun record => (record.bind (privateProbeRecordCandidate target)).map (fun digest => (output, digest))) <$> + runPrivateProbeRecords target computation context fuel table ordinal output) := by + let tracked := trackPrivateProbeHistory target (privatePositionProbeCutAt target computation ordinal) (context.state.pendingAt (.position target)) + have hprevalid := hvalid.replacePrivatePosition target output hstate + have hprecomplete := hcomplete.replacePrivatePosition target output hstate hclean + have hinitial : PrivateTargetState target output ∅ (completePrivatePosition target context output).toDeferredContext := by + refine ⟨hstate, ?_, hhidden, ?_⟩ + · simp [completePrivatePosition, DeferredStructuralValues.install] + · ext digest + simp [completePrivatePosition, LazyRevealProbe.State.pendingAt, LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway] + have hsafe := trackPrivateProbeHistory_query_bound target (privatePositionProbeCutAt target computation ordinal) + (context.state.pendingAt (.position target)) _ 0 (privatePositionProbeCutAt_no_disclosure target computation ordinal) + have hcount := trackPrivateProbeHistory_query_bound target (privatePositionProbeCutAt target computation ordinal) + (context.state.pendingAt (.position target)) _ ordinal (privatePositionProbeCutAt_probe_bound target computation ordinal) + have hcleanup := evalDist_runResolvedLiveValue_clearPending_known target output table (replacePrivatePosition target output context) fuel tracked + hprevalid hprecomplete (by simp [DeferredContext.positionValue, replacePrivatePosition, hstate, DeferredStructuralValues.install]) + have hprojection := evalDist_privateProbeRecords_candidate_eq_tracked target output computation context fuel table ordinal hvalid hcomplete hstate hhidden + rw [evalDist_privateResolvedSelectedCandidate_preloaded target output _ tracked _ fuel table ∅ ordinal hinitial + (hprevalid.clearPending (.position target)).valuesConsistent (show StartTableAgrees context.state table from startTableAgrees_of_deferredCompletable hcomplete) hsafe hcount] + have hdist := evalDist_map_eq_of_evalDist_eq hcleanup.symm + (fun result => result.bind (fun pair => (privateTrackedCandidate target pair.1 pair.2).map (fun digest => (output, digest)))) + calc + _ = _ := hdist + _ = _ := by + have heq := evalDist_map_eq_of_evalDist_eq hprojection.symm (Option.map (fun digest => (output, digest))) + simpa only [Functor.map_map, Function.comp_def, Option.map_bind] using heq + + +theorem evalDist_runPrivateProbeRecords_eq_none_of_initial_hit + (target : Position) (output : HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (hhit : context.state.hitAt (.position target) output) : + evalDist (runPrivateProbeRecords target computation context fuel table ordinal output) = evalDist (pure none : ProbComp (Option (ResolvedRunResult (PrivateValueCut α)))) := by + let run := runPrivateProbeRecords target computation context fuel table ordinal output + have honly (record) (hrecord : record ∈ support run) : record = none := by + cases record with + | none => rfl + | some record => + have hhistory := runPrivateProbeRecords_supported_history target computation context fuel table ordinal output hstate hhidden record hrecord + exact False.elim (hhistory.2.2 (hhistory.1 hhit)) + calc + _ = evalDist (run >>= fun record => pure record) := by simp [run] + _ = evalDist (run >>= fun _ => pure none) := by + apply evalDist_bind_congr + intro record hrecord + rw [honly record hrecord] + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails run + (by simp [run, runPrivateProbeRecords, runPrivateRecords, runResolvedFromTable]) (pure none) + +theorem evalDist_privateResolvedTrackedCandidate_eq_sampled + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hhidden : .position target ∉ context.state.revealed) : + evalDist (privateResolvedSelectedCandidate target (privateTrackedCandidate target) <$> + runPrivateResolvedView target table context fuel + (trackPrivateProbeHistory target (privatePositionProbeCutAt target computation ordinal) (context.state.pendingAt (.position target)))) = + evalDist (privateSampledCandidatePair <$> samplePrivateHistoryGuess + (runPrivateProbeRecords target computation context fuel table ordinal) (privateProbeRecordCandidate target)) := by + let tracked := trackPrivateProbeHistory target (privatePositionProbeCutAt target computation ordinal) (context.state.pendingAt (.position target)) + have hdist := evalDist_runPrivateResolvedView_eq_uniform target tracked context fuel table hvalid hcomplete hensured hstate hvalue + calc + _ = evalDist (privateResolvedSelectedCandidate target (privateTrackedCandidate target) <$> (do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt (.position target) output then pure none + else runPrivateResolvedView target table (completePrivatePosition target context output).toDeferredContext fuel tracked)) := + evalDist_map_eq_of_evalDist_eq hdist _ + _ = _ := by + unfold samplePrivateHistoryGuess + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro output _ + by_cases hhit : context.state.hitAt (.position target) output + · simp only [if_pos hhit, pure_bind, Function.comp_apply, privateResolvedSelectedCandidate] + have hnone := evalDist_runPrivateProbeRecords_eq_none_of_initial_hit target output computation context fuel table ordinal hstate hhidden hhit + have hmapped := evalDist_map_eq_of_evalDist_eq hnone + (fun record => (record.bind (privateProbeRecordCandidate target)).map (fun digest => (output, digest))) + simpa only [map_eq_bind_pure_comp, bind_assoc, pure_bind, Function.comp_def, privateSampledCandidatePair, + Option.bind_none, Option.map_none] using hmapped.symm + · simp only [if_neg hhit] + have htransport := evalDist_privateResolvedTrackedCandidate_completePrivatePosition target output computation context fuel table ordinal + hvalid hcomplete hstate hhidden hhit + simpa only [map_eq_bind_pure_comp, bind_assoc, pure_bind, Function.comp_def, privateSampledCandidatePair] using htransport + + +theorem probEvent_privateResolvedTrackedCandidate_hit_le_charge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hhidden : .position target ∉ context.state.revealed) + (hcard : (context.state.pendingAt (.position target)).card + ordinal ≤ 2 ^ 126) : + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateTrackedCandidate target) <$> + runPrivateResolvedView target table context fuel + (trackPrivateProbeHistory target (privatePositionProbeCutAt target computation ordinal) (context.state.pendingAt (.position target)))] ≤ + sampledPrivateProbeCharge target computation context fuel table ordinal * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + have hdist := evalDist_privateResolvedTrackedCandidate_eq_sampled target computation context fuel table ordinal + hvalid hcomplete hensured hstate hvalue hhidden + rw [probEvent_congr' (fun _ _ => Iff.rfl) hdist, probEvent_map] + have hevent (pair : HashOutput × Option Digest) : PrivateCandidatePairHit (privateSampledCandidatePair pair) ↔ + pair.2 = some (truncateHash pair.1) := by + rcases pair with ⟨output, candidate⟩ + cases candidate <;> simp [privateSampledCandidatePair, PrivateCandidatePairHit] + have hprob := probEvent_congr' (fun pair _ => hevent pair) + (rfl : evalDist (samplePrivateHistoryGuess (runPrivateProbeRecords target computation context fuel table ordinal) + (privateProbeRecordCandidate target)) = _) + simp only [Function.comp_def] + rw [hprob] + exact probEvent_samplePrivateProbeRecords_hit_le_charge target computation context fuel table ordinal hstate hhidden hcard + +theorem probEvent_privateResolvedTrackedCandidate_occurrence_eq_charge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hhidden : .position target ∉ context.state.revealed) : + Pr[fun pair => pair ≠ none | privateResolvedSelectedCandidate target (privateTrackedCandidate target) <$> + runPrivateResolvedView target table context fuel + (trackPrivateProbeHistory target (privatePositionProbeCutAt target computation ordinal) (context.state.pendingAt (.position target)))] = + sampledPrivateProbeCharge target computation context fuel table ordinal := by + have hdist := evalDist_privateResolvedTrackedCandidate_eq_sampled target computation context fuel table ordinal + hvalid hcomplete hensured hstate hvalue hhidden + rw [probEvent_congr' (fun _ _ => Iff.rfl) hdist, probEvent_map] + have hevent (pair : HashOutput × Option Digest) : privateSampledCandidatePair pair ≠ none ↔ pair.2 ≠ none := by + rcases pair with ⟨output, candidate⟩ + cases candidate <;> simp [privateSampledCandidatePair] + have hprob := probEvent_congr' (fun pair _ => hevent pair) + (rfl : evalDist (samplePrivateHistoryGuess (runPrivateProbeRecords target computation context fuel table ordinal) + (privateProbeRecordCandidate target)) = _) + simp only [Function.comp_def] + rw [hprob] + exact probEvent_samplePrivateProbeRecords_occurrence_eq_charge target computation context fuel table ordinal hstate hhidden + +theorem probEvent_privateResolvedTrackedCandidate_hit_le_occurrence + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hhidden : .position target ∉ context.state.revealed) + (hcard : (context.state.pendingAt (.position target)).card + ordinal ≤ 2 ^ 126) : + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateTrackedCandidate target) <$> + runPrivateResolvedView target table context fuel + (trackPrivateProbeHistory target (privatePositionProbeCutAt target computation ordinal) (context.state.pendingAt (.position target)))] ≤ + Pr[fun pair => pair ≠ none | privateResolvedSelectedCandidate target (privateTrackedCandidate target) <$> + runPrivateResolvedView target table context fuel + (trackPrivateProbeHistory target (privatePositionProbeCutAt target computation ordinal) (context.state.pendingAt (.position target)))] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + rw [probEvent_privateResolvedTrackedCandidate_occurrence_eq_charge target computation context fuel table ordinal + hvalid hcomplete hensured hstate hvalue hhidden] + exact probEvent_privateResolvedTrackedCandidate_hit_le_charge target computation context fuel table ordinal + hvalid hcomplete hensured hstate hvalue hhidden hcard + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueRawProbeRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueRawProbeRisk.lean new file mode 100644 index 00000000..9f81083a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueRawProbeRisk.lean @@ -0,0 +1,249 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueProbeTransport + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def privateRawCutCandidate (target : Position) (_remaining : Nat) (cut : PrivateValueCut α) : Option Digest := + privatePositionAccessCandidate target (some cut) + +def privateRawRecordCandidate (target : Position) (record : ResolvedRunResult (PrivateValueCut α)) : Option Digest := + privateRawCutCandidate target record.remaining record.value + +theorem evalDist_privateRawProbeRecords_candidate_eq_live_value + (target : Position) (output : HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hstate : context.state.values (.position target) = none) : + evalDist ((fun record => record.bind (privateRawRecordCandidate target)) <$> + runPrivateProbeRecords target computation context fuel table ordinal output) = + evalDist ((fun result => result.bind (fun pair => privateRawCutCandidate target pair.1 pair.2)) <$> + runResolvedLiveValue table (replacePrivatePosition target output context) fuel (privatePositionProbeCutAt target computation ordinal)) := by + have hdist := evalDist_runResolvedLiveValue_eq_retained_value table (replacePrivatePosition target output context) fuel + (privatePositionProbeCutAt target computation ordinal) (hvalid.replacePrivatePosition target output hstate).valuesConsistent + (show StartTableAgrees context.state table from startTableAgrees_of_deferredCompletable hcomplete) + calc + _ = evalDist ((fun result => (retainCompletableResult result).bind + (fun record => privateRawCutCandidate target record.remaining record.value)) <$> + runResolvedFromTable (replacePrivatePosition target output context) fuel table (privatePositionProbeCutAt target computation ordinal)) := by + unfold runPrivateProbeRecords runPrivateRecords + rw [Functor.map_map] + congr 2 + funext result + unfold privateRecordedResult + cases retainCompletableResult result <;> rfl + _ = _ := by + have heq := evalDist_map_eq_of_evalDist_eq hdist (fun result => result.bind (fun pair => privateRawCutCandidate target pair.1 pair.2)) + simpa only [Functor.map_map, Function.comp_def, Option.bind_map] using heq.symm + +theorem evalDist_privateResolvedRawCandidate_completePrivatePosition + (target : Position) (output : HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (hclean : ¬context.state.hitAt (.position target) output) : + evalDist (privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table (completePrivatePosition target context output).toDeferredContext fuel + (privatePositionProbeCutAt target computation ordinal)) = + evalDist ((fun record => (record.bind (privateRawRecordCandidate target)).map (fun digest => (output, digest))) <$> + runPrivateProbeRecords target computation context fuel table ordinal output) := by + have hprevalid := hvalid.replacePrivatePosition target output hstate + have hprecomplete := hcomplete.replacePrivatePosition target output hstate hclean + have hinitial : PrivateTargetState target output ∅ (completePrivatePosition target context output).toDeferredContext := by + refine ⟨hstate, ?_, hhidden, ?_⟩ + · simp [completePrivatePosition, DeferredStructuralValues.install] + · ext digest + simp [completePrivatePosition, LazyRevealProbe.State.pendingAt, LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway] + have hcleanup := evalDist_runResolvedLiveValue_clearPending_known target output table (replacePrivatePosition target output context) fuel + (privatePositionProbeCutAt target computation ordinal) hprevalid hprecomplete + (by simp [DeferredContext.positionValue, replacePrivatePosition, hstate, DeferredStructuralValues.install]) + have hprojection := evalDist_privateRawProbeRecords_candidate_eq_live_value target output computation context fuel table ordinal hvalid hcomplete hstate + rw [evalDist_privateResolvedSelectedCandidate_preloaded target output _ (privatePositionProbeCutAt target computation ordinal) _ fuel table ∅ ordinal hinitial + (hprevalid.clearPending (.position target)).valuesConsistent + (show StartTableAgrees context.state table from startTableAgrees_of_deferredCompletable hcomplete) + (privatePositionProbeCutAt_no_disclosure target computation ordinal) (privatePositionProbeCutAt_probe_bound target computation ordinal)] + have hdist := evalDist_map_eq_of_evalDist_eq hcleanup.symm + (fun result => result.bind (fun pair => (privateRawCutCandidate target pair.1 pair.2).map (fun digest => (output, digest)))) + calc + _ = _ := hdist + _ = _ := by + have heq := evalDist_map_eq_of_evalDist_eq hprojection.symm (Option.map (fun digest => (output, digest))) + simpa only [Functor.map_map, Function.comp_def, Option.map_bind] using heq + +theorem evalDist_privateResolvedRawCandidate_eq_sampled + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hhidden : .position target ∉ context.state.revealed) : + evalDist (privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target computation ordinal)) = + evalDist (privateSampledCandidatePair <$> samplePrivateHistoryGuess + (runPrivateProbeRecords target computation context fuel table ordinal) (privateRawRecordCandidate target)) := by + have hdist := evalDist_runPrivateResolvedView_eq_uniform target (privatePositionProbeCutAt target computation ordinal) + context fuel table hvalid hcomplete hensured hstate hvalue + calc + _ = evalDist (privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> (do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt (.position target) output then pure none + else + runPrivateResolvedView target table (completePrivatePosition target context output).toDeferredContext fuel + (privatePositionProbeCutAt target computation ordinal))) := evalDist_map_eq_of_evalDist_eq hdist _ + _ = _ := by + unfold samplePrivateHistoryGuess + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro output _ + by_cases hhit : context.state.hitAt (.position target) output + · simp only [if_pos hhit, pure_bind, Function.comp_apply, privateResolvedSelectedCandidate] + have hnone := evalDist_runPrivateProbeRecords_eq_none_of_initial_hit target output computation context fuel table ordinal hstate hhidden hhit + have hmapped := evalDist_map_eq_of_evalDist_eq hnone + (fun record => (record.bind (privateRawRecordCandidate target)).map (fun digest => (output, digest))) + simpa only [map_eq_bind_pure_comp, bind_assoc, pure_bind, Function.comp_def, privateSampledCandidatePair, + Option.bind_none, Option.map_none] using hmapped.symm + · simp only [if_neg hhit] + have htransport := evalDist_privateResolvedRawCandidate_completePrivatePosition target output computation context fuel table ordinal + hvalid hcomplete hstate hhidden hhit + simpa only [map_eq_bind_pure_comp, bind_assoc, pure_bind, Function.comp_def, privateSampledCandidatePair] using htransport + +theorem probEvent_samplePrivateProbeRecords_raw_hit_eq_fresh_hit + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | samplePrivateHistoryGuess + (runPrivateProbeRecords target computation context fuel table ordinal) (privateRawRecordCandidate target)] = + Pr[fun pair => pair.2 = some (truncateHash pair.1) | samplePrivateHistoryGuess + (runPrivateProbeRecords target computation context fuel table ordinal) (privateProbeRecordCandidate target)] := by + unfold samplePrivateHistoryGuess + apply probEvent_bind_congr + intro output _ + apply probEvent_bind_congr + intro record hrecord + cases record with + | none => rfl + | some record => + have hclean := (runPrivateProbeRecords_supported_history target computation context fuel table ordinal output hstate hhidden record hrecord).2.2 + simp only [probEvent_pure, Option.bind_some] + congr 1 + simp [privateProbeRecordCandidate, privateRawRecordCandidate, privateRawCutCandidate, hclean] + +theorem probEvent_privateResolvedRawCandidate_hit_le_charge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hhidden : .position target ∉ context.state.revealed) + (hcard : (context.state.pendingAt (.position target)).card + ordinal ≤ 2 ^ 126) : + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target computation ordinal)] ≤ + sampledPrivateProbeCharge target computation context fuel table ordinal * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + have hdist := evalDist_privateResolvedRawCandidate_eq_sampled target computation context fuel table ordinal + hvalid hcomplete hensured hstate hvalue hhidden + rw [probEvent_congr' (fun _ _ => Iff.rfl) hdist, probEvent_map] + have hevent (pair : HashOutput × Option Digest) : PrivateCandidatePairHit (privateSampledCandidatePair pair) ↔ + pair.2 = some (truncateHash pair.1) := by + rcases pair with ⟨output, candidate⟩ + cases candidate <;> simp [privateSampledCandidatePair, PrivateCandidatePairHit] + have hprob := probEvent_congr' (fun pair _ => hevent pair) + (rfl : evalDist (samplePrivateHistoryGuess (runPrivateProbeRecords target computation context fuel table ordinal) + (privateRawRecordCandidate target)) = _) + simp only [Function.comp_def] + rw [hprob, probEvent_samplePrivateProbeRecords_raw_hit_eq_fresh_hit target computation context fuel table ordinal hstate hhidden] + exact probEvent_samplePrivateProbeRecords_hit_le_charge target computation context fuel table ordinal hstate hhidden hcard + + +theorem sampledPrivateProbeCharge_le_raw_occurrence + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hhidden : .position target ∉ context.state.revealed) : + sampledPrivateProbeCharge target computation context fuel table ordinal ≤ + Pr[fun pair => pair ≠ none | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target computation ordinal)] := by + rw [← probEvent_samplePrivateProbeRecords_occurrence_eq_charge target computation context fuel table ordinal hstate hhidden] + have hdist := evalDist_privateResolvedRawCandidate_eq_sampled target computation context fuel table ordinal + hvalid hcomplete hensured hstate hvalue hhidden + rw [probEvent_congr' (fun _ _ => Iff.rfl) hdist, probEvent_map] + have hevent (pair : HashOutput × Option Digest) : privateSampledCandidatePair pair ≠ none ↔ pair.2 ≠ none := by + rcases pair with ⟨output, candidate⟩ + cases candidate <;> simp [privateSampledCandidatePair] + have hprob := probEvent_congr' (fun pair _ => hevent pair) + (rfl : evalDist (samplePrivateHistoryGuess (runPrivateProbeRecords target computation context fuel table ordinal) + (privateRawRecordCandidate target)) = _) + simp only [Function.comp_def] + rw [hprob] + unfold samplePrivateHistoryGuess + apply probEvent_bind_mono + intro output _ + apply probEvent_bind_mono + intro record _ + cases record with + | none => rfl + | some record => + simp only [probEvent_pure, Option.bind_some] + by_cases hraw : privateRawRecordCandidate target record = none + · have hfresh : privateProbeRecordCandidate target record = none := by + simpa only [privateProbeRecordCandidate, privateRawRecordCandidate, privateRawCutCandidate, + hraw, Option.filter_none] using congrArg (fun candidate => candidate.filter + (fun digest => digest ∉ record.context.state.pendingAt (.position target))) hraw + simp [hraw, hfresh] + · simp only [ne_eq, hraw, not_false_eq_true, if_true] + split_ifs <;> simp + +def PrivateProbeCutReached (target : Position) (result : Option (ResolvedRunResult (PrivateValueCut α))) : Prop := + (privatePositionAccessCandidate target (result.map ResolvedRunResult.value)) ≠ none + +theorem probEvent_privateResolvedRawCandidate_occurrence_le_cut_reached + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) : + Pr[fun pair => pair ≠ none | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target computation ordinal)] ≤ + Pr[PrivateProbeCutReached target | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)] := by + unfold runPrivateResolvedView + rw [map_bind] + apply probEvent_bind_le_probEvent + intro result _ hresult + cases result with + | none => simp [privateResolvedSelectedCandidate] + | some result => + have hnone : privateRawCutCandidate target result.remaining result.value = none := by + simpa only [PrivateProbeCutReached, Option.map_some, privateRawCutCandidate, not_not] using hresult + unfold privateResolutionResult + rw [map_bind, probEvent_bind_eq_tsum] + apply ENNReal.tsum_eq_zero.mpr + intro resolved + cases resolved with + | none => simp [privateResolvedSelectedCandidate] + | some resolved => + by_cases hcomplete : DeferredCompletable table resolved.toDeferredContext + · simp only [if_pos hcomplete, map_pure, privateResolvedSelectedCandidate, hnone] + cases resolved.toDeferredContext.positionValue target <;> simp + · simp [hcomplete, privateResolvedSelectedCandidate] + +theorem probEvent_privateResolvedRawCandidate_hit_le_cut_reached + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hhidden : .position target ∉ context.state.revealed) + (hcard : (context.state.pendingAt (.position target)).card + ordinal ≤ 2 ^ 126) : + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target computation ordinal)] ≤ + Pr[PrivateProbeCutReached target | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)] * + ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply (probEvent_privateResolvedRawCandidate_hit_le_charge target computation context fuel table ordinal + hvalid hcomplete hensured hstate hvalue hhidden hcard).trans + exact mul_le_mul' ((sampledPrivateProbeCharge_le_raw_occurrence target computation context fuel table ordinal + hvalid hcomplete hensured hstate hvalue hhidden).trans + (probEvent_privateResolvedRawCandidate_occurrence_le_cut_reached target computation context fuel table ordinal)) le_rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueRecordReplacement.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueRecordReplacement.lean new file mode 100644 index 00000000..77a692be --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueRecordReplacement.lean @@ -0,0 +1,127 @@ +import SphincsSecurity.Proof.OtsProbePrivateValueProbeRecords + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem PrivatePositionReplaceable.of_mem_runResolved_no_exposure + {target : Position} {before after : HashOutput} + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (h : PrivatePositionReplaceable target before after context) + (hsafe : computation.IsQueryBoundP (IsPrivateValueExposure target before after) 0) + (hresult : some result ∈ support (runResolvedFromTable context fuel table computation)) : + PrivatePositionReplaceable target before after result.context := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runResolvedFromTable] at hresult + subst result + exact h + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hsafe + have hquery : ¬IsPrivateValueExposure target before after query := by simpa using hsafe.1 + have hnext : ∀ reply, (next reply).IsQueryBoundP (IsPrivateValueExposure target before after) 0 := by + intro reply + simpa using hsafe.2 reply + cases query with + | uniform n => + rw [runResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨reply, _, htail⟩ := hresult + exact ih reply context fuel h (hnext reply) htail + | hashOutput => + rw [runResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨reply, _, htail⟩ := hresult + exact ih reply context fuel h (hnext reply) htail + | ensure coordinate => + rw [runResolvedFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel h (hnext ()) hresult + | peek coordinate => + rw [runResolvedFromTable_peek_query_bind] at hresult + exact ih _ context fuel h (hnext _) hresult + | publish coordinate => + rw [runResolvedFromTable_publish_query_bind] at hresult + exact ih () { context with state := context.state.publish coordinate } fuel h (hnext ()) hresult + | probe coordinate digest => + rw [runResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + split_ifs at hresult + · exact ih () context remaining h (hnext ()) hresult + · exact ih () _ remaining (h.addPending coordinate digest hquery) (hnext ()) hresult + | reveal coordinate => + rw [runResolvedFromTable_reveal_query_bind] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [pure_bind] at hresult + cases hresolved : resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context with + | none => simp [hresolved] at hresult + | some middle => + simp only [hresolved] at hresult + have hvalues := resolveDeferredChainStart_deferred_values_eq table ⟨lay, tree, leafIdx, chainIdx⟩ context middle hresolved + exact ih middle.output _ fuel (h.materialize_other _ middle.output middle.values (by simp) (hvalues ▸ h.2.1)) + (hnext middle.output) hresult + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨option, hresolve, htail⟩ := hresult + cases option with + | none => simp at htail + | some middle => + have hvalue := privateValue_preserved_by_resolveDeferredReveal target position before table context middle h.1 h.2.1 hresolve + exact ih middle.output _ fuel (h.materialize_other _ middle.output middle.values hquery hvalue) + (hnext middle.output) htail + +theorem privateRecordedResult_replace + (target : Position) (before after : HashOutput) (result : ResolvedRunResult α) + (h : PrivatePositionReplaceable target before after result.context) : + privateRecordedResult target (some (replacePrivateRunResult target after result)) = privateRecordedResult target (some result) := by + unfold privateRecordedResult + rw [retainCompletableResult_replacePrivateRunResult target before after result h, Option.map_map] + cases retainCompletableResult (some result) with + | none => rfl + | some kept => simp [replacePrivateRunResult, replacePrivatePosition, DeferredStructuralValues.install] + +theorem evalDist_runPrivateRecords_replace + (target : Position) (before after : HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (h : PrivatePositionReplaceable target before after context) + (hsafe : computation.IsQueryBoundP (IsPrivateValueExposure target before after) 0) : + evalDist (runPrivateRecords target (replacePrivatePosition target after context) fuel table computation) = + evalDist (runPrivateRecords target context fuel table computation) := by + have hdist := evalDist_runResolved_replacePrivatePosition target before after computation context fuel table h hsafe + unfold runPrivateRecords + calc + _ = evalDist (privateRecordedResult target <$> (Option.map (replacePrivateRunResult target after) <$> + runResolvedFromTable context fuel table computation)) := evalDist_map_eq_of_evalDist_eq hdist _ + _ = _ := by + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + simp only [pure_bind, Function.comp_apply, Option.map_some] + rw [privateRecordedResult_replace target before after result + (h.of_mem_runResolved_no_exposure computation context fuel table result hsafe hresult)] + +theorem evalDist_privateExposureRecords_preload_swap + (target : Position) (before after : HashOutput) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hstate : context.state.values (.position target) = none) + (hbefore : ¬context.state.hitAt (.position target) before) (hafter : ¬context.state.hitAt (.position target) after) : + evalDist (runPrivateRecords target (replacePrivatePosition target before context) fuel table + (privateValueExposureCut target before after computation)) = + evalDist (runPrivateRecords target (replacePrivatePosition target after context) fuel table + (privateValueExposureCut target after before computation)) := by + have hinitial : PrivatePositionReplaceable target before after (replacePrivatePosition target before context) := + ⟨hstate, by simp [replacePrivatePosition, DeferredStructuralValues.install], hbefore, hafter⟩ + have hdist := evalDist_runPrivateRecords_replace target before after (privateValueExposureCut target before after computation) + (replacePrivatePosition target before context) fuel table hinitial (privateValueExposureCut_no_exposure target before after computation) + rw [privateValueExposureCut_swap target after before computation] + simpa [replacePrivatePosition, DeferredStructuralValues.install] using hdist.symm + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueReplacement.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueReplacement.lean new file mode 100644 index 00000000..4e232f56 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateValueReplacement.lean @@ -0,0 +1,323 @@ +import SphincsSecurity.Proof.OtsProbeCandidateRiskComponents + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def replacePrivatePosition (target : Position) (output : HashOutput) (context : DeferredContext) : DeferredContext := + { context with values := context.values.install target output } + +def replacePrivateResolution (target : Position) (output : HashOutput) (position : Option Position) + (result : DeferredResolution) : DeferredResolution := + ⟨replacePrivatePosition target output result.toDeferredContext, + if position = some target then output else result.output⟩ + +def PrivatePositionReplaceable (target : Position) (before after : HashOutput) (context : DeferredContext) : Prop := + context.state.values (.position target) = none ∧ context.values target = some before ∧ + ¬context.state.hitAt (.position target) before ∧ ¬context.state.hitAt (.position target) after + +theorem PrivatePositionReplaceable.of_transition + {target : Position} {before after : HashOutput} {left right : DeferredContext} + (h : PrivatePositionReplaceable target before after left) + (hstate : right.state.values = left.state.values) + (hvalue : right.positionValue target = left.positionValue target) + (hpending : right.state.pending ⊆ left.state.pending) : + PrivatePositionReplaceable target before after right := by + have hnone : right.state.values (.position target) = none := by rw [hstate]; exact h.1 + refine ⟨hnone, ?_, ?_, ?_⟩ + · simpa [DeferredContext.positionValue, hnone, h.1, h.2.1] using hvalue + all_goals + intro hhit + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + have hmem := hpending hhit + first + | apply h.2.2.1 + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff] using hmem + | apply h.2.2.2 + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff] using hmem + +theorem resolveDeferredPositionValue_replacePrivatePosition + (target position : Position) (before after : HashOutput) (context : DeferredContext) + (h : PrivatePositionReplaceable target before after context) : + resolveDeferredPositionValue position (replacePrivatePosition target after context) = + Option.map (replacePrivateResolution target after (some position)) <$> + resolveDeferredPositionValue position context := by + by_cases heq : position = target + · subst position + simp [resolveDeferredPositionValue, replacePrivatePosition, replacePrivateResolution, + DeferredStructuralValues.install, h.1, h.2.1, h.2.2.1, h.2.2.2] + · have hcomm (output : HashOutput) : + (context.values.install target after).install position output = + (context.values.install position output).install target after := by + exact Function.update_comm (Ne.symm heq) (some after) (some output) context.values + cases hstate : context.state.values (.position position) with + | some output => + by_cases hhit : context.state.hitAt (.position position) output <;> + simp [resolveDeferredPositionValue, replacePrivatePosition, replacePrivateResolution, + hstate, hhit, heq, hcomm] + | none => + cases hvalue : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output <;> + simp [resolveDeferredPositionValue, replacePrivatePosition, replacePrivateResolution, + DeferredStructuralValues.install, hstate, hvalue, hhit, heq] + | none => + simp only [resolveDeferredPositionValue, replacePrivatePosition, DeferredStructuralValues.install, + hstate, Function.update_of_ne heq, hvalue, map_bind] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] + · simpa [hhit, replacePrivateResolution, replacePrivatePosition, heq, + DeferredStructuralValues.install] using hcomm output + +theorem resolveDeferredChainStart_replacePrivatePosition + (target : Position) (after : HashOutput) (table : OtsSecretIndex → HashOutput) + (index : OtsSecretIndex) (context : DeferredContext) : + resolveDeferredChainStart table index (replacePrivatePosition target after context) = + (resolveDeferredChainStart table index context).map (replacePrivateResolution target after none) := by + cases hstate : context.state.values index.coordinate <;> + simp [resolveDeferredChainStart, replacePrivatePosition, hstate] <;> + split_ifs <;> rfl + +theorem PrivatePositionReplaceable.positionValue + {target : Position} {before after : HashOutput} {context : DeferredContext} + (h : PrivatePositionReplaceable target before after context) : + context.positionValue target = some before := by + simp [DeferredContext.positionValue, h.1, h.2.1] + +def chainPrefixResultPosition (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + (steps : Nat) → steps ≤ chainLength - 1 → Option Position + | 0, _ => none + | steps + 1, hsteps => some (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + +theorem evalDist_resolveDeferredChainPrefix_replacePrivatePosition + (target : Position) (before after : HashOutput) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps context, PrivatePositionReplaceable target before after context → + evalDist (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps + (replacePrivatePosition target after context)) = + evalDist (Option.map (replacePrivateResolution target after + (chainPrefixResultPosition lay tree leafIdx chainIdx steps hsteps)) <$> + resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) + | 0, hsteps, context, h => by + simp only [resolveDeferredChainPrefix, chainPrefixResultPosition, map_pure, + resolveDeferredChainStart_replacePrivatePosition] + | steps + 1, hsteps, context, h => by + simp only [resolveDeferredChainPrefix, chainPrefixResultPosition] + rw [evalDist_bind, + evalDist_resolveDeferredChainPrefix_replacePrivatePosition target before after table lay tree leafIdx chainIdx + steps (by omega) context h, ← evalDist_bind, bind_map_left, map_bind] + apply evalDist_bind_congr + intro option hoption + cases option with + | none => simp + | some result => + have hnext := h.of_transition + (resolveDeferredChainPrefix_preserves_state_values table lay tree leafIdx chainIdx steps (by omega) + context result hoption) + ((resolveDeferredChainPrefix_preserves_positionValue table lay tree leafIdx chainIdx steps (by omega) + context result target before h.positionValue hoption).trans h.positionValue.symm) + (resolveDeferredChainPrefix_pending_subset table lay tree leafIdx chainIdx steps (by omega) + context result hoption) + exact congrArg evalDist (resolveDeferredPositionValue_replacePrivatePosition target + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) before after result.toDeferredContext hnext) + +theorem evalDist_resolveDeferredChains_replacePrivatePosition + (target : Position) (before after : HashOutput) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ∀ chains context, PrivatePositionReplaceable target before after context → + evalDist (resolveDeferredChains table lay tree leafIdx chains (replacePrivatePosition target after context)) = + evalDist (Option.map (replacePrivatePosition target after) <$> + resolveDeferredChains table lay tree leafIdx chains context) + | [], context, _ => by simp [resolveDeferredChains] + | chainIdx :: remaining, context, h => by + simp only [resolveDeferredChains] + rw [evalDist_bind, + evalDist_resolveDeferredChainPrefix_replacePrivatePosition target before after table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context h, ← evalDist_bind, bind_map_left, map_bind] + apply evalDist_bind_congr + intro option hoption + cases option with + | none => simp + | some result => + have hnext := h.of_transition + (resolveDeferredChainPrefix_preserves_state_values table lay tree leafIdx chainIdx (chainLength - 1) (by omega) + context result hoption) + ((resolveDeferredChainPrefix_preserves_positionValue table lay tree leafIdx chainIdx (chainLength - 1) (by omega) + context result target before h.positionValue hoption).trans h.positionValue.symm) + (resolveDeferredChainPrefix_pending_subset table lay tree leafIdx chainIdx (chainLength - 1) (by omega) + context result hoption) + exact evalDist_resolveDeferredChains_replacePrivatePosition target before after table lay tree leafIdx + remaining result.toDeferredContext hnext + +theorem evalDist_resolveDeferredOtsLeaf_replacePrivatePosition + (target : Position) (before after : HashOutput) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (context : DeferredContext) + (h : PrivatePositionReplaceable target before after context) : + evalDist (resolveDeferredOtsLeaf table lay tree leafIdx (replacePrivatePosition target after context)) = + evalDist (Option.map (replacePrivateResolution target after (some (.leaf lay tree leafIdx))) <$> + resolveDeferredOtsLeaf table lay tree leafIdx context) := by + unfold resolveDeferredOtsLeaf + rw [evalDist_bind, evalDist_resolveDeferredChains_replacePrivatePosition target before after table lay tree leafIdx + _ context h, ← evalDist_bind, bind_map_left, map_bind] + apply evalDist_bind_congr + intro option hoption + cases option with + | none => simp + | some result => + have hnext := h.of_transition + (resolveDeferredChains_preserves_state_values table lay tree leafIdx _ context result hoption) + ((resolveDeferredChains_preserves_positionValue table lay tree leafIdx _ context result target before + h.positionValue hoption).trans h.positionValue.symm) + (resolveDeferredChains_pending_subset table lay tree leafIdx _ context result hoption) + exact congrArg evalDist (resolveDeferredPositionValue_replacePrivatePosition target (.leaf lay tree leafIdx) + before after result hnext) + +theorem evalDist_resolveDeferredTreeNode_replacePrivatePosition + (target : Position) (before after : HashOutput) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel context, PrivatePositionReplaceable target before after context → + evalDist (resolveDeferredTreeNode table lay tree level nodeIdx hlevel (replacePrivatePosition target after context)) = + evalDist (Option.map (replacePrivateResolution target after (some (deferredTreePosition lay tree level nodeIdx hlevel))) <$> + resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) + | 0, nodeIdx, hlevel, context, h => + evalDist_resolveDeferredOtsLeaf_replacePrivatePosition target before after table lay tree (leafOfNat nodeIdx) context h + | level + 1, nodeIdx, hlevel, context, h => by + simp only [resolveDeferredTreeNode, deferredTreePosition] + rw [evalDist_bind, + evalDist_resolveDeferredTreeNode_replacePrivatePosition target before after table lay tree + level (2 * nodeIdx) (by omega) context h, ← evalDist_bind, bind_map_left, map_bind] + apply evalDist_bind_congr + intro leftOption hleft + cases leftOption with + | none => simp + | some left => + have hnext := h.of_transition + (resolveDeferredTreeNode_preserves_state_values table lay tree level (2 * nodeIdx) (by omega) context left hleft) + ((resolveDeferredTreeNode_preserves_positionValue table lay tree level (2 * nodeIdx) (by omega) + context left target before h.positionValue hleft).trans h.positionValue.symm) + (resolveDeferredTreeNode_pending_subset table lay tree level (2 * nodeIdx) (by omega) context left hleft) + dsimp only [Option.map, replacePrivateResolution] + rw [evalDist_bind, + evalDist_resolveDeferredTreeNode_replacePrivatePosition target before after table lay tree + level (2 * nodeIdx + 1) (by omega) left.toDeferredContext hnext, + ← evalDist_bind, bind_map_left, map_bind] + apply evalDist_bind_congr + intro rightOption hright + cases rightOption with + | none => simp + | some right => + have hfinal := hnext.of_transition + (resolveDeferredTreeNode_preserves_state_values table lay tree level (2 * nodeIdx + 1) (by omega) + left.toDeferredContext right hright) + ((resolveDeferredTreeNode_preserves_positionValue table lay tree level (2 * nodeIdx + 1) (by omega) + left.toDeferredContext right target before hnext.positionValue hright).trans hnext.positionValue.symm) + (resolveDeferredTreeNode_pending_subset table lay tree level (2 * nodeIdx + 1) (by omega) + left.toDeferredContext right hright) + exact congrArg evalDist (resolveDeferredPositionValue_replacePrivatePosition target + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) before after right.toDeferredContext hfinal) + +theorem evalDist_resolveDeferredPosition_replacePrivatePosition + (target position : Position) (before after : HashOutput) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (h : PrivatePositionReplaceable target before after context) : + evalDist (resolveDeferredPosition table position (replacePrivatePosition target after context)) = + evalDist (Option.map (replacePrivateResolution target after (some position)) <$> + resolveDeferredPosition table position context) := by + cases position with + | chain lay tree leafIdx chainIdx step => + simpa only [resolveDeferredPosition, chainPrefixResultPosition] using + evalDist_resolveDeferredChainPrefix_replacePrivatePosition target before after table lay tree leafIdx chainIdx + (step.val + 1) (by have := step.isLt; omega) context h + | leaf lay tree leafIdx => + exact evalDist_resolveDeferredOtsLeaf_replacePrivatePosition target before after table lay tree leafIdx context h + | node lay tree level nodeIdx => + simpa only [resolveDeferredPosition, deferredTreePosition, leafOfNat, Nat.mod_eq_of_lt nodeIdx.isLt, Fin.eta] using + evalDist_resolveDeferredTreeNode_replacePrivatePosition target before after table lay tree + (level.val + 1) nodeIdx (by have := level.isLt; omega) context h + | ftsLeaf | ftsNode | ftsRoots => + exact congrArg evalDist (resolveDeferredPositionValue_replacePrivatePosition target _ before after context h) + +theorem evalDist_resolveDeferredReveal_replacePrivatePosition + (target position : Position) (before after : HashOutput) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (h : PrivatePositionReplaceable target before after context) : + evalDist (resolveDeferredReveal table position (replacePrivatePosition target after context)) = + evalDist (Option.map (replacePrivateResolution target after (some position)) <$> + resolveDeferredReveal table position context) := by + unfold resolveDeferredReveal + split_ifs + · exact evalDist_resolveDeferredPosition_replacePrivatePosition target position before after table context h + · exact congrArg evalDist (resolveDeferredPositionValue_replacePrivatePosition target position before after context h) + +theorem replacePrivatePosition_materialized_value_none_iff + (target : Position) (after : HashOutput) (context : DeferredContext) + (hknown : context.positionValue target ≠ none) (coordinate : Coordinate) : + (materializedDeferredState (replacePrivatePosition target after context)).values coordinate = none ↔ + (materializedDeferredState context).values coordinate = none := by + cases coordinate with + | chainStart => rfl + | position position => + by_cases heq : position = target + · subst position + cases hstate : context.state.values (.position target) <;> + simp_all [materializedDeferredState, replacePrivatePosition, DeferredContext.positionValue, + DeferredStructuralValues.install] + · simp [materializedDeferredState, replacePrivatePosition, DeferredContext.positionValue, + DeferredStructuralValues.install, heq] + +theorem candidateCharges_replacePrivatePosition + (target : Position) (after : HashOutput) (context : DeferredContext) + (hknown : context.positionValue target ≠ none) (candidate : Option Probe) : + (unmaterializedCandidateCharge (materializedDeferredState (replacePrivatePosition target after context)) candidate, + materializedCandidateCharge (materializedDeferredState (replacePrivatePosition target after context)) candidate) = + (unmaterializedCandidateCharge (materializedDeferredState context) candidate, + materializedCandidateCharge (materializedDeferredState context) candidate) := by + cases candidate with + | none => rfl + | some candidate => + simp only [unmaterializedCandidateCharge, materializedCandidateCharge, LazyRevealProbe.pendingProbeCharge, + ne_eq, replacePrivatePosition_materialized_value_none_iff target after context hknown] + rfl + +theorem canonicalWeightedHashCharge_replacePrivatePosition + (target : Position) (after : HashOutput) (context : DeferredContext) + (hknown : context.positionValue target ≠ none) (parameter : PublicParameter) (input : HashInput) : + canonicalWeightedHashCharge parameter input (replacePrivatePosition target after context) = + canonicalWeightedHashCharge parameter input context := by + have hunmaterialized := congrArg Prod.fst (candidateCharges_replacePrivatePosition target after context hknown + (purePlanProbingHashQuery parameter input context.state).candidate?) + have hmaterialized := congrArg Prod.snd (candidateCharges_replacePrivatePosition target after context hknown + (rootAwarePlannedCandidate? parameter input context.state)) + dsimp only at hunmaterialized hmaterialized + unfold canonicalWeightedHashCharge + change ((unmaterializedCandidateCharge (materializedDeferredState (replacePrivatePosition target after context)) + (purePlanProbingHashQuery parameter input context.state).candidate? : ENNReal) * (4 / 3) + + (materializedCandidateCharge (materializedDeferredState (replacePrivatePosition target after context)) + (rootAwarePlannedCandidate? parameter input context.state) : ENNReal) * (4 / 3)) = _ + rw [hunmaterialized, hmaterialized] + +theorem canonicalizeMaterializedValues_replacePrivatePosition + (target : Position) (after : HashOutput) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (hhidden : Coordinate.position target ∉ context.state.revealed) : + canonicalizeMaterializedValues table (replacePrivatePosition target after context) = + replacePrivatePosition target after (canonicalizeMaterializedValues table context) := by + have hpublic : publicMaterializedValues table (replacePrivatePosition target after context) = + publicMaterializedValues table context := by + funext coordinate + cases coordinate with + | chainStart => rfl + | position position => + by_cases heq : position = target + · subst position + simp [publicMaterializedValues, replacePrivatePosition, hhidden] + · simp [publicMaterializedValues, replacePrivatePosition, resolvedCompletionValue, + DeferredContext.positionValue, DeferredStructuralValues.install, heq] + unfold canonicalizeMaterializedValues + rw [hpublic] + rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateWeightedGame.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateWeightedGame.lean new file mode 100644 index 00000000..33fe8ef6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateWeightedGame.lean @@ -0,0 +1,168 @@ +import SphincsSecurity.Proof.OtsProbePrivateWeightedRisk +import SphincsSecurity.Proof.OtsProbeInitializedGameCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem initializedNative_joint_probe_count_le_actual_ots_count + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + expectedLiveResolvedQueryCharge chainStartProbeQueryCharge (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + (ensuredInitialContext targets) fuel table + + expectedLiveResolvedQueryCharge structuralProbeQueryCharge (nativeChronologicalRetainedComputation adversary parameter ftsSecret) + (ensuredInitialContext targets) fuel table ≤ + expectedQueryCharge (fun _ input => otsHashInputCharge parameter input) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) ∅ := by + have hbound := initializedNative_joint_charge_le_gameDirectCharge targets adversary parameter table ftsSecret fuel + unfold directOtsQueryCharge at hbound + rw [expectedQueryCharge_mul] at hbound + have hcancel : (4 / 3 : ENNReal) * (3 / 4) = 1 := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + norm_num [ENNReal.toReal_mul, ENNReal.toReal_div] + simpa only [mul_assoc, hcancel, mul_one] using mul_le_mul' hbound (le_refl (3 / 4 : ENNReal)) + +theorem sum_targets_privateHits_ensuredInitial_le_historyRate + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q fuel : Nat) (table : OtsSecretIndex → HashOutput) (hq : q < Fintype.card Digest) : + (∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table (ensuredInitialContext targets) fuel (privatePositionProbeCutAt target computation ordinal)]) ≤ + expectedLiveResolvedQueryCharge structuralProbeQueryCharge computation (ensuredInitialContext targets) fuel table * + privateHistoryGuessRate q := by + apply sum_targets_privateHits_le_live_structural_rate targets computation q (ensuredInitialContext targets) fuel table q + (ensuredInitialContext_valid targets) (ensuredInitialContext_completable targets table) + (ensuredInitialContext_mem_ensured targets) + · intro target _ + rfl + · intro target _ + rfl + · intro target _ + simp [ensuredInitialContext, LazyRevealProbe.State.empty] + · intro target _ + simp [ensuredInitialContext, LazyRevealProbe.State.empty, LazyRevealProbe.State.pendingAt] + · exact hq + +noncomputable def sampledInitializedPrivateHitRisk + (targets : Finset Position) (adversary : Adversary) (fuel q : Nat) : ENNReal := + ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + ∑' table, Pr[= table | sampleOtsHashTable] * + ∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table (ensuredInitialContext targets) fuel + (privatePositionProbeCutAt target (nativeChronologicalRetainedComputation adversary parameter ftsSecret) ordinal)] + +theorem uniformTable_actualOtsCount_le_sampledSecrets + (adversary : Adversary) (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + (∑' table, Pr[= table | sampleOtsHashTable] * + expectedQueryCharge (fun _ input => otsHashInputCharge parameter input) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) ∅) ≤ + ∑' otsSecret, Pr[= otsSecret | sampleOtsSecrets] * + expectedQueryCharge (fun _ input => otsHashInputCharge parameter input) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ := by + have hbound := expected_cost_le_of_relTriple relTriple_uniformOtsHashTable_sampleOtsSecrets + (fun table => expectedQueryCharge (fun _ input => otsHashInputCharge parameter input) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) ∅) + (fun otsSecret => expectedQueryCharge (fun _ input => otsHashInputCharge parameter input) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅) + (fun _ => 0) (by + intro table otsSecret hsecrets + rw [← hsecrets, add_zero] + exact le_rfl) + simpa only [sampleOtsHashTable, mul_zero, tsum_zero, add_zero] using hbound + +theorem sampledInitializedPrivateHitRisk_le_actualOtsCount + (targets : Finset Position) (adversary : Adversary) (fuel q : Nat) (hq : q < Fintype.card Digest) : + sampledInitializedPrivateHitRisk targets adversary fuel q ≤ + sampledQueryCharge (fun secretKey _ input => otsHashInputCharge secretKey.parameter input) adversary * + privateHistoryGuessRate q := by + calc + _ ≤ ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + ((∑' otsSecret, Pr[= otsSecret | sampleOtsSecrets] * + expectedQueryCharge (fun _ input => otsHashInputCharge parameter input) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅) * privateHistoryGuessRate q) := by + apply ENNReal.tsum_le_tsum + intro parameter + apply mul_le_mul' le_rfl + apply ENNReal.tsum_le_tsum + intro ftsSecret + apply mul_le_mul' le_rfl + apply le_trans _ (mul_le_mul' (uniformTable_actualOtsCount_le_sampledSecrets adversary parameter ftsSecret) le_rfl) + rw [← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro table + rw [mul_assoc] + apply mul_le_mul' le_rfl + apply (sum_targets_privateHits_ensuredInitial_le_historyRate targets + (nativeChronologicalRetainedComputation adversary parameter ftsSecret) q fuel table hq).trans + apply mul_le_mul' _ le_rfl + exact (le_add_self : _ ≤ _ + _).trans + (initializedNative_joint_probe_count_le_actual_ots_count targets adversary parameter table ftsSecret fuel) + _ = _ := by + unfold sampledQueryCharge + simp only [sampleSecrets, tsum_probOutput_bind_mul, tsum_probOutput_pure_mul, primitiveAccountingKey] + simp only [← ENNReal.tsum_mul_left, ← ENNReal.tsum_mul_right, mul_assoc] + apply tsum_congr + intro parameter + rw [ENNReal.tsum_comm] + apply tsum_congr + intro otsSecret + apply tsum_congr + intro ftsSecret + ring + +theorem sampledInitializedPrivateHitRisk_le_actualOtsCount127 + (targets : Finset Position) (adversary : Adversary) (fuel q : Nat) (hq : q ≤ 2 ^ 127) : + sampledInitializedPrivateHitRisk targets adversary fuel q ≤ + sampledQueryCharge (fun secretKey _ input => otsHashInputCharge secretKey.parameter input) adversary * + ((2 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply (sampledInitializedPrivateHitRisk_le_actualOtsCount targets adversary fuel q + (hq.trans_lt (by norm_num [digestBits]))).trans + exact mul_le_mul' le_rfl (privateHistoryGuessRate_le_two hq) + +theorem sampledInitializedPrivateHitRisk_le_queryBudget + (targets : Finset Position) (adversary : Adversary) (fuel q : Nat) + (hq : HasHashQueryBound scheme adversary q) (hqSpace : q < Fintype.card Digest) : + sampledInitializedPrivateHitRisk targets adversary fuel q ≤ (q : ENNReal) * privateHistoryGuessRate q := by + apply (sampledInitializedPrivateHitRisk_le_actualOtsCount targets adversary fuel q hqSpace).trans + apply mul_le_mul' _ le_rfl + simpa only [one_mul] using sampledQueryCharge_le_const + (fun secretKey _ input => otsHashInputCharge secretKey.parameter input) 1 (by + intro secretKey cache input + unfold otsHashInputCharge + split_ifs <;> simp) adversary q hq + +theorem sampledInitializedNativeDirectRisk_eq_start_add_private + (targets : Finset Position) (adversary : Adversary) (fuel q : Nat) : + sampledInitializedNativeDirectRisk targets adversary fuel q = + (∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + ∑ ordinal ∈ Finset.range q, Pr[LiveUnresolvedStartHit nativeCutCandidate | + sampledEnsuredNativeProbeCut targets (nativeChronologicalRetainedComputation adversary parameter ftsSecret) fuel ordinal]) + + sampledInitializedPrivateHitRisk targets adversary fuel q := by + unfold sampledInitializedNativeDirectRisk initializedNativeDirectRisk sampledInitializedPrivateHitRisk + simp_rw [mul_add, ENNReal.tsum_add] + simp only [mul_add, ENNReal.tsum_add] + +theorem sampledInitializedNativeDirectRisk_le_start_add_historyRate + (targets : Finset Position) (adversary : Adversary) (fuel q : Nat) (hq : q < Fintype.card Digest) : + sampledInitializedNativeDirectRisk targets adversary fuel q ≤ + (∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + ∑ ordinal ∈ Finset.range q, Pr[LiveUnresolvedStartHit nativeCutCandidate | + sampledEnsuredNativeProbeCut targets (nativeChronologicalRetainedComputation adversary parameter ftsSecret) fuel ordinal]) + + sampledQueryCharge (fun secretKey _ input => otsHashInputCharge secretKey.parameter input) adversary * + privateHistoryGuessRate q := by + rw [sampledInitializedNativeDirectRisk_eq_start_add_private] + exact add_le_add le_rfl (sampledInitializedPrivateHitRisk_le_actualOtsCount targets adversary fuel q hq) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateWeightedRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateWeightedRisk.lean new file mode 100644 index 00000000..51d5638f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePrivateWeightedRisk.lean @@ -0,0 +1,125 @@ +import SphincsSecurity.Proof.OtsProbePrivateHistoryRate +import SphincsSecurity.Proof.OtsProbePrivateValueLiveProbeCounting + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def privateProbeHistoryWeightedCharge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) : ENNReal := + privateHistoryWeightedOccurrence (runPrivateProbeRecords target computation context fuel table ordinal) + (privateProbeRecordCandidate target) (fun record => record.context.state.pendingAt (.position target)) + +theorem probEvent_samplePrivateProbeRecords_hit_le_historyWeightedCharge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (hcard : (context.state.pendingAt (.position target)).card + ordinal < Fintype.card Digest) : + Pr[fun pair => pair.2 = some (truncateHash pair.1) | samplePrivateHistoryGuess + (runPrivateProbeRecords target computation context fuel table ordinal) (privateProbeRecordCandidate target)] ≤ + privateProbeHistoryWeightedCharge target computation context fuel table ordinal := by + apply probEvent_samplePrivateHistoryGuess_hit_le_weighted + · exact probOutput_runPrivateProbeRecords_eq_of_compatible target computation context fuel table ordinal hstate hhidden + · intro output record hhit + exact probOutput_runPrivateProbeRecords_eq_zero_of_history_hit target computation context fuel table ordinal + output hstate hhidden record hhit + · intro output record hrecord + exact (runPrivateProbeRecords_supported_history target computation context fuel table ordinal output + hstate hhidden record hrecord).2.1.trans_lt hcard + +theorem privateProbeHistoryWeightedCharge_le_rate_mul_charge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal budget : Nat) + (hstate : context.state.values (.position target) = none) (hhidden : .position target ∉ context.state.revealed) + (hcard : (context.state.pendingAt (.position target)).card + ordinal ≤ budget) : + privateProbeHistoryWeightedCharge target computation context fuel table ordinal ≤ + sampledPrivateProbeCharge target computation context fuel table ordinal * privateHistoryGuessRate budget := by + rw [← probEvent_samplePrivateProbeRecords_occurrence_eq_charge target computation context fuel table ordinal hstate hhidden] + apply privateHistoryWeightedOccurrence_le_budget + intro output record hrecord + exact (runPrivateProbeRecords_supported_history target computation context fuel table ordinal output + hstate hhidden record hrecord).2.1.trans hcard + +theorem probEvent_privateResolvedRawCandidate_hit_le_historyWeightedCharge + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hhidden : .position target ∉ context.state.revealed) + (hcard : (context.state.pendingAt (.position target)).card + ordinal < Fintype.card Digest) : + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target computation ordinal)] ≤ + privateProbeHistoryWeightedCharge target computation context fuel table ordinal := by + have hdist := evalDist_privateResolvedRawCandidate_eq_sampled target computation context fuel table ordinal + hvalid hcomplete hensured hstate hvalue hhidden + rw [probEvent_congr' (fun _ _ => Iff.rfl) hdist, probEvent_map] + have hevent (pair : HashOutput × Option Digest) : PrivateCandidatePairHit (privateSampledCandidatePair pair) ↔ + pair.2 = some (truncateHash pair.1) := by + rcases pair with ⟨output, candidate⟩ + cases candidate <;> simp [privateSampledCandidatePair, PrivateCandidatePairHit] + have hprob := probEvent_congr' (fun pair _ => hevent pair) + (rfl : evalDist (samplePrivateHistoryGuess (runPrivateProbeRecords target computation context fuel table ordinal) + (privateRawRecordCandidate target)) = _) + simp only [Function.comp_def] + rw [hprob, probEvent_samplePrivateProbeRecords_raw_hit_eq_fresh_hit target computation context fuel table ordinal hstate hhidden] + exact probEvent_samplePrivateProbeRecords_hit_le_historyWeightedCharge target computation context fuel table ordinal + hstate hhidden hcard + +theorem probEvent_privateResolvedRawCandidate_hit_le_live_cut_rate + (target : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (ordinal budget : Nat) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : .position target ∈ context.state.ensured) + (hstate : context.state.values (.position target) = none) (hvalue : context.values target = none) + (hhidden : .position target ∉ context.state.revealed) + (hcard : (context.state.pendingAt (.position target)).card + ordinal ≤ budget) + (hbudget : budget < Fintype.card Digest) : + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target computation ordinal)] ≤ + Pr[LivePrivateProbeCutReached target | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)] * + privateHistoryGuessRate budget := by + apply (probEvent_privateResolvedRawCandidate_hit_le_historyWeightedCharge target computation context fuel table ordinal + hvalid hcomplete hensured hstate hvalue hhidden (hcard.trans_lt hbudget)).trans + apply (privateProbeHistoryWeightedCharge_le_rate_mul_charge target computation context fuel table ordinal budget + hstate hhidden hcard).trans + exact mul_le_mul' (sampledPrivateProbeCharge_le_live_cut target computation context fuel table ordinal + hvalid hcomplete hensured hstate hvalue hhidden) le_rfl + +theorem sum_targets_privateHits_le_live_structural_rate + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (q : Nat) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (budget : Nat) + (hvalid : context.Valid) (hcomplete : DeferredCompletable table context) + (hensured : ∀ target ∈ targets, .position target ∈ context.state.ensured) + (hstate : ∀ target ∈ targets, context.state.values (.position target) = none) + (hvalue : ∀ target ∈ targets, context.values target = none) + (hhidden : ∀ target ∈ targets, .position target ∉ context.state.revealed) + (hcard : ∀ target ∈ targets, (context.state.pendingAt (.position target)).card + q ≤ budget) + (hbudget : budget < Fintype.card Digest) : + (∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[PrivateCandidatePairHit | privateResolvedSelectedCandidate target (privateRawCutCandidate target) <$> + runPrivateResolvedView target table context fuel (privatePositionProbeCutAt target computation ordinal)]) ≤ + expectedLiveResolvedQueryCharge structuralProbeQueryCharge computation context fuel table * + privateHistoryGuessRate budget := by + calc + _ ≤ ∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[LivePrivateProbeCutReached target | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)] * + privateHistoryGuessRate budget := by + apply Finset.sum_le_sum + intro target htarget + apply Finset.sum_le_sum + intro ordinal hordinal + apply probEvent_privateResolvedRawCandidate_hit_le_live_cut_rate target computation context fuel table ordinal budget + hvalid hcomplete (hensured target htarget) (hstate target htarget) (hvalue target htarget) (hhidden target htarget) _ hbudget + exact (Nat.add_le_add_left (Nat.le_of_lt (Finset.mem_range.mp hordinal)) _).trans (hcard target htarget) + _ = (∑ target ∈ targets, ∑ ordinal ∈ Finset.range q, + Pr[LivePrivateProbeCutReached target | runResolvedFromTable context fuel table (privatePositionProbeCutAt target computation ordinal)]) * + privateHistoryGuessRate budget := by simp only [Finset.sum_mul] + _ ≤ _ := mul_le_mul' (sum_targets_livePrivateProbeCutReached_le_expectedStructuralCharge targets computation q context fuel table + hvalid.valuesConsistent (startTableAgrees_of_deferredCompletable hcomplete)) le_rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeProbeFreeRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeProbeFreeRisk.lean new file mode 100644 index 00000000..75afc6d5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeProbeFreeRisk.lean @@ -0,0 +1,236 @@ +import SphincsSecurity.Proof.OtsProbeRecursiveRejectionRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option backward.isDefEq.respectTransparency false + +theorem evalDist_finalize_failure_of_coreEq + (table : OtsSecretIndex → HashOutput) (left right : DeferredContext) + (hvalid : left.Valid) (hstarts : StartTableAgrees left.state table) + (hcomplete : DeferredCompletable table left) (heq : left.CoreEq right) : + evalDist (Option.isNone <$> finalizeResolvedCoordinates left.state.coordinates.toList left table) = + evalDist (Option.isNone <$> finalizeResolvedCoordinates right.state.coordinates.toList right table) := by + have hrightValid := hvalid.of_coreEq heq + have hrightStarts := hstarts.of_coreEq heq + have hvalues : resolvedCompletionValue table left = resolvedCompletionValue table right := by + funext coordinate + cases coordinate with + | chainStart => rfl + | position position => exact congrFun heq.positionValue_eq position + have hview := finalizationViewEq_of_deferredCompletion_iff hvalid hrightValid hstarts hrightStarts + hvalues hcomplete (fun completion => + ⟨fun h => h.of_coreEq heq, fun h => h.of_coreEq heq.symm⟩) + exact evalDist_map_isNone_finalizeResolvedCoordinates_congr_covered table _ _ left right hview + (Finset.nodup_toList _) (Finset.nodup_toList _) + (pendingCovered_coordinates_toList _) (pendingCovered_coordinates_toList _) + +theorem evalDist_resolveDeferredChainStart_then_finalize_materialized + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) (context : DeferredContext) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hcomplete : DeferredCompletable table context) + (hcard : context.state.pending.card < Fintype.card Digest) : + evalDist (match resolveDeferredChainStart table index context with + | none => (pure true : ProbComp Bool) + | some result => Option.isNone <$> (finalizeResolvedCoordinates + (materializeResolvedChainStart context index result).state.coordinates.toList + (materializeResolvedChainStart context index result) table)) = + evalDist (Option.isNone <$> finalizeResolvedCoordinates context.state.coordinates.toList context table) := by + let coordinates := context.state.coordinates.toList + have hbase := congrArg (Functor.map Option.isNone) + (evalDist_map_resolveDeferredChainStart_then_finalize table index coordinates context + hvalid (pendingCovered_coordinates_toList context)) + rw [← evalDist_map, ← evalDist_map, Functor.map_map] at hbase + have hright : (fun option => (projectDeferredState option).isNone) = + (Option.isNone : Option DeferredContext → Bool) := by + funext option; cases option <;> rfl + rw [hright] at hbase + apply Eq.trans ?_ hbase + cases hresult : resolveDeferredChainStart table index context with + | none => simp + | some result => + rw [Functor.map_map, hright] + have hresultValid := hvalid.of_resolveDeferredChainStart table index result hresult + have hresultStarts := hstarts.of_state_values_eq + (resolveDeferredChainStart_state_values_eq table index context result hresult) + have hpending := resolveDeferredChainStart_pending_eq table index context result hresult + have hsubset : result.state.pending ⊆ context.state.pending := by + rw [hpending]; exact Finset.filter_subset _ _ + have hcovered : PendingCovered coordinates result.toDeferredContext := by + intro entry hentry + exact pendingCovered_coordinates_toList context entry (hsubset hentry) + have hfixed := evalDist_finalizeResolvedCoordinates_eq_dynamic table coordinates result.toDeferredContext + hresultValid hresultStarts hcovered (Finset.nodup_toList _) + ((Finset.card_le_card hsubset).trans_lt hcard) + have hview := finalizationViewEq_materializeResolvedChainStart index result hvalid hstarts hresult + (hcomplete.materializeResolvedChainStart hstarts index result hresult) + exact (evalDist_map_isNone_finalizeResolvedCoordinates_congr_covered table _ _ _ _ hview + (Finset.nodup_toList _) (Finset.nodup_toList _) + (pendingCovered_coordinates_toList _) (pendingCovered_coordinates_toList _)).trans hfixed.symm + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 800000 in +theorem evalDist_runResolvedFinishIsNone_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hcard : context.state.pending.card < Fintype.card Digest) : + evalDist (runResolvedFinishIsNone context fuel table computation) = + evalDist (Option.isNone <$> finalizeResolvedCoordinates context.state.coordinates.toList context table) := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp only [runResolvedFinishIsNone, runResolvedFromTable, OracleComp.construct_pure, pure_bind] + exact evalDist_finishResolvedRunIsNone_eq_finalize ⟨context, fuel, value, table⟩ hvalid hstarts hcard + | query_bind input next ih => + by_cases hcomplete : DeferredCompletable table context + · rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + have htail : ∀ output, (next output).IsQueryBoundP LazyRevealProbe.IsProbe 0 := by + intro output + simpa only [Nat.zero_sub, ite_self] using hbound.2 output + cases input with + | uniform n => + rw [runResolvedFinishIsNone, runResolvedFromTable_uniform_query_bind, bind_assoc] + calc + _ = evalDist (do + let _ ← (liftM (unifSpec.query n) : ProbComp _) + Option.isNone <$> finalizeResolvedCoordinates context.state.coordinates.toList context table) := by + apply evalDist_bind_congr + intro output _houtput + exact ih output context fuel (htail output) hvalid hstarts hcard + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails _ (by simp) _ + | hashOutput => + rw [runResolvedFinishIsNone, runResolvedFromTable_hashOutput_query_bind, bind_assoc] + calc + _ = evalDist (do + let _ ← LazyRevealProbe.sampleHashOutput + Option.isNone <$> finalizeResolvedCoordinates context.state.coordinates.toList context table) := by + apply evalDist_bind_congr + intro output _houtput + exact ih output context fuel (htail output) hvalid hstarts hcard + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails _ (by simp) _ + | ensure coordinate => + rw [runResolvedFinishIsNone, runResolvedFromTable_ensure_query_bind] + have heq : context.CoreEq { context with state := context.state.ensure coordinate } := ⟨rfl, rfl, rfl⟩ + exact (ih () _ fuel (htail ()) (hvalid.of_coreEq heq) (hstarts.of_coreEq heq) hcard).trans + (evalDist_finalize_failure_of_coreEq table _ _ hvalid hstarts hcomplete heq).symm + | publish coordinate => + rw [runResolvedFinishIsNone, runResolvedFromTable_publish_query_bind] + have heq : context.CoreEq { context with state := context.state.publish coordinate } := ⟨rfl, rfl, rfl⟩ + exact (ih () _ fuel (htail ()) (hvalid.of_coreEq heq) (hstarts.of_coreEq heq) hcard).trans + (evalDist_finalize_failure_of_coreEq table _ _ hvalid hstarts hcomplete heq).symm + | peek coordinate => + rw [runResolvedFinishIsNone, runResolvedFromTable_peek_query_bind] + exact ih _ context fuel (htail _) hvalid hstarts hcard + | probe coordinate candidate => simp [LazyRevealProbe.IsProbe] at hbound + | reveal coordinate => + cases coordinate with + | position position => + rw [runResolvedFinishIsNone, runResolvedFromTable_reveal_query_bind, bind_assoc] + apply Eq.trans ?_ (evalDist_resolveDeferredReveal_then_finalize_materialized + table position context hvalid hstarts hcard) + apply evalDist_bind_congr + intro option hoption + cases option with + | none => simp [finishResolvedRunIsNone, finishResolvedRun] + | some result => + have hresolvedValid := hvalid.of_resolveDeferredReveal table position result hoption + have hvalues := resolveDeferredReveal_preserves_state_values table position context result hoption + have hresolved := resolveDeferredReveal_resolves table position context result hoption + exact ih result.output _ fuel (htail result.output) + (hvalid.materializeResolvedPosition_of position result hresolvedValid hvalues hresolved) + (hstarts.materialize_position position result.output) + ((Finset.card_le_card (Finset.filter_subset _ _)).trans_lt hcard) + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + rw [runResolvedFinishIsNone, runResolvedFromTable_reveal_query_bind] + dsimp only + rw [pure_bind] + apply Eq.trans ?_ (evalDist_resolveDeferredChainStart_then_finalize_materialized + table index context hvalid hstarts hcomplete hcard) + cases hresult : resolveDeferredChainStart table index context with + | none => simp [finishResolvedRunIsNone, finishResolvedRun] + | some result => + have hdeferred := resolveDeferredChainStart_deferred_values_eq table index context result hresult + have houtput := resolveDeferredChainStart_output_of_agrees table index context result hstarts hresult + have hnextValid : (materializeResolvedChainStart context index result).Valid := by + rw [materializeResolvedChainStart, hdeferred] + exact hvalid.materialize_chainStart lay tree leafIdx chainIdx result.output + have hnextStarts : StartTableAgrees (materializeResolvedChainStart context index result).state table := by + simp only [materializeResolvedChainStart, houtput] + exact hstarts.materialize_start index + simpa only [index, hresult, materializeResolvedChainStart, OtsSecretIndex.coordinate, + runResolvedFinishIsNone] using + ih result.output _ fuel (htail result.output) hnextValid hnextStarts + ((Finset.card_le_card (Finset.filter_subset _ _)).trans_lt hcard) + · rw [runResolvedFinishIsNone, + evalDist_runResolvedFinishIsNone_eq_true_of_not_completable context fuel table _ + hvalid.valuesConsistent hstarts hcomplete, + evalDist_map, evalDist_finalizeResolvedCoordinates_eq_none_of_not_completable table _ context + hvalid hstarts (pendingCovered_coordinates_toList _) hcard hcomplete] + simp + +theorem evalDist_finish_canonicalizeResolvedRun + (result : ResolvedRunResult α) (hvalid : result.context.Valid) + (hstarts : StartTableAgrees result.context.state result.table) : + evalDist (finishResolvedRunIsNone (canonicalizeResolvedRun result.table (some result))) = + evalDist (finishResolvedRunIsNone (some result)) := by + by_cases hcomplete : DeferredCompletable result.table result.context + · have hcanonical := valid_completable_canonicalizeMaterializedValues result.table result.context hvalid hcomplete + have hview := finalizationViewEq_canonicalize_left result.table result.context hvalid hstarts + (fun coordinate output hvalue hhit => hcomplete.not_pendingResolvedHit ⟨coordinate, output, hvalue, hhit⟩) + simp only [canonicalizeResolvedRun] + rw [finishResolvedRunIsNone_some_eq_finalize _ hcanonical.2, + finishResolvedRunIsNone_some_eq_finalize result hcomplete] + exact evalDist_map_isNone_finalizeResolvedCoordinates_congr_covered result.table _ _ _ _ hview + (Finset.nodup_toList _) (Finset.nodup_toList _) + (pendingCovered_coordinates_toList _) (pendingCovered_coordinates_toList _) + · have hcanonical := doomedResolvedContext_canonicalizeMaterializedValues + (show DoomedResolvedContext result.table result.context from ⟨hvalid.valuesConsistent, hstarts, hcomplete⟩) + simp [canonicalizeResolvedRun, finishResolvedRunIsNone, finishResolvedRun, hcomplete, hcanonical.2.2] + +theorem evalDist_canonicalQuery_finished_of_no_hash + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hnoHash : outerHashQueryCount input = 0) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hcard : context.state.pending.card < Fintype.card Digest) : + evalDist (canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache >>= + finishResolvedRunIsNone) = + evalDist (Option.isNone <$> finalizeResolvedCoordinates context.state.coordinates.toList context table) := by + have hbound : ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache).IsQueryBoundP + LazyRevealProbe.IsProbe 0 := by + simpa only [hnoHash] using maskedChronologicalExpandedAdversaryImpl_probeBound parameter root ftsSecret input cache + apply Eq.trans ?_ (evalDist_runResolvedFinishIsNone_of_probeFree _ context fuel table hbound hvalid hstarts hcard) + rw [canonicalChronologicalAdversaryImpl_eq_raw_then_canonicalize, bind_assoc] + unfold runResolvedFinishIsNone + apply evalDist_bind_congr + intro option hoption + simp only [pure_bind] + cases option with + | none => rfl + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table result + hvalid.valuesConsistent hstarts hoption + have hnextValid := (valid_pendingCovered_of_mem_runResolvedFromTable_of_probeFree _ context fuel table result + context.state.coordinates.toList hbound hvalid (pendingCovered_coordinates_toList context) hoption).1 + have heq := evalDist_finish_canonicalizeResolvedRun result hnextValid (hcore.1 ▸ hcore.2.2) + simpa only [hcore.1] using heq + +theorem canonicalQueryRejectionRisk_le_pendingFailureRisk_of_no_hash + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (entry : CanonicalQuerySelection) (hnoHash : outerHashQueryCount entry.input = 0) + (hvalid : entry.context.Valid) (hstarts : StartTableAgrees entry.context.state entry.table) + (hcard : entry.context.state.pending.card < Fintype.card Digest) : + canonicalQueryRejectionRisk parameter root ftsSecret entry ≤ resolvedPendingFailureRisk entry.table entry.context := by + apply (probEvent_resolvedQueryRejected_le_finished _).trans_eq + have heq := congrArg (fun distribution : SPMF Bool => distribution true) + (evalDist_canonicalQuery_finished_of_no_hash parameter root entry.table ftsSecret entry.input entry.context + entry.fuel entry.cache hnoHash hvalid hstarts hcard) + change Pr[= true | _] = Pr[= true | _] at heq + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput, probEvent_map] at heq + simpa only [Function.comp_def, Option.isNone_iff_eq_none, resolvedPendingFailureRisk] using heq + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbePublicHashValues.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbePublicHashValues.lean new file mode 100644 index 00000000..45c37706 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbePublicHashValues.lean @@ -0,0 +1,271 @@ +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveObserver + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local irreducible] maskedPublishedTreeRoot + +def MaterializedValuesPublished (state : LazyRevealProbe.State Coordinate) : Prop := + ∀ coordinate output, state.values coordinate = some output → coordinate ∈ state.revealed + +def ResolvedPreservesPublicMaterialization + (computation : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ context cache fuel table result, MaterializedValuesPublished context.state → + some result ∈ support (runResolvedFromTable context fuel table (computation.run cache)) → + MaterializedValuesPublished result.context.state + +theorem ResolvedPreservesPublicMaterialization.of_preservesCoordinate + {computation : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α} + (hpreserves : ∀ coordinate, ResolvedPreservesCoordinate coordinate computation) : + ResolvedPreservesPublicMaterialization computation := by + intro context cache fuel table result hpublic hresult coordinate output hvalue + have hcoordinate := hpreserves coordinate context fuel table cache result hresult + exact hcoordinate.2.mpr (hpublic coordinate output (hcoordinate.1.symm.trans hvalue)) + +theorem ResolvedPreservesPublicMaterialization.pure (value : α) : + ResolvedPreservesPublicMaterialization (pure value) := + .of_preservesCoordinate fun coordinate => resolvedPreservesCoordinate_pure coordinate value + +theorem ResolvedPreservesPublicMaterialization.bind + {left : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : ResolvedPreservesPublicMaterialization left) + (hnext : ∀ value, ResolvedPreservesPublicMaterialization (next value)) : + ResolvedPreservesPublicMaterialization (left >>= next) := by + intro context cache fuel table result hpublic hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨leftOption, hleftSupport, hrest⟩ := hresult + cases leftOption with + | none => simp at hrest + | some leftResult => + exact hnext leftResult.value.1 leftResult.context leftResult.value.2 leftResult.remaining + leftResult.table result (hleft context cache fuel table leftResult hpublic hleftSupport) hrest + +theorem resolvedPreservesPublicMaterialization_reveal_publish (coordinate : Coordinate) : + ResolvedPreservesPublicMaterialization (do + let output ← revealCoordinateOutput coordinate + publishCoordinate coordinate + pure output) := by + intro context cache fuel table result hpublic hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨revealOption, hreveal, hrest⟩ := hresult + cases revealOption with + | none => simp at hrest + | some revealResult => + simp only at hrest + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hrest + obtain ⟨publishOption, hpublish, hreturn⟩ := hrest + cases publishOption with + | none => simp at hreturn + | some publishResult => + simp [runResolvedFromTable] at hreturn + subst result + change some publishResult ∈ support (runResolvedFromTable revealResult.context + revealResult.remaining revealResult.table + (LazyRevealProbe.publishQuery coordinate >>= fun output => pure (output, revealResult.value.2))) at hpublish + rw [LazyRevealProbe.publishQuery, runResolvedFromTable_publish_query_bind] at hpublish + simp [runResolvedFromTable] at hpublish + subst publishResult + intro other output hvalue + by_cases heq : other = coordinate + · subst other + simp [LazyRevealProbe.State.publish] + · have hpreserved := resolvedPreservesCoordinate_revealCoordinateOutput_of_ne other coordinate heq + context fuel table cache revealResult hreveal + have hbefore : context.state.values other = some output := by + rw [← hpreserved.1] + exact hvalue + have hrevealed := hpreserved.2.mpr (hpublic other output hbefore) + simpa [LazyRevealProbe.State.publish, heq] using hrevealed + +theorem resolvedPreservesPublicMaterialization_resolveKnownInput + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) : + ResolvedPreservesPublicMaterialization (resolveKnownInput parameter coordinate input) := by + unfold resolveKnownInput + apply (ResolvedPreservesPublicMaterialization.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_peekTableInput parameter other coordinate).bind + intro known + cases known with + | none => exact .of_preservesCoordinate fun other => resolvedPreservesCoordinate_splitHashQuery other (.ordinary input) + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + have hpreserves := (resolvedPreservesPublicMaterialization_reveal_publish coordinate).bind fun output => + (ResolvedPreservesPublicMaterialization.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_modify other fun cache => + Function.update cache (.ordinary input) (some output)).bind fun _ => + ResolvedPreservesPublicMaterialization.pure output + simpa only [bind_assoc, pure_bind] using hpreserves + · simp only [heq, ↓reduceIte] + exact .of_preservesCoordinate fun other => resolvedPreservesCoordinate_splitHashQuery other (.ordinary input) + +theorem resolvedPreservesPublicMaterialization_probeFirstMissingInputCoordinate + (input : HashInput) : ∀ slot coordinates, + ResolvedPreservesPublicMaterialization (probeFirstMissingInputCoordinate input slot coordinates) + | _, [] => .pure () + | slot, coordinate :: remaining => by + rw [probeFirstMissingInputCoordinate] + exact (ResolvedPreservesPublicMaterialization.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_peekCoordinate other coordinate).bind fun value => + match value with + | none => .of_preservesCoordinate fun other => + resolvedPreservesCoordinate_probe other ⟨coordinate, slotDigest slot input⟩ + | some _ => resolvedPreservesPublicMaterialization_probeFirstMissingInputCoordinate input (slot + 1) remaining + +theorem resolvedPreservesPublicMaterialization_prepareLeafInputProbe + (input : HashInput) (candidate : Probe) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ResolvedPreservesPublicMaterialization (prepareLeafInputProbe input candidate lay tree leafIdx) := by + unfold prepareLeafInputProbe + apply (ResolvedPreservesPublicMaterialization.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_peekCoordinate other candidate.coordinate).bind + intro value + cases value with + | none => exact .of_preservesCoordinate fun other => resolvedPreservesCoordinate_probe other candidate + | some output => + exact resolvedPreservesPublicMaterialization_probeFirstMissingInputCoordinate input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + +theorem resolvedPreservesPublicMaterialization_probingHashQuery + (parameter : PublicParameter) (input : HashInput) : + ResolvedPreservesPublicMaterialization (probingHashQuery parameter input) := by + unfold probingHashQuery + cases decodeProbe? parameter input with + | some candidate => + cases decodePosition? parameter input with + | some position => + cases position with + | leaf lay tree leafIdx => + exact (resolvedPreservesPublicMaterialization_prepareLeafInputProbe input candidate lay tree leafIdx).bind + fun _ => resolvedPreservesPublicMaterialization_resolveKnownInput parameter candidate.outputCoordinate input + | chain | node | ftsLeaf | ftsNode | ftsRoots => + exact (ResolvedPreservesPublicMaterialization.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_probe other candidate).bind fun _ => + resolvedPreservesPublicMaterialization_resolveKnownInput parameter candidate.outputCoordinate input + | none => + exact (ResolvedPreservesPublicMaterialization.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_probe other candidate).bind fun _ => + resolvedPreservesPublicMaterialization_resolveKnownInput parameter candidate.outputCoordinate input + | none => + cases decodePosition? parameter input with + | none => exact .of_preservesCoordinate fun other => resolvedPreservesCoordinate_splitHashQuery other (.ordinary input) + | some position => + cases position with + | chain | leaf => exact resolvedPreservesPublicMaterialization_resolveKnownInput parameter _ input + | node lay tree level nodeIdx => + exact (resolvedPreservesPublicMaterialization_probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)).bind fun _ => + resolvedPreservesPublicMaterialization_resolveKnownInput parameter _ input + | ftsLeaf | ftsNode | ftsRoots => + exact .of_preservesCoordinate fun other => resolvedPreservesCoordinate_splitHashQuery other (.ordinary input) + +theorem resolvedPreservesPublicMaterialization_splitUniformImpl (n : Nat) : + ResolvedPreservesPublicMaterialization (splitUniformImpl n) := by + intro context cache fuel table result hpublic hresult + change some result ∈ support (runResolvedFromTable context fuel table + (LazyRevealProbe.uniformQuery n >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.uniformQuery, runResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hdone⟩ := hresult + simp [runResolvedFromTable] at hdone + subst result + exact hpublic + +theorem resolvedPreservesPublicMaterialization_probingRomImpl + (parameter : PublicParameter) (query : OracleWorld.Domain) : + ResolvedPreservesPublicMaterialization (probingRomImpl parameter query) := by + cases query with + | inl n => exact resolvedPreservesPublicMaterialization_splitUniformImpl n + | inr input => exact resolvedPreservesPublicMaterialization_probingHashQuery parameter input + +theorem MaterializedValuesPublished.of_canonical + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hcanonical : CanonicalMaterializedValues table context) : MaterializedValuesPublished context.state := by + intro coordinate output hvalue + rw [hcanonical] at hvalue + by_contra hnot + simp [publicMaterializedValues, hnot] at hvalue + +theorem canonicalMaterializedValues_of_public + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hpublic : MaterializedValuesPublished context.state) + (hpublished : PublishedValues context.state) (hstarts : StartTableAgrees context.state table) : + CanonicalMaterializedValues table context := by + funext coordinate + cases hvalue : context.state.values coordinate with + | none => + have hnot : coordinate ∉ context.state.revealed := fun h => hpublished coordinate h hvalue + simp [publicMaterializedValues, hnot] + | some output => + have hrevealed := hpublic coordinate output hvalue + simp only [publicMaterializedValues, hrevealed, ↓reduceIte] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + have heq := hstarts ⟨lay, tree, leafIdx, chainIdx⟩ output hvalue + simp [resolvedCompletionValue, heq] + | position position => simp [resolvedCompletionValue, DeferredContext.positionValue, hvalue] + +theorem resolvedPreservesPublicMaterialization_sequenceFin {n : Nat} + (computation : Fin n → StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, ResolvedPreservesPublicMaterialization (computation index)) : + ResolvedPreservesPublicMaterialization (sequenceFin computation) := by + induction n with + | zero => simpa [sequenceFin] using ResolvedPreservesPublicMaterialization.pure Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomponent 0).bind fun _ => + (ih (fun index : Fin n => computation index.succ) (fun index => hcomponent index.succ)).bind fun _ => .pure _ + +theorem resolvedPreservesPublicMaterialization_ensureOtsLeaf + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ResolvedPreservesPublicMaterialization (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + apply (resolvedPreservesPublicMaterialization_sequenceFin _ fun chainIdx => ?_).bind fun _ => + ResolvedPreservesPublicMaterialization.of_preservesCoordinate fun other => resolvedPreservesCoordinate_ensure other _ + unfold ensureFullChain + exact (resolvedPreservesPublicMaterialization_sequenceFin _ fun _ => + ResolvedPreservesPublicMaterialization.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_ensure other _).bind fun _ => .pure () + +theorem resolvedPreservesPublicMaterialization_ensureTreeNode + (lay : Layer) (tree : TreeIndex) : ∀ level nodeIdx, + ResolvedPreservesPublicMaterialization (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => by + rw [ensureTreeNode] + exact resolvedPreservesPublicMaterialization_ensureOtsLeaf lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (resolvedPreservesPublicMaterialization_ensureTreeNode lay tree level (2 * nodeIdx)).bind fun _ => + (resolvedPreservesPublicMaterialization_ensureTreeNode lay tree level (2 * nodeIdx + 1)).bind fun _ => by + split + · exact .of_preservesCoordinate fun other => resolvedPreservesCoordinate_ensure other _ + · exact .pure () + +theorem resolvedPreservesPublicMaterialization_revealPublishedCoordinate (coordinate : Coordinate) : + ResolvedPreservesPublicMaterialization (revealPublishedCoordinate coordinate) := by + have hpreserves := (resolvedPreservesPublicMaterialization_reveal_publish coordinate).bind fun output => + ResolvedPreservesPublicMaterialization.pure (truncateHash output) + simpa only [revealPublishedCoordinate, revealCoordinate, bind_assoc, pure_bind] using hpreserves + +theorem canonicalMaterializedValues_of_mem_maskedPublishedTreeRoot + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) (fuel : Nat) + (result : ResolvedRunResult (Digest × SplitHashCache)) + (hresult : some result ∈ support (runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) : + CanonicalMaterializedValues table result.context := by + have hpreserves : ResolvedPreservesPublicMaterialization maskedPublishedTreeRoot := by + unfold maskedPublishedTreeRoot + exact (resolvedPreservesPublicMaterialization_ensureTreeNode topLayer rootTree (layerHeight topLayer) 0).bind + fun _ => resolvedPreservesPublicMaterialization_revealPublishedCoordinate _ + have hpublic := hpreserves _ emptySplitHashCache fuel table result (by + intro coordinate output hvalue + simp [LazyRevealProbe.State.empty] at hvalue) hresult + have hcore := resolvedCore_of_mem_runResolved_maskedPublishedTreeRoot parameter table fuel result hresult + have hpubPreserves : ResolvedPreservesPublished maskedPublishedTreeRoot := by + unfold maskedPublishedTreeRoot + exact (resolvedPreservesPublishedValues_ensureTreeNode topLayer rootTree (layerHeight topLayer) 0).bind + fun _ => resolvedPreservesPublishedValues_revealPublishedCoordinate _ + have hpublished := hpubPreserves _ emptySplitHashCache fuel table result publishedValues_empty hresult + exact canonicalMaterializedValues_of_public hpublic hpublished hcore.2.2 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeQueryCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeQueryCharge.lean new file mode 100644 index 00000000..a5febe78 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeQueryCharge.lean @@ -0,0 +1,91 @@ +import SphincsSecurity.Proof.LazyRevealProbeCostBind +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveClean + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot + +theorem probEvent_sampledRunThenFinalizeClean_none_le_expectedCharge + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe fuel) : + Pr[= none | sampledRunThenFinalizeClean state fuel computation] ≤ + (LazyRevealProbe.expectedProbeCharge computation state fuel + (state.pending.card : ℝ≥0∞)) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ = Pr[= none | detailedExperimentCleanWithCompletionTable state fuel computation] := + probOutput_congr rfl (by + unfold sampledRunThenFinalizeClean + exact evalDist_runThenFinalizeCleanFromTable_eq_detailed computation state fuel) + _ = Pr[= true | LazyRevealProbe.experiment state fuel computation] := + probEvent_detailedExperimentClean_none_eq_hit computation state fuel hbound + _ ≤ _ := by + rw [← probEvent_eq_eq_probOutput] + exact LazyRevealProbe.experiment_probability_le_expectedProbeCharge state fuel computation + +theorem probEvent_sampledRunThenFinalizeClean_empty_none_le_expectedCharge_of_not_stopped_false + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel : Nat) + (hnotStopped : LazyRevealProbe.RawResult.stopped false ∉ support + (LazyRevealProbe.runRaw (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel computation)) : + Pr[= none | sampledRunThenFinalizeClean + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel computation] ≤ + LazyRevealProbe.expectedProbeCharge computation LazyRevealProbe.State.empty fuel * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ = Pr[= none | detailedExperimentCleanWithCompletionTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel computation] := + probOutput_congr rfl (by + unfold sampledRunThenFinalizeClean + exact evalDist_runThenFinalizeCleanFromTable_eq_detailed computation LazyRevealProbe.State.empty fuel) + _ = Pr[= true | LazyRevealProbe.experiment + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel computation] := + probEvent_detailedExperimentClean_none_eq_hit_of_not_stopped_false computation + LazyRevealProbe.State.empty fuel hnotStopped + _ ≤ _ := by + rw [← probEvent_eq_eq_probOutput] + exact LazyRevealProbe.experiment_empty_probability_le_expectedProbeCharge fuel computation + +noncomputable def deferredOtsProbeCharge (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) : ℝ≥0∞ := + LazyRevealProbe.expectedProbeCharge (deferredCleanRetainedRun adversary parameter ftsSecret) + LazyRevealProbe.State.empty q + +theorem deferredOtsProbeCharge_le_q (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) : + deferredOtsProbeCharge adversary parameter ftsSecret q ≤ q := + LazyRevealProbe.expectedProbeCharge_le_fuel _ _ _ + +theorem deferredOtsProbeCharge_eq_expectedCost (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) : + deferredOtsProbeCharge adversary parameter ftsSecret q = + ∑' result, Pr[= result | LazyRevealProbe.runCharged LazyRevealProbe.State.empty q + (deferredCleanRetainedRun adversary parameter ftsSecret)] * (result.2 : ℝ≥0∞) := + (LazyRevealProbe.runCharged_expectedCost_eq _ _ _).symm + +theorem maskedSign_expectedProbeCharge_eq_zero (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) (fuel : Nat) : + LazyRevealProbe.expectedProbeCharge ((maskedSign parameter root ftsSecret message).run cache) state fuel = 0 := + LazyRevealProbe.expectedProbeCharge_eq_zero_of_probeFree _ state fuel + (maskedSign_probeFree parameter root ftsSecret message cache) + +theorem maskedPublishedTreeRoot_expectedProbeCharge_eq_zero + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) (fuel : Nat) : + LazyRevealProbe.expectedProbeCharge (maskedPublishedTreeRoot.run cache) state fuel = 0 := + LazyRevealProbe.expectedProbeCharge_eq_zero_of_probeFree _ state fuel (maskedPublishedTreeRoot_probeFree cache) + +theorem probEvent_sampledDeferredCleanFinish_none_le_expectedCharge + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[= none | sampledRunThenFinalizeClean + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) q + (deferredCleanRetainedRun adversary parameter ftsSecret)] ≤ + deferredOtsProbeCharge adversary parameter ftsSecret q * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + probEvent_sampledRunThenFinalizeClean_empty_none_le_expectedCharge_of_not_stopped_false + (deferredCleanRetainedRun adversary parameter ftsSecret) q + (stopped_false_not_mem_support_deferredCleanRetainedRun adversary q hq parameter hparameter ftsSecret hfts) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeQueryCutPrehit.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeQueryCutPrehit.lean new file mode 100644 index 00000000..53c3e727 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeQueryCutPrehit.lean @@ -0,0 +1,81 @@ +import SphincsSecurity.Proof.OuterQueryCut +import SphincsSecurity.Proof.OtsProbeEncodingPrehitViewed + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem encodingPrehitViewedAdversaryImpl_cache_projection + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) : + (fun result => (result.1, result.2.1.cache)) <$> + (simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run state = + (simulateQ (unloggedMappedAdversaryImpl secretKey) computation).run state.1.cache := by + calc + _ = (fun result : α × ViewedFullTraceState => (result.1, result.2.cache)) <$> + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) computation).run state.1 := by + rw [← encodingPrehitViewedAdversaryImpl_projection accountingKey secretKey computation state] + simp only [Functor.map_map] + rfl + _ = Prod.map id Prod.fst <$> + (simulateQ (fullTracedMappedAdversaryImpl secretKey) computation).run state.1.base := by + rw [← viewedFullTracedMappedAdversaryImpl_projection secretKey computation state.1] + simp only [Functor.map_map] + rfl + _ = _ := _root_.OracleComp.extendState_run_proj_eq (unloggedMappedAdversaryImpl secretKey) + fullAdversaryTraceUpdate computation state.1.cache state.1.trace + +def actualSelectionOfPrehitCut (result : OuterQueryCut α × (ViewedFullTraceState × Bool)) : + Option ActualQuerySelection := + result.1.input?.map (fun input => ⟨input, result.2.1.cache⟩) + +theorem actualSelectionOfPrehitCut_projection + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) + (state : ViewedFullTraceState × Bool) : + actualSelectionOfPrehitCut <$> + (simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) + (outerQueryCutAt computation ordinal)).run state = + actualQuerySelection secretKey computation ordinal state.1.cache := by + rw [actualQuerySelection_eq_cut_projection, + ← encodingPrehitViewedAdversaryImpl_cache_projection accountingKey secretKey + (outerQueryCutAt computation ordinal) state] + simp only [Functor.map_map] + rfl + +theorem encodingPrehitViewedAdversaryImpl_initial_false_of_mem_support + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialState finalState : ViewedFullTraceState) (hit : Bool) (value : α) + (hrun : (value, (finalState, false)) ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run (initialState, hit))) : + hit = false := by + obtain ⟨log, hmonitor, _⟩ := encodingPrehitViewedAdversaryImpl_support_monitor accountingKey secretKey + computation (initialState, hit) (value, (finalState, false)) hrun + exact TightEncoding.runEncodingPrehitMonitor_initial_false_of_mem_support accountingKey _ + initialState.cache hit _ hmonitor + +theorem mem_support_prehit_cut_resume_false_iff + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) + (initialState finalState : ViewedFullTraceState) (value : α) : + (value, (finalState, false)) ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run (initialState, false)) ↔ + ∃ cut : OuterQueryCut α, ∃ middleState : ViewedFullTraceState, + (cut, (middleState, false)) ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) + (outerQueryCutAt computation ordinal)).run (initialState, false)) ∧ + (value, (finalState, false)) ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) cut.resume).run (middleState, false)) := by + rw [mem_support_run_cut_resume_iff] + constructor + · rintro ⟨cut, ⟨middleState, hit⟩, hprefix, hsuffix⟩ + have hfalse := encodingPrehitViewedAdversaryImpl_initial_false_of_mem_support accountingKey secretKey + cut.resume middleState finalState hit value hsuffix + subst hit + exact ⟨cut, middleState, hprefix, hsuffix⟩ + · rintro ⟨cut, middleState, hprefix, hsuffix⟩ + exact ⟨cut, (middleState, false), hprefix, hsuffix⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeQueryTraceCoupling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeQueryTraceCoupling.lean new file mode 100644 index 00000000..42b1a3c2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeQueryTraceCoupling.lean @@ -0,0 +1,142 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalQueryTrace +import SphincsSecurity.Proof.OtsProbePrehitQueryTrace + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option maxRecDepth 100000 in +theorem relTriple_canonicalChronologicalQuery_prehit + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (accountingKey : SecretKey) + (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (state : ViewedFullTraceState × Bool) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) state.1.cache) + (hvisible : VisibleResolvedComputationsCached parameter table context state.1.cache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + RelTriple (canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache) + ((encodingPrehitViewedAdversaryImpl accountingKey secretKey input).run state) + (fun left right => ReachableResolvedRunRel parameter table left (right.1, right.2.1.cache) ∧ + ∀ result, left = some result → DeferredComputationsClosed result.context) := by + classical + dsimp only + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + have hstep := canonicalReachableResolvedImplCouples_chronologicalAdversaryImpl parameter root table ftsSecret + input context fuel cache state.1.cache hinvariant hvisible hpublished + have hsupported := FtsProbeSimulation.relTriple_and_left_support hstep + (fun left => ∀ result, left = some result → DeferredComputationsClosed result.context) (by + intro left hleft result heq + subst left + exact hcomputed.of_mem_canonicalChronologicalQuery parameter root table ftsSecret input context fuel cache + result hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hleft) + have hprojection := encodingPrehitViewedAdversaryImpl_cache_projection accountingKey secretKey + ((OracleWorld + SigningSpec).query input) state + simp only [simulateQ_spec_query] at hprojection + have hmonitor := relTriple_of_evalDist_map_eq_general + ((unloggedMappedAdversaryImpl secretKey input).run state.1.cache) + ((encodingPrehitViewedAdversaryImpl accountingKey secretKey input).run state) + id (fun result => (result.1, result.2.1.cache)) (by + simpa only [id_map] using congrArg evalDist hprojection.symm) + apply relTriple_post_mono (relTriple_trans_exists hsupported hmonitor) + rintro left right ⟨actual, hrelation, heq⟩ + exact ⟨heq ▸ hrelation.1, hrelation.2⟩ + +def CanonicalQueryTraceRel (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (left : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) + (right : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) : Prop := + (match left.1 with + | none => True + | some result => result.table = table ∧ result.value.1 = right.1.1 ∧ + ResolvedContextInvariant parameter table result.context (ordinaryQueryCache result.value.2) right.1.2.1.cache ∧ + VisibleResolvedComputationsCached parameter table result.context right.1.2.1.cache ∧ + PublishedValues result.context.state ∧ DeferredComputationsClosed result.context) ∧ + List.Forall₂ (fun a b => CanonicalQuerySelectionRel parameter table (some a) (some b.actual)) + left.2 (right.2.take left.2.length) + +theorem CanonicalQueryTraceRel.prepend + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection} + {right : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot} + (hrelation : CanonicalQueryTraceRel parameter table left right) + (a : CanonicalQuerySelection) (b : PrehitQuerySnapshot) + (hhead : CanonicalQuerySelectionRel parameter table (some a) (some b.actual)) : + CanonicalQueryTraceRel parameter table (left.1, a :: left.2) (right.1, b :: right.2) := by + refine ⟨hrelation.1, ?_⟩ + simpa only [List.length_cons, List.take_succ_cons] using List.Forall₂.cons + (R := fun (a : CanonicalQuerySelection) (b : PrehitQuerySnapshot) => + CanonicalQuerySelectionRel parameter table (some a) (some b.actual)) hhead hrelation.2 + +theorem relTriple_empty_canonicalTrace_any + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (right : ProbComp ((α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot)) : + RelTriple (pure (none, []) : ProbComp (Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection)) + right (CanonicalQueryTraceRel parameter table) := by + have hbase := relTriple_true + (pure (none, []) : ProbComp (Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection)) right + have hsupported := FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = (none, [])) (by intro result hresult; simpa using hresult) + apply relTriple_post_mono hsupported + intro left right hrelation + rw [hrelation.2] + exact ⟨trivial, List.Forall₂.nil⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_canonicalQueryTrace_prehitQueryTrace + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (accountingKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (state : ViewedFullTraceState × Bool) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) state.1.cache) + (hvisible : VisibleResolvedComputationsCached parameter table context state.1.cache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + RelTriple (runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache) + (runPrehitQueryTrace accountingKey secretKey computation state) (CanonicalQueryTraceRel parameter table) := by + dsimp only + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + induction computation using OracleComp.inductionOn generalizing context fuel cache state with + | pure value => + rw [runCanonicalQueryTrace, OracleComp.construct_pure, if_pos hinvariant.2.2.2.1] + exact relTriple_pure_pure ⟨⟨rfl, rfl, hinvariant, hvisible, hpublished, hcomputed⟩, List.Forall₂.nil⟩ + | query_bind input next ih => + rw [runCanonicalQueryTrace_query_bind, if_pos hinvariant.2.2.2.1, runPrehitQueryTrace_query_bind] + apply relTriple_bind (relTriple_canonicalChronologicalQuery_prehit parameter root table ftsSecret accountingKey + input context fuel cache state hinvariant hvisible hpublished hcomputed) + intro left right hrelation + have htail : RelTriple + (match left with + | none => pure (none, []) + | some result => runCanonicalQueryTrace parameter root ftsSecret (next result.value.1) + result.context result.remaining result.table result.value.2) + (runPrehitQueryTrace accountingKey secretKey (next right.1) right.2) + (CanonicalQueryTraceRel parameter table) := by + cases left with + | none => exact relTriple_empty_canonicalTrace_any parameter table _ + | some result => + dsimp only + rcases hrelation.1 with hclean | hdoomed + · rw [hclean.1, ← hclean.2.1] + exact ih result.value.1 result.context result.remaining result.value.2 right.2 + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 (hrelation.2 result rfl) + · rw [runCanonicalQueryTrace_of_not_completable parameter root ftsSecret + (next result.value.1) result.context result.remaining result.table result.value.2 (by + rw [hdoomed.1] + exact hdoomed.2.2.2)] + exact relTriple_empty_canonicalTrace_any parameter table _ + have hmap := relTriple_map + (f := fun tail : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection => + (tail.1, (⟨input, context, fuel, table, cache⟩ : CanonicalQuerySelection) :: tail.2)) + (g := fun tail : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot => + (tail.1, (⟨input, state⟩ : PrehitQuerySnapshot) :: tail.2)) + (relTriple_post_mono htail (fun leftTail rightTail htailRelation => + htailRelation.prepend ⟨input, context, fuel, table, cache⟩ ⟨input, state⟩ + ⟨rfl, rfl, hinvariant, hvisible, hpublished, hcomputed⟩)) + cases left <;> simpa only [map_eq_bind_pure_comp, Function.comp_def] using hmap + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeQueryTraceProjection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeQueryTraceProjection.lean new file mode 100644 index 00000000..47f76c27 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeQueryTraceProjection.lean @@ -0,0 +1,116 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalQueryTrace +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveProbability + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxRecDepth 100000 in +theorem runCanonicalQueryTrace_synchronized_projection + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + evalDist (Prod.fst <$> runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache) = + evalDist (runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + computation context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + simp only [runCanonicalQueryTrace, runSynchronizedResolved, OracleComp.construct_pure] + split_ifs <;> simp + | query_bind input next ih => + rw [runCanonicalQueryTrace_query_bind, runSynchronizedResolved, OracleComp.construct_query_bind] + by_cases hcomplete : DeferredCompletable table context + · simp only [hcomplete, ↓reduceIte, map_bind] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => simp + | some result => + have hcore := resolvedCore_of_mem_canonicalChronologicalAdversaryImpl parameter root table + ftsSecret input context fuel cache result hconsistent hstarts hresult + simp only [map_bind, map_pure] + change evalDist (Prod.fst <$> runCanonicalQueryTrace parameter root ftsSecret + (next result.value.1) result.context result.remaining result.table result.value.2) = + evalDist (runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (next result.value.1) result.context result.remaining result.table result.value.2) + rw [hcore.1] + exact ih result.value.1 result.context result.remaining result.value.2 hcore.2.1 hcore.2.2 + · simp [hcomplete] + +theorem runCanonicalQueryTrace_observer_projection + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (observer : Option (ResolvedRunResult (α × SplitHashCache)) → ProbComp β) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + evalDist (runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache >>= + fun result => observer result.1) = + evalDist (runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + computation context fuel table cache >>= observer) := by + have hprojection := runCanonicalQueryTrace_synchronized_projection parameter root ftsSecret + computation context fuel table cache hconsistent hstarts + rw [← bind_map_left] + rw [evalDist_bind, evalDist_bind, hprojection] + +noncomputable def canonicalRetainedSigningQueryTrace + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp (Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)) × List CanonicalQuerySelection) := do + let rootResult ← runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure (none, []) + | some rootResult => do + let result ← runCanonicalQueryTrace parameter rootResult.value.1 ftsSecret + (signingTraceComputation (adversary.main ⟨rootResult.value.1, parameter⟩)) + rootResult.context rootResult.remaining rootResult.table rootResult.value.2 + let verified ← canonicalVerifierContinuation parameter rootResult.value.1 result.1 + pure (verified, result.2) + +theorem canonicalRetainedSigningQueryTrace_projection + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (Prod.fst <$> canonicalRetainedSigningQueryTrace adversary parameter table ftsSecret fuel) = + evalDist (canonicalChronologicalRetainedRunAfterFtsSecrets adversary parameter table ftsSecret fuel) := by + unfold canonicalRetainedSigningQueryTrace canonicalChronologicalRetainedRunAfterFtsSecrets + rw [map_bind] + apply evalDist_bind_congr + intro rootOption hroot + cases rootOption with + | none => simp + | some rootResult => + have hcore := resolvedCore_of_mem_runResolved_maskedPublishedTreeRoot parameter table fuel rootResult hroot + dsimp only + rw [hcore.1] + simp only [map_bind, map_pure, bind_pure] + exact runCanonicalQueryTrace_observer_projection parameter rootResult.value.1 ftsSecret + (signingTraceComputation (adversary.main ⟨rootResult.value.1, parameter⟩)) + rootResult.context rootResult.remaining table rootResult.value.2 + (canonicalVerifierContinuation parameter rootResult.value.1) hcore.2.1 hcore.2.2 + +theorem probEvent_winningRetainedVerifyProbe_le_signingQueryTrace_failure + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table)] ≤ + Pr[fun result => result = none | + canonicalRetainedSigningQueryTrace adversary parameter table ftsSecret fuel >>= + fun result => finishResolvedRun result.1] := by + have hprojection := canonicalRetainedSigningQueryTrace_projection adversary parameter table ftsSecret fuel + have hfinish : evalDist (canonicalRetainedSigningQueryTrace adversary parameter table ftsSecret fuel >>= + fun result => finishResolvedRun result.1) = + evalDist (canonicalChronologicalRetainedRunAfterFtsSecrets adversary parameter table ftsSecret fuel >>= + finishResolvedRun) := by + rw [← bind_map_left, evalDist_bind, evalDist_bind, hprojection] + rw [probEvent_eq_eq_probOutput, _root_.OracleComp.probOutput_congr rfl hfinish] + simpa only [probEvent_eq_eq_probOutput] using + probEvent_winningRetainedVerifyProbe_le_canonicalFinishedResolvedRun_none adversary parameter table ftsSecret fuel + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeQueryTraceReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeQueryTraceReserve.lean new file mode 100644 index 00000000..559377f6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeQueryTraceReserve.lean @@ -0,0 +1,113 @@ +import SphincsSecurity.Proof.OtsProbeQueryTraceCoupling +import SphincsSecurity.Proof.OtsProbePrehitTraceTerminal + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +namespace CanonicalQueryTraceRel + +variable {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection} + {right : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot} + (hrelation : CanonicalQueryTraceRel parameter table left right) + +include hrelation + +theorem length_le : left.2.length ≤ right.2.length := by + have hlength := hrelation.2.length_eq + rw [List.length_take] at hlength + omega + +theorem selection_at (i : Fin left.2.length) : + CanonicalQuerySelectionRel parameter table (some (left.2.get i)) + (some (right.2.get ⟨i.val, i.isLt.trans_le hrelation.length_le⟩).actual) := by + have hbound : i.val < (right.2.take left.2.length).length := by + rw [← hrelation.2.length_eq] + exact i.isLt + have hget := hrelation.2.get i.isLt hbound + simpa only [List.get_eq_getElem, List.getElem_take] using hget + +end CanonicalQueryTraceRel + +set_option maxRecDepth 100000 in +theorem CanonicalQueryTraceRel.reserve_of_matching_history_roots + {accountingKey : SecretKey} (secretKey : SecretKey) {table : OtsSecretIndex → HashOutput} + {left : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection} + {right : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot} + (hrelation : CanonicalQueryTraceRel accountingKey.parameter table left right) + (hsecrets : accountingKey.otsSecret = fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) + (hrun : right ∈ support (runPrehitQueryTrace accountingKey secretKey computation state)) + (hfinal : right.1.2.2 = false) + (i j : Fin left.2.length) (hij : i.val < j.val) + (input : HashInput) (candidate : Probe) (lay : Layer) (tree : TreeIndex) (output : HashOutput) + (hinput : (left.2.get i).input = .inl (.inr input)) + (hcandidate : EncodingLayerRootCandidateAt accountingKey.parameter input candidate) + (hposition : candidate.coordinate = .position (layerRootPosition lay tree)) + (hvalue : (left.2.get j).context.positionValue (layerRootPosition lay tree) = some output) + (hmatch : candidate.candidate = truncateHash output) : + (4 / 3 : ℝ≥0∞) ≤ otsOpeningRefinedQueryReserve accountingKey + (right.2.get ⟨i.val, i.isLt.trans_le hrelation.length_le⟩).state.1.cache input := by + let actualI : Fin right.2.length := ⟨i.val, i.isLt.trans_le hrelation.length_le⟩ + let actualJ : Fin right.2.length := ⟨j.val, j.isLt.trans_le hrelation.length_le⟩ + have hsource := hrelation.selection_at i + have htarget := hrelation.selection_at j + obtain ⟨_htargetInput, _htable, hinvariant, _hvisible, _hpublished, hcomputed⟩ := htarget + have hroot := hcomputed.root_settled_value hinvariant accountingKey.ftsSecret lay tree output hvalue + have hsettled : Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret + (right.2.get actualJ).state.1.cache (layerRootPosition lay tree) := by + rw [hsecrets] + exact hroot.1 + have hrootValue : honestValue (fromCache (right.2.get actualJ).state.1.cache) + accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret (layerRootPosition lay tree) = + truncateHash output := by + rw [hsecrets] + exact hroot.2 + have hfalse := prehitQueryTrace_entry_false_of_final_false accountingKey secretKey computation state right hrun hfinal + (right.2.get actualJ) (List.get_mem _ _) + have hpairs := prehitQueryTrace_pairwise_encodingReserve accountingKey secretKey computation state right hrun + have hpair := hpairs.rel_get_of_lt (show actualI < actualJ from hij) + exact hpair input candidate (layerRootPosition lay tree) (hsource.1.symm.trans hinput) + hcandidate hposition hfalse hsettled (hmatch.trans hrootValue.symm) + +set_option maxRecDepth 100000 in +theorem CanonicalQueryTraceRel.reserve_of_matching_final_root + {accountingKey : SecretKey} (secretKey : SecretKey) {table : OtsSecretIndex → HashOutput} + {left : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection} + {right : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot} + (hrelation : CanonicalQueryTraceRel accountingKey.parameter table left right) + (hsecrets : accountingKey.otsSecret = fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) + (hrun : right ∈ support (runPrehitQueryTrace accountingKey secretKey computation state)) + (hfinal : right.1.2.2 = false) + (terminal : ResolvedRunResult (α × SplitHashCache)) (hterminal : left.1 = some terminal) + (i : Fin left.2.length) + (input : HashInput) (candidate : Probe) (lay : Layer) (tree : TreeIndex) (output : HashOutput) + (hinput : (left.2.get i).input = .inl (.inr input)) + (hcandidate : EncodingLayerRootCandidateAt accountingKey.parameter input candidate) + (hposition : candidate.coordinate = .position (layerRootPosition lay tree)) + (hvalue : terminal.context.positionValue (layerRootPosition lay tree) = some output) + (hmatch : candidate.candidate = truncateHash output) : + (4 / 3 : ℝ≥0∞) ≤ otsOpeningRefinedQueryReserve accountingKey + (right.2.get ⟨i.val, i.isLt.trans_le hrelation.length_le⟩).state.1.cache input := by + have hterminalRelation := hrelation.1 + rw [hterminal] at hterminalRelation + obtain ⟨_htable, _hvalue, hinvariant, _hvisible, _hpublished, hcomputed⟩ := hterminalRelation + have hroot := hcomputed.root_settled_value hinvariant accountingKey.ftsSecret lay tree output hvalue + have hsettled : Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret + right.1.2.1.cache (layerRootPosition lay tree) := by + rw [hsecrets] + exact hroot.1 + have hrootValue : honestValue (fromCache right.1.2.1.cache) + accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret (layerRootPosition lay tree) = + truncateHash output := by + rw [hsecrets] + exact hroot.2 + exact prehitQueryTrace_encodingReserve_at_final accountingKey secretKey computation state right hrun _ (List.get_mem _ _) + input candidate (layerRootPosition lay tree) ((hrelation.selection_at i).1.symm.trans hinput) + hcandidate hposition hfinal hsettled (hmatch.trans hrootValue.symm) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRealization.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRealization.lean new file mode 100644 index 00000000..d1eeb0f4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRealization.lean @@ -0,0 +1,1408 @@ +import SphincsSecurity.Proof.OtsProbeSimulation + +/-! +# Realizing the concrete one-time structure + +A completed opaque table determines the one-time secrets and every structural answer. If an answer +function returns the table output at each corresponding table input, the concrete chain and tree +computations recover exactly those table values. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp + +set_option maxRecDepth 10000 in +theorem mergedCache_tableInput (parameter : PublicParameter) + (table : Coordinate → HashOutput) (ensured : Finset Coordinate) + (cache : SplitHashCache) (position : Position) (hots : IsOtsPosition position) : + mergedCache parameter table ensured cache + (tableInput parameter table (.position position)) = + completedSplitHashCache table ensured cache (.hidden (.position position)) := by + have hdecode := (decodePosition?_eq_some_iff parameter + (tableInput parameter table (.position position)) position).2 + ⟨tablePayload table position, rfl⟩ + change mergeDecodedPosition parameter table ensured cache + (tableInput parameter table (.position position)) + (decodePosition? parameter (tableInput parameter table (.position position))) = _ + rw [hdecode] + cases position <;> simp [mergeDecodedPosition, IsOtsPosition] at hots ⊢ + +theorem tableAnswer_tableInput (parameter : PublicParameter) + (table : Coordinate → HashOutput) (fallback : QueryImpl HashSpec Id) + (position : Position) (hots : IsOtsPosition position) : + tableAnswer parameter table fallback + (tableInput parameter table (.position position)) = + table (.position position) := by + have hdecode := (decodePosition?_eq_some_iff parameter + (tableInput parameter table (.position position)) position).2 + ⟨tablePayload table position, rfl⟩ + change tableAnswerDecoded parameter table fallback + (tableInput parameter table (.position position)) + (decodePosition? parameter (tableInput parameter table (.position position))) = _ + rw [hdecode] + cases position <;> simp [tableAnswerDecoded, IsOtsPosition] at hots ⊢ + +def splitFallback (cache : SplitHashCache) : QueryImpl HashSpec Id := + fun input => (cache (.ordinary input)).getD 0 + +noncomputable def extendTable (state : LazyRevealProbe.State Coordinate) + (base : Coordinate → HashOutput) : Coordinate → HashOutput := + fun coordinate => (state.values coordinate).getD (base coordinate) + +def HiddenConsistent (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) : Prop := + ∀ coordinate output, cache (.hidden coordinate) = some output → + state.values coordinate = some output + +theorem hiddenConsistent_empty : + HiddenConsistent (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + emptySplitHashCache := by + intro coordinate output houtput + simp [emptySplitHashCache] at houtput + +theorem HiddenConsistent.updateOrdinary + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (hconsistent : HiddenConsistent state cache) (input : HashInput) (output : HashOutput) : + HiddenConsistent state (Function.update cache (.ordinary input) (some output)) := by + intro coordinate hiddenOutput hhidden + simp [Function.update] at hhidden + exact hconsistent coordinate hiddenOutput hhidden + +theorem HiddenConsistent.ensure + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (hconsistent : HiddenConsistent state cache) (coordinate : Coordinate) : + HiddenConsistent (state.ensure coordinate) cache := by + simpa [HiddenConsistent, LazyRevealProbe.State.ensure] using hconsistent + +theorem HiddenConsistent.addPending + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (hconsistent : HiddenConsistent state cache) (coordinate : Coordinate) + (candidate : Digest) : + HiddenConsistent (state.addPending coordinate candidate) cache := by + simpa [HiddenConsistent, LazyRevealProbe.State.addPending] using hconsistent + +theorem HiddenConsistent.publish + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (hconsistent : HiddenConsistent state cache) (coordinate : Coordinate) : + HiddenConsistent (state.publish coordinate) cache := by + simpa [HiddenConsistent, LazyRevealProbe.State.publish] using hconsistent + +theorem HiddenConsistent.install_of_none + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (hconsistent : HiddenConsistent state cache) (coordinate : Coordinate) + (output : HashOutput) (hvalue : state.values coordinate = none) : + HiddenConsistent (state.install coordinate output) cache := by + intro other hiddenOutput hhidden + by_cases heq : other = coordinate + · subst other + have := hconsistent coordinate hiddenOutput hhidden + rw [hvalue] at this + simp at this + · simp [LazyRevealProbe.State.install, Function.update, heq] + exact hconsistent other hiddenOutput hhidden + +theorem HiddenConsistent.clearPending + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (hconsistent : HiddenConsistent state cache) (coordinate : Coordinate) : + HiddenConsistent (state.clearPending coordinate) cache := by + simpa [HiddenConsistent, LazyRevealProbe.State.clearPending] using hconsistent + +theorem HiddenConsistent.complete_of_none + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (hconsistent : HiddenConsistent state cache) (coordinate : Coordinate) + (output : HashOutput) (hvalue : state.values coordinate = none) : + HiddenConsistent (state.complete coordinate output) cache := by + intro other hiddenOutput hhidden + by_cases heq : other = coordinate + · subst other + have := hconsistent coordinate hiddenOutput hhidden + rw [hvalue] at this + simp at this + · simp [LazyRevealProbe.State.complete, Function.update, heq] + exact hconsistent other hiddenOutput hhidden + +theorem HiddenConsistent.updateHidden_of_value + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (hconsistent : HiddenConsistent state cache) (coordinate : Coordinate) + (output : HashOutput) (hvalue : state.values coordinate = some output) : + HiddenConsistent state (Function.update cache (.hidden coordinate) (some output)) := by + intro other hiddenOutput hhidden + by_cases heq : other = coordinate + · subst other + simp [Function.update] at hhidden + rwa [← hhidden] + · simp [Function.update, heq] at hhidden + exact hconsistent other hiddenOutput hhidden + +theorem HiddenConsistent.updateHidden_install + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} + (hconsistent : HiddenConsistent state cache) (coordinate : Coordinate) + (output : HashOutput) : + HiddenConsistent (state.install coordinate output) + (Function.update cache (.hidden coordinate) (some output)) := by + intro other hiddenOutput hhidden + by_cases heq : other = coordinate + · subst other + simp [Function.update] at hhidden + simp [LazyRevealProbe.State.install, hhidden] + · simp [Function.update, heq] at hhidden + simp [LazyRevealProbe.State.install, Function.update, heq] + exact hconsistent other hiddenOutput hhidden + +theorem completedSplitHashCache_extendTable_consistent + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (base : Coordinate → HashOutput) (hconsistent : HiddenConsistent state cache) : + ∀ coordinate output, + completedSplitHashCache (extendTable state base) state.ensured cache + (.hidden coordinate) = some output → + output = extendTable state base coordinate := by + intro coordinate output houtput + unfold completedSplitHashCache at houtput + change (match cache (.hidden coordinate) with + | some cached => some cached + | none => if coordinate ∈ state.ensured then + some (extendTable state base coordinate) else none) = some output at houtput + cases hcache : cache (.hidden coordinate) with + | some cached => + rw [hcache] at houtput + have heq : cached = output := Option.some.inj houtput + subst output + have hvalue := hconsistent coordinate cached hcache + simp [extendTable, hvalue] + | none => + rw [hcache] at houtput + by_cases hmem : coordinate ∈ state.ensured + · rw [if_pos hmem] at houtput + exact Option.some.inj houtput |>.symm + · rw [if_neg hmem] at houtput + simp at houtput + +def PreservesHidden + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ state cache fuel finalState remaining value finalCache, + HiddenConsistent state cache → + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + HiddenConsistent finalState finalCache + +theorem PreservesHidden.done + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + (hcomputation : PreservesHidden computation) + {state : LazyRevealProbe.State Coordinate} {cache : SplitHashCache} {fuel : Nat} + {finalState : LazyRevealProbe.State Coordinate} {remaining : Nat} + {value : alpha} {finalCache : SplitHashCache} + (hconsistent : HiddenConsistent state cache) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache))) : + HiddenConsistent finalState finalCache := + hcomputation state cache fuel finalState remaining value finalCache hconsistent hresult + +theorem preservesHidden_pure (value : alpha) : + PreservesHidden (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro state cache fuel finalState remaining result finalCache hconsistent hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hconsistent + +theorem preservesHidden_get : + PreservesHidden (get : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) SplitHashCache) := by + intro state cache fuel finalState remaining result finalCache hconsistent hresult + simp [StateT.run_get, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hconsistent + +theorem PreservesHidden.bind + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : PreservesHidden left) (hnext : ∀ value, PreservesHidden (next value)) : + PreservesHidden (left >>= next) := by + intro state cache fuel finalState remaining result finalCache hconsistent hresult + change LazyRevealProbe.RawResult.done finalState remaining (result, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun leftResult => (next leftResult.1).run leftResult.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining leftResult => + rcases leftResult with ⟨leftValue, middleCache⟩ + have hmiddle := hleft state cache fuel middleState middleRemaining leftValue middleCache + hconsistent hraw + exact hnext leftValue middleState middleCache middleRemaining finalState remaining result + finalCache hmiddle hrest + +theorem splitHashQuery_run_eq (key : SplitHashKey) (cache : SplitHashCache) : + (splitHashQuery key).run cache = + match cache key with + | some output => pure (output, cache) + | none => LazyRevealProbe.hashOutputQuery >>= fun output => + pure (output, Function.update cache key (some output)) := by + cases hlookup : cache key <;> simp [splitHashQuery, hlookup] + +theorem preservesHidden_splitHashQuery_ordinary (input : HashInput) : + PreservesHidden (splitHashQuery (.ordinary input)) := by + intro state cache fuel finalState remaining value finalCache hconsistent hresult + rw [splitHashQuery_run_eq] at hresult + cases hlookup : cache (.ordinary input) with + | some output => + rw [hlookup] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hconsistent + | none => + rw [hlookup] at hresult + dsimp only at hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.hashOutputQuery >>= fun output => + pure (output, Function.update cache (.ordinary input) (some output)))) at hresult + rw [LazyRevealProbe.hashOutputQuery, + LazyRevealProbe.runRaw_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _, hdone⟩ := hresult + simp [LazyRevealProbe.runRaw] at hdone + rcases hdone with ⟨rfl, rfl, rfl, rfl⟩ + exact hconsistent.updateOrdinary input value + +theorem preservesHidden_ensureCoordinate (coordinate : Coordinate) : + PreservesHidden (ensureCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hconsistent hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.ensureQuery coordinate >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.ensureQuery, LazyRevealProbe.runRaw_ensure_query_bind] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hconsistent.ensure coordinate + +theorem preservesHidden_probe (candidate : Probe) : + PreservesHidden (probe candidate) := by + intro state cache fuel finalState remaining value finalCache hconsistent hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate >>= fun output => + pure (output, cache))) at hresult + rw [LazyRevealProbe.probeQuery, LazyRevealProbe.runRaw_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remainingFuel => + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (if candidate.coordinate ∈ state.revealed then + LazyRevealProbe.runRaw state remainingFuel (pure ((), cache)) + else + LazyRevealProbe.runRaw + (state.addPending candidate.coordinate candidate.candidate) remainingFuel + (pure ((), cache))) at hresult + by_cases hrevealed : candidate.coordinate ∈ state.revealed + · rw [if_pos hrevealed] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hconsistent + · rw [if_neg hrevealed] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hconsistent.addPending candidate.coordinate candidate.candidate + +theorem preservesHidden_peekCoordinate (coordinate : Coordinate) : + PreservesHidden (peekCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hconsistent hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.peekQuery coordinate >>= fun output => + pure (truncateHash <$> output, cache))) at hresult + rw [LazyRevealProbe.peekQuery, LazyRevealProbe.runRaw_peek_query_bind] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hconsistent + +theorem preservesHidden_publishCoordinate (coordinate : Coordinate) : + PreservesHidden (publishCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hconsistent hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.publishQuery coordinate >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.publishQuery, LazyRevealProbe.runRaw_publish_query_bind] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hconsistent.publish coordinate + +theorem revealCoordinateOutput_run (coordinate : Coordinate) (cache : SplitHashCache) : + (revealCoordinateOutput coordinate).run cache = + (LazyRevealProbe.revealQuery coordinate >>= fun output => + pure (output, Function.update cache (.hidden coordinate) (some output))) := by + simp [revealCoordinateOutput, StateT.run_modify] + +theorem preservesHidden_revealCoordinateOutput (coordinate : Coordinate) : + PreservesHidden (revealCoordinateOutput coordinate) := by + intro state cache fuel finalState remaining value finalCache hconsistent hresult + rw [revealCoordinateOutput_run] at hresult + rw [LazyRevealProbe.revealQuery, LazyRevealProbe.runRaw_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + rw [hvalue] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hconsistent.updateHidden_of_value coordinate value hvalue + | none => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨output, _, hrest⟩ := hresult + by_cases hhit : state.hitAt coordinate output + · rw [if_pos hhit] at hrest + simp at hrest + · rw [if_neg hhit] at hrest + simp [LazyRevealProbe.runRaw] at hrest + rcases hrest with ⟨rfl, rfl, rfl, rfl⟩ + exact hconsistent.updateHidden_install coordinate value + +theorem preservesHidden_revealCoordinate (coordinate : Coordinate) : + PreservesHidden (revealCoordinate coordinate) := by + unfold revealCoordinate + exact (preservesHidden_revealCoordinateOutput coordinate).bind fun _ => + preservesHidden_pure _ + +theorem preservesHidden_splitUniformImpl (n : Nat) : + PreservesHidden (splitUniformImpl n) := by + intro state cache fuel finalState remaining value finalCache hconsistent hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.uniformQuery n >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.uniformQuery, LazyRevealProbe.runRaw_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _, hdone⟩ := hresult + simp [LazyRevealProbe.runRaw] at hdone + rcases hdone with ⟨rfl, rfl, rfl, rfl⟩ + exact hconsistent + +def PreservesHiddenImpl {spec : OracleSpec ι} + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) : Prop := + ∀ query, PreservesHidden (impl query) + +theorem PreservesHiddenImpl.simulateQ {spec : OracleSpec ι} + {impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))} + (himpl : PreservesHiddenImpl impl) (computation : OracleComp spec alpha) : + PreservesHidden (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => exact preservesHidden_pure value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (himpl query).bind ih + +theorem preservesHiddenImpl_ordinaryHashImpl : + PreservesHiddenImpl ordinaryHashImpl := by + intro input + exact preservesHidden_splitHashQuery_ordinary input + +theorem preservesHiddenImpl_splitUniformImpl : + PreservesHiddenImpl splitUniformImpl := + preservesHidden_splitUniformImpl + +theorem preservesHiddenImpl_ordinaryRomImpl : + PreservesHiddenImpl ordinaryRomImpl := by + intro query + cases query with + | inl query => exact preservesHiddenImpl_splitUniformImpl query + | inr query => exact preservesHiddenImpl_ordinaryHashImpl query + +theorem preservesHidden_sequenceFin {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hcomputation : ∀ index, PreservesHidden (computation index)) : + PreservesHidden (sequenceFin computation) := by + induction n with + | zero => + simp only [sequenceFin] + exact preservesHidden_pure Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomputation 0).bind fun head => + (ih (fun index => computation index.succ) + (fun index => hcomputation index.succ)).bind fun tail => + preservesHidden_pure (Fin.cases head tail : Fin (n + 1) → alpha) + +theorem preservesHidden_revealPosition (position : Position) : + PreservesHidden (revealPosition position) := + preservesHidden_revealCoordinate (.position position) + +theorem preservesHidden_revealChainStart (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + PreservesHidden (revealChainStart lay tree leafIdx chainIdx) := + preservesHidden_revealCoordinate (.chainStart lay tree leafIdx chainIdx) + +theorem preservesHidden_peekPositionValues (positions : List Position) : + PreservesHidden (peekPositionValues positions) := by + induction positions with + | nil => exact preservesHidden_pure (some []) + | cons position remaining ih => + rw [peekPositionValues] + exact (preservesHidden_peekCoordinate (.position position)).bind fun value => + match value with + | none => preservesHidden_pure none + | some _ => ih.bind fun values => + match values with + | none => preservesHidden_pure none + | some _ => preservesHidden_pure _ + +theorem preservesHidden_peekTableInput (parameter : PublicParameter) + (coordinate : Coordinate) : + PreservesHidden (peekTableInput parameter coordinate) := by + cases coordinate with + | chainStart => exact preservesHidden_pure none + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput] + by_cases hzero : step.val = 0 + · rw [if_pos hzero] + exact (preservesHidden_peekCoordinate + (.chainStart lay tree leafIdx chainIdx)).bind fun value => + match value with + | none => preservesHidden_pure none + | some _ => preservesHidden_pure _ + · rw [if_neg hzero] + exact (preservesHidden_peekPositionValues + (Position.chain lay tree leafIdx chainIdx step).children).bind fun values => + match values with + | none => preservesHidden_pure none + | some _ => preservesHidden_pure _ + | leaf lay tree leafIdx => + simp only [peekTableInput] + exact (preservesHidden_peekPositionValues _).bind fun values => + match values with + | none => preservesHidden_pure none + | some _ => preservesHidden_pure _ + | node lay tree level nodeIdx => + simp only [peekTableInput] + exact (preservesHidden_peekPositionValues _).bind fun values => + match values with + | none => preservesHidden_pure none + | some _ => preservesHidden_pure _ + | ftsLeaf index tree leafIdx => + simp only [peekTableInput] + exact (preservesHidden_peekPositionValues _).bind fun values => + match values with + | none => preservesHidden_pure none + | some _ => preservesHidden_pure _ + | ftsNode index tree level nodeIdx => + simp only [peekTableInput] + exact (preservesHidden_peekPositionValues _).bind fun values => + match values with + | none => preservesHidden_pure none + | some _ => preservesHidden_pure _ + | ftsRoots index => + simp only [peekTableInput] + exact (preservesHidden_peekPositionValues _).bind fun values => + match values with + | none => preservesHidden_pure none + | some _ => preservesHidden_pure _ + +theorem preservesHidden_ensureFullChain (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + PreservesHidden (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (preservesHidden_sequenceFin _ fun step => + preservesHidden_ensureCoordinate + (.position (.chain lay tree leafIdx chainIdx step))).bind fun _ => + preservesHidden_pure () + +theorem preservesHidden_ensureChainPrefix (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + PreservesHidden (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (preservesHidden_sequenceFin _ fun step => by + split + · exact preservesHidden_ensureCoordinate + (.position (.chain lay tree leafIdx chainIdx step)) + · exact preservesHidden_pure ()).bind fun _ => preservesHidden_pure () + +theorem preservesHidden_ensureOtsLeaf (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + PreservesHidden (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (preservesHidden_sequenceFin _ fun chainIdx => + preservesHidden_ensureFullChain lay tree leafIdx chainIdx).bind fun _ => + preservesHidden_ensureCoordinate (.position (.leaf lay tree leafIdx)) + +theorem preservesHidden_ensureTreeNode (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) : + PreservesHidden (ensureTreeNode lay tree level nodeIdx) := by + induction level generalizing nodeIdx with + | zero => exact preservesHidden_ensureOtsLeaf lay tree (leafOfNat nodeIdx) + | succ level ih => + rw [ensureTreeNode] + exact (ih (2 * nodeIdx)).bind fun _ => + (ih (2 * nodeIdx + 1)).bind fun _ => by + split + · exact preservesHidden_ensureCoordinate _ + · exact preservesHidden_pure () + +theorem preservesHidden_maskedTreeNode (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) : + PreservesHidden (maskedTreeNode lay tree level nodeIdx) := by + unfold maskedTreeNode + exact (preservesHidden_ensureTreeNode lay tree level nodeIdx).bind fun _ => + match level with + | 0 => preservesHidden_revealPosition (.leaf lay tree (leafOfNat nodeIdx)) + | current + 1 => by + rw [show current + 1 = Nat.succ current by omega] + change PreservesHidden + (if hlevel : current < maxLayerHeight then + revealPosition (.node lay tree ⟨current, hlevel⟩ (leafOfNat nodeIdx)) + else pure 0) + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact preservesHidden_revealPosition _ + · rw [dif_neg hlevel] + exact preservesHidden_pure 0 + +theorem preservesHidden_maskedTreeRoot (lay : Layer) (tree : TreeIndex) : + PreservesHidden (maskedTreeRoot lay tree) := + preservesHidden_maskedTreeNode lay tree (layerHeight lay) 0 + +theorem preservesHidden_maskedTreePath (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + PreservesHidden (maskedTreePath lay tree leafIdx) := by + unfold maskedTreePath + exact preservesHidden_sequenceFin _ fun level => by + split + · exact preservesHidden_maskedTreeNode _ _ _ _ + · exact preservesHidden_pure 0 + +theorem preservesHidden_maskedChainValue (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + PreservesHidden (maskedChainValue lay tree leafIdx chainIdx digit) := by + unfold maskedChainValue + exact (preservesHidden_ensureChainPrefix lay tree leafIdx chainIdx digit).bind fun _ => by + split + · exact preservesHidden_revealChainStart lay tree leafIdx chainIdx + · exact preservesHidden_revealPosition _ + +theorem preservesHidden_maskedOtsSignFrom (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) + (attempts counter : Nat) : + PreservesHidden + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) := by + induction attempts generalizing counter with + | zero => exact preservesHidden_pure none + | succ attempts ih => + rw [maskedOtsSignFrom] + exact (preservesHiddenImpl_ordinaryHashImpl.simulateQ + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter))).bind fun encoded => + match encoded with + | none => ih (counter + 1) + | some encoding => + (preservesHidden_sequenceFin _ fun chainIdx => + preservesHidden_ensureChainPrefix lay tree leafIdx chainIdx + (encoding chainIdx)).bind fun _ => preservesHidden_pure + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem preservesHidden_maskedOtsSign (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + PreservesHidden (maskedOtsSign parameter lay tree leafIdx message) := + preservesHidden_maskedOtsSignFrom parameter lay tree leafIdx message + encodingAttemptLimit 0 + +theorem preservesHidden_maskedLayerMessage (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + PreservesHidden (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + split + · exact preservesHidden_maskedTreeRoot _ _ + · exact preservesHiddenImpl_ordinaryHashImpl.simulateQ + (ftsKey parameter index (ftsSecret index)) + +theorem preservesHidden_ensureTreePath (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + PreservesHidden (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (preservesHidden_sequenceFin _ fun level => by + split + · exact preservesHidden_ensureTreeNode _ _ _ _ + · exact preservesHidden_pure ()).bind fun _ => preservesHidden_pure () + +theorem preservesHidden_maskedSignLayer (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + PreservesHidden (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + exact (preservesHidden_maskedLayerMessage parameter ftsSecret index lay).bind fun message => + (preservesHidden_maskedOtsSign parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message).bind fun result => + match result with + | none => preservesHidden_pure none + | some part => + (preservesHidden_ensureTreePath lay (treeIndexAt index lay) + (leafIndexAt index lay)).bind fun _ => + preservesHidden_pure (some part) + +theorem preservesHidden_revealPublishedCoordinate (coordinate : Coordinate) : + PreservesHidden (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + exact (preservesHidden_revealCoordinate coordinate).bind fun value => + (preservesHidden_publishCoordinate coordinate).bind fun _ => preservesHidden_pure value + +theorem preservesHidden_revealLayerValues (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + PreservesHidden (revealLayerValues index lay encoding) := by + unfold revealLayerValues + exact (preservesHidden_sequenceFin _ fun chainIdx => + preservesHidden_revealPublishedCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx))).bind fun values => + (preservesHidden_sequenceFin _ fun level => by + split + · cases hlevelValue : level.val with + | zero => exact preservesHidden_revealPublishedCoordinate _ + | succ current => + rw [show current + 1 = Nat.succ current by omega] + change PreservesHidden + (if hlevel : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hlevel⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0) + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact preservesHidden_revealPublishedCoordinate _ + · rw [dif_neg hlevel] + exact preservesHidden_pure 0 + · exact preservesHidden_pure 0).bind fun path => preservesHidden_pure (values, path) + +theorem preservesHidden_maskedSignAfterDigest (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + PreservesHidden + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest + exact (preservesHiddenImpl_ordinaryHashImpl.simulateQ + (ftsOpen parameter index leaves (ftsSecret index))).bind fun ftsPath => + (preservesHidden_sequenceFin _ fun lay => + preservesHidden_maskedSignLayer parameter ftsSecret index lay).bind fun layers => + by + cases hparts : traverseOption layers with + | none => + exact preservesHidden_pure (none : Option Signature) + | some parts => + exact (preservesHidden_sequenceFin _ fun lay => + preservesHidden_revealLayerValues index lay (parts lay).2).bind fun _ => + preservesHidden_pure _ + +theorem preservesHidden_maskedSign (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + PreservesHidden (maskedSign parameter root ftsSecret message) := by + unfold maskedSign + exact (preservesHiddenImpl_ordinaryRomImpl.simulateQ + (signDigestLoop digestAttemptLimit + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ message)).bind fun result => + match result with + | none => preservesHidden_pure none + | some selected => preservesHidden_maskedSignAfterDigest parameter ftsSecret + selected.1 selected.2.1 selected.2.2 + +theorem preservesHidden_modifyOrdinary (input : HashInput) (output : HashOutput) : + PreservesHidden + (modify (fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output))) := by + intro state cache fuel finalState remaining value finalCache hconsistent hresult + simp [StateT.run_modify, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hconsistent.updateOrdinary input output + +theorem preservesHidden_resolveKnownInput (parameter : PublicParameter) + (coordinate : Coordinate) (input : HashInput) : + PreservesHidden (resolveKnownInput parameter coordinate input) := by + unfold resolveKnownInput + exact (preservesHidden_peekTableInput parameter coordinate).bind fun known => + match known with + | none => preservesHidden_splitHashQuery_ordinary input + | some knownInput => by + change PreservesHidden + (if knownInput = input then do + let output ← revealCoordinateOutput coordinate + publishCoordinate coordinate + modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output) + pure output + else splitHashQuery (.ordinary input)) + by_cases heq : knownInput = input + · rw [if_pos heq] + exact (preservesHidden_revealCoordinateOutput coordinate).bind fun output => + (preservesHidden_publishCoordinate coordinate).bind fun _ => + (preservesHidden_modifyOrdinary input output).bind fun _ => + preservesHidden_pure output + · rw [if_neg heq] + exact preservesHidden_splitHashQuery_ordinary input + +set_option maxHeartbeats 10000 in +theorem preservesHidden_probeFirstMissingInputCoordinate (input : HashInput) : + ∀ (slot : Nat) (coordinates : List Coordinate), + PreservesHidden (probeFirstMissingInputCoordinate input slot coordinates) + | _, [] => preservesHidden_pure () + | slot, coordinate :: remaining => by + rw [probeFirstMissingInputCoordinate] + exact (preservesHidden_peekCoordinate coordinate).bind fun value => + match value with + | none => preservesHidden_probe ⟨coordinate, slotDigest slot input⟩ + | some _ => preservesHidden_probeFirstMissingInputCoordinate input (slot + 1) remaining + +theorem preservesHidden_prepareLeafInputProbe + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + PreservesHidden (prepareLeafInputProbe input candidate lay tree leafIdx) := by + unfold prepareLeafInputProbe + apply (preservesHidden_peekCoordinate candidate.coordinate).bind + intro value + cases value with + | none => + simp only + exact preservesHidden_probe candidate + | some output => + simp only + exact preservesHidden_probeFirstMissingInputCoordinate input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + +theorem preservesHidden_probingHashQuery (parameter : PublicParameter) + (input : HashInput) : + PreservesHidden (probingHashQuery parameter input) := by + unfold probingHashQuery + cases decodeProbe? parameter input with + | some candidate => + cases decodePosition? parameter input with + | some position => + cases position with + | leaf lay tree leafIdx => + exact (preservesHidden_prepareLeafInputProbe input candidate lay tree leafIdx).bind + fun _ => preservesHidden_resolveKnownInput parameter candidate.outputCoordinate input + | chain | node | ftsLeaf | ftsNode | ftsRoots => + exact (preservesHidden_probe candidate).bind fun _ => + preservesHidden_resolveKnownInput parameter candidate.outputCoordinate input + | none => exact (preservesHidden_probe candidate).bind fun _ => + preservesHidden_resolveKnownInput parameter candidate.outputCoordinate input + | none => + cases decodePosition? parameter input with + | none => exact preservesHidden_splitHashQuery_ordinary input + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + exact preservesHidden_resolveKnownInput parameter + (.position (.chain lay tree leafIdx chainIdx step)) input + | leaf lay tree leafIdx => + exact preservesHidden_resolveKnownInput parameter + (.position (.leaf lay tree leafIdx)) input + | node lay tree level nodeIdx => + exact (preservesHidden_probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)).bind fun _ => + preservesHidden_resolveKnownInput parameter + (.position (.node lay tree level nodeIdx)) input + | ftsLeaf | ftsNode | ftsRoots => exact preservesHidden_splitHashQuery_ordinary input + +theorem preservesHiddenImpl_probingHashImpl (parameter : PublicParameter) : + PreservesHiddenImpl (probingHashImpl parameter) := + preservesHidden_probingHashQuery parameter + +theorem preservesHiddenImpl_probingRomImpl (parameter : PublicParameter) : + PreservesHiddenImpl (probingRomImpl parameter) := by + intro query + cases query with + | inl query => exact preservesHiddenImpl_splitUniformImpl query + | inr query => exact preservesHiddenImpl_probingHashImpl parameter query + +theorem preservesHidden_revealPositionValues (positions : List Position) : + PreservesHidden (revealPositionValues positions) := by + induction positions with + | nil => exact preservesHidden_pure [] + | cons position remaining ih => + exact (preservesHidden_revealPosition position).bind fun value => + ih.bind fun values => preservesHidden_pure (value :: values) + +theorem preservesHidden_revealTableInputChildren (coordinate : Coordinate) : + PreservesHidden (revealTableInputChildren coordinate) := by + cases coordinate with + | chainStart => exact preservesHidden_pure () + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + by_cases hzero : step.val = 0 + · simp only [revealTableInputChildren, hzero, ↓reduceIte] + exact (preservesHidden_revealChainStart lay tree leafIdx chainIdx).bind fun _ => + preservesHidden_pure () + · simp only [revealTableInputChildren, hzero, ↓reduceIte] + exact (preservesHidden_revealPositionValues _).bind fun _ => + preservesHidden_pure () + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp only [revealTableInputChildren] + exact (preservesHidden_revealPositionValues _).bind fun _ => + preservesHidden_pure () + +theorem preservesHidden_resolveVerifierInput (parameter : PublicParameter) + (coordinate : Coordinate) (input : HashInput) : + PreservesHidden (resolveVerifierInput parameter coordinate input) := by + unfold resolveVerifierInput + exact preservesHidden_get.bind fun cache => + match cache (.ordinary input) with + | some output => preservesHidden_pure output + | none => + (preservesHidden_revealTableInputChildren coordinate).bind fun _ => + preservesHidden_resolveKnownInput parameter coordinate input + +theorem preservesHidden_verifierHashQuery (parameter : PublicParameter) + (input : HashInput) : PreservesHidden (verifierHashQuery parameter input) := by + unfold verifierHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + exact (preservesHidden_probe candidate).bind fun _ => + preservesHidden_resolveVerifierInput parameter candidate.outputCoordinate input + | none => + cases hposition : decodePosition? parameter input with + | none => exact preservesHidden_splitHashQuery_ordinary input + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + exact preservesHidden_resolveVerifierInput parameter + (.position (.chain lay tree leafIdx chainIdx step)) input + | leaf lay tree leafIdx => + exact preservesHidden_resolveVerifierInput parameter + (.position (.leaf lay tree leafIdx)) input + | node lay tree level nodeIdx => + exact preservesHidden_resolveVerifierInput parameter + (.position (.node lay tree level nodeIdx)) input + | ftsLeaf | ftsNode | ftsRoots => exact preservesHidden_splitHashQuery_ordinary input + +theorem preservesHiddenImpl_verifierHashImpl (parameter : PublicParameter) : + PreservesHiddenImpl (verifierHashImpl parameter) := + preservesHidden_verifierHashQuery parameter + +theorem preservesHiddenImpl_verifierRomImpl (parameter : PublicParameter) : + PreservesHiddenImpl (verifierRomImpl parameter) := by + intro query + cases query with + | inl query => exact preservesHiddenImpl_splitUniformImpl query + | inr query => exact preservesHiddenImpl_verifierHashImpl parameter query + +theorem preservesHiddenImpl_maskedSigningImpl (parameter : PublicParameter) + (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + PreservesHiddenImpl (maskedSigningImpl parameter root ftsSecret) := + preservesHidden_maskedSign parameter root ftsSecret + +theorem preservesHiddenImpl_maskedExpandedAdversaryImpl (parameter : PublicParameter) + (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + PreservesHiddenImpl (maskedExpandedAdversaryImpl parameter root ftsSecret) := by + intro query + cases query with + | inl query => exact preservesHiddenImpl_probingRomImpl parameter query + | inr query => exact preservesHiddenImpl_maskedSigningImpl parameter root ftsSecret query + +theorem PreservesHidden.map {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + (hcomputation : PreservesHidden computation) (transform : alpha → beta) : + PreservesHidden (transform <$> computation) := by + rw [map_eq_bind_pure_comp] + exact hcomputation.bind fun value => preservesHidden_pure (transform value) + +def WriterPreservesHidden [EmptyCollection ω] [Append ω] + (computation : WriterT ω + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate))) alpha) : Prop := + PreservesHidden computation.run + +theorem writerPreservesHidden_pure [EmptyCollection ω] [Append ω] + [LawfulAppend ω] (value : alpha) : + WriterPreservesHidden (pure value : WriterT ω + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate))) alpha) := by + rw [WriterPreservesHidden, WriterT.run_pure'] + exact preservesHidden_pure (value, ∅) + +theorem WriterPreservesHidden.bind [EmptyCollection ω] [Append ω] + [LawfulAppend ω] + {left : WriterT ω + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate))) alpha} + {next : alpha → WriterT ω + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate))) beta} + (hleft : WriterPreservesHidden left) + (hnext : ∀ value, WriterPreservesHidden (next value)) : + WriterPreservesHidden (left >>= next) := by + rw [WriterPreservesHidden, WriterT.bind_def'] + exact PreservesHidden.bind hleft fun leftResult => + PreservesHidden.map (hnext leftResult.1) fun rightResult => + (rightResult.1, leftResult.2 ++ rightResult.2) + +theorem writerPreservesHidden_lift [EmptyCollection ω] [Append ω] + [LawfulAppend ω] + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + (hcomputation : PreservesHidden computation) : + WriterPreservesHidden + (monadLift computation : WriterT ω + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate))) alpha) := by + rw [WriterPreservesHidden, WriterT.run_monadLift'] + exact hcomputation.map fun value => (value, ∅) + +theorem writerPreservesHidden_tell [EmptyCollection ω] [Append ω] + [LawfulAppend ω] (trace : ω) : + WriterPreservesHidden + (tell trace : WriterT ω + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate))) PUnit) := by + rw [WriterPreservesHidden, WriterT.run_tell] + exact preservesHidden_pure (PUnit.unit, trace) + +theorem writerPreservesHidden_withTraceAppend [EmptyCollection ω] [Append ω] + [LawfulAppend ω] + {spec : OracleSpec ι} + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (traceFn : (query : spec.Domain) → spec.Range query → ω) + (himpl : PreservesHiddenImpl impl) (query : spec.Domain) : + WriterPreservesHidden (QueryImpl.withTraceAppend impl traceFn query) := by + rw [QueryImpl.withTraceAppend_apply] + exact (writerPreservesHidden_lift (himpl query)).bind fun output => + (writerPreservesHidden_tell (traceFn query output)).bind fun _ => + writerPreservesHidden_pure output + +theorem writerPreservesHidden_simulateQ [EmptyCollection ω] [Append ω] + [LawfulAppend ω] + {spec : OracleSpec ι} + (impl : QueryImpl spec + (WriterT ω + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate))))) + (himpl : ∀ query, WriterPreservesHidden (impl query)) + (computation : OracleComp spec alpha) : + WriterPreservesHidden (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => exact writerPreservesHidden_pure value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (himpl query).bind ih + +theorem preservesHidden_simulateQ_withTraceAppend_run [EmptyCollection ω] [Append ω] + [LawfulAppend ω] + {spec : OracleSpec ι} + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (traceFn : (query : spec.Domain) → spec.Range query → ω) + (himpl : PreservesHiddenImpl impl) (computation : OracleComp spec alpha) : + PreservesHidden (simulateQ (QueryImpl.withTraceAppend impl traceFn) computation).run := + writerPreservesHidden_simulateQ _ + (writerPreservesHidden_withTraceAppend impl traceFn himpl) computation + +theorem preservesHidden_retainedGameRestComputation (adversary : Adversary) + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + PreservesHidden + (simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (retainedGameRestComputation adversary ⟨root, parameter⟩)) := by + rw [simulateQ_maskedExpanded_retainedGameRestComputation, + ← simulateQ_withTraceAppend_run_eq_signingTraceComputation] + exact (preservesHidden_simulateQ_withTraceAppend_run + (maskedExpandedAdversaryImpl parameter root ftsSecret) signingLogFragment + (preservesHiddenImpl_maskedExpandedAdversaryImpl parameter root ftsSecret) + (adversary.main ⟨root, parameter⟩)).bind fun adversaryResult => + (preservesHiddenImpl_probingRomImpl parameter).simulateQ + (scheme.verify ⟨root, parameter⟩ adversaryResult.1.message + adversaryResult.1.signature) |>.bind fun verified => + preservesHidden_pure ((adversaryResult.1, adversaryResult.2), verified) + +theorem preservesHidden_maskedRetainedGameAfterFtsSecrets (adversary : Adversary) + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + PreservesHidden + (maskedRetainedGameAfterFtsSecrets adversary parameter ftsSecret) := by + unfold maskedRetainedGameAfterFtsSecrets + exact (preservesHidden_maskedTreeRoot topLayer rootTree).bind fun root => + (preservesHidden_publishCoordinate (.position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0))).bind + fun _ => + (preservesHiddenImpl_maskedExpandedAdversaryImpl parameter root ftsSecret).simulateQ + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) |>.bind + fun adversaryResult => + (preservesHiddenImpl_verifierRomImpl parameter).simulateQ + (scheme.verify ⟨root, parameter⟩ adversaryResult.1.message + adversaryResult.1.signature) |>.bind fun verified => + preservesHidden_pure (root, (adversaryResult, verified)) + +theorem preservesHidden_maskedGameAfterFtsSecrets (adversary : Adversary) + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + PreservesHidden (maskedGameAfterFtsSecrets adversary parameter ftsSecret) := by + unfold maskedGameAfterFtsSecrets + exact (preservesHidden_maskedTreeRoot topLayer rootTree).bind fun root => + (preservesHidden_publishCoordinate (.position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0))).bind + fun _ => + (preservesHidden_simulateQ_withTraceAppend_run + (maskedExpandedAdversaryImpl parameter root ftsSecret) signingLogFragment + (preservesHiddenImpl_maskedExpandedAdversaryImpl parameter root ftsSecret) + (adversary.main ⟨root, parameter⟩)).bind fun adversaryResult => + (preservesHiddenImpl_verifierRomImpl parameter).simulateQ + (scheme.verify ⟨root, parameter⟩ adversaryResult.1.message + adversaryResult.1.signature) |>.bind fun verified => + preservesHidden_pure (decide + (SigningTranscript.Valid adversaryResult.2 ∧ + ¬SigningTranscript.Contains adversaryResult.2 adversaryResult.1) && + verified) + +noncomputable def maskedGameComputation (adversary : Adversary) + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) Bool := + maskedGameAfterFtsSecrets adversary parameter ftsSecret + +theorem preservesHidden_maskedGameComputation (adversary : Adversary) + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + PreservesHidden (maskedGameComputation adversary parameter ftsSecret) := by + rw [maskedGameComputation] + exact preservesHidden_maskedGameAfterFtsSecrets adversary parameter ftsSecret + +theorem finalizeDetailedFrom_preservesHidden (coordinates : List Coordinate) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (hconsistent : HiddenConsistent state cache) (finalState : LazyRevealProbe.State Coordinate) + (hresult : (false, finalState) ∈ support + (LazyRevealProbe.finalizeDetailedFrom coordinates state)) : + HiddenConsistent finalState cache := by + induction coordinates generalizing state with + | nil => + simp [LazyRevealProbe.finalizeDetailedFrom] at hresult + rcases hresult with ⟨rfl, rfl⟩ + exact hconsistent + | cons coordinate remaining ih => + rw [LazyRevealProbe.finalizeDetailedFrom] at hresult + cases hvalue : state.values coordinate with + | some output => + rw [hvalue] at hresult + exact ih (state.clearPending coordinate) (hconsistent.clearPending coordinate) hresult + | none => + rw [hvalue] at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _, hrest⟩ := hresult + by_cases hhit : state.hitAt coordinate output + · rw [if_pos hhit] at hrest + simp at hrest + · rw [if_neg hhit] at hrest + exact ih (state.complete coordinate output) + (hconsistent.complete_of_none coordinate output hvalue) hrest + +theorem finalizeDetailed_preservesHidden (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (hconsistent : HiddenConsistent state cache) + (finalState : LazyRevealProbe.State Coordinate) + (hresult : (false, finalState) ∈ support (LazyRevealProbe.finalizeDetailed state)) : + HiddenConsistent finalState cache := + finalizeDetailedFrom_preservesHidden state.coordinates.toList state cache hconsistent + finalState hresult + +theorem detailedExperiment_hiddenConsistent + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hpreserves : PreservesHidden computation) + (initialState : LazyRevealProbe.State Coordinate) (initialCache : SplitHashCache) + (hinitial : HiddenConsistent initialState initialCache) (fuel : Nat) + (finalState : LazyRevealProbe.State Coordinate) (remaining : Nat) + (value : alpha) (finalCache : SplitHashCache) + (hresult : LazyRevealProbe.DetailedResult.done false finalState remaining + (value, finalCache) ∈ support + (LazyRevealProbe.detailedExperiment initialState fuel + (computation.run initialCache))) : + HiddenConsistent finalState finalCache := by + rw [LazyRevealProbe.detailedExperiment, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hfinish⟩ := hresult + cases raw with + | stopped hit => + simp [LazyRevealProbe.RawResult.finishDetailed] at hfinish + | done state remainingFuel result => + rcases result with ⟨resultValue, cache⟩ + have hmiddle : HiddenConsistent state cache := by + exact PreservesHidden.done + (computation := computation) hpreserves + (state := initialState) (cache := initialCache) + (fuel := fuel) (finalState := state) (remaining := remainingFuel) + (value := resultValue) (finalCache := cache) hinitial hraw + rw [LazyRevealProbe.RawResult.finishDetailed, mem_support_bind_iff] at hfinish + obtain ⟨finished, hfinished, hdone⟩ := hfinish + rcases finished with ⟨hit, completedState⟩ + simp at hdone + rcases hdone with ⟨rfl, rfl, rfl, rfl, rfl⟩ + exact finalizeDetailed_preservesHidden state finalCache hmiddle finalState hfinished + +theorem mergeDecodedPosition_eq_some_imp_tableAnswerDecoded + (parameter : PublicParameter) + (table : Coordinate → HashOutput) (ensured : Finset Coordinate) + (cache : SplitHashCache) + (hhidden : ∀ coordinate output, + completedSplitHashCache table ensured cache (.hidden coordinate) = some output → + output = table coordinate) + (input : HashInput) (decoded : Option Position) (output : HashOutput) + (hcached : mergeDecodedPosition parameter table ensured cache input decoded = + some output) : + tableAnswerDecoded parameter table (splitFallback cache) input decoded = output := by + cases decoded with + | none => + simp only [mergeDecodedPosition] at hcached + simp only [tableAnswerDecoded, splitFallback] + simp [hcached] + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + by_cases hexact : input = tableInput parameter table + (.position (.chain lay tree leafIdx chainIdx step)) + · simp only [mergeDecodedPosition, hexact, ↓reduceIte] at hcached + simp only [tableAnswerDecoded, hexact, ↓reduceIte] + exact (hhidden _ _ hcached).symm + · simp only [mergeDecodedPosition, hexact, ↓reduceIte] at hcached + simp only [tableAnswerDecoded, hexact, ↓reduceIte, splitFallback] + simp [hcached] + | leaf lay tree leafIdx => + by_cases hexact : input = tableInput parameter table + (.position (.leaf lay tree leafIdx)) + · simp only [mergeDecodedPosition, hexact, ↓reduceIte] at hcached + simp only [tableAnswerDecoded, hexact, ↓reduceIte] + exact (hhidden _ _ hcached).symm + · simp only [mergeDecodedPosition, hexact, ↓reduceIte] at hcached + simp only [tableAnswerDecoded, hexact, ↓reduceIte, splitFallback] + simp [hcached] + | node lay tree level nodeIdx => + by_cases hexact : input = tableInput parameter table + (.position (.node lay tree level nodeIdx)) + · simp only [mergeDecodedPosition, hexact, ↓reduceIte] at hcached + simp only [tableAnswerDecoded, hexact, ↓reduceIte] + exact (hhidden _ _ hcached).symm + · simp only [mergeDecodedPosition, hexact, ↓reduceIte] at hcached + simp only [tableAnswerDecoded, hexact, ↓reduceIte, splitFallback] + simp [hcached] + | ftsLeaf | ftsNode | ftsRoots => + simp only [mergeDecodedPosition] at hcached + simp only [tableAnswerDecoded, splitFallback] + simp [hcached] + +theorem mergedCache_agreesWith_tableAnswer (parameter : PublicParameter) + (table : Coordinate → HashOutput) (ensured : Finset Coordinate) + (cache : SplitHashCache) + (hhidden : ∀ coordinate output, + completedSplitHashCache table ensured cache (.hidden coordinate) = some output → + output = table coordinate) : + (mergedCache parameter table ensured cache).AgreesWithFn + (tableAnswer parameter table (splitFallback cache)) := by + intro input output hcached + exact mergeDecodedPosition_eq_some_imp_tableAnswerDecoded parameter table ensured cache + hhidden input (decodePosition? parameter input) output hcached + +theorem fromMergedCache_tableInput (parameter : PublicParameter) + (table : Coordinate → HashOutput) (ensured : Finset Coordinate) + (cache : SplitHashCache) (position : Position) (hots : IsOtsPosition position) + (hcomplete : completedSplitHashCache table ensured cache + (.hidden (.position position)) = some (table (.position position))) : + fromCache (mergedCache parameter table ensured cache) + (tableInput parameter table (.position position)) = + table (.position position) := by + rw [fromCache, mergedCache_tableInput parameter table ensured cache position hots, + hcomplete] + rfl + +theorem fromMergedCache_realizesTable (parameter : PublicParameter) + (table : Coordinate → HashOutput) (ensured : Finset Coordinate) + (cache : SplitHashCache) + (hcomplete : ∀ position : Position, IsOtsPosition position → + completedSplitHashCache table ensured cache (.hidden (.position position)) = + some (table (.position position))) : + ∀ position : Position, IsOtsPosition position → + fromCache (mergedCache parameter table ensured cache) + (tableInput parameter table (.position position)) = + table (.position position) := by + intro position hots + exact fromMergedCache_tableInput parameter table ensured cache position hots + (hcomplete position hots) + +theorem honestChain_eq_table_succ + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (hf : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (step : Nat) (hstep : step < chainLength - 1) : + honestChain f parameter lay tree leafIdx chainIdx + (tableOtsSecret table lay tree leafIdx chainIdx) (step + 1) = + tableValue table (.chain lay tree leafIdx chainIdx ⟨step, hstep⟩) := by + induction step using Nat.strong_induction_on with + | h step ih => + rw [honestChain_succ f parameter lay tree leafIdx chainIdx _ step hstep] + have hinput : + tweakableHashInput parameter (.chain lay tree leafIdx chainIdx ⟨step, hstep⟩) + (digestBytes (honestChain f parameter lay tree leafIdx chainIdx + (tableOtsSecret table lay tree leafIdx chainIdx) step)) = + tableInput parameter table + (.position (.chain lay tree leafIdx chainIdx ⟨step, hstep⟩)) := by + cases step with + | zero => + simp [honestChain_zero, tableInput, tablePayload, tableOtsSecret, + Position.domain] + | succ previous => + have hprevious : previous < chainLength - 1 := by omega + rw [ih previous (by omega) hprevious] + simp [tableInput, tablePayload, Position.children, Position.domain] + rw [hinput, hf (.chain lay tree leafIdx chainIdx ⟨step, hstep⟩) (by trivial)] + rfl + +theorem honestEndpoints_eq_table + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) + (hf : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) : + honestEndpoints f parameter lay tree (tableOtsSecret table lay tree) leafIdx = + fun chainIdx => + tableValue table (.chain lay tree leafIdx chainIdx Position.lastChainStep) := by + funext chainIdx + unfold honestEndpoints + have h := honestChain_eq_table_succ f parameter table lay tree leafIdx chainIdx hf + (chainLength - 2) (by decide) + rw [show chainLength - 2 + 1 = chainLength - 1 by + norm_num [chainLength, winternitzBits]] at h + have hposition : (⟨chainLength - 2, by decide⟩ : ChainStep) = + Position.lastChainStep := Fin.ext (by rfl) + rw [hposition] at h + exact h + +theorem honestNode_zero_eq_table + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) + (hf : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) : + honestNode f parameter lay tree (tableOtsSecret table lay tree) 0 leafIdx.val = + tableValue table (.leaf lay tree leafIdx) := by + rw [honestNode_zero_eq_leafHash] + rw [honestEndpoints_eq_table f parameter table lay tree leafIdx hf] + have hinput : + tweakableHashInput parameter (.leaf lay tree leafIdx) + (leafPayload fun chainIdx => + tableValue table (.chain lay tree leafIdx chainIdx Position.lastChainStep)) = + tableInput parameter table (.position (.leaf lay tree leafIdx)) := by + simp [tableInput, tablePayload, Position.children, Position.domain, leafPayload, + Function.comp_def] + rw [hinput, hf (.leaf lay tree leafIdx) (by trivial)] + rfl + +theorem honestNode_eq_table_succ + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (table : Coordinate → HashOutput) (lay : Layer) (tree : TreeIndex) + (hf : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (level nodeIdx : Nat) (hlevel : level < maxLayerHeight) + (hspan : 2 ^ (level + 1) * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) : + honestNode f parameter lay tree (tableOtsSecret table lay tree) (level + 1) nodeIdx = + tableValue table + (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx)) := by + induction level using Nat.strong_induction_on generalizing nodeIdx with + | h level ih => + rw [honestNode_succ] + have hnode : nodeIdx < 2 ^ maxLayerHeight := by + have hpow : 0 < 2 ^ (level + 1) := pow_pos (by omega) _ + nlinarith + have hpowTwo : 2 ≤ 2 ^ (level + 1) := by + have hp : 2 ^ 1 ≤ 2 ^ (level + 1) := + Nat.pow_le_pow_right (by omega) (by omega) + simpa using hp + have hleft : 2 * nodeIdx < 2 ^ maxLayerHeight := by + nlinarith + have hright : 2 * nodeIdx + 1 < 2 ^ maxLayerHeight := by + nlinarith + by_cases hzero : level = 0 + · subst level + have hleftValue := honestNode_zero_eq_table f parameter table lay tree + (leafOfNat (2 * nodeIdx)) hf + have hrightValue := honestNode_zero_eq_table f parameter table lay tree + (leafOfNat (2 * nodeIdx + 1)) hf + have hleftIndex : (leafOfNat (2 * nodeIdx)).val = 2 * nodeIdx := by + simp [leafOfNat, Nat.mod_eq_of_lt hleft] + have hrightIndex : (leafOfNat (2 * nodeIdx + 1)).val = 2 * nodeIdx + 1 := by + simp [leafOfNat, Nat.mod_eq_of_lt hright] + rw [hleftIndex] at hleftValue + rw [hrightIndex] at hrightValue + rw [hleftValue, hrightValue] + have hinput : + tweakableHashInput parameter (.node lay tree 1 nodeIdx) + (nodePayload + (tableValue table (.leaf lay tree (leafOfNat (2 * nodeIdx)))) + (tableValue table (.leaf lay tree (leafOfNat (2 * nodeIdx + 1))))) = + tableInput parameter table + (.position (.node lay tree ⟨0, hlevel⟩ (leafOfNat nodeIdx))) := by + simp only [tableInput, tablePayload, Position.domain] + rw [Position.children, dif_pos (by + simpa [leafOfNat, Nat.mod_eq_of_lt hnode] using hright), + dif_neg (show ¬0 < (⟨0, hlevel⟩ : Fin maxLayerHeight).val by simp)] + simp [nodePayload, leafOfNat, Nat.mod_eq_of_lt hnode, + Nat.mod_eq_of_lt hleft, Nat.mod_eq_of_lt hright] + rw [hinput, hf (.node lay tree ⟨0, hlevel⟩ (leafOfNat nodeIdx)) (by trivial)] + rfl + · obtain ⟨previous, rfl⟩ : ∃ previous, level = previous + 1 := + ⟨level - 1, by omega⟩ + have hleftSpan : 2 ^ (previous + 1) * (2 * nodeIdx + 1) ≤ + 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith + have hrightSpan : 2 ^ (previous + 1) * (2 * nodeIdx + 1 + 1) ≤ + 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith + rw [ih previous (by omega) (2 * nodeIdx) (by omega) hleftSpan, + ih previous (by omega) (2 * nodeIdx + 1) (by omega) hrightSpan] + have hinput : + tweakableHashInput parameter (.node lay tree (previous + 1 + 1) nodeIdx) + (nodePayload + (tableValue table + (.node lay tree ⟨previous, by omega⟩ (leafOfNat (2 * nodeIdx)))) + (tableValue table + (.node lay tree ⟨previous, by omega⟩ + (leafOfNat (2 * nodeIdx + 1))))) = + tableInput parameter table + (.position + (.node lay tree ⟨previous + 1, hlevel⟩ (leafOfNat nodeIdx))) := by + simp only [tableInput, tablePayload, Position.domain] + rw [Position.children, dif_pos (by + simpa [leafOfNat, Nat.mod_eq_of_lt hnode] using hright), + dif_pos (show 0 < (⟨previous + 1, hlevel⟩ : Fin maxLayerHeight).val by + simp)] + simp [nodePayload, leafOfNat, Nat.mod_eq_of_lt hnode, + Nat.mod_eq_of_lt hleft, Nat.mod_eq_of_lt hright] + rw [hinput, + hf (.node lay tree ⟨previous + 1, hlevel⟩ (leafOfNat nodeIdx)) (by trivial)] + rfl + +theorem honestNode_eq_table_succ_fromMerged + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (ensured : Finset Coordinate) (cache : SplitHashCache) + (hcomplete : ∀ position : Position, IsOtsPosition position → + completedSplitHashCache table ensured cache (.hidden (.position position)) = + some (table (.position position))) + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) + (hlevel : level < maxLayerHeight) + (hspan : 2 ^ (level + 1) * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) : + honestNode (fromCache (mergedCache parameter table ensured cache)) parameter lay tree + (tableOtsSecret table lay tree) (level + 1) nodeIdx = + tableValue table + (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx)) := + honestNode_eq_table_succ + (fromCache (mergedCache parameter table ensured cache)) parameter table lay tree + (fromMergedCache_realizesTable parameter table ensured cache hcomplete) + level nodeIdx hlevel hspan + +theorem honestNode_eq_table_succ_tableAnswer + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (fallback : QueryImpl HashSpec Id) (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) (hlevel : level < maxLayerHeight) + (hspan : 2 ^ (level + 1) * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) : + honestNode (tableAnswer parameter table fallback) parameter lay tree + (tableOtsSecret table lay tree) (level + 1) nodeIdx = + tableValue table + (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx)) := + honestNode_eq_table_succ (tableAnswer parameter table fallback) parameter table lay tree + (tableAnswer_tableInput parameter table fallback) level nodeIdx hlevel hspan + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRecursiveRejectionRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRecursiveRejectionRisk.lean new file mode 100644 index 00000000..fe7431e1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRecursiveRejectionRisk.lean @@ -0,0 +1,265 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalPendingHit + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option backward.isDefEq.respectTransparency false + +theorem evalDist_finalizeResolvedCoordinates_eq_none_of_pendingResolvedHit + (table : OtsSecretIndex → HashOutput) (coordinates : List Coordinate) (context : DeferredContext) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hcovered : PendingCovered coordinates context) + (hhit : PendingResolvedHit table context) : + evalDist (finalizeResolvedCoordinates coordinates context table) = + evalDist (pure none : ProbComp (Option DeferredContext)) := by + obtain ⟨coordinate, output, hvalue, hhit⟩ := hhit + have hpending : (coordinate, truncateHash output) ∈ context.state.pending := by + rwa [← LazyRevealProbe.State.mem_pendingAt_iff] + have hmem : coordinate ∈ coordinates := hcovered _ hpending + have hmissing : context.state.values coordinate = none := by + cases hstate : context.state.values coordinate with + | none => rfl + | some cached => + have heq : cached = output := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + have htable := hstarts ⟨lay, tree, leafIdx, chainIdx⟩ cached hstate + simpa [resolvedCompletionValue, htable] using hvalue + | position position => simpa [resolvedCompletionValue, DeferredContext.positionValue, hstate] using hvalue + exact False.elim (hvalid.2 coordinate cached hstate (heq ▸ hhit)) + rw [evalDist_finalizeResolvedCoordinates_move_to_front coordinate coordinates context table hmem] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + have heq : table ⟨lay, tree, leafIdx, chainIdx⟩ = output := by + simpa [resolvedCompletionValue] using hvalue + rw [finalizeResolvedCoordinates] + simp only [hmissing] + rw [resolveDeferredChainStart_of_missing table ⟨lay, tree, leafIdx, chainIdx⟩ context hmissing] + simp [OtsSecretIndex.coordinate, heq, hhit] + | position position => + have hdeferred : context.values position = some output := by + simpa [resolvedCompletionValue, DeferredContext.positionValue, hmissing] using hvalue + rw [finalizeResolvedCoordinates_cons_position_of_deferred_value position _ context table output + hmissing hdeferred, if_pos hhit] + +theorem evalDist_finalizeResolvedCoordinates_eq_none_of_not_completable + (table : OtsSecretIndex → HashOutput) (coordinates : List Coordinate) (context : DeferredContext) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hcovered : PendingCovered coordinates context) + (hcard : context.state.pending.card < Fintype.card Digest) + (hstop : ¬DeferredCompletable table context) : + evalDist (finalizeResolvedCoordinates coordinates context table) = + evalDist (pure none : ProbComp (Option DeferredContext)) := by + apply evalDist_finalizeResolvedCoordinates_eq_none_of_pendingResolvedHit table coordinates context + hvalid hstarts hcovered + exact Classical.not_not.mp fun hclean => hstop + ((deferredCompletable_iff_no_pendingResolvedHit table context hvalid.valuesConsistent hstarts hcard).mpr hclean) + +theorem evalDist_finalize_materializeResolvedReveal_dynamic + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (position : Position) (result : DeferredResolution) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hcard : context.state.pending.card < Fintype.card Digest) + (hresult : some result ∈ support (resolveDeferredReveal table position context)) : + evalDist (Option.isNone <$> finalizeResolvedCoordinates + (materializeResolvedPosition context position result).state.coordinates.toList + (materializeResolvedPosition context position result) table) = + evalDist (Option.isNone <$> finalizeResolvedCoordinates + result.state.coordinates.toList result.toDeferredContext table) := by + by_cases hcomplete : DeferredCompletable table (materializeResolvedPosition context position result) + · exact evalDist_map_isNone_finalizeResolvedCoordinates_materializeResolvedReveal_dynamic + position result hvalid hstarts hresult hcomplete + · have hresolvedValid := hvalid.of_resolveDeferredReveal table position result hresult + have hvalues := resolveDeferredReveal_preserves_state_values table position context result hresult + have hresolved := resolveDeferredReveal_resolves table position context result hresult + have hmaterializedValid := hvalid.materializeResolvedPosition_of position result hresolvedValid hvalues hresolved + have hmaterializedStarts : StartTableAgrees (materializeResolvedPosition context position result).state table := + hstarts.materialize_position position result.output + have hresolvedStarts := hstarts.of_state_values_eq hvalues + have hsubset : result.state.pending ⊆ context.state.pending := + (resolveDeferredReveal_pendingAway_subset table position context result hresult).trans (Finset.filter_subset _ _) + have hresolvedCard := (Finset.card_le_card hsubset).trans_lt hcard + have hmaterializedCard : (materializeResolvedPosition context position result).state.pending.card < + Fintype.card Digest := + (Finset.card_le_card (Finset.filter_subset _ _)).trans_lt hcard + have hresolvedStop : ¬DeferredCompletable table result.toDeferredContext := by + rintro ⟨completion, hcompletion⟩ + exact hcomplete ⟨completion, + (deferredCompletion_materializeResolvedReveal_iff position result hvalid hstarts hresult).mpr hcompletion⟩ + rw [evalDist_map, evalDist_map, + evalDist_finalizeResolvedCoordinates_eq_none_of_not_completable table _ _ hmaterializedValid + hmaterializedStarts (pendingCovered_coordinates_toList _) hmaterializedCard hcomplete, + evalDist_finalizeResolvedCoordinates_eq_none_of_not_completable table _ _ hresolvedValid + hresolvedStarts (pendingCovered_coordinates_toList _) hresolvedCard hresolvedStop] + +theorem evalDist_finalizeResolvedCoordinates_eq_dynamic + (table : OtsSecretIndex → HashOutput) (coordinates : List Coordinate) (context : DeferredContext) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hcovered : PendingCovered coordinates context) (hnodup : coordinates.Nodup) + (hcard : context.state.pending.card < Fintype.card Digest) : + evalDist (Option.isNone <$> finalizeResolvedCoordinates coordinates context table) = + evalDist (Option.isNone <$> finalizeResolvedCoordinates context.state.coordinates.toList context table) := by + by_cases hcomplete : DeferredCompletable table context + · apply evalDist_map_isNone_finalizeResolvedCoordinates_congr_covered table coordinates + context.state.coordinates.toList context context + (FinalizationViewEq.refl table context hvalid hstarts ?_) hnodup (Finset.nodup_toList _) + hcovered (pendingCovered_coordinates_toList context) + intro coordinate output hvalue hhit + exact hcomplete.not_pendingResolvedHit ⟨coordinate, output, hvalue, hhit⟩ + · rw [evalDist_map, evalDist_map, + evalDist_finalizeResolvedCoordinates_eq_none_of_not_completable table coordinates context + hvalid hstarts hcovered hcard hcomplete, + evalDist_finalizeResolvedCoordinates_eq_none_of_not_completable table _ context + hvalid hstarts (pendingCovered_coordinates_toList _) hcard hcomplete] + +theorem evalDist_resolveDeferredReveal_then_finalize_materialized + (table : OtsSecretIndex → HashOutput) (position : Position) (context : DeferredContext) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hcard : context.state.pending.card < Fintype.card Digest) : + evalDist (do + let result ← resolveDeferredReveal table position context + match result with + | none => pure true + | some result => Option.isNone <$> (finalizeResolvedCoordinates + (materializeResolvedPosition context position result).state.coordinates.toList + (materializeResolvedPosition context position result) table)) = + evalDist (Option.isNone <$> finalizeResolvedCoordinates context.state.coordinates.toList context table) := by + let coordinates := context.state.coordinates.toList + have hbase := evalDist_map_resolveDeferredReveal_then_finalize table position coordinates context + hvalid (pendingCovered_coordinates_toList context) + calc + _ = evalDist (Option.isNone <$> (do + let result ← resolveDeferredReveal table position context + match result with + | none => (pure none : ProbComp (Option (LazyRevealProbe.State Coordinate))) + | some result => projectDeferredState <$> + finalizeResolvedCoordinates coordinates result.toDeferredContext table)) := by + rw [map_bind] + apply evalDist_bind_congr + intro option hoption + cases option with + | none => simp + | some result => + have hsubset : result.state.pending ⊆ context.state.pending := + (resolveDeferredReveal_pendingAway_subset table position context result hoption).trans (Finset.filter_subset _ _) + have hresolvedValid := hvalid.of_resolveDeferredReveal table position result hoption + have hresolvedStarts := hstarts.of_state_values_eq + (resolveDeferredReveal_preserves_state_values table position context result hoption) + have hresolvedCovered : PendingCovered coordinates result.toDeferredContext := by + intro entry hentry + exact pendingCovered_coordinates_toList context entry (hsubset hentry) + have hfixed := evalDist_finalizeResolvedCoordinates_eq_dynamic table coordinates result.toDeferredContext + hresolvedValid hresolvedStarts hresolvedCovered (Finset.nodup_toList _) + ((Finset.card_le_card hsubset).trans_lt hcard) + have hmaterialized := evalDist_finalize_materializeResolvedReveal_dynamic + position result hvalid hstarts hcard hoption + simpa only [Functor.map_map, Function.comp_def, projectDeferredState, Option.isNone_map] using + hmaterialized.trans hfixed.symm + _ = _ := by + rw [evalDist_map] + apply (congrArg (Functor.map Option.isNone) hbase).trans + rw [← evalDist_map, Functor.map_map] + simp only [projectDeferredState, Option.isNone_map, coordinates] + +noncomputable def resolvedPendingFailureRisk + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) : ℝ≥0∞ := + Pr[fun result => result = none | + finalizeResolvedCoordinates context.state.coordinates.toList context table] + +theorem resolvedPendingFailureRisk_eq_resolveDeferredReveal + (table : OtsSecretIndex → HashOutput) (position : Position) (context : DeferredContext) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hcard : context.state.pending.card < Fintype.card Digest) : + resolvedPendingFailureRisk table context = + ∑' option, Pr[= option | resolveDeferredReveal table position context] * + match option with + | none => 1 + | some result => resolvedPendingFailureRisk table (materializeResolvedPosition context position result) := by + have hdist := evalDist_resolveDeferredReveal_then_finalize_materialized table position context hvalid hstarts hcard + have hprob := congrArg (fun distribution : SPMF Bool => distribution true) hdist + change Pr[= true | _] = Pr[= true | _] at hprob + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput, + probEvent_bind_eq_tsum, probEvent_map] at hprob + simp only [Function.comp_def] at hprob + have hevent : (fun result : Option DeferredContext => result.isNone = true) = (fun result => result = none) := by + funext result; simp + rw [hevent] at hprob + change _ = resolvedPendingFailureRisk table context at hprob + rw [← hprob] + apply tsum_congr + intro option + cases option with + | none => simp + | some result => simp only [resolvedPendingFailureRisk, probEvent_map, Function.comp_def, hevent] + +theorem evalDist_finishResolvedRunIsNone_eq_finalize + (result : ResolvedRunResult α) (hvalid : result.context.Valid) + (hstarts : StartTableAgrees result.context.state result.table) + (hcard : result.context.state.pending.card < Fintype.card Digest) : + evalDist (finishResolvedRunIsNone (some result)) = + evalDist (Option.isNone <$> finalizeResolvedCoordinates + result.context.state.coordinates.toList result.context result.table) := by + by_cases hcomplete : DeferredCompletable result.table result.context + · rw [finishResolvedRunIsNone_some_eq_finalize result hcomplete] + · rw [finishResolvedRunIsNone, finishResolvedRun_of_not_deferredCompletable result hcomplete] + simp only [evalDist_map] + rw [evalDist_finalizeResolvedCoordinates_eq_none_of_not_completable + result.table _ result.context hvalid hstarts (pendingCovered_coordinates_toList _) hcard hcomplete] + simp + +theorem evalDist_runResolvedFinishIsNone_revealPosition + (table : OtsSecretIndex → HashOutput) (position : Position) (context : DeferredContext) + (fuel : Nat) (cache : SplitHashCache) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hcard : context.state.pending.card < Fintype.card Digest) : + evalDist (runResolvedFinishIsNone context fuel table ((revealCoordinate (.position position)).run cache)) = + evalDist (Option.isNone <$> finalizeResolvedCoordinates context.state.coordinates.toList context table) := by + apply Eq.trans ?_ (evalDist_resolveDeferredReveal_then_finalize_materialized table position context hvalid hstarts hcard) + rw [runResolvedFinishIsNone, runResolvedFromTable_revealCoordinate, bind_assoc] + apply evalDist_bind_congr + intro option hoption + cases option with + | none => simp [finishResolvedRunIsNone, finishResolvedRun] + | some result => + simp only [pure_bind] + have hresolvedValid := hvalid.of_resolveDeferredReveal table position result hoption + have hvalues := resolveDeferredReveal_preserves_state_values table position context result hoption + have hresolved := resolveDeferredReveal_resolves table position context result hoption + apply evalDist_finishResolvedRunIsNone_eq_finalize + · exact hvalid.materializeResolvedPosition_of position result hresolvedValid hvalues hresolved + · exact hstarts.materialize_position position result.output + · exact (Finset.card_le_card (Finset.filter_subset _ _)).trans_lt hcard + +theorem probEvent_resolvedQueryRejected_le_finished (computation : ProbComp (Option (ResolvedRunResult α))) : + Pr[ResolvedQueryRejected | computation] ≤ + Pr[fun verdict => verdict = true | computation >>= finishResolvedRunIsNone] := by + classical + rw [probEvent_eq_tsum_ite, probEvent_bind_eq_tsum] + apply ENNReal.tsum_le_tsum + intro option + by_cases hreject : ResolvedQueryRejected option + · rw [if_pos hreject] + cases option with + | none => simp [finishResolvedRunIsNone, finishResolvedRun] + | some result => + simp only [ResolvedQueryRejected] at hreject + simp [finishResolvedRunIsNone, finishResolvedRun_of_not_deferredCompletable result hreject] + · rw [if_neg hreject] + exact bot_le + +theorem probEvent_revealPosition_rejected_le_pendingFailureRisk + (table : OtsSecretIndex → HashOutput) (position : Position) (context : DeferredContext) + (fuel : Nat) (cache : SplitHashCache) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hcard : context.state.pending.card < Fintype.card Digest) : + Pr[ResolvedQueryRejected | runResolvedFromTable context fuel table + ((revealCoordinate (.position position)).run cache)] ≤ resolvedPendingFailureRisk table context := by + apply (probEvent_resolvedQueryRejected_le_finished _).trans_eq + have heq := congrArg (fun distribution : SPMF Bool => distribution true) + (evalDist_runResolvedFinishIsNone_revealPosition table position context fuel cache hvalid hstarts hcard) + change Pr[= true | _] = Pr[= true | _] at heq + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput, probEvent_map] at heq + simpa only [runResolvedFinishIsNone, Function.comp_def, Option.isNone_iff_eq_none, resolvedPendingFailureRisk] using heq + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResidual125.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResidual125.lean new file mode 100644 index 00000000..e6b7b96c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResidual125.lean @@ -0,0 +1,296 @@ +import SphincsSecurity.Proof.OtsProbeSelectionTransport125 + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +def PermissiveSelectionNonRoot : Option PermissivePrivateOrdinalSelection → Prop + | none => False + | some selection => ¬selection.candidate.IsLayerRoot + +set_option maxRecDepth 100000 in +theorem probEvent_canonicalNonRootSelection_le_delayedCommon + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[PrivateOrdinalSelectionNonRoot | + granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret + fuel] ≤ + Pr[PermissiveSelectionNonRoot | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table] := by + apply probEvent_le_of_relTriple + (relTriple_granularAllCanonicalPrivateOrdinalSelection_preserved ordinal adversary parameter + table ftsSecret fuel) + intro left right hrelation hnonRoot + cases left with + | none => exact False.elim hnonRoot + | some left => + cases right with + | none => exact False.elim hrelation + | some right => + change ¬right.candidate.IsLayerRoot + have hcandidate : left.candidate = right.candidate := hrelation.1 + rwa [← hcandidate] + +theorem rootSelection_nonRootSelection_mass_le_one + (common : ProbComp (Option PermissivePrivateOrdinalSelection)) : + Pr[fun selection => + (permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection).isSome = true | + common] + Pr[PermissiveSelectionNonRoot | common] ≤ 1 := by + classical + have hdisjoint : ∀ selection, + (permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection).isSome = true → + ¬PermissiveSelectionNonRoot selection := by + intro selection hroot hnonRoot + obtain ⟨target, htarget⟩ := Option.isSome_iff_exists.mp hroot + obtain ⟨selected, rfl, hcandidate, _⟩ := + (permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?_eq_some_iff + target selection).mp htarget + exact hnonRoot ⟨target, (candidateLayerRootPosition?_eq_some_iff _ _).mp hcandidate⟩ + rw [probEvent_eq_tsum_ite, probEvent_eq_tsum_ite, ← ENNReal.tsum_add] + apply le_trans (b := ∑' selection, Pr[= selection | common]) _ tsum_probOutput_le_one + apply ENNReal.tsum_le_tsum + intro selection + by_cases hroot : + (permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection).isSome = true + · simp [hroot, hdisjoint selection hroot] + · by_cases hnonRoot : PermissiveSelectionNonRoot selection + · simp [hroot, hnonRoot] + · simp [hroot, hnonRoot] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_granularAllCanonicalPlan_firstUsesNonRootOrdinal_le_selected_mass + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + granularAllCanonicalPrivateWitnessPlan adversary parameter table ftsSecret fuel] ≤ + Pr[PrivateOrdinalSelectionNonRoot | + granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret + fuel] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ Pr[fun hit : Bool => hit = true | + granularAllCanonicalPrivateOrdinalNonRootRisk ordinal adversary parameter table ftsSecret + fuel] := by + unfold granularAllCanonicalPrivateWitnessPlan + granularAllCanonicalPrivateOrdinalNonRootRisk + apply probEvent_runDirectWitnessPlanFirstUsesNonRootOrdinal_le_risk ordinal _ _ [] + emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) (by simp) + intro result hresult + apply probEvent_canonicalizeWitnessPlanFirstUsesNonRootOrdinal_le_risk table ordinal _ _ + result.context result.remaining result.value [] (by simp) + dsimp only + intro _hprivate hpublished _hcompletable + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) emptyWitnessDeferredContext fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hcore := resolvedCore_of_done_runDirectResolvedDetailedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) emptyWitnessDeferredContext fuel table + result DeferredContext.valid_empty.valuesConsistent (startTableAgrees_empty table) hdetailed + exact probEvent_granularDetailedRetainedRestWitnessFirstUsesNonRootOrdinal_le_nonRootRisk + adversary parameter table ftsSecret ordinal + (canonicalizeMaterializedValues table result.context) result.remaining result.value [] + (by simp) (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + hpublished.to_canonicalizedMaterializedValues + _ ≤ _ := probEvent_granularNonRootRisk_le_selected_mass ordinal adversary + parameter table ftsSecret fuel + +set_option maxRecDepth 100000 in +theorem probEvent_granularNonRootOrdinal_le_common_mass + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun output => WitnessFirstUsesNonLayerRootOrdinal ordinal + (erasePrivateWitnessSnapshotOutput output) | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel] ≤ + Pr[PermissiveSelectionNonRoot | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + have hprojection : + Pr[fun output => WitnessFirstUsesNonLayerRootOrdinal ordinal + (erasePrivateWitnessSnapshotOutput output) | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel] = + Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + granularAllCanonicalPrivateWitnessPlan adversary parameter table ftsSecret fuel] := by + rw [← map_erase_granularAllCanonicalPrivateWitnessSnapshot, probEvent_map] + rfl + rw [hprojection] + exact (probEvent_granularAllCanonicalPlan_firstUsesNonRootOrdinal_le_selected_mass ordinal + adversary parameter table ftsSecret fuel).trans + (mul_le_mul' (probEvent_canonicalNonRootSelection_le_delayedCommon ordinal adversary parameter + table ftsSecret fuel) le_rfl) + +namespace Range125 + +set_option maxRecDepth 100000 in +theorem probEvent_granularResidualOrdinal_pair_le_eight_sevenths + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hordinal : ordinal < q) (hq : q ≤ 2 ^ 125) : + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q] + + Pr[fun output => WitnessFirstUsesNonLayerRootOrdinal ordinal + (erasePrivateWitnessSnapshotOutput output) | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q] ≤ + (8 / 7 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let common := delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret q table + let rootMass := Pr[fun selection => + (permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection).isSome = true | common] + let nonRootMass := Pr[PermissiveSelectionNonRoot | common] + let epsilon := ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + have hroot := probEvent_granularAllCanonical_delayedOrdinal_le_selected_mass ordinal adversary + parameter table ftsSecret q hordinal hq + have hnonRoot := probEvent_granularNonRootOrdinal_le_common_mass ordinal adversary parameter + table ftsSecret q + have hcoefficient : epsilon ≤ (8 / 7 : ENNReal) * epsilon := by + calc + epsilon = 1 * epsilon := (one_mul _).symm + _ ≤ _ := mul_le_mul' (by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + norm_num) le_rfl + calc + _ ≤ rootMass * ((8 / 7) * epsilon) + nonRootMass * epsilon := + add_le_add hroot hnonRoot + _ ≤ rootMass * ((8 / 7) * epsilon) + nonRootMass * ((8 / 7) * epsilon) := + add_le_add le_rfl (mul_le_mul' le_rfl hcoefficient) + _ = (rootMass + nonRootMass) * ((8 / 7) * epsilon) := (add_mul ..).symm + _ ≤ 1 * ((8 / 7) * epsilon) := + mul_le_mul' (rootSelection_nonRootSelection_mass_le_one common) le_rfl + _ = _ := one_mul _ + +set_option maxRecDepth 100000 in +theorem probEvent_sampledResidualOrdinal_pair_le_eight_sevenths + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hordinal : ordinal < q) (hq : q ≤ 2 ^ 125) : + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] + + Pr[fun output => WitnessFirstUsesNonLayerRootOrdinal ordinal + (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + (8 / 7 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let epsilon := (8 / 7 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot + simp only [probEvent_bind_eq_tsum, ← ENNReal.tsum_add, ← mul_add] + calc + _ ≤ ∑' table, Pr[= table | sampleOtsHashTable] * epsilon := by + apply ENNReal.tsum_le_tsum + intro table + exact mul_le_mul' le_rfl + (probEvent_granularResidualOrdinal_pair_le_eight_sevenths ordinal adversary parameter + table ftsSecret q hordinal hq) + _ = (∑' table, Pr[= table | sampleOtsHashTable]) * epsilon := ENNReal.tsum_mul_right + _ ≤ 1 * epsilon := mul_le_mul' tsum_probOutput_le_one le_rfl + _ = _ := one_mul _ + +set_option maxRecDepth 100000 in +theorem probEvent_jointResidual_le_eight_sevenths_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[JointSnapshotResidual | + sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q] ≤ + ((8 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + rw [probEvent_jointResidual_eq_snapshot] + apply (probEvent_or_le _ _ _).trans + calc + _ ≤ (∑ ordinal : Fin q, + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal.val | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q]) + + ∑ ordinal : Fin q, + Pr[fun output => WitnessFirstUsesNonLayerRootOrdinal ordinal.val + (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := + add_le_add + (probEvent_sampledCanonical_delayed_le_sum_ordinals adversary parameter ftsSecret q hbound) + (probEvent_sampledCanonical_nonRoot_le_sum_ordinals adversary parameter ftsSecret q hbound) + _ = ∑ ordinal : Fin q, + (Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal.val | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] + + Pr[fun output => WitnessFirstUsesNonLayerRootOrdinal ordinal.val + (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q]) := + Finset.sum_add_distrib.symm + _ ≤ ∑ _ordinal : Fin q, + (8 / 7 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply Finset.sum_le_sum + intro ordinal _ + exact probEvent_sampledResidualOrdinal_pair_le_eight_sevenths ordinal.val adversary + parameter ftsSecret q ordinal.isLt hq + _ = _ := by simp; ring + +set_option maxRecDepth 100000 in +theorem probEvent_jointBoundary_failed_le_thirty_sevenths_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[fun output => output.outcome.failed = true | + sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q] ≤ + ((30 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + have hfuel : 2 * q < Fintype.card Digest := by + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + norm_num [digestBits] at hq ⊢ + omega + apply (probEvent_sampledJointSnapshot_failed_le_diagnostic_add_residual adversary parameter + ftsSecret q hbound).trans + calc + _ ≤ ((22 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + ((8 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + add_le_add + (probEvent_sampledDiagnostic_bad_le_twenty_two_sevenths_mul adversary parameter + ftsSecret q hfuel hbound hq) + (probEvent_jointResidual_le_eight_sevenths_mul adversary parameter ftsSecret q hbound hq) + _ = _ := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul, ENNReal.toReal_div, ENNReal.toReal_natCast, + ENNReal.toReal_inv, ENNReal.toReal_ofNat] + ring + +set_option maxRecDepth 100000 in +theorem probEvent_sampledActualRetained_verifyProbe_le_thirty_sevenths_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + ((30 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + (probEvent_sampledActualRetained_verifyProbe_le_jointBoundaryFailed adversary parameter + ftsSecret q).trans + (probEvent_jointBoundary_failed_le_thirty_sevenths_mul adversary parameter + ftsSecret q hbound hq) + +end Range125 +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResidualCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResidualCharge.lean new file mode 100644 index 00000000..e55ae80e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResidualCharge.lean @@ -0,0 +1,117 @@ +import SphincsSecurity.Proof.OtsProbeDiagnosticCharge +import SphincsSecurity.Proof.OtsProbeResidual125 +import SphincsSecurity.Proof.OtsProbeRootBudget + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +noncomputable def residualSelectionCharge (common : ProbComp (Option PermissivePrivateOrdinalSelection)) : ℝ≥0∞ := + Pr[fun selection => (permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection).isSome = true | common] * + (4 / 3) + Pr[PermissiveSelectionNonRoot | common] + +theorem residualSelectionCharge_le_four_thirds (common : ProbComp (Option PermissivePrivateOrdinalSelection)) : + residualSelectionCharge common ≤ 4 / 3 := by + have hfactor : (1 : ℝ≥0∞) ≤ 4 / 3 := by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + norm_num + unfold residualSelectionCharge + calc + _ ≤ Pr[fun selection => (permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection).isSome = true | common] * + (4 / 3) + Pr[PermissiveSelectionNonRoot | common] * (4 / 3) := + add_le_add le_rfl (by simpa only [mul_one] using mul_le_mul' le_rfl hfactor) + _ ≤ _ := by + rw [← add_mul] + exact mul_le_of_le_one_left (by positivity) (rootSelection_nonRootSelection_mass_le_one common) + +theorem probEvent_canonical_delayedRoot_le_selectedCharge126 + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) (hordinal : ordinal < q) (hq : q ≤ 2 ^ 126) : + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q] ≤ + Pr[fun selection => (permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection).isSome = true | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret q table] * + ((4 / 3) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) := by + apply Range125.probEvent_le_common_selected_mass + (leftPosition := delayedSnapshotLayerRootPosition? ordinal) + (common := delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret q table) + (commonPosition := permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?) + · intro output hdelayed + obtain ⟨target, htarget⟩ := delayedSnapshotLayerRootPosition?_eq_some_of_delayed hdelayed + rw [htarget] + simp + · intro target + exact probEvent_canonical_delayedRootFiber_le_four_thirds_common ordinal adversary parameter table ftsSecret q target hordinal hq + +theorem probEvent_residualOrdinal_pair_le_selectedCharge126 + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) (hordinal : ordinal < q) (hq : q ≤ 2 ^ 126) : + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q] + + Pr[fun output => WitnessFirstUsesNonLayerRootOrdinal ordinal (erasePrivateWitnessSnapshotOutput output) | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q] ≤ + residualSelectionCharge + (delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret q table) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply (add_le_add (probEvent_canonical_delayedRoot_le_selectedCharge126 ordinal adversary parameter table ftsSecret q hordinal hq) + (probEvent_granularNonRootOrdinal_le_common_mass ordinal adversary parameter table ftsSecret q)).trans_eq + unfold residualSelectionCharge + rw [add_mul, mul_assoc] + +noncomputable def sampledResidualSelectionCharge (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) : ℝ≥0∞ := + ∑ ordinal : Fin q, ∑' table, Pr[= table | sampleOtsHashTable] * + residualSelectionCharge + (delayedPermissiveDetailedSelectionExperimentAfterTable ordinal.val adversary parameter ftsSecret q table) + +theorem probEvent_sampledResidualOrdinal_pair_le_selectedCharge126 + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) (hordinal : ordinal < q) (hq : q ≤ 2 ^ 126) : + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] + + Pr[fun output => WitnessFirstUsesNonLayerRootOrdinal ordinal (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + (∑' table, Pr[= table | sampleOtsHashTable] * residualSelectionCharge + (delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret q table)) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot + simp only [probEvent_bind_eq_tsum, ← ENNReal.tsum_add, ← mul_add] + rw [← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro table + rw [mul_assoc] + exact mul_le_mul' le_rfl + (probEvent_residualOrdinal_pair_le_selectedCharge126 ordinal adversary parameter table ftsSecret q hordinal hq) + +theorem probEvent_jointResidual_le_selectionCharge126 + (adversary : Adversary) (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[JointSnapshotResidual | sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q] ≤ + sampledResidualSelectionCharge adversary parameter ftsSecret q * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [Range125.probEvent_jointResidual_eq_snapshot] + apply (probEvent_or_le _ _ _).trans + apply (add_le_add + (probEvent_sampledCanonical_delayed_le_sum_ordinals adversary parameter ftsSecret q hbound) + (probEvent_sampledCanonical_nonRoot_le_sum_ordinals adversary parameter ftsSecret q hbound)).trans + rw [← Finset.sum_add_distrib, sampledResidualSelectionCharge, Finset.sum_mul] + exact Finset.sum_le_sum fun ordinal _ => + probEvent_sampledResidualOrdinal_pair_le_selectedCharge126 ordinal.val adversary parameter ftsSecret q ordinal.isLt hq + +theorem sampledResidualSelectionCharge_le_four_thirds_mul + (adversary : Adversary) (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) : + sampledResidualSelectionCharge adversary parameter ftsSecret q ≤ (4 / 3 : ℝ≥0∞) * q := by + unfold sampledResidualSelectionCharge + calc + _ ≤ ∑ _ordinal : Fin q, (4 / 3 : ℝ≥0∞) := by + apply Finset.sum_le_sum + intro ordinal _ + apply (ENNReal.tsum_le_tsum fun table => mul_le_mul' le_rfl (residualSelectionCharge_le_four_thirds _)).trans + rw [ENNReal.tsum_mul_right] + exact mul_le_of_le_one_left (by positivity) tsum_probOutput_le_one + _ = _ := by simp [mul_comm] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveBoundary.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveBoundary.lean new file mode 100644 index 00000000..6e2737b1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveBoundary.lean @@ -0,0 +1,188 @@ +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveVerifier + +/-! +# Reachable publication boundaries for canonical adaptive one-time probes +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +structure CanonicalResolvedBoundary + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (cache : SplitHashCache) + (allowed : Coordinate → Prop) where + concreteCache : QueryCache HashSpec + invariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache + closed : VisibleResolvedComputationsCached parameter table context concreteCache + published : PublishedValues context.state + allowed : RevealedChainAllowed allowed context.state + +structure CanonicalVerifierTerminal + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (targetCache : QueryCache HashSpec) + (completion : Coordinate → HashOutput) (fallback : QueryImpl HashSpec Id) + (adversaryResult : ResolvedRunResult + ((Forgery × QueryLog SigningSpec) × SplitHashCache)) where + result : ResolvedRunResult (RetainedGameResult × SplitHashCache) + table_eq : adversaryResult.table = table + mem_support : some result ∈ support + (canonicalVerifierContinuation parameter root (some adversaryResult)) + resultCompletion : DeferredCompletion table result.context completion + fallbackAgrees : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback + probe : VerifyProbeWitness (tableAnswer parameter completion fallback) targetCache + (⟨parameter, result.value.1.1, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + result.value.1.2.1.2 result.value.1.2.1.1.message + result.value.1.2.1.1.signature + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxHeartbeats 10000000 in +set_option maxRecDepth 100000 in +theorem canonicalRootBoundary_of_mem + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (allowed : Coordinate → Prop) (fuel : Nat) + (rootResult : ResolvedRunResult (Digest × SplitHashCache)) + (completion : Coordinate → HashOutput) + (hroot : some rootResult ∈ support + (runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hcompletion : DeferredCompletion table rootResult.context completion) : + Nonempty + (CanonicalResolvedBoundary parameter table rootResult.context rootResult.value.2 + allowed) := by + obtain ⟨rootConcreteCache, hrootInvariant, hrootClosed, hrootPublished, + _hrootConcrete⟩ := + concreteSupport_of_mem_runResolved_maskedPublishedTreeRoot parameter table fuel + rootResult completion hroot hcompletion + have hemptyAllowed : RevealedChainAllowed allowed + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) := by + intro coordinate _hchain hrevealed + simp [LazyRevealProbe.State.empty] at hrevealed + have hrootAllowed : RevealedChainAllowed allowed rootResult.context.state := + resolvedPreservesChainPublication_maskedPublishedTreeRoot allowed + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + emptySplitHashCache fuel table rootResult completion + DeferredContext.valid_empty.valuesConsistent (startTableAgrees_empty table) + hemptyAllowed hroot hcompletion + exact ⟨⟨rootConcreteCache, hrootInvariant, hrootClosed, hrootPublished, hrootAllowed⟩⟩ + +set_option maxRecDepth 100000 in +theorem canonicalAdversaryBoundary_of_mem + (adversary : Adversary) (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (targetCache : QueryCache HashSpec) + (completion : Coordinate → HashOutput) (fallback : QueryImpl HashSpec Id) + (rootResult : ResolvedRunResult (Digest × SplitHashCache)) + (adversaryResult : ResolvedRunResult + ((Forgery × QueryLog SigningSpec) × SplitHashCache)) + (result : ResolvedRunResult (RetainedGameResult × SplitHashCache)) + (hrootBoundary : CanonicalResolvedBoundary parameter table rootResult.context + rootResult.value.2 + (CoveredChainCoordinate (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + adversaryResult.value.1.2)) + (hadversary : some adversaryResult ∈ support + (runSynchronizedResolved + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) + rootResult.context rootResult.remaining table rootResult.value.2)) + (htable : adversaryResult.table = table) + (hcompletion : DeferredCompletion table adversaryResult.context completion) + (hfinish : some result ∈ support + (canonicalVerifierContinuation parameter root (some adversaryResult))) + (hfinalCompletion : DeferredCompletion table result.context completion) + (hfinalFallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback) + (hlogRuns : ∀ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), entry ∈ result.value.1.2.1.2 → + entry.2 = some signature → + SuccessfulSignRun (tableAnswer parameter completion fallback) targetCache + (⟨parameter, result.value.1.1, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + entry.1 signature) : + ∃ _boundary : CanonicalResolvedBoundary parameter table adversaryResult.context + adversaryResult.value.2 + (CoveredChainCoordinate (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + adversaryResult.value.1.2), + CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache adversaryResult.value.2) fallback := by + obtain ⟨adversaryConcreteCache, hadversaryInvariant, hadversaryClosed, + hadversaryPublished, _hadversaryConcrete⟩ := + concreteSupport_of_mem_runSynchronizedResolved + (canonicalReachableResolvedImplCouples_chronologicalAdversaryImpl parameter root table + ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) + rootResult.context rootResult.remaining rootResult.value.2 hrootBoundary.concreteCache + adversaryResult completion hrootBoundary.invariant hrootBoundary.closed + hrootBoundary.published hadversary hcompletion + have hadversaryFallback := + hfinalFallback.of_mem_canonicalVerifierContinuation parameter root table adversaryResult + result adversaryConcreteCache completion fallback htable hfinish hadversaryInvariant + hadversaryClosed hadversaryPublished hfinalCompletion + have hterminalValue := canonicalVerifierContinuation_value_of_mem_support parameter root + adversaryResult result hfinish + have hlogRuns' := hlogRuns + rw [hterminalValue.1, hterminalValue.2] at hlogRuns' + have hadversaryAllowed := + revealedChainAllowed_runSynchronizedResolved_signingTraceComputation parameter root table + ftsSecret targetCache adversaryResult.value.1.2 completion fallback hlogRuns' + (adversary.main ⟨root, parameter⟩) rootResult.context rootResult.remaining + rootResult.value.2 hrootBoundary.concreteCache adversaryResult + hrootBoundary.invariant hrootBoundary.closed hrootBoundary.published + hrootBoundary.allowed (fun entry => id) hadversary hcompletion + hadversaryFallback + exact ⟨⟨adversaryConcreteCache, hadversaryInvariant, hadversaryClosed, + hadversaryPublished, hadversaryAllowed⟩, hadversaryFallback⟩ + +set_option maxRecDepth 100000 in +theorem CanonicalResolvedBoundary.contradicts_canonicalVerifierTerminal + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (targetCache : QueryCache HashSpec) + (completion : Coordinate → HashOutput) (fallback : QueryImpl HashSpec Id) + (adversaryResult : ResolvedRunResult + ((Forgery × QueryLog SigningSpec) × SplitHashCache)) + (boundary : CanonicalResolvedBoundary parameter table adversaryResult.context + adversaryResult.value.2 + (CoveredChainCoordinate (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + adversaryResult.value.1.2)) + (terminal : CanonicalVerifierTerminal parameter root table ftsSecret targetCache + completion fallback adversaryResult) : False := by + have hvalue := canonicalVerifierContinuation_value_of_mem_support parameter root + adversaryResult terminal.result terminal.mem_support + have hprobe := terminal.probe + rw [hvalue.1] at hprobe + apply not_verifyProbe_of_mem_canonicalVerifierContinuation parameter root table ftsSecret + targetCache completion fallback adversaryResult boundary.concreteCache terminal.result + terminal.table_eq terminal.mem_support boundary.invariant boundary.closed + boundary.published boundary.allowed terminal.resultCompletion terminal.fallbackAgrees + exact hprobe + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveBridge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveBridge.lean new file mode 100644 index 00000000..f59bc506 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveBridge.lean @@ -0,0 +1,683 @@ +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveObserver + +/-! +# Adaptive delayed-signer bridge + +The delayed signer is erased under an arbitrary terminal observer that treats doomed contexts as +failure, respects synchronized finalization views, and is neutral to an ensured private position. +The resulting clean interpreter canonicalizes materialized values only at outer-query boundaries. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp + +attribute [local irreducible] maskedSignLayer + +theorem evalDist_runDeferredChronologicalLayersAndPublish_observe_eq_selectionOnly + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + {observe : DeferredContext → Nat → + (Option Signature × SplitHashCache) → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (runDeferredChronologicalLayersAndPublish parameter table ftsSecret randomness + index leaves ftsPath context fuel cache >>= finishObserve observe) = + evalDist (runSelectionOnlyLayersAndPublish parameter table ftsSecret randomness index + leaves ftsPath context fuel cache >>= finishObserve observe) := by + calc + _ = evalDist (runDeferredLayersAndPublish parameter table ftsSecret randomness index leaves + ftsPath deferredLayerSchedule context fuel cache >>= finishObserve observe) := + evalDist_runDeferredChronologicalLayersAndPublish_observe_eq_deferred parameter table + ftsSecret randomness index leaves ftsPath context fuel cache observe + _ = _ := evalDist_runDeferredLayersAndPublish_observe_eq_selectionOnly parameter table + ftsSecret randomness index leaves ftsPath context fuel cache hvalid hcompletable + +set_option maxRecDepth 100000 in +theorem evalDist_runDeferredChronologicalSignAfterDigest_observe_eq_selectionOnly + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + {observe : DeferredContext → Nat → + (Option Signature × SplitHashCache) → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (runDeferredChronologicalSignAfterDigest parameter table ftsSecret randomness + index leaves context fuel cache >>= finishObserve observe) = + evalDist (runSelectionOnlySignAfterDigest parameter table ftsSecret randomness index + leaves context fuel cache >>= finishObserve observe) := by + unfold runDeferredChronologicalSignAfterDigest runSelectionOnlySignAfterDigest + simp only [bind_assoc] + apply evalDist_bind_congr + intro ftsOption hfts + cases ftsOption with + | none => simp [finishObserve] + | some ftsResult => + have hftsInvariants := + valid_completable_of_mem_runResolvedFromTable_of_finalizationMaterializedCouples table + (simulateQ ordinaryHashImpl (ftsOpen parameter index leaves (ftsSecret index))) + (finalizationMaterializedCouples_simulateQ ordinaryHashImpl + (finalizationMaterializedCouples_ordinaryHashImpl table) + (ftsOpen parameter index leaves (ftsSecret index))) + context fuel cache ftsResult hvalid hcompletable hfts + exact evalDist_runDeferredChronologicalLayersAndPublish_observe_eq_selectionOnly parameter + table ftsSecret randomness index leaves ftsResult.value.1 ftsResult.context + ftsResult.remaining ftsResult.value.2 hftsInvariants.1 hftsInvariants.2 + +set_option maxRecDepth 100000 in +theorem evalDist_runDeferredChronologicalSign_observe_eq_maskedSign + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + {observe : DeferredContext → Nat → + (Option Signature × SplitHashCache) → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (runDeferredChronologicalSign parameter root table ftsSecret message context fuel + cache >>= finishObserve observe) = + evalDist (runResolvedObserve observe context fuel table + ((maskedSign parameter root ftsSecret message).run cache)) := by + calc + _ = evalDist (runSelectionOnlySign parameter root table ftsSecret message context fuel cache >>= + finishObserve observe) := by + unfold runDeferredChronologicalSign runSelectionOnlySign + simp only [bind_assoc] + apply evalDist_bind_congr + intro selectedOption hselected + cases selectedOption with + | none => simp [finishObserve] + | some selected => + cases hvalue : selected.value.1 with + | none => simp [hvalue, finishObserve] + | some digestResult => + rcases digestResult with ⟨randomness, selectedIndex, leaves⟩ + simp only [hvalue] + let secretKey : SecretKey := + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ + have hselectedInvariants := + valid_completable_of_mem_runResolvedFromTable_of_finalizationMaterializedCouples + table + (simulateQ ordinaryRomImpl + (signDigestLoop digestAttemptLimit secretKey message)) + (finalizationMaterializedCouples_simulateQ ordinaryRomImpl + (finalizationMaterializedCouples_ordinaryRomImpl table) + (signDigestLoop digestAttemptLimit secretKey message)) + context fuel cache selected hvalid hcompletable (by + simpa only [secretKey] using hselected) + exact + evalDist_runDeferredChronologicalSignAfterDigest_observe_eq_selectionOnly + parameter table ftsSecret randomness selectedIndex leaves selected.context + selected.remaining selected.value.2 hselectedInvariants.1 + hselectedInvariants.2 + _ = evalDist (runResolvedFromTable context fuel table + ((maskedSign parameter root ftsSecret message).run cache) >>= finishObserve observe) := by + rw [evalDist_bind, evalDist_bind, + evalDist_runSelectionOnlySign_eq_resolved parameter root table ftsSecret message context + fuel cache hvalid.valuesConsistent + (startTableAgrees_of_deferredCompletable hcompletable)] + _ = _ := rfl + +noncomputable def canonicalizeObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : α) : ProbComp Bool := by + classical + exact if PublishedValues context.state then + observe (canonicalizeMaterializedValues table context) fuel value + else + pure true + +instance canonicalizeObserve_observerDooms + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → ProbComp Bool) + [ObserverDooms table observe] : + ObserverDooms table (canonicalizeObserve table observe) where + eq_true context fuel value hconsistent hstarts hdoomed := by + unfold canonicalizeObserve + split + next _ => + exact ObserverDooms.eq_true + (table := table) (observe := observe) + (canonicalizeMaterializedValues table context) fuel value + (canonicalizeMaterializedValues_valuesConsistent table context hconsistent) + (canonicalizeMaterializedValues_startTableAgrees table context) + (doomedResolvedContext_canonicalizeMaterializedValues + (table := table) ⟨hconsistent, hstarts, hdoomed⟩).2.2 + next _ => rfl + +instance canonicalizeObserve_observerSynchronized + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → ProbComp Bool) + [ObserverSynchronized table observe] : + ObserverSynchronized table (canonicalizeObserve table observe) where + eq_of_synchronized left right fuel value hcontext hvalues hrevealed := by + have hpublishedIff : PublishedValues left.state ↔ PublishedValues right.state := by + simp only [PublishedValues] + constructor + · intro hpublished coordinate hrightRevealed + rw [← hvalues] + exact hpublished coordinate (by simpa [hrevealed] using hrightRevealed) + · intro hpublished coordinate hleftRevealed + rw [hvalues] + exact hpublished coordinate (by simpa [hrevealed] using hleftRevealed) + unfold canonicalizeObserve + split + next hleftPublished => + have hrightPublished := hpublishedIff.mp hleftPublished + simp only [hrightPublished, ↓reduceIte] + have hcanonical := canonicalizedFinalizationContextEq hcontext hrevealed + exact ObserverSynchronized.eq_of_synchronized + (table := table) (observe := observe) + (canonicalizeMaterializedValues table left) + (canonicalizeMaterializedValues table right) fuel value + hcanonical.1 hcanonical.2 hrevealed + next hleftNotPublished => + have hrightNotPublished : ¬PublishedValues right.state := by + rwa [← hpublishedIff] + simp [hrightNotPublished] + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_canonicalizeObserve + (position : Position) (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (hneutral : ObserverPositionNeutralAt table position observe) + (context : DeferredContext) (fuel : Nat) (value : α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : Coordinate.position position ∈ context.state.ensured) : + evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + canonicalizeObserve table observe resolved.toDeferredContext fuel value) = + evalDist (canonicalizeObserve table observe context fuel value) := by + by_cases hpublished : PublishedValues context.state + · let finish : Option DeferredResolution → ProbComp Bool + | none => pure true + | some resolved => observe resolved.toDeferredContext fuel value + have hclean : ∀ coordinate output, + resolvedCompletionValue table context coordinate = some output → + ¬context.state.hitAt coordinate output := by + obtain ⟨completion, hcompletion⟩ := hcompletable + intro coordinate output hvalue hhit + have houtput := hcompletion.eq_resolvedCompletionValue coordinate output hvalue + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + exact hcompletion.2.2.1 coordinate (truncateHash output) hhit (by rw [houtput]) + have hcanonicalValid : + (canonicalizeMaterializedValues table context).Valid := + canonicalizeMaterializedValues_valid table context hvalid hclean + have hcanonicalCompletable : + DeferredCompletable table (canonicalizeMaterializedValues table context) := by + obtain ⟨completion, hcompletion⟩ := hcompletable + exact ⟨completion, hcompletion.to_canonicalizedMaterializedValues⟩ + have hcanonicalEnsured : Coordinate.position position ∈ + (canonicalizeMaterializedValues table context).state.ensured := hensured + calc + _ = evalDist (((Option.map (canonicalizeDeferredResolution table)) <$> + resolveDeferredPositionValue position context) >>= finish) := by + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hresolvedPublished : PublishedValues resolved.state := + (publishedValues_resolveDeferredPositionValue_iff position context resolved + hresolved).2 hpublished + simp [canonicalizeObserve, hresolvedPublished, finish, + canonicalizeDeferredResolution] + _ = evalDist (resolveDeferredPositionValue position + (canonicalizeMaterializedValues table context) >>= finish) := + evalDist_bind_eq_of_evalDist_eq + (evalDist_resolveDeferredPositionValue_canonicalize table position context + hvalid.valuesConsistent hpublished) + finish + _ = evalDist (observe (canonicalizeMaterializedValues table context) fuel value) := by + exact hneutral (canonicalizeMaterializedValues table context) fuel value + hcanonicalValid hcanonicalCompletable hcanonicalEnsured + _ = _ := by simp [canonicalizeObserve, hpublished] + · calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun _ => + pure true) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hresolvedNotPublished : ¬PublishedValues resolved.state := by + intro hresolvedPublished + exact hpublished + ((publishedValues_resolveDeferredPositionValue_iff position context resolved + hresolved).1 hresolvedPublished) + simp [canonicalizeObserve, hresolvedNotPublished] + _ = evalDist (pure true : ProbComp Bool) := + OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolveDeferredPositionValue position context) + (by simp [resolveDeferredPositionValue, LazyRevealProbe.sampleHashOutput]) + (pure true) + _ = _ := by simp [canonicalizeObserve, hpublished] + +instance canonicalizeObserve_observerPositionNeutral + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → ProbComp Bool) + [ObserverPositionNeutral table observe] : + ObserverPositionNeutral table (canonicalizeObserve table observe) where + eq_resolve position context fuel value hvalid hcompletable hensured := + evalDist_resolveDeferredPositionValue_then_canonicalizeObserve position table observe + (ObserverPositionNeutral.at table position observe) context fuel value hvalid hcompletable + hensured + +theorem canonicalizeObserve_observerPositionNeutralAt + (table : OtsSecretIndex → HashOutput) (position : Position) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (hneutral : ObserverPositionNeutralAt table position observe) : + ObserverPositionNeutralAt table position (canonicalizeObserve table observe) := by + intro context fuel value hvalid hcompletable hensured + exact evalDist_resolveDeferredPositionValue_then_canonicalizeObserve position table observe + hneutral context fuel value hvalid hcompletable hensured + +noncomputable def boundaryObserve + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : ProbComp Bool := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp spec α => + (DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) → + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → ProbComp Bool) + (fun value observe context fuel _table cache => observe context fuel (value, cache)) + (fun query _next recursivelyRun observe context fuel table cache => + runResolvedFromTable context fuel table ((impl query).run cache) >>= + finishObserve (canonicalizeObserve table + (fun nextContext remaining value => + recursivelyRun value.1 observe nextContext remaining table value.2))) + computation observe context fuel table cache + +set_option maxRecDepth 100000 in +theorem boundaryObserve_dooms + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + [ObserverDooms table observe] + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) : + evalDist (boundaryObserve impl computation observe context fuel table cache) = + evalDist (pure true : ProbComp Bool) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + rw [boundaryObserve, OracleComp.construct_pure] + exact ObserverDooms.eq_true context fuel (value, cache) hconsistent hstarts hdoomed + | query_bind query next ih => + rw [boundaryObserve, OracleComp.construct_query_bind] + let nextObserve : DeferredContext → Nat → + ((spec.Range query) × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + boundaryObserve impl (next value.1) observe nextContext remaining table value.2 + letI : ObserverDooms table nextObserve := ⟨by + intro nextContext remaining value hnextConsistent hnextStarts hnextDoomed + exact ih value.1 nextContext remaining value.2 hnextConsistent hnextStarts + hnextDoomed⟩ + exact evalDist_runResolvedObserve_eq_true_of_not_completable_auto + (observe := canonicalizeObserve table nextObserve) + context fuel table ((impl query).run cache) hconsistent hstarts hdoomed + +set_option maxRecDepth 100000 in +theorem boundaryObserve_synchronized + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + [ObserverDooms table observe] [ObserverSynchronized table observe] + (left right : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) + (hrevealed : left.state.revealed = right.state.revealed) : + evalDist (boundaryObserve impl computation observe left fuel table cache) = + evalDist (boundaryObserve impl computation observe right fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing left right fuel cache with + | pure value => + rw [boundaryObserve, OracleComp.construct_pure, + boundaryObserve, OracleComp.construct_pure] + exact ObserverSynchronized.eq_of_synchronized left right fuel (value, cache) + hcontext hvalues hrevealed + | query_bind query next ih => + rw [boundaryObserve, OracleComp.construct_query_bind, + boundaryObserve, OracleComp.construct_query_bind] + let nextObserve : DeferredContext → Nat → + ((spec.Range query) × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + boundaryObserve impl (next value.1) observe nextContext remaining table value.2 + letI : ObserverDooms table nextObserve := ⟨by + intro nextContext remaining value hnextConsistent hnextStarts hnextDoomed + exact boundaryObserve_dooms impl (next value.1) observe nextContext remaining + value.2 hnextConsistent hnextStarts hnextDoomed⟩ + letI : ObserverSynchronized table nextObserve := ⟨by + intro nextLeft nextRight remaining value hnextContext hnextValues hnextRevealed + exact ih value.1 nextLeft nextRight remaining value.2 hnextContext hnextValues + hnextRevealed⟩ + letI : ObserverDooms table (canonicalizeObserve table nextObserve) := inferInstance + letI : ObserverSynchronized table + (canonicalizeObserve table nextObserve) := inferInstance + exact evalDist_runResolvedObserve_eq_of_finalizationSynchronized + (observe := canonicalizeObserve table nextObserve) + ((impl query).run cache) left right fuel table hcontext hvalues hrevealed + +set_option maxRecDepth 100000 in +theorem boundaryObserve_positionNeutral + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + [ObserverDooms table observe] [ObserverPositionNeutral table observe] + (position : Position) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) (hvalid : context.Valid) + (hcompletable : DeferredCompletable table context) + (hensured : Coordinate.position position ∈ context.state.ensured) : + evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + boundaryObserve impl computation observe resolved.toDeferredContext fuel table + cache) = + evalDist (boundaryObserve impl computation observe context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing position context fuel cache with + | pure value => + rw [boundaryObserve, OracleComp.construct_pure] + exact ObserverPositionNeutral.eq_resolve + (table := table) (observe := observe) position context fuel (value, cache) + hvalid hcompletable hensured + | query_bind query next ih => + rw [boundaryObserve, OracleComp.construct_query_bind] + let nextObserve : DeferredContext → Nat → + ((spec.Range query) × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + boundaryObserve impl (next value.1) observe nextContext remaining table value.2 + letI : ObserverDooms table nextObserve := ⟨by + intro nextContext remaining value hnextConsistent hnextStarts hnextDoomed + exact boundaryObserve_dooms impl (next value.1) observe nextContext remaining + value.2 hnextConsistent hnextStarts hnextDoomed⟩ + letI : ObserverPositionNeutral table nextObserve := ⟨by + intro nextPosition nextContext remaining value hnextValid hnextCompletable hnextEnsured + exact ih value.1 nextPosition nextContext remaining value.2 hnextValid + hnextCompletable hnextEnsured⟩ + letI : ObserverDooms table (canonicalizeObserve table nextObserve) := inferInstance + letI : ObserverPositionNeutral table + (canonicalizeObserve table nextObserve) := inferInstance + exact evalDist_resolveDeferredPositionValue_then_runResolvedObserve_auto position + (observe := canonicalizeObserve table nextObserve) + ((impl query).run cache) context fuel table hvalid hcompletable hensured + +set_option maxRecDepth 100000 in +theorem evalDist_canonicalDeferredAdversaryImpl_observe + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) + (observe : DeferredContext → Nat → + ((OracleWorld + SigningSpec).Range query × SplitHashCache) → ProbComp Bool) + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hpublished : PublishedValues context.state) : + evalDist + (canonicalDeferredAdversaryImpl parameter root table ftsSecret query context fuel table + cache >>= finishObserve observe) = + evalDist (runResolvedObserve (canonicalizeObserve table observe) context fuel table + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run cache)) := by + letI : ObserverDooms table (canonicalizeObserve table observe) := inferInstance + letI : ObserverSynchronized table (canonicalizeObserve table observe) := inferInstance + letI : ObserverPositionNeutral table + (canonicalizeObserve table observe) := inferInstance + cases query with + | inl oracleQuery => + rw [canonicalDeferredAdversaryImpl] + simp only [bind_assoc, pure_bind] + unfold runResolvedObserve + apply evalDist_bind_congr + intro rawOption hraw + cases rawOption with + | none => simp [canonicalizeResolvedRun, finishObserve] + | some rawResult => + have hrawPublished := + resolvedPreservesPublishedValuesImpl_probingRomImpl parameter oracleQuery context + cache fuel table rawResult hpublished hraw + simp [canonicalizeResolvedRun, finishObserve, canonicalizeObserve, + hrawPublished] + | inr message => + let hdooms : ObserverDooms table (canonicalizeObserve table observe) := + canonicalizeObserve_observerDooms table observe + let hsync : ObserverSynchronized table (canonicalizeObserve table observe) := + canonicalizeObserve_observerSynchronized table observe + let hposition : ObserverPositionNeutral table + (canonicalizeObserve table observe) := + canonicalizeObserve_observerPositionNeutral table observe + letI := hdooms + letI := hsync + letI := hposition + rw [canonicalDeferredAdversaryImpl] + simp only [bind_assoc, pure_bind] + calc + _ = evalDist (runDeferredChronologicalSign parameter root table ftsSecret message context + fuel cache >>= finishObserve (canonicalizeObserve table observe)) := by + apply evalDist_bind_congr + intro rawOption hraw + cases rawOption with + | none => simp [canonicalizeResolvedRun, finishObserve] + | some rawResult => + have hrawPublished := publishedValues_of_mem_runDeferredChronologicalSign + parameter root table ftsSecret message context fuel cache rawResult hpublished + hraw + simp [canonicalizeResolvedRun, finishObserve, canonicalizeObserve, + hrawPublished] + _ = _ := @evalDist_runDeferredChronologicalSign_observe_eq_maskedSign + parameter root table ftsSecret message context fuel cache + (canonicalizeObserve table observe) hdooms hsync hposition hvalid hcompletable + +theorem valid_of_resolvedCore_completable + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hcompletable : DeferredCompletable table context) : context.Valid := by + refine ⟨hconsistent, ?_⟩ + intro coordinate output hvalue hhit + obtain ⟨completion, hcompletion⟩ := hcompletable + have hresolved : resolvedCompletionValue table context coordinate = some output := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simpa [resolvedCompletionValue] using + (hstarts ⟨lay, tree, leafIdx, chainIdx⟩ output hvalue).symm + | position position => + simp [resolvedCompletionValue, DeferredContext.positionValue, hvalue] + have houtput := hcompletion.eq_resolvedCompletionValue coordinate output hresolved + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + exact hcompletion.2.2.1 coordinate (truncateHash output) hhit (by rw [houtput]) + +set_option maxRecDepth 100000 in +theorem canonicalDeferredAdversaryImpl_core + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult + ((OracleWorld + SigningSpec).Range query × SplitHashCache)) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hpublished : PublishedValues context.state) + (hresult : some result ∈ support + (canonicalDeferredAdversaryImpl parameter root table ftsSecret query context fuel table + cache)) : + result.table = table ∧ result.context.ValuesConsistent ∧ + StartTableAgrees result.context.state table ∧ PublishedValues result.context.state := by + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + cases query with + | inl oracleQuery => + rw [canonicalDeferredAdversaryImpl, mem_support_bind_iff] at hresult + obtain ⟨rawOption, hraw, hcanonical⟩ := hresult + cases rawOption with + | none => + have hfalse : some result = none := by + simpa only [canonicalizeResolvedRun, support_pure, Set.mem_singleton_iff] using + hcanonical + contradiction + | some rawResult => + simp only [canonicalizeResolvedRun, mem_support_pure_iff] at hcanonical + have hresultEq : result = + { rawResult with + context := canonicalizeMaterializedValues table rawResult.context } := + Option.some.inj hcanonical + subst result + have hcore := resolvedCore_of_mem_runResolvedFromTable + ((probingRomImpl parameter oracleQuery).run cache) context fuel table rawResult + hvalid.valuesConsistent hstarts hraw + have hrawPublished := + resolvedPreservesPublishedValuesImpl_probingRomImpl parameter oracleQuery context + cache fuel table rawResult hpublished hraw + exact ⟨hcore.1, + canonicalizeMaterializedValues_valuesConsistent table rawResult.context hcore.2.1, + canonicalizeMaterializedValues_startTableAgrees table rawResult.context, + hrawPublished.to_canonicalizedMaterializedValues⟩ + | inr message => + rw [canonicalDeferredAdversaryImpl, mem_support_bind_iff] at hresult + obtain ⟨rawOption, hraw, hcanonical⟩ := hresult + cases rawOption with + | none => + have hfalse : some result = none := by + simpa only [canonicalizeResolvedRun, support_pure, Set.mem_singleton_iff] using + hcanonical + contradiction + | some rawResult => + simp only [canonicalizeResolvedRun, mem_support_pure_iff] at hcanonical + have hresultEq : result = + { rawResult with + context := canonicalizeMaterializedValues table rawResult.context } := + Option.some.inj hcanonical + subst result + have hrawValid := valid_of_mem_runDeferredChronologicalSign parameter root table + ftsSecret message context fuel cache rawResult hvalid hcompletable hraw + have hrawPublished := publishedValues_of_mem_runDeferredChronologicalSign parameter root + table ftsSecret message context fuel cache rawResult hpublished hraw + have hview := finalizationViewEq_of_deferredCompletion_iff hvalid hvalid hstarts hstarts + rfl hcompletable (fun _ => Iff.rfl) + have hrelation := + relTriple_runResolvedFromTable_maskedPublishedChronologicalSign_finalization parameter + root table ftsSecret message context context fuel cache cache + ⟨hview, hvalid, hvalid, hcompletable⟩ rfl rfl + obtain ⟨leftOption, _hleft, hrelated⟩ := + exists_right_of_relTriple_of_mem_support + (OracleComp.ProgramLogic.Relational.relTriple_symm hrelation) hraw + cases leftOption with + | none => simp [FinalizationMaterializedRunEq] at hrelated + | some leftResult => + simp only [FinalizationMaterializedRunEq] at hrelated + rcases hrelated with + ⟨_houtput, _hcontext, _hremaining, _hleftTable, hrawTable, _hcache, + _hrevealed⟩ + exact ⟨hrawTable, + canonicalizeMaterializedValues_valuesConsistent table rawResult.context + hrawValid.valuesConsistent, + canonicalizeMaterializedValues_startTableAgrees table rawResult.context, + hrawPublished.to_canonicalizedMaterializedValues⟩ + +set_option maxRecDepth 100000 in +theorem evalDist_canonicalDeferred_adaptive_eq_boundaryObserve + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hpublished : PublishedValues context.state) : + evalDist + (runSynchronizedResolved + (canonicalDeferredAdversaryImpl parameter root table ftsSecret) + computation context fuel table cache >>= finishObserve observe) = + evalDist + (boundaryObserve (maskedExpandedAdversaryImpl parameter root ftsSecret) + computation observe context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + rw [runSynchronizedResolved_pure _ value context fuel table cache hcompletable, + boundaryObserve, OracleComp.construct_pure] + simp [finishObserve] + | query_bind query next ih => + rw [runSynchronizedResolved, OracleComp.construct_query_bind, + boundaryObserve, OracleComp.construct_query_bind] + simp only [dif_pos hcompletable, bind_assoc] + let nextObserve : DeferredContext → Nat → + ((OracleWorld + SigningSpec).Range query × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + boundaryObserve (maskedExpandedAdversaryImpl parameter root ftsSecret) + (next value.1) observe nextContext remaining table value.2 + letI : ObserverDooms table nextObserve := ⟨by + intro nextContext remaining value hnextConsistent hnextStarts hnextDoomed + exact boundaryObserve_dooms + (maskedExpandedAdversaryImpl parameter root ftsSecret) (next value.1) observe + nextContext remaining value.2 hnextConsistent hnextStarts hnextDoomed⟩ + letI : ObserverSynchronized table nextObserve := ⟨by + intro nextLeft nextRight remaining value hnextContext hnextValues hnextRevealed + exact boundaryObserve_synchronized + (maskedExpandedAdversaryImpl parameter root ftsSecret) (next value.1) observe + nextLeft nextRight remaining value.2 hnextContext hnextValues hnextRevealed⟩ + letI : ObserverPositionNeutral table nextObserve := ⟨by + intro position nextContext remaining value hnextValid hnextCompletable hnextEnsured + exact boundaryObserve_positionNeutral + (maskedExpandedAdversaryImpl parameter root ftsSecret) (next value.1) observe position + nextContext remaining value.2 hnextValid hnextCompletable hnextEnsured⟩ + calc + _ = evalDist + (canonicalDeferredAdversaryImpl parameter root table ftsSecret query context fuel + table cache >>= finishObserve nextObserve) := by + apply evalDist_bind_congr + intro stepOption hstep + cases stepOption with + | none => simp [finishObserve] + | some step => + have hcore := canonicalDeferredAdversaryImpl_core parameter root table + ftsSecret query context fuel cache step hvalid hcompletable hpublished hstep + simp only [finishObserve] + rw [hcore.1] + change evalDist + (runSynchronizedResolved + (canonicalDeferredAdversaryImpl parameter root table ftsSecret) + (next step.value.1) step.context step.remaining table + step.value.2 >>= finishObserve observe) = + evalDist + (boundaryObserve + (maskedExpandedAdversaryImpl parameter root ftsSecret) + (next step.value.1) observe step.context step.remaining table + step.value.2) + by_cases hnextCompletable : DeferredCompletable table step.context + · have hnextValid := valid_of_resolvedCore_completable table step.context + hcore.2.1 hcore.2.2.1 hnextCompletable + exact ih step.value.1 step.context step.remaining step.value.2 hnextValid + hnextCompletable hcore.2.2.2 + · rw [runSynchronizedResolved_of_not_completable] + · exact (boundaryObserve_dooms + (maskedExpandedAdversaryImpl parameter root ftsSecret) + (next step.value.1) observe step.context step.remaining step.value.2 + hcore.2.1 hcore.2.2.1 hnextCompletable).symm + · exact hnextCompletable + _ = _ := evalDist_canonicalDeferredAdversaryImpl_observe parameter root table ftsSecret + query nextObserve context fuel cache hvalid hcompletable hpublished + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveClean.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveClean.lean new file mode 100644 index 00000000..dbb62cc4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveClean.lean @@ -0,0 +1,943 @@ +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveProbability +import SphincsSecurity.Proof.OtsProbeResolvedCleanTerminal +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryDirect +import SphincsSecurity.Proof.TerminalResidual +import SphincsSecurity.Proof.FtsProbeSampling + +/-! +# Clean terminal lift for adaptive one-time probes + +The canonical delayed failure is transported to the uniformly completed clean interpreter. The +clean endpoint itself is already the generic `q * 2^-128` lazy-probe bound. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedTreeRoot +attribute [local semireducible] sampleOtsSecrets + +noncomputable def constantDigestAnswer (digest : Digest) : QueryImpl HashSpec Id := + fun _ => hashOutputOfDigest digest + +@[simp] theorem eval_tweakableHash_constantDigestAnswer + (digest : Digest) (parameter : PublicParameter) (domain : HashDomain) + (payload : HashInput) : + evalWithAnswerFn (constantDigestAnswer digest) + (tweakableHash parameter domain payload) = digest := by + rw [Concrete.eval_tweakableHash] + exact truncateHash_hashOutputOfDigest digest + +theorem eval_treeNode_constantDigestAnswer + (digest : Digest) (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (secret : LeafIndex → ChainIndex → Digest) : + ∀ level nodeIdx, + evalWithAnswerFn (constantDigestAnswer digest) + (treeNode parameter lay tree secret level nodeIdx) = digest := by + intro level + induction level with + | zero => + intro nodeIdx + rw [treeNode_zero_eq] + simp only [evalWithAnswerFn_bind] + exact eval_tweakableHash_constantDigestAnswer digest parameter _ _ + | succ level ih => + intro nodeIdx + rw [treeNode_succ_eq] + simp [evalWithAnswerFn_bind, ih] + +theorem mem_support_treeRoot_all + (digest : Digest) (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (secret : LeafIndex → ChainIndex → Digest) : + digest ∈ support (treeRoot parameter lay tree secret : OracleComp HashSpec Digest) := by + have hsim := (OracleComp.exists_agreesWithFn_evalWithAnswerFn_eq_iff_mem_support + (treeRoot parameter lay tree secret) ∅ digest).mp ⟨constantDigestAnswer digest, + (by simp [QueryCache.AgreesWithFn]), by + simp only [treeRoot] + exact eval_treeNode_constantDigestAnswer digest parameter lay tree secret + (layerHeight lay) 0⟩ + obtain ⟨cache, hcache⟩ := hsim + apply OracleComp.support_simulateQ_run'_subset + (randomOracle : QueryImpl HashSpec _) (treeRoot parameter lay tree secret) ∅ + rw [StateT.run'_eq, support_map] + exact ⟨(digest, cache), hcache, rfl⟩ + +theorem isQueryBoundP_gameRest_all_roots + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (root : Digest) : + (gameRest scheme adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩).IsQueryBoundP + (· matches Sum.inr _) q := by + have hgame := Concrete.isQueryBoundP_gameAfterSecrets adversary q hq hparameter hots hfts + rw [Concrete.gameAfterSecrets] at hgame + have hroot : root ∈ support + (OracleComp.liftComp + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : + OracleComp HashSpec Digest) + OracleWorld) := by + rw [OracleComp.support_liftComp] + exact mem_support_treeRoot_all root parameter topLayer rootTree + (otsSecret topLayer rootTree) + exact isQueryBoundP_of_bind hgame root (by + simpa only [OracleComp.liftComp_eq_liftM] using hroot) + +theorem mem_support_sampleOtsSecrets_all + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) : + otsSecret ∈ support sampleOtsSecrets := by + change otsSecret ∈ support + (@SampleableType.selectElem + (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + otsSecretsSampleableType) + exact otsSecretsSampleableType.mem_support_selectElem otsSecret + +theorem isQueryBoundP_expandedRetained_all_tables_roots + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (root : Digest) : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (· matches Sum.inr _) q := by + let secretKey : SecretKey := + ⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ + have hrest := isQueryBoundP_gameRest_all_roots adversary q hq parameter hparameter + secretKey.otsSecret (mem_support_sampleOtsSecrets_all secretKey.otsSecret) + ftsSecret hfts root + have hbound := + Concrete.FtsProbeSimulation.simulateQ_expanded_retainedGameRestComputation_isQueryBoundP + adversary secretKey q hrest + convert hbound using 1 <;> rfl + +noncomputable def rejectingHashOutput : HashOutput := + hashOutputCoordinatesEquiv.symm + ((default, ⟨1, by norm_num [ftsTreeHeight]⟩), 0) + +noncomputable def rejectingRomAnswer : QueryImpl OracleWorld Id + | .inl n => (0 : Fin (n + 1)) + | .inr _ => rejectingHashOutput + +theorem signAttemptResultOfOutput_rejecting : + signAttemptResultOfOutput rejectingHashOutput = none := by + by_contra h + have hne : signAttemptResultOfOutput rejectingHashOutput ≠ none := h + rw [show rejectingHashOutput = hashOutputCoordinatesEquiv.symm + ((default, ⟨1, by norm_num [ftsTreeHeight]⟩), 0) from rfl, + signAttemptResultOfOutput_coordinates_ne_none_iff] at hne + norm_num at hne + +@[simp] theorem eval_lift_hash_rejecting (input : HashInput) : + evalWithAnswerFn rejectingRomAnswer + (liftM (HashSpec.query input) : OracleComp OracleWorld HashOutput) = + rejectingHashOutput := by + rfl + +theorem eval_lift_hash_comp_rejecting (computation : OracleComp HashSpec α) : + evalWithAnswerFn rejectingRomAnswer + (OracleComp.liftComp computation OracleWorld) = + evalWithAnswerFn (fun _ : HashInput => rejectingHashOutput) computation := by + induction computation using OracleComp.inductionOn with + | pure value => rfl + | query_bind input next ih => + rw [OracleComp.liftComp_bind, evalWithAnswerFn_bind, evalWithAnswerFn_bind, + show evalWithAnswerFn rejectingRomAnswer + (OracleComp.liftComp (liftM (HashSpec.query input)) OracleWorld) = + rejectingHashOutput from rfl, + show + evalWithAnswerFn (fun _ : HashInput => rejectingHashOutput) + (liftM (HashSpec.query input)) = rejectingHashOutput from rfl] + exact ih rejectingHashOutput + +set_option maxRecDepth 100000 in +theorem eval_signAttempt_rejecting (secretKey : SecretKey) (message : Message) + (randomness : Randomness) : + evalWithAnswerFn rejectingRomAnswer + (liftM (signAttempt secretKey message randomness : OracleComp HashSpec _) : + OracleComp OracleWorld _) = none := by + change evalWithAnswerFn rejectingRomAnswer + (OracleComp.liftComp (signAttempt secretKey message randomness : OracleComp HashSpec _) + OracleWorld) = none + rw [eval_lift_hash_comp_rejecting] + simp only [signAttempt, messageDigest, oracleHash, evalWithAnswerFn_bind, + evalWithAnswerFn_query, evalWithAnswerFn_pure] + have hreject : ¬Admissible (truncateMessageDigest rejectingHashOutput) := by + intro hadmissible + have hne : signAttemptResultOfOutput rejectingHashOutput ≠ none := + (signAttemptResultOfOutput_ne_none_iff rejectingHashOutput).2 hadmissible + exact hne signAttemptResultOfOutput_rejecting + simp [hreject] + +theorem eval_signDigestLoop_rejecting (attempts : Nat) (secretKey : SecretKey) + (message : Message) : + evalWithAnswerFn rejectingRomAnswer (signDigestLoop attempts secretKey message) = none := by + induction attempts with + | zero => simp [signDigestLoop] + | succ attempts ih => + rw [signDigestLoop] + simp only [evalWithAnswerFn_bind, eval_signAttempt_rejecting, ih] + +theorem eval_sign_rejecting (secretKey : SecretKey) (message : Message) : + evalWithAnswerFn rejectingRomAnswer (scheme.sign secretKey message) = none := by + change evalWithAnswerFn rejectingRomAnswer (sign secretKey message) = none + rw [sign_eq_digestLoop_afterDigest] + simp [evalWithAnswerFn_bind, eval_signDigestLoop_rejecting] + +theorem mem_support_sign_none (secretKey : SecretKey) (message : Message) : + none ∈ support (scheme.sign secretKey message) := by + have hsim := (OracleComp.exists_agreesWithFn_evalWithAnswerFn_eq_iff_mem_support + (scheme.sign secretKey message) ∅ none).mp + ⟨rejectingRomAnswer, (by simp [QueryCache.AgreesWithFn]), + eval_sign_rejecting secretKey message⟩ + obtain ⟨cache, hcache⟩ := hsim + apply OracleComp.support_simulateQ_run'_subset + (randomOracle : QueryImpl OracleWorld _) (scheme.sign secretKey message) ∅ + rw [StateT.run'_eq, support_map] + exact ⟨(none, cache), hcache, rfl⟩ + +theorem mem_support_of_evalWithAnswerFn + (f : QueryImpl HashSpec Id) (computation : OracleComp HashSpec α) + (value : α) (heval : evalWithAnswerFn f computation = value) : + value ∈ support computation := by + have hsim := (OracleComp.exists_agreesWithFn_evalWithAnswerFn_eq_iff_mem_support + computation ∅ value).mp ⟨f, (by simp [QueryCache.AgreesWithFn]), heval⟩ + obtain ⟨cache, hcache⟩ := hsim + apply OracleComp.support_simulateQ_run'_subset + (randomOracle : QueryImpl HashSpec _) computation ∅ + rw [StateT.run'_eq, support_map] + exact ⟨(value, cache), hcache, rfl⟩ + +set_option maxRecDepth 100000 in +theorem SuccessfulSignRun.mem_support_sign + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {message : Message} {signature : Signature} + (hrun : SuccessfulSignRun f cache secretKey message signature) : + some signature ∈ support (scheme.sign secretKey message) := by + change some signature ∈ support (sign secretKey message) + obtain ⟨index, leaves, hdigest, hafter⟩ := hrun.eval_signAfterDigest + have hattempt : some (index, leaves) ∈ + support (signAttempt secretKey message signature.randomness : OracleComp HashSpec _) := + mem_support_of_evalWithAnswerFn f _ _ hdigest.2.1 + have hloop : some (signature.randomness, index, leaves) ∈ + support (signDigestLoop digestAttemptLimit secretKey message) := by + rw [show digestAttemptLimit = (digestAttemptLimit - 1) + 1 by + norm_num [digestAttemptLimit], signDigestLoop, mem_support_bind_iff] + refine ⟨signature.randomness, ?_, ?_⟩ + · change signature.randomness ∈ + support (OracleComp.liftComp sampleRandomness OracleWorld) + rw [OracleComp.mem_support_liftComp_iff] + exact hdigest.1 + · rw [mem_support_bind_iff] + refine ⟨some (index, leaves), ?_, by simp⟩ + change some (index, leaves) ∈ support + (OracleComp.liftComp + (signAttempt secretKey message signature.randomness : OracleComp HashSpec _) + OracleWorld) + rw [OracleComp.mem_support_liftComp_iff] + exact hattempt + have hafterSupport : some signature ∈ + support (signAfterDigest secretKey signature.randomness index leaves) := + mem_support_of_evalWithAnswerFn f _ _ hafter + rw [sign_eq_digestLoop_afterDigest, mem_support_bind_iff] + exact ⟨some (signature.randomness, index, leaves), hloop, by + change some signature ∈ support + (OracleComp.liftComp + (signAfterDigest secretKey signature.randomness index leaves) OracleWorld) + rw [OracleComp.mem_support_liftComp_iff] + exact hafterSupport⟩ + +theorem tableOtsSecret_retainedCompletionTable_of_startTableAgrees + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (table : OtsSecretIndex → HashOutput) + (hagrees : StartTableAgrees state table) : + tableOtsSecret (retainedCompletionTable parameter state cache + (baseStartsOfTable table)) = + tableOtsSecret (extendStartTable table) := by + rw [tableOtsSecret_retainedCompletionTable_eq_extendStartTable] + congr 2 + funext index + unfold completedStartTable + cases hvalue : state.values index.coordinate with + | none => simp + | some output => simp [hagrees index output hvalue] + +set_option maxRecDepth 10000 in +theorem maskedSign_done_output_mem_support + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (output : Option Signature) (hagrees : StartTableAgrees finalState table) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (output, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedSign parameter root ftsSecret message).run cache))) : + output ∈ support + (scheme.sign + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey) + message) := by + cases output with + | none => + exact mem_support_sign_none _ _ + | some signature => + let baseStarts := fun lay tree leafIdx chainIdx => + table (⟨lay, tree, leafIdx, chainIdx⟩ : OtsSecretIndex) + let completion := retainedCompletionTable parameter finalState finalCache baseStarts + let f := retainedCompletionAnswer parameter finalState finalCache baseStarts + have hrun := successfulSignRun_of_mem_runRaw_maskedSign f parameter root completion + ftsSecret message signature state finalState cache finalCache fuel remaining finalState + finalCache + (stableCacheAgreesWithFn_retainedCompletionAnswer parameter finalState finalCache + baseStarts) + (fun coordinate cached hvalue => + (completedRealizedTable_of_value (splitFallback finalCache) parameter finalState + baseStarts coordinate cached hvalue).symm) + (retainedCompletionAnswer_realizes parameter finalState finalCache baseStarts) + hresult (by intro coordinate hvalue; exact hvalue) + (by intro input output hstable hcached; exact hcached) + have hsupport := SuccessfulSignRun.mem_support_sign hrun + have hsecret : tableOtsSecret completion = + tableOtsSecret (extendStartTable table) := by + change tableOtsSecret (retainedCompletionTable parameter finalState finalCache + (baseStartsOfTable table)) = tableOtsSecret (extendStartTable table) + exact tableOtsSecret_retainedCompletionTable_of_startTableAgrees parameter + finalState finalCache table hagrees + rw [hsecret] at hsupport + exact hsupport + +theorem startTableAgrees_completedStartTable + (state : LazyRevealProbe.State Coordinate) (base : OtsSecretIndex → HashOutput) : + StartTableAgrees state (completedStartTable state base) := by + intro index output hvalue + simp [completedStartTable, hvalue] + +set_option maxRecDepth 100000 in +theorem stopped_false_not_mem_support_masked_adversary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) + (hbound : ∀ table : OtsSecretIndex → HashOutput, + StartTableAgrees state table → + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + computation).IsQueryBoundP (· matches Sum.inr _) fuel) : + LazyRevealProbe.RawResult.stopped false ∉ support + (LazyRevealProbe.runRaw state fuel + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + computation).run cache)) := by + induction computation using OracleComp.inductionOn generalizing state fuel cache with + | pure value => simp [simulateQ_pure, StateT.run_pure, LazyRevealProbe.runRaw] + | query_bind input next ih => + rw [simulateQ_query_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] + rintro ⟨stepResult, hstep, htail⟩ + cases stepResult with + | stopped hit => + cases hit with + | false => + apply LazyRevealProbe.stopped_false_not_mem_support_runRaw state fuel + ((maskedExpandedAdversaryImpl parameter root ftsSecret input).run cache) ?_ hstep + cases input with + | inl worldInput => + cases worldInput with + | inl n => + exact (maskedExpandedAdversaryImpl_step_isProbeBound parameter root + ftsSecret (.inl (.inl n)) cache).mono (by simp [IsOuterHash]) + | inr hashInput => + let table := completedStartTable state (fun _ => 0) + have hsource := hbound table + (startTableAgrees_completedStartTable state _) + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hsource + have hpositive : 0 < fuel := by simpa using hsource.1 + exact (maskedExpandedAdversaryImpl_step_isProbeBound parameter root + ftsSecret (.inl (.inr hashInput)) cache).mono (by + simp [IsOuterHash] + omega) + | inr message => + exact (maskedExpandedAdversaryImpl_step_isProbeBound parameter root + ftsSecret (.inr message) cache).mono (by simp [IsOuterHash]) + | true => simp at htail + | done finalState remaining result => + rcases result with ⟨output, finalCache⟩ + have hvaluesLE := LazyRevealProbe.valuesLE_of_mem_runRaw_done + ((maskedExpandedAdversaryImpl parameter root ftsSecret input).run cache) + state finalState fuel remaining (output, finalCache) hstep + have hinitial : ∀ table : OtsSecretIndex → HashOutput, + StartTableAgrees finalState table → StartTableAgrees state table := by + intro table hagrees index cached hcached + exact hagrees index cached (hvaluesLE index.coordinate cached hcached) + have hstepBound := maskedExpandedAdversaryImpl_step_isProbeBound parameter root + ftsSecret input cache + have hfuel := LazyRevealProbe.fuel_le_remaining_add_of_mem_support_runRaw_done + state finalState fuel remaining (if IsOuterHash input then 1 else 0) + ((maskedExpandedAdversaryImpl parameter root ftsSecret input).run cache) + (output, finalCache) hstepBound hstep + apply ih output finalState remaining finalCache + · intro table hagrees + have hsource := hbound table (hinitial table hagrees) + cases input with + | inl worldInput => + cases worldInput with + | inl n => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hsource + exact (hsource.2 output).mono (by simpa [IsOuterHash] using hfuel) + | inr hashInput => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hsource + have htailSource : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), + ftsSecret⟩ : SecretKey)) + (next output)).IsQueryBoundP (· matches Sum.inr _) (fuel - 1) := by + simpa using hsource.2 output + change fuel ≤ remaining + 1 at hfuel + exact htailSource.mono (by omega) + | inr message => + change Option Signature at output + change LazyRevealProbe.RawResult.done finalState remaining + (output, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((maskedSigningImpl parameter root ftsSecret message).run cache)) at hstep + rw [simulateQ_expandedAdversaryImpl_query_bind_inr] at hsource + have houtput : output ∈ support + (scheme.sign + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey) message) := by + exact maskedSign_done_output_mem_support parameter root table ftsSecret + message state finalState cache finalCache fuel remaining output hagrees + (by simpa only [SigningSpec, maskedExpandedAdversaryImpl, + maskedSigningImpl] using hstep) + exact (isQueryBoundP_of_bind hsource output houtput).mono (by + simpa [IsOuterHash] using hfuel) + · exact htail + +noncomputable def chronologicalCleanRetainedRest + (adversary : Adversary) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (cache : SplitHashCache) : + OracleComp (LazyRevealProbe.World Coordinate) + (RetainedRestResult × SplitHashCache) := + (do + let (forgery, log) ← + simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) + let verified ← simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature) + pure ((forgery, log), verified)).run cache + +noncomputable def chronologicalCleanRetainedRun + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + OracleComp (LazyRevealProbe.World Coordinate) + (RetainedGameResult × SplitHashCache) := do + let rootResult ← maskedPublishedTreeRoot.run emptySplitHashCache + let restResult ← chronologicalCleanRetainedRest adversary parameter rootResult.1 ftsSecret + rootResult.2 + pure ((rootResult.1, restResult.1), restResult.2) + +noncomputable def deferredCleanRetainedRest + (adversary : Adversary) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (cache : SplitHashCache) : + OracleComp (LazyRevealProbe.World Coordinate) + (RetainedRestResult × SplitHashCache) := + (do + let (forgery, log) ← + simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) + let verified ← simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature) + pure ((forgery, log), verified)).run cache + +noncomputable def deferredCleanRetainedRun + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + OracleComp (LazyRevealProbe.World Coordinate) + (RetainedGameResult × SplitHashCache) := do + let rootResult ← maskedPublishedTreeRoot.run emptySplitHashCache + let restResult ← deferredCleanRetainedRest adversary parameter rootResult.1 ftsSecret + rootResult.2 + pure ((rootResult.1, restResult.1), restResult.2) + +set_option maxRecDepth 100000 in +theorem deferredCleanRetainedRun_eq + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + deferredCleanRetainedRun adversary parameter ftsSecret = + (maskedResolvedRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache := by + unfold deferredCleanRetainedRun deferredCleanRetainedRest + maskedResolvedRetainedGameAfterFtsSecrets maskedRetainedPrefixAfterFtsSecrets + simp only [StateT.run_bind, StateT.run_pure, bind_assoc, pure_bind] + +set_option maxRecDepth 100000 in +theorem chronologicalCleanRetainedRun_eq + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + chronologicalCleanRetainedRun adversary parameter ftsSecret = + (maskedChronologicalRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache := by + unfold chronologicalCleanRetainedRun chronologicalCleanRetainedRest + maskedChronologicalRetainedGameAfterFtsSecrets + maskedChronologicalRetainedPrefixAfterFtsSecrets + simp only [StateT.run_bind, StateT.run_pure, bind_assoc, pure_bind] + +theorem maskedPublishedTreeRoot_probeFree : ProbeFree maskedPublishedTreeRoot := by + intro cache + rw [maskedPublishedTreeRoot_eq, StateT.run_bind] + apply OracleComp.isQueryBoundP_bind (n := 0) (m := 0) + (maskedTreeRoot_probeFree topLayer rootTree cache) + intro rootResult _hroot + rcases rootResult with ⟨root, nextCache⟩ + rw [StateT.run_bind] + exact OracleComp.isQueryBoundP_bind (n := 0) (m := 0) + (publishCoordinate_probeFree (.position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0)) + nextCache) + (fun _ _ => by simp) + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 1000000 in +set_option linter.constructorNameAsVariable false in +theorem stopped_false_not_mem_support_deferredCleanRetainedRun + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + LazyRevealProbe.RawResult.stopped false ∉ support + (LazyRevealProbe.runRaw LazyRevealProbe.State.empty q + (deferredCleanRetainedRun adversary parameter ftsSecret)) := by + unfold deferredCleanRetainedRun + apply LazyRevealProbe.stopped_false_not_mem_support_runRaw_bind_of_bound + · exact maskedPublishedTreeRoot_probeFree emptySplitHashCache + · apply LazyRevealProbe.stopped_false_not_mem_support_runRaw + exact (maskedPublishedTreeRoot_probeFree emptySplitHashCache).mono (Nat.zero_le q) + · intro rootState remaining rootResult _hroot hfuel + rcases rootResult with ⟨root, cache⟩ + apply LazyRevealProbe.stopped_false_not_mem_support_runRaw_bind + · unfold deferredCleanRetainedRest + rw [← simulateQ_maskedExpanded_retainedGameRestComputation] + apply stopped_false_not_mem_support_masked_adversary parameter root ftsSecret + (retainedGameRestComputation adversary ⟨root, parameter⟩) + rootState remaining cache + intro table _hagrees + exact (isQueryBoundP_expandedRetained_all_tables_roots adversary q hq parameter + hparameter table ftsSecret hfts root).mono (by omega) + · intro finalState finalRemaining restResult _hrest + simp [LazyRevealProbe.runRaw] + +theorem probEvent_sampledDeferredCleanFinish_none_le + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[= none | sampledRunThenFinalizeClean + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) q + (deferredCleanRetainedRun adversary parameter ftsSecret)] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + probEvent_sampledRunThenFinalizeClean_empty_none_le_of_not_stopped_false + (deferredCleanRetainedRun adversary parameter ftsSecret) q + (stopped_false_not_mem_support_deferredCleanRetainedRun adversary q hq parameter + hparameter ftsSecret hfts) + +set_option maxRecDepth 100000 in +theorem chronologicalCleanRetainedRun_isProbeBound + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash q) : + (chronologicalCleanRetainedRun adversary parameter ftsSecret).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) q := by + unfold chronologicalCleanRetainedRun + have htail : ∀ rootResult ∈ support (maskedPublishedTreeRoot.run emptySplitHashCache), + (do + let restResult ← chronologicalCleanRetainedRest adversary parameter rootResult.1 + ftsSecret rootResult.2 + pure ((rootResult.1, restResult.1), restResult.2)).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) q := by + intro rootResult _hroot + rcases rootResult with ⟨root, cache⟩ + let rest := chronologicalCleanRetainedRest adversary parameter root ftsSecret cache + change ((fun result : RetainedRestResult × SplitHashCache => + ((root, result.1), result.2)) <$> rest).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) q + rw [OracleComp.isQueryBoundP_map_iff] + unfold rest chronologicalCleanRetainedRest + exact maskedChronologicalRetainedGameRest_run_isProbeBound adversary parameter root ftsSecret q + (hbound root) cache + simpa only [Nat.zero_add] using OracleComp.isQueryBoundP_bind + (n := 0) (m := q) (maskedPublishedTreeRoot_probeFree emptySplitHashCache) htail + +theorem probEvent_sampledChronologicalCleanFinish_none_le + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash q) : + Pr[= none | sampledRunThenFinalizeClean + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) q + (chronologicalCleanRetainedRun adversary parameter ftsSecret)] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + probEvent_sampledRunThenFinalizeClean_empty_none_le + (chronologicalCleanRetainedRun adversary parameter ftsSecret) q + (chronologicalCleanRetainedRun_isProbeBound adversary parameter ftsSecret q hbound) + +noncomputable def sampledCanonicalDeferredFinishIsNone + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := do + let table ← sampleOtsHashTable + let result ← canonicalDeferredRetainedRunAfterFtsSecrets adversary parameter table + ftsSecret fuel + finishResolvedRunIsNone result + +noncomputable def sampledAllDirectBoundaryFinishIsNone + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := do + let table ← sampleOtsHashTable + allDirectBoundaryDeferredRetainedFinishIsNone adversary parameter table ftsSecret fuel + +theorem evalDist_sampledCanonicalDeferredFinishIsNone_eq_allDirect + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (sampledCanonicalDeferredFinishIsNone adversary parameter ftsSecret fuel) = + evalDist (sampledAllDirectBoundaryFinishIsNone adversary parameter ftsSecret fuel) := by + unfold sampledCanonicalDeferredFinishIsNone sampledAllDirectBoundaryFinishIsNone + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro table + exact evalDist_canonicalDeferredRetainedFinishIsNone_eq_allDirect adversary parameter table + ftsSecret fuel + +theorem probEvent_finishResolvedRun_none_eq_isNone + (run : ProbComp (Option (ResolvedRunResult α))) : + Pr[= none | run >>= finishResolvedRun] = + Pr[= true | run >>= finishResolvedRunIsNone] := by + have hrun : run >>= finishResolvedRunIsNone = + Option.isNone <$> (run >>= finishResolvedRun) := by + unfold finishResolvedRunIsNone + rw [map_bind] + rw [hrun, ← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput, + probEvent_map] + apply OracleComp.probEvent_congr' (fun result _ => by cases result <;> simp) rfl + +set_option linter.constructorNameAsVariable false in +theorem probEvent_sampledActualRetainedOtsHashTable_verifyProbe_le_canonicalDeferred + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + Pr[= true | + sampledCanonicalDeferredFinishIsNone adversary parameter ftsSecret fuel] := by + unfold sampledActualRetainedOtsHashTable sampledCanonicalDeferredFinishIsNone + sampleOtsHashTable + rw [← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_bind_of_forall_le + intro table _htable + calc + _ ≤ Pr[= none | + canonicalChronologicalRetainedRunAfterFtsSecrets adversary parameter table ftsSecret + fuel >>= finishResolvedRun] := by + simpa [probEvent_map, Function.comp_def] using + probEvent_winningRetainedVerifyProbe_le_canonicalFinishedResolvedRun_none adversary + parameter table ftsSecret fuel + _ = Pr[= true | + canonicalChronologicalRetainedRunAfterFtsSecrets adversary parameter table ftsSecret + fuel >>= finishResolvedRunIsNone] := + probEvent_finishResolvedRun_none_eq_isNone _ + _ = Pr[= true | + canonicalDeferredRetainedRunAfterFtsSecrets adversary parameter table ftsSecret fuel >>= + finishResolvedRunIsNone] := + prob_canonicalChronologicalRetainedFinishIsNone_eq_deferred adversary parameter table + ftsSecret fuel + _ = Pr[fun failed : Bool => failed = true | + canonicalDeferredRetainedRunAfterFtsSecrets adversary parameter table ftsSecret fuel >>= + finishResolvedRunIsNone] := by + rw [probEvent_eq_eq_probOutput] + +set_option linter.constructorNameAsVariable false in +theorem probEvent_sampledActualRetainedOtsHashTable_verifyProbe_le_of_fixed + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (bound : ℝ≥0∞) + (hfixed : ∀ table : OtsSecretIndex → HashOutput, + Pr[WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret + (extendStartTable table)] ≤ bound) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ bound := by + unfold sampledActualRetainedOtsHashTable + apply probEvent_bind_le_of_forall_le + intro table _htable + simpa [probEvent_map, Function.comp_def] using hfixed table + +set_option linter.constructorNameAsVariable false in +theorem probEvent_sampledActualRetainedOtsSecrets_verifyProbe_le_of_fixed + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (bound : ℝ≥0∞) + (hfixed : ∀ table : OtsSecretIndex → HashOutput, + Pr[WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret + (extendStartTable table)] ≤ bound) : + Pr[fun result => WinningRetainedVerifyProbeAfterOtsSecret parameter result.1 + ftsSecret result.2 | + sampledActualRetainedOtsSecrets adversary parameter ftsSecret] ≤ bound := by + rw [← probEvent_sampledWinningRetainedVerifyProbe_eq_secrets adversary parameter ftsSecret] + exact probEvent_sampledActualRetainedOtsHashTable_verifyProbe_le_of_fixed adversary parameter + ftsSecret bound hfixed + +noncomputable def sampledViewedOtsSecrets (adversary : Adversary) + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ProbComp ((Layer → TreeIndex → LeafIndex → ChainIndex → Digest) × + ((Digest × Forgery × Bool) × ViewedFullTraceState)) := do + let otsSecret ← sampleOtsSecrets + let result ← gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + pure (otsSecret, result) + +theorem probEvent_cleanFresh_le_verifyProbeAfterOtsSecret + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[cleanFreshEvent parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + Pr[WinningRetainedVerifyProbeAfterOtsSecret parameter otsSecret ftsSecret | + actualRetainedGameAfterOtsSecret adversary parameter ftsSecret otsSecret] := by + let table := tableOfOtsSecret otsSecret + calc + _ ≤ Pr[WinningRetainedFreshLayerOpeningWitness parameter table ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret table] := by + simpa [table, tableOtsSecret_tableOfOtsSecret] using + probEvent_cleanFresh_le_actualRetained adversary parameter table ftsSecret + _ ≤ Pr[WinningRetainedVerifyProbeWitness parameter table ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret table] := + probEvent_winningRetainedFresh_le_verifyProbe adversary parameter table ftsSecret + _ = _ := by + rw [actualRetainedGameAfterTable_eq_afterOtsSecret] + simp only [table, tableOtsSecret_tableOfOtsSecret] + rfl + +theorem probEvent_cleanBackward_le_verifyProbeAfterOtsSecret + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[cleanBackwardEvent parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + Pr[WinningRetainedVerifyProbeAfterOtsSecret parameter otsSecret ftsSecret | + actualRetainedGameAfterOtsSecret adversary parameter ftsSecret otsSecret] := by + let table := tableOfOtsSecret otsSecret + calc + _ ≤ Pr[WinningRetainedBackwardChainOpeningWitness parameter table ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret table] := by + simpa [table, tableOtsSecret_tableOfOtsSecret] using + probEvent_cleanBackward_le_actualRetained adversary parameter table ftsSecret + _ ≤ Pr[WinningRetainedVerifyProbeWitness parameter table ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret table] := + probEvent_winningRetainedBackward_le_verifyProbe adversary parameter table ftsSecret + _ = _ := by + rw [actualRetainedGameAfterTable_eq_afterOtsSecret] + simp only [table, tableOtsSecret_tableOfOtsSecret] + rfl + +theorem probEvent_sampledViewedOtsSecrets_cleanFresh_le_verifyProbe + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[fun result => cleanFreshEvent parameter result.1 ftsSecret result.2 | + sampledViewedOtsSecrets adversary parameter ftsSecret] ≤ + Pr[fun result => WinningRetainedVerifyProbeAfterOtsSecret parameter result.1 + ftsSecret result.2 | + sampledActualRetainedOtsSecrets adversary parameter ftsSecret] := by + unfold sampledViewedOtsSecrets sampledActualRetainedOtsSecrets + apply probEvent_bind_le_bind_of_forall_le + intro otsSecret _hots + simpa [probEvent_map, Function.comp_def] using + probEvent_cleanFresh_le_verifyProbeAfterOtsSecret adversary parameter otsSecret ftsSecret + +theorem probEvent_sampledViewedOtsSecrets_cleanBackward_le_verifyProbe + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[fun result => cleanBackwardEvent parameter result.1 ftsSecret result.2 | + sampledViewedOtsSecrets adversary parameter ftsSecret] ≤ + Pr[fun result => WinningRetainedVerifyProbeAfterOtsSecret parameter result.1 + ftsSecret result.2 | + sampledActualRetainedOtsSecrets adversary parameter ftsSecret] := by + unfold sampledViewedOtsSecrets sampledActualRetainedOtsSecrets + apply probEvent_bind_le_bind_of_forall_le + intro otsSecret _hots + simpa [probEvent_map, Function.comp_def] using + probEvent_cleanBackward_le_verifyProbeAfterOtsSecret adversary parameter otsSecret ftsSecret + +noncomputable def sampledViewedGameFtsFirst (adversary : Adversary) : + ProbComp SampledViewedResult := do + let parameter ← sampleParameter + let ftsSecret ← sampleFtsSecrets + let result ← sampledViewedOtsSecrets adversary parameter ftsSecret + pure ⟨⟨parameter, result.1, ftsSecret⟩, result.2⟩ + +set_option maxRecDepth 100000 in +theorem evalDist_sampledViewedGame_eq_ftsFirst (adversary : Adversary) : + 𝒟[sampledViewedGame adversary] = 𝒟[sampledViewedGameFtsFirst adversary] := by + unfold sampledViewedGame sampleSecrets sampledViewedGameFtsFirst sampledViewedOtsSecrets + simp only [bind_assoc, pure_bind] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro parameter + exact OracleComp.DeferredSampling.evalDist_bind_comm sampleOtsSecrets sampleFtsSecrets + (fun otsSecret ftsSecret => do + let result ← gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + pure (⟨⟨parameter, otsSecret, ftsSecret⟩, result⟩ : SampledViewedResult)) + +theorem probEvent_sampledViewedGame_cleanFresh_le_of_sampled + (adversary : Adversary) (bound : ℝ≥0∞) + (hsampled : ∀ parameter ∈ support sampleParameter, + ∀ ftsSecret ∈ support sampleFtsSecrets, + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ bound) : + Pr[SampledViewedEvent cleanFreshEvent | sampledViewedGame adversary] ≤ bound := by + have hrewrite : + Pr[SampledViewedEvent cleanFreshEvent | sampledViewedGame adversary] = + Pr[SampledViewedEvent cleanFreshEvent | sampledViewedGameFtsFirst adversary] := + OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + (evalDist_sampledViewedGame_eq_ftsFirst adversary) + rw [hrewrite] + unfold sampledViewedGameFtsFirst + apply probEvent_bind_le_of_forall_le + intro parameter hparameter + apply probEvent_bind_le_of_forall_le + intro ftsSecret hfts + calc + _ = Pr[fun result => cleanFreshEvent parameter result.1 ftsSecret result.2 | + sampledViewedOtsSecrets adversary parameter ftsSecret] := by + change Pr[SampledViewedEvent cleanFreshEvent | + (fun result => + (⟨⟨parameter, result.1, ftsSecret⟩, result.2⟩ : SampledViewedResult)) <$> + sampledViewedOtsSecrets adversary parameter ftsSecret] = _ + rw [probEvent_map] + rfl + _ ≤ Pr[fun result => WinningRetainedVerifyProbeAfterOtsSecret parameter result.1 + ftsSecret result.2 | + sampledActualRetainedOtsSecrets adversary parameter ftsSecret] := + probEvent_sampledViewedOtsSecrets_cleanFresh_le_verifyProbe adversary parameter ftsSecret + _ = Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] := + (probEvent_sampledWinningRetainedVerifyProbe_eq_secrets adversary parameter ftsSecret).symm + _ ≤ bound := hsampled parameter hparameter ftsSecret hfts + +theorem probEvent_sampledViewedGame_cleanBackward_le_of_sampled + (adversary : Adversary) (bound : ℝ≥0∞) + (hsampled : ∀ parameter ∈ support sampleParameter, + ∀ ftsSecret ∈ support sampleFtsSecrets, + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ bound) : + Pr[SampledViewedEvent cleanBackwardEvent | sampledViewedGame adversary] ≤ bound := by + have hrewrite : + Pr[SampledViewedEvent cleanBackwardEvent | sampledViewedGame adversary] = + Pr[SampledViewedEvent cleanBackwardEvent | sampledViewedGameFtsFirst adversary] := + OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + (evalDist_sampledViewedGame_eq_ftsFirst adversary) + rw [hrewrite] + unfold sampledViewedGameFtsFirst + apply probEvent_bind_le_of_forall_le + intro parameter hparameter + apply probEvent_bind_le_of_forall_le + intro ftsSecret hfts + calc + _ = Pr[fun result => cleanBackwardEvent parameter result.1 ftsSecret result.2 | + sampledViewedOtsSecrets adversary parameter ftsSecret] := by + change Pr[SampledViewedEvent cleanBackwardEvent | + (fun result => + (⟨⟨parameter, result.1, ftsSecret⟩, result.2⟩ : SampledViewedResult)) <$> + sampledViewedOtsSecrets adversary parameter ftsSecret] = _ + rw [probEvent_map] + rfl + _ ≤ Pr[fun result => WinningRetainedVerifyProbeAfterOtsSecret parameter result.1 + ftsSecret result.2 | + sampledActualRetainedOtsSecrets adversary parameter ftsSecret] := + probEvent_sampledViewedOtsSecrets_cleanBackward_le_verifyProbe adversary parameter ftsSecret + _ = Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] := + (probEvent_sampledWinningRetainedVerifyProbe_eq_secrets adversary parameter ftsSecret).symm + _ ≤ bound := hsampled parameter hparameter ftsSecret hfts + +theorem security_of_sampledWinningRetainedVerifyProbe_le_mul + (c : Nat) (hc : 2 * c + 1 ≤ 19) + (hprobe : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ securityBits → + ∀ parameter ∈ support sampleParameter, + ∀ ftsSecret ∈ support sampleFtsSecrets, + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + ((c * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + SphincsSecurityStatement := by + apply security_of_sampled_hiddenOpeningRisk_le + intro q hqPos adversary hq hqMax + let probeBound := ((c * q : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + let unitBound := (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + have hsampled : ∀ parameter ∈ support sampleParameter, + ∀ ftsSecret ∈ support sampleFtsSecrets, + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ probeBound := by + intro parameter hparameter ftsSecret hfts + exact hprobe q hqPos adversary hq hqMax parameter hparameter ftsSecret hfts + have hfresh : + Pr[SampledViewedEvent cleanFreshEvent | sampledViewedGame adversary] ≤ probeBound := + probEvent_sampledViewedGame_cleanFresh_le_of_sampled adversary probeBound hsampled + have hbackward : + Pr[SampledViewedEvent cleanBackwardEvent | sampledViewedGame adversary] ≤ probeBound := + probEvent_sampledViewedGame_cleanBackward_le_of_sampled adversary probeBound hsampled + have huncovered : + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary] ≤ unitBound := + FtsProbeSimulation.probEvent_sampledViewedGame_cleanUncovered_le adversary q hq + rw [sampledHiddenOpeningRisk] + calc + _ ≤ probeBound + (probeBound + unitBound) := + add_le_add hfresh (add_le_add hbackward huncovered) + _ = (((2 * c + 1) * q : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + simp only [probeBound, unitBound] + push_cast + ring + _ ≤ ((19 * q : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + gcongr + +theorem security_of_sampledWinningRetainedVerifyProbe_le + (hprobe : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ securityBits → + ∀ parameter ∈ support sampleParameter, + ∀ ftsSecret ∈ support sampleFtsSecrets, + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + SphincsSecurityStatement := by + apply security_of_sampledWinningRetainedVerifyProbe_le_mul 1 (by omega) + simpa using hprobe + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveEndpoint.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveEndpoint.lean new file mode 100644 index 00000000..dca199f9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveEndpoint.lean @@ -0,0 +1,195 @@ +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveBridge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def verifierFinishObserve + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : (Forgery × QueryLog SigningSpec) × SplitHashCache) : ProbComp Bool := + runResolvedFinishIsNone context fuel table + ((canonicalVerifierFinish parameter root value.1).run value.2) + +instance verifierFinishObserve_observerDooms + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (root : Digest) : + ObserverDooms table (verifierFinishObserve table parameter root) where + eq_true context fuel value hconsistent hstarts hdoomed := by + exact evalDist_runResolvedFinishIsNone_eq_true_of_not_completable context fuel table + ((canonicalVerifierFinish parameter root value.1).run value.2) + hconsistent hstarts hdoomed + +instance verifierFinishObserve_observerSynchronized + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (root : Digest) : + ObserverSynchronized table (verifierFinishObserve table parameter root) where + eq_of_synchronized left right fuel value hcontext hvalues hrevealed := by + exact evalDist_runResolvedFinishIsNone_eq_of_finalizationSynchronized + ((canonicalVerifierFinish parameter root value.1).run value.2) + left right fuel table hcontext hvalues hrevealed + +instance verifierFinishObserve_observerPositionNeutral + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (root : Digest) : + ObserverPositionNeutral table (verifierFinishObserve table parameter root) where + eq_resolve position context fuel value hvalid hcompletable hensured := by + exact evalDist_resolveDeferredPositionValue_then_runResolvedFinishIsNone position + ((canonicalVerifierFinish parameter root value.1).run value.2) + context fuel table hvalid hcompletable hensured + +noncomputable def boundaryDeferredRetainedFinishIsNone + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := do + let rootResult ← runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure true + | some rootResult => + boundaryObserve (maskedExpandedAdversaryImpl parameter rootResult.value.1 ftsSecret) + (signingTraceComputation (adversary.main ⟨rootResult.value.1, parameter⟩)) + (verifierFinishObserve table parameter rootResult.value.1) + rootResult.context rootResult.remaining table rootResult.value.2 + +theorem finalizationMaterializedCouples_maskedPublishedTreeRoot + (table : OtsSecretIndex → HashOutput) : + FinalizationMaterializedCouples table maskedPublishedTreeRoot := by + unfold maskedPublishedTreeRoot + apply (finalizationMaterializedCouples_ensureTreeNode table topLayer rootTree + (layerHeight topLayer) 0).bind + intro _ + exact finalizationMaterializedCouples_revealPublishedCoordinate table + (.position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0)) + +theorem resolvedPreservesPublished_maskedPublishedTreeRoot : + ResolvedPreservesPublished maskedPublishedTreeRoot := by + unfold maskedPublishedTreeRoot + apply (resolvedPreservesPublishedValues_ensureTreeNode topLayer rootTree + (layerHeight topLayer) 0).bind + intro _ + exact resolvedPreservesPublishedValues_revealPublishedCoordinate _ + +set_option maxRecDepth 100000 in +theorem resolvedCore_of_mem_runSynchronizedResolved_canonicalDeferred + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hpublished : PublishedValues context.state) + (hresult : some result ∈ support + (runSynchronizedResolved + (canonicalDeferredAdversaryImpl parameter root table ftsSecret) + computation context fuel table cache)) : + result.table = table ∧ result.context.ValuesConsistent ∧ + StartTableAgrees result.context.state table ∧ PublishedValues result.context.state := by + induction computation using OracleComp.inductionOn generalizing context fuel cache result with + | pure value => + rw [runSynchronizedResolved_pure _ value context fuel table cache hcompletable] at hresult + simp only [mem_support_pure_iff, Option.some.injEq] at hresult + subst result + exact ⟨rfl, hvalid.valuesConsistent, + startTableAgrees_of_deferredCompletable hcompletable, hpublished⟩ + | query_bind query next ih => + rw [runSynchronizedResolved, OracleComp.construct_query_bind] at hresult + simp only [dif_pos hcompletable, mem_support_bind_iff] at hresult + obtain ⟨stepOption, hstep, htail⟩ := hresult + cases stepOption with + | none => simp at htail + | some stepResult => + have hstepCore := canonicalDeferredAdversaryImpl_core parameter root table ftsSecret + query context fuel cache stepResult hvalid hcompletable hpublished hstep + change some result ∈ support + (runSynchronizedResolved + (canonicalDeferredAdversaryImpl parameter root table ftsSecret) + (next stepResult.value.1) stepResult.context stepResult.remaining + stepResult.table stepResult.value.2) at htail + rw [hstepCore.1] at htail + by_cases hnextCompletable : DeferredCompletable table stepResult.context + · have hnextValid := valid_of_resolvedCore_completable table stepResult.context + hstepCore.2.1 hstepCore.2.2.1 hnextCompletable + exact ih stepResult.value.1 stepResult.context stepResult.remaining + stepResult.value.2 result hnextValid hnextCompletable hstepCore.2.2.2 htail + · rw [runSynchronizedResolved_of_not_completable] at htail + · simp at htail + · exact hnextCompletable + +set_option maxRecDepth 100000 in +theorem evalDist_canonicalDeferredRetainedFinishIsNone_eq_boundary + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist + (canonicalDeferredRetainedRunAfterFtsSecrets adversary parameter table ftsSecret fuel >>= + finishResolvedRunIsNone) = + evalDist + (boundaryDeferredRetainedFinishIsNone adversary parameter table ftsSecret fuel) := by + unfold canonicalDeferredRetainedRunAfterFtsSecrets + boundaryDeferredRetainedFinishIsNone + simp only [bind_assoc] + apply evalDist_bind_congr + intro rootOption hroot + cases rootOption with + | none => simp [finishResolvedRunIsNone, finishResolvedRun] + | some rootResult => + have hrootCore := resolvedCore_of_mem_runResolved_maskedPublishedTreeRoot parameter table + fuel rootResult hroot + have hrootInvariants := + valid_completable_of_mem_runResolvedFromTable_of_finalizationMaterializedCouples table + maskedPublishedTreeRoot + (finalizationMaterializedCouples_maskedPublishedTreeRoot table) + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel emptySplitHashCache rootResult DeferredContext.valid_empty + (deferredCompletable_empty table) hroot + have hrootPublished : PublishedValues rootResult.context.state := + resolvedPreservesPublished_maskedPublishedTreeRoot + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + emptySplitHashCache fuel table rootResult publishedValues_empty hroot + simp only + rw [hrootCore.1] + calc + _ = evalDist + (runSynchronizedResolved + (canonicalDeferredAdversaryImpl parameter rootResult.value.1 table ftsSecret) + (signingTraceComputation + (adversary.main ⟨rootResult.value.1, parameter⟩)) + rootResult.context rootResult.remaining table rootResult.value.2 >>= + finishObserve + (verifierFinishObserve table parameter rootResult.value.1)) := by + rw [bind_assoc] + apply evalDist_bind_congr + intro adversaryOption hadversary + cases adversaryOption with + | none => simp [canonicalVerifierContinuation, finishResolvedRunIsNone, + finishResolvedRun] + | some adversaryResult => + have hadversaryCore := + resolvedCore_of_mem_runSynchronizedResolved_canonicalDeferred parameter + rootResult.value.1 table ftsSecret + (signingTraceComputation + (adversary.main ⟨rootResult.value.1, parameter⟩)) + rootResult.context rootResult.remaining rootResult.value.2 + adversaryResult hrootInvariants.1 hrootInvariants.2 hrootPublished + hadversary + simp [canonicalVerifierContinuation, finishObserve, + verifierFinishObserve, runResolvedFinishIsNone, hadversaryCore.1] + _ = _ := evalDist_canonicalDeferred_adaptive_eq_boundaryObserve parameter + rootResult.value.1 table ftsSecret + (signingTraceComputation (adversary.main ⟨rootResult.value.1, parameter⟩)) + (verifierFinishObserve table parameter rootResult.value.1) + rootResult.context rootResult.remaining rootResult.value.2 hrootInvariants.1 + hrootInvariants.2 hrootPublished + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveFinalization.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveFinalization.lean new file mode 100644 index 00000000..f017d8e3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveFinalization.lean @@ -0,0 +1,1532 @@ +import SphincsSecurity.Proof.OtsProbeResolvedSignerFinalization + +/-! +# Finalization equivalence through adaptive execution + +The chronological and delayed signers leave different coordinates materialized. This file tracks +their common clean completion semantics through the adaptive random-oracle handler, while treating +a context with no clean completion as terminally doomed. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def FinalizationDoomedRun (table : OtsSecretIndex → HashOutput) : + Option (ResolvedRunResult α) → Prop + | none => True + | some result => + result.table = table ∧ DoomedResolvedContext table result.context + +def FinalizationAdaptiveRunEq (table : OtsSecretIndex → HashOutput) : + Option (ResolvedRunResult (α × SplitHashCache)) → + Option (ResolvedRunResult (α × SplitHashCache)) → Prop := + fun left right => + FinalizationMaterializedRunEq table left right ∨ + (FinalizationDoomedRun table left ∧ FinalizationDoomedRun table right) + +def MaterializedValuesEq : + Option (ResolvedRunResult (α × SplitHashCache)) → + Option (ResolvedRunResult (α × SplitHashCache)) → Prop + | none, none => True + | some left, some right => left.context.state.values = right.context.state.values + | _, _ => False + +def FinalizationSynchronizedRunEq (table : OtsSecretIndex → HashOutput) : + Option (ResolvedRunResult (α × SplitHashCache)) → + Option (ResolvedRunResult (α × SplitHashCache)) → Prop := + fun left right => + (FinalizationMaterializedRunEq table left right ∧ MaterializedValuesEq left right) ∨ + (FinalizationDoomedRun table left ∧ FinalizationDoomedRun table right) + +def FinalizationSynchronizedCouples (table : OtsSecretIndex → HashOutput) + (left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftContext rightContext fuel leftCache rightCache, + FinalizationContextEq table (some leftContext) (some rightContext) → + leftContext.state.values = rightContext.state.values → + ordinaryQueryCache leftCache = ordinaryQueryCache rightCache → + leftContext.state.revealed = rightContext.state.revealed → + RelTriple + (runResolvedFromTable leftContext fuel table (left.run leftCache)) + (runResolvedFromTable rightContext fuel table (right.run rightCache)) + (FinalizationSynchronizedRunEq table) + +theorem FinalizationAdaptiveRunEq.symm + {table : OtsSecretIndex → HashOutput} + {left right : Option (ResolvedRunResult (α × SplitHashCache))} + (hrelation : FinalizationAdaptiveRunEq table left right) : + FinalizationAdaptiveRunEq table right left := by + rcases hrelation with hclean | hdoomed + · left + cases left with + | none => + cases right with + | none => trivial + | some right => simp [FinalizationMaterializedRunEq] at hclean + | some left => + cases right with + | none => simp [FinalizationMaterializedRunEq] at hclean + | some right => + rcases hclean with + ⟨hvalue, hcontext, hfuel, hleftTable, hrightTable, hcache, hrevealed⟩ + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hrightCompletable : DeferredCompletable table right.context := by + rcases hleftCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, (hview.deferredCompletion_iff completion).mp hcompletion⟩ + exact ⟨hvalue.symm, + ⟨hview.symm, hrightValid, hleftValid, hrightCompletable⟩, + hfuel.symm, hrightTable, hleftTable, hcache.symm, hrevealed.symm⟩ + · exact Or.inr ⟨hdoomed.2, hdoomed.1⟩ + +def FinalizationAdaptiveCouples (table : OtsSecretIndex → HashOutput) + (left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftContext rightContext fuel leftCache rightCache, + FinalizationContextEq table (some leftContext) (some rightContext) → + ordinaryQueryCache leftCache = ordinaryQueryCache rightCache → + leftContext.state.revealed = rightContext.state.revealed → + RelTriple + (runResolvedFromTable leftContext fuel table (left.run leftCache)) + (runResolvedFromTable rightContext fuel table (right.run rightCache)) + (FinalizationAdaptiveRunEq table) + +theorem finalizationDoomedRun_of_mem_runResolvedFromTable + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (result : ResolvedRunResult α) + (hdoomed : DoomedResolvedContext table context) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table computation)) : + FinalizationDoomedRun table (some result) := by + have hcore := resolvedCore_of_mem_runResolvedFromTable computation context fuel table result + hdoomed.1 hdoomed.2.1 hresult + exact ⟨hcore.1, hcore.2.1, hcore.2.2, + not_deferredCompletable_of_mem_runResolvedFromTable computation context fuel table result + hdoomed.1 hdoomed.2.1 hresult hdoomed.2.2⟩ + +theorem relTriple_runResolvedFromTable_of_finalizationDoomed + (table : OtsSecretIndex → HashOutput) + (leftComputation : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (rightComputation : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (hleftDoomed : DoomedResolvedContext table left) + (hrightDoomed : DoomedResolvedContext table right) : + RelTriple + (runResolvedFromTable left leftFuel table leftComputation) + (runResolvedFromTable right rightFuel table rightComputation) + (FinalizationAdaptiveRunEq table) := by + have hbase := relTriple_true + (runResolvedFromTable left leftFuel table leftComputation) + (runResolvedFromTable right rightFuel table rightComputation) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (runResolvedFromTable left leftFuel table leftComputation)) + (fun result hresult => hresult) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro leftResult rightResult hrelation + right + constructor + · cases leftResult with + | none => trivial + | some result => + exact finalizationDoomedRun_of_mem_runResolvedFromTable table leftComputation left leftFuel + result hleftDoomed hrelation.1.2 + · cases rightResult with + | none => trivial + | some result => + exact finalizationDoomedRun_of_mem_runResolvedFromTable table rightComputation right rightFuel + result hrightDoomed hrelation.2 + +theorem relTriple_pure_none_runResolvedFromTable_of_finalizationDoomed + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (context : DeferredContext) (fuel : Nat) + (hdoomed : DoomedResolvedContext table context) : + RelTriple + (pure none : ProbComp + (Option (ResolvedRunResult (α × SplitHashCache)))) + (runResolvedFromTable context fuel table computation) + (FinalizationAdaptiveRunEq table) := by + have hbase := relTriple_true + (pure none : ProbComp (Option (ResolvedRunResult (α × SplitHashCache)))) + (runResolvedFromTable context fuel table computation) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (pure none : ProbComp (Option (ResolvedRunResult (α × SplitHashCache))))) + (fun result hresult => hresult) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro leftResult rightResult hrelation + have hleftResult : leftResult = none := by simpa using hrelation.1.2 + subst leftResult + right + refine ⟨trivial, ?_⟩ + cases rightResult with + | none => trivial + | some result => + exact finalizationDoomedRun_of_mem_runResolvedFromTable table computation context fuel + result hdoomed hrelation.2 + +theorem relTriple_runResolvedFromTable_pure_none_of_finalizationDoomed + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (context : DeferredContext) (fuel : Nat) + (hdoomed : DoomedResolvedContext table context) : + RelTriple + (runResolvedFromTable context fuel table computation) + (pure none : ProbComp + (Option (ResolvedRunResult (α × SplitHashCache)))) + (FinalizationAdaptiveRunEq table) := by + apply relTriple_post_mono + (relTriple_symm + (relTriple_pure_none_runResolvedFromTable_of_finalizationDoomed table computation context + fuel hdoomed)) + intro leftResult rightResult hrelation + exact hrelation.symm + +theorem relTriple_runResolvedFromTable_of_finalizationDoomed_synchronized + (table : OtsSecretIndex → HashOutput) + (leftComputation : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (rightComputation : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (hleftDoomed : DoomedResolvedContext table left) + (hrightDoomed : DoomedResolvedContext table right) : + RelTriple + (runResolvedFromTable left leftFuel table leftComputation) + (runResolvedFromTable right rightFuel table rightComputation) + (FinalizationSynchronizedRunEq table) := by + have hbase := relTriple_true + (runResolvedFromTable left leftFuel table leftComputation) + (runResolvedFromTable right rightFuel table rightComputation) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (runResolvedFromTable left leftFuel table leftComputation)) + (fun result hresult => hresult) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro leftResult rightResult hrelation + right + constructor + · cases leftResult with + | none => trivial + | some result => + exact finalizationDoomedRun_of_mem_runResolvedFromTable table leftComputation left + leftFuel result hleftDoomed hrelation.1.2 + · cases rightResult with + | none => trivial + | some result => + exact finalizationDoomedRun_of_mem_runResolvedFromTable table rightComputation right + rightFuel result hrightDoomed hrelation.2 + +theorem relTriple_pure_none_runResolvedFromTable_of_finalizationDoomed_synchronized + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (context : DeferredContext) (fuel : Nat) + (hdoomed : DoomedResolvedContext table context) : + RelTriple + (pure none : ProbComp + (Option (ResolvedRunResult (α × SplitHashCache)))) + (runResolvedFromTable context fuel table computation) + (FinalizationSynchronizedRunEq table) := by + have hbase := relTriple_true + (pure none : ProbComp (Option (ResolvedRunResult (α × SplitHashCache)))) + (runResolvedFromTable context fuel table computation) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (pure none : ProbComp (Option (ResolvedRunResult (α × SplitHashCache))))) + (fun result hresult => hresult) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro leftResult rightResult hrelation + have hleftResult : leftResult = none := by simpa using hrelation.1.2 + subst leftResult + right + refine ⟨trivial, ?_⟩ + cases rightResult with + | none => trivial + | some result => + exact finalizationDoomedRun_of_mem_runResolvedFromTable table computation context fuel + result hdoomed hrelation.2 + +theorem relTriple_runResolvedFromTable_pure_none_of_finalizationDoomed_synchronized + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (context : DeferredContext) (fuel : Nat) + (hdoomed : DoomedResolvedContext table context) : + RelTriple + (runResolvedFromTable context fuel table computation) + (pure none : ProbComp + (Option (ResolvedRunResult (α × SplitHashCache)))) + (FinalizationSynchronizedRunEq table) := by + apply relTriple_post_mono + (relTriple_symm + (relTriple_pure_none_runResolvedFromTable_of_finalizationDoomed_synchronized table + computation context fuel hdoomed)) + intro leftResult rightResult hrelation + rcases hrelation with hclean | hdoomed + · cases leftResult with + | none => + cases rightResult with + | none => exact Or.inl ⟨trivial, trivial⟩ + | some rightResult => simp [FinalizationMaterializedRunEq] at hclean + | some leftResult => + cases rightResult with + | none => simp [FinalizationMaterializedRunEq] at hclean + | some rightResult => + rcases hclean.1 with + ⟨hvalue, hcontext, hfuel, hleftTable, hrightTable, hcache, hrevealed⟩ + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hleftCompletable' : DeferredCompletable table leftResult.context := by + rcases hleftCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, (hview.deferredCompletion_iff completion).mp hcompletion⟩ + left + exact ⟨⟨hvalue.symm, + ⟨hview.symm, hrightValid, hleftValid, hleftCompletable'⟩, + hfuel.symm, hrightTable, hleftTable, hcache.symm, hrevealed.symm⟩, + hclean.2.symm⟩ + · exact Or.inr ⟨hdoomed.2, hdoomed.1⟩ + +theorem FinalizationMaterializedCouples.toAdaptive + {table : OtsSecretIndex → HashOutput} + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + (hcomputation : FinalizationMaterializedCouples table computation) : + FinalizationAdaptiveCouples table computation computation := by + intro left right fuel leftCache rightCache hcontext hcache hrevealed + apply relTriple_post_mono + (hcomputation left right fuel leftCache rightCache hcontext hcache hrevealed) + intro leftResult rightResult hrelation + exact Or.inl hrelation + +theorem FinalizationSynchronizedRunEq.toAdaptive + {table : OtsSecretIndex → HashOutput} + {left right : Option (ResolvedRunResult (α × SplitHashCache))} + (hrelation : FinalizationSynchronizedRunEq table left right) : + FinalizationAdaptiveRunEq table left right := by + rcases hrelation with hclean | hdoomed + · exact Or.inl hclean.1 + · exact Or.inr hdoomed + +theorem finalizationSynchronizedCouples_pure + (table : OtsSecretIndex → HashOutput) (value : α) : + FinalizationSynchronizedCouples table + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := by + intro left right fuel leftCache rightCache hcontext hvalues hcache hrevealed + simp [StateT.run_pure, runResolvedFromTable, FinalizationSynchronizedRunEq, + FinalizationMaterializedRunEq, MaterializedValuesEq, hcontext, hvalues, hcache, hrevealed] + +theorem finalizationSynchronizedCouples_peekCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + FinalizationSynchronizedCouples table (peekCoordinate coordinate) + (peekCoordinate coordinate) := by + intro left right fuel leftCache rightCache hcontext hvalues hcache hrevealed + cases hleftValue : left.state.values coordinate with + | none => + have hrightValue : right.state.values coordinate = none := by + rw [← hvalues] + exact hleftValue + rw [runResolvedFromTable_peekCoordinate_of_none left fuel table leftCache coordinate + hleftValue, + runResolvedFromTable_peekCoordinate_of_none right fuel table rightCache coordinate + hrightValue] + apply relTriple_pure_pure + left + exact ⟨⟨rfl, hcontext, rfl, rfl, rfl, hcache, hrevealed⟩, hvalues⟩ + | some output => + have hrightValue : right.state.values coordinate = some output := by + rw [← hvalues] + exact hleftValue + rw [runResolvedFromTable_peekCoordinate_of_value left fuel table leftCache coordinate output + hleftValue, + runResolvedFromTable_peekCoordinate_of_value right fuel table rightCache coordinate output + hrightValue] + apply relTriple_pure_pure + left + exact ⟨⟨rfl, hcontext, rfl, rfl, rfl, hcache, hrevealed⟩, hvalues⟩ + +theorem finalizationSynchronizedCouples_ensureCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + FinalizationSynchronizedCouples table (ensureCoordinate coordinate) + (ensureCoordinate coordinate) := by + intro left right fuel leftCache rightCache hcontext hvalues hcache hrevealed + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + unfold ensureCoordinate + simp only [StateT.run_liftM, LazyRevealProbe.ensureQuery, runResolvedFromTable] + apply relTriple_pure_pure + left + exact ⟨⟨rfl, + ⟨hview.ensure coordinate, hleftValid.ensure coordinate, + hrightValid.ensure coordinate, hleftCompletable.ensure coordinate⟩, + rfl, rfl, rfl, hcache, hrevealed⟩, hvalues⟩ + +theorem finalizationSynchronizedCouples_publishCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + FinalizationSynchronizedCouples table (publishCoordinate coordinate) + (publishCoordinate coordinate) := by + intro left right fuel leftCache rightCache hcontext hvalues hcache hrevealed + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + unfold publishCoordinate + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.publishQuery, + runResolvedFromTable_publish_query_bind, + runResolvedFromTable_publish_query_bind] + apply relTriple_pure_pure + left + exact ⟨⟨rfl, + ⟨hview.publish coordinate, hleftValid.publish coordinate, + hrightValid.publish coordinate, hleftCompletable.publish coordinate⟩, + rfl, rfl, rfl, hcache, by + simpa [LazyRevealProbe.State.publish] using congrArg (insert coordinate) hrevealed⟩, + hvalues⟩ + +theorem finalizationSynchronizedCouples_splitHashQuery_ordinary + (table : OtsSecretIndex → HashOutput) (input : HashInput) : + FinalizationSynchronizedCouples table (splitHashQuery (.ordinary input)) + (splitHashQuery (.ordinary input)) := by + intro left right fuel leftCache rightCache hcontext hvalues hcache hrevealed + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + have hcacheAt : leftCache (.ordinary input) = rightCache (.ordinary input) := + congrFun hcache input + cases hlookup : leftCache (.ordinary input) with + | some output => + have hright : rightCache (.ordinary input) = some output := by + rw [← hcacheAt] + exact hlookup + simp only [hright] + simp [runResolvedFromTable, FinalizationSynchronizedRunEq, + FinalizationMaterializedRunEq, MaterializedValuesEq, hcontext, hvalues, hcache, + hrevealed] + | none => + have hright : rightCache (.ordinary input) = none := by + rw [← hcacheAt] + exact hlookup + simp only [hright] + rw [LazyRevealProbe.hashOutputQuery, + runResolvedFromTable_hashOutput_query_bind, + runResolvedFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runResolvedFromTable] + apply relTriple_pure_pure + left + refine ⟨⟨rfl, hcontext, rfl, rfl, rfl, ?_, hrevealed⟩, hvalues⟩ + rw [ordinaryQueryCache_update, ordinaryQueryCache_update, hcache] + +theorem finalizationSynchronizedCouples_ordinaryHashImpl + (table : OtsSecretIndex → HashOutput) (input : HashInput) : + FinalizationSynchronizedCouples table (ordinaryHashImpl input) + (ordinaryHashImpl input) := + finalizationSynchronizedCouples_splitHashQuery_ordinary table input + +set_option maxRecDepth 100000 in +theorem finalizationSynchronizedCouples_revealPosition + (table : OtsSecretIndex → HashOutput) (position : Position) : + FinalizationSynchronizedCouples table (revealPosition position) + (revealPosition position) := by + intro left right fuel leftCache rightCache hcontext hvalues hcache hrevealed + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + rw [runResolvedFromTable_revealPosition, runResolvedFromTable_revealPosition] + have hresolved := relTriple_resolveDeferredReveal_of_finalizationViewEq table position left + right hview hleftValid hrightValid hleftCompletable + have hresolvedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolved + (fun result => result ∈ support (resolveDeferredReveal table position left)) + (fun result hresult => hresult) + have hresolvedBoth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hresolvedLeft + apply relTriple_bind hresolvedBoth + intro leftResolved rightResolved hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResolved with + | none => + cases rightResolved with + | none => + simp [FinalizationSynchronizedRunEq, FinalizationMaterializedRunEq, + MaterializedValuesEq] + | some rightResolved => simp [FinalizationResolutionEq] at hrelation + | some leftResolved => + cases rightResolved with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResolved => + have hleftMaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition left position leftResolved) := by + rcases hrelation.2.2.2.2 with ⟨completion, hcompletion⟩ + exact ⟨completion, + (deferredCompletion_materializeResolvedReveal_iff position leftResolved + hleftValid hview.leftStarts hleftSupport).mpr hcompletion⟩ + have hrightRawCompletable : + DeferredCompletable table rightResolved.toDeferredContext := by + rcases hrelation.2.2.2.2 with ⟨completion, hcompletion⟩ + exact ⟨completion, + (hrelation.2.1.deferredCompletion_iff completion).mp hcompletion⟩ + have hrightMaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition right position rightResolved) := by + rcases hrightRawCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, + (deferredCompletion_materializeResolvedReveal_iff position rightResolved + hrightValid hview.rightStarts hrightSupport).mpr hcompletion⟩ + have hleftMaterializedView := finalizationViewEq_materializeResolvedReveal position + leftResolved hleftValid hview.leftStarts hleftSupport + hleftMaterializedCompletable + have hrightMaterializedView := finalizationViewEq_materializeResolvedReveal position + rightResolved hrightValid hview.rightStarts hrightSupport + hrightMaterializedCompletable + have hleftResultValid := hleftValid.of_resolveDeferredReveal table position + leftResolved hleftSupport + have hrightResultValid := hrightValid.of_resolveDeferredReveal table position + rightResolved hrightSupport + have hleftStateValues := resolveDeferredReveal_preserves_state_values table position + left leftResolved hleftSupport + have hrightStateValues := resolveDeferredReveal_preserves_state_values table position + right rightResolved hrightSupport + have hleftResolvedValue := resolveDeferredReveal_resolves table position left + leftResolved hleftSupport + have hrightResolvedValue := resolveDeferredReveal_resolves table position right + rightResolved hrightSupport + have hleftMaterializedValid : + (materializeResolvedPosition left position leftResolved).Valid := + hleftValid.materializeResolvedPosition_of position leftResolved hleftResultValid + hleftStateValues hleftResolvedValue + have hrightMaterializedValid : + (materializeResolvedPosition right position rightResolved).Valid := + hrightValid.materializeResolvedPosition_of position rightResolved hrightResultValid + hrightStateValues hrightResolvedValue + apply relTriple_pure_pure + left + refine ⟨⟨?_, ?_, rfl, rfl, rfl, ?_, ?_⟩, ?_⟩ + · simpa using congrArg truncateHash hrelation.1 + · exact ⟨hleftMaterializedView.trans + (hrelation.2.1.trans hrightMaterializedView.symm), + hleftMaterializedValid, hrightMaterializedValid, + hleftMaterializedCompletable⟩ + · rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, + hcache] + · simpa [materializeResolvedPosition, LazyRevealProbe.State.materialize] + using hrevealed + · change Function.update left.state.values (.position position) + (some leftResolved.output) = + Function.update right.state.values (.position position) + (some rightResolved.output) + rw [hrelation.1, hvalues] + +set_option maxRecDepth 100000 in +theorem finalizationSynchronizedCouples_revealPositionOutput + (table : OtsSecretIndex → HashOutput) (position : Position) : + FinalizationSynchronizedCouples table + (revealCoordinateOutput (.position position)) + (revealCoordinateOutput (.position position)) := by + intro left right fuel leftCache rightCache hcontext hvalues hcache hrevealed + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + rw [runResolvedFromTable_revealCoordinateOutput, + runResolvedFromTable_revealCoordinateOutput] + simp only + have hresolved := relTriple_resolveDeferredReveal_of_finalizationViewEq table position left + right hview hleftValid hrightValid hleftCompletable + have hresolvedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolved + (fun result => result ∈ support (resolveDeferredReveal table position left)) + (fun result hresult => hresult) + have hresolvedBoth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hresolvedLeft + apply relTriple_bind hresolvedBoth + intro leftResolved rightResolved hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResolved with + | none => + cases rightResolved with + | none => + simp [FinalizationSynchronizedRunEq, FinalizationMaterializedRunEq, + MaterializedValuesEq] + | some rightResolved => simp [FinalizationResolutionEq] at hrelation + | some leftResolved => + cases rightResolved with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResolved => + have hleftMaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition left position leftResolved) := by + rcases hrelation.2.2.2.2 with ⟨completion, hcompletion⟩ + exact ⟨completion, + (deferredCompletion_materializeResolvedReveal_iff position leftResolved + hleftValid hview.leftStarts hleftSupport).mpr hcompletion⟩ + have hrightRawCompletable : + DeferredCompletable table rightResolved.toDeferredContext := by + rcases hrelation.2.2.2.2 with ⟨completion, hcompletion⟩ + exact ⟨completion, + (hrelation.2.1.deferredCompletion_iff completion).mp hcompletion⟩ + have hrightMaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition right position rightResolved) := by + rcases hrightRawCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, + (deferredCompletion_materializeResolvedReveal_iff position rightResolved + hrightValid hview.rightStarts hrightSupport).mpr hcompletion⟩ + have hleftMaterializedView := finalizationViewEq_materializeResolvedReveal position + leftResolved hleftValid hview.leftStarts hleftSupport + hleftMaterializedCompletable + have hrightMaterializedView := finalizationViewEq_materializeResolvedReveal position + rightResolved hrightValid hview.rightStarts hrightSupport + hrightMaterializedCompletable + have hleftResultValid := hleftValid.of_resolveDeferredReveal table position + leftResolved hleftSupport + have hrightResultValid := hrightValid.of_resolveDeferredReveal table position + rightResolved hrightSupport + have hleftStateValues := resolveDeferredReveal_preserves_state_values table position + left leftResolved hleftSupport + have hrightStateValues := resolveDeferredReveal_preserves_state_values table position + right rightResolved hrightSupport + have hleftResolvedValue := resolveDeferredReveal_resolves table position left + leftResolved hleftSupport + have hrightResolvedValue := resolveDeferredReveal_resolves table position right + rightResolved hrightSupport + have hleftMaterializedValid : + (materializeResolvedPosition left position leftResolved).Valid := + hleftValid.materializeResolvedPosition_of position leftResolved hleftResultValid + hleftStateValues hleftResolvedValue + have hrightMaterializedValid : + (materializeResolvedPosition right position rightResolved).Valid := + hrightValid.materializeResolvedPosition_of position rightResolved hrightResultValid + hrightStateValues hrightResolvedValue + apply relTriple_pure_pure + left + refine ⟨⟨hrelation.1, ?_, rfl, rfl, rfl, ?_, ?_⟩, ?_⟩ + · exact ⟨hleftMaterializedView.trans + (hrelation.2.1.trans hrightMaterializedView.symm), + hleftMaterializedValid, hrightMaterializedValid, + hleftMaterializedCompletable⟩ + · rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, + hcache] + · simpa [materializeResolvedPosition, LazyRevealProbe.State.materialize] + using hrevealed + · change Function.update left.state.values (.position position) + (some leftResolved.output) = + Function.update right.state.values (.position position) + (some rightResolved.output) + rw [hrelation.1, hvalues] + +set_option maxRecDepth 100000 in +theorem finalizationSynchronizedCouples_revealChainStart + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) : + FinalizationSynchronizedCouples table + (revealChainStart index.lay index.tree index.leafIdx index.chainIdx) + (revealChainStart index.lay index.tree index.leafIdx index.chainIdx) := by + intro left right fuel leftCache rightCache hcontext hvalues hcache hrevealed + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + rw [revealChainStart, runResolvedFromTable_revealCoordinate, + runResolvedFromTable_revealCoordinate] + have hresolved := relTriple_resolveDeferredChainStart_of_finalizationViewEq table index left + right hview hleftValid hrightValid hleftCompletable + have hresolvedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolved + (fun result => result ∈ support + (pure (resolveDeferredChainStart table index left) : + ProbComp (Option DeferredResolution))) + (fun result hresult => hresult) + have hresolvedBoth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hresolvedLeft + apply relTriple_bind hresolvedBoth + intro leftResolved rightResolved hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResolved with + | none => + cases rightResolved with + | none => + simp [FinalizationSynchronizedRunEq, FinalizationMaterializedRunEq, + MaterializedValuesEq] + | some rightResolved => simp [FinalizationResolutionEq] at hrelation + | some leftResolved => + cases rightResolved with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResolved => + have hleftResult : + resolveDeferredChainStart table index left = some leftResolved := by + simpa using hleftSupport.symm + have hrightResult : + resolveDeferredChainStart table index right = some rightResolved := by + simpa using hrightSupport.symm + have hleftMaterializedCompletable := + hleftCompletable.materializeResolvedChainStart hview.leftStarts index leftResolved + hleftResult + have hrightCompletable : DeferredCompletable table right := by + rcases hleftCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, (hview.deferredCompletion_iff completion).mp hcompletion⟩ + have hrightMaterializedCompletable := + hrightCompletable.materializeResolvedChainStart hview.rightStarts index + rightResolved hrightResult + have hleftMaterializedView := + finalizationViewEq_materializeResolvedChainStart index leftResolved hleftValid + hview.leftStarts hleftResult hleftMaterializedCompletable + have hrightMaterializedView := + finalizationViewEq_materializeResolvedChainStart index rightResolved hrightValid + hview.rightStarts hrightResult hrightMaterializedCompletable + have hleftMaterializedValid : + (materializeResolvedChainStart left index leftResolved).Valid := by + unfold materializeResolvedChainStart + rw [resolveDeferredChainStart_deferred_values_eq table index left leftResolved + hleftResult] + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + exact hleftValid.materialize_chainStart lay tree leafIdx chainIdx leftResolved.output + have hrightMaterializedValid : + (materializeResolvedChainStart right index rightResolved).Valid := by + unfold materializeResolvedChainStart + rw [resolveDeferredChainStart_deferred_values_eq table index right rightResolved + hrightResult] + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + exact hrightValid.materialize_chainStart lay tree leafIdx chainIdx + rightResolved.output + apply relTriple_pure_pure + left + refine ⟨⟨?_, ?_, rfl, rfl, rfl, ?_, ?_⟩, ?_⟩ + · simpa using congrArg truncateHash hrelation.1 + · exact ⟨hleftMaterializedView.trans + (hrelation.2.1.trans hrightMaterializedView.symm), + hleftMaterializedValid, hrightMaterializedValid, + hleftMaterializedCompletable⟩ + · rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, + hcache] + · simpa [materializeResolvedChainStart, LazyRevealProbe.State.materialize] + using hrevealed + · change Function.update left.state.values index.coordinate + (some leftResolved.output) = + Function.update right.state.values index.coordinate + (some rightResolved.output) + rw [hrelation.1, hvalues] + +theorem finalizationSynchronizedCouples_revealCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + FinalizationSynchronizedCouples table (revealCoordinate coordinate) + (revealCoordinate coordinate) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact finalizationSynchronizedCouples_revealChainStart table + ⟨lay, tree, leafIdx, chainIdx⟩ + | position position => + exact finalizationSynchronizedCouples_revealPosition table position + +theorem DeferredCompletion.addPending_of_avoids + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} (coordinate : Coordinate) + (candidate : Digest) (hcompletion : DeferredCompletion table context completion) + (havoids : truncateHash (completion coordinate) ≠ candidate) : + DeferredCompletion table + { context with state := context.state.addPending coordinate candidate } completion := by + refine ⟨hcompletion.1, hcompletion.2.1, ?_, hcompletion.2.2.2⟩ + intro other otherCandidate hmember + simp only [LazyRevealProbe.State.addPending, Finset.mem_insert] at hmember + rcases hmember with hnew | hold + · rcases hnew with ⟨rfl, rfl⟩ + exact havoids + · exact hcompletion.2.2.1 other otherCandidate hold + +theorem FinalizationViewEq.addPending_of_completable + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewEq table left right) (coordinate : Coordinate) + (candidate : Digest) + (hleftCompletable : DeferredCompletable table + { left with state := left.state.addPending coordinate candidate }) + (hrightCompletable : DeferredCompletable table + { right with state := right.state.addPending coordinate candidate }) : + FinalizationViewEq table + { left with state := left.state.addPending coordinate candidate } + { right with state := right.state.addPending coordinate candidate } := by + refine ⟨hview.leftConsistent.addPending coordinate candidate, + hview.rightConsistent.addPending coordinate candidate, + hview.leftStarts.addPending coordinate candidate, + hview.rightStarts.addPending coordinate candidate, hview.valueEq, ?_, ?_, ?_⟩ + · intro other output hvalue hhit + obtain ⟨completion, hcompletion⟩ := hleftCompletable + have houtput := hcompletion.eq_resolvedCompletionValue other output hvalue + have havoids := hcompletion.2.2.1 + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + exact havoids other (truncateHash output) hhit (by rw [houtput]) + · intro other output hvalue hhit + obtain ⟨completion, hcompletion⟩ := hrightCompletable + have houtput := hcompletion.eq_resolvedCompletionValue other output hvalue + have havoids := hcompletion.2.2.1 + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + exact havoids other (truncateHash output) hhit (by rw [houtput]) + · intro other hvalue + have hvalueBase : resolvedCompletionValue table left other = none := hvalue + ext digest + rw [LazyRevealProbe.State.mem_pendingAt_iff, + LazyRevealProbe.State.mem_pendingAt_iff] + simp only [LazyRevealProbe.State.addPending, Finset.mem_insert] + have hbase : (other, digest) ∈ left.state.pending ↔ + (other, digest) ∈ right.state.pending := by + rw [← LazyRevealProbe.State.mem_pendingAt_iff, + ← LazyRevealProbe.State.mem_pendingAt_iff, + hview.pendingEq other hvalueBase] + tauto + +theorem deferredCompletable_addPending_iff_of_finalizationViewEq + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewEq table left right) (coordinate : Coordinate) + (candidate : Digest) : + DeferredCompletable table + { left with state := left.state.addPending coordinate candidate } ↔ + DeferredCompletable table + { right with state := right.state.addPending coordinate candidate } := by + constructor + · rintro ⟨completion, hcompletion⟩ + have hleftBase := hcompletion.of_addPending coordinate candidate + have hrightBase := (hview.deferredCompletion_iff completion).mp hleftBase + have havoids := hcompletion.2.2.1 coordinate candidate (by + simp [LazyRevealProbe.State.addPending]) + exact ⟨completion, hrightBase.addPending_of_avoids coordinate candidate havoids⟩ + · rintro ⟨completion, hcompletion⟩ + have hrightBase := hcompletion.of_addPending coordinate candidate + have hleftBase := (hview.deferredCompletion_iff completion).mpr hrightBase + have havoids := hcompletion.2.2.1 coordinate candidate (by + simp [LazyRevealProbe.State.addPending]) + exact ⟨completion, hleftBase.addPending_of_avoids coordinate candidate havoids⟩ + +theorem finalizationAdaptiveCouples_probe + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (candidate : Digest) : + FinalizationAdaptiveCouples table (probe ⟨coordinate, candidate⟩) + (probe ⟨coordinate, candidate⟩) := by + intro left right fuel leftCache rightCache hcontext hcache hrevealed + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + unfold probe + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.probeQuery, + runResolvedFromTable_probe_query_bind, runResolvedFromTable_probe_query_bind] + cases fuel with + | zero => + apply relTriple_pure_pure + exact Or.inl trivial + | succ remaining => + by_cases hleftRevealed : coordinate ∈ left.state.revealed + · have hrightRevealed : coordinate ∈ right.state.revealed := by + rw [← hrevealed] + exact hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte, runResolvedFromTable] + apply relTriple_pure_pure + exact Or.inl ⟨rfl, ⟨hview, hleftValid, hrightValid, hleftCompletable⟩, + rfl, rfl, rfl, hcache, hrevealed⟩ + · have hrightRevealed : coordinate ∉ right.state.revealed := by + rwa [← hrevealed] + simp only [hleftRevealed, hrightRevealed, ↓reduceIte, runResolvedFromTable] + let left' : DeferredContext := + { left with state := left.state.addPending coordinate candidate } + let right' : DeferredContext := + { right with state := right.state.addPending coordinate candidate } + have hcompletableIff := deferredCompletable_addPending_iff_of_finalizationViewEq hview + coordinate candidate + by_cases hleft' : DeferredCompletable table left' + · have hright' : DeferredCompletable table right' := hcompletableIff.mp hleft' + obtain ⟨leftCompletion, hleftCompletion⟩ := hleft' + obtain ⟨rightCompletion, hrightCompletion⟩ := hright' + have hleftCompletable' : DeferredCompletable table left' := + ⟨leftCompletion, hleftCompletion⟩ + have hrightCompletable' : DeferredCompletable table right' := + ⟨rightCompletion, hrightCompletion⟩ + have hleftValid' : left'.Valid := ⟨ + hleftValid.valuesConsistent.addPending coordinate candidate, by + intro other output hvalue hhit + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + exact hleftCompletion.2.2.1 other (truncateHash output) hhit + (by rw [hleftCompletion.1 other output hvalue])⟩ + have hrightValid' : right'.Valid := ⟨ + hrightValid.valuesConsistent.addPending coordinate candidate, by + intro other output hvalue hhit + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + exact hrightCompletion.2.2.1 other (truncateHash output) hhit + (by rw [hrightCompletion.1 other output hvalue])⟩ + apply relTriple_pure_pure + left + exact ⟨rfl, + ⟨hview.addPending_of_completable coordinate candidate hleftCompletable' + hrightCompletable', + hleftValid', hrightValid', hleftCompletable'⟩, + rfl, rfl, rfl, hcache, hrevealed⟩ + · have hright' : ¬DeferredCompletable table right' := by + rwa [← hcompletableIff] + apply relTriple_pure_pure + right + exact ⟨⟨rfl, hleftValid.valuesConsistent.addPending coordinate candidate, + hview.leftStarts.addPending coordinate candidate, hleft'⟩, + ⟨rfl, hrightValid.valuesConsistent.addPending coordinate candidate, + hview.rightStarts.addPending coordinate candidate, hright'⟩⟩ + +theorem finalizationSynchronizedCouples_probe + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (candidate : Digest) : + FinalizationSynchronizedCouples table (probe ⟨coordinate, candidate⟩) + (probe ⟨coordinate, candidate⟩) := by + intro left right fuel leftCache rightCache hcontext hvalues hcache hrevealed + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + unfold probe + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.probeQuery, + runResolvedFromTable_probe_query_bind, runResolvedFromTable_probe_query_bind] + cases fuel with + | zero => + apply relTriple_pure_pure + exact Or.inl ⟨trivial, trivial⟩ + | succ remaining => + by_cases hleftRevealed : coordinate ∈ left.state.revealed + · have hrightRevealed : coordinate ∈ right.state.revealed := by + rw [← hrevealed] + exact hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte, runResolvedFromTable] + apply relTriple_pure_pure + left + exact ⟨⟨rfl, ⟨hview, hleftValid, hrightValid, hleftCompletable⟩, + rfl, rfl, rfl, hcache, hrevealed⟩, hvalues⟩ + · have hrightRevealed : coordinate ∉ right.state.revealed := by + rwa [← hrevealed] + simp only [hleftRevealed, hrightRevealed, ↓reduceIte, runResolvedFromTable] + let left' : DeferredContext := + { left with state := left.state.addPending coordinate candidate } + let right' : DeferredContext := + { right with state := right.state.addPending coordinate candidate } + have hcompletableIff := deferredCompletable_addPending_iff_of_finalizationViewEq hview + coordinate candidate + by_cases hleft' : DeferredCompletable table left' + · have hright' : DeferredCompletable table right' := hcompletableIff.mp hleft' + obtain ⟨leftCompletion, hleftCompletion⟩ := hleft' + obtain ⟨rightCompletion, hrightCompletion⟩ := hright' + have hleftCompletable' : DeferredCompletable table left' := + ⟨leftCompletion, hleftCompletion⟩ + have hrightCompletable' : DeferredCompletable table right' := + ⟨rightCompletion, hrightCompletion⟩ + have hleftValid' : left'.Valid := ⟨ + hleftValid.valuesConsistent.addPending coordinate candidate, by + intro other output hvalue hhit + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + exact hleftCompletion.2.2.1 other (truncateHash output) hhit + (by rw [hleftCompletion.1 other output hvalue])⟩ + have hrightValid' : right'.Valid := ⟨ + hrightValid.valuesConsistent.addPending coordinate candidate, by + intro other output hvalue hhit + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + exact hrightCompletion.2.2.1 other (truncateHash output) hhit + (by rw [hrightCompletion.1 other output hvalue])⟩ + apply relTriple_pure_pure + left + refine ⟨⟨rfl, + ⟨hview.addPending_of_completable coordinate candidate hleftCompletable' + hrightCompletable', + hleftValid', hrightValid', hleftCompletable'⟩, + rfl, rfl, rfl, hcache, hrevealed⟩, ?_⟩ + exact hvalues + · have hright' : ¬DeferredCompletable table right' := by + rwa [← hcompletableIff] + apply relTriple_pure_pure + right + exact ⟨⟨rfl, hleftValid.valuesConsistent.addPending coordinate candidate, + hview.leftStarts.addPending coordinate candidate, hleft'⟩, + ⟨rfl, hrightValid.valuesConsistent.addPending coordinate candidate, + hview.rightStarts.addPending coordinate candidate, hright'⟩⟩ + +theorem FinalizationAdaptiveCouples.bind + {table : OtsSecretIndex → HashOutput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {leftNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + {rightNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : FinalizationAdaptiveCouples table left right) + (hnext : ∀ value, FinalizationAdaptiveCouples table (leftNext value) (rightNext value)) : + FinalizationAdaptiveCouples table (left >>= leftNext) (right >>= rightNext) := by + intro leftContext rightContext fuel leftCache rightCache hcontext hcache hrevealed + rw [StateT.run_bind, StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_bind] + apply relTriple_bind + (hleft leftContext rightContext fuel leftCache rightCache hcontext hcache hrevealed) + intro leftResult rightResult hrelation + rcases hrelation with hclean | hdoomed + · cases leftResult with + | none => + cases rightResult with + | none => simp [FinalizationAdaptiveRunEq, FinalizationMaterializedRunEq] + | some rightResult => simp [FinalizationMaterializedRunEq] at hclean + | some leftResult => + cases rightResult with + | none => simp [FinalizationMaterializedRunEq] at hclean + | some rightResult => + rcases leftResult with ⟨leftContext, leftFuel, leftValue, leftTable⟩ + rcases rightResult with ⟨rightContext, rightFuel, rightValue, rightTable⟩ + rcases leftValue with ⟨leftOutput, leftCache⟩ + rcases rightValue with ⟨rightOutput, rightCache⟩ + simp only [FinalizationMaterializedRunEq] at hclean + rcases hclean with + ⟨houtput, hcontext, hfuel, hleftTable, hrightTable, hcache, hrevealed⟩ + subst rightOutput + subst rightFuel + subst leftTable + subst rightTable + exact hnext leftOutput leftContext rightContext leftFuel leftCache rightCache + hcontext hcache hrevealed + · cases leftResult with + | none => + cases rightResult with + | none => simp [FinalizationAdaptiveRunEq, FinalizationDoomedRun] + | some rightResult => + simp only + rw [hdoomed.2.1] + exact relTriple_pure_none_runResolvedFromTable_of_finalizationDoomed table + ((rightNext rightResult.value.1).run rightResult.value.2) + rightResult.context rightResult.remaining hdoomed.2.2 + | some leftResult => + cases rightResult with + | none => + simp only + rw [hdoomed.1.1] + exact relTriple_runResolvedFromTable_pure_none_of_finalizationDoomed table + ((leftNext leftResult.value.1).run leftResult.value.2) + leftResult.context leftResult.remaining hdoomed.1.2 + | some rightResult => + have hleftTable := hdoomed.1.1 + have hrightTable := hdoomed.2.1 + simp only + rw [hleftTable, hrightTable] + exact relTriple_runResolvedFromTable_of_finalizationDoomed table + ((leftNext leftResult.value.1).run leftResult.value.2) + ((rightNext rightResult.value.1).run rightResult.value.2) + leftResult.context rightResult.context leftResult.remaining rightResult.remaining + hdoomed.1.2 hdoomed.2.2 + +theorem FinalizationSynchronizedCouples.bind + {table : OtsSecretIndex → HashOutput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {leftNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + {rightNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : FinalizationSynchronizedCouples table left right) + (hnext : ∀ value, + FinalizationSynchronizedCouples table (leftNext value) (rightNext value)) : + FinalizationSynchronizedCouples table (left >>= leftNext) (right >>= rightNext) := by + intro leftContext rightContext fuel leftCache rightCache hcontext hvalues hcache hrevealed + rw [StateT.run_bind, StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_bind] + apply relTriple_bind + (hleft leftContext rightContext fuel leftCache rightCache hcontext hvalues hcache hrevealed) + intro leftResult rightResult hrelation + rcases hrelation with hclean | hdoomed + · cases leftResult with + | none => + cases rightResult with + | none => simp [FinalizationSynchronizedRunEq, FinalizationMaterializedRunEq, + MaterializedValuesEq] + | some rightResult => simp [FinalizationMaterializedRunEq] at hclean + | some leftResult => + cases rightResult with + | none => simp [FinalizationMaterializedRunEq] at hclean + | some rightResult => + rcases leftResult with ⟨leftContext, leftFuel, leftValue, leftTable⟩ + rcases rightResult with ⟨rightContext, rightFuel, rightValue, rightTable⟩ + rcases leftValue with ⟨leftOutput, leftCache⟩ + rcases rightValue with ⟨rightOutput, rightCache⟩ + simp only [FinalizationMaterializedRunEq, MaterializedValuesEq] at hclean + rcases hclean.1 with + ⟨houtput, hcontext, hfuel, hleftTable, hrightTable, hcache, hrevealed⟩ + subst rightOutput + subst rightFuel + subst leftTable + subst rightTable + exact hnext leftOutput leftContext rightContext leftFuel leftCache rightCache + hcontext hclean.2 hcache hrevealed + · cases leftResult with + | none => + cases rightResult with + | none => simp [FinalizationSynchronizedRunEq, FinalizationDoomedRun] + | some rightResult => + simp only + rw [hdoomed.2.1] + exact relTriple_pure_none_runResolvedFromTable_of_finalizationDoomed_synchronized + table ((rightNext rightResult.value.1).run rightResult.value.2) + rightResult.context rightResult.remaining hdoomed.2.2 + | some leftResult => + cases rightResult with + | none => + simp only + rw [hdoomed.1.1] + exact relTriple_runResolvedFromTable_pure_none_of_finalizationDoomed_synchronized + table ((leftNext leftResult.value.1).run leftResult.value.2) + leftResult.context leftResult.remaining hdoomed.1.2 + | some rightResult => + have hleftTable := hdoomed.1.1 + have hrightTable := hdoomed.2.1 + simp only + rw [hleftTable, hrightTable] + exact relTriple_runResolvedFromTable_of_finalizationDoomed_synchronized table + ((leftNext leftResult.value.1).run leftResult.value.2) + ((rightNext rightResult.value.1).run rightResult.value.2) + leftResult.context rightResult.context leftResult.remaining rightResult.remaining + hdoomed.1.2 hdoomed.2.2 + +theorem finalizationSynchronizedCouples_splitUniformImpl + (table : OtsSecretIndex → HashOutput) (n : Nat) : + FinalizationSynchronizedCouples table (splitUniformImpl n) (splitUniformImpl n) := by + intro left right fuel leftCache rightCache hcontext hvalues hcache hrevealed + unfold splitUniformImpl + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.uniformQuery, + runResolvedFromTable_uniform_query_bind, + runResolvedFromTable_uniform_query_bind] + apply relTriple_bind (relTriple_refl + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))) + intro leftOutput rightOutput houtput + subst rightOutput + apply relTriple_pure_pure + left + exact ⟨⟨rfl, hcontext, rfl, rfl, rfl, hcache, hrevealed⟩, hvalues⟩ + +theorem finalizationSynchronizedCouples_ordinaryRomImpl + (table : OtsSecretIndex → HashOutput) (query : OracleWorld.Domain) : + FinalizationSynchronizedCouples table (ordinaryRomImpl query) + (ordinaryRomImpl query) := by + cases query with + | inl n => exact finalizationSynchronizedCouples_splitUniformImpl table n + | inr input => exact finalizationSynchronizedCouples_ordinaryHashImpl table input + +theorem finalizationSynchronizedCouples_simulateQ + {table : OtsSecretIndex → HashOutput} {spec : OracleSpec ι} + (leftImpl rightImpl : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))) + (hquery : ∀ query, + FinalizationSynchronizedCouples table (leftImpl query) (rightImpl query)) + (computation : OracleComp spec α) : + FinalizationSynchronizedCouples table + (simulateQ leftImpl computation) (simulateQ rightImpl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp only [simulateQ_pure] + exact finalizationSynchronizedCouples_pure table value + | query_bind query next ih => + rw [simulateQ_query_bind, simulateQ_query_bind] + exact (hquery query).bind fun output => ih output + +theorem finalizationSynchronizedCouples_peekPositionValues + (table : OtsSecretIndex → HashOutput) : ∀ positions, + FinalizationSynchronizedCouples table (peekPositionValues positions) + (peekPositionValues positions) + | [] => finalizationSynchronizedCouples_pure table (some []) + | position :: remaining => by + rw [peekPositionValues] + apply (finalizationSynchronizedCouples_peekCoordinate table (.position position)).bind + intro value + cases value with + | none => exact finalizationSynchronizedCouples_pure table none + | some value => + apply (finalizationSynchronizedCouples_peekPositionValues table remaining).bind + intro values + cases values with + | none => exact finalizationSynchronizedCouples_pure table none + | some values => + exact finalizationSynchronizedCouples_pure table (some (value :: values)) + +theorem finalizationSynchronizedCouples_peekTableInput + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) : ∀ coordinate, + FinalizationSynchronizedCouples table (peekTableInput parameter coordinate) + (peekTableInput parameter coordinate) + | .chainStart _ _ _ _ => finalizationSynchronizedCouples_pure table none + | .position (.chain lay tree leafIdx chainIdx step) => by + simp only [peekTableInput] + by_cases hstep : step.val = 0 + · rw [if_pos hstep] + apply (finalizationSynchronizedCouples_peekCoordinate table + (.chainStart lay tree leafIdx chainIdx)).bind + intro value + cases value with + | none => exact finalizationSynchronizedCouples_pure table none + | some value => + simp only + exact finalizationSynchronizedCouples_pure table + (some (tweakableHashInput parameter + (Position.chain lay tree leafIdx chainIdx step).domain (digestBytes value))) + · rw [if_neg hstep] + apply (finalizationSynchronizedCouples_peekPositionValues table + (Position.chain lay tree leafIdx chainIdx step).children).bind + intro values + cases values with + | none => + simp only + exact finalizationSynchronizedCouples_pure table none + | some values => + simp only + exact finalizationSynchronizedCouples_pure table + (some (tweakableHashInput parameter + (Position.chain lay tree leafIdx chainIdx step).domain + (values.flatMap digestBytes))) + | .position (.leaf lay tree leafIdx) => by + unfold peekTableInput + apply (finalizationSynchronizedCouples_peekPositionValues table + (Position.leaf lay tree leafIdx).children).bind + intro values + cases values with + | none => + simp only + exact finalizationSynchronizedCouples_pure table none + | some values => + simp only + exact finalizationSynchronizedCouples_pure table + (some (tweakableHashInput parameter (Position.leaf lay tree leafIdx).domain + (values.flatMap digestBytes))) + | .position (.node lay tree level nodeIdx) => by + unfold peekTableInput + apply (finalizationSynchronizedCouples_peekPositionValues table + (Position.node lay tree level nodeIdx).children).bind + intro values + cases values with + | none => + simp only + exact finalizationSynchronizedCouples_pure table none + | some values => + simp only + exact finalizationSynchronizedCouples_pure table + (some (tweakableHashInput parameter (Position.node lay tree level nodeIdx).domain + (values.flatMap digestBytes))) + | .position (.ftsLeaf index tree leafIdx) => by + unfold peekTableInput + apply (finalizationSynchronizedCouples_peekPositionValues table + (Position.ftsLeaf index tree leafIdx).children).bind + intro values + cases values with + | none => + simp only + exact finalizationSynchronizedCouples_pure table none + | some values => + simp only + exact finalizationSynchronizedCouples_pure table + (some (tweakableHashInput parameter (Position.ftsLeaf index tree leafIdx).domain + (values.flatMap digestBytes))) + | .position (.ftsNode index tree level nodeIdx) => by + unfold peekTableInput + apply (finalizationSynchronizedCouples_peekPositionValues table + (Position.ftsNode index tree level nodeIdx).children).bind + intro values + cases values with + | none => + simp only + exact finalizationSynchronizedCouples_pure table none + | some values => + simp only + exact finalizationSynchronizedCouples_pure table + (some (tweakableHashInput parameter (Position.ftsNode index tree level nodeIdx).domain + (values.flatMap digestBytes))) + | .position (.ftsRoots index) => by + unfold peekTableInput + apply (finalizationSynchronizedCouples_peekPositionValues table + (Position.ftsRoots index).children).bind + intro values + cases values with + | none => + simp only + exact finalizationSynchronizedCouples_pure table none + | some values => + simp only + exact finalizationSynchronizedCouples_pure table + (some (tweakableHashInput parameter (Position.ftsRoots index).domain + (values.flatMap digestBytes))) + +theorem finalizationSynchronizedCouples_cacheOrdinary + (table : OtsSecretIndex → HashOutput) (input : HashInput) (output : HashOutput) : + FinalizationSynchronizedCouples table + (modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output)) + (modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output)) := by + intro left right fuel leftCache rightCache hcontext hvalues hcache hrevealed + simp only [StateT.run_modify, runResolvedFromTable] + apply relTriple_pure_pure + left + refine ⟨⟨rfl, hcontext, rfl, rfl, rfl, ?_, hrevealed⟩, hvalues⟩ + rw [ordinaryQueryCache_update, ordinaryQueryCache_update, hcache] + +theorem finalizationSynchronizedCouples_resolveKnownInput + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (position : Position) (input : HashInput) : + FinalizationSynchronizedCouples table + (resolveKnownInput parameter (.position position) input) + (resolveKnownInput parameter (.position position) input) := by + unfold resolveKnownInput + apply (finalizationSynchronizedCouples_peekTableInput table parameter + (.position position)).bind + intro knownInput + cases knownInput with + | none => exact finalizationSynchronizedCouples_splitHashQuery_ordinary table input + | some knownInput => + simp only + by_cases hknown : knownInput = input + · rw [if_pos hknown] + apply (finalizationSynchronizedCouples_revealPositionOutput table position).bind + intro output + apply (finalizationSynchronizedCouples_publishCoordinate table + (.position position)).bind + intro _ + apply (finalizationSynchronizedCouples_cacheOrdinary table input output).bind + intro _ + exact finalizationSynchronizedCouples_pure table output + · rw [if_neg hknown] + exact finalizationSynchronizedCouples_splitHashQuery_ordinary table input + +theorem finalizationSynchronizedCouples_resolveKnownInputCoordinate + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (coordinate : Coordinate) (input : HashInput) : + FinalizationSynchronizedCouples table + (resolveKnownInput parameter coordinate input) + (resolveKnownInput parameter coordinate input) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + unfold resolveKnownInput + simp only [peekTableInput, pure_bind] + exact finalizationSynchronizedCouples_splitHashQuery_ordinary table input + | position position => + exact finalizationSynchronizedCouples_resolveKnownInput table parameter position input + +theorem finalizationSynchronizedCouples_probeFirstMissingInputCoordinate + (table : OtsSecretIndex → HashOutput) (input : HashInput) : + ∀ slot coordinates, + FinalizationSynchronizedCouples table + (probeFirstMissingInputCoordinate input slot coordinates) + (probeFirstMissingInputCoordinate input slot coordinates) + | _, [] => finalizationSynchronizedCouples_pure table () + | slot, coordinate :: remaining => by + rw [probeFirstMissingInputCoordinate] + apply (finalizationSynchronizedCouples_peekCoordinate table coordinate).bind + intro value + cases value with + | none => + exact finalizationSynchronizedCouples_probe table coordinate + (slotDigest slot input) + | some _ => + exact finalizationSynchronizedCouples_probeFirstMissingInputCoordinate table input + (slot + 1) remaining + +theorem finalizationSynchronizedCouples_prepareLeafInputProbe + (table : OtsSecretIndex → HashOutput) (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + FinalizationSynchronizedCouples table + (prepareLeafInputProbe input candidate lay tree leafIdx) + (prepareLeafInputProbe input candidate lay tree leafIdx) := by + unfold prepareLeafInputProbe + apply (finalizationSynchronizedCouples_peekCoordinate table candidate.coordinate).bind + intro value + cases value with + | none => + exact finalizationSynchronizedCouples_probe table candidate.coordinate + candidate.candidate + | some _ => + exact finalizationSynchronizedCouples_probeFirstMissingInputCoordinate table input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + +theorem finalizationSynchronizedCouples_probingHashQuery + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (input : HashInput) : + FinalizationSynchronizedCouples table (probingHashQuery parameter input) + (probingHashQuery parameter input) := by + unfold probingHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases hposition : decodePosition? parameter input with + | none => + apply (finalizationSynchronizedCouples_probe table candidate.coordinate + candidate.candidate).bind + intro _ + exact finalizationSynchronizedCouples_resolveKnownInputCoordinate table parameter + candidate.outputCoordinate input + | some position => + cases position with + | leaf lay tree leafIdx => + apply (finalizationSynchronizedCouples_prepareLeafInputProbe table input candidate + lay tree leafIdx).bind + intro _ + exact finalizationSynchronizedCouples_resolveKnownInputCoordinate table parameter + candidate.outputCoordinate input + | chain lay tree leafIdx chainIdx step => + apply (finalizationSynchronizedCouples_probe table candidate.coordinate + candidate.candidate).bind + intro _ + exact finalizationSynchronizedCouples_resolveKnownInputCoordinate table parameter + candidate.outputCoordinate input + | node lay tree level nodeIdx => + apply (finalizationSynchronizedCouples_probe table candidate.coordinate + candidate.candidate).bind + intro _ + exact finalizationSynchronizedCouples_resolveKnownInputCoordinate table parameter + candidate.outputCoordinate input + | ftsLeaf index tree leafIdx => + apply (finalizationSynchronizedCouples_probe table candidate.coordinate + candidate.candidate).bind + intro _ + exact finalizationSynchronizedCouples_resolveKnownInputCoordinate table parameter + candidate.outputCoordinate input + | ftsNode index tree level nodeIdx => + apply (finalizationSynchronizedCouples_probe table candidate.coordinate + candidate.candidate).bind + intro _ + exact finalizationSynchronizedCouples_resolveKnownInputCoordinate table parameter + candidate.outputCoordinate input + | ftsRoots index => + apply (finalizationSynchronizedCouples_probe table candidate.coordinate + candidate.candidate).bind + intro _ + exact finalizationSynchronizedCouples_resolveKnownInputCoordinate table parameter + candidate.outputCoordinate input + | none => + cases hposition : decodePosition? parameter input with + | none => + exact finalizationSynchronizedCouples_splitHashQuery_ordinary table input + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + exact finalizationSynchronizedCouples_resolveKnownInput table parameter + (.chain lay tree leafIdx chainIdx step) input + | leaf lay tree leafIdx => + exact finalizationSynchronizedCouples_resolveKnownInput table parameter + (.leaf lay tree leafIdx) input + | node lay tree level nodeIdx => + apply (finalizationSynchronizedCouples_probeFirstMissingInputCoordinate table input + 0 ((Position.node lay tree level nodeIdx).children.map + Coordinate.position)).bind + intro _ + exact finalizationSynchronizedCouples_resolveKnownInput table parameter + (.node lay tree level nodeIdx) input + | ftsLeaf index tree leafIdx => + exact finalizationSynchronizedCouples_splitHashQuery_ordinary table input + | ftsNode index tree level nodeIdx => + exact finalizationSynchronizedCouples_splitHashQuery_ordinary table input + | ftsRoots index => + exact finalizationSynchronizedCouples_splitHashQuery_ordinary table input + +theorem finalizationSynchronizedCouples_probingRomImpl + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (query : OracleWorld.Domain) : + FinalizationSynchronizedCouples table (probingRomImpl parameter query) + (probingRomImpl parameter query) := by + cases query with + | inl n => exact finalizationSynchronizedCouples_splitUniformImpl table n + | inr input => exact finalizationSynchronizedCouples_probingHashQuery table parameter input + +theorem finalizationSynchronizedCouples_probingRom + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (computation : OracleComp OracleWorld α) : + FinalizationSynchronizedCouples table + (simulateQ (probingRomImpl parameter) computation) + (simulateQ (probingRomImpl parameter) computation) := + finalizationSynchronizedCouples_simulateQ (probingRomImpl parameter) + (probingRomImpl parameter) + (finalizationSynchronizedCouples_probingRomImpl table parameter) computation + +theorem finalizationAdaptiveCouples_pure + (table : OtsSecretIndex → HashOutput) (value : α) : + FinalizationAdaptiveCouples table + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := + (finalizationMaterializedCouples_pure table value).toAdaptive + +theorem finalizationAdaptiveCouples_simulateQ + {table : OtsSecretIndex → HashOutput} {spec : OracleSpec ι} + (leftImpl rightImpl : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))) + (hquery : ∀ query, + FinalizationAdaptiveCouples table (leftImpl query) (rightImpl query)) + (computation : OracleComp spec α) : + FinalizationAdaptiveCouples table + (simulateQ leftImpl computation) (simulateQ rightImpl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp only [simulateQ_pure] + exact finalizationAdaptiveCouples_pure table value + | query_bind query next ih => + rw [simulateQ_query_bind, simulateQ_query_bind] + exact (hquery query).bind fun output => ih output + +theorem finalizationAdaptiveCouples_ordinaryRomImpl + (table : OtsSecretIndex → HashOutput) (query : OracleWorld.Domain) : + FinalizationAdaptiveCouples table (ordinaryRomImpl query) (ordinaryRomImpl query) := + (finalizationMaterializedCouples_ordinaryRomImpl table query).toAdaptive + +theorem finalizationAdaptiveCouples_ensureCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + FinalizationAdaptiveCouples table (ensureCoordinate coordinate) + (ensureCoordinate coordinate) := + (finalizationMaterializedCouples_ensureCoordinate table coordinate).toAdaptive + +theorem finalizationAdaptiveCouples_revealCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + FinalizationAdaptiveCouples table (revealCoordinate coordinate) + (revealCoordinate coordinate) := + (finalizationMaterializedCouples_revealCoordinate table coordinate).toAdaptive + +theorem finalizationAdaptiveCouples_publishCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + FinalizationAdaptiveCouples table (publishCoordinate coordinate) + (publishCoordinate coordinate) := + (finalizationMaterializedCouples_publishCoordinate table coordinate).toAdaptive + +theorem relTriple_finishResolvedRunIsNone_of_finalizationAdaptiveRunEq + (table : OtsSecretIndex → HashOutput) + (left right : Option (ResolvedRunResult (α × SplitHashCache))) + (hrelation : FinalizationAdaptiveRunEq table left right) : + RelTriple (finishResolvedRunIsNone left) (finishResolvedRunIsNone right) + (EqRel Bool) := by + rcases hrelation with hclean | hdoomed + · exact relTriple_finishResolvedRunIsNone_of_finalizationMaterializedRunEq table left right + hclean + · cases left with + | none => + cases right with + | none => exact relTriple_pure_pure rfl + | some right => + have hrightTable := hdoomed.2.1 + have hrightDoomed : + ¬DeferredCompletable right.table right.context := by + rw [hrightTable] + exact hdoomed.2.2.2.2 + rw [finishResolvedRunIsNone, finishResolvedRunIsNone, + finishResolvedRun_of_not_deferredCompletable right hrightDoomed] + simp [finishResolvedRun] + rfl + | some left => + have hleftTable := hdoomed.1.1 + have hleftDoomed : ¬DeferredCompletable left.table left.context := by + rw [hleftTable] + exact hdoomed.1.2.2.2 + cases right with + | none => + rw [finishResolvedRunIsNone, finishResolvedRunIsNone, + finishResolvedRun_of_not_deferredCompletable left hleftDoomed] + simp [finishResolvedRun] + rfl + | some right => + have hrightTable := hdoomed.2.1 + have hrightDoomed : + ¬DeferredCompletable right.table right.context := by + rw [hrightTable] + exact hdoomed.2.2.2.2 + rw [finishResolvedRunIsNone, finishResolvedRunIsNone, + finishResolvedRun_of_not_deferredCompletable left hleftDoomed, + finishResolvedRun_of_not_deferredCompletable right hrightDoomed] + exact relTriple_pure_pure rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveObserver.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveObserver.lean new file mode 100644 index 00000000..0b54e313 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveObserver.lean @@ -0,0 +1,1076 @@ +import SphincsSecurity.Proof.OtsProbeResolvedPrivateSigner + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp + +attribute [local irreducible] maskedSignLayer + +def ResolvedPreservesCoordinate (coordinate : Coordinate) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ context fuel table cache result, + some result ∈ support + (runResolvedFromTable context fuel table (computation.run cache)) → + result.context.state.values coordinate = context.state.values coordinate ∧ + (coordinate ∈ result.context.state.revealed ↔ + coordinate ∈ context.state.revealed) + +theorem ResolvedPreservesCoordinate.bind + {coordinate : Coordinate} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : ResolvedPreservesCoordinate coordinate left) + (hnext : ∀ value, ResolvedPreservesCoordinate coordinate (next value)) : + ResolvedPreservesCoordinate coordinate (left >>= next) := by + intro context fuel table cache result hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨leftOption, hleftSupport, hrest⟩ := hresult + cases leftOption with + | none => simp at hrest + | some leftResult => + have hmiddle := hleft context fuel table cache leftResult hleftSupport + have hfinal := hnext leftResult.value.1 leftResult.context leftResult.remaining + leftResult.table leftResult.value.2 result hrest + exact ⟨hfinal.1.trans hmiddle.1, hfinal.2.trans hmiddle.2⟩ + +theorem resolvedPreservesCoordinate_pure (coordinate : Coordinate) (value : α) : + ResolvedPreservesCoordinate coordinate + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := by + intro context fuel table cache result hresult + simp [runResolvedFromTable] at hresult + subst result + exact ⟨rfl, Iff.rfl⟩ + +theorem ResolvedPreservesPublished.of_preservesCoordinate + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + (hpreserves : ∀ coordinate, + ResolvedPreservesCoordinate coordinate computation) : + ResolvedPreservesPublished computation := by + intro context cache fuel table result hpublished hresult coordinate hrevealed + have hcoordinate := hpreserves coordinate context fuel table cache result hresult + rw [hcoordinate.1] + exact hpublished coordinate (hcoordinate.2.mp hrevealed) + +theorem resolvedPreservesCoordinate_get (coordinate : Coordinate) : + ResolvedPreservesCoordinate coordinate + (get : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) SplitHashCache) := by + intro context fuel table cache result hresult + simp [runResolvedFromTable] at hresult + subst result + exact ⟨rfl, Iff.rfl⟩ + +theorem resolvedPreservesCoordinate_modify (coordinate : Coordinate) + (update : SplitHashCache → SplitHashCache) : + ResolvedPreservesCoordinate coordinate + (modify update : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit) := by + intro context fuel table cache result hresult + simp [StateT.run_modify, runResolvedFromTable] at hresult + subst result + exact ⟨rfl, Iff.rfl⟩ + +theorem resolvedPreservesCoordinate_splitHashQuery + (coordinate : Coordinate) (key : SplitHashKey) : + ResolvedPreservesCoordinate coordinate (splitHashQuery key) := by + intro context fuel table cache result hresult + rw [splitHashQuery_run_eq] at hresult + cases hlookup : cache key with + | some output => + rw [hlookup] at hresult + simp [runResolvedFromTable] at hresult + subst result + exact ⟨rfl, Iff.rfl⟩ + | none => + rw [hlookup] at hresult + dsimp only at hresult + change some result ∈ support (runResolvedFromTable context fuel table + (LazyRevealProbe.hashOutputQuery >>= fun output => + pure (output, Function.update cache key (some output)))) at hresult + rw [LazyRevealProbe.hashOutputQuery] at hresult + rw [runResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hdone⟩ := hresult + simp [runResolvedFromTable] at hdone + subst result + exact ⟨rfl, Iff.rfl⟩ + +theorem resolvedPreservesCoordinate_ensure + (coordinate ensured : Coordinate) : + ResolvedPreservesCoordinate coordinate (ensureCoordinate ensured) := by + intro context fuel table cache result hresult + change some result ∈ support (runResolvedFromTable context fuel table + (LazyRevealProbe.ensureQuery ensured >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.ensureQuery] at hresult + rw [runResolvedFromTable_ensure_query_bind] at hresult + simp [runResolvedFromTable, LazyRevealProbe.State.ensure] at hresult + subst result + exact ⟨rfl, Iff.rfl⟩ + +theorem resolvedPreservesCoordinate_probe + (coordinate : Coordinate) (candidate : Probe) : + ResolvedPreservesCoordinate coordinate (probe candidate) := by + intro context fuel table cache result hresult + change some result ∈ support (runResolvedFromTable context fuel table + (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate >>= fun output => + pure (output, cache))) at hresult + rw [LazyRevealProbe.probeQuery] at hresult + rw [runResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] at hresult + simp [runResolvedFromTable] at hresult + subst result + exact ⟨rfl, Iff.rfl⟩ + · simp only [hrevealed, ↓reduceIte] at hresult + change some result ∈ support (runResolvedFromTable + { context with state := + (context.state.addPending candidate.coordinate candidate.candidate) } + remaining table (pure ((), cache))) at hresult + simp [runResolvedFromTable, LazyRevealProbe.State.addPending] at hresult + subst result + exact ⟨rfl, Iff.rfl⟩ + +theorem resolvedPreservesCoordinate_peekCoordinate + (coordinate observed : Coordinate) : + ResolvedPreservesCoordinate coordinate (peekCoordinate observed) := by + intro context fuel table cache result hresult + change some result ∈ support (runResolvedFromTable context fuel table + (LazyRevealProbe.peekQuery observed >>= fun output => + pure (truncateHash <$> output, cache))) at hresult + rw [LazyRevealProbe.peekQuery, runResolvedFromTable_peek_query_bind] at hresult + simp [runResolvedFromTable] at hresult + subst result + exact ⟨rfl, Iff.rfl⟩ + +theorem resolvedPreservesCoordinate_peekPositionValues + (coordinate : Coordinate) : ∀ positions, + ResolvedPreservesCoordinate coordinate (peekPositionValues positions) + | [] => resolvedPreservesCoordinate_pure coordinate (some []) + | position :: remaining => by + rw [peekPositionValues] + exact (resolvedPreservesCoordinate_peekCoordinate coordinate (.position position)).bind + fun value => match value with + | none => resolvedPreservesCoordinate_pure coordinate none + | some value => + (resolvedPreservesCoordinate_peekPositionValues coordinate remaining).bind + fun values => match values with + | none => resolvedPreservesCoordinate_pure coordinate none + | some values => resolvedPreservesCoordinate_pure coordinate + (some (value :: values)) + +theorem resolvedPreservesCoordinate_peekTableInput + (parameter : PublicParameter) (coordinate : Coordinate) : ∀ target, + ResolvedPreservesCoordinate coordinate (peekTableInput parameter target) + | .chainStart _ _ _ _ => resolvedPreservesCoordinate_pure coordinate none + | .position position => by + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput] + by_cases hstep : step.val = 0 + · rw [if_pos hstep] + exact (resolvedPreservesCoordinate_peekCoordinate coordinate + (.chainStart lay tree leafIdx chainIdx)).bind fun value => match value with + | none => resolvedPreservesCoordinate_pure coordinate none + | some value => resolvedPreservesCoordinate_pure coordinate + (some (tweakableHashInput parameter + (Position.chain lay tree leafIdx chainIdx step).domain + (digestBytes value))) + · rw [if_neg hstep] + exact (resolvedPreservesCoordinate_peekPositionValues coordinate + (Position.chain lay tree leafIdx chainIdx step).children).bind + fun values => match values with + | none => resolvedPreservesCoordinate_pure coordinate none + | some values => resolvedPreservesCoordinate_pure coordinate + (some (tweakableHashInput parameter + (Position.chain lay tree leafIdx chainIdx step).domain + (values.flatMap digestBytes))) + | leaf lay tree leafIdx => + simp only [peekTableInput] + exact (resolvedPreservesCoordinate_peekPositionValues coordinate + (Position.leaf lay tree leafIdx).children).bind fun values => match values with + | none => resolvedPreservesCoordinate_pure coordinate none + | some values => resolvedPreservesCoordinate_pure coordinate + (some (tweakableHashInput parameter (Position.leaf lay tree leafIdx).domain + (values.flatMap digestBytes))) + | node lay tree level nodeIdx => + simp only [peekTableInput] + exact (resolvedPreservesCoordinate_peekPositionValues coordinate + (Position.node lay tree level nodeIdx).children).bind fun values => match values with + | none => resolvedPreservesCoordinate_pure coordinate none + | some values => resolvedPreservesCoordinate_pure coordinate + (some (tweakableHashInput parameter + (Position.node lay tree level nodeIdx).domain + (values.flatMap digestBytes))) + | ftsLeaf index tree leafIdx => + simp only [peekTableInput] + exact (resolvedPreservesCoordinate_peekPositionValues coordinate + (Position.ftsLeaf index tree leafIdx).children).bind fun values => match values with + | none => resolvedPreservesCoordinate_pure coordinate none + | some values => resolvedPreservesCoordinate_pure coordinate + (some (tweakableHashInput parameter (Position.ftsLeaf index tree leafIdx).domain + (values.flatMap digestBytes))) + | ftsNode index tree level nodeIdx => + simp only [peekTableInput] + exact (resolvedPreservesCoordinate_peekPositionValues coordinate + (Position.ftsNode index tree level nodeIdx).children).bind fun values => match values with + | none => resolvedPreservesCoordinate_pure coordinate none + | some values => resolvedPreservesCoordinate_pure coordinate + (some (tweakableHashInput parameter + (Position.ftsNode index tree level nodeIdx).domain + (values.flatMap digestBytes))) + | ftsRoots index => + simp only [peekTableInput] + exact (resolvedPreservesCoordinate_peekPositionValues coordinate + (Position.ftsRoots index).children).bind fun values => match values with + | none => resolvedPreservesCoordinate_pure coordinate none + | some values => resolvedPreservesCoordinate_pure coordinate + (some (tweakableHashInput parameter (Position.ftsRoots index).domain + (values.flatMap digestBytes))) + +theorem resolvedPreservesCoordinate_publish_of_ne + (coordinate published : Coordinate) (hne : coordinate ≠ published) : + ResolvedPreservesCoordinate coordinate (publishCoordinate published) := by + intro context fuel table cache result hresult + change some result ∈ support (runResolvedFromTable context fuel table + (LazyRevealProbe.publishQuery published >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.publishQuery, runResolvedFromTable_publish_query_bind] at hresult + simp [runResolvedFromTable] at hresult + subst result + simp [LazyRevealProbe.State.publish, hne] + +theorem resolvedPreservesCoordinate_revealCoordinateOutput_of_ne + (coordinate revealed : Coordinate) (hne : coordinate ≠ revealed) : + ResolvedPreservesCoordinate coordinate (revealCoordinateOutput revealed) := by + intro context fuel table cache result hresult + rw [runResolvedFromTable_revealCoordinateOutput] at hresult + cases revealed with + | chainStart lay tree leafIdx chainIdx => + cases hresolve : resolveDeferredChainStart table + ⟨lay, tree, leafIdx, chainIdx⟩ context with + | none => simp [hresolve] at hresult + | some resolved => + simp [hresolve] at hresult + subst result + simp [LazyRevealProbe.State.materialize, Function.update, hne] + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, _hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + simp at hrest + subst result + simp [LazyRevealProbe.State.materialize, Function.update, hne] + +theorem resolvedPreservesPublishedValues_revealCoordinateOutput + (coordinate : Coordinate) : + ResolvedPreservesPublished (revealCoordinateOutput coordinate) := by + intro context cache fuel table result hpublished hresult + rw [runResolvedFromTable_revealCoordinateOutput] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + cases hresolve : resolveDeferredChainStart table + ⟨lay, tree, leafIdx, chainIdx⟩ context with + | none => simp [hresolve] at hresult + | some resolved => + simp [hresolve] at hresult + subst result + intro other hother + by_cases heq : other = .chainStart lay tree leafIdx chainIdx + · subst other + simp [LazyRevealProbe.State.materialize] + · have hvalue := hpublished other (by + simpa [LazyRevealProbe.State.materialize] using hother) + simpa [LazyRevealProbe.State.materialize, Function.update, heq] using hvalue + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, _hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + simp at hrest + subst result + intro other hother + by_cases heq : other = .position position + · subst other + simp [LazyRevealProbe.State.materialize] + · have hvalue := hpublished other (by + simpa [LazyRevealProbe.State.materialize] using hother) + simpa [LazyRevealProbe.State.materialize, Function.update, heq] using hvalue + +theorem resolvedPreservesPublishedValues_revealCoordinateOutput_publish + (coordinate : Coordinate) : + ResolvedPreservesPublished (do + let output ← revealCoordinateOutput coordinate + publishCoordinate coordinate + pure output) := by + intro context cache fuel table result hpublished hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨revealOption, hreveal, hrest⟩ := hresult + cases revealOption with + | none => simp at hrest + | some revealResult => + simp only at hrest + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hrest + obtain ⟨publishOption, hpublish, hreturn⟩ := hrest + cases publishOption with + | none => simp at hreturn + | some publishResult => + simp [runResolvedFromTable] at hreturn + subst result + have hpublishedReveal := + resolvedPreservesPublishedValues_revealCoordinateOutput coordinate context cache fuel + table revealResult hpublished hreveal + change some publishResult ∈ support (runResolvedFromTable revealResult.context + revealResult.remaining revealResult.table + ((publishCoordinate coordinate).run revealResult.value.2)) at hpublish + change some publishResult ∈ support (runResolvedFromTable revealResult.context + revealResult.remaining revealResult.table + (LazyRevealProbe.publishQuery coordinate >>= fun output => + pure (output, revealResult.value.2))) at hpublish + rw [LazyRevealProbe.publishQuery, + runResolvedFromTable_publish_query_bind] at hpublish + simp [runResolvedFromTable] at hpublish + subst publishResult + intro other hother + by_cases heq : other = coordinate + · subst other + have hvalue := value_of_mem_runResolvedFromTable_revealCoordinateOutput context fuel + table coordinate cache revealResult hreveal + simp [LazyRevealProbe.State.publish, hvalue] + · have hvalue := hpublishedReveal other (by + simpa [LazyRevealProbe.State.publish, heq] using hother) + simpa [LazyRevealProbe.State.publish] using hvalue + +theorem resolvedPreservesPublishedValues_resolveKnownInput + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) : + ResolvedPreservesPublished (resolveKnownInput parameter coordinate input) := by + unfold resolveKnownInput + apply (ResolvedPreservesPublished.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_peekTableInput parameter other coordinate).bind + intro known + cases known with + | none => + exact ResolvedPreservesPublished.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_splitHashQuery other (.ordinary input) + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + have hpreserves := + (resolvedPreservesPublishedValues_revealCoordinateOutput_publish coordinate).bind + fun output => + (ResolvedPreservesPublished.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_modify other fun cache => + Function.update cache (.ordinary input) (some output)).bind fun _ => + ResolvedPreservesPublished.pure output + simpa only [bind_assoc, pure_bind] using hpreserves + · simp only [heq, ↓reduceIte] + exact ResolvedPreservesPublished.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_splitHashQuery other (.ordinary input) + +theorem resolvedPreservesPublishedValues_probeFirstMissingInputCoordinate + (input : HashInput) : ∀ slot coordinates, + ResolvedPreservesPublished + (probeFirstMissingInputCoordinate input slot coordinates) + | _, [] => ResolvedPreservesPublished.pure () + | slot, coordinate :: remaining => by + rw [probeFirstMissingInputCoordinate] + exact (ResolvedPreservesPublished.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_peekCoordinate other coordinate).bind fun value => + match value with + | none => ResolvedPreservesPublished.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_probe other + ⟨coordinate, slotDigest slot input⟩ + | some _ => resolvedPreservesPublishedValues_probeFirstMissingInputCoordinate input + (slot + 1) remaining + +theorem resolvedPreservesPublishedValues_prepareLeafInputProbe + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ResolvedPreservesPublished + (prepareLeafInputProbe input candidate lay tree leafIdx) := by + unfold prepareLeafInputProbe + apply (ResolvedPreservesPublished.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_peekCoordinate other candidate.coordinate).bind + intro value + cases value with + | none => + exact ResolvedPreservesPublished.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_probe other candidate + | some output => + exact resolvedPreservesPublishedValues_probeFirstMissingInputCoordinate input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + +theorem resolvedPreservesPublishedValues_probingHashQuery + (parameter : PublicParameter) (input : HashInput) : + ResolvedPreservesPublished (probingHashQuery parameter input) := by + unfold probingHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases decodePosition? parameter input with + | some position => + cases position with + | leaf lay tree leafIdx => + exact (resolvedPreservesPublishedValues_prepareLeafInputProbe input candidate lay + tree leafIdx).bind fun _ => + resolvedPreservesPublishedValues_resolveKnownInput parameter + candidate.outputCoordinate input + | chain | node | ftsLeaf | ftsNode | ftsRoots => + exact (ResolvedPreservesPublished.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_probe other candidate).bind fun _ => + resolvedPreservesPublishedValues_resolveKnownInput parameter + candidate.outputCoordinate input + | none => + exact (ResolvedPreservesPublished.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_probe other candidate).bind fun _ => + resolvedPreservesPublishedValues_resolveKnownInput parameter + candidate.outputCoordinate input + | none => + cases hposition : decodePosition? parameter input with + | none => + exact ResolvedPreservesPublished.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_splitHashQuery other (.ordinary input) + | some position => + cases position with + | chain | leaf => + exact resolvedPreservesPublishedValues_resolveKnownInput parameter _ input + | node lay tree level nodeIdx => + exact (resolvedPreservesPublishedValues_probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map + Coordinate.position)).bind fun _ => + resolvedPreservesPublishedValues_resolveKnownInput parameter _ input + | ftsLeaf | ftsNode | ftsRoots => + exact ResolvedPreservesPublished.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_splitHashQuery other (.ordinary input) + +theorem resolvedPreservesPublishedValues_splitUniformImpl (n : Nat) : + ResolvedPreservesPublished (splitUniformImpl n) := by + intro context cache fuel table result hpublished hresult + change some result ∈ support (runResolvedFromTable context fuel table + (LazyRevealProbe.uniformQuery n >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.uniformQuery, runResolvedFromTable_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hdone⟩ := hresult + simp [runResolvedFromTable] at hdone + subst result + exact hpublished + +def ResolvedPreservesPublishedImpl {spec : OracleSpec ι} + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) : Prop := + ∀ query, ResolvedPreservesPublished (impl query) + +theorem ResolvedPreservesPublishedImpl.simulateQ + {spec : OracleSpec ι} + {impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))} + (himpl : ResolvedPreservesPublishedImpl impl) + (computation : OracleComp spec α) : + ResolvedPreservesPublished (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => exact ResolvedPreservesPublished.pure value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (himpl query).bind ih + +theorem resolvedPreservesPublishedValues_ensureCoordinate + (coordinate : Coordinate) : + ResolvedPreservesPublished (ensureCoordinate coordinate) := + ResolvedPreservesPublished.of_preservesCoordinate fun other => + resolvedPreservesCoordinate_ensure other coordinate + +theorem resolvedPreservesPublishedValuesImpl_ordinaryHashImpl : + ResolvedPreservesPublishedImpl ordinaryHashImpl := + fun input => ResolvedPreservesPublished.of_preservesCoordinate fun coordinate => + resolvedPreservesCoordinate_splitHashQuery coordinate (.ordinary input) + +theorem resolvedPreservesPublishedValues_simulateQ_ordinaryHashImpl + (computation : OracleComp HashSpec α) : + ResolvedPreservesPublished (simulateQ ordinaryHashImpl computation) := + resolvedPreservesPublishedValuesImpl_ordinaryHashImpl.simulateQ computation + +theorem resolvedPreservesPublishedValues_revealCoordinate (coordinate : Coordinate) : + ResolvedPreservesPublished (revealCoordinate coordinate) := by + unfold revealCoordinate + exact (resolvedPreservesPublishedValues_revealCoordinateOutput coordinate).bind fun _ => + ResolvedPreservesPublished.pure _ + +theorem resolvedPreservesPublishedValues_revealPublishedCoordinate + (coordinate : Coordinate) : + ResolvedPreservesPublished (revealPublishedCoordinate coordinate) := by + have hpreserves := + (resolvedPreservesPublishedValues_revealCoordinateOutput_publish coordinate).bind + fun output => ResolvedPreservesPublished.pure (truncateHash output) + simpa only [revealPublishedCoordinate, revealCoordinate, bind_assoc, pure_bind] using hpreserves + +theorem resolvedPreservesPublishedValuesImpl_probingRomImpl + (parameter : PublicParameter) : + ResolvedPreservesPublishedImpl (probingRomImpl parameter) := by + intro query + cases query with + | inl n => exact resolvedPreservesPublishedValues_splitUniformImpl n + | inr input => exact resolvedPreservesPublishedValues_probingHashQuery parameter input + +theorem resolvedPreservesPublishedValues_ensureFullChain + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ResolvedPreservesPublished (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (resolvedPreservesPublished_sequenceFin _ fun step => + resolvedPreservesPublishedValues_ensureCoordinate + (.position (.chain lay tree leafIdx chainIdx step))).bind fun _ => + ResolvedPreservesPublished.pure () + +theorem resolvedPreservesPublishedValues_ensureChainPrefix + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (digit : Digit) : + ResolvedPreservesPublished (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (resolvedPreservesPublished_sequenceFin _ fun step => by + split + · exact resolvedPreservesPublishedValues_ensureCoordinate + (.position (.chain lay tree leafIdx chainIdx step)) + · exact ResolvedPreservesPublished.pure ()).bind fun _ => + ResolvedPreservesPublished.pure () + +theorem resolvedPreservesPublishedValues_ensureOtsLeaf + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ResolvedPreservesPublished (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (resolvedPreservesPublished_sequenceFin _ fun chainIdx => + resolvedPreservesPublishedValues_ensureFullChain lay tree leafIdx chainIdx).bind fun _ => + resolvedPreservesPublishedValues_ensureCoordinate (.position (.leaf lay tree leafIdx)) + +theorem resolvedPreservesPublishedValues_ensureTreeNode + (lay : Layer) (tree : TreeIndex) : ∀ level nodeIdx, + ResolvedPreservesPublished (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => by + rw [ensureTreeNode] + exact resolvedPreservesPublishedValues_ensureOtsLeaf lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (resolvedPreservesPublishedValues_ensureTreeNode lay tree level + (2 * nodeIdx)).bind fun _ => + (resolvedPreservesPublishedValues_ensureTreeNode lay tree level + (2 * nodeIdx + 1)).bind fun _ => by + split + · exact resolvedPreservesPublishedValues_ensureCoordinate _ + · exact ResolvedPreservesPublished.pure () + +theorem resolvedPreservesPublishedValues_maskedTreeNode + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) : + ResolvedPreservesPublished (maskedTreeNode lay tree level nodeIdx) := by + cases level with + | zero => + rw [maskedTreeNode] + exact (resolvedPreservesPublishedValues_ensureTreeNode lay tree 0 nodeIdx).bind fun _ => + resolvedPreservesPublishedValues_revealCoordinate _ + | succ current => + rw [maskedTreeNode] + exact (resolvedPreservesPublishedValues_ensureTreeNode lay tree (current + 1) + nodeIdx).bind fun _ => by + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact resolvedPreservesPublishedValues_revealCoordinate _ + · rw [dif_neg hlevel] + exact ResolvedPreservesPublished.pure 0 + +theorem resolvedPreservesPublishedValues_maskedTreeRoot + (lay : Layer) (tree : TreeIndex) : + ResolvedPreservesPublished (maskedTreeRoot lay tree) := + resolvedPreservesPublishedValues_maskedTreeNode lay tree (layerHeight lay) 0 + +theorem resolvedPreservesPublishedValues_ensureTreePath + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ResolvedPreservesPublished (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (resolvedPreservesPublished_sequenceFin _ fun level => by + split + · exact resolvedPreservesPublishedValues_ensureTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · exact ResolvedPreservesPublished.pure ()).bind fun _ => + ResolvedPreservesPublished.pure () + +theorem resolvedPreservesPublishedValues_maskedLayerMessage + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + ResolvedPreservesPublished (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + split + · exact resolvedPreservesPublishedValues_maskedTreeRoot _ _ + · exact resolvedPreservesPublishedValues_simulateQ_ordinaryHashImpl _ + +theorem resolvedPreservesPublishedValues_maskedOtsSignFrom + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : ∀ attempts counter, + ResolvedPreservesPublished + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, _ => ResolvedPreservesPublished.pure none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + exact (resolvedPreservesPublishedValues_simulateQ_ordinaryHashImpl _).bind fun encoded => + match encoded with + | none => resolvedPreservesPublishedValues_maskedOtsSignFrom parameter lay tree leafIdx + message attempts (counter + 1) + | some encoding => + (resolvedPreservesPublished_sequenceFin _ fun chainIdx => + resolvedPreservesPublishedValues_ensureChainPrefix lay tree leafIdx chainIdx + (encoding chainIdx)).bind fun _ => ResolvedPreservesPublished.pure _ + +theorem resolvedPreservesPublishedValues_maskedOtsSign + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : + ResolvedPreservesPublished + (maskedOtsSign parameter lay tree leafIdx message) := + resolvedPreservesPublishedValues_maskedOtsSignFrom parameter lay tree leafIdx message + encodingAttemptLimit 0 + +theorem resolvedPreservesPublishedValues_maskedSignLayer + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + ResolvedPreservesPublished (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + exact (resolvedPreservesPublishedValues_maskedLayerMessage parameter ftsSecret index lay).bind + fun message => + (resolvedPreservesPublishedValues_maskedOtsSign parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message).bind fun result => + match result with + | none => ResolvedPreservesPublished.pure none + | some _ => + (resolvedPreservesPublishedValues_ensureTreePath lay (treeIndexAt index lay) + (leafIndexAt index lay)).bind fun _ => ResolvedPreservesPublished.pure _ + +theorem resolvedPreservesPublishedValues_revealLayerValues + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + ResolvedPreservesPublished (revealLayerValues index lay encoding) := by + unfold revealLayerValues + exact (resolvedPreservesPublished_sequenceFin _ fun chainIdx => + resolvedPreservesPublishedValues_revealPublishedCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + (encoding chainIdx))).bind fun _ => + (resolvedPreservesPublished_sequenceFin _ fun level => by + split + · cases hlevelValue : level.val with + | zero => exact resolvedPreservesPublishedValues_revealPublishedCoordinate _ + | succ current => + rw [show current + 1 = Nat.succ current by omega] + change ResolvedPreservesPublished + (if hlevel : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hlevel⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0) + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact resolvedPreservesPublishedValues_revealPublishedCoordinate _ + · rw [dif_neg hlevel] + exact ResolvedPreservesPublished.pure 0 + · exact ResolvedPreservesPublished.pure 0).bind fun _ => + ResolvedPreservesPublished.pure _ + +theorem resolvedPreservesPublishedValues_ordinarySignDigestLoop + (secretKey : SecretKey) (attempts : Nat) (message : Message) : + ResolvedPreservesPublished + (simulateQ ordinaryRomImpl (signDigestLoop attempts secretKey message)) := by + induction attempts with + | zero => + rw [signDigestLoop, simulateQ_pure] + exact ResolvedPreservesPublished.pure none + | succ attempts ih => + rw [signDigestLoop, simulateQ_bind] + have hrandomness : ResolvedPreservesPublished + (simulateQ ordinaryRomImpl (liftM sampleRandomness)) := by + rw [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_left] + exact (show ResolvedPreservesPublishedImpl splitUniformImpl from + fun n => resolvedPreservesPublishedValues_splitUniformImpl n).simulateQ + sampleRandomness + exact hrandomness.bind fun randomness => by + rw [simulateQ_bind] + have hattempt : ResolvedPreservesPublished + (simulateQ ordinaryRomImpl + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))))) := by + rw [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_right] + exact resolvedPreservesPublishedValues_simulateQ_ordinaryHashImpl _ + exact hattempt.bind fun attempt => by + cases attempt with + | none => exact ih + | some selected => exact ResolvedPreservesPublished.pure _ + +theorem resolvedPreservesPublishedValues_maskedSignAfterDigest + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + ResolvedPreservesPublished + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest + exact (resolvedPreservesPublishedValues_simulateQ_ordinaryHashImpl _).bind fun _ => + (resolvedPreservesPublished_sequenceFin _ fun lay => + resolvedPreservesPublishedValues_maskedSignLayer parameter ftsSecret index lay).bind + fun layers => match traverseOption layers with + | none => ResolvedPreservesPublished.pure none + | some parts => (resolvedPreservesPublished_sequenceFin _ fun lay => + resolvedPreservesPublishedValues_revealLayerValues index lay (parts lay).2).bind + fun _ => ResolvedPreservesPublished.pure _ + +theorem resolvedPreservesPublishedValues_maskedSign + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + ResolvedPreservesPublished (maskedSign parameter root ftsSecret message) := by + unfold maskedSign + exact (resolvedPreservesPublishedValues_ordinarySignDigestLoop + (⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ : SecretKey) digestAttemptLimit + message).bind fun selected => match selected with + | none => ResolvedPreservesPublished.pure none + | some data => resolvedPreservesPublishedValues_maskedSignAfterDigest parameter ftsSecret + data.1 data.2.1 data.2.2 + +theorem PublishedValues.of_privateStateAgrees + {left right : DeferredContext} (hpublished : PublishedValues right.state) + (hagrees : PrivateStateAgrees left right) : PublishedValues left.state := by + intro coordinate hrevealed + rw [hagrees.1] + exact hpublished coordinate (by simpa [hagrees.2.1] using hrevealed) + +theorem resolvedPreservesPublishedValues_publishChronologicalSignature + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (layers : Layer → Option ChronologicalLayerPart) : + ResolvedPreservesPublished + (publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers) := by + unfold publishChronologicalSignature + cases hparts : traverseOption layers with + | none => exact ResolvedPreservesPublished.pure none + | some parts => + exact (resolvedPreservesPublished_sequenceFin _ fun lay => + resolvedPreservesPublishedValues_revealLayerValues index lay + (parts lay).encoding).bind fun _ => ResolvedPreservesPublished.pure _ + +theorem publishedValues_of_mem_selectDeferredLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (input result : ResolvedRunResult DeferredLayerStore) + (hpublished : PublishedValues input.context.state) + (hresult : some result ∈ support + (selectDeferredLayer parameter table ftsSecret index lay input)) : + PublishedValues result.context.state := by + unfold selectDeferredLayer at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨selectedOption, hselected, hreturn⟩ := hresult + cases selectedOption with + | none => simp at hreturn + | some selected => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hresultEq := Option.some.inj hreturn + subst result + exact resolvedPreservesPublishedValues_maskedSignLayer parameter ftsSecret index lay + input.context input.value.cache input.remaining table selected hpublished hselected + +theorem publishedValues_of_mem_resolveDeferredLayer + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (input result : ResolvedRunResult DeferredLayerStore) + (hpublished : PublishedValues input.context.state) + (hresult : some result ∈ support (resolveDeferredLayer table index lay input)) : + PublishedValues result.context.state := by + unfold resolveDeferredLayer at hresult + cases hselection : input.value.selected lay with + | none => + simp only [hselection, support_pure, Set.mem_singleton_iff] at hresult + have hresultEq := Option.some.inj hresult + subst result + exact hpublished + | some selection => + rcases selection with ⟨counter, encoding⟩ + simp only [hselection, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hreturn⟩ := hresult + cases resolvedOption with + | none => simp at hreturn + | some resolved => + rcases resolved with ⟨finalContext, values⟩ + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hresultEq := Option.some.inj hreturn + subst result + exact hpublished.of_privateStateAgrees + (privateStateAgrees_resolveDeferredLayerValues table index lay encoding input.context + finalContext values hresolved) + +theorem publishedValues_of_mem_runDeferredLayerOperation + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (operation : DeferredLayerOperation) + (input result : ResolvedRunResult DeferredLayerStore) + (hpublished : PublishedValues input.context.state) + (hresult : some result ∈ support + (runDeferredLayerOperation parameter table ftsSecret index operation (some input))) : + PublishedValues result.context.state := by + cases operation with + | select lay => + exact publishedValues_of_mem_selectDeferredLayer parameter table ftsSecret index lay input + result hpublished hresult + | resolve lay => + exact publishedValues_of_mem_resolveDeferredLayer table index lay input result hpublished + hresult + +theorem publishedValues_of_mem_runDeferredLayerSchedule + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) : + ∀ operations (input result : ResolvedRunResult DeferredLayerStore), + PublishedValues input.context.state → + some result ∈ support + (runDeferredLayerSchedule parameter table ftsSecret index operations (some input)) → + PublishedValues result.context.state + | [], input, result, hpublished, hresult => by + simp [runDeferredLayerSchedule] at hresult + subst result + exact hpublished + | operation :: remaining, input, result, hpublished, hresult => by + rw [runDeferredLayerSchedule, mem_support_bind_iff] at hresult + obtain ⟨stepOption, hstep, hrest⟩ := hresult + cases stepOption with + | none => simp at hrest + | some step => + exact publishedValues_of_mem_runDeferredLayerSchedule parameter table ftsSecret index + remaining step result + (publishedValues_of_mem_runDeferredLayerOperation parameter table ftsSecret index + operation input step hpublished hstep) + hrest + +theorem publishedValues_of_mem_publishDeferredChronologicalSignature + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (input : ResolvedRunResult DeferredLayerStore) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (hpublished : PublishedValues input.context.state) + (hresult : some result ∈ support + (publishDeferredChronologicalSignature ftsSecret randomness index leaves ftsPath + (some input))) : + PublishedValues result.context.state := by + unfold publishDeferredChronologicalSignature at hresult + exact resolvedPreservesPublishedValues_publishChronologicalSignature ftsSecret randomness index + leaves ftsPath (chronologicalPartsOfStore input.value) input.context input.value.cache + input.remaining input.table result hpublished hresult + +theorem publishedValues_of_mem_runDeferredChronologicalLayersAndPublish + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (hpublished : PublishedValues context.state) + (hresult : some result ∈ support + (runDeferredChronologicalLayersAndPublish parameter table ftsSecret randomness index leaves + ftsPath context fuel cache)) : + PublishedValues result.context.state := by + unfold runDeferredChronologicalLayersAndPublish at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨layersOption, hlayers, hpublish⟩ := hresult + cases layersOption with + | none => simp [publishDeferredChronologicalSignature] at hpublish + | some layers => + have hlayersPublished := publishedValues_of_mem_runDeferredLayerSchedule parameter table + ftsSecret index chronologicalLayerSchedule + { context := context, remaining := fuel, value := emptyDeferredLayerStore cache, + table := table } + layers hpublished hlayers + exact publishedValues_of_mem_publishDeferredChronologicalSignature ftsSecret randomness + index leaves ftsPath layers result hlayersPublished hpublish + +theorem publishedValues_of_mem_runDeferredChronologicalSignAfterDigest + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (hpublished : PublishedValues context.state) + (hresult : some result ∈ support + (runDeferredChronologicalSignAfterDigest parameter table ftsSecret randomness index leaves + context fuel cache)) : + PublishedValues result.context.state := by + unfold runDeferredChronologicalSignAfterDigest at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨ftsOption, hfts, hrest⟩ := hresult + cases ftsOption with + | none => simp at hrest + | some ftsResult => + have hftsPublished := resolvedPreservesPublishedValues_simulateQ_ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index)) context cache fuel table ftsResult + hpublished hfts + exact publishedValues_of_mem_runDeferredChronologicalLayersAndPublish parameter table + ftsSecret randomness index leaves ftsResult.value.1 ftsResult.context + ftsResult.remaining ftsResult.value.2 result hftsPublished hrest + +theorem publishedValues_of_mem_runDeferredChronologicalSign + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (hpublished : PublishedValues context.state) + (hresult : some result ∈ support + (runDeferredChronologicalSign parameter root table ftsSecret message context fuel cache)) : + PublishedValues result.context.state := by + unfold runDeferredChronologicalSign at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨selectedOption, hselected, hrest⟩ := hresult + cases selectedOption with + | none => simp at hrest + | some selected => + have hselectedPublished := resolvedPreservesPublishedValues_ordinarySignDigestLoop + (⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ : SecretKey) digestAttemptLimit message + context cache fuel table selected hpublished hselected + cases hvalue : selected.value.1 with + | none => + simp only [hvalue, support_pure, Set.mem_singleton_iff] at hrest + have hresultEq := Option.some.inj hrest + subst result + exact hselectedPublished + | some digestResult => + rcases digestResult with ⟨randomness, selectedIndex, leaves⟩ + simp only [hvalue] at hrest + exact publishedValues_of_mem_runDeferredChronologicalSignAfterDigest parameter table + ftsSecret randomness selectedIndex leaves selected.context selected.remaining + selected.value.2 result hselectedPublished hrest + +theorem valid_of_mem_runDeferredChronologicalSign + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hresult : some result ∈ support + (runDeferredChronologicalSign parameter root table ftsSecret message context fuel cache)) : + result.context.Valid := by + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hview := finalizationViewEq_of_deferredCompletion_iff hvalid hvalid hstarts hstarts rfl + hcompletable (fun _ => Iff.rfl) + have hrelation := + relTriple_runResolvedFromTable_maskedPublishedChronologicalSign_finalization parameter root + table ftsSecret message context context fuel cache cache + ⟨hview, hvalid, hvalid, hcompletable⟩ rfl rfl + obtain ⟨leftOption, _hleft, hrelated⟩ := + exists_right_of_relTriple_of_mem_support + (OracleComp.ProgramLogic.Relational.relTriple_symm hrelation) hresult + cases leftOption with + | none => simp [FinalizationMaterializedRunEq] at hrelated + | some leftResult => + exact hrelated.2.1.2.2.1 + +theorem evalDist_finishObserve_canonicalContinuation_canonicalizeResolvedRun + (table : OtsSecretIndex → HashOutput) + (next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β) + (result : Option (ResolvedRunResult (α × SplitHashCache))) + (hconsistent : ∀ resolved, result = some resolved → + resolved.context.ValuesConsistent) + (hpublished : ∀ resolved, result = some resolved → + PublishedValues resolved.context.state) : + evalDist (finishObserve (canonicalContinuationObserve table next) + (canonicalizeResolvedRun table result)) = + evalDist (finishObserve (canonicalContinuationObserve table next) result) := by + cases result with + | none => rfl + | some result => + have hresultConsistent := hconsistent result rfl + have hresultPublished := hpublished result rfl + have hcanonicalPublished := + hresultPublished.to_canonicalizedMaterializedValues (table := table) + simp only [canonicalizeResolvedRun, finishObserve] + unfold canonicalContinuationObserve + simp only [hresultPublished, hcanonicalPublished, ↓reduceIte] + rw [canonicalizeMaterializedValues_idempotent table result.context + hresultConsistent] + +theorem evalDist_runResolvedFromTable_canonicalize_then_canonicalContinuation + (table : OtsSecretIndex → HashOutput) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) + (hpreserves : ResolvedPreservesPublished computation) : + evalDist (runResolvedFromTable context fuel table (computation.run cache) >>= fun result => + finishObserve (canonicalContinuationObserve table next) + (canonicalizeResolvedRun table result)) = + evalDist (runResolvedObserve (canonicalContinuationObserve table next) context fuel table + (computation.run cache)) := by + unfold runResolvedObserve + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable (computation.run cache) context fuel + table result hconsistent hstarts hresult + have hresultPublished := hpreserves context cache fuel table result hpublished hresult + exact evalDist_finishObserve_canonicalContinuation_canonicalizeResolvedRun table next + (some result) (by simp [hcore.2.1]) (by simp [hresultPublished]) + +theorem evalDist_canonicalDeferredAdversaryImpl_hash_canonicalContinuation + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : OracleWorld.Domain) + (next : OracleWorld.Range query → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) : + evalDist + (canonicalDeferredAdversaryImpl parameter root table ftsSecret (.inl query) context fuel + table cache >>= finishObserve (canonicalContinuationObserve table next)) = + evalDist (runResolvedObserve (canonicalContinuationObserve table next) context fuel table + ((probingRomImpl parameter query).run cache)) := by + rw [canonicalDeferredAdversaryImpl] + simp only [bind_assoc, pure_bind] + exact evalDist_runResolvedFromTable_canonicalize_then_canonicalContinuation table + (probingRomImpl parameter query) next context fuel cache hconsistent hstarts hpublished + (resolvedPreservesPublishedValuesImpl_probingRomImpl parameter query) + +theorem evalDist_canonicalDeferredAdversaryImpl_sign_canonicalContinuation + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (next : Option Signature → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hpublished : PublishedValues context.state) : + evalDist + (canonicalDeferredAdversaryImpl parameter root table ftsSecret (.inr message) context fuel + table cache >>= finishObserve (canonicalContinuationObserve table next)) = + evalDist (runResolvedObserve (canonicalContinuationObserve table next) context fuel table + ((maskedSign parameter root ftsSecret message).run cache)) := by + rw [canonicalDeferredAdversaryImpl] + simp only [bind_assoc, pure_bind] + calc + _ = evalDist (runDeferredChronologicalSign parameter root table ftsSecret message context fuel + cache >>= finishObserve (canonicalContinuationObserve table next)) := by + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hresultValid := valid_of_mem_runDeferredChronologicalSign parameter root table + ftsSecret message context fuel cache result hvalid hcompletable hresult + have hresultPublished := publishedValues_of_mem_runDeferredChronologicalSign parameter + root table ftsSecret message context fuel cache result hpublished hresult + exact evalDist_finishObserve_canonicalContinuation_canonicalizeResolvedRun table next + (some result) (by simp [hresultValid.valuesConsistent]) + (by simp [hresultPublished]) + _ = _ := evalDist_runDeferredChronologicalSign_canonicalObserve_eq_maskedSign parameter root + table ftsSecret message context fuel cache next hvalid hcompletable + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveProbability.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveProbability.lean new file mode 100644 index 00000000..3971e4af --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveProbability.lean @@ -0,0 +1,226 @@ +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveBoundary +import SphincsSecurity.Proof.OtsProbeChronologicalProbability + +/-! +# Probability boundary for canonical adaptive one-time probes + +The canonical chronological monitor couples directly to the real retained game. Its deterministic +terminal contradiction bounds a real winning hidden opening by canonical completion failure, which +is the event shared with the delayed monitor. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +def CanonicalChronologicalSupported + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (result : ResolvedRunResult (RetainedGameResult × SplitHashCache)) : Prop := + some result ∈ support + (canonicalChronologicalRetainedRunAfterFtsSecrets adversary parameter table ftsSecret fuel) + +set_option maxHeartbeats 10000000 in +set_option maxRecDepth 100000 in +theorem not_completionVerifyProbe_of_canonicalReachableResolvedRunRel + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (result : ResolvedRunResult (RetainedGameResult × SplitHashCache)) + (actualValue : RetainedGameResult) (actualCache : QueryCache HashSpec) + (hresult : CanonicalChronologicalSupported adversary parameter table ftsSecret fuel result) + (hactual : (actualValue, actualCache) ∈ support + (actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table))) + (hrelation : ReachableResolvedRunRel parameter table (some result) + (actualValue, actualCache)) + (completion : Coordinate → HashOutput) + (hcompletion : DeferredCompletion table result.context completion) + (hprobe : VerifyProbeWitness + (tableAnswer parameter completion (fromCache (ordinaryQueryCache result.value.2))) + actualCache + (⟨parameter, actualValue.1, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + actualValue.2.1.2 actualValue.2.1.1.message actualValue.2.1.1.signature) : False := by + rcases hrelation with hclean | hdoomed + · have hactual' : (result.value.1, actualCache) ∈ support + (actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table)) := by + rw [hclean.2.1] + exact hactual + have hprobe' : VerifyProbeWitness + (tableAnswer parameter completion (fromCache (ordinaryQueryCache result.value.2))) + actualCache + (⟨parameter, result.value.1.1, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + result.value.1.2.1.2 result.value.1.2.1.1.message + result.value.1.2.1.1.signature := by + rw [hclean.2.1] + exact hprobe + let fallback : QueryImpl HashSpec Id := fromCache (ordinaryQueryCache result.value.2) + have hfallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback := + CacheAgreesWithFnOffTable.of_agrees + (agreesWithFn_fromCache (ordinaryQueryCache result.value.2)) + have hagrees : actualCache.AgreesWithFn + (tableAnswer parameter completion fallback) := + hclean.2.2.1.concreteCache_agreesWith_tableAnswer_of_fallback completion hcompletion + fallback hfallback + have hlogRuns := successfulSignRuns_of_mem_support_actualRetainedGameAfterTable adversary + (tableAnswer parameter completion fallback) parameter table ftsSecret result.value.1.1 + result.value.1.2.1.1 result.value.1.2.1.2 result.value.1.2.2 actualCache hactual' hagrees + unfold CanonicalChronologicalSupported at hresult + unfold canonicalChronologicalRetainedRunAfterFtsSecrets at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨rootOption, hroot, hrest⟩ := hresult + cases rootOption with + | none => simp at hrest + | some rootResult => + have hrootCore := resolvedCore_of_mem_runResolved_maskedPublishedTreeRoot parameter table + fuel rootResult hroot + simp only at hrest + rw [hrootCore.1, mem_support_bind_iff] at hrest + obtain ⟨adversaryOption, hadversary, hverifierFinish⟩ := hrest + cases adversaryOption with + | none => simp [canonicalVerifierContinuation] at hverifierFinish + | some adversaryResult => + have hadversaryCore := + resolvedCore_of_mem_runSynchronizedResolved_canonicalChronological + parameter rootResult.value.1 table ftsSecret + (signingTraceComputation (adversary.main ⟨rootResult.value.1, parameter⟩)) + rootResult.context rootResult.remaining rootResult.value.2 adversaryResult + hrootCore.2.1 hrootCore.2.2 hadversary + have hadversaryCompletion := + hcompletion.of_mem_canonicalVerifierContinuation parameter rootResult.value.1 table + adversaryResult result completion hadversaryCore.1 hverifierFinish + hadversaryCore.2.1 hadversaryCore.2.2 + have hrootCompletion : DeferredCompletion table rootResult.context completion := + hadversaryCompletion.of_mem_runSynchronizedResolved_canonicalChronological + (signingTraceComputation (adversary.main ⟨rootResult.value.1, parameter⟩)) + rootResult.context rootResult.remaining rootResult.value.2 adversaryResult + completion hrootCore.2.1 hrootCore.2.2 hadversary + obtain ⟨hrootBoundary⟩ := canonicalRootBoundary_of_mem parameter table + (CoveredChainCoordinate (tableAnswer parameter completion fallback) actualCache + (⟨parameter, rootResult.value.1, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + adversaryResult.value.1.2) + fuel rootResult completion hroot hrootCompletion + obtain ⟨hadversaryBoundary, _hadversaryFallback⟩ := by + apply canonicalAdversaryBoundary_of_mem adversary parameter rootResult.value.1 table + ftsSecret actualCache completion fallback rootResult adversaryResult result + hrootBoundary hadversary hadversaryCore.1 hadversaryCompletion hverifierFinish + hcompletion hfallback + exact hlogRuns + let terminal : CanonicalVerifierTerminal parameter rootResult.value.1 table ftsSecret + actualCache completion fallback adversaryResult := + { result := result + table_eq := hadversaryCore.1 + mem_support := hverifierFinish + resultCompletion := hcompletion + fallbackAgrees := hfallback + probe := hprobe' } + exact hadversaryBoundary.contradicts_canonicalVerifierTerminal + parameter rootResult.value.1 table ftsSecret actualCache completion fallback + adversaryResult terminal + · exact hdoomed.2.2.2 ⟨completion, hcompletion⟩ + +theorem not_resolvedCompletionVerifyProbe_of_canonicalReachableResolvedRunRel + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (result : ResolvedRunResult (RetainedGameResult × SplitHashCache)) + (actualValue : RetainedGameResult) (actualCache : QueryCache HashSpec) + (hresult : CanonicalChronologicalSupported adversary parameter table ftsSecret fuel result) + (hactual : (actualValue, actualCache) ∈ support + (actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table))) + (hrelation : ReachableResolvedRunRel parameter table (some result) + (actualValue, actualCache)) : + ¬ResolvedCompletionVerifyProbe parameter table ftsSecret result actualValue actualCache := by + rintro ⟨completion, hcompletion, hprobe⟩ + exact not_completionVerifyProbe_of_canonicalReachableResolvedRunRel adversary parameter table + ftsSecret fuel result actualValue actualCache hresult hactual hrelation completion hcompletion + hprobe + +theorem not_deferredCompletable_of_winningRetainedVerifyProbe_canonical + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (result : ResolvedRunResult (RetainedGameResult × SplitHashCache)) + (actualValue : RetainedGameResult) (actualCache : QueryCache HashSpec) + (hresult : CanonicalChronologicalSupported adversary parameter table ftsSecret fuel result) + (hactual : (actualValue, actualCache) ∈ support + (actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table))) + (hrelation : ReachableResolvedRunRel parameter table (some result) + (actualValue, actualCache)) + (hwitness : WinningRetainedVerifyProbeWitness parameter (extendStartTable table) + ftsSecret (actualValue, actualCache)) : + ¬DeferredCompletable table result.context := by + intro hcompletable + have hcompletionProbe := + resolvedCompletionVerifyProbe_of_winning_of_deferredCompletable adversary parameter table + ftsSecret result actualValue actualCache hactual hrelation hcompletable hwitness + exact (not_resolvedCompletionVerifyProbe_of_canonicalReachableResolvedRunRel adversary + parameter table ftsSecret fuel result actualValue actualCache hresult hactual hrelation) + hcompletionProbe + +theorem probEvent_winningRetainedVerifyProbe_le_canonicalResolvedCompletionFailure + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table)] ≤ + Pr[ResolvedCompletionFailure table | + canonicalChronologicalRetainedRunAfterFtsSecrets adversary parameter table ftsSecret + fuel] := by + let canonicalRun := canonicalChronologicalRetainedRunAfterFtsSecrets adversary parameter table + ftsSecret fuel + let actualRun := + actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table) + have hrel := relTriple_canonicalChronologicalRetainedRun_actual adversary parameter table + ftsSecret fuel + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hrel + (fun result => result ∈ support canonicalRun) (fun result hresult => hresult) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply probEvent_le_of_relTriple (relTriple_symm hboth) + intro actualResult canonicalResult hrelation hwitness + cases canonicalResult with + | none => trivial + | some result => + have hresult : CanonicalChronologicalSupported adversary parameter table ftsSecret fuel + result := hrelation.1.2 + exact not_deferredCompletable_of_winningRetainedVerifyProbe_canonical adversary parameter + table ftsSecret fuel result actualResult.1 actualResult.2 hresult hrelation.2 + hrelation.1.1 hwitness + +theorem probEvent_winningRetainedVerifyProbe_le_canonicalFinishedResolvedRun_none + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table)] ≤ + Pr[fun result => result = none | + canonicalChronologicalRetainedRunAfterFtsSecrets adversary parameter table ftsSecret + fuel >>= finishResolvedRun] := by + apply (probEvent_winningRetainedVerifyProbe_le_canonicalResolvedCompletionFailure adversary + parameter table ftsSecret fuel).trans + apply probEvent_resolvedCompletionFailure_le_finishResolvedRun_none table + intro result hresult + have hrel := relTriple_canonicalChronologicalRetainedRun_actual adversary parameter table + ftsSecret fuel + obtain ⟨actualResult, _hactual, hrelation⟩ := + exists_right_of_relTriple_of_mem_support hrel hresult + rcases hrelation with hclean | hdoomed + · exact hclean.1 + · exact hdoomed.1 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptivePublication.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptivePublication.lean new file mode 100644 index 00000000..e4afbdce --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptivePublication.lean @@ -0,0 +1,175 @@ +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveSigner + +/-! +# Signed-chain publication through canonical adaptive execution +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option maxRecDepth 100000 in +theorem revealedChainAllowed_runSynchronizedResolved_signingTraceComputation + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (targetCache : QueryCache HashSpec) (allowedLog : QueryLog SigningSpec) + (completion : Coordinate → HashOutput) (fallback : QueryImpl HashSpec Id) + (hlogRuns : ∀ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), entry ∈ allowedLog → entry.2 = some signature → + SuccessfulSignRun (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + entry.1 signature) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (result : ResolvedRunResult ((α × QueryLog SigningSpec) × SplitHashCache)) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hallowed : RevealedChainAllowed + (CoveredChainCoordinate (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + allowedLog) + context.state) + (hsub : ∀ entry, entry ∈ result.value.1.2 → entry ∈ allowedLog) + (hresult : some result ∈ support + (runSynchronizedResolved + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (signingTraceComputation computation) context fuel table cache)) + (hcompletion : DeferredCompletion table result.context completion) + (hfallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback) : + RevealedChainAllowed + (CoveredChainCoordinate (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + allowedLog) + result.context.state := by + induction computation using OracleComp.inductionOn generalizing context fuel cache + concreteCache result with + | pure value => + have htrace : signingTraceComputation + (pure value : OracleComp (OracleWorld + SigningSpec) α) = pure (value, []) := by + simp [signingTraceComputation] + rw [htrace, runSynchronizedResolved_pure _ (value, []) context fuel table cache + hinvariant.2.2.2.1] at hresult + simp only [mem_support_pure_iff, Option.some.injEq] at hresult + subst result + exact hallowed + | query_bind input next ih => + rw [signingTraceComputation_query_bind, runSynchronizedResolved, + OracleComp.construct_query_bind] at hresult + simp only [dif_pos hinvariant.2.2.2.1, mem_support_bind_iff] at hresult + obtain ⟨queryOption, hquery, hrest⟩ := hresult + cases queryOption with + | none => simp at hrest + | some queryResult => + change some result ∈ support + (runSynchronizedResolved + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + ((fun tail => + (tail.1, signingLogFragment input queryResult.value.1 ++ tail.2)) <$> + signingTraceComputation (next queryResult.value.1)) + queryResult.context queryResult.remaining queryResult.table + queryResult.value.2) at hrest + rw [map_eq_bind_pure_comp, runSynchronizedResolved_bind, + mem_support_bind_iff] at hrest + obtain ⟨tailOption, htail, hfinish⟩ := hrest + cases tailOption with + | none => simp at hfinish + | some tailResult => + have hqueryCore := + resolvedCore_of_mem_canonicalChronologicalAdversaryImpl parameter root table + ftsSecret input context fuel cache queryResult + hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hquery + change some tailResult ∈ support + (runSynchronizedResolved + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (signingTraceComputation (next queryResult.value.1)) queryResult.context + queryResult.remaining queryResult.table queryResult.value.2) at htail + rw [hqueryCore.1] at htail + have htailCore := + resolvedCore_of_mem_runSynchronizedResolved_canonicalChronological parameter root + table ftsSecret (signingTraceComputation (next queryResult.value.1)) + queryResult.context queryResult.remaining queryResult.value.2 tailResult + hqueryCore.2.1 hqueryCore.2.2 htail + simp only at hfinish + change some result ∈ support + (runSynchronizedResolved + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (pure (tailResult.value.1.1, + signingLogFragment input queryResult.value.1 ++ tailResult.value.1.2)) + tailResult.context tailResult.remaining tailResult.table + tailResult.value.2) at hfinish + have htailCompletable : + DeferredCompletable tailResult.table tailResult.context := by + by_contra hnotCompletable + rw [runSynchronizedResolved_pure_of_not_completable _ _ tailResult.context + tailResult.remaining tailResult.table tailResult.value.2 + hnotCompletable] at hfinish + simp at hfinish + rw [runSynchronizedResolved_pure _ _ tailResult.context tailResult.remaining + tailResult.table tailResult.value.2 htailCompletable] at hfinish + simp only [mem_support_pure_iff, Option.some.injEq] at hfinish + subst result + simp only at hsub hcompletion hfallback ⊢ + have hqueryCompletion : DeferredCompletion table queryResult.context completion := + hcompletion.of_mem_runSynchronizedResolved_canonicalChronological + (signingTraceComputation (next queryResult.value.1)) queryResult.context + queryResult.remaining queryResult.value.2 tailResult completion + hqueryCore.2.1 hqueryCore.2.2 htail + have hqueryRel := + canonicalReachableResolvedImplCouples_chronologicalAdversaryImpl parameter root + table ftsSecret input context fuel cache concreteCache hinvariant hclosed + hpublished + obtain ⟨queryRight, _hqueryRightSupport, hqueryRelation⟩ := + exists_right_of_relTriple_of_mem_support hqueryRel hquery + rcases queryRight with ⟨_queryValue, queryConcreteCache⟩ + obtain ⟨_queryOutput, hqueryInvariant, hqueryClosed, hqueryPublished⟩ := + hqueryRelation.clean_of_completion hqueryCompletion + have htailRel := relTriple_runSynchronizedResolved_reachable + (canonicalReachableResolvedImplCouples_chronologicalAdversaryImpl parameter root + table ftsSecret) + (signingTraceComputation (next queryResult.value.1)) queryResult.context + queryResult.remaining queryResult.value.2 queryConcreteCache hqueryInvariant + hqueryClosed hqueryPublished + let secretKey : SecretKey := + ⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ + have hqueryFallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache queryResult.value.2) fallback := + CacheAgreesWithFnOffTable.of_reachableRelTriple htailRel hqueryInvariant htail + hcompletion hfallback (fun value finalCache hright => + FtsProbeSimulation.simulateQ_unloggedMappedAdversaryImpl_cache_le secretKey + (signingTraceComputation (next queryResult.value.1)) queryConcreteCache + finalCache value hright) + have hqueryAllowed := + revealedChainAllowed_canonicalChronologicalAdversaryQuery parameter root table + ftsSecret targetCache allowedLog completion fallback hlogRuns input context + fuel cache concreteCache queryResult hinvariant hclosed hpublished hallowed + (fun entry hentry => hsub entry + (List.mem_append_left tailResult.value.1.2 hentry)) + hquery hqueryCompletion hqueryFallback + apply ih queryResult.value.1 queryResult.context queryResult.remaining + queryResult.value.2 queryConcreteCache tailResult hqueryInvariant hqueryClosed + hqueryPublished hqueryAllowed + · intro entry hentry + exact hsub entry (List.mem_append_right _ hentry) + · exact htail + · exact hcompletion + · exact hfallback + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveSigner.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveSigner.lean new file mode 100644 index 00000000..cb2a7291 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveSigner.lean @@ -0,0 +1,2126 @@ +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveFinalization + +/-! +# Canonical adaptive signer boundaries + +A signer may materialize structural answers that it does not publish. At the return boundary these +answers move back into the deferred representation, so later adversarial guesses remain probeable. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def publicMaterializedValues (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (coordinate : Coordinate) : Option HashOutput := + if coordinate ∈ context.state.revealed then + resolvedCompletionValue table context coordinate + else none + +def canonicalizeMaterializedValues (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) : DeferredContext := + { context with + state := { context.state with values := publicMaterializedValues table context } } + +def CanonicalMaterializedValues (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) : Prop := + context.state.values = publicMaterializedValues table context + +theorem canonicalizeMaterializedValues_revealed + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) : + (canonicalizeMaterializedValues table context).state.revealed = + context.state.revealed := rfl + +theorem canonicalizeMaterializedValues_pending + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) : + (canonicalizeMaterializedValues table context).state.pending = + context.state.pending := rfl + +theorem canonicalizeMaterializedValues_positionValue + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hconsistent : context.ValuesConsistent) (position : Position) : + (canonicalizeMaterializedValues table context).positionValue position = + context.positionValue position := by + unfold canonicalizeMaterializedValues DeferredContext.positionValue + publicMaterializedValues + by_cases hrevealed : Coordinate.position position ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte, resolvedCompletionValue] + cases hstate : context.state.values (.position position) with + | none => + cases hdeferred : context.values position <;> + simp [DeferredContext.positionValue, hstate, hdeferred] + | some output => simp [DeferredContext.positionValue, hstate] + · simp only [hrevealed, ↓reduceIte] + cases hvalue : context.state.values (.position position) with + | none => simp + | some output => + have hdeferred := hconsistent position output hvalue + simp [hdeferred] + +theorem canonicalizeMaterializedValues_resolvedCompletionValue + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hconsistent : context.ValuesConsistent) : + resolvedCompletionValue table (canonicalizeMaterializedValues table context) = + resolvedCompletionValue table context := by + funext coordinate + cases coordinate with + | chainStart => rfl + | position position => + exact canonicalizeMaterializedValues_positionValue table context hconsistent position + +theorem canonicalizeMaterializedValues_canonical + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hconsistent : context.ValuesConsistent) : + CanonicalMaterializedValues table + (canonicalizeMaterializedValues table context) := by + change publicMaterializedValues table context = + publicMaterializedValues table (canonicalizeMaterializedValues table context) + funext coordinate + unfold publicMaterializedValues + by_cases hrevealed : coordinate ∈ context.state.revealed + · have hcanonicalRevealed : coordinate ∈ + (canonicalizeMaterializedValues table context).state.revealed := hrevealed + simp only [hrevealed, hcanonicalRevealed, ↓reduceIte] + rw [canonicalizeMaterializedValues_resolvedCompletionValue table context hconsistent] + · have hcanonicalNotRevealed : coordinate ∉ + (canonicalizeMaterializedValues table context).state.revealed := hrevealed + simp [hrevealed, hcanonicalNotRevealed] + +theorem canonicalizeMaterializedValues_idempotent + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hconsistent : context.ValuesConsistent) : + canonicalizeMaterializedValues table + (canonicalizeMaterializedValues table context) = + canonicalizeMaterializedValues table context := by + have hcanonical := canonicalizeMaterializedValues_canonical table context hconsistent + unfold CanonicalMaterializedValues at hcanonical + cases context with + | mk state values => + cases state with + | mk pending stateValues revealed ensured => + simp only [canonicalizeMaterializedValues] at hcanonical ⊢ + rw [← hcanonical] + +theorem canonicalizeMaterializedValues_valuesConsistent + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hconsistent : context.ValuesConsistent) : + (canonicalizeMaterializedValues table context).ValuesConsistent := by + intro position output hvalue + unfold canonicalizeMaterializedValues publicMaterializedValues at hvalue + by_cases hrevealed : Coordinate.position position ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] at hvalue + have hresolved : context.positionValue position = some output := by + simpa [resolvedCompletionValue] using hvalue + change context.values position = some output + unfold DeferredContext.positionValue at hresolved + cases hstate : context.state.values (.position position) with + | none => simpa [hstate] using hresolved + | some cached => + have hcached : cached = output := by simpa [hstate] using hresolved + subst cached + exact hconsistent position output hstate + · simp [hrevealed] at hvalue + +theorem canonicalizeMaterializedValues_startTableAgrees + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) : + StartTableAgrees (canonicalizeMaterializedValues table context).state table := by + intro index output hvalue + unfold canonicalizeMaterializedValues publicMaterializedValues at hvalue + by_cases hrevealed : index.coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] at hvalue + have htable : table index = output := by + simpa [resolvedCompletionValue, OtsSecretIndex.coordinate] using hvalue + exact htable.symm + · simp [hrevealed] at hvalue + +theorem finalizationViewEq_canonicalize_left + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hclean : ∀ coordinate output, + resolvedCompletionValue table context coordinate = some output → + ¬context.state.hitAt coordinate output) : + FinalizationViewEq table (canonicalizeMaterializedValues table context) context := by + have hconsistent := hvalid.valuesConsistent + have hvalueEq := canonicalizeMaterializedValues_resolvedCompletionValue table context hconsistent + refine ⟨canonicalizeMaterializedValues_valuesConsistent table context hconsistent, + hconsistent, canonicalizeMaterializedValues_startTableAgrees table context, + hstarts, hvalueEq, ?_, hclean, ?_⟩ + · intro coordinate output hvalue + have horiginal : resolvedCompletionValue table context coordinate = some output := by + rw [← hvalueEq] + exact hvalue + change ¬context.state.hitAt coordinate output + exact hclean coordinate output horiginal + · intro coordinate hvalue + rfl + +theorem canonicalizeMaterializedValues_valid + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hvalid : context.Valid) + (hclean : ∀ coordinate output, + resolvedCompletionValue table context coordinate = some output → + ¬context.state.hitAt coordinate output) : + (canonicalizeMaterializedValues table context).Valid := by + refine ⟨canonicalizeMaterializedValues_valuesConsistent table context + hvalid.valuesConsistent, ?_⟩ + intro coordinate output hvalue + unfold canonicalizeMaterializedValues publicMaterializedValues at hvalue + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] at hvalue + change ¬context.state.hitAt coordinate output + exact hclean coordinate output hvalue + · simp [hrevealed] at hvalue + +theorem publicMaterializedValues_eq_of_finalizationViewEq + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewEq table left right) + (hrevealed : left.state.revealed = right.state.revealed) : + publicMaterializedValues table left = publicMaterializedValues table right := by + funext coordinate + by_cases hleftRevealed : coordinate ∈ left.state.revealed + · have hrightRevealed : coordinate ∈ right.state.revealed := by + rwa [← hrevealed] + simp [publicMaterializedValues, hleftRevealed, hrightRevealed, hview.valueEq] + · have hrightRevealed : coordinate ∉ right.state.revealed := by + rwa [← hrevealed] + simp [publicMaterializedValues, hleftRevealed, hrightRevealed] + +theorem canonicalizedFinalizationContextEq + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextEq table (some left) (some right)) + (hrevealed : left.state.revealed = right.state.revealed) : + FinalizationContextEq table + (some (canonicalizeMaterializedValues table left)) + (some (canonicalizeMaterializedValues table right)) ∧ + (canonicalizeMaterializedValues table left).state.values = + (canonicalizeMaterializedValues table right).state.values := by + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hleftCanonicalView := finalizationViewEq_canonicalize_left table left hleftValid + hview.leftStarts hview.leftClean + have hrightCanonicalView := finalizationViewEq_canonicalize_left table right hrightValid + hview.rightStarts hview.rightClean + have hleftCanonicalValid := canonicalizeMaterializedValues_valid table left hleftValid + hview.leftClean + have hrightCanonicalValid := canonicalizeMaterializedValues_valid table right hrightValid + hview.rightClean + have hleftCanonicalCompletable : DeferredCompletable table + (canonicalizeMaterializedValues table left) := by + rcases hleftCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, + (hleftCanonicalView.deferredCompletion_iff completion).mpr hcompletion⟩ + constructor + · exact ⟨hleftCanonicalView.trans (hview.trans hrightCanonicalView.symm), + hleftCanonicalValid, hrightCanonicalValid, hleftCanonicalCompletable⟩ + · exact publicMaterializedValues_eq_of_finalizationViewEq hview hrevealed + +theorem DeferredCompletion.of_canonicalizeMaterializedValues + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hcompletion : DeferredCompletion table + (canonicalizeMaterializedValues table context) completion) : + DeferredCompletion table context completion := by + refine ⟨?_, hcompletion.2.1, hcompletion.2.2.1, hcompletion.2.2.2⟩ + intro coordinate output hvalue + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + have houtput : output = table index := hstarts index output hvalue + rw [houtput] + exact hcompletion.2.2.2 index + | position position => + have hprivate := hconsistent position output hvalue + exact hcompletion.2.1 position output hprivate + +theorem DeferredCompletion.to_canonicalizedMaterializedValues + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hcompletion : DeferredCompletion table context completion) : + DeferredCompletion table (canonicalizeMaterializedValues table context) completion := by + refine ⟨?_, hcompletion.2.1, hcompletion.2.2.1, hcompletion.2.2.2⟩ + intro coordinate output hvalue + unfold canonicalizeMaterializedValues publicMaterializedValues at hvalue + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] at hvalue + exact hcompletion.eq_resolvedCompletionValue coordinate output hvalue + · simp [hrevealed] at hvalue + +theorem ChronologicalCacheAgrees.to_canonicalizedMaterializedValues + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {cache : QueryCache HashSpec} + (hagrees : ChronologicalCacheAgrees parameter table context cache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + ChronologicalCacheAgrees parameter table + (canonicalizeMaterializedValues table context) cache := by + intro completion hcompletion position hots + have horiginal := hcompletion.of_canonicalizeMaterializedValues hconsistent hstarts + have hknown := hagrees completion horiginal position hots + unfold ResolveInputAgrees at hknown ⊢ + rw [canonicalizeMaterializedValues_positionValue table context hconsistent] + exact hknown + +theorem ResolvedCachePartition.to_canonicalizedMaterializedValues + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hpartition : ResolvedCachePartition parameter table context ordinaryCache concreteCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + ResolvedCachePartition parameter table + (canonicalizeMaterializedValues table context) ordinaryCache concreteCache := by + refine ⟨hpartition.1, ?_⟩ + intro input output hcached + rcases hpartition.2 input output hcached with hordinary | hfixed + · exact Or.inl hordinary + · rcases hfixed with ⟨position, hots, hvalue, hinput⟩ + right + refine ⟨position, hots, ?_, ?_⟩ + · rw [canonicalizeMaterializedValues_positionValue table context hconsistent] + exact hvalue + · intro completion hcompletion + exact hinput completion + (hcompletion.of_canonicalizeMaterializedValues hconsistent hstarts) + +theorem VisibleResolvedComputationsCached.to_canonicalizedMaterializedValues + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {cache : QueryCache HashSpec} + (hclosed : VisibleResolvedComputationsCached parameter table context cache) + (hpublished : PublishedValues context.state) : + VisibleResolvedComputationsCached parameter table + (canonicalizeMaterializedValues table context) cache := by + intro position output hresolvable hvalue + have hrevealed : Coordinate.position position ∈ context.state.revealed := by + unfold canonicalizeMaterializedValues publicMaterializedValues at hvalue + by_contra hnotRevealed + simp [hnotRevealed] at hvalue + have horiginalNonempty := hpublished (.position position) hrevealed + cases horiginal : context.state.values (.position position) with + | none => exact False.elim (horiginalNonempty horiginal) + | some originalOutput => + have hresolved : resolvedCompletionValue table context (.position position) = + some originalOutput := by + simp [resolvedCompletionValue, DeferredContext.positionValue, horiginal] + have houtput : originalOutput = output := by + unfold canonicalizeMaterializedValues publicMaterializedValues at hvalue + simp only [hrevealed, ↓reduceIte] at hvalue + exact Option.some.inj (hresolved.symm.trans hvalue) + subst originalOutput + exact hclosed position output hresolvable horiginal + +theorem PublishedValues.to_canonicalizedMaterializedValues + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hpublished : PublishedValues context.state) : + PublishedValues (canonicalizeMaterializedValues table context).state := by + intro coordinate hrevealed + have hrevealedOriginal : coordinate ∈ context.state.revealed := by + simpa [canonicalizeMaterializedValues] using hrevealed + unfold canonicalizeMaterializedValues publicMaterializedValues + simp only [hrevealedOriginal, ↓reduceIte] + have horiginalNonempty := hpublished coordinate hrevealedOriginal + cases coordinate with + | chainStart lay tree leafIdx chainIdx => simp [resolvedCompletionValue] + | position position => + cases horiginal : context.state.values (.position position) with + | none => exact False.elim (horiginalNonempty horiginal) + | some output => + simp [resolvedCompletionValue, DeferredContext.positionValue, horiginal] + +theorem ResolvedContextInvariant.to_canonicalizedMaterializedValues + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hinvariant : ResolvedContextInvariant parameter table context ordinaryCache concreteCache) : + ResolvedContextInvariant parameter table + (canonicalizeMaterializedValues table context) ordinaryCache concreteCache := by + rcases hinvariant with ⟨hagrees, hvalid, hstarts, hcompletable, hpartition⟩ + refine ⟨hagrees.to_canonicalizedMaterializedValues hvalid.valuesConsistent hstarts, + ?_, canonicalizeMaterializedValues_startTableAgrees table context, ?_, + hpartition.to_canonicalizedMaterializedValues hvalid.valuesConsistent hstarts⟩ + · rcases hcompletable with ⟨completion, hcompletion⟩ + have hclean : ∀ coordinate output, + resolvedCompletionValue table context coordinate = some output → + ¬context.state.hitAt coordinate output := by + intro coordinate output hvalue hhit + have houtput := hcompletion.eq_resolvedCompletionValue coordinate output hvalue + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + exact hcompletion.2.2.1 coordinate (truncateHash output) hhit (by rw [houtput]) + exact canonicalizeMaterializedValues_valid table context hvalid hclean + · rcases hcompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, hcompletion.to_canonicalizedMaterializedValues⟩ + +theorem doomedResolvedContext_canonicalizeMaterializedValues + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hdoomed : DoomedResolvedContext table context) : + DoomedResolvedContext table (canonicalizeMaterializedValues table context) := by + refine ⟨canonicalizeMaterializedValues_valuesConsistent table context hdoomed.1, + canonicalizeMaterializedValues_startTableAgrees table context, ?_⟩ + intro hcompletable + rcases hcompletable with ⟨completion, hcompletion⟩ + exact hdoomed.2.2 ⟨completion, + hcompletion.of_canonicalizeMaterializedValues hdoomed.1 hdoomed.2.1⟩ + +def canonicalizeResolvedRun (table : OtsSecretIndex → HashOutput) : + Option (ResolvedRunResult α) → Option (ResolvedRunResult α) + | none => none + | some result => some + { result with context := canonicalizeMaterializedValues table result.context } + +def CanonicalResolvedRun (table : OtsSecretIndex → HashOutput) : + Option (ResolvedRunResult α) → Prop + | none => True + | some result => CanonicalMaterializedValues table result.context + +theorem canonicalResolvedRun_canonicalize + (table : OtsSecretIndex → HashOutput) + (result : Option (ResolvedRunResult α)) + (hconsistent : ∀ resolved, result = some resolved → + resolved.context.ValuesConsistent) : + CanonicalResolvedRun table (canonicalizeResolvedRun table result) := by + cases result with + | none => trivial + | some result => + exact canonicalizeMaterializedValues_canonical table result.context + (hconsistent result rfl) + +theorem canonicalizeResolvedRun_idempotent + (table : OtsSecretIndex → HashOutput) + (result : Option (ResolvedRunResult α)) + (hconsistent : ∀ resolved, result = some resolved → + resolved.context.ValuesConsistent) : + canonicalizeResolvedRun table (canonicalizeResolvedRun table result) = + canonicalizeResolvedRun table result := by + cases result with + | none => rfl + | some result => + simp only [canonicalizeResolvedRun] + rw [canonicalizeMaterializedValues_idempotent table result.context + (hconsistent result rfl)] + +theorem ReachableResolvedRunRel.canonicalizeResolvedRun + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left : Option (ResolvedRunResult (α × SplitHashCache))} + {right : α × QueryCache HashSpec} + (hrelation : ReachableResolvedRunRel parameter table left right) : + ReachableResolvedRunRel parameter table (canonicalizeResolvedRun table left) right := by + cases left with + | none => trivial + | some result => + rcases hrelation with hclean | hdoomed + · left + exact ⟨hclean.1, hclean.2.1, + hclean.2.2.1.to_canonicalizedMaterializedValues, + hclean.2.2.2.1.to_canonicalizedMaterializedValues hclean.2.2.2.2, + hclean.2.2.2.2.to_canonicalizedMaterializedValues⟩ + · right + exact ⟨hdoomed.1, + doomedResolvedContext_canonicalizeMaterializedValues hdoomed.2⟩ + +theorem relTriple_canonicalizeResolvedRun_of_reachable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (leftRun : ProbComp (Option (ResolvedRunResult (α × SplitHashCache)))) + (rightRun : ProbComp (α × QueryCache HashSpec)) + (hrelation : RelTriple leftRun rightRun + (ReachableResolvedRunRel parameter table)) : + RelTriple + (leftRun >>= fun result => pure (canonicalizeResolvedRun table result)) + rightRun (ReachableResolvedRunRel parameter table) := by + rw [show rightRun = rightRun >>= pure by simp] + apply relTriple_bind hrelation + intro left right hresult + exact relTriple_pure_pure hresult.canonicalizeResolvedRun + +theorem finalizationSynchronizedRunEq_canonicalize + (table : OtsSecretIndex → HashOutput) + (left right : Option (ResolvedRunResult (α × SplitHashCache))) + (hrelation : FinalizationAdaptiveRunEq table left right) : + FinalizationSynchronizedRunEq table + (canonicalizeResolvedRun table left) (canonicalizeResolvedRun table right) := by + rcases hrelation with hclean | hdoomed + · cases left with + | none => + cases right with + | none => exact Or.inl ⟨trivial, trivial⟩ + | some right => simp [FinalizationMaterializedRunEq] at hclean + | some left => + cases right with + | none => simp [FinalizationMaterializedRunEq] at hclean + | some right => + rcases hclean with + ⟨hvalue, hcontext, hremaining, hleftTable, hrightTable, hcache, hrevealed⟩ + obtain ⟨hcanonicalContext, hcanonicalValues⟩ := + canonicalizedFinalizationContextEq hcontext hrevealed + left + exact ⟨⟨hvalue, hcanonicalContext, hremaining, hleftTable, hrightTable, + hcache, hrevealed⟩, hcanonicalValues⟩ + · right + constructor + · cases left with + | none => trivial + | some left => + exact ⟨hdoomed.1.1, + doomedResolvedContext_canonicalizeMaterializedValues hdoomed.1.2⟩ + · cases right with + | none => trivial + | some right => + exact ⟨hdoomed.2.1, + doomedResolvedContext_canonicalizeMaterializedValues hdoomed.2.2⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_canonicalized_maskedPublishedChronologicalSign + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (left right : DeferredContext) (fuel : Nat) (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) : + RelTriple + (runResolvedFromTable left fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run leftCache) >>= + fun result => pure (canonicalizeResolvedRun table result)) + (runDeferredChronologicalSign parameter root table ftsSecret message right fuel rightCache >>= + fun result => pure (canonicalizeResolvedRun table result)) + (FinalizationSynchronizedRunEq table) := by + apply relTriple_bind + (relTriple_runResolvedFromTable_maskedPublishedChronologicalSign_finalization parameter root + table ftsSecret message left right fuel leftCache rightCache hcontext hcache hrevealed) + intro leftResult rightResult hrelation + apply relTriple_pure_pure + exact finalizationSynchronizedRunEq_canonicalize table leftResult rightResult + (Or.inl hrelation) + +def ResolvedQueryImpl (spec : OracleSpec ι) := + (query : spec.Domain) → DeferredContext → Nat → + (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp (Option (ResolvedRunResult (spec.Range query × SplitHashCache))) + +noncomputable def runSynchronizedResolved + (impl : ResolvedQueryImpl spec) (computation : OracleComp spec α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option (ResolvedRunResult (α × SplitHashCache))) := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp spec α => DeferredContext → Nat → + (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp (Option (ResolvedRunResult (α × SplitHashCache)))) + (fun value context remaining table cache => + if _hcompletable : DeferredCompletable table context then + pure (some ⟨context, remaining, (value, cache), table⟩) + else pure none) + (fun query _next recursivelyRun context fuel table cache => + if _hcompletable : DeferredCompletable table context then do + let stepOption : Option (ResolvedRunResult (spec.Range query × SplitHashCache)) ← + impl query context fuel table cache + match stepOption with + | none => pure (none : Option (ResolvedRunResult (α × SplitHashCache))) + | some result => + recursivelyRun result.value.1 result.context result.remaining result.table + result.value.2 + else pure none) + computation context fuel table cache + +theorem runSynchronizedResolved_pure + (impl : ResolvedQueryImpl spec) (value : α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcompletable : DeferredCompletable table context) : + runSynchronizedResolved impl (pure value) context fuel table cache = + pure (some ⟨context, fuel, (value, cache), table⟩) := by + rw [runSynchronizedResolved, OracleComp.construct_pure] + simp [hcompletable] + +theorem runSynchronizedResolved_pure_of_not_completable + (impl : ResolvedQueryImpl spec) (value : α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hnotCompletable : ¬DeferredCompletable table context) : + runSynchronizedResolved impl (pure value) context fuel table cache = pure none := by + rw [runSynchronizedResolved, OracleComp.construct_pure] + simp [hnotCompletable] + +theorem runSynchronizedResolved_query_bind_of_not_completable + (impl : ResolvedQueryImpl spec) (query : spec.Domain) + (next : spec.Range query → OracleComp spec α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hnotCompletable : ¬DeferredCompletable table context) : + runSynchronizedResolved impl (liftM (spec.query query) >>= next) + context fuel table cache = pure none := by + rw [runSynchronizedResolved, OracleComp.construct_query_bind] + simp [hnotCompletable] + +theorem runSynchronizedResolved_of_not_completable + (impl : ResolvedQueryImpl spec) (computation : OracleComp spec α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hnotCompletable : ¬DeferredCompletable table context) : + runSynchronizedResolved impl computation context fuel table cache = pure none := by + induction computation using OracleComp.inductionOn with + | pure value => + exact runSynchronizedResolved_pure_of_not_completable impl value context fuel table cache + hnotCompletable + | query_bind query next ih => + exact runSynchronizedResolved_query_bind_of_not_completable impl query next context fuel + table cache hnotCompletable + +set_option maxRecDepth 100000 in +theorem runSynchronizedResolved_bind + (impl : ResolvedQueryImpl spec) (left : OracleComp spec α) + (next : α → OracleComp spec β) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runSynchronizedResolved impl (left >>= next) context fuel table cache = (do + let leftResult ← runSynchronizedResolved impl left context fuel table cache + match leftResult with + | none => pure none + | some result => + runSynchronizedResolved impl (next result.value.1) result.context + result.remaining result.table result.value.2) := by + induction left using OracleComp.inductionOn generalizing context fuel table cache with + | pure value => + rw [pure_bind] + by_cases hcompletable : DeferredCompletable table context + · rw [runSynchronizedResolved_pure impl value context fuel table cache hcompletable] + simp + · rw [runSynchronizedResolved_pure_of_not_completable impl value context fuel table + cache hcompletable, + runSynchronizedResolved_of_not_completable impl (next value) context fuel table cache + hcompletable] + simp + | query_bind query tail ih => + rw [bind_assoc, runSynchronizedResolved, OracleComp.construct_query_bind, + runSynchronizedResolved, OracleComp.construct_query_bind] + by_cases hcompletable : DeferredCompletable table context + · simp only [dif_pos hcompletable, bind_assoc] + apply bind_congr + intro stepOption + cases stepOption with + | none => simp + | some result => + exact ih result.value.1 result.context result.remaining result.table result.value.2 + · simp only [dif_neg hcompletable, pure_bind] + +def SynchronizedResolvedImplCouples (table : OtsSecretIndex → HashOutput) + (leftImpl rightImpl : ResolvedQueryImpl spec) : Prop := + ∀ query left right fuel leftCache rightCache, + FinalizationContextEq table (some left) (some right) → + left.state.values = right.state.values → + ordinaryQueryCache leftCache = ordinaryQueryCache rightCache → + left.state.revealed = right.state.revealed → + RelTriple + (leftImpl query left fuel table leftCache) + (rightImpl query right fuel table rightCache) + (FinalizationSynchronizedRunEq table) + +set_option maxRecDepth 100000 in +theorem relTriple_runSynchronizedResolved + {table : OtsSecretIndex → HashOutput} + {leftImpl rightImpl : ResolvedQueryImpl spec} + (himpl : SynchronizedResolvedImplCouples table leftImpl rightImpl) + (computation : OracleComp spec α) + (left right : DeferredContext) (fuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) : + RelTriple + (runSynchronizedResolved leftImpl computation left fuel table leftCache) + (runSynchronizedResolved rightImpl computation right fuel table rightCache) + (FinalizationSynchronizedRunEq table) := by + induction computation using OracleComp.inductionOn generalizing left right fuel leftCache + rightCache with + | pure value => + have hleftCompletable := hcontext.2.2.2 + have hrightCompletable : DeferredCompletable table right := by + rcases hleftCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, (hcontext.1.deferredCompletion_iff completion).mp hcompletion⟩ + rw [runSynchronizedResolved_pure leftImpl value left fuel table leftCache + hleftCompletable, + runSynchronizedResolved_pure rightImpl value right fuel table rightCache + hrightCompletable] + apply relTriple_pure_pure + left + exact ⟨⟨rfl, hcontext, rfl, rfl, rfl, hcache, hrevealed⟩, hvalues⟩ + | query_bind query next ih => + have hleftCompletable := hcontext.2.2.2 + have hrightCompletable : DeferredCompletable table right := by + rcases hleftCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, (hcontext.1.deferredCompletion_iff completion).mp hcompletion⟩ + rw [runSynchronizedResolved, OracleComp.construct_query_bind, + runSynchronizedResolved, OracleComp.construct_query_bind] + simp only [dif_pos hleftCompletable, dif_pos hrightCompletable] + apply relTriple_bind + (himpl query left right fuel leftCache rightCache hcontext hvalues hcache hrevealed) + intro leftResult rightResult hrelation + rcases hrelation with hclean | hdoomed + · cases leftResult with + | none => + cases rightResult with + | none => simp [FinalizationSynchronizedRunEq, FinalizationMaterializedRunEq, + MaterializedValuesEq] + | some rightResult => simp [FinalizationMaterializedRunEq] at hclean + | some leftResult => + cases rightResult with + | none => simp [FinalizationMaterializedRunEq] at hclean + | some rightResult => + rcases leftResult with ⟨leftContext, leftFuel, leftValue, leftTable⟩ + rcases rightResult with ⟨rightContext, rightFuel, rightValue, rightTable⟩ + rcases leftValue with ⟨leftOutput, nextLeftCache⟩ + rcases rightValue with ⟨rightOutput, nextRightCache⟩ + simp only [FinalizationMaterializedRunEq, MaterializedValuesEq] at hclean + rcases hclean.1 with + ⟨houtput, hnextContext, hnextFuel, hleftTable, hrightTable, + hnextCache, hnextRevealed⟩ + subst rightOutput + subst rightFuel + subst leftTable + subst rightTable + exact ih leftOutput leftContext rightContext leftFuel nextLeftCache nextRightCache + hnextContext hclean.2 hnextCache hnextRevealed + · cases leftResult with + | none => + cases rightResult with + | none => simp [FinalizationSynchronizedRunEq, FinalizationDoomedRun] + | some rightResult => + have hrightTable := hdoomed.2.1 + have hrightNotCompletable : + ¬DeferredCompletable rightResult.table rightResult.context := by + rw [hrightTable] + exact hdoomed.2.2.2.2 + simp only + change RelTriple (pure none) + (runSynchronizedResolved rightImpl (next rightResult.value.1) + rightResult.context rightResult.remaining rightResult.table + rightResult.value.2) + (FinalizationSynchronizedRunEq table) + rw [runSynchronizedResolved_of_not_completable] + · simp [FinalizationSynchronizedRunEq, FinalizationDoomedRun] + · exact hrightNotCompletable + | some leftResult => + cases rightResult with + | none => + have hleftTable := hdoomed.1.1 + have hleftNotCompletable : + ¬DeferredCompletable leftResult.table leftResult.context := by + rw [hleftTable] + exact hdoomed.1.2.2.2 + simp only + change RelTriple + (runSynchronizedResolved leftImpl (next leftResult.value.1) + leftResult.context leftResult.remaining leftResult.table leftResult.value.2) + (pure none) (FinalizationSynchronizedRunEq table) + rw [runSynchronizedResolved_of_not_completable] + · simp [FinalizationSynchronizedRunEq, FinalizationDoomedRun] + · exact hleftNotCompletable + | some rightResult => + have hleftTable := hdoomed.1.1 + have hrightTable := hdoomed.2.1 + have hleftNotCompletable : + ¬DeferredCompletable leftResult.table leftResult.context := by + rw [hleftTable] + exact hdoomed.1.2.2.2 + have hrightNotCompletable : + ¬DeferredCompletable rightResult.table rightResult.context := by + rw [hrightTable] + exact hdoomed.2.2.2.2 + simp only + change RelTriple + (runSynchronizedResolved leftImpl (next leftResult.value.1) + leftResult.context leftResult.remaining leftResult.table leftResult.value.2) + (runSynchronizedResolved rightImpl (next rightResult.value.1) + rightResult.context rightResult.remaining rightResult.table + rightResult.value.2) + (FinalizationSynchronizedRunEq table) + rw [runSynchronizedResolved_of_not_completable, + runSynchronizedResolved_of_not_completable] + · simp [FinalizationSynchronizedRunEq, FinalizationDoomedRun] + · exact hrightNotCompletable + · exact hleftNotCompletable + +theorem finalizationSynchronizedCouples_sequenceFin + {table : OtsSecretIndex → HashOutput} {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ position, + FinalizationSynchronizedCouples table (computation position) + (computation position)) : + FinalizationSynchronizedCouples table (sequenceFin computation) + (sequenceFin computation) := by + induction n with + | zero => + simpa [sequenceFin] using + (finalizationSynchronizedCouples_pure table Fin.elim0 : + FinalizationSynchronizedCouples table + (pure Fin.elim0 : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Fin 0 → α)) + (pure Fin.elim0 : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Fin 0 → α))) + | succ n ih => + rw [sequenceFin] + apply (hcomponent 0).bind + intro head + apply (ih (fun position : Fin n => computation position.succ) + (fun position => hcomponent position.succ)).bind + intro tail + exact finalizationSynchronizedCouples_pure table + (Fin.cases head tail : Fin (n + 1) → α) + +theorem finalizationSynchronizedCouples_ensureFullChain + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + FinalizationSynchronizedCouples table + (ensureFullChain lay tree leafIdx chainIdx) + (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + apply (finalizationSynchronizedCouples_sequenceFin + (fun step : ChainStep => + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step))) + (fun step => finalizationSynchronizedCouples_ensureCoordinate table + (.position (.chain lay tree leafIdx chainIdx step)))).bind + intro _ + exact finalizationSynchronizedCouples_pure table () + +theorem finalizationSynchronizedCouples_ensureOtsLeaf + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + FinalizationSynchronizedCouples table (ensureOtsLeaf lay tree leafIdx) + (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + apply (finalizationSynchronizedCouples_sequenceFin + (fun chainIdx : ChainIndex => ensureFullChain lay tree leafIdx chainIdx) + (fun chainIdx => finalizationSynchronizedCouples_ensureFullChain table lay tree leafIdx + chainIdx)).bind + intro _ + exact finalizationSynchronizedCouples_ensureCoordinate table + (.position (.leaf lay tree leafIdx)) + +theorem finalizationSynchronizedCouples_ensureTreeNode + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, + FinalizationSynchronizedCouples table (ensureTreeNode lay tree level nodeIdx) + (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => + finalizationSynchronizedCouples_ensureOtsLeaf table lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + apply (finalizationSynchronizedCouples_ensureTreeNode table lay tree level + (2 * nodeIdx)).bind + intro _ + apply (finalizationSynchronizedCouples_ensureTreeNode table lay tree level + (2 * nodeIdx + 1)).bind + intro _ + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact finalizationSynchronizedCouples_ensureCoordinate table + (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact finalizationSynchronizedCouples_pure table () + +theorem finalizationSynchronizedCouples_revealPublishedCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + FinalizationSynchronizedCouples table (revealPublishedCoordinate coordinate) + (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + exact (finalizationSynchronizedCouples_revealCoordinate table coordinate).bind fun value => + (finalizationSynchronizedCouples_publishCoordinate table coordinate).bind fun _ => + finalizationSynchronizedCouples_pure table value + +set_option maxRecDepth 100000 in +theorem finalizationSynchronizedCouples_maskedPublishedTreeRoot + (table : OtsSecretIndex → HashOutput) : + FinalizationSynchronizedCouples table maskedPublishedTreeRoot + maskedPublishedTreeRoot := by + unfold maskedPublishedTreeRoot + apply (finalizationSynchronizedCouples_ensureTreeNode table topLayer rootTree + (layerHeight topLayer) 0).bind + intro _ + exact finalizationSynchronizedCouples_revealPublishedCoordinate table + (.position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0)) + +noncomputable def canonicalChronologicalAdversaryImpl + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ResolvedQueryImpl (OracleWorld + SigningSpec) := + fun query context fuel _table cache => + match query with + | .inl oracleQuery => + runResolvedFromTable context fuel table + ((probingRomImpl parameter oracleQuery).run cache) >>= + fun result => pure (canonicalizeResolvedRun table result) + | .inr message => + runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache) >>= + fun result => pure (canonicalizeResolvedRun table result) + +noncomputable def canonicalDeferredAdversaryImpl + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ResolvedQueryImpl (OracleWorld + SigningSpec) := + fun query context fuel _table cache => + match query with + | .inl oracleQuery => + runResolvedFromTable context fuel table + ((probingRomImpl parameter oracleQuery).run cache) >>= + fun result => pure (canonicalizeResolvedRun table result) + | .inr message => + runDeferredChronologicalSign parameter root table ftsSecret message context fuel cache >>= + fun result => pure (canonicalizeResolvedRun table result) + +def CanonicalReachableResolvedImplCouples (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (leftImpl : ResolvedQueryImpl spec) + (rightImpl : QueryImpl spec (StateT (QueryCache HashSpec) ProbComp)) : Prop := + ∀ query context fuel cache concreteCache, + ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache → + VisibleResolvedComputationsCached parameter table context concreteCache → + PublishedValues context.state → + RelTriple + (leftImpl query context fuel table cache) + ((rightImpl query).run concreteCache) + (ReachableResolvedRunRel parameter table) + +set_option maxRecDepth 100000 in +theorem canonicalReachableResolvedImplCouples_chronologicalAdversaryImpl + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + CanonicalReachableResolvedImplCouples parameter table + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (unloggedMappedAdversaryImpl + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey)) := by + intro query context fuel cache concreteCache hinvariant hclosed hpublished + cases query with + | inl oracleQuery => + apply relTriple_canonicalizeResolvedRun_of_reachable parameter table + exact reachableResolvedCouples_probingRomImpl parameter table oracleQuery context fuel cache + concreteCache hinvariant hclosed hpublished + | inr message => + apply relTriple_canonicalizeResolvedRun_of_reachable parameter table + exact reachableResolvedCouples_maskedPublishedChronologicalSign_concrete parameter root + table ftsSecret message context fuel cache concreteCache hinvariant hclosed hpublished + +theorem canonicalChronologicalAdversaryImpl_eq_raw_then_canonicalize + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + canonicalChronologicalAdversaryImpl parameter root table ftsSecret + input context fuel table cache = + (runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) >>= + fun result => pure (canonicalizeResolvedRun table result)) := by + cases input <;> rfl + +set_option maxRecDepth 100000 in +theorem revealedChainAllowed_canonicalChronologicalAdversaryQuery + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (targetCache : QueryCache HashSpec) (allowedLog : QueryLog SigningSpec) + (completion : Coordinate → HashOutput) (fallback : QueryImpl HashSpec Id) + (hlogRuns : ∀ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), entry ∈ allowedLog → entry.2 = some signature → + SuccessfulSignRun (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + entry.1 signature) + (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (result : ResolvedRunResult + ((OracleWorld + SigningSpec).Range input × SplitHashCache)) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hallowed : RevealedChainAllowed + (CoveredChainCoordinate (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + allowedLog) + context.state) + (hfragment : ∀ entry, entry ∈ signingLogFragment input result.value.1 → + entry ∈ allowedLog) + (hresult : some result ∈ support + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret + input context fuel table cache)) + (hcompletion : DeferredCompletion table result.context completion) + (hfallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback) : + RevealedChainAllowed + (CoveredChainCoordinate (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + allowedLog) + result.context.state := by + rw [canonicalChronologicalAdversaryImpl_eq_raw_then_canonicalize, + mem_support_bind_iff] at hresult + obtain ⟨rawOption, hraw, hcanonical⟩ := hresult + cases rawOption with + | none => simp [canonicalizeResolvedRun] at hcanonical + | some rawResult => + simp only [canonicalizeResolvedRun, mem_support_pure_iff] at hcanonical + have hresultEq : result = + { rawResult with + context := canonicalizeMaterializedValues table rawResult.context } := + Option.some.inj hcanonical + subst result + have hcore := resolvedCore_of_mem_runResolvedFromTable + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) + context fuel table rawResult hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hraw + have hrawCompletion : DeferredCompletion table rawResult.context completion := + hcompletion.of_canonicalizeMaterializedValues hcore.2.1 hcore.2.2 + have hrawAllowed := + revealedChainAllowed_maskedChronologicalExpandedAdversaryQuery parameter root table + ftsSecret targetCache allowedLog completion fallback hlogRuns input context fuel cache + concreteCache rawResult hinvariant hclosed hpublished hallowed hfragment hraw + hrawCompletion hfallback + intro coordinate hchain hrevealed + apply hrawAllowed coordinate hchain + simpa [canonicalizeMaterializedValues] using hrevealed + +theorem resolvedCore_of_mem_canonicalChronologicalAdversaryImpl + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult + ((OracleWorld + SigningSpec).Range input × SplitHashCache)) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret + input context fuel table cache)) : + result.table = table ∧ result.context.ValuesConsistent ∧ + StartTableAgrees result.context.state table := by + rw [canonicalChronologicalAdversaryImpl_eq_raw_then_canonicalize, + mem_support_bind_iff] at hresult + obtain ⟨rawOption, hraw, hcanonical⟩ := hresult + cases rawOption with + | none => simp [canonicalizeResolvedRun] at hcanonical + | some rawResult => + simp only [canonicalizeResolvedRun, mem_support_pure_iff] at hcanonical + have hresultEq : result = + { rawResult with + context := canonicalizeMaterializedValues table rawResult.context } := + Option.some.inj hcanonical + subst result + have hcore := resolvedCore_of_mem_runResolvedFromTable + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) + context fuel table rawResult hconsistent hstarts hraw + exact ⟨hcore.1, + canonicalizeMaterializedValues_valuesConsistent table rawResult.context hcore.2.1, + canonicalizeMaterializedValues_startTableAgrees table rawResult.context⟩ + +theorem DeferredCompletion.of_mem_canonicalChronologicalAdversaryImpl + {parameter : PublicParameter} {root : Digest} + {table : OtsSecretIndex → HashOutput} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {input : (OracleWorld + SigningSpec).Domain} + {context : DeferredContext} {fuel : Nat} {cache : SplitHashCache} + {result : ResolvedRunResult + ((OracleWorld + SigningSpec).Range input × SplitHashCache)} + {completion : Coordinate → HashOutput} + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret + input context fuel table cache)) + (hcompletion : DeferredCompletion table result.context completion) : + DeferredCompletion table context completion := by + rw [canonicalChronologicalAdversaryImpl_eq_raw_then_canonicalize, + mem_support_bind_iff] at hresult + obtain ⟨rawOption, hraw, hcanonical⟩ := hresult + cases rawOption with + | none => simp [canonicalizeResolvedRun] at hcanonical + | some rawResult => + simp only [canonicalizeResolvedRun, mem_support_pure_iff] at hcanonical + have hresultEq : result = + { rawResult with + context := canonicalizeMaterializedValues table rawResult.context } := + Option.some.inj hcanonical + subst result + have hcore := resolvedCore_of_mem_runResolvedFromTable + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache) + context fuel table rawResult hconsistent hstarts hraw + have hrawCompletion : DeferredCompletion table rawResult.context completion := + hcompletion.of_canonicalizeMaterializedValues hcore.2.1 hcore.2.2 + exact hrawCompletion.of_mem_runResolvedFromTable _ context fuel table rawResult completion + hconsistent hstarts hraw + +set_option maxRecDepth 100000 in +theorem DeferredCompletion.of_mem_runSynchronizedResolved_canonicalChronological + {parameter : PublicParameter} {root : Digest} + {table : OtsSecretIndex → HashOutput} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) + (completion : Coordinate → HashOutput) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (runSynchronizedResolved + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + computation context fuel table cache)) + (hcompletion : DeferredCompletion table result.context completion) : + DeferredCompletion table context completion := by + induction computation using OracleComp.inductionOn generalizing context fuel cache result with + | pure value => + by_cases hcompletable : DeferredCompletable table context + · rw [runSynchronizedResolved_pure _ value context fuel table cache hcompletable] at hresult + simp only [mem_support_pure_iff, Option.some.injEq] at hresult + subst result + exact hcompletion + · rw [runSynchronizedResolved_pure_of_not_completable _ value context fuel table cache + hcompletable] at hresult + simp at hresult + | query_bind input next ih => + rw [runSynchronizedResolved, OracleComp.construct_query_bind] at hresult + by_cases hcompletable : DeferredCompletable table context + · simp only [dif_pos hcompletable, mem_support_bind_iff] at hresult + obtain ⟨stepOption, hstep, htail⟩ := hresult + cases stepOption with + | none => simp at htail + | some stepResult => + have hstepCore := + resolvedCore_of_mem_canonicalChronologicalAdversaryImpl parameter root table + ftsSecret input context fuel cache stepResult hconsistent hstarts hstep + change some result ∈ support + (runSynchronizedResolved + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (next stepResult.value.1) stepResult.context stepResult.remaining + stepResult.table stepResult.value.2) at htail + rw [hstepCore.1] at htail + have hstepCompletion := ih stepResult.value.1 stepResult.context + stepResult.remaining stepResult.value.2 result hstepCore.2.1 hstepCore.2.2 htail + hcompletion + exact hstepCompletion.of_mem_canonicalChronologicalAdversaryImpl hconsistent hstarts + hstep + · simp [hcompletable] at hresult + +set_option maxRecDepth 100000 in +theorem resolvedCore_of_mem_runSynchronizedResolved_canonicalChronological + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (runSynchronizedResolved + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + computation context fuel table cache)) : + result.table = table ∧ result.context.ValuesConsistent ∧ + StartTableAgrees result.context.state table := by + induction computation using OracleComp.inductionOn generalizing context fuel cache result with + | pure value => + by_cases hcompletable : DeferredCompletable table context + · rw [runSynchronizedResolved_pure _ value context fuel table cache hcompletable] at hresult + simp only [mem_support_pure_iff, Option.some.injEq] at hresult + subst result + exact ⟨rfl, hconsistent, hstarts⟩ + · rw [runSynchronizedResolved_pure_of_not_completable _ value context fuel table cache + hcompletable] at hresult + simp at hresult + | query_bind input next ih => + rw [runSynchronizedResolved, OracleComp.construct_query_bind] at hresult + by_cases hcompletable : DeferredCompletable table context + · simp only [dif_pos hcompletable, mem_support_bind_iff] at hresult + obtain ⟨stepOption, hstep, htail⟩ := hresult + cases stepOption with + | none => simp at htail + | some stepResult => + have hstepCore := + resolvedCore_of_mem_canonicalChronologicalAdversaryImpl parameter root table + ftsSecret input context fuel cache stepResult hconsistent hstarts hstep + change some result ∈ support + (runSynchronizedResolved + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (next stepResult.value.1) stepResult.context stepResult.remaining + stepResult.table stepResult.value.2) at htail + rw [hstepCore.1] at htail + exact ih stepResult.value.1 stepResult.context stepResult.remaining + stepResult.value.2 result hstepCore.2.1 hstepCore.2.2 htail + · simp [hcompletable] at hresult + +set_option maxRecDepth 100000 in +theorem relTriple_runSynchronizedResolved_reachable + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {leftImpl : ResolvedQueryImpl spec} + {rightImpl : QueryImpl spec (StateT (QueryCache HashSpec) ProbComp)} + (himpl : CanonicalReachableResolvedImplCouples parameter table leftImpl rightImpl) + (computation : OracleComp spec α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) : + RelTriple + (runSynchronizedResolved leftImpl computation context fuel table cache) + ((simulateQ rightImpl computation).run concreteCache) + (ReachableResolvedRunRel parameter table) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache concreteCache + with + | pure value => + rw [runSynchronizedResolved_pure leftImpl value context fuel table cache + hinvariant.2.2.2.1, + simulateQ_pure] + simp only [StateT.run_pure] + exact relTriple_pure_pure + (Or.inl ⟨rfl, rfl, hinvariant, hclosed, hpublished⟩) + | query_bind query next ih => + rw [runSynchronizedResolved, OracleComp.construct_query_bind, + simulateQ_query_bind, StateT.run_bind] + simp only [OracleQuery.input_query, dif_pos hinvariant.2.2.2.1] + apply relTriple_bind + (himpl query context fuel cache concreteCache hinvariant hclosed hpublished) + intro leftResult rightResult hrelation + cases leftResult with + | none => + have hbase := relTriple_true + (pure none : ProbComp (Option (ResolvedRunResult (α × SplitHashCache)))) + ((simulateQ rightImpl (next rightResult.1)).run rightResult.2) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun finalLeft => finalLeft = none) (by + intro finalLeft hsupport + simpa using hsupport) + apply relTriple_post_mono hsupported + intro finalLeft _ hfinal + rw [hfinal.2] + trivial + | some result => + rcases hrelation with hclean | hdoomed + · rcases rightResult with ⟨rightValue, rightCache⟩ + have hvalue : result.value.1 = rightValue := hclean.2.1 + subst rightValue + change RelTriple + (runSynchronizedResolved leftImpl (next result.value.1) result.context + result.remaining result.table result.value.2) + ((simulateQ rightImpl (next result.value.1)).run rightCache) + (ReachableResolvedRunRel parameter table) + rw [hclean.1] + exact ih result.value.1 result.context result.remaining result.value.2 rightCache + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 + · have hnotCompletable : + ¬DeferredCompletable result.table result.context := by + rw [hdoomed.1] + exact hdoomed.2.2.2 + change RelTriple + (runSynchronizedResolved leftImpl (next result.value.1) result.context + result.remaining result.table result.value.2) + ((simulateQ rightImpl (next rightResult.1)).run rightResult.2) + (ReachableResolvedRunRel parameter table) + rw [runSynchronizedResolved_of_not_completable leftImpl + (next result.value.1) result.context result.remaining result.table result.value.2 + hnotCompletable] + have hbase := relTriple_true + (pure none : ProbComp (Option (ResolvedRunResult (α × SplitHashCache)))) + ((simulateQ rightImpl (next rightResult.1)).run rightResult.2) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun finalLeft => finalLeft = none) (by + intro finalLeft hsupport + simpa using hsupport) + apply relTriple_post_mono hsupported + intro finalLeft _ hfinal + rw [hfinal.2] + trivial + +theorem concreteSupport_of_mem_runSynchronizedResolved + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {leftImpl : ResolvedQueryImpl spec} + {rightImpl : QueryImpl spec (StateT (QueryCache HashSpec) ProbComp)} + (himpl : CanonicalReachableResolvedImplCouples parameter table leftImpl rightImpl) + (computation : OracleComp spec α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (result : ResolvedRunResult (α × SplitHashCache)) + (completion : Coordinate → HashOutput) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hresult : some result ∈ support + (runSynchronizedResolved leftImpl computation context fuel table cache)) + (hcompletion : DeferredCompletion table result.context completion) : + ∃ rightCache, + ResolvedContextInvariant parameter table result.context + (ordinaryQueryCache result.value.2) rightCache ∧ + VisibleResolvedComputationsCached parameter table result.context rightCache ∧ + PublishedValues result.context.state ∧ + (result.value.1, rightCache) ∈ support + ((simulateQ rightImpl computation).run concreteCache) := by + have hrel := relTriple_runSynchronizedResolved_reachable himpl computation context fuel cache + concreteCache hinvariant hclosed hpublished + obtain ⟨rightResult, hrightSupport, hrelation⟩ := + exists_right_of_relTriple_of_mem_support hrel hresult + rcases rightResult with ⟨rightValue, rightCache⟩ + have hclean := hrelation.clean_of_completion hcompletion + refine ⟨rightCache, hclean.2.1, hclean.2.2.1, hclean.2.2.2, ?_⟩ + rw [hclean.1] + exact hrightSupport + +theorem CacheAgreesWithFnOffTable.of_reachableRelTriple + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {leftRun : ProbComp (Option (ResolvedRunResult (α × SplitHashCache)))} + {rightRun : ProbComp (α × QueryCache HashSpec)} + {context : DeferredContext} {cache concreteCache : QueryCache HashSpec} + {result : ResolvedRunResult (α × SplitHashCache)} + {completion : Coordinate → HashOutput} {fallback : QueryImpl HashSpec Id} + (hrelation : RelTriple leftRun rightRun + (ReachableResolvedRunRel parameter table)) + (hinvariant : ResolvedContextInvariant parameter table context cache concreteCache) + (hresult : some result ∈ support leftRun) + (hcompletion : DeferredCompletion table result.context completion) + (hfinal : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback) + (hrightLe : ∀ value finalCache, + (value, finalCache) ∈ support rightRun → concreteCache ≤ finalCache) : + CacheAgreesWithFnOffTable parameter completion cache fallback := by + obtain ⟨rightResult, hrightSupport, hresultRelation⟩ := + exists_right_of_relTriple_of_mem_support hrelation hresult + rcases rightResult with ⟨rightValue, rightCache⟩ + obtain ⟨_value, hfinalInvariant, _hfinalClosed, _hfinalPublished⟩ := + hresultRelation.clean_of_completion hcompletion + intro input output hoff hcached + have hconcrete : concreteCache input = some output := + hinvariant.2.2.2.2.1 input output hcached + have hright : rightCache input = some output := + hrightLe rightValue rightCache hrightSupport hconcrete + rcases hfinalInvariant.2.2.2.2.2 input output hright with hordinary | hfixed + · exact hfinal input output hoff hordinary + · rcases hfixed with ⟨position, hots, _hvalue, hinput⟩ + exact False.elim (hoff position hots (hinput completion hcompletion)) + + +set_option maxRecDepth 100000 in +theorem synchronizedResolvedImplCouples_canonicalAdversaryImpl + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + SynchronizedResolvedImplCouples table + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (canonicalDeferredAdversaryImpl parameter root table ftsSecret) := by + intro query left right fuel leftCache rightCache hcontext hvalues hcache hrevealed + cases query with + | inl oracleQuery => + apply relTriple_bind + (finalizationSynchronizedCouples_probingRomImpl table parameter oracleQuery + left right fuel leftCache rightCache hcontext hvalues hcache hrevealed) + intro leftResult rightResult hrelation + apply relTriple_pure_pure + exact finalizationSynchronizedRunEq_canonicalize table leftResult rightResult + hrelation.toAdaptive + | inr message => + exact relTriple_canonicalized_maskedPublishedChronologicalSign parameter root table + ftsSecret message left right fuel leftCache rightCache hcontext hcache hrevealed + +set_option maxRecDepth 100000 in +theorem relTriple_canonical_adversaryExecution + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (left right : DeferredContext) (fuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) : + RelTriple + (runSynchronizedResolved + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + computation left fuel table leftCache) + (runSynchronizedResolved + (canonicalDeferredAdversaryImpl parameter root table ftsSecret) + computation right fuel table rightCache) + (FinalizationSynchronizedRunEq table) := + relTriple_runSynchronizedResolved + (synchronizedResolvedImplCouples_canonicalAdversaryImpl parameter root table ftsSecret) + computation left right fuel leftCache rightCache hcontext hvalues hcache hrevealed + +noncomputable def canonicalVerifierFinish + (parameter : PublicParameter) (root : Digest) + (forgeryLog : Forgery × QueryLog SigningSpec) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) RetainedGameResult := do + let verified ← simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgeryLog.1.message forgeryLog.1.signature) + pure (root, (forgeryLog, verified)) + +noncomputable def concreteVerifierFinish + (parameter : PublicParameter) (root : Digest) + (forgeryLog : Forgery × QueryLog SigningSpec) : + StateT (QueryCache HashSpec) ProbComp RetainedGameResult := do + let verified ← simulateQ romImpl + (scheme.verify ⟨root, parameter⟩ forgeryLog.1.message forgeryLog.1.signature) + pure (root, (forgeryLog, verified)) + +theorem concreteVerifierFinish_cache_le + (parameter : PublicParameter) (root : Digest) + (forgeryLog : Forgery × QueryLog SigningSpec) + (initialCache : QueryCache HashSpec) + (result : RetainedGameResult × QueryCache HashSpec) + (hresult : result ∈ support + ((concreteVerifierFinish parameter root forgeryLog).run initialCache)) : + initialCache ≤ result.2 := by + unfold concreteVerifierFinish at hresult + rw [StateT.run_bind, mem_support_bind_iff] at hresult + obtain ⟨verifiedResult, hverified, hfinish⟩ := hresult + simp only [StateT.run_pure, mem_support_pure_iff] at hfinish + subst result + exact simulateQ_romImpl_cache_le + (scheme.verify ⟨root, parameter⟩ forgeryLog.1.message forgeryLog.1.signature) + initialCache verifiedResult hverified + +theorem reachableResolvedCouples_canonicalVerifierFinish + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (forgeryLog : Forgery × QueryLog SigningSpec) : + ReachableResolvedCouples parameter table + (canonicalVerifierFinish parameter root forgeryLog) + (concreteVerifierFinish parameter root forgeryLog) := by + unfold canonicalVerifierFinish concreteVerifierFinish + apply (reachableResolvedCouples_probingRom parameter table + (scheme.verify ⟨root, parameter⟩ forgeryLog.1.message + forgeryLog.1.signature)).bind + intro verified + exact reachableResolvedCouples_pure parameter table (root, (forgeryLog, verified)) + +theorem finalizationSynchronizedCouples_canonicalVerifierFinish + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (forgeryLog : Forgery × QueryLog SigningSpec) : + FinalizationSynchronizedCouples table + (canonicalVerifierFinish parameter root forgeryLog) + (canonicalVerifierFinish parameter root forgeryLog) := by + unfold canonicalVerifierFinish + apply (finalizationSynchronizedCouples_probingRom table parameter + (scheme.verify ⟨root, parameter⟩ forgeryLog.1.message + forgeryLog.1.signature)).bind + intro verified + exact finalizationSynchronizedCouples_pure table (root, (forgeryLog, verified)) + +noncomputable def canonicalVerifierContinuation + (parameter : PublicParameter) (root : Digest) + (result : Option (ResolvedRunResult + ((Forgery × QueryLog SigningSpec) × SplitHashCache))) : + ProbComp (Option (ResolvedRunResult (RetainedGameResult × SplitHashCache))) := + match result with + | none => pure none + | some result => + runResolvedFromTable result.context result.remaining result.table + ((canonicalVerifierFinish parameter root result.value.1).run result.value.2) + +theorem relTriple_canonicalVerifierContinuation + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (left right : Option (ResolvedRunResult + ((Forgery × QueryLog SigningSpec) × SplitHashCache))) + (hrelation : FinalizationSynchronizedRunEq table left right) : + RelTriple + (canonicalVerifierContinuation parameter root left) + (canonicalVerifierContinuation parameter root right) + (FinalizationSynchronizedRunEq table) := by + rcases hrelation with hclean | hdoomed + · cases left with + | none => + cases right with + | none => simp [canonicalVerifierContinuation, FinalizationSynchronizedRunEq, + FinalizationMaterializedRunEq, MaterializedValuesEq] + | some right => simp [FinalizationMaterializedRunEq] at hclean + | some left => + cases right with + | none => simp [FinalizationMaterializedRunEq] at hclean + | some right => + rcases left with ⟨leftContext, leftFuel, leftValue, leftTable⟩ + rcases right with ⟨rightContext, rightFuel, rightValue, rightTable⟩ + rcases leftValue with ⟨leftOutput, leftCache⟩ + rcases rightValue with ⟨rightOutput, rightCache⟩ + simp only [FinalizationMaterializedRunEq, MaterializedValuesEq] at hclean + rcases hclean.1 with + ⟨houtput, hcontext, hfuel, hleftTable, hrightTable, hcache, hrevealed⟩ + subst rightOutput + subst rightFuel + subst leftTable + subst rightTable + exact finalizationSynchronizedCouples_canonicalVerifierFinish parameter root table + leftOutput leftContext rightContext leftFuel leftCache rightCache hcontext + hclean.2 hcache hrevealed + · cases left with + | none => + cases right with + | none => simp [canonicalVerifierContinuation, FinalizationSynchronizedRunEq, + FinalizationDoomedRun] + | some right => + simp only [canonicalVerifierContinuation] + rw [hdoomed.2.1] + exact relTriple_pure_none_runResolvedFromTable_of_finalizationDoomed_synchronized + table ((canonicalVerifierFinish parameter root right.value.1).run right.value.2) + right.context right.remaining hdoomed.2.2 + | some left => + cases right with + | none => + simp only [canonicalVerifierContinuation] + rw [hdoomed.1.1] + exact relTriple_runResolvedFromTable_pure_none_of_finalizationDoomed_synchronized + table ((canonicalVerifierFinish parameter root left.value.1).run left.value.2) + left.context left.remaining hdoomed.1.2 + | some right => + simp only [canonicalVerifierContinuation] + rw [hdoomed.1.1, hdoomed.2.1] + exact relTriple_runResolvedFromTable_of_finalizationDoomed_synchronized table + ((canonicalVerifierFinish parameter root left.value.1).run left.value.2) + ((canonicalVerifierFinish parameter root right.value.1).run right.value.2) + left.context right.context left.remaining right.remaining hdoomed.1.2 hdoomed.2.2 + +theorem relTriple_canonicalVerifierContinuation_reachable + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (left : Option (ResolvedRunResult + ((Forgery × QueryLog SigningSpec) × SplitHashCache))) + (right : (Forgery × QueryLog SigningSpec) × QueryCache HashSpec) + (hrelation : ReachableResolvedRunRel parameter table left right) : + RelTriple + (canonicalVerifierContinuation parameter root left) + ((concreteVerifierFinish parameter root right.1).run right.2) + (ReachableResolvedRunRel parameter table) := by + cases left with + | none => + have hbase := relTriple_true + (pure none : ProbComp + (Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)))) + ((concreteVerifierFinish parameter root right.1).run right.2) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = none) (by + intro result hsupport + simpa using hsupport) + apply relTriple_post_mono hsupported + intro result _ hsupport + rw [hsupport.2] + trivial + | some result => + rcases hrelation with hclean | hdoomed + · rcases right with ⟨rightValue, rightCache⟩ + have hvalue : result.value.1 = rightValue := hclean.2.1 + subst rightValue + simp only [canonicalVerifierContinuation] + rw [hclean.1] + exact reachableResolvedCouples_canonicalVerifierFinish parameter root table + result.value.1 result.context result.remaining result.value.2 rightCache + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 + · simp only [canonicalVerifierContinuation] + rw [hdoomed.1] + exact relTriple_runResolvedFromTable_of_doomed_reachable parameter table + (canonicalVerifierFinish parameter root result.value.1) + ((concreteVerifierFinish parameter root right.1).run right.2) + result.context result.remaining result.value.2 hdoomed.2 + +noncomputable def canonicalChronologicalRetainedRunAfterFtsSecrets + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp (Option (ResolvedRunResult (RetainedGameResult × SplitHashCache))) := do + let rootResult ← runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure none + | some rootResult => do + let adversaryResult ← runSynchronizedResolved + (canonicalChronologicalAdversaryImpl parameter rootResult.value.1 table ftsSecret) + (signingTraceComputation (adversary.main ⟨rootResult.value.1, parameter⟩)) + rootResult.context rootResult.remaining rootResult.table rootResult.value.2 + canonicalVerifierContinuation parameter rootResult.value.1 adversaryResult + +noncomputable def canonicalDeferredRetainedRunAfterFtsSecrets + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp (Option (ResolvedRunResult (RetainedGameResult × SplitHashCache))) := do + let rootResult ← runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure none + | some rootResult => do + let adversaryResult ← runSynchronizedResolved + (canonicalDeferredAdversaryImpl parameter rootResult.value.1 table ftsSecret) + (signingTraceComputation (adversary.main ⟨rootResult.value.1, parameter⟩)) + rootResult.context rootResult.remaining rootResult.table rootResult.value.2 + canonicalVerifierContinuation parameter rootResult.value.1 adversaryResult + +set_option maxRecDepth 100000 in +theorem relTriple_canonicalChronologicalRest_reachable + (adversary : Adversary) (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) : + RelTriple + (do + let adversaryResult ← runSynchronizedResolved + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) + context fuel table cache + canonicalVerifierContinuation parameter root adversaryResult) + ((do + let forgeryLog ← simulateQ + (unloggedMappedAdversaryImpl + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey)) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) + concreteVerifierFinish parameter root forgeryLog).run concreteCache) + (ReachableResolvedRunRel parameter table) := by + rw [StateT.run_bind] + apply relTriple_bind + (relTriple_runSynchronizedResolved_reachable + (canonicalReachableResolvedImplCouples_chronologicalAdversaryImpl parameter root table + ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) context fuel cache + concreteCache hinvariant hclosed hpublished) + intro left right hrelation + exact relTriple_canonicalVerifierContinuation_reachable parameter root table left right + hrelation + +set_option maxRecDepth 100000 in +theorem relTriple_canonicalChronologicalRetainedRun_actual + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + RelTriple + (canonicalChronologicalRetainedRunAfterFtsSecrets adversary parameter table ftsSecret fuel) + (actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table)) + (ReachableResolvedRunRel parameter table) := by + rw [← concreteRetainedGameAfterFtsSecrets_run_eq_actual adversary parameter table ftsSecret] + unfold canonicalChronologicalRetainedRunAfterFtsSecrets + concreteRetainedGameAfterFtsSecrets concreteRetainedPrefixAfterFtsSecrets + simp only [StateT.run_bind, StateT.run_pure, bind_assoc, pure_bind] + change RelTriple + (runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) >>= fun rootOption => + match rootOption with + | none => pure none + | some rootResult => do + let adversaryResult ← runSynchronizedResolved + (canonicalChronologicalAdversaryImpl parameter rootResult.value.1 table ftsSecret) + (signingTraceComputation + (adversary.main ⟨rootResult.value.1, parameter⟩)) + rootResult.context rootResult.remaining rootResult.table rootResult.value.2 + canonicalVerifierContinuation parameter rootResult.value.1 adversaryResult) + (((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter topLayer rootTree + (fun leafIdx chainIdx => + truncateHash (table ⟨topLayer, rootTree, leafIdx, chainIdx⟩)) + (layerHeight topLayer) 0)).run ∅) >>= fun rootResult => + (do + let forgeryLog ← simulateQ + (unloggedMappedAdversaryImpl + (⟨parameter, rootResult.1, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey)) + (signingTraceComputation (adversary.main ⟨rootResult.1, parameter⟩)) + concreteVerifierFinish parameter rootResult.1 forgeryLog).run rootResult.2) + (ReachableResolvedRunRel parameter table) + have hroot := reachableResolvedCouples_maskedPublishedTreeRoot parameter table + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel emptySplitHashCache ∅ (resolvedContextInvariant_empty parameter table) + (visibleResolvedComputationsCached_empty parameter table emptyDeferredStructuralValues ∅) + publishedValues_empty + apply relTriple_bind hroot + intro leftRoot rightRoot hrelation + cases leftRoot with + | none => + have hbase := relTriple_true + (pure none : ProbComp + (Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)))) + ((do + let forgeryLog ← simulateQ + (unloggedMappedAdversaryImpl + (⟨parameter, rightRoot.1, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey)) + (signingTraceComputation (adversary.main ⟨rightRoot.1, parameter⟩)) + concreteVerifierFinish parameter rightRoot.1 forgeryLog).run rightRoot.2) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = none) (by + intro result hsupport + simpa using hsupport) + apply relTriple_post_mono hsupported + intro result _ hsupport + rw [hsupport.2] + trivial + | some rootResult => + rcases hrelation with hclean | hdoomed + · rcases rightRoot with ⟨rightRoot, rightCache⟩ + have hrootValue : rootResult.value.1 = rightRoot := hclean.2.1 + subst rightRoot + simp only + rw [hclean.1] + exact relTriple_canonicalChronologicalRest_reachable adversary parameter + rootResult.value.1 table ftsSecret rootResult.context rootResult.remaining + rootResult.value.2 rightCache hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 + · have hnotCompletable : + ¬DeferredCompletable rootResult.table rootResult.context := by + rw [hdoomed.1] + exact hdoomed.2.2.2 + simp only + rw [runSynchronizedResolved_of_not_completable + (canonicalChronologicalAdversaryImpl parameter rootResult.value.1 table ftsSecret) + (signingTraceComputation (adversary.main ⟨rootResult.value.1, parameter⟩)) + rootResult.context rootResult.remaining rootResult.table rootResult.value.2 + hnotCompletable] + simp only [canonicalVerifierContinuation] + have hbase := relTriple_true + (pure none : ProbComp + (Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)))) + ((do + let forgeryLog ← simulateQ + (unloggedMappedAdversaryImpl + (⟨parameter, rightRoot.1, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey)) + (signingTraceComputation (adversary.main ⟨rightRoot.1, parameter⟩)) + concreteVerifierFinish parameter rightRoot.1 forgeryLog).run rightRoot.2) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = none) (by + intro result hsupport + simpa using hsupport) + apply relTriple_post_mono hsupported + intro result _ hsupport + rw [hsupport.2] + trivial + + + +theorem finalizationContextEq_empty (table : OtsSecretIndex → HashOutput) : + FinalizationContextEq table + (some + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues }) + (some + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues }) := by + let context : DeferredContext := + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + have hclean : ∀ coordinate output, + resolvedCompletionValue table context coordinate = some output → + ¬context.state.hitAt coordinate output := by + intro coordinate output _hvalue + simp [context, LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, + LazyRevealProbe.State.empty] + exact ⟨FinalizationViewEq.refl table context DeferredContext.valid_empty + (startTableAgrees_empty table) hclean, + DeferredContext.valid_empty, DeferredContext.valid_empty, + deferredCompletable_empty table⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_canonicalRetainedRunAfterFtsSecrets + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + RelTriple + (canonicalChronologicalRetainedRunAfterFtsSecrets adversary parameter table ftsSecret fuel) + (canonicalDeferredRetainedRunAfterFtsSecrets adversary parameter table ftsSecret fuel) + (FinalizationSynchronizedRunEq table) := by + unfold canonicalChronologicalRetainedRunAfterFtsSecrets + canonicalDeferredRetainedRunAfterFtsSecrets + let emptyContext : DeferredContext := + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + have hroot := finalizationSynchronizedCouples_maskedPublishedTreeRoot table + emptyContext emptyContext fuel emptySplitHashCache emptySplitHashCache + (finalizationContextEq_empty table) rfl rfl rfl + apply relTriple_bind hroot + intro leftRootResult rightRootResult hrootRelation + rcases hrootRelation with hrootClean | hrootDoomed + · cases leftRootResult with + | none => + cases rightRootResult with + | none => simp [FinalizationSynchronizedRunEq, FinalizationMaterializedRunEq, + MaterializedValuesEq] + | some right => simp [FinalizationMaterializedRunEq] at hrootClean + | some leftRootResult => + cases rightRootResult with + | none => simp [FinalizationMaterializedRunEq] at hrootClean + | some rightRootResult => + rcases leftRootResult with + ⟨leftContext, leftFuel, leftValue, leftTable⟩ + rcases rightRootResult with + ⟨rightContext, rightFuel, rightValue, rightTable⟩ + rcases leftValue with ⟨leftRoot, leftCache⟩ + rcases rightValue with ⟨rightRoot, rightCache⟩ + simp only [FinalizationMaterializedRunEq, MaterializedValuesEq] at hrootClean + rcases hrootClean.1 with + ⟨hroot, hcontext, hfuel, hleftTable, hrightTable, hcache, hrevealed⟩ + subst rightRoot + subst rightFuel + subst leftTable + subst rightTable + apply relTriple_bind + (relTriple_canonical_adversaryExecution parameter leftRoot table ftsSecret + (signingTraceComputation (adversary.main ⟨leftRoot, parameter⟩)) + leftContext rightContext leftFuel leftCache rightCache hcontext hrootClean.2 + hcache hrevealed) + intro leftAdversaryResult rightAdversaryResult hadversary + exact relTriple_canonicalVerifierContinuation parameter leftRoot table + leftAdversaryResult rightAdversaryResult hadversary + · cases leftRootResult with + | none => + cases rightRootResult with + | none => simp [FinalizationSynchronizedRunEq, FinalizationDoomedRun] + | some rightRootResult => + have hrightTable := hrootDoomed.2.1 + have hrightNotCompletable : + ¬DeferredCompletable rightRootResult.table rightRootResult.context := by + rw [hrightTable] + exact hrootDoomed.2.2.2.2 + simp only + rw [runSynchronizedResolved_of_not_completable] + · simp [canonicalVerifierContinuation, FinalizationSynchronizedRunEq, + FinalizationDoomedRun] + · exact hrightNotCompletable + | some leftRootResult => + cases rightRootResult with + | none => + have hleftTable := hrootDoomed.1.1 + have hleftNotCompletable : + ¬DeferredCompletable leftRootResult.table leftRootResult.context := by + rw [hleftTable] + exact hrootDoomed.1.2.2.2 + simp only + rw [runSynchronizedResolved_of_not_completable] + · simp [canonicalVerifierContinuation, FinalizationSynchronizedRunEq, + FinalizationDoomedRun] + · exact hleftNotCompletable + | some rightRootResult => + have hleftTable := hrootDoomed.1.1 + have hrightTable := hrootDoomed.2.1 + have hleftNotCompletable : + ¬DeferredCompletable leftRootResult.table leftRootResult.context := by + rw [hleftTable] + exact hrootDoomed.1.2.2.2 + have hrightNotCompletable : + ¬DeferredCompletable rightRootResult.table rightRootResult.context := by + rw [hrightTable] + exact hrootDoomed.2.2.2.2 + simp only + rw [runSynchronizedResolved_of_not_completable, + runSynchronizedResolved_of_not_completable] + · simp [canonicalVerifierContinuation, FinalizationSynchronizedRunEq, + FinalizationDoomedRun] + · exact hrightNotCompletable + · exact hleftNotCompletable + +theorem relTriple_canonicalRetainedFinishIsNone + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + RelTriple + (canonicalChronologicalRetainedRunAfterFtsSecrets adversary parameter table ftsSecret fuel + >>= finishResolvedRunIsNone) + (canonicalDeferredRetainedRunAfterFtsSecrets adversary parameter table ftsSecret fuel >>= + finishResolvedRunIsNone) + (EqRel Bool) := by + apply relTriple_bind + (relTriple_canonicalRetainedRunAfterFtsSecrets adversary parameter table ftsSecret fuel) + intro left right hrelation + exact relTriple_finishResolvedRunIsNone_of_finalizationAdaptiveRunEq table left right + hrelation.toAdaptive + +theorem prob_canonicalChronologicalRetainedFinishIsNone_eq_deferred + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[= true | + canonicalChronologicalRetainedRunAfterFtsSecrets adversary parameter table ftsSecret fuel + >>= finishResolvedRunIsNone] = + Pr[= true | + canonicalDeferredRetainedRunAfterFtsSecrets adversary parameter table ftsSecret fuel >>= + finishResolvedRunIsNone] := + probOutput_true_eq_of_relTriple_eqRel + (relTriple_canonicalRetainedFinishIsNone adversary parameter table ftsSecret fuel) + +def CanonicalFailureRefinementRunEq (table : OtsSecretIndex → HashOutput) : + Option (ResolvedRunResult (α × SplitHashCache)) → + Option (ResolvedRunResult (α × SplitHashCache)) → Prop := + fun left right => + (FinalizationMaterializedRunEq table left right ∧ CanonicalResolvedRun table right) ∨ + FinalizationDoomedRun table right + +theorem canonicalFailureRefinementRunEq_canonicalize_right_of_synchronized + (table : OtsSecretIndex → HashOutput) + (left right : Option (ResolvedRunResult (α × SplitHashCache))) + (hrelation : FinalizationSynchronizedRunEq table left right) : + CanonicalFailureRefinementRunEq table left (canonicalizeResolvedRun table right) := by + rcases hrelation with hclean | hdoomed + · cases left with + | none => + cases right with + | none => exact Or.inl ⟨trivial, trivial⟩ + | some right => simp [FinalizationMaterializedRunEq] at hclean + | some left => + cases right with + | none => simp [FinalizationMaterializedRunEq] at hclean + | some right => + rcases hclean.1 with + ⟨hvalue, hcontext, hremaining, hleftTable, hrightTable, hcache, hrevealed⟩ + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hrightCanonicalView := finalizationViewEq_canonicalize_left table right.context + hrightValid hview.rightStarts hview.rightClean + have hrightCanonicalValid := canonicalizeMaterializedValues_valid table right.context + hrightValid hview.rightClean + left + constructor + · exact ⟨hvalue, + ⟨hview.trans hrightCanonicalView.symm, hleftValid, + hrightCanonicalValid, hleftCompletable⟩, + hremaining, hleftTable, hrightTable, hcache, by + simpa [canonicalizeResolvedRun, + canonicalizeMaterializedValues_revealed] using hrevealed⟩ + · exact canonicalizeMaterializedValues_canonical table right.context + hrightValid.valuesConsistent + · right + cases right with + | none => trivial + | some right => + exact ⟨hdoomed.2.1, + doomedResolvedContext_canonicalizeMaterializedValues hdoomed.2.2⟩ + +theorem relTriple_canonicalize_right_of_synchronized + (table : OtsSecretIndex → HashOutput) + (leftRun rightRun : ProbComp + (Option (ResolvedRunResult (α × SplitHashCache)))) + (hrelation : RelTriple leftRun rightRun + (FinalizationSynchronizedRunEq table)) : + RelTriple leftRun + (rightRun >>= fun result => pure (canonicalizeResolvedRun table result)) + (CanonicalFailureRefinementRunEq table) := by + rw [← bind_pure leftRun] + apply relTriple_bind hrelation + intro left right hsync + apply relTriple_pure_pure + exact canonicalFailureRefinementRunEq_canonicalize_right_of_synchronized table left right + hsync + +def CanonicalRefinementResolvedImplCouples (table : OtsSecretIndex → HashOutput) + (leftImpl rightImpl : ResolvedQueryImpl spec) : Prop := + ∀ query left right fuel leftCache rightCache, + FinalizationContextEq table (some left) (some right) → + CanonicalMaterializedValues table right → + ordinaryQueryCache leftCache = ordinaryQueryCache rightCache → + left.state.revealed = right.state.revealed → + RelTriple + (leftImpl query left fuel table leftCache) + (rightImpl query right fuel table rightCache) + (CanonicalFailureRefinementRunEq table) + +set_option maxRecDepth 100000 in +theorem relTriple_runSynchronizedResolved_canonicalRefinement + {table : OtsSecretIndex → HashOutput} + {leftImpl rightImpl : ResolvedQueryImpl spec} + (himpl : CanonicalRefinementResolvedImplCouples table leftImpl rightImpl) + (computation : OracleComp spec α) + (left right : DeferredContext) (fuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hrightCanonical : CanonicalMaterializedValues table right) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) : + RelTriple + (runSynchronizedResolved leftImpl computation left fuel table leftCache) + (runSynchronizedResolved rightImpl computation right fuel table rightCache) + (CanonicalFailureRefinementRunEq table) := by + induction computation using OracleComp.inductionOn generalizing left right fuel leftCache + rightCache with + | pure value => + have hleftCompletable := hcontext.2.2.2 + have hrightCompletable : DeferredCompletable table right := by + rcases hleftCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, (hcontext.1.deferredCompletion_iff completion).mp hcompletion⟩ + rw [runSynchronizedResolved_pure leftImpl value left fuel table leftCache + hleftCompletable, + runSynchronizedResolved_pure rightImpl value right fuel table rightCache + hrightCompletable] + apply relTriple_pure_pure + left + exact ⟨⟨rfl, hcontext, rfl, rfl, rfl, hcache, hrevealed⟩, + hrightCanonical⟩ + | query_bind query next ih => + have hleftCompletable := hcontext.2.2.2 + have hrightCompletable : DeferredCompletable table right := by + rcases hleftCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, (hcontext.1.deferredCompletion_iff completion).mp hcompletion⟩ + rw [runSynchronizedResolved, OracleComp.construct_query_bind, + runSynchronizedResolved, OracleComp.construct_query_bind] + simp only [dif_pos hleftCompletable, dif_pos hrightCompletable] + apply relTriple_bind + (himpl query left right fuel leftCache rightCache hcontext hrightCanonical hcache + hrevealed) + intro leftResult rightResult hrelation + rcases hrelation with hclean | hrightDoomed + · cases leftResult with + | none => + cases rightResult with + | none => simp [CanonicalFailureRefinementRunEq, FinalizationMaterializedRunEq, + CanonicalResolvedRun] + | some rightResult => simp [FinalizationMaterializedRunEq] at hclean + | some leftResult => + cases rightResult with + | none => simp [FinalizationMaterializedRunEq] at hclean + | some rightResult => + rcases leftResult with ⟨leftContext, leftFuel, leftValue, leftTable⟩ + rcases rightResult with ⟨rightContext, rightFuel, rightValue, rightTable⟩ + rcases leftValue with ⟨leftOutput, nextLeftCache⟩ + rcases rightValue with ⟨rightOutput, nextRightCache⟩ + simp only [FinalizationMaterializedRunEq, CanonicalResolvedRun] at hclean + rcases hclean.1 with + ⟨houtput, hnextContext, hnextFuel, hleftTable, hrightTable, + hnextCache, hnextRevealed⟩ + subst rightOutput + subst rightFuel + subst leftTable + subst rightTable + exact ih leftOutput leftContext rightContext leftFuel nextLeftCache nextRightCache + hnextContext hclean.2 hnextCache hnextRevealed + · have hbase := relTriple_true + (match leftResult with + | none => pure none + | some result => + runSynchronizedResolved leftImpl (next result.value.1) result.context + result.remaining result.table result.value.2) + (match rightResult with + | none => pure none + | some result => + runSynchronizedResolved rightImpl (next result.value.1) result.context + result.remaining result.table result.value.2) + have hright := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + apply relTriple_post_mono hright + intro _ rightFinal hsupport + right + cases rightResult with + | none => + have hnone : rightFinal = none := by simpa using hsupport.2 + subst rightFinal + trivial + | some rightResult => + have hrightTable := hrightDoomed.1 + have hnotCompletable : + ¬DeferredCompletable rightResult.table rightResult.context := by + rw [hrightTable] + exact hrightDoomed.2.2.2 + have hrun := runSynchronizedResolved_of_not_completable rightImpl + (next rightResult.value.1) rightResult.context rightResult.remaining + rightResult.table rightResult.value.2 hnotCompletable + have hnone : rightFinal = none := by + simp only at hsupport + rw [hrun] at hsupport + simpa using hsupport.2 + subst rightFinal + trivial + +theorem relTriple_finishResolvedRunIsNone_of_canonicalFailureRefinement + (table : OtsSecretIndex → HashOutput) + (left right : Option (ResolvedRunResult (α × SplitHashCache))) + (hrelation : CanonicalFailureRefinementRunEq table left right) : + RelTriple (finishResolvedRunIsNone left) (finishResolvedRunIsNone right) + (fun leftFailed rightFailed => leftFailed = true → rightFailed = true) := by + rcases hrelation with hclean | hrightDoomed + · apply relTriple_post_mono + (relTriple_finishResolvedRunIsNone_of_finalizationMaterializedRunEq table left right + hclean.1) + intro leftFailed rightFailed heq hleft + rw [← heq] + exact hleft + · cases right with + | none => + have hright : finishResolvedRunIsNone + (none : Option (ResolvedRunResult (α × SplitHashCache))) = pure true := by + simp [finishResolvedRunIsNone, finishResolvedRun] + rw [hright] + have hbase := relTriple_true (finishResolvedRunIsNone left) + (pure true : ProbComp Bool) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + apply relTriple_post_mono hsupported + intro leftFailed rightFailed hsupport _hleft + simpa using hsupport.2 + | some right => + have hrightTable := hrightDoomed.1 + have hnotCompletable : ¬DeferredCompletable right.table right.context := by + rw [hrightTable] + exact hrightDoomed.2.2.2 + have hright : finishResolvedRunIsNone (some right) = pure true := by + unfold finishResolvedRunIsNone + rw [finishResolvedRun_of_not_deferredCompletable right hnotCompletable] + simp + rw [hright] + have hbase := relTriple_true (finishResolvedRunIsNone left) + (pure true : ProbComp Bool) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + apply relTriple_post_mono hsupported + intro leftFailed rightFailed hsupport _hleft + simpa using hsupport.2 + +theorem prob_finishResolvedRunIsNone_le_of_canonicalFailureRefinement + (table : OtsSecretIndex → HashOutput) + (leftRun rightRun : ProbComp + (Option (ResolvedRunResult (α × SplitHashCache)))) + (hrelation : RelTriple leftRun rightRun + (CanonicalFailureRefinementRunEq table)) : + Pr[= true | leftRun >>= finishResolvedRunIsNone] ≤ + Pr[= true | rightRun >>= finishResolvedRunIsNone] := by + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput] + apply probEvent_le_of_relTriple + (p := fun failed : Bool => failed = true) + (q := fun failed : Bool => failed = true) + (relTriple_bind hrelation fun left right hresult => + relTriple_finishResolvedRunIsNone_of_canonicalFailureRefinement table left right hresult) + intro leftFailed rightFailed himp hleft + exact himp hleft + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveVerifier.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveVerifier.lean new file mode 100644 index 00000000..ca58f370 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveVerifier.lean @@ -0,0 +1,152 @@ +import SphincsSecurity.Proof.OtsProbeResolvedAdaptivePublication + +/-! +# Canonical verifier boundary for adaptive one-time probes +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option maxRecDepth 100000 in +theorem canonicalVerifierContinuation_value_of_mem_support + (parameter : PublicParameter) (root : Digest) + (adversaryResult : ResolvedRunResult + ((Forgery × QueryLog SigningSpec) × SplitHashCache)) + (result : ResolvedRunResult (RetainedGameResult × SplitHashCache)) + (hresult : some result ∈ support + (canonicalVerifierContinuation parameter root (some adversaryResult))) : + result.value.1.1 = root ∧ result.value.1.2.1 = adversaryResult.value.1 := by + simp only [canonicalVerifierContinuation] at hresult + unfold canonicalVerifierFinish at hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨verifierOption, _hverifier, hfinish⟩ := hresult + cases verifierOption with + | none => simp at hfinish + | some verifierResult => + simp [runResolvedFromTable] at hfinish + subst result + exact ⟨rfl, rfl⟩ + +set_option maxRecDepth 100000 in +theorem DeferredCompletion.of_mem_canonicalVerifierContinuation + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (adversaryResult : ResolvedRunResult + ((Forgery × QueryLog SigningSpec) × SplitHashCache)) + (result : ResolvedRunResult (RetainedGameResult × SplitHashCache)) + (completion : Coordinate → HashOutput) + (htable : adversaryResult.table = table) + (hresult : some result ∈ support + (canonicalVerifierContinuation parameter root (some adversaryResult))) + (hconsistent : adversaryResult.context.ValuesConsistent) + (hstarts : StartTableAgrees adversaryResult.context.state table) + (hcompletion : DeferredCompletion table result.context completion) : + DeferredCompletion table adversaryResult.context completion := by + simp only [canonicalVerifierContinuation] at hresult + rw [htable] at hresult + unfold canonicalVerifierFinish at hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨verifierOption, hverifier, hfinish⟩ := hresult + cases verifierOption with + | none => simp at hfinish + | some verifierResult => + simp [runResolvedFromTable] at hfinish + subst result + exact hcompletion.of_mem_runResolvedFromTable + ((simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ + adversaryResult.value.1.1.message + adversaryResult.value.1.1.signature)).run adversaryResult.value.2) + adversaryResult.context adversaryResult.remaining table verifierResult + completion hconsistent hstarts hverifier + +theorem CacheAgreesWithFnOffTable.of_mem_canonicalVerifierContinuation + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (adversaryResult : ResolvedRunResult + ((Forgery × QueryLog SigningSpec) × SplitHashCache)) + (result : ResolvedRunResult (RetainedGameResult × SplitHashCache)) + (adversaryConcreteCache : QueryCache HashSpec) + (completion : Coordinate → HashOutput) (fallback : QueryImpl HashSpec Id) + (htable : adversaryResult.table = table) + (hresult : some result ∈ support + (canonicalVerifierContinuation parameter root (some adversaryResult))) + (hinvariant : ResolvedContextInvariant parameter table adversaryResult.context + (ordinaryQueryCache adversaryResult.value.2) adversaryConcreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table adversaryResult.context + adversaryConcreteCache) + (hpublished : PublishedValues adversaryResult.context.state) + (hcompletion : DeferredCompletion table result.context completion) + (hfallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback) : + CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache adversaryResult.value.2) fallback := by + have hverifierRel := reachableResolvedCouples_canonicalVerifierFinish parameter root table + adversaryResult.value.1 adversaryResult.context adversaryResult.remaining + adversaryResult.value.2 adversaryConcreteCache hinvariant hclosed hpublished + have hrun : some result ∈ support + (runResolvedFromTable adversaryResult.context adversaryResult.remaining table + ((canonicalVerifierFinish parameter root adversaryResult.value.1).run + adversaryResult.value.2)) := by + simpa only [canonicalVerifierContinuation, htable] using hresult + exact CacheAgreesWithFnOffTable.of_reachableRelTriple hverifierRel hinvariant hrun + hcompletion hfallback (fun value finalCache hright => + concreteVerifierFinish_cache_le parameter root adversaryResult.value.1 + adversaryConcreteCache (value, finalCache) hright) + +set_option maxRecDepth 100000 in +theorem not_verifyProbe_of_mem_canonicalVerifierContinuation + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (targetCache : QueryCache HashSpec) + (completion : Coordinate → HashOutput) (fallback : QueryImpl HashSpec Id) + (adversaryResult : ResolvedRunResult + ((Forgery × QueryLog SigningSpec) × SplitHashCache)) + (adversaryConcreteCache : QueryCache HashSpec) + (result : ResolvedRunResult (RetainedGameResult × SplitHashCache)) + (htable : adversaryResult.table = table) + (hresult : some result ∈ support + (canonicalVerifierContinuation parameter root (some adversaryResult))) + (hinvariant : ResolvedContextInvariant parameter table adversaryResult.context + (ordinaryQueryCache adversaryResult.value.2) adversaryConcreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table adversaryResult.context + adversaryConcreteCache) + (hpublished : PublishedValues adversaryResult.context.state) + (hallowed : RevealedChainAllowed + (CoveredChainCoordinate (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + adversaryResult.value.1.2) + adversaryResult.context.state) + (hcompletion : DeferredCompletion table result.context completion) + (hfallback : CacheAgreesWithFnOffTable parameter completion + (ordinaryQueryCache result.value.2) fallback) + (hprobe : VerifyProbeWitness (tableAnswer parameter completion fallback) targetCache + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + result.value.1.2.1.2 result.value.1.2.1.1.message + result.value.1.2.1.1.signature) : False := by + simp only [canonicalVerifierContinuation] at hresult + rw [htable] at hresult + unfold canonicalVerifierFinish at hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨verifierOption, hverifier, hfinish⟩ := hresult + cases verifierOption with + | none => simp at hfinish + | some verifierResult => + simp [runResolvedFromTable] at hfinish + subst result + exact not_verifyProbe_of_mem_runResolved_verifier parameter table ftsSecret + targetCache root adversaryResult.value.1.1 adversaryResult.value.1.2 completion + fallback adversaryResult.context adversaryResult.remaining adversaryResult.value.2 + adversaryConcreteCache verifierResult hinvariant hclosed hpublished hallowed + hverifier hcompletion hfallback hprobe + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryDirect.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryDirect.lean new file mode 100644 index 00000000..bdc6a67b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryDirect.lean @@ -0,0 +1,757 @@ +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveEndpoint +import SphincsSecurity.Proof.OtsProbeResolvedDirectRecursive + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def directBoundaryObserve + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : ProbComp Bool := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp spec α => + (DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) → + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → ProbComp Bool) + (fun value observe context fuel _table cache => observe context fuel (value, cache)) + (fun query _next recursivelyRun observe context fuel table cache => + runDirectResolvedFromTable context fuel table ((impl query).run cache) >>= + finishObserve (canonicalizeObserve table + (fun nextContext remaining value => + recursivelyRun value.1 observe nextContext remaining table value.2))) + computation observe context fuel table cache + +set_option maxRecDepth 100000 in +theorem directBoundaryObserve_dooms + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + [ObserverDooms table observe] + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) : + evalDist (directBoundaryObserve impl computation observe context fuel table cache) = + evalDist (pure true : ProbComp Bool) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + rw [directBoundaryObserve, OracleComp.construct_pure] + exact ObserverDooms.eq_true context fuel (value, cache) hconsistent hstarts hdoomed + | query_bind query next ih => + rw [directBoundaryObserve, OracleComp.construct_query_bind] + let nextObserve : DeferredContext → Nat → + ((spec.Range query) × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + directBoundaryObserve impl (next value.1) observe nextContext remaining table value.2 + letI : ObserverDooms table nextObserve := ⟨by + intro nextContext remaining value hnextConsistent hnextStarts hnextDoomed + exact ih value.1 nextContext remaining value.2 hnextConsistent hnextStarts hnextDoomed⟩ + exact evalDist_runDirectResolvedObserve_eq_true_of_not_completable_auto + (observe := canonicalizeObserve table nextObserve) context fuel table + ((impl query).run cache) hconsistent hstarts hdoomed + +theorem valid_completable_canonicalizeMaterializedValues + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + (canonicalizeMaterializedValues table context).Valid ∧ + DeferredCompletable table (canonicalizeMaterializedValues table context) := by + obtain ⟨completion, hcompletion⟩ := hcompletable + have hclean : ∀ coordinate output, + resolvedCompletionValue table context coordinate = some output → + ¬context.state.hitAt coordinate output := by + intro coordinate output hvalue hhit + have houtput := hcompletion.eq_resolvedCompletionValue coordinate output hvalue + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + exact hcompletion.2.2.1 coordinate (truncateHash output) hhit (by rw [houtput]) + exact ⟨canonicalizeMaterializedValues_valid table context hvalid hclean, + ⟨completion, hcompletion.to_canonicalizedMaterializedValues⟩⟩ + +theorem canonicalizeMaterializedValues_chain_value + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hstarts : StartTableAgrees context.state table) + (hchainValid : ChainState.ValidFor allowed context.state) + (coordinate : Coordinate) (hchain : IsChainCoordinate coordinate) : + (canonicalizeMaterializedValues table context).state.values coordinate = + context.state.values coordinate := by + unfold canonicalizeMaterializedValues publicMaterializedValues + cases hvalue : context.state.values coordinate with + | none => + have hnotRevealed : coordinate ∉ context.state.revealed := by + intro hrevealed + exact (hchainValid coordinate hchain).2.1 hrevealed hvalue + simp [hnotRevealed] + | some output => + have hrevealed : coordinate ∈ context.state.revealed := + (hchainValid coordinate hchain).1 (by simp [hvalue]) + simp only [hrevealed, ↓reduceIte] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + have htable : output = table index := hstarts index output (by + simpa [index, OtsSecretIndex.coordinate] using hvalue) + simp [resolvedCompletionValue, index, htable] + | position position => + simp [resolvedCompletionValue, DeferredContext.positionValue, hvalue] + +theorem canonicalizeMaterializedValues_chain_private_eq + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hdirect : context = directDeferredContext context.state) + (hstarts : StartTableAgrees context.state table) + (hchainValid : ChainState.ValidFor allowed context.state) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (step : ChainStep) : + (canonicalizeMaterializedValues table context).values + (.chain lay tree leafIdx chainIdx step) = + (canonicalizeMaterializedValues table context).state.values + (.position (.chain lay tree leafIdx chainIdx step)) := by + have hprivate : + context.values (.chain lay tree leafIdx chainIdx step) = + context.state.values (.position (.chain lay tree leafIdx chainIdx step)) := by + rw [hdirect] + rfl + change context.values (.chain lay tree leafIdx chainIdx step) = _ + rw [canonicalizeMaterializedValues_chain_value table context hstarts hchainValid] + · exact hprivate + · trivial + +theorem ChainValuesMirrored.canonicalizeMaterializedValues + {context : DeferredContext} (hmirror : ChainValuesMirrored context) + (table : OtsSecretIndex → HashOutput) + (hstarts : StartTableAgrees context.state table) + (hchainValid : ChainState.ValidFor allowed context.state) : + ChainValuesMirrored (canonicalizeMaterializedValues table context) := by + intro lay tree leafIdx chainIdx step + change context.values (.chain lay tree leafIdx chainIdx step) = _ + rw [canonicalizeMaterializedValues_chain_value table context hstarts hchainValid] + · exact hmirror lay tree leafIdx chainIdx step + · trivial + +theorem ChainState.ValidFor.canonicalizeMaterializedValues + {context : DeferredContext} (hvalid : ChainState.ValidFor allowed context.state) + (table : OtsSecretIndex → HashOutput) + (hstarts : StartTableAgrees context.state table) : + ChainState.ValidFor allowed + (canonicalizeMaterializedValues table context).state := by + intro coordinate hchain + rw [canonicalizeMaterializedValues_chain_value table context hstarts hvalid coordinate hchain, + canonicalizeMaterializedValues_revealed] + exact hvalid coordinate hchain + +theorem ChainInvariant.canonicalizeMaterializedValues + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hstarts : StartTableAgrees context.state table) + (hinvariant : ChainInvariant parameter allowed context.state cache) : + ChainInvariant parameter allowed + (canonicalizeMaterializedValues table context).state cache := by + constructor + · intro coordinate hchain + have hcoordinate := hinvariant.1 coordinate hchain + rw [canonicalizeMaterializedValues_chain_value table context hstarts hinvariant.1 + coordinate hchain, canonicalizeMaterializedValues_revealed] + exact hcoordinate + · intro probe input hmatches hcached hnotAllowed + have hpending := hinvariant.2 probe input hmatches hcached hnotAllowed + simpa [LazyRevealProbe.State.pendingAt, + canonicalizeMaterializedValues_pending] using hpending + +theorem preservesChainValid_maskedSignAfterDigest_true + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + PreservesChainValid (fun _ => True) + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest + apply ((preservesChainValidImpl_ordinaryHashImpl (fun _ => True)).simulateQ + (ftsOpen parameter index leaves (ftsSecret index))).bind + intro _ftsPath + apply (preservesChainValid_sequenceFin (fun _ => True) _ fun lay => + preservesChainValid_maskedSignLayer (fun _ => True) parameter ftsSecret index lay).bind + intro layers + cases hparts : traverseOption layers with + | none => + simp only + exact preservesChainValid_pure (fun _ => True) none + | some parts => + simp only + apply (preservesChainValid_sequenceFin (fun _ => True) _ fun lay => + preservesChainValid_revealLayerValues (fun _ => True) index lay (parts lay).2 + (fun _ => trivial)).bind + intro _revealed + exact preservesChainValid_pure (fun _ => True) _ + +theorem preservesChainValid_maskedSign_true + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + PreservesChainValid (fun _ => True) (maskedSign parameter root ftsSecret message) := by + unfold maskedSign + apply ((preservesChainValidImpl_ordinaryRomImpl (fun _ => True)).simulateQ + (signDigestLoop digestAttemptLimit + (⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ : SecretKey) message)).bind + intro selected + cases selected with + | none => exact preservesChainValid_pure (fun _ => True) none + | some data => + exact preservesChainValid_maskedSignAfterDigest_true parameter ftsSecret + data.1 data.2.1 data.2.2 + +theorem preservesChainValidImpl_maskedExpandedAdversaryImpl_true + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + PreservesChainValidImpl (fun _ => True) + (maskedExpandedAdversaryImpl parameter root ftsSecret) := by + intro query + cases query with + | inl query => + exact preservesChainValidImpl_probingRomImpl (fun _ => True) + (by intro candidate _hallowed _hchain; trivial) parameter query + | inr message => + exact preservesChainValid_maskedSign_true parameter root ftsSecret message + +theorem preservesChainValid_publishCoordinate_of_not_chain + (allowed : Coordinate → Prop) (coordinate : Coordinate) + (hnotChain : ¬IsChainCoordinate coordinate) : + PreservesChainValid allowed (publishCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hvalid hresult + unfold publishCoordinate at hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.publishQuery coordinate >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.publishQuery, LazyRevealProbe.runRaw_publish_query_bind] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + intro other hchain + have hne : other ≠ coordinate := by + intro heq + exact hnotChain (heq ▸ hchain) + simpa [LazyRevealProbe.State.publish, hne] using hvalid other hchain + +theorem preservesChainValid_maskedPublishedTreeRoot_true : + PreservesChainValid (fun _ => True) maskedPublishedTreeRoot := by + rw [maskedPublishedTreeRoot_eq] + apply (preservesChainValid_maskedTreeRoot (fun _ => True) topLayer rootTree).bind + intro root + apply (preservesChainValid_publishCoordinate_of_not_chain (fun _ => True) + (.position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0)) + (by simp [IsChainCoordinate])).bind + intro _ + exact preservesChainValid_pure (fun _ => True) root + +theorem preservesChainValid_canonicalVerifierFinish_true + (parameter : PublicParameter) (root : Digest) + (forgeryLog : Forgery × QueryLog SigningSpec) : + PreservesChainValid (fun _ => True) + (canonicalVerifierFinish parameter root forgeryLog) := by + unfold canonicalVerifierFinish + exact ((preservesChainValidImpl_probingRomImpl (fun _ => True) + (by intro candidate _hallowed _hchain; trivial) parameter).simulateQ + (scheme.verify ⟨root, parameter⟩ forgeryLog.1.message forgeryLog.1.signature)).bind + fun _ => preservesChainValid_pure (fun _ => True) _ + +set_option maxRecDepth 100000 in +theorem evalDist_directBoundaryObserve_eq_of_chain_invariants + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (himpl : PreservesChainValidImpl (fun _ => True) impl) + (computation : OracleComp spec α) + (left right : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + (heq : ∀ context fuel value, + context.ValuesConsistent → StartTableAgrees context.state table → + ChainValuesMirrored context → ChainState.ValidFor (fun _ => True) context.state → + evalDist (left context fuel value) = evalDist (right context fuel value)) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hmirror : ChainValuesMirrored context) + (hchainValid : ChainState.ValidFor (fun _ => True) context.state) : + evalDist (directBoundaryObserve impl computation left context fuel table cache) = + evalDist (directBoundaryObserve impl computation right context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + rw [directBoundaryObserve, OracleComp.construct_pure, + directBoundaryObserve, OracleComp.construct_pure] + exact heq context fuel (value, cache) hconsistent hstarts hmirror hchainValid + | query_bind query next ih => + rw [directBoundaryObserve, OracleComp.construct_query_bind, + directBoundaryObserve, OracleComp.construct_query_bind] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable + ((impl query).run cache) context fuel table result hconsistent hstarts hresult + have hnextMirror := chainValuesMirrored_of_mem_runDirectResolvedFromTable + ((impl query).run cache) context fuel table result hmirror hresult + have hnextChainValid := chainValid_of_mem_runDirectResolvedFromTable + (fun _ => True) (impl query) context fuel table cache result (himpl query) + hchainValid hresult + unfold finishObserve canonicalizeObserve + by_cases hpublished : PublishedValues result.context.state + · simp only [hpublished, ↓reduceIte] + have hcanonicalConsistent := + canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1 + have hcanonicalStarts := + canonicalizeMaterializedValues_startTableAgrees table result.context + have hcanonicalMirror := hnextMirror.canonicalizeMaterializedValues table hcore.2.2 + hnextChainValid + have hcanonicalChainValid := hnextChainValid.canonicalizeMaterializedValues table + hcore.2.2 + exact ih result.value.1 (canonicalizeMaterializedValues table result.context) + result.remaining result.value.2 hcanonicalConsistent hcanonicalStarts + hcanonicalMirror hcanonicalChainValid + · simp [hpublished] + +set_option maxRecDepth 100000 in +theorem evalDist_boundaryObserve_eq_directBoundaryObserve + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (boundaryObserve impl computation observe context fuel table cache) = + evalDist (directBoundaryObserve impl computation observe context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + rw [boundaryObserve, OracleComp.construct_pure, + directBoundaryObserve, OracleComp.construct_pure] + | query_bind query next ih => + rw [boundaryObserve, OracleComp.construct_query_bind, + directBoundaryObserve, OracleComp.construct_query_bind] + let leftNext : DeferredContext → Nat → + ((spec.Range query) × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + boundaryObserve impl (next value.1) observe nextContext remaining table value.2 + let rightNext : DeferredContext → Nat → + ((spec.Range query) × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + directBoundaryObserve impl (next value.1) observe nextContext remaining table value.2 + letI : ObserverDooms table leftNext := ⟨by + intro nextContext remaining value hconsistent hstarts hdoomed + exact boundaryObserve_dooms impl (next value.1) observe nextContext remaining value.2 + hconsistent hstarts hdoomed⟩ + letI : ObserverSynchronized table leftNext := ⟨by + intro left right remaining value hcontext hvalues hrevealed + exact boundaryObserve_synchronized impl (next value.1) observe left right remaining + value.2 hcontext hvalues hrevealed⟩ + letI : ObserverPositionNeutral table leftNext := ⟨by + intro position nextContext remaining value hnextValid hnextCompletable hensured + exact boundaryObserve_positionNeutral impl (next value.1) observe position nextContext + remaining value.2 hnextValid hnextCompletable hensured⟩ + calc + _ = evalDist (runDirectResolvedObserve (canonicalizeObserve table leftNext) + context fuel table ((impl query).run cache)) := + evalDist_runResolvedObserve_eq_runDirectResolvedObserve + (observe := canonicalizeObserve table leftNext) context fuel table + ((impl query).run cache) hvalid hcompletable + _ = _ := by + unfold runDirectResolvedObserve + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable + ((impl query).run cache) context fuel table result hvalid.valuesConsistent + (startTableAgrees_of_deferredCompletable hcompletable) hresult + change evalDist (canonicalizeObserve table leftNext result.context + result.remaining result.value) = + evalDist (canonicalizeObserve table rightNext result.context + result.remaining result.value) + by_cases hnextCompletable : DeferredCompletable table result.context + · have hnextValid := valid_of_resolvedCore_completable table result.context + hcore.2.1 hcore.2.2 hnextCompletable + unfold canonicalizeObserve + by_cases hpublished : PublishedValues result.context.state + · simp only [hpublished, ↓reduceIte] + have hcanonical := valid_completable_canonicalizeMaterializedValues table + result.context hnextValid hnextCompletable + exact ih result.value.1 (canonicalizeMaterializedValues table result.context) + result.remaining result.value.2 hcanonical.1 hcanonical.2 + · simp [hpublished] + · have hdoomed : DoomedResolvedContext table result.context := + ⟨hcore.2.1, hcore.2.2, hnextCompletable⟩ + unfold canonicalizeObserve + by_cases hpublished : PublishedValues result.context.state + · simp only [hpublished, ↓reduceIte] + have hcanonical := doomedResolvedContext_canonicalizeMaterializedValues + hdoomed + exact (boundaryObserve_dooms impl (next result.value.1) observe + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hcanonical.1 hcanonical.2.1 hcanonical.2.2).trans + (directBoundaryObserve_dooms impl (next result.value.1) observe + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hcanonical.1 hcanonical.2.1 hcanonical.2.2).symm + · simp [hpublished] + +set_option maxRecDepth 100000 in +theorem directBoundaryObserve_synchronized + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] + (left right : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) + (hrevealed : left.state.revealed = right.state.revealed) : + evalDist (directBoundaryObserve impl computation observe left fuel table cache) = + evalDist (directBoundaryObserve impl computation observe right fuel table cache) := by + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hrightCompletable : DeferredCompletable table right := by + rcases hleftCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, (hview.deferredCompletion_iff completion).mp hcompletion⟩ + calc + _ = evalDist (boundaryObserve impl computation observe left fuel table cache) := + (evalDist_boundaryObserve_eq_directBoundaryObserve impl computation observe left fuel + cache hleftValid hleftCompletable).symm + _ = evalDist (boundaryObserve impl computation observe right fuel table cache) := + boundaryObserve_synchronized impl computation observe left right fuel cache + ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ hvalues hrevealed + _ = _ := evalDist_boundaryObserve_eq_directBoundaryObserve impl computation observe right + fuel cache hrightValid hrightCompletable + +set_option maxRecDepth 100000 in +theorem directBoundaryObserve_positionNeutral + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] + (position : Position) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : Coordinate.position position ∈ context.state.ensured) : + evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + directBoundaryObserve impl computation observe resolved.toDeferredContext fuel table + cache) = + evalDist (directBoundaryObserve impl computation observe context fuel table cache) := by + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + boundaryObserve impl computation observe resolved.toDeferredContext fuel table + cache) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hresolvedValid := hvalid.of_resolveDeferredPositionValue position resolved + hresolved + have hresolvedCompletable := hcompletable.of_resolveDeferredPositionValue hvalid + position resolved hresolved + simpa using (evalDist_boundaryObserve_eq_directBoundaryObserve impl computation observe + resolved.toDeferredContext fuel cache hresolvedValid hresolvedCompletable).symm + _ = evalDist (boundaryObserve impl computation observe context fuel table cache) := + boundaryObserve_positionNeutral impl computation observe position context fuel cache + hvalid hcompletable hensured + _ = _ := evalDist_boundaryObserve_eq_directBoundaryObserve impl computation observe context + fuel cache hvalid hcompletable + +noncomputable def directBoundaryDeferredRetainedFinishIsNone + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := do + let rootResult ← runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure true + | some rootResult => + directBoundaryObserve (maskedExpandedAdversaryImpl parameter rootResult.value.1 ftsSecret) + (signingTraceComputation (adversary.main ⟨rootResult.value.1, parameter⟩)) + (verifierFinishObserve table parameter rootResult.value.1) + rootResult.context rootResult.remaining table rootResult.value.2 + +set_option maxRecDepth 100000 in +theorem evalDist_boundaryDeferredRetainedFinishIsNone_eq_direct + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (boundaryDeferredRetainedFinishIsNone adversary parameter table ftsSecret fuel) = + evalDist (directBoundaryDeferredRetainedFinishIsNone adversary parameter table ftsSecret + fuel) := by + unfold boundaryDeferredRetainedFinishIsNone + directBoundaryDeferredRetainedFinishIsNone + apply evalDist_bind_congr + intro rootOption hroot + cases rootOption with + | none => rfl + | some rootResult => + have hrootInvariants : rootResult.context.Valid ∧ + DeferredCompletable table rootResult.context := + valid_completable_of_mem_runResolvedFromTable_of_finalizationMaterializedCouples + (α := Digest) table maskedPublishedTreeRoot + (finalizationMaterializedCouples_maskedPublishedTreeRoot table) + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel emptySplitHashCache rootResult DeferredContext.valid_empty + (deferredCompletable_empty table) hroot + exact evalDist_boundaryObserve_eq_directBoundaryObserve + (maskedExpandedAdversaryImpl parameter rootResult.value.1 ftsSecret) + (signingTraceComputation (adversary.main ⟨rootResult.value.1, parameter⟩)) + (verifierFinishObserve table parameter rootResult.value.1) + rootResult.context rootResult.remaining rootResult.value.2 + hrootInvariants.1 hrootInvariants.2 + +noncomputable def directRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp Bool := + directBoundaryObserve (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (signingTraceComputation (adversary.main ⟨value.1, parameter⟩)) + (verifierFinishObserve table parameter value.1) + context fuel table value.2 + +instance directRetainedRestObserve_observerDooms + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ObserverDooms table + (directRetainedRestObserve adversary parameter table ftsSecret) where + eq_true context fuel value hconsistent hstarts hdoomed := by + exact directBoundaryObserve_dooms + (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (signingTraceComputation (adversary.main ⟨value.1, parameter⟩)) + (verifierFinishObserve table parameter value.1) + context fuel value.2 hconsistent hstarts hdoomed + +instance directRetainedRestObserve_observerSynchronized + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ObserverSynchronized table + (directRetainedRestObserve adversary parameter table ftsSecret) where + eq_of_synchronized left right fuel value hcontext hvalues hrevealed := by + exact directBoundaryObserve_synchronized + (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (signingTraceComputation (adversary.main ⟨value.1, parameter⟩)) + (verifierFinishObserve table parameter value.1) + left right fuel value.2 hcontext hvalues hrevealed + +instance directRetainedRestObserve_observerPositionNeutral + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ObserverPositionNeutral table + (directRetainedRestObserve adversary parameter table ftsSecret) where + eq_resolve position context fuel value hvalid hcompletable hensured := by + exact directBoundaryObserve_positionNeutral + (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (signingTraceComputation (adversary.main ⟨value.1, parameter⟩)) + (verifierFinishObserve table parameter value.1) + position context fuel value.2 hvalid hcompletable hensured + +noncomputable def fullyDirectBoundaryDeferredRetainedFinishIsNone + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := + runDirectResolvedObserve (directRetainedRestObserve adversary parameter table ftsSecret) + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +set_option maxRecDepth 100000 in +theorem evalDist_directBoundaryDeferredRetainedFinishIsNone_eq_fullyDirect + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (directBoundaryDeferredRetainedFinishIsNone adversary parameter table ftsSecret + fuel) = + evalDist (fullyDirectBoundaryDeferredRetainedFinishIsNone adversary parameter table + ftsSecret fuel) := by + let context : DeferredContext := + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + have hleft : directBoundaryDeferredRetainedFinishIsNone adversary parameter table ftsSecret + fuel = runResolvedObserve + (directRetainedRestObserve adversary parameter table ftsSecret) + context fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) := by + unfold directBoundaryDeferredRetainedFinishIsNone runResolvedObserve + apply bind_congr + intro result + cases result <;> rfl + rw [hleft] + exact evalDist_runResolvedObserve_eq_runDirectResolvedObserve + (observe := directRetainedRestObserve adversary parameter table ftsSecret) + context fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + DeferredContext.valid_empty (deferredCompletable_empty table) + +noncomputable def directVerifierFinishObserve + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : (Forgery × QueryLog SigningSpec) × SplitHashCache) : ProbComp Bool := + runDirectResolvedFromTable context fuel table + ((canonicalVerifierFinish parameter root value.1).run value.2) >>= + finishObserve (resolvedFinalizationObserve table) + +theorem evalDist_verifierFinishObserve_eq_direct + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : (Forgery × QueryLog SigningSpec) × SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + evalDist (verifierFinishObserve table parameter root context fuel value) = + evalDist (directVerifierFinishObserve table parameter root context fuel value) := by + by_cases hcompletable : DeferredCompletable table context + · have hvalid := valid_of_resolvedCore_completable table context hconsistent hstarts + hcompletable + exact evalDist_runResolvedFinishIsNone_eq_runDirectResolvedFinalizationIsNone + context fuel table ((canonicalVerifierFinish parameter root value.1).run value.2) + hvalid hcompletable + · calc + _ = evalDist (pure true : ProbComp Bool) := + ObserverDooms.eq_true context fuel value hconsistent hstarts hcompletable + _ = _ := (evalDist_runDirectResolvedObserve_eq_true_of_not_completable_auto + (observe := resolvedFinalizationObserve table) context fuel table + ((canonicalVerifierFinish parameter root value.1).run value.2) + hconsistent hstarts hcompletable).symm + +noncomputable def allDirectRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp Bool := + directBoundaryObserve (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (signingTraceComputation (adversary.main ⟨value.1, parameter⟩)) + (directVerifierFinishObserve table parameter value.1) + context fuel table value.2 + +noncomputable def allDirectBoundaryDeferredRetainedFinishIsNone + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := + runDirectResolvedObserve + (allDirectRetainedRestObserve adversary parameter table ftsSecret) + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem evalDist_fullyDirectBoundaryDeferredRetainedFinishIsNone_eq_allDirect + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (fullyDirectBoundaryDeferredRetainedFinishIsNone adversary parameter table + ftsSecret fuel) = + evalDist (allDirectBoundaryDeferredRetainedFinishIsNone adversary parameter table + ftsSecret fuel) := by + unfold fullyDirectBoundaryDeferredRetainedFinishIsNone + allDirectBoundaryDeferredRetainedFinishIsNone runDirectResolvedObserve + apply evalDist_bind_congr + intro rootOption hroot + cases rootOption with + | none => rfl + | some rootResult => + let initial : DeferredContext := + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + generalize hrootComputation : maskedPublishedTreeRoot.run emptySplitHashCache = + rootComputation at hroot + change some rootResult ∈ support (runDirectResolvedFromTable initial fuel table + rootComputation) at hroot + have hinitialConsistent : initial.ValuesConsistent := by + exact DeferredContext.valid_empty.valuesConsistent + have hinitialStarts : StartTableAgrees initial.state table := by + exact startTableAgrees_empty table + have hcore : rootResult.table = table ∧ rootResult.context.ValuesConsistent ∧ + StartTableAgrees rootResult.context.state table := by + exact resolvedCore_of_mem_runDirectResolvedFromTable + (computation := rootComputation) + (context := initial) (fuel := fuel) (table := table) (result := rootResult) + hinitialConsistent hinitialStarts hroot + have hmirror := chainValuesMirrored_of_mem_runDirectResolvedFromTable + (computation := rootComputation) + (context := initial) (fuel := fuel) (table := table) (result := rootResult) + (by + intro lay tree leafIdx chainIdx step + rfl) + hroot + have hraw := raw_done_of_mem_runDirectResolvedFromTable rootComputation initial fuel table + rootResult hroot + have hrawRoot : LazyRevealProbe.RawResult.done rootResult.context.state + rootResult.remaining rootResult.value ∈ support (LazyRevealProbe.runRaw + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel + (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + rw [hrootComputation] + exact hraw + generalize hrootProgram : maskedPublishedTreeRoot = rootProgram at hrawRoot + have hpreserves : PreservesChainValid (fun _ => True) rootProgram := by + rw [← hrootProgram] + exact preservesChainValid_maskedPublishedTreeRoot_true + unfold PreservesChainValid at hpreserves + have hchainValid : ChainState.ValidFor (fun _ => True) rootResult.context.state := by + exact hpreserves + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) emptySplitHashCache fuel + rootResult.context.state rootResult.remaining rootResult.value.1 rootResult.value.2 + (ChainState.validFor_empty (fun _ => True)) hrawRoot + exact evalDist_directBoundaryObserve_eq_of_chain_invariants + (maskedExpandedAdversaryImpl parameter rootResult.value.1 ftsSecret) + (preservesChainValidImpl_maskedExpandedAdversaryImpl_true parameter + rootResult.value.1 ftsSecret) + (signingTraceComputation (adversary.main ⟨rootResult.value.1, parameter⟩)) + (verifierFinishObserve table parameter rootResult.value.1) + (directVerifierFinishObserve table parameter rootResult.value.1) + (by + intro context remaining value hconsistent hstarts _hmirror _hchainValid + exact evalDist_verifierFinishObserve_eq_direct table parameter rootResult.value.1 + context remaining value hconsistent hstarts) + rootResult.context rootResult.remaining rootResult.value.2 hcore.2.1 hcore.2.2 + hmirror hchainValid + +theorem evalDist_canonicalDeferredRetainedFinishIsNone_eq_allDirect + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist + (canonicalDeferredRetainedRunAfterFtsSecrets adversary parameter table ftsSecret fuel >>= + finishResolvedRunIsNone) = + evalDist (allDirectBoundaryDeferredRetainedFinishIsNone adversary parameter table + ftsSecret fuel) := by + calc + _ = evalDist + (boundaryDeferredRetainedFinishIsNone adversary parameter table ftsSecret fuel) := + evalDist_canonicalDeferredRetainedFinishIsNone_eq_boundary adversary parameter table + ftsSecret fuel + _ = evalDist + (directBoundaryDeferredRetainedFinishIsNone adversary parameter table ftsSecret fuel) := + evalDist_boundaryDeferredRetainedFinishIsNone_eq_direct adversary parameter table ftsSecret + fuel + _ = evalDist + (fullyDirectBoundaryDeferredRetainedFinishIsNone adversary parameter table ftsSecret + fuel) := + evalDist_directBoundaryDeferredRetainedFinishIsNone_eq_fullyDirect adversary parameter + table ftsSecret fuel + _ = _ := evalDist_fullyDirectBoundaryDeferredRetainedFinishIsNone_eq_allDirect adversary + parameter table ftsSecret fuel + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryFinalAssembly.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryFinalAssembly.lean new file mode 100644 index 00000000..ace19b0f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryFinalAssembly.lean @@ -0,0 +1,79 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionOrdinal + +/-! +# Final resolved-boundary assembly + +The canonical private endpoint is impossible. Keeping that exact zero in the final accounting +leaves seven units for the granular private endpoint and two for the ordinary endpoints. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option linter.constructorNameAsVariable false + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledMaterializedCanonicalPrivateRetained_le_zero + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) : + Pr[= true | + sampledMaterializedCanonicalPrivateRetained adversary parameter ftsSecret q] ≤ 0 := by + unfold sampledMaterializedCanonicalPrivateRetained + rw [← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_of_forall_le + intro table _htable + rw [probEvent_eq_eq_probOutput] + exact probEvent_materializedCanonicalPrivateRetained_le_zero adversary parameter table + ftsSecret q + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_failed_sampledAllDirectBoundaryDetailedRetainedOutcome_le_nine_mul_of_granular + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hdomination : + Pr[fun outcome => outcome.failed = true | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret q] ≤ + Pr[= true | + sampledFlatDetailedOrdinaryRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledMaterializedGuardedSafeOrdinaryRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledMaterializedCanonicalPrivateRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q]) + (hgranular : + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q] ≤ + ((7 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[fun outcome => outcome.failed = true | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret q] ≤ + ((9 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ Pr[= true | + sampledFlatDetailedOrdinaryRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledMaterializedGuardedSafeOrdinaryRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledMaterializedCanonicalPrivateRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q] := hdomination + _ ≤ ((2 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + 0 + + ((7 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + exact add_le_add + (add_le_add + (probEvent_sampledFlat_add_materializedGuardedOrdinaryRetained_le_two_mul + adversary parameter ftsSecret q) + (probEvent_sampledMaterializedCanonicalPrivateRetained_le_zero adversary parameter + ftsSecret q)) + hgranular + _ = _ := by + push_cast + ring + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryFirstFire.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryFirstFire.lean new file mode 100644 index 00000000..21ccae42 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryFirstFire.lean @@ -0,0 +1,1504 @@ +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveClean + +/-! +# Structural boundary first fire + +Canonical signer boundaries hide materialized values that were not published while retaining their +private structural copy. A later probe can make such a context impossible only by naming the +truncated private value. This file isolates that exact discrepancy from ordinary clean execution. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot + +def PrivateStructuralHit (context : DeferredContext) : Prop := + ∃ position output, + context.state.values (.position position) = none ∧ + context.values position = some output ∧ + context.state.hitAt (.position position) output + +theorem DeferredCompletion.not_privateStructuralHit + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hcompletion : DeferredCompletion table context completion) : + ¬PrivateStructuralHit context := by + rintro ⟨position, output, _hhidden, hprivate, hhit⟩ + have hcompletionOutput : completion (.position position) = output := + hcompletion.2.1 position output hprivate + have hpending : + (Coordinate.position position, truncateHash output) ∈ context.state.pending := by + rw [← LazyRevealProbe.State.mem_pendingAt_iff] + exact hhit + have havoids := hcompletion.2.2.1 (.position position) (truncateHash output) hpending + rw [hcompletionOutput] at havoids + exact havoids rfl + +theorem not_privateStructuralHit_of_deferredCompletable + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hcompletable : DeferredCompletable table context) : + ¬PrivateStructuralHit context := by + obtain ⟨completion, hcompletion⟩ := hcompletable + exact hcompletion.not_privateStructuralHit + +theorem privateStructuralHit_addPending_iff + (context : DeferredContext) (position : Position) (output : HashOutput) + (candidate : Digest) + (hclean : ¬PrivateStructuralHit context) + (hhidden : context.state.values (.position position) = none) + (hprivate : context.values position = some output) : + PrivateStructuralHit + { context with + state := context.state.addPending (.position position) candidate } ↔ + truncateHash output = candidate := by + constructor + · rintro ⟨other, otherOutput, hotherHidden, hotherPrivate, hotherHit⟩ + by_cases heq : other = position + · subst other + have houtput : otherOutput = output := by + rw [hprivate] at hotherPrivate + exact Option.some.inj hotherPrivate.symm + subst otherOutput + rw [hitAt_addPending_self_iff] at hotherHit + exact hotherHit.resolve_left fun hold => + hclean ⟨position, output, hhidden, hprivate, hold⟩ + · have hcoordinate : Coordinate.position position ≠ .position other := by + intro hcoordinate + exact heq (Coordinate.position.inj hcoordinate).symm + have holdHit : context.state.hitAt (.position other) otherOutput := by + simpa only [hitAt_addPending_of_ne context.state (.position position) + (.position other) candidate otherOutput hcoordinate] using hotherHit + exact False.elim (hclean ⟨other, otherOutput, hotherHidden, hotherPrivate, holdHit⟩) + · intro hcandidate + refine ⟨position, output, hhidden, hprivate, ?_⟩ + exact (hitAt_addPending_self_iff context.state (.position position) candidate output).2 + (Or.inr hcandidate) + +theorem privateStructuralHit_addPending_imp + (context : DeferredContext) (coordinate : Coordinate) (candidate : Digest) : + PrivateStructuralHit + { context with state := context.state.addPending coordinate candidate } → + PrivateStructuralHit context ∨ + ∃ position output, + coordinate = .position position ∧ + context.state.values (.position position) = none ∧ + context.values position = some output ∧ + truncateHash output = candidate := by + rintro ⟨position, output, hhidden, hprivate, hhit⟩ + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + left + refine ⟨position, output, hhidden, hprivate, ?_⟩ + exact (hitAt_addPending_of_ne context.state + (.chainStart lay tree leafIdx chainIdx) (.position position) candidate output + (by simp)).mp hhit + | position added => + by_cases heq : position = added + · subst position + rw [hitAt_addPending_self_iff] at hhit + exact hhit.elim + (fun hold => Or.inl ⟨added, output, hhidden, hprivate, hold⟩) + (fun hcandidate => Or.inr ⟨added, output, rfl, hhidden, hprivate, hcandidate⟩) + · left + refine ⟨position, output, hhidden, hprivate, ?_⟩ + exact (hitAt_addPending_of_ne context.state (.position added) + (.position position) candidate output (by + intro hcoordinate + exact heq (Coordinate.position.inj hcoordinate.symm))).mp hhit + +theorem privateStructuralHit_addPending_iff_of_clean + (context : DeferredContext) (coordinate : Coordinate) (candidate : Digest) + (hclean : ¬PrivateStructuralHit context) : + PrivateStructuralHit + { context with state := context.state.addPending coordinate candidate } ↔ + ∃ position output, + coordinate = .position position ∧ + context.state.values (.position position) = none ∧ + context.values position = some output ∧ + truncateHash output = candidate := by + constructor + · intro hhit + exact (privateStructuralHit_addPending_imp context coordinate candidate hhit).resolve_left + hclean + · rintro ⟨position, output, rfl, hhidden, hprivate, hcandidate⟩ + refine ⟨position, output, hhidden, hprivate, ?_⟩ + exact (hitAt_addPending_self_iff context.state (.position position) candidate output).2 + (Or.inr hcandidate) + +theorem deferredCompletable_addPending_position_iff + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (position : Position) (output : HashOutput) (candidate : Digest) + (hcompletion : DeferredCompletion table context completion) + (hprivate : context.values position = some output) : + DeferredCompletable table + { context with + state := context.state.addPending (.position position) candidate } ↔ + truncateHash output ≠ candidate := by + constructor + · rintro ⟨nextCompletion, hnextCompletion⟩ + have hnextOutput : nextCompletion (.position position) = output := + hnextCompletion.2.1 position output hprivate + have hpending : (Coordinate.position position, candidate) ∈ + (context.state.addPending (.position position) candidate).pending := by + simp [LazyRevealProbe.State.addPending] + have havoids := + hnextCompletion.2.2.1 (.position position) candidate hpending + rwa [hnextOutput] at havoids + · intro havoids + refine ⟨completion, hcompletion.addPending_of_avoids (.position position) candidate ?_⟩ + have hcompletionOutput : completion (.position position) = output := + hcompletion.2.1 position output hprivate + rwa [hcompletionOutput] + +theorem truncateHash_completion_eq_of_not_deferredCompletable_addPending + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (coordinate : Coordinate) (candidate : Digest) + (hcompletion : DeferredCompletion table context completion) + (hnotCompletable : ¬DeferredCompletable table + { context with state := context.state.addPending coordinate candidate }) : + truncateHash (completion coordinate) = candidate := by + by_contra hne + exact hnotCompletable + ⟨completion, hcompletion.addPending_of_avoids coordinate candidate hne⟩ + +theorem not_deferredCompletable_addPending_position_iff_privateStructuralHit + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (position : Position) (output : HashOutput) (candidate : Digest) + (hcompletion : DeferredCompletion table context completion) + (hhidden : context.state.values (.position position) = none) + (hprivate : context.values position = some output) : + ¬DeferredCompletable table + { context with + state := context.state.addPending (.position position) candidate } ↔ + PrivateStructuralHit + { context with + state := context.state.addPending (.position position) candidate } := by + rw [deferredCompletable_addPending_position_iff position output candidate hcompletion hprivate, + privateStructuralHit_addPending_iff context position output candidate + hcompletion.not_privateStructuralHit hhidden hprivate] + simp + +theorem privateStructuralHit_addPending_of_truncateHash_eq + (context : DeferredContext) (position : Position) (output : HashOutput) + (candidate : Digest) + (hhidden : context.state.values (.position position) = none) + (hprivate : context.values position = some output) + (hcandidate : truncateHash output = candidate) : + PrivateStructuralHit + { context with + state := context.state.addPending (.position position) candidate } := by + refine ⟨position, output, hhidden, hprivate, ?_⟩ + exact (hitAt_addPending_self_iff context.state (.position position) candidate output).2 + (Or.inr hcandidate) + +theorem not_privateStructuralHit_presamplePosition + (context : DeferredContext) (position : Position) (output : HashOutput) + (hclean : ¬PrivateStructuralHit context) : + ¬PrivateStructuralHit (context.presamplePosition position output) := by + rintro ⟨other, otherOutput, hhidden, hprivate, hhit⟩ + by_cases heq : other = position + · subst other + exact (not_hitAt_clearPending_self context.state (.position position) otherOutput) hhit + · apply hclean + refine ⟨other, otherOutput, hhidden, ?_, ?_⟩ + · simpa [DeferredContext.presamplePosition, DeferredStructuralValues.install, + Function.update_of_ne heq] using hprivate + · exact (hitAt_clearPending_of_ne context.state (.position position) + (.position other) otherOutput (by + intro hcoordinate + exact heq (Coordinate.position.inj hcoordinate))).mp hhit + +theorem probEvent_privateStructuralHit_presamplePosition_addPending_le + (context : DeferredContext) (position : Position) (candidate : Digest) + (hclean : ¬PrivateStructuralHit context) + (hhidden : context.state.values (.position position) = none) : + Pr[fun output : HashOutput => + PrivateStructuralHit + { context.presamplePosition position output with + state := (context.presamplePosition position output).state.addPending + (.position position) candidate } | + LazyRevealProbe.sampleHashOutput] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ = Pr[fun output : HashOutput => truncateHash output = candidate | + LazyRevealProbe.sampleHashOutput] := by + apply OracleComp.probEvent_congr' + · intro output _houtput + apply privateStructuralHit_addPending_iff + · exact not_privateStructuralHit_presamplePosition context position output hclean + · simpa [DeferredContext.presamplePosition] using hhidden + · simp [DeferredContext.presamplePosition, DeferredStructuralValues.install] + · rfl + _ = (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + unfold LazyRevealProbe.sampleHashOutput + exact SphincsSecurity.probEvent_uniform_truncateHash_eq candidate + _ ≤ _ := by + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + +noncomputable def resolveThenPrivateProbeOutcome + (context : DeferredContext) (position : Position) (candidate : Digest) : + ProbComp Bool := by + classical + exact do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure false + | some resolved => + pure (decide (PrivateStructuralHit + { resolved.toDeferredContext with + state := resolved.state.addPending (.position position) candidate })) + +theorem probEvent_resolveThenPrivateProbeOutcome_le + (context : DeferredContext) (position : Position) (candidate : Digest) + (hclean : ¬PrivateStructuralHit context) + (hhidden : context.state.values (.position position) = none) + (hprivate : context.values position = none) : + Pr[= true | resolveThenPrivateProbeOutcome context position candidate] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + classical + have hrun : resolveThenPrivateProbeOutcome context position candidate = (do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt (.position position) output then pure false + else pure (decide (PrivateStructuralHit + { context.presamplePosition position output with + state := (context.presamplePosition position output).state.addPending + (.position position) candidate }))) := by + rw [resolveThenPrivateProbeOutcome, + resolveDeferredPositionValue_fresh position context hhidden hprivate] + simp only [bind_assoc] + apply bind_congr + intro output + by_cases holdHit : context.state.hitAt (.position position) output + · simp [holdHit] + · simp [holdHit, DeferredContext.presamplePosition] + rw [hrun] + rw [← probEvent_eq_eq_probOutput] + refine (probEvent_bind_le_probEvent_add + (mx := LazyRevealProbe.sampleHashOutput) + (my := fun output => + if context.state.hitAt (.position position) output then pure false + else pure (decide (PrivateStructuralHit + { context.presamplePosition position output with + state := (context.presamplePosition position output).state.addPending + (.position position) candidate }))) + (q := fun hit : Bool => hit = true) + (p := fun output : HashOutput => PrivateStructuralHit + { context.presamplePosition position output with + state := (context.presamplePosition position output).state.addPending + (.position position) candidate }) + (ε := 0) ?_).trans ?_ + · intro output _houtput hmiss + by_cases holdHit : context.state.hitAt (.position position) output + · simp [holdHit] + · simp [holdHit, hmiss] + · simpa only [add_zero] using + probEvent_privateStructuralHit_presamplePosition_addPending_le + context position candidate hclean hhidden + +inductive DirectStopReason where + | fuelExhausted + | ordinaryHit + | privateStructuralHit +deriving DecidableEq + +inductive DirectDetailedResult (alpha : Type) where + | stopped (reason : DirectStopReason) + | done (result : ResolvedRunResult alpha) + +def DirectDetailedResult.toOption : DirectDetailedResult alpha → Option (ResolvedRunResult alpha) + | .stopped _ => none + | .done result => some result + +noncomputable def runDirectResolvedDetailedFromTable + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) : + ProbComp (DirectDetailedResult alpha) := + OracleComp.construct + (C := fun _ : OracleComp (LazyRevealProbe.World Coordinate) alpha => + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → + ProbComp (DirectDetailedResult alpha)) + (fun value context remaining table => + pure (.done ⟨context, remaining, value, table⟩)) + (fun input _next recursivelyRun context fuel table => + match input with + | .uniform n => do + let output ← liftM (unifSpec.query n) + recursivelyRun output context fuel table + | .hashOutput => do + let output ← LazyRevealProbe.sampleHashOutput + recursivelyRun output context fuel table + | .ensure coordinate => + recursivelyRun () + { context with state := context.state.ensure coordinate } fuel table + | .probe coordinate candidate => + match fuel with + | 0 => pure (.stopped .fuelExhausted) + | remaining + 1 => + if coordinate ∈ context.state.revealed then + recursivelyRun () context remaining table + else + recursivelyRun () + { context with + state := context.state.addPending coordinate candidate } + remaining table + | .peek coordinate => + recursivelyRun (context.state.values coordinate) context fuel table + | .publish coordinate => + recursivelyRun () + { context with state := context.state.publish coordinate } fuel table + | .reveal coordinate => + match context.state.values coordinate with + | some output => recursivelyRun output context fuel table + | none => + match coordinate with + | .chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + if context.state.hitAt coordinate output then + pure (.stopped .ordinaryHit) + else + recursivelyRun output + { state := context.state.materialize coordinate output + values := context.values } + fuel table + | .position position => + match context.values position with + | some output => + if context.state.hitAt coordinate output then + pure (.stopped .privateStructuralHit) + else + recursivelyRun output + { state := context.state.materialize coordinate output + values := context.values } + fuel table + | none => do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt coordinate output then + pure (.stopped .ordinaryHit) + else + recursivelyRun output + { state := context.state.materialize coordinate output + values := context.values.install position output } + fuel table) + computation context fuel table + +theorem runDirectResolvedDetailedFromTable_uniform_query_bind + (context : DeferredContext) (fuel n : Nat) + (table : OtsSecretIndex → HashOutput) + (next : Fin (n + 1) → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedDetailedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.uniform n)) : + OracleComp (LazyRevealProbe.World Coordinate) (Fin (n + 1))) >>= next) = (do + let output ← liftM (unifSpec.query n) + runDirectResolvedDetailedFromTable context fuel table (next output)) := by + rfl + +theorem runDirectResolvedDetailedFromTable_hashOutput_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedDetailedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + .hashOutput) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = (do + let output ← LazyRevealProbe.sampleHashOutput + runDirectResolvedDetailedFromTable context fuel table (next output)) := by + rfl + +theorem runDirectResolvedDetailedFromTable_ensure_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedDetailedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.ensure coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runDirectResolvedDetailedFromTable + { context with state := context.state.ensure coordinate } + fuel table (next ()) := by + rfl + +theorem runDirectResolvedDetailedFromTable_probe_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (candidate : Digest) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedDetailedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.probe coordinate candidate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + match fuel with + | 0 => pure (.stopped .fuelExhausted) + | remaining + 1 => + if coordinate ∈ context.state.revealed then + runDirectResolvedDetailedFromTable context remaining table (next ()) + else + runDirectResolvedDetailedFromTable + { context with + state := context.state.addPending coordinate candidate } + remaining table (next ()) := by + rfl + +theorem runDirectResolvedDetailedFromTable_peek_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Option HashOutput → + OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedDetailedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.peek coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) (Option HashOutput)) >>= next) = + runDirectResolvedDetailedFromTable context fuel table + (next (context.state.values coordinate)) := by + rfl + +theorem runDirectResolvedDetailedFromTable_publish_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedDetailedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.publish coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runDirectResolvedDetailedFromTable + { context with state := context.state.publish coordinate } + fuel table (next ()) := by + rfl + +theorem runDirectResolvedDetailedFromTable_reveal_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedDetailedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.reveal coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = + (match context.state.values coordinate with + | some output => + runDirectResolvedDetailedFromTable context fuel table (next output) + | none => + match coordinate with + | .chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + if context.state.hitAt coordinate output then + pure (.stopped .ordinaryHit) + else + runDirectResolvedDetailedFromTable + { state := context.state.materialize coordinate output + values := context.values } + fuel table (next output) + | .position position => + match context.values position with + | some output => + if context.state.hitAt coordinate output then + pure (.stopped .privateStructuralHit) + else + runDirectResolvedDetailedFromTable + { state := context.state.materialize coordinate output + values := context.values } + fuel table (next output) + | none => do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt coordinate output then + pure (.stopped .ordinaryHit) + else + runDirectResolvedDetailedFromTable + { state := context.state.materialize coordinate output + values := context.values.install position output } + fuel table (next output)) := by + cases coordinate <;> rfl + +theorem runDirectResolvedDetailedFromTable_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (left : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (next : alpha → OracleComp (LazyRevealProbe.World Coordinate) beta) : + runDirectResolvedDetailedFromTable context fuel table (left >>= next) = + runDirectResolvedDetailedFromTable context fuel table left >>= fun result => + match result with + | .stopped reason => pure (.stopped reason) + | .done result => + runDirectResolvedDetailedFromTable result.context result.remaining result.table + (next result.value) := by + induction left using OracleComp.inductionOn generalizing context fuel with + | pure value => simp [runDirectResolvedDetailedFromTable] + | query_bind input continuation ih => + cases input with + | uniform n => + rw [bind_assoc, runDirectResolvedDetailedFromTable_uniform_query_bind, + runDirectResolvedDetailedFromTable_uniform_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output context fuel + | hashOutput => + rw [bind_assoc, runDirectResolvedDetailedFromTable_hashOutput_query_bind, + runDirectResolvedDetailedFromTable_hashOutput_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output context fuel + | ensure coordinate => + rw [bind_assoc, runDirectResolvedDetailedFromTable_ensure_query_bind, + runDirectResolvedDetailedFromTable_ensure_query_bind] + exact ih () { context with state := context.state.ensure coordinate } fuel + | probe coordinate candidate => + rw [bind_assoc, runDirectResolvedDetailedFromTable_probe_query_bind, + runDirectResolvedDetailedFromTable_probe_query_bind] + cases fuel with + | zero => simp + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () context remaining + · simp only [hrevealed, ↓reduceIte] + exact ih () + { context with state := context.state.addPending coordinate candidate } + remaining + | peek coordinate => + rw [bind_assoc, runDirectResolvedDetailedFromTable_peek_query_bind, + runDirectResolvedDetailedFromTable_peek_query_bind] + exact ih (context.state.values coordinate) context fuel + | publish coordinate => + rw [bind_assoc, runDirectResolvedDetailedFromTable_publish_query_bind, + runDirectResolvedDetailedFromTable_publish_query_bind] + exact ih () { context with state := context.state.publish coordinate } fuel + | reveal coordinate => + rw [bind_assoc, runDirectResolvedDetailedFromTable_reveal_query_bind, + runDirectResolvedDetailedFromTable_reveal_query_bind] + cases hvalue : context.state.values coordinate with + | some output => + exact ih output context fuel + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] + · simp only [output, hhit, ↓reduceIte] + exact ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel + | position position => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hprivate, hhit] + · simp only [hprivate, hhit, ↓reduceIte] + exact ih output + { state := context.state.materialize (.position position) output + values := context.values } + fuel + | none => + simp only [hprivate, bind_assoc] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + exact ih output + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel + +set_option maxRecDepth 100000 in +theorem map_toOption_runDirectResolvedDetailedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + DirectDetailedResult.toOption <$> + runDirectResolvedDetailedFromTable context fuel table computation = + runDirectResolvedFromTable context fuel table computation := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runDirectResolvedDetailedFromTable, runDirectResolvedFromTable, + DirectDetailedResult.toOption] + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectResolvedDetailedFromTable_uniform_query_bind, + runDirectResolvedFromTable_uniform_query_bind, map_bind] + apply bind_congr + intro output + exact ih output context fuel + | hashOutput => + rw [runDirectResolvedDetailedFromTable_hashOutput_query_bind, + runDirectResolvedFromTable_hashOutput_query_bind, map_bind] + apply bind_congr + intro output + exact ih output context fuel + | ensure coordinate => + rw [runDirectResolvedDetailedFromTable_ensure_query_bind, + runDirectResolvedFromTable_ensure_query_bind] + exact ih () { context with state := context.state.ensure coordinate } fuel + | probe coordinate candidate => + rw [runDirectResolvedDetailedFromTable_probe_query_bind, + runDirectResolvedFromTable_probe_query_bind] + cases fuel with + | zero => simp [DirectDetailedResult.toOption] + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () context remaining + · simp only [hrevealed, ↓reduceIte] + exact ih () + { context with + state := context.state.addPending coordinate candidate } + remaining + | peek coordinate => + rw [runDirectResolvedDetailedFromTable_peek_query_bind, + runDirectResolvedFromTable_peek_query_bind] + exact ih (context.state.values coordinate) context fuel + | publish coordinate => + rw [runDirectResolvedDetailedFromTable_publish_query_bind, + runDirectResolvedFromTable_publish_query_bind] + exact ih () { context with state := context.state.publish coordinate } fuel + | reveal coordinate => + rw [runDirectResolvedDetailedFromTable_reveal_query_bind, + runDirectResolvedFromTable_reveal_query_bind] + cases hstate : context.state.values coordinate with + | some output => + simp only + exact ih output context fuel + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit, DirectDetailedResult.toOption] + · simp only [output, hhit, ↓reduceIte] + exact ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel + | position position => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hprivate, hhit, DirectDetailedResult.toOption, + resolveDeferredPositionValue, hstate] + · simp only [hprivate, hhit, ↓reduceIte] + rw [resolveDeferredPositionValue_of_deferred_value position context + output hstate hprivate, if_neg hhit] + simp only [pure_bind] + exact ih output + { state := context.state.materialize (.position position) output + values := context.values } + fuel + | none => + simp only [hprivate] + rw [resolveDeferredPositionValue_fresh position context hstate hprivate, + map_bind, bind_assoc] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit, DirectDetailedResult.toOption] + · simp only [hhit, ↓reduceIte, pure_bind] + exact ih output + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel + +theorem mem_support_runDirectResolvedFromTable_of_done_detailed + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult alpha) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation)) : + some result ∈ support + (runDirectResolvedFromTable context fuel table computation) := by + rw [← map_toOption_runDirectResolvedDetailedFromTable computation context fuel table, + support_map] + exact ⟨.done result, hresult, rfl⟩ + +inductive DirectBoundaryOutcome where + | success + | ordinaryFailure + | privateStructuralFailure +deriving DecidableEq + +def DirectBoundaryOutcome.failed : DirectBoundaryOutcome → Bool + | .success => false + | .ordinaryFailure => true + | .privateStructuralFailure => true + +def DirectBoundaryOutcome.privateStructural : DirectBoundaryOutcome → Bool + | .privateStructuralFailure => true + | _ => false + +def DirectBoundaryOutcome.ordinary : DirectBoundaryOutcome → Bool + | .ordinaryFailure => true + | _ => false + +def DirectBoundaryOutcome.ofFailed : Bool → DirectBoundaryOutcome + | false => .success + | true => .ordinaryFailure + +@[simp] theorem DirectBoundaryOutcome.failed_ofFailed (failed : Bool) : + (DirectBoundaryOutcome.ofFailed failed).failed = failed := by + cases failed <;> rfl + +@[simp] theorem DirectBoundaryOutcome.ordinary_ofFailed (failed : Bool) : + (DirectBoundaryOutcome.ofFailed failed).ordinary = failed := by + cases failed <;> rfl + +theorem DirectBoundaryOutcome.failed_eq_true_iff + (outcome : DirectBoundaryOutcome) : + outcome.failed = true ↔ + outcome = .ordinaryFailure ∨ outcome = .privateStructuralFailure := by + cases outcome <;> simp [DirectBoundaryOutcome.failed] + +@[simp] theorem DirectBoundaryOutcome.ordinary_eq_true_iff + (outcome : DirectBoundaryOutcome) : + outcome.ordinary = true ↔ outcome = .ordinaryFailure := by + cases outcome <;> simp [DirectBoundaryOutcome.ordinary] + +@[simp] theorem DirectBoundaryOutcome.privateStructural_eq_true_iff + (outcome : DirectBoundaryOutcome) : + outcome.privateStructural = true ↔ outcome = .privateStructuralFailure := by + cases outcome <;> simp [DirectBoundaryOutcome.privateStructural] + +theorem probEvent_ordinaryFailure_eq_map_ordinary + (run : ProbComp DirectBoundaryOutcome) : + Pr[= .ordinaryFailure | run] = + Pr[= true | DirectBoundaryOutcome.ordinary <$> run] := by + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput] + rw [probEvent_map] + exact OracleComp.probEvent_congr' + (fun outcome _ => DirectBoundaryOutcome.ordinary_eq_true_iff outcome |>.symm) rfl + +theorem probEvent_privateStructuralFailure_eq_map_privateStructural + (run : ProbComp DirectBoundaryOutcome) : + Pr[= .privateStructuralFailure | run] = + Pr[= true | DirectBoundaryOutcome.privateStructural <$> run] := by + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput] + rw [probEvent_map] + exact OracleComp.probEvent_congr' + (fun outcome _ => DirectBoundaryOutcome.privateStructural_eq_true_iff outcome |>.symm) rfl + +theorem probEvent_failed_le_ordinary_add_private + (run : ProbComp DirectBoundaryOutcome) : + Pr[fun outcome => outcome.failed = true | run] ≤ + Pr[= .ordinaryFailure | run] + Pr[= .privateStructuralFailure | run] := by + have heq : Pr[fun outcome => outcome.failed = true | run] = + Pr[fun outcome => outcome = .ordinaryFailure ∨ + outcome = .privateStructuralFailure | run] := + OracleComp.probEvent_congr' + (fun outcome _ => DirectBoundaryOutcome.failed_eq_true_iff outcome) rfl + rw [heq] + simpa only [probEvent_eq_eq_probOutput] using + (probEvent_or_le run + (fun outcome => outcome = .ordinaryFailure) + (fun outcome => outcome = .privateStructuralFailure)) + +noncomputable def classifyDirectObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) : + ProbComp DirectBoundaryOutcome := by + classical + exact if PrivateStructuralHit context then + pure .privateStructuralFailure + else if DeferredCompletable table context then + DirectBoundaryOutcome.ofFailed <$> observe context fuel value + else + pure .ordinaryFailure + +theorem evalDist_failed_classifyDirectObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + [ObserverDooms table observe] + (context : DeferredContext) (fuel : Nat) (value : alpha) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + evalDist (DirectBoundaryOutcome.failed <$> + classifyDirectObserve table observe context fuel value) = + evalDist (observe context fuel value) := by + unfold classifyDirectObserve + by_cases hprivate : PrivateStructuralHit context + · simp only [hprivate, ↓reduceIte, map_pure, DirectBoundaryOutcome.failed] + exact (ObserverDooms.eq_true (table := table) (observe := observe) + context fuel value hconsistent hstarts + (fun hcompletable => + (not_privateStructuralHit_of_deferredCompletable hcompletable) hprivate)).symm + · simp only [hprivate, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table context + · simp [hcompletable, Functor.map_map] + · simp only [hcompletable, ↓reduceIte, map_pure, DirectBoundaryOutcome.failed] + exact (ObserverDooms.eq_true (table := table) (observe := observe) + context fuel value hconsistent hstarts hcompletable).symm + +noncomputable def finishDirectDetailedObserve + (observe : DeferredContext → Nat → alpha → ProbComp DirectBoundaryOutcome) : + DirectDetailedResult alpha → ProbComp DirectBoundaryOutcome + | .stopped .privateStructuralHit => pure .privateStructuralFailure + | .stopped _ => pure .ordinaryFailure + | .done result => observe result.context result.remaining result.value + +noncomputable def classifyDirectDetailedObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → alpha → ProbComp DirectBoundaryOutcome) + (context : DeferredContext) (fuel : Nat) (value : alpha) : + ProbComp DirectBoundaryOutcome := by + classical + exact if PrivateStructuralHit context then + pure .privateStructuralFailure + else if DeferredCompletable table context then + observe context fuel value + else + pure .ordinaryFailure + +theorem evalDist_failed_classifyDirectDetailedObserve + (table : OtsSecretIndex → HashOutput) + (detailedObserve : DeferredContext → Nat → alpha → ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + [ObserverDooms table observe] + (context : DeferredContext) (fuel : Nat) (value : alpha) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hproject : evalDist (DirectBoundaryOutcome.failed <$> + detailedObserve context fuel value) = + evalDist (observe context fuel value)) : + evalDist (DirectBoundaryOutcome.failed <$> + classifyDirectDetailedObserve table detailedObserve context fuel value) = + evalDist (observe context fuel value) := by + unfold classifyDirectDetailedObserve + by_cases hprivate : PrivateStructuralHit context + · simp only [hprivate, ↓reduceIte, map_pure, DirectBoundaryOutcome.failed] + exact (ObserverDooms.eq_true (table := table) (observe := observe) + context fuel value hconsistent hstarts + (fun hcompletable => + (not_privateStructuralHit_of_deferredCompletable hcompletable) hprivate)).symm + · simp only [hprivate, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table context + · simpa only [hcompletable, ↓reduceIte] using hproject + · simp only [hcompletable, ↓reduceIte, map_pure, DirectBoundaryOutcome.failed] + exact (ObserverDooms.eq_true (table := table) (observe := observe) + context fuel value hconsistent hstarts hcompletable).symm + +noncomputable def canonicalizeDirectDetailedObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → alpha → ProbComp DirectBoundaryOutcome) + (context : DeferredContext) (fuel : Nat) (value : alpha) : + ProbComp DirectBoundaryOutcome := by + classical + exact if PrivateStructuralHit (canonicalizeMaterializedValues table context) then + pure .privateStructuralFailure + else if PublishedValues context.state then + classifyDirectDetailedObserve table observe + (canonicalizeMaterializedValues table context) fuel value + else + pure .ordinaryFailure + +theorem evalDist_failed_canonicalizeDirectDetailedObserve + (table : OtsSecretIndex → HashOutput) + (detailedObserve : DeferredContext → Nat → alpha → ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + [ObserverDooms table observe] + (context : DeferredContext) (fuel : Nat) (value : alpha) + (hconsistent : context.ValuesConsistent) + (hproject : evalDist (DirectBoundaryOutcome.failed <$> + detailedObserve (canonicalizeMaterializedValues table context) fuel value) = + evalDist (observe (canonicalizeMaterializedValues table context) fuel value)) : + evalDist (DirectBoundaryOutcome.failed <$> + canonicalizeDirectDetailedObserve table detailedObserve context fuel value) = + evalDist (canonicalizeObserve table observe context fuel value) := by + unfold canonicalizeDirectDetailedObserve canonicalizeObserve + by_cases hprivate : PrivateStructuralHit (canonicalizeMaterializedValues table context) + · simp only [hprivate, ↓reduceIte, map_pure, DirectBoundaryOutcome.failed] + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + exact (ObserverDooms.eq_true (table := table) (observe := observe) + (canonicalizeMaterializedValues table context) fuel value + (canonicalizeMaterializedValues_valuesConsistent table context hconsistent) + (canonicalizeMaterializedValues_startTableAgrees table context) + (fun hcompletable => + (not_privateStructuralHit_of_deferredCompletable hcompletable) hprivate)).symm + · simp [hpublished] + · simp only [hprivate, ↓reduceIte] + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + exact evalDist_failed_classifyDirectDetailedObserve table detailedObserve observe + (canonicalizeMaterializedValues table context) fuel value + (canonicalizeMaterializedValues_valuesConsistent table context hconsistent) + (canonicalizeMaterializedValues_startTableAgrees table context) hproject + · simp [hpublished, DirectBoundaryOutcome.failed] + +noncomputable def classifyDirectOrdinaryObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) : + ProbComp Bool := by + classical + exact if PrivateStructuralHit context then + pure false + else if DeferredCompletable table context then + observe context fuel value + else + pure true + +theorem evalDist_ordinary_classifyDirectObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) : + evalDist (DirectBoundaryOutcome.ordinary <$> + classifyDirectObserve table observe context fuel value) = + evalDist (classifyDirectOrdinaryObserve table observe context fuel value) := by + unfold classifyDirectObserve classifyDirectOrdinaryObserve + by_cases hprivate : PrivateStructuralHit context + · simp [hprivate, DirectBoundaryOutcome.ordinary] + · simp only [hprivate, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table context + · simp [hcompletable, Functor.map_map] + · simp [hcompletable, DirectBoundaryOutcome.ordinary] + +noncomputable def finishDirectDetailedOrdinaryObserve + (observe : DeferredContext → Nat → alpha → ProbComp Bool) : + DirectDetailedResult alpha → ProbComp Bool + | .stopped .privateStructuralHit => pure false + | .stopped _ => pure true + | .done result => observe result.context result.remaining result.value + +noncomputable def classifyDirectDetailedOrdinaryObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) : + ProbComp Bool := by + classical + exact if PrivateStructuralHit context then + pure false + else if DeferredCompletable table context then + observe context fuel value + else + pure true + +theorem evalDist_ordinary_classifyDirectDetailedObserve + (table : OtsSecretIndex → HashOutput) + (detailedObserve : DeferredContext → Nat → alpha → ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) + (hproject : evalDist (DirectBoundaryOutcome.ordinary <$> + detailedObserve context fuel value) = + evalDist (observe context fuel value)) : + evalDist (DirectBoundaryOutcome.ordinary <$> + classifyDirectDetailedObserve table detailedObserve context fuel value) = + evalDist (classifyDirectDetailedOrdinaryObserve table observe context fuel value) := by + unfold classifyDirectDetailedObserve classifyDirectDetailedOrdinaryObserve + by_cases hprivate : PrivateStructuralHit context + · simp [hprivate, DirectBoundaryOutcome.ordinary] + · simp only [hprivate, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table context + · simpa [hcompletable] using hproject + · simp [hcompletable, DirectBoundaryOutcome.ordinary] + +noncomputable def canonicalizeDirectDetailedOrdinaryObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) : + ProbComp Bool := by + classical + exact if PrivateStructuralHit (canonicalizeMaterializedValues table context) then + pure false + else if PublishedValues context.state then + classifyDirectDetailedOrdinaryObserve table observe + (canonicalizeMaterializedValues table context) fuel value + else + pure true + +theorem evalDist_ordinary_canonicalizeDirectDetailedObserve + (table : OtsSecretIndex → HashOutput) + (detailedObserve : DeferredContext → Nat → alpha → ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) + (hproject : evalDist (DirectBoundaryOutcome.ordinary <$> + detailedObserve (canonicalizeMaterializedValues table context) fuel value) = + evalDist (observe (canonicalizeMaterializedValues table context) fuel value)) : + evalDist (DirectBoundaryOutcome.ordinary <$> + canonicalizeDirectDetailedObserve table detailedObserve context fuel value) = + evalDist (canonicalizeDirectDetailedOrdinaryObserve table observe context fuel value) := by + unfold canonicalizeDirectDetailedObserve canonicalizeDirectDetailedOrdinaryObserve + by_cases hprivate : PrivateStructuralHit (canonicalizeMaterializedValues table context) + · simp [hprivate, DirectBoundaryOutcome.ordinary] + · simp only [hprivate, ↓reduceIte] + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + exact evalDist_ordinary_classifyDirectDetailedObserve table detailedObserve observe + (canonicalizeMaterializedValues table context) fuel value hproject + · simp [hpublished, DirectBoundaryOutcome.ordinary] + +noncomputable def runDirectDetailedObserve + (observe : DeferredContext → Nat → alpha → ProbComp DirectBoundaryOutcome) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) : + ProbComp DirectBoundaryOutcome := + runDirectResolvedDetailedFromTable context fuel table computation >>= + finishDirectDetailedObserve observe + +theorem evalDist_failed_runDirectDetailedObserve + (detailedObserve : DeferredContext → Nat → alpha → ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (hproject : ∀ result, + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) → + evalDist (DirectBoundaryOutcome.failed <$> + detailedObserve result.context result.remaining result.value) = + evalDist (observe result.context result.remaining result.value)) : + evalDist (DirectBoundaryOutcome.failed <$> + runDirectDetailedObserve detailedObserve context fuel table computation) = + evalDist (runDirectResolvedObserve observe context fuel table computation) := by + unfold runDirectDetailedObserve runDirectResolvedObserve + rw [map_bind] + calc + _ = evalDist (runDirectResolvedDetailedFromTable context fuel table computation >>= + fun result => finishObserve observe (DirectDetailedResult.toOption result)) := by + apply evalDist_bind_congr + intro result hresult + cases result with + | stopped reason => + cases reason <;> rfl + | done result => + exact hproject result hresult + _ = evalDist ((DirectDetailedResult.toOption <$> + runDirectResolvedDetailedFromTable context fuel table computation) >>= + finishObserve observe) := by + apply congrArg evalDist + simp only [map_eq_bind_pure_comp, bind_assoc, pure_bind, Function.comp_apply] + _ = _ := by + rw [map_toOption_runDirectResolvedDetailedFromTable] + +noncomputable def runDirectDetailedOrdinaryObserve + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) : + ProbComp Bool := + runDirectResolvedDetailedFromTable context fuel table computation >>= + finishDirectDetailedOrdinaryObserve observe + +theorem evalDist_ordinary_runDirectDetailedObserve + (detailedObserve : DeferredContext → Nat → alpha → ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (hproject : ∀ result, + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) → + evalDist (DirectBoundaryOutcome.ordinary <$> + detailedObserve result.context result.remaining result.value) = + evalDist (observe result.context result.remaining result.value)) : + evalDist (DirectBoundaryOutcome.ordinary <$> + runDirectDetailedObserve detailedObserve context fuel table computation) = + evalDist (runDirectDetailedOrdinaryObserve observe context fuel table computation) := by + unfold runDirectDetailedObserve runDirectDetailedOrdinaryObserve + rw [map_bind] + apply evalDist_bind_congr + intro result hresult + cases result with + | stopped reason => + cases reason <;> rfl + | done result => + exact hproject result hresult + +noncomputable def directDetailedBoundaryObserve + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec alpha) + (observe : DeferredContext → Nat → (alpha × SplitHashCache) → + ProbComp DirectBoundaryOutcome) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp DirectBoundaryOutcome := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp spec alpha => + (DeferredContext → Nat → (alpha × SplitHashCache) → + ProbComp DirectBoundaryOutcome) → + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp DirectBoundaryOutcome) + (fun value observe context fuel _table cache => observe context fuel (value, cache)) + (fun query _next recursivelyRun observe context fuel table cache => + runDirectDetailedObserve + (canonicalizeDirectDetailedObserve table + (fun nextContext remaining value => + recursivelyRun value.1 observe nextContext remaining table value.2)) + context fuel table ((impl query).run cache)) + computation observe context fuel table cache + +set_option maxRecDepth 100000 in +theorem evalDist_failed_directDetailedBoundaryObserve + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec alpha) + (detailedObserve : DeferredContext → Nat → (alpha × SplitHashCache) → + ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) + [ObserverDooms table observe] + (hobserve : ∀ context fuel value, + context.ValuesConsistent → StartTableAgrees context.state table → + evalDist (DirectBoundaryOutcome.failed <$> + detailedObserve context fuel value) = + evalDist (observe context fuel value)) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + evalDist (DirectBoundaryOutcome.failed <$> + directDetailedBoundaryObserve impl computation detailedObserve context fuel table cache) = + evalDist (directBoundaryObserve impl computation observe context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + rw [directDetailedBoundaryObserve, OracleComp.construct_pure, + directBoundaryObserve, OracleComp.construct_pure] + exact hobserve context fuel (value, cache) hconsistent hstarts + | query_bind query next ih => + rw [directDetailedBoundaryObserve, OracleComp.construct_query_bind, + directBoundaryObserve, OracleComp.construct_query_bind] + let detailedNext : DeferredContext → Nat → + ((spec.Range query) × SplitHashCache) → ProbComp DirectBoundaryOutcome := + fun nextContext remaining value => + directDetailedBoundaryObserve impl (next value.1) detailedObserve + nextContext remaining table value.2 + let nextObserve : DeferredContext → Nat → + ((spec.Range query) × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + directBoundaryObserve impl (next value.1) observe + nextContext remaining table value.2 + letI : ObserverDooms table nextObserve := ⟨by + intro nextContext remaining value hnextConsistent hnextStarts hnextDoomed + exact directBoundaryObserve_dooms impl (next value.1) observe nextContext remaining + value.2 hnextConsistent hnextStarts hnextDoomed⟩ + apply evalDist_failed_runDirectDetailedObserve + intro result hresult + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + ((impl query).run cache) context fuel table result hresult + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable + ((impl query).run cache) context fuel table result hconsistent hstarts hdirect + apply evalDist_failed_canonicalizeDirectDetailedObserve + table detailedNext nextObserve result.context result.remaining result.value hcore.2.1 + exact ih result.value.1 (canonicalizeMaterializedValues table result.context) + result.remaining result.value.2 + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + +noncomputable def directDetailedBoundaryOrdinaryObserve + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec alpha) + (observe : DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp Bool := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp spec alpha => + (DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) → + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp Bool) + (fun value observe context fuel _table cache => observe context fuel (value, cache)) + (fun query _next recursivelyRun observe context fuel table cache => + runDirectDetailedOrdinaryObserve + (canonicalizeDirectDetailedOrdinaryObserve table + (fun nextContext remaining value => + recursivelyRun value.1 observe nextContext remaining table value.2)) + context fuel table ((impl query).run cache)) + computation observe context fuel table cache + +set_option maxRecDepth 100000 in +theorem evalDist_ordinary_directDetailedBoundaryObserve + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec alpha) + (detailedObserve : DeferredContext → Nat → (alpha × SplitHashCache) → + ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) + (hobserve : ∀ context fuel value, + evalDist (DirectBoundaryOutcome.ordinary <$> + detailedObserve context fuel value) = + evalDist (observe context fuel value)) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) : + evalDist (DirectBoundaryOutcome.ordinary <$> + directDetailedBoundaryObserve impl computation detailedObserve context fuel table cache) = + evalDist (directDetailedBoundaryOrdinaryObserve impl computation observe + context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + rw [directDetailedBoundaryObserve, OracleComp.construct_pure, + directDetailedBoundaryOrdinaryObserve, OracleComp.construct_pure] + exact hobserve context fuel (value, cache) + | query_bind query next ih => + rw [directDetailedBoundaryObserve, OracleComp.construct_query_bind, + directDetailedBoundaryOrdinaryObserve, OracleComp.construct_query_bind] + apply evalDist_ordinary_runDirectDetailedObserve + intro result _hresult + apply evalDist_ordinary_canonicalizeDirectDetailedObserve + exact ih result.value.1 (canonicalizeMaterializedValues table result.context) + result.remaining result.value.2 + +noncomputable def directDetailedVerifierFinishObserve + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : (Forgery × QueryLog SigningSpec) × SplitHashCache) : + ProbComp DirectBoundaryOutcome := + runDirectDetailedObserve + (classifyDirectObserve table (resolvedFinalizationObserve table)) + context fuel table ((canonicalVerifierFinish parameter root value.1).run value.2) + +instance directVerifierFinishObserve_observerDooms + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (root : Digest) : + ObserverDooms table (directVerifierFinishObserve table parameter root) where + eq_true context fuel value hconsistent hstarts hdoomed := by + unfold directVerifierFinishObserve + exact evalDist_runDirectResolvedObserve_eq_true_of_not_completable_auto + (observe := resolvedFinalizationObserve table) context fuel table + ((canonicalVerifierFinish parameter root value.1).run value.2) + hconsistent hstarts hdoomed + +theorem evalDist_failed_directDetailedVerifierFinishObserve + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : (Forgery × QueryLog SigningSpec) × SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + evalDist (DirectBoundaryOutcome.failed <$> + directDetailedVerifierFinishObserve table parameter root context fuel value) = + evalDist (directVerifierFinishObserve table parameter root context fuel value) := by + unfold directDetailedVerifierFinishObserve directVerifierFinishObserve + apply evalDist_failed_runDirectDetailedObserve + intro result hresult + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + ((canonicalVerifierFinish parameter root value.1).run value.2) + context fuel table result hresult + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable + ((canonicalVerifierFinish parameter root value.1).run value.2) + context fuel table result hconsistent hstarts hdirect + exact evalDist_failed_classifyDirectObserve table (resolvedFinalizationObserve table) + result.context result.remaining result.value hcore.2.1 hcore.2.2 + +noncomputable def directDetailedVerifierFinishOrdinaryObserve + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : (Forgery × QueryLog SigningSpec) × SplitHashCache) : + ProbComp Bool := + runDirectDetailedOrdinaryObserve + (classifyDirectOrdinaryObserve table (resolvedFinalizationObserve table)) + context fuel table ((canonicalVerifierFinish parameter root value.1).run value.2) + +theorem evalDist_ordinary_directDetailedVerifierFinishObserve + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : (Forgery × QueryLog SigningSpec) × SplitHashCache) : + evalDist (DirectBoundaryOutcome.ordinary <$> + directDetailedVerifierFinishObserve table parameter root context fuel value) = + evalDist (directDetailedVerifierFinishOrdinaryObserve table parameter root + context fuel value) := by + unfold directDetailedVerifierFinishObserve directDetailedVerifierFinishOrdinaryObserve + apply evalDist_ordinary_runDirectDetailedObserve + intro result _hresult + exact evalDist_ordinary_classifyDirectObserve table (resolvedFinalizationObserve table) + result.context result.remaining result.value + +noncomputable def allDirectDetailedRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp DirectBoundaryOutcome := + directDetailedBoundaryObserve + (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (signingTraceComputation (adversary.main ⟨value.1, parameter⟩)) + (directDetailedVerifierFinishObserve table parameter value.1) + context fuel table value.2 + +theorem evalDist_failed_allDirectDetailedRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + evalDist (DirectBoundaryOutcome.failed <$> + allDirectDetailedRetainedRestObserve adversary parameter table ftsSecret + context fuel value) = + evalDist (allDirectRetainedRestObserve adversary parameter table ftsSecret + context fuel value) := by + unfold allDirectDetailedRetainedRestObserve allDirectRetainedRestObserve + apply evalDist_failed_directDetailedBoundaryObserve + intro nextContext remaining nextValue hnextConsistent hnextStarts + exact evalDist_failed_directDetailedVerifierFinishObserve table parameter value.1 + nextContext remaining nextValue hnextConsistent hnextStarts + exact hconsistent + exact hstarts + +noncomputable def allDirectDetailedRetainedRestOrdinaryObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp Bool := + directDetailedBoundaryOrdinaryObserve + (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (signingTraceComputation (adversary.main ⟨value.1, parameter⟩)) + (directDetailedVerifierFinishOrdinaryObserve table parameter value.1) + context fuel table value.2 + +theorem evalDist_ordinary_allDirectDetailedRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : + evalDist (DirectBoundaryOutcome.ordinary <$> + allDirectDetailedRetainedRestObserve adversary parameter table ftsSecret + context fuel value) = + evalDist (allDirectDetailedRetainedRestOrdinaryObserve adversary parameter table + ftsSecret context fuel value) := by + unfold allDirectDetailedRetainedRestObserve allDirectDetailedRetainedRestOrdinaryObserve + apply evalDist_ordinary_directDetailedBoundaryObserve + intro nextContext remaining nextValue + exact evalDist_ordinary_directDetailedVerifierFinishObserve table parameter value.1 + nextContext remaining nextValue + +noncomputable def allDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp DirectBoundaryOutcome := + runDirectDetailedObserve + (allDirectDetailedRetainedRestObserve adversary parameter table ftsSecret) + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem evalDist_failed_allDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.failed <$> + allDirectBoundaryDetailedRetainedOutcome adversary parameter table ftsSecret fuel) = + evalDist (allDirectBoundaryDeferredRetainedFinishIsNone adversary parameter table + ftsSecret fuel) := by + let initial : DeferredContext := + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + unfold allDirectBoundaryDetailedRetainedOutcome + allDirectBoundaryDeferredRetainedFinishIsNone + apply evalDist_failed_runDirectDetailedObserve + intro result hresult + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + (maskedPublishedTreeRoot.run emptySplitHashCache) initial fuel table result hresult + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) initial fuel table result + DeferredContext.valid_empty.valuesConsistent (startTableAgrees_empty table) hdirect + exact evalDist_failed_allDirectDetailedRetainedRestObserve adversary parameter table ftsSecret + result.context result.remaining result.value hcore.2.1 hcore.2.2 + +noncomputable def allDirectBoundaryDetailedRetainedOrdinary + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := + runDirectDetailedOrdinaryObserve + (allDirectDetailedRetainedRestOrdinaryObserve adversary parameter table ftsSecret) + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +theorem evalDist_ordinary_allDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.ordinary <$> + allDirectBoundaryDetailedRetainedOutcome adversary parameter table ftsSecret fuel) = + evalDist (allDirectBoundaryDetailedRetainedOrdinary adversary parameter table + ftsSecret fuel) := by + unfold allDirectBoundaryDetailedRetainedOutcome allDirectBoundaryDetailedRetainedOrdinary + apply evalDist_ordinary_runDirectDetailedObserve + intro result _hresult + exact evalDist_ordinary_allDirectDetailedRetainedRestObserve adversary parameter table ftsSecret + result.context result.remaining result.value + +noncomputable def sampledAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp DirectBoundaryOutcome := do + let table ← sampleOtsHashTable + allDirectBoundaryDetailedRetainedOutcome adversary parameter table ftsSecret fuel + +noncomputable def sampledAllDirectBoundaryDetailedRetainedOrdinary + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := do + let table ← sampleOtsHashTable + allDirectBoundaryDetailedRetainedOrdinary adversary parameter table ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem evalDist_ordinary_sampledAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.ordinary <$> + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret fuel) = + evalDist (sampledAllDirectBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret fuel) := by + unfold sampledAllDirectBoundaryDetailedRetainedOutcome + sampledAllDirectBoundaryDetailedRetainedOrdinary + rw [map_bind] + apply evalDist_bind_congr + intro table _htable + exact evalDist_ordinary_allDirectBoundaryDetailedRetainedOutcome adversary parameter table + ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_ordinaryFailure_sampledAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[= .ordinaryFailure | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret fuel] = + Pr[= true | + sampledAllDirectBoundaryDetailedRetainedOrdinary adversary parameter ftsSecret fuel] := by + rw [probEvent_ordinaryFailure_eq_map_ordinary] + exact OracleComp.probOutput_congr rfl + (evalDist_ordinary_sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret fuel) + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem evalDist_failed_sampledAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.failed <$> + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret fuel) = + evalDist (sampledAllDirectBoundaryFinishIsNone adversary parameter ftsSecret fuel) := by + unfold sampledAllDirectBoundaryDetailedRetainedOutcome sampledAllDirectBoundaryFinishIsNone + rw [map_bind] + apply evalDist_bind_congr + intro table _htable + exact evalDist_failed_allDirectBoundaryDetailedRetainedOutcome adversary parameter table + ftsSecret fuel + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryOrdinary.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryOrdinary.lean new file mode 100644 index 00000000..9407cced --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryOrdinary.lean @@ -0,0 +1,1937 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryProbability + +/-! +# Ordinary boundary failures + +The fixed-table detailed interpreter is averaged by drawing each missing chain start only when it +is revealed. Structural values remain lazy. This is the sampling-order bridge needed by the +ordinary first-fire bound. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option maxHeartbeats 20000 + +def MissingChainStartHit (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) : Prop := + ∃ index, + context.state.values index.coordinate = none ∧ + context.state.hitAt index.coordinate (table index) + +theorem exists_digest_not_mem_pendingAt + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (hcard : state.pending.card < Fintype.card Digest) : + ∃ candidate : Digest, candidate ∉ state.pendingAt coordinate := by + have hcoordinateCard : (state.pendingAt coordinate).card < Fintype.card Digest := by + have hle : (state.pendingAt coordinate).card ≤ state.pending.card := by + have := state.pendingAway_card_add_pendingAt_card_le coordinate + omega + exact hle.trans_lt hcard + have hne : state.pendingAt coordinate ≠ Finset.univ := + (Finset.card_lt_iff_ne_univ _).mp hcoordinateCard + by_contra hmissing + push Not at hmissing + exact hne (Finset.eq_univ_of_forall hmissing) + +theorem deferredCompletable_of_valid_of_no_boundary_hit + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hprivate : ¬PrivateStructuralHit context) + (hstart : ¬MissingChainStartHit table context) + (hcard : context.state.pending.card < Fintype.card Digest) : + DeferredCompletable table context := by + classical + let missingDigest : Coordinate → Digest := fun coordinate => + Classical.choose (exists_digest_not_mem_pendingAt context.state coordinate hcard) + let completion : Coordinate → HashOutput := fun coordinate => + match context.state.values coordinate with + | some output => output + | none => + match coordinate with + | .chainStart lay tree leafIdx chainIdx => table ⟨lay, tree, leafIdx, chainIdx⟩ + | .position position => + match context.values position with + | some output => output + | none => hashOutputOfDigest (missingDigest (.position position)) + refine ⟨completion, ?_, ?_, ?_, ?_⟩ + · intro coordinate output hvalue + simp [completion, hvalue] + · intro position output hvalue + cases hstate : context.state.values (.position position) with + | none => simp [completion, hstate, hvalue] + | some stateOutput => + have heq : stateOutput = output := by + have := hvalid.1 position stateOutput hstate + rw [hvalue] at this + exact (Option.some.inj this).symm + simp [completion, hstate, heq] + · intro coordinate candidate hpending + cases hstate : context.state.values coordinate with + | some output => + have hclean := hvalid.2 coordinate output hstate + have hnotEq : truncateHash output ≠ candidate := by + intro heq + apply hclean + unfold LazyRevealProbe.State.hitAt + rw [LazyRevealProbe.State.mem_pendingAt_iff] + simpa [heq] using hpending + simpa [completion, hstate] using hnotEq + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + have hnotHit : ¬context.state.hitAt index.coordinate (table index) := by + intro hhit + apply hstart + exact ⟨index, by simpa [index, OtsSecretIndex.coordinate] using hstate, hhit⟩ + have hnotEq : truncateHash (table index) ≠ candidate := by + intro heq + apply hnotHit + unfold LazyRevealProbe.State.hitAt + rw [LazyRevealProbe.State.mem_pendingAt_iff] + simpa [heq, index, OtsSecretIndex.coordinate] using hpending + simpa [completion, hstate, index, OtsSecretIndex.coordinate] using hnotEq + | position position => + cases hvalue : context.values position with + | some output => + have hnotHit : ¬context.state.hitAt (.position position) output := by + intro hhit + exact hprivate ⟨position, output, hstate, hvalue, hhit⟩ + have hnotEq : truncateHash output ≠ candidate := by + intro heq + apply hnotHit + unfold LazyRevealProbe.State.hitAt + rw [LazyRevealProbe.State.mem_pendingAt_iff] + simpa [heq] using hpending + simpa [completion, hstate, hvalue] using hnotEq + | none => + have hmissing : missingDigest (.position position) ∉ + context.state.pendingAt (.position position) := + Classical.choose_spec + (exists_digest_not_mem_pendingAt context.state (.position position) hcard) + have hnotEq : missingDigest (.position position) ≠ candidate := by + intro heq + apply hmissing + rw [LazyRevealProbe.State.mem_pendingAt_iff] + simpa [heq] using hpending + simpa [completion, hstate, hvalue, truncateHash_hashOutputOfDigest] using hnotEq + · intro index + cases hstate : context.state.values index.coordinate with + | none => + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + have hstate' : context.state.values + (.chainStart lay tree leafIdx chainIdx) = none := by + simpa [OtsSecretIndex.coordinate] using hstate + change completion (.chainStart lay tree leafIdx chainIdx) = + table ⟨lay, tree, leafIdx, chainIdx⟩ + simp [completion, hstate'] + | some output => + have heq := hstarts index output hstate + simp [completion, hstate, heq] + +theorem privateStructuralHit_or_missingChainStartHit_of_not_completable + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hcard : context.state.pending.card < Fintype.card Digest) + (hnotCompletable : ¬DeferredCompletable table context) : + PrivateStructuralHit context ∨ MissingChainStartHit table context := by + by_cases hprivate : PrivateStructuralHit context + · exact Or.inl hprivate + · right + by_contra hstart + exact hnotCompletable + (deferredCompletable_of_valid_of_no_boundary_hit table context hvalid hstarts hprivate + hstart hcard) + +def ChainStartEntryHit (table : OtsSecretIndex → HashOutput) : + Coordinate × Digest → Prop + | (⟨.chainStart lay tree leafIdx chainIdx, candidate⟩) => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩) = candidate + | _ => False + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 200000 in +theorem probEvent_sampleOtsHashTable_cell_truncate_eq + (index : OtsSecretIndex) (candidate : Digest) : + Pr[fun table : OtsSecretIndex → HashOutput => + truncateHash (table index) = candidate | sampleOtsHashTable] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + have hdist : + evalDist ((fun table : OtsSecretIndex → HashOutput => truncateHash (table index)) <$> + sampleOtsHashTable) = + evalDist (truncateHash <$> LazyRevealProbe.sampleHashOutput) := by + let cont : (OtsSecretIndex → HashOutput) → HashOutput → ProbComp Digest := + fun _table output => pure (truncateHash output) + have hcell := evalDist_completionTable_bind_cell_extract index cont + have hcell' : + evalDist (do + let table ← sampleOtsHashTable + cont table (table index)) = + evalDist (do + let output ← LazyRevealProbe.sampleHashOutput + let table ← sampleOtsHashTable + cont (Function.update table index output) output) := by + simpa only [sampleOtsHashTable, LazyRevealProbe.sampleHashOutput] using hcell + calc + _ = evalDist (do + let table ← sampleOtsHashTable + cont table (table index)) := by rfl + _ = evalDist (do + let output ← LazyRevealProbe.sampleHashOutput + let table ← sampleOtsHashTable + cont (Function.update table index output) output) := hcell' + _ = evalDist (truncateHash <$> LazyRevealProbe.sampleHashOutput) := by + apply evalDist_bind_congr + intro output _houtput + change evalDist (do + let _table ← sampleOtsHashTable + pure (truncateHash output)) = + evalDist (pure (truncateHash output) : ProbComp Digest) + exact evalDist_sampleOtsHashTable_bind_const + (pure (truncateHash output) : ProbComp Digest) + calc + _ = Pr[fun output : Digest => output = candidate | + (fun table : OtsSecretIndex → HashOutput => truncateHash (table index)) <$> + sampleOtsHashTable] := by + rw [probEvent_map] + rfl + _ = Pr[fun output : Digest => output = candidate | + truncateHash <$> LazyRevealProbe.sampleHashOutput] := + OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) hdist + _ = Pr[= candidate | truncateHash <$> LazyRevealProbe.sampleHashOutput] := + probEvent_eq_eq_probOutput _ candidate + _ ≤ _ := by + simpa only [LazyRevealProbe.sampleHashOutput] using + SphincsSecurity.probOutput_truncateHash_le candidate + +theorem exists_chainStartEntryHit_of_missing_completedStartTable + (context : DeferredContext) (base : OtsSecretIndex → HashOutput) + (hmissing : MissingChainStartHit + (completedStartTable context.state base) context) : + ∃ entry ∈ context.state.pending, ChainStartEntryHit base entry := by + obtain ⟨index, hvalue, hhit⟩ := hmissing + have hlookup : completedStartTable context.state base index = base index := by + simp [completedStartTable, hvalue] + have hmem : (index.coordinate, truncateHash (base index)) ∈ context.state.pending := by + rw [← LazyRevealProbe.State.mem_pendingAt_iff] + simpa [LazyRevealProbe.State.hitAt, hlookup] using hhit + refine ⟨(index.coordinate, truncateHash (base index)), hmem, ?_⟩ + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + simp [ChainStartEntryHit, OtsSecretIndex.coordinate] + +theorem probEvent_missingChainStartHit_completedStartTable_le + (context : DeferredContext) : + Pr[fun base : OtsSecretIndex → HashOutput => + MissingChainStartHit (completedStartTable context.state base) context | + sampleOtsHashTable] ≤ + (context.state.pending.card : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ ≤ Pr[fun base : OtsSecretIndex → HashOutput => + ∃ entry ∈ context.state.pending, ChainStartEntryHit base entry | + sampleOtsHashTable] := probEvent_mono fun base _ hmissing => + exists_chainStartEntryHit_of_missing_completedStartTable context base hmissing + _ ≤ ∑ entry ∈ context.state.pending, + Pr[fun base => ChainStartEntryHit base entry | sampleOtsHashTable] := + probEvent_exists_finset_le_sum context.state.pending sampleOtsHashTable + (fun entry base => ChainStartEntryHit base entry) + _ ≤ ∑ _entry ∈ context.state.pending, + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply Finset.sum_le_sum + intro entry _hentry + rcases entry with ⟨coordinate, candidate⟩ + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact probEvent_sampleOtsHashTable_cell_truncate_eq + ⟨lay, tree, leafIdx, chainIdx⟩ candidate + | position position => simp [ChainStartEntryHit] + _ = _ := by + rw [Finset.sum_const, nsmul_eq_mul] + +noncomputable def runDirectResolvedDetailedWithCompletionTable + (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) : + ProbComp (DirectDetailedResult alpha) := + OracleComp.construct + (C := fun _ : OracleComp (LazyRevealProbe.World Coordinate) alpha => + DeferredContext → Nat → ProbComp (DirectDetailedResult alpha)) + (fun value context remaining => do + let base ← sampleOtsHashTable + pure (.done ⟨context, remaining, value, completedStartTable context.state base⟩)) + (fun input _next recursivelyRun context fuel => + match input with + | .uniform n => do + let output ← liftM (unifSpec.query n) + recursivelyRun output context fuel + | .hashOutput => do + let output ← LazyRevealProbe.sampleHashOutput + recursivelyRun output context fuel + | .ensure coordinate => + recursivelyRun () { context with state := context.state.ensure coordinate } fuel + | .probe coordinate candidate => + match fuel with + | 0 => pure (.stopped .fuelExhausted) + | remaining + 1 => + if coordinate ∈ context.state.revealed then + recursivelyRun () context remaining + else + recursivelyRun () + { context with state := context.state.addPending coordinate candidate } + remaining + | .peek coordinate => + recursivelyRun (context.state.values coordinate) context fuel + | .publish coordinate => + recursivelyRun () { context with state := context.state.publish coordinate } fuel + | .reveal coordinate => + match context.state.values coordinate with + | some output => recursivelyRun output context fuel + | none => + match coordinate with + | .chainStart _ _ _ _ => do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt coordinate output then + pure (.stopped .ordinaryHit) + else + recursivelyRun output + { state := context.state.materialize coordinate output + values := context.values } + fuel + | .position position => + match context.values position with + | some output => + if context.state.hitAt coordinate output then + pure (.stopped .privateStructuralHit) + else + recursivelyRun output + { state := context.state.materialize coordinate output + values := context.values } + fuel + | none => do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt coordinate output then + pure (.stopped .ordinaryHit) + else + recursivelyRun output + { state := context.state.materialize coordinate output + values := context.values.install position output } + fuel) + computation context fuel + +theorem runDirectResolvedDetailedFromTable_pure + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (value : alpha) : + runDirectResolvedDetailedFromTable context fuel table + (pure value : OracleComp (LazyRevealProbe.World Coordinate) alpha) = + pure (.done ⟨context, fuel, value, table⟩) := by + rfl + +theorem runDirectResolvedDetailedWithCompletionTable_pure + (context : DeferredContext) (fuel : Nat) (value : alpha) : + runDirectResolvedDetailedWithCompletionTable context fuel + (pure value : OracleComp (LazyRevealProbe.World Coordinate) alpha) = (do + let base ← sampleOtsHashTable + pure (.done ⟨context, fuel, value, completedStartTable context.state base⟩)) := by + rw [runDirectResolvedDetailedWithCompletionTable, OracleComp.construct_pure] + +theorem runDirectResolvedDetailedWithCompletionTable_uniform_query_bind + (context : DeferredContext) (fuel n : Nat) + (next : Fin (n + 1) → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedDetailedWithCompletionTable context fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) (.uniform n)) : + OracleComp (LazyRevealProbe.World Coordinate) (Fin (n + 1))) >>= next) = (do + let output ← liftM (unifSpec.query n) + runDirectResolvedDetailedWithCompletionTable context fuel (next output)) := by + rfl + +theorem runDirectResolvedDetailedWithCompletionTable_hashOutput_query_bind + (context : DeferredContext) (fuel : Nat) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedDetailedWithCompletionTable context fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) .hashOutput) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = (do + let output ← LazyRevealProbe.sampleHashOutput + runDirectResolvedDetailedWithCompletionTable context fuel (next output)) := by + rfl + +theorem runDirectResolvedDetailedWithCompletionTable_ensure_query_bind + (context : DeferredContext) (fuel : Nat) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedDetailedWithCompletionTable context fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.ensure coordinate)) : OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runDirectResolvedDetailedWithCompletionTable + { context with state := context.state.ensure coordinate } fuel (next ()) := by + rfl + +theorem runDirectResolvedDetailedWithCompletionTable_probe_query_bind + (context : DeferredContext) (fuel : Nat) (coordinate : Coordinate) (candidate : Digest) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedDetailedWithCompletionTable context fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.probe coordinate candidate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + match fuel with + | 0 => pure (.stopped .fuelExhausted) + | remaining + 1 => + if coordinate ∈ context.state.revealed then + runDirectResolvedDetailedWithCompletionTable context remaining (next ()) + else + runDirectResolvedDetailedWithCompletionTable + { context with state := context.state.addPending coordinate candidate } + remaining (next ()) := by + rfl + +theorem runDirectResolvedDetailedWithCompletionTable_peek_query_bind + (context : DeferredContext) (fuel : Nat) (coordinate : Coordinate) + (next : Option HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedDetailedWithCompletionTable context fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.peek coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) (Option HashOutput)) >>= next) = + runDirectResolvedDetailedWithCompletionTable context fuel + (next (context.state.values coordinate)) := by + rfl + +theorem runDirectResolvedDetailedWithCompletionTable_publish_query_bind + (context : DeferredContext) (fuel : Nat) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedDetailedWithCompletionTable context fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.publish coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runDirectResolvedDetailedWithCompletionTable + { context with state := context.state.publish coordinate } fuel (next ()) := by + rfl + +theorem runDirectResolvedDetailedWithCompletionTable_reveal_query_bind + (context : DeferredContext) (fuel : Nat) (coordinate : Coordinate) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedDetailedWithCompletionTable context fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.reveal coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = + (match context.state.values coordinate with + | some output => + runDirectResolvedDetailedWithCompletionTable context fuel (next output) + | none => + match coordinate with + | .chainStart _ _ _ _ => do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt coordinate output then + pure (.stopped .ordinaryHit) + else + runDirectResolvedDetailedWithCompletionTable + { state := context.state.materialize coordinate output + values := context.values } + fuel (next output) + | .position position => + match context.values position with + | some output => + if context.state.hitAt coordinate output then + pure (.stopped .privateStructuralHit) + else + runDirectResolvedDetailedWithCompletionTable + { state := context.state.materialize coordinate output + values := context.values } + fuel (next output) + | none => do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt coordinate output then + pure (.stopped .ordinaryHit) + else + runDirectResolvedDetailedWithCompletionTable + { state := context.state.materialize coordinate output + values := context.values.install position output } + fuel (next output)) := by + cases coordinate <;> rfl + +private theorem evalDist_sampled_runDirectResolvedDetailed_reveal_chainStart_query_bind + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) + (ih : ∀ output context fuel, + 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable context.state base + runDirectResolvedDetailedFromTable context fuel table (next output)] = + 𝒟[runDirectResolvedDetailedWithCompletionTable context fuel (next output)]) + (context : DeferredContext) (fuel : Nat) : + 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable context.state base + runDirectResolvedDetailedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.reveal (.chainStart lay tree leafIdx chainIdx))) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next)] = + 𝒟[runDirectResolvedDetailedWithCompletionTable context fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.reveal (.chainStart lay tree leafIdx chainIdx))) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next)] := by + simp_rw [runDirectResolvedDetailedFromTable_reveal_query_bind] + rw [runDirectResolvedDetailedWithCompletionTable_reveal_query_bind] + cases hstate : context.state.values (.chainStart lay tree leafIdx chainIdx) with + | some output => exact ih output context fuel + | none => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + let cont := fun base : OtsSecretIndex → HashOutput => + fun output : HashOutput => + if context.state.hitAt (.chainStart lay tree leafIdx chainIdx) output then + pure (.stopped .ordinaryHit) + else + runDirectResolvedDetailedFromTable + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel (completedStartTable context.state base) (next output) + have hcell := evalDist_completionTable_bind_cell_extract index cont + have hstate' : context.state.values index.coordinate = none := by + simpa [index, OtsSecretIndex.coordinate] using hstate + calc + _ = 𝒟[do + let base ← sampleOtsHashTable + cont base (base index)] := by + apply congrArg evalDist + apply bind_congr + intro base + have hlookup : completedStartTable context.state base index = base index := by + change (context.state.values index.coordinate).getD (base index) = base index + rw [hstate'] + rfl + simp only [cont] + rw [hlookup] + _ = 𝒟[do + let output ← LazyRevealProbe.sampleHashOutput + let base ← sampleOtsHashTable + cont (Function.update base index output) output] := by + simpa only [sampleOtsHashTable, LazyRevealProbe.sampleHashOutput] using hcell + _ = _ := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp only [cont, hhit, ↓reduceIte] + simpa using evalDist_sampleOtsHashTable_bind_const + (pure (.stopped .ordinaryHit) : ProbComp (DirectDetailedResult alpha)) + · simp only [cont, hhit, ↓reduceIte] + have hnext := ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel + have htable (base : OtsSecretIndex → HashOutput) : + completedStartTable context.state (Function.update base index output) = + completedStartTable + (context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output) base := by + rw [completedStartTable_update_base_of_missing context.state base index + output hstate'] + simpa [index, OtsSecretIndex.coordinate] using + (completedStartTable_materialize_coordinate context.state base index output).symm + calc + _ = 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable + (context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output) base + runDirectResolvedDetailedFromTable + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel table (next output)] := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro base + rw [htable base] + _ = _ := hnext + +private theorem evalDist_sampled_runDirectResolvedDetailed_reveal_position_query_bind + (position : Position) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) + (ih : ∀ output context fuel, + 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable context.state base + runDirectResolvedDetailedFromTable context fuel table (next output)] = + 𝒟[runDirectResolvedDetailedWithCompletionTable context fuel (next output)]) + (context : DeferredContext) (fuel : Nat) : + 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable context.state base + runDirectResolvedDetailedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.reveal (.position position))) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next)] = + 𝒟[runDirectResolvedDetailedWithCompletionTable context fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.reveal (.position position))) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next)] := by + simp_rw [runDirectResolvedDetailedFromTable_reveal_query_bind] + rw [runDirectResolvedDetailedWithCompletionTable_reveal_query_bind] + cases hstate : context.state.values (.position position) with + | some output => exact ih output context fuel + | none => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp only [hprivate, hhit, ↓reduceIte] + simpa using evalDist_sampleOtsHashTable_bind_const + (pure (.stopped .privateStructuralHit) : + ProbComp (DirectDetailedResult alpha)) + · simp only [hprivate, hhit, ↓reduceIte] + have hnext := ih output + { state := context.state.materialize (.position position) output + values := context.values } + fuel + calc + _ = 𝒟[do + let base ← sampleOtsHashTable + runDirectResolvedDetailedFromTable + { state := context.state.materialize (.position position) output + values := context.values } + fuel + (completedStartTable + (context.state.materialize (.position position) output) base) + (next output)] := by + apply congrArg evalDist + apply bind_congr + intro base + rw [completedStartTable_materialize_position] + _ = _ := hnext + | none => + simp only [hprivate] + calc + _ = 𝒟[LazyRevealProbe.sampleHashOutput >>= fun output => + sampleOtsHashTable >>= fun base => + if context.state.hitAt (.position position) output then + pure (.stopped .ordinaryHit) + else + runDirectResolvedDetailedFromTable + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel (completedStartTable context.state base) (next output)] := + OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + _ = _ := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + by_cases hhit : context.state.hitAt (.position position) output + · simp only [hhit, ↓reduceIte] + simpa using evalDist_sampleOtsHashTable_bind_const + (pure (.stopped .ordinaryHit) : ProbComp (DirectDetailedResult alpha)) + · simp only [hhit, ↓reduceIte] + have hnext := ih output + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel + calc + _ = 𝒟[do + let base ← sampleOtsHashTable + runDirectResolvedDetailedFromTable + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel + (completedStartTable + (context.state.materialize (.position position) output) base) + (next output)] := by + apply congrArg evalDist + apply bind_congr + intro base + rw [completedStartTable_materialize_position] + _ = _ := hnext + +private theorem evalDist_sampled_runDirectResolvedDetailed_reveal_query_bind + (coordinate : Coordinate) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) + (ih : ∀ output context fuel, + 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable context.state base + runDirectResolvedDetailedFromTable context fuel table (next output)] = + 𝒟[runDirectResolvedDetailedWithCompletionTable context fuel (next output)]) + (context : DeferredContext) (fuel : Nat) : + 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable context.state base + runDirectResolvedDetailedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.reveal coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next)] = + 𝒟[runDirectResolvedDetailedWithCompletionTable context fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.reveal coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next)] := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact evalDist_sampled_runDirectResolvedDetailed_reveal_chainStart_query_bind + lay tree leafIdx chainIdx next ih context fuel + | position position => + exact evalDist_sampled_runDirectResolvedDetailed_reveal_position_query_bind + position next ih context fuel + +private def DirectDetailedSamplingEq + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (context : DeferredContext) (fuel : Nat) : Prop := + 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable context.state base + runDirectResolvedDetailedFromTable context fuel table computation] = + 𝒟[runDirectResolvedDetailedWithCompletionTable context fuel computation] + +private theorem directDetailedSamplingEq_pure + (value : alpha) (context : DeferredContext) (fuel : Nat) : + DirectDetailedSamplingEq + (pure value : OracleComp (LazyRevealProbe.World Coordinate) alpha) context fuel := by + unfold DirectDetailedSamplingEq + simp_rw [runDirectResolvedDetailedFromTable_pure] + rw [runDirectResolvedDetailedWithCompletionTable_pure] + +private theorem directDetailedSamplingEq_uniform_query_bind + (n : Nat) + (next : Fin (n + 1) → OracleComp (LazyRevealProbe.World Coordinate) alpha) + (ih : ∀ output context fuel, DirectDetailedSamplingEq (next output) context fuel) + (context : DeferredContext) (fuel : Nat) : + DirectDetailedSamplingEq + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) (.uniform n)) : + OracleComp (LazyRevealProbe.World Coordinate) (Fin (n + 1))) >>= next) + context fuel := by + unfold DirectDetailedSamplingEq at ih ⊢ + simp_rw [runDirectResolvedDetailedFromTable_uniform_query_bind] + rw [runDirectResolvedDetailedWithCompletionTable_uniform_query_bind] + calc + _ = 𝒟[(liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) >>= fun output => + sampleOtsHashTable >>= fun base => + runDirectResolvedDetailedFromTable context fuel + (completedStartTable context.state base) (next output)] := + OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + _ = _ := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + exact ih output context fuel + +private theorem directDetailedSamplingEq_hashOutput_query_bind + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) + (ih : ∀ output context fuel, DirectDetailedSamplingEq (next output) context fuel) + (context : DeferredContext) (fuel : Nat) : + DirectDetailedSamplingEq + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) .hashOutput) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) + context fuel := by + unfold DirectDetailedSamplingEq at ih ⊢ + simp_rw [runDirectResolvedDetailedFromTable_hashOutput_query_bind] + rw [runDirectResolvedDetailedWithCompletionTable_hashOutput_query_bind] + calc + _ = 𝒟[LazyRevealProbe.sampleHashOutput >>= fun output => + sampleOtsHashTable >>= fun base => + runDirectResolvedDetailedFromTable context fuel + (completedStartTable context.state base) (next output)] := + OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + _ = _ := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + exact ih output context fuel + +private theorem directDetailedSamplingEq_ensure_query_bind + (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) + (ih : ∀ output context fuel, DirectDetailedSamplingEq (next output) context fuel) + (context : DeferredContext) (fuel : Nat) : + DirectDetailedSamplingEq + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.ensure coordinate)) : OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) + context fuel := by + unfold DirectDetailedSamplingEq at ih ⊢ + simp_rw [runDirectResolvedDetailedFromTable_ensure_query_bind] + rw [runDirectResolvedDetailedWithCompletionTable_ensure_query_bind] + have hnext := ih () { context with state := context.state.ensure coordinate } fuel + calc + _ = 𝒟[do + let base ← sampleOtsHashTable + runDirectResolvedDetailedFromTable + { context with state := context.state.ensure coordinate } fuel + (completedStartTable (context.state.ensure coordinate) base) (next ())] := by + apply congrArg evalDist + apply bind_congr + intro base + rw [completedStartTable_ensure] + _ = _ := hnext + +private theorem directDetailedSamplingEq_probe_query_bind + (coordinate : Coordinate) (candidate : Digest) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) + (ih : ∀ output context fuel, DirectDetailedSamplingEq (next output) context fuel) + (context : DeferredContext) (fuel : Nat) : + DirectDetailedSamplingEq + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.probe coordinate candidate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) + context fuel := by + unfold DirectDetailedSamplingEq at ih ⊢ + simp_rw [runDirectResolvedDetailedFromTable_probe_query_bind] + rw [runDirectResolvedDetailedWithCompletionTable_probe_query_bind] + cases fuel with + | zero => + simpa using evalDist_sampleOtsHashTable_bind_const + (pure (.stopped .fuelExhausted) : ProbComp (DirectDetailedResult alpha)) + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () context remaining + · simp only [hrevealed, ↓reduceIte] + have hnext := ih () + { context with state := context.state.addPending coordinate candidate } remaining + calc + _ = 𝒟[do + let base ← sampleOtsHashTable + runDirectResolvedDetailedFromTable + { context with state := context.state.addPending coordinate candidate } + remaining + (completedStartTable + (context.state.addPending coordinate candidate) base) (next ())] := by + apply congrArg evalDist + apply bind_congr + intro base + rw [completedStartTable_addPending] + _ = _ := hnext + +private theorem directDetailedSamplingEq_peek_query_bind + (coordinate : Coordinate) + (next : Option HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) + (ih : ∀ output context fuel, DirectDetailedSamplingEq (next output) context fuel) + (context : DeferredContext) (fuel : Nat) : + DirectDetailedSamplingEq + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.peek coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) (Option HashOutput)) >>= next) + context fuel := by + unfold DirectDetailedSamplingEq at ih ⊢ + simp_rw [runDirectResolvedDetailedFromTable_peek_query_bind] + rw [runDirectResolvedDetailedWithCompletionTable_peek_query_bind] + exact ih (context.state.values coordinate) context fuel + +private theorem directDetailedSamplingEq_publish_query_bind + (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) + (ih : ∀ output context fuel, DirectDetailedSamplingEq (next output) context fuel) + (context : DeferredContext) (fuel : Nat) : + DirectDetailedSamplingEq + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.publish coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) + context fuel := by + unfold DirectDetailedSamplingEq at ih ⊢ + simp_rw [runDirectResolvedDetailedFromTable_publish_query_bind] + rw [runDirectResolvedDetailedWithCompletionTable_publish_query_bind] + have hnext := ih () { context with state := context.state.publish coordinate } fuel + calc + _ = 𝒟[do + let base ← sampleOtsHashTable + runDirectResolvedDetailedFromTable + { context with state := context.state.publish coordinate } fuel + (completedStartTable (context.state.publish coordinate) base) (next ())] := by + apply congrArg evalDist + apply bind_congr + intro base + rw [completedStartTable_publish] + _ = _ := hnext + +private theorem directDetailedSamplingEq_reveal_query_bind + (coordinate : Coordinate) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) + (ih : ∀ output context fuel, DirectDetailedSamplingEq (next output) context fuel) + (context : DeferredContext) (fuel : Nat) : + DirectDetailedSamplingEq + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.reveal coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) + context fuel := by + unfold DirectDetailedSamplingEq at ih ⊢ + exact evalDist_sampled_runDirectResolvedDetailed_reveal_query_bind + coordinate next ih context fuel + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 100000 in +theorem evalDist_sampled_runDirectResolvedDetailed_eq_completionTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (context : DeferredContext) (fuel : Nat) : + 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable context.state base + runDirectResolvedDetailedFromTable context fuel table computation] = + 𝒟[runDirectResolvedDetailedWithCompletionTable context fuel computation] := by + change DirectDetailedSamplingEq computation context fuel + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => exact directDetailedSamplingEq_pure value context fuel + | query_bind input next ih => + cases input with + | uniform n => + exact directDetailedSamplingEq_uniform_query_bind n next ih context fuel + | hashOutput => + exact directDetailedSamplingEq_hashOutput_query_bind next ih context fuel + | ensure coordinate => + exact directDetailedSamplingEq_ensure_query_bind coordinate next ih context fuel + | probe coordinate candidate => + exact directDetailedSamplingEq_probe_query_bind coordinate candidate next ih context fuel + | peek coordinate => + exact directDetailedSamplingEq_peek_query_bind coordinate next ih context fuel + | publish coordinate => + exact directDetailedSamplingEq_publish_query_bind coordinate next ih context fuel + | reveal coordinate => + exact directDetailedSamplingEq_reveal_query_bind coordinate next ih context fuel + +noncomputable def finishDirectDetailedSafeOrdinaryObserve + (observe : (OtsSecretIndex → HashOutput) → + DeferredContext → Nat → alpha → ProbComp Bool) : + DirectDetailedResult alpha → ProbComp Bool + | .stopped .ordinaryHit => pure true + | .stopped _ => pure false + | .done result => observe result.table result.context result.remaining result.value + +noncomputable def runDirectDetailedSafeOrdinaryWithCompletionTable + (observe : (OtsSecretIndex → HashOutput) → + DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) : ProbComp Bool := + runDirectResolvedDetailedWithCompletionTable context fuel computation >>= + finishDirectDetailedSafeOrdinaryObserve observe + +theorem evalDist_sampled_runDirectDetailedSafeOrdinary_eq_completionTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (observe : (OtsSecretIndex → HashOutput) → + DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) : + 𝒟[(do + let base ← sampleOtsHashTable + let table := completedStartTable context.state base + runDirectResolvedDetailedFromTable context fuel table computation) >>= + finishDirectDetailedSafeOrdinaryObserve observe] = + 𝒟[runDirectDetailedSafeOrdinaryWithCompletionTable observe context fuel computation] := by + unfold runDirectDetailedSafeOrdinaryWithCompletionTable + exact evalDist_bind_eq_of_evalDist_eq + (evalDist_sampled_runDirectResolvedDetailed_eq_completionTable computation context fuel) + (finishDirectDetailedSafeOrdinaryObserve observe) + +theorem runDirectDetailedSafeOrdinaryWithCompletionTable_pure + (observe : (OtsSecretIndex → HashOutput) → + DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) : + runDirectDetailedSafeOrdinaryWithCompletionTable observe context fuel + (pure value : OracleComp (LazyRevealProbe.World Coordinate) alpha) = (do + let base ← sampleOtsHashTable + observe (completedStartTable context.state base) context fuel value) := by + rw [runDirectDetailedSafeOrdinaryWithCompletionTable, + runDirectResolvedDetailedWithCompletionTable_pure] + simp only [bind_assoc, pure_bind, finishDirectDetailedSafeOrdinaryObserve] + +theorem runDirectDetailedSafeOrdinaryWithCompletionTable_uniform_query_bind + (observe : (OtsSecretIndex → HashOutput) → + DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel n : Nat) + (next : Fin (n + 1) → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectDetailedSafeOrdinaryWithCompletionTable observe context fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) (.uniform n)) : + OracleComp (LazyRevealProbe.World Coordinate) (Fin (n + 1))) >>= next) = (do + let output ← liftM (unifSpec.query n) + runDirectDetailedSafeOrdinaryWithCompletionTable observe context fuel (next output)) := by + rw [runDirectDetailedSafeOrdinaryWithCompletionTable, + runDirectResolvedDetailedWithCompletionTable_uniform_query_bind, bind_assoc] + rfl + +theorem runDirectDetailedSafeOrdinaryWithCompletionTable_hashOutput_query_bind + (observe : (OtsSecretIndex → HashOutput) → + DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectDetailedSafeOrdinaryWithCompletionTable observe context fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) .hashOutput) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = (do + let output ← LazyRevealProbe.sampleHashOutput + runDirectDetailedSafeOrdinaryWithCompletionTable observe context fuel (next output)) := by + rw [runDirectDetailedSafeOrdinaryWithCompletionTable, + runDirectResolvedDetailedWithCompletionTable_hashOutput_query_bind, bind_assoc] + rfl + +theorem runDirectDetailedSafeOrdinaryWithCompletionTable_ensure_query_bind + (observe : (OtsSecretIndex → HashOutput) → + DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectDetailedSafeOrdinaryWithCompletionTable observe context fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.ensure coordinate)) : OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runDirectDetailedSafeOrdinaryWithCompletionTable observe + { context with state := context.state.ensure coordinate } fuel (next ()) := by + rw [runDirectDetailedSafeOrdinaryWithCompletionTable, + runDirectResolvedDetailedWithCompletionTable_ensure_query_bind] + rfl + +theorem runDirectDetailedSafeOrdinaryWithCompletionTable_probe_query_bind + (observe : (OtsSecretIndex → HashOutput) → + DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (coordinate : Coordinate) (candidate : Digest) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectDetailedSafeOrdinaryWithCompletionTable observe context fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.probe coordinate candidate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + match fuel with + | 0 => pure false + | remaining + 1 => + if coordinate ∈ context.state.revealed then + runDirectDetailedSafeOrdinaryWithCompletionTable observe context remaining (next ()) + else + runDirectDetailedSafeOrdinaryWithCompletionTable observe + { context with state := context.state.addPending coordinate candidate } + remaining (next ()) := by + rw [runDirectDetailedSafeOrdinaryWithCompletionTable, + runDirectResolvedDetailedWithCompletionTable_probe_query_bind] + cases fuel with + | zero => rfl + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed <;> + simp only [hrevealed, ↓reduceIte] <;> rfl + +theorem runDirectDetailedSafeOrdinaryWithCompletionTable_peek_query_bind + (observe : (OtsSecretIndex → HashOutput) → + DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (coordinate : Coordinate) + (next : Option HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectDetailedSafeOrdinaryWithCompletionTable observe context fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.peek coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) (Option HashOutput)) >>= next) = + runDirectDetailedSafeOrdinaryWithCompletionTable observe context fuel + (next (context.state.values coordinate)) := by + rw [runDirectDetailedSafeOrdinaryWithCompletionTable, + runDirectResolvedDetailedWithCompletionTable_peek_query_bind] + rfl + +theorem runDirectDetailedSafeOrdinaryWithCompletionTable_publish_query_bind + (observe : (OtsSecretIndex → HashOutput) → + DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectDetailedSafeOrdinaryWithCompletionTable observe context fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.publish coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runDirectDetailedSafeOrdinaryWithCompletionTable observe + { context with state := context.state.publish coordinate } fuel (next ()) := by + rw [runDirectDetailedSafeOrdinaryWithCompletionTable, + runDirectResolvedDetailedWithCompletionTable_publish_query_bind] + rfl + +theorem runDirectDetailedSafeOrdinaryWithCompletionTable_reveal_query_bind + (observe : (OtsSecretIndex → HashOutput) → + DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (coordinate : Coordinate) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectDetailedSafeOrdinaryWithCompletionTable observe context fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.reveal coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = + (match context.state.values coordinate with + | some output => + runDirectDetailedSafeOrdinaryWithCompletionTable observe context fuel (next output) + | none => + match coordinate with + | .chainStart _ _ _ _ => do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt coordinate output then pure true + else + runDirectDetailedSafeOrdinaryWithCompletionTable observe + { state := context.state.materialize coordinate output + values := context.values } + fuel (next output) + | .position position => + match context.values position with + | some output => + if context.state.hitAt coordinate output then pure false + else + runDirectDetailedSafeOrdinaryWithCompletionTable observe + { state := context.state.materialize coordinate output + values := context.values } + fuel (next output) + | none => do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt coordinate output then pure true + else + runDirectDetailedSafeOrdinaryWithCompletionTable observe + { state := context.state.materialize coordinate output + values := context.values.install position output } + fuel (next output)) := by + rw [runDirectDetailedSafeOrdinaryWithCompletionTable, + runDirectResolvedDetailedWithCompletionTable_reveal_query_bind] + cases hstate : context.state.values coordinate with + | some output => rfl + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [bind_assoc] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output <;> + simp only [hhit, ↓reduceIte] <;> rfl + | position position => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output <;> + simp only [hprivate, hhit, ↓reduceIte] <;> rfl + | none => + simp only [hprivate, bind_assoc] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output <;> + simp only [hhit, ↓reduceIte] <;> rfl + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 200000 in +set_option linter.constructorNameAsVariable false in +theorem probEvent_runDirectDetailedSafeOrdinaryWithCompletionTable_le + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (observe : (OtsSecretIndex → HashOutput) → + DeferredContext → Nat → alpha → ProbComp Bool) + (hobserve : ∀ (context : DeferredContext) (fuel : Nat) (value : alpha), + Pr[fun hit : Bool => hit = true | do + let base ← sampleOtsHashTable + observe (completedStartTable context.state base) context fuel value] ≤ + ((fuel + context.state.pending.card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) + (context : DeferredContext) (fuel : Nat) : + Pr[fun hit : Bool => hit = true | + runDirectDetailedSafeOrdinaryWithCompletionTable observe context fuel computation] ≤ + ((fuel + context.state.pending.card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + rw [runDirectDetailedSafeOrdinaryWithCompletionTable_pure] + exact hobserve context fuel value + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectDetailedSafeOrdinaryWithCompletionTable_uniform_query_bind] + exact probEvent_bind_le_of_forall_le fun output _ => ih output context fuel + | hashOutput => + rw [runDirectDetailedSafeOrdinaryWithCompletionTable_hashOutput_query_bind] + exact probEvent_bind_le_of_forall_le fun output _ => ih output context fuel + | ensure coordinate => + rw [runDirectDetailedSafeOrdinaryWithCompletionTable_ensure_query_bind] + simpa only [LazyRevealProbe.State.pending_card_ensure] using + ih () { context with state := context.state.ensure coordinate } fuel + | probe coordinate candidate => + rw [runDirectDetailedSafeOrdinaryWithCompletionTable_probe_query_bind] + cases fuel with + | zero => simp + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + refine (ih () context remaining).trans ?_ + have hnat : remaining + context.state.pending.card ≤ + remaining + 1 + context.state.pending.card := by omega + exact mul_le_mul_of_nonneg_right (by exact_mod_cast hnat) zero_le + · simp only [hrevealed, ↓reduceIte] + refine (ih () + { context with state := context.state.addPending coordinate candidate } + remaining).trans ?_ + have hnat : remaining + + (context.state.addPending coordinate candidate).pending.card ≤ + remaining + 1 + context.state.pending.card := by + have := context.state.pending_card_addPending_le coordinate candidate + omega + exact mul_le_mul_of_nonneg_right (by exact_mod_cast hnat) zero_le + | peek coordinate => + rw [runDirectDetailedSafeOrdinaryWithCompletionTable_peek_query_bind] + exact ih (context.state.values coordinate) context fuel + | publish coordinate => + rw [runDirectDetailedSafeOrdinaryWithCompletionTable_publish_query_bind] + exact ih () { context with state := context.state.publish coordinate } fuel + | reveal coordinate => + rw [runDirectDetailedSafeOrdinaryWithCompletionTable_reveal_query_bind] + cases hstate : context.state.values coordinate with + | some output => exact ih output context fuel + | none => + simp only + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + refine (probEvent_bind_le_probEvent_add + (mx := LazyRevealProbe.sampleHashOutput) + (my := fun output => + if context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output then + pure true + else + runDirectDetailedSafeOrdinaryWithCompletionTable observe + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel (next output)) + (q := fun hit : Bool => hit = true) + (p := context.state.hitAt (.chainStart lay tree leafIdx chainIdx)) + (ε := ((fuel + (context.state.pendingAway + (.chainStart lay tree leafIdx chainIdx)).card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) ?_).trans ?_ + · intro output _houtput hmiss + simp only [hmiss, ↓reduceIte] + simpa only [LazyRevealProbe.State.pending_card_materialize] using + ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel + · refine add_le_add + (LazyRevealProbe.probEvent_sampleHashOutput_hitAt_le context.state + (.chainStart lay tree leafIdx chainIdx)) le_rfl |>.trans ?_ + calc + ((context.state.pendingAt + (.chainStart lay tree leafIdx chainIdx)).card : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + ((fuel + (context.state.pendingAway + (.chainStart lay tree leafIdx chainIdx)).card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ = + (((context.state.pendingAt + (.chainStart lay tree leafIdx chainIdx)).card + fuel + + (context.state.pendingAway + (.chainStart lay tree leafIdx chainIdx)).card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + push_cast + ring + _ ≤ ((fuel + context.state.pending.card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + have hsplit := context.state.pendingAway_card_add_pendingAt_card_le + (.chainStart lay tree leafIdx chainIdx) + have hnat : + (context.state.pendingAt + (.chainStart lay tree leafIdx chainIdx)).card + fuel + + (context.state.pendingAway + (.chainStart lay tree leafIdx chainIdx)).card ≤ + fuel + context.state.pending.card := by omega + exact mul_le_mul_of_nonneg_right (by exact_mod_cast hnat) zero_le + | position position => + simp only + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + refine (ih output + { state := context.state.materialize (.position position) output + values := context.values } + fuel).trans ?_ + have hsplit := context.state.pendingAway_card_add_pendingAt_card_le + (.position position) + have hnat : fuel + + (context.state.pendingAway (.position position)).card ≤ + fuel + context.state.pending.card := by omega + simpa only [LazyRevealProbe.State.pending_card_materialize] using + mul_le_mul_of_nonneg_right (by exact_mod_cast hnat) zero_le + | none => + refine (probEvent_bind_le_probEvent_add + (mx := LazyRevealProbe.sampleHashOutput) + (my := fun output => + if context.state.hitAt (.position position) output then + pure true + else + runDirectDetailedSafeOrdinaryWithCompletionTable observe + { state := context.state.materialize + (.position position) output + values := context.values.install position output } + fuel (next output)) + (q := fun hit : Bool => hit = true) + (p := context.state.hitAt (.position position)) + (ε := ((fuel + (context.state.pendingAway + (.position position)).card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) ?_).trans ?_ + · intro output _houtput hmiss + simp only [hmiss, ↓reduceIte] + simpa only [LazyRevealProbe.State.pending_card_materialize] using + ih output + { state := context.state.materialize + (.position position) output + values := context.values.install position output } + fuel + · refine add_le_add + (LazyRevealProbe.probEvent_sampleHashOutput_hitAt_le context.state + (.position position)) le_rfl |>.trans ?_ + calc + ((context.state.pendingAt (.position position)).card : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + ((fuel + (context.state.pendingAway + (.position position)).card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ = + (((context.state.pendingAt (.position position)).card + fuel + + (context.state.pendingAway + (.position position)).card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + push_cast + ring + _ ≤ ((fuel + context.state.pending.card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + have hsplit := context.state.pendingAway_card_add_pendingAt_card_le + (.position position) + have hnat : + (context.state.pendingAt (.position position)).card + fuel + + (context.state.pendingAway + (.position position)).card ≤ + fuel + context.state.pending.card := by omega + exact mul_le_mul_of_nonneg_right + (by exact_mod_cast hnat) zero_le + +theorem probEvent_runDirectDetailedSafeOrdinaryFinalize_le + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (context : DeferredContext) (fuel : Nat) : + Pr[fun hit : Bool => hit = true | + runDirectDetailedSafeOrdinaryWithCompletionTable + (fun _ nextContext _ _ => LazyRevealProbe.finalize nextContext.state) + context fuel computation] ≤ + ((fuel + context.state.pending.card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply probEvent_runDirectDetailedSafeOrdinaryWithCompletionTable_le + intro nextContext remaining value + have hdist : + 𝒟[do + let _base ← sampleOtsHashTable + LazyRevealProbe.finalize nextContext.state] = + 𝒟[LazyRevealProbe.finalize nextContext.state] := + evalDist_sampleOtsHashTable_bind_const _ + refine (OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) hdist).le.trans ?_ + refine (LazyRevealProbe.finalize_probability_le nextContext.state).trans ?_ + have hnat : nextContext.state.pending.card ≤ + remaining + nextContext.state.pending.card := by omega + exact mul_le_mul_of_nonneg_right (by exact_mod_cast hnat) zero_le + +def DirectDetailedResult.toRawResult : + DirectDetailedResult alpha → LazyRevealProbe.RawResult Coordinate alpha + | .stopped .ordinaryHit => .stopped true + | .stopped _ => .stopped false + | .done result => .done result.context.state result.remaining result.value + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 200000 in +theorem evalDist_toRawResult_runDirectResolvedDetailedWithCompletionTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) : + 𝒟[DirectDetailedResult.toRawResult <$> + runDirectResolvedDetailedWithCompletionTable + (directDeferredContext state) fuel computation] = + 𝒟[LazyRevealProbe.runRaw state fuel computation] := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + rw [runDirectResolvedDetailedWithCompletionTable_pure] + calc + _ = 𝒟[sampleOtsHashTable >>= fun _ => + (pure (.done state fuel value) : + ProbComp (LazyRevealProbe.RawResult Coordinate alpha))] := by + apply congrArg evalDist + rw [map_bind] + apply bind_congr + intro base + rfl + _ = 𝒟[pure (.done state fuel value)] := + evalDist_sampleOtsHashTable_bind_const _ + _ = _ := rfl + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectResolvedDetailedWithCompletionTable_uniform_query_bind, + LazyRevealProbe.runRaw_uniform_query_bind, map_bind] + apply evalDist_bind_congr + intro output _houtput + exact ih output state fuel + | hashOutput => + rw [runDirectResolvedDetailedWithCompletionTable_hashOutput_query_bind, + LazyRevealProbe.runRaw_hashOutput_query_bind, map_bind] + apply evalDist_bind_congr + intro output _houtput + exact ih output state fuel + | ensure coordinate => + rw [runDirectResolvedDetailedWithCompletionTable_ensure_query_bind, + LazyRevealProbe.runRaw_ensure_query_bind] + simpa [directDeferredContext, directDeferredValues_ensure] using + ih () (state.ensure coordinate) fuel + | probe coordinate candidate => + rw [runDirectResolvedDetailedWithCompletionTable_probe_query_bind, + LazyRevealProbe.runRaw_probe_query_bind] + cases fuel with + | zero => simp [DirectDetailedResult.toRawResult] + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [directDeferredContext, hrevealed, ↓reduceIte] + exact ih () state remaining + · simp only [directDeferredContext, hrevealed, ↓reduceIte] + simpa [directDeferredContext, directDeferredValues_addPending] using + ih () (state.addPending coordinate candidate) remaining + | peek coordinate => + rw [runDirectResolvedDetailedWithCompletionTable_peek_query_bind, + LazyRevealProbe.runRaw_peek_query_bind] + exact ih (state.values coordinate) state fuel + | publish coordinate => + rw [runDirectResolvedDetailedWithCompletionTable_publish_query_bind, + LazyRevealProbe.runRaw_publish_query_bind] + simpa [directDeferredContext, directDeferredValues_publish] using + ih () (state.publish coordinate) fuel + | reveal coordinate => + rw [runDirectResolvedDetailedWithCompletionTable_reveal_query_bind, + LazyRevealProbe.runRaw_reveal_query_bind] + cases hstate : state.values coordinate with + | some output => + simp only [directDeferredContext, hstate] + exact ih output state fuel + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [directDeferredContext, hstate, map_bind] + apply evalDist_bind_congr + intro output _houtput + by_cases hhit : state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [hhit, DirectDetailedResult.toRawResult] + · simp only [hhit, ↓reduceIte] + have hcontext : + { state := state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := directDeferredValues state } = + directDeferredContext + (state.materialize + (.chainStart lay tree leafIdx chainIdx) output) := by + congr 1 + rw [hcontext] + exact ih output + (state.materialize + (.chainStart lay tree leafIdx chainIdx) output) fuel + | position position => + simp only [directDeferredContext, directDeferredValues, hstate, + map_bind] + apply evalDist_bind_congr + intro output _houtput + by_cases hhit : state.hitAt (.position position) output + · simp [hhit, DirectDetailedResult.toRawResult] + · simp only [hhit, ↓reduceIte] + have hcontext : + { state := state.materialize (.position position) output + values := (directDeferredValues state).install position output } = + directDeferredContext + (state.materialize (.position position) output) := by + simp [directDeferredContext, + directDeferredValues_materialize_position] + rw [hcontext] + exact ih output (state.materialize (.position position) output) fuel + +theorem finishDirectDetailedSafeOrdinaryFinalize_eq_rawFinish + (result : DirectDetailedResult alpha) : + finishDirectDetailedSafeOrdinaryObserve + (fun _ context _ _ => LazyRevealProbe.finalize context.state) result = + result.toRawResult.finish := by + cases result with + | stopped reason => cases reason <;> rfl + | done result => rfl + +theorem evalDist_runDirectDetailedSafeOrdinaryFinalize_eq_runRawFinish + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) : + 𝒟[runDirectDetailedSafeOrdinaryWithCompletionTable + (fun _ context _ _ => LazyRevealProbe.finalize context.state) + (directDeferredContext state) fuel computation] = + 𝒟[LazyRevealProbe.runRaw state fuel computation >>= + LazyRevealProbe.RawResult.finish] := by + unfold runDirectDetailedSafeOrdinaryWithCompletionTable + calc + _ = 𝒟[(DirectDetailedResult.toRawResult <$> + runDirectResolvedDetailedWithCompletionTable + (directDeferredContext state) fuel computation) >>= + LazyRevealProbe.RawResult.finish] := by + apply congrArg evalDist + rw [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro result + exact finishDirectDetailedSafeOrdinaryFinalize_eq_rawFinish result + _ = _ := evalDist_bind_eq_of_evalDist_eq + (evalDist_toRawResult_runDirectResolvedDetailedWithCompletionTable computation state fuel) + LazyRevealProbe.RawResult.finish + +theorem evalDist_runDirectDetailedSafeOrdinaryFinalize_eq_experiment + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (hnotStopped : LazyRevealProbe.RawResult.stopped false ∉ support + (LazyRevealProbe.runRaw state fuel computation)) : + 𝒟[runDirectDetailedSafeOrdinaryWithCompletionTable + (fun _ context _ _ => LazyRevealProbe.finalize context.state) + (directDeferredContext state) fuel computation] = + 𝒟[LazyRevealProbe.experiment state fuel computation] := by + calc + _ = 𝒟[LazyRevealProbe.runRaw state fuel computation >>= + LazyRevealProbe.RawResult.finish] := + evalDist_runDirectDetailedSafeOrdinaryFinalize_eq_runRawFinish computation state fuel + _ = _ := + (LazyRevealProbe.evalDist_experiment_eq_runRaw_finish_of_not_stopped_false + state fuel computation hnotStopped).symm + +theorem probEvent_runDirectDetailedSafeOrdinaryFinalize_empty_le + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) (fuel : Nat) : + Pr[= true | + runDirectDetailedSafeOrdinaryWithCompletionTable + (fun _ context _ _ => LazyRevealProbe.finalize context.state) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel computation] ≤ + (fuel : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + simpa [directDeferredContext, LazyRevealProbe.State.empty] using + (probEvent_runDirectDetailedSafeOrdinaryFinalize_le computation + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) fuel) + +theorem fuelExhausted_not_mem_support_runDirectResolvedDetailedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe fuel) : + DirectDetailedResult.stopped .fuelExhausted ∉ support + (runDirectResolvedDetailedFromTable context fuel table computation) := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runDirectResolvedDetailedFromTable_pure] + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases input with + | uniform n => + rw [runDirectResolvedDetailedFromTable_uniform_query_bind, mem_support_bind_iff] + rintro ⟨output, _houtput, hrest⟩ + exact ih output context fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) hrest + | hashOutput => + rw [runDirectResolvedDetailedFromTable_hashOutput_query_bind, mem_support_bind_iff] + rintro ⟨output, _houtput, hrest⟩ + exact ih output context fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) hrest + | ensure coordinate => + rw [runDirectResolvedDetailedFromTable_ensure_query_bind] + exact ih () { context with state := context.state.ensure coordinate } fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) + | probe coordinate candidate => + have hpositive : 0 < fuel := by + simpa [LazyRevealProbe.IsProbe] using hbound.1 + cases fuel with + | zero => omega + | succ remaining => + rw [runDirectResolvedDetailedFromTable_probe_query_bind] + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () context remaining + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) + · simp only [hrevealed, ↓reduceIte] + exact ih () + { context with + state := context.state.addPending coordinate candidate } + remaining + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) + | peek coordinate => + rw [runDirectResolvedDetailedFromTable_peek_query_bind] + exact ih (context.state.values coordinate) context fuel + (by simpa [LazyRevealProbe.IsProbe] using + hbound.2 (context.state.values coordinate)) + | publish coordinate => + rw [runDirectResolvedDetailedFromTable_publish_query_bind] + exact ih () { context with state := context.state.publish coordinate } fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) + | reveal coordinate => + rw [runDirectResolvedDetailedFromTable_reveal_query_bind] + cases hstate : context.state.values coordinate with + | some output => + exact ih output context fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] + · simp only [output, hhit, ↓reduceIte] + exact ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + | position position => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hprivate, hhit] + · simp only [hprivate, hhit, ↓reduceIte] + exact ih output + { state := context.state.materialize (.position position) output + values := context.values } + fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + | none => + simp only [hprivate, mem_support_bind_iff] + rintro ⟨output, _houtput, hrest⟩ + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hrest + · simp only [hhit, ↓reduceIte] at hrest + exact ih output + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) hrest + +theorem stopped_false_mem_support_runRaw_of_fuelExhausted_detailed + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (hresult : DirectDetailedResult.stopped .fuelExhausted ∈ support + (runDirectResolvedDetailedWithCompletionTable + (directDeferredContext state) fuel computation)) : + LazyRevealProbe.RawResult.stopped false ∈ support + (LazyRevealProbe.runRaw state fuel computation) := by + have hmapped : LazyRevealProbe.RawResult.stopped false ∈ support + (DirectDetailedResult.toRawResult <$> + runDirectResolvedDetailedWithCompletionTable + (directDeferredContext state) fuel computation) := by + rw [support_map] + exact ⟨.stopped .fuelExhausted, hresult, rfl⟩ + exact (mem_support_iff_of_evalDist_eq + (evalDist_toRawResult_runDirectResolvedDetailedWithCompletionTable computation state fuel) + (.stopped false)).mp hmapped + +theorem fuelExhausted_not_mem_support_detailed_of_runRaw + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (hnotStopped : LazyRevealProbe.RawResult.stopped false ∉ support + (LazyRevealProbe.runRaw state fuel computation)) : + DirectDetailedResult.stopped .fuelExhausted ∉ support + (runDirectResolvedDetailedWithCompletionTable + (directDeferredContext state) fuel computation) := by + intro hresult + exact hnotStopped + (stopped_false_mem_support_runRaw_of_fuelExhausted_detailed computation state fuel hresult) + +theorem remaining_add_pending_card_le_of_done_runDirectResolvedDetailedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult alpha) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation)) : + result.remaining + result.context.state.pending.card ≤ + fuel + context.state.pending.card := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runDirectResolvedDetailedFromTable] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + simp + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectResolvedDetailedFromTable_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel htail + | hashOutput => + rw [runDirectResolvedDetailedFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel htail + | ensure coordinate => + rw [runDirectResolvedDetailedFromTable_ensure_query_bind] at hresult + simpa only [LazyRevealProbe.State.pending_card_ensure] using + ih () { context with state := context.state.ensure coordinate } fuel hresult + | probe coordinate candidate => + cases fuel with + | zero => simp [runDirectResolvedDetailedFromTable_probe_query_bind] at hresult + | succ remaining => + rw [runDirectResolvedDetailedFromTable_probe_query_bind] at hresult + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] at hresult + have htail := ih () context remaining hresult + omega + · simp only [hrevealed, ↓reduceIte] at hresult + have htail := ih () + { context with + state := context.state.addPending coordinate candidate } + remaining hresult + change result.remaining + result.context.state.pending.card ≤ + remaining + (context.state.addPending coordinate candidate).pending.card at htail + have hadd := context.state.pending_card_addPending_le coordinate candidate + omega + | peek coordinate => + rw [runDirectResolvedDetailedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hresult + | publish coordinate => + rw [runDirectResolvedDetailedFromTable_publish_query_bind] at hresult + exact ih () { context with state := context.state.publish coordinate } fuel hresult + | reveal coordinate => + rw [runDirectResolvedDetailedFromTable_reveal_query_bind] at hresult + cases hstate : context.state.values coordinate with + | some output => + simp only [hstate] at hresult + exact ih output context fuel hresult + | none => + simp only [hstate] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + have htail := ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel hresult + have haway := context.state.pendingAway_card_add_pendingAt_card_le + (.chainStart lay tree leafIdx chainIdx) + simp only [LazyRevealProbe.State.pending_card_materialize] at htail + omega + | position position => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hprivate, hhit] at hresult + · simp only [hprivate, hhit, ↓reduceIte] at hresult + have htail := ih output + { state := context.state.materialize (.position position) output + values := context.values } + fuel hresult + have haway := context.state.pendingAway_card_add_pendingAt_card_le + (.position position) + simp only [LazyRevealProbe.State.pending_card_materialize] at htail + omega + | none => + simp only [hprivate, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htailResult⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at htailResult + · simp only [hhit, ↓reduceIte] at htailResult + have htail := ih output + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel htailResult + have haway := context.state.pendingAway_card_add_pendingAt_card_le + (.position position) + simp only [LazyRevealProbe.State.pending_card_materialize] at htail + omega + +theorem pending_card_lt_digest_card_of_remaining_add_le + (context : DeferredContext) (fuel q : Nat) + (hbudget : fuel + context.state.pending.card ≤ q) + (hq : q ≤ 2 ^ securityBits) : + context.state.pending.card < Fintype.card Digest := by + have hpending : context.state.pending.card ≤ q := by omega + have hspace : 2 ^ securityBits < Fintype.card Digest := by + norm_num [securityBits, digestBits] + exact hpending.trans_lt (hq.trans_lt hspace) + +noncomputable def directDetailedSafeOrdinaryTerminalObserve + (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (fuel : Nat) (value : alpha) : ProbComp Bool := + classifyDirectDetailedOrdinaryObserve table (fun _ _ _ => pure false) + context fuel value + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_sampled_directDetailedSafeOrdinaryTerminalObserve_le + (context : DeferredContext) (fuel : Nat) (value : alpha) + (hvalid : context.Valid) + (hcard : context.state.pending.card < Fintype.card Digest) : + Pr[= true | do + let base ← sampleOtsHashTable + directDetailedSafeOrdinaryTerminalObserve + (completedStartTable context.state base) context fuel value] ≤ + ((fuel + context.state.pending.card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + classical + by_cases hprivate : PrivateStructuralHit context + · simp [directDetailedSafeOrdinaryTerminalObserve, + classifyDirectDetailedOrdinaryObserve, hprivate] + · calc + _ ≤ Pr[fun base : OtsSecretIndex → HashOutput => + MissingChainStartHit (completedStartTable context.state base) context | + sampleOtsHashTable] := by + calc + _ ≤ Pr[= true | sampleOtsHashTable >>= fun base => + pure (decide (MissingChainStartHit + (completedStartTable context.state base) context))] := by + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput] + apply probEvent_bind_mono + intro base _hbase + unfold directDetailedSafeOrdinaryTerminalObserve + by_cases hcompletable : DeferredCompletable + (completedStartTable context.state base) context + · simp [classifyDirectDetailedOrdinaryObserve, hprivate, hcompletable] + · have hmissing := + privateStructuralHit_or_missingChainStartHit_of_not_completable + (completedStartTable context.state base) context hvalid + (startTableAgrees_completedStartTable context.state base) hcard + hcompletable + have hmissing' : MissingChainStartHit + (completedStartTable context.state base) context := + hmissing.resolve_left hprivate + simp [classifyDirectDetailedOrdinaryObserve, hprivate, hcompletable, + hmissing'] + _ = _ := by + rw [show (fun base : OtsSecretIndex → HashOutput => + pure (decide (MissingChainStartHit + (completedStartTable context.state base) context))) = + pure ∘ (fun base => decide (MissingChainStartHit + (completedStartTable context.state base) context)) by rfl] + rw [← probEvent_eq_eq_probOutput, probEvent_bind_pure_comp] + apply OracleComp.probEvent_congr' + · intro base _hbase + simp + · rfl + _ ≤ (context.state.pending.card : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + probEvent_missingChainStartHit_completedStartTable_le context + _ ≤ ((fuel + context.state.pending.card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply mul_le_mul_of_nonneg_right + exact_mod_cast Nat.le_add_left context.state.pending.card fuel + positivity + +noncomputable def guardedDirectDetailedSafeOrdinaryTerminalObserve + (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (fuel : Nat) (value : alpha) : ProbComp Bool := by + classical + exact if context.Valid ∧ context.state.pending.card < Fintype.card Digest then + directDetailedSafeOrdinaryTerminalObserve table context fuel value + else + pure false + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_sampled_guardedDirectDetailedSafeOrdinaryTerminalObserve_le + (context : DeferredContext) (fuel : Nat) (value : alpha) : + Pr[= true | do + let base ← sampleOtsHashTable + guardedDirectDetailedSafeOrdinaryTerminalObserve + (completedStartTable context.state base) context fuel value] ≤ + ((fuel + context.state.pending.card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + classical + by_cases hguard : context.Valid ∧ + context.state.pending.card < Fintype.card Digest + · simp only [guardedDirectDetailedSafeOrdinaryTerminalObserve, hguard] + exact probEvent_sampled_directDetailedSafeOrdinaryTerminalObserve_le + context fuel value hguard.1 hguard.2 + · have hguard' : ¬(context.Valid ∧ + context.state.pending.card < 2 ^ digestBits) := by + simpa using hguard + simp [guardedDirectDetailedSafeOrdinaryTerminalObserve, hguard'] + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_runDirectDetailedSafeOrdinaryGuardedTerminal_le + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (context : DeferredContext) (fuel : Nat) : + Pr[= true | + runDirectDetailedSafeOrdinaryWithCompletionTable + guardedDirectDetailedSafeOrdinaryTerminalObserve + context fuel computation] ≤ + ((fuel + context.state.pending.card : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_runDirectDetailedSafeOrdinaryWithCompletionTable_le + intro nextContext remaining value + rw [probEvent_eq_eq_probOutput] + exact probEvent_sampled_guardedDirectDetailedSafeOrdinaryTerminalObserve_le + nextContext remaining value + +noncomputable def flatDetailedOrdinaryRetained + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := + runDirectResolvedDetailedFromTable + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table (deferredCleanRetainedRun adversary parameter ftsSecret) >>= + finishDirectDetailedSafeOrdinaryObserve + (fun _ context _ _ => LazyRevealProbe.finalize context.state) + +noncomputable def sampledFlatDetailedOrdinaryRetained + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := do + let table ← sampleOtsHashTable + flatDetailedOrdinaryRetained adversary parameter table ftsSecret fuel + +theorem completedStartTable_empty + (table : OtsSecretIndex → HashOutput) : + completedStartTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) table = table := by + funext index + simp [completedStartTable, LazyRevealProbe.State.empty] + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem evalDist_sampledFlatDetailedOrdinaryRetained_eq_safe + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + 𝒟[sampledFlatDetailedOrdinaryRetained adversary parameter ftsSecret fuel] = + 𝒟[runDirectDetailedSafeOrdinaryWithCompletionTable + (fun _ context _ _ => LazyRevealProbe.finalize context.state) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel (deferredCleanRetainedRun adversary parameter ftsSecret)] := by + unfold sampledFlatDetailedOrdinaryRetained flatDetailedOrdinaryRetained + have hsample := evalDist_sampled_runDirectDetailedSafeOrdinary_eq_completionTable + (deferredCleanRetainedRun adversary parameter ftsSecret) + (fun _ context _ _ => LazyRevealProbe.finalize context.state) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) fuel + simpa [directDeferredContext, completedStartTable_empty] using hsample + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_sampledFlatDetailedOrdinaryRetained_le + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[= true | sampledFlatDetailedOrdinaryRetained adversary parameter ftsSecret fuel] ≤ + (fuel : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ = Pr[= true | runDirectDetailedSafeOrdinaryWithCompletionTable + (fun _ context _ _ => LazyRevealProbe.finalize context.state) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel (deferredCleanRetainedRun adversary parameter ftsSecret)] := + OracleComp.probOutput_congr rfl + (evalDist_sampledFlatDetailedOrdinaryRetained_eq_safe adversary parameter + ftsSecret fuel) + _ ≤ _ := by + exact probEvent_runDirectDetailedSafeOrdinaryFinalize_empty_le + (deferredCleanRetainedRun adversary parameter ftsSecret) fuel + +set_option maxRecDepth 100000 in +theorem deferredCleanRetainedRun_eq_boundary_bind + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + deferredCleanRetainedRun adversary parameter ftsSecret = (do + let rootResult ← maskedPublishedTreeRoot.run emptySplitHashCache + let forgeryLogResult ← + (simulateQ + (maskedExpandedAdversaryImpl parameter rootResult.1 ftsSecret) + (signingTraceComputation + (adversary.main ⟨rootResult.1, parameter⟩))).run rootResult.2 + (canonicalVerifierFinish parameter rootResult.1 forgeryLogResult.1).run + forgeryLogResult.2) := by + unfold deferredCleanRetainedRun deferredCleanRetainedRest canonicalVerifierFinish + simp only [StateT.run_bind, StateT.run_pure, bind_assoc, pure_bind] + +set_option maxRecDepth 100000 in +theorem evalDist_sampledFlatDetailedOrdinaryRetained_eq_experiment + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (hparameter : parameter ∈ support sampleParameter) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + 𝒟[sampledFlatDetailedOrdinaryRetained adversary parameter ftsSecret q] = + 𝒟[LazyRevealProbe.experiment + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) q + (deferredCleanRetainedRun adversary parameter ftsSecret)] := by + rw [evalDist_sampledFlatDetailedOrdinaryRetained_eq_safe] + exact evalDist_runDirectDetailedSafeOrdinaryFinalize_eq_experiment + (deferredCleanRetainedRun adversary parameter ftsSecret) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) q + (stopped_false_not_mem_support_deferredCleanRetainedRun adversary q hq parameter + hparameter ftsSecret hfts) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryOrdinaryAdaptive.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryOrdinaryAdaptive.lean new file mode 100644 index 00000000..030f88c4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryOrdinaryAdaptive.lean @@ -0,0 +1,4098 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryOrdinarySigner +import SphincsSecurity.Proof.QueryBound + +/-! +# Adaptive ordinary boundary refinement + +This file lifts the one-query ordinary refinement through the complete adaptive computation and its +terminal verifier. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +theorem FinalizationContextLE.canonicalize_left + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextLE table left right) : + FinalizationContextLE table (canonicalizeMaterializedValues table left) right where + view := (FinalizationViewLE.of_eq + (finalizationViewEq_canonicalize_left table left hcontext.leftValid + hcontext.view.leftStarts hcontext.view.leftClean)).trans hcontext.view + leftValid := canonicalizeMaterializedValues_valid table left hcontext.leftValid + hcontext.view.leftClean + rightValid := hcontext.rightValid + rightCompletable := hcontext.rightCompletable + +theorem valuesLE_canonicalizeMaterializedValues_left + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) : + LazyRevealProbe.ValuesLE + (canonicalizeMaterializedValues table context).state context.state := by + intro coordinate output hvalue + unfold canonicalizeMaterializedValues publicMaterializedValues at hvalue + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] at hvalue + have hknown := hpublished coordinate hrevealed + cases horiginal : context.state.values coordinate with + | none => exact False.elim (hknown horiginal) + | some original => + have hresolved : resolvedCompletionValue table context coordinate = some original := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + have heq := hstarts ⟨lay, tree, leafIdx, chainIdx⟩ original horiginal + simp [resolvedCompletionValue, heq] + | position position => + simp [resolvedCompletionValue, DeferredContext.positionValue, horiginal] + rw [hresolved] at hvalue + have heq : original = output := Option.some.inj hvalue + rwa [heq] at horiginal + · simp [hrevealed] at hvalue + +theorem OrdinaryMaterializedRunEq.canonicalize_left + {table : OtsSecretIndex → HashOutput} + {left right : ResolvedRunResult (α × SplitHashCache)} + (hrelation : OrdinaryMaterializedRunEq table left right) : + OrdinaryMaterializedRunEq table + { left with + context := canonicalizeMaterializedValues table left.context } + right where + value_eq := hrelation.value_eq + context_le := hrelation.context_le.canonicalize_left + remaining_le := hrelation.remaining_le + left_table := hrelation.left_table + right_table := hrelation.right_table + cache_eq := hrelation.cache_eq + revealed_eq := by + rw [canonicalizeMaterializedValues_revealed] + exact hrelation.revealed_eq + values_le := (valuesLE_canonicalizeMaterializedValues_left table left.context + hrelation.context_le.view.leftStarts hrelation.left_published).trans hrelation.values_le + left_published := hrelation.left_published.to_canonicalizedMaterializedValues + right_materialized := hrelation.right_materialized + +theorem PrivateStructuralHit.canonicalizeMaterializedValues + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hprivate : PrivateStructuralHit context) + (hpublished : PublishedValues context.state) : + PrivateStructuralHit (canonicalizeMaterializedValues table context) := by + rcases hprivate with ⟨position, output, hhidden, hvalue, hhit⟩ + have hnotRevealed : Coordinate.position position ∉ context.state.revealed := by + intro hrevealed + exact (hpublished (.position position) hrevealed) hhidden + refine ⟨position, output, ?_, hvalue, ?_⟩ + · change publicMaterializedValues table context (.position position) = none + simp [publicMaterializedValues, hnotRevealed] + · change truncateHash output ∈ context.state.pendingAt (.position position) + exact hhit + +theorem privateStructuralHit_canonicalizeMaterializedValues_iff + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hpublished : PublishedValues context.state) : + PrivateStructuralHit (canonicalizeMaterializedValues table context) ↔ + ∃ position output, + Coordinate.position position ∉ context.state.revealed ∧ + context.values position = some output ∧ + context.state.hitAt (.position position) output := by + constructor + · rintro ⟨position, output, hhidden, hprivate, hhit⟩ + refine ⟨position, output, ?_, hprivate, ?_⟩ + · intro hrevealed + have hknown := hpublished (.position position) hrevealed + unfold canonicalizeMaterializedValues publicMaterializedValues at hhidden + simp only [hrevealed, ↓reduceIte] at hhidden + cases hvalue : context.state.values (.position position) with + | none => exact hknown hvalue + | some value => + simp [resolvedCompletionValue, DeferredContext.positionValue, hvalue] at hhidden + · change truncateHash output ∈ context.state.pendingAt (.position position) + exact hhit + · rintro ⟨position, output, hnotRevealed, hprivate, hhit⟩ + refine ⟨position, output, ?_, hprivate, ?_⟩ + · change publicMaterializedValues table context (.position position) = none + simp [publicMaterializedValues, hnotRevealed] + · change truncateHash output ∈ context.state.pendingAt (.position position) + exact hhit + +theorem privateStructuralHit_canonicalize_directDeferredContext_iff + (table : OtsSecretIndex → HashOutput) + (state : LazyRevealProbe.State Coordinate) + (hpublished : PublishedValues state) : + PrivateStructuralHit + (canonicalizeMaterializedValues table (directDeferredContext state)) ↔ + ∃ position output, + Coordinate.position position ∉ state.revealed ∧ + state.values (.position position) = some output ∧ + state.hitAt (.position position) output := by + rw [privateStructuralHit_canonicalizeMaterializedValues_iff table + (directDeferredContext state) hpublished] + rfl + +theorem privateStructuralHit_canonicalize_presample_materialize_addPending_iff + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (position : Position) (output : HashOutput) (candidate : Digest) + (hpublished : PublishedValues context.state) + (hhidden : context.state.values (.position position) = none) + (hclean : ¬PrivateStructuralHit + (canonicalizeMaterializedValues table context)) : + let nextContext : DeferredContext := + { state := ((context.state.clearPending (.position position)).materialize + (.position position) output).addPending (.position position) candidate + values := context.values.install position output } + PrivateStructuralHit (canonicalizeMaterializedValues table nextContext) ↔ + truncateHash output = candidate := by + dsimp only + let baseState := (context.state.clearPending (.position position)).materialize + (.position position) output + let nextContext : DeferredContext := + { state := baseState.addPending (.position position) candidate + values := context.values.install position output } + have hnotRevealed : Coordinate.position position ∉ context.state.revealed := by + intro hrevealed + exact (hpublished (.position position) hrevealed) hhidden + have hbasePublished : PublishedValues baseState := by + apply PublishedValues.materialize + simpa [PublishedValues, LazyRevealProbe.State.clearPending] using hpublished + have hnextPublished : PublishedValues nextContext.state := by + simpa [nextContext, PublishedValues, LazyRevealProbe.State.addPending] using + hbasePublished + rw [privateStructuralHit_canonicalizeMaterializedValues_iff table nextContext + hnextPublished] + constructor + · rintro ⟨other, otherOutput, hotherHidden, hotherPrivate, hotherHit⟩ + by_cases heq : other = position + · subst other + have houtput : otherOutput = output := by + have hvalue : some output = some otherOutput := by + simpa [nextContext, DeferredStructuralValues.install] using hotherPrivate + exact (Option.some.inj hvalue).symm + subst otherOutput + have hbaseMiss : ¬baseState.hitAt (.position position) output := by + change ¬((context.state.clearPending (.position position)).clearPending + (.position position)).hitAt (.position position) output + exact not_hitAt_clearPending_self + (context.state.clearPending (.position position)) (.position position) output + exact (hitAt_addPending_self_iff baseState (.position position) candidate output).1 + hotherHit |>.resolve_left hbaseMiss + · exfalso + apply hclean + rw [privateStructuralHit_canonicalizeMaterializedValues_iff table context hpublished] + refine ⟨other, otherOutput, ?_, ?_, ?_⟩ + · simpa [nextContext, baseState, LazyRevealProbe.State.addPending, + LazyRevealProbe.State.materialize, LazyRevealProbe.State.clearPending] using + hotherHidden + · simpa [nextContext, DeferredStructuralValues.install, + Function.update_of_ne heq] using hotherPrivate + · have hcoordinate : Coordinate.position position ≠ .position other := by + intro hsame + exact heq (Coordinate.position.inj hsame).symm + have hbaseHit : baseState.hitAt (.position other) otherOutput := by + change (baseState.addPending (.position position) candidate).hitAt + (.position other) otherOutput at hotherHit + rw [hitAt_addPending_of_ne baseState (.position position) + (.position other) candidate otherOutput hcoordinate] at hotherHit + exact hotherHit + change ((context.state.clearPending (.position position)).clearPending + (.position position)).hitAt (.position other) otherOutput at hbaseHit + have honce := (hitAt_clearPending_of_ne + (context.state.clearPending (.position position)) (.position position) + (.position other) otherOutput hcoordinate.symm).mp hbaseHit + exact (hitAt_clearPending_of_ne context.state (.position position) + (.position other) otherOutput hcoordinate.symm).mp honce + · intro hcandidate + refine ⟨position, output, ?_, ?_, ?_⟩ + · simpa [nextContext, baseState, LazyRevealProbe.State.addPending, + LazyRevealProbe.State.materialize, LazyRevealProbe.State.clearPending] using + hnotRevealed + · simp [nextContext, DeferredStructuralValues.install] + · exact (hitAt_addPending_self_iff baseState (.position position) candidate output).2 + (Or.inr hcandidate) + +theorem probEvent_privateStructuralHit_canonicalize_presample_materialize_addPending_le + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (position : Position) (candidate : Digest) + (hpublished : PublishedValues context.state) + (hhidden : context.state.values (.position position) = none) + (hclean : ¬PrivateStructuralHit + (canonicalizeMaterializedValues table context)) : + Pr[fun output : HashOutput => + let nextContext : DeferredContext := + { state := ((context.state.clearPending (.position position)).materialize + (.position position) output).addPending (.position position) candidate + values := context.values.install position output } + PrivateStructuralHit (canonicalizeMaterializedValues table nextContext) | + LazyRevealProbe.sampleHashOutput] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ = Pr[fun output : HashOutput => truncateHash output = candidate | + LazyRevealProbe.sampleHashOutput] := by + apply OracleComp.probEvent_congr' + · intro output _houtput + exact privateStructuralHit_canonicalize_presample_materialize_addPending_iff + table context position output candidate hpublished hhidden hclean + · rfl + _ = (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + unfold LazyRevealProbe.sampleHashOutput + exact SphincsSecurity.probEvent_uniform_truncateHash_eq candidate + _ ≤ _ := by + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + +noncomputable def resolveThenMaterializedPrivateProbeOutcome + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (position : Position) (candidate : Digest) : ProbComp Bool := by + classical + exact do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure false + | some resolved => + let nextContext : DeferredContext := + { resolved.toDeferredContext with + state := (resolved.state.materialize (.position position) resolved.output).addPending + (.position position) candidate } + pure (decide (PrivateStructuralHit + (canonicalizeMaterializedValues table nextContext))) + +theorem probEvent_resolveThenMaterializedPrivateProbeOutcome_le + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (position : Position) (candidate : Digest) + (hpublished : PublishedValues context.state) + (hhidden : context.state.values (.position position) = none) + (hprivate : context.values position = none) + (hclean : ¬PrivateStructuralHit + (canonicalizeMaterializedValues table context)) : + Pr[= true | + resolveThenMaterializedPrivateProbeOutcome table context position candidate] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + classical + have hrun : resolveThenMaterializedPrivateProbeOutcome table context position candidate = (do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt (.position position) output then pure false + else + let nextContext : DeferredContext := + { state := ((context.state.clearPending (.position position)).materialize + (.position position) output).addPending (.position position) candidate + values := context.values.install position output } + pure (decide (PrivateStructuralHit + (canonicalizeMaterializedValues table nextContext)))) := by + rw [resolveThenMaterializedPrivateProbeOutcome, + resolveDeferredPositionValue_fresh position context hhidden hprivate] + simp only [bind_assoc] + apply bind_congr + intro output + by_cases holdHit : context.state.hitAt (.position position) output + · simp [holdHit] + · simp [holdHit] + rw [hrun, ← probEvent_eq_eq_probOutput] + refine (probEvent_bind_le_probEvent_add + (mx := LazyRevealProbe.sampleHashOutput) + (my := fun output => + if context.state.hitAt (.position position) output then pure false + else + let nextContext : DeferredContext := + { state := ((context.state.clearPending (.position position)).materialize + (.position position) output).addPending (.position position) candidate + values := context.values.install position output } + pure (decide (PrivateStructuralHit + (canonicalizeMaterializedValues table nextContext)))) + (q := fun hit : Bool => hit = true) + (p := fun output : HashOutput => + let nextContext : DeferredContext := + { state := ((context.state.clearPending (.position position)).materialize + (.position position) output).addPending (.position position) candidate + values := context.values.install position output } + PrivateStructuralHit (canonicalizeMaterializedValues table nextContext)) + (ε := 0) ?_).trans ?_ + · intro output _houtput hmiss + by_cases holdHit : context.state.hitAt (.position position) output + · simp [holdHit] + · simp [holdHit, hmiss] + · simpa only [add_zero] using + probEvent_privateStructuralHit_canonicalize_presample_materialize_addPending_le + table context position candidate hpublished hhidden hclean + +noncomputable def classifyCanonicalMaterializedPrivateObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) : ProbComp Bool := by + classical + exact if PrivateStructuralHit (canonicalizeMaterializedValues table context) then + pure true + else if DeferredCompletable table context then + observe context fuel value + else + pure false + +noncomputable def classifyCanonicalMaterializedOrdinaryObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) : ProbComp Bool := by + classical + exact if PrivateStructuralHit (canonicalizeMaterializedValues table context) then + pure false + else if DeferredCompletable table context then + observe context fuel value + else + pure true + +noncomputable def classifyCanonicalMaterializedFailedObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) : ProbComp Bool := by + classical + exact if PrivateStructuralHit (canonicalizeMaterializedValues table context) then + pure true + else if DeferredCompletable table context then + observe context fuel value + else + pure true + +noncomputable def classifyCanonicalMaterializedObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → alpha → ProbComp DirectBoundaryOutcome) + (context : DeferredContext) (fuel : Nat) (value : alpha) : + ProbComp DirectBoundaryOutcome := by + classical + exact if PrivateStructuralHit (canonicalizeMaterializedValues table context) then + pure .privateStructuralFailure + else if DeferredCompletable table context then + observe context fuel value + else + pure .ordinaryFailure + +theorem evalDist_private_classifyCanonicalMaterializedObserve + (table : OtsSecretIndex → HashOutput) + (detailedObserve : DeferredContext → Nat → alpha → + ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) + (hproject : evalDist (DirectBoundaryOutcome.privateStructural <$> + detailedObserve context fuel value) = + evalDist (observe context fuel value)) : + evalDist (DirectBoundaryOutcome.privateStructural <$> + classifyCanonicalMaterializedObserve table detailedObserve context fuel value) = + evalDist + (classifyCanonicalMaterializedPrivateObserve table observe context fuel value) := by + unfold classifyCanonicalMaterializedObserve + classifyCanonicalMaterializedPrivateObserve + by_cases hprivate : PrivateStructuralHit + (canonicalizeMaterializedValues table context) + · simp [hprivate, DirectBoundaryOutcome.privateStructural] + · simp only [hprivate, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table context + · simpa [hcompletable] using hproject + · simp [hcompletable, DirectBoundaryOutcome.privateStructural] + +theorem evalDist_ordinary_classifyCanonicalMaterializedObserve + (table : OtsSecretIndex → HashOutput) + (detailedObserve : DeferredContext → Nat → alpha → + ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) + (hproject : evalDist (DirectBoundaryOutcome.ordinary <$> + detailedObserve context fuel value) = + evalDist (observe context fuel value)) : + evalDist (DirectBoundaryOutcome.ordinary <$> + classifyCanonicalMaterializedObserve table detailedObserve context fuel value) = + evalDist + (classifyCanonicalMaterializedOrdinaryObserve table observe context fuel value) := by + unfold classifyCanonicalMaterializedObserve + classifyCanonicalMaterializedOrdinaryObserve + by_cases hprivate : PrivateStructuralHit + (canonicalizeMaterializedValues table context) + · simp [hprivate, DirectBoundaryOutcome.ordinary] + · simp only [hprivate, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table context + · simpa [hcompletable] using hproject + · simp [hcompletable, DirectBoundaryOutcome.ordinary] + +theorem evalDist_failed_classifyCanonicalMaterializedObserve + (table : OtsSecretIndex → HashOutput) + (detailedObserve : DeferredContext → Nat → alpha → + ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) + (hproject : evalDist (DirectBoundaryOutcome.failed <$> + detailedObserve context fuel value) = + evalDist (observe context fuel value)) : + evalDist (DirectBoundaryOutcome.failed <$> + classifyCanonicalMaterializedObserve table detailedObserve context fuel value) = + evalDist + (classifyCanonicalMaterializedFailedObserve table observe context fuel value) := by + unfold classifyCanonicalMaterializedObserve + classifyCanonicalMaterializedFailedObserve + by_cases hprivate : PrivateStructuralHit + (canonicalizeMaterializedValues table context) + · simp [hprivate, DirectBoundaryOutcome.failed] + · simp only [hprivate, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table context + · simpa [hcompletable] using hproject + · simp [hcompletable, DirectBoundaryOutcome.failed] + +theorem probEvent_resolve_then_classifyCanonicalMaterializedPrivateObserve_le + (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (position : Position) (candidate : Digest) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (fuel : Nat) (value : alpha) (bound : ℝ≥0∞) + (hpublished : PublishedValues context.state) + (hhidden : context.state.values (.position position) = none) + (hprivate : context.values position = none) + (hclean : ¬PrivateStructuralHit + (canonicalizeMaterializedValues table context)) + (hobserve : ∀ resolved : DeferredResolution, + let nextContext : DeferredContext := + { resolved.toDeferredContext with + state := (resolved.state.materialize (.position position) resolved.output).addPending + (.position position) candidate } + ¬PrivateStructuralHit (canonicalizeMaterializedValues table nextContext) → + DeferredCompletable table nextContext → + Pr[= true | observe nextContext fuel value] ≤ bound) : + Pr[= true | do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure false + | some resolved => + let nextContext : DeferredContext := + { resolved.toDeferredContext with + state := (resolved.state.materialize (.position position) resolved.output).addPending + (.position position) candidate } + classifyCanonicalMaterializedPrivateObserve table observe nextContext fuel value] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + bound := by + classical + let nextContext : DeferredResolution → DeferredContext := fun resolved => + { resolved.toDeferredContext with + state := (resolved.state.materialize (.position position) resolved.output).addPending + (.position position) candidate } + let fires : Option DeferredResolution → Prop + | none => False + | some resolved => + PrivateStructuralHit (canonicalizeMaterializedValues table (nextContext resolved)) + let continuation : Option DeferredResolution → ProbComp Bool + | none => pure false + | some resolved => + classifyCanonicalMaterializedPrivateObserve table observe + (nextContext resolved) fuel value + rw [← probEvent_eq_eq_probOutput] + refine (probEvent_bind_le_probEvent_add + (mx := resolveDeferredPositionValue position context) + (my := continuation) + (q := fun hit : Bool => hit = true) + (p := fires) + (ε := bound) ?_).trans ?_ + · intro resolved _hresolved hmiss + cases resolved with + | none => simp [continuation] + | some resolved => + have hnotPrivate : + ¬PrivateStructuralHit + (canonicalizeMaterializedValues table (nextContext resolved)) := by + simpa [fires] using hmiss + unfold continuation classifyCanonicalMaterializedPrivateObserve + simp only [hnotPrivate, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table (nextContext resolved) + · simpa [hcompletable] using hobserve resolved hnotPrivate hcompletable + · simp [hcompletable] + · have hsource : + Pr[fires | resolveDeferredPositionValue position context] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + have houtcome : + resolveThenMaterializedPrivateProbeOutcome table context position candidate = + (fun resolved => decide (fires resolved)) <$> + resolveDeferredPositionValue position context := by + unfold resolveThenMaterializedPrivateProbeOutcome + simp only [map_eq_bind_pure_comp] + apply bind_congr + intro resolved + cases resolved <;> simp [fires, nextContext] + exact calc + Pr[fires | resolveDeferredPositionValue position context] = + Pr[= true | + resolveThenMaterializedPrivateProbeOutcome table context position candidate] := by + rw [houtcome, ← probEvent_eq_eq_probOutput, probEvent_map] + exact OracleComp.probEvent_congr' (fun resolved _ => by simp) rfl + _ ≤ _ := probEvent_resolveThenMaterializedPrivateProbeOutcome_le + table context position candidate hpublished hhidden hprivate hclean + simpa [add_comm] using add_le_add_right hsource bound + +noncomputable def directDetailedBoundaryCanonicalMaterializedPrivateObserve + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec alpha) + (observe : DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp Bool := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp spec alpha => + (DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) → + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp Bool) + (fun value observe context fuel _table cache => observe context fuel (value, cache)) + (fun query _next recursivelyRun observe context fuel table cache => + runDirectDetailedPrivateObserve + (classifyCanonicalMaterializedPrivateObserve table + (fun nextContext remaining value => + recursivelyRun value.1 observe nextContext remaining table value.2)) + context fuel table ((impl query).run cache)) + computation observe context fuel table cache + +noncomputable def directDetailedBoundaryCanonicalMaterializedOrdinaryObserve + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec alpha) + (observe : DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp Bool := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp spec alpha => + (DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) → + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp Bool) + (fun value observe context fuel _table cache => observe context fuel (value, cache)) + (fun query _next recursivelyRun observe context fuel table cache => + runDirectDetailedOrdinaryObserve + (classifyCanonicalMaterializedOrdinaryObserve table + (fun nextContext remaining value => + recursivelyRun value.1 observe nextContext remaining table value.2)) + context fuel table ((impl query).run cache)) + computation observe context fuel table cache + +noncomputable def directBoundaryCanonicalMaterializedFailedObserve + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec alpha) + (observe : DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp Bool := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp spec alpha => + (DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) → + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp Bool) + (fun value observe context fuel _table cache => observe context fuel (value, cache)) + (fun query _next recursivelyRun observe context fuel table cache => + runDirectResolvedObserve + (classifyCanonicalMaterializedFailedObserve table + (fun nextContext remaining value => + recursivelyRun value.1 observe nextContext remaining table value.2)) + context fuel table ((impl query).run cache)) + computation observe context fuel table cache + +noncomputable def directDetailedBoundaryCanonicalMaterializedObserve + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec alpha) + (observe : DeferredContext → Nat → + (alpha × SplitHashCache) → ProbComp DirectBoundaryOutcome) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp DirectBoundaryOutcome := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp spec alpha => + (DeferredContext → Nat → + (alpha × SplitHashCache) → ProbComp DirectBoundaryOutcome) → + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp DirectBoundaryOutcome) + (fun value observe context fuel _table cache => observe context fuel (value, cache)) + (fun query _next recursivelyRun observe context fuel table cache => + runDirectDetailedObserve + (classifyCanonicalMaterializedObserve table + (fun nextContext remaining value => + recursivelyRun value.1 observe nextContext remaining table value.2)) + context fuel table ((impl query).run cache)) + computation observe context fuel table cache + +set_option maxRecDepth 100000 in +theorem evalDist_private_directDetailedBoundaryCanonicalMaterializedObserve + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec alpha) + (detailedObserve : DeferredContext → Nat → + (alpha × SplitHashCache) → ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) + (hobserve : ∀ context fuel value, + evalDist (DirectBoundaryOutcome.privateStructural <$> + detailedObserve context fuel value) = + evalDist (observe context fuel value)) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) : + evalDist (DirectBoundaryOutcome.privateStructural <$> + directDetailedBoundaryCanonicalMaterializedObserve impl computation detailedObserve + context fuel table cache) = + evalDist (directDetailedBoundaryCanonicalMaterializedPrivateObserve impl computation + observe context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + rw [directDetailedBoundaryCanonicalMaterializedObserve, + OracleComp.construct_pure, + directDetailedBoundaryCanonicalMaterializedPrivateObserve, + OracleComp.construct_pure] + exact hobserve context fuel (value, cache) + | query_bind query next ih => + rw [directDetailedBoundaryCanonicalMaterializedObserve, + OracleComp.construct_query_bind, + directDetailedBoundaryCanonicalMaterializedPrivateObserve, + OracleComp.construct_query_bind] + apply evalDist_private_runDirectDetailedObserve + intro result _hresult + apply evalDist_private_classifyCanonicalMaterializedObserve + exact ih result.value.1 result.context result.remaining result.value.2 + +set_option maxRecDepth 100000 in +theorem evalDist_ordinary_directDetailedBoundaryCanonicalMaterializedObserve + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec alpha) + (detailedObserve : DeferredContext → Nat → + (alpha × SplitHashCache) → ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) + (hobserve : ∀ context fuel value, + evalDist (DirectBoundaryOutcome.ordinary <$> + detailedObserve context fuel value) = + evalDist (observe context fuel value)) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) : + evalDist (DirectBoundaryOutcome.ordinary <$> + directDetailedBoundaryCanonicalMaterializedObserve impl computation detailedObserve + context fuel table cache) = + evalDist (directDetailedBoundaryCanonicalMaterializedOrdinaryObserve impl computation + observe context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + rw [directDetailedBoundaryCanonicalMaterializedObserve, + OracleComp.construct_pure, + directDetailedBoundaryCanonicalMaterializedOrdinaryObserve, + OracleComp.construct_pure] + exact hobserve context fuel (value, cache) + | query_bind query next ih => + rw [directDetailedBoundaryCanonicalMaterializedObserve, + OracleComp.construct_query_bind, + directDetailedBoundaryCanonicalMaterializedOrdinaryObserve, + OracleComp.construct_query_bind] + apply evalDist_ordinary_runDirectDetailedObserve + intro result _hresult + apply evalDist_ordinary_classifyCanonicalMaterializedObserve + exact ih result.value.1 result.context result.remaining result.value.2 + +set_option maxRecDepth 100000 in +theorem evalDist_failed_directDetailedBoundaryCanonicalMaterializedObserve + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec alpha) + (detailedObserve : DeferredContext → Nat → + (alpha × SplitHashCache) → ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) + (hobserve : ∀ context fuel value, + evalDist (DirectBoundaryOutcome.failed <$> + detailedObserve context fuel value) = + evalDist (observe context fuel value)) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) : + evalDist (DirectBoundaryOutcome.failed <$> + directDetailedBoundaryCanonicalMaterializedObserve impl computation detailedObserve + context fuel table cache) = + evalDist (directBoundaryCanonicalMaterializedFailedObserve impl computation + observe context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + rw [directDetailedBoundaryCanonicalMaterializedObserve, + OracleComp.construct_pure, + directBoundaryCanonicalMaterializedFailedObserve, + OracleComp.construct_pure] + exact hobserve context fuel (value, cache) + | query_bind query next ih => + rw [directDetailedBoundaryCanonicalMaterializedObserve, + OracleComp.construct_query_bind, + directBoundaryCanonicalMaterializedFailedObserve, + OracleComp.construct_query_bind] + apply evalDist_failed_runDirectDetailedObserve + intro result _hresult + apply evalDist_failed_classifyCanonicalMaterializedObserve + exact ih result.value.1 result.context result.remaining result.value.2 + +set_option maxRecDepth 100000 in +theorem directDetailedBoundaryCanonicalMaterializedPrivateObserve_bind + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (left : OracleComp spec alpha) (next : alpha → OracleComp spec beta) + (observe : DeferredContext → Nat → (beta × SplitHashCache) → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + directDetailedBoundaryCanonicalMaterializedPrivateObserve impl (left >>= next) + observe context fuel table cache = + directDetailedBoundaryCanonicalMaterializedPrivateObserve impl left + (fun nextContext remaining value => + directDetailedBoundaryCanonicalMaterializedPrivateObserve impl (next value.1) + observe nextContext remaining table value.2) + context fuel table cache := by + induction left using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + simp [directDetailedBoundaryCanonicalMaterializedPrivateObserve] + | query_bind query continuation ih => + rw [bind_assoc, directDetailedBoundaryCanonicalMaterializedPrivateObserve, + OracleComp.construct_query_bind, + directDetailedBoundaryCanonicalMaterializedPrivateObserve, + OracleComp.construct_query_bind] + apply bind_congr + intro result + cases result with + | stopped reason => cases reason <;> rfl + | done result => + simp only [finishDirectDetailedPrivateObserve] + unfold classifyCanonicalMaterializedPrivateObserve + by_cases hprivate : PrivateStructuralHit + (canonicalizeMaterializedValues table result.context) + · simp [hprivate] + · simp only [hprivate, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table result.context + · simp only [hcompletable, ↓reduceIte] + exact ih result.value.1 result.context result.remaining result.value.2 + · simp [hcompletable] + +set_option maxRecDepth 100000 in +theorem probEvent_directDetailedBoundaryCanonicalMaterializedPrivateObserve_le + {iota : Type} {spec : OracleSpec iota} + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (isCharged : iota → Prop) [DecidablePred isCharged] + (computation : OracleComp spec alpha) + (observe : DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (epsilon terminalBound : ℝ≥0∞) + (hstep : ∀ query nextContext remaining nextCache nextObserve, + ¬PrivateStructuralHit + (canonicalizeMaterializedValues table nextContext) → + DeferredCompletable table nextContext → + (∀ result : ResolvedRunResult (spec.Range query × SplitHashCache), + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable nextContext remaining table + ((impl query).run nextCache)) → + ¬PrivateStructuralHit + (canonicalizeMaterializedValues table result.context) → + DeferredCompletable table result.context → + Pr[= true | nextObserve result.context result.remaining result.value] ≤ + (result.remaining : ℝ≥0∞) * epsilon + terminalBound) → + Pr[= true | + runDirectDetailedPrivateObserve + (classifyCanonicalMaterializedPrivateObserve table nextObserve) + nextContext remaining table ((impl query).run nextCache)] ≤ + (remaining : ℝ≥0∞) * epsilon + terminalBound) + (hremaining : ∀ query nextContext remaining nextCache result, + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable nextContext remaining table + ((impl query).run nextCache)) → + remaining ≤ result.remaining + if isCharged query then 1 else 0) + (hterminal : ∀ nextContext remaining value nextCache, + ¬PrivateStructuralHit + (canonicalizeMaterializedValues table nextContext) → + DeferredCompletable table nextContext → + Pr[= true | observe nextContext remaining (value, nextCache)] ≤ terminalBound) + (hbound : computation.IsQueryBoundP isCharged fuel) + (hclean : ¬PrivateStructuralHit + (canonicalizeMaterializedValues table context)) + (hcompletable : DeferredCompletable table context) : + Pr[= true | + directDetailedBoundaryCanonicalMaterializedPrivateObserve impl computation observe + context fuel table cache] ≤ + (fuel : ℝ≥0∞) * epsilon + terminalBound := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + simp only [directDetailedBoundaryCanonicalMaterializedPrivateObserve, + OracleComp.construct_pure] + exact (hterminal context fuel value cache hclean hcompletable).trans + (le_add_left le_rfl) + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [directDetailedBoundaryCanonicalMaterializedPrivateObserve, + OracleComp.construct_query_bind] + apply hstep query context fuel cache + · exact hclean + · exact hcompletable + · intro result hresult hnextClean hnextCompletable + apply ih result.value.1 result.context result.remaining result.value.2 + · apply (hbound.2 result.value.1).mono + have hfuel := hremaining query context fuel cache result hresult + by_cases hcharged : isCharged query + · simp only [hcharged, ↓reduceIte] at hfuel + have hpositive : 0 < fuel := by + rcases hbound.1 with hnotCharged | hpositive + · exact (hnotCharged hcharged).elim + · exact hpositive + simpa [hcharged] using (show fuel - 1 ≤ result.remaining by omega) + · simp only [hcharged, ↓reduceIte, add_zero] at hfuel + simpa [hcharged] using hfuel + · exact hnextClean + · exact hnextCompletable + +theorem remaining_le_of_done_maskedExpandedAdversaryImpl + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) + (result : ResolvedRunResult + ((OracleWorld + SigningSpec).Range query × SplitHashCache)) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run cache))) : + fuel ≤ result.remaining + if IsOuterHash query then 1 else 0 := by + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run cache) + context fuel table result hresult + have hraw := raw_done_of_mem_runDirectResolvedFromTable + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run cache) + context fuel table result hdirect + exact LazyRevealProbe.fuel_le_remaining_add_of_mem_support_runRaw_done + context.state result.context.state fuel result.remaining + (if IsOuterHash query then 1 else 0) + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run cache) + result.value + (maskedExpandedAdversaryImpl_step_isProbeBound parameter root ftsSecret query cache) + hraw + +set_option maxRecDepth 100000 in +theorem probEvent_materializedPrivateStep_uniform_le + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (n : Nat) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (nextObserve : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → ProbComp Bool) + (epsilon terminalBound : ℝ≥0∞) + (hclean : ¬PrivateStructuralHit + (canonicalizeMaterializedValues table context)) + (hcompletable : DeferredCompletable table context) + (hcontinuation : ∀ result : ResolvedRunResult + (Fin (n + 1) × SplitHashCache), + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((maskedExpandedAdversaryImpl parameter root ftsSecret + (.inl (.inl n))).run cache)) → + ¬PrivateStructuralHit + (canonicalizeMaterializedValues table result.context) → + DeferredCompletable table result.context → + Pr[= true | nextObserve result.context result.remaining result.value] ≤ + (result.remaining : ℝ≥0∞) * epsilon + terminalBound) : + Pr[= true | + runDirectDetailedPrivateObserve + (classifyCanonicalMaterializedPrivateObserve table nextObserve) + context fuel table + ((maskedExpandedAdversaryImpl parameter root ftsSecret + (.inl (.inl n))).run cache)] ≤ + (fuel : ℝ≥0∞) * epsilon + terminalBound := by + change Pr[= true | + runDirectDetailedPrivateObserve + (classifyCanonicalMaterializedPrivateObserve table nextObserve) + context fuel table ((splitUniformImpl n).run cache)] ≤ + (fuel : ℝ≥0∞) * epsilon + terminalBound + unfold splitUniformImpl + rw [StateT.run_liftM, LazyRevealProbe.uniformQuery] + unfold runDirectDetailedPrivateObserve + rw [runDirectResolvedDetailedFromTable_uniform_query_bind] + simp only [runDirectResolvedDetailedFromTable_pure, bind_assoc, pure_bind, + finishDirectDetailedPrivateObserve, classifyCanonicalMaterializedPrivateObserve, + hclean, hcompletable, ↓reduceIte] + rw [← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_of_forall_le + intro output houtput + have hmem : DirectDetailedResult.done + (⟨context, fuel, (output, cache), table⟩ : + ResolvedRunResult (Fin (n + 1) × SplitHashCache)) ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((maskedExpandedAdversaryImpl parameter root ftsSecret + (.inl (.inl n))).run cache)) := by + unfold maskedExpandedAdversaryImpl probingRomImpl + change DirectDetailedResult.done ⟨context, fuel, (output, cache), table⟩ ∈ support + (runDirectResolvedDetailedFromTable context fuel table ((splitUniformImpl n).run cache)) + unfold splitUniformImpl + rw [StateT.run_liftM, LazyRevealProbe.uniformQuery, + runDirectResolvedDetailedFromTable_uniform_query_bind, mem_support_bind_iff] + exact ⟨output, houtput, by simp [runDirectResolvedDetailedFromTable_pure]⟩ + simpa using hcontinuation ⟨context, fuel, (output, cache), table⟩ hmem hclean hcompletable + +set_option maxRecDepth 100000 in +theorem probEvent_directDetailedBoundaryCanonicalMaterializedPrivateObserve_maskedExpanded_le + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (observe : DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (epsilon terminalBound : ℝ≥0∞) + (hstep : ∀ query nextContext remaining nextCache nextObserve, + ¬PrivateStructuralHit + (canonicalizeMaterializedValues table nextContext) → + DeferredCompletable table nextContext → + (∀ result : ResolvedRunResult + ((OracleWorld + SigningSpec).Range query × SplitHashCache), + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable nextContext remaining table + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run nextCache)) → + ¬PrivateStructuralHit + (canonicalizeMaterializedValues table result.context) → + DeferredCompletable table result.context → + Pr[= true | nextObserve result.context result.remaining result.value] ≤ + (result.remaining : ℝ≥0∞) * epsilon + terminalBound) → + Pr[= true | + runDirectDetailedPrivateObserve + (classifyCanonicalMaterializedPrivateObserve table nextObserve) + nextContext remaining table + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run nextCache)] ≤ + (remaining : ℝ≥0∞) * epsilon + terminalBound) + (hterminal : ∀ nextContext remaining value nextCache, + ¬PrivateStructuralHit + (canonicalizeMaterializedValues table nextContext) → + DeferredCompletable table nextContext → + Pr[= true | observe nextContext remaining (value, nextCache)] ≤ terminalBound) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + computation).IsQueryBoundP (· matches Sum.inr _) fuel) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hclean : ¬PrivateStructuralHit + (canonicalizeMaterializedValues table context)) + (hcompletable : DeferredCompletable table context) : + Pr[= true | + directDetailedBoundaryCanonicalMaterializedPrivateObserve + (maskedExpandedAdversaryImpl parameter root ftsSecret) computation observe + context fuel table cache] ≤ + (fuel : ℝ≥0∞) * epsilon + terminalBound := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + simp only [directDetailedBoundaryCanonicalMaterializedPrivateObserve, + OracleComp.construct_pure] + exact (hterminal context fuel value cache hclean hcompletable).trans + (le_add_left le_rfl) + | query_bind query next ih => + rw [directDetailedBoundaryCanonicalMaterializedPrivateObserve, + OracleComp.construct_query_bind] + apply hstep query context fuel cache + · exact hclean + · exact hcompletable + · rintro ⟨resultContext, resultRemaining, ⟨output, finalCache⟩, resultTable⟩ + hresult hnextClean hnextCompletable + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run cache) + context fuel table + ⟨resultContext, resultRemaining, (output, finalCache), resultTable⟩ hresult + have hraw := raw_done_of_mem_runDirectResolvedFromTable + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run cache) + context fuel table + ⟨resultContext, resultRemaining, (output, finalCache), resultTable⟩ hdirect + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run cache) + context fuel table + ⟨resultContext, resultRemaining, (output, finalCache), resultTable⟩ + hconsistent hstarts hdirect + have hremaining := remaining_le_of_done_maskedExpandedAdversaryImpl + parameter root ftsSecret query context fuel table cache + ⟨resultContext, resultRemaining, (output, finalCache), resultTable⟩ hresult + have htailBound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (next output)).IsQueryBoundP + (· matches Sum.inr _) resultRemaining := by + cases query with + | inl worldQuery => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases worldQuery with + | inl n => + exact (hbound.2 output).mono (by + simpa [IsOuterHash] using hremaining) + | inr input => + have htail : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, + tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (next output)).IsQueryBoundP + (· matches Sum.inr _) (fuel - 1) := by + simpa [IsOuterHash] using hbound.2 output + apply htail.mono + change fuel ≤ resultRemaining + 1 at hremaining + omega + | inr message => + rw [simulateQ_expandedAdversaryImpl_query_bind_inr] at hbound + change Option Signature at output + change LazyRevealProbe.RawResult.done resultContext.state resultRemaining + (output, finalCache) ∈ support + (LazyRevealProbe.runRaw context.state fuel + ((maskedSigningImpl parameter root ftsSecret message).run cache)) at hraw + have houtput : output ∈ support + (scheme.sign + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey) message) := by + exact maskedSign_done_output_mem_support parameter root table ftsSecret + message context.state resultContext.state cache finalCache + fuel resultRemaining output hcore.2.2 (by + simpa only [SigningSpec, maskedExpandedAdversaryImpl, + maskedSigningImpl] using hraw) + exact (isQueryBoundP_of_bind hbound output houtput).mono (by + simpa [IsOuterHash] using hremaining) + apply ih output resultContext resultRemaining finalCache + · exact htailBound + · exact hcore.2.1 + · exact hcore.2.2 + · exact hnextClean + · exact hnextCompletable + +theorem publishedValues_of_done_runDirectResolvedDetailedFromTable + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hpreserves : PreservesPublishedValues computation) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) + (hpublished : PublishedValues context.state) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table (computation.run cache))) : + PublishedValues result.context.state := by + apply hpreserves context.state cache fuel result.context.state result.remaining + result.value.1 result.value.2 hpublished + apply raw_done_of_mem_runDirectResolvedFromTable + (computation.run cache) context fuel table result + exact mem_support_runDirectResolvedFromTable_of_done_detailed + (computation.run cache) context fuel table result hresult + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_probingRomImpl + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (query : OracleWorld.Domain) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hpositive : 0 < leftFuel) (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + (((probingRomImpl parameter) query).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + (((probingRomImpl parameter) query).run rightCache)) + (DirectDetailedOrdinaryRunEq table) := by + cases query with + | inl n => + change RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((splitUniformImpl n).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((splitUniformImpl n).run rightCache)) + (DirectDetailedOrdinaryRunEq table) + unfold splitUniformImpl + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.uniformQuery, + runDirectResolvedDetailedFromTable_uniform_query_bind, + runDirectResolvedDetailedFromTable_uniform_query_bind] + apply relTriple_bind (relTriple_refl + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))) + intro leftOutput rightOutput houtput + subst rightOutput + exact relTriple_runDirectResolvedDetailed_pure_of_ordinaryMaterialized table leftOutput + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + | inr input => + exact relTriple_runDirectResolvedDetailed_probingHashQuery parameter table input + left right leftFuel rightFuel leftCache rightCache hcontext hpositive hfuel hcache + hrevealed hvalues hpublished hrightMaterialized + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_maskedExpandedAdversaryImpl + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hpositive : IsOuterHash query → 0 < leftFuel) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run rightCache)) + (DirectDetailedOrdinaryRunEq table) := by + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + apply relTriple_stable_to_ordinary + simpa [maskedExpandedAdversaryImpl, probingRomImpl] using + ordinaryMaterializedStableCouples_splitUniformImpl table n left right leftFuel + rightFuel leftCache rightCache hcontext hfuel hcache hrevealed hvalues hpublished + hrightMaterialized + | inr input => + simpa [maskedExpandedAdversaryImpl] using + relTriple_runDirectResolvedDetailed_probingRomImpl parameter table (.inr input) + left right leftFuel rightFuel leftCache rightCache hcontext + (hpositive (by simp [IsOuterHash])) hfuel hcache hrevealed hvalues hpublished + hrightMaterialized + | inr message => + apply relTriple_stable_to_ordinary + simpa [maskedExpandedAdversaryImpl, maskedSigningImpl] using + ordinaryMaterializedStableCouples_maskedSigningImpl table parameter root ftsSecret + message left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache + hrevealed hvalues hpublished hrightMaterialized + +set_option maxRecDepth 100000 in +theorem isQueryBoundP_expandedSigningTrace_all_tables_roots + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (root : Digest) : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (signingTraceComputation + (adversary.main ⟨root, parameter⟩))).IsQueryBoundP + (· matches Sum.inr _) q := by + have hfull := isQueryBoundP_expandedRetained_all_tables_roots adversary q hq parameter + hparameter table ftsSecret hfts root + unfold retainedGameRestComputation at hfull + rw [simulateQ_bind] at hfull + exact IsQueryBoundP.of_bind_left hfull + +theorem ordinaryMaterializedStableCouples_maskedPublishedTreeRoot + (table : OtsSecretIndex → HashOutput) : + OrdinaryMaterializedStableCouples table maskedPublishedTreeRoot := by + unfold maskedPublishedTreeRoot + apply (ordinaryMaterializedStableCouples_ensureTreeNode table topLayer rootTree + (layerHeight topLayer) 0).bind + intro _ + exact ordinaryMaterializedStableCouples_revealPublishedCoordinate table + (.position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0)) + +theorem finalizationContextLE_empty + (table : OtsSecretIndex → HashOutput) : + FinalizationContextLE table + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) := by + have hright : directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) = + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } := by + rfl + rw [hright] + refine + { view := FinalizationViewLE.refl table _ DeferredContext.valid_empty + (startTableAgrees_empty table) ?_ + leftValid := DeferredContext.valid_empty + rightValid := DeferredContext.valid_empty + rightCompletable := deferredCompletable_empty table } + intro coordinate output _hvalue + simp [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, + LazyRevealProbe.State.empty] + +def BoolImp (left right : Bool) : Prop := left = true → right = true + +theorem relTriple_any_true_of_evalDist_eq_true + (left right : ProbComp Bool) + (hright : evalDist right = evalDist (pure true : ProbComp Bool)) : + RelTriple left right BoolImp := by + have hbase := relTriple_true left (pure true : ProbComp Bool) + have hsupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + have himp : RelTriple left (pure true : ProbComp Bool) BoolImp := by + apply relTriple_post_mono hsupport + intro leftValue rightValue hrelation _hleft + simpa using hrelation.2 + exact relTriple_of_evalDist_eq_right hright.symm himp + +theorem relTriple_false_any (right : ProbComp Bool) : + RelTriple (pure false : ProbComp Bool) right BoolImp := by + have hbase := relTriple_true (pure false : ProbComp Bool) right + have hsupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun value => value ∈ support (pure false : ProbComp Bool)) + (fun value hvalue => hvalue) + apply relTriple_post_mono hsupport + intro leftValue rightValue hrelation hleft + have hfalse : leftValue = false := by + simpa using hrelation.2 + rw [hfalse] at hleft + contradiction + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectDetailedOrdinaryObserve_runDirectResolvedObserve + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (leftObserve rightObserve : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hobserve : ∀ result, + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) → + RelTriple + (leftObserve result.context result.remaining result.value) + (rightObserve result.context result.remaining result.value) + BoolImp) : + RelTriple + (runDirectDetailedOrdinaryObserve leftObserve context fuel table computation) + (runDirectResolvedObserve rightObserve context fuel table computation) + BoolImp := by + unfold runDirectDetailedOrdinaryObserve runDirectResolvedObserve + rw [← map_toOption_runDirectResolvedDetailedFromTable computation context fuel table, + map_eq_bind_pure_comp, bind_assoc] + let run := runDirectResolvedDetailedFromTable context fuel table computation + have hrun := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + (relTriple_refl run) (fun result => result ∈ support run) (fun result hresult => hresult) + apply relTriple_bind hrun + intro leftResult rightResult hrelation + rcases hrelation with ⟨heq, hleftMem⟩ + subst rightResult + cases leftResult with + | stopped reason => + cases reason with + | privateStructuralHit => exact relTriple_false_any (pure true) + | ordinaryHit => exact relTriple_pure_pure (by intro _; rfl) + | fuelExhausted => exact relTriple_pure_pure (by intro _; rfl) + | done result => + simpa [finishDirectDetailedOrdinaryObserve, finishObserve, + DirectDetailedResult.toOption] using hobserve result hleftMem + +set_option maxRecDepth 100000 in +theorem relTriple_map_isNone_finalizeResolvedCoordinates_of_finalizationViewLE + (table : OtsSecretIndex → HashOutput) (coordinates : List Coordinate) + (left right : DeferredContext) (hview : FinalizationViewLE table left right) : + RelTriple + (Option.isNone <$> finalizeResolvedCoordinates coordinates left table) + (Option.isNone <$> finalizeResolvedCoordinates coordinates right table) + BoolImp := by + induction coordinates generalizing left right with + | nil => + simp [finalizeResolvedCoordinates, BoolImp] + | cons coordinate remaining ih => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + have hleftClean : ¬left.state.hitAt index.coordinate (table index) := + hview.leftClean index.coordinate (table index) (by + simp [index, resolvedCompletionValue, OtsSecretIndex.coordinate]) + have hrightClean : ¬right.state.hitAt index.coordinate (table index) := + hview.rightClean index.coordinate (table index) (by + simp [index, resolvedCompletionValue, OtsSecretIndex.coordinate]) + change RelTriple + (Option.isNone <$> + finalizeResolvedCoordinates (index.coordinate :: remaining) left table) + (Option.isNone <$> + finalizeResolvedCoordinates (index.coordinate :: remaining) right table) + BoolImp + rw [finalizeResolvedCoordinates_cons_chainStart_of_clean table index remaining left + hview.leftStarts hleftClean, + finalizeResolvedCoordinates_cons_chainStart_of_clean table index remaining right + hview.rightStarts hrightClean] + exact ih (left.completeResolved index.coordinate (table index)) + (right.completeResolved index.coordinate (table index)) + (hview.completeStart index) + | position position => + cases hvalue : resolvedCompletionValue table left (.position position) with + | some output => + have hrightValue : + resolvedCompletionValue table right (.position position) = some output := by + rw [← hview.valueEq] + exact hvalue + have hleftClean := hview.leftClean (.position position) output hvalue + have hrightClean := hview.rightClean (.position position) output hrightValue + rw [finalizeResolvedCoordinates_cons_position_of_known_clean table position + remaining left hview.leftConsistent output + (by simpa [resolvedCompletionValue] using hvalue) hleftClean, + finalizeResolvedCoordinates_cons_position_of_known_clean table position + remaining right hview.rightConsistent output + (by simpa [resolvedCompletionValue] using hrightValue) hrightClean] + exact ih (left.completeResolved (.position position) output) + (right.completeResolved (.position position) output) + (hview.completePosition position output) + | none => + have hrightValue : + resolvedCompletionValue table right (.position position) = none := by + rw [← hview.valueEq] + exact hvalue + rw [finalizeResolvedCoordinates_cons_position_of_unknown table position remaining + left (by simpa [resolvedCompletionValue] using hvalue), + finalizeResolvedCoordinates_cons_position_of_unknown table position remaining + right (by simpa [resolvedCompletionValue] using hrightValue)] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + by_cases hleftHit : left.state.hitAt (.position position) leftOutput + · have hrightHit : right.state.hitAt (.position position) leftOutput := by + exact hview.pendingLE (.position position) hvalue hleftHit + rw [if_pos hleftHit, if_pos hrightHit] + exact relTriple_pure_pure (fun h => h) + · by_cases hrightHit : right.state.hitAt (.position position) leftOutput + · rw [if_neg hleftHit, if_pos hrightHit] + exact relTriple_any_true_of_evalDist_eq_true + (Option.isNone <$> + finalizeResolvedCoordinates remaining + (left.completeResolved (.position position) leftOutput) table) + (pure true) rfl + · rw [if_neg hleftHit, if_neg hrightHit] + exact ih + (left.completeResolved (.position position) leftOutput) + (right.completeResolved (.position position) leftOutput) + (hview.completePosition position leftOutput) + +set_option maxRecDepth 100000 in +theorem relTriple_map_isNone_finalizeResolvedCoordinates_of_finalizationViewLE_covered + (table : OtsSecretIndex → HashOutput) + (leftCoordinates rightCoordinates : List Coordinate) + (left right : DeferredContext) (hview : FinalizationViewLE table left right) + (hleftNodup : leftCoordinates.Nodup) (hrightNodup : rightCoordinates.Nodup) + (hleftCovered : PendingCovered leftCoordinates left) + (hrightCovered : PendingCovered rightCoordinates right) : + RelTriple + (Option.isNone <$> finalizeResolvedCoordinates leftCoordinates left table) + (Option.isNone <$> finalizeResolvedCoordinates rightCoordinates right table) + BoolImp := by + classical + let leftBase := leftCoordinates.toFinset.toList + let rightBase := rightCoordinates.toFinset.toList + let leftExtra := (rightCoordinates.toFinset \ leftCoordinates.toFinset).toList + let rightExtra := (leftCoordinates.toFinset \ rightCoordinates.toFinset).toList + have hleftBasePerm : leftBase.Perm leftCoordinates := by + simpa [leftBase] using List.toFinset_toList hleftNodup + have hrightBasePerm : rightBase.Perm rightCoordinates := by + simpa [rightBase] using List.toFinset_toList hrightNodup + have hleftBaseCovered : PendingCovered leftBase left := by + intro entry hentry + have hmem := hleftCovered entry hentry + simpa [leftBase] using hmem + have hrightBaseCovered : PendingCovered rightBase right := by + intro entry hentry + have hmem := hrightCovered entry hentry + simpa [rightBase] using hmem + have hleftDisjoint : leftExtra.Disjoint leftBase := by + rw [List.disjoint_left] + intro coordinate hleftExtra hleftBase + simp only [leftExtra, Finset.mem_toList, Finset.mem_sdiff] at hleftExtra + simp only [leftBase, Finset.mem_toList, List.mem_toFinset] at hleftBase + exact hleftExtra.2 (by simpa using hleftBase) + have hrightDisjoint : rightExtra.Disjoint rightBase := by + rw [List.disjoint_left] + intro coordinate hrightExtra hrightBase + simp only [rightExtra, Finset.mem_toList, Finset.mem_sdiff] at hrightExtra + simp only [rightBase, Finset.mem_toList, List.mem_toFinset] at hrightBase + exact hrightExtra.2 (by simpa using hrightBase) + have hleftAugNodup : (leftExtra ++ leftBase).Nodup := + List.Nodup.append (Finset.nodup_toList _) (Finset.nodup_toList _) hleftDisjoint + have hrightAugNodup : (rightExtra ++ rightBase).Nodup := + List.Nodup.append (Finset.nodup_toList _) (Finset.nodup_toList _) hrightDisjoint + have haugPerm : (leftExtra ++ leftBase).Perm (rightExtra ++ rightBase) := by + apply List.perm_of_nodup_nodup_toFinset_eq hleftAugNodup hrightAugNodup + ext coordinate + simp only [List.toFinset_append, leftExtra, rightExtra, leftBase, rightBase, + Finset.toList_toFinset, Finset.mem_union, Finset.mem_sdiff, List.mem_toFinset] + by_cases hleft : coordinate ∈ leftCoordinates <;> + by_cases hright : coordinate ∈ rightCoordinates <;> simp [hleft, hright] + have hleftPermDist : + evalDist (Option.isNone <$> + finalizeResolvedCoordinates leftBase left table) = + evalDist (Option.isNone <$> + finalizeResolvedCoordinates leftCoordinates left table) := by + rw [evalDist_map, evalDist_map, + evalDist_finalizeResolvedCoordinates_perm hleftBasePerm left table] + have hrightPermDist : + evalDist (Option.isNone <$> + finalizeResolvedCoordinates rightBase right table) = + evalDist (Option.isNone <$> + finalizeResolvedCoordinates rightCoordinates right table) := by + rw [evalDist_map, evalDist_map, + evalDist_finalizeResolvedCoordinates_perm hrightBasePerm right table] + have hleftAug := evalDist_map_isNone_finalizeResolvedCoordinates_append_irrelevant + table leftExtra leftBase left (Finset.nodup_toList _) + (by + intro coordinate hleftExtra + simp only [leftExtra, Finset.mem_toList, Finset.mem_sdiff] at hleftExtra + simp only [leftBase, Finset.mem_toList, List.mem_toFinset] + simpa using hleftExtra.2) + hleftBaseCovered hview.leftConsistent hview.leftStarts hview.leftClean + have hrightAug := evalDist_map_isNone_finalizeResolvedCoordinates_append_irrelevant + table rightExtra rightBase right (Finset.nodup_toList _) + (by + intro coordinate hrightExtra + simp only [rightExtra, Finset.mem_toList, Finset.mem_sdiff] at hrightExtra + simp only [rightBase, Finset.mem_toList, List.mem_toFinset] + simpa using hrightExtra.2) + hrightBaseCovered hview.rightConsistent hview.rightStarts hview.rightClean + have hsameAug := + relTriple_map_isNone_finalizeResolvedCoordinates_of_finalizationViewLE table + (leftExtra ++ leftBase) left right hview + have hpermAug : + evalDist (Option.isNone <$> finalizeResolvedCoordinates + (leftExtra ++ leftBase) right table) = + evalDist (Option.isNone <$> finalizeResolvedCoordinates + (rightExtra ++ rightBase) right table) := by + rw [evalDist_map, evalDist_map, + evalDist_finalizeResolvedCoordinates_perm haugPerm right table] + have hleftToAug : + evalDist (Option.isNone <$> + finalizeResolvedCoordinates leftCoordinates left table) = + evalDist (Option.isNone <$> + finalizeResolvedCoordinates (leftExtra ++ leftBase) left table) := + hleftPermDist.symm.trans hleftAug.symm + have hrightFromAug : + evalDist (Option.isNone <$> + finalizeResolvedCoordinates (leftExtra ++ leftBase) right table) = + evalDist (Option.isNone <$> + finalizeResolvedCoordinates rightCoordinates right table) := + hpermAug.trans (hrightAug.trans hrightPermDist) + exact relTriple_of_evalDist_eq_right hrightFromAug + (relTriple_of_evalDist_eq_left hleftToAug hsameAug) + +set_option maxRecDepth 100000 in +theorem relTriple_finishResolvedRunIsNone_of_finalizationContextLE + (table : OtsSecretIndex → HashOutput) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftValue rightValue : α) + (hcontext : FinalizationContextLE table left right) : + RelTriple + (finishResolvedRunIsNone + (some ⟨left, leftFuel, leftValue, table⟩)) + (finishResolvedRunIsNone + (some ⟨right, rightFuel, rightValue, table⟩)) + BoolImp := by + rw [finishResolvedRunIsNone_some_eq_finalize _ hcontext.leftCompletable, + finishResolvedRunIsNone_some_eq_finalize _ hcontext.rightCompletable] + exact relTriple_map_isNone_finalizeResolvedCoordinates_of_finalizationViewLE_covered + table left.state.coordinates.toList right.state.coordinates.toList left right hcontext.view + left.state.coordinates.nodup_toList right.state.coordinates.nodup_toList + (pendingCovered_coordinates_toList left) (pendingCovered_coordinates_toList right) + +set_option maxRecDepth 100000 in +theorem relTriple_classifyDirectOrdinaryObserve_resolvedFinalization_of_contextLE + (table : OtsSecretIndex → HashOutput) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftValue rightValue : α) + (hcontext : FinalizationContextLE table left right) : + RelTriple + (classifyDirectOrdinaryObserve table (resolvedFinalizationObserve table) + left leftFuel leftValue) + (classifyDirectOrdinaryObserve table (resolvedFinalizationObserve table) + right rightFuel rightValue) + BoolImp := by + have hleftNotPrivate := + not_privateStructuralHit_of_deferredCompletable hcontext.leftCompletable + have hrightNotPrivate := + not_privateStructuralHit_of_deferredCompletable hcontext.rightCompletable + simp only [classifyDirectOrdinaryObserve, hleftNotPrivate, hrightNotPrivate, + hcontext.leftCompletable, hcontext.rightCompletable, ↓reduceIte, + resolvedFinalizationObserve] + exact relTriple_finishResolvedRunIsNone_of_finalizationContextLE table left right leftFuel + rightFuel leftValue rightValue hcontext + +theorem relTriple_finishDirectDetailedOrdinaryObserve_of_stableRunEq + (table : OtsSecretIndex → HashOutput) + (leftRun rightRun : ProbComp + (DirectDetailedResult (α × SplitHashCache))) + (leftObserve rightObserve : DeferredContext → Nat → + (α × SplitHashCache) → ProbComp Bool) + (hrun : RelTriple leftRun rightRun + (DirectDetailedOrdinaryStableRunEq table)) + (hclean : ∀ leftResult rightResult, + DirectDetailedResult.done leftResult ∈ support leftRun → + DirectDetailedResult.done rightResult ∈ support rightRun → + OrdinaryMaterializedRunEq table leftResult rightResult → + RelTriple + (leftObserve leftResult.context leftResult.remaining leftResult.value) + (rightObserve rightResult.context rightResult.remaining rightResult.value) + BoolImp) + (hdoomed : ∀ result, + DirectDetailedResult.done result ∈ support rightRun → + OrdinaryMaterializedDoomedRun table result → + evalDist (rightObserve result.context result.remaining result.value) = + evalDist (pure true : ProbComp Bool)) : + RelTriple + (leftRun >>= finishDirectDetailedOrdinaryObserve leftObserve) + (rightRun >>= finishDirectDetailedOrdinaryObserve rightObserve) + BoolImp := by + have hleftSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hrun + (fun result => result ∈ support leftRun) (fun result hresult => hresult) + have hbothSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupport + apply relTriple_bind hbothSupport + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hrelation, hleftMem⟩, hrightMem⟩ + cases leftResult with + | stopped leftReason => + cases leftReason with + | privateStructuralHit => + exact relTriple_false_any + (finishDirectDetailedOrdinaryObserve rightObserve rightResult) + | ordinaryHit => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => exact relTriple_pure_pure (fun h => h) + | fuelExhausted => exact relTriple_pure_pure (fun h => h) + | done rightResult => + exact relTriple_any_true_of_evalDist_eq_true (pure true) + (rightObserve rightResult.context rightResult.remaining rightResult.value) + (hdoomed rightResult hrightMem hrelation) + | fuelExhausted => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => exact relTriple_pure_pure (fun h => h) + | fuelExhausted => exact relTriple_pure_pure (fun h => h) + | done rightResult => + exact relTriple_any_true_of_evalDist_eq_true (pure true) + (rightObserve rightResult.context rightResult.remaining rightResult.value) + (hdoomed rightResult hrightMem hrelation) + | done leftResult => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => + exact relTriple_any_true_of_evalDist_eq_true + (leftObserve leftResult.context leftResult.remaining leftResult.value) + (pure true) rfl + | fuelExhausted => + exact relTriple_any_true_of_evalDist_eq_true + (leftObserve leftResult.context leftResult.remaining leftResult.value) + (pure true) rfl + | done rightResult => + rcases hrelation with hcleanRelation | hdoomedRelation + · exact hclean leftResult rightResult hleftMem hrightMem hcleanRelation + · exact relTriple_any_true_of_evalDist_eq_true + (leftObserve leftResult.context leftResult.remaining leftResult.value) + (rightObserve rightResult.context rightResult.remaining rightResult.value) + (hdoomed rightResult hrightMem hdoomedRelation) + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectDetailedOrdinaryObserve_maskedPublishedTreeRoot + (table : OtsSecretIndex → HashOutput) (fuel : Nat) + (leftObserve rightObserve : DeferredContext → Nat → + (Digest × SplitHashCache) → ProbComp Bool) + (hclean : ∀ leftResult rightResult, + DirectDetailedResult.done leftResult ∈ support + (runDirectResolvedDetailedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)) → + DirectDetailedResult.done rightResult ∈ support + (runDirectResolvedDetailedFromTable + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)) → + OrdinaryMaterializedRunEq table leftResult rightResult → + RelTriple + (leftObserve leftResult.context leftResult.remaining leftResult.value) + (rightObserve rightResult.context rightResult.remaining rightResult.value) + BoolImp) + (hdoomed : ∀ result, + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)) → + OrdinaryMaterializedDoomedRun table result → + evalDist (rightObserve result.context result.remaining result.value) = + evalDist (pure true : ProbComp Bool)) : + RelTriple + (runDirectDetailedOrdinaryObserve leftObserve + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)) + (runDirectDetailedOrdinaryObserve rightObserve + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)) + BoolImp := by + apply relTriple_finishDirectDetailedOrdinaryObserve_of_stableRunEq table + · exact ordinaryMaterializedStableCouples_maskedPublishedTreeRoot table + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel fuel emptySplitHashCache emptySplitHashCache + (finalizationContextLE_empty table) le_rfl rfl rfl + (fun _ _ hvalue => hvalue) publishedValues_empty rfl + · exact hclean + · exact hdoomed + +theorem evalDist_runDirectDetailedOrdinaryObserve_bind + (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (fuel : Nat) + (left : OracleComp (LazyRevealProbe.World Coordinate) α) + (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) + (observe : DeferredContext → Nat → β → ProbComp Bool) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + evalDist + (runDirectDetailedOrdinaryObserve observe context fuel table (left >>= next)) = + evalDist (runDirectResolvedDetailedFromTable context fuel table left >>= + finishDirectDetailedOrdinaryObserve + (fun nextContext remaining value => + runDirectDetailedOrdinaryObserve observe nextContext remaining table + (next value))) := by + unfold runDirectDetailedOrdinaryObserve + rw [runDirectResolvedDetailedFromTable_bind, bind_assoc] + apply evalDist_bind_congr + intro result hresult + cases result with + | stopped reason => cases reason <;> rfl + | done result => + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + left context fuel table result hresult + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable + left context fuel table result hconsistent hstarts hdirect + simp [finishDirectDetailedOrdinaryObserve, hcore.1] + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectDetailedOrdinaryObserve_simulateQ_le_boundaryFailed + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec alpha) + (observe : DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + RelTriple + (runDirectDetailedOrdinaryObserve observe context fuel table + ((simulateQ impl computation).run cache)) + (directBoundaryCanonicalMaterializedFailedObserve impl computation observe + context fuel table cache) + BoolImp := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + simp [directBoundaryCanonicalMaterializedFailedObserve, + runDirectDetailedOrdinaryObserve, runDirectResolvedDetailedFromTable, + finishDirectDetailedOrdinaryObserve] + apply relTriple_post_mono (relTriple_refl (observe context fuel (value, cache))) + intro leftValue rightValue heq hleft + rw [← heq] + exact hleft + all_goals trivial + | query_bind query next ih => + let leftNext : DeferredContext → Nat → + ((spec.Range query) × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + runDirectDetailedOrdinaryObserve observe nextContext remaining table + ((simulateQ impl (next value.1)).run value.2) + let rightNext : DeferredContext → Nat → + ((spec.Range query) × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + directBoundaryCanonicalMaterializedFailedObserve impl (next value.1) observe + nextContext remaining table value.2 + have hleftFactor : + evalDist + (runDirectDetailedOrdinaryObserve observe context fuel table + ((simulateQ impl (OracleSpec.query query >>= next)).run cache)) = + evalDist + (runDirectDetailedOrdinaryObserve leftNext context fuel table + ((impl query).run cache)) := by + rw [simulateQ_query_bind, StateT.run_bind] + exact evalDist_runDirectDetailedOrdinaryObserve_bind table context fuel + ((impl query).run cache) + (fun value => (simulateQ impl (next value.1)).run value.2) + observe hconsistent hstarts + apply relTriple_of_evalDist_eq_left hleftFactor + rw [directBoundaryCanonicalMaterializedFailedObserve, + OracleComp.construct_query_bind] + apply relTriple_runDirectDetailedOrdinaryObserve_runDirectResolvedObserve + intro result hresult + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + ((impl query).run cache) context fuel table result hresult + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable + ((impl query).run cache) context fuel table result hconsistent hstarts hdirect + unfold classifyCanonicalMaterializedFailedObserve + by_cases hprivate : PrivateStructuralHit + (canonicalizeMaterializedValues table result.context) + · simp only [hprivate, ↓reduceIte] + exact relTriple_any_true_of_evalDist_eq_true + (leftNext result.context result.remaining result.value) (pure true) rfl + · simp only [hprivate, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table result.context + · simp only [hcompletable, ↓reduceIte] + exact ih result.value.1 result.context result.remaining result.value.2 + hcore.2.1 hcore.2.2 + · simp only [hcompletable, ↓reduceIte] + exact relTriple_any_true_of_evalDist_eq_true + (leftNext result.context result.remaining result.value) (pure true) rfl + +set_option maxRecDepth 100000 in +theorem relTriple_finishDirectDetailedOrdinaryObserve_of_runEq + (table : OtsSecretIndex → HashOutput) + (leftRun rightRun : ProbComp + (DirectDetailedResult (α × SplitHashCache))) + (leftObserve rightObserve : DeferredContext → Nat → + (α × SplitHashCache) → ProbComp Bool) + (hrun : RelTriple leftRun rightRun (DirectDetailedOrdinaryRunEq table)) + (hleftPublished : ∀ result, + DirectDetailedResult.done result ∈ support leftRun → + PublishedValues result.context.state) + (hclean : ∀ leftResult rightResult, + DirectDetailedResult.done leftResult ∈ support leftRun → + DirectDetailedResult.done rightResult ∈ support rightRun → + OrdinaryMaterializedRunEq table leftResult rightResult → + RelTriple + (leftObserve (canonicalizeMaterializedValues table leftResult.context) + leftResult.remaining leftResult.value) + (rightObserve rightResult.context rightResult.remaining rightResult.value) + BoolImp) + (hdoomed : ∀ result, + DirectDetailedResult.done result ∈ support rightRun → + OrdinaryMaterializedDoomedRun table result → + evalDist (rightObserve result.context result.remaining result.value) = + evalDist (pure true : ProbComp Bool)) : + RelTriple + (leftRun >>= finishDirectDetailedOrdinaryObserve + (canonicalizeDirectDetailedOrdinaryObserve table leftObserve)) + (rightRun >>= finishDirectDetailedOrdinaryObserve rightObserve) + BoolImp := by + have hleftSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hrun + (fun result => result ∈ support leftRun) (fun result hresult => hresult) + have hbothSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupport + apply relTriple_bind hbothSupport + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hrelation, hleftMem⟩, hrightMem⟩ + cases leftResult with + | stopped leftReason => + cases leftReason with + | privateStructuralHit => + exact relTriple_false_any + (finishDirectDetailedOrdinaryObserve rightObserve rightResult) + | ordinaryHit => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => exact relTriple_pure_pure (fun h => h) + | fuelExhausted => exact relTriple_pure_pure (fun h => h) + | done rightResult => + exact relTriple_any_true_of_evalDist_eq_true (pure true) + (rightObserve rightResult.context rightResult.remaining rightResult.value) + (hdoomed rightResult hrightMem hrelation) + | fuelExhausted => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => exact relTriple_pure_pure (fun h => h) + | fuelExhausted => exact relTriple_pure_pure (fun h => h) + | done rightResult => + exact relTriple_any_true_of_evalDist_eq_true (pure true) + (rightObserve rightResult.context rightResult.remaining rightResult.value) + (hdoomed rightResult hrightMem hrelation) + | done leftResult => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => + exact relTriple_any_true_of_evalDist_eq_true + (canonicalizeDirectDetailedOrdinaryObserve table leftObserve + leftResult.context leftResult.remaining leftResult.value) + (pure true) rfl + | fuelExhausted => + exact relTriple_any_true_of_evalDist_eq_true + (canonicalizeDirectDetailedOrdinaryObserve table leftObserve + leftResult.context leftResult.remaining leftResult.value) + (pure true) rfl + | done rightResult => + rcases hrelation with hcleanRelation | hprivateRelation | hdoomedRelation + · have hcanonicalCompletable := + hcleanRelation.canonicalize_left.context_le.leftCompletable + have hnotPrivate := not_privateStructuralHit_of_deferredCompletable + hcanonicalCompletable + simpa [finishDirectDetailedOrdinaryObserve, + canonicalizeDirectDetailedOrdinaryObserve, + classifyDirectDetailedOrdinaryObserve, hnotPrivate, + hcleanRelation.left_published, hcanonicalCompletable] using + hclean leftResult rightResult hleftMem hrightMem hcleanRelation + · have hpublished := hleftPublished leftResult hleftMem + have hcanonicalPrivate := + hprivateRelation.canonicalizeMaterializedValues (table := table) hpublished + simp only [finishDirectDetailedOrdinaryObserve, + canonicalizeDirectDetailedOrdinaryObserve, hcanonicalPrivate, ↓reduceIte] + exact relTriple_false_any + (rightObserve rightResult.context rightResult.remaining rightResult.value) + · exact relTriple_any_true_of_evalDist_eq_true + (canonicalizeDirectDetailedOrdinaryObserve table leftObserve + leftResult.context leftResult.remaining leftResult.value) + (rightObserve rightResult.context rightResult.remaining rightResult.value) + (hdoomed rightResult hrightMem hdoomedRelation) + +set_option maxRecDepth 100000 in +theorem evalDist_runDirectDetailedOrdinaryObserve_eq_true_of_materializedDoomed + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (hdoomed : DoomedResolvedContext table context) + (hmaterialized : context = directDeferredContext context.state) + (hobserve : ∀ result, + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) → + FinalizationDoomedRun table (some result) → + result.context = directDeferredContext result.context.state → + evalDist (observe result.context result.remaining result.value) = + evalDist (pure true : ProbComp Bool)) : + evalDist (runDirectDetailedOrdinaryObserve observe context fuel table computation) = + evalDist (pure true : ProbComp Bool) := by + unfold runDirectDetailedOrdinaryObserve + calc + _ = evalDist + (runDirectResolvedDetailedFromTable context fuel table computation >>= fun _ => + pure true) := by + apply evalDist_bind_congr + intro result hresult + have hshape : DirectDetailedMaterialized result := by + rw [hmaterialized] at hresult + exact directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + computation context.state fuel table result hresult + cases result with + | stopped reason => + cases reason with + | privateStructuralHit => exact False.elim hshape + | ordinaryHit => rfl + | fuelExhausted => rfl + | done result => + exact hobserve result hresult + (finalizationDoomedRun_of_mem_runDirectResolvedDetailedFromTable table + computation context fuel result hdoomed hresult) + hshape + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (runDirectResolvedDetailedFromTable context fuel table computation) + (by simp [runDirectResolvedDetailedFromTable]) (pure true) + +set_option maxRecDepth 100000 in +theorem relTriple_directDetailedBoundaryOrdinaryObserve_maskedExpandedAdversaryImpl + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (leftObserve rightObserve : DeferredContext → Nat → + (α × SplitHashCache) → ProbComp Bool) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) computation).IsQueryBoundP + (fun query => query matches Sum.inr _) leftFuel) + (hterminal : ∀ value nextLeft nextRight nextLeftFuel nextRightFuel + nextLeftCache nextRightCache, + FinalizationContextLE table nextLeft nextRight → + nextLeftFuel ≤ nextRightFuel → + ordinaryQueryCache nextLeftCache = ordinaryQueryCache nextRightCache → + nextLeft.state.revealed = nextRight.state.revealed → + LazyRevealProbe.ValuesLE nextLeft.state nextRight.state → + PublishedValues nextLeft.state → + nextRight = directDeferredContext nextRight.state → + RelTriple + (leftObserve nextLeft nextLeftFuel (value, nextLeftCache)) + (rightObserve nextRight nextRightFuel (value, nextRightCache)) BoolImp) + (hdoomed : ∀ result : ResolvedRunResult (α × SplitHashCache), + FinalizationDoomedRun table (some result) → + result.context = directDeferredContext result.context.state → + evalDist (rightObserve result.context result.remaining result.value) = + evalDist (pure true : ProbComp Bool)) : + RelTriple + (directDetailedBoundaryOrdinaryObserve + (maskedExpandedAdversaryImpl parameter root ftsSecret) computation leftObserve + left leftFuel table leftCache) + (runDirectDetailedOrdinaryObserve rightObserve right rightFuel table + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + computation).run rightCache)) BoolImp := by + induction computation using OracleComp.inductionOn generalizing + left right leftFuel rightFuel leftCache rightCache with + | pure value => + simp only [directDetailedBoundaryOrdinaryObserve, OracleComp.construct_pure, + simulateQ_pure, StateT.run_pure] + simpa [runDirectDetailedOrdinaryObserve, runDirectResolvedDetailedFromTable_pure, + finishDirectDetailedOrdinaryObserve] using + hterminal value left right leftFuel rightFuel leftCache rightCache hcontext hfuel + hcache hrevealed hvalues hpublished hrightMaterialized + | query_bind input next ih => + rw [directDetailedBoundaryOrdinaryObserve, OracleComp.construct_query_bind] + let leftNextObserve : DeferredContext → Nat → + ((OracleWorld + SigningSpec).Range input × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + directDetailedBoundaryOrdinaryObserve + (maskedExpandedAdversaryImpl parameter root ftsSecret) (next value.1) + leftObserve nextContext remaining table value.2 + let rightNextObserve : DeferredContext → Nat → + ((OracleWorld + SigningSpec).Range input × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + runDirectDetailedOrdinaryObserve rightObserve nextContext remaining table + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (next value.1)).run value.2) + have hrightFactor : + evalDist + (runDirectDetailedOrdinaryObserve rightObserve right rightFuel table + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (OracleSpec.query input >>= next)).run rightCache)) = + evalDist + (runDirectResolvedDetailedFromTable right rightFuel table + ((maskedExpandedAdversaryImpl parameter root ftsSecret input).run rightCache) >>= + finishDirectDetailedOrdinaryObserve rightNextObserve) := by + rw [simulateQ_query_bind, StateT.run_bind] + exact evalDist_runDirectDetailedOrdinaryObserve_bind table right rightFuel + ((maskedExpandedAdversaryImpl parameter root ftsSecret input).run rightCache) + (fun value => + (simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (next value.1)).run value.2) + rightObserve hcontext.rightValid.valuesConsistent hcontext.view.rightStarts + apply relTriple_of_evalDist_eq_right hrightFactor.symm + apply relTriple_finishDirectDetailedOrdinaryObserve_of_runEq table + · apply relTriple_runDirectResolvedDetailed_maskedExpandedAdversaryImpl + · exact hcontext + · intro houter + cases input with + | inl worldInput => + cases worldInput with + | inl n => simp [IsOuterHash] at houter + | inr hashInput => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + simpa using hbound.1 + | inr message => simp [IsOuterHash] at houter + · exact hfuel + · exact hcache + · exact hrevealed + · exact hvalues + · exact hpublished + · exact hrightMaterialized + · intro result hresult + exact publishedValues_of_done_runDirectResolvedDetailedFromTable + (maskedExpandedAdversaryImpl parameter root ftsSecret input) + (preservesPublishedValuesImpl_maskedExpandedAdversaryImpl parameter root ftsSecret + input) + left leftFuel table leftCache result hpublished hresult + · rintro ⟨leftContext, leftRemaining, ⟨leftOutput, leftFinalCache⟩, leftTable⟩ + ⟨rightContext, rightRemaining, ⟨rightOutput, rightFinalCache⟩, rightTable⟩ + hleftMem hrightMem hrelation + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + ((maskedExpandedAdversaryImpl parameter root ftsSecret input).run leftCache) + left leftFuel table + ⟨leftContext, leftRemaining, (leftOutput, leftFinalCache), leftTable⟩ hleftMem + have hraw := raw_done_of_mem_runDirectResolvedFromTable + ((maskedExpandedAdversaryImpl parameter root ftsSecret input).run leftCache) + left leftFuel table + ⟨leftContext, leftRemaining, (leftOutput, leftFinalCache), leftTable⟩ hdirect + have hstepBound := maskedExpandedAdversaryImpl_step_isProbeBound parameter root + ftsSecret input leftCache + have hremaining := LazyRevealProbe.fuel_le_remaining_add_of_mem_support_runRaw_done + left.state leftContext.state leftFuel leftRemaining + (if IsOuterHash input then 1 else 0) + ((maskedExpandedAdversaryImpl parameter root ftsSecret input).run leftCache) + (leftOutput, leftFinalCache) hstepBound hraw + have htailBound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (next leftOutput)).IsQueryBoundP + (fun query => query matches Sum.inr _) leftRemaining := by + cases input with + | inl worldInput => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases worldInput with + | inl n => + exact (hbound.2 leftOutput).mono (by + simpa [IsOuterHash] using hremaining) + | inr hashInput => + have htail : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, + tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (next leftOutput)).IsQueryBoundP + (fun query => query matches Sum.inr _) (leftFuel - 1) := by + simpa [IsOuterHash] using hbound.2 leftOutput + apply htail.mono + change leftFuel ≤ leftRemaining + 1 at hremaining + omega + | inr message => + rw [simulateQ_expandedAdversaryImpl_query_bind_inr] at hbound + change Option Signature at leftOutput + change LazyRevealProbe.RawResult.done leftContext.state + leftRemaining (leftOutput, leftFinalCache) ∈ support + (LazyRevealProbe.runRaw left.state leftFuel + ((maskedSigningImpl parameter root ftsSecret message).run leftCache)) at hraw + have houtput : leftOutput ∈ support + (scheme.sign + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey) message) := by + exact maskedSign_done_output_mem_support parameter root table ftsSecret + message left.state leftContext.state leftCache leftFinalCache + leftFuel leftRemaining leftOutput + hrelation.context_le.view.leftStarts (by + simpa only [SigningSpec, maskedExpandedAdversaryImpl, + maskedSigningImpl] using hraw) + exact (isQueryBoundP_of_bind hbound leftOutput houtput).mono (by + simpa [IsOuterHash] using hremaining) + simp only [rightNextObserve] + have houtputEq : leftOutput = rightOutput := hrelation.value_eq + rw [← houtputEq] + exact ih leftOutput + (canonicalizeMaterializedValues table leftContext) rightContext + leftRemaining rightRemaining leftFinalCache rightFinalCache + hrelation.canonicalize_left.context_le hrelation.remaining_le hrelation.cache_eq + hrelation.canonicalize_left.revealed_eq hrelation.canonicalize_left.values_le + hrelation.canonicalize_left.left_published hrelation.right_materialized htailBound + · intro result hresult hdoomedRun + exact evalDist_runDirectDetailedOrdinaryObserve_eq_true_of_materializedDoomed + table + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (next result.value.1)).run result.value.2) + rightObserve result.context result.remaining hdoomedRun.1.2 hdoomedRun.2 + (fun nextResult _ => hdoomed nextResult) + +theorem not_privateStructuralHit_of_directDeferredContext + (context : DeferredContext) + (hmaterialized : context = directDeferredContext context.state) : + ¬PrivateStructuralHit context := by + intro hprivate + rcases hprivate with ⟨position, output, hhidden, hvalue, _hhit⟩ + have hsame : context.values position = context.state.values (.position position) := by + rw [hmaterialized] + rfl + rw [hsame, hhidden] at hvalue + contradiction + +noncomputable def retainedResolvedFinalizationOrdinaryObserve + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) : ProbComp Bool := + classifyDirectOrdinaryObserve table (resolvedFinalizationObserve table) + context fuel ((root, value.1), value.2) + +set_option maxRecDepth 100000 in +theorem relTriple_directDetailedRetainedRestOrdinaryObserve + (adversary : Adversary) (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) leftFuel) : + RelTriple + (directDetailedBoundaryOrdinaryObserve + (maskedExpandedAdversaryImpl parameter root ftsSecret) + (retainedGameRestComputation adversary ⟨root, parameter⟩) + (retainedResolvedFinalizationOrdinaryObserve table root) + left leftFuel table leftCache) + (runDirectDetailedOrdinaryObserve + (retainedResolvedFinalizationOrdinaryObserve table root) + right rightFuel table + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).run rightCache)) + BoolImp := by + apply relTriple_directDetailedBoundaryOrdinaryObserve_maskedExpandedAdversaryImpl + parameter root table ftsSecret + · exact hcontext + · exact hfuel + · exact hcache + · exact hrevealed + · exact hvalues + · exact hpublished + · exact hrightMaterialized + · exact hbound + · intro value nextLeft nextRight nextLeftFuel nextRightFuel nextLeftCache nextRightCache + hnextContext _hnextFuel _hnextCache _hnextRevealed _hnextValues _hnextPublished + _hnextMaterialized + exact relTriple_classifyDirectOrdinaryObserve_resolvedFinalization_of_contextLE table + nextLeft nextRight nextLeftFuel nextRightFuel + ((root, value), nextLeftCache) ((root, value), nextRightCache) hnextContext + · intro result hdoomed hmaterialized + have hnotPrivate := + not_privateStructuralHit_of_directDeferredContext result.context hmaterialized + simp [retainedResolvedFinalizationOrdinaryObserve, + classifyDirectOrdinaryObserve, hnotPrivate, hdoomed.2.2.2] + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxRecDepth 100000 in +theorem directBoundaryObserve_bind + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (left : OracleComp spec α) (next : α → OracleComp spec β) + (observe : DeferredContext → Nat → (β × SplitHashCache) → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + directBoundaryObserve impl (left >>= next) observe context fuel table cache = + directBoundaryObserve impl left + (fun nextContext remaining value => + directBoundaryObserve impl (next value.1) observe + nextContext remaining table value.2) + context fuel table cache := by + induction left using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + simp [directBoundaryObserve] + | query_bind query continuation ih => + rw [bind_assoc, directBoundaryObserve, OracleComp.construct_query_bind, + directBoundaryObserve, OracleComp.construct_query_bind] + apply bind_congr + intro result + cases result with + | none => rfl + | some result => + unfold finishObserve canonicalizeObserve + simp only + by_cases hpublished : PublishedValues result.context.state + · simp only [hpublished, ↓reduceIte] + exact ih result.value.1 (canonicalizeMaterializedValues table result.context) + result.remaining result.value.2 + · simp [hpublished] + +set_option maxRecDepth 100000 in +theorem runDirectResolvedFromTable_bind_general + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (left : OracleComp (LazyRevealProbe.World Coordinate) α) + (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) : + runDirectResolvedFromTable context fuel table (left >>= next) = + runDirectResolvedFromTable context fuel table left >>= fun result => + match result with + | none => pure none + | some result => + runDirectResolvedFromTable result.context result.remaining result.table + (next result.value) := by + induction left using OracleComp.inductionOn generalizing context fuel with + | pure value => simp [runDirectResolvedFromTable] + | query_bind input continuation ih => + cases input with + | uniform n => + rw [bind_assoc, runDirectResolvedFromTable_uniform_query_bind, + runDirectResolvedFromTable_uniform_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output context fuel + | hashOutput => + rw [bind_assoc, runDirectResolvedFromTable_hashOutput_query_bind, + runDirectResolvedFromTable_hashOutput_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output context fuel + | ensure coordinate => + rw [bind_assoc, runDirectResolvedFromTable_ensure_query_bind, + runDirectResolvedFromTable_ensure_query_bind] + exact ih () { context with state := context.state.ensure coordinate } fuel + | probe coordinate candidate => + rw [bind_assoc, runDirectResolvedFromTable_probe_query_bind, + runDirectResolvedFromTable_probe_query_bind] + cases fuel with + | zero => simp + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () context remaining + · simp only [hrevealed, ↓reduceIte] + exact ih () + { context with state := context.state.addPending coordinate candidate } + remaining + | peek coordinate => + rw [bind_assoc, runDirectResolvedFromTable_peek_query_bind, + runDirectResolvedFromTable_peek_query_bind] + exact ih (context.state.values coordinate) context fuel + | publish coordinate => + rw [bind_assoc, runDirectResolvedFromTable_publish_query_bind, + runDirectResolvedFromTable_publish_query_bind] + exact ih () { context with state := context.state.publish coordinate } fuel + | reveal coordinate => + rw [bind_assoc, runDirectResolvedFromTable_reveal_query_bind, + runDirectResolvedFromTable_reveal_query_bind] + cases hvalue : context.state.values coordinate with + | some output => + exact ih output context fuel + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] + · simp only [output, hhit, ↓reduceIte] + exact ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel + | position position => + simp only [bind_assoc] + apply bind_congr + intro resolved + cases resolved with + | none => rfl + | some resolved => + exact ih resolved.output + { state := context.state.materialize (.position position) resolved.output + values := resolved.values } + fuel + +set_option maxRecDepth 100000 in +theorem evalDist_failed_directDetailedBoundaryObserve_bind + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (left : OracleComp spec α) (next : α → OracleComp spec β) + (detailedObserve : DeferredContext → Nat → (β × SplitHashCache) → + ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → (β × SplitHashCache) → ProbComp Bool) + [ObserverDooms table observe] + (hobserve : ∀ nextContext remaining value, + nextContext.ValuesConsistent → StartTableAgrees nextContext.state table → + evalDist (DirectBoundaryOutcome.failed <$> + detailedObserve nextContext remaining value) = + evalDist (observe nextContext remaining value)) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + evalDist (DirectBoundaryOutcome.failed <$> + directDetailedBoundaryObserve impl (left >>= next) detailedObserve + context fuel table cache) = + evalDist (DirectBoundaryOutcome.failed <$> + directDetailedBoundaryObserve impl left + (fun nextContext remaining value => + directDetailedBoundaryObserve impl (next value.1) detailedObserve + nextContext remaining table value.2) + context fuel table cache) := by + let detailedNext : DeferredContext → Nat → (α × SplitHashCache) → + ProbComp DirectBoundaryOutcome := fun nextContext remaining value => + directDetailedBoundaryObserve impl (next value.1) detailedObserve + nextContext remaining table value.2 + let nextObserve : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + directBoundaryObserve impl (next value.1) observe + nextContext remaining table value.2 + letI : ObserverDooms table nextObserve := ⟨by + intro nextContext remaining value hnextConsistent hnextStarts hdoomed + exact directBoundaryObserve_dooms impl (next value.1) observe nextContext remaining + value.2 hnextConsistent hnextStarts hdoomed⟩ + calc + _ = evalDist (directBoundaryObserve impl (left >>= next) observe + context fuel table cache) := + evalDist_failed_directDetailedBoundaryObserve impl (left >>= next) detailedObserve observe + hobserve context fuel cache hconsistent hstarts + _ = evalDist (directBoundaryObserve impl left nextObserve + context fuel table cache) := by + rw [directBoundaryObserve_bind] + _ = _ := by + symm + apply evalDist_failed_directDetailedBoundaryObserve impl left detailedNext nextObserve + · intro nextContext remaining value hnextConsistent hnextStarts + exact evalDist_failed_directDetailedBoundaryObserve impl (next value.1) + detailedObserve observe hobserve nextContext remaining value.2 hnextConsistent + hnextStarts + · exact hconsistent + · exact hstarts + +set_option maxRecDepth 100000 in +theorem directBoundaryObserve_liftOracleWorldLeft + (left : QueryImpl OracleWorld + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (right : QueryImpl SigningSpec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp OracleWorld α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + directBoundaryObserve (left + right) (liftOracleWorldLeft computation) + observe context fuel table cache = + directBoundaryObserve left computation observe context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + simp [liftOracleWorldLeft, directBoundaryObserve] + | query_bind query next ih => + change directBoundaryObserve (left + right) + (liftM ((OracleWorld + SigningSpec).query (.inl query)) >>= fun output => + liftOracleWorldLeft (next output)) + observe context fuel table cache = + directBoundaryObserve left (liftM (OracleWorld.query query) >>= next) + observe context fuel table cache + rw [directBoundaryObserve, OracleComp.construct_query_bind, + directBoundaryObserve, OracleComp.construct_query_bind] + apply bind_congr + intro result + cases result with + | none => rfl + | some result => + unfold finishObserve canonicalizeObserve + simp only + by_cases hpublished : PublishedValues result.context.state + · simp only [hpublished, ↓reduceIte] + exact ih result.value.1 (canonicalizeMaterializedValues table result.context) + result.remaining result.value.2 + · simp [hpublished] + +noncomputable def retainedResolvedFinalizationDetailedObserve + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) : ProbComp DirectBoundaryOutcome := + classifyDirectObserve table (resolvedFinalizationObserve table) + context fuel ((root, value.1), value.2) + +noncomputable def retainedResolvedFinalizationObserve + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) : ProbComp Bool := + resolvedFinalizationObserve table context fuel ((root, value.1), value.2) + +instance retainedResolvedFinalizationObserve_observerDooms + (table : OtsSecretIndex → HashOutput) (root : Digest) : + ObserverDooms table (retainedResolvedFinalizationObserve table root) where + eq_true context fuel value hconsistent hstarts hdoomed := by + exact ObserverDooms.eq_true context fuel ((root, value.1), value.2) + hconsistent hstarts hdoomed + +noncomputable def granularDetailedRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp DirectBoundaryOutcome := + directDetailedBoundaryObserve + (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationDetailedObserve table value.1) + context fuel table value.2 + +noncomputable def granularRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp Bool := + directBoundaryObserve + (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationObserve table value.1) + context fuel table value.2 + +instance granularRetainedRestObserve_observerDooms + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ObserverDooms table + (granularRetainedRestObserve adversary parameter table ftsSecret) where + eq_true context fuel value hconsistent hstarts hdoomed := by + exact directBoundaryObserve_dooms + (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationObserve table value.1) + context fuel value.2 hconsistent hstarts hdoomed + +noncomputable def granularDetailedVerifierFinishObserve + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : (Forgery × QueryLog SigningSpec) × SplitHashCache) : + ProbComp DirectBoundaryOutcome := + directDetailedBoundaryObserve + (maskedExpandedAdversaryImpl parameter root ftsSecret) + (do + let verified ← liftOracleWorldLeft + (scheme.verify ⟨root, parameter⟩ value.1.1.message value.1.1.signature) + pure (value.1, verified)) + (retainedResolvedFinalizationDetailedObserve table root) + context fuel table value.2 + +noncomputable def granularVerifierFinishObserve + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : (Forgery × QueryLog SigningSpec) × SplitHashCache) : ProbComp Bool := + directBoundaryObserve + (maskedExpandedAdversaryImpl parameter root ftsSecret) + (do + let verified ← liftOracleWorldLeft + (scheme.verify ⟨root, parameter⟩ value.1.1.message value.1.1.signature) + pure (value.1, verified)) + (retainedResolvedFinalizationObserve table root) + context fuel table value.2 + +noncomputable def granularVerifierResultObserve + (table : OtsSecretIndex → HashOutput) (root : Digest) + (forgeryLog : Forgery × QueryLog SigningSpec) + (context : DeferredContext) (fuel : Nat) + (value : Bool × SplitHashCache) : ProbComp Bool := + retainedResolvedFinalizationObserve table root context fuel + ((forgeryLog, value.1), value.2) + +set_option maxRecDepth 100000 in +theorem granularVerifierFinishObserve_eq_body + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : (Forgery × QueryLog SigningSpec) × SplitHashCache) : + granularVerifierFinishObserve parameter root table ftsSecret context fuel value = + directBoundaryObserve (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ value.1.1.message value.1.1.signature) + (granularVerifierResultObserve table root value.1) + context fuel table value.2 := by + unfold granularVerifierFinishObserve + rw [directBoundaryObserve_bind] + change directBoundaryObserve + (maskedExpandedAdversaryImpl parameter root ftsSecret) + (liftOracleWorldLeft + (scheme.verify ⟨root, parameter⟩ value.1.1.message value.1.1.signature)) + (granularVerifierResultObserve table root value.1) + context fuel table value.2 = _ + unfold maskedExpandedAdversaryImpl + rw [directBoundaryObserve_liftOracleWorldLeft] + +set_option maxRecDepth 100000 in +theorem directVerifierFinishObserve_eq_body + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (fuel : Nat) + (value : (Forgery × QueryLog SigningSpec) × SplitHashCache) : + directVerifierFinishObserve table parameter root context fuel value = + runDirectResolvedObserve (granularVerifierResultObserve table root value.1) + context fuel table + ((simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ value.1.1.message + value.1.1.signature)).run value.2) := by + unfold directVerifierFinishObserve canonicalVerifierFinish runDirectResolvedObserve + granularVerifierResultObserve retainedResolvedFinalizationObserve + simp only [StateT.run_bind, StateT.run_pure] + rw [runDirectResolvedFromTable_bind_general] + simp only [bind_assoc] + apply bind_congr + intro result + cases result <;> rfl + +set_option maxRecDepth 100000 in +theorem evalDist_failed_granularDetailedVerifierFinishObserve + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : (Forgery × QueryLog SigningSpec) × SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + evalDist (DirectBoundaryOutcome.failed <$> + granularDetailedVerifierFinishObserve parameter root table ftsSecret + context fuel value) = + evalDist (granularVerifierFinishObserve parameter root table ftsSecret + context fuel value) := by + unfold granularDetailedVerifierFinishObserve granularVerifierFinishObserve + apply evalDist_failed_directDetailedBoundaryObserve + · intro nextContext remaining nextValue hnextConsistent hnextStarts + unfold retainedResolvedFinalizationDetailedObserve + retainedResolvedFinalizationObserve + exact evalDist_failed_classifyDirectObserve table (resolvedFinalizationObserve table) + nextContext remaining ((root, nextValue.1), nextValue.2) + hnextConsistent hnextStarts + · exact hconsistent + · exact hstarts + +instance granularVerifierFinishObserve_observerDooms + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ObserverDooms table + (granularVerifierFinishObserve parameter root table ftsSecret) where + eq_true context fuel value hconsistent hstarts hdoomed := by + exact directBoundaryObserve_dooms + (maskedExpandedAdversaryImpl parameter root ftsSecret) + (do + let verified ← liftOracleWorldLeft + (scheme.verify ⟨root, parameter⟩ value.1.1.message value.1.1.signature) + pure (value.1, verified)) + (retainedResolvedFinalizationObserve table root) + context fuel value.2 hconsistent hstarts hdoomed + +noncomputable def splitGranularDetailedRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp DirectBoundaryOutcome := + directDetailedBoundaryObserve + (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (signingTraceComputation (adversary.main ⟨value.1, parameter⟩)) + (granularDetailedVerifierFinishObserve parameter value.1 table ftsSecret) + context fuel table value.2 + +set_option maxRecDepth 100000 in +theorem evalDist_failed_granularDetailedRetainedRestObserve_eq_split + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + evalDist (DirectBoundaryOutcome.failed <$> + granularDetailedRetainedRestObserve adversary parameter table ftsSecret + context fuel value) = + evalDist (DirectBoundaryOutcome.failed <$> + splitGranularDetailedRetainedRestObserve adversary parameter table ftsSecret + context fuel value) := by + unfold granularDetailedRetainedRestObserve splitGranularDetailedRetainedRestObserve + retainedGameRestComputation granularDetailedVerifierFinishObserve + apply evalDist_failed_directDetailedBoundaryObserve_bind + (observe := retainedResolvedFinalizationObserve table value.1) + · intro nextContext remaining nextValue hnextConsistent hnextStarts + unfold retainedResolvedFinalizationDetailedObserve + retainedResolvedFinalizationObserve + exact evalDist_failed_classifyDirectObserve table (resolvedFinalizationObserve table) + nextContext remaining ((value.1, nextValue.1), nextValue.2) + hnextConsistent hnextStarts + · exact hconsistent + · exact hstarts + +set_option maxRecDepth 100000 in +theorem evalDist_failed_granularDetailedRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + evalDist (DirectBoundaryOutcome.failed <$> + granularDetailedRetainedRestObserve adversary parameter table ftsSecret + context fuel value) = + evalDist (granularRetainedRestObserve adversary parameter table ftsSecret + context fuel value) := by + unfold granularDetailedRetainedRestObserve granularRetainedRestObserve + apply evalDist_failed_directDetailedBoundaryObserve + · intro nextContext remaining nextValue hnextConsistent hnextStarts + unfold retainedResolvedFinalizationDetailedObserve + retainedResolvedFinalizationObserve + exact evalDist_failed_classifyDirectObserve table (resolvedFinalizationObserve table) + nextContext remaining ((value.1, nextValue.1), nextValue.2) + hnextConsistent hnextStarts + · exact hconsistent + · exact hstarts + +noncomputable def granularDetailedRetainedRestOrdinaryObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp Bool := + directDetailedBoundaryOrdinaryObserve + (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationOrdinaryObserve table value.1) + context fuel table value.2 + +theorem evalDist_ordinary_granularDetailedRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : + evalDist (DirectBoundaryOutcome.ordinary <$> + granularDetailedRetainedRestObserve adversary parameter table ftsSecret + context fuel value) = + evalDist (granularDetailedRetainedRestOrdinaryObserve adversary parameter table + ftsSecret context fuel value) := by + unfold granularDetailedRetainedRestObserve + granularDetailedRetainedRestOrdinaryObserve + apply evalDist_ordinary_directDetailedBoundaryObserve + intro nextContext remaining nextValue + unfold retainedResolvedFinalizationDetailedObserve + retainedResolvedFinalizationOrdinaryObserve + exact evalDist_ordinary_classifyDirectObserve table (resolvedFinalizationObserve table) + nextContext remaining ((value.1, nextValue.1), nextValue.2) + +noncomputable def retainedResolvedFinalizationPrivateObserve + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) : ProbComp Bool := + classifyDirectPrivateObserve table (resolvedFinalizationObserve table) + context fuel ((root, value.1), value.2) + +noncomputable def granularDetailedRetainedRestPrivateObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp Bool := + directDetailedBoundaryPrivateObserve + (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivateObserve table value.1) + context fuel table value.2 + +theorem evalDist_private_granularDetailedRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : + evalDist (DirectBoundaryOutcome.privateStructural <$> + granularDetailedRetainedRestObserve adversary parameter table ftsSecret + context fuel value) = + evalDist (granularDetailedRetainedRestPrivateObserve adversary parameter table + ftsSecret context fuel value) := by + unfold granularDetailedRetainedRestObserve + granularDetailedRetainedRestPrivateObserve + apply evalDist_private_directDetailedBoundaryObserve + intro nextContext remaining nextValue + unfold retainedResolvedFinalizationDetailedObserve + retainedResolvedFinalizationPrivateObserve + exact evalDist_private_classifyDirectObserve table (resolvedFinalizationObserve table) + nextContext remaining ((value.1, nextValue.1), nextValue.2) + +noncomputable def granularAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp DirectBoundaryOutcome := + runDirectDetailedObserve + (granularDetailedRetainedRestObserve adversary parameter table ftsSecret) + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +noncomputable def splitGranularAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp DirectBoundaryOutcome := + runDirectDetailedObserve + (splitGranularDetailedRetainedRestObserve adversary parameter table ftsSecret) + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +set_option maxRecDepth 100000 in +theorem evalDist_failed_granularAllDirectBoundaryDetailedRetainedOutcome_eq_split + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.failed <$> + granularAllDirectBoundaryDetailedRetainedOutcome adversary parameter table + ftsSecret fuel) = + evalDist (DirectBoundaryOutcome.failed <$> + splitGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter table + ftsSecret fuel) := by + let initial : DeferredContext := + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + unfold granularAllDirectBoundaryDetailedRetainedOutcome + splitGranularAllDirectBoundaryDetailedRetainedOutcome runDirectDetailedObserve + rw [map_bind, map_bind] + apply evalDist_bind_congr + intro result hresult + cases result with + | stopped reason => cases reason <;> rfl + | done result => + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + (maskedPublishedTreeRoot.run emptySplitHashCache) initial fuel table result hresult + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) initial fuel table result + DeferredContext.valid_empty.valuesConsistent (startTableAgrees_empty table) hdirect + simp only [finishDirectDetailedObserve] + exact evalDist_failed_granularDetailedRetainedRestObserve_eq_split adversary parameter + table ftsSecret result.context result.remaining result.value hcore.2.1 hcore.2.2 + +noncomputable def granularAllDirectBoundaryRetainedFinishIsNone + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : ProbComp Bool := + runDirectResolvedObserve + (granularRetainedRestObserve adversary parameter table ftsSecret) + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem evalDist_failed_granularAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.failed <$> + granularAllDirectBoundaryDetailedRetainedOutcome adversary parameter table + ftsSecret fuel) = + evalDist (granularAllDirectBoundaryRetainedFinishIsNone adversary parameter table + ftsSecret fuel) := by + let initial : DeferredContext := + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + unfold granularAllDirectBoundaryDetailedRetainedOutcome + granularAllDirectBoundaryRetainedFinishIsNone + apply evalDist_failed_runDirectDetailedObserve + intro result hresult + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + (maskedPublishedTreeRoot.run emptySplitHashCache) initial fuel table result hresult + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) initial fuel table result + DeferredContext.valid_empty.valuesConsistent (startTableAgrees_empty table) hdirect + exact evalDist_failed_granularDetailedRetainedRestObserve adversary parameter table ftsSecret + result.context result.remaining result.value hcore.2.1 hcore.2.2 + +noncomputable def materializedDetailedRetainedRestOrdinaryObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp Bool := + runDirectDetailedOrdinaryObserve + (retainedResolvedFinalizationOrdinaryObserve table value.1) + context fuel table + ((simulateQ (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (retainedGameRestComputation adversary ⟨value.1, parameter⟩)).run value.2) + +noncomputable def granularAllDirectBoundaryDetailedRetainedOrdinary + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := + runDirectDetailedOrdinaryObserve + (granularDetailedRetainedRestOrdinaryObserve adversary parameter table ftsSecret) + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +theorem evalDist_ordinary_granularAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.ordinary <$> + granularAllDirectBoundaryDetailedRetainedOutcome adversary parameter table + ftsSecret fuel) = + evalDist (granularAllDirectBoundaryDetailedRetainedOrdinary adversary parameter table + ftsSecret fuel) := by + unfold granularAllDirectBoundaryDetailedRetainedOutcome + granularAllDirectBoundaryDetailedRetainedOrdinary + apply evalDist_ordinary_runDirectDetailedObserve + intro result _hresult + exact evalDist_ordinary_granularDetailedRetainedRestObserve adversary parameter table + ftsSecret result.context result.remaining result.value + +noncomputable def granularAllDirectBoundaryDetailedRetainedPrivate + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : ProbComp Bool := + runDirectDetailedPrivateObserve + (granularDetailedRetainedRestPrivateObserve adversary parameter table ftsSecret) + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +theorem evalDist_private_granularAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.privateStructural <$> + granularAllDirectBoundaryDetailedRetainedOutcome adversary parameter table + ftsSecret fuel) = + evalDist (granularAllDirectBoundaryDetailedRetainedPrivate adversary parameter table + ftsSecret fuel) := by + unfold granularAllDirectBoundaryDetailedRetainedOutcome + granularAllDirectBoundaryDetailedRetainedPrivate + apply evalDist_private_runDirectDetailedObserve + intro result _hresult + exact evalDist_private_granularDetailedRetainedRestObserve adversary parameter table + ftsSecret result.context result.remaining result.value + +noncomputable def materializedBoundaryDetailedRetainedOrdinary + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := + runDirectDetailedOrdinaryObserve + (materializedDetailedRetainedRestOrdinaryObserve adversary parameter table ftsSecret) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +noncomputable def materializedCanonicalPrivateRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp Bool := + directDetailedBoundaryCanonicalMaterializedPrivateObserve + (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (fun _ _ _ => pure false) context fuel table value.2 + +noncomputable def materializedCanonicalDetailedRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp DirectBoundaryOutcome := + directDetailedBoundaryCanonicalMaterializedObserve + (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (fun _ _ _ => pure .success) context fuel table value.2 + +noncomputable def materializedCanonicalOrdinaryRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp Bool := + directDetailedBoundaryCanonicalMaterializedOrdinaryObserve + (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationOrdinaryObserve table value.1) + context fuel table value.2 + +noncomputable def materializedCanonicalFullDetailedRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp DirectBoundaryOutcome := + directDetailedBoundaryCanonicalMaterializedObserve + (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (fun nextContext remaining nextValue => + DirectBoundaryOutcome.ofFailed <$> + retainedResolvedFinalizationOrdinaryObserve table value.1 + nextContext remaining nextValue) + context fuel table value.2 + +noncomputable def materializedCanonicalFailedRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp Bool := + directBoundaryCanonicalMaterializedFailedObserve + (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationOrdinaryObserve table value.1) + context fuel table value.2 + +noncomputable def materializedCanonicalPrivateRetained + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := + runDirectDetailedPrivateObserve + (materializedCanonicalPrivateRetainedRestObserve adversary parameter table ftsSecret) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +noncomputable def materializedCanonicalDetailedRetained + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp DirectBoundaryOutcome := + runDirectDetailedObserve + (materializedCanonicalDetailedRetainedRestObserve adversary parameter table ftsSecret) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +noncomputable def materializedCanonicalOrdinaryRetained + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := + runDirectDetailedOrdinaryObserve + (materializedCanonicalOrdinaryRetainedRestObserve adversary parameter table ftsSecret) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +noncomputable def materializedCanonicalFullDetailedRetained + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp DirectBoundaryOutcome := + runDirectDetailedObserve + (materializedCanonicalFullDetailedRetainedRestObserve adversary parameter table ftsSecret) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +noncomputable def materializedCanonicalFailedRetained + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := + runDirectResolvedObserve + (materializedCanonicalFailedRetainedRestObserve adversary parameter table ftsSecret) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +theorem evalDist_private_materializedCanonicalDetailedRetained + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.privateStructural <$> + materializedCanonicalDetailedRetained adversary parameter table ftsSecret fuel) = + evalDist + (materializedCanonicalPrivateRetained adversary parameter table ftsSecret fuel) := by + unfold materializedCanonicalDetailedRetained materializedCanonicalPrivateRetained + apply evalDist_private_runDirectDetailedObserve + intro result _hresult + unfold materializedCanonicalDetailedRetainedRestObserve + materializedCanonicalPrivateRetainedRestObserve + apply evalDist_private_directDetailedBoundaryCanonicalMaterializedObserve + intro nextContext remaining value + simp [DirectBoundaryOutcome.privateStructural] + +theorem evalDist_private_materializedCanonicalFullDetailedRetained + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.privateStructural <$> + materializedCanonicalFullDetailedRetained adversary parameter table + ftsSecret fuel) = + evalDist + (materializedCanonicalPrivateRetained adversary parameter table ftsSecret fuel) := by + unfold materializedCanonicalFullDetailedRetained materializedCanonicalPrivateRetained + apply evalDist_private_runDirectDetailedObserve + intro result _hresult + unfold materializedCanonicalFullDetailedRetainedRestObserve + materializedCanonicalPrivateRetainedRestObserve + apply evalDist_private_directDetailedBoundaryCanonicalMaterializedObserve + intro nextContext remaining value + let observe := retainedResolvedFinalizationOrdinaryObserve table result.value.1 + nextContext remaining value + have hprojection : + (fun hit : Bool => (DirectBoundaryOutcome.ofFailed hit).privateStructural) = + fun _ => false := by + funext hit + cases hit <;> rfl + rw [Functor.map_map] + rw [hprojection] + change evalDist ((fun _ : Bool => false) <$> observe) = + evalDist (pure false : ProbComp Bool) + simp only [map_eq_bind_pure_comp] + exact OracleComp.DeferredSampling.evalDist_bind_const_neverFails + observe (by simp [observe, retainedResolvedFinalizationOrdinaryObserve]) (pure false) + +theorem evalDist_ordinary_materializedCanonicalFullDetailedRetained + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.ordinary <$> + materializedCanonicalFullDetailedRetained adversary parameter table + ftsSecret fuel) = + evalDist + (materializedCanonicalOrdinaryRetained adversary parameter table ftsSecret fuel) := by + unfold materializedCanonicalFullDetailedRetained materializedCanonicalOrdinaryRetained + apply evalDist_ordinary_runDirectDetailedObserve + intro result _hresult + unfold materializedCanonicalFullDetailedRetainedRestObserve + materializedCanonicalOrdinaryRetainedRestObserve + apply evalDist_ordinary_directDetailedBoundaryCanonicalMaterializedObserve + intro nextContext remaining value + have hprojection : + (fun hit : Bool => (DirectBoundaryOutcome.ofFailed hit).ordinary) = id := by + funext hit + cases hit <;> rfl + rw [Functor.map_map] + rw [hprojection] + simp + +theorem evalDist_failed_materializedCanonicalFullDetailedRetained + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.failed <$> + materializedCanonicalFullDetailedRetained adversary parameter table + ftsSecret fuel) = + evalDist + (materializedCanonicalFailedRetained adversary parameter table ftsSecret fuel) := by + unfold materializedCanonicalFullDetailedRetained materializedCanonicalFailedRetained + apply evalDist_failed_runDirectDetailedObserve + intro result _hresult + unfold materializedCanonicalFullDetailedRetainedRestObserve + materializedCanonicalFailedRetainedRestObserve + apply evalDist_failed_directDetailedBoundaryCanonicalMaterializedObserve + intro nextContext remaining value + have hprojection : + (fun hit : Bool => (DirectBoundaryOutcome.ofFailed hit).failed) = id := by + funext hit + cases hit <;> rfl + rw [Functor.map_map, hprojection] + simp + +set_option maxRecDepth 100000 in +theorem relTriple_materializedBoundaryDetailedRetainedOrdinary_le_canonicalFailed + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + RelTriple + (materializedBoundaryDetailedRetainedOrdinary adversary parameter table + ftsSecret fuel) + (materializedCanonicalFailedRetained adversary parameter table ftsSecret fuel) + BoolImp := by + unfold materializedBoundaryDetailedRetainedOrdinary + materializedCanonicalFailedRetained + apply relTriple_runDirectDetailedOrdinaryObserve_runDirectResolvedObserve + intro result hresult + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + (maskedPublishedTreeRoot.run emptySplitHashCache) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table result hresult + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table result DeferredContext.valid_empty.valuesConsistent + (startTableAgrees_empty table) hdirect + unfold materializedDetailedRetainedRestOrdinaryObserve + materializedCanonicalFailedRetainedRestObserve + exact relTriple_runDirectDetailedOrdinaryObserve_simulateQ_le_boundaryFailed + (maskedExpandedAdversaryImpl parameter result.value.1 ftsSecret) + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + (retainedResolvedFinalizationOrdinaryObserve table result.value.1) + result.context result.remaining table result.value.2 hcore.2.1 hcore.2.2 + +noncomputable def sampledMaterializedCanonicalPrivateRetained + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := do + let table ← sampleOtsHashTable + materializedCanonicalPrivateRetained adversary parameter table ftsSecret fuel + +noncomputable def sampledMaterializedCanonicalDetailedRetained + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp DirectBoundaryOutcome := do + let table ← sampleOtsHashTable + materializedCanonicalDetailedRetained adversary parameter table ftsSecret fuel + +noncomputable def sampledMaterializedCanonicalOrdinaryRetained + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := do + let table ← sampleOtsHashTable + materializedCanonicalOrdinaryRetained adversary parameter table ftsSecret fuel + +noncomputable def sampledMaterializedCanonicalFullDetailedRetained + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp DirectBoundaryOutcome := do + let table ← sampleOtsHashTable + materializedCanonicalFullDetailedRetained adversary parameter table ftsSecret fuel + +noncomputable def sampledMaterializedCanonicalFailedRetained + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := do + let table ← sampleOtsHashTable + materializedCanonicalFailedRetained adversary parameter table ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem evalDist_private_sampledMaterializedCanonicalDetailedRetained + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.privateStructural <$> + sampledMaterializedCanonicalDetailedRetained adversary parameter ftsSecret fuel) = + evalDist + (sampledMaterializedCanonicalPrivateRetained adversary parameter ftsSecret fuel) := by + unfold sampledMaterializedCanonicalDetailedRetained + sampledMaterializedCanonicalPrivateRetained + rw [map_bind] + apply evalDist_bind_congr + intro table _htable + exact evalDist_private_materializedCanonicalDetailedRetained adversary parameter table + ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem evalDist_private_sampledMaterializedCanonicalFullDetailedRetained + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.privateStructural <$> + sampledMaterializedCanonicalFullDetailedRetained adversary parameter + ftsSecret fuel) = + evalDist + (sampledMaterializedCanonicalPrivateRetained adversary parameter ftsSecret fuel) := by + unfold sampledMaterializedCanonicalFullDetailedRetained + sampledMaterializedCanonicalPrivateRetained + rw [map_bind] + apply evalDist_bind_congr + intro table _htable + exact evalDist_private_materializedCanonicalFullDetailedRetained adversary parameter table + ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem evalDist_ordinary_sampledMaterializedCanonicalFullDetailedRetained + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.ordinary <$> + sampledMaterializedCanonicalFullDetailedRetained adversary parameter + ftsSecret fuel) = + evalDist + (sampledMaterializedCanonicalOrdinaryRetained adversary parameter ftsSecret fuel) := by + unfold sampledMaterializedCanonicalFullDetailedRetained + sampledMaterializedCanonicalOrdinaryRetained + rw [map_bind] + apply evalDist_bind_congr + intro table _htable + exact evalDist_ordinary_materializedCanonicalFullDetailedRetained adversary parameter table + ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem evalDist_failed_sampledMaterializedCanonicalFullDetailedRetained + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.failed <$> + sampledMaterializedCanonicalFullDetailedRetained adversary parameter + ftsSecret fuel) = + evalDist + (sampledMaterializedCanonicalFailedRetained adversary parameter ftsSecret fuel) := by + unfold sampledMaterializedCanonicalFullDetailedRetained + sampledMaterializedCanonicalFailedRetained + rw [map_bind] + apply evalDist_bind_congr + intro table _htable + exact evalDist_failed_materializedCanonicalFullDetailedRetained adversary parameter table + ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_privateStructuralFailure_sampledMaterializedCanonicalDetailedRetained + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[= .privateStructuralFailure | + sampledMaterializedCanonicalDetailedRetained adversary parameter ftsSecret fuel] = + Pr[= true | + sampledMaterializedCanonicalPrivateRetained adversary parameter ftsSecret fuel] := by + rw [probEvent_privateStructuralFailure_eq_map_privateStructural] + exact OracleComp.probOutput_congr rfl + (evalDist_private_sampledMaterializedCanonicalDetailedRetained adversary parameter + ftsSecret fuel) + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_failed_sampledMaterializedCanonicalFullDetailedRetained_le + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun outcome => outcome.failed = true | + sampledMaterializedCanonicalFullDetailedRetained adversary parameter + ftsSecret fuel] ≤ + Pr[= true | + sampledMaterializedCanonicalOrdinaryRetained adversary parameter + ftsSecret fuel] + + Pr[= true | + sampledMaterializedCanonicalPrivateRetained adversary parameter + ftsSecret fuel] := by + calc + _ ≤ Pr[= .ordinaryFailure | + sampledMaterializedCanonicalFullDetailedRetained adversary parameter + ftsSecret fuel] + + Pr[= .privateStructuralFailure | + sampledMaterializedCanonicalFullDetailedRetained adversary parameter + ftsSecret fuel] := + probEvent_failed_le_ordinary_add_private + (sampledMaterializedCanonicalFullDetailedRetained adversary parameter + ftsSecret fuel) + _ = _ := by + rw [probEvent_ordinaryFailure_eq_map_ordinary, + probEvent_privateStructuralFailure_eq_map_privateStructural] + apply congrArg₂ (· + ·) + · exact OracleComp.probOutput_congr rfl + (evalDist_ordinary_sampledMaterializedCanonicalFullDetailedRetained + adversary parameter ftsSecret fuel) + · exact OracleComp.probOutput_congr rfl + (evalDist_private_sampledMaterializedCanonicalFullDetailedRetained + adversary parameter ftsSecret fuel) + +set_option maxRecDepth 100000 in +theorem fuel_le_remaining_of_done_maskedPublishedTreeRoot + (table : OtsSecretIndex → HashOutput) (fuel : Nat) + (result : ResolvedRunResult (Digest × SplitHashCache)) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) : + fuel ≤ result.remaining := by + have hdirect : some result ∈ support + (runDirectResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)) := + mem_support_runDirectResolvedFromTable_of_done_detailed + (alpha := Digest × SplitHashCache) + (computation := maskedPublishedTreeRoot.run emptySplitHashCache) + (context := + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues }) + (fuel := fuel) (table := table) (result := result) hresult + have hraw : LazyRevealProbe.RawResult.done result.context.state result.remaining result.value ∈ + support (LazyRevealProbe.runRaw + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel + (maskedPublishedTreeRoot.run emptySplitHashCache)) := + raw_done_of_mem_runDirectResolvedFromTable + (computation := maskedPublishedTreeRoot.run emptySplitHashCache) + (context := + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues }) + (fuel := fuel) (table := table) (result := result) hdirect + have hremaining := LazyRevealProbe.fuel_le_remaining_add_of_mem_support_runRaw_done + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + result.context.state fuel result.remaining 0 + (maskedPublishedTreeRoot.run emptySplitHashCache) result.value + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) hraw + simpa using hremaining + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem relTriple_granularAllDirectBoundaryDetailedRetainedOrdinary + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (hparameter : parameter ∈ support sampleParameter) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + RelTriple + (granularAllDirectBoundaryDetailedRetainedOrdinary adversary parameter table ftsSecret q) + (materializedBoundaryDetailedRetainedOrdinary adversary parameter table ftsSecret q) + BoolImp := by + unfold granularAllDirectBoundaryDetailedRetainedOrdinary + materializedBoundaryDetailedRetainedOrdinary + apply relTriple_runDirectDetailedOrdinaryObserve_maskedPublishedTreeRoot table q + · intro leftResult rightResult hleftMem _hrightMem hrelation + have hremaining : q ≤ leftResult.remaining := + fuel_le_remaining_of_done_maskedPublishedTreeRoot + table q leftResult hleftMem + have hbound := isQueryBoundP_expandedRetained_all_tables_roots adversary q hq parameter + hparameter table ftsSecret hfts leftResult.value.1 + have htailBound := hbound.mono (by simpa using hremaining) + have hroot : leftResult.value.1 = rightResult.value.1 := hrelation.value_eq + unfold granularDetailedRetainedRestOrdinaryObserve + materializedDetailedRetainedRestOrdinaryObserve + rw [← hroot] + exact relTriple_directDetailedRetainedRestOrdinaryObserve adversary parameter + leftResult.value.1 table ftsSecret leftResult.context rightResult.context + leftResult.remaining rightResult.remaining leftResult.value.2 rightResult.value.2 + hrelation.context_le hrelation.remaining_le hrelation.cache_eq hrelation.revealed_eq + hrelation.values_le hrelation.left_published hrelation.right_materialized htailBound + · intro result _hresult hdoomed + unfold materializedDetailedRetainedRestOrdinaryObserve + exact evalDist_runDirectDetailedOrdinaryObserve_eq_true_of_materializedDoomed table + ((simulateQ (maskedExpandedAdversaryImpl parameter result.value.1 ftsSecret) + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩)).run + result.value.2) + (retainedResolvedFinalizationOrdinaryObserve table result.value.1) + result.context result.remaining hdoomed.1.2 hdoomed.2 + (fun finalResult _hfinal hfinalDoomed hfinalMaterialized => by + have hnotPrivate := not_privateStructuralHit_of_directDeferredContext + finalResult.context hfinalMaterialized + simp [retainedResolvedFinalizationOrdinaryObserve, + classifyDirectOrdinaryObserve, hnotPrivate, hfinalDoomed.2.2.2]) + +noncomputable def materializedFlatResolvedFinalizationOrdinary + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := + runDirectDetailedOrdinaryObserve + (classifyDirectOrdinaryObserve table (resolvedFinalizationObserve table)) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table (deferredCleanRetainedRun adversary parameter ftsSecret) + +/-! The guarded endpoint charges ordinary failure already visible in the final materialized +context. It is one component of the ordinary comparison. The separate flat endpoint retains the +actual lazy finalization and charges failures created only while completing unresolved values. -/ + +noncomputable def materializedGuardedSafeOrdinaryRetained + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := + runDirectResolvedDetailedFromTable + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table (deferredCleanRetainedRun adversary parameter ftsSecret) >>= + finishDirectDetailedSafeOrdinaryObserve + guardedDirectDetailedSafeOrdinaryTerminalObserve + +noncomputable def sampledMaterializedGuardedSafeOrdinaryRetained + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := do + let table ← sampleOtsHashTable + materializedGuardedSafeOrdinaryRetained adversary parameter table ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem evalDist_sampledMaterializedGuardedSafeOrdinaryRetained_eq_completionTable + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist + (sampledMaterializedGuardedSafeOrdinaryRetained adversary parameter + ftsSecret fuel) = + evalDist + (runDirectDetailedSafeOrdinaryWithCompletionTable + guardedDirectDetailedSafeOrdinaryTerminalObserve + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel (deferredCleanRetainedRun adversary parameter ftsSecret)) := by + unfold sampledMaterializedGuardedSafeOrdinaryRetained + materializedGuardedSafeOrdinaryRetained + have hsample := evalDist_sampled_runDirectDetailedSafeOrdinary_eq_completionTable + (deferredCleanRetainedRun adversary parameter ftsSecret) + guardedDirectDetailedSafeOrdinaryTerminalObserve + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) fuel + simpa [directDeferredContext, completedStartTable_empty] using hsample + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_sampledMaterializedGuardedSafeOrdinaryRetained_le + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[= true | + sampledMaterializedGuardedSafeOrdinaryRetained adversary parameter + ftsSecret fuel] ≤ + (fuel : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ = Pr[= true | + runDirectDetailedSafeOrdinaryWithCompletionTable + guardedDirectDetailedSafeOrdinaryTerminalObserve + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel (deferredCleanRetainedRun adversary parameter ftsSecret)] := + OracleComp.probOutput_congr rfl + (evalDist_sampledMaterializedGuardedSafeOrdinaryRetained_eq_completionTable + adversary parameter ftsSecret fuel) + _ ≤ _ := by + simpa [directDeferredContext, LazyRevealProbe.State.empty] using + (probEvent_runDirectDetailedSafeOrdinaryGuardedTerminal_le + (deferredCleanRetainedRun adversary parameter ftsSecret) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) fuel) + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_sampledFlat_add_materializedGuardedOrdinaryRetained_le_two_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) : + Pr[= true | sampledFlatDetailedOrdinaryRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledMaterializedGuardedSafeOrdinaryRetained adversary parameter ftsSecret q] ≤ + ((2 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ ≤ (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + add_le_add + (probEvent_sampledFlatDetailedOrdinaryRetained_le adversary parameter ftsSecret q) + (probEvent_sampledMaterializedGuardedSafeOrdinaryRetained_le adversary parameter + ftsSecret q) + _ = _ := by + push_cast + ring + +set_option maxRecDepth 100000 in +theorem deferredCleanRetainedRun_eq_retainedGameRest_bind + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + deferredCleanRetainedRun adversary parameter ftsSecret = (do + let rootResult ← maskedPublishedTreeRoot.run emptySplitHashCache + let restResult ← + (simulateQ + (maskedExpandedAdversaryImpl parameter rootResult.1 ftsSecret) + (retainedGameRestComputation adversary ⟨rootResult.1, parameter⟩)).run + rootResult.2 + pure ((rootResult.1, restResult.1), restResult.2)) := by + rw [deferredCleanRetainedRun_eq_boundary_bind] + apply bind_congr + intro rootResult + rw [simulateQ_maskedExpanded_retainedGameRestComputation] + unfold canonicalVerifierFinish + simp only [StateT.run_bind, StateT.run_pure, bind_assoc, pure_bind] + +set_option maxRecDepth 100000 in +theorem evalDist_materializedBoundaryDetailedRetainedOrdinary_eq_flat + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (materializedBoundaryDetailedRetainedOrdinary adversary parameter table + ftsSecret fuel) = + evalDist (materializedFlatResolvedFinalizationOrdinary adversary parameter table + ftsSecret fuel) := by + unfold materializedBoundaryDetailedRetainedOrdinary + materializedDetailedRetainedRestOrdinaryObserve + retainedResolvedFinalizationOrdinaryObserve + materializedFlatResolvedFinalizationOrdinary + rw [deferredCleanRetainedRun_eq_retainedGameRest_bind] + rw [evalDist_runDirectDetailedOrdinaryObserve_bind] + · apply evalDist_bind_congr + intro result hresult + cases result with + | stopped reason => cases reason <;> rfl + | done result => + simp only [finishDirectDetailedOrdinaryObserve] + symm + apply evalDist_runDirectDetailedOrdinaryObserve_bind + · have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + (maskedPublishedTreeRoot.run emptySplitHashCache) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table result hresult + exact (resolvedCore_of_mem_runDirectResolvedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table result DeferredContext.valid_empty.valuesConsistent + (startTableAgrees_empty table) hdirect).2.1 + · have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + (maskedPublishedTreeRoot.run emptySplitHashCache) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table result hresult + exact (resolvedCore_of_mem_runDirectResolvedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table result DeferredContext.valid_empty.valuesConsistent + (startTableAgrees_empty table) hdirect).2.2 + · exact DeferredContext.valid_empty.valuesConsistent + · exact startTableAgrees_empty table + +set_option maxRecDepth 100000 in +theorem evalDist_runDirectDetailedOrdinaryResolvedFinalization_materialized_eq + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hconsistent : (directDeferredContext state).ValuesConsistent) + (hstarts : StartTableAgrees state table) : + evalDist + (runDirectDetailedOrdinaryObserve + (classifyDirectOrdinaryObserve table (resolvedFinalizationObserve table)) + (directDeferredContext state) fuel table computation) = + evalDist + (runDirectResolvedFromTable (directDeferredContext state) fuel table computation >>= + finishResolvedRunIsNone) := by + unfold runDirectDetailedOrdinaryObserve + rw [← map_toOption_runDirectResolvedDetailedFromTable computation + (directDeferredContext state) fuel table] + simp only [map_eq_bind_pure_comp, bind_assoc, pure_bind, Function.comp_apply] + apply evalDist_bind_congr + intro result hresult + have hmaterialized := + directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + computation state fuel table result hresult + cases result with + | stopped reason => + cases reason with + | privateStructuralHit => contradiction + | ordinaryHit => rfl + | fuelExhausted => rfl + | done result => + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + computation (directDeferredContext state) fuel table result hresult + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable computation + (directDeferredContext state) fuel table result hconsistent hstarts hdirect + rcases result with ⟨resultContext, remaining, value, resultTable⟩ + dsimp only at hcore hmaterialized ⊢ + have htable : resultTable = table := hcore.1 + subst resultTable + have hnotPrivate := not_privateStructuralHit_of_directDeferredContext + resultContext hmaterialized + by_cases hcompletable : DeferredCompletable table resultContext + · simp [finishDirectDetailedOrdinaryObserve, classifyDirectOrdinaryObserve, + resolvedFinalizationObserve, DirectDetailedResult.toOption, + hnotPrivate, hcompletable] + · simp [finishDirectDetailedOrdinaryObserve, classifyDirectOrdinaryObserve, + DirectDetailedResult.toOption, finishResolvedRunIsNone, finishResolvedRun, + hnotPrivate, hcompletable] + +noncomputable def sampledMaterializedBoundaryDetailedRetainedOrdinary + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := do + let table ← sampleOtsHashTable + materializedBoundaryDetailedRetainedOrdinary adversary parameter table ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem relTriple_sampledMaterializedBoundaryDetailedRetainedOrdinary_le_canonicalFailed + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + RelTriple + (sampledMaterializedBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret fuel) + (sampledMaterializedCanonicalFailedRetained adversary parameter ftsSecret fuel) + BoolImp := by + unfold sampledMaterializedBoundaryDetailedRetainedOrdinary + sampledMaterializedCanonicalFailedRetained + apply relTriple_bind (relTriple_refl sampleOtsHashTable) + intro leftTable rightTable htable + subst rightTable + exact relTriple_materializedBoundaryDetailedRetainedOrdinary_le_canonicalFailed + adversary parameter leftTable ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_sampledMaterializedBoundaryDetailedRetainedOrdinary_le_canonicalFailed + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[= true | + sampledMaterializedBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret fuel] ≤ + Pr[= true | + sampledMaterializedCanonicalFailedRetained adversary parameter ftsSecret fuel] := by + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput] + apply probEvent_le_of_relTriple + (relTriple_sampledMaterializedBoundaryDetailedRetainedOrdinary_le_canonicalFailed + adversary parameter ftsSecret fuel) + intro leftValue rightValue himp hleft + exact himp hleft + +noncomputable def sampledGranularAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp DirectBoundaryOutcome := do + let table ← sampleOtsHashTable + granularAllDirectBoundaryDetailedRetainedOutcome adversary parameter table ftsSecret fuel + +noncomputable def sampledSplitGranularAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp DirectBoundaryOutcome := do + let table ← sampleOtsHashTable + splitGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter table ftsSecret fuel + +noncomputable def sampledGranularAllDirectBoundaryRetainedFinishIsNone + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : ProbComp Bool := do + let table ← sampleOtsHashTable + granularAllDirectBoundaryRetainedFinishIsNone adversary parameter table ftsSecret fuel + +noncomputable def sampledGranularAllDirectBoundaryDetailedRetainedOrdinary + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : ProbComp Bool := do + let table ← sampleOtsHashTable + granularAllDirectBoundaryDetailedRetainedOrdinary adversary parameter table ftsSecret fuel + +noncomputable def sampledGranularAllDirectBoundaryDetailedRetainedPrivate + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : ProbComp Bool := do + let table ← sampleOtsHashTable + granularAllDirectBoundaryDetailedRetainedPrivate adversary parameter table ftsSecret fuel + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem relTriple_sampledGranularAllDirectBoundaryDetailedRetainedOrdinary_materialized + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (hparameter : parameter ∈ support sampleParameter) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + RelTriple + (sampledGranularAllDirectBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret q) + (sampledMaterializedBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret q) + BoolImp := by + unfold sampledGranularAllDirectBoundaryDetailedRetainedOrdinary + sampledMaterializedBoundaryDetailedRetainedOrdinary + apply relTriple_bind (relTriple_refl sampleOtsHashTable) + intro leftTable rightTable htable + subst rightTable + exact relTriple_granularAllDirectBoundaryDetailedRetainedOrdinary adversary parameter + leftTable ftsSecret q hq hparameter hfts + +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledGranularAllDirectBoundaryDetailedRetainedOrdinary_le_materialized + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (hparameter : parameter ∈ support sampleParameter) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret q] ≤ + Pr[= true | + sampledMaterializedBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret q] := by + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput] + apply probEvent_le_of_relTriple + (relTriple_sampledGranularAllDirectBoundaryDetailedRetainedOrdinary_materialized + adversary parameter ftsSecret q hq hparameter hfts) + intro leftValue rightValue himp hleft + exact himp hleft + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem evalDist_sampledMaterializedBoundaryDetailedRetainedOrdinary_eq_flat + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist + (sampledMaterializedBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret fuel) = + evalDist (do + let table ← sampleOtsHashTable + materializedFlatResolvedFinalizationOrdinary adversary parameter table + ftsSecret fuel) := by + unfold sampledMaterializedBoundaryDetailedRetainedOrdinary + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro table + exact evalDist_materializedBoundaryDetailedRetainedOrdinary_eq_flat adversary parameter + table ftsSecret fuel + +set_option maxRecDepth 100000 in +theorem evalDist_finishDirectRunIsNone_eq_true_of_missingChainStartHit + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (fuel : Nat) (value : α) + (hmissing : MissingChainStartHit table (directDeferredContext state)) : + evalDist (finishDirectRunIsNone + (some ⟨directDeferredContext state, fuel, value, table⟩)) = + evalDist (pure true : ProbComp Bool) := by + obtain ⟨index, hvalue, hhit⟩ := hmissing + have hstateValue : state.values index.coordinate = none := by + simpa only [directDeferredContext] using hvalue + have hmem : index.coordinate ∈ state.coordinates := by + by_contra hnotMem + exact (not_hitAt_of_not_mem_coordinates state index.coordinate (table index) hnotMem) hhit + have hexpose := evalDist_finalizeCleanFromTable_finset_expose_missing + index.coordinate state.coordinates state table hmem hstateValue + unfold finishDirectRunIsNone finishCleanRunIsNone projectResolvedRunResult + simp only [finishCleanRunFromTable, map_bind] + simp only [directDeferredContext] + rw [evalDist_bind, hexpose, ← evalDist_bind] + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + have hhitState : state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + simpa only [directDeferredContext, OtsSecretIndex.coordinate] using hhit + simp [OtsSecretIndex.coordinate, completionOutputFromTable, hhitState] + +set_option maxRecDepth 100000 in +theorem evalDist_finishResolvedRunIsNone_eq_finishDirectRunIsNone_of_materialized + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (fuel : Nat) (value : α) + (hvalid : (directDeferredContext state).Valid) + (hstarts : StartTableAgrees state table) + (hcard : state.pending.card < Fintype.card Digest) : + evalDist (finishResolvedRunIsNone + (some ⟨directDeferredContext state, fuel, value, table⟩)) = + evalDist (finishDirectRunIsNone + (some ⟨directDeferredContext state, fuel, value, table⟩)) := by + by_cases hcompletable : DeferredCompletable table (directDeferredContext state) + · exact evalDist_finishResolvedRunIsNone_eq_finishDirectRunIsNone + state fuel value table hcompletable + · have hcause := privateStructuralHit_or_missingChainStartHit_of_not_completable + table (directDeferredContext state) hvalid hstarts hcard hcompletable + have hnotPrivate := not_privateStructuralHit_of_directDeferredContext + (directDeferredContext state) rfl + have hmissing : MissingChainStartHit table (directDeferredContext state) := + hcause.resolve_left hnotPrivate + calc + _ = evalDist (pure true : ProbComp Bool) := by + simp [finishResolvedRunIsNone, finishResolvedRun, hcompletable] + _ = _ := + (evalDist_finishDirectRunIsNone_eq_true_of_missingChainStartHit + state table fuel value hmissing).symm + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem evalDist_ordinary_sampledGranularAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.ordinary <$> + sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret fuel) = + evalDist (sampledGranularAllDirectBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret fuel) := by + unfold sampledGranularAllDirectBoundaryDetailedRetainedOutcome + sampledGranularAllDirectBoundaryDetailedRetainedOrdinary + rw [map_bind] + apply evalDist_bind_congr + intro table _htable + exact evalDist_ordinary_granularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + table ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem evalDist_private_sampledGranularAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.privateStructural <$> + sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret fuel) = + evalDist (sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret fuel) := by + unfold sampledGranularAllDirectBoundaryDetailedRetainedOutcome + sampledGranularAllDirectBoundaryDetailedRetainedPrivate + rw [map_bind] + apply evalDist_bind_congr + intro table _htable + exact evalDist_private_granularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + table ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem evalDist_failed_sampledGranularAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.failed <$> + sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret fuel) = + evalDist (sampledGranularAllDirectBoundaryRetainedFinishIsNone adversary parameter + ftsSecret fuel) := by + unfold sampledGranularAllDirectBoundaryDetailedRetainedOutcome + sampledGranularAllDirectBoundaryRetainedFinishIsNone + rw [map_bind] + apply evalDist_bind_congr + intro table _htable + exact evalDist_failed_granularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + table ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem evalDist_failed_sampledGranularAllDirectBoundaryDetailedRetainedOutcome_eq_split + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.failed <$> + sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret fuel) = + evalDist (DirectBoundaryOutcome.failed <$> + sampledSplitGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret fuel) := by + unfold sampledGranularAllDirectBoundaryDetailedRetainedOutcome + sampledSplitGranularAllDirectBoundaryDetailedRetainedOutcome + rw [map_bind, map_bind] + apply evalDist_bind_congr + intro table _htable + exact evalDist_failed_granularAllDirectBoundaryDetailedRetainedOutcome_eq_split adversary + parameter table ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_failed_sampledGranularAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun outcome => outcome.failed = true | + sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret fuel] = + Pr[= true | + sampledGranularAllDirectBoundaryRetainedFinishIsNone adversary parameter + ftsSecret fuel] := by + calc + _ = Pr[fun hit : Bool => hit = true | DirectBoundaryOutcome.failed <$> + sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret fuel] := by + rw [probEvent_map] + rfl + _ = Pr[= true | DirectBoundaryOutcome.failed <$> + sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret fuel] := probEvent_eq_eq_probOutput _ true + _ = _ := OracleComp.probOutput_congr rfl + (evalDist_failed_sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary + parameter ftsSecret fuel) + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_ordinaryFailure_sampledGranularAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[= .ordinaryFailure | + sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret fuel] = + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret fuel] := by + rw [probEvent_ordinaryFailure_eq_map_ordinary] + exact OracleComp.probOutput_congr rfl + (evalDist_ordinary_sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary + parameter ftsSecret fuel) + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_privateStructuralFailure_sampledGranularAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[= .privateStructuralFailure | + sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret fuel] = + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret fuel] := by + rw [probEvent_privateStructuralFailure_eq_map_privateStructural] + exact OracleComp.probOutput_congr rfl + (evalDist_private_sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary + parameter ftsSecret fuel) + +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem probEvent_failed_sampledGranularAllDirectBoundaryDetailedRetainedOutcome_le_materialized_add_private + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (hparameter : parameter ∈ support sampleParameter) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun outcome => outcome.failed = true | + sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret q] ≤ + Pr[= true | + sampledMaterializedBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret q] + + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q] := by + calc + _ ≤ Pr[= .ordinaryFailure | + sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret q] + + Pr[= .privateStructuralFailure | + sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret q] := + probEvent_failed_le_ordinary_add_private + (sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret q) + _ = Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret q] + + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q] := by + rw [probEvent_ordinaryFailure_sampledGranularAllDirectBoundaryDetailedRetainedOutcome, + probEvent_privateStructuralFailure_sampledGranularAllDirectBoundaryDetailedRetainedOutcome] + _ ≤ _ := add_le_add + (probEvent_sampledGranularAllDirectBoundaryDetailedRetainedOrdinary_le_materialized + adversary parameter ftsSecret q hq hparameter hfts) le_rfl + +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem probEvent_failed_sampledGranularAllDirectBoundaryDetailedRetainedOutcome_le_canonical_add_private + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (hparameter : parameter ∈ support sampleParameter) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun outcome => outcome.failed = true | + sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret q] ≤ + Pr[= true | + sampledMaterializedCanonicalFailedRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q] := by + calc + _ ≤ Pr[= true | + sampledMaterializedBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret q] + + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q] := + probEvent_failed_sampledGranularAllDirectBoundaryDetailedRetainedOutcome_le_materialized_add_private + adversary parameter ftsSecret q hq hparameter hfts + _ ≤ _ := add_le_add + (probEvent_sampledMaterializedBoundaryDetailedRetainedOrdinary_le_canonicalFailed + adversary parameter ftsSecret q) le_rfl + +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem probEvent_failed_sampledGranularAllDirectBoundaryDetailedRetainedOutcome_le_three_endpoints + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (hparameter : parameter ∈ support sampleParameter) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun outcome => outcome.failed = true | + sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret q] ≤ + Pr[= true | + sampledMaterializedCanonicalOrdinaryRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledMaterializedCanonicalPrivateRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q] := by + have hfailed : + Pr[= true | + sampledMaterializedCanonicalFailedRetained adversary parameter ftsSecret q] = + Pr[fun outcome => outcome.failed = true | + sampledMaterializedCanonicalFullDetailedRetained adversary parameter + ftsSecret q] := by + calc + _ = Pr[= true | DirectBoundaryOutcome.failed <$> + sampledMaterializedCanonicalFullDetailedRetained adversary parameter + ftsSecret q] := + OracleComp.probOutput_congr rfl + (evalDist_failed_sampledMaterializedCanonicalFullDetailedRetained adversary parameter + ftsSecret q).symm + _ = Pr[fun hit : Bool => hit = true | DirectBoundaryOutcome.failed <$> + sampledMaterializedCanonicalFullDetailedRetained adversary parameter + ftsSecret q] := + (probEvent_eq_eq_probOutput _ true).symm + _ = _ := by + rw [probEvent_map] + rfl + calc + _ ≤ Pr[= true | + sampledMaterializedCanonicalFailedRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q] := + probEvent_failed_sampledGranularAllDirectBoundaryDetailedRetainedOutcome_le_canonical_add_private + adversary parameter ftsSecret q hq hparameter hfts + _ = Pr[fun outcome => outcome.failed = true | + sampledMaterializedCanonicalFullDetailedRetained adversary parameter + ftsSecret q] + + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q] := by + rw [hfailed] + _ ≤ _ := add_le_add + (probEvent_failed_sampledMaterializedCanonicalFullDetailedRetained_le adversary parameter + ftsSecret q) le_rfl + +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem probEvent_failed_sampledGranularAllDirectBoundaryDetailedRetainedOutcome_le_two_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) + (hparameter : parameter ∈ support sampleParameter) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (hmaterialized : + Pr[= true | + sampledMaterializedBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret q] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) + (hprivate : + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + Pr[fun outcome => outcome.failed = true | + sampledGranularAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret q] ≤ + ((2 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ ≤ Pr[= true | + sampledMaterializedBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret q] + + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q] := + probEvent_failed_sampledGranularAllDirectBoundaryDetailedRetainedOutcome_le_materialized_add_private + adversary parameter ftsSecret q hq hparameter hfts + _ ≤ (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + add_le_add hmaterialized hprivate + _ = _ := by + push_cast + ring + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_failed_sampledAllDirectBoundaryDetailedRetainedOutcome_le_four_mul_of_endpoints + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hdomination : + Pr[fun outcome => outcome.failed = true | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret q] ≤ + Pr[= true | + sampledFlatDetailedOrdinaryRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledMaterializedGuardedSafeOrdinaryRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledMaterializedCanonicalPrivateRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q]) + (hmaterializedPrivate : + Pr[= true | + sampledMaterializedCanonicalPrivateRetained adversary parameter ftsSecret q] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) + (hgranularPrivate : + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + Pr[fun outcome => outcome.failed = true | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret q] ≤ + ((4 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ ≤ Pr[= true | + sampledFlatDetailedOrdinaryRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledMaterializedGuardedSafeOrdinaryRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledMaterializedCanonicalPrivateRetained adversary parameter ftsSecret q] + + Pr[= true | + sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret q] := hdomination + _ ≤ ((2 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + exact add_le_add + (add_le_add + (probEvent_sampledFlat_add_materializedGuardedOrdinaryRetained_le_two_mul + adversary parameter ftsSecret q) + hmaterializedPrivate) + hgranularPrivate + _ = _ := by + push_cast + ring + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryOrdinaryRefinement.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryOrdinaryRefinement.lean new file mode 100644 index 00000000..be5dc580 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryOrdinaryRefinement.lean @@ -0,0 +1,4026 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryOrdinary + +/-! +# One-sided ordinary boundary refinement + +The canonical side can spend a probe at an unpublished structural value which the materialized +side can already read. A miss preserves finalization semantics while consuming one unit of fuel; +a hit is exactly the private structural outcome and imposes no ordinary-failure obligation. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem FinalizationViewEq.addPending_left_of_resolved + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewEq table left right) + (coordinate : Coordinate) (candidate : Digest) (output : HashOutput) + (hvalue : resolvedCompletionValue table left coordinate = some output) + (hmiss : truncateHash output ≠ candidate) : + FinalizationViewEq table + { left with state := left.state.addPending coordinate candidate } right := by + refine + { leftConsistent := hview.leftConsistent.addPending coordinate candidate + rightConsistent := hview.rightConsistent + leftStarts := hview.leftStarts.addPending coordinate candidate + rightStarts := hview.rightStarts + valueEq := hview.valueEq + leftClean := ?_ + rightClean := hview.rightClean + pendingEq := ?_ } + · intro other otherOutput hotherValue hhit + by_cases heq : other = coordinate + · subst other + have houtput : otherOutput = output := by + change resolvedCompletionValue table left coordinate = some otherOutput at hotherValue + rw [hvalue] at hotherValue + exact (Option.some.inj hotherValue).symm + subst otherOutput + rw [hitAt_addPending_self_iff] at hhit + exact hhit.elim (hview.leftClean coordinate output hvalue) hmiss + · have hhitBase : left.state.hitAt other otherOutput := by + rw [hitAt_addPending_of_ne left.state coordinate other candidate otherOutput (Ne.symm heq)] + at hhit + exact hhit + exact hview.leftClean other otherOutput hotherValue hhitBase + · intro other hnone + have hne : other ≠ coordinate := by + intro heq + subst other + change resolvedCompletionValue table left coordinate = none at hnone + rw [hvalue] at hnone + contradiction + calc + (left.state.addPending coordinate candidate).pendingAt other = + left.state.pendingAt other := by + ext digest + simp [LazyRevealProbe.State.pendingAt, LazyRevealProbe.State.addPending, hne] + _ = right.state.pendingAt other := hview.pendingEq other hnone + +theorem FinalizationContextEq.addPending_left_of_resolved + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextEq table (some left) (some right)) + (coordinate : Coordinate) (candidate : Digest) (output : HashOutput) + (hvalue : resolvedCompletionValue table left coordinate = some output) + (hmiss : truncateHash output ≠ candidate) : + FinalizationContextEq table + (some { left with state := left.state.addPending coordinate candidate }) + (some right) := by + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + obtain ⟨completion, hcompletion⟩ := hleftCompletable + have hcompletionOutput : completion coordinate = output := + hcompletion.eq_resolvedCompletionValue coordinate output hvalue + have hcompletion' : DeferredCompletion table + { left with state := left.state.addPending coordinate candidate } completion := + hcompletion.addPending_of_avoids coordinate candidate (by + rwa [hcompletionOutput]) + have hleftCompletable' : DeferredCompletable table + { left with state := left.state.addPending coordinate candidate } := + ⟨completion, hcompletion'⟩ + exact + ⟨hview.addPending_left_of_resolved coordinate candidate output hvalue hmiss, + hleftValid.addPending_of_completable coordinate candidate hleftCompletable', + hrightValid, hleftCompletable'⟩ + +structure FinalizationViewLE (table : OtsSecretIndex → HashOutput) + (left right : DeferredContext) : Prop where + leftConsistent : left.ValuesConsistent + rightConsistent : right.ValuesConsistent + leftStarts : StartTableAgrees left.state table + rightStarts : StartTableAgrees right.state table + valueEq : resolvedCompletionValue table left = resolvedCompletionValue table right + leftClean : ∀ coordinate output, + resolvedCompletionValue table left coordinate = some output → + ¬left.state.hitAt coordinate output + rightClean : ∀ coordinate output, + resolvedCompletionValue table right coordinate = some output → + ¬right.state.hitAt coordinate output + pendingLE : ∀ coordinate, + resolvedCompletionValue table left coordinate = none → + left.state.pendingAt coordinate ⊆ right.state.pendingAt coordinate + +theorem FinalizationViewLE.of_eq + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewEq table left right) : + FinalizationViewLE table left right where + leftConsistent := hview.leftConsistent + rightConsistent := hview.rightConsistent + leftStarts := hview.leftStarts + rightStarts := hview.rightStarts + valueEq := hview.valueEq + leftClean := hview.leftClean + rightClean := hview.rightClean + pendingLE coordinate hnone := by + rw [hview.pendingEq coordinate hnone] + +theorem FinalizationViewLE.refl + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hclean : ∀ coordinate output, + resolvedCompletionValue table context coordinate = some output → + ¬context.state.hitAt coordinate output) : + FinalizationViewLE table context context := + FinalizationViewLE.of_eq + (FinalizationViewEq.refl table context hvalid hstarts hclean) + +theorem FinalizationViewLE.trans + {table : OtsSecretIndex → HashOutput} {left middle right : DeferredContext} + (hleft : FinalizationViewLE table left middle) + (hright : FinalizationViewLE table middle right) : + FinalizationViewLE table left right := by + refine + { leftConsistent := hleft.leftConsistent + rightConsistent := hright.rightConsistent + leftStarts := hleft.leftStarts + rightStarts := hright.rightStarts + valueEq := hleft.valueEq.trans hright.valueEq + leftClean := hleft.leftClean + rightClean := hright.rightClean + pendingLE := ?_ } + intro coordinate hvalue candidate hcandidate + have hmiddleValue : resolvedCompletionValue table middle coordinate = none := by + rw [← hleft.valueEq] + exact hvalue + exact hright.pendingLE coordinate hmiddleValue + (hleft.pendingLE coordinate hvalue hcandidate) + +theorem FinalizationViewLE.deferredCompletion_left + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewLE table left right) + (completion : Coordinate → HashOutput) + (hcompletion : DeferredCompletion table right completion) : + DeferredCompletion table left completion := by + refine ⟨?_, ?_, ?_, hcompletion.2.2.2⟩ + · intro coordinate output hvalue + have hleftValue : resolvedCompletionValue table left coordinate = some output := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + have houtput := hview.leftStarts + ⟨lay, tree, leafIdx, chainIdx⟩ output hvalue + simp [resolvedCompletionValue, houtput] + | position position => + simp [resolvedCompletionValue, DeferredContext.positionValue, hvalue] + have hrightValue : resolvedCompletionValue table right coordinate = some output := by + rw [← hview.valueEq] + exact hleftValue + exact hcompletion.eq_resolvedCompletionValue coordinate output hrightValue + · intro position output hvalue + have hleftValue : resolvedCompletionValue table left (.position position) = + some output := by + unfold resolvedCompletionValue DeferredContext.positionValue + cases hstate : left.state.values (.position position) with + | some cached => + have hsame := hview.leftConsistent position cached hstate + rw [hsame] at hvalue + have hcached : cached = output := Option.some.inj hvalue + simp [hstate, hcached] + | none => simpa [hstate] using hvalue + have hrightValue : resolvedCompletionValue table right (.position position) = + some output := by + rw [← hview.valueEq] + exact hleftValue + exact hcompletion.eq_resolvedCompletionValue (.position position) output hrightValue + · intro coordinate candidate hmember + cases hvalue : resolvedCompletionValue table left coordinate with + | some output => + have hrightValue : resolvedCompletionValue table right coordinate = some output := by + rw [← hview.valueEq] + exact hvalue + have hcompletionOutput : completion coordinate = output := + hcompletion.eq_resolvedCompletionValue coordinate output hrightValue + intro hhit + apply hview.leftClean coordinate output hvalue + unfold LazyRevealProbe.State.hitAt + rw [LazyRevealProbe.State.mem_pendingAt_iff] + have hcandidate : candidate = truncateHash output := by + rw [← hhit, hcompletionOutput] + simpa [hcandidate] using hmember + | none => + have hrightValue : resolvedCompletionValue table right coordinate = none := by + rw [← hview.valueEq] + exact hvalue + have hleftPending : candidate ∈ left.state.pendingAt coordinate := + (LazyRevealProbe.State.mem_pendingAt_iff left.state coordinate candidate).2 hmember + have hrightPending : candidate ∈ right.state.pendingAt coordinate := + hview.pendingLE coordinate hvalue hleftPending + exact hcompletion.2.2.1 coordinate candidate + ((LazyRevealProbe.State.mem_pendingAt_iff right.state coordinate candidate).1 + hrightPending) + +structure FinalizationContextLE (table : OtsSecretIndex → HashOutput) + (left right : DeferredContext) : Prop where + view : FinalizationViewLE table left right + leftValid : left.Valid + rightValid : right.Valid + rightCompletable : DeferredCompletable table right + +theorem FinalizationContextLE.of_eq + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextEq table (some left) (some right)) : + FinalizationContextLE table left right := by + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + obtain ⟨completion, hcompletion⟩ := hleftCompletable + exact + { view := FinalizationViewLE.of_eq hview + leftValid := hleftValid + rightValid := hrightValid + rightCompletable := + ⟨completion, (hview.deferredCompletion_iff completion).mp hcompletion⟩ } + +theorem FinalizationContextLE.leftCompletable + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextLE table left right) : + DeferredCompletable table left := by + obtain ⟨completion, hcompletion⟩ := hcontext.rightCompletable + exact ⟨completion, hcontext.view.deferredCompletion_left completion hcompletion⟩ + +set_option maxRecDepth 100000 in +theorem FinalizationViewLE.completeStart + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewLE table left right) + (index : OtsSecretIndex) : + FinalizationViewLE table + (left.completeResolved index.coordinate (table index)) + (right.completeResolved index.coordinate (table index)) := by + have hleftState : (left.completeResolved index.coordinate (table index)).state = + left.state.complete index.coordinate (table index) := by + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + rfl + have hrightState : (right.completeResolved index.coordinate (table index)).state = + right.state.complete index.coordinate (table index) := by + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + rfl + refine ⟨hview.leftConsistent.completeResolved index.coordinate (table index), + hview.rightConsistent.completeResolved index.coordinate (table index), + ?_, ?_, ?_, ?_, ?_, ?_⟩ + · rw [hleftState] + exact hview.leftStarts.complete_start index + · rw [hrightState] + exact hview.rightStarts.complete_start index + · funext other + by_cases heq : other = index.coordinate + · subst other + simp + · rw [resolvedCompletionValue_completeResolved_of_ne table left index.coordinate other + (table index) heq, + resolvedCompletionValue_completeResolved_of_ne table right index.coordinate other + (table index) heq, + hview.valueEq] + · intro other otherOutput hvalue + by_cases heq : other = index.coordinate + · subst other + have houtput : otherOutput = table index := by + simpa using hvalue.symm + subst otherOutput + rw [hleftState] + exact not_hitAt_complete_self left.state index.coordinate (table index) + · have horiginal : resolvedCompletionValue table left other = some otherOutput := by + rw [← resolvedCompletionValue_completeResolved_of_ne table left index.coordinate other + (table index) heq] + exact hvalue + have hclean := hview.leftClean other otherOutput horiginal + rw [hleftState] + exact (hitAt_complete_of_ne left.state index.coordinate other (table index) otherOutput + heq).not.mpr hclean + · intro other otherOutput hvalue + by_cases heq : other = index.coordinate + · subst other + have houtput : otherOutput = table index := by + simpa using hvalue.symm + subst otherOutput + rw [hrightState] + exact not_hitAt_complete_self right.state index.coordinate (table index) + · have horiginal : resolvedCompletionValue table right other = some otherOutput := by + rw [← resolvedCompletionValue_completeResolved_of_ne table right index.coordinate other + (table index) heq] + exact hvalue + have hclean := hview.rightClean other otherOutput horiginal + rw [hrightState] + exact (hitAt_complete_of_ne right.state index.coordinate other (table index) otherOutput + heq).not.mpr hclean + · intro other hvalue + have hne : other ≠ index.coordinate := by + intro heq + subst other + simp at hvalue + have horiginal : resolvedCompletionValue table left other = none := by + rw [← resolvedCompletionValue_completeResolved_of_ne table left index.coordinate other + (table index) hne] + exact hvalue + have hpending := hview.pendingLE other horiginal + rw [hleftState, hrightState] + rw [pendingAt_complete_of_ne left.state index.coordinate other (table index) hne, + pendingAt_complete_of_ne right.state index.coordinate other (table index) hne] + exact hpending + +set_option maxRecDepth 100000 in +theorem FinalizationViewLE.completePosition + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewLE table left right) + (position : Position) (output : HashOutput) : + FinalizationViewLE table + (left.completeResolved (.position position) output) + (right.completeResolved (.position position) output) := by + have hleftState : (left.completeResolved (.position position) output).state = + left.state.complete (.position position) output := rfl + have hrightState : (right.completeResolved (.position position) output).state = + right.state.complete (.position position) output := rfl + refine ⟨hview.leftConsistent.completeResolved (.position position) output, + hview.rightConsistent.completeResolved (.position position) output, + hview.leftStarts.complete_position position output, + hview.rightStarts.complete_position position output, ?_, ?_, ?_, ?_⟩ + · funext other + by_cases heq : other = .position position + · subst other + simp + · rw [resolvedCompletionValue_completeResolved_of_ne table left (.position position) + other output heq, + resolvedCompletionValue_completeResolved_of_ne table right (.position position) + other output heq, + hview.valueEq] + · intro other otherOutput hvalue + by_cases heq : other = .position position + · subst other + have houtput : otherOutput = output := by simpa using hvalue.symm + subst otherOutput + rw [hleftState] + exact not_hitAt_complete_self left.state (.position position) output + · have horiginal : resolvedCompletionValue table left other = some otherOutput := by + rw [← resolvedCompletionValue_completeResolved_of_ne table left (.position position) + other output heq] + exact hvalue + have hclean := hview.leftClean other otherOutput horiginal + rw [hleftState] + exact (hitAt_complete_of_ne left.state (.position position) other output otherOutput + heq).not.mpr hclean + · intro other otherOutput hvalue + by_cases heq : other = .position position + · subst other + have houtput : otherOutput = output := by simpa using hvalue.symm + subst otherOutput + rw [hrightState] + exact not_hitAt_complete_self right.state (.position position) output + · have horiginal : resolvedCompletionValue table right other = some otherOutput := by + rw [← resolvedCompletionValue_completeResolved_of_ne table right (.position position) + other output heq] + exact hvalue + have hclean := hview.rightClean other otherOutput horiginal + rw [hrightState] + exact (hitAt_complete_of_ne right.state (.position position) other output otherOutput + heq).not.mpr hclean + · intro other hvalue + have hne : other ≠ .position position := by + intro heq + subst other + simp at hvalue + have horiginal : resolvedCompletionValue table left other = none := by + rw [← resolvedCompletionValue_completeResolved_of_ne table left (.position position) + other output hne] + exact hvalue + have hpending := hview.pendingLE other horiginal + rw [hleftState, hrightState] + rw [pendingAt_complete_of_ne left.state (.position position) other output hne, + pendingAt_complete_of_ne right.state (.position position) other output hne] + exact hpending + +theorem FinalizationViewLE.not_rightCompletable_of_not_leftCompletable + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewLE table left right) + (hleft : ¬DeferredCompletable table left) : + ¬DeferredCompletable table right := by + rintro ⟨completion, hcompletion⟩ + exact hleft ⟨completion, hview.deferredCompletion_left completion hcompletion⟩ + +theorem FinalizationViewLE.addPending_right_of_completable + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewLE table left right) (coordinate : Coordinate) + (candidate : Digest) + (hcompletable : DeferredCompletable table + { right with state := right.state.addPending coordinate candidate }) : + FinalizationViewLE table left + { right with state := right.state.addPending coordinate candidate } := by + refine + { leftConsistent := hview.leftConsistent + rightConsistent := hview.rightConsistent.addPending coordinate candidate + leftStarts := hview.leftStarts + rightStarts := hview.rightStarts.addPending coordinate candidate + valueEq := hview.valueEq + leftClean := hview.leftClean + rightClean := ?_ + pendingLE := ?_ } + · intro other output hvalue hhit + obtain ⟨completion, hcompletion⟩ := hcompletable + have houtput := hcompletion.eq_resolvedCompletionValue other output hvalue + have havoids := hcompletion.2.2.1 + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + exact havoids other (truncateHash output) hhit (by rw [houtput]) + · intro other hvalue digest hdigest + have hbase := hview.pendingLE other hvalue hdigest + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hbase ⊢ + simp only [LazyRevealProbe.State.addPending, Finset.mem_insert] + exact Or.inr hbase + +theorem FinalizationContextLE.addPending_right_of_completable + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextLE table left right) + (coordinate : Coordinate) (candidate : Digest) + (hcompletable : DeferredCompletable table + { right with state := right.state.addPending coordinate candidate }) : + FinalizationContextLE table left + { right with state := right.state.addPending coordinate candidate } where + view := hcontext.view.addPending_right_of_completable coordinate candidate hcompletable + leftValid := hcontext.leftValid + rightValid := hcontext.rightValid.addPending_of_completable + coordinate candidate hcompletable + rightCompletable := hcompletable + +theorem FinalizationViewLE.addPending_left_of_resolved + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewLE table left right) + (coordinate : Coordinate) (candidate : Digest) (output : HashOutput) + (hvalue : resolvedCompletionValue table left coordinate = some output) + (hmiss : truncateHash output ≠ candidate) : + FinalizationViewLE table + { left with state := left.state.addPending coordinate candidate } right := by + refine + { leftConsistent := hview.leftConsistent.addPending coordinate candidate + rightConsistent := hview.rightConsistent + leftStarts := hview.leftStarts.addPending coordinate candidate + rightStarts := hview.rightStarts + valueEq := hview.valueEq + leftClean := ?_ + rightClean := hview.rightClean + pendingLE := ?_ } + · intro other otherOutput hotherValue hhit + by_cases heq : other = coordinate + · subst other + have houtput : otherOutput = output := by + change resolvedCompletionValue table left coordinate = some otherOutput at hotherValue + rw [hvalue] at hotherValue + exact (Option.some.inj hotherValue).symm + subst otherOutput + rw [hitAt_addPending_self_iff] at hhit + exact hhit.elim (hview.leftClean coordinate output hvalue) hmiss + · have hhitBase : left.state.hitAt other otherOutput := by + rw [hitAt_addPending_of_ne left.state coordinate other candidate otherOutput + (Ne.symm heq)] at hhit + exact hhit + exact hview.leftClean other otherOutput hotherValue hhitBase + · intro other hnone digest hdigest + have hne : other ≠ coordinate := by + intro heq + subst other + change resolvedCompletionValue table left coordinate = none at hnone + rw [hvalue] at hnone + contradiction + have hbase : digest ∈ left.state.pendingAt other := by + have hpending : + (left.state.addPending coordinate candidate).pendingAt other = + left.state.pendingAt other := by + ext otherCandidate + simp [LazyRevealProbe.State.pendingAt, LazyRevealProbe.State.addPending, hne] + rw [← hpending] + exact hdigest + exact hview.pendingLE other hnone hbase + +theorem FinalizationContextLE.addPending_left_of_resolved + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextLE table left right) + (coordinate : Coordinate) (candidate : Digest) (output : HashOutput) + (hvalue : resolvedCompletionValue table left coordinate = some output) + (hmiss : truncateHash output ≠ candidate) : + FinalizationContextLE table + { left with state := left.state.addPending coordinate candidate } right := by + obtain ⟨completion, hcompletion⟩ := hcontext.leftCompletable + have hcompletionOutput : completion coordinate = output := + hcompletion.eq_resolvedCompletionValue coordinate output hvalue + have hcompletion' : DeferredCompletion table + { left with state := left.state.addPending coordinate candidate } completion := + hcompletion.addPending_of_avoids coordinate candidate (by + rwa [hcompletionOutput]) + exact + { view := hcontext.view.addPending_left_of_resolved + coordinate candidate output hvalue hmiss + leftValid := hcontext.leftValid.addPending_of_completable coordinate candidate + ⟨completion, hcompletion'⟩ + rightValid := hcontext.rightValid + rightCompletable := hcontext.rightCompletable } + +theorem FinalizationViewLE.addPending_both_of_right_completable + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewLE table left right) + (coordinate : Coordinate) (candidate : Digest) + (hrightCompletable : DeferredCompletable table + { right with state := right.state.addPending coordinate candidate }) : + FinalizationViewLE table + { left with state := left.state.addPending coordinate candidate } + { right with state := right.state.addPending coordinate candidate } := by + obtain ⟨completion, hrightCompletion⟩ := hrightCompletable + have hrightBase := hrightCompletion.of_addPending coordinate candidate + have hleftBase := hview.deferredCompletion_left completion hrightBase + have havoids := hrightCompletion.2.2.1 coordinate candidate (by + simp [LazyRevealProbe.State.addPending]) + have hleftCompletion := + hleftBase.addPending_of_avoids coordinate candidate havoids + refine + { leftConsistent := hview.leftConsistent.addPending coordinate candidate + rightConsistent := hview.rightConsistent.addPending coordinate candidate + leftStarts := hview.leftStarts.addPending coordinate candidate + rightStarts := hview.rightStarts.addPending coordinate candidate + valueEq := hview.valueEq + leftClean := ?_ + rightClean := ?_ + pendingLE := ?_ } + · intro other output hvalue hhit + have houtput := hleftCompletion.eq_resolvedCompletionValue other output hvalue + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + exact hleftCompletion.2.2.1 other (truncateHash output) hhit (by rw [houtput]) + · intro other output hvalue hhit + have houtput := hrightCompletion.eq_resolvedCompletionValue other output hvalue + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + exact hrightCompletion.2.2.1 other (truncateHash output) hhit (by rw [houtput]) + · intro other hvalue digest hdigest + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hdigest ⊢ + simp only [LazyRevealProbe.State.addPending, Finset.mem_insert] at hdigest ⊢ + rcases hdigest with hnew | hold + · exact Or.inl hnew + · right + rw [← LazyRevealProbe.State.mem_pendingAt_iff] at hold ⊢ + exact hview.pendingLE other hvalue hold + +theorem FinalizationContextLE.addPending_both_of_right_completable + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextLE table left right) + (coordinate : Coordinate) (candidate : Digest) + (hrightCompletable : DeferredCompletable table + { right with state := right.state.addPending coordinate candidate }) : + FinalizationContextLE table + { left with state := left.state.addPending coordinate candidate } + { right with state := right.state.addPending coordinate candidate } := by + have hview := hcontext.view.addPending_both_of_right_completable + coordinate candidate hrightCompletable + have hleftCompletable : DeferredCompletable table + { left with state := left.state.addPending coordinate candidate } := by + obtain ⟨completion, hcompletion⟩ := hrightCompletable + exact ⟨completion, hview.deferredCompletion_left completion hcompletion⟩ + exact + { view := hview + leftValid := hcontext.leftValid.addPending_of_completable coordinate candidate + hleftCompletable + rightValid := hcontext.rightValid.addPending_of_completable coordinate candidate + hrightCompletable + rightCompletable := hrightCompletable } + +theorem FinalizationViewLE.privateValue_of_left_hidden_of_right_materialized + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewLE table left right) (position : Position) + (output : HashOutput) + (hleft : left.state.values (.position position) = none) + (hright : right.state.values (.position position) = some output) : + left.values position = some output := by + have hposition : left.positionValue position = some output := by + change resolvedCompletionValue table left (.position position) = some output + rw [hview.valueEq] + simp [resolvedCompletionValue, DeferredContext.positionValue, hright] + simpa [DeferredContext.positionValue, hleft] using hposition + +set_option maxRecDepth 100000 in +theorem FinalizationViewLE.materialize_position_left + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewLE table left right) (position : Position) + (output : HashOutput) + (hhidden : left.state.values (.position position) = none) + (hprivate : left.values position = some output) : + FinalizationViewLE table + { left with state := left.state.materialize (.position position) output } right := by + let materialized : DeferredContext := + { left with state := left.state.materialize (.position position) output } + have hresolved : resolvedCompletionValue table materialized = + resolvedCompletionValue table left := by + funext coordinate + cases coordinate with + | chainStart => rfl + | position other => + by_cases heq : other = position + · subst other + simp [materialized, resolvedCompletionValue, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, hhidden, hprivate] + · simp [materialized, resolvedCompletionValue, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by simpa using heq] + refine + { leftConsistent := ?_ + rightConsistent := hview.rightConsistent + leftStarts := hview.leftStarts.materialize_position position output + rightStarts := hview.rightStarts + valueEq := hresolved.trans hview.valueEq + leftClean := ?_ + rightClean := hview.rightClean + pendingLE := ?_ } + · intro other cached hvalue + by_cases heq : other = position + · subst other + have hsame : cached = output := by + simpa [materialized, LazyRevealProbe.State.materialize] using hvalue.symm + subst cached + exact hprivate + · apply hview.leftConsistent other cached + simpa [materialized, LazyRevealProbe.State.materialize, Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by simpa using heq] + using hvalue + · intro coordinate otherOutput hvalue + have horiginal : resolvedCompletionValue table left coordinate = some otherOutput := by + rw [← hresolved] + exact hvalue + by_cases heq : coordinate = .position position + · subst coordinate + change ¬(left.state.clearPending (.position position)).hitAt + (.position position) otherOutput + exact not_hitAt_clearPending_self left.state (.position position) otherOutput + · change ¬(left.state.clearPending (.position position)).hitAt coordinate otherOutput + exact (hitAt_clearPending_of_ne left.state (.position position) coordinate + otherOutput heq).not.mpr (hview.leftClean coordinate otherOutput horiginal) + · intro coordinate hvalue candidate hcandidate + have horiginal : resolvedCompletionValue table left coordinate = none := by + rw [← hresolved] + exact hvalue + have hbase : candidate ∈ left.state.pendingAt coordinate := by + by_cases heq : coordinate = .position position + · subst coordinate + change resolvedCompletionValue table materialized (.position position) = none at hvalue + simp [materialized, resolvedCompletionValue, DeferredContext.positionValue, + LazyRevealProbe.State.materialize] at hvalue + · change candidate ∈ + (left.state.clearPending (.position position)).pendingAt coordinate at hcandidate + rw [pendingAt_clearPending_of_ne left.state (.position position) coordinate heq] + at hcandidate + exact hcandidate + exact hview.pendingLE coordinate horiginal hbase + +theorem FinalizationContextLE.materialize_position_left + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextLE table left right) (position : Position) + (output : HashOutput) + (hhidden : left.state.values (.position position) = none) + (hprivate : left.values position = some output) : + FinalizationContextLE table + { left with state := left.state.materialize (.position position) output } right where + view := hcontext.view.materialize_position_left position output hhidden hprivate + leftValid := hcontext.leftValid.materialize_position position output hprivate + rightValid := hcontext.rightValid + rightCompletable := hcontext.rightCompletable + +theorem FinalizationViewLE.leftValid_of_view + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewLE table left right) : left.Valid := by + refine ⟨hview.leftConsistent, ?_⟩ + intro coordinate output hvalue + apply hview.leftClean coordinate output + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + have hsame := hview.leftStarts ⟨lay, tree, leafIdx, chainIdx⟩ output hvalue + simp [resolvedCompletionValue, hsame] + | position position => + simp [resolvedCompletionValue, DeferredContext.positionValue, hvalue] + +theorem FinalizationViewLE.rightValid_of_view + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewLE table left right) : right.Valid := by + refine ⟨hview.rightConsistent, ?_⟩ + intro coordinate output hvalue + apply hview.rightClean coordinate output + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + have hsame := hview.rightStarts ⟨lay, tree, leafIdx, chainIdx⟩ output hvalue + simp [resolvedCompletionValue, hsame] + | position position => + simp [resolvedCompletionValue, DeferredContext.positionValue, hvalue] + +set_option maxRecDepth 100000 in +theorem FinalizationViewLE.materialize_position_both + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewLE table left right) (position : Position) + (output : HashOutput) : + FinalizationViewLE table + { state := left.state.materialize (.position position) output + values := left.values.install position output } + { state := right.state.materialize (.position position) output + values := right.values.install position output } := by + let leftMaterialized : DeferredContext := + { state := left.state.materialize (.position position) output + values := left.values.install position output } + let rightMaterialized : DeferredContext := + { state := right.state.materialize (.position position) output + values := right.values.install position output } + refine + { leftConsistent := ?_ + rightConsistent := ?_ + leftStarts := hview.leftStarts.materialize_position position output + rightStarts := hview.rightStarts.materialize_position position output + valueEq := ?_ + leftClean := ?_ + rightClean := ?_ + pendingLE := ?_ } + · intro other cached hvalue + by_cases heq : other = position + · subst other + have hsame : cached = output := by + simpa [leftMaterialized, LazyRevealProbe.State.materialize] using hvalue.symm + subst cached + simp [DeferredStructuralValues.install] + · have hold := hview.leftConsistent other cached (by + simpa [leftMaterialized, LazyRevealProbe.State.materialize, Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by simpa using heq, + DeferredStructuralValues.install, heq] using hvalue) + simpa [leftMaterialized, DeferredStructuralValues.install, heq] using hold + · intro other cached hvalue + by_cases heq : other = position + · subst other + have hsame : cached = output := by + simpa [rightMaterialized, LazyRevealProbe.State.materialize] using hvalue.symm + subst cached + simp [DeferredStructuralValues.install] + · have hold := hview.rightConsistent other cached (by + simpa [rightMaterialized, LazyRevealProbe.State.materialize, Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by simpa using heq, + DeferredStructuralValues.install, heq] using hvalue) + simpa [rightMaterialized, DeferredStructuralValues.install, heq] using hold + · funext coordinate + cases coordinate with + | chainStart => rfl + | position other => + by_cases heq : other = position + · subst other + simp [resolvedCompletionValue, DeferredContext.positionValue, + LazyRevealProbe.State.materialize] + · simpa [leftMaterialized, rightMaterialized, resolvedCompletionValue, + DeferredContext.positionValue, LazyRevealProbe.State.materialize, + Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by simpa using heq, + DeferredStructuralValues.install, heq] using congrFun hview.valueEq (.position other) + · intro coordinate otherOutput hvalue + by_cases heq : coordinate = .position position + · subst coordinate + change ¬(left.state.clearPending (.position position)).hitAt + (.position position) otherOutput + exact not_hitAt_clearPending_self left.state (.position position) otherOutput + · have horiginal : resolvedCompletionValue table left coordinate = some otherOutput := by + cases coordinate with + | chainStart => exact hvalue + | position other => + have hother : other ≠ position := by simpa using heq + simpa [leftMaterialized, resolvedCompletionValue, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by + simpa using hother, + DeferredStructuralValues.install, hother] using hvalue + change ¬(left.state.clearPending (.position position)).hitAt coordinate otherOutput + exact (hitAt_clearPending_of_ne left.state (.position position) coordinate + otherOutput heq).not.mpr (hview.leftClean coordinate otherOutput horiginal) + · intro coordinate otherOutput hvalue + by_cases heq : coordinate = .position position + · subst coordinate + change ¬(right.state.clearPending (.position position)).hitAt + (.position position) otherOutput + exact not_hitAt_clearPending_self right.state (.position position) otherOutput + · have horiginal : resolvedCompletionValue table right coordinate = some otherOutput := by + cases coordinate with + | chainStart => exact hvalue + | position other => + have hother : other ≠ position := by simpa using heq + simpa [rightMaterialized, resolvedCompletionValue, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by + simpa using hother, + DeferredStructuralValues.install, hother] using hvalue + change ¬(right.state.clearPending (.position position)).hitAt coordinate otherOutput + exact (hitAt_clearPending_of_ne right.state (.position position) coordinate + otherOutput heq).not.mpr (hview.rightClean coordinate otherOutput horiginal) + · intro coordinate hvalue candidate hcandidate + have hne : coordinate ≠ .position position := by + intro heq + subst coordinate + change resolvedCompletionValue table leftMaterialized (.position position) = none at hvalue + simp [leftMaterialized, resolvedCompletionValue, DeferredContext.positionValue, + LazyRevealProbe.State.materialize] at hvalue + have horiginal : resolvedCompletionValue table left coordinate = none := by + cases coordinate with + | chainStart => exact hvalue + | position other => + have hother : other ≠ position := by simpa using hne + simpa [leftMaterialized, resolvedCompletionValue, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by + simpa using hother, + DeferredStructuralValues.install, hother] using hvalue + have hbase : candidate ∈ left.state.pendingAt coordinate := by + change candidate ∈ + (left.state.clearPending (.position position)).pendingAt coordinate at hcandidate + rw [pendingAt_clearPending_of_ne left.state (.position position) coordinate hne] + at hcandidate + exact hcandidate + have hrightBase := hview.pendingLE coordinate horiginal hbase + change candidate ∈ + (right.state.clearPending (.position position)).pendingAt coordinate + rw [pendingAt_clearPending_of_ne right.state (.position position) coordinate hne] + exact hrightBase + +set_option maxRecDepth 100000 in +theorem FinalizationContextLE.materialize_position_both + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextLE table left right) (position : Position) + (output : HashOutput) : + FinalizationContextLE table + { state := left.state.materialize (.position position) output + values := left.values.install position output } + { state := right.state.materialize (.position position) output + values := right.values.install position output } := by + let leftMaterialized : DeferredContext := + { state := left.state.materialize (.position position) output + values := left.values.install position output } + let rightMaterialized : DeferredContext := + { state := right.state.materialize (.position position) output + values := right.values.install position output } + have hview := hcontext.view.materialize_position_both position output + obtain ⟨completion, hcompletion⟩ := hcontext.rightCompletable + let nextCompletion : Coordinate → HashOutput := + Function.update completion (.position position) output + have hnextCompletion : DeferredCompletion table rightMaterialized nextCompletion := by + refine ⟨?_, ?_, ?_, ?_⟩ + · intro coordinate cached hvalue + by_cases heq : coordinate = .position position + · subst coordinate + have hsame : cached = output := by + simpa [rightMaterialized, LazyRevealProbe.State.materialize] using hvalue.symm + simp [nextCompletion, hsame] + · have hold := hcompletion.1 coordinate cached (by + simpa [rightMaterialized, LazyRevealProbe.State.materialize, + Function.update_of_ne heq] using hvalue) + simpa [nextCompletion, Function.update_of_ne, heq] using hold + · intro other cached hvalue + by_cases heq : other = position + · subst other + have hsame : cached = output := by + simpa [rightMaterialized, DeferredStructuralValues.install] using hvalue.symm + simp [nextCompletion, hsame] + · have hold := hcompletion.2.1 other cached (by + simpa [rightMaterialized, DeferredStructuralValues.install, heq] using hvalue) + simpa [nextCompletion, Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by simpa using heq] + using hold + · intro coordinate candidate hmember + have hparts : (coordinate, candidate) ∈ right.state.pending ∧ + coordinate ≠ .position position := by + change (coordinate, candidate) ∈ + right.state.pendingAway (.position position) at hmember + simpa [LazyRevealProbe.State.pendingAway] using hmember + simpa [nextCompletion, Function.update_of_ne, hparts.2] using + hcompletion.2.2.1 coordinate candidate hparts.1 + · intro index + simpa [nextCompletion, Function.update_of_ne, + show index.coordinate ≠ Coordinate.position position by + simp [OtsSecretIndex.coordinate]] using hcompletion.2.2.2 index + exact + { view := hview + leftValid := hview.leftValid_of_view + rightValid := hview.rightValid_of_view + rightCompletable := ⟨nextCompletion, hnextCompletion⟩ } + +theorem LazyRevealProbe.ValuesLE.materialize_both + {left right : LazyRevealProbe.State Coordinate} + (hvalues : LazyRevealProbe.ValuesLE left right) + (coordinate : Coordinate) (output : HashOutput) : + LazyRevealProbe.ValuesLE (left.materialize coordinate output) + (right.materialize coordinate output) := by + intro other cached hvalue + by_cases heq : other = coordinate + · subst other + have hsame : cached = output := by + simpa [LazyRevealProbe.State.materialize] using hvalue.symm + simp [LazyRevealProbe.State.materialize, hsame] + · have hbase : left.values other = some cached := by + simpa [LazyRevealProbe.State.materialize, Function.update_of_ne heq] using hvalue + simpa [LazyRevealProbe.State.materialize, Function.update_of_ne heq] using + hvalues other cached hbase + +theorem LazyRevealProbe.ValuesLE.materialize_left + {left right : LazyRevealProbe.State Coordinate} + (hvalues : LazyRevealProbe.ValuesLE left right) + (coordinate : Coordinate) (output : HashOutput) + (hright : right.values coordinate = some output) : + LazyRevealProbe.ValuesLE (left.materialize coordinate output) right := by + intro other cached hvalue + by_cases heq : other = coordinate + · subst other + have hsame : cached = output := by + simpa [LazyRevealProbe.State.materialize] using hvalue.symm + simpa [hsame] using hright + · apply hvalues other cached + simpa [LazyRevealProbe.State.materialize, Function.update_of_ne heq] using hvalue + +theorem FinalizationViewLE.publish + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewLE table left right) (coordinate : Coordinate) : + FinalizationViewLE table + { left with state := left.state.publish coordinate } + { right with state := right.state.publish coordinate } where + leftConsistent := hview.leftConsistent.publish coordinate + rightConsistent := hview.rightConsistent.publish coordinate + leftStarts := hview.leftStarts + rightStarts := hview.rightStarts + valueEq := hview.valueEq + leftClean := hview.leftClean + rightClean := hview.rightClean + pendingLE := hview.pendingLE + +theorem FinalizationContextLE.publish + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextLE table left right) (coordinate : Coordinate) : + FinalizationContextLE table + { left with state := left.state.publish coordinate } + { right with state := right.state.publish coordinate } where + view := hcontext.view.publish coordinate + leftValid := hcontext.leftValid.publish coordinate + rightValid := hcontext.rightValid.publish coordinate + rightCompletable := hcontext.rightCompletable.publish coordinate + +theorem PublishedValues.publish_of_value + {state : LazyRevealProbe.State Coordinate} (hpublished : PublishedValues state) + (coordinate : Coordinate) (output : HashOutput) + (hvalue : state.values coordinate = some output) : + PublishedValues (state.publish coordinate) := by + intro other hrevealed + simp only [LazyRevealProbe.State.publish, Finset.mem_insert] at hrevealed + rcases hrevealed with heq | hold + · subst other + simp [hvalue] + · exact hpublished other hold + +structure OrdinaryMaterializedRunEq (table : OtsSecretIndex → HashOutput) + (left right : ResolvedRunResult (α × SplitHashCache)) : Prop where + value_eq : left.value.1 = right.value.1 + context_le : FinalizationContextLE table left.context right.context + remaining_le : left.remaining ≤ right.remaining + left_table : left.table = table + right_table : right.table = table + cache_eq : ordinaryQueryCache left.value.2 = ordinaryQueryCache right.value.2 + revealed_eq : left.context.state.revealed = right.context.state.revealed + values_le : LazyRevealProbe.ValuesLE left.context.state right.context.state + left_published : PublishedValues left.context.state + right_materialized : + right.context = directDeferredContext right.context.state + +def OrdinaryMaterializedDoomedRun (table : OtsSecretIndex → HashOutput) + (result : ResolvedRunResult α) : Prop := + FinalizationDoomedRun table (some result) ∧ + result.context = directDeferredContext result.context.state + +def DirectDetailedOrdinaryRunEq (table : OtsSecretIndex → HashOutput) : + DirectDetailedResult (α × SplitHashCache) → + DirectDetailedResult (α × SplitHashCache) → Prop + | .stopped .privateStructuralHit, _ => True + | .stopped .ordinaryHit, .stopped .privateStructuralHit => False + | .stopped .ordinaryHit, .stopped _ => True + | .stopped .ordinaryHit, .done right => + OrdinaryMaterializedDoomedRun table right + | .stopped .fuelExhausted, .stopped .ordinaryHit => True + | .stopped .fuelExhausted, .stopped .fuelExhausted => True + | .stopped .fuelExhausted, .done right => + OrdinaryMaterializedDoomedRun table right + | .stopped .fuelExhausted, _ => False + | .done _, .stopped .privateStructuralHit => False + | .done _, .stopped _ => True + | .done left, .done right => + OrdinaryMaterializedRunEq table left right ∨ + PrivateStructuralHit left.context ∨ + OrdinaryMaterializedDoomedRun table right + +def DirectDetailedMaterialized : DirectDetailedResult α → Prop + | .stopped .privateStructuralHit => False + | .stopped _ => True + | .done result => + result.context = directDeferredContext result.context.state + +set_option maxRecDepth 100000 in +theorem directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : DirectDetailedResult α) + (hresult : result ∈ support + (runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table computation)) : + DirectDetailedMaterialized result := by + induction computation using OracleComp.inductionOn generalizing state fuel result with + | pure value => + simp [runDirectResolvedDetailedFromTable] at hresult + subst result + rfl + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectResolvedDetailedFromTable_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output state fuel result hrest + | hashOutput => + rw [runDirectResolvedDetailedFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output state fuel result hrest + | ensure coordinate => + rw [runDirectResolvedDetailedFromTable_ensure_query_bind] at hresult + have hcontext : + { directDeferredContext state with state := state.ensure coordinate } = + directDeferredContext (state.ensure coordinate) := by + simp [directDeferredContext, directDeferredValues_ensure] + exact ih () (state.ensure coordinate) fuel result (hcontext ▸ hresult) + | probe coordinate candidate => + rw [runDirectResolvedDetailedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => + simp at hresult + subst result + trivial + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · exact ih () state remaining result (by + simpa [directDeferredContext, hrevealed] using hresult) + · simp only [directDeferredContext, hrevealed, ↓reduceIte] at hresult + have hcontext : + { directDeferredContext state with + state := state.addPending coordinate candidate } = + directDeferredContext (state.addPending coordinate candidate) := by + simp [directDeferredContext, directDeferredValues_addPending] + exact ih () (state.addPending coordinate candidate) remaining result + (hcontext ▸ hresult) + | peek coordinate => + rw [runDirectResolvedDetailedFromTable_peek_query_bind] at hresult + exact ih (state.values coordinate) state fuel result hresult + | publish coordinate => + rw [runDirectResolvedDetailedFromTable_publish_query_bind] at hresult + exact ih () (state.publish coordinate) fuel result (by + simpa [directDeferredContext, directDeferredValues_publish] using hresult) + | reveal coordinate => + rw [runDirectResolvedDetailedFromTable_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + exact ih output state fuel result (by + simpa only [directDeferredContext, hvalue] using hresult) + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + let output := table index + by_cases hhit : state.hitAt index.coordinate output + · change state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) at hhit + simp only [directDeferredContext, hvalue, hhit, ↓reduceIte] at hresult + simp at hresult + subst result + trivial + · have hcontext : + { state := state.materialize index.coordinate output + values := directDeferredValues state } = + directDeferredContext + (state.materialize index.coordinate output) := by + simp [directDeferredContext, + directDeferredValues_materialize_chainStart] + change ¬state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) at hhit + simp only [directDeferredContext, hvalue, hhit, ↓reduceIte] at hresult + exact ih output (state.materialize index.coordinate output) fuel result + (hcontext ▸ hresult) + | position position => + simp only [directDeferredContext, directDeferredValues, hvalue, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : state.hitAt (.position position) output + · simp [hhit] at hrest + subst result + trivial + · simp only [hhit, ↓reduceIte] at hrest + have hcontext : + { state := state.materialize (.position position) output + values := (directDeferredValues state).install position output } = + directDeferredContext + (state.materialize (.position position) output) := by + simp [directDeferredContext, + directDeferredValues_materialize_position] + exact ih output (state.materialize (.position position) output) fuel result + (hcontext ▸ hrest) + +theorem finalizationDoomedRun_of_mem_runDirectResolvedDetailedFromTable + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (result : ResolvedRunResult α) + (hdoomed : DoomedResolvedContext table context) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation)) : + FinalizationDoomedRun table (some result) := by + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + computation context fuel table result hresult + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable computation context fuel table + result hdoomed.1 hdoomed.2.1 hdirect + exact ⟨hcore.1, hcore.2.1, hcore.2.2, + not_deferredCompletable_of_mem_runDirectResolvedFromTable computation context fuel table + result hdoomed.1 hdoomed.2.1 hdirect hdoomed.2.2⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_of_right_materializedDoomed + (table : OtsSecretIndex → HashOutput) + (leftRun : ProbComp (DirectDetailedResult (α × SplitHashCache))) + (rightComputation : + OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (right : DeferredContext) (rightFuel : Nat) + (hrightDoomed : DoomedResolvedContext table right) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + leftRun + (runDirectResolvedDetailedFromTable right rightFuel table rightComputation) + (DirectDetailedOrdinaryRunEq table) := by + have hbase := relTriple_true + leftRun + (runDirectResolvedDetailedFromTable right rightFuel table rightComputation) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support leftRun) + (fun result hresult => hresult) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro leftResult rightResult hrelation + have hrightShape : DirectDetailedMaterialized rightResult := by + have hsupport := hrelation.2 + rw [hrightMaterialized] at hsupport + exact directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + rightComputation right.state rightFuel table rightResult hsupport + cases rightResult with + | stopped reason => + cases reason with + | privateStructuralHit => exact False.elim hrightShape + | ordinaryHit => + cases leftResult with + | stopped leftReason => cases leftReason <;> trivial + | done _ => trivial + | fuelExhausted => + cases leftResult with + | stopped leftReason => cases leftReason <;> trivial + | done _ => trivial + | done rightResult => + have hdoomed := + finalizationDoomedRun_of_mem_runDirectResolvedDetailedFromTable table + rightComputation right rightFuel rightResult hrightDoomed hrelation.2 + have hmaterialized := hrightShape + cases leftResult with + | stopped reason => + cases reason with + | privateStructuralHit => trivial + | ordinaryHit => exact ⟨hdoomed, hmaterialized⟩ + | fuelExhausted => exact ⟨hdoomed, hmaterialized⟩ + | done _ => + right + right + exact ⟨hdoomed, hmaterialized⟩ + +theorem relTriple_pure_privateStructuralHit_any + (table : OtsSecretIndex → HashOutput) + (rightRun : ProbComp (DirectDetailedResult (α × SplitHashCache))) : + RelTriple + (pure (.stopped .privateStructuralHit) : + ProbComp (DirectDetailedResult (α × SplitHashCache))) + rightRun (DirectDetailedOrdinaryRunEq table) := by + have hbase := relTriple_true + (pure (.stopped .privateStructuralHit) : + ProbComp (DirectDetailedResult (α × SplitHashCache))) rightRun + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (pure (.stopped .privateStructuralHit) : + ProbComp (DirectDetailedResult (α × SplitHashCache)))) + (fun result hresult => hresult) + apply relTriple_post_mono hsupported + intro leftResult _ hrelation + have hleft : leftResult = .stopped .privateStructuralHit := by + simpa using hrelation.2 + subst leftResult + trivial + +theorem relTriple_any_pure_nonprivateStop + (table : OtsSecretIndex → HashOutput) + (leftRun : ProbComp (DirectDetailedResult (α × SplitHashCache))) + (reason : DirectStopReason) (hreason : reason ≠ .privateStructuralHit) : + RelTriple leftRun + (pure (.stopped reason) : + ProbComp (DirectDetailedResult (α × SplitHashCache))) + (DirectDetailedOrdinaryRunEq table) := by + have hbase := relTriple_true leftRun + (pure (.stopped reason) : + ProbComp (DirectDetailedResult (α × SplitHashCache))) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + apply relTriple_post_mono hsupported + intro leftResult rightResult hrelation + have hright : rightResult = .stopped reason := by + simpa using hrelation.2 + subst rightResult + cases reason with + | privateStructuralHit => contradiction + | ordinaryHit => cases leftResult with + | stopped leftReason => cases leftReason <;> trivial + | done _ => trivial + | fuelExhausted => cases leftResult with + | stopped leftReason => cases leftReason <;> trivial + | done _ => trivial + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_bind + (table : OtsSecretIndex → HashOutput) + (left right : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (leftNext rightNext : α → SplitHashCache → + OracleComp (LazyRevealProbe.World Coordinate) (β × SplitHashCache)) + (leftContext rightContext : DeferredContext) (leftFuel rightFuel : Nat) + (hleft : RelTriple + (runDirectResolvedDetailedFromTable leftContext leftFuel table left) + (runDirectResolvedDetailedFromTable rightContext rightFuel table right) + (DirectDetailedOrdinaryRunEq table)) + (hclean : ∀ (leftResult rightResult : + ResolvedRunResult (α × SplitHashCache)), + OrdinaryMaterializedRunEq table leftResult rightResult → + RelTriple + (runDirectResolvedDetailedFromTable leftResult.context leftResult.remaining + leftResult.table (leftNext leftResult.value.1 leftResult.value.2)) + (runDirectResolvedDetailedFromTable rightResult.context rightResult.remaining + rightResult.table (rightNext rightResult.value.1 rightResult.value.2)) + (DirectDetailedOrdinaryRunEq table)) + (hprivate : ∀ (leftResult rightResult : + ResolvedRunResult (α × SplitHashCache)), + PrivateStructuralHit leftResult.context → + RelTriple + (runDirectResolvedDetailedFromTable leftResult.context leftResult.remaining + leftResult.table (leftNext leftResult.value.1 leftResult.value.2)) + (runDirectResolvedDetailedFromTable rightResult.context rightResult.remaining + rightResult.table (rightNext rightResult.value.1 rightResult.value.2)) + (DirectDetailedOrdinaryRunEq table)) : + RelTriple + (runDirectResolvedDetailedFromTable leftContext leftFuel table + (left >>= fun value => leftNext value.1 value.2)) + (runDirectResolvedDetailedFromTable rightContext rightFuel table + (right >>= fun value => rightNext value.1 value.2)) + (DirectDetailedOrdinaryRunEq table) := by + rw [runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_bind] + apply relTriple_bind hleft + intro leftResult rightResult hrelation + cases leftResult with + | stopped leftReason => + cases leftReason with + | privateStructuralHit => + exact relTriple_pure_privateStructuralHit_any table _ + | ordinaryHit => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => exact relTriple_pure_pure trivial + | fuelExhausted => exact relTriple_pure_pure trivial + | done rightResult => + simp only + rw [hrelation.1.1] + exact relTriple_runDirectResolvedDetailed_of_right_materializedDoomed table + (pure (.stopped .ordinaryHit)) + (rightNext rightResult.value.1 rightResult.value.2) + rightResult.context rightResult.remaining hrelation.1.2 hrelation.2 + | fuelExhausted => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => exact relTriple_pure_pure trivial + | fuelExhausted => exact relTriple_pure_pure trivial + | done rightResult => + simp only + rw [hrelation.1.1] + exact relTriple_runDirectResolvedDetailed_of_right_materializedDoomed table + (pure (.stopped .fuelExhausted)) + (rightNext rightResult.value.1 rightResult.value.2) + rightResult.context rightResult.remaining hrelation.1.2 hrelation.2 + | done leftResult => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => + exact relTriple_any_pure_nonprivateStop table _ .ordinaryHit (by decide) + | fuelExhausted => + exact relTriple_any_pure_nonprivateStop table _ .fuelExhausted (by decide) + | done rightResult => + rcases hrelation with hcleanRelation | hprivateRelation | hdoomedRelation + · exact hclean leftResult rightResult hcleanRelation + · exact hprivate leftResult rightResult hprivateRelation + · simp only + rw [hdoomedRelation.1.1] + exact relTriple_runDirectResolvedDetailed_of_right_materializedDoomed table + (runDirectResolvedDetailedFromTable leftResult.context leftResult.remaining + leftResult.table (leftNext leftResult.value.1 leftResult.value.2)) + (rightNext rightResult.value.1 rightResult.value.2) + rightResult.context rightResult.remaining hdoomedRelation.1.2 + hdoomedRelation.2 + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_bind_with_support + (table : OtsSecretIndex → HashOutput) + (left right : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (leftNext rightNext : α → SplitHashCache → + OracleComp (LazyRevealProbe.World Coordinate) (β × SplitHashCache)) + (leftContext rightContext : DeferredContext) (leftFuel rightFuel : Nat) + (hleft : RelTriple + (runDirectResolvedDetailedFromTable leftContext leftFuel table left) + (runDirectResolvedDetailedFromTable rightContext rightFuel table right) + (DirectDetailedOrdinaryRunEq table)) + (hclean : ∀ (leftResult rightResult : + ResolvedRunResult (α × SplitHashCache)), + DirectDetailedResult.done leftResult ∈ support + (runDirectResolvedDetailedFromTable leftContext leftFuel table left) → + DirectDetailedResult.done rightResult ∈ support + (runDirectResolvedDetailedFromTable rightContext rightFuel table right) → + OrdinaryMaterializedRunEq table leftResult rightResult → + RelTriple + (runDirectResolvedDetailedFromTable leftResult.context leftResult.remaining + leftResult.table (leftNext leftResult.value.1 leftResult.value.2)) + (runDirectResolvedDetailedFromTable rightResult.context rightResult.remaining + rightResult.table (rightNext rightResult.value.1 rightResult.value.2)) + (DirectDetailedOrdinaryRunEq table)) + (hprivate : ∀ (leftResult rightResult : + ResolvedRunResult (α × SplitHashCache)), + DirectDetailedResult.done leftResult ∈ support + (runDirectResolvedDetailedFromTable leftContext leftFuel table left) → + DirectDetailedResult.done rightResult ∈ support + (runDirectResolvedDetailedFromTable rightContext rightFuel table right) → + PrivateStructuralHit leftResult.context → + RelTriple + (runDirectResolvedDetailedFromTable leftResult.context leftResult.remaining + leftResult.table (leftNext leftResult.value.1 leftResult.value.2)) + (runDirectResolvedDetailedFromTable rightResult.context rightResult.remaining + rightResult.table (rightNext rightResult.value.1 rightResult.value.2)) + (DirectDetailedOrdinaryRunEq table)) : + RelTriple + (runDirectResolvedDetailedFromTable leftContext leftFuel table + (left >>= fun value => leftNext value.1 value.2)) + (runDirectResolvedDetailedFromTable rightContext rightFuel table + (right >>= fun value => rightNext value.1 value.2)) + (DirectDetailedOrdinaryRunEq table) := by + rw [runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_bind] + have hleftWithSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hleft + (fun result => result ∈ support + (runDirectResolvedDetailedFromTable leftContext leftFuel table left)) + (fun result hresult => hresult) + have hbothWithSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftWithSupport + apply relTriple_bind hbothWithSupport + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResult with + | stopped leftReason => + cases leftReason with + | privateStructuralHit => + exact relTriple_pure_privateStructuralHit_any table _ + | ordinaryHit => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => exact relTriple_pure_pure trivial + | fuelExhausted => exact relTriple_pure_pure trivial + | done rightResult => + simp only + rw [hrelation.1.1] + exact relTriple_runDirectResolvedDetailed_of_right_materializedDoomed table + (pure (.stopped .ordinaryHit)) + (rightNext rightResult.value.1 rightResult.value.2) + rightResult.context rightResult.remaining hrelation.1.2 hrelation.2 + | fuelExhausted => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => exact relTriple_pure_pure trivial + | fuelExhausted => exact relTriple_pure_pure trivial + | done rightResult => + simp only + rw [hrelation.1.1] + exact relTriple_runDirectResolvedDetailed_of_right_materializedDoomed table + (pure (.stopped .fuelExhausted)) + (rightNext rightResult.value.1 rightResult.value.2) + rightResult.context rightResult.remaining hrelation.1.2 hrelation.2 + | done leftResult => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => + exact relTriple_any_pure_nonprivateStop table _ .ordinaryHit (by decide) + | fuelExhausted => + exact relTriple_any_pure_nonprivateStop table _ .fuelExhausted (by decide) + | done rightResult => + rcases hrelation with hcleanRelation | hprivateRelation | hdoomedRelation + · exact hclean leftResult rightResult hleftSupport hrightSupport hcleanRelation + · exact hprivate leftResult rightResult hleftSupport hrightSupport hprivateRelation + · simp only + rw [hdoomedRelation.1.1] + exact relTriple_runDirectResolvedDetailed_of_right_materializedDoomed table + (runDirectResolvedDetailedFromTable leftResult.context leftResult.remaining + leftResult.table (leftNext leftResult.value.1 leftResult.value.2)) + (rightNext rightResult.value.1 rightResult.value.2) + rightResult.context rightResult.remaining hdoomedRelation.1.2 + hdoomedRelation.2 + +def DirectPreservesPrivatePosition + (position : Position) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ context fuel table cache result, + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table (computation.run cache)) → + result.context.state.values (.position position) = + context.state.values (.position position) ∧ + result.context.state.pendingAt (.position position) = + context.state.pendingAt (.position position) ∧ + result.context.values position = context.values position + +theorem directPreservesPrivatePosition_pure + (position : Position) (value : α) : + DirectPreservesPrivatePosition position + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := by + intro context fuel table cache result hresult + simp [runDirectResolvedDetailedFromTable] at hresult + subst result + exact ⟨rfl, rfl, rfl⟩ + +theorem DirectPreservesPrivatePosition.bind + {position : Position} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : DirectPreservesPrivatePosition position left) + (hnext : ∀ value, DirectPreservesPrivatePosition position (next value)) : + DirectPreservesPrivatePosition position (left >>= next) := by + intro context fuel table cache result hresult + change DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + (left.run cache >>= fun leftResult => (next leftResult.1).run leftResult.2)) at hresult + rw [runDirectResolvedDetailedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨leftResult, hleftResult, hrest⟩ := hresult + cases leftResult with + | stopped reason => simp at hrest + | done middle => + have hmiddle := hleft context fuel table cache middle hleftResult + have hfinal := hnext middle.value.1 middle.context middle.remaining middle.table + middle.value.2 result hrest + exact ⟨hfinal.1.trans hmiddle.1, + hfinal.2.1.trans hmiddle.2.1, + hfinal.2.2.trans hmiddle.2.2⟩ + +theorem runDirectResolvedDetailedFromTable_peek_query_privateHelper + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (context : DeferredContext) (fuel : Nat) : + runDirectResolvedDetailedFromTable context fuel table + (liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.peek coordinate))) = + pure (.done ⟨context, fuel, context.state.values coordinate, table⟩) := by + rw [← bind_pure + (liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.peek coordinate)))] + rw [runDirectResolvedDetailedFromTable_peek_query_bind, + runDirectResolvedDetailedFromTable_pure] + +theorem runDirectResolvedDetailedFromTable_peekCoordinate_privateHelper + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + runDirectResolvedDetailedFromTable context fuel table + ((peekCoordinate coordinate).run cache) = + pure (.done ⟨context, fuel, + (truncateHash <$> context.state.values coordinate, cache), table⟩) := by + unfold peekCoordinate + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind] + simp only [StateT.run_liftM] + unfold LazyRevealProbe.peekQuery + rw [runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peek_query_privateHelper] + simp [runDirectResolvedDetailedFromTable_pure] + +theorem directPreservesPrivatePosition_peekCoordinate + (position : Position) (coordinate : Coordinate) : + DirectPreservesPrivatePosition position (peekCoordinate coordinate) := by + intro context fuel table cache result hresult + rw [runDirectResolvedDetailedFromTable_peekCoordinate_privateHelper] at hresult + simp at hresult + subst result + exact ⟨rfl, rfl, rfl⟩ + +theorem directPreservesPrivatePosition_splitHashQuery + (position : Position) (key : SplitHashKey) : + DirectPreservesPrivatePosition position (splitHashQuery key) := by + intro context fuel table cache result hresult + rw [splitHashQuery_run_eq] at hresult + cases hlookup : cache key with + | some output => + simp only [hlookup] at hresult + simp [runDirectResolvedDetailedFromTable] at hresult + subst result + exact ⟨rfl, rfl, rfl⟩ + | none => + simp only [hlookup, LazyRevealProbe.hashOutputQuery, + runDirectResolvedDetailedFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + simp [runDirectResolvedDetailedFromTable] at hrest + subst result + exact ⟨rfl, rfl, rfl⟩ + +theorem directPreservesPrivatePosition_publishCoordinate + (position : Position) (coordinate : Coordinate) : + DirectPreservesPrivatePosition position (publishCoordinate coordinate) := by + intro context fuel table cache result hresult + unfold publishCoordinate at hresult + rw [StateT.run_liftM, LazyRevealProbe.publishQuery, + runDirectResolvedDetailedFromTable_publish_query_bind] at hresult + simp [runDirectResolvedDetailedFromTable] at hresult + subst result + exact ⟨rfl, rfl, rfl⟩ + +theorem directPreservesPrivatePosition_modify + (position : Position) (update : SplitHashCache → SplitHashCache) : + DirectPreservesPrivatePosition position + (modify update : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit) := by + intro context fuel table cache result hresult + simp [StateT.run_modify, runDirectResolvedDetailedFromTable] at hresult + subst result + exact ⟨rfl, rfl, rfl⟩ + +theorem directPreservesPrivatePosition_peekPositionValues + (position : Position) : ∀ positions : List Position, + DirectPreservesPrivatePosition position (peekPositionValues positions) + | [] => directPreservesPrivatePosition_pure position (some []) + | head :: remaining => by + rw [peekPositionValues] + exact (directPreservesPrivatePosition_peekCoordinate position (.position head)).bind + fun value => match value with + | none => directPreservesPrivatePosition_pure position none + | some headValue => + (directPreservesPrivatePosition_peekPositionValues position remaining).bind + fun values => match values with + | none => directPreservesPrivatePosition_pure position none + | some tailValues => directPreservesPrivatePosition_pure position + (some (headValue :: tailValues)) + +set_option maxRecDepth 100000 in +theorem directPreservesPrivatePosition_peekTableInput + (position : Position) (parameter : PublicParameter) (coordinate : Coordinate) : + DirectPreservesPrivatePosition position (peekTableInput parameter coordinate) := by + cases coordinate with + | chainStart => exact directPreservesPrivatePosition_pure position none + | position outputPosition => + cases outputPosition with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput.eq_2] + by_cases hzero : step.val = 0 + · rw [if_pos hzero] + exact + (directPreservesPrivatePosition_peekCoordinate position + (.chainStart lay tree leafIdx chainIdx)).bind fun value => + match value with + | none => directPreservesPrivatePosition_pure position none + | some _ => directPreservesPrivatePosition_pure position (some _) + · rw [if_neg hzero] + exact (directPreservesPrivatePosition_peekPositionValues position + (Position.chain lay tree leafIdx chainIdx step).children).bind fun values => + match values with + | none => directPreservesPrivatePosition_pure position none + | some _ => directPreservesPrivatePosition_pure position (some _) + | leaf lay tree leafIdx => + rw [peekTableInput.eq_3 parameter (.leaf lay tree leafIdx) (by simp)] + exact (directPreservesPrivatePosition_peekPositionValues position + (Position.leaf lay tree leafIdx).children).bind fun values => + match values with + | none => directPreservesPrivatePosition_pure position none + | some _ => directPreservesPrivatePosition_pure position (some _) + | node lay tree level nodeIdx => + rw [peekTableInput.eq_3 parameter (.node lay tree level nodeIdx) (by simp)] + exact (directPreservesPrivatePosition_peekPositionValues position + (Position.node lay tree level nodeIdx).children).bind fun values => + match values with + | none => directPreservesPrivatePosition_pure position none + | some _ => directPreservesPrivatePosition_pure position (some _) + | ftsLeaf index tree leafIdx => + rw [peekTableInput.eq_3 parameter (.ftsLeaf index tree leafIdx) (by simp)] + exact (directPreservesPrivatePosition_peekPositionValues position + (Position.ftsLeaf index tree leafIdx).children).bind fun values => + match values with + | none => directPreservesPrivatePosition_pure position none + | some _ => directPreservesPrivatePosition_pure position (some _) + | ftsNode index tree level nodeIdx => + rw [peekTableInput.eq_3 parameter (.ftsNode index tree level nodeIdx) (by simp)] + exact (directPreservesPrivatePosition_peekPositionValues position + (Position.ftsNode index tree level nodeIdx).children).bind fun values => + match values with + | none => directPreservesPrivatePosition_pure position none + | some _ => directPreservesPrivatePosition_pure position (some _) + | ftsRoots index => + rw [peekTableInput.eq_3 parameter (.ftsRoots index) (by simp)] + exact (directPreservesPrivatePosition_peekPositionValues position + (Position.ftsRoots index).children).bind fun values => + match values with + | none => directPreservesPrivatePosition_pure position none + | some _ => directPreservesPrivatePosition_pure position (some _) + +set_option maxRecDepth 100000 in +theorem directPreservesPrivatePosition_revealCoordinateOutput_of_ne + (position : Position) (coordinate : Coordinate) + (hne : coordinate ≠ .position position) : + DirectPreservesPrivatePosition position (revealCoordinateOutput coordinate) := by + intro context fuel table cache result hresult + unfold revealCoordinateOutput at hresult + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind] at hresult + simp only [StateT.run_liftM] at hresult + rw [LazyRevealProbe.revealQuery, + runDirectResolvedDetailedFromTable_reveal_query_bind] at hresult + cases hvalue : context.state.values coordinate with + | some output => + simp only [hvalue] at hresult + simp [StateT.run_modify, runDirectResolvedDetailedFromTable] at hresult + subst result + exact ⟨rfl, rfl, rfl⟩ + | none => + simp only [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + simp [StateT.run_modify, runDirectResolvedDetailedFromTable] at hresult + subst result + refine ⟨?_, ?_, rfl⟩ + · simp [LazyRevealProbe.State.materialize, Function.update_of_ne, + show Coordinate.position position ≠ + Coordinate.chainStart lay tree leafIdx chainIdx by simp] + · change + (context.state.clearPending (.chainStart lay tree leafIdx chainIdx)).pendingAt + (.position position) = context.state.pendingAt (.position position) + rw [pendingAt_clearPending_of_ne] + simp + | position other => + have hother : other ≠ position := by + intro heq + subst other + exact hne rfl + cases hprivate : context.values other with + | some output => + by_cases hhit : context.state.hitAt (.position other) output + · simp [hprivate, hhit] at hresult + · simp only [hprivate, hhit, ↓reduceIte] at hresult + simp [StateT.run_modify, runDirectResolvedDetailedFromTable] at hresult + subst result + refine ⟨?_, ?_, ?_⟩ + · simp [LazyRevealProbe.State.materialize, Function.update_of_ne, + show Coordinate.position position ≠ Coordinate.position other by + simpa using Ne.symm hother] + · change + (context.state.clearPending (.position other)).pendingAt + (.position position) = context.state.pendingAt (.position position) + exact pendingAt_clearPending_of_ne context.state (.position other) + (.position position) (by simpa using Ne.symm hother) + · rfl + | none => + simp only [hprivate, mem_support_bind_iff] at hresult + obtain ⟨revealedResult, hreveal, hrest⟩ := hresult + cases revealedResult with + | stopped reason => simp at hrest + | done middle => + obtain ⟨output, _houtput, houtput⟩ := hreveal + by_cases hhit : context.state.hitAt (.position other) output + · simp [hhit] at houtput + · simp only [hhit, ↓reduceIte] at houtput + simp [runDirectResolvedDetailedFromTable] at houtput + subst middle + simp [StateT.run_modify, runDirectResolvedDetailedFromTable] at hrest + subst result + refine ⟨?_, ?_, ?_⟩ + · simp [LazyRevealProbe.State.materialize, Function.update_of_ne, + show Coordinate.position position ≠ Coordinate.position other by + simpa using Ne.symm hother] + · change + (context.state.clearPending (.position other)).pendingAt + (.position position) = context.state.pendingAt (.position position) + exact pendingAt_clearPending_of_ne context.state (.position other) + (.position position) (by simpa using Ne.symm hother) + · simp [DeferredStructuralValues.install, + Function.update_of_ne (Ne.symm hother)] + +theorem directPreservesPrivatePosition_publishOrdinaryInput + (position : Position) (coordinate : Coordinate) (input : HashInput) + (output : HashOutput) : + DirectPreservesPrivatePosition position + (publishOrdinaryInput coordinate input output) := + (directPreservesPrivatePosition_publishCoordinate position coordinate).bind fun _ => + (directPreservesPrivatePosition_modify position fun cache => + Function.update cache (.ordinary input) (some output)).bind fun _ => + directPreservesPrivatePosition_pure position output + +set_option maxRecDepth 100000 in +theorem directPreservesPrivatePosition_resolveKnownInput_of_ne + (position : Position) (parameter : PublicParameter) (coordinate : Coordinate) + (input : HashInput) (hne : coordinate ≠ .position position) : + DirectPreservesPrivatePosition position + (resolveKnownInput parameter coordinate input) := by + unfold resolveKnownInput + exact (directPreservesPrivatePosition_peekTableInput position parameter coordinate).bind + fun known => match known with + | none => directPreservesPrivatePosition_splitHashQuery position (.ordinary input) + | some knownInput => by + simp only + by_cases heq : knownInput = input + · rw [if_pos heq] + exact (directPreservesPrivatePosition_revealCoordinateOutput_of_ne position coordinate + hne).bind fun output => + directPreservesPrivatePosition_publishOrdinaryInput position coordinate input output + · rw [if_neg heq] + exact directPreservesPrivatePosition_splitHashQuery position (.ordinary input) +theorem relTriple_runDirectResolvedDetailed_pure_of_ordinaryMaterialized + (table : OtsSecretIndex → HashOutput) (value : α) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α).run rightCache)) + (DirectDetailedOrdinaryRunEq table) := by + rw [StateT.run_pure, StateT.run_pure, + runDirectResolvedDetailedFromTable_pure, + runDirectResolvedDetailedFromTable_pure] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := hcache + revealed_eq := hrevealed + values_le := hvalues + left_published := hpublished + right_materialized := hrightMaterialized } + +theorem runDirectResolvedDetailedFromTable_peek_query + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (context : DeferredContext) (fuel : Nat) : + runDirectResolvedDetailedFromTable context fuel table + (liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.peek coordinate))) = + pure (.done ⟨context, fuel, context.state.values coordinate, table⟩) := by + rw [← bind_pure + (liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.peek coordinate)))] + rw [runDirectResolvedDetailedFromTable_peek_query_bind, + runDirectResolvedDetailedFromTable_pure] + +theorem runDirectResolvedDetailedFromTable_peekCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + runDirectResolvedDetailedFromTable context fuel table + ((peekCoordinate coordinate).run cache) = + pure (.done ⟨context, fuel, + (truncateHash <$> context.state.values coordinate, cache), table⟩) := by + unfold peekCoordinate + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind] + simp only [StateT.run_liftM] + unfold LazyRevealProbe.peekQuery + rw [runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peek_query] + simp [runDirectResolvedDetailedFromTable_pure] + +theorem runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_cons + (table : OtsSecretIndex → HashOutput) (input : HashInput) (slot : Nat) + (coordinate : Coordinate) (remaining : List Coordinate) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + runDirectResolvedDetailedFromTable context fuel table + ((probeFirstMissingInputCoordinate input slot + (coordinate :: remaining)).run cache) = + match context.state.values coordinate with + | none => + runDirectResolvedDetailedFromTable context fuel table + ((probe ⟨coordinate, slotDigest slot input⟩).run cache) + | some _ => + runDirectResolvedDetailedFromTable context fuel table + ((probeFirstMissingInputCoordinate input (slot + 1) remaining).run cache) := by + rw [probeFirstMissingInputCoordinate, StateT.run_bind, + runDirectResolvedDetailedFromTable_bind] + rw [runDirectResolvedDetailedFromTable_peekCoordinate] + cases context.state.values coordinate <;> simp + +theorem runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_of_values + (values : Coordinate → HashOutput) (input : HashInput) + (context : DeferredContext) (cache : SplitHashCache) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : ∀ (slot : Nat) (coordinates : List Coordinate), + (∀ coordinate, coordinate ∈ coordinates → + context.state.values coordinate = some (values coordinate)) → + runDirectResolvedDetailedFromTable context fuel table + ((probeFirstMissingInputCoordinate input slot coordinates).run cache) = + pure (.done ⟨context, fuel, ((), cache), table⟩) + | _, [], _ => by simp [probeFirstMissingInputCoordinate, runDirectResolvedDetailedFromTable] + | slot, coordinate :: remaining, hvalues => by + rw [runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_cons] + rw [hvalues coordinate (by simp)] + exact runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_of_values values + input context cache fuel table (slot + 1) remaining + (fun other hother => hvalues other (by simp [hother])) + +set_option maxRecDepth 10000 in +theorem runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_of_prefix_values_of_missing + (values : Coordinate → HashOutput) (input : HashInput) + (context : DeferredContext) (cache : SplitHashCache) + (fuel slot : Nat) (prior remaining : List Coordinate) (coordinate : Coordinate) + (table : OtsSecretIndex → HashOutput) + (hvalues : ∀ other, other ∈ prior → + context.state.values other = some (values other)) + (hmissing : context.state.values coordinate = none) + (hnotRevealed : coordinate ∉ context.state.revealed) : + runDirectResolvedDetailedFromTable context (fuel + 1) table + ((probeFirstMissingInputCoordinate input slot + (prior ++ coordinate :: remaining)).run cache) = + pure (.done ⟨ + { context with state := (context.state.addPending coordinate + (slotDigest (slot + prior.length) input)) }, + fuel, ((), cache), table⟩) := by + induction prior generalizing slot with + | nil => + rw [List.nil_append, + runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_cons, hmissing] + unfold probe + rw [StateT.run_liftM, LazyRevealProbe.probeQuery, + runDirectResolvedDetailedFromTable_probe_query_bind] + simp [hnotRevealed, runDirectResolvedDetailedFromTable] + | cons head tail ih => + rw [List.cons_append, + runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_cons, + hvalues head (by simp)] + have htailValues : ∀ other, other ∈ tail → + context.state.values other = some (values other) := by + intro other hother + exact hvalues other (by simp [hother]) + rw [ih (slot + 1) htailValues] + simp [Nat.add_comm, Nat.add_left_comm] + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_pure_probe_right + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (candidate : Digest) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel + 1 ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hrightMissing : right.state.values coordinate = none) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((pure () : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probe ⟨coordinate, candidate⟩).run rightCache)) + (DirectDetailedOrdinaryRunEq table) := by + obtain ⟨remaining, rfl⟩ := Nat.exists_eq_succ_of_ne_zero + (by omega : rightFuel ≠ 0) + unfold probe + rw [StateT.run_pure, StateT.run_liftM] + unfold LazyRevealProbe.probeQuery + simp only + rw [runDirectResolvedDetailedFromTable_pure, + runDirectResolvedDetailedFromTable_probe_query_bind] + have hrightNotRevealed : coordinate ∉ right.state.revealed := by + intro hrightRevealed + have hleftRevealed : coordinate ∈ left.state.revealed := by + rw [hrevealed] + exact hrightRevealed + have hleftKnown := hpublished coordinate hleftRevealed + cases hleftValue : left.state.values coordinate with + | none => exact hleftKnown hleftValue + | some output => + have hrightValue := hvalues coordinate output hleftValue + rw [hrightMissing] at hrightValue + contradiction + simp only [hrightNotRevealed, ↓reduceIte] + rw [runDirectResolvedDetailedFromTable_pure] + apply relTriple_pure_pure + let nextRight : DeferredContext := + { right with state := right.state.addPending coordinate candidate } + by_cases hcompletable : DeferredCompletable table nextRight + · left + exact + { value_eq := rfl + context_le := hcontext.addPending_right_of_completable + coordinate candidate hcompletable + remaining_le := by + show leftFuel ≤ remaining + omega + left_table := rfl + right_table := rfl + cache_eq := hcache + revealed_eq := hrevealed + values_le := hvalues + left_published := hpublished + right_materialized := by + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_addPending] } + · right + right + refine ⟨⟨rfl, hcontext.view.rightConsistent.addPending coordinate candidate, + hcontext.view.rightStarts.addPending coordinate candidate, hcompletable⟩, ?_⟩ + change { right with state := right.state.addPending coordinate candidate } = + directDeferredContext (right.state.addPending coordinate candidate) + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_addPending] + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_pure_probeFirstMissing_right + (table : OtsSecretIndex → HashOutput) (input : HashInput) : + ∀ (slot : Nat) (coordinates : List Coordinate) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache), + FinalizationContextLE table left right → + leftFuel + 1 ≤ rightFuel → + ordinaryQueryCache leftCache = ordinaryQueryCache rightCache → + left.state.revealed = right.state.revealed → + LazyRevealProbe.ValuesLE left.state right.state → + PublishedValues left.state → + right = directDeferredContext right.state → + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((pure () : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probeFirstMissingInputCoordinate input slot coordinates).run rightCache)) + (DirectDetailedOrdinaryRunEq table) + | slot, [], left, right, leftFuel, rightFuel, leftCache, rightCache, + hcontext, hfuel, hcache, hrevealed, hvalues, hpublished, + hrightMaterialized => by + simpa [probeFirstMissingInputCoordinate] using + (relTriple_runDirectResolvedDetailed_pure_of_ordinaryMaterialized table () + left right leftFuel rightFuel leftCache rightCache hcontext (by omega) + hcache hrevealed hvalues hpublished hrightMaterialized) + | slot, coordinate :: remaining, left, right, leftFuel, rightFuel, + leftCache, rightCache, hcontext, hfuel, hcache, hrevealed, hvalues, + hpublished, hrightMaterialized => by + rw [runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_cons] + cases hrightValue : right.state.values coordinate with + | none => + exact relTriple_runDirectResolvedDetailed_pure_probe_right table coordinate + (slotDigest slot input) left right leftFuel rightFuel leftCache rightCache + hcontext hfuel hcache hrevealed hvalues hpublished hrightMaterialized + hrightValue + | some output => + exact relTriple_runDirectResolvedDetailed_pure_probeFirstMissing_right table input + (slot + 1) remaining left right leftFuel rightFuel leftCache rightCache + hcontext hfuel hcache hrevealed hvalues hpublished hrightMaterialized + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_probe_aligned + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (candidate : Digest) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : 0 < leftFuel ∧ leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((probe ⟨coordinate, candidate⟩).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probe ⟨coordinate, candidate⟩).run rightCache)) + (DirectDetailedOrdinaryRunEq table) := by + obtain ⟨leftRemaining, rfl⟩ := Nat.exists_eq_succ_of_ne_zero + (by omega : leftFuel ≠ 0) + obtain ⟨rightRemaining, rfl⟩ := Nat.exists_eq_succ_of_ne_zero + (by omega : rightFuel ≠ 0) + unfold probe + rw [StateT.run_liftM, StateT.run_liftM] + unfold LazyRevealProbe.probeQuery + simp only + rw [runDirectResolvedDetailedFromTable_probe_query_bind, + runDirectResolvedDetailedFromTable_probe_query_bind] + by_cases hleftRevealed : coordinate ∈ left.state.revealed + · have hrightRevealed : coordinate ∈ right.state.revealed := by + rw [← hrevealed] + exact hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + exact relTriple_runDirectResolvedDetailed_pure_of_ordinaryMaterialized table () + left right leftRemaining rightRemaining leftCache rightCache hcontext + (by omega) hcache hrevealed hvalues hpublished hrightMaterialized + · have hrightRevealed : coordinate ∉ right.state.revealed := by + rwa [← hrevealed] + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + let nextLeft : DeferredContext := + { left with state := left.state.addPending coordinate candidate } + let nextRight : DeferredContext := + { right with state := right.state.addPending coordinate candidate } + by_cases hcompletable : DeferredCompletable table nextRight + · have hnext := hcontext.addPending_both_of_right_completable + coordinate candidate hcompletable + have hnextPublished : PublishedValues nextLeft.state := by + simpa [nextLeft, PublishedValues, LazyRevealProbe.State.addPending] using hpublished + exact relTriple_runDirectResolvedDetailed_pure_of_ordinaryMaterialized table () + nextLeft nextRight leftRemaining rightRemaining leftCache rightCache hnext + (by omega) hcache hrevealed hvalues hnextPublished (by + change { right with state := right.state.addPending coordinate candidate } = + directDeferredContext (right.state.addPending coordinate candidate) + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_addPending]) + · rw [runDirectResolvedDetailedFromTable_pure, + runDirectResolvedDetailedFromTable_pure] + apply relTriple_pure_pure + right + right + refine ⟨⟨rfl, hcontext.view.rightConsistent.addPending coordinate candidate, + hcontext.view.rightStarts.addPending coordinate candidate, hcompletable⟩, ?_⟩ + change { right with state := right.state.addPending coordinate candidate } = + directDeferredContext (right.state.addPending coordinate candidate) + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_addPending] + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_privateHit_pure_probeFirstMissing_right + (table : OtsSecretIndex → HashOutput) (input : HashInput) : + ∀ (slot : Nat) (coordinates : List Coordinate) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache), + PrivateStructuralHit left → + leftFuel + 1 ≤ rightFuel → + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((pure () : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probeFirstMissingInputCoordinate input slot coordinates).run rightCache)) + (DirectDetailedOrdinaryRunEq table) + | slot, [], left, right, leftFuel, rightFuel, leftCache, rightCache, + hprivate, hfuel => by + rw [StateT.run_pure, runDirectResolvedDetailedFromTable_pure] + simp only [probeFirstMissingInputCoordinate, StateT.run_pure, + runDirectResolvedDetailedFromTable_pure] + apply relTriple_pure_pure + right + left + exact hprivate + | slot, coordinate :: remaining, left, right, leftFuel, rightFuel, + leftCache, rightCache, hprivate, hfuel => by + rw [runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_cons] + cases hrightValue : right.state.values coordinate with + | some output => + exact + relTriple_runDirectResolvedDetailed_privateHit_pure_probeFirstMissing_right + table input (slot + 1) remaining left right leftFuel rightFuel + leftCache rightCache hprivate hfuel + | none => + obtain ⟨rightRemaining, rfl⟩ := Nat.exists_eq_succ_of_ne_zero + (by omega : rightFuel ≠ 0) + unfold probe + rw [StateT.run_pure, StateT.run_liftM] + unfold LazyRevealProbe.probeQuery + simp only + rw [runDirectResolvedDetailedFromTable_pure, + runDirectResolvedDetailedFromTable_probe_query_bind] + by_cases hrevealed : coordinate ∈ right.state.revealed <;> + simp only [hrevealed, ↓reduceIte] <;> + rw [runDirectResolvedDetailedFromTable_pure] <;> + apply relTriple_pure_pure <;> + right <;> left <;> exact hprivate + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_probe_private_position_probeFirstMissing_right + (table : OtsSecretIndex → HashOutput) (input : HashInput) (slot : Nat) + (coordinates : List Coordinate) (position : Position) + (candidate : Digest) (output : HashOutput) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : 0 < leftFuel ∧ leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hhidden : left.state.values (.position position) = none) + (hprivate : left.values position = some output) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((probe ⟨.position position, candidate⟩).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probeFirstMissingInputCoordinate input slot coordinates).run rightCache)) + (DirectDetailedOrdinaryRunEq table) := by + obtain ⟨remaining, rfl⟩ := Nat.exists_eq_succ_of_ne_zero + (by omega : leftFuel ≠ 0) + unfold probe + rw [StateT.run_liftM] + unfold LazyRevealProbe.probeQuery + simp only + rw [runDirectResolvedDetailedFromTable_probe_query_bind] + have hleftNotRevealed : Coordinate.position position ∉ left.state.revealed := by + intro hrevealedPosition + exact (hpublished (.position position) hrevealedPosition) hhidden + simp only [hleftNotRevealed, ↓reduceIte] + let nextLeft : DeferredContext := + { left with state := left.state.addPending (.position position) candidate } + by_cases hhit : truncateHash output = candidate + · have hprivateHit : PrivateStructuralHit nextLeft := + (privateStructuralHit_addPending_iff left position output candidate + (not_privateStructuralHit_of_deferredCompletable hcontext.leftCompletable) + hhidden hprivate).2 hhit + exact + relTriple_runDirectResolvedDetailed_privateHit_pure_probeFirstMissing_right + table input slot coordinates nextLeft right remaining rightFuel leftCache rightCache + hprivateHit (by omega) + · have hnext := hcontext.addPending_left_of_resolved + (.position position) candidate output (by + change left.positionValue position = some output + simp [DeferredContext.positionValue, hhidden, hprivate]) hhit + have hnextPublished : PublishedValues nextLeft.state := by + simpa [nextLeft, PublishedValues, LazyRevealProbe.State.addPending] using hpublished + exact relTriple_runDirectResolvedDetailed_pure_probeFirstMissing_right table input + slot coordinates nextLeft right remaining rightFuel leftCache rightCache hnext + (by omega) hcache hrevealed hvalues hnextPublished hrightMaterialized + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_probeFirstMissing_positions + (table : OtsSecretIndex → HashOutput) (input : HashInput) : + ∀ (slot : Nat) (positions : List Position) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache), + FinalizationContextLE table left right → + 0 < leftFuel → leftFuel ≤ rightFuel → + ordinaryQueryCache leftCache = ordinaryQueryCache rightCache → + left.state.revealed = right.state.revealed → + LazyRevealProbe.ValuesLE left.state right.state → + PublishedValues left.state → + right = directDeferredContext right.state → + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((probeFirstMissingInputCoordinate input slot + (positions.map Coordinate.position)).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probeFirstMissingInputCoordinate input slot + (positions.map Coordinate.position)).run rightCache)) + (DirectDetailedOrdinaryRunEq table) + | slot, [], left, right, leftFuel, rightFuel, leftCache, rightCache, + hcontext, hpositive, hfuel, hcache, hrevealed, hvalues, hpublished, + hrightMaterialized => by + simpa [probeFirstMissingInputCoordinate] using + (relTriple_runDirectResolvedDetailed_pure_of_ordinaryMaterialized table () + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache + hrevealed hvalues hpublished hrightMaterialized) + | slot, position :: remaining, left, right, leftFuel, rightFuel, + leftCache, rightCache, hcontext, hpositive, hfuel, hcache, hrevealed, + hvalues, hpublished, hrightMaterialized => by + simp only [List.map_cons] + rw [runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_cons, + runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_cons] + cases hleftValue : left.state.values (.position position) with + | some leftOutput => + have hrightValue := hvalues (.position position) leftOutput hleftValue + rw [hrightValue] + exact relTriple_runDirectResolvedDetailed_probeFirstMissing_positions table input + (slot + 1) remaining left right leftFuel rightFuel leftCache rightCache + hcontext hpositive hfuel hcache hrevealed hvalues hpublished + hrightMaterialized + | none => + cases hrightValue : right.state.values (.position position) with + | none => + exact relTriple_runDirectResolvedDetailed_probe_aligned table + (.position position) (slotDigest slot input) left right leftFuel rightFuel + leftCache rightCache hcontext ⟨hpositive, hfuel⟩ hcache hrevealed + hvalues hpublished hrightMaterialized + | some output => + have hprivate := + hcontext.view.privateValue_of_left_hidden_of_right_materialized + position output hleftValue hrightValue + exact + relTriple_runDirectResolvedDetailed_probe_private_position_probeFirstMissing_right + table input (slot + 1) (remaining.map Coordinate.position) position + (slotDigest slot input) output left right leftFuel rightFuel + leftCache rightCache hcontext ⟨hpositive, hfuel⟩ hcache hrevealed + hvalues hpublished hrightMaterialized hleftValue hprivate + +theorem runDirectResolvedDetailedFromTable_prepareLeafInputProbe + (table : OtsSecretIndex → HashOutput) (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + runDirectResolvedDetailedFromTable context fuel table + ((prepareLeafInputProbe input candidate lay tree leafIdx).run cache) = + match context.state.values candidate.coordinate with + | none => + runDirectResolvedDetailedFromTable context fuel table + ((probe candidate).run cache) + | some _ => + runDirectResolvedDetailedFromTable context fuel table + ((probeFirstMissingInputCoordinate input 0 + ((Position.leaf lay tree leafIdx).children.map + Coordinate.position)).run cache) := by + unfold prepareLeafInputProbe + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekCoordinate] + cases context.state.values candidate.coordinate <;> simp + +theorem runDirectResolvedDetailedFromTable_peekPositionValues_of_values + (completion : Coordinate → HashOutput) (context : DeferredContext) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ∀ positions : List Position, + (∀ position, position ∈ positions → + context.state.values (.position position) = some (completion (.position position))) → + runDirectResolvedDetailedFromTable context fuel table + ((peekPositionValues positions).run cache) = + pure (.done ⟨context, fuel, + (some (positions.map (tableValue completion)), cache), table⟩) + | [], _ => by simp [peekPositionValues, runDirectResolvedDetailedFromTable] + | position :: remaining, hvalues => by + rw [peekPositionValues, StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekCoordinate] + rw [hvalues position (by simp)] + rw [show truncateHash <$> some (completion (.position position)) = + some (tableValue completion position) by rfl] + simp only [pure_bind] + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekPositionValues_of_values completion context fuel + table cache remaining (fun other hother => hvalues other (by simp [hother]))] + simp [runDirectResolvedDetailedFromTable, tableValue] + +theorem runDirectResolvedDetailedFromTable_peekPositionValues_of_prefix_values_of_missing + (completion : Coordinate → HashOutput) (context : DeferredContext) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (prior remaining : List Position) (position : Position) + (hvalues : ∀ other, other ∈ prior → + context.state.values (.position other) = some (completion (.position other))) + (hmissing : context.state.values (.position position) = none) : + runDirectResolvedDetailedFromTable context fuel table + ((peekPositionValues (prior ++ position :: remaining)).run cache) = + pure (.done ⟨context, fuel, (none, cache), table⟩) := by + induction prior with + | nil => + rw [List.nil_append, peekPositionValues, StateT.run_bind, + runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekCoordinate, hmissing] + simp [runDirectResolvedDetailedFromTable] + | cons head tail ih => + rw [List.cons_append, peekPositionValues, StateT.run_bind, + runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekCoordinate, + hvalues head (by simp)] + rw [show truncateHash <$> some (completion (.position head)) = + some (tableValue completion head) by rfl] + simp only [pure_bind] + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + ih (fun other hother => hvalues other (by simp [hother]))] + simp [runDirectResolvedDetailedFromTable] + +theorem runDirectResolvedDetailedFromTable_peekTableInput_of_available + (parameter : PublicParameter) (completion : Coordinate → HashOutput) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) (coordinate : Coordinate) + (havailable : TableInputAvailable completion context.state coordinate) : + runDirectResolvedDetailedFromTable context fuel table + ((peekTableInput parameter coordinate).run cache) = + pure (.done ⟨context, fuel, + (some (tableInput parameter completion coordinate), cache), table⟩) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [TableInputAvailable] at havailable + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput.eq_2] + by_cases hzero : step.val = 0 + · rw [if_pos hzero, StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekCoordinate] + rw [show context.state.values (.chainStart lay tree leafIdx chainIdx) = + some (completion (.chainStart lay tree leafIdx chainIdx)) by + simpa [TableInputAvailable, hzero] using havailable] + simp [runDirectResolvedDetailedFromTable, tableInput, tablePayload, hzero] + · rw [if_neg hzero, StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekPositionValues_of_values completion context + fuel table cache _ (by simpa [TableInputAvailable, hzero] using havailable)] + simp [runDirectResolvedDetailedFromTable, tableInput, tablePayload, hzero] + | leaf lay tree leafIdx => + rw [peekTableInput.eq_3 parameter (.leaf lay tree leafIdx) (by simp), + StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekPositionValues_of_values completion context + fuel table cache _ havailable] + simp [runDirectResolvedDetailedFromTable, tableInput, tablePayload] + | node lay tree level nodeIdx => + rw [peekTableInput.eq_3 parameter (.node lay tree level nodeIdx) (by simp), + StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekPositionValues_of_values completion context + fuel table cache _ havailable] + simp [runDirectResolvedDetailedFromTable, tableInput, tablePayload] + | ftsLeaf index tree leafIdx => + rw [peekTableInput.eq_3 parameter (.ftsLeaf index tree leafIdx) (by simp), + StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekPositionValues_of_values completion context + fuel table cache _ havailable] + simp [runDirectResolvedDetailedFromTable, tableInput, tablePayload] + | ftsNode index tree level nodeIdx => + rw [peekTableInput.eq_3 parameter (.ftsNode index tree level nodeIdx) (by simp), + StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekPositionValues_of_values completion context + fuel table cache _ havailable] + simp [runDirectResolvedDetailedFromTable, tableInput, tablePayload] + | ftsRoots index => + rw [peekTableInput.eq_3 parameter (.ftsRoots index) (by simp), + StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekPositionValues_of_values completion context + fuel table cache _ havailable] + simp [runDirectResolvedDetailedFromTable, tableInput, tablePayload] + +set_option maxRecDepth 100000 in +theorem runDirectResolvedDetailedFromTable_peekTableInput_of_unavailable + (parameter : PublicParameter) (completion : Coordinate → HashOutput) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) (coordinate : Coordinate) + (hcompletion : DeferredCompletion table context completion) + (hots : ∀ position, coordinate = .position position → IsOtsPosition position) + (hunavailable : ¬TableInputAvailable completion context.state coordinate) : + runDirectResolvedDetailedFromTable context fuel table + ((peekTableInput parameter coordinate).run cache) = + pure (.done ⟨context, fuel, (none, cache), table⟩) := by + have htable : ∀ coordinate output, + context.state.values coordinate = some output → output = completion coordinate := by + intro other output hvalue + exact (hcompletion.1 other output hvalue).symm + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [peekTableInput, runDirectResolvedDetailedFromTable] + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput.eq_2] + by_cases hzero : step.val = 0 + · rw [if_pos hzero, StateT.run_bind, runDirectResolvedDetailedFromTable_bind] + have hnone : context.state.values (.chainStart lay tree leafIdx chainIdx) = none := by + cases hvalue : context.state.values (.chainStart lay tree leafIdx chainIdx) with + | none => rfl + | some output => + have hsame := htable (.chainStart lay tree leafIdx chainIdx) output hvalue + exfalso + apply hunavailable + simpa [TableInputAvailable, hzero, hsame] using hvalue + rw [runDirectResolvedDetailedFromTable_peekCoordinate, hnone] + simp [runDirectResolvedDetailedFromTable] + · rw [if_neg hzero, StateT.run_bind, runDirectResolvedDetailedFromTable_bind] + rcases positionValues_or_first_missing completion context.state + (Position.chain lay tree leafIdx chainIdx step).children + (fun other output hvalue => + htable (.position other) output hvalue) with havailable | + ⟨prior, child, remaining, hchildren, hvalues, hmissing⟩ + · exact (hunavailable (by simpa [TableInputAvailable, hzero] using havailable)).elim + · rw [hchildren, + runDirectResolvedDetailedFromTable_peekPositionValues_of_prefix_values_of_missing + completion context fuel table cache prior remaining child hvalues hmissing] + simp [runDirectResolvedDetailedFromTable] + | leaf lay tree leafIdx => + rw [peekTableInput.eq_3 parameter (.leaf lay tree leafIdx) (by simp), + StateT.run_bind, runDirectResolvedDetailedFromTable_bind] + rcases positionValues_or_first_missing completion context.state + (Position.leaf lay tree leafIdx).children (fun other output hvalue => + htable (.position other) output hvalue) with havailable | + ⟨prior, child, remaining, hchildren, hvalues, hmissing⟩ + · exact (hunavailable havailable).elim + · rw [hchildren, + runDirectResolvedDetailedFromTable_peekPositionValues_of_prefix_values_of_missing + completion context fuel table cache prior remaining child hvalues hmissing] + simp [runDirectResolvedDetailedFromTable] + | node lay tree level nodeIdx => + rw [peekTableInput.eq_3 parameter (.node lay tree level nodeIdx) (by simp), + StateT.run_bind, runDirectResolvedDetailedFromTable_bind] + rcases positionValues_or_first_missing completion context.state + (Position.node lay tree level nodeIdx).children (fun other output hvalue => + htable (.position other) output hvalue) with havailable | + ⟨prior, child, remaining, hchildren, hvalues, hmissing⟩ + · exact (hunavailable havailable).elim + · rw [hchildren, + runDirectResolvedDetailedFromTable_peekPositionValues_of_prefix_values_of_missing + completion context fuel table cache prior remaining child hvalues hmissing] + simp [runDirectResolvedDetailedFromTable] + | ftsLeaf index tree leafIdx => simpa [IsOtsPosition] using hots _ rfl + | ftsNode index tree level nodeIdx => simpa [IsOtsPosition] using hots _ rfl + | ftsRoots index => simpa [IsOtsPosition] using hots _ rfl + +theorem runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (output : HashOutput) + (hvalue : context.state.values coordinate = some output) : + runDirectResolvedDetailedFromTable context fuel table + ((revealCoordinateOutput coordinate).run cache) = + pure (.done ⟨context, fuel, + (output, Function.update cache (.hidden coordinate) (some output)), table⟩) := by + unfold revealCoordinateOutput + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind] + simp only [StateT.run_liftM] + rw [LazyRevealProbe.revealQuery, + runDirectResolvedDetailedFromTable_reveal_query_bind, hvalue] + simp [StateT.run_modify, runDirectResolvedDetailedFromTable] + +theorem runDirectResolvedDetailedFromTable_revealCoordinateOutput_position_of_private + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (output : HashOutput) + (hhidden : context.state.values (.position position) = none) + (hprivate : context.values position = some output) : + runDirectResolvedDetailedFromTable context fuel table + ((revealCoordinateOutput (.position position)).run cache) = + if context.state.hitAt (.position position) output then + pure (.stopped .privateStructuralHit) + else + pure (.done ⟨ + { state := context.state.materialize (.position position) output + values := context.values }, + fuel, + (output, Function.update cache (.hidden (.position position)) (some output)), + table⟩) := by + unfold revealCoordinateOutput + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind] + simp only [StateT.run_liftM] + rw [LazyRevealProbe.revealQuery, + runDirectResolvedDetailedFromTable_reveal_query_bind] + by_cases hhit : context.state.hitAt (.position position) output <;> + simp [hhidden, hprivate, hhit, StateT.run_modify, + runDirectResolvedDetailedFromTable] + +theorem runDirectResolvedDetailedFromTable_revealCoordinateOutput_position_of_fresh + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hhidden : context.state.values (.position position) = none) + (hprivate : context.values position = none) : + runDirectResolvedDetailedFromTable context fuel table + ((revealCoordinateOutput (.position position)).run cache) = (do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt (.position position) output then + pure (.stopped .ordinaryHit) + else + pure (.done ⟨ + { state := context.state.materialize (.position position) output + values := context.values.install position output }, + fuel, + (output, Function.update cache (.hidden (.position position)) (some output)), + table⟩)) := by + unfold revealCoordinateOutput + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind] + simp only [StateT.run_liftM] + rw [LazyRevealProbe.revealQuery, + runDirectResolvedDetailedFromTable_reveal_query_bind] + simp [hhidden, hprivate, StateT.run_modify, runDirectResolvedDetailedFromTable] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output <;> simp [hhit] + +theorem runDirectResolvedDetailedFromTable_publishOrdinaryInput + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (input : HashInput) (output : HashOutput) (context : DeferredContext) + (fuel : Nat) (cache : SplitHashCache) : + runDirectResolvedDetailedFromTable context fuel table + ((publishOrdinaryInput coordinate input output).run cache) = + pure (.done ⟨ + { context with state := context.state.publish coordinate }, + fuel, + (output, Function.update cache (.ordinary input) (some output)), + table⟩) := by + unfold publishOrdinaryInput publishCoordinate + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind] + simp only [StateT.run_liftM, LazyRevealProbe.publishQuery] + rw [runDirectResolvedDetailedFromTable_publish_query_bind] + simp [StateT.run_modify, runDirectResolvedDetailedFromTable] + +noncomputable def revealPublishOrdinaryInput + (coordinate : Coordinate) (input : HashInput) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput := do + let output ← revealCoordinateOutput coordinate + publishOrdinaryInput coordinate input output + +theorem runDirectResolvedDetailedFromTable_revealPublishOrdinaryInput_of_value + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (input : HashInput) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) (output : HashOutput) + (hvalue : context.state.values coordinate = some output) : + runDirectResolvedDetailedFromTable context fuel table + ((revealPublishOrdinaryInput coordinate input).run cache) = + pure (.done ⟨ + { context with state := context.state.publish coordinate }, + fuel, + (output, Function.update + (Function.update cache (.hidden coordinate) (some output)) + (.ordinary input) (some output)), + table⟩) := by + unfold revealPublishOrdinaryInput + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table coordinate + context fuel cache output hvalue] + simp only [pure_bind] + rw [runDirectResolvedDetailedFromTable_publishOrdinaryInput] + +theorem runDirectResolvedDetailedFromTable_revealPublishOrdinaryInput_position_of_private + (table : OtsSecretIndex → HashOutput) (position : Position) + (input : HashInput) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) (output : HashOutput) + (hhidden : context.state.values (.position position) = none) + (hprivate : context.values position = some output) : + runDirectResolvedDetailedFromTable context fuel table + ((revealPublishOrdinaryInput (.position position) input).run cache) = + if context.state.hitAt (.position position) output then + pure (.stopped .privateStructuralHit) + else + pure (.done ⟨ + { state := (context.state.materialize (.position position) output).publish + (.position position) + values := context.values }, + fuel, + (output, Function.update + (Function.update cache (.hidden (.position position)) (some output)) + (.ordinary input) (some output)), + table⟩) := by + unfold revealPublishOrdinaryInput + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_position_of_private table position + context fuel cache output hhidden hprivate] + by_cases hhit : context.state.hitAt (.position position) output <;> simp [hhit] + rw [runDirectResolvedDetailedFromTable_publishOrdinaryInput] + +theorem runDirectResolvedDetailedFromTable_revealPublishOrdinaryInput_position_of_fresh + (table : OtsSecretIndex → HashOutput) (position : Position) + (input : HashInput) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) + (hhidden : context.state.values (.position position) = none) + (hprivate : context.values position = none) : + runDirectResolvedDetailedFromTable context fuel table + ((revealPublishOrdinaryInput (.position position) input).run cache) = (do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt (.position position) output then + pure (.stopped .ordinaryHit) + else + pure (.done ⟨ + { state := (context.state.materialize (.position position) output).publish + (.position position) + values := context.values.install position output }, + fuel, + (output, Function.update + (Function.update cache (.hidden (.position position)) (some output)) + (.ordinary input) (some output)), + table⟩)) := by + unfold revealPublishOrdinaryInput + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_position_of_fresh table position + context fuel cache hhidden hprivate] + rw [bind_assoc] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] + · simp only [hhit, ↓reduceIte, pure_bind] + rw [runDirectResolvedDetailedFromTable_publishOrdinaryInput] + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_splitHashQuery_ordinary + (table : OtsSecretIndex → HashOutput) (input : HashInput) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((splitHashQuery (.ordinary input)).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((splitHashQuery (.ordinary input)).run rightCache)) + (DirectDetailedOrdinaryRunEq table) := by + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + have hcacheAt : leftCache (.ordinary input) = rightCache (.ordinary input) := + congrFun hcache input + cases hlookup : leftCache (.ordinary input) with + | some output => + have hright : rightCache (.ordinary input) = some output := by + rw [← hcacheAt] + exact hlookup + simp only [hright] + exact relTriple_runDirectResolvedDetailed_pure_of_ordinaryMaterialized table output + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + | none => + have hright : rightCache (.ordinary input) = none := by + rw [← hcacheAt] + exact hlookup + simp only [hright] + rw [LazyRevealProbe.hashOutputQuery, + runDirectResolvedDetailedFromTable_hashOutput_query_bind, + runDirectResolvedDetailedFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runDirectResolvedDetailedFromTable] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update, ordinaryQueryCache_update, hcache] + revealed_eq := hrevealed + values_le := hvalues + left_published := hpublished + right_materialized := hrightMaterialized } + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_splitHashQuery_private_left_materialized_right + (table : OtsSecretIndex → HashOutput) (input : HashInput) + (left : DeferredContext) (leftFuel : Nat) (leftCache : SplitHashCache) + (rightComputation : + OracleComp (LazyRevealProbe.World Coordinate) (HashOutput × SplitHashCache)) + (right : DeferredContext) (rightFuel : Nat) + (hprivate : PrivateStructuralHit left) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((splitHashQuery (.ordinary input)).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table rightComputation) + (DirectDetailedOrdinaryRunEq table) := by + have hbase := relTriple_true + (runDirectResolvedDetailedFromTable left leftFuel table + ((splitHashQuery (.ordinary input)).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table rightComputation) + have hleftSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (runDirectResolvedDetailedFromTable left leftFuel table + ((splitHashQuery (.ordinary input)).run leftCache))) + (fun result hresult => hresult) + have hbothSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupport + apply relTriple_post_mono hbothSupport + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨_trivial, hleftResult⟩, hrightResult⟩ + have hleftDone : ∃ result, leftResult = .done result ∧ result.context = left := by + rw [splitHashQuery_run_eq] at hleftResult + cases hlookup : leftCache (.ordinary input) with + | some output => + simp only [hlookup] at hleftResult + simp [runDirectResolvedDetailedFromTable] at hleftResult + subst leftResult + exact ⟨_, rfl, rfl⟩ + | none => + simp only [hlookup, LazyRevealProbe.hashOutputQuery, + runDirectResolvedDetailedFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hleftResult + obtain ⟨output, _houtput, hrest⟩ := hleftResult + simp [runDirectResolvedDetailedFromTable] at hrest + subst leftResult + exact ⟨_, rfl, rfl⟩ + obtain ⟨leftRunResult, rfl, hleftContext⟩ := hleftDone + have hrightShape := directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + rightComputation right.state rightFuel table rightResult (by + rw [← hrightMaterialized] + exact hrightResult) + cases rightResult with + | stopped reason => + cases reason with + | privateStructuralHit => contradiction + | ordinaryHit => trivial + | fuelExhausted => trivial + | done rightRunResult => + right + left + rwa [hleftContext] + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_revealCoordinateOutput_position + (table : OtsSecretIndex → HashOutput) (position : Position) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((revealCoordinateOutput (.position position)).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((revealCoordinateOutput (.position position)).run rightCache)) + (DirectDetailedOrdinaryRunEq table) := by + cases hleftValue : left.state.values (.position position) with + | some output => + have hrightValue : right.state.values (.position position) = some output := + hvalues (.position position) output hleftValue + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + (.position position) left leftFuel leftCache output hleftValue, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + (.position position) right rightFuel rightCache output hrightValue] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache] + revealed_eq := hrevealed + values_le := hvalues + left_published := hpublished + right_materialized := hrightMaterialized } + | none => + cases hrightValue : right.state.values (.position position) with + | some output => + have hprivate := hcontext.view.privateValue_of_left_hidden_of_right_materialized + position output hleftValue hrightValue + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_position_of_private + table position left leftFuel leftCache output hleftValue hprivate, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + (.position position) right rightFuel rightCache output hrightValue] + by_cases hhit : left.state.hitAt (.position position) output + · simp only [hhit, ↓reduceIte] + exact relTriple_pure_pure trivial + · simp only [hhit, ↓reduceIte] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext.materialize_position_left position output + hleftValue hprivate + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache] + revealed_eq := by + simpa [LazyRevealProbe.State.materialize] using hrevealed + values_le := hvalues.materialize_left (.position position) output hrightValue + left_published := hpublished.materialize (.position position) output + right_materialized := hrightMaterialized } + | none => + have hrightPrivate : right.values position = none := by + rw [hrightMaterialized] + simpa [directDeferredContext, directDeferredValues] using hrightValue + have hleftPositionValue : left.positionValue position = none := by + change resolvedCompletionValue table left (.position position) = none + rw [hcontext.view.valueEq] + simp [resolvedCompletionValue, DeferredContext.positionValue, hrightValue, + hrightPrivate] + have hleftPrivate : left.values position = none := by + simpa [DeferredContext.positionValue, hleftValue] using hleftPositionValue + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_position_of_fresh + table position left leftFuel leftCache hleftValue hleftPrivate, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_position_of_fresh + table position right rightFuel rightCache hrightValue hrightPrivate] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + by_cases hleftHit : left.state.hitAt (.position position) leftOutput + · have hresolvedNone : + resolvedCompletionValue table left (.position position) = none := by + simpa [resolvedCompletionValue] using hleftPositionValue + have hrightHit : right.state.hitAt (.position position) leftOutput := by + unfold LazyRevealProbe.State.hitAt at hleftHit ⊢ + exact hcontext.view.pendingLE (.position position) hresolvedNone hleftHit + simp only [hleftHit, hrightHit, ↓reduceIte] + exact relTriple_pure_pure trivial + · by_cases hrightHit : right.state.hitAt (.position position) leftOutput + · simp only [hleftHit, hrightHit, ↓reduceIte] + exact relTriple_pure_pure trivial + · simp only [hleftHit, hrightHit, ↓reduceIte] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext.materialize_position_both position leftOutput + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, + hcache] + revealed_eq := by + simpa [LazyRevealProbe.State.materialize] using hrevealed + values_le := hvalues.materialize_both (.position position) leftOutput + left_published := hpublished.materialize (.position position) leftOutput + right_materialized := by + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_materialize_position] } + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_revealPublishOrdinaryInput_position + (table : OtsSecretIndex → HashOutput) (position : Position) (input : HashInput) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((revealPublishOrdinaryInput (.position position) input).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((revealPublishOrdinaryInput (.position position) input).run rightCache)) + (DirectDetailedOrdinaryRunEq table) := by + cases hleftValue : left.state.values (.position position) with + | some output => + have hrightValue : right.state.values (.position position) = some output := + hvalues (.position position) output hleftValue + rw [runDirectResolvedDetailedFromTable_revealPublishOrdinaryInput_of_value table + (.position position) input left leftFuel leftCache output hleftValue, + runDirectResolvedDetailedFromTable_revealPublishOrdinaryInput_of_value table + (.position position) input right rightFuel rightCache output hrightValue] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext.publish (.position position) + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update, ordinaryQueryCache_update, + ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache] + revealed_eq := by + simpa [LazyRevealProbe.State.publish] using + congrArg (insert (.position position)) hrevealed + values_le := hvalues + left_published := + hpublished.publish_of_value (.position position) output hleftValue + right_materialized := by + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_publish] } + | none => + cases hrightValue : right.state.values (.position position) with + | some output => + have hprivate := hcontext.view.privateValue_of_left_hidden_of_right_materialized + position output hleftValue hrightValue + rw [runDirectResolvedDetailedFromTable_revealPublishOrdinaryInput_position_of_private + table position input left leftFuel leftCache output hleftValue hprivate, + runDirectResolvedDetailedFromTable_revealPublishOrdinaryInput_of_value table + (.position position) input right rightFuel rightCache output hrightValue] + by_cases hhit : left.state.hitAt (.position position) output + · simp only [hhit, ↓reduceIte] + exact relTriple_pure_pure trivial + · simp only [hhit, ↓reduceIte] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := + (hcontext.materialize_position_left position output hleftValue hprivate).publish + (.position position) + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update, ordinaryQueryCache_update, + ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache] + revealed_eq := by + simpa [LazyRevealProbe.State.materialize, LazyRevealProbe.State.publish] using + congrArg (insert (.position position)) hrevealed + values_le := hvalues.materialize_left (.position position) output hrightValue + left_published := + (hpublished.materialize (.position position) output).publish_of_value + (.position position) output (by + simp [LazyRevealProbe.State.materialize]) + right_materialized := by + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_publish] } + | none => + have hrightPrivate : right.values position = none := by + rw [hrightMaterialized] + simpa [directDeferredContext, directDeferredValues] using hrightValue + have hleftPositionValue : left.positionValue position = none := by + change resolvedCompletionValue table left (.position position) = none + rw [hcontext.view.valueEq] + simp [resolvedCompletionValue, DeferredContext.positionValue, hrightValue, + hrightPrivate] + have hleftPrivate : left.values position = none := by + simpa [DeferredContext.positionValue, hleftValue] using hleftPositionValue + rw [runDirectResolvedDetailedFromTable_revealPublishOrdinaryInput_position_of_fresh + table position input left leftFuel leftCache hleftValue hleftPrivate, + runDirectResolvedDetailedFromTable_revealPublishOrdinaryInput_position_of_fresh + table position input right rightFuel rightCache hrightValue hrightPrivate] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + by_cases hleftHit : left.state.hitAt (.position position) leftOutput + · have hresolvedNone : + resolvedCompletionValue table left (.position position) = none := by + simpa [resolvedCompletionValue] using hleftPositionValue + have hrightHit : right.state.hitAt (.position position) leftOutput := by + unfold LazyRevealProbe.State.hitAt at hleftHit ⊢ + exact hcontext.view.pendingLE (.position position) hresolvedNone hleftHit + simp only [hleftHit, hrightHit, ↓reduceIte] + exact relTriple_pure_pure trivial + · by_cases hrightHit : right.state.hitAt (.position position) leftOutput + · simp only [hleftHit, hrightHit, ↓reduceIte] + exact relTriple_pure_pure trivial + · simp only [hleftHit, hrightHit, ↓reduceIte] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := + (hcontext.materialize_position_both position leftOutput).publish + (.position position) + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update, ordinaryQueryCache_update, + ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, + hcache] + revealed_eq := by + simpa [LazyRevealProbe.State.materialize, LazyRevealProbe.State.publish] using + congrArg (insert (.position position)) hrevealed + values_le := hvalues.materialize_both (.position position) leftOutput + left_published := + (hpublished.materialize (.position position) leftOutput).publish_of_value + (.position position) leftOutput (by + simp [LazyRevealProbe.State.materialize]) + right_materialized := by + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_materialize_position, + directDeferredValues_publish] } + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_resolveKnownInput_available + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (position : Position) (input : HashInput) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (completion : Coordinate → HashOutput) + (havailable : TableInputAvailable completion left.state (.position position)) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((resolveKnownInput parameter (.position position) input).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((resolveKnownInput parameter (.position position) input).run rightCache)) + (DirectDetailedOrdinaryRunEq table) := by + have hrightAvailable : + TableInputAvailable completion right.state (.position position) := + havailable.monoValues hvalues + unfold resolveKnownInput + rw [StateT.run_bind, StateT.run_bind, + runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekTableInput_of_available parameter completion left + leftFuel table leftCache (.position position) havailable, + runDirectResolvedDetailedFromTable_peekTableInput_of_available parameter completion right + rightFuel table rightCache (.position position) hrightAvailable] + simp only [pure_bind] + by_cases heq : tableInput parameter completion (.position position) = input + · simp only [heq, ↓reduceIte] + simpa [revealPublishOrdinaryInput, publishOrdinaryInput] using + relTriple_runDirectResolvedDetailed_revealPublishOrdinaryInput_position table position + input left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + · simp only [heq, ↓reduceIte] + exact relTriple_runDirectResolvedDetailed_splitHashQuery_ordinary table input + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed hvalues + hpublished hrightMaterialized + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_resolveKnownInput_completionOrdinary + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (coordinate : Coordinate) (input : HashInput) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hots : ∀ position, coordinate = .position position → IsOtsPosition position) + (hordinary : CompletionOrdinaryInput parameter table left input) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((resolveKnownInput parameter coordinate input).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((resolveKnownInput parameter coordinate input).run rightCache)) + (DirectDetailedOrdinaryRunEq table) := by + obtain ⟨completion, hrightCompletion⟩ := hcontext.rightCompletable + have hleftCompletion : DeferredCompletion table left completion := + hcontext.view.deferredCompletion_left completion hrightCompletion + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + unfold resolveKnownInput + simp only [peekTableInput, pure_bind] + exact relTriple_runDirectResolvedDetailed_splitHashQuery_ordinary table input + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + | position position => + have hotsPosition : IsOtsPosition position := hots position rfl + unfold resolveKnownInput + rw [StateT.run_bind, StateT.run_bind, + runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_bind] + by_cases hleftAvailable : + TableInputAvailable completion left.state (.position position) + · have hrightAvailable : + TableInputAvailable completion right.state (.position position) := + hleftAvailable.monoValues hvalues + rw [runDirectResolvedDetailedFromTable_peekTableInput_of_available parameter completion + left leftFuel table leftCache (.position position) hleftAvailable, + runDirectResolvedDetailedFromTable_peekTableInput_of_available parameter completion + right rightFuel table rightCache (.position position) hrightAvailable] + simp only [pure_bind] + have hne : tableInput parameter completion (.position position) ≠ input := by + intro heq + exact hordinary completion hleftCompletion position hotsPosition heq.symm + rw [if_neg hne] + exact relTriple_runDirectResolvedDetailed_splitHashQuery_ordinary table input + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + · rw [runDirectResolvedDetailedFromTable_peekTableInput_of_unavailable parameter completion + left leftFuel table leftCache (.position position) hleftCompletion + (fun other heq => by cases heq; exact hotsPosition) hleftAvailable] + simp only [pure_bind] + by_cases hrightAvailable : + TableInputAvailable completion right.state (.position position) + · rw [runDirectResolvedDetailedFromTable_peekTableInput_of_available parameter completion + right rightFuel table rightCache (.position position) hrightAvailable] + simp only [pure_bind] + have hne : tableInput parameter completion (.position position) ≠ input := by + intro heq + exact hordinary completion hleftCompletion position hotsPosition heq.symm + rw [if_neg hne] + exact relTriple_runDirectResolvedDetailed_splitHashQuery_ordinary table input + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + · rw [runDirectResolvedDetailedFromTable_peekTableInput_of_unavailable parameter completion + right rightFuel table rightCache (.position position) hrightCompletion + (fun other heq => by cases heq; exact hotsPosition) hrightAvailable] + simp only [pure_bind] + exact relTriple_runDirectResolvedDetailed_splitHashQuery_ordinary table input + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_prepareLeafInputProbe + (table : OtsSecretIndex → HashOutput) (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (position : Position) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcoordinate : candidate.coordinate = .position position) + (hcontext : FinalizationContextLE table left right) + (hpositive : 0 < leftFuel) (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((prepareLeafInputProbe input candidate lay tree leafIdx).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((prepareLeafInputProbe input candidate lay tree leafIdx).run rightCache)) + (DirectDetailedOrdinaryRunEq table) := by + have hcandidate : candidate = ⟨.position position, candidate.candidate⟩ := by + rcases candidate with ⟨coordinate, candidateDigest⟩ + simp only at hcoordinate ⊢ + subst coordinate + rfl + rw [runDirectResolvedDetailedFromTable_prepareLeafInputProbe, + runDirectResolvedDetailedFromTable_prepareLeafInputProbe] + cases hleftValue : left.state.values candidate.coordinate with + | some leftOutput => + have hrightValue := hvalues candidate.coordinate leftOutput hleftValue + rw [hrightValue] + exact relTriple_runDirectResolvedDetailed_probeFirstMissing_positions table input + 0 (Position.leaf lay tree leafIdx).children left right leftFuel rightFuel + leftCache rightCache hcontext hpositive hfuel hcache hrevealed hvalues hpublished + hrightMaterialized + | none => + cases hrightValue : right.state.values candidate.coordinate with + | none => + exact relTriple_runDirectResolvedDetailed_probe_aligned table + candidate.coordinate candidate.candidate left right leftFuel rightFuel + leftCache rightCache hcontext ⟨hpositive, hfuel⟩ hcache hrevealed hvalues + hpublished hrightMaterialized + | some output => + have hleftPosition : left.state.values (.position position) = none := by + simpa [hcoordinate] using hleftValue + have hrightPosition : right.state.values (.position position) = some output := by + simpa [hcoordinate] using hrightValue + have hprivate := + hcontext.view.privateValue_of_left_hidden_of_right_materialized position output + hleftPosition hrightPosition + rw [hcandidate] + exact + relTriple_runDirectResolvedDetailed_probe_private_position_probeFirstMissing_right + table input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + position candidate.candidate output left right leftFuel rightFuel + leftCache rightCache hcontext ⟨hpositive, hfuel⟩ hcache hrevealed hvalues + hpublished hrightMaterialized hleftPosition hprivate + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_probe_skip_private_position + (table : OtsSecretIndex → HashOutput) (position : Position) + (candidate : Digest) (output : HashOutput) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : 0 < leftFuel ∧ leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hhidden : left.state.values (.position position) = none) + (hprivate : left.values position = some output) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((probe ⟨.position position, candidate⟩).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((pure () : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit).run rightCache)) + (DirectDetailedOrdinaryRunEq table) := by + obtain ⟨remaining, rfl⟩ := Nat.exists_eq_succ_of_ne_zero (by omega : leftFuel ≠ 0) + unfold probe + rw [StateT.run_liftM, StateT.run_pure] + unfold LazyRevealProbe.probeQuery + simp only + rw [runDirectResolvedDetailedFromTable_probe_query_bind, + runDirectResolvedDetailedFromTable_pure] + have hleftNotRevealed : Coordinate.position position ∉ left.state.revealed := by + intro hrevealedPosition + exact (hpublished (.position position) hrevealedPosition) hhidden + simp only [hleftNotRevealed, ↓reduceIte] + apply relTriple_pure_pure + by_cases hhit : truncateHash output = candidate + · right + left + exact (privateStructuralHit_addPending_iff left position output candidate + (not_privateStructuralHit_of_deferredCompletable hcontext.leftCompletable) + hhidden hprivate).2 hhit + · left + exact + { value_eq := rfl + context_le := hcontext.addPending_left_of_resolved + (.position position) candidate output (by + change left.positionValue position = some output + simp [DeferredContext.positionValue, hhidden, hprivate]) hhit + remaining_le := by + show remaining ≤ rightFuel + omega + left_table := rfl + right_table := rfl + cache_eq := hcache + revealed_eq := hrevealed + values_le := hvalues + left_published := hpublished + right_materialized := hrightMaterialized } + +set_option maxHeartbeats 800000 in +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_probingHashQuery_chain + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (step : ChainStep) + (hprobe : decodeProbe? parameter input = some candidate) + (hposition : decodePosition? parameter input = + some (.chain lay tree leafIdx chainIdx step)) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hpositive : 0 < leftFuel) (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((probingHashQuery parameter input).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQuery parameter input).run rightCache)) + (DirectDetailedOrdinaryRunEq table) := by + have hmatches := (decodeProbe?_eq_some_iff parameter input candidate).1 hprobe + have houtput := decodeProbe?_outputCoordinate_eq_position parameter input candidate + (.chain lay tree leafIdx chainIdx step) hprobe hposition + obtain ⟨leftRemaining, rfl⟩ := Nat.exists_eq_succ_of_ne_zero (by omega : leftFuel ≠ 0) + obtain ⟨rightRemaining, hrightFuel⟩ := + Nat.exists_eq_succ_of_ne_zero (by omega : rightFuel ≠ 0) + subst rightFuel + have hremaining : leftRemaining ≤ rightRemaining := by omega + unfold probingHashQuery + rw [hprobe, hposition] + simp only + rw [StateT.run_bind, StateT.run_bind, + runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_bind] + unfold probe + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.probeQuery, + runDirectResolvedDetailedFromTable_probe_query_bind, + runDirectResolvedDetailedFromTable_probe_query_bind] + by_cases hleftNotRevealed : candidate.coordinate ∉ left.state.revealed + · have hrightNotRevealed : candidate.coordinate ∉ right.state.revealed := by + rwa [← hrevealed] + simp only [hleftNotRevealed, hrightNotRevealed, ↓reduceIte, + runDirectResolvedDetailedFromTable] + let nextLeft : DeferredContext := + { left with state := left.state.addPending candidate.coordinate candidate.candidate } + let nextRight : DeferredContext := + { right with state := right.state.addPending candidate.coordinate candidate.candidate } + by_cases hnextCompletable : DeferredCompletable table nextRight + · have hnextContext : FinalizationContextLE table nextLeft nextRight := + hcontext.addPending_both_of_right_completable candidate.coordinate + candidate.candidate hnextCompletable + have hpending : (candidate.coordinate, candidate.candidate) ∈ + nextLeft.state.pending := by + simp [nextLeft, LazyRevealProbe.State.addPending] + have hordinary := completionOrdinaryInput_of_pending_decodedProbe (table := table) + hprobe hpending + have hnextRightMaterialized : + nextRight = directDeferredContext nextRight.state := by + unfold nextRight + rw [hrightMaterialized] + simp only [directDeferredContext, directDeferredValues_addPending] + rw [houtput] + exact relTriple_runDirectResolvedDetailed_resolveKnownInput_completionOrdinary + parameter table (.position (.chain lay tree leafIdx chainIdx step)) input + nextLeft nextRight leftRemaining rightRemaining leftCache rightCache hnextContext + hremaining hcache hrevealed hvalues + (by simpa [nextLeft, PublishedValues, LazyRevealProbe.State.addPending] using + hpublished) + hnextRightMaterialized + (fun position heq => by cases heq; simp [IsOtsPosition]) hordinary + · have hnextDoomed : DoomedResolvedContext table nextRight := + ⟨hcontext.view.rightConsistent.addPending candidate.coordinate candidate.candidate, + hcontext.view.rightStarts.addPending candidate.coordinate candidate.candidate, + hnextCompletable⟩ + have hnextRightMaterialized : + nextRight = directDeferredContext nextRight.state := by + unfold nextRight + rw [hrightMaterialized] + simp only [directDeferredContext, directDeferredValues_addPending] + exact relTriple_runDirectResolvedDetailed_of_right_materializedDoomed table + (runDirectResolvedDetailedFromTable nextLeft leftRemaining table + ((resolveKnownInput parameter candidate.outputCoordinate input).run leftCache)) + ((resolveKnownInput parameter candidate.outputCoordinate input).run rightCache) + nextRight rightRemaining hnextDoomed hnextRightMaterialized + · have hleftRevealed : candidate.coordinate ∈ left.state.revealed := by + simpa using hleftNotRevealed + have hrightRevealed : candidate.coordinate ∈ right.state.revealed := by + rwa [← hrevealed] + simp only [hleftRevealed, hrightRevealed, ↓reduceIte, + runDirectResolvedDetailedFromTable] + obtain ⟨completion, hrightCompletion⟩ := hcontext.rightCompletable + have hleftCompletion := + hcontext.view.deferredCompletion_left completion hrightCompletion + have havailable := tableInputAvailable_chain_of_probe_revealed hleftCompletion hpublished + hmatches houtput hleftRevealed + rw [houtput] + exact relTriple_runDirectResolvedDetailed_resolveKnownInput_available parameter table + (.chain lay tree leafIdx chainIdx step) input left right leftRemaining rightRemaining + leftCache rightCache completion havailable hcontext hremaining hcache hrevealed hvalues + hpublished hrightMaterialized + +set_option maxRecDepth 100000 in +theorem preparedLeaf_available_or_completionOrdinary + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (hprobe : decodeProbe? parameter input = some candidate) + (hposition : decodePosition? parameter input = some (.leaf lay tree leafIdx)) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (completion : Coordinate → HashOutput) + (hcompletion : DeferredCompletion table context completion) + (hpositive : 0 < fuel) (hpublished : PublishedValues context.state) + (result : ResolvedRunResult (Unit × SplitHashCache)) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((prepareLeafInputProbe input candidate lay tree leafIdx).run cache))) : + TableInputAvailable completion result.context.state + (.position (.leaf lay tree leafIdx)) ∨ + CompletionOrdinaryInput parameter table result.context input := by + obtain ⟨remainingFuel, rfl⟩ := Nat.exists_eq_succ_of_ne_zero (by omega : fuel ≠ 0) + rw [runDirectResolvedDetailedFromTable_prepareLeafInputProbe] at hresult + cases hsourceValue : context.state.values candidate.coordinate with + | none => + rw [hsourceValue] at hresult + have hnotRevealed : candidate.coordinate ∉ context.state.revealed := by + intro hrevealed + exact (hpublished candidate.coordinate hrevealed) hsourceValue + unfold probe at hresult + rw [StateT.run_liftM, LazyRevealProbe.probeQuery, + runDirectResolvedDetailedFromTable_probe_query_bind] at hresult + simp [hnotRevealed, runDirectResolvedDetailedFromTable] at hresult + subst result + right + apply completionOrdinaryInput_of_pending_decodedProbe (table := table) hprobe + simp [LazyRevealProbe.State.addPending] + | some sourceOutput => + rw [hsourceValue] at hresult + rcases positionValues_or_first_missing completion context.state + (Position.leaf lay tree leafIdx).children + (fun other output hvalue => (hcompletion.1 (.position other) output hvalue).symm) with + havailable | ⟨prior, child, remaining, hchildren, hvalues, hmissing⟩ + · let coordinates := (Position.leaf lay tree leafIdx).children.map Coordinate.position + have hcoordinateValues : ∀ coordinate, coordinate ∈ coordinates → + context.state.values coordinate = some (completion coordinate) := by + intro coordinate hcoordinate + obtain ⟨position, hpositionMem, rfl⟩ := List.mem_map.1 hcoordinate + exact havailable position hpositionMem + rw [runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_of_values + completion input context cache (remainingFuel + 1) table 0 coordinates + hcoordinateValues] at hresult + simp at hresult + subst result + left + simpa [TableInputAvailable] using havailable + · let priorCoordinates := prior.map Coordinate.position + let remainingCoordinates := remaining.map Coordinate.position + have hcoordinates : + (Position.leaf lay tree leafIdx).children.map Coordinate.position = + priorCoordinates ++ .position child :: remainingCoordinates := by + simp [hchildren, priorCoordinates, remainingCoordinates] + have hcoordinateValues : ∀ coordinate, coordinate ∈ priorCoordinates → + context.state.values coordinate = some (completion coordinate) := by + intro coordinate hcoordinate + obtain ⟨position, hpositionMem, rfl⟩ := List.mem_map.1 hcoordinate + exact hvalues position hpositionMem + have hnotRevealed : .position child ∉ context.state.revealed := by + intro hrevealed + exact (hpublished (.position child) hrevealed) hmissing + rw [hcoordinates, + runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_of_prefix_values_of_missing + completion input context cache remainingFuel 0 priorCoordinates remainingCoordinates + (.position child) table hcoordinateValues hmissing hnotRevealed] at hresult + simp at hresult + subst result + right + apply completionOrdinaryInput_of_pending_leaf_child (table := table) + hposition hchildren + have hlength : priorCoordinates.length = prior.length := by simp [priorCoordinates] + simp [hlength, LazyRevealProbe.State.addPending] + +set_option maxRecDepth 100000 in +theorem preparedLeaf_privateStructuralHit_has_missingChild + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (hprobe : decodeProbe? parameter input = some candidate) + (hposition : decodePosition? parameter input = some (.leaf lay tree leafIdx)) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hcompletable : DeferredCompletable table context) + (hpositive : 0 < fuel) (hpublished : PublishedValues context.state) + (result : ResolvedRunResult (Unit × SplitHashCache)) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((prepareLeafInputProbe input candidate lay tree leafIdx).run cache))) + (hprivate : PrivateStructuralHit result.context) : + ∃ child ∈ (Position.leaf lay tree leafIdx).children, + result.context.state.values (.position child) = none := by + obtain ⟨completion, hcompletion⟩ := hcompletable + have hclean := hcompletion.not_privateStructuralHit + have hcandidate := decodeProbe?_leaf_eq parameter input candidate lay tree leafIdx + hprobe hposition + subst candidate + obtain ⟨remainingFuel, rfl⟩ := Nat.exists_eq_succ_of_ne_zero (by omega : fuel ≠ 0) + rw [runDirectResolvedDetailedFromTable_prepareLeafInputProbe] at hresult + cases hsourceValue : context.state.values + (.position (.chain lay tree leafIdx ⟨0, by norm_num [numChains]⟩ + Position.lastChainStep)) with + | none => + rw [hsourceValue] at hresult + have hnotRevealed : + (.position (.chain lay tree leafIdx ⟨0, by norm_num [numChains]⟩ + Position.lastChainStep) : Coordinate) ∉ context.state.revealed := by + intro hrevealed + exact (hpublished _ hrevealed) hsourceValue + unfold probe at hresult + rw [StateT.run_liftM, LazyRevealProbe.probeQuery, + runDirectResolvedDetailedFromTable_probe_query_bind] at hresult + simp [hnotRevealed, runDirectResolvedDetailedFromTable] at hresult + subst result + have hnew := privateStructuralHit_addPending_imp context + (.position (.chain lay tree leafIdx ⟨0, by norm_num [numChains]⟩ + Position.lastChainStep)) (slotDigest 0 input) hprivate + rcases hnew with hold | ⟨child, output, hcoordinate, hhidden, _hvalue, _hmatch⟩ + · exact False.elim (hclean hold) + · have hchild : child = + .chain lay tree leafIdx ⟨0, by norm_num [numChains]⟩ + Position.lastChainStep := by + simpa using hcoordinate.symm + subst child + refine ⟨.chain lay tree leafIdx ⟨0, by norm_num [numChains]⟩ + Position.lastChainStep, ?_, ?_⟩ + · simp [Position.children] + · simpa [LazyRevealProbe.State.addPending] using hhidden + | some sourceOutput => + rw [hsourceValue] at hresult + rcases positionValues_or_first_missing completion context.state + (Position.leaf lay tree leafIdx).children + (fun other output hvalue => (hcompletion.1 (.position other) output hvalue).symm) with + havailable | ⟨prior, child, remaining, hchildren, hvalues, hmissing⟩ + · let coordinates := (Position.leaf lay tree leafIdx).children.map Coordinate.position + have hcoordinateValues : ∀ coordinate, coordinate ∈ coordinates → + context.state.values coordinate = some (completion coordinate) := by + intro coordinate hcoordinate + obtain ⟨position, hpositionMem, rfl⟩ := List.mem_map.1 hcoordinate + exact havailable position hpositionMem + rw [runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_of_values + completion input context cache (remainingFuel + 1) table 0 coordinates + hcoordinateValues] at hresult + simp at hresult + subst result + exact False.elim (hclean hprivate) + · let priorCoordinates := prior.map Coordinate.position + let remainingCoordinates := remaining.map Coordinate.position + have hcoordinates : + (Position.leaf lay tree leafIdx).children.map Coordinate.position = + priorCoordinates ++ .position child :: remainingCoordinates := by + simp [hchildren, priorCoordinates, remainingCoordinates] + have hcoordinateValues : ∀ coordinate, coordinate ∈ priorCoordinates → + context.state.values coordinate = some (completion coordinate) := by + intro coordinate hcoordinate + obtain ⟨position, hpositionMem, rfl⟩ := List.mem_map.1 hcoordinate + exact hvalues position hpositionMem + have hnotRevealed : .position child ∉ context.state.revealed := by + intro hrevealed + exact (hpublished (.position child) hrevealed) hmissing + rw [hcoordinates, + runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_of_prefix_values_of_missing + completion input context cache remainingFuel 0 priorCoordinates remainingCoordinates + (.position child) table hcoordinateValues hmissing hnotRevealed] at hresult + simp at hresult + subst result + have hnew := privateStructuralHit_addPending_imp context (.position child) + (slotDigest priorCoordinates.length input) hprivate + rcases hnew with hold | ⟨other, output, hcoordinate, hhidden, _hvalue, _hmatch⟩ + · exact False.elim (hclean hold) + · have hother : other = child := by simpa using hcoordinate.symm + subst other + refine ⟨child, by simp [hchildren], ?_⟩ + simpa [LazyRevealProbe.State.addPending] using hhidden + +set_option maxRecDepth 100000 in +theorem runDirectResolvedDetailedFromTable_peekPositionValues_of_mem_none + (positions : List Position) (child : Position) + (hchild : child ∈ positions) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hmissing : context.state.values (.position child) = none) : + runDirectResolvedDetailedFromTable context fuel table + ((peekPositionValues positions).run cache) = + pure (.done ⟨context, fuel, (none, cache), table⟩) := by + induction positions with + | nil => simp at hchild + | cons head remaining ih => + rw [peekPositionValues, StateT.run_bind, + runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekCoordinate] + by_cases heq : head = child + · subst head + rw [hmissing] + simp [runDirectResolvedDetailedFromTable] + · have htail : child ∈ remaining := by + rcases List.mem_cons.1 hchild with hsame | htail + · exact False.elim (heq hsame.symm) + · exact htail + cases hhead : context.state.values (.position head) with + | none => simp [runDirectResolvedDetailedFromTable] + | some output => + rw [show truncateHash <$> some output = some (truncateHash output) by rfl] + simp only [pure_bind] + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + ih htail] + rfl + +set_option maxRecDepth 100000 in +theorem runDirectResolvedDetailedFromTable_resolveKnownInput_leaf_of_missingChild + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (child : Position) (hchild : child ∈ (Position.leaf lay tree leafIdx).children) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hmissing : context.state.values (.position child) = none) : + runDirectResolvedDetailedFromTable context fuel table + ((resolveKnownInput parameter (.position (.leaf lay tree leafIdx)) input).run cache) = + runDirectResolvedDetailedFromTable context fuel table + ((splitHashQuery (.ordinary input)).run cache) := by + unfold resolveKnownInput + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + peekTableInput.eq_3 parameter (.leaf lay tree leafIdx) (by simp), + StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekPositionValues_of_mem_none + (Position.leaf lay tree leafIdx).children child hchild context fuel table cache hmissing] + simp [runDirectResolvedDetailedFromTable] + +set_option maxHeartbeats 800000 in +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_probingHashQuery_leaf + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (hprobe : decodeProbe? parameter input = some candidate) + (hposition : decodePosition? parameter input = some (.leaf lay tree leafIdx)) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hpositive : 0 < leftFuel) (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((probingHashQuery parameter input).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQuery parameter input).run rightCache)) + (DirectDetailedOrdinaryRunEq table) := by + have hcandidate := decodeProbe?_leaf_eq parameter input candidate lay tree leafIdx + hprobe hposition + have hcoordinate : candidate.coordinate = + .position (.chain lay tree leafIdx ⟨0, by norm_num [numChains]⟩ + Position.lastChainStep) := by + rw [hcandidate] + have houtput := decodeProbe?_outputCoordinate_eq_position parameter input candidate + (.leaf lay tree leafIdx) hprobe hposition + unfold probingHashQuery + rw [hprobe, hposition] + simp only + rw [StateT.run_bind, StateT.run_bind] + apply relTriple_runDirectResolvedDetailed_bind_with_support table + ((prepareLeafInputProbe input candidate lay tree leafIdx).run leftCache) + ((prepareLeafInputProbe input candidate lay tree leafIdx).run rightCache) + (fun _ cache => + (resolveKnownInput parameter candidate.outputCoordinate input).run cache) + (fun _ cache => + (resolveKnownInput parameter candidate.outputCoordinate input).run cache) + left right leftFuel rightFuel + · exact relTriple_runDirectResolvedDetailed_prepareLeafInputProbe table input candidate + lay tree leafIdx + (.chain lay tree leafIdx ⟨0, by norm_num [numChains]⟩ Position.lastChainStep) + left right leftFuel rightFuel leftCache rightCache hcoordinate hcontext hpositive hfuel hcache + hrevealed hvalues hpublished hrightMaterialized + · intro leftResult rightResult hleftSupport hrightSupport hrelation + have hrightResultMaterialized : + rightResult.context = directDeferredContext rightResult.context.state := by + have hshape := directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + ((prepareLeafInputProbe input candidate lay tree leafIdx).run rightCache) + right.state rightFuel table (.done rightResult) (by + rw [← hrightMaterialized] + exact hrightSupport) + exact hshape + obtain ⟨completion, hcompletion⟩ := hcontext.leftCompletable + rcases preparedLeaf_available_or_completionOrdinary parameter table input candidate + lay tree leafIdx hprobe hposition left leftFuel leftCache completion hcompletion + hpositive hpublished leftResult hleftSupport with havailable | hordinary + · rw [hrelation.left_table, hrelation.right_table, houtput] + exact relTriple_runDirectResolvedDetailed_resolveKnownInput_available parameter table + (.leaf lay tree leafIdx) input leftResult.context rightResult.context + leftResult.remaining rightResult.remaining leftResult.value.2 rightResult.value.2 + completion havailable hrelation.context_le hrelation.remaining_le + hrelation.cache_eq hrelation.revealed_eq hrelation.values_le + hrelation.left_published hrightResultMaterialized + · rw [hrelation.left_table, hrelation.right_table, houtput] + exact relTriple_runDirectResolvedDetailed_resolveKnownInput_completionOrdinary + parameter table (.position (.leaf lay tree leafIdx)) input leftResult.context + rightResult.context leftResult.remaining rightResult.remaining leftResult.value.2 + rightResult.value.2 hrelation.context_le hrelation.remaining_le + hrelation.cache_eq hrelation.revealed_eq hrelation.values_le + hrelation.left_published hrightResultMaterialized + (fun position heq => by cases heq; simp [IsOtsPosition]) hordinary + · intro leftResult rightResult hleftSupport hrightSupport hprivate + have hleftCore := resolvedCore_of_mem_runDirectResolvedFromTable + ((prepareLeafInputProbe input candidate lay tree leafIdx).run leftCache) + left leftFuel table leftResult hcontext.view.leftConsistent hcontext.view.leftStarts + (mem_support_runDirectResolvedFromTable_of_done_detailed + ((prepareLeafInputProbe input candidate lay tree leafIdx).run leftCache) + left leftFuel table leftResult hleftSupport) + have hrightCore := resolvedCore_of_mem_runDirectResolvedFromTable + ((prepareLeafInputProbe input candidate lay tree leafIdx).run rightCache) + right rightFuel table rightResult hcontext.view.rightConsistent hcontext.view.rightStarts + (mem_support_runDirectResolvedFromTable_of_done_detailed + ((prepareLeafInputProbe input candidate lay tree leafIdx).run rightCache) + right rightFuel table rightResult hrightSupport) + have hrightResultMaterialized : + rightResult.context = directDeferredContext rightResult.context.state := by + have hshape := directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + ((prepareLeafInputProbe input candidate lay tree leafIdx).run rightCache) + right.state rightFuel table (.done rightResult) (by + rw [← hrightMaterialized] + exact hrightSupport) + exact hshape + obtain ⟨child, hchild, hmissing⟩ := + preparedLeaf_privateStructuralHit_has_missingChild parameter table input candidate + lay tree leafIdx hprobe hposition left leftFuel leftCache hcontext.leftCompletable + hpositive hpublished leftResult hleftSupport hprivate + rw [hleftCore.1, hrightCore.1, houtput, + runDirectResolvedDetailedFromTable_resolveKnownInput_leaf_of_missingChild + parameter table input lay tree leafIdx child hchild leftResult.context + leftResult.remaining leftResult.value.2 hmissing] + exact relTriple_runDirectResolvedDetailed_splitHashQuery_private_left_materialized_right + table input leftResult.context leftResult.remaining leftResult.value.2 + ((resolveKnownInput parameter (.position (.leaf lay tree leafIdx)) input).run + rightResult.value.2) + rightResult.context rightResult.remaining hprivate hrightResultMaterialized + +set_option maxRecDepth 100000 in +theorem scannedNode_available_or_completionOrdinary + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (lay : Layer) (tree : TreeIndex) + (level : Fin maxLayerHeight) (nodeIdx : LeafIndex) + (hposition : decodePosition? parameter input = some (.node lay tree level nodeIdx)) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (completion : Coordinate → HashOutput) + (hcompletion : DeferredCompletion table context completion) + (hpositive : 0 < fuel) (hpublished : PublishedValues context.state) + (result : ResolvedRunResult (Unit × SplitHashCache)) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)).run cache))) : + TableInputAvailable completion result.context.state + (.position (.node lay tree level nodeIdx)) ∨ + CompletionOrdinaryInput parameter table result.context input := by + obtain ⟨remainingFuel, rfl⟩ := Nat.exists_eq_succ_of_ne_zero (by omega : fuel ≠ 0) + rcases positionValues_or_first_missing completion context.state + (Position.node lay tree level nodeIdx).children + (fun other output hvalue => (hcompletion.1 (.position other) output hvalue).symm) with + havailable | ⟨prior, child, remaining, hchildren, hvalues, hmissing⟩ + · let coordinates := (Position.node lay tree level nodeIdx).children.map Coordinate.position + have hcoordinateValues : ∀ coordinate, coordinate ∈ coordinates → + context.state.values coordinate = some (completion coordinate) := by + intro coordinate hcoordinate + obtain ⟨position, hpositionMem, rfl⟩ := List.mem_map.1 hcoordinate + exact havailable position hpositionMem + rw [runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_of_values + completion input context cache (remainingFuel + 1) table 0 coordinates + hcoordinateValues] at hresult + simp at hresult + subst result + left + simpa [TableInputAvailable] using havailable + · let priorCoordinates := prior.map Coordinate.position + let remainingCoordinates := remaining.map Coordinate.position + have hcoordinates : + (Position.node lay tree level nodeIdx).children.map Coordinate.position = + priorCoordinates ++ .position child :: remainingCoordinates := by + simp [hchildren, priorCoordinates, remainingCoordinates] + have hcoordinateValues : ∀ coordinate, coordinate ∈ priorCoordinates → + context.state.values coordinate = some (completion coordinate) := by + intro coordinate hcoordinate + obtain ⟨position, hpositionMem, rfl⟩ := List.mem_map.1 hcoordinate + exact hvalues position hpositionMem + have hnotRevealed : .position child ∉ context.state.revealed := by + intro hrevealed + exact (hpublished (.position child) hrevealed) hmissing + rw [hcoordinates, + runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_of_prefix_values_of_missing + completion input context cache remainingFuel 0 priorCoordinates remainingCoordinates + (.position child) table hcoordinateValues hmissing hnotRevealed] at hresult + simp at hresult + subst result + right + apply completionOrdinaryInput_of_pending_node_child (table := table) + hposition hchildren + have hlength : priorCoordinates.length = prior.length := by simp [priorCoordinates] + simp [hlength, LazyRevealProbe.State.addPending] + +set_option maxRecDepth 100000 in +theorem scannedNode_privateStructuralHit_has_missingChild + (table : OtsSecretIndex → HashOutput) (input : HashInput) + (lay : Layer) (tree : TreeIndex) (level : Fin maxLayerHeight) + (nodeIdx : LeafIndex) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) (hcompletable : DeferredCompletable table context) + (hpositive : 0 < fuel) (hpublished : PublishedValues context.state) + (result : ResolvedRunResult (Unit × SplitHashCache)) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)).run cache))) + (hprivate : PrivateStructuralHit result.context) : + ∃ child ∈ (Position.node lay tree level nodeIdx).children, + result.context.state.values (.position child) = none := by + obtain ⟨completion, hcompletion⟩ := hcompletable + have hclean := hcompletion.not_privateStructuralHit + obtain ⟨remainingFuel, rfl⟩ := Nat.exists_eq_succ_of_ne_zero (by omega : fuel ≠ 0) + rcases positionValues_or_first_missing completion context.state + (Position.node lay tree level nodeIdx).children + (fun other output hvalue => (hcompletion.1 (.position other) output hvalue).symm) with + havailable | ⟨prior, child, remaining, hchildren, hvalues, hmissing⟩ + · let coordinates := (Position.node lay tree level nodeIdx).children.map Coordinate.position + have hcoordinateValues : ∀ coordinate, coordinate ∈ coordinates → + context.state.values coordinate = some (completion coordinate) := by + intro coordinate hcoordinate + obtain ⟨position, hpositionMem, rfl⟩ := List.mem_map.1 hcoordinate + exact havailable position hpositionMem + rw [runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_of_values + completion input context cache (remainingFuel + 1) table 0 coordinates + hcoordinateValues] at hresult + simp at hresult + subst result + exact False.elim (hclean hprivate) + · let priorCoordinates := prior.map Coordinate.position + let remainingCoordinates := remaining.map Coordinate.position + have hcoordinates : + (Position.node lay tree level nodeIdx).children.map Coordinate.position = + priorCoordinates ++ .position child :: remainingCoordinates := by + simp [hchildren, priorCoordinates, remainingCoordinates] + have hcoordinateValues : ∀ coordinate, coordinate ∈ priorCoordinates → + context.state.values coordinate = some (completion coordinate) := by + intro coordinate hcoordinate + obtain ⟨position, hpositionMem, rfl⟩ := List.mem_map.1 hcoordinate + exact hvalues position hpositionMem + have hnotRevealed : .position child ∉ context.state.revealed := by + intro hrevealed + exact (hpublished (.position child) hrevealed) hmissing + rw [hcoordinates, + runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_of_prefix_values_of_missing + completion input context cache remainingFuel 0 priorCoordinates remainingCoordinates + (.position child) table hcoordinateValues hmissing hnotRevealed] at hresult + simp at hresult + subst result + have hnew := privateStructuralHit_addPending_imp context (.position child) + (slotDigest priorCoordinates.length input) hprivate + rcases hnew with hold | ⟨other, output, hcoordinate, hhidden, _hvalue, _hmatch⟩ + · exact False.elim (hclean hold) + · have hother : other = child := by simpa using hcoordinate.symm + subst other + refine ⟨child, by simp [hchildren], ?_⟩ + simpa [LazyRevealProbe.State.addPending] using hhidden + +set_option maxRecDepth 100000 in +theorem runDirectResolvedDetailedFromTable_resolveKnownInput_node_of_missingChild + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (lay : Layer) (tree : TreeIndex) + (level : Fin maxLayerHeight) (nodeIdx : LeafIndex) + (child : Position) (hchild : child ∈ (Position.node lay tree level nodeIdx).children) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hmissing : context.state.values (.position child) = none) : + runDirectResolvedDetailedFromTable context fuel table + ((resolveKnownInput parameter (.position (.node lay tree level nodeIdx)) input).run cache) = + runDirectResolvedDetailedFromTable context fuel table + ((splitHashQuery (.ordinary input)).run cache) := by + unfold resolveKnownInput + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + peekTableInput.eq_3 parameter (.node lay tree level nodeIdx) (by simp), + StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekPositionValues_of_mem_none + (Position.node lay tree level nodeIdx).children child hchild context fuel table cache hmissing] + simp [runDirectResolvedDetailedFromTable] + +set_option maxHeartbeats 800000 in +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_probingHashQuery_node + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (lay : Layer) (tree : TreeIndex) + (level : Fin maxLayerHeight) (nodeIdx : LeafIndex) + (hprobe : decodeProbe? parameter input = none) + (hposition : decodePosition? parameter input = some (.node lay tree level nodeIdx)) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hpositive : 0 < leftFuel) (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((probingHashQuery parameter input).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQuery parameter input).run rightCache)) + (DirectDetailedOrdinaryRunEq table) := by + unfold probingHashQuery + rw [hprobe, hposition] + simp only + rw [StateT.run_bind, StateT.run_bind] + apply relTriple_runDirectResolvedDetailed_bind_with_support table + ((probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)).run leftCache) + ((probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)).run rightCache) + (fun _ cache => + (resolveKnownInput parameter (.position (.node lay tree level nodeIdx)) input).run cache) + (fun _ cache => + (resolveKnownInput parameter (.position (.node lay tree level nodeIdx)) input).run cache) + left right leftFuel rightFuel + · exact relTriple_runDirectResolvedDetailed_probeFirstMissing_positions table input 0 + (Position.node lay tree level nodeIdx).children left right leftFuel rightFuel + leftCache rightCache hcontext hpositive hfuel hcache hrevealed hvalues hpublished + hrightMaterialized + · intro leftResult rightResult hleftSupport hrightSupport hrelation + have hrightResultMaterialized : + rightResult.context = directDeferredContext rightResult.context.state := by + have hshape := directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + ((probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)).run + rightCache) + right.state rightFuel table (.done rightResult) (by + rw [← hrightMaterialized] + exact hrightSupport) + exact hshape + obtain ⟨completion, hcompletion⟩ := hcontext.leftCompletable + rcases scannedNode_available_or_completionOrdinary parameter table input lay tree level + nodeIdx hposition left leftFuel leftCache completion hcompletion hpositive hpublished + leftResult hleftSupport with havailable | hordinary + · rw [hrelation.left_table, hrelation.right_table] + exact relTriple_runDirectResolvedDetailed_resolveKnownInput_available parameter table + (.node lay tree level nodeIdx) input leftResult.context rightResult.context + leftResult.remaining rightResult.remaining leftResult.value.2 rightResult.value.2 + completion havailable hrelation.context_le hrelation.remaining_le + hrelation.cache_eq hrelation.revealed_eq hrelation.values_le + hrelation.left_published hrightResultMaterialized + · rw [hrelation.left_table, hrelation.right_table] + exact relTriple_runDirectResolvedDetailed_resolveKnownInput_completionOrdinary + parameter table (.position (.node lay tree level nodeIdx)) input leftResult.context + rightResult.context leftResult.remaining rightResult.remaining leftResult.value.2 + rightResult.value.2 hrelation.context_le hrelation.remaining_le + hrelation.cache_eq hrelation.revealed_eq hrelation.values_le + hrelation.left_published hrightResultMaterialized + (fun position heq => by cases heq; simp [IsOtsPosition]) hordinary + · intro leftResult rightResult hleftSupport hrightSupport hprivate + have hleftCore := resolvedCore_of_mem_runDirectResolvedFromTable + ((probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)).run leftCache) + left leftFuel table leftResult hcontext.view.leftConsistent hcontext.view.leftStarts + (mem_support_runDirectResolvedFromTable_of_done_detailed + ((probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)).run + leftCache) + left leftFuel table leftResult hleftSupport) + have hrightCore := resolvedCore_of_mem_runDirectResolvedFromTable + ((probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)).run rightCache) + right rightFuel table rightResult hcontext.view.rightConsistent hcontext.view.rightStarts + (mem_support_runDirectResolvedFromTable_of_done_detailed + ((probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)).run + rightCache) + right rightFuel table rightResult hrightSupport) + have hrightResultMaterialized : + rightResult.context = directDeferredContext rightResult.context.state := by + have hshape := directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + ((probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)).run + rightCache) + right.state rightFuel table (.done rightResult) (by + rw [← hrightMaterialized] + exact hrightSupport) + exact hshape + obtain ⟨child, hchild, hmissing⟩ := + scannedNode_privateStructuralHit_has_missingChild table input lay tree level nodeIdx + left leftFuel leftCache hcontext.leftCompletable hpositive hpublished leftResult + hleftSupport hprivate + rw [hleftCore.1, hrightCore.1, + runDirectResolvedDetailedFromTable_resolveKnownInput_node_of_missingChild + parameter table input lay tree level nodeIdx child hchild leftResult.context + leftResult.remaining leftResult.value.2 hmissing] + exact relTriple_runDirectResolvedDetailed_splitHashQuery_private_left_materialized_right + table input leftResult.context leftResult.remaining leftResult.value.2 + ((resolveKnownInput parameter (.position (.node lay tree level nodeIdx)) input).run + rightResult.value.2) + rightResult.context rightResult.remaining hprivate hrightResultMaterialized + +set_option maxHeartbeats 800000 in +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_probingHashQuery + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (left right : DeferredContext) + (leftFuel rightFuel : Nat) (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hpositive : 0 < leftFuel) (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((probingHashQuery parameter input).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQuery parameter input).run rightCache)) + (DirectDetailedOrdinaryRunEq table) := by + cases hprobe : decodeProbe? parameter input with + | some candidate => + rcases decodePosition?_chain_or_leaf_of_decodeProbe? parameter input candidate hprobe with + ⟨lay, tree, leafIdx, chainIdx, step, hposition⟩ | + ⟨lay, tree, leafIdx, hposition⟩ + · exact relTriple_runDirectResolvedDetailed_probingHashQuery_chain parameter table + input candidate lay tree leafIdx chainIdx step hprobe hposition left right leftFuel + rightFuel leftCache rightCache hcontext hpositive hfuel hcache hrevealed hvalues + hpublished hrightMaterialized + · exact relTriple_runDirectResolvedDetailed_probingHashQuery_leaf parameter table + input candidate lay tree leafIdx hprobe hposition left right leftFuel rightFuel + leftCache rightCache hcontext hpositive hfuel hcache hrevealed hvalues hpublished + hrightMaterialized + | none => + cases hposition : decodePosition? parameter input with + | none => + unfold probingHashQuery + rw [hprobe, hposition] + exact relTriple_runDirectResolvedDetailed_splitHashQuery_ordinary table input + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + have hordinary := completionOrdinaryInput_of_decodeProbe_none_chain + (table := table) (context := left) hprobe hposition + unfold probingHashQuery + rw [hprobe, hposition] + exact relTriple_runDirectResolvedDetailed_resolveKnownInput_completionOrdinary + parameter table (.position (.chain lay tree leafIdx chainIdx step)) input + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache + hrevealed hvalues hpublished hrightMaterialized + (fun other heq => by cases heq; simp [IsOtsPosition]) hordinary + | leaf lay tree leafIdx => + have hordinary := completionOrdinaryInput_of_decodeProbe_none_leaf + (table := table) (context := left) hprobe hposition + unfold probingHashQuery + rw [hprobe, hposition] + exact relTriple_runDirectResolvedDetailed_resolveKnownInput_completionOrdinary + parameter table (.position (.leaf lay tree leafIdx)) input left right leftFuel + rightFuel leftCache rightCache hcontext hfuel hcache hrevealed hvalues + hpublished hrightMaterialized + (fun other heq => by cases heq; simp [IsOtsPosition]) hordinary + | node lay tree level nodeIdx => + exact relTriple_runDirectResolvedDetailed_probingHashQuery_node parameter table + input lay tree level nodeIdx hprobe hposition left right leftFuel rightFuel + leftCache rightCache hcontext hpositive hfuel hcache hrevealed hvalues + hpublished hrightMaterialized + | ftsLeaf index tree leafIdx => + unfold probingHashQuery + rw [hprobe, hposition] + exact relTriple_runDirectResolvedDetailed_splitHashQuery_ordinary table input + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache + hrevealed hvalues hpublished hrightMaterialized + | ftsNode index tree level nodeIdx => + unfold probingHashQuery + rw [hprobe, hposition] + exact relTriple_runDirectResolvedDetailed_splitHashQuery_ordinary table input + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache + hrevealed hvalues hpublished hrightMaterialized + | ftsRoots index => + unfold probingHashQuery + rw [hprobe, hposition] + exact relTriple_runDirectResolvedDetailed_splitHashQuery_ordinary table input + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache + hrevealed hvalues hpublished hrightMaterialized + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryOrdinarySigner.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryOrdinarySigner.lean new file mode 100644 index 00000000..91a32795 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryOrdinarySigner.lean @@ -0,0 +1,1446 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryOrdinaryRefinement + +/-! +# Directional ordinary refinement through the signer + +The general boundary relation permits a successful left run to retain a private structural hit. +That alternative is needed after a probing hash query, but it is not stable under an arbitrary +bind. The signer-local relation below removes only that successful latent-hit alternative. A +stopped private hit remains admissible, and a materialized right run may still be doomed. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def DirectDetailedOrdinaryStableRunEq (table : OtsSecretIndex → HashOutput) : + DirectDetailedResult (α × SplitHashCache) → + DirectDetailedResult (α × SplitHashCache) → Prop + | .stopped .privateStructuralHit, _ => True + | .stopped .ordinaryHit, .stopped .privateStructuralHit => False + | .stopped .ordinaryHit, .stopped _ => True + | .stopped .ordinaryHit, .done right => + OrdinaryMaterializedDoomedRun table right + | .stopped .fuelExhausted, .stopped .ordinaryHit => True + | .stopped .fuelExhausted, .stopped .fuelExhausted => True + | .stopped .fuelExhausted, .done right => + OrdinaryMaterializedDoomedRun table right + | .stopped .fuelExhausted, _ => False + | .done _, .stopped .privateStructuralHit => False + | .done _, .stopped _ => True + | .done left, .done right => + OrdinaryMaterializedRunEq table left right ∨ + OrdinaryMaterializedDoomedRun table right + +theorem DirectDetailedOrdinaryStableRunEq.toOrdinary + {table : OtsSecretIndex → HashOutput} + {left right : DirectDetailedResult (α × SplitHashCache)} + (hrelation : DirectDetailedOrdinaryStableRunEq table left right) : + DirectDetailedOrdinaryRunEq table left right := by + cases left with + | stopped leftReason => + cases leftReason with + | privateStructuralHit => trivial + | ordinaryHit => + cases right with + | stopped rightReason => cases rightReason <;> exact hrelation + | done _ => exact hrelation + | fuelExhausted => + cases right with + | stopped rightReason => cases rightReason <;> exact hrelation + | done _ => exact hrelation + | done leftResult => + cases right with + | stopped rightReason => cases rightReason <;> exact hrelation + | done rightResult => + rcases hrelation with hclean | hdoomed + · exact Or.inl hclean + · exact Or.inr (Or.inr hdoomed) + +theorem relTriple_stable_to_ordinary + {table : OtsSecretIndex → HashOutput} + {left right : ProbComp (DirectDetailedResult (α × SplitHashCache))} + (hrelation : RelTriple left right + (DirectDetailedOrdinaryStableRunEq table)) : + RelTriple left right (DirectDetailedOrdinaryRunEq table) := by + apply relTriple_post_mono hrelation + intro leftResult rightResult + exact DirectDetailedOrdinaryStableRunEq.toOrdinary + +theorem relTriple_pure_privateStructuralHit_any_stable + (table : OtsSecretIndex → HashOutput) + (rightRun : ProbComp (DirectDetailedResult (α × SplitHashCache))) : + RelTriple + (pure (.stopped .privateStructuralHit) : + ProbComp (DirectDetailedResult (α × SplitHashCache))) + rightRun (DirectDetailedOrdinaryStableRunEq table) := by + have hbase := relTriple_true + (pure (.stopped .privateStructuralHit) : + ProbComp (DirectDetailedResult (α × SplitHashCache))) rightRun + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (pure (.stopped .privateStructuralHit) : + ProbComp (DirectDetailedResult (α × SplitHashCache)))) + (fun result hresult => hresult) + apply relTriple_post_mono hsupported + intro leftResult _ hrelation + have hleft : leftResult = .stopped .privateStructuralHit := by + simpa using hrelation.2 + subst leftResult + trivial + +theorem relTriple_any_pure_nonprivateStop_stable + (table : OtsSecretIndex → HashOutput) + (leftRun : ProbComp (DirectDetailedResult (α × SplitHashCache))) + (reason : DirectStopReason) (hreason : reason ≠ .privateStructuralHit) : + RelTriple leftRun + (pure (.stopped reason) : + ProbComp (DirectDetailedResult (α × SplitHashCache))) + (DirectDetailedOrdinaryStableRunEq table) := by + have hbase := relTriple_true leftRun + (pure (.stopped reason) : + ProbComp (DirectDetailedResult (α × SplitHashCache))) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + apply relTriple_post_mono hsupported + intro leftResult rightResult hrelation + have hright : rightResult = .stopped reason := by + simpa using hrelation.2 + subst rightResult + cases reason with + | privateStructuralHit => contradiction + | ordinaryHit => cases leftResult with + | stopped leftReason => cases leftReason <;> trivial + | done _ => trivial + | fuelExhausted => cases leftResult with + | stopped leftReason => cases leftReason <;> trivial + | done _ => trivial + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_of_right_materializedDoomed_stable + (table : OtsSecretIndex → HashOutput) + (leftRun : ProbComp (DirectDetailedResult (α × SplitHashCache))) + (rightComputation : + OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (right : DeferredContext) (rightFuel : Nat) + (hrightDoomed : DoomedResolvedContext table right) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + leftRun + (runDirectResolvedDetailedFromTable right rightFuel table rightComputation) + (DirectDetailedOrdinaryStableRunEq table) := by + have hbase := relTriple_true leftRun + (runDirectResolvedDetailedFromTable right rightFuel table rightComputation) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support leftRun) + (fun result hresult => hresult) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro leftResult rightResult hrelation + have hrightShape : DirectDetailedMaterialized rightResult := by + have hsupport := hrelation.2 + rw [hrightMaterialized] at hsupport + exact directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + rightComputation right.state rightFuel table rightResult hsupport + cases rightResult with + | stopped reason => + cases reason with + | privateStructuralHit => exact False.elim hrightShape + | ordinaryHit => + cases leftResult with + | stopped leftReason => cases leftReason <;> trivial + | done _ => trivial + | fuelExhausted => + cases leftResult with + | stopped leftReason => cases leftReason <;> trivial + | done _ => trivial + | done rightResult => + have hdoomed := + finalizationDoomedRun_of_mem_runDirectResolvedDetailedFromTable table + rightComputation right rightFuel rightResult hrightDoomed hrelation.2 + have hmaterialized := hrightShape + cases leftResult with + | stopped reason => + cases reason with + | privateStructuralHit => trivial + | ordinaryHit => exact ⟨hdoomed, hmaterialized⟩ + | fuelExhausted => exact ⟨hdoomed, hmaterialized⟩ + | done _ => + right + exact ⟨hdoomed, hmaterialized⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_bind_stable + (table : OtsSecretIndex → HashOutput) + (left right : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (leftNext rightNext : α → SplitHashCache → + OracleComp (LazyRevealProbe.World Coordinate) (β × SplitHashCache)) + (leftContext rightContext : DeferredContext) (leftFuel rightFuel : Nat) + (hleft : RelTriple + (runDirectResolvedDetailedFromTable leftContext leftFuel table left) + (runDirectResolvedDetailedFromTable rightContext rightFuel table right) + (DirectDetailedOrdinaryStableRunEq table)) + (hclean : ∀ (leftResult rightResult : + ResolvedRunResult (α × SplitHashCache)), + OrdinaryMaterializedRunEq table leftResult rightResult → + RelTriple + (runDirectResolvedDetailedFromTable leftResult.context leftResult.remaining + leftResult.table (leftNext leftResult.value.1 leftResult.value.2)) + (runDirectResolvedDetailedFromTable rightResult.context rightResult.remaining + rightResult.table (rightNext rightResult.value.1 rightResult.value.2)) + (DirectDetailedOrdinaryStableRunEq table)) : + RelTriple + (runDirectResolvedDetailedFromTable leftContext leftFuel table + (left >>= fun value => leftNext value.1 value.2)) + (runDirectResolvedDetailedFromTable rightContext rightFuel table + (right >>= fun value => rightNext value.1 value.2)) + (DirectDetailedOrdinaryStableRunEq table) := by + rw [runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_bind] + apply relTriple_bind hleft + intro leftResult rightResult hrelation + cases leftResult with + | stopped leftReason => + cases leftReason with + | privateStructuralHit => + exact relTriple_pure_privateStructuralHit_any_stable table _ + | ordinaryHit => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => exact relTriple_pure_pure trivial + | fuelExhausted => exact relTriple_pure_pure trivial + | done rightResult => + simp only + rw [hrelation.1.1] + exact relTriple_runDirectResolvedDetailed_of_right_materializedDoomed_stable table + (pure (.stopped .ordinaryHit)) + (rightNext rightResult.value.1 rightResult.value.2) + rightResult.context rightResult.remaining hrelation.1.2 hrelation.2 + | fuelExhausted => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => exact relTriple_pure_pure trivial + | fuelExhausted => exact relTriple_pure_pure trivial + | done rightResult => + simp only + rw [hrelation.1.1] + exact relTriple_runDirectResolvedDetailed_of_right_materializedDoomed_stable table + (pure (.stopped .fuelExhausted)) + (rightNext rightResult.value.1 rightResult.value.2) + rightResult.context rightResult.remaining hrelation.1.2 hrelation.2 + | done leftResult => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => + exact relTriple_any_pure_nonprivateStop_stable table _ .ordinaryHit (by decide) + | fuelExhausted => + exact relTriple_any_pure_nonprivateStop_stable table _ .fuelExhausted (by decide) + | done rightResult => + rcases hrelation with hcleanRelation | hdoomedRelation + · exact hclean leftResult rightResult hcleanRelation + · simp only + rw [hdoomedRelation.1.1] + exact relTriple_runDirectResolvedDetailed_of_right_materializedDoomed_stable table + (runDirectResolvedDetailedFromTable leftResult.context leftResult.remaining + leftResult.table (leftNext leftResult.value.1 leftResult.value.2)) + (rightNext rightResult.value.1 rightResult.value.2) + rightResult.context rightResult.remaining hdoomedRelation.1.2 + hdoomedRelation.2 + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_bind_with_support_stable + (table : OtsSecretIndex → HashOutput) + (left right : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (leftNext rightNext : α → SplitHashCache → + OracleComp (LazyRevealProbe.World Coordinate) (β × SplitHashCache)) + (leftContext rightContext : DeferredContext) (leftFuel rightFuel : Nat) + (hleft : RelTriple + (runDirectResolvedDetailedFromTable leftContext leftFuel table left) + (runDirectResolvedDetailedFromTable rightContext rightFuel table right) + (DirectDetailedOrdinaryStableRunEq table)) + (hclean : ∀ (leftResult rightResult : + ResolvedRunResult (α × SplitHashCache)), + DirectDetailedResult.done leftResult ∈ support + (runDirectResolvedDetailedFromTable leftContext leftFuel table left) → + DirectDetailedResult.done rightResult ∈ support + (runDirectResolvedDetailedFromTable rightContext rightFuel table right) → + OrdinaryMaterializedRunEq table leftResult rightResult → + RelTriple + (runDirectResolvedDetailedFromTable leftResult.context leftResult.remaining + leftResult.table (leftNext leftResult.value.1 leftResult.value.2)) + (runDirectResolvedDetailedFromTable rightResult.context rightResult.remaining + rightResult.table (rightNext rightResult.value.1 rightResult.value.2)) + (DirectDetailedOrdinaryStableRunEq table)) : + RelTriple + (runDirectResolvedDetailedFromTable leftContext leftFuel table + (left >>= fun value => leftNext value.1 value.2)) + (runDirectResolvedDetailedFromTable rightContext rightFuel table + (right >>= fun value => rightNext value.1 value.2)) + (DirectDetailedOrdinaryStableRunEq table) := by + rw [runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_bind] + have hleftWithSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hleft + (fun result => result ∈ support + (runDirectResolvedDetailedFromTable leftContext leftFuel table left)) + (fun result hresult => hresult) + have hbothWithSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftWithSupport + apply relTriple_bind hbothWithSupport + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResult with + | stopped leftReason => + cases leftReason with + | privateStructuralHit => + exact relTriple_pure_privateStructuralHit_any_stable table _ + | ordinaryHit => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => exact relTriple_pure_pure trivial + | fuelExhausted => exact relTriple_pure_pure trivial + | done rightResult => + simp only + rw [hrelation.1.1] + exact relTriple_runDirectResolvedDetailed_of_right_materializedDoomed_stable table + (pure (.stopped .ordinaryHit)) + (rightNext rightResult.value.1 rightResult.value.2) + rightResult.context rightResult.remaining hrelation.1.2 hrelation.2 + | fuelExhausted => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => exact relTriple_pure_pure trivial + | fuelExhausted => exact relTriple_pure_pure trivial + | done rightResult => + simp only + rw [hrelation.1.1] + exact relTriple_runDirectResolvedDetailed_of_right_materializedDoomed_stable table + (pure (.stopped .fuelExhausted)) + (rightNext rightResult.value.1 rightResult.value.2) + rightResult.context rightResult.remaining hrelation.1.2 hrelation.2 + | done leftResult => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => + exact relTriple_any_pure_nonprivateStop_stable table _ .ordinaryHit (by decide) + | fuelExhausted => + exact relTriple_any_pure_nonprivateStop_stable table _ .fuelExhausted (by decide) + | done rightResult => + rcases hrelation with hcleanRelation | hdoomedRelation + · exact hclean leftResult rightResult hleftSupport hrightSupport hcleanRelation + · simp only + rw [hdoomedRelation.1.1] + exact relTriple_runDirectResolvedDetailed_of_right_materializedDoomed_stable table + (runDirectResolvedDetailedFromTable leftResult.context leftResult.remaining + leftResult.table (leftNext leftResult.value.1 leftResult.value.2)) + (rightNext rightResult.value.1 rightResult.value.2) + rightResult.context rightResult.remaining hdoomedRelation.1.2 + hdoomedRelation.2 + +def OrdinaryMaterializedStableCouples (table : OtsSecretIndex → HashOutput) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ left right leftFuel rightFuel leftCache rightCache, + FinalizationContextLE table left right → + leftFuel ≤ rightFuel → + ordinaryQueryCache leftCache = ordinaryQueryCache rightCache → + left.state.revealed = right.state.revealed → + LazyRevealProbe.ValuesLE left.state right.state → + PublishedValues left.state → + right = directDeferredContext right.state → + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + (computation.run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + (computation.run rightCache)) + (DirectDetailedOrdinaryStableRunEq table) + +theorem ordinaryMaterializedStableCouples_pure + (table : OtsSecretIndex → HashOutput) (value : α) : + OrdinaryMaterializedStableCouples table + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + rw [StateT.run_pure, StateT.run_pure, + runDirectResolvedDetailedFromTable_pure, + runDirectResolvedDetailedFromTable_pure] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := hcache + revealed_eq := hrevealed + values_le := hvalues + left_published := hpublished + right_materialized := hrightMaterialized } + +theorem OrdinaryMaterializedStableCouples.bind + {table : OtsSecretIndex → HashOutput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : OrdinaryMaterializedStableCouples table left) + (hnext : ∀ value, OrdinaryMaterializedStableCouples table (next value)) : + OrdinaryMaterializedStableCouples table (left >>= next) := by + intro leftContext rightContext leftFuel rightFuel leftCache rightCache hcontext hfuel hcache + hrevealed hvalues hpublished hrightMaterialized + rw [StateT.run_bind, StateT.run_bind] + apply relTriple_runDirectResolvedDetailed_bind_stable table + (left.run leftCache) (left.run rightCache) + (fun value cache => (next value).run cache) + (fun value cache => (next value).run cache) + leftContext rightContext leftFuel rightFuel + · exact hleft leftContext rightContext leftFuel rightFuel leftCache rightCache hcontext hfuel + hcache hrevealed hvalues hpublished hrightMaterialized + · intro leftResult rightResult hrelation + rw [hrelation.left_table, hrelation.right_table, ← hrelation.value_eq] + exact hnext leftResult.value.1 leftResult.context rightResult.context + leftResult.remaining rightResult.remaining leftResult.value.2 rightResult.value.2 + hrelation.context_le hrelation.remaining_le hrelation.cache_eq hrelation.revealed_eq + hrelation.values_le hrelation.left_published hrelation.right_materialized + +theorem FinalizationViewLE.ensure + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewLE table left right) (coordinate : Coordinate) : + FinalizationViewLE table + { left with state := left.state.ensure coordinate } + { right with state := right.state.ensure coordinate } where + leftConsistent := hview.leftConsistent.ensure coordinate + rightConsistent := hview.rightConsistent.ensure coordinate + leftStarts := hview.leftStarts + rightStarts := hview.rightStarts + valueEq := hview.valueEq + leftClean := hview.leftClean + rightClean := hview.rightClean + pendingLE := hview.pendingLE + +theorem FinalizationContextLE.ensure + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextLE table left right) (coordinate : Coordinate) : + FinalizationContextLE table + { left with state := left.state.ensure coordinate } + { right with state := right.state.ensure coordinate } where + view := hcontext.view.ensure coordinate + leftValid := hcontext.leftValid.ensure coordinate + rightValid := hcontext.rightValid.ensure coordinate + rightCompletable := hcontext.rightCompletable.ensure coordinate + +theorem ordinaryMaterializedStableCouples_ensureCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + OrdinaryMaterializedStableCouples table (ensureCoordinate coordinate) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + unfold ensureCoordinate + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.ensureQuery, + runDirectResolvedDetailedFromTable_ensure_query_bind, + runDirectResolvedDetailedFromTable_ensure_query_bind, + runDirectResolvedDetailedFromTable_pure, + runDirectResolvedDetailedFromTable_pure] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext.ensure coordinate + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := hcache + revealed_eq := by + simpa [LazyRevealProbe.State.ensure] using hrevealed + values_le := by + intro other output hvalue + exact hvalues other output hvalue + left_published := by + simpa [PublishedValues, LazyRevealProbe.State.ensure] using hpublished + right_materialized := by + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_ensure] } + +theorem ordinaryMaterializedStableCouples_sequenceFin + {table : OtsSecretIndex → HashOutput} {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, + OrdinaryMaterializedStableCouples table (computation index)) : + OrdinaryMaterializedStableCouples table (sequenceFin computation) := by + induction n with + | zero => + simpa [sequenceFin] using + (ordinaryMaterializedStableCouples_pure table Fin.elim0 : + OrdinaryMaterializedStableCouples table + (pure Fin.elim0 : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Fin 0 → α))) + | succ n ih => + rw [sequenceFin] + apply (hcomponent 0).bind + intro head + apply (ih (fun index : Fin n => computation index.succ) + (fun index => hcomponent index.succ)).bind + intro tail + exact ordinaryMaterializedStableCouples_pure table + (Fin.cases head tail : Fin (n + 1) → α) + +set_option maxRecDepth 100000 in +theorem ordinaryMaterializedStableCouples_splitHashQuery_ordinary + (table : OtsSecretIndex → HashOutput) (input : HashInput) : + OrdinaryMaterializedStableCouples table + (splitHashQuery (.ordinary input)) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + have hcacheAt : leftCache (.ordinary input) = rightCache (.ordinary input) := + congrFun hcache input + cases hlookup : leftCache (.ordinary input) with + | some output => + have hright : rightCache (.ordinary input) = some output := by + rw [← hcacheAt] + exact hlookup + simp only [hright] + exact ordinaryMaterializedStableCouples_pure table output left right leftFuel rightFuel + leftCache rightCache hcontext hfuel hcache hrevealed hvalues hpublished + hrightMaterialized + | none => + have hright : rightCache (.ordinary input) = none := by + rw [← hcacheAt] + exact hlookup + simp only [hright] + rw [LazyRevealProbe.hashOutputQuery, + runDirectResolvedDetailedFromTable_hashOutput_query_bind, + runDirectResolvedDetailedFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runDirectResolvedDetailedFromTable] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update, ordinaryQueryCache_update, hcache] + revealed_eq := hrevealed + values_le := hvalues + left_published := hpublished + right_materialized := hrightMaterialized } + +theorem ordinaryMaterializedStableCouples_ordinaryHashImpl + (table : OtsSecretIndex → HashOutput) (input : HashInput) : + OrdinaryMaterializedStableCouples table (ordinaryHashImpl input) := + ordinaryMaterializedStableCouples_splitHashQuery_ordinary table input + +theorem ordinaryMaterializedStableCouples_splitUniformImpl + (table : OtsSecretIndex → HashOutput) (n : unifSpec.Domain) : + OrdinaryMaterializedStableCouples table (splitUniformImpl n) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + unfold splitUniformImpl + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.uniformQuery, + runDirectResolvedDetailedFromTable_uniform_query_bind, + runDirectResolvedDetailedFromTable_uniform_query_bind] + apply relTriple_bind (relTriple_refl + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))) + intro leftOutput rightOutput houtput + subst rightOutput + exact ordinaryMaterializedStableCouples_pure table leftOutput left right leftFuel rightFuel + leftCache rightCache hcontext hfuel hcache hrevealed hvalues hpublished + hrightMaterialized + +theorem ordinaryMaterializedStableCouples_simulateQ + {table : OtsSecretIndex → HashOutput} {spec : OracleSpec ι} + (impl : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))) + (hquery : ∀ query, OrdinaryMaterializedStableCouples table (impl query)) + (computation : OracleComp spec α) : + OrdinaryMaterializedStableCouples table (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp only [simulateQ_pure] + exact ordinaryMaterializedStableCouples_pure table value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (hquery query).bind fun output => ih output + +set_option maxRecDepth 100000 in +theorem ordinaryMaterializedStableCouples_revealCoordinateOutput_position + (table : OtsSecretIndex → HashOutput) (position : Position) : + OrdinaryMaterializedStableCouples table + (revealCoordinateOutput (.position position)) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + cases hleftValue : left.state.values (.position position) with + | some output => + have hrightValue : right.state.values (.position position) = some output := + hvalues (.position position) output hleftValue + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + (.position position) left leftFuel leftCache output hleftValue, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + (.position position) right rightFuel rightCache output hrightValue] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache] + revealed_eq := hrevealed + values_le := hvalues + left_published := hpublished + right_materialized := hrightMaterialized } + | none => + cases hrightValue : right.state.values (.position position) with + | some output => + have hprivate := hcontext.view.privateValue_of_left_hidden_of_right_materialized + position output hleftValue hrightValue + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_position_of_private + table position left leftFuel leftCache output hleftValue hprivate, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + (.position position) right rightFuel rightCache output hrightValue] + by_cases hhit : left.state.hitAt (.position position) output + · simp only [hhit, ↓reduceIte] + exact relTriple_pure_pure trivial + · simp only [hhit, ↓reduceIte] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext.materialize_position_left position output + hleftValue hprivate + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache] + revealed_eq := by + simpa [LazyRevealProbe.State.materialize] using hrevealed + values_le := hvalues.materialize_left (.position position) output hrightValue + left_published := hpublished.materialize (.position position) output + right_materialized := hrightMaterialized } + | none => + have hrightPrivate : right.values position = none := by + rw [hrightMaterialized] + simpa [directDeferredContext, directDeferredValues] using hrightValue + have hleftPositionValue : left.positionValue position = none := by + change resolvedCompletionValue table left (.position position) = none + rw [hcontext.view.valueEq] + simp [resolvedCompletionValue, DeferredContext.positionValue, hrightValue, + hrightPrivate] + have hleftPrivate : left.values position = none := by + simpa [DeferredContext.positionValue, hleftValue] using hleftPositionValue + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_position_of_fresh + table position left leftFuel leftCache hleftValue hleftPrivate, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_position_of_fresh + table position right rightFuel rightCache hrightValue hrightPrivate] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + by_cases hleftHit : left.state.hitAt (.position position) leftOutput + · have hresolvedNone : + resolvedCompletionValue table left (.position position) = none := by + simpa [resolvedCompletionValue] using hleftPositionValue + have hrightHit : right.state.hitAt (.position position) leftOutput := by + unfold LazyRevealProbe.State.hitAt at hleftHit ⊢ + exact hcontext.view.pendingLE (.position position) hresolvedNone hleftHit + simp only [hleftHit, hrightHit, ↓reduceIte] + exact relTriple_pure_pure trivial + · by_cases hrightHit : right.state.hitAt (.position position) leftOutput + · simp only [hleftHit, hrightHit, ↓reduceIte] + exact relTriple_pure_pure trivial + · simp only [hleftHit, hrightHit, ↓reduceIte] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext.materialize_position_both position leftOutput + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, + hcache] + revealed_eq := by + simpa [LazyRevealProbe.State.materialize] using hrevealed + values_le := hvalues.materialize_both (.position position) leftOutput + left_published := hpublished.materialize (.position position) leftOutput + right_materialized := by + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_materialize_position] } + +theorem ordinaryMaterializedStableCouples_revealPosition + (table : OtsSecretIndex → HashOutput) (position : Position) : + OrdinaryMaterializedStableCouples table (revealPosition position) := by + unfold revealPosition revealCoordinate + exact (ordinaryMaterializedStableCouples_revealCoordinateOutput_position table position).bind + fun output => ordinaryMaterializedStableCouples_pure table (truncateHash output) + +theorem DeferredCompletable.materialize_chainStart_value + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hcompletable : DeferredCompletable table context) (index : OtsSecretIndex) : + DeferredCompletable table + { context with + state := context.state.materialize index.coordinate (table index) } := by + rcases hcompletable with ⟨completion, hcompletion⟩ + refine ⟨completion, ?_, hcompletion.2.1, ?_, hcompletion.2.2.2⟩ + · intro coordinate output hvalue + by_cases heq : coordinate = index.coordinate + · subst coordinate + have houtput : output = table index := by + simpa [LazyRevealProbe.State.materialize] using hvalue.symm + rw [houtput] + exact hcompletion.2.2.2 index + · apply hcompletion.1 coordinate output + simpa [LazyRevealProbe.State.materialize, Function.update_of_ne heq] using hvalue + · intro coordinate candidate hmember + apply hcompletion.2.2.1 coordinate candidate + change (coordinate, candidate) ∈ context.state.pendingAway index.coordinate at hmember + exact (Finset.mem_filter.1 hmember).1 + +set_option maxRecDepth 100000 in +theorem FinalizationViewLE.materialize_chainStart_left + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewLE table left right) (index : OtsSecretIndex) : + FinalizationViewLE table + { left with state := left.state.materialize index.coordinate (table index) } right := by + let materialized : DeferredContext := + { left with state := left.state.materialize index.coordinate (table index) } + have hresolved : resolvedCompletionValue table materialized = + resolvedCompletionValue table left := by + funext coordinate + cases coordinate with + | chainStart => rfl + | position position => + simp [materialized, resolvedCompletionValue, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, OtsSecretIndex.coordinate] + refine + { leftConsistent := ?_ + rightConsistent := hview.rightConsistent + leftStarts := hview.leftStarts.materialize_start index + rightStarts := hview.rightStarts + valueEq := hresolved.trans hview.valueEq + leftClean := ?_ + rightClean := hview.rightClean + pendingLE := ?_ } + · intro position output hvalue + apply hview.leftConsistent position output + simpa [materialized, LazyRevealProbe.State.materialize, OtsSecretIndex.coordinate] using + hvalue + · intro coordinate output hvalue + have horiginal : resolvedCompletionValue table left coordinate = some output := by + rw [← hresolved] + exact hvalue + by_cases heq : coordinate = index.coordinate + · subst coordinate + change ¬(left.state.clearPending index.coordinate).hitAt index.coordinate output + exact not_hitAt_clearPending_self left.state index.coordinate output + · change ¬(left.state.clearPending index.coordinate).hitAt coordinate output + exact (hitAt_clearPending_of_ne left.state index.coordinate coordinate output heq).not.mpr + (hview.leftClean coordinate output horiginal) + · intro coordinate hvalue candidate hcandidate + have horiginal : resolvedCompletionValue table left coordinate = none := by + rw [← hresolved] + exact hvalue + have hne : coordinate ≠ index.coordinate := by + intro heq + subst coordinate + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + change some (table ⟨lay, tree, leafIdx, chainIdx⟩) = none at hvalue + contradiction + have hbase : candidate ∈ left.state.pendingAt coordinate := by + change candidate ∈ + (left.state.clearPending index.coordinate).pendingAt coordinate at hcandidate + rw [pendingAt_clearPending_of_ne left.state index.coordinate coordinate hne] at hcandidate + exact hcandidate + exact hview.pendingLE coordinate horiginal hbase + +set_option maxRecDepth 100000 in +theorem FinalizationViewLE.materialize_chainStart_right + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewLE table left right) (index : OtsSecretIndex) : + FinalizationViewLE table left + { right with state := right.state.materialize index.coordinate (table index) } := by + let materialized : DeferredContext := + { right with state := right.state.materialize index.coordinate (table index) } + have hresolved : resolvedCompletionValue table materialized = + resolvedCompletionValue table right := by + funext coordinate + cases coordinate with + | chainStart => rfl + | position position => + simp [materialized, resolvedCompletionValue, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, OtsSecretIndex.coordinate] + refine + { leftConsistent := hview.leftConsistent + rightConsistent := ?_ + leftStarts := hview.leftStarts + rightStarts := hview.rightStarts.materialize_start index + valueEq := hview.valueEq.trans hresolved.symm + leftClean := hview.leftClean + rightClean := ?_ + pendingLE := ?_ } + · intro position output hvalue + apply hview.rightConsistent position output + simpa [materialized, LazyRevealProbe.State.materialize, OtsSecretIndex.coordinate] using + hvalue + · intro coordinate output hvalue + have horiginal : resolvedCompletionValue table right coordinate = some output := by + rw [← hresolved] + exact hvalue + by_cases heq : coordinate = index.coordinate + · subst coordinate + change ¬(right.state.clearPending index.coordinate).hitAt index.coordinate output + exact not_hitAt_clearPending_self right.state index.coordinate output + · change ¬(right.state.clearPending index.coordinate).hitAt coordinate output + exact (hitAt_clearPending_of_ne right.state index.coordinate coordinate output heq).not.mpr + (hview.rightClean coordinate output horiginal) + · intro coordinate hvalue candidate hcandidate + have hne : coordinate ≠ index.coordinate := by + intro heq + subst coordinate + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + change some (table ⟨lay, tree, leafIdx, chainIdx⟩) = none at hvalue + contradiction + have hrightValue : resolvedCompletionValue table right coordinate = none := by + rw [← hview.valueEq] + exact hvalue + have hleftValue : resolvedCompletionValue table left coordinate = none := by + exact hvalue + have hbase := hview.pendingLE coordinate hleftValue hcandidate + change candidate ∈ + (right.state.clearPending index.coordinate).pendingAt coordinate + rw [pendingAt_clearPending_of_ne right.state index.coordinate coordinate hne] + exact hbase + +theorem FinalizationContextLE.materialize_chainStart_left + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextLE table left right) (index : OtsSecretIndex) : + FinalizationContextLE table + { left with state := left.state.materialize index.coordinate (table index) } right where + view := hcontext.view.materialize_chainStart_left index + leftValid := by + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + exact hcontext.leftValid.materialize_chainStart lay tree leafIdx chainIdx + (table ⟨lay, tree, leafIdx, chainIdx⟩) + rightValid := hcontext.rightValid + rightCompletable := hcontext.rightCompletable + +theorem FinalizationContextLE.materialize_chainStart_right + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextLE table left right) (index : OtsSecretIndex) : + FinalizationContextLE table left + { right with state := right.state.materialize index.coordinate (table index) } where + view := hcontext.view.materialize_chainStart_right index + leftValid := hcontext.leftValid + rightValid := by + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + exact hcontext.rightValid.materialize_chainStart lay tree leafIdx chainIdx + (table ⟨lay, tree, leafIdx, chainIdx⟩) + rightCompletable := hcontext.rightCompletable.materialize_chainStart_value index + +theorem FinalizationContextLE.materialize_chainStart_both + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextLE table left right) (index : OtsSecretIndex) : + FinalizationContextLE table + { left with state := left.state.materialize index.coordinate (table index) } + { right with state := right.state.materialize index.coordinate (table index) } := + (hcontext.materialize_chainStart_left index).materialize_chainStart_right index + +theorem runDirectResolvedDetailedFromTable_revealCoordinateOutput_chainStart_of_missing + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hmissing : context.state.values index.coordinate = none) : + runDirectResolvedDetailedFromTable context fuel table + ((revealCoordinateOutput index.coordinate).run cache) = + if context.state.hitAt index.coordinate (table index) then + pure (.stopped .ordinaryHit) + else + pure (.done ⟨ + { context with + state := context.state.materialize index.coordinate (table index) }, + fuel, + (table index, Function.update cache (.hidden index.coordinate) (some (table index))), + table⟩) := by + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + change context.state.values (.chainStart lay tree leafIdx chainIdx) = none at hmissing + unfold revealCoordinateOutput + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind] + simp only [StateT.run_liftM] + rw [LazyRevealProbe.revealQuery, + runDirectResolvedDetailedFromTable_reveal_query_bind] + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) (table ⟨lay, tree, leafIdx, chainIdx⟩) <;> + simp [OtsSecretIndex.coordinate, hmissing, hhit, StateT.run_modify, + runDirectResolvedDetailedFromTable] + +set_option maxRecDepth 100000 in +theorem ordinaryMaterializedStableCouples_revealCoordinateOutput_chainStart + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) : + OrdinaryMaterializedStableCouples table + (revealCoordinateOutput index.coordinate) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + cases hleftValue : left.state.values index.coordinate with + | some output => + have hrightValue : right.state.values index.coordinate = some output := + hvalues index.coordinate output hleftValue + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + index.coordinate left leftFuel leftCache output hleftValue, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + index.coordinate right rightFuel rightCache output hrightValue] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache] + revealed_eq := hrevealed + values_le := hvalues + left_published := hpublished + right_materialized := hrightMaterialized } + | none => + have hleftMiss : ¬left.state.hitAt index.coordinate (table index) := + hcontext.leftCompletable.not_hitAt_chainStart index + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_chainStart_of_missing + table index left leftFuel leftCache hleftValue, if_neg hleftMiss] + cases hrightValue : right.state.values index.coordinate with + | some output => + have houtput : output = table index := by + exact hcontext.view.rightStarts index output hrightValue + subst output + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + index.coordinate right rightFuel rightCache (table index) hrightValue] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext.materialize_chainStart_left index + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache] + revealed_eq := by + simpa [LazyRevealProbe.State.materialize] using hrevealed + values_le := hvalues.materialize_left index.coordinate (table index) hrightValue + left_published := hpublished.materialize index.coordinate (table index) + right_materialized := hrightMaterialized } + | none => + have hrightMiss : ¬right.state.hitAt index.coordinate (table index) := + hcontext.rightCompletable.not_hitAt_chainStart index + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_chainStart_of_missing + table index right rightFuel rightCache hrightValue, if_neg hrightMiss] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext.materialize_chainStart_both index + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache] + revealed_eq := by + simpa [LazyRevealProbe.State.materialize] using hrevealed + values_le := hvalues.materialize_both index.coordinate (table index) + left_published := hpublished.materialize index.coordinate (table index) + right_materialized := by + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_materialize_chainStart] } + +theorem ordinaryMaterializedStableCouples_revealCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + OrdinaryMaterializedStableCouples table (revealCoordinate coordinate) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + unfold revealCoordinate + exact (ordinaryMaterializedStableCouples_revealCoordinateOutput_chainStart table + ⟨lay, tree, leafIdx, chainIdx⟩).bind fun output => + ordinaryMaterializedStableCouples_pure table (truncateHash output) + | position position => + exact ordinaryMaterializedStableCouples_revealPosition table position + +theorem ordinaryMaterializedStableCouples_revealCoordinateOutput + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + OrdinaryMaterializedStableCouples table (revealCoordinateOutput coordinate) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact ordinaryMaterializedStableCouples_revealCoordinateOutput_chainStart table + ⟨lay, tree, leafIdx, chainIdx⟩ + | position position => + exact ordinaryMaterializedStableCouples_revealCoordinateOutput_position table position + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedDetailed_publishCoordinate_then_pure_stable + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (value : α) (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hleftValue : ∃ output, left.state.values coordinate = some output) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((publishCoordinate coordinate >>= fun _ => pure value).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((publishCoordinate coordinate >>= fun _ => pure value).run rightCache)) + (DirectDetailedOrdinaryStableRunEq table) := by + obtain ⟨output, hleftValue⟩ := hleftValue + have hrightValue : right.state.values coordinate = some output := + hvalues coordinate output hleftValue + unfold publishCoordinate + rw [StateT.run_bind, StateT.run_bind] + simp only [StateT.run_liftM] + simp only [StateT.run_pure, bind_assoc, pure_bind] + unfold LazyRevealProbe.publishQuery + rw [runDirectResolvedDetailedFromTable_publish_query_bind, + runDirectResolvedDetailedFromTable_publish_query_bind] + rw [runDirectResolvedDetailedFromTable_pure, + runDirectResolvedDetailedFromTable_pure] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext.publish coordinate + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := hcache + revealed_eq := by + simpa [LazyRevealProbe.State.publish] using congrArg (insert coordinate) hrevealed + values_le := by + intro other otherOutput hvalue + exact hvalues other otherOutput hvalue + left_published := hpublished.publish_of_value coordinate output hleftValue + right_materialized := by + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_publish] } + +set_option maxRecDepth 100000 in +theorem value_of_done_runDirectResolvedDetailedFromTable_revealCoordinateOutput + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult (HashOutput × SplitHashCache)) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((revealCoordinateOutput coordinate).run cache))) : + result.context.state.values coordinate = some result.value.1 := by + cases hvalue : context.state.values coordinate with + | some output => + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + coordinate context fuel cache output hvalue] at hresult + simp at hresult + subst result + exact hvalue + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + have hmissing : context.state.values index.coordinate = none := by + simpa [index, OtsSecretIndex.coordinate] using hvalue + change DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((revealCoordinateOutput index.coordinate).run cache)) at hresult + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_chainStart_of_missing + table index context fuel cache hmissing] at hresult + by_cases hhit : context.state.hitAt index.coordinate (table index) + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + simp [LazyRevealProbe.State.materialize, index, OtsSecretIndex.coordinate] + | position position => + cases hprivate : context.values position with + | some output => + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_position_of_private + table position context fuel cache output hvalue hprivate] at hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + simp [LazyRevealProbe.State.materialize] + | none => + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_position_of_fresh + table position context fuel cache hvalue hprivate, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hrest + · simp [hhit] at hrest + subst result + simp [LazyRevealProbe.State.materialize] + +set_option maxRecDepth 100000 in +theorem ordinaryMaterializedStableCouples_revealPublishedCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + OrdinaryMaterializedStableCouples table (revealPublishedCoordinate coordinate) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + unfold revealPublishedCoordinate revealCoordinate + simp only [bind_assoc, pure_bind] + rw [StateT.run_bind, StateT.run_bind] + apply relTriple_runDirectResolvedDetailed_bind_with_support_stable table + ((revealCoordinateOutput coordinate).run leftCache) + ((revealCoordinateOutput coordinate).run rightCache) + (fun output cache => + ((publishCoordinate coordinate >>= fun _ => pure (truncateHash output)).run cache)) + (fun output cache => + ((publishCoordinate coordinate >>= fun _ => pure (truncateHash output)).run cache)) + left right leftFuel rightFuel + · exact ordinaryMaterializedStableCouples_revealCoordinateOutput table coordinate + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed hvalues + hpublished hrightMaterialized + · intro leftResult rightResult hleftSupport _hrightSupport hrelation + have hleftValue := + value_of_done_runDirectResolvedDetailedFromTable_revealCoordinateOutput table coordinate + left leftFuel leftCache leftResult hleftSupport + rw [hrelation.left_table, hrelation.right_table, ← hrelation.value_eq] + exact relTriple_runDirectResolvedDetailed_publishCoordinate_then_pure_stable table + coordinate (truncateHash leftResult.value.1) leftResult.context rightResult.context + leftResult.remaining rightResult.remaining leftResult.value.2 rightResult.value.2 + hrelation.context_le hrelation.remaining_le hrelation.cache_eq hrelation.revealed_eq + hrelation.values_le hrelation.left_published ⟨leftResult.value.1, hleftValue⟩ + hrelation.right_materialized + +theorem ordinaryMaterializedStableCouples_ordinaryRomImpl + (table : OtsSecretIndex → HashOutput) (query : OracleWorld.Domain) : + OrdinaryMaterializedStableCouples table (ordinaryRomImpl query) := by + cases query with + | inl n => exact ordinaryMaterializedStableCouples_splitUniformImpl table n + | inr input => exact ordinaryMaterializedStableCouples_ordinaryHashImpl table input + +theorem ordinaryMaterializedStableCouples_ensureFullChain + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + OrdinaryMaterializedStableCouples table + (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + apply (ordinaryMaterializedStableCouples_sequenceFin + (fun step : ChainStep => + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step))) + (fun step => ordinaryMaterializedStableCouples_ensureCoordinate table + (.position (.chain lay tree leafIdx chainIdx step)))).bind + intro _ + exact ordinaryMaterializedStableCouples_pure table () + +theorem ordinaryMaterializedStableCouples_ensureOtsLeaf + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + OrdinaryMaterializedStableCouples table (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + apply (ordinaryMaterializedStableCouples_sequenceFin + (fun chainIdx : ChainIndex => ensureFullChain lay tree leafIdx chainIdx) + (fun chainIdx => ordinaryMaterializedStableCouples_ensureFullChain table lay tree leafIdx + chainIdx)).bind + intro _ + exact ordinaryMaterializedStableCouples_ensureCoordinate table + (.position (.leaf lay tree leafIdx)) + +theorem ordinaryMaterializedStableCouples_ensureTreeNode + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, + OrdinaryMaterializedStableCouples table (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => + ordinaryMaterializedStableCouples_ensureOtsLeaf table lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + apply (ordinaryMaterializedStableCouples_ensureTreeNode table lay tree level + (2 * nodeIdx)).bind + intro _ + apply (ordinaryMaterializedStableCouples_ensureTreeNode table lay tree level + (2 * nodeIdx + 1)).bind + intro _ + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact ordinaryMaterializedStableCouples_ensureCoordinate table + (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact ordinaryMaterializedStableCouples_pure table () + +theorem ordinaryMaterializedStableCouples_maskedTreeNode + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) : + OrdinaryMaterializedStableCouples table (maskedTreeNode lay tree level nodeIdx) := by + unfold maskedTreeNode + apply (ordinaryMaterializedStableCouples_ensureTreeNode table lay tree level nodeIdx).bind + intro _ + cases level with + | zero => + exact ordinaryMaterializedStableCouples_revealPosition table + (.leaf lay tree (leafOfNat nodeIdx)) + | succ current => + by_cases hlevel : current < maxLayerHeight + · simp only [hlevel, ↓reduceDIte] + exact ordinaryMaterializedStableCouples_revealPosition table + (.node lay tree ⟨current, hlevel⟩ (leafOfNat nodeIdx)) + · simp only [hlevel, ↓reduceDIte] + exact ordinaryMaterializedStableCouples_pure table 0 + +theorem ordinaryMaterializedStableCouples_maskedTreeRoot + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + OrdinaryMaterializedStableCouples table (maskedTreeRoot lay tree) := by + unfold maskedTreeRoot + exact ordinaryMaterializedStableCouples_maskedTreeNode table lay tree (layerHeight lay) 0 + +theorem ordinaryMaterializedStableCouples_ensureChainPrefix + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + OrdinaryMaterializedStableCouples table + (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + apply (ordinaryMaterializedStableCouples_sequenceFin + (fun step : ChainStep => + if step.val < digit.val then + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + else pure ()) + (fun step => by + by_cases hstep : step.val < digit.val + · rw [if_pos hstep] + exact ordinaryMaterializedStableCouples_ensureCoordinate table + (.position (.chain lay tree leafIdx chainIdx step)) + · rw [if_neg hstep] + exact ordinaryMaterializedStableCouples_pure table ())).bind + intro _ + exact ordinaryMaterializedStableCouples_pure table () + +theorem ordinaryMaterializedStableCouples_ensureTreePath + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + OrdinaryMaterializedStableCouples table (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + apply (ordinaryMaterializedStableCouples_sequenceFin + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + ensureTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + else pure ()) + (fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + exact ordinaryMaterializedStableCouples_ensureTreeNode table lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · rw [if_neg hlevel] + exact ordinaryMaterializedStableCouples_pure table ())).bind + intro _ + exact ordinaryMaterializedStableCouples_pure table () + +theorem ordinaryMaterializedStableCouples_maskedOtsSignFrom + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter, + OrdinaryMaterializedStableCouples table + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom] + exact ordinaryMaterializedStableCouples_pure table none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + have hencoded := ordinaryMaterializedStableCouples_simulateQ ordinaryHashImpl + (ordinaryMaterializedStableCouples_ordinaryHashImpl table) + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter)) + apply hencoded.bind + intro encoded + cases encoded with + | none => + exact ordinaryMaterializedStableCouples_maskedOtsSignFrom table parameter lay tree + leafIdx message attempts (counter + 1) + | some encoding => + apply (ordinaryMaterializedStableCouples_sequenceFin + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx + (encoding chainIdx)) + (fun chainIdx => ordinaryMaterializedStableCouples_ensureChainPrefix table lay tree + leafIdx chainIdx (encoding chainIdx))).bind + intro _ + exact ordinaryMaterializedStableCouples_pure table + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem ordinaryMaterializedStableCouples_maskedOtsSign + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + OrdinaryMaterializedStableCouples table + (maskedOtsSign parameter lay tree leafIdx message) := + ordinaryMaterializedStableCouples_maskedOtsSignFrom table parameter lay tree leafIdx message + encodingAttemptLimit 0 + +theorem ordinaryMaterializedStableCouples_maskedLayerMessage + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + OrdinaryMaterializedStableCouples table + (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + by_cases hbelow : lay.val + 1 < numLayers + · rw [dif_pos hbelow] + exact ordinaryMaterializedStableCouples_maskedTreeRoot table ⟨lay.val + 1, hbelow⟩ + (treeIndexAt index ⟨lay.val + 1, hbelow⟩) + · rw [dif_neg hbelow] + exact ordinaryMaterializedStableCouples_simulateQ ordinaryHashImpl + (ordinaryMaterializedStableCouples_ordinaryHashImpl table) + (ftsKey parameter index (ftsSecret index)) + +theorem ordinaryMaterializedStableCouples_maskedSignLayer + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + OrdinaryMaterializedStableCouples table + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + apply (ordinaryMaterializedStableCouples_maskedLayerMessage table parameter ftsSecret index + lay).bind + intro message + apply (ordinaryMaterializedStableCouples_maskedOtsSign table parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) message).bind + intro selected + cases selected with + | none => exact ordinaryMaterializedStableCouples_pure table none + | some selected => + apply (ordinaryMaterializedStableCouples_ensureTreePath table lay + (treeIndexAt index lay) (leafIndexAt index lay)).bind + intro _ + exact ordinaryMaterializedStableCouples_pure table (some selected) + +set_option maxRecDepth 100000 in +theorem ordinaryMaterializedStableCouples_revealLayerValues + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + OrdinaryMaterializedStableCouples table (revealLayerValues index lay encoding) := by + unfold revealLayerValues + apply (ordinaryMaterializedStableCouples_sequenceFin + (fun chainIdx : ChainIndex => + revealPublishedCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx))) + (fun chainIdx => ordinaryMaterializedStableCouples_revealPublishedCoordinate table + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx)))).bind + intro values + apply (ordinaryMaterializedStableCouples_sequenceFin + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + match level.val with + | 0 => revealPublishedCoordinate (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | current + 1 => + if hcurrent : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hcurrent⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0 + else pure 0) + (fun level => by + by_cases hinLayer : level.val < layerHeight lay + · rw [if_pos hinLayer] + cases hvalue : level.val with + | zero => + exact ordinaryMaterializedStableCouples_revealPublishedCoordinate table + (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | succ current => + have hcurrent : current < maxLayerHeight := by + have := level.isLt + omega + simp only + rw [dif_pos hcurrent] + exact ordinaryMaterializedStableCouples_revealPublishedCoordinate table + (.position (.node lay (treeIndexAt index lay) ⟨current, hcurrent⟩ + (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + · rw [if_neg hinLayer] + exact ordinaryMaterializedStableCouples_pure table 0)).bind + intro path + exact ordinaryMaterializedStableCouples_pure table (values, path) + +set_option maxRecDepth 100000 in +theorem ordinaryMaterializedStableCouples_maskedSignAfterDigest + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + OrdinaryMaterializedStableCouples table + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest + apply (ordinaryMaterializedStableCouples_simulateQ ordinaryHashImpl + (ordinaryMaterializedStableCouples_ordinaryHashImpl table) + (ftsOpen parameter index leaves (ftsSecret index))).bind + intro ftsPath + apply (ordinaryMaterializedStableCouples_sequenceFin + (fun lay : Layer => maskedSignLayer parameter ftsSecret index lay) + (fun lay => ordinaryMaterializedStableCouples_maskedSignLayer table parameter ftsSecret + index lay)).bind + intro layers + cases hparts : traverseOption layers with + | none => exact ordinaryMaterializedStableCouples_pure table none + | some parts => + apply (ordinaryMaterializedStableCouples_sequenceFin + (fun lay : Layer => revealLayerValues index lay (parts lay).2) + (fun lay => ordinaryMaterializedStableCouples_revealLayerValues table index lay + (parts lay).2)).bind + intro revealed + let signature : Signature := + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (revealed lay).1 + authPath := flattenPaths fun lay => (revealed lay).2 } + exact ordinaryMaterializedStableCouples_pure table (some signature) + +set_option maxRecDepth 100000 in +theorem ordinaryMaterializedStableCouples_maskedSign + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + OrdinaryMaterializedStableCouples table + (maskedSign parameter root ftsSecret message) := by + unfold maskedSign + apply (ordinaryMaterializedStableCouples_simulateQ ordinaryRomImpl + (ordinaryMaterializedStableCouples_ordinaryRomImpl table) + (signDigestLoop digestAttemptLimit + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ message)).bind + intro selected + cases selected with + | none => exact ordinaryMaterializedStableCouples_pure table none + | some data => + exact ordinaryMaterializedStableCouples_maskedSignAfterDigest table parameter ftsSecret + data.1 data.2.1 data.2.2 + +theorem ordinaryMaterializedStableCouples_maskedSigningImpl + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + OrdinaryMaterializedStableCouples table + (maskedSigningImpl parameter root ftsSecret message) := + ordinaryMaterializedStableCouples_maskedSign table parameter root ftsSecret message + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivate.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivate.lean new file mode 100644 index 00000000..d4ddd2b4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivate.lean @@ -0,0 +1,437 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryFirstFire + +/-! +# Private structural boundary outcome + +This file factors the private structural projection of the detailed boundary game through a plain +Boolean interpreter. The projection is exact and retains the first-fire classification. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def classifyDirectPrivateObserve + (_table : OtsSecretIndex → HashOutput) + (_observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (_fuel : Nat) (_value : alpha) : + ProbComp Bool := by + classical + exact if PrivateStructuralHit context then + pure true + else + pure false + +theorem evalDist_private_classifyDirectObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) : + evalDist (DirectBoundaryOutcome.privateStructural <$> + classifyDirectObserve table observe context fuel value) = + evalDist (classifyDirectPrivateObserve table observe context fuel value) := by + unfold classifyDirectObserve classifyDirectPrivateObserve + by_cases hprivate : PrivateStructuralHit context + · simp [hprivate, DirectBoundaryOutcome.privateStructural] + · simp only [hprivate, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table context + · simp only [hcompletable, ↓reduceIte, Functor.map_map] + have hprojection : + (fun output : Bool => (DirectBoundaryOutcome.ofFailed output).privateStructural) = + fun _ => false := by + funext output + cases output <;> rfl + rw [hprojection] + change evalDist ((fun _ : Bool => false) <$> observe context fuel value) = + evalDist (pure false : ProbComp Bool) + simp only [map_eq_bind_pure_comp] + exact OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (observe context fuel value) (by simp) (pure false) + · simp [hcompletable, DirectBoundaryOutcome.privateStructural] + +noncomputable def finishDirectDetailedPrivateObserve + (observe : DeferredContext → Nat → alpha → ProbComp Bool) : + DirectDetailedResult alpha → ProbComp Bool + | .stopped .privateStructuralHit => pure true + | .stopped _ => pure false + | .done result => observe result.context result.remaining result.value + +noncomputable def classifyDirectDetailedPrivateObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) : + ProbComp Bool := by + classical + exact if PrivateStructuralHit context then + pure true + else if DeferredCompletable table context then + observe context fuel value + else + pure false + +set_option maxRecDepth 100000 in +theorem probEvent_resolve_then_classifyDirectDetailedPrivateObserve_le + (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (position : Position) (candidate : Digest) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (fuel : Nat) (value : alpha) (bound : ℝ≥0∞) + (hclean : ¬PrivateStructuralHit context) + (hhidden : context.state.values (.position position) = none) + (hprivate : context.values position = none) + (hobserve : ∀ resolved : DeferredResolution, + some resolved ∈ support (resolveDeferredPositionValue position context) → + let nextContext : DeferredContext := + { resolved.toDeferredContext with + state := resolved.state.addPending (.position position) candidate } + ¬PrivateStructuralHit nextContext → DeferredCompletable table nextContext → + Pr[= true | observe nextContext fuel value] ≤ bound) : + Pr[= true | do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure false + | some resolved => + classifyDirectDetailedPrivateObserve table observe + { resolved.toDeferredContext with + state := resolved.state.addPending (.position position) candidate } + fuel value] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + bound := by + classical + let nextContext : DeferredResolution → DeferredContext := fun resolved => + { resolved.toDeferredContext with + state := resolved.state.addPending (.position position) candidate } + let fires : Option DeferredResolution → Prop + | none => False + | some resolved => PrivateStructuralHit (nextContext resolved) + let continuation : Option DeferredResolution → ProbComp Bool + | none => pure false + | some resolved => + classifyDirectDetailedPrivateObserve table observe + (nextContext resolved) fuel value + rw [← probEvent_eq_eq_probOutput] + refine (probEvent_bind_le_probEvent_add + (mx := resolveDeferredPositionValue position context) + (my := continuation) + (q := fun hit : Bool => hit = true) + (p := fires) + (ε := bound) ?_).trans ?_ + · intro resolved hresolved hmiss + cases resolved with + | none => simp [continuation] + | some resolved => + have hnotPrivate : ¬PrivateStructuralHit (nextContext resolved) := by + simpa [fires] using hmiss + unfold continuation classifyDirectDetailedPrivateObserve + simp only [hnotPrivate, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table (nextContext resolved) + · simpa [hcompletable] using hobserve resolved hresolved hnotPrivate hcompletable + · simp [hcompletable] + · have hsource : + Pr[fires | resolveDeferredPositionValue position context] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + have houtcome : resolveThenPrivateProbeOutcome context position candidate = + (fun resolved => decide (fires resolved)) <$> + resolveDeferredPositionValue position context := by + unfold resolveThenPrivateProbeOutcome + simp only [map_eq_bind_pure_comp] + apply bind_congr + intro resolved + cases resolved <;> simp [fires, nextContext] + exact calc + Pr[fires | resolveDeferredPositionValue position context] = + Pr[= true | resolveThenPrivateProbeOutcome context position candidate] := by + rw [houtcome, ← probEvent_eq_eq_probOutput, probEvent_map] + exact OracleComp.probEvent_congr' (fun resolved _ => by simp) rfl + _ ≤ _ := probEvent_resolveThenPrivateProbeOutcome_le context position candidate + hclean hhidden hprivate + simpa [add_comm] using add_le_add_right hsource bound + +theorem evalDist_private_classifyDirectDetailedObserve + (table : OtsSecretIndex → HashOutput) + (detailedObserve : DeferredContext → Nat → alpha → ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) + (hproject : evalDist (DirectBoundaryOutcome.privateStructural <$> + detailedObserve context fuel value) = + evalDist (observe context fuel value)) : + evalDist (DirectBoundaryOutcome.privateStructural <$> + classifyDirectDetailedObserve table detailedObserve context fuel value) = + evalDist (classifyDirectDetailedPrivateObserve table observe context fuel value) := by + unfold classifyDirectDetailedObserve classifyDirectDetailedPrivateObserve + by_cases hprivate : PrivateStructuralHit context + · simp [hprivate, DirectBoundaryOutcome.privateStructural] + · simp only [hprivate, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table context + · simpa [hcompletable] using hproject + · simp [hcompletable, DirectBoundaryOutcome.privateStructural] + +noncomputable def canonicalizeDirectDetailedPrivateObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) : + ProbComp Bool := by + classical + exact if PrivateStructuralHit (canonicalizeMaterializedValues table context) then + pure true + else if PublishedValues context.state then + classifyDirectDetailedPrivateObserve table observe + (canonicalizeMaterializedValues table context) fuel value + else + pure false + +theorem evalDist_private_canonicalizeDirectDetailedObserve + (table : OtsSecretIndex → HashOutput) + (detailedObserve : DeferredContext → Nat → alpha → ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : alpha) + (hproject : evalDist (DirectBoundaryOutcome.privateStructural <$> + detailedObserve (canonicalizeMaterializedValues table context) fuel value) = + evalDist (observe (canonicalizeMaterializedValues table context) fuel value)) : + evalDist (DirectBoundaryOutcome.privateStructural <$> + canonicalizeDirectDetailedObserve table detailedObserve context fuel value) = + evalDist (canonicalizeDirectDetailedPrivateObserve table observe context fuel value) := by + unfold canonicalizeDirectDetailedObserve canonicalizeDirectDetailedPrivateObserve + by_cases hprivate : PrivateStructuralHit (canonicalizeMaterializedValues table context) + · simp [hprivate, DirectBoundaryOutcome.privateStructural] + · simp only [hprivate, ↓reduceIte] + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + exact evalDist_private_classifyDirectDetailedObserve table detailedObserve observe + (canonicalizeMaterializedValues table context) fuel value hproject + · simp [hpublished, DirectBoundaryOutcome.privateStructural] + +noncomputable def runDirectDetailedPrivateObserve + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) : + ProbComp Bool := + runDirectResolvedDetailedFromTable context fuel table computation >>= + finishDirectDetailedPrivateObserve observe + +theorem evalDist_runDirectDetailedPrivateObserve_bind + (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (fuel : Nat) + (left : OracleComp (LazyRevealProbe.World Coordinate) α) + (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) + (observe : DeferredContext → Nat → β → ProbComp Bool) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + evalDist + (runDirectDetailedPrivateObserve observe context fuel table (left >>= next)) = + evalDist (runDirectResolvedDetailedFromTable context fuel table left >>= + finishDirectDetailedPrivateObserve + (fun nextContext remaining value => + runDirectDetailedPrivateObserve observe nextContext remaining table + (next value))) := by + unfold runDirectDetailedPrivateObserve + rw [runDirectResolvedDetailedFromTable_bind, bind_assoc] + apply evalDist_bind_congr + intro result hresult + cases result with + | stopped reason => cases reason <;> rfl + | done result => + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + left context fuel table result hresult + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable + left context fuel table result hconsistent hstarts hdirect + simp [finishDirectDetailedPrivateObserve, hcore.1] + +theorem evalDist_private_runDirectDetailedObserve + (detailedObserve : DeferredContext → Nat → alpha → ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → alpha → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (hproject : ∀ result, + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) → + evalDist (DirectBoundaryOutcome.privateStructural <$> + detailedObserve result.context result.remaining result.value) = + evalDist (observe result.context result.remaining result.value)) : + evalDist (DirectBoundaryOutcome.privateStructural <$> + runDirectDetailedObserve detailedObserve context fuel table computation) = + evalDist (runDirectDetailedPrivateObserve observe context fuel table computation) := by + unfold runDirectDetailedObserve runDirectDetailedPrivateObserve + rw [map_bind] + apply evalDist_bind_congr + intro result hresult + cases result with + | stopped reason => + cases reason <;> rfl + | done result => + exact hproject result hresult + +noncomputable def directDetailedBoundaryPrivateObserve + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec alpha) + (observe : DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp Bool := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp spec alpha => + (DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) → + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp Bool) + (fun value observe context fuel _table cache => observe context fuel (value, cache)) + (fun query _next recursivelyRun observe context fuel table cache => + runDirectDetailedPrivateObserve + (canonicalizeDirectDetailedPrivateObserve table + (fun nextContext remaining value => + recursivelyRun value.1 observe nextContext remaining table value.2)) + context fuel table ((impl query).run cache)) + computation observe context fuel table cache + +set_option maxRecDepth 100000 in +theorem evalDist_private_directDetailedBoundaryObserve + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec alpha) + (detailedObserve : DeferredContext → Nat → (alpha × SplitHashCache) → + ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → (alpha × SplitHashCache) → ProbComp Bool) + (hobserve : ∀ context fuel value, + evalDist (DirectBoundaryOutcome.privateStructural <$> + detailedObserve context fuel value) = + evalDist (observe context fuel value)) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) : + evalDist (DirectBoundaryOutcome.privateStructural <$> + directDetailedBoundaryObserve impl computation detailedObserve context fuel table cache) = + evalDist (directDetailedBoundaryPrivateObserve impl computation observe + context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + rw [directDetailedBoundaryObserve, OracleComp.construct_pure, + directDetailedBoundaryPrivateObserve, OracleComp.construct_pure] + exact hobserve context fuel (value, cache) + | query_bind query next ih => + rw [directDetailedBoundaryObserve, OracleComp.construct_query_bind, + directDetailedBoundaryPrivateObserve, OracleComp.construct_query_bind] + apply evalDist_private_runDirectDetailedObserve + intro result _hresult + apply evalDist_private_canonicalizeDirectDetailedObserve + exact ih result.value.1 (canonicalizeMaterializedValues table result.context) + result.remaining result.value.2 + +noncomputable def directDetailedVerifierFinishPrivateObserve + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : (Forgery × QueryLog SigningSpec) × SplitHashCache) : + ProbComp Bool := + runDirectDetailedPrivateObserve + (classifyDirectPrivateObserve table (fun _ _ _ => pure false)) + context fuel table ((canonicalVerifierFinish parameter root value.1).run value.2) + +theorem evalDist_private_directDetailedVerifierFinishObserve + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : (Forgery × QueryLog SigningSpec) × SplitHashCache) : + evalDist (DirectBoundaryOutcome.privateStructural <$> + directDetailedVerifierFinishObserve table parameter root context fuel value) = + evalDist (directDetailedVerifierFinishPrivateObserve table parameter root + context fuel value) := by + unfold directDetailedVerifierFinishObserve directDetailedVerifierFinishPrivateObserve + apply evalDist_private_runDirectDetailedObserve + intro result _hresult + exact evalDist_private_classifyDirectObserve table (resolvedFinalizationObserve table) + result.context result.remaining result.value + +noncomputable def allDirectDetailedRetainedRestPrivateObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp Bool := + directDetailedBoundaryPrivateObserve + (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (signingTraceComputation (adversary.main ⟨value.1, parameter⟩)) + (directDetailedVerifierFinishPrivateObserve table parameter value.1) + context fuel table value.2 + +theorem evalDist_private_allDirectDetailedRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : + evalDist (DirectBoundaryOutcome.privateStructural <$> + allDirectDetailedRetainedRestObserve adversary parameter table ftsSecret + context fuel value) = + evalDist (allDirectDetailedRetainedRestPrivateObserve adversary parameter table + ftsSecret context fuel value) := by + unfold allDirectDetailedRetainedRestObserve allDirectDetailedRetainedRestPrivateObserve + apply evalDist_private_directDetailedBoundaryObserve + intro nextContext remaining nextValue + exact evalDist_private_directDetailedVerifierFinishObserve table parameter value.1 + nextContext remaining nextValue + +noncomputable def allDirectBoundaryDetailedRetainedPrivate + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := + runDirectDetailedPrivateObserve + (allDirectDetailedRetainedRestPrivateObserve adversary parameter table ftsSecret) + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +theorem evalDist_private_allDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.privateStructural <$> + allDirectBoundaryDetailedRetainedOutcome adversary parameter table ftsSecret fuel) = + evalDist (allDirectBoundaryDetailedRetainedPrivate adversary parameter table + ftsSecret fuel) := by + unfold allDirectBoundaryDetailedRetainedOutcome allDirectBoundaryDetailedRetainedPrivate + apply evalDist_private_runDirectDetailedObserve + intro result _hresult + exact evalDist_private_allDirectDetailedRetainedRestObserve adversary parameter table ftsSecret + result.context result.remaining result.value + +noncomputable def sampledAllDirectBoundaryDetailedRetainedPrivate + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := do + let table ← sampleOtsHashTable + allDirectBoundaryDetailedRetainedPrivate adversary parameter table ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem evalDist_private_sampledAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.privateStructural <$> + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret fuel) = + evalDist (sampledAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret fuel) := by + unfold sampledAllDirectBoundaryDetailedRetainedOutcome + sampledAllDirectBoundaryDetailedRetainedPrivate + rw [map_bind] + apply evalDist_bind_congr + intro table _htable + exact evalDist_private_allDirectBoundaryDetailedRetainedOutcome adversary parameter table + ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_privateStructuralFailure_sampledAllDirectBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[= .privateStructuralFailure | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret fuel] = + Pr[= true | + sampledAllDirectBoundaryDetailedRetainedPrivate adversary parameter ftsSecret fuel] := by + rw [probEvent_privateStructuralFailure_eq_map_privateStructural] + exact OracleComp.probOutput_congr rfl + (evalDist_private_sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret fuel) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateCandidateGame.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateCandidateGame.lean new file mode 100644 index 00000000..ba46fea2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateCandidateGame.lean @@ -0,0 +1,215 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateCount + +/-! +# Finite planned-candidate game + +The abstract all-miss endpoint samples only structural coordinates named by the recorded candidate list. Repeated candidates at one coordinate share one hidden output, and the total first-fire probability is charged by the list length rather than by a structural-position universe. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +def candidateTargets (target : Position) (candidate : Probe) : Bool := + decide (candidate.coordinate = .position target) + +def candidateTargetCount (target : Position) (candidates : List Probe) : Nat := + candidates.countP (candidateTargets target) + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_sampleHashOutput_candidateListHits_le_count + (target : Position) (candidates : List Probe) : + Pr[candidateListHits target candidates | LazyRevealProbe.sampleHashOutput] ≤ + (candidateTargetCount target candidates : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + induction candidates with + | nil => simp [candidateListHits, candidateTargetCount] + | cons candidate remaining ih => + let epsilon := ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + by_cases hcoordinate : candidate.coordinate = .position target + · have hhead : Pr[fun output : HashOutput => + truncateHash output = candidate.candidate | + LazyRevealProbe.sampleHashOutput] = epsilon := by + calc + _ = (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + unfold LazyRevealProbe.sampleHashOutput + exact SphincsSecurity.probEvent_uniform_truncateHash_eq _ + _ = epsilon := by + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + have hevent : candidateListHits target (candidate :: remaining) = + fun output => truncateHash output = candidate.candidate ∨ + candidateListHits target remaining output := by + funext output + simp [candidateListHits, hcoordinate] + calc + _ = Pr[fun output : HashOutput => + truncateHash output = candidate.candidate ∨ + candidateListHits target remaining output | + LazyRevealProbe.sampleHashOutput] := by rw [hevent] + _ ≤ Pr[fun output : HashOutput => + truncateHash output = candidate.candidate | + LazyRevealProbe.sampleHashOutput] + + Pr[candidateListHits target remaining | + LazyRevealProbe.sampleHashOutput] := + probEvent_or_le LazyRevealProbe.sampleHashOutput _ _ + _ ≤ epsilon + + (candidateTargetCount target remaining : ℝ≥0∞) * epsilon := + add_le_add hhead.le ih + _ = (candidateTargetCount target (candidate :: remaining) : ℝ≥0∞) * + epsilon := by + simp [candidateTargetCount, candidateTargets, hcoordinate] + ring + · have hevent : candidateListHits target (candidate :: remaining) = + candidateListHits target remaining := by + funext output + simp [candidateListHits, hcoordinate] + rw [hevent] + simpa [candidateTargetCount, candidateTargets, hcoordinate] using ih + +def removeTargetCandidates (target : Position) (candidates : List Probe) : List Probe := + candidates.filter fun candidate => !candidateTargets target candidate + +theorem candidateTargetCount_add_removeTargetCandidates_length + (target : Position) (candidates : List Probe) : + candidateTargetCount target candidates + + (removeTargetCandidates target candidates).length = candidates.length := by + rw [candidateTargetCount, removeTargetCandidates, List.countP_eq_length_filter] + exact (List.length_eq_length_filter_add + (l := candidates) (candidateTargets target)).symm + +noncomputable def plannedCandidateGroupsFire : Nat → List Probe → ProbComp Bool + | 0, _ => pure false + | _ + 1, [] => pure false + | fuel + 1, candidate :: remaining => + match candidate.coordinate with + | .chainStart _ _ _ _ => plannedCandidateGroupsFire fuel remaining + | .position target => do + let output ← LazyRevealProbe.sampleHashOutput + if candidateListHits target (candidate :: remaining) output then + pure true + else + plannedCandidateGroupsFire fuel + (removeTargetCandidates target (candidate :: remaining)) + +noncomputable def plannedCandidateListFire (candidates : List Probe) : ProbComp Bool := + plannedCandidateGroupsFire candidates.length candidates + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem probEvent_plannedCandidateGroupsFire_le + (fuel : Nat) (candidates : List Probe) (hlength : candidates.length ≤ fuel) : + Pr[= true | plannedCandidateGroupsFire fuel candidates] ≤ + (candidates.length : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + let epsilon := ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + induction fuel generalizing candidates with + | zero => + have hcandidates : candidates = [] := List.eq_nil_of_length_eq_zero (by omega) + subst candidates + simp [plannedCandidateGroupsFire] + | succ fuel ih => + cases candidates with + | nil => simp [plannedCandidateGroupsFire] + | cons candidate remaining => + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [plannedCandidateGroupsFire, hcoordinate] + exact (ih remaining (by simpa using hlength)).trans (by + gcongr + simp) + | position target => + let rest := removeTargetCandidates target (candidate :: remaining) + have hheadTarget : candidateTargets target candidate = true := by + simp [candidateTargets, hcoordinate] + have hcountPositive : + 1 ≤ candidateTargetCount target (candidate :: remaining) := by + simp [candidateTargetCount, hheadTarget] + have hrestLength : rest.length ≤ fuel := by + have hpartition := + candidateTargetCount_add_removeTargetCandidates_length target + (candidate :: remaining) + dsimp only [rest] + omega + have hrest := ih rest hrestLength + have hstep : Pr[= true | + LazyRevealProbe.sampleHashOutput >>= fun output => + if candidateListHits target (candidate :: remaining) output then + pure true + else plannedCandidateGroupsFire fuel rest] ≤ + (candidateTargetCount target (candidate :: remaining) : ℝ≥0∞) * epsilon + + (rest.length : ℝ≥0∞) * epsilon := by + rw [← probEvent_eq_eq_probOutput] + rw [← probEvent_eq_eq_probOutput] at hrest + have hbind := probEvent_bind_le_probEvent_add + (mx := LazyRevealProbe.sampleHashOutput) + (my := fun output => + if candidateListHits target (candidate :: remaining) output then + pure true + else plannedCandidateGroupsFire fuel rest) + (q := fun hit : Bool => hit = true) + (p := candidateListHits target (candidate :: remaining)) + (ε := (rest.length : ℝ≥0∞) * epsilon) (by + intro output _houtput hmiss + simp only [hmiss, ↓reduceIte] + simpa only [epsilon] using hrest) + calc + _ ≤ Pr[candidateListHits target (candidate :: remaining) | + LazyRevealProbe.sampleHashOutput] + + (rest.length : ℝ≥0∞) * epsilon := hbind + _ ≤ (candidateTargetCount target (candidate :: remaining) : ℝ≥0∞) * + epsilon + (rest.length : ℝ≥0∞) * epsilon := + add_le_add + (probEvent_sampleHashOutput_candidateListHits_le_count target + (candidate :: remaining)) le_rfl + rw [plannedCandidateGroupsFire, hcoordinate] + change Pr[= true | + LazyRevealProbe.sampleHashOutput >>= fun output => + if candidateListHits target (candidate :: remaining) output then + pure true + else plannedCandidateGroupsFire fuel rest] ≤ _ + calc + _ ≤ (candidateTargetCount target (candidate :: remaining) : ℝ≥0∞) * epsilon + + (rest.length : ℝ≥0∞) * epsilon := hstep + _ = ((candidateTargetCount target (candidate :: remaining) + + rest.length : Nat) : ℝ≥0∞) * epsilon := by + push_cast + ring + _ = ((candidate :: remaining).length : ℝ≥0∞) * epsilon := by + rw [candidateTargetCount_add_removeTargetCandidates_length target + (candidate :: remaining)] + +theorem probEvent_plannedCandidateListFire_le (candidates : List Probe) : + Pr[= true | plannedCandidateListFire candidates] ≤ + (candidates.length : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + exact probEvent_plannedCandidateGroupsFire_le candidates.length candidates le_rfl + +theorem probEvent_bind_plannedCandidateListFire_le_of_length + (plans : ProbComp (List Probe)) (q : Nat) + (hlength : ∀ candidates ∈ support plans, candidates.length ≤ q) : + Pr[= true | plans >>= plannedCandidateListFire] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_of_forall_le + intro candidates hcandidates + rw [probEvent_eq_eq_probOutput] + exact (probEvent_plannedCandidateListFire_le candidates).trans (by + gcongr + exact_mod_cast hlength candidates hcandidates) + +theorem probEvent_privatePlan_le_of_candidate_game + (run : ProbComp (Bool × List Probe)) (q : Nat) + (hdomination : Pr[fun result => result.1 = true | run] ≤ + Pr[= true | (Prod.snd <$> run) >>= plannedCandidateListFire]) + (hlength : ∀ result ∈ support run, result.2.length ≤ q) : + Pr[fun result => result.1 = true | run] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply hdomination.trans + apply probEvent_bind_plannedCandidateListFire_le_of_length + intro candidates hcandidates + rw [support_map] at hcandidates + obtain ⟨result, hresult, rfl⟩ := hcandidates + exact hlength result hresult + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateCandidateResolve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateCandidateResolve.lean new file mode 100644 index 00000000..798eeda8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateCandidateResolve.lean @@ -0,0 +1,156 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateCandidateGame + +/-! +# Deferred resolution of a finite candidate list + +This module realizes the abstract finite candidate game through the actual deferred structural resolver. It starts from a context fresh at every structural coordinate named by the list, samples each named coordinate only when its group is processed, and leaves unrelated coordinates untouched. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +def CandidateCoordinatesFresh (context : DeferredContext) (candidates : List Probe) : Prop := + context.state.pending = ∅ ∧ + ∀ candidate ∈ candidates, + match candidate.coordinate with + | .chainStart _ _ _ _ => True + | .position position => + context.state.values (.position position) = none ∧ + context.values position = none + +theorem candidateCoordinatesFresh_empty (candidates : List Probe) : + CandidateCoordinatesFresh + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + candidates := by + constructor + · rfl + · intro candidate _hcandidate + cases candidate.coordinate <;> simp [LazyRevealProbe.State.empty, + emptyDeferredStructuralValues] + +theorem not_hitAt_of_pending_eq_empty + (context : DeferredContext) (coordinate : Coordinate) (output : HashOutput) + (hpending : context.state.pending = ∅) : + ¬context.state.hitAt coordinate output := by + simp [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, hpending] + +noncomputable def resolvedCandidateGroupsFire : Nat → List Probe → DeferredContext → ProbComp Bool + | 0, _, _ => pure false + | _ + 1, [], _ => pure false + | fuel + 1, candidate :: remaining, context => + match candidate.coordinate with + | .chainStart _ _ _ _ => resolvedCandidateGroupsFire fuel remaining context + | .position target => do + let resolved ← resolveDeferredPositionValue target context + match resolved with + | none => pure true + | some resolved => + if candidateListHits target (candidate :: remaining) resolved.output then + pure true + else + resolvedCandidateGroupsFire fuel + (removeTargetCandidates target (candidate :: remaining)) + resolved.toDeferredContext + +theorem candidateCoordinatesFresh_remove_resolved + (context : DeferredContext) (candidate : Probe) (remaining : List Probe) + (target : Position) (output : HashOutput) + (hfresh : CandidateCoordinatesFresh context (candidate :: remaining)) : + CandidateCoordinatesFresh + { state := context.state.clearPending (.position target) + values := context.values.install target output } + (removeTargetCandidates target (candidate :: remaining)) := by + constructor + · simp [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway, hfresh.1] + · intro nextCandidate hnext + have hnextOriginal : nextCandidate ∈ candidate :: remaining := by + unfold removeTargetCandidates at hnext + exact (List.mem_filter.mp hnext).1 + have hnotTarget : ¬candidateTargets target nextCandidate := by + unfold removeTargetCandidates at hnext + have := (List.mem_filter.mp hnext).2 + simpa using this + have hnextFresh := hfresh.2 nextCandidate hnextOriginal + cases hnextCoordinate : nextCandidate.coordinate with + | chainStart lay tree leafIdx chainIdx => trivial + | position other => + simp only [hnextCoordinate] at hnextFresh + have hne : other ≠ target := by + intro heq + subst other + apply hnotTarget + simp [candidateTargets, hnextCoordinate] + constructor + · simpa [LazyRevealProbe.State.clearPending] using hnextFresh.1 + · simpa [DeferredStructuralValues.install, Function.update_of_ne hne] using + hnextFresh.2 + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem evalDist_resolvedCandidateGroupsFire_eq_planned + (fuel : Nat) (candidates : List Probe) (context : DeferredContext) + (hfresh : CandidateCoordinatesFresh context candidates) : + evalDist (resolvedCandidateGroupsFire fuel candidates context) = + evalDist (plannedCandidateGroupsFire fuel candidates) := by + induction fuel generalizing candidates context with + | zero => simp [resolvedCandidateGroupsFire, plannedCandidateGroupsFire] + | succ fuel ih => + cases candidates with + | nil => simp [resolvedCandidateGroupsFire, plannedCandidateGroupsFire] + | cons candidate remaining => + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [resolvedCandidateGroupsFire, plannedCandidateGroupsFire, hcoordinate] + exact ih remaining context ⟨hfresh.1, fun next hnext => + hfresh.2 next (List.mem_cons_of_mem candidate hnext)⟩ + | position target => + have htargetFresh := hfresh.2 candidate (by simp) + simp only [hcoordinate] at htargetFresh + have hnoHit : ∀ output, + ¬context.state.hitAt (.position target) output := fun output => + not_hitAt_of_pending_eq_empty context (.position target) output hfresh.1 + simp only [resolvedCandidateGroupsFire, plannedCandidateGroupsFire, hcoordinate] + rw [resolveDeferredPositionValue_fresh target context htargetFresh.1 + htargetFresh.2] + simp only [bind_assoc] + apply evalDist_bind_congr + intro output _houtput + simp only [hnoHit output, ↓reduceIte, pure_bind] + by_cases hfire : candidateListHits target (candidate :: remaining) output + · simp [hfire] + · simp only [hfire, ↓reduceIte] + exact ih (removeTargetCandidates target (candidate :: remaining)) + { state := context.state.clearPending (.position target) + values := context.values.install target output } + (candidateCoordinatesFresh_remove_resolved context candidate remaining target + output hfresh) + +noncomputable def resolvedCandidateListFire + (candidates : List Probe) (context : DeferredContext) : ProbComp Bool := + resolvedCandidateGroupsFire candidates.length candidates context + +theorem evalDist_resolvedCandidateListFire_empty + (candidates : List Probe) : + evalDist (resolvedCandidateListFire candidates + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues }) = + evalDist (plannedCandidateListFire candidates) := by + exact evalDist_resolvedCandidateGroupsFire_eq_planned candidates.length candidates _ + (candidateCoordinatesFresh_empty candidates) + +theorem probEvent_resolvedCandidateListFire_empty_le (candidates : List Probe) : + Pr[= true | resolvedCandidateListFire candidates + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues }] ≤ + (candidates.length : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ = Pr[= true | plannedCandidateListFire candidates] := + OracleComp.probOutput_congr rfl + (evalDist_resolvedCandidateListFire_empty candidates) + _ ≤ _ := probEvent_plannedCandidateListFire_le candidates + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateCount.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateCount.lean new file mode 100644 index 00000000..aa6fb8bb --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateCount.lean @@ -0,0 +1,329 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateTrace + +/-! +# Planned-probe count + +The proof-only plan trace appends at most one candidate at an outer hash query and appends none at uniform or signing queries. Consequently every supported trace contains at most the source computation's outer hash-query budget many new candidates. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +theorem appendPlannedCandidate_length_le (candidates : List Probe) + (planned : Option Probe) : + (appendPlannedCandidate candidates planned).length ≤ candidates.length + 1 := by + cases planned <;> simp [appendPlannedCandidate] + +theorem maskedExpandedAdversaryPlanner_none_of_not_outer + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) + (hquery : ¬IsOuterHash query) : + maskedExpandedAdversaryPlanner parameter root ftsSecret query = pure none := by + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => rfl + | inr input => simp [IsOuterHash] at hquery + | inr message => rfl + +theorem support_finishDirectDetailedPrivatePlanObserve_length_le + (observe : DeferredContext → Nat → α → List Probe → ProbComp (Bool × List Probe)) + (candidates : List Probe) (result : DirectDetailedResult α) (bound : Nat) + (hobserve : ∀ context fuel value candidates output, + output ∈ support (observe context fuel value candidates) → + output.2.length ≤ candidates.length + bound) + (output : Bool × List Probe) + (houtput : output ∈ support + (finishDirectDetailedPrivatePlanObserve observe candidates result)) : + output.2.length ≤ candidates.length + bound := by + cases result with + | stopped reason => + cases reason <;> + simp [finishDirectDetailedPrivatePlanObserve] at houtput <;> + subst output <;> simp + | done result => + exact hobserve result.context result.remaining result.value candidates output houtput + +theorem support_classifyDirectDetailedPrivatePlanObserve_length_le + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → ProbComp (Bool × List Probe)) + (context : DeferredContext) (fuel : Nat) (value : α) + (candidates : List Probe) (bound : Nat) + (hobserve : ∀ nextContext remaining nextValue nextCandidates output, + output ∈ support (observe nextContext remaining nextValue nextCandidates) → + output.2.length ≤ nextCandidates.length + bound) + (output : Bool × List Probe) + (houtput : output ∈ support + (classifyDirectDetailedPrivatePlanObserve table observe context fuel value candidates)) : + output.2.length ≤ candidates.length + bound := by + unfold classifyDirectDetailedPrivatePlanObserve at houtput + by_cases hprivate : PrivateStructuralHit context + · simp [hprivate] at houtput + subst output + simp + · simp only [hprivate, ↓reduceIte] at houtput + by_cases hcompletable : DeferredCompletable table context + · simp only [hcompletable, ↓reduceIte] at houtput + exact hobserve context fuel value candidates output houtput + · simp [hcompletable] at houtput + subst output + simp + +theorem support_canonicalizeDirectDetailedPrivatePlanObserve_length_le + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → ProbComp (Bool × List Probe)) + (context : DeferredContext) (fuel : Nat) (value : α) + (candidates : List Probe) (bound : Nat) + (hobserve : ∀ nextContext remaining nextValue nextCandidates output, + output ∈ support (observe nextContext remaining nextValue nextCandidates) → + output.2.length ≤ nextCandidates.length + bound) + (output : Bool × List Probe) + (houtput : output ∈ support + (canonicalizeDirectDetailedPrivatePlanObserve table observe + context fuel value candidates)) : + output.2.length ≤ candidates.length + bound := by + unfold canonicalizeDirectDetailedPrivatePlanObserve at houtput + by_cases hprivate : PrivateStructuralHit (canonicalizeMaterializedValues table context) + · simp [hprivate] at houtput + subst output + simp + · simp only [hprivate, ↓reduceIte] at houtput + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] at houtput + exact support_classifyDirectDetailedPrivatePlanObserve_length_le table observe + (canonicalizeMaterializedValues table context) fuel value candidates bound hobserve + output houtput + · simp [hpublished] at houtput + subst output + simp + +theorem support_canonicalizeDirectDetailedPrivatePlanObserve_length_le_at + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → ProbComp (Bool × List Probe)) + (context : DeferredContext) (fuel : Nat) (value : α) + (candidates : List Probe) (bound : Nat) + (hobserve : ∀ output, + output ∈ support + (observe (canonicalizeMaterializedValues table context) fuel value candidates) → + output.2.length ≤ candidates.length + bound) + (output : Bool × List Probe) + (houtput : output ∈ support + (canonicalizeDirectDetailedPrivatePlanObserve table observe + context fuel value candidates)) : + output.2.length ≤ candidates.length + bound := by + unfold canonicalizeDirectDetailedPrivatePlanObserve at houtput + by_cases hprivate : PrivateStructuralHit (canonicalizeMaterializedValues table context) + · simp [hprivate] at houtput + subst output + simp + · simp only [hprivate, ↓reduceIte] at houtput + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] at houtput + unfold classifyDirectDetailedPrivatePlanObserve at houtput + simp only [hprivate, ↓reduceIte] at houtput + by_cases hcompletable : + DeferredCompletable table (canonicalizeMaterializedValues table context) + · simp only [hcompletable, ↓reduceIte] at houtput + exact hobserve output houtput + · simp [hcompletable] at houtput + subst output + simp + · simp [hpublished] at houtput + subst output + simp + +theorem support_runDirectDetailedPrivatePlanObserve_length_le + (observe : DeferredContext → Nat → α → List Probe → ProbComp (Bool × List Probe)) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (bound : Nat) + (hobserve : ∀ nextContext remaining value nextCandidates output, + output ∈ support (observe nextContext remaining value nextCandidates) → + output.2.length ≤ nextCandidates.length + bound) + (output : Bool × List Probe) + (houtput : output ∈ support + (runDirectDetailedPrivatePlanObserve observe candidates context fuel table computation)) : + output.2.length ≤ candidates.length + bound := by + unfold runDirectDetailedPrivatePlanObserve at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, houtput⟩ := houtput + exact support_finishDirectDetailedPrivatePlanObserve_length_le observe candidates result bound + hobserve output houtput + +theorem support_runDirectDetailedPrivatePlanObserve_length_le_of_done + (observe : DeferredContext → Nat → α → List Probe → ProbComp (Bool × List Probe)) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (bound : Nat) + (hobserve : ∀ result, + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) → + ∀ output, output ∈ support + (observe result.context result.remaining result.value candidates) → + output.2.length ≤ candidates.length + bound) + (output : Bool × List Probe) + (houtput : output ∈ support + (runDirectDetailedPrivatePlanObserve observe candidates context fuel table computation)) : + output.2.length ≤ candidates.length + bound := by + unfold runDirectDetailedPrivatePlanObserve at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, houtput⟩ := houtput + cases result with + | stopped reason => + cases reason <;> + simp [finishDirectDetailedPrivatePlanObserve] at houtput <;> + subst output <;> simp + | done result => + exact hobserve result hresult output houtput + +theorem resolvedCore_of_done_runDirectResolvedDetailedFromTable_for_count + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation)) : + result.table = table ∧ result.context.ValuesConsistent ∧ + StartTableAgrees result.context.state table := by + apply resolvedCore_of_mem_runDirectResolvedFromTable computation context fuel table result + hconsistent hstarts + exact mem_support_runDirectResolvedFromTable_of_done_detailed computation context fuel table + result hresult + +set_option maxRecDepth 100000 in +theorem support_directDetailedBoundaryPrivatePlanObserve_length_le + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp (Bool × List Probe)) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) (q : Nat) + (hbound : computation.IsQueryBoundP IsOuterHash q) + (hobserve : ∀ nextContext remaining value nextCandidates output, + output ∈ support (observe nextContext remaining value nextCandidates) → + output.2.length ≤ nextCandidates.length) + (output : Bool × List Probe) + (houtput : output ∈ support + (directDetailedBoundaryPrivatePlanObserve + (maskedExpandedAdversaryImpl parameter root ftsSecret) + (maskedExpandedAdversaryPlanner parameter root ftsSecret) + computation observe candidates context fuel table cache)) : + output.2.length ≤ candidates.length + q := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache q output with + | pure value => + simp only [directDetailedBoundaryPrivatePlanObserve, + OracleComp.construct_pure] at houtput + exact (hobserve context fuel (value, cache) candidates output houtput).trans + (Nat.le_add_right candidates.length q) + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [directDetailedBoundaryPrivatePlanObserve, + OracleComp.construct_query_bind, mem_support_bind_iff] at houtput + obtain ⟨plannedResult, hplanned, houtput⟩ := houtput + cases plannedResult with + | stopped reason => + simp at houtput + subst output + simp + | done plannedResult => + let nextCandidates := appendPlannedCandidate candidates plannedResult.value.1 + have htail : output.2.length ≤ nextCandidates.length + + (if IsOuterHash query then q - 1 else q) := by + apply support_runDirectDetailedPrivatePlanObserve_length_le + (canonicalizeDirectDetailedPrivatePlanObserve table + (fun nextContext remaining value nextCandidates => + directDetailedBoundaryPrivatePlanObserve + (maskedExpandedAdversaryImpl parameter root ftsSecret) + (maskedExpandedAdversaryPlanner parameter root ftsSecret) + (next value.1) observe nextCandidates nextContext remaining table value.2)) + nextCandidates plannedResult.context plannedResult.remaining table + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run + plannedResult.value.2) + (if IsOuterHash query then q - 1 else q) + · intro nextContext remaining value laterCandidates laterOutput hlater + exact support_canonicalizeDirectDetailedPrivatePlanObserve_length_le table _ + nextContext remaining value laterCandidates + (if IsOuterHash query then q - 1 else q) + (by + intro canonicalContext canonicalRemaining + (canonicalValue : + (OracleWorld + SigningSpec).Range query × SplitHashCache) + canonicalCandidates canonicalOutput hcanonicalOutput + exact ih canonicalValue.1 + (candidates := canonicalCandidates) (context := canonicalContext) + (fuel := canonicalRemaining) (cache := canonicalValue.2) + (q := if IsOuterHash query then q - 1 else q) + (output := canonicalOutput) (hbound.2 canonicalValue.1) + hcanonicalOutput) + laterOutput hlater + · exact houtput + by_cases hquery : IsOuterHash query + · have hpositive : 0 < q := by + rcases hbound.1 with hnot | hpositive + · exact (hnot hquery).elim + · exact hpositive + have hnextLength : nextCandidates.length ≤ candidates.length + 1 := + appendPlannedCandidate_length_le candidates plannedResult.value.1 + simp only [hquery, ↓reduceIte] at htail + omega + · have hplanner : maskedExpandedAdversaryPlanner parameter root ftsSecret query = + pure none := + maskedExpandedAdversaryPlanner_none_of_not_outer parameter root ftsSecret query + hquery + have hplannedNone : plannedResult.value.1 = none := by + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + ((maskedExpandedAdversaryPlanner parameter root ftsSecret query).run cache) + context fuel table plannedResult hplanned + rw [hplanner, StateT.run_pure] at hdirect + have hraw := raw_done_of_mem_runDirectResolvedFromTable + ((pure none : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Probe)).run cache) + context fuel table plannedResult hdirect + simp [LazyRevealProbe.runRaw] at hraw + exact congrArg Prod.fst hraw.2.2 + simp only [hquery, ↓reduceIte] at htail + simp [nextCandidates, hplannedNone, appendPlannedCandidate] at htail ⊢ + exact htail + +theorem support_retainedResolvedFinalizationPrivatePlanObserve_length_le + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) (candidates : List Probe) + (output : Bool × List Probe) + (houtput : output ∈ support + (retainedResolvedFinalizationPrivatePlanObserve table root context fuel value candidates)) : + output.2.length ≤ candidates.length := by + unfold retainedResolvedFinalizationPrivatePlanObserve at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨hit, _hhit, houtput⟩ := houtput + simp at houtput + subst output + simp + +set_option maxRecDepth 100000 in +theorem support_granularDetailedRetainedRestPrivatePlanObserve_length_le + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) (q : Nat) + (hbound : (retainedGameRestComputation adversary ⟨value.1, parameter⟩).IsQueryBoundP + IsOuterHash q) + (output : Bool × List Probe) + (houtput : output ∈ support + (granularDetailedRetainedRestPrivatePlanObserve adversary parameter table ftsSecret + context fuel value candidates)) : + output.2.length ≤ candidates.length + q := by + unfold granularDetailedRetainedRestPrivatePlanObserve at houtput + exact support_directDetailedBoundaryPrivatePlanObserve_length_le parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivatePlanObserve table value.1) + candidates context fuel table value.2 q hbound + (support_retainedResolvedFinalizationPrivatePlanObserve_length_le table value.1) + output houtput + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateFresh.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateFresh.lean new file mode 100644 index 00000000..a4b70988 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateFresh.lean @@ -0,0 +1,198 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePlan + +/-! +# Fresh planned private probes + +This file moves one planned structural draw immediately before its candidate and carries a clean miss through the probe-free hash suffix. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +theorem canonicalizeMaterializedValues_eq_of_canonical + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hcanonical : CanonicalMaterializedValues table context) : + canonicalizeMaterializedValues table context = context := by + unfold CanonicalMaterializedValues at hcanonical + cases context with + | mk state values => + cases state with + | mk pending stateValues revealed ensured => + simp only [canonicalizeMaterializedValues] + rw [← hcanonical] + +theorem publicMaterializedValues_addPending + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (coordinate : Coordinate) (candidate : Digest) : + publicMaterializedValues table + { context with state := context.state.addPending coordinate candidate } = + publicMaterializedValues table context := by + funext other + unfold publicMaterializedValues resolvedCompletionValue DeferredContext.positionValue + rfl + +theorem canonicalMaterializedValues_resolve_addPending + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (position : Position) (candidate : Digest) (resolved : DeferredResolution) + (hpublished : PublishedValues context.state) + (hcanonical : CanonicalMaterializedValues table context) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue position context)) : + CanonicalMaterializedValues table + { resolved.toDeferredContext with + state := resolved.state.addPending (.position position) candidate } := by + unfold CanonicalMaterializedValues + have hstate := resolveDeferredPositionValue_state_eq_clearPending position context resolved + hresolved + have hpublic := publicMaterializedValues_clearPending_values table context + (.position position) resolved.values hpublished + change (resolved.state.addPending (.position position) candidate).values = + publicMaterializedValues table + { state := resolved.state.addPending (.position position) candidate + values := resolved.values } + rw [hstate] + change context.state.values = _ + rw [hcanonical] + rw [publicMaterializedValues_addPending table + { state := context.state.clearPending (.position position) + values := resolved.values } + (.position position) candidate] + exact hpublic.symm + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem probEvent_granularPrivateProbeFree_le + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (nextObserve : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + (epsilon terminalBound : ℝ≥0∞) + (hprobeFree : ProbeFree computation) + (hrawClean : ¬PrivateStructuralHit context) + (hcanonicalClean : ¬PrivateStructuralHit + (canonicalizeMaterializedValues table context)) + (hcontinuation : ∀ result : ResolvedRunResult (α × SplitHashCache), + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table (computation.run cache)) → + PublishedValues result.context.state → + DeferredCompletable table + (canonicalizeMaterializedValues table result.context) → + Pr[= true | + nextObserve (canonicalizeMaterializedValues table result.context) + result.remaining result.value] ≤ + (result.remaining : ℝ≥0∞) * epsilon + terminalBound) : + Pr[= true | + runDirectDetailedPrivateObserve + (canonicalizeDirectDetailedPrivateObserve table nextObserve) + context fuel table (computation.run cache)] ≤ + (fuel : ℝ≥0∞) * epsilon + terminalBound := by + rw [← probEvent_eq_eq_probOutput] + unfold runDirectDetailedPrivateObserve + apply probEvent_bind_le_of_forall_le + intro detailedResult hdetailed + have hsafe := canonicalPrivateSafeResult_of_probeFree + (computation.run cache) context fuel table (hprobeFree cache) + hrawClean hcanonicalClean detailedResult hdetailed + cases detailedResult with + | stopped reason => + cases reason with + | privateStructuralHit => exact False.elim hsafe + | ordinaryHit => simp [finishDirectDetailedPrivateObserve] + | fuelExhausted => simp [finishDirectDetailedPrivateObserve] + | done result => + simp only [CanonicalPrivateSafeResult] at hsafe + simp only [finishDirectDetailedPrivateObserve] + unfold canonicalizeDirectDetailedPrivateObserve + simp only [hsafe, ↓reduceIte] + by_cases hpublished : PublishedValues result.context.state + · simp only [hpublished, ↓reduceIte] + unfold classifyDirectDetailedPrivateObserve + simp only [hsafe, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table + (canonicalizeMaterializedValues table result.context) + · simp only [hcompletable, ↓reduceIte] + have hnext := hcontinuation result hdetailed hpublished hcompletable + rw [← probEvent_eq_eq_probOutput] at hnext + refine hnext.trans ?_ + gcongr + exact_mod_cast + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + (computation.run cache) context fuel table result hdetailed + · simp [hcompletable] + · simp [hpublished] + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem probEvent_resolve_addPending_probeFreeSuffix_le + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (position : Position) (candidate : Digest) + (suffix : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (nextObserve : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + (fuel : Nat) (cache : SplitHashCache) (bound : ℝ≥0∞) + (hpublished : PublishedValues context.state) + (hcanonical : CanonicalMaterializedValues table context) + (hhidden : context.state.values (.position position) = none) + (hprivate : context.values position = none) + (hclean : ¬PrivateStructuralHit context) + (hsuffix : ProbeFree suffix) + (hcontinuation : ∀ resolved : DeferredResolution, + let probeContext : DeferredContext := + { resolved.toDeferredContext with + state := resolved.state.addPending (.position position) candidate } + ¬PrivateStructuralHit probeContext → DeferredCompletable table probeContext → + ∀ result : ResolvedRunResult (α × SplitHashCache), + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable probeContext fuel table (suffix.run cache)) → + PublishedValues result.context.state → + DeferredCompletable table + (canonicalizeMaterializedValues table result.context) → + Pr[= true | + nextObserve (canonicalizeMaterializedValues table result.context) + result.remaining result.value] ≤ bound) : + Pr[= true | do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure false + | some resolved => + let probeContext : DeferredContext := + { resolved.toDeferredContext with + state := resolved.state.addPending (.position position) candidate } + classifyDirectDetailedPrivateObserve table + (fun nextContext remaining _ => + runDirectDetailedPrivateObserve + (canonicalizeDirectDetailedPrivateObserve table nextObserve) + nextContext remaining table (suffix.run cache)) + probeContext fuel cache] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + bound := by + apply probEvent_resolve_then_classifyDirectDetailedPrivateObserve_le table context position + candidate + (fun nextContext remaining _ => + runDirectDetailedPrivateObserve + (canonicalizeDirectDetailedPrivateObserve table nextObserve) + nextContext remaining table (suffix.run cache)) + fuel cache bound hclean hhidden hprivate + intro resolved hresolved + dsimp only + intro hnextClean hnextCompletable + have hnextCanonical := canonicalMaterializedValues_resolve_addPending table context position + candidate resolved hpublished hcanonical hresolved + have hcanonicalContext : canonicalizeMaterializedValues table + { resolved.toDeferredContext with + state := resolved.state.addPending (.position position) candidate } = + { resolved.toDeferredContext with + state := resolved.state.addPending (.position position) candidate } := by + exact canonicalizeMaterializedValues_eq_of_canonical table _ hnextCanonical + have hsuffixBound := probEvent_granularPrivateProbeFree_le suffix + { resolved.toDeferredContext with + state := resolved.state.addPending (.position position) candidate } + fuel table cache nextObserve 0 bound hsuffix hnextClean + (by simpa [hcanonicalContext] using hnextClean) (by + intro result hresult hresultPublished hresultCompletable + simpa using hcontinuation resolved hnextClean hnextCompletable result hresult + hresultPublished hresultCompletable) + simpa using hsuffixBound + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateHindsight.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateHindsight.lean new file mode 100644 index 00000000..098350da --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateHindsight.lean @@ -0,0 +1,420 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePreparationCanonical + +/-! +# Hindsight preparation for the normalized plan trace + +Fixing a final candidate list turns the normalized outer trace into a Boolean recursion. Every suffix probe belongs to that final list, so the guarded direct-interpreter theorem moves its private structural risk into the finite preparation observer. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable + +def PlanHitAt (finalCandidates : List Probe) (output : Bool × List Probe) : Prop := + output.1 = true ∧ output.2 = finalCandidates + +noncomputable def finishDirectDetailedPlanHitObserve + (finalCandidates currentCandidates : List Probe) + (observe : DeferredContext → Nat → α → ProbComp Bool) : + DirectDetailedResult α → ProbComp Bool + | .stopped .privateStructuralHit => pure (decide (currentCandidates = finalCandidates)) + | .stopped _ => pure false + | .done result => observe result.context result.remaining result.value + +noncomputable def runDirectDetailedPlanHitObserve + (finalCandidates currentCandidates : List Probe) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : ProbComp Bool := + runDirectResolvedDetailedFromTable context fuel table computation >>= + finishDirectDetailedPlanHitObserve finalCandidates currentCandidates observe + +theorem probEvent_runDirectDetailedPlanHitObserve_le_privatePreparation + (finalCandidates currentCandidates : List Probe) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hterminal : ∀ result : ResolvedRunResult α, + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) → + Pr[= true | observe result.context result.remaining result.value] ≤ + Pr[= true | guardedPreparationObserve finalCandidates result.context]) : + Pr[= true | runDirectDetailedPlanHitObserve finalCandidates currentCandidates observe + context fuel table computation] ≤ + Pr[= true | runPrivatePreparation finalCandidates context fuel table computation] := by + unfold runDirectDetailedPlanHitObserve runPrivatePreparation + runDirectDetailedPrivateObserve + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_bind_of_forall_le + intro result hresult + cases result with + | stopped reason => + cases reason with + | fuelExhausted => simp [finishDirectDetailedPlanHitObserve, + finishDirectDetailedPrivateObserve] + | ordinaryHit => simp [finishDirectDetailedPlanHitObserve, + finishDirectDetailedPrivateObserve] + | privateStructuralHit => + by_cases heq : currentCandidates = finalCandidates <;> + simp [finishDirectDetailedPlanHitObserve, finishDirectDetailedPrivateObserve, heq] + | done result => + simpa [finishDirectDetailedPlanHitObserve, finishDirectDetailedPrivateObserve] using + hterminal result hresult + +theorem probEvent_runDirectDetailedPlanHitObserve_eq_zero + (finalCandidates currentCandidates : List Probe) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hne : currentCandidates ≠ finalCandidates) + (hterminal : ∀ result : ResolvedRunResult α, + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) → + Pr[= true | observe result.context result.remaining result.value] = 0) : + Pr[= true | runDirectDetailedPlanHitObserve finalCandidates currentCandidates observe + context fuel table computation] = 0 := by + unfold runDirectDetailedPlanHitObserve + apply le_antisymm + · rw [← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_of_forall_le + intro result hresult + cases result with + | stopped reason => cases reason <;> + simp [finishDirectDetailedPlanHitObserve, hne] + | done result => + rw [probEvent_eq_eq_probOutput] + simpa [finishDirectDetailedPlanHitObserve] using hterminal result hresult + · exact zero_le + +theorem probEvent_runDirectDetailedPlanHitObserve_le_guarded + (finalCandidates currentCandidates : List Probe) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hcovered : PendingCoveredBy finalCandidates context) + (hbound : computation.IsQueryBoundP (IsUncoveredProbe finalCandidates) 0) + (hterminal : ∀ result : ResolvedRunResult α, + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) → + Pr[= true | observe result.context result.remaining result.value] ≤ + Pr[= true | guardedPreparationObserve finalCandidates result.context]) : + Pr[= true | runDirectDetailedPlanHitObserve finalCandidates currentCandidates observe + context fuel table computation] ≤ + Pr[= true | guardedPreparationObserve finalCandidates context] := + (probEvent_runDirectDetailedPlanHitObserve_le_privatePreparation finalCandidates + currentCandidates observe context fuel table computation hterminal).trans + (probEvent_runPrivatePreparation_le_guarded finalCandidates computation context fuel table + hcovered hbound) + +noncomputable def canonicalizeDirectDetailedPlanHitObserve + (table : OtsSecretIndex → HashOutput) + (finalCandidates currentCandidates : List Probe) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : α) : ProbComp Bool := by + classical + let canonical := canonicalizeMaterializedValues table context + exact if PrivateStructuralHit canonical then + pure (decide (currentCandidates = finalCandidates)) + else if PublishedValues context.state then + if DeferredCompletable table canonical then + observe canonical fuel value + else + pure false + else + pure false + +theorem evalDist_planHit_canonicalizeDirectDetailedPrivatePlanObserve + (table : OtsSecretIndex → HashOutput) + (finalCandidates currentCandidates : List Probe) + (observe : DeferredContext → Nat → α → List Probe → ProbComp (Bool × List Probe)) + (boolObserve : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : α) + (hproject : ∀ nextContext remaining nextValue, + evalDist ((fun output => decide (PlanHitAt finalCandidates output)) <$> + observe nextContext remaining nextValue currentCandidates) = + evalDist (boolObserve nextContext remaining nextValue)) : + evalDist ((fun output => decide (PlanHitAt finalCandidates output)) <$> + canonicalizeDirectDetailedPrivatePlanObserve table observe context fuel value + currentCandidates) = + evalDist (canonicalizeDirectDetailedPlanHitObserve table finalCandidates currentCandidates + boolObserve context fuel value) := by + unfold canonicalizeDirectDetailedPrivatePlanObserve + canonicalizeDirectDetailedPlanHitObserve + let canonical := canonicalizeMaterializedValues table context + by_cases hprivate : PrivateStructuralHit canonical + · simp [canonical, hprivate, PlanHitAt] + · by_cases hpublished : PublishedValues context.state + · simp only [canonical, hprivate, hpublished, ↓reduceIte] + change evalDist ((fun output => decide (PlanHitAt finalCandidates output)) <$> + classifyDirectDetailedPrivatePlanObserve table observe canonical fuel value + currentCandidates) = + evalDist (if DeferredCompletable table canonical then + boolObserve canonical fuel value + else pure false) + unfold classifyDirectDetailedPrivatePlanObserve + simp only [hprivate, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table canonical + · simpa [hcompletable] using hproject canonical fuel value + · simp [hcompletable, PlanHitAt] + · simp [canonical, hprivate, hpublished, PlanHitAt] + +theorem probEvent_planHit_canonicalizeDirectDetailedPrivatePlanObserve_eq + (table : OtsSecretIndex → HashOutput) + (finalCandidates currentCandidates : List Probe) + (observe : DeferredContext → Nat → α → List Probe → ProbComp (Bool × List Probe)) + (boolObserve : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : α) + (hproject : ∀ nextContext remaining nextValue, + Pr[PlanHitAt finalCandidates | + observe nextContext remaining nextValue currentCandidates] = + Pr[= true | boolObserve nextContext remaining nextValue]) : + Pr[PlanHitAt finalCandidates | + canonicalizeDirectDetailedPrivatePlanObserve table observe context fuel value + currentCandidates] = + Pr[= true | canonicalizeDirectDetailedPlanHitObserve table finalCandidates + currentCandidates boolObserve context fuel value] := by + unfold canonicalizeDirectDetailedPrivatePlanObserve + canonicalizeDirectDetailedPlanHitObserve + let canonical := canonicalizeMaterializedValues table context + by_cases hprivate : PrivateStructuralHit canonical + · simp [canonical, hprivate, PlanHitAt] + · by_cases hpublished : PublishedValues context.state + · simp only [canonical, hprivate, hpublished, ↓reduceIte] + unfold classifyDirectDetailedPrivatePlanObserve + change ¬PrivateStructuralHit (canonicalizeMaterializedValues table context) at hprivate + simp only [hprivate, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table canonical + · change DeferredCompletable table (canonicalizeMaterializedValues table context) at hcompletable + simp only [hcompletable, ↓reduceIte] + exact hproject canonical fuel value + · change ¬DeferredCompletable table (canonicalizeMaterializedValues table context) at hcompletable + simp [hcompletable, PlanHitAt] + · simp [canonical, hprivate, hpublished, PlanHitAt] + +theorem evalDist_planHit_finishDirectDetailedPrivatePlanObserve + (finalCandidates currentCandidates : List Probe) + (observe : DeferredContext → Nat → α → List Probe → ProbComp (Bool × List Probe)) + (boolObserve : DeferredContext → Nat → α → ProbComp Bool) + (result : DirectDetailedResult α) + (hproject : ∀ nextContext remaining nextValue, + evalDist ((fun output => decide (PlanHitAt finalCandidates output)) <$> + observe nextContext remaining nextValue currentCandidates) = + evalDist (boolObserve nextContext remaining nextValue)) : + evalDist ((fun output => decide (PlanHitAt finalCandidates output)) <$> + finishDirectDetailedPrivatePlanObserve observe currentCandidates result) = + evalDist (finishDirectDetailedPlanHitObserve finalCandidates currentCandidates boolObserve + result) := by + cases result with + | stopped reason => cases reason <;> simp [finishDirectDetailedPrivatePlanObserve, + finishDirectDetailedPlanHitObserve, PlanHitAt] + | done result => exact hproject result.context result.remaining result.value + +theorem probEvent_planHit_runDirectDetailedPrivatePlanObserve_eq + (finalCandidates currentCandidates : List Probe) + (observe : DeferredContext → Nat → α → List Probe → ProbComp (Bool × List Probe)) + (boolObserve : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hproject : ∀ nextContext remaining nextValue, + Pr[PlanHitAt finalCandidates | + observe nextContext remaining nextValue currentCandidates] = + Pr[= true | boolObserve nextContext remaining nextValue]) : + Pr[PlanHitAt finalCandidates | + runDirectDetailedPrivatePlanObserve observe currentCandidates context fuel table + computation] = + Pr[= true | runDirectDetailedPlanHitObserve finalCandidates currentCandidates boolObserve + context fuel table computation] := by + unfold runDirectDetailedPrivatePlanObserve runDirectDetailedPlanHitObserve + rw [← probEvent_eq_eq_probOutput, probEvent_bind_eq_tsum, probEvent_bind_eq_tsum] + apply tsum_congr + intro result + congr 1 + cases result with + | stopped reason => + cases reason <;> + simp [finishDirectDetailedPrivatePlanObserve, finishDirectDetailedPlanHitObserve, + PlanHitAt] + | done result => + simpa [finishDirectDetailedPrivatePlanObserve, finishDirectDetailedPlanHitObserve, + probEvent_eq_eq_probOutput] using + hproject result.context result.remaining result.value + +theorem probEvent_canonicalizeDirectDetailedPlanHitObserve_le_guarded + (table : OtsSecretIndex → HashOutput) + (finalCandidates currentCandidates : List Probe) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : α) + (hconsistent : context.ValuesConsistent) + (hpublished : PublishedValues context.state) + (hcovered : PendingCoveredBy finalCandidates context) + (hcontinuation : + let canonical := canonicalizeMaterializedValues table context + ¬PrivateStructuralHit canonical → DeferredCompletable table canonical → + Pr[= true | observe canonical fuel value] ≤ + Pr[= true | guardedPreparationObserve finalCandidates canonical]) : + Pr[= true | canonicalizeDirectDetailedPlanHitObserve table finalCandidates + currentCandidates observe context fuel value] ≤ + Pr[= true | guardedPreparationObserve finalCandidates context] := by + let canonical := canonicalizeMaterializedValues table context + have hcanonicalCovered : PendingCoveredBy finalCandidates canonical := by + exact (pendingCoveredBy_canonicalize_iff table finalCandidates context).2 hcovered + have hguardedEq := evalDist_guardedPreparationObserve_canonicalize table finalCandidates + context hconsistent hpublished + unfold canonicalizeDirectDetailedPlanHitObserve + by_cases hprivate : PrivateStructuralHit canonical + · simp only [canonical, hprivate, ↓reduceIte] + by_cases heq : currentCandidates = finalCandidates + · simp only [heq, decide_true] + have htrue := evalDist_guardedPreparationObserve_eq_true_of_privateStructuralHit + finalCandidates canonical hcanonicalCovered hprivate + have hrawTrue : evalDist (guardedPreparationObserve finalCandidates context) = + evalDist (pure true : ProbComp Bool) := hguardedEq.symm.trans htrue + exact le_of_eq (OracleComp.probOutput_congr rfl hrawTrue.symm) + · simp [heq] + · simp only [canonical, hprivate, ↓reduceIte, hpublished] + by_cases hcompletable : DeferredCompletable table canonical + · change DeferredCompletable table (canonicalizeMaterializedValues table context) at hcompletable + simp only [hcompletable, ↓reduceIte] + exact (hcontinuation hprivate hcompletable).trans + (le_of_eq (OracleComp.probOutput_congr rfl hguardedEq)) + · change ¬DeferredCompletable table (canonicalizeMaterializedValues table context) at hcompletable + simp [hcompletable] + +theorem probEvent_canonicalizeDirectDetailedPlanHitObserve_eq_zero + (table : OtsSecretIndex → HashOutput) + (finalCandidates currentCandidates : List Probe) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : α) + (hne : currentCandidates ≠ finalCandidates) + (hcontinuation : + let canonical := canonicalizeMaterializedValues table context + ¬PrivateStructuralHit canonical → DeferredCompletable table canonical → + Pr[= true | observe canonical fuel value] = 0) : + Pr[= true | canonicalizeDirectDetailedPlanHitObserve table finalCandidates + currentCandidates observe context fuel value] = 0 := by + let canonical := canonicalizeMaterializedValues table context + unfold canonicalizeDirectDetailedPlanHitObserve + by_cases hprivate : PrivateStructuralHit canonical + · simp [canonical, hprivate, hne] + · change ¬PrivateStructuralHit (canonicalizeMaterializedValues table context) at hprivate + by_cases hpublished : PublishedValues context.state + · by_cases hcompletable : DeferredCompletable table canonical + · change DeferredCompletable table (canonicalizeMaterializedValues table context) at hcompletable + simp only [hprivate, hpublished, hcompletable, ↓reduceIte] + exact hcontinuation hprivate hcompletable + · change ¬DeferredCompletable table (canonicalizeMaterializedValues table context) at hcompletable + simp [hprivate, hpublished, hcompletable] + · simp [hprivate, hpublished] + +noncomputable def directDetailedBoundaryNormalizedPlanHitObserve + (finalCandidates : List Probe) + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp (Bool × List Probe)) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : ProbComp Bool := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + (DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp (Bool × List Probe)) → + List Probe → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → + SplitHashCache → ProbComp Bool) + (fun value observe candidates context fuel _table cache => + (fun output => decide (PlanHitAt finalCandidates output)) <$> + observe context fuel (value, cache) candidates) + (fun query _next recursivelyRun observe candidates context fuel table cache => + match query with + | .inl (.inl n) => + runDirectDetailedPlanHitObserve finalCandidates candidates + (canonicalizeDirectDetailedPlanHitObserve table finalCandidates candidates + (fun nextContext remaining value => + recursivelyRun value.1 observe candidates nextContext remaining table value.2)) + context fuel table ((splitUniformImpl n).run cache) + | .inl (.inr input) => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + runDirectDetailedPlanHitObserve finalCandidates nextCandidates + (canonicalizeDirectDetailedPlanHitObserve table finalCandidates nextCandidates + (fun nextContext remaining value => + recursivelyRun value.1 observe nextCandidates nextContext remaining table value.2)) + context fuel table ((probingHashQueryAfterPlan parameter input plan).run cache) + | .inr message => + runDirectDetailedPlanHitObserve finalCandidates candidates + (canonicalizeDirectDetailedPlanHitObserve table finalCandidates candidates + (fun nextContext remaining value => + recursivelyRun value.1 observe candidates nextContext remaining table value.2)) + context fuel table ((maskedSign parameter root ftsSecret message).run cache)) + computation observe candidates context fuel table cache + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_planHit_directDetailedBoundaryNormalizedPrivatePlanObserve_eq + (finalCandidates : List Probe) + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp (Bool × List Probe)) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + Pr[PlanHitAt finalCandidates | + directDetailedBoundaryNormalizedPrivatePlanObserve parameter root ftsSecret computation + observe candidates context fuel table cache] = + Pr[= true | directDetailedBoundaryNormalizedPlanHitObserve finalCandidates parameter root + ftsSecret computation observe candidates context fuel table cache] := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryNormalizedPrivatePlanObserve, OracleComp.construct_pure, + directDetailedBoundaryNormalizedPlanHitObserve, OracleComp.construct_pure, + ← probEvent_eq_eq_probOutput, probEvent_map] + exact OracleComp.probEvent_congr' (fun output _ => by simp) rfl + | query_bind query next ih => + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [directDetailedBoundaryNormalizedPrivatePlanObserve, + OracleComp.construct_query_bind, + directDetailedBoundaryNormalizedPlanHitObserve, + OracleComp.construct_query_bind] + apply probEvent_planHit_runDirectDetailedPrivatePlanObserve_eq + intro nextContext remaining nextValue + apply probEvent_planHit_canonicalizeDirectDetailedPrivatePlanObserve_eq + intro finalContext finalRemaining finalValue + exact ih finalValue.1 candidates finalContext finalRemaining finalValue.2 + | inr input => + rw [directDetailedBoundaryNormalizedPrivatePlanObserve, + OracleComp.construct_query_bind, + directDetailedBoundaryNormalizedPlanHitObserve, + OracleComp.construct_query_bind] + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + apply probEvent_planHit_runDirectDetailedPrivatePlanObserve_eq + intro nextContext remaining nextValue + apply probEvent_planHit_canonicalizeDirectDetailedPrivatePlanObserve_eq + intro finalContext finalRemaining finalValue + exact ih finalValue.1 nextCandidates finalContext finalRemaining finalValue.2 + | inr message => + rw [directDetailedBoundaryNormalizedPrivatePlanObserve, + OracleComp.construct_query_bind, + directDetailedBoundaryNormalizedPlanHitObserve, + OracleComp.construct_query_bind] + apply probEvent_planHit_runDirectDetailedPrivatePlanObserve_eq + intro nextContext remaining nextValue + apply probEvent_planHit_canonicalizeDirectDetailedPrivatePlanObserve_eq + intro finalContext finalRemaining finalValue + exact ih finalValue.1 candidates finalContext finalRemaining finalValue.2 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateHindsightOuter.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateHindsightOuter.lean new file mode 100644 index 00000000..efe719ad --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateHindsightOuter.lean @@ -0,0 +1,409 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateHindsight + +/-! +# Fixed-list outer induction + +Incompatible candidate prefixes have zero gated risk without state invariants. Compatible prefixes are dominated by guarded preparation. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +theorem probEvent_decide_planHit_eq + (finalCandidates : List Probe) (run : ProbComp (Bool × List Probe)) : + Pr[fun output => decide (PlanHitAt finalCandidates output) = true | run] = + Pr[PlanHitAt finalCandidates | run] := + OracleComp.probEvent_congr' (fun output _ => by simp) rfl + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_directDetailedBoundaryNormalizedPlanHitObserve_eq_zero_of_not_prefix + (finalCandidates : List Probe) + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp (Bool × List Probe)) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hnotPrefix : ¬candidates.IsPrefix finalCandidates) + (hterminalZero : ∀ nextContext remaining value currentCandidates, + ¬currentCandidates.IsPrefix finalCandidates → + Pr[PlanHitAt finalCandidates | + observe nextContext remaining value currentCandidates] = 0) : + Pr[= true | directDetailedBoundaryNormalizedPlanHitObserve finalCandidates parameter root + ftsSecret computation observe candidates context fuel table cache] = 0 := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryNormalizedPlanHitObserve, OracleComp.construct_pure, + ← probEvent_eq_eq_probOutput, probEvent_map] + change Pr[fun output => decide (PlanHitAt finalCandidates output) = true | + observe context fuel (value, cache) candidates] = 0 + rw [probEvent_decide_planHit_eq] + exact hterminalZero context fuel (value, cache) candidates hnotPrefix + | query_bind query next ih => + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [directDetailedBoundaryNormalizedPlanHitObserve, + OracleComp.construct_query_bind] + apply probEvent_runDirectDetailedPlanHitObserve_eq_zero finalCandidates candidates + · exact fun heq => hnotPrefix (heq ▸ by simp) + · intro result _hresult + apply probEvent_canonicalizeDirectDetailedPlanHitObserve_eq_zero table + finalCandidates candidates + · exact fun heq => hnotPrefix (heq ▸ by simp) + · dsimp only + intro _hprivate _hcompletable + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hnotPrefix + | inr input => + rw [directDetailedBoundaryNormalizedPlanHitObserve, + OracleComp.construct_query_bind] + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + have hcurrentPrefix : candidates.IsPrefix nextCandidates := by + unfold nextCandidates appendPlannedCandidate + cases rootAwarePlannedCandidate? parameter input context.state <;> simp + have hnextNotPrefix : ¬nextCandidates.IsPrefix finalCandidates := fun hnext => + hnotPrefix (hcurrentPrefix.trans hnext) + apply probEvent_runDirectDetailedPlanHitObserve_eq_zero finalCandidates + nextCandidates + · exact fun heq => hnextNotPrefix (heq ▸ by simp) + · intro result _hresult + apply probEvent_canonicalizeDirectDetailedPlanHitObserve_eq_zero table + finalCandidates nextCandidates + · exact fun heq => hnextNotPrefix (heq ▸ by simp) + · dsimp only + intro _hprivate _hcompletable + exact ih result.value.1 nextCandidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hnextNotPrefix + | inr message => + rw [directDetailedBoundaryNormalizedPlanHitObserve, + OracleComp.construct_query_bind] + apply probEvent_runDirectDetailedPlanHitObserve_eq_zero finalCandidates candidates + · exact fun heq => hnotPrefix (heq ▸ by simp) + · intro result _hresult + apply probEvent_canonicalizeDirectDetailedPlanHitObserve_eq_zero table + finalCandidates candidates + · exact fun heq => hnotPrefix (heq ▸ by simp) + · dsimp only + intro _hprivate _hcompletable + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hnotPrefix + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_directDetailedBoundaryNormalizedPlanHitObserve_le_guarded + (finalCandidates : List Probe) + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp (Bool × List Probe)) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hprefix : candidates.IsPrefix finalCandidates) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) + (hcovered : PendingCoveredBy finalCandidates context) + (hterminalLe : ∀ nextContext remaining value currentCandidates, + currentCandidates.IsPrefix finalCandidates → nextContext.ValuesConsistent → + StartTableAgrees nextContext.state table → PublishedValues nextContext.state → + PendingCoveredBy finalCandidates nextContext → + Pr[PlanHitAt finalCandidates | + observe nextContext remaining value currentCandidates] ≤ + Pr[= true | guardedPreparationObserve finalCandidates nextContext]) + (hterminalZero : ∀ nextContext remaining value currentCandidates, + ¬currentCandidates.IsPrefix finalCandidates → + Pr[PlanHitAt finalCandidates | + observe nextContext remaining value currentCandidates] = 0) : + Pr[= true | directDetailedBoundaryNormalizedPlanHitObserve finalCandidates parameter root + ftsSecret computation observe candidates context fuel table cache] ≤ + Pr[= true | guardedPreparationObserve finalCandidates context] := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryNormalizedPlanHitObserve, OracleComp.construct_pure, + ← probEvent_eq_eq_probOutput, probEvent_map] + change Pr[fun output => decide (PlanHitAt finalCandidates output) = true | + observe context fuel (value, cache) candidates] ≤ _ + rw [probEvent_decide_planHit_eq] + exact hterminalLe context fuel (value, cache) candidates hprefix hconsistent hstarts + hpublished hcovered + | query_bind query next ih => + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [directDetailedBoundaryNormalizedPlanHitObserve, + OracleComp.construct_query_bind] + let inner := (splitUniformImpl n).run cache + have hprobeBound : inner.IsQueryBoundP (IsUncoveredProbe finalCandidates) 0 := + OracleComp.IsQueryBoundP.of_imp (isUncoveredProbe_imp_isProbe finalCandidates) + (splitUniformImpl_probeFree n cache) + apply probEvent_runDirectDetailedPlanHitObserve_le_guarded finalCandidates + candidates _ context fuel table inner hcovered hprobeBound + intro result hresult + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed inner + context fuel table result hresult + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable inner context fuel table + result hconsistent hstarts hdirect + have hnextPublished := publishedValues_of_done_runDirectResolvedDetailedFromTable + (splitUniformImpl n) (preservesPublishedValuesImpl_splitUniformImpl n) + context fuel table cache result hpublished hresult + have hnextCovered := pendingCoveredBy_of_done_runDirectResolvedDetailedFromTable + finalCandidates inner context fuel table result hcovered hprobeBound hresult + apply probEvent_canonicalizeDirectDetailedPlanHitObserve_le_guarded table + finalCandidates candidates + (observe := fun nextContext remaining value => + directDetailedBoundaryNormalizedPlanHitObserve finalCandidates parameter root + ftsSecret (next value.1) observe candidates nextContext remaining table value.2) + result.context result.remaining result.value hcore.2.1 hnextPublished hnextCovered + dsimp only + intro _hprivate _hcompletable + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hprefix + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + hnextPublished.to_canonicalizedMaterializedValues + ((pendingCoveredBy_canonicalize_iff table finalCandidates result.context).2 + hnextCovered) + | inr input => + rw [directDetailedBoundaryNormalizedPlanHitObserve, + OracleComp.construct_query_bind] + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + by_cases hnextPrefix : nextCandidates.IsPrefix finalCandidates + · have hplanMem : ∀ candidate, plan.candidate? = some candidate → + candidate ∈ finalCandidates := by + intro candidate hcandidate + apply hnextPrefix.subset + have hrecorded := rootAwarePlannedCandidate?_eq_of_plan_some hcandidate + simp [nextCandidates, appendPlannedCandidate, hrecorded] + let inner := (probingHashQueryAfterPlan parameter input plan).run cache + have hprobeBound := probingHashQueryAfterPlan_probeBound parameter input plan + finalCandidates hplanMem cache + apply probEvent_runDirectDetailedPlanHitObserve_le_guarded finalCandidates + nextCandidates _ context fuel table inner hcovered hprobeBound + intro result hresult + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed inner + context fuel table result hresult + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable inner context fuel table + result hconsistent hstarts hdirect + have hnextPublished := publishedValues_of_done_runDirectResolvedDetailedFromTable + (probingHashQueryAfterPlan parameter input plan) + (preservesPublishedValues_probingHashQueryAfterPlan parameter input plan) + context fuel table cache result hpublished hresult + have hnextCovered := pendingCoveredBy_of_done_runDirectResolvedDetailedFromTable + finalCandidates inner context fuel table result hcovered hprobeBound hresult + apply probEvent_canonicalizeDirectDetailedPlanHitObserve_le_guarded table + finalCandidates nextCandidates + (observe := fun nextContext remaining value => + directDetailedBoundaryNormalizedPlanHitObserve finalCandidates parameter root + ftsSecret (next value.1) observe nextCandidates nextContext remaining table + value.2) + result.context result.remaining result.value hcore.2.1 hnextPublished hnextCovered + dsimp only + intro _hprivate _hcompletable + exact ih result.value.1 nextCandidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hnextPrefix + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + hnextPublished.to_canonicalizedMaterializedValues + ((pendingCoveredBy_canonicalize_iff table finalCandidates result.context).2 + hnextCovered) + · have hzero := + probEvent_runDirectDetailedPlanHitObserve_eq_zero finalCandidates nextCandidates + (fun nextContext remaining value => + canonicalizeDirectDetailedPlanHitObserve table finalCandidates nextCandidates + (fun finalContext finalRemaining finalValue => + directDetailedBoundaryNormalizedPlanHitObserve finalCandidates parameter + root ftsSecret (next finalValue.1) observe nextCandidates finalContext + finalRemaining table finalValue.2) + nextContext remaining value) + context fuel table ((probingHashQueryAfterPlan parameter input plan).run cache) + (fun heq => hnextPrefix (heq ▸ by simp)) (by + intro result _hresult + apply probEvent_canonicalizeDirectDetailedPlanHitObserve_eq_zero table + finalCandidates nextCandidates + · exact fun heq => hnextPrefix (heq ▸ by simp) + · dsimp only + intro _hprivate _hcompletable + exact probEvent_directDetailedBoundaryNormalizedPlanHitObserve_eq_zero_of_not_prefix + finalCandidates parameter root ftsSecret (next result.value.1) observe + nextCandidates (canonicalizeMaterializedValues table result.context) + result.remaining table result.value.2 hnextPrefix hterminalZero) + exact hzero.le.trans zero_le + | inr message => + rw [directDetailedBoundaryNormalizedPlanHitObserve, + OracleComp.construct_query_bind] + let inner := (maskedSign parameter root ftsSecret message).run cache + have hprobeBound : inner.IsQueryBoundP (IsUncoveredProbe finalCandidates) 0 := + OracleComp.IsQueryBoundP.of_imp (isUncoveredProbe_imp_isProbe finalCandidates) + (maskedSign_probeFree parameter root ftsSecret message cache) + apply probEvent_runDirectDetailedPlanHitObserve_le_guarded finalCandidates candidates _ + context fuel table inner hcovered hprobeBound + intro result hresult + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed inner context + fuel table result hresult + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable inner context fuel table + result hconsistent hstarts hdirect + have hnextPublished := publishedValues_of_done_runDirectResolvedDetailedFromTable + (maskedSign parameter root ftsSecret message) + (preservesPublishedValues_maskedSign parameter root ftsSecret message) + context fuel table cache result hpublished hresult + have hnextCovered := pendingCoveredBy_of_done_runDirectResolvedDetailedFromTable + finalCandidates inner context fuel table result hcovered hprobeBound hresult + apply probEvent_canonicalizeDirectDetailedPlanHitObserve_le_guarded table + finalCandidates candidates + (observe := fun nextContext remaining value => + directDetailedBoundaryNormalizedPlanHitObserve finalCandidates parameter root + ftsSecret (next value.1) observe candidates nextContext remaining table value.2) + result.context result.remaining result.value hcore.2.1 hnextPublished hnextCovered + dsimp only + intro _hprivate _hcompletable + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining result.value.2 + hprefix (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + hnextPublished.to_canonicalizedMaterializedValues + ((pendingCoveredBy_canonicalize_iff table finalCandidates result.context).2 + hnextCovered) + +theorem probEvent_retainedResolvedFinalizationPrivatePlanObserve_planHit_le_guarded + (table : OtsSecretIndex → HashOutput) (root : Digest) + (finalCandidates currentCandidates : List Probe) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) + (hprefix : currentCandidates.IsPrefix finalCandidates) + (hcovered : PendingCoveredBy finalCandidates context) : + Pr[PlanHitAt finalCandidates | + retainedResolvedFinalizationPrivatePlanObserve table root context fuel value + currentCandidates] ≤ + Pr[= true | guardedPreparationObserve finalCandidates context] := by + by_cases heq : currentCandidates = finalCandidates + · subst currentCandidates + by_cases hprivate : PrivateStructuralHit context + · unfold retainedResolvedFinalizationPrivatePlanObserve + retainedResolvedFinalizationPrivateObserve classifyDirectPrivateObserve + simp only [hprivate, ↓reduceIte, pure_bind, probEvent_pure, PlanHitAt, and_self, + ] + have htrue := evalDist_guardedPreparationObserve_eq_true_of_privateStructuralHit + finalCandidates context hcovered hprivate + have hrawTrue : evalDist (guardedPreparationObserve finalCandidates context) = + evalDist (pure true : ProbComp Bool) := htrue + apply le_of_eq + calc + (1 : ℝ≥0∞) = Pr[= true | (pure true : ProbComp Bool)] := by simp + _ = _ := OracleComp.probOutput_congr rfl hrawTrue.symm + · simp [retainedResolvedFinalizationPrivatePlanObserve, + retainedResolvedFinalizationPrivateObserve, classifyDirectPrivateObserve, + hprivate, PlanHitAt] + · unfold retainedResolvedFinalizationPrivatePlanObserve + retainedResolvedFinalizationPrivateObserve classifyDirectPrivateObserve + by_cases hprivate : PrivateStructuralHit context <;> + simp [hprivate, PlanHitAt, heq] + +theorem probEvent_retainedResolvedFinalizationPrivatePlanObserve_planHit_eq_zero + (table : OtsSecretIndex → HashOutput) (root : Digest) + (finalCandidates currentCandidates : List Probe) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) + (hnotPrefix : ¬currentCandidates.IsPrefix finalCandidates) : + Pr[PlanHitAt finalCandidates | + retainedResolvedFinalizationPrivatePlanObserve table root context fuel value + currentCandidates] = 0 := by + have hne : currentCandidates ≠ finalCandidates := fun heq => + hnotPrefix (heq ▸ by simp) + unfold retainedResolvedFinalizationPrivatePlanObserve + retainedResolvedFinalizationPrivateObserve classifyDirectPrivateObserve + by_cases hprivate : PrivateStructuralHit context <;> + simp [hprivate, PlanHitAt, hne] + +theorem probEvent_granularDetailedRetainedRestNormalizedPlanHitObserve_le_guarded + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (finalCandidates currentCandidates : List Probe) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) + (hprefix : currentCandidates.IsPrefix finalCandidates) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) + (hcovered : PendingCoveredBy finalCandidates context) : + Pr[= true | directDetailedBoundaryNormalizedPlanHitObserve finalCandidates parameter + value.1 ftsSecret (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivatePlanObserve table value.1) + currentCandidates context fuel table value.2] ≤ + Pr[= true | guardedPreparationObserve finalCandidates context] := by + apply probEvent_directDetailedBoundaryNormalizedPlanHitObserve_le_guarded finalCandidates + parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivatePlanObserve table value.1) + currentCandidates context fuel table value.2 hprefix hconsistent hstarts hpublished hcovered + · intro nextContext remaining nextValue nextCandidates hnextPrefix _hnextConsistent + _hnextStarts _hnextPublished hnextCovered + exact probEvent_retainedResolvedFinalizationPrivatePlanObserve_planHit_le_guarded table + value.1 finalCandidates nextCandidates nextContext remaining nextValue hnextPrefix + hnextCovered + · intro nextContext remaining nextValue nextCandidates hnextNotPrefix + exact probEvent_retainedResolvedFinalizationPrivatePlanObserve_planHit_eq_zero table value.1 + finalCandidates nextCandidates nextContext remaining nextValue hnextNotPrefix + +theorem probEvent_granularDetailedRetainedRestNormalized_planHit_le_guarded + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (finalCandidates currentCandidates : List Probe) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) + (hprefix : currentCandidates.IsPrefix finalCandidates) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) + (hcovered : PendingCoveredBy finalCandidates context) : + Pr[PlanHitAt finalCandidates | + granularDetailedRetainedRestNormalizedPrivatePlanObserve adversary parameter table + ftsSecret context fuel value currentCandidates] ≤ + Pr[= true | guardedPreparationObserve finalCandidates context] := by + unfold granularDetailedRetainedRestNormalizedPrivatePlanObserve + calc + _ = Pr[= true | directDetailedBoundaryNormalizedPlanHitObserve finalCandidates parameter + value.1 ftsSecret (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivatePlanObserve table value.1) + currentCandidates context fuel table value.2] := + probEvent_planHit_directDetailedBoundaryNormalizedPrivatePlanObserve_eq finalCandidates + parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivatePlanObserve table value.1) + currentCandidates context fuel table value.2 + _ ≤ _ := probEvent_granularDetailedRetainedRestNormalizedPlanHitObserve_le_guarded + adversary parameter table ftsSecret finalCandidates currentCandidates context fuel value + hprefix hconsistent hstarts hpublished hcovered + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem preservesPublishedValues_maskedPublishedTreeRoot : + PreservesPublishedValues maskedPublishedTreeRoot := by + unfold maskedPublishedTreeRoot + apply (preservesPublishedValues_ensureTreeNode topLayer rootTree + (layerHeight topLayer) 0).bind + intro _ + exact preservesPublishedValues_revealPublishedCoordinate + (.position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateHindsightWeighted.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateHindsightWeighted.lean new file mode 100644 index 00000000..0dbe0e07 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateHindsightWeighted.lean @@ -0,0 +1,115 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateHindsightOuter + +/-! +# Weight-preserving private hindsight + +The fixed-list hindsight theorem is useful only after retaining the probability of producing that +list. This file packages the required fiberwise interface. It deliberately does not permit an +unweighted sum of fixed-list preparation bounds. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp ENNReal + +attribute [local instance] Classical.propDecidable + +theorem probEvent_eq_tsum_classify_fibers + {α ι : Type} + (run : ProbComp α) (event : α → Prop) (classify : α → ι) : + Pr[event | run] = + ∑' index, Pr[fun output => event output ∧ classify output = index | run] := by + classical + letI : DecidablePred event := Classical.decPred event + letI : DecidableEq ι := Classical.decEq ι + rw [probEvent_eq_tsum_ite] + simp_rw [probEvent_eq_tsum_ite] + rw [ENNReal.tsum_comm] + apply tsum_congr + intro output + by_cases hevent : event output + · simp only [hevent, true_and, if_true] + rw [tsum_eq_single (classify output)] + · simp + · intro index hne + simp [Ne.symm hne] + · simp [hevent] + +theorem probEvent_le_tsum_weighted_fibers + {α ι : Type} + (run : ProbComp α) (event : α → Prop) (classify : α → ι) + (risk : ι → ℝ≥0∞) + (hfiber : ∀ index, + Pr[fun output => event output ∧ classify output = index | run] ≤ + Pr[fun output => classify output = index | run] * risk index) : + Pr[event | run] ≤ + ∑' index, Pr[fun output => classify output = index | run] * risk index := by + rw [probEvent_eq_tsum_classify_fibers run event classify] + exact ENNReal.tsum_le_tsum hfiber + +theorem probEvent_bind_risk_eq_tsum_weighted_fibers + {α ι : Type} + (run : ProbComp α) (classify : α → ι) (risk : ι → ProbComp Bool) : + Pr[= true | run >>= fun output => risk (classify output)] = + ∑' index, Pr[fun output => classify output = index | run] * + Pr[= true | risk index] := by + classical + letI : DecidableEq ι := Classical.decEq ι + rw [← probEvent_eq_eq_probOutput] + rw [probEvent_bind_eq_tsum] + have hfiber : ∀ index, + Pr[fun output => classify output = index | run] = + ∑' output, if classify output = index then Pr[= output | run] else 0 := + fun index => probEvent_eq_tsum_ite run (fun output => classify output = index) + simp_rw [hfiber, ← ENNReal.tsum_mul_right] + rw [ENNReal.tsum_comm] + apply tsum_congr + intro output + rw [tsum_eq_single (classify output)] + · simp + · intro index hne + simp [Ne.symm hne] + +theorem probEvent_le_bind_risk_of_weighted_fibers + {α ι : Type} + (run : ProbComp α) (event : α → Prop) (classify : α → ι) + (risk : ι → ProbComp Bool) + (hfiber : ∀ index, + Pr[fun output => event output ∧ classify output = index | run] ≤ + Pr[fun output => classify output = index | run] * + Pr[= true | risk index]) : + Pr[event | run] ≤ + Pr[= true | run >>= fun output => risk (classify output)] := by + rw [probEvent_eq_tsum_classify_fibers run event classify] + calc + (∑' index, + Pr[fun output => event output ∧ classify output = index | run]) ≤ + ∑' index, Pr[fun output => classify output = index | run] * + Pr[= true | risk index] := + ENNReal.tsum_le_tsum hfiber + _ = _ := (probEvent_bind_risk_eq_tsum_weighted_fibers run classify risk).symm + +theorem probEvent_privatePlan_le_of_weighted_hindsight + (run : ProbComp (Bool × List Probe)) (q : Nat) + (hfiber : ∀ candidates, + Pr[PlanHitAt candidates | run] ≤ + Pr[fun output => output.2 = candidates | run] * + Pr[= true | plannedCandidateListFire candidates]) + (hlength : ∀ result ∈ support run, result.2.length ≤ q) : + Pr[fun result => result.1 = true | run] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply probEvent_privatePlan_le_of_candidate_game run q + · have hweighted := probEvent_le_bind_risk_of_weighted_fibers run + (fun result => result.1 = true) Prod.snd plannedCandidateListFire (by + intro candidates + change Pr[PlanHitAt candidates | run] ≤ _ + exact hfiber candidates) + have hcomp : + (Prod.snd <$> run) >>= plannedCandidateListFire = + run >>= fun output => plannedCandidateListFire output.2 := by + simp [map_eq_bind_pure_comp, bind_assoc] + rw [hcomp] + exact hweighted + · exact hlength + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePlan.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePlan.lean new file mode 100644 index 00000000..ac09658e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePlan.lean @@ -0,0 +1,312 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateSafe + +/-! +# Private-boundary probe planning + +The probing hash handler is factored into a probe-free planner, at most one probe, and a probe-free suffix. The planner depends only on public input and materialization presence, never on a deferred private value. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +inductive PlannedHashAction where + | ordinary + | resolve (coordinate : Coordinate) + +structure PlannedHashQuery where + candidate? : Option Probe + action : PlannedHashAction + +noncomputable def firstMissingInputCoordinatePlan (state : LazyRevealProbe.State Coordinate) + (input : HashInput) : Nat → List Coordinate → Option Probe + | _, [] => none + | slot, coordinate :: remaining => + match state.values coordinate with + | none => some ⟨coordinate, slotDigest slot input⟩ + | some _ => firstMissingInputCoordinatePlan state input (slot + 1) remaining + +noncomputable def leafInputProbePlan (state : LazyRevealProbe.State Coordinate) + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : Option Probe := + match state.values candidate.coordinate with + | none => some candidate + | some _ => + firstMissingInputCoordinatePlan state input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + +theorem firstMissingInputCoordinatePlan_some_value_none + (state : LazyRevealProbe.State Coordinate) (input : HashInput) : + ∀ slot coordinates candidate, + firstMissingInputCoordinatePlan state input slot coordinates = some candidate → + state.values candidate.coordinate = none := by + intro slot coordinates + induction coordinates generalizing slot with + | nil => simp [firstMissingInputCoordinatePlan] + | cons coordinate remaining ih => + intro candidate hplan + rw [firstMissingInputCoordinatePlan] at hplan + cases hvalue : state.values coordinate with + | none => + simp only [hvalue] at hplan + have hcand : candidate = ⟨coordinate, slotDigest slot input⟩ := + Option.some.inj hplan.symm + subst candidate + exact hvalue + | some output => + simp only [hvalue] at hplan + exact ih (slot + 1) candidate hplan + +theorem leafInputProbePlan_some_value_none + (state : LazyRevealProbe.State Coordinate) + (input : HashInput) (candidate planned : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (hplan : leafInputProbePlan state input candidate lay tree leafIdx = some planned) : + state.values planned.coordinate = none := by + unfold leafInputProbePlan at hplan + cases hvalue : state.values candidate.coordinate with + | none => + simp only [hvalue] at hplan + have heq : planned = candidate := Option.some.inj hplan.symm + subst planned + exact hvalue + | some output => + simp only [hvalue] at hplan + exact firstMissingInputCoordinatePlan_some_value_none state input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) planned hplan + +noncomputable def planFirstMissingInputCoordinate (input : HashInput) : + Nat → List Coordinate → + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Probe) + | _, [] => pure none + | slot, coordinate :: remaining => do + match ← peekCoordinate coordinate with + | none => pure (some ⟨coordinate, slotDigest slot input⟩) + | some _ => planFirstMissingInputCoordinate input (slot + 1) remaining + +noncomputable def planLeafInputProbe (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Probe) := do + match ← peekCoordinate candidate.coordinate with + | none => pure (some candidate) + | some _ => + planFirstMissingInputCoordinate input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + +noncomputable def planProbingHashQuery (parameter : PublicParameter) (input : HashInput) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) PlannedHashQuery := + match decodeProbe? parameter input with + | some candidate => + match decodePosition? parameter input with + | some (.leaf lay tree leafIdx) => do + let candidate? ← planLeafInputProbe input candidate lay tree leafIdx + pure ⟨candidate?, .resolve candidate.outputCoordinate⟩ + | _ => pure ⟨some candidate, .resolve candidate.outputCoordinate⟩ + | none => + match decodePosition? parameter input with + | some position@(.chain _ _ _ _ _) => pure ⟨none, .resolve (.position position)⟩ + | some position@(.leaf _ _ _) => pure ⟨none, .resolve (.position position)⟩ + | some position@(.node _ _ _ _) => do + let candidate? ← planFirstMissingInputCoordinate input 0 + (position.children.map Coordinate.position) + pure ⟨candidate?, .resolve (.position position)⟩ + | _ => pure ⟨none, .ordinary⟩ + +@[simp] noncomputable def executeCandidate? : Option Probe → + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit + | none => pure () + | some candidate => probe candidate + +noncomputable def executePlannedHashQuery + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput := do + executeCandidate? plan.candidate? + match plan.action with + | .ordinary => splitHashQuery (.ordinary input) + | .resolve coordinate => resolveKnownInput parameter coordinate input + +theorem planFirstMissingInputCoordinate_execute + (input : HashInput) : ∀ slot coordinates, + (do + let candidate? ← planFirstMissingInputCoordinate input slot coordinates + executeCandidate? candidate?) = + probeFirstMissingInputCoordinate input slot coordinates := by + intro slot coordinates + induction coordinates generalizing slot with + | nil => simp [planFirstMissingInputCoordinate, probeFirstMissingInputCoordinate] + | cons coordinate remaining ih => + simp only [planFirstMissingInputCoordinate, probeFirstMissingInputCoordinate, bind_assoc] + apply bind_congr + intro value + cases value with + | none => simp + | some output => simpa using ih (slot + 1) + +theorem planLeafInputProbe_execute + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + (do + let candidate? ← planLeafInputProbe input candidate lay tree leafIdx + executeCandidate? candidate?) = + prepareLeafInputProbe input candidate lay tree leafIdx := by + unfold planLeafInputProbe prepareLeafInputProbe + simp only [bind_assoc] + apply bind_congr + intro value + cases value with + | none => simp + | some output => + simpa using planFirstMissingInputCoordinate_execute input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + +set_option maxRecDepth 100000 in +theorem probingHashQuery_eq_planned_leaf + (parameter : PublicParameter) (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (hprobe : decodeProbe? parameter input = some candidate) + (hposition : decodePosition? parameter input = some (.leaf lay tree leafIdx)) : + probingHashQuery parameter input = (do + let planned ← planLeafInputProbe input candidate lay tree leafIdx + executeCandidate? planned + resolveKnownInput parameter candidate.outputCoordinate input) := by + unfold probingHashQuery + rw [hprobe, hposition] + rw [← bind_assoc, planLeafInputProbe_execute] + +set_option maxRecDepth 100000 in +theorem probingHashQuery_eq_planned_node + (parameter : PublicParameter) (input : HashInput) + (lay : Layer) (tree : TreeIndex) (level : Fin maxLayerHeight) + (nodeIdx : LeafIndex) + (hprobe : decodeProbe? parameter input = none) + (hposition : decodePosition? parameter input = some (.node lay tree level nodeIdx)) : + probingHashQuery parameter input = (do + let planned ← planFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position) + executeCandidate? planned + resolveKnownInput parameter (.position (.node lay tree level nodeIdx)) input) := by + unfold probingHashQuery + rw [hprobe, hposition] + rw [← bind_assoc, planFirstMissingInputCoordinate_execute] + +theorem planFirstMissingInputCoordinate_probeFree + (input : HashInput) (slot : Nat) (coordinates : List Coordinate) : + ProbeFree (planFirstMissingInputCoordinate input slot coordinates) := by + induction coordinates generalizing slot with + | nil => exact ProbeFree.pure none + | cons coordinate remaining ih => + rw [planFirstMissingInputCoordinate] + apply (peekCoordinate_probeFree coordinate).bind + intro value + cases value with + | none => + simpa using (ProbeFree.pure + (some (⟨coordinate, slotDigest slot input⟩ : Probe) : Option Probe)) + | some output => simpa using ih (slot + 1) + +theorem planLeafInputProbe_probeFree + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ProbeFree (planLeafInputProbe input candidate lay tree leafIdx) := by + unfold planLeafInputProbe + apply (peekCoordinate_probeFree candidate.coordinate).bind + intro value + cases value with + | none => simpa using (ProbeFree.pure (some candidate : Option Probe)) + | some output => + simpa using planFirstMissingInputCoordinate_probeFree input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + +theorem planProbingHashQuery_probeFree + (parameter : PublicParameter) (input : HashInput) : + ProbeFree (planProbingHashQuery parameter input) := by + unfold planProbingHashQuery + cases decodeProbe? parameter input with + | some candidate => + cases hposition : decodePosition? parameter input with + | none => exact ProbeFree.pure _ + | some position => + cases position with + | leaf lay tree leafIdx => + exact (planLeafInputProbe_probeFree input candidate lay tree leafIdx).bind + fun candidate? => ProbeFree.pure + (⟨candidate?, .resolve candidate.outputCoordinate⟩ : PlannedHashQuery) + | chain | node | ftsLeaf | ftsNode | ftsRoots => exact ProbeFree.pure _ + | none => + cases hposition : decodePosition? parameter input with + | none => exact ProbeFree.pure _ + | some position => + cases position with + | node lay tree level nodeIdx => + exact (planFirstMissingInputCoordinate_probeFree input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)).bind + fun candidate? => ProbeFree.pure + (⟨candidate?, .resolve (.position + (.node lay tree level nodeIdx))⟩ : PlannedHashQuery) + | chain | leaf | ftsLeaf | ftsNode | ftsRoots => exact ProbeFree.pure _ + +theorem runDirectResolvedDetailed_planFirstMissingInputCoordinate + (state : LazyRevealProbe.State Coordinate) (input : HashInput) : + ∀ slot coordinates context fuel table cache, + context.state = state → + runDirectResolvedDetailedFromTable context fuel table + ((planFirstMissingInputCoordinate input slot coordinates).run cache) = + pure (.done ⟨context, fuel, + (firstMissingInputCoordinatePlan state input slot coordinates, cache), table⟩) := by + intro slot coordinates + induction coordinates generalizing slot with + | nil => + intro context fuel table cache hstate + simp [planFirstMissingInputCoordinate, firstMissingInputCoordinatePlan, + runDirectResolvedDetailedFromTable_pure] + | cons coordinate remaining ih => + intro context fuel table cache hstate + rw [planFirstMissingInputCoordinate, StateT.run_bind, + runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekCoordinate] + simp only [pure_bind] + rw [hstate] + cases hvalue : state.values coordinate with + | none => + simp [hvalue, firstMissingInputCoordinatePlan, + runDirectResolvedDetailedFromTable_pure] + | some output => + change runDirectResolvedDetailedFromTable context fuel table + ((planFirstMissingInputCoordinate input (slot + 1) remaining).run cache) = _ + rw [ih (slot + 1) context fuel table cache hstate] + simp [firstMissingInputCoordinatePlan, hvalue] + +theorem runDirectResolvedDetailed_planLeafInputProbe + (state : LazyRevealProbe.State Coordinate) + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hstate : context.state = state) : + runDirectResolvedDetailedFromTable context fuel table + ((planLeafInputProbe input candidate lay tree leafIdx).run cache) = + pure (.done ⟨context, fuel, + (leafInputProbePlan state input candidate lay tree leafIdx, cache), table⟩) := by + rw [planLeafInputProbe, StateT.run_bind, + runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekCoordinate] + simp only [pure_bind] + rw [hstate] + cases hvalue : state.values candidate.coordinate with + | none => + simp [hvalue, leafInputProbePlan, runDirectResolvedDetailedFromTable_pure] + | some output => + change runDirectResolvedDetailedFromTable context fuel table + ((planFirstMissingInputCoordinate input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position)).run cache) = _ + rw [runDirectResolvedDetailed_planFirstMissingInputCoordinate state input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + context fuel table cache hstate] + simp [leafInputProbePlan, hvalue] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePlanExecution.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePlanExecution.lean new file mode 100644 index 00000000..0a773cc8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePlanExecution.lean @@ -0,0 +1,241 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePreparationInterpreter + +/-! +# Single-execution planned hash handler + +The concrete probing hash handler is factored into its state-neutral planner, execution of the one recorded candidate, and a probe-free suffix. This avoids executing the finite scan twice in the plan-traced game. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +theorem isUncoveredProbe_imp_isProbe (candidates : List Probe) + (query : (LazyRevealProbe.World Coordinate).Domain) : + IsUncoveredProbe candidates query → LazyRevealProbe.IsProbe query := by + cases query <;> simp [IsUncoveredProbe, LazyRevealProbe.IsProbe] + +noncomputable def purePlanProbingHashQuery (parameter : PublicParameter) + (input : HashInput) (state : LazyRevealProbe.State Coordinate) : PlannedHashQuery := + match decodeProbe? parameter input with + | some candidate => + match decodePosition? parameter input with + | some (.leaf lay tree leafIdx) => + ⟨leafInputProbePlan state input candidate lay tree leafIdx, + .resolve candidate.outputCoordinate⟩ + | _ => ⟨some candidate, .resolve candidate.outputCoordinate⟩ + | none => + match decodePosition? parameter input with + | some position@(.chain _ _ _ _ _) => ⟨none, .resolve (.position position)⟩ + | some position@(.leaf _ _ _) => ⟨none, .resolve (.position position)⟩ + | some position@(.node _ _ _ _) => + ⟨firstMissingInputCoordinatePlan state input 0 + (position.children.map Coordinate.position), + .resolve (.position position)⟩ + | _ => ⟨none, .ordinary⟩ + +set_option maxRecDepth 100000 in +theorem runDirectResolvedDetailed_planProbingHashQuery + (parameter : PublicParameter) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hstate : context.state = state) : + runDirectResolvedDetailedFromTable context fuel table + ((planProbingHashQuery parameter input).run cache) = + pure (.done ⟨context, fuel, + (purePlanProbingHashQuery parameter input state, cache), table⟩) := by + unfold planProbingHashQuery purePlanProbingHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases hposition : decodePosition? parameter input with + | none => simp [runDirectResolvedDetailedFromTable_pure] + | some position => + cases position with + | leaf lay tree leafIdx => + rw [StateT.run_bind, + runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailed_planLeafInputProbe state input candidate lay tree + leafIdx context fuel table cache hstate] + simp [runDirectResolvedDetailedFromTable_pure] + | chain | node | ftsLeaf | ftsNode | ftsRoots => + simp [runDirectResolvedDetailedFromTable_pure] + | none => + cases hposition : decodePosition? parameter input with + | none => simp [runDirectResolvedDetailedFromTable_pure] + | some position => + cases position with + | node lay tree level nodeIdx => + rw [StateT.run_bind, + runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailed_planFirstMissingInputCoordinate state input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position) + context fuel table cache hstate] + simp [runDirectResolvedDetailedFromTable_pure] + | chain | leaf | ftsLeaf | ftsNode | ftsRoots => + simp [runDirectResolvedDetailedFromTable_pure] + +noncomputable def probingHashQueryAfterPlan + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput := + executePlannedHashQuery parameter input plan + +set_option maxRecDepth 100000 in +theorem probingHashQuery_eq_plan_then_afterPlan_leaf + (parameter : PublicParameter) (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (hprobe : decodeProbe? parameter input = some candidate) + (hposition : decodePosition? parameter input = some (.leaf lay tree leafIdx)) : + probingHashQuery parameter input = (do + let plan ← planProbingHashQuery parameter input + probingHashQueryAfterPlan parameter input plan) := by + rw [probingHashQuery_eq_planned_leaf parameter input candidate lay tree leafIdx hprobe + hposition] + unfold planProbingHashQuery probingHashQueryAfterPlan executePlannedHashQuery + rw [hprobe, hposition] + simp + +set_option maxRecDepth 100000 in +theorem probingHashQuery_eq_plan_then_afterPlan_node + (parameter : PublicParameter) (input : HashInput) + (lay : Layer) (tree : TreeIndex) (level : Fin maxLayerHeight) + (nodeIdx : LeafIndex) + (hprobe : decodeProbe? parameter input = none) + (hposition : decodePosition? parameter input = some (.node lay tree level nodeIdx)) : + probingHashQuery parameter input = (do + let plan ← planProbingHashQuery parameter input + probingHashQueryAfterPlan parameter input plan) := by + rw [probingHashQuery_eq_planned_node parameter input lay tree level nodeIdx hprobe hposition] + unfold planProbingHashQuery probingHashQueryAfterPlan executePlannedHashQuery + rw [hprobe, hposition] + simp + +set_option maxRecDepth 100000 in +theorem probingHashQuery_eq_plan_then_afterPlan_of_probe_some_nonleaf + (parameter : PublicParameter) (input : HashInput) (candidate : Probe) + (hprobe : decodeProbe? parameter input = some candidate) + (hposition : ¬∃ lay tree leafIdx, + decodePosition? parameter input = some (.leaf lay tree leafIdx)) : + probingHashQuery parameter input = (do + let plan ← planProbingHashQuery parameter input + probingHashQueryAfterPlan parameter input plan) := by + unfold probingHashQuery planProbingHashQuery probingHashQueryAfterPlan executePlannedHashQuery + rw [hprobe] + cases hdecoded : decodePosition? parameter input with + | none => simp + | some position => + cases position with + | leaf lay tree leafIdx => exact False.elim (hposition ⟨lay, tree, leafIdx, hdecoded⟩) + | chain | node | ftsLeaf | ftsNode | ftsRoots => simp + +set_option maxRecDepth 100000 in +theorem probingHashQuery_eq_plan_then_afterPlan_of_probe_none_nonnode + (parameter : PublicParameter) (input : HashInput) + (hprobe : decodeProbe? parameter input = none) + (hposition : ¬∃ lay tree level nodeIdx, + decodePosition? parameter input = some (.node lay tree level nodeIdx)) : + probingHashQuery parameter input = (do + let plan ← planProbingHashQuery parameter input + probingHashQueryAfterPlan parameter input plan) := by + unfold probingHashQuery planProbingHashQuery probingHashQueryAfterPlan executePlannedHashQuery + rw [hprobe] + cases hdecoded : decodePosition? parameter input with + | none => simp + | some position => + cases position with + | node lay tree level nodeIdx => + exact False.elim (hposition ⟨lay, tree, level, nodeIdx, hdecoded⟩) + | chain | leaf | ftsLeaf | ftsNode | ftsRoots => simp + +theorem probingHashQueryAfterPlan_probeBound + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (candidates : List Probe) (hplanned : ∀ candidate, plan.candidate? = some candidate → + candidate ∈ candidates) (cache : SplitHashCache) : + ((probingHashQueryAfterPlan parameter input plan).run cache).IsQueryBoundP + (IsUncoveredProbe candidates) 0 := by + unfold probingHashQueryAfterPlan executePlannedHashQuery + rw [StateT.run_bind] + apply OracleComp.isQueryBoundP_bind (n := 0) (m := 0) + · cases hopt : plan.candidate? with + | none => simp [executeCandidate?] + | some candidate => + have hmem := hplanned candidate hopt + change (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate).IsQueryBoundP + (IsUncoveredProbe candidates) 0 + unfold LazyRevealProbe.probeQuery + rw [OracleComp.isQueryBoundP_query_iff] + simp [IsUncoveredProbe, hmem] + · intro result _hresult + cases plan.action with + | ordinary => + exact OracleComp.IsQueryBoundP.of_imp + (isUncoveredProbe_imp_isProbe candidates) + (splitHashQuery_probeFree (.ordinary input) result.2) + | resolve coordinate => + exact OracleComp.IsQueryBoundP.of_imp + (isUncoveredProbe_imp_isProbe candidates) + (resolveKnownInput_probeFree parameter coordinate input result.2) + +set_option maxRecDepth 100000 in +theorem evalDist_runDirectDetailedPrivateObserve_probingHashQuery_eq_afterPlan + (parameter : PublicParameter) (input : HashInput) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (observe : DeferredContext → Nat → (HashOutput × SplitHashCache) → ProbComp Bool) + (hfactor : probingHashQuery parameter input = (do + let plan ← planProbingHashQuery parameter input + probingHashQueryAfterPlan parameter input plan)) : + evalDist (runDirectDetailedPrivateObserve observe context fuel table + ((probingHashQuery parameter input).run cache)) = + evalDist (runDirectDetailedPrivateObserve observe context fuel table + ((probingHashQueryAfterPlan parameter input + (purePlanProbingHashQuery parameter input context.state)).run cache)) := by + rw [hfactor] + unfold runDirectDetailedPrivateObserve + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind] + rw [runDirectResolvedDetailed_planProbingHashQuery parameter input context.state context fuel + table cache rfl] + simp only [pure_bind] + +theorem preservesPublishedValues_probe (candidate : Probe) : + PreservesPublishedValues (probe candidate) := by + intro state cache fuel finalState remaining value finalCache hpublished hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate >>= fun result => + pure (result, cache))) at hresult + rw [LazyRevealProbe.probeQuery, LazyRevealProbe.runRaw_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remainingFuel => + by_cases hrevealed : candidate.coordinate ∈ state.revealed + · simp [hrevealed, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hpublished + · simp [hrevealed, LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + simpa [PublishedValues, LazyRevealProbe.State.addPending] using hpublished + +theorem preservesPublishedValues_executeCandidate (planned : Option Probe) : + PreservesPublishedValues (executeCandidate? planned) := by + cases planned with + | none => exact PreservesPublishedValues.pure () + | some candidate => exact preservesPublishedValues_probe candidate + +theorem preservesPublishedValues_splitHashQuery_ordinary (input : HashInput) : + PreservesPublishedValues (splitHashQuery (.ordinary input)) := by + have h := preservesPublishedValues_simulateQ_ordinaryHashImpl + (liftM (HashSpec.query input) : OracleComp HashSpec HashOutput) + simpa [simulateQ_query, ordinaryHashImpl] using h + +theorem preservesPublishedValues_probingHashQueryAfterPlan + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) : + PreservesPublishedValues (probingHashQueryAfterPlan parameter input plan) := by + unfold probingHashQueryAfterPlan executePlannedHashQuery + apply (preservesPublishedValues_executeCandidate plan.candidate?).bind + intro _ + cases plan.action with + | ordinary => exact preservesPublishedValues_splitHashQuery_ordinary input + | resolve coordinate => exact preservesPublishedValues_resolveKnownInput parameter coordinate input + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePlanNormalized.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePlanNormalized.lean new file mode 100644 index 00000000..e647fc3f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePlanNormalized.lean @@ -0,0 +1,253 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateRootCandidate + +/-! +# Normalized outer plan trace + +The outer private trace computes each hash plan once, records its candidate, and executes the corresponding single-probe suffix. Uniform and signing queries record no candidate. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +noncomputable def directDetailedBoundaryNormalizedPrivatePlanObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp (Bool × List Probe)) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Bool × List Probe) := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + (DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp (Bool × List Probe)) → + List Probe → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → + SplitHashCache → ProbComp (Bool × List Probe)) + (fun value observe candidates context fuel _table cache => + observe context fuel (value, cache) candidates) + (fun query _next recursivelyRun observe candidates context fuel table cache => + match query with + | .inl (.inl n) => + runDirectDetailedPrivatePlanObserve + (canonicalizeDirectDetailedPrivatePlanObserve table + (fun nextContext remaining value nextCandidates => + recursivelyRun value.1 observe nextCandidates nextContext remaining table + value.2)) + candidates context fuel table ((splitUniformImpl n).run cache) + | .inl (.inr input) => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + runDirectDetailedPrivatePlanObserve + (canonicalizeDirectDetailedPrivatePlanObserve table + (fun nextContext remaining value finalCandidates => + recursivelyRun value.1 observe finalCandidates nextContext remaining table + value.2)) + nextCandidates context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) + | .inr message => + runDirectDetailedPrivatePlanObserve + (canonicalizeDirectDetailedPrivatePlanObserve table + (fun nextContext remaining value nextCandidates => + recursivelyRun value.1 observe nextCandidates nextContext remaining table + value.2)) + candidates context fuel table + ((maskedSign parameter root ftsSecret message).run cache)) + computation observe candidates context fuel table cache + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_fst_directDetailedBoundaryNormalizedPrivatePlanObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp (Bool × List Probe)) + (boolObserve : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hproject : ∀ nextContext remaining value nextCandidates, + evalDist (Prod.fst <$> observe nextContext remaining value nextCandidates) = + evalDist (boolObserve nextContext remaining value)) : + evalDist (Prod.fst <$> + directDetailedBoundaryNormalizedPrivatePlanObserve parameter root ftsSecret computation + observe candidates context fuel table cache) = + evalDist (directDetailedBoundaryPrivateObserve + (maskedExpandedAdversaryImpl parameter root ftsSecret) computation boolObserve + context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryNormalizedPrivatePlanObserve, OracleComp.construct_pure, + directDetailedBoundaryPrivateObserve, OracleComp.construct_pure] + exact hproject context fuel (value, cache) candidates + | query_bind query next ih => + rw [directDetailedBoundaryNormalizedPrivatePlanObserve, OracleComp.construct_query_bind, + directDetailedBoundaryPrivateObserve, OracleComp.construct_query_bind] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + change evalDist (Prod.fst <$> runDirectDetailedPrivatePlanObserve _ candidates + context fuel table ((splitUniformImpl n).run cache)) = + evalDist (runDirectDetailedPrivateObserve _ context fuel table + ((splitUniformImpl n).run cache)) + apply evalDist_fst_runDirectDetailedPrivatePlanObserve + intro nextContext remaining value nextCandidates + apply evalDist_fst_canonicalizeDirectDetailedPrivatePlanObserve + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + change evalDist (Prod.fst <$> runDirectDetailedPrivatePlanObserve _ nextCandidates + context fuel table ((probingHashQueryAfterPlan parameter input plan).run cache)) = + evalDist (runDirectDetailedPrivateObserve _ context fuel table + ((probingHashQuery parameter input).run cache)) + calc + _ = evalDist (runDirectDetailedPrivateObserve + (canonicalizeDirectDetailedPrivateObserve table + (fun nextContext remaining value => + directDetailedBoundaryPrivateObserve + (maskedExpandedAdversaryImpl parameter root ftsSecret) + (next value.1) boolObserve nextContext remaining table value.2)) + context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache)) := by + apply evalDist_fst_runDirectDetailedPrivatePlanObserve + intro nextContext remaining value finalCandidates + apply evalDist_fst_canonicalizeDirectDetailedPrivatePlanObserve + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + _ = _ := by + symm + apply evalDist_runDirectDetailedPrivateObserve_probingHashQuery_eq_afterPlan + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases hposition : decodePosition? parameter input with + | none => + exact probingHashQuery_eq_plan_then_afterPlan_of_probe_some_nonleaf + parameter input candidate hprobe (by + rintro ⟨lay, tree, leafIdx, heq⟩ + simp [hposition] at heq) + | some position => + cases position with + | leaf lay tree leafIdx => + exact probingHashQuery_eq_plan_then_afterPlan_leaf parameter input + candidate lay tree leafIdx hprobe hposition + | chain | node | ftsLeaf | ftsNode | ftsRoots => + exact probingHashQuery_eq_plan_then_afterPlan_of_probe_some_nonleaf + parameter input candidate hprobe (by + rintro ⟨lay, tree, leafIdx, heq⟩ + simp [hposition] at heq) + | none => + cases hposition : decodePosition? parameter input with + | none => + exact probingHashQuery_eq_plan_then_afterPlan_of_probe_none_nonnode + parameter input hprobe (by + rintro ⟨lay, tree, level, nodeIdx, heq⟩ + simp [hposition] at heq) + | some position => + cases position with + | node lay tree level nodeIdx => + exact probingHashQuery_eq_plan_then_afterPlan_node parameter input + lay tree level nodeIdx hprobe hposition + | chain | leaf | ftsLeaf | ftsNode | ftsRoots => + exact probingHashQuery_eq_plan_then_afterPlan_of_probe_none_nonnode + parameter input hprobe (by + rintro ⟨lay, tree, level, nodeIdx, heq⟩ + simp [hposition] at heq) + | inr message => + change evalDist (Prod.fst <$> runDirectDetailedPrivatePlanObserve _ candidates + context fuel table ((maskedSign parameter root ftsSecret message).run cache)) = + evalDist (runDirectDetailedPrivateObserve _ context fuel table + ((maskedSign parameter root ftsSecret message).run cache)) + apply evalDist_fst_runDirectDetailedPrivatePlanObserve + intro nextContext remaining value nextCandidates + apply evalDist_fst_canonicalizeDirectDetailedPrivatePlanObserve + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + +noncomputable def granularDetailedRetainedRestNormalizedPrivatePlanObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) : + ProbComp (Bool × List Probe) := + directDetailedBoundaryNormalizedPrivatePlanObserve parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivatePlanObserve table value.1) + candidates context fuel table value.2 + +theorem evalDist_fst_granularDetailedRetainedRestNormalizedPrivatePlanObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) : + evalDist (Prod.fst <$> granularDetailedRetainedRestNormalizedPrivatePlanObserve + adversary parameter table ftsSecret context fuel value candidates) = + evalDist (granularDetailedRetainedRestPrivateObserve adversary parameter table ftsSecret + context fuel value) := by + unfold granularDetailedRetainedRestNormalizedPrivatePlanObserve + granularDetailedRetainedRestPrivateObserve + apply evalDist_fst_directDetailedBoundaryNormalizedPrivatePlanObserve + intro nextContext remaining nextValue nextCandidates + exact evalDist_fst_retainedResolvedFinalizationPrivatePlanObserve table value.1 nextContext + remaining nextValue nextCandidates + +noncomputable def granularAllDirectBoundaryNormalizedPrivatePlan + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp (Bool × List Probe) := + runDirectDetailedPrivatePlanObserve + (granularDetailedRetainedRestNormalizedPrivatePlanObserve adversary parameter table ftsSecret) + [] + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +theorem evalDist_fst_granularAllDirectBoundaryNormalizedPrivatePlan + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (Prod.fst <$> granularAllDirectBoundaryNormalizedPrivatePlan + adversary parameter table ftsSecret fuel) = + evalDist (granularAllDirectBoundaryDetailedRetainedPrivate adversary parameter table + ftsSecret fuel) := by + unfold granularAllDirectBoundaryNormalizedPrivatePlan + granularAllDirectBoundaryDetailedRetainedPrivate + apply evalDist_fst_runDirectDetailedPrivatePlanObserve + intro nextContext remaining value nextCandidates + exact evalDist_fst_granularDetailedRetainedRestNormalizedPrivatePlanObserve adversary parameter + table ftsSecret nextContext remaining value nextCandidates + +noncomputable def sampledGranularAllDirectBoundaryNormalizedPrivatePlan + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp (Bool × List Probe) := do + let table ← sampleOtsHashTable + granularAllDirectBoundaryNormalizedPrivatePlan adversary parameter table ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem evalDist_fst_sampledGranularAllDirectBoundaryNormalizedPrivatePlan + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (Prod.fst <$> sampledGranularAllDirectBoundaryNormalizedPrivatePlan + adversary parameter ftsSecret fuel) = + evalDist (sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret fuel) := by + unfold sampledGranularAllDirectBoundaryNormalizedPrivatePlan + sampledGranularAllDirectBoundaryDetailedRetainedPrivate + rw [map_bind] + apply evalDist_bind_congr + intro table _htable + exact evalDist_fst_granularAllDirectBoundaryNormalizedPrivatePlan adversary parameter table + ftsSecret fuel + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePlanNormalizedCount.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePlanNormalizedCount.lean new file mode 100644 index 00000000..b8084439 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePlanNormalizedCount.lean @@ -0,0 +1,337 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePlanNormalized +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveClean +import SphincsSecurity.Proof.DirectQueryBudget + +/-! +# Normalized plan count + +The normalized trace appends one optional candidate exactly at an outer hash query, so its supported final lists are bounded by the source computation's `IsOuterHash` budget. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem support_directDetailedBoundaryNormalizedPrivatePlanObserve_length_le + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp (Bool × List Probe)) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) (q : Nat) + (hbound : computation.IsQueryBoundP IsOuterHash q) + (hobserve : ∀ nextContext remaining value nextCandidates output, + output ∈ support (observe nextContext remaining value nextCandidates) → + output.2.length ≤ nextCandidates.length) + (output : Bool × List Probe) + (houtput : output ∈ support + (directDetailedBoundaryNormalizedPrivatePlanObserve parameter root ftsSecret computation + observe candidates context fuel table cache)) : + output.2.length ≤ candidates.length + q := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache q output with + | pure value => + simp only [directDetailedBoundaryNormalizedPrivatePlanObserve, + OracleComp.construct_pure] at houtput + exact (hobserve context fuel (value, cache) candidates output houtput).trans + (Nat.le_add_right candidates.length q) + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [directDetailedBoundaryNormalizedPrivatePlanObserve, + OracleComp.construct_query_bind] at houtput + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + have htail : output.2.length ≤ candidates.length + q := by + apply support_runDirectDetailedPrivatePlanObserve_length_le + (canonicalizeDirectDetailedPrivatePlanObserve table + (fun nextContext remaining value nextCandidates => + directDetailedBoundaryNormalizedPrivatePlanObserve parameter root ftsSecret + (next value.1) observe nextCandidates nextContext remaining table value.2)) + candidates context fuel table ((splitUniformImpl n).run cache) q + · intro nextContext remaining value nextCandidates nextOutput hnextOutput + exact support_canonicalizeDirectDetailedPrivatePlanObserve_length_le table _ + nextContext remaining value nextCandidates q + (by + intro finalContext finalRemaining + (finalValue : Fin (n + 1) × SplitHashCache) + finalCandidates finalOutput hfinalOutput + exact ih finalValue.1 finalCandidates finalContext finalRemaining + finalValue.2 (q := q) + (by simpa [IsOuterHash] using hbound.2 finalValue.1) + (output := finalOutput) hfinalOutput) + nextOutput hnextOutput + · exact houtput + exact htail + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + have hpositive : 0 < q := by + rcases hbound.1 with hnot | hpositive + · exact (hnot (by simp [IsOuterHash])).elim + · exact hpositive + have htail : output.2.length ≤ nextCandidates.length + (q - 1) := by + apply support_runDirectDetailedPrivatePlanObserve_length_le + (canonicalizeDirectDetailedPrivatePlanObserve table + (fun nextContext remaining value finalCandidates => + directDetailedBoundaryNormalizedPrivatePlanObserve parameter root ftsSecret + (next value.1) observe finalCandidates nextContext remaining table value.2)) + nextCandidates context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) (q - 1) + · intro nextContext remaining value finalCandidates nextOutput hnextOutput + exact support_canonicalizeDirectDetailedPrivatePlanObserve_length_le table _ + nextContext remaining value finalCandidates (q - 1) + (by + intro finalContext finalRemaining + (finalValue : HashOutput × SplitHashCache) + laterCandidates finalOutput hfinalOutput + exact ih finalValue.1 laterCandidates finalContext finalRemaining + finalValue.2 (q := q - 1) + (by simpa [IsOuterHash] using hbound.2 finalValue.1) + (output := finalOutput) hfinalOutput) + nextOutput hnextOutput + · exact houtput + have hnextLength : nextCandidates.length ≤ candidates.length + 1 := + appendPlannedCandidate_length_le candidates + (rootAwarePlannedCandidate? parameter input context.state) + omega + | inr message => + have htail : output.2.length ≤ candidates.length + q := by + apply support_runDirectDetailedPrivatePlanObserve_length_le + (canonicalizeDirectDetailedPrivatePlanObserve table + (fun nextContext remaining value nextCandidates => + directDetailedBoundaryNormalizedPrivatePlanObserve parameter root ftsSecret + (next value.1) observe nextCandidates nextContext remaining table value.2)) + candidates context fuel table ((maskedSign parameter root ftsSecret message).run cache) q + · intro nextContext remaining value nextCandidates nextOutput hnextOutput + exact support_canonicalizeDirectDetailedPrivatePlanObserve_length_le table _ + nextContext remaining value nextCandidates q + (by + intro finalContext finalRemaining + (finalValue : Option Signature × SplitHashCache) + finalCandidates finalOutput hfinalOutput + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + (q := q) (by simpa [IsOuterHash] using hbound.2 finalValue.1) + (output := finalOutput) hfinalOutput) + nextOutput hnextOutput + · exact houtput + exact htail + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem support_directDetailedBoundaryNormalizedPrivatePlanObserve_length_le_of_expanded + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp (Bool × List Probe)) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) (q : Nat) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + computation).IsQueryBoundP (fun query => query matches Sum.inr _) q) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hobserve : ∀ nextContext remaining value nextCandidates output, + output ∈ support (observe nextContext remaining value nextCandidates) → + output.2.length ≤ nextCandidates.length) + (output : Bool × List Probe) + (houtput : output ∈ support + (directDetailedBoundaryNormalizedPrivatePlanObserve parameter root ftsSecret computation + observe candidates context fuel table cache)) : + output.2.length ≤ candidates.length + q := by + induction computation using OracleComp.inductionOn generalizing + candidates context fuel cache q output with + | pure value => + simp only [directDetailedBoundaryNormalizedPrivatePlanObserve, + OracleComp.construct_pure] at houtput + exact (hobserve context fuel (value, cache) candidates output houtput).trans + (Nat.le_add_right candidates.length q) + | query_bind query next ih => + rw [directDetailedBoundaryNormalizedPrivatePlanObserve, + OracleComp.construct_query_bind] at houtput + cases query with + | inl worldQuery => + rw [SphincsSecurity.simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases worldQuery with + | inl n => + apply support_runDirectDetailedPrivatePlanObserve_length_le_of_done + (canonicalizeDirectDetailedPrivatePlanObserve table + (fun nextContext remaining value nextCandidates => + directDetailedBoundaryNormalizedPrivatePlanObserve parameter root ftsSecret + (next value.1) observe nextCandidates nextContext remaining table value.2)) + candidates context fuel table ((splitUniformImpl n).run cache) q + · intro result hresult nextOutput hnextOutput + have hcore := + resolvedCore_of_done_runDirectResolvedDetailedFromTable_for_count + ((splitUniformImpl n).run cache) context fuel table result hconsistent hstarts + hresult + exact support_canonicalizeDirectDetailedPrivatePlanObserve_length_le_at table _ + result.context result.remaining result.value candidates q + (by + intro finalOutput hfinalOutput + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 (q := q) (hbound.2 result.value.1) + (canonicalizeMaterializedValues_valuesConsistent table result.context + hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + (output := finalOutput) hfinalOutput) + nextOutput hnextOutput + · exact houtput + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + have hpositive : 0 < q := by + rcases hbound.1 with hnot | hpositive + · exact (hnot (by simp)).elim + · exact hpositive + have htail : output.2.length ≤ nextCandidates.length + (q - 1) := by + apply support_runDirectDetailedPrivatePlanObserve_length_le_of_done + (canonicalizeDirectDetailedPrivatePlanObserve table + (fun nextContext remaining value finalCandidates => + directDetailedBoundaryNormalizedPrivatePlanObserve parameter root ftsSecret + (next value.1) observe finalCandidates nextContext remaining table value.2)) + nextCandidates context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) (q - 1) + · intro result hresult nextOutput hnextOutput + have hcore := resolvedCore_of_done_runDirectResolvedDetailedFromTable_for_count + ((probingHashQueryAfterPlan parameter input plan).run cache) + context fuel table result hconsistent hstarts hresult + exact support_canonicalizeDirectDetailedPrivatePlanObserve_length_le_at table _ + result.context result.remaining result.value nextCandidates (q - 1) + (by + intro finalOutput hfinalOutput + exact ih result.value.1 nextCandidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 (q := q - 1) (hbound.2 result.value.1) + (canonicalizeMaterializedValues_valuesConsistent table result.context + hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + (output := finalOutput) hfinalOutput) + nextOutput hnextOutput + · exact houtput + have hnextLength : nextCandidates.length ≤ candidates.length + 1 := + appendPlannedCandidate_length_le candidates + (rootAwarePlannedCandidate? parameter input context.state) + omega + | inr message => + rw [SphincsSecurity.simulateQ_expandedAdversaryImpl_query_bind_inr] at hbound + apply support_runDirectDetailedPrivatePlanObserve_length_le_of_done + (canonicalizeDirectDetailedPrivatePlanObserve table + (fun nextContext remaining value nextCandidates => + directDetailedBoundaryNormalizedPrivatePlanObserve parameter root ftsSecret + (next value.1) observe nextCandidates nextContext remaining table value.2)) + candidates context fuel table ((maskedSign parameter root ftsSecret message).run cache) q + · intro result hresult nextOutput hnextOutput + have hcore := resolvedCore_of_done_runDirectResolvedDetailedFromTable_for_count + ((maskedSign parameter root ftsSecret message).run cache) + context fuel table result hconsistent hstarts hresult + have hdirect : some result ∈ support + (runDirectResolvedFromTable context fuel table + ((maskedSign parameter root ftsSecret message).run cache)) := + mem_support_runDirectResolvedFromTable_of_done_detailed + ((maskedSign parameter root ftsSecret message).run cache) + context fuel table result hresult + have hraw := raw_done_of_mem_runDirectResolvedFromTable + ((maskedSign parameter root ftsSecret message).run cache) + context fuel table result hdirect + have hsign : result.value.1 ∈ support + (scheme.sign + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey) message) := by + exact maskedSign_done_output_mem_support parameter root table ftsSecret message + context.state result.context.state cache result.value.2 fuel result.remaining + result.value.1 hcore.2.2 (by + simpa only [SigningSpec, maskedExpandedAdversaryImpl, maskedSigningImpl] + using hraw) + have htailBound := isQueryBoundP_of_bind hbound result.value.1 hsign + exact support_canonicalizeDirectDetailedPrivatePlanObserve_length_le_at table _ + result.context result.remaining result.value candidates q + (by + intro finalOutput hfinalOutput + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 + (q := q) htailBound + (canonicalizeMaterializedValues_valuesConsistent table result.context + hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + (output := finalOutput) hfinalOutput) + nextOutput hnextOutput + · exact houtput + +theorem support_retainedResolvedFinalizationPrivatePlanObserve_length_le_zero + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) (candidates : List Probe) + (output : Bool × List Probe) + (houtput : output ∈ support + (retainedResolvedFinalizationPrivatePlanObserve table root context fuel value candidates)) : + output.2.length ≤ candidates.length := by + unfold retainedResolvedFinalizationPrivatePlanObserve at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨hit, _hhit, houtput⟩ := houtput + simp at houtput + subst output + simp + +theorem support_granularDetailedRetainedRestNormalizedPrivatePlanObserve_length_le + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) (q : Nat) + (hbound : (retainedGameRestComputation adversary ⟨value.1, parameter⟩).IsQueryBoundP + IsOuterHash q) + (output : Bool × List Probe) + (houtput : output ∈ support + (granularDetailedRetainedRestNormalizedPrivatePlanObserve adversary parameter table + ftsSecret context fuel value candidates)) : + output.2.length ≤ candidates.length + q := by + unfold granularDetailedRetainedRestNormalizedPrivatePlanObserve at houtput + exact support_directDetailedBoundaryNormalizedPrivatePlanObserve_length_le parameter value.1 + ftsSecret (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivatePlanObserve table value.1) + candidates context fuel table value.2 q hbound + (support_retainedResolvedFinalizationPrivatePlanObserve_length_le_zero table value.1) + output houtput + +theorem support_granularDetailedRetainedRestNormalizedPrivatePlanObserve_length_le_of_expanded + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) (q : Nat) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, value.1, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨value.1, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (output : Bool × List Probe) + (houtput : output ∈ support + (granularDetailedRetainedRestNormalizedPrivatePlanObserve adversary parameter table + ftsSecret context fuel value candidates)) : + output.2.length ≤ candidates.length + q := by + unfold granularDetailedRetainedRestNormalizedPrivatePlanObserve at houtput + exact support_directDetailedBoundaryNormalizedPrivatePlanObserve_length_le_of_expanded + parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivatePlanObserve table value.1) + candidates context fuel table value.2 q hbound hconsistent hstarts + (support_retainedResolvedFinalizationPrivatePlanObserve_length_le_zero table value.1) + output houtput + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePlannedCommute.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePlannedCommute.lean new file mode 100644 index 00000000..c84b7e4d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePlannedCommute.lean @@ -0,0 +1,210 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateFresh + +/-! +# Planned-probe resolution commutation + +Resolving a target before one planned candidate and resolving it again afterward is distributionally identical to executing the candidate first and resolving the target once. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open ENNReal + +def addCandidateContext (context : DeferredContext) (candidate : Probe) : DeferredContext := + if candidate.coordinate ∈ context.state.revealed then context + else { context with + state := context.state.addPending candidate.coordinate candidate.candidate } + +noncomputable def resolveAfterCandidate + (target : Position) (candidate : Probe) (context : DeferredContext) : + ProbComp (Option DeferredResolution) := + resolveDeferredPositionValue target (addCandidateContext context candidate) + +theorem resolveDeferredPositionValue_then_resolve_self + (position : Position) (context : DeferredContext) : + evalDist (do + let first ← resolveDeferredPositionValue position context + match first with + | none => pure none + | some first => resolveDeferredPositionValue position first.toDeferredContext) = + evalDist (resolveDeferredPositionValue position context) := by + calc + _ = evalDist (resolveDeferredPositionValue position context >>= pure) := by + apply evalDist_bind_congr + intro first hfirst + cases first with + | none => rfl + | some first => + exact congrArg evalDist + (resolveDeferredPositionValue_of_resolved position context first hfirst) + _ = _ := by rw [bind_pure] + +set_option maxRecDepth 100000 in +theorem resolveDeferredPositionValue_then_resolveAfterCandidate + (target : Position) (candidate : Probe) (context : DeferredContext) : + evalDist (do + let first ← resolveDeferredPositionValue target context + match first with + | none => pure none + | some first => resolveAfterCandidate target candidate first.toDeferredContext) = + evalDist (resolveAfterCandidate target candidate context) := by + unfold resolveAfterCandidate addCandidateContext + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · have hresolvedRevealed : ∀ first, + some first ∈ support (resolveDeferredPositionValue target context) → + candidate.coordinate ∈ first.state.revealed := by + intro first hfirst + rw [resolveDeferredPositionValue_state_eq_clearPending target context first hfirst] + exact hrevealed + simp only [hrevealed, ↓reduceIte] + calc + _ = evalDist (resolveDeferredPositionValue target context >>= pure) := by + apply evalDist_bind_congr + intro first hfirst + cases first with + | none => rfl + | some first => + simp only [hresolvedRevealed first hfirst, ↓reduceIte] + exact congrArg evalDist + (resolveDeferredPositionValue_of_resolved target context first hfirst) + _ = _ := by rw [bind_pure] + · have hresolvedNotRevealed : ∀ first, + some first ∈ support (resolveDeferredPositionValue target context) → + candidate.coordinate ∉ first.state.revealed := by + intro first hfirst hfirstRevealed + apply hrevealed + rw [resolveDeferredPositionValue_state_eq_clearPending target context first hfirst] + at hfirstRevealed + exact hfirstRevealed + simp only [hrevealed, ↓reduceIte] + cases candidate with + | mk coordinate digest => + by_cases heq : coordinate = .position target + · subst coordinate + calc + _ = evalDist (do + let first ← resolveDeferredPositionValue target context + match first with + | none => pure none + | some first => + resolveDeferredPositionValue target + { first.toDeferredContext with + state := first.state.addPending (.position target) digest }) := by + apply evalDist_bind_congr + intro first hfirst + cases first with + | none => rfl + | some first => + simp [hresolvedNotRevealed first hfirst] + _ = _ := congrArg evalDist + (resolveDeferredPositionValue_then_addPending_self_resolve target context digest) + · rw [resolveDeferredPositionValue_addPending_of_ne target context coordinate digest heq] + simp only [map_eq_bind_pure_comp] + apply evalDist_bind_congr + intro first hfirst + cases first with + | none => rfl + | some first => + simp only [hresolvedNotRevealed first hfirst, ↓reduceIte] + rw [resolveDeferredPositionValue_addPending_of_ne target + first.toDeferredContext coordinate digest heq] + rw [map_eq_bind_pure_comp, + resolveDeferredPositionValue_of_resolved target context first hfirst] + simp [DeferredResolution.addPending] + +def candidateListHits (target : Position) : List Probe → HashOutput → Prop + | [], _ => False + | candidate :: remaining, output => + (candidate.coordinate = .position target ∧ + truncateHash output = candidate.candidate) ∨ + candidateListHits target remaining output + +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampleHashOutput_candidateListHits_le + (target : Position) (candidates : List Probe) : + Pr[candidateListHits target candidates | LazyRevealProbe.sampleHashOutput] ≤ + (candidates.length : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + induction candidates with + | nil => simp [candidateListHits] + | cons candidate remaining ih => + let epsilon := ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + have hhead : Pr[fun output : HashOutput => + candidate.coordinate = .position target ∧ + truncateHash output = candidate.candidate | + LazyRevealProbe.sampleHashOutput] ≤ epsilon := by + by_cases hcoordinate : candidate.coordinate = .position target + · apply le_of_eq + calc + _ = Pr[fun output : HashOutput => + truncateHash output = candidate.candidate | + LazyRevealProbe.sampleHashOutput] := by + apply OracleComp.probEvent_congr' (fun _ _ => by simp [hcoordinate]) rfl + _ = (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + unfold LazyRevealProbe.sampleHashOutput + exact SphincsSecurity.probEvent_uniform_truncateHash_eq _ + _ = epsilon := by + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + · simp [hcoordinate] + calc + _ ≤ Pr[fun output : HashOutput => + candidate.coordinate = .position target ∧ + truncateHash output = candidate.candidate | + LazyRevealProbe.sampleHashOutput] + + Pr[candidateListHits target remaining | + LazyRevealProbe.sampleHashOutput] := + probEvent_or_le LazyRevealProbe.sampleHashOutput _ _ + _ ≤ epsilon + (remaining.length : ℝ≥0∞) * epsilon := + add_le_add hhead ih + _ = ((candidate :: remaining).length : ℝ≥0∞) * epsilon := by + simp only [List.length_cons, Nat.cast_add, Nat.cast_one] + ring + +noncomputable def resolveCandidateListFire + (target : Position) (candidates : List Probe) (context : DeferredContext) : + ProbComp Bool := by + classical + exact do + let resolved ← resolveDeferredPositionValue target context + match resolved with + | none => pure false + | some resolved => pure (decide (candidateListHits target candidates resolved.output)) + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_resolveCandidateListFire_le + (target : Position) (candidates : List Probe) (context : DeferredContext) + (hhidden : context.state.values (.position target) = none) + (hprivate : context.values target = none) : + Pr[= true | resolveCandidateListFire target candidates context] ≤ + (candidates.length : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + classical + have hrun : resolveCandidateListFire target candidates context = (do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt (.position target) output then pure false + else pure (decide (candidateListHits target candidates output))) := by + unfold resolveCandidateListFire + rw [resolveDeferredPositionValue_fresh target context hhidden hprivate] + simp only [bind_assoc] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position target) output <;> simp [hhit] + rw [hrun, ← probEvent_eq_eq_probOutput] + refine (probEvent_bind_le_probEvent_add + (mx := LazyRevealProbe.sampleHashOutput) + (my := fun output => + if context.state.hitAt (.position target) output then pure false + else pure (decide (candidateListHits target candidates output))) + (q := fun hit : Bool => hit = true) + (p := candidateListHits target candidates) + (ε := 0) ?_).trans ?_ + · intro output _houtput hmiss + by_cases hhit : context.state.hitAt (.position target) output + · simp [hhit] + · simp [hhit, hmiss] + · simpa only [add_zero] using + probEvent_sampleHashOutput_candidateListHits_le target candidates + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePreparation.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePreparation.lean new file mode 100644 index 00000000..d4cefe8c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePreparation.lean @@ -0,0 +1,296 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateTraceInvariant + +/-! +# All-miss candidate preparation + +The finite resolver endpoint is strengthened to return the prepared context on an all-miss path. Every candidate coordinate then has one persistent private output which avoids every recorded digest at that coordinate. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +def CandidateOutputsSafe (context : DeferredContext) (candidates : List Probe) : Prop := + ∀ candidate ∈ candidates, + match candidate.coordinate with + | .chainStart _ _ _ _ => True + | .position position => + ∃ output, context.values position = some output ∧ + truncateHash output ≠ candidate.candidate + +theorem candidateListHits_iff_exists_mem + (target : Position) (candidates : List Probe) (output : HashOutput) : + candidateListHits target candidates output ↔ + ∃ candidate ∈ candidates, + candidate.coordinate = .position target ∧ + truncateHash output = candidate.candidate := by + induction candidates with + | nil => simp [candidateListHits] + | cons candidate remaining ih => + simp only [candidateListHits, List.mem_cons, ih] + constructor + · rintro (hhead | ⟨found, hfound, hcoordinate, hdigest⟩) + · exact ⟨candidate, Or.inl rfl, hhead.1, hhead.2⟩ + · exact ⟨found, Or.inr hfound, hcoordinate, hdigest⟩ + · rintro ⟨found, rfl | hfound, hcoordinate, hdigest⟩ + · exact Or.inl ⟨hcoordinate, hdigest⟩ + · exact Or.inr ⟨found, hfound, hcoordinate, hdigest⟩ + +theorem not_recordedCandidateHit_of_candidateOutputsSafe + (context : DeferredContext) (candidates : List Probe) + (hsafe : CandidateOutputsSafe context candidates) : + ¬RecordedCandidateHit context candidates := by + rintro ⟨position, output, hvalue, hhit⟩ + obtain ⟨candidate, hcandidate, hcoordinate, hdigest⟩ := + (candidateListHits_iff_exists_mem position candidates output).1 hhit + have hcandidateSafe := hsafe candidate hcandidate + rw [hcoordinate] at hcandidateSafe + obtain ⟨safeOutput, hsafeOutput, hne⟩ := hcandidateSafe + have heq : safeOutput = output := by + rw [hvalue] at hsafeOutput + exact Option.some.inj hsafeOutput.symm + exact hne (heq ▸ hdigest) + +theorem CandidateOutputsSafe.of_privateValuesLE + {left right : DeferredContext} {candidates : List Probe} + (hsafe : CandidateOutputsSafe left candidates) + (hvalues : PrivateValuesLE left right) : + CandidateOutputsSafe right candidates := by + intro candidate hcandidate + have hsafeCandidate := hsafe candidate hcandidate + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => trivial + | position position => + simp only [hcoordinate] at hsafeCandidate ⊢ + obtain ⟨output, houtput, hne⟩ := hsafeCandidate + exact ⟨output, hvalues position output houtput, hne⟩ + +noncomputable def prepareCandidateGroups : Nat → List Probe → DeferredContext → + ProbComp (Option DeferredContext) + | 0, _, context => pure (some context) + | _ + 1, [], context => pure (some context) + | fuel + 1, candidate :: remaining, context => + match candidate.coordinate with + | .chainStart _ _ _ _ => prepareCandidateGroups fuel remaining context + | .position target => do + let resolved ← resolveDeferredPositionValue target context + match resolved with + | none => pure none + | some resolved => + if candidateListHits target (candidate :: remaining) resolved.output then + pure none + else + prepareCandidateGroups fuel + (removeTargetCandidates target (candidate :: remaining)) + resolved.toDeferredContext + +noncomputable def prepareCandidateList + (candidates : List Probe) (context : DeferredContext) : + ProbComp (Option DeferredContext) := + prepareCandidateGroups candidates.length candidates context + +set_option maxRecDepth 100000 in +theorem evalDist_isNone_prepareCandidateGroups_eq_fire + (fuel : Nat) (candidates : List Probe) (context : DeferredContext) : + evalDist (Option.isNone <$> prepareCandidateGroups fuel candidates context) = + evalDist (resolvedCandidateGroupsFire fuel candidates context) := by + induction fuel generalizing candidates context with + | zero => simp [prepareCandidateGroups, resolvedCandidateGroupsFire] + | succ fuel ih => + cases candidates with + | nil => simp [prepareCandidateGroups, resolvedCandidateGroupsFire] + | cons candidate remaining => + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [prepareCandidateGroups, resolvedCandidateGroupsFire, hcoordinate] + exact ih remaining context + | position target => + simp only [prepareCandidateGroups, resolvedCandidateGroupsFire, hcoordinate, + map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved with + | none => simp + | some resolved => + by_cases hhit : candidateListHits target (candidate :: remaining) resolved.output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + exact ih (removeTargetCandidates target (candidate :: remaining)) + resolved.toDeferredContext + +theorem evalDist_isNone_prepareCandidateList_eq_fire + (candidates : List Probe) (context : DeferredContext) : + evalDist (Option.isNone <$> prepareCandidateList candidates context) = + evalDist (resolvedCandidateListFire candidates context) := + evalDist_isNone_prepareCandidateGroups_eq_fire candidates.length candidates context + +theorem privateValuesLE_install_fresh + (context : DeferredContext) (target : Position) (output : HashOutput) + (hfresh : context.values target = none) : + PrivateValuesLE context + { state := context.state.clearPending (.position target) + values := context.values.install target output } := by + intro position value hvalue + have hne : position ≠ target := by + intro heq + subst position + rw [hfresh] at hvalue + contradiction + simpa [DeferredStructuralValues.install, Function.update_of_ne hne] using hvalue + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem preparedCandidateGroups_safe + (fuel : Nat) (candidates : List Probe) (context finalContext : DeferredContext) + (hlength : candidates.length ≤ fuel) + (hfresh : CandidateCoordinatesFresh context candidates) + (hresult : some finalContext ∈ support + (prepareCandidateGroups fuel candidates context)) : + PrivateValuesLE context finalContext ∧ + CandidateOutputsSafe finalContext candidates := by + induction fuel generalizing candidates context finalContext with + | zero => + have hcandidates : candidates = [] := List.eq_nil_of_length_eq_zero (by omega) + subst candidates + simp [prepareCandidateGroups] at hresult + subst finalContext + exact ⟨PrivateValuesLE.refl context, by simp [CandidateOutputsSafe]⟩ + | succ fuel ih => + cases candidates with + | nil => + simp [prepareCandidateGroups] at hresult + subst finalContext + exact ⟨PrivateValuesLE.refl context, by simp [CandidateOutputsSafe]⟩ + | cons candidate remaining => + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [prepareCandidateGroups, hcoordinate] at hresult + have htailFresh : CandidateCoordinatesFresh context remaining := + ⟨hfresh.1, fun next hnext => + hfresh.2 next (List.mem_cons_of_mem candidate hnext)⟩ + obtain ⟨hvalues, hsafe⟩ := + ih remaining context finalContext (by simpa using hlength) htailFresh hresult + refine ⟨hvalues, ?_⟩ + intro next hnext + simp only [List.mem_cons] at hnext + rcases hnext with rfl | hnext + · simp [hcoordinate] + · exact hsafe next hnext + | position target => + have htargetFresh := hfresh.2 candidate (by simp) + simp only [hcoordinate] at htargetFresh + rw [prepareCandidateGroups, hcoordinate, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, htail⟩ := hresult + cases resolvedOption with + | none => simp at htail + | some resolved => + have hnoHit : ∀ output, + ¬context.state.hitAt (.position target) output := fun output => + not_hitAt_of_pending_eq_empty context (.position target) output hfresh.1 + rw [resolveDeferredPositionValue_fresh target context htargetFresh.1 + htargetFresh.2, mem_support_bind_iff] at hresolved + obtain ⟨sampledOutput, _hsampledOutput, hresolved⟩ := hresolved + simp [hnoHit sampledOutput] at hresolved + subst resolved + by_cases hhit : + candidateListHits target (candidate :: remaining) sampledOutput + · simp [hhit] at htail + · simp only [hhit, ↓reduceIte] at htail + let rest := removeTargetCandidates target (candidate :: remaining) + have hheadTarget : candidateTargets target candidate = true := by + simp [candidateTargets, hcoordinate] + have hcountPositive : + 1 ≤ candidateTargetCount target (candidate :: remaining) := by + simp [candidateTargetCount, hheadTarget] + have hrestLength : rest.length ≤ fuel := by + have hpartition := + candidateTargetCount_add_removeTargetCandidates_length target + (candidate :: remaining) + dsimp only [rest] + omega + have hrestFresh := candidateCoordinatesFresh_remove_resolved context + candidate remaining target sampledOutput hfresh + obtain ⟨hrestValues, hrestSafe⟩ := ih + rest + { state := context.state.clearPending (.position target) + values := context.values.install target sampledOutput } + finalContext hrestLength hrestFresh htail + have hresolvedValues : PrivateValuesLE context + { state := context.state.clearPending (.position target) + values := context.values.install target sampledOutput } := + privateValuesLE_install_fresh context target sampledOutput htargetFresh.2 + refine ⟨hresolvedValues.trans hrestValues, ?_⟩ + intro next hnext + cases hnextCoordinate : next.coordinate with + | chainStart nextLay nextTree nextLeaf nextChain => trivial + | position other => + by_cases heq : other = target + · subst other + have htargetValue : + (context.values.install target sampledOutput) target = + some sampledOutput := by + simp [DeferredStructuralValues.install] + have hfinalTarget := hrestValues target sampledOutput htargetValue + refine ⟨sampledOutput, hfinalTarget, ?_⟩ + intro heqDigest + apply hhit + exact candidateListHits_of_mem target sampledOutput next + (candidate :: remaining) hnext (by simpa using hnextCoordinate) + heqDigest.symm + · have hnextRest : next ∈ removeTargetCandidates target + (candidate :: remaining) := by + unfold removeTargetCandidates + apply List.mem_filter.mpr + refine ⟨hnext, ?_⟩ + simp [candidateTargets, hnextCoordinate, heq] + simpa [hnextCoordinate] using hrestSafe next hnextRest + +theorem preparedCandidateList_safe + (candidates : List Probe) (context finalContext : DeferredContext) + (hfresh : CandidateCoordinatesFresh context candidates) + (hresult : some finalContext ∈ support (prepareCandidateList candidates context)) : + PrivateValuesLE context finalContext ∧ CandidateOutputsSafe finalContext candidates := + preparedCandidateGroups_safe candidates.length candidates context finalContext le_rfl hfresh + hresult + +theorem not_recordedCandidateHit_of_prepared_run + (candidates : List Probe) (context prepared : DeferredContext) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : ResolvedRunResult α) + (hfresh : CandidateCoordinatesFresh context candidates) + (hprepared : some prepared ∈ support (prepareCandidateList candidates context)) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable prepared fuel table computation)) : + ¬RecordedCandidateHit result.context candidates := by + obtain ⟨_hcontextValues, hsafe⟩ := + preparedCandidateList_safe candidates context prepared hfresh hprepared + have hvalues := privateValuesLE_of_done_runDirectResolvedDetailedFromTable + computation prepared fuel table result hresult + exact not_recordedCandidateHit_of_candidateOutputsSafe result.context candidates + (hsafe.of_privateValuesLE hvalues) + +theorem probEvent_prepareCandidateList_empty_none_le (candidates : List Probe) : + Pr[= none | prepareCandidateList candidates + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues }] ≤ + (candidates.length : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + let initial : DeferredContext := + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + calc + _ = Pr[fun result : Option DeferredContext => Option.isNone result = true | + prepareCandidateList candidates initial] := by + rw [← probEvent_eq_eq_probOutput] + apply OracleComp.probEvent_congr' (fun result _ => by cases result <;> simp) rfl + _ = Pr[= true | Option.isNone <$> prepareCandidateList candidates initial] := by + rw [← probEvent_eq_eq_probOutput, probEvent_map] + rfl + _ = Pr[= true | resolvedCandidateListFire candidates initial] := + OracleComp.probOutput_congr rfl + (evalDist_isNone_prepareCandidateList_eq_fire candidates initial) + _ ≤ _ := probEvent_resolvedCandidateListFire_empty_le candidates + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePreparationCanonical.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePreparationCanonical.lean new file mode 100644 index 00000000..22e02c7d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePreparationCanonical.lean @@ -0,0 +1,106 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePlanNormalizedCount + +/-! +# Candidate preparation across canonicalization + +Canonicalization moves unpublished materialized structural outputs into the private table without changing their resolution semantics. The finite guarded preparation observer is therefore invariant under a canonical boundary. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_prepareCandidateGroupsFails_canonicalize + (table : OtsSecretIndex → HashOutput) + (fuel : Nat) (candidates : List Probe) (context : DeferredContext) + (hconsistent : context.ValuesConsistent) + (hpublished : PublishedValues context.state) : + evalDist (prepareCandidateGroupsFails fuel candidates + (canonicalizeMaterializedValues table context)) = + evalDist (prepareCandidateGroupsFails fuel candidates context) := by + induction fuel generalizing candidates context with + | zero => simp [prepareCandidateGroupsFails, resolvedCandidateGroupsFire] + | succ fuel ih => + cases candidates with + | nil => simp [prepareCandidateGroupsFails, resolvedCandidateGroupsFire] + | cons candidate remaining => + cases hcandidate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + exact ih remaining context hconsistent hpublished + | position target => + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + let continuation : Option DeferredResolution → ProbComp Bool + | none => pure true + | some resolved => + if candidateListHits target (candidate :: remaining) resolved.output then + pure true + else + prepareCandidateGroupsFails fuel + (removeTargetCandidates target (candidate :: remaining)) + resolved.toDeferredContext + have hresolution := evalDist_resolveDeferredPositionValue_canonicalize table target + context hconsistent hpublished + calc + _ = evalDist (((Option.map (canonicalizeDeferredResolution table)) <$> + resolveDeferredPositionValue target context) >>= continuation) := + evalDist_bind_eq_of_evalDist_eq hresolution.symm continuation + _ = evalDist (resolveDeferredPositionValue target context >>= continuation) := by + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + simp only [Function.comp_apply, pure_bind, Option.map_some, + canonicalizeDeferredResolution] + by_cases hhit : candidateListHits target (candidate :: remaining) + resolved.output + · simp [continuation, hhit] + · simp only [continuation, hhit, ↓reduceIte] + have hnextConsistent := + hconsistent.of_resolveDeferredPositionValue target resolved hresolved + have hnextPublished : PublishedValues resolved.state := + (publishedValues_resolveDeferredPositionValue_iff target context resolved + hresolved).2 hpublished + exact ih (removeTargetCandidates target (candidate :: remaining)) + resolved.toDeferredContext hnextConsistent hnextPublished + _ = _ := rfl + +theorem evalDist_prepareCandidateListFails_canonicalize + (table : OtsSecretIndex → HashOutput) (candidates : List Probe) + (context : DeferredContext) (hconsistent : context.ValuesConsistent) + (hpublished : PublishedValues context.state) : + evalDist (prepareCandidateListFails candidates + (canonicalizeMaterializedValues table context)) = + evalDist (prepareCandidateListFails candidates context) := + evalDist_prepareCandidateGroupsFails_canonicalize table candidates.length candidates context + hconsistent hpublished + +theorem pendingCoveredBy_canonicalize_iff + (table : OtsSecretIndex → HashOutput) (candidates : List Probe) + (context : DeferredContext) : + PendingCoveredBy candidates (canonicalizeMaterializedValues table context) ↔ + PendingCoveredBy candidates context := by + rfl + +theorem evalDist_guardedPreparationObserve_canonicalize + (table : OtsSecretIndex → HashOutput) (candidates : List Probe) + (context : DeferredContext) (hconsistent : context.ValuesConsistent) + (hpublished : PublishedValues context.state) : + evalDist (guardedPreparationObserve candidates + (canonicalizeMaterializedValues table context)) = + evalDist (guardedPreparationObserve candidates context) := by + unfold guardedPreparationObserve + rw [pendingCoveredBy_canonicalize_iff table candidates context] + by_cases hcovered : PendingCoveredBy candidates context + · simp only [hcovered, ↓reduceIte] + exact evalDist_prepareCandidateListFails_canonicalize table candidates context hconsistent + hpublished + · simp [hcovered] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePreparationCommute.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePreparationCommute.lean new file mode 100644 index 00000000..29cb7072 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePreparationCommute.lean @@ -0,0 +1,357 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePreparation + +/-! +# Candidate preparation commutation + +A structural position named by a fixed candidate list may be resolved before the all-miss preparation or at its grouped position in the list. The preparation-failure distribution is unchanged. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable + +def TargetOccurs (target : Position) (candidates : List Probe) : Prop := + ∃ candidate ∈ candidates, candidate.coordinate = .position target + +def NoPendingHit (target : Position) (context : DeferredContext) : Prop := + ∀ output, ¬context.state.hitAt (.position target) output + +theorem noPendingHit_of_pendingCovered_not_occurs + (target : Position) (candidates : List Probe) (context : DeferredContext) + (hcovered : PendingCoveredBy candidates context) + (hnotOccurs : ¬TargetOccurs target candidates) : + NoPendingHit target context := by + intro output hhit + have hpending : + (Coordinate.position target, truncateHash output) ∈ context.state.pending := by + rw [← LazyRevealProbe.State.mem_pendingAt_iff] + exact hhit + obtain ⟨candidate, hcandidate, hcoordinate, _hdigest⟩ := + hcovered (Coordinate.position target, truncateHash output) hpending + exact hnotOccurs ⟨candidate, hcandidate, hcoordinate⟩ + +theorem noPendingHit_clearPending_of_ne + (target other : Position) (context : DeferredContext) (hne : target ≠ other) + (hnoHit : NoPendingHit target context) : + NoPendingHit target + { context with state := context.state.clearPending (.position other) } := by + intro output + rw [hitAt_clearPending_of_ne context.state (.position other) (.position target) output] + · exact hnoHit output + · intro heq + exact hne (Coordinate.position.inj heq) + +theorem evalDist_resolveDeferredPositionValue_isNone_of_noPendingHit + (target : Position) (context : DeferredContext) + (hnoHit : NoPendingHit target context) : + evalDist (resolveDeferredPositionValue target context >>= fun resolved => + match resolved with + | none => pure true + | some _ => pure false) = + evalDist (pure false : ProbComp Bool) := by + unfold resolveDeferredPositionValue + cases hstate : context.state.values (.position target) with + | some output => simp [hstate, hnoHit output] + | none => + simp only [hstate] + cases hprivate : context.values target with + | some output => simp [hnoHit output] + | none => + simp only [bind_assoc] + calc + _ = evalDist (LazyRevealProbe.sampleHashOutput >>= fun _ => pure false) := by + apply evalDist_bind_congr + intro output _houtput + simp [hnoHit output] + _ = evalDist (pure false : ProbComp Bool) := + OracleComp.DeferredSampling.evalDist_bind_const_neverFails + LazyRevealProbe.sampleHashOutput (by + simp [LazyRevealProbe.sampleHashOutput]) (pure false) + +theorem targetOccurs_removeTarget_of_ne + (target other : Position) (candidates : List Probe) (hne : target ≠ other) + (hoccurs : TargetOccurs target candidates) : + TargetOccurs target (removeTargetCandidates other candidates) := by + obtain ⟨candidate, hcandidate, hcoordinate⟩ := hoccurs + refine ⟨candidate, ?_, hcoordinate⟩ + unfold removeTargetCandidates + apply List.mem_filter.mpr + refine ⟨hcandidate, ?_⟩ + simp [candidateTargets, hcoordinate, hne] + +noncomputable def prepareCandidateGroupsFails + (fuel : Nat) (candidates : List Probe) (context : DeferredContext) : ProbComp Bool := + resolvedCandidateGroupsFire fuel candidates context + +noncomputable def continuePreparationAfterRevealed + (fuel : Nat) (target : Position) (candidates : List Probe) : + Option RevealedResolution → ProbComp Bool + | none => pure true + | some resolved => + if candidateListHits target candidates resolved.output then + pure true + else + prepareCandidateGroupsFails fuel (removeTargetCandidates target candidates) + resolved.context + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_resolve_then_prepareCandidateGroupsFails + (position : Position) (fuel : Nat) (candidates : List Probe) + (context : DeferredContext) (hlength : candidates.length ≤ fuel) + (hready : TargetOccurs position candidates ∨ NoPendingHit position context) : + evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + prepareCandidateGroupsFails fuel candidates resolved.toDeferredContext) = + evalDist (prepareCandidateGroupsFails fuel candidates context) := by + induction fuel generalizing candidates context with + | zero => + have hcandidates : candidates = [] := List.eq_nil_of_length_eq_zero (by omega) + subst candidates + rcases hready with hoccurs | hnoHit + · simp [TargetOccurs] at hoccurs + · simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire] + exact evalDist_resolveDeferredPositionValue_isNone_of_noPendingHit position context hnoHit + | succ fuel ih => + cases candidates with + | nil => + rcases hready with hoccurs | hnoHit + · simp [TargetOccurs] at hoccurs + · simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire] + exact evalDist_resolveDeferredPositionValue_isNone_of_noPendingHit position context + hnoHit + | cons candidate remaining => + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcoordinate] + apply ih remaining context (by simpa using hlength) + rcases hready with hoccurs | hnoHit + · left + obtain ⟨found, hfound, hfoundCoordinate⟩ := hoccurs + simp only [List.mem_cons] at hfound + rcases hfound with rfl | hfound + · simp [hcoordinate] at hfoundCoordinate + · exact ⟨found, hfound, hfoundCoordinate⟩ + · exact Or.inr hnoHit + | position target => + by_cases heq : position = target + · subst position + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcoordinate, + ] + apply evalDist_bind_congr + intro first hfirst + cases first with + | none => rfl + | some first => + change evalDist (resolveDeferredPositionValue target + first.toDeferredContext >>= fun second => + match second with + | none => pure true + | some second => + if candidateListHits target (candidate :: remaining) + second.output then + pure true + else + prepareCandidateGroupsFails fuel + (removeTargetCandidates target (candidate :: remaining)) + second.toDeferredContext) = + evalDist (if candidateListHits target (candidate :: remaining) + first.output then + pure true + else + prepareCandidateGroupsFails fuel + (removeTargetCandidates target (candidate :: remaining)) + first.toDeferredContext) + rw [resolveDeferredPositionValue_of_resolved target context first hfirst] + rfl + · let rest := removeTargetCandidates target (candidate :: remaining) + have hcommute := evalDist_resolvePositionValues_comm_of_ne position target + context heq + let continuation := continuePreparationAfterRevealed fuel target + (candidate :: remaining) + calc + _ = evalDist (resolvePositionValuesInOrder position target context >>= + continuation) := by + unfold resolvePositionValuesInOrder continuation + continuePreparationAfterRevealed prepareCandidateGroupsFails + simp only [resolvedCandidateGroupsFire, hcoordinate, bind_assoc] + apply evalDist_bind_congr + intro first _hfirst + cases first with + | none => rfl + | some first => + simp only + rw [bind_assoc] + apply evalDist_bind_congr + intro second _hsecond + cases second <;> rfl + _ = evalDist (resolvePositionValuesSwapped position target context >>= + continuation) := + evalDist_bind_eq_of_evalDist_eq hcommute continuation + _ = evalDist (prepareCandidateGroupsFails (fuel + 1) + (candidate :: remaining) context) := by + unfold resolvePositionValuesSwapped continuation + continuePreparationAfterRevealed prepareCandidateGroupsFails + simp only [resolvedCandidateGroupsFire, hcoordinate, bind_assoc] + apply evalDist_bind_congr + intro targetResolved htargetResolved + cases targetResolved with + | none => rfl + | some targetResolved => + simp only + rw [bind_assoc] + by_cases hhit : candidateListHits target (candidate :: remaining) + targetResolved.output + · simp only [hhit, ↓reduceIte] + calc + _ = evalDist (resolveDeferredPositionValue position + targetResolved.toDeferredContext >>= fun _ => pure true) := by + apply evalDist_bind_congr + intro first _hfirst + cases first <;> simp [hhit] + _ = evalDist (pure true : ProbComp Bool) := + OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolveDeferredPositionValue position + targetResolved.toDeferredContext) + (by simp [resolveDeferredPositionValue, + LazyRevealProbe.sampleHashOutput]) (pure true) + · simp only [hhit, ↓reduceIte] + have hrestLength : rest.length ≤ fuel := by + have hheadTarget : candidateTargets target candidate = true := by + simp [candidateTargets, hcoordinate] + have hcountPositive : 1 ≤ candidateTargetCount target + (candidate :: remaining) := by + simp [candidateTargetCount, hheadTarget] + have hpartition := + candidateTargetCount_add_removeTargetCandidates_length target + (candidate :: remaining) + dsimp only [rest] + omega + have hrestReady : TargetOccurs position rest ∨ + NoPendingHit position targetResolved.toDeferredContext := by + rcases hready with hoccurs | hnoHit + · exact Or.inl (targetOccurs_removeTarget_of_ne position target + (candidate :: remaining) heq hoccurs) + · right + have hstate := resolveDeferredPositionValue_state_eq_clearPending + target context targetResolved htargetResolved + intro output + rw [hstate] + exact noPendingHit_clearPending_of_ne position target context heq + hnoHit output + calc + _ = evalDist (resolveDeferredPositionValue position + targetResolved.toDeferredContext >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + prepareCandidateGroupsFails fuel rest + resolved.toDeferredContext) := by + apply evalDist_bind_congr + intro first _hfirst + cases first <;> simp [hhit, prepareCandidateGroupsFails, rest] + _ = _ := ih rest targetResolved.toDeferredContext hrestLength + hrestReady + +noncomputable def prepareCandidateListFails + (candidates : List Probe) (context : DeferredContext) : ProbComp Bool := + resolvedCandidateListFire candidates context + +theorem evalDist_resolve_then_prepareCandidateListFails + (position : Position) (candidates : List Probe) (context : DeferredContext) + (hoccurs : TargetOccurs position candidates) : + evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => prepareCandidateListFails candidates resolved.toDeferredContext) = + evalDist (prepareCandidateListFails candidates context) := by + exact evalDist_resolve_then_prepareCandidateGroupsFails position candidates.length candidates + context le_rfl (Or.inl hoccurs) + +theorem evalDist_resolve_then_prepareCandidateListFails_of_pendingCovered + (position : Position) (candidates : List Probe) (context : DeferredContext) + (hcovered : PendingCoveredBy candidates context) : + evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => prepareCandidateListFails candidates resolved.toDeferredContext) = + evalDist (prepareCandidateListFails candidates context) := by + apply evalDist_resolve_then_prepareCandidateGroupsFails position candidates.length candidates + context le_rfl + by_cases hoccurs : TargetOccurs position candidates + · exact Or.inl hoccurs + · exact Or.inr + (noPendingHit_of_pendingCovered_not_occurs position candidates context hcovered hoccurs) + +noncomputable def guardedPreparationObserve + (candidates : List Probe) (context : DeferredContext) : ProbComp Bool := by + classical + exact if PendingCoveredBy candidates context then + prepareCandidateListFails candidates context + else + pure true + +theorem pendingCoveredBy_of_resolveDeferredPositionValue + (position : Position) (candidates : List Probe) (context : DeferredContext) + (resolved : DeferredResolution) + (hcovered : PendingCoveredBy candidates context) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue position context)) : + PendingCoveredBy candidates resolved.toDeferredContext := by + apply hcovered.of_subset + rw [resolveDeferredPositionValue_pending position context resolved hresolved] + exact Finset.filter_subset _ _ + +theorem evalDist_resolve_then_guardedPreparationObserve_of_covered + (position : Position) (candidates : List Probe) (context : DeferredContext) + (hcovered : PendingCoveredBy candidates context) : + evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => guardedPreparationObserve candidates resolved.toDeferredContext) = + evalDist (guardedPreparationObserve candidates context) := by + have hleft : evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => guardedPreparationObserve candidates resolved.toDeferredContext) = + evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => prepareCandidateListFails candidates resolved.toDeferredContext) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hnextCovered := pendingCoveredBy_of_resolveDeferredPositionValue position candidates + context resolved hcovered hresolved + simp [guardedPreparationObserve, hnextCovered] + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => prepareCandidateListFails candidates resolved.toDeferredContext) := + hleft + _ = evalDist (prepareCandidateListFails candidates context) := + evalDist_resolve_then_prepareCandidateListFails_of_pendingCovered position candidates + context hcovered + _ = _ := by simp [guardedPreparationObserve, hcovered] + +theorem probEvent_resolve_then_guardedPreparationObserve_le + (position : Position) (candidates : List Probe) (context : DeferredContext) : + Pr[= true | resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => guardedPreparationObserve candidates resolved.toDeferredContext] ≤ + Pr[= true | guardedPreparationObserve candidates context] := by + by_cases hcovered : PendingCoveredBy candidates context + · exact le_of_eq (OracleComp.probOutput_congr rfl + (evalDist_resolve_then_guardedPreparationObserve_of_covered position candidates context + hcovered)) + · simp [guardedPreparationObserve, hcovered] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePreparationInterpreter.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePreparationInterpreter.lean new file mode 100644 index 00000000..6f1edf08 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePreparationInterpreter.lean @@ -0,0 +1,512 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePreparationLift + +/-! +# Guarded preparation through the direct interpreter + +The direct interpreter's private-stop projection is dominated by the guarded finite preparation observer whenever every probe issued by the computation is present in the fixed candidate list. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable + +def IsUncoveredProbe (candidates : List Probe) : + (LazyRevealProbe.World Coordinate).Domain → Prop + | .probe coordinate digest => ⟨coordinate, digest⟩ ∉ candidates + | _ => False + +instance (candidates : List Probe) : DecidablePred (IsUncoveredProbe candidates) + | .probe coordinate digest => inferInstanceAs (Decidable (⟨coordinate, digest⟩ ∉ candidates)) + | .uniform _ | .hashOutput | .ensure _ | .peek _ | .publish _ | .reveal _ => isFalse id + +noncomputable def runPrivatePreparation + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : ProbComp Bool := + runDirectDetailedPrivateObserve + (fun nextContext _remaining _value => guardedPreparationObserve candidates nextContext) + context fuel table computation + +theorem runPrivatePreparation_pure + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (value : α) : + runPrivatePreparation candidates context fuel table (pure value) = + guardedPreparationObserve candidates context := by + simp [runPrivatePreparation, runDirectDetailedPrivateObserve, + runDirectResolvedDetailedFromTable, finishDirectDetailedPrivateObserve] + +theorem runPrivatePreparation_uniform_query_bind + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (n : Nat) + (next : Fin (n + 1) → OracleComp (LazyRevealProbe.World Coordinate) α) : + runPrivatePreparation candidates context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) (.uniform n)) : + OracleComp (LazyRevealProbe.World Coordinate) (Fin (n + 1))) >>= next) = (do + let output ← liftM (unifSpec.query n) + runPrivatePreparation candidates context fuel table (next output)) := by + unfold runPrivatePreparation runDirectDetailedPrivateObserve + rw [runDirectResolvedDetailedFromTable_uniform_query_bind, bind_assoc] + +theorem runPrivatePreparation_hashOutput_query_bind + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) : + runPrivatePreparation candidates context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) .hashOutput) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = (do + let output ← LazyRevealProbe.sampleHashOutput + runPrivatePreparation candidates context fuel table (next output)) := by + unfold runPrivatePreparation runDirectDetailedPrivateObserve + rw [runDirectResolvedDetailedFromTable_hashOutput_query_bind, bind_assoc] + +theorem runPrivatePreparation_ensure_query_bind + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) α) : + runPrivatePreparation candidates context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.ensure coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runPrivatePreparation candidates + { context with state := context.state.ensure coordinate } + fuel table (next ()) := by + unfold runPrivatePreparation runDirectDetailedPrivateObserve + rw [runDirectResolvedDetailedFromTable_ensure_query_bind] + +theorem runPrivatePreparation_probe_query_bind + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) (digest : Digest) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) α) : + runPrivatePreparation candidates context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.probe coordinate digest)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + match fuel with + | 0 => pure false + | remaining + 1 => + if coordinate ∈ context.state.revealed then + runPrivatePreparation candidates context remaining table (next ()) + else + runPrivatePreparation candidates + { context with state := context.state.addPending coordinate digest } + remaining table (next ()) := by + unfold runPrivatePreparation runDirectDetailedPrivateObserve + rw [runDirectResolvedDetailedFromTable_probe_query_bind] + cases fuel with + | zero => rfl + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed <;> + simp [hrevealed] + +theorem runPrivatePreparation_peek_query_bind + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Option HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) : + runPrivatePreparation candidates context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.peek coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) (Option HashOutput)) >>= next) = + runPrivatePreparation candidates context fuel table + (next (context.state.values coordinate)) := by + unfold runPrivatePreparation runDirectDetailedPrivateObserve + rw [runDirectResolvedDetailedFromTable_peek_query_bind] + +theorem runPrivatePreparation_publish_query_bind + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) α) : + runPrivatePreparation candidates context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.publish coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runPrivatePreparation candidates + { context with state := context.state.publish coordinate } + fuel table (next ()) := by + unfold runPrivatePreparation runDirectDetailedPrivateObserve + rw [runDirectResolvedDetailedFromTable_publish_query_bind] + +theorem runPrivatePreparation_reveal_query_bind + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) : + runPrivatePreparation candidates context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.reveal coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = + (match context.state.values coordinate with + | some output => runPrivatePreparation candidates context fuel table (next output) + | none => + match coordinate with + | .chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + if context.state.hitAt coordinate output then + pure false + else + runPrivatePreparation candidates + { state := context.state.materialize coordinate output + values := context.values } + fuel table (next output) + | .position position => + match context.values position with + | some output => + if context.state.hitAt coordinate output then + pure true + else + runPrivatePreparation candidates + { state := context.state.materialize coordinate output + values := context.values } + fuel table (next output) + | none => do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt coordinate output then + pure false + else + runPrivatePreparation candidates + { state := context.state.materialize coordinate output + values := context.values.install position output } + fuel table (next output)) := by + unfold runPrivatePreparation runDirectDetailedPrivateObserve + rw [runDirectResolvedDetailedFromTable_reveal_query_bind] + cases hstate : context.state.values coordinate with + | some output => rfl + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) (table ⟨lay, tree, leafIdx, chainIdx⟩) <;> + simp [hhit, finishDirectDetailedPrivateObserve] + | position position => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output <;> + simp [hprivate, hhit, finishDirectDetailedPrivateObserve] + | none => + simp only [hprivate, bind_assoc] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output <;> + simp [hhit, finishDirectDetailedPrivateObserve] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_runPrivatePreparation_le_guarded + (candidates : List Probe) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hcovered : PendingCoveredBy candidates context) + (hbound : computation.IsQueryBoundP (IsUncoveredProbe candidates) 0) : + Pr[= true | runPrivatePreparation candidates context fuel table computation] ≤ + Pr[= true | guardedPreparationObserve candidates context] := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + rw [runPrivatePreparation_pure] + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases input with + | uniform n => + rw [runPrivatePreparation_uniform_query_bind, ← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_of_forall_le + intro output _houtput + rw [probEvent_eq_eq_probOutput] + exact ih output context fuel hcovered (hbound.2 output) + | hashOutput => + rw [runPrivatePreparation_hashOutput_query_bind, ← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_of_forall_le + intro output _houtput + rw [probEvent_eq_eq_probOutput] + exact ih output context fuel hcovered (hbound.2 output) + | ensure coordinate => + rw [runPrivatePreparation_ensure_query_bind] + calc + _ ≤ Pr[= true | guardedPreparationObserve candidates + { context with state := context.state.ensure coordinate }] := + ih () { context with state := context.state.ensure coordinate } fuel + ((pendingCoveredBy_ensure candidates context coordinate).2 hcovered) + (hbound.2 ()) + _ = _ := OracleComp.probOutput_congr rfl + (evalDist_guardedPreparationObserve_ensure candidates context coordinate) + | probe coordinate digest => + rw [runPrivatePreparation_probe_query_bind] + have hmem : (⟨coordinate, digest⟩ : Probe) ∈ candidates := by + simpa [IsUncoveredProbe] using hbound.1 + have htail : (next ()).IsQueryBoundP (IsUncoveredProbe candidates) 0 := by + simpa [IsUncoveredProbe] using hbound.2 () + cases fuel with + | zero => simp + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp [hrevealed] + exact ih () context remaining hcovered htail + · simp [hrevealed] + let candidate : Probe := ⟨coordinate, digest⟩ + have hnextCovered := hcovered.addPending_of_mem candidate hmem + calc + _ ≤ Pr[= true | guardedPreparationObserve candidates + { context with state := context.state.addPending coordinate digest }] := + ih () { context with state := context.state.addPending coordinate digest } + remaining hnextCovered htail + _ = _ := OracleComp.probOutput_congr rfl + (evalDist_guardedPreparationObserve_addPending_of_mem candidates context + candidate hmem) + | peek coordinate => + rw [runPrivatePreparation_peek_query_bind] + exact ih (context.state.values coordinate) context fuel hcovered (hbound.2 _) + | publish coordinate => + rw [runPrivatePreparation_publish_query_bind] + calc + _ ≤ Pr[= true | guardedPreparationObserve candidates + { context with state := context.state.publish coordinate }] := + ih () { context with state := context.state.publish coordinate } fuel + ((pendingCoveredBy_publish candidates context coordinate).2 hcovered) + (hbound.2 ()) + _ = _ := OracleComp.probOutput_congr rfl + (evalDist_guardedPreparationObserve_publish candidates context coordinate) + | reveal coordinate => + rw [runPrivatePreparation_reveal_query_bind] + cases hstate : context.state.values coordinate with + | some output => + exact ih output context fuel hcovered (hbound.2 output) + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + let output := table index + change Pr[= true | + if context.state.hitAt index.coordinate output then + pure false + else + runPrivatePreparation candidates + { state := context.state.materialize index.coordinate output + values := context.values } + fuel table (next output)] ≤ _ + by_cases hhit : context.state.hitAt index.coordinate output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + have hnextCovered : PendingCoveredBy candidates + { state := context.state.materialize index.coordinate output + values := context.values } := + hcovered.clearPending index.coordinate + calc + _ ≤ Pr[= true | guardedPreparationObserve candidates + { state := context.state.materialize index.coordinate output + values := context.values }] := + ih output + { state := context.state.materialize index.coordinate output + values := context.values } + fuel hnextCovered (hbound.2 output) + _ ≤ _ := probEvent_guardedPreparationObserve_materializeChainStart_le + candidates context index output + | position position => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp only [hprivate, hhit, ↓reduceIte] + have hprivateHit : PrivateStructuralHit context := + ⟨position, output, hstate, hprivate, hhit⟩ + have hguarded := evalDist_guardedPreparationObserve_eq_true_of_privateStructuralHit + candidates context hcovered hprivateHit + exact le_of_eq (OracleComp.probOutput_congr rfl hguarded.symm) + · simp only [hprivate, hhit, ↓reduceIte] + have hnextCovered : PendingCoveredBy candidates + { state := context.state.materialize (.position position) output + values := context.values } := + hcovered.clearPending (.position position) + calc + _ ≤ Pr[= true | guardedPreparationObserve candidates + { state := context.state.materialize (.position position) output + values := context.values }] := + ih output + { state := context.state.materialize (.position position) output + values := context.values } + fuel hnextCovered (hbound.2 output) + _ = _ := OracleComp.probOutput_congr rfl + (evalDist_guardedPreparationObserve_materializePrivate_eq_of_miss + candidates context position output hstate hprivate hhit hcovered) + | none => + simp only [hprivate] + let resolvedContext : HashOutput → DeferredContext := fun output => + { state := context.state.clearPending (.position position) + values := context.values.install position output } + let materializedContext : HashOutput → DeferredContext := fun output => + { state := context.state.materialize (.position position) output + values := context.values.install position output } + let left : HashOutput → ProbComp Bool := fun output => + if context.state.hitAt (.position position) output then + pure false + else + runPrivatePreparation candidates (materializedContext output) fuel table + (next output) + let right : HashOutput → ProbComp Bool := fun output => + if context.state.hitAt (.position position) output then + pure true + else + guardedPreparationObserve candidates (resolvedContext output) + have hbind : Pr[= true | LazyRevealProbe.sampleHashOutput >>= left] ≤ + Pr[= true | LazyRevealProbe.sampleHashOutput >>= right] := by + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_bind_of_forall_le + intro output _houtput + by_cases hhit : context.state.hitAt (.position position) output + · simp [left, right, hhit] + · simp only [left, right, hhit, ↓reduceIte] + have hresolvedCovered : PendingCoveredBy candidates + (resolvedContext output) := + hcovered.clearPending (.position position) + have hmaterializedCovered : PendingCoveredBy candidates + (materializedContext output) := hresolvedCovered + have htail := ih output (materializedContext output) fuel + hmaterializedCovered (hbound.2 output) + have hresolvedState : + (resolvedContext output).state.values (.position position) = none := + hstate + have hresolvedPrivate : + (resolvedContext output).values position = some output := by + simp [resolvedContext, DeferredStructuralValues.install] + have hresolvedMiss : + ¬(resolvedContext output).state.hitAt (.position position) output := + not_hitAt_clearPending_self context.state (.position position) output + have hmaterializedEq := + evalDist_guardedPreparationObserve_materializePrivate_eq_of_miss + candidates (resolvedContext output) position output hresolvedState + hresolvedPrivate hresolvedMiss hresolvedCovered + have hmaterializedContextEq : + { state := (resolvedContext output).state.materialize + (.position position) output + values := (resolvedContext output).values } = + materializedContext output := by + simp [resolvedContext, materializedContext, + LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.materialize, + LazyRevealProbe.State.pendingAway] + rw [hmaterializedContextEq] at hmaterializedEq + rw [probEvent_eq_eq_probOutput, probEvent_eq_eq_probOutput] + exact htail.trans (le_of_eq + (OracleComp.probOutput_congr rfl hmaterializedEq)) + have hright : Pr[= true | + LazyRevealProbe.sampleHashOutput >>= right] ≤ + Pr[= true | guardedPreparationObserve candidates context] := by + let resolvedRun : ProbComp Bool := + resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + guardedPreparationObserve candidates resolved.toDeferredContext + have heq : evalDist (LazyRevealProbe.sampleHashOutput >>= right) = + evalDist resolvedRun := by + unfold resolvedRun + rw [resolveDeferredPositionValue_fresh position context hstate hprivate] + simp only [bind_assoc] + apply evalDist_bind_congr + intro output _houtput + by_cases hhit : context.state.hitAt (.position position) output <;> + simp [right, resolvedContext, hhit] + calc + _ = Pr[= true | resolvedRun] := + OracleComp.probOutput_congr rfl heq + _ ≤ _ := probEvent_resolve_then_guardedPreparationObserve_le position + candidates context + exact hbind.trans hright + +set_option maxRecDepth 100000 in +theorem pendingCoveredBy_of_done_runDirectResolvedDetailedFromTable + (candidates : List Probe) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hcovered : PendingCoveredBy candidates context) + (hbound : computation.IsQueryBoundP (IsUncoveredProbe candidates) 0) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation)) : + PendingCoveredBy candidates result.context := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runDirectResolvedDetailedFromTable] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hcovered + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases input with + | uniform n => + rw [runDirectResolvedDetailedFromTable_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel hcovered (hbound.2 output) htail + | hashOutput => + rw [runDirectResolvedDetailedFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel hcovered (hbound.2 output) htail + | ensure coordinate => + rw [runDirectResolvedDetailedFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel hcovered + (hbound.2 ()) hresult + | probe coordinate digest => + have hmem : (⟨coordinate, digest⟩ : Probe) ∈ candidates := by + simpa [IsUncoveredProbe] using hbound.1 + have htail : (next ()).IsQueryBoundP (IsUncoveredProbe candidates) 0 := by + simpa [IsUncoveredProbe] using hbound.2 () + cases fuel with + | zero => simp [runDirectResolvedDetailedFromTable_probe_query_bind] at hresult + | succ remaining => + rw [runDirectResolvedDetailedFromTable_probe_query_bind] at hresult + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] at hresult + exact ih () context remaining hcovered htail hresult + · simp only [hrevealed, ↓reduceIte] at hresult + exact ih () { context with state := context.state.addPending coordinate digest } + remaining (hcovered.addPending_of_mem ⟨coordinate, digest⟩ hmem) htail hresult + | peek coordinate => + rw [runDirectResolvedDetailedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hcovered (hbound.2 _) hresult + | publish coordinate => + rw [runDirectResolvedDetailedFromTable_publish_query_bind] at hresult + exact ih () { context with state := context.state.publish coordinate } fuel hcovered + (hbound.2 ()) hresult + | reveal coordinate => + rw [runDirectResolvedDetailedFromTable_reveal_query_bind] at hresult + cases hstate : context.state.values coordinate with + | some output => + simp only [hstate] at hresult + exact ih output context fuel hcovered (hbound.2 output) hresult + | none => + simp only [hstate] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + exact ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel (hcovered.clearPending (.chainStart lay tree leafIdx chainIdx)) + (hbound.2 output) hresult + | position position => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hprivate, hhit] at hresult + · simp only [hprivate, hhit, ↓reduceIte] at hresult + exact ih output + { state := context.state.materialize (.position position) output + values := context.values } + fuel (hcovered.clearPending (.position position)) (hbound.2 output) + hresult + | none => + simp only [hprivate, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htailResult⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at htailResult + · simp only [hhit, ↓reduceIte] at htailResult + exact ih output + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel (hcovered.clearPending (.position position)) (hbound.2 output) + htailResult + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePreparationLift.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePreparationLift.lean new file mode 100644 index 00000000..67debf90 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePreparationLift.lean @@ -0,0 +1,996 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePreparationCommute + +/-! +# Administrative preparation lift + +The guarded finite preparation observer is insensitive to administrative changes of the ensured and published sets. These are the nonprobabilistic interpreter cases surrounding structural resolution. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable + +set_option maxRecDepth 100000 in +theorem evalDist_prepareCandidateGroupsFails_ensure + (fuel : Nat) (candidates : List Probe) (context : DeferredContext) + (coordinate : Coordinate) : + evalDist (prepareCandidateGroupsFails fuel candidates + { context with state := context.state.ensure coordinate }) = + evalDist (prepareCandidateGroupsFails fuel candidates context) := by + induction fuel generalizing candidates context with + | zero => simp [prepareCandidateGroupsFails, resolvedCandidateGroupsFire] + | succ fuel ih => + cases candidates with + | nil => simp [prepareCandidateGroupsFails, resolvedCandidateGroupsFire] + | cons candidate remaining => + cases hcandidate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + exact ih remaining context + | position target => + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + rw [resolveDeferredPositionValue_ensure] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved with + | none => rfl + | some resolved => + simp only [Function.comp_apply, pure_bind, Option.map_some, + DeferredResolution.ensure] + by_cases hhit : candidateListHits target (candidate :: remaining) + resolved.output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + exact ih (removeTargetCandidates target (candidate :: remaining)) + resolved.toDeferredContext + +set_option maxRecDepth 100000 in +theorem evalDist_prepareCandidateGroupsFails_publish + (fuel : Nat) (candidates : List Probe) (context : DeferredContext) + (coordinate : Coordinate) : + evalDist (prepareCandidateGroupsFails fuel candidates + { context with state := context.state.publish coordinate }) = + evalDist (prepareCandidateGroupsFails fuel candidates context) := by + induction fuel generalizing candidates context with + | zero => simp [prepareCandidateGroupsFails, resolvedCandidateGroupsFire] + | succ fuel ih => + cases candidates with + | nil => simp [prepareCandidateGroupsFails, resolvedCandidateGroupsFire] + | cons candidate remaining => + cases hcandidate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + exact ih remaining context + | position target => + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + rw [resolveDeferredPositionValue_publish] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved with + | none => rfl + | some resolved => + simp only [Function.comp_apply, pure_bind, Option.map_some, + DeferredResolution.publish] + by_cases hhit : candidateListHits target (candidate :: remaining) + resolved.output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + exact ih (removeTargetCandidates target (candidate :: remaining)) + resolved.toDeferredContext + +theorem pendingCoveredBy_ensure + (candidates : List Probe) (context : DeferredContext) (coordinate : Coordinate) : + PendingCoveredBy candidates + { context with state := context.state.ensure coordinate } ↔ + PendingCoveredBy candidates context := by + rfl + +theorem pendingCoveredBy_publish + (candidates : List Probe) (context : DeferredContext) (coordinate : Coordinate) : + PendingCoveredBy candidates + { context with state := context.state.publish coordinate } ↔ + PendingCoveredBy candidates context := by + rfl + +theorem evalDist_guardedPreparationObserve_ensure + (candidates : List Probe) (context : DeferredContext) (coordinate : Coordinate) : + evalDist (guardedPreparationObserve candidates + { context with state := context.state.ensure coordinate }) = + evalDist (guardedPreparationObserve candidates context) := by + unfold guardedPreparationObserve + rw [pendingCoveredBy_ensure] + by_cases hcovered : PendingCoveredBy candidates context + · simp only [hcovered, ↓reduceIte] + exact evalDist_prepareCandidateGroupsFails_ensure candidates.length candidates context + coordinate + · simp [hcovered] + +theorem evalDist_guardedPreparationObserve_publish + (candidates : List Probe) (context : DeferredContext) (coordinate : Coordinate) : + evalDist (guardedPreparationObserve candidates + { context with state := context.state.publish coordinate }) = + evalDist (guardedPreparationObserve candidates context) := by + unfold guardedPreparationObserve + rw [pendingCoveredBy_publish] + by_cases hcovered : PendingCoveredBy candidates context + · simp only [hcovered, ↓reduceIte] + exact evalDist_prepareCandidateGroupsFails_publish candidates.length candidates context + coordinate + · simp [hcovered] + +set_option maxRecDepth 100000 in +theorem evalDist_prepareCandidateGroupsFails_addPending_chainStart + (fuel : Nat) (candidates : List Probe) (context : DeferredContext) + (index : OtsSecretIndex) (digest : Digest) : + evalDist (prepareCandidateGroupsFails fuel candidates + { context with state := context.state.addPending index.coordinate digest }) = + evalDist (prepareCandidateGroupsFails fuel candidates context) := by + induction fuel generalizing candidates context with + | zero => simp [prepareCandidateGroupsFails, resolvedCandidateGroupsFire] + | succ fuel ih => + cases candidates with + | nil => simp [prepareCandidateGroupsFails, resolvedCandidateGroupsFire] + | cons candidate remaining => + cases hcandidate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + exact ih remaining context + | position target => + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + rw [resolveDeferredPositionValue_addPending_of_ne target context index.coordinate + digest (by cases index; simp [OtsSecretIndex.coordinate])] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved with + | none => rfl + | some resolved => + simp only [Function.comp_apply, pure_bind, Option.map_some, + DeferredResolution.addPending] + by_cases hhit : candidateListHits target (candidate :: remaining) + resolved.output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + exact ih (removeTargetCandidates target (candidate :: remaining)) + resolved.toDeferredContext + +theorem pendingCoveredBy_addPending_chainStart_iff + (candidates : List Probe) (context : DeferredContext) + (index : OtsSecretIndex) (digest : Digest) : + PendingCoveredBy candidates + { context with state := context.state.addPending index.coordinate digest } ↔ + PendingCoveredBy candidates context ∧ + ∃ candidate ∈ candidates, + candidate.coordinate = index.coordinate ∧ candidate.candidate = digest := by + constructor + · intro hcovered + constructor + · intro entry hentry + exact hcovered entry (by + simp only [LazyRevealProbe.State.addPending, Finset.mem_insert] + exact Or.inr hentry) + · exact hcovered (index.coordinate, digest) (by + simp [LazyRevealProbe.State.addPending]) + · rintro ⟨hcovered, candidate, hcandidate, hcoordinate, hdigest⟩ + intro entry hentry + simp only [LazyRevealProbe.State.addPending, Finset.mem_insert] at hentry + rcases hentry with rfl | hentry + · exact ⟨candidate, hcandidate, hcoordinate, hdigest⟩ + · exact hcovered entry hentry + +theorem evalDist_guardedPreparationObserve_addPending_chainStart_of_mem + (candidates : List Probe) (context : DeferredContext) + (index : OtsSecretIndex) (digest : Digest) + (hmem : ∃ candidate ∈ candidates, + candidate.coordinate = index.coordinate ∧ candidate.candidate = digest) : + evalDist (guardedPreparationObserve candidates + { context with state := context.state.addPending index.coordinate digest }) = + evalDist (guardedPreparationObserve candidates context) := by + unfold guardedPreparationObserve + by_cases hcovered : PendingCoveredBy candidates context + · have hnextCovered : PendingCoveredBy candidates + { context with state := context.state.addPending index.coordinate digest } := + (pendingCoveredBy_addPending_chainStart_iff candidates context index digest).2 + ⟨hcovered, hmem⟩ + simp only [hcovered, hnextCovered, ↓reduceIte] + exact evalDist_prepareCandidateGroupsFails_addPending_chainStart candidates.length candidates + context index digest + · have hnextNotCovered : ¬PendingCoveredBy candidates + { context with state := context.state.addPending index.coordinate digest } := by + intro hnext + have hparts := + (pendingCoveredBy_addPending_chainStart_iff candidates context index digest).1 hnext + exact hcovered hparts.1 + simp [hcovered, hnextNotCovered] + +set_option maxRecDepth 100000 in +theorem evalDist_prepareCandidateGroupsFails_clearPending_chainStart + (fuel : Nat) (candidates : List Probe) (context : DeferredContext) + (index : OtsSecretIndex) : + evalDist (prepareCandidateGroupsFails fuel candidates + { context with state := context.state.clearPending index.coordinate }) = + evalDist (prepareCandidateGroupsFails fuel candidates context) := by + induction fuel generalizing candidates context with + | zero => simp [prepareCandidateGroupsFails, resolvedCandidateGroupsFire] + | succ fuel ih => + cases candidates with + | nil => simp [prepareCandidateGroupsFails, resolvedCandidateGroupsFire] + | cons candidate remaining => + cases hcandidate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + exact ih remaining context + | position target => + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + rw [resolveDeferredPositionValue_clearPending_of_ne target context index.coordinate + (by cases index; simp [OtsSecretIndex.coordinate])] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved with + | none => rfl + | some resolved => + simp only [Function.comp_apply, pure_bind, Option.map_some, + DeferredResolution.clearPending] + by_cases hhit : candidateListHits target (candidate :: remaining) + resolved.output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + exact ih (removeTargetCandidates target (candidate :: remaining)) + resolved.toDeferredContext + +theorem PendingCoveredBy.clearPending + {candidates : List Probe} {context : DeferredContext} (coordinate : Coordinate) + (hcovered : PendingCoveredBy candidates context) : + PendingCoveredBy candidates + { context with state := context.state.clearPending coordinate } := by + apply hcovered.of_subset + exact Finset.filter_subset _ _ + +theorem probEvent_guardedPreparationObserve_clearPending_chainStart_le + (candidates : List Probe) (context : DeferredContext) (index : OtsSecretIndex) : + Pr[= true | guardedPreparationObserve candidates + { context with state := context.state.clearPending index.coordinate }] ≤ + Pr[= true | guardedPreparationObserve candidates context] := by + by_cases hcovered : PendingCoveredBy candidates context + · have hnextCovered := hcovered.clearPending index.coordinate + apply le_of_eq + apply OracleComp.probOutput_congr rfl + unfold guardedPreparationObserve + simp only [hcovered, hnextCovered, ↓reduceIte] + exact evalDist_prepareCandidateGroupsFails_clearPending_chainStart candidates.length + candidates context index + · unfold guardedPreparationObserve + simp only [hcovered, ↓reduceIte] + by_cases hnextCovered : PendingCoveredBy candidates + { context with state := context.state.clearPending index.coordinate } + · simp only [hnextCovered, ↓reduceIte] + convert (probOutput_le_one + (mx := prepareCandidateListFails candidates + { context with state := context.state.clearPending index.coordinate }) + (x := true)) using 1 + simp + · simp [hnextCovered] + +theorem clearPending_addPending_self + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (digest : Digest) : + (state.addPending coordinate digest).clearPending coordinate = + state.clearPending coordinate := by + rcases state with ⟨pending, values, revealed, ensured⟩ + simp only [LazyRevealProbe.State.addPending, LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway] + congr 1 + ext entry + simp only [Finset.mem_filter, Finset.mem_insert] + constructor + · rintro ⟨hentry, hne⟩ + rcases hentry with rfl | hentry + · exact False.elim (hne rfl) + · exact ⟨hentry, hne⟩ + · rintro ⟨hentry, hne⟩ + exact ⟨Or.inr hentry, hne⟩ + +theorem resolveDeferredPositionValue_addPending_self_of_resolved + (position : Position) (context : DeferredContext) (resolved : DeferredResolution) + (digest : Digest) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue position context)) : + resolveDeferredPositionValue position + { resolved.toDeferredContext with + state := resolved.state.addPending (.position position) digest } = + if truncateHash resolved.output = digest then + pure none + else + pure (some resolved) := by + rw [resolveDeferredPositionValue_eq_bind_output] + have hvalue := resolveDeferredPositionValue_resolves position context resolved hresolved + have hpositionValue : + ({ resolved.toDeferredContext with + state := resolved.state.addPending (.position position) digest } : + DeferredContext).positionValue position = some resolved.output := by + simpa [DeferredContext.positionValue] using hvalue + unfold deferredPositionOutput + rw [hpositionValue] + simp only [pure_bind] + unfold resolvePrivatePositionWithOutput + have holdClean : ¬resolved.state.hitAt (.position position) resolved.output := by + rw [resolveDeferredPositionValue_state_eq_clearPending position context resolved hresolved] + exact not_hitAt_clearPending_self context.state (.position position) resolved.output + have hhitIff : + (resolved.state.addPending (.position position) digest).hitAt + (.position position) resolved.output ↔ + truncateHash resolved.output = digest := by + rw [hitAt_addPending_self_iff] + simp [holdClean] + by_cases hhit : truncateHash resolved.output = digest + · have hnewHit := hhitIff.mpr hhit + simp [hnewHit, hhit] + · have hnewMiss : ¬(resolved.state.addPending (.position position) digest).hitAt + (.position position) resolved.output := fun hold => hhit (hhitIff.mp hold) + simp only [hnewMiss, hhit, ↓reduceIte] + congr 3 + calc + completePrivatePosition position + { state := resolved.state.addPending (.position position) digest + values := resolved.values } + resolved.output = + completePrivatePosition position resolved.toDeferredContext resolved.output := by + unfold completePrivatePosition + congr 2 + rw [resolveDeferredPositionValue_state_eq_clearPending position context resolved + hresolved] + rw [clearPending_addPending_self, clearPending_idem] + _ = resolved := completePrivatePosition_resolved_eq position context resolved hresolved + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_prepareCandidateGroupsFails_addPending_position_of_mem + (fuel : Nat) (candidates : List Probe) (context : DeferredContext) + (added : Probe) (position : Position) + (hcoordinate : added.coordinate = .position position) + (hmem : added ∈ candidates) (hlength : candidates.length ≤ fuel) : + evalDist (prepareCandidateGroupsFails fuel candidates + { context with + state := context.state.addPending added.coordinate added.candidate }) = + evalDist (prepareCandidateGroupsFails fuel candidates context) := by + induction fuel generalizing candidates context with + | zero => + have hcandidates : candidates = [] := List.eq_nil_of_length_eq_zero (by omega) + subst candidates + simp at hmem + | succ fuel ih => + cases candidates with + | nil => simp at hmem + | cons candidate remaining => + cases hcandidate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + have htailMem : added ∈ remaining := by + simp only [List.mem_cons] at hmem + rcases hmem with hhead | htail + · subst added + simp [hcandidate] at hcoordinate + · exact htail + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + exact ih remaining context htailMem (by simpa using hlength) + | position target => + by_cases heq : position = target + · subst position + have haddedCoordinate : added.coordinate = .position target := hcoordinate + let continuation : Option DeferredResolution → ProbComp Bool + | none => pure true + | some resolved => + if candidateListHits target (candidate :: remaining) resolved.output then + pure true + else + prepareCandidateGroupsFails fuel + (removeTargetCandidates target (candidate :: remaining)) + resolved.toDeferredContext + have hresolver := resolveDeferredPositionValue_then_addPending_self_resolve + target context added.candidate + calc + _ = evalDist (resolveDeferredPositionValue target + { context with + state := context.state.addPending (.position target) + added.candidate } >>= continuation) := by + unfold prepareCandidateGroupsFails + rw [resolvedCandidateGroupsFire, hcandidate, haddedCoordinate] + rfl + _ = evalDist ((do + let first ← resolveDeferredPositionValue target context + match first with + | none => (pure none : ProbComp (Option DeferredResolution)) + | some first => + resolveDeferredPositionValue target + { first.toDeferredContext with + state := first.state.addPending (.position target) + added.candidate }) >>= continuation) := + congrArg evalDist + (congrArg (fun resolver => resolver >>= continuation) hresolver.symm) + _ = evalDist (resolveDeferredPositionValue target context >>= fun first => + match first with + | none => pure true + | some first => + if candidateListHits target (candidate :: remaining) first.output then + pure true + else + prepareCandidateGroupsFails fuel + (removeTargetCandidates target (candidate :: remaining)) + first.toDeferredContext) := by + simp only [bind_assoc] + apply evalDist_bind_congr + intro first hfirst + cases first with + | none => rfl + | some first => + simp only + rw [resolveDeferredPositionValue_addPending_self_of_resolved target + context first added.candidate hfirst] + by_cases haddedHit : truncateHash first.output = added.candidate + · have hlistHit : candidateListHits target (candidate :: remaining) + first.output := + candidateListHits_of_mem target first.output added + (candidate :: remaining) hmem haddedCoordinate haddedHit.symm + simp [continuation, haddedHit, hlistHit] + · simp [continuation, haddedHit] + _ = _ := by + unfold prepareCandidateGroupsFails + rw [resolvedCandidateGroupsFire, hcandidate] + simp only + rfl + · have hcoordinateNe : Coordinate.position position ≠ .position target := by + intro hold + exact heq (Coordinate.position.inj hold) + have htailMem : added ∈ removeTargetCandidates target + (candidate :: remaining) := by + unfold removeTargetCandidates + apply List.mem_filter.mpr + refine ⟨hmem, ?_⟩ + simp [candidateTargets, hcoordinate, heq] + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + rw [hcoordinate, + resolveDeferredPositionValue_addPending_of_ne target context + (.position position) added.candidate hcoordinateNe] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved with + | none => rfl + | some resolved => + simp only [Function.comp_apply, pure_bind, Option.map_some, + DeferredResolution.addPending] + by_cases hhit : candidateListHits target (candidate :: remaining) + resolved.output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + have hrestLength : + (removeTargetCandidates target + (candidate :: remaining)).length ≤ fuel := by + have hheadTarget : candidateTargets target candidate = true := by + simp [candidateTargets, hcandidate] + have hcountPositive : 1 ≤ candidateTargetCount target + (candidate :: remaining) := by + simp [candidateTargetCount, hheadTarget] + have hpartition := + candidateTargetCount_add_removeTargetCandidates_length target + (candidate :: remaining) + omega + have hih := ih + (removeTargetCandidates target (candidate :: remaining)) + resolved.toDeferredContext htailMem hrestLength + rw [hcoordinate] at hih + exact hih + +theorem evalDist_prepareCandidateListFails_addPending_position_of_mem + (candidates : List Probe) (context : DeferredContext) + (added : Probe) (position : Position) + (hcoordinate : added.coordinate = .position position) + (hmem : added ∈ candidates) : + evalDist (prepareCandidateListFails candidates + { context with + state := context.state.addPending added.coordinate added.candidate }) = + evalDist (prepareCandidateListFails candidates context) := + evalDist_prepareCandidateGroupsFails_addPending_position_of_mem candidates.length candidates + context added position hcoordinate hmem le_rfl + +theorem PendingCoveredBy.addPending_of_mem + {candidates : List Probe} {context : DeferredContext} (added : Probe) + (hcovered : PendingCoveredBy candidates context) (hmem : added ∈ candidates) : + PendingCoveredBy candidates + { context with + state := context.state.addPending added.coordinate added.candidate } := by + intro entry hentry + simp only [LazyRevealProbe.State.addPending, Finset.mem_insert] at hentry + rcases hentry with rfl | hentry + · exact ⟨added, hmem, rfl, rfl⟩ + · exact hcovered entry hentry + +theorem evalDist_guardedPreparationObserve_addPending_of_mem + (candidates : List Probe) (context : DeferredContext) (added : Probe) + (hmem : added ∈ candidates) : + evalDist (guardedPreparationObserve candidates + { context with + state := context.state.addPending added.coordinate added.candidate }) = + evalDist (guardedPreparationObserve candidates context) := by + by_cases hcovered : PendingCoveredBy candidates context + · have hnextCovered := hcovered.addPending_of_mem added hmem + unfold guardedPreparationObserve + simp only [hcovered, hnextCovered, ↓reduceIte] + cases hcoordinate : added.coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + have hindex : index.coordinate = added.coordinate := by + simp [index, OtsSecretIndex.coordinate, hcoordinate] + rw [← hcoordinate, ← hindex] + exact evalDist_prepareCandidateGroupsFails_addPending_chainStart candidates.length + candidates context index added.candidate + | position position => + rw [← hcoordinate] + exact evalDist_prepareCandidateListFails_addPending_position_of_mem candidates context + added position hcoordinate hmem + · have hnextNotCovered : ¬PendingCoveredBy candidates + { context with + state := context.state.addPending added.coordinate added.candidate } := by + intro hnext + apply hcovered + intro entry hentry + exact hnext entry (by + simp only [LazyRevealProbe.State.addPending, Finset.mem_insert] + exact Or.inr hentry) + simp [guardedPreparationObserve, hcovered, hnextNotCovered] + +theorem evalDist_guardedPreparationObserve_probe_of_mem + (candidates : List Probe) (context : DeferredContext) (candidate : Probe) + (hmem : candidate ∈ candidates) : + evalDist (guardedPreparationObserve candidates + (if candidate.coordinate ∈ context.state.revealed then + context + else + { context with + state := context.state.addPending candidate.coordinate candidate.candidate })) = + evalDist (guardedPreparationObserve candidates context) := by + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact evalDist_guardedPreparationObserve_addPending_of_mem candidates context candidate hmem + +theorem probEvent_resolveDeferredChainStart_then_guardedPreparationObserve_le + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (candidates : List Probe) (context : DeferredContext) : + Pr[= true | + match resolveDeferredChainStart table index context with + | none => pure false + | some resolved => guardedPreparationObserve candidates resolved.toDeferredContext] ≤ + Pr[= true | guardedPreparationObserve candidates context] := by + cases hresolved : resolveDeferredChainStart table index context with + | none => simp + | some resolved => + have hstate := resolveDeferredChainStart_state_eq_clearPending table index context + resolved hresolved + have hvalues := resolveDeferredChainStart_deferred_values_eq table index context + resolved hresolved + have hcontext : resolved.toDeferredContext = + { context with state := context.state.clearPending index.coordinate } := by + cases context with + | mk state values => + cases resolved with + | mk resolvedContext output => + cases resolvedContext with + | mk resolvedState resolvedValues => + simp only at hstate hvalues ⊢ + subst resolvedState + subst resolvedValues + rfl + simp only + rw [hcontext] + exact probEvent_guardedPreparationObserve_clearPending_chainStart_le candidates context + index + +def DeferredResolution.setStateValue (resolved : DeferredResolution) + (coordinate : Coordinate) (output : HashOutput) : DeferredResolution := + ⟨{ resolved.toDeferredContext with + state := { resolved.state with + values := Function.update resolved.state.values coordinate (some output) } }, + resolved.output⟩ + +theorem clearPending_setStateValue_comm + (state : LazyRevealProbe.State Coordinate) (cleared coordinate : Coordinate) + (output : HashOutput) : + ({ state with values := Function.update state.values coordinate (some output) }).clearPending + cleared = + { state.clearPending cleared with + values := Function.update (state.clearPending cleared).values coordinate (some output) } := by + rfl + +@[simp] theorem hitAt_setStateValue + (state : LazyRevealProbe.State Coordinate) (updated coordinate : Coordinate) + (updatedOutput output : HashOutput) : + ({ state with values := Function.update state.values updated (some updatedOutput) }).hitAt + coordinate output = state.hitAt coordinate output := rfl + +theorem resolveDeferredPositionValue_setStateValue_of_ne + (position : Position) (context : DeferredContext) (coordinate : Coordinate) + (output : HashOutput) (hne : coordinate ≠ .position position) : + resolveDeferredPositionValue position + { context with + state := { context.state with + values := Function.update context.state.values coordinate (some output) } } = + (fun result => result.map fun resolved => resolved.setStateValue coordinate output) <$> + resolveDeferredPositionValue position context := by + unfold resolveDeferredPositionValue DeferredResolution.setStateValue + have hlookup : Function.update context.state.values coordinate (some output) + (.position position) = context.state.values (.position position) := + Function.update_of_ne (a := .position position) (a' := coordinate) (Ne.symm hne) + (some output) context.state.values + simp only [hlookup] + cases hstate : context.state.values (.position position) with + | some positionOutput => + by_cases hhit : context.state.hitAt (.position position) positionOutput + · simp [hhit] + · simp [hhit, clearPending_setStateValue_comm] + | none => + cases hprivate : context.values position with + | some positionOutput => + by_cases hhit : context.state.hitAt (.position position) positionOutput + · simp [hhit] + · simp [hhit, clearPending_setStateValue_comm] + | none => + simp only [map_bind] + apply bind_congr + intro positionOutput + by_cases hhit : context.state.hitAt (.position position) positionOutput + · simp [hhit] + · simp [hhit, clearPending_setStateValue_comm] + +set_option maxRecDepth 100000 in +theorem evalDist_prepareCandidateGroupsFails_setChainStartValue + (fuel : Nat) (candidates : List Probe) (context : DeferredContext) + (index : OtsSecretIndex) (output : HashOutput) : + evalDist (prepareCandidateGroupsFails fuel candidates + { context with + state := { context.state with + values := Function.update context.state.values index.coordinate (some output) } }) = + evalDist (prepareCandidateGroupsFails fuel candidates context) := by + induction fuel generalizing candidates context with + | zero => simp [prepareCandidateGroupsFails, resolvedCandidateGroupsFire] + | succ fuel ih => + cases candidates with + | nil => simp [prepareCandidateGroupsFails, resolvedCandidateGroupsFire] + | cons candidate remaining => + cases hcandidate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + exact ih remaining context + | position target => + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + rw [resolveDeferredPositionValue_setStateValue_of_ne target context index.coordinate + output (by cases index; simp [OtsSecretIndex.coordinate])] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved with + | none => rfl + | some resolved => + simp only [Function.comp_apply, pure_bind, Option.map_some, + DeferredResolution.setStateValue] + by_cases hhit : candidateListHits target (candidate :: remaining) + resolved.output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + exact ih (removeTargetCandidates target (candidate :: remaining)) + resolved.toDeferredContext + +set_option maxRecDepth 100000 in +theorem evalDist_prepareCandidateGroupsFails_setPositionValue_of_not_occurs + (fuel : Nat) (candidates : List Probe) (context : DeferredContext) + (position : Position) (output : HashOutput) + (hnotOccurs : ¬TargetOccurs position candidates) : + evalDist (prepareCandidateGroupsFails fuel candidates + { context with + state := { context.state with + values := Function.update context.state.values (.position position) (some output) } }) = + evalDist (prepareCandidateGroupsFails fuel candidates context) := by + induction fuel generalizing candidates context with + | zero => simp [prepareCandidateGroupsFails, resolvedCandidateGroupsFire] + | succ fuel ih => + cases candidates with + | nil => simp [prepareCandidateGroupsFails, resolvedCandidateGroupsFire] + | cons candidate remaining => + cases hcandidate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + apply ih remaining context + intro htail + exact hnotOccurs ⟨htail.choose, List.mem_cons_of_mem candidate htail.choose_spec.1, + htail.choose_spec.2⟩ + | position target => + have hne : Coordinate.position position ≠ .position target := by + intro heq + have hposition : position = target := Coordinate.position.inj heq + apply hnotOccurs + exact ⟨candidate, by simp, by simpa [hposition] using hcandidate⟩ + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + rw [resolveDeferredPositionValue_setStateValue_of_ne target context + (.position position) output hne] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved with + | none => rfl + | some resolved => + simp only [Function.comp_apply, pure_bind, Option.map_some, + DeferredResolution.setStateValue] + by_cases hhit : candidateListHits target (candidate :: remaining) + resolved.output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + apply ih (removeTargetCandidates target (candidate :: remaining)) + resolved.toDeferredContext + intro hrest + obtain ⟨found, hfound, hfoundCoordinate⟩ := hrest + apply hnotOccurs + exact ⟨found, (List.mem_filter.mp hfound).1, hfoundCoordinate⟩ + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_prepareCandidateGroupsFails_promotePrivatePosition + (fuel : Nat) (candidates : List Probe) (context : DeferredContext) + (position : Position) (output : HashOutput) + (hstate : context.state.values (.position position) = none) + (hprivate : context.values position = some output) : + evalDist (prepareCandidateGroupsFails fuel candidates + { context with + state := { context.state with + values := Function.update context.state.values (.position position) (some output) } }) = + evalDist (prepareCandidateGroupsFails fuel candidates context) := by + induction fuel generalizing candidates context with + | zero => simp [prepareCandidateGroupsFails, resolvedCandidateGroupsFire] + | succ fuel ih => + cases candidates with + | nil => simp [prepareCandidateGroupsFails, resolvedCandidateGroupsFire] + | cons candidate remaining => + cases hcandidate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + exact ih remaining context hstate hprivate + | position target => + by_cases heq : position = target + · subst position + let promoted : DeferredContext := + { context with + state := { context.state with + values := Function.update context.state.values (.position target) + (some output) } } + change evalDist (prepareCandidateGroupsFails (fuel + 1) + (candidate :: remaining) promoted) = _ + have hupdatedValue : Function.update context.state.values (.position target) + (some output) (.position target) = some output := by simp + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + rw [resolveDeferredPositionValue_of_state_value target + promoted output (by simp [promoted]), + resolveDeferredPositionValue_of_deferred_value target context output hstate + hprivate] + have hhitEq : + promoted.state.hitAt (.position target) output = + context.state.hitAt (.position target) output := rfl + by_cases hhit : context.state.hitAt (.position target) output + · have hpromotedHit : promoted.state.hitAt (.position target) output := by + rwa [hhitEq] + simp [hhit, hpromotedHit] + · have hpromotedMiss : ¬promoted.state.hitAt (.position target) output := by + rwa [hhitEq] + simp only [hhit, hpromotedMiss, ↓reduceIte, pure_bind] + by_cases hcandidateHit : candidateListHits target (candidate :: remaining) output + · simp [hcandidateHit] + · simp only [hcandidateHit, ↓reduceIte] + have hinstall : context.values.install target output = context.values := by + unfold DeferredStructuralValues.install + conv_lhs => rw [← hprivate] + exact Function.update_eq_self _ _ + rw [hinstall] + let rest := removeTargetCandidates target (candidate :: remaining) + have hnotOccurs : ¬TargetOccurs target rest := by + rintro ⟨found, hfound, hfoundCoordinate⟩ + have hnotTarget := (List.mem_filter.mp hfound).2 + simp [candidateTargets, hfoundCoordinate] at hnotTarget + exact evalDist_prepareCandidateGroupsFails_setPositionValue_of_not_occurs + fuel rest + { context with state := context.state.clearPending (.position target) } + target output hnotOccurs + · have hcoordinateNe : Coordinate.position position ≠ .position target := by + intro hold + exact heq (Coordinate.position.inj hold) + simp only [prepareCandidateGroupsFails, resolvedCandidateGroupsFire, hcandidate] + rw [resolveDeferredPositionValue_setStateValue_of_ne target context + (.position position) output hcoordinateNe] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + simp only [Function.comp_apply, pure_bind, Option.map_some, + DeferredResolution.setStateValue] + by_cases hhit : candidateListHits target (candidate :: remaining) + resolved.output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + have hnextState : resolved.state.values (.position position) = none := by + rw [resolveDeferredPositionValue_preserves_state_values target context + resolved hresolved] + exact hstate + have hnextPrivate : resolved.values position = some output := by + rw [resolveDeferredPositionValue_preserves_other target position context + resolved heq hresolved] + exact hprivate + exact ih (removeTargetCandidates target (candidate :: remaining)) + resolved.toDeferredContext hnextState hnextPrivate + +theorem evalDist_prepareCandidateListFails_materializePrivate_eq_clear + (candidates : List Probe) (context : DeferredContext) + (position : Position) (output : HashOutput) + (hstate : context.state.values (.position position) = none) + (hprivate : context.values position = some output) : + evalDist (prepareCandidateListFails candidates + { state := context.state.materialize (.position position) output + values := context.values }) = + evalDist (prepareCandidateListFails candidates + { context with state := context.state.clearPending (.position position) }) := by + let cleared : DeferredContext := + { context with state := context.state.clearPending (.position position) } + let promoted : DeferredContext := + { cleared with state := { cleared.state with + values := Function.update cleared.state.values (.position position) (some output) } } + have hclearedState : cleared.state.values (.position position) = none := by + exact hstate + have hclearedPrivate : cleared.values position = some output := hprivate + change evalDist (prepareCandidateListFails candidates + { promoted with state := promoted.state.ensure (.position position) }) = + evalDist (prepareCandidateListFails candidates cleared) + calc + _ = evalDist (prepareCandidateListFails candidates promoted) := + evalDist_prepareCandidateGroupsFails_ensure candidates.length candidates promoted + (.position position) + _ = _ := evalDist_prepareCandidateGroupsFails_promotePrivatePosition candidates.length + candidates cleared position output hclearedState hclearedPrivate + +theorem evalDist_guardedPreparationObserve_materializePrivate_eq_clear_of_covered + (candidates : List Probe) (context : DeferredContext) + (position : Position) (output : HashOutput) + (hstate : context.state.values (.position position) = none) + (hprivate : context.values position = some output) + (hcovered : PendingCoveredBy candidates context) : + evalDist (guardedPreparationObserve candidates + { state := context.state.materialize (.position position) output + values := context.values }) = + evalDist (guardedPreparationObserve candidates + { context with state := context.state.clearPending (.position position) }) := by + have hleftCovered : PendingCoveredBy candidates + { state := context.state.materialize (.position position) output + values := context.values } := hcovered.clearPending (.position position) + have hrightCovered : PendingCoveredBy candidates + { context with state := context.state.clearPending (.position position) } := + hcovered.clearPending (.position position) + unfold guardedPreparationObserve + simp only [hleftCovered, hrightCovered, ↓reduceIte] + exact evalDist_prepareCandidateListFails_materializePrivate_eq_clear candidates context + position output hstate hprivate + +theorem evalDist_guardedPreparationObserve_eq_true_of_privateStructuralHit + (candidates : List Probe) (context : DeferredContext) + (hcovered : PendingCoveredBy candidates context) + (hhit : PrivateStructuralHit context) : + evalDist (guardedPreparationObserve candidates context) = + evalDist (pure true : ProbComp Bool) := by + obtain ⟨position, output, hstate, hprivate, hpositionHit⟩ := hhit + have hcommute := + evalDist_resolve_then_prepareCandidateListFails_of_pendingCovered position candidates + context hcovered + rw [resolveDeferredPositionValue_of_deferred_value position context output hstate hprivate] + at hcommute + simp only [hpositionHit, ↓reduceIte, pure_bind] at hcommute + unfold guardedPreparationObserve + simp only [hcovered, ↓reduceIte] + exact hcommute.symm + +theorem evalDist_guardedPreparationObserve_materializePrivate_eq_of_miss + (candidates : List Probe) (context : DeferredContext) + (position : Position) (output : HashOutput) + (hstate : context.state.values (.position position) = none) + (hprivate : context.values position = some output) + (hmiss : ¬context.state.hitAt (.position position) output) + (hcovered : PendingCoveredBy candidates context) : + evalDist (guardedPreparationObserve candidates + { state := context.state.materialize (.position position) output + values := context.values }) = + evalDist (guardedPreparationObserve candidates context) := by + let resolved : DeferredResolution := + ⟨{ state := context.state.clearPending (.position position) + values := context.values }, output⟩ + have hresolver : resolveDeferredPositionValue position context = pure (some resolved) := by + rw [resolveDeferredPositionValue_of_deferred_value position context output hstate hprivate] + simp [hmiss, resolved] + have hcommute := + evalDist_resolve_then_guardedPreparationObserve_of_covered position candidates context + hcovered + rw [hresolver] at hcommute + simp only [pure_bind] at hcommute + calc + _ = evalDist (guardedPreparationObserve candidates resolved.toDeferredContext) := + evalDist_guardedPreparationObserve_materializePrivate_eq_clear_of_covered candidates + context position output hstate hprivate hcovered + _ = _ := hcommute + +theorem evalDist_prepareCandidateListFails_materializeChainStart_eq_clear + (candidates : List Probe) (context : DeferredContext) + (index : OtsSecretIndex) (output : HashOutput) : + evalDist (prepareCandidateListFails candidates + { context with state := context.state.materialize index.coordinate output }) = + evalDist (prepareCandidateListFails candidates + { context with state := context.state.clearPending index.coordinate }) := by + change evalDist (prepareCandidateListFails candidates + { context with + state := { (context.state.clearPending index.coordinate) with + values := Function.update (context.state.clearPending index.coordinate).values + index.coordinate (some output) + ensured := insert index.coordinate context.state.ensured } }) = _ + calc + _ = evalDist (prepareCandidateListFails candidates + { context with + state := { (context.state.clearPending index.coordinate) with + values := Function.update (context.state.clearPending index.coordinate).values + index.coordinate (some output) } }) := + evalDist_prepareCandidateGroupsFails_ensure candidates.length candidates + { context with state := + { (context.state.clearPending index.coordinate) with + values := Function.update (context.state.clearPending index.coordinate).values + index.coordinate (some output) } } + index.coordinate + _ = _ := evalDist_prepareCandidateGroupsFails_setChainStartValue candidates.length candidates + { context with state := context.state.clearPending index.coordinate } index output + +theorem pendingCoveredBy_materializeChainStart_iff_clear + (candidates : List Probe) (context : DeferredContext) + (index : OtsSecretIndex) (output : HashOutput) : + PendingCoveredBy candidates + { context with state := context.state.materialize index.coordinate output } ↔ + PendingCoveredBy candidates + { context with state := context.state.clearPending index.coordinate } := by + rfl + +theorem evalDist_guardedPreparationObserve_materializeChainStart_eq_clear + (candidates : List Probe) (context : DeferredContext) + (index : OtsSecretIndex) (output : HashOutput) : + evalDist (guardedPreparationObserve candidates + { context with state := context.state.materialize index.coordinate output }) = + evalDist (guardedPreparationObserve candidates + { context with state := context.state.clearPending index.coordinate }) := by + unfold guardedPreparationObserve + rw [pendingCoveredBy_materializeChainStart_iff_clear candidates context index output] + by_cases hcovered : PendingCoveredBy candidates + { context with state := context.state.clearPending index.coordinate } + · simp only [hcovered, ↓reduceIte] + exact evalDist_prepareCandidateListFails_materializeChainStart_eq_clear candidates context + index output + · simp [hcovered] + +theorem probEvent_guardedPreparationObserve_materializeChainStart_le + (candidates : List Probe) (context : DeferredContext) + (index : OtsSecretIndex) (output : HashOutput) : + Pr[= true | guardedPreparationObserve candidates + { context with state := context.state.materialize index.coordinate output }] ≤ + Pr[= true | guardedPreparationObserve candidates context] := by + calc + _ = Pr[= true | guardedPreparationObserve candidates + { context with state := context.state.clearPending index.coordinate }] := + OracleComp.probOutput_congr rfl + (evalDist_guardedPreparationObserve_materializeChainStart_eq_clear candidates context + index output) + _ ≤ _ := probEvent_guardedPreparationObserve_clearPending_chainStart_le candidates context + index + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateRootCandidate.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateRootCandidate.lean new file mode 100644 index 00000000..52fc729c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateRootCandidate.lean @@ -0,0 +1,156 @@ +import SphincsSecurity.Proof.EncodingTarget +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePlanExecution + +/-! +# Root-aware planned candidates + +An encoding-domain query carries its guessed layer message in payload slot zero. Top and middle +layer messages are the roots later materialized by the masked signer. This module records that +guess as a proof-only candidate without changing execution of the concrete hash handler. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +def Probe.HasStructuralParent (candidate : Probe) : Prop := + match candidate.coordinate with + | .chainStart _ _ _ _ => True + | .position position => ∃ parent, Position.parentOf position = some parent + +def layerRootPosition (lay : Layer) (tree : TreeIndex) : Position := + .node lay tree + ⟨layerHeight lay - 1, by + have hpos : 0 < layerHeight lay := by + unfold layerHeight + split <;> norm_num [maxLayerHeight] + have hle := layerHeight_le lay + omega⟩ + 0 + +def IsLayerRoot (position : Position) : Prop := + ∃ lay tree, position = layerRootPosition lay tree + +def Probe.IsLayerRoot (candidate : Probe) : Prop := + ∃ position, candidate.coordinate = .position position ∧ + SphincsSecurity.Concrete.OtsProbeSimulation.IsLayerRoot position + +theorem isShortLayerRoot_of_isLayerRoot_of_parent + {position parent : Position} (hroot : IsLayerRoot position) + (hparent : Position.parentOf position = some parent) : + ∃ lay tree, lay ≠ topLayer ∧ position = layerRootPosition lay tree := by + obtain ⟨lay, tree, rfl⟩ := hroot + fin_cases lay + · simp [layerRootPosition, Position.parentOf, layerHeight, + maxLayerHeight] at hparent + · exact ⟨middleLayer, tree, by decide, rfl⟩ + · exact ⟨bottomLayer, tree, by decide, rfl⟩ + +def EncodingLayerRootCandidateAt (parameter : PublicParameter) (input : HashInput) + (candidate : Probe) : Prop := + ∃ (position : EncodingPosition) (index : Index), + AtEncodingPosition parameter input position ∧ + treeIndexAt index position.lay = position.tree ∧ + leafIndexAt index position.lay = position.leafIdx ∧ + position.lay ≠ bottomLayer ∧ + candidate = ⟨.position (layerMessagePosition index position.lay), slotDigest 0 input⟩ + +theorem encodingLayerRootCandidateAt_unique + {parameter : PublicParameter} {input : HashInput} {left right : Probe} + (hleft : EncodingLayerRootCandidateAt parameter input left) + (hright : EncodingLayerRootCandidateAt parameter input right) : left = right := by + obtain ⟨leftPosition, leftIndex, hleftAt, hleftTree, hleftLeaf, _hleftLayer, + hleftCandidate⟩ := hleft + obtain ⟨rightPosition, rightIndex, hrightAt, hrightTree, hrightLeaf, _hrightLayer, + hrightCandidate⟩ := hright + have hposition : leftPosition = rightPosition := + atEncodingPosition_unique hleftAt hrightAt + subst rightPosition + have hmessage : layerMessagePosition leftIndex leftPosition.lay = + layerMessagePosition rightIndex leftPosition.lay := + layerMessagePosition_eq_of_position_eq leftIndex rightIndex leftPosition.lay + (hleftTree.trans hrightTree.symm) (hleftLeaf.trans hrightLeaf.symm) + rw [hleftCandidate, hrightCandidate, hmessage] + +noncomputable def decodeEncodingLayerRootCandidate? + (parameter : PublicParameter) (input : HashInput) : Option Probe := by + classical + exact if hcandidate : ∃ candidate, EncodingLayerRootCandidateAt parameter input candidate then + some (Classical.choose hcandidate) + else none + +theorem decodeEncodingLayerRootCandidate?_eq_some_iff + (parameter : PublicParameter) (input : HashInput) (candidate : Probe) : + decodeEncodingLayerRootCandidate? parameter input = some candidate ↔ + EncodingLayerRootCandidateAt parameter input candidate := by + classical + unfold decodeEncodingLayerRootCandidate? + split + next hexists => + constructor + · intro heq + have hchosen : Classical.choose hexists = candidate := by simpa using heq + simpa [← hchosen] using Classical.choose_spec hexists + · intro hcandidate + have hchosen : Classical.choose hexists = candidate := + encodingLayerRootCandidateAt_unique (Classical.choose_spec hexists) hcandidate + simp [hchosen] + next hnone => + constructor + · simp + · intro hcandidate + exact (hnone ⟨candidate, hcandidate⟩).elim + +theorem encodingLayerRootCandidateAt_isLayerRoot + {parameter : PublicParameter} {input : HashInput} {candidate : Probe} + (hcandidate : EncodingLayerRootCandidateAt parameter input candidate) : + ∃ position, candidate.coordinate = .position position ∧ IsLayerRoot position := by + obtain ⟨position, index, _hat, _htree, _hleaf, hnotBottom, rfl⟩ := hcandidate + rcases position with ⟨lay, tree, leafIdx⟩ + fin_cases lay + · refine ⟨layerMessagePosition index topLayer, rfl, middleLayer, + treeIndexAt index middleLayer, ?_⟩ + simp [layerRootPosition] + · refine ⟨layerMessagePosition index middleLayer, rfl, bottomLayer, + treeIndexAt index bottomLayer, ?_⟩ + simp [layerRootPosition] + · exact False.elim (hnotBottom rfl) + +theorem decodeEncodingLayerRootCandidate?_some_isLayerRoot + {parameter : PublicParameter} {input : HashInput} {candidate : Probe} + (hdecode : decodeEncodingLayerRootCandidate? parameter input = some candidate) : + candidate.IsLayerRoot := + encodingLayerRootCandidateAt_isLayerRoot + ((decodeEncodingLayerRootCandidate?_eq_some_iff parameter input candidate).mp hdecode) + +theorem encodingLayerRootCandidateAt_hasStructuralParent + {parameter : PublicParameter} {input : HashInput} {candidate : Probe} + (hcandidate : EncodingLayerRootCandidateAt parameter input candidate) : + candidate.HasStructuralParent := by + obtain ⟨position, index, _hat, _htree, _hleaf, hnotBottom, rfl⟩ := hcandidate + rcases position with ⟨lay, tree, leafIdx⟩ + fin_cases lay + · change ∃ parent, Position.parentOf (layerMessagePosition index topLayer) = some parent + rw [layerMessagePosition_top] + simp [Position.parentOf, layerHeight, middleLayer, maxLayerHeight] + · change ∃ parent, Position.parentOf (layerMessagePosition index middleLayer) = some parent + rw [layerMessagePosition_middle] + simp [Position.parentOf, layerHeight, bottomLayer, maxLayerHeight, numLayers] + · exact False.elim (hnotBottom rfl) + +noncomputable def rootAwarePlannedCandidate? + (parameter : PublicParameter) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) : Option Probe := + let planned := (purePlanProbingHashQuery parameter input state).candidate? + match planned with + | some candidate => some candidate + | none => decodeEncodingLayerRootCandidate? parameter input + +theorem rootAwarePlannedCandidate?_eq_of_plan_some + {parameter : PublicParameter} {input : HashInput} + {state : LazyRevealProbe.State Coordinate} {candidate : Probe} + (hplan : (purePlanProbingHashQuery parameter input state).candidate? = some candidate) : + rootAwarePlannedCandidate? parameter input state = some candidate := by + simp [rootAwarePlannedCandidate?, hplan] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateSafe.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateSafe.lean new file mode 100644 index 00000000..824d402e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateSafe.lean @@ -0,0 +1,1223 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryOrdinaryAdaptive + +/-! +# Probe-free private-boundary safety + +A computation that issues no probes cannot create a private structural first fire. This supplies the signing-query case of the materialized private-boundary probability lift. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +def CanonicalPrivateSafeResult + (table : OtsSecretIndex → HashOutput) : DirectDetailedResult α → Prop + | .stopped .privateStructuralHit => False + | .stopped _ => True + | .done result => + ¬PrivateStructuralHit (canonicalizeMaterializedValues table result.context) + +theorem canonicalPrivateClean_ensure + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (coordinate : Coordinate) + (hclean : ¬PrivateStructuralHit + (canonicalizeMaterializedValues table context)) : + ¬PrivateStructuralHit + (canonicalizeMaterializedValues table + { context with state := context.state.ensure coordinate }) := by + rintro ⟨position, output, hhidden, hprivate, hhit⟩ + apply hclean + refine ⟨position, output, ?_, hprivate, ?_⟩ + · unfold canonicalizeMaterializedValues publicMaterializedValues at hhidden ⊢ + by_cases hrevealed : Coordinate.position position ∈ context.state.revealed + · simp only [LazyRevealProbe.State.ensure, hrevealed, ↓reduceIte] at hhidden ⊢ + simpa [resolvedCompletionValue, DeferredContext.positionValue] using hhidden + · simp [hrevealed] + · simpa [canonicalizeMaterializedValues, LazyRevealProbe.State.ensure, + LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt] using hhit + +theorem canonicalPrivateClean_publish + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (coordinate : Coordinate) + (hclean : ¬PrivateStructuralHit + (canonicalizeMaterializedValues table context)) : + ¬PrivateStructuralHit + (canonicalizeMaterializedValues table + { context with state := context.state.publish coordinate }) := by + rintro ⟨position, output, hhidden, hprivate, hhit⟩ + apply hclean + refine ⟨position, output, ?_, hprivate, ?_⟩ + · unfold canonicalizeMaterializedValues publicMaterializedValues at hhidden ⊢ + by_cases heq : Coordinate.position position = coordinate + · subst coordinate + change context.values position = some output at hprivate + cases hstate : context.state.values (.position position) <;> + simp [LazyRevealProbe.State.publish, resolvedCompletionValue, + DeferredContext.positionValue, hprivate, hstate] at hhidden + · by_cases hrevealed : Coordinate.position position ∈ context.state.revealed + · simp only [LazyRevealProbe.State.publish, Finset.mem_insert, heq, hrevealed, + ↓reduceIte] at hhidden ⊢ + simpa [resolvedCompletionValue, DeferredContext.positionValue] using hhidden + · simp [hrevealed] + · simpa [canonicalizeMaterializedValues, LazyRevealProbe.State.publish, + LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt] using hhit + +theorem canonicalPrivateClean_materialize + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (coordinate : Coordinate) (materialized : HashOutput) + (values : DeferredStructuralValues) + (hvalues : ∀ position, coordinate ≠ .position position → + values position = context.values position) + (hclean : ¬PrivateStructuralHit + (canonicalizeMaterializedValues table context)) : + ¬PrivateStructuralHit + (canonicalizeMaterializedValues table + { state := context.state.materialize coordinate materialized + values := values }) := by + rintro ⟨position, output, hhidden, hprivate, hhit⟩ + by_cases heq : coordinate = .position position + · subst coordinate + have hfalse := not_hitAt_clearPending_self context.state + (.position position) output + apply hfalse + simpa [canonicalizeMaterializedValues, LazyRevealProbe.State.materialize, + LazyRevealProbe.State.clearPending, LazyRevealProbe.State.hitAt, + LazyRevealProbe.State.pendingAt] using hhit + · apply hclean + have hne : Coordinate.position position ≠ coordinate := fun hsame => heq hsame.symm + refine ⟨position, output, ?_, ?_, ?_⟩ + · change publicMaterializedValues table + { state := context.state.materialize coordinate materialized + values := values } + (.position position) = none at hhidden + change publicMaterializedValues table context (.position position) = none + unfold publicMaterializedValues at hhidden ⊢ + by_cases hrevealed : Coordinate.position position ∈ context.state.revealed + · simp only [LazyRevealProbe.State.materialize, hrevealed, ↓reduceIte] at hhidden ⊢ + unfold resolvedCompletionValue DeferredContext.positionValue at hhidden ⊢ + simpa [LazyRevealProbe.State.materialize, Function.update_of_ne hne, + hvalues position heq] using hhidden + · simp [hrevealed] + · change values position = some output at hprivate + rw [hvalues position heq] at hprivate + exact hprivate + · have hsame := hitAt_clearPending_of_ne context.state coordinate + (.position position) output hne + apply hsame.mp + simpa [canonicalizeMaterializedValues, LazyRevealProbe.State.materialize, + LazyRevealProbe.State.clearPending, LazyRevealProbe.State.hitAt, + LazyRevealProbe.State.pendingAt] using hhit + +theorem privateClean_materialize + (context : DeferredContext) (coordinate : Coordinate) + (materialized : HashOutput) (values : DeferredStructuralValues) + (hvalues : ∀ position, coordinate ≠ .position position → + values position = context.values position) + (hclean : ¬PrivateStructuralHit context) : + ¬PrivateStructuralHit + { state := context.state.materialize coordinate materialized + values := values } := by + rintro ⟨position, output, hhidden, hprivate, hhit⟩ + by_cases heq : coordinate = .position position + · subst coordinate + simp [LazyRevealProbe.State.materialize] at hhidden + · apply hclean + have hne : Coordinate.position position ≠ coordinate := fun hsame => heq hsame.symm + refine ⟨position, output, ?_, ?_, ?_⟩ + · simpa [LazyRevealProbe.State.materialize, Function.update_of_ne hne] using hhidden + · change values position = some output at hprivate + rw [hvalues position heq] at hprivate + exact hprivate + · have hsame := hitAt_clearPending_of_ne context.state coordinate + (.position position) output hne + apply hsame.mp + simpa [LazyRevealProbe.State.materialize, LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt] using hhit + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem canonicalPrivateSafeResult_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) + (hrawClean : ¬PrivateStructuralHit context) + (hclean : ¬PrivateStructuralHit + (canonicalizeMaterializedValues table context)) : + ∀ result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation), + CanonicalPrivateSafeResult table result := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + intro result hresult + simp [runDirectResolvedDetailedFromTable_pure] at hresult + subst result + exact hclean + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases query with + | uniform n => + rw [runDirectResolvedDetailedFromTable_uniform_query_bind] + intro result hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hresult⟩ := hresult + exact ih output context fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + hrawClean hclean result hresult + | hashOutput => + rw [runDirectResolvedDetailedFromTable_hashOutput_query_bind] + intro result hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hresult⟩ := hresult + exact ih output context fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + hrawClean hclean result hresult + | ensure coordinate => + rw [runDirectResolvedDetailedFromTable_ensure_query_bind] + intro result hresult + apply ih () { context with state := context.state.ensure coordinate } fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) + (by simpa [PrivateStructuralHit, LazyRevealProbe.State.ensure, + LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt] using hrawClean) + (canonicalPrivateClean_ensure table context coordinate hclean) + · exact hresult + | probe coordinate candidate => + exfalso + simpa [LazyRevealProbe.IsProbe] using hbound.1 + | peek coordinate => + rw [runDirectResolvedDetailedFromTable_peek_query_bind] + intro result hresult + exact ih (context.state.values coordinate) context fuel + (by simpa [LazyRevealProbe.IsProbe] using + hbound.2 (context.state.values coordinate)) + hrawClean hclean result hresult + | publish coordinate => + rw [runDirectResolvedDetailedFromTable_publish_query_bind] + intro result hresult + apply ih () { context with state := context.state.publish coordinate } fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) + · simpa [PrivateStructuralHit, LazyRevealProbe.State.publish, + LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt] using hrawClean + · exact canonicalPrivateClean_publish table context coordinate hclean + · exact hresult + | reveal coordinate => + rw [runDirectResolvedDetailedFromTable_reveal_query_bind] + cases hstate : context.state.values coordinate with + | some output => + intro result hresult + exact ih output context fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + hrawClean hclean result hresult + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp only [output, hhit, ↓reduceIte] + intro result hresult + simp only [support_pure, Set.mem_singleton_iff] at hresult + subst result + trivial + · simp only [output, hhit, ↓reduceIte] + intro result hresult + apply ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + · apply privateClean_materialize context + (.chainStart lay tree leafIdx chainIdx) output context.values + · intro position _hne + rfl + · exact hrawClean + · apply canonicalPrivateClean_materialize table context + (.chainStart lay tree leafIdx chainIdx) output context.values + · intro position _hne + rfl + · exact hclean + · exact hresult + | position position => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · exact False.elim + (hrawClean ⟨position, output, hstate, hprivate, hhit⟩) + · simp only [hprivate, hhit, ↓reduceIte] + intro result hresult + apply ih output + { state := context.state.materialize (.position position) output + values := context.values } + fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + · apply privateClean_materialize context (.position position) output + context.values + · intro other _hne + rfl + · exact hrawClean + · apply canonicalPrivateClean_materialize table context + (.position position) output context.values + · intro other _hne + rfl + · exact hclean + · exact hresult + | none => + simp only [hprivate] + intro result hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hrest⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp only [hhit, ↓reduceIte, support_pure, + Set.mem_singleton_iff] at hrest + subst result + trivial + · simp only [hhit, ↓reduceIte] at hrest + apply ih output + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + · apply privateClean_materialize context (.position position) output + (context.values.install position output) + · intro other hne + simp [DeferredStructuralValues.install, + Function.update_of_ne (fun heq => hne (congrArg Coordinate.position + heq.symm))] + · exact hrawClean + · apply canonicalPrivateClean_materialize table context + (.position position) output + (context.values.install position output) + · intro other hne + simp [DeferredStructuralValues.install, + Function.update_of_ne (fun heq => hne (congrArg Coordinate.position + heq.symm))] + · exact hclean + · exact hrest + +set_option maxRecDepth 100000 in +theorem remaining_le_fuel_of_mem_support_runRaw_done + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state finalState : LazyRevealProbe.State Coordinate) + (fuel remaining : Nat) (value : α) + (hresult : LazyRevealProbe.RawResult.done finalState remaining value ∈ + support (LazyRevealProbe.runRaw state fuel computation)) : + remaining ≤ fuel := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure result => + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl⟩ + exact le_rfl + | query_bind query next ih => + cases query with + | uniform n => + rw [LazyRevealProbe.runRaw_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output state fuel hrest + | hashOutput => + rw [LazyRevealProbe.runRaw_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output state fuel hrest + | ensure coordinate => + rw [LazyRevealProbe.runRaw_ensure_query_bind] at hresult + exact ih () (state.ensure coordinate) fuel hresult + | probe coordinate candidate => + cases fuel with + | zero => simp [LazyRevealProbe.runRaw_probe_query_bind] at hresult + | succ nextFuel => + rw [LazyRevealProbe.runRaw_probe_query_bind] at hresult + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] at hresult + exact (ih () state nextFuel hresult).trans (Nat.le_succ nextFuel) + · simp only [hrevealed, ↓reduceIte] at hresult + exact (ih () (state.addPending coordinate candidate) nextFuel hresult).trans + (Nat.le_succ nextFuel) + | peek coordinate => + rw [LazyRevealProbe.runRaw_peek_query_bind] at hresult + exact ih (state.values coordinate) state fuel hresult + | publish coordinate => + rw [LazyRevealProbe.runRaw_publish_query_bind] at hresult + exact ih () (state.publish coordinate) fuel hresult + | reveal coordinate => + rw [LazyRevealProbe.runRaw_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + rw [hvalue] at hresult + exact ih output state fuel hresult + | none => + rw [hvalue] at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : state.hitAt coordinate output + · simp [hhit] at hrest + · simp only [hhit, ↓reduceIte] at hrest + exact ih output (state.materialize coordinate output) fuel hrest + +theorem remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation)) : + result.remaining ≤ fuel := by + apply remaining_le_fuel_of_mem_support_runRaw_done computation context.state + result.context.state fuel result.remaining result.value + exact raw_done_of_mem_runDirectResolvedFromTable computation context fuel table result + (mem_support_runDirectResolvedFromTable_of_done_detailed computation context fuel table + result hresult) + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem valid_of_done_runDirectResolvedDetailedFromTable_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) + (hvalid : context.Valid) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation)) : + result.context.Valid := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runDirectResolvedDetailedFromTable_pure] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hvalid + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases query with + | uniform n => + rw [runDirectResolvedDetailedFromTable_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) hvalid hrest + | hashOutput => + rw [runDirectResolvedDetailedFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) hvalid hrest + | ensure coordinate => + rw [runDirectResolvedDetailedFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) + (hvalid.ensure coordinate) hresult + | probe coordinate candidate => + exfalso + simpa [LazyRevealProbe.IsProbe] using hbound.1 + | peek coordinate => + rw [runDirectResolvedDetailedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel + (by simpa [LazyRevealProbe.IsProbe] using + hbound.2 (context.state.values coordinate)) hvalid hresult + | publish coordinate => + rw [runDirectResolvedDetailedFromTable_publish_query_bind] at hresult + exact ih () { context with state := context.state.publish coordinate } fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) + (hvalid.publish coordinate) hresult + | reveal coordinate => + rw [runDirectResolvedDetailedFromTable_reveal_query_bind] at hresult + cases hstate : context.state.values coordinate with + | some output => + rw [hstate] at hresult + exact ih output context fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) hvalid hresult + | none => + rw [hstate] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + exact ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + (hvalid.materialize_chainStart lay tree leafIdx chainIdx output) hresult + | position position => + simp only at hresult + cases hprivate : context.values position with + | some output => + rw [hprivate] at hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresult + · simp only [hhit, ↓reduceIte] at hresult + exact ih output + { state := context.state.materialize (.position position) output + values := context.values } + fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + (hvalid.materialize_position position output hprivate) hresult + | none => + rw [hprivate, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hrest + · simp only [hhit, ↓reduceIte] at hrest + have htemporary : + ({ state := context.state + values := context.values.install position output } : + DeferredContext).Valid := by + constructor + · intro other otherOutput hvalue + by_cases heq : other = position + · subst other + rw [hstate] at hvalue + contradiction + · simpa [DeferredStructuralValues.install, + Function.update_of_ne heq] using + hvalid.1 other otherOutput hvalue + · exact hvalid.2 + have hnextValid : + ({ state := context.state.materialize (.position position) output + values := context.values.install position output } : + DeferredContext).Valid := by + apply htemporary.materialize_position position output + simp [DeferredStructuralValues.install] + exact ih output + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + hnextValid hrest + +theorem DeferredContext.Valid.addPending_of_value_none + {context : DeferredContext} (hvalid : context.Valid) + (coordinate : Coordinate) (candidate : Digest) + (hvalue : context.state.values coordinate = none) : + ({ context with state := context.state.addPending coordinate candidate } : + DeferredContext).Valid := by + constructor + · exact hvalid.1 + · intro other output hother + change context.state.values other = some output at hother + by_cases heq : other = coordinate + · subst other + rw [hvalue] at hother + contradiction + · rw [hitAt_addPending_of_ne context.state coordinate other candidate output (Ne.symm heq)] + exact hvalid.2 other output hother + +set_option maxRecDepth 100000 in +theorem valid_of_done_runDirectResolvedDetailed_probe + (candidate : Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (Unit × SplitHashCache)) + (hvalid : context.Valid) + (hsafe : candidate.coordinate ∈ context.state.revealed ∨ + context.state.values candidate.coordinate = none) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((probe candidate).run cache))) : + result.context.Valid := by + unfold probe at hresult + rw [StateT.run_liftM, LazyRevealProbe.probeQuery, + runDirectResolvedDetailedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte, + runDirectResolvedDetailedFromTable_pure] at hresult + simp only [support_pure, Set.mem_singleton_iff, + DirectDetailedResult.done.injEq] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hvalid + · simp only [hrevealed, ↓reduceIte, + runDirectResolvedDetailedFromTable_pure] at hresult + simp only [support_pure, Set.mem_singleton_iff, + DirectDetailedResult.done.injEq] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hvalid.addPending_of_value_none candidate.coordinate candidate.candidate + (hsafe.resolve_left hrevealed) + +set_option maxRecDepth 100000 in +theorem valid_of_done_runDirectResolvedDetailed_probeFirstMissingInputCoordinate + (input : HashInput) (slot : Nat) (coordinates : List Coordinate) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (Unit × SplitHashCache)) + (hvalid : context.Valid) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((probeFirstMissingInputCoordinate input slot coordinates).run cache))) : + result.context.Valid := by + induction coordinates generalizing slot with + | nil => + simp [probeFirstMissingInputCoordinate, + runDirectResolvedDetailedFromTable_pure] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hvalid + | cons coordinate remaining ih => + rw [runDirectResolvedDetailedFromTable_probeFirstMissingInputCoordinate_cons] at hresult + cases hvalue : context.state.values coordinate with + | none => + rw [hvalue] at hresult + exact valid_of_done_runDirectResolvedDetailed_probe + ⟨coordinate, slotDigest slot input⟩ context fuel table cache result hvalid + (Or.inr hvalue) hresult + | some output => + rw [hvalue] at hresult + exact ih (slot + 1) hresult + +set_option maxRecDepth 100000 in +theorem valid_of_done_runDirectResolvedDetailed_prepareLeafInputProbe + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (Unit × SplitHashCache)) + (hvalid : context.Valid) + (hsafe : candidate.coordinate ∈ context.state.revealed ∨ + context.state.values candidate.coordinate = none) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((prepareLeafInputProbe input candidate lay tree leafIdx).run cache))) : + result.context.Valid := by + rw [runDirectResolvedDetailedFromTable_prepareLeafInputProbe] at hresult + cases hvalue : context.state.values candidate.coordinate with + | none => + rw [hvalue] at hresult + exact valid_of_done_runDirectResolvedDetailed_probe candidate context fuel table cache + result hvalid hsafe hresult + | some output => + rw [hvalue] at hresult + exact valid_of_done_runDirectResolvedDetailed_probeFirstMissingInputCoordinate input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + context fuel table cache result hvalid hresult + +set_option maxRecDepth 100000 in +theorem valid_of_done_runDirectResolvedDetailed_bind_probeFree + (left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (β × SplitHashCache)) + (hleft : ∀ middle : ResolvedRunResult (α × SplitHashCache), + DirectDetailedResult.done middle ∈ support + (runDirectResolvedDetailedFromTable context fuel table (left.run cache)) → + middle.context.Valid) + (hnext : ∀ value, ProbeFree (next value)) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((left >>= next).run cache))) : + result.context.Valid := by + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + mem_support_bind_iff] at hresult + obtain ⟨middleResult, hmiddle, hrest⟩ := hresult + cases middleResult with + | stopped reason => simp at hrest + | done middle => + exact valid_of_done_runDirectResolvedDetailedFromTable_of_probeFree + ((next middle.value.1).run middle.value.2) middle.context middle.remaining + middle.table result (hnext middle.value.1 middle.value.2) + (hleft middle hmiddle) hrest + +theorem probe_safe_of_chainValid + (candidate : Probe) (parameter : PublicParameter) (input : HashInput) + (context : DeferredContext) + (hmatches : candidate.MatchesInput parameter input) + (hchainValid : ChainState.ValidFor (fun _ => True) context.state) : + candidate.coordinate ∈ context.state.revealed ∨ + context.state.values candidate.coordinate = none := by + have hchain := candidate.isChainCoordinate_of_matchesInput hmatches + cases hvalue : context.state.values candidate.coordinate with + | none => exact Or.inr rfl + | some output => + exact Or.inl ((hchainValid candidate.coordinate hchain).1 (by simp [hvalue])) + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem valid_of_done_runDirectResolvedDetailed_probingHashQuery + (parameter : PublicParameter) (input : HashInput) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (HashOutput × SplitHashCache)) + (hvalid : context.Valid) + (hchainValid : ChainState.ValidFor (fun _ => True) context.state) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((probingHashQuery parameter input).run cache))) : + result.context.Valid := by + unfold probingHashQuery at hresult + cases hprobe : decodeProbe? parameter input with + | some candidate => + rw [hprobe] at hresult + have hmatches := (decodeProbe?_eq_some_iff parameter input candidate).1 hprobe + have hsafe := probe_safe_of_chainValid candidate parameter input context hmatches + hchainValid + cases hposition : decodePosition? parameter input with + | none => + rw [hposition] at hresult + apply valid_of_done_runDirectResolvedDetailed_bind_probeFree + (left := probe candidate) + (next := fun _ => resolveKnownInput parameter candidate.outputCoordinate input) + context fuel table cache result + · intro middle hmiddle + exact valid_of_done_runDirectResolvedDetailed_probe candidate context fuel table + cache middle hvalid hsafe hmiddle + · intro _ + exact resolveKnownInput_probeFree parameter candidate.outputCoordinate input + · exact hresult + | some position => + rw [hposition] at hresult + cases position with + | leaf lay tree leafIdx => + apply valid_of_done_runDirectResolvedDetailed_bind_probeFree + (left := prepareLeafInputProbe input candidate lay tree leafIdx) + (next := fun _ => resolveKnownInput parameter candidate.outputCoordinate input) + context fuel table cache result + · intro middle hmiddle + exact valid_of_done_runDirectResolvedDetailed_prepareLeafInputProbe input + candidate lay tree leafIdx context fuel table cache middle hvalid hsafe hmiddle + · intro _ + exact resolveKnownInput_probeFree parameter candidate.outputCoordinate input + · exact hresult + | chain lay tree leafIdx chainIdx step => + apply valid_of_done_runDirectResolvedDetailed_bind_probeFree + (left := probe candidate) + (next := fun _ => resolveKnownInput parameter candidate.outputCoordinate input) + context fuel table cache result + · intro middle hmiddle + exact valid_of_done_runDirectResolvedDetailed_probe candidate context fuel table + cache middle hvalid hsafe hmiddle + · intro _ + exact resolveKnownInput_probeFree parameter candidate.outputCoordinate input + · exact hresult + | node lay tree level nodeIdx => + apply valid_of_done_runDirectResolvedDetailed_bind_probeFree + (left := probe candidate) + (next := fun _ => resolveKnownInput parameter candidate.outputCoordinate input) + context fuel table cache result + · intro middle hmiddle + exact valid_of_done_runDirectResolvedDetailed_probe candidate context fuel table + cache middle hvalid hsafe hmiddle + · intro _ + exact resolveKnownInput_probeFree parameter candidate.outputCoordinate input + · exact hresult + | ftsLeaf index tree leafIdx => + apply valid_of_done_runDirectResolvedDetailed_bind_probeFree + (left := probe candidate) + (next := fun _ => resolveKnownInput parameter candidate.outputCoordinate input) + context fuel table cache result + · intro middle hmiddle + exact valid_of_done_runDirectResolvedDetailed_probe candidate context fuel table + cache middle hvalid hsafe hmiddle + · intro _ + exact resolveKnownInput_probeFree parameter candidate.outputCoordinate input + · exact hresult + | ftsNode index tree level nodeIdx => + apply valid_of_done_runDirectResolvedDetailed_bind_probeFree + (left := probe candidate) + (next := fun _ => resolveKnownInput parameter candidate.outputCoordinate input) + context fuel table cache result + · intro middle hmiddle + exact valid_of_done_runDirectResolvedDetailed_probe candidate context fuel table + cache middle hvalid hsafe hmiddle + · intro _ + exact resolveKnownInput_probeFree parameter candidate.outputCoordinate input + · exact hresult + | ftsRoots index => + apply valid_of_done_runDirectResolvedDetailed_bind_probeFree + (left := probe candidate) + (next := fun _ => resolveKnownInput parameter candidate.outputCoordinate input) + context fuel table cache result + · intro middle hmiddle + exact valid_of_done_runDirectResolvedDetailed_probe candidate context fuel table + cache middle hvalid hsafe hmiddle + · intro _ + exact resolveKnownInput_probeFree parameter candidate.outputCoordinate input + · exact hresult + | none => + rw [hprobe] at hresult + cases hposition : decodePosition? parameter input with + | none => + rw [hposition] at hresult + exact valid_of_done_runDirectResolvedDetailedFromTable_of_probeFree + ((splitHashQuery (.ordinary input)).run cache) context fuel table result + (splitHashQuery_probeFree (.ordinary input) cache) hvalid hresult + | some position => + rw [hposition] at hresult + cases position with + | chain lay tree leafIdx chainIdx step => + exact valid_of_done_runDirectResolvedDetailedFromTable_of_probeFree + ((resolveKnownInput parameter + (.position (.chain lay tree leafIdx chainIdx step)) input).run cache) + context fuel table result + (resolveKnownInput_probeFree parameter + (.position (.chain lay tree leafIdx chainIdx step)) input cache) + hvalid hresult + | leaf lay tree leafIdx => + exact valid_of_done_runDirectResolvedDetailedFromTable_of_probeFree + ((resolveKnownInput parameter (.position (.leaf lay tree leafIdx)) input).run + cache) + context fuel table result + (resolveKnownInput_probeFree parameter (.position (.leaf lay tree leafIdx)) + input cache) + hvalid hresult + | node lay tree level nodeIdx => + apply valid_of_done_runDirectResolvedDetailed_bind_probeFree + (left := probeFirstMissingInputCoordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)) + (next := fun _ => + resolveKnownInput parameter (.position (.node lay tree level nodeIdx)) input) + context fuel table cache result + · intro middle hmiddle + exact valid_of_done_runDirectResolvedDetailed_probeFirstMissingInputCoordinate + input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position) + context fuel table cache middle hvalid hmiddle + · intro _ + exact resolveKnownInput_probeFree parameter + (.position (.node lay tree level nodeIdx)) input + · exact hresult + | ftsLeaf index tree leafIdx => + exact valid_of_done_runDirectResolvedDetailedFromTable_of_probeFree + ((splitHashQuery (.ordinary input)).run cache) context fuel table result + (splitHashQuery_probeFree (.ordinary input) cache) hvalid hresult + | ftsNode index tree level nodeIdx => + exact valid_of_done_runDirectResolvedDetailedFromTable_of_probeFree + ((splitHashQuery (.ordinary input)).run cache) context fuel table result + (splitHashQuery_probeFree (.ordinary input) cache) hvalid hresult + | ftsRoots index => + exact valid_of_done_runDirectResolvedDetailedFromTable_of_probeFree + ((splitHashQuery (.ordinary input)).run cache) context fuel table result + (splitHashQuery_probeFree (.ordinary input) cache) hvalid hresult + +theorem not_privateStructuralHit_canonicalize_of_direct_valid + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hdirect : context = directDeferredContext context.state) + (hvalid : context.Valid) : + ¬PrivateStructuralHit (canonicalizeMaterializedValues table context) := by + rintro ⟨position, output, _hhidden, hprivate, hhit⟩ + have hstate : context.state.values (.position position) = some output := by + have hsame : context.values position = + context.state.values (.position position) := by + rw [hdirect] + rfl + change context.values position = some output at hprivate + rw [hsame] at hprivate + exact hprivate + apply hvalid.2 (.position position) output hstate + simpa [canonicalizeMaterializedValues, LazyRevealProbe.State.hitAt, + LazyRevealProbe.State.pendingAt] using hhit + +set_option maxRecDepth 100000 in +theorem direct_valid_chain_of_done_maskedExpandedAdversaryImpl + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult + ((OracleWorld + SigningSpec).Range query × SplitHashCache)) + (hdirect : context = directDeferredContext context.state) + (hvalid : context.Valid) + (hchainValid : ChainState.ValidFor (fun _ => True) context.state) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run cache))) : + result.context = directDeferredContext result.context.state ∧ + result.context.Valid ∧ + ChainState.ValidFor (fun _ => True) result.context.state := by + have hoption := mem_support_runDirectResolvedFromTable_of_done_detailed + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run cache) + context fuel table result hresult + have hresultDirect : result.context = directDeferredContext result.context.state := by + have hshape := directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run cache) + context.state fuel table (.done result) (by + rw [← hdirect] + exact hresult) + exact hshape + have hresultValid : result.context.Valid := by + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + exact valid_of_done_runDirectResolvedDetailedFromTable_of_probeFree + ((maskedExpandedAdversaryImpl parameter root ftsSecret (.inl (.inl n))).run cache) + context fuel table result + (by + simpa [maskedExpandedAdversaryImpl, probingRomImpl] using + splitUniformImpl_probeFree n cache) + hvalid hresult + | inr input => + change ResolvedRunResult (HashOutput × SplitHashCache) at result + change DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((probingHashQuery parameter input).run cache)) at hresult + exact valid_of_done_runDirectResolvedDetailed_probingHashQuery parameter input + context fuel table cache result hvalid hchainValid hresult + | inr message => + exact valid_of_done_runDirectResolvedDetailedFromTable_of_probeFree + ((maskedExpandedAdversaryImpl parameter root ftsSecret (.inr message)).run cache) + context fuel table result + (by + simpa [maskedExpandedAdversaryImpl, maskedSigningImpl] using + maskedSign_probeFree parameter root ftsSecret message cache) + hvalid hresult + have hresultChain : ChainState.ValidFor (fun _ => True) result.context.state := by + apply chainValid_of_mem_runDirectResolvedFromTable (fun _ => True) + (maskedExpandedAdversaryImpl parameter root ftsSecret query) + context fuel table cache result + ((preservesChainValidImpl_maskedExpandedAdversaryImpl_true parameter root ftsSecret) query) + hchainValid hoption + exact ⟨hresultDirect, hresultValid, hresultChain⟩ + +set_option maxRecDepth 100000 in +theorem probEvent_materializedPrivateStep_le + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (nextObserve : DeferredContext → Nat → + ((OracleWorld + SigningSpec).Range query × SplitHashCache) → ProbComp Bool) + (epsilon terminalBound : ℝ≥0∞) + (hdirect : context = directDeferredContext context.state) + (hvalid : context.Valid) + (hchainValid : ChainState.ValidFor (fun _ => True) context.state) + (hcontinuation : ∀ result : ResolvedRunResult + ((OracleWorld + SigningSpec).Range query × SplitHashCache), + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run cache)) → + result.context = directDeferredContext result.context.state → + result.context.Valid → + ChainState.ValidFor (fun _ => True) result.context.state → + DeferredCompletable table result.context → + Pr[= true | nextObserve result.context result.remaining result.value] ≤ + (result.remaining : ℝ≥0∞) * epsilon + terminalBound) : + Pr[= true | + runDirectDetailedPrivateObserve + (classifyCanonicalMaterializedPrivateObserve table nextObserve) + context fuel table + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run cache)] ≤ + (fuel : ℝ≥0∞) * epsilon + terminalBound := by + rw [← probEvent_eq_eq_probOutput] + unfold runDirectDetailedPrivateObserve + apply probEvent_bind_le_of_forall_le + intro detailedResult hdetailed + have hshape := directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run cache) + context.state fuel table detailedResult (by + rw [← hdirect] + exact hdetailed) + cases detailedResult with + | stopped reason => + cases reason with + | privateStructuralHit => exact False.elim hshape + | ordinaryHit => simp [finishDirectDetailedPrivateObserve] + | fuelExhausted => simp [finishDirectDetailedPrivateObserve] + | done result => + have hinvariants := direct_valid_chain_of_done_maskedExpandedAdversaryImpl + parameter root ftsSecret query context fuel table cache result hdirect hvalid + hchainValid hdetailed + have hclean := not_privateStructuralHit_canonicalize_of_direct_valid table + result.context hinvariants.1 hinvariants.2.1 + simp only [finishDirectDetailedPrivateObserve] + unfold classifyCanonicalMaterializedPrivateObserve + simp only [hclean, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table result.context + · simp only [hcompletable, ↓reduceIte] + have hnext := hcontinuation result hdetailed hinvariants.1 hinvariants.2.1 + hinvariants.2.2 hcompletable + rw [← probEvent_eq_eq_probOutput] at hnext + refine hnext.trans ?_ + gcongr + exact_mod_cast + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run cache) + context fuel table result hdetailed + · simp [hcompletable] + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem probEvent_directDetailedBoundaryCanonicalMaterializedPrivateObserve_false_le_zero + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hdirect : context = directDeferredContext context.state) + (hvalid : context.Valid) + (hchainValid : ChainState.ValidFor (fun _ => True) context.state) : + Pr[= true | + directDetailedBoundaryCanonicalMaterializedPrivateObserve + (maskedExpandedAdversaryImpl parameter root ftsSecret) computation + (fun _ _ _ => pure false) context fuel table cache] ≤ + (fuel : ℝ≥0∞) * 0 + 0 := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + simp [directDetailedBoundaryCanonicalMaterializedPrivateObserve] + | query_bind query next ih => + rw [directDetailedBoundaryCanonicalMaterializedPrivateObserve, + OracleComp.construct_query_bind] + apply probEvent_materializedPrivateStep_le parameter root ftsSecret query context fuel + table cache (epsilon := 0) (terminalBound := 0) + · exact hdirect + · exact hvalid + · exact hchainValid + · intro result hresult hresultDirect hresultValid hresultChain hcompletable + exact ih result.value.1 result.context result.remaining result.value.2 + hresultDirect hresultValid hresultChain + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem probEvent_runDirectDetailedPrivateObserve_probeFree_le_zero + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hprobeFree : ProbeFree computation) + (hpreservesChain : PreservesChainValid (fun _ => True) computation) + (hdirect : context = directDeferredContext context.state) + (hvalid : context.Valid) + (hchainValid : ChainState.ValidFor (fun _ => True) context.state) + (hobserve : ∀ result : ResolvedRunResult (α × SplitHashCache), + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table (computation.run cache)) → + result.context = directDeferredContext result.context.state → + result.context.Valid → + ChainState.ValidFor (fun _ => True) result.context.state → + Pr[= true | observe result.context result.remaining result.value] ≤ 0) : + Pr[= true | + runDirectDetailedPrivateObserve observe context fuel table (computation.run cache)] ≤ 0 := by + rw [← probEvent_eq_eq_probOutput] + unfold runDirectDetailedPrivateObserve + apply probEvent_bind_le_of_forall_le + intro detailedResult hdetailed + have hshape := directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + (computation.run cache) context.state fuel table detailedResult (by + rw [← hdirect] + exact hdetailed) + cases detailedResult with + | stopped reason => + cases reason with + | privateStructuralHit => exact False.elim hshape + | ordinaryHit => simp [finishDirectDetailedPrivateObserve] + | fuelExhausted => simp [finishDirectDetailedPrivateObserve] + | done result => + have hoption := mem_support_runDirectResolvedFromTable_of_done_detailed + (computation.run cache) context fuel table result hdetailed + have hresultValid := + valid_of_done_runDirectResolvedDetailedFromTable_of_probeFree + (computation.run cache) context fuel table result (hprobeFree cache) hvalid hdetailed + have hresultChain := chainValid_of_mem_runDirectResolvedFromTable + (fun _ => True) computation context fuel table cache result hpreservesChain + hchainValid hoption + simp only [finishDirectDetailedPrivateObserve] + have hnext := hobserve result hdetailed hshape hresultValid hresultChain + rwa [← probEvent_eq_eq_probOutput] at hnext + +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem probEvent_materializedCanonicalPrivateRetained_le_zero + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[= true | + materializedCanonicalPrivateRetained adversary parameter table ftsSecret fuel] ≤ 0 := by + change Pr[= true | + runDirectDetailedPrivateObserve + (materializedCanonicalPrivateRetainedRestObserve adversary parameter table ftsSecret) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)] ≤ 0 + apply probEvent_runDirectDetailedPrivateObserve_probeFree_le_zero + maskedPublishedTreeRoot + (materializedCanonicalPrivateRetainedRestObserve adversary parameter table ftsSecret) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + fuel table emptySplitHashCache + · exact maskedPublishedTreeRoot_probeFree + · exact preservesChainValid_maskedPublishedTreeRoot_true + · rfl + · exact DeferredContext.valid_empty + · exact ChainState.validFor_empty (fun _ => True) + · intro result hresult hresultDirect hresultValid hresultChain + unfold materializedCanonicalPrivateRetainedRestObserve + simpa using + (probEvent_directDetailedBoundaryCanonicalMaterializedPrivateObserve_false_le_zero + parameter result.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining table result.value.2 hresultDirect hresultValid + hresultChain) + +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledMaterializedCanonicalPrivateRetained_le + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) : + Pr[= true | + sampledMaterializedCanonicalPrivateRetained adversary parameter ftsSecret q] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + unfold sampledMaterializedCanonicalPrivateRetained + rw [← probEvent_eq_eq_probOutput] + have hzero : Pr[fun hit : Bool => hit = true | do + let table ← sampleOtsHashTable + materializedCanonicalPrivateRetained adversary parameter table ftsSecret q] ≤ 0 := by + apply probEvent_bind_le_of_forall_le + intro table _htable + rw [probEvent_eq_eq_probOutput] + exact probEvent_materializedCanonicalPrivateRetained_le_zero + adversary parameter table ftsSecret q + exact hzero.trans (by positivity) + +set_option maxRecDepth 100000 in +theorem probEvent_materializedPrivateStep_signing_le + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (nextObserve : DeferredContext → Nat → + (Option Signature × SplitHashCache) → ProbComp Bool) + (epsilon terminalBound : ℝ≥0∞) + (hclean : ¬PrivateStructuralHit + (canonicalizeMaterializedValues table context)) + (hcompletable : DeferredCompletable table context) + (hcontinuation : ∀ result : ResolvedRunResult + (Option Signature × SplitHashCache), + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((maskedExpandedAdversaryImpl parameter root ftsSecret + (.inr message)).run cache)) → + ¬PrivateStructuralHit + (canonicalizeMaterializedValues table result.context) → + DeferredCompletable table result.context → + Pr[= true | nextObserve result.context result.remaining result.value] ≤ + (result.remaining : ℝ≥0∞) * epsilon + terminalBound) : + Pr[= true | + runDirectDetailedPrivateObserve + (classifyCanonicalMaterializedPrivateObserve table nextObserve) + context fuel table + ((maskedExpandedAdversaryImpl parameter root ftsSecret + (.inr message)).run cache)] ≤ + (fuel : ℝ≥0∞) * epsilon + terminalBound := by + have hprobeFree : + (((maskedExpandedAdversaryImpl parameter root ftsSecret + (.inr message)).run cache).IsQueryBoundP + LazyRevealProbe.IsProbe 0) := by + simpa [maskedExpandedAdversaryImpl, maskedSigningImpl] using + maskedSign_probeFree parameter root ftsSecret message cache + have hrawClean : ¬PrivateStructuralHit context := + not_privateStructuralHit_of_deferredCompletable hcompletable + rw [← probEvent_eq_eq_probOutput] + unfold runDirectDetailedPrivateObserve + apply probEvent_bind_le_of_forall_le + intro result hresult + have hsafe := canonicalPrivateSafeResult_of_probeFree + ((maskedExpandedAdversaryImpl parameter root ftsSecret (.inr message)).run cache) + context fuel table hprobeFree hrawClean hclean result hresult + cases result with + | stopped reason => + cases reason with + | privateStructuralHit => exact False.elim hsafe + | ordinaryHit => simp [finishDirectDetailedPrivateObserve] + | fuelExhausted => simp [finishDirectDetailedPrivateObserve] + | done result => + simp only [CanonicalPrivateSafeResult] at hsafe + simp only [finishDirectDetailedPrivateObserve] + unfold classifyCanonicalMaterializedPrivateObserve + simp only [hsafe, ↓reduceIte] + by_cases hnextCompletable : DeferredCompletable table result.context + · simp only [hnextCompletable, ↓reduceIte] + have hnext := hcontinuation result hresult hsafe hnextCompletable + rw [← probEvent_eq_eq_probOutput] at hnext + refine hnext.trans ?_ + gcongr + exact_mod_cast + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((maskedExpandedAdversaryImpl parameter root ftsSecret + (.inr message)).run cache) + context fuel table result hresult + · simp [hnextCompletable] + +set_option maxRecDepth 100000 in +theorem probEvent_granularPrivateStep_signing_le + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (nextObserve : DeferredContext → Nat → + (Option Signature × SplitHashCache) → ProbComp Bool) + (epsilon terminalBound : ℝ≥0∞) + (hclean : ¬PrivateStructuralHit + (canonicalizeMaterializedValues table context)) + (hcompletable : DeferredCompletable table context) + (hcontinuation : ∀ result : ResolvedRunResult + (Option Signature × SplitHashCache), + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((maskedExpandedAdversaryImpl parameter root ftsSecret + (.inr message)).run cache)) → + PublishedValues result.context.state → + DeferredCompletable table + (canonicalizeMaterializedValues table result.context) → + Pr[= true | + nextObserve (canonicalizeMaterializedValues table result.context) + result.remaining result.value] ≤ + (result.remaining : ℝ≥0∞) * epsilon + terminalBound) : + Pr[= true | + runDirectDetailedPrivateObserve + (canonicalizeDirectDetailedPrivateObserve table nextObserve) + context fuel table + ((maskedExpandedAdversaryImpl parameter root ftsSecret + (.inr message)).run cache)] ≤ + (fuel : ℝ≥0∞) * epsilon + terminalBound := by + have hprobeFree : + (((maskedExpandedAdversaryImpl parameter root ftsSecret + (.inr message)).run cache).IsQueryBoundP + LazyRevealProbe.IsProbe 0) := by + simpa [maskedExpandedAdversaryImpl, maskedSigningImpl] using + maskedSign_probeFree parameter root ftsSecret message cache + have hrawClean : ¬PrivateStructuralHit context := + not_privateStructuralHit_of_deferredCompletable hcompletable + rw [← probEvent_eq_eq_probOutput] + unfold runDirectDetailedPrivateObserve + apply probEvent_bind_le_of_forall_le + intro result hresult + have hsafe := canonicalPrivateSafeResult_of_probeFree + ((maskedExpandedAdversaryImpl parameter root ftsSecret (.inr message)).run cache) + context fuel table hprobeFree hrawClean hclean result hresult + cases result with + | stopped reason => + cases reason with + | privateStructuralHit => exact False.elim hsafe + | ordinaryHit => simp [finishDirectDetailedPrivateObserve] + | fuelExhausted => simp [finishDirectDetailedPrivateObserve] + | done result => + simp only [CanonicalPrivateSafeResult] at hsafe + simp only [finishDirectDetailedPrivateObserve] + unfold canonicalizeDirectDetailedPrivateObserve + simp only [hsafe, ↓reduceIte] + by_cases hpublished : PublishedValues result.context.state + · simp only [hpublished, ↓reduceIte] + unfold classifyDirectDetailedPrivateObserve + simp only [hsafe, ↓reduceIte] + by_cases hnextCompletable : DeferredCompletable table + (canonicalizeMaterializedValues table result.context) + · simp only [hnextCompletable, ↓reduceIte] + have hnext := hcontinuation result hresult hpublished hnextCompletable + rw [← probEvent_eq_eq_probOutput] at hnext + refine hnext.trans ?_ + gcongr + exact_mod_cast + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((maskedExpandedAdversaryImpl parameter root ftsSecret + (.inr message)).run cache) + context fuel table result hresult + · simp [hnextCompletable] + · simp [hpublished] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateTrace.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateTrace.lean new file mode 100644 index 00000000..12d7ad0b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateTrace.lean @@ -0,0 +1,461 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePlannedCommute + +/-! +# Planned-probe hash trace + +The proof-only hash handler returns the planned candidate beside the ordinary hash output. Projecting the first component recovers the concrete probing handler branch by branch. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +noncomputable def plannedProbingHashQuery (parameter : PublicParameter) (input : HashInput) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (HashOutput × Option Probe) := + match decodeProbe? parameter input with + | some candidate => + match decodePosition? parameter input with + | some (.leaf lay tree leafIdx) => do + let planned ← planLeafInputProbe input candidate lay tree leafIdx + executeCandidate? planned + let output ← resolveKnownInput parameter candidate.outputCoordinate input + pure (output, planned) + | _ => do + probe candidate + let output ← resolveKnownInput parameter candidate.outputCoordinate input + pure (output, some candidate) + | none => + match decodePosition? parameter input with + | some position@(.chain _ _ _ _ _) => do + let output ← resolveKnownInput parameter (.position position) input + pure (output, none) + | some position@(.leaf _ _ _) => do + let output ← resolveKnownInput parameter (.position position) input + pure (output, none) + | some position@(.node _ _ _ _) => do + let planned ← planFirstMissingInputCoordinate input 0 + (position.children.map Coordinate.position) + executeCandidate? planned + let output ← resolveKnownInput parameter (.position position) input + pure (output, planned) + | _ => do + let output ← splitHashQuery (.ordinary input) + pure (output, none) + +set_option maxRecDepth 100000 in +theorem plannedProbingHashQuery_fst_leaf + (parameter : PublicParameter) (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (hprobe : decodeProbe? parameter input = some candidate) + (hposition : decodePosition? parameter input = some (.leaf lay tree leafIdx)) : + Prod.fst <$> plannedProbingHashQuery parameter input = probingHashQuery parameter input := by + unfold plannedProbingHashQuery probingHashQuery + rw [hprobe, hposition] + simp only [map_eq_bind_pure_comp, bind_assoc, pure_bind, Function.comp_apply] + rw [← bind_assoc, planLeafInputProbe_execute] + simp + +set_option maxRecDepth 100000 in +theorem plannedProbingHashQuery_fst_node + (parameter : PublicParameter) (input : HashInput) + (lay : Layer) (tree : TreeIndex) (level : Fin maxLayerHeight) + (nodeIdx : LeafIndex) + (hprobe : decodeProbe? parameter input = none) + (hposition : decodePosition? parameter input = some (.node lay tree level nodeIdx)) : + Prod.fst <$> plannedProbingHashQuery parameter input = probingHashQuery parameter input := by + unfold plannedProbingHashQuery probingHashQuery + rw [hprobe, hposition] + simp only [map_eq_bind_pure_comp, bind_assoc, pure_bind, Function.comp_apply] + rw [← bind_assoc, planFirstMissingInputCoordinate_execute] + simp + +set_option maxRecDepth 100000 in +theorem plannedProbingHashQuery_fst_of_decodeProbe_some_nonleaf + (parameter : PublicParameter) (input : HashInput) (candidate : Probe) + (hprobe : decodeProbe? parameter input = some candidate) + (hposition : ¬∃ lay tree leafIdx, + decodePosition? parameter input = some (.leaf lay tree leafIdx)) : + Prod.fst <$> plannedProbingHashQuery parameter input = probingHashQuery parameter input := by + unfold plannedProbingHashQuery probingHashQuery + rw [hprobe] + cases hdecoded : decodePosition? parameter input with + | none => simp + | some position => + cases position with + | leaf lay tree leafIdx => exact False.elim (hposition ⟨lay, tree, leafIdx, hdecoded⟩) + | chain | node | ftsLeaf | ftsNode | ftsRoots => simp + +set_option maxRecDepth 100000 in +theorem plannedProbingHashQuery_fst_of_decodeProbe_none_nonnode + (parameter : PublicParameter) (input : HashInput) + (hprobe : decodeProbe? parameter input = none) + (hposition : ¬∃ lay tree level nodeIdx, + decodePosition? parameter input = some (.node lay tree level nodeIdx)) : + Prod.fst <$> plannedProbingHashQuery parameter input = probingHashQuery parameter input := by + unfold plannedProbingHashQuery probingHashQuery + rw [hprobe] + cases hdecoded : decodePosition? parameter input with + | none => simp + | some position => + cases position with + | node lay tree level nodeIdx => + exact False.elim (hposition ⟨lay, tree, level, nodeIdx, hdecoded⟩) + | chain | leaf | ftsLeaf | ftsNode | ftsRoots => simp + +noncomputable def plannedMaskedExpandedAdversaryImpl + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) + ((OracleWorld + SigningSpec).Range query × Option Probe) := by + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + exact do + let output ← splitUniformImpl n + pure (output, none) + | inr input => exact plannedProbingHashQuery parameter input + | inr message => + exact do + let output ← maskedSign parameter root ftsSecret message + pure (output, none) + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem plannedMaskedExpandedAdversaryImpl_fst + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) : + Prod.fst <$> plannedMaskedExpandedAdversaryImpl parameter root ftsSecret query = + maskedExpandedAdversaryImpl parameter root ftsSecret query := by + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + simp [plannedMaskedExpandedAdversaryImpl, maskedExpandedAdversaryImpl, + probingRomImpl] + | inr input => + change Prod.fst <$> plannedProbingHashQuery parameter input = + probingHashQuery parameter input + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases hposition : decodePosition? parameter input with + | none => + exact plannedProbingHashQuery_fst_of_decodeProbe_some_nonleaf parameter input + candidate hprobe (by + rintro ⟨lay, tree, leafIdx, heq⟩ + simp [hposition] at heq) + | some position => + cases position with + | leaf lay tree leafIdx => + exact plannedProbingHashQuery_fst_leaf parameter input candidate lay tree + leafIdx hprobe hposition + | chain | node | ftsLeaf | ftsNode | ftsRoots => + exact plannedProbingHashQuery_fst_of_decodeProbe_some_nonleaf parameter + input candidate hprobe (by + rintro ⟨lay, tree, leafIdx, heq⟩ + simp [hposition] at heq) + | none => + cases hposition : decodePosition? parameter input with + | none => + exact plannedProbingHashQuery_fst_of_decodeProbe_none_nonnode parameter input + hprobe (by + rintro ⟨lay, tree, level, nodeIdx, heq⟩ + simp [hposition] at heq) + | some position => + cases position with + | node lay tree level nodeIdx => + exact plannedProbingHashQuery_fst_node parameter input lay tree level + nodeIdx hprobe hposition + | chain | leaf | ftsLeaf | ftsNode | ftsRoots => + exact plannedProbingHashQuery_fst_of_decodeProbe_none_nonnode parameter + input hprobe (by + rintro ⟨lay, tree, level, nodeIdx, heq⟩ + simp [hposition] at heq) + | inr message => + simp [plannedMaskedExpandedAdversaryImpl, maskedExpandedAdversaryImpl, + maskedSigningImpl] + +def appendPlannedCandidate (candidates : List Probe) : Option Probe → List Probe + | none => candidates + | some candidate => candidates ++ [candidate] + +noncomputable def finishDirectDetailedPrivatePlanObserve + (observe : DeferredContext → Nat → α → List Probe → ProbComp (Bool × List Probe)) + (candidates : List Probe) : DirectDetailedResult α → ProbComp (Bool × List Probe) + | .stopped .privateStructuralHit => pure (true, candidates) + | .stopped _ => pure (false, candidates) + | .done result => observe result.context result.remaining result.value candidates + +noncomputable def classifyDirectDetailedPrivatePlanObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → ProbComp (Bool × List Probe)) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) : + ProbComp (Bool × List Probe) := by + classical + exact if PrivateStructuralHit context then + pure (true, candidates) + else if DeferredCompletable table context then + observe context fuel value candidates + else + pure (false, candidates) + +noncomputable def canonicalizeDirectDetailedPrivatePlanObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → ProbComp (Bool × List Probe)) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) : + ProbComp (Bool × List Probe) := by + classical + exact if PrivateStructuralHit (canonicalizeMaterializedValues table context) then + pure (true, candidates) + else if PublishedValues context.state then + classifyDirectDetailedPrivatePlanObserve table observe + (canonicalizeMaterializedValues table context) fuel value candidates + else + pure (false, candidates) + +noncomputable def runDirectDetailedPrivatePlanObserve + (observe : DeferredContext → Nat → α → List Probe → ProbComp (Bool × List Probe)) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + ProbComp (Bool × List Probe) := + runDirectResolvedDetailedFromTable context fuel table computation >>= + finishDirectDetailedPrivatePlanObserve observe candidates + +noncomputable def directDetailedBoundaryPrivatePlanObserve + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (planner : (query : spec.Domain) → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Probe)) + (computation : OracleComp spec α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp (Bool × List Probe)) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Bool × List Probe) := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp spec α => + (DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp (Bool × List Probe)) → + List Probe → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → + SplitHashCache → ProbComp (Bool × List Probe)) + (fun value observe candidates context fuel _table cache => + observe context fuel (value, cache) candidates) + (fun query _next recursivelyRun observe candidates context fuel table cache => + runDirectResolvedDetailedFromTable context fuel table ((planner query).run cache) >>= + fun plannedResult => + match plannedResult with + | .stopped _ => pure (false, candidates) + | .done plannedResult => + let nextCandidates := appendPlannedCandidate candidates plannedResult.value.1 + runDirectDetailedPrivatePlanObserve + (canonicalizeDirectDetailedPrivatePlanObserve table + (fun nextContext remaining value nextCandidates => + recursivelyRun value.1 observe nextCandidates nextContext remaining table + value.2)) + nextCandidates plannedResult.context plannedResult.remaining table + ((impl query).run plannedResult.value.2)) + computation observe candidates context fuel table cache + +noncomputable def maskedExpandedAdversaryPlanner + (parameter : PublicParameter) (_root : Digest) + (_ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Probe) := by + cases query with + | inl worldQuery => + cases worldQuery with + | inl _ => exact pure none + | inr input => + exact match decodeProbe? parameter input with + | some candidate => + match decodePosition? parameter input with + | some (.leaf lay tree leafIdx) => + planLeafInputProbe input candidate lay tree leafIdx + | _ => pure (some candidate) + | none => + match decodePosition? parameter input with + | some position@(.node _ _ _ _) => + planFirstMissingInputCoordinate input 0 + (position.children.map Coordinate.position) + | _ => pure none + | inr _ => exact pure none + +noncomputable def retainedResolvedFinalizationPrivatePlanObserve + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) (candidates : List Probe) : + ProbComp (Bool × List Probe) := do + let hit ← retainedResolvedFinalizationPrivateObserve table root context fuel value + pure (hit, candidates) + +noncomputable def granularDetailedRetainedRestPrivatePlanObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) : + ProbComp (Bool × List Probe) := + directDetailedBoundaryPrivatePlanObserve + (maskedExpandedAdversaryImpl parameter value.1 ftsSecret) + (maskedExpandedAdversaryPlanner parameter value.1 ftsSecret) + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivatePlanObserve table value.1) + candidates context fuel table value.2 + +noncomputable def granularAllDirectBoundaryDetailedRetainedPrivatePlan + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp (Bool × List Probe) := + runDirectDetailedPrivatePlanObserve + (granularDetailedRetainedRestPrivatePlanObserve adversary parameter table ftsSecret) + [] + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +theorem evalDist_fst_finishDirectDetailedPrivatePlanObserve + (observe : DeferredContext → Nat → α → List Probe → ProbComp (Bool × List Probe)) + (boolObserve : DeferredContext → Nat → α → ProbComp Bool) + (candidates : List Probe) (result : DirectDetailedResult α) + (hproject : ∀ context fuel value candidates, + evalDist (Prod.fst <$> observe context fuel value candidates) = + evalDist (boolObserve context fuel value)) : + evalDist (Prod.fst <$> + finishDirectDetailedPrivatePlanObserve observe candidates result) = + evalDist (finishDirectDetailedPrivateObserve boolObserve result) := by + cases result with + | stopped reason => cases reason <;> rfl + | done result => exact hproject result.context result.remaining result.value candidates + +set_option maxRecDepth 100000 in +theorem evalDist_fst_runDirectDetailedPrivatePlanObserve + (observe : DeferredContext → Nat → α → List Probe → ProbComp (Bool × List Probe)) + (boolObserve : DeferredContext → Nat → α → ProbComp Bool) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hproject : ∀ nextContext remaining value nextCandidates, + evalDist (Prod.fst <$> observe nextContext remaining value nextCandidates) = + evalDist (boolObserve nextContext remaining value)) : + evalDist (Prod.fst <$> + runDirectDetailedPrivatePlanObserve observe candidates context fuel table computation) = + evalDist (runDirectDetailedPrivateObserve boolObserve context fuel table computation) := by + unfold runDirectDetailedPrivatePlanObserve runDirectDetailedPrivateObserve + rw [map_bind] + apply evalDist_bind_congr + intro result _hresult + exact evalDist_fst_finishDirectDetailedPrivatePlanObserve observe boolObserve candidates result + hproject + +theorem evalDist_fst_classifyDirectDetailedPrivatePlanObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → ProbComp (Bool × List Probe)) + (boolObserve : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hproject : ∀ nextContext remaining nextValue nextCandidates, + evalDist (Prod.fst <$> observe nextContext remaining nextValue nextCandidates) = + evalDist (boolObserve nextContext remaining nextValue)) : + evalDist (Prod.fst <$> + classifyDirectDetailedPrivatePlanObserve table observe context fuel value candidates) = + evalDist (classifyDirectDetailedPrivateObserve table boolObserve context fuel value) := by + unfold classifyDirectDetailedPrivatePlanObserve classifyDirectDetailedPrivateObserve + by_cases hprivate : PrivateStructuralHit context + · simp [hprivate] + · simp only [hprivate, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table context + · simpa [hcompletable] using hproject context fuel value candidates + · simp [hcompletable] + +theorem evalDist_fst_canonicalizeDirectDetailedPrivatePlanObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → ProbComp (Bool × List Probe)) + (boolObserve : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hproject : ∀ nextContext remaining nextValue nextCandidates, + evalDist (Prod.fst <$> observe nextContext remaining nextValue nextCandidates) = + evalDist (boolObserve nextContext remaining nextValue)) : + evalDist (Prod.fst <$> canonicalizeDirectDetailedPrivatePlanObserve table observe + context fuel value candidates) = + evalDist (canonicalizeDirectDetailedPrivateObserve table boolObserve + context fuel value) := by + unfold canonicalizeDirectDetailedPrivatePlanObserve + canonicalizeDirectDetailedPrivateObserve + by_cases hprivate : PrivateStructuralHit (canonicalizeMaterializedValues table context) + · simp [hprivate] + · simp only [hprivate, ↓reduceIte] + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + exact evalDist_fst_classifyDirectDetailedPrivatePlanObserve table observe boolObserve + (canonicalizeMaterializedValues table context) fuel value candidates hproject + · simp [hpublished] + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem evalDist_fst_directDetailedBoundaryPrivatePlanObserve + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (planner : (query : spec.Domain) → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Probe)) + (computation : OracleComp spec α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp (Bool × List Probe)) + (boolObserve : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hplanner : ∀ query nextContext remaining nextCache, + ∃ planned, + runDirectResolvedDetailedFromTable nextContext remaining table + ((planner query).run nextCache) = + pure (.done ⟨nextContext, remaining, (planned, nextCache), table⟩)) + (hproject : ∀ nextContext remaining value nextCandidates, + evalDist (Prod.fst <$> observe nextContext remaining value nextCandidates) = + evalDist (boolObserve nextContext remaining value)) : + evalDist (Prod.fst <$> directDetailedBoundaryPrivatePlanObserve impl planner computation + observe candidates context fuel table cache) = + evalDist (directDetailedBoundaryPrivateObserve impl computation boolObserve + context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryPrivatePlanObserve, OracleComp.construct_pure, + directDetailedBoundaryPrivateObserve, OracleComp.construct_pure] + exact hproject context fuel (value, cache) candidates + | query_bind query next ih => + rw [directDetailedBoundaryPrivatePlanObserve, OracleComp.construct_query_bind, + directDetailedBoundaryPrivateObserve, OracleComp.construct_query_bind, map_bind] + obtain ⟨planned, hplanned⟩ := hplanner query context fuel cache + rw [hplanned, pure_bind] + let nextCandidates := appendPlannedCandidate candidates planned + apply evalDist_fst_runDirectDetailedPrivatePlanObserve + intro nextContext remaining value finalCandidates + apply evalDist_fst_canonicalizeDirectDetailedPrivatePlanObserve + intro finalContext finalRemaining finalValue finalCandidates + simpa [directDetailedBoundaryPrivatePlanObserve, + directDetailedBoundaryPrivateObserve] using + ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + +theorem evalDist_fst_retainedResolvedFinalizationPrivatePlanObserve + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) (candidates : List Probe) : + evalDist (Prod.fst <$> + retainedResolvedFinalizationPrivatePlanObserve table root context fuel value candidates) = + evalDist (retainedResolvedFinalizationPrivateObserve table root context fuel value) := by + unfold retainedResolvedFinalizationPrivatePlanObserve + simp + +noncomputable def sampledGranularAllDirectBoundaryDetailedRetainedPrivatePlan + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp (Bool × List Probe) := do + let table ← sampleOtsHashTable + granularAllDirectBoundaryDetailedRetainedPrivatePlan adversary parameter table ftsSecret fuel + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateTraceInvariant.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateTraceInvariant.lean new file mode 100644 index 00000000..153eeba7 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateTraceInvariant.lean @@ -0,0 +1,300 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateCandidateResolve + +/-! +# Pending-candidate trace invariant + +Probe-free resolved computations can only preserve or remove pending candidates. This is the support invariant needed to show that every private structural stop is witnessed by a candidate already present in the proof-only plan trace. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +set_option maxRecDepth 100000 in +theorem pending_subset_of_done_runDirectResolvedDetailedFromTable_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hprobeFree : computation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation)) : + result.context.state.pending ⊆ context.state.pending := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runDirectResolvedDetailedFromTable] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact Finset.Subset.rfl + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hprobeFree + cases input with + | uniform n => + rw [runDirectResolvedDetailedFromTable_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel (hprobeFree.2 output) htail + | hashOutput => + rw [runDirectResolvedDetailedFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel (hprobeFree.2 output) htail + | ensure coordinate => + rw [runDirectResolvedDetailedFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel + (hprobeFree.2 ()) hresult + | probe coordinate candidate => + simp [LazyRevealProbe.IsProbe] at hprobeFree + | peek coordinate => + rw [runDirectResolvedDetailedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel + (hprobeFree.2 _) hresult + | publish coordinate => + rw [runDirectResolvedDetailedFromTable_publish_query_bind] at hresult + exact ih () { context with state := context.state.publish coordinate } fuel + (hprobeFree.2 ()) hresult + | reveal coordinate => + rw [runDirectResolvedDetailedFromTable_reveal_query_bind] at hresult + cases hstate : context.state.values coordinate with + | some output => + simp only [hstate] at hresult + exact ih output context fuel (hprobeFree.2 output) hresult + | none => + simp only [hstate] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + exact (ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel (hprobeFree.2 output) hresult).trans + (Finset.filter_subset _ _) + | position position => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hprivate, hhit] at hresult + · simp only [hprivate, hhit, ↓reduceIte] at hresult + exact (ih output + { state := context.state.materialize (.position position) output + values := context.values } + fuel (hprobeFree.2 output) hresult).trans + (Finset.filter_subset _ _) + | none => + simp only [hprivate, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at htail + · simp only [hhit, ↓reduceIte] at htail + exact (ih output + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel (hprobeFree.2 output) htail).trans + (Finset.filter_subset _ _) + +theorem pending_subset_of_done_runDirectResolvedDetailedFromTable_of_ProbeFree + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) + (hprobeFree : ProbeFree computation) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table (computation.run cache))) : + result.context.state.pending ⊆ context.state.pending := + pending_subset_of_done_runDirectResolvedDetailedFromTable_of_probeFree + (computation.run cache) context fuel table result (hprobeFree cache) hresult + +def PendingCoveredBy (candidates : List Probe) (context : DeferredContext) : Prop := + ∀ entry ∈ context.state.pending, + ∃ candidate ∈ candidates, + candidate.coordinate = entry.1 ∧ candidate.candidate = entry.2 + +theorem pendingCoveredBy_empty : + PendingCoveredBy [] + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } := by + intro entry hentry + simp [LazyRevealProbe.State.empty] at hentry + +theorem PendingCoveredBy.of_subset + {candidates : List Probe} {left right : DeferredContext} + (hcovered : PendingCoveredBy candidates right) + (hsubset : left.state.pending ⊆ right.state.pending) : + PendingCoveredBy candidates left := by + intro entry hentry + exact hcovered entry (hsubset hentry) + +theorem PendingCoveredBy.mono_candidates + {prior later : List Probe} {context : DeferredContext} + (hcovered : PendingCoveredBy prior context) (hsublist : prior.Sublist later) : + PendingCoveredBy later context := by + intro entry hentry + obtain ⟨candidate, hcandidate, hcoordinate, hdigest⟩ := hcovered entry hentry + exact ⟨candidate, hsublist.subset hcandidate, hcoordinate, hdigest⟩ + +theorem PendingCoveredBy.addPending_append + (candidates : List Probe) (context : DeferredContext) (candidate : Probe) + (hcovered : PendingCoveredBy candidates context) : + PendingCoveredBy (candidates ++ [candidate]) + { context with + state := context.state.addPending candidate.coordinate candidate.candidate } := by + intro entry hentry + simp only [LazyRevealProbe.State.addPending, Finset.mem_insert] at hentry + rcases hentry with hnew | hold + · subst entry + exact ⟨candidate, by simp, rfl, rfl⟩ + · obtain ⟨oldCandidate, holdCandidate, hcoordinate, hdigest⟩ := hcovered entry hold + exact ⟨oldCandidate, by simp [holdCandidate], hcoordinate, hdigest⟩ + +theorem candidateListHits_of_mem + (target : Position) (output : HashOutput) (candidate : Probe) + (candidates : List Probe) (hmem : candidate ∈ candidates) + (hcoordinate : candidate.coordinate = .position target) + (hdigest : candidate.candidate = truncateHash output) : + candidateListHits target candidates output := by + induction candidates with + | nil => simp at hmem + | cons head remaining ih => + simp only [List.mem_cons] at hmem + rcases hmem with rfl | hmem + · exact Or.inl ⟨hcoordinate, hdigest.symm⟩ + · exact Or.inr (ih hmem) + +def RecordedCandidateHit (context : DeferredContext) (candidates : List Probe) : Prop := + ∃ position output, + context.values position = some output ∧ + candidateListHits position candidates output + +theorem recordedCandidateHit_of_privateStructuralHit + (context : DeferredContext) (candidates : List Probe) + (hcovered : PendingCoveredBy candidates context) + (hhit : PrivateStructuralHit context) : + RecordedCandidateHit context candidates := by + obtain ⟨position, output, _hhidden, hprivate, hhit⟩ := hhit + have hpending : + (Coordinate.position position, truncateHash output) ∈ context.state.pending := by + rw [← LazyRevealProbe.State.mem_pendingAt_iff] + exact hhit + obtain ⟨candidate, hcandidate, hcoordinate, hdigest⟩ := + hcovered (Coordinate.position position, truncateHash output) hpending + exact ⟨position, output, hprivate, + candidateListHits_of_mem position output candidate candidates hcandidate hcoordinate + hdigest⟩ + +def PrivateValuesLE (left right : DeferredContext) : Prop := + ∀ position output, left.values position = some output → + right.values position = some output + +theorem PrivateValuesLE.refl (context : DeferredContext) : + PrivateValuesLE context context := by + intro position output hvalue + exact hvalue + +theorem PrivateValuesLE.trans {first second third : DeferredContext} + (hfirst : PrivateValuesLE first second) (hsecond : PrivateValuesLE second third) : + PrivateValuesLE first third := by + intro position output hvalue + exact hsecond position output (hfirst position output hvalue) + +set_option maxRecDepth 100000 in +theorem privateValuesLE_of_done_runDirectResolvedDetailedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation)) : + PrivateValuesLE context result.context := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runDirectResolvedDetailedFromTable] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact PrivateValuesLE.refl context + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectResolvedDetailedFromTable_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨value, _hvalue, htail⟩ := hresult + exact ih value context fuel htail + | hashOutput => + rw [runDirectResolvedDetailedFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨value, _hvalue, htail⟩ := hresult + exact ih value context fuel htail + | ensure coordinate => + rw [runDirectResolvedDetailedFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel hresult + | probe coordinate candidate => + cases fuel with + | zero => simp [runDirectResolvedDetailedFromTable_probe_query_bind] at hresult + | succ remaining => + rw [runDirectResolvedDetailedFromTable_probe_query_bind] at hresult + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] at hresult + exact ih () context remaining hresult + · simp only [hrevealed, ↓reduceIte] at hresult + exact ih () + { context with state := context.state.addPending coordinate candidate } + remaining hresult + | peek coordinate => + rw [runDirectResolvedDetailedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hresult + | publish coordinate => + rw [runDirectResolvedDetailedFromTable_publish_query_bind] at hresult + exact ih () { context with state := context.state.publish coordinate } fuel hresult + | reveal coordinate => + rw [runDirectResolvedDetailedFromTable_reveal_query_bind] at hresult + cases hstate : context.state.values coordinate with + | some value => + simp only [hstate] at hresult + exact ih value context fuel hresult + | none => + simp only [hstate] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let value := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) value + · simp [value, hhit] at hresult + · simp only [value, hhit, ↓reduceIte] at hresult + exact ih value + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) value + values := context.values } + fuel hresult + | position revealed => + cases hprivate : context.values revealed with + | some value => + by_cases hhit : context.state.hitAt (.position revealed) value + · simp [hprivate, hhit] at hresult + · simp only [hprivate, hhit, ↓reduceIte] at hresult + exact ih value + { state := context.state.materialize (.position revealed) value + values := context.values } + fuel hresult + | none => + simp only [hprivate, mem_support_bind_iff] at hresult + obtain ⟨value, _hvalue, htail⟩ := hresult + by_cases hhit : context.state.hitAt (.position revealed) value + · simp [hhit] at htail + · simp only [hhit, ↓reduceIte] at htail + have hnext := ih value + { state := context.state.materialize (.position revealed) value + values := context.values.install revealed value } + fuel htail + intro position output hvalue + apply hnext position output + have hne : position ≠ revealed := by + intro heq + subst position + rw [hprivate] at hvalue + contradiction + simpa [DeferredStructuralValues.install, Function.update_of_ne hne] using + hvalue + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitness.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitness.lean new file mode 100644 index 00000000..36ea6439 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitness.lean @@ -0,0 +1,438 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateHindsightWeighted + +/-! +# Private first-fire witnesses + +The existing detailed interpreter records only the cause of a stop. The ordinal first-fire proof +also needs the structural position and full output that caused a private stop. This parallel +interpreter retains those two values and erases exactly to the existing detailed interpreter. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +structure PrivateHitWitness where + position : Position + output : HashOutput + revealed : Finset Coordinate +deriving DecidableEq + +inductive DirectWitnessResult (alpha : Type) where + | stoppedFuel + | stoppedOrdinary + | stoppedPrivate (witness : PrivateHitWitness) + | done (result : ResolvedRunResult alpha) + +def DirectWitnessResult.erase : DirectWitnessResult alpha → DirectDetailedResult alpha + | .stoppedFuel => .stopped .fuelExhausted + | .stoppedOrdinary => .stopped .ordinaryHit + | .stoppedPrivate _ => .stopped .privateStructuralHit + | .done result => .done result + +noncomputable def runDirectResolvedWitnessFromTable + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) : + ProbComp (DirectWitnessResult alpha) := + OracleComp.construct + (C := fun _ : OracleComp (LazyRevealProbe.World Coordinate) alpha => + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → + ProbComp (DirectWitnessResult alpha)) + (fun value context remaining table => + pure (.done ⟨context, remaining, value, table⟩)) + (fun input _next recursivelyRun context fuel table => + match input with + | .uniform n => do + let output ← liftM (unifSpec.query n) + recursivelyRun output context fuel table + | .hashOutput => do + let output ← LazyRevealProbe.sampleHashOutput + recursivelyRun output context fuel table + | .ensure coordinate => + recursivelyRun () + { context with state := context.state.ensure coordinate } fuel table + | .probe coordinate candidate => + match fuel with + | 0 => pure .stoppedFuel + | remaining + 1 => + if coordinate ∈ context.state.revealed then + recursivelyRun () context remaining table + else + recursivelyRun () + { context with + state := context.state.addPending coordinate candidate } + remaining table + | .peek coordinate => + recursivelyRun (context.state.values coordinate) context fuel table + | .publish coordinate => + recursivelyRun () + { context with state := context.state.publish coordinate } fuel table + | .reveal coordinate => + match context.state.values coordinate with + | some output => recursivelyRun output context fuel table + | none => + match coordinate with + | .chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + if context.state.hitAt coordinate output then + pure .stoppedOrdinary + else + recursivelyRun output + { state := context.state.materialize coordinate output + values := context.values } + fuel table + | .position position => + match context.values position with + | some output => + if context.state.hitAt coordinate output then + pure (.stoppedPrivate ⟨position, output, + context.state.revealed⟩) + else + recursivelyRun output + { state := context.state.materialize coordinate output + values := context.values } + fuel table + | none => do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt coordinate output then + pure .stoppedOrdinary + else + recursivelyRun output + { state := context.state.materialize coordinate output + values := context.values.install position output } + fuel table) + computation context fuel table + +theorem runDirectResolvedWitnessFromTable_uniform_query_bind + (context : DeferredContext) (fuel n : Nat) + (table : OtsSecretIndex → HashOutput) + (next : Fin (n + 1) → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedWitnessFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.uniform n)) : + OracleComp (LazyRevealProbe.World Coordinate) (Fin (n + 1))) >>= next) = (do + let output ← liftM (unifSpec.query n) + runDirectResolvedWitnessFromTable context fuel table (next output)) := by + rfl + +theorem runDirectResolvedWitnessFromTable_hashOutput_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedWitnessFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + .hashOutput) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = (do + let output ← LazyRevealProbe.sampleHashOutput + runDirectResolvedWitnessFromTable context fuel table (next output)) := by + rfl + +theorem runDirectResolvedWitnessFromTable_ensure_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedWitnessFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.ensure coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runDirectResolvedWitnessFromTable + { context with state := context.state.ensure coordinate } + fuel table (next ()) := by + rfl + +theorem runDirectResolvedWitnessFromTable_probe_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (candidate : Digest) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedWitnessFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.probe coordinate candidate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + match fuel with + | 0 => pure .stoppedFuel + | remaining + 1 => + if coordinate ∈ context.state.revealed then + runDirectResolvedWitnessFromTable context remaining table (next ()) + else + runDirectResolvedWitnessFromTable + { context with + state := context.state.addPending coordinate candidate } + remaining table (next ()) := by + rfl + +theorem runDirectResolvedWitnessFromTable_peek_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Option HashOutput → + OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedWitnessFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.peek coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) (Option HashOutput)) >>= next) = + runDirectResolvedWitnessFromTable context fuel table + (next (context.state.values coordinate)) := by + rfl + +theorem runDirectResolvedWitnessFromTable_publish_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedWitnessFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.publish coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runDirectResolvedWitnessFromTable + { context with state := context.state.publish coordinate } + fuel table (next ()) := by + rfl + +theorem runDirectResolvedWitnessFromTable_reveal_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runDirectResolvedWitnessFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.reveal coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = + (match context.state.values coordinate with + | some output => + runDirectResolvedWitnessFromTable context fuel table (next output) + | none => + match coordinate with + | .chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + if context.state.hitAt coordinate output then + pure .stoppedOrdinary + else + runDirectResolvedWitnessFromTable + { state := context.state.materialize coordinate output + values := context.values } + fuel table (next output) + | .position position => + match context.values position with + | some output => + if context.state.hitAt coordinate output then + pure (.stoppedPrivate ⟨position, output, + context.state.revealed⟩) + else + runDirectResolvedWitnessFromTable + { state := context.state.materialize coordinate output + values := context.values } + fuel table (next output) + | none => do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt coordinate output then + pure .stoppedOrdinary + else + runDirectResolvedWitnessFromTable + { state := context.state.materialize coordinate output + values := context.values.install position output } + fuel table (next output)) := by + cases coordinate <;> rfl + +set_option maxRecDepth 100000 in +theorem map_erase_runDirectResolvedWitnessFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + DirectWitnessResult.erase <$> + runDirectResolvedWitnessFromTable context fuel table computation = + runDirectResolvedDetailedFromTable context fuel table computation := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runDirectResolvedWitnessFromTable, runDirectResolvedDetailedFromTable, + DirectWitnessResult.erase] + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectResolvedWitnessFromTable_uniform_query_bind, + runDirectResolvedDetailedFromTable_uniform_query_bind, map_bind] + apply bind_congr + intro output + exact ih output context fuel + | hashOutput => + rw [runDirectResolvedWitnessFromTable_hashOutput_query_bind, + runDirectResolvedDetailedFromTable_hashOutput_query_bind, map_bind] + apply bind_congr + intro output + exact ih output context fuel + | ensure coordinate => + rw [runDirectResolvedWitnessFromTable_ensure_query_bind, + runDirectResolvedDetailedFromTable_ensure_query_bind] + exact ih () { context with state := context.state.ensure coordinate } fuel + | probe coordinate candidate => + rw [runDirectResolvedWitnessFromTable_probe_query_bind, + runDirectResolvedDetailedFromTable_probe_query_bind] + cases fuel with + | zero => simp [DirectWitnessResult.erase] + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () context remaining + · simp only [hrevealed, ↓reduceIte] + exact ih () + { context with + state := context.state.addPending coordinate candidate } + remaining + | peek coordinate => + rw [runDirectResolvedWitnessFromTable_peek_query_bind, + runDirectResolvedDetailedFromTable_peek_query_bind] + exact ih (context.state.values coordinate) context fuel + | publish coordinate => + rw [runDirectResolvedWitnessFromTable_publish_query_bind, + runDirectResolvedDetailedFromTable_publish_query_bind] + exact ih () { context with state := context.state.publish coordinate } fuel + | reveal coordinate => + rw [runDirectResolvedWitnessFromTable_reveal_query_bind, + runDirectResolvedDetailedFromTable_reveal_query_bind] + cases hstate : context.state.values coordinate with + | some output => + simp only + exact ih output context fuel + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit, DirectWitnessResult.erase] + · simp only [output, hhit, ↓reduceIte] + exact ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel + | position position => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hprivate, hhit, DirectWitnessResult.erase] + · simp only [hprivate, hhit, ↓reduceIte] + exact ih output + { state := context.state.materialize (.position position) output + values := context.values } + fuel + | none => + simp only [hprivate, map_bind] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit, DirectWitnessResult.erase] + · simp only [hhit, ↓reduceIte] + exact ih output + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel + +set_option maxRecDepth 100000 in +theorem candidateListHits_of_stoppedPrivate_mem_runDirectResolvedWitnessFromTable + (candidates : List Probe) + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (witness : PrivateHitWitness) + (hcovered : PendingCoveredBy candidates context) + (hbound : computation.IsQueryBoundP (IsUncoveredProbe candidates) 0) + (hresult : DirectWitnessResult.stoppedPrivate witness ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) : + candidateListHits witness.position candidates witness.output := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runDirectResolvedWitnessFromTable] at hresult + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases input with + | uniform n => + rw [runDirectResolvedWitnessFromTable_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel hcovered (hbound.2 output) htail + | hashOutput => + rw [runDirectResolvedWitnessFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel hcovered (hbound.2 output) htail + | ensure coordinate => + rw [runDirectResolvedWitnessFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel hcovered + (hbound.2 ()) hresult + | probe coordinate digest => + have hmem : (⟨coordinate, digest⟩ : Probe) ∈ candidates := by + simpa [IsUncoveredProbe] using hbound.1 + have htail : (next ()).IsQueryBoundP (IsUncoveredProbe candidates) 0 := by + simpa [IsUncoveredProbe] using hbound.2 () + cases fuel with + | zero => simp [runDirectResolvedWitnessFromTable_probe_query_bind] at hresult + | succ remaining => + rw [runDirectResolvedWitnessFromTable_probe_query_bind] at hresult + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] at hresult + exact ih () context remaining hcovered htail hresult + · simp only [hrevealed, ↓reduceIte] at hresult + exact ih () + { context with state := context.state.addPending coordinate digest } + remaining (hcovered.addPending_of_mem ⟨coordinate, digest⟩ hmem) htail + hresult + | peek coordinate => + rw [runDirectResolvedWitnessFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hcovered (hbound.2 _) hresult + | publish coordinate => + rw [runDirectResolvedWitnessFromTable_publish_query_bind] at hresult + exact ih () { context with state := context.state.publish coordinate } fuel hcovered + (hbound.2 ()) hresult + | reveal coordinate => + rw [runDirectResolvedWitnessFromTable_reveal_query_bind] at hresult + cases hstate : context.state.values coordinate with + | some output => + simp only [hstate] at hresult + exact ih output context fuel hcovered (hbound.2 output) hresult + | none => + simp only [hstate] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + exact ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel (hcovered.clearPending (.chainStart lay tree leafIdx chainIdx)) + (hbound.2 output) hresult + | position position => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hprivate, hhit] at hresult + subst witness + have hpending : + (Coordinate.position position, truncateHash output) ∈ + context.state.pending := by + rw [← LazyRevealProbe.State.mem_pendingAt_iff] + exact hhit + obtain ⟨candidate, hcandidate, hcoordinate, hdigest⟩ := + hcovered (Coordinate.position position, truncateHash output) hpending + exact candidateListHits_of_mem position output candidate candidates + hcandidate hcoordinate hdigest + · simp only [hprivate, hhit, ↓reduceIte] at hresult + exact ih output + { state := context.state.materialize (.position position) output + values := context.values } + fuel (hcovered.clearPending (.position position)) (hbound.2 output) + hresult + | none => + simp only [hprivate, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htailResult⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at htailResult + · simp only [hhit, ↓reduceIte] at htailResult + exact ih output + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel (hcovered.clearPending (.position position)) (hbound.2 output) + htailResult + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinal.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinal.lean new file mode 100644 index 00000000..60368aeb --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinal.lean @@ -0,0 +1,227 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessPlan +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePlanNormalizedCount + +/-! +# Private witness ordinals + +Every retained private witness selects one concrete candidate ordinal. The selection is bounded by +the supported plan length, so a source computation with at most `q` outer hash queries places every +witness in `Fin q` without enumerating structural positions. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +def PrivateWitnessAtOrdinal + (witness : PrivateHitWitness) (candidates : List Probe) + (ordinal : Fin candidates.length) : Prop := + let candidate := candidates.get ordinal + candidate.coordinate = .position witness.position ∧ + truncateHash witness.output = candidate.candidate + +theorem exists_privateWitnessAtOrdinal_of_candidateListHits + (witness : PrivateHitWitness) (candidates : List Probe) + (hhit : candidateListHits witness.position candidates witness.output) : + ∃ ordinal, PrivateWitnessAtOrdinal witness candidates ordinal := by + obtain ⟨candidate, hcandidate, hcoordinate, hdigest⟩ := + (candidateListHits_iff_exists_mem witness.position candidates witness.output).1 hhit + obtain ⟨ordinal, hget⟩ := List.mem_iff_get.mp hcandidate + exact ⟨ordinal, by + unfold PrivateWitnessAtOrdinal + rw [hget] + exact ⟨hcoordinate, hdigest⟩⟩ + +noncomputable def firstPrivateWitnessOrdinal? + (witness : PrivateHitWitness) (candidates : List Probe) : + Option (Fin candidates.length) := by + classical + let matching := Finset.univ.filter fun ordinal : Fin candidates.length => + PrivateWitnessAtOrdinal witness candidates ordinal + exact if h : matching.Nonempty then + some (matching.min' h) + else + none + +theorem firstPrivateWitnessOrdinal?_eq_some_of_candidateListHits + (witness : PrivateHitWitness) (candidates : List Probe) + (hhit : candidateListHits witness.position candidates witness.output) : + ∃ ordinal, firstPrivateWitnessOrdinal? witness candidates = some ordinal ∧ + PrivateWitnessAtOrdinal witness candidates ordinal := by + classical + obtain ⟨ordinal, hordinal⟩ := + exists_privateWitnessAtOrdinal_of_candidateListHits witness candidates hhit + let matching := Finset.univ.filter fun selected : Fin candidates.length => + PrivateWitnessAtOrdinal witness candidates selected + have hmatching : matching.Nonempty := by + exact ⟨ordinal, Finset.mem_filter.mpr ⟨Finset.mem_univ _, hordinal⟩⟩ + unfold firstPrivateWitnessOrdinal? + simp only [matching, hmatching, dif_pos] + refine ⟨matching.min' hmatching, rfl, ?_⟩ + exact (Finset.mem_filter.mp (matching.min'_mem hmatching)).2 + +theorem firstPrivateWitnessOrdinal?_le_of_eq_some_of_matches + (witness : PrivateHitWitness) (candidates : List Probe) + (ordinal other : Fin candidates.length) + (hfirst : firstPrivateWitnessOrdinal? witness candidates = some ordinal) + (hother : PrivateWitnessAtOrdinal witness candidates other) : + ordinal.val ≤ other.val := by + classical + let matching := Finset.univ.filter fun selected : Fin candidates.length => + PrivateWitnessAtOrdinal witness candidates selected + have hmatching : matching.Nonempty := by + exact ⟨other, Finset.mem_filter.mpr ⟨Finset.mem_univ _, hother⟩⟩ + unfold firstPrivateWitnessOrdinal? at hfirst + simp only [matching, hmatching, dif_pos, Option.some.injEq] at hfirst + subst ordinal + exact_mod_cast matching.min'_le other + (Finset.mem_filter.mpr ⟨Finset.mem_univ _, hother⟩) + +def WitnessFirstUsesOrdinal + (ordinal : Nat) (output : PrivateWitnessPlanOutput) : Prop := + ∃ witness sourceOrdinal, + output.1 = some witness ∧ sourceOrdinal.val = ordinal ∧ + firstPrivateWitnessOrdinal? witness output.2 = some sourceOrdinal + +def WitnessFirstUsesLayerRootOrdinal + (ordinal : Nat) (output : PrivateWitnessPlanOutput) : Prop := + ∃ witness sourceOrdinal, + output.1 = some witness ∧ sourceOrdinal.val = ordinal ∧ + firstPrivateWitnessOrdinal? witness output.2 = some sourceOrdinal ∧ + (output.2.get sourceOrdinal).IsLayerRoot + +def WitnessFirstUsesNonLayerRootOrdinal + (ordinal : Nat) (output : PrivateWitnessPlanOutput) : Prop := + ∃ witness sourceOrdinal, + output.1 = some witness ∧ sourceOrdinal.val = ordinal ∧ + firstPrivateWitnessOrdinal? witness output.2 = some sourceOrdinal ∧ + ¬(output.2.get sourceOrdinal).IsLayerRoot + +theorem witnessFirstUsesOrdinal_iff_root_or_nonRoot + {ordinal : Nat} {output : PrivateWitnessPlanOutput} : + WitnessFirstUsesOrdinal ordinal output ↔ + WitnessFirstUsesLayerRootOrdinal ordinal output ∨ + WitnessFirstUsesNonLayerRootOrdinal ordinal output := by + constructor + · rintro ⟨witness, sourceOrdinal, hwitness, hvalue, hfirst⟩ + by_cases hroot : (output.2.get sourceOrdinal).IsLayerRoot + · exact Or.inl ⟨witness, sourceOrdinal, hwitness, hvalue, hfirst, hroot⟩ + · exact Or.inr ⟨witness, sourceOrdinal, hwitness, hvalue, hfirst, hroot⟩ + · rintro (⟨witness, sourceOrdinal, hwitness, hvalue, hfirst, _hroot⟩ | + ⟨witness, sourceOrdinal, hwitness, hvalue, hfirst, _hroot⟩) + · exact ⟨witness, sourceOrdinal, hwitness, hvalue, hfirst⟩ + · exact ⟨witness, sourceOrdinal, hwitness, hvalue, hfirst⟩ + +noncomputable def boundedPrivateWitnessOrdinal? + (q : Nat) (output : PrivateWitnessPlanOutput) : Option (Fin q) := by + classical + match output.1 with + | none => exact none + | some witness => + match firstPrivateWitnessOrdinal? witness output.2 with + | none => exact none + | some ordinal => + if hlt : ordinal.val < q then exact some ⟨ordinal.val, hlt⟩ else exact none + +theorem boundedPrivateWitnessOrdinal?_eq_some_of_covered + (q : Nat) (output : PrivateWitnessPlanOutput) (witness : PrivateHitWitness) + (hwitness : output.1 = some witness) + (hcovered : PrivateWitnessCovered output) (hlength : output.2.length ≤ q) : + ∃ ordinal : Fin q, + boundedPrivateWitnessOrdinal? q output = some ordinal ∧ + ∃ sourceOrdinal : Fin output.2.length, + sourceOrdinal.val = ordinal.val ∧ + PrivateWitnessAtOrdinal witness output.2 sourceOrdinal := by + classical + have hhit := hcovered witness hwitness + obtain ⟨sourceOrdinal, hfirst, hsource⟩ := + firstPrivateWitnessOrdinal?_eq_some_of_candidateListHits witness output.2 hhit + have hlt : sourceOrdinal.val < q := sourceOrdinal.isLt.trans_le hlength + let ordinal : Fin q := ⟨sourceOrdinal.val, hlt⟩ + refine ⟨ordinal, ?_, sourceOrdinal, rfl, hsource⟩ + unfold boundedPrivateWitnessOrdinal? + simp only [hwitness] + rw [hfirst] + simp [hlt, ordinal] + +theorem support_granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve_length_le + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) (q : Nat) + (hbound : (retainedGameRestComputation adversary ⟨value.1, parameter⟩).IsQueryBoundP + IsOuterHash q) + (output : PrivateWitnessPlanOutput) + (houtput : output ∈ support + (granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates)) : + output.2.length ≤ candidates.length + q := by + have herased : erasePrivateWitnessPlanOutput output ∈ support + (granularDetailedRetainedRestNormalizedPrivatePlanObserve adversary parameter table + ftsSecret context fuel value candidates) := by + rw [← map_erase_granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary + parameter table ftsSecret context fuel value candidates, support_map] + exact ⟨output, houtput, rfl⟩ + exact support_granularDetailedRetainedRestNormalizedPrivatePlanObserve_length_le adversary + parameter table ftsSecret context fuel value candidates q hbound + (erasePrivateWitnessPlanOutput output) herased + +theorem support_granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve_length_le_of_expanded + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) (q : Nat) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, value.1, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨value.1, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (output : PrivateWitnessPlanOutput) + (houtput : output ∈ support + (granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates)) : + output.2.length ≤ candidates.length + q := by + have herased : erasePrivateWitnessPlanOutput output ∈ support + (granularDetailedRetainedRestNormalizedPrivatePlanObserve adversary parameter table + ftsSecret context fuel value candidates) := by + rw [← map_erase_granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary + parameter table ftsSecret context fuel value candidates, support_map] + exact ⟨output, houtput, rfl⟩ + exact support_granularDetailedRetainedRestNormalizedPrivatePlanObserve_length_le_of_expanded + adversary parameter table ftsSecret context fuel value candidates q hbound hconsistent hstarts + (erasePrivateWitnessPlanOutput output) herased + +theorem supported_retained_privateWitness_has_bounded_ordinal + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) (q : Nat) + (hbound : (retainedGameRestComputation adversary ⟨value.1, parameter⟩).IsQueryBoundP + IsOuterHash q) + (hcovered : PendingCoveredBy candidates context) + (output : PrivateWitnessPlanOutput) + (houtput : output ∈ support + (granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates)) + (witness : PrivateHitWitness) (hwitness : output.1 = some witness) : + ∃ ordinal : Fin (candidates.length + q), + boundedPrivateWitnessOrdinal? (candidates.length + q) output = some ordinal := by + have houtputCovered := + privateWitnessCovered_of_mem_granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve + adversary parameter table ftsSecret context fuel value candidates hcovered output houtput + have hlength := + support_granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve_length_le adversary + parameter table ftsSecret context fuel value candidates q hbound output houtput + obtain ⟨ordinal, hordinal, _⟩ := + boundedPrivateWitnessOrdinal?_eq_some_of_covered (candidates.length + q) output witness + hwitness houtputCovered hlength + exact ⟨ordinal, hordinal⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalCommute.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalCommute.lean new file mode 100644 index 00000000..ea60d3de --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalCommute.lean @@ -0,0 +1,320 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalProbability + +/-! +# One-ordinal resolution commutation + +Resolving an arbitrary structural position before testing one selected candidate cannot increase +the selected fire probability. A resolution at the selected position may stop on an older pending +hit. A different resolution is commuted past the selected deferred draw. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +noncomputable def resolveThenPrivateCandidateFire + (position : Position) (candidate : Probe) (context : DeferredContext) : ProbComp Bool := do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure false + | some resolved => privateCandidateFire candidate resolved.toDeferredContext + +theorem deferredPositionOutput_completePrivatePosition_self + (position : Position) (context : DeferredContext) (output : HashOutput) + (houtput : output ∈ support (deferredPositionOutput position context)) : + deferredPositionOutput position + (completePrivatePosition position context output).toDeferredContext = + pure output := by + unfold deferredPositionOutput DeferredContext.positionValue at houtput ⊢ + unfold completePrivatePosition + cases hstate : context.state.values (.position position) with + | some value => + simp [hstate] at houtput + subst output + simp [hstate] + | none => + cases hprivate : context.values position with + | some value => + simp [hstate, hprivate] at houtput + subst output + simp [hstate, DeferredStructuralValues.install] + | none => + simp [hstate, DeferredStructuralValues.install] + +theorem evalDist_resolveThenPrivateCandidateFire_same + (target : Position) (candidate : Probe) (context : DeferredContext) + (hcoordinate : candidate.coordinate = .position target) : + evalDist (resolveThenPrivateCandidateFire target candidate context) = evalDist (do + let output ← deferredPositionOutput target context + if context.state.hitAt (.position target) output then + pure false + else + pure (truncateHash output = candidate.candidate)) := by + unfold resolveThenPrivateCandidateFire + rw [resolveDeferredPositionValue_eq_bind_output] + simp only [bind_assoc] + apply evalDist_bind_congr + intro output _houtput + unfold resolvePrivatePositionWithOutput + by_cases hhit : context.state.hitAt (.position target) output + · simp [hhit] + · simp only [hhit, ↓reduceIte, pure_bind] + unfold privateCandidateFire + simp only [hcoordinate] + rw [deferredPositionOutput_completePrivatePosition_self target context output _houtput] + simp + +theorem probEvent_resolveThenPrivateCandidateFire_same_le + (target : Position) (candidate : Probe) (context : DeferredContext) + (hcoordinate : candidate.coordinate = .position target) : + Pr[= true | resolveThenPrivateCandidateFire target candidate context] ≤ + Pr[= true | privateCandidateFire candidate context] := by + have hdist := evalDist_resolveThenPrivateCandidateFire_same target candidate context hcoordinate + calc + _ = Pr[= true | do + let output ← deferredPositionOutput target context + if context.state.hitAt (.position target) output then + pure false + else + pure (truncateHash output = candidate.candidate)] := + OracleComp.probOutput_congr rfl hdist + _ ≤ Pr[fun output => truncateHash output = candidate.candidate | + deferredPositionOutput target context] := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_probEvent + intro output _houtput hmiss + by_cases hhit : context.state.hitAt (.position target) output + · simp [hhit] + · simp [hhit, hmiss] + _ = Pr[= true | privateCandidateFire candidate context] := by + unfold privateCandidateFire + rw [hcoordinate] + change Pr[fun output => truncateHash output = candidate.candidate | + deferredPositionOutput target context] = + Pr[= true | (fun output : HashOutput => + decide (truncateHash output = candidate.candidate)) <$> + deferredPositionOutput target context] + rw [← probEvent_eq_eq_probOutput, probEvent_map] + exact OracleComp.probEvent_congr' (fun _ _ => by simp) rfl + +theorem evalDist_resolveThenPrivateCandidateFire_ne + (position target : Position) (candidate : Probe) (context : DeferredContext) + (hcoordinate : candidate.coordinate = .position target) (hne : position ≠ target) : + evalDist (resolveThenPrivateCandidateFire position candidate context) = evalDist (do + let targetOutput ← deferredPositionOutput target context + let positionOutput ← deferredPositionOutput position context + if context.state.hitAt (.position position) positionOutput then + pure false + else + pure (truncateHash targetOutput = candidate.candidate)) := by + let continuation : HashOutput → HashOutput → ProbComp Bool := + fun positionOutput targetOutput => + if context.state.hitAt (.position position) positionOutput then + pure false + else + pure (truncateHash targetOutput = candidate.candidate) + calc + _ = evalDist (do + let positionOutput ← deferredPositionOutput position context + let targetOutput ← deferredPositionOutput target context + continuation positionOutput targetOutput) := by + unfold resolveThenPrivateCandidateFire + rw [resolveDeferredPositionValue_eq_bind_output] + simp only [bind_assoc] + apply evalDist_bind_congr + intro positionOutput _hpositionOutput + unfold resolvePrivatePositionWithOutput + by_cases hhit : context.state.hitAt (.position position) positionOutput + · simp only [hhit, ↓reduceIte, pure_bind, continuation] + exact (OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (deferredPositionOutput target context) + (by simp [deferredPositionOutput, LazyRevealProbe.sampleHashOutput]) + (pure false)).symm + · simp only [hhit, ↓reduceIte, pure_bind, continuation] + unfold privateCandidateFire + simp only [hcoordinate] + rw [deferredPositionOutput_completePrivatePosition_of_ne position target context + positionOutput hne] + _ = evalDist (do + let targetOutput ← deferredPositionOutput target context + let positionOutput ← deferredPositionOutput position context + continuation positionOutput targetOutput) := + OracleComp.DeferredSampling.evalDist_bind_comm + (deferredPositionOutput position context) (deferredPositionOutput target context) + continuation + _ = _ := by rfl + +theorem probEvent_resolveThenPrivateCandidateFire_ne_le + (position target : Position) (candidate : Probe) (context : DeferredContext) + (hcoordinate : candidate.coordinate = .position target) (hne : position ≠ target) : + Pr[= true | resolveThenPrivateCandidateFire position candidate context] ≤ + Pr[= true | privateCandidateFire candidate context] := by + have hdist := evalDist_resolveThenPrivateCandidateFire_ne position target candidate context + hcoordinate hne + calc + _ = Pr[= true | do + let targetOutput ← deferredPositionOutput target context + let positionOutput ← deferredPositionOutput position context + if context.state.hitAt (.position position) positionOutput then + pure false + else + pure (truncateHash targetOutput = candidate.candidate)] := + OracleComp.probOutput_congr rfl hdist + _ ≤ Pr[fun output => truncateHash output = candidate.candidate | + deferredPositionOutput target context] := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_probEvent + intro targetOutput _htargetOutput hmiss + simp [hmiss] + _ = Pr[= true | privateCandidateFire candidate context] := by + unfold privateCandidateFire + rw [hcoordinate] + change Pr[fun output => truncateHash output = candidate.candidate | + deferredPositionOutput target context] = + Pr[= true | (fun output : HashOutput => + decide (truncateHash output = candidate.candidate)) <$> + deferredPositionOutput target context] + rw [← probEvent_eq_eq_probOutput, probEvent_map] + exact OracleComp.probEvent_congr' (fun _ _ => by simp) rfl + +theorem probEvent_resolveThenPrivateCandidateFire_le + (position : Position) (candidate : Probe) (context : DeferredContext) : + Pr[= true | resolveThenPrivateCandidateFire position candidate context] ≤ + Pr[= true | privateCandidateFire candidate context] := by + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + unfold resolveThenPrivateCandidateFire privateCandidateFire + rw [← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_of_forall_le + intro resolved _hresolved + cases resolved <;> simp [hcoordinate] + | position target => + by_cases heq : position = target + · subst position + exact probEvent_resolveThenPrivateCandidateFire_same_le target candidate context hcoordinate + · exact probEvent_resolveThenPrivateCandidateFire_ne_le position target candidate context + hcoordinate heq + +theorem privateCandidateFire_materialize_chainStart + (candidate : Probe) (context : DeferredContext) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (output : HashOutput) : + privateCandidateFire candidate + { state := context.state.materialize (.chainStart lay tree leafIdx chainIdx) output + values := context.values } = + privateCandidateFire candidate context := by + cases hcandidate : candidate.coordinate with + | chainStart otherLay otherTree otherLeaf otherChain => + simp [privateCandidateFire, hcandidate] + | position position => + rfl + +theorem privateCandidateFire_materialize_position_of_positionValue + (candidate : Probe) (context : DeferredContext) + (position : Position) (output : HashOutput) + (hvalue : context.positionValue position = some output) : + privateCandidateFire candidate + { state := context.state.materialize (.position position) output + values := context.values } = + privateCandidateFire candidate context := by + cases hcandidate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => simp [privateCandidateFire, hcandidate] + | position target => + by_cases heq : target = position + · subst target + unfold privateCandidateFire + simp only [hcandidate] + unfold deferredPositionOutput + have hpost : + ({ state := context.state.materialize (.position position) output + values := context.values } : DeferredContext).positionValue position = + some output := by + simp [DeferredContext.positionValue, LazyRevealProbe.State.materialize] + rw [hpost, hvalue] + · unfold privateCandidateFire + simp only [hcandidate] + unfold deferredPositionOutput + have hcoordinateNe : Coordinate.position target ≠ .position position := by + intro hcoordinate + exact heq (Coordinate.position.inj hcoordinate) + have hpost : + ({ state := context.state.materialize (.position position) output + values := context.values } : DeferredContext).positionValue target = + context.positionValue target := by + unfold DeferredContext.positionValue + simp [LazyRevealProbe.State.materialize, Function.update_of_ne hcoordinateNe] + rw [hpost] + +theorem privateCandidateFire_materialize_install_position_of_positionValue + (candidate : Probe) (context : DeferredContext) + (position : Position) (output : HashOutput) + (hvalue : context.positionValue position = some output) : + privateCandidateFire candidate + { state := context.state.materialize (.position position) output + values := context.values.install position output } = + privateCandidateFire candidate context := by + have hmaterialized := privateCandidateFire_materialize_position_of_positionValue candidate + context position output hvalue + cases hcandidate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => simp [privateCandidateFire, hcandidate] + | position target => + have hpost : + ({ state := context.state.materialize (.position position) output + values := context.values.install position output } : DeferredContext).positionValue + target = + ({ state := context.state.materialize (.position position) output + values := context.values } : DeferredContext).positionValue target := by + unfold DeferredContext.positionValue + by_cases heq : target = position + · subst target + simp [LazyRevealProbe.State.materialize] + · have hcoordinateNe : Coordinate.position target ≠ .position position := by + intro hcoordinate + exact heq (Coordinate.position.inj hcoordinate) + simp [LazyRevealProbe.State.materialize, Function.update_of_ne hcoordinateNe, + DeferredStructuralValues.install, Function.update_of_ne heq] + calc + _ = privateCandidateFire candidate + { state := context.state.materialize (.position position) output + values := context.values } := by + unfold privateCandidateFire + simp only [hcandidate] + unfold deferredPositionOutput + rw [hpost] + _ = _ := hmaterialized + +theorem privateCandidateFire_materialize_install_eq_complete + (candidate : Probe) (context : DeferredContext) + (position : Position) (output : HashOutput) + (hstate : context.state.values (.position position) = none) : + privateCandidateFire candidate + { state := context.state.materialize (.position position) output + values := context.values.install position output } = + privateCandidateFire candidate + (completePrivatePosition position context output).toDeferredContext := by + cases hcandidate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => simp [privateCandidateFire, hcandidate] + | position target => + have hpositionValue : + ({ state := context.state.materialize (.position position) output + values := context.values.install position output } : DeferredContext).positionValue + target = + (completePrivatePosition position context output).toDeferredContext.positionValue + target := by + unfold DeferredContext.positionValue completePrivatePosition + by_cases heq : target = position + · subst target + simp [LazyRevealProbe.State.materialize, hstate, + DeferredStructuralValues.install] + · have hcoordinateNe : Coordinate.position target ≠ .position position := by + intro hcoordinate + exact heq (Coordinate.position.inj hcoordinate) + simp [LazyRevealProbe.State.materialize, LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway, Function.update_of_ne hcoordinateNe, + DeferredStructuralValues.install, Function.update_of_ne heq] + unfold privateCandidateFire + simp only [hcandidate] + unfold deferredPositionOutput + rw [hpositionValue] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHidden.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHidden.lean new file mode 100644 index 00000000..4ac8ceff --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHidden.lean @@ -0,0 +1,259 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateRootCandidate +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRiskLift + +/-! +# Hidden selected-candidate risk + +A recorded plan may name a coordinate that is already published. Such a candidate cannot explain +a private witness, but the ungated candidate observer can still return true there. The hidden +observer removes that harmless over-approximation. `NoAuxiliaryPrivateValues` is the invariant of +the delayed selection schedule needed to make every hidden selected candidate fresh. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +def NoAuxiliaryPrivateValues (context : DeferredContext) : Prop := + ∀ position, context.state.values (.position position) = none → + context.values position = none + +def CandidatePositionsFresh (context : DeferredContext) : Prop := + ∀ position parent, Position.parentOf position = some parent → + Coordinate.position position ∉ context.state.revealed → + context.state.values (.position position) = none ∧ + context.values position = none + +theorem candidatePositionsFresh_empty : + CandidatePositionsFresh + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } := by + intro position parent hparent hhidden + simp [LazyRevealProbe.State.empty, emptyDeferredStructuralValues] + +theorem noAuxiliaryPrivateValues_empty : + NoAuxiliaryPrivateValues + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } := by + intro position _hstate + simp [emptyDeferredStructuralValues] + +theorem noAuxiliaryPrivateValues_directDeferredContext + (state : LazyRevealProbe.State Coordinate) : + NoAuxiliaryPrivateValues (directDeferredContext state) := by + intro position hstate + simpa [directDeferredContext, directDeferredValues] using hstate + +theorem NoAuxiliaryPrivateValues.ensure + {context : DeferredContext} (hprivate : NoAuxiliaryPrivateValues context) + (coordinate : Coordinate) : + NoAuxiliaryPrivateValues + { context with state := context.state.ensure coordinate } := by + intro position hstate + exact hprivate position hstate + +theorem NoAuxiliaryPrivateValues.addPending + {context : DeferredContext} (hprivate : NoAuxiliaryPrivateValues context) + (coordinate : Coordinate) (candidate : Digest) : + NoAuxiliaryPrivateValues + { context with state := context.state.addPending coordinate candidate } := by + intro position hstate + exact hprivate position hstate + +theorem NoAuxiliaryPrivateValues.clearPending + {context : DeferredContext} (hprivate : NoAuxiliaryPrivateValues context) + (coordinate : Coordinate) : + NoAuxiliaryPrivateValues + { context with state := context.state.clearPending coordinate } := by + intro position hstate + exact hprivate position hstate + +theorem NoAuxiliaryPrivateValues.publish + {context : DeferredContext} (hprivate : NoAuxiliaryPrivateValues context) + (coordinate : Coordinate) : + NoAuxiliaryPrivateValues + { context with state := context.state.publish coordinate } := by + intro position hstate + exact hprivate position hstate + +theorem NoAuxiliaryPrivateValues.materialize_install + {context : DeferredContext} (hprivate : NoAuxiliaryPrivateValues context) + (coordinate : Coordinate) (position : Position) (output : HashOutput) + (hcoordinate : coordinate = .position position) : + NoAuxiliaryPrivateValues + { state := context.state.materialize coordinate output + values := context.values.install position output } := by + subst coordinate + intro other hstate + by_cases heq : other = position + · subst other + simp [LazyRevealProbe.State.materialize] at hstate + · change (context.values.install position output) other = none + unfold DeferredStructuralValues.install + rw [Function.update_of_ne heq] + apply hprivate other + have hcoordinate : Coordinate.position other ≠ .position position := by + simpa using heq + simpa [LazyRevealProbe.State.materialize, Function.update_of_ne hcoordinate] using hstate + +noncomputable def hiddenPrivateCandidateFire + (candidate : Probe) (context : DeferredContext) : ProbComp Bool := + if candidate.coordinate ∈ context.state.revealed then + pure false + else + privateCandidateFire candidate context + +theorem hiddenPrivateCandidateFire_of_not_revealed + (candidate : Probe) (context : DeferredContext) + (hhidden : candidate.coordinate ∉ context.state.revealed) : + hiddenPrivateCandidateFire candidate context = + privateCandidateFire candidate context := by + simp [hiddenPrivateCandidateFire, hhidden] + +theorem hiddenPrivateCandidateFire_of_revealed + (candidate : Probe) (context : DeferredContext) + (hrevealed : candidate.coordinate ∈ context.state.revealed) : + hiddenPrivateCandidateFire candidate context = pure false := by + simp [hiddenPrivateCandidateFire, hrevealed] + +theorem probEvent_hiddenPrivateCandidateFire_le + (candidate : Probe) (context : DeferredContext) + (hvalid : context.state.Valid) + (hprivate : NoAuxiliaryPrivateValues context) : + Pr[= true | hiddenPrivateCandidateFire candidate context] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · simp [hiddenPrivateCandidateFire, hrevealed] + · rw [hiddenPrivateCandidateFire_of_not_revealed candidate context hrevealed] + apply probEvent_privateCandidateFire_le_of_fresh + · intro position hcoordinate + have hhidden : Coordinate.position position ∉ context.state.revealed := by + rwa [← hcoordinate] + exact hvalid.not_revealed_value_none hhidden + · intro position hcoordinate + have hhidden : Coordinate.position position ∉ context.state.revealed := by + rwa [← hcoordinate] + exact hprivate position (hvalid.not_revealed_value_none hhidden) + +theorem probEvent_hiddenPrivateCandidateFire_empty_le (candidate : Probe) : + Pr[= true | hiddenPrivateCandidateFire candidate + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues }] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + exact probEvent_hiddenPrivateCandidateFire_le candidate _ + LazyRevealProbe.State.valid_empty noAuxiliaryPrivateValues_empty + +theorem probEvent_hiddenPrivateCandidateFire_le_of_candidatePositionsFresh + (candidate : Probe) (context : DeferredContext) + (hparent : candidate.HasStructuralParent) + (hfresh : CandidatePositionsFresh context) : + Pr[= true | hiddenPrivateCandidateFire candidate context] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · simp [hiddenPrivateCandidateFire, hrevealed] + · rw [hiddenPrivateCandidateFire_of_not_revealed candidate context hrevealed] + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [privateCandidateFire, hcoordinate] + | position position => + simp only [Probe.HasStructuralParent, hcoordinate] at hparent + obtain ⟨parent, hpositionParent⟩ := hparent + have hpositionHidden : Coordinate.position position ∉ context.state.revealed := by + simpa [hcoordinate] using hrevealed + have hpositionFresh := hfresh position parent hpositionParent hpositionHidden + exact probEvent_privateCandidateFire_le_of_fresh candidate context + (by + intro other hother + have : position = other := by + simpa [hcoordinate] using hother + subst other + exact hpositionFresh.1) + (by + intro other hother + have : position = other := by + simpa [hcoordinate] using hother + subst other + exact hpositionFresh.2) + +theorem Probe.hasStructuralParent_of_matchesInput + (candidate : Probe) (parameter : PublicParameter) (input : HashInput) + (hmatch : candidate.MatchesInput parameter input) : + candidate.HasStructuralParent := by + rcases candidate with ⟨coordinate, digest⟩ + cases coordinate with + | chainStart lay tree leafIdx chainIdx => trivial + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + change ∃ parent, Position.parentOf (.chain lay tree leafIdx chainIdx step) = some parent + by_cases hnext : step.val + 1 < chainLength - 1 + · refine ⟨.chain lay tree leafIdx chainIdx ⟨step.val + 1, hnext⟩, ?_⟩ + rw [Position.parentOf, dif_pos hnext] + · refine ⟨.leaf lay tree leafIdx, ?_⟩ + rw [Position.parentOf, dif_neg hnext] + | leaf lay tree leafIdx => simp [Probe.MatchesInput] at hmatch + | node lay tree level nodeIdx => simp [Probe.MatchesInput] at hmatch + | ftsLeaf index tree leafIdx => simp [Probe.MatchesInput] at hmatch + | ftsNode index tree level nodeIdx => simp [Probe.MatchesInput] at hmatch + | ftsRoots index => simp [Probe.MatchesInput] at hmatch + +theorem Probe.hasStructuralParent_of_decodeProbe?_eq_some + (candidate : Probe) (parameter : PublicParameter) (input : HashInput) + (hdecode : decodeProbe? parameter input = some candidate) : + candidate.HasStructuralParent := by + exact candidate.hasStructuralParent_of_matchesInput parameter input + ((decodeProbe?_eq_some_iff parameter input candidate).mp hdecode) + +theorem firstMissingInputCoordinatePlan_some_mem + (state : LazyRevealProbe.State Coordinate) (input : HashInput) : + ∀ slot coordinates candidate, + firstMissingInputCoordinatePlan state input slot coordinates = some candidate → + candidate.coordinate ∈ coordinates := by + intro slot coordinates + induction coordinates generalizing slot with + | nil => simp [firstMissingInputCoordinatePlan] + | cons coordinate remaining ih => + intro candidate hplan + rw [firstMissingInputCoordinatePlan] at hplan + cases hvalue : state.values coordinate with + | none => + simp only [hvalue] at hplan + have hcand : candidate = ⟨coordinate, slotDigest slot input⟩ := + Option.some.inj hplan.symm + subst candidate + simp + | some output => + simp only [hvalue] at hplan + exact List.mem_cons_of_mem coordinate (ih (slot + 1) candidate hplan) + +theorem hasStructuralParent_of_mem_children_coordinates + (parent : Position) (candidate : Probe) + (hmem : candidate.coordinate ∈ parent.children.map Coordinate.position) : + candidate.HasStructuralParent := by + rw [List.mem_map] at hmem + obtain ⟨position, hposition, hcoordinate⟩ := hmem + have hparent : Position.parentOf position = some parent := + Position.mem_children_iff.mp hposition + unfold Probe.HasStructuralParent + rw [← hcoordinate] + exact ⟨parent, hparent⟩ + +theorem leafInputProbePlan_hasStructuralParent + (state : LazyRevealProbe.State Coordinate) + (input : HashInput) (candidate planned : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (hbase : candidate.HasStructuralParent) + (hplan : leafInputProbePlan state input candidate lay tree leafIdx = some planned) : + planned.HasStructuralParent := by + unfold leafInputProbePlan at hplan + cases hvalue : state.values candidate.coordinate with + | none => + simp only [hvalue] at hplan + exact Option.some.inj hplan.symm ▸ hbase + | some output => + simp only [hvalue] at hplan + exact hasStructuralParent_of_mem_children_coordinates (.leaf lay tree leafIdx) planned + (firstMissingInputCoordinatePlan_some_mem state input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) planned hplan) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenFresh.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenFresh.lean new file mode 100644 index 00000000..369d4a1b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenFresh.lean @@ -0,0 +1,215 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenRisk + +/-! +# Hidden candidate freshness transport + +The direct interpreter installs an auxiliary structural value only together with a materialized +state value. Since state values are never removed, absence of the final state value preserves +absence of the initial auxiliary value. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +def ChildValuesPublished (state : LazyRevealProbe.State Coordinate) : Prop := + ∀ position parent, Position.parentOf position = some parent → + state.values (.position position) ≠ none → + Coordinate.position position ∈ state.revealed + +theorem childValuesPublished_empty : + ChildValuesPublished (LazyRevealProbe.State.empty : + LazyRevealProbe.State Coordinate) := by + intro position parent hparent hvalue + simp [LazyRevealProbe.State.empty] at hvalue + +set_option maxRecDepth 100000 in +theorem auxiliaryPositionValue_none_of_done_runDirectResolvedWitnessFromTable + (position : Position) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hstate : context.state.values (.position position) = none) + (hprivate : context.values position = none) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) + (hfinalState : result.context.state.values (.position position) = none) : + result.context.values position = none := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runDirectResolvedWitnessFromTable] at hresult + subst result + exact hprivate + | query_bind query next ih => + cases query with + | uniform n => + rw [runDirectResolvedWitnessFromTable_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨sampled, _hsampled, htail⟩ := hresult + exact ih sampled context fuel hstate hprivate htail + | hashOutput => + rw [runDirectResolvedWitnessFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨sampled, _hsampled, htail⟩ := hresult + exact ih sampled context fuel hstate hprivate htail + | ensure coordinate => + rw [runDirectResolvedWitnessFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel hstate + hprivate hresult + | probe coordinate candidate => + rw [runDirectResolvedWitnessFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] at hresult + exact ih () context remaining hstate hprivate hresult + · simp only [hrevealed, ↓reduceIte] at hresult + exact ih () { context with state := context.state.addPending coordinate candidate } + remaining hstate hprivate hresult + | peek coordinate => + rw [runDirectResolvedWitnessFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hstate hprivate hresult + | publish coordinate => + rw [runDirectResolvedWitnessFromTable_publish_query_bind] at hresult + exact ih () { context with state := context.state.publish coordinate } fuel hstate + hprivate hresult + | reveal coordinate => + rw [runDirectResolvedWitnessFromTable_reveal_query_bind] at hresult + cases hvalue : context.state.values coordinate with + | some output => + simp only [hvalue] at hresult + exact ih output context fuel hstate hprivate hresult + | none => + simp only [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + have hnextState : + (context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output).values + (.position position) = none := by + simpa [LazyRevealProbe.State.materialize] using hstate + exact ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel hnextState hprivate hresult + | position revealed => + by_cases heq : revealed = position + · subst revealed + cases hprivateValue : context.values position with + | some output => + rw [hprivate] at hprivateValue + contradiction + | none => + simp only [hprivateValue] at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at htail + · simp only [hhit, ↓reduceIte] at htail + have hinstalled : + ({ state := context.state.materialize (.position position) output + values := context.values.install position output } : + DeferredContext).state.values (.position position) = some output := by + simp [LazyRevealProbe.State.materialize] + let nextContext : DeferredContext := + { state := context.state.materialize (.position position) output + values := context.values.install position output } + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable nextContext fuel table + (next output)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable (next output) + nextContext fuel table, support_map] + exact ⟨DirectWitnessResult.done result, htail, rfl⟩ + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + (next output) nextContext fuel table result hdetailed + have hraw := raw_done_of_mem_runDirectResolvedFromTable + (next output) nextContext fuel table result hdirect + have hvalues := LazyRevealProbe.valuesLE_of_mem_runRaw_done + (next output) nextContext.state result.context.state fuel + result.remaining result.value hraw + have hfalse : result.context.state.values (.position position) = + some output := hvalues (.position position) output hinstalled + rw [hfinalState] at hfalse + contradiction + · cases hprivateValue : context.values revealed with + | some output => + simp only [hprivateValue] at hresult + by_cases hhit : context.state.hitAt (.position revealed) output + · simp [hhit] at hresult + · simp only [hhit, ↓reduceIte] at hresult + have hnextState : + (context.state.materialize (.position revealed) output).values + (.position position) = none := by + have hcoordinate : Coordinate.position position ≠ + .position revealed := by simpa using Ne.symm heq + simpa [LazyRevealProbe.State.materialize, + Function.update_of_ne hcoordinate] using hstate + exact ih output + { state := context.state.materialize (.position revealed) output + values := context.values } + fuel hnextState hprivate hresult + | none => + simp only [hprivateValue] at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + by_cases hhit : context.state.hitAt (.position revealed) output + · simp [hhit] at htail + · simp only [hhit, ↓reduceIte] at htail + have hnextState : + (context.state.materialize (.position revealed) output).values + (.position position) = none := by + have hcoordinate : Coordinate.position position ≠ + .position revealed := by simpa using Ne.symm heq + simpa [LazyRevealProbe.State.materialize, + Function.update_of_ne hcoordinate] using hstate + have hnextPrivate : + (context.values.install revealed output) position = none := by + unfold DeferredStructuralValues.install + rw [Function.update_of_ne (Ne.symm heq)] + exact hprivate + exact ih output + { state := context.state.materialize (.position revealed) output + values := context.values.install revealed output } + fuel hnextState hnextPrivate htail + +theorem candidatePositionsFresh_canonicalize_of_done + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hfresh : CandidatePositionsFresh context) + (hpublished : PublishedValues context.state) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) + (hchildren : ChildValuesPublished result.context.state) : + CandidatePositionsFresh (canonicalizeMaterializedValues table result.context) := by + intro position parent hparent hcanonicalHidden + have hfinalHidden : Coordinate.position position ∉ result.context.state.revealed := by + simpa [canonicalizeMaterializedValues_revealed] using hcanonicalHidden + have hinitialHidden : Coordinate.position position ∉ context.state.revealed := by + intro hinitialRevealed + obtain ⟨output, hvalue⟩ := Option.ne_none_iff_exists'.mp + (hpublished (.position position) hinitialRevealed) + have hknown := knownPublishedCoordinateResult_of_mem_runDirectResolvedWitnessFromTable + (.position position) output computation context fuel table hvalue hinitialRevealed + (DirectWitnessResult.done result) hresult + exact hfinalHidden hknown.2 + have hinitialFresh := hfresh position parent hparent hinitialHidden + have hfinalState : result.context.state.values (.position position) = none := by + by_contra hvalue + exact hfinalHidden (hchildren position parent hparent hvalue) + have hfinalPrivate := auxiliaryPositionValue_none_of_done_runDirectResolvedWitnessFromTable + position computation context fuel table result hinitialFresh.1 hinitialFresh.2 hresult + hfinalState + constructor + · unfold canonicalizeMaterializedValues publicMaterializedValues + simp [hfinalHidden] + · exact hfinalPrivate + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenFreshSigner.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenFreshSigner.lean new file mode 100644 index 00000000..30c21000 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenFreshSigner.lean @@ -0,0 +1,552 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateRootCandidate +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenFreshSteps + +/-! +# Signer freshness + +The masked signer can materialize an unpublished position only while computing a layer message. +Such a position is exactly the root of the tree below that layer. Every other coordinate is either +left unchanged or revealed together with publication. This file isolates those exceptional roots +from the candidate-freshness argument. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +theorem rootAwarePlannedCandidate?_hasStructuralParent + {parameter : PublicParameter} {input : HashInput} + {state : LazyRevealProbe.State Coordinate} {candidate : Probe} + (hplan : rootAwarePlannedCandidate? parameter input state = some candidate) : + candidate.HasStructuralParent := by + unfold rootAwarePlannedCandidate? at hplan + cases hstructural : (purePlanProbingHashQuery parameter input state).candidate? with + | some structural => + simp only [hstructural] at hplan + have heq : candidate = structural := by simpa using hplan.symm + subst candidate + exact purePlanProbingHashQuery_candidate_hasStructuralParent parameter input state + structural hstructural + | none => + simp only [hstructural] at hplan + exact encodingLayerRootCandidateAt_hasStructuralParent + ((decodeEncodingLayerRootCandidate?_eq_some_iff parameter input candidate).mp hplan) + +theorem PreservesCoordinate.sequenceFin + {coordinate : Coordinate} {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomputation : ∀ index, PreservesCoordinate coordinate (computation index)) : + PreservesCoordinate coordinate (sequenceFin computation) := by + induction n with + | zero => exact preservesCoordinate_pure coordinate Fin.elim0 + | succ n ih => + rw [SphincsSecurity.Concrete.sequenceFin] + exact (hcomputation 0).bind fun head => + (ih (fun index => computation index.succ) + (fun index => hcomputation index.succ)).bind fun tail => + preservesCoordinate_pure coordinate + (Fin.cases head tail : Fin (n + 1) → α) + +theorem PreservesCoordinate.simulateQ + {spec : OracleSpec ι} {coordinate : Coordinate} + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (himpl : ∀ query, PreservesCoordinate coordinate (impl query)) + (computation : OracleComp spec α) : + PreservesCoordinate coordinate (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => exact preservesCoordinate_pure coordinate value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (himpl query).bind ih + +theorem preservesCoordinate_ensureCoordinate + (coordinate ensured : Coordinate) : + PreservesCoordinate coordinate (ensureCoordinate ensured) := by + intro state cache fuel finalState remaining value finalCache hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + (LazyRevealProbe.ensureQuery ensured >>= fun result => pure (result, cache))) at hresult + rw [LazyRevealProbe.ensureQuery, LazyRevealProbe.runRaw_ensure_query_bind] at hresult + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + simp [LazyRevealProbe.State.ensure] + +theorem preservesCoordinate_simulateQ_ordinaryHashImpl + (coordinate : Coordinate) (computation : OracleComp HashSpec α) : + PreservesCoordinate coordinate (simulateQ ordinaryHashImpl computation) := + PreservesCoordinate.simulateQ ordinaryHashImpl + (fun input => preservesCoordinate_splitHashQuery coordinate (.ordinary input)) computation + +theorem preservesCoordinate_simulateQ_splitUniformImpl + (coordinate : Coordinate) (computation : ProbComp α) : + PreservesCoordinate coordinate (simulateQ splitUniformImpl computation) := by + intro state cache fuel finalState remaining value finalCache hresult + obtain ⟨rfl, rfl, _hcache, _hvalue⟩ := + mem_runRaw_simulateQ_splitUniformImpl_projects computation state finalState cache finalCache + fuel remaining value hresult + exact ⟨rfl, Iff.rfl⟩ + +theorem preservesCoordinate_ensureFullChain + (coordinate : Coordinate) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + PreservesCoordinate coordinate (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (PreservesCoordinate.sequenceFin _ fun step => + preservesCoordinate_ensureCoordinate coordinate + (.position (.chain lay tree leafIdx chainIdx step))).bind fun _ => + preservesCoordinate_pure coordinate () + +theorem preservesCoordinate_ensureChainPrefix + (coordinate : Coordinate) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + PreservesCoordinate coordinate (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (PreservesCoordinate.sequenceFin _ fun step => by + split + · exact preservesCoordinate_ensureCoordinate coordinate + (.position (.chain lay tree leafIdx chainIdx step)) + · exact preservesCoordinate_pure coordinate ()).bind fun _ => + preservesCoordinate_pure coordinate () + +theorem preservesCoordinate_ensureOtsLeaf + (coordinate : Coordinate) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + PreservesCoordinate coordinate (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (PreservesCoordinate.sequenceFin _ fun chainIdx => + preservesCoordinate_ensureFullChain coordinate lay tree leafIdx chainIdx).bind fun _ => + preservesCoordinate_ensureCoordinate coordinate (.position (.leaf lay tree leafIdx)) + +theorem preservesCoordinate_ensureTreeNode + (coordinate : Coordinate) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, PreservesCoordinate coordinate (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => by + rw [ensureTreeNode] + exact preservesCoordinate_ensureOtsLeaf coordinate lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (preservesCoordinate_ensureTreeNode coordinate lay tree level + (2 * nodeIdx)).bind fun _ => + (preservesCoordinate_ensureTreeNode coordinate lay tree level + (2 * nodeIdx + 1)).bind fun _ => by + split + · exact preservesCoordinate_ensureCoordinate coordinate _ + · exact preservesCoordinate_pure coordinate () + +theorem preservesCoordinate_ensureTreePath + (coordinate : Coordinate) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + PreservesCoordinate coordinate (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (PreservesCoordinate.sequenceFin _ fun level => by + split + · exact preservesCoordinate_ensureTreeNode coordinate lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · exact preservesCoordinate_pure coordinate ()).bind fun _ => + preservesCoordinate_pure coordinate () + +theorem preservesCoordinate_maskedTreeRoot_of_not_layerRoot + (position : Position) (hnotRoot : ¬IsLayerRoot position) + (lay : Layer) (tree : TreeIndex) : + PreservesCoordinate (.position position) (maskedTreeRoot lay tree) := by + have hpos : 0 < layerHeight lay := by + unfold layerHeight + split <;> norm_num [maxLayerHeight] + have hlevel : layerHeight lay - 1 < maxLayerHeight := by + have hle := layerHeight_le lay + omega + have hne : Coordinate.position position ≠ + .position (.node lay tree ⟨layerHeight lay - 1, hlevel⟩ (leafOfNat 0)) := by + intro heq + have hposition : position = + .node lay tree ⟨layerHeight lay - 1, hlevel⟩ (leafOfNat 0) := by + simpa using heq + apply hnotRoot + refine ⟨lay, tree, ?_⟩ + rw [hposition] + rfl + unfold maskedTreeRoot + rw [show layerHeight lay = (layerHeight lay - 1) + 1 by omega, maskedTreeNode] + exact (preservesCoordinate_ensureTreeNode (.position position) lay tree + (layerHeight lay - 1 + 1) 0).bind fun _ => by + rw [dif_pos hlevel] + exact preservesCoordinate_revealPosition_of_ne (.position position) + (.node lay tree ⟨layerHeight lay - 1, hlevel⟩ (leafOfNat 0)) hne + +theorem preservesCoordinate_maskedLayerMessage_of_not_layerRoot + (position : Position) (hnotRoot : ¬IsLayerRoot position) + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + PreservesCoordinate (.position position) + (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + split + · exact preservesCoordinate_maskedTreeRoot_of_not_layerRoot position hnotRoot _ _ + · exact preservesCoordinate_simulateQ_ordinaryHashImpl (.position position) _ + +theorem preservesCoordinate_maskedOtsSignFrom + (coordinate : Coordinate) (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter, + PreservesCoordinate coordinate + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, _ => preservesCoordinate_pure coordinate none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + exact (preservesCoordinate_simulateQ_ordinaryHashImpl coordinate _).bind fun encoded => + match encoded with + | none => preservesCoordinate_maskedOtsSignFrom coordinate parameter lay tree leafIdx + message attempts (counter + 1) + | some encoding => + (PreservesCoordinate.sequenceFin _ fun chainIdx => + preservesCoordinate_ensureChainPrefix coordinate lay tree leafIdx chainIdx + (encoding chainIdx)).bind fun _ => preservesCoordinate_pure coordinate _ + +theorem preservesCoordinate_maskedOtsSign + (coordinate : Coordinate) (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + PreservesCoordinate coordinate (maskedOtsSign parameter lay tree leafIdx message) := + preservesCoordinate_maskedOtsSignFrom coordinate parameter lay tree leafIdx message + encodingAttemptLimit 0 + +theorem preservesCoordinateMaterializedPublished_maskedSignLayer_of_not_layerRoot + (position : Position) (hnotRoot : ¬IsLayerRoot position) + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + PreservesCoordinateMaterializedPublished (.position position) + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + apply (preservesCoordinate_maskedLayerMessage_of_not_layerRoot position hnotRoot parameter + ftsSecret index lay).to_materializedPublished.bind + intro message + apply (preservesCoordinate_maskedOtsSign (.position position) parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) message).to_materializedPublished.bind + intro selected + cases selected with + | none => exact (preservesCoordinate_pure (.position position) none).to_materializedPublished + | some selected => + exact (preservesCoordinate_ensureTreePath (.position position) lay + (treeIndexAt index lay) (leafIndexAt index lay)).to_materializedPublished.bind fun _ => + (preservesCoordinate_pure (.position position) (some selected)).to_materializedPublished + +theorem preservesCoordinateMaterializedPublished_revealPublishedCoordinate + (coordinate : Coordinate) : + PreservesCoordinateMaterializedPublished coordinate + (revealPublishedCoordinate coordinate) := by + intro state cache fuel finalState remaining value finalCache hvalid hresult + unfold revealPublishedCoordinate at hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨revealRaw, hreveal, hrest⟩ := hresult + cases revealRaw with + | stopped hit => simp at hrest + | done revealState revealRemaining revealResult => + rcases revealResult with ⟨revealed, revealCache⟩ + simp [publishCoordinate, LazyRevealProbe.publishQuery, + LazyRevealProbe.runRaw] at hrest + rcases hrest with ⟨rfl, rfl, rfl, rfl⟩ + intro _hvalue + simp [LazyRevealProbe.State.publish] + +theorem preservesCoordinateMaterializedPublished_revealPublishedCoordinate_at + (coordinate published : Coordinate) : + PreservesCoordinateMaterializedPublished coordinate + (revealPublishedCoordinate published) := by + by_cases heq : coordinate = published + · subst published + exact preservesCoordinateMaterializedPublished_revealPublishedCoordinate coordinate + · unfold revealPublishedCoordinate + exact ((preservesCoordinate_revealCoordinate_of_ne coordinate published heq).bind + fun _ => (preservesCoordinate_publishCoordinate_of_ne coordinate published heq).bind + fun _ => preservesCoordinate_pure coordinate _).to_materializedPublished + +theorem PreservesCoordinateMaterializedPublished.sequenceFin + {coordinate : Coordinate} {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomputation : ∀ index, + PreservesCoordinateMaterializedPublished coordinate (computation index)) : + PreservesCoordinateMaterializedPublished coordinate (sequenceFin computation) := by + induction n with + | zero => exact (preservesCoordinate_pure coordinate Fin.elim0).to_materializedPublished + | succ n ih => + rw [SphincsSecurity.Concrete.sequenceFin] + exact (hcomputation 0).bind fun head => + (ih (fun index => computation index.succ) + (fun index => hcomputation index.succ)).bind fun tail => + (preservesCoordinate_pure coordinate + (Fin.cases head tail : Fin (n + 1) → α)).to_materializedPublished + +theorem preservesCoordinateMaterializedPublished_revealLayerValues + (coordinate : Coordinate) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + PreservesCoordinateMaterializedPublished coordinate + (revealLayerValues index lay encoding) := by + unfold revealLayerValues + apply (PreservesCoordinateMaterializedPublished.sequenceFin _ fun chainIdx => + preservesCoordinateMaterializedPublished_revealPublishedCoordinate_at coordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + (encoding chainIdx))).bind + intro _ + apply (PreservesCoordinateMaterializedPublished.sequenceFin _ fun level => by + split + · cases hvalue : level.val with + | zero => + exact preservesCoordinateMaterializedPublished_revealPublishedCoordinate_at coordinate _ + | succ current => + rw [show current + 1 = Nat.succ current by omega] + change PreservesCoordinateMaterializedPublished coordinate + (if hlevel : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hlevel⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0) + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact preservesCoordinateMaterializedPublished_revealPublishedCoordinate_at coordinate _ + · rw [dif_neg hlevel] + exact (preservesCoordinate_pure coordinate 0).to_materializedPublished + · exact (preservesCoordinate_pure coordinate 0).to_materializedPublished).bind + intro _ + exact (preservesCoordinate_pure coordinate _).to_materializedPublished + +theorem preservesCoordinate_simulateQ_ordinaryRomImpl + (coordinate : Coordinate) (computation : OracleComp OracleWorld α) : + PreservesCoordinate coordinate (simulateQ ordinaryRomImpl computation) := by + apply PreservesCoordinate.simulateQ ordinaryRomImpl + intro query + cases query with + | inl n => + exact preservesCoordinate_simulateQ_splitUniformImpl coordinate + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) + | inr input => exact preservesCoordinate_splitHashQuery coordinate (.ordinary input) + +theorem preservesCoordinateMaterializedPublished_maskedSignAfterDigest_of_not_layerRoot + (position : Position) (hnotRoot : ¬IsLayerRoot position) + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + PreservesCoordinateMaterializedPublished (.position position) + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest + apply (preservesCoordinate_simulateQ_ordinaryHashImpl (.position position) _).to_materializedPublished.bind + intro _ + apply (PreservesCoordinateMaterializedPublished.sequenceFin _ fun lay => + preservesCoordinateMaterializedPublished_maskedSignLayer_of_not_layerRoot position hnotRoot + parameter ftsSecret index lay).bind + intro layers + cases hparts : traverseOption layers with + | none => exact (preservesCoordinate_pure (.position position) none).to_materializedPublished + | some parts => + apply (PreservesCoordinateMaterializedPublished.sequenceFin _ fun lay => + preservesCoordinateMaterializedPublished_revealLayerValues (.position position) index lay + (parts lay).2).bind + intro _ + exact (preservesCoordinate_pure (.position position) _).to_materializedPublished + +theorem preservesCoordinateMaterializedPublished_maskedSign_of_not_layerRoot + (position : Position) (hnotRoot : ¬IsLayerRoot position) + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + PreservesCoordinateMaterializedPublished (.position position) + (maskedSign parameter root ftsSecret message) := by + unfold maskedSign + apply (preservesCoordinate_simulateQ_ordinaryRomImpl (.position position) _).to_materializedPublished.bind + intro selected + cases selected with + | none => exact (preservesCoordinate_pure (.position position) none).to_materializedPublished + | some selected => + exact preservesCoordinateMaterializedPublished_maskedSignAfterDigest_of_not_layerRoot + position hnotRoot parameter ftsSecret selected.1 selected.2.1 selected.2.2 + +def CandidatePositionsFreshExceptLayerRoots (context : DeferredContext) : Prop := + ∀ position parent, Position.parentOf position = some parent → + Coordinate.position position ∉ context.state.revealed → + (context.state.values (.position position) = none ∧ context.values position = none) ∨ + IsLayerRoot position + +theorem probEvent_hiddenPrivateCandidateFire_le_of_freshExceptLayerRoots + (candidate : Probe) (context : DeferredContext) + (hparent : candidate.HasStructuralParent) + (hnotRoot : ¬ (Probe.IsLayerRoot candidate)) + (hfresh : CandidatePositionsFreshExceptLayerRoots context) : + Pr[= true | hiddenPrivateCandidateFire candidate context] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · simp [hiddenPrivateCandidateFire, hrevealed] + · rw [hiddenPrivateCandidateFire_of_not_revealed candidate context hrevealed] + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [privateCandidateFire, hcoordinate] + | position position => + simp only [Probe.HasStructuralParent, hcoordinate] at hparent + obtain ⟨parent, hpositionParent⟩ := hparent + have hpositionHidden : Coordinate.position position ∉ context.state.revealed := by + simpa [hcoordinate] using hrevealed + rcases hfresh position parent hpositionParent hpositionHidden with + hpositionFresh | hroot + · exact probEvent_privateCandidateFire_le_of_fresh candidate context + (by + intro other hother + have : position = other := by simpa [hcoordinate] using hother + subst other + exact hpositionFresh.1) + (by + intro other hother + have : position = other := by simpa [hcoordinate] using hother + subst other + exact hpositionFresh.2) + · exact False.elim (hnotRoot ⟨position, hcoordinate, hroot⟩) + +theorem CandidatePositionsFresh.exceptLayerRoots + {context : DeferredContext} (hfresh : CandidatePositionsFresh context) : + CandidatePositionsFreshExceptLayerRoots context := by + intro position parent hparent hhidden + exact Or.inl (hfresh position parent hparent hhidden) + +theorem CandidatePositionsFreshExceptLayerRoots.canonicalize + {context : DeferredContext} (hfresh : CandidatePositionsFreshExceptLayerRoots context) + (table : OtsSecretIndex → HashOutput) : + CandidatePositionsFreshExceptLayerRoots + (canonicalizeMaterializedValues table context) := by + intro position parent hparent hhidden + have horiginalHidden : Coordinate.position position ∉ context.state.revealed := by + simpa [canonicalizeMaterializedValues_revealed] using hhidden + rcases hfresh position parent hparent horiginalHidden with hfreshPosition | hroot + · left + constructor + · unfold canonicalizeMaterializedValues publicMaterializedValues + simp [horiginalHidden] + · exact hfreshPosition.2 + · exact Or.inr hroot + +theorem candidatePositionsFreshExceptLayerRoots_uniformStep + (n : Nat) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (Fin (n + 1) × SplitHashCache)) + (hfresh : CandidatePositionsFreshExceptLayerRoots context) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table + ((splitUniformImpl n).run cache))) : + CandidatePositionsFreshExceptLayerRoots + (canonicalizeMaterializedValues table result.context) := by + unfold splitUniformImpl at hresult + rw [StateT.run_liftM, LazyRevealProbe.uniformQuery, + runDirectResolvedWitnessFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + simp [runDirectResolvedWitnessFromTable] at htail + subst result + exact hfresh.canonicalize table + +theorem candidatePositionsFreshExceptLayerRoots_hashStep + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (HashOutput × SplitHashCache)) + (hfresh : CandidatePositionsFreshExceptLayerRoots context) + (hpublished : PublishedValues context.state) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache))) : + CandidatePositionsFreshExceptLayerRoots + (canonicalizeMaterializedValues table result.context) := by + let computation := (probingHashQueryAfterPlan parameter input plan).run cache + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) := by + rw [← map_erase_runDirectResolvedWitnessFromTable computation context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed computation context fuel + table result hdetailed + have hraw := raw_done_of_mem_runDirectResolvedFromTable computation context fuel table result + hdirect + intro position parent hparent hhidden + by_cases hroot : IsLayerRoot position + · exact Or.inr hroot + · left + have hfinalHidden : Coordinate.position position ∉ result.context.state.revealed := by + simpa [canonicalizeMaterializedValues_revealed] using hhidden + have hinitialHidden : Coordinate.position position ∉ context.state.revealed := by + intro hinitialRevealed + obtain ⟨output, hvalue⟩ := Option.ne_none_iff_exists'.mp + (hpublished (.position position) hinitialRevealed) + have hknown := knownPublishedCoordinateResult_of_mem_runDirectResolvedWitnessFromTable + (.position position) output computation context fuel table hvalue hinitialRevealed + (DirectWitnessResult.done result) hresult + exact hfinalHidden hknown.2 + have hinitialFresh : context.state.values (.position position) = none ∧ + context.values position = none := by + rcases hfresh position parent hparent hinitialHidden with hfreshPosition | hrootPosition + · exact hfreshPosition + · exact False.elim (hroot hrootPosition) + have hfinalState : result.context.state.values (.position position) = none := by + by_contra hvalue + exact hfinalHidden + (preservesCoordinateMaterializedPublished_probingHashQueryAfterPlan parameter input plan + (.position position) context.state cache fuel result.context.state result.remaining + result.value.1 result.value.2 + (fun hvalue => False.elim (hvalue hinitialFresh.1)) hraw hvalue) + have hfinalPrivate := auxiliaryPositionValue_none_of_done_runDirectResolvedWitnessFromTable + position computation context fuel table result hinitialFresh.1 hinitialFresh.2 hresult + hfinalState + constructor + · unfold canonicalizeMaterializedValues publicMaterializedValues + simp [hfinalHidden] + · exact hfinalPrivate + +theorem candidatePositionsFreshExceptLayerRoots_signStep + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (hfresh : CandidatePositionsFreshExceptLayerRoots context) + (hpublished : PublishedValues context.state) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table + ((maskedSign parameter root ftsSecret message).run cache))) : + CandidatePositionsFreshExceptLayerRoots + (canonicalizeMaterializedValues table result.context) := by + let computation := (maskedSign parameter root ftsSecret message).run cache + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) := by + rw [← map_erase_runDirectResolvedWitnessFromTable computation context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed computation context fuel + table result hdetailed + have hraw := raw_done_of_mem_runDirectResolvedFromTable computation context fuel table result + hdirect + intro position parent hparent hhidden + by_cases hrootPosition : IsLayerRoot position + · exact Or.inr hrootPosition + · left + have hfinalHidden : Coordinate.position position ∉ result.context.state.revealed := by + simpa [canonicalizeMaterializedValues_revealed] using hhidden + have hinitialHidden : Coordinate.position position ∉ context.state.revealed := by + intro hinitialRevealed + obtain ⟨output, hvalue⟩ := Option.ne_none_iff_exists'.mp + (hpublished (.position position) hinitialRevealed) + have hknown := knownPublishedCoordinateResult_of_mem_runDirectResolvedWitnessFromTable + (.position position) output computation context fuel table hvalue hinitialRevealed + (DirectWitnessResult.done result) hresult + exact hfinalHidden hknown.2 + have hinitialFresh : context.state.values (.position position) = none ∧ + context.values position = none := by + rcases hfresh position parent hparent hinitialHidden with hfreshPosition | hroot + · exact hfreshPosition + · exact False.elim (hrootPosition hroot) + have hfinalState : result.context.state.values (.position position) = none := by + by_contra hvalue + exact hfinalHidden + (preservesCoordinateMaterializedPublished_maskedSign_of_not_layerRoot position + hrootPosition parameter root ftsSecret message context.state cache fuel + result.context.state result.remaining result.value.1 result.value.2 + (fun hvalue => False.elim (hvalue hinitialFresh.1)) hraw hvalue) + have hfinalPrivate := auxiliaryPositionValue_none_of_done_runDirectResolvedWitnessFromTable + position computation context fuel table result hinitialFresh.1 hinitialFresh.2 hresult + hfinalState + constructor + · unfold canonicalizeMaterializedValues publicMaterializedValues + simp [hfinalHidden] + · exact hfinalPrivate + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenFreshSteps.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenFreshSteps.lean new file mode 100644 index 00000000..6f2dec42 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenFreshSteps.lean @@ -0,0 +1,214 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenRiskBound + +/-! +# Local freshness steps + +Canonicalization preserves candidate freshness, and a uniform outer query leaves the deferred +context unchanged. These discharge the uniform premise of the one-unit hidden ordinal theorem. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +theorem CandidatePositionsFresh.canonicalize + {context : DeferredContext} (hfresh : CandidatePositionsFresh context) + (table : OtsSecretIndex → HashOutput) : + CandidatePositionsFresh (canonicalizeMaterializedValues table context) := by + intro position parent hparent hhidden + have horiginalHidden : Coordinate.position position ∉ context.state.revealed := by + simpa [canonicalizeMaterializedValues_revealed] using hhidden + have hpositionFresh := hfresh position parent hparent horiginalHidden + constructor + · unfold canonicalizeMaterializedValues publicMaterializedValues + simp [horiginalHidden] + · exact hpositionFresh.2 + +theorem candidatePositionsFresh_uniformStep + (n : Nat) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (Fin (n + 1) × SplitHashCache)) + (hfresh : CandidatePositionsFresh context) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table + ((splitUniformImpl n).run cache))) : + CandidatePositionsFresh (canonicalizeMaterializedValues table result.context) := by + unfold splitUniformImpl at hresult + rw [StateT.run_liftM, LazyRevealProbe.uniformQuery, + runDirectResolvedWitnessFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + simp [runDirectResolvedWitnessFromTable] at htail + subst result + exact hfresh.canonicalize table + +def CoordinateMaterializedPublished + (coordinate : Coordinate) (state : LazyRevealProbe.State Coordinate) : Prop := + state.values coordinate ≠ none → coordinate ∈ state.revealed + +def PreservesCoordinateMaterializedPublished + (coordinate : Coordinate) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ state cache fuel finalState remaining value finalCache, + CoordinateMaterializedPublished coordinate state → + LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run cache)) → + CoordinateMaterializedPublished coordinate finalState + +theorem PreservesCoordinate.to_materializedPublished + {coordinate : Coordinate} + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + (hpreserves : PreservesCoordinate coordinate computation) : + PreservesCoordinateMaterializedPublished coordinate computation := by + intro state cache fuel finalState remaining value finalCache hvalid hresult + have hsame := hpreserves state cache fuel finalState remaining value finalCache hresult + intro hvalue + apply hsame.2.mpr + apply hvalid + rwa [hsame.1] at hvalue + +theorem PreservesCoordinateMaterializedPublished.bind + {coordinate : Coordinate} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : PreservesCoordinateMaterializedPublished coordinate left) + (hnext : ∀ value, PreservesCoordinateMaterializedPublished coordinate (next value)) : + PreservesCoordinateMaterializedPublished coordinate (left >>= next) := by + intro state cache fuel finalState remaining value finalCache hvalid hresult + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel + (left.run cache >>= fun leftResult => (next leftResult.1).run leftResult.2)) at hresult + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨raw, hraw, hrest⟩ := hresult + cases raw with + | stopped hit => simp at hrest + | done middleState middleRemaining leftResult => + exact hnext leftResult.1 middleState leftResult.2 middleRemaining finalState remaining + value finalCache (hleft state cache fuel middleState middleRemaining leftResult.1 + leftResult.2 hvalid hraw) hrest + +theorem preservesCoordinateMaterializedPublished_revealOutput_publish + (coordinate : Coordinate) : + PreservesCoordinateMaterializedPublished coordinate (do + let output ← revealCoordinateOutput coordinate + publishCoordinate coordinate + pure output) := by + intro state cache fuel finalState remaining value finalCache hvalid hresult + rw [StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨revealRaw, hreveal, hrest⟩ := hresult + cases revealRaw with + | stopped hit => simp at hrest + | done revealState revealRemaining revealResult => + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw revealState revealRemaining + ((publishCoordinate coordinate).run revealResult.2 >>= fun publishResult => + pure (revealResult.1, publishResult.2))) at hrest + rw [LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hrest + obtain ⟨publishRaw, hpublish, hreturn⟩ := hrest + cases publishRaw with + | stopped hit => simp at hreturn + | done publishState publishRemaining publishResult => + change LazyRevealProbe.RawResult.done publishState publishRemaining publishResult ∈ + support (LazyRevealProbe.runRaw revealState revealRemaining + (LazyRevealProbe.publishQuery coordinate >>= fun result => + pure (result, revealResult.2))) at hpublish + rw [LazyRevealProbe.publishQuery, + LazyRevealProbe.runRaw_publish_query_bind] at hpublish + simp [LazyRevealProbe.runRaw] at hpublish + rcases hpublish with ⟨rfl, rfl, rfl, rfl⟩ + simp [LazyRevealProbe.runRaw] at hreturn + rcases hreturn with ⟨rfl, rfl, rfl, rfl⟩ + intro _hvalue + simp [LazyRevealProbe.State.publish] + +theorem preservesCoordinateMaterializedPublished_resolveKnownInput + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) : + PreservesCoordinateMaterializedPublished coordinate + (resolveKnownInput parameter coordinate input) := by + unfold resolveKnownInput + apply ((rawReadOnly_peekTableInput parameter coordinate).preservesCoordinate + coordinate).to_materializedPublished.bind + intro known + cases known with + | none => + exact (preservesCoordinate_splitHashQuery coordinate (.ordinary input)).to_materializedPublished + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + have hpreserves := + (preservesCoordinateMaterializedPublished_revealOutput_publish coordinate).bind + fun output => (preservesCoordinate_modify coordinate fun cache => + Function.update cache (.ordinary input) + (some output)).to_materializedPublished.bind + fun _ => (preservesCoordinate_pure coordinate output).to_materializedPublished + simpa only [bind_assoc, pure_bind] using hpreserves + · simp only [heq, ↓reduceIte] + exact (preservesCoordinate_splitHashQuery coordinate + (.ordinary input)).to_materializedPublished + +theorem preservesCoordinateMaterializedPublished_executeCandidate + (coordinate : Coordinate) : ∀ candidate? : Option Probe, + PreservesCoordinateMaterializedPublished coordinate (executeCandidate? candidate?) + | none => (preservesCoordinate_pure coordinate ()).to_materializedPublished + | some candidate => (preservesCoordinate_probe coordinate candidate).to_materializedPublished + +theorem preservesCoordinateMaterializedPublished_probingHashQueryAfterPlan + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (coordinate : Coordinate) : + PreservesCoordinateMaterializedPublished coordinate + (probingHashQueryAfterPlan parameter input plan) := by + unfold probingHashQueryAfterPlan executePlannedHashQuery + apply (preservesCoordinateMaterializedPublished_executeCandidate coordinate + plan.candidate?).bind + intro _ + cases plan.action with + | ordinary => exact (preservesCoordinate_splitHashQuery coordinate + (.ordinary input)).to_materializedPublished + | resolve resolved => + by_cases heq : coordinate = resolved + · subst resolved + exact preservesCoordinateMaterializedPublished_resolveKnownInput parameter coordinate input + · exact (preservesCoordinate_resolveKnownInput_of_ne parameter coordinate resolved input + heq).to_materializedPublished + +theorem CandidatePositionsFresh.childValuesPublished + {context : DeferredContext} (hfresh : CandidatePositionsFresh context) : + ChildValuesPublished context.state := by + intro position parent hparent hvalue + by_contra hhidden + exact hvalue (hfresh position parent hparent hhidden).1 + +theorem candidatePositionsFresh_hashStep + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (HashOutput × SplitHashCache)) + (hfresh : CandidatePositionsFresh context) + (hpublished : PublishedValues context.state) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache))) : + CandidatePositionsFresh (canonicalizeMaterializedValues table result.context) := by + let computation := (probingHashQueryAfterPlan parameter input plan).run cache + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) := by + rw [← map_erase_runDirectResolvedWitnessFromTable computation context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed computation context fuel + table result hdetailed + have hraw := raw_done_of_mem_runDirectResolvedFromTable computation context fuel table result + hdirect + have hchildren : ChildValuesPublished result.context.state := by + intro position parent hparent + exact preservesCoordinateMaterializedPublished_probingHashQueryAfterPlan parameter input plan + (.position position) context.state cache fuel result.context.state result.remaining + result.value.1 result.value.2 + (hfresh.childValuesPublished position parent hparent) hraw + exact candidatePositionsFresh_canonicalize_of_done computation context fuel table result hfresh + hpublished hresult hchildren + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenMatch.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenMatch.lean new file mode 100644 index 00000000..cd85c1f2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenMatch.lean @@ -0,0 +1,325 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenPlanFinal + +/-! +# Hidden fixed-candidate matching + +A coordinate that is already published stays published through the direct interpreter, and a +private stop cannot name it. This strengthens the post-selection observer from the ungated +candidate risk to the hidden candidate risk. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +def KnownPublishedCoordinateResult + (coordinate : Coordinate) (output : HashOutput) : DirectWitnessResult α → Prop + | .stoppedPrivate witness => coordinate ≠ .position witness.position + | .done result => + result.context.state.values coordinate = some output ∧ + coordinate ∈ result.context.state.revealed + | _ => True + +set_option maxRecDepth 100000 in +theorem knownPublishedCoordinateResult_of_mem_runDirectResolvedWitnessFromTable + (coordinate : Coordinate) (output : HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hvalue : context.state.values coordinate = some output) + (hrevealed : coordinate ∈ context.state.revealed) : + ∀ result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation), + KnownPublishedCoordinateResult coordinate output result := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + intro result hresult + simp [runDirectResolvedWitnessFromTable] at hresult + subst result + exact ⟨hvalue, hrevealed⟩ + | query_bind query next ih => + cases query with + | uniform n => + rw [runDirectResolvedWitnessFromTable_uniform_query_bind] + intro result hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨sampled, _hsampled, htail⟩ := hresult + exact ih sampled context fuel hvalue hrevealed result htail + | hashOutput => + rw [runDirectResolvedWitnessFromTable_hashOutput_query_bind] + intro result hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨sampled, _hsampled, htail⟩ := hresult + exact ih sampled context fuel hvalue hrevealed result htail + | ensure ensured => + rw [runDirectResolvedWitnessFromTable_ensure_query_bind] + intro result hresult + exact ih () { context with state := context.state.ensure ensured } fuel hvalue + hrevealed result hresult + | probe probed candidate => + rw [runDirectResolvedWitnessFromTable_probe_query_bind] + intro result hresult + cases fuel with + | zero => + simp at hresult + subst result + trivial + | succ remaining => + by_cases hprobedRevealed : probed ∈ context.state.revealed + · simp only [hprobedRevealed, ↓reduceIte] at hresult + exact ih () context remaining hvalue hrevealed result hresult + · simp only [hprobedRevealed, ↓reduceIte] at hresult + exact ih () { context with state := context.state.addPending probed candidate } + remaining hvalue hrevealed result hresult + | peek peeked => + rw [runDirectResolvedWitnessFromTable_peek_query_bind] + intro result hresult + exact ih (context.state.values peeked) context fuel hvalue hrevealed result hresult + | publish published => + rw [runDirectResolvedWitnessFromTable_publish_query_bind] + intro result hresult + exact ih () { context with state := context.state.publish published } fuel hvalue + (by simp [LazyRevealProbe.State.publish, hrevealed]) result hresult + | reveal revealed => + rw [runDirectResolvedWitnessFromTable_reveal_query_bind] + intro result hresult + cases hrevealedValue : context.state.values revealed with + | some revealedOutput => + simp only [hrevealedValue] at hresult + exact ih revealedOutput context fuel hvalue hrevealed result hresult + | none => + simp only [hrevealedValue] at hresult + have hne : revealed ≠ coordinate := by + intro heq + subst revealed + rw [hvalue] at hrevealedValue + contradiction + cases revealed with + | chainStart lay tree leafIdx chainIdx => + let revealedOutput := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) revealedOutput + · simp [revealedOutput, hhit] at hresult + subst result + trivial + · simp only [revealedOutput, hhit, ↓reduceIte] at hresult + have hnextValue : + (context.state.materialize + (.chainStart lay tree leafIdx chainIdx) revealedOutput).values + coordinate = some output := by + simpa [LazyRevealProbe.State.materialize, + Function.update_of_ne (Ne.symm hne)] using hvalue + exact ih revealedOutput + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) revealedOutput + values := context.values } + fuel hnextValue hrevealed result hresult + | position position => + cases hprivate : context.values position with + | some revealedOutput => + by_cases hhit : context.state.hitAt (.position position) revealedOutput + · simp [hprivate, hhit] at hresult + subst result + exact Ne.symm hne + · simp only [hprivate, hhit, ↓reduceIte] at hresult + have hnextValue : + (context.state.materialize (.position position) revealedOutput).values + coordinate = some output := by + simpa [LazyRevealProbe.State.materialize, + Function.update_of_ne (Ne.symm hne)] using hvalue + exact ih revealedOutput + { state := context.state.materialize (.position position) revealedOutput + values := context.values } + fuel hnextValue hrevealed result hresult + | none => + simp only [hprivate] at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨revealedOutput, _houtput, htail⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) revealedOutput + · simp [hhit] at htail + subst result + trivial + · simp only [hhit, ↓reduceIte] at htail + have hnextValue : + (context.state.materialize (.position position) revealedOutput).values + coordinate = some output := by + simpa [LazyRevealProbe.State.materialize, + Function.update_of_ne (Ne.symm hne)] using hvalue + exact ih revealedOutput + { state := context.state.materialize (.position position) revealedOutput + values := context.values.install position revealedOutput } + fuel hnextValue hrevealed result htail + +noncomputable def finishDirectWitnessHiddenCandidateMatch + (candidate : Probe) : DirectWitnessResult α → ProbComp Bool + | .stoppedFuel => pure false + | .stoppedOrdinary => pure false + | .stoppedPrivate witness => pure (decide (witness.MatchesCandidate candidate)) + | .done result => hiddenPrivateCandidateFire candidate result.context + +theorem probEvent_runDirectWitnessHiddenCandidateMatch_le_zero_of_revealed + (candidate : Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hpublished : PublishedValues context.state) + (hrevealed : candidate.coordinate ∈ context.state.revealed) : + Pr[fun hit : Bool => hit = true | + runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectWitnessHiddenCandidateMatch candidate] ≤ 0 := by + obtain ⟨output, hvalue⟩ := Option.ne_none_iff_exists'.mp + (hpublished candidate.coordinate hrevealed) + rw [probEvent_bind_eq_tsum] + have hzero : (∑' result, + Pr[= result | runDirectResolvedWitnessFromTable context fuel table computation] * + Pr[fun hit : Bool => hit = true | + finishDirectWitnessHiddenCandidateMatch candidate result]) = 0 := by + apply ENNReal.tsum_eq_zero.2 + intro result + by_cases hresult : result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation) + · have hsafe := knownPublishedCoordinateResult_of_mem_runDirectResolvedWitnessFromTable + candidate.coordinate output computation context fuel table hvalue hrevealed result hresult + cases result with + | stoppedFuel => simp [finishDirectWitnessHiddenCandidateMatch] + | stoppedOrdinary => simp [finishDirectWitnessHiddenCandidateMatch] + | stoppedPrivate witness => + have hnotMatch : ¬witness.MatchesCandidate candidate := by + intro hmatch + exact hsafe hmatch.1 + simp [finishDirectWitnessHiddenCandidateMatch, hnotMatch] + | done result => + simp [finishDirectWitnessHiddenCandidateMatch, hiddenPrivateCandidateFire, + hsafe.2] + · rw [probOutput_eq_zero_of_not_mem_support hresult] + simp + rw [hzero] + +theorem probEvent_finishDirectWitnessHiddenCandidateMatch_le + (candidate : Probe) (result : DirectWitnessResult α) : + Pr[fun hit : Bool => hit = true | + finishDirectWitnessHiddenCandidateMatch candidate result] ≤ + Pr[fun hit : Bool => hit = true | + finishDirectWitnessPrivateCandidateMatch candidate result] := by + cases result with + | stoppedFuel => + change Pr[fun hit : Bool => hit = true | pure false] ≤ + Pr[fun hit : Bool => hit = true | pure false] + exact le_rfl + | stoppedOrdinary => + change Pr[fun hit : Bool => hit = true | pure false] ≤ + Pr[fun hit : Bool => hit = true | pure false] + exact le_rfl + | stoppedPrivate witness => + change Pr[fun hit : Bool => hit = true | + pure (decide (witness.MatchesCandidate candidate))] ≤ + Pr[fun hit : Bool => hit = true | + pure (decide (witness.MatchesCandidate candidate))] + exact le_rfl + | done result => + change Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate result.context] ≤ + Pr[fun hit : Bool => hit = true | + privateCandidateFire candidate result.context] + unfold hiddenPrivateCandidateFire + split + · simp + · exact le_rfl + +theorem probEvent_runDirectWitnessHiddenCandidateMatch_le + (candidate : Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hpublished : PublishedValues context.state) : + Pr[fun hit : Bool => hit = true | + runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectWitnessHiddenCandidateMatch candidate] ≤ + Pr[fun hit : Bool => hit = true | hiddenPrivateCandidateFire candidate context] := by + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · rw [hiddenPrivateCandidateFire_of_revealed candidate context hrevealed] + simpa using probEvent_runDirectWitnessHiddenCandidateMatch_le_zero_of_revealed candidate + context fuel table computation hpublished hrevealed + · rw [hiddenPrivateCandidateFire_of_not_revealed candidate context hrevealed] + have hleft : + Pr[fun hit : Bool => hit = true | + runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectWitnessHiddenCandidateMatch candidate] ≤ + Pr[fun hit : Bool => hit = true | + runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectWitnessPrivateCandidateMatch candidate] := by + apply probEvent_bind_mono + intro result _hresult + exact probEvent_finishDirectWitnessHiddenCandidateMatch_le candidate result + exact hleft.trans + (probEvent_runDirectWitnessPrivateCandidateMatch_le candidate context fuel table computation) + +theorem probEvent_finishDirectWitnessPlanMatchesCandidate_le_hidden + (candidate : Probe) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (result : DirectWitnessResult α) + (hobserve : ∀ resolved : ResolvedRunResult α, + result = .done resolved → + Pr[PrivateWitnessPlanMatchesCandidate candidate | + observe resolved.context resolved.remaining resolved.value candidates] ≤ + Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate resolved.context]) : + Pr[PrivateWitnessPlanMatchesCandidate candidate | + finishDirectWitnessPlanObserve observe candidates result] ≤ + Pr[fun hit : Bool => hit = true | + finishDirectWitnessHiddenCandidateMatch candidate result] := by + cases result with + | stoppedFuel => simp [finishDirectWitnessPlanObserve, + finishDirectWitnessHiddenCandidateMatch, PrivateWitnessPlanMatchesCandidate] + | stoppedOrdinary => simp [finishDirectWitnessPlanObserve, + finishDirectWitnessHiddenCandidateMatch, PrivateWitnessPlanMatchesCandidate] + | stoppedPrivate witness => + simp [finishDirectWitnessPlanObserve, finishDirectWitnessHiddenCandidateMatch, + PrivateWitnessPlanMatchesCandidate] + | done resolved => + simpa [finishDirectWitnessPlanObserve, finishDirectWitnessHiddenCandidateMatch] using + hobserve resolved rfl + +set_option maxRecDepth 100000 in +theorem probEvent_runDirectWitnessPlanMatchesCandidate_le_hidden + (candidate : Probe) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hpublished : PublishedValues context.state) + (hobserve : ∀ result : ResolvedRunResult α, + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation) → + Pr[PrivateWitnessPlanMatchesCandidate candidate | + observe result.context result.remaining result.value candidates] ≤ + Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate result.context]) : + Pr[PrivateWitnessPlanMatchesCandidate candidate | + runDirectWitnessPlanObserve observe candidates context fuel table computation] ≤ + Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate context] := by + unfold runDirectWitnessPlanObserve + calc + _ ≤ Pr[fun hit : Bool => hit = true | + runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectWitnessHiddenCandidateMatch candidate] := by + rw [probEvent_bind_eq_tsum, probEvent_bind_eq_tsum] + apply ENNReal.tsum_le_tsum + intro result + by_cases hresult : result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation) + · exact mul_le_mul' le_rfl + (probEvent_finishDirectWitnessPlanMatchesCandidate_le_hidden candidate observe candidates + result (by + intro resolved heq + subst result + exact hobserve resolved hresult)) + · rw [probOutput_eq_zero_of_not_mem_support hresult] + simp + _ ≤ _ := probEvent_runDirectWitnessHiddenCandidateMatch_le candidate context fuel table + computation hpublished + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenMatchLift.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenMatchLift.lean new file mode 100644 index 00000000..f0791b2d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenMatchLift.lean @@ -0,0 +1,107 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenMatch + +/-! +# Hidden fixed-candidate boundary lift + +The hidden candidate observer crosses classification and canonicalization. Publication rules out a +matching private witness at an already revealed coordinate; otherwise the hidden observer is the +existing fixed-candidate observer. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +theorem probEvent_classifyDirectWitnessPlanMatchesCandidate_le_hidden + (table : OtsSecretIndex → HashOutput) (candidate : Probe) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hpublished : PublishedValues context.state) + (hcontinuation : ¬PrivateStructuralHit context → DeferredCompletable table context → + Pr[PrivateWitnessPlanMatchesCandidate candidate | + observe context fuel value candidates] ≤ + Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate context]) : + Pr[PrivateWitnessPlanMatchesCandidate candidate | + classifyDirectWitnessPlanObserve table observe context fuel value candidates] ≤ + Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate context] := by + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · rw [hiddenPrivateCandidateFire_of_revealed candidate context hrevealed] + unfold classifyDirectWitnessPlanObserve + by_cases hhit : PrivateStructuralHit context + · simp only [hhit, ↓reduceDIte] + have hspec := privateHitWitnessOf_spec context hhit + have hnotMatch : + ¬(privateHitWitnessOf context hhit).MatchesCandidate candidate := by + intro hmatch + have hknown := hpublished candidate.coordinate hrevealed + rw [hmatch.1] at hknown + exact hknown hspec.1 + simp [PrivateWitnessPlanMatchesCandidate, hnotMatch] + · simp only [hhit, ↓reduceDIte] + by_cases hcompletable : DeferredCompletable table context + · simp only [hcompletable, ↓reduceIte] + simpa [hiddenPrivateCandidateFire, hrevealed] using + hcontinuation hhit hcompletable + · simp [hcompletable, PrivateWitnessPlanMatchesCandidate] + · rw [hiddenPrivateCandidateFire_of_not_revealed candidate context hrevealed] + apply probEvent_classifyDirectWitnessPlanMatchesCandidate_le table candidate observe context + fuel value candidates + intro hhit hcompletable + simpa [hiddenPrivateCandidateFire, hrevealed] using hcontinuation hhit hcompletable + +theorem hiddenPrivateCandidateFire_canonicalize + (table : OtsSecretIndex → HashOutput) (candidate : Probe) + (context : DeferredContext) (hconsistent : context.ValuesConsistent) : + evalDist (hiddenPrivateCandidateFire candidate + (canonicalizeMaterializedValues table context)) = + evalDist (hiddenPrivateCandidateFire candidate context) := by + unfold hiddenPrivateCandidateFire + rw [canonicalizeMaterializedValues_revealed] + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact congrArg evalDist + (privateCandidateFire_canonicalize table candidate context hconsistent) + +theorem probEvent_canonicalizeDirectWitnessPlanMatchesCandidate_le_hidden + (table : OtsSecretIndex → HashOutput) (candidate : Probe) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hconsistent : context.ValuesConsistent) + (hpublished : PublishedValues context.state) + (hcontinuation : + let canonical := canonicalizeMaterializedValues table context + ¬PrivateStructuralHit canonical → DeferredCompletable table canonical → + Pr[PrivateWitnessPlanMatchesCandidate candidate | + observe canonical fuel value candidates] ≤ + Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate canonical]) : + Pr[PrivateWitnessPlanMatchesCandidate candidate | + canonicalizeDirectWitnessPlanObserve table observe context fuel value candidates] ≤ + Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate context] := by + let canonical := canonicalizeMaterializedValues table context + have hcanonicalPublished : PublishedValues canonical.state := + hpublished.to_canonicalizedMaterializedValues + have hclassify := probEvent_classifyDirectWitnessPlanMatchesCandidate_le_hidden table candidate + observe canonical fuel value candidates hcanonicalPublished hcontinuation + have hcanonicalize : + canonicalizeDirectWitnessPlanObserve table observe context fuel value candidates = + classifyDirectWitnessPlanObserve table observe canonical fuel value candidates := by + unfold canonicalizeDirectWitnessPlanObserve + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit, classifyDirectWitnessPlanObserve] + · simp [canonical, hhit, hpublished, classifyDirectWitnessPlanObserve] + rw [hcanonicalize] + refine hclassify.trans ?_ + rw [probEvent_eq_eq_probOutput, probEvent_eq_eq_probOutput] + exact le_of_eq (OracleComp.probOutput_congr rfl + (hiddenPrivateCandidateFire_canonicalize table candidate context hconsistent)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenMatchOuter.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenMatchOuter.lean new file mode 100644 index 00000000..5f779be0 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenMatchOuter.lean @@ -0,0 +1,136 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenMatchLift + +/-! +# Hidden fixed-candidate outer continuation + +The hidden matching observer is lifted through every normalized outer query. Completed direct +steps preserve publication, so canonicalization may recurse with the same hidden gate. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_directDetailedBoundaryNormalizedPrivateWitnessPlanMatchesCandidate_le_hidden + (candidate : Probe) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) + (hterminal : ∀ nextContext remaining value nextCandidates, + nextContext.ValuesConsistent → StartTableAgrees nextContext.state table → + PublishedValues nextContext.state → + Pr[PrivateWitnessPlanMatchesCandidate candidate | + observe nextContext remaining value nextCandidates] ≤ + Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate nextContext]) : + Pr[PrivateWitnessPlanMatchesCandidate candidate | + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + computation observe candidates context fuel table cache] ≤ + Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate context] := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_pure] + exact hterminal context fuel (value, cache) candidates hconsistent hstarts hpublished + | query_bind query next ih => + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind] + let inner := (splitUniformImpl n).run cache + apply probEvent_runDirectWitnessPlanMatchesCandidate_le_hidden candidate _ + candidates context fuel table inner hpublished + intro result hresult + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table inner) := by + rw [← map_erase_runDirectResolvedWitnessFromTable inner context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hcore := resolvedCore_of_done_mem_runDirectResolvedWitnessFromTable inner + context fuel table result hconsistent hstarts hresult + have hnextPublished := publishedValues_of_done_runDirectResolvedDetailedFromTable + (splitUniformImpl n) (preservesPublishedValuesImpl_splitUniformImpl n) + context fuel table cache result hpublished hdetailed + apply probEvent_canonicalizeDirectWitnessPlanMatchesCandidate_le_hidden table + candidate _ result.context result.remaining result.value candidates hcore.2.1 + hnextPublished + dsimp only + intro _hprivate _hcompletable + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + hnextPublished.to_canonicalizedMaterializedValues + | inr input => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind] + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + let inner := (probingHashQueryAfterPlan parameter input plan).run cache + apply probEvent_runDirectWitnessPlanMatchesCandidate_le_hidden candidate _ + nextCandidates context fuel table inner hpublished + intro result hresult + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table inner) := by + rw [← map_erase_runDirectResolvedWitnessFromTable inner context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hcore := resolvedCore_of_done_mem_runDirectResolvedWitnessFromTable inner + context fuel table result hconsistent hstarts hresult + have hnextPublished := publishedValues_of_done_runDirectResolvedDetailedFromTable + (probingHashQueryAfterPlan parameter input plan) + (preservesPublishedValues_probingHashQueryAfterPlan parameter input plan) + context fuel table cache result hpublished hdetailed + apply probEvent_canonicalizeDirectWitnessPlanMatchesCandidate_le_hidden table + candidate _ result.context result.remaining result.value nextCandidates hcore.2.1 + hnextPublished + dsimp only + intro _hprivate _hcompletable + exact ih result.value.1 nextCandidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + hnextPublished.to_canonicalizedMaterializedValues + | inr message => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind] + let inner := (maskedSign parameter root ftsSecret message).run cache + apply probEvent_runDirectWitnessPlanMatchesCandidate_le_hidden candidate _ candidates + context fuel table inner hpublished + intro result hresult + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table inner) := by + rw [← map_erase_runDirectResolvedWitnessFromTable inner context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hcore := resolvedCore_of_done_mem_runDirectResolvedWitnessFromTable inner context + fuel table result hconsistent hstarts hresult + have hnextPublished := publishedValues_of_done_runDirectResolvedDetailedFromTable + (maskedSign parameter root ftsSecret message) + (preservesPublishedValues_maskedSign parameter root ftsSecret message) + context fuel table cache result hpublished hdetailed + apply probEvent_canonicalizeDirectWitnessPlanMatchesCandidate_le_hidden table candidate _ + result.context result.remaining result.value candidates hcore.2.1 hnextPublished + dsimp only + intro _hprivate _hcompletable + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining result.value.2 + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + hnextPublished.to_canonicalizedMaterializedValues + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenPlan.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenPlan.lean new file mode 100644 index 00000000..ed9a14cb --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenPlan.lean @@ -0,0 +1,140 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHidden + +/-! +# Planned candidate provenance + +Every candidate produced by the pure hash planner is either a chain probe or one exact child of a +leaf or node input. Hence a structural candidate always has a named parent. The dependent decoder +branches are stated separately to keep elaboration local. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +theorem purePlan_candidate_parent_probe_leaf + (parameter : PublicParameter) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) (decoded candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (hprobe : decodeProbe? parameter input = some decoded) + (hposition : decodePosition? parameter input = some (.leaf lay tree leafIdx)) + (hplan : (purePlanProbingHashQuery parameter input state).candidate? = some candidate) : + candidate.HasStructuralParent := by + have hdecoded := decoded.hasStructuralParent_of_decodeProbe?_eq_some parameter input hprobe + unfold purePlanProbingHashQuery at hplan + rw [hprobe, hposition] at hplan + exact leafInputProbePlan_hasStructuralParent state input decoded candidate lay tree leafIdx + hdecoded hplan + +theorem purePlan_candidate_parent_probe_chain + (parameter : PublicParameter) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) (decoded candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (step : ChainStep) + (hprobe : decodeProbe? parameter input = some decoded) + (hposition : decodePosition? parameter input = + some (.chain lay tree leafIdx chainIdx step)) + (hplan : (purePlanProbingHashQuery parameter input state).candidate? = some candidate) : + candidate.HasStructuralParent := by + have hdecoded := decoded.hasStructuralParent_of_decodeProbe?_eq_some parameter input hprobe + unfold purePlanProbingHashQuery at hplan + rw [hprobe, hposition] at hplan + exact Option.some.inj hplan.symm ▸ hdecoded + +theorem purePlan_candidate_parent_probe_node + (parameter : PublicParameter) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) (decoded candidate : Probe) + (lay : Layer) (tree : TreeIndex) (level : Fin maxLayerHeight) (nodeIdx : LeafIndex) + (hprobe : decodeProbe? parameter input = some decoded) + (hposition : decodePosition? parameter input = some (.node lay tree level nodeIdx)) + (hplan : (purePlanProbingHashQuery parameter input state).candidate? = some candidate) : + candidate.HasStructuralParent := by + have hdecoded := decoded.hasStructuralParent_of_decodeProbe?_eq_some parameter input hprobe + unfold purePlanProbingHashQuery at hplan + rw [hprobe, hposition] at hplan + exact Option.some.inj hplan.symm ▸ hdecoded + +theorem purePlan_candidate_parent_probe_ftsLeaf + (parameter : PublicParameter) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) (decoded candidate : Probe) + (index : Index) (tree : FtsTree) (leafIdx : FtsLeaf) + (hprobe : decodeProbe? parameter input = some decoded) + (hposition : decodePosition? parameter input = some (.ftsLeaf index tree leafIdx)) + (hplan : (purePlanProbingHashQuery parameter input state).candidate? = some candidate) : + candidate.HasStructuralParent := by + have hdecoded := decoded.hasStructuralParent_of_decodeProbe?_eq_some parameter input hprobe + unfold purePlanProbingHashQuery at hplan + rw [hprobe, hposition] at hplan + exact Option.some.inj hplan.symm ▸ hdecoded + +theorem purePlan_candidate_parent_probe_ftsNode + (parameter : PublicParameter) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) (decoded candidate : Probe) + (index : Index) (tree : FtsTree) (level : Fin ftsTreeHeight) (nodeIdx : FtsLeaf) + (hprobe : decodeProbe? parameter input = some decoded) + (hposition : decodePosition? parameter input = some (.ftsNode index tree level nodeIdx)) + (hplan : (purePlanProbingHashQuery parameter input state).candidate? = some candidate) : + candidate.HasStructuralParent := by + have hdecoded := decoded.hasStructuralParent_of_decodeProbe?_eq_some parameter input hprobe + unfold purePlanProbingHashQuery at hplan + rw [hprobe, hposition] at hplan + exact Option.some.inj hplan.symm ▸ hdecoded + +theorem purePlan_candidate_parent_probe_ftsRoots + (parameter : PublicParameter) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) (decoded candidate : Probe) + (index : Index) + (hprobe : decodeProbe? parameter input = some decoded) + (hposition : decodePosition? parameter input = some (.ftsRoots index)) + (hplan : (purePlanProbingHashQuery parameter input state).candidate? = some candidate) : + candidate.HasStructuralParent := by + have hdecoded := decoded.hasStructuralParent_of_decodeProbe?_eq_some parameter input hprobe + unfold purePlanProbingHashQuery at hplan + rw [hprobe, hposition] at hplan + exact Option.some.inj hplan.symm ▸ hdecoded + +theorem purePlan_candidate_parent_probe_no_position + (parameter : PublicParameter) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) (decoded candidate : Probe) + (hprobe : decodeProbe? parameter input = some decoded) + (hposition : decodePosition? parameter input = none) + (hplan : (purePlanProbingHashQuery parameter input state).candidate? = some candidate) : + candidate.HasStructuralParent := by + have hdecoded := decoded.hasStructuralParent_of_decodeProbe?_eq_some parameter input hprobe + unfold purePlanProbingHashQuery at hplan + rw [hprobe, hposition] at hplan + exact Option.some.inj hplan.symm ▸ hdecoded + +theorem purePlan_candidate_parent_node + (parameter : PublicParameter) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (level : Fin maxLayerHeight) (nodeIdx : LeafIndex) + (hprobe : decodeProbe? parameter input = none) + (hposition : decodePosition? parameter input = some (.node lay tree level nodeIdx)) + (hplan : (purePlanProbingHashQuery parameter input state).candidate? = some candidate) : + candidate.HasStructuralParent := by + unfold purePlanProbingHashQuery at hplan + rw [hprobe, hposition] at hplan + exact hasStructuralParent_of_mem_children_coordinates (.node lay tree level nodeIdx) candidate + (firstMissingInputCoordinatePlan_some_mem state input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position) candidate hplan) + +set_option maxRecDepth 100000 in +theorem purePlan_candidate_none_of_probe_none_nonnode + (parameter : PublicParameter) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) + (hprobe : decodeProbe? parameter input = none) + (hposition : ¬∃ lay tree level nodeIdx, + decodePosition? parameter input = some (.node lay tree level nodeIdx)) : + (purePlanProbingHashQuery parameter input state).candidate? = none := by + unfold purePlanProbingHashQuery + rw [hprobe] + cases hdecoded : decodePosition? parameter input with + | none => rfl + | some position => + cases position with + | node lay tree level nodeIdx => + exact False.elim (hposition ⟨lay, tree, level, nodeIdx, hdecoded⟩) + | chain | leaf | ftsLeaf | ftsNode | ftsRoots => rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenPlanFinal.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenPlanFinal.lean new file mode 100644 index 00000000..65c039ba --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenPlanFinal.lean @@ -0,0 +1,33 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenPlan + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +theorem purePlanProbingHashQuery_candidate_hasStructuralParent + (parameter : PublicParameter) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) (candidate : Probe) + (hplan : (purePlanProbingHashQuery parameter input state).candidate? = some candidate) : + candidate.HasStructuralParent := by + cases hprobe : decodeProbe? parameter input with + | some decoded => + rcases decodePosition?_chain_or_leaf_of_decodeProbe? parameter input decoded hprobe with + hchain | hleaf + · obtain ⟨lay, tree, leafIdx, chainIdx, step, hposition⟩ := hchain + exact purePlan_candidate_parent_probe_chain parameter input state decoded candidate lay + tree leafIdx chainIdx step hprobe hposition hplan + · obtain ⟨lay, tree, leafIdx, hposition⟩ := hleaf + exact purePlan_candidate_parent_probe_leaf parameter input state decoded candidate lay tree + leafIdx hprobe hposition hplan + | none => + by_cases hnode : ∃ lay tree level nodeIdx, + decodePosition? parameter input = some (.node lay tree level nodeIdx) + · obtain ⟨lay, tree, level, nodeIdx, hposition⟩ := hnode + exact purePlan_candidate_parent_node parameter input state candidate lay tree level nodeIdx + hprobe hposition hplan + · have hnone := purePlan_candidate_none_of_probe_none_nonnode parameter input state + hprobe hnode + rw [hnone] at hplan + contradiction + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenPrefix.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenPrefix.lean new file mode 100644 index 00000000..fc03bb94 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenPrefix.lean @@ -0,0 +1,135 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenMatchOuter + +/-! +# Hidden selected-ordinal step + +The exact hash query that appends an ordinal is bounded by the hidden candidate observer. The +retained finalizer satisfies the hidden terminal condition because a published coordinate cannot +be the position of a private witness. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +theorem probEvent_retainedResolvedFinalizationPrivateWitnessPlanMatchesCandidate_le_hidden + (table : OtsSecretIndex → HashOutput) (root : Digest) (candidate : Probe) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) (candidates : List Probe) + (hpublished : PublishedValues context.state) : + Pr[PrivateWitnessPlanMatchesCandidate candidate | + retainedResolvedFinalizationPrivateWitnessPlanObserve table root context fuel value + candidates] ≤ + Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate context] := by + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · rw [hiddenPrivateCandidateFire_of_revealed candidate context hrevealed] + unfold retainedResolvedFinalizationPrivateWitnessPlanObserve + by_cases hhit : PrivateStructuralHit context + · simp only [hhit, ↓reduceDIte] + have hspec := privateHitWitnessOf_spec context hhit + have hnotMatch : + ¬(privateHitWitnessOf context hhit).MatchesCandidate candidate := by + intro hmatch + have hknown := hpublished candidate.coordinate hrevealed + rw [hmatch.1] at hknown + exact hknown hspec.1 + simp [PrivateWitnessPlanMatchesCandidate, hnotMatch] + · simp [hhit, PrivateWitnessPlanMatchesCandidate] + · rw [hiddenPrivateCandidateFire_of_not_revealed candidate context hrevealed] + exact probEvent_retainedResolvedFinalizationPrivateWitnessPlanMatchesCandidate_le table root + candidate context fuel value candidates + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_selectedHashPlanWitnessUsesOrdinal_le_hidden + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp PrivateWitnessPlanOutput) + (current : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (candidate : Probe) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) + (hterminal : ∀ nextContext remaining value nextCandidates, + nextContext.ValuesConsistent → StartTableAgrees nextContext.state table → + PublishedValues nextContext.state → + Pr[PrivateWitnessPlanMatchesCandidate candidate | + observe nextContext remaining value nextCandidates] ≤ + Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate nextContext]) + (hobservePrefix : ∀ nextContext remaining value nextCandidates output, + output ∈ support (observe nextContext remaining value nextCandidates) → + PrivateWitnessPlanExtends nextCandidates output) : + Pr[WitnessUsesOrdinal current.length | + runDirectWitnessPlanObserve + (canonicalizeDirectWitnessPlanObserve table + (fun nextContext remaining value laterCandidates => + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + (next value.1) observe laterCandidates nextContext remaining table value.2)) + (current ++ [candidate]) context fuel table + ((probingHashQueryAfterPlan parameter input + (purePlanProbingHashQuery parameter input context.state)).run cache)] ≤ + Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate context] := by + let plan := purePlanProbingHashQuery parameter input context.state + let branch := runDirectWitnessPlanObserve + (canonicalizeDirectWitnessPlanObserve table + (fun nextContext remaining value laterCandidates => + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + (next value.1) observe laterCandidates nextContext remaining table value.2)) + (current ++ [candidate]) context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) + apply probEvent_witnessUses_newlyAppendedOrdinal_le branch current candidate _ + · intro output houtput + unfold branch at houtput + apply privateWitnessPlanExtends_of_mem_runDirectWitnessPlanObserve _ + (current ++ [candidate]) context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) (output := output) + (houtput := houtput) + intro result _hresult nextOutput hnextOutput + apply privateWitnessPlanExtends_of_mem_canonicalizeDirectWitnessPlanObserve table _ + result.context result.remaining result.value (current ++ [candidate]) + (output := nextOutput) (houtput := hnextOutput) + intro finalOutput hfinalOutput + exact privateWitnessPlanExtends_of_mem_directDetailedBoundaryNormalizedPrivateWitnessPlanObserve + parameter root ftsSecret (next result.value.1) observe (current ++ [candidate]) + (canonicalizeMaterializedValues table result.context) result.remaining table result.value.2 + hobservePrefix finalOutput hfinalOutput + · unfold branch + apply probEvent_runDirectWitnessPlanMatchesCandidate_le_hidden candidate _ + (current ++ [candidate]) context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) hpublished + intro result hresult + let inner := (probingHashQueryAfterPlan parameter input plan).run cache + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table inner) := by + rw [← map_erase_runDirectResolvedWitnessFromTable inner context fuel table, support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable inner context fuel table result + hconsistent hstarts + (mem_support_runDirectResolvedFromTable_of_done_detailed inner context fuel table result + hdetailed) + have hnextPublished := publishedValues_of_done_runDirectResolvedDetailedFromTable + (probingHashQueryAfterPlan parameter input plan) + (preservesPublishedValues_probingHashQueryAfterPlan parameter input plan) + context fuel table cache result hpublished hdetailed + apply probEvent_canonicalizeDirectWitnessPlanMatchesCandidate_le_hidden table candidate _ + result.context result.remaining result.value (current ++ [candidate]) hcore.2.1 + hnextPublished + dsimp only + intro _hprivate _hcompletable + exact probEvent_directDetailedBoundaryNormalizedPrivateWitnessPlanMatchesCandidate_le_hidden + candidate parameter root ftsSecret (next result.value.1) observe (current ++ [candidate]) + (canonicalizeMaterializedValues table result.context) result.remaining table result.value.2 + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + hnextPublished.to_canonicalizedMaterializedValues hterminal + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenRisk.lean new file mode 100644 index 00000000..2c07db2d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenRisk.lean @@ -0,0 +1,359 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenPrefix + +/-! +# Hidden ordinal prefix risk + +This is the sound prefix endpoint. It follows the normalized execution until a fixed ordinal is +selected and then tests only the hidden candidate risk. Earlier stops and termination before the +ordinal contribute zero. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +noncomputable def directDetailedBoundaryPrivateOrdinalHiddenRisk + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : ProbComp Bool := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + List Probe → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → + SplitHashCache → ProbComp Bool) + (fun _value candidates context _fuel _table _cache => + if hselected : ordinal < candidates.length then + hiddenPrivateCandidateFire (candidates.get ⟨ordinal, hselected⟩) context + else + pure false) + (fun query _next recursivelyRun candidates context fuel table cache => + if hselected : ordinal < candidates.length then + hiddenPrivateCandidateFire (candidates.get ⟨ordinal, hselected⟩) context + else + match query with + | .inl (.inl n) => + runDirectResolvedWitnessFromTable context fuel table ((splitUniformImpl n).run cache) >>= + finishDirectWitnessOrdinalRisk + (canonicalizeDirectWitnessOrdinalRisk table + (fun nextContext remaining value laterCandidates => + recursivelyRun value.1 laterCandidates nextContext remaining table value.2)) + candidates + | .inl (.inr input) => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + if hnextSelected : ordinal < nextCandidates.length then + hiddenPrivateCandidateFire + (nextCandidates.get ⟨ordinal, hnextSelected⟩) context + else + runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) >>= + finishDirectWitnessOrdinalRisk + (canonicalizeDirectWitnessOrdinalRisk table + (fun nextContext remaining value laterCandidates => + recursivelyRun value.1 laterCandidates nextContext remaining table value.2)) + nextCandidates + | .inr message => + runDirectResolvedWitnessFromTable context fuel table + ((maskedSign parameter root ftsSecret message).run cache) >>= + finishDirectWitnessOrdinalRisk + (canonicalizeDirectWitnessOrdinalRisk table + (fun nextContext remaining value laterCandidates => + recursivelyRun value.1 laterCandidates nextContext remaining table value.2)) + candidates) + computation candidates context fuel table cache + +noncomputable def granularDetailedRetainedRestPrivateOrdinalHiddenRisk + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) : ProbComp Bool := + directDetailedBoundaryPrivateOrdinalHiddenRisk ordinal parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + candidates context fuel table value.2 + +theorem directDetailedBoundaryPrivateOrdinalHiddenRisk_eq_fire_of_selected + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hselected : ordinal < candidates.length) : + directDetailedBoundaryPrivateOrdinalHiddenRisk ordinal parameter root ftsSecret computation + candidates context fuel table cache = + hiddenPrivateCandidateFire (candidates.get ⟨ordinal, hselected⟩) context := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryPrivateOrdinalHiddenRisk, OracleComp.construct_pure] + simp only [hselected, ↓reduceDIte] + | query_bind query next ih => + rw [directDetailedBoundaryPrivateOrdinalHiddenRisk, OracleComp.construct_query_bind] + simp only [hselected, ↓reduceDIte] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_hashBranchWitnessUsesOrdinal_le_hiddenRisk + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hnotSelected : ¬ordinal < candidates.length) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) + (hrecursive : ∀ output nextCandidates nextContext remaining nextCache, + ¬ordinal < nextCandidates.length → + nextContext.ValuesConsistent → StartTableAgrees nextContext.state table → + PublishedValues nextContext.state → + Pr[WitnessUsesOrdinal ordinal | + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + (next output) observe nextCandidates nextContext remaining table nextCache] ≤ + Pr[fun hit : Bool => hit = true | + directDetailedBoundaryPrivateOrdinalHiddenRisk ordinal parameter root ftsSecret + (next output) nextCandidates nextContext remaining table nextCache]) + (hterminalMatch : ∀ candidate nextContext remaining value nextCandidates, + nextContext.ValuesConsistent → StartTableAgrees nextContext.state table → + PublishedValues nextContext.state → + Pr[PrivateWitnessPlanMatchesCandidate candidate | + observe nextContext remaining value nextCandidates] ≤ + Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate nextContext]) + (hterminalPrefix : ∀ nextContext remaining value nextCandidates output, + output ∈ support (observe nextContext remaining value nextCandidates) → + PrivateWitnessPlanExtends nextCandidates output) : + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + Pr[WitnessUsesOrdinal ordinal | + runDirectWitnessPlanObserve + (canonicalizeDirectWitnessPlanObserve table + (fun nextContext remaining value laterCandidates => + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + (next value.1) observe laterCandidates nextContext remaining table value.2)) + nextCandidates context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache)] ≤ + Pr[fun hit : Bool => hit = true | + if hselected : ordinal < nextCandidates.length then + hiddenPrivateCandidateFire (nextCandidates.get ⟨ordinal, hselected⟩) context + else + runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) >>= + finishDirectWitnessOrdinalRisk + (canonicalizeDirectWitnessOrdinalRisk table + (fun nextContext remaining value laterCandidates => + directDetailedBoundaryPrivateOrdinalHiddenRisk ordinal parameter root ftsSecret + (next value.1) laterCandidates nextContext remaining table value.2)) + nextCandidates] := by + dsimp only + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + by_cases hnextSelected : ordinal < nextCandidates.length + · rw [dif_pos hnextSelected] + have hexists : ∃ candidate, + rootAwarePlannedCandidate? parameter input context.state = some candidate := by + cases hcandidate : rootAwarePlannedCandidate? parameter input context.state with + | none => + have hsame : nextCandidates = candidates := by + simp [nextCandidates, appendPlannedCandidate, hcandidate] + exact (hnotSelected (hsame ▸ hnextSelected)).elim + | some candidate => exact ⟨candidate, rfl⟩ + obtain ⟨candidate, hcandidate⟩ := hexists + have hordinal : ordinal = candidates.length := by + have hlength : nextCandidates.length = candidates.length + 1 := by + simp [nextCandidates, appendPlannedCandidate, hcandidate] + omega + subst ordinal + have hget : nextCandidates.get ⟨candidates.length, hnextSelected⟩ = candidate := by + simp [nextCandidates, appendPlannedCandidate, hcandidate, List.get_eq_getElem] + rw [hget] + have hbound := probEvent_selectedHashPlanWitnessUsesOrdinal_le_hidden parameter root ftsSecret + input next observe candidates context fuel table cache candidate hconsistent hstarts + hpublished + (by + intro nextContext remaining value laterCandidates hnextConsistent hnextStarts + hnextPublished + exact hterminalMatch candidate nextContext remaining value laterCandidates hnextConsistent + hnextStarts hnextPublished) + hterminalPrefix + simpa only [nextCandidates, hcandidate, appendPlannedCandidate, plan] using hbound + · rw [dif_neg hnextSelected] + apply probEvent_unselectedDirectWitnessStep_le_ordinalRisk ordinal _ _ nextCandidates + context fuel table ((probingHashQueryAfterPlan parameter input plan).run cache) + hnextSelected + intro result hresult + let inner := (probingHashQueryAfterPlan parameter input plan).run cache + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table inner) := by + rw [← map_erase_runDirectResolvedWitnessFromTable inner context fuel table, support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hcore := resolvedCore_of_done_mem_runDirectResolvedWitnessFromTable inner context fuel + table result hconsistent hstarts hresult + have hnextPublished := publishedValues_of_done_runDirectResolvedDetailedFromTable + (probingHashQueryAfterPlan parameter input plan) + (preservesPublishedValues_probingHashQueryAfterPlan parameter input plan) + context fuel table cache result hpublished hdetailed + exact hrecursive result.value.1 nextCandidates + (canonicalizeMaterializedValues table result.context) result.remaining result.value.2 + hnextSelected + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + hnextPublished.to_canonicalizedMaterializedValues + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_directDetailedBoundaryWitnessUsesOrdinal_le_hiddenRisk + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hnotSelected : ¬ordinal < candidates.length) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) + (hterminalZero : ∀ nextContext remaining value nextCandidates, + ¬ordinal < nextCandidates.length → + Pr[WitnessUsesOrdinal ordinal | + observe nextContext remaining value nextCandidates] ≤ 0) + (hterminalMatch : ∀ candidate nextContext remaining value nextCandidates, + nextContext.ValuesConsistent → StartTableAgrees nextContext.state table → + PublishedValues nextContext.state → + Pr[PrivateWitnessPlanMatchesCandidate candidate | + observe nextContext remaining value nextCandidates] ≤ + Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate nextContext]) + (hterminalPrefix : ∀ nextContext remaining value nextCandidates output, + output ∈ support (observe nextContext remaining value nextCandidates) → + PrivateWitnessPlanExtends nextCandidates output) : + Pr[WitnessUsesOrdinal ordinal | + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + computation observe candidates context fuel table cache] ≤ + Pr[fun hit : Bool => hit = true | + directDetailedBoundaryPrivateOrdinalHiddenRisk ordinal parameter root ftsSecret computation + candidates context fuel table cache] := by + induction computation using OracleComp.inductionOn generalizing + candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_pure, directDetailedBoundaryPrivateOrdinalHiddenRisk, + OracleComp.construct_pure] + simp only [hnotSelected, ↓reduceDIte] + simpa using hterminalZero context fuel (value, cache) candidates hnotSelected + | query_bind query next ih => + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind, directDetailedBoundaryPrivateOrdinalHiddenRisk, + OracleComp.construct_query_bind] + simp only [hnotSelected, ↓reduceDIte] + let inner := (splitUniformImpl n).run cache + apply probEvent_unselectedDirectWitnessStep_le_ordinalRisk ordinal _ _ candidates + context fuel table inner hnotSelected + intro result hresult + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table inner) := by + rw [← map_erase_runDirectResolvedWitnessFromTable inner context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hcore := resolvedCore_of_done_mem_runDirectResolvedWitnessFromTable inner + context fuel table result hconsistent hstarts hresult + have hnextPublished := publishedValues_of_done_runDirectResolvedDetailedFromTable + (splitUniformImpl n) (preservesPublishedValuesImpl_splitUniformImpl n) + context fuel table cache result hpublished hdetailed + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hnotSelected + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + hnextPublished.to_canonicalizedMaterializedValues + | inr input => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind, directDetailedBoundaryPrivateOrdinalHiddenRisk, + OracleComp.construct_query_bind] + simp only [hnotSelected, ↓reduceDIte] + apply probEvent_hashBranchWitnessUsesOrdinal_le_hiddenRisk ordinal parameter root + ftsSecret input next observe candidates context fuel table cache hnotSelected + hconsistent hstarts hpublished + · intro output nextCandidates nextContext remaining nextCache hnextNotSelected + hnextConsistent hnextStarts hnextPublished + exact ih output nextCandidates nextContext remaining nextCache hnextNotSelected + hnextConsistent hnextStarts hnextPublished + · exact hterminalMatch + · exact hterminalPrefix + | inr message => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind, directDetailedBoundaryPrivateOrdinalHiddenRisk, + OracleComp.construct_query_bind] + simp only [hnotSelected, ↓reduceDIte] + let inner := (maskedSign parameter root ftsSecret message).run cache + apply probEvent_unselectedDirectWitnessStep_le_ordinalRisk ordinal _ _ candidates + context fuel table inner hnotSelected + intro result hresult + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table inner) := by + rw [← map_erase_runDirectResolvedWitnessFromTable inner context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hcore := resolvedCore_of_done_mem_runDirectResolvedWitnessFromTable inner context + fuel table result hconsistent hstarts hresult + have hnextPublished := publishedValues_of_done_runDirectResolvedDetailedFromTable + (maskedSign parameter root ftsSecret message) + (preservesPublishedValues_maskedSign parameter root ftsSecret message) + context fuel table cache result hpublished hdetailed + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hnotSelected + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + hnextPublished.to_canonicalizedMaterializedValues + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_granularDetailedRetainedRestWitnessUsesOrdinal_le_hiddenRisk + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) + (hnotSelected : ¬ordinal < candidates.length) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) : + Pr[WitnessUsesOrdinal ordinal | + granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates] ≤ + Pr[fun hit : Bool => hit = true | + granularDetailedRetainedRestPrivateOrdinalHiddenRisk adversary parameter table ftsSecret + ordinal context fuel value candidates] := by + unfold granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve + granularDetailedRetainedRestPrivateOrdinalHiddenRisk + apply probEvent_directDetailedBoundaryWitnessUsesOrdinal_le_hiddenRisk ordinal parameter value.1 + ftsSecret (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivateWitnessPlanObserve table value.1) + candidates context fuel table value.2 hnotSelected hconsistent hstarts hpublished + · intro nextContext remaining nextValue nextCandidates hnextNotSelected + exact probEvent_retainedFinalizationWitnessUsesOrdinal_le_zero table value.1 nextContext + remaining nextValue nextCandidates ordinal hnextNotSelected + · intro candidate nextContext remaining nextValue nextCandidates _hnextConsistent + _hnextStarts hnextPublished + exact probEvent_retainedResolvedFinalizationPrivateWitnessPlanMatchesCandidate_le_hidden table + value.1 candidate nextContext remaining nextValue nextCandidates hnextPublished + · intro nextContext remaining nextValue nextCandidates output houtput + exact privateWitnessPlanExtends_of_mem_retainedResolvedFinalizationPrivateWitnessPlanObserve + table value.1 nextContext remaining nextValue nextCandidates output houtput + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenRiskBound.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenRiskBound.lean new file mode 100644 index 00000000..89fa11dc --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenRiskBound.lean @@ -0,0 +1,274 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenFresh + +/-! +# One-unit hidden ordinal bound + +The hidden ordinal risk costs one unit whenever every completed query step transports candidate +freshness across its canonical boundary. This file isolates that exact remaining interface from the +finite-union and witness machinery. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +def CandidatesHaveStructuralParent (candidates : List Probe) : Prop := + ∀ candidate ∈ candidates, candidate.HasStructuralParent + +theorem candidatesHaveStructuralParent_nil : + CandidatesHaveStructuralParent [] := by simp [CandidatesHaveStructuralParent] + +theorem CandidatesHaveStructuralParent.appendCandidate + {candidates : List Probe} (hparents : CandidatesHaveStructuralParent candidates) + (candidate : Probe) (hparent : candidate.HasStructuralParent) : + CandidatesHaveStructuralParent (candidates ++ [candidate]) := by + intro other hmem + rcases List.mem_append.mp hmem with hleft | hright + · exact hparents other hleft + · have heq : other = candidate := by simpa using hright + subst other + exact hparent + +theorem CandidatesHaveStructuralParent.appendPlanned + {candidates : List Probe} (hparents : CandidatesHaveStructuralParent candidates) + (candidate? : Option Probe) + (hcandidate : ∀ candidate, candidate? = some candidate → + candidate.HasStructuralParent) : + CandidatesHaveStructuralParent (appendPlannedCandidate candidates candidate?) := by + cases hvalue : candidate? with + | none => simpa [appendPlannedCandidate, hvalue] using hparents + | some candidate => + exact hparents.appendCandidate candidate (hcandidate candidate hvalue) + +theorem candidateHasStructuralParent_get + {candidates : List Probe} (hparents : CandidatesHaveStructuralParent candidates) + (ordinal : Nat) (hlt : ordinal < candidates.length) : + (candidates.get ⟨ordinal, hlt⟩).HasStructuralParent := + hparents _ (List.get_mem candidates ⟨ordinal, hlt⟩) + +theorem probEvent_finishDirectWitnessOrdinalRisk_le + (table : OtsSecretIndex → HashOutput) + (riskObserve : DeferredContext → Nat → α → List Probe → ProbComp Bool) + (candidates : List Probe) (result : DirectWitnessResult α) (bound : ℝ≥0∞) + (hcontinuation : ∀ resolved : ResolvedRunResult α, + result = .done resolved → + PublishedValues resolved.context.state → + DeferredCompletable table (canonicalizeMaterializedValues table resolved.context) → + Pr[fun hit : Bool => hit = true | + riskObserve (canonicalizeMaterializedValues table resolved.context) + resolved.remaining resolved.value candidates] ≤ bound) : + Pr[fun hit : Bool => hit = true | + finishDirectWitnessOrdinalRisk + (canonicalizeDirectWitnessOrdinalRisk table riskObserve) candidates result] ≤ + bound := by + cases result with + | stoppedFuel => simp [finishDirectWitnessOrdinalRisk] + | stoppedOrdinary => simp [finishDirectWitnessOrdinalRisk] + | stoppedPrivate witness => simp [finishDirectWitnessOrdinalRisk] + | done resolved => + unfold finishDirectWitnessOrdinalRisk canonicalizeDirectWitnessOrdinalRisk + let canonical := canonicalizeMaterializedValues table resolved.context + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit] + · simp only [canonical, hhit] + by_cases hpublished : PublishedValues resolved.context.state + · simp only [hpublished, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table canonical + · change DeferredCompletable table + (canonicalizeMaterializedValues table resolved.context) at hcompletable + rw [if_pos hcompletable] + exact hcontinuation resolved rfl hpublished hcompletable + · change ¬DeferredCompletable table + (canonicalizeMaterializedValues table resolved.context) at hcompletable + rw [if_neg hcompletable] + simp + · simp [hpublished] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_directDetailedBoundaryPrivateOrdinalHiddenRisk_le + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hparents : CandidatesHaveStructuralParent candidates) + (hfresh : CandidatePositionsFresh context) + (hpublishedContext : PublishedValues context.state) + (hrootAwareParent : ∀ input state candidate, + rootAwarePlannedCandidate? parameter input state = some candidate → + candidate.HasStructuralParent) + (huniformFresh : ∀ n nextContext remaining nextCache result, + CandidatePositionsFresh nextContext → + PublishedValues nextContext.state → + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable nextContext remaining table + ((splitUniformImpl n).run nextCache)) → + PublishedValues result.context.state → + CandidatePositionsFresh (canonicalizeMaterializedValues table result.context)) + (hhashFresh : ∀ input plan nextContext remaining nextCache result, + CandidatePositionsFresh nextContext → + PublishedValues nextContext.state → + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable nextContext remaining table + ((probingHashQueryAfterPlan parameter input plan).run nextCache)) → + PublishedValues result.context.state → + CandidatePositionsFresh (canonicalizeMaterializedValues table result.context)) + (hsignFresh : ∀ message nextContext remaining nextCache result, + CandidatePositionsFresh nextContext → + PublishedValues nextContext.state → + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable nextContext remaining table + ((maskedSign parameter root ftsSecret message).run nextCache)) → + PublishedValues result.context.state → + CandidatePositionsFresh (canonicalizeMaterializedValues table result.context)) : + Pr[fun hit : Bool => hit = true | + directDetailedBoundaryPrivateOrdinalHiddenRisk ordinal parameter root ftsSecret computation + candidates context fuel table cache] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryPrivateOrdinalHiddenRisk, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + simpa using probEvent_hiddenPrivateCandidateFire_le_of_candidatePositionsFresh + (candidates.get ⟨ordinal, hselected⟩) context + (candidateHasStructuralParent_get hparents ordinal hselected) hfresh + · simp [hselected] + | query_bind query next ih => + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [directDetailedBoundaryPrivateOrdinalHiddenRisk, + OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + simpa using probEvent_hiddenPrivateCandidateFire_le_of_candidatePositionsFresh + (candidates.get ⟨ordinal, hselected⟩) context + (candidateHasStructuralParent_get hparents ordinal hselected) hfresh + · simp only [hselected, ↓reduceDIte] + apply probEvent_bind_le_of_forall_le + intro result hresult + apply probEvent_finishDirectWitnessOrdinalRisk_le table _ candidates result _ + intro resolved heq hpublished hcompletable + subst result + exact ih resolved.value.1 candidates + (canonicalizeMaterializedValues table resolved.context) resolved.remaining + resolved.value.2 hparents + (huniformFresh n context fuel cache resolved hfresh hpublishedContext hresult + hpublished) + hpublished.to_canonicalizedMaterializedValues + | inr input => + rw [directDetailedBoundaryPrivateOrdinalHiddenRisk, + OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + simpa using probEvent_hiddenPrivateCandidateFire_le_of_candidatePositionsFresh + (candidates.get ⟨ordinal, hselected⟩) context + (candidateHasStructuralParent_get hparents ordinal hselected) hfresh + · simp only [hselected, ↓reduceDIte] + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + have hnextParents : CandidatesHaveStructuralParent nextCandidates := by + apply hparents.appendPlanned + (rootAwarePlannedCandidate? parameter input context.state) + intro candidate hcandidate + exact hrootAwareParent input context.state candidate hcandidate + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [nextCandidates, plan] using hnextSelected + rw [dif_pos hactual] + simpa [nextCandidates, plan] using + (probEvent_hiddenPrivateCandidateFire_le_of_candidatePositionsFresh + (nextCandidates.get ⟨ordinal, hnextSelected⟩) context + (candidateHasStructuralParent_get hnextParents ordinal hnextSelected) hfresh) + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [nextCandidates, plan] using hnextSelected + rw [dif_neg hactual] + apply probEvent_bind_le_of_forall_le + intro result hresult + apply probEvent_finishDirectWitnessOrdinalRisk_le table _ nextCandidates result _ + intro resolved heq hpublished hcompletable + subst result + exact ih resolved.value.1 nextCandidates + (canonicalizeMaterializedValues table resolved.context) resolved.remaining + resolved.value.2 hnextParents + (hhashFresh input plan context fuel cache resolved hfresh hpublishedContext + hresult hpublished) + hpublished.to_canonicalizedMaterializedValues + | inr message => + rw [directDetailedBoundaryPrivateOrdinalHiddenRisk, + OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + simpa using probEvent_hiddenPrivateCandidateFire_le_of_candidatePositionsFresh + (candidates.get ⟨ordinal, hselected⟩) context + (candidateHasStructuralParent_get hparents ordinal hselected) hfresh + · simp only [hselected, ↓reduceDIte] + apply probEvent_bind_le_of_forall_le + intro result hresult + apply probEvent_finishDirectWitnessOrdinalRisk_le table _ candidates result _ + intro resolved heq hpublished hcompletable + subst result + exact ih resolved.value.1 candidates + (canonicalizeMaterializedValues table resolved.context) resolved.remaining + resolved.value.2 hparents + (hsignFresh message context fuel cache resolved hfresh hpublishedContext hresult + hpublished) + hpublished.to_canonicalizedMaterializedValues + +theorem probEvent_granularDetailedRetainedRestPrivateOrdinalHiddenRisk_le + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) + (hparents : CandidatesHaveStructuralParent candidates) + (hfresh : CandidatePositionsFresh context) + (hpublished : PublishedValues context.state) + (hrootAwareParent : ∀ input state candidate, + rootAwarePlannedCandidate? parameter input state = some candidate → + candidate.HasStructuralParent) + (huniformFresh : ∀ n nextContext remaining nextCache result, + CandidatePositionsFresh nextContext → + PublishedValues nextContext.state → + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable nextContext remaining table + ((splitUniformImpl n).run nextCache)) → + PublishedValues result.context.state → + CandidatePositionsFresh (canonicalizeMaterializedValues table result.context)) + (hhashFresh : ∀ input plan nextContext remaining nextCache result, + CandidatePositionsFresh nextContext → + PublishedValues nextContext.state → + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable nextContext remaining table + ((probingHashQueryAfterPlan parameter input plan).run nextCache)) → + PublishedValues result.context.state → + CandidatePositionsFresh (canonicalizeMaterializedValues table result.context)) + (hsignFresh : ∀ message nextContext remaining nextCache result, + CandidatePositionsFresh nextContext → + PublishedValues nextContext.state → + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable nextContext remaining table + ((maskedSign parameter value.1 ftsSecret message).run nextCache)) → + PublishedValues result.context.state → + CandidatePositionsFresh (canonicalizeMaterializedValues table result.context)) : + Pr[fun hit : Bool => hit = true | + granularDetailedRetainedRestPrivateOrdinalHiddenRisk adversary parameter table ftsSecret + ordinal context fuel value candidates] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + unfold granularDetailedRetainedRestPrivateOrdinalHiddenRisk + exact probEvent_directDetailedBoundaryPrivateOrdinalHiddenRisk_le ordinal parameter value.1 + ftsSecret (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + candidates context fuel table value.2 hparents hfresh hpublished hrootAwareParent + huniformFresh hhashFresh hsignFresh + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalInterpreter.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalInterpreter.lean new file mode 100644 index 00000000..a5caed84 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalInterpreter.lean @@ -0,0 +1,251 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalCommute + +/-! +# Fixed-candidate interpreter lift + +For one fixed candidate, running any direct resolved computation before the candidate observer +cannot increase its firing probability. Stops contribute zero, while completed runs carry the same +selected structural output through the deferred context. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +noncomputable def finishDirectWitnessPrivateCandidateFire + (candidate : Probe) : DirectWitnessResult α → ProbComp Bool + | .stoppedFuel => pure false + | .stoppedOrdinary => pure false + | .stoppedPrivate _ => pure false + | .done result => privateCandidateFire candidate result.context + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_freshPositionWitnessPrivateCandidateFire_le + (candidate : Probe) (context : DeferredContext) (position : Position) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) + (hstate : context.state.values (.position position) = none) + (hprivate : context.values position = none) + (htail : ∀ output, + Pr[fun hit : Bool => hit = true | + runDirectResolvedWitnessFromTable + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel table (next output) >>= + finishDirectWitnessPrivateCandidateFire candidate] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate + { state := context.state.materialize (.position position) output + values := context.values.install position output }]) : + Pr[fun hit : Bool => hit = true | + LazyRevealProbe.sampleHashOutput >>= fun output => + if context.state.hitAt (.position position) output then + pure false + else + runDirectResolvedWitnessFromTable + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel table (next output) >>= + finishDirectWitnessPrivateCandidateFire candidate] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate context] := by + let continuation := fun output : HashOutput => + if context.state.hitAt (.position position) output then + pure false + else + privateCandidateFire candidate + (completePrivatePosition position context output).toDeferredContext + have hleft : + Pr[fun hit : Bool => hit = true | + LazyRevealProbe.sampleHashOutput >>= fun output => + if context.state.hitAt (.position position) output then + pure false + else + runDirectResolvedWitnessFromTable + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel table (next output) >>= + finishDirectWitnessPrivateCandidateFire candidate] ≤ + Pr[fun hit : Bool => hit = true | + LazyRevealProbe.sampleHashOutput >>= continuation] := by + apply probEvent_bind_mono + intro output _houtput + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit, continuation] + · simp only [hhit, ↓reduceIte, continuation] + exact (htail output).trans (le_of_eq (OracleComp.probEvent_congr' + (fun _ _ => Iff.rfl) (congrArg evalDist + (privateCandidateFire_materialize_install_eq_complete candidate context position + output hstate)))) + have hresolve : evalDist + (LazyRevealProbe.sampleHashOutput >>= continuation) = + evalDist (resolveThenPrivateCandidateFire position candidate context) := by + unfold resolveThenPrivateCandidateFire + rw [resolveDeferredPositionValue_fresh position context hstate hprivate] + simp only [bind_assoc] + apply evalDist_bind_congr + intro output _houtput + by_cases hhit : context.state.hitAt (.position position) output <;> + simp [hhit, continuation, completePrivatePosition] + have hprob : + Pr[fun hit : Bool => hit = true | + LazyRevealProbe.sampleHashOutput >>= continuation] = + Pr[fun hit : Bool => hit = true | + resolveThenPrivateCandidateFire position candidate context] := by + rw [probEvent_eq_eq_probOutput, probEvent_eq_eq_probOutput] + exact OracleComp.probOutput_congr rfl hresolve + have hresolveBound : + Pr[fun hit : Bool => hit = true | + resolveThenPrivateCandidateFire position candidate context] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate context] := by + rw [probEvent_eq_eq_probOutput, probEvent_eq_eq_probOutput] + exact probEvent_resolveThenPrivateCandidateFire_le position candidate context + calc + _ ≤ Pr[fun hit : Bool => hit = true | + LazyRevealProbe.sampleHashOutput >>= continuation] := hleft + _ = Pr[fun hit : Bool => hit = true | + resolveThenPrivateCandidateFire position candidate context] := hprob + _ ≤ _ := hresolveBound + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_runDirectWitnessPrivateCandidateFire_le + (candidate : Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + Pr[fun hit : Bool => hit = true | + runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectWitnessPrivateCandidateFire candidate] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate context] := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runDirectResolvedWitnessFromTable, finishDirectWitnessPrivateCandidateFire] + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectResolvedWitnessFromTable_uniform_query_bind, bind_assoc] + apply probEvent_bind_le_of_forall_le + intro output _houtput + exact ih output context fuel + | hashOutput => + rw [runDirectResolvedWitnessFromTable_hashOutput_query_bind, bind_assoc] + apply probEvent_bind_le_of_forall_le + intro output _houtput + exact ih output context fuel + | ensure coordinate => + rw [runDirectResolvedWitnessFromTable_ensure_query_bind] + exact (ih () { context with state := context.state.ensure coordinate } fuel).trans + (le_of_eq (OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + (congrArg evalDist (privateCandidateFire_ensure candidate context coordinate)))) + | probe coordinate digest => + rw [runDirectResolvedWitnessFromTable_probe_query_bind] + cases fuel with + | zero => simp [finishDirectWitnessPrivateCandidateFire] + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () context remaining + · simp only [hrevealed, ↓reduceIte] + exact (ih () + { context with state := context.state.addPending coordinate digest } + remaining).trans + (le_of_eq (OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + (congrArg evalDist + (privateCandidateFire_addPending candidate context coordinate digest)))) + | peek coordinate => + rw [runDirectResolvedWitnessFromTable_peek_query_bind] + exact ih (context.state.values coordinate) context fuel + | publish coordinate => + rw [runDirectResolvedWitnessFromTable_publish_query_bind] + exact (ih () { context with state := context.state.publish coordinate } fuel).trans + (le_of_eq (OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + (congrArg evalDist (privateCandidateFire_publish candidate context coordinate)))) + | reveal coordinate => + rw [runDirectResolvedWitnessFromTable_reveal_query_bind] + cases hstate : context.state.values coordinate with + | some output => + exact ih output context fuel + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit, finishDirectWitnessPrivateCandidateFire] + · simp only [output, hhit, ↓reduceIte] + exact (ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel).trans + (le_of_eq (OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + (congrArg evalDist + (privateCandidateFire_materialize_chainStart candidate context lay + tree leafIdx chainIdx output)))) + | position position => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hprivate, hhit, finishDirectWitnessPrivateCandidateFire] + · simp only [hprivate, hhit, ↓reduceIte] + have hvalue : context.positionValue position = some output := by + simp [DeferredContext.positionValue, hstate, hprivate] + exact (ih output + { state := context.state.materialize (.position position) output + values := context.values } + fuel).trans + (le_of_eq (OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + (congrArg evalDist + (privateCandidateFire_materialize_position_of_positionValue + candidate context position output hvalue)))) + | none => + simp only [hprivate, bind_assoc] + have htail : ∀ output, + Pr[fun hit : Bool => hit = true | + runDirectResolvedWitnessFromTable + { state := context.state.materialize + (.position position) output + values := context.values.install position output } + fuel table (next output) >>= + finishDirectWitnessPrivateCandidateFire candidate] ≤ + Pr[fun hit : Bool => hit = true | + privateCandidateFire candidate + { state := context.state.materialize + (.position position) output + values := context.values.install position output }] := by + intro output + exact ih output + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel + have hfresh := probEvent_freshPositionWitnessPrivateCandidateFire_le + (α := α) (candidate := candidate) (context := context) + (position := position) (fuel := fuel) (table := table) (next := next) + hstate hprivate htail + have hnormalize : + (LazyRevealProbe.sampleHashOutput >>= fun output => + (if context.state.hitAt (.position position) output then + pure (.stoppedOrdinary : DirectWitnessResult α) + else + runDirectResolvedWitnessFromTable + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel table (next output)) >>= + finishDirectWitnessPrivateCandidateFire candidate) = + (LazyRevealProbe.sampleHashOutput >>= fun output => + if context.state.hitAt (.position position) output then + pure false + else + runDirectResolvedWitnessFromTable + { state := context.state.materialize + (.position position) output + values := context.values.install position output } + fuel table (next output) >>= + finishDirectWitnessPrivateCandidateFire candidate) := by + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output <;> + simp [hhit, finishDirectWitnessPrivateCandidateFire] + rw [hnormalize] + exact hfresh + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalMatch.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalMatch.lean new file mode 100644 index 00000000..240cffaa --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalMatch.lean @@ -0,0 +1,279 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalUnion + +/-! +# Fixed-candidate witness matching + +After one candidate ordinal is selected, a private stop is relevant only when its retained position +and output match that candidate. The combined matching-stop or completed-context observer remains +bounded by the candidate's current deferred firing risk. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +def PrivateHitWitness.MatchesCandidate + (witness : PrivateHitWitness) (candidate : Probe) : Prop := + candidate.coordinate = .position witness.position ∧ + truncateHash witness.output = candidate.candidate + +noncomputable def finishDirectWitnessPrivateCandidateMatch + (candidate : Probe) : DirectWitnessResult α → ProbComp Bool + | .stoppedFuel => pure false + | .stoppedOrdinary => pure false + | .stoppedPrivate witness => pure (decide (witness.MatchesCandidate candidate)) + | .done result => privateCandidateFire candidate result.context + +theorem probEvent_privateWitnessMatch_le_privateCandidateFire_of_privateValue + (candidate : Probe) (context : DeferredContext) + (position : Position) (output : HashOutput) + (hstate : context.state.values (.position position) = none) + (hprivate : context.values position = some output) : + Pr[= true | (pure (decide ((PrivateHitWitness.mk position output + context.state.revealed).MatchesCandidate + candidate)) : ProbComp Bool)] ≤ + Pr[= true | privateCandidateFire candidate context] := by + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [PrivateHitWitness.MatchesCandidate, privateCandidateFire, hcoordinate] + | position target => + by_cases heq : target = position + · subst target + unfold privateCandidateFire deferredPositionOutput DeferredContext.positionValue + simp [PrivateHitWitness.MatchesCandidate, hcoordinate, hstate, hprivate] + · simp [PrivateHitWitness.MatchesCandidate, privateCandidateFire, hcoordinate, heq] + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_freshPositionWitnessPrivateCandidateMatch_le + (candidate : Probe) (context : DeferredContext) (position : Position) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) + (hstate : context.state.values (.position position) = none) + (hprivate : context.values position = none) + (htail : ∀ output, + Pr[fun hit : Bool => hit = true | + runDirectResolvedWitnessFromTable + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel table (next output) >>= + finishDirectWitnessPrivateCandidateMatch candidate] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate + { state := context.state.materialize (.position position) output + values := context.values.install position output }]) : + Pr[fun hit : Bool => hit = true | + LazyRevealProbe.sampleHashOutput >>= fun output => + if context.state.hitAt (.position position) output then + pure false + else + runDirectResolvedWitnessFromTable + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel table (next output) >>= + finishDirectWitnessPrivateCandidateMatch candidate] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate context] := by + let continuation := fun output : HashOutput => + if context.state.hitAt (.position position) output then + pure false + else + privateCandidateFire candidate + (completePrivatePosition position context output).toDeferredContext + have hleft : + Pr[fun hit : Bool => hit = true | + LazyRevealProbe.sampleHashOutput >>= fun output => + if context.state.hitAt (.position position) output then + pure false + else + runDirectResolvedWitnessFromTable + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel table (next output) >>= + finishDirectWitnessPrivateCandidateMatch candidate] ≤ + Pr[fun hit : Bool => hit = true | + LazyRevealProbe.sampleHashOutput >>= continuation] := by + apply probEvent_bind_mono + intro output _houtput + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit, continuation] + · simp only [hhit, ↓reduceIte, continuation] + exact (htail output).trans (le_of_eq (OracleComp.probEvent_congr' + (fun _ _ => Iff.rfl) (congrArg evalDist + (privateCandidateFire_materialize_install_eq_complete candidate context position + output hstate)))) + have hresolve : evalDist + (LazyRevealProbe.sampleHashOutput >>= continuation) = + evalDist (resolveThenPrivateCandidateFire position candidate context) := by + unfold resolveThenPrivateCandidateFire + rw [resolveDeferredPositionValue_fresh position context hstate hprivate] + simp only [bind_assoc] + apply evalDist_bind_congr + intro output _houtput + by_cases hhit : context.state.hitAt (.position position) output <;> + simp [hhit, continuation, completePrivatePosition] + have hprob : + Pr[fun hit : Bool => hit = true | + LazyRevealProbe.sampleHashOutput >>= continuation] = + Pr[fun hit : Bool => hit = true | + resolveThenPrivateCandidateFire position candidate context] := by + rw [probEvent_eq_eq_probOutput, probEvent_eq_eq_probOutput] + exact OracleComp.probOutput_congr rfl hresolve + have hresolveBound : + Pr[fun hit : Bool => hit = true | + resolveThenPrivateCandidateFire position candidate context] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate context] := by + rw [probEvent_eq_eq_probOutput, probEvent_eq_eq_probOutput] + exact probEvent_resolveThenPrivateCandidateFire_le position candidate context + calc + _ ≤ Pr[fun hit : Bool => hit = true | + LazyRevealProbe.sampleHashOutput >>= continuation] := hleft + _ = Pr[fun hit : Bool => hit = true | + resolveThenPrivateCandidateFire position candidate context] := hprob + _ ≤ _ := hresolveBound + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_runDirectWitnessPrivateCandidateMatch_le + (candidate : Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + Pr[fun hit : Bool => hit = true | + runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectWitnessPrivateCandidateMatch candidate] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate context] := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runDirectResolvedWitnessFromTable, finishDirectWitnessPrivateCandidateMatch] + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectResolvedWitnessFromTable_uniform_query_bind, bind_assoc] + apply probEvent_bind_le_of_forall_le + intro output _houtput + exact ih output context fuel + | hashOutput => + rw [runDirectResolvedWitnessFromTable_hashOutput_query_bind, bind_assoc] + apply probEvent_bind_le_of_forall_le + intro output _houtput + exact ih output context fuel + | ensure coordinate => + rw [runDirectResolvedWitnessFromTable_ensure_query_bind] + exact (ih () { context with state := context.state.ensure coordinate } fuel).trans + (le_of_eq (OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + (congrArg evalDist (privateCandidateFire_ensure candidate context coordinate)))) + | probe coordinate digest => + rw [runDirectResolvedWitnessFromTable_probe_query_bind] + cases fuel with + | zero => simp [finishDirectWitnessPrivateCandidateMatch] + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () context remaining + · simp only [hrevealed, ↓reduceIte] + exact (ih () + { context with state := context.state.addPending coordinate digest } + remaining).trans + (le_of_eq (OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + (congrArg evalDist + (privateCandidateFire_addPending candidate context coordinate digest)))) + | peek coordinate => + rw [runDirectResolvedWitnessFromTable_peek_query_bind] + exact ih (context.state.values coordinate) context fuel + | publish coordinate => + rw [runDirectResolvedWitnessFromTable_publish_query_bind] + exact (ih () { context with state := context.state.publish coordinate } fuel).trans + (le_of_eq (OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + (congrArg evalDist (privateCandidateFire_publish candidate context coordinate)))) + | reveal coordinate => + rw [runDirectResolvedWitnessFromTable_reveal_query_bind] + cases hstate : context.state.values coordinate with + | some output => exact ih output context fuel + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit, finishDirectWitnessPrivateCandidateMatch] + · simp only [output, hhit, ↓reduceIte] + exact (ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel).trans + (le_of_eq (OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + (congrArg evalDist + (privateCandidateFire_materialize_chainStart candidate context lay + tree leafIdx chainIdx output)))) + | position position => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · have hmatch := + probEvent_privateWitnessMatch_le_privateCandidateFire_of_privateValue + candidate context position output hstate hprivate + simpa [hprivate, hhit, finishDirectWitnessPrivateCandidateMatch] using hmatch + · simp only [hprivate, hhit, ↓reduceIte] + have hvalue : context.positionValue position = some output := by + simp [DeferredContext.positionValue, hstate, hprivate] + exact (ih output + { state := context.state.materialize (.position position) output + values := context.values } + fuel).trans + (le_of_eq (OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + (congrArg evalDist + (privateCandidateFire_materialize_position_of_positionValue + candidate context position output hvalue)))) + | none => + simp only [hprivate, bind_assoc] + have htail : ∀ output, + Pr[fun hit : Bool => hit = true | + runDirectResolvedWitnessFromTable + { state := context.state.materialize + (.position position) output + values := context.values.install position output } + fuel table (next output) >>= + finishDirectWitnessPrivateCandidateMatch candidate] ≤ + Pr[fun hit : Bool => hit = true | + privateCandidateFire candidate + { state := context.state.materialize + (.position position) output + values := context.values.install position output }] := by + intro output + exact ih output + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel + have hfresh := probEvent_freshPositionWitnessPrivateCandidateMatch_le + (α := α) (candidate := candidate) (context := context) + (position := position) (fuel := fuel) (table := table) (next := next) + hstate hprivate htail + have hnormalize : + (LazyRevealProbe.sampleHashOutput >>= fun output => + (if context.state.hitAt (.position position) output then + pure (.stoppedOrdinary : DirectWitnessResult α) + else + runDirectResolvedWitnessFromTable + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel table (next output)) >>= + finishDirectWitnessPrivateCandidateMatch candidate) = + (LazyRevealProbe.sampleHashOutput >>= fun output => + if context.state.hitAt (.position position) output then + pure false + else + runDirectResolvedWitnessFromTable + { state := context.state.materialize + (.position position) output + values := context.values.install position output } + fuel table (next output) >>= + finishDirectWitnessPrivateCandidateMatch candidate) := by + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output <;> + simp [hhit, finishDirectWitnessPrivateCandidateMatch] + rw [hnormalize] + exact hfresh + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalMatchLift.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalMatchLift.lean new file mode 100644 index 00000000..797b9612 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalMatchLift.lean @@ -0,0 +1,315 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalMatch + +/-! +# Fixed-candidate outer continuation + +The witness event after a candidate is fixed is lifted through direct runs and canonical query +boundaries. Candidate-list bookkeeping is irrelevant here; only the retained position and output +are compared with the selected candidate. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +def PrivateWitnessPlanMatchesCandidate + (candidate : Probe) (output : PrivateWitnessPlanOutput) : Prop := + ∃ witness, output.1 = some witness ∧ witness.MatchesCandidate candidate + +theorem probEvent_finishDirectWitnessPlanMatchesCandidate_le + (candidate : Probe) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (result : DirectWitnessResult α) + (hobserve : ∀ resolved : ResolvedRunResult α, + result = .done resolved → + Pr[PrivateWitnessPlanMatchesCandidate candidate | + observe resolved.context resolved.remaining resolved.value candidates] ≤ + Pr[fun hit : Bool => hit = true | + privateCandidateFire candidate resolved.context]) : + Pr[PrivateWitnessPlanMatchesCandidate candidate | + finishDirectWitnessPlanObserve observe candidates result] ≤ + Pr[fun hit : Bool => hit = true | + finishDirectWitnessPrivateCandidateMatch candidate result] := by + cases result with + | stoppedFuel => simp [finishDirectWitnessPlanObserve, + finishDirectWitnessPrivateCandidateMatch, PrivateWitnessPlanMatchesCandidate] + | stoppedOrdinary => simp [finishDirectWitnessPlanObserve, + finishDirectWitnessPrivateCandidateMatch, PrivateWitnessPlanMatchesCandidate] + | stoppedPrivate witness => + simp [finishDirectWitnessPlanObserve, finishDirectWitnessPrivateCandidateMatch, + PrivateWitnessPlanMatchesCandidate] + | done resolved => + simpa [finishDirectWitnessPlanObserve, finishDirectWitnessPrivateCandidateMatch] using + hobserve resolved rfl + +set_option maxRecDepth 100000 in +theorem probEvent_runDirectWitnessPlanMatchesCandidate_le + (candidate : Probe) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hobserve : ∀ result : ResolvedRunResult α, + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation) → + Pr[PrivateWitnessPlanMatchesCandidate candidate | + observe result.context result.remaining result.value candidates] ≤ + Pr[fun hit : Bool => hit = true | + privateCandidateFire candidate result.context]) : + Pr[PrivateWitnessPlanMatchesCandidate candidate | + runDirectWitnessPlanObserve observe candidates context fuel table computation] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate context] := by + unfold runDirectWitnessPlanObserve + calc + _ ≤ Pr[fun hit : Bool => hit = true | + runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectWitnessPrivateCandidateMatch candidate] := by + rw [probEvent_bind_eq_tsum, probEvent_bind_eq_tsum] + apply ENNReal.tsum_le_tsum + intro result + by_cases hresult : result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation) + · exact mul_le_mul' le_rfl + (probEvent_finishDirectWitnessPlanMatchesCandidate_le candidate observe candidates + result (by + intro resolved heq + subst result + exact hobserve resolved hresult)) + · rw [probOutput_eq_zero_of_not_mem_support hresult] + simp + _ ≤ _ := probEvent_runDirectWitnessPrivateCandidateMatch_le candidate context fuel table + computation + +theorem probEvent_classifyDirectWitnessPlanMatchesCandidate_le + (table : OtsSecretIndex → HashOutput) (candidate : Probe) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hcontinuation : ¬PrivateStructuralHit context → DeferredCompletable table context → + Pr[PrivateWitnessPlanMatchesCandidate candidate | + observe context fuel value candidates] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate context]) : + Pr[PrivateWitnessPlanMatchesCandidate candidate | + classifyDirectWitnessPlanObserve table observe context fuel value candidates] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate context] := by + unfold classifyDirectWitnessPlanObserve + by_cases hhit : PrivateStructuralHit context + · simp only [hhit, ↓reduceDIte] + have hspec := privateHitWitnessOf_spec context hhit + have hmatch := probEvent_privateWitnessMatch_le_privateCandidateFire_of_privateValue + candidate context (privateHitWitnessOf context hhit).position + (privateHitWitnessOf context hhit).output hspec.1 hspec.2.1 + simpa [PrivateWitnessPlanMatchesCandidate, privateHitWitnessOf] using hmatch + · simp only [hhit, ↓reduceDIte] + by_cases hcompletable : DeferredCompletable table context + · simp only [hcompletable, ↓reduceIte] + exact hcontinuation hhit hcompletable + · simp [hcompletable, PrivateWitnessPlanMatchesCandidate] + +theorem probEvent_canonicalizeDirectWitnessPlanMatchesCandidate_le + (table : OtsSecretIndex → HashOutput) (candidate : Probe) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hconsistent : context.ValuesConsistent) + (hcontinuation : + let canonical := canonicalizeMaterializedValues table context + ¬PrivateStructuralHit canonical → DeferredCompletable table canonical → + Pr[PrivateWitnessPlanMatchesCandidate candidate | + observe canonical fuel value candidates] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate canonical]) : + Pr[PrivateWitnessPlanMatchesCandidate candidate | + canonicalizeDirectWitnessPlanObserve table observe context fuel value candidates] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate context] := by + let canonical := canonicalizeMaterializedValues table context + have hfire := privateCandidateFire_canonicalize table candidate context hconsistent + have hfireProb : + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate canonical] = + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate context] := by + rw [probEvent_eq_eq_probOutput, probEvent_eq_eq_probOutput] + exact OracleComp.probOutput_congr rfl (congrArg evalDist hfire) + have hclassify : + Pr[PrivateWitnessPlanMatchesCandidate candidate | + classifyDirectWitnessPlanObserve table observe canonical fuel value candidates] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate canonical] := + probEvent_classifyDirectWitnessPlanMatchesCandidate_le table candidate observe canonical fuel + value candidates hcontinuation + unfold canonicalizeDirectWitnessPlanObserve + by_cases hhit : PrivateStructuralHit canonical + · simp only [canonical, hhit, ↓reduceDIte] + have hspec := privateHitWitnessOf_spec canonical hhit + have hmatch := probEvent_privateWitnessMatch_le_privateCandidateFire_of_privateValue + candidate canonical (privateHitWitnessOf canonical hhit).position + (privateHitWitnessOf canonical hhit).output hspec.1 hspec.2.1 + have hmatchEvent : + Pr[PrivateWitnessPlanMatchesCandidate candidate | + (pure (some (privateHitWitnessOf canonical hhit), candidates) : + ProbComp PrivateWitnessPlanOutput)] ≤ + Pr[fun hit : Bool => hit = true | + privateCandidateFire candidate canonical] := by + rw [probEvent_eq_eq_probOutput] + simpa [PrivateWitnessPlanMatchesCandidate, privateHitWitnessOf] using hmatch + exact hmatchEvent.trans (le_of_eq hfireProb) + · simp only [canonical, hhit, ↓reduceDIte] + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + exact hclassify.trans (le_of_eq hfireProb) + · simp [hpublished, PrivateWitnessPlanMatchesCandidate] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_directDetailedBoundaryNormalizedPrivateWitnessPlanMatchesCandidate_le + (candidate : Probe) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hterminal : ∀ nextContext remaining value nextCandidates, + nextContext.ValuesConsistent → StartTableAgrees nextContext.state table → + Pr[PrivateWitnessPlanMatchesCandidate candidate | + observe nextContext remaining value nextCandidates] ≤ + Pr[fun hit : Bool => hit = true | + privateCandidateFire candidate nextContext]) : + Pr[PrivateWitnessPlanMatchesCandidate candidate | + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + computation observe candidates context fuel table cache] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate context] := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_pure] + exact hterminal context fuel (value, cache) candidates hconsistent hstarts + | query_bind query next ih => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let inner := (splitUniformImpl n).run cache + apply probEvent_runDirectWitnessPlanMatchesCandidate_le candidate _ candidates + context fuel table inner + intro result hresult + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table inner) := by + rw [← map_erase_runDirectResolvedWitnessFromTable inner context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable inner context fuel table + result hconsistent hstarts + (mem_support_runDirectResolvedFromTable_of_done_detailed inner context fuel table + result hdetailed) + apply probEvent_canonicalizeDirectWitnessPlanMatchesCandidate_le table candidate _ + result.context result.remaining result.value candidates hcore.2.1 + dsimp only + intro _hprivate _hcompletable + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + let inner := (probingHashQueryAfterPlan parameter input plan).run cache + apply probEvent_runDirectWitnessPlanMatchesCandidate_le candidate _ nextCandidates + context fuel table inner + intro result hresult + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table inner) := by + rw [← map_erase_runDirectResolvedWitnessFromTable inner context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable inner context fuel table + result hconsistent hstarts + (mem_support_runDirectResolvedFromTable_of_done_detailed inner context fuel table + result hdetailed) + apply probEvent_canonicalizeDirectWitnessPlanMatchesCandidate_le table candidate _ + result.context result.remaining result.value nextCandidates hcore.2.1 + dsimp only + intro _hprivate _hcompletable + exact ih result.value.1 nextCandidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + | inr message => + let inner := (maskedSign parameter root ftsSecret message).run cache + apply probEvent_runDirectWitnessPlanMatchesCandidate_le candidate _ candidates context + fuel table inner + intro result hresult + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table inner) := by + rw [← map_erase_runDirectResolvedWitnessFromTable inner context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable inner context fuel table + result hconsistent hstarts + (mem_support_runDirectResolvedFromTable_of_done_detailed inner context fuel table result + hdetailed) + apply probEvent_canonicalizeDirectWitnessPlanMatchesCandidate_le table candidate _ + result.context result.remaining result.value candidates hcore.2.1 + dsimp only + intro _hprivate _hcompletable + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining result.value.2 + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + +theorem probEvent_retainedResolvedFinalizationPrivateWitnessPlanMatchesCandidate_le + (table : OtsSecretIndex → HashOutput) (root : Digest) (candidate : Probe) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) (candidates : List Probe) : + Pr[PrivateWitnessPlanMatchesCandidate candidate | + retainedResolvedFinalizationPrivateWitnessPlanObserve table root context fuel value + candidates] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate context] := by + unfold retainedResolvedFinalizationPrivateWitnessPlanObserve + by_cases hhit : PrivateStructuralHit context + · simp only [hhit, ↓reduceDIte] + have hspec := privateHitWitnessOf_spec context hhit + have hmatch := probEvent_privateWitnessMatch_le_privateCandidateFire_of_privateValue + candidate context (privateHitWitnessOf context hhit).position + (privateHitWitnessOf context hhit).output hspec.1 hspec.2.1 + have hmatchEvent : + Pr[PrivateWitnessPlanMatchesCandidate candidate | + (pure (some (privateHitWitnessOf context hhit), candidates) : + ProbComp PrivateWitnessPlanOutput)] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate context] := by + rw [probEvent_eq_eq_probOutput] + simpa [PrivateWitnessPlanMatchesCandidate, privateHitWitnessOf] using hmatch + exact hmatchEvent + · simp [hhit, PrivateWitnessPlanMatchesCandidate] + +theorem probEvent_granularDetailedRetainedRestNormalizedWitnessMatchesCandidate_le + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (candidate : Probe) (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + Pr[PrivateWitnessPlanMatchesCandidate candidate | + granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate context] := by + unfold granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve + apply probEvent_directDetailedBoundaryNormalizedPrivateWitnessPlanMatchesCandidate_le candidate + parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivateWitnessPlanObserve table value.1) + candidates context fuel table value.2 hconsistent hstarts + intro nextContext remaining nextValue nextCandidates _hnextConsistent _hnextStarts + exact probEvent_retainedResolvedFinalizationPrivateWitnessPlanMatchesCandidate_le table value.1 + candidate nextContext remaining nextValue nextCandidates + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalNonRootRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalNonRootRisk.lean new file mode 100644 index 00000000..782c62d9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalNonRootRisk.lean @@ -0,0 +1,806 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenFreshSigner + +/-! +# Non-root ordinal risk + +The least selected ordinal is split by whether its candidate names a layer root. This risk is the +existing hidden prefix risk with root candidates gated to false. The weakened freshness invariant +is therefore sufficient through the concrete signer. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +noncomputable def nonRootHiddenPrivateCandidateFire + (candidate : Probe) (context : DeferredContext) : ProbComp Bool := + if candidate.IsLayerRoot then pure false else hiddenPrivateCandidateFire candidate context + +theorem probEvent_nonRootHiddenPrivateCandidateFire_le + (candidate : Probe) (context : DeferredContext) + (hparent : candidate.HasStructuralParent) + (hfresh : CandidatePositionsFreshExceptLayerRoots context) : + Pr[fun hit : Bool => hit = true | + nonRootHiddenPrivateCandidateFire candidate context] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + by_cases hroot : candidate.IsLayerRoot + · simp [nonRootHiddenPrivateCandidateFire, hroot] + · rw [nonRootHiddenPrivateCandidateFire, if_neg hroot] + rw [probEvent_eq_eq_probOutput] + exact probEvent_hiddenPrivateCandidateFire_le_of_freshExceptLayerRoots candidate context + hparent hroot hfresh + +noncomputable def directDetailedBoundaryPrivateOrdinalNonRootRisk + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : ProbComp Bool := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + List Probe → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → + SplitHashCache → ProbComp Bool) + (fun _value candidates context _fuel _table _cache => + if hselected : ordinal < candidates.length then + nonRootHiddenPrivateCandidateFire (candidates.get ⟨ordinal, hselected⟩) context + else pure false) + (fun query _next recursivelyRun candidates context fuel table cache => + if hselected : ordinal < candidates.length then + nonRootHiddenPrivateCandidateFire (candidates.get ⟨ordinal, hselected⟩) context + else + match query with + | .inl (.inl n) => + runDirectResolvedWitnessFromTable context fuel table ((splitUniformImpl n).run cache) >>= + finishDirectWitnessOrdinalRisk + (canonicalizeDirectWitnessOrdinalRisk table + (fun nextContext remaining value laterCandidates => + recursivelyRun value.1 laterCandidates nextContext remaining table value.2)) + candidates + | .inl (.inr input) => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + if hnextSelected : ordinal < nextCandidates.length then + nonRootHiddenPrivateCandidateFire + (nextCandidates.get ⟨ordinal, hnextSelected⟩) context + else + runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) >>= + finishDirectWitnessOrdinalRisk + (canonicalizeDirectWitnessOrdinalRisk table + (fun nextContext remaining value laterCandidates => + recursivelyRun value.1 laterCandidates nextContext remaining table value.2)) + nextCandidates + | .inr message => + runDirectResolvedWitnessFromTable context fuel table + ((maskedSign parameter root ftsSecret message).run cache) >>= + finishDirectWitnessOrdinalRisk + (canonicalizeDirectWitnessOrdinalRisk table + (fun nextContext remaining value laterCandidates => + recursivelyRun value.1 laterCandidates nextContext remaining table value.2)) + candidates) + computation candidates context fuel table cache + +theorem directDetailedBoundaryPrivateOrdinalNonRootRisk_eq_fire_of_selected + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hselected : ordinal < candidates.length) : + directDetailedBoundaryPrivateOrdinalNonRootRisk ordinal parameter root ftsSecret computation + candidates context fuel table cache = + nonRootHiddenPrivateCandidateFire + (candidates.get ⟨ordinal, hselected⟩) context := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryPrivateOrdinalNonRootRisk, OracleComp.construct_pure] + simp only [hselected, ↓reduceDIte] + | query_bind query next ih => + rw [directDetailedBoundaryPrivateOrdinalNonRootRisk, OracleComp.construct_query_bind] + simp only [hselected, ↓reduceDIte] + +theorem not_witnessFirstUsesNonLayerRootOrdinal_of_not_lt_length + (ordinal : Nat) (output : PrivateWitnessPlanOutput) + (hnot : ¬ordinal < output.2.length) : + ¬WitnessFirstUsesNonLayerRootOrdinal ordinal output := by + intro hfirst + exact (not_witnessUsesOrdinal_of_not_lt_length ordinal output hnot) + (witnessUsesOrdinal_of_witnessFirstUsesNonLayerRootOrdinal hfirst) + +theorem probEvent_finishDirectWitnessPlanFirstUsesNonRootOrdinal_le_risk + (ordinal : Nat) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (riskObserve : DeferredContext → Nat → α → List Probe → ProbComp Bool) + (candidates : List Probe) (result : DirectWitnessResult α) + (hnotSelected : ¬ordinal < candidates.length) + (hcontinuation : ∀ resolved : ResolvedRunResult α, + result = .done resolved → + Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + observe resolved.context resolved.remaining resolved.value candidates] ≤ + Pr[fun hit : Bool => hit = true | + riskObserve resolved.context resolved.remaining resolved.value candidates]) : + Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + finishDirectWitnessPlanObserve observe candidates result] ≤ + Pr[fun hit : Bool => hit = true | + finishDirectWitnessOrdinalRisk riskObserve candidates result] := by + cases result with + | stoppedFuel => + simp [finishDirectWitnessPlanObserve, finishDirectWitnessOrdinalRisk, + WitnessFirstUsesNonLayerRootOrdinal] + | stoppedOrdinary => + simp [finishDirectWitnessPlanObserve, finishDirectWitnessOrdinalRisk, + WitnessFirstUsesNonLayerRootOrdinal] + | stoppedPrivate witness => + have hnone : ¬WitnessFirstUsesNonLayerRootOrdinal ordinal (some witness, candidates) := + not_witnessFirstUsesNonLayerRootOrdinal_of_not_lt_length ordinal + (some witness, candidates) hnotSelected + simp [finishDirectWitnessPlanObserve, finishDirectWitnessOrdinalRisk, hnone] + | done resolved => + simpa [finishDirectWitnessPlanObserve, finishDirectWitnessOrdinalRisk] using + hcontinuation resolved rfl + +theorem probEvent_runDirectWitnessPlanFirstUsesNonRootOrdinal_le_risk + (ordinal : Nat) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (riskObserve : DeferredContext → Nat → α → List Probe → ProbComp Bool) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hnotSelected : ¬ordinal < candidates.length) + (hcontinuation : ∀ result : ResolvedRunResult α, + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation) → + Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + observe result.context result.remaining result.value candidates] ≤ + Pr[fun hit : Bool => hit = true | + riskObserve result.context result.remaining result.value candidates]) : + Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + runDirectWitnessPlanObserve observe candidates context fuel table computation] ≤ + Pr[fun hit : Bool => hit = true | + runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectWitnessOrdinalRisk riskObserve candidates] := by + unfold runDirectWitnessPlanObserve + rw [probEvent_bind_eq_tsum, probEvent_bind_eq_tsum] + apply ENNReal.tsum_le_tsum + intro result + by_cases hresult : result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation) + · exact mul_le_mul' le_rfl + (probEvent_finishDirectWitnessPlanFirstUsesNonRootOrdinal_le_risk ordinal observe riskObserve + candidates result hnotSelected (by + intro resolved heq + subst result + exact hcontinuation resolved hresult)) + · rw [probOutput_eq_zero_of_not_mem_support hresult] + simp + +theorem probEvent_canonicalizeWitnessPlanFirstUsesNonRootOrdinal_le_risk + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (riskObserve : DeferredContext → Nat → α → List Probe → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hnotSelected : ¬ordinal < candidates.length) + (hcontinuation : + let canonical := canonicalizeMaterializedValues table context + ¬PrivateStructuralHit canonical → PublishedValues context.state → + DeferredCompletable table canonical → + Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + observe canonical fuel value candidates] ≤ + Pr[fun hit : Bool => hit = true | + riskObserve canonical fuel value candidates]) : + Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + canonicalizeDirectWitnessPlanObserve table observe context fuel value candidates] ≤ + Pr[fun hit : Bool => hit = true | + canonicalizeDirectWitnessOrdinalRisk table riskObserve context fuel value candidates] := by + let canonical := canonicalizeMaterializedValues table context + unfold canonicalizeDirectWitnessPlanObserve canonicalizeDirectWitnessOrdinalRisk + by_cases hhit : PrivateStructuralHit canonical + · simp only [canonical, hhit, ↓reduceDIte, if_pos] + rw [probEvent_pure, probEvent_pure] + simp only [Bool.false_eq_true, if_false] + rw [if_neg + (not_witnessFirstUsesNonLayerRootOrdinal_of_not_lt_length ordinal _ hnotSelected)] + · simp only [canonical, hhit, ↓reduceDIte] + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + unfold classifyDirectWitnessPlanObserve + change ¬PrivateStructuralHit (canonicalizeMaterializedValues table context) at hhit + simp only [hhit, ↓reduceDIte] + by_cases hcompletable : DeferredCompletable table canonical + · change DeferredCompletable table (canonicalizeMaterializedValues table context) + at hcompletable + simp only [hcompletable, ↓reduceIte] + exact hcontinuation hhit hpublished hcompletable + · change ¬DeferredCompletable table (canonicalizeMaterializedValues table context) + at hcompletable + simp only [hcompletable, ↓reduceIte, probEvent_pure, Bool.false_eq_true] + have hnone : ¬WitnessFirstUsesNonLayerRootOrdinal ordinal + ((none, candidates) : PrivateWitnessPlanOutput) := + not_witnessFirstUsesNonLayerRootOrdinal_of_not_lt_length ordinal _ hnotSelected + rw [if_neg hnone] + · simp only [hpublished, ↓reduceIte, probEvent_pure, Bool.false_eq_true] + have hnone : ¬WitnessFirstUsesNonLayerRootOrdinal ordinal + ((none, candidates) : PrivateWitnessPlanOutput) := + not_witnessFirstUsesNonLayerRootOrdinal_of_not_lt_length ordinal _ hnotSelected + rw [if_neg hnone] + +theorem probEvent_unselectedDirectWitnessStepFirstUsesNonRootOrdinal_le_risk + (ordinal : Nat) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (riskObserve : DeferredContext → Nat → α → List Probe → ProbComp Bool) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hnotSelected : ¬ordinal < candidates.length) + (hcontinuation : ∀ result : ResolvedRunResult α, + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation) → + Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + observe (canonicalizeMaterializedValues table result.context) + result.remaining result.value candidates] ≤ + Pr[fun hit : Bool => hit = true | + riskObserve (canonicalizeMaterializedValues table result.context) + result.remaining result.value candidates]) : + Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + runDirectWitnessPlanObserve + (canonicalizeDirectWitnessPlanObserve table observe) + candidates context fuel table computation] ≤ + Pr[fun hit : Bool => hit = true | + runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectWitnessOrdinalRisk + (canonicalizeDirectWitnessOrdinalRisk table riskObserve) candidates] := by + apply probEvent_runDirectWitnessPlanFirstUsesNonRootOrdinal_le_risk ordinal _ _ candidates + context fuel table computation hnotSelected + intro result hresult + apply probEvent_canonicalizeWitnessPlanFirstUsesNonRootOrdinal_le_risk table ordinal _ _ + result.context result.remaining result.value candidates hnotSelected + dsimp only + intro _hprivate _hpublished _hcompletable + exact hcontinuation result hresult + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_directDetailedBoundaryWitnessFirstUsesNonRootOrdinal_le_of_selected + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hselected : ordinal < candidates.length) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) + (hterminal : ∀ nextContext remaining value nextCandidates, + nextContext.ValuesConsistent → StartTableAgrees nextContext.state table → + PublishedValues nextContext.state → + Pr[PrivateWitnessPlanMatchesCandidate (candidates.get ⟨ordinal, hselected⟩) | + observe nextContext remaining value nextCandidates] ≤ + Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire (candidates.get ⟨ordinal, hselected⟩) nextContext]) + (hobservePrefix : ∀ nextContext remaining value nextCandidates output, + output ∈ support (observe nextContext remaining value nextCandidates) → + PrivateWitnessPlanExtends nextCandidates output) : + Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + computation observe candidates context fuel table cache] ≤ + Pr[fun hit : Bool => hit = true | + nonRootHiddenPrivateCandidateFire + (candidates.get ⟨ordinal, hselected⟩) context] := by + let candidate := candidates.get ⟨ordinal, hselected⟩ + by_cases hroot : candidate.IsLayerRoot + · have hzero : Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + computation observe candidates context fuel table cache] = 0 := by + apply probEvent_eq_zero + intro output houtput hfirst + exact not_witnessFirstUsesNonLayerRootOrdinal_of_prefix_of_root candidates output ordinal + hselected + (privateWitnessPlanExtends_of_mem_directDetailedBoundaryNormalizedPrivateWitnessPlanObserve + parameter root ftsSecret computation observe candidates context fuel table cache + hobservePrefix output houtput) + hroot hfirst + rw [hzero] + have hroot' : (candidates.get ⟨ordinal, hselected⟩).IsLayerRoot := by + simpa [candidate] using hroot + unfold nonRootHiddenPrivateCandidateFire + rw [if_pos hroot'] + simp + · calc + _ ≤ Pr[PrivateWitnessPlanMatchesCandidate candidate | + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + computation observe candidates context fuel table cache] := by + apply probEvent_mono + intro output houtput hfirst + apply privateWitnessPlanMatchesCandidate_of_usesOrdinal_of_prefix candidates output + ordinal hselected + · exact privateWitnessPlanExtends_of_mem_directDetailedBoundaryNormalizedPrivateWitnessPlanObserve + parameter root ftsSecret computation observe candidates context fuel table cache + hobservePrefix output houtput + · exact witnessUsesOrdinal_of_witnessFirstUsesNonLayerRootOrdinal hfirst + _ ≤ Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate context] := by + exact probEvent_directDetailedBoundaryNormalizedPrivateWitnessPlanMatchesCandidate_le_hidden + candidate parameter root ftsSecret computation observe candidates context fuel table + cache hconsistent hstarts hpublished (by + intro nextContext remaining value nextCandidates hnextConsistent hnextStarts + hnextPublished + exact hterminal nextContext remaining value nextCandidates hnextConsistent hnextStarts + hnextPublished) + _ = _ := by + have hroot' : ¬(candidates.get ⟨ordinal, hselected⟩).IsLayerRoot := by + simpa [candidate] using hroot + unfold nonRootHiddenPrivateCandidateFire + rw [if_neg hroot'] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_hashBranchWitnessFirstUsesNonRootOrdinal_le_nonRootRisk + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hnotSelected : ¬ordinal < candidates.length) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) + (hrecursive : ∀ output nextCandidates nextContext remaining nextCache, + ¬ordinal < nextCandidates.length → + nextContext.ValuesConsistent → StartTableAgrees nextContext.state table → + PublishedValues nextContext.state → + Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + (next output) observe nextCandidates nextContext remaining table nextCache] ≤ + Pr[fun hit : Bool => hit = true | + directDetailedBoundaryPrivateOrdinalNonRootRisk ordinal parameter root ftsSecret + (next output) nextCandidates nextContext remaining table nextCache]) + (hterminalMatch : ∀ candidate nextContext remaining value nextCandidates, + nextContext.ValuesConsistent → StartTableAgrees nextContext.state table → + PublishedValues nextContext.state → + Pr[PrivateWitnessPlanMatchesCandidate candidate | + observe nextContext remaining value nextCandidates] ≤ + Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate nextContext]) + (hterminalPrefix : ∀ nextContext remaining value nextCandidates output, + output ∈ support (observe nextContext remaining value nextCandidates) → + PrivateWitnessPlanExtends nextCandidates output) : + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + runDirectWitnessPlanObserve + (canonicalizeDirectWitnessPlanObserve table + (fun nextContext remaining value laterCandidates => + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + (next value.1) observe laterCandidates nextContext remaining table value.2)) + nextCandidates context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache)] ≤ + Pr[fun hit : Bool => hit = true | + if hselected : ordinal < nextCandidates.length then + nonRootHiddenPrivateCandidateFire + (nextCandidates.get ⟨ordinal, hselected⟩) context + else + runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) >>= + finishDirectWitnessOrdinalRisk + (canonicalizeDirectWitnessOrdinalRisk table + (fun nextContext remaining value laterCandidates => + directDetailedBoundaryPrivateOrdinalNonRootRisk ordinal parameter root ftsSecret + (next value.1) laterCandidates nextContext remaining table value.2)) + nextCandidates] := by + dsimp only + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + by_cases hnextSelected : ordinal < nextCandidates.length + · rw [dif_pos hnextSelected] + have hexists : ∃ candidate, + rootAwarePlannedCandidate? parameter input context.state = some candidate := by + cases hcandidate : rootAwarePlannedCandidate? parameter input context.state with + | none => + have hsame : nextCandidates = candidates := by + simp [nextCandidates, appendPlannedCandidate, hcandidate] + exact (hnotSelected (hsame ▸ hnextSelected)).elim + | some candidate => exact ⟨candidate, rfl⟩ + obtain ⟨candidate, hcandidate⟩ := hexists + have hordinal : ordinal = candidates.length := by + have hlength : nextCandidates.length = candidates.length + 1 := by + simp [nextCandidates, appendPlannedCandidate, hcandidate] + omega + subst ordinal + have hget : nextCandidates.get ⟨candidates.length, hnextSelected⟩ = candidate := by + simp [nextCandidates, appendPlannedCandidate, hcandidate, List.get_eq_getElem] + rw [hget] + by_cases hroot : candidate.IsLayerRoot + · have hzero : Pr[WitnessFirstUsesNonLayerRootOrdinal candidates.length | + runDirectWitnessPlanObserve + (canonicalizeDirectWitnessPlanObserve table + (fun nextContext remaining value laterCandidates => + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + (next value.1) observe laterCandidates nextContext remaining table value.2)) + nextCandidates context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache)] = 0 := by + apply probEvent_eq_zero + intro output houtput hfirst + apply not_witnessFirstUsesNonLayerRootOrdinal_of_prefix_of_root nextCandidates output + candidates.length hnextSelected + · apply privateWitnessPlanExtends_of_mem_runDirectWitnessPlanObserve _ nextCandidates + context fuel table ((probingHashQueryAfterPlan parameter input plan).run cache) + (output := output) (houtput := houtput) + intro result _hresult nextOutput hnextOutput + apply privateWitnessPlanExtends_of_mem_canonicalizeDirectWitnessPlanObserve table _ + result.context result.remaining result.value nextCandidates + (output := nextOutput) (houtput := hnextOutput) + intro finalOutput hfinalOutput + exact privateWitnessPlanExtends_of_mem_directDetailedBoundaryNormalizedPrivateWitnessPlanObserve + parameter root ftsSecret (next result.value.1) observe nextCandidates + (canonicalizeMaterializedValues table result.context) result.remaining table + result.value.2 hterminalPrefix finalOutput hfinalOutput + · rw [hget] + exact hroot + · exact hfirst + rw [hzero] + simp [nonRootHiddenPrivateCandidateFire, hroot] + · have hbound := probEvent_selectedHashPlanWitnessUsesOrdinal_le_hidden parameter root + ftsSecret input next observe candidates context fuel table cache candidate hconsistent + hstarts hpublished + (by + intro nextContext remaining value laterCandidates hnextConsistent hnextStarts + hnextPublished + exact hterminalMatch candidate nextContext remaining value laterCandidates + hnextConsistent hnextStarts hnextPublished) + hterminalPrefix + calc + _ ≤ Pr[WitnessUsesOrdinal candidates.length | + runDirectWitnessPlanObserve + (canonicalizeDirectWitnessPlanObserve table + (fun nextContext remaining value laterCandidates => + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root + ftsSecret (next value.1) observe laterCandidates nextContext remaining table + value.2)) + nextCandidates context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache)] := by + apply probEvent_mono + intro output _houtput hfirst + exact witnessUsesOrdinal_of_witnessFirstUsesNonLayerRootOrdinal hfirst + _ ≤ Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate context] := by + simpa only [nextCandidates, hcandidate, appendPlannedCandidate, plan] using hbound + _ = _ := by + unfold nonRootHiddenPrivateCandidateFire + rw [if_neg hroot] + · rw [dif_neg hnextSelected] + apply probEvent_unselectedDirectWitnessStepFirstUsesNonRootOrdinal_le_risk ordinal _ _ + nextCandidates context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) hnextSelected + intro result hresult + let inner := (probingHashQueryAfterPlan parameter input plan).run cache + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table inner) := by + rw [← map_erase_runDirectResolvedWitnessFromTable inner context fuel table, support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hcore := resolvedCore_of_done_mem_runDirectResolvedWitnessFromTable inner context fuel + table result hconsistent hstarts hresult + have hnextPublished := publishedValues_of_done_runDirectResolvedDetailedFromTable + (probingHashQueryAfterPlan parameter input plan) + (preservesPublishedValues_probingHashQueryAfterPlan parameter input plan) + context fuel table cache result hpublished hdetailed + exact hrecursive result.value.1 nextCandidates + (canonicalizeMaterializedValues table result.context) result.remaining result.value.2 + hnextSelected + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + hnextPublished.to_canonicalizedMaterializedValues + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_directDetailedBoundaryWitnessFirstUsesNonRootOrdinal_le_nonRootRisk + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hnotSelected : ¬ordinal < candidates.length) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) + (hterminalZero : ∀ nextContext remaining value nextCandidates, + ¬ordinal < nextCandidates.length → + Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + observe nextContext remaining value nextCandidates] ≤ 0) + (hterminalMatch : ∀ candidate nextContext remaining value nextCandidates, + nextContext.ValuesConsistent → StartTableAgrees nextContext.state table → + PublishedValues nextContext.state → + Pr[PrivateWitnessPlanMatchesCandidate candidate | + observe nextContext remaining value nextCandidates] ≤ + Pr[fun hit : Bool => hit = true | + hiddenPrivateCandidateFire candidate nextContext]) + (hterminalPrefix : ∀ nextContext remaining value nextCandidates output, + output ∈ support (observe nextContext remaining value nextCandidates) → + PrivateWitnessPlanExtends nextCandidates output) : + Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + computation observe candidates context fuel table cache] ≤ + Pr[fun hit : Bool => hit = true | + directDetailedBoundaryPrivateOrdinalNonRootRisk ordinal parameter root ftsSecret + computation candidates context fuel table cache] := by + induction computation using OracleComp.inductionOn generalizing + candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_pure, directDetailedBoundaryPrivateOrdinalNonRootRisk, + OracleComp.construct_pure] + simp only [hnotSelected, ↓reduceDIte] + simpa using hterminalZero context fuel (value, cache) candidates hnotSelected + | query_bind query next ih => + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind, + directDetailedBoundaryPrivateOrdinalNonRootRisk, + OracleComp.construct_query_bind] + simp only [hnotSelected, ↓reduceDIte] + let inner := (splitUniformImpl n).run cache + apply probEvent_unselectedDirectWitnessStepFirstUsesNonRootOrdinal_le_risk ordinal + _ _ candidates context fuel table inner hnotSelected + intro result hresult + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table inner) := by + rw [← map_erase_runDirectResolvedWitnessFromTable inner context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hcore := resolvedCore_of_done_mem_runDirectResolvedWitnessFromTable inner + context fuel table result hconsistent hstarts hresult + have hnextPublished := publishedValues_of_done_runDirectResolvedDetailedFromTable + (splitUniformImpl n) (preservesPublishedValuesImpl_splitUniformImpl n) + context fuel table cache result hpublished hdetailed + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hnotSelected + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + hnextPublished.to_canonicalizedMaterializedValues + | inr input => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind, + directDetailedBoundaryPrivateOrdinalNonRootRisk, + OracleComp.construct_query_bind] + simp only [hnotSelected, ↓reduceDIte] + apply probEvent_hashBranchWitnessFirstUsesNonRootOrdinal_le_nonRootRisk ordinal + parameter root ftsSecret input next observe candidates context fuel table cache + hnotSelected hconsistent hstarts hpublished + · intro output nextCandidates nextContext remaining nextCache hnextNotSelected + hnextConsistent hnextStarts hnextPublished + exact ih output nextCandidates nextContext remaining nextCache hnextNotSelected + hnextConsistent hnextStarts hnextPublished + · exact hterminalMatch + · exact hterminalPrefix + | inr message => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind, + directDetailedBoundaryPrivateOrdinalNonRootRisk, + OracleComp.construct_query_bind] + simp only [hnotSelected, ↓reduceDIte] + let inner := (maskedSign parameter root ftsSecret message).run cache + apply probEvent_unselectedDirectWitnessStepFirstUsesNonRootOrdinal_le_risk ordinal _ _ + candidates context fuel table inner hnotSelected + intro result hresult + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table inner) := by + rw [← map_erase_runDirectResolvedWitnessFromTable inner context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hcore := resolvedCore_of_done_mem_runDirectResolvedWitnessFromTable inner context + fuel table result hconsistent hstarts hresult + have hnextPublished := publishedValues_of_done_runDirectResolvedDetailedFromTable + (maskedSign parameter root ftsSecret message) + (preservesPublishedValues_maskedSign parameter root ftsSecret message) + context fuel table cache result hpublished hdetailed + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hnotSelected + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + hnextPublished.to_canonicalizedMaterializedValues + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_granularDetailedRetainedRestWitnessFirstUsesNonRootOrdinal_le_nonRootRisk + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) + (hnotSelected : ¬ordinal < candidates.length) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) : + Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates] ≤ + Pr[fun hit : Bool => hit = true | + directDetailedBoundaryPrivateOrdinalNonRootRisk ordinal parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + candidates context fuel table value.2] := by + unfold granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve + apply probEvent_directDetailedBoundaryWitnessFirstUsesNonRootOrdinal_le_nonRootRisk ordinal + parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivateWitnessPlanObserve table value.1) + candidates context fuel table value.2 hnotSelected hconsistent hstarts hpublished + · intro nextContext remaining nextValue nextCandidates hnextNotSelected + calc + _ ≤ Pr[WitnessUsesOrdinal ordinal | + retainedResolvedFinalizationPrivateWitnessPlanObserve table value.1 nextContext + remaining nextValue nextCandidates] := by + apply probEvent_mono + intro output _houtput hfirst + exact witnessUsesOrdinal_of_witnessFirstUsesNonLayerRootOrdinal hfirst + _ ≤ 0 := probEvent_retainedFinalizationWitnessUsesOrdinal_le_zero table value.1 nextContext + remaining nextValue nextCandidates ordinal hnextNotSelected + · intro candidate nextContext remaining nextValue nextCandidates _hnextConsistent + _hnextStarts hnextPublished + exact probEvent_retainedResolvedFinalizationPrivateWitnessPlanMatchesCandidate_le_hidden table + value.1 candidate nextContext remaining nextValue nextCandidates hnextPublished + · intro nextContext remaining nextValue nextCandidates output houtput + exact privateWitnessPlanExtends_of_mem_retainedResolvedFinalizationPrivateWitnessPlanObserve + table value.1 nextContext remaining nextValue nextCandidates output houtput + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_directDetailedBoundaryPrivateOrdinalNonRootRisk_le + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hparents : CandidatesHaveStructuralParent candidates) + (hfresh : CandidatePositionsFreshExceptLayerRoots context) + (hpublishedContext : PublishedValues context.state) : + Pr[fun hit : Bool => hit = true | + directDetailedBoundaryPrivateOrdinalNonRootRisk ordinal parameter root ftsSecret + computation candidates context fuel table cache] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryPrivateOrdinalNonRootRisk, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact probEvent_nonRootHiddenPrivateCandidateFire_le + (candidates.get ⟨ordinal, hselected⟩) context + (candidateHasStructuralParent_get hparents ordinal hselected) hfresh + · simp [hselected] + | query_bind query next ih => + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [directDetailedBoundaryPrivateOrdinalNonRootRisk, + OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact probEvent_nonRootHiddenPrivateCandidateFire_le + (candidates.get ⟨ordinal, hselected⟩) context + (candidateHasStructuralParent_get hparents ordinal hselected) hfresh + · simp only [hselected, ↓reduceDIte] + apply probEvent_bind_le_of_forall_le + intro result hresult + apply probEvent_finishDirectWitnessOrdinalRisk_le table _ candidates result _ + intro resolved heq hpublished hcompletable + subst result + exact ih resolved.value.1 candidates + (canonicalizeMaterializedValues table resolved.context) resolved.remaining + resolved.value.2 hparents + (candidatePositionsFreshExceptLayerRoots_uniformStep n context fuel table cache + resolved hfresh hresult) + hpublished.to_canonicalizedMaterializedValues + | inr input => + rw [directDetailedBoundaryPrivateOrdinalNonRootRisk, + OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact probEvent_nonRootHiddenPrivateCandidateFire_le + (candidates.get ⟨ordinal, hselected⟩) context + (candidateHasStructuralParent_get hparents ordinal hselected) hfresh + · simp only [hselected, ↓reduceDIte] + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + have hnextParents : CandidatesHaveStructuralParent nextCandidates := by + apply hparents.appendPlanned + (rootAwarePlannedCandidate? parameter input context.state) + intro candidate hcandidate + exact rootAwarePlannedCandidate?_hasStructuralParent hcandidate + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [nextCandidates, plan] using hnextSelected + rw [dif_pos hactual] + simpa [nextCandidates, plan] using + (probEvent_nonRootHiddenPrivateCandidateFire_le + (nextCandidates.get ⟨ordinal, hnextSelected⟩) context + (candidateHasStructuralParent_get hnextParents ordinal hnextSelected) hfresh) + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [nextCandidates, plan] using hnextSelected + rw [dif_neg hactual] + apply probEvent_bind_le_of_forall_le + intro result hresult + apply probEvent_finishDirectWitnessOrdinalRisk_le table _ nextCandidates result _ + intro resolved heq hpublished hcompletable + subst result + exact ih resolved.value.1 nextCandidates + (canonicalizeMaterializedValues table resolved.context) resolved.remaining + resolved.value.2 hnextParents + (candidatePositionsFreshExceptLayerRoots_hashStep parameter input plan context + fuel table cache resolved hfresh hpublishedContext hresult) + hpublished.to_canonicalizedMaterializedValues + | inr message => + rw [directDetailedBoundaryPrivateOrdinalNonRootRisk, + OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact probEvent_nonRootHiddenPrivateCandidateFire_le + (candidates.get ⟨ordinal, hselected⟩) context + (candidateHasStructuralParent_get hparents ordinal hselected) hfresh + · simp only [hselected, ↓reduceDIte] + apply probEvent_bind_le_of_forall_le + intro result hresult + apply probEvent_finishDirectWitnessOrdinalRisk_le table _ candidates result _ + intro resolved heq hpublished hcompletable + subst result + exact ih resolved.value.1 candidates + (canonicalizeMaterializedValues table resolved.context) resolved.remaining + resolved.value.2 hparents + (candidatePositionsFreshExceptLayerRoots_signStep parameter root ftsSecret message + context fuel table cache resolved hfresh hpublishedContext hresult) + hpublished.to_canonicalizedMaterializedValues + +theorem probEvent_granularDetailedRetainedRestWitnessFirstUsesNonRootOrdinal_le + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) + (hnotSelected : ¬ordinal < candidates.length) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) + (hparents : CandidatesHaveStructuralParent candidates) + (hfresh : CandidatePositionsFreshExceptLayerRoots context) : + Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ ≤ Pr[fun hit : Bool => hit = true | + directDetailedBoundaryPrivateOrdinalNonRootRisk ordinal parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + candidates context fuel table value.2] := + probEvent_granularDetailedRetainedRestWitnessFirstUsesNonRootOrdinal_le_nonRootRisk + adversary parameter table ftsSecret ordinal context fuel value candidates hnotSelected + hconsistent hstarts hpublished + _ ≤ _ := probEvent_directDetailedBoundaryPrivateOrdinalNonRootRisk_le ordinal parameter + value.1 ftsSecret (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + candidates context fuel table value.2 hparents hfresh hpublished + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalPrefix.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalPrefix.lean new file mode 100644 index 00000000..d4fa5250 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalPrefix.lean @@ -0,0 +1,430 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalMatchLift + +/-! +# Monotone witness plan prefixes + +The normalized witness trace only appends candidates. A candidate already selected at one ordinal +therefore remains at that ordinal in every later output. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +def PrivateWitnessPlanExtends + (candidates : List Probe) (output : PrivateWitnessPlanOutput) : Prop := + candidates.IsPrefix output.2 + +theorem privateWitnessPlanExtends_of_mem_finishDirectWitnessPlanObserve + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (result : DirectWitnessResult α) + (hobserve : ∀ resolved : ResolvedRunResult α, + result = .done resolved → + ∀ output ∈ support + (observe resolved.context resolved.remaining resolved.value candidates), + PrivateWitnessPlanExtends candidates output) + (output : PrivateWitnessPlanOutput) + (houtput : output ∈ support + (finishDirectWitnessPlanObserve observe candidates result)) : + PrivateWitnessPlanExtends candidates output := by + cases result with + | stoppedFuel => + simp [finishDirectWitnessPlanObserve] at houtput + subst output + simp [PrivateWitnessPlanExtends] + | stoppedOrdinary => + simp [finishDirectWitnessPlanObserve] at houtput + subst output + simp [PrivateWitnessPlanExtends] + | stoppedPrivate witness => + simp [finishDirectWitnessPlanObserve] at houtput + subst output + simp [PrivateWitnessPlanExtends] + | done resolved => exact hobserve resolved rfl output houtput + +theorem privateWitnessPlanExtends_of_mem_runDirectWitnessPlanObserve + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hobserve : ∀ result : ResolvedRunResult α, + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation) → + ∀ output ∈ support + (observe result.context result.remaining result.value candidates), + PrivateWitnessPlanExtends candidates output) + (output : PrivateWitnessPlanOutput) + (houtput : output ∈ support + (runDirectWitnessPlanObserve observe candidates context fuel table computation)) : + PrivateWitnessPlanExtends candidates output := by + unfold runDirectWitnessPlanObserve at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + exact privateWitnessPlanExtends_of_mem_finishDirectWitnessPlanObserve observe candidates result + (by + intro resolved heq + subst result + exact hobserve resolved hresult) + output hfinish + +theorem privateWitnessPlanExtends_of_mem_classifyDirectWitnessPlanObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hobserve : ∀ output ∈ support (observe context fuel value candidates), + PrivateWitnessPlanExtends candidates output) + (output : PrivateWitnessPlanOutput) + (houtput : output ∈ support + (classifyDirectWitnessPlanObserve table observe context fuel value candidates)) : + PrivateWitnessPlanExtends candidates output := by + unfold classifyDirectWitnessPlanObserve at houtput + by_cases hhit : PrivateStructuralHit context + · simp [hhit] at houtput + subst output + simp [PrivateWitnessPlanExtends] + · simp only [hhit, ↓reduceDIte] at houtput + by_cases hcompletable : DeferredCompletable table context + · simp only [hcompletable, ↓reduceIte] at houtput + exact hobserve output houtput + · simp [hcompletable] at houtput + subst output + simp [PrivateWitnessPlanExtends] + +theorem privateWitnessPlanExtends_of_mem_canonicalizeDirectWitnessPlanObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hobserve : ∀ output ∈ support + (observe (canonicalizeMaterializedValues table context) fuel value candidates), + PrivateWitnessPlanExtends candidates output) + (output : PrivateWitnessPlanOutput) + (houtput : output ∈ support + (canonicalizeDirectWitnessPlanObserve table observe context fuel value candidates)) : + PrivateWitnessPlanExtends candidates output := by + unfold canonicalizeDirectWitnessPlanObserve at houtput + let canonical := canonicalizeMaterializedValues table context + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit] at houtput + subst output + simp [PrivateWitnessPlanExtends] + · simp only [canonical, hhit, ↓reduceDIte] at houtput + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] at houtput + exact privateWitnessPlanExtends_of_mem_classifyDirectWitnessPlanObserve table observe + canonical fuel value candidates hobserve output houtput + · simp [hpublished] at houtput + subst output + simp [PrivateWitnessPlanExtends] + +set_option maxRecDepth 100000 in +theorem privateWitnessPlanExtends_of_mem_directDetailedBoundaryNormalizedPrivateWitnessPlanObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hobserve : ∀ nextContext remaining value nextCandidates output, + output ∈ support (observe nextContext remaining value nextCandidates) → + PrivateWitnessPlanExtends nextCandidates output) + (output : PrivateWitnessPlanOutput) + (houtput : output ∈ support + (directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + computation observe candidates context fuel table cache)) : + PrivateWitnessPlanExtends candidates output := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache output with + | pure value => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_pure] at houtput + exact hobserve context fuel (value, cache) candidates output houtput + | query_bind query next ih => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind] at houtput + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + apply privateWitnessPlanExtends_of_mem_runDirectWitnessPlanObserve _ candidates + context fuel table ((splitUniformImpl n).run cache) (output := output) + (houtput := houtput) + intro result _hresult nextOutput hnextOutput + apply privateWitnessPlanExtends_of_mem_canonicalizeDirectWitnessPlanObserve table _ + result.context result.remaining result.value candidates (output := nextOutput) + (houtput := hnextOutput) + intro finalOutput hfinalOutput + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 finalOutput hfinalOutput + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + have hprefix : candidates.IsPrefix nextCandidates := by + cases hcandidate : rootAwarePlannedCandidate? parameter input context.state <;> + simp [nextCandidates, appendPlannedCandidate, hcandidate] + have hnext : PrivateWitnessPlanExtends nextCandidates output := by + apply privateWitnessPlanExtends_of_mem_runDirectWitnessPlanObserve _ nextCandidates + context fuel table ((probingHashQueryAfterPlan parameter input plan).run cache) + (output := output) (houtput := houtput) + intro result _hresult nextOutput hnextOutput + apply privateWitnessPlanExtends_of_mem_canonicalizeDirectWitnessPlanObserve table _ + result.context result.remaining result.value nextCandidates + (output := nextOutput) (houtput := hnextOutput) + intro finalOutput hfinalOutput + exact ih result.value.1 nextCandidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 finalOutput hfinalOutput + exact hprefix.trans hnext + | inr message => + apply privateWitnessPlanExtends_of_mem_runDirectWitnessPlanObserve _ candidates context + fuel table ((maskedSign parameter root ftsSecret message).run cache) (output := output) + (houtput := houtput) + intro result _hresult nextOutput hnextOutput + apply privateWitnessPlanExtends_of_mem_canonicalizeDirectWitnessPlanObserve table _ + result.context result.remaining result.value candidates (output := nextOutput) + (houtput := hnextOutput) + intro finalOutput hfinalOutput + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining result.value.2 + finalOutput hfinalOutput + +theorem privateWitnessPlanExtends_of_mem_retainedResolvedFinalizationPrivateWitnessPlanObserve + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) (candidates : List Probe) + (output : PrivateWitnessPlanOutput) + (houtput : output ∈ support + (retainedResolvedFinalizationPrivateWitnessPlanObserve table root context fuel value + candidates)) : + PrivateWitnessPlanExtends candidates output := by + unfold retainedResolvedFinalizationPrivateWitnessPlanObserve at houtput + by_cases hhit : PrivateStructuralHit context <;> + simp [hhit] at houtput <;> subst output <;> simp [PrivateWitnessPlanExtends] + +theorem privateWitnessPlanExtends_of_mem_granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) + (output : PrivateWitnessPlanOutput) + (houtput : output ∈ support + (granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates)) : + PrivateWitnessPlanExtends candidates output := by + unfold granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve at houtput + apply privateWitnessPlanExtends_of_mem_directDetailedBoundaryNormalizedPrivateWitnessPlanObserve + parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivateWitnessPlanObserve table value.1) + candidates context fuel table value.2 (output := output) (houtput := houtput) + intro nextContext remaining nextValue nextCandidates nextOutput hnextOutput + exact privateWitnessPlanExtends_of_mem_retainedResolvedFinalizationPrivateWitnessPlanObserve + table value.1 nextContext remaining nextValue nextCandidates nextOutput hnextOutput + +theorem privateWitnessPlanMatchesCandidate_of_usesOrdinal_of_prefix + (current : List Probe) (output : PrivateWitnessPlanOutput) (ordinal : Nat) + (hlt : ordinal < current.length) + (hprefix : PrivateWitnessPlanExtends current output) + (huses : WitnessUsesOrdinal ordinal output) : + PrivateWitnessPlanMatchesCandidate (current.get ⟨ordinal, hlt⟩) output := by + obtain ⟨witness, sourceOrdinal, hwitness, hordinal, hsource⟩ := huses + subst ordinal + refine ⟨witness, hwitness, ?_⟩ + have hselected : current.get ⟨sourceOrdinal.val, hlt⟩ = + output.2.get sourceOrdinal := by + change current[sourceOrdinal.val] = output.2[sourceOrdinal.val] + exact hprefix.getElem hlt + unfold PrivateWitnessAtOrdinal at hsource + unfold PrivateHitWitness.MatchesCandidate + rw [hselected] + exact hsource + +theorem not_witnessFirstUsesNonLayerRootOrdinal_of_prefix_of_root + (current : List Probe) (output : PrivateWitnessPlanOutput) (ordinal : Nat) + (hlt : ordinal < current.length) + (hprefix : PrivateWitnessPlanExtends current output) + (hroot : (current.get ⟨ordinal, hlt⟩).IsLayerRoot) : + ¬WitnessFirstUsesNonLayerRootOrdinal ordinal output := by + rintro ⟨witness, sourceOrdinal, hwitness, hvalue, hfirst, hnotRoot⟩ + have hselected : current.get ⟨sourceOrdinal.val, by simpa [hvalue] using hlt⟩ = + output.2.get sourceOrdinal := by + change current[sourceOrdinal.val] = output.2[sourceOrdinal.val] + exact hprefix.getElem (by simpa [hvalue] using hlt) + have hcurrent : current.get ⟨sourceOrdinal.val, by simpa [hvalue] using hlt⟩ = + current.get ⟨ordinal, hlt⟩ := by + congr + apply hnotRoot + rw [← hselected, hcurrent] + exact hroot + +theorem probEvent_granularDetailedRetainedRestWitnessUsesOrdinal_le_of_selected + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) + (ordinal : Nat) (hlt : ordinal < candidates.length) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + Pr[WitnessUsesOrdinal ordinal | + granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates] ≤ + Pr[fun hit : Bool => hit = true | + privateCandidateFire (candidates.get ⟨ordinal, hlt⟩) context] := by + apply (probEvent_mono (mx := + granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates) (p := WitnessUsesOrdinal ordinal) + (q := PrivateWitnessPlanMatchesCandidate (candidates.get ⟨ordinal, hlt⟩)) ?_).trans + · exact probEvent_granularDetailedRetainedRestNormalizedWitnessMatchesCandidate_le + adversary parameter table ftsSecret (candidates.get ⟨ordinal, hlt⟩) context fuel value + candidates hconsistent hstarts + · intro output houtput huses + exact privateWitnessPlanMatchesCandidate_of_usesOrdinal_of_prefix candidates output ordinal hlt + (privateWitnessPlanExtends_of_mem_granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve + adversary parameter table ftsSecret context fuel value candidates output houtput) + huses + +theorem probEvent_witnessUses_newlyAppendedOrdinal_le + (run : ProbComp PrivateWitnessPlanOutput) + (current : List Probe) (candidate : Probe) (bound : ENNReal) + (hextends : ∀ output ∈ support run, + PrivateWitnessPlanExtends (current ++ [candidate]) output) + (hmatch : Pr[PrivateWitnessPlanMatchesCandidate candidate | run] ≤ bound) : + Pr[WitnessUsesOrdinal current.length | run] ≤ bound := by + apply (probEvent_mono (mx := run) (p := WitnessUsesOrdinal current.length) + (q := PrivateWitnessPlanMatchesCandidate candidate) ?_).trans hmatch + intro output houtput huses + have hlt : current.length < (current ++ [candidate]).length := by simp + have hselected := privateWitnessPlanMatchesCandidate_of_usesOrdinal_of_prefix + (current ++ [candidate]) output current.length hlt (hextends output houtput) huses + have hget : (current ++ [candidate]).get ⟨current.length, hlt⟩ = candidate := by + simp [List.get_eq_getElem] + simpa [hget] using hselected + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_selectedHashPlanWitnessUsesOrdinal_le + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp PrivateWitnessPlanOutput) + (current : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (candidate : Probe) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hterminal : ∀ nextContext remaining value nextCandidates, + nextContext.ValuesConsistent → StartTableAgrees nextContext.state table → + Pr[PrivateWitnessPlanMatchesCandidate candidate | + observe nextContext remaining value nextCandidates] ≤ + Pr[fun hit : Bool => hit = true | + privateCandidateFire candidate nextContext]) + (hobservePrefix : ∀ nextContext remaining value nextCandidates output, + output ∈ support (observe nextContext remaining value nextCandidates) → + PrivateWitnessPlanExtends nextCandidates output) : + Pr[WitnessUsesOrdinal current.length | + runDirectWitnessPlanObserve + (canonicalizeDirectWitnessPlanObserve table + (fun nextContext remaining value laterCandidates => + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + (next value.1) observe laterCandidates nextContext remaining table value.2)) + (current ++ [candidate]) context fuel table + ((probingHashQueryAfterPlan parameter input + (purePlanProbingHashQuery parameter input context.state)).run cache)] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate context] := by + let plan := purePlanProbingHashQuery parameter input context.state + let branch := runDirectWitnessPlanObserve + (canonicalizeDirectWitnessPlanObserve table + (fun nextContext remaining value laterCandidates => + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + (next value.1) observe laterCandidates nextContext remaining table value.2)) + (current ++ [candidate]) context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) + apply probEvent_witnessUses_newlyAppendedOrdinal_le branch current candidate _ + · intro output houtput + unfold branch at houtput + apply privateWitnessPlanExtends_of_mem_runDirectWitnessPlanObserve _ + (current ++ [candidate]) context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) (output := output) + (houtput := houtput) + intro result _hresult nextOutput hnextOutput + apply privateWitnessPlanExtends_of_mem_canonicalizeDirectWitnessPlanObserve table _ + result.context result.remaining result.value (current ++ [candidate]) + (output := nextOutput) (houtput := hnextOutput) + intro finalOutput hfinalOutput + exact privateWitnessPlanExtends_of_mem_directDetailedBoundaryNormalizedPrivateWitnessPlanObserve + parameter root ftsSecret (next result.value.1) observe (current ++ [candidate]) + (canonicalizeMaterializedValues table result.context) result.remaining table result.value.2 + hobservePrefix finalOutput hfinalOutput + · unfold branch + apply probEvent_runDirectWitnessPlanMatchesCandidate_le candidate _ (current ++ [candidate]) + context fuel table ((probingHashQueryAfterPlan parameter input plan).run cache) + intro result hresult + let inner := (probingHashQueryAfterPlan parameter input plan).run cache + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table inner) := by + rw [← map_erase_runDirectResolvedWitnessFromTable inner context fuel table, support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable inner context fuel table result + hconsistent hstarts + (mem_support_runDirectResolvedFromTable_of_done_detailed inner context fuel table result + hdetailed) + apply probEvent_canonicalizeDirectWitnessPlanMatchesCandidate_le table candidate _ + result.context result.remaining result.value (current ++ [candidate]) hcore.2.1 + dsimp only + intro _hprivate _hcompletable + exact probEvent_directDetailedBoundaryNormalizedPrivateWitnessPlanMatchesCandidate_le + candidate parameter root ftsSecret (next result.value.1) observe (current ++ [candidate]) + (canonicalizeMaterializedValues table result.context) result.remaining table result.value.2 + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) hterminal + +theorem probEvent_directDetailedBoundaryWitnessUsesOrdinal_le_of_selected + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hselected : ordinal < candidates.length) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hterminal : ∀ nextContext remaining value nextCandidates, + nextContext.ValuesConsistent → StartTableAgrees nextContext.state table → + Pr[PrivateWitnessPlanMatchesCandidate (candidates.get ⟨ordinal, hselected⟩) | + observe nextContext remaining value nextCandidates] ≤ + Pr[fun hit : Bool => hit = true | + privateCandidateFire (candidates.get ⟨ordinal, hselected⟩) nextContext]) + (hobservePrefix : ∀ nextContext remaining value nextCandidates output, + output ∈ support (observe nextContext remaining value nextCandidates) → + PrivateWitnessPlanExtends nextCandidates output) : + Pr[WitnessUsesOrdinal ordinal | + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + computation observe candidates context fuel table cache] ≤ + Pr[fun hit : Bool => hit = true | + privateCandidateFire (candidates.get ⟨ordinal, hselected⟩) context] := by + apply (probEvent_mono (mx := + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret computation + observe candidates context fuel table cache) (p := WitnessUsesOrdinal ordinal) + (q := PrivateWitnessPlanMatchesCandidate (candidates.get ⟨ordinal, hselected⟩)) ?_).trans + · exact probEvent_directDetailedBoundaryNormalizedPrivateWitnessPlanMatchesCandidate_le + (candidates.get ⟨ordinal, hselected⟩) parameter root ftsSecret computation observe + candidates context fuel table cache hconsistent hstarts hterminal + · intro output houtput huses + exact privateWitnessPlanMatchesCandidate_of_usesOrdinal_of_prefix candidates output ordinal + hselected + (privateWitnessPlanExtends_of_mem_directDetailedBoundaryNormalizedPrivateWitnessPlanObserve + parameter root ftsSecret computation observe candidates context fuel table cache + hobservePrefix output houtput) + huses + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalProbability.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalProbability.lean new file mode 100644 index 00000000..cfe411d8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalProbability.lean @@ -0,0 +1,398 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinal + +/-! +# One-ordinal private endpoint + +One selected plan ordinal tests at most one structural output. The fixed-list endpoint deliberately +ignores every other candidate, since their misses belong to the all-miss prefix that produces the +selected candidate rather than to additional target events. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +noncomputable def plannedOrdinalCandidateFire + (ordinal : Nat) (candidates : List Probe) : ProbComp Bool := + match candidates[ordinal]? with + | none => pure false + | some candidate => + match candidate.coordinate with + | .chainStart _ _ _ _ => pure false + | .position _ => do + let output ← LazyRevealProbe.sampleHashOutput + pure (truncateHash output = candidate.candidate) + +noncomputable def privateCandidateFire + (candidate : Probe) (context : DeferredContext) : ProbComp Bool := + match candidate.coordinate with + | .chainStart _ _ _ _ => pure false + | .position position => do + let output ← deferredPositionOutput position context + pure (truncateHash output = candidate.candidate) + +noncomputable def preparePrivateCandidate + (candidate : Probe) (context : DeferredContext) : + ProbComp (Option DeferredContext) := + match candidate.coordinate with + | .chainStart _ _ _ _ => pure (some context) + | .position position => do + let output ← deferredPositionOutput position context + if truncateHash output = candidate.candidate then + pure none + else + pure (some { context with values := context.values.install position output }) + +theorem map_isNone_preparePrivateCandidate + (candidate : Probe) (context : DeferredContext) : + Option.isNone <$> preparePrivateCandidate candidate context = + privateCandidateFire candidate context := by + unfold preparePrivateCandidate privateCandidateFire + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => simp + | position position => + simp only [map_bind] + apply bind_congr + intro output + by_cases hhit : truncateHash output = candidate.candidate <;> simp [hhit] + +theorem privateCandidateFire_ensure + (candidate : Probe) (context : DeferredContext) (coordinate : Coordinate) : + privateCandidateFire candidate + { context with state := context.state.ensure coordinate } = + privateCandidateFire candidate context := by + cases hcandidate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => simp [privateCandidateFire, hcandidate] + | position position => rfl + +theorem privateCandidateFire_addPending + (candidate : Probe) (context : DeferredContext) + (coordinate : Coordinate) (digest : Digest) : + privateCandidateFire candidate + { context with state := context.state.addPending coordinate digest } = + privateCandidateFire candidate context := by + cases hcandidate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => simp [privateCandidateFire, hcandidate] + | position position => rfl + +theorem privateCandidateFire_publish + (candidate : Probe) (context : DeferredContext) (coordinate : Coordinate) : + privateCandidateFire candidate + { context with state := context.state.publish coordinate } = + privateCandidateFire candidate context := by + cases hcandidate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => simp [privateCandidateFire, hcandidate] + | position position => rfl + +theorem privateCandidateFire_clearPending + (candidate : Probe) (context : DeferredContext) (coordinate : Coordinate) : + privateCandidateFire candidate + { context with state := context.state.clearPending coordinate } = + privateCandidateFire candidate context := by + cases hcandidate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => simp [privateCandidateFire, hcandidate] + | position position => rfl + +theorem privateCandidateFire_canonicalize + (table : OtsSecretIndex → HashOutput) + (candidate : Probe) (context : DeferredContext) + (hconsistent : context.ValuesConsistent) : + privateCandidateFire candidate (canonicalizeMaterializedValues table context) = + privateCandidateFire candidate context := by + cases hcandidate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => simp [privateCandidateFire, hcandidate] + | position position => + simp only [privateCandidateFire, hcandidate] + unfold deferredPositionOutput + rw [canonicalizeMaterializedValues_positionValue table context hconsistent position] + +theorem candidateOutputsSafe_preparePrivateCandidate + (candidate : Probe) (context prepared : DeferredContext) + (hprepared : some prepared ∈ support (preparePrivateCandidate candidate context)) : + CandidateOutputsSafe prepared [candidate] := by + unfold preparePrivateCandidate at hprepared + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [hcoordinate, CandidateOutputsSafe] + | position position => + simp only [hcoordinate, mem_support_bind_iff] at hprepared + obtain ⟨output, _houtput, hreturn⟩ := hprepared + by_cases hhit : truncateHash output = candidate.candidate + · simp [hhit] at hreturn + · simp [hhit] at hreturn + subst prepared + intro found hfound + simp only [List.mem_singleton] at hfound + subst found + simp only [hcoordinate] + exact ⟨output, by simp [DeferredStructuralValues.install], hhit⟩ + +theorem not_recordedCandidateHit_of_preparePrivateCandidate_run + (candidate : Probe) (context prepared : DeferredContext) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : ResolvedRunResult α) + (hprepared : some prepared ∈ support (preparePrivateCandidate candidate context)) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable prepared fuel table computation)) : + ¬RecordedCandidateHit result.context [candidate] := by + have hsafe := candidateOutputsSafe_preparePrivateCandidate candidate context prepared hprepared + have hvalues := privateValuesLE_of_done_runDirectResolvedDetailedFromTable + computation prepared fuel table result hresult + exact not_recordedCandidateHit_of_candidateOutputsSafe result.context [candidate] + (hsafe.of_privateValuesLE hvalues) + +theorem privateCandidateFire_eq_planned_of_fresh + (candidate : Probe) (context : DeferredContext) + (hstate : ∀ position, candidate.coordinate = .position position → + context.state.values (.position position) = none) + (hprivate : ∀ position, candidate.coordinate = .position position → + context.values position = none) : + privateCandidateFire candidate context = + (match candidate.coordinate with + | .chainStart _ _ _ _ => pure false + | .position _ => do + let output ← LazyRevealProbe.sampleHashOutput + pure (truncateHash output = candidate.candidate)) := by + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => simp [privateCandidateFire, hcoordinate] + | position position => + simp [privateCandidateFire, hcoordinate, deferredPositionOutput, + DeferredContext.positionValue, hstate position hcoordinate, + hprivate position hcoordinate] + +theorem probEvent_privateCandidateFire_le_of_fresh + (candidate : Probe) (context : DeferredContext) + (hstate : ∀ position, candidate.coordinate = .position position → + context.state.values (.position position) = none) + (hprivate : ∀ position, candidate.coordinate = .position position → + context.values position = none) : + Pr[= true | privateCandidateFire candidate context] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [privateCandidateFire_eq_planned_of_fresh candidate context hstate hprivate] + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => simp + | position position => + change Pr[= true | (fun output : HashOutput => + decide (truncateHash output = candidate.candidate)) <$> + LazyRevealProbe.sampleHashOutput] ≤ _ + calc + _ = Pr[fun output : HashOutput => truncateHash output = candidate.candidate | + LazyRevealProbe.sampleHashOutput] := by + rw [← probEvent_eq_eq_probOutput, probEvent_map] + exact OracleComp.probEvent_congr' (fun _ _ => by simp) rfl + _ = (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + unfold LazyRevealProbe.sampleHashOutput + exact SphincsSecurity.probEvent_uniform_truncateHash_eq _ + _ = ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + _ ≤ ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := le_rfl + +theorem probEvent_privateCandidateFire_empty_le (candidate : Probe) : + Pr[= true | privateCandidateFire candidate + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues }] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply probEvent_privateCandidateFire_le_of_fresh + · intro position _hcoordinate + rfl + · intro position _hcoordinate + simp [emptyDeferredStructuralValues] + +theorem probEvent_preparePrivateCandidate_empty_none_le (candidate : Probe) : + Pr[= none | preparePrivateCandidate candidate + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues }] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ = Pr[fun result => Option.isNone result = true | + preparePrivateCandidate candidate + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues }] := by + rw [← probEvent_eq_eq_probOutput] + apply OracleComp.probEvent_congr' (fun result _ => by cases result <;> simp) rfl + _ = Pr[fun hit : Bool => hit = true | + Option.isNone <$> preparePrivateCandidate candidate + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues }] := by + rw [probEvent_map] + exact OracleComp.probEvent_congr' (fun result _ => by simp) rfl + _ = Pr[= true | Option.isNone <$> preparePrivateCandidate candidate + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues }] := + probEvent_eq_eq_probOutput _ true + _ = Pr[= true | privateCandidateFire candidate + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues }] := + OracleComp.probOutput_congr rfl + (congrArg evalDist (map_isNone_preparePrivateCandidate candidate _)) + _ ≤ _ := probEvent_privateCandidateFire_empty_le candidate + +theorem probEvent_bind_privateCandidateFire_empty_le (candidates : ProbComp Probe) : + Pr[= true | candidates >>= fun candidate => privateCandidateFire candidate + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues }] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_of_forall_le + intro candidate _hcandidate + rw [probEvent_eq_eq_probOutput] + exact probEvent_privateCandidateFire_empty_le candidate + +theorem probEvent_plannedOrdinalCandidateFire_le + (ordinal : Nat) (candidates : List Probe) : + Pr[= true | plannedOrdinalCandidateFire ordinal candidates] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + unfold plannedOrdinalCandidateFire + cases hcandidate : candidates[ordinal]? with + | none => simp + | some candidate => + simp only + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => simp + | position target => + change Pr[= true | (fun output : HashOutput => + decide (truncateHash output = candidate.candidate)) <$> + LazyRevealProbe.sampleHashOutput] ≤ _ + calc + _ = Pr[fun output : HashOutput => truncateHash output = candidate.candidate | + LazyRevealProbe.sampleHashOutput] := by + rw [← probEvent_eq_eq_probOutput, probEvent_map] + exact OracleComp.probEvent_congr' (fun _ _ => by simp) rfl + _ = (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + unfold LazyRevealProbe.sampleHashOutput + exact SphincsSecurity.probEvent_uniform_truncateHash_eq _ + _ = ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + _ ≤ ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := le_rfl + +theorem probEvent_bind_plannedOrdinalCandidateFire_le + (plans : ProbComp (List Probe)) (ordinal : Nat) : + Pr[= true | plans >>= plannedOrdinalCandidateFire ordinal] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_of_forall_le + intro candidates _hcandidates + rw [probEvent_eq_eq_probOutput] + exact probEvent_plannedOrdinalCandidateFire_le ordinal candidates + +def WitnessUsesOrdinal + (ordinal : Nat) (output : PrivateWitnessPlanOutput) : Prop := + ∃ witness sourceOrdinal, + output.1 = some witness ∧ sourceOrdinal.val = ordinal ∧ + PrivateWitnessAtOrdinal witness output.2 sourceOrdinal + +theorem witnessUsesOrdinal_of_witnessFirstUsesOrdinal + {ordinal : Nat} {output : PrivateWitnessPlanOutput} + (hfirst : WitnessFirstUsesOrdinal ordinal output) : + WitnessUsesOrdinal ordinal output := by + obtain ⟨witness, sourceOrdinal, hwitness, hvalue, hfirst⟩ := hfirst + have hmatch : PrivateWitnessAtOrdinal witness output.2 sourceOrdinal := by + classical + unfold firstPrivateWitnessOrdinal? at hfirst + let matching := Finset.univ.filter fun selected : Fin output.2.length => + PrivateWitnessAtOrdinal witness output.2 selected + by_cases hmatching : matching.Nonempty + · simp only [matching, hmatching, dif_pos, Option.some.injEq] at hfirst + rw [← hfirst] + exact (Finset.mem_filter.mp (matching.min'_mem hmatching)).2 + · simp [matching, hmatching] at hfirst + exact ⟨witness, sourceOrdinal, hwitness, hvalue, hmatch⟩ + +theorem witnessUsesOrdinal_of_witnessFirstUsesNonLayerRootOrdinal + {ordinal : Nat} {output : PrivateWitnessPlanOutput} + (hfirst : WitnessFirstUsesNonLayerRootOrdinal ordinal output) : + WitnessUsesOrdinal ordinal output := by + obtain ⟨witness, sourceOrdinal, hwitness, hvalue, hselected, _hroot⟩ := hfirst + exact witnessUsesOrdinal_of_witnessFirstUsesOrdinal + ⟨witness, sourceOrdinal, hwitness, hvalue, hselected⟩ + +theorem witnessUsesOrdinal_of_bounded_eq + (q : Nat) (output : PrivateWitnessPlanOutput) (ordinal : Fin q) + (hcovered : PrivateWitnessCovered output) + (hordinal : boundedPrivateWitnessOrdinal? q output = some ordinal) : + WitnessUsesOrdinal ordinal.val output := by + classical + cases hwitness : output.1 with + | none => + unfold boundedPrivateWitnessOrdinal? at hordinal + simp [hwitness] at hordinal + | some witness => + have hhit := hcovered witness hwitness + obtain ⟨sourceOrdinal, hfirst, hsource⟩ := + firstPrivateWitnessOrdinal?_eq_some_of_candidateListHits witness output.2 hhit + unfold boundedPrivateWitnessOrdinal? at hordinal + simp only [hwitness] at hordinal + rw [hfirst] at hordinal + by_cases hlt : sourceOrdinal.val < q + · simp only [hlt, ↓reduceDIte, Option.some.injEq] at hordinal + have hval := congrArg Fin.val hordinal + exact ⟨witness, sourceOrdinal, hwitness, hval, hsource⟩ + · simp [hlt] at hordinal + +theorem witnessFirstUsesOrdinal_of_bounded_eq + (q : Nat) (output : PrivateWitnessPlanOutput) (ordinal : Fin q) + (hordinal : boundedPrivateWitnessOrdinal? q output = some ordinal) : + WitnessFirstUsesOrdinal ordinal.val output := by + classical + cases hwitness : output.1 with + | none => + unfold boundedPrivateWitnessOrdinal? at hordinal + simp [hwitness] at hordinal + | some witness => + cases hfirst : firstPrivateWitnessOrdinal? witness output.2 with + | none => + unfold boundedPrivateWitnessOrdinal? at hordinal + simp [hwitness, hfirst] at hordinal + | some sourceOrdinal => + unfold boundedPrivateWitnessOrdinal? at hordinal + simp only [hwitness, hfirst] at hordinal + by_cases hlt : sourceOrdinal.val < q + · simp only [hlt, ↓reduceDIte, Option.some.injEq] at hordinal + have hval := congrArg Fin.val hordinal + exact ⟨witness, sourceOrdinal, hwitness, hval, hfirst⟩ + · simp [hlt] at hordinal + +theorem not_privateWitnessAtOrdinal_of_witnessFirstUsesOrdinal_of_lt + {ordinal : Nat} {output : PrivateWitnessPlanOutput} + (hfirst : WitnessFirstUsesOrdinal ordinal output) + (earlier : Fin output.2.length) (hlt : earlier.val < ordinal) : + ∀ witness, output.1 = some witness → + ¬PrivateWitnessAtOrdinal witness output.2 earlier := by + intro witness hwitness hearlier + obtain ⟨selectedWitness, sourceOrdinal, hselectedWitness, hsourceValue, hsourceFirst⟩ := hfirst + have hwitnessEq : witness = selectedWitness := by + exact Option.some.inj (hwitness.symm.trans hselectedWitness) + subst witness + have hle := firstPrivateWitnessOrdinal?_le_of_eq_some_of_matches selectedWitness output.2 + sourceOrdinal earlier hsourceFirst hearlier + omega + +theorem probEvent_privateWitness_le_of_bounded_ordinals + (run : ProbComp PrivateWitnessPlanOutput) (q : Nat) (epsilon : ℝ≥0∞) + (hclassifies : ∀ output ∈ support run, output.1.isSome = true → + ∃ ordinal : Fin q, boundedPrivateWitnessOrdinal? q output = some ordinal) + (hordinal : ∀ ordinal : Fin q, + Pr[fun output => boundedPrivateWitnessOrdinal? q output = some ordinal | run] ≤ + epsilon) : + Pr[fun output => output.1.isSome = true | run] ≤ (q : ℝ≥0∞) * epsilon := by + classical + calc + _ ≤ Pr[fun output => ∃ ordinal ∈ (Finset.univ : Finset (Fin q)), + boundedPrivateWitnessOrdinal? q output = some ordinal | run] := by + apply probEvent_mono + intro output houtput hwitness + obtain ⟨ordinal, hordinal⟩ := hclassifies output houtput hwitness + exact ⟨ordinal, Finset.mem_univ ordinal, hordinal⟩ + _ ≤ ∑ ordinal ∈ (Finset.univ : Finset (Fin q)), + Pr[fun output => boundedPrivateWitnessOrdinal? q output = some ordinal | run] := + probEvent_exists_finset_le_sum Finset.univ run + (fun ordinal output => boundedPrivateWitnessOrdinal? q output = some ordinal) + _ ≤ ∑ _ordinal ∈ (Finset.univ : Finset (Fin q)), epsilon := by + apply Finset.sum_le_sum + intro ordinal _hordinal + exact hordinal ordinal + _ = (q : ℝ≥0∞) * epsilon := by + rw [Finset.sum_const, nsmul_eq_mul, Finset.card_univ, Fintype.card_fin] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRisk.lean new file mode 100644 index 00000000..8f86174f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRisk.lean @@ -0,0 +1,259 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalPrefix + +/-! +# Ordinal prefix risk + +The prefix-risk computation follows the normalized execution until one fixed candidate ordinal is +selected. It then stops before executing that hash-query suffix and tests the selected candidate +against the current deferred structural output. Earlier stops and a computation that ends before +the ordinal is selected contribute zero. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +noncomputable def finishDirectWitnessOrdinalRisk + (observe : DeferredContext → Nat → α → List Probe → ProbComp Bool) + (candidates : List Probe) : DirectWitnessResult α → ProbComp Bool + | .stoppedFuel => pure false + | .stoppedOrdinary => pure false + | .stoppedPrivate _ => pure false + | .done result => observe result.context result.remaining result.value candidates + +noncomputable def canonicalizeDirectWitnessOrdinalRisk + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) : + ProbComp Bool := by + classical + let canonical := canonicalizeMaterializedValues table context + exact if PrivateStructuralHit canonical then + pure false + else if PublishedValues context.state then + if DeferredCompletable table canonical then + observe canonical fuel value candidates + else + pure false + else + pure false + +noncomputable def directDetailedBoundaryPrivateOrdinalRisk + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : ProbComp Bool := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + List Probe → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → + SplitHashCache → ProbComp Bool) + (fun _value candidates context _fuel _table _cache => + if hselected : ordinal < candidates.length then + privateCandidateFire (candidates.get ⟨ordinal, hselected⟩) context + else + pure false) + (fun query _next recursivelyRun candidates context fuel table cache => + if hselected : ordinal < candidates.length then + privateCandidateFire (candidates.get ⟨ordinal, hselected⟩) context + else + match query with + | .inl (.inl n) => + runDirectResolvedWitnessFromTable context fuel table ((splitUniformImpl n).run cache) >>= + finishDirectWitnessOrdinalRisk + (canonicalizeDirectWitnessOrdinalRisk table + (fun nextContext remaining value laterCandidates => + recursivelyRun value.1 laterCandidates nextContext remaining table value.2)) + candidates + | .inl (.inr input) => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + if hnextSelected : ordinal < nextCandidates.length then + privateCandidateFire (nextCandidates.get ⟨ordinal, hnextSelected⟩) context + else + runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) >>= + finishDirectWitnessOrdinalRisk + (canonicalizeDirectWitnessOrdinalRisk table + (fun nextContext remaining value laterCandidates => + recursivelyRun value.1 laterCandidates nextContext remaining table value.2)) + nextCandidates + | .inr message => + runDirectResolvedWitnessFromTable context fuel table + ((maskedSign parameter root ftsSecret message).run cache) >>= + finishDirectWitnessOrdinalRisk + (canonicalizeDirectWitnessOrdinalRisk table + (fun nextContext remaining value laterCandidates => + recursivelyRun value.1 laterCandidates nextContext remaining table value.2)) + candidates) + computation candidates context fuel table cache + +noncomputable def granularDetailedRetainedRestPrivateOrdinalRisk + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) : ProbComp Bool := + directDetailedBoundaryPrivateOrdinalRisk ordinal parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + candidates context fuel table value.2 + +theorem directDetailedBoundaryPrivateOrdinalRisk_eq_fire_of_selected + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hselected : ordinal < candidates.length) : + directDetailedBoundaryPrivateOrdinalRisk ordinal parameter root ftsSecret computation + candidates context fuel table cache = + privateCandidateFire (candidates.get ⟨ordinal, hselected⟩) context := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryPrivateOrdinalRisk, OracleComp.construct_pure] + simp only [hselected, ↓reduceDIte] + | query_bind query next ih => + rw [directDetailedBoundaryPrivateOrdinalRisk, OracleComp.construct_query_bind] + simp only [hselected, ↓reduceDIte] + +theorem directDetailedBoundaryPrivateOrdinalRisk_pure_eq_false_of_not_selected + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (value : α) (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hnotSelected : ¬ordinal < candidates.length) : + directDetailedBoundaryPrivateOrdinalRisk ordinal parameter root ftsSecret + (pure value : OracleComp (OracleWorld + SigningSpec) α) + candidates context fuel table cache = pure false := by + rw [directDetailedBoundaryPrivateOrdinalRisk, OracleComp.construct_pure] + simp only [hnotSelected, ↓reduceDIte] + +theorem not_witnessUsesOrdinal_of_not_lt_length + (ordinal : Nat) (output : PrivateWitnessPlanOutput) + (hnot : ¬ordinal < output.2.length) : + ¬WitnessUsesOrdinal ordinal output := by + rintro ⟨witness, sourceOrdinal, _hwitness, hordinal, _hsource⟩ + exact hnot (hordinal ▸ sourceOrdinal.isLt) + +theorem probEvent_finishDirectWitnessPlanUsesOrdinal_le_risk + (ordinal : Nat) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (riskObserve : DeferredContext → Nat → α → List Probe → ProbComp Bool) + (candidates : List Probe) (result : DirectWitnessResult α) + (hnotSelected : ¬ordinal < candidates.length) + (hcontinuation : ∀ resolved : ResolvedRunResult α, + result = .done resolved → + Pr[WitnessUsesOrdinal ordinal | + observe resolved.context resolved.remaining resolved.value candidates] ≤ + Pr[fun hit : Bool => hit = true | + riskObserve resolved.context resolved.remaining resolved.value candidates]) : + Pr[WitnessUsesOrdinal ordinal | + finishDirectWitnessPlanObserve observe candidates result] ≤ + Pr[fun hit : Bool => hit = true | + finishDirectWitnessOrdinalRisk riskObserve candidates result] := by + cases result with + | stoppedFuel => + simp [finishDirectWitnessPlanObserve, finishDirectWitnessOrdinalRisk, + WitnessUsesOrdinal] + | stoppedOrdinary => + simp [finishDirectWitnessPlanObserve, finishDirectWitnessOrdinalRisk, + WitnessUsesOrdinal] + | stoppedPrivate witness => + have hnone : ¬WitnessUsesOrdinal ordinal (some witness, candidates) := + not_witnessUsesOrdinal_of_not_lt_length ordinal (some witness, candidates) hnotSelected + simp [finishDirectWitnessPlanObserve, finishDirectWitnessOrdinalRisk, hnone] + | done resolved => + simpa [finishDirectWitnessPlanObserve, finishDirectWitnessOrdinalRisk] using + hcontinuation resolved rfl + +theorem probEvent_runDirectWitnessPlanUsesOrdinal_le_risk + (ordinal : Nat) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (riskObserve : DeferredContext → Nat → α → List Probe → ProbComp Bool) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hnotSelected : ¬ordinal < candidates.length) + (hcontinuation : ∀ result : ResolvedRunResult α, + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation) → + Pr[WitnessUsesOrdinal ordinal | + observe result.context result.remaining result.value candidates] ≤ + Pr[fun hit : Bool => hit = true | + riskObserve result.context result.remaining result.value candidates]) : + Pr[WitnessUsesOrdinal ordinal | + runDirectWitnessPlanObserve observe candidates context fuel table computation] ≤ + Pr[fun hit : Bool => hit = true | + runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectWitnessOrdinalRisk riskObserve candidates] := by + unfold runDirectWitnessPlanObserve + rw [probEvent_bind_eq_tsum, probEvent_bind_eq_tsum] + apply ENNReal.tsum_le_tsum + intro result + by_cases hresult : result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation) + · exact mul_le_mul' le_rfl + (probEvent_finishDirectWitnessPlanUsesOrdinal_le_risk ordinal observe riskObserve candidates + result hnotSelected (by + intro resolved heq + subst result + exact hcontinuation resolved hresult)) + · rw [probOutput_eq_zero_of_not_mem_support hresult] + simp + +theorem probEvent_canonicalizeWitnessPlanUsesOrdinal_le_risk + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (riskObserve : DeferredContext → Nat → α → List Probe → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hnotSelected : ¬ordinal < candidates.length) + (hcontinuation : + let canonical := canonicalizeMaterializedValues table context + ¬PrivateStructuralHit canonical → PublishedValues context.state → + DeferredCompletable table canonical → + Pr[WitnessUsesOrdinal ordinal | observe canonical fuel value candidates] ≤ + Pr[fun hit : Bool => hit = true | + riskObserve canonical fuel value candidates]) : + Pr[WitnessUsesOrdinal ordinal | + canonicalizeDirectWitnessPlanObserve table observe context fuel value candidates] ≤ + Pr[fun hit : Bool => hit = true | + canonicalizeDirectWitnessOrdinalRisk table riskObserve context fuel value candidates] := by + let canonical := canonicalizeMaterializedValues table context + unfold canonicalizeDirectWitnessPlanObserve canonicalizeDirectWitnessOrdinalRisk + by_cases hhit : PrivateStructuralHit canonical + · simp only [canonical, hhit, ↓reduceDIte, if_pos] + rw [probEvent_pure, probEvent_pure] + simp only [Bool.false_eq_true, if_false] + rw [if_neg (not_witnessUsesOrdinal_of_not_lt_length ordinal _ hnotSelected)] + · simp only [canonical, hhit, ↓reduceDIte] + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + unfold classifyDirectWitnessPlanObserve + change ¬PrivateStructuralHit (canonicalizeMaterializedValues table context) at hhit + simp only [hhit, ↓reduceDIte] + by_cases hcompletable : DeferredCompletable table canonical + · change DeferredCompletable table (canonicalizeMaterializedValues table context) + at hcompletable + simp only [hcompletable, ↓reduceIte] + exact hcontinuation hhit hpublished hcompletable + · change ¬DeferredCompletable table (canonicalizeMaterializedValues table context) + at hcompletable + simp only [hcompletable, ↓reduceIte, probEvent_pure, Bool.false_eq_true] + have hnone : ¬WitnessUsesOrdinal ordinal + ((none, candidates) : PrivateWitnessPlanOutput) := + not_witnessUsesOrdinal_of_not_lt_length ordinal _ hnotSelected + rw [if_neg hnone] + · simp only [hpublished, ↓reduceIte, probEvent_pure, Bool.false_eq_true] + have hnone : ¬WitnessUsesOrdinal ordinal + ((none, candidates) : PrivateWitnessPlanOutput) := + not_witnessUsesOrdinal_of_not_lt_length ordinal _ hnotSelected + rw [if_neg hnone] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRiskLift.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRiskLift.lean new file mode 100644 index 00000000..39d594a8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRiskLift.lean @@ -0,0 +1,316 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRisk + +/-! +# Ordinal witness to prefix-risk lift + +The normalized witness event is bounded by the prefix-risk computation one outer query at a time. +The common unselected step is kept separate from the dependent outer query match. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +theorem probEvent_unselectedDirectWitnessStep_le_ordinalRisk + (ordinal : Nat) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (riskObserve : DeferredContext → Nat → α → List Probe → ProbComp Bool) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hnotSelected : ¬ordinal < candidates.length) + (hcontinuation : ∀ result : ResolvedRunResult α, + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation) → + Pr[WitnessUsesOrdinal ordinal | + observe (canonicalizeMaterializedValues table result.context) + result.remaining result.value candidates] ≤ + Pr[fun hit : Bool => hit = true | + riskObserve (canonicalizeMaterializedValues table result.context) + result.remaining result.value candidates]) : + Pr[WitnessUsesOrdinal ordinal | + runDirectWitnessPlanObserve + (canonicalizeDirectWitnessPlanObserve table observe) + candidates context fuel table computation] ≤ + Pr[fun hit : Bool => hit = true | + runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectWitnessOrdinalRisk + (canonicalizeDirectWitnessOrdinalRisk table riskObserve) candidates] := by + apply probEvent_runDirectWitnessPlanUsesOrdinal_le_risk ordinal _ _ candidates context fuel + table computation hnotSelected + intro result hresult + apply probEvent_canonicalizeWitnessPlanUsesOrdinal_le_risk table ordinal _ _ + result.context result.remaining result.value candidates hnotSelected + dsimp only + intro _hprivate _hpublished _hcompletable + exact hcontinuation result hresult + +theorem resolvedCore_of_done_mem_runDirectResolvedWitnessFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) : + result.table = table ∧ result.context.ValuesConsistent ∧ + StartTableAgrees result.context.state table := by + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) := by + rw [← map_erase_runDirectResolvedWitnessFromTable computation context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + exact resolvedCore_of_mem_runDirectResolvedFromTable computation context fuel table result + hconsistent hstarts + (mem_support_runDirectResolvedFromTable_of_done_detailed computation context fuel table result + hdetailed) + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_hashBranchWitnessUsesOrdinal_le_ordinalRisk + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hnotSelected : ¬ordinal < candidates.length) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hrecursive : ∀ output nextCandidates nextContext remaining nextCache, + ¬ordinal < nextCandidates.length → + nextContext.ValuesConsistent → StartTableAgrees nextContext.state table → + Pr[WitnessUsesOrdinal ordinal | + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + (next output) observe nextCandidates nextContext remaining table nextCache] ≤ + Pr[fun hit : Bool => hit = true | + directDetailedBoundaryPrivateOrdinalRisk ordinal parameter root ftsSecret + (next output) nextCandidates nextContext remaining table nextCache]) + (hterminalMatch : ∀ candidate nextContext remaining value nextCandidates, + nextContext.ValuesConsistent → StartTableAgrees nextContext.state table → + Pr[PrivateWitnessPlanMatchesCandidate candidate | + observe nextContext remaining value nextCandidates] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate nextContext]) + (hterminalPrefix : ∀ nextContext remaining value nextCandidates output, + output ∈ support (observe nextContext remaining value nextCandidates) → + PrivateWitnessPlanExtends nextCandidates output) : + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + Pr[WitnessUsesOrdinal ordinal | + runDirectWitnessPlanObserve + (canonicalizeDirectWitnessPlanObserve table + (fun nextContext remaining value laterCandidates => + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + (next value.1) observe laterCandidates nextContext remaining table value.2)) + nextCandidates context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache)] ≤ + Pr[fun hit : Bool => hit = true | + if hselected : ordinal < nextCandidates.length then + privateCandidateFire (nextCandidates.get ⟨ordinal, hselected⟩) context + else + runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) >>= + finishDirectWitnessOrdinalRisk + (canonicalizeDirectWitnessOrdinalRisk table + (fun nextContext remaining value laterCandidates => + directDetailedBoundaryPrivateOrdinalRisk ordinal parameter root ftsSecret + (next value.1) laterCandidates nextContext remaining table value.2)) + nextCandidates] := by + dsimp only + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + by_cases hnextSelected : ordinal < nextCandidates.length + · rw [dif_pos hnextSelected] + have hexists : ∃ candidate, + rootAwarePlannedCandidate? parameter input context.state = some candidate := by + cases hcandidate : rootAwarePlannedCandidate? parameter input context.state with + | none => + have hsame : nextCandidates = candidates := by + simp [nextCandidates, appendPlannedCandidate, hcandidate] + exact (hnotSelected (hsame ▸ hnextSelected)).elim + | some candidate => exact ⟨candidate, rfl⟩ + obtain ⟨candidate, hcandidate⟩ := hexists + have hordinal : ordinal = candidates.length := by + have hlength : nextCandidates.length = candidates.length + 1 := by + simp [nextCandidates, appendPlannedCandidate, hcandidate] + omega + subst ordinal + have hget : nextCandidates.get ⟨candidates.length, hnextSelected⟩ = candidate := by + simp [nextCandidates, appendPlannedCandidate, hcandidate, List.get_eq_getElem] + rw [hget] + have hbound := probEvent_selectedHashPlanWitnessUsesOrdinal_le parameter root ftsSecret input + next observe candidates context fuel table cache candidate hconsistent hstarts + (by + intro nextContext remaining value laterCandidates hnextConsistent hnextStarts + exact hterminalMatch candidate nextContext remaining value laterCandidates + hnextConsistent hnextStarts) + hterminalPrefix + simpa only [nextCandidates, hcandidate, appendPlannedCandidate, plan] using hbound + · rw [dif_neg hnextSelected] + apply probEvent_unselectedDirectWitnessStep_le_ordinalRisk ordinal _ _ nextCandidates + context fuel table ((probingHashQueryAfterPlan parameter input plan).run cache) + hnextSelected + intro result hresult + have hcore := resolvedCore_of_done_mem_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterPlan parameter input plan).run cache) context fuel table result + hconsistent hstarts hresult + exact hrecursive result.value.1 nextCandidates + (canonicalizeMaterializedValues table result.context) result.remaining result.value.2 + hnextSelected + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_directDetailedBoundaryWitnessUsesOrdinal_le_ordinalRisk + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hnotSelected : ¬ordinal < candidates.length) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hterminalZero : ∀ nextContext remaining value nextCandidates, + ¬ordinal < nextCandidates.length → + Pr[WitnessUsesOrdinal ordinal | + observe nextContext remaining value nextCandidates] ≤ 0) + (hterminalMatch : ∀ candidate nextContext remaining value nextCandidates, + nextContext.ValuesConsistent → StartTableAgrees nextContext.state table → + Pr[PrivateWitnessPlanMatchesCandidate candidate | + observe nextContext remaining value nextCandidates] ≤ + Pr[fun hit : Bool => hit = true | privateCandidateFire candidate nextContext]) + (hterminalPrefix : ∀ nextContext remaining value nextCandidates output, + output ∈ support (observe nextContext remaining value nextCandidates) → + PrivateWitnessPlanExtends nextCandidates output) : + Pr[WitnessUsesOrdinal ordinal | + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + computation observe candidates context fuel table cache] ≤ + Pr[fun hit : Bool => hit = true | + directDetailedBoundaryPrivateOrdinalRisk ordinal parameter root ftsSecret computation + candidates context fuel table cache] := by + induction computation using OracleComp.inductionOn generalizing + candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_pure, directDetailedBoundaryPrivateOrdinalRisk, + OracleComp.construct_pure] + simp only [hnotSelected, ↓reduceDIte] + simpa using hterminalZero context fuel (value, cache) candidates hnotSelected + | query_bind query next ih => + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind, directDetailedBoundaryPrivateOrdinalRisk, + OracleComp.construct_query_bind] + simp only [hnotSelected, ↓reduceDIte] + apply probEvent_unselectedDirectWitnessStep_le_ordinalRisk ordinal _ _ candidates + context fuel table ((splitUniformImpl n).run cache) hnotSelected + intro result hresult + have hcore := resolvedCore_of_done_mem_runDirectResolvedWitnessFromTable + ((splitUniformImpl n).run cache) context fuel table result hconsistent hstarts + hresult + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hnotSelected + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + | inr input => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind, directDetailedBoundaryPrivateOrdinalRisk, + OracleComp.construct_query_bind] + simp only [hnotSelected, ↓reduceDIte] + apply probEvent_hashBranchWitnessUsesOrdinal_le_ordinalRisk ordinal parameter root + ftsSecret input next observe candidates context fuel table cache hnotSelected + hconsistent hstarts + · intro output nextCandidates nextContext remaining nextCache hnextNotSelected + hnextConsistent hnextStarts + exact ih output nextCandidates nextContext remaining nextCache hnextNotSelected + hnextConsistent hnextStarts + · exact hterminalMatch + · exact hterminalPrefix + | inr message => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind, directDetailedBoundaryPrivateOrdinalRisk, + OracleComp.construct_query_bind] + simp only [hnotSelected, ↓reduceDIte] + apply probEvent_unselectedDirectWitnessStep_le_ordinalRisk ordinal _ _ candidates + context fuel table ((maskedSign parameter root ftsSecret message).run cache) + hnotSelected + intro result hresult + have hcore := resolvedCore_of_done_mem_runDirectResolvedWitnessFromTable + ((maskedSign parameter root ftsSecret message).run cache) + context fuel table result hconsistent hstarts hresult + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hnotSelected + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + +theorem probEvent_retainedFinalizationWitnessUsesOrdinal_le_zero + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) (candidates : List Probe) + (ordinal : Nat) (hnotSelected : ¬ordinal < candidates.length) : + Pr[WitnessUsesOrdinal ordinal | + retainedResolvedFinalizationPrivateWitnessPlanObserve table root context fuel value + candidates] ≤ 0 := by + unfold retainedResolvedFinalizationPrivateWitnessPlanObserve + by_cases hhit : PrivateStructuralHit context + · simp only [hhit, ↓reduceDIte] + have hnone : ¬WitnessUsesOrdinal ordinal + (some (privateHitWitnessOf context hhit), candidates) := + not_witnessUsesOrdinal_of_not_lt_length ordinal _ hnotSelected + simp [hnone] + · simp only [hhit, ↓reduceDIte] + have hnone : ¬WitnessUsesOrdinal ordinal + ((none, candidates) : PrivateWitnessPlanOutput) := + not_witnessUsesOrdinal_of_not_lt_length ordinal _ hnotSelected + simp [hnone] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_granularDetailedRetainedRestWitnessUsesOrdinal_le_ordinalRisk + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (ordinal : Nat) (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) + (hnotSelected : ¬ordinal < candidates.length) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + Pr[WitnessUsesOrdinal ordinal | + granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates] ≤ + Pr[fun hit : Bool => hit = true | + granularDetailedRetainedRestPrivateOrdinalRisk adversary parameter table ftsSecret + ordinal context fuel value candidates] := by + unfold granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve + granularDetailedRetainedRestPrivateOrdinalRisk + apply probEvent_directDetailedBoundaryWitnessUsesOrdinal_le_ordinalRisk ordinal parameter + value.1 ftsSecret (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivateWitnessPlanObserve table value.1) + candidates context fuel table value.2 hnotSelected hconsistent hstarts + · intro nextContext remaining nextValue nextCandidates hnextNotSelected + exact probEvent_retainedFinalizationWitnessUsesOrdinal_le_zero table value.1 nextContext + remaining nextValue nextCandidates ordinal hnextNotSelected + · intro candidate nextContext remaining nextValue nextCandidates _hnextConsistent + _hnextStarts + exact probEvent_retainedResolvedFinalizationPrivateWitnessPlanMatchesCandidate_le table + value.1 candidate nextContext remaining nextValue nextCandidates + · intro nextContext remaining nextValue nextCandidates output houtput + exact privateWitnessPlanExtends_of_mem_retainedResolvedFinalizationPrivateWitnessPlanObserve + table value.1 nextContext remaining nextValue nextCandidates output houtput + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootAdaptive.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootAdaptive.lean new file mode 100644 index 00000000..388c166a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootAdaptive.lean @@ -0,0 +1,1085 @@ +import SphincsSecurity.Proof.FewTimeOriginProbability +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSigner + +/-! +# Adaptive layer-root cache relation + +The root cache quotient pairs signer inputs carrying the actual and comparison roots. Earlier +adversarial inputs carrying any other digest remain equal at their exact keys. If an earlier input +carries either distinguished root, it is the corresponding first-hit event instead. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem encodingInputNamesRoot_of_guessesRoot + {parameter : PublicParameter} {target : Position} + {guess : Digest} {input : HashInput} + (hguess : EncodingInputGuessesRoot parameter target guess input) : + EncodingInputNamesRoot parameter target input := + ⟨⟨.position target, guess⟩, hguess, rfl⟩ + +theorem RootEncodingCacheRel.update_same_wrong + {parameter : PublicParameter} {target : Position} {leftRoot rightRoot : Digest} + {left right : SplitHashCache} + (hrel : RootEncodingCacheRel parameter target leftRoot rightRoot left right) + (input : HashInput) (guess : Digest) + (hguess : EncodingInputGuessesRoot parameter target guess input) + (hleft : guess ≠ leftRoot) (hright : guess ≠ rightRoot) + (output : HashOutput) : + RootEncodingCacheRel parameter target leftRoot rightRoot + (Function.update left (.ordinary input) (some output)) + (Function.update right (.ordinary input) (some output)) := by + refine ⟨?_, ?_, ?_, ?_⟩ + · intro other hother + have hne : SplitHashKey.ordinary other ≠ .ordinary input := by + intro heq + apply hother + have hinput := SplitHashKey.ordinary.inj heq + rw [hinput] + exact encodingInputNamesRoot_of_guessesRoot hguess + simp [Function.update_of_ne hne, hrel.nonroot other hother] + · intro position counter hposition + have hleftNe : SplitHashKey.ordinary + (encodingRetryInput parameter position leftRoot counter) ≠ .ordinary input := by + intro heq + have hinput := (SplitHashKey.ordinary.inj heq).symm + exact hleft (guess_eq_of_encodingRetryInput_eq hposition hinput hguess) + have hrightNe : SplitHashKey.ordinary + (encodingRetryInput parameter position rightRoot counter) ≠ .ordinary input := by + intro heq + have hinput := (SplitHashKey.ordinary.inj heq).symm + exact hright (guess_eq_of_encodingRetryInput_eq hposition hinput hguess) + simp [Function.update_of_ne hleftNe, Function.update_of_ne hrightNe, + hrel.retry position counter hposition] + · intro coordinate + simp [hrel.hidden coordinate] + · intro other otherGuess hotherGuess hotherLeft hotherRight + by_cases heq : SplitHashKey.ordinary other = .ordinary input + · simp [heq] + · simp [Function.update_of_ne heq, + hrel.wrong other otherGuess hotherGuess hotherLeft hotherRight] + +theorem RootEncodingCacheRel.lookup_guess + {parameter : PublicParameter} {target : Position} {leftRoot rightRoot : Digest} + {left right : SplitHashCache} + (hrel : RootEncodingCacheRel parameter target leftRoot rightRoot left right) + (input : HashInput) (guess : Digest) + (hguess : EncodingInputGuessesRoot parameter target guess input) : + guess = leftRoot ∨ guess = rightRoot ∨ + left (.ordinary input) = right (.ordinary input) := by + by_cases hleft : guess = leftRoot + · exact Or.inl hleft + · by_cases hright : guess = rightRoot + · exact Or.inr (Or.inl hright) + · exact Or.inr (Or.inr (hrel.wrong input guess hguess hleft hright)) + +theorem relTriple_splitHashQuery_same_wrong + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) (guess : Digest) + (hguess : EncodingInputGuessesRoot parameter target guess input) + (hleft : guess ≠ leftRoot) (hright : guess ≠ rightRoot) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + RelTriple + (runCleanFromTable state fuel table ((splitHashQuery (.ordinary input)).run leftCache)) + (runCleanFromTable state fuel table ((splitHashQuery (.ordinary input)).run rightCache)) + (RootEncodingCleanSameRel parameter target leftRoot rightRoot) := by + have hlookup := hcache.wrong input guess hguess hleft hright + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + cases hleftLookup : leftCache (.ordinary input) with + | some output => + have hrightLookup : rightCache (.ordinary input) = some output := by + rw [← hlookup] + exact hleftLookup + simp only [hrightLookup, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + | none => + have hrightLookup : rightCache (.ordinary input) = none := by + rw [← hlookup] + exact hleftLookup + simp only [hrightLookup] + unfold LazyRevealProbe.hashOutputQuery + rw [runCleanFromTable_hashOutput_query_bind, + runCleanFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_wrong input guess hguess hleft hright leftOutput⟩ + +theorem splitHashQuery_root_guess_trichotomy + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) (guess : Digest) + (hguess : EncodingInputGuessesRoot parameter target guess input) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + guess = leftRoot ∨ guess = rightRoot ∨ + RelTriple + (runCleanFromTable state fuel table ((splitHashQuery (.ordinary input)).run leftCache)) + (runCleanFromTable state fuel table ((splitHashQuery (.ordinary input)).run rightCache)) + (RootEncodingCleanSameRel parameter target leftRoot rightRoot) := by + by_cases hleft : guess = leftRoot + · exact Or.inl hleft + · by_cases hright : guess = rightRoot + · exact Or.inr (Or.inl hright) + · exact Or.inr (Or.inr + (relTriple_splitHashQuery_same_wrong parameter target leftRoot rightRoot input guess + hguess hleft hright leftCache rightCache hcache state fuel table)) + +def RootInputAvoids + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) : Prop := + ¬EncodingInputGuessesRoot parameter target leftRoot input ∧ + ¬EncodingInputGuessesRoot parameter target rightRoot input + +def NoEncodingRootGuessCached + (parameter : PublicParameter) (target : Position) + (root : Digest) (cache : SplitHashCache) : Prop := + ∀ input, EncodingInputGuessesRoot parameter target root input → + cache (.ordinary input) = none + +theorem RootEncodingCacheRel.of_same_of_no_guesses + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (cache : SplitHashCache) + (hleft : NoEncodingRootGuessCached parameter target leftRoot cache) + (hright : NoEncodingRootGuessCached parameter target rightRoot cache) : + RootEncodingCacheRel parameter target leftRoot rightRoot cache cache := by + refine ⟨?_, ?_, ?_, ?_⟩ + · intro input hinput + rfl + · intro position counter hposition + rw [hleft (encodingRetryInput parameter position leftRoot counter) + (decodeEncodingLayerRootCandidate?_encodingRetryInput hposition leftRoot counter)] + rw [hright (encodingRetryInput parameter position rightRoot counter) + (decodeEncodingLayerRootCandidate?_encodingRetryInput hposition rightRoot counter)] + · intro coordinate + rfl + · intro input guess hguess hguessLeft hguessRight + rfl + +theorem rootInputAvoids_classify + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} {input : HashInput} + (havoid : RootInputAvoids parameter target leftRoot rightRoot input) : + ¬EncodingInputNamesRoot parameter target input ∨ + ∃ guess, EncodingInputGuessesRoot parameter target guess input ∧ + guess ≠ leftRoot ∧ guess ≠ rightRoot := by + by_cases hnames : EncodingInputNamesRoot parameter target input + · obtain ⟨candidate, hdecode, hcoordinate⟩ := hnames + let guess := candidate.candidate + have hcandidate : candidate = ⟨.position target, guess⟩ := by + cases candidate with + | mk coordinate candidate => + simp only at hcoordinate + subst coordinate + rfl + have hguess : EncodingInputGuessesRoot parameter target guess input := by + unfold EncodingInputGuessesRoot + rwa [← hcandidate] + exact Or.inr ⟨guess, hguess, + fun heq => havoid.1 (heq ▸ hguess), + fun heq => havoid.2 (heq ▸ hguess)⟩ + · exact Or.inl hnames + +theorem RootEncodingCacheRel.lookup_avoids + {parameter : PublicParameter} {target : Position} {leftRoot rightRoot : Digest} + {left right : SplitHashCache} + (hrel : RootEncodingCacheRel parameter target leftRoot rightRoot left right) + (input : HashInput) (havoid : RootInputAvoids parameter target leftRoot rightRoot input) : + left (.ordinary input) = right (.ordinary input) := by + rcases rootInputAvoids_classify havoid with hnonroot | ⟨guess, hguess, hleft, hright⟩ + · exact hrel.nonroot input hnonroot + · exact hrel.wrong input guess hguess hleft hright + +theorem RootEncodingCacheRel.update_same_avoids + {parameter : PublicParameter} {target : Position} {leftRoot rightRoot : Digest} + {left right : SplitHashCache} + (hrel : RootEncodingCacheRel parameter target leftRoot rightRoot left right) + (input : HashInput) (havoid : RootInputAvoids parameter target leftRoot rightRoot input) + (output : HashOutput) : + RootEncodingCacheRel parameter target leftRoot rightRoot + (Function.update left (.ordinary input) (some output)) + (Function.update right (.ordinary input) (some output)) := by + rcases rootInputAvoids_classify havoid with hnonroot | ⟨guess, hguess, hleft, hright⟩ + · exact hrel.update_same_nonroot (.ordinary input) output hnonroot + · exact hrel.update_same_wrong input guess hguess hleft hright output + +theorem relTriple_splitHashQuery_same_avoids + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) + (havoid : RootInputAvoids parameter target leftRoot rightRoot input) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + RelTriple + (runCleanFromTable state fuel table ((splitHashQuery (.ordinary input)).run leftCache)) + (runCleanFromTable state fuel table ((splitHashQuery (.ordinary input)).run rightCache)) + (RootEncodingCleanSameRel parameter target leftRoot rightRoot) := by + have hlookup := hcache.lookup_avoids input havoid + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + cases hleftLookup : leftCache (.ordinary input) with + | some output => + have hrightLookup : rightCache (.ordinary input) = some output := by + rw [← hlookup] + exact hleftLookup + simp only [hrightLookup, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + | none => + have hrightLookup : rightCache (.ordinary input) = none := by + rw [← hlookup] + exact hleftLookup + simp only [hrightLookup] + unfold LazyRevealProbe.hashOutputQuery + rw [runCleanFromTable_hashOutput_query_bind, + runCleanFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_avoids input havoid leftOutput⟩ + +theorem rootEncodingCacheCouples_modifyOrdinary_avoids + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) + (havoid : RootInputAvoids parameter target leftRoot rightRoot input) + (output : HashOutput) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output)) := by + intro leftCache rightCache hcache state fuel table + simp only [StateT.run_modify, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_avoids input havoid output⟩ + +theorem rootEncodingCacheCouples_resolveKnownInput_avoids + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (coordinate : Coordinate) (input : HashInput) + (havoid : RootInputAvoids parameter target leftRoot rightRoot input) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (resolveKnownInput parameter coordinate input) := by + unfold resolveKnownInput + apply (rootEncodingCacheCouples_peekTableInput parameter target leftRoot rightRoot + coordinate).bind + intro knownInput + cases knownInput with + | none => + intro leftCache rightCache hcache state fuel table + exact relTriple_splitHashQuery_same_avoids parameter target leftRoot rightRoot input havoid + leftCache rightCache hcache state fuel table + | some knownInput => + simp only + by_cases heq : knownInput = input + · rw [if_pos heq] + apply (rootEncodingCacheCouples_revealCoordinateOutput parameter target leftRoot rightRoot + coordinate).bind + intro output + exact (rootEncodingCacheCouples_publishCoordinate parameter target leftRoot rightRoot + coordinate).bind fun _ => + (rootEncodingCacheCouples_modifyOrdinary_avoids parameter target leftRoot rightRoot + input havoid output).bind fun _ => + rootEncodingCacheCouples_pure parameter target leftRoot rightRoot output + · rw [if_neg heq] + intro leftCache rightCache hcache state fuel table + exact relTriple_splitHashQuery_same_avoids parameter target leftRoot rightRoot input havoid + leftCache rightCache hcache state fuel table + +theorem rootEncodingCacheCouples_executeCandidate + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (candidate? : Option Probe) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (executeCandidate? candidate?) := by + cases candidate? with + | none => + simp only [executeCandidate?] + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot () + | some candidate => + simp only [executeCandidate?] + exact rootEncodingCacheCouples_probe parameter target leftRoot rightRoot candidate + +theorem rootEncodingCacheCouples_planFirstMissingInputCoordinate + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) : + ∀ slot coordinates, + RootEncodingCacheCouples parameter target leftRoot rightRoot + (planFirstMissingInputCoordinate input slot coordinates) := by + intro slot coordinates + induction coordinates generalizing slot with + | nil => + rw [planFirstMissingInputCoordinate] + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot none + | cons coordinate remaining ih => + rw [planFirstMissingInputCoordinate] + apply (rootEncodingCacheCouples_peekCoordinate parameter target leftRoot rightRoot + coordinate).bind + intro value + cases value with + | none => + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (some (⟨coordinate, slotDigest slot input⟩ : Probe)) + | some output => exact ih (slot + 1) + +theorem rootEncodingCacheCouples_planLeafInputProbe + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (planLeafInputProbe input candidate lay tree leafIdx) := by + unfold planLeafInputProbe + apply (rootEncodingCacheCouples_peekCoordinate parameter target leftRoot rightRoot + candidate.coordinate).bind + intro value + cases value with + | none => + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot (some candidate) + | some output => + exact rootEncodingCacheCouples_planFirstMissingInputCoordinate parameter target leftRoot + rightRoot input 0 ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + +theorem rootEncodingCacheCouples_planProbingHashQuery + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (planProbingHashQuery parameter input) := by + unfold planProbingHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases hposition : decodePosition? parameter input with + | none => + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (⟨some candidate, .resolve candidate.outputCoordinate⟩ : PlannedHashQuery) + | some position => + cases position with + | leaf lay tree leafIdx => + apply (rootEncodingCacheCouples_planLeafInputProbe parameter target leftRoot + rightRoot input candidate lay tree leafIdx).bind + intro candidate? + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (⟨candidate?, .resolve candidate.outputCoordinate⟩ : PlannedHashQuery) + | chain | node | ftsLeaf | ftsNode | ftsRoots => + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (⟨some candidate, .resolve candidate.outputCoordinate⟩ : PlannedHashQuery) + | none => + cases hposition : decodePosition? parameter input with + | none => + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (⟨none, .ordinary⟩ : PlannedHashQuery) + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (⟨none, .resolve (.position (.chain lay tree leafIdx chainIdx step))⟩ : + PlannedHashQuery) + | leaf lay tree leafIdx => + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (⟨none, .resolve (.position (.leaf lay tree leafIdx))⟩ : PlannedHashQuery) + | node lay tree level nodeIdx => + apply (rootEncodingCacheCouples_planFirstMissingInputCoordinate parameter target + leftRoot rightRoot input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)).bind + intro candidate? + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (⟨candidate?, .resolve (.position (.node lay tree level nodeIdx))⟩ : + PlannedHashQuery) + | ftsLeaf | ftsNode | ftsRoots => + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (⟨none, .ordinary⟩ : PlannedHashQuery) + +theorem rootEncodingCacheCouples_probingHashQueryAfterPlan_avoids + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) (plan : PlannedHashQuery) + (havoid : RootInputAvoids parameter target leftRoot rightRoot input) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (probingHashQueryAfterPlan parameter input plan) := by + unfold probingHashQueryAfterPlan executePlannedHashQuery + apply (rootEncodingCacheCouples_executeCandidate parameter target leftRoot rightRoot + plan.candidate?).bind + intro _ + cases plan.action with + | ordinary => + intro leftCache rightCache hcache state fuel table + exact relTriple_splitHashQuery_same_avoids parameter target leftRoot rightRoot input havoid + leftCache rightCache hcache state fuel table + | resolve coordinate => + exact rootEncodingCacheCouples_resolveKnownInput_avoids parameter target leftRoot rightRoot + coordinate input havoid + +theorem rootEncodingCacheCouples_probingHashQuery_avoids + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) + (havoid : RootInputAvoids parameter target leftRoot rightRoot input) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (probingHashQuery parameter input) := by + have hcoupled : RootEncodingCacheCouples parameter target leftRoot rightRoot (do + let plan ← planProbingHashQuery parameter input + probingHashQueryAfterPlan parameter input plan) := + (rootEncodingCacheCouples_planProbingHashQuery parameter target leftRoot rightRoot input).bind + fun plan => rootEncodingCacheCouples_probingHashQueryAfterPlan_avoids parameter target + leftRoot rightRoot input plan havoid + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases hposition : decodePosition? parameter input with + | none => + rw [probingHashQuery_eq_plan_then_afterPlan_of_probe_some_nonleaf parameter input + candidate hprobe (by + rintro ⟨lay, tree, leafIdx, heq⟩ + simp [hposition] at heq)] + exact hcoupled + | some position => + cases position with + | leaf lay tree leafIdx => + rw [probingHashQuery_eq_plan_then_afterPlan_leaf parameter input candidate lay tree + leafIdx hprobe hposition] + exact hcoupled + | chain | node | ftsLeaf | ftsNode | ftsRoots => + rw [probingHashQuery_eq_plan_then_afterPlan_of_probe_some_nonleaf parameter input + candidate hprobe (by + rintro ⟨lay, tree, leafIdx, heq⟩ + simp [hposition] at heq)] + exact hcoupled + | none => + cases hposition : decodePosition? parameter input with + | none => + rw [probingHashQuery_eq_plan_then_afterPlan_of_probe_none_nonnode parameter input hprobe + (by + rintro ⟨lay, tree, level, nodeIdx, heq⟩ + simp [hposition] at heq)] + exact hcoupled + | some position => + cases position with + | node lay tree level nodeIdx => + rw [probingHashQuery_eq_plan_then_afterPlan_node parameter input lay tree level + nodeIdx hprobe hposition] + exact hcoupled + | chain | leaf | ftsLeaf | ftsNode | ftsRoots => + rw [probingHashQuery_eq_plan_then_afterPlan_of_probe_none_nonnode parameter input + hprobe (by + rintro ⟨lay, tree, level, nodeIdx, heq⟩ + simp [hposition] at heq)] + exact hcoupled + +theorem rootInput_hit_or_avoids + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) : + EncodingInputGuessesRoot parameter target leftRoot input ∨ + EncodingInputGuessesRoot parameter target rightRoot input ∨ + RootInputAvoids parameter target leftRoot rightRoot input := by + by_cases hleft : EncodingInputGuessesRoot parameter target leftRoot input + · exact Or.inl hleft + · by_cases hright : EncodingInputGuessesRoot parameter target rightRoot input + · exact Or.inr (Or.inl hright) + · exact Or.inr (Or.inr ⟨hleft, hright⟩) + +theorem probingHashQueryAfterPlan_root_trichotomy + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) (plan : PlannedHashQuery) : + EncodingInputGuessesRoot parameter target leftRoot input ∨ + EncodingInputGuessesRoot parameter target rightRoot input ∨ + RootEncodingCacheRelatesStored parameter target leftRoot rightRoot + (probingHashQueryAfterPlan parameter input plan) + (probingHashQueryAfterPlan parameter input plan) := by + rcases rootInput_hit_or_avoids parameter target leftRoot rightRoot input with + hleft | hright | hsafe + · exact Or.inl hleft + · exact Or.inr (Or.inl hright) + · exact Or.inr (Or.inr + ((rootEncodingCacheCouples_probingHashQueryAfterPlan_avoids parameter target leftRoot + rightRoot input plan hsafe).relates.toStored)) + +noncomputable def maskedComparisonSigningImpl + (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (comparisonRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + QueryImpl SigningSpec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate))) := + fun message => + maskedSignWithTargetComparison parameter publicRoot target comparisonRoot ftsSecret message + +noncomputable def maskedExpandedAdversaryImplWithTargetComparison + (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (comparisonRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + QueryImpl (OracleWorld + SigningSpec) + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate))) := + probingRomImpl parameter + + maskedComparisonSigningImpl parameter publicRoot target comparisonRoot ftsSecret + +def ExpandedQueryGuessesRoot + (parameter : PublicParameter) (target : Position) (root : Digest) + (query : (OracleWorld + SigningSpec).Domain) : Prop := + ∃ input, query = .inl (.inr input) ∧ + EncodingInputGuessesRoot parameter target root input + +def ExpandedQueryAvoidsRoots + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (query : (OracleWorld + SigningSpec).Domain) : Prop := + match query with + | .inl (.inr input) => RootInputAvoids parameter target leftRoot rightRoot input + | _ => True + +theorem not_expandedQueryGuessesRoot_of_avoids + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} + {query : (OracleWorld + SigningSpec).Domain} + (havoid : ExpandedQueryAvoidsRoots parameter target leftRoot rightRoot query) : + ¬ExpandedQueryGuessesRoot parameter target leftRoot query ∧ + ¬ExpandedQueryGuessesRoot parameter target rightRoot query := by + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => simp [ExpandedQueryGuessesRoot] + | inr input => + constructor + · rintro ⟨otherInput, heq, hguess⟩ + cases heq + exact havoid.1 hguess + · rintro ⟨otherInput, heq, hguess⟩ + cases heq + exact havoid.2 hguess + | inr message => simp [ExpandedQueryGuessesRoot] + +theorem maskedExpandedAdversaryImpl_step_root_trichotomy + (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) : + ExpandedQueryGuessesRoot parameter target leftRoot query ∨ + ExpandedQueryGuessesRoot parameter target rightRoot query ∨ + RootEncodingCacheRelatesStored parameter target leftRoot rightRoot + (maskedExpandedAdversaryImpl parameter publicRoot ftsSecret query) + (maskedExpandedAdversaryImplWithTargetComparison parameter publicRoot target rightRoot + ftsSecret query) := by + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + exact Or.inr (Or.inr + ((rootEncodingCacheCouples_splitUniformImpl parameter target leftRoot rightRoot + n).relates.toStored)) + | inr input => + rcases rootInput_hit_or_avoids parameter target leftRoot rightRoot input with + hleft | hright | hsafe + · exact Or.inl ⟨input, rfl, hleft⟩ + · exact Or.inr (Or.inl ⟨input, rfl, hright⟩) + · exact Or.inr (Or.inr + ((rootEncodingCacheCouples_probingHashQuery_avoids parameter target leftRoot + rightRoot input hsafe).relates.toStored)) + | inr message => + exact Or.inr (Or.inr + (rootEncodingCacheRelatesStored_maskedSign_targetComparison parameter publicRoot target + hroot leftRoot rightRoot ftsSecret message)) + +theorem rootEncodingCacheRelatesStored_maskedExpandedAdversaryImpl_of_avoids + (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) + (havoid : ExpandedQueryAvoidsRoots parameter target leftRoot rightRoot query) : + RootEncodingCacheRelatesStored parameter target leftRoot rightRoot + (maskedExpandedAdversaryImpl parameter publicRoot ftsSecret query) + (maskedExpandedAdversaryImplWithTargetComparison parameter publicRoot target rightRoot + ftsSecret query) := by + have hnot := not_expandedQueryGuessesRoot_of_avoids havoid + rcases maskedExpandedAdversaryImpl_step_root_trichotomy parameter publicRoot target hroot + leftRoot rightRoot ftsSecret query with hleft | hright | hsafe + · exact False.elim (hnot.1 hleft) + · exact False.elim (hnot.2 hright) + · exact hsafe + +noncomputable def rootAvoidingComputation + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + OracleComp (OracleWorld + SigningSpec) (Option α) := by + classical + exact OracleComp.construct + (C := fun _ => OracleComp (OracleWorld + SigningSpec) (Option α)) + (fun value => pure (some value)) + (fun query _next recursivelyRun => + if ExpandedQueryAvoidsRoots parameter target leftRoot rightRoot query then do + let output ← liftM ((OracleWorld + SigningSpec).query query) + recursivelyRun output + else pure none) + computation + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem rootEncodingCacheRelatesStored_simulateQ_rootAvoidingComputation + (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + RootEncodingCacheRelatesStored parameter target leftRoot rightRoot + (simulateQ (maskedExpandedAdversaryImpl parameter publicRoot ftsSecret) + (rootAvoidingComputation parameter target leftRoot rightRoot computation)) + (simulateQ (maskedExpandedAdversaryImplWithTargetComparison parameter publicRoot target + rightRoot ftsSecret) + (rootAvoidingComputation parameter target leftRoot rightRoot computation)) := by + induction computation using OracleComp.inductionOn with + | pure value => + rw [rootAvoidingComputation, OracleComp.construct_pure, simulateQ_pure, simulateQ_pure] + exact ((rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (some value)).relates).toStored + | query_bind query next ih => + rw [rootAvoidingComputation, OracleComp.construct_query_bind] + by_cases hsafe : ExpandedQueryAvoidsRoots parameter target leftRoot rightRoot query + · rw [if_pos hsafe, simulateQ_query_bind, simulateQ_query_bind] + apply (rootEncodingCacheRelatesStored_maskedExpandedAdversaryImpl_of_avoids parameter + publicRoot target hroot leftRoot rightRoot ftsSecret query hsafe).bind + intro leftOutput rightOutput houtput + subst rightOutput + exact ih leftOutput + · rw [if_neg hsafe, simulateQ_pure, simulateQ_pure] + exact ((rootEncodingCacheCouples_pure parameter target leftRoot rightRoot none).relates).toStored + +theorem rootAwarePlannedCandidate_root_plan_or_encodingGuess + {parameter : PublicParameter} {input : HashInput} + {state : LazyRevealProbe.State Coordinate} {candidate : Probe} + {target : Position} + (hcandidate : rootAwarePlannedCandidate? parameter input state = some candidate) + (hcoordinate : candidate.coordinate = .position target) : + (purePlanProbingHashQuery parameter input state).candidate? = some candidate ∨ + EncodingInputGuessesRoot parameter target candidate.candidate input := by + unfold rootAwarePlannedCandidate? at hcandidate + cases hplan : (purePlanProbingHashQuery parameter input state).candidate? with + | some planned => + simp only [hplan] at hcandidate + have heq : planned = candidate := Option.some.inj hcandidate + subst candidate + exact Or.inl rfl + | none => + simp only [hplan] at hcandidate + right + unfold EncodingInputGuessesRoot + cases candidate with + | mk coordinate candidateDigest => + simp only at hcoordinate ⊢ + subst coordinate + exact hcandidate + +theorem Probe.exists_atPosition_of_matchesInput + {parameter : PublicParameter} {input : HashInput} {probe : Probe} + (hmatch : probe.MatchesInput parameter input) : + ∃ position, AtPosition parameter input position := by + rcases probe with ⟨coordinate, candidate⟩ + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + obtain ⟨step, _hstep, hinput⟩ := hmatch + exact ⟨.chain lay tree leafIdx chainIdx step, digestBytes candidate, hinput⟩ + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + by_cases hnext : step.val + 1 < chainLength - 1 + · simp only [Probe.MatchesInput, hnext, ↓reduceDIte] at hmatch + obtain ⟨nextStep, _hstep, hinput⟩ := hmatch + exact ⟨.chain lay tree leafIdx chainIdx nextStep, digestBytes candidate, hinput⟩ + · simp only [Probe.MatchesInput, hnext, ↓reduceDIte] at hmatch + obtain ⟨_hchain, payload, hinput, _hslot⟩ := hmatch + exact ⟨.leaf lay tree leafIdx, payload, hinput⟩ + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp [Probe.MatchesInput] at hmatch + +theorem decodeProbe?_eq_none_of_atEncodingPosition + {parameter : PublicParameter} {input : HashInput} + {position : EncodingPosition} + (hencoding : AtEncodingPosition parameter input position) : + decodeProbe? parameter input = none := by + rw [decodeProbe?_eq_none_iff] + intro probe hmatch + obtain ⟨structuralPosition, hposition⟩ := probe.exists_atPosition_of_matchesInput hmatch + exact hencoding.not_atPosition structuralPosition hposition + +theorem decodePosition?_eq_none_of_atEncodingPosition + {parameter : PublicParameter} {input : HashInput} + {position : EncodingPosition} + (hencoding : AtEncodingPosition parameter input position) : + decodePosition? parameter input = none := by + classical + unfold decodePosition? + rw [dif_neg] + rintro ⟨structuralPosition, hposition⟩ + exact hencoding.not_atPosition structuralPosition hposition + +theorem rootAwarePlannedCandidate?_eq_some_of_encodingInputGuessesRoot + {parameter : PublicParameter} {target : Position} {root : Digest} + {input : HashInput} (state : LazyRevealProbe.State Coordinate) + (hguess : EncodingInputGuessesRoot parameter target root input) : + rootAwarePlannedCandidate? parameter input state = + some ⟨.position target, root⟩ := by + have hdecode : decodeEncodingLayerRootCandidate? parameter input = + some ⟨.position target, root⟩ := hguess + have hcandidate := + (decodeEncodingLayerRootCandidate?_eq_some_iff parameter input + ⟨.position target, root⟩).mp hdecode + obtain ⟨position, index, hencoding, _htree, _hleaf, _hlayer, _hcandidate⟩ := hcandidate + have hprobe := decodeProbe?_eq_none_of_atEncodingPosition hencoding + have hposition := decodePosition?_eq_none_of_atEncodingPosition hencoding + unfold rootAwarePlannedCandidate? purePlanProbingHashQuery + rw [hprobe, hposition] + exact hdecode + +def RootAwareCandidateAvoidsRoots + (target : Position) (leftRoot rightRoot : Digest) + (candidate? : Option Probe) : Prop := + candidate? ≠ some ⟨.position target, leftRoot⟩ ∧ + candidate? ≠ some ⟨.position target, rightRoot⟩ + +theorem rootInputAvoids_of_rootAwareCandidateAvoidsRoots + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} {input : HashInput} + {state : LazyRevealProbe.State Coordinate} + (havoid : RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwarePlannedCandidate? parameter input state)) : + RootInputAvoids parameter target leftRoot rightRoot input := by + constructor + · intro hguess + exact havoid.1 + (rootAwarePlannedCandidate?_eq_some_of_encodingInputGuessesRoot state hguess) + · intro hguess + exact havoid.2 + (rootAwarePlannedCandidate?_eq_some_of_encodingInputGuessesRoot state hguess) + +def cleanRunReturnedValue? : Option (CleanRunResult (α × SplitHashCache)) → Option α + | none => none + | some result => some result.value.1 + +theorem evalDist_cleanRunReturnedValue_eq_of_rootEncodingStored + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} + {left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + (hrelates : RootEncodingCacheRelatesStored parameter target leftRoot rightRoot left right) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hstored : StoredLayerRoot state target leftRoot) : + evalDist (cleanRunReturnedValue? <$> + runCleanFromTable state fuel table (left.run leftCache)) = + evalDist (cleanRunReturnedValue? <$> + runCleanFromTable state fuel table (right.run rightCache)) := by + have hrun := hrelates leftCache rightCache hcache state fuel table hstored + have hprojected : RelTriple + (runCleanFromTable state fuel table (left.run leftCache)) + (runCleanFromTable state fuel table (right.run rightCache)) + (fun leftResult rightResult => + cleanRunReturnedValue? leftResult = cleanRunReturnedValue? rightResult) := by + apply relTriple_post_mono hrun + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => rfl + | some rightResult => simp [RootEncodingStoredCleanSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootEncodingStoredCleanSameRel] at hresult + | some rightResult => + simp only [RootEncodingStoredCleanSameRel, RootEncodingCleanSameRel] at hresult + simp [cleanRunReturnedValue?, hresult.1.2.2.2.1] + have hmapped : RelTriple + (cleanRunReturnedValue? <$> + runCleanFromTable state fuel table (left.run leftCache)) + (cleanRunReturnedValue? <$> + runCleanFromTable state fuel table (right.run rightCache)) + (fun leftValue rightValue => leftValue = rightValue) := + relTriple_map hprojected + exact evalDist_eq_of_relTriple_eqRel hmapped + +theorem evalDist_rootAvoidingComputation_returnedValue_eq + (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hstored : StoredLayerRoot state target leftRoot) : + evalDist (cleanRunReturnedValue? <$> + runCleanFromTable state fuel table + ((simulateQ (maskedExpandedAdversaryImpl parameter publicRoot ftsSecret) + (rootAvoidingComputation parameter target leftRoot rightRoot computation)).run + leftCache)) = + evalDist (cleanRunReturnedValue? <$> + runCleanFromTable state fuel table + ((simulateQ + (maskedExpandedAdversaryImplWithTargetComparison parameter publicRoot target + rightRoot ftsSecret) + (rootAvoidingComputation parameter target leftRoot rightRoot computation)).run + rightCache)) := + evalDist_cleanRunReturnedValue_eq_of_rootEncodingStored + (rootEncodingCacheRelatesStored_simulateQ_rootAvoidingComputation parameter publicRoot target + hroot leftRoot rightRoot ftsSecret computation) + leftCache rightCache hcache state fuel table hstored + +theorem probEvent_uniform_root_matches_distribution_independent_guess_le + (run : Digest → ProbComp α) (reference : ProbComp α) + (heq : ∀ root, evalDist (run root) = evalDist reference) + (guess : α → Digest) : + Pr[fun result : Digest × α => result.1 = guess result.2 | do + let root ← ($ᵗ Digest : ProbComp Digest) + let result ← run root + pure (root, result)] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let sampled := ($ᵗ Digest : ProbComp Digest) + let dependent : ProbComp (Digest × α) := do + let root ← sampled + let result ← run root + pure (root, result) + let independent : ProbComp (Digest × α) := do + let result ← reference + let root ← sampled + pure (root, result) + have hreplace : evalDist dependent = evalDist (do + let root ← sampled + let result ← reference + pure (root, result)) := by + unfold dependent + apply evalDist_bind_congr + intro root _hroot + rw [evalDist_bind, evalDist_bind, heq root] + have hcommute : evalDist (do + let root ← sampled + let result ← reference + pure (root, result)) = evalDist independent := by + unfold independent + exact OracleComp.DeferredSampling.evalDist_bind_comm sampled reference + (fun root result => pure (root, result)) + change Pr[fun result : Digest × α => result.1 = guess result.2 | dependent] ≤ _ + calc + _ = Pr[fun result : Digest × α => result.1 = guess result.2 | independent] := by + exact OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) (hreplace.trans hcommute) + _ ≤ ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + unfold independent + apply probEvent_bind_le_of_forall_le + intro result _hresult + rw [show (do + let root ← sampled + pure (root, result)) = + (fun root => (root, result)) <$> sampled by + simp [map_eq_bind_pure_comp], probEvent_map] + change Pr[fun root : Digest => root = guess result | sampled] ≤ _ + rw [probEvent_eq_eq_probOutput, probOutput_uniformSample] + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + +theorem probEvent_uniform_root_matches_distribution_independent_guess_le_mul + (run : Digest → ProbComp α) (reference : ProbComp α) + (heq : ∀ root, evalDist (run root) = evalDist reference) + (guess : α → Digest) (gate : α → Prop) : + Pr[fun result : Digest × α => + gate result.2 ∧ result.1 = guess result.2 | do + let root ← ($ᵗ Digest : ProbComp Digest) + let result ← run root + pure (root, result)] ≤ + Pr[gate | reference] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let sampled := ($ᵗ Digest : ProbComp Digest) + let dependent : ProbComp (Digest × α) := do + let root ← sampled + let result ← run root + pure (root, result) + let independent : ProbComp (Digest × α) := do + let result ← reference + let root ← sampled + pure (root, result) + have hreplace : evalDist dependent = evalDist (do + let root ← sampled + let result ← reference + pure (root, result)) := by + unfold dependent + apply evalDist_bind_congr + intro root _hroot + rw [evalDist_bind, evalDist_bind, heq root] + have hcommute : evalDist (do + let root ← sampled + let result ← reference + pure (root, result)) = evalDist independent := by + unfold independent + exact OracleComp.DeferredSampling.evalDist_bind_comm sampled reference + (fun root result => pure (root, result)) + change Pr[fun result : Digest × α => + gate result.2 ∧ result.1 = guess result.2 | dependent] ≤ _ + calc + _ = Pr[fun result : Digest × α => + gate result.2 ∧ result.1 = guess result.2 | independent] := by + exact OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) (hreplace.trans hcommute) + _ ≤ Pr[gate | reference] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + unfold independent + apply SphincsSecurity.probEvent_bind_le_gated_mul + · intro result _hresult hnotGate + rw [show (do + let root ← sampled + pure (root, result)) = + (fun root => (root, result)) <$> sampled by + simp [map_eq_bind_pure_comp], probEvent_map] + simp [hnotGate] + · intro result _hresult hgate + have hbound : Pr[fun pair : Digest × α => + gate pair.2 ∧ pair.1 = guess pair.2 | do + let root ← sampled + pure (root, result)] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + rw [show (do + let root ← sampled + pure (root, result)) = + (fun root => (root, result)) <$> sampled by + simp [map_eq_bind_pure_comp], probEvent_map] + change Pr[fun root : Digest => gate result ∧ root = guess result | sampled] ≤ _ + simpa [hgate] using + (show Pr[fun root : Digest => root = guess result | sampled] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ by + rw [probEvent_eq_eq_probOutput, probOutput_uniformSample] + rw [show Fintype.card Digest = 2 ^ digestBits by simp]) + exact hbound + +theorem probEvent_uniform_root_matches_symmetric_two_root_run_le + (run : Digest → Digest → ProbComp α) + (reference : Digest → ProbComp α) + (hright : ∀ leftRoot rightRoot, + evalDist (run leftRoot rightRoot) = evalDist (reference leftRoot)) + (hswap : ∀ leftRoot rightRoot, + evalDist (run leftRoot rightRoot) = evalDist (run rightRoot leftRoot)) + (guess : α → Digest) : + Pr[fun result : Digest × α => result.1 = guess result.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let result ← run leftRoot rightRoot + pure (leftRoot, result)] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let sampled := ($ᵗ Digest : ProbComp Digest) + let outerRun (leftRoot : Digest) : ProbComp α := do + let rightRoot ← sampled + run leftRoot rightRoot + have hreference (leftRoot : Digest) : + evalDist (reference leftRoot) = evalDist (reference (default : Digest)) := by + calc + _ = evalDist (run leftRoot default) := (hright leftRoot default).symm + _ = evalDist (run default leftRoot) := hswap leftRoot default + _ = _ := hright default leftRoot + have houter (leftRoot : Digest) : + evalDist (outerRun leftRoot) = evalDist (reference (default : Digest)) := by + calc + _ = evalDist (sampled >>= fun _ => reference leftRoot) := by + unfold outerRun + apply evalDist_bind_congr + intro rightRoot _hrightRoot + exact hright leftRoot rightRoot + _ = evalDist (reference leftRoot) := + OracleComp.DeferredSampling.evalDist_bind_const_neverFails sampled (by simp [sampled]) + (reference leftRoot) + _ = _ := hreference leftRoot + have hbound := probEvent_uniform_root_matches_distribution_independent_guess_le + outerRun (reference default) houter guess + simpa only [outerRun, sampled, bind_assoc] using hbound + +theorem probEvent_uniform_root_matches_symmetric_two_root_run_le_mul + (run : Digest → Digest → ProbComp α) + (reference : Digest → ProbComp α) + (hright : ∀ leftRoot rightRoot, + evalDist (run leftRoot rightRoot) = evalDist (reference leftRoot)) + (hswap : ∀ leftRoot rightRoot, + evalDist (run leftRoot rightRoot) = evalDist (run rightRoot leftRoot)) + (guess : α → Digest) (gate : α → Prop) : + Pr[fun result : Digest × α => + gate result.2 ∧ result.1 = guess result.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let result ← run leftRoot rightRoot + pure (leftRoot, result)] ≤ + Pr[gate | reference default] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let sampled := ($ᵗ Digest : ProbComp Digest) + let outerRun (leftRoot : Digest) : ProbComp α := do + let rightRoot ← sampled + run leftRoot rightRoot + have hreference (leftRoot : Digest) : + evalDist (reference leftRoot) = evalDist (reference (default : Digest)) := by + calc + _ = evalDist (run leftRoot default) := (hright leftRoot default).symm + _ = evalDist (run default leftRoot) := hswap leftRoot default + _ = _ := hright default leftRoot + have houter (leftRoot : Digest) : + evalDist (outerRun leftRoot) = evalDist (reference (default : Digest)) := by + calc + _ = evalDist (sampled >>= fun _ => reference leftRoot) := by + unfold outerRun + apply evalDist_bind_congr + intro rightRoot _hrightRoot + exact hright leftRoot rightRoot + _ = evalDist (reference leftRoot) := + OracleComp.DeferredSampling.evalDist_bind_const_neverFails sampled (by simp [sampled]) + (reference leftRoot) + _ = _ := hreference leftRoot + have hbound := probEvent_uniform_root_matches_distribution_independent_guess_le_mul + outerRun (reference default) houter guess gate + simpa only [outerRun, sampled, bind_assoc] using hbound + +theorem probEvent_le_of_uniform_weighted_fibers + {α ι : Type} (run : ProbComp α) (event : α → Prop) (classify : α → ι) + (epsilon : ENNReal) + (hfiber : ∀ index, + Pr[fun output => event output ∧ classify output = index | run] ≤ + Pr[fun output => classify output = index | run] * epsilon) : + Pr[event | run] ≤ epsilon := by + rw [probEvent_eq_tsum_classify_fibers run event classify] + calc + _ ≤ ∑' index, Pr[fun output => classify output = index | run] * epsilon := + ENNReal.tsum_le_tsum hfiber + _ = (∑' index, Pr[fun output => classify output = index | run]) * epsilon := by + rw [ENNReal.tsum_mul_right] + _ = Pr[fun _ : α => True | run] * epsilon := by + congr 1 + rw [probEvent_eq_tsum_classify_fibers run (fun _ : α => True) classify] + simp + _ ≤ epsilon := by + simpa only [one_mul] using mul_le_mul' probEvent_le_one le_rfl + +theorem privateWitnessAtOrdinal_of_firstPrivateWitnessOrdinal?_eq_some + {witness : PrivateHitWitness} {candidates : List Probe} + {ordinal : Fin candidates.length} + (hfirst : firstPrivateWitnessOrdinal? witness candidates = some ordinal) : + PrivateWitnessAtOrdinal witness candidates ordinal := by + classical + let matching := Finset.univ.filter fun selected : Fin candidates.length => + PrivateWitnessAtOrdinal witness candidates selected + have hmatching : matching.Nonempty := by + by_contra hnone + unfold firstPrivateWitnessOrdinal? at hfirst + simp [matching, hnone] at hfirst + unfold firstPrivateWitnessOrdinal? at hfirst + simp only [matching, hmatching, dif_pos, Option.some.injEq] at hfirst + subst ordinal + exact (Finset.mem_filter.mp (matching.min'_mem hmatching)).2 + +theorem earlier_candidate_ne_of_witnessFirstUsesOrdinal + {ordinal : Nat} {output : PrivateWitnessPlanOutput} + (hfirst : WitnessFirstUsesOrdinal ordinal output) + (witness : PrivateHitWitness) (hwitness : output.1 = some witness) + (earlier : Fin output.2.length) (hlt : earlier.val < ordinal) + (target : Position) + (hcoordinate : (output.2.get earlier).coordinate = .position target) + (hposition : witness.position = target) : + (output.2.get earlier).candidate ≠ truncateHash witness.output := by + intro heq + apply not_privateWitnessAtOrdinal_of_witnessFirstUsesOrdinal_of_lt hfirst earlier hlt + witness hwitness + unfold PrivateWitnessAtOrdinal + exact ⟨hcoordinate.trans (congrArg Coordinate.position hposition.symm), heq.symm⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootCache.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootCache.lean new file mode 100644 index 00000000..6cc72794 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootCache.lean @@ -0,0 +1,1550 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootEvent + +/-! +# Hidden layer-root cache quotient + +For one structural layer root, encoding inputs carrying that root are opaque until an outer query +guesses the root. The root-aware probe records exactly that attempt. This module defines the cache +quotient that forgets those opaque ordinary entries and proves its elementary update laws. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def EncodingInputNamesRoot + (parameter : PublicParameter) (target : Position) (input : HashInput) : Prop := + ∃ candidate, + decodeEncodingLayerRootCandidate? parameter input = some candidate ∧ + candidate.coordinate = .position target + +noncomputable instance encodingInputNamesRootDecidable + (parameter : PublicParameter) (target : Position) : + DecidablePred (EncodingInputNamesRoot parameter target) := + Classical.decPred _ + +def RootEncodingKey + (parameter : PublicParameter) (target : Position) : SplitHashKey → Prop + | .ordinary input => EncodingInputNamesRoot parameter target input + | .hidden _ => False + +noncomputable instance rootEncodingKeyDecidable + (parameter : PublicParameter) (target : Position) : + DecidablePred (RootEncodingKey parameter target) := + Classical.decPred _ + +noncomputable def eraseRootEncodingCache + (parameter : PublicParameter) (target : Position) + (cache : SplitHashCache) : SplitHashCache := + fun key => if RootEncodingKey parameter target key then none else cache key + +def RootEncodingCacheEq + (parameter : PublicParameter) (target : Position) + (left right : SplitHashCache) : Prop := + eraseRootEncodingCache parameter target left = + eraseRootEncodingCache parameter target right + +theorem RootEncodingCacheEq.refl + (parameter : PublicParameter) (target : Position) (cache : SplitHashCache) : + RootEncodingCacheEq parameter target cache cache := + rfl + +theorem RootEncodingCacheEq.symm + {parameter : PublicParameter} {target : Position} {left right : SplitHashCache} + (heq : RootEncodingCacheEq parameter target left right) : + RootEncodingCacheEq parameter target right left := + Eq.symm heq + +theorem RootEncodingCacheEq.trans + {parameter : PublicParameter} {target : Position} {left middle right : SplitHashCache} + (hleft : RootEncodingCacheEq parameter target left middle) + (hright : RootEncodingCacheEq parameter target middle right) : + RootEncodingCacheEq parameter target left right := + Eq.trans hleft hright + +theorem RootEncodingCacheEq.lookup_of_not_root + {parameter : PublicParameter} {target : Position} {left right : SplitHashCache} + (heq : RootEncodingCacheEq parameter target left right) + (key : SplitHashKey) (hkey : ¬RootEncodingKey parameter target key) : + left key = right key := by + have hvalue := congrFun heq key + simpa [eraseRootEncodingCache, hkey] using hvalue + +theorem rootEncodingKey_ordinary_iff + (parameter : PublicParameter) (target : Position) (input : HashInput) : + RootEncodingKey parameter target (.ordinary input) ↔ + EncodingInputNamesRoot parameter target input := by + rfl + +theorem not_rootEncodingKey_hidden + (parameter : PublicParameter) (target : Position) (coordinate : Coordinate) : + ¬RootEncodingKey parameter target (.hidden coordinate) := by + simp [RootEncodingKey] + +theorem eraseRootEncodingCache_update_root + (parameter : PublicParameter) (target : Position) + (cache : SplitHashCache) (key : SplitHashKey) (value : Option HashOutput) + (hkey : RootEncodingKey parameter target key) : + eraseRootEncodingCache parameter target (Function.update cache key value) = + eraseRootEncodingCache parameter target cache := by + funext other + by_cases hother : other = key + · subst other + simp [eraseRootEncodingCache, hkey] + · by_cases hotherRoot : RootEncodingKey parameter target other + · simp [eraseRootEncodingCache, hotherRoot] + · simp [eraseRootEncodingCache, hotherRoot, Function.update_of_ne hother] + +theorem RootEncodingCacheEq.update_root_left + {parameter : PublicParameter} {target : Position} {left right : SplitHashCache} + (heq : RootEncodingCacheEq parameter target left right) + (key : SplitHashKey) (value : Option HashOutput) + (hkey : RootEncodingKey parameter target key) : + RootEncodingCacheEq parameter target (Function.update left key value) right := by + unfold RootEncodingCacheEq + rw [eraseRootEncodingCache_update_root parameter target left key value hkey] + exact heq + +theorem RootEncodingCacheEq.update_root_right + {parameter : PublicParameter} {target : Position} {left right : SplitHashCache} + (heq : RootEncodingCacheEq parameter target left right) + (key : SplitHashKey) (value : Option HashOutput) + (hkey : RootEncodingKey parameter target key) : + RootEncodingCacheEq parameter target left (Function.update right key value) := + (heq.symm.update_root_left key value hkey).symm + +theorem eraseRootEncodingCache_update_nonroot + (parameter : PublicParameter) (target : Position) + (cache : SplitHashCache) (key : SplitHashKey) (value : Option HashOutput) + (hkey : ¬RootEncodingKey parameter target key) : + eraseRootEncodingCache parameter target (Function.update cache key value) = + Function.update (eraseRootEncodingCache parameter target cache) key value := by + funext other + by_cases hother : other = key + · subst other + simp [eraseRootEncodingCache, hkey] + · by_cases hotherRoot : RootEncodingKey parameter target other + · simp [eraseRootEncodingCache, hotherRoot, Function.update_of_ne hother] + · simp [eraseRootEncodingCache, hotherRoot, Function.update_of_ne hother] + +theorem RootEncodingCacheEq.update_nonroot + {parameter : PublicParameter} {target : Position} {left right : SplitHashCache} + (heq : RootEncodingCacheEq parameter target left right) + (key : SplitHashKey) (value : Option HashOutput) + (hkey : ¬RootEncodingKey parameter target key) : + RootEncodingCacheEq parameter target + (Function.update left key value) (Function.update right key value) := by + unfold RootEncodingCacheEq at heq ⊢ + rw [eraseRootEncodingCache_update_nonroot parameter target left key value hkey, + eraseRootEncodingCache_update_nonroot parameter target right key value hkey, heq] + +theorem encodingInputNamesRoot_of_decode + {parameter : PublicParameter} {target : Position} {input : HashInput} + {candidate : Probe} + (hdecode : decodeEncodingLayerRootCandidate? parameter input = some candidate) + (hcoordinate : candidate.coordinate = .position target) : + EncodingInputNamesRoot parameter target input := + ⟨candidate, hdecode, hcoordinate⟩ + +theorem rootEncodingKey_of_decode + {parameter : PublicParameter} {target : Position} {input : HashInput} + {candidate : Probe} + (hdecode : decodeEncodingLayerRootCandidate? parameter input = some candidate) + (hcoordinate : candidate.coordinate = .position target) : + RootEncodingKey parameter target (.ordinary input) := + encodingInputNamesRoot_of_decode hdecode hcoordinate + +theorem encodingInputNamesRoot_target_unique + {parameter : PublicParameter} {input : HashInput} {left right : Position} + (hleft : EncodingInputNamesRoot parameter left input) + (hright : EncodingInputNamesRoot parameter right input) : + left = right := by + obtain ⟨leftCandidate, hleftDecode, hleftCoordinate⟩ := hleft + obtain ⟨rightCandidate, hrightDecode, hrightCoordinate⟩ := hright + have hcandidate : leftCandidate = rightCandidate := by + rw [hleftDecode] at hrightDecode + exact Option.some.inj hrightDecode + subst rightCandidate + rw [hleftCoordinate] at hrightCoordinate + exact Coordinate.position.inj hrightCoordinate + +theorem encodingInputNamesRoot_isLayerRoot + {parameter : PublicParameter} {target : Position} {input : HashInput} + (hnames : EncodingInputNamesRoot parameter target input) : + IsLayerRoot target := by + obtain ⟨candidate, hdecode, hcoordinate⟩ := hnames + obtain ⟨position, hcandidateCoordinate, hroot⟩ := + decodeEncodingLayerRootCandidate?_some_isLayerRoot hdecode + rw [hcoordinate] at hcandidateCoordinate + have hposition : target = position := Coordinate.position.inj hcandidateCoordinate + rwa [hposition] + +theorem not_encodingInputNamesRoot_tweakableHashInput_of_not_encoding + (parameter : PublicParameter) (target : Position) (domain : HashDomain) + (payload : HashInput) (hinRange : domain.InRange) + (hnotEncoding : ∀ lay tree leafIdx, domain ≠ .encoding lay tree leafIdx) : + ¬EncodingInputNamesRoot parameter target + (tweakableHashInput parameter domain payload) := by + intro hnames + obtain ⟨candidate, hdecode, _hcoordinate⟩ := hnames + obtain ⟨position, _index, hat, _htree, _hleaf, _hnotBottom, _hcandidate⟩ := + (decodeEncodingLayerRootCandidate?_eq_some_iff parameter _ candidate).mp hdecode + obtain ⟨otherPayload, hinput⟩ := hat + have hdomain := (tweakableHashInput_injective parameter hinRange + (by trivial) hinput).1 + exact hnotEncoding position.lay position.tree position.leafIdx hdomain + +theorem not_encodingInputNamesRoot_of_rootAwareCandidate_ne + {parameter : PublicParameter} {target : Position} {input : HashInput} + {plan : PlannedHashQuery} {candidate : Probe} + (hplan : plan.candidate? = none) + (hrootAware : rootAwareCandidateForPlan? parameter input plan = some candidate) + (hne : candidate.coordinate ≠ .position target) : + ¬EncodingInputNamesRoot parameter target input := by + intro hnames + obtain ⟨other, hdecode, hcoordinate⟩ := hnames + unfold rootAwareCandidateForPlan? at hrootAware + rw [hplan, hdecode] at hrootAware + have hcandidate : candidate = other := Option.some.inj hrootAware.symm + apply hne + rw [hcandidate, hcoordinate] + +def EncodingPositionNamesRoot + (target : Position) (position : EncodingPosition) : Prop := + ∃ index : Index, + treeIndexAt index position.lay = position.tree ∧ + leafIndexAt index position.lay = position.leafIdx ∧ + position.lay ≠ bottomLayer ∧ + target = layerMessagePosition index position.lay + +theorem encodingRetryInput_namesRoot + {parameter : PublicParameter} {target : Position} + {position : EncodingPosition} (hposition : EncodingPositionNamesRoot target position) + (root : Digest) (counter : Nat) : + EncodingInputNamesRoot parameter target + (encodingRetryInput parameter position root counter) := by + obtain ⟨index, htree, hleaf, hnotBottom, htarget⟩ := hposition + let candidate : Probe := ⟨.position target, root⟩ + refine ⟨candidate, ?_, rfl⟩ + rw [decodeEncodingLayerRootCandidate?_eq_some_iff] + refine ⟨position, index, ?_, htree, hleaf, hnotBottom, ?_⟩ + · exact ⟨digestBytes root ++ counterBytes (BitVec.ofNat counterBits counter), rfl⟩ + · subst target + simp [candidate, encodingRetryInput, slotDigest_zero_encodingInput] + +theorem decodeEncodingLayerRootCandidate?_encodingRetryInput + {parameter : PublicParameter} {target : Position} + {position : EncodingPosition} (hposition : EncodingPositionNamesRoot target position) + (root : Digest) (counter : Nat) : + decodeEncodingLayerRootCandidate? parameter + (encodingRetryInput parameter position root counter) = + some ⟨.position target, root⟩ := by + rw [decodeEncodingLayerRootCandidate?_eq_some_iff] + obtain ⟨index, htree, hleaf, hnotBottom, htarget⟩ := hposition + refine ⟨position, index, ?_, htree, hleaf, hnotBottom, ?_⟩ + · exact ⟨digestBytes root ++ counterBytes (BitVec.ofNat counterBits counter), rfl⟩ + · subst target + simp [encodingRetryInput, slotDigest_zero_encodingInput] + +def EncodingInputGuessesRoot + (parameter : PublicParameter) (target : Position) + (guess : Digest) (input : HashInput) : Prop := + decodeEncodingLayerRootCandidate? parameter input = + some ⟨.position target, guess⟩ + +theorem guess_eq_of_encodingRetryInput_eq + {parameter : PublicParameter} {target : Position} + {position : EncodingPosition} (hposition : EncodingPositionNamesRoot target position) + {root guess : Digest} {counter : Nat} {input : HashInput} + (hinput : input = encodingRetryInput parameter position root counter) + (hguess : EncodingInputGuessesRoot parameter target guess input) : + guess = root := by + unfold EncodingInputGuessesRoot at hguess + rw [hinput, decodeEncodingLayerRootCandidate?_encodingRetryInput hposition root counter] + at hguess + exact congrArg Probe.candidate (Option.some.inj hguess.symm) + +theorem not_encodingInputNamesRoot_encodingRetryInput_of_not_positionNames + {parameter : PublicParameter} {target : Position} + {position : EncodingPosition} + (hnotPosition : ¬EncodingPositionNamesRoot target position) + (message : Digest) (counter : Nat) : + ¬EncodingInputNamesRoot parameter target + (encodingRetryInput parameter position message counter) := by + intro hnames + obtain ⟨candidate, hdecode, hcoordinate⟩ := hnames + obtain ⟨queriedPosition, index, hat, htree, hleaf, hnotBottom, hcandidate⟩ := + (decodeEncodingLayerRootCandidate?_eq_some_iff parameter _ candidate).mp hdecode + have hcurrentAt : AtEncodingPosition parameter + (encodingRetryInput parameter position message counter) position := by + exact ⟨digestBytes message ++ counterBytes (BitVec.ofNat counterBits counter), rfl⟩ + have hposition : queriedPosition = position := atEncodingPosition_unique hat hcurrentAt + subst queriedPosition + apply hnotPosition + refine ⟨index, htree, hleaf, hnotBottom, ?_⟩ + subst candidate + simp only at hcoordinate + exact Coordinate.position.inj hcoordinate.symm + +structure RootEncodingCacheRel + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (left right : SplitHashCache) : Prop where + nonroot : ∀ input, ¬EncodingInputNamesRoot parameter target input → + left (.ordinary input) = right (.ordinary input) + retry : ∀ position counter, EncodingPositionNamesRoot target position → + left (.ordinary (encodingRetryInput parameter position leftRoot counter)) = + right (.ordinary (encodingRetryInput parameter position rightRoot counter)) + hidden : ∀ coordinate, left (.hidden coordinate) = right (.hidden coordinate) + wrong : ∀ input guess, EncodingInputGuessesRoot parameter target guess input → + guess ≠ leftRoot → guess ≠ rightRoot → + left (.ordinary input) = right (.ordinary input) + +theorem RootEncodingCacheRel.refl + (parameter : PublicParameter) (target : Position) (root : Digest) + (cache : SplitHashCache) : + RootEncodingCacheRel parameter target root root cache cache := by + exact ⟨fun _ _ => rfl, fun _ _ _ => rfl, fun _ => rfl, fun _ _ _ _ _ => rfl⟩ + +theorem RootEncodingCacheRel.symm + {parameter : PublicParameter} {target : Position} {leftRoot rightRoot : Digest} + {left right : SplitHashCache} + (hrel : RootEncodingCacheRel parameter target leftRoot rightRoot left right) : + RootEncodingCacheRel parameter target rightRoot leftRoot right left := by + refine ⟨?_, ?_, ?_, ?_⟩ + · intro input hinput + exact (hrel.nonroot input hinput).symm + · intro position counter hposition + exact (hrel.retry position counter hposition).symm + · intro coordinate + exact (hrel.hidden coordinate).symm + · intro input guess hguess hright hleft + exact (hrel.wrong input guess hguess hleft hright).symm + +theorem RootEncodingCacheRel.lookup_nonroot + {parameter : PublicParameter} {target : Position} {leftRoot rightRoot : Digest} + {left right : SplitHashCache} + (hrel : RootEncodingCacheRel parameter target leftRoot rightRoot left right) + (key : SplitHashKey) (hkey : ¬RootEncodingKey parameter target key) : + left key = right key := by + cases key with + | ordinary input => exact hrel.nonroot input hkey + | hidden coordinate => exact hrel.hidden coordinate + +theorem encodingRetryInput_corresponding_eq + {parameter : PublicParameter} {leftRoot rightRoot : Digest} + {leftPosition rightPosition : EncodingPosition} {leftCounter rightCounter : Nat} + (heq : encodingRetryInput parameter leftPosition leftRoot leftCounter = + encodingRetryInput parameter rightPosition leftRoot rightCounter) : + encodingRetryInput parameter leftPosition rightRoot leftCounter = + encodingRetryInput parameter rightPosition rightRoot rightCounter := by + unfold encodingRetryInput at heq ⊢ + have hparts := tweakableHashInput_injective parameter (by trivial) (by trivial) heq + have hposition : leftPosition = rightPosition := by + obtain ⟨leftLay, leftTree, leftLeaf⟩ := leftPosition + obtain ⟨rightLay, rightTree, rightLeaf⟩ := rightPosition + simp only [EncodingPosition.domain, HashDomain.encoding.injEq] at hparts + obtain ⟨rfl, rfl, rfl⟩ := hparts.1 + rfl + subst rightPosition + have hcounter : counterBytes (BitVec.ofNat counterBits leftCounter) = + counterBytes (BitVec.ofNat counterBits rightCounter) := by + obtain ⟨_hroot, hcounter⟩ := List.append_inj hparts.2 + (by simp [digestBytes_length]) + exact hcounter + rw [hcounter] + +theorem RootEncodingCacheRel.update_retry + {parameter : PublicParameter} {target : Position} {leftRoot rightRoot : Digest} + {left right : SplitHashCache} + (hrel : RootEncodingCacheRel parameter target leftRoot rightRoot left right) + (position : EncodingPosition) (counter : Nat) + (hposition : EncodingPositionNamesRoot target position) + (output : HashOutput) : + RootEncodingCacheRel parameter target leftRoot rightRoot + (Function.update left + (.ordinary (encodingRetryInput parameter position leftRoot counter)) (some output)) + (Function.update right + (.ordinary (encodingRetryInput parameter position rightRoot counter)) (some output)) := by + refine ⟨?_, ?_, ?_, ?_⟩ + · intro input hinput + have hleftNe : SplitHashKey.ordinary input ≠ + .ordinary (encodingRetryInput parameter position leftRoot counter) := by + intro heq + apply hinput + have hinputEq := SplitHashKey.ordinary.inj heq + rw [hinputEq] + exact encodingRetryInput_namesRoot (parameter := parameter) hposition leftRoot counter + have hrightNe : SplitHashKey.ordinary input ≠ + .ordinary (encodingRetryInput parameter position rightRoot counter) := by + intro heq + apply hinput + have hinputEq := SplitHashKey.ordinary.inj heq + rw [hinputEq] + exact encodingRetryInput_namesRoot (parameter := parameter) hposition rightRoot counter + simp [Function.update_of_ne hleftNe, Function.update_of_ne hrightNe, + hrel.nonroot input hinput] + · intro otherPosition otherCounter hotherPosition + let leftInput := encodingRetryInput parameter otherPosition leftRoot otherCounter + let rightInput := encodingRetryInput parameter otherPosition rightRoot otherCounter + let updatedLeft := encodingRetryInput parameter position leftRoot counter + let updatedRight := encodingRetryInput parameter position rightRoot counter + by_cases heq : leftInput = updatedLeft + · have hrightEq : rightInput = updatedRight := + encodingRetryInput_corresponding_eq heq + simp [leftInput, rightInput, updatedLeft, updatedRight, heq, hrightEq] + · have hrightNe : rightInput ≠ updatedRight := by + intro hrightEq + have := encodingRetryInput_corresponding_eq + (leftRoot := rightRoot) (rightRoot := leftRoot) hrightEq + exact heq this + have hold := hrel.retry otherPosition otherCounter hotherPosition + simp [leftInput, rightInput, updatedLeft, updatedRight, + Function.update_of_ne, heq, hrightNe, hold] + · intro coordinate + simpa using hrel.hidden coordinate + · intro input guess hguess hleft hright + have hleftNe : SplitHashKey.ordinary input ≠ + .ordinary (encodingRetryInput parameter position leftRoot counter) := by + intro heq + have hinput := SplitHashKey.ordinary.inj heq + exact hleft (guess_eq_of_encodingRetryInput_eq hposition hinput hguess) + have hrightNe : SplitHashKey.ordinary input ≠ + .ordinary (encodingRetryInput parameter position rightRoot counter) := by + intro heq + have hinput := SplitHashKey.ordinary.inj heq + exact hright (guess_eq_of_encodingRetryInput_eq hposition hinput hguess) + simp [Function.update_of_ne hleftNe, Function.update_of_ne hrightNe, + hrel.wrong input guess hguess hleft hright] + +theorem RootEncodingCacheRel.update_same_nonroot + {parameter : PublicParameter} {target : Position} {leftRoot rightRoot : Digest} + {left right : SplitHashCache} + (hrel : RootEncodingCacheRel parameter target leftRoot rightRoot left right) + (key : SplitHashKey) (output : HashOutput) + (hkey : ¬RootEncodingKey parameter target key) : + RootEncodingCacheRel parameter target leftRoot rightRoot + (Function.update left key (some output)) + (Function.update right key (some output)) := by + refine ⟨?_, ?_, ?_, ?_⟩ + · intro input hinput + by_cases heq : SplitHashKey.ordinary input = key + · simp [heq] + · simp [Function.update_of_ne heq, hrel.nonroot input hinput] + · intro position counter hposition + have hleftRoot : RootEncodingKey parameter target + (.ordinary (encodingRetryInput parameter position leftRoot counter)) := + encodingRetryInput_namesRoot (parameter := parameter) hposition leftRoot counter + have hrightRoot : RootEncodingKey parameter target + (.ordinary (encodingRetryInput parameter position rightRoot counter)) := + encodingRetryInput_namesRoot (parameter := parameter) hposition rightRoot counter + have hleftNe : SplitHashKey.ordinary + (encodingRetryInput parameter position leftRoot counter) ≠ key := by + intro heq + exact hkey (heq ▸ hleftRoot) + have hrightNe : SplitHashKey.ordinary + (encodingRetryInput parameter position rightRoot counter) ≠ key := by + intro heq + exact hkey (heq ▸ hrightRoot) + simp [Function.update_of_ne hleftNe, Function.update_of_ne hrightNe, + hrel.retry position counter hposition] + · intro coordinate + by_cases heq : SplitHashKey.hidden coordinate = key + · simp [heq] + · simp [Function.update_of_ne heq, hrel.hidden coordinate] + · intro input guess hguess hleft hright + by_cases heq : SplitHashKey.ordinary input = key + · simp [heq] + · simp [Function.update_of_ne heq, hrel.wrong input guess hguess hleft hright] + +def RootEncodingCleanSameRel + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) : + Option (CleanRunResult (α × SplitHashCache)) → + Option (CleanRunResult (α × SplitHashCache)) → Prop + | some left, some right => + left.state = right.state ∧ left.remaining = right.remaining ∧ + left.table = right.table ∧ left.value.1 = right.value.1 ∧ + RootEncodingCacheRel parameter target leftRoot rightRoot left.value.2 right.value.2 + | none, none => True + | _, _ => False + +def RootEncodingCacheCouples + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftCache rightCache, + RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache → + ∀ state fuel table, + RelTriple + (runCleanFromTable state fuel table (computation.run leftCache)) + (runCleanFromTable state fuel table (computation.run rightCache)) + (RootEncodingCleanSameRel parameter target leftRoot rightRoot) + +def RootEncodingCacheRelates + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftCache rightCache, + RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache → + ∀ state fuel table, + RelTriple + (runCleanFromTable state fuel table (left.run leftCache)) + (runCleanFromTable state fuel table (right.run rightCache)) + (RootEncodingCleanSameRel parameter target leftRoot rightRoot) + +theorem RootEncodingCacheCouples.relates + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + (hcouples : RootEncodingCacheCouples parameter target leftRoot rightRoot computation) : + RootEncodingCacheRelates parameter target leftRoot rightRoot computation computation := + hcouples + +theorem rootEncodingCacheCouples_pure + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (value : α) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := by + intro leftCache rightCache hcache state fuel table + simp only [StateT.run_pure, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem rootEncodingCacheCouples_ensureCoordinate + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (coordinate : Coordinate) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (ensureCoordinate coordinate) := by + intro leftCache rightCache hcache state fuel table + rw [runCleanFromTable_ensureCoordinate, runCleanFromTable_ensureCoordinate] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem peekCoordinate_run_eq + (coordinate : Coordinate) (cache : SplitHashCache) : + (peekCoordinate coordinate).run cache = (do + let output ← LazyRevealProbe.peekQuery coordinate + pure (truncateHash <$> output, cache)) := by + simp [peekCoordinate] + +theorem rootEncodingCacheCouples_peekCoordinate + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (coordinate : Coordinate) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (peekCoordinate coordinate) := by + intro leftCache rightCache hcache state fuel table + rw [peekCoordinate_run_eq, peekCoordinate_run_eq, LazyRevealProbe.peekQuery, + runCleanFromTable_peek_query_bind, runCleanFromTable_peek_query_bind] + simp only [runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem rootEncodingCacheCouples_probe + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (candidate : Probe) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (probe candidate) := by + intro leftCache rightCache hcache state fuel table + unfold probe LazyRevealProbe.probeQuery + rw [StateT.run_liftM, StateT.run_liftM, + runCleanFromTable_probe_query_bind, runCleanFromTable_probe_query_bind] + cases fuel with + | zero => exact relTriple_pure_pure trivial + | succ remaining => + by_cases hrevealed : candidate.coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + · simp only [hrevealed, ↓reduceIte, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem RootEncodingCacheCouples.bind + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : RootEncodingCacheCouples parameter target leftRoot rightRoot left) + (hnext : ∀ value, + RootEncodingCacheCouples parameter target leftRoot rightRoot (next value)) : + RootEncodingCacheCouples parameter target leftRoot rightRoot (left >>= next) := by + intro leftCache rightCache hcache state fuel table + rw [StateT.run_bind, StateT.run_bind, runCleanFromTable_bind, + runCleanFromTable_bind] + apply relTriple_bind (hleft leftCache rightCache hcache state fuel table) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [RootEncodingCleanSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootEncodingCleanSameRel] at hresult + | some rightResult => + rcases hresult with ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + simp only + rw [← hstate, ← hremaining, ← htable, ← hvalue] + exact hnext leftResult.value.1 leftResult.value.2 rightResult.value.2 hnextCache + leftResult.state leftResult.remaining leftResult.table + +theorem rootEncodingCacheCouples_peekPositionValues + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) : ∀ positions, + RootEncodingCacheCouples parameter target leftRoot rightRoot + (peekPositionValues positions) + | [] => by + rw [peekPositionValues] + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot (some []) + | position :: remaining => by + rw [peekPositionValues] + apply (rootEncodingCacheCouples_peekCoordinate parameter target leftRoot rightRoot + (.position position)).bind + intro value + cases value with + | none => exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot none + | some value => + apply (rootEncodingCacheCouples_peekPositionValues parameter target leftRoot rightRoot + remaining).bind + intro values + cases values with + | none => exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot none + | some values => + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (some (value :: values)) + +theorem rootEncodingCacheCouples_peekTableInput + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (coordinate : Coordinate) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (peekTableInput parameter coordinate) := by + cases coordinate with + | chainStart => + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot none + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput] + by_cases hzero : step.val = 0 + · rw [if_pos hzero] + exact (rootEncodingCacheCouples_peekCoordinate parameter target leftRoot rightRoot + (.chainStart lay tree leafIdx chainIdx)).bind fun value => + match value with + | none => rootEncodingCacheCouples_pure parameter target leftRoot rightRoot none + | some _ => rootEncodingCacheCouples_pure parameter target leftRoot rightRoot _ + · rw [if_neg hzero] + exact (rootEncodingCacheCouples_peekPositionValues parameter target leftRoot rightRoot + (Position.chain lay tree leafIdx chainIdx step).children).bind fun values => + match values with + | none => rootEncodingCacheCouples_pure parameter target leftRoot rightRoot none + | some _ => rootEncodingCacheCouples_pure parameter target leftRoot rightRoot _ + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp only [peekTableInput] + exact (rootEncodingCacheCouples_peekPositionValues parameter target leftRoot rightRoot + _).bind fun values => + match values with + | none => rootEncodingCacheCouples_pure parameter target leftRoot rightRoot none + | some _ => rootEncodingCacheCouples_pure parameter target leftRoot rightRoot _ + +theorem RootEncodingCacheRelates.bind + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {leftNext rightNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hfirst : RootEncodingCacheRelates parameter target leftRoot rightRoot left right) + (hnext : ∀ leftValue rightValue, leftValue = rightValue → + RootEncodingCacheRelates parameter target leftRoot rightRoot + (leftNext leftValue) (rightNext rightValue)) : + RootEncodingCacheRelates parameter target leftRoot rightRoot + (left >>= leftNext) (right >>= rightNext) := by + intro leftCache rightCache hcache state fuel table + rw [StateT.run_bind, StateT.run_bind, runCleanFromTable_bind, + runCleanFromTable_bind] + apply relTriple_bind (hfirst leftCache rightCache hcache state fuel table) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [RootEncodingCleanSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootEncodingCleanSameRel] at hresult + | some rightResult => + rcases hresult with ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + simp only + rw [← hstate, ← hremaining, ← htable, ← hvalue] + exact hnext leftResult.value.1 leftResult.value.1 rfl + leftResult.value.2 rightResult.value.2 hnextCache + leftResult.state leftResult.remaining leftResult.table + +theorem rootEncodingCacheCouples_sequenceFin + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, + RootEncodingCacheCouples parameter target leftRoot rightRoot (computation index)) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (sequenceFin computation) := by + induction n with + | zero => + simp only [sequenceFin] + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomponent 0).bind fun _ => + (ih (fun index : Fin n => computation index.succ) + (fun index => hcomponent index.succ)).bind fun _ => + rootEncodingCacheCouples_pure parameter target leftRoot rightRoot _ + +theorem rootEncodingCacheRelates_sequenceFin + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) {n : Nat} + (left right : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, + RootEncodingCacheRelates parameter target leftRoot rightRoot + (left index) (right index)) : + RootEncodingCacheRelates parameter target leftRoot rightRoot + (sequenceFin left) (sequenceFin right) := by + induction n with + | zero => + simp only [sequenceFin] + exact (rootEncodingCacheCouples_pure parameter target leftRoot rightRoot Fin.elim0).relates + | succ n ih => + rw [sequenceFin, sequenceFin] + exact (hcomponent 0).bind fun leftHead rightHead hhead => + (ih (fun index : Fin n => left index.succ) (fun index : Fin n => right index.succ) + (fun index => hcomponent index.succ)).bind fun leftTail rightTail htail => by + subst rightHead + subst rightTail + exact (rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (Fin.cases leftHead leftTail : Fin (n + 1) → α)).relates + +theorem rootEncodingCacheCouples_ensureChainPrefix + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (rootEncodingCacheCouples_sequenceFin parameter target leftRoot rightRoot _ + fun step => by + by_cases hstep : step.val < digit.val + · rw [if_pos hstep] + exact rootEncodingCacheCouples_ensureCoordinate parameter target leftRoot rightRoot _ + · rw [if_neg hstep] + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot ()).bind fun _ => + rootEncodingCacheCouples_pure parameter target leftRoot rightRoot () + +theorem rootEncodingCacheCouples_ensureFullChain + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (rootEncodingCacheCouples_sequenceFin parameter target leftRoot rightRoot _ + fun step => rootEncodingCacheCouples_ensureCoordinate parameter target leftRoot rightRoot + (.position (.chain lay tree leafIdx chainIdx step))).bind fun _ => + rootEncodingCacheCouples_pure parameter target leftRoot rightRoot () + +theorem rootEncodingCacheCouples_ensureOtsLeaf + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (rootEncodingCacheCouples_sequenceFin parameter target leftRoot rightRoot _ + fun chainIdx => rootEncodingCacheCouples_ensureFullChain parameter target leftRoot rightRoot + lay tree leafIdx chainIdx).bind fun _ => + rootEncodingCacheCouples_ensureCoordinate parameter target leftRoot rightRoot + (.position (.leaf lay tree leafIdx)) + +theorem rootEncodingCacheCouples_ensureTreeNode + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, + RootEncodingCacheCouples parameter target leftRoot rightRoot + (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => by + rw [ensureTreeNode] + exact rootEncodingCacheCouples_ensureOtsLeaf parameter target leftRoot rightRoot lay tree + (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (rootEncodingCacheCouples_ensureTreeNode parameter target leftRoot rightRoot lay tree + level (2 * nodeIdx)).bind fun _ => + (rootEncodingCacheCouples_ensureTreeNode parameter target leftRoot rightRoot lay tree + level (2 * nodeIdx + 1)).bind fun _ => by + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact rootEncodingCacheCouples_ensureCoordinate parameter target leftRoot + rightRoot (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot () + +theorem rootEncodingCacheCouples_ensureTreePath + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (rootEncodingCacheCouples_sequenceFin parameter target leftRoot rightRoot _ + fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + exact rootEncodingCacheCouples_ensureTreeNode parameter target leftRoot rightRoot lay tree + level.val (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · rw [if_neg hlevel] + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot ()).bind fun _ => + rootEncodingCacheCouples_pure parameter target leftRoot rightRoot () + +def RootEncodingCleanQueryRel + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) : + Option (CleanRunResult (HashOutput × SplitHashCache)) → + Option (CleanRunResult (HashOutput × SplitHashCache)) → Prop := + RootEncodingCleanSameRel parameter target leftRoot rightRoot + +theorem relTriple_splitHashQuery_same_nonroot + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (key : SplitHashKey) + (hkey : ¬RootEncodingKey parameter target key) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + RelTriple + (runCleanFromTable state fuel table ((splitHashQuery key).run leftCache)) + (runCleanFromTable state fuel table ((splitHashQuery key).run rightCache)) + (RootEncodingCleanSameRel parameter target leftRoot rightRoot) := by + have hlookup := hcache.lookup_nonroot key hkey + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + cases hleft : leftCache key with + | some output => + have hright : rightCache key = some output := by + rw [← hlookup] + exact hleft + simp only [hright, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + | none => + have hright : rightCache key = none := by + rw [← hlookup] + exact hleft + simp only [hright] + unfold LazyRevealProbe.hashOutputQuery + rw [runCleanFromTable_hashOutput_query_bind, + runCleanFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_nonroot key leftOutput hkey⟩ + +theorem rootEncodingCacheCouples_splitHashQuery_same_nonroot + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (key : SplitHashKey) + (hkey : ¬RootEncodingKey parameter target key) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (splitHashQuery key) := by + intro leftCache rightCache hcache state fuel table + exact relTriple_splitHashQuery_same_nonroot parameter target leftRoot rightRoot key hkey + leftCache rightCache hcache state fuel table + +theorem rootEncodingCacheCouples_splitUniformImpl + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (n : Nat) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (splitUniformImpl n) := by + intro leftCache rightCache hcache state fuel table + unfold splitUniformImpl LazyRevealProbe.uniformQuery + rw [StateT.run_liftM, StateT.run_liftM, + runCleanFromTable_uniform_query_bind, runCleanFromTable_uniform_query_bind] + apply relTriple_bind + (relTriple_refl (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem rootEncodingCacheCouples_simulateQ_splitUniformImpl + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (computation : ProbComp α) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (simulateQ splitUniformImpl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + rw [simulateQ_pure] + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot value + | query_bind n next ih => + rw [simulateQ_query_bind] + exact (rootEncodingCacheCouples_splitUniformImpl parameter target leftRoot rightRoot n).bind + fun output => ih output + +theorem rootEncodingCacheCouples_messageDigest + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (publicRoot : Digest) + (message : Message) (randomness : Randomness) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl + (messageDigest parameter publicRoot message randomness)) := by + unfold messageDigest oracleHash + simp only [simulateQ_bind, HasQuery.instOfMonadLift_query, simulateQ_spec_query, + simulateQ_pure, ordinaryHashImpl] + exact (rootEncodingCacheCouples_splitHashQuery_same_nonroot parameter target leftRoot + rightRoot (.ordinary (tweakableHashInput parameter .message + (messageDigestPayload publicRoot message randomness))) + (not_encodingInputNamesRoot_tweakableHashInput_of_not_encoding parameter target .message + _ (by trivial) (by simp))).bind fun output => + rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (truncateMessageDigest output) + +theorem rootEncodingCacheCouples_signAttempt + (target : Position) (leftRoot rightRoot : Digest) + (secretKey : SecretKey) (message : Message) (randomness : Randomness) : + RootEncodingCacheCouples secretKey.parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl (signAttempt secretKey message randomness)) := by + unfold signAttempt + simp only [simulateQ_bind] + exact (rootEncodingCacheCouples_messageDigest secretKey.parameter target leftRoot rightRoot + secretKey.root message randomness).bind fun digest => by + split <;> exact rootEncodingCacheCouples_pure secretKey.parameter target leftRoot rightRoot _ + +theorem rootEncodingCacheCouples_signDigestLoop + (target : Position) (leftRoot rightRoot : Digest) + (secretKey : SecretKey) (message : Message) : ∀ attempts, + RootEncodingCacheCouples secretKey.parameter target leftRoot rightRoot + (simulateQ ordinaryRomImpl (signDigestLoop attempts secretKey message)) + | 0 => by + rw [signDigestLoop, simulateQ_pure] + exact rootEncodingCacheCouples_pure secretKey.parameter target leftRoot rightRoot none + | attempts + 1 => by + rw [signDigestLoop, simulateQ_bind] + have hrandomness : RootEncodingCacheCouples secretKey.parameter target leftRoot rightRoot + (simulateQ ordinaryRomImpl (liftM sampleRandomness)) := by + rw [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_left] + exact rootEncodingCacheCouples_simulateQ_splitUniformImpl secretKey.parameter target + leftRoot rightRoot sampleRandomness + exact hrandomness.bind fun randomness => by + rw [simulateQ_bind] + have hattempt : RootEncodingCacheCouples secretKey.parameter target leftRoot rightRoot + (simulateQ ordinaryRomImpl + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))))) := by + rw [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_right] + exact rootEncodingCacheCouples_signAttempt target leftRoot rightRoot secretKey message + randomness + exact hattempt.bind fun attempt => by + cases attempt with + | none => + exact rootEncodingCacheCouples_signDigestLoop target leftRoot rightRoot secretKey + message attempts + | some selected => + rw [simulateQ_pure] + exact rootEncodingCacheCouples_pure secretKey.parameter target leftRoot rightRoot + (some (randomness, selected.1, selected.2)) + +theorem rootEncodingCacheCouples_tweakableHash_of_not_encoding + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (domain : HashDomain) (payload : HashInput) + (hinRange : domain.InRange) + (hnotEncoding : ∀ lay tree leafIdx, domain ≠ .encoding lay tree leafIdx) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl (tweakableHash parameter domain payload)) := by + unfold tweakableHash oracleHash + simp only [simulateQ_bind, HasQuery.instOfMonadLift_query, simulateQ_spec_query, + simulateQ_pure] + exact (rootEncodingCacheCouples_splitHashQuery_same_nonroot parameter target leftRoot + rightRoot (.ordinary (tweakableHashInput parameter domain payload)) + (not_encodingInputNamesRoot_tweakableHashInput_of_not_encoding parameter target domain + payload hinRange hnotEncoding)).bind fun _ => + rootEncodingCacheCouples_pure parameter target leftRoot rightRoot _ + +theorem rootEncodingCacheCouples_ftsLeafHash + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) (tree : FtsTree) + (leafIdx : FtsLeaf) (secret : Digest) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl + (ftsLeafHash parameter index tree leafIdx secret)) := by + unfold ftsLeafHash + exact rootEncodingCacheCouples_tweakableHash_of_not_encoding parameter target leftRoot + rightRoot (.ftsLeaf index tree leafIdx) (digestBytes secret) (by trivial) (by simp) + +theorem rootEncodingCacheCouples_ftsNode + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) (tree : FtsTree) + (secret : FtsLeaf → Digest) : ∀ level nodeIdx, + level ≤ ftsTreeHeight → + 2 ^ level * (nodeIdx + 1) ≤ 2 ^ ftsTreeHeight → + RootEncodingCacheCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl + (ftsNode parameter index tree secret level nodeIdx)) + | 0, nodeIdx, _hlevel, _hspan => by + rw [ftsNode_zero_eq] + exact rootEncodingCacheCouples_ftsLeafHash parameter target leftRoot rightRoot index tree + (ftsLeafOfNat nodeIdx) (secret (ftsLeafOfNat nodeIdx)) + | level + 1, nodeIdx, hlevel, hspan => by + rw [ftsNode_succ_eq] + simp only [simulateQ_bind] + have hleftSpan : 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ ftsTreeHeight := by + rw [pow_succ] at hspan + calc + 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ level * (2 * (nodeIdx + 1)) := + Nat.mul_le_mul_left _ (by omega) + _ = 2 ^ level * 2 * (nodeIdx + 1) := by ring + _ ≤ 2 ^ ftsTreeHeight := hspan + have hrightSpan : 2 ^ level * (2 * nodeIdx + 1 + 1) ≤ 2 ^ ftsTreeHeight := by + rw [pow_succ] at hspan + calc + 2 ^ level * (2 * nodeIdx + 1 + 1) = 2 ^ level * 2 * (nodeIdx + 1) := by ring + _ ≤ 2 ^ ftsTreeHeight := hspan + have hinRange : (HashDomain.ftsNode index tree (level + 1) nodeIdx).InRange := by + show level + 1 < 2 ^ 32 ∧ nodeIdx < 2 ^ 32 + constructor + · have : ftsTreeHeight < 2 ^ 32 := by norm_num [ftsTreeHeight] + omega + · have hnode : nodeIdx < 2 ^ ftsTreeHeight := by + have hpow : 0 < 2 ^ (level + 1) := Nat.two_pow_pos _ + nlinarith + have : 2 ^ ftsTreeHeight ≤ 2 ^ 32 := Nat.pow_le_pow_right (by omega) (by + norm_num [ftsTreeHeight]) + omega + exact (rootEncodingCacheCouples_ftsNode parameter target leftRoot rightRoot index tree + secret level (2 * nodeIdx) (by omega) hleftSpan).bind fun left => + (rootEncodingCacheCouples_ftsNode parameter target leftRoot rightRoot index tree + secret level (2 * nodeIdx + 1) (by omega) hrightSpan).bind fun right => + rootEncodingCacheCouples_tweakableHash_of_not_encoding parameter target leftRoot + rightRoot (.ftsNode index tree (level + 1) nodeIdx) (nodePayload left right) + hinRange (by simp) + +theorem rootEncodingCacheCouples_ftsKey + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) + (secret : FtsTree → FtsLeaf → Digest) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl (ftsKey parameter index secret)) := by + unfold ftsKey + rw [simulateQ_bind, simulateQ_ordinaryHashImpl_sequenceFin] + exact (rootEncodingCacheCouples_sequenceFin parameter target leftRoot rightRoot _ + fun tree => rootEncodingCacheCouples_ftsNode parameter target leftRoot rightRoot index tree + (secret tree) ftsTreeHeight 0 le_rfl (by simp)).bind fun roots => + rootEncodingCacheCouples_tweakableHash_of_not_encoding parameter target leftRoot + rightRoot (.ftsRoots index) (ftsRootsPayload roots) (by trivial) (by simp) + +theorem rootEncodingCacheCouples_ftsOpen + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) + (leaves : DigestTree → FtsLeaf) + (secret : FtsTree → FtsLeaf → Digest) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl (ftsOpen parameter index leaves secret)) := by + unfold ftsOpen + rw [simulateQ_ordinaryHashImpl_sequenceFin] + apply rootEncodingCacheCouples_sequenceFin + intro tree + rw [simulateQ_ordinaryHashImpl_sequenceFin] + apply rootEncodingCacheCouples_sequenceFin + intro level + exact rootEncodingCacheCouples_ftsNode parameter target leftRoot rightRoot index tree + (secret tree) level.val (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1) + (Nat.le_of_lt level.isLt) + (FtsProbeSimulation.ftsOpen_node_bound (leaves (ftsIndexOf tree)) level) + +theorem revealCoordinateOutput_run_eq + (coordinate : Coordinate) (cache : SplitHashCache) : + (revealCoordinateOutput coordinate).run cache = (do + let output ← LazyRevealProbe.revealQuery coordinate + pure (output, Function.update cache (.hidden coordinate) (some output))) := by + simp [revealCoordinateOutput, StateT.run_modify] + +theorem rootEncodingCacheCouples_revealCoordinateOutput + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (coordinate : Coordinate) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (revealCoordinateOutput coordinate) := by + intro leftCache rightCache hcache state fuel table + rw [revealCoordinateOutput_run_eq, revealCoordinateOutput_run_eq, + LazyRevealProbe.revealQuery, runCleanFromTable_reveal_query_bind, + runCleanFromTable_reveal_query_bind] + have hhidden : ¬RootEncodingKey parameter target (.hidden coordinate) := + not_rootEncodingKey_hidden parameter target coordinate + cases hvalue : state.values coordinate with + | some output => + simp only [runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_nonroot (.hidden coordinate) output hhidden⟩ + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + by_cases hhit : state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) + · simp [hhit, RootEncodingCleanSameRel] + · simp only [hhit, ↓reduceIte, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_nonroot + (.hidden (.chainStart lay tree leafIdx chainIdx)) + (table ⟨lay, tree, leafIdx, chainIdx⟩) hhidden⟩ + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + by_cases hhit : state.hitAt (.position position) leftOutput + · simp [hhit, RootEncodingCleanSameRel] + · simp only [hhit, ↓reduceIte, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_nonroot (.hidden (.position position)) leftOutput hhidden⟩ + +theorem rootEncodingCacheCouples_revealCoordinate + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (coordinate : Coordinate) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (revealCoordinate coordinate) := by + intro leftCache rightCache hcache state fuel table + rw [revealCoordinate_run, revealCoordinate_run, LazyRevealProbe.revealQuery, + runCleanFromTable_reveal_query_bind, runCleanFromTable_reveal_query_bind] + have hhidden : ¬RootEncodingKey parameter target (.hidden coordinate) := + not_rootEncodingKey_hidden parameter target coordinate + cases hvalue : state.values coordinate with + | some output => + simp only [runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_nonroot (.hidden coordinate) output hhidden⟩ + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + by_cases hhit : state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) + · simp [hhit, RootEncodingCleanSameRel] + · simp only [hhit, ↓reduceIte, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_nonroot + (.hidden (.chainStart lay tree leafIdx chainIdx)) + (table ⟨lay, tree, leafIdx, chainIdx⟩) hhidden⟩ + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + by_cases hhit : state.hitAt (.position position) leftOutput + · simp [hhit, RootEncodingCleanSameRel] + · simp only [hhit, ↓reduceIte, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_nonroot (.hidden (.position position)) leftOutput hhidden⟩ + +theorem rootEncodingCacheCouples_revealPosition + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (position : Position) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (revealPosition position) := + rootEncodingCacheCouples_revealCoordinate parameter target leftRoot rightRoot + (.position position) + +theorem rootEncodingCacheCouples_publishCoordinate + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (coordinate : Coordinate) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (publishCoordinate coordinate) := by + intro leftCache rightCache hcache state fuel table + rw [runCleanFromTable_publishCoordinate, runCleanFromTable_publishCoordinate] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem rootEncodingCacheCouples_revealPublishedCoordinate + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (coordinate : Coordinate) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + exact (rootEncodingCacheCouples_revealCoordinate parameter target leftRoot rightRoot + coordinate).bind fun _ => + (rootEncodingCacheCouples_publishCoordinate parameter target leftRoot rightRoot + coordinate).bind fun _ => + rootEncodingCacheCouples_pure parameter target leftRoot rightRoot _ + +theorem rootEncodingCacheCouples_revealLayerValues + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (revealLayerValues index lay encoding) := by + unfold revealLayerValues + apply (rootEncodingCacheCouples_sequenceFin parameter target leftRoot rightRoot _ + fun chainIdx => rootEncodingCacheCouples_revealPublishedCoordinate parameter target + leftRoot rightRoot + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + (encoding chainIdx))).bind + intro values + apply (rootEncodingCacheCouples_sequenceFin parameter target leftRoot rightRoot _ + fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + cases hzero : level.val with + | zero => + exact rootEncodingCacheCouples_revealPublishedCoordinate parameter target leftRoot + rightRoot (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | succ current => + rw [Nat.add_one] + simp only + by_cases hcurrent : current < maxLayerHeight + · rw [dif_pos hcurrent] + exact rootEncodingCacheCouples_revealPublishedCoordinate parameter target leftRoot + rightRoot (.position (.node lay (treeIndexAt index lay) ⟨current, hcurrent⟩ + (leafOfNat (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + · rw [dif_neg hcurrent] + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot 0 + · rw [if_neg hlevel] + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot 0).bind + intro path + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot (values, path) + +theorem rootEncodingCacheCouples_maskedTreeNode + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, + RootEncodingCacheCouples parameter target leftRoot rightRoot + (maskedTreeNode lay tree level nodeIdx) + | level, nodeIdx => by + unfold maskedTreeNode + apply (rootEncodingCacheCouples_ensureTreeNode parameter target leftRoot rightRoot lay tree + level nodeIdx).bind + intro _ + cases level with + | zero => + exact rootEncodingCacheCouples_revealPosition parameter target leftRoot rightRoot + (.leaf lay tree (leafOfNat nodeIdx)) + | succ current => + rw [Nat.add_one] + simp only + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact rootEncodingCacheCouples_revealPosition parameter target leftRoot rightRoot + (.node lay tree ⟨current, hlevel⟩ (leafOfNat nodeIdx)) + · rw [dif_neg hlevel] + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot 0 + +theorem rootEncodingCacheCouples_maskedTreeRoot + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (maskedTreeRoot lay tree) := + rootEncodingCacheCouples_maskedTreeNode parameter target leftRoot rightRoot lay tree + (layerHeight lay) 0 + +theorem rootEncodingCacheCouples_maskedLayerMessage + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + by_cases hbelow : lay.val + 1 < numLayers + · rw [dif_pos hbelow] + exact rootEncodingCacheCouples_maskedTreeRoot parameter target leftRoot rightRoot + ⟨lay.val + 1, hbelow⟩ (treeIndexAt index ⟨lay.val + 1, hbelow⟩) + · rw [dif_neg hbelow] + exact rootEncodingCacheCouples_ftsKey parameter target leftRoot rightRoot index + (ftsSecret index) + +theorem relTriple_splitHashQuery_encodingRetryInput + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (position : EncodingPosition) (counter : Nat) + (hposition : EncodingPositionNamesRoot target position) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + RelTriple + (runCleanFromTable state fuel table + ((splitHashQuery (.ordinary + (encodingRetryInput parameter position leftRoot counter))).run leftCache)) + (runCleanFromTable state fuel table + ((splitHashQuery (.ordinary + (encodingRetryInput parameter position rightRoot counter))).run rightCache)) + (RootEncodingCleanQueryRel parameter target leftRoot rightRoot) := by + let leftInput := encodingRetryInput parameter position leftRoot counter + let rightInput := encodingRetryInput parameter position rightRoot counter + have hlookup := hcache.retry position counter hposition + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + cases hleft : leftCache (.ordinary leftInput) with + | some output => + have hright : rightCache (.ordinary rightInput) = some output := by + rw [← hlookup] + exact hleft + simp only [rightInput, hright] + simp only [runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + | none => + have hright : rightCache (.ordinary rightInput) = none := by + rw [← hlookup] + exact hleft + simp only [rightInput, hright] + unfold LazyRevealProbe.hashOutputQuery + rw [runCleanFromTable_hashOutput_query_bind, + runCleanFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_retry position counter hposition leftOutput⟩ + +noncomputable def rootEncodingAttemptRun + (parameter : PublicParameter) (position : EncodingPosition) + (message : Digest) (counter : Nat) (cache : SplitHashCache) : + OracleComp (LazyRevealProbe.World Coordinate) + (Option Encoding × SplitHashCache) := do + let result ← (splitHashQuery (.ordinary + (encodingRetryInput parameter position message counter))).run cache + pure (TargetSum.decodeDigest (truncateHash result.1), result.2) + +theorem rootEncodingAttemptRun_eq_encode + (parameter : PublicParameter) (position : EncodingPosition) + (message : Digest) (counter : Nat) (cache : SplitHashCache) : + rootEncodingAttemptRun parameter position message counter cache = + (simulateQ ordinaryHashImpl + (encode parameter position.lay position.tree position.leafIdx message + (BitVec.ofNat counterBits counter))).run cache := by + unfold rootEncodingAttemptRun encode tweakableHash oracleHash + simp only [simulateQ_bind, simulateQ_pure, StateT.run_bind, StateT.run_pure, + HasQuery.instOfMonadLift_query, simulateQ_spec_query, ordinaryHashImpl, + encodingRetryInput, EncodingPosition.domain, bind_assoc, pure_bind] + +def RootEncodingAttemptRel + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) : + Option (CleanRunResult (Option Encoding × SplitHashCache)) → + Option (CleanRunResult (Option Encoding × SplitHashCache)) → Prop := + RootEncodingCleanSameRel parameter target leftRoot rightRoot + +theorem relTriple_rootEncodingAttemptRun + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (position : EncodingPosition) (counter : Nat) + (hposition : EncodingPositionNamesRoot target position) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + RelTriple + (runCleanFromTable state fuel table + (rootEncodingAttemptRun parameter position leftRoot counter leftCache)) + (runCleanFromTable state fuel table + (rootEncodingAttemptRun parameter position rightRoot counter rightCache)) + (RootEncodingAttemptRel parameter target leftRoot rightRoot) := by + unfold rootEncodingAttemptRun + rw [runCleanFromTable_bind, runCleanFromTable_bind] + apply relTriple_bind + (relTriple_splitHashQuery_encodingRetryInput parameter target leftRoot rightRoot position + counter hposition leftCache rightCache hcache state fuel table) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => + simp [RootEncodingCleanQueryRel, RootEncodingCleanSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootEncodingCleanQueryRel, RootEncodingCleanSameRel] at hresult + | some rightResult => + rcases hresult with ⟨hstate, hremaining, htable, houtput, hnextCache⟩ + simp only + rw [← hstate, ← hremaining, ← htable, ← houtput] + simp only [runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hnextCache⟩ + +theorem relTriple_simulateQ_encode_roots + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (position : EncodingPosition) (counter : Nat) + (hposition : EncodingPositionNamesRoot target position) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + RelTriple + (runCleanFromTable state fuel table + ((simulateQ ordinaryHashImpl + (encode parameter position.lay position.tree position.leafIdx leftRoot + (BitVec.ofNat counterBits counter))).run leftCache)) + (runCleanFromTable state fuel table + ((simulateQ ordinaryHashImpl + (encode parameter position.lay position.tree position.leafIdx rightRoot + (BitVec.ofNat counterBits counter))).run rightCache)) + (RootEncodingCleanSameRel parameter target leftRoot rightRoot) := by + rw [← rootEncodingAttemptRun_eq_encode parameter position leftRoot counter leftCache, + ← rootEncodingAttemptRun_eq_encode parameter position rightRoot counter rightCache] + simpa [RootEncodingAttemptRel, RootEncodingCleanSameRel] using + (relTriple_rootEncodingAttemptRun parameter target leftRoot rightRoot position counter + hposition leftCache rightCache hcache state fuel table) + +theorem rootEncodingCacheRelates_encode + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (position : EncodingPosition) (counter : Nat) + (hposition : EncodingPositionNamesRoot target position) : + RootEncodingCacheRelates parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl + (encode parameter position.lay position.tree position.leafIdx leftRoot + (BitVec.ofNat counterBits counter))) + (simulateQ ordinaryHashImpl + (encode parameter position.lay position.tree position.leafIdx rightRoot + (BitVec.ofNat counterBits counter))) := by + intro leftCache rightCache hcache state fuel table + exact relTriple_simulateQ_encode_roots parameter target leftRoot rightRoot position counter + hposition leftCache rightCache hcache state fuel table + +theorem rootEncodingCacheRelates_maskedOtsSignFrom + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) + (hposition : EncodingPositionNamesRoot target ⟨lay, tree, leafIdx⟩) : + ∀ attempts counter, + RootEncodingCacheRelates parameter target leftRoot rightRoot + (maskedOtsSignFrom parameter lay tree leafIdx leftRoot attempts counter) + (maskedOtsSignFrom parameter lay tree leafIdx rightRoot attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom, maskedOtsSignFrom] + exact (rootEncodingCacheCouples_pure parameter target leftRoot rightRoot none).relates + | attempts + 1, counter => by + rw [maskedOtsSignFrom, maskedOtsSignFrom] + apply (rootEncodingCacheRelates_encode parameter target leftRoot rightRoot + ⟨lay, tree, leafIdx⟩ counter hposition).bind + intro leftEncoded rightEncoded hencoded + subst rightEncoded + cases leftEncoded with + | none => + exact rootEncodingCacheRelates_maskedOtsSignFrom parameter target leftRoot rightRoot + lay tree leafIdx hposition attempts (counter + 1) + | some encoding => + exact ((rootEncodingCacheCouples_sequenceFin parameter target leftRoot rightRoot + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx (encoding chainIdx)) + (fun chainIdx => rootEncodingCacheCouples_ensureChainPrefix parameter target + leftRoot rightRoot lay tree leafIdx chainIdx (encoding chainIdx))).bind fun _ => + rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (some (BitVec.ofNat counterBits counter, encoding))).relates + +theorem rootEncodingCacheRelates_maskedOtsSign + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) + (hposition : EncodingPositionNamesRoot target ⟨lay, tree, leafIdx⟩) : + RootEncodingCacheRelates parameter target leftRoot rightRoot + (maskedOtsSign parameter lay tree leafIdx leftRoot) + (maskedOtsSign parameter lay tree leafIdx rightRoot) := + rootEncodingCacheRelates_maskedOtsSignFrom parameter target leftRoot rightRoot lay tree leafIdx + hposition encodingAttemptLimit 0 + +set_option maxHeartbeats 1000000 in +theorem rootEncodingCacheCouples_encode_of_not_positionNames + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (position : EncodingPosition) + (message : Digest) (counter : Nat) + (hnotPosition : ¬EncodingPositionNamesRoot target position) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl + (encode parameter position.lay position.tree position.leafIdx message + (BitVec.ofNat counterBits counter))) := by + unfold encode tweakableHash oracleHash + simp only [simulateQ_bind, HasQuery.instOfMonadLift_query, simulateQ_spec_query, + simulateQ_pure, ordinaryHashImpl, bind_assoc, pure_bind] + exact (rootEncodingCacheCouples_splitHashQuery_same_nonroot parameter target leftRoot + rightRoot (.ordinary (encodingRetryInput parameter position message counter)) + (not_encodingInputNamesRoot_encodingRetryInput_of_not_positionNames hnotPosition message + counter)).bind fun output => + rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (TargetSum.decodeDigest (truncateHash output)) + +set_option maxHeartbeats 1000000 in +theorem rootEncodingCacheCouples_maskedOtsSignFrom_of_not_positionNames + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) + (hnotPosition : ¬EncodingPositionNamesRoot target ⟨lay, tree, leafIdx⟩) : + ∀ attempts counter, + RootEncodingCacheCouples parameter target leftRoot rightRoot + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom] + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + apply (rootEncodingCacheCouples_encode_of_not_positionNames parameter target leftRoot + rightRoot ⟨lay, tree, leafIdx⟩ message counter hnotPosition).bind + intro encoded + cases encoded with + | none => + exact rootEncodingCacheCouples_maskedOtsSignFrom_of_not_positionNames parameter target + leftRoot rightRoot lay tree leafIdx message hnotPosition attempts (counter + 1) + | some encoding => + exact (rootEncodingCacheCouples_sequenceFin parameter target leftRoot rightRoot + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx (encoding chainIdx)) + (fun chainIdx => rootEncodingCacheCouples_ensureChainPrefix parameter target + leftRoot rightRoot lay tree leafIdx chainIdx (encoding chainIdx))).bind fun _ => + rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem rootEncodingCacheCouples_maskedOtsSign_of_not_positionNames + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) + (hnotPosition : ¬EncodingPositionNamesRoot target ⟨lay, tree, leafIdx⟩) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (maskedOtsSign parameter lay tree leafIdx message) := + rootEncodingCacheCouples_maskedOtsSignFrom_of_not_positionNames parameter target leftRoot + rightRoot lay tree leafIdx message hnotPosition encodingAttemptLimit 0 + +theorem rootEncodingCacheCouples_maskedOtsLayerAfterMessage_of_not_positionNames + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) (lay : Layer) + (message : Digest) + (hnotPosition : ¬EncodingPositionNamesRoot target + ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (maskedOtsLayerAfterMessage parameter index lay message) := by + unfold maskedOtsLayerAfterMessage + apply (rootEncodingCacheCouples_maskedOtsSign_of_not_positionNames parameter target leftRoot + rightRoot lay (treeIndexAt index lay) (leafIndexAt index lay) message hnotPosition).bind + intro selected + cases selected with + | none => exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot none + | some selected => + exact (rootEncodingCacheCouples_ensureTreePath parameter target leftRoot rightRoot lay + (treeIndexAt index lay) (leafIndexAt index lay)).bind fun _ => + rootEncodingCacheCouples_pure parameter target leftRoot rightRoot (some selected) + +theorem rootEncodingCacheRelates_maskedOtsLayerAfterMessage + (parameter : PublicParameter) (index : Index) (lay : Layer) + (hnotBottom : lay ≠ bottomLayer) (leftRoot rightRoot : Digest) : + RootEncodingCacheRelates parameter (layerMessagePosition index lay) leftRoot rightRoot + (maskedOtsLayerAfterMessage parameter index lay leftRoot) + (maskedOtsLayerAfterMessage parameter index lay rightRoot) := by + have hposition : EncodingPositionNamesRoot (layerMessagePosition index lay) + ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩ := + ⟨index, rfl, rfl, hnotBottom, rfl⟩ + unfold maskedOtsLayerAfterMessage + apply (rootEncodingCacheRelates_maskedOtsSign parameter (layerMessagePosition index lay) + leftRoot rightRoot lay (treeIndexAt index lay) (leafIndexAt index lay) hposition).bind + intro leftSelected rightSelected hselected + subst rightSelected + cases leftSelected with + | none => + exact (rootEncodingCacheCouples_pure parameter (layerMessagePosition index lay) + leftRoot rightRoot none).relates + | some selected => + exact ((rootEncodingCacheCouples_ensureTreePath parameter + (layerMessagePosition index lay) leftRoot rightRoot lay (treeIndexAt index lay) + (leafIndexAt index lay)).bind fun _ => + rootEncodingCacheCouples_pure parameter (layerMessagePosition index lay) + leftRoot rightRoot (some selected)).relates + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootDeferred.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootDeferred.lean new file mode 100644 index 00000000..db1f7308 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootDeferred.lean @@ -0,0 +1,337 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootStateHash + +/-! +# Canonical deferred swapped roots + +Between adaptive queries the selected layer root is absent from the visible lazy state and retained +only in the private structural table. The two executions therefore have equal public state and may +differ at exactly that deferred table cell. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +structure RootDeferredContextRel + (target : Position) (leftOutput rightOutput : HashOutput) + (left right : DeferredContext) : Prop where + state : left.state = right.state + target_hidden : left.state.values (.position target) = none + target_private : Coordinate.position target ∉ left.state.revealed + left_target : left.values target = some leftOutput + right_target : right.values target = some rightOutput + other_values : ∀ position, position ≠ target → + left.values position = right.values position + +structure RootMaterializedContextRel + (target : Position) (leftOutput rightOutput : HashOutput) + (left right : DeferredContext) : Prop where + state : RootHiddenStateRel target leftOutput rightOutput left.state right.state + left_target : left.values target = some leftOutput + right_target : right.values target = some rightOutput + other_values : ∀ position, position ≠ target → + left.values position = right.values position + +def RootDeferredCacheRel + (parameter : PublicParameter) (target : Position) + (leftOutput rightOutput : HashOutput) + (left right : SplitHashCache) : Prop := + ∃ middle, + RootEncodingCacheRel parameter target + (truncateHash leftOutput) (truncateHash rightOutput) left middle ∧ + RootHiddenCacheRel target leftOutput rightOutput middle right + +structure RootDeferredConfigRel + (parameter : PublicParameter) (target : Position) + (leftOutput rightOutput : HashOutput) + (leftContext rightContext : DeferredContext) + (leftCache rightCache : SplitHashCache) : Prop where + context : RootDeferredContextRel target leftOutput rightOutput leftContext rightContext + cache : RootDeferredCacheRel parameter target leftOutput rightOutput leftCache rightCache + +theorem rootDeferredCacheRel_fullSwapRootCache + (parameter : PublicParameter) (target : Position) + (leftOutput rightOutput : HashOutput) (cache : SplitHashCache) + (hleft : cache (.hidden (.position target)) = some leftOutput) : + RootDeferredCacheRel parameter target leftOutput rightOutput cache + (fullSwapRootCache parameter target (truncateHash leftOutput) + (truncateHash rightOutput) rightOutput cache) := by + refine ⟨swapCanonicalRootEncodingCache parameter target + (truncateHash leftOutput) (truncateHash rightOutput) cache, ?_, ?_⟩ + · exact rootEncodingCacheRel_swapCanonical parameter target + (truncateHash leftOutput) (truncateHash rightOutput) cache + · exact rootHiddenCacheRel_fullSwapRootCache parameter target leftOutput rightOutput cache hleft + +theorem RootDeferredContextRel.symm + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : RootDeferredContextRel target leftOutput rightOutput left right) : + RootDeferredContextRel target rightOutput leftOutput right left := by + refine ⟨hrel.state.symm, ?_, ?_, hrel.right_target, hrel.left_target, ?_⟩ + · rw [← hrel.state] + exact hrel.target_hidden + · intro hmem + apply hrel.target_private + rwa [hrel.state] + · intro position hne + exact (hrel.other_values position hne).symm + +theorem rootDeferredContextRel_install + (target : Position) (leftOutput rightOutput : HashOutput) + (context : DeferredContext) + (hhidden : context.state.values (.position target) = none) + (hprivate : Coordinate.position target ∉ context.state.revealed) : + RootDeferredContextRel target leftOutput rightOutput + { context with values := context.values.install target leftOutput } + { context with values := context.values.install target rightOutput } := by + refine ⟨rfl, hhidden, hprivate, ?_, ?_, ?_⟩ + · simp [DeferredStructuralValues.install] + · simp [DeferredStructuralValues.install] + · intro position hne + simp [DeferredStructuralValues.install, Function.update_of_ne hne] + +theorem RootDeferredContextRel.positionValue_other + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : RootDeferredContextRel target leftOutput rightOutput left right) + (position : Position) (hne : position ≠ target) : + left.positionValue position = right.positionValue position := by + unfold DeferredContext.positionValue + rw [hrel.state] + cases right.state.values (.position position) with + | some output => rfl + | none => exact hrel.other_values position hne + +theorem RootDeferredContextRel.positionValue_target + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : RootDeferredContextRel target leftOutput rightOutput left right) : + left.positionValue target = some leftOutput ∧ + right.positionValue target = some rightOutput := by + unfold DeferredContext.positionValue + have hrightHidden : right.state.values (.position target) = none := by + rw [← hrel.state] + exact hrel.target_hidden + rw [hrel.target_hidden, hrightHidden] + exact ⟨hrel.left_target, hrel.right_target⟩ + +theorem RootDeferredContextRel.deferredPositionOutput_other + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : RootDeferredContextRel target leftOutput rightOutput left right) + (position : Position) (hne : position ≠ target) : + deferredPositionOutput position left = deferredPositionOutput position right := by + unfold deferredPositionOutput + rw [hrel.positionValue_other position hne] + +theorem RootDeferredContextRel.deferredPositionOutput_target_left + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : RootDeferredContextRel target leftOutput rightOutput left right) : + deferredPositionOutput target left = pure leftOutput := by + unfold deferredPositionOutput + rw [hrel.positionValue_target.1] + +theorem RootDeferredContextRel.deferredPositionOutput_target_right + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : RootDeferredContextRel target leftOutput rightOutput left right) : + deferredPositionOutput target right = pure rightOutput := by + unfold deferredPositionOutput + rw [hrel.positionValue_target.2] + +theorem RootDeferredContextRel.privateCandidateFire_other + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : RootDeferredContextRel target leftOutput rightOutput left right) + (candidate : Probe) (hne : candidate.coordinate ≠ .position target) : + privateCandidateFire candidate left = privateCandidateFire candidate right := by + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [privateCandidateFire, hcoordinate] + | position position => + have hposition : position ≠ target := by + intro heq + apply hne + rw [hcoordinate, heq] + simp only [privateCandidateFire, hcoordinate] + rw [hrel.deferredPositionOutput_other position hposition] + +theorem RootDeferredContextRel.hiddenPrivateCandidateFire_other + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : RootDeferredContextRel target leftOutput rightOutput left right) + (candidate : Probe) (hne : candidate.coordinate ≠ .position target) : + hiddenPrivateCandidateFire candidate left = hiddenPrivateCandidateFire candidate right := by + unfold hiddenPrivateCandidateFire + have hrevealed : left.state.revealed = right.state.revealed := congrArg _ hrel.state + by_cases hleft : candidate.coordinate ∈ left.state.revealed + · have hright : candidate.coordinate ∈ right.state.revealed := by rwa [← hrevealed] + simp [hleft, hright] + · have hright : candidate.coordinate ∉ right.state.revealed := by + intro hmem + exact hleft (by rwa [hrevealed]) + simp only [hleft, hright, ↓reduceIte] + exact hrel.privateCandidateFire_other candidate hne + +theorem RootDeferredContextRel.hiddenPrivateCandidateFire_target_left + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : RootDeferredContextRel target leftOutput rightOutput left right) + (candidate : Digest) : + hiddenPrivateCandidateFire ⟨.position target, candidate⟩ left = + pure (decide (truncateHash leftOutput = candidate)) := by + rw [hiddenPrivateCandidateFire_of_not_revealed _ _ hrel.target_private] + simp only [privateCandidateFire] + rw [hrel.deferredPositionOutput_target_left] + simp + +theorem RootDeferredContextRel.hiddenPrivateCandidateFire_target_right + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : RootDeferredContextRel target leftOutput rightOutput left right) + (candidate : Digest) : + hiddenPrivateCandidateFire ⟨.position target, candidate⟩ right = + pure (decide (truncateHash rightOutput = candidate)) := by + have hprivate : Coordinate.position target ∉ right.state.revealed := by + intro hmem + apply hrel.target_private + rwa [hrel.state] + rw [hiddenPrivateCandidateFire_of_not_revealed _ _ hprivate] + simp only [privateCandidateFire] + rw [hrel.deferredPositionOutput_target_right] + simp + +theorem RootDeferredContextRel.materialize_target + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : RootDeferredContextRel target leftOutput rightOutput left right) : + RootMaterializedContextRel target leftOutput rightOutput + { left with + state := left.state.materialize (.position target) leftOutput } + { right with + state := right.state.materialize (.position target) rightOutput } := by + refine ⟨?_, hrel.left_target, hrel.right_target, hrel.other_values⟩ + rw [hrel.state] + exact rootHiddenStateRel_materialize target leftOutput rightOutput right.state (by + intro hmem + apply hrel.target_private + rwa [hrel.state]) + +theorem RootDeferredContextRel.ensure + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : RootDeferredContextRel target leftOutput rightOutput left right) + (coordinate : Coordinate) : + RootDeferredContextRel target leftOutput rightOutput + { left with state := left.state.ensure coordinate } + { right with state := right.state.ensure coordinate } := by + refine ⟨by simp [hrel.state], hrel.target_hidden, hrel.target_private, + hrel.left_target, hrel.right_target, hrel.other_values⟩ + +theorem RootDeferredContextRel.addPending + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : RootDeferredContextRel target leftOutput rightOutput left right) + (coordinate : Coordinate) (candidate : Digest) : + RootDeferredContextRel target leftOutput rightOutput + { left with state := left.state.addPending coordinate candidate } + { right with state := right.state.addPending coordinate candidate } := by + refine ⟨by simp [hrel.state], hrel.target_hidden, hrel.target_private, + hrel.left_target, hrel.right_target, hrel.other_values⟩ + +theorem RootDeferredContextRel.publish_of_ne + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : RootDeferredContextRel target leftOutput rightOutput left right) + (coordinate : Coordinate) (hne : coordinate ≠ .position target) : + RootDeferredContextRel target leftOutput rightOutput + { left with state := left.state.publish coordinate } + { right with state := right.state.publish coordinate } := by + refine ⟨by simp [hrel.state], hrel.target_hidden, ?_, + hrel.left_target, hrel.right_target, hrel.other_values⟩ + simp [LazyRevealProbe.State.publish, hrel.target_private, Ne.symm hne] + +theorem RootDeferredContextRel.canonicalize + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : RootDeferredContextRel target leftOutput rightOutput left right) + (table : OtsSecretIndex → HashOutput) : + RootDeferredContextRel target leftOutput rightOutput + (canonicalizeMaterializedValues table left) + (canonicalizeMaterializedValues table right) := by + have hpublic : publicMaterializedValues table left = publicMaterializedValues table right := by + funext coordinate + unfold publicMaterializedValues + have hreveal : left.state.revealed = right.state.revealed := congrArg _ hrel.state + by_cases hrevealed : coordinate ∈ left.state.revealed + · have hrightRevealed : coordinate ∈ right.state.revealed := by rwa [← hreveal] + simp only [hrevealed, hrightRevealed, ↓reduceIte] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [resolvedCompletionValue] + | position position => + have hne : position ≠ target := by + intro heq + subst position + exact hrel.target_private hrevealed + simp [resolvedCompletionValue, hrel.positionValue_other position hne] + · have hrightRevealed : coordinate ∉ right.state.revealed := by + intro hmem + exact hrevealed (by rwa [hreveal]) + simp [hrevealed, hrightRevealed] + refine ⟨?_, ?_, ?_, hrel.left_target, hrel.right_target, hrel.other_values⟩ + · unfold canonicalizeMaterializedValues + simp [hrel.state, hpublic] + · unfold canonicalizeMaterializedValues publicMaterializedValues + simp [hrel.target_private] + · simpa [canonicalizeMaterializedValues_revealed] using hrel.target_private + +theorem RootMaterializedContextRel.canonicalize + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : RootMaterializedContextRel target leftOutput rightOutput left right) + (table : OtsSecretIndex → HashOutput) : + RootDeferredContextRel target leftOutput rightOutput + (canonicalizeMaterializedValues table left) + (canonicalizeMaterializedValues table right) := by + have hpublic : publicMaterializedValues table left = publicMaterializedValues table right := by + funext coordinate + unfold publicMaterializedValues + have hreveal : left.state.revealed = right.state.revealed := hrel.state.revealed + by_cases hrevealed : coordinate ∈ left.state.revealed + · have hrightRevealed : coordinate ∈ right.state.revealed := by rwa [← hreveal] + simp only [hrevealed, hrightRevealed, ↓reduceIte] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [resolvedCompletionValue] + | position position => + have hne : position ≠ target := by + intro heq + subst position + exact hrel.state.target_private hrevealed + unfold resolvedCompletionValue DeferredContext.positionValue + have hcoordinate : Coordinate.position position ≠ .position target := by + simpa using hne + change (match left.state.values (.position position) with + | some output => some output + | none => left.values position) = + (match right.state.values (.position position) with + | some output => some output + | none => right.values position) + rw [hrel.state.other_values (.position position) hcoordinate] + cases right.state.values (.position position) with + | some output => rfl + | none => exact hrel.other_values position hne + · have hrightRevealed : coordinate ∉ right.state.revealed := by + intro hmem + exact hrevealed (by rwa [hreveal]) + simp [hrevealed, hrightRevealed] + refine ⟨?_, ?_, ?_, hrel.left_target, hrel.right_target, hrel.other_values⟩ + · unfold canonicalizeMaterializedValues + simp [hrel.state.pending, hrel.state.revealed, hrel.state.ensured, hpublic] + · unfold canonicalizeMaterializedValues publicMaterializedValues + simp [hrel.state.target_private] + · simpa [canonicalizeMaterializedValues_revealed] using hrel.state.target_private + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootEvent.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootEvent.lean new file mode 100644 index 00000000..47c73736 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootEvent.lean @@ -0,0 +1,100 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootProbeCoupling + +/-! +# Root ordinal event + +The sampled granular witness trace is split at its least matching candidate. This module packages +the exact layer-root event that remains to be coupled to the root-aware lazy comparison and keeps +the existing Boolean private-failure endpoint as its marginal. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +def WitnessFirstUsesSomeLayerRoot (output : PrivateWitnessPlanOutput) : Prop := + ∃ ordinal, WitnessFirstUsesLayerRootOrdinal ordinal output + +def WitnessFirstUsesSomeNonLayerRoot (output : PrivateWitnessPlanOutput) : Prop := + ∃ ordinal, WitnessFirstUsesNonLayerRootOrdinal ordinal output + +theorem witnessFirstUsesSome_root_or_nonRoot + {output : PrivateWitnessPlanOutput} + (hcovered : PrivateWitnessCovered output) + (hwitness : output.1.isSome = true) : + WitnessFirstUsesSomeLayerRoot output ∨ WitnessFirstUsesSomeNonLayerRoot output := by + cases hwitnessValue : output.1 with + | none => simp [hwitnessValue] at hwitness + | some witness => + have hhit := hcovered witness hwitnessValue + obtain ⟨ordinal, hfirst, _hsource⟩ := + firstPrivateWitnessOrdinal?_eq_some_of_candidateListHits witness output.2 hhit + have huses : WitnessFirstUsesOrdinal ordinal.val output := + ⟨witness, ordinal, hwitnessValue, rfl, hfirst⟩ + exact (witnessFirstUsesOrdinal_iff_root_or_nonRoot.mp huses).imp + (fun hroot => ⟨ordinal.val, hroot⟩) + (fun hnonRoot => ⟨ordinal.val, hnonRoot⟩) + +theorem probEvent_privateWitness_le_root_add_nonRoot + (run : ProbComp PrivateWitnessPlanOutput) + (hcovered : ∀ output ∈ support run, PrivateWitnessCovered output) : + Pr[fun output => output.1.isSome = true | run] ≤ + Pr[WitnessFirstUsesSomeLayerRoot | run] + + Pr[WitnessFirstUsesSomeNonLayerRoot | run] := by + calc + _ ≤ Pr[fun output => + WitnessFirstUsesSomeLayerRoot output ∨ WitnessFirstUsesSomeNonLayerRoot output | run] := by + apply probEvent_mono + intro output houtput hwitness + exact witnessFirstUsesSome_root_or_nonRoot (hcovered output houtput) hwitness + _ ≤ _ := probEvent_or_le _ _ _ + +noncomputable def sampledGranularAllDirectBoundaryNormalizedPrivateWitnessPlan + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp PrivateWitnessPlanOutput := do + let table ← sampleOtsHashTable + granularAllDirectBoundaryNormalizedPrivateWitnessPlan adversary parameter table ftsSecret fuel + +theorem probEvent_isSome_sampledGranularAllDirectBoundaryNormalizedPrivateWitnessPlan_eq + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun output => output.1.isSome = true | + sampledGranularAllDirectBoundaryNormalizedPrivateWitnessPlan adversary parameter + ftsSecret fuel] = + Pr[= true | sampledGranularAllDirectBoundaryDetailedRetainedPrivate adversary parameter + ftsSecret fuel] := by + unfold sampledGranularAllDirectBoundaryNormalizedPrivateWitnessPlan + sampledGranularAllDirectBoundaryDetailedRetainedPrivate + rw [probEvent_bind_eq_tsum, probOutput_bind_eq_tsum] + apply tsum_congr + intro table + congr 1 + calc + Pr[fun output => output.1.isSome = true | + granularAllDirectBoundaryNormalizedPrivateWitnessPlan adversary parameter table ftsSecret + fuel] = + Pr[fun output => output.1 = true | + erasePrivateWitnessPlanOutput <$> + granularAllDirectBoundaryNormalizedPrivateWitnessPlan adversary parameter table + ftsSecret fuel] := by + rw [probEvent_map] + exact OracleComp.probEvent_congr' (fun output _ => by + simp [erasePrivateWitnessPlanOutput]) rfl + _ = Pr[fun output => output.1 = true | + granularAllDirectBoundaryNormalizedPrivatePlan adversary parameter table ftsSecret + fuel] := + OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + (congrArg evalDist + (map_erase_granularAllDirectBoundaryNormalizedPrivateWitnessPlan adversary parameter + table ftsSecret fuel)) + _ = Pr[= true | Prod.fst <$> + granularAllDirectBoundaryNormalizedPrivatePlan adversary parameter table ftsSecret + fuel] := by + rw [← probEvent_eq_eq_probOutput, probEvent_map] + rfl + _ = _ := OracleComp.probOutput_congr rfl + (evalDist_fst_granularAllDirectBoundaryNormalizedPrivatePlan adversary parameter table + ftsSecret fuel) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootFiber.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootFiber.lean new file mode 100644 index 00000000..27336e88 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootFiber.lean @@ -0,0 +1,285 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootAdaptive + +/-! +# Layer-root ordinal fibers + +The root selected by one chronological candidate ordinal is dynamic. This module classifies a +retained witness by that root position so a weighted fiber argument can fix the target without +paying for every possible structural position. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +abbrev RootOutputHigh := BitVec (hashOutputBits - digestBits) + +noncomputable def rootOutputOfParts (root : Digest) (high : RootOutputHigh) : HashOutput := + (splitHashOutputEquiv digestBits (by decide)).symm (root, high) + +@[simp] theorem truncateHash_rootOutputOfParts (root : Digest) (high : RootOutputHigh) : + truncateHash (rootOutputOfParts root high) = root := by + change (splitHashOutput digestBits + ((splitHashOutputEquiv digestBits (by decide)).symm (root, high))).1 = root + rw [show splitHashOutput digestBits = splitHashOutputEquiv digestBits (by decide) from rfl, + Equiv.apply_symm_apply] + +theorem evalDist_sample_rootOutputOfParts : + evalDist (do + let root ← ($ᵗ Digest : ProbComp Digest) + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + pure (rootOutputOfParts root high)) = + evalDist LazyRevealProbe.sampleHashOutput := by + let split := splitHashOutputEquiv digestBits (by decide) + let pairSample := + ($ᵗ (Digest × RootOutputHigh) : ProbComp (Digest × RootOutputHigh)) + have hpair : evalDist (do + let root ← ($ᵗ Digest : ProbComp Digest) + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + pure (root, high)) = evalDist pairSample := by + exact evalDist_independent_uniform_pair + have hleft : (do + let root ← ($ᵗ Digest : ProbComp Digest) + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + pure (rootOutputOfParts root high)) = + split.symm <$> (do + let root ← ($ᵗ Digest : ProbComp Digest) + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + pure (root, high)) := by + simp [rootOutputOfParts, split, map_eq_bind_pure_comp, bind_assoc] + calc + _ = evalDist (split.symm <$> pairSample) := by + rw [hleft, evalDist_map, hpair, ← evalDist_map] + _ = evalDist ($ᵗ HashOutput : ProbComp HashOutput) := + evalDist_map_bijective_uniform_cross _ split.symm split.symm.bijective + _ = _ := rfl + +noncomputable def freshRootResolution (target : Position) (context : DeferredContext) + (output : HashOutput) : Option DeferredResolution := + if context.state.hitAt (.position target) output then none + else some (DeferredResolution.mk + { state := context.state.clearPending (.position target) + values := context.values.install target output } + output) + +theorem resolveDeferredPositionValue_fresh_eq_bind_rootResolution + (target : Position) (context : DeferredContext) + (hstate : context.state.values (.position target) = none) + (hvalue : context.values target = none) : + resolveDeferredPositionValue target context = (do + let output ← LazyRevealProbe.sampleHashOutput + pure (freshRootResolution target context output)) := by + rw [resolveDeferredPositionValue_fresh target context hstate hvalue] + apply bind_congr + intro output + unfold freshRootResolution + by_cases hhit : context.state.hitAt (.position target) output <;> simp [hhit] + +theorem evalDist_resolveDeferredPositionValue_fresh_root_parts + (target : Position) (context : DeferredContext) + (hstate : context.state.values (.position target) = none) + (hvalue : context.values target = none) : + evalDist (resolveDeferredPositionValue target context) = evalDist (do + let root ← ($ᵗ Digest : ProbComp Digest) + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + pure (freshRootResolution target context (rootOutputOfParts root high))) := by + rw [resolveDeferredPositionValue_fresh_eq_bind_rootResolution target context hstate hvalue] + let parts : ProbComp HashOutput := do + let root ← ($ᵗ Digest : ProbComp Digest) + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + pure (rootOutputOfParts root high) + calc + evalDist (LazyRevealProbe.sampleHashOutput >>= + fun output => pure (freshRootResolution target context output)) = + evalDist (parts >>= fun output => + pure (freshRootResolution target context output)) := by + rw [evalDist_bind, evalDist_bind, evalDist_sample_rootOutputOfParts] + _ = _ := by simp [parts] + +theorem storedLayerRoot_materializeResolvedPosition + (context : DeferredContext) (target : Position) (result : DeferredResolution) : + StoredLayerRoot (materializeResolvedPosition context target result).state target + (truncateHash result.output) := by + refine ⟨result.output, ?_, rfl⟩ + simp [materializeResolvedPosition, LazyRevealProbe.State.materialize] + +theorem storedLayerRoot_materialize_freshRootResolution + (context : DeferredContext) (target : Position) (output : HashOutput) + (result : DeferredResolution) + (hresult : freshRootResolution target context output = some result) : + StoredLayerRoot (materializeResolvedPosition context target result).state target + (truncateHash output) := by + unfold freshRootResolution at hresult + by_cases hhit : context.state.hitAt (.position target) output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + exact storedLayerRoot_materializeResolvedPosition context target _ + +noncomputable def candidateLayerRootPosition? (candidate : Probe) : Option Position := + match candidate.coordinate with + | .position position => if IsLayerRoot position then some position else none + | .chainStart _ _ _ _ => none + +theorem candidateLayerRootPosition?_eq_some_iff + (candidate : Probe) (target : Position) : + candidateLayerRootPosition? candidate = some target ↔ + candidate.coordinate = .position target ∧ IsLayerRoot target := by + cases candidate with + | mk coordinate digest => + cases coordinate with + | chainStart => simp [candidateLayerRootPosition?] + | position position => + simp only [candidateLayerRootPosition?] + by_cases hroot : IsLayerRoot position + · rw [if_pos hroot] + simp only [Option.some.injEq, Coordinate.position.injEq] + constructor + · intro heq + subst target + exact ⟨rfl, hroot⟩ + · rintro ⟨heq, _htarget⟩ + exact heq + · rw [if_neg hroot] + constructor + · simp + · rintro ⟨heq, htarget⟩ + have hposition : position = target := Coordinate.position.inj heq + subst target + exact False.elim (hroot htarget) + +noncomputable def selectedLayerRootPosition? + (ordinal : Nat) (output : PrivateWitnessPlanOutput) : Option Position := + if hselected : ordinal < output.2.length then + candidateLayerRootPosition? (output.2.get ⟨ordinal, hselected⟩) + else none + +def selectedPrivateWitnessDigest (output : PrivateWitnessPlanOutput) : Digest := + match output.1 with + | none => 0 + | some witness => truncateHash witness.output + +theorem selectedLayerRootPosition?_eq_some_of_witnessFirstUsesLayerRootOrdinal + {ordinal : Nat} {output : PrivateWitnessPlanOutput} + (hfirst : WitnessFirstUsesLayerRootOrdinal ordinal output) : + ∃ target, selectedLayerRootPosition? ordinal output = some target := by + obtain ⟨witness, sourceOrdinal, _hwitness, hordinal, _hfirst, hroot⟩ := hfirst + obtain ⟨target, hcoordinate, htarget⟩ := hroot + have hselected : ordinal < output.2.length := by + rw [← hordinal] + exact sourceOrdinal.isLt + refine ⟨target, ?_⟩ + unfold selectedLayerRootPosition? + rw [dif_pos hselected, candidateLayerRootPosition?_eq_some_iff] + have hindex : (⟨ordinal, hselected⟩ : Fin output.2.length) = sourceOrdinal := + Fin.ext hordinal.symm + rw [hindex] + exact ⟨hcoordinate, htarget⟩ + +theorem not_witnessFirstUsesLayerRootOrdinal_of_selectedLayerRootPosition?_eq_none + {ordinal : Nat} {output : PrivateWitnessPlanOutput} + (hposition : selectedLayerRootPosition? ordinal output = none) : + ¬WitnessFirstUsesLayerRootOrdinal ordinal output := by + intro hfirst + obtain ⟨target, htarget⟩ := + selectedLayerRootPosition?_eq_some_of_witnessFirstUsesLayerRootOrdinal hfirst + rw [hposition] at htarget + simp at htarget + +theorem witnessFirstUsesLayerRootOrdinal_fiber_data + {ordinal : Nat} {output : PrivateWitnessPlanOutput} {target : Position} + (hfirst : WitnessFirstUsesLayerRootOrdinal ordinal output) + (hfiber : selectedLayerRootPosition? ordinal output = some target) : + ∃ witness sourceOrdinal, + output.1 = some witness ∧ sourceOrdinal.val = ordinal ∧ + firstPrivateWitnessOrdinal? witness output.2 = some sourceOrdinal ∧ + witness.position = target ∧ + truncateHash witness.output = (output.2.get sourceOrdinal).candidate ∧ + IsLayerRoot target := by + obtain ⟨witness, sourceOrdinal, hwitness, hordinal, hsourceFirst, _hroot⟩ := hfirst + have hmatch := + privateWitnessAtOrdinal_of_firstPrivateWitnessOrdinal?_eq_some hsourceFirst + have hselected : ordinal < output.2.length := by + rw [← hordinal] + exact sourceOrdinal.isLt + have hindex : (⟨ordinal, hselected⟩ : Fin output.2.length) = sourceOrdinal := + Fin.ext hordinal.symm + have hfiber' := hfiber + unfold selectedLayerRootPosition? at hfiber' + rw [dif_pos hselected, candidateLayerRootPosition?_eq_some_iff, hindex] at hfiber' + unfold PrivateWitnessAtOrdinal at hmatch + have hposition : witness.position = target := by + exact Coordinate.position.inj (hmatch.1.symm.trans hfiber'.1) + exact ⟨witness, sourceOrdinal, hwitness, hordinal, hsourceFirst, hposition, + hmatch.2, hfiber'.2⟩ + +theorem selectedPrivateWitnessDigest_eq_candidate_of_witnessFirstUsesLayerRootOrdinal + {ordinal : Nat} {output : PrivateWitnessPlanOutput} + (hfirst : WitnessFirstUsesLayerRootOrdinal ordinal output) : + ∃ hselected : ordinal < output.2.length, + selectedPrivateWitnessDigest output = + (output.2.get ⟨ordinal, hselected⟩).candidate := by + obtain ⟨target, htarget⟩ := + selectedLayerRootPosition?_eq_some_of_witnessFirstUsesLayerRootOrdinal hfirst + obtain ⟨witness, sourceOrdinal, hwitness, hordinal, hsourceFirst, _hposition, + hroot, _htarget⟩ := witnessFirstUsesLayerRootOrdinal_fiber_data hfirst htarget + have hselected : ordinal < output.2.length := by + rw [← hordinal] + exact sourceOrdinal.isLt + refine ⟨hselected, ?_⟩ + have hindex : (⟨ordinal, hselected⟩ : Fin output.2.length) = sourceOrdinal := + Fin.ext hordinal.symm + rw [hindex, selectedPrivateWitnessDigest, hwitness] + exact hroot + +theorem earlier_fiber_candidate_ne_actual_root + {ordinal : Nat} {output : PrivateWitnessPlanOutput} {target : Position} + (hfirst : WitnessFirstUsesLayerRootOrdinal ordinal output) + (hfiber : selectedLayerRootPosition? ordinal output = some target) + (earlier : Fin output.2.length) (hlt : earlier.val < ordinal) + (hcoordinate : (output.2.get earlier).coordinate = .position target) : + (output.2.get earlier).candidate ≠ + truncateHash (Option.get output.1 (by + obtain ⟨witness, _sourceOrdinal, hwitness, _⟩ := + witnessFirstUsesLayerRootOrdinal_fiber_data hfirst hfiber + rw [hwitness] + simp)).output := by + obtain ⟨witness, sourceOrdinal, hwitness, hordinal, hsourceFirst, hposition, + _hroot, _htarget⟩ := witnessFirstUsesLayerRootOrdinal_fiber_data hfirst hfiber + have hwitnessGet : Option.get output.1 (by rw [hwitness]; simp) = witness := by + simp [hwitness] + rw [hwitnessGet] + have huses : WitnessFirstUsesOrdinal ordinal output := + ⟨witness, sourceOrdinal, hwitness, hordinal, hsourceFirst⟩ + apply earlier_candidate_ne_of_witnessFirstUsesOrdinal + huses witness hwitness earlier hlt target hcoordinate hposition + +theorem probEvent_witnessFirstUsesLayerRootOrdinal_le_of_position_fibers + (run : ProbComp PrivateWitnessPlanOutput) (ordinal : Nat) + (hfiber : ∀ target, + Pr[fun output => WitnessFirstUsesLayerRootOrdinal ordinal output ∧ + selectedLayerRootPosition? ordinal output = some target | run] ≤ + Pr[fun output => selectedLayerRootPosition? ordinal output = some target | run] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[WitnessFirstUsesLayerRootOrdinal ordinal | run] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_le_of_uniform_weighted_fibers run + (WitnessFirstUsesLayerRootOrdinal ordinal) + (selectedLayerRootPosition? ordinal) + (((2 ^ digestBits : Nat) : ENNReal)⁻¹) + intro position? + cases position? with + | none => + have hzero : Pr[fun output => WitnessFirstUsesLayerRootOrdinal ordinal output ∧ + selectedLayerRootPosition? ordinal output = none | run] = 0 := by + apply probEvent_eq_zero + intro output _houtput hevent + exact not_witnessFirstUsesLayerRootOrdinal_of_selectedLayerRootPosition?_eq_none + hevent.2 hevent.1 + rw [hzero] + exact zero_le + | some target => exact hfiber target + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobal.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobal.lean new file mode 100644 index 00000000..2f20fbd7 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobal.lean @@ -0,0 +1,1230 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionBoundary + +/-! +# Global root boundary + +The early clean failure is split before the delayed witness is classified by ordinal or position. +This module contains the probability rule used by that split. The failure event lives on the +comparison run, while the residual event stays on the original run, so later unions cannot copy +the failure term. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +structure CleanProbeObservation where + coordinate : Coordinate + candidate : Digest + valueAtProbe : Option HashOutput + revealedAtProbe : Bool +deriving DecidableEq + +def CleanProbeObservation.toProbe (observation : CleanProbeObservation) : Probe := + ⟨observation.coordinate, observation.candidate⟩ + +def cleanProbeObservation (state : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) (candidate : Digest) : CleanProbeObservation := + { coordinate := coordinate + candidate := candidate + valueAtProbe := state.values coordinate + revealedAtProbe := decide (coordinate ∈ state.revealed) } + +def CleanProbeObservation.TrackedBy + (observation : CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) : Prop := + (∀ output, observation.valueAtProbe = some output → + state.values observation.coordinate = some output) ∧ + (observation.valueAtProbe = none → observation.revealedAtProbe = false → + ((observation.coordinate, observation.candidate) ∈ state.pending ∧ + state.values observation.coordinate = none) ∨ + ∃ output, state.values observation.coordinate = some output ∧ + truncateHash output ≠ observation.candidate) + +def CleanProbeObservationsTrackedBy + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) : Prop := + ∀ observation ∈ observations, observation.TrackedBy state + +def CleanProbeObservationsCoverPending + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) : Prop := + ∀ entry ∈ state.pending, + ∃ observation ∈ observations, + observation.coordinate = entry.1 ∧ + observation.candidate = entry.2 ∧ observation.revealedAtProbe = false + +theorem CleanProbeObservationsCoverPending.mono + {prior later : List CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (hcovered : CleanProbeObservationsCoverPending prior state) + (hsublist : prior.Sublist later) : + CleanProbeObservationsCoverPending later state := by + intro entry hentry + obtain ⟨observation, hobservation, hcoordinate, hcandidate, hhidden⟩ := + hcovered entry hentry + exact ⟨observation, hsublist.subset hobservation, hcoordinate, hcandidate, hhidden⟩ + +theorem CleanProbeObservationsCoverPending.state_subset + {observations : List CleanProbeObservation} + {left right : LazyRevealProbe.State Coordinate} + (hcovered : CleanProbeObservationsCoverPending observations right) + (hsubset : left.pending ⊆ right.pending) : + CleanProbeObservationsCoverPending observations left := by + intro entry hentry + exact hcovered entry (hsubset hentry) + +theorem CleanProbeObservationsCoverPending.ensure + {observations : List CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (hcovered : CleanProbeObservationsCoverPending observations state) + (coordinate : Coordinate) : + CleanProbeObservationsCoverPending observations (state.ensure coordinate) := by + exact hcovered + +theorem CleanProbeObservationsCoverPending.publish + {observations : List CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (hcovered : CleanProbeObservationsCoverPending observations state) + (coordinate : Coordinate) : + CleanProbeObservationsCoverPending observations (state.publish coordinate) := by + exact hcovered + +theorem CleanProbeObservationsCoverPending.materialize + {observations : List CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (hcovered : CleanProbeObservationsCoverPending observations state) + (coordinate : Coordinate) (output : HashOutput) : + CleanProbeObservationsCoverPending observations + (state.materialize coordinate output) := by + apply hcovered.state_subset + intro entry hentry + exact (Finset.mem_filter.1 hentry).1 + +theorem cleanProbeObservationsCoverPending_append_revealed + {observations : List CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (hcovered : CleanProbeObservationsCoverPending observations state) + (coordinate : Coordinate) (candidate : Digest) : + CleanProbeObservationsCoverPending + (observations ++ [cleanProbeObservation state coordinate candidate]) state := by + apply hcovered.mono + exact List.sublist_append_left _ _ + +theorem cleanProbeObservationsCoverPending_append_hidden + {observations : List CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (hcovered : CleanProbeObservationsCoverPending observations state) + (coordinate : Coordinate) (candidate : Digest) + (hhidden : coordinate ∉ state.revealed) : + CleanProbeObservationsCoverPending + (observations ++ [cleanProbeObservation state coordinate candidate]) + (state.addPending coordinate candidate) := by + intro entry hentry + simp only [LazyRevealProbe.State.addPending, Finset.mem_insert] at hentry + rcases hentry with rfl | hold + · exact ⟨cleanProbeObservation state coordinate candidate, by simp, + by simp [cleanProbeObservation], by simp [cleanProbeObservation], by + simp [cleanProbeObservation, hhidden]⟩ + · obtain ⟨observation, hobservation, hcoordinate, hcandidate, hhidden⟩ := + hcovered entry hold + exact ⟨observation, by simp [hobservation], hcoordinate, hcandidate, hhidden⟩ + +def CleanProbeObservation.ResolvedSafe + (observation : CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) : Prop := + observation.valueAtProbe = none → observation.revealedAtProbe = false → + ∀ output, state.values observation.coordinate = some output → + truncateHash output ≠ observation.candidate + +def CleanProbeObservationsResolvedSafe + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) : Prop := + ∀ observation ∈ observations, observation.ResolvedSafe state + +theorem CleanProbeObservation.resolvedSafe_of_trackedBy + {observation : CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (htracked : observation.TrackedBy state) : observation.ResolvedSafe state := by + intro hnone hhidden output hvalue + rcases htracked.2 hnone hhidden with hpending | hmaterialized + · rw [hpending.2] at hvalue + simp at hvalue + · obtain ⟨stored, hstored, hmismatch⟩ := hmaterialized + have : stored = output := Option.some.inj (hstored.symm.trans hvalue) + subst output + exact hmismatch + +theorem cleanProbeObservationsResolvedSafe_of_trackedBy + {observations : List CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (htracked : CleanProbeObservationsTrackedBy observations state) : + CleanProbeObservationsResolvedSafe observations state := by + intro observation hobservation + exact CleanProbeObservation.resolvedSafe_of_trackedBy + (htracked observation hobservation) + +theorem CleanProbeObservation.TrackedBy.ensure + {observation : CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (htracked : observation.TrackedBy state) (coordinate : Coordinate) : + observation.TrackedBy (state.ensure coordinate) := by + simpa [CleanProbeObservation.TrackedBy, LazyRevealProbe.State.ensure] using htracked + +theorem CleanProbeObservation.TrackedBy.addPending + {observation : CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (htracked : observation.TrackedBy state) (coordinate : Coordinate) + (candidate : Digest) : + observation.TrackedBy (state.addPending coordinate candidate) := by + constructor + · simpa [LazyRevealProbe.State.addPending] using htracked.1 + · intro hnone hhidden + rcases htracked.2 hnone hhidden with hpending | hmaterialized + · exact Or.inl ⟨Finset.mem_insert_of_mem hpending.1, hpending.2⟩ + · exact Or.inr hmaterialized + +theorem CleanProbeObservation.TrackedBy.publish + {observation : CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (htracked : observation.TrackedBy state) (coordinate : Coordinate) : + observation.TrackedBy (state.publish coordinate) := by + simpa [CleanProbeObservation.TrackedBy, LazyRevealProbe.State.publish] using htracked + +theorem CleanProbeObservation.TrackedBy.materialize + {observation : CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (htracked : observation.TrackedBy state) (coordinate : Coordinate) + (output : HashOutput) (hvalue : state.values coordinate = none) + (hmiss : ¬state.hitAt coordinate output) : + observation.TrackedBy (state.materialize coordinate output) := by + constructor + · intro stored hobservation + have hstored := htracked.1 stored hobservation + by_cases heq : observation.coordinate = coordinate + · subst coordinate + rw [hvalue] at hstored + simp at hstored + · simpa [LazyRevealProbe.State.materialize, Function.update_of_ne heq] using hstored + · intro hnone hhidden + rcases htracked.2 hnone hhidden with hpending | hmaterialized + · by_cases heq : observation.coordinate = coordinate + · subst coordinate + right + refine ⟨output, by simp [LazyRevealProbe.State.materialize], ?_⟩ + intro hdigest + apply hmiss + unfold LazyRevealProbe.State.hitAt + rw [LazyRevealProbe.State.mem_pendingAt_iff] + simpa [hdigest] using hpending.1 + · left + refine ⟨?_, ?_⟩ + · simp only [LazyRevealProbe.State.materialize, + LazyRevealProbe.State.pendingAway, Finset.mem_filter] + exact ⟨hpending.1, heq⟩ + · simp [LazyRevealProbe.State.materialize, Function.update_of_ne heq] + exact hpending.2 + · obtain ⟨stored, hstored, hmismatch⟩ := hmaterialized + by_cases heq : observation.coordinate = coordinate + · subst coordinate + rw [hvalue] at hstored + simp at hstored + · right + refine ⟨stored, ?_, hmismatch⟩ + simpa [LazyRevealProbe.State.materialize, Function.update_of_ne heq] using hstored + +theorem CleanProbeObservation.TrackedBy.complete + {observation : CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (htracked : observation.TrackedBy state) (coordinate : Coordinate) + (output : HashOutput) (hvalue : state.values coordinate = none) + (hmiss : ¬state.hitAt coordinate output) : + observation.TrackedBy (state.complete coordinate output) := by + constructor + · intro stored hobservation + have hstored := htracked.1 stored hobservation + by_cases heq : observation.coordinate = coordinate + · subst coordinate + rw [hvalue] at hstored + simp at hstored + · simpa [LazyRevealProbe.State.complete, Function.update_of_ne heq] using hstored + · intro hnone hhidden + rcases htracked.2 hnone hhidden with hpending | hmaterialized + · by_cases heq : observation.coordinate = coordinate + · subst coordinate + right + refine ⟨output, by simp [LazyRevealProbe.State.complete], ?_⟩ + intro hdigest + apply hmiss + unfold LazyRevealProbe.State.hitAt + rw [LazyRevealProbe.State.mem_pendingAt_iff] + simpa [hdigest] using hpending.1 + · left + refine ⟨?_, ?_⟩ + · simp only [LazyRevealProbe.State.complete, + LazyRevealProbe.State.pendingAway, Finset.mem_filter] + exact ⟨hpending.1, heq⟩ + · simp [LazyRevealProbe.State.complete, Function.update_of_ne heq] + exact hpending.2 + · obtain ⟨stored, hstored, hmismatch⟩ := hmaterialized + by_cases heq : observation.coordinate = coordinate + · subst coordinate + rw [hvalue] at hstored + simp at hstored + · right + refine ⟨stored, ?_, hmismatch⟩ + simpa [LazyRevealProbe.State.complete, Function.update_of_ne heq] using hstored + +theorem CleanProbeObservation.TrackedBy.clearPending + {observation : CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (htracked : observation.TrackedBy state) (coordinate : Coordinate) + (output : HashOutput) (hvalue : state.values coordinate = some output) : + observation.TrackedBy (state.clearPending coordinate) := by + constructor + · simpa [LazyRevealProbe.State.clearPending] using htracked.1 + · intro hnone hhidden + rcases htracked.2 hnone hhidden with hpending | hmaterialized + · by_cases heq : observation.coordinate = coordinate + · subst coordinate + rw [hvalue] at hpending + simp at hpending + · left + refine ⟨?_, ?_⟩ + · simp only [LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway, Finset.mem_filter] + exact ⟨hpending.1, heq⟩ + · exact hpending.2 + · exact Or.inr hmaterialized + +theorem CleanProbeObservationsTrackedBy.ensure + {observations : List CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (htracked : CleanProbeObservationsTrackedBy observations state) + (coordinate : Coordinate) : + CleanProbeObservationsTrackedBy observations (state.ensure coordinate) := by + intro observation hobservation + exact (htracked observation hobservation).ensure coordinate + +theorem CleanProbeObservationsTrackedBy.addPending + {observations : List CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (htracked : CleanProbeObservationsTrackedBy observations state) + (coordinate : Coordinate) (candidate : Digest) : + CleanProbeObservationsTrackedBy observations + (state.addPending coordinate candidate) := by + intro observation hobservation + exact (htracked observation hobservation).addPending coordinate candidate + +theorem CleanProbeObservationsTrackedBy.publish + {observations : List CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (htracked : CleanProbeObservationsTrackedBy observations state) + (coordinate : Coordinate) : + CleanProbeObservationsTrackedBy observations (state.publish coordinate) := by + intro observation hobservation + exact (htracked observation hobservation).publish coordinate + +theorem CleanProbeObservationsTrackedBy.materialize + {observations : List CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (htracked : CleanProbeObservationsTrackedBy observations state) + (coordinate : Coordinate) (output : HashOutput) + (hvalue : state.values coordinate = none) + (hmiss : ¬state.hitAt coordinate output) : + CleanProbeObservationsTrackedBy observations + (state.materialize coordinate output) := by + intro observation hobservation + exact (htracked observation hobservation).materialize coordinate output hvalue hmiss + +theorem CleanProbeObservationsTrackedBy.complete + {observations : List CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (htracked : CleanProbeObservationsTrackedBy observations state) + (coordinate : Coordinate) (output : HashOutput) + (hvalue : state.values coordinate = none) + (hmiss : ¬state.hitAt coordinate output) : + CleanProbeObservationsTrackedBy observations + (state.complete coordinate output) := by + intro observation hobservation + exact (htracked observation hobservation).complete coordinate output hvalue hmiss + +theorem CleanProbeObservationsTrackedBy.clearPending + {observations : List CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (htracked : CleanProbeObservationsTrackedBy observations state) + (coordinate : Coordinate) (output : HashOutput) + (hvalue : state.values coordinate = some output) : + CleanProbeObservationsTrackedBy observations + (state.clearPending coordinate) := by + intro observation hobservation + exact (htracked observation hobservation).clearPending coordinate output hvalue + +theorem cleanProbeObservationsTrackedBy_append_revealed + {observations : List CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (htracked : CleanProbeObservationsTrackedBy observations state) + (coordinate : Coordinate) (candidate : Digest) + (hrevealed : coordinate ∈ state.revealed) : + CleanProbeObservationsTrackedBy + (observations ++ [cleanProbeObservation state coordinate candidate]) state := by + intro observation hobservation + simp only [List.mem_append, List.mem_singleton] at hobservation + rcases hobservation with hold | rfl + · exact htracked observation hold + · constructor + · intro output hvalue + simpa [cleanProbeObservation] using hvalue + · intro _hnone hhidden + simp [cleanProbeObservation, hrevealed] at hhidden + +theorem cleanProbeObservationsTrackedBy_append_hidden + {observations : List CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} + (htracked : CleanProbeObservationsTrackedBy observations state) + (coordinate : Coordinate) (candidate : Digest) + (hhidden : coordinate ∉ state.revealed) : + CleanProbeObservationsTrackedBy + (observations ++ [cleanProbeObservation state coordinate candidate]) + (state.addPending coordinate candidate) := by + intro observation hobservation + simp only [List.mem_append, List.mem_singleton] at hobservation + rcases hobservation with hold | rfl + · exact (htracked observation hold).addPending coordinate candidate + · constructor + · intro output hvalue + simpa [cleanProbeObservation, LazyRevealProbe.State.addPending] using hvalue + · intro hnone _hrevealed + exact Or.inl + ⟨by simp [cleanProbeObservation, LazyRevealProbe.State.addPending], hnone⟩ + +structure ObservedCleanRunResult (alpha : Type) where + state : LazyRevealProbe.State Coordinate + remaining : Nat + value : alpha + table : OtsSecretIndex → HashOutput + observations : List CleanProbeObservation + +def WitnessFirstUsesDelayedLayerRoot + (output : PrivateWitnessPlanOutput) + (observations : List CleanProbeObservation) : Prop := + ∃ witness, ∃ sourceOrdinal : Fin output.2.length, + ∃ observationOrdinal : Fin observations.length, + output.1 = some witness ∧ + sourceOrdinal.val = observationOrdinal.val ∧ + firstPrivateWitnessOrdinal? witness output.2 = some sourceOrdinal ∧ + (output.2.get sourceOrdinal).IsLayerRoot ∧ + (observations.get observationOrdinal).valueAtProbe = some witness.output + +set_option maxRecDepth 100000 in +theorem witnessFirstUsesDelayedLayerRoot_of_aligned_tracked + {output : PrivateWitnessPlanOutput} + {result : ObservedCleanRunResult α} + (hfirst : WitnessFirstUsesSomeLayerRoot output) + (halign : output.2.IsPrefix + (result.observations.map CleanProbeObservation.toProbe)) + (htracked : CleanProbeObservationsTrackedBy result.observations result.state) + (hstored : ∀ witness, output.1 = some witness → + result.state.values (Coordinate.position witness.position) = some witness.output) + (hselectedHidden : ∀ witness (sourceOrdinal : Fin output.2.length) + (observationOrdinal : Fin result.observations.length), + output.1 = some witness → + sourceOrdinal.val = observationOrdinal.val → + firstPrivateWitnessOrdinal? witness output.2 = some sourceOrdinal → + (result.observations.get observationOrdinal).revealedAtProbe = false) : + WitnessFirstUsesDelayedLayerRoot output result.observations := by + obtain ⟨ordinal, witness, sourceOrdinal, hwitness, hordinal, hsourceFirst, hroot⟩ := hfirst + have hlength : output.2.length ≤ result.observations.length := by + simpa using halign.length_le + let observationOrdinal : Fin result.observations.length := + ⟨sourceOrdinal.val, sourceOrdinal.isLt.trans_le hlength⟩ + have hordinalValue : sourceOrdinal.val = observationOrdinal.val := rfl + have hprobe : (result.observations.get observationOrdinal).toProbe = + output.2.get sourceOrdinal := by + rw [List.get_eq_getElem, List.get_eq_getElem] + change (result.observations[sourceOrdinal.val]).toProbe = + output.2[sourceOrdinal.val] + rw [halign.getElem sourceOrdinal.isLt, List.getElem_map] + have hmatch := privateWitnessAtOrdinal_of_firstPrivateWitnessOrdinal?_eq_some hsourceFirst + unfold PrivateWitnessAtOrdinal at hmatch + have hobservationCoordinate : + (result.observations.get observationOrdinal).coordinate = + Coordinate.position witness.position := by + exact congrArg Probe.coordinate hprobe |>.trans hmatch.1 + have hobservationCandidate : + (result.observations.get observationOrdinal).candidate = truncateHash witness.output := by + exact congrArg Probe.candidate hprobe |>.trans hmatch.2.symm + have hhidden := hselectedHidden witness sourceOrdinal observationOrdinal hwitness + hordinalValue hsourceFirst + have hobservationTracked := htracked (result.observations.get observationOrdinal) + (List.get_mem _ _) + cases hvalue : (result.observations.get observationOrdinal).valueAtProbe with + | none => + have hsafe := CleanProbeObservation.resolvedSafe_of_trackedBy hobservationTracked + have hfinalAtObservation : result.state.values + (result.observations.get observationOrdinal).coordinate = some witness.output := by + rw [hobservationCoordinate] + exact hstored witness hwitness + have hmismatch := hsafe hvalue hhidden witness.output hfinalAtObservation + exact False.elim (hmismatch (hobservationCandidate.symm)) + | some stored => + have hstoredAtFinal := hobservationTracked.1 stored hvalue + rw [hobservationCoordinate] at hstoredAtFinal + have hstoredEq : stored = witness.output := + Option.some.inj (hstoredAtFinal.symm.trans (hstored witness hwitness)) + subst stored + exact ⟨witness, sourceOrdinal, observationOrdinal, hwitness, + hordinalValue, hsourceFirst, hroot, hvalue⟩ + +def ObservedCleanRunResult.toClean + (result : ObservedCleanRunResult α) : CleanRunResult α := + ⟨result.state, result.remaining, result.value, result.table⟩ + +def projectObservedCleanRun : + Option (ObservedCleanRunResult α) → Option (CleanRunResult α) + | none => none + | some result => some result.toClean + +noncomputable def runObservedCleanFromTable + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + ProbComp (Option (ObservedCleanRunResult α)) := + OracleComp.construct + (C := fun _ : OracleComp (LazyRevealProbe.World Coordinate) α => + List CleanProbeObservation → LazyRevealProbe.State Coordinate → Nat → + (OtsSecretIndex → HashOutput) → + ProbComp (Option (ObservedCleanRunResult α))) + (fun value observations state remaining table => + pure (some ⟨state, remaining, value, table, observations⟩)) + (fun input _next recursivelyRun observations state fuel table => + match input with + | .uniform n => do + let output ← liftM (unifSpec.query n) + recursivelyRun output observations state fuel table + | .hashOutput => do + let output ← LazyRevealProbe.sampleHashOutput + recursivelyRun output observations state fuel table + | .ensure coordinate => + recursivelyRun () observations (state.ensure coordinate) fuel table + | .probe coordinate candidate => + match fuel with + | 0 => pure none + | remaining + 1 => + let observation := cleanProbeObservation state coordinate candidate + let nextObservations := observations ++ [observation] + if coordinate ∈ state.revealed then + recursivelyRun () nextObservations state remaining table + else + recursivelyRun () nextObservations + (state.addPending coordinate candidate) remaining table + | .peek coordinate => + recursivelyRun (state.values coordinate) observations state fuel table + | .publish coordinate => + recursivelyRun () observations (state.publish coordinate) fuel table + | .reveal coordinate => + match state.values coordinate with + | some output => recursivelyRun output observations state fuel table + | none => + match coordinate with + | .chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + if state.hitAt coordinate output then + pure none + else + recursivelyRun output observations + (state.materialize coordinate output) fuel table + | .position _ => do + let output ← LazyRevealProbe.sampleHashOutput + if state.hitAt coordinate output then + pure none + else + recursivelyRun output observations + (state.materialize coordinate output) fuel table) + computation observations state fuel table + +theorem runObservedCleanFromTable_probe_query_bind + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (candidate : Digest) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) α) : + runObservedCleanFromTable observations state fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.probe coordinate candidate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + match fuel with + | 0 => pure none + | remaining + 1 => + let observation := cleanProbeObservation state coordinate candidate + let nextObservations := observations ++ [observation] + if coordinate ∈ state.revealed then + runObservedCleanFromTable nextObservations state remaining table (next ()) + else + runObservedCleanFromTable nextObservations + (state.addPending coordinate candidate) remaining table (next ()) := by + rfl + +set_option maxRecDepth 100000 in +theorem cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (htracked : CleanProbeObservationsTrackedBy observations state) + (result : ObservedCleanRunResult α) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table computation)) : + CleanProbeObservationsTrackedBy result.observations result.state := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table with + | pure value => + simp [runObservedCleanFromTable] at hresult + subst result + exact htracked + | query_bind input next ih => + cases input with + | uniform n => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output observations state fuel table htracked hrest + | hashOutput => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output observations state fuel table htracked hrest + | ensure coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih () observations (state.ensure coordinate) fuel table + (htracked.ensure coordinate) hresult + | probe coordinate candidate => + rw [runObservedCleanFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · exact ih () + (observations ++ [cleanProbeObservation state coordinate candidate]) + state remaining table + (cleanProbeObservationsTrackedBy_append_revealed htracked coordinate candidate + hrevealed) + (by simpa [hrevealed] using hresult) + · exact ih () + (observations ++ [cleanProbeObservation state coordinate candidate]) + (state.addPending coordinate candidate) remaining table + (cleanProbeObservationsTrackedBy_append_hidden htracked coordinate candidate + hrevealed) + (by simpa [hrevealed] using hresult) + | peek coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih (state.values coordinate) observations state fuel table htracked hresult + | publish coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih () observations (state.publish coordinate) fuel table + (htracked.publish coordinate) hresult + | reveal coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + simp only [hvalue] at hresult + exact ih output observations state fuel table htracked hresult + | none => + simp only [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + change some result ∈ support + (runObservedCleanFromTable observations + (state.materialize (.chainStart lay tree leafIdx chainIdx) output) + fuel table (next output)) at hresult + exact ih output observations + (state.materialize (.chainStart lay tree leafIdx chainIdx) output) + fuel table + (htracked.materialize (.chainStart lay tree leafIdx chainIdx) output + hvalue hhit) + hresult + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : state.hitAt (.position position) output + · simp [hhit] at hrest + · simp only [hhit, ↓reduceIte] at hrest + change some result ∈ support + (runObservedCleanFromTable observations + (state.materialize (.position position) output) + fuel table (next output)) at hrest + exact ih output observations (state.materialize (.position position) output) + fuel table (htracked.materialize (.position position) output hvalue hhit) + hrest + +set_option maxRecDepth 100000 in +theorem cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hcovered : CleanProbeObservationsCoverPending observations state) + (result : ObservedCleanRunResult α) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table computation)) : + CleanProbeObservationsCoverPending result.observations result.state := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table with + | pure value => + simp [runObservedCleanFromTable] at hresult + subst result + exact hcovered + | query_bind input next ih => + cases input with + | uniform n => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output observations state fuel table hcovered hrest + | hashOutput => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output observations state fuel table hcovered hrest + | ensure coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih () observations (state.ensure coordinate) fuel table + (hcovered.ensure coordinate) hresult + | probe coordinate candidate => + rw [runObservedCleanFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · exact ih () + (observations ++ [cleanProbeObservation state coordinate candidate]) + state remaining table + (cleanProbeObservationsCoverPending_append_revealed hcovered coordinate + candidate) + (by simpa [hrevealed] using hresult) + · exact ih () + (observations ++ [cleanProbeObservation state coordinate candidate]) + (state.addPending coordinate candidate) remaining table + (cleanProbeObservationsCoverPending_append_hidden hcovered coordinate candidate + hrevealed) + (by simpa [hrevealed] using hresult) + | peek coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih (state.values coordinate) observations state fuel table hcovered hresult + | publish coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih () observations (state.publish coordinate) fuel table + (hcovered.publish coordinate) hresult + | reveal coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + simp only [hvalue] at hresult + exact ih output observations state fuel table hcovered hresult + | none => + simp only [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + change some result ∈ support + (runObservedCleanFromTable observations + (state.materialize (.chainStart lay tree leafIdx chainIdx) output) + fuel table (next output)) at hresult + exact ih output observations + (state.materialize (.chainStart lay tree leafIdx chainIdx) output) + fuel table (hcovered.materialize _ output) hresult + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : state.hitAt (.position position) output + · simp [hhit] at hrest + · simp only [hhit, ↓reduceIte] at hrest + change some result ∈ support + (runObservedCleanFromTable observations + (state.materialize (.position position) output) + fuel table (next output)) at hrest + exact ih output observations (state.materialize (.position position) output) + fuel table (hcovered.materialize _ output) hrest + +set_option maxRecDepth 100000 in +theorem remaining_add_pending_card_le_of_mem_runObservedCleanFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (result : ObservedCleanRunResult α) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table computation)) : + result.remaining + result.state.pending.card ≤ fuel + state.pending.card := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table with + | pure value => + simp [runObservedCleanFromTable] at hresult + subst result + simp + | query_bind input next ih => + cases input with + | uniform n => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output observations state fuel table hrest + | hashOutput => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output observations state fuel table hrest + | ensure coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + simpa only [LazyRevealProbe.State.pending_card_ensure] using + ih () observations (state.ensure coordinate) fuel table hresult + | probe coordinate candidate => + rw [runObservedCleanFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · have htail := ih () + (observations ++ [cleanProbeObservation state coordinate candidate]) + state remaining table (by simpa [hrevealed] using hresult) + omega + · have htail := ih () + (observations ++ [cleanProbeObservation state coordinate candidate]) + (state.addPending coordinate candidate) remaining table + (by simpa [hrevealed] using hresult) + have hadd := state.pending_card_addPending_le coordinate candidate + omega + | peek coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih (state.values coordinate) observations state fuel table hresult + | publish coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih () observations (state.publish coordinate) fuel table hresult + | reveal coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + simp only [hvalue] at hresult + exact ih output observations state fuel table hresult + | none => + simp only [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + have htail := ih output observations + (state.materialize (.chainStart lay tree leafIdx chainIdx) output) + fuel table hresult + have haway := state.pendingAway_card_add_pendingAt_card_le + (.chainStart lay tree leafIdx chainIdx) + simp only [LazyRevealProbe.State.pending_card_materialize] at htail + omega + + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : state.hitAt (.position position) output + · simp [hhit] at hrest + · simp only [hhit, ↓reduceIte] at hrest + have htail := ih output observations + (state.materialize (.position position) output) fuel table hrest + have haway := state.pendingAway_card_add_pendingAt_card_le + (.position position) + simp only [LazyRevealProbe.State.pending_card_materialize] at htail + omega + +set_option maxRecDepth 100000 in +theorem observations_length_add_remaining_eq_of_mem_runObservedCleanFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (result : ObservedCleanRunResult α) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table computation)) : + result.observations.length + result.remaining = observations.length + fuel := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table with + | pure value => + simp [runObservedCleanFromTable] at hresult + subst result + rfl + | query_bind input next ih => + cases input with + | uniform n => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output observations state fuel table hrest + | hashOutput => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output observations state fuel table hrest + | ensure coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih () observations (state.ensure coordinate) fuel table hresult + | probe coordinate candidate => + rw [runObservedCleanFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · have htail := ih () + (observations ++ [cleanProbeObservation state coordinate candidate]) + state remaining table (by simpa [hrevealed] using hresult) + simp only [List.length_append, List.length_singleton] at htail + omega + · have htail := ih () + (observations ++ [cleanProbeObservation state coordinate candidate]) + (state.addPending coordinate candidate) remaining table + (by simpa [hrevealed] using hresult) + simp only [List.length_append, List.length_singleton] at htail + omega + | peek coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih (state.values coordinate) observations state fuel table hresult + | publish coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih () observations (state.publish coordinate) fuel table hresult + | reveal coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + simp only [hvalue] at hresult + exact ih output observations state fuel table hresult + | none => + simp only [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + exact ih output observations + (state.materialize (.chainStart lay tree leafIdx chainIdx) output) + fuel table hresult + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : state.hitAt (.position position) output + · simp [hhit] at hrest + · simp only [hhit, ↓reduceIte] at hrest + exact ih output observations + (state.materialize (.position position) output) fuel table hrest + +set_option maxRecDepth 100000 in +theorem map_projectObservedCleanRun_runObservedCleanFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + projectObservedCleanRun <$> + runObservedCleanFromTable observations state fuel table computation = + runCleanFromTable state fuel table computation := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel with + | pure value => + simp [runObservedCleanFromTable, runCleanFromTable, projectObservedCleanRun, + ObservedCleanRunResult.toClean] + | query_bind input next ih => + cases input with + | uniform n => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + runCleanFromTable_uniform_query_bind, map_bind] + apply bind_congr + intro output + exact ih output observations state fuel + | hashOutput => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + runCleanFromTable_hashOutput_query_bind, map_bind] + apply bind_congr + intro output + exact ih output observations state fuel + | ensure coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + runCleanFromTable_ensure_query_bind] + exact ih () observations (state.ensure coordinate) fuel + | probe coordinate candidate => + rw [runObservedCleanFromTable_probe_query_bind, + runCleanFromTable_probe_query_bind] + cases fuel with + | zero => simp [projectObservedCleanRun] + | succ remaining => + let observation := cleanProbeObservation state coordinate candidate + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + simpa [observation, hrevealed] using + (ih () (observations ++ [observation]) state remaining) + · simp only [hrevealed, ↓reduceIte] + simpa [observation, hrevealed] using + (ih () (observations ++ [observation]) + (state.addPending coordinate candidate) remaining) + | peek coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + runCleanFromTable_peek_query_bind] + exact ih (state.values coordinate) observations state fuel + | publish coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + runCleanFromTable_publish_query_bind] + exact ih () observations (state.publish coordinate) fuel + | reveal coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + runCleanFromTable_reveal_query_bind] + cases hvalue : state.values coordinate with + | some output => + simp only [hvalue] + exact ih output observations state fuel + | none => + simp only [hvalue] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : state.hitAt (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit, projectObservedCleanRun] + · simp only [output, hhit, ↓reduceIte] + exact ih output observations + (state.materialize (.chainStart lay tree leafIdx chainIdx) output) fuel + | position position => + simp only [map_bind] + apply bind_congr + intro output + by_cases hhit : state.hitAt (.position position) output + · simp [hhit, projectObservedCleanRun] + · simp only [hhit, ↓reduceIte] + exact ih output observations + (state.materialize (.position position) output) fuel + +theorem startTableAgrees_of_mem_runObservedCleanFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hagrees : StartTableAgrees state table) + (result : ObservedCleanRunResult α) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table computation)) : + result.table = table ∧ StartTableAgrees result.state table := by + have hmapped : some result.toClean ∈ support + (projectObservedCleanRun <$> + runObservedCleanFromTable observations state fuel table computation) := by + rw [support_map, Set.mem_image] + exact ⟨some result, hresult, rfl⟩ + rw [map_projectObservedCleanRun_runObservedCleanFromTable] at hmapped + exact startTableAgrees_of_mem_runCleanFromTable computation state fuel table hagrees + result.toClean hmapped + +noncomputable def finishObservedCleanRunFromTable : + Option (ObservedCleanRunResult α) → + ProbComp (Option (ObservedCleanRunResult α)) + | none => pure none + | some result => do + let finalized ← finalizeCleanFromTable result.state.coordinates.toList + result.state result.table + match finalized with + | none => pure none + | some (finalState, finalTable) => + pure (some + ⟨finalState, result.remaining, result.value, finalTable, result.observations⟩) + +set_option maxRecDepth 100000 in +theorem cleanProbeObservationsTrackedBy_of_mem_finalizeCleanFromTable : + ∀ (coordinates : List Coordinate) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) + (observations : List CleanProbeObservation), + CleanProbeObservationsTrackedBy observations state → + ∀ finalState finalTable, + some (finalState, finalTable) ∈ support + (finalizeCleanFromTable coordinates state table) → + CleanProbeObservationsTrackedBy observations finalState + | [], state, table, observations, htracked, finalState, finalTable, hresult => by + simp [finalizeCleanFromTable] at hresult + obtain ⟨rfl, rfl⟩ := hresult + exact htracked + | coordinate :: remaining, state, table, observations, htracked, + finalState, finalTable, hresult => by + rw [finalizeCleanFromTable.eq_def] at hresult + cases hvalue : state.values coordinate with + | some output => + simp only [hvalue] at hresult + exact cleanProbeObservationsTrackedBy_of_mem_finalizeCleanFromTable remaining + (state.clearPending coordinate) table observations + (htracked.clearPending coordinate output hvalue) finalState finalTable hresult + | none => + simp only [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : state.hitAt (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + exact cleanProbeObservationsTrackedBy_of_mem_finalizeCleanFromTable remaining + (state.complete (.chainStart lay tree leafIdx chainIdx) output) table + observations + (htracked.complete (.chainStart lay tree leafIdx chainIdx) output hvalue hhit) + finalState finalTable hresult + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : state.hitAt (.position position) output + · simp [hhit] at hrest + · simp only [hhit, ↓reduceIte] at hrest + exact cleanProbeObservationsTrackedBy_of_mem_finalizeCleanFromTable remaining + (state.complete (.position position) output) table observations + (htracked.complete (.position position) output hvalue hhit) + finalState finalTable hrest + +theorem cleanProbeObservationsTrackedBy_of_mem_finishObservedCleanRunFromTable + (result finalResult : ObservedCleanRunResult α) + (htracked : CleanProbeObservationsTrackedBy result.observations result.state) + (hresult : some finalResult ∈ support + (finishObservedCleanRunFromTable (some result))) : + CleanProbeObservationsTrackedBy finalResult.observations finalResult.state := by + unfold finishObservedCleanRunFromTable at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨finalized, hfinalized, hreturn⟩ := hresult + cases finalized with + | none => simp at hreturn + | some value => + rcases value with ⟨finalState, finalTable⟩ + simp only [support_pure, Set.mem_singleton_iff, Option.some.injEq] at hreturn + obtain ⟨rfl, rfl, rfl, rfl, rfl⟩ := hreturn + exact cleanProbeObservationsTrackedBy_of_mem_finalizeCleanFromTable + result.state.coordinates.toList result.state result.table result.observations + htracked finalState finalTable hfinalized + +theorem map_projectObservedCleanRun_finishObservedCleanRunFromTable + (result : Option (ObservedCleanRunResult α)) : + projectObservedCleanRun <$> finishObservedCleanRunFromTable result = + finishCleanRunFromTable (projectObservedCleanRun result) := by + cases result with + | none => simp [finishObservedCleanRunFromTable, finishCleanRunFromTable, + projectObservedCleanRun] + | some result => + unfold finishObservedCleanRunFromTable finishCleanRunFromTable + rw [map_bind] + apply bind_congr + intro finalized + cases finalized <;> + simp [projectObservedCleanRun, ObservedCleanRunResult.toClean] + +theorem map_projectObservedCleanRun_bind_finishObservedCleanRunFromTable + (run : ProbComp (Option (ObservedCleanRunResult α))) : + projectObservedCleanRun <$> (run >>= finishObservedCleanRunFromTable) = + (projectObservedCleanRun <$> run) >>= finishCleanRunFromTable := by + calc + _ = run >>= fun result => + projectObservedCleanRun <$> finishObservedCleanRunFromTable result := map_bind _ _ _ + _ = run >>= fun result => + finishCleanRunFromTable (projectObservedCleanRun result) := by + apply bind_congr + intro result + exact map_projectObservedCleanRun_finishObservedCleanRunFromTable result + _ = _ := by simp [map_eq_bind_pure_comp, bind_assoc] + +noncomputable def sampledObservedRootAwareClean + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp (Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))) := do + let base ← sampleOtsHashTable + let table := completedStartTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) base + let result ← runObservedCleanFromTable [] LazyRevealProbe.State.empty fuel table + (rootAwareCleanRetainedRun adversary parameter ftsSecret) + finishObservedCleanRunFromTable result + +set_option maxRecDepth 100000 in +theorem map_projectObservedCleanRun_sampledObservedRootAwareClean + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + projectObservedCleanRun <$> + sampledObservedRootAwareClean adversary parameter ftsSecret fuel = + sampledRunThenFinalizeClean + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel + (rootAwareCleanRetainedRun adversary parameter ftsSecret) := by + unfold sampledObservedRootAwareClean sampledRunThenFinalizeClean + rw [map_bind] + apply bind_congr + intro base + dsimp only + rw [map_projectObservedCleanRun_bind_finishObservedCleanRunFromTable, + map_projectObservedCleanRun_runObservedCleanFromTable] + +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledObservedRootAwareClean_none_le + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash q) : + Pr[= none | + sampledObservedRootAwareClean adversary parameter ftsSecret q] ≤ + (q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ = Pr[= none | projectObservedCleanRun <$> + sampledObservedRootAwareClean adversary parameter ftsSecret q] := by + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput, probEvent_map] + apply OracleComp.probEvent_congr' + · intro result _hresult + cases result <;> simp [projectObservedCleanRun] + · rfl + _ = Pr[= none | sampledRunThenFinalizeClean + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) q + (rootAwareCleanRetainedRun adversary parameter ftsSecret)] := + OracleComp.probOutput_congr rfl + (congrArg evalDist + (map_projectObservedCleanRun_sampledObservedRootAwareClean adversary parameter + ftsSecret q)) + _ ≤ _ := probEvent_sampledRootAwareCleanRetainedRun_none_le adversary parameter + ftsSecret q hbound + +theorem probEvent_le_failure_add_residual_of_relTriple + (left : ProbComp α) (right : ProbComp β) + (relation : α → β → Prop) + (event residual : α → Prop) (failure : β → Prop) + (hrel : RelTriple left right relation) + (hclassify : ∀ leftOutput rightOutput, + relation leftOutput rightOutput → event leftOutput → + ¬residual leftOutput → failure rightOutput) : + Pr[event | left] ≤ Pr[failure | right] + Pr[residual | left] := by + calc + _ = Pr[fun output => + (event output ∧ residual output) ∨ + (event output ∧ ¬residual output) | left] := by + apply OracleComp.probEvent_congr' + intro output _houtput + tauto + rfl + _ ≤ Pr[fun output => event output ∧ residual output | left] + + Pr[fun output => event output ∧ ¬residual output | left] := + probEvent_or_le _ _ _ + _ ≤ Pr[residual | left] + Pr[failure | right] := by + apply add_le_add + · apply probEvent_mono + intro output _houtput hboth + exact hboth.2 + · apply probEvent_le_of_relTriple hrel + intro leftOutput rightOutput hrelation hboth + exact hclassify leftOutput rightOutput hrelation hboth.1 hboth.2 + _ = Pr[failure | right] + Pr[residual | left] := add_comm _ _ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassification.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassification.lean new file mode 100644 index 00000000..d1dcd264 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassification.lean @@ -0,0 +1,562 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalProbability + +/-! +# Sound global root classification + +Guarded finalization conflates a fresh completion hit with a probe that matches a hidden value +materialized by an earlier outer query. This file keeps that distinction explicit. The ordinary +unguarded finalizer accounts for the fresh branch, while a Boolean records whether the state was +already non-completable before finalization. The latter branch is retained for the delayed-root +classification instead of being charged as fresh randomness. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def CleanProbeObservation.ExistingHiddenHit + (observation : CleanProbeObservation) : Prop := + observation.revealedAtProbe = false ∧ + ∃ output, observation.valueAtProbe = some output ∧ + truncateHash output = observation.candidate + +def CleanProbeObservation.ExistingHiddenRootHit + (observation : CleanProbeObservation) : Prop := + observation.ExistingHiddenHit ∧ observation.toProbe.IsLayerRoot + +def CleanProbeObservation.ExistingHiddenNonRootHit + (observation : CleanProbeObservation) : Prop := + observation.ExistingHiddenHit ∧ ¬observation.toProbe.IsLayerRoot + +def ObservedCleanRunResult.HasExistingHiddenHit + (result : ObservedCleanRunResult α) : Prop := + ∃ observation ∈ result.observations, observation.ExistingHiddenHit + +def ObservedCleanRunResult.HasExistingHiddenRootHit + (result : ObservedCleanRunResult α) : Prop := + ∃ observation ∈ result.observations, observation.ExistingHiddenRootHit + +def ObservedCleanRunResult.HasExistingHiddenNonRootHit + (result : ObservedCleanRunResult α) : Prop := + ∃ observation ∈ result.observations, observation.ExistingHiddenNonRootHit + +theorem ObservedCleanRunResult.existingHidden_root_or_nonRoot + {result : ObservedCleanRunResult α} + (hhit : result.HasExistingHiddenHit) : + result.HasExistingHiddenRootHit ∨ result.HasExistingHiddenNonRootHit := by + classical + obtain ⟨observation, hobservation, hhit⟩ := hhit + by_cases hroot : observation.toProbe.IsLayerRoot + · exact Or.inl ⟨observation, hobservation, hhit, hroot⟩ + · exact Or.inr ⟨observation, hobservation, hhit, hroot⟩ + +def ExistingHiddenHitAtOrdinal + (result : ObservedCleanRunResult α) (ordinal : Fin result.observations.length) : Prop := + (result.observations.get ordinal).ExistingHiddenHit + +def FirstExistingHiddenHitAt + (result : ObservedCleanRunResult α) (ordinal : Nat) : Prop := + ∃ selected : Fin result.observations.length, + selected.val = ordinal ∧ ExistingHiddenHitAtOrdinal result selected ∧ + ∀ earlier : Fin result.observations.length, + earlier.val < ordinal → ¬ExistingHiddenHitAtOrdinal result earlier + +noncomputable def firstExistingHiddenHitOrdinal? + (result : ObservedCleanRunResult α) : Option (Fin result.observations.length) := by + classical + let matching := Finset.univ.filter fun ordinal : Fin result.observations.length => + ExistingHiddenHitAtOrdinal result ordinal + exact if h : matching.Nonempty then some (matching.min' h) else none + +theorem firstExistingHiddenHitOrdinal?_eq_some_of_hasExistingHiddenHit + (result : ObservedCleanRunResult α) (hhit : result.HasExistingHiddenHit) : + ∃ ordinal, firstExistingHiddenHitOrdinal? result = some ordinal ∧ + ExistingHiddenHitAtOrdinal result ordinal := by + classical + obtain ⟨observation, hobservation, hhit⟩ := hhit + obtain ⟨ordinal, hordinal⟩ := List.mem_iff_get.mp hobservation + let matching := Finset.univ.filter fun selected : Fin result.observations.length => + ExistingHiddenHitAtOrdinal result selected + have hmatching : matching.Nonempty := by + refine ⟨ordinal, Finset.mem_filter.mpr ⟨Finset.mem_univ _, ?_⟩⟩ + rw [ExistingHiddenHitAtOrdinal, hordinal] + exact hhit + unfold firstExistingHiddenHitOrdinal? + simp only [matching, hmatching, dif_pos] + refine ⟨matching.min' hmatching, rfl, ?_⟩ + exact (Finset.mem_filter.mp (matching.min'_mem hmatching)).2 + +theorem existingHiddenHitAtOrdinal_of_firstExistingHiddenHitOrdinal?_eq_some + {result : ObservedCleanRunResult α} + {ordinal : Fin result.observations.length} + (hfirst : firstExistingHiddenHitOrdinal? result = some ordinal) : + ExistingHiddenHitAtOrdinal result ordinal := by + classical + let matching := Finset.univ.filter fun selected : Fin result.observations.length => + ExistingHiddenHitAtOrdinal result selected + unfold firstExistingHiddenHitOrdinal? at hfirst + change (if h : matching.Nonempty then some (matching.min' h) else none) = some ordinal at hfirst + split at hfirst + next hmatching => + have heq : matching.min' hmatching = ordinal := Option.some.inj hfirst + rw [← heq] + exact (Finset.mem_filter.mp (matching.min'_mem hmatching)).2 + next hmatching => simp at hfirst + +theorem not_existingHiddenHitAtOrdinal_before_first + {result : ObservedCleanRunResult α} + {ordinal : Fin result.observations.length} + (hfirst : firstExistingHiddenHitOrdinal? result = some ordinal) + (earlier : Fin result.observations.length) + (hlt : earlier.val < ordinal.val) : + ¬ExistingHiddenHitAtOrdinal result earlier := by + classical + let matching := Finset.univ.filter fun selected : Fin result.observations.length => + ExistingHiddenHitAtOrdinal result selected + unfold firstExistingHiddenHitOrdinal? at hfirst + change (if h : matching.Nonempty then some (matching.min' h) else none) = some ordinal at hfirst + split at hfirst + next hmatching => + have heq : matching.min' hmatching = ordinal := Option.some.inj hfirst + intro hearlier + have hearlierMem : earlier ∈ matching := + Finset.mem_filter.mpr ⟨Finset.mem_univ _, hearlier⟩ + have hle := matching.min'_le earlier hearlierMem + rw [heq] at hle + exact (Nat.not_le_of_lt hlt) hle + next hmatching => simp at hfirst + +theorem firstExistingHiddenHitAt_of_firstExistingHiddenHitOrdinal?_eq_some + {result : ObservedCleanRunResult α} + {ordinal : Fin result.observations.length} + (hfirst : firstExistingHiddenHitOrdinal? result = some ordinal) : + FirstExistingHiddenHitAt result ordinal.val := by + refine ⟨ordinal, rfl, + existingHiddenHitAtOrdinal_of_firstExistingHiddenHitOrdinal?_eq_some hfirst, ?_⟩ + intro earlier hlt + exact not_existingHiddenHitAtOrdinal_before_first hfirst earlier hlt + +theorem directDeferredContext_valid_of_no_existingHiddenHit + (result : ObservedCleanRunResult α) + (htracked : CleanProbeObservationsTrackedBy result.observations result.state) + (hcovered : CleanProbeObservationsCoverPending result.observations result.state) + (hnohit : ¬result.HasExistingHiddenHit) : + (directDeferredContext result.state).Valid := by + constructor + · intro position output hvalue + simpa [directDeferredContext, directDeferredValues] using hvalue + · intro coordinate output hvalue hhit + change result.state.values coordinate = some output at hvalue + change truncateHash output ∈ result.state.pendingAt coordinate at hhit + have hpending : (coordinate, truncateHash output) ∈ result.state.pending := + (LazyRevealProbe.State.mem_pendingAt_iff result.state coordinate + (truncateHash output)).1 hhit + obtain ⟨observation, hobservation, hcoordinate, hcandidate, hhidden⟩ := + hcovered (coordinate, truncateHash output) hpending + have hobservationTracked := htracked observation hobservation + cases hatProbe : observation.valueAtProbe with + | none => + rcases hobservationTracked.2 hatProbe hhidden with hpending | hmaterialized + · rw [hcoordinate, hvalue] at hpending + simp at hpending + · obtain ⟨stored, hstored, hmismatch⟩ := hmaterialized + rw [hcoordinate] at hstored + have hsame : stored = output := Option.some.inj (hstored.symm.trans hvalue) + subst stored + exact hmismatch hcandidate.symm + | some stored => + have hstored := hobservationTracked.1 stored hatProbe + rw [hcoordinate] at hstored + have hsame : stored = output := Option.some.inj (hstored.symm.trans hvalue) + subst stored + apply hnohit + exact ⟨observation, hobservation, hhidden, output, hatProbe, hcandidate.symm⟩ + +theorem not_missingChainStartHit_of_mem_finishObservedCleanRunFromTable + (result finalResult : ObservedCleanRunResult α) + (hfinal : some finalResult ∈ support + (finishObservedCleanRunFromTable (some result))) : + ¬MissingChainStartHit result.table (directDeferredContext result.state) := by + rintro ⟨index, hvalue, hhit⟩ + have hstateValue : result.state.values index.coordinate = none := by + simpa only [directDeferredContext] using hvalue + have hmem : index.coordinate ∈ result.state.coordinates := by + by_contra hnotMem + exact (not_hitAt_of_not_mem_coordinates result.state index.coordinate + (result.table index) hnotMem) hhit + unfold finishObservedCleanRunFromTable at hfinal + rw [mem_support_bind_iff] at hfinal + obtain ⟨finalized, hfinalized, hreturn⟩ := hfinal + cases finalized with + | none => simp at hreturn + | some value => + rcases value with ⟨finalState, finalTable⟩ + have hexpose := evalDist_finalizeCleanFromTable_finset_expose_missing + index.coordinate result.state.coordinates result.state result.table hmem hstateValue + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + have hhit' : result.state.hitAt (.chainStart lay tree leafIdx chainIdx) + (result.table ⟨lay, tree, leafIdx, chainIdx⟩) := by + simpa only [directDeferredContext, OtsSecretIndex.coordinate] using hhit + rw [mem_support_iff_evalDist_apply_ne_zero] at hfinalized + change evalDist + (finalizeCleanFromTable result.state.coordinates.toList result.state result.table) + (some (finalState, finalTable)) ≠ 0 at hfinalized + rw [hexpose] at hfinalized + simpa [OtsSecretIndex.coordinate, completionOutputFromTable, hhit'] using hfinalized + +theorem hasExistingHiddenHit_of_doomed_finished + (table : OtsSecretIndex → HashOutput) + (result finalResult : ObservedCleanRunResult α) + (htable : result.table = table) + (hdoomed : DoomedResolvedContext table (directDeferredContext result.state)) + (htracked : CleanProbeObservationsTrackedBy result.observations result.state) + (hcovered : CleanProbeObservationsCoverPending result.observations result.state) + (hcard : result.state.pending.card < Fintype.card Digest) + (hfinal : some finalResult ∈ support + (finishObservedCleanRunFromTable (some result))) : + result.HasExistingHiddenHit := by + by_contra hnohit + have hvalid := directDeferredContext_valid_of_no_existingHiddenHit result htracked hcovered + hnohit + have hcause := privateStructuralHit_or_missingChainStartHit_of_not_completable + table (directDeferredContext result.state) hvalid hdoomed.2.1 hcard hdoomed.2.2 + have hnotPrivate := not_privateStructuralHit_of_directDeferredContext + (directDeferredContext result.state) rfl + have hmissing : MissingChainStartHit table (directDeferredContext result.state) := + hcause.resolve_left hnotPrivate + rw [← htable] at hmissing + exact not_missingChainStartHit_of_mem_finishObservedCleanRunFromTable result finalResult hfinal + hmissing + +structure ObservedMaterializedDiagnostic (alpha : Type) where + before : Option (ObservedCleanRunResult alpha) + final : Option (ObservedCleanRunResult alpha) + wasDoomed : Bool + +def ObservedMaterializedDiagnostic.HasExistingHiddenHit + (outcome : ObservedMaterializedDiagnostic α) : Prop := + ∃ result, outcome.before = some result ∧ result.HasExistingHiddenHit + +def ObservedMaterializedDiagnostic.HasExistingHiddenRootHit + (outcome : ObservedMaterializedDiagnostic α) : Prop := + ∃ result, outcome.before = some result ∧ result.HasExistingHiddenRootHit + +def ObservedMaterializedDiagnostic.HasExistingHiddenNonRootHit + (outcome : ObservedMaterializedDiagnostic α) : Prop := + ∃ result, outcome.before = some result ∧ result.HasExistingHiddenNonRootHit + +def ObservedMaterializedDiagnostic.FirstExistingHiddenRootHitOrdinal + (ordinal : Nat) (outcome : ObservedMaterializedDiagnostic α) : Prop := + ∃ result sourceOrdinal, + outcome.before = some result ∧ sourceOrdinal.val = ordinal ∧ + firstExistingHiddenHitOrdinal? result = some sourceOrdinal ∧ + (result.observations.get sourceOrdinal).toProbe.IsLayerRoot + +def ObservedMaterializedDiagnostic.FirstExistingHiddenNonRootHitOrdinal + (ordinal : Nat) (outcome : ObservedMaterializedDiagnostic α) : Prop := + ∃ result sourceOrdinal, + outcome.before = some result ∧ sourceOrdinal.val = ordinal ∧ + firstExistingHiddenHitOrdinal? result = some sourceOrdinal ∧ + ¬(result.observations.get sourceOrdinal).toProbe.IsLayerRoot + +def ObservedMaterializedDiagnostic.FirstExistingHiddenRootHitAt + (ordinal : Nat) (outcome : ObservedMaterializedDiagnostic α) : Prop := + ∃ result selected, + outcome.before = some result ∧ selected.val = ordinal ∧ + FirstExistingHiddenHitAt result ordinal ∧ + (result.observations.get selected).toProbe.IsLayerRoot + +def ObservedMaterializedDiagnostic.FirstExistingHiddenNonRootHitAt + (ordinal : Nat) (outcome : ObservedMaterializedDiagnostic α) : Prop := + ∃ result selected, + outcome.before = some result ∧ selected.val = ordinal ∧ + FirstExistingHiddenHitAt result ordinal ∧ + ¬(result.observations.get selected).toProbe.IsLayerRoot + +theorem ObservedMaterializedDiagnostic.firstExistingHiddenRootHitAt_of_ordinal + {outcome : ObservedMaterializedDiagnostic α} {ordinal : Nat} + (hroot : outcome.FirstExistingHiddenRootHitOrdinal ordinal) : + outcome.FirstExistingHiddenRootHitAt ordinal := by + obtain ⟨result, selected, hbefore, hordinal, hfirst, hroot⟩ := hroot + exact ⟨result, selected, hbefore, hordinal, + hordinal ▸ firstExistingHiddenHitAt_of_firstExistingHiddenHitOrdinal?_eq_some hfirst, hroot⟩ + +theorem ObservedMaterializedDiagnostic.firstExistingHiddenNonRootHitAt_of_ordinal + {outcome : ObservedMaterializedDiagnostic α} {ordinal : Nat} + (hnonRoot : outcome.FirstExistingHiddenNonRootHitOrdinal ordinal) : + outcome.FirstExistingHiddenNonRootHitAt ordinal := by + obtain ⟨result, selected, hbefore, hordinal, hfirst, hnonRoot⟩ := hnonRoot + exact ⟨result, selected, hbefore, hordinal, + hordinal ▸ firstExistingHiddenHitAt_of_firstExistingHiddenHitOrdinal?_eq_some hfirst, + hnonRoot⟩ + +theorem ObservedMaterializedDiagnostic.firstExistingHiddenRootHitOrdinal_hit + {outcome : ObservedMaterializedDiagnostic α} {ordinal : Nat} + (hroot : outcome.FirstExistingHiddenRootHitOrdinal ordinal) : + ∃ result sourceOrdinal, + outcome.before = some result ∧ sourceOrdinal.val = ordinal ∧ + ExistingHiddenHitAtOrdinal result sourceOrdinal ∧ + (result.observations.get sourceOrdinal).toProbe.IsLayerRoot := by + obtain ⟨result, sourceOrdinal, hbefore, hordinal, hfirst, hroot⟩ := hroot + exact ⟨result, sourceOrdinal, hbefore, hordinal, + existingHiddenHitAtOrdinal_of_firstExistingHiddenHitOrdinal?_eq_some hfirst, hroot⟩ + +theorem ObservedMaterializedDiagnostic.firstExistingHiddenNonRootHitOrdinal_hit + {outcome : ObservedMaterializedDiagnostic α} {ordinal : Nat} + (hnonRoot : outcome.FirstExistingHiddenNonRootHitOrdinal ordinal) : + ∃ result sourceOrdinal, + outcome.before = some result ∧ sourceOrdinal.val = ordinal ∧ + ExistingHiddenHitAtOrdinal result sourceOrdinal ∧ + ¬(result.observations.get sourceOrdinal).toProbe.IsLayerRoot := by + obtain ⟨result, sourceOrdinal, hbefore, hordinal, hfirst, hnonRoot⟩ := hnonRoot + exact ⟨result, sourceOrdinal, hbefore, hordinal, + existingHiddenHitAtOrdinal_of_firstExistingHiddenHitOrdinal?_eq_some hfirst, hnonRoot⟩ + +theorem ObservedMaterializedDiagnostic.firstExistingHidden_root_or_nonRoot + {outcome : ObservedMaterializedDiagnostic α} + (hhit : outcome.HasExistingHiddenHit) : + (∃ ordinal, outcome.FirstExistingHiddenRootHitOrdinal ordinal) ∨ + ∃ ordinal, outcome.FirstExistingHiddenNonRootHitOrdinal ordinal := by + classical + obtain ⟨result, hbefore, hhit⟩ := hhit + obtain ⟨sourceOrdinal, hfirst, _hhitAt⟩ := + firstExistingHiddenHitOrdinal?_eq_some_of_hasExistingHiddenHit result hhit + by_cases hroot : (result.observations.get sourceOrdinal).toProbe.IsLayerRoot + · exact Or.inl ⟨sourceOrdinal.val, result, sourceOrdinal, hbefore, rfl, hfirst, hroot⟩ + · exact Or.inr ⟨sourceOrdinal.val, result, sourceOrdinal, hbefore, rfl, hfirst, hroot⟩ + +theorem ObservedMaterializedDiagnostic.existingHidden_root_or_nonRoot + {outcome : ObservedMaterializedDiagnostic α} + (hhit : outcome.HasExistingHiddenHit) : + outcome.HasExistingHiddenRootHit ∨ outcome.HasExistingHiddenNonRootHit := by + obtain ⟨result, hbefore, hhit⟩ := hhit + exact (result.existingHidden_root_or_nonRoot hhit).imp + (fun hroot => ⟨result, hbefore, hroot⟩) + (fun hnonRoot => ⟨result, hbefore, hnonRoot⟩) + +theorem probEvent_diagnostic_existingHidden_le_root_add_nonRoot + (run : ProbComp (ObservedMaterializedDiagnostic α)) : + Pr[ObservedMaterializedDiagnostic.HasExistingHiddenHit | run] ≤ + Pr[ObservedMaterializedDiagnostic.HasExistingHiddenRootHit | run] + + Pr[ObservedMaterializedDiagnostic.HasExistingHiddenNonRootHit | run] := by + calc + _ ≤ Pr[fun outcome => outcome.HasExistingHiddenRootHit ∨ + outcome.HasExistingHiddenNonRootHit | run] := by + apply probEvent_mono + intro outcome _ hhit + exact outcome.existingHidden_root_or_nonRoot hhit + _ ≤ _ := probEvent_or_le _ _ _ + +def ObservedMaterializedDiagnostic.Bad + (outcome : ObservedMaterializedDiagnostic alpha) : Prop := + outcome.final = none ∨ outcome.wasDoomed = true + +def ObservedMaterializedDiagnostic.SuccessfulDoomed + (outcome : ObservedMaterializedDiagnostic alpha) : Prop := + outcome.final.isSome = true ∧ outcome.wasDoomed = true + +theorem probEvent_diagnosticBad_le_finalNone_add_successfulDoomed + (run : ProbComp (ObservedMaterializedDiagnostic alpha)) : + Pr[ObservedMaterializedDiagnostic.Bad | run] ≤ + Pr[fun outcome => outcome.final = none | run] + + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | run] := by + calc + _ ≤ Pr[fun outcome => outcome.final = none ∨ + outcome.SuccessfulDoomed | run] := by + apply probEvent_mono + intro outcome _ hbad + rcases hbad with hnone | hdoomed + · exact Or.inl hnone + · cases hfinal : outcome.final with + | none => exact Or.inl rfl + | some result => exact Or.inr ⟨by simp [hfinal], hdoomed⟩ + _ ≤ _ := probEvent_or_le _ _ _ + +noncomputable def finishObservedMaterializedDiagnostic + (table : OtsSecretIndex → HashOutput) + (result : Option (ObservedCleanRunResult alpha)) : + ProbComp (ObservedMaterializedDiagnostic alpha) := by + classical + match result with + | none => exact pure ⟨none, none, false⟩ + | some result => + exact do + let final ← finishObservedCleanRunFromTable (some result) + pure ⟨some result, final, + decide (¬DeferredCompletable table (directDeferredContext result.state))⟩ + +noncomputable def sampledObservedMaterializedDiagnostic + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp (ObservedMaterializedDiagnostic + (RetainedGameResult × SplitHashCache)) := do + let table ← sampleOtsHashTable + let result ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table + finishObservedMaterializedDiagnostic table result + +def ObservedMaterializedDiagnostic.project + (outcome : ObservedMaterializedDiagnostic alpha) : + Option (CleanRunResult alpha) := + projectObservedCleanRun outcome.final + +theorem map_project_finishObservedMaterializedDiagnostic + (table : OtsSecretIndex → HashOutput) + (result : Option (ObservedCleanRunResult alpha)) : + ObservedMaterializedDiagnostic.project <$> + finishObservedMaterializedDiagnostic table result = + finishCleanRunFromTable (projectObservedCleanRun result) := by + classical + cases result with + | none => + simp [finishObservedMaterializedDiagnostic, + ObservedMaterializedDiagnostic.project, projectObservedCleanRun, + finishCleanRunFromTable] + | some result => + unfold finishObservedMaterializedDiagnostic + rw [map_bind] + calc + _ = projectObservedCleanRun <$> + finishObservedCleanRunFromTable (some result) := by + apply bind_congr + intro final + rfl + _ = _ := map_projectObservedCleanRun_finishObservedCleanRunFromTable (some result) + +set_option maxRecDepth 100000 in +theorem map_project_sampledObservedMaterializedDiagnostic + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ObservedMaterializedDiagnostic.project <$> + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel = + sampledMaterializedCleanUnguarded adversary parameter ftsSecret fuel := by + unfold sampledObservedMaterializedDiagnostic sampledMaterializedCleanUnguarded + rw [map_bind] + apply bind_congr + intro table + rw [map_bind] + calc + _ = observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table >>= + fun result => finishCleanRunFromTable (projectObservedCleanRun result) := by + apply bind_congr + intro result + exact map_project_finishObservedMaterializedDiagnostic table result + _ = (projectObservedCleanRun <$> + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table) >>= + finishCleanRunFromTable := by + rw [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro result + rfl + _ = _ := by + rw [map_projectObservedCleanRun_observedMaterializedRetainedRunFromTable] + +theorem probEvent_sampledObservedMaterializedDiagnostic_final_none_eq + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun outcome => outcome.final = none | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel] = + Pr[= none | sampledMaterializedCleanUnguarded adversary parameter ftsSecret fuel] := by + calc + _ = Pr[= none | ObservedMaterializedDiagnostic.project <$> + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel] := by + rw [← probEvent_eq_eq_probOutput, probEvent_map] + exact OracleComp.probEvent_congr' (fun outcome _ => by + rcases outcome with ⟨before, final, doomed⟩ + cases final <;> + simp [ObservedMaterializedDiagnostic.project, projectObservedCleanRun]) rfl + _ = _ := OracleComp.probOutput_congr rfl + (congrArg evalDist + (map_project_sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel)) + +theorem probEvent_sampledObservedMaterializedDiagnostic_final_none_le + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hbudget : q ≤ fuel) : + Pr[fun outcome => outcome.final = none | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel] ≤ + (fuel : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + rw [probEvent_sampledObservedMaterializedDiagnostic_final_none_eq] + exact probEvent_sampledMaterializedCleanUnguarded_none_le_of_fuel adversary parameter + ftsSecret fuel q hbound hbudget + +def SnapshotObservedDiagnosticRootRel + (source : PrivateWitnessSnapshotOutput) + (outcome : ObservedMaterializedDiagnostic + (RetainedGameResult × SplitHashCache)) : Prop := + outcome.Bad ∨ + (WitnessFirstUsesSomeLayerRoot (erasePrivateWitnessSnapshotOutput source) → + WitnessFirstUsesSomeDelayedLayerRootSnapshot source) + +set_option maxRecDepth 100000 in +theorem relTriple_pure_finishObservedDiagnostic_of_rootOrDoomed + (table : OtsSecretIndex → HashOutput) + (source : PrivateWitnessSnapshotOutput) + (observed : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))) + (hrelation : SnapshotObservedRootOrDoomedRel table source observed) : + RelTriple + (pure source : ProbComp PrivateWitnessSnapshotOutput) + (finishObservedMaterializedDiagnostic table observed) + SnapshotObservedDiagnosticRootRel := by + rcases hrelation with hfailed | hsuccess | hdoomed + · subst observed + simp [finishObservedMaterializedDiagnostic, SnapshotObservedDiagnosticRootRel, + ObservedMaterializedDiagnostic.Bad] + · obtain ⟨result, hresult, himplication⟩ := hsuccess + subst observed + have hbase := relTriple_true + (pure source : ProbComp PrivateWitnessSnapshotOutput) + (finishObservedCleanRunFromTable (some result)) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun output => output = source) (by intro output houtput; simpa using houtput) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_bind hboth + intro left final hfinal + have hleftEq : left = source := hfinal.1.2 + subst left + apply relTriple_pure_pure + cases final with + | none => + left + left + rfl + | some finalResult => + right + exact himplication + · obtain ⟨result, hresult, hdoomedContext⟩ := hdoomed + subst observed + have hbase := relTriple_true + (pure source : ProbComp PrivateWitnessSnapshotOutput) + (finishObservedCleanRunFromTable (some result)) + apply relTriple_bind hbase + intro _ final _ + apply relTriple_pure_pure + left + right + simp [hdoomedContext.2.2] + +set_option maxRecDepth 100000 in +theorem relTriple_finishObservedDiagnostic_of_rootOrDoomed + (table : OtsSecretIndex → HashOutput) + (source : ProbComp PrivateWitnessSnapshotOutput) + (observed : ProbComp (Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)))) + (hrelation : RelTriple source observed (SnapshotObservedRootOrDoomedRel table)) : + RelTriple source + (observed >>= finishObservedMaterializedDiagnostic table) + SnapshotObservedDiagnosticRootRel := by + have hbound := relTriple_bind hrelation fun sourceOutput observedOutput houtput => + relTriple_pure_finishObservedDiagnostic_of_rootOrDoomed table sourceOutput observedOutput + houtput + simpa using hbound + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationKernel.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationKernel.lean new file mode 100644 index 00000000..3ed0ce14 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationKernel.lean @@ -0,0 +1,152 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassification + +/-! +# Fixed-table diagnostic root kernel + +The operational root-or-doomed coupling is composed with the diagnostic finalizer in this separate +module so the resulting relational proof term is compiled once before table sampling. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_granularAllCanonical_diagnosticRootRel + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + RelTriple + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q) + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table >>= + finishObservedMaterializedDiagnostic table) + SnapshotObservedDiagnosticRootRel := by + exact relTriple_finishObservedDiagnostic_of_rootOrDoomed table _ _ + (relTriple_granularAllCanonical_observedMaterialized_rootOrDoomed adversary parameter + ftsSecret q table hbound) + +attribute [local irreducible] observedMaterializedRetainedRunFromTable in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem hasExistingHiddenHit_of_mem_diagnosticFromTable_successfulDoomed + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hq : q ≤ 2 ^ securityBits) + (outcome : ObservedMaterializedDiagnostic + (RetainedGameResult × SplitHashCache)) + (houtcome : outcome ∈ support + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table >>= + finishObservedMaterializedDiagnostic table)) + (hsuccess : outcome.SuccessfulDoomed) : + outcome.HasExistingHiddenHit := by + classical + rw [mem_support_bind_iff] at houtcome + obtain ⟨before?, hbefore, hfinish⟩ := houtcome + cases before? with + | none => + have houtcomeEq : outcome = ⟨none, none, false⟩ := by + simpa [finishObservedMaterializedDiagnostic] using hfinish + have hfinalNone : outcome.final = none := congrArg + ObservedMaterializedDiagnostic.final houtcomeEq + simp [ObservedMaterializedDiagnostic.SuccessfulDoomed, hfinalNone] at hsuccess + | some before => + unfold finishObservedMaterializedDiagnostic at hfinish + rw [mem_support_bind_iff] at hfinish + obtain ⟨final?, hfinal, hreturn⟩ := hfinish + cases final? with + | none => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hfinalNone : outcome.final = none := by + simpa using congrArg ObservedMaterializedDiagnostic.final hreturn + simp [ObservedMaterializedDiagnostic.SuccessfulDoomed, hfinalNone] at hsuccess + | some finalResult => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hbeforeEq : outcome.before = some before := by + simpa using congrArg ObservedMaterializedDiagnostic.before hreturn + have hdoomedEq : decide + (¬DeferredCompletable table (directDeferredContext before.state)) = true := by + have hfield := congrArg ObservedMaterializedDiagnostic.wasDoomed hreturn + exact hfield.symm.trans hsuccess.2 + have hnotCompletable : + ¬DeferredCompletable table (directDeferredContext before.state) := by + simpa using of_decide_eq_true hdoomedEq + have htracked : + CleanProbeObservationsTrackedBy before.observations before.state := by + simpa only [ObservedMaterializedOutputTracked] using + observedMaterializedOutputTracked_of_mem_retainedRunFromTable adversary parameter + ftsSecret (2 * q) table (some before) hbefore + have hcovered : + CleanProbeObservationsCoverPending before.observations before.state := by + simpa only [ObservedMaterializedOutputCovered] using + observedMaterializedOutputCovered_of_mem_retainedRunFromTable adversary parameter + ftsSecret (2 * q) table (some before) hbefore + have hpending : before.state.pending.card ≤ 2 * q := + pending_card_le_fuel_of_mem_observedMaterializedRetainedRunFromTable adversary parameter + ftsSecret (2 * q) table before hbefore + have htableAndStarts : + before.table = table ∧ StartTableAgrees before.state table := + table_eq_and_startTableAgrees_of_mem_observedMaterializedRetainedRunFromTable + adversary parameter ftsSecret (2 * q) table before hbefore + have hcard : before.state.pending.card < Fintype.card Digest := by + have hq' : 2 * q ≤ 2 ^ (securityBits + 1) := by + have : 2 * q ≤ 2 * 2 ^ securityBits := Nat.mul_le_mul_left 2 hq + simpa [pow_succ, Nat.mul_comm] using this + have hspace : 2 ^ (securityBits + 1) < Fintype.card Digest := by + norm_num [securityBits, digestBits] + exact hpending.trans_lt (hq'.trans_lt hspace) + have hconsistent : + (directDeferredContext before.state).ValuesConsistent := by + intro position output hvalue + simpa [directDeferredContext, directDeferredValues] using hvalue + have hdoomed : + DoomedResolvedContext table (directDeferredContext before.state) := + ⟨hconsistent, htableAndStarts.2, hnotCompletable⟩ + exact ⟨before, hbeforeEq, hasExistingHiddenHit_of_doomed_finished table before finalResult + htableAndStarts.1 hdoomed htracked hcovered hcard hfinal⟩ + +attribute [local irreducible] observedMaterializedRetainedRunFromTable in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem observations_length_le_of_mem_diagnosticFromTable_before + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (outcome : ObservedMaterializedDiagnostic + (RetainedGameResult × SplitHashCache)) + (result : ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) + (houtcome : outcome ∈ support + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table >>= + finishObservedMaterializedDiagnostic table)) + (hbefore : outcome.before = some result) : + result.observations.length ≤ fuel := by + rw [mem_support_bind_iff] at houtcome + obtain ⟨before?, hbeforeSupport, hfinish⟩ := houtcome + cases before? with + | none => + have houtcomeEq : outcome = ⟨none, none, false⟩ := by + simpa [finishObservedMaterializedDiagnostic] using hfinish + rw [houtcomeEq] at hbefore + simp at hbefore + | some before => + unfold finishObservedMaterializedDiagnostic at hfinish + rw [mem_support_bind_iff] at hfinish + obtain ⟨final?, _hfinal, hreturn⟩ := hfinish + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hbeforeEq : outcome.before = some before := by + simpa using congrArg ObservedMaterializedDiagnostic.before hreturn + have heq : before = result := Option.some.inj (hbeforeEq.symm.trans hbefore) + subst result + exact observations_length_le_fuel_of_mem_observedMaterializedRetainedRunFromTable + adversary parameter ftsSecret fuel table before hbeforeSupport + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationProjection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationProjection.lean new file mode 100644 index 00000000..3c1d44b2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationProjection.lean @@ -0,0 +1,272 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationSample + +/-! +# First-hit diagnostic projection + +The diagnostic finalizer does not create observations. This module removes it from each fixed +first-hit event, leaving only the retained materialized run that the stopped endpoint couplings +must analyze. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +def ObservedCleanRunOption.FirstExistingHiddenRootHitAt + (ordinal : Nat) : Option (ObservedCleanRunResult α) → Prop + | none => False + | some result => + ∃ selected : Fin result.observations.length, + selected.val = ordinal ∧ FirstExistingHiddenHitAt result ordinal ∧ + (result.observations.get selected).toProbe.IsLayerRoot + +def ObservedCleanRunOption.FirstExistingHiddenNonRootHitAt + (ordinal : Nat) : Option (ObservedCleanRunResult α) → Prop + | none => False + | some result => + ∃ selected : Fin result.observations.length, + selected.val = ordinal ∧ FirstExistingHiddenHitAt result ordinal ∧ + ¬(result.observations.get selected).toProbe.IsLayerRoot + +def ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt + (_table : OtsSecretIndex → HashOutput) (ordinal : Nat) : + Option (ObservedCleanRunResult α) → Prop + | none => False + | some result => + (∃ finalResult, some finalResult ∈ support + (finishObservedCleanRunFromTable (some result))) ∧ + ObservedCleanRunOption.FirstExistingHiddenRootHitAt ordinal (some result) + +def ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt + (_table : OtsSecretIndex → HashOutput) (ordinal : Nat) : + Option (ObservedCleanRunResult α) → Prop + | none => False + | some result => + (∃ finalResult, some finalResult ∈ support + (finishObservedCleanRunFromTable (some result))) ∧ + ObservedCleanRunOption.FirstExistingHiddenNonRootHitAt ordinal (some result) + +theorem before_eq_of_mem_finishObservedMaterializedDiagnostic + (table : OtsSecretIndex → HashOutput) + (result : Option (ObservedCleanRunResult α)) + (outcome : ObservedMaterializedDiagnostic α) + (houtcome : outcome ∈ support (finishObservedMaterializedDiagnostic table result)) : + outcome.before = result := by + classical + cases result with + | none => + simp [finishObservedMaterializedDiagnostic] at houtcome + subst outcome + rfl + | some result => + unfold finishObservedMaterializedDiagnostic at houtcome + rw [mem_support_bind_iff] at houtcome + obtain ⟨final, _hfinal, hreturn⟩ := houtcome + simp only [mem_support_pure_iff] at hreturn + subst outcome + rfl + +theorem successfulDoomed_data_of_mem_finishObservedMaterializedDiagnostic + (table : OtsSecretIndex → HashOutput) + (result : Option (ObservedCleanRunResult α)) + (outcome : ObservedMaterializedDiagnostic α) + (houtcome : outcome ∈ support (finishObservedMaterializedDiagnostic table result)) + (hsuccess : outcome.SuccessfulDoomed) : + ∃ before finalResult, + result = some before ∧ + outcome.before = some before ∧ + outcome.final = some finalResult ∧ + some finalResult ∈ support (finishObservedCleanRunFromTable (some before)) ∧ + ¬DeferredCompletable table (directDeferredContext before.state) := by + classical + cases result with + | none => + simp [finishObservedMaterializedDiagnostic] at houtcome + subst outcome + simp [ObservedMaterializedDiagnostic.SuccessfulDoomed] at hsuccess + | some before => + unfold finishObservedMaterializedDiagnostic at houtcome + rw [mem_support_bind_iff] at houtcome + obtain ⟨final, hfinal, hreturn⟩ := houtcome + simp only [mem_support_pure_iff] at hreturn + subst outcome + cases final with + | none => + simp [ObservedMaterializedDiagnostic.SuccessfulDoomed] at hsuccess + | some finalResult => + refine ⟨before, finalResult, rfl, rfl, rfl, hfinal, ?_⟩ + simpa [ObservedMaterializedDiagnostic.SuccessfulDoomed] using hsuccess.2 + +theorem probEvent_finishDiagnostic_successfulDoomed_firstExistingHiddenRootHitAt_le + (table : OtsSecretIndex → HashOutput) + (run : ProbComp (Option (ObservedCleanRunResult α))) (ordinal : Nat) : + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal | + run >>= finishObservedMaterializedDiagnostic table] ≤ + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal | + run] := by + apply probEvent_bind_le_probEvent + intro result _hresult hnot + apply probEvent_eq_zero + intro outcome houtcome hevent + obtain ⟨before, finalResult, hresult, hbefore, _hfinalEq, hfinal, _hdoomed⟩ := + successfulDoomed_data_of_mem_finishObservedMaterializedDiagnostic table result outcome + houtcome hevent.1 + subst result + obtain ⟨rootResult, selected, hrootBefore, hselected, hfirst, hroot⟩ := hevent.2 + have hsame : rootResult = before := Option.some.inj (hrootBefore.symm.trans hbefore) + subst rootResult + exact hnot ⟨⟨finalResult, hfinal⟩, + ⟨selected, hselected, hfirst, hroot⟩⟩ + +theorem probEvent_finishDiagnostic_successfulDoomed_firstExistingHiddenNonRootHitAt_le + (table : OtsSecretIndex → HashOutput) + (run : ProbComp (Option (ObservedCleanRunResult α))) (ordinal : Nat) : + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal | + run >>= finishObservedMaterializedDiagnostic table] ≤ + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt table ordinal | + run] := by + apply probEvent_bind_le_probEvent + intro result _hresult hnot + apply probEvent_eq_zero + intro outcome houtcome hevent + obtain ⟨before, finalResult, hresult, hbefore, _hfinalEq, hfinal, _hdoomed⟩ := + successfulDoomed_data_of_mem_finishObservedMaterializedDiagnostic table result outcome + houtcome hevent.1 + subst result + obtain ⟨nonRootResult, selected, hnonRootBefore, hselected, hfirst, hnonRoot⟩ := hevent.2 + have hsame : nonRootResult = before := Option.some.inj (hnonRootBefore.symm.trans hbefore) + subst nonRootResult + exact hnot ⟨⟨finalResult, hfinal⟩, + ⟨selected, hselected, hfirst, hnonRoot⟩⟩ + +theorem probEvent_finishDiagnostic_firstExistingHiddenRootHitAt_le + (table : OtsSecretIndex → HashOutput) + (run : ProbComp (Option (ObservedCleanRunResult α))) (ordinal : Nat) : + Pr[ObservedMaterializedDiagnostic.FirstExistingHiddenRootHitAt ordinal | + run >>= finishObservedMaterializedDiagnostic table] ≤ + Pr[ObservedCleanRunOption.FirstExistingHiddenRootHitAt ordinal | run] := by + apply probEvent_bind_le_probEvent + intro result _hresult hnot + apply probEvent_eq_zero + intro outcome houtcome hroot + obtain ⟨before, selected, hbefore, hselected, hfirst, hroot⟩ := hroot + have heq := before_eq_of_mem_finishObservedMaterializedDiagnostic table result outcome houtcome + rw [heq] at hbefore + cases result with + | none => simp at hbefore + | some result => + have hresult : before = result := Option.some.inj hbefore.symm + subst before + exact hnot ⟨selected, hselected, hfirst, hroot⟩ + +theorem probEvent_finishDiagnostic_firstExistingHiddenNonRootHitAt_le + (table : OtsSecretIndex → HashOutput) + (run : ProbComp (Option (ObservedCleanRunResult α))) (ordinal : Nat) : + Pr[ObservedMaterializedDiagnostic.FirstExistingHiddenNonRootHitAt ordinal | + run >>= finishObservedMaterializedDiagnostic table] ≤ + Pr[ObservedCleanRunOption.FirstExistingHiddenNonRootHitAt ordinal | run] := by + apply probEvent_bind_le_probEvent + intro result _hresult hnot + apply probEvent_eq_zero + intro outcome houtcome hnonRoot + obtain ⟨before, selected, hbefore, hselected, hfirst, hnonRoot⟩ := hnonRoot + have heq := before_eq_of_mem_finishObservedMaterializedDiagnostic table result outcome houtcome + rw [heq] at hbefore + cases result with + | none => simp at hbefore + | some result => + have hresult : before = result := Option.some.inj hbefore.symm + subst before + exact hnot ⟨selected, hselected, hfirst, hnonRoot⟩ + +attribute [local irreducible] + observedMaterializedRetainedRunFromTable finishObservedMaterializedDiagnostic in +theorem probEvent_sampledDiagnostic_firstExistingHiddenRootHitAt_le_raw + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel ordinal : Nat) : + Pr[ObservedMaterializedDiagnostic.FirstExistingHiddenRootHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel] ≤ + Pr[ObservedCleanRunOption.FirstExistingHiddenRootHitAt ordinal | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table] := by + unfold sampledObservedMaterializedDiagnostic + rw [probEvent_bind_eq_tsum, probEvent_bind_eq_tsum] + apply ENNReal.tsum_le_tsum + intro table + gcongr + exact probEvent_finishDiagnostic_firstExistingHiddenRootHitAt_le table + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table) ordinal + +attribute [local irreducible] + observedMaterializedRetainedRunFromTable finishObservedMaterializedDiagnostic in +theorem probEvent_sampledDiagnostic_firstExistingHiddenNonRootHitAt_le_raw + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel ordinal : Nat) : + Pr[ObservedMaterializedDiagnostic.FirstExistingHiddenNonRootHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel] ≤ + Pr[ObservedCleanRunOption.FirstExistingHiddenNonRootHitAt ordinal | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table] := by + unfold sampledObservedMaterializedDiagnostic + rw [probEvent_bind_eq_tsum, probEvent_bind_eq_tsum] + apply ENNReal.tsum_le_tsum + intro table + gcongr + exact probEvent_finishDiagnostic_firstExistingHiddenNonRootHitAt_le table + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table) ordinal + +set_option maxRecDepth 1000000 in +set_option maxHeartbeats 2000000 in +set_option linter.constructorNameAsVariable false in +attribute [local irreducible] + observedMaterializedRetainedRunFromTable finishObservedMaterializedDiagnostic in +theorem probEvent_sampledDiagnostic_successfulDoomed_firstExistingHiddenRootHitAt_le_of_forall + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel ordinal : Nat) + (bound : ENNReal) + (hbound : ∀ table, + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table] ≤ + bound) : + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel] ≤ bound := by + unfold sampledObservedMaterializedDiagnostic + apply probEvent_bind_le_of_forall_le + intro table _htable + calc + _ ≤ Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table] := + probEvent_finishDiagnostic_successfulDoomed_firstExistingHiddenRootHitAt_le table + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table) ordinal + _ ≤ bound := hbound table + +set_option maxRecDepth 1000000 in +set_option maxHeartbeats 2000000 in +set_option linter.constructorNameAsVariable false in +attribute [local irreducible] + observedMaterializedRetainedRunFromTable finishObservedMaterializedDiagnostic in +theorem probEvent_sampledDiagnostic_successfulDoomed_firstExistingHiddenNonRootHitAt_le_of_forall + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel ordinal : Nat) + (bound : ENNReal) + (hbound : ∀ table, + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table] ≤ + bound) : + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel] ≤ bound := by + unfold sampledObservedMaterializedDiagnostic + apply probEvent_bind_le_of_forall_le + intro table _htable + calc + _ ≤ Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table] := + probEvent_finishDiagnostic_successfulDoomed_firstExistingHiddenNonRootHitAt_le table + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table) ordinal + _ ≤ bound := hbound table + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationSample.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationSample.lean new file mode 100644 index 00000000..81ad2e3c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationSample.lean @@ -0,0 +1,293 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationKernel + +/-! +# Sampled sound global root classification + +The fixed-table diagnostic relation is lifted through the opaque one-time table sampler here. The +probability projection keeps the fresh failure, successful doomed state and delayed source event as +three separate terms. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] + observedMaterializedRetainedRunFromTable finishObservedMaterializedDiagnostic in +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem hasExistingHiddenHit_of_mem_sampledDiagnostic_successfulDoomed + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : q ≤ 2 ^ securityBits) + (outcome : ObservedMaterializedDiagnostic + (RetainedGameResult × SplitHashCache)) + (houtcome : outcome ∈ support + (sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q))) + (hsuccess : outcome.SuccessfulDoomed) : + outcome.HasExistingHiddenHit := by + change outcome ∈ support (sampleOtsHashTable >>= fun table => + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table >>= + finishObservedMaterializedDiagnostic table) at houtcome + rw [mem_support_bind_iff] at houtcome + obtain ⟨table, _htable, hfixed⟩ := houtcome + exact hasExistingHiddenHit_of_mem_diagnosticFromTable_successfulDoomed adversary parameter + ftsSecret q table hq outcome hfixed hsuccess + +attribute [local irreducible] sampledObservedMaterializedDiagnostic in +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_le_existingHiddenHit + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : q ≤ 2 ^ securityBits) : + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + Pr[ObservedMaterializedDiagnostic.HasExistingHiddenHit | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] := by + apply probEvent_mono + intro outcome houtcome hsuccess + exact hasExistingHiddenHit_of_mem_sampledDiagnostic_successfulDoomed adversary parameter + ftsSecret q hq outcome houtcome hsuccess + +attribute [local irreducible] sampledObservedMaterializedDiagnostic in +theorem probEvent_sampledDiagnostic_successfulDoomed_le_root_add_nonRoot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : q ≤ 2 ^ securityBits) : + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + Pr[ObservedMaterializedDiagnostic.HasExistingHiddenRootHit | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] + + Pr[ObservedMaterializedDiagnostic.HasExistingHiddenNonRootHit | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] := by + exact (probEvent_sampledDiagnostic_successfulDoomed_le_existingHiddenHit adversary parameter + ftsSecret q hq).trans + (probEvent_diagnostic_existingHidden_le_root_add_nonRoot + (sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q))) + +attribute [local irreducible] + observedMaterializedRetainedRunFromTable finishObservedMaterializedDiagnostic in +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem observations_length_le_of_mem_sampledDiagnostic_before + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (outcome : ObservedMaterializedDiagnostic + (RetainedGameResult × SplitHashCache)) + (result : ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) + (houtcome : outcome ∈ support + (sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel)) + (hbefore : outcome.before = some result) : + result.observations.length ≤ fuel := by + change outcome ∈ support (sampleOtsHashTable >>= fun table => + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table >>= + finishObservedMaterializedDiagnostic table) at houtcome + rw [mem_support_bind_iff] at houtcome + obtain ⟨table, _htable, hfixed⟩ := houtcome + exact observations_length_le_of_mem_diagnosticFromTable_before adversary parameter ftsSecret + fuel table outcome result hfixed hbefore + +attribute [local irreducible] sampledObservedMaterializedDiagnostic in +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnostic_existingHidden_le_sum_firstOrdinals + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[ObservedMaterializedDiagnostic.HasExistingHiddenHit | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel] ≤ + ∑ ordinal : Fin fuel, + (Pr[ObservedMaterializedDiagnostic.FirstExistingHiddenRootHitOrdinal ordinal.val | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel] + + Pr[ObservedMaterializedDiagnostic.FirstExistingHiddenNonRootHitOrdinal ordinal.val | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel]) := by + classical + let run := sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel + calc + _ ≤ Pr[fun outcome => ∃ ordinal ∈ (Finset.univ : Finset (Fin fuel)), + outcome.FirstExistingHiddenRootHitOrdinal ordinal.val ∨ + outcome.FirstExistingHiddenNonRootHitOrdinal ordinal.val | run] := by + apply probEvent_mono + intro outcome houtcome hhit + rcases outcome.firstExistingHidden_root_or_nonRoot hhit with hroot | hnonRoot + · obtain ⟨ordinal, result, sourceOrdinal, hbefore, hordinal, hfirst, hroot⟩ := hroot + have hlength := observations_length_le_of_mem_sampledDiagnostic_before adversary parameter + ftsSecret fuel outcome result houtcome hbefore + have hlt : ordinal < fuel := by omega + let bounded : Fin fuel := ⟨ordinal, hlt⟩ + exact ⟨bounded, Finset.mem_univ bounded, Or.inl + ⟨result, sourceOrdinal, hbefore, hordinal, hfirst, hroot⟩⟩ + · obtain ⟨ordinal, result, sourceOrdinal, hbefore, hordinal, hfirst, hnonRoot⟩ := + hnonRoot + have hlength := observations_length_le_of_mem_sampledDiagnostic_before adversary parameter + ftsSecret fuel outcome result houtcome hbefore + have hlt : ordinal < fuel := by omega + let bounded : Fin fuel := ⟨ordinal, hlt⟩ + exact ⟨bounded, Finset.mem_univ bounded, Or.inr + ⟨result, sourceOrdinal, hbefore, hordinal, hfirst, hnonRoot⟩⟩ + _ ≤ ∑ ordinal : Fin fuel, + Pr[fun outcome => + outcome.FirstExistingHiddenRootHitOrdinal ordinal.val ∨ + outcome.FirstExistingHiddenNonRootHitOrdinal ordinal.val | run] := + probEvent_exists_finset_le_sum Finset.univ run fun (ordinal : Fin fuel) outcome => + outcome.FirstExistingHiddenRootHitOrdinal ordinal.val ∨ + outcome.FirstExistingHiddenNonRootHitOrdinal ordinal.val + _ ≤ ∑ ordinal : Fin fuel, + (Pr[ObservedMaterializedDiagnostic.FirstExistingHiddenRootHitOrdinal ordinal.val | run] + + Pr[ObservedMaterializedDiagnostic.FirstExistingHiddenNonRootHitOrdinal ordinal.val | + run]) := by + apply Finset.sum_le_sum + intro ordinal _hordinal + exact probEvent_or_le _ _ _ + _ = _ := by simp only [run] + +attribute [local irreducible] sampledObservedMaterializedDiagnostic in +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_le_sum_successfulFirstOrdinals + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : q ≤ 2 ^ securityBits) : + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + ∑ ordinal : Fin (2 * q), + (Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal.val | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal.val | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)]) := by + classical + let run := sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q) + calc + _ ≤ Pr[fun outcome => ∃ ordinal ∈ (Finset.univ : Finset (Fin (2 * q))), + (outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal.val) ∨ + (outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal.val) | run] := by + apply probEvent_mono + intro outcome houtcome hsuccess + have hhit := hasExistingHiddenHit_of_mem_sampledDiagnostic_successfulDoomed adversary + parameter ftsSecret q hq outcome houtcome hsuccess + rcases outcome.firstExistingHidden_root_or_nonRoot hhit with hroot | hnonRoot + · obtain ⟨ordinal, result, sourceOrdinal, hbefore, hordinal, hfirst, hroot⟩ := hroot + have hlength := observations_length_le_of_mem_sampledDiagnostic_before adversary parameter + ftsSecret (2 * q) outcome result houtcome hbefore + have hlt : ordinal < 2 * q := by omega + let bounded : Fin (2 * q) := ⟨ordinal, hlt⟩ + have hrootAt : outcome.FirstExistingHiddenRootHitAt ordinal := + outcome.firstExistingHiddenRootHitAt_of_ordinal + ⟨result, sourceOrdinal, hbefore, hordinal, hfirst, hroot⟩ + exact ⟨bounded, Finset.mem_univ bounded, Or.inl ⟨hsuccess, hrootAt⟩⟩ + · obtain ⟨ordinal, result, sourceOrdinal, hbefore, hordinal, hfirst, hnonRoot⟩ := + hnonRoot + have hlength := observations_length_le_of_mem_sampledDiagnostic_before adversary parameter + ftsSecret (2 * q) outcome result houtcome hbefore + have hlt : ordinal < 2 * q := by omega + let bounded : Fin (2 * q) := ⟨ordinal, hlt⟩ + have hnonRootAt : outcome.FirstExistingHiddenNonRootHitAt ordinal := + outcome.firstExistingHiddenNonRootHitAt_of_ordinal + ⟨result, sourceOrdinal, hbefore, hordinal, hfirst, hnonRoot⟩ + exact ⟨bounded, Finset.mem_univ bounded, Or.inr ⟨hsuccess, hnonRootAt⟩⟩ + _ ≤ ∑ ordinal : Fin (2 * q), + Pr[fun outcome => + (outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal.val) ∨ + (outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal.val) | run] := + probEvent_exists_finset_le_sum Finset.univ run fun (ordinal : Fin (2 * q)) outcome => + (outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal.val) ∨ + (outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal.val) + _ ≤ ∑ ordinal : Fin (2 * q), + (Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal.val | run] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal.val | run]) := by + apply Finset.sum_le_sum + intro ordinal _hordinal + exact probEvent_or_le _ _ _ + _ = _ := by simp only [run] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_sampledGranularAllCanonical_diagnosticRootRel + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + RelTriple + (sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q) + (sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)) + SnapshotObservedDiagnosticRootRel := by + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot + sampledObservedMaterializedDiagnostic + apply relTriple_bind (relTriple_refl sampleOtsHashTable) + intro leftTable rightTable htable + subst rightTable + exact relTriple_granularAllCanonical_diagnosticRootRel adversary parameter ftsSecret q + leftTable (hbound leftTable) + +theorem probEvent_sampledCanonical_root_le_diagnostic + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + Pr[fun output => + WitnessFirstUsesSomeLayerRoot (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + Pr[fun outcome => outcome.final = none | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] + + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] + + Pr[WitnessFirstUsesSomeDelayedLayerRootSnapshot | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := by + let source := sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q + let diagnostic := + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q) + have hsplit : + Pr[fun output => + WitnessFirstUsesSomeLayerRoot (erasePrivateWitnessSnapshotOutput output) | source] ≤ + Pr[ObservedMaterializedDiagnostic.Bad | diagnostic] + + Pr[WitnessFirstUsesSomeDelayedLayerRootSnapshot | source] := by + apply probEvent_le_failure_add_residual_of_relTriple source diagnostic + SnapshotObservedDiagnosticRootRel + (fun output => + WitnessFirstUsesSomeLayerRoot (erasePrivateWitnessSnapshotOutput output)) + WitnessFirstUsesSomeDelayedLayerRootSnapshot + ObservedMaterializedDiagnostic.Bad + (relTriple_sampledGranularAllCanonical_diagnosticRootRel adversary parameter ftsSecret q + hbound) + intro sourceOutput diagnosticOutput hrelation hroot hnotDelayed + rcases hrelation with hbad | himplication + · exact hbad + · exact False.elim (hnotDelayed (himplication hroot)) + calc + _ ≤ Pr[ObservedMaterializedDiagnostic.Bad | diagnostic] + + Pr[WitnessFirstUsesSomeDelayedLayerRootSnapshot | source] := hsplit + _ ≤ (Pr[fun outcome => outcome.final = none | diagnostic] + + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | diagnostic]) + + Pr[WitnessFirstUsesSomeDelayedLayerRootSnapshot | source] := by + gcongr + exact probEvent_diagnosticBad_le_finalNone_add_successfulDoomed diagnostic + _ = _ := by + simp only [source, diagnostic] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStopped.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStopped.lean new file mode 100644 index 00000000..48925cde --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStopped.lean @@ -0,0 +1,586 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationProjection + +/-! +# Successful stopped hidden-hit classification + +A missing chain-start obstruction cannot disappear along a successful materialized run. This is the +unrecoverable half of the stopped coupling: once it has been separated from a matched private stop, +successful finalization rules it out. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem MissingChainStartHit.ensure + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hmissing : MissingChainStartHit table context) (coordinate : Coordinate) : + MissingChainStartHit table + { context with state := context.state.ensure coordinate } := by + obtain ⟨index, hvalue, hhit⟩ := hmissing + exact ⟨index, by simpa using hvalue, by simpa using hhit⟩ + +theorem MissingChainStartHit.publish + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hmissing : MissingChainStartHit table context) (coordinate : Coordinate) : + MissingChainStartHit table + { context with state := context.state.publish coordinate } := by + obtain ⟨index, hvalue, hhit⟩ := hmissing + exact ⟨index, by simpa using hvalue, by simpa using hhit⟩ + +theorem MissingChainStartHit.addPending + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hmissing : MissingChainStartHit table context) + (coordinate : Coordinate) (candidate : Digest) : + MissingChainStartHit table + { context with state := context.state.addPending coordinate candidate } := by + obtain ⟨index, hvalue, hhit⟩ := hmissing + refine ⟨index, by simpa using hvalue, ?_⟩ + unfold LazyRevealProbe.State.hitAt at hhit ⊢ + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit ⊢ + exact Finset.mem_insert_of_mem hhit + +theorem missingChainStartHit_materialize_of_ne + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (index : OtsSecretIndex) + (hvalue : context.state.values index.coordinate = none) + (hhit : context.state.hitAt index.coordinate (table index)) + (coordinate : Coordinate) (output : HashOutput) + (hne : coordinate ≠ index.coordinate) : + MissingChainStartHit table + { context with state := context.state.materialize coordinate output } := by + refine ⟨index, ?_, ?_⟩ + · simpa [LazyRevealProbe.State.materialize, Function.update_of_ne hne.symm] using hvalue + · unfold LazyRevealProbe.State.hitAt at hhit ⊢ + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit ⊢ + exact Finset.mem_filter.mpr ⟨hhit, hne.symm⟩ + +set_option maxRecDepth 100000 in +theorem missingChainStartHit_of_mem_runObservedCleanFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (result : ObservedCleanRunResult α) + (hmissing : MissingChainStartHit table (directDeferredContext state)) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table computation)) : + result.table = table ∧ + MissingChainStartHit table (directDeferredContext result.state) := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table with + | pure value => + simp [runObservedCleanFromTable] at hresult + subst result + exact ⟨rfl, hmissing⟩ + | query_bind query next ih => + cases query with + | uniform n => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output observations state fuel table hmissing hrest + | hashOutput => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output observations state fuel table hmissing hrest + | ensure coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih () observations (state.ensure coordinate) fuel table + (hmissing.ensure coordinate) hresult + | probe coordinate candidate => + rw [runObservedCleanFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · exact ih () + (observations ++ [cleanProbeObservation state coordinate candidate]) + state remaining table hmissing (by simpa [hrevealed] using hresult) + · exact ih () + (observations ++ [cleanProbeObservation state coordinate candidate]) + (state.addPending coordinate candidate) remaining table + (hmissing.addPending coordinate candidate) + (by simpa [hrevealed] using hresult) + | peek coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih (state.values coordinate) observations state fuel table hmissing hresult + | publish coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih () observations (state.publish coordinate) fuel table + (hmissing.publish coordinate) hresult + | reveal coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + obtain ⟨index, hvalue, hhit⟩ := hmissing + cases hstored : state.values coordinate with + | some output => + simp only [hstored] at hresult + exact ih output observations state fuel table ⟨index, hvalue, hhit⟩ hresult + | none => + simp only [hstored] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let revealedIndex : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + let output := table revealedIndex + by_cases hcoordinate : + Coordinate.chainStart lay tree leafIdx chainIdx = index.coordinate + · have heq : revealedIndex = index := + OtsSecretIndex.coordinate_injective (by + simpa [revealedIndex, OtsSecretIndex.coordinate] using hcoordinate) + have hhit' : state.hitAt + (.chainStart lay tree leafIdx chainIdx) output := by + have hhitState : state.hitAt index.coordinate (table index) := by + simpa only [directDeferredContext] using hhit + simpa [output, heq, hcoordinate] using hhitState + have hhitLiteral : state.hitAt + (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + simpa [output, revealedIndex] using hhit' + simp [hhitLiteral] at hresult + · + by_cases hrevealedHit : state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · have hhitLiteral : state.hitAt + (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + simpa [output, revealedIndex] using hrevealedHit + simp [hhitLiteral] at hresult + · have hnotHitLiteral : ¬state.hitAt + (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + simpa [output, revealedIndex] using hrevealedHit + simp only [if_neg hnotHitLiteral] at hresult + have hrest : some result ∈ support + (runObservedCleanFromTable observations + (state.materialize + (.chainStart lay tree leafIdx chainIdx) output) + fuel table (next output)) := by + rw [runObservedCleanFromTable] + simpa [output, revealedIndex] using hresult + exact ih output observations + (state.materialize (.chainStart lay tree leafIdx chainIdx) output) + fuel table + (missingChainStartHit_materialize_of_ne index hvalue hhit + (.chainStart lay tree leafIdx chainIdx) output hcoordinate) + hrest + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hpositionHit : state.hitAt (.position position) output + · simp [hpositionHit] at hrest + · simp only [hpositionHit, ↓reduceIte] at hrest + have hcoordinate : Coordinate.position position ≠ index.coordinate := by + cases index + simp [OtsSecretIndex.coordinate] + exact ih output observations (state.materialize (.position position) output) + fuel table + (missingChainStartHit_materialize_of_ne index hvalue hhit + (.position position) output hcoordinate) + hrest + +set_option maxRecDepth 100000 in +theorem missingChainStartHit_of_mem_observedMaterializedBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hmissing : MissingChainStartHit table (directDeferredContext state)) + (hresult : some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache)) : + result.table = table ∧ + MissingChainStartHit table (directDeferredContext result.state) := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table cache with + | pure value => + simp [observedMaterializedBoundary] at hresult + obtain rfl := hresult + exact ⟨rfl, hmissing⟩ + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind] at hresult + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + have hnext := missingChainStartHit_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run cache) observations state fuel table step hmissing hstep + exact ih step.value.1 step.observations step.state step.remaining table + step.value.2 hnext.2 (by + simpa only [observedMaterializedBoundary] using hrest) + | inr input => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + have hnext := missingChainStartHit_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache) observations state fuel table step hmissing hstep + exact ih step.value.1 step.observations step.state step.remaining table + step.value.2 hnext.2 (by + simpa only [observedMaterializedBoundary] using hrest) + | inr message => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + have hnext := missingChainStartHit_of_mem_runObservedCleanFromTable + ((maskedSign parameter root ftsSecret message).run cache) observations state fuel + table step hmissing hstep + exact ih step.value.1 step.observations step.state step.remaining table + step.value.2 hnext.2 (by + simpa only [observedMaterializedBoundary] using hrest) + +theorem not_missingChainStartHit_of_successful_observedMaterializedBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (finalResult : ObservedCleanRunResult (α × SplitHashCache)) + (hrun : some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache)) + (hfinish : some finalResult ∈ support + (finishObservedCleanRunFromTable (some result))) : + ¬MissingChainStartHit table (directDeferredContext state) := by + intro hmissing + have hpersist := missingChainStartHit_of_mem_observedMaterializedBoundary parameter root + ftsSecret computation observations state fuel table cache result hmissing hrun + have hfinalMissing := hpersist.2 + rw [← hpersist.1] at hfinalMissing + exact not_missingChainStartHit_of_mem_finishObservedCleanRunFromTable result finalResult hfinish + hfinalMissing + +def CleanProbeObservation.ExistingHiddenChainStartHit + (observation : CleanProbeObservation) : Prop := + observation.ExistingHiddenHit ∧ + ∃ index : OtsSecretIndex, observation.coordinate = index.coordinate + +def FirstExistingHiddenChainStartHit + (observations : List CleanProbeObservation) : Prop := + ∃ selected : Fin observations.length, + (observations.get selected).ExistingHiddenChainStartHit ∧ + ∀ earlier : Fin observations.length, + earlier.val < selected.val → + ¬(observations.get earlier).ExistingHiddenHit + +theorem FirstExistingHiddenChainStartHit.prefix + {before after : List CleanProbeObservation} + (hhit : FirstExistingHiddenChainStartHit before) + (hprefix : before <+: after) : + FirstExistingHiddenChainStartHit after := by + obtain ⟨selected, hselected, hfirst⟩ := hhit + have hselectedLt : selected.val < after.length := + selected.isLt.trans_le hprefix.length_le + let selected' : Fin after.length := ⟨selected.val, hselectedLt⟩ + refine ⟨selected', ?_, ?_⟩ + · have hget : after[selected.val] = before[selected.val] := + (hprefix.getElem selected.isLt).symm + simpa [selected', hget] using hselected + · intro earlier hearlier + have hearlierBefore : earlier.val < before.length := hearlier.trans selected.isLt + let earlier' : Fin before.length := ⟨earlier.val, hearlierBefore⟩ + have hget : after[earlier.val] = before[earlier.val] := + (hprefix.getElem hearlierBefore).symm + simpa [earlier', hget] using hfirst earlier' (by simpa [selected', earlier'] using hearlier) + +theorem firstExistingHiddenHit_selected_unique + {observations : List CleanProbeObservation} + {left right : Fin observations.length} + (hleft : (observations.get left).ExistingHiddenHit ∧ + ∀ earlier : Fin observations.length, + earlier.val < left.val → ¬(observations.get earlier).ExistingHiddenHit) + (hright : (observations.get right).ExistingHiddenHit ∧ + ∀ earlier : Fin observations.length, + earlier.val < right.val → ¬(observations.get earlier).ExistingHiddenHit) : + left = right := by + apply Fin.ext + by_contra hne + rcases Nat.lt_or_gt_of_ne hne with hlt | hgt + · exact hright.2 left hlt hleft.1 + · exact hleft.2 right hgt hright.1 + +theorem FirstExistingHiddenChainStartHit.selected_eq + {result : ObservedCleanRunResult α} {ordinal : Nat} + (hchain : FirstExistingHiddenChainStartHit result.observations) + (hfirst : FirstExistingHiddenHitAt result ordinal) : + ∃ selected : Fin result.observations.length, + selected.val = ordinal ∧ + (result.observations.get selected).ExistingHiddenChainStartHit := by + obtain ⟨chainSelected, hchainHit, hchainFirst⟩ := hchain + obtain ⟨selected, hordinal, hselectedHit, hselectedFirst⟩ := hfirst + have heq : chainSelected = selected := firstExistingHiddenHit_selected_unique + ⟨hchainHit.1, hchainFirst⟩ ⟨hselectedHit, by + intro earlier hearlier + exact hselectedFirst earlier (by omega)⟩ + subst chainSelected + exact ⟨selected, hordinal, hchainHit⟩ + +theorem not_firstExistingHiddenRootHitAt_of_firstChainStart + {result : ObservedCleanRunResult α} {ordinal : Nat} + (hchain : FirstExistingHiddenChainStartHit result.observations) + (hfirst : FirstExistingHiddenHitAt result ordinal) : + ∀ selected : Fin result.observations.length, + selected.val = ordinal → + ¬(result.observations.get selected).toProbe.IsLayerRoot := by + intro selected hselected + obtain ⟨chainSelected, hchainOrdinal, hchainHit⟩ := hchain.selected_eq hfirst + have heq : chainSelected = selected := by + apply Fin.ext + omega + subst chainSelected + rintro ⟨position, hposition, _hroot⟩ + obtain ⟨index, hindex⟩ := hchainHit.2 + change (result.observations.get selected).coordinate = .position position at hposition + rw [hposition] at hindex + cases index + simp [OtsSecretIndex.coordinate] at hindex + +def ObservedStoppedCause + (table : OtsSecretIndex → HashOutput) + (result : ObservedCleanRunResult α) : Prop := + MissingChainStartHit table (directDeferredContext result.state) ∨ + FirstExistingHiddenChainStartHit result.observations + +def SnapshotObservedPrefixStoppedRel + (table : OtsSecretIndex → HashOutput) + (source : PrivateWitnessSnapshotOutput) + (observed : Option (ObservedCleanRunResult (α × SplitHashCache))) : Prop := + observed = none ∨ + (∃ result aligned, observed = some result ∧ + aligned <+: result.observations ∧ + SnapshotsObservedAt table source.2 aligned ∧ + ∀ witness, source.1 = some witness → + result.state.values (.position witness.position) = some witness.output) ∨ + ∃ result, observed = some result ∧ + result.table = table ∧ + DoomedResolvedContext table (directDeferredContext result.state) ∧ + ObservedStoppedCause table result + +theorem observedStoppedCause_of_mem_observedMaterializedBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hcause : MissingChainStartHit table (directDeferredContext state) ∨ + FirstExistingHiddenChainStartHit observations) + (hresult : some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache)) : + ObservedStoppedCause table result := by + rcases hcause with hmissing | hchain + · exact Or.inl + (missingChainStartHit_of_mem_observedMaterializedBoundary parameter root ftsSecret + computation observations state fuel table cache result hmissing hresult).2 + · right + have hprefix := observations_prefix_of_mem_observedMaterializedBoundary parameter root + ftsSecret computation observations state fuel table cache result hresult + exact hchain.prefix hprefix + +theorem relTriple_any_observedMaterializedBoundary_of_stoppedCause + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (source : ProbComp PrivateWitnessSnapshotOutput) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hdoomed : DoomedResolvedContext table (directDeferredContext state)) + (hcause : MissingChainStartHit table (directDeferredContext state) ∨ + FirstExistingHiddenChainStartHit observations) : + RelTriple source + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache) + (SnapshotObservedPrefixStoppedRel table) := by + have hbase := relTriple_true source + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + apply relTriple_post_mono hboth + intro sourceOutput observed hrelation + cases observed with + | none => exact Or.inl rfl + | some result => + right + right + refine ⟨result, rfl, ?_, ?_, ?_⟩ + · exact (materializedDoomed_of_mem_observedMaterializedBoundary parameter root ftsSecret + computation observations state fuel table cache result hdoomed hrelation.2).1 + · exact (materializedDoomed_of_mem_observedMaterializedBoundary parameter root ftsSecret + computation observations state fuel table cache result hdoomed hrelation.2).2 + · exact observedStoppedCause_of_mem_observedMaterializedBoundary parameter root ftsSecret + computation observations state fuel table cache result hcause hrelation.2 + +theorem SnapshotObservedPrefixStoppedRel.aligned_of_successful_firstRoot + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} + {result : ObservedCleanRunResult (α × SplitHashCache)} + (hrelation : SnapshotObservedPrefixStoppedRel table source (some result)) + (finalResult : ObservedCleanRunResult (α × SplitHashCache)) + (hfinish : some finalResult ∈ support + (finishObservedCleanRunFromTable (some result))) + (ordinal : Nat) + (hfirst : FirstExistingHiddenHitAt result ordinal) + (hroot : ∀ selected : Fin result.observations.length, + selected.val = ordinal → + (result.observations.get selected).toProbe.IsLayerRoot) : + ∃ aligned, + aligned <+: result.observations ∧ + SnapshotsObservedAt table source.2 aligned ∧ + ∀ witness, source.1 = some witness → + result.state.values (.position witness.position) = some witness.output := by + rcases hrelation with hnone | haligned | hstopped + · simp at hnone + · obtain ⟨other, aligned, hresult, hprefix, hsnapshots, hstored⟩ := haligned + have heq : other = result := Option.some.inj hresult.symm + subst other + exact ⟨aligned, hprefix, hsnapshots, hstored⟩ + · obtain ⟨other, hresult, htable, _hdoomed, hcause⟩ := hstopped + have heq : other = result := Option.some.inj hresult.symm + subst other + rcases hcause with hmissing | hchain + · rw [← htable] at hmissing + exact (not_missingChainStartHit_of_mem_finishObservedCleanRunFromTable result finalResult + hfinish hmissing).elim + · obtain ⟨selected, hselected, _hhit⟩ := hchain.selected_eq hfirst + exact (not_firstExistingHiddenRootHitAt_of_firstChainStart hchain hfirst selected hselected + (hroot selected hselected)).elim + +theorem candidateStopCause_of_not_completable + (table : OtsSecretIndex → HashOutput) + (candidate : Probe) + (observations : List CleanProbeObservation) + (left right : DeferredContext) + (hcontext : FinalizationContextLE table left right) + (hrevealed : left.state.revealed = right.state.revealed) + (hcanonical : CanonicalMaterializedValues table left) + (hrightMaterialized : right = directDeferredContext right.state) + (hhidden : candidate.coordinate ∉ right.state.revealed) + (hnoEarlier : ∀ observation ∈ observations, + ¬observation.ExistingHiddenHit) + (hcard : (right.state.addPending candidate.coordinate candidate.candidate).pending.card < + Fintype.card Digest) + (hnotCompletable : ¬DeferredCompletable table + ({ right with state := right.state.addPending candidate.coordinate candidate.candidate } : + DeferredContext)) : + PrivateStructuralHit + ({ left with state := left.state.addPending candidate.coordinate candidate.candidate } : + DeferredContext) ∨ + MissingChainStartHit table + ({ right with state := right.state.addPending candidate.coordinate candidate.candidate } : + DeferredContext) ∨ + FirstExistingHiddenChainStartHit + (observations ++ [cleanProbeObservation right.state + candidate.coordinate candidate.candidate]) := by + let nextRight : DeferredContext := + { right with state := right.state.addPending candidate.coordinate candidate.candidate } + cases hvalue : right.state.values candidate.coordinate with + | some output => + have hhit : truncateHash output = candidate.candidate := by + by_contra hmiss + obtain ⟨completion, hcompletion⟩ := hcontext.rightCompletable + have hresolved : resolvedCompletionValue table right candidate.coordinate = some output := by + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + have hvalue' : right.state.values + (.chainStart lay tree leafIdx chainIdx) = some output := by + simpa [hcoordinate] using hvalue + have htable := hcontext.view.rightStarts ⟨lay, tree, leafIdx, chainIdx⟩ output + hvalue' + simp [resolvedCompletionValue, htable] + | position position => + rw [hrightMaterialized] + have hvalue' : right.state.values (.position position) = some output := by + simpa [hcoordinate] using hvalue + simp [resolvedCompletionValue, directDeferredContext, + DeferredContext.positionValue, hvalue'] + have hcompletionOutput : completion candidate.coordinate = output := + hcompletion.eq_resolvedCompletionValue candidate.coordinate output hresolved + apply hnotCompletable + refine ⟨completion, hcompletion.addPending_of_avoids + candidate.coordinate candidate.candidate ?_⟩ + rw [hcompletionOutput] + exact hmiss + cases hcoordinate : candidate.coordinate with + | chainStart lay tree leafIdx chainIdx => + right + right + let observation := cleanProbeObservation right.state + (.chainStart lay tree leafIdx chainIdx) candidate.candidate + change FirstExistingHiddenChainStartHit (observations ++ [observation]) + have hobservationHit : observation.ExistingHiddenChainStartHit := by + refine ⟨?_, ⟨⟨lay, tree, leafIdx, chainIdx⟩, ?_⟩⟩ + · refine ⟨?_, output, ?_, hhit⟩ + · have hhidden' : Coordinate.chainStart lay tree leafIdx chainIdx ∉ + right.state.revealed := by simpa [hcoordinate] using hhidden + simp [observation, cleanProbeObservation, hhidden'] + · have hvalue' : right.state.values + (.chainStart lay tree leafIdx chainIdx) = some output := by + simpa [hcoordinate] using hvalue + simp [observation, cleanProbeObservation, hvalue'] + · rfl + have hlength : observations.length < (observations ++ [observation]).length := by simp + let selected : Fin (observations ++ [observation]).length := + ⟨observations.length, hlength⟩ + refine ⟨selected, ?_, ?_⟩ + · simpa [selected, observation] + · intro earlier hearlier + have hearlierLength : earlier.val < observations.length := by + simpa [selected] using hearlier + let before : Fin observations.length := ⟨earlier.val, hearlierLength⟩ + have hbefore := hnoEarlier (observations.get before) (List.get_mem _ _) + simpa [selected, before, List.getElem_append, hearlierLength] using hbefore + | position position => + left + have hleftHidden : left.state.values (.position position) = none := by + apply canonical_value_none_of_not_revealed hcanonical + intro hleftRevealed + apply hhidden + rw [← hrevealed] + simpa [hcoordinate] using hleftRevealed + have hrightValue : right.state.values (.position position) = some output := by + simpa [hcoordinate] using hvalue + have hprivate : left.values position = some output := + hcontext.view.privateValue_of_left_hidden_of_right_materialized position output + hleftHidden hrightValue + refine ⟨position, output, ?_, hprivate, ?_⟩ + · simpa [LazyRevealProbe.State.addPending, hcoordinate] using hleftHidden + · unfold LazyRevealProbe.State.hitAt + rw [LazyRevealProbe.State.mem_pendingAt_iff] + simp [LazyRevealProbe.State.addPending, hhit] + | none => + right + left + have hvalid : nextRight.Valid := by + apply hcontext.rightValid.addPending_of_value_none + exact hvalue + have hstarts : StartTableAgrees nextRight.state table := by + exact hcontext.view.rightStarts.addPending candidate.coordinate candidate.candidate + have hcause := privateStructuralHit_or_missingChainStartHit_of_not_completable table nextRight + hvalid hstarts hcard hnotCompletable + exact hcause.resolve_left (not_privateStructuralHit_of_directDeferredContext nextRight (by + dsimp [nextRight] + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_addPending])) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedAlignedProjection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedAlignedProjection.lean new file mode 100644 index 00000000..268aff18 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedAlignedProjection.lean @@ -0,0 +1,227 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedNonRoot + +/-! +# Aligned stopped diagnostic projection + +The stopped relation retains the equality between the source candidate and the comparison +observation at the selected ordinal. Consequently the comparison-side root classification can be +transported to the exact source selector without enlarging to the unclassified source event. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +def PlannedProbeSnapshot.ExistingHiddenPositionHit + (table : OtsSecretIndex → HashOutput) (snapshot : PlannedProbeSnapshot) : Prop := + ∃ observation position, + snapshot.ObservedAt table observation ∧ + observation.coordinate = .position position ∧ observation.ExistingHiddenHit + +def SnapshotsAvoidExistingHiddenPositionHits + (table : OtsSecretIndex → HashOutput) + (snapshots : List PlannedProbeSnapshot) : Prop := + ∀ snapshot ∈ snapshots, ¬snapshot.ExistingHiddenPositionHit table + +theorem PlannedProbeSnapshot.ObservedAt.existingHiddenPositionHit_iff + {table : OtsSecretIndex → HashOutput} + {snapshot : PlannedProbeSnapshot} {observation : CleanProbeObservation} + (haligned : snapshot.ObservedAt table observation) : + snapshot.ExistingHiddenPositionHit table ↔ + ∃ position, observation.coordinate = .position position ∧ + observation.ExistingHiddenHit := by + constructor + · rintro ⟨other, position, hother, hposition, hhit⟩ + have hprobe : other.toProbe = observation.toProbe := hother.1.trans haligned.1.symm + have hcoordinate : other.coordinate = observation.coordinate := + congrArg Probe.coordinate hprobe + have hcandidate : other.candidate = observation.candidate := + congrArg Probe.candidate hprobe + refine ⟨position, hcoordinate.symm.trans hposition, ?_⟩ + obtain ⟨hhidden, output, hvalue, hcandidateHit⟩ := hhit + refine ⟨?_, output, ?_, ?_⟩ + · calc + observation.revealedAtProbe = + decide (observation.coordinate ∈ snapshot.context.state.revealed) := + haligned.2.2.1 + _ = decide (other.coordinate ∈ snapshot.context.state.revealed) := by + rw [hcoordinate] + _ = other.revealedAtProbe := hother.2.2.1.symm + _ = false := hhidden + · have hotherValue := hother.2.1 position hposition + have halignedValue := haligned.2.1 position (hcoordinate.symm.trans hposition) + rw [hotherValue] at hvalue + rw [halignedValue] + exact hvalue + · exact hcandidateHit.trans hcandidate + · rintro ⟨position, hposition, hhit⟩ + exact ⟨observation, position, haligned, hposition, hhit⟩ + +theorem SnapshotsObservedAt.avoidExistingHiddenPositionHits + {table : OtsSecretIndex → HashOutput} + {snapshots : List PlannedProbeSnapshot} + {observations : List CleanProbeObservation} + (haligned : SnapshotsObservedAt table snapshots observations) + (hnoHit : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) : + SnapshotsAvoidExistingHiddenPositionHits table snapshots := by + induction haligned with + | nil => simp [SnapshotsAvoidExistingHiddenPositionHits] + | cons hhead htail ih => + intro snapshot hsnapshot + simp only [List.mem_cons] at hsnapshot + rcases hsnapshot with rfl | hrest + · intro hhit + obtain ⟨_position, _hposition, hobservation⟩ := + hhead.existingHiddenPositionHit_iff.mp hhit + exact hnoHit _ (by simp) hobservation + · apply ih + · intro observation hobservation + exact hnoHit observation (by simp [hobservation]) + · exact hrest + +theorem SelectedSnapshotObservationAlignedAt.avoidExistingHiddenPositionHits + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} + {result : ObservedCleanRunResult α} {ordinal : Nat} + (haligned : SelectedSnapshotObservationAlignedAt table source result ordinal) + (hfirst : FirstExistingHiddenHitAt result ordinal) : + SnapshotsAvoidExistingHiddenPositionHits table (source.2.take ordinal) := by + obtain ⟨_selectedSource, selectedObserved, _hsource, hobserved, _hcandidate, + _hprefix, hsnapshots⟩ := haligned + apply hsnapshots.avoidExistingHiddenPositionHits + intro observation hobservation + obtain ⟨index, hget⟩ := List.mem_iff_get.mp hobservation + obtain ⟨_first, _hfirstOrdinal, _hfirstHit, hbefore⟩ := hfirst + have hindexLt : index.val < ordinal := by + have hlt := index.isLt + simp only [List.length_take] at hlt + omega + have hresultLt : index.val < result.observations.length := by + have hordinalLt : ordinal < result.observations.length := by + rw [← hobserved] + exact selectedObserved.isLt + exact hindexLt.trans hordinalLt + let resultIndex : Fin result.observations.length := ⟨index.val, hresultLt⟩ + have hgetResult : result.observations.get resultIndex = observation := by + obtain ⟨tail, htail⟩ := List.take_prefix ordinal result.observations + have htakeGet : (result.observations.take ordinal).get index = + result.observations.get resultIndex := by + simp [resultIndex] + exact htakeGet.symm.trans hget + rw [← hgetResult] + exact hbefore resultIndex hindexLt + +theorem SnapshotObservedFirstStoppedRel.selectedNonRoot_of_successful_firstNonRoot + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} + {result : ObservedCleanRunResult (α × SplitHashCache)} + (hrelation : SnapshotObservedFirstStoppedRel table source (some result)) + (finalResult : ObservedCleanRunResult (α × SplitHashCache)) + (hfinish : some finalResult ∈ support + (finishObservedCleanRunFromTable (some result))) + (ordinal : Nat) + (selected : Fin result.observations.length) + (hselected : selected.val = ordinal) + (hfirst : FirstExistingHiddenHitAt result ordinal) + (hnonRoot : ¬(result.observations.get selected).toProbe.IsLayerRoot) + (hnotChain : ¬FirstExistingHiddenChainStartHitAt result.observations ordinal) : + SelectedPrivateSnapshotNonRootHitAt source ordinal := by + rcases hrelation.selectedAligned_or_chain_of_successful_firstHit finalResult hfinish ordinal + hfirst with ⟨hhit, haligned⟩ | hchain + · rcases selectedPrivateSnapshotHitAt_root_or_nonRoot' hhit with hroot | hnonRootSource + · obtain ⟨sourceSelected, target, output, hsourceSelected, _hselection, hgood, + htargetRoot⟩ := hroot + obtain ⟨alignedSource, alignedObserved, halignedSource, halignedObserved, + hcandidates, _hprefix, _hsnapshots⟩ := haligned + have hsourceEq : sourceSelected = alignedSource := + Fin.ext (hsourceSelected.trans halignedSource.symm) + have hobservedEq : alignedObserved = selected := + Fin.ext (halignedObserved.trans hselected.symm) + have hsourceRoot : (source.2.get alignedSource).probe.IsLayerRoot := by + rw [← hsourceEq] + refine ⟨target, ?_, htargetRoot⟩ + exact congrArg Probe.coordinate hgood.1 + have hobservedRoot : + (result.observations.get alignedObserved).toProbe.IsLayerRoot := by + rw [← hcandidates] + exact hsourceRoot + rw [hobservedEq] at hobservedRoot + exact (hnonRoot hobservedRoot).elim + · exact hnonRootSource + · exact (hnotChain (hchain.at_of_firstExistingHiddenHitAt hfirst)).elim + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_observedMaterialized_successfulDoomed_firstNonRoot_le_selectedNonRoot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun source => SelectedPrivateSnapshotNonRootHitAt source ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q] := by + let source := granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q + let observed := observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + calc + _ ≤ Pr[fun source => SelectedPrivateSnapshotNonRootHitAt source ordinal | source] + + Pr[ObservedMaterializedOutput.FirstExistingHiddenChainStartHitAt ordinal | observed] := by + apply probEvent_le_failure_add_residual_of_relTriple observed source + (fun observed source => SnapshotObservedFirstStoppedRel table source observed) + (ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt table ordinal) + (ObservedMaterializedOutput.FirstExistingHiddenChainStartHitAt ordinal) + (fun source => SelectedPrivateSnapshotNonRootHitAt source ordinal) + (relTriple_symm + (relTriple_granularAllSnapshot_observedMaterializedRetained_firstStopped adversary + parameter ftsSecret q table hbound hq)) + intro right left hrelation hevent hnotChain + cases right with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt] at hevent + | some result => + obtain ⟨⟨finalResult, hfinish⟩, selected, hselected, hfirst, + hnonRoot⟩ := hevent + exact hrelation.selectedNonRoot_of_successful_firstNonRoot finalResult hfinish ordinal + selected hselected hfirst hnonRoot hnotChain + _ = _ := by + rw [probEvent_firstExistingHiddenChainStartHitAt_eq_zero adversary parameter ftsSecret + (2 * q) ordinal table] + simp [source] + +set_option maxRecDepth 1000000 in +set_option maxHeartbeats 2000000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_firstNonRoot_le + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_sampledDiagnostic_successfulDoomed_firstExistingHiddenNonRootHitAt_le_of_forall + intro table + calc + _ ≤ Pr[fun source => SelectedPrivateSnapshotNonRootHitAt source ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q] := + probEvent_observedMaterialized_successfulDoomed_firstNonRoot_le_selectedNonRoot adversary + parameter ftsSecret q ordinal table (hbound table) hq + _ ≤ _ := probEvent_granularAllCanonical_selectedNonRoot_le ordinal adversary parameter + table ftsSecret q + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedChain.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedChain.lean new file mode 100644 index 00000000..31853fea --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedChain.lean @@ -0,0 +1,314 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedProjection +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryDirect + +/-! +# Hidden chain-start observations are unreachable + +The masked signer reveals every materialized chain coordinate before returning to the adversary. +The published root and signer computations are probe-free, and the direct hash handler performs its +single probe before its probe-free public action. Consequently no retained observation can see a +materialized but hidden chain start. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +def NoExistingHiddenChainStartHits (observations : List CleanProbeObservation) : Prop := + ∀ observation ∈ observations, ¬observation.ExistingHiddenChainStartHit + +theorem not_existingHiddenChainStartHit_cleanProbeObservation_of_chainValid + (state : LazyRevealProbe.State Coordinate) + (hvalid : ChainState.ValidFor (fun _ => True) state) + (coordinate : Coordinate) (candidate : Digest) : + ¬(cleanProbeObservation state coordinate candidate).ExistingHiddenChainStartHit := by + intro hhit + have hhidden := hhit.1.1 + obtain ⟨output, hvalue, _hcandidate⟩ := hhit.1.2 + obtain ⟨index, hcoordinate⟩ := hhit.2 + change coordinate = index.coordinate at hcoordinate + have hchain : IsChainCoordinate coordinate := by + rw [hcoordinate] + simp [IsChainCoordinate, OtsSecretIndex.coordinate] + have hstored : state.values coordinate ≠ none := by + simp [cleanProbeObservation] at hvalue + simp [hvalue] + have hrevealed := (hvalid coordinate hchain).1 hstored + simp [cleanProbeObservation, hrevealed] at hhidden + +set_option maxRecDepth 100000 in +theorem chainValid_of_mem_runObservedCleanFromTable + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hpreserves : PreservesChainValid (fun _ => True) computation) + (hvalid : ChainState.ValidFor (fun _ => True) state) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table (computation.run cache))) : + ChainState.ValidFor (fun _ => True) result.state := by + have hclean : some result.toClean ∈ support + (runCleanFromTable state fuel table (computation.run cache)) := by + rw [← map_projectObservedCleanRun_runObservedCleanFromTable + (computation.run cache) observations state fuel table, support_map] + exact ⟨some result, hresult, rfl⟩ + have hraw := mem_support_runRaw_done_of_mem_runCleanFromTable_some + (computation.run cache) state fuel table result.toClean hclean + rcases hvalue : result.value with ⟨value, finalCache⟩ + exact hpreserves state cache fuel result.state result.remaining value finalCache hvalid (by + simpa [ObservedCleanRunResult.toClean, hvalue] using hraw) + +theorem NoExistingHiddenChainStartHits.append_cleanProbeObservation + {observations : List CleanProbeObservation} + (hobservations : NoExistingHiddenChainStartHits observations) + (state : LazyRevealProbe.State Coordinate) + (hvalid : ChainState.ValidFor (fun _ => True) state) + (coordinate : Coordinate) (candidate : Digest) : + NoExistingHiddenChainStartHits + (observations ++ [cleanProbeObservation state coordinate candidate]) := by + intro observation hobservation + simp only [List.mem_append, List.mem_singleton] at hobservation + rcases hobservation with hold | rfl + · exact hobservations observation hold + · exact not_existingHiddenChainStartHit_cleanProbeObservation_of_chainValid + state hvalid coordinate candidate + +theorem preservesChainValid_probingHashQueryPublicAction_true + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (action : PlannedHashAction) : + PreservesChainValid (fun _ => True) + (probingHashQueryPublicAction parameter input publicState action) := by + cases action with + | ordinary => exact preservesChainValid_splitHashQuery_ordinary (fun _ => True) input + | resolve coordinate => + simp only [probingHashQueryPublicAction] + unfold resolvePublicKnownInput + cases purePeekTableInput parameter publicState coordinate with + | none => exact preservesChainValid_splitHashQuery_ordinary (fun _ => True) input + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + exact preservesChainValid_revealPublishOrdinary (fun _ => True) coordinate input + (fun _ => trivial) + · simp only [heq, ↓reduceIte] + exact preservesChainValid_splitHashQuery_ordinary (fun _ => True) input + +set_option maxRecDepth 100000 in +theorem rootAwarePublic_invariants_of_mem_runObservedCleanFromTable + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ObservedCleanRunResult (HashOutput × SplitHashCache)) + (hobservations : NoExistingHiddenChainStartHits observations) + (hvalid : ChainState.ValidFor (fun _ => True) state) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache))) : + ChainState.ValidFor (fun _ => True) result.state ∧ + NoExistingHiddenChainStartHits result.observations := by + let publicAction := probingHashQueryPublicAction parameter input publicState plan.action + have hpreserves : PreservesChainValid (fun _ => True) publicAction := + preservesChainValid_probingHashQueryPublicAction_true parameter input publicState plan.action + have hprobeFree (workingCache : SplitHashCache) : + (publicAction.run workingCache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0 := + probingHashQueryPublicAction_probeFree parameter input publicState plan.action workingCache + cases hcandidate : rootAwareCandidateForPlan? parameter input plan with + | none => + rw [runObservedCleanFromTable_rootAwarePublic_of_none parameter input publicState plan + observations state fuel table cache hcandidate] at hresult + have hfinalValid := chainValid_of_mem_runObservedCleanFromTable publicAction observations + state fuel table cache result hpreserves hvalid hresult + have hobservationsEq := observations_eq_of_mem_runObservedCleanFromTable_of_probeFree + (publicAction.run cache) observations state fuel table result (hprobeFree cache) hresult + exact ⟨hfinalValid, hobservationsEq ▸ hobservations⟩ + | some candidate => + cases fuel with + | zero => + unfold probingHashQueryAfterRootAwarePublicPlan at hresult + rw [StateT.run_bind] at hresult + simp [executeCandidate?, hcandidate, probe, LazyRevealProbe.probeQuery, + runObservedCleanFromTable] at hresult + | succ remaining => + have hnextObservations := hobservations.append_cleanProbeObservation state hvalid + candidate.coordinate candidate.candidate + by_cases hrevealed : candidate.coordinate ∈ state.revealed + · rw [runObservedCleanFromTable_rootAwarePublic_of_revealed parameter input publicState + plan candidate observations state remaining table cache hcandidate hrevealed] + at hresult + have hfinalValid := chainValid_of_mem_runObservedCleanFromTable publicAction + (observations ++ [cleanProbeObservation state candidate.coordinate + candidate.candidate]) state remaining table cache result hpreserves hvalid hresult + have hobservationsEq := observations_eq_of_mem_runObservedCleanFromTable_of_probeFree + (publicAction.run cache) + (observations ++ [cleanProbeObservation state candidate.coordinate + candidate.candidate]) state remaining table result (hprobeFree cache) hresult + exact ⟨hfinalValid, hobservationsEq ▸ hnextObservations⟩ + · rw [runObservedCleanFromTable_rootAwarePublic_of_hidden parameter input publicState + plan candidate observations state remaining table cache hcandidate hrevealed] + at hresult + have hnextValid := hvalid.addPending candidate.coordinate candidate.candidate + have hfinalValid := chainValid_of_mem_runObservedCleanFromTable publicAction + (observations ++ [cleanProbeObservation state candidate.coordinate + candidate.candidate]) + (state.addPending candidate.coordinate candidate.candidate) remaining table cache + result hpreserves hnextValid hresult + have hobservationsEq := observations_eq_of_mem_runObservedCleanFromTable_of_probeFree + (publicAction.run cache) + (observations ++ [cleanProbeObservation state candidate.coordinate + candidate.candidate]) + (state.addPending candidate.coordinate candidate.candidate) remaining table result + (hprobeFree cache) hresult + exact ⟨hfinalValid, hobservationsEq ▸ hnextObservations⟩ + +set_option maxRecDepth 100000 in +theorem probeFree_invariants_of_mem_runObservedCleanFromTable + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hpreserves : PreservesChainValid (fun _ => True) computation) + (hprobeFree : (computation.run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) + (hobservations : NoExistingHiddenChainStartHits observations) + (hvalid : ChainState.ValidFor (fun _ => True) state) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table (computation.run cache))) : + ChainState.ValidFor (fun _ => True) result.state ∧ + NoExistingHiddenChainStartHits result.observations := by + have hfinalValid := chainValid_of_mem_runObservedCleanFromTable computation observations state + fuel table cache result hpreserves hvalid hresult + have hobservationsEq := observations_eq_of_mem_runObservedCleanFromTable_of_probeFree + (computation.run cache) observations state fuel table result hprobeFree hresult + exact ⟨hfinalValid, hobservationsEq ▸ hobservations⟩ + +set_option maxRecDepth 100000 in +theorem observedMaterializedBoundary_chain_invariants + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hobservations : NoExistingHiddenChainStartHits observations) + (hvalid : ChainState.ValidFor (fun _ => True) state) + (hresult : some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache)) : + ChainState.ValidFor (fun _ => True) result.state ∧ + NoExistingHiddenChainStartHits result.observations := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table cache with + | pure value => + simp [observedMaterializedBoundary] at hresult + obtain rfl := hresult + exact ⟨hvalid, hobservations⟩ + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind] at hresult + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + have hnext := probeFree_invariants_of_mem_runObservedCleanFromTable + (splitUniformImpl n) observations state fuel table cache step + (preservesChainValid_splitUniformImpl (fun _ => True) n) + (splitUniformImpl_probeFree n cache) hobservations hvalid hstep + exact ih step.value.1 step.observations step.state step.remaining table + step.value.2 hnext.2 hnext.1 (by + simpa only [observedMaterializedBoundary] using hrest) + | inr input => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + have hnext := rootAwarePublic_invariants_of_mem_runObservedCleanFromTable + parameter input publicContext.state plan observations state fuel table cache + step hobservations hvalid hstep + exact ih step.value.1 step.observations step.state step.remaining table + step.value.2 hnext.2 hnext.1 (by + simpa only [observedMaterializedBoundary] using hrest) + | inr message => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + have hnext := probeFree_invariants_of_mem_runObservedCleanFromTable + (maskedSign parameter root ftsSecret message) observations state fuel table cache + step (preservesChainValid_maskedSign_true parameter root ftsSecret message) + (maskedSign_probeFree parameter root ftsSecret message cache) hobservations hvalid + hstep + exact ih step.value.1 step.observations step.state step.remaining table + step.value.2 hnext.2 hnext.1 (by + simpa only [observedMaterializedBoundary] using hrest) + +theorem NoExistingHiddenChainStartHits.not_firstAt + {observations : List CleanProbeObservation} + (hobservations : NoExistingHiddenChainStartHits observations) (ordinal : Nat) : + ¬FirstExistingHiddenChainStartHitAt observations ordinal := by + rintro ⟨selected, _hordinal, hhit, _hfirst⟩ + exact hobservations (observations.get selected) (List.get_mem observations selected) hhit + +def ObservedMaterializedOutputNoHiddenChainStartHits : + Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) → Prop + | none => True + | some result => NoExistingHiddenChainStartHits result.observations + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxRecDepth 100000 in +theorem observedMaterializedOutputNoHiddenChainStartHits_of_mem_retainedRunFromTable + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (output : Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))) + (houtput : output ∈ support + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table)) : + ObservedMaterializedOutputNoHiddenChainStartHits output := by + unfold observedMaterializedRetainedRunFromTable at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨rootResult?, hroot, hrest⟩ := houtput + cases rootResult? with + | none => + simp at hrest + subst output + trivial + | some rootResult => + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult?, hrestResult, hreturn⟩ := hrest + cases restResult? with + | none => + simp at hreturn + subst output + trivial + | some restResult => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + subst output + have hrootInvariants := probeFree_invariants_of_mem_runObservedCleanFromTable + maskedPublishedTreeRoot [] LazyRevealProbe.State.empty fuel table emptySplitHashCache + rootResult preservesChainValid_maskedPublishedTreeRoot_true + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) + (by intro observation hobservation; simp at hobservation) + (ChainState.validFor_empty (fun _ => True)) hroot + have hrestInvariants := observedMaterializedBoundary_chain_invariants parameter + rootResult.value.1 + ftsSecret (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table rootResult.value.2 + restResult hrootInvariants.2 hrootInvariants.1 hrestResult + exact hrestInvariants.2 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedChainProbability.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedChainProbability.lean new file mode 100644 index 00000000..68d5575f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedChainProbability.lean @@ -0,0 +1,80 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedChain + +/-! +# Probability projection for unreachable chain-start observations + +The named option event keeps the retained result type opaque while the support invariant is +projected to probability zero. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +def ObservedMaterializedOutput.FirstExistingHiddenChainStartHitAt + (ordinal : Nat) : + Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) → Prop + | none => False + | some result => + SphincsSecurity.Concrete.OtsProbeSimulation.FirstExistingHiddenChainStartHitAt + result.observations ordinal + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_firstExistingHiddenChainStartHitAt_eq_zero + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel ordinal : Nat) + (table : OtsSecretIndex → HashOutput) : + Pr[ObservedMaterializedOutput.FirstExistingHiddenChainStartHitAt ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table] = 0 := by + apply probEvent_eq_zero + intro output houtput hevent + unfold observedMaterializedRetainedRunFromTable at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨rootResult?, hroot, hrest⟩ := houtput + cases rootResult? with + | none => + simp at hrest + subst output + exact hevent + | some rootResult => + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult?, hrestResult, hreturn⟩ := hrest + cases restResult? with + | none => + simp at hreturn + subst output + exact hevent + | some restResult => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + subst output + have hrootInvariants := probeFree_invariants_of_mem_runObservedCleanFromTable + maskedPublishedTreeRoot [] LazyRevealProbe.State.empty fuel table emptySplitHashCache + rootResult preservesChainValid_maskedPublishedTreeRoot_true + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) + (by intro observation hobservation; simp at hobservation) + (ChainState.validFor_empty (fun _ => True)) hroot + have hrestInvariants := observedMaterializedBoundary_chain_invariants parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table rootResult.value.2 + restResult hrootInvariants.2 hrootInvariants.1 hrestResult + exact hrestInvariants.2.not_firstAt ordinal hevent + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampled_firstExistingHiddenChainStartHitAt_eq_zero + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel ordinal : Nat) : + Pr[ObservedMaterializedOutput.FirstExistingHiddenChainStartHitAt ordinal | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table] = 0 := by + rw [probEvent_bind_eq_tsum (mx := sampleOtsHashTable)] + apply ENNReal.tsum_eq_zero.2 + intro table + rw [probEvent_firstExistingHiddenChainStartHitAt_eq_zero] + simp + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedHash.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedHash.lean new file mode 100644 index 00000000..c7538303 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedHash.lean @@ -0,0 +1,467 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSource + +/-! +# Stopped root-aware hash boundary + +The root-aware comparison executes its candidate probe before the probe-free public action. This +module exposes the exact hidden-candidate state at that boundary. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem runObservedCleanFromTable_rootAwarePublic_of_hidden + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (candidate : Probe) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (remaining : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcandidate : rootAwareCandidateForPlan? parameter input plan = some candidate) + (hhidden : candidate.coordinate ∉ state.revealed) : + runObservedCleanFromTable observations state (remaining + 1) table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) = + runObservedCleanFromTable + (observations ++ [cleanProbeObservation state + candidate.coordinate candidate.candidate]) + (state.addPending candidate.coordinate candidate.candidate) remaining table + ((probingHashQueryPublicAction parameter input publicState plan.action).run cache) := by + unfold probingHashQueryAfterRootAwarePublicPlan + rw [StateT.run_bind] + simp only [executeCandidate?, hcandidate, probe, StateT.run_liftM, + LazyRevealProbe.probeQuery] + simp only [bind_assoc, pure_bind] + rw [runObservedCleanFromTable_probe_query_bind] + simp [hhidden] + +noncomputable def observedMaterializedHashContinuation + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (plan : PlannedHashQuery) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option (ObservedCleanRunResult (α × SplitHashCache))) := do + let step ← runObservedCleanFromTable observations state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input + (materializedCanonicalContext table state).state plan).run cache) + match step with + | none => pure none + | some step => + observedMaterializedBoundary parameter root ftsSecret (next step.value.1) + step.observations step.state step.remaining table step.value.2 + +set_option maxRecDepth 100000 in +theorem stopped_data_of_mem_observedMaterializedHashContinuation + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (plan : PlannedHashQuery) (candidate : Probe) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (remaining : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hcandidate : rootAwareCandidateForPlan? parameter input plan = some candidate) + (hhidden : candidate.coordinate ∉ state.revealed) + (hdoomed : DoomedResolvedContext table + (directDeferredContext + (state.addPending candidate.coordinate candidate.candidate))) + (hresult : some result ∈ support + (observedMaterializedHashContinuation parameter root ftsSecret input plan next observations + state (remaining + 1) table cache)) : + result.table = table ∧ + DoomedResolvedContext table (directDeferredContext result.state) ∧ + (observations ++ [cleanProbeObservation state + candidate.coordinate candidate.candidate]) <+: result.observations := by + unfold observedMaterializedHashContinuation at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + rw [runObservedCleanFromTable_rootAwarePublic_of_hidden parameter input + (materializedCanonicalContext table state).state plan candidate observations state remaining + table cache hcandidate hhidden] at hstep + cases step? with + | none => simp at hrest + | some step => + have hstepDoomed := materializedDoomed_of_mem_runObservedCleanFromTable + ((probingHashQueryPublicAction parameter input + (materializedCanonicalContext table state).state plan.action).run cache) + (observations ++ [cleanProbeObservation state + candidate.coordinate candidate.candidate]) + (state.addPending candidate.coordinate candidate.candidate) remaining table step hdoomed + hstep + have hrestDoomed := materializedDoomed_of_mem_observedMaterializedBoundary parameter root + ftsSecret (next step.value.1) step.observations step.state step.remaining table + step.value.2 result hstepDoomed.2 hrest + refine ⟨hrestDoomed.1, hrestDoomed.2, ?_⟩ + exact (observations_prefix_of_mem_runObservedCleanFromTable + ((probingHashQueryPublicAction parameter input + (materializedCanonicalContext table state).state plan.action).run cache) + (observations ++ [cleanProbeObservation state + candidate.coordinate candidate.candidate]) + (state.addPending candidate.coordinate candidate.candidate) remaining table step hstep).trans + (observations_prefix_of_mem_observedMaterializedBoundary parameter root ftsSecret + (next step.value.1) step.observations step.state step.remaining table step.value.2 result + hrest) + +set_option maxRecDepth 100000 in +theorem stopped_cause_of_mem_observedMaterializedHashContinuation + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (plan : PlannedHashQuery) (candidate : Probe) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (remaining : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hcandidate : rootAwareCandidateForPlan? parameter input plan = some candidate) + (hhidden : candidate.coordinate ∉ state.revealed) + (hcause : MissingChainStartHit table + (directDeferredContext + (state.addPending candidate.coordinate candidate.candidate)) ∨ + FirstExistingHiddenChainStartHit + (observations ++ [cleanProbeObservation state + candidate.coordinate candidate.candidate])) + (hresult : some result ∈ support + (observedMaterializedHashContinuation parameter root ftsSecret input plan next observations + state (remaining + 1) table cache)) : + ObservedStoppedCause table result := by + unfold observedMaterializedHashContinuation at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + rw [runObservedCleanFromTable_rootAwarePublic_of_hidden parameter input + (materializedCanonicalContext table state).state plan candidate observations state remaining + table cache hcandidate hhidden] at hstep + cases step? with + | none => simp at hrest + | some step => + have hstepCause : MissingChainStartHit table (directDeferredContext step.state) ∨ + FirstExistingHiddenChainStartHit step.observations := by + rcases hcause with hmissing | hchain + · exact Or.inl (missingChainStartHit_of_mem_runObservedCleanFromTable + ((probingHashQueryPublicAction parameter input + (materializedCanonicalContext table state).state plan.action).run cache) + (observations ++ [cleanProbeObservation state + candidate.coordinate candidate.candidate]) + (state.addPending candidate.coordinate candidate.candidate) remaining table step + hmissing hstep).2 + · exact Or.inr (hchain.prefix + (observations_prefix_of_mem_runObservedCleanFromTable + ((probingHashQueryPublicAction parameter input + (materializedCanonicalContext table state).state plan.action).run cache) + (observations ++ [cleanProbeObservation state + candidate.coordinate candidate.candidate]) + (state.addPending candidate.coordinate candidate.candidate) remaining table step + hstep)) + exact observedStoppedCause_of_mem_observedMaterializedBoundary parameter root ftsSecret + (next step.value.1) step.observations step.state step.remaining table step.value.2 result + hstepCause hrest + +set_option maxRecDepth 100000 in +theorem candidatesAvoidRoot_of_aligned_tracked + (table : OtsSecretIndex → HashOutput) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (candidate : Probe) (left right : DeferredContext) + (hbefore : SnapshotsBefore snapshots left) + (hcontext : FinalizationContextLE table left right) + (hrightMaterialized : right = directDeferredContext right.state) + (hnoEarlier : ∀ observation ∈ observations, + ¬observation.ExistingHiddenHit) + (haligned : SnapshotsObservedAt table snapshots observations) + (htracked : CleanProbeObservationsTrackedBy observations right.state) + (position : Position) (output : HashOutput) + (hcandidate : candidate = ⟨.position position, truncateHash output⟩) + (hstate : left.state.values (.position position) = none) + (hprivate : left.values position = some output) + (hhidden : candidate.coordinate ∉ left.state.revealed) : + CandidatesAvoidRoot position (truncateHash output) + (snapshots.map PlannedProbeSnapshot.toProbe) := by + have hleftHidden : Coordinate.position position ∉ left.state.revealed := by + simpa [hcandidate] using hhidden + have hleftResolved : resolvedCompletionValue table left (.position position) = some output := by + simp [resolvedCompletionValue, DeferredContext.positionValue, hstate, hprivate] + have hrightResolved : + resolvedCompletionValue table right (.position position) = some output := by + rw [← hcontext.view.valueEq] + exact hleftResolved + have hrightValue : right.state.values (.position position) = some output := by + rw [hrightMaterialized] at hrightResolved + cases hvalue : right.state.values (.position position) with + | none => + simp [resolvedCompletionValue, DeferredContext.positionValue, directDeferredContext, + directDeferredValues, hvalue] at hrightResolved + | some stored => + have hstored : stored = output := by + simpa [resolvedCompletionValue, DeferredContext.positionValue, directDeferredContext, + directDeferredValues, hvalue] using hrightResolved + simpa [hvalue, hstored] + intro earlier hearlier heq + obtain ⟨mappedOrdinal, hmapped⟩ := List.mem_iff_get.mp hearlier + let snapshotOrdinal : Fin snapshots.length := + ⟨mappedOrdinal.val, by simpa using mappedOrdinal.isLt⟩ + have hsnapshotProbe : (snapshots.get snapshotOrdinal).probe = earlier := by + simpa [snapshotOrdinal] using hmapped + let observationOrdinal : Fin observations.length := + ⟨snapshotOrdinal.val, by rw [← haligned.length_eq]; exact snapshotOrdinal.isLt⟩ + have hpair := haligned.get snapshotOrdinal.isLt observationOrdinal.isLt + have hpair' : PlannedProbeSnapshot.ObservedAt table + (snapshots.get snapshotOrdinal) (observations.get observationOrdinal) := by + simpa [observationOrdinal] using hpair + have hobservationProbe : + (observations.get observationOrdinal).toProbe = + ⟨.position position, truncateHash output⟩ := by + rw [hpair'.1, hsnapshotProbe, heq] + have hobservationCoordinate : + (observations.get observationOrdinal).coordinate = .position position := + congrArg Probe.coordinate hobservationProbe + have hobservationCandidate : + (observations.get observationOrdinal).candidate = truncateHash output := + congrArg Probe.candidate hobservationProbe + have hsnapshotHidden : Coordinate.position position ∉ + (snapshots.get snapshotOrdinal).context.state.revealed := by + intro hrevealed + exact hleftHidden + ((hbefore (snapshots.get snapshotOrdinal) (List.get_mem _ _)).1 hrevealed) + have hobservationHidden : + (observations.get observationOrdinal).revealedAtProbe = false := by + rw [hpair'.2.2.1, hobservationCoordinate] + exact decide_eq_false hsnapshotHidden + have hobservationTracked := htracked (observations.get observationOrdinal) + (List.get_mem _ _) + cases hobservationValue : + (observations.get observationOrdinal).valueAtProbe with + | some stored => + have hstored := hobservationTracked.1 stored hobservationValue + rw [hobservationCoordinate, hrightValue] at hstored + have heqStored : stored = output := Option.some.inj hstored.symm + subst stored + exact (hnoEarlier (observations.get observationOrdinal) (List.get_mem _ _) + ⟨hobservationHidden, output, hobservationValue, hobservationCandidate.symm⟩).elim + | none => + rcases hobservationTracked.2 hobservationValue hobservationHidden with + hpending | ⟨stored, hstored, hmismatch⟩ + · rw [hobservationCoordinate, hrightValue] at hpending + simp at hpending + · rw [hobservationCoordinate, hrightValue] at hstored + have heqStored : stored = output := Option.some.inj hstored.symm + subst stored + exact (hmismatch hobservationCandidate.symm).elim + +set_option maxRecDepth 100000 in +theorem relTriple_source_observedMaterializedHashContinuation_firstStopped_of_private + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (plan : PlannedHashQuery) (candidate : Probe) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (source : ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (remaining : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcandidate : rootAwareCandidateForPlan? parameter input plan = some candidate) + (hcontext : FinalizationContextLE table left right) + (hrevealed : left.state.revealed = right.state.revealed) + (hrightMaterialized : right = directDeferredContext right.state) + (hhidden : candidate.coordinate ∉ right.state.revealed) + (hnoEarlier : ∀ observation ∈ observations, + ¬observation.ExistingHiddenHit) + (haligned : SnapshotsObservedAt table snapshots observations) + (hbefore : SnapshotsBefore snapshots left) + (htracked : CleanProbeObservationsTrackedBy observations right.state) + (hsource : ∀ output ∈ support source, + PrivateWitnessSnapshotExtends + (snapshots ++ [(⟨candidate, left⟩ : PlannedProbeSnapshot)]) output) + (hhit : PrivateStructuralHit + ({ left with + state := left.state.addPending candidate.coordinate candidate.candidate } : + DeferredContext)) + (hdoomed : DoomedResolvedContext table + (directDeferredContext + (right.state.addPending candidate.coordinate candidate.candidate))) : + RelTriple source + (observedMaterializedHashContinuation parameter root ftsSecret input plan next observations + right.state (remaining + 1) table cache) + (SnapshotObservedFirstStoppedRel table) := by + have hbase := relTriple_true source + (observedMaterializedHashContinuation parameter root ftsSecret input plan next observations + right.state (remaining + 1) table cache) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun output => output ∈ support source) (fun output houtput => houtput) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro sourceOutput observed hrelation + cases observed with + | none => exact Or.inl rfl + | some result => + have hdata := stopped_data_of_mem_observedMaterializedHashContinuation parameter root + ftsSecret input plan candidate next observations right.state remaining table cache result + hcandidate hhidden hdoomed hrelation.2 + have hfirst := firstExistingHiddenHitAt_append_of_privateStructuralHit table candidate + observations left right hcontext hrightMaterialized hhidden hnoEarlier hhit + right + right + left + have hlength : snapshots.length = observations.length := haligned.length_eq + have hleftHidden : candidate.coordinate ∉ left.state.revealed := by + rwa [hrevealed] + have hextends := hsource sourceOutput hrelation.1.2 + have hfirstResult : FirstExistingHiddenHitAt result snapshots.length := by + simpa [hlength] using hfirst.prefix hdata.2.2 + have hselected : SelectedPrivateSnapshotHitAt sourceOutput snapshots.length := + selectedPrivateSnapshotHitAt_of_appended_privateStructuralHit snapshots candidate left + sourceOutput hextends hcontext.leftCompletable hleftHidden + (fun position output hcandidate' hstate hprivate => + candidatesAvoidRoot_of_aligned_tracked table snapshots observations candidate left right + hbefore hcontext hrightMaterialized hnoEarlier haligned htracked position output + hcandidate' hstate hprivate hleftHidden) + hhit + have hsourceLt : snapshots.length < sourceOutput.2.length := by + have hprefixLength := hextends.length_le + simpa using (Nat.lt_of_lt_of_le (by simp : snapshots.length < + (snapshots ++ [(⟨candidate, left⟩ : PlannedProbeSnapshot)]).length) hprefixLength) + let sourceOrdinal : Fin sourceOutput.2.length := ⟨snapshots.length, hsourceLt⟩ + have hsourceProbe : (sourceOutput.2.get sourceOrdinal).probe = candidate := by + obtain ⟨tail, htail⟩ := hextends + simp [← htail, sourceOrdinal] + have hobservedLt : observations.length < result.observations.length := + (by simp : observations.length < + (observations ++ [cleanProbeObservation right.state candidate.coordinate + candidate.candidate]).length) |>.trans_le hdata.2.2.length_le + let observedOrdinal : Fin result.observations.length := + ⟨observations.length, hobservedLt⟩ + have hobservedProbe : + (result.observations.get observedOrdinal).toProbe = candidate := by + obtain ⟨tail, htail⟩ := hdata.2.2 + simp [← htail, observedOrdinal, cleanProbeObservation, + CleanProbeObservation.toProbe] + have hselectedAligned : + SelectedSnapshotObservationAlignedAt table sourceOutput result snapshots.length := + ⟨sourceOrdinal, observedOrdinal, rfl, hlength.symm, + hsourceProbe.trans hobservedProbe.symm, by + obtain ⟨sourceTail, hsourceTail⟩ := hextends + obtain ⟨observedTail, hobservedTail⟩ := hdata.2.2 + rw [← hsourceTail, ← hobservedTail] + simpa [List.map_append, hlength] using haligned.map_toProbe_eq, by + obtain ⟨sourceTail, hsourceTail⟩ := hextends + obtain ⟨observedTail, hobservedTail⟩ := hdata.2.2 + rw [← hsourceTail, ← hobservedTail] + simpa [hlength] using haligned⟩ + exact ⟨result, snapshots.length, rfl, hdata.1, hdata.2.1, hfirstResult, hselected, + hselectedAligned⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_source_observedMaterializedHashContinuation_firstStopped_of_cause + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (plan : PlannedHashQuery) (candidate : Probe) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (source : ProbComp PrivateWitnessSnapshotOutput) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (remaining : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcandidate : rootAwareCandidateForPlan? parameter input plan = some candidate) + (hhidden : candidate.coordinate ∉ state.revealed) + (hdoomed : DoomedResolvedContext table + (directDeferredContext + (state.addPending candidate.coordinate candidate.candidate))) + (hcause : MissingChainStartHit table + (directDeferredContext + (state.addPending candidate.coordinate candidate.candidate)) ∨ + FirstExistingHiddenChainStartHit + (observations ++ [cleanProbeObservation state + candidate.coordinate candidate.candidate])) : + RelTriple source + (observedMaterializedHashContinuation parameter root ftsSecret input plan next observations + state (remaining + 1) table cache) + (SnapshotObservedFirstStoppedRel table) := by + have hbase := relTriple_true source + (observedMaterializedHashContinuation parameter root ftsSecret input plan next observations + state (remaining + 1) table cache) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + apply relTriple_post_mono hboth + intro sourceOutput observed hrelation + cases observed with + | none => exact Or.inl rfl + | some result => + have hdata := stopped_data_of_mem_observedMaterializedHashContinuation parameter root + ftsSecret input plan candidate next observations state remaining table cache result + hcandidate hhidden hdoomed hrelation.2 + right + right + right + exact ⟨result, rfl, hdata.1, hdata.2.1, + stopped_cause_of_mem_observedMaterializedHashContinuation parameter root ftsSecret input + plan candidate next observations state remaining table cache result hcandidate hhidden + hcause hrelation.2⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_source_observedMaterializedHashContinuation_firstStopped_of_notCompletable + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (plan : PlannedHashQuery) (candidate : Probe) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (source : ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (remaining : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcandidate : rootAwareCandidateForPlan? parameter input plan = some candidate) + (hcontext : FinalizationContextLE table left right) + (hrevealed : left.state.revealed = right.state.revealed) + (hcanonical : CanonicalMaterializedValues table left) + (hrightMaterialized : right = directDeferredContext right.state) + (hhidden : candidate.coordinate ∉ right.state.revealed) + (hnoEarlier : ∀ observation ∈ observations, + ¬observation.ExistingHiddenHit) + (haligned : SnapshotsObservedAt table snapshots observations) + (hbefore : SnapshotsBefore snapshots left) + (htracked : CleanProbeObservationsTrackedBy observations right.state) + (hsource : ∀ output ∈ support source, + PrivateWitnessSnapshotExtends + (snapshots ++ [(⟨candidate, left⟩ : PlannedProbeSnapshot)]) output) + (hcard : (right.state.addPending candidate.coordinate candidate.candidate).pending.card < + Fintype.card Digest) + (hnotCompletable : ¬DeferredCompletable table + ({ right with + state := right.state.addPending candidate.coordinate candidate.candidate } : + DeferredContext)) : + RelTriple source + (observedMaterializedHashContinuation parameter root ftsSecret input plan next observations + right.state (remaining + 1) table cache) + (SnapshotObservedFirstStoppedRel table) := by + let nextRight : DeferredContext := + { right with + state := right.state.addPending candidate.coordinate candidate.candidate } + have hnextRight : nextRight = directDeferredContext + (right.state.addPending candidate.coordinate candidate.candidate) := by + dsimp [nextRight] + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_addPending] + have hdoomed : DoomedResolvedContext table + (directDeferredContext + (right.state.addPending candidate.coordinate candidate.candidate)) := by + rw [← hnextRight] + exact ⟨hcontext.rightValid.valuesConsistent.addPending candidate.coordinate + candidate.candidate, + hcontext.view.rightStarts.addPending candidate.coordinate candidate.candidate, + hnotCompletable⟩ + have hcauses := candidateStopCause_of_not_completable table candidate observations left right + hcontext hrevealed hcanonical hrightMaterialized hhidden hnoEarlier hcard hnotCompletable + rcases hcauses with hprivate | hmissing | hchain + · exact relTriple_source_observedMaterializedHashContinuation_firstStopped_of_private + parameter root ftsSecret input plan candidate next source snapshots observations left right + remaining table cache hcandidate hcontext hrevealed hrightMaterialized hhidden hnoEarlier + haligned hbefore htracked hsource hprivate hdoomed + · apply relTriple_source_observedMaterializedHashContinuation_firstStopped_of_cause + parameter root ftsSecret input plan candidate next source observations right.state remaining + table cache hcandidate hhidden hdoomed + exact Or.inl (by rwa [← hnextRight]) + · exact relTriple_source_observedMaterializedHashContinuation_firstStopped_of_cause + parameter root ftsSecret input plan candidate next source observations right.state remaining + table cache hcandidate hhidden hdoomed (Or.inr hchain) diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedLift.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedLift.lean new file mode 100644 index 00000000..d6c4989b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedLift.lean @@ -0,0 +1,1383 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedHash + +/-! +# Adaptive stopped lift + +The recursive lift stays aligned while the materialized comparison is completable. A completed +local step either supplies the ordinary aligned result or a persistent missing-chain obstruction. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def WitnessObservedFirstStoppedStepRel + (table : OtsSecretIndex → HashOutput) + (observations : List CleanProbeObservation) + (left : DirectWitnessResult (α × SplitHashCache)) + (right : Option (ObservedCleanRunResult (α × SplitHashCache))) : Prop := + right = none ∨ + (∃ leftResult rightResult, + left = .done leftResult ∧ + right = some (observedResolvedResult observations rightResult) ∧ + OrdinaryMaterializedRunEq table leftResult rightResult) ∨ + ∃ rightResult, + right = some (observedResolvedResult observations rightResult) ∧ + OrdinaryMaterializedDoomedRun table rightResult ∧ + MissingChainStartHit table rightResult.context + +theorem WitnessObservedStepRel.to_firstStoppedStep_of_not_private + {table : OtsSecretIndex → HashOutput} + {observations : List CleanProbeObservation} + {leftResult : DirectWitnessResult (α × SplitHashCache)} + {rightResult : Option (ObservedCleanRunResult (α × SplitHashCache))} + (hrelation : WitnessObservedStepRel table observations leftResult rightResult) + (hnotPrivate : ∀ witness, leftResult ≠ .stoppedPrivate witness) + (hvalid : ∀ right, + rightResult = some (observedResolvedResult observations right) → + (directDeferredContext right.context.state).Valid) + (hcard : ∀ right, + rightResult = some (observedResolvedResult observations right) → + right.context.state.pending.card < Fintype.card Digest) : + WitnessObservedFirstStoppedStepRel table observations leftResult rightResult := by + obtain ⟨detailed, hproject, hstable⟩ := hrelation + cases detailed with + | stopped reason => + left + simpa [projectDirectDetailedObserved] using hproject.symm + | done right => + have hright : rightResult = some (observedResolvedResult observations right) := by + simpa [projectDirectDetailedObserved, observedResolvedResult] using hproject.symm + right + cases leftResult with + | stoppedFuel => + right + refine ⟨right, hright, hstable, ?_⟩ + exact missingChainStartHit_of_doomed_direct_valid table right.context.state + (by rw [← hstable.2]; exact hstable.1.2) (hvalid right hright) + (hcard right hright) + + | stoppedOrdinary => + right + refine ⟨right, hright, hstable, ?_⟩ + exact missingChainStartHit_of_doomed_direct_valid table right.context.state + (by rw [← hstable.2]; exact hstable.1.2) (hvalid right hright) + (hcard right hright) + | stoppedPrivate witness => exact (hnotPrivate witness rfl).elim + | done left => + rcases hstable with hclean | hdoomed + · left + exact ⟨left, right, rfl, hright, hclean⟩ + · right + refine ⟨right, hright, hdoomed, ?_⟩ + exact missingChainStartHit_of_doomed_direct_valid table right.context.state + (by rw [← hdoomed.2]; exact hdoomed.1.2) (hvalid right hright) + (hcard right hright) + +set_option maxRecDepth 100000 in +theorem not_stoppedPrivate_mem_runDirectResolvedWitnessFromTable_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (witness : PrivateHitWitness) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hprobeFree : computation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) + (hresult : DirectWitnessResult.stoppedPrivate witness ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) : False := by + have hdetailed : DirectDetailedResult.stopped .privateStructuralHit ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) := by + rw [← map_erase_runDirectResolvedWitnessFromTable computation context fuel table, support_map] + exact ⟨.stoppedPrivate witness, hresult, rfl⟩ + have hcanonicalCompletable := + (valid_completable_canonicalizeMaterializedValues table context hvalid hcompletable).2 + exact canonicalPrivateSafeResult_of_probeFree computation context fuel table hprobeFree + (not_privateStructuralHit_of_deferredCompletable hcompletable) + (not_privateStructuralHit_of_deferredCompletable hcanonicalCompletable) + (.stopped .privateStructuralHit) hdetailed + +set_option maxRecDepth 100000 in +theorem not_stoppedPrivate_mem_afterPlan_of_completable + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (witness : PrivateHitWitness) + (hpositive : 0 < fuel) (hvalid : context.Valid) + (hcompletable : DeferredCompletable table context) + (hnextCompletable : ∀ candidate, + plan.candidate? = some candidate → candidate.coordinate ∉ context.state.revealed → + DeferredCompletable table + ({ context with state := + context.state.addPending candidate.coordinate candidate.candidate } : + DeferredContext)) + (hresult : DirectWitnessResult.stoppedPrivate witness ∈ support + (runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache))) : False := by + rw [runDirectResolvedWitnessFromTable_afterPlan_eq_publicPlan parameter input plan context fuel + table cache] at hresult + unfold probingHashQueryAfterPublicPlan at hresult + cases hcandidate : plan.candidate? with + | none => + rw [hcandidate] at hresult + simp only [executeCandidate?, runDirectResolvedWitnessFromTable, pure_bind] at hresult + exact not_stoppedPrivate_mem_runDirectResolvedWitnessFromTable_of_probeFree + ((probingHashQueryPublicAction parameter input context.state plan.action).run cache) + context fuel table witness hvalid hcompletable + (probingHashQueryPublicAction_probeFree parameter input context.state plan.action cache) + hresult + | some candidate => + rw [hcandidate] at hresult + simp only [executeCandidate?, StateT.run_bind, probe, StateT.run_liftM, + LazyRevealProbe.probeQuery, bind_assoc, pure_bind] at hresult + rw [runDirectResolvedWitnessFromTable_probe_query_bind] at hresult + cases fuel with + | zero => omega + | succ remaining => + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] at hresult + exact not_stoppedPrivate_mem_runDirectResolvedWitnessFromTable_of_probeFree + ((probingHashQueryPublicAction parameter input context.state plan.action).run cache) + context remaining table witness hvalid hcompletable + (probingHashQueryPublicAction_probeFree parameter input context.state plan.action + cache) hresult + + · simp only [hrevealed, ↓reduceIte] at hresult + let nextContext : DeferredContext := + { context with state := + context.state.addPending candidate.coordinate candidate.candidate } + have hnextCompletable' : DeferredCompletable table nextContext := + hnextCompletable candidate hcandidate hrevealed + have hnextValid : nextContext.Valid := + hvalid.addPending_of_completable candidate.coordinate candidate.candidate + hnextCompletable' + exact not_stoppedPrivate_mem_runDirectResolvedWitnessFromTable_of_probeFree + ((probingHashQueryPublicAction parameter input context.state plan.action).run cache) + nextContext remaining table witness hnextValid hnextCompletable' + (probingHashQueryPublicAction_probeFree parameter input context.state plan.action + cache) hresult + +set_option maxRecDepth 100000 in +theorem observations_eq_of_mem_runObservedCleanFromTable_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (result : ObservedCleanRunResult α) + (hprobeFree : computation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table computation)) : + result.observations = observations := by + have hmapped : some result ∈ support + (attachCleanProbeObservations observations <$> + runCleanFromTable state fuel table computation) := by + rw [map_attachCleanProbeObservations_runCleanFromTable_of_probeFree computation observations + state fuel table hprobeFree] + exact hresult + rw [support_map] at hmapped + obtain ⟨clean, _hclean, hattach⟩ := hmapped + cases clean with + | none => simp [attachCleanProbeObservations] at hattach + | some clean => + have heq : result = + (⟨clean.state, clean.remaining, clean.value, clean.table, observations⟩ : + ObservedCleanRunResult α) := by + simpa [attachCleanProbeObservations] using Option.some.inj hattach.symm + exact congrArg ObservedCleanRunResult.observations heq + +theorem not_existingHiddenHit_cleanProbeObservation_of_addPending_completable + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (candidate : Probe) + (hcompletable : DeferredCompletable table + ({ context with state := + context.state.addPending candidate.coordinate candidate.candidate } : + DeferredContext)) : + ¬(cleanProbeObservation context.state candidate.coordinate + candidate.candidate).ExistingHiddenHit := by + rintro ⟨_hhidden, output, hvalue, hcandidate⟩ + obtain ⟨completion, hcompletion⟩ := hcompletable + have hstate : context.state.values candidate.coordinate = some output := by + simpa [cleanProbeObservation] using hvalue + have hpostState : (context.state.addPending candidate.coordinate + candidate.candidate).values candidate.coordinate = some output := by + simpa [LazyRevealProbe.State.addPending] using hstate + have houtput := hcompletion.1 candidate.coordinate output hpostState + have havoids := hcompletion.2.2.1 candidate.coordinate candidate.candidate (by + simp [LazyRevealProbe.State.addPending]) + apply havoids + rw [houtput] + simpa [cleanProbeObservation] using hcandidate + +theorem runObservedCleanFromTable_rootAwarePublic_of_revealed + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (candidate : Probe) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (remaining : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcandidate : rootAwareCandidateForPlan? parameter input plan = some candidate) + (hrevealed : candidate.coordinate ∈ state.revealed) : + runObservedCleanFromTable observations state (remaining + 1) table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) = + runObservedCleanFromTable + (observations ++ [cleanProbeObservation state + candidate.coordinate candidate.candidate]) + state remaining table + ((probingHashQueryPublicAction parameter input publicState plan.action).run cache) := by + unfold probingHashQueryAfterRootAwarePublicPlan + rw [StateT.run_bind] + simp only [executeCandidate?, hcandidate, probe, StateT.run_liftM, + LazyRevealProbe.probeQuery] + simp only [bind_assoc, pure_bind] + rw [runObservedCleanFromTable_probe_query_bind] + simp [hrevealed] + +theorem runObservedCleanFromTable_rootAwarePublic_of_none + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcandidate : rootAwareCandidateForPlan? parameter input plan = none) : + runObservedCleanFromTable observations state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) = + runObservedCleanFromTable observations state fuel table + ((probingHashQueryPublicAction parameter input publicState plan.action).run cache) := by + unfold probingHashQueryAfterRootAwarePublicPlan + rw [StateT.run_bind] + simp [executeCandidate?, hcandidate] + +theorem runDirectResolvedWitnessFromTable_afterPlan_of_none + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcandidate : plan.candidate? = none) : + runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) = + runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryPublicAction parameter input context.state plan.action).run cache) := by + rw [runDirectResolvedWitnessFromTable_afterPlan_eq_publicPlan parameter input plan context fuel + table cache] + unfold probingHashQueryAfterPublicPlan + rw [hcandidate] + simp only [executeCandidate?, pure_bind] + unfold probingHashQueryPublicAction + cases plan.action <;> rfl + +theorem runDirectResolvedWitnessFromTable_afterPlan_of_revealed + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (candidate : Probe) (context : DeferredContext) (remaining : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcandidate : plan.candidate? = some candidate) + (hrevealed : candidate.coordinate ∈ context.state.revealed) : + runDirectResolvedWitnessFromTable context (remaining + 1) table + ((probingHashQueryAfterPlan parameter input plan).run cache) = + runDirectResolvedWitnessFromTable context remaining table + ((probingHashQueryPublicAction parameter input context.state plan.action).run cache) := by + rw [runDirectResolvedWitnessFromTable_afterPlan_eq_publicPlan parameter input plan context + (remaining + 1) table cache] + unfold probingHashQueryAfterPublicPlan + rw [hcandidate] + simp only [executeCandidate?, StateT.run_bind, probe, StateT.run_liftM, + LazyRevealProbe.probeQuery, bind_assoc, pure_bind] + rw [runDirectResolvedWitnessFromTable_probe_query_bind] + simp only [hrevealed, ↓reduceIte] + unfold probingHashQueryPublicAction + cases plan.action <;> rfl + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedWitness_afterPlan_observedMaterialized_firstStopped_of_hidden_completable + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) + (plan : PlannedHashQuery) (candidate : Probe) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (leftFuel remaining : Nat) + (leftCache rightCache : SplitHashCache) + (hcandidate : rootAwareCandidateForPlan? parameter input plan = some candidate) + (hpositive : 0 < leftFuel) (hstrictFuel : leftFuel < remaining + 1) + (hcontext : FinalizationContextLE table left right) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hhidden : candidate.coordinate ∉ right.state.revealed) + (hpostCompletable : DeferredCompletable table + ({ right with state := + right.state.addPending candidate.coordinate candidate.candidate } : DeferredContext)) + (htracked : CleanProbeObservationsTrackedBy observations right.state) + (hcovered : CleanProbeObservationsCoverPending observations right.state) + (hnoEarlier : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hbudget : remaining + + (right.state.addPending candidate.coordinate candidate.candidate).pending.card < + Fintype.card Digest) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache)) + (runObservedCleanFromTable observations right.state (remaining + 1) table + ((probingHashQueryAfterRootAwarePublicPlan parameter input left.state plan).run + rightCache)) + (WitnessObservedFirstStoppedStepRel table + (observations ++ [cleanProbeObservation right.state + candidate.coordinate candidate.candidate])) := by + let nextObservations := observations ++ [cleanProbeObservation right.state + candidate.coordinate candidate.candidate] + let nextRight : DeferredContext := + { right with state := + right.state.addPending candidate.coordinate candidate.candidate } + have hlocal := relTriple_runDirectResolvedWitness_afterPlan_observedMaterialized table parameter + input left.state plan observations left right leftFuel (remaining + 1) leftCache rightCache rfl + hpositive hstrictFuel hcontext hcache hrevealed hvalues hpublished hrightMaterialized + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hlocal + (fun result => result ∈ support + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache))) + (fun result hresult => hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupported + apply relTriple_post_mono hbothSupported + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hstep, hleftSupport⟩, hrightSupport⟩ + have hleftHidden : candidate.coordinate ∉ left.state.revealed := by + rwa [hrevealed] + have hnotPrivate : ∀ witness, leftResult ≠ .stoppedPrivate witness := by + intro witness heq + subst leftResult + apply not_stoppedPrivate_mem_afterPlan_of_completable parameter input plan left leftFuel table + leftCache witness hpositive hcontext.leftValid hcontext.leftCompletable + · intro planned hplanned hplannedHidden + have hsame : planned = candidate := by + unfold rootAwareCandidateForPlan? at hcandidate + rw [hplanned] at hcandidate + exact Option.some.inj hcandidate + subst planned + exact (hcontext.addPending_both_of_right_completable candidate.coordinate + candidate.candidate hpostCompletable).leftCompletable + · exact hleftSupport + have hnextTracked : CleanProbeObservationsTrackedBy nextObservations nextRight.state := by + exact cleanProbeObservationsTrackedBy_append_hidden htracked candidate.coordinate + candidate.candidate hhidden + have hnextCovered : CleanProbeObservationsCoverPending nextObservations nextRight.state := by + exact cleanProbeObservationsCoverPending_append_hidden hcovered candidate.coordinate + candidate.candidate hhidden + have hnewNoHit : ¬(cleanProbeObservation right.state candidate.coordinate + candidate.candidate).ExistingHiddenHit := + not_existingHiddenHit_cleanProbeObservation_of_addPending_completable table right candidate + hpostCompletable + have hnextNoHit : ∀ observation ∈ nextObservations, + ¬observation.ExistingHiddenHit := by + intro observation hobservation + simp only [nextObservations, List.mem_append, List.mem_singleton] at hobservation + rcases hobservation with hold | rfl + · exact hnoEarlier observation hold + · exact hnewNoHit + have hobservations : observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan) = nextObservations := by + simp [observationsAfterCandidate, hcandidate, nextObservations] + rw [hobservations] at hstep + apply hstep.to_firstStoppedStep_of_not_private hnotPrivate + · intro resolved hresolved + have hsupport : some (observedResolvedResult nextObservations resolved) ∈ support + (runObservedCleanFromTable nextObservations nextRight.state remaining table + ((probingHashQueryPublicAction parameter input left.state plan.action).run + rightCache)) := by + have hrightSupport' := hrightSupport + rw [hresolved] at hrightSupport' + rw [runObservedCleanFromTable_rootAwarePublic_of_hidden parameter input left.state plan + candidate observations right.state remaining table rightCache hcandidate hhidden] + at hrightSupport' + simpa [nextObservations, nextRight] using hrightSupport' + have hobservations := observations_eq_of_mem_runObservedCleanFromTable_of_probeFree + ((probingHashQueryPublicAction parameter input left.state plan.action).run rightCache) + nextObservations nextRight.state remaining table + (observedResolvedResult nextObservations resolved) + (probingHashQueryPublicAction_probeFree parameter input left.state plan.action rightCache) + hsupport + have htrackedResult := cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((probingHashQueryPublicAction parameter input left.state plan.action).run rightCache) + nextObservations nextRight.state remaining table hnextTracked + (observedResolvedResult nextObservations resolved) hsupport + have hcoveredResult := cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((probingHashQueryPublicAction parameter input left.state plan.action).run rightCache) + nextObservations nextRight.state remaining table hnextCovered + (observedResolvedResult nextObservations resolved) hsupport + apply directDeferredContext_valid_of_no_existingHiddenHit + (observedResolvedResult nextObservations resolved) htrackedResult hcoveredResult + intro hhit + obtain ⟨observation, hobservation, hobservationHit⟩ := hhit + apply hnextNoHit observation + · simpa [observedResolvedResult, hobservations] using hobservation + · exact hobservationHit + · intro resolved hresolved + have hsupport : some (observedResolvedResult nextObservations resolved) ∈ support + (runObservedCleanFromTable nextObservations nextRight.state remaining table + ((probingHashQueryPublicAction parameter input left.state plan.action).run + rightCache)) := by + have hrightSupport' := hrightSupport + rw [hresolved] at hrightSupport' + rw [runObservedCleanFromTable_rootAwarePublic_of_hidden parameter input left.state plan + candidate observations right.state remaining table rightCache hcandidate hhidden] + at hrightSupport' + simpa [nextObservations, nextRight] using hrightSupport' + have hremaining := remaining_add_pending_card_le_of_mem_runObservedCleanFromTable + ((probingHashQueryPublicAction parameter input left.state plan.action).run rightCache) + nextObservations nextRight.state remaining table + (observedResolvedResult nextObservations resolved) hsupport + simp only [observedResolvedResult] at hremaining + exact (Nat.le_add_left _ _).trans (hremaining.trans_lt hbudget) + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedWitness_observed_firstStopped_of_probeFree + (table : OtsSecretIndex → HashOutput) + (leftComputation rightComputation : + OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (hbase : RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table leftComputation) + (runDirectResolvedDetailedFromTable right rightFuel table rightComputation) + (DirectWitnessMaterializedStableRunEq table)) + (hleftProbeFree : leftComputation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) + (hrightProbeFree : rightComputation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) + (hleftValid : left.Valid) (hleftCompletable : DeferredCompletable table left) + (hrightMaterialized : right = directDeferredContext right.state) + (htracked : CleanProbeObservationsTrackedBy observations right.state) + (hcovered : CleanProbeObservationsCoverPending observations right.state) + (hnoHit : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hbudget : rightFuel + right.state.pending.card < Fintype.card Digest) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table leftComputation) + (runObservedCleanFromTable observations right.state rightFuel table rightComputation) + (WitnessObservedFirstStoppedStepRel table observations) := by + have hlocal := relTriple_runDirectResolvedWitness_observed_of_probeFree table leftComputation + rightComputation observations left right leftFuel rightFuel hbase hrightProbeFree + hrightMaterialized + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hlocal + (fun result => result ∈ support + (runDirectResolvedWitnessFromTable left leftFuel table leftComputation)) + (fun result hresult => hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupported + apply relTriple_post_mono hbothSupported + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hstep, hleftSupport⟩, hrightSupport⟩ + have hnotPrivate : ∀ witness, leftResult ≠ .stoppedPrivate witness := by + intro witness heq + subst leftResult + exact (not_stoppedPrivate_mem_runDirectResolvedWitnessFromTable_of_probeFree leftComputation + left leftFuel table witness hleftValid hleftCompletable hleftProbeFree hleftSupport).elim + apply hstep.to_firstStoppedStep_of_not_private hnotPrivate + · intro resolved hresolved + have hsupport : some (observedResolvedResult observations resolved) ∈ support + (runObservedCleanFromTable observations right.state rightFuel table rightComputation) := by + rwa [hresolved] at hrightSupport + have hobservations := observations_eq_of_mem_runObservedCleanFromTable_of_probeFree + rightComputation observations right.state rightFuel table + (observedResolvedResult observations resolved) hrightProbeFree hsupport + have htrackedResult := cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + rightComputation observations right.state rightFuel table htracked + (observedResolvedResult observations resolved) hsupport + have hcoveredResult := cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + rightComputation observations right.state rightFuel table hcovered + (observedResolvedResult observations resolved) hsupport + apply directDeferredContext_valid_of_no_existingHiddenHit + (observedResolvedResult observations resolved) htrackedResult hcoveredResult + intro hhit + obtain ⟨observation, hobservation, hobservationHit⟩ := hhit + apply hnoHit observation + · simpa [observedResolvedResult, hobservations] using hobservation + · exact hobservationHit + · intro resolved hresolved + have hsupport : some (observedResolvedResult observations resolved) ∈ support + (runObservedCleanFromTable observations right.state rightFuel table rightComputation) := by + rwa [hresolved] at hrightSupport + have hremaining := remaining_add_pending_card_le_of_mem_runObservedCleanFromTable + rightComputation observations right.state rightFuel table + (observedResolvedResult observations resolved) hsupport + simp only [observedResolvedResult] at hremaining + exact (Nat.le_add_left _ _).trans (hremaining.trans_lt hbudget) + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedWitness_afterPlan_observedMaterialized_firstStopped_of_revealed + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) + (plan : PlannedHashQuery) (candidate : Probe) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (leftFuel remaining : Nat) + (leftCache rightCache : SplitHashCache) + (hcandidate : rootAwareCandidateForPlan? parameter input plan = some candidate) + (hpositive : 0 < leftFuel) (hstrictFuel : leftFuel < remaining + 1) + (hcontext : FinalizationContextLE table left right) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hcandidateRevealed : candidate.coordinate ∈ right.state.revealed) + (htracked : CleanProbeObservationsTrackedBy observations right.state) + (hcovered : CleanProbeObservationsCoverPending observations right.state) + (hnoEarlier : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hbudget : remaining + right.state.pending.card < Fintype.card Digest) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache)) + (runObservedCleanFromTable observations right.state (remaining + 1) table + ((probingHashQueryAfterRootAwarePublicPlan parameter input left.state plan).run + rightCache)) + (WitnessObservedFirstStoppedStepRel table + (observations ++ [cleanProbeObservation right.state + candidate.coordinate candidate.candidate])) := by + let nextObservations := observations ++ [cleanProbeObservation right.state + candidate.coordinate candidate.candidate] + have hleftRevealed : candidate.coordinate ∈ left.state.revealed := by + rwa [hrevealed] + have hnextTracked : CleanProbeObservationsTrackedBy nextObservations right.state := by + exact cleanProbeObservationsTrackedBy_append_revealed htracked candidate.coordinate + candidate.candidate hcandidateRevealed + have hnextCovered : CleanProbeObservationsCoverPending nextObservations right.state := by + exact cleanProbeObservationsCoverPending_append_revealed hcovered candidate.coordinate + candidate.candidate + have hnewNoHit : ¬(cleanProbeObservation right.state candidate.coordinate + candidate.candidate).ExistingHiddenHit := by + rintro ⟨hhidden, _output, _hvalue, _hcandidate⟩ + simp [cleanProbeObservation, hcandidateRevealed] at hhidden + have hnextNoHit : ∀ observation ∈ nextObservations, + ¬observation.ExistingHiddenHit := by + intro observation hobservation + simp only [nextObservations, List.mem_append, List.mem_singleton] at hobservation + rcases hobservation with hold | rfl + · exact hnoEarlier observation hold + · exact hnewNoHit + cases hplanCandidate : plan.candidate? with + | none => + have hleftEq := runDirectResolvedWitnessFromTable_afterPlan_of_none parameter input plan + left leftFuel table leftCache hplanCandidate + have hrightEq := runObservedCleanFromTable_rootAwarePublic_of_revealed parameter input + left.state plan candidate observations right.state remaining table rightCache hcandidate + hcandidateRevealed + rw [hleftEq, hrightEq] + have hbase := witnessMaterializedStableCouplesBetween_publicAction table parameter input + left.state plan.action left right leftFuel remaining leftCache rightCache hcontext + (by omega) hcache hrevealed hvalues hpublished hrightMaterialized + exact relTriple_runDirectResolvedWitness_observed_firstStopped_of_probeFree table + ((probingHashQueryPublicAction parameter input left.state plan.action).run leftCache) + ((probingHashQueryPublicAction parameter input left.state plan.action).run rightCache) + nextObservations left right leftFuel remaining hbase + (probingHashQueryPublicAction_probeFree parameter input left.state plan.action leftCache) + (probingHashQueryPublicAction_probeFree parameter input left.state plan.action rightCache) + hcontext.leftValid hcontext.leftCompletable hrightMaterialized hnextTracked hnextCovered + hnextNoHit hbudget + | some planned => + have hsame : planned = candidate := by + unfold rootAwareCandidateForPlan? at hcandidate + rw [hplanCandidate] at hcandidate + exact Option.some.inj hcandidate + subst planned + cases leftFuel with + | zero => omega + | succ leftRemaining => + have hleftEq := runDirectResolvedWitnessFromTable_afterPlan_of_revealed parameter input + plan candidate left leftRemaining table leftCache hplanCandidate hleftRevealed + have hrightEq := runObservedCleanFromTable_rootAwarePublic_of_revealed parameter input + left.state plan candidate observations right.state remaining table rightCache + hcandidate hcandidateRevealed + rw [hleftEq, hrightEq] + have hbase := witnessMaterializedStableCouplesBetween_publicAction table parameter input + left.state plan.action left right leftRemaining remaining leftCache rightCache hcontext + (by omega) hcache hrevealed hvalues hpublished hrightMaterialized + exact relTriple_runDirectResolvedWitness_observed_firstStopped_of_probeFree table + ((probingHashQueryPublicAction parameter input left.state plan.action).run leftCache) + ((probingHashQueryPublicAction parameter input left.state plan.action).run rightCache) + nextObservations left right leftRemaining remaining hbase + (probingHashQueryPublicAction_probeFree parameter input left.state plan.action leftCache) + (probingHashQueryPublicAction_probeFree parameter input left.state plan.action rightCache) + hcontext.leftValid hcontext.leftCompletable hrightMaterialized hnextTracked hnextCovered + hnextNoHit hbudget + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedWitness_afterPlan_observedMaterialized_firstStopped_of_none + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcandidate : rootAwareCandidateForPlan? parameter input plan = none) + (hfuel : leftFuel ≤ rightFuel) + (hcontext : FinalizationContextLE table left right) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (htracked : CleanProbeObservationsTrackedBy observations right.state) + (hcovered : CleanProbeObservationsCoverPending observations right.state) + (hnoHit : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hbudget : rightFuel + right.state.pending.card < Fintype.card Digest) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache)) + (runObservedCleanFromTable observations right.state rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input left.state plan).run + rightCache)) + (WitnessObservedFirstStoppedStepRel table observations) := by + have hplanCandidate : plan.candidate? = none := by + unfold rootAwareCandidateForPlan? at hcandidate + cases hplan : plan.candidate? with + | none => exact rfl + | some candidate => simp [hplan] at hcandidate + have hleftEq := runDirectResolvedWitnessFromTable_afterPlan_of_none parameter input plan left + leftFuel table leftCache hplanCandidate + have hrightEq := runObservedCleanFromTable_rootAwarePublic_of_none parameter input left.state + plan observations right.state rightFuel table rightCache hcandidate + rw [hleftEq, hrightEq] + have hbase := witnessMaterializedStableCouplesBetween_publicAction table parameter input + left.state plan.action left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache + hrevealed hvalues hpublished hrightMaterialized + exact relTriple_runDirectResolvedWitness_observed_firstStopped_of_probeFree table + ((probingHashQueryPublicAction parameter input left.state plan.action).run leftCache) + ((probingHashQueryPublicAction parameter input left.state plan.action).run rightCache) + observations left right leftFuel rightFuel hbase + (probingHashQueryPublicAction_probeFree parameter input left.state plan.action leftCache) + (probingHashQueryPublicAction_probeFree parameter input left.state plan.action rightCache) + hcontext.leftValid hcontext.leftCompletable hrightMaterialized htracked hcovered hnoHit hbudget + +set_option maxRecDepth 100000 in +theorem relTriple_finishWitnessObservedFirstStoppedStep + (parameter : PublicParameter) (rootOf : α → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (next : α → OracleComp (OracleWorld + SigningSpec) β) + (leftObserve : DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (table : OtsSecretIndex → HashOutput) + (leftResult : DirectWitnessResult (α × SplitHashCache)) + (rightResult : Option (ObservedCleanRunResult (α × SplitHashCache))) + (hrelation : WitnessObservedFirstStoppedStepRel table observations leftResult rightResult) + (hrecursive : ∀ left right, + leftResult = .done left → + rightResult = some (observedResolvedResult observations right) → + OrdinaryMaterializedRunEq table left right → + RelTriple + (canonicalizeDirectWitnessSnapshotObserve table leftObserve left.context left.remaining + (left.value.1, left.value.2) snapshots) + (observedMaterializedBoundary parameter (rootOf right.value.1) ftsSecret + (next right.value.1) observations right.context.state right.remaining table + right.value.2) + (SnapshotObservedFirstStoppedRel table)) : + RelTriple + (finishDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table leftObserve) snapshots leftResult) + (match rightResult with + | none => pure none + | some result => + observedMaterializedBoundary parameter (rootOf result.value.1) ftsSecret + (next result.value.1) result.observations result.state result.remaining table + result.value.2) + (SnapshotObservedFirstStoppedRel table) := by + rcases hrelation with hfailed | haligned | hmissing + · subst rightResult + have hbase := relTriple_true + (finishDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table leftObserve) snapshots leftResult) + (pure none : ProbComp (Option (ObservedCleanRunResult (β × SplitHashCache)))) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + apply relTriple_post_mono hsupported + intro source observed hsupport + have : observed = none := by simpa using hsupport.2 + exact Or.inl this + · obtain ⟨left, right, hleft, hright, hclean⟩ := haligned + subst leftResult + subst rightResult + simp only [finishDirectWitnessSnapshotObserve, observedResolvedResult] + exact hrecursive left right rfl rfl hclean + · obtain ⟨right, hright, hdoomed, hmissing⟩ := hmissing + subst rightResult + exact relTriple_any_observedMaterializedBoundary_firstStopped_of_cause parameter + (rootOf right.value.1) ftsSecret (next right.value.1) + (finishDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table leftObserve) snapshots leftResult) + observations right.context.state right.remaining table right.value.2 + (by rw [← hdoomed.2]; exact hdoomed.1.2) (Or.inl (by rwa [← hdoomed.2])) + +set_option maxRecDepth 100000 in +theorem relTriple_bind_finishWitnessObservedFirstStoppedStep + (parameter : PublicParameter) (rootOf : α → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (next : α → OracleComp (OracleWorld + SigningSpec) β) + (leftObserve : DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (table : OtsSecretIndex → HashOutput) + (leftStep : ProbComp (DirectWitnessResult (α × SplitHashCache))) + (rightStep : ProbComp (Option (ObservedCleanRunResult (α × SplitHashCache)))) + (hstep : RelTriple leftStep rightStep + (WitnessObservedFirstStoppedStepRel table observations)) + (hrecursive : ∀ left right, + DirectWitnessResult.done left ∈ support leftStep → + some (observedResolvedResult observations right) ∈ support rightStep → + OrdinaryMaterializedRunEq table left right → + RelTriple + (canonicalizeDirectWitnessSnapshotObserve table leftObserve left.context left.remaining + (left.value.1, left.value.2) snapshots) + (observedMaterializedBoundary parameter (rootOf right.value.1) ftsSecret + (next right.value.1) observations right.context.state right.remaining table + right.value.2) + (SnapshotObservedFirstStoppedRel table)) : + RelTriple + (leftStep >>= finishDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table leftObserve) snapshots) + (rightStep >>= fun result => + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter (rootOf result.value.1) ftsSecret + (next result.value.1) result.observations result.state result.remaining table + result.value.2) + (SnapshotObservedFirstStoppedRel table) := by + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hstep + (fun result => result ∈ support leftStep) (fun result hresult => hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupported + apply relTriple_bind hbothSupported + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + exact relTriple_finishWitnessObservedFirstStoppedStep parameter rootOf ftsSecret next leftObserve + snapshots observations table leftResult rightResult hrelation (by + intro left right hleft hright hclean + subst leftResult + subst rightResult + exact hrecursive left right hleftSupport hrightSupport hclean) + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_directSnapshotBoundary_observedMaterialized_firstStopped + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) RetainedRestResult) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) (q bound : Nat) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) computation).IsQueryBoundP + (fun query => query matches Sum.inr _) bound) + (hcontext : FinalizationContextLE table left right) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hcanonical : CanonicalMaterializedValues table left) + (haligned : SnapshotsObservedAt table snapshots observations) + (hbefore : SnapshotsBefore snapshots left) + (htracked : CleanProbeObservationsTrackedBy observations right.state) + (hcovered : CleanProbeObservationsCoverPending observations right.state) + (hnoHit : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hleftLower : bound ≤ leftFuel) (hleftUpper : leftFuel ≤ q) + (hrightLower : q + bound ≤ rightFuel) + (hbudget : rightFuel + right.state.pending.card < Fintype.card Digest) : + RelTriple + (directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root ftsSecret + computation (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table root) + snapshots left leftFuel table leftCache) + (observedMaterializedBoundary parameter root ftsSecret computation observations right.state + rightFuel table rightCache) + (SnapshotObservedFirstStoppedRel table) := by + induction computation using OracleComp.inductionOn generalizing + snapshots observations left right leftFuel rightFuel leftCache rightCache bound with + | pure value => + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_pure, observedMaterializedBoundary, OracleComp.construct_pure] + have hnotPrivate : ¬PrivateStructuralHit left := + not_privateStructuralHit_of_deferredCompletable hcontext.leftCompletable + simp [retainedResolvedFinalizationPrivateWitnessSnapshotObserve, hnotPrivate] + right + left + exact ⟨_, observations, rfl, List.prefix_rfl, haligned, hnoHit, by simp⟩ + | query_bind query next ih => + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_query_bind, observedMaterializedBoundary, + OracleComp.construct_query_bind] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + simp only + let leftObserve : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput := + fun nextContext remaining value laterSnapshots => + directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root + ftsSecret (next value.1) + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table root) + laterSnapshots nextContext remaining table value.2 + let leftStep : ProbComp + (DirectWitnessResult (Fin (n + 1) × SplitHashCache)) := + runDirectResolvedWitnessFromTable left leftFuel table + ((splitUniformImpl n).run leftCache) + let rightStep : ProbComp + (Option (ObservedCleanRunResult (Fin (n + 1) × SplitHashCache))) := + runObservedCleanFromTable observations right.state rightFuel table + ((splitUniformImpl n).run rightCache) + have hbase := (witnessMaterializedStableCouples_splitUniformImpl table n) + left right leftFuel rightFuel leftCache rightCache hcontext (by omega) hcache + hrevealed hvalues hpublished hrightMaterialized + have hlocal := relTriple_runDirectResolvedWitness_observed_firstStopped_of_probeFree + table ((splitUniformImpl n).run leftCache) ((splitUniformImpl n).run rightCache) + observations left right leftFuel rightFuel hbase + (splitUniformImpl_probeFree n leftCache) (splitUniformImpl_probeFree n rightCache) + hcontext.leftValid hcontext.leftCompletable hrightMaterialized htracked hcovered + hnoHit hbudget + unfold runDirectWitnessSnapshotObserve + change RelTriple + (leftStep >>= finishDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table leftObserve) snapshots) + (rightStep >>= fun result => + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state result.remaining + table result.value.2) + (SnapshotObservedFirstStoppedRel table) + apply relTriple_bind_finishWitnessObservedFirstStoppedStep + (α := Fin (n + 1)) (β := RetainedRestResult) parameter (fun _ => root) + ftsSecret next leftObserve snapshots observations table leftStep rightStep + (by simpa [leftStep, rightStep] using hlocal) + intro nextLeft nextRight hleftSupport hrightSupport hclean + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hleftCompletable : DeferredCompletable table canonical := + hcanonicalRun.context_le.leftCompletable + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hleftFuelPreserved : leftFuel ≤ nextLeft.remaining := by + have := fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table nextLeft 0 + (splitUniformImpl_probeFree n leftCache) + (by exact hleftSupport) + omega + have hrightFuelPreserved : rightFuel ≤ nextRight.remaining := by + have := fuel_le_remaining_add_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run rightCache) observations right.state rightFuel table + (observedResolvedResult observations nextRight) 0 + (splitUniformImpl_probeFree n rightCache) + (by exact hrightSupport) + simpa [observedResolvedResult] using this + have hleftRemainingUpper : nextLeft.remaining ≤ leftFuel := + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table nextLeft (by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩) + have hnextTracked : CleanProbeObservationsTrackedBy observations + nextRight.context.state := by + simpa [rightStep, observedResolvedResult] using + (cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run rightCache) observations right.state rightFuel table + htracked (observedResolvedResult observations nextRight) + hrightSupport) + have hnextCovered : CleanProbeObservationsCoverPending observations + nextRight.context.state := by + simpa [rightStep, observedResolvedResult] using + (cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run rightCache) observations right.state rightFuel table + hcovered (observedResolvedResult observations nextRight) + hrightSupport) + have hnextBudget : nextRight.remaining + nextRight.context.state.pending.card < + Fintype.card Digest := by + have hremaining := remaining_add_pending_card_le_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run rightCache) observations right.state rightFuel table + (observedResolvedResult observations nextRight) + hrightSupport + simpa [observedResolvedResult] using hremaining.trans_lt hbudget + have hnextBefore : SnapshotsBefore snapshots canonical := + (hbefore.of_done_runDirectResolvedWitnessFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table nextLeft + hleftSupport).canonicalize_right table + unfold canonicalizeDirectWitnessSnapshotObserve + classifyDirectWitnessSnapshotObserve + simp only [canonical, hnotPrivate, ↓reduceDIte, hclean.left_published, + ↓reduceIte, hleftCompletable] + rw [← hclean.value_eq] + simpa [leftObserve] using + (ih nextLeft.value.1 snapshots observations canonical nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 bound + (hbound.2 nextLeft.value.1) hcanonicalRun.context_le hcanonicalRun.cache_eq + hcanonicalRun.revealed_eq hcanonicalRun.values_le hcanonicalRun.left_published + hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table nextLeft.context + hclean.context_le.view.leftConsistent) + haligned hnextBefore hnextTracked hnextCovered hnoHit (by omega) (by omega) + (by omega) + hnextBudget) + | inr input => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + simp only + have hrightValues : + (materializedCanonicalContext table right.state).state.values = + left.state.values := by + unfold materializedCanonicalContext + rw [← hrightMaterialized] + exact canonicalized_right_values_eq_of_finalizationContextLE hcontext hrevealed + hcanonical + have hplanEq : + purePlanProbingHashQuery parameter input + (materializedCanonicalContext table right.state).state = + purePlanProbingHashQuery parameter input left.state := + purePlanProbingHashQuery_eq_of_values_eq hrightValues parameter input + rw [hplanEq] + rw [← rootAwareCandidateForPlan?_purePlan parameter input left.state] + let plan := purePlanProbingHashQuery parameter input left.state + have hpublicExecutor : + probingHashQueryAfterRootAwarePublicPlan parameter input + (materializedCanonicalContext table right.state).state plan = + probingHashQueryAfterRootAwarePublicPlan parameter input left.state plan := + probingHashQueryAfterRootAwarePublicPlan_eq_of_values_eq parameter input + hrightValues plan + rw [hpublicExecutor] + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextSnapshots := appendPlannedSnapshot snapshots candidate? left + let leftObserve : DeferredContext → Nat → + ((OracleWorld + SigningSpec).Range (.inl (.inr input)) × SplitHashCache) → + List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput := + fun nextContext remaining value laterSnapshots => + directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root + ftsSecret (next value.1) + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table root) + laterSnapshots nextContext remaining table value.2 + let leftStep : ProbComp (DirectWitnessResult + ((OracleWorld + SigningSpec).Range (.inl (.inr input)) × SplitHashCache)) := + runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache) + let rightStep : ProbComp (Option (ObservedCleanRunResult + ((OracleWorld + SigningSpec).Range (.inl (.inr input)) × SplitHashCache))) := + runObservedCleanFromTable observations right.state rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input left.state plan).run + rightCache) + have hcontextDirect : + FinalizationContextLE table left (directDeferredContext right.state) := by + rwa [← hrightMaterialized] + have houter : IsOuterHash (.inl (.inr input)) := by simp [IsOuterHash] + have hboundPositive : 0 < bound := by + rcases hbound.1 with hnot | hpositive + · exact (hnot (by simp)).elim + · exact hpositive + have hleftPositive : 0 < leftFuel := by omega + have hstrictFuel : leftFuel < rightFuel := by omega + have hcontinue : ∀ nextObservations, + SnapshotsObservedAt table nextSnapshots nextObservations → + (∀ observation ∈ nextObservations, ¬observation.ExistingHiddenHit) → + RelTriple leftStep rightStep + (WitnessObservedFirstStoppedStepRel table nextObservations) → + RelTriple + (leftStep >>= finishDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table leftObserve) nextSnapshots) + (rightStep >>= fun result => + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state + result.remaining table result.value.2) + (SnapshotObservedFirstStoppedRel table) := by + intro nextObservations hnextAligned hnextNoHit hlocal + convert relTriple_bind_finishWitnessObservedFirstStoppedStep + (α := (OracleWorld + SigningSpec).Range (.inl (.inr input))) + (β := RetainedRestResult) parameter (fun _ => root) ftsSecret + next leftObserve nextSnapshots nextObservations table leftStep rightStep hlocal ?_ + using 1 <;> + try (apply bind_congr; intro result; cases result <;> rfl) + intro nextLeft nextRight hleftSupport hrightSupport hclean + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hleftCompletable : DeferredCompletable table canonical := + hcanonicalRun.context_le.leftCompletable + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hleftFuelSpent : leftFuel ≤ nextLeft.remaining + 1 := + fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterPlan parameter input plan).run leftCache) left leftFuel + table nextLeft 1 + (probingHashQueryAfterPlan_isProbeBound_one parameter input plan leftCache) + (by exact hleftSupport) + have hrightFuelSpent : rightFuel ≤ nextRight.remaining + 1 := by + have := fuel_le_remaining_add_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input left.state plan).run + rightCache) observations right.state rightFuel table + (observedResolvedResult nextObservations nextRight) 1 + (probingHashQueryAfterRootAwarePublicPlan_isProbeBound_one parameter input + left.state plan rightCache) (by exact hrightSupport) + simpa [observedResolvedResult] using this + have hleftRemainingUpper : nextLeft.remaining ≤ leftFuel := + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((probingHashQueryAfterPlan parameter input plan).run leftCache) left leftFuel + table nextLeft (by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterPlan parameter input plan).run leftCache) left + leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩) + have hnextTracked : CleanProbeObservationsTrackedBy nextObservations + nextRight.context.state := by + simpa [rightStep, observedResolvedResult] using + (cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input left.state + plan).run rightCache) observations right.state rightFuel table htracked + (observedResolvedResult nextObservations nextRight) + hrightSupport) + have hnextCovered : CleanProbeObservationsCoverPending nextObservations + nextRight.context.state := by + simpa [rightStep, observedResolvedResult] using + (cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input left.state + plan).run rightCache) observations right.state rightFuel table hcovered + (observedResolvedResult nextObservations nextRight) + hrightSupport) + have hnextBudget : nextRight.remaining + nextRight.context.state.pending.card < + Fintype.card Digest := by + have hremaining := remaining_add_pending_card_le_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input left.state plan).run + rightCache) observations right.state rightFuel table + (observedResolvedResult nextObservations nextRight) + hrightSupport + simpa [observedResolvedResult] using hremaining.trans_lt hbudget + have hnextBefore : SnapshotsBefore nextSnapshots canonical := + ((hbefore.appendPlannedSnapshot candidate?).of_done_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterPlan parameter input plan).run leftCache) left leftFuel + table nextLeft hleftSupport).canonicalize_right table + unfold canonicalizeDirectWitnessSnapshotObserve + classifyDirectWitnessSnapshotObserve + simp only [canonical, hnotPrivate, ↓reduceDIte, hclean.left_published, + ↓reduceIte, hleftCompletable] + rw [← hclean.value_eq] + simpa [leftObserve, IsOuterHash] using + (ih nextLeft.value.1 nextSnapshots nextObservations canonical nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 + (bound - 1) (by simpa [IsOuterHash] using hbound.2 nextLeft.value.1) + hcanonicalRun.context_le hcanonicalRun.cache_eq hcanonicalRun.revealed_eq + hcanonicalRun.values_le hcanonicalRun.left_published + hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table nextLeft.context + hclean.context_le.view.leftConsistent) + hnextAligned hnextBefore hnextTracked hnextCovered hnextNoHit (by omega) + (by omega) + (by omega) hnextBudget) + unfold runDirectWitnessSnapshotObserve + cases hcandidate : candidate? with + | none => + have hnextSnapshots : nextSnapshots = snapshots := by + simp [nextSnapshots, candidate?, hcandidate, appendPlannedSnapshot] + have hlocal := + relTriple_runDirectResolvedWitness_afterPlan_observedMaterialized_firstStopped_of_none + table parameter input plan observations left right leftFuel rightFuel + leftCache rightCache hcandidate (by omega) hcontext hcache hrevealed hvalues + hpublished hrightMaterialized htracked hcovered hnoHit hbudget + have hresult := hcontinue observations + (by simpa [hnextSnapshots] using haligned) hnoHit + (by simpa [leftStep, rightStep] using hlocal) + convert hresult using 1 <;> + try (apply bind_congr; intro result; cases result <;> rfl) + | some candidate => + have hnextSnapshots : nextSnapshots = + snapshots ++ [(⟨candidate, left⟩ : PlannedProbeSnapshot)] := by + simp [nextSnapshots, candidate?, hcandidate, appendPlannedSnapshot] + let nextObservations := observations ++ [cleanProbeObservation right.state + candidate.coordinate candidate.candidate] + have hnextAligned : SnapshotsObservedAt table nextSnapshots nextObservations := by + have hnext := haligned.appendCandidate (some candidate) hcontextDirect hrevealed + hpublished hcanonical + rw [hnextSnapshots] + simpa [nextObservations, observationsAfterCandidate, hcandidate, + appendPlannedSnapshot] using hnext + by_cases hcandidateRevealed : candidate.coordinate ∈ right.state.revealed + · have hnewNoHit : ¬(cleanProbeObservation right.state candidate.coordinate + candidate.candidate).ExistingHiddenHit := by + rintro ⟨hhidden, _output, _hvalue, _hcandidate⟩ + simp [cleanProbeObservation, hcandidateRevealed] at hhidden + have hnextNoHit : ∀ observation ∈ nextObservations, + ¬observation.ExistingHiddenHit := by + intro observation hobservation + simp only [nextObservations, List.mem_append, List.mem_singleton] + at hobservation + rcases hobservation with hold | rfl + · exact hnoHit observation hold + · exact hnewNoHit + have hlocal := + relTriple_runDirectResolvedWitness_afterPlan_observedMaterialized_firstStopped_of_revealed + table parameter input plan candidate observations left right leftFuel + (rightFuel - 1) leftCache rightCache hcandidate hleftPositive (by omega) + hcontext hcache hrevealed hvalues hpublished hrightMaterialized + hcandidateRevealed htracked hcovered hnoHit (by omega) + have hrightFuelEq : rightFuel - 1 + 1 = rightFuel := by omega + have hresult := hcontinue nextObservations hnextAligned hnextNoHit + (by simpa [leftStep, rightStep, nextObservations, hrightFuelEq] using hlocal) + convert hresult using 1 <;> + try (apply bind_congr; intro result; cases result <;> rfl) + · let postRight : DeferredContext := + { right with state := + (right.state.addPending candidate.coordinate candidate.candidate) } + by_cases hpostCompletable : DeferredCompletable table postRight + · have hnewNoHit : ¬(cleanProbeObservation right.state candidate.coordinate + candidate.candidate).ExistingHiddenHit := + not_existingHiddenHit_cleanProbeObservation_of_addPending_completable table + right candidate hpostCompletable + have hnextNoHit : ∀ observation ∈ nextObservations, + ¬observation.ExistingHiddenHit := by + intro observation hobservation + simp only [nextObservations, List.mem_append, List.mem_singleton] + at hobservation + rcases hobservation with hold | rfl + · exact hnoHit observation hold + · exact hnewNoHit + have hpostBudget : (rightFuel - 1) + + (right.state.addPending candidate.coordinate + candidate.candidate).pending.card < Fintype.card Digest := by + have hcard := LazyRevealProbe.State.pending_card_addPending_le + right.state candidate.coordinate candidate.candidate + omega + have hlocal := + relTriple_runDirectResolvedWitness_afterPlan_observedMaterialized_firstStopped_of_hidden_completable + table parameter input plan candidate observations left right leftFuel + (rightFuel - 1) leftCache rightCache hcandidate hleftPositive (by omega) + hcontext hcache hrevealed hvalues hpublished hrightMaterialized + hcandidateRevealed hpostCompletable htracked hcovered hnoHit hpostBudget + have hrightFuelEq : rightFuel - 1 + 1 = rightFuel := by omega + have hresult := hcontinue nextObservations hnextAligned hnextNoHit + (by simpa [leftStep, rightStep, nextObservations, hrightFuelEq] using hlocal) + convert hresult using 1 <;> + try (apply bind_congr; intro result; cases result <;> rfl) + · have hpostCard : + (right.state.addPending candidate.coordinate + candidate.candidate).pending.card < Fintype.card Digest := by + have hcard := LazyRevealProbe.State.pending_card_addPending_le + right.state candidate.coordinate candidate.candidate + omega + have hsource : ∀ output ∈ support + (leftStep >>= finishDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table leftObserve) + nextSnapshots), + PrivateWitnessSnapshotExtends + (snapshots ++ [(⟨candidate, left⟩ : PlannedProbeSnapshot)]) output := by + intro output houtput + change output ∈ support + (runDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table leftObserve) + nextSnapshots left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache)) + at houtput + have hextends := + privateWitnessSnapshotExtends_of_mem_runDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table leftObserve) + nextSnapshots left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache) + (by + intro result _hresult nextOutput hnextOutput + apply privateWitnessSnapshotExtends_of_mem_canonicalizeDirectWitnessSnapshotObserve + table leftObserve result.context result.remaining result.value + nextSnapshots (output := nextOutput) (houtput := hnextOutput) + intro finalOutput hfinalOutput + change finalOutput ∈ support + (directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve + parameter root ftsSecret (next result.value.1) + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table + root) nextSnapshots + (canonicalizeMaterializedValues table result.context) + result.remaining table result.value.2) at hfinalOutput + exact privateWitnessSnapshotExtends_of_mem_directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve + parameter root ftsSecret (next result.value.1) + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table + root) nextSnapshots + (canonicalizeMaterializedValues table result.context) + result.remaining table result.value.2 (by + intro finalContext finalRemaining finalValue finalSnapshots + retainedOutput hretained + exact privateWitnessSnapshotExtends_of_mem_retainedResolvedFinalizationPrivateWitnessSnapshotObserve + table root finalContext finalRemaining finalValue finalSnapshots + retainedOutput hretained) + finalOutput hfinalOutput) + output houtput + simpa [hnextSnapshots] using hextends + have hstopped := + relTriple_source_observedMaterializedHashContinuation_firstStopped_of_notCompletable + parameter root ftsSecret input plan candidate next + (leftStep >>= finishDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table leftObserve) + nextSnapshots) + snapshots observations left right (rightFuel - 1) table rightCache + hcandidate hcontext hrevealed hcanonical hrightMaterialized + hcandidateRevealed hnoHit haligned hbefore htracked hsource hpostCard (by + simpa [postRight] using hpostCompletable) + have hrightFuelEq : rightFuel - 1 + 1 = rightFuel := by omega + have hresult : RelTriple + (leftStep >>= finishDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table leftObserve) + nextSnapshots) + (rightStep >>= fun result => + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state + result.remaining table result.value.2) + (SnapshotObservedFirstStoppedRel table) := by + convert hstopped using 1 + all_goals try simp [rightStep, observedMaterializedHashContinuation, + hpublicExecutor, hrightFuelEq] + all_goals try (apply bind_congr; intro result; cases result <;> rfl) + convert hresult using 1 <;> + try (apply bind_congr; intro result; cases result <;> rfl) + | inr message => + rw [simulateQ_expandedAdversaryImpl_query_bind_inr] at hbound + simp only + let leftObserve : DeferredContext → Nat → + (Option Signature × SplitHashCache) → + List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput := + fun nextContext remaining value laterSnapshots => + directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root + ftsSecret (next value.1) + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table root) + laterSnapshots nextContext remaining table value.2 + let leftStep : ProbComp (DirectWitnessResult + (Option Signature × SplitHashCache)) := + runDirectResolvedWitnessFromTable left leftFuel table + ((maskedSign parameter root ftsSecret message).run leftCache) + let rightStep : ProbComp (Option (ObservedCleanRunResult + (Option Signature × SplitHashCache))) := + runObservedCleanFromTable observations right.state rightFuel table + ((maskedSign parameter root ftsSecret message).run rightCache) + have hbase := (witnessMaterializedStableCouples_maskedSign table parameter root + ftsSecret message) left right leftFuel rightFuel leftCache rightCache hcontext + (by omega) hcache hrevealed hvalues hpublished hrightMaterialized + have hlocal := relTriple_runDirectResolvedWitness_observed_firstStopped_of_probeFree + table ((maskedSign parameter root ftsSecret message).run leftCache) + ((maskedSign parameter root ftsSecret message).run rightCache) observations left right + leftFuel rightFuel hbase + (maskedSign_probeFree parameter root ftsSecret message leftCache) + (maskedSign_probeFree parameter root ftsSecret message rightCache) hcontext.leftValid + hcontext.leftCompletable hrightMaterialized htracked hcovered hnoHit hbudget + unfold runDirectWitnessSnapshotObserve + convert relTriple_bind_finishWitnessObservedFirstStoppedStep + (α := Option Signature) + (β := RetainedRestResult) parameter (fun _ => root) + ftsSecret next leftObserve snapshots observations table leftStep rightStep + (by simpa [leftStep, rightStep] using hlocal) ?_ using 1 <;> + try (apply bind_congr; intro result; cases result <;> rfl) + intro nextLeft nextRight hleftSupport hrightSupport hclean + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hleftCompletable : DeferredCompletable table canonical := + hcanonicalRun.context_le.leftCompletable + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hleftFuelPreserved : leftFuel ≤ nextLeft.remaining := by + have := fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) left leftFuel table + nextLeft 0 (maskedSign_probeFree parameter root ftsSecret message leftCache) + (by exact hleftSupport) + omega + have hrightFuelPreserved : rightFuel ≤ nextRight.remaining := by + have := fuel_le_remaining_add_of_mem_runObservedCleanFromTable + ((maskedSign parameter root ftsSecret message).run rightCache) observations + right.state rightFuel table (observedResolvedResult observations nextRight) 0 + (maskedSign_probeFree parameter root ftsSecret message rightCache) + (by exact hrightSupport) + simpa [observedResolvedResult] using this + have hleftRemainingUpper : nextLeft.remaining ≤ leftFuel := + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) left leftFuel table + nextLeft (by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) left leftFuel + table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩) + have hnextTracked : CleanProbeObservationsTrackedBy observations + nextRight.context.state := by + simpa [rightStep, observedResolvedResult] using + (cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((maskedSign parameter root ftsSecret message).run rightCache) observations + right.state rightFuel table htracked + (observedResolvedResult observations nextRight) + hrightSupport) + have hnextCovered : CleanProbeObservationsCoverPending observations + nextRight.context.state := by + simpa [rightStep, observedResolvedResult] using + (cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((maskedSign parameter root ftsSecret message).run rightCache) observations + right.state rightFuel table hcovered + (observedResolvedResult observations nextRight) + hrightSupport) + have hnextBudget : nextRight.remaining + nextRight.context.state.pending.card < + Fintype.card Digest := by + have hremaining := remaining_add_pending_card_le_of_mem_runObservedCleanFromTable + ((maskedSign parameter root ftsSecret message).run rightCache) observations + right.state rightFuel table (observedResolvedResult observations nextRight) + hrightSupport + simpa [observedResolvedResult] using hremaining.trans_lt hbudget + have hnextBefore : SnapshotsBefore snapshots canonical := + (hbefore.of_done_runDirectResolvedWitnessFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) left leftFuel table + nextLeft hleftSupport).canonicalize_right table + unfold canonicalizeDirectWitnessSnapshotObserve classifyDirectWitnessSnapshotObserve + simp only [canonical, hnotPrivate, ↓reduceDIte, hclean.left_published, + ↓reduceIte, hleftCompletable] + rw [← hclean.value_eq] + have hdetailed : DirectDetailedResult.done nextLeft ∈ support + (runDirectResolvedDetailedFromTable left leftFuel table + ((maskedSign parameter root ftsSecret message).run leftCache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩ + have hdirect : some nextLeft ∈ support + (runDirectResolvedFromTable left leftFuel table + ((maskedSign parameter root ftsSecret message).run leftCache)) := + mem_support_runDirectResolvedFromTable_of_done_detailed + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table nextLeft hdetailed + have hraw := raw_done_of_mem_runDirectResolvedFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table nextLeft hdirect + have houtput : nextLeft.value.1 ∈ support + (scheme.sign + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey) message) := by + exact maskedSign_done_output_mem_support parameter root table ftsSecret + message left.state nextLeft.context.state leftCache nextLeft.value.2 + leftFuel nextLeft.remaining nextLeft.value.1 + hclean.context_le.view.leftStarts (by + simpa only [SigningSpec, maskedExpandedAdversaryImpl, + maskedSigningImpl] using hraw) + have htailBound := isQueryBoundP_of_bind hbound nextLeft.value.1 houtput + simpa [leftObserve, IsOuterHash] using + (ih nextLeft.value.1 snapshots observations canonical nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 bound + (htailBound.mono (by omega)) + hcanonicalRun.context_le hcanonicalRun.cache_eq hcanonicalRun.revealed_eq + hcanonicalRun.values_le hcanonicalRun.left_published + hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table nextLeft.context + hclean.context_le.view.leftConsistent) + haligned hnextBefore hnextTracked hnextCovered hnoHit (by omega) (by omega) + (by omega) + hnextBudget) diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedNonRoot.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedNonRoot.lean new file mode 100644 index 00000000..f64ff42a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedNonRoot.lean @@ -0,0 +1,496 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSelectorCoupling + +/-! +# Non-root stopped ordinal projection + +A selected stopped snapshot at a non-root position makes the existing non-root candidate observer +fire. This module connects the exact ordinal selector to that observer before lifting its one-unit +bound through public-root construction and table sampling. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +set_option linter.constructorNameAsVariable false + +noncomputable def privateOrdinalSelectionNonRootFire : + Option PrivateOrdinalSelection → ProbComp Bool + | none => pure false + | some selection => + nonRootHiddenPrivateCandidateFire selection.candidate selection.context + +theorem privateOrdinalSelectionNonRootFire_eq_true_of_goodForActualRoot + (selection : PrivateOrdinalSelection) (target : Position) (output : HashOutput) + (ordinal : Nat) + (hgood : selection.GoodForActualRoot target output ordinal) + (hnonRoot : ¬IsLayerRoot target) : + privateOrdinalSelectionNonRootFire (some selection) = pure true := by + unfold privateOrdinalSelectionNonRootFire nonRootHiddenPrivateCandidateFire + have hcoordinate : selection.candidate.coordinate = .position target := by + rw [hgood.1] + have hcandidateRoot : ¬selection.candidate.IsLayerRoot := by + simpa [Probe.IsLayerRoot, hcoordinate] using hnonRoot + change (if selection.candidate.IsLayerRoot then pure false + else hiddenPrivateCandidateFire selection.candidate selection.context) = pure true + rw [if_neg hcandidateRoot] + rw [hiddenPrivateCandidateFire_of_not_revealed selection.candidate selection.context (by + simpa [hcoordinate] using hgood.2.2.1)] + unfold privateCandidateFire deferredPositionOutput DeferredContext.positionValue + rw [hgood.1] + simp [hgood.2.1, hgood.2.2.2.1] + +theorem finishDirectPrivateOrdinalSelection_bind_nonRootFire + (selectionObserve : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (riskObserve : DeferredContext → Nat → α → List Probe → ProbComp Bool) + (candidates : List Probe) (result : DirectWitnessResult α) + (hobserve : ∀ context fuel value laterCandidates, + selectionObserve context fuel value laterCandidates >>= + privateOrdinalSelectionNonRootFire = + riskObserve context fuel value laterCandidates) : + finishDirectPrivateOrdinalSelection selectionObserve candidates result >>= + privateOrdinalSelectionNonRootFire = + finishDirectWitnessOrdinalRisk riskObserve candidates result := by + cases result with + | stoppedFuel => simp [finishDirectPrivateOrdinalSelection, + finishDirectWitnessOrdinalRisk, privateOrdinalSelectionNonRootFire] + | stoppedOrdinary => simp [finishDirectPrivateOrdinalSelection, + finishDirectWitnessOrdinalRisk, privateOrdinalSelectionNonRootFire] + | stoppedPrivate witness => simp [finishDirectPrivateOrdinalSelection, + finishDirectWitnessOrdinalRisk, privateOrdinalSelectionNonRootFire] + | done result => + simpa [finishDirectPrivateOrdinalSelection, finishDirectWitnessOrdinalRisk] using + hobserve result.context result.remaining result.value candidates + +theorem canonicalizeDirectPrivateOrdinalSelection_bind_nonRootFire + (table : OtsSecretIndex → HashOutput) + (selectionObserve : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (riskObserve : DeferredContext → Nat → α → List Probe → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hobserve : ∀ nextContext remaining nextValue laterCandidates, + selectionObserve nextContext remaining nextValue laterCandidates >>= + privateOrdinalSelectionNonRootFire = + riskObserve nextContext remaining nextValue laterCandidates) : + canonicalizeDirectPrivateOrdinalSelection table selectionObserve context fuel value + candidates >>= + privateOrdinalSelectionNonRootFire = + canonicalizeDirectWitnessOrdinalRisk table riskObserve context fuel value candidates := by + classical + unfold canonicalizeDirectPrivateOrdinalSelection canonicalizeDirectWitnessOrdinalRisk + let canonical := canonicalizeMaterializedValues table context + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit, privateOrdinalSelectionNonRootFire] + · simp only [canonical, hhit, ↓reduceIte] + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table canonical + · simpa [canonical, hcompletable] using hobserve canonical fuel value candidates + · simp [canonical, hcompletable, privateOrdinalSelectionNonRootFire] + · simp [hpublished, privateOrdinalSelectionNonRootFire] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem directDetailedBoundaryPrivateOrdinalNonRootRisk_eq_selection_bind_fire + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret computation + candidates context fuel table cache >>= + privateOrdinalSelectionNonRootFire = + directDetailedBoundaryPrivateOrdinalNonRootRisk ordinal parameter root ftsSecret computation + candidates context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing + candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryPrivateOrdinalSelection, OracleComp.construct_pure, + directDetailedBoundaryPrivateOrdinalNonRootRisk, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp [selectedPrivateOrdinal?, hselected, privateOrdinalSelectionNonRootFire] + · simp [selectedPrivateOrdinal?, hselected, privateOrdinalSelectionNonRootFire] + | query_bind query next ih => + rw [directDetailedBoundaryPrivateOrdinalSelection, OracleComp.construct_query_bind, + directDetailedBoundaryPrivateOrdinalNonRootRisk, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp [hselected, privateOrdinalSelectionNonRootFire] + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [bind_assoc] + apply bind_congr + intro result + apply finishDirectPrivateOrdinalSelection_bind_nonRootFire + intro nextContext remaining value laterCandidates + apply canonicalizeDirectPrivateOrdinalSelection_bind_nonRootFire + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + | inr input => + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [nextCandidates] using hnextSelected + simp [hactual, privateOrdinalSelectionNonRootFire] + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + rw [bind_assoc] + apply bind_congr + intro result + apply finishDirectPrivateOrdinalSelection_bind_nonRootFire + intro nextContext remaining value laterCandidates + apply canonicalizeDirectPrivateOrdinalSelection_bind_nonRootFire + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + | inr message => + rw [bind_assoc] + apply bind_congr + intro result + apply finishDirectPrivateOrdinalSelection_bind_nonRootFire + intro nextContext remaining value laterCandidates + apply canonicalizeDirectPrivateOrdinalSelection_bind_nonRootFire + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + +noncomputable def granularAllCanonicalPrivateOrdinalSelection + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp (Option PrivateOrdinalSelection) := + runDirectResolvedWitnessFromTable emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) >>= + finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (fun context remaining value candidates => + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + candidates context remaining table value.2)) [] + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxRecDepth 100000 in +theorem privateOrdinalSelectionPendingCovered_of_mem_granularAllCanonical + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (output : Option PrivateOrdinalSelection) + (houtput : output ∈ support + (granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret + fuel)) : + PrivateOrdinalSelectionPendingCovered ordinal output := by + unfold granularAllCanonicalPrivateOrdinalSelection at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + apply privateOrdinalSelectionPendingCovered_of_mem_finish ordinal _ [] result + (output := output) (houtput := hfinish) + intro resolved nextOutput heq hnextOutput + subst result + have hdetailed : DirectDetailedResult.done resolved ∈ support + (runDirectResolvedDetailedFromTable emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) emptyWitnessDeferredContext fuel table, + support_map] + exact ⟨DirectWitnessResult.done resolved, hresult, rfl⟩ + have hprobeBound : (maskedPublishedTreeRoot.run emptySplitHashCache).IsQueryBoundP + (IsUncoveredProbe []) 0 := + OracleComp.IsQueryBoundP.of_imp (isUncoveredProbe_imp_isProbe []) + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) + have hnextCovered := pendingCoveredBy_of_done_runDirectResolvedDetailedFromTable [] + (maskedPublishedTreeRoot.run emptySplitHashCache) emptyWitnessDeferredContext fuel table + resolved pendingCoveredBy_empty hprobeBound hdetailed + apply privateOrdinalSelectionPendingCovered_of_mem_canonicalize ordinal table _ + resolved.context resolved.remaining resolved.value [] _ hnextCovered nextOutput hnextOutput + intro nextContext finalOutput hfinalCovered hfinalOutput + exact privateOrdinalSelectionPendingCovered_of_mem_direct ordinal parameter resolved.value.1 + ftsSecret (retainedGameRestComputation adversary ⟨resolved.value.1, parameter⟩) [] + nextContext resolved.remaining table resolved.value.2 hfinalCovered (by simp) finalOutput + hfinalOutput + +noncomputable def granularAllCanonicalPrivateOrdinalNonRootRisk + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : ProbComp Bool := + runDirectResolvedWitnessFromTable emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) >>= + finishDirectWitnessOrdinalRisk + (canonicalizeDirectWitnessOrdinalRisk table + (fun context remaining value candidates => + directDetailedBoundaryPrivateOrdinalNonRootRisk ordinal parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + candidates context remaining table value.2)) [] + +theorem granularAllCanonicalPrivateOrdinalSelection_bind_nonRootFire + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret fuel >>= + privateOrdinalSelectionNonRootFire = + granularAllCanonicalPrivateOrdinalNonRootRisk ordinal adversary parameter table ftsSecret + fuel := by + unfold granularAllCanonicalPrivateOrdinalSelection + granularAllCanonicalPrivateOrdinalNonRootRisk + rw [bind_assoc] + apply bind_congr + intro result + apply finishDirectPrivateOrdinalSelection_bind_nonRootFire + intro context remaining value candidates + apply canonicalizeDirectPrivateOrdinalSelection_bind_nonRootFire + intro nextContext nextRemaining nextValue nextCandidates + exact directDetailedBoundaryPrivateOrdinalNonRootRisk_eq_selection_bind_fire ordinal parameter + nextValue.1 ftsSecret (retainedGameRestComputation adversary ⟨nextValue.1, parameter⟩) + nextCandidates nextContext nextRemaining table nextValue.2 + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxRecDepth 100000 in +theorem candidatePositionsFreshExceptLayerRoots_of_done_maskedPublishedTreeRoot + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : ResolvedRunResult (Digest × SplitHashCache)) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache))) : + CandidatePositionsFreshExceptLayerRoots + (canonicalizeMaterializedValues table result.context) := by + let computation := maskedPublishedTreeRoot.run emptySplitHashCache + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable emptyWitnessDeferredContext fuel table computation) := by + rw [← map_erase_runDirectResolvedWitnessFromTable computation emptyWitnessDeferredContext fuel + table, support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed computation + emptyWitnessDeferredContext fuel table result hdetailed + have hraw := raw_done_of_mem_runDirectResolvedFromTable computation + emptyWitnessDeferredContext fuel table result hdirect + intro position parent hparent hhidden + by_cases hroot : IsLayerRoot position + · exact Or.inr hroot + · left + have hne : position ≠ layerRootPosition topLayer rootTree := by + intro heq + exact hroot ⟨topLayer, rootTree, heq⟩ + have hpreserves := preservesCoordinate_maskedPublishedTreeRoot_of_ne position hne + have hsame := hpreserves + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) emptySplitHashCache fuel + result.context.state result.remaining result.value.1 result.value.2 hraw + have hstate : result.context.state.values (.position position) = none := by + rw [hsame.1] + rfl + have hprivate : result.context.values position = none := + auxiliaryPositionValue_none_of_done_runDirectResolvedWitnessFromTable position computation + emptyWitnessDeferredContext fuel table result (by rfl) (by + simp [emptyWitnessDeferredContext, emptyDeferredStructuralValues]) hresult hstate + have hfinalHidden : Coordinate.position position ∉ result.context.state.revealed := by + simpa [canonicalizeMaterializedValues_revealed] using hhidden + constructor + · unfold canonicalizeMaterializedValues publicMaterializedValues + simp [hfinalHidden] + · exact hprivate + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_granularAllCanonicalPrivateOrdinalNonRootRisk_le + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun hit : Bool => hit = true | + granularAllCanonicalPrivateOrdinalNonRootRisk ordinal adversary parameter table ftsSecret + fuel] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + unfold granularAllCanonicalPrivateOrdinalNonRootRisk + apply probEvent_bind_le_of_forall_le + intro result hresult + apply probEvent_finishDirectWitnessOrdinalRisk_le table _ [] result _ + intro resolved heq hpublished _hcompletable + subst result + exact probEvent_directDetailedBoundaryPrivateOrdinalNonRootRisk_le ordinal parameter + resolved.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨resolved.value.1, parameter⟩) [] + (canonicalizeMaterializedValues table resolved.context) resolved.remaining table + resolved.value.2 candidatesHaveStructuralParent_nil + (candidatePositionsFreshExceptLayerRoots_of_done_maskedPublishedTreeRoot fuel table resolved + hresult) + hpublished.to_canonicalizedMaterializedValues + +theorem relTriple_granularAllCanonicalSnapshot_privateOrdinalSelection + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + RelTriple + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel) + (granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret + fuel) + (SnapshotOrdinalSelectionRel ordinal) := by + unfold granularAllCanonicalPrivateWitnessSnapshot + granularAllCanonicalPrivateOrdinalSelection + apply relTriple_runSnapshot_privateOrdinalSelection table ordinal _ _ [] + emptyWitnessDeferredContext fuel (maskedPublishedTreeRoot.run emptySplitHashCache) (by simp) + intro result _hresult + exact relTriple_granularRetainedSnapshot_privateOrdinalSelection ordinal adversary parameter + table ftsSecret (canonicalizeMaterializedValues table result.context) result.remaining + result.value [] (by simp) + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_granularAllCanonicalSnapshot_privateOrdinalSelection_supported + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + RelTriple + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel) + (granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret + fuel) + (fun source selection => + SnapshotOrdinalSelectionRel ordinal source selection ∧ + selection ∈ support + (granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table + ftsSecret fuel)) := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support + (relTriple_granularAllCanonicalSnapshot_privateOrdinalSelection ordinal adversary parameter + table ftsSecret fuel) + +attribute [local irreducible] granularAllCanonicalPrivateOrdinalSelection in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_granularAllCanonicalSnapshot_privateOrdinalSelection_pendingCovered + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + RelTriple + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel) + (granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret + fuel) + (fun source selection => + SnapshotOrdinalSelectionRel ordinal source selection ∧ + PrivateOrdinalSelectionPendingCovered ordinal selection) := by + apply relTriple_post_mono + (relTriple_granularAllCanonicalSnapshot_privateOrdinalSelection_supported ordinal adversary + parameter table ftsSecret fuel) + intro source selection hrelation + exact ⟨hrelation.1, + privateOrdinalSelectionPendingCovered_of_mem_granularAllCanonical ordinal adversary parameter + table ftsSecret fuel selection hrelation.2⟩ + +def SelectedPrivateSnapshotNonRootHitAt + (source : PrivateWitnessSnapshotOutput) (ordinal : Nat) : Prop := + ∃ selected : Fin source.2.length, ∃ target output, + selected.val = ordinal ∧ + selectedPrivateSnapshotOrdinal? ordinal source.2 = + some (privateOrdinalSelectionOfSnapshot selected) ∧ + (privateOrdinalSelectionOfSnapshot selected).GoodForActualRoot target output ordinal ∧ + ¬IsLayerRoot target + +theorem selectedPrivateSnapshotHitAt_root_or_nonRoot' + {source : PrivateWitnessSnapshotOutput} {ordinal : Nat} + (hhit : SelectedPrivateSnapshotHitAt source ordinal) : + (∃ selected : Fin source.2.length, ∃ target output, + selected.val = ordinal ∧ + selectedPrivateSnapshotOrdinal? ordinal source.2 = + some (privateOrdinalSelectionOfSnapshot selected) ∧ + (privateOrdinalSelectionOfSnapshot selected).GoodForActualRoot target output ordinal ∧ + IsLayerRoot target) ∨ + SelectedPrivateSnapshotNonRootHitAt source ordinal := by + exact selectedPrivateSnapshotHitAt_root_or_nonRoot hhit + +theorem relTriple_granularAllCanonicalSnapshot_nonRootFire + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + RelTriple + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel) + (granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret + fuel >>= + privateOrdinalSelectionNonRootFire) + (fun source hit => SelectedPrivateSnapshotNonRootHitAt source ordinal → hit = true) := by + have hbind : RelTriple + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel >>= + fun source => pure source) + (granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret + fuel >>= + privateOrdinalSelectionNonRootFire) + (fun source hit => SelectedPrivateSnapshotNonRootHitAt source ordinal → hit = true) := by + apply relTriple_bind + (relTriple_granularAllCanonicalSnapshot_privateOrdinalSelection ordinal adversary parameter + table ftsSecret fuel) + intro source selection hselection + by_cases hnonRoot : SelectedPrivateSnapshotNonRootHitAt source ordinal + · obtain ⟨selected, target, output, _hordinal, hselected, hgood, hroot⟩ := hnonRoot + have hselectionEq : selection = some (privateOrdinalSelectionOfSnapshot selected) := by + exact hselection.symm.trans hselected + rw [hselectionEq] + rw [privateOrdinalSelectionNonRootFire_eq_true_of_goodForActualRoot + (privateOrdinalSelectionOfSnapshot selected) target output ordinal hgood hroot] + exact relTriple_pure_pure (fun _ => rfl) + · have hbase := relTriple_true + (pure source : ProbComp PrivateWitnessSnapshotOutput) + (privateOrdinalSelectionNonRootFire selection) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun output => output = source) (by + intro left hleft + simpa using hleft) + exact relTriple_post_mono hleft (fun left _ hrelation h => by + rw [hrelation.2] at h + exact False.elim (hnonRoot h)) + simpa using hbind + +theorem probEvent_granularAllCanonical_nonRoot_le_selectionFire + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun source => SelectedPrivateSnapshotNonRootHitAt source ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel] ≤ + Pr[fun hit : Bool => hit = true | + granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret + fuel >>= + privateOrdinalSelectionNonRootFire] := by + apply probEvent_le_of_relTriple + (relTriple_granularAllCanonicalSnapshot_nonRootFire ordinal adversary parameter table ftsSecret + fuel) + intro source hit hrelation hsource + exact hrelation hsource + +theorem probEvent_granularAllCanonical_selectedNonRoot_le + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun source => SelectedPrivateSnapshotNonRootHitAt source ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ ≤ Pr[fun hit : Bool => hit = true | + granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret + fuel >>= + privateOrdinalSelectionNonRootFire] := + probEvent_granularAllCanonical_nonRoot_le_selectionFire ordinal adversary parameter table + ftsSecret fuel + _ = Pr[fun hit : Bool => hit = true | + granularAllCanonicalPrivateOrdinalNonRootRisk ordinal adversary parameter table ftsSecret + fuel] := by + rw [granularAllCanonicalPrivateOrdinalSelection_bind_nonRootFire] + _ ≤ _ := probEvent_granularAllCanonicalPrivateOrdinalNonRootRisk_le ordinal adversary + parameter table ftsSecret fuel + +theorem probEvent_sampledGranularAllCanonical_selectedNonRoot_le + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun source => SelectedPrivateSnapshotNonRootHitAt source ordinal | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret fuel] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot + apply probEvent_bind_le_of_forall_le + intro table _htable + exact probEvent_granularAllCanonical_selectedNonRoot_le ordinal adversary parameter table + ftsSecret fuel + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedProbability.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedProbability.lean new file mode 100644 index 00000000..a5c17d8b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedProbability.lean @@ -0,0 +1,359 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSelection + +/-! +# Probability interface for stopped structural ordinals + +Only source ordinals below the outer hash-query bound can occur. This removes the comparison +interpreter's extra fuel from the union and packages the remaining quantitative obligation as one +fixed-ordinal selected-snapshot estimate. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot +set_option maxRecDepth 1000000 +set_option linter.constructorNameAsVariable false + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem snapshots_length_le_of_mem_granularAllCanonical + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q)) : + output.2.length ≤ q := by + classical + unfold granularAllCanonicalPrivateWitnessSnapshot runDirectWitnessSnapshotObserve at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + cases result with + | stoppedFuel => + simp [finishDirectWitnessSnapshotObserve] at hfinish + subst output + simp + | stoppedOrdinary => + simp [finishDirectWitnessSnapshotObserve] at hfinish + subst output + simp + | stoppedPrivate witness => + simp [finishDirectWitnessSnapshotObserve] at hfinish + subst output + simp + | done resolved => + have hcore := resolvedCore_of_done_mem_runDirectResolvedWitnessFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) emptyWitnessDeferredContext q table + resolved DeferredContext.valid_empty.valuesConsistent (startTableAgrees_empty table) + hresult + simp only [finishDirectWitnessSnapshotObserve] at hfinish + unfold canonicalizeDirectWitnessSnapshotObserve at hfinish + let canonical := canonicalizeMaterializedValues table resolved.context + change output ∈ support + (if hhit : PrivateStructuralHit canonical then + pure (some (privateHitWitnessOf canonical hhit), []) + else if PublishedValues resolved.context.state then + classifyDirectWitnessSnapshotObserve table + (granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary + parameter table ftsSecret) + canonical resolved.remaining resolved.value [] + else pure (none, [])) at hfinish + by_cases hhit : PrivateStructuralHit canonical + · simp [hhit] at hfinish + subst output + simp + · simp only [hhit, ↓reduceDIte] at hfinish + by_cases hpublished : PublishedValues resolved.context.state + · simp only [hpublished, ↓reduceIte] at hfinish + unfold classifyDirectWitnessSnapshotObserve at hfinish + simp only [hhit, ↓reduceDIte] at hfinish + by_cases hcompletable : DeferredCompletable table canonical + · simp only [hcompletable, ↓reduceIte] at hfinish + have herased : erasePrivateWitnessSnapshotOutput output ∈ support + (granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary + parameter table ftsSecret canonical resolved.remaining resolved.value []) := by + have hmap := + map_erase_granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve + adversary parameter table ftsSecret canonical resolved.remaining resolved.value + [] + have hmap' : + erasePrivateWitnessSnapshotOutput <$> + granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve + adversary parameter table ftsSecret canonical resolved.remaining + resolved.value [] = + granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary + parameter table ftsSecret canonical resolved.remaining resolved.value [] := by + simpa using hmap + rw [← hmap', support_map] + exact ⟨output, hfinish, rfl⟩ + have hlength := + support_granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve_length_le_of_expanded + adversary parameter table ftsSecret canonical resolved.remaining resolved.value + [] q (hbound resolved.value.1) + (canonicalizeMaterializedValues_valuesConsistent table resolved.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table resolved.context) + (erasePrivateWitnessSnapshotOutput output) herased + simpa [erasePrivateWitnessSnapshotOutput] using hlength + · simp [hcompletable] at hfinish + subst output + simp + · simp [hpublished] at hfinish + subst output + simp + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem snapshots_length_le_of_mem_sampledGranularAllCanonical + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q)) : + output.2.length ≤ q := by + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨table, _htable, hrest⟩ := houtput + exact snapshots_length_le_of_mem_granularAllCanonical adversary parameter table ftsSecret q + (hbound table) output hrest + +set_option maxHeartbeats 2000000 in +theorem probEvent_selectedPrivateSnapshotHitAt_eq_zero_of_q_le_ordinal + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hordinal : q ≤ ordinal) : + Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] = 0 := by + classical + apply probEvent_eq_zero + intro source hsource hselected + obtain ⟨selected, hselectedOrdinal, _⟩ := hselected + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot at hsource + rw [mem_support_bind_iff] at hsource + obtain ⟨table, _htable, hsource⟩ := hsource + have hlength : source.2.length ≤ q := + snapshots_length_le_of_mem_granularAllCanonical + (adversary := adversary) (parameter := parameter) (table := table) + (ftsSecret := ftsSecret) (q := q) (hbound := hbound table) (output := source) + (houtput := hsource) + have : ordinal < q := by + rw [← hselectedOrdinal] + exact selected.isLt.trans_le hlength + omega + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_le_of_selected_ordinals_bound + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) + (bound : ENNReal) + (hordinal : ∀ ordinal : Fin q, + Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal.val | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ bound) : + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + (q : ENNReal) * bound := by + classical + let diagnostic := + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q) + let source := + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q + calc + _ ≤ ∑ ordinal : Fin (2 * q), + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenHitAt ordinal.val | diagnostic] := + probEvent_sampledDiagnostic_successfulDoomed_le_sum_firstHits adversary parameter ftsSecret + q hq + _ ≤ ∑ ordinal : Fin (2 * q), + Pr[fun selected => SelectedPrivateSnapshotHitAt selected ordinal.val | source] := by + apply Finset.sum_le_sum + intro ordinal _hordinal + calc + _ ≤ Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenHitAt ordinal.val | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) + table] := + probEvent_sampledDiagnostic_successfulDoomed_firstExistingHiddenHitAt_le_raw adversary + parameter ftsSecret (2 * q) ordinal.val + _ ≤ _ := probEvent_sampledSuccessfulFirstHit_le_selectedSnapshot adversary parameter + ftsSecret q ordinal.val hexpanded hq + _ = ∑ ordinal : Fin q, + Pr[fun selected => SelectedPrivateSnapshotHitAt selected ordinal.val | source] := by + simp only [Finset.sum_fin_eq_sum_range] + rw [show 2 * q = q + q by omega, Finset.sum_range_add] + have hfirst : + (∑ ordinal ∈ Finset.range q, if h : ordinal < q + q then + Pr[fun selected => SelectedPrivateSnapshotHitAt selected ordinal | source] + else 0) = + ∑ ordinal ∈ Finset.range q, if h : ordinal < q then + Pr[fun selected => SelectedPrivateSnapshotHitAt selected ordinal | source] + else 0 := by + apply Finset.sum_congr rfl + intro ordinal hordinalMem + have hlt : ordinal < q := Finset.mem_range.1 hordinalMem + have hlt' : ordinal < q + q := hlt.trans_le (Nat.le_add_right q q) + simp [hlt, hlt'] + have hzero : + (∑ ordinal ∈ Finset.range q, if h : q + ordinal < q + q then + Pr[fun selected => SelectedPrivateSnapshotHitAt selected (q + ordinal) | source] + else 0) = 0 := by + apply Finset.sum_eq_zero + intro ordinal hordinalMem + have hlt : ordinal < q := Finset.mem_range.1 hordinalMem + simp only [show q + ordinal < q + q by omega, ↓reduceDIte] + exact probEvent_selectedPrivateSnapshotHitAt_eq_zero_of_q_le_ordinal adversary parameter + ftsSecret q (q + ordinal) hexpanded (by omega) + rw [hfirst, hzero, add_zero] + _ ≤ ∑ _ordinal : Fin q, bound := by + apply Finset.sum_le_sum + intro ordinal _hordinal + exact hordinal ordinal + _ = _ := by simp + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_le_of_selected_ordinals + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) + (hordinal : ∀ ordinal : Fin q, + Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal.val | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + (q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + exact probEvent_sampledDiagnostic_successfulDoomed_le_of_selected_ordinals_bound adversary parameter + ftsSecret q hexpanded hq (((2 ^ digestBits : Nat) : ENNReal)⁻¹) hordinal + +set_option maxHeartbeats 2000000 in +theorem probEvent_sampledDiagnostic_bad_le_of_selected_ordinals_bound + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) + (bound : ENNReal) + (hordinal : ∀ ordinal : Fin q, + Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal.val | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ bound) : + Pr[ObservedMaterializedDiagnostic.Bad | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + ((2 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + (q : ENNReal) * bound := by + let diagnostic := + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q) + calc + _ ≤ Pr[fun outcome => outcome.final = none | diagnostic] + + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | diagnostic] := + probEvent_diagnosticBad_le_finalNone_add_successfulDoomed diagnostic + _ ≤ ((2 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + (q : ENNReal) * bound := by + apply add_le_add + · exact probEvent_sampledObservedMaterializedDiagnostic_final_none_le adversary parameter + ftsSecret (2 * q) q hexpanded (by omega) + · exact probEvent_sampledDiagnostic_successfulDoomed_le_of_selected_ordinals_bound + adversary parameter ftsSecret q hexpanded hq bound hordinal + +set_option maxHeartbeats 2000000 in +theorem probEvent_sampledDiagnostic_bad_le_of_selected_ordinals + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) + (hordinal : ∀ ordinal : Fin q, + Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal.val | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[ObservedMaterializedDiagnostic.Bad | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + ((3 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ ((2 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + (q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + probEvent_sampledDiagnostic_bad_le_of_selected_ordinals_bound adversary parameter + ftsSecret q hexpanded hq (((2 ^ digestBits : Nat) : ENNReal)⁻¹) hordinal + _ = _ := by + push_cast + ring + +set_option maxHeartbeats 2000000 in +theorem probEvent_sampledDiagnostic_bad_le_of_selected_ordinals_mul + (c : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) + (hordinal : ∀ ordinal : Fin q, + Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal.val | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + (c : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[ObservedMaterializedDiagnostic.Bad | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + (((c + 2) * q : Nat) : ENNReal) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ ((2 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + (q : ENNReal) * ((c : ENNReal) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := + probEvent_sampledDiagnostic_bad_le_of_selected_ordinals_bound adversary parameter + ftsSecret q hexpanded hq + ((c : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) hordinal + _ = _ := by + push_cast + ring + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedProjection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedProjection.lean new file mode 100644 index 00000000..047c902c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedProjection.lean @@ -0,0 +1,180 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedTop + +/-! +# Stopped diagnostic projection + +The stopped coupling turns a successful already-materialized hidden hit into the exact source +snapshot that selected it. A non-root hit may instead be the separately charged hidden one-time +chain start. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +def FirstExistingHiddenChainStartHitAt + (observations : List CleanProbeObservation) (ordinal : Nat) : Prop := + ∃ selected : Fin observations.length, + selected.val = ordinal ∧ + (observations.get selected).ExistingHiddenChainStartHit ∧ + ∀ earlier : Fin observations.length, + earlier.val < ordinal → + ¬(observations.get earlier).ExistingHiddenHit + +theorem FirstExistingHiddenChainStartHit.at_of_firstExistingHiddenHitAt + {result : ObservedCleanRunResult α} {ordinal : Nat} + (hchain : FirstExistingHiddenChainStartHit result.observations) + (hfirst : FirstExistingHiddenHitAt result ordinal) : + FirstExistingHiddenChainStartHitAt result.observations ordinal := by + obtain ⟨selected, hselected, hhit⟩ := hchain.selected_eq hfirst + obtain ⟨firstSelected, hfirstOrdinal, _hfirstHit, hbefore⟩ := hfirst + have heq : selected = firstSelected := Fin.ext (hselected.trans hfirstOrdinal.symm) + subst selected + exact ⟨firstSelected, hfirstOrdinal, hhit, hbefore⟩ + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_observedMaterialized_successfulDoomed_firstRoot_le_selectedSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q] := by + apply probEvent_le_of_relTriple + (relTriple_symm + (relTriple_granularAllSnapshot_observedMaterializedRetained_firstStopped adversary + parameter ftsSecret q table hbound hq)) + intro observed source hrelation hevent + cases observed with + | none => simp [ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hevent + | some result => + obtain ⟨⟨finalResult, hfinish⟩, selected, hselected, hfirst, hroot⟩ := hevent + apply hrelation.selected_of_successful_firstRoot finalResult hfinish ordinal hfirst + intro other hother + have heq : other = selected := Fin.ext (hother.trans hselected.symm) + subst other + exact hroot + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_observedMaterialized_successfulDoomed_firstNonRoot_le_selectedSnapshot_add_chainStart + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q] + + Pr[fun observed => (match observed with + | none => False + | some result => FirstExistingHiddenChainStartHitAt result.observations ordinal) | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] := by + let source := granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q + let observed := observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + apply probEvent_le_failure_add_residual_of_relTriple observed source + (fun observed source => SnapshotObservedFirstStoppedRel table source observed) + (ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt table ordinal) + (fun observed => match observed with + | none => False + | some result => FirstExistingHiddenChainStartHitAt result.observations ordinal) + (fun source => SelectedPrivateSnapshotHitAt source ordinal) + (relTriple_symm + (relTriple_granularAllSnapshot_observedMaterializedRetained_firstStopped adversary + parameter ftsSecret q table hbound hq)) + intro right left hrelation hevent hnotChain + cases right with + | none => simp [ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt] at hevent + | some result => + obtain ⟨⟨finalResult, hfinish⟩, _selected, _hselected, hfirst, + _hnonRoot⟩ := hevent + rcases hrelation.selected_or_chain_of_successful_firstNonRoot finalResult hfinish ordinal + hfirst with hselected | hchain + · exact hselected + · exact (hnotChain (hchain.at_of_firstExistingHiddenHitAt hfirst)).elim + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_observedMaterialized_successfulDoomed_firstHit_le_selectedSnapshot_add_chainStartAt + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[fun observed => + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal + observed ∨ + ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt table ordinal + observed | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q] + + Pr[fun observed => (match observed with + | none => False + | some result => FirstExistingHiddenChainStartHitAt result.observations ordinal) | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] := by + let source := granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q + let observed := observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + apply probEvent_le_failure_add_residual_of_relTriple observed source + (fun observed source => SnapshotObservedFirstStoppedRel table source observed) + (fun observed => + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal observed ∨ + ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt table ordinal + observed) + (fun observed => match observed with + | none => False + | some result => FirstExistingHiddenChainStartHitAt result.observations ordinal) + (fun source => SelectedPrivateSnapshotHitAt source ordinal) + (relTriple_symm + (relTriple_granularAllSnapshot_observedMaterializedRetained_firstStopped adversary + parameter ftsSecret q table hbound hq)) + intro right left hrelation hevent hnotChain + rcases hevent with hroot | hnonRoot + · cases right with + | none => simp [ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hroot + | some result => + obtain ⟨⟨finalResult, hfinish⟩, selected, hselected, hfirst, hroot⟩ := + hroot + apply hrelation.selected_of_successful_firstRoot finalResult hfinish ordinal hfirst + intro other hother + have heq : other = selected := Fin.ext (hother.trans hselected.symm) + subst other + exact hroot + · cases right with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt] at hnonRoot + | some result => + obtain ⟨⟨finalResult, hfinish⟩, _selected, _hselected, hfirst, + _hnonRoot⟩ := hnonRoot + rcases hrelation.selected_or_chain_of_successful_firstNonRoot finalResult hfinish ordinal + hfirst with hselected | hchain + · exact hselected + · exact (hnotChain (hchain.at_of_firstExistingHiddenHitAt hfirst)).elim + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRoot.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRoot.lean new file mode 100644 index 00000000..95f5677c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRoot.lean @@ -0,0 +1,173 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedAlignedProjection +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionBoundary + +/-! +# Clean stopped layer-root projection + +The successful first-root diagnostic retains the exact source selector together with the intrinsic +fact that no earlier source snapshot is an already-materialized hidden structural hit. This is the +source event consumed by the joint root-selection bound. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +def SelectedPrivateSnapshotCleanRootHitAt + (table : OtsSecretIndex → HashOutput) + (source : PrivateWitnessSnapshotOutput) (ordinal : Nat) : Prop := + ∃ selected : Fin source.2.length, ∃ target output, + selected.val = ordinal ∧ + selectedPrivateSnapshotOrdinal? ordinal source.2 = + some (privateOrdinalSelectionOfSnapshot selected) ∧ + (privateOrdinalSelectionOfSnapshot selected).GoodForActualRoot target output ordinal ∧ + IsLayerRoot target ∧ + SnapshotsAvoidExistingHiddenPositionHits table (source.2.take ordinal) + +noncomputable def selectedPrivateSnapshotLayerRootPosition? + (ordinal : Nat) (source : PrivateWitnessSnapshotOutput) : Option Position := + if hselected : ordinal < source.2.length then + candidateLayerRootPosition? (source.2.get ⟨ordinal, hselected⟩).probe + else none + +theorem selectedPrivateSnapshotLayerRootPosition?_eq_some_of_cleanRootHitAt + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} {ordinal : Nat} + (hhit : SelectedPrivateSnapshotCleanRootHitAt table source ordinal) : + ∃ target, selectedPrivateSnapshotLayerRootPosition? ordinal source = some target := by + obtain ⟨selected, target, output, hordinal, _hselection, hgood, hroot, _hclean⟩ := hhit + have hlt : ordinal < source.2.length := by + rw [← hordinal] + exact selected.isLt + refine ⟨target, ?_⟩ + unfold selectedPrivateSnapshotLayerRootPosition? + rw [dif_pos hlt, candidateLayerRootPosition?_eq_some_iff] + have hindex : (⟨ordinal, hlt⟩ : Fin source.2.length) = selected := Fin.ext hordinal.symm + rw [hindex] + have hcandidate := hgood.1 + rw [privateOrdinalSelectionOfSnapshot_candidate] at hcandidate + have hcandidate' : (source.2.get selected).probe = + ⟨.position target, truncateHash output⟩ := by + simpa [snapshotProbeOrdinal] using hcandidate + exact ⟨congrArg Probe.coordinate hcandidate', hroot⟩ + +theorem not_selectedPrivateSnapshotCleanRootHitAt_of_position_eq_none + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} {ordinal : Nat} + (hposition : selectedPrivateSnapshotLayerRootPosition? ordinal source = none) : + ¬SelectedPrivateSnapshotCleanRootHitAt table source ordinal := by + intro hhit + obtain ⟨target, htarget⟩ := + selectedPrivateSnapshotLayerRootPosition?_eq_some_of_cleanRootHitAt hhit + rw [hposition] at htarget + simp at htarget + +theorem probEvent_selectedPrivateSnapshotCleanRootHitAt_le_of_position_fibers + (table : OtsSecretIndex → HashOutput) + (run : ProbComp PrivateWitnessSnapshotOutput) (ordinal : Nat) + (hfiber : ∀ target, + Pr[fun source => SelectedPrivateSnapshotCleanRootHitAt table source ordinal ∧ + selectedPrivateSnapshotLayerRootPosition? ordinal source = some target | run] ≤ + Pr[fun source => + selectedPrivateSnapshotLayerRootPosition? ordinal source = some target | run] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[fun source => SelectedPrivateSnapshotCleanRootHitAt table source ordinal | run] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_le_of_uniform_weighted_fibers run + (SelectedPrivateSnapshotCleanRootHitAt table · ordinal) + (selectedPrivateSnapshotLayerRootPosition? ordinal) + (((2 ^ digestBits : Nat) : ENNReal)⁻¹) + intro position? + cases position? with + | none => + have hzero : Pr[fun source => + SelectedPrivateSnapshotCleanRootHitAt table source ordinal ∧ + selectedPrivateSnapshotLayerRootPosition? ordinal source = none | run] = 0 := by + apply probEvent_eq_zero + intro source _hsource hevent + exact not_selectedPrivateSnapshotCleanRootHitAt_of_position_eq_none hevent.2 hevent.1 + rw [hzero] + exact zero_le + | some target => exact hfiber target + +theorem SnapshotObservedFirstStoppedRel.selectedCleanRoot_of_successful_firstRoot + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} + {result : ObservedCleanRunResult (α × SplitHashCache)} + (hrelation : SnapshotObservedFirstStoppedRel table source (some result)) + (finalResult : ObservedCleanRunResult (α × SplitHashCache)) + (hfinish : some finalResult ∈ support + (finishObservedCleanRunFromTable (some result))) + (ordinal : Nat) + (selected : Fin result.observations.length) + (hselected : selected.val = ordinal) + (hfirst : FirstExistingHiddenHitAt result ordinal) + (hroot : (result.observations.get selected).toProbe.IsLayerRoot) : + SelectedPrivateSnapshotCleanRootHitAt table source ordinal := by + rcases hrelation.selectedAligned_or_chain_of_successful_firstHit finalResult hfinish ordinal + hfirst with ⟨hhit, haligned⟩ | hchain + · rcases selectedPrivateSnapshotHitAt_root_or_nonRoot' hhit with hsourceRoot | hsourceNonRoot + · obtain ⟨sourceSelected, target, output, hsourceOrdinal, hselection, hgood, + htargetRoot⟩ := hsourceRoot + exact ⟨sourceSelected, target, output, hsourceOrdinal, hselection, hgood, htargetRoot, + haligned.avoidExistingHiddenPositionHits hfirst⟩ + · obtain ⟨sourceSelected, target, output, hsourceOrdinal, _hselection, hgood, + htargetNotRoot⟩ := hsourceNonRoot + obtain ⟨alignedSource, alignedObserved, halignedSource, halignedObserved, + hcandidates, _hprefix, _hsnapshots⟩ := haligned + have hsourceEq : sourceSelected = alignedSource := + Fin.ext (hsourceOrdinal.trans halignedSource.symm) + have hobservedEq : alignedObserved = selected := + Fin.ext (halignedObserved.trans hselected.symm) + have hsourceRoot : (source.2.get alignedSource).probe.IsLayerRoot := by + rw [hcandidates, hobservedEq] + exact hroot + have htargetRoot : IsLayerRoot target := by + rw [← hsourceEq] at hsourceRoot + have hcandidate := hgood.1 + rw [privateOrdinalSelectionOfSnapshot_candidate] at hcandidate + have hcandidate' : (source.2.get sourceSelected).probe = + ⟨.position target, truncateHash output⟩ := by + simpa [snapshotProbeOrdinal] using hcandidate + obtain ⟨rootTarget, hcoordinate, hrootTarget⟩ := hsourceRoot + have htarget : target = rootTarget := by + exact Coordinate.position.inj + ((congrArg Probe.coordinate hcandidate').symm.trans hcoordinate) + simpa [htarget] using hrootTarget + exact (htargetNotRoot htargetRoot).elim + · exact (not_firstExistingHiddenRootHitAt_of_firstChainStart hchain hfirst selected hselected + hroot).elim + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_observedMaterialized_successfulDoomed_firstRoot_le_selectedCleanRoot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun source => SelectedPrivateSnapshotCleanRootHitAt table source ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q] := by + apply probEvent_le_of_relTriple + (relTriple_symm + (relTriple_granularAllSnapshot_observedMaterializedRetained_firstStopped adversary + parameter ftsSecret q table hbound hq)) + intro observed source hrelation hevent + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hevent + | some result => + obtain ⟨⟨finalResult, hfinish⟩, selected, hselected, hfirst, hroot⟩ := hevent + exact hrelation.selectedCleanRoot_of_successful_firstRoot finalResult hfinish ordinal + selected hselected hfirst hroot + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveAfterRoot.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveAfterRoot.lean new file mode 100644 index 00000000..0fe631a0 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveAfterRoot.lean @@ -0,0 +1,149 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveLift +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareSharedSemantic + +/-! +# Adaptive selected-root coupling after the public root + +This module initializes the adaptive selected-root relation at one supported result of the +probe-free public-root computation. The remaining target-resolution normalization is kept separate. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_indicator_observed_directDelayed_afterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (rightRoot : Digest) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, rootResult.value.1, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary + ⟨rootResult.value.1, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) + (hroot : IsLayerRoot target) : + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining table rootResult.value.2) + (directDelayedSelectedRootIndicator ordinal parameter rootResult.value.1 ftsSecret table + target rightRoot + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state)) q + rootResult.value.2) + SuccessfulObservedIndicatorRel := by + have hpending : rootResult.state.pending = ∅ := + pending_eq_empty_of_mem_runCleanFromTable_maskedPublishedTreeRoot (2 * q) table rootResult + hresult + have htable : rootResult.table = table ∧ StartTableAgrees rootResult.state table := + startTableAgrees_of_mem_runCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table + (startTableAgrees_empty table) rootResult hresult + have hraw := mem_support_runRaw_done_of_mem_runCleanFromTable_some + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table rootResult + hresult + have hpublished : PublishedValues rootResult.state := + preservesPublishedValues_maskedPublishedTreeRoot + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) emptySplitHashCache (2 * q) + rootResult.state rootResult.remaining rootResult.value.1 rootResult.value.2 + publishedValues_empty hraw + have hchainValid : ChainState.ValidFor (fun _ ↦ True) rootResult.state := + preservesChainValid_maskedPublishedTreeRoot_true + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) emptySplitHashCache (2 * q) + rootResult.state rootResult.remaining rootResult.value.1 rootResult.value.2 + (by simp [ChainState.ValidFor, LazyRevealProbe.State.empty]) hraw + let right := directDeferredContext rootResult.state + have hvalid : right.Valid := by + constructor + · intro position output hvalue + simpa [right, directDeferredContext, directDeferredValues] using hvalue + · intro coordinate output _hvalue hhit + simp [right, directDeferredContext, LazyRevealProbe.State.hitAt, + LazyRevealProbe.State.pendingAt, hpending] at hhit + have hprivate : ¬PrivateStructuralHit right := by + rintro ⟨position, output, _hhidden, _hvalue, hhit⟩ + simp [right, directDeferredContext, LazyRevealProbe.State.hitAt, + LazyRevealProbe.State.pendingAt, hpending] at hhit + have hstart : ¬MissingChainStartHit table right := by + rintro ⟨index, _hvalue, hhit⟩ + simp [right, directDeferredContext, LazyRevealProbe.State.hitAt, + LazyRevealProbe.State.pendingAt, hpending] at hhit + have hcard : right.state.pending.card < Fintype.card Digest := by + simp [right, directDeferredContext, hpending] + have hcompletable : DeferredCompletable table right := + deferredCompletable_of_valid_of_no_boundary_hit table right hvalid htable.2 hprivate hstart + hcard + have hclean : ∀ coordinate output, + resolvedCompletionValue table right coordinate = some output → + ¬right.state.hitAt coordinate output := by + intro coordinate output _hvalue + simp [right, directDeferredContext, LazyRevealProbe.State.hitAt, + LazyRevealProbe.State.pendingAt, hpending] + have hbase : FinalizationContextLE table right right := + { view := FinalizationViewLE.refl table right hvalid htable.2 hclean + leftValid := hvalid + rightValid := hvalid + rightCompletable := hcompletable } + let left := canonicalizeMaterializedValues table right + have hcontext : FinalizationContextLE table left right := hbase.canonicalize_left + have hvalues : LazyRevealProbe.ValuesLE left.state right.state := + valuesLE_canonicalizeMaterializedValues_left table right htable.2 hpublished + have hremaining : rootResult.remaining = 2 * q := by + let observed : ObservedCleanRunResult (Digest × SplitHashCache) := + ⟨rootResult.state, rootResult.remaining, rootResult.value, rootResult.table, []⟩ + have hobserved : some observed ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + rw [← map_attachCleanProbeObservations_runCleanFromTable_of_probeFree + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty (2 * q) + table (maskedPublishedTreeRoot_probeFree emptySplitHashCache), support_map] + exact ⟨some rootResult, hresult, rfl⟩ + simpa [observed] using + (remaining_eq_fuel_of_mem_observed_of_probeFree + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty (2 * q) + table observed + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) hobserved) + have hcapacity : 2 * q < Fintype.card Digest := by + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + norm_num [securityBits, digestBits] at hq ⊢ + omega + have hbudget : rootResult.remaining + right.state.pending.card < Fintype.card Digest := by + rw [hremaining] + change 2 * q + rootResult.state.pending.card < Fintype.card Digest + rw [hpending] + simpa using hcapacity + have hrel := relTriple_indicator_observed_directDelayed ordinal parameter rootResult.value.1 + rightRoot ftsSecret table target hroot + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] [] left right q + rootResult.remaining rootResult.value.2 rootResult.value.2 q q hbound hcontext rfl rfl + hvalues hpublished.to_canonicalizedMaterializedValues rfl hchainValid + (canonicalizeMaterializedValues_canonical table right hvalid.valuesConsistent) + (by simp [SnapshotsObservedAt]) (by simp [SnapshotsBefore]) + (by simp [CleanProbeObservationsTrackedBy]) + (by simp [CleanProbeObservationsCoverPending, right, directDeferredContext, hpending]) + (by simp) (by simp) (by simp) + (by simp [PendingCoveredBy, left, canonicalizeMaterializedValues, right, directDeferredContext, + hpending]) le_rfl le_rfl (by omega) hbudget + dsimp [left, right] at hrel + simpa [directDeferredContext] using hrel + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveBridge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveBridge.lean new file mode 100644 index 00000000..471f67e4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveBridge.lean @@ -0,0 +1,159 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerBridge +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerSelected + +/-! +# Adaptive selected-root bridge + +The comparison root is independent of both executions. This file conditions on it before the +remaining adaptive coupling, leaving the hard prefix theorem with one fewer sampler and no product +wrapper. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +noncomputable def fixedComparisonRootIndicator + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (target : Position) + (root rightRoot : Digest) : + Option (ObservedCleanRunResult (RetainedRestResult × SplitHashCache)) → Bool := + fun observed => successfulObservedRootComparisonIndicator table ordinal target + (retainObservedRoot root observed, rightRoot) + +noncomputable def resolvedEagerObservedRootComparisonAtRoot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp (Option (ObservedCleanRunResult (RetainedRestResult × SplitHashCache))) := do + let resolved ← resolveDeferredPositionValue target (directDeferredContext rootResult.state) + match resolved with + | none => pure none + | some resolved => + observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState resolved.toDeferredContext) rootResult.remaining rootResult.table + (replaceHiddenRootCache target resolved.output rootResult.value.2) + +set_option maxRecDepth 100000 in +theorem relTriple_indicator_afterRootResult_of_fixedComparisonRoot + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hfixed : ∀ rightRoot, + RelTriple + (fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> + observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining table rootResult.value.2) + (fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> + resolvedEagerObservedRootComparisonAtRoot adversary parameter ftsSecret target + rootResult) + SuccessfulObservedIndicatorRel) : + RelTriple + (successfulObservedRootComparisonIndicator table ordinal target <$> (do + let observed ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining table rootResult.value.2 + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (retainObservedRoot rootResult.value.1 observed, rightRoot))) + (successfulObservedRootComparisonIndicator table ordinal target <$> + resolvedEagerObservedRootComparisonAfterRootResult adversary parameter ftsSecret target + rootResult) + SuccessfulObservedIndicatorRel := by + let observed := observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining table rootResult.value.2 + let comparison := ($ᵗ Digest : ProbComp Digest) + let leftAtRoot := fun rightRoot => + fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> observed + let rightAtRoot := fun rightRoot => + fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> + resolvedEagerObservedRootComparisonAtRoot adversary parameter ftsSecret target rootResult + have hconditioned : RelTriple + (comparison >>= leftAtRoot) (comparison >>= rightAtRoot) + SuccessfulObservedIndicatorRel := by + apply relTriple_bind (relTriple_refl comparison) + intro leftRoot rightRoot hroot + subst rightRoot + exact hfixed leftRoot + have hleft : evalDist + (successfulObservedRootComparisonIndicator table ordinal target <$> (do + let observed ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining table rootResult.value.2 + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (retainObservedRoot rootResult.value.1 observed, rightRoot))) = + evalDist (comparison >>= leftAtRoot) := by + unfold comparison leftAtRoot fixedComparisonRootIndicator + simp only [map_eq_bind_pure_comp, bind_assoc] + rw [OracleComp.DeferredSampling.evalDist_bind_comm observed + ($ᵗ Digest : ProbComp Digest)] + apply evalDist_bind_congr + intro rightRoot _hrightRoot + apply evalDist_bind_congr + intro result _hresult + cases result <;> rfl + have hright : evalDist (comparison >>= rightAtRoot) = evalDist + (successfulObservedRootComparisonIndicator table ordinal target <$> + resolvedEagerObservedRootComparisonAfterRootResult adversary parameter ftsSecret target + rootResult) := by + let resolver := + resolveDeferredPositionValue target (directDeferredContext rootResult.state) + let continuation : Digest → Option DeferredResolution → ProbComp Bool := + fun rightRoot resolved => + match resolved with + | none => pure (fixedComparisonRootIndicator table ordinal target rootResult.value.1 + rightRoot (none : Option + (ObservedCleanRunResult (RetainedRestResult × SplitHashCache)))) + | some resolved => + fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> + observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState resolved.toDeferredContext) rootResult.remaining + rootResult.table + (replaceHiddenRootCache target resolved.output rootResult.value.2) + have hswap := OracleComp.DeferredSampling.evalDist_bind_comm comparison resolver continuation + have hconditionedRight : evalDist (comparison >>= rightAtRoot) = + evalDist (comparison >>= fun rightRoot => + resolver >>= continuation rightRoot) := by + apply evalDist_bind_congr + intro rightRoot _hrightRoot + unfold rightAtRoot resolvedEagerObservedRootComparisonAtRoot + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved with + | none => rfl + | some resolved => rfl + have horiginalRight : + evalDist (resolver >>= fun resolved => + comparison >>= fun rightRoot => continuation rightRoot resolved) = + evalDist + (successfulObservedRootComparisonIndicator table ordinal target <$> + resolvedEagerObservedRootComparisonAfterRootResult adversary parameter ftsSecret + target rootResult) := by + unfold resolver comparison continuation + resolvedEagerObservedRootComparisonAfterRootResult fixedComparisonRootIndicator + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved with + | none => + apply evalDist_bind_congr + intro rightRoot _hrightRoot + rfl + | some resolved => + apply evalDist_bind_congr + intro rightRoot _hrightRoot + simp only + rw [bind_assoc] + apply evalDist_bind_congr + intro observed _hobserved + cases observed <;> rfl + exact hconditionedRight.trans (hswap.trans horiginalRight) + exact relTriple_of_evalDist_eq_left hleft + (relTriple_of_evalDist_eq_right hright hconditioned) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveEndpoint.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveEndpoint.lean new file mode 100644 index 00000000..ce8c277c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveEndpoint.lean @@ -0,0 +1,374 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveReverse +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedAfterRoot + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_eagerProxy_resolvedObservedAtRoot_afterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (rightRoot : Digest) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, rootResult.value.1, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary + ⟨rootResult.value.1, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) + (hroot : IsLayerRoot target) : + RelTriple + (eagerDirectDelayedSelectedRootIndicator ordinal parameter rootResult.value.1 ftsSecret table + target rightRoot + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state)) q + rootResult.value.2) + (fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> + resolvedEagerObservedRootComparisonAtRoot adversary parameter ftsSecret target rootResult) + SuccessfulObservedIndicatorRel := by + have hinitial := directDeferredContext_invariants_afterRootResult table (2 * q) rootResult hresult + have hrootRaw := mem_support_runRaw_done_of_mem_runCleanFromTable_some + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table rootResult hresult + have hrootPublished : PublishedValues rootResult.state := + preservesPublishedValues_maskedPublishedTreeRoot + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) emptySplitHashCache (2 * q) + rootResult.state rootResult.remaining rootResult.value.1 rootResult.value.2 + publishedValues_empty hrootRaw + have htable : rootResult.table = table ∧ StartTableAgrees rootResult.state table := + startTableAgrees_of_mem_runCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table + (startTableAgrees_empty table) rootResult hresult + have hrootChainValid : ChainState.ValidFor (fun _ ↦ True) rootResult.state := + preservesChainValid_maskedPublishedTreeRoot_true + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) emptySplitHashCache (2 * q) + rootResult.state rootResult.remaining rootResult.value.1 rootResult.value.2 + (by simp [ChainState.ValidFor, LazyRevealProbe.State.empty]) hrootRaw + have hrootPending : rootResult.state.pending = ∅ := + pending_eq_empty_of_mem_runCleanFromTable_maskedPublishedTreeRoot (2 * q) table rootResult + hresult + have hremaining : rootResult.remaining = 2 * q := by + let observed : ObservedCleanRunResult (Digest × SplitHashCache) := + ⟨rootResult.state, rootResult.remaining, rootResult.value, rootResult.table, []⟩ + have hobserved : some observed ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + rw [← map_attachCleanProbeObservations_runCleanFromTable_of_probeFree + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty (2 * q) + table (maskedPublishedTreeRoot_probeFree emptySplitHashCache), support_map] + exact ⟨some rootResult, hresult, rfl⟩ + simpa [observed] using + (remaining_eq_fuel_of_mem_observed_of_probeFree + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty (2 * q) + table observed (maskedPublishedTreeRoot_probeFree emptySplitHashCache) hobserved) + have hcapacity : 2 * q < Fintype.card Digest := by + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + norm_num [securityBits, digestBits] at hq ⊢ + omega + unfold eagerDirectDelayedSelectedRootIndicator + simp only [List.length_nil, Nat.not_lt_zero, ↓reduceIte] + unfold resolvedEagerObservedRootComparisonAtRoot + simp only [map_eq_bind_pure_comp, bind_assoc] + have hresolve := relTriple_resolveDeferredPositionValue_canonical_afterRootResult table (2 * q) + target rootResult hresult + have hleft := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolve + (fun resolved ↦ resolved ∈ support + (resolveDeferredPositionValue target + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state)))) + (fun _ hsupport ↦ hsupport) + have hboth := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_bind hboth + intro left right hrelation + rcases hrelation with ⟨⟨hresolution, hleftSupport⟩, hrightSupport⟩ + cases left with + | none => + cases right with + | none => exact relTriple_pure_pure (fun hfalse ↦ (Bool.false_ne_true hfalse).elim) + | some right => simp [FinalizationResolutionEq] at hresolution + | some left => + cases right with + | none => simp [FinalizationResolutionEq] at hresolution + | some right => + simp only [pure_bind] + let initial := canonicalizeMaterializedValues table + (directDeferredContext rootResult.state) + have hinitialCanonical := valid_completable_canonicalizeMaterializedValues table + (directDeferredContext rootResult.state) hinitial.1 hinitial.2.1 + have hleftValid : left.toDeferredContext.Valid := + hinitialCanonical.1.of_resolveDeferredPositionValue target left hleftSupport + have hleftCompletable : DeferredCompletable table left.toDeferredContext := + hinitialCanonical.2.of_resolveDeferredPositionValue hinitialCanonical.1 target left + hleftSupport + have hleftCanonical := left_resolution_canonical_afterRootResult table (2 * q) target + rootResult hresult left hleftSupport + have hleftState := resolveDeferredPositionValue_state_eq_clearPending target initial left + hleftSupport + have hinitialPublished : PublishedValues initial.state := by + apply PublishedValues.to_canonicalizedMaterializedValues + (context := directDeferredContext rootResult.state) + simpa [directDeferredContext] using hrootPublished + have hleftPublished : PublishedValues left.state := by + rw [hleftState] + intro coordinate hrevealed + have hnonempty := hinitialPublished coordinate (by + simpa [LazyRevealProbe.State.clearPending] using hrevealed) + simpa [LazyRevealProbe.State.clearPending] using hnonempty + have hleftChainValid : ChainState.ValidFor (fun _ ↦ True) left.state := by + intro coordinate hcoordinate + constructor + · intro hsome + by_contra hhidden + rw [hleftCanonical] at hsome + simp [publicMaterializedValues, hhidden] at hsome + · exact ⟨hleftPublished coordinate, fun _ ↦ trivial⟩ + have hleftPrivate : left.toDeferredContext.values target = some left.output := + resolveDeferredPositionValue_installs target initial left hleftSupport + have hleftPending : left.state.pending = ∅ := by + rw [resolveDeferredPositionValue_pending target initial left hleftSupport] + simp [initial, canonicalizeMaterializedValues, directDeferredContext, hrootPending, + LazyRevealProbe.State.pendingAway] + have hshadow := relTriple_directDelayed_observed_shadow ordinal parameter + rootResult.value.1 rightRoot ftsSecret table target left.output hroot + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + left.toDeferredContext q (2 * q) q q rootResult.value.2 hbound hleftValid + hleftCompletable hleftPublished hleftCanonical hleftChainValid hleftPrivate + (by simp [SnapshotsObservedAt]) (by simp [SnapshotsBefore]) + (by simp [CleanProbeObservationsTrackedBy]) + (by simp [CleanProbeObservationsCoverPending, hleftPending]) (by simp) + (by simp [PendingCoveredBy, hleftPending]) (by simp) le_rfl le_rfl (by omega) + (by simpa [hleftPending] using hcapacity) + have hcanonicalized := canonicalized_resolutions_afterRootResult table target + rootResult.state left right hleftSupport hrightSupport hresolution + let leftCanonical := canonicalizeMaterializedValues table left.toDeferredContext + let rightCanonical := canonicalizeMaterializedValues table right.toDeferredContext + have hleftCanonicalEq : leftCanonical = left.toDeferredContext := by + exact canonicalizeMaterializedValues_eq_of_canonical table left.toDeferredContext + hleftCanonical + have hrightState := resolveDeferredPositionValue_state_eq_clearPending target + (directDeferredContext rootResult.state) right hrightSupport + have hrightStarts : StartTableAgrees right.state table := by + rw [hrightState] + intro index output hvalue + apply htable.2 index output + simpa [directDeferredContext, LazyRevealProbe.State.clearPending] using hvalue + have hrightChainValid : ChainState.ValidFor (fun _ ↦ True) right.state := by + rw [hrightState] + intro coordinate hcoordinate + simpa [directDeferredContext, LazyRevealProbe.State.clearPending] using + hrootChainValid coordinate hcoordinate + have hrightMaterialized : materializedDeferredState rightCanonical = + materializedDeferredState right.toDeferredContext := by + exact ScratchLocal.materializedDeferredState_canonicalize_eq table + right.toDeferredContext hrightStarts hrightChainValid + hresolution.2.2.2.1.valuesConsistent + have hstateEq : CompletionSafeStateEq table + (materializedDeferredState left.toDeferredContext) + (materializedDeferredState right.toDeferredContext) := by + have hsafe := hcanonicalized.2.2.2 + rw [canonicalizeMaterializedValues_eq_of_canonical table left.toDeferredContext + hleftCanonical, + ScratchLocal.materializedDeferredState_canonicalize_eq table + right.toDeferredContext hrightStarts hrightChainValid + hresolution.2.2.2.1.valuesConsistent] at hsafe + exact hsafe + let leftObserved := observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState left.toDeferredContext) (2 * q) table rootResult.value.2 + let rightObserved := observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState right.toDeferredContext) (2 * q) table rootResult.value.2 + have hstateBridge : RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> leftObserved) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> rightObserved) + (EqRel Bool) := by + apply relTriple_indicator_observedMaterializedBoundary_completionSafeEq ordinal + parameter rootResult.value.1 rightRoot ftsSecret table target + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState left.toDeferredContext) + (materializedDeferredState right.toDeferredContext) (2 * q) rootResult.value.2 + hstateEq + intro index output hvalue + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + apply hresolution.2.1.leftStarts ⟨lay, tree, leafIdx, chainIdx⟩ output + simpa [materializedDeferredState, OtsSecretIndex.coordinate] using hvalue + have hstateImp : RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> leftObserved) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> rightObserved) + SuccessfulObservedIndicatorRel := by + apply relTriple_post_mono hstateBridge + intro leftValue rightValue heq + intro htrue + rw [← heq] + exact htrue + change RelTriple _ + (fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> + observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState right.toDeferredContext) rootResult.remaining + rootResult.table + (replaceHiddenRootCache target right.output rootResult.value.2)) + SuccessfulObservedIndicatorRel + rw [hremaining, htable.1] + have hfirst := SphincsSecurity.relTriple_trans_exists hshadow hstateImp + let installedObserved := observedMaterializedBoundary parameter rootResult.value.1 + ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState right.toDeferredContext) (2 * q) table + (replaceHiddenRootCache target right.output rootResult.value.2) + have hordinary : ordinaryQueryCache rootResult.value.2 = + ordinaryQueryCache + (replaceHiddenRootCache target right.output rootResult.value.2) := by + simpa [replaceHiddenRootCache] using + (ordinaryQueryCache_update_hidden rootResult.value.2 (.position target) right.output).symm + have hcacheBase := relTriple_observedMaterializedBoundary_ordinaryCache parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + (materializedDeferredState right.toDeferredContext) (2 * q) table rootResult.value.2 + (replaceHiddenRootCache target right.output rootResult.value.2) hordinary + have hcacheBridge : RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> rightObserved) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> installedObserved) + SuccessfulObservedIndicatorRel := by + apply relTriple_map + apply relTriple_post_mono hcacheBase + intro leftResult rightResult hrelation hleftGood + cases leftResult with + | none => + cases rightResult with + | none => exact hleftGood + | some rightResult => simp [ObservedOrdinaryCacheRel] at hrelation + | some leftResult => + cases rightResult with + | none => simp [ObservedOrdinaryCacheRel] at hrelation + | some rightResult => + rcases hrelation with + ⟨hstate, hremaining, htable, hvalue, _hcache, suffix, + hleftObservations, hrightObservations⟩ + change successfulObservedRootComparisonIndicator table ordinal target + (some leftResult, rightRoot) = true at hleftGood + rw [successfulObservedRootComparisonIndicator_eq_true_iff] at hleftGood + change successfulObservedRootComparisonIndicator table ordinal target + (some rightResult, rightRoot) = true + rw [successfulObservedRootComparisonIndicator_eq_true_iff] + have hobservations : leftResult.observations = rightResult.observations := by + rw [hleftObservations, hrightObservations] + rcases hleftGood with + ⟨⟨⟨hfinish, hfirstRoot⟩, hposition⟩, hcomparison⟩ + have hrightFinish := exists_finishObservedCleanRunFromTable_of_state_table_eq + leftResult rightResult hstate htable hfinish + have hrightPosition : + observedFirstLayerRootPosition? ordinal (some rightResult) = some target := by + rw [← observedFirstLayerRootPosition?_eq_of_observations_eq ordinal + leftResult rightResult hobservations] + exact hposition + obtain ⟨_selected, _hselected, hfirst, _hroot⟩ := hfirstRoot + have hrightFirst := firstExistingHiddenHitAt_of_observations_eq leftResult + rightResult ordinal hobservations hfirst + have hrightFirstRoot : + ObservedCleanRunOption.FirstExistingHiddenRootHitAt ordinal + (some rightResult) := + firstExistingHiddenRootHitAt_of_first_of_position rightResult ordinal target + hrightFirst hrightPosition + have hrightComparison : CandidatesAvoidRoot target rightRoot + (observedPrefixProbes ordinal (some rightResult)) := by + rw [← observedPrefixProbes_eq_of_observations_eq ordinal leftResult + rightResult hobservations] + exact hcomparison + exact ⟨⟨⟨hrightFinish, hrightFirstRoot⟩, + hrightPosition⟩, hrightComparison⟩ + have hsecond := SphincsSecurity.relTriple_trans_exists hfirst hcacheBridge + have hretain : RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> installedObserved) + (fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> + installedObserved) + (EqRel Bool) := by + apply relTriple_map + apply relTriple_post_mono (relTriple_refl installedObserved) + intro leftResult rightResult heq + subst rightResult + apply Bool.eq_iff_iff.mpr + simp only [Function.comp_apply] + unfold fixedComparisonRootIndicator + rw [successfulObservedRootComparisonIndicator_eq_true_iff, + successfulObservedRootComparisonIndicator_eq_true_iff] + change + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt table ordinal + target rightRoot leftResult ↔ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt table ordinal + target rightRoot (retainObservedRoot rootResult.value.1 leftResult) + exact (successfulDoomedFirstRootGoodForComparisonAt_retainObservedRoot_iff table + ordinal target rootResult.value.1 rightRoot leftResult).symm + have hretainImp : RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> installedObserved) + (fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> + installedObserved) + SuccessfulObservedIndicatorRel := by + apply relTriple_post_mono hretain + intro leftValue rightValue heq htrue + rwa [← heq] + have hfinal := SphincsSecurity.relTriple_trans_exists hsecond hretainImp + apply relTriple_post_mono hfinal + intro source retained hrelation + obtain ⟨installed, htoInstalled, hretainResult⟩ := hrelation + obtain ⟨rightState, htoRightState, hcacheResult⟩ := htoInstalled + obtain ⟨leftState, hshadowResult, hstateResult⟩ := htoRightState + exact fun htrue ↦ + hretainResult (hcacheResult (hstateResult (hshadowResult htrue))) + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_observedRootComparison_le_production_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] ≤ + Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target (2 * q) table] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_observedRootComparison_le_production_mul_of_eagerProxy ordinal adversary + parameter table ftsSecret q target hroot hparent hfuel hbound hq + intro rootResult hresult rightRoot + exact relTriple_eagerProxy_resolvedObservedAtRoot_afterRootResult ordinal adversary parameter + table ftsSecret q target rightRoot rootResult hresult (hbound rootResult.value.1) hq hroot + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveLift.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveLift.lean new file mode 100644 index 00000000..265c9cbc --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveLift.lean @@ -0,0 +1,2969 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdministrative +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveRootAwarePrivate +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedChain + +/-! +# Adaptive selected-root lift + +The first-stopped step relation is consumed without forgetting the shared continuation. Clean +steps recurse, failed materialized steps make the real indicator false, and a persistent missing +chain start contradicts successful finalization. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem cleanProbeObservation_materializedDeferredState_eq_of_position + (table : OtsSecretIndex → HashOutput) (left right : DeferredContext) + (position : Position) (candidate : Digest) + (hcontext : FinalizationContextLE table left right) + (hrevealed : left.state.revealed = right.state.revealed) + (hrightMaterialized : right = directDeferredContext right.state) : + cleanProbeObservation (materializedDeferredState left) (.position position) candidate = + cleanProbeObservation right.state (.position position) candidate := by + unfold cleanProbeObservation + have hvalue := congrFun hcontext.view.valueEq (.position position) + simp only [resolvedCompletionValue] at hvalue + rw [hrightMaterialized] at hvalue + simp only [directDeferredContext, directDeferredValues, DeferredContext.positionValue] at hvalue + have hvalue' : left.positionValue position = + right.state.values (.position position) := by + cases hrightValue : right.state.values (.position position) <;> + simpa [DeferredContext.positionValue, hrightValue] using hvalue + simp only [materializedDeferredState_position, hvalue', materializedDeferredState_revealed, + hrevealed] + +theorem not_existingHiddenHit_cleanProbeObservation_materializedDeferredState + (table : OtsSecretIndex → HashOutput) (left right : DeferredContext) + (coordinate : Coordinate) (candidate : Digest) + (hcontext : FinalizationContextLE table left right) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hactual : ¬(cleanProbeObservation right.state coordinate candidate).ExistingHiddenHit) : + ¬(cleanProbeObservation (materializedDeferredState left) coordinate candidate).ExistingHiddenHit := by + cases coordinate with + | position position => + rw [cleanProbeObservation_materializedDeferredState_eq_of_position table left right + position candidate hcontext hrevealed hrightMaterialized] + exact hactual + | chainStart lay tree leafIdx chainIdx => + rintro ⟨hhidden, output, hvalue, hcandidate⟩ + apply hactual + refine ⟨?_, output, ?_, hcandidate⟩ + · simpa [cleanProbeObservation, materializedDeferredState_revealed, hrevealed] using hhidden + · have hleftValue : left.state.values + (.chainStart lay tree leafIdx chainIdx) = some output := by + simpa [cleanProbeObservation, materializedDeferredState_chainStart] using hvalue + simpa [cleanProbeObservation] using hvalues _ output hleftValue + +theorem materializedDeferredState_values_eq_of_chainValid + (table : OtsSecretIndex → HashOutput) (left right : DeferredContext) + (hcontext : FinalizationContextLE table left right) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hchainValid : ChainState.ValidFor (fun _ => True) right.state) + (hrightMaterialized : right = directDeferredContext right.state) : + (materializedDeferredState left).values = right.state.values := by + funext coordinate + cases coordinate with + | position position => + have hvalue := congrFun hcontext.view.valueEq (.position position) + rw [hrightMaterialized] at hvalue + cases hrightValue : right.state.values (.position position) <;> + simpa [resolvedCompletionValue, DeferredContext.positionValue, + directDeferredContext, directDeferredValues, hrightValue] using hvalue + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + cases hrightValue : right.state.values index.coordinate with + | none => + have hleftValue : left.state.values index.coordinate = none := by + by_contra hne + obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hne + have := hvalues index.coordinate output houtput + rw [hrightValue] at this + simp at this + change left.state.values index.coordinate = right.state.values index.coordinate + rw [hrightValue] + exact hleftValue + | some output => + have hrightRevealed : index.coordinate ∈ right.state.revealed := + (hchainValid index.coordinate (by simp [index, OtsSecretIndex.coordinate, + IsChainCoordinate])).1 (by simp [hrightValue]) + have hleftRevealed : index.coordinate ∈ left.state.revealed := by + rwa [hrevealed] + have hleftKnown := hpublished index.coordinate hleftRevealed + obtain ⟨leftOutput, hleftValue⟩ := Option.ne_none_iff_exists'.mp hleftKnown + have hleftTable := hcontext.view.leftStarts index leftOutput hleftValue + have hrightTable := hcontext.view.rightStarts index output (by + rw [hrightMaterialized] + simpa [directDeferredContext] using hrightValue) + change left.state.values index.coordinate = right.state.values index.coordinate + rw [hrightValue] + exact hleftValue.trans (congrArg some (hleftTable.trans hrightTable.symm)) + +structure CompletionSafeStateLE + (table : OtsSecretIndex → HashOutput) + (left right : LazyRevealProbe.State Coordinate) : Prop where + values : left.values = right.values + revealed : left.revealed = right.revealed + pending : ∀ coordinate candidate, + (coordinate, candidate) ∈ left.pending → + (coordinate, candidate) ∈ right.pending ∨ + (∃ output, left.values coordinate = some output ∧ + candidate ≠ truncateHash output) ∨ + ∃ index : OtsSecretIndex, + coordinate = index.coordinate ∧ candidate ≠ truncateHash (table index) + +theorem CompletionSafeStateLE.refl + (table : OtsSecretIndex → HashOutput) + (state : LazyRevealProbe.State Coordinate) : + CompletionSafeStateLE table state state := + ⟨rfl, rfl, fun _ _ hentry ↦ Or.inl hentry⟩ + +theorem CompletionSafeStateLE.ensure + {table : OtsSecretIndex → HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hstate : CompletionSafeStateLE table left right) (coordinate : Coordinate) : + CompletionSafeStateLE table (left.ensure coordinate) (right.ensure coordinate) := by + exact ⟨hstate.values, hstate.revealed, hstate.pending⟩ + +theorem CompletionSafeStateLE.publish + {table : OtsSecretIndex → HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hstate : CompletionSafeStateLE table left right) (coordinate : Coordinate) : + CompletionSafeStateLE table (left.publish coordinate) (right.publish coordinate) := by + refine ⟨hstate.values, ?_, hstate.pending⟩ + simp [LazyRevealProbe.State.publish, hstate.revealed] + +theorem CompletionSafeStateLE.addPending + {table : OtsSecretIndex → HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hstate : CompletionSafeStateLE table left right) + (coordinate : Coordinate) (candidate : Digest) : + CompletionSafeStateLE table + (left.addPending coordinate candidate) (right.addPending coordinate candidate) := by + refine ⟨hstate.values, hstate.revealed, ?_⟩ + intro other otherCandidate hentry + simp only [LazyRevealProbe.State.addPending, Finset.mem_insert] at hentry ⊢ + rcases hentry with hnew | hold + · exact Or.inl (Or.inl hnew) + · rcases hstate.pending other otherCandidate hold with hright | hsafe + · exact Or.inl (Or.inr hright) + · exact Or.inr hsafe + +theorem CompletionSafeStateLE.clearPending + {table : OtsSecretIndex → HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hstate : CompletionSafeStateLE table left right) (coordinate : Coordinate) : + CompletionSafeStateLE table + (left.clearPending coordinate) (right.clearPending coordinate) := by + refine ⟨hstate.values, hstate.revealed, ?_⟩ + intro other candidate hentry + simp only [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway, + Finset.mem_filter] at hentry ⊢ + rcases hstate.pending other candidate hentry.1 with hright | hsafe + · exact Or.inl ⟨hright, hentry.2⟩ + · exact Or.inr hsafe + +theorem CompletionSafeStateLE.materialize + {table : OtsSecretIndex → HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hstate : CompletionSafeStateLE table left right) + (coordinate : Coordinate) (output : HashOutput) : + CompletionSafeStateLE table + (left.materialize coordinate output) (right.materialize coordinate output) := by + refine ⟨?_, hstate.revealed, ?_⟩ + · simp [LazyRevealProbe.State.materialize, hstate.values] + · intro other candidate hentry + simp only [LazyRevealProbe.State.materialize, LazyRevealProbe.State.pendingAway, + Finset.mem_filter] at hentry ⊢ + rcases hstate.pending other candidate hentry.1 with hright | hsafe + · exact Or.inl ⟨hright, hentry.2⟩ + · rcases hsafe with ⟨known, hknown, hmiss⟩ | hchain + · right + left + by_cases heq : other = coordinate + · exact (hentry.2 heq).elim + · refine ⟨known, ?_, hmiss⟩ + simpa [LazyRevealProbe.State.materialize, Function.update_of_ne heq] using hknown + · exact Or.inr (Or.inr hchain) + +theorem CompletionSafeStateLE.complete + {table : OtsSecretIndex → HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hstate : CompletionSafeStateLE table left right) + (coordinate : Coordinate) (output : HashOutput) : + CompletionSafeStateLE table + (left.complete coordinate output) (right.complete coordinate output) := by + refine ⟨?_, hstate.revealed, ?_⟩ + · simp [LazyRevealProbe.State.complete, hstate.values] + · intro other candidate hentry + simp only [LazyRevealProbe.State.complete, LazyRevealProbe.State.pendingAway, + Finset.mem_filter] at hentry ⊢ + rcases hstate.pending other candidate hentry.1 with hright | hsafe + · exact Or.inl ⟨hright, hentry.2⟩ + · rcases hsafe with ⟨known, hknown, hmiss⟩ | hchain + · right + left + by_cases heq : other = coordinate + · exact (hentry.2 heq).elim + · refine ⟨known, ?_, hmiss⟩ + simpa [LazyRevealProbe.State.complete, Function.update_of_ne heq] using hknown + · exact Or.inr (Or.inr hchain) + +theorem CompletionSafeStateLE.not_hitAt_left_of_right + {table : OtsSecretIndex → HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hstate : CompletionSafeStateLE table left right) + (coordinate : Coordinate) (output : HashOutput) + (hleftValue : left.values coordinate = none) + (hcompletion : ∀ index : OtsSecretIndex, + coordinate = index.coordinate → output = table index) + (hrightMiss : ¬right.hitAt coordinate output) : + ¬left.hitAt coordinate output := by + intro hleftHit + have hentry : (coordinate, truncateHash output) ∈ left.pending := by + rwa [← LazyRevealProbe.State.mem_pendingAt_iff] + rcases hstate.pending coordinate (truncateHash output) hentry with + hright | ⟨known, hknown, _hmiss⟩ | ⟨index, hcoordinate, hmiss⟩ + · apply hrightMiss + rwa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff] + · rw [hleftValue] at hknown + simp at hknown + · exact hmiss (congrArg truncateHash (hcompletion index hcoordinate)) + +theorem doomed_direct_addPending_of_stored + {table : OtsSecretIndex → HashOutput} + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (output : HashOutput) + (hvalue : state.values coordinate = some output) + (hstarts : StartTableAgrees state table) : + DoomedResolvedContext table + (directDeferredContext + (state.addPending coordinate (truncateHash output))) := by + refine ⟨?_, ?_, ?_⟩ + · intro position stored hstored + simpa [directDeferredContext, directDeferredValues] using hstored + · intro index stored hstored + apply hstarts index stored + simpa [directDeferredContext, LazyRevealProbe.State.addPending] using hstored + · rintro ⟨completion, hcompletion⟩ + have hcompletionValue : completion coordinate = output := + hcompletion.1 coordinate output (by + simpa [directDeferredContext, LazyRevealProbe.State.addPending] using hvalue) + have havoids := hcompletion.2.2.1 coordinate (truncateHash output) (by + simp [directDeferredContext, LazyRevealProbe.State.addPending]) + exact havoids (by rw [hcompletionValue]) + +set_option maxRecDepth 100000 in +theorem relTriple_map_isSome_finalizeCleanFromTable_completionSafe + (table : OtsSecretIndex → HashOutput) (coordinates : List Coordinate) + (left right : LazyRevealProbe.State Coordinate) + (hstate : CompletionSafeStateLE table left right) : + RelTriple + (Option.isSome <$> finalizeCleanFromTable coordinates right table) + (Option.isSome <$> finalizeCleanFromTable coordinates left table) + BoolImp := by + induction coordinates generalizing left right with + | nil => simp [finalizeCleanFromTable, BoolImp] + | cons coordinate remaining ih => + rw [finalizeCleanFromTable.eq_def, finalizeCleanFromTable.eq_def] + have hvalue : left.values coordinate = right.values coordinate := + congrFun hstate.values coordinate + cases hrightValue : right.values coordinate with + | some output => + have hleftValue : left.values coordinate = some output := by + rw [hvalue, hrightValue] + simp only [hrightValue, hleftValue] + exact ih (left.clearPending coordinate) (right.clearPending coordinate) + (hstate.clearPending coordinate) + | none => + have hleftValue : left.values coordinate = none := by + rw [hvalue, hrightValue] + simp only [hrightValue, hleftValue] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + let output := table index + change RelTriple + (Option.isSome <$> if right.hitAt index.coordinate output then pure none else + finalizeCleanFromTable remaining (right.complete index.coordinate output) table) + (Option.isSome <$> if left.hitAt index.coordinate output then pure none else + finalizeCleanFromTable remaining (left.complete index.coordinate output) table) + BoolImp + by_cases hrightHit : right.hitAt index.coordinate output + · simp only [hrightHit, ↓reduceIte, map_pure] + exact relTriple_false_any _ + · have hleftHit : ¬left.hitAt index.coordinate output := + hstate.not_hitAt_left_of_right index.coordinate output hleftValue + (by + intro other hcoordinate + have heq : other = index := + OtsSecretIndex.coordinate_injective hcoordinate.symm + subst other + rfl) + hrightHit + simp only [hrightHit, hleftHit, ↓reduceIte] + exact ih (left.complete index.coordinate output) + (right.complete index.coordinate output) (hstate.complete _ output) + | position position => + simp only [map_eq_bind_pure_comp, bind_assoc] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + by_cases hrightHit : right.hitAt (.position position) leftOutput + · simp only [hrightHit, ↓reduceIte, map_pure] + exact relTriple_false_any _ + · have hleftHit : ¬left.hitAt (.position position) leftOutput := + hstate.not_hitAt_left_of_right (.position position) leftOutput hleftValue + (by intro index hcoordinate; cases hcoordinate) hrightHit + simp only [hrightHit, hleftHit, ↓reduceIte] + simpa [map_eq_bind_pure_comp] using + (ih (left.complete (.position position) leftOutput) + (right.complete (.position position) leftOutput) + (hstate.complete _ leftOutput)) + +set_option maxRecDepth 100000 in +theorem exists_successful_finalizeCleanFromTable + (table : OtsSecretIndex → HashOutput) : + ∀ (coordinates : List Coordinate) (state : LazyRevealProbe.State Coordinate), + coordinates.Nodup → + (∀ entry ∈ state.pending, entry.1 ∈ coordinates) → + ¬MissingChainStartHit table (directDeferredContext state) → + (∀ position, state.values (.position position) = none → + (state.pendingAt (.position position)).card < Fintype.card Digest) → + ∃ final, some final ∈ support (finalizeCleanFromTable coordinates state table) + | [], state, _hnodup, _hcovered, _hstart, _hcard => by + exact ⟨(state, table), by simp [finalizeCleanFromTable]⟩ + | coordinate :: remaining, state, hnodup, hcovered, hstart, hcard => by + have hnotMem : coordinate ∉ remaining := (List.nodup_cons.mp hnodup).1 + have nextCovered : ∀ (nextState : LazyRevealProbe.State Coordinate), + nextState.pending ⊆ state.pending → + (∀ entry ∈ nextState.pending, entry.1 ≠ coordinate) → + ∀ entry ∈ nextState.pending, entry.1 ∈ remaining := by + intro nextState hsubset haway entry hentry + have horiginal := hcovered entry (hsubset hentry) + simp only [List.mem_cons] at horiginal + exact horiginal.resolve_left (fun heq ↦ haway entry hentry heq) + have nextStart : ∀ (nextState : LazyRevealProbe.State Coordinate), + nextState.pending ⊆ state.pending → + (∀ other, other ≠ coordinate → nextState.values other = state.values other) → + nextState.values coordinate ≠ none → + ¬MissingChainStartHit table (directDeferredContext nextState) := by + intro nextState hsubset hvalues hcoordinateValue + rintro ⟨index, hvalue, hhit⟩ + by_cases heq : index.coordinate = coordinate + · exact hcoordinateValue (by simpa [directDeferredContext, heq] using hvalue) + · apply hstart + refine ⟨index, ?_, ?_⟩ + · simpa only [directDeferredContext, hvalues index.coordinate heq] using hvalue + · unfold LazyRevealProbe.State.hitAt at hhit ⊢ + rw [LazyRevealProbe.State.mem_pendingAt_iff] + apply hsubset + exact (LazyRevealProbe.State.mem_pendingAt_iff nextState index.coordinate + (truncateHash (table index))).1 (by simpa only [directDeferredContext] using hhit) + cases hvalue : state.values coordinate with + | some output => + simp only [finalizeCleanFromTable, hvalue] + apply exists_successful_finalizeCleanFromTable table remaining + (state.clearPending coordinate) + · exact hnodup.tail + · apply nextCovered + · intro entry hentry + have hentry' : entry ∈ state.pending ∧ entry.1 ≠ coordinate := by + simpa [LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway] using hentry + exact hentry'.1 + · intro entry hentry + have hentry' : entry ∈ state.pending ∧ entry.1 ≠ coordinate := by + simpa [LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway] using hentry + exact hentry'.2 + · apply nextStart (state.clearPending coordinate) + · intro entry hentry + have hentry' : entry ∈ state.pending ∧ entry.1 ≠ coordinate := by + simpa [LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway] using hentry + exact hentry'.1 + · intro other _hne + rfl + · simpa [LazyRevealProbe.State.clearPending, hvalue] + · intro position hmissing + apply (Finset.card_le_card ?_).trans_lt (hcard position (by + simpa [LazyRevealProbe.State.clearPending] using hmissing)) + intro candidate hcandidate + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hcandidate ⊢ + have hentry : (Coordinate.position position, candidate) ∈ state.pending ∧ + Coordinate.position position ≠ coordinate := by + simpa [LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway] using hcandidate + exact hentry.1 + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [finalizeCleanFromTable, hvalue] + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + let output := table index + have hmiss : ¬state.hitAt index.coordinate output := by + intro hhit + apply hstart + exact ⟨index, by simpa [index, OtsSecretIndex.coordinate, + directDeferredContext] using hvalue, hhit⟩ + change ∃ final, some final ∈ support + (if state.hitAt index.coordinate output then pure none else + finalizeCleanFromTable remaining (state.complete index.coordinate output) table) + simp only [hmiss, ↓reduceIte] + apply exists_successful_finalizeCleanFromTable table remaining + (state.complete index.coordinate output) + · exact hnodup.tail + · apply nextCovered + · intro entry hentry + have hentry' : entry ∈ state.pending ∧ entry.1 ≠ index.coordinate := by + simpa [LazyRevealProbe.State.complete, + LazyRevealProbe.State.pendingAway] using hentry + exact hentry'.1 + · intro entry hentry + have hentry' : entry ∈ state.pending ∧ entry.1 ≠ index.coordinate := by + simpa [LazyRevealProbe.State.complete, + LazyRevealProbe.State.pendingAway] using hentry + simpa [index, OtsSecretIndex.coordinate] using hentry'.2 + · apply nextStart (state.complete index.coordinate output) + · intro entry hentry + have hentry' : entry ∈ state.pending ∧ entry.1 ≠ index.coordinate := by + simpa [LazyRevealProbe.State.complete, + LazyRevealProbe.State.pendingAway] using hentry + exact hentry'.1 + · intro other hne + have hne' : other ≠ index.coordinate := by + simpa [index, OtsSecretIndex.coordinate] using hne + simp [LazyRevealProbe.State.complete, Function.update_of_ne hne'] + · simp [LazyRevealProbe.State.complete, index, OtsSecretIndex.coordinate] + · intro position hmissing + have hne : Coordinate.position position ≠ index.coordinate := by + simp [index, OtsSecretIndex.coordinate] + apply (Finset.card_le_card ?_).trans_lt (hcard position (by + simpa [LazyRevealProbe.State.complete, Function.update_of_ne hne] using + hmissing)) + intro candidate hcandidate + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hcandidate ⊢ + have hentry : (Coordinate.position position, candidate) ∈ state.pending ∧ + Coordinate.position position ≠ index.coordinate := by + simpa [LazyRevealProbe.State.complete, + LazyRevealProbe.State.pendingAway] using hcandidate + exact hentry.1 + | position position => + have hcoordinateCard := hcard position hvalue + have hne : state.pendingAt (.position position) ≠ Finset.univ := + (Finset.card_lt_iff_ne_univ _).mp hcoordinateCard + obtain ⟨candidate, hcandidate⟩ : ∃ candidate : Digest, + candidate ∉ state.pendingAt (.position position) := by + by_contra hmissing + push Not at hmissing + exact hne (Finset.eq_univ_of_forall hmissing) + let output := hashOutputOfDigest candidate + have hmiss : ¬state.hitAt (.position position) output := by + simpa [LazyRevealProbe.State.hitAt, output, + truncateHash_hashOutputOfDigest] using hcandidate + simp only [finalizeCleanFromTable, hvalue] + obtain ⟨final, hfinal⟩ := exists_successful_finalizeCleanFromTable table remaining + (state.complete (.position position) output) hnodup.tail (by + apply nextCovered + · intro entry hentry + have hentry' : entry ∈ state.pending ∧ + entry.1 ≠ Coordinate.position position := by + simpa [LazyRevealProbe.State.complete, + LazyRevealProbe.State.pendingAway] using hentry + exact hentry'.1 + · intro entry hentry + have hentry' : entry ∈ state.pending ∧ + entry.1 ≠ Coordinate.position position := by + simpa [LazyRevealProbe.State.complete, + LazyRevealProbe.State.pendingAway] using hentry + exact hentry'.2) (by + apply nextStart (state.complete (.position position) output) + · intro entry hentry + have hentry' : entry ∈ state.pending ∧ + entry.1 ≠ Coordinate.position position := by + simpa [LazyRevealProbe.State.complete, + LazyRevealProbe.State.pendingAway] using hentry + exact hentry'.1 + · intro other hne + simp [LazyRevealProbe.State.complete, Function.update_of_ne hne] + · simp [LazyRevealProbe.State.complete]) (by + intro other hmissing + by_cases heq : other = position + · subst other + simp [LazyRevealProbe.State.complete] at hmissing + · have hcoordinateNe : Coordinate.position other ≠ + Coordinate.position position := by simpa using heq + apply (Finset.card_le_card ?_).trans_lt (hcard other (by + simpa [LazyRevealProbe.State.complete, + Function.update_of_ne hcoordinateNe] using hmissing)) + intro otherCandidate hcandidate + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hcandidate ⊢ + have hentry : (Coordinate.position other, otherCandidate) ∈ state.pending ∧ + Coordinate.position other ≠ Coordinate.position position := by + simpa [LazyRevealProbe.State.complete, + LazyRevealProbe.State.pendingAway] using hcandidate + exact hentry.1) + refine ⟨final, ?_⟩ + rw [mem_support_bind_iff] + exact ⟨output, by simp [LazyRevealProbe.sampleHashOutput, output], by + simpa [hmiss] using hfinal⟩ + +theorem CompletionSafeStateLE.not_missingChainStartHit_left_of_right + {table : OtsSecretIndex → HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hstate : CompletionSafeStateLE table left right) + (hright : ¬MissingChainStartHit table (directDeferredContext right)) : + ¬MissingChainStartHit table (directDeferredContext left) := by + rintro ⟨index, hleftValue, hleftHit⟩ + have hleftValue' : left.values index.coordinate = none := by + simpa only [directDeferredContext] using hleftValue + have hrightValue : right.values index.coordinate = none := by + rw [← hstate.values] + exact hleftValue' + apply hright + refine ⟨index, by simpa only [directDeferredContext] using hrightValue, ?_⟩ + by_contra hrightMiss + exact (hstate.not_hitAt_left_of_right index.coordinate (table index) hleftValue' + (by + intro other hcoordinate + have heq : other = index := OtsSecretIndex.coordinate_injective hcoordinate.symm + subst other + rfl) + hrightMiss) hleftHit + +theorem CompletionSafeStateLE.pendingAt_position_card_lt + {table : OtsSecretIndex → HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hstate : CompletionSafeStateLE table left right) + (position : Position) (hleftValue : left.values (.position position) = none) + (hrightCard : right.pending.card < Fintype.card Digest) : + (left.pendingAt (.position position)).card < Fintype.card Digest := by + have hsubset : left.pendingAt (.position position) ⊆ + right.pendingAt (.position position) := by + intro candidate hcandidate + have hentry : (Coordinate.position position, candidate) ∈ left.pending := + (LazyRevealProbe.State.mem_pendingAt_iff left (.position position) candidate).1 hcandidate + rcases hstate.pending (.position position) candidate hentry with + hright | ⟨output, hvalue, _hmiss⟩ | ⟨index, hcoordinate, _hmiss⟩ + · exact (LazyRevealProbe.State.mem_pendingAt_iff right (.position position) candidate).2 + hright + · rw [hleftValue] at hvalue + simp at hvalue + · cases hcoordinate + have hrightPendingAt : (right.pendingAt (.position position)).card ≤ + right.pending.card := + (right.pendingAt_card_le (.position position)).trans (Finset.card_filter_le _ _) + exact lt_of_le_of_lt (Finset.card_le_card hsubset) + (lt_of_le_of_lt hrightPendingAt hrightCard) + +theorem exists_successful_finishObservedCleanRunFromTable_completionSafe + {table : OtsSecretIndex → HashOutput} + {left right : ObservedCleanRunResult α} + (hstate : CompletionSafeStateLE table left.state right.state) + (htable : left.table = table) + (hrightStart : ¬MissingChainStartHit table (directDeferredContext right.state)) + (hrightCard : right.state.pending.card < Fintype.card Digest) : + ∃ finalResult, some finalResult ∈ support + (finishObservedCleanRunFromTable (some left)) := by + have hleftStart := hstate.not_missingChainStartHit_left_of_right hrightStart + obtain ⟨final, hfinal⟩ := exists_successful_finalizeCleanFromTable table + left.state.coordinates.toList left.state left.state.coordinates.nodup_toList (by + intro entry hentry + simp only [Finset.mem_toList, LazyRevealProbe.State.coordinates, + Finset.mem_union, Finset.mem_image] + exact Or.inr ⟨entry, hentry, rfl⟩) hleftStart (by + intro position hvalue + exact hstate.pendingAt_position_card_lt position hvalue hrightCard) + rw [← htable] at hfinal + rcases final with ⟨finalState, finalTable⟩ + refine ⟨⟨finalState, left.remaining, left.value, finalTable, left.observations⟩, ?_⟩ + unfold finishObservedCleanRunFromTable + rw [mem_support_bind_iff] + exact ⟨some (finalState, finalTable), hfinal, by simp⟩ + +theorem completionSafeStateLE_materialized_of_finalizationContextLE + (table : OtsSecretIndex → HashOutput) (left right : DeferredContext) + (hcontext : FinalizationContextLE table left right) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : (materializedDeferredState left).values = right.state.values) : + CompletionSafeStateLE table (materializedDeferredState left) right.state := by + refine ⟨hvalues, ?_, ?_⟩ + · rw [materializedDeferredState_revealed] + exact hrevealed + intro coordinate candidate hentry + have hsourceEntry : (coordinate, candidate) ∈ left.state.pending := by + simpa [materializedDeferredState_pending] using hentry + cases hresolved : resolvedCompletionValue table left coordinate with + | none => + left + have hsourcePending : candidate ∈ left.state.pendingAt coordinate := + (LazyRevealProbe.State.mem_pendingAt_iff left.state coordinate candidate).2 hsourceEntry + have hrightPending := hcontext.view.pendingLE coordinate hresolved hsourcePending + exact (LazyRevealProbe.State.mem_pendingAt_iff right.state coordinate candidate).1 + hrightPending + | some output => + have hmiss : candidate ≠ truncateHash output := by + intro heq + apply hcontext.view.leftClean coordinate output hresolved + rw [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.mem_pendingAt_iff] + simpa [heq] using hsourceEntry + cases coordinate with + | position position => + right + left + refine ⟨output, ?_, hmiss⟩ + simpa [resolvedCompletionValue, DeferredContext.positionValue, + materializedDeferredState_position] using hresolved + | chainStart lay tree leafIdx chainIdx => + right + right + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + refine ⟨index, ?_, ?_⟩ + · rfl + · have houtput : table index = output := by + simpa [index, resolvedCompletionValue] using hresolved + intro heq + apply hmiss + rw [← houtput] + exact heq + +theorem materializedDeferredState_install_eq_of_value + (context : DeferredContext) (target : Position) (output : HashOutput) + (hvalue : context.values target = some output) : + materializedDeferredState + { context with values := context.values.install target output } = + materializedDeferredState context := by + have hinstall : context.values.install target output = context.values := by + unfold DeferredStructuralValues.install + rw [← hvalue] + exact Function.update_eq_self target context.values + rw [hinstall] + +def ObservedCompletionSafeRel + (table : OtsSecretIndex → HashOutput) + (leftPrefix rightPrefix : List CleanProbeObservation) : + Option (ObservedCleanRunResult α) → Option (ObservedCleanRunResult α) → Prop + | _, none => True + | none, some _ => False + | some left, some right => + left.value = right.value ∧ left.table = right.table ∧ + left.remaining = right.remaining ∧ + (∃ suffix, + left.observations = leftPrefix ++ suffix ∧ + right.observations = rightPrefix ++ suffix) ∧ + CompletionSafeStateLE table left.state right.state + +theorem ObservedCompletionSafeRel.pure + (table : OtsSecretIndex → HashOutput) + (leftPrefix rightPrefix : List CleanProbeObservation) + (leftState rightState : LazyRevealProbe.State Coordinate) + (fuel : Nat) (value : α) + (hstate : CompletionSafeStateLE table leftState rightState) : + ObservedCompletionSafeRel table leftPrefix rightPrefix + (some ⟨leftState, fuel, value, table, leftPrefix⟩) + (some ⟨rightState, fuel, value, table, rightPrefix⟩) := by + exact ⟨rfl, rfl, rfl, ⟨[], by simp, by simp⟩, hstate⟩ + +theorem relTriple_any_pure_none_observedCompletionSafe + (table : OtsSecretIndex → HashOutput) + (leftPrefix rightPrefix : List CleanProbeObservation) + (run : ProbComp (Option (ObservedCleanRunResult α))) : + RelTriple run (pure none : ProbComp (Option (ObservedCleanRunResult α))) + (ObservedCompletionSafeRel table leftPrefix rightPrefix) := by + have hbase := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support + (relTriple_true run (pure none : ProbComp (Option (ObservedCleanRunResult α)))) + apply relTriple_post_mono hbase + intro _ right hrelation + have hright : right = none := by simpa using hrelation.2 + subst right + trivial + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_runObservedCleanFromTable_completionSafe + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (leftPrefix rightPrefix : List CleanProbeObservation) + (leftState rightState : LazyRevealProbe.State Coordinate) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hstate : CompletionSafeStateLE table leftState rightState) : + RelTriple + (runObservedCleanFromTable leftPrefix leftState fuel table computation) + (runObservedCleanFromTable rightPrefix rightState fuel table computation) + (ObservedCompletionSafeRel table leftPrefix rightPrefix) := by + induction computation using OracleComp.inductionOn generalizing + leftPrefix rightPrefix leftState rightState fuel with + | pure value => + rw [runObservedCleanFromTable, OracleComp.construct_pure, + runObservedCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure + (ObservedCompletionSafeRel.pure table leftPrefix rightPrefix leftState rightState fuel + value hstate) + | query_bind query next ih => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + runObservedCleanFromTable, OracleComp.construct_query_bind] + cases query with + | uniform n => + apply relTriple_bind (relTriple_refl (liftM (unifSpec.query n))) + intro leftValue rightValue hvalue + subst rightValue + exact ih leftValue leftPrefix rightPrefix leftState rightState fuel hstate + | hashOutput => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftValue rightValue hvalue + subst rightValue + exact ih leftValue leftPrefix rightPrefix leftState rightState fuel hstate + | ensure coordinate => + exact ih () leftPrefix rightPrefix (leftState.ensure coordinate) + (rightState.ensure coordinate) fuel + (hstate.ensure coordinate) + | probe coordinate candidate => + cases fuel with + | zero => exact relTriple_pure_pure (by trivial) + | succ remaining => + let leftObservation := cleanProbeObservation leftState coordinate candidate + let rightObservation := cleanProbeObservation rightState coordinate candidate + have hobservation : leftObservation = rightObservation := by + unfold leftObservation rightObservation cleanProbeObservation + simp [hstate.values, hstate.revealed] + have hrevealed : coordinate ∈ leftState.revealed ↔ + coordinate ∈ rightState.revealed := by + rw [hstate.revealed] + by_cases hleftRevealed : coordinate ∈ leftState.revealed + · have hrightRevealed : coordinate ∈ rightState.revealed := + hrevealed.mp hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + have hnext := ih () + (leftPrefix ++ [leftObservation]) (rightPrefix ++ [rightObservation]) + leftState rightState remaining hstate + apply relTriple_post_mono hnext + intro leftResult rightResult hresult + cases rightResult with + | none => trivial + | some rightResult => + cases leftResult with + | none => simp [ObservedCompletionSafeRel] at hresult + | some leftResult => + rcases hresult with ⟨hvalue, htable, hremaining, + ⟨suffix, hleft, hright⟩, hnextState⟩ + refine ⟨hvalue, htable, hremaining, ⟨leftObservation :: suffix, ?_, ?_⟩, + hnextState⟩ + · simpa [List.append_assoc] using hleft + · simpa [List.append_assoc, hobservation] using hright + · have hrightRevealed : coordinate ∉ rightState.revealed := by + simpa [hrevealed] using hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + have hnext := ih () + (leftPrefix ++ [leftObservation]) (rightPrefix ++ [rightObservation]) + (leftState.addPending coordinate candidate) + (rightState.addPending coordinate candidate) remaining + (hstate.addPending coordinate candidate) + apply relTriple_post_mono hnext + intro leftResult rightResult hresult + cases rightResult with + | none => trivial + | some rightResult => + cases leftResult with + | none => simp [ObservedCompletionSafeRel] at hresult + | some leftResult => + rcases hresult with ⟨hvalue, htable, hremaining, + ⟨suffix, hleft, hright⟩, hnextState⟩ + refine ⟨hvalue, htable, hremaining, ⟨leftObservation :: suffix, ?_, ?_⟩, + hnextState⟩ + · simpa [List.append_assoc] using hleft + · simpa [List.append_assoc, hobservation] using hright + | peek coordinate => + simp only + have hvalue : leftState.values coordinate = rightState.values coordinate := by + rw [hstate.values] + rw [hvalue] + exact ih (rightState.values coordinate) leftPrefix rightPrefix leftState rightState fuel + hstate + | publish coordinate => + simp only + exact ih () leftPrefix rightPrefix (leftState.publish coordinate) + (rightState.publish coordinate) fuel + (hstate.publish coordinate) + | reveal coordinate => + simp only + have hvalue : leftState.values coordinate = rightState.values coordinate := by + rw [hstate.values] + cases hrightValue : rightState.values coordinate with + | some output => + have hleftValue : leftState.values coordinate = some output := by + rw [hvalue, hrightValue] + simp only [hleftValue, hrightValue] + exact ih output leftPrefix rightPrefix leftState rightState fuel hstate + | none => + have hleftValue : leftState.values coordinate = none := by + rw [hvalue, hrightValue] + simp only [hleftValue, hrightValue] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hrightHit : rightState.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp only [output, hrightHit, ↓reduceIte] + exact relTriple_any_pure_none_observedCompletionSafe table leftPrefix + rightPrefix _ + · have hleftHit : ¬leftState.hitAt + (.chainStart lay tree leafIdx chainIdx) output := + hstate.not_hitAt_left_of_right _ output hleftValue + (by + intro index hcoordinate + rcases index with ⟨otherLay, otherTree, otherLeaf, otherChain⟩ + simp [OtsSecretIndex.coordinate] at hcoordinate + obtain ⟨rfl, rfl, rfl, rfl⟩ := hcoordinate + rfl) + hrightHit + simp only [output, hleftHit, hrightHit, ↓reduceIte] + exact ih output leftPrefix rightPrefix + (leftState.materialize (.chainStart lay tree leafIdx chainIdx) output) + (rightState.materialize (.chainStart lay tree leafIdx chainIdx) output) + fuel (hstate.materialize _ output) + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + by_cases hrightHit : rightState.hitAt (.position position) leftOutput + · simp only [hrightHit, ↓reduceIte] + exact relTriple_any_pure_none_observedCompletionSafe table leftPrefix + rightPrefix _ + · have hleftHit : ¬leftState.hitAt (.position position) leftOutput := + hstate.not_hitAt_left_of_right _ leftOutput hleftValue + (by intro index hcoordinate; cases hcoordinate) hrightHit + simp only [hleftHit, hrightHit, ↓reduceIte] + exact ih leftOutput leftPrefix rightPrefix + (leftState.materialize (.position position) leftOutput) + (rightState.materialize (.position position) leftOutput) fuel + (hstate.materialize _ leftOutput) + +theorem materializedCanonicalContext_values_eq_of_completionSafe + (table : OtsSecretIndex → HashOutput) + {left right : LazyRevealProbe.State Coordinate} + (hstate : CompletionSafeStateLE table left right) : + (materializedCanonicalContext table left).state.values = + (materializedCanonicalContext table right).state.values := by + change publicMaterializedValues table (directDeferredContext left) = + publicMaterializedValues table (directDeferredContext right) + funext coordinate + unfold publicMaterializedValues + have hrevealed : coordinate ∈ left.revealed ↔ coordinate ∈ right.revealed := by + rw [hstate.revealed] + by_cases hleftRevealed : coordinate ∈ left.revealed + · have hrightRevealed : coordinate ∈ right.revealed := hrevealed.mp hleftRevealed + simp only [directDeferredContext, hleftRevealed, hrightRevealed, ↓reduceIte] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => simp [resolvedCompletionValue] + | position position => + simp [resolvedCompletionValue, DeferredContext.positionValue, directDeferredValues, + hstate.values] + · have hrightRevealed : coordinate ∉ right.revealed := by + simpa [hrevealed] using hleftRevealed + simp [directDeferredContext, hleftRevealed, hrightRevealed] + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_observedMaterializedBoundary_completionSafe + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (leftPrefix rightPrefix : List CleanProbeObservation) + (leftState rightState : LazyRevealProbe.State Coordinate) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) + (hstate : CompletionSafeStateLE table leftState rightState) : + RelTriple + (observedMaterializedBoundary parameter root ftsSecret computation leftPrefix leftState + fuel table cache) + (observedMaterializedBoundary parameter root ftsSecret computation rightPrefix rightState + fuel table cache) + (ObservedCompletionSafeRel table leftPrefix rightPrefix) := by + induction computation using OracleComp.inductionOn generalizing + leftPrefix rightPrefix leftState rightState fuel cache with + | pure value => + rw [observedMaterializedBoundary, OracleComp.construct_pure, + observedMaterializedBoundary, OracleComp.construct_pure] + exact relTriple_pure_pure + (ObservedCompletionSafeRel.pure table leftPrefix rightPrefix leftState rightState fuel + (value, cache) hstate) + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind, + observedMaterializedBoundary, OracleComp.construct_query_bind] + have continueAfter + (leftRun rightRun : ProbComp (Option (ObservedCleanRunResult + ((OracleWorld + SigningSpec).Range query × SplitHashCache)))) + (hrun : RelTriple leftRun rightRun + (ObservedCompletionSafeRel table leftPrefix rightPrefix)) : + RelTriple + (leftRun >>= fun result => + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state result.remaining table + result.value.2) + (rightRun >>= fun result => + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state result.remaining table + result.value.2) + (ObservedCompletionSafeRel table leftPrefix rightPrefix) := by + apply relTriple_bind hrun + intro leftResult rightResult hresult + cases rightResult with + | none => + exact relTriple_any_pure_none_observedCompletionSafe table leftPrefix rightPrefix _ + | some rightResult => + cases leftResult with + | none => simp [ObservedCompletionSafeRel] at hresult + | some leftResult => + rcases hresult with ⟨hvalue, htable, hremaining, + ⟨suffix, hleftObservations, hrightObservations⟩, hnextState⟩ + simp only + have houtput : leftResult.value.1 = rightResult.value.1 := + congrArg Prod.fst hvalue + have hnextCache : leftResult.value.2 = rightResult.value.2 := + congrArg Prod.snd hvalue + rw [← houtput, ← hnextCache, ← hremaining] + have hnext := ih leftResult.value.1 leftResult.observations + rightResult.observations leftResult.state rightResult.state + leftResult.remaining leftResult.value.2 hnextState + apply relTriple_post_mono hnext + intro laterLeft laterRight hlater + cases laterRight with + | none => trivial + | some laterRight => + cases laterLeft with + | none => simp [ObservedCompletionSafeRel] at hlater + | some laterLeft => + rcases hlater with ⟨hlaterValue, hlaterTable, hlaterRemaining, + ⟨laterSuffix, hlaterLeft, hlaterRight⟩, hlaterState⟩ + refine ⟨hlaterValue, hlaterTable, hlaterRemaining, + ⟨suffix ++ laterSuffix, ?_, ?_⟩, hlaterState⟩ + · rw [hlaterLeft, hleftObservations, List.append_assoc] + · rw [hlaterRight, hrightObservations, List.append_assoc] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + change Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α at next + simp only + have hstep := relTriple_runObservedCleanFromTable_completionSafe + ((splitUniformImpl n).run cache) leftPrefix rightPrefix leftState rightState fuel + table hstate + convert continueAfter _ _ hstep using 1 <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + | inr input => + change HashOutput → OracleComp (OracleWorld + SigningSpec) α at next + simp only + let leftPublic := materializedCanonicalContext table leftState + let rightPublic := materializedCanonicalContext table rightState + have hpublicValues : leftPublic.state.values = rightPublic.state.values := + materializedCanonicalContext_values_eq_of_completionSafe table hstate + have hplan : purePlanProbingHashQuery parameter input leftPublic.state = + purePlanProbingHashQuery parameter input rightPublic.state := + purePlanProbingHashQuery_eq_of_values_eq hpublicValues parameter input + let plan := purePlanProbingHashQuery parameter input leftPublic.state + have hexecutor : + probingHashQueryAfterRootAwarePublicPlan parameter input leftPublic.state plan = + probingHashQueryAfterRootAwarePublicPlan parameter input rightPublic.state + plan := + probingHashQueryAfterRootAwarePublicPlan_eq_of_values_eq parameter input + hpublicValues plan + rw [← hplan, ← hexecutor] + have hstep := relTriple_runObservedCleanFromTable_completionSafe + ((probingHashQueryAfterRootAwarePublicPlan parameter input leftPublic.state + plan).run cache) + leftPrefix rightPrefix leftState rightState fuel table hstate + convert continueAfter _ _ hstep using 1 <;> + simp only [leftPublic, plan, observedMaterializedBoundary] <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + | inr message => + change Option Signature → OracleComp (OracleWorld + SigningSpec) α at next + simp only + have hstep := relTriple_runObservedCleanFromTable_completionSafe + ((maskedSign parameter root ftsSecret message).run cache) + leftPrefix rightPrefix leftState rightState fuel table hstate + convert continueAfter _ _ hstep using 1 <;> + simp only [observedMaterializedBoundary] <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_indicator_observedMaterializedBoundary_completionSafe_of_left_doomed + (ordinal : Nat) (parameter : PublicParameter) (publicRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (leftState rightState : LazyRevealProbe.State Coordinate) + (fuel : Nat) (cache : SplitHashCache) + (hstate : CompletionSafeStateLE table leftState rightState) + (hleftStarts : StartTableAgrees leftState table) + (hbudget : fuel + rightState.pending.card < Fintype.card Digest) + (_hleftDoomed : ∀ result : ObservedCleanRunResult (α × SplitHashCache), + some result ∈ support + (observedMaterializedBoundary parameter publicRoot ftsSecret computation observations + leftState fuel table cache) → + ¬DeferredCompletable table (directDeferredContext result.state)) : + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret computation observations + rightState fuel table cache) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret computation observations + leftState fuel table cache) + SuccessfulObservedIndicatorRel := by + let leftRun := observedMaterializedBoundary parameter publicRoot ftsSecret computation + observations leftState fuel table cache + let rightRun := observedMaterializedBoundary parameter publicRoot ftsSecret computation + observations rightState fuel table cache + have hbase := relTriple_observedMaterializedBoundary_completionSafe parameter publicRoot + ftsSecret computation observations observations leftState rightState fuel table cache hstate + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result ↦ result ∈ support leftRun) (by + intro result hresult + simpa [leftRun] using hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupported + have hreverse := relTriple_symm hbothSupported + apply relTriple_map + apply relTriple_post_mono hreverse + intro rightResult leftResult hrelation hrightGood + change successfulObservedRootComparisonIndicator table ordinal target + (rightResult, rightRoot) = true at hrightGood + rw [successfulObservedRootComparisonIndicator_eq_true_iff] at hrightGood + change successfulObservedRootComparisonIndicator table ordinal target + (leftResult, rightRoot) = true + rw [successfulObservedRootComparisonIndicator_eq_true_iff] + rcases hrelation with ⟨⟨hcompletion, hleftSupport⟩, hrightSupport⟩ + cases rightResult with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hrightGood + | some rightResult => + cases leftResult with + | none => simp [ObservedCompletionSafeRel] at hcompletion + | some leftResult => + rcases hcompletion with ⟨_hvalue, htable, _hremaining, + ⟨suffix, hleftObservations, hrightObservations⟩, hfinalState⟩ + have hobservations : leftResult.observations = rightResult.observations := by + rw [hleftObservations, hrightObservations] + rcases hrightGood with + ⟨⟨⟨⟨rightFinal, hrightFinish⟩, hrightFirstRoot⟩, + hrightPosition⟩, hrightComparison⟩ + have hleftTable : leftResult.table = table := + (startTableAgrees_of_mem_observedMaterializedBoundary parameter publicRoot ftsSecret + computation observations leftState fuel table cache hleftStarts leftResult + (by simpa [leftRun] using hleftSupport)).1 + have hrightTable : rightResult.table = table := htable.symm.trans hleftTable + have hrightStart : ¬MissingChainStartHit table + (directDeferredContext rightResult.state) := + by + rw [← hrightTable] + exact not_missingChainStartHit_of_mem_finishObservedCleanRunFromTable rightResult + rightFinal hrightFinish + have hrightCard : rightResult.state.pending.card < Fintype.card Digest := by + have hremaining := remaining_add_pending_card_le_of_mem_observedMaterializedBoundary + parameter publicRoot ftsSecret computation observations rightState fuel table cache + rightResult (by simpa [rightRun] using hrightSupport) + omega + obtain ⟨leftFinal, hleftFinish⟩ := + exists_successful_finishObservedCleanRunFromTable_completionSafe hfinalState + hleftTable hrightStart hrightCard + have hleftPosition : + observedFirstLayerRootPosition? ordinal (some leftResult) = some target := by + rw [observedFirstLayerRootPosition?_eq_of_observations_eq ordinal leftResult + rightResult hobservations] + exact hrightPosition + have hleftFirstRoot : + ObservedCleanRunOption.FirstExistingHiddenRootHitAt ordinal (some leftResult) := by + obtain ⟨_selected, _hselected, hrightFirst, _hroot⟩ := hrightFirstRoot + have hleftFirst := firstExistingHiddenHitAt_of_observations_eq rightResult leftResult + ordinal hobservations.symm hrightFirst + exact firstExistingHiddenRootHitAt_of_first_of_position leftResult ordinal target + hleftFirst hleftPosition + have hleftComparison : CandidatesAvoidRoot target rightRoot + (observedPrefixProbes ordinal (some leftResult)) := by + rw [observedPrefixProbes_eq_of_observations_eq ordinal leftResult rightResult + hobservations] + exact hrightComparison + exact ⟨⟨⟨⟨leftFinal, hleftFinish⟩, hleftFirstRoot⟩, + hleftPosition⟩, hleftComparison⟩ + +set_option maxRecDepth 100000 in +theorem selectedHash_goodForRoots + (ordinal : Nat) (parameter : PublicParameter) (publicRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (candidate : Probe) + (hcandidate : rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input left.state) = some candidate) + (hordinal : snapshots.length = ordinal) + (hcontext : FinalizationContextLE table left right) + (hrevealed : left.state.revealed = right.state.revealed) + (hrightMaterialized : right = directDeferredContext right.state) + (hcanonical : CanonicalMaterializedValues table left) + (haligned : SnapshotsObservedAt table snapshots observations) + (hbefore : SnapshotsBefore snapshots left) + (htracked : CleanProbeObservationsTrackedBy observations right.state) + (hnoHit : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hleftCovered : PendingCoveredBy + (snapshots.map PlannedProbeSnapshot.toProbe) left) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hresult : some result ∈ support + (observedMaterializedBoundary parameter publicRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations right.state fuel table cache)) + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result)) : + ∃ output, + let selection : PrivateOrdinalSelection := + ⟨candidate, left, + (snapshots ++ [(⟨candidate, left⟩ : PlannedProbeSnapshot)]).map + PlannedProbeSnapshot.toProbe⟩ + selection.GoodForRoots target output rightRoot ordinal ∧ + PendingCoveredBy (selection.candidates.take ordinal) selection.context := by + have hobservationLength : observations.length = ordinal := + haligned.length_eq.symm.trans hordinal + have hrightValues : + (materializedCanonicalContext table right.state).state.values = left.state.values := by + unfold materializedCanonicalContext + rw [← hrightMaterialized] + exact canonicalized_right_values_eq_of_finalizationContextLE hcontext hrevealed hcanonical + have hplanEq : + purePlanProbingHashQuery parameter input + (materializedCanonicalContext table right.state).state = + purePlanProbingHashQuery parameter input left.state := + purePlanProbingHashQuery_eq_of_values_eq hrightValues parameter input + have hqueryCandidate : rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table right.state).state) = some candidate := by + rw [hplanEq] + exact hcandidate + obtain ⟨⟨⟨⟨_finalResult, _hfinish⟩, + selected, hselected, hfirst, _hroot⟩, hposition⟩, hcomparison⟩ := hgood + have hobservation := + selected_observation_eq_of_mem_observedMaterializedBoundary_hash_query ordinal parameter + publicRoot ftsSecret input next observations right.state fuel table cache candidate + hobservationLength hqueryCandidate result hresult selected hselected + obtain ⟨first, hfirstOrdinal, hfirstHit, _hbeforeFirst⟩ := hfirst + have hfirstSelected : first = selected := + Fin.ext (hfirstOrdinal.trans hselected.symm) + subst first + rw [ExistingHiddenHitAtOrdinal, hobservation] at hfirstHit + obtain ⟨hselectedHidden, output, hselectedValue, hselectedCandidate⟩ := hfirstHit + have hrightValue : right.state.values candidate.coordinate = some output := by + simpa [cleanProbeObservation] using hselectedValue + have hcandidateDigest : truncateHash output = candidate.candidate := by + simpa [cleanProbeObservation] using hselectedCandidate + have hselectedLt : ordinal < result.observations.length := by + rw [← hselected] + exact selected.isLt + have hselectedIndex : + (⟨ordinal, hselectedLt⟩ : Fin result.observations.length) = selected := + Fin.ext hselected.symm + have htargetData : + (result.observations.get selected).coordinate = .position target ∧ IsLayerRoot target := by + simp only [observedFirstLayerRootPosition?, hselectedLt, ↓reduceDIte] at hposition + rw [candidateLayerRootPosition?_eq_some_iff, hselectedIndex] at hposition + exact hposition + have hcandidateCoordinate : candidate.coordinate = .position target := by + rw [hobservation] at htargetData + simpa [cleanProbeObservation] using htargetData.1 + have hcandidateEq : candidate = ⟨.position target, truncateHash output⟩ := by + cases candidate + simp only [Probe.mk.injEq] + exact ⟨hcandidateCoordinate, hcandidateDigest.symm⟩ + have hrightHidden : candidate.coordinate ∉ right.state.revealed := by + simpa [cleanProbeObservation, decide_eq_false_iff_not] using hselectedHidden + have hleftHidden : Coordinate.position target ∉ left.state.revealed := by + rw [← hcandidateCoordinate, hrevealed] + exact hrightHidden + have hleftState : left.state.values (.position target) = none := + canonical_value_none_of_not_revealed hcanonical hleftHidden + have hrightPositionValue : right.state.values (.position target) = some output := by + rw [← hcandidateCoordinate] + exact hrightValue + have hleftPrivate : left.values target = some output := + hcontext.view.privateValue_of_left_hidden_of_right_materialized target output hleftState + hrightPositionValue + have hleftCandidateHidden : candidate.coordinate ∉ left.state.revealed := by + simpa [hcandidateCoordinate] using hleftHidden + have hactualAvoid := candidatesAvoidRoot_of_aligned_tracked table snapshots observations + candidate left right hbefore hcontext hrightMaterialized hnoHit haligned htracked target output + hcandidateEq hleftState hleftPrivate hleftCandidateHidden + have hprefix := observations_prefix_of_mem_observedMaterializedBoundary parameter publicRoot + ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations right.state fuel table cache result hresult + have htake : result.observations.take ordinal = observations := by + obtain ⟨tail, htail⟩ := hprefix + rw [← htail, List.take_append_of_le_length] + · simpa [hobservationLength] + · omega + have hcomparison' : CandidatesAvoidRoot target rightRoot + (snapshots.map PlannedProbeSnapshot.toProbe) := by + simpa [observedPrefixProbes, htake, haligned.map_toProbe_eq] using hcomparison + let selection : PrivateOrdinalSelection := + ⟨candidate, left, + (snapshots ++ [(⟨candidate, left⟩ : PlannedProbeSnapshot)]).map + PlannedProbeSnapshot.toProbe⟩ + refine ⟨output, ?_, ?_⟩ + · refine ⟨hcandidateEq, hleftState, hleftHidden, hleftPrivate, ?_⟩ + intro earlier hearlier + have hearlier' : earlier ∈ snapshots.map PlannedProbeSnapshot.toProbe := by + simpa [selection, hordinal] using hearlier + exact ⟨hactualAvoid earlier hearlier', hcomparison' earlier hearlier'⟩ + · simpa [selection, hordinal] using hleftCovered + +theorem relTriple_indicator_observedMaterializedBoundary_pure_false + (ordinal : Nat) (parameter : PublicParameter) (publicRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) + (value : α) (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) (cache : SplitHashCache) + (hnoHit : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) : + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret + (pure value : OracleComp (OracleWorld + SigningSpec) α) observations state fuel table + cache) + (pure false : ProbComp Bool) + SuccessfulObservedIndicatorRel := by + rw [observedMaterializedBoundary, OracleComp.construct_pure] + simp only [map_pure] + apply relTriple_pure_pure + intro hgood + change successfulObservedRootComparisonIndicator table ordinal target + (some ⟨state, fuel, (value, cache), table, observations⟩, rightRoot) = true at hgood + rw [successfulObservedRootComparisonIndicator_eq_true_iff] at hgood + obtain ⟨⟨⟨⟨_finalResult, _hfinish⟩, + selected, _hselected, hfirst, _hroot⟩, _hposition⟩, _hcomparison⟩ := hgood + obtain ⟨first, _hfirstOrdinal, hfirstHit, _hbefore⟩ := hfirst + exact (hnoHit (observations.get first) (List.get_mem observations first) hfirstHit).elim + +set_option maxRecDepth 100000 in +theorem relTriple_indicator_observedMaterializedBoundary_false_of_ordinal_lt + (ordinal : Nat) (parameter : PublicParameter) (publicRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) (cache : SplitHashCache) + (other : ProbComp Bool) + (hordinal : ordinal < observations.length) + (hnoHit : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) : + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret computation observations + state fuel table cache) + other SuccessfulObservedIndicatorRel := by + let real := + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret computation observations + state fuel table cache + have hbase := relTriple_true real other + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result ↦ result ∈ support real) (fun _ hresult ↦ hresult) + apply relTriple_post_mono hsupported + intro realResult _otherResult hsupport htrue + have hrealSupport : true ∈ support real := by simpa [htrue] using hsupport.2 + unfold real at hrealSupport + rw [support_map] at hrealSupport + obtain ⟨observed, hobserved, hindicator⟩ := hrealSupport + have hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot observed := by + change successfulObservedRootComparisonIndicator table ordinal target + (observed, rightRoot) = true at hindicator + rw [successfulObservedRootComparisonIndicator_eq_true_iff] at hindicator + exact hindicator + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hgood + | some result => + obtain ⟨⟨⟨⟨_finalResult, _hfinish⟩, + _selected, _hselected, hfirst, _hroot⟩, _hposition⟩, _hcomparison⟩ := hgood + obtain ⟨first, hfirstOrdinal, hfirstHit, _hbefore⟩ := hfirst + have hprefix := observations_prefix_of_mem_observedMaterializedBoundary parameter + publicRoot ftsSecret computation observations state fuel table cache result hobserved + let initial : Fin observations.length := ⟨ordinal, hordinal⟩ + have hresultOrdinal : ordinal < result.observations.length := + hordinal.trans_le hprefix.length_le + let resultIndex : Fin result.observations.length := ⟨ordinal, hresultOrdinal⟩ + have hfirstEq : first = resultIndex := Fin.ext hfirstOrdinal + subst first + have hget : observations[initial.val] = result.observations[resultIndex.val] := + hprefix.getElem hordinal + have hinitialHit : (observations.get initial).ExistingHiddenHit := by + simpa [ExistingHiddenHitAtOrdinal, initial, resultIndex, ← hget] using hfirstHit + exact (hnoHit (observations.get initial) (List.get_mem observations initial) + hinitialHit).elim + +set_option maxRecDepth 100000 in +theorem relTriple_observed_finishDirectDelayed_of_firstStopped + (ordinal : Nat) (parameter : PublicParameter) (publicRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) + (next : α → OracleComp (OracleWorld + SigningSpec) RetainedRestResult) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations delayedObservations : List CleanProbeObservation) + (leftResult : DirectWitnessResult (α × SplitHashCache)) + (rightResult : Option (ObservedCleanRunResult (α × SplitHashCache))) + (hrelation : WitnessObservedFirstStoppedStepRel table observations leftResult rightResult) + (hrecursive : ∀ left right, + leftResult = .done left → + rightResult = some (observedResolvedResult observations right) → + OrdinaryMaterializedRunEq table left right → + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret (next right.value.1) + observations right.context.state right.remaining table right.value.2) + (canonicalizeDirectDelayedSelectedRootIndicator table observe left.context left.remaining + (left.value.1, left.value.2) snapshots delayedObservations) + SuccessfulObservedIndicatorRel) : + RelTriple + (match rightResult with + | none => pure false + | some result => + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret (next result.value.1) + result.observations result.state result.remaining table result.value.2) + (finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots delayedObservations leftResult) + SuccessfulObservedIndicatorRel := by + rcases hrelation with hfailed | haligned | hmissing + · subst rightResult + have hbase := relTriple_true (pure false : ProbComp Bool) + (finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots delayedObservations leftResult) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result ↦ result = false) (by intro result hresult; simpa using hresult) + apply relTriple_post_mono hsupported + intro real delayed hrelation hreal + exact (Bool.false_ne_true (hrelation.2.symm.trans hreal)).elim + · obtain ⟨left, right, hleft, hright, hclean⟩ := haligned + subst leftResult + subst rightResult + simp only [finishDirectDelayedSelectedRootIndicator, observedResolvedResult] + exact hrecursive left right rfl rfl hclean + · obtain ⟨right, hright, hdoomed, hmissing⟩ := hmissing + subst rightResult + let realRun := + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret (next right.value.1) + observations right.context.state right.remaining table right.value.2 + let delayedRun := finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots delayedObservations leftResult + have hbase := relTriple_true realRun delayedRun + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result ↦ result ∈ support realRun) (fun _ hresult ↦ hresult) + apply relTriple_post_mono hsupported + intro real delayed hsupport hreal + exfalso + have hrealSupport : true ∈ support realRun := by simpa [hreal] using hsupport.2 + unfold realRun at hrealSupport + rw [support_map] at hrealSupport + obtain ⟨observed, hobserved, hindicator⟩ := hrealSupport + have hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot observed := by + change successfulObservedRootComparisonIndicator table ordinal target + (observed, rightRoot) = true at hindicator + rw [successfulObservedRootComparisonIndicator_eq_true_iff] at hindicator + exact hindicator + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hgood + | some result => + obtain ⟨finalResult, hfinish⟩ := hgood.1.1.1 + exact not_missingChainStartHit_of_successful_observedMaterializedBoundary parameter + publicRoot ftsSecret (next right.value.1) observations right.context.state + right.remaining table right.value.2 result finalResult hobserved hfinish + (by rw [hdoomed.2] at hmissing; exact hmissing) + +set_option maxRecDepth 100000 in +theorem relTriple_bind_observed_finishDirectDelayed_of_firstStopped + (ordinal : Nat) (parameter : PublicParameter) (publicRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) + (next : α → OracleComp (OracleWorld + SigningSpec) RetainedRestResult) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations delayedObservations : List CleanProbeObservation) + (leftStep : ProbComp (DirectWitnessResult (α × SplitHashCache))) + (rightStep : ProbComp (Option (ObservedCleanRunResult (α × SplitHashCache)))) + (hstep : RelTriple leftStep rightStep + (WitnessObservedFirstStoppedStepRel table observations)) + (hrecursive : ∀ left right, + DirectWitnessResult.done left ∈ support leftStep → + some (observedResolvedResult observations right) ∈ support rightStep → + OrdinaryMaterializedRunEq table left right → + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret (next right.value.1) + observations right.context.state right.remaining table right.value.2) + (canonicalizeDirectDelayedSelectedRootIndicator table observe left.context left.remaining + (left.value.1, left.value.2) snapshots delayedObservations) + SuccessfulObservedIndicatorRel) : + RelTriple + (rightStep >>= fun result => + match result with + | none => pure false + | some result => + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret (next result.value.1) + result.observations result.state result.remaining table result.value.2) + (leftStep >>= finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots delayedObservations) + SuccessfulObservedIndicatorRel := by + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hstep + (fun result ↦ result ∈ support leftStep) (fun _ hresult ↦ hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupported + apply relTriple_bind (relTriple_symm hbothSupported) + intro rightResult leftResult hrelation + rcases hrelation with ⟨⟨hrelation, hrightSupport⟩, hleftSupport⟩ + exact relTriple_observed_finishDirectDelayed_of_firstStopped ordinal parameter publicRoot + rightRoot ftsSecret table target next observe snapshots observations delayedObservations + leftResult rightResult hrelation (by + intro left right hleft hright hclean + subst leftResult + subst rightResult + exact hrecursive left right hrightSupport hleftSupport hclean) + +set_option maxRecDepth 100000 in +theorem relTriple_bind_observed_finishDirectDelayed_of_probeFree + (ordinal : Nat) (parameter : PublicParameter) (publicRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) + (next : α → OracleComp (OracleWorld + SigningSpec) RetainedRestResult) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations delayedObservations : List CleanProbeObservation) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftComputation rightComputation : + OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (hbase : RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table leftComputation) + (runDirectResolvedDetailedFromTable right rightFuel table rightComputation) + (DirectWitnessMaterializedStableRunEq table)) + (hleftProbeFree : leftComputation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) + (hrightProbeFree : rightComputation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) + (hleftValid : left.Valid) (hleftCompletable : DeferredCompletable table left) + (hrightMaterialized : right = directDeferredContext right.state) + (htracked : CleanProbeObservationsTrackedBy observations right.state) + (hcovered : CleanProbeObservationsCoverPending observations right.state) + (hnoHit : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hbudget : rightFuel + right.state.pending.card < Fintype.card Digest) + (hrecursive : ∀ leftResult rightResult, + DirectWitnessResult.done leftResult ∈ support + (runDirectResolvedWitnessFromTable left leftFuel table leftComputation) → + some (observedResolvedResult observations rightResult) ∈ support + (runObservedCleanFromTable observations right.state rightFuel table rightComputation) → + OrdinaryMaterializedRunEq table leftResult rightResult → + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret + (next rightResult.value.1) observations rightResult.context.state + rightResult.remaining table rightResult.value.2) + (canonicalizeDirectDelayedSelectedRootIndicator table observe leftResult.context + leftResult.remaining (leftResult.value.1, leftResult.value.2) snapshots + delayedObservations) + SuccessfulObservedIndicatorRel) : + RelTriple + (runObservedCleanFromTable observations right.state rightFuel table rightComputation >>= + fun result => + match result with + | none => pure false + | some result => + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret + (next result.value.1) result.observations result.state result.remaining table + result.value.2) + (runDirectResolvedWitnessFromTable left leftFuel table leftComputation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots delayedObservations) + SuccessfulObservedIndicatorRel := by + have hstep := relTriple_runDirectResolvedWitness_observed_firstStopped_of_probeFree table + leftComputation rightComputation observations left right leftFuel rightFuel hbase + hleftProbeFree hrightProbeFree hleftValid hleftCompletable hrightMaterialized htracked hcovered + hnoHit hbudget + exact relTriple_bind_observed_finishDirectDelayed_of_firstStopped ordinal parameter publicRoot + rightRoot ftsSecret table target next observe snapshots observations + delayedObservations + (runDirectResolvedWitnessFromTable left leftFuel table leftComputation) + (runObservedCleanFromTable observations right.state rightFuel table rightComputation) + hstep hrecursive + +set_option maxRecDepth 100000 in +theorem relTriple_uniform_finishDirectDelayed + (ordinal : Nat) (parameter : PublicParameter) (publicRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) + (n : unifSpec.Domain) + (next : Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) RetainedRestResult) + (observe : DeferredContext → Nat → (Fin (n + 1) × SplitHashCache) → + List PlannedProbeSnapshot → List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations delayedObservations : List CleanProbeObservation) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (htracked : CleanProbeObservationsTrackedBy observations right.state) + (hcovered : CleanProbeObservationsCoverPending observations right.state) + (hnoHit : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hbudget : rightFuel + right.state.pending.card < Fintype.card Digest) + (hrecursive : ∀ leftResult rightResult, + DirectWitnessResult.done leftResult ∈ support + (runDirectResolvedWitnessFromTable left leftFuel table + ((splitUniformImpl n).run leftCache)) → + some (observedResolvedResult observations rightResult) ∈ support + (runObservedCleanFromTable observations right.state rightFuel table + ((splitUniformImpl n).run rightCache)) → + OrdinaryMaterializedRunEq table leftResult rightResult → + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret + (next rightResult.value.1) observations rightResult.context.state + rightResult.remaining table rightResult.value.2) + (canonicalizeDirectDelayedSelectedRootIndicator table observe leftResult.context + leftResult.remaining (leftResult.value.1, leftResult.value.2) snapshots + delayedObservations) + SuccessfulObservedIndicatorRel) : + RelTriple + (runObservedCleanFromTable observations right.state rightFuel table + ((splitUniformImpl n).run rightCache) >>= fun result ↦ + match result with + | none => pure false + | some result => + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret + (next result.value.1) result.observations result.state result.remaining table + result.value.2) + (runDirectResolvedWitnessFromTable left leftFuel table + ((splitUniformImpl n).run leftCache) >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots delayedObservations) + SuccessfulObservedIndicatorRel := by + apply relTriple_bind_observed_finishDirectDelayed_of_probeFree ordinal parameter publicRoot + rightRoot ftsSecret table target next observe snapshots observations delayedObservations + left right leftFuel + rightFuel ((splitUniformImpl n).run leftCache) ((splitUniformImpl n).run rightCache) + · exact (witnessMaterializedStableCouples_splitUniformImpl table n) left right leftFuel + rightFuel leftCache rightCache hcontext hfuel hcache hrevealed hvalues hpublished + hrightMaterialized + · exact splitUniformImpl_probeFree n leftCache + · exact splitUniformImpl_probeFree n rightCache + · exact hcontext.leftValid + · exact hcontext.leftCompletable + · exact hrightMaterialized + · exact htracked + · exact hcovered + · exact hnoHit + · exact hbudget + · exact hrecursive + +set_option maxRecDepth 100000 in +theorem relTriple_sign_finishDirectDelayed + (ordinal : Nat) (parameter : PublicParameter) (publicRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) + (message : Message) + (next : Option Signature → + OracleComp (OracleWorld + SigningSpec) RetainedRestResult) + (observe : DeferredContext → Nat → + (Option Signature × SplitHashCache) → + List PlannedProbeSnapshot → List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations delayedObservations : List CleanProbeObservation) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (htracked : CleanProbeObservationsTrackedBy observations right.state) + (hcovered : CleanProbeObservationsCoverPending observations right.state) + (hnoHit : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hbudget : rightFuel + right.state.pending.card < Fintype.card Digest) + (hrecursive : ∀ leftResult rightResult, + DirectWitnessResult.done leftResult ∈ support + (runDirectResolvedWitnessFromTable left leftFuel table + ((maskedSign parameter publicRoot ftsSecret message).run leftCache)) → + some (observedResolvedResult observations rightResult) ∈ support + (runObservedCleanFromTable observations right.state rightFuel table + ((maskedSign parameter publicRoot ftsSecret message).run rightCache)) → + OrdinaryMaterializedRunEq table leftResult rightResult → + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret + (next rightResult.value.1) observations rightResult.context.state + rightResult.remaining table rightResult.value.2) + (canonicalizeDirectDelayedSelectedRootIndicator table observe leftResult.context + leftResult.remaining (leftResult.value.1, leftResult.value.2) snapshots + delayedObservations) + SuccessfulObservedIndicatorRel) : + RelTriple + (runObservedCleanFromTable observations right.state rightFuel table + ((maskedSign parameter publicRoot ftsSecret message).run rightCache) >>= fun result ↦ + match result with + | none => pure false + | some result => + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret + (next result.value.1) result.observations result.state result.remaining table + result.value.2) + (runDirectResolvedWitnessFromTable left leftFuel table + ((maskedSign parameter publicRoot ftsSecret message).run leftCache) >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots delayedObservations) + SuccessfulObservedIndicatorRel := by + have hresult := relTriple_bind_observed_finishDirectDelayed_of_probeFree ordinal parameter + publicRoot rightRoot ftsSecret table target next observe snapshots observations + delayedObservations left right leftFuel rightFuel + ((maskedSign parameter publicRoot ftsSecret message).run leftCache) + ((maskedSign parameter publicRoot ftsSecret message).run rightCache) + ((witnessMaterializedStableCouples_maskedSign table parameter publicRoot ftsSecret message) + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed hvalues + hpublished hrightMaterialized) + (maskedSign_probeFree parameter publicRoot ftsSecret message leftCache) + (maskedSign_probeFree parameter publicRoot ftsSecret message rightCache) + hcontext.leftValid hcontext.leftCompletable hrightMaterialized htracked hcovered hnoHit hbudget + hrecursive + convert hresult using 1 <;> + try (apply bind_congr; intro result; cases result <;> rfl) + +set_option maxRecDepth 100000 in +theorem relTriple_indicator_observedMaterializedHashContinuation_hidden_notCompletable + (ordinal : Nat) (parameter : PublicParameter) (publicRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) + (input : HashInput) + (plan : PlannedHashQuery) (candidate : Probe) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (rightFuel : Nat) (rightCache : SplitHashCache) + (delayed : ProbComp Bool) + (hcandidate : rootAwareCandidateForPlan? parameter input plan = some candidate) + (hnotSelected : ¬ordinal < (snapshots ++ + [(⟨candidate, left⟩ : PlannedProbeSnapshot)]).length) + (hcontext : FinalizationContextLE table left right) + (hrevealed : left.state.revealed = right.state.revealed) + (hcanonical : CanonicalMaterializedValues table left) + (hrightMaterialized : right = directDeferredContext right.state) + (hhidden : candidate.coordinate ∉ right.state.revealed) + (hnoHit : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (haligned : SnapshotsObservedAt table snapshots observations) + (hbefore : SnapshotsBefore snapshots left) + (htracked : CleanProbeObservationsTrackedBy observations right.state) + (hrightPositive : 0 < rightFuel) + (hbudget : rightFuel + right.state.pending.card < Fintype.card Digest) + (hnotCompletable : ¬DeferredCompletable table + ({ right with state := + right.state.addPending candidate.coordinate candidate.candidate } : DeferredContext)) : + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedHashContinuation parameter publicRoot ftsSecret input plan next + observations right.state rightFuel table rightCache) + delayed SuccessfulObservedIndicatorRel := by + let nextSnapshots := snapshots ++ [(⟨candidate, left⟩ : PlannedProbeSnapshot)] + let source : ProbComp PrivateWitnessSnapshotOutput := pure (none, nextSnapshots) + have hpostCard : + (right.state.addPending candidate.coordinate candidate.candidate).pending.card < + Fintype.card Digest := by + have hcard := LazyRevealProbe.State.pending_card_addPending_le right.state + candidate.coordinate candidate.candidate + omega + have hsource : ∀ output ∈ support source, + PrivateWitnessSnapshotExtends nextSnapshots output := by + intro output houtput + simp [source] at houtput + subst output + simp [PrivateWitnessSnapshotExtends] + have hstopped := + relTriple_source_observedMaterializedHashContinuation_firstStopped_of_notCompletable + parameter publicRoot ftsSecret input plan candidate next source snapshots observations left + right (rightFuel - 1) table rightCache hcandidate hcontext hrevealed hcanonical + hrightMaterialized hhidden hnoHit haligned hbefore htracked (by + intro output houtput + exact hsource output houtput) hpostCard hnotCompletable + have hstoppedSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hstopped + (fun output ↦ output ∈ support source) (fun _ houtput ↦ houtput) + have hsemantic : RelTriple + (observedMaterializedHashContinuation parameter publicRoot ftsSecret input plan next + observations right.state (rightFuel - 1 + 1) table rightCache) + source + (fun observed sourceOutput ↦ + EqRel Bool + (successfulObservedRootComparisonIndicator table ordinal target + (observed, rightRoot)) false) := by + apply relTriple_post_mono (relTriple_symm hstoppedSupported) + intro observed sourceOutput hrelation + rw [EqRel, Bool.eq_false_iff] + intro htrue + have hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot observed := by + rw [successfulObservedRootComparisonIndicator_eq_true_iff] at htrue + exact htrue + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hgood + | some result => + have hsourceOutput : sourceOutput = (none, nextSnapshots) := by + simpa [source] using hrelation.2 + subst sourceOutput + obtain ⟨⟨⟨⟨finalResult, hfinish⟩, + selected, hselected, hfirst, hroot⟩, _hposition⟩, _hcomparison⟩ := hgood + have hrootAll : ∀ other : Fin result.observations.length, + other.val = ordinal → (result.observations.get other).toProbe.IsLayerRoot := by + intro other hother + have heq : other = selected := Fin.ext (hother.trans hselected.symm) + subst other + exact hroot + have hselectedSource := hrelation.1.selected_of_successful_firstRoot finalResult hfinish + ordinal hfirst hrootAll + obtain ⟨sourceSelected, hselectedOrdinal, _hwitness⟩ := hselectedSource + apply hnotSelected + simpa [nextSnapshots, hselectedOrdinal] using sourceSelected.isLt + have hmapped := relTriple_map + (f := successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) + (g := fun _ : PrivateWitnessSnapshotOutput ↦ false) + hsemantic + have hmappedFalse : RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedHashContinuation parameter publicRoot ftsSecret input plan next + observations right.state (rightFuel - 1 + 1) table rightCache) + (pure false : ProbComp Bool) (EqRel Bool) := by + simpa [source] using hmapped + have hfalse : RelTriple (pure false : ProbComp Bool) delayed + SuccessfulObservedIndicatorRel := by + have hbase := relTriple_true (pure false : ProbComp Bool) delayed + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result ↦ result = false) (by intro result hresult; simpa using hresult) + apply relTriple_post_mono hsupported + intro actual _delayed hrelation hactual + exact (Bool.false_ne_true (hrelation.2.symm.trans hactual)).elim + have hglued := SphincsSecurity.relTriple_trans_exists hmappedFalse hfalse + have hresult : RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedHashContinuation parameter publicRoot ftsSecret input plan next + observations right.state (rightFuel - 1 + 1) table rightCache) + delayed SuccessfulObservedIndicatorRel := by + apply relTriple_post_mono hglued + intro actual delayedResult hrelation + obtain ⟨middle, hactual, hmiddle⟩ := hrelation + exact hactual ▸ hmiddle + have hrightFuel : rightFuel - 1 + 1 = rightFuel := by omega + simpa [hrightFuel] using hresult + +theorem relTriple_indicator_observed_directDelayed + (ordinal : Nat) (parameter : PublicParameter) (publicRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) + (hroot : IsLayerRoot target) + (computation : OracleComp (OracleWorld + SigningSpec) RetainedRestResult) + (snapshots : List PlannedProbeSnapshot) + (observations delayedObservations : List CleanProbeObservation) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) (q bound : Nat) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, publicRoot, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) computation).IsQueryBoundP + (fun query => query matches Sum.inr _) bound) + (hcontext : FinalizationContextLE table left right) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hchainValid : ChainState.ValidFor (fun _ => True) right.state) + (hcanonical : CanonicalMaterializedValues table left) + (haligned : SnapshotsObservedAt table snapshots observations) + (hbefore : SnapshotsBefore snapshots left) + (htracked : CleanProbeObservationsTrackedBy observations right.state) + (hcovered : CleanProbeObservationsCoverPending observations right.state) + (hnoHit : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hdelayedProbes : delayedObservations.map CleanProbeObservation.toProbe = + snapshots.map PlannedProbeSnapshot.toProbe) + (hdelayedNoHit : ∀ observation ∈ delayedObservations, + ¬observation.ExistingHiddenHit) + (hleftCovered : PendingCoveredBy + (snapshots.map PlannedProbeSnapshot.toProbe) left) + (hleftLower : bound ≤ leftFuel) (hleftUpper : leftFuel ≤ q) + (hrightLower : q + bound ≤ rightFuel) + (hbudget : rightFuel + right.state.pending.card < Fintype.card Digest) : + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret computation observations + right.state rightFuel table rightCache) + (directDelayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret table target + rightRoot computation snapshots delayedObservations left leftFuel leftCache) + SuccessfulObservedIndicatorRel := by + induction computation using OracleComp.inductionOn generalizing + snapshots observations delayedObservations left right leftFuel rightFuel leftCache + rightCache bound with + | pure value => + by_cases hselected : ordinal < snapshots.length + · have hordinal : ordinal < observations.length := by + rw [← haligned.length_eq] + exact hselected + exact relTriple_indicator_observedMaterializedBoundary_false_of_ordinal_lt ordinal + parameter publicRoot rightRoot ftsSecret table target (pure value) observations + right.state rightFuel rightCache + (directDelayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret table target + rightRoot (pure value) snapshots delayedObservations left leftFuel leftCache) + hordinal hnoHit + · rw [directDelayedSelectedRootIndicator, OracleComp.construct_pure] + simp only [hselected, ↓reduceDIte] + exact relTriple_indicator_observedMaterializedBoundary_pure_false ordinal parameter + publicRoot rightRoot ftsSecret table target value observations right.state rightFuel + rightCache hnoHit + | query_bind query next ih => + by_cases hselected : ordinal < snapshots.length + · have hordinal : ordinal < observations.length := by + rw [← haligned.length_eq] + exact hselected + exact relTriple_indicator_observedMaterializedBoundary_false_of_ordinal_lt ordinal + parameter publicRoot rightRoot ftsSecret table target + (liftM (OracleSpec.query query) >>= next) observations right.state rightFuel rightCache + (directDelayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret table target + rightRoot (liftM (OracleSpec.query query) >>= next) snapshots delayedObservations left + leftFuel leftCache) + hordinal hnoHit + · cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [observedMaterializedBoundary, OracleComp.construct_query_bind, + directDelayedSelectedRootIndicator, OracleComp.construct_query_bind] + simp only [hselected, ↓reduceDIte] + let observe : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool := + fun nextContext remaining value laterSnapshots laterObservations => + directDelayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret + table target rightRoot (next value.1) laterSnapshots laterObservations + nextContext remaining value.2 + apply relTriple_uniform_finishDirectDelayed ordinal parameter publicRoot + rightRoot ftsSecret table target n next observe snapshots observations + delayedObservations left + right leftFuel rightFuel leftCache rightCache hcontext (by omega) hcache + hrevealed hvalues hpublished hrightMaterialized htracked hcovered hnoHit hbudget + intro nextLeft nextRight hleftSupport hrightSupport hclean + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hleftCompletable : DeferredCompletable table canonical := + hcanonicalRun.context_le.leftCompletable + have hleftFuelPreserved : leftFuel ≤ nextLeft.remaining := by + have hfuel := fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table nextLeft 0 + (splitUniformImpl_probeFree n leftCache) hleftSupport + omega + have hrightFuelPreserved : rightFuel ≤ nextRight.remaining := by + have hfuel := fuel_le_remaining_add_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run rightCache) observations right.state rightFuel table + (observedResolvedResult observations nextRight) 0 + (splitUniformImpl_probeFree n rightCache) hrightSupport + simpa [observedResolvedResult] using hfuel + have hleftRemainingUpper : nextLeft.remaining ≤ leftFuel := + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table nextLeft (by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩) + have hnextTracked : CleanProbeObservationsTrackedBy observations + nextRight.context.state := by + simpa [observedResolvedResult] using + (cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run rightCache) observations right.state rightFuel table + htracked (observedResolvedResult observations nextRight) hrightSupport) + have hnextCovered : CleanProbeObservationsCoverPending observations + nextRight.context.state := by + simpa [observedResolvedResult] using + (cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run rightCache) observations right.state rightFuel table + hcovered (observedResolvedResult observations nextRight) hrightSupport) + have hnextBudget : nextRight.remaining + + nextRight.context.state.pending.card < Fintype.card Digest := by + have hremaining := remaining_add_pending_card_le_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run rightCache) observations right.state rightFuel table + (observedResolvedResult observations nextRight) hrightSupport + simpa [observedResolvedResult] using hremaining.trans_lt hbudget + have hnextBefore : SnapshotsBefore snapshots canonical := + (hbefore.of_done_runDirectResolvedWitnessFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table nextLeft + hleftSupport).canonicalize_right table + have hnextLeftCovered : PendingCoveredBy + (snapshots.map PlannedProbeSnapshot.toProbe) canonical := by + apply (pendingCoveredBy_canonicalize_iff table + (snapshots.map PlannedProbeSnapshot.toProbe) nextLeft.context).2 + apply hleftCovered.of_subset + apply pending_subset_of_done_runDirectResolvedDetailedFromTable_of_probeFree + ((splitUniformImpl n).run leftCache) left leftFuel table nextLeft + (splitUniformImpl_probeFree n leftCache) + rw [← map_erase_runDirectResolvedWitnessFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩ + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hnextChainValid : ChainState.ValidFor (fun _ => True) + nextRight.context.state := by + have hnext := chainValid_of_mem_runObservedCleanFromTable + (splitUniformImpl n) observations right.state rightFuel table rightCache + (observedResolvedResult observations nextRight) + (preservesChainValid_splitUniformImpl (fun _ => True) n) hchainValid + hrightSupport + simpa [observedResolvedResult] using hnext + unfold canonicalizeDirectDelayedSelectedRootIndicator + simp only [canonical, hnotPrivate, ↓reduceDIte, hclean.left_published, + ↓reduceIte, hleftCompletable] + rw [← hclean.value_eq] + simpa [observe] using + (ih nextLeft.value.1 snapshots observations delayedObservations canonical + nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 bound + (hbound.2 nextLeft.value.1) hcanonicalRun.context_le hcanonicalRun.cache_eq + hcanonicalRun.revealed_eq hcanonicalRun.values_le hcanonicalRun.left_published + hcanonicalRun.right_materialized hnextChainValid + (canonicalizeMaterializedValues_canonical table nextLeft.context + hclean.context_le.view.leftConsistent) + haligned hnextBefore hnextTracked hnextCovered hnoHit hdelayedProbes + hdelayedNoHit + hnextLeftCovered + (by omega) (by omega) (by omega) hnextBudget) + | inr input => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + change HashOutput → OracleComp (OracleWorld + SigningSpec) + RetainedRestResult at next + have hrightValues : + (materializedCanonicalContext table right.state).state.values = + left.state.values := by + unfold materializedCanonicalContext + rw [← hrightMaterialized] + exact canonicalized_right_values_eq_of_finalizationContextLE hcontext hrevealed + hcanonical + have hplanEq : + purePlanProbingHashQuery parameter input + (materializedCanonicalContext table right.state).state = + purePlanProbingHashQuery parameter input left.state := + purePlanProbingHashQuery_eq_of_values_eq hrightValues parameter input + let plan := purePlanProbingHashQuery parameter input left.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextSnapshots := appendPlannedSnapshot snapshots candidate? left + by_cases hnowSelected : ordinal < nextSnapshots.length + · have hcandidateExists : ∃ candidate, candidate? = some candidate := by + cases hcandidate : candidate? with + | none => + exfalso + apply hselected + simpa [nextSnapshots, hcandidate, appendPlannedSnapshot] using hnowSelected + | some candidate => exact ⟨candidate, rfl⟩ + obtain ⟨candidate, hcandidate⟩ := hcandidateExists + have hnextSnapshots : nextSnapshots = + snapshots ++ [(⟨candidate, left⟩ : PlannedProbeSnapshot)] := by + simp [nextSnapshots, hcandidate, appendPlannedSnapshot] + have hordinal : snapshots.length = ordinal := by + rw [hnextSnapshots] at hnowSelected + simp only [List.length_append, List.length_singleton] at hnowSelected + omega + subst ordinal + have hget : nextSnapshots.get ⟨snapshots.length, hnowSelected⟩ = + (⟨candidate, left⟩ : PlannedProbeSnapshot) := by + simp [nextSnapshots, appendPlannedSnapshot, hcandidate, List.get_eq_getElem] + let selection : PrivateOrdinalSelection := + ⟨candidate, left, + (snapshots ++ [(⟨candidate, left⟩ : PlannedProbeSnapshot)]).map + PlannedProbeSnapshot.toProbe⟩ + have hselectedEq : + directDelayedSelectedRootIndicator snapshots.length parameter publicRoot ftsSecret + table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots delayedObservations left leftFuel leftCache = + delayedSelectedRootIndicator snapshots.length parameter publicRoot ftsSecret table + target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + delayedObservations selection leftFuel leftCache := by + rw [directDelayedSelectedRootIndicator_hash_eq_selected snapshots.length parameter + publicRoot ftsSecret table target rightRoot input next snapshots + delayedObservations left leftFuel leftCache hselected + (by simpa [nextSnapshots] using hnowSelected)] + rw [show (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input left.state)) left).get + ⟨snapshots.length, by simpa [nextSnapshots] using hnowSelected⟩ = + (⟨candidate, left⟩ : PlannedProbeSnapshot) by + simpa [nextSnapshots] using hget] + have hcandidateRaw : rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input left.state) = some candidate := by + simpa [candidate?, plan] using hcandidate + simp [selection, hcandidateRaw, appendPlannedCandidate] + rw [hselectedEq] + by_cases hgoodExists : ∃ output, + selection.GoodForRoots target output rightRoot snapshots.length ∧ + PendingCoveredBy (selection.candidates.take snapshots.length) selection.context + · obtain ⟨output, hselectionGood, hselectionCovered⟩ := hgoodExists + have hmaterializedValues : + (materializedDeferredState left).values = right.state.values := + materializedDeferredState_values_eq_of_chainValid table left right hcontext + hrevealed hvalues hpublished hchainValid hrightMaterialized + have hcompletionState : CompletionSafeStateLE table + (materializedDeferredState left) right.state := + completionSafeStateLE_materialized_of_finalizationContextLE table left right + hcontext hrevealed hmaterializedValues + have hinstalledState : + materializedDeferredState + { selection.context with + values := selection.context.values.install target output } = + materializedDeferredState left := by + simpa [selection] using + (materializedDeferredState_install_eq_of_value left target output + hselectionGood.2.2.2.1) + have hcompletionInstalled : CompletionSafeStateLE table + (materializedDeferredState + { selection.context with + values := selection.context.values.install target output }) + right.state := by + rw [hinstalledState] + exact hcompletionState + let resolved : DeferredResolution := + ⟨{ state := selection.context.state.clearPending (.position target) + values := selection.context.values }, output⟩ + have hresolve : resolveDeferredPositionValue target selection.context = + pure (some resolved) := by + simpa [resolved] using + resolveDeferredPositionValue_eq_good_output hselectionGood + hselectionCovered + have hresolved : some resolved ∈ support + (resolveDeferredPositionValue target selection.context) := by + rw [hresolve] + simp + let resolvedState := materializedDeferredState resolved.toDeferredContext + have hsafe : SafeTargetPendingLE target output resolvedState + (materializedDeferredState + { selection.context with + values := selection.context.values.install target output }) := by + exact safeTargetPendingLE_of_resolveDeferredPositionValue hselectionGood + hselectionCovered resolved hresolved + have hcompletionResolved : CompletionSafeStateLE table resolvedState + right.state := by + refine ⟨hsafe.values.trans hcompletionInstalled.values, + hsafe.revealed.trans hcompletionInstalled.revealed, ?_⟩ + intro coordinate digest hentry + rcases hcompletionInstalled.pending coordinate digest + (hsafe.pending hentry) with hright | hknown | hchain + · exact Or.inl hright + · right + left + obtain ⟨known, hknownValue, hmiss⟩ := hknown + refine ⟨known, ?_, hmiss⟩ + rw [hsafe.values] + exact hknownValue + · exact Or.inr (Or.inr hchain) + have hresolvedStarts : StartTableAgrees resolvedState table := by + intro index stored hstored + apply hcontext.view.rightStarts index stored + rw [← hcompletionResolved.values] + exact hstored + have hresolvedPublicValues : + (materializedCanonicalContext table resolvedState).state.values = + left.state.values := by + calc + _ = (materializedCanonicalContext table right.state).state.values := + materializedCanonicalContext_values_eq_of_completionSafe table + hcompletionResolved + _ = left.state.values := hrightValues + have hresolvedPlan : + purePlanProbingHashQuery parameter input + (materializedCanonicalContext table resolvedState).state = plan := by + simpa [plan] using + (purePlanProbingHashQuery_eq_of_values_eq hresolvedPublicValues parameter + input) + have hresolvedCandidate : rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table resolvedState).state) = + some candidate := by + rw [hresolvedPlan] + simpa [candidate?, plan] using hcandidate + have hcandidateEq : candidate = + ⟨.position target, truncateHash output⟩ := by + simpa [selection] using hselectionGood.1 + have hresolvedHidden : candidate.coordinate ∉ resolvedState.revealed := by + rw [hcandidateEq] + simpa [resolvedState, resolved, materializedDeferredState_revealed, + LazyRevealProbe.State.clearPending] using + hselectionGood.2.2.1 + have hresolvedValue : resolvedState.values candidate.coordinate = + some output := by + rw [hcandidateEq] + exact hsafe.target_value + have hresolvedDoomed : DoomedResolvedContext table + (directDeferredContext + (resolvedState.addPending candidate.coordinate candidate.candidate)) := by + rw [hcandidateEq] + exact doomed_direct_addPending_of_stored resolvedState (.position target) + output hsafe.target_value hresolvedStarts + have hboundPositive : 0 < bound := by + rcases hbound.1 with hnot | hpositive + · exact (hnot (by simp)).elim + · exact hpositive + have hrightPositive : 0 < rightFuel := by omega + have hleftDoomed : ∀ result : ObservedCleanRunResult + (RetainedRestResult × SplitHashCache), + some result ∈ support + (observedMaterializedBoundary parameter publicRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations resolvedState rightFuel table rightCache) → + ¬DeferredCompletable table + (directDeferredContext result.state) := by + intro result hresult + rw [observedMaterializedBoundary_hash_query_bind] at hresult + change some result ∈ support + (observedMaterializedHashContinuation parameter publicRoot ftsSecret input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table resolvedState).state) + next observations resolvedState rightFuel table rightCache) at hresult + have hstopped := stopped_data_of_mem_observedMaterializedHashContinuation + parameter publicRoot ftsSecret input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table resolvedState).state) + candidate next observations resolvedState (rightFuel - 1) table rightCache + result hresolvedCandidate hresolvedHidden hresolvedDoomed (by + simpa [Nat.sub_add_cancel hrightPositive] using hresult) + exact hstopped.2.1.2.2 + have hsameFuel := + relTriple_indicator_observedMaterializedBoundary_completionSafe_of_left_doomed + snapshots.length parameter publicRoot rightRoot ftsSecret table target + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations resolvedState right.state rightFuel rightCache + hcompletionResolved hresolvedStarts hbudget hleftDoomed + rw [delayedSelectedRootIndicator, hresolve] + simp only [pure_bind] + let selectedComputation := + liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next + have hselectedBound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, publicRoot, + tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + selectedComputation).IsQueryBoundP + (fun query => query matches Sum.inr _) bound := by + unfold selectedComputation + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] + exact hbound + have hcacheBridge := + relTriple_indicator_observedMaterializedBoundary_ordinaryCache + snapshots.length parameter publicRoot rightRoot ftsSecret table target + selectedComputation observations delayedObservations resolvedState rightFuel + rightCache leftCache hcache.symm haligned.length_eq.symm + (haligned.map_toProbe_eq.symm.trans hdelayedProbes.symm) hnoHit + hdelayedNoHit + have hfuelBridge := + relTriple_indicator_observedMaterializedBoundary_fuel_of_isQueryBoundP + snapshots.length parameter publicRoot rightRoot ftsSecret table target + selectedComputation delayedObservations resolvedState rightFuel leftFuel + bound leftCache hselectedBound hresolvedStarts (by omega) hleftLower + have hstateCache := SphincsSecurity.relTriple_trans_exists hsameFuel hcacheBridge + have hstateCache' : RelTriple + ((successfulObservedRootComparisonIndicator table snapshots.length target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret + selectedComputation observations right.state rightFuel table rightCache) + ((successfulObservedRootComparisonIndicator table snapshots.length target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret + selectedComputation delayedObservations resolvedState rightFuel table + leftCache) + SuccessfulObservedIndicatorRel := by + apply relTriple_post_mono hstateCache + intro actual delayed hrelation hactual + obtain ⟨middle, hfirst, hsecond⟩ := hrelation + exact hsecond (hfirst hactual) + have hfinal := SphincsSecurity.relTriple_trans_exists hstateCache' hfuelBridge + have hresolvedAvoid : CandidatesAvoidRoots target + (truncateHash resolved.output) rightRoot + (selection.candidates.take snapshots.length) := by + simpa [resolved] using hselectionGood.2.2.2.2 + rw [if_pos hresolvedAvoid] + apply relTriple_post_mono hfinal + intro actual delayed hrelation hactual + obtain ⟨middle, hfirst, hsecond⟩ := hrelation + simpa [selectedComputation, resolvedState] using + hsecond (hfirst hactual) + · let real := + (successfulObservedRootComparisonIndicator table snapshots.length target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations right.state rightFuel table rightCache + let delayed := delayedSelectedRootIndicator snapshots.length parameter publicRoot + ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + delayedObservations selection leftFuel leftCache + have hbase := relTriple_true real delayed + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + hbase (fun result ↦ result ∈ support real) (fun _ hresult ↦ hresult) + apply relTriple_post_mono hsupported + intro actual _delayed hrelation hactual + have hactualSupport : true ∈ support real := by + simpa [hactual] using hrelation.2 + unfold real at hactualSupport + rw [support_map] at hactualSupport + obtain ⟨result, hresult, hindicator⟩ := hactualSupport + have hgood : + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table snapshots.length target rightRoot result := by + change successfulObservedRootComparisonIndicator table snapshots.length target + (result, rightRoot) = true at hindicator + rw [successfulObservedRootComparisonIndicator_eq_true_iff] at hindicator + exact hindicator + cases result with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + at hgood + | some result => + obtain ⟨output, houtputGood, houtputCovered⟩ := + selectedHash_goodForRoots snapshots.length parameter publicRoot rightRoot + ftsSecret table target input next snapshots observations left right + rightFuel rightCache candidate + (by simpa [candidate?, plan] using hcandidate) rfl hcontext + hrevealed hrightMaterialized hcanonical haligned hbefore htracked + hnoHit hleftCovered result hresult hgood + exact (hgoodExists ⟨output, by simpa [selection] using houtputGood, + by simpa [selection] using houtputCovered⟩).elim + · rw [directDelayedSelectedRootIndicator_hash_eq_not_selected ordinal parameter + publicRoot ftsSecret table target rightRoot input next snapshots + delayedObservations left leftFuel leftCache hselected + (by simpa [nextSnapshots, candidate?, plan] using hnowSelected)] + rw [observedMaterializedBoundary_hash_query_bind] + simp only + rw [hplanEq] + have hpublicExecutor : + probingHashQueryAfterRootAwarePublicPlan parameter input + (materializedCanonicalContext table right.state).state plan = + probingHashQueryAfterRootAwarePublicPlan parameter input left.state plan := + probingHashQueryAfterRootAwarePublicPlan_eq_of_values_eq parameter input + hrightValues plan + rw [hpublicExecutor] + let delayedNextObservations := observationsAfterCandidate delayedObservations + (materializedDeferredState left) candidate? + let leftStep : ProbComp (DirectWitnessResult + (HashOutput × SplitHashCache)) := + runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterRootAwarePlan parameter input plan).run leftCache) + let rightStep : ProbComp (Option (ObservedCleanRunResult + (HashOutput × SplitHashCache))) := + runObservedCleanFromTable observations right.state rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input left.state plan).run + rightCache) + have hrealEq : + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + (rightStep >>= fun result => + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter publicRoot ftsSecret + (next result.value.1) result.observations result.state + result.remaining table result.value.2)) = + (rightStep >>= fun result => + match result with + | none => pure false + | some result => + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret + (next result.value.1) result.observations result.state + result.remaining table result.value.2) := by + rw [map_bind] + apply bind_congr + intro result + cases result with + | none => + simp [successfulObservedRootComparisonIndicator, + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + | some result => rfl + have hrealPointwise (result : Option (ObservedCleanRunResult + (HashOutput × SplitHashCache))) : + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter publicRoot ftsSecret + (next result.value.1) result.observations result.state + result.remaining table result.value.2) = + (match result with + | none => pure false + | some result => + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret + (next result.value.1) result.observations result.state + result.remaining table result.value.2) := by + cases result with + | none => + simp [successfulObservedRootComparisonIndicator, + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + | some result => rfl + rw [map_bind] + let observe : DeferredContext → Nat → (HashOutput × SplitHashCache) → + List PlannedProbeSnapshot → List CleanProbeObservation → ProbComp Bool := + fun nextContext remaining value laterSnapshots laterObservations => + directDelayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret + table target rightRoot (next value.1) laterSnapshots laterObservations + nextContext remaining value.2 + have hcontextDirect : + FinalizationContextLE table left (directDeferredContext right.state) := by + rwa [← hrightMaterialized] + have houter : IsOuterHash (.inl (.inr input)) := by simp [IsOuterHash] + have hboundPositive : 0 < bound := by + rcases hbound.1 with hnot | hpositive + · exact (hnot (by simp)).elim + · exact hpositive + have hleftPositive : 0 < leftFuel := by omega + have hstrictFuel : leftFuel < rightFuel := by omega + have hcontinue (actualNextObservations : List CleanProbeObservation) + (hnextAligned : SnapshotsObservedAt table nextSnapshots actualNextObservations) + (hnextNoHit : ∀ observation ∈ actualNextObservations, + ¬observation.ExistingHiddenHit) + (hnextDelayedProbes : delayedNextObservations.map + CleanProbeObservation.toProbe = + nextSnapshots.map PlannedProbeSnapshot.toProbe) + (hnextDelayedNoHit : ∀ observation ∈ delayedNextObservations, + ¬observation.ExistingHiddenHit) + (hlocal : RelTriple leftStep rightStep + (WitnessObservedFirstStoppedStepRel table actualNextObservations)) : + RelTriple + (rightStep >>= fun result => + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter publicRoot ftsSecret + (next result.value.1) result.observations result.state + result.remaining table result.value.2) + (leftStep >>= finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + nextSnapshots delayedNextObservations) + SuccessfulObservedIndicatorRel := by + let middle : ProbComp Bool := rightStep >>= fun result => + match result with + | none => pure false + | some result => + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret + (next result.value.1) result.observations result.state + result.remaining table result.value.2 + have hfinish : RelTriple middle + (leftStep >>= finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + nextSnapshots delayedNextObservations) + SuccessfulObservedIndicatorRel := by + unfold middle + convert (relTriple_bind_observed_finishDirectDelayed_of_firstStopped + (α := HashOutput) ordinal parameter publicRoot rightRoot ftsSecret table + target next observe nextSnapshots actualNextObservations + delayedNextObservations leftStep rightStep hlocal (by + intro nextLeft nextRight hleftSupport hrightSupport hclean + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hleftCompletable : DeferredCompletable table canonical := + hcanonicalRun.context_le.leftCompletable + have hleftFuelSpent : leftFuel ≤ nextLeft.remaining + 1 := + fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterRootAwarePlan parameter input plan).run leftCache) left + leftFuel table nextLeft 1 + (probingHashQueryAfterRootAwarePlan_isProbeBound parameter input plan + leftCache) + hleftSupport + have hrightFuelSpent : rightFuel ≤ nextRight.remaining + 1 := by + have hfuel := fuel_le_remaining_add_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input left.state + plan).run rightCache) observations right.state rightFuel table + (observedResolvedResult actualNextObservations nextRight) 1 + (probingHashQueryAfterRootAwarePublicPlan_isProbeBound_one parameter + input left.state plan rightCache) hrightSupport + simpa [observedResolvedResult] using hfuel + have hleftRemainingUpper : nextLeft.remaining ≤ leftFuel := + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((probingHashQueryAfterRootAwarePlan parameter input plan).run leftCache) left + leftFuel table nextLeft (by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterRootAwarePlan parameter input plan).run leftCache) + left leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩) + have hnextTracked : CleanProbeObservationsTrackedBy actualNextObservations + nextRight.context.state := by + simpa [rightStep, observedResolvedResult] using + (cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input left.state + plan).run rightCache) observations right.state rightFuel table + htracked (observedResolvedResult actualNextObservations nextRight) + hrightSupport) + have hnextCovered : CleanProbeObservationsCoverPending + actualNextObservations nextRight.context.state := by + simpa [rightStep, observedResolvedResult] using + (cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input left.state + plan).run rightCache) observations right.state rightFuel table + hcovered (observedResolvedResult actualNextObservations nextRight) + hrightSupport) + have hnextBudget : nextRight.remaining + + nextRight.context.state.pending.card < Fintype.card Digest := by + have hremaining := + remaining_add_pending_card_le_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input left.state + plan).run rightCache) observations right.state rightFuel table + (observedResolvedResult actualNextObservations nextRight) + hrightSupport + simpa [observedResolvedResult] using hremaining.trans_lt hbudget + have hnextBefore : SnapshotsBefore nextSnapshots canonical := + ((hbefore.appendPlannedSnapshot candidate?).of_done_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterRootAwarePlan parameter input plan).run leftCache) left + leftFuel table nextLeft hleftSupport).canonicalize_right table + have hnextCandidates : nextSnapshots.map PlannedProbeSnapshot.toProbe = + appendPlannedCandidate + (snapshots.map PlannedProbeSnapshot.toProbe) candidate? := by + cases hcandidate' : candidate? <;> + simp [nextSnapshots, hcandidate', appendPlannedSnapshot, + appendPlannedCandidate] + have hcoveredAtStart : PendingCoveredBy + (nextSnapshots.map PlannedProbeSnapshot.toProbe) left := by + apply hleftCovered.mono_candidates + cases hcandidate' : candidate? <;> + simp [nextSnapshots, hcandidate', appendPlannedSnapshot] + have hplanMem : ∀ candidate, candidate? = some candidate → + candidate ∈ nextSnapshots.map PlannedProbeSnapshot.toProbe := by + intro candidate hcandidate + rw [hnextCandidates] + simp [appendPlannedCandidate, hcandidate] + have hprobeBound := + probingHashQueryAfterRootAwarePlan_uncoveredProbeBound parameter input + plan (nextSnapshots.map PlannedProbeSnapshot.toProbe) hplanMem leftCache + have hnextLeftCovered : PendingCoveredBy + (nextSnapshots.map PlannedProbeSnapshot.toProbe) canonical := by + apply (pendingCoveredBy_canonicalize_iff table + (nextSnapshots.map PlannedProbeSnapshot.toProbe) nextLeft.context).2 + apply pendingCoveredBy_of_done_runDirectResolvedDetailedFromTable + (nextSnapshots.map PlannedProbeSnapshot.toProbe) + ((probingHashQueryAfterRootAwarePlan parameter input plan).run leftCache) left + leftFuel table nextLeft hcoveredAtStart hprobeBound + rw [← map_erase_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterRootAwarePlan parameter input plan).run leftCache) left + leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩ + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hnoChain : NoExistingHiddenChainStartHits observations := by + intro observation hobservation hhit + exact hnoHit observation hobservation hhit.1 + have hnextChainValid : ChainState.ValidFor (fun _ => True) + nextRight.context.state := by + have hnext := rootAwarePublic_invariants_of_mem_runObservedCleanFromTable + parameter input left.state plan observations right.state rightFuel + table rightCache (observedResolvedResult actualNextObservations + nextRight) hnoChain hchainValid hrightSupport + simpa [observedResolvedResult] using hnext.1 + unfold canonicalizeDirectDelayedSelectedRootIndicator + simp only [canonical, hnotPrivate, hclean.left_published, ↓reduceIte, + hleftCompletable] + rw [← hclean.value_eq] + simpa [observe, IsOuterHash] using + (ih nextLeft.value.1 nextSnapshots actualNextObservations + delayedNextObservations canonical nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 + nextRight.value.2 (bound - 1) + (by simpa [IsOuterHash] using hbound.2 nextLeft.value.1) + hcanonicalRun.context_le hcanonicalRun.cache_eq + hcanonicalRun.revealed_eq hcanonicalRun.values_le + hcanonicalRun.left_published hcanonicalRun.right_materialized + hnextChainValid + (canonicalizeMaterializedValues_canonical table nextLeft.context + hclean.context_le.view.leftConsistent) + hnextAligned hnextBefore hnextTracked hnextCovered hnextNoHit + hnextDelayedProbes hnextDelayedNoHit hnextLeftCovered + (by omega) (by omega) (by omega) + hnextBudget))) using 1 + apply bind_congr + intro result + cases result <;> rfl + have houter : RelTriple + (rightStep >>= fun result => + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter publicRoot ftsSecret + (next result.value.1) result.observations result.state + result.remaining table result.value.2) + middle + (EqRel Bool) := by + unfold middle + apply relTriple_bind (relTriple_refl rightStep) + intro actual expected heq + subst expected + exact relTriple_eqRel_of_eq (hrealPointwise actual) + have hglued := SphincsSecurity.relTriple_trans_exists + (ob := middle) + (oc := leftStep >>= finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + nextSnapshots delayedNextObservations) + (R := EqRel Bool) (S := SuccessfulObservedIndicatorRel) houter hfinish + apply relTriple_post_mono hglued + intro actual delayed hrelation + obtain ⟨middle, hactual, hmiddle⟩ := hrelation + exact hactual ▸ hmiddle + cases hcandidate : candidate? with + | none => + have hnextSnapshots : nextSnapshots = snapshots := by + simp [nextSnapshots, hcandidate, appendPlannedSnapshot] + have hnextDelayedObservations : delayedNextObservations = + delayedObservations := by + simp [delayedNextObservations, hcandidate, observationsAfterCandidate] + have hlocal := + relTriple_runDirectResolvedWitness_rootAwarePrivate_observed_firstStopped + table parameter input left.state plan observations left right leftFuel + rightFuel leftCache rightCache rfl hleftPositive hcontext (by omega) + hcache hrevealed hvalues hpublished hrightMaterialized (by + intro candidate hcandidateRoot _hhidden + simp [candidate?, hcandidate] at hcandidateRoot) + htracked hcovered (by + simpa [candidate?, hcandidate, observationsAfterCandidate] using hnoHit) + hbudget + have hlocalObservations : observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan) = observations := by + simpa [candidate?, hcandidate, observationsAfterCandidate] + rw [hlocalObservations] at hlocal + have hresult := hcontinue observations + (by simpa [hnextSnapshots] using haligned) hnoHit + (by simpa [hnextSnapshots, hnextDelayedObservations] using hdelayedProbes) + (by simpa [hnextDelayedObservations] using hdelayedNoHit) + (by simpa [leftStep, rightStep] using hlocal) + simp only [leftStep, rightStep, observe, plan, candidate?, + delayedNextObservations, hnextDelayedObservations, nextSnapshots, + hnextSnapshots] at hresult ⊢ + convert hresult using 1 + apply bind_congr + intro result + cases result <;> rfl + | some candidate => + have hnextSnapshotsEq : nextSnapshots = + snapshots ++ [(⟨candidate, left⟩ : PlannedProbeSnapshot)] := by + simp [nextSnapshots, hcandidate, appendPlannedSnapshot] + let actualNextObservations := observations ++ + [cleanProbeObservation right.state candidate.coordinate + candidate.candidate] + have hnextDelayedProbes : delayedNextObservations.map + CleanProbeObservation.toProbe = + nextSnapshots.map PlannedProbeSnapshot.toProbe := by + simp [delayedNextObservations, nextSnapshots, hcandidate, + observationsAfterCandidate, appendPlannedSnapshot, + CleanProbeObservation.toProbe, cleanProbeObservation, hdelayedProbes] + by_cases hcandidateRevealed : candidate.coordinate ∈ right.state.revealed + · have hnewNoHit : ¬(cleanProbeObservation right.state candidate.coordinate + candidate.candidate).ExistingHiddenHit := by + rintro ⟨hhidden, _output, _hvalue, _hcandidate⟩ + simp [cleanProbeObservation, hcandidateRevealed] at hhidden + have hnextNoHit : ∀ observation ∈ actualNextObservations, + ¬observation.ExistingHiddenHit := by + intro observation hobservation + simp only [actualNextObservations, List.mem_append, + List.mem_singleton] at hobservation + rcases hobservation with hold | rfl + · exact hnoHit observation hold + · exact hnewNoHit + have hlocal := + relTriple_runDirectResolvedWitness_rootAwarePrivate_observed_firstStopped + table parameter input left.state plan observations left right leftFuel + rightFuel leftCache rightCache rfl hleftPositive hcontext (by omega) + hcache hrevealed hvalues hpublished hrightMaterialized (by + intro other hother hhidden + have heq : other = candidate := by + apply Option.some.inj + exact hother.symm.trans (by simpa [candidate?] using hcandidate) + subst other + exact (hhidden (by rwa [hrevealed])).elim) + htracked hcovered (by + simpa [candidate?, hcandidate, actualNextObservations, + observationsAfterCandidate] using hnextNoHit) + hbudget + have hlocalObservations : observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan) = + actualNextObservations := by + simpa [candidate?, hcandidate, actualNextObservations, + observationsAfterCandidate] + rw [hlocalObservations] at hlocal + have hresult := hcontinue actualNextObservations + (by simpa [actualNextObservations, nextSnapshots, candidate?, hcandidate, + observationsAfterCandidate, appendPlannedSnapshot] using + (haligned.appendCandidate (some candidate) hcontextDirect hrevealed + hpublished hcanonical)) + hnextNoHit hnextDelayedProbes + (by + intro observation hobservation + simp only [delayedNextObservations, observationsAfterCandidate, + hcandidate, List.mem_append, List.mem_singleton] at hobservation + rcases hobservation with hold | rfl + · exact hdelayedNoHit observation hold + · exact not_existingHiddenHit_cleanProbeObservation_materializedDeferredState + table left right candidate.coordinate candidate.candidate hcontext + hrevealed hvalues hrightMaterialized hnewNoHit) + (by simpa [leftStep, rightStep] using hlocal) + simp only [leftStep, rightStep, observe, plan, candidate?, nextSnapshots, + delayedNextObservations] at hresult ⊢ + convert hresult using 1 + apply bind_congr + intro result + cases result <;> rfl + · let postRight : DeferredContext := + { right with state := + right.state.addPending candidate.coordinate candidate.candidate } + by_cases hpostCompletable : DeferredCompletable table postRight + · have hnewNoHit : + ¬(cleanProbeObservation right.state candidate.coordinate + candidate.candidate).ExistingHiddenHit := + not_existingHiddenHit_cleanProbeObservation_of_addPending_completable + table right candidate hpostCompletable + have hnextNoHit : ∀ observation ∈ actualNextObservations, + ¬observation.ExistingHiddenHit := by + intro observation hobservation + simp only [actualNextObservations, List.mem_append, + List.mem_singleton] at hobservation + rcases hobservation with hold | rfl + · exact hnoHit observation hold + · exact hnewNoHit + have hpostBudget : (rightFuel - 1) + + (right.state.addPending candidate.coordinate + candidate.candidate).pending.card < Fintype.card Digest := by + have hcard := LazyRevealProbe.State.pending_card_addPending_le + right.state candidate.coordinate candidate.candidate + omega + have hlocal := + relTriple_runDirectResolvedWitness_rootAwarePrivate_observed_firstStopped + table parameter input left.state plan observations left right leftFuel + rightFuel leftCache rightCache rfl hleftPositive hcontext (by omega) + hcache hrevealed hvalues hpublished hrightMaterialized (by + intro other hother _hhidden + have heq : other = candidate := by + apply Option.some.inj + exact hother.symm.trans (by simpa [candidate?] using hcandidate) + subst other + exact (hcontext.addPending_both_of_right_completable + candidate.coordinate candidate.candidate (by + simpa [postRight] using hpostCompletable)).leftCompletable) + htracked hcovered (by + simpa [candidate?, hcandidate, actualNextObservations, + observationsAfterCandidate] using hnextNoHit) + hbudget + have hlocalObservations : observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan) = + actualNextObservations := by + simpa [candidate?, hcandidate, actualNextObservations, + observationsAfterCandidate] + rw [hlocalObservations] at hlocal + have hresult := hcontinue actualNextObservations + (by simpa [actualNextObservations, nextSnapshots, candidate?, hcandidate, + observationsAfterCandidate, appendPlannedSnapshot] using + (haligned.appendCandidate (some candidate) hcontextDirect hrevealed + hpublished hcanonical)) + hnextNoHit hnextDelayedProbes + (by + intro observation hobservation + simp only [delayedNextObservations, observationsAfterCandidate, + hcandidate, List.mem_append, List.mem_singleton] at hobservation + rcases hobservation with hold | rfl + · exact hdelayedNoHit observation hold + · exact not_existingHiddenHit_cleanProbeObservation_materializedDeferredState + table left right candidate.coordinate candidate.candidate hcontext + hrevealed hvalues hrightMaterialized hnewNoHit) + (by simpa [leftStep, rightStep] using hlocal) + simp only [leftStep, rightStep, observe, plan, candidate?, nextSnapshots, + delayedNextObservations] at hresult ⊢ + convert hresult using 1 + apply bind_congr + intro result + cases result <;> rfl + + · have hnoncompletable := + relTriple_indicator_observedMaterializedHashContinuation_hidden_notCompletable + ordinal parameter publicRoot rightRoot ftsSecret table target input plan + candidate next snapshots observations left right rightFuel rightCache + (leftStep >>= finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + nextSnapshots delayedNextObservations) + hcandidate (by simpa [hnextSnapshotsEq] using hnowSelected) hcontext + hrevealed hcanonical hrightMaterialized hcandidateRevealed hnoHit + haligned hbefore htracked (by omega) hbudget (by + simpa [postRight] using hpostCompletable) + simp only [leftStep, rightStep, observe, plan, candidate?, nextSnapshots, + delayedNextObservations, observedMaterializedHashContinuation, + hpublicExecutor, map_bind] at hnoncompletable ⊢ + convert hnoncompletable using 1 + apply bind_congr + intro result + cases result <;> rfl + | inr message => + rw [simulateQ_expandedAdversaryImpl_query_bind_inr] at hbound + change Option Signature → OracleComp (OracleWorld + SigningSpec) + RetainedRestResult at next + have hleft : + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inr message)) >>= next) + observations right.state rightFuel table rightCache) = + (runObservedCleanFromTable observations right.state rightFuel table + ((maskedSign parameter publicRoot ftsSecret message).run rightCache) >>= + fun result => + match result with + | none => pure false + | some result => + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret + (next result.value.1) result.observations result.state + result.remaining table result.value.2) := by + rw [observedMaterializedBoundary, OracleComp.construct_query_bind, map_bind] + apply bind_congr + intro result + cases result with + | none => + simp [successfulObservedRootComparisonIndicator, + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + | some result => rfl + rw [directDelayedSelectedRootIndicator, OracleComp.construct_query_bind] + simp only [hselected, ↓reduceDIte] + rw [hleft] + let observe : DeferredContext → Nat → + (Option Signature × SplitHashCache) → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool := + fun nextContext remaining value laterSnapshots laterObservations => + directDelayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret table + target rightRoot (next value.1) laterSnapshots laterObservations nextContext + remaining value.2 + apply relTriple_sign_finishDirectDelayed ordinal parameter publicRoot rightRoot + ftsSecret table target message next observe snapshots observations delayedObservations + left right + leftFuel rightFuel leftCache rightCache hcontext (by omega) hcache hrevealed + hvalues hpublished hrightMaterialized htracked hcovered hnoHit hbudget + intro nextLeft nextRight hleftSupport hrightSupport hclean + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hleftCompletable : DeferredCompletable table canonical := + hcanonicalRun.context_le.leftCompletable + have hleftFuelPreserved : leftFuel ≤ nextLeft.remaining := by + have hfuel := fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + ((maskedSign parameter publicRoot ftsSecret message).run leftCache) left leftFuel + table nextLeft 0 + (maskedSign_probeFree parameter publicRoot ftsSecret message leftCache) + hleftSupport + omega + have hrightFuelPreserved : rightFuel ≤ nextRight.remaining := by + have hfuel := fuel_le_remaining_add_of_mem_runObservedCleanFromTable + ((maskedSign parameter publicRoot ftsSecret message).run rightCache) observations + right.state rightFuel table (observedResolvedResult observations nextRight) 0 + (maskedSign_probeFree parameter publicRoot ftsSecret message rightCache) + hrightSupport + simpa [observedResolvedResult] using hfuel + have hleftRemainingUpper : nextLeft.remaining ≤ leftFuel := + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((maskedSign parameter publicRoot ftsSecret message).run leftCache) left leftFuel + table nextLeft (by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((maskedSign parameter publicRoot ftsSecret message).run leftCache) left + leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩) + have hnextTracked : CleanProbeObservationsTrackedBy observations + nextRight.context.state := by + simpa [observedResolvedResult] using + (cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((maskedSign parameter publicRoot ftsSecret message).run rightCache) + observations right.state rightFuel table htracked + (observedResolvedResult observations nextRight) hrightSupport) + have hnextCovered : CleanProbeObservationsCoverPending observations + nextRight.context.state := by + simpa [observedResolvedResult] using + (cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((maskedSign parameter publicRoot ftsSecret message).run rightCache) + observations right.state rightFuel table hcovered + (observedResolvedResult observations nextRight) hrightSupport) + have hnextBudget : nextRight.remaining + nextRight.context.state.pending.card < + Fintype.card Digest := by + have hremaining := remaining_add_pending_card_le_of_mem_runObservedCleanFromTable + ((maskedSign parameter publicRoot ftsSecret message).run rightCache) observations + right.state rightFuel table (observedResolvedResult observations nextRight) + hrightSupport + simpa [observedResolvedResult] using hremaining.trans_lt hbudget + have hnextBefore : SnapshotsBefore snapshots canonical := + (hbefore.of_done_runDirectResolvedWitnessFromTable + ((maskedSign parameter publicRoot ftsSecret message).run leftCache) left leftFuel + table nextLeft hleftSupport).canonicalize_right table + have hnextLeftCovered : PendingCoveredBy + (snapshots.map PlannedProbeSnapshot.toProbe) canonical := by + apply (pendingCoveredBy_canonicalize_iff table + (snapshots.map PlannedProbeSnapshot.toProbe) nextLeft.context).2 + apply hleftCovered.of_subset + apply pending_subset_of_done_runDirectResolvedDetailedFromTable_of_probeFree + ((maskedSign parameter publicRoot ftsSecret message).run leftCache) left leftFuel + table nextLeft + (maskedSign_probeFree parameter publicRoot ftsSecret message leftCache) + rw [← map_erase_runDirectResolvedWitnessFromTable + ((maskedSign parameter publicRoot ftsSecret message).run leftCache) left leftFuel + table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩ + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hnextChainValid : ChainState.ValidFor (fun _ => True) + nextRight.context.state := by + have hnext := chainValid_of_mem_runObservedCleanFromTable + (maskedSign parameter publicRoot ftsSecret message) observations right.state + rightFuel table rightCache (observedResolvedResult observations nextRight) + (preservesChainValid_maskedSign_true parameter publicRoot ftsSecret message) + hchainValid hrightSupport + simpa [observedResolvedResult] using hnext + unfold canonicalizeDirectDelayedSelectedRootIndicator + simp only [canonical, hnotPrivate, hclean.left_published, ↓reduceIte, + hleftCompletable] + rw [← hclean.value_eq] + have hdetailed : DirectDetailedResult.done nextLeft ∈ support + (runDirectResolvedDetailedFromTable left leftFuel table + ((maskedSign parameter publicRoot ftsSecret message).run leftCache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((maskedSign parameter publicRoot ftsSecret message).run leftCache) + left leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩ + have hdirect : some nextLeft ∈ support + (runDirectResolvedFromTable left leftFuel table + ((maskedSign parameter publicRoot ftsSecret message).run leftCache)) := + mem_support_runDirectResolvedFromTable_of_done_detailed + ((maskedSign parameter publicRoot ftsSecret message).run leftCache) + left leftFuel table nextLeft hdetailed + have hraw := raw_done_of_mem_runDirectResolvedFromTable + ((maskedSign parameter publicRoot ftsSecret message).run leftCache) + left leftFuel table nextLeft hdirect + have houtput : nextLeft.value.1 ∈ support + (scheme.sign + (⟨parameter, publicRoot, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey) message) := by + exact maskedSign_done_output_mem_support parameter publicRoot table ftsSecret + message left.state nextLeft.context.state leftCache nextLeft.value.2 + leftFuel nextLeft.remaining nextLeft.value.1 + hclean.context_le.view.leftStarts (by + simpa only [SigningSpec, maskedExpandedAdversaryImpl, + maskedSigningImpl] using hraw) + have htailBound := isQueryBoundP_of_bind hbound nextLeft.value.1 houtput + simpa [observe] using + (ih nextLeft.value.1 snapshots observations delayedObservations canonical + nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 bound + (htailBound.mono (by omega)) hcanonicalRun.context_le hcanonicalRun.cache_eq + hcanonicalRun.revealed_eq hcanonicalRun.values_le hcanonicalRun.left_published + hcanonicalRun.right_materialized hnextChainValid + (canonicalizeMaterializedValues_canonical table nextLeft.context + hclean.context_le.view.leftConsistent) + haligned hnextBefore hnextTracked hnextCovered hnoHit hdelayedProbes + hdelayedNoHit + hnextLeftCovered + (by omega) (by omega) (by omega) hnextBudget) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalize.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalize.lean new file mode 100644 index 00000000..53b83652 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalize.lean @@ -0,0 +1,1466 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveTrace +import SphincsSecurity.Proof.OtsProbeResolvedPrivateRetainedCommutation +import SphincsSecurity.Proof.OtsProbeResolvedDirectSynchronized + +/-! +# Adaptive selected-root normalization + +The selected-root computation resolves its target only when the chosen candidate is reached. This +module moves that same resolution to the start of the deferred prefix. The post-selection suffix is +already handled by the adaptive selected-root bridge, so the normalization stops at that boundary. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +noncomputable def eagerDirectDelayedSelectedRootIndicator + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : ProbComp Bool := + if ordinal < snapshots.length then + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + computation snapshots observations context fuel cache + else do + let resolved ← resolveDeferredPositionValue target context + match resolved with + | none => pure false + | some resolved => + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + computation snapshots observations resolved.toDeferredContext fuel cache + +set_option maxRecDepth 100000 in +theorem evalDist_eagerDirectDelayedSelectedRootIndicator_eq_of_selected + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hselected : ordinal < snapshots.length) : + evalDist + (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot computation snapshots observations context fuel cache) = + evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot computation snapshots observations context fuel cache) := by + simp [eagerDirectDelayedSelectedRootIndicator, hselected] + +theorem evalDist_eagerDirectDelayedSelectedRootIndicator_pure_eq + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (value : α) (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hselected : ¬ordinal < snapshots.length) : + evalDist + (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (pure value) snapshots observations context fuel cache) = + evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (pure value) snapshots observations context fuel cache) := by + simp only [eagerDirectDelayedSelectedRootIndicator, hselected, ↓reduceIte, + directDelayedSelectedRootIndicator, OracleComp.construct_pure, ↓reduceDIte] + calc + _ = evalDist + (resolveDeferredPositionValue target context >>= fun _ ↦ + (pure false : ProbComp Bool)) := by + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved <;> rfl + _ = evalDist (pure false : ProbComp Bool) := + OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolveDeferredPositionValue target context) + (by simp [resolveDeferredPositionValue, LazyRevealProbe.sampleHashOutput]) + (pure false) + +theorem evalDist_eagerDirectDelayedSelectedRootIndicator_of_resolved + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (resolved : DeferredResolution) + (fuel : Nat) (cache : SplitHashCache) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target context)) : + evalDist + (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot computation snapshots observations resolved.toDeferredContext fuel cache) = + evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot computation snapshots observations resolved.toDeferredContext fuel cache) := by + by_cases hselected : ordinal < snapshots.length + · exact evalDist_eagerDirectDelayedSelectedRootIndicator_eq_of_selected ordinal parameter + root ftsSecret table target rightRoot computation snapshots observations + resolved.toDeferredContext fuel cache hselected + · unfold eagerDirectDelayedSelectedRootIndicator + simp only [hselected, ↓reduceIte] + rw [resolveDeferredPositionValue_of_resolved target context resolved hresolved] + rfl + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_canonicalizeDirectDelayed + (table : OtsSecretIndex → HashOutput) (target : Position) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hpublished : PublishedValues context.state) + (hnormalize : evalDist (resolveDeferredPositionValue target + (canonicalizeMaterializedValues table context) >>= fun resolved ↦ + match resolved with + | none => pure false + | some resolved => + observe resolved.toDeferredContext fuel value snapshots observations) = + evalDist (observe (canonicalizeMaterializedValues table context) fuel value snapshots + observations)) : + evalDist (resolveDeferredPositionValue target context >>= fun resolved ↦ + match resolved with + | none => pure false + | some resolved => + canonicalizeDirectDelayedSelectedRootIndicator table observe + resolved.toDeferredContext fuel value snapshots observations) = + evalDist (canonicalizeDirectDelayedSelectedRootIndicator table observe context fuel value + snapshots observations) := by + have hclean : ∀ coordinate output, + resolvedCompletionValue table context coordinate = some output → + ¬context.state.hitAt coordinate output := by + obtain ⟨completion, hcompletion⟩ := hcompletable + intro coordinate output hvalue hhit + have houtput := hcompletion.eq_resolvedCompletionValue coordinate output hvalue + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + exact hcompletion.2.2.1 coordinate (truncateHash output) hhit (by rw [houtput]) + have hcanonicalValid : + (canonicalizeMaterializedValues table context).Valid := + canonicalizeMaterializedValues_valid table context hvalid hclean + have hcanonicalCompletable : + DeferredCompletable table (canonicalizeMaterializedValues table context) := + (valid_completable_canonicalizeMaterializedValues table context hvalid hcompletable).2 + have hcanonicalNoHit : + ¬PrivateStructuralHit (canonicalizeMaterializedValues table context) := + not_privateStructuralHit_of_deferredCompletable hcanonicalCompletable + have hright : evalDist + (canonicalizeDirectDelayedSelectedRootIndicator table observe context fuel value snapshots + observations) = + evalDist (observe (canonicalizeMaterializedValues table context) fuel value snapshots + observations) := by + simp [canonicalizeDirectDelayedSelectedRootIndicator, hcanonicalNoHit, hpublished, + hcanonicalCompletable] + rw [hright] + let finish : Option DeferredResolution → ProbComp Bool + | none => pure false + | some resolved => observe resolved.toDeferredContext fuel value snapshots observations + calc + _ = evalDist (((Option.map (canonicalizeDeferredResolution table)) <$> + resolveDeferredPositionValue target context) >>= finish) := by + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hresolvedValid := hvalid.of_resolveDeferredPositionValue target resolved hresolved + have hresolvedCompletable := + hcompletable.of_resolveDeferredPositionValue hvalid target resolved hresolved + have hresolvedPublished : PublishedValues resolved.state := + (publishedValues_resolveDeferredPositionValue_iff target context resolved + hresolved).2 hpublished + have hcanonical := valid_completable_canonicalizeMaterializedValues table + resolved.toDeferredContext hresolvedValid hresolvedCompletable + have hcanonicalNoHit : ¬PrivateStructuralHit + (canonicalizeMaterializedValues table resolved.toDeferredContext) := + not_privateStructuralHit_of_deferredCompletable hcanonical.2 + simp [canonicalizeDirectDelayedSelectedRootIndicator, hcanonicalNoHit, + hresolvedPublished, hcanonical.2, finish, canonicalizeDeferredResolution] + _ = evalDist (resolveDeferredPositionValue target + (canonicalizeMaterializedValues table context) >>= finish) := + evalDist_bind_eq_of_evalDist_eq + (evalDist_resolveDeferredPositionValue_canonicalize table target context + hvalid.valuesConsistent hpublished) finish + _ = _ := hnormalize + +theorem runDirectResolvedWitnessFromTable_splitUniformImpl + (n fuel : Nat) (context : DeferredContext) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runDirectResolvedWitnessFromTable context fuel table ((splitUniformImpl n).run cache) = (do + let output ← liftM (unifSpec.query n) + pure (DirectWitnessResult.done ⟨context, fuel, (output, cache), table⟩)) := by + rfl + +noncomputable def negatedDirectDelayedObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (value : α) : ProbComp Bool := + Bool.not <$> observe context fuel value snapshots observations + +set_option maxRecDepth 100000 in +theorem evalDist_runDirectWitness_finish_false_eq_complement_runDirectObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + evalDist (runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectDelayedSelectedRootIndicator observe snapshots observations) = + evalDist (Bool.not <$> runDirectResolvedObserve + (negatedDirectDelayedObserve observe snapshots observations) + context fuel table computation) := by + unfold runDirectResolvedObserve + rw [← map_toOption_runDirectResolvedDetailedFromTable computation context fuel table] + rw [← map_erase_runDirectResolvedWitnessFromTable computation context fuel table] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro result _hresult + cases result <;> + simp [finishDirectDelayedSelectedRootIndicator, finishObserve, + DirectWitnessResult.erase, DirectDetailedResult.toOption, negatedDirectDelayedObserve] + +set_option maxRecDepth 100000 in +theorem evalDist_complement_runDirectWitness_finish_false_eq_runDirectObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + evalDist (Bool.not <$> (runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectDelayedSelectedRootIndicator observe snapshots observations)) = + evalDist (runDirectResolvedObserve + (negatedDirectDelayedObserve observe snapshots observations) + context fuel table computation) := by + have hbridge := evalDist_runDirectWitness_finish_false_eq_complement_runDirectObserve observe + snapshots observations context fuel table computation + calc + _ = evalDist (Bool.not <$> (Bool.not <$> runDirectResolvedObserve + (negatedDirectDelayedObserve observe snapshots observations) + context fuel table computation)) := by + rw [evalDist_map, evalDist_map, hbridge] + _ = _ := by simp + +instance negatedCanonicalizeDirectDelayedObserve_observerDooms + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) : + ObserverDooms table + (negatedDirectDelayedObserve + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations) where + eq_true context fuel value hconsistent hstarts hdoomed := by + have hcanonicalDoomed := doomedResolvedContext_canonicalizeMaterializedValues + (table := table) (context := context) ⟨hconsistent, hstarts, hdoomed⟩ + unfold negatedDirectDelayedObserve canonicalizeDirectDelayedSelectedRootIndicator + let canonical := canonicalizeMaterializedValues table context + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit] + · by_cases hpublished : PublishedValues context.state + · simp [canonical, hhit, hpublished, hcanonicalDoomed.2.2] + · simp [canonical, hhit, hpublished] + +instance negatedCanonicalizeDirectDelayedObserve_observerSynchronized + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + [ObserverSynchronized table + (negatedDirectDelayedObserve observe snapshots observations)] : + ObserverSynchronized table + (negatedDirectDelayedObserve + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations) where + eq_of_synchronized left right fuel value hcontext hvalues hrevealed := by + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hrightCompletable : DeferredCompletable table right := by + rcases hleftCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, (hview.deferredCompletion_iff completion).mp hcompletion⟩ + have hleftCanonical := valid_completable_canonicalizeMaterializedValues table left + hleftValid hleftCompletable + have hrightCanonical := valid_completable_canonicalizeMaterializedValues table right + hrightValid hrightCompletable + have hleftNoHit : + ¬PrivateStructuralHit (canonicalizeMaterializedValues table left) := + not_privateStructuralHit_of_deferredCompletable hleftCanonical.2 + have hrightNoHit : + ¬PrivateStructuralHit (canonicalizeMaterializedValues table right) := + not_privateStructuralHit_of_deferredCompletable hrightCanonical.2 + have hpublishedIff : PublishedValues left.state ↔ PublishedValues right.state := by + simp only [PublishedValues] + constructor + · intro hpublished coordinate hrightRevealed + rw [← hvalues] + exact hpublished coordinate (by simpa [hrevealed] using hrightRevealed) + · intro hpublished coordinate hleftRevealed + rw [hvalues] + exact hpublished coordinate (by simpa [hrevealed] using hleftRevealed) + unfold negatedDirectDelayedObserve canonicalizeDirectDelayedSelectedRootIndicator + by_cases hleftPublished : PublishedValues left.state + · have hrightPublished := hpublishedIff.mp hleftPublished + simp only [hleftNoHit, hrightNoHit, hleftPublished, hrightPublished, + hleftCanonical.2, hrightCanonical.2, ↓reduceIte] + have hcanonical := canonicalizedFinalizationContextEq + (⟨hview, hleftValid, hrightValid, hleftCompletable⟩ : + FinalizationContextEq table (some left) (some right)) hrevealed + exact ObserverSynchronized.eq_of_synchronized + (table := table) + (observe := negatedDirectDelayedObserve observe snapshots observations) + (canonicalizeMaterializedValues table left) + (canonicalizeMaterializedValues table right) fuel value hcanonical.1 hcanonical.2 + hrevealed + · have hrightNotPublished : ¬PublishedValues right.state := by + rwa [← hpublishedIff] + simp [hleftNoHit, hrightNoHit, hleftPublished, hrightNotPublished] + +theorem evalDist_negatedCanonicalizeDirectDelayedObserve_eq_canonicalizeObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (value : α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist + (negatedDirectDelayedObserve + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations context fuel value) = + evalDist + (canonicalizeObserve table + (negatedDirectDelayedObserve observe snapshots observations) + context fuel value) := by + have hcanonical := valid_completable_canonicalizeMaterializedValues table context hvalid + hcompletable + have hnoHit : ¬PrivateStructuralHit + (canonicalizeMaterializedValues table context) := + not_privateStructuralHit_of_deferredCompletable hcanonical.2 + unfold negatedDirectDelayedObserve canonicalizeDirectDelayedSelectedRootIndicator + canonicalizeObserve + by_cases hpublished : PublishedValues context.state <;> + simp [hnoHit, hpublished, hcanonical.2] + +instance negatedCanonicalizeDirectDelayedObserve_observerPositionNeutral + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + [ObserverPositionNeutral table + (negatedDirectDelayedObserve observe snapshots observations)] : + ObserverPositionNeutral table + (negatedDirectDelayedObserve + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations) where + eq_resolve position context fuel value hvalid hcompletable hensured := by + let standard := canonicalizeObserve table + (negatedDirectDelayedObserve observe snapshots observations) + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved ↦ + match resolved with + | none => pure true + | some resolved => standard resolved.toDeferredContext fuel value) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + exact evalDist_negatedCanonicalizeDirectDelayedObserve_eq_canonicalizeObserve + table observe snapshots observations resolved.toDeferredContext fuel value + (hvalid.of_resolveDeferredPositionValue position resolved hresolved) + (hcompletable.of_resolveDeferredPositionValue hvalid position resolved hresolved) + _ = evalDist (standard context fuel value) := + ObserverPositionNeutral.eq_resolve + (table := table) + (observe := canonicalizeObserve table + (negatedDirectDelayedObserve observe snapshots observations)) + position context fuel value hvalid hcompletable hensured + _ = _ := + (evalDist_negatedCanonicalizeDirectDelayedObserve_eq_canonicalizeObserve table observe + snapshots observations context fuel value hvalid hcompletable).symm + +theorem negatedCanonicalizeDirectDelayedObserve_observerPositionNeutralAt + (table : OtsSecretIndex → HashOutput) (position : Position) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (hneutral : ObserverPositionNeutralAt table position + (negatedDirectDelayedObserve observe snapshots observations)) : + ObserverPositionNeutralAt table position + (negatedDirectDelayedObserve + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations) := by + intro context fuel value hvalid hcompletable hensured + let standard := canonicalizeObserve table + (negatedDirectDelayedObserve observe snapshots observations) + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved ↦ + match resolved with + | none => pure true + | some resolved => standard resolved.toDeferredContext fuel value) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + exact evalDist_negatedCanonicalizeDirectDelayedObserve_eq_canonicalizeObserve + table observe snapshots observations resolved.toDeferredContext fuel value + (hvalid.of_resolveDeferredPositionValue position resolved hresolved) + (hcompletable.of_resolveDeferredPositionValue hvalid position resolved hresolved) + _ = evalDist (standard context fuel value) := + canonicalizeObserve_observerPositionNeutralAt table position + (negatedDirectDelayedObserve observe snapshots observations) hneutral + context fuel value hvalid hcompletable hensured + _ = _ := + (evalDist_negatedCanonicalizeDirectDelayedObserve_eq_canonicalizeObserve table observe + snapshots observations context fuel value hvalid hcompletable).symm + +set_option maxRecDepth 100000 in +theorem evalDist_complement_runDirectWitness_finish_false_eq_of_synchronized + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (left right : DeferredContext) (fuel : Nat) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) + (hrevealed : left.state.revealed = right.state.revealed) + [ObserverSynchronized table + (negatedDirectDelayedObserve observe snapshots observations)] : + evalDist (Bool.not <$> + (runDirectResolvedWitnessFromTable left fuel table computation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations)) = + evalDist (Bool.not <$> + (runDirectResolvedWitnessFromTable right fuel table computation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations)) := by + let nextObserve := negatedDirectDelayedObserve + (canonicalizeDirectDelayedSelectedRootIndicator table observe) snapshots observations + calc + _ = evalDist (runDirectResolvedObserve nextObserve left fuel table computation) := + evalDist_complement_runDirectWitness_finish_false_eq_runDirectObserve + (canonicalizeDirectDelayedSelectedRootIndicator table observe) snapshots observations + left fuel table computation + _ = evalDist (runDirectResolvedObserve nextObserve right fuel table computation) := + evalDist_runDirectResolvedObserve_eq_of_finalizationSynchronized computation left right + fuel table hcontext hvalues hrevealed + _ = _ := + (evalDist_complement_runDirectWitness_finish_false_eq_runDirectObserve + (canonicalizeDirectDelayedSelectedRootIndicator table observe) snapshots observations + right fuel table computation).symm + +theorem evalDist_eq_of_complement_eq + (left right : ProbComp Bool) + (hcomplement : evalDist (Bool.not <$> left) = evalDist (Bool.not <$> right)) : + evalDist left = evalDist right := by + have h := congrArg (Functor.map Bool.not) hcomplement + simpa [evalDist_map, Functor.map_map] using h + +set_option maxRecDepth 100000 in +theorem evalDist_resolve_then_runDirectWitness_finish_false + (table : OtsSecretIndex → HashOutput) (target : Position) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + [ObserverSynchronized table + (negatedDirectDelayedObserve observe snapshots observations)] + [ObserverPositionNeutral table + (negatedDirectDelayedObserve observe snapshots observations)] : + evalDist (resolveDeferredPositionValue target context >>= fun resolved ↦ + match resolved with + | none => pure false + | some resolved => + runDirectResolvedWitnessFromTable resolved.toDeferredContext fuel table computation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations) = + evalDist (runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations) := by + let nextObserve := negatedDirectDelayedObserve + (canonicalizeDirectDelayedSelectedRootIndicator table observe) snapshots observations + apply evalDist_eq_of_complement_eq + calc + _ = evalDist (resolveDeferredPositionValue target context >>= fun resolved ↦ + match resolved with + | none => pure true + | some resolved => + runResolvedObserve nextObserve resolved.toDeferredContext fuel table computation) := by + rw [map_bind] + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hresolvedValid := hvalid.of_resolveDeferredPositionValue target resolved hresolved + have hresolvedCompletable := hcompletable.of_resolveDeferredPositionValue hvalid target + resolved hresolved + calc + _ = evalDist (runDirectResolvedObserve nextObserve resolved.toDeferredContext fuel + table computation) := + evalDist_complement_runDirectWitness_finish_false_eq_runDirectObserve + (canonicalizeDirectDelayedSelectedRootIndicator table observe) snapshots + observations resolved.toDeferredContext fuel table computation + _ = _ := + (evalDist_runResolvedObserve_eq_runDirectResolvedObserve + (observe := nextObserve) resolved.toDeferredContext fuel table computation + hresolvedValid hresolvedCompletable).symm + _ = evalDist (runResolvedObserve nextObserve context fuel table computation) := + evalDist_resolveDeferredPositionValue_then_runResolvedObserve_any + (observe := nextObserve) target computation context fuel table hvalid hcompletable + _ = evalDist (runDirectResolvedObserve nextObserve context fuel table computation) := + evalDist_runResolvedObserve_eq_runDirectResolvedObserve + (observe := nextObserve) context fuel table computation hvalid hcompletable + _ = _ := + (evalDist_complement_runDirectWitness_finish_false_eq_runDirectObserve + (canonicalizeDirectDelayedSelectedRootIndicator table observe) snapshots observations + context fuel table computation).symm + +set_option maxRecDepth 100000 in +theorem evalDist_resolve_then_runDirectWitness_finish_false_at + (table : OtsSecretIndex → HashOutput) (target : Position) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : Coordinate.position target ∈ context.state.ensured) + (hneutral : ObserverPositionNeutralAt table target + (negatedDirectDelayedObserve observe snapshots observations)) : + evalDist (resolveDeferredPositionValue target context >>= fun resolved ↦ + match resolved with + | none => pure false + | some resolved => + runDirectResolvedWitnessFromTable resolved.toDeferredContext fuel table computation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations) = + evalDist (runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations) := by + let nextObserve := negatedDirectDelayedObserve + (canonicalizeDirectDelayedSelectedRootIndicator table observe) snapshots observations + have hnextNeutral : ObserverPositionNeutralAt table target nextObserve := + negatedCanonicalizeDirectDelayedObserve_observerPositionNeutralAt table target observe + snapshots observations hneutral + apply evalDist_eq_of_complement_eq + calc + _ = evalDist (resolveDeferredPositionValue target context >>= fun resolved ↦ + match resolved with + | none => pure true + | some resolved => + runDirectResolvedObserve nextObserve resolved.toDeferredContext fuel table + computation) := by + rw [map_bind] + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved with + | none => rfl + | some resolved => + exact evalDist_complement_runDirectWitness_finish_false_eq_runDirectObserve + (canonicalizeDirectDelayedSelectedRootIndicator table observe) snapshots + observations resolved.toDeferredContext fuel table computation + _ = evalDist (runDirectResolvedObserve nextObserve context fuel table computation) := + evalDist_resolveDeferredPositionValue_then_runDirectResolvedObserve target computation + context fuel table hvalid hcompletable hensured + hnextNeutral + _ = _ := + (evalDist_complement_runDirectWitness_finish_false_eq_runDirectObserve + (canonicalizeDirectDelayedSelectedRootIndicator table observe) snapshots observations + context fuel table computation).symm + +theorem cleanProbeObservation_materializedDeferredState_resolved + (target : Position) (context : DeferredContext) (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target context)) + (coordinate : Coordinate) (candidate : Digest) : + cleanProbeObservation (materializedDeferredState resolved.toDeferredContext) + coordinate candidate = + installPositionValueAtProbe target resolved.output + (cleanProbeObservation (materializedDeferredState context) coordinate candidate) := by + have hstate := resolveDeferredPositionValue_state_eq_clearPending target context resolved + hresolved + have hstateValues := resolveDeferredPositionValue_preserves_state_values target context resolved + hresolved + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [cleanProbeObservation, installPositionValueAtProbe, hstate, + LazyRevealProbe.State.clearPending] + | position position => + by_cases hposition : position = target + · subst position + have hvalue := resolveDeferredPositionValue_resolves target context resolved hresolved + simp [cleanProbeObservation, installPositionValueAtProbe, hstate, hvalue, + LazyRevealProbe.State.clearPending] + · have hvalue : resolved.toDeferredContext.positionValue position = + context.positionValue position := by + unfold DeferredContext.positionValue + rw [hstateValues] + split + · rfl + · exact resolveDeferredPositionValue_preserves_other target position context resolved + hposition hresolved + simp [cleanProbeObservation, installPositionValueAtProbe, hstate, hvalue, hposition, + LazyRevealProbe.State.clearPending] + +theorem observationsAfterCandidate_materializedDeferredState_resolved + (target : Position) (context : DeferredContext) (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target context)) + (observations : List CleanProbeObservation) (candidate? : Option Probe) : + observationsAfterCandidate + (observations.map (installPositionValueAtProbe target resolved.output)) + (materializedDeferredState resolved.toDeferredContext) candidate? = + (observationsAfterCandidate observations (materializedDeferredState context) candidate?).map + (installPositionValueAtProbe target resolved.output) := by + cases candidate? with + | none => rfl + | some candidate => + simp [observationsAfterCandidate, + cleanProbeObservation_materializedDeferredState_resolved target context resolved hresolved] + +theorem observationsAfterCandidate_eventEq_resolved_of_clean_of_avoids + (target : Position) (context : DeferredContext) (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target context)) + (observations : List CleanProbeObservation) (candidate? : Option Probe) + (hclean : ∀ observation ∈ + observationsAfterCandidate observations (materializedDeferredState context) candidate?, + ¬observation.ExistingHiddenHit) + (havoid : CandidatesAvoidRoot target (truncateHash resolved.output) + ((observationsAfterCandidate observations (materializedDeferredState context) + candidate?).map CleanProbeObservation.toProbe)) : + CleanProbeObservationsEventEq + (observationsAfterCandidate + (observations.map (installPositionValueAtProbe target resolved.output)) + (materializedDeferredState resolved.toDeferredContext) candidate?) + (observationsAfterCandidate observations (materializedDeferredState context) candidate?) := by + rw [observationsAfterCandidate_materializedDeferredState_resolved target context resolved + hresolved] + exact + CleanProbeObservationsEventEq.map_installPositionValueAtProbe_of_clean_of_avoids target + resolved.output _ hclean havoid + +theorem observationsAfterCandidate_eventEq_resolved_current_of_clean_of_avoids + (target : Position) (context : DeferredContext) (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target context)) + (observations : List CleanProbeObservation) (candidate? : Option Probe) + (hclean : ∀ observation ∈ + observationsAfterCandidate observations (materializedDeferredState context) candidate?, + ¬observation.ExistingHiddenHit) + (havoid : CandidatesAvoidRoot target (truncateHash resolved.output) + ((observationsAfterCandidate observations (materializedDeferredState context) + candidate?).map CleanProbeObservation.toProbe)) : + CleanProbeObservationsEventEq + (observationsAfterCandidate observations + (materializedDeferredState resolved.toDeferredContext) candidate?) + (observationsAfterCandidate observations (materializedDeferredState context) candidate?) := by + cases candidate? with + | none => exact CleanProbeObservationsEventEq.refl observations + | some candidate => + apply List.rel_append (CleanProbeObservationsEventEq.refl observations) + apply List.Forall₂.cons + · rw [cleanProbeObservation_materializedDeferredState_resolved target context resolved + hresolved] + apply CleanProbeObservation.eventEq_installPositionValueAtProbe_of_clean_of_avoids + · exact hclean _ (by simp [observationsAfterCandidate]) + · intro heq + exact havoid _ (by simp [observationsAfterCandidate]) heq + · exact .nil + +def installPositionValueAtSnapshot + (target : Position) (output : HashOutput) + (snapshot : PlannedProbeSnapshot) : PlannedProbeSnapshot := + ⟨snapshot.probe, + (completePrivatePosition target snapshot.context output).toDeferredContext⟩ + +@[simp] theorem installPositionValueAtSnapshot_toProbe + (target : Position) (output : HashOutput) (snapshot : PlannedProbeSnapshot) : + (installPositionValueAtSnapshot target output snapshot).toProbe = snapshot.toProbe := by + rfl + +theorem completePrivatePosition_eq_of_resolveDeferredPositionValue + (target : Position) (context : DeferredContext) (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target context)) : + completePrivatePosition target context resolved.output = resolved := by + have hstate := resolveDeferredPositionValue_state_eq_clearPending target context resolved + hresolved + have htarget := resolveDeferredPositionValue_installs target context resolved hresolved + rcases resolved with ⟨⟨state, values⟩, output⟩ + simp only at hstate htarget ⊢ + subst state + have hvalues : context.values.install target output = values := by + funext position + by_cases hposition : position = target + · subst position + simpa [DeferredStructuralValues.install] using htarget.symm + · rw [DeferredStructuralValues.install, Function.update_of_ne hposition] + exact (resolveDeferredPositionValue_preserves_other target position context + ⟨⟨context.state.clearPending (.position target), values⟩, output⟩ hposition hresolved).symm + simp [completePrivatePosition, hvalues] + +theorem appendPlannedSnapshot_resolved + (target : Position) (context : DeferredContext) (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target context)) + (snapshots : List PlannedProbeSnapshot) (candidate? : Option Probe) : + appendPlannedSnapshot + (snapshots.map (installPositionValueAtSnapshot target resolved.output)) + candidate? resolved.toDeferredContext = + (appendPlannedSnapshot snapshots candidate? context).map + (installPositionValueAtSnapshot target resolved.output) := by + have hcontext := congrArg DeferredResolution.toDeferredContext + (completePrivatePosition_eq_of_resolveDeferredPositionValue target context resolved hresolved) + cases candidate? with + | none => rfl + | some candidate => + simp [appendPlannedSnapshot, installPositionValueAtSnapshot, hcontext] + +set_option maxRecDepth 100000 in +theorem evalDist_directDelayedSelectedRootIndicator_eq_of_selected_context + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hselected : ordinal < snapshots.length) : + evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot computation snapshots observations left fuel cache) = + evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot computation snapshots observations right fuel cache) := by + rw [directDelayedSelectedRootIndicator_eq_selected ordinal parameter root ftsSecret table target + rightRoot computation snapshots observations left fuel cache hselected] + rw [directDelayedSelectedRootIndicator_eq_selected ordinal parameter root ftsSecret table target + rightRoot computation snapshots observations right fuel cache hselected] + +theorem evalDist_directDelayedSelectedRootIndicator_pure_eq_of_unselected_context + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (value : α) (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hselected : ¬ordinal < snapshots.length) : + evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (pure value) snapshots observations left fuel cache) = + evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (pure value) snapshots observations right fuel cache) := by + simp [directDelayedSelectedRootIndicator, hselected] + +set_option maxRecDepth 100000 in +theorem evalDist_negatedDirectDelayedSelectedRootIndicator_eq_of_selected_context + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hselected : ordinal < snapshots.length) : + evalDist (Bool.not <$> + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot computation snapshots observations left fuel cache) = + evalDist (Bool.not <$> + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot computation snapshots observations right fuel cache) := by + rw [evalDist_map, evalDist_map, + evalDist_directDelayedSelectedRootIndicator_eq_of_selected_context ordinal parameter root + ftsSecret table target rightRoot computation snapshots observations left right fuel cache + hselected] + +theorem evalDist_negatedDirectDelayedSelectedRootIndicator_pure_eq_of_unselected_context + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (value : α) (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hselected : ¬ordinal < snapshots.length) : + evalDist (Bool.not <$> + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (pure value) snapshots observations left fuel cache) = + evalDist (Bool.not <$> + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (pure value) snapshots observations right fuel cache) := by + rw [evalDist_map, evalDist_map, + evalDist_directDelayedSelectedRootIndicator_pure_eq_of_unselected_context ordinal parameter + root ftsSecret table target rightRoot value snapshots observations left right fuel cache + hselected] + +set_option maxRecDepth 100000 in +theorem evalDist_eagerDirectDelayedSelectedRootIndicator_uniform_eq + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (n : Nat) (next : Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hselected : ¬ordinal < snapshots.length) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hpublished : PublishedValues context.state) + (hnext : ∀ output, + evalDist (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table + target rightRoot (next output) snapshots observations + (canonicalizeMaterializedValues table context) fuel cache) = + evalDist (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next output) snapshots observations + (canonicalizeMaterializedValues table context) fuel cache)) : + evalDist + (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inl n))) >>= next) + snapshots observations context fuel cache) = + evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inl n))) >>= next) + snapshots observations context fuel cache) := by + let uniform : ProbComp (Fin (n + 1)) := liftM (unifSpec.query n) + let observe : DeferredContext → Nat → (Fin (n + 1) × SplitHashCache) → + List PlannedProbeSnapshot → List CleanProbeObservation → ProbComp Bool := + fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (next value.1) laterSnapshots laterObservations nextContext remaining value.2 + unfold eagerDirectDelayedSelectedRootIndicator + simp only [hselected, ↓reduceIte] + rw [directDelayedSelectedRootIndicator_uniform_eq ordinal parameter root ftsSecret table target + rightRoot n next snapshots observations context fuel cache hselected] + calc + _ = evalDist (resolveDeferredPositionValue target context >>= fun resolved ↦ + match resolved with + | none => pure false + | some resolved => + runDirectResolvedWitnessFromTable resolved.toDeferredContext fuel table + ((splitUniformImpl n).run cache) >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + simpa only using congrArg evalDist + (directDelayedSelectedRootIndicator_uniform_eq ordinal parameter root ftsSecret table + target rightRoot n next snapshots observations resolved.toDeferredContext fuel cache + hselected) + _ = evalDist (resolveDeferredPositionValue target context >>= fun resolved ↦ + uniform >>= fun output ↦ + match resolved with + | none => pure false + | some resolved => + canonicalizeDirectDelayedSelectedRootIndicator table observe + resolved.toDeferredContext fuel (output, cache) snapshots observations) := by + simp_rw [runDirectResolvedWitnessFromTable_splitUniformImpl] + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved with + | none => + exact (OracleComp.DeferredSampling.evalDist_bind_const_neverFails uniform + (by simp [uniform]) (pure false)).symm + | some resolved => + simp [finishDirectDelayedSelectedRootIndicator, uniform] + _ = evalDist (uniform >>= fun output ↦ + resolveDeferredPositionValue target context >>= fun resolved ↦ + match resolved with + | none => pure false + | some resolved => + canonicalizeDirectDelayedSelectedRootIndicator table observe + resolved.toDeferredContext fuel (output, cache) snapshots observations) := by + exact OracleComp.DeferredSampling.evalDist_bind_comm + (resolveDeferredPositionValue target context) uniform + (fun resolved output ↦ + match resolved with + | none => pure false + | some resolved => + canonicalizeDirectDelayedSelectedRootIndicator table observe + resolved.toDeferredContext fuel (output, cache) snapshots observations) + _ = evalDist (uniform >>= fun output ↦ + canonicalizeDirectDelayedSelectedRootIndicator table observe context fuel + (output, cache) snapshots observations) := by + apply evalDist_bind_congr + intro output _houtput + apply evalDist_resolveDeferredPositionValue_then_canonicalizeDirectDelayed table target + observe context fuel (output, cache) snapshots observations hvalid hcompletable hpublished + simpa [eagerDirectDelayedSelectedRootIndicator, hselected, observe] using hnext output + _ = _ := by + simp [uniform, observe, runDirectResolvedWitnessFromTable_splitUniformImpl, + finishDirectDelayedSelectedRootIndicator] + +set_option maxRecDepth 100000 in +theorem evalDist_eagerDirectDelayedSelectedRootIndicator_signing_eq + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (message : Message) + (next : Option Signature → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hselected : ¬ordinal < snapshots.length) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + [ObserverSynchronized table + (negatedDirectDelayedObserve + (fun nextContext remaining (value : Option Signature × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2) + snapshots observations)] + [ObserverPositionNeutral table + (negatedDirectDelayedObserve + (fun nextContext remaining (value : Option Signature × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2) + snapshots observations)] : + evalDist + (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) (Sum.inr message)) >>= next) + snapshots observations context fuel cache) = + evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) (Sum.inr message)) >>= next) + snapshots observations context fuel cache) := by + let observe := fun nextContext remaining (value : Option Signature × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (next value.1) laterSnapshots laterObservations nextContext remaining value.2 + rw [directDelayedSelectedRootIndicator_signing_eq ordinal parameter root ftsSecret table target + rightRoot message next snapshots observations context fuel cache hselected] + unfold eagerDirectDelayedSelectedRootIndicator + simp only [hselected, ↓reduceIte] + calc + _ = evalDist (resolveDeferredPositionValue target context >>= fun resolved ↦ + match resolved with + | none => pure false + | some resolved => + runDirectResolvedWitnessFromTable resolved.toDeferredContext fuel table + ((maskedSign parameter root ftsSecret message).run cache) >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + simpa only [observe] using congrArg evalDist + (directDelayedSelectedRootIndicator_signing_eq ordinal parameter root ftsSecret table + target rightRoot message next snapshots observations resolved.toDeferredContext + fuel cache hselected) + _ = _ := evalDist_resolve_then_runDirectWitness_finish_false table target observe snapshots + observations ((maskedSign parameter root ftsSecret message).run cache) context fuel hvalid + hcompletable + +set_option maxRecDepth 100000 in +theorem relTriple_directDelayed_eagerDirectDelayed_hash_selected + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hbefore : ¬ordinal < snapshots.length) + (hselected : ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length) : + RelTriple + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) + (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) + (EqRel Bool) := by + classical + let candidate? := rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state) + let nextSnapshots := appendPlannedSnapshot snapshots candidate? context + have hnowSelected : ordinal < nextSnapshots.length := by + simpa [nextSnapshots, candidate?] using hselected + have hcandidateExists : ∃ candidate, candidate? = some candidate := by + cases hcandidate : candidate? with + | none => + exfalso + apply hbefore + simpa [nextSnapshots, hcandidate, appendPlannedSnapshot] using hnowSelected + | some candidate => exact ⟨candidate, rfl⟩ + obtain ⟨candidate, hcandidate⟩ := hcandidateExists + have hnextSnapshots : nextSnapshots = + snapshots ++ [(⟨candidate, context⟩ : PlannedProbeSnapshot)] := by + simp [nextSnapshots, hcandidate, appendPlannedSnapshot] + have hordinal : snapshots.length = ordinal := by + rw [hnextSnapshots] at hnowSelected + simp only [List.length_append, List.length_singleton] at hnowSelected + omega + have hget : nextSnapshots.get ⟨ordinal, hnowSelected⟩ = + (⟨candidate, context⟩ : PlannedProbeSnapshot) := by + subst ordinal + simp [nextSnapshots, appendPlannedSnapshot, hcandidate, List.get_eq_getElem] + rw [directDelayedSelectedRootIndicator_hash_eq_selected ordinal parameter root ftsSecret table + target rightRoot input next snapshots observations context fuel cache hbefore hselected] + rw [show (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).get + ⟨ordinal, hselected⟩ = (⟨candidate, context⟩ : PlannedProbeSnapshot) by + simpa [nextSnapshots, candidate?] using hget] + unfold eagerDirectDelayedSelectedRootIndicator + simp only [hbefore, ↓reduceIte] + unfold delayedSelectedRootIndicator + have hresolve := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + (relTriple_refl (resolveDeferredPositionValue target context)) + (fun resolved => resolved ∈ support (resolveDeferredPositionValue target context)) + (fun resolved hresolved => hresolved) + apply relTriple_bind hresolve + intro leftResolved rightResolved hrelation + obtain ⟨rfl, hresolved⟩ := hrelation + cases leftResolved with + | none => exact relTriple_pure_pure rfl + | some resolved => + have hvalues := resolveDeferredPositionValue_preserves_state_values target context resolved + hresolved + have hplan : purePlanProbingHashQuery parameter input resolved.state = + purePlanProbingHashQuery parameter input context.state := + purePlanProbingHashQuery_eq_of_values_eq hvalues parameter input + have hcandidateResolved : rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input resolved.state) = some candidate := by + rw [hplan] + simpa [candidate?] using hcandidate + have hselectedResolved : ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input resolved.state)) + resolved.toDeferredContext).length := by + simp [appendPlannedSnapshot, hcandidateResolved, ← hordinal] + have hgetResolved : + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input resolved.state)) + resolved.toDeferredContext).get ⟨ordinal, hselectedResolved⟩ = + (⟨candidate, resolved.toDeferredContext⟩ : PlannedProbeSnapshot) := by + subst ordinal + simp [appendPlannedSnapshot, hcandidateResolved, List.get_eq_getElem] + simp only + rw [directDelayedSelectedRootIndicator_hash_eq_selected ordinal parameter root ftsSecret table + target rightRoot input next snapshots observations resolved.toDeferredContext fuel cache + hbefore hselectedResolved] + rw [hgetResolved] + unfold delayedSelectedRootIndicator + rw [resolveDeferredPositionValue_of_resolved target context resolved hresolved] + simp only [pure_bind] + have hcandidates : + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input resolved.state)) + resolved.toDeferredContext).map PlannedProbeSnapshot.toProbe = + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) + context).map PlannedProbeSnapshot.toProbe := by + have hcandidateBase : rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state) = some candidate := by + simpa [candidate?] using hcandidate + simp [appendPlannedSnapshot, hcandidateResolved, hcandidateBase] + rw [hcandidates] + let selection : PrivateOrdinalSelection := + ⟨candidate, context, + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).map + PlannedProbeSnapshot.toProbe⟩ + change RelTriple + (if CandidatesAvoidRoots target (truncateHash resolved.output) rightRoot + (selection.candidates.take ordinal) then + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) <$> + observedMaterializedBoundary parameter root ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations (materializedDeferredState resolved.toDeferredContext) fuel table cache + else pure false) + (if CandidatesAvoidRoots target (truncateHash resolved.output) rightRoot + (selection.candidates.take ordinal) then + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) <$> + observedMaterializedBoundary parameter root ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations (materializedDeferredState resolved.toDeferredContext) fuel table cache + else pure false) + (EqRel Bool) + by_cases hsafe : CandidatesAvoidRoots target (truncateHash resolved.output) rightRoot + (selection.candidates.take ordinal) + · simp only [hsafe, ↓reduceIte] + exact relTriple_refl _ + · simp only [hsafe, ↓reduceIte] + exact relTriple_pure_pure rfl + +theorem evalDist_eagerDirectDelayedSelectedRootIndicator_hash_eq_selected + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hbefore : ¬ordinal < snapshots.length) + (hselected : ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length) : + evalDist + (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) = + evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) := by + exact (evalDist_eq_of_relTriple_eqRel + (relTriple_directDelayed_eagerDirectDelayed_hash_selected ordinal parameter root ftsSecret + table target rightRoot input next snapshots observations context fuel cache hbefore + hselected)).symm + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 1000000 in +theorem evalDist_eagerDirectDelayedSelectedRootIndicator_hash_eq_not_selected_of_trace + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hbefore : ¬ordinal < snapshots.length) + (hnotSelected : ¬ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + [ObserverSynchronized table + (negatedDirectDelayedObserve + (fun nextContext remaining (value : HashOutput × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2) + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context) + (observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state))))] + [ObserverPositionNeutral table + (negatedDirectDelayedObserve + (fun nextContext remaining (value : HashOutput × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2) + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context) + (observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state))))] + (htrace : ∀ (resolved : DeferredResolution) + (_hresolved : some resolved ∈ support + (resolveDeferredPositionValue target context)), + evalDist + (runDirectResolvedWitnessFromTable resolved.toDeferredContext fuel table + ((probingHashQueryAfterRootAwarePlan parameter input + (purePlanProbingHashQuery parameter input context.state)).run cache) >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2)) + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) + resolved.toDeferredContext) + (observationsAfterCandidate observations + (materializedDeferredState resolved.toDeferredContext) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)))) = + evalDist + (runDirectResolvedWitnessFromTable resolved.toDeferredContext fuel table + ((probingHashQueryAfterRootAwarePlan parameter input + (purePlanProbingHashQuery parameter input context.state)).run cache) >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2)) + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context) + (observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state))))) : + evalDist + (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) = + evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) := by + rw [directDelayedSelectedRootIndicator_hash_eq_not_selected ordinal parameter root ftsSecret table + target rightRoot input next snapshots observations context fuel cache hbefore hnotSelected] + unfold eagerDirectDelayedSelectedRootIndicator + simp only [hbefore, ↓reduceIte] + calc + _ = evalDist (resolveDeferredPositionValue target context >>= fun resolved ↦ + match resolved with + | none => pure false + | some resolved => + runDirectResolvedWitnessFromTable resolved.toDeferredContext fuel table + ((probingHashQueryAfterRootAwarePlan parameter input + (purePlanProbingHashQuery parameter input context.state)).run cache) >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table + target rightRoot (next value.1) laterSnapshots laterObservations nextContext + remaining value.2)) + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context) + (observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)))) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hvalues := resolveDeferredPositionValue_preserves_state_values target context + resolved hresolved + have hplan : purePlanProbingHashQuery parameter input resolved.state = + purePlanProbingHashQuery parameter input context.state := + purePlanProbingHashQuery_eq_of_values_eq hvalues parameter input + have hnotSelectedResolved : ¬ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input resolved.state)) + resolved.toDeferredContext).length := by + rw [hplan] + have hlength : + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) + resolved.toDeferredContext).length = + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length := by + cases rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state) <;> + simp [appendPlannedSnapshot] + rw [hlength] + exact hnotSelected + simp only + rw [directDelayedSelectedRootIndicator_hash_eq_not_selected ordinal parameter root + ftsSecret table target rightRoot input next snapshots observations + resolved.toDeferredContext fuel cache hbefore hnotSelectedResolved] + rw [hplan] + exact htrace resolved hresolved + _ = _ := evalDist_resolve_then_runDirectWitness_finish_false table target + (fun nextContext remaining (value : HashOutput × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (next value.1) laterSnapshots laterObservations nextContext remaining value.2) + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context) + (observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state))) + ((probingHashQueryAfterRootAwarePlan parameter input + (purePlanProbingHashQuery parameter input context.state)).run cache) + context fuel hvalid hcompletable + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 1000000 in +theorem evalDist_eagerDirectDelayedSelectedRootIndicator_hash_eq_not_selected_of_clean_avoids + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hbefore : ¬ordinal < snapshots.length) + (hnotSelected : ¬ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + [ObserverSynchronized table + (negatedDirectDelayedObserve + (fun nextContext remaining (value : HashOutput × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2) + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context) + (observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state))))] + [ObserverPositionNeutral table + (negatedDirectDelayedObserve + (fun nextContext remaining (value : HashOutput × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2) + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context) + (observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state))))] + (hclean : ∀ observation ∈ + observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)), + ¬observation.ExistingHiddenHit) + (havoid : ∀ resolved : DeferredResolution, + some resolved ∈ support (resolveDeferredPositionValue target context) → + CandidatesAvoidRoot target (truncateHash resolved.output) + ((observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state))).map + CleanProbeObservation.toProbe)) : + evalDist + (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) = + evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) := by + apply evalDist_eagerDirectDelayedSelectedRootIndicator_hash_eq_not_selected_of_trace ordinal + parameter root ftsSecret table target rightRoot input next snapshots observations context fuel + cache hbefore hnotSelected hvalid hcompletable + intro resolved hresolved + have hvalues := resolveDeferredPositionValue_preserves_state_values target context resolved + hresolved + have hplan : purePlanProbingHashQuery parameter input resolved.state = + purePlanProbingHashQuery parameter input context.state := + purePlanProbingHashQuery_eq_of_values_eq hvalues parameter input + let candidate? := rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state) + let leftSnapshots := appendPlannedSnapshot snapshots candidate? resolved.toDeferredContext + let rightSnapshots := appendPlannedSnapshot snapshots candidate? context + let leftObservations := observationsAfterCandidate observations + (materializedDeferredState resolved.toDeferredContext) candidate? + let rightObservations := observationsAfterCandidate observations + (materializedDeferredState context) candidate? + have hsnapshots : leftSnapshots.map PlannedProbeSnapshot.toProbe = + rightSnapshots.map PlannedProbeSnapshot.toProbe := by + cases hcandidate : candidate? <;> + simp [leftSnapshots, rightSnapshots, appendPlannedSnapshot, hcandidate] + have hlength : leftSnapshots.length = rightSnapshots.length := + plannedProbeSnapshots_length_eq_of_toProbe_eq hsnapshots + have hrightBefore : ¬ordinal < rightSnapshots.length := by + simpa [rightSnapshots, candidate?] using hnotSelected + have hleftBefore : ¬ordinal < leftSnapshots.length := by + rwa [hlength] + have htrace : CleanProbeObservationsEventEq leftObservations rightObservations := by + apply observationsAfterCandidate_eventEq_resolved_current_of_clean_of_avoids target context + resolved hresolved observations candidate? + · simpa [rightObservations, candidate?] using hclean + · simpa [rightObservations, candidate?] using havoid resolved hresolved + apply evalDist_bind_congr + intro result _hresult + cases result with + | stoppedFuel => rfl + | stoppedOrdinary => rfl + | stoppedPrivate witness => rfl + | done result => + simp only [finishDirectDelayedSelectedRootIndicator, + canonicalizeDirectDelayedSelectedRootIndicator] + split + · rfl + · split + · split + · exact evalDist_directDelayedSelectedRootIndicator_eq_of_eventEq ordinal parameter root + ftsSecret table target rightRoot (next result.value.1) leftSnapshots rightSnapshots + leftObservations rightObservations + (canonicalizeMaterializedValues table result.context) result.remaining result.value.2 + hleftBefore hrightBefore hsnapshots htrace + · rfl + · rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizeLift.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizeLift.lean new file mode 100644 index 00000000..0838b673 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizeLift.lean @@ -0,0 +1,2599 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizeSupport + +/-! +# Structural adaptive normalization + +This module lifts eager target resolution through an arbitrary outer computation. The delayed +indicator can only succeed when every observation preceding its selected ordinal is hit-free, which +supplies the invariant needed by the nonselected hash step. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem no_existingHiddenHit_of_prefix_of_firstExistingHiddenHitAt + (before : List CleanProbeObservation) (result : ObservedCleanRunResult α) + (ordinal : Nat) (hprefix : before <+: result.observations) + (hlength : before.length ≤ ordinal) + (hfirst : FirstExistingHiddenHitAt result ordinal) : + ∀ observation ∈ before, ¬observation.ExistingHiddenHit := by + intro observation hobservation + obtain ⟨beforeIndex, hget⟩ := List.mem_iff_get.mp hobservation + obtain ⟨selected, hselected, _hhit, hearlier⟩ := hfirst + let resultIndex : Fin result.observations.length := + ⟨beforeIndex.val, beforeIndex.isLt.trans_le hprefix.length_le⟩ + have hresultGet : result.observations.get resultIndex = observation := by + rw [← hget] + exact (hprefix.getElem beforeIndex.isLt).symm + have hbeforeOrdinal : resultIndex.val < ordinal := beforeIndex.isLt.trans_le hlength + rw [← hresultGet] + exact hearlier resultIndex hbeforeOrdinal + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem no_existingHiddenHit_of_true_mem_directDelayedSelectedRootIndicator + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (haligned : observations.length = snapshots.length) + (hlength : snapshots.length ≤ ordinal) + (htrue : true ∈ support + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + computation snapshots observations context fuel cache)) : + ∀ observation ∈ observations, ¬observation.ExistingHiddenHit := by + classical + induction computation using OracleComp.inductionOn generalizing + snapshots observations context fuel cache with + | pure value => + have hbefore : ¬ordinal < snapshots.length := by omega + simp [directDelayedSelectedRootIndicator, hbefore] at htrue + | query_bind query next ih => + have hbefore : ¬ordinal < snapshots.length := by omega + have continueAfter + (runComputation : OracleComp (LazyRevealProbe.World Coordinate) + ((OracleWorld + SigningSpec).Range query × SplitHashCache)) + (nextSnapshots : List PlannedProbeSnapshot) + (nextObservations : List CleanProbeObservation) + (hnextAligned : nextObservations.length = nextSnapshots.length) + (hnextLength : nextSnapshots.length ≤ ordinal) + (hnextTrue : true ∈ support + (runDirectResolvedWitnessFromTable context fuel table runComputation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table + target rightRoot (next value.1) laterSnapshots laterObservations nextContext + remaining value.2)) + nextSnapshots nextObservations)) : + ∀ observation ∈ nextObservations, ¬observation.ExistingHiddenHit := by + rw [mem_support_bind_iff] at hnextTrue + obtain ⟨result, hresult, hfinish⟩ := hnextTrue + cases result with + | stoppedFuel => simp [finishDirectDelayedSelectedRootIndicator] at hfinish + | stoppedOrdinary => simp [finishDirectDelayedSelectedRootIndicator] at hfinish + | stoppedPrivate witness => simp [finishDirectDelayedSelectedRootIndicator] at hfinish + | done result => + let canonical := canonicalizeMaterializedValues table result.context + unfold finishDirectDelayedSelectedRootIndicator at hfinish + unfold canonicalizeDirectDelayedSelectedRootIndicator at hfinish + change true ∈ support + (if PrivateStructuralHit canonical then pure false + else if PublishedValues result.context.state then + if DeferredCompletable table canonical then + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table + target rightRoot (next result.value.1) nextSnapshots nextObservations + canonical result.remaining result.value.2 + else pure false + else pure false) at hfinish + by_cases hhit : PrivateStructuralHit canonical + · simp [hhit] at hfinish + · by_cases hpublished : PublishedValues result.context.state + · by_cases hcompletable : DeferredCompletable table canonical + · simp only [hhit, hpublished, hcompletable, ↓reduceIte] at hfinish + exact ih result.value.1 nextSnapshots nextObservations canonical + result.remaining result.value.2 hnextAligned hnextLength hfinish + · simp [hhit, hpublished, hcompletable] at hfinish + · simp [hhit, hpublished] at hfinish + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [directDelayedSelectedRootIndicator_uniform_eq ordinal parameter root ftsSecret + table target rightRoot n next snapshots observations context fuel cache hbefore] + at htrue + exact continueAfter ((splitUniformImpl n).run cache) snapshots observations haligned + hlength htrue + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextSnapshots := appendPlannedSnapshot snapshots candidate? context + let nextObservations := observationsAfterCandidate observations + (materializedDeferredState context) candidate? + have hnextAligned : nextObservations.length = nextSnapshots.length := by + cases hcandidate : candidate? <;> + simp [nextSnapshots, nextObservations, observationsAfterCandidate, + appendPlannedSnapshot, hcandidate, haligned] + by_cases hselected : ordinal < nextSnapshots.length + · rw [directDelayedSelectedRootIndicator_hash_eq_selected ordinal parameter root + ftsSecret table target rightRoot input next snapshots observations context fuel + cache hbefore (by simpa [nextSnapshots, candidate?, plan] using hselected)] at htrue + unfold delayedSelectedRootIndicator at htrue + rw [mem_support_bind_iff] at htrue + obtain ⟨resolvedOption, _hresolvedOption, hrest⟩ := htrue + cases resolvedOption with + | none => simp at hrest + | some resolved => + simp only at hrest + split at hrest + · rw [support_map] at hrest + obtain ⟨observed, hobserved, hindicator⟩ := hrest + have hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot observed := by + change successfulObservedRootComparisonIndicator table ordinal target + (observed, rightRoot) = true at hindicator + rw [successfulObservedRootComparisonIndicator_eq_true_iff] at hindicator + exact hindicator + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + at hgood + | some result => + obtain ⟨⟨⟨⟨_finalResult, _hfinish⟩, + _selected, _hselected, hfirst, _hroot⟩, _hposition⟩, + _hcomparison⟩ := hgood + have hprefix := observations_prefix_of_mem_observedMaterializedBoundary + parameter root ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache + result hobserved + exact no_existingHiddenHit_of_prefix_of_firstExistingHiddenHitAt + observations result ordinal hprefix (by omega) hfirst + · simp at hrest + · have hnextLength : nextSnapshots.length ≤ ordinal := by omega + rw [directDelayedSelectedRootIndicator_hash_eq_not_selected ordinal parameter root + ftsSecret table target rightRoot input next snapshots observations context fuel + cache hbefore (by simpa [nextSnapshots, candidate?, plan] using hselected)] at htrue + have hnextClean := continueAfter + ((probingHashQueryAfterRootAwarePlan parameter input plan).run cache) + nextSnapshots nextObservations hnextAligned hnextLength htrue + intro observation hobservation + apply hnextClean observation + cases hcandidate : candidate? with + | none => simpa [nextObservations, observationsAfterCandidate, hcandidate] + using hobservation + | some candidate => + simp only [nextObservations, observationsAfterCandidate, hcandidate, + List.mem_append, List.mem_singleton] + exact Or.inl hobservation + | inr message => + rw [directDelayedSelectedRootIndicator_signing_eq ordinal parameter root ftsSecret table + target rightRoot message next snapshots observations context fuel cache hbefore] at htrue + exact continueAfter ((maskedSign parameter root ftsSecret message).run cache) snapshots + observations haligned hlength htrue + +set_option maxRecDepth 100000 in +theorem no_existingHiddenHit_afterCandidate_of_true_mem_hash_not_selected + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hbefore : ¬ordinal < snapshots.length) + (hnotSelected : ¬ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length) + (haligned : observations.length = snapshots.length) + (htrue : true ∈ support + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache)) : + ∀ observation ∈ + observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)), + ¬observation.ExistingHiddenHit := by + classical + let plan := purePlanProbingHashQuery parameter input context.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextSnapshots := appendPlannedSnapshot snapshots candidate? context + let nextObservations := observationsAfterCandidate observations + (materializedDeferredState context) candidate? + have hnextAligned : nextObservations.length = nextSnapshots.length := by + cases hcandidate : candidate? <;> + simp [nextSnapshots, nextObservations, observationsAfterCandidate, + appendPlannedSnapshot, hcandidate, haligned] + have hnextLength : nextSnapshots.length ≤ ordinal := by + simpa [nextSnapshots, candidate?, plan] using Nat.le_of_not_gt hnotSelected + rw [directDelayedSelectedRootIndicator_hash_eq_not_selected ordinal parameter root ftsSecret + table target rightRoot input next snapshots observations context fuel cache hbefore + hnotSelected] at htrue + rw [mem_support_bind_iff] at htrue + obtain ⟨result, hresult, hfinish⟩ := htrue + cases result with + | stoppedFuel => simp [finishDirectDelayedSelectedRootIndicator] at hfinish + | stoppedOrdinary => simp [finishDirectDelayedSelectedRootIndicator] at hfinish + | stoppedPrivate witness => simp [finishDirectDelayedSelectedRootIndicator] at hfinish + | done result => + let canonical := canonicalizeMaterializedValues table result.context + unfold finishDirectDelayedSelectedRootIndicator at hfinish + unfold canonicalizeDirectDelayedSelectedRootIndicator at hfinish + change true ∈ support + (if PrivateStructuralHit canonical then pure false + else if PublishedValues result.context.state then + if DeferredCompletable table canonical then + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next result.value.1) nextSnapshots nextObservations canonical + result.remaining result.value.2 + else pure false + else pure false) at hfinish + by_cases hhit : PrivateStructuralHit canonical + · simp [hhit] at hfinish + · by_cases hpublished : PublishedValues result.context.state + · by_cases hcompletable : DeferredCompletable table canonical + · simp only [hhit, hpublished, hcompletable, ↓reduceIte] at hfinish + exact no_existingHiddenHit_of_true_mem_directDelayedSelectedRootIndicator ordinal + parameter root ftsSecret table target rightRoot (next result.value.1) + nextSnapshots nextObservations canonical result.remaining result.value.2 + hnextAligned hnextLength hfinish + · simp [hhit, hpublished, hcompletable] at hfinish + · simp [hhit, hpublished] at hfinish + +theorem resolveDeferredPositionValue_output_eq_of_positionValue + (position : Position) (context : DeferredContext) (known : HashOutput) + (resolved : DeferredResolution) + (hknown : context.positionValue position = some known) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue position context)) : + resolved.output = known := by + cases hstate : context.state.values (.position position) with + | some output => + have hknownOutput : output = known := by + simpa [DeferredContext.positionValue, hstate] using hknown + unfold resolveDeferredPositionValue at hresolved + simp only [hstate] at hresolved + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresolved + · simp [hhit] at hresolved + subst resolved + exact hknownOutput + | none => + cases hprivate : context.values position with + | some output => + have hknownOutput : output = known := by + simpa [DeferredContext.positionValue, hstate, hprivate] using hknown + unfold resolveDeferredPositionValue at hresolved + simp only [hstate, hprivate] at hresolved + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresolved + · simp [hhit] at hresolved + subst resolved + exact hknownOutput + | none => + simp [DeferredContext.positionValue, hstate, hprivate] at hknown + +theorem existingHiddenHit_cleanProbeObservation_materializedDeferredState_resolved + (target : Position) (context : DeferredContext) (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target context)) + (candidate : Probe) + (hhit : (cleanProbeObservation (materializedDeferredState context) + candidate.coordinate candidate.candidate).ExistingHiddenHit) : + (cleanProbeObservation (materializedDeferredState resolved.toDeferredContext) + candidate.coordinate candidate.candidate).ExistingHiddenHit := by + rw [cleanProbeObservation_materializedDeferredState_resolved target context resolved hresolved] + by_cases hcoordinate : candidate.coordinate = .position target + · rw [installPositionValueAtProbe_existingHiddenHit_iff_of_target target resolved.output _ + hcoordinate] + unfold CleanProbeObservation.ExistingHiddenHit at hhit + simp only [cleanProbeObservation, decide_eq_false_iff_not] at hhit ⊢ + refine ⟨hhit.1, ?_⟩ + obtain ⟨known, hknown, hdigest⟩ := hhit.2 + have hpositionValue : context.positionValue target = some known := by + simpa [materializedDeferredState_position, hcoordinate] using hknown + have houtput := resolveDeferredPositionValue_output_eq_of_positionValue target context known + resolved hpositionValue hresolved + simpa [houtput] using hdigest + · rw [installPositionValueAtProbe_existingHiddenHit_iff_of_ne target resolved.output _ + hcoordinate] + exact hhit + +theorem not_clean_observationsAfterCandidate_resolved + (target : Position) (context : DeferredContext) (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target context)) + (observations : List CleanProbeObservation) (candidate? : Option Probe) + (hclean : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hdirty : ¬∀ observation ∈ + observationsAfterCandidate observations (materializedDeferredState context) candidate?, + ¬observation.ExistingHiddenHit) : + ¬∀ observation ∈ + observationsAfterCandidate observations + (materializedDeferredState resolved.toDeferredContext) candidate?, + ¬observation.ExistingHiddenHit := by + cases candidate? with + | none => simpa [observationsAfterCandidate] using hdirty + | some candidate => + intro hresolvedClean + apply hdirty + intro observation hobservation + simp only [observationsAfterCandidate, List.mem_append, List.mem_singleton] at hobservation + rcases hobservation with hold | rfl + · exact hclean observation hold + · intro hhit + exact hresolvedClean + (cleanProbeObservation (materializedDeferredState resolved.toDeferredContext) + candidate.coordinate candidate.candidate) + (by simp [observationsAfterCandidate]) + (existingHiddenHit_cleanProbeObservation_materializedDeferredState_resolved + target context resolved hresolved candidate hhit) + +theorem relTriple_eq_false_of_true_not_mem + (run : ProbComp Bool) (hfalse : true ∉ support run) : + RelTriple run (pure false : ProbComp Bool) (EqRel Bool) := by + have hleft := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + (relTriple_true run (pure false : ProbComp Bool)) + (fun value ↦ value ∈ support run) (fun _ hvalue ↦ hvalue) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro left right hrelation + have hright : right = false := by simpa using hrelation.2 + subst right + cases left with + | false => rfl + | true => exact (hfalse hrelation.1.2).elim + +set_option maxRecDepth 100000 in +theorem true_not_mem_eagerDirectDelayed_hash_of_dirty_not_selected + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hbefore : ¬ordinal < snapshots.length) + (hnotSelected : ¬ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length) + (haligned : observations.length = snapshots.length) + (hclean : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hdirty : ¬∀ observation ∈ + observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)), + ¬observation.ExistingHiddenHit) : + true ∉ support + (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) := by + intro htrue + unfold eagerDirectDelayedSelectedRootIndicator at htrue + simp only [hbefore, ↓reduceIte] at htrue + rw [mem_support_bind_iff] at htrue + obtain ⟨resolvedOption, hresolvedOption, hrest⟩ := htrue + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hvalues := resolveDeferredPositionValue_preserves_state_values target context resolved + hresolvedOption + have hplan : purePlanProbingHashQuery parameter input resolved.state = + purePlanProbingHashQuery parameter input context.state := + purePlanProbingHashQuery_eq_of_values_eq hvalues parameter input + have hnotSelectedResolved : ¬ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input resolved.state)) + resolved.toDeferredContext).length := by + rw [hplan] + have hlength : + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) + resolved.toDeferredContext).length = + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length := by + cases rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state) <;> + simp [appendPlannedSnapshot] + rw [hlength] + exact hnotSelected + have hresolvedDirty := not_clean_observationsAfterCandidate_resolved target context resolved + hresolvedOption observations + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) hclean hdirty + have hresolvedClean := + no_existingHiddenHit_afterCandidate_of_true_mem_hash_not_selected ordinal parameter root + ftsSecret table target rightRoot input next snapshots observations + resolved.toDeferredContext fuel cache hbefore hnotSelectedResolved haligned (by + simpa [hplan] using hrest) + apply hresolvedDirty + simpa [hplan] using hresolvedClean + +set_option maxRecDepth 100000 in +theorem relTriple_directDelayed_eagerDirectDelayed_hash_not_selected_general + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hbefore : ¬ordinal < snapshots.length) + (hnotSelected : ¬ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (haligned : observations.map CleanProbeObservation.toProbe = + snapshots.map PlannedProbeSnapshot.toProbe) + (hclean : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hsynchronized : + (∀ observation ∈ + observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)), + ¬observation.ExistingHiddenHit) → + ObserverSynchronized table + (negatedDirectDelayedObserve + (fun nextContext remaining (value : HashOutput × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2) + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context) + (observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state))))) + (hneutral : + (∀ observation ∈ + observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)), + ¬observation.ExistingHiddenHit) → + ObserverPositionNeutral table + (negatedDirectDelayedObserve + (fun nextContext remaining (value : HashOutput × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2) + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context) + (observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state))))) : + RelTriple + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) + (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) + (EqRel Bool) := by + have hlength : observations.length = snapshots.length := by + simpa only [List.length_map] using congrArg List.length haligned + let nextObservations := observationsAfterCandidate observations + (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) + by_cases hnextClean : ∀ observation ∈ nextObservations, + ¬observation.ExistingHiddenHit + · letI := hsynchronized (by simpa [nextObservations] using hnextClean) + letI := hneutral (by simpa [nextObservations] using hnextClean) + have hnextAligned : + nextObservations.map CleanProbeObservation.toProbe = + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).map + PlannedProbeSnapshot.toProbe := by + cases hcandidate : rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state) <;> + simp [nextObservations, observationsAfterCandidate, appendPlannedSnapshot, hcandidate, + CleanProbeObservation.toProbe, cleanProbeObservation, haligned] + exact relTriple_directDelayed_eagerDirectDelayed_hash_not_selected ordinal parameter root + ftsSecret table target rightRoot input next snapshots observations context fuel cache + hbefore hnotSelected hvalid hcompletable hnextAligned + (by simpa [nextObservations] using hnextClean) + · have hdirectFalse : true ∉ support + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) := by + intro htrue + apply hnextClean + exact no_existingHiddenHit_afterCandidate_of_true_mem_hash_not_selected ordinal parameter + root ftsSecret table target rightRoot input next snapshots observations context fuel cache + hbefore hnotSelected hlength htrue + have hleft := relTriple_eq_false_of_true_not_mem _ hdirectFalse + have hright := relTriple_eq_false_of_true_not_mem _ + (true_not_mem_eagerDirectDelayed_hash_of_dirty_not_selected ordinal parameter root ftsSecret + table target rightRoot input next snapshots observations context fuel cache hbefore + hnotSelected hlength hclean (by simpa [nextObservations] using hnextClean)) + have hglued := SphincsSecurity.relTriple_trans_exists hleft (relTriple_symm hright) + apply relTriple_post_mono hglued + intro left right hrelation + obtain ⟨middle, hleftEq, hrightEq⟩ := hrelation + exact hleftEq.trans hrightEq.symm + +noncomputable def negatedDirectDelayedComputationObserve + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : ProbComp Bool := + Bool.not <$> directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot computation snapshots observations context fuel cache + +theorem negatedDirectDelayedComputationObserve_pure_eq_true + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (value : α) (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hbefore : snapshots.length ≤ ordinal) : + negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot (pure value) snapshots observations context fuel cache = + pure true := by + have hnotSelected : ¬ordinal < snapshots.length := by omega + simp [negatedDirectDelayedComputationObserve, directDelayedSelectedRootIndicator, + hnotSelected] + +theorem negatedDirectDelayedComputationObserve_pure_observerSynchronized + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (value : α) (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (hbefore : snapshots.length ≤ ordinal) : + ObserverSynchronized table + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot (pure value) snapshots observations) where + eq_of_synchronized left right fuel cache _hcontext _hvalues _hrevealed := by + rw [negatedDirectDelayedComputationObserve_pure_eq_true ordinal parameter root ftsSecret table + target rightRoot value snapshots observations left fuel cache hbefore] + rw [negatedDirectDelayedComputationObserve_pure_eq_true ordinal parameter root ftsSecret table + target rightRoot value snapshots observations right fuel cache hbefore] + +theorem negatedDirectDelayedComputationObserve_pure_observerPositionNeutral + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (value : α) (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (hbefore : snapshots.length ≤ ordinal) : + ObserverPositionNeutral table + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot (pure value) snapshots observations) where + eq_resolve position context fuel cache _hvalid _hcompletable _hensured := by + rw [negatedDirectDelayedComputationObserve_pure_eq_true ordinal parameter root ftsSecret table + target rightRoot value snapshots observations context fuel cache hbefore] + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun _ ↦ + (pure true : ProbComp Bool)) := by + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved with + | none => rfl + | some resolved => + simp only + rw [negatedDirectDelayedComputationObserve_pure_eq_true ordinal parameter root + ftsSecret table target rightRoot value snapshots observations + resolved.toDeferredContext fuel cache hbefore] + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolveDeferredPositionValue position context) + (by simp [resolveDeferredPositionValue, LazyRevealProbe.sampleHashOutput]) + (pure true) + +theorem negatedDirectDelayedComputationObserve_pure_observerPositionNeutralAt + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target position : Position) + (rightRoot : Digest) (value : α) (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (hbefore : snapshots.length ≤ ordinal) : + ObserverPositionNeutralAt table position + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot (pure value) snapshots observations) := by + letI := negatedDirectDelayedComputationObserve_pure_observerPositionNeutral ordinal parameter + root ftsSecret table target rightRoot value snapshots observations hbefore + exact ObserverPositionNeutral.at table position _ + +set_option maxRecDepth 100000 in +theorem evalDist_resolve_then_complement_runDirectWitness_finish_false + (table : OtsSecretIndex → HashOutput) (position : Position) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + [ObserverSynchronized table + (negatedDirectDelayedObserve observe snapshots observations)] + [ObserverPositionNeutral table + (negatedDirectDelayedObserve observe snapshots observations)] : + evalDist (resolveDeferredPositionValue position context >>= fun resolved ↦ + match resolved with + | none => pure true + | some resolved => Bool.not <$> + (runDirectResolvedWitnessFromTable resolved.toDeferredContext fuel table computation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations)) = + evalDist (Bool.not <$> + (runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations)) := by + have hmove := evalDist_resolve_then_runDirectWitness_finish_false table position observe + snapshots observations computation context fuel hvalid hcompletable + calc + _ = evalDist (Bool.not <$> (resolveDeferredPositionValue position context >>= fun resolved ↦ + match resolved with + | none => pure false + | some resolved => + runDirectResolvedWitnessFromTable resolved.toDeferredContext fuel table computation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations)) := by + rw [map_bind] + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved <;> rfl + _ = _ := by + rw [evalDist_map, evalDist_map] + exact congrArg (fun distribution => Bool.not <$> distribution) hmove + +set_option maxRecDepth 100000 in +theorem evalDist_resolve_then_complement_runDirectWitness_finish_false_at + (table : OtsSecretIndex → HashOutput) (position : Position) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : Coordinate.position position ∈ context.state.ensured) + (hneutral : ObserverPositionNeutralAt table position + (negatedDirectDelayedObserve observe snapshots observations)) : + evalDist (resolveDeferredPositionValue position context >>= fun resolved ↦ + match resolved with + | none => pure true + | some resolved => Bool.not <$> + (runDirectResolvedWitnessFromTable resolved.toDeferredContext fuel table computation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations)) = + evalDist (Bool.not <$> + (runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations)) := by + have hmove := evalDist_resolve_then_runDirectWitness_finish_false_at table position observe + snapshots observations computation context fuel hvalid hcompletable hensured hneutral + calc + _ = evalDist (Bool.not <$> (resolveDeferredPositionValue position context >>= fun resolved ↦ + match resolved with + | none => pure false + | some resolved => + runDirectResolvedWitnessFromTable resolved.toDeferredContext fuel table computation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations)) := by + rw [map_bind] + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved <;> rfl + _ = _ := by + rw [evalDist_map, evalDist_map] + exact congrArg (fun distribution => Bool.not <$> distribution) hmove + +set_option maxRecDepth 100000 in +theorem negatedDirectDelayedComputationObserve_uniform_observerSynchronized + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (n : Nat) (next : Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (hbefore : snapshots.length ≤ ordinal) + (hsynchronized : ∀ output, + ObserverSynchronized table + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot (next output) snapshots observations)) : + ObserverSynchronized table + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inl n))) >>= next) + snapshots observations) where + eq_of_synchronized left right fuel cache hcontext hvalues hrevealed := by + let observe := fun nextContext remaining (value : Fin (n + 1) × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (next value.1) laterSnapshots laterObservations nextContext remaining value.2 + letI : ObserverSynchronized table + (negatedDirectDelayedObserve observe snapshots observations) := ⟨by + intro nextLeft nextRight remaining value hnextContext hnextValues hnextRevealed + simpa [negatedDirectDelayedObserve, negatedDirectDelayedComputationObserve, observe] using + ObserverSynchronized.eq_of_synchronized + (table := table) + (observe := negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret + table target rightRoot (next value.1) snapshots observations) + nextLeft nextRight remaining value.2 hnextContext hnextValues hnextRevealed⟩ + have hnotSelected : ¬ordinal < snapshots.length := by omega + unfold negatedDirectDelayedComputationObserve + rw [directDelayedSelectedRootIndicator_uniform_eq ordinal parameter root ftsSecret table + target rightRoot n next snapshots observations left fuel cache hnotSelected] + rw [directDelayedSelectedRootIndicator_uniform_eq ordinal parameter root ftsSecret table + target rightRoot n next snapshots observations right fuel cache hnotSelected] + exact evalDist_complement_runDirectWitness_finish_false_eq_of_synchronized table observe + snapshots observations ((splitUniformImpl n).run cache) left right fuel hcontext hvalues + hrevealed + +set_option maxRecDepth 100000 in +theorem negatedDirectDelayedComputationObserve_uniform_observerPositionNeutral + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (n : Nat) (next : Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (hbefore : snapshots.length ≤ ordinal) + (hsynchronized : ∀ output, + ObserverSynchronized table + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot (next output) snapshots observations)) + (hneutral : ∀ output, + ObserverPositionNeutral table + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot (next output) snapshots observations)) : + ObserverPositionNeutral table + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inl n))) >>= next) + snapshots observations) where + eq_resolve position context fuel cache hvalid hcompletable _hensured := by + let observe := fun nextContext remaining (value : Fin (n + 1) × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (next value.1) laterSnapshots laterObservations nextContext remaining value.2 + letI : ObserverSynchronized table + (negatedDirectDelayedObserve observe snapshots observations) := ⟨by + intro nextLeft nextRight remaining value hnextContext hnextValues hnextRevealed + simpa [negatedDirectDelayedObserve, negatedDirectDelayedComputationObserve, observe] using + ObserverSynchronized.eq_of_synchronized + (table := table) + (observe := negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret + table target rightRoot (next value.1) snapshots observations) + nextLeft nextRight remaining value.2 hnextContext hnextValues hnextRevealed⟩ + letI : ObserverPositionNeutral table + (negatedDirectDelayedObserve observe snapshots observations) := ⟨by + intro nextPosition nextContext remaining value hnextValid hnextCompletable hensured + simpa [negatedDirectDelayedObserve, negatedDirectDelayedComputationObserve, observe] using + ObserverPositionNeutral.eq_resolve + (table := table) + (observe := negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret + table target rightRoot (next value.1) snapshots observations) + nextPosition nextContext remaining value.2 hnextValid hnextCompletable hensured⟩ + have hnotSelected : ¬ordinal < snapshots.length := by omega + unfold negatedDirectDelayedComputationObserve + simp_rw [directDelayedSelectedRootIndicator_uniform_eq ordinal parameter root ftsSecret table + target rightRoot n next snapshots observations _ fuel cache hnotSelected] + exact evalDist_resolve_then_complement_runDirectWitness_finish_false table position observe + snapshots observations ((splitUniformImpl n).run cache) context fuel hvalid hcompletable + +set_option maxRecDepth 100000 in +theorem negatedDirectDelayedComputationObserve_uniform_observerPositionNeutralAt + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (position : Position) (n : Nat) + (next : Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (hbefore : snapshots.length ≤ ordinal) + (hneutral : ∀ output, ObserverPositionNeutralAt table position + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot (next output) snapshots observations)) : + ObserverPositionNeutralAt table position + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inl n))) >>= next) + snapshots observations) := by + intro context fuel cache hvalid hcompletable hensured + let observe := fun nextContext remaining (value : Fin (n + 1) × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (next value.1) laterSnapshots laterObservations nextContext remaining value.2 + have hnextNeutral : ObserverPositionNeutralAt table position + (negatedDirectDelayedObserve observe snapshots observations) := by + intro nextContext remaining value hnextValid hnextCompletable hnextEnsured + simpa [negatedDirectDelayedObserve, negatedDirectDelayedComputationObserve, observe] using + hneutral value.1 nextContext remaining value.2 hnextValid hnextCompletable hnextEnsured + have hnotSelected : ¬ordinal < snapshots.length := by omega + unfold negatedDirectDelayedComputationObserve + simp_rw [directDelayedSelectedRootIndicator_uniform_eq ordinal parameter root ftsSecret table + target rightRoot n next snapshots observations _ fuel cache hnotSelected] + exact evalDist_resolve_then_complement_runDirectWitness_finish_false_at table position observe + snapshots observations ((splitUniformImpl n).run cache) context fuel hvalid hcompletable + hensured hnextNeutral + +set_option maxRecDepth 100000 in +theorem negatedDirectDelayedComputationObserve_signing_observerSynchronized + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (message : Message) + (next : Option Signature → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (hbefore : snapshots.length ≤ ordinal) + (hsynchronized : ∀ output, + ObserverSynchronized table + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot (next output) snapshots observations)) : + ObserverSynchronized table + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) (Sum.inr message)) >>= next) + snapshots observations) where + eq_of_synchronized left right fuel cache hcontext hvalues hrevealed := by + let observe := fun nextContext remaining (value : Option Signature × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (next value.1) laterSnapshots laterObservations nextContext remaining value.2 + letI : ObserverSynchronized table + (negatedDirectDelayedObserve observe snapshots observations) := ⟨by + intro nextLeft nextRight remaining value hnextContext hnextValues hnextRevealed + simpa [negatedDirectDelayedObserve, negatedDirectDelayedComputationObserve, observe] using + ObserverSynchronized.eq_of_synchronized + (table := table) + (observe := negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret + table target rightRoot (next value.1) snapshots observations) + nextLeft nextRight remaining value.2 hnextContext hnextValues hnextRevealed⟩ + have hnotSelected : ¬ordinal < snapshots.length := by omega + unfold negatedDirectDelayedComputationObserve + rw [directDelayedSelectedRootIndicator_signing_eq ordinal parameter root ftsSecret table + target rightRoot message next snapshots observations left fuel cache hnotSelected] + rw [directDelayedSelectedRootIndicator_signing_eq ordinal parameter root ftsSecret table + target rightRoot message next snapshots observations right fuel cache hnotSelected] + exact evalDist_complement_runDirectWitness_finish_false_eq_of_synchronized table observe + snapshots observations ((maskedSign parameter root ftsSecret message).run cache) + left right fuel hcontext hvalues hrevealed + +set_option maxRecDepth 100000 in +theorem negatedDirectDelayedComputationObserve_signing_observerPositionNeutral + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (message : Message) + (next : Option Signature → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (hbefore : snapshots.length ≤ ordinal) + (hsynchronized : ∀ output, + ObserverSynchronized table + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot (next output) snapshots observations)) + (hneutral : ∀ output, + ObserverPositionNeutral table + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot (next output) snapshots observations)) : + ObserverPositionNeutral table + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) (Sum.inr message)) >>= next) + snapshots observations) where + eq_resolve position context fuel cache hvalid hcompletable _hensured := by + let observe := fun nextContext remaining (value : Option Signature × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (next value.1) laterSnapshots laterObservations nextContext remaining value.2 + letI : ObserverSynchronized table + (negatedDirectDelayedObserve observe snapshots observations) := ⟨by + intro nextLeft nextRight remaining value hnextContext hnextValues hnextRevealed + simpa [negatedDirectDelayedObserve, negatedDirectDelayedComputationObserve, observe] using + ObserverSynchronized.eq_of_synchronized + (table := table) + (observe := negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret + table target rightRoot (next value.1) snapshots observations) + nextLeft nextRight remaining value.2 hnextContext hnextValues hnextRevealed⟩ + letI : ObserverPositionNeutral table + (negatedDirectDelayedObserve observe snapshots observations) := ⟨by + intro nextPosition nextContext remaining value hnextValid hnextCompletable hensured + simpa [negatedDirectDelayedObserve, negatedDirectDelayedComputationObserve, observe] using + ObserverPositionNeutral.eq_resolve + (table := table) + (observe := negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret + table target rightRoot (next value.1) snapshots observations) + nextPosition nextContext remaining value.2 hnextValid hnextCompletable hensured⟩ + have hnotSelected : ¬ordinal < snapshots.length := by omega + unfold negatedDirectDelayedComputationObserve + simp_rw [directDelayedSelectedRootIndicator_signing_eq ordinal parameter root ftsSecret table + target rightRoot message next snapshots observations _ fuel cache hnotSelected] + exact evalDist_resolve_then_complement_runDirectWitness_finish_false table position observe + snapshots observations ((maskedSign parameter root ftsSecret message).run cache) + context fuel hvalid hcompletable + +set_option maxRecDepth 100000 in +theorem negatedDirectDelayedComputationObserve_signing_observerPositionNeutralAt + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (position : Position) (message : Message) + (next : Option Signature → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (hbefore : snapshots.length ≤ ordinal) + (hneutral : ∀ output, ObserverPositionNeutralAt table position + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot (next output) snapshots observations)) : + ObserverPositionNeutralAt table position + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) (Sum.inr message)) >>= next) + snapshots observations) := by + intro context fuel cache hvalid hcompletable hensured + let observe := fun nextContext remaining (value : Option Signature × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (next value.1) laterSnapshots laterObservations nextContext remaining value.2 + have hnextNeutral : ObserverPositionNeutralAt table position + (negatedDirectDelayedObserve observe snapshots observations) := by + intro nextContext remaining value hnextValid hnextCompletable hnextEnsured + simpa [negatedDirectDelayedObserve, negatedDirectDelayedComputationObserve, observe] using + hneutral value.1 nextContext remaining value.2 hnextValid hnextCompletable hnextEnsured + have hnotSelected : ¬ordinal < snapshots.length := by omega + unfold negatedDirectDelayedComputationObserve + simp_rw [directDelayedSelectedRootIndicator_signing_eq ordinal parameter root ftsSecret table + target rightRoot message next snapshots observations _ fuel cache hnotSelected] + exact evalDist_resolve_then_complement_runDirectWitness_finish_false_at table position observe + snapshots observations ((maskedSign parameter root ftsSecret message).run cache) + context fuel hvalid hcompletable hensured hnextNeutral + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem evalDist_directDelayed_eagerDirectDelayed_hash_not_selected_at + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hbefore : ¬ordinal < snapshots.length) + (hnotSelected : ¬ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : Coordinate.position target ∈ context.state.ensured) + (haligned : + (observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state))).map + CleanProbeObservation.toProbe = + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).map + PlannedProbeSnapshot.toProbe) + (hclean : ∀ observation ∈ + observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)), + ¬observation.ExistingHiddenHit) + (hneutral : ObserverPositionNeutralAt table target + (negatedDirectDelayedObserve + (fun nextContext remaining (value : HashOutput × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2) + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context) + (observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state))))) : + evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) = + evalDist + (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) := by + let candidate? := rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state) + let rightSnapshots := appendPlannedSnapshot snapshots candidate? context + let rightObservations := observationsAfterCandidate observations + (materializedDeferredState context) candidate? + let runComputation := + (probingHashQueryAfterRootAwarePlan parameter input + (purePlanProbingHashQuery parameter input context.state)).run cache + let observe := fun nextContext remaining (value : HashOutput × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (next value.1) laterSnapshots laterObservations nextContext remaining value.2 + let delayedResolved : Option DeferredResolution → ProbComp Bool + | none => pure false + | some resolved => + runDirectResolvedWitnessFromTable resolved.toDeferredContext fuel table runComputation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + rightSnapshots rightObservations + let eagerResolved : Option DeferredResolution → ProbComp Bool + | none => pure false + | some resolved => + runDirectResolvedWitnessFromTable resolved.toDeferredContext fuel table runComputation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + (appendPlannedSnapshot snapshots candidate? resolved.toDeferredContext) + (observationsAfterCandidate observations + (materializedDeferredState resolved.toDeferredContext) candidate?) + have hdelayed : evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) = + evalDist (resolveDeferredPositionValue target context >>= delayedResolved) := by + rw [directDelayedSelectedRootIndicator_hash_eq_not_selected ordinal parameter root ftsSecret + table target rightRoot input next snapshots observations context fuel cache hbefore + hnotSelected] + exact (evalDist_resolve_then_runDirectWitness_finish_false_at table target observe rightSnapshots + rightObservations runComputation context fuel hvalid hcompletable hensured (by + simpa [observe, rightSnapshots, rightObservations, candidate?] using hneutral)).symm + have heager : evalDist + (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) = + evalDist (resolveDeferredPositionValue target context >>= eagerResolved) := by + unfold eagerDirectDelayedSelectedRootIndicator + simp only [hbefore, ↓reduceIte] + apply evalDist_bind_congr + intro resolvedOption hresolvedOption + cases resolvedOption with + | none => rfl + | some resolved => + simp only + have hvalues := resolveDeferredPositionValue_preserves_state_values target context resolved + hresolvedOption + have hplan : purePlanProbingHashQuery parameter input resolved.state = + purePlanProbingHashQuery parameter input context.state := + purePlanProbingHashQuery_eq_of_values_eq hvalues parameter input + have hnotSelectedResolved : ¬ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input resolved.state)) + resolved.toDeferredContext).length := by + rw [hplan] + have hlength : + (appendPlannedSnapshot snapshots candidate? resolved.toDeferredContext).length = + rightSnapshots.length := by + cases hcandidate : candidate? <;> + simp [rightSnapshots, appendPlannedSnapshot, hcandidate] + rw [hlength] + simpa [rightSnapshots, candidate?] using hnotSelected + rw [directDelayedSelectedRootIndicator_hash_eq_not_selected ordinal parameter root + ftsSecret table target rightRoot input next snapshots observations + resolved.toDeferredContext fuel cache hbefore hnotSelectedResolved] + rw [hplan] + calc + _ = evalDist (resolveDeferredPositionValue target context >>= delayedResolved) := hdelayed + _ = evalDist (resolveDeferredPositionValue target context >>= eagerResolved) := by + apply evalDist_bind_congr + intro resolvedOption hresolvedOption + cases resolvedOption with + | none => rfl + | some resolved => + have hresolvedPrivate : resolved.values target = some resolved.output := + resolveDeferredPositionValue_installs target context resolved hresolvedOption + let leftSnapshots := appendPlannedSnapshot snapshots candidate? + resolved.toDeferredContext + let leftObservations := observationsAfterCandidate observations + (materializedDeferredState resolved.toDeferredContext) candidate? + have hsnapshots : leftSnapshots.map PlannedProbeSnapshot.toProbe = + rightSnapshots.map PlannedProbeSnapshot.toProbe := by + cases hcandidate : candidate? <;> + simp [leftSnapshots, rightSnapshots, appendPlannedSnapshot, hcandidate] + have hlength : rightSnapshots.length ≤ ordinal := by + simpa [rightSnapshots, candidate?] using Nat.le_of_not_gt hnotSelected + apply evalDist_eq_of_relTriple_eqRel + apply relTriple_runDirectWitness_finishDirectDelayed_of_safe_trace ordinal parameter root + ftsSecret table target resolved.output rightRoot HashOutput next runComputation + leftSnapshots rightSnapshots leftObservations rightObservations + resolved.toDeferredContext fuel hresolvedPrivate + (by rwa [plannedProbeSnapshots_length_eq_of_toProbe_eq hsnapshots]) hlength hsnapshots + intro hsafe + apply observationsAfterCandidate_eventEq_resolved_current_of_clean_of_avoids target + context resolved hresolvedOption observations candidate? + · simpa [rightObservations, candidate?] using hclean + · intro probe hprobe + have hprobeSnapshots : probe ∈ rightSnapshots.map PlannedProbeSnapshot.toProbe := by + rw [← haligned] + simpa [rightObservations, candidate?] using hprobe + exact (hsafe probe hprobeSnapshots).1 + _ = _ := heager.symm + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem evalDist_directDelayed_eagerDirectDelayed_hash_not_selected_general_at + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hbefore : ¬ordinal < snapshots.length) + (hnotSelected : ¬ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : Coordinate.position target ∈ context.state.ensured) + (haligned : observations.map CleanProbeObservation.toProbe = + snapshots.map PlannedProbeSnapshot.toProbe) + (hclean : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hneutral : + (∀ observation ∈ + observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)), + ¬observation.ExistingHiddenHit) → + ObserverPositionNeutralAt table target + (negatedDirectDelayedObserve + (fun nextContext remaining (value : HashOutput × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2) + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context) + (observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state))))) : + evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) = + evalDist + (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) := by + have hlength : observations.length = snapshots.length := by + simpa only [List.length_map] using congrArg List.length haligned + let nextObservations := observationsAfterCandidate observations + (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) + by_cases hnextClean : ∀ observation ∈ nextObservations, + ¬observation.ExistingHiddenHit + · have hnextAligned : + nextObservations.map CleanProbeObservation.toProbe = + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).map + PlannedProbeSnapshot.toProbe := by + cases hcandidate : rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state) <;> + simp [nextObservations, observationsAfterCandidate, appendPlannedSnapshot, hcandidate, + CleanProbeObservation.toProbe, cleanProbeObservation, haligned] + exact evalDist_directDelayed_eagerDirectDelayed_hash_not_selected_at ordinal parameter root + ftsSecret table target rightRoot input next snapshots observations context fuel cache hbefore + hnotSelected hvalid hcompletable hensured hnextAligned + (by simpa [nextObservations] using hnextClean) + (hneutral (by simpa [nextObservations] using hnextClean)) + · have hdirectFalse : true ∉ support + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) := by + intro htrue + apply hnextClean + exact no_existingHiddenHit_afterCandidate_of_true_mem_hash_not_selected ordinal parameter + root ftsSecret table target rightRoot input next snapshots observations context fuel cache + hbefore hnotSelected hlength htrue + have heagerFalse : true ∉ support + (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) := + true_not_mem_eagerDirectDelayed_hash_of_dirty_not_selected ordinal parameter root ftsSecret + table target rightRoot input next snapshots observations context fuel cache hbefore + hnotSelected hlength hclean (by simpa [nextObservations] using hnextClean) + exact (evalDist_eq_of_relTriple_eqRel (relTriple_eq_false_of_true_not_mem _ hdirectFalse)).trans + (evalDist_eq_of_relTriple_eqRel + (relTriple_eq_false_of_true_not_mem _ heagerFalse)).symm + +theorem cleanProbeObservation_materializedDeferredState_eq_of_finalizationContextEq + (table : OtsSecretIndex → HashOutput) (left right : DeferredContext) + (coordinate : Coordinate) (candidate : Digest) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) + (hrevealed : left.state.revealed = right.state.revealed) : + cleanProbeObservation (materializedDeferredState left) coordinate candidate = + cleanProbeObservation (materializedDeferredState right) coordinate candidate := by + rcases hcontext with ⟨hview, _hleftValid, _hrightValid, _hleftCompletable⟩ + have hvalueAt : + (materializedDeferredState left).values coordinate = + (materializedDeferredState right).values coordinate := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simpa only [materializedDeferredState_chainStart] using + congrFun hvalues (.chainStart lay tree leafIdx chainIdx) + | position position => + have hvalueEq := congrFun hview.valueEq (.position position) + simpa only [resolvedCompletionValue, materializedDeferredState_position] using hvalueEq + by_cases hleftRevealed : coordinate ∈ left.state.revealed + · have hrightRevealed : coordinate ∈ right.state.revealed := by + simpa [hrevealed] using hleftRevealed + simp [cleanProbeObservation, hvalueAt, hleftRevealed, hrightRevealed] + · have hrightRevealed : coordinate ∉ right.state.revealed := by + simpa [hrevealed] using hleftRevealed + simp [cleanProbeObservation, hvalueAt, hleftRevealed, hrightRevealed] + +theorem observationsAfterCandidate_materializedDeferredState_eq_of_finalizationContextEq + (table : OtsSecretIndex → HashOutput) (left right : DeferredContext) + (observations : List CleanProbeObservation) (candidate? : Option Probe) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) + (hrevealed : left.state.revealed = right.state.revealed) : + observationsAfterCandidate observations (materializedDeferredState left) candidate? = + observationsAfterCandidate observations (materializedDeferredState right) candidate? := by + cases candidate? with + | none => rfl + | some candidate => + simp only [observationsAfterCandidate] + rw [cleanProbeObservation_materializedDeferredState_eq_of_finalizationContextEq table + left right candidate.coordinate candidate.candidate hcontext hvalues hrevealed] + +theorem materializedDeferredState_values_eq_of_finalizationContextEq + (table : OtsSecretIndex → HashOutput) (left right : DeferredContext) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) : + (materializedDeferredState left).values = + (materializedDeferredState right).values := by + rcases hcontext with ⟨hview, _hleftValid, _hrightValid, _hleftCompletable⟩ + funext coordinate + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simpa only [materializedDeferredState_chainStart] using + congrFun hvalues (.chainStart lay tree leafIdx chainIdx) + | position position => + have hvalueEq := congrFun hview.valueEq (.position position) + simpa only [resolvedCompletionValue, materializedDeferredState_position] using hvalueEq + +structure CompletionSafeStateEq + (table : OtsSecretIndex → HashOutput) + (left right : LazyRevealProbe.State Coordinate) : Prop where + forward : CompletionSafeStateLE table left right + backward : CompletionSafeStateLE table right left + +theorem completionSafeStateEq_materialized_of_finalizationContextEq + (table : OtsSecretIndex → HashOutput) (left right : DeferredContext) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) + (hrevealed : left.state.revealed = right.state.revealed) : + CompletionSafeStateEq table + (materializedDeferredState left) (materializedDeferredState right) := by + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hrightCompletable : DeferredCompletable table right := by + obtain ⟨completion, hcompletion⟩ := hleftCompletable + exact ⟨completion, (hview.deferredCompletion_iff completion).mp hcompletion⟩ + have hmaterializedValues := + materializedDeferredState_values_eq_of_finalizationContextEq table left right + ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ hvalues + have forwardContext : FinalizationContextLE table left (materializedDeferredContext right) := by + have hrightMaterialized := + finalizationContextLE_materializedDeferredContext hrightValid hrightCompletable + exact + { view := (FinalizationContextLE.of_eq + (⟨hview, hleftValid, hrightValid, hleftCompletable⟩ : + FinalizationContextEq table (some left) (some right))).view.trans + hrightMaterialized.view + leftValid := hleftValid + rightValid := hrightMaterialized.rightValid + rightCompletable := hrightMaterialized.rightCompletable } + have backwardContext : FinalizationContextLE table right (materializedDeferredContext left) := by + have hleftMaterialized := + finalizationContextLE_materializedDeferredContext hleftValid hleftCompletable + have hreverse : FinalizationContextEq table (some right) (some left) := + ⟨hview.symm, hrightValid, hleftValid, hrightCompletable⟩ + exact + { view := (FinalizationContextLE.of_eq hreverse).view.trans hleftMaterialized.view + leftValid := hrightValid + rightValid := hleftMaterialized.rightValid + rightCompletable := hleftMaterialized.rightCompletable } + refine ⟨?_, ?_⟩ + · exact completionSafeStateLE_materialized_of_finalizationContextLE table left + (materializedDeferredContext right) forwardContext (by + change left.state.revealed = (materializedDeferredState right).revealed + simpa using hrevealed) + (by + change (materializedDeferredState left).values = + (materializedDeferredState right).values + exact hmaterializedValues) + · exact completionSafeStateLE_materialized_of_finalizationContextLE table right + (materializedDeferredContext left) backwardContext (by + change right.state.revealed = (materializedDeferredState left).revealed + simpa using hrevealed.symm) + (by + change (materializedDeferredState right).values = + (materializedDeferredState left).values + exact hmaterializedValues.symm) + +theorem CompletionSafeStateEq.ensure + {table : OtsSecretIndex → HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hstate : CompletionSafeStateEq table left right) (coordinate : Coordinate) : + CompletionSafeStateEq table (left.ensure coordinate) (right.ensure coordinate) := + ⟨hstate.forward.ensure coordinate, hstate.backward.ensure coordinate⟩ + +theorem CompletionSafeStateEq.publish + {table : OtsSecretIndex → HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hstate : CompletionSafeStateEq table left right) (coordinate : Coordinate) : + CompletionSafeStateEq table (left.publish coordinate) (right.publish coordinate) := + ⟨hstate.forward.publish coordinate, hstate.backward.publish coordinate⟩ + +theorem CompletionSafeStateEq.addPending + {table : OtsSecretIndex → HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hstate : CompletionSafeStateEq table left right) + (coordinate : Coordinate) (candidate : Digest) : + CompletionSafeStateEq table + (left.addPending coordinate candidate) (right.addPending coordinate candidate) := + ⟨hstate.forward.addPending coordinate candidate, + hstate.backward.addPending coordinate candidate⟩ + +theorem CompletionSafeStateEq.materialize + {table : OtsSecretIndex → HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hstate : CompletionSafeStateEq table left right) + (coordinate : Coordinate) (output : HashOutput) : + CompletionSafeStateEq table + (left.materialize coordinate output) (right.materialize coordinate output) := + ⟨hstate.forward.materialize coordinate output, + hstate.backward.materialize coordinate output⟩ + +theorem CompletionSafeStateEq.hitAt_iff_of_value_none + {table : OtsSecretIndex → HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hstate : CompletionSafeStateEq table left right) + (coordinate : Coordinate) (output : HashOutput) + (hleftValue : left.values coordinate = none) + (hcompletion : ∀ index : OtsSecretIndex, + coordinate = index.coordinate → output = table index) : + left.hitAt coordinate output ↔ right.hitAt coordinate output := by + have hrightValue : right.values coordinate = none := by + rw [← hstate.forward.values] + exact hleftValue + constructor + · intro hleft + by_contra hright + exact hstate.forward.not_hitAt_left_of_right coordinate output hleftValue hcompletion + hright hleft + · intro hright + by_contra hleft + exact hstate.backward.not_hitAt_left_of_right coordinate output hrightValue hcompletion + hleft hright + +theorem CompletionSafeStateEq.pendingAt_eq_of_position_value_none + {table : OtsSecretIndex → HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hstate : CompletionSafeStateEq table left right) + (position : Position) (hleftValue : left.values (.position position) = none) : + left.pendingAt (.position position) = right.pendingAt (.position position) := by + have hrightValue : right.values (.position position) = none := by + rw [← hstate.forward.values] + exact hleftValue + apply Finset.Subset.antisymm + · intro candidate hcandidate + have hentry : (Coordinate.position position, candidate) ∈ left.pending := + (LazyRevealProbe.State.mem_pendingAt_iff left (.position position) candidate).1 hcandidate + rcases hstate.forward.pending (.position position) candidate hentry with + hright | ⟨output, hvalue, _hmiss⟩ | ⟨index, hcoordinate, _hmiss⟩ + · exact (LazyRevealProbe.State.mem_pendingAt_iff right + (.position position) candidate).2 hright + · rw [hleftValue] at hvalue + simp at hvalue + · cases hcoordinate + · intro candidate hcandidate + have hentry : (Coordinate.position position, candidate) ∈ right.pending := + (LazyRevealProbe.State.mem_pendingAt_iff right (.position position) candidate).1 hcandidate + rcases hstate.backward.pending (.position position) candidate hentry with + hleft | ⟨output, hvalue, _hmiss⟩ | ⟨index, hcoordinate, _hmiss⟩ + · exact (LazyRevealProbe.State.mem_pendingAt_iff left + (.position position) candidate).2 hleft + · rw [hrightValue] at hvalue + simp at hvalue + · cases hcoordinate + +theorem CompletionSafeStateLE.directDeferredCompletable_of_right + {table : OtsSecretIndex → HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hstate : CompletionSafeStateLE table left right) + (hcompletable : DeferredCompletable table (directDeferredContext right)) : + DeferredCompletable table (directDeferredContext left) := by + obtain ⟨completion, hcompletion⟩ := hcompletable + refine ⟨completion, ?_⟩ + refine ⟨?_, ?_, ?_, hcompletion.2.2.2⟩ + · intro coordinate output hvalue + apply hcompletion.1 coordinate output + simpa [directDeferredContext, hstate.values] using hvalue + · intro position output hvalue + apply hcompletion.2.1 position output + simpa [directDeferredContext, directDeferredValues, hstate.values] using hvalue + · intro coordinate candidate hentry + have hentry' : (coordinate, candidate) ∈ left.pending := by + simpa [directDeferredContext] using hentry + rcases hstate.pending coordinate candidate hentry' with hright | hknown | hchain + · apply hcompletion.2.2.1 coordinate candidate + simpa [directDeferredContext] using hright + · obtain ⟨output, hvalue, hmiss⟩ := hknown + have hcompletionValue : completion coordinate = output := + hcompletion.1 coordinate output (by + simpa [directDeferredContext] using + (show right.values coordinate = some output by rw [← hstate.values]; exact hvalue)) + simpa [hcompletionValue] using Ne.symm hmiss + · obtain ⟨index, hcoordinate, hmiss⟩ := hchain + have hcompletionValue : completion coordinate = table index := by + rw [hcoordinate] + exact hcompletion.2.2.2 index + simpa [hcompletionValue] using Ne.symm hmiss + +theorem CompletionSafeStateEq.directDeferredCompletable_iff + {table : OtsSecretIndex → HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hstate : CompletionSafeStateEq table left right) : + DeferredCompletable table (directDeferredContext left) ↔ + DeferredCompletable table (directDeferredContext right) := by + exact ⟨hstate.backward.directDeferredCompletable_of_right, + hstate.forward.directDeferredCompletable_of_right⟩ + +set_option maxRecDepth 100000 in +theorem pendingAt_position_card_lt_of_mem_finalizeCleanFromTable + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) + (position : Position) + (hvalue : state.values (.position position) = none) + (finalState : LazyRevealProbe.State Coordinate) + (finalTable : OtsSecretIndex → HashOutput) + (hfinal : some (finalState, finalTable) ∈ support + (finalizeCleanFromTable state.coordinates.toList state table)) : + (state.pendingAt (.position position)).card < Fintype.card Digest := by + by_cases hempty : state.pendingAt (.position position) = ∅ + · rw [hempty, Finset.card_empty] + exact Fintype.card_pos + · obtain ⟨candidate, hcandidate⟩ := Finset.nonempty_iff_ne_empty.mpr hempty + have hentry : (Coordinate.position position, candidate) ∈ state.pending := + (LazyRevealProbe.State.mem_pendingAt_iff state (.position position) candidate).1 hcandidate + have hcoordinate : Coordinate.position position ∈ state.coordinates := by + simp only [LazyRevealProbe.State.coordinates, Finset.mem_union, Finset.mem_image] + exact Or.inr ⟨(.position position, candidate), hentry, rfl⟩ + have hexpose := evalDist_finalizeCleanFromTable_finset_expose_missing + (.position position) state.coordinates state table hcoordinate hvalue + have hfinalEval : some (finalState, finalTable) ∈ + support (do + let output ← completionOutputFromTable (.position position) table + if state.hitAt (.position position) output then + pure none + else + finalizeCleanFromTable (state.coordinates.toList.erase (.position position)) + (state.complete (.position position) output) table) := by + rw [mem_support_iff_evalDist_apply_ne_zero] at hfinal ⊢ + rw [← hexpose] + exact hfinal + rw [mem_support_bind_iff] at hfinalEval + obtain ⟨output, _houtput, hrest⟩ := hfinalEval + have hmiss : ¬state.hitAt (.position position) output := by + intro hhit + simp [hhit] at hrest + have hnotMem : truncateHash output ∉ state.pendingAt (.position position) := by + simpa [LazyRevealProbe.State.hitAt] using hmiss + exact (Finset.card_lt_iff_ne_univ _).2 (by + intro huniv + apply hnotMem + rw [huniv] + simp) + +set_option maxRecDepth 100000 in +theorem exists_successful_finishObservedCleanRunFromTable_of_completionSafeEq + {table : OtsSecretIndex → HashOutput} + {left right : ObservedCleanRunResult α} + (hstate : CompletionSafeStateEq table left.state right.state) + (hleftTable : left.table = table) (hrightTable : right.table = table) + (hfinish : ∃ finalResult, some finalResult ∈ support + (finishObservedCleanRunFromTable (some left))) : + ∃ finalResult, some finalResult ∈ support + (finishObservedCleanRunFromTable (some right)) := by + obtain ⟨leftFinal, hleftFinal⟩ := hfinish + unfold finishObservedCleanRunFromTable at hleftFinal + rw [mem_support_bind_iff] at hleftFinal + obtain ⟨finalized, hfinalized, hreturn⟩ := hleftFinal + cases finalized with + | none => simp at hreturn + | some finalized => + rcases finalized with ⟨finalState, finalTable⟩ + have hfinalizedTable : some (finalState, finalTable) ∈ support + (finalizeCleanFromTable left.state.coordinates.toList left.state table) := by + simpa [hleftTable] using hfinalized + have hleftStart : ¬MissingChainStartHit table + (directDeferredContext left.state) := by + rw [← hleftTable] + exact not_missingChainStartHit_of_mem_finishObservedCleanRunFromTable left leftFinal + (by + unfold finishObservedCleanRunFromTable + rw [mem_support_bind_iff] + exact ⟨some (finalState, finalTable), hfinalized, hreturn⟩) + have hrightStart : ¬MissingChainStartHit table + (directDeferredContext right.state) := + hstate.backward.not_missingChainStartHit_left_of_right hleftStart + obtain ⟨rightFinal, hrightFinal⟩ := exists_successful_finalizeCleanFromTable table + right.state.coordinates.toList right.state right.state.coordinates.nodup_toList (by + intro entry hentry + simp only [Finset.mem_toList, LazyRevealProbe.State.coordinates, + Finset.mem_union, Finset.mem_image] + exact Or.inr ⟨entry, hentry, rfl⟩) hrightStart (by + intro position hrightValue + have hleftValue : left.state.values (.position position) = none := by + rw [hstate.forward.values, hrightValue] + have hcard := pendingAt_position_card_lt_of_mem_finalizeCleanFromTable left.state table + position hleftValue finalState finalTable hfinalizedTable + rw [← hstate.pendingAt_eq_of_position_value_none position hleftValue] + exact hcard) + rcases rightFinal with ⟨rightFinalState, rightFinalTable⟩ + let result : ObservedCleanRunResult α := + ⟨rightFinalState, right.remaining, right.value, rightFinalTable, right.observations⟩ + refine ⟨result, ?_⟩ + unfold finishObservedCleanRunFromTable + rw [mem_support_bind_iff] + refine ⟨some (rightFinalState, rightFinalTable), ?_, by simp [result]⟩ + simpa [hrightTable] using hrightFinal + +theorem successful_finishObservedCleanRunFromTable_iff_of_completionSafeEq + {table : OtsSecretIndex → HashOutput} + {left right : ObservedCleanRunResult α} + (hstate : CompletionSafeStateEq table left.state right.state) + (hleftTable : left.table = table) (hrightTable : right.table = table) : + (∃ finalResult, some finalResult ∈ support + (finishObservedCleanRunFromTable (some left))) ↔ + ∃ finalResult, some finalResult ∈ support + (finishObservedCleanRunFromTable (some right)) := by + constructor + · exact exists_successful_finishObservedCleanRunFromTable_of_completionSafeEq hstate + hleftTable hrightTable + · exact exists_successful_finishObservedCleanRunFromTable_of_completionSafeEq + ⟨hstate.backward, hstate.forward⟩ hrightTable hleftTable + +theorem successfulDoomedFirstRootGoodForComparisonAt_iff_of_completionSafeEq + {table : OtsSecretIndex → HashOutput} (ordinal : Nat) (target : Position) + (rightRoot : Digest) (left right : ObservedCleanRunResult α) + (hstate : CompletionSafeStateEq table left.state right.state) + (hleftTable : left.table = table) (hrightTable : right.table = table) + (hobservations : left.observations = right.observations) : + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some left) ↔ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some right) := by + have hfinish := successful_finishObservedCleanRunFromTable_iff_of_completionSafeEq hstate + hleftTable hrightTable + have hfirst : + ObservedCleanRunOption.FirstExistingHiddenRootHitAt ordinal (some left) ↔ + ObservedCleanRunOption.FirstExistingHiddenRootHitAt ordinal (some right) := by + rcases left with ⟨leftState, leftRemaining, leftValue, leftTable, leftObservations⟩ + rcases right with ⟨rightState, rightRemaining, rightValue, rightTable, rightObservations⟩ + simp only at hobservations ⊢ + subst rightObservations + rfl + have hposition := observedFirstLayerRootPosition?_eq_of_observations_eq ordinal left right + hobservations + have hprefix := observedPrefixProbes_eq_of_observations_eq ordinal left right hobservations + simp only [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + rw [hfinish, hfirst, hposition, hprefix] + +def ObservedCompletionSafeEqRel + (table : OtsSecretIndex → HashOutput) + (leftPrefix rightPrefix : List CleanProbeObservation) : + Option (ObservedCleanRunResult α) → Option (ObservedCleanRunResult α) → Prop + | none, none => True + | some left, some right => + left.value = right.value ∧ left.table = right.table ∧ + left.remaining = right.remaining ∧ + (∃ suffix, + left.observations = leftPrefix ++ suffix ∧ + right.observations = rightPrefix ++ suffix) ∧ + CompletionSafeStateEq table left.state right.state + | _, _ => False + +theorem ObservedCompletionSafeEqRel.pure + (table : OtsSecretIndex → HashOutput) + (leftPrefix rightPrefix : List CleanProbeObservation) + (leftState rightState : LazyRevealProbe.State Coordinate) + (fuel : Nat) (value : α) + (hstate : CompletionSafeStateEq table leftState rightState) : + ObservedCompletionSafeEqRel table leftPrefix rightPrefix + (some ⟨leftState, fuel, value, table, leftPrefix⟩) + (some ⟨rightState, fuel, value, table, rightPrefix⟩) := by + exact ⟨rfl, rfl, rfl, ⟨[], by simp, by simp⟩, hstate⟩ + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_runObservedCleanFromTable_completionSafeEq + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (leftPrefix rightPrefix : List CleanProbeObservation) + (leftState rightState : LazyRevealProbe.State Coordinate) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hstate : CompletionSafeStateEq table leftState rightState) : + RelTriple + (runObservedCleanFromTable leftPrefix leftState fuel table computation) + (runObservedCleanFromTable rightPrefix rightState fuel table computation) + (ObservedCompletionSafeEqRel table leftPrefix rightPrefix) := by + induction computation using OracleComp.inductionOn generalizing + leftPrefix rightPrefix leftState rightState fuel with + | pure value => + rw [runObservedCleanFromTable, OracleComp.construct_pure, + runObservedCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure + (ObservedCompletionSafeEqRel.pure table leftPrefix rightPrefix leftState rightState fuel + value hstate) + | query_bind query next ih => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + runObservedCleanFromTable, OracleComp.construct_query_bind] + have extendObservation + (leftObservation rightObservation : CleanProbeObservation) + (hobservation : leftObservation = rightObservation) + (leftRun rightRun : ProbComp (Option (ObservedCleanRunResult α))) + (hrun : RelTriple leftRun rightRun + (ObservedCompletionSafeEqRel table + (leftPrefix ++ [leftObservation]) (rightPrefix ++ [rightObservation]))) : + RelTriple leftRun rightRun + (ObservedCompletionSafeEqRel table leftPrefix rightPrefix) := by + apply relTriple_post_mono hrun + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => trivial + | some rightResult => + simp [ObservedCompletionSafeEqRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [ObservedCompletionSafeEqRel] at hresult + | some rightResult => + rcases hresult with ⟨hvalue, htable, hremaining, + ⟨suffix, hleft, hright⟩, hnextState⟩ + refine ⟨hvalue, htable, hremaining, + ⟨leftObservation :: suffix, ?_, ?_⟩, hnextState⟩ + · simpa [List.append_assoc] using hleft + · simpa [List.append_assoc, hobservation] using hright + cases query with + | uniform n => + apply relTriple_bind (relTriple_refl (liftM (unifSpec.query n))) + intro leftValue rightValue hvalue + subst rightValue + exact ih leftValue leftPrefix rightPrefix leftState rightState fuel hstate + | hashOutput => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftValue rightValue hvalue + subst rightValue + exact ih leftValue leftPrefix rightPrefix leftState rightState fuel hstate + | ensure coordinate => + exact ih () leftPrefix rightPrefix (leftState.ensure coordinate) + (rightState.ensure coordinate) fuel (hstate.ensure coordinate) + | probe coordinate candidate => + cases fuel with + | zero => exact relTriple_pure_pure (by trivial) + | succ remaining => + let leftObservation := cleanProbeObservation leftState coordinate candidate + let rightObservation := cleanProbeObservation rightState coordinate candidate + have hobservation : leftObservation = rightObservation := by + unfold leftObservation rightObservation cleanProbeObservation + simp [hstate.forward.values, hstate.forward.revealed] + have hrevealed : coordinate ∈ leftState.revealed ↔ + coordinate ∈ rightState.revealed := by + rw [hstate.forward.revealed] + by_cases hleftRevealed : coordinate ∈ leftState.revealed + · have hrightRevealed : coordinate ∈ rightState.revealed := + hrevealed.mp hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + exact extendObservation leftObservation rightObservation hobservation _ _ + (ih () (leftPrefix ++ [leftObservation]) + (rightPrefix ++ [rightObservation]) leftState rightState remaining hstate) + · have hrightRevealed : coordinate ∉ rightState.revealed := by + simpa [hrevealed] using hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + exact extendObservation leftObservation rightObservation hobservation _ _ + (ih () (leftPrefix ++ [leftObservation]) + (rightPrefix ++ [rightObservation]) + (leftState.addPending coordinate candidate) + (rightState.addPending coordinate candidate) remaining + (hstate.addPending coordinate candidate)) + | peek coordinate => + simp only + have hvalue : leftState.values coordinate = rightState.values coordinate := by + rw [hstate.forward.values] + rw [hvalue] + exact ih (rightState.values coordinate) leftPrefix rightPrefix leftState rightState fuel + hstate + | publish coordinate => + simp only + exact ih () leftPrefix rightPrefix (leftState.publish coordinate) + (rightState.publish coordinate) fuel (hstate.publish coordinate) + | reveal coordinate => + simp only + have hvalue : leftState.values coordinate = rightState.values coordinate := by + rw [hstate.forward.values] + cases hrightValue : rightState.values coordinate with + | some output => + have hleftValue : leftState.values coordinate = some output := by + rw [hvalue, hrightValue] + simp only [hleftValue] + exact ih output leftPrefix rightPrefix leftState rightState fuel hstate + | none => + have hleftValue : leftState.values coordinate = none := by + rw [hvalue, hrightValue] + simp only [hleftValue] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + have hhit : leftState.hitAt (.chainStart lay tree leafIdx chainIdx) output ↔ + rightState.hitAt (.chainStart lay tree leafIdx chainIdx) output := + hstate.hitAt_iff_of_value_none _ output hleftValue (by + intro index hcoordinate + rcases index with ⟨otherLay, otherTree, otherLeaf, otherChain⟩ + simp [OtsSecretIndex.coordinate] at hcoordinate + obtain ⟨rfl, rfl, rfl, rfl⟩ := hcoordinate + rfl) + by_cases hleftHit : leftState.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · have hrightHit := hhit.mp hleftHit + simp only [output, hleftHit, hrightHit, ↓reduceIte] + exact relTriple_pure_pure (by trivial) + · have hrightHit : ¬rightState.hitAt + (.chainStart lay tree leafIdx chainIdx) output := by + rwa [← hhit] + simp only [output, hleftHit, hrightHit, ↓reduceIte] + exact ih output leftPrefix rightPrefix + (leftState.materialize (.chainStart lay tree leafIdx chainIdx) output) + (rightState.materialize (.chainStart lay tree leafIdx chainIdx) output) + fuel (hstate.materialize _ output) + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + have hhit : leftState.hitAt (.position position) leftOutput ↔ + rightState.hitAt (.position position) leftOutput := + hstate.hitAt_iff_of_value_none _ leftOutput hleftValue + (by intro index hcoordinate; cases hcoordinate) + by_cases hleftHit : leftState.hitAt (.position position) leftOutput + · have hrightHit := hhit.mp hleftHit + simp only [hleftHit, hrightHit, ↓reduceIte] + exact relTriple_pure_pure (by trivial) + · have hrightHit : ¬rightState.hitAt (.position position) leftOutput := by + rwa [← hhit] + simp only [hleftHit, hrightHit, ↓reduceIte] + exact ih leftOutput leftPrefix rightPrefix + (leftState.materialize (.position position) leftOutput) + (rightState.materialize (.position position) leftOutput) fuel + (hstate.materialize _ leftOutput) + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_observedMaterializedBoundary_completionSafeEq + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (leftPrefix rightPrefix : List CleanProbeObservation) + (leftState rightState : LazyRevealProbe.State Coordinate) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) + (hstate : CompletionSafeStateEq table leftState rightState) : + RelTriple + (observedMaterializedBoundary parameter root ftsSecret computation leftPrefix leftState + fuel table cache) + (observedMaterializedBoundary parameter root ftsSecret computation rightPrefix rightState + fuel table cache) + (ObservedCompletionSafeEqRel table leftPrefix rightPrefix) := by + induction computation using OracleComp.inductionOn generalizing + leftPrefix rightPrefix leftState rightState fuel cache with + | pure value => + rw [observedMaterializedBoundary, OracleComp.construct_pure, + observedMaterializedBoundary, OracleComp.construct_pure] + exact relTriple_pure_pure + (ObservedCompletionSafeEqRel.pure table leftPrefix rightPrefix leftState rightState fuel + (value, cache) hstate) + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind, + observedMaterializedBoundary, OracleComp.construct_query_bind] + have continueAfter + (leftRun rightRun : ProbComp (Option (ObservedCleanRunResult + ((OracleWorld + SigningSpec).Range query × SplitHashCache)))) + (hrun : RelTriple leftRun rightRun + (ObservedCompletionSafeEqRel table leftPrefix rightPrefix)) : + RelTriple + (leftRun >>= fun result ↦ + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state result.remaining table + result.value.2) + (rightRun >>= fun result ↦ + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state result.remaining table + result.value.2) + (ObservedCompletionSafeEqRel table leftPrefix rightPrefix) := by + apply relTriple_bind hrun + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure (by trivial) + | some rightResult => simp [ObservedCompletionSafeEqRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [ObservedCompletionSafeEqRel] at hresult + | some rightResult => + rcases hresult with ⟨hvalue, htable, hremaining, + ⟨suffix, hleftObservations, hrightObservations⟩, hnextState⟩ + simp only + have houtput : leftResult.value.1 = rightResult.value.1 := + congrArg Prod.fst hvalue + have hnextCache : leftResult.value.2 = rightResult.value.2 := + congrArg Prod.snd hvalue + rw [← houtput, ← hnextCache, ← hremaining] + have hnext := ih leftResult.value.1 leftResult.observations + rightResult.observations leftResult.state rightResult.state + leftResult.remaining leftResult.value.2 hnextState + apply relTriple_post_mono hnext + intro laterLeft laterRight hlater + cases laterLeft with + | none => + cases laterRight with + | none => trivial + | some laterRight => simp [ObservedCompletionSafeEqRel] at hlater + | some laterLeft => + cases laterRight with + | none => simp [ObservedCompletionSafeEqRel] at hlater + | some laterRight => + rcases hlater with ⟨hlaterValue, hlaterTable, hlaterRemaining, + ⟨laterSuffix, hlaterLeft, hlaterRight⟩, hlaterState⟩ + refine ⟨hlaterValue, hlaterTable, hlaterRemaining, + ⟨suffix ++ laterSuffix, ?_, ?_⟩, hlaterState⟩ + · rw [hlaterLeft, hleftObservations, List.append_assoc] + · rw [hlaterRight, hrightObservations, List.append_assoc] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + change Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α at next + simp only + have hstep := relTriple_runObservedCleanFromTable_completionSafeEq + ((splitUniformImpl n).run cache) leftPrefix rightPrefix leftState rightState fuel + table hstate + convert continueAfter _ _ hstep using 1 <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + | inr input => + change HashOutput → OracleComp (OracleWorld + SigningSpec) α at next + simp only + let leftPublic := materializedCanonicalContext table leftState + let rightPublic := materializedCanonicalContext table rightState + have hpublicValues : leftPublic.state.values = rightPublic.state.values := + materializedCanonicalContext_values_eq_of_completionSafe table hstate.forward + have hplan : purePlanProbingHashQuery parameter input leftPublic.state = + purePlanProbingHashQuery parameter input rightPublic.state := + purePlanProbingHashQuery_eq_of_values_eq hpublicValues parameter input + let plan := purePlanProbingHashQuery parameter input leftPublic.state + have hexecutor : + probingHashQueryAfterRootAwarePublicPlan parameter input leftPublic.state plan = + probingHashQueryAfterRootAwarePublicPlan parameter input rightPublic.state + plan := + probingHashQueryAfterRootAwarePublicPlan_eq_of_values_eq parameter input + hpublicValues plan + rw [← hplan, ← hexecutor] + have hstep := relTriple_runObservedCleanFromTable_completionSafeEq + ((probingHashQueryAfterRootAwarePublicPlan parameter input leftPublic.state + plan).run cache) + leftPrefix rightPrefix leftState rightState fuel table hstate + convert continueAfter _ _ hstep using 1 <;> + simp only [leftPublic, plan, observedMaterializedBoundary] <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + | inr message => + change Option Signature → OracleComp (OracleWorld + SigningSpec) α at next + simp only + have hstep := relTriple_runObservedCleanFromTable_completionSafeEq + ((maskedSign parameter root ftsSecret message).run cache) + leftPrefix rightPrefix leftState rightState fuel table hstate + convert continueAfter _ _ hstep using 1 <;> + simp only [observedMaterializedBoundary] <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + +set_option maxRecDepth 100000 in +theorem relTriple_indicator_observedMaterializedBoundary_completionSafeEq + (ordinal : Nat) (parameter : PublicParameter) (publicRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (leftState rightState : LazyRevealProbe.State Coordinate) + (fuel : Nat) (cache : SplitHashCache) + (hstate : CompletionSafeStateEq table leftState rightState) + (hleftStarts : StartTableAgrees leftState table) : + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret computation observations + leftState fuel table cache) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret computation observations + rightState fuel table cache) + (EqRel Bool) := by + let leftRun := observedMaterializedBoundary parameter publicRoot ftsSecret computation + observations leftState fuel table cache + let rightRun := observedMaterializedBoundary parameter publicRoot ftsSecret computation + observations rightState fuel table cache + have hbase := relTriple_observedMaterializedBoundary_completionSafeEq parameter publicRoot + ftsSecret computation observations observations leftState rightState fuel table cache hstate + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result ↦ result ∈ support leftRun) (by + intro result hresult + simpa [leftRun] using hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupported + apply relTriple_map + apply relTriple_post_mono hbothSupported + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hcompletion, hleftSupport⟩, hrightSupport⟩ + cases leftResult with + | none => + cases rightResult with + | none => rfl + | some rightResult => simp [ObservedCompletionSafeEqRel] at hcompletion + | some leftResult => + cases rightResult with + | none => simp [ObservedCompletionSafeEqRel] at hcompletion + | some rightResult => + rcases hcompletion with ⟨_hvalue, htable, _hremaining, + ⟨suffix, hleftObservations, hrightObservations⟩, hfinalState⟩ + have hobservations : leftResult.observations = rightResult.observations := by + rw [hleftObservations, hrightObservations] + have hleftTable : leftResult.table = table := + (startTableAgrees_of_mem_observedMaterializedBoundary parameter publicRoot ftsSecret + computation observations leftState fuel table cache hleftStarts leftResult + (by simpa [leftRun] using hleftSupport)).1 + have hrightTable : rightResult.table = table := htable.symm.trans hleftTable + apply Bool.eq_iff_iff.mpr + simp only [Function.comp_apply, successfulObservedRootComparisonIndicator_eq_true_iff] + exact successfulDoomedFirstRootGoodForComparisonAt_iff_of_completionSafeEq ordinal + target rightRoot leftResult rightResult hfinalState hleftTable hrightTable + hobservations + +set_option maxRecDepth 100000 in +theorem evalDist_delayedSelectedRootIndicator_eq_of_finalizationContextEq + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (probe : Probe) (candidates : List Probe) + (left right : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) + (hrevealed : left.state.revealed = right.state.revealed) : + evalDist + (delayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + computation observations ⟨probe, left, candidates⟩ fuel cache) = + evalDist + (delayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + computation observations ⟨probe, right, candidates⟩ fuel cache) := by + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hbase := relTriple_resolveDeferredPositionValue_of_finalizationViewEq table target + left right hview hleftValid hrightValid hleftCompletable + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result ↦ result ∈ support (resolveDeferredPositionValue target left)) + (fun _ hresult ↦ hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupported + unfold delayedSelectedRootIndicator + apply evalDist_eq_of_relTriple_eqRel + apply relTriple_bind hbothSupported + intro leftResolved rightResolved hrelation + rcases hrelation with ⟨⟨hresolution, hleftSupport⟩, hrightSupport⟩ + cases leftResolved with + | none => + cases rightResolved with + | none => exact relTriple_pure_pure rfl + | some rightResolved => simp [FinalizationResolutionEq] at hresolution + | some leftResolved => + cases rightResolved with + | none => simp [FinalizationResolutionEq] at hresolution + | some rightResolved => + rcases hresolution with + ⟨houtput, hresolvedView, hleftResolvedValid, hrightResolvedValid, + hleftResolvedCompletable⟩ + simp only + rw [← houtput] + by_cases hsafe : CandidatesAvoidRoots target (truncateHash leftResolved.output) + rightRoot (candidates.take ordinal) + · simp only [hsafe, ↓reduceIte] + have hresolvedValues : leftResolved.state.values = rightResolved.state.values := by + rw [resolveDeferredPositionValue_preserves_state_values target left leftResolved + hleftSupport, + resolveDeferredPositionValue_preserves_state_values target right rightResolved + hrightSupport] + exact hvalues + have hleftState := resolveDeferredPositionValue_state_eq_clearPending target left + leftResolved hleftSupport + have hrightState := resolveDeferredPositionValue_state_eq_clearPending target right + rightResolved hrightSupport + have hresolvedRevealed : + leftResolved.state.revealed = rightResolved.state.revealed := by + rw [hleftState, hrightState] + simpa [LazyRevealProbe.State.clearPending] using hrevealed + have hresolvedContext : FinalizationContextEq table + (some leftResolved.toDeferredContext) (some rightResolved.toDeferredContext) := + ⟨hresolvedView, hleftResolvedValid, hrightResolvedValid, + hleftResolvedCompletable⟩ + have hstate := completionSafeStateEq_materialized_of_finalizationContextEq table + leftResolved.toDeferredContext rightResolved.toDeferredContext hresolvedContext + hresolvedValues hresolvedRevealed + have hstarts : StartTableAgrees + (materializedDeferredState leftResolved.toDeferredContext) table := by + intro index output hvalue + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + apply hresolvedView.leftStarts ⟨lay, tree, leafIdx, chainIdx⟩ output + simpa [materializedDeferredState, OtsSecretIndex.coordinate] using hvalue + exact relTriple_indicator_observedMaterializedBoundary_completionSafeEq ordinal + parameter root rightRoot ftsSecret table target computation observations + (materializedDeferredState leftResolved.toDeferredContext) + (materializedDeferredState rightResolved.toDeferredContext) fuel cache hstate hstarts + · simp only [hsafe, ↓reduceIte] + exact relTriple_pure_pure rfl + +set_option maxRecDepth 100000 in +theorem evalDist_negatedDirectDelayedComputationObserve_eq_of_eventEq + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (leftSnapshots rightSnapshots : List PlannedProbeSnapshot) + (leftObservations rightObservations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hleftBefore : ¬ordinal < leftSnapshots.length) + (hrightBefore : ¬ordinal < rightSnapshots.length) + (hsnapshots : leftSnapshots.map PlannedProbeSnapshot.toProbe = + rightSnapshots.map PlannedProbeSnapshot.toProbe) + (htrace : CleanProbeObservationsEventEq leftObservations rightObservations) : + evalDist + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot computation leftSnapshots leftObservations context fuel cache) = + evalDist + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot computation rightSnapshots rightObservations context fuel cache) := by + unfold negatedDirectDelayedComputationObserve + rw [evalDist_map, evalDist_map] + exact congrArg (fun distribution => Bool.not <$> distribution) + (evalDist_directDelayedSelectedRootIndicator_eq_of_eventEq ordinal parameter root ftsSecret + table target rightRoot computation leftSnapshots rightSnapshots leftObservations + rightObservations context fuel cache hleftBefore hrightBefore hsnapshots htrace) + +set_option maxRecDepth 100000 in +theorem evalDist_complement_runDirectWitness_finish_false_eq_of_eventEq + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (next : α → OracleComp (OracleWorld + SigningSpec) β) + (leftSnapshots rightSnapshots : List PlannedProbeSnapshot) + (leftObservations rightObservations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (hleftBefore : ¬ordinal < leftSnapshots.length) + (hrightBefore : ¬ordinal < rightSnapshots.length) + (hsnapshots : leftSnapshots.map PlannedProbeSnapshot.toProbe = + rightSnapshots.map PlannedProbeSnapshot.toProbe) + (htrace : CleanProbeObservationsEventEq leftObservations rightObservations) : + evalDist (Bool.not <$> + (runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2)) + leftSnapshots leftObservations)) = + evalDist (Bool.not <$> + (runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2)) + rightSnapshots rightObservations)) := by + rw [evalDist_map, evalDist_map] + apply congrArg (fun distribution => Bool.not <$> distribution) + apply evalDist_bind_congr + intro result _hresult + cases result with + | stoppedFuel => rfl + | stoppedOrdinary => rfl + | stoppedPrivate witness => rfl + | done result => + unfold finishDirectDelayedSelectedRootIndicator + unfold canonicalizeDirectDelayedSelectedRootIndicator + let canonical := canonicalizeMaterializedValues table result.context + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit] + · by_cases hpublished : PublishedValues result.context.state + · by_cases hcompletable : DeferredCompletable table canonical + · simp only [canonical, hhit, hpublished, hcompletable, ↓reduceIte] + exact evalDist_directDelayedSelectedRootIndicator_eq_of_eventEq ordinal parameter root + ftsSecret table target rightRoot (next result.value.1) leftSnapshots rightSnapshots + leftObservations rightObservations canonical result.remaining result.value.2 + hleftBefore hrightBefore hsnapshots htrace + · simp [canonical, hhit, hpublished, hcompletable] + · simp [canonical, hhit, hpublished] + +theorem evalDist_negated_eq_pure_true_of_true_not_mem + (run : ProbComp Bool) (hfalse : true ∉ support run) : + evalDist (Bool.not <$> run) = evalDist (pure true : ProbComp Bool) := by + have heq := evalDist_eq_of_relTriple_eqRel (relTriple_eq_false_of_true_not_mem run hfalse) + rw [evalDist_map] + simpa using congrArg (fun distribution => Bool.not <$> distribution) heq + +set_option maxRecDepth 100000 in +theorem evalDist_resolve_self_then_negated_delayedSelectedRootIndicator + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (probe : Probe) (candidates : List Probe) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + evalDist (resolveDeferredPositionValue target context >>= fun resolved ↦ + match resolved with + | none => pure true + | some resolved => Bool.not <$> + delayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + computation observations ⟨probe, resolved.toDeferredContext, candidates⟩ fuel cache) = + evalDist (Bool.not <$> + delayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + computation observations ⟨probe, context, candidates⟩ fuel cache) := by + unfold delayedSelectedRootIndicator + rw [map_bind] + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + simp only + rw [resolveDeferredPositionValue_of_resolved target context resolved hresolved] + rfl + +set_option maxRecDepth 1000000 in +theorem evalDist_hash_selected_self_positionNeutral + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hbefore : ¬ordinal < snapshots.length) + (hselected : ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length) : + evalDist (resolveDeferredPositionValue target context >>= fun resolved ↦ + match resolved with + | none => pure true + | some resolved => + negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations resolved.toDeferredContext fuel cache) = + evalDist + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) := by + let candidate? := rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state) + obtain ⟨candidate, hcandidate⟩ : ∃ candidate, candidate? = some candidate := by + cases hcandidate : candidate? with + | none => + simp [candidate?, hcandidate, appendPlannedSnapshot] at hselected + omega + | some candidate => exact ⟨candidate, rfl⟩ + have hlength : snapshots.length = ordinal := by + simp [candidate?, hcandidate, appendPlannedSnapshot] at hselected + omega + let candidates := + (snapshots ++ [(⟨candidate, context⟩ : PlannedProbeSnapshot)]).map + PlannedProbeSnapshot.toProbe + unfold negatedDirectDelayedComputationObserve + have hleft : evalDist (resolveDeferredPositionValue target context >>= fun resolved ↦ + match resolved with + | none => pure true + | some resolved => Bool.not <$> + delayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations ⟨candidate, resolved.toDeferredContext, candidates⟩ fuel cache) = + evalDist (resolveDeferredPositionValue target context >>= fun resolved ↦ + match resolved with + | none => pure true + | some resolved => Bool.not <$> + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations resolved.toDeferredContext fuel cache) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + simp only + have hvalues := resolveDeferredPositionValue_preserves_state_values target context resolved + hresolved + have hplan : purePlanProbingHashQuery parameter input resolved.state = + purePlanProbingHashQuery parameter input context.state := + purePlanProbingHashQuery_eq_of_values_eq hvalues parameter input + have hcandidateResolved : rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input resolved.state) = some candidate := by + rw [hplan] + simpa [candidate?] using hcandidate + have hselectedResolved : ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input resolved.state)) + resolved.toDeferredContext).length := by + simp [appendPlannedSnapshot, hcandidateResolved, hlength] + rw [directDelayedSelectedRootIndicator_hash_eq_selected ordinal parameter root ftsSecret + table target rightRoot input next snapshots observations resolved.toDeferredContext fuel + cache hbefore hselectedResolved] + simp [appendPlannedSnapshot, hcandidateResolved, hlength, candidates, + List.get_eq_getElem] + rw [← hleft] + rw [directDelayedSelectedRootIndicator_hash_eq_selected ordinal parameter root ftsSecret table + target rightRoot input next snapshots observations context fuel cache hbefore hselected] + have hbase := evalDist_resolve_self_then_negated_delayedSelectedRootIndicator ordinal + parameter root ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations candidate candidates context fuel cache + simpa [candidate?, hcandidate, appendPlannedSnapshot, hlength, candidates, + List.get_eq_getElem] using hbase + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem negatedDirectDelayedComputationObserve_hash_observerPositionNeutralAt + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (hbefore : snapshots.length ≤ ordinal) + (haligned : observations.map CleanProbeObservation.toProbe = + snapshots.map PlannedProbeSnapshot.toProbe) + (hclean : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hneutral : ∀ output laterSnapshots laterObservations, + laterSnapshots.length ≤ ordinal → + laterObservations.map CleanProbeObservation.toProbe = + laterSnapshots.map PlannedProbeSnapshot.toProbe → + (∀ observation ∈ laterObservations, ¬observation.ExistingHiddenHit) → + ObserverPositionNeutralAt table target + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot (next output) laterSnapshots laterObservations)) : + ObserverPositionNeutralAt table target + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations) := by + intro context fuel cache hvalid hcompletable hensured + have hnotSelectedBefore : ¬ordinal < snapshots.length := by omega + let plan := purePlanProbingHashQuery parameter input context.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextSnapshots := appendPlannedSnapshot snapshots candidate? context + let nextObservations := observationsAfterCandidate observations + (materializedDeferredState context) candidate? + have hnextAligned : nextObservations.map CleanProbeObservation.toProbe = + nextSnapshots.map PlannedProbeSnapshot.toProbe := by + cases hcandidate : candidate? <;> + simp [nextObservations, nextSnapshots, observationsAfterCandidate, appendPlannedSnapshot, + hcandidate, CleanProbeObservation.toProbe, cleanProbeObservation, haligned] + by_cases hselected : ordinal < nextSnapshots.length + · exact evalDist_hash_selected_self_positionNeutral ordinal parameter root ftsSecret table + target rightRoot input next snapshots observations context fuel cache hnotSelectedBefore (by + simpa [nextSnapshots, candidate?, plan] using hselected) + · have hnextBefore : nextSnapshots.length ≤ ordinal := by omega + have hnextNeutral : + (∀ observation ∈ nextObservations, ¬observation.ExistingHiddenHit) → + ObserverPositionNeutralAt table target + (negatedDirectDelayedObserve + (fun nextContext remaining (value : HashOutput × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2) + nextSnapshots nextObservations) := by + intro hnextClean nextContext remaining value hnextValid hnextCompletable hnextEnsured + simpa [negatedDirectDelayedObserve, negatedDirectDelayedComputationObserve] using + hneutral value.1 nextSnapshots nextObservations hnextBefore hnextAligned hnextClean + nextContext remaining value.2 hnextValid hnextCompletable hnextEnsured + have heq := evalDist_directDelayed_eagerDirectDelayed_hash_not_selected_general_at ordinal + parameter root ftsSecret table target rightRoot input next snapshots observations context fuel + cache hnotSelectedBefore (by simpa [nextSnapshots, candidate?, plan] using hselected) + hvalid hcompletable hensured haligned hclean (by + simpa [nextSnapshots, nextObservations, candidate?, plan] using hnextNeutral) + unfold negatedDirectDelayedComputationObserve + calc + _ = evalDist (Bool.not <$> + eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) := by + unfold eagerDirectDelayedSelectedRootIndicator + rw [if_neg hnotSelectedBefore, map_bind] + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved <;> rfl + _ = _ := by + rw [evalDist_map, evalDist_map] + exact congrArg (fun distribution => Bool.not <$> distribution) heq.symm + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem negatedDirectDelayedComputationObserve_hash_observerSynchronized + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (hbefore : snapshots.length ≤ ordinal) + (haligned : observations.map CleanProbeObservation.toProbe = + snapshots.map PlannedProbeSnapshot.toProbe) + (_hclean : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hsynchronized : ∀ output laterSnapshots laterObservations, + laterSnapshots.length ≤ ordinal → + laterObservations.map CleanProbeObservation.toProbe = + laterSnapshots.map PlannedProbeSnapshot.toProbe → + (∀ observation ∈ laterObservations, ¬observation.ExistingHiddenHit) → + ObserverSynchronized table + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot (next output) laterSnapshots laterObservations)) : + ObserverSynchronized table + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations) where + eq_of_synchronized left right fuel cache hcontext hvalues hrevealed := by + have hnotSelected : ¬ordinal < snapshots.length := by omega + let plan := purePlanProbingHashQuery parameter input left.state + have hplan : purePlanProbingHashQuery parameter input right.state = plan := by + rw [purePlanProbingHashQuery_eq_of_values_eq hvalues.symm parameter input] + let candidate? := rootAwareCandidateForPlan? parameter input plan + have hrightCandidate : rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input right.state) = candidate? := by + rw [hplan] + let nextLeftSnapshots := appendPlannedSnapshot snapshots candidate? left + let nextRightSnapshots := appendPlannedSnapshot snapshots candidate? right + let nextLeftObservations := observationsAfterCandidate observations + (materializedDeferredState left) candidate? + let nextRightObservations := observationsAfterCandidate observations + (materializedDeferredState right) candidate? + have hnextSnapshots : nextLeftSnapshots.map PlannedProbeSnapshot.toProbe = + nextRightSnapshots.map PlannedProbeSnapshot.toProbe := by + cases hcandidate : candidate? <;> + simp [nextLeftSnapshots, nextRightSnapshots, appendPlannedSnapshot, hcandidate] + have hnextLength : nextLeftSnapshots.length = nextRightSnapshots.length := + plannedProbeSnapshots_length_eq_of_toProbe_eq hnextSnapshots + have hnextObservations : nextLeftObservations = nextRightObservations := + observationsAfterCandidate_materializedDeferredState_eq_of_finalizationContextEq table + left right observations candidate? hcontext hvalues hrevealed + have hnextAligned : nextLeftObservations.map CleanProbeObservation.toProbe = + nextLeftSnapshots.map PlannedProbeSnapshot.toProbe := by + cases hcandidate : candidate? <;> + simp [nextLeftObservations, nextLeftSnapshots, observationsAfterCandidate, + appendPlannedSnapshot, hcandidate, CleanProbeObservation.toProbe, + cleanProbeObservation, haligned] + by_cases hselected : ordinal < nextLeftSnapshots.length + · have hselectedRight : ordinal < nextRightSnapshots.length := by + rwa [← hnextLength] + obtain ⟨candidate, hcandidate⟩ : ∃ candidate, candidate? = some candidate := by + cases hcandidate : candidate? with + | none => + simp [nextLeftSnapshots, appendPlannedSnapshot, hcandidate] at hselected + omega + | some candidate => exact ⟨candidate, rfl⟩ + have hlength : snapshots.length = ordinal := by + simp [nextLeftSnapshots, appendPlannedSnapshot, hcandidate] at hselected + omega + have hcandidateLeft : rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input left.state) = some candidate := by + simpa [candidate?, plan] using hcandidate + have hcandidateRight : rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input right.state) = some candidate := + hrightCandidate.trans hcandidate + unfold negatedDirectDelayedComputationObserve + rw [evalDist_map, evalDist_map] + apply congrArg (fun distribution => Bool.not <$> distribution) + rw [directDelayedSelectedRootIndicator_hash_eq_selected ordinal parameter root ftsSecret + table target rightRoot input next snapshots observations left fuel cache hnotSelected (by + simpa [nextLeftSnapshots, candidate?, plan] using hselected)] + rw [directDelayedSelectedRootIndicator_hash_eq_selected ordinal parameter root ftsSecret + table target rightRoot input next snapshots observations right fuel cache hnotSelected (by + simpa [nextRightSnapshots, candidate?, hrightCandidate] using hselectedRight)] + simpa [hcandidateLeft, hcandidateRight, appendPlannedSnapshot, hlength, + List.get_eq_getElem] using + (evalDist_delayedSelectedRootIndicator_eq_of_finalizationContextEq ordinal parameter root + ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations candidate + ((snapshots ++ [(⟨candidate, left⟩ : PlannedProbeSnapshot)]).map + PlannedProbeSnapshot.toProbe) + left right fuel cache hcontext hvalues hrevealed) + · have hnotSelectedRight : ¬ordinal < nextRightSnapshots.length := by + rwa [← hnextLength] + have hnextBefore : nextLeftSnapshots.length ≤ ordinal := by omega + by_cases hnextClean : ∀ observation ∈ nextLeftObservations, + ¬observation.ExistingHiddenHit + · let observe := fun nextContext remaining + (value : HashOutput × SplitHashCache) laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2 + letI : ObserverSynchronized table + (negatedDirectDelayedObserve observe nextLeftSnapshots nextLeftObservations) := ⟨by + intro nextLeft nextRight remaining value hnextContext hnextValues hnextRevealed + exact (hsynchronized value.1 nextLeftSnapshots nextLeftObservations hnextBefore + hnextAligned hnextClean).eq_of_synchronized nextLeft nextRight remaining value.2 + hnextContext hnextValues hnextRevealed⟩ + unfold negatedDirectDelayedComputationObserve + rw [directDelayedSelectedRootIndicator_hash_eq_not_selected ordinal parameter root + ftsSecret table target rightRoot input next snapshots observations left fuel cache + hnotSelected (by simpa [nextLeftSnapshots, candidate?, plan] using hselected)] + rw [directDelayedSelectedRootIndicator_hash_eq_not_selected ordinal parameter root + ftsSecret table target rightRoot input next snapshots observations right fuel cache + hnotSelected (by + simpa [nextRightSnapshots, candidate?, hrightCandidate] using hnotSelectedRight)] + have hsync := + evalDist_complement_runDirectWitness_finish_false_eq_of_synchronized table + observe nextLeftSnapshots nextLeftObservations + ((probingHashQueryAfterRootAwarePlan parameter input plan).run cache) left right fuel + hcontext hvalues hrevealed + have htrace : CleanProbeObservationsEventEq nextLeftObservations + nextRightObservations := by + rw [hnextObservations] + exact CleanProbeObservationsEventEq.refl nextRightObservations + have hevent := + evalDist_complement_runDirectWitness_finish_false_eq_of_eventEq ordinal + parameter root ftsSecret table target rightRoot next nextLeftSnapshots + nextRightSnapshots nextLeftObservations nextRightObservations right fuel + ((probingHashQueryAfterRootAwarePlan parameter input plan).run cache) hselected + hnotSelectedRight hnextSnapshots htrace + rw [hsync] + rw [hevent, hplan] + · have hleftFalse : true ∉ support + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations left fuel cache) := by + intro htrue + apply hnextClean + have hleftStep : ¬ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input left.state)) left).length := by + simpa [nextLeftSnapshots, candidate?, plan] using hselected + have hlength : observations.length = snapshots.length := by + simpa only [List.length_map] using congrArg List.length haligned + have hleftClean := + no_existingHiddenHit_afterCandidate_of_true_mem_hash_not_selected ordinal + parameter root ftsSecret table target rightRoot input next snapshots observations + left fuel cache hnotSelected hleftStep hlength htrue + change ∀ observation ∈ observationsAfterCandidate observations + (materializedDeferredState left) candidate?, ¬observation.ExistingHiddenHit + exact hleftClean + have hrightDirty : ¬∀ observation ∈ nextRightObservations, + ¬observation.ExistingHiddenHit := by + rwa [← hnextObservations] + have hrightFalse : true ∉ support + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations right fuel cache) := by + intro htrue + apply hrightDirty + have hrightStep : ¬ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input right.state)) right).length := by + simpa [nextRightSnapshots, candidate?, hrightCandidate] using hnotSelectedRight + have hlength : observations.length = snapshots.length := by + simpa only [List.length_map] using congrArg List.length haligned + have hrightClean := + no_existingHiddenHit_afterCandidate_of_true_mem_hash_not_selected ordinal + parameter root ftsSecret table target rightRoot input next snapshots observations + right fuel cache hnotSelected hrightStep hlength htrue + change ∀ observation ∈ observationsAfterCandidate observations + (materializedDeferredState right) candidate?, ¬observation.ExistingHiddenHit + rw [← hrightCandidate] + exact hrightClean + unfold negatedDirectDelayedComputationObserve + exact (evalDist_negated_eq_pure_true_of_true_not_mem _ hleftFalse).trans + (evalDist_negated_eq_pure_true_of_true_not_mem _ hrightFalse).symm + + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizeStructural.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizeStructural.lean new file mode 100644 index 00000000..84cbf688 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizeStructural.lean @@ -0,0 +1,250 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizeLift + +/-! Structural synchronization and target-neutrality for adaptive normalization. -/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem negatedDirectDelayedComputationObserve_observerLaws + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + ∀ (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation), + snapshots.length ≤ ordinal → + observations.map CleanProbeObservation.toProbe = + snapshots.map PlannedProbeSnapshot.toProbe → + (∀ observation ∈ observations, ¬observation.ExistingHiddenHit) → + ObserverSynchronized table + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot computation snapshots observations) ∧ + ObserverPositionNeutralAt table target + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table target + rightRoot computation snapshots observations) := by + intro snapshots observations hbefore haligned hclean + induction computation using OracleComp.inductionOn generalizing snapshots observations with + | pure value => + exact ⟨ + negatedDirectDelayedComputationObserve_pure_observerSynchronized ordinal parameter root + ftsSecret table target rightRoot value snapshots observations hbefore, + negatedDirectDelayedComputationObserve_pure_observerPositionNeutralAt ordinal parameter + root ftsSecret table target target rightRoot value snapshots observations hbefore⟩ + | query_bind query next ih => + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + change Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α at next + have hnext : ∀ output, + ObserverSynchronized table + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret + table target rightRoot (next output) snapshots observations) ∧ + ObserverPositionNeutralAt table target + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret + table target rightRoot (next output) snapshots observations) := + fun output ↦ ih output snapshots observations hbefore haligned hclean + exact ⟨ + negatedDirectDelayedComputationObserve_uniform_observerSynchronized ordinal + parameter root ftsSecret table target rightRoot n next snapshots observations + hbefore (fun output ↦ (hnext output).1), + negatedDirectDelayedComputationObserve_uniform_observerPositionNeutralAt ordinal + parameter root ftsSecret table target rightRoot target n next snapshots + observations hbefore (fun output ↦ (hnext output).2)⟩ + | inr input => + change HashOutput → OracleComp (OracleWorld + SigningSpec) α at next + have hnext : ∀ output laterSnapshots laterObservations, + laterSnapshots.length ≤ ordinal → + laterObservations.map CleanProbeObservation.toProbe = + laterSnapshots.map PlannedProbeSnapshot.toProbe → + (∀ observation ∈ laterObservations, + ¬observation.ExistingHiddenHit) → + ObserverSynchronized table + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret + table target rightRoot (next output) laterSnapshots laterObservations) ∧ + ObserverPositionNeutralAt table target + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret + table target rightRoot (next output) laterSnapshots laterObservations) := + fun output laterSnapshots laterObservations hlaterBefore hlaterAligned + hlaterClean ↦ + ih output laterSnapshots laterObservations hlaterBefore hlaterAligned hlaterClean + exact ⟨ + negatedDirectDelayedComputationObserve_hash_observerSynchronized ordinal parameter + root ftsSecret table target rightRoot input next snapshots observations hbefore + haligned hclean + (fun output laterSnapshots laterObservations hlaterBefore hlaterAligned + hlaterClean ↦ + (hnext output laterSnapshots laterObservations hlaterBefore hlaterAligned + hlaterClean).1), + negatedDirectDelayedComputationObserve_hash_observerPositionNeutralAt ordinal + parameter root ftsSecret table target rightRoot input next snapshots observations + hbefore haligned hclean + (fun output laterSnapshots laterObservations hlaterBefore hlaterAligned + hlaterClean ↦ + (hnext output laterSnapshots laterObservations hlaterBefore hlaterAligned + hlaterClean).2)⟩ + | inr message => + change Option Signature → OracleComp (OracleWorld + SigningSpec) α at next + have hnext : ∀ output, + ObserverSynchronized table + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table + target rightRoot (next output) snapshots observations) ∧ + ObserverPositionNeutralAt table target + (negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table + target rightRoot (next output) snapshots observations) := + fun output ↦ ih output snapshots observations hbefore haligned hclean + exact ⟨ + negatedDirectDelayedComputationObserve_signing_observerSynchronized ordinal parameter + root ftsSecret table target rightRoot message next snapshots observations hbefore + (fun output ↦ (hnext output).1), + negatedDirectDelayedComputationObserve_signing_observerPositionNeutralAt ordinal + parameter root ftsSecret table target rightRoot target message next snapshots + observations hbefore (fun output ↦ (hnext output).2)⟩ + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_observe_eq_of_synchronized + (table : OtsSecretIndex → HashOutput) (position : Position) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverSynchronized table observe] + (left right : DeferredContext) (fuel : Nat) (value : α) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) + (hrevealed : left.state.revealed = right.state.revealed) : + evalDist (resolveDeferredPositionValue position left >>= fun resolved ↦ + match resolved with + | none => pure true + | some resolved => observe resolved.toDeferredContext fuel value) = + evalDist (resolveDeferredPositionValue position right >>= fun resolved ↦ + match resolved with + | none => pure true + | some resolved => observe resolved.toDeferredContext fuel value) := by + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hresolved := relTriple_resolveDeferredPositionValue_of_finalizationViewEq table position + left right hview hleftValid hrightValid hleftCompletable + have hresolvedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolved + (fun result => result ∈ support (resolveDeferredPositionValue position left)) + (fun result hresult => hresult) + have hresolvedBoth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hresolvedLeft + apply evalDist_eq_of_relTriple_eqRel + apply relTriple_bind hresolvedBoth + intro leftResolved rightResolved hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResolved with + | none => + cases rightResolved with + | none => exact relTriple_pure_pure rfl + | some rightResolved => simp [FinalizationResolutionEq] at hrelation + | some leftResolved => + cases rightResolved with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResolved => + apply relTriple_eqRel_of_evalDist_eq + apply ObserverSynchronized.eq_of_synchronized + (table := table) (observe := observe) + · exact ⟨hrelation.2.1, hrelation.2.2.1, hrelation.2.2.2.1, + hrelation.2.2.2.2⟩ + · rw [resolveDeferredPositionValue_preserves_state_values position left leftResolved + hleftSupport, + resolveDeferredPositionValue_preserves_state_values position right rightResolved + hrightSupport] + exact hvalues + · rw [resolveDeferredPositionValue_state_eq_clearPending position left leftResolved + hleftSupport, + resolveDeferredPositionValue_state_eq_clearPending position right rightResolved + hrightSupport] + simpa [LazyRevealProbe.State.clearPending] using hrevealed + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_observe_any_at + (table : OtsSecretIndex → HashOutput) (position : Position) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverSynchronized table observe] + (context : DeferredContext) (fuel : Nat) (value : α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hneutral : ObserverPositionNeutralAt table position observe) : + evalDist (resolveDeferredPositionValue position context >>= fun resolved ↦ + match resolved with + | none => pure true + | some resolved => observe resolved.toDeferredContext fuel value) = + evalDist (observe context fuel value) := by + let ensured : DeferredContext := + { context with state := context.state.ensure (.position position) } + have hensuredValid : ensured.Valid := hvalid.ensure (.position position) + have hensuredCompletable : DeferredCompletable table ensured := + hcompletable.ensure (.position position) + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hensuredStarts : StartTableAgrees ensured.state table := + hstarts.ensure (.position position) + have hview : FinalizationViewEq table context ensured := + finalizationViewEq_of_deferredCompletion_iff hvalid hensuredValid hstarts hensuredStarts rfl + hcompletable (fun _ => Iff.rfl) + have hcontext : FinalizationContextEq table (some context) (some ensured) := + ⟨hview, hvalid, hensuredValid, hcompletable⟩ + have hcontextSymm : FinalizationContextEq table (some ensured) (some context) := + ⟨hview.symm, hensuredValid, hvalid, hensuredCompletable⟩ + calc + _ = evalDist (resolveDeferredPositionValue position ensured >>= fun resolved ↦ + match resolved with + | none => pure true + | some resolved => observe resolved.toDeferredContext fuel value) := + evalDist_resolveDeferredPositionValue_then_observe_eq_of_synchronized table position + context ensured fuel value hcontext rfl rfl + _ = evalDist (observe ensured fuel value) := + hneutral ensured fuel value hensuredValid hensuredCompletable + (by simp [ensured, LazyRevealProbe.State.ensure]) + _ = _ := + ObserverSynchronized.eq_of_synchronized ensured context fuel value hcontextSymm rfl rfl + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem evalDist_eagerDirectDelayedSelectedRootIndicator_eq + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hbefore : snapshots.length ≤ ordinal) + (haligned : observations.map CleanProbeObservation.toProbe = + snapshots.map PlannedProbeSnapshot.toProbe) + (hclean : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist + (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot computation snapshots observations context fuel cache) = + evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot computation snapshots observations context fuel cache) := by + have hnotSelected : ¬ordinal < snapshots.length := by omega + let observe := negatedDirectDelayedComputationObserve ordinal parameter root ftsSecret table + target rightRoot computation snapshots observations + have hlaws := negatedDirectDelayedComputationObserve_observerLaws ordinal parameter root + ftsSecret table target rightRoot computation snapshots observations hbefore haligned hclean + letI : ObserverSynchronized table observe := by + simpa only [observe] using hlaws.1 + have hneutral : ObserverPositionNeutralAt table target observe := by + simpa only [observe] using hlaws.2 + apply evalDist_eq_of_complement_eq + unfold eagerDirectDelayedSelectedRootIndicator + rw [if_neg hnotSelected, map_bind] + calc + _ = evalDist (resolveDeferredPositionValue target context >>= fun resolved ↦ + match resolved with + | none => pure true + | some resolved => observe resolved.toDeferredContext fuel cache) := by + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved <;> rfl + _ = evalDist (observe context fuel cache) := + evalDist_resolveDeferredPositionValue_then_observe_any_at table target context fuel cache + hvalid hcompletable hneutral + _ = _ := by rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizeSupport.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizeSupport.lean new file mode 100644 index 00000000..4917336f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizeSupport.lean @@ -0,0 +1,586 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalize + +/-! +# Support invariants for adaptive root normalization + +A successful delayed selected-root execution certifies that every candidate already recorded before +the selected ordinal avoids both comparison roots. This is the unsafe half of eager normalization: +when an earlier candidate does not avoid the eagerly resolved root, the delayed indicator cannot be +true. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable + +theorem positionValue_eq_of_private_of_deferredCompletable + (table : OtsSecretIndex → HashOutput) (target : Position) + (context : DeferredContext) (output : HashOutput) + (hprivate : context.values target = some output) + (hcompletable : DeferredCompletable table context) : + context.positionValue target = some output := by + obtain ⟨completion, hcompletion⟩ := hcompletable + unfold DeferredContext.positionValue + cases hstate : context.state.values (.position target) with + | none => simpa [hstate] using hprivate + | some cached => + have hcached : completion (.position target) = cached := + hcompletion.1 (.position target) cached hstate + have houtput : completion (.position target) = output := + hcompletion.2.1 target output hprivate + have : cached = output := hcached.symm.trans houtput + simpa [hstate, this] + +theorem resolveDeferredPositionValue_output_eq_of_private_of_deferredCompletable + (table : OtsSecretIndex → HashOutput) (target : Position) + (context : DeferredContext) (output : HashOutput) + (hprivate : context.values target = some output) + (hcompletable : DeferredCompletable table context) + (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target context)) : + resolved.output = output := by + have hknown := positionValue_eq_of_private_of_deferredCompletable table target context output + hprivate hcompletable + have hpreserved := resolveDeferredPositionValue_preserves_positionValue target target context + resolved output hknown hresolved + have hresolvedValue := resolveDeferredPositionValue_resolves target context resolved hresolved + exact Option.some.inj (hresolvedValue.symm.trans hpreserved) + +theorem privateValuesLE_of_done_runDirectResolvedWitnessFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) : + PrivateValuesLE context result.context := by + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) := by + rw [← map_erase_runDirectResolvedWitnessFromTable computation context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + exact privateValuesLE_of_done_runDirectResolvedDetailedFromTable computation context fuel table + result hdetailed + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem candidatesAvoidRoots_of_true_mem_directDelayedSelectedRootIndicator + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (output : HashOutput) + (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hprivate : context.values target = some output) + (hcompletable : DeferredCompletable table context) + (hlength : snapshots.length ≤ ordinal) + (htrue : true ∈ support + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + computation snapshots observations context fuel cache)) : + CandidatesAvoidRoots target (truncateHash output) rightRoot + (snapshots.map PlannedProbeSnapshot.toProbe) := by + induction computation using OracleComp.inductionOn generalizing + snapshots observations context fuel cache with + | pure value => + have hbefore : ¬ordinal < snapshots.length := by omega + simp [directDelayedSelectedRootIndicator, hbefore] at htrue + | query_bind query next ih => + have hbefore : ¬ordinal < snapshots.length := by omega + have continueAfter + (runComputation : OracleComp (LazyRevealProbe.World Coordinate) + ((OracleWorld + SigningSpec).Range query × SplitHashCache)) + (nextSnapshots : List PlannedProbeSnapshot) + (nextObservations : List CleanProbeObservation) + (hnextLength : nextSnapshots.length ≤ ordinal) + (hnextTrue : true ∈ support + (runDirectResolvedWitnessFromTable context fuel table runComputation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table + target rightRoot (next value.1) laterSnapshots laterObservations nextContext + remaining value.2)) + nextSnapshots nextObservations)) : + CandidatesAvoidRoots target (truncateHash output) rightRoot + (nextSnapshots.map PlannedProbeSnapshot.toProbe) := by + rw [mem_support_bind_iff] at hnextTrue + obtain ⟨result, hresult, hfinish⟩ := hnextTrue + cases result with + | stoppedFuel => simp [finishDirectDelayedSelectedRootIndicator] at hfinish + | stoppedOrdinary => simp [finishDirectDelayedSelectedRootIndicator] at hfinish + | stoppedPrivate witness => simp [finishDirectDelayedSelectedRootIndicator] at hfinish + | done result => + let canonical := canonicalizeMaterializedValues table result.context + have hprivateLE := privateValuesLE_of_done_runDirectResolvedWitnessFromTable + runComputation context fuel table result hresult + have hnextPrivate : canonical.values target = some output := by + exact (hprivateLE.canonicalize_right table) target output hprivate + unfold finishDirectDelayedSelectedRootIndicator at hfinish + unfold canonicalizeDirectDelayedSelectedRootIndicator at hfinish + change true ∈ support + (if PrivateStructuralHit canonical then pure false + else if PublishedValues result.context.state then + if DeferredCompletable table canonical then + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table + target rightRoot (next result.value.1) nextSnapshots nextObservations + canonical result.remaining result.value.2 + else pure false + else pure false) at hfinish + by_cases hhit : PrivateStructuralHit canonical + · simp [hhit] at hfinish + · by_cases hpublished : PublishedValues result.context.state + · by_cases hnextCompletable : DeferredCompletable table canonical + · simp only [hhit, hpublished, hnextCompletable, ↓reduceIte] at hfinish + exact ih result.value.1 nextSnapshots nextObservations canonical result.remaining + result.value.2 hnextPrivate hnextCompletable hnextLength hfinish + · simp [hhit, hpublished, hnextCompletable] at hfinish + · simp [hhit, hpublished] at hfinish + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [directDelayedSelectedRootIndicator_uniform_eq ordinal parameter root ftsSecret + table target rightRoot n next snapshots observations context fuel cache hbefore] + at htrue + exact continueAfter ((splitUniformImpl n).run cache) snapshots observations hlength + htrue + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextSnapshots := appendPlannedSnapshot snapshots candidate? context + let nextObservations := observationsAfterCandidate observations + (materializedDeferredState context) candidate? + by_cases hselected : ordinal < nextSnapshots.length + · rw [directDelayedSelectedRootIndicator_hash_eq_selected ordinal parameter root + ftsSecret table target rightRoot input next snapshots observations context fuel + cache hbefore (by simpa [nextSnapshots, candidate?, plan] using hselected)] at htrue + have hnextLength : nextSnapshots.length = ordinal + 1 := by + have : nextSnapshots.length ≤ snapshots.length + 1 := by + cases hcandidate : candidate? <;> + simp [nextSnapshots, appendPlannedSnapshot, hcandidate] + omega + have htake : + (nextSnapshots.map PlannedProbeSnapshot.toProbe).take ordinal = + snapshots.map PlannedProbeSnapshot.toProbe := by + cases hcandidate : candidate? with + | none => + simp [nextSnapshots, appendPlannedSnapshot, hcandidate] at hselected + omega + | some candidate => + have hsnapshotLength : snapshots.length = ordinal := by + simp [nextSnapshots, appendPlannedSnapshot, hcandidate] at hnextLength + omega + simp [nextSnapshots, appendPlannedSnapshot, hcandidate, hsnapshotLength] + unfold delayedSelectedRootIndicator at htrue + rw [mem_support_bind_iff] at htrue + obtain ⟨resolvedOption, hresolvedOption, hrest⟩ := htrue + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hselectedContext : + (nextSnapshots.get ⟨ordinal, hselected⟩).context = context := by + cases hcandidate : candidate? with + | none => + exfalso + apply hbefore + simpa [nextSnapshots, appendPlannedSnapshot, hcandidate] using hselected + | some candidate => + have hsnapshotLength : snapshots.length = ordinal := by + simp [nextSnapshots, appendPlannedSnapshot, hcandidate] at hnextLength + omega + simp [nextSnapshots, appendPlannedSnapshot, hcandidate, + hsnapshotLength, List.get_eq_getElem] + rw [hselectedContext] at hresolvedOption + have houtput := + resolveDeferredPositionValue_output_eq_of_private_of_deferredCompletable + table target context output hprivate hcompletable resolved hresolvedOption + simp only at hrest + rw [houtput] at hrest + by_cases hsafe : CandidatesAvoidRoots target (truncateHash output) rightRoot + ((nextSnapshots.map PlannedProbeSnapshot.toProbe).take ordinal) + · simpa [htake] using hsafe + · have hunsafe : ¬CandidatesAvoidRoots target (truncateHash output) rightRoot + (((appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) + context).map PlannedProbeSnapshot.toProbe).take ordinal) := by + simpa [nextSnapshots, candidate?, plan] using hsafe + rw [map_toProbe_appendPlannedSnapshot] at hunsafe + simp [hunsafe] at hrest + · have hnextLength : nextSnapshots.length ≤ ordinal := by omega + rw [directDelayedSelectedRootIndicator_hash_eq_not_selected ordinal parameter root + ftsSecret table target rightRoot input next snapshots observations context fuel + cache hbefore (by simpa [nextSnapshots, candidate?, plan] using hselected)] at htrue + have hnextAvoid := continueAfter + ((probingHashQueryAfterRootAwarePlan parameter input plan).run cache) + nextSnapshots nextObservations hnextLength htrue + intro probe hprobe + apply hnextAvoid probe + cases hcandidate : candidate? with + | none => + simpa [nextSnapshots, appendPlannedSnapshot, hcandidate] using hprobe + | some candidate => + simp only [nextSnapshots, appendPlannedSnapshot, hcandidate, List.map_append, + List.map_singleton, List.mem_append] + exact Or.inl hprobe + | inr message => + rw [directDelayedSelectedRootIndicator_signing_eq ordinal parameter root ftsSecret table + target rightRoot message next snapshots observations context fuel cache hbefore] at htrue + exact continueAfter ((maskedSign parameter root ftsSecret message).run cache) snapshots + observations hlength htrue + +theorem candidatesAvoidRoots_of_true_mem_runDirectWitness_finishDirectDelayed + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (output : HashOutput) + (rightRoot : Digest) (β : Type) + (next : β → OracleComp (OracleWorld + SigningSpec) α) + (runComputation : OracleComp (LazyRevealProbe.World Coordinate) (β × SplitHashCache)) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) + (hprivate : context.values target = some output) + (hlength : snapshots.length ≤ ordinal) + (htrue : true ∈ support + (runDirectResolvedWitnessFromTable context fuel table runComputation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2)) snapshots observations)) : + CandidatesAvoidRoots target (truncateHash output) rightRoot + (snapshots.map PlannedProbeSnapshot.toProbe) := by + rw [mem_support_bind_iff] at htrue + obtain ⟨result, hresult, hfinish⟩ := htrue + cases result with + | stoppedFuel => simp [finishDirectDelayedSelectedRootIndicator] at hfinish + | stoppedOrdinary => simp [finishDirectDelayedSelectedRootIndicator] at hfinish + | stoppedPrivate witness => simp [finishDirectDelayedSelectedRootIndicator] at hfinish + | done result => + let canonical := canonicalizeMaterializedValues table result.context + have hprivateLE := privateValuesLE_of_done_runDirectResolvedWitnessFromTable runComputation + context fuel table result hresult + have hnextPrivate : canonical.values target = some output := by + exact (hprivateLE.canonicalize_right table) target output hprivate + unfold finishDirectDelayedSelectedRootIndicator at hfinish + unfold canonicalizeDirectDelayedSelectedRootIndicator at hfinish + change true ∈ support + (if PrivateStructuralHit canonical then pure false + else if PublishedValues result.context.state then + if DeferredCompletable table canonical then + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next result.value.1) snapshots observations canonical result.remaining + result.value.2 + else pure false + else pure false) at hfinish + by_cases hhit : PrivateStructuralHit canonical + · simp [hhit] at hfinish + · by_cases hpublished : PublishedValues result.context.state + · by_cases hnextCompletable : DeferredCompletable table canonical + · simp only [hhit, hpublished, hnextCompletable, ↓reduceIte] at hfinish + exact candidatesAvoidRoots_of_true_mem_directDelayedSelectedRootIndicator ordinal + parameter root ftsSecret table target output rightRoot (next result.value.1) + snapshots observations canonical result.remaining result.value.2 hnextPrivate + hnextCompletable hlength hfinish + · simp [hhit, hpublished, hnextCompletable] at hfinish + · simp [hhit, hpublished] at hfinish + +open OracleComp.ProgramLogic.Relational + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectWitness_finishDirectDelayed_of_safe_trace + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (output : HashOutput) + (rightRoot : Digest) (β : Type) + (next : β → OracleComp (OracleWorld + SigningSpec) α) + (runComputation : OracleComp (LazyRevealProbe.World Coordinate) (β × SplitHashCache)) + (leftSnapshots rightSnapshots : List PlannedProbeSnapshot) + (leftObservations rightObservations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) + (hprivate : context.values target = some output) + (hleftLength : leftSnapshots.length ≤ ordinal) + (hrightLength : rightSnapshots.length ≤ ordinal) + (hsnapshots : leftSnapshots.map PlannedProbeSnapshot.toProbe = + rightSnapshots.map PlannedProbeSnapshot.toProbe) + (hsafeTrace : CandidatesAvoidRoots target (truncateHash output) rightRoot + (rightSnapshots.map PlannedProbeSnapshot.toProbe) → + CleanProbeObservationsEventEq leftObservations rightObservations) : + RelTriple + (runDirectResolvedWitnessFromTable context fuel table runComputation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2)) rightSnapshots rightObservations) + (runDirectResolvedWitnessFromTable context fuel table runComputation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2)) leftSnapshots leftObservations) + (EqRel Bool) := by + let leftRun := runDirectResolvedWitnessFromTable context fuel table runComputation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2)) rightSnapshots rightObservations + let rightRun := runDirectResolvedWitnessFromTable context fuel table runComputation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2)) leftSnapshots leftObservations + by_cases hsafe : CandidatesAvoidRoots target (truncateHash output) rightRoot + (rightSnapshots.map PlannedProbeSnapshot.toProbe) + · have htrace := hsafeTrace hsafe + have heval : evalDist leftRun = evalDist rightRun := by + dsimp [leftRun, rightRun] + apply evalDist_bind_congr + intro result _hresult + cases result with + | stoppedFuel => rfl + | stoppedOrdinary => rfl + | stoppedPrivate witness => rfl + | done result => + simp only [finishDirectDelayedSelectedRootIndicator, + canonicalizeDirectDelayedSelectedRootIndicator] + split + · rfl + · split + · split + · exact evalDist_directDelayedSelectedRootIndicator_eq_of_eventEq ordinal parameter + root ftsSecret table target rightRoot (next result.value.1) rightSnapshots + leftSnapshots rightObservations leftObservations + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 (by omega) (by omega) hsnapshots.symm htrace.symm + · rfl + · rfl + exact relTriple_eqRel_of_evalDist_eq heval + · have hbase := relTriple_true leftRun rightRun + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun value ↦ value ∈ support leftRun) (fun _ hvalue ↦ hvalue) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupported + apply relTriple_post_mono hbothSupported + intro leftValue rightValue hrelation + have hleftFalse : leftValue = false := by + cases hleft : leftValue with + | false => rfl + | true => + have havoid := candidatesAvoidRoots_of_true_mem_runDirectWitness_finishDirectDelayed + ordinal parameter root ftsSecret table target output rightRoot β next runComputation + rightSnapshots rightObservations context fuel hprivate hrightLength (by + simpa [leftRun, hleft] using hrelation.1.2) + exact (hsafe havoid).elim + have hrightFalse : rightValue = false := by + cases hright : rightValue with + | false => rfl + | true => + have havoid := candidatesAvoidRoots_of_true_mem_runDirectWitness_finishDirectDelayed + ordinal parameter root ftsSecret table target output rightRoot β next runComputation + leftSnapshots leftObservations context fuel hprivate hleftLength (by + simpa [rightRun, hright] using hrelation.2) + have havoidRight : CandidatesAvoidRoots target (truncateHash output) rightRoot + (rightSnapshots.map PlannedProbeSnapshot.toProbe) := by + rwa [hsnapshots] at havoid + exact (hsafe havoidRight).elim + exact hleftFalse.trans hrightFalse.symm + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_directDelayed_eagerDirectDelayed_hash_not_selected + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hbefore : ¬ordinal < snapshots.length) + (hnotSelected : ¬ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + [ObserverSynchronized table + (negatedDirectDelayedObserve + (fun nextContext remaining (value : HashOutput × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2) + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context) + (observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state))))] + [ObserverPositionNeutral table + (negatedDirectDelayedObserve + (fun nextContext remaining (value : HashOutput × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2) + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context) + (observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state))))] + (haligned : + (observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state))).map + CleanProbeObservation.toProbe = + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).map + PlannedProbeSnapshot.toProbe) + (hclean : ∀ observation ∈ + observationsAfterCandidate observations (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)), + ¬observation.ExistingHiddenHit) : + RelTriple + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) + (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) + (EqRel Bool) := by + let candidate? := rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state) + let rightSnapshots := appendPlannedSnapshot snapshots candidate? context + let rightObservations := observationsAfterCandidate observations + (materializedDeferredState context) candidate? + let runComputation := + (probingHashQueryAfterRootAwarePlan parameter input + (purePlanProbingHashQuery parameter input context.state)).run cache + let observe := fun nextContext remaining (value : HashOutput × SplitHashCache) + laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (next value.1) laterSnapshots laterObservations nextContext remaining value.2 + let delayedResolved : Option DeferredResolution → ProbComp Bool + | none => pure false + | some resolved => + runDirectResolvedWitnessFromTable resolved.toDeferredContext fuel table runComputation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + rightSnapshots rightObservations + let eagerResolved : Option DeferredResolution → ProbComp Bool + | none => pure false + | some resolved => + runDirectResolvedWitnessFromTable resolved.toDeferredContext fuel table runComputation >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + (appendPlannedSnapshot snapshots candidate? resolved.toDeferredContext) + (observationsAfterCandidate observations + (materializedDeferredState resolved.toDeferredContext) candidate?) + have hdelayed : evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) = + evalDist (resolveDeferredPositionValue target context >>= delayedResolved) := by + rw [directDelayedSelectedRootIndicator_hash_eq_not_selected ordinal parameter root ftsSecret + table target rightRoot input next snapshots observations context fuel cache hbefore + hnotSelected] + exact (evalDist_resolve_then_runDirectWitness_finish_false table target observe rightSnapshots + rightObservations runComputation context fuel hvalid hcompletable).symm + have heager : evalDist + (eagerDirectDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) = + evalDist (resolveDeferredPositionValue target context >>= eagerResolved) := by + unfold eagerDirectDelayedSelectedRootIndicator + simp only [hbefore, ↓reduceIte] + apply evalDist_bind_congr + intro resolvedOption hresolvedOption + cases resolvedOption with + | none => rfl + | some resolved => + simp only + have hvalues := resolveDeferredPositionValue_preserves_state_values target context resolved + hresolvedOption + have hplan : purePlanProbingHashQuery parameter input resolved.state = + purePlanProbingHashQuery parameter input context.state := + purePlanProbingHashQuery_eq_of_values_eq hvalues parameter input + have hnotSelectedResolved : ¬ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input resolved.state)) + resolved.toDeferredContext).length := by + rw [hplan] + have hlength : + (appendPlannedSnapshot snapshots candidate? resolved.toDeferredContext).length = + rightSnapshots.length := by + cases hcandidate : candidate? <;> + simp [rightSnapshots, appendPlannedSnapshot, hcandidate] + rw [hlength] + simpa [rightSnapshots, candidate?] using hnotSelected + rw [directDelayedSelectedRootIndicator_hash_eq_not_selected ordinal parameter root + ftsSecret table target rightRoot input next snapshots observations + resolved.toDeferredContext fuel cache hbefore hnotSelectedResolved] + rw [hplan] + apply relTriple_of_evalDist_eq_left hdelayed + apply relTriple_of_evalDist_eq_right heager.symm + have hresolve := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + (relTriple_refl (resolveDeferredPositionValue target context)) + (fun resolved ↦ resolved ∈ support (resolveDeferredPositionValue target context)) + (fun _ hresolved ↦ hresolved) + apply relTriple_bind hresolve + intro leftResolved rightResolved hrelation + obtain ⟨rfl, hresolved⟩ := hrelation + cases leftResolved with + | none => + exact relTriple_pure_pure rfl + | some resolved => + have hresolvedPrivate : resolved.values target = some resolved.output := + resolveDeferredPositionValue_installs target context resolved hresolved + have hresolvedCompletable : DeferredCompletable table resolved.toDeferredContext := + hcompletable.of_resolveDeferredPositionValue hvalid target resolved hresolved + let leftSnapshots := appendPlannedSnapshot snapshots candidate? resolved.toDeferredContext + let leftObservations := observationsAfterCandidate observations + (materializedDeferredState resolved.toDeferredContext) candidate? + have hsnapshots : leftSnapshots.map PlannedProbeSnapshot.toProbe = + rightSnapshots.map PlannedProbeSnapshot.toProbe := by + cases hcandidate : candidate? <;> + simp [leftSnapshots, rightSnapshots, appendPlannedSnapshot, hcandidate] + have hlength : rightSnapshots.length ≤ ordinal := by + simpa [rightSnapshots, candidate?] using Nat.le_of_not_gt hnotSelected + apply relTriple_runDirectWitness_finishDirectDelayed_of_safe_trace ordinal parameter root + ftsSecret table target resolved.output rightRoot HashOutput next runComputation + leftSnapshots rightSnapshots leftObservations rightObservations resolved.toDeferredContext + fuel hresolvedPrivate (by rwa [plannedProbeSnapshots_length_eq_of_toProbe_eq hsnapshots]) + hlength hsnapshots + intro hsafe + apply observationsAfterCandidate_eventEq_resolved_current_of_clean_of_avoids target context + resolved hresolved observations candidate? + · simpa [rightObservations, candidate?] using hclean + · intro probe hprobe + have hprobeSnapshots : probe ∈ rightSnapshots.map PlannedProbeSnapshot.toProbe := by + rw [← haligned] + simpa [rightObservations, candidate?] using hprobe + exact (hsafe probe hprobeSnapshots).1 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedAfterRoot.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedAfterRoot.lean new file mode 100644 index 00000000..39379158 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedAfterRoot.lean @@ -0,0 +1,423 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveAfterRoot +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizeStructural + +/-! +# Normalized adaptive coupling after the public root + +The initialized adaptive coupling lands in the eager target-resolution proxy by exact structural +normalization. The remaining bridge from that proxy to the fully observed eager run is kept +directional. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +theorem directDeferredContext_invariants_afterRootResult + (table : OtsSecretIndex → HashOutput) (fuel : Nat) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache))) : + let context := directDeferredContext rootResult.state + context.Valid ∧ DeferredCompletable table context ∧ + StartTableAgrees context.state table ∧ + ∀ coordinate output, + resolvedCompletionValue table context coordinate = some output → + ¬context.state.hitAt coordinate output := by + dsimp only + have hpending := pending_eq_empty_of_mem_runCleanFromTable_maskedPublishedTreeRoot + fuel table rootResult hresult + have hvalid : (directDeferredContext rootResult.state).Valid := by + constructor + · intro position output hvalue + simpa [directDeferredContext, directDeferredValues] using hvalue + · intro coordinate output _hvalue hhit + simp [directDeferredContext, LazyRevealProbe.State.hitAt, + LazyRevealProbe.State.pendingAt, hpending] at hhit + have htable := startTableAgrees_of_mem_runCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (startTableAgrees_empty table) rootResult hresult + have hprivate : ¬PrivateStructuralHit (directDeferredContext rootResult.state) := by + rintro ⟨position, output, _hhidden, _hvalue, hhit⟩ + simp [directDeferredContext, LazyRevealProbe.State.hitAt, + LazyRevealProbe.State.pendingAt, hpending] at hhit + have hstart : ¬MissingChainStartHit table (directDeferredContext rootResult.state) := by + rintro ⟨index, _hvalue, hhit⟩ + simp [directDeferredContext, LazyRevealProbe.State.hitAt, + LazyRevealProbe.State.pendingAt, hpending] at hhit + have hcard : (directDeferredContext rootResult.state).state.pending.card < + Fintype.card Digest := by + simp [directDeferredContext, hpending] + have hcompletable := deferredCompletable_of_valid_of_no_boundary_hit table + (directDeferredContext rootResult.state) hvalid htable.2 hprivate hstart hcard + have hclean : ∀ coordinate output, + resolvedCompletionValue table (directDeferredContext rootResult.state) coordinate = + some output → + ¬(directDeferredContext rootResult.state).state.hitAt coordinate output := by + intro coordinate output _hvalue + simp [directDeferredContext, LazyRevealProbe.State.hitAt, + LazyRevealProbe.State.pendingAt, hpending] + exact ⟨hvalid, hcompletable, htable.2, hclean⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_resolveDeferredPositionValue_canonical_afterRootResult + (table : OtsSecretIndex → HashOutput) (fuel : Nat) (target : Position) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache))) : + RelTriple + (resolveDeferredPositionValue target + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state))) + (resolveDeferredPositionValue target (directDeferredContext rootResult.state)) + (FinalizationResolutionEq table) := by + let context := directDeferredContext rootResult.state + have hinvariants := directDeferredContext_invariants_afterRootResult table fuel rootResult hresult + have hcanonical := valid_completable_canonicalizeMaterializedValues table context + hinvariants.1 hinvariants.2.1 + apply relTriple_resolveDeferredPositionValue_of_finalizationViewEq table target + · exact finalizationViewEq_canonicalize_left table context hinvariants.1 hinvariants.2.2.1 + hinvariants.2.2.2 + · exact hcanonical.1 + · exact hinvariants.1 + · exact hcanonical.2 + +theorem canonicalized_resolutions_afterRootResult + (table : OtsSecretIndex → HashOutput) (target : Position) + (rootState : LazyRevealProbe.State Coordinate) + (left right : DeferredResolution) + (hleft : some left ∈ support + (resolveDeferredPositionValue target + (canonicalizeMaterializedValues table (directDeferredContext rootState)))) + (hright : some right ∈ support + (resolveDeferredPositionValue target (directDeferredContext rootState))) + (hresolution : FinalizationResolutionEq table (some left) (some right)) : + let leftContext := canonicalizeMaterializedValues table left.toDeferredContext + let rightContext := canonicalizeMaterializedValues table right.toDeferredContext + FinalizationContextEq table (some leftContext) (some rightContext) ∧ + leftContext.state.values = rightContext.state.values ∧ + leftContext.state.revealed = rightContext.state.revealed ∧ + CompletionSafeStateEq table + (materializedDeferredState leftContext) + (materializedDeferredState rightContext) := by + dsimp only + have hrevealed : left.state.revealed = right.state.revealed := by + rw [resolveDeferredPositionValue_state_eq_clearPending target + (canonicalizeMaterializedValues table (directDeferredContext rootState)) left hleft, + resolveDeferredPositionValue_state_eq_clearPending target + (directDeferredContext rootState) right hright] + simp [canonicalizeMaterializedValues_revealed, LazyRevealProbe.State.clearPending] + have hcontext : FinalizationContextEq table + (some left.toDeferredContext) (some right.toDeferredContext) := + ⟨hresolution.2.1, hresolution.2.2.1, hresolution.2.2.2.1, + hresolution.2.2.2.2⟩ + have hcanonical := canonicalizedFinalizationContextEq hcontext hrevealed + have hcanonicalRevealed : + (canonicalizeMaterializedValues table left.toDeferredContext).state.revealed = + (canonicalizeMaterializedValues table right.toDeferredContext).state.revealed := by + simpa [canonicalizeMaterializedValues_revealed] using hrevealed + refine ⟨hcanonical.1, hcanonical.2, hcanonicalRevealed, ?_⟩ + exact completionSafeStateEq_materialized_of_finalizationContextEq table + (canonicalizeMaterializedValues table left.toDeferredContext) + (canonicalizeMaterializedValues table right.toDeferredContext) + hcanonical.1 hcanonical.2 hcanonicalRevealed + +theorem canonicalMaterializedValues_of_resolveDeferredPositionValue + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (resolved : DeferredResolution) + (hpublished : PublishedValues context.state) + (hcanonical : CanonicalMaterializedValues table context) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue position context)) : + CanonicalMaterializedValues table resolved.toDeferredContext := by + cases resolved with + | mk resolvedContext output => + cases resolvedContext with + | mk resolvedState resolvedValues => + have hstate := resolveDeferredPositionValue_state_eq_clearPending position context + ⟨⟨resolvedState, resolvedValues⟩, output⟩ hresolved + change resolvedState = context.state.clearPending (.position position) at hstate + subst resolvedState + unfold CanonicalMaterializedValues + change context.state.values = publicMaterializedValues table + { state := context.state.clearPending (.position position), + values := resolvedValues } + rw [hcanonical] + exact (publicMaterializedValues_clearPending_values table context (.position position) + resolvedValues hpublished).symm + +theorem left_resolution_canonical_afterRootResult + (table : OtsSecretIndex → HashOutput) (fuel : Nat) (target : Position) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (left : DeferredResolution) + (hleft : some left ∈ support + (resolveDeferredPositionValue target + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state)))) : + CanonicalMaterializedValues table left.toDeferredContext := by + have hinvariants := directDeferredContext_invariants_afterRootResult table fuel rootResult hresult + have hraw := mem_support_runRaw_done_of_mem_runCleanFromTable_some + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table rootResult hresult + have hpublished : PublishedValues rootResult.state := + preservesPublishedValues_maskedPublishedTreeRoot + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) emptySplitHashCache fuel + rootResult.state rootResult.remaining rootResult.value.1 rootResult.value.2 + publishedValues_empty hraw + let context := canonicalizeMaterializedValues table (directDeferredContext rootResult.state) + have hcontextCanonical : CanonicalMaterializedValues table context := + canonicalizeMaterializedValues_canonical table (directDeferredContext rootResult.state) + hinvariants.1.valuesConsistent + have hcontextPublished : PublishedValues context.state := by + exact hpublished.to_canonicalizedMaterializedValues + exact canonicalMaterializedValues_of_resolveDeferredPositionValue table target context left + hcontextPublished hcontextCanonical hleft + +set_option maxRecDepth 100000 in +theorem relTriple_eagerProxy_resolvedObservedAtRoot_of_resolved + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (rightRoot : Digest) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hresolved : ∀ (left right : DeferredResolution), + some left ∈ support + (resolveDeferredPositionValue target + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state))) → + some right ∈ support + (resolveDeferredPositionValue target (directDeferredContext rootResult.state)) → + FinalizationResolutionEq table (some left) (some right) → + RelTriple + (directDelayedSelectedRootIndicator ordinal parameter rootResult.value.1 ftsSecret table + target rightRoot + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + left.toDeferredContext q rootResult.value.2) + (fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> + observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState right.toDeferredContext) rootResult.remaining + rootResult.table (replaceHiddenRootCache target right.output rootResult.value.2)) + SuccessfulObservedIndicatorRel) : + RelTriple + (eagerDirectDelayedSelectedRootIndicator ordinal parameter rootResult.value.1 ftsSecret table + target rightRoot + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state)) q + rootResult.value.2) + (fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> + resolvedEagerObservedRootComparisonAtRoot adversary parameter ftsSecret target rootResult) + SuccessfulObservedIndicatorRel := by + have hresolve := relTriple_resolveDeferredPositionValue_canonical_afterRootResult table (2 * q) + target rootResult hresult + have hleft := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolve + (fun resolved ↦ resolved ∈ support + (resolveDeferredPositionValue target + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state)))) + (fun resolved hsupport ↦ hsupport) + have hboth := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + unfold eagerDirectDelayedSelectedRootIndicator resolvedEagerObservedRootComparisonAtRoot + simp only [List.length_nil, Nat.not_lt_zero, ↓reduceIte, map_eq_bind_pure_comp, bind_assoc] + apply relTriple_bind hboth + intro left right hrelation + rcases hrelation with ⟨⟨hresolution, hleftSupport⟩, hrightSupport⟩ + cases left with + | none => + cases right with + | none => exact relTriple_pure_pure (fun hfalse ↦ (Bool.false_ne_true hfalse).elim) + | some right => simp [FinalizationResolutionEq] at hresolution + | some left => + cases right with + | none => simp [FinalizationResolutionEq] at hresolution + | some right => + simpa only [pure_bind, map_eq_bind_pure_comp] using + hresolved left right hleftSupport hrightSupport hresolution + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_indicator_observed_eagerDirectDelayed_afterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (rightRoot : Digest) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, rootResult.value.1, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary + ⟨rootResult.value.1, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) + (hroot : IsLayerRoot target) : + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining table rootResult.value.2) + (eagerDirectDelayedSelectedRootIndicator ordinal parameter rootResult.value.1 ftsSecret table + target rightRoot + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state)) q + rootResult.value.2) + SuccessfulObservedIndicatorRel := by + have hdelayed := relTriple_indicator_observed_directDelayed_afterRootResult ordinal adversary + parameter table ftsSecret q target rightRoot rootResult hresult hbound hq hroot + have hinvariants := directDeferredContext_invariants_afterRootResult table (2 * q) rootResult + hresult + have hcanonical := valid_completable_canonicalizeMaterializedValues table + (directDeferredContext rootResult.state) hinvariants.1 hinvariants.2.1 + apply relTriple_of_evalDist_eq_right _ hdelayed + exact (evalDist_eagerDirectDelayedSelectedRootIndicator_eq + (α := RetainedRestResult) ordinal parameter rootResult.value.1 ftsSecret table target rightRoot + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state)) q + rootResult.value.2 (by simp) (by simp) (by simp) hcanonical.1 hcanonical.2).symm + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_indicator_afterRootResult_of_eagerProxy + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, rootResult.value.1, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary + ⟨rootResult.value.1, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) + (hroot : IsLayerRoot target) + (hproxy : ∀ rightRoot, + RelTriple + (eagerDirectDelayedSelectedRootIndicator ordinal parameter rootResult.value.1 ftsSecret + table target rightRoot + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state)) q + rootResult.value.2) + (fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> + resolvedEagerObservedRootComparisonAtRoot adversary parameter ftsSecret target + rootResult) + SuccessfulObservedIndicatorRel) : + RelTriple + (successfulObservedRootComparisonIndicator table ordinal target <$> (do + let observed ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining table rootResult.value.2 + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (retainObservedRoot rootResult.value.1 observed, rightRoot))) + (successfulObservedRootComparisonIndicator table ordinal target <$> + resolvedEagerObservedRootComparisonAfterRootResult adversary parameter ftsSecret target + rootResult) + SuccessfulObservedIndicatorRel := by + apply relTriple_indicator_afterRootResult_of_fixedComparisonRoot ordinal adversary parameter + table ftsSecret target rootResult + intro rightRoot + have hleft := relTriple_indicator_observed_eagerDirectDelayed_afterRootResult ordinal adversary + parameter table ftsSecret q target rightRoot rootResult hresult hbound hq hroot + let observed := observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining table rootResult.value.2 + have hretain : RelTriple + (fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> observed) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun result ↦ (result, rightRoot)) <$> observed) + SuccessfulObservedIndicatorRel := by + apply relTriple_map + apply relTriple_post_mono (relTriple_refl observed) + intro left right heq hgood + subst right + change successfulObservedRootComparisonIndicator table ordinal target + (retainObservedRoot rootResult.value.1 left, rightRoot) = true at hgood + change successfulObservedRootComparisonIndicator table ordinal target + (left, rightRoot) = true + rw [successfulObservedRootComparisonIndicator_eq_true_iff] at hgood ⊢ + exact successfulDoomedFirstRootGoodForComparisonAt_of_retainObservedRoot table ordinal target + rootResult.value.1 rightRoot left hgood + have hfirst := SphincsSecurity.relTriple_trans_exists hretain hleft + have hsecond := SphincsSecurity.relTriple_trans_exists hfirst (hproxy rightRoot) + apply relTriple_post_mono hsecond + intro observed resolved hrelation + obtain ⟨proxy, hchain, heager⟩ := hrelation + obtain ⟨middle, hretained, hnormalized⟩ := hchain + exact fun htrue ↦ heager (hnormalized (hretained htrue)) + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_observedRootComparison_le_production_mul_of_eagerProxy + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) + (hproxy : ∀ (rootResult : CleanRunResult (Digest × SplitHashCache)), + some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache)) → + ∀ rightRoot, + RelTriple + (eagerDirectDelayedSelectedRootIndicator ordinal parameter rootResult.value.1 ftsSecret + table target rightRoot + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state)) q + rootResult.value.2) + (fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> + resolvedEagerObservedRootComparisonAtRoot adversary parameter ftsSecret target + rootResult) + SuccessfulObservedIndicatorRel) : + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] ≤ + Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target (2 * q) table] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_observedRootComparison_le_production_mul_of_afterRootResult ordinal adversary + parameter table ftsSecret q target hroot hparent hfuel + intro rootResult hresult + exact relTriple_indicator_afterRootResult_of_eagerProxy ordinal adversary parameter table + ftsSecret q target rootResult hresult (hbound rootResult.value.1) hq hroot + (hproxy rootResult hresult) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedResolved.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedResolved.lean new file mode 100644 index 00000000..3d41e099 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedResolved.lean @@ -0,0 +1,276 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedAfterRoot + +/-! +# Resolved adaptive selected-root bridge + +The selected hash boundary composes the delayed fixed-output handoff with the administrative +normalization of its materialized state and observation prefix. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem relTriple_boolImp_of_not_reverse + (left right : ProbComp Bool) + (hreverse : RelTriple (Bool.not <$> right) (Bool.not <$> left) BoolImp) : + RelTriple left right BoolImp := by + have hcontra : RelTriple (Bool.not <$> right) (Bool.not <$> left) + (fun rightNot leftNot => BoolImp (!leftNot) (!rightNot)) := by + apply relTriple_post_mono hreverse + intro rightNot leftNot himp + cases rightNot <;> cases leftNot <;> simp [BoolImp] at himp ⊢ + have hmapped := relTriple_map + (R := fun rightValue leftValue : Bool => BoolImp leftValue rightValue) + (f := Bool.not) (g := Bool.not) hcontra + simp only [Functor.map_map, Bool.not_not] at hmapped + simpa only [show (fun value : Bool => value) = id from rfl, id_map] using + relTriple_symm hmapped + +theorem runObservedCleanFromTable_splitUniformImpl + (n fuel : Nat) (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runObservedCleanFromTable observations state fuel table ((splitUniformImpl n).run cache) = (do + let output ← liftM (unifSpec.query n) + pure (some ⟨state, fuel, (output, cache), table, observations⟩)) := by + rfl + +set_option maxRecDepth 100000 in +theorem relTriple_directDelayed_uniform_observed + (ordinal : Nat) (parameter : PublicParameter) (publicRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) + (n : Nat) + (next : Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) RetainedRestResult) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (leftFuel rightFuel : Nat) (cache : SplitHashCache) + (hselected : ¬ordinal < snapshots.length) + (hcompletable : DeferredCompletable table context) + (hpublished : PublishedValues context.state) + (hcanonical : CanonicalMaterializedValues table context) + (hrecursive : ∀ output, + RelTriple + (directDelayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret table target + rightRoot (next output) snapshots observations context leftFuel cache) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret (next output) observations + (materializedDeferredState context) rightFuel table cache) + SuccessfulObservedIndicatorRel) : + RelTriple + (directDelayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inl n))) >>= next) + snapshots observations context leftFuel cache) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inl n))) >>= next) + observations (materializedDeferredState context) rightFuel table cache) + SuccessfulObservedIndicatorRel := by + rw [directDelayedSelectedRootIndicator_uniform_eq ordinal parameter publicRoot ftsSecret table + target rightRoot n next snapshots observations context leftFuel cache hselected] + rw [observedMaterializedBoundary_uniform_query_bind] + rw [runDirectResolvedWitnessFromTable_splitUniformImpl, + runObservedCleanFromTable_splitUniformImpl] + simp only [map_eq_bind_pure_comp, bind_assoc, pure_bind] + apply relTriple_bind (relTriple_refl (liftM (unifSpec.query n))) + intro output _ houtput + subst output + simp only [finishDirectDelayedSelectedRootIndicator] + unfold canonicalizeDirectDelayedSelectedRootIndicator + rw [canonicalizeMaterializedValues_eq_of_canonical table context hcanonical] + simp only [not_privateStructuralHit_of_deferredCompletable hcompletable, + hpublished, hcompletable, ↓reduceIte] + exact hrecursive _ + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_directDelayed_selected_hash_observed_of_good + (ordinal : Nat) (parameter : PublicParameter) (publicRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) + (output : HashOutput) (hroot : IsLayerRoot target) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) RetainedRestResult) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hbefore : snapshots.length = ordinal) + (hcandidate : rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state) = + some ⟨.position target, truncateHash output⟩) + (hstate : context.state.values (.position target) = none) + (hhidden : Coordinate.position target ∉ context.state.revealed) + (hprivate : context.values target = some output) + (havoid : CandidatesAvoidRoots target (truncateHash output) rightRoot + (snapshots.map PlannedProbeSnapshot.toProbe)) + (hcovered : PendingCoveredBy + (snapshots.map PlannedProbeSnapshot.toProbe) context) + (hvalid : context.Valid) + (hcompletable : DeferredCompletable table context) + (hpublished : PublishedValues context.state) + (hcanonical : CanonicalMaterializedValues table context) + (hobservationLength : observations.length = ordinal) + (hprobes : observations.map CleanProbeObservation.toProbe = + snapshots.map PlannedProbeSnapshot.toProbe) + (hnoHit : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) : + RelTriple + (directDelayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations (materializedDeferredState context) fuel table cache) + SuccessfulObservedIndicatorRel := by + let candidate : Probe := ⟨.position target, truncateHash output⟩ + let nextSnapshots := snapshots ++ [(⟨candidate, context⟩ : PlannedProbeSnapshot)] + have hnotSelected : ¬ordinal < snapshots.length := by omega + have hselected : ordinal < nextSnapshots.length := by + simp [nextSnapshots, hbefore] + have hget : nextSnapshots.get ⟨ordinal, hselected⟩ = + (⟨candidate, context⟩ : PlannedProbeSnapshot) := by + subst ordinal + simp [nextSnapshots, List.get_eq_getElem] + let selection : PrivateOrdinalSelection := + ⟨candidate, context, nextSnapshots.map PlannedProbeSnapshot.toProbe⟩ + have hselectionGood : selection.GoodForRoots target output rightRoot ordinal := by + refine ⟨rfl, hstate, hhidden, hprivate, ?_⟩ + simpa [selection, nextSnapshots, hbefore] using havoid + have hselectionCovered : + PendingCoveredBy (selection.candidates.take ordinal) selection.context := by + simpa [selection, nextSnapshots, hbefore] using hcovered + have hselectedEq : + directDelayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache = + delayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations selection fuel cache := by + rw [directDelayedSelectedRootIndicator_hash_eq_selected ordinal parameter publicRoot + ftsSecret table target rightRoot input next snapshots observations context fuel cache + hnotSelected] + · rw [show + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).get + ⟨ordinal, by simpa [appendPlannedSnapshot, hcandidate, candidate, nextSnapshots] + using hselected⟩ = + (⟨candidate, context⟩ : PlannedProbeSnapshot) by + simpa [appendPlannedSnapshot, hcandidate, candidate, nextSnapshots] using hget] + simp [selection, appendPlannedSnapshot, hcandidate, candidate, nextSnapshots] + · simpa [appendPlannedSnapshot, hcandidate, candidate, nextSnapshots] using hselected + rw [hselectedEq] + have hqueryCandidate : ∀ (resolved : DeferredResolution), + some resolved ∈ support + (resolveDeferredPositionValue target selection.context) → + rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table + (materializedDeferredState resolved.toDeferredContext)).state) = + some ⟨.position target, truncateHash output⟩ := by + intro resolved hresolved + have hresolvedValid := hvalid.of_resolveDeferredPositionValue target resolved hresolved + have hresolvedCompletable := + hcompletable.of_resolveDeferredPositionValue hvalid target resolved hresolved + have hresolvedCanonical := canonicalMaterializedValues_of_resolveDeferredPositionValue + table target context resolved hpublished hcanonical hresolved + have hcontextLE := finalizationContextLE_materializedDeferredContext hresolvedValid + hresolvedCompletable + have hvalues : + (materializedCanonicalContext table + (materializedDeferredState resolved.toDeferredContext)).state.values = + resolved.state.values := by + exact canonicalized_right_values_eq_of_finalizationContextLE hcontextLE rfl + hresolvedCanonical + have hpreserved := resolveDeferredPositionValue_preserves_state_values target context + resolved hresolved + rw [purePlanProbingHashQuery_eq_of_values_eq hvalues parameter input, + purePlanProbingHashQuery_eq_of_values_eq hpreserved parameter input] + exact hcandidate + have hselectedBridge := relTriple_delayedSelectedRootIndicator_hash_query ordinal parameter + publicRoot ftsSecret table target output rightRoot hroot input next observations selection + hselectionGood hselectionCovered hobservationLength + (by + intro probe hprobe + exact (havoid probe (by simpa [hprobes] using hprobe)).1) + fuel cache hqueryCandidate + have hinstalledState : + materializedDeferredState + { selection.context with + values := selection.context.values.install target output } = + materializedDeferredState context := by + simpa [selection] using + materializedDeferredState_install_eq_of_value context target output hprivate + have hinstalledNoHit : + ∀ observation ∈ observations.map (installPositionValueAtProbe target output), + ¬observation.ExistingHiddenHit := by + apply no_existingHiddenHit_map_installPositionValueAtProbe_of_avoids target output + · intro observation hobservation + exact hnoHit observation hobservation + · intro probe hprobe + exact (havoid probe (by simpa [hprobes] using hprobe)).1 + let computation := + liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next + let installedRun := observedMaterializedBoundary parameter publicRoot ftsSecret computation + (observations.map (installPositionValueAtProbe target output)) + (materializedDeferredState context) fuel table cache + let actualRun := observedMaterializedBoundary parameter publicRoot ftsSecret computation + observations (materializedDeferredState context) fuel table cache + have hretain : RelTriple + (fixedComparisonRootIndicator table ordinal target publicRoot rightRoot <$> installedRun) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> installedRun) + SuccessfulObservedIndicatorRel := by + apply relTriple_map + apply relTriple_post_mono (relTriple_refl installedRun) + intro left right heq hgood + subst right + change successfulObservedRootComparisonIndicator table ordinal target + (retainObservedRoot publicRoot left, rightRoot) = true at hgood + change successfulObservedRootComparisonIndicator table ordinal target + (left, rightRoot) = true + rw [successfulObservedRootComparisonIndicator_eq_true_iff] at hgood ⊢ + exact successfulDoomedFirstRootGoodForComparisonAt_of_retainObservedRoot table ordinal target + publicRoot rightRoot left hgood + have hprefixed : RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> installedRun) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> actualRun) + SuccessfulObservedIndicatorRel := by + apply relTriple_indicator_observedMaterializedBoundary_ordinaryCache ordinal parameter + publicRoot rightRoot ftsSecret table target computation + (observations.map (installPositionValueAtProbe target output)) observations + (materializedDeferredState context) fuel cache cache rfl + · simpa using hobservationLength + · exact map_toProbe_map_installPositionValueAtProbe target output observations + · exact hinstalledNoHit + · exact hnoHit + rw [hinstalledState] at hselectedBridge + change RelTriple _ (fixedComparisonRootIndicator table ordinal target publicRoot rightRoot <$> + installedRun) SuccessfulObservedIndicatorRel at hselectedBridge + have hfirst := SphincsSecurity.relTriple_trans_exists hselectedBridge hretain + have hsecond := SphincsSecurity.relTriple_trans_exists hfirst hprefixed + apply relTriple_post_mono hsecond + intro source actual hrelation + obtain ⟨middle, hsource, hactual⟩ := hrelation + obtain ⟨retained, hfirst, hsecond⟩ := hsource + exact fun htrue ↦ hactual (hsecond (hfirst htrue)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedSigner.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedSigner.lean new file mode 100644 index 00000000..113825e1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedSigner.lean @@ -0,0 +1,226 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedResolved + +/-! +# Reverse signer normalization + +The complete masked signer preserves exact clean-finalization semantics across a deferred context +and its materialized shadow. Canonicalizing a direct result and rematerializing it recovers the +operational state, while published canonical observers depend only on the common finalization view. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option maxRecDepth 100000 in +theorem finalizationMaterializedCouples_maskedSignAfterDigest + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + FinalizationMaterializedCouples table + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest + apply (finalizationMaterializedCouples_simulateQ ordinaryHashImpl + (finalizationMaterializedCouples_ordinaryHashImpl table) + (ftsOpen parameter index leaves (ftsSecret index))).bind + intro ftsPath + apply (finalizationMaterializedCouples_sequenceFin + (fun lay : Layer ↦ maskedSignLayer parameter ftsSecret index lay) + (fun lay ↦ finalizationMaterializedCouples_maskedSignLayer table parameter ftsSecret + index lay)).bind + intro layers + cases hparts : traverseOption layers with + | none => exact finalizationMaterializedCouples_pure table none + | some parts => + apply (finalizationMaterializedCouples_sequenceFin + (fun lay : Layer ↦ revealLayerValues index lay (parts lay).2) + (fun lay ↦ finalizationMaterializedCouples_revealLayerValues table index lay + (parts lay).2)).bind + intro revealed + let signature : Signature := + { randomness := randomness + ftsSecret := fun tree ↦ ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay ↦ (parts lay).1 + chainValue := fun lay ↦ (revealed lay).1 + authPath := flattenPaths fun lay ↦ (revealed lay).2 } + exact finalizationMaterializedCouples_pure table (some signature) + +set_option maxRecDepth 100000 in +theorem finalizationMaterializedCouples_maskedSign + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + FinalizationMaterializedCouples table + (maskedSign parameter root ftsSecret message) := by + unfold maskedSign + apply (finalizationMaterializedCouples_simulateQ ordinaryRomImpl + (finalizationMaterializedCouples_ordinaryRomImpl table) + (signDigestLoop digestAttemptLimit + ⟨parameter, root, fun _ _ _ _ ↦ 0, ftsSecret⟩ message)).bind + intro selected + cases selected with + | none => exact finalizationMaterializedCouples_pure table none + | some data => + exact finalizationMaterializedCouples_maskedSignAfterDigest table parameter ftsSecret + data.1 data.2.1 data.2.2 + +theorem finalizationContextEq_materializedDeferredContext + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + FinalizationContextEq table (some context) + (some (materializedDeferredContext context)) := by + have hle := finalizationContextLE_materializedDeferredContext hvalid hcompletable + refine ⟨{ + leftConsistent := hle.view.leftConsistent + rightConsistent := hle.view.rightConsistent + leftStarts := hle.view.leftStarts + rightStarts := hle.view.rightStarts + valueEq := hle.view.valueEq + leftClean := hle.view.leftClean + rightClean := hle.view.rightClean + pendingEq := ?_ }, hvalid, hle.rightValid, hcompletable⟩ + intro coordinate _hnone + rfl + +theorem materializedDeferredState_canonicalize_direct_eq + (table : OtsSecretIndex → HashOutput) + (state : LazyRevealProbe.State Coordinate) + (hstarts : StartTableAgrees state table) + (hchainValid : ChainState.ValidFor (fun _ ↦ True) state) : + materializedDeferredState + (canonicalizeMaterializedValues table (directDeferredContext state)) = state := by + cases state with + | mk pending values revealed ensured => + simp only [materializedDeferredState, canonicalizeMaterializedValues, + directDeferredContext] + congr + funext coordinate + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + by_cases hrevealed : Coordinate.chainStart lay tree leafIdx chainIdx ∈ revealed + · have hvalue := (hchainValid (.chainStart lay tree leafIdx chainIdx) + (by simp [IsChainCoordinate])).2.1 hrevealed + obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hvalue + have htable := hstarts ⟨lay, tree, leafIdx, chainIdx⟩ output houtput + simp only [publicMaterializedValues, hrevealed, ↓reduceIte, + resolvedCompletionValue] + have houtput' : values (.chainStart lay tree leafIdx chainIdx) = some output := by + simpa using houtput + exact (congrArg some htable).symm.trans houtput'.symm + · have hvalue : values (.chainStart lay tree leafIdx chainIdx) = none := by + by_contra hne + exact hrevealed ((hchainValid (.chainStart lay tree leafIdx chainIdx) + (by simp [IsChainCoordinate])).1 hne) + simp [publicMaterializedValues, hrevealed, hvalue] + | position position => + by_cases hrevealed : Coordinate.position position ∈ revealed + · simp only [publicMaterializedValues, hrevealed, ↓reduceIte, + resolvedCompletionValue, DeferredContext.positionValue, directDeferredValues] + cases values (.position position) <;> simp + · simp only [publicMaterializedValues, hrevealed, ↓reduceIte, + DeferredContext.positionValue, directDeferredValues] + +theorem evalDist_negatedCanonicalizeDirectDelayedObserve_eq_of_finalizationContextEq_published + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (fuel : Nat) (value : α) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hrevealed : left.state.revealed = right.state.revealed) + (hleftPublished : PublishedValues left.state) + (hrightPublished : PublishedValues right.state) + [ObserverSynchronized table + (negatedDirectDelayedObserve observe snapshots observations)] : + evalDist + (negatedDirectDelayedObserve + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations left fuel value) = + evalDist + (negatedDirectDelayedObserve + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations right fuel value) := by + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hrightCompletable : DeferredCompletable table right := by + obtain ⟨completion, hcompletion⟩ := hleftCompletable + exact ⟨completion, (hview.deferredCompletion_iff completion).mp hcompletion⟩ + have hleftCanonical := valid_completable_canonicalizeMaterializedValues table left + hleftValid hleftCompletable + have hrightCanonical := valid_completable_canonicalizeMaterializedValues table right + hrightValid hrightCompletable + have hleftNoHit : ¬PrivateStructuralHit (canonicalizeMaterializedValues table left) := + not_privateStructuralHit_of_deferredCompletable hleftCanonical.2 + have hrightNoHit : ¬PrivateStructuralHit (canonicalizeMaterializedValues table right) := + not_privateStructuralHit_of_deferredCompletable hrightCanonical.2 + unfold negatedDirectDelayedObserve canonicalizeDirectDelayedSelectedRootIndicator + simp only [hleftNoHit, hrightNoHit, hleftPublished, hrightPublished, + hleftCanonical.2, hrightCanonical.2, ↓reduceIte] + have hcanonical := canonicalizedFinalizationContextEq + (⟨hview, hleftValid, hrightValid, hleftCompletable⟩ : + FinalizationContextEq table (some left) (some right)) hrevealed + exact ObserverSynchronized.eq_of_synchronized + (table := table) + (observe := negatedDirectDelayedObserve observe snapshots observations) + (canonicalizeMaterializedValues table left) + (canonicalizeMaterializedValues table right) fuel value hcanonical.1 hcanonical.2 hrevealed + +theorem relTriple_finishObserve_reverse_of_finalizationMaterialized + (table : OtsSecretIndex → HashOutput) + (leftRun rightRun : ProbComp + (Option (ResolvedRunResult (α × SplitHashCache)))) + (leftObserve rightObserve : DeferredContext → Nat → + (α × SplitHashCache) → ProbComp Bool) + (hstep : RelTriple leftRun rightRun (FinalizationMaterializedRunEq table)) + (hrecursive : ∀ left right, + FinalizationMaterializedRunEq table (some left) (some right) → + RelTriple + (rightObserve right.context right.remaining right.value) + (leftObserve left.context left.remaining left.value) + BoolImp) : + RelTriple + (rightRun >>= finishObserve rightObserve) + (leftRun >>= finishObserve leftObserve) + BoolImp := by + apply relTriple_bind (relTriple_symm hstep) + intro right left hrelation + cases right with + | none => + cases left with + | none => exact relTriple_pure_pure (by simp [BoolImp]) + | some left => simp [FinalizationMaterializedRunEq] at hrelation + | some right => + cases left with + | none => simp [FinalizationMaterializedRunEq] at hrelation + | some left => exact hrecursive left right hrelation + +set_option maxRecDepth 100000 in +theorem evalDist_complement_observed_probeFree_eq_runDirectResolvedObserve + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (continuation : LazyRevealProbe.State Coordinate → Nat → α → ProbComp Bool) + (hprobeFree : computation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) : + evalDist (Bool.not <$> (runObservedCleanFromTable observations state fuel table computation >>= + fun result ↦ match result with + | none => pure false + | some result => continuation result.state result.remaining result.value)) = + evalDist (runDirectResolvedObserve + (fun context remaining value ↦ + Bool.not <$> continuation context.state remaining value) + (directDeferredContext state) fuel table computation) := by + rw [map_bind] + have hobserved := map_attachCleanProbeObservations_runCleanFromTable_of_probeFree computation + observations state fuel table hprobeFree + rw [← hobserved, map_eq_bind_pure_comp, bind_assoc] + have hclean := map_projectResolvedRunResult_runDirect_eq_runClean computation state fuel table + rw [← hclean, map_eq_bind_pure_comp, bind_assoc] + unfold runDirectResolvedObserve + apply evalDist_bind_congr + intro result _hresult + cases result <;> rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedSignerStrong.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedSignerStrong.lean new file mode 100644 index 00000000..a366e4cc --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedSignerStrong.lean @@ -0,0 +1,1351 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedSigner + +/-! +# Exact reverse signer coupling + +A probe-free signer preserves the full finalization view between a deferred execution and its +materialized shadow. Successful runs agree on outputs, caches, revealed coordinates and materialized +values while retaining both independent probe-fuel counters exactly. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def DeferredStructuralValuesLE + (left right : DeferredStructuralValues) : Prop := + ∀ position output, left position = some output → right position = some output + +theorem DeferredStructuralValuesLE.refl (values : DeferredStructuralValues) : + DeferredStructuralValuesLE values values := by + intro position output hvalue + exact hvalue + +theorem DeferredStructuralValuesLE.trans + {left middle right : DeferredStructuralValues} + (hleft : DeferredStructuralValuesLE left middle) + (hright : DeferredStructuralValuesLE middle right) : + DeferredStructuralValuesLE left right := by + intro position output hvalue + exact hright position output (hleft position output hvalue) + +theorem DeferredStructuralValuesLE.install_of_none + {values : DeferredStructuralValues} {position : Position} {installed : HashOutput} + (hmissing : values position = none) : + DeferredStructuralValuesLE values (values.install position installed) := by + intro other output hvalue + have hne : other ≠ position := by + intro heq + subst other + rw [hmissing] at hvalue + contradiction + simpa [DeferredStructuralValues.install, hne] using hvalue + +def DirectWitnessFinalizationMaterializedRunEq + (table : OtsSecretIndex → HashOutput) (initialValues : DeferredStructuralValues) + (leftInitialFuel rightInitialFuel : Nat) : + DirectWitnessResult (α × SplitHashCache) → + DirectDetailedResult (α × SplitHashCache) → Prop + | .done left, .done right => + left.value.1 = right.value.1 ∧ + FinalizationContextEq table (some left.context) (some right.context) ∧ + left.remaining = leftInitialFuel ∧ right.remaining = rightInitialFuel ∧ + left.table = table ∧ right.table = table ∧ + left.value.2 = right.value.2 ∧ + left.context.state.revealed = right.context.state.revealed ∧ + (materializedDeferredState left.context).values = right.context.state.values ∧ + DeferredStructuralValuesLE initialValues left.context.values ∧ + right.context = directDeferredContext right.context.state + | .done _, .stopped _ => False + | _, _ => True + +def DirectWitnessFinalizationMaterializedCouples + (table : OtsSecretIndex → HashOutput) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ left right leftFuel rightFuel leftCache rightCache, + FinalizationContextEq table (some left) (some right) → + leftCache = rightCache → + left.state.revealed = right.state.revealed → + (materializedDeferredState left).values = right.state.values → + right = directDeferredContext right.state → + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table (computation.run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table (computation.run rightCache)) + (DirectWitnessFinalizationMaterializedRunEq table left.values leftFuel rightFuel) + +theorem materializedDeferredState_ensure + (context : DeferredContext) (coordinate : Coordinate) : + materializedDeferredState + { context with state := context.state.ensure coordinate } = + (materializedDeferredState context).ensure coordinate := by + rcases context with ⟨state, values⟩ + rcases state with ⟨pending, stateValues, revealed, ensured⟩ + simp [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.ensure] + +theorem materializedDeferredState_publish + (context : DeferredContext) (coordinate : Coordinate) : + materializedDeferredState + { context with state := context.state.publish coordinate } = + (materializedDeferredState context).publish coordinate := by + rcases context with ⟨state, values⟩ + rcases state with ⟨pending, stateValues, revealed, ensured⟩ + simp [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.publish] + +@[simp] theorem materializedDeferredState_directDeferredContext + (state : LazyRevealProbe.State Coordinate) : + materializedDeferredState (directDeferredContext state) = state := by + rcases state with ⟨pending, values, revealed, ensured⟩ + simp only [materializedDeferredState, directDeferredContext, + directDeferredValues, DeferredContext.positionValue] + congr + funext coordinate + cases coordinate with + | chainStart => rfl + | position position => + change (match values (.position position) with + | some output => some output + | none => values (.position position)) = values (.position position) + cases values (.position position) <;> rfl + +theorem materializedDeferredState_values_materialize_position_of_private + (context : DeferredContext) (position : Position) (output : HashOutput) + (hconsistent : context.ValuesConsistent) + (hprivate : context.values position = some output) : + (materializedDeferredState + { context with state := context.state.materialize (.position position) output }).values = + (materializedDeferredState context).values := by + funext coordinate + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [materializedDeferredState, LazyRevealProbe.State.materialize, + Function.update_of_ne] + | position other => + by_cases heq : other = position + · subst other + cases hvalue : context.state.values (.position position) with + | none => + simp [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, hprivate, hvalue] + | some cached => + have hcached := hconsistent position cached hvalue + rw [hprivate] at hcached + have hsame : output = cached := Option.some.inj hcached + subst cached + simp [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, hprivate, hvalue] + · simp [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by simpa using heq, + heq] + +theorem materializedDeferredState_values_materialize_position_install + (context : DeferredContext) (position : Position) (output : HashOutput) : + (materializedDeferredState + { state := context.state.materialize (.position position) output + values := context.values.install position output }).values = + Function.update (materializedDeferredState context).values + (.position position) (some output) := by + funext coordinate + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [materializedDeferredState, LazyRevealProbe.State.materialize, + Function.update_of_ne] + | position other => + by_cases heq : other = position + · subst other + simp [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, DeferredStructuralValues.install] + · simp [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by simpa using heq, + DeferredStructuralValues.install, heq] + +theorem materializedDeferredState_values_materialize_chainStart + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (index : OtsSecretIndex) : + (materializedDeferredState + { context with state := context.state.materialize index.coordinate (table index) }).values = + Function.update (materializedDeferredState context).values index.coordinate + (some (table index)) := by + rcases index with ⟨indexLay, indexTree, indexLeaf, indexChain⟩ + change + (materializedDeferredState + { context with state := (context.state.materialize + (.chainStart indexLay indexTree indexLeaf indexChain) + (table ⟨indexLay, indexTree, indexLeaf, indexChain⟩)) }).values = + Function.update (materializedDeferredState context).values + (.chainStart indexLay indexTree indexLeaf indexChain) + (some (table ⟨indexLay, indexTree, indexLeaf, indexChain⟩)) + funext coordinate + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + by_cases heq : Coordinate.chainStart lay tree leafIdx chainIdx = + Coordinate.chainStart indexLay indexTree indexLeaf indexChain + · rw [heq] + simp [materializedDeferredState, LazyRevealProbe.State.materialize] + · simp [materializedDeferredState, LazyRevealProbe.State.materialize, + Function.update_of_ne heq] + | position position => + simp [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, OtsSecretIndex.coordinate] + +set_option maxRecDepth 100000 in +theorem FinalizationContextEq.materialize_position_left_of_right_value + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextEq table (some left) (some right)) + (position : Position) (output : HashOutput) + (hleftHidden : left.state.values (.position position) = none) + (hleftPrivate : left.values position = some output) : + FinalizationContextEq table + (some { left with state := left.state.materialize (.position position) output }) + (some right) := by + have hle := (FinalizationContextLE.of_eq hcontext).materialize_position_left + position output hleftHidden hleftPrivate + refine ⟨{ + leftConsistent := hle.view.leftConsistent + rightConsistent := hle.view.rightConsistent + leftStarts := hle.view.leftStarts + rightStarts := hle.view.rightStarts + valueEq := hle.view.valueEq + leftClean := hle.view.leftClean + rightClean := hle.view.rightClean + pendingEq := ?_ }, hle.leftValid, hle.rightValid, hle.leftCompletable⟩ + intro coordinate hnone + have hne : coordinate ≠ .position position := by + intro heq + subst coordinate + simp [resolvedCompletionValue, DeferredContext.positionValue, + LazyRevealProbe.State.materialize] at hnone + have hrightNone : resolvedCompletionValue table right coordinate = none := by + rw [← hle.view.valueEq] + exact hnone + have hleftNone : resolvedCompletionValue table left coordinate = none := by + rw [hcontext.1.valueEq] + exact hrightNone + change (left.state.clearPending (.position position)).pendingAt coordinate = + right.state.pendingAt coordinate + rw [pendingAt_clearPending_of_ne left.state (.position position) coordinate hne] + exact hcontext.1.pendingEq coordinate hleftNone + +set_option maxRecDepth 100000 in +theorem FinalizationContextEq.materialize_position_both + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextEq table (some left) (some right)) + (position : Position) (output : HashOutput) : + FinalizationContextEq table + (some { state := left.state.materialize (.position position) output + values := left.values.install position output }) + (some { state := right.state.materialize (.position position) output + values := right.values.install position output }) := by + have hle := (FinalizationContextLE.of_eq hcontext).materialize_position_both position output + refine ⟨{ + leftConsistent := hle.view.leftConsistent + rightConsistent := hle.view.rightConsistent + leftStarts := hle.view.leftStarts + rightStarts := hle.view.rightStarts + valueEq := hle.view.valueEq + leftClean := hle.view.leftClean + rightClean := hle.view.rightClean + pendingEq := ?_ }, hle.leftValid, hle.rightValid, hle.leftCompletable⟩ + intro coordinate hnone + have hne : coordinate ≠ .position position := by + intro heq + subst coordinate + simp [resolvedCompletionValue, DeferredContext.positionValue, + LazyRevealProbe.State.materialize] at hnone + change (left.state.clearPending (.position position)).pendingAt coordinate = + (right.state.clearPending (.position position)).pendingAt coordinate + rw [pendingAt_clearPending_of_ne left.state (.position position) coordinate hne, + pendingAt_clearPending_of_ne right.state (.position position) coordinate hne] + have hleftNone : resolvedCompletionValue table left coordinate = none := by + cases coordinate with + | chainStart => exact hnone + | position other => + have hother : other ≠ position := by simpa using hne + simpa [resolvedCompletionValue, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by simpa using hother, + DeferredStructuralValues.install, hother] using hnone + exact hcontext.1.pendingEq coordinate hleftNone + +set_option maxRecDepth 100000 in +theorem FinalizationContextEq.materialize_chainStart_left + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextEq table (some left) (some right)) + (index : OtsSecretIndex) : + FinalizationContextEq table + (some { left with state := left.state.materialize index.coordinate (table index) }) + (some right) := by + have hle := (FinalizationContextLE.of_eq hcontext).materialize_chainStart_left index + refine ⟨{ + leftConsistent := hle.view.leftConsistent + rightConsistent := hle.view.rightConsistent + leftStarts := hle.view.leftStarts + rightStarts := hle.view.rightStarts + valueEq := hle.view.valueEq + leftClean := hle.view.leftClean + rightClean := hle.view.rightClean + pendingEq := ?_ }, hle.leftValid, hle.rightValid, hle.leftCompletable⟩ + intro coordinate hnone + have hne : coordinate ≠ index.coordinate := by + intro heq + subst coordinate + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + simp [resolvedCompletionValue, OtsSecretIndex.coordinate] at hnone + have hrightNone : resolvedCompletionValue table right coordinate = none := by + rw [← hle.view.valueEq] + exact hnone + have hleftNone : resolvedCompletionValue table left coordinate = none := by + rw [hcontext.1.valueEq] + exact hrightNone + change (left.state.clearPending index.coordinate).pendingAt coordinate = + right.state.pendingAt coordinate + rw [pendingAt_clearPending_of_ne left.state index.coordinate coordinate hne] + exact hcontext.1.pendingEq coordinate hleftNone + +set_option maxRecDepth 100000 in +theorem FinalizationContextEq.materialize_chainStart_right + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextEq table (some left) (some right)) + (index : OtsSecretIndex) : + FinalizationContextEq table + (some left) + (some { right with state := right.state.materialize index.coordinate (table index) }) := by + have hle := (FinalizationContextLE.of_eq hcontext).materialize_chainStart_right index + refine ⟨{ + leftConsistent := hle.view.leftConsistent + rightConsistent := hle.view.rightConsistent + leftStarts := hle.view.leftStarts + rightStarts := hle.view.rightStarts + valueEq := hle.view.valueEq + leftClean := hle.view.leftClean + rightClean := hle.view.rightClean + pendingEq := ?_ }, hle.leftValid, hle.rightValid, hle.leftCompletable⟩ + intro coordinate hnone + have hne : coordinate ≠ index.coordinate := by + intro heq + subst coordinate + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + simp [resolvedCompletionValue, OtsSecretIndex.coordinate] at hnone + change left.state.pendingAt coordinate = + (right.state.clearPending index.coordinate).pendingAt coordinate + rw [pendingAt_clearPending_of_ne right.state index.coordinate coordinate hne] + exact hcontext.1.pendingEq coordinate hnone + +set_option maxRecDepth 100000 in +theorem FinalizationContextEq.materialize_chainStart_both + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextEq table (some left) (some right)) + (index : OtsSecretIndex) : + FinalizationContextEq table + (some { left with state := left.state.materialize index.coordinate (table index) }) + (some { right with state := right.state.materialize index.coordinate (table index) }) := by + have hle := (FinalizationContextLE.of_eq hcontext).materialize_chainStart_both index + refine ⟨{ + leftConsistent := hle.view.leftConsistent + rightConsistent := hle.view.rightConsistent + leftStarts := hle.view.leftStarts + rightStarts := hle.view.rightStarts + valueEq := hle.view.valueEq + leftClean := hle.view.leftClean + rightClean := hle.view.rightClean + pendingEq := ?_ }, hle.leftValid, hle.rightValid, hle.leftCompletable⟩ + intro coordinate hnone + have hne : coordinate ≠ index.coordinate := by + intro heq + subst coordinate + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + simp [resolvedCompletionValue, OtsSecretIndex.coordinate] at hnone + change (left.state.clearPending index.coordinate).pendingAt coordinate = + (right.state.clearPending index.coordinate).pendingAt coordinate + rw [pendingAt_clearPending_of_ne left.state index.coordinate coordinate hne, + pendingAt_clearPending_of_ne right.state index.coordinate coordinate hne] + have hleftNone : resolvedCompletionValue table left coordinate = none := by + cases coordinate with + | chainStart => exact hnone + | position position => + simpa [resolvedCompletionValue, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, OtsSecretIndex.coordinate] using hnone + exact hcontext.1.pendingEq coordinate hleftNone + +theorem completionSafeStateEq_materialized_right_of_finalizationContextEq + (table : OtsSecretIndex → HashOutput) (left right : DeferredContext) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : (materializedDeferredState left).values = right.state.values) + (hrevealed : left.state.revealed = right.state.revealed) + (hright : right = directDeferredContext right.state) : + CompletionSafeStateEq table (materializedDeferredState left) right.state := by + have hforward := completionSafeStateLE_materialized_of_finalizationContextLE table left right + (FinalizationContextLE.of_eq hcontext) hrevealed hvalues + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hrightCompletable : DeferredCompletable table right := by + obtain ⟨completion, hcompletion⟩ := hleftCompletable + exact ⟨completion, (hview.deferredCompletion_iff completion).mp hcompletion⟩ + have hleftMaterialized := + finalizationContextLE_materializedDeferredContext hleftValid hleftCompletable + have hreverse : FinalizationContextEq table (some right) (some left) := + ⟨hview.symm, hrightValid, hleftValid, hrightCompletable⟩ + have hbackwardContext : FinalizationContextLE table right + (materializedDeferredContext left) := + { view := (FinalizationContextLE.of_eq hreverse).view.trans hleftMaterialized.view + leftValid := hrightValid + rightValid := hleftMaterialized.rightValid + rightCompletable := hleftMaterialized.rightCompletable } + have hrightMaterialized : materializedDeferredState right = right.state := by + rw [hright] + exact materializedDeferredState_directDeferredContext right.state + have hbackwardValues : (materializedDeferredState right).values = + (materializedDeferredState left).values := by + rw [hrightMaterialized, ← hvalues] + have hbackwardRevealed : right.state.revealed = + (materializedDeferredContext left).state.revealed := by + change right.state.revealed = (materializedDeferredState left).revealed + simpa using hrevealed.symm + have hbackward := completionSafeStateLE_materialized_of_finalizationContextLE table right + (materializedDeferredContext left) hbackwardContext hbackwardRevealed (by + change (materializedDeferredState right).values = + (materializedDeferredState left).values + exact hbackwardValues) + refine ⟨hforward, ?_⟩ + rw [hrightMaterialized] at hbackward + exact hbackward + +theorem directWitnessFinalizationMaterializedCouples_pure + (table : OtsSecretIndex → HashOutput) (value : α) : + DirectWitnessFinalizationMaterializedCouples table + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized + hright + rw [StateT.run_pure, StateT.run_pure, runDirectResolvedDetailedFromTable_pure] + simp only [runDirectResolvedWitnessFromTable] + exact relTriple_pure_pure + ⟨rfl, hcontext, rfl, rfl, rfl, rfl, hcache, hrevealed, hmaterialized, + DeferredStructuralValuesLE.refl left.values, hright⟩ + +theorem DirectWitnessFinalizationMaterializedCouples.bind + {table : OtsSecretIndex → HashOutput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : DirectWitnessFinalizationMaterializedCouples table left) + (hnext : ∀ value, DirectWitnessFinalizationMaterializedCouples table (next value)) : + DirectWitnessFinalizationMaterializedCouples table (left >>= next) := by + intro leftContext rightContext leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed + hmaterialized hright + rw [StateT.run_bind, StateT.run_bind, runDirectResolvedWitnessFromTable_bind, + runDirectResolvedDetailedFromTable_bind] + apply relTriple_bind + (hleft leftContext rightContext leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed + hmaterialized hright) + intro leftResult rightResult hresult + cases leftResult with + | stoppedFuel => + cases rightResult with + | stopped reason => exact relTriple_pure_pure trivial + | done rightResult => + have hbase := relTriple_true + (pure (.stoppedFuel : DirectWitnessResult (β × SplitHashCache)) : + ProbComp (DirectWitnessResult (β × SplitHashCache))) + (runDirectResolvedDetailedFromTable rightResult.context rightResult.remaining + rightResult.table ((next rightResult.value.1).run rightResult.value.2)) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result ↦ result = .stoppedFuel) (by intro result hresult; simpa using hresult) + apply relTriple_post_mono hsupported + intro left _right hrelation + rw [hrelation.2] + trivial + | stoppedOrdinary => + cases rightResult with + | stopped reason => exact relTriple_pure_pure trivial + | done rightResult => + have hbase := relTriple_true + (pure (.stoppedOrdinary : DirectWitnessResult (β × SplitHashCache)) : + ProbComp (DirectWitnessResult (β × SplitHashCache))) + (runDirectResolvedDetailedFromTable rightResult.context rightResult.remaining + rightResult.table ((next rightResult.value.1).run rightResult.value.2)) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result ↦ result = .stoppedOrdinary) + (by intro result hresult; simpa using hresult) + apply relTriple_post_mono hsupported + intro left _right hrelation + rw [hrelation.2] + trivial + | stoppedPrivate witness => + cases rightResult with + | stopped reason => exact relTriple_pure_pure trivial + | done rightResult => + have hbase := relTriple_true + (pure (.stoppedPrivate witness : DirectWitnessResult (β × SplitHashCache)) : + ProbComp (DirectWitnessResult (β × SplitHashCache))) + (runDirectResolvedDetailedFromTable rightResult.context rightResult.remaining + rightResult.table ((next rightResult.value.1).run rightResult.value.2)) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result ↦ result = .stoppedPrivate witness) + (by intro result hresult; simpa using hresult) + apply relTriple_post_mono hsupported + intro left _right hrelation + rw [hrelation.2] + trivial + | done leftResult => + cases rightResult with + | stopped reason => simp [DirectWitnessFinalizationMaterializedRunEq] at hresult + | done rightResult => + rcases leftResult with ⟨leftContext, leftRemaining, leftValue, leftTable⟩ + rcases rightResult with ⟨rightContext, rightRemaining, rightValue, rightTable⟩ + rcases leftValue with ⟨leftOutput, leftCache⟩ + rcases rightValue with ⟨rightOutput, rightCache⟩ + simp only [DirectWitnessFinalizationMaterializedRunEq] at hresult + rcases hresult with + ⟨houtput, hcontext, hleftRemaining, hrightRemaining, hleftTable, hrightTable, hcache, + hrevealed, + hmaterialized, hprivateValues, hright⟩ + subst rightOutput + subst leftRemaining + subst rightRemaining + subst leftTable + subst rightTable + have htail := hnext leftOutput leftContext rightContext leftFuel rightFuel leftCache rightCache + hcontext hcache hrevealed hmaterialized hright + apply relTriple_post_mono htail + intro finalLeft finalRight hfinal + cases finalLeft with + | stoppedFuel => trivial + | stoppedOrdinary => trivial + | stoppedPrivate witness => trivial + | done finalLeft => + cases finalRight with + | stopped reason => + simp [DirectWitnessFinalizationMaterializedRunEq] at hfinal + | done finalRight => + simp only [DirectWitnessFinalizationMaterializedRunEq] at hfinal ⊢ + rcases hfinal with + ⟨houtput, hcontext, hleftRemaining, hrightRemaining, hleftTable, hrightTable, + hcache, + hrevealed, hmaterialized, htailValues, hright⟩ + exact ⟨houtput, hcontext, hleftRemaining, hrightRemaining, hleftTable, + hrightTable, hcache, + hrevealed, hmaterialized, hprivateValues.trans htailValues, hright⟩ + +theorem directWitnessFinalizationMaterializedCouples_ensureCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + DirectWitnessFinalizationMaterializedCouples table (ensureCoordinate coordinate) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized + hright + unfold ensureCoordinate + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.ensureQuery, + runDirectResolvedWitnessFromTable_ensure_query_bind, + runDirectResolvedDetailedFromTable_ensure_query_bind, + runDirectResolvedDetailedFromTable_pure] + simp only [runDirectResolvedWitnessFromTable] + apply relTriple_pure_pure + refine ⟨rfl, ⟨hcontext.1.ensure coordinate, hcontext.2.1.ensure coordinate, + hcontext.2.2.1.ensure coordinate, hcontext.2.2.2.ensure coordinate⟩, + rfl, rfl, rfl, rfl, hcache, ?_, ?_, ?_, ?_⟩ + · simpa [LazyRevealProbe.State.ensure] using hrevealed + · simpa [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.ensure] using hmaterialized + · exact DeferredStructuralValuesLE.refl left.values + · rw [hright] + simp [directDeferredContext, directDeferredValues_ensure] + +set_option maxRecDepth 100000 in +theorem directWitnessFinalizationMaterializedCouples_revealCoordinateOutput_position + (table : OtsSecretIndex → HashOutput) (position : Position) : + DirectWitnessFinalizationMaterializedCouples table + (revealCoordinateOutput (.position position)) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized + hright + cases hleftValue : left.state.values (.position position) with + | some output => + have hleftResolved : resolvedCompletionValue table left (.position position) = + some output := by + simp [resolvedCompletionValue, DeferredContext.positionValue, hleftValue] + have hrightResolved : resolvedCompletionValue table right (.position position) = + some output := by + rw [← hcontext.1.valueEq] + exact hleftResolved + have hrightValue : right.state.values (.position position) = some output := by + have hvalue := congrFun hmaterialized (.position position) + simpa [materializedDeferredState_position, DeferredContext.positionValue, + hleftValue] using hvalue.symm + rw [runDirectResolvedWitnessFromTable_revealCoordinateOutput_of_value table + (.position position) left leftFuel leftCache output hleftValue, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + (.position position) right rightFuel rightCache output hrightValue] + apply relTriple_pure_pure + refine ⟨rfl, hcontext, rfl, rfl, rfl, rfl, ?_, hrevealed, hmaterialized, + DeferredStructuralValuesLE.refl left.values, hright⟩ + simpa [hcache] + | none => + cases hrightValue : right.state.values (.position position) with + | some output => + have hprivate := (FinalizationContextLE.of_eq hcontext).view + |>.privateValue_of_left_hidden_of_right_materialized + position output hleftValue hrightValue + rw [runDirectResolvedWitnessFromTable_revealCoordinateOutput_position_of_private + table position left leftFuel leftCache output hleftValue hprivate, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + (.position position) right rightFuel rightCache output hrightValue] + have hresolved : resolvedCompletionValue table left (.position position) = + some output := by + simp [resolvedCompletionValue, DeferredContext.positionValue, hleftValue, hprivate] + have hmiss := hcontext.1.leftClean (.position position) output hresolved + simp only [hmiss, ↓reduceIte] + apply relTriple_pure_pure + refine ⟨rfl, + hcontext.materialize_position_left_of_right_value position output + hleftValue hprivate, + rfl, rfl, rfl, rfl, ?_, ?_, ?_, DeferredStructuralValuesLE.refl left.values, + hright⟩ + · simpa [hcache] + · simpa [LazyRevealProbe.State.materialize] using hrevealed + · rw [materializedDeferredState_values_materialize_position_of_private + left position output hcontext.2.1.valuesConsistent hprivate] + exact hmaterialized + | none => + have hrightPrivate : right.values position = none := by + rw [hright] + simpa [directDeferredContext, directDeferredValues] using hrightValue + have hleftPositionValue : left.positionValue position = none := by + change resolvedCompletionValue table left (.position position) = none + rw [hcontext.1.valueEq] + simp [resolvedCompletionValue, DeferredContext.positionValue, hrightValue, + hrightPrivate] + have hleftPrivate : left.values position = none := by + simpa [DeferredContext.positionValue, hleftValue] using hleftPositionValue + rw [runDirectResolvedWitnessFromTable_revealCoordinateOutput_position_of_fresh + table position left leftFuel leftCache hleftValue hleftPrivate, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_position_of_fresh + table position right rightFuel rightCache hrightValue hrightPrivate] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + have hresolvedNone : resolvedCompletionValue table left (.position position) = none := by + simpa [resolvedCompletionValue] using hleftPositionValue + have hpending := hcontext.1.pendingEq (.position position) hresolvedNone + have hhit : left.state.hitAt (.position position) leftOutput ↔ + right.state.hitAt (.position position) leftOutput := by + change truncateHash leftOutput ∈ left.state.pendingAt (.position position) ↔ + truncateHash leftOutput ∈ right.state.pendingAt (.position position) + rw [hpending] + by_cases hleftHit : left.state.hitAt (.position position) leftOutput + · have hrightHit := hhit.mp hleftHit + simp only [hleftHit, hrightHit, ↓reduceIte] + exact relTriple_pure_pure trivial + · have hrightHit := hhit.not.mp hleftHit + simp only [hleftHit, hrightHit, ↓reduceIte] + apply relTriple_pure_pure + refine ⟨rfl, hcontext.materialize_position_both position leftOutput, + rfl, rfl, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · simpa [hcache] + · simpa [LazyRevealProbe.State.materialize] using hrevealed + · rw [materializedDeferredState_values_materialize_position_install] + simpa [LazyRevealProbe.State.materialize] using + congrArg (fun values : Coordinate → Option HashOutput => + Function.update values (.position position) + (some leftOutput)) hmaterialized + · exact DeferredStructuralValuesLE.install_of_none hleftPrivate + · rw [hright] + simp [directDeferredContext, directDeferredValues_materialize_position] + +theorem directWitnessFinalizationMaterializedCouples_revealPosition + (table : OtsSecretIndex → HashOutput) (position : Position) : + DirectWitnessFinalizationMaterializedCouples table (revealPosition position) := by + unfold revealPosition revealCoordinate + exact (directWitnessFinalizationMaterializedCouples_revealCoordinateOutput_position + table position).bind fun output ↦ + directWitnessFinalizationMaterializedCouples_pure table (truncateHash output) + +set_option maxRecDepth 100000 in +theorem directWitnessFinalizationMaterializedCouples_revealCoordinateOutput_chainStart + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) : + DirectWitnessFinalizationMaterializedCouples table + (revealCoordinateOutput index.coordinate) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized + hright + have hrightCompletable := (FinalizationContextLE.of_eq hcontext).rightCompletable + cases hleftValue : left.state.values index.coordinate with + | some output => + have houtput := hcontext.1.leftStarts index output hleftValue + subst output + rw [runDirectResolvedWitnessFromTable_revealCoordinateOutput_of_value table + index.coordinate left leftFuel leftCache (table index) hleftValue] + cases hrightValue : right.state.values index.coordinate with + | some output => + have houtput := hcontext.1.rightStarts index output hrightValue + subst output + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + index.coordinate right rightFuel rightCache (table index) hrightValue] + apply relTriple_pure_pure + refine ⟨rfl, hcontext, rfl, rfl, rfl, rfl, ?_, hrevealed, hmaterialized, + DeferredStructuralValuesLE.refl left.values, hright⟩ + simpa [hcache] + | none => + have hvalue := congrFun hmaterialized index.coordinate + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + change left.state.values (.chainStart lay tree leafIdx chainIdx) = + some (table ⟨lay, tree, leafIdx, chainIdx⟩) at hleftValue + change right.state.values (.chainStart lay tree leafIdx chainIdx) = none at hrightValue + have hvalue' : left.state.values (.chainStart lay tree leafIdx chainIdx) = + right.state.values (.chainStart lay tree leafIdx chainIdx) := by + simpa [materializedDeferredState, OtsSecretIndex.coordinate] using hvalue + rw [hleftValue, hrightValue] at hvalue' + contradiction + | none => + have hleftMiss : ¬left.state.hitAt index.coordinate (table index) := + hcontext.2.2.2.not_hitAt_chainStart index + rw [runDirectResolvedWitnessFromTable_revealCoordinateOutput_chainStart_of_missing + table index left leftFuel leftCache hleftValue, if_neg hleftMiss] + cases hrightValue : right.state.values index.coordinate with + | some output => + have hvalue := congrFun hmaterialized index.coordinate + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + change left.state.values (.chainStart lay tree leafIdx chainIdx) = none at hleftValue + change right.state.values (.chainStart lay tree leafIdx chainIdx) = some output at hrightValue + have hvalue' : left.state.values (.chainStart lay tree leafIdx chainIdx) = + right.state.values (.chainStart lay tree leafIdx chainIdx) := by + simpa [materializedDeferredState, OtsSecretIndex.coordinate] using hvalue + rw [hleftValue, hrightValue] at hvalue' + contradiction + | none => + have hrightMiss : ¬right.state.hitAt index.coordinate (table index) := + hrightCompletable.not_hitAt_chainStart index + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_chainStart_of_missing + table index right rightFuel rightCache hrightValue, if_neg hrightMiss] + apply relTriple_pure_pure + refine ⟨rfl, hcontext.materialize_chainStart_both index, + rfl, rfl, rfl, rfl, ?_, ?_, ?_, DeferredStructuralValuesLE.refl left.values, ?_⟩ + · simpa [hcache] + · simpa [LazyRevealProbe.State.materialize] using hrevealed + · rw [materializedDeferredState_values_materialize_chainStart table] + simpa [LazyRevealProbe.State.materialize] using + congrArg (fun values : Coordinate → Option HashOutput => + Function.update values index.coordinate + (some (table index))) hmaterialized + · rw [hright] + simp [directDeferredContext, directDeferredValues_materialize_chainStart] + +theorem directWitnessFinalizationMaterializedCouples_revealCoordinateOutput + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + DirectWitnessFinalizationMaterializedCouples table + (revealCoordinateOutput coordinate) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact directWitnessFinalizationMaterializedCouples_revealCoordinateOutput_chainStart table + ⟨lay, tree, leafIdx, chainIdx⟩ + | position position => + exact directWitnessFinalizationMaterializedCouples_revealCoordinateOutput_position + table position + +theorem directWitnessFinalizationMaterializedCouples_revealCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + DirectWitnessFinalizationMaterializedCouples table (revealCoordinate coordinate) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + unfold revealCoordinate + exact (directWitnessFinalizationMaterializedCouples_revealCoordinateOutput_chainStart table + ⟨lay, tree, leafIdx, chainIdx⟩).bind fun output ↦ + directWitnessFinalizationMaterializedCouples_pure table (truncateHash output) + | position position => + exact directWitnessFinalizationMaterializedCouples_revealPosition table position + +theorem directWitnessFinalizationMaterializedCouples_publishCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + DirectWitnessFinalizationMaterializedCouples table (publishCoordinate coordinate) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized + hright + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + unfold publishCoordinate + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.publishQuery, + runDirectResolvedWitnessFromTable_publish_query_bind, + runDirectResolvedDetailedFromTable_publish_query_bind, + runDirectResolvedDetailedFromTable_pure] + simp only [runDirectResolvedWitnessFromTable] + apply relTriple_pure_pure + refine ⟨rfl, + ⟨hview.publish coordinate, hleftValid.publish coordinate, + hrightValid.publish coordinate, hleftCompletable.publish coordinate⟩, + rfl, rfl, rfl, rfl, hcache, ?_, ?_, DeferredStructuralValuesLE.refl left.values, ?_⟩ + · simpa [LazyRevealProbe.State.publish] using congrArg (insert coordinate) hrevealed + · rw [materializedDeferredState_publish] + simpa [LazyRevealProbe.State.publish] using hmaterialized + · rw [hright] + simp [directDeferredContext, directDeferredValues_publish] + +theorem directWitnessFinalizationMaterializedCouples_revealPublishedCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + DirectWitnessFinalizationMaterializedCouples table + (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate revealCoordinate + simp only [bind_assoc, pure_bind] + apply (directWitnessFinalizationMaterializedCouples_revealCoordinateOutput + table coordinate).bind + intro output + apply (directWitnessFinalizationMaterializedCouples_publishCoordinate + table coordinate).bind + intro _ + exact directWitnessFinalizationMaterializedCouples_pure table (truncateHash output) + +set_option maxRecDepth 100000 in +theorem directWitnessFinalizationMaterializedCouples_sequenceFin + {table : OtsSecretIndex → HashOutput} {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, + DirectWitnessFinalizationMaterializedCouples table (computation index)) : + DirectWitnessFinalizationMaterializedCouples table (sequenceFin computation) := by + induction n with + | zero => + simpa [sequenceFin] using + (directWitnessFinalizationMaterializedCouples_pure table Fin.elim0 : + DirectWitnessFinalizationMaterializedCouples table + (pure Fin.elim0 : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Fin 0 → α))) + | succ n ih => + rw [sequenceFin] + apply (hcomponent 0).bind + intro head + apply (ih (fun index : Fin n ↦ computation index.succ) + (fun index ↦ hcomponent index.succ)).bind + intro tail + exact directWitnessFinalizationMaterializedCouples_pure table + (Fin.cases head tail : Fin (n + 1) → α) + +set_option maxRecDepth 100000 in +theorem directWitnessFinalizationMaterializedCouples_splitHashQuery_ordinary + (table : OtsSecretIndex → HashOutput) (input : HashInput) : + DirectWitnessFinalizationMaterializedCouples table + (splitHashQuery (.ordinary input)) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized + hright + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + have hcacheAt : leftCache (.ordinary input) = rightCache (.ordinary input) := + congrFun hcache (.ordinary input) + cases hlookup : leftCache (.ordinary input) with + | some output => + have hrightLookup : rightCache (.ordinary input) = some output := by + rw [← hcacheAt] + exact hlookup + simp only [hrightLookup] + exact directWitnessFinalizationMaterializedCouples_pure table output left right leftFuel + rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized hright + | none => + have hrightLookup : rightCache (.ordinary input) = none := by + rw [← hcacheAt] + exact hlookup + simp only [hrightLookup] + rw [LazyRevealProbe.hashOutputQuery, + runDirectResolvedWitnessFromTable_hashOutput_query_bind, + runDirectResolvedDetailedFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runDirectResolvedWitnessFromTable, runDirectResolvedDetailedFromTable] + apply relTriple_pure_pure + refine ⟨rfl, hcontext, rfl, rfl, rfl, rfl, ?_, hrevealed, hmaterialized, + DeferredStructuralValuesLE.refl left.values, hright⟩ + simpa [hcache] + +theorem directWitnessFinalizationMaterializedCouples_ordinaryHashImpl + (table : OtsSecretIndex → HashOutput) (input : HashInput) : + DirectWitnessFinalizationMaterializedCouples table (ordinaryHashImpl input) := + directWitnessFinalizationMaterializedCouples_splitHashQuery_ordinary table input + +theorem directWitnessFinalizationMaterializedCouples_splitUniformImpl + (table : OtsSecretIndex → HashOutput) (n : unifSpec.Domain) : + DirectWitnessFinalizationMaterializedCouples table (splitUniformImpl n) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized + hright + unfold splitUniformImpl + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.uniformQuery, + runDirectResolvedWitnessFromTable_uniform_query_bind, + runDirectResolvedDetailedFromTable_uniform_query_bind] + apply relTriple_bind (relTriple_refl + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))) + intro leftOutput rightOutput houtput + subst rightOutput + exact directWitnessFinalizationMaterializedCouples_pure table leftOutput left right leftFuel + rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized hright + +theorem directWitnessFinalizationMaterializedCouples_simulateQ + {table : OtsSecretIndex → HashOutput} {spec : OracleSpec ι} + (impl : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))) + (hquery : ∀ query, + DirectWitnessFinalizationMaterializedCouples table (impl query)) + (computation : OracleComp spec α) : + DirectWitnessFinalizationMaterializedCouples table (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp only [simulateQ_pure] + exact directWitnessFinalizationMaterializedCouples_pure table value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (hquery query).bind fun output ↦ ih output + +theorem directWitnessFinalizationMaterializedCouples_ordinaryRomImpl + (table : OtsSecretIndex → HashOutput) (query : OracleWorld.Domain) : + DirectWitnessFinalizationMaterializedCouples table (ordinaryRomImpl query) := by + cases query with + | inl n => exact directWitnessFinalizationMaterializedCouples_splitUniformImpl table n + | inr input => exact directWitnessFinalizationMaterializedCouples_ordinaryHashImpl table input + +theorem directWitnessFinalizationMaterializedCouples_ensureFullChain + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + DirectWitnessFinalizationMaterializedCouples table + (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + apply (directWitnessFinalizationMaterializedCouples_sequenceFin + (fun step : ChainStep => + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step))) + (fun step => directWitnessFinalizationMaterializedCouples_ensureCoordinate table + (.position (.chain lay tree leafIdx chainIdx step)))).bind + intro _ + exact directWitnessFinalizationMaterializedCouples_pure table () + +theorem directWitnessFinalizationMaterializedCouples_ensureOtsLeaf + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + DirectWitnessFinalizationMaterializedCouples table (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + apply (directWitnessFinalizationMaterializedCouples_sequenceFin + (fun chainIdx : ChainIndex => ensureFullChain lay tree leafIdx chainIdx) + (fun chainIdx => directWitnessFinalizationMaterializedCouples_ensureFullChain table lay tree + leafIdx chainIdx)).bind + intro _ + exact directWitnessFinalizationMaterializedCouples_ensureCoordinate table + (.position (.leaf lay tree leafIdx)) + +theorem directWitnessFinalizationMaterializedCouples_ensureTreeNode + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, + DirectWitnessFinalizationMaterializedCouples table (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => + directWitnessFinalizationMaterializedCouples_ensureOtsLeaf table lay tree + (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + apply (directWitnessFinalizationMaterializedCouples_ensureTreeNode table lay tree level + (2 * nodeIdx)).bind + intro _ + apply (directWitnessFinalizationMaterializedCouples_ensureTreeNode table lay tree level + (2 * nodeIdx + 1)).bind + intro _ + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact directWitnessFinalizationMaterializedCouples_ensureCoordinate table + (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact directWitnessFinalizationMaterializedCouples_pure table () + +theorem directWitnessFinalizationMaterializedCouples_maskedTreeNode + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) : + DirectWitnessFinalizationMaterializedCouples table + (maskedTreeNode lay tree level nodeIdx) := by + unfold maskedTreeNode + apply (directWitnessFinalizationMaterializedCouples_ensureTreeNode table lay tree level + nodeIdx).bind + intro _ + cases level with + | zero => + exact directWitnessFinalizationMaterializedCouples_revealPosition table + (.leaf lay tree (leafOfNat nodeIdx)) + | succ current => + by_cases hlevel : current < maxLayerHeight + · simp only [hlevel, ↓reduceDIte] + exact directWitnessFinalizationMaterializedCouples_revealPosition table + (.node lay tree ⟨current, hlevel⟩ (leafOfNat nodeIdx)) + · simp only [hlevel, ↓reduceDIte] + exact directWitnessFinalizationMaterializedCouples_pure table 0 + +theorem directWitnessFinalizationMaterializedCouples_maskedTreeRoot + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + DirectWitnessFinalizationMaterializedCouples table (maskedTreeRoot lay tree) := by + unfold maskedTreeRoot + exact directWitnessFinalizationMaterializedCouples_maskedTreeNode table lay tree + (layerHeight lay) 0 + +theorem directWitnessFinalizationMaterializedCouples_ensureChainPrefix + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + DirectWitnessFinalizationMaterializedCouples table + (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + apply (directWitnessFinalizationMaterializedCouples_sequenceFin + (fun step : ChainStep => + if step.val < digit.val then + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + else pure ()) + (fun step => by + by_cases hstep : step.val < digit.val + · rw [if_pos hstep] + exact directWitnessFinalizationMaterializedCouples_ensureCoordinate table + (.position (.chain lay tree leafIdx chainIdx step)) + · rw [if_neg hstep] + exact directWitnessFinalizationMaterializedCouples_pure table ())).bind + intro _ + exact directWitnessFinalizationMaterializedCouples_pure table () + +theorem directWitnessFinalizationMaterializedCouples_ensureTreePath + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + DirectWitnessFinalizationMaterializedCouples table (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + apply (directWitnessFinalizationMaterializedCouples_sequenceFin + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + ensureTreeNode lay tree level.val (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + else pure ()) + (fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + exact directWitnessFinalizationMaterializedCouples_ensureTreeNode table lay tree + level.val (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · rw [if_neg hlevel] + exact directWitnessFinalizationMaterializedCouples_pure table ())).bind + intro _ + exact directWitnessFinalizationMaterializedCouples_pure table () + +theorem directWitnessFinalizationMaterializedCouples_maskedOtsSignFrom + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter, + DirectWitnessFinalizationMaterializedCouples table + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom] + exact directWitnessFinalizationMaterializedCouples_pure table none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + have hencoded := directWitnessFinalizationMaterializedCouples_simulateQ ordinaryHashImpl + (directWitnessFinalizationMaterializedCouples_ordinaryHashImpl table) + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) + apply hencoded.bind + intro encoded + cases encoded with + | none => + exact directWitnessFinalizationMaterializedCouples_maskedOtsSignFrom table parameter + lay tree leafIdx message attempts (counter + 1) + | some encoding => + apply (directWitnessFinalizationMaterializedCouples_sequenceFin + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx (encoding chainIdx)) + (fun chainIdx => + directWitnessFinalizationMaterializedCouples_ensureChainPrefix table lay tree + leafIdx chainIdx (encoding chainIdx))).bind + intro _ + exact directWitnessFinalizationMaterializedCouples_pure table + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem directWitnessFinalizationMaterializedCouples_maskedOtsSign + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + DirectWitnessFinalizationMaterializedCouples table + (maskedOtsSign parameter lay tree leafIdx message) := + directWitnessFinalizationMaterializedCouples_maskedOtsSignFrom table parameter lay tree + leafIdx message encodingAttemptLimit 0 + +theorem directWitnessFinalizationMaterializedCouples_maskedLayerMessage + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + DirectWitnessFinalizationMaterializedCouples table + (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + by_cases hbelow : lay.val + 1 < numLayers + · rw [dif_pos hbelow] + exact directWitnessFinalizationMaterializedCouples_maskedTreeRoot table + ⟨lay.val + 1, hbelow⟩ (treeIndexAt index ⟨lay.val + 1, hbelow⟩) + · rw [dif_neg hbelow] + exact directWitnessFinalizationMaterializedCouples_simulateQ ordinaryHashImpl + (directWitnessFinalizationMaterializedCouples_ordinaryHashImpl table) + (ftsKey parameter index (ftsSecret index)) + +theorem directWitnessFinalizationMaterializedCouples_maskedSignLayer + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + DirectWitnessFinalizationMaterializedCouples table + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + apply (directWitnessFinalizationMaterializedCouples_maskedLayerMessage table parameter + ftsSecret index lay).bind + intro message + apply (directWitnessFinalizationMaterializedCouples_maskedOtsSign table parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) message).bind + intro selected + cases selected with + | none => exact directWitnessFinalizationMaterializedCouples_pure table none + | some selected => + apply (directWitnessFinalizationMaterializedCouples_ensureTreePath table lay + (treeIndexAt index lay) (leafIndexAt index lay)).bind + intro _ + exact directWitnessFinalizationMaterializedCouples_pure table (some selected) + +set_option maxRecDepth 100000 in +theorem directWitnessFinalizationMaterializedCouples_revealLayerValues + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + DirectWitnessFinalizationMaterializedCouples table + (revealLayerValues index lay encoding) := by + unfold revealLayerValues + apply (directWitnessFinalizationMaterializedCouples_sequenceFin + (fun chainIdx : ChainIndex => + revealPublishedCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx))) + (fun chainIdx => directWitnessFinalizationMaterializedCouples_revealPublishedCoordinate table + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx)))).bind + intro values + apply (directWitnessFinalizationMaterializedCouples_sequenceFin + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + match level.val with + | 0 => revealPublishedCoordinate (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | current + 1 => + if hcurrent : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hcurrent⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0 + else pure 0) + (fun level => by + by_cases hinLayer : level.val < layerHeight lay + · rw [if_pos hinLayer] + cases hvalue : level.val with + | zero => + exact directWitnessFinalizationMaterializedCouples_revealPublishedCoordinate table + (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | succ current => + have hcurrent : current < maxLayerHeight := by + have := level.isLt + omega + simp only + rw [dif_pos hcurrent] + exact directWitnessFinalizationMaterializedCouples_revealPublishedCoordinate table + (.position (.node lay (treeIndexAt index lay) ⟨current, hcurrent⟩ + (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + · rw [if_neg hinLayer] + exact directWitnessFinalizationMaterializedCouples_pure table 0)).bind + intro path + exact directWitnessFinalizationMaterializedCouples_pure table (values, path) + +set_option maxRecDepth 100000 in +theorem directWitnessFinalizationMaterializedCouples_maskedSignAfterDigest + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + DirectWitnessFinalizationMaterializedCouples table + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest + apply (directWitnessFinalizationMaterializedCouples_simulateQ ordinaryHashImpl + (directWitnessFinalizationMaterializedCouples_ordinaryHashImpl table) + (ftsOpen parameter index leaves (ftsSecret index))).bind + intro ftsPath + apply (directWitnessFinalizationMaterializedCouples_sequenceFin + (fun lay : Layer => maskedSignLayer parameter ftsSecret index lay) + (fun lay => directWitnessFinalizationMaterializedCouples_maskedSignLayer table parameter + ftsSecret index lay)).bind + intro layers + cases hparts : traverseOption layers with + | none => exact directWitnessFinalizationMaterializedCouples_pure table none + | some parts => + apply (directWitnessFinalizationMaterializedCouples_sequenceFin + (fun lay : Layer => revealLayerValues index lay (parts lay).2) + (fun lay => directWitnessFinalizationMaterializedCouples_revealLayerValues table index lay + (parts lay).2)).bind + intro revealed + let signature : Signature := + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (revealed lay).1 + authPath := flattenPaths fun lay => (revealed lay).2 } + exact directWitnessFinalizationMaterializedCouples_pure table (some signature) + +set_option maxRecDepth 100000 in +theorem directWitnessFinalizationMaterializedCouples_maskedSign + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + DirectWitnessFinalizationMaterializedCouples table + (maskedSign parameter root ftsSecret message) := by + unfold maskedSign + apply (directWitnessFinalizationMaterializedCouples_simulateQ ordinaryRomImpl + (directWitnessFinalizationMaterializedCouples_ordinaryRomImpl table) + (signDigestLoop digestAttemptLimit + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ message)).bind + intro selected + cases selected with + | none => exact directWitnessFinalizationMaterializedCouples_pure table none + | some data => + exact directWitnessFinalizationMaterializedCouples_maskedSignAfterDigest table parameter + ftsSecret data.1 data.2.1 data.2.2 + +set_option maxRecDepth 100000 in +theorem evalDist_runDirectDetailed_finish_eq_runObservedClean_finish + (computation : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (continuation : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List CleanProbeObservation → ProbComp Bool) + (hprobeFree : computation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) : + evalDist + (runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table computation >>= + fun result => match result with + | .stopped _ => pure false + | .done result => continuation result.context.state result.remaining + result.value.1 result.value.2 observations) = + evalDist + (runObservedCleanFromTable observations state fuel table computation >>= fun result => + match result with + | none => pure false + | some result => continuation result.state result.remaining result.value.1 + result.value.2 result.observations) := by + let finishClean : Option (CleanRunResult (α × SplitHashCache)) → ProbComp Bool + | none => pure false + | some result => continuation result.state result.remaining result.value.1 + result.value.2 observations + let finishObserved : Option (ObservedCleanRunResult (α × SplitHashCache)) → ProbComp Bool + | none => pure false + | some result => continuation result.state result.remaining result.value.1 + result.value.2 result.observations + have hdirect := map_projectDirectDetailedClean_run_eq_clean computation state fuel table + have hobserved := map_attachCleanProbeObservations_runCleanFromTable_of_probeFree computation + observations state fuel table hprobeFree + calc + _ = evalDist + ((projectDirectDetailedClean <$> + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + computation) >>= finishClean) := by + rw [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro result _hresult + cases result <;> rfl + _ = evalDist (runCleanFromTable state fuel table computation >>= finishClean) := by + rw [hdirect] + _ = evalDist + ((attachCleanProbeObservations observations <$> + runCleanFromTable state fuel table computation) >>= finishObserved) := by + rw [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro result _hresult + cases result <;> rfl + _ = _ := by rw [hobserved] + +theorem runDirectDetailed_finish_eq_runObservedClean_finish + (computation : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (continuation : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List CleanProbeObservation → ProbComp Bool) + (hprobeFree : computation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) : + (runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table computation >>= + fun result => match result with + | .stopped _ => pure false + | .done result => continuation result.context.state result.remaining + result.value.1 result.value.2 observations) = + (runObservedCleanFromTable observations state fuel table computation >>= fun result => + match result with + | none => pure false + | some result => continuation result.state result.remaining result.value.1 + result.value.2 result.observations) := by + let finishClean : Option (CleanRunResult (α × SplitHashCache)) → ProbComp Bool + | none => pure false + | some result => continuation result.state result.remaining result.value.1 + result.value.2 observations + let finishObserved : Option (ObservedCleanRunResult (α × SplitHashCache)) → ProbComp Bool + | none => pure false + | some result => continuation result.state result.remaining result.value.1 + result.value.2 result.observations + have hdirect := map_projectDirectDetailedClean_run_eq_clean computation state fuel table + have hobserved := map_attachCleanProbeObservations_runCleanFromTable_of_probeFree computation + observations state fuel table hprobeFree + calc + _ = (projectDirectDetailedClean <$> + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + computation) >>= finishClean := by + rw [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro result + cases result <;> rfl + _ = runCleanFromTable state fuel table computation >>= finishClean := by rw [hdirect] + _ = (attachCleanProbeObservations observations <$> + runCleanFromTable state fuel table computation) >>= finishObserved := by + rw [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro result + cases result <;> rfl + _ = _ := by rw [hobserved] + +theorem relTriple_finishDirectWitness_directDetailed + (table : OtsSecretIndex → HashOutput) (initialValues : DeferredStructuralValues) + (leftInitialFuel rightInitialFuel : Nat) + (leftRun : ProbComp (DirectWitnessResult (α × SplitHashCache))) + (rightRun : ProbComp (DirectDetailedResult (α × SplitHashCache))) + (leftObserve : DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → List CleanProbeObservation → ProbComp Bool) + (rightObserve : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (hstep : RelTriple leftRun rightRun + (DirectWitnessFinalizationMaterializedRunEq table initialValues leftInitialFuel + rightInitialFuel)) + (hnext : ∀ left right, + DirectWitnessResult.done left ∈ support leftRun → + DirectDetailedResult.done right ∈ support rightRun → + DirectWitnessFinalizationMaterializedRunEq table initialValues leftInitialFuel + rightInitialFuel (.done left) (.done right) → + RelTriple + (leftObserve left.context left.remaining left.value snapshots observations) + (rightObserve right.context.state right.remaining right.value.1 right.value.2 + observations) + BoolImp) : + RelTriple + (leftRun >>= finishDirectDelayedSelectedRootIndicator leftObserve snapshots observations) + (rightRun >>= fun result => match result with + | .stopped _ => pure false + | .done result => rightObserve result.context.state result.remaining result.value.1 + result.value.2 observations) + BoolImp := by + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hstep + (fun result => result ∈ support leftRun) (fun _ hresult => hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupported + apply relTriple_bind hbothSupported + intro left right hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases left with + | stoppedFuel => + simp only [finishDirectDelayedSelectedRootIndicator] + exact relTriple_false_any _ + | stoppedOrdinary => + simp only [finishDirectDelayedSelectedRootIndicator] + exact relTriple_false_any _ + | stoppedPrivate witness => + simp only [finishDirectDelayedSelectedRootIndicator] + exact relTriple_false_any _ + | done left => + cases right with + | stopped reason => simp [DirectWitnessFinalizationMaterializedRunEq] at hrelation + | done right => exact hnext left right hleftSupport hrightSupport hrelation +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveObservation.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveObservation.lean new file mode 100644 index 00000000..566c573d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveObservation.lean @@ -0,0 +1,180 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptivePrefix + +/-! +# Adaptive selected-query observations + +The selected hash query appends exactly the observation at the chosen ordinal. Supported suffix +results retain that observation and the complete strict prefix. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +set_option maxRecDepth 100000 in +theorem selected_observation_eq_of_mem_observedMaterializedBoundary_hash_query + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (candidate : Probe) + (hordinal : observations.length = ordinal) + (hcandidate : rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state) = some candidate) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hresult : some result ∈ support + (observedMaterializedBoundary parameter publicRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations state fuel table cache)) + (selected : Fin result.observations.length) (hselected : selected.val = ordinal) : + result.observations.get selected = + cleanProbeObservation state candidate.coordinate candidate.candidate := by + rw [observedMaterializedBoundary_hash_query_bind, mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + let observation := cleanProbeObservation state candidate.coordinate candidate.candidate + have hstepObservations : step.observations = observations ++ [observation] := by + have hobservations := + observations_eq_of_mem_runObservedCleanFromTable_rootAwarePublic parameter input + (materializedCanonicalContext table state).state + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state) + observations state fuel table cache step hstep + simpa [observationsAfterCandidate, hcandidate, observation] using hobservations + have htail : some result ∈ support + (observedMaterializedBoundary parameter publicRoot ftsSecret (next step.value.1) + step.observations step.state step.remaining table step.value.2) := by + simpa only [observedMaterializedBoundary] using hrest + have hprefix := observations_prefix_of_mem_observedMaterializedBoundary parameter publicRoot + ftsSecret (next step.value.1) step.observations step.state step.remaining table step.value.2 + result htail + have hstepIndex : observations.length < step.observations.length := by + simp [hstepObservations] + have hresultIndex : observations.length < result.observations.length := + lt_of_lt_of_le hstepIndex hprefix.length_le + have hselectedEq : selected = ⟨observations.length, hresultIndex⟩ := by + exact Fin.ext (hselected.trans hordinal.symm) + rw [hselectedEq] + have hget := hprefix.getElem hstepIndex + have hstepGet : step.observations[observations.length] = observation := by + simp [hstepObservations, observation] + have hget' := hget.symm + change result.observations[observations.length] = + step.observations[observations.length] at hget' + exact hget'.trans hstepGet + +set_option maxRecDepth 100000 in +theorem earlier_observation_avoids_of_mem_observedMaterializedBoundary + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (digest : Digest) + (hordinal : observations.length = ordinal) + (havoid : CandidatesAvoidRoot target digest + (observations.map CleanProbeObservation.toProbe)) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hresult : some result ∈ support + (observedMaterializedBoundary parameter publicRoot ftsSecret computation observations state + fuel table cache)) + (earlier : Fin result.observations.length) (hearlier : earlier.val < ordinal) : + (result.observations.get earlier).toProbe ≠ ⟨.position target, digest⟩ := by + have hprefix := observations_prefix_of_mem_observedMaterializedBoundary parameter publicRoot + ftsSecret computation observations state fuel table cache result hresult + have hinitial : earlier.val < observations.length := by omega + have hget := hprefix.getElem hinitial + have hmember : (observations.get ⟨earlier.val, hinitial⟩).toProbe ∈ + observations.map CleanProbeObservation.toProbe := by + exact List.mem_map.mpr ⟨observations.get ⟨earlier.val, hinitial⟩, + List.get_mem observations _, rfl⟩ + intro heq + apply havoid _ hmember + have hget' : result.observations.get earlier = + observations.get ⟨earlier.val, hinitial⟩ := by + have hget' := hget.symm + change result.observations[earlier.val] = observations[earlier.val] at hget' + exact hget' + rw [hget'] at heq + exact heq + +open OracleComp.ProgramLogic.Relational + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_delayedSelectedRootIndicator_hash_query + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (output : HashOutput) + (rightRoot : Digest) (hroot : IsLayerRoot target) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) RetainedRestResult) + (observations : List CleanProbeObservation) + (selection : PrivateOrdinalSelection) + (hgood : selection.GoodForRoots target output rightRoot ordinal) + (hcovered : PendingCoveredBy (selection.candidates.take ordinal) selection.context) + (hordinal : observations.length = ordinal) + (havoid : CandidatesAvoidRoot target (truncateHash output) + (observations.map CleanProbeObservation.toProbe)) + (fuel : Nat) (cache : SplitHashCache) + (hqueryCandidate : ∀ (resolved : DeferredResolution), + some resolved ∈ support + (resolveDeferredPositionValue target selection.context) → + rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table + (materializedDeferredState resolved.toDeferredContext)).state) = + some ⟨.position target, truncateHash output⟩) : + RelTriple + (delayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations selection fuel cache) + (fixedComparisonRootIndicator table ordinal target publicRoot rightRoot <$> + observedMaterializedBoundary parameter publicRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + (observations.map (installPositionValueAtProbe target output)) + (materializedDeferredState + { selection.context with + values := selection.context.values.install target output }) + fuel table cache) + SuccessfulObservedIndicatorRel := by + apply relTriple_delayedSelectedRootIndicator_supported ordinal parameter publicRoot ftsSecret + table target output rightRoot hroot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations selection hgood hcovered fuel cache + · intro resolved hresolved result hresult _hresultGood selected hselected + have hprivate : Coordinate.position target ∉ + (materializedDeferredState resolved.toDeferredContext).revealed := by + rw [materializedDeferredState_revealed, + resolveDeferredPositionValue_state_eq_clearPending target selection.context resolved + hresolved] + simpa [LazyRevealProbe.State.clearPending] using hgood.2.2.1 + have hobservation := + selected_observation_eq_of_mem_observedMaterializedBoundary_hash_query ordinal parameter + publicRoot ftsSecret input next observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache + ⟨.position target, truncateHash output⟩ hordinal (hqueryCandidate resolved hresolved) + result hresult selected hselected + rw [hobservation] + refine ⟨rfl, ?_, rfl⟩ + simp only [cleanProbeObservation, decide_eq_false_iff_not] + simpa only [materializedDeferredState_revealed] using hprivate + · intro resolved hresolved result hresult _hresultGood earlier hearlier + exact earlier_observation_avoids_of_mem_observedMaterializedBoundary ordinal parameter + publicRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations (materializedDeferredState resolved.toDeferredContext) fuel table cache target + (truncateHash output) hordinal havoid result hresult earlier hearlier + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptivePrefix.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptivePrefix.lean new file mode 100644 index 00000000..134866e0 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptivePrefix.lean @@ -0,0 +1,569 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveBridge + +/-! +# Adaptive selected-root prefix + +This file keeps the deferred prefix and its chronological observations together. When the chosen +ordinal is appended, it resolves that root and hands the complete current query and suffix to the +compiled selected-root bridge. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable + +noncomputable def delayedSelectedRootIndicator + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (selection : PrivateOrdinalSelection) (fuel : Nat) (cache : SplitHashCache) : + ProbComp Bool := do + let resolved ← resolveDeferredPositionValue target selection.context + match resolved with + | none => pure false + | some resolved => + if CandidatesAvoidRoots target (truncateHash resolved.output) rightRoot + (selection.candidates.take ordinal) then + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) <$> + observedMaterializedBoundary parameter root ftsSecret computation observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache + else pure false + +theorem successfulDoomedFirstRootGoodForComparisonAt_retainObservedRoot + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (target : Position) + (root rightRoot : Digest) + (observed : Option + (ObservedCleanRunResult (RetainedRestResult × SplitHashCache))) + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot observed) : + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (retainObservedRoot root observed) := by + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hgood + | some result => + simp only [retainObservedRoot] + rcases hgood with ⟨⟨⟨hfinish, hfirst⟩, hposition⟩, havoid⟩ + refine ⟨⟨⟨?_, ?_⟩, ?_⟩, ?_⟩ + · obtain ⟨finalResult, hfinalResult⟩ := hfinish + unfold finishObservedCleanRunFromTable at hfinalResult + rw [mem_support_bind_iff] at hfinalResult + obtain ⟨finalized, hfinalized, hreturn⟩ := hfinalResult + cases finalized with + | none => simp at hreturn + | some finalized => + obtain ⟨finalState, finalTable⟩ := finalized + refine ⟨⟨finalState, result.remaining, + ((root, result.value.1), result.value.2), finalTable, + result.observations⟩, ?_⟩ + unfold finishObservedCleanRunFromTable + rw [mem_support_bind_iff] + exact ⟨some (finalState, finalTable), hfinalized, by simp⟩ + · simpa [ObservedCleanRunOption.FirstExistingHiddenRootHitAt, + FirstExistingHiddenHitAt, ExistingHiddenHitAtOrdinal] using hfirst + · simpa [observedFirstLayerRootPosition?] using hposition + · simpa [observedPrefixProbes] using havoid + +theorem successfulDoomedFirstRootGoodForComparisonAt_of_retainObservedRoot + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (target : Position) + (root rightRoot : Digest) + (observed : Option + (ObservedCleanRunResult (RetainedRestResult × SplitHashCache))) + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (retainObservedRoot root observed)) : + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot observed := by + cases observed with + | none => + simp [retainObservedRoot, + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hgood + | some result => + simp only [retainObservedRoot] at hgood + rcases hgood with ⟨⟨⟨hfinish, hfirst⟩, hposition⟩, havoid⟩ + refine ⟨⟨⟨?_, ?_⟩, ?_⟩, ?_⟩ + · obtain ⟨finalResult, hfinalResult⟩ := hfinish + unfold finishObservedCleanRunFromTable at hfinalResult + rw [mem_support_bind_iff] at hfinalResult + obtain ⟨finalized, hfinalized, hreturn⟩ := hfinalResult + cases finalized with + | none => simp at hreturn + | some finalized => + obtain ⟨finalState, finalTable⟩ := finalized + refine ⟨⟨finalState, result.remaining, result.value, finalTable, + result.observations⟩, ?_⟩ + unfold finishObservedCleanRunFromTable + rw [mem_support_bind_iff] + exact ⟨some (finalState, finalTable), hfinalized, by simp⟩ + · simpa [ObservedCleanRunOption.FirstExistingHiddenRootHitAt, + FirstExistingHiddenHitAt, ExistingHiddenHitAtOrdinal] using hfirst + · simpa [observedFirstLayerRootPosition?] using hposition + · simpa [observedPrefixProbes] using havoid + +theorem successfulDoomedFirstRootGoodForComparisonAt_retainObservedRoot_iff + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (target : Position) + (root rightRoot : Digest) + (observed : Option + (ObservedCleanRunResult (RetainedRestResult × SplitHashCache))) : + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (retainObservedRoot root observed) ↔ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot observed := by + constructor + · exact successfulDoomedFirstRootGoodForComparisonAt_of_retainObservedRoot + table ordinal target root rightRoot observed + · exact successfulDoomedFirstRootGoodForComparisonAt_retainObservedRoot + table ordinal target root rightRoot observed + +set_option maxRecDepth 100000 in +theorem relTriple_delayedSelectedRootIndicator + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (output : HashOutput) + (rightRoot : Digest) (hroot : IsLayerRoot target) + (computation : OracleComp (OracleWorld + SigningSpec) RetainedRestResult) + (observations : List CleanProbeObservation) + (selection : PrivateOrdinalSelection) + (hgood : selection.GoodForRoots target output rightRoot ordinal) + (hcovered : PendingCoveredBy (selection.candidates.take ordinal) selection.context) + (fuel : Nat) (cache : SplitHashCache) + (hselectedHit : ∀ result : ObservedCleanRunResult (RetainedRestResult × SplitHashCache), + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result) → + ∀ selected : Fin result.observations.length, selected.val = ordinal → + (result.observations.get selected).coordinate = .position target ∧ + (result.observations.get selected).revealedAtProbe = false ∧ + truncateHash output = (result.observations.get selected).candidate) + (hactualAvoid : ∀ result : ObservedCleanRunResult (RetainedRestResult × SplitHashCache), + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result) → + ∀ earlier : Fin result.observations.length, earlier.val < ordinal → + (result.observations.get earlier).toProbe ≠ + ⟨.position target, truncateHash output⟩) : + RelTriple + (delayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + computation observations selection fuel cache) + (fixedComparisonRootIndicator table ordinal target root rightRoot <$> + observedMaterializedBoundary parameter root ftsSecret computation + (observations.map (installPositionValueAtProbe target output)) + (materializedDeferredState + { selection.context with + values := selection.context.values.install target output }) + fuel table cache) + SuccessfulObservedIndicatorRel := by + rw [delayedSelectedRootIndicator, + resolveDeferredPositionValue_eq_good_output hgood hcovered] + simp only [pure_bind, hgood.2.2.2.2, ↓reduceIte] + let eager := observedMaterializedBoundary parameter root ftsSecret computation + (observations.map (installPositionValueAtProbe target output)) + (materializedDeferredState + { selection.context with + values := selection.context.values.install target output }) + fuel table cache + have hselected := + relTriple_indicator_resolveSelectedRoot_then_observedMaterializedBoundary parameter root + ftsSecret target output rightRoot ordinal hroot selection hgood hcovered computation + observations fuel table cache hselectedHit hactualAvoid + rw [resolveDeferredPositionValue_eq_good_output hgood hcovered] at hselected + simp only [pure_bind] at hselected + have hretain : RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) <$> eager) + (fixedComparisonRootIndicator table ordinal target root rightRoot <$> eager) + SuccessfulObservedIndicatorRel := by + have hbase : RelTriple eager eager (fun left right => + SuccessfulObservedIndicatorRel + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) left) + (fixedComparisonRootIndicator table ordinal target root rightRoot right)) := by + apply relTriple_post_mono (relTriple_refl eager) + intro left right hright hlazy + subst right + change successfulObservedRootComparisonIndicator table ordinal target + (left, rightRoot) = true at hlazy + change successfulObservedRootComparisonIndicator table ordinal target + (retainObservedRoot root left, rightRoot) = true + rw [successfulObservedRootComparisonIndicator_eq_true_iff] at hlazy ⊢ + exact successfulDoomedFirstRootGoodForComparisonAt_retainObservedRoot table ordinal target + root rightRoot left hlazy + exact relTriple_map + (f := successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) + (g := fixedComparisonRootIndicator table ordinal target root rightRoot) + hbase + have hglued := SphincsSecurity.relTriple_trans_exists hselected hretain + apply relTriple_post_mono hglued + intro lazy retained hrelation + obtain ⟨eagerResult, hlazy, hretained⟩ := hrelation + exact fun htrue => hretained (hlazy htrue) + +set_option maxRecDepth 100000 in +theorem relTriple_delayedSelectedRootIndicator_supported + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (output : HashOutput) + (rightRoot : Digest) (hroot : IsLayerRoot target) + (computation : OracleComp (OracleWorld + SigningSpec) RetainedRestResult) + (observations : List CleanProbeObservation) + (selection : PrivateOrdinalSelection) + (hgood : selection.GoodForRoots target output rightRoot ordinal) + (hcovered : PendingCoveredBy (selection.candidates.take ordinal) selection.context) + (fuel : Nat) (cache : SplitHashCache) + (hselectedHit : ∀ (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target selection.context)) + (result : ObservedCleanRunResult (RetainedRestResult × SplitHashCache)), + some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache) → + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result) → + ∀ selected : Fin result.observations.length, selected.val = ordinal → + (result.observations.get selected).coordinate = .position target ∧ + (result.observations.get selected).revealedAtProbe = false ∧ + truncateHash output = (result.observations.get selected).candidate) + (hactualAvoid : ∀ (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target selection.context)) + (result : ObservedCleanRunResult (RetainedRestResult × SplitHashCache)), + some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache) → + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result) → + ∀ earlier : Fin result.observations.length, earlier.val < ordinal → + (result.observations.get earlier).toProbe ≠ + ⟨.position target, truncateHash output⟩) : + RelTriple + (delayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + computation observations selection fuel cache) + (fixedComparisonRootIndicator table ordinal target root rightRoot <$> + observedMaterializedBoundary parameter root ftsSecret computation + (observations.map (installPositionValueAtProbe target output)) + (materializedDeferredState + { selection.context with + values := selection.context.values.install target output }) + fuel table cache) + SuccessfulObservedIndicatorRel := by + rw [delayedSelectedRootIndicator, + resolveDeferredPositionValue_eq_good_output hgood hcovered] + simp only [pure_bind, hgood.2.2.2.2, ↓reduceIte] + let eager := observedMaterializedBoundary parameter root ftsSecret computation + (observations.map (installPositionValueAtProbe target output)) + (materializedDeferredState + { selection.context with + values := selection.context.values.install target output }) + fuel table cache + have hselected := + relTriple_indicator_resolveSelectedRoot_then_observedMaterializedBoundary_supported + parameter root ftsSecret target output rightRoot ordinal hroot selection hgood hcovered + computation observations fuel table cache hselectedHit hactualAvoid + rw [resolveDeferredPositionValue_eq_good_output hgood hcovered] at hselected + simp only [pure_bind] at hselected + have hretain : RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) <$> eager) + (fixedComparisonRootIndicator table ordinal target root rightRoot <$> eager) + SuccessfulObservedIndicatorRel := by + have hbase : RelTriple eager eager (fun left right => + SuccessfulObservedIndicatorRel + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) left) + (fixedComparisonRootIndicator table ordinal target root rightRoot right)) := by + apply relTriple_post_mono (relTriple_refl eager) + intro left right hright hlazy + subst right + change successfulObservedRootComparisonIndicator table ordinal target + (left, rightRoot) = true at hlazy + change successfulObservedRootComparisonIndicator table ordinal target + (retainObservedRoot root left, rightRoot) = true + rw [successfulObservedRootComparisonIndicator_eq_true_iff] at hlazy ⊢ + exact successfulDoomedFirstRootGoodForComparisonAt_retainObservedRoot table ordinal target + root rightRoot left hlazy + exact relTriple_map + (f := successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) + (g := fixedComparisonRootIndicator table ordinal target root rightRoot) + hbase + have hglued := SphincsSecurity.relTriple_trans_exists hselected hretain + apply relTriple_post_mono hglued + intro lazy retained hrelation + obtain ⟨eagerResult, hlazy, hretained⟩ := hrelation + exact fun htrue => hretained (hlazy htrue) + +noncomputable def finishDirectDelayedSelectedRootIndicator + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) : DirectWitnessResult α → ProbComp Bool + | .stoppedFuel => pure false + | .stoppedOrdinary => pure false + | .stoppedPrivate _ => pure false + | .done result => + observe result.context result.remaining result.value snapshots observations + +noncomputable def canonicalizeDirectDelayedSelectedRootIndicator + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) : ProbComp Bool := by + classical + let canonical := canonicalizeMaterializedValues table context + exact if PrivateStructuralHit canonical then pure false + else if PublishedValues context.state then + if DeferredCompletable table canonical then + observe canonical fuel value snapshots observations + else pure false + else pure false + +noncomputable def directDelayedSelectedRootIndicator + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : ProbComp Bool := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + List PlannedProbeSnapshot → List CleanProbeObservation → DeferredContext → Nat → + SplitHashCache → ProbComp Bool) + (fun _value snapshots observations context fuel cache => + if hselected : ordinal < snapshots.length then + delayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (pure _value) observations + ⟨(snapshots.get ⟨ordinal, hselected⟩).probe, + (snapshots.get ⟨ordinal, hselected⟩).context, + snapshots.map PlannedProbeSnapshot.toProbe⟩ fuel cache + else pure false) + (fun query _next recursivelyRun snapshots observations context fuel cache => + if hselected : ordinal < snapshots.length then + delayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (liftM (OracleSpec.query query) >>= _next) observations + ⟨(snapshots.get ⟨ordinal, hselected⟩).probe, + (snapshots.get ⟨ordinal, hselected⟩).context, + snapshots.map PlannedProbeSnapshot.toProbe⟩ fuel cache + else + match query with + | .inl (.inl n) => + runDirectResolvedWitnessFromTable context fuel table ((splitUniformImpl n).run cache) >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations => + recursivelyRun value.1 laterSnapshots laterObservations nextContext remaining + value.2)) snapshots observations + | .inl (.inr input) => + let plan := purePlanProbingHashQuery parameter input context.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextSnapshots := appendPlannedSnapshot snapshots candidate? context + let nextObservations := observationsAfterCandidate observations + (materializedDeferredState context) candidate? + if hnextSelected : ordinal < nextSnapshots.length then + delayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + ((liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) : + OracleComp (OracleWorld + SigningSpec) HashOutput) >>= _next) observations + ⟨(nextSnapshots.get ⟨ordinal, hnextSelected⟩).probe, + (nextSnapshots.get ⟨ordinal, hnextSelected⟩).context, + nextSnapshots.map PlannedProbeSnapshot.toProbe⟩ fuel cache + else + runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterRootAwarePlan parameter input plan).run cache) >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations => + recursivelyRun value.1 laterSnapshots laterObservations nextContext remaining + value.2)) nextSnapshots nextObservations + | .inr message => + runDirectResolvedWitnessFromTable context fuel table + ((maskedSign parameter root ftsSecret message).run cache) >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations => + recursivelyRun value.1 laterSnapshots laterObservations nextContext remaining + value.2)) snapshots observations) + computation snapshots observations context fuel cache + +theorem directDelayedSelectedRootIndicator_eq_selected + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hselected : ordinal < snapshots.length) : + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + computation snapshots observations context fuel cache = + delayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + computation observations + ⟨(snapshots.get ⟨ordinal, hselected⟩).probe, + (snapshots.get ⟨ordinal, hselected⟩).context, + snapshots.map PlannedProbeSnapshot.toProbe⟩ fuel cache := by + induction computation using OracleComp.inductionOn generalizing + snapshots observations context fuel cache with + | pure value => + rw [directDelayedSelectedRootIndicator, OracleComp.construct_pure] + simp only [hselected, ↓reduceDIte] + | query_bind query next ih => + rw [directDelayedSelectedRootIndicator, OracleComp.construct_query_bind] + simp only [hselected, ↓reduceDIte] + +theorem directDelayedSelectedRootIndicator_hash_eq_selected + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hbefore : ¬ordinal < snapshots.length) + (hselected : ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length) : + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache = + delayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations + ⟨((appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).get + ⟨ordinal, hselected⟩).probe, + ((appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).get + ⟨ordinal, hselected⟩).context, + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).map + PlannedProbeSnapshot.toProbe⟩ fuel cache := by + rw [directDelayedSelectedRootIndicator, OracleComp.construct_query_bind] + simp only [hbefore, ↓reduceDIte] + exact dif_pos hselected + +theorem directDelayedSelectedRootIndicator_hash_eq_not_selected + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hbefore : ¬ordinal < snapshots.length) + (hselected : ¬ordinal < + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length) : + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache = + runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterRootAwarePlan parameter input + (purePlanProbingHashQuery parameter input context.state)).run cache) >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations => + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2)) + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context) + (observationsAfterCandidate observations + (materializedDeferredState context) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state))) := by + rw [directDelayedSelectedRootIndicator, OracleComp.construct_query_bind] + simp only [hbefore, ↓reduceDIte] + exact dif_neg hselected + +theorem directDelayedSelectedRootIndicator_uniform_eq + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (n : Nat) (next : Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hselected : ¬ordinal < snapshots.length) : + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inl n))) >>= next) + snapshots observations context fuel cache = + runDirectResolvedWitnessFromTable context fuel table ((splitUniformImpl n).run cache) >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2)) + snapshots observations := by + conv_lhs => + rw [directDelayedSelectedRootIndicator, OracleComp.construct_query_bind] + simp only [hselected, ↓reduceDIte] + change (runDirectResolvedWitnessFromTable context fuel table + ((splitUniformImpl n).run cache) >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2)) snapshots observations) = _ + rfl + +theorem directDelayedSelectedRootIndicator_signing_eq + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (message : Message) + (next : Option Signature → OracleComp (OracleWorld + SigningSpec) α) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hselected : ¬ordinal < snapshots.length) : + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) (Sum.inr message)) >>= next) + snapshots observations context fuel cache = + runDirectResolvedWitnessFromTable context fuel table + ((maskedSign parameter root ftsSecret message).run cache) >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2)) + snapshots observations := by + conv_lhs => + rw [directDelayedSelectedRootIndicator, OracleComp.construct_query_bind] + simp only [hselected, ↓reduceDIte] + change (runDirectResolvedWitnessFromTable context fuel table + ((maskedSign parameter root ftsSecret message).run cache) >>= + finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot (next value.1) laterSnapshots laterObservations nextContext remaining + value.2)) snapshots observations) = _ + rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProbability.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProbability.lean new file mode 100644 index 00000000..6f143fe2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProbability.lean @@ -0,0 +1,120 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveEndpoint +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootJoint + +/-! +# Absorbed fixed-root probability + +The independent comparison root can coincide with one of the earlier candidates. For a source +ordinal below the query bound this exception has coefficient at most one half, so it is absorbed +without discarding the target-specific production weight. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +theorem ordinal_mul_inv_digest_le_inv_two + (ordinal q : Nat) (hordinal : ordinal < q) (hq : q ≤ 2 ^ securityBits) : + (ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ ≤ + (2 : ENNReal)⁻¹ := by + calc + (ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ ≤ + ((2 ^ securityBits : Nat) : ENNReal) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + gcongr + exact_mod_cast (Nat.le_of_lt (hordinal.trans_le hq)) + _ ≤ (2 : ENNReal)⁻¹ := by + rw [ENNReal.mul_inv_le_iff (by norm_num) (by norm_num)] + apply (ENNReal.toReal_le_toReal (by norm_num) (by finiteness)).mp + rw [ENNReal.toReal_mul, ENNReal.toReal_inv] + norm_num [securityBits, digestBits] + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_successfulDoomedFirstRootFiber_le_two_mul_production + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (hordinal : ordinal < q) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[fun observed => + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target (2 * q) table] * + (2 * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + let run := observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table + let probability := Pr[fun observed => + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed | run] + let weight := Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target (2 * q) table] + let epsilon := ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + have hgood : + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] ≤ weight * epsilon := by + exact probEvent_observedRootComparison_le_production_mul ordinal adversary parameter table + ftsSecret q target hroot hparent hfuel hbound hq + have hsplit : probability ≤ + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest => + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] + + probability * + ((ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + exact probEvent_successfulDoomedFirstRootFiber_le_goodComparison_add_weightedException + table run ordinal target + have hhalf : + (ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ ≤ + (2 : ENNReal)⁻¹ := + ordinal_mul_inv_digest_le_inv_two ordinal q hordinal hq + have habsorb : probability ≤ 2 * (weight * epsilon) := by + apply le_two_mul_of_le_add_mul_inv_two probability (weight * epsilon) + · exact probEvent_le_one + · apply ne_top_of_le_ne_top (by norm_num : (1 : ENNReal) ≠ ∞) + calc + weight * epsilon ≤ 1 * 1 := by + apply mul_le_mul probEvent_le_one + · simp [epsilon, digestBits] + · exact bot_le + · exact bot_le + _ = 1 := one_mul 1 + · calc + probability ≤ + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest => + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] + + probability * + ((ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := hsplit + _ ≤ weight * epsilon + probability * (2 : ENNReal)⁻¹ := by + exact add_le_add hgood (mul_le_mul_right hhalf probability) + change probability ≤ weight * (2 * epsilon) + calc + probability ≤ 2 * (weight * epsilon) := habsorb + _ = weight * (2 * epsilon) := by ac_rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProduction.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProduction.lean new file mode 100644 index 00000000..7f1e73b4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProduction.lean @@ -0,0 +1,1246 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProbability + +/-! +# Common root-aware production selector + +The fixed-target root bound leaves a target-specific production weight. This module defines the +single deferred selector whose position fibers will account for all of those weights. It executes +the proof-only root-aware probe, but neither its computation nor its sampled state names a target. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + + +theorem materializedCanonicalContext_values_materialize_hidden + (table : OtsSecretIndex → HashOutput) + (state : LazyRevealProbe.State Coordinate) (target : Position) (output : HashOutput) + (hhidden : Coordinate.position target ∉ state.revealed) : + (materializedCanonicalContext table + (state.materialize (.position target) output)).state.values = + (materializedCanonicalContext table state).state.values := by + funext coordinate + unfold materializedCanonicalContext canonicalizeMaterializedValues + publicMaterializedValues directDeferredContext + simp only [LazyRevealProbe.State.materialize] + by_cases hrevealed : coordinate ∈ state.revealed + · have hne : coordinate ≠ .position target := by + intro heq + subst coordinate + exact hhidden hrevealed + rw [if_pos hrevealed, if_pos hrevealed] + unfold resolvedCompletionValue DeferredContext.positionValue + cases coordinate with + | chainStart => rfl + | position position => + have hposition : position ≠ target := by + simpa using hne + simp [directDeferredValues, Function.update_of_ne, hposition] + · rw [if_neg hrevealed, if_neg hrevealed] + +theorem purePlanProbingHashQuery_materialize_hidden + (table : OtsSecretIndex → HashOutput) + (state : LazyRevealProbe.State Coordinate) (target : Position) (output : HashOutput) + (hhidden : Coordinate.position target ∉ state.revealed) + (parameter : PublicParameter) (input : HashInput) : + purePlanProbingHashQuery parameter input + (materializedCanonicalContext table + (state.materialize (.position target) output)).state = + purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state := + purePlanProbingHashQuery_eq_of_values_eq + (materializedCanonicalContext_values_materialize_hidden table state target output hhidden) + parameter input + +noncomputable def runPermissiveFromTable + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + ProbComp (Option (CleanRunResult α)) := + OracleComp.construct + (C := fun _ : OracleComp (LazyRevealProbe.World Coordinate) α => + LazyRevealProbe.State Coordinate → Nat → (OtsSecretIndex → HashOutput) → + ProbComp (Option (CleanRunResult α))) + (fun value state remaining table => pure (some ⟨state, remaining, value, table⟩)) + (fun input _next recursivelyRun state fuel table => + match input with + | .uniform n => do + let output ← liftM (unifSpec.query n) + recursivelyRun output state fuel table + | .hashOutput => do + let output ← LazyRevealProbe.sampleHashOutput + recursivelyRun output state fuel table + | .ensure coordinate => + recursivelyRun () (state.ensure coordinate) fuel table + | .probe coordinate candidate => + match fuel with + | 0 => pure none + | remaining + 1 => + if coordinate ∈ state.revealed then + recursivelyRun () state remaining table + else + recursivelyRun () (state.addPending coordinate candidate) remaining table + | .peek coordinate => + recursivelyRun (state.values coordinate) state fuel table + | .publish coordinate => + recursivelyRun () (state.publish coordinate) fuel table + | .reveal coordinate => + match state.values coordinate with + | some output => recursivelyRun output state fuel table + | none => + match coordinate with + | .chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + recursivelyRun output (state.materialize coordinate output) fuel table + | .position _ => do + let output ← LazyRevealProbe.sampleHashOutput + recursivelyRun output (state.materialize coordinate output) fuel table) + computation state fuel table + +structure PermissiveStateRel + (left right : LazyRevealProbe.State Coordinate) : Prop where + values : left.values = right.values + revealed : left.revealed = right.revealed + +def PermissiveCleanRel : + Option (CleanRunResult α) → Option (CleanRunResult α) → Prop + | none, none => True + | some left, some right => + PermissiveStateRel left.state right.state ∧ + left.remaining = right.remaining ∧ left.value = right.value ∧ left.table = right.table + | _, _ => False + +theorem PermissiveStateRel.ensure + {left right : LazyRevealProbe.State Coordinate} + (hrel : PermissiveStateRel left right) (coordinate : Coordinate) : + PermissiveStateRel (left.ensure coordinate) (right.ensure coordinate) := by + exact ⟨hrel.values, hrel.revealed⟩ + +theorem PermissiveStateRel.addPending + {left right : LazyRevealProbe.State Coordinate} + (hrel : PermissiveStateRel left right) (coordinate : Coordinate) (candidate : Digest) : + PermissiveStateRel (left.addPending coordinate candidate) + (right.addPending coordinate candidate) := by + exact ⟨hrel.values, hrel.revealed⟩ + +theorem PermissiveStateRel.publish + {left right : LazyRevealProbe.State Coordinate} + (hrel : PermissiveStateRel left right) (coordinate : Coordinate) : + PermissiveStateRel (left.publish coordinate) (right.publish coordinate) := by + exact ⟨hrel.values, + by simp [LazyRevealProbe.State.publish, hrel.revealed]⟩ + +theorem PermissiveStateRel.materialize + {left right : LazyRevealProbe.State Coordinate} + (hrel : PermissiveStateRel left right) (coordinate : Coordinate) (output : HashOutput) : + PermissiveStateRel (left.materialize coordinate output) + (right.materialize coordinate output) := by + exact ⟨by simp [LazyRevealProbe.State.materialize, hrel.values], hrel.revealed⟩ + +theorem materializedCanonicalContext_values_eq_of_permissiveStateRel + (table : OtsSecretIndex → HashOutput) + {left right : LazyRevealProbe.State Coordinate} + (hstate : PermissiveStateRel left right) : + (materializedCanonicalContext table left).state.values = + (materializedCanonicalContext table right).state.values := by + change publicMaterializedValues table (directDeferredContext left) = + publicMaterializedValues table (directDeferredContext right) + funext coordinate + unfold publicMaterializedValues + have hrevealed : coordinate ∈ left.revealed ↔ coordinate ∈ right.revealed := by + rw [hstate.revealed] + by_cases hleftRevealed : coordinate ∈ left.revealed + · have hrightRevealed : coordinate ∈ right.revealed := hrevealed.mp hleftRevealed + simp only [directDeferredContext, hleftRevealed, hrightRevealed, ↓reduceIte] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => simp [resolvedCompletionValue] + | position position => + simp [resolvedCompletionValue, DeferredContext.positionValue, directDeferredValues, + hstate.values] + · have hrightRevealed : coordinate ∉ right.revealed := by + simpa [hrevealed] using hleftRevealed + simp [directDeferredContext, hleftRevealed, hrightRevealed] + +set_option maxRecDepth 100000 in +theorem relTriple_runPermissiveFromTable_of_stateRel + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (left right : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hstate : PermissiveStateRel left right) : + RelTriple + (runPermissiveFromTable left fuel table computation) + (runPermissiveFromTable right fuel table computation) + PermissiveCleanRel := by + induction computation using OracleComp.inductionOn generalizing left right fuel with + | pure value => + simp [runPermissiveFromTable, PermissiveCleanRel, hstate] + | query_bind query next ih => + rw [runPermissiveFromTable, OracleComp.construct_query_bind, + runPermissiveFromTable, OracleComp.construct_query_bind] + cases query with + | uniform n => + apply relTriple_bind (relTriple_refl (liftM (unifSpec.query n))) + intro leftOutput rightOutput heq + subst rightOutput + exact ih leftOutput left right fuel hstate + | hashOutput => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + exact ih leftOutput left right fuel hstate + | ensure coordinate => + exact ih () (left.ensure coordinate) (right.ensure coordinate) fuel + (hstate.ensure coordinate) + | probe coordinate candidate => + cases fuel with + | zero => simp [PermissiveCleanRel] + | succ remaining => + have hrevealed : coordinate ∈ left.revealed ↔ coordinate ∈ right.revealed := by + rw [hstate.revealed] + by_cases hleft : coordinate ∈ left.revealed + · have hright : coordinate ∈ right.revealed := hrevealed.mp hleft + simp only [hleft, hright, ↓reduceIte] + exact ih () left right remaining hstate + · have hright : coordinate ∉ right.revealed := by + simpa [hrevealed] using hleft + simp only [hleft, hright, ↓reduceIte] + exact ih () (left.addPending coordinate candidate) + (right.addPending coordinate candidate) remaining + (hstate.addPending coordinate candidate) + | peek coordinate => + have hvalue := congrFun hstate.values coordinate + simp only + rw [hvalue] + exact ih (right.values coordinate) left right fuel hstate + | publish coordinate => + exact ih () (left.publish coordinate) (right.publish coordinate) fuel + (hstate.publish coordinate) + | reveal coordinate => + have hvalue := congrFun hstate.values coordinate + cases hleft : left.values coordinate with + | some output => + have hright : right.values coordinate = some output := by + rw [← hvalue] + exact hleft + simp only [hleft, hright] + exact ih output left right fuel hstate + | none => + have hright : right.values coordinate = none := by + rw [← hvalue] + exact hleft + simp only [hleft, hright] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact ih (table ⟨lay, tree, leafIdx, chainIdx⟩) + (left.materialize (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩)) + (right.materialize (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩)) fuel + (hstate.materialize (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩)) + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + exact ih leftOutput (left.materialize (.position position) leftOutput) + (right.materialize (.position position) leftOutput) fuel + (hstate.materialize (.position position) leftOutput) + +def CleanPermissiveRel : + Option (CleanRunResult α) → Option (CleanRunResult α) → Prop + | none, _ => True + | some left, right => right = some left + +theorem relTriple_none_any_cleanPermissive + (right : ProbComp (Option (CleanRunResult α))) : + RelTriple (pure none : ProbComp (Option (CleanRunResult α))) right + CleanPermissiveRel := by + have hbase := relTriple_true + (pure none : ProbComp (Option (CleanRunResult α))) right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun value => value = none) (by + intro value hvalue + simpa using hvalue) + apply relTriple_post_mono hsupported + intro left right hrelation + rw [hrelation.2] + trivial + +set_option maxRecDepth 100000 in +theorem relTriple_runCleanFromTable_runPermissiveFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + RelTriple + (runCleanFromTable state fuel table computation) + (runPermissiveFromTable state fuel table computation) + CleanPermissiveRel := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + simp [runCleanFromTable, runPermissiveFromTable, CleanPermissiveRel] + | query_bind query next ih => + rw [runCleanFromTable, OracleComp.construct_query_bind, + runPermissiveFromTable, OracleComp.construct_query_bind] + cases query with + | uniform n => + apply relTriple_bind (relTriple_refl (liftM (unifSpec.query n))) + intro left right heq + subst right + exact ih left state fuel + | hashOutput => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro left right heq + subst right + exact ih left state fuel + | ensure coordinate => exact ih () (state.ensure coordinate) fuel + | probe coordinate candidate => + cases fuel with + | zero => simp [CleanPermissiveRel] + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () state remaining + · simp only [hrevealed, ↓reduceIte] + exact ih () (state.addPending coordinate candidate) remaining + | peek coordinate => exact ih (state.values coordinate) state fuel + | publish coordinate => exact ih () (state.publish coordinate) fuel + | reveal coordinate => + cases hvalue : state.values coordinate with + | some output => + simp only [hvalue] + exact ih output state fuel + | none => + simp only [hvalue] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : state.hitAt (.chainStart lay tree leafIdx chainIdx) output + · simp only [output, hhit, ↓reduceIte] + exact relTriple_none_any_cleanPermissive + (runPermissiveFromTable + (state.materialize (.chainStart lay tree leafIdx chainIdx) output) + fuel table (next output)) + · simp only [output, hhit, ↓reduceIte] + exact ih output + (state.materialize (.chainStart lay tree leafIdx chainIdx) output) fuel + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro left right heq + subst right + by_cases hhit : state.hitAt (.position position) left + · simp only [hhit, ↓reduceIte] + exact relTriple_none_any_cleanPermissive + (runPermissiveFromTable + (state.materialize (.position position) left) fuel table (next left)) + · simp only [hhit, ↓reduceIte] + exact ih left (state.materialize (.position position) left) fuel + +noncomputable def finishPermissivePrivateOrdinalSelection + (observe : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp (Option Probe)) + (candidates : List Probe) : Option (CleanRunResult (α × SplitHashCache)) → + ProbComp (Option Probe) + | none => pure none + | some result => + observe result.state result.remaining result.value.1 result.value.2 candidates + +noncomputable def permissiveRootAwarePlan + (parameter : PublicParameter) (input : HashInput) + (table : OtsSecretIndex → HashOutput) (state : LazyRevealProbe.State Coordinate) : + PlannedHashQuery := + purePlanProbingHashQuery parameter input (materializedCanonicalContext table state).state + +noncomputable def permissiveRootAwareCandidates + (parameter : PublicParameter) (input : HashInput) + (table : OtsSecretIndex → HashOutput) (state : LazyRevealProbe.State Coordinate) + (candidates : List Probe) : List Probe := + appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (permissiveRootAwarePlan parameter input table state)) + +noncomputable def permissiveRootAwarePublicActionWithPlan + (parameter : PublicParameter) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (cache : SplitHashCache) : + OracleComp (LazyRevealProbe.World Coordinate) (HashOutput × SplitHashCache) := + (probingHashQueryAfterRootAwarePublicPlan parameter input state plan).run cache + +noncomputable def permissiveRootAwarePublicAction + (parameter : PublicParameter) (input : HashInput) + (table : OtsSecretIndex → HashOutput) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) : + OracleComp (LazyRevealProbe.World Coordinate) (HashOutput × SplitHashCache) := + permissiveRootAwarePublicActionWithPlan parameter input + (materializedCanonicalContext table state).state + (permissiveRootAwarePlan parameter input table state) cache + +noncomputable def selectPermissiveOrdinal + (ordinal : Nat) (candidates : List Probe) (otherwise : ProbComp (Option Probe)) : + ProbComp (Option Probe) := + if hselected : ordinal < candidates.length then + pure (some (candidates.get ⟨ordinal, hselected⟩)) + else + otherwise + +noncomputable def permissiveRootAwareHashContinue + (_ordinal : Nat) (parameter : PublicParameter) (input : HashInput) + (recursivelyRun : HashOutput → List Probe → LazyRevealProbe.State Coordinate → Nat → + (OtsSecretIndex → HashOutput) → SplitHashCache → ProbComp (Option Probe)) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option Probe) := + runPermissiveFromTable state fuel table + (permissiveRootAwarePublicAction parameter input table state cache) >>= + finishPermissivePrivateOrdinalSelection + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache) + (permissiveRootAwareCandidates parameter input table state candidates) + +noncomputable def permissiveRootAwareHashStep + (ordinal : Nat) (parameter : PublicParameter) (input : HashInput) + (recursivelyRun : HashOutput → List Probe → LazyRevealProbe.State Coordinate → Nat → + (OtsSecretIndex → HashOutput) → SplitHashCache → ProbComp (Option Probe)) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option Probe) := + selectPermissiveOrdinal ordinal + (permissiveRootAwareCandidates parameter input table state candidates) + (permissiveRootAwareHashContinue ordinal parameter input recursivelyRun candidates state fuel + table cache) + +noncomputable def permissiveRootAwareOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option Probe) := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + List Probe → LazyRevealProbe.State Coordinate → Nat → + (OtsSecretIndex → HashOutput) → SplitHashCache → ProbComp (Option Probe)) + (fun _value candidates _state _fuel _table _cache => + if hselected : ordinal < candidates.length then + pure (some (candidates.get ⟨ordinal, hselected⟩)) + else pure none) + (fun query _next recursivelyRun candidates state fuel table cache => + if hselected : ordinal < candidates.length then + pure (some (candidates.get ⟨ordinal, hselected⟩)) + else + match query with + | .inl (.inl n) => + runPermissiveFromTable state fuel table ((splitUniformImpl n).run cache) >>= + finishPermissivePrivateOrdinalSelection + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache) + candidates + | .inl (.inr input) => + permissiveRootAwareHashStep ordinal parameter input recursivelyRun candidates state + fuel table cache + | .inr message => + runPermissiveFromTable state fuel table + ((maskedSign parameter root ftsSecret message).run cache) >>= + finishPermissivePrivateOrdinalSelection + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache) + candidates) + computation candidates state fuel table cache + +theorem relTriple_finishPermissivePrivateOrdinalSelection_eq + (leftObserve rightObserve : LazyRevealProbe.State Coordinate → Nat → α → + SplitHashCache → List Probe → ProbComp (Option Probe)) + (leftCandidates rightCandidates : List Probe) + (left right : Option (CleanRunResult (α × SplitHashCache))) + (hresult : PermissiveCleanRel left right) + (hrecursive : ∀ (leftResult rightResult : CleanRunResult (α × SplitHashCache)), + PermissiveCleanRel (some leftResult) (some rightResult) → + RelTriple + (leftObserve leftResult.state leftResult.remaining leftResult.value.1 + leftResult.value.2 leftCandidates) + (rightObserve rightResult.state rightResult.remaining rightResult.value.1 + rightResult.value.2 rightCandidates) + (EqRel (Option Probe))) : + RelTriple + (finishPermissivePrivateOrdinalSelection leftObserve leftCandidates left) + (finishPermissivePrivateOrdinalSelection rightObserve rightCandidates right) + (EqRel (Option Probe)) := by + cases left with + | none => + cases right with + | none => exact relTriple_pure_pure rfl + | some right => exact False.elim hresult + | some left => + cases right with + | none => exact False.elim hresult + | some right => exact hrecursive left right hresult + +theorem relTriple_selectPermissiveOrdinal + (ordinal : Nat) (leftCandidates rightCandidates : List Probe) + (leftOtherwise rightOtherwise : ProbComp (Option Probe)) + (hcandidates : leftCandidates = rightCandidates) + (hotherwise : RelTriple leftOtherwise rightOtherwise (EqRel (Option Probe))) : + RelTriple + (selectPermissiveOrdinal ordinal leftCandidates leftOtherwise) + (selectPermissiveOrdinal ordinal rightCandidates rightOtherwise) + (EqRel (Option Probe)) := by + subst rightCandidates + unfold selectPermissiveOrdinal + by_cases hselected : ordinal < leftCandidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure rfl + · simp only [hselected, ↓reduceDIte] + exact hotherwise + +theorem permissiveRootAwarePlan_eq_of_stateRel + (parameter : PublicParameter) (input : HashInput) + (table : OtsSecretIndex → HashOutput) + {left right : LazyRevealProbe.State Coordinate} + (hstate : PermissiveStateRel left right) : + permissiveRootAwarePlan parameter input table left = + permissiveRootAwarePlan parameter input table right := by + unfold permissiveRootAwarePlan + exact purePlanProbingHashQuery_eq_of_values_eq + (materializedCanonicalContext_values_eq_of_permissiveStateRel table hstate) + parameter input + +theorem permissiveRootAwareCandidates_eq_of_stateRel + (parameter : PublicParameter) (input : HashInput) + (table : OtsSecretIndex → HashOutput) (candidates : List Probe) + {left right : LazyRevealProbe.State Coordinate} + (hstate : PermissiveStateRel left right) : + permissiveRootAwareCandidates parameter input table left candidates = + permissiveRootAwareCandidates parameter input table right candidates := by + unfold permissiveRootAwareCandidates + rw [permissiveRootAwarePlan_eq_of_stateRel parameter input table hstate] + +theorem permissiveRootAwarePublicActionWithPlan_eq_of_values_eq + (parameter : PublicParameter) (input : HashInput) + {left right : LazyRevealProbe.State Coordinate} + (hvalues : left.values = right.values) (plan : PlannedHashQuery) + (cache : SplitHashCache) : + permissiveRootAwarePublicActionWithPlan parameter input left plan cache = + permissiveRootAwarePublicActionWithPlan parameter input right plan cache := by + exact congrArg (fun computation => computation.run cache) + (probingHashQueryAfterRootAwarePublicPlan_eq_of_values_eq parameter input hvalues plan) + +theorem permissiveRootAwarePublicAction_eq_of_stateRel + (parameter : PublicParameter) (input : HashInput) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + {left right : LazyRevealProbe.State Coordinate} + (hstate : PermissiveStateRel left right) : + permissiveRootAwarePublicAction parameter input table left cache = + permissiveRootAwarePublicAction parameter input table right cache := by + unfold permissiveRootAwarePublicAction + have hvalues := materializedCanonicalContext_values_eq_of_permissiveStateRel table hstate + calc + permissiveRootAwarePublicActionWithPlan parameter input + (materializedCanonicalContext table left).state + (permissiveRootAwarePlan parameter input table left) cache = + permissiveRootAwarePublicActionWithPlan parameter input + (materializedCanonicalContext table right).state + (permissiveRootAwarePlan parameter input table left) cache := + permissiveRootAwarePublicActionWithPlan_eq_of_values_eq parameter input hvalues _ cache + _ = permissiveRootAwarePublicActionWithPlan parameter input + (materializedCanonicalContext table right).state + (permissiveRootAwarePlan parameter input table right) cache := + congrArg + (fun plan => permissiveRootAwarePublicActionWithPlan parameter input + (materializedCanonicalContext table right).state plan cache) + (permissiveRootAwarePlan_eq_of_stateRel parameter input table hstate) + +theorem relTriple_permissiveRootAwareHashContinue_of_stateRel + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (table : OtsSecretIndex → HashOutput) + (hrecursive : ∀ output candidates rightCandidates left right fuel cache, + candidates = rightCandidates → PermissiveStateRel left right → + RelTriple + (permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret (next output) + candidates left fuel table cache) + (permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret (next output) + rightCandidates right fuel table cache) + (EqRel (Option Probe))) + (candidates : List Probe) + (left right : LazyRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) + (hstate : PermissiveStateRel left right) : + RelTriple + (permissiveRootAwareHashContinue ordinal parameter input + (fun output laterCandidates nextState remaining laterTable nextCache => + permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret (next output) + laterCandidates nextState remaining laterTable nextCache) + candidates left fuel table cache) + (permissiveRootAwareHashContinue ordinal parameter input + (fun output laterCandidates nextState remaining laterTable nextCache => + permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret (next output) + laterCandidates nextState remaining laterTable nextCache) + candidates right fuel table cache) + (EqRel (Option Probe)) := by + unfold permissiveRootAwareHashContinue + have hcandidates := permissiveRootAwareCandidates_eq_of_stateRel parameter input table + candidates hstate + have haction := permissiveRootAwarePublicAction_eq_of_stateRel parameter input table cache + hstate + have hrun : RelTriple + (runPermissiveFromTable left fuel table + (permissiveRootAwarePublicAction parameter input table left cache)) + (runPermissiveFromTable right fuel table + (permissiveRootAwarePublicAction parameter input table right cache)) + PermissiveCleanRel := by + rw [haction] + exact relTriple_runPermissiveFromTable_of_stateRel _ left right fuel table hstate + let observe : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates ↦ + permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_bind hrun + intro leftResult rightResult hresult + apply relTriple_finishPermissivePrivateOrdinalSelection_eq observe observe + (permissiveRootAwareCandidates parameter input table left candidates) + (permissiveRootAwareCandidates parameter input table right candidates) + leftResult rightResult hresult + intro nextLeft nextRight hnext + rcases hnext with ⟨hnextState, hremaining, hvalue, htable⟩ + simpa only [observe, hremaining, hvalue] using + hrecursive nextLeft.value.1 + (permissiveRootAwareCandidates parameter input table left candidates) + (permissiveRootAwareCandidates parameter input table right candidates) + nextLeft.state nextRight.state nextLeft.remaining nextLeft.value.2 hcandidates hnextState + +set_option maxHeartbeats 400000 in +set_option maxRecDepth 10000 in +theorem relTriple_permissiveRootAwareHashStep_of_stateRel + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (table : OtsSecretIndex → HashOutput) + (hrecursive : ∀ output candidates rightCandidates left right fuel cache, + candidates = rightCandidates → PermissiveStateRel left right → + RelTriple + (permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret (next output) + candidates left fuel table cache) + (permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret (next output) + rightCandidates right fuel table cache) + (EqRel (Option Probe))) + (candidates : List Probe) + (left right : LazyRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) + (hstate : PermissiveStateRel left right) : + RelTriple + (permissiveRootAwareHashStep ordinal parameter input + (fun output laterCandidates nextState remaining laterTable nextCache => + permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret (next output) + laterCandidates nextState remaining laterTable nextCache) + candidates left fuel table cache) + (permissiveRootAwareHashStep ordinal parameter input + (fun output laterCandidates nextState remaining laterTable nextCache => + permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret (next output) + laterCandidates nextState remaining laterTable nextCache) + candidates right fuel table cache) + (EqRel (Option Probe)) := by + unfold permissiveRootAwareHashStep + apply relTriple_selectPermissiveOrdinal ordinal + (permissiveRootAwareCandidates parameter input table left candidates) + (permissiveRootAwareCandidates parameter input table right candidates) + · exact permissiveRootAwareCandidates_eq_of_stateRel parameter input table candidates hstate + · exact relTriple_permissiveRootAwareHashContinue_of_stateRel ordinal parameter root + ftsSecret input next table hrecursive candidates left right fuel cache hstate + +theorem relTriple_permissiveRootAwareOrdinalSelection_hash + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (table : OtsSecretIndex → HashOutput) + (hrecursive : ∀ output candidates rightCandidates left right fuel cache, + candidates = rightCandidates → PermissiveStateRel left right → + RelTriple + (permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret (next output) + candidates left fuel table cache) + (permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret (next output) + rightCandidates right fuel table cache) + (EqRel (Option Probe))) + (candidates : List Probe) + (left right : LazyRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) + (hstate : PermissiveStateRel left right) : + RelTriple + (permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + candidates left fuel table cache) + (permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + candidates right fuel table cache) + (EqRel (Option Probe)) := by + rw [permissiveRootAwareOrdinalSelection, OracleComp.construct_query_bind, + permissiveRootAwareOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure rfl + · simp only [hselected, ↓reduceDIte] + exact relTriple_permissiveRootAwareHashStep_of_stateRel ordinal parameter root ftsSecret + input next table hrecursive candidates left right fuel cache hstate + +set_option maxHeartbeats 400000 in +set_option maxRecDepth 2000 in +theorem relTriple_permissiveRootAwareOrdinalSelection_of_stateRel_aux + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates rightCandidates : List Probe) + (left right : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcandidates : candidates = rightCandidates) + (hstate : PermissiveStateRel left right) : + RelTriple + (permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + candidates left fuel table cache) + (permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + rightCandidates right fuel table cache) + (EqRel (Option Probe)) := by + induction computation using OracleComp.inductionOn generalizing + candidates rightCandidates left right fuel cache with + | pure value => + subst rightCandidates + simp only [permissiveRootAwareOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length <;> + simp only [hselected, ↓reduceDIte] <;> exact relTriple_pure_pure rfl + | query_bind query next ih => + subst rightCandidates + rw [permissiveRootAwareOrdinalSelection, OracleComp.construct_query_bind, + permissiveRootAwareOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure rfl + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let leftObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates ↦ + permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + let rightObserve := leftObserve + apply relTriple_bind + (relTriple_runPermissiveFromTable_of_stateRel + ((splitUniformImpl n).run cache) left right fuel table hstate) + intro leftResult rightResult hresult + apply relTriple_finishPermissivePrivateOrdinalSelection_eq leftObserve + rightObserve candidates candidates leftResult rightResult hresult + intro nextLeft nextRight hnext + rcases hnext with ⟨hnextState, hremaining, hvalue, htable⟩ + simpa only [leftObserve, rightObserve, hremaining, hvalue] using + ih nextLeft.value.1 candidates candidates nextLeft.state nextRight.state + nextLeft.remaining nextLeft.value.2 rfl hnextState + | inr input => + simpa only [permissiveRootAwareOrdinalSelection, + OracleComp.construct_query_bind, hselected, ↓reduceDIte] using + relTriple_permissiveRootAwareOrdinalSelection_hash ordinal parameter root + ftsSecret input next table ih candidates left right fuel cache hstate + | inr message => + let observe : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates ↦ + permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_runPermissiveFromTable_of_stateRel + ((maskedSign parameter root ftsSecret message).run cache) + left right fuel table hstate) + intro leftResult rightResult hresult + apply relTriple_finishPermissivePrivateOrdinalSelection_eq observe observe candidates + candidates leftResult rightResult hresult + intro nextLeft nextRight hnext + rcases hnext with ⟨hnextState, hremaining, hvalue, htable⟩ + simpa only [observe, hremaining, hvalue] using + ih nextLeft.value.1 candidates candidates nextLeft.state nextRight.state + nextLeft.remaining nextLeft.value.2 rfl hnextState + +noncomputable def permissiveRootAwareSelectionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (rootResult : CleanRunResult (Digest × SplitHashCache)) : ProbComp (Option Probe) := + permissiveRootAwareOrdinalSelection ordinal parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining rootResult.table rootResult.value.2 + +noncomputable def permissiveRootAwareOrdinalSelectionExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : ProbComp (Option Probe) := do + let rootResult ← runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure none + | some result => + permissiveRootAwareSelectionAfterRootResult ordinal adversary parameter ftsSecret result + +noncomputable def optionalProbeLayerRootPosition? : Option Probe → Option Position + | none => none + | some candidate => candidateLayerRootPosition? candidate + +def MaterializedPermissiveSelectionRel + (target : Position) : Option Probe → Option Probe → Prop := + fun materialized permissive => + materializedOrdinalSelectionAt target materialized → + materializedOrdinalSelectionAt target permissive + +theorem relTriple_none_any_materializedPermissiveSelection + (target : Position) (right : ProbComp (Option Probe)) : + RelTriple (pure none : ProbComp (Option Probe)) right + (MaterializedPermissiveSelectionRel target) := by + have hbase := relTriple_true (pure none : ProbComp (Option Probe)) right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun value => value = none) (by + intro value hvalue + simpa using hvalue) + apply relTriple_post_mono hsupported + intro left right hrelation + rw [hrelation.2] + simp [MaterializedPermissiveSelectionRel, materializedOrdinalSelectionAt] + +theorem relTriple_finishMaterializedPermissiveSelection + (target : Position) + (leftObserve : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp (Option Probe)) + (rightObserve : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp (Option Probe)) + (candidates : List Probe) + (left right : Option (CleanRunResult (α × SplitHashCache))) + (hrelation : CleanPermissiveRel left right) + (hrecursive : ∀ result : CleanRunResult (α × SplitHashCache), + RelTriple + (leftObserve result.state result.remaining result.value.1 result.value.2 candidates) + (rightObserve result.state result.remaining result.value.1 result.value.2 candidates) + (MaterializedPermissiveSelectionRel target)) : + RelTriple + (finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target leftObserve) candidates left) + (finishPermissivePrivateOrdinalSelection rightObserve candidates right) + (MaterializedPermissiveSelectionRel target) := by + cases left with + | none => exact relTriple_none_any_materializedPermissiveSelection target _ + | some left => + have hright : right = some left := hrelation + subst right + by_cases hrevealed : Coordinate.position target ∈ left.state.revealed + · simp only [finishMaterializedPrivateOrdinalSelection, + continueMaterializedPrivateOrdinalSelection, finishPermissivePrivateOrdinalSelection, + hrevealed, ↓reduceIte] + exact relTriple_none_any_materializedPermissiveSelection target _ + · simp only [finishMaterializedPrivateOrdinalSelection, + continueMaterializedPrivateOrdinalSelection, finishPermissivePrivateOrdinalSelection, + hrevealed, ↓reduceIte] + exact hrecursive left + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_materializedRootAware_permissiveRootAwareOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + RelTriple + (materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot target + leftRoot rightRoot ftsSecret computation candidates state fuel table cache) + (permissiveRootAwareOrdinalSelection ordinal parameter publicRoot ftsSecret computation + candidates state fuel table cache) + (MaterializedPermissiveSelectionRel target) := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + simp only [materializedActualRootAwareAvoidingOrdinalSelection, + materializedRootAwareAvoidingOrdinalSelection, + permissiveRootAwareOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length <;> + simp only [hselected, ↓reduceDIte] <;> + exact relTriple_pure_pure (fun h => h) + | query_bind query next ih => + rw [materializedActualRootAwareAvoidingOrdinalSelection, + materializedRootAwareAvoidingOrdinalSelection, OracleComp.construct_query_bind, + permissiveRootAwareOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure (fun h => h) + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let leftObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter + publicRoot target leftRoot rightRoot ftsSecret (next output) laterCandidates + nextState remaining table nextCache + let rightObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + permissiveRootAwareOrdinalSelection ordinal parameter publicRoot ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_runCleanFromTable_runPermissiveFromTable + ((splitUniformImpl n).run cache) state fuel table) + intro leftResult rightResult hresult + apply relTriple_finishMaterializedPermissiveSelection target leftObserve + rightObserve candidates leftResult rightResult hresult + intro result + simpa [leftObserve, rightObserve] using + ih result.value.1 candidates result.state result.remaining result.value.2 + | inr input => + simp only [permissiveRootAwareHashStep, selectPermissiveOrdinal, + permissiveRootAwareHashContinue, permissiveRootAwareCandidates, + permissiveRootAwarePublicAction, permissiveRootAwarePublicActionWithPlan, + permissiveRootAwarePlan] + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + exact relTriple_pure_pure (fun h => h) + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + by_cases hsafe : RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? + · have hsafeActual : RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + let leftObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter + publicRoot target leftRoot rightRoot ftsSecret (next output) + laterCandidates nextState remaining table nextCache + let rightObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + permissiveRootAwareOrdinalSelection ordinal parameter publicRoot ftsSecret + (next output) laterCandidates nextState remaining table nextCache + let inner := + (probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache + apply relTriple_bind + (relTriple_runCleanFromTable_runPermissiveFromTable inner state fuel table) + intro leftResult rightResult hresult + apply relTriple_finishMaterializedPermissiveSelection target leftObserve + rightObserve nextCandidates leftResult rightResult hresult + intro result + simpa [leftObserve, rightObserve] using + ih result.value.1 nextCandidates result.state result.remaining result.value.2 + · have hsafeActual : ¬RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + exact relTriple_none_any_materializedPermissiveSelection target _ + | inr message => + let leftObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot + target leftRoot rightRoot ftsSecret (next output) laterCandidates nextState + remaining table nextCache + let rightObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + permissiveRootAwareOrdinalSelection ordinal parameter publicRoot ftsSecret + (next output) laterCandidates nextState remaining table nextCache + let inner := (maskedSign parameter publicRoot ftsSecret message).run cache + apply relTriple_bind + (relTriple_runCleanFromTable_runPermissiveFromTable inner state fuel table) + intro leftResult rightResult hresult + apply relTriple_finishMaterializedPermissiveSelection target leftObserve rightObserve + candidates leftResult rightResult hresult + intro result + simpa [leftObserve, rightObserve] using + ih result.value.1 candidates result.state result.remaining result.value.2 + +noncomputable def sampledHighInstalledPermissiveRootAwareSelectionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp (Digest × Option Probe) := do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let output := fun root => rootOutputOfParts root high + let context : DeferredContext := directDeferredContext rootResult.state + let rootContext := + { context with values := context.values.install target (output leftRoot) } + let selection ← permissiveRootAwareOrdinalSelection ordinal parameter rootResult.value.1 + ftsSecret (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState rootContext) rootResult.remaining rootResult.table + (rootInstalledCache target output rootResult.value.2 leftRoot) + pure (leftRoot, selection) + +theorem relTriple_sampledHigh_materializedRootAwareProduction_installedPermissive + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + RelTriple + (sampledHighMaterializedRootAwareSelectionProductionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult) + (sampledHighInstalledPermissiveRootAwareSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) + (fun left right => left.1 = right.1 ∧ + MaterializedPermissiveSelectionRel target left.2 right.2) := by + unfold sampledHighMaterializedRootAwareSelectionProductionAfterRootResult + sampledHighInstalledPermissiveRootAwareSelectionAfterRootResult + apply relTriple_bind (relTriple_refl ($ᵗ RootOutputHigh : ProbComp RootOutputHigh)) + intro leftHigh rightHigh hhigh + subst rightHigh + apply relTriple_bind (relTriple_refl ($ᵗ Digest : ProbComp Digest)) + intro leftRoot rightRoot hroot + subst rightRoot + let output := fun root => rootOutputOfParts root leftHigh + let context : DeferredContext := directDeferredContext rootResult.state + let rootContext := + { context with values := context.values.install target (output leftRoot) } + apply relTriple_bind + (relTriple_materializedRootAware_permissiveRootAwareOrdinalSelection ordinal parameter + rootResult.value.1 target leftRoot leftRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState rootContext) rootResult.remaining rootResult.table + (rootInstalledCache target output rootResult.value.2 leftRoot)) + intro leftSelection rightSelection hselection + exact relTriple_pure_pure ⟨rfl, hselection⟩ + +theorem probEvent_materializedRootAwareProduction_le_installedPermissive + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + sampledHighMaterializedRootAwareSelectionProductionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult] ≤ + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + sampledHighInstalledPermissiveRootAwareSelectionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult] := by + apply probEvent_le_of_relTriple + (relTriple_sampledHigh_materializedRootAwareProduction_installedPermissive ordinal adversary + parameter ftsSecret target rootResult) + intro left right hrelation hleft + exact hrelation.2 hleft + +noncomputable def directDetailedRootAwarePrivateOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option PrivateOrdinalSelection) := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + List Probe → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → + SplitHashCache → ProbComp (Option PrivateOrdinalSelection)) + (fun _value candidates context _fuel _table _cache => + pure (selectedPrivateOrdinal? ordinal candidates context)) + (fun query _next recursivelyRun candidates context fuel table cache => + if hselected : ordinal < candidates.length then + pure (some ⟨candidates.get ⟨ordinal, hselected⟩, context, candidates⟩) + else + match query with + | .inl (.inl n) => + runDirectResolvedWitnessFromTable context fuel table ((splitUniformImpl n).run cache) >>= + finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (fun nextContext remaining value laterCandidates => + recursivelyRun value.1 laterCandidates nextContext remaining table value.2)) + candidates + | .inl (.inr input) => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input plan) + if hnextSelected : ordinal < nextCandidates.length then + pure (some ⟨nextCandidates.get ⟨ordinal, hnextSelected⟩, context, + nextCandidates⟩) + else + runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterRootAwarePlan parameter input plan).run cache) >>= + finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (fun nextContext remaining value laterCandidates => + recursivelyRun value.1 laterCandidates nextContext remaining table value.2)) + nextCandidates + | .inr message => + runDirectResolvedWitnessFromTable context fuel table + ((maskedSign parameter root ftsSecret message).run cache) >>= + finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (fun nextContext remaining value laterCandidates => + recursivelyRun value.1 laterCandidates nextContext remaining table value.2)) + candidates) + computation candidates context fuel table cache + +theorem directDetailedRootAwarePrivateOrdinalSelection_eq_selected + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hselected : ordinal < candidates.length) : + directDetailedRootAwarePrivateOrdinalSelection ordinal parameter root ftsSecret computation + candidates context fuel table cache = + pure (some ⟨candidates.get ⟨ordinal, hselected⟩, context, candidates⟩) := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache with + | pure value => + rw [directDetailedRootAwarePrivateOrdinalSelection, OracleComp.construct_pure] + simp [selectedPrivateOrdinal?, hselected] + | query_bind query next ih => + rw [directDetailedRootAwarePrivateOrdinalSelection, OracleComp.construct_query_bind] + simp only [hselected, ↓reduceDIte] + +noncomputable def directRootAwareSelectionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp (Option PrivateOrdinalSelection) := + directDetailedRootAwarePrivateOrdinalSelection ordinal parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (canonicalizeMaterializedValues rootResult.table + (directDeferredContext rootResult.state)) + rootResult.remaining rootResult.table rootResult.value.2 + +noncomputable def directRootAwareOrdinalSelectionExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (Option PrivateOrdinalSelection) := do + let rootResult ← runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure none + | some result => + directRootAwareSelectionAfterRootResult ordinal adversary parameter ftsSecret result + +noncomputable def privateOrdinalSelectionLayerRootPosition? : + Option PrivateOrdinalSelection → Option Position + | none => none + | some selection => candidateLayerRootPosition? selection.candidate + +noncomputable def privateOrdinalSelectionUnrevealedLayerRootPosition? : + Option PrivateOrdinalSelection → Option Position + | none => none + | some selection => + match candidateLayerRootPosition? selection.candidate with + | none => none + | some target => + if Coordinate.position target ∈ selection.context.state.revealed then none + else some target + +theorem materializedOrdinalSelectionAt_iff_layerRootPosition + (target : Position) (hroot : IsLayerRoot target) + (selection : Option PrivateOrdinalSelection) : + materializedOrdinalSelectionAt target (selection.map PrivateOrdinalSelection.candidate) ↔ + privateOrdinalSelectionLayerRootPosition? selection = some target := by + cases selection with + | none => simp [materializedOrdinalSelectionAt, privateOrdinalSelectionLayerRootPosition?] + | some selection => + simp only [Option.map_some, privateOrdinalSelectionLayerRootPosition?] + rw [candidateLayerRootPosition?_eq_some_iff] + simp [materializedOrdinalSelectionAt, hroot] + +theorem privateOrdinalSelectionUnrevealedLayerRootPosition?_eq_some_iff + (target : Position) (selection : Option PrivateOrdinalSelection) : + privateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target ↔ + ∃ selected, selection = some selected ∧ + candidateLayerRootPosition? selected.candidate = some target ∧ + Coordinate.position target ∉ selected.context.state.revealed := by + cases selection with + | none => simp [privateOrdinalSelectionUnrevealedLayerRootPosition?] + | some selected => + simp only [privateOrdinalSelectionUnrevealedLayerRootPosition?] + cases hposition : candidateLayerRootPosition? selected.candidate with + | none => simp [hposition] + | some position => + by_cases hrevealed : Coordinate.position position ∈ selected.context.state.revealed + · simp only [hrevealed, ↓reduceIte] + constructor + · intro hnone + contradiction + · rintro ⟨other, heq, htarget, hunrevealed⟩ + cases heq + have hpositionTarget : position = target := by + rw [hposition] at htarget + exact Option.some.inj htarget + subst target + exact False.elim (hunrevealed hrevealed) + · simp only [hrevealed, ↓reduceIte, Option.some.injEq] + constructor + · intro heq + subst position + exact ⟨selected, rfl, hposition, hrevealed⟩ + · rintro ⟨other, heq, htarget, hunrevealed⟩ + cases heq + rw [hposition] at htarget + exact Option.some.inj htarget + +theorem privateOrdinalSelectionUnrevealedLayerRootPosition?_eq_some_of_candidate + {target : Position} {selection : PrivateOrdinalSelection} + (hcandidate : ∃ root, selection.candidate = ⟨.position target, root⟩) + (hroot : IsLayerRoot target) + (hunrevealed : Coordinate.position target ∉ selection.context.state.revealed) : + privateOrdinalSelectionUnrevealedLayerRootPosition? (some selection) = some target := by + rw [privateOrdinalSelectionUnrevealedLayerRootPosition?_eq_some_iff] + refine ⟨selection, rfl, ?_, hunrevealed⟩ + rw [candidateLayerRootPosition?_eq_some_iff] + obtain ⟨root, hcandidate⟩ := hcandidate + exact ⟨congrArg Probe.coordinate hcandidate, hroot⟩ + +theorem probEvent_of_rootAware_selection_position_fibers + (run : ProbComp (Option PrivateOrdinalSelection)) (event : Option PrivateOrdinalSelection → Prop) + (epsilon : ENNReal) + (hnone : ∀ selection, event selection → + privateOrdinalSelectionUnrevealedLayerRootPosition? selection ≠ none) + (hfiber : ∀ target, + Pr[fun selection => event selection ∧ + privateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | run] ≤ + Pr[fun selection => + privateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | run] * + epsilon) : + Pr[event | run] ≤ epsilon := by + apply probEvent_le_of_uniform_weighted_fibers run event + privateOrdinalSelectionUnrevealedLayerRootPosition? epsilon + intro target? + cases target? with + | none => + have hzero : Pr[fun selection => event selection ∧ + privateOrdinalSelectionUnrevealedLayerRootPosition? selection = none | run] = 0 := by + apply probEvent_eq_zero + intro selection _hselection hevent + exact hnone selection hevent.1 hevent.2 + rw [hzero] + exact zero_le + | some target => exact hfiber target + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionAggregation.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionAggregation.lean new file mode 100644 index 00000000..23fbb337 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionAggregation.lean @@ -0,0 +1,318 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonization + +/-! +# Aggregating common root-production fibers + +Every comparison probe emitted by the root-aware handler has a structural parent. The root fibers +can therefore be summed against the one target-independent selector. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +def CleanProbeObservationsHaveStructuralParents + (observations : List CleanProbeObservation) : Prop := + ∀ observation ∈ observations, observation.toProbe.HasStructuralParent + +theorem CleanProbeObservationsHaveStructuralParents.afterCandidate + {observations : List CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} {candidate? : Option Probe} + (hobservations : CleanProbeObservationsHaveStructuralParents observations) + (hcandidate : ∀ candidate, candidate? = some candidate → candidate.HasStructuralParent) : + CleanProbeObservationsHaveStructuralParents + (observationsAfterCandidate observations state candidate?) := by + intro observation hobservation + cases hoption : candidate? with + | none => + have hmem : observation ∈ observations := by + simpa [observationsAfterCandidate, hoption] using hobservation + exact hobservations observation hmem + | some candidate => + have hmem : observation ∈ observations ∨ + observation = cleanProbeObservation state candidate.coordinate candidate.candidate := by + simpa [observationsAfterCandidate, hoption] using hobservation + rcases hmem with hobservation | rfl + · exact hobservations observation hobservation + · simpa [CleanProbeObservation.toProbe, cleanProbeObservation] using + hcandidate candidate hoption + +set_option maxRecDepth 100000 in +theorem observationsHaveStructuralParents_of_mem_observedMaterializedBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hparents : CleanProbeObservationsHaveStructuralParents observations) + (hresult : some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache)) : + CleanProbeObservationsHaveStructuralParents result.observations := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table cache with + | pure value => + simp [observedMaterializedBoundary] at hresult + obtain rfl := hresult + exact hparents + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind] at hresult + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + have heq := observations_eq_of_mem_runObservedCleanFromTable_of_probeFree + ((splitUniformImpl n).run cache) observations state fuel table step + (splitUniformImpl_probeFree n cache) hstep + apply ih step.value.1 step.observations step.state step.remaining table + step.value.2 (heq ▸ hparents) + simpa only [observedMaterializedBoundary] using hrest + | inr input => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + have heq := observations_eq_of_mem_runObservedCleanFromTable_rootAwarePublic + parameter input publicContext.state plan observations state fuel table cache + step hstep + have hcandidates : ∀ candidate, + rootAwareCandidateForPlan? parameter input plan = some candidate → + candidate.HasStructuralParent := by + intro candidate hcandidate + rw [rootAwareCandidateForPlan?_purePlan] at hcandidate + exact rootAwarePlannedCandidate?_hasStructuralParent hcandidate + have hnext : CleanProbeObservationsHaveStructuralParents step.observations := by + rw [heq] + exact hparents.afterCandidate hcandidates + apply ih step.value.1 step.observations step.state step.remaining table + step.value.2 hnext + simpa only [observedMaterializedBoundary] using hrest + | inr message => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + have heq := observations_eq_of_mem_runObservedCleanFromTable_of_probeFree + ((maskedSign parameter root ftsSecret message).run cache) observations state fuel + table step (maskedSign_probeFree parameter root ftsSecret message cache) hstep + apply ih step.value.1 step.observations step.state step.remaining table step.value.2 + (heq ▸ hparents) + simpa only [observedMaterializedBoundary] using hrest + +def ObservedMaterializedOutputHasStructuralParents : + Option (ObservedCleanRunResult α) → Prop + | none => True + | some result => CleanProbeObservationsHaveStructuralParents result.observations + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxRecDepth 100000 in +theorem observedMaterializedOutputHasStructuralParents_of_mem_retainedRunFromTable + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (output : Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))) + (houtput : output ∈ support + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table)) : + ObservedMaterializedOutputHasStructuralParents output := by + unfold observedMaterializedRetainedRunFromTable at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨rootResult?, hroot, hrest⟩ := houtput + cases rootResult? with + | none => + simp at hrest + subst output + trivial + | some rootResult => + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult?, hrestResult, hreturn⟩ := hrest + cases restResult? with + | none => + simp at hreturn + subst output + trivial + | some restResult => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + subst output + have hrootObservations := observations_eq_of_mem_runObservedCleanFromTable_of_probeFree + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty fuel + table rootResult (maskedPublishedTreeRoot_probeFree emptySplitHashCache) hroot + have hparents : + CleanProbeObservationsHaveStructuralParents rootResult.observations := by + rw [hrootObservations] + intro observation hobservation + simp at hobservation + exact observationsHaveStructuralParents_of_mem_observedMaterializedBoundary parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table rootResult.value.2 + restResult hparents hrestResult + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem root_and_parent_of_successfulDoomedFirstRootHitAtTarget + {adversary : Adversary} {parameter : PublicParameter} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {fuel : Nat} {table : OtsSecretIndex → HashOutput} + {ordinal : Nat} {target : Position} + (observed : Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))) : + observed ∈ support + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table) → + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed → + IsLayerRoot target ∧ ∃ parent, Position.parentOf target = some parent := by + cases observed with + | none => + intro _hsupport hhit + simp [ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hhit + | some result => + intro hsupport hhit + have hparents : CleanProbeObservationsHaveStructuralParents result.observations := by + unfold observedMaterializedRetainedRunFromTable at hsupport + rw [mem_support_bind_iff] at hsupport + obtain ⟨rootResult?, hrootResult, hrest⟩ := hsupport + cases rootResult? with + | none => simp at hrest + | some rootResult => + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult?, hrestResult, hreturn⟩ := hrest + cases restResult? with + | none => simp at hreturn + | some restResult => + simp only [support_pure, Set.mem_singleton_iff, Option.some.injEq] at hreturn + have hrootObservations := + observations_eq_of_mem_runObservedCleanFromTable_of_probeFree + (maskedPublishedTreeRoot.run emptySplitHashCache) [] + LazyRevealProbe.State.empty fuel table rootResult + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) hrootResult + have hrootParents : + CleanProbeObservationsHaveStructuralParents rootResult.observations := by + rw [hrootObservations] + intro observation hobservation + simp at hobservation + have hrestParents := + observationsHaveStructuralParents_of_mem_observedMaterializedBoundary parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table + rootResult.value.2 restResult hrootParents hrestResult + rw [hreturn] + exact hrestParents + obtain ⟨⟨_final, selected, hselected, _hfirst, _hroot⟩, hposition⟩ := hhit + have hlt : ordinal < result.observations.length := by + rw [← hselected] + exact selected.isLt + simp only [observedFirstLayerRootPosition?, hlt, ↓reduceDIte] at hposition + have hindex : (⟨ordinal, hlt⟩ : Fin result.observations.length) = selected := + Fin.ext hselected.symm + rw [candidateLayerRootPosition?_eq_some_iff, hindex] at hposition + have hcandidateParent := hparents (result.observations.get selected) + (List.get_mem result.observations selected) + have hcoordinate : + (result.observations.get selected).toProbe.coordinate = .position target := hposition.1 + unfold Probe.HasStructuralParent at hcandidateParent + rw [hcoordinate] at hcandidateParent + exact ⟨hposition.2, hcandidateParent⟩ + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem root_and_parent_of_existing_successfulDoomedFirstRootFiber + {adversary : Adversary} {parameter : PublicParameter} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {fuel : Nat} {table : OtsSecretIndex → HashOutput} + {ordinal : Nat} {target : Position} + (hexists : ∃ observed ∈ support + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table), + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal observed ∧ + observedFirstLayerRootPosition? ordinal observed = some target) : + IsLayerRoot target ∧ ∃ parent, Position.parentOf target = some parent := by + obtain ⟨observed, hsupport, hevent, hposition⟩ := hexists + exact root_and_parent_of_successfulDoomedFirstRootHitAtTarget observed hsupport + ⟨hevent, hposition⟩ + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_successfulDoomedFirstRoot_le_commonDetailed + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (hordinal : ordinal < q) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + 2 * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_le_of_common_position_fibers + (leftPosition := observedFirstLayerRootPosition? ordinal) + (common := permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret (2 * q) table) + (commonPosition := permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?) + · intro observed hevent hnone + exact not_successfulDoomedFirstRoot_of_position_eq_none hnone hevent + · intro target + by_cases hexists : ∃ observed ∈ support + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table), + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal observed ∧ + observedFirstLayerRootPosition? ordinal observed = some target + · have hstructure := + root_and_parent_of_existing_successfulDoomedFirstRootFiber hexists + simpa [ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget] using + probEvent_successfulDoomedFirstRootFiber_le_commonDetailedFiber ordinal adversary + parameter table ftsSecret q target hstructure.1 hstructure.2 hordinal hfuel hbound hq + · simp only [not_exists, not_and] at hexists + have hzero : Pr[fun observed => + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt + table ordinal observed ∧ + observedFirstLayerRootPosition? ordinal observed = some target | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] = + 0 := by + apply probEvent_eq_zero + intro observed hsupport hevent + exact hexists observed hsupport hevent.1 hevent.2 + rw [hzero] + exact zero_le + +set_option maxRecDepth 1000000 in +set_option maxHeartbeats 2000000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_firstRoot_le + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (hordinal : ordinal < q) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + 2 * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_sampledDiagnostic_successfulDoomed_firstExistingHiddenRootHitAt_le_of_forall + intro table + exact probEvent_successfulDoomedFirstRoot_le_commonDetailed ordinal adversary parameter table + ftsSecret q hordinal hfuel (hbound table) hq + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommon.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommon.lean new file mode 100644 index 00000000..325d8c94 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommon.lean @@ -0,0 +1,734 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionNormalizeLift + +/-! +# Common root production observer + +The common selector keeps the selected structural position observable while a distinguished +position remains lazily sampled. Its split cache is completed at that position exactly when the +deferred context already contains the corresponding output. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable + +noncomputable def installDeferredPositionCache + (target : Position) (context : DeferredContext) (cache : SplitHashCache) : SplitHashCache := + match context.positionValue target with + | none => cache + | some output => replaceHiddenRootCache target output cache + +theorem installDeferredPositionCache_eq_of_positionValue_eq + (target : Position) (left right : DeferredContext) (cache : SplitHashCache) + (hvalue : left.positionValue target = right.positionValue target) : + installDeferredPositionCache target left cache = + installDeferredPositionCache target right cache := by + unfold installDeferredPositionCache + rw [hvalue] + +theorem permissiveStateRel_materializedDeferredState_of_finalizationContextEq + (table : OtsSecretIndex → HashOutput) (left right : DeferredContext) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) + (hrevealed : left.state.revealed = right.state.revealed) : + PermissiveStateRel (materializedDeferredState left) + (materializedDeferredState right) := by + exact ⟨materializedDeferredState_values_eq_of_finalizationContextEq table left right + hcontext hvalues, by simpa using hrevealed⟩ + +theorem positionValue_eq_of_finalizationContextEq + (table : OtsSecretIndex → HashOutput) (target : Position) + (left right : DeferredContext) + (hcontext : FinalizationContextEq table (some left) (some right)) : + left.positionValue target = right.positionValue target := by + have hvalue := congrFun hcontext.1.valueEq (Coordinate.position target) + simpa [resolvedCompletionValue] using hvalue + +structure PermissivePrivateOrdinalSelection where + candidate : Probe + state : LazyRevealProbe.State Coordinate + candidates : List Probe + +def erasePermissivePrivateOrdinalSelection : + Option PermissivePrivateOrdinalSelection → Option Probe + | none => none + | some selection => some selection.candidate + +noncomputable def permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? : + Option PermissivePrivateOrdinalSelection → Option Position + | none => none + | some selection => + match candidateLayerRootPosition? selection.candidate with + | none => none + | some target => + if Coordinate.position target ∈ selection.state.revealed then none + else some target + +theorem permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?_eq_some_iff + (target : Position) (selection : Option PermissivePrivateOrdinalSelection) : + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target ↔ + ∃ selected, selection = some selected ∧ + candidateLayerRootPosition? selected.candidate = some target ∧ + Coordinate.position target ∉ selected.state.revealed := by + cases selection with + | none => simp [permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?] + | some selected => + simp only [permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?] + cases hposition : candidateLayerRootPosition? selected.candidate with + | none => simp [hposition] + | some position => + by_cases hrevealed : Coordinate.position position ∈ selected.state.revealed + · simp only [hrevealed, ↓reduceIte] + constructor + · intro hnone + contradiction + · rintro ⟨other, heq, htarget, hunrevealed⟩ + cases heq + have hpositionTarget : position = target := by + rw [hposition] at htarget + exact Option.some.inj htarget + subst target + exact False.elim (hunrevealed hrevealed) + · simp only [hrevealed, ↓reduceIte, Option.some.injEq] + constructor + · intro heq + subst position + exact ⟨selected, rfl, hposition, hrevealed⟩ + · rintro ⟨other, heq, htarget, _hunrevealed⟩ + cases heq + rw [hposition] at htarget + exact Option.some.inj htarget + +theorem permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?_eq_some_of_candidate + {target : Position} {selection : PermissivePrivateOrdinalSelection} + (hcandidate : selection.candidate.coordinate = .position target) + (hroot : IsLayerRoot target) + (hunrevealed : Coordinate.position target ∉ selection.state.revealed) : + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? (some selection) = + some target := by + rw [permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?_eq_some_iff] + refine ⟨selection, rfl, ?_, hunrevealed⟩ + rw [candidateLayerRootPosition?_eq_some_iff] + exact ⟨hcandidate, hroot⟩ + +noncomputable def finishPermissiveDetailedPrivateOrdinalSelection + (observe : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp (Option PermissivePrivateOrdinalSelection)) + (candidates : List Probe) : Option (CleanRunResult (α × SplitHashCache)) → + ProbComp (Option PermissivePrivateOrdinalSelection) + | none => pure none + | some result => + observe result.state result.remaining result.value.1 result.value.2 candidates + +noncomputable def permissiveDetailedRootAwareOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option PermissivePrivateOrdinalSelection) := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + List Probe → LazyRevealProbe.State Coordinate → Nat → + (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp (Option PermissivePrivateOrdinalSelection)) + (fun _value candidates state _fuel _table _cache => + if hselected : ordinal < candidates.length then + pure (some ⟨candidates.get ⟨ordinal, hselected⟩, state, candidates⟩) + else pure none) + (fun query _next recursivelyRun candidates state fuel table cache => + if hselected : ordinal < candidates.length then + pure (some ⟨candidates.get ⟨ordinal, hselected⟩, state, candidates⟩) + else + match query with + | .inl (.inl n) => + runPermissiveFromTable state fuel table ((splitUniformImpl n).run cache) >>= + finishPermissiveDetailedPrivateOrdinalSelection + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache) + candidates + | .inl (.inr input) => + let nextCandidates := permissiveRootAwareCandidates parameter input table state + candidates + if hnextSelected : ordinal < nextCandidates.length then + pure (some ⟨nextCandidates.get ⟨ordinal, hnextSelected⟩, state, + nextCandidates⟩) + else + runPermissiveFromTable state fuel table + (permissiveRootAwarePublicAction parameter input table state cache) >>= + finishPermissiveDetailedPrivateOrdinalSelection + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache) + nextCandidates + | .inr message => + runPermissiveFromTable state fuel table + ((maskedSign parameter root ftsSecret message).run cache) >>= + finishPermissiveDetailedPrivateOrdinalSelection + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache) + candidates) + computation candidates state fuel table cache + +set_option maxRecDepth 100000 in +theorem map_erase_permissiveDetailedRootAwareOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + erasePermissivePrivateOrdinalSelection <$> + permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache = + permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + simp only [permissiveDetailedRootAwareOrdinalSelection, OracleComp.construct_pure, + permissiveRootAwareOrdinalSelection] + by_cases hselected : ordinal < candidates.length <;> + simp [hselected, erasePermissivePrivateOrdinalSelection] + | query_bind query next ih => + rw [permissiveDetailedRootAwareOrdinalSelection, OracleComp.construct_query_bind, + permissiveRootAwareOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp [hselected, erasePermissivePrivateOrdinalSelection] + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [map_bind] + apply bind_congr + intro result + cases result with + | none => rfl + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection, + finishPermissivePrivateOrdinalSelection] + exact ih result.value.1 candidates result.state result.remaining result.value.2 + | inr input => + simp only + let nextCandidates := + permissiveRootAwareCandidates parameter input table state candidates + by_cases hnextSelected : ordinal < nextCandidates.length + · simp [nextCandidates, hnextSelected, erasePermissivePrivateOrdinalSelection, + permissiveRootAwareHashStep, selectPermissiveOrdinal] + · simp only [nextCandidates, hnextSelected, ↓reduceDIte, + permissiveRootAwareHashStep, selectPermissiveOrdinal, + permissiveRootAwareHashContinue] + rw [map_bind] + apply bind_congr + intro result + cases result with + | none => rfl + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection, + finishPermissivePrivateOrdinalSelection] + exact ih result.value.1 nextCandidates result.state result.remaining + result.value.2 + | inr message => + rw [map_bind] + apply bind_congr + intro result + cases result with + | none => rfl + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection, + finishPermissivePrivateOrdinalSelection] + exact ih result.value.1 candidates result.state result.remaining result.value.2 + +def PermissiveDetailedSelectionRel : + Option PermissivePrivateOrdinalSelection → + Option PermissivePrivateOrdinalSelection → Prop + | none, none => True + | some left, some right => + left.candidate = right.candidate ∧ left.candidates = right.candidates ∧ + PermissiveStateRel left.state right.state + | _, _ => False + +def MaterializedPermissiveDetailedSelectionRel + (target : Position) : Option Probe → Option PermissivePrivateOrdinalSelection → Prop := + fun materialized permissive => + materializedOrdinalSelectionAt target materialized → + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? permissive = some target + +theorem relTriple_none_any_materializedPermissiveDetailedSelection + (target : Position) (right : ProbComp (Option PermissivePrivateOrdinalSelection)) : + RelTriple (pure none : ProbComp (Option Probe)) right + (MaterializedPermissiveDetailedSelectionRel target) := by + have hbase := relTriple_true (pure none : ProbComp (Option Probe)) right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun value => value = none) (by + intro value hvalue + simpa using hvalue) + apply relTriple_post_mono hsupported + intro left right hrelation + rw [hrelation.2] + simp [MaterializedPermissiveDetailedSelectionRel, materializedOrdinalSelectionAt] + +theorem relTriple_pure_selected_materializedPermissiveDetailedSelection + (target : Position) (hroot : IsLayerRoot target) + (candidate : Probe) (state : LazyRevealProbe.State Coordinate) + (candidates : List Probe) + (hunrevealed : Coordinate.position target ∉ state.revealed) : + RelTriple + (pure (some candidate) : ProbComp (Option Probe)) + (pure (some ⟨candidate, state, candidates⟩) : + ProbComp (Option PermissivePrivateOrdinalSelection)) + (MaterializedPermissiveDetailedSelectionRel target) := by + apply relTriple_pure_pure + intro hselected + exact permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?_eq_some_of_candidate + (by simpa [materializedOrdinalSelectionAt] using hselected) hroot hunrevealed + +theorem relTriple_finishMaterializedPermissiveDetailedSelection + (target : Position) + (leftObserve : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp (Option Probe)) + (rightObserve : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp (Option PermissivePrivateOrdinalSelection)) + (candidates : List Probe) + (left right : Option (CleanRunResult (α × SplitHashCache))) + (hrelation : CleanPermissiveRel left right) + (hrecursive : ∀ result : CleanRunResult (α × SplitHashCache), + Coordinate.position target ∉ result.state.revealed → + RelTriple + (leftObserve result.state result.remaining result.value.1 result.value.2 candidates) + (rightObserve result.state result.remaining result.value.1 result.value.2 candidates) + (MaterializedPermissiveDetailedSelectionRel target)) : + RelTriple + (finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target leftObserve) candidates left) + (finishPermissiveDetailedPrivateOrdinalSelection rightObserve candidates right) + (MaterializedPermissiveDetailedSelectionRel target) := by + cases left with + | none => exact relTriple_none_any_materializedPermissiveDetailedSelection target _ + | some left => + have hright : right = some left := hrelation + subst right + by_cases hrevealed : Coordinate.position target ∈ left.state.revealed + · simp only [finishMaterializedPrivateOrdinalSelection, + continueMaterializedPrivateOrdinalSelection, + finishPermissiveDetailedPrivateOrdinalSelection, hrevealed, ↓reduceIte] + exact relTriple_none_any_materializedPermissiveDetailedSelection target _ + · simp only [finishMaterializedPrivateOrdinalSelection, + continueMaterializedPrivateOrdinalSelection, + finishPermissiveDetailedPrivateOrdinalSelection, hrevealed, ↓reduceIte] + exact hrecursive left hrevealed + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_materializedRootAware_permissiveDetailedRootAwareOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hunrevealed : Coordinate.position target ∉ state.revealed) : + RelTriple + (materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot target + leftRoot rightRoot ftsSecret computation candidates state fuel table cache) + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter publicRoot ftsSecret + computation candidates state fuel table cache) + (MaterializedPermissiveDetailedSelectionRel target) := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + simp only [materializedActualRootAwareAvoidingOrdinalSelection, + materializedRootAwareAvoidingOrdinalSelection, + permissiveDetailedRootAwareOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_selected_materializedPermissiveDetailedSelection target hroot + (candidates.get ⟨ordinal, hselected⟩) state candidates hunrevealed + · simp only [hselected, ↓reduceDIte] + apply relTriple_pure_pure + simp [MaterializedPermissiveDetailedSelectionRel, materializedOrdinalSelectionAt] + | query_bind query next ih => + rw [materializedActualRootAwareAvoidingOrdinalSelection, + materializedRootAwareAvoidingOrdinalSelection, OracleComp.construct_query_bind, + permissiveDetailedRootAwareOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_selected_materializedPermissiveDetailedSelection target hroot + (candidates.get ⟨ordinal, hselected⟩) state candidates hunrevealed + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let leftObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter + publicRoot target leftRoot rightRoot ftsSecret (next output) laterCandidates + nextState remaining table nextCache + let rightObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + permissiveDetailedRootAwareOrdinalSelection ordinal parameter publicRoot + ftsSecret (next output) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_runCleanFromTable_runPermissiveFromTable + ((splitUniformImpl n).run cache) state fuel table) + intro leftResult rightResult hresult + apply relTriple_finishMaterializedPermissiveDetailedSelection target leftObserve + rightObserve candidates leftResult rightResult hresult + intro result hnextUnrevealed + simpa [leftObserve, rightObserve] using + ih result.value.1 candidates result.state result.remaining result.value.2 + hnextUnrevealed + | inr input => + simp only + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + have hnextCandidates : + permissiveRootAwareCandidates parameter input table state candidates = + nextCandidates := by + rfl + by_cases hnextSelected : ordinal < nextCandidates.length + · have hleftSelected : ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + have hrightSelected : ordinal < + (permissiveRootAwareCandidates parameter input table state candidates).length := + by simpa [hnextCandidates] using hnextSelected + simp only [hleftSelected, hrightSelected, ↓reduceDIte] + exact relTriple_pure_selected_materializedPermissiveDetailedSelection target + hroot (nextCandidates.get ⟨ordinal, hnextSelected⟩) state nextCandidates + hunrevealed + · have hleftSelected : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + have hrightSelected : ¬ordinal < + (permissiveRootAwareCandidates parameter input table state candidates).length := + by simpa [hnextCandidates] using hnextSelected + simp only [hleftSelected, hrightSelected, ↓reduceDIte] + by_cases hsafe : RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? + · have hsafeActual : RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + let leftObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter + publicRoot target leftRoot rightRoot ftsSecret (next output) + laterCandidates nextState remaining table nextCache + let rightObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + permissiveDetailedRootAwareOrdinalSelection ordinal parameter publicRoot + ftsSecret (next output) laterCandidates nextState remaining table nextCache + let inner := + (probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache + apply relTriple_bind + (relTriple_runCleanFromTable_runPermissiveFromTable inner state fuel table) + intro leftResult rightResult hresult + apply relTriple_finishMaterializedPermissiveDetailedSelection target + leftObserve rightObserve nextCandidates leftResult rightResult hresult + intro result hnextUnrevealed + simpa [leftObserve, rightObserve] using + ih result.value.1 nextCandidates result.state result.remaining result.value.2 + hnextUnrevealed + · have hsafeActual : ¬RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + exact relTriple_none_any_materializedPermissiveDetailedSelection target _ + | inr message => + let leftObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot + target leftRoot rightRoot ftsSecret (next output) laterCandidates nextState + remaining table nextCache + let rightObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + permissiveDetailedRootAwareOrdinalSelection ordinal parameter publicRoot ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_runCleanFromTable_runPermissiveFromTable + ((maskedSign parameter publicRoot ftsSecret message).run cache) state fuel table) + intro leftResult rightResult hresult + apply relTriple_finishMaterializedPermissiveDetailedSelection target leftObserve + rightObserve candidates leftResult rightResult hresult + intro result hnextUnrevealed + simpa [leftObserve, rightObserve] using + ih result.value.1 candidates result.state result.remaining result.value.2 + hnextUnrevealed + +theorem PermissiveDetailedSelectionRel.positionFiber_eq + {left right : Option PermissivePrivateOrdinalSelection} + (hrel : PermissiveDetailedSelectionRel left right) : + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? left = + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? right := by + cases left with + | none => + cases right with + | none => rfl + | some right => exact False.elim hrel + | some left => + cases right with + | none => exact False.elim hrel + | some right => + rcases hrel with ⟨hcandidate, _hcandidates, hstate⟩ + simp only [permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?] + rw [hcandidate, hstate.revealed] + +theorem relTriple_finishPermissiveDetailedSelection + (leftObserve rightObserve : LazyRevealProbe.State Coordinate → Nat → α → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection)) + (leftCandidates rightCandidates : List Probe) + (left right : Option (CleanRunResult (α × SplitHashCache))) + (_hcandidates : leftCandidates = rightCandidates) + (hresult : PermissiveCleanRel left right) + (hrecursive : ∀ (leftResult rightResult : CleanRunResult (α × SplitHashCache)), + PermissiveCleanRel (some leftResult) (some rightResult) → + RelTriple + (leftObserve leftResult.state leftResult.remaining leftResult.value.1 + leftResult.value.2 leftCandidates) + (rightObserve rightResult.state rightResult.remaining rightResult.value.1 + rightResult.value.2 rightCandidates) + PermissiveDetailedSelectionRel) : + RelTriple + (finishPermissiveDetailedPrivateOrdinalSelection leftObserve leftCandidates left) + (finishPermissiveDetailedPrivateOrdinalSelection rightObserve rightCandidates right) + PermissiveDetailedSelectionRel := by + cases left with + | none => + cases right with + | none => exact relTriple_pure_pure trivial + | some right => exact False.elim hresult + | some left => + cases right with + | none => exact False.elim hresult + | some right => exact hrecursive left right hresult + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem relTriple_permissiveDetailedRootAwareOrdinalSelection_of_stateRel + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (leftCandidates rightCandidates : List Probe) + (left right : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcandidates : leftCandidates = rightCandidates) + (hstate : PermissiveStateRel left right) : + RelTriple + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + leftCandidates left fuel table cache) + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + rightCandidates right fuel table cache) + PermissiveDetailedSelectionRel := by + induction computation using OracleComp.inductionOn generalizing + leftCandidates rightCandidates left right fuel cache with + | pure value => + subst rightCandidates + simp only [permissiveDetailedRootAwareOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < leftCandidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure ⟨rfl, rfl, hstate⟩ + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure trivial + | query_bind query next ih => + subst rightCandidates + rw [permissiveDetailedRootAwareOrdinalSelection, OracleComp.construct_query_bind, + permissiveDetailedRootAwareOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < leftCandidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure ⟨rfl, rfl, hstate⟩ + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let leftObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + let rightObserve := leftObserve + apply relTriple_bind + (relTriple_runPermissiveFromTable_of_stateRel + ((splitUniformImpl n).run cache) left right fuel table hstate) + intro leftResult rightResult hresult + apply relTriple_finishPermissiveDetailedSelection leftObserve rightObserve leftCandidates + leftCandidates leftResult rightResult rfl hresult + intro nextLeft nextRight hnext + rcases hnext with ⟨hnextState, hremaining, hvalue, htable⟩ + simpa only [leftObserve, rightObserve, hremaining, hvalue, + permissiveDetailedRootAwareOrdinalSelection] using + ih nextLeft.value.1 leftCandidates leftCandidates nextLeft.state nextRight.state + nextLeft.remaining nextLeft.value.2 rfl hnextState + | inr input => + let leftNext := + permissiveRootAwareCandidates parameter input table left leftCandidates + let rightNext := + permissiveRootAwareCandidates parameter input table right leftCandidates + have hnext : leftNext = rightNext := by + exact permissiveRootAwareCandidates_eq_of_stateRel parameter input table + leftCandidates hstate + by_cases hnextSelected : ordinal < leftNext.length + · have hrightSelected : ordinal < rightNext.length := by rwa [← hnext] + simp only [leftNext, rightNext, hnextSelected, hrightSelected, ↓reduceDIte] + apply relTriple_pure_pure + change PermissiveDetailedSelectionRel + (some ⟨leftNext.get ⟨ordinal, hnextSelected⟩, left, leftNext⟩) + (some ⟨rightNext.get ⟨ordinal, hrightSelected⟩, right, rightNext⟩) + exact ⟨by + rw [List.get_eq_getElem, List.get_eq_getElem] + simpa only [hnext], hnext, hstate⟩ + · have hrightSelected : ¬ordinal < rightNext.length := by rwa [← hnext] + simp only [leftNext, rightNext, hnextSelected, hrightSelected, ↓reduceDIte] + have haction := permissiveRootAwarePublicAction_eq_of_stateRel parameter input + table cache hstate + let leftObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + let rightObserve := leftObserve + apply relTriple_bind + (by + rw [haction] + exact relTriple_runPermissiveFromTable_of_stateRel _ left right fuel table + hstate) + intro leftResult rightResult hresult + apply relTriple_finishPermissiveDetailedSelection leftObserve rightObserve + leftNext rightNext + leftResult rightResult hnext hresult + intro nextLeft nextRight hnextResult + rcases hnextResult with ⟨hnextState, hremaining, hvalue, htable⟩ + simpa only [leftObserve, rightObserve, hremaining, hvalue, + permissiveDetailedRootAwareOrdinalSelection] using + ih nextLeft.value.1 leftNext rightNext nextLeft.state nextRight.state + nextLeft.remaining nextLeft.value.2 hnext hnextState + | inr message => + let leftObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + let rightObserve := leftObserve + apply relTriple_bind + (relTriple_runPermissiveFromTable_of_stateRel + ((maskedSign parameter root ftsSecret message).run cache) + left right fuel table hstate) + intro leftResult rightResult hresult + apply relTriple_finishPermissiveDetailedSelection leftObserve rightObserve + leftCandidates leftCandidates + leftResult rightResult rfl hresult + intro nextLeft nextRight hnext + rcases hnext with ⟨hnextState, hremaining, hvalue, htable⟩ + simpa only [leftObserve, rightObserve, hremaining, hvalue, + permissiveDetailedRootAwareOrdinalSelection] using + ih nextLeft.value.1 leftCandidates leftCandidates nextLeft.state nextRight.state + nextLeft.remaining nextLeft.value.2 rfl hnextState + +noncomputable def permissiveDetailedRootAwarePositionFiberComplement + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (target : Position) + (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : ProbComp Bool := do + let selection ← permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret + computation candidates (materializedDeferredState context) fuel table + (installDeferredPositionCache target context cache) + pure (decide + (permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection ≠ some target)) + +instance permissiveDetailedRootAwarePositionFiberComplement_observerSynchronized + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (target : Position) + (table : OtsSecretIndex → HashOutput) : + ObserverSynchronized table + (permissiveDetailedRootAwarePositionFiberComplement ordinal parameter root ftsSecret + computation candidates target table) where + eq_of_synchronized left right fuel cache hcontext hvalues hrevealed := by + have hstate := + permissiveStateRel_materializedDeferredState_of_finalizationContextEq table left right + hcontext hvalues hrevealed + have hcache := installDeferredPositionCache_eq_of_positionValue_eq target left right cache + (positionValue_eq_of_finalizationContextEq table target left right hcontext) + unfold permissiveDetailedRootAwarePositionFiberComplement + rw [hcache] + apply evalDist_eq_of_relTriple_eqRel + apply relTriple_bind + (relTriple_permissiveDetailedRootAwareOrdinalSelection_of_stateRel ordinal parameter root + ftsSecret computation candidates candidates (materializedDeferredState left) + (materializedDeferredState right) fuel table + (installDeferredPositionCache target right cache) rfl hstate) + intro leftSelection rightSelection hselection + apply relTriple_pure_pure + rw [hselection.positionFiber_eq] + rfl + +noncomputable def permissiveRootAwarePositionComplement + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (target : Position) + (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : ProbComp Bool := do + let selection ← permissiveRootAwareOrdinalSelection ordinal parameter root ftsSecret + computation candidates (materializedDeferredState context) fuel table + (installDeferredPositionCache target context cache) + pure (decide (¬materializedOrdinalSelectionAt target selection)) + +instance permissiveRootAwarePositionComplement_observerSynchronized + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (target : Position) + (table : OtsSecretIndex → HashOutput) : + ObserverSynchronized table + (permissiveRootAwarePositionComplement ordinal parameter root ftsSecret computation + candidates target table) where + eq_of_synchronized left right fuel cache hcontext hvalues hrevealed := by + have hstate := + permissiveStateRel_materializedDeferredState_of_finalizationContextEq table left right + hcontext hvalues hrevealed + have hcache := installDeferredPositionCache_eq_of_positionValue_eq target left right cache + (positionValue_eq_of_finalizationContextEq table target left right hcontext) + unfold permissiveRootAwarePositionComplement + rw [hcache] + apply evalDist_bind_eq_of_evalDist_eq + exact evalDist_eq_of_relTriple_eqRel + (relTriple_permissiveRootAwareOrdinalSelection_of_stateRel_aux ordinal parameter root + ftsSecret computation candidates candidates (materializedDeferredState left) + (materializedDeferredState right) fuel table + (installDeferredPositionCache target right cache) rfl hstate) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonCache.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonCache.lean new file mode 100644 index 00000000..f839cd5a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonCache.lean @@ -0,0 +1,656 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonPeekFree + +/-! +# Hidden-cache quotient for common root production + +The permissive selector's concrete actions depend on a split cache only through its ordinary +random-oracle projection. Hidden entries are outputs of reveals and are never read by these actions. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def PermissiveOrdinaryCacheRel : + Option (CleanRunResult (α × SplitHashCache)) → + Option (CleanRunResult (α × SplitHashCache)) → Prop + | none, none => True + | some left, some right => + left.state = right.state ∧ left.remaining = right.remaining ∧ + left.table = right.table ∧ left.value.1 = right.value.1 ∧ + ordinaryQueryCache left.value.2 = ordinaryQueryCache right.value.2 + | _, _ => False + +def PermissiveOrdinaryCacheCouples + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftCache rightCache, + ordinaryQueryCache leftCache = ordinaryQueryCache rightCache → + ∀ state fuel table, + RelTriple + (runPermissiveFromTable state fuel table (computation.run leftCache)) + (runPermissiveFromTable state fuel table (computation.run rightCache)) + PermissiveOrdinaryCacheRel + +theorem runPermissiveFromTable_uniform_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel n : Nat) + (table : OtsSecretIndex → HashOutput) + (next : Fin (n + 1) → OracleComp (LazyRevealProbe.World Coordinate) α) : + runPermissiveFromTable state fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.uniform n)) : + OracleComp (LazyRevealProbe.World Coordinate) (Fin (n + 1))) >>= next) = (do + let output ← liftM (unifSpec.query n) + runPermissiveFromTable state fuel table (next output)) := by + rfl + +theorem runPermissiveFromTable_hashOutput_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) : + runPermissiveFromTable state fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) .hashOutput) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = (do + let output ← LazyRevealProbe.sampleHashOutput + runPermissiveFromTable state fuel table (next output)) := by + rfl + +theorem runPermissiveFromTable_ensure_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) α) : + runPermissiveFromTable state fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.ensure coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runPermissiveFromTable (state.ensure coordinate) fuel table (next ()) := by + rfl + +theorem runPermissiveFromTable_probe_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) (candidate : Digest) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) α) : + runPermissiveFromTable state fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.probe coordinate candidate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + match fuel with + | 0 => pure none + | remaining + 1 => + if coordinate ∈ state.revealed then + runPermissiveFromTable state remaining table (next ()) + else runPermissiveFromTable (state.addPending coordinate candidate) + remaining table (next ()) := by + rfl + +theorem runPermissiveFromTable_peek_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Option HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) : + runPermissiveFromTable state fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.peek coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) (Option HashOutput)) >>= next) = + runPermissiveFromTable state fuel table (next (state.values coordinate)) := by + rfl + +theorem runPermissiveFromTable_publish_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) α) : + runPermissiveFromTable state fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.publish coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runPermissiveFromTable (state.publish coordinate) fuel table (next ()) := by + rfl + +theorem runPermissiveFromTable_reveal_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) : + runPermissiveFromTable state fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.reveal coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = + (match state.values coordinate with + | some output => runPermissiveFromTable state fuel table (next output) + | none => + match coordinate with + | .chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + runPermissiveFromTable (state.materialize coordinate output) fuel table + (next output) + | .position _ => do + let output ← LazyRevealProbe.sampleHashOutput + runPermissiveFromTable (state.materialize coordinate output) fuel table + (next output)) := by + cases coordinate <;> rfl + +theorem runPermissiveFromTable_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (left : OracleComp (LazyRevealProbe.World Coordinate) α) + (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) : + runPermissiveFromTable state fuel table (left >>= next) = + runPermissiveFromTable state fuel table left >>= fun result => + match result with + | none => pure none + | some result => + runPermissiveFromTable result.state result.remaining result.table + (next result.value) := by + induction left using OracleComp.inductionOn generalizing state fuel with + | pure value => simp [runPermissiveFromTable] + | query_bind input continuation ih => + cases input with + | uniform n => + rw [bind_assoc, runPermissiveFromTable_uniform_query_bind, + runPermissiveFromTable_uniform_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output state fuel + | hashOutput => + rw [bind_assoc, runPermissiveFromTable_hashOutput_query_bind, + runPermissiveFromTable_hashOutput_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output state fuel + | ensure coordinate => + rw [bind_assoc, runPermissiveFromTable_ensure_query_bind, + runPermissiveFromTable_ensure_query_bind] + exact ih () (state.ensure coordinate) fuel + | probe coordinate candidate => + rw [bind_assoc, runPermissiveFromTable_probe_query_bind, + runPermissiveFromTable_probe_query_bind] + cases fuel with + | zero => simp + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () state remaining + · simp only [hrevealed, ↓reduceIte] + exact ih () (state.addPending coordinate candidate) remaining + | peek coordinate => + rw [bind_assoc, runPermissiveFromTable_peek_query_bind, + runPermissiveFromTable_peek_query_bind] + exact ih (state.values coordinate) state fuel + | publish coordinate => + rw [bind_assoc, runPermissiveFromTable_publish_query_bind, + runPermissiveFromTable_publish_query_bind] + exact ih () (state.publish coordinate) fuel + | reveal coordinate => + rw [bind_assoc, runPermissiveFromTable_reveal_query_bind, + runPermissiveFromTable_reveal_query_bind] + cases hvalue : state.values coordinate with + | some output => exact ih output state fuel + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact ih (table ⟨lay, tree, leafIdx, chainIdx⟩) + (state.materialize (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩)) fuel + | position position => + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output (state.materialize (.position position) output) fuel + +theorem permissiveOrdinaryCacheCouples_pure (value : α) : + PermissiveOrdinaryCacheCouples + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := by + intro leftCache rightCache hcache state fuel table + simp [runPermissiveFromTable, PermissiveOrdinaryCacheRel, hcache] + +theorem PermissiveOrdinaryCacheCouples.bind + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : PermissiveOrdinaryCacheCouples left) + (hnext : ∀ value, PermissiveOrdinaryCacheCouples (next value)) : + PermissiveOrdinaryCacheCouples (left >>= next) := by + intro leftCache rightCache hcache state fuel table + rw [StateT.run_bind, StateT.run_bind, runPermissiveFromTable_bind, + runPermissiveFromTable_bind] + apply relTriple_bind (hleft leftCache rightCache hcache state fuel table) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => exact False.elim hresult + | some leftResult => + cases rightResult with + | none => exact False.elim hresult + | some rightResult => + rcases hresult with ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + simp only + rw [← hstate, ← hremaining, ← htable, ← hvalue] + exact hnext leftResult.value.1 leftResult.value.2 rightResult.value.2 hnextCache + leftResult.state leftResult.remaining leftResult.table + +theorem permissiveOrdinaryCacheCouples_sequenceFin + {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, PermissiveOrdinaryCacheCouples (computation index)) : + PermissiveOrdinaryCacheCouples (sequenceFin computation) := by + induction n with + | zero => + simp only [sequenceFin] + exact permissiveOrdinaryCacheCouples_pure Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomponent 0).bind fun head => + (ih (fun index : Fin n => computation index.succ) + (fun index => hcomponent index.succ)).bind fun tail => + permissiveOrdinaryCacheCouples_pure + (Fin.cases head tail : Fin (n + 1) → α) + +theorem permissiveOrdinaryCacheCouples_splitUniformImpl (n : Nat) : + PermissiveOrdinaryCacheCouples (splitUniformImpl n) := by + intro leftCache rightCache hcache state fuel table + unfold splitUniformImpl LazyRevealProbe.uniformQuery + rw [StateT.run_liftM, StateT.run_liftM, + runPermissiveFromTable_uniform_query_bind, + runPermissiveFromTable_uniform_query_bind] + apply relTriple_bind + (relTriple_refl (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))) + intro leftOutput rightOutput houtput + subst rightOutput + simp [runPermissiveFromTable, PermissiveOrdinaryCacheRel, hcache] + +theorem permissiveOrdinaryCacheCouples_splitHashQuery_ordinary (input : HashInput) : + PermissiveOrdinaryCacheCouples (splitHashQuery (.ordinary input)) := by + intro leftCache rightCache hcache state fuel table + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + cases hleft : leftCache (.ordinary input) with + | some output => + have hright : rightCache (.ordinary input) = some output := by + change ordinaryQueryCache rightCache input = some output + rw [← hcache] + exact hleft + simp [hright, runPermissiveFromTable, PermissiveOrdinaryCacheRel, hcache] + | none => + have hright : rightCache (.ordinary input) = none := by + change ordinaryQueryCache rightCache input = none + rw [← hcache] + exact hleft + simp only [hright] + unfold LazyRevealProbe.hashOutputQuery + rw [runPermissiveFromTable_hashOutput_query_bind, + runPermissiveFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runPermissiveFromTable, OracleComp.construct_pure] + apply relTriple_pure_pure + refine ⟨rfl, rfl, rfl, rfl, ?_⟩ + rw [ordinaryQueryCache_update, ordinaryQueryCache_update, hcache] + +theorem permissiveOrdinaryCacheCouples_simulateQ + {spec : OracleSpec ι} + (impl : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))) + (himpl : ∀ query, PermissiveOrdinaryCacheCouples (impl query)) + (computation : OracleComp spec α) : + PermissiveOrdinaryCacheCouples (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + rw [simulateQ_pure] + exact permissiveOrdinaryCacheCouples_pure value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (himpl query).bind fun output => ih output + +theorem permissiveOrdinaryCacheCouples_simulateQ_ordinaryHashImpl + (computation : OracleComp HashSpec α) : + PermissiveOrdinaryCacheCouples (simulateQ ordinaryHashImpl computation) := + permissiveOrdinaryCacheCouples_simulateQ ordinaryHashImpl + permissiveOrdinaryCacheCouples_splitHashQuery_ordinary computation + +theorem permissiveOrdinaryCacheCouples_simulateQ_ordinaryRomImpl + (computation : OracleComp OracleWorld α) : + PermissiveOrdinaryCacheCouples (simulateQ ordinaryRomImpl computation) := by + apply permissiveOrdinaryCacheCouples_simulateQ ordinaryRomImpl + intro query + cases query with + | inl n => exact permissiveOrdinaryCacheCouples_splitUniformImpl n + | inr input => exact permissiveOrdinaryCacheCouples_splitHashQuery_ordinary input + +theorem permissiveOrdinaryCacheCouples_ensureCoordinate (coordinate : Coordinate) : + PermissiveOrdinaryCacheCouples (ensureCoordinate coordinate) := by + intro leftCache rightCache hcache state fuel table + unfold ensureCoordinate + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.ensureQuery, + runPermissiveFromTable_ensure_query_bind, + runPermissiveFromTable_ensure_query_bind] + simp [runPermissiveFromTable, PermissiveOrdinaryCacheRel, hcache] + +theorem permissiveOrdinaryCacheCouples_probe (candidate : Probe) : + PermissiveOrdinaryCacheCouples (probe candidate) := by + intro leftCache rightCache hcache state fuel table + unfold probe LazyRevealProbe.probeQuery + rw [StateT.run_liftM, StateT.run_liftM, + runPermissiveFromTable_probe_query_bind, + runPermissiveFromTable_probe_query_bind] + cases fuel with + | zero => exact relTriple_pure_pure trivial + | succ remaining => + by_cases hrevealed : candidate.coordinate ∈ state.revealed + · simp [hrevealed, runPermissiveFromTable, PermissiveOrdinaryCacheRel, hcache] + · simp [hrevealed, runPermissiveFromTable, PermissiveOrdinaryCacheRel, hcache] + +theorem permissiveOrdinaryCacheCouples_revealCoordinateOutput (coordinate : Coordinate) : + PermissiveOrdinaryCacheCouples (revealCoordinateOutput coordinate) := by + intro leftCache rightCache hcache state fuel table + rw [revealCoordinateOutput_run_eq, revealCoordinateOutput_run_eq, + LazyRevealProbe.revealQuery, runPermissiveFromTable_reveal_query_bind, + runPermissiveFromTable_reveal_query_bind] + cases hvalue : state.values coordinate with + | some output => + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache]⟩ + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache]⟩ + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache]⟩ + +theorem permissiveOrdinaryCacheCouples_revealCoordinate (coordinate : Coordinate) : + PermissiveOrdinaryCacheCouples (revealCoordinate coordinate) := by + unfold revealCoordinate + exact (permissiveOrdinaryCacheCouples_revealCoordinateOutput coordinate).bind fun _ => + permissiveOrdinaryCacheCouples_pure _ + +theorem permissiveOrdinaryCacheCouples_publishCoordinate (coordinate : Coordinate) : + PermissiveOrdinaryCacheCouples (publishCoordinate coordinate) := by + intro leftCache rightCache hcache state fuel table + unfold publishCoordinate + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.publishQuery, + runPermissiveFromTable_publish_query_bind, + runPermissiveFromTable_publish_query_bind] + simp [runPermissiveFromTable, PermissiveOrdinaryCacheRel, hcache] + +theorem permissiveOrdinaryCacheCouples_modifyOrdinary + (input : HashInput) (output : HashOutput) : + PermissiveOrdinaryCacheCouples + (modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output)) := by + intro leftCache rightCache hcache state fuel table + simp only [StateT.run_modify, runPermissiveFromTable, OracleComp.construct_pure] + apply relTriple_pure_pure + refine ⟨rfl, rfl, rfl, rfl, ?_⟩ + rw [ordinaryQueryCache_update, ordinaryQueryCache_update, hcache] + +theorem permissiveOrdinaryCacheCouples_resolvePublicKnownInput + (parameter : PublicParameter) (publicState : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) (input : HashInput) : + PermissiveOrdinaryCacheCouples + (resolvePublicKnownInput parameter publicState coordinate input) := by + unfold resolvePublicKnownInput + cases hknown : purePeekTableInput parameter publicState coordinate with + | none => exact permissiveOrdinaryCacheCouples_splitHashQuery_ordinary input + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + exact (permissiveOrdinaryCacheCouples_revealCoordinateOutput coordinate).bind fun output => + (permissiveOrdinaryCacheCouples_publishCoordinate coordinate).bind fun _ => + (permissiveOrdinaryCacheCouples_modifyOrdinary input output).bind fun _ => + permissiveOrdinaryCacheCouples_pure output + · simp only [heq, ↓reduceIte] + exact permissiveOrdinaryCacheCouples_splitHashQuery_ordinary input + +theorem permissiveOrdinaryCacheCouples_publicAction + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (action : PlannedHashAction) : + PermissiveOrdinaryCacheCouples + (probingHashQueryPublicAction parameter input publicState action) := by + cases action with + | ordinary => exact permissiveOrdinaryCacheCouples_splitHashQuery_ordinary input + | resolve coordinate => + exact permissiveOrdinaryCacheCouples_resolvePublicKnownInput parameter publicState + coordinate input + +theorem permissiveOrdinaryCacheCouples_executeCandidate? (candidate : Option Probe) : + PermissiveOrdinaryCacheCouples (executeCandidate? candidate) := by + cases candidate with + | none => exact permissiveOrdinaryCacheCouples_pure () + | some candidate => exact permissiveOrdinaryCacheCouples_probe candidate + +theorem permissiveOrdinaryCacheCouples_rootAwarePublicPlan + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) : + PermissiveOrdinaryCacheCouples + (probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan) := by + unfold probingHashQueryAfterRootAwarePublicPlan + exact (permissiveOrdinaryCacheCouples_executeCandidate? + (rootAwareCandidateForPlan? parameter input plan)).bind fun _ => + permissiveOrdinaryCacheCouples_publicAction parameter input publicState plan.action + +theorem permissiveOrdinaryCacheCouples_ensureChainPrefix + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) : + PermissiveOrdinaryCacheCouples (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (permissiveOrdinaryCacheCouples_sequenceFin _ fun step => by + split + · exact permissiveOrdinaryCacheCouples_ensureCoordinate + (.position (.chain lay tree leafIdx chainIdx step)) + · exact permissiveOrdinaryCacheCouples_pure ()).bind fun _ => + permissiveOrdinaryCacheCouples_pure () + +theorem permissiveOrdinaryCacheCouples_ensureFullChain + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + PermissiveOrdinaryCacheCouples (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (permissiveOrdinaryCacheCouples_sequenceFin _ fun step => + permissiveOrdinaryCacheCouples_ensureCoordinate + (.position (.chain lay tree leafIdx chainIdx step))).bind fun _ => + permissiveOrdinaryCacheCouples_pure () + +theorem permissiveOrdinaryCacheCouples_ensureOtsLeaf + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + PermissiveOrdinaryCacheCouples (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (permissiveOrdinaryCacheCouples_sequenceFin _ fun chainIdx => + permissiveOrdinaryCacheCouples_ensureFullChain lay tree leafIdx chainIdx).bind fun _ => + permissiveOrdinaryCacheCouples_ensureCoordinate (.position (.leaf lay tree leafIdx)) + +theorem permissiveOrdinaryCacheCouples_ensureTreeNode + (lay : Layer) (tree : TreeIndex) : ∀ level nodeIdx, + PermissiveOrdinaryCacheCouples (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => permissiveOrdinaryCacheCouples_ensureOtsLeaf lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (permissiveOrdinaryCacheCouples_ensureTreeNode lay tree level + (2 * nodeIdx)).bind fun _ => + (permissiveOrdinaryCacheCouples_ensureTreeNode lay tree level + (2 * nodeIdx + 1)).bind fun _ => by + split + · exact permissiveOrdinaryCacheCouples_ensureCoordinate + (.position (.node lay tree ⟨level, by assumption⟩ (leafOfNat nodeIdx))) + · exact permissiveOrdinaryCacheCouples_pure () + +theorem permissiveOrdinaryCacheCouples_ensureTreePath + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + PermissiveOrdinaryCacheCouples (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (permissiveOrdinaryCacheCouples_sequenceFin _ fun level => by + split + · exact permissiveOrdinaryCacheCouples_ensureTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · exact permissiveOrdinaryCacheCouples_pure ()).bind fun _ => + permissiveOrdinaryCacheCouples_pure () + +theorem permissiveOrdinaryCacheCouples_maskedTreeNode + (lay : Layer) (tree : TreeIndex) : ∀ level nodeIdx, + PermissiveOrdinaryCacheCouples (maskedTreeNode lay tree level nodeIdx) + | level, nodeIdx => by + unfold maskedTreeNode + apply (permissiveOrdinaryCacheCouples_ensureTreeNode lay tree level nodeIdx).bind + intro _ + cases level with + | zero => + exact permissiveOrdinaryCacheCouples_revealCoordinate + (.position (.leaf lay tree (leafOfNat nodeIdx))) + | succ current => + rw [Nat.add_one] + simp only + split + · exact permissiveOrdinaryCacheCouples_revealCoordinate + (.position (.node lay tree ⟨current, by assumption⟩ (leafOfNat nodeIdx))) + · exact permissiveOrdinaryCacheCouples_pure 0 + +theorem permissiveOrdinaryCacheCouples_maskedTreeRoot + (lay : Layer) (tree : TreeIndex) : + PermissiveOrdinaryCacheCouples (maskedTreeRoot lay tree) := + permissiveOrdinaryCacheCouples_maskedTreeNode lay tree (layerHeight lay) 0 + +theorem permissiveOrdinaryCacheCouples_maskedOtsSignFrom + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : ∀ attempts counter, + PermissiveOrdinaryCacheCouples + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, _ => permissiveOrdinaryCacheCouples_pure none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + exact (permissiveOrdinaryCacheCouples_simulateQ_ordinaryHashImpl + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter))).bind fun encoded => by + cases encoded with + | none => + exact permissiveOrdinaryCacheCouples_maskedOtsSignFrom parameter lay tree + leafIdx message attempts (counter + 1) + | some encoding => + exact (permissiveOrdinaryCacheCouples_sequenceFin _ fun chainIdx => + permissiveOrdinaryCacheCouples_ensureChainPrefix lay tree leafIdx chainIdx + (encoding chainIdx)).bind fun _ => permissiveOrdinaryCacheCouples_pure _ + +theorem permissiveOrdinaryCacheCouples_maskedOtsSign + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : + PermissiveOrdinaryCacheCouples (maskedOtsSign parameter lay tree leafIdx message) := + permissiveOrdinaryCacheCouples_maskedOtsSignFrom parameter lay tree leafIdx message + encodingAttemptLimit 0 + +theorem permissiveOrdinaryCacheCouples_maskedLayerMessage + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + PermissiveOrdinaryCacheCouples (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + split + · exact permissiveOrdinaryCacheCouples_maskedTreeRoot _ _ + · exact permissiveOrdinaryCacheCouples_simulateQ_ordinaryHashImpl _ + +theorem permissiveOrdinaryCacheCouples_maskedSignLayer + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + PermissiveOrdinaryCacheCouples (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + exact (permissiveOrdinaryCacheCouples_maskedLayerMessage parameter ftsSecret index lay).bind + fun message => + (permissiveOrdinaryCacheCouples_maskedOtsSign parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message).bind fun selected => by + cases selected with + | none => exact permissiveOrdinaryCacheCouples_pure none + | some selected => + exact (permissiveOrdinaryCacheCouples_ensureTreePath lay + (treeIndexAt index lay) (leafIndexAt index lay)).bind fun _ => + permissiveOrdinaryCacheCouples_pure (some selected) + +theorem permissiveOrdinaryCacheCouples_revealPublishedCoordinate + (coordinate : Coordinate) : + PermissiveOrdinaryCacheCouples (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + exact (permissiveOrdinaryCacheCouples_revealCoordinate coordinate).bind fun _ => + (permissiveOrdinaryCacheCouples_publishCoordinate coordinate).bind fun _ => + permissiveOrdinaryCacheCouples_pure _ + +theorem permissiveOrdinaryCacheCouples_revealLayerValues + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + PermissiveOrdinaryCacheCouples (revealLayerValues index lay encoding) := by + unfold revealLayerValues + exact (permissiveOrdinaryCacheCouples_sequenceFin _ fun chainIdx => + permissiveOrdinaryCacheCouples_revealPublishedCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx))).bind fun values => + (permissiveOrdinaryCacheCouples_sequenceFin _ fun level => by + split + · cases hzero : level.val with + | zero => + exact permissiveOrdinaryCacheCouples_revealPublishedCoordinate + (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | succ current => + simp only + split + · exact permissiveOrdinaryCacheCouples_revealPublishedCoordinate + (.position (.node lay (treeIndexAt index lay) + ⟨current, by assumption⟩ + (leafOfNat (Nat.xor + ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + · exact permissiveOrdinaryCacheCouples_pure 0 + · exact permissiveOrdinaryCacheCouples_pure 0).bind fun path => + permissiveOrdinaryCacheCouples_pure (values, path) + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem permissiveOrdinaryCacheCouples_maskedSignAfterDigest + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + PermissiveOrdinaryCacheCouples + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest + exact (permissiveOrdinaryCacheCouples_simulateQ_ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index))).bind fun ftsPath => + (permissiveOrdinaryCacheCouples_sequenceFin _ fun lay => + permissiveOrdinaryCacheCouples_maskedSignLayer parameter ftsSecret index lay).bind + fun layers => by + cases hparts : traverseOption layers with + | none => exact permissiveOrdinaryCacheCouples_pure none + | some parts => + exact (permissiveOrdinaryCacheCouples_sequenceFin _ fun lay => + permissiveOrdinaryCacheCouples_revealLayerValues index lay + (parts lay).2).bind fun revealed => + permissiveOrdinaryCacheCouples_pure (some + (show Signature from + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (revealed lay).1 + authPath := flattenPaths fun lay => (revealed lay).2 })) + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem permissiveOrdinaryCacheCouples_maskedSign + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + PermissiveOrdinaryCacheCouples (maskedSign parameter root ftsSecret message) := by + unfold maskedSign + exact (permissiveOrdinaryCacheCouples_simulateQ_ordinaryRomImpl + (signDigestLoop digestAttemptLimit + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ message)).bind fun selected => by + cases selected with + | none => exact permissiveOrdinaryCacheCouples_pure none + | some data => + exact permissiveOrdinaryCacheCouples_maskedSignAfterDigest parameter ftsSecret + data.1 data.2.1 data.2.2 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonCacheLift.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonCacheLift.lean new file mode 100644 index 00000000..8d8e04bd --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonCacheLift.lean @@ -0,0 +1,141 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonCache + +/-! +# Hidden-cache quotient through the detailed selector + +Equal ordinary cache projections give exactly coupled detailed permissive selections. This removes +the proof-only hidden target entry before the lazy sampler is commuted through the selector. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem relTriple_permissiveDetailedRootAwareOrdinalSelection_of_ordinaryCacheEq + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) : + RelTriple + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table leftCache) + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table rightCache) + (fun left right => left = right) := by + induction computation using OracleComp.inductionOn generalizing + candidates state fuel leftCache rightCache with + | pure value => + simp only [permissiveDetailedRootAwareOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length <;> + simp [hselected] + | query_bind query next ih => + rw [permissiveDetailedRootAwareOrdinalSelection, OracleComp.construct_query_bind, + permissiveDetailedRootAwareOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp [hselected] + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + apply relTriple_bind + (permissiveOrdinaryCacheCouples_splitUniformImpl n leftCache rightCache hcache + state fuel table) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] + | some rightResult => exact False.elim hresult + | some leftResult => + cases rightResult with + | none => exact False.elim hresult + | some rightResult => + rcases hresult with + ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + simp only [finishPermissiveDetailedPrivateOrdinalSelection] + simpa only [hstate, hremaining, hvalue, + permissiveDetailedRootAwareOrdinalSelection] using + ih leftResult.value.1 candidates leftResult.state + leftResult.remaining leftResult.value.2 rightResult.value.2 + hnextCache + | inr input => + let nextCandidates := + permissiveRootAwareCandidates parameter input table state candidates + by_cases hnextSelected : ordinal < nextCandidates.length + · simp [nextCandidates, hnextSelected] + · simp only [nextCandidates, hnextSelected, ↓reduceDIte] + have haction := + permissiveOrdinaryCacheCouples_rootAwarePublicPlan parameter input + (materializedCanonicalContext table state).state + (permissiveRootAwarePlan parameter input table state) + leftCache rightCache hcache state fuel table + apply relTriple_bind (by + simpa only [permissiveRootAwarePublicAction, + permissiveRootAwarePublicActionWithPlan] using haction) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] + | some rightResult => exact False.elim hresult + | some leftResult => + cases rightResult with + | none => exact False.elim hresult + | some rightResult => + rcases hresult with + ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + simp only [finishPermissiveDetailedPrivateOrdinalSelection] + simpa only [hstate, hremaining, hvalue, + permissiveDetailedRootAwareOrdinalSelection] using + ih leftResult.value.1 nextCandidates leftResult.state + leftResult.remaining leftResult.value.2 rightResult.value.2 + hnextCache + | inr message => + apply relTriple_bind + (permissiveOrdinaryCacheCouples_maskedSign parameter root ftsSecret message + leftCache rightCache hcache state fuel table) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] + | some rightResult => exact False.elim hresult + | some leftResult => + cases rightResult with + | none => exact False.elim hresult + | some rightResult => + rcases hresult with ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + simp only [finishPermissiveDetailedPrivateOrdinalSelection] + simpa only [hstate, hremaining, hvalue, + permissiveDetailedRootAwareOrdinalSelection] using + ih leftResult.value.1 candidates leftResult.state leftResult.remaining + leftResult.value.2 rightResult.value.2 hnextCache + +theorem evalDist_permissiveDetailedRootAwareOrdinalSelection_eq_of_ordinaryCacheEq + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) : + evalDist + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table leftCache) = + evalDist + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table rightCache) := + evalDist_eq_of_relTriple_eqRel + (relTriple_permissiveDetailedRootAwareOrdinalSelection_of_ordinaryCacheEq ordinal parameter + root ftsSecret computation candidates state fuel table leftCache rightCache hcache) + +theorem ordinaryQueryCache_replaceHiddenRootCache + (target : Position) (output : HashOutput) (cache : SplitHashCache) : + ordinaryQueryCache (replaceHiddenRootCache target output cache) = ordinaryQueryCache cache := by + funext input + simp [ordinaryQueryCache, replaceHiddenRootCache] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonExperiment.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonExperiment.lean new file mode 100644 index 00000000..7158662e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonExperiment.lean @@ -0,0 +1,77 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonLift + +/-! +# Target-independent detailed root production + +The unresolved detailed permissive selector is one common experiment for every structural +position. Its optional position output partitions the successful layer-root selections into +disjoint fibers. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def permissiveDetailedSelectionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp (Option PermissivePrivateOrdinalSelection) := + permissiveDetailedRootAwareOrdinalSelection ordinal parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] rootResult.state + rootResult.remaining rootResult.table rootResult.value.2 + +noncomputable def permissiveDetailedSelectionExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (Option PermissivePrivateOrdinalSelection) := do + let rootResult ← rootAwareProductionInitialRun fuel table + match rootResult with + | none => pure none + | some result => + permissiveDetailedSelectionAfterRootResult ordinal adversary parameter ftsSecret result + +theorem probEvent_permissiveDetailedSelection_positionFiber_le_one + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (target : Position) : + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret fuel + table] ≤ 1 := + probEvent_le_one + +theorem probEvent_le_of_common_position_fibers + (left : ProbComp α) (event : α → Prop) (leftPosition : α → Option Position) + (common : ProbComp β) (commonPosition : β → Option Position) (epsilon : ENNReal) + (hnone : ∀ value, event value → leftPosition value ≠ none) + (hfiber : ∀ target, + Pr[fun value => event value ∧ leftPosition value = some target | left] ≤ + Pr[fun value => commonPosition value = some target | common] * epsilon) : + Pr[event | left] ≤ epsilon := by + rw [probEvent_eq_tsum_classify_fibers left event leftPosition] + calc + _ ≤ ∑' target : Option Position, + Pr[fun value => commonPosition value = target | common] * epsilon := by + apply ENNReal.tsum_le_tsum + intro target + cases target with + | none => + have hzero : Pr[fun value => event value ∧ leftPosition value = none | left] = 0 := by + apply probEvent_eq_zero + intro value _hvalue hevent + exact hnone value hevent.1 hevent.2 + rw [hzero] + exact zero_le + | some target => exact hfiber target + _ = Pr[fun _ : β => True | common] * epsilon := by + have hsum := probEvent_eq_tsum_classify_fibers common (fun _ : β => True) commonPosition + simp only [true_and] at hsum + rw [ENNReal.tsum_mul_right, ← hsum] + _ ≤ epsilon := by + simpa using mul_le_of_le_one_left (zero_le epsilon) (probEvent_le_one (oa := common)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonFactorization.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonFactorization.lean new file mode 100644 index 00000000..62352200 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonFactorization.lean @@ -0,0 +1,406 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonExperiment + +/-! +# One-cell lazy factorization for common root production + +An eager hidden root is represented by preloading only its value. Unlike materialization, this +does not erase probes accumulated at that coordinate. The preload therefore commutes through every +answer-independent step until the first reveal consumes the same uniform output on the lazy side. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def preloadPositionValue + (target : Position) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) : LazyRevealProbe.State Coordinate := + { state with + values := Function.update state.values (.position target) (some output) + ensured := insert (.position target) state.ensured } + +@[simp] theorem preloadPositionValue_values_target + (target : Position) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) : + (preloadPositionValue target output state).values (.position target) = some output := by + simp [preloadPositionValue] + +theorem preloadPositionValue_values_of_ne + (target : Position) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (hne : coordinate ≠ .position target) : + (preloadPositionValue target output state).values coordinate = state.values coordinate := by + simp [preloadPositionValue, Function.update_of_ne hne] + +@[simp] theorem preloadPositionValue_revealed + (target : Position) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) : + (preloadPositionValue target output state).revealed = state.revealed := + rfl + +@[simp] theorem preloadPositionValue_ensure + (target : Position) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) : + preloadPositionValue target output (state.ensure coordinate) = + (preloadPositionValue target output state).ensure coordinate := by + cases state + simp [preloadPositionValue, LazyRevealProbe.State.ensure, Finset.insert_comm] + +@[simp] theorem preloadPositionValue_addPending + (target : Position) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) (candidate : Digest) : + preloadPositionValue target output (state.addPending coordinate candidate) = + (preloadPositionValue target output state).addPending coordinate candidate := by + rfl + +@[simp] theorem preloadPositionValue_publish + (target : Position) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) : + preloadPositionValue target output (state.publish coordinate) = + (preloadPositionValue target output state).publish coordinate := by + rfl + +theorem preloadPositionValue_materialize_of_ne + (target : Position) (targetOutput : HashOutput) + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (output : HashOutput) (hne : coordinate ≠ .position target) : + preloadPositionValue target targetOutput (state.materialize coordinate output) = + (preloadPositionValue target targetOutput state).materialize coordinate output := by + cases state + simp [preloadPositionValue, LazyRevealProbe.State.materialize, + LazyRevealProbe.State.pendingAway, Function.update_comm hne, + Finset.insert_comm] + +theorem preloadPositionValue_eq_materialize_of_pending_eq_empty + (target : Position) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) + (hpending : state.pending = ∅) : + preloadPositionValue target output state = + state.materialize (.position target) output := by + cases state with + | mk pending values revealed ensured => + simp only at hpending + subst pending + simp [preloadPositionValue, LazyRevealProbe.State.materialize, + LazyRevealProbe.State.pendingAway] + +theorem permissiveStateRel_preload_materialize + (target : Position) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) : + PermissiveStateRel (preloadPositionValue target output state) + (state.materialize (.position target) output) := by + exact ⟨rfl, rfl⟩ + +theorem materializedCanonicalContext_values_preload_hidden + (table : OtsSecretIndex → HashOutput) + (state : LazyRevealProbe.State Coordinate) (target : Position) (output : HashOutput) + (hhidden : Coordinate.position target ∉ state.revealed) : + (materializedCanonicalContext table + (preloadPositionValue target output state)).state.values = + (materializedCanonicalContext table state).state.values := by + calc + _ = (materializedCanonicalContext table + (state.materialize (.position target) output)).state.values := + materializedCanonicalContext_values_eq_of_permissiveStateRel table + (permissiveStateRel_preload_materialize target output state) + _ = _ := materializedCanonicalContext_values_materialize_hidden table state target output + hhidden + +def IsTargetPeek (target : Position) : LazyRevealProbe.Query Coordinate → Prop + | .peek (.position position) => position = target + | _ => False + +noncomputable instance (target : Position) : DecidablePred (IsTargetPeek target) := + fun _query => Classical.propDecidable _ + +def SplitCacheEqAway (target : Position) (left right : SplitHashCache) : Prop := + ∀ key, key ≠ .hidden (.position target) → left key = right key + +theorem splitCacheEqAway_replaceHiddenRootCache + (target : Position) (output : HashOutput) (cache : SplitHashCache) : + SplitCacheEqAway target (replaceHiddenRootCache target output cache) cache := by + intro key hne + simp [replaceHiddenRootCache, Function.update_of_ne hne] + +theorem SplitCacheEqAway.update + {target : Position} {left right : SplitHashCache} + (hrel : SplitCacheEqAway target left right) + (key : SplitHashKey) (output : HashOutput) : + SplitCacheEqAway target (Function.update left key (some output)) + (Function.update right key (some output)) := by + intro other hother + by_cases heq : other = key + · subst other + simp + · simp [Function.update_of_ne heq, hrel other hother] + +theorem SplitCacheEqAway.update_target_eq + {target : Position} {left right : SplitHashCache} + (hrel : SplitCacheEqAway target left right) (output : HashOutput) : + Function.update left (.hidden (.position target)) (some output) = + Function.update right (.hidden (.position target)) (some output) := by + funext key + by_cases heq : key = .hidden (.position target) + · subst key + simp + · simp [Function.update_of_ne heq, hrel key heq] + +def PreloadedPositionStateRel + (target : Position) (left right : LazyRevealProbe.State Coordinate) : Prop := + right.values (.position target) = none ∧ left.revealed = right.revealed ∧ + ∃ output, left.values = Function.update right.values (.position target) (some output) + +theorem preloadedPositionStateRel_preload + (target : Position) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) + (hvalue : state.values (.position target) = none) : + PreloadedPositionStateRel target (preloadPositionValue target output state) state := by + exact ⟨hvalue, rfl, output, rfl⟩ + +def PreloadedPermissiveCleanRel + (target : Position) : + Option (CleanRunResult α) → Option (CleanRunResult α) → Prop + | none, none => True + | some left, some right => + left.remaining = right.remaining ∧ left.value = right.value ∧ left.table = right.table ∧ + (PermissiveStateRel left.state right.state ∨ + PreloadedPositionStateRel target left.state right.state) + | _, _ => False + +theorem permissiveCleanRel_to_preloadedPermissiveCleanRel + (target : Position) {left right : Option (CleanRunResult α)} + (hrel : PermissiveCleanRel left right) : + PreloadedPermissiveCleanRel target left right := by + cases left <;> cases right <;> simp_all [PermissiveCleanRel, PreloadedPermissiveCleanRel] + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_sample_preload_runPermissiveFromTable + (target : Position) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hvalue : state.values (.position target) = none) + (hnoPeek : computation.IsQueryBoundP (IsTargetPeek target) 0) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveFromTable (preloadPositionValue target output state) fuel table computation) + (runPermissiveFromTable state fuel table computation) + (PreloadedPermissiveCleanRel target) := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + simp only [runPermissiveFromTable, OracleComp.construct_pure] + let rightResult : Option (CleanRunResult α) := + some ⟨state, fuel, value, table⟩ + let leftResult (output : HashOutput) : Option (CleanRunResult α) := + some ⟨preloadPositionValue target output state, fuel, value, table⟩ + change RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + pure (leftResult output)) + (pure rightResult) (PreloadedPermissiveCleanRel target) + rw [show (pure rightResult : ProbComp _) = + (pure () >>= fun _ => pure rightResult) by simp] + apply relTriple_bind + (relTriple_true LazyRevealProbe.sampleHashOutput (pure ())) + intro output _ _ + apply relTriple_pure_pure + simp [leftResult, rightResult, PreloadedPermissiveCleanRel, + preloadedPositionStateRel_preload target output state hvalue] + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hnoPeek + have hnext : ∀ output, (next output).IsQueryBoundP (IsTargetPeek target) 0 := by + intro output + simpa using hnoPeek.2 output + cases query with + | uniform n => + simp only [runPermissiveFromTable, OracleComp.construct_query_bind] + have hleft : evalDist + (LazyRevealProbe.sampleHashOutput >>= fun targetOutput => + (liftM (unifSpec.query n) >>= fun output => + runPermissiveFromTable (preloadPositionValue target targetOutput state) fuel + table (next output))) = + evalDist + (liftM (unifSpec.query n) >>= fun output => + LazyRevealProbe.sampleHashOutput >>= fun targetOutput => + runPermissiveFromTable (preloadPositionValue target targetOutput state) fuel + table (next output)) := + OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + apply relTriple_of_evalDist_eq_left hleft + apply relTriple_bind (relTriple_refl (liftM (unifSpec.query n))) + intro leftOutput rightOutput heq + subst rightOutput + exact ih leftOutput state fuel hvalue (hnext leftOutput) + | hashOutput => + simp only [runPermissiveFromTable, OracleComp.construct_query_bind] + have hleft : evalDist + (LazyRevealProbe.sampleHashOutput >>= fun targetOutput => + (LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveFromTable (preloadPositionValue target targetOutput state) fuel + table (next output))) = + evalDist + (LazyRevealProbe.sampleHashOutput >>= fun output => + LazyRevealProbe.sampleHashOutput >>= fun targetOutput => + runPermissiveFromTable (preloadPositionValue target targetOutput state) fuel + table (next output)) := + OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + apply relTriple_of_evalDist_eq_left hleft + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + exact ih leftOutput state fuel hvalue (hnext leftOutput) + | ensure coordinate => + simp only [runPermissiveFromTable, OracleComp.construct_query_bind] + change RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveFromTable + ((preloadPositionValue target output state).ensure coordinate) + fuel table (next ())) + (runPermissiveFromTable (state.ensure coordinate) fuel table (next ())) + (PreloadedPermissiveCleanRel target) + simp_rw [← preloadPositionValue_ensure] + exact ih () (state.ensure coordinate) fuel hvalue (hnext ()) + | probe coordinate candidate => + simp only [runPermissiveFromTable, OracleComp.construct_query_bind] + cases fuel with + | zero => + change RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun _ => pure none) + (pure none) (PreloadedPermissiveCleanRel target) + apply relTriple_of_evalDist_eq_left + (OracleComp.DeferredSampling.evalDist_bind_const_neverFails + LazyRevealProbe.sampleHashOutput (by + simp [LazyRevealProbe.sampleHashOutput]) (pure none)) + exact relTriple_pure_pure (by simp [PreloadedPermissiveCleanRel]) + | succ remaining => + change RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + if coordinate ∈ (preloadPositionValue target output state).revealed then + runPermissiveFromTable (preloadPositionValue target output state) remaining + table (next ()) + else + runPermissiveFromTable + ((preloadPositionValue target output state).addPending coordinate candidate) + remaining table (next ())) + (if coordinate ∈ state.revealed then + runPermissiveFromTable state remaining table (next ()) + else runPermissiveFromTable (state.addPending coordinate candidate) remaining + table (next ())) + (PreloadedPermissiveCleanRel target) + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [preloadPositionValue_revealed, hrevealed, ↓reduceIte] + exact ih () state remaining hvalue (hnext ()) + · simp only [preloadPositionValue_revealed, hrevealed, ↓reduceIte] + exact ih () (state.addPending coordinate candidate) remaining hvalue + (hnext ()) + | peek coordinate => + simp only [runPermissiveFromTable, OracleComp.construct_query_bind] + have hne : coordinate ≠ .position target := by + intro heq + subst coordinate + have hnot : ¬IsTargetPeek target + (LazyRevealProbe.Query.peek (.position target)) := by + simpa using hnoPeek.1 + exact hnot (by simp [IsTargetPeek]) + change RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveFromTable (preloadPositionValue target output state) fuel table + (next ((preloadPositionValue target output state).values coordinate))) + (runPermissiveFromTable state fuel table (next (state.values coordinate))) + (PreloadedPermissiveCleanRel target) + simp_rw [preloadPositionValue_values_of_ne target _ state coordinate hne] + exact ih (state.values coordinate) state fuel hvalue + (hnext (state.values coordinate)) + | publish coordinate => + simp only [runPermissiveFromTable, OracleComp.construct_query_bind] + change RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveFromTable + ((preloadPositionValue target output state).publish coordinate) + fuel table (next ())) + (runPermissiveFromTable (state.publish coordinate) fuel table (next ())) + (PreloadedPermissiveCleanRel target) + simp_rw [← preloadPositionValue_publish] + exact ih () (state.publish coordinate) fuel hvalue (hnext ()) + | reveal coordinate => + simp only [runPermissiveFromTable, OracleComp.construct_query_bind] + by_cases htarget : coordinate = .position target + · subst coordinate + simp only [preloadPositionValue_values_target, hvalue] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + have hstate : PermissiveStateRel + (preloadPositionValue target leftOutput state) + (state.materialize (.position target) leftOutput) := + permissiveStateRel_preload_materialize target leftOutput state + apply relTriple_post_mono + (relTriple_runPermissiveFromTable_of_stateRel (next leftOutput) + (preloadPositionValue target leftOutput state) + (state.materialize (.position target) leftOutput) fuel table hstate) + intro left right hrel + exact permissiveCleanRel_to_preloadedPermissiveCleanRel target hrel + · simp_rw [preloadPositionValue_values_of_ne target _ state coordinate htarget] + cases hcoordinateValue : state.values coordinate with + | some output => + simp only + exact ih output state fuel hvalue (hnext output) + | none => + simp only + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only + let coordinate : Coordinate := .chainStart lay tree leafIdx chainIdx + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + have hvalue' : (state.materialize coordinate output).values + (.position target) = none := by + simp [coordinate, LazyRevealProbe.State.materialize, + hvalue] + have hcoupling := + ih output (state.materialize coordinate output) fuel hvalue' + (hnext output) + simp_rw [preloadPositionValue_materialize_of_ne target _ state coordinate + output htarget] at hcoupling + exact hcoupling + | position position => + simp only + have hposition : Coordinate.position position ≠ .position target := htarget + have hvalue' (output : HashOutput) : + (state.materialize (.position position) output).values + (.position target) = none := by + simp [LazyRevealProbe.State.materialize, + Function.update_of_ne (Ne.symm hposition), hvalue] + have hleft : evalDist + (LazyRevealProbe.sampleHashOutput >>= fun targetOutput => + LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveFromTable + (preloadPositionValue target targetOutput + (state.materialize (.position position) output)) + fuel table (next output)) = + evalDist + (LazyRevealProbe.sampleHashOutput >>= fun output => + LazyRevealProbe.sampleHashOutput >>= fun targetOutput => + runPermissiveFromTable + (preloadPositionValue target targetOutput + (state.materialize (.position position) output)) + fuel table (next output)) := + OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + simp only [preloadPositionValue_materialize_of_ne target _ state + (.position position) _ hposition] at hleft + apply relTriple_of_evalDist_eq_left hleft + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + have hcoupling := + ih leftOutput (state.materialize (.position position) leftOutput) fuel + (hvalue' leftOutput) (hnext leftOutput) + simp_rw [preloadPositionValue_materialize_of_ne target _ state + (.position position) leftOutput hposition] at hcoupling + change RelTriple _ + (runPermissiveFromTable + (state.materialize (.position position) leftOutput) fuel table + (next leftOutput)) + (PreloadedPermissiveCleanRel target) + exact hcoupling + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonInitial.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonInitial.lean new file mode 100644 index 00000000..089af57e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonInitial.lean @@ -0,0 +1,123 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonSelectionSampling + +/-! +# Initial facts for common root production + +This module packages the initial root computation facts before they are used under the larger +probability expressions of the common selector. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem initialRootResult_target_absent_pending_empty + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support (rootAwareProductionInitialRun fuel table)) : + rootResult.state.values (.position target) = none ∧ + Coordinate.position target ∉ rootResult.state.revealed ∧ + rootResult.state.pending = ∅ := by + have hraw : LazyRevealProbe.RawResult.done rootResult.state rootResult.remaining + rootResult.value ∈ support + (LazyRevealProbe.runRaw + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel + (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + unfold rootAwareProductionInitialRun at hresult + exact mem_support_runRaw_done_of_mem_runCleanFromTable_some + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table rootResult hresult + have hne := layerRootPosition_ne_top_of_parent hroot hparent + have hsame := preservesCoordinate_maskedPublishedTreeRoot_of_ne target hne + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) emptySplitHashCache fuel + rootResult.state rootResult.remaining rootResult.value.1 rootResult.value.2 hraw + have habsent : rootResult.state.values (.position target) = none ∧ + Coordinate.position target ∉ rootResult.state.revealed := by + constructor + · rw [hsame.1] + rfl + · intro hrevealed + have : Coordinate.position target ∈ + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate).revealed := + hsame.2.mp hrevealed + simp [LazyRevealProbe.State.empty] at this + have hpending : rootResult.state.pending = ∅ := by + have hsubset := pending_subset_of_done_runRaw_of_probeFree + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) rootResult.state fuel + rootResult.remaining rootResult.value (maskedPublishedTreeRoot_probeFree emptySplitHashCache) + hraw + simpa [LazyRevealProbe.State.empty] using hsubset + exact ⟨habsent.1, habsent.2, hpending⟩ + +def InitialRootOptionFacts (target : Position) : + Option (CleanRunResult (Digest × SplitHashCache)) → Prop + | none => True + | some rootResult => + rootResult.state.values (.position target) = none ∧ + Coordinate.position target ∉ rootResult.state.revealed ∧ + rootResult.state.pending = ∅ + +set_option maxRecDepth 100000 in +theorem initialRootOptionFacts_of_mem + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (rootResult? : Option (CleanRunResult (Digest × SplitHashCache))) : + rootResult? ∈ support (rootAwareProductionInitialRun fuel table) → + InitialRootOptionFacts target rootResult? := by + cases rootResult? with + | none => simp [InitialRootOptionFacts] + | some rootResult => + intro hresult + exact initialRootResult_target_absent_pending_empty target hroot hparent fuel table + rootResult hresult + +def InitialRootSwapFacts (parameter : PublicParameter) (target : Position) : + Option (CleanRunResult (Digest × SplitHashCache)) → Prop + | none => True + | some rootResult => + ∀ leftRoot rightRoot, + swapCanonicalRootEncodingCache parameter target leftRoot rightRoot + rootResult.value.2 = rootResult.value.2 + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem initialRootSwapFacts_of_mem + (parameter : PublicParameter) (target : Position) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : Option (CleanRunResult (Digest × SplitHashCache))) + (hresult : result ∈ support (rootAwareProductionInitialRun fuel table)) : + InitialRootSwapFacts parameter target result := by + cases result with + | none => simp [InitialRootSwapFacts] + | some rootResult => + unfold rootAwareProductionInitialRun at hresult + intro leftRoot rightRoot + exact swapCanonicalRootEncodingCache_of_mem_runCleanFromTable_maskedPublishedTreeRoot + parameter target leftRoot rightRoot + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + rootResult hresult + +def InitialRootAllFacts (parameter : PublicParameter) (target : Position) + (result : Option (CleanRunResult (Digest × SplitHashCache))) : Prop := + InitialRootOptionFacts target result ∧ InitialRootSwapFacts parameter target result + +set_option maxRecDepth 100000 in +theorem initialRootAllFacts_of_mem + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : Option (CleanRunResult (Digest × SplitHashCache))) + (hresult : result ∈ support (rootAwareProductionInitialRun fuel table)) : + InitialRootAllFacts parameter target result := + ⟨initialRootOptionFacts_of_mem target hroot hparent fuel table result hresult, + initialRootSwapFacts_of_mem parameter target fuel table result hresult⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonLift.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonLift.lean new file mode 100644 index 00000000..7eab9cb9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonLift.lean @@ -0,0 +1,242 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommon + +/-! +# Detailed common production lift + +The target-specific clean production selector is dominated by an unrevealed position fiber of the +detailed permissive selector. Its explicit low and high output sampler is then normalized to the +ordinary deferred position resolver. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def sampledHighInstalledPermissiveDetailedSelectionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp (Digest × Option PermissivePrivateOrdinalSelection) := do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let output := fun root => rootOutputOfParts root high + let context : DeferredContext := directDeferredContext rootResult.state + let rootContext := + { context with values := context.values.install target (output leftRoot) } + let selection ← permissiveDetailedRootAwareOrdinalSelection ordinal parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState rootContext) rootResult.remaining rootResult.table + (rootInstalledCache target output rootResult.value.2 leftRoot) + pure (leftRoot, selection) + +noncomputable def resolvedInstalledPermissiveDetailedSelectionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp (Digest × Option PermissivePrivateOrdinalSelection) := do + let resolved ← resolveDeferredPositionValue target + (directDeferredContext rootResult.state) + match resolved with + | none => pure (0, none) + | some resolved => + let selection ← permissiveDetailedRootAwareOrdinalSelection ordinal parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState resolved.toDeferredContext) rootResult.remaining + rootResult.table + (replaceHiddenRootCache target resolved.output rootResult.value.2) + pure (truncateHash resolved.output, selection) + +theorem relTriple_sampledHigh_materializedRootAwareProduction_installedPermissiveDetailed + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hunrevealed : Coordinate.position target ∉ rootResult.state.revealed) : + RelTriple + (sampledHighMaterializedRootAwareSelectionProductionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult) + (sampledHighInstalledPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) + (fun left right => left.1 = right.1 ∧ + MaterializedPermissiveDetailedSelectionRel target left.2 right.2) := by + unfold sampledHighMaterializedRootAwareSelectionProductionAfterRootResult + sampledHighInstalledPermissiveDetailedSelectionAfterRootResult + apply relTriple_bind (relTriple_refl ($ᵗ RootOutputHigh : ProbComp RootOutputHigh)) + intro leftHigh rightHigh hhigh + subst rightHigh + apply relTriple_bind (relTriple_refl ($ᵗ Digest : ProbComp Digest)) + intro leftRoot rightRoot hrootEq + subst rightRoot + let output := fun root => rootOutputOfParts root leftHigh + let context : DeferredContext := directDeferredContext rootResult.state + let rootContext := + { context with values := context.values.install target (output leftRoot) } + have hrootUnrevealed : Coordinate.position target ∉ + (materializedDeferredState rootContext).revealed := by + change Coordinate.position target ∉ rootResult.state.revealed + exact hunrevealed + apply relTriple_bind + (relTriple_materializedRootAware_permissiveDetailedRootAwareOrdinalSelection ordinal parameter + rootResult.value.1 target hroot leftRoot leftRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState rootContext) rootResult.remaining rootResult.table + (rootInstalledCache target output rootResult.value.2 leftRoot) hrootUnrevealed) + intro leftSelection rightSelection hselection + exact relTriple_pure_pure ⟨rfl, hselection⟩ + +theorem probEvent_materializedRootAwareProduction_le_installedPermissiveDetailed + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hunrevealed : Coordinate.position target ∉ rootResult.state.revealed) : + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + sampledHighMaterializedRootAwareSelectionProductionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult] ≤ + Pr[fun result => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? result.2 = some target | + sampledHighInstalledPermissiveDetailedSelectionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult] := by + apply probEvent_le_of_relTriple + (relTriple_sampledHigh_materializedRootAwareProduction_installedPermissiveDetailed ordinal + adversary parameter ftsSecret target hroot rootResult hunrevealed) + intro left right hrelation hleft + exact hrelation.2 hleft + +set_option maxRecDepth 100000 in +theorem evalDist_sampledHighInstalledPermissiveDetailed_eq_resolved + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hstate : rootResult.state.values (.position target) = none) + (hpending : rootResult.state.pending = ∅) : + evalDist + (sampledHighInstalledPermissiveDetailedSelectionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult) = + evalDist + (resolvedInstalledPermissiveDetailedSelectionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult) := by + unfold resolvedInstalledPermissiveDetailedSelectionAfterRootResult + rw [resolveDeferredPositionValue_fresh target (directDeferredContext rootResult.state)] + · have hhit : ∀ output, ¬rootResult.state.hitAt (.position target) output := by + intro output + simp [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, hpending] + simp only [directDeferredContext, hhit, ↓reduceIte] + have hclear : rootResult.state.clearPending (.position target) = rootResult.state := by + rcases hrootState : rootResult.state with ⟨pending, values, revealed, ensured⟩ + simp only [LazyRevealProbe.State.clearPending] + have hp : pending = ∅ := by simpa only [hrootState] using hpending + simp [LazyRevealProbe.State.pendingAway, hp] + rw [hclear] + unfold sampledHighInstalledPermissiveDetailedSelectionAfterRootResult rootInstalledCache + let parts : ProbComp HashOutput := do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let root ← ($ᵗ Digest : ProbComp Digest) + pure (rootOutputOfParts root high) + have hparts : evalDist parts = evalDist LazyRevealProbe.sampleHashOutput := by + calc + _ = evalDist (do + let root ← ($ᵗ Digest : ProbComp Digest) + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + pure (rootOutputOfParts root high)) := by + exact OracleComp.DeferredSampling.evalDist_bind_comm + ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + ($ᵗ Digest : ProbComp Digest) + (fun high root => pure (rootOutputOfParts root high)) + _ = _ := evalDist_sample_rootOutputOfParts + let continuation := fun output : HashOutput => do + let selection ← permissiveDetailedRootAwareOrdinalSelection ordinal parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState + { state := rootResult.state + values := (directDeferredValues rootResult.state).install target output }) + rootResult.remaining rootResult.table + (replaceHiddenRootCache target output rootResult.value.2) + pure (truncateHash output, selection) + calc + _ = evalDist (parts >>= continuation) := by + simp [parts, continuation, directDeferredContext, bind_assoc] + _ = evalDist (LazyRevealProbe.sampleHashOutput >>= continuation) := by + exact evalDist_bind_eq_of_evalDist_eq hparts continuation + _ = _ := by rfl + · simpa [directDeferredContext] using hstate + · simpa [directDeferredContext, directDeferredValues] using hstate + +theorem probEvent_materializedRootAwareProduction_le_resolvedPermissiveDetailed_afterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache))) : + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + sampledHighMaterializedRootAwareSelectionProductionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult] ≤ + Pr[fun result => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? result.2 = some target | + resolvedInstalledPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult] := by + have habsent := target_absent_of_mem_runCleanFromTable_maskedPublishedTreeRoot target hroot + hparent fuel table rootResult hresult + have hpending := pending_eq_empty_of_mem_runCleanFromTable_maskedPublishedTreeRoot fuel table + rootResult hresult + calc + _ ≤ Pr[fun result => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? result.2 = some target | + sampledHighInstalledPermissiveDetailedSelectionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult] := + probEvent_materializedRootAwareProduction_le_installedPermissiveDetailed ordinal adversary + parameter ftsSecret target hroot rootResult habsent.2 + _ = _ := by + apply OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + exact evalDist_sampledHighInstalledPermissiveDetailed_eq_resolved ordinal adversary parameter + ftsSecret target rootResult habsent.1 hpending + +noncomputable def resolvedInstalledPermissiveDetailedSelectionExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (Digest × Option PermissivePrivateOrdinalSelection) := do + let rootResult ← rootAwareProductionInitialRun fuel table + match rootResult with + | none => pure (0, none) + | some result => + resolvedInstalledPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target result + +theorem probEvent_materializedRootAwareProduction_le_resolvedPermissiveDetailed + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] ≤ + Pr[fun result => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? result.2 = some target | + resolvedInstalledPermissiveDetailedSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret target fuel table] := by + unfold materializedRootAwareOrdinalProductionExperimentAfterTable + resolvedInstalledPermissiveDetailedSelectionExperimentAfterTable + apply probEvent_bind_le_bind_of_forall_le + intro rootResult hresult + cases rootResult with + | none => simp [materializedOrdinalSelectionAt, + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?] + | some rootResult => + exact + probEvent_materializedRootAwareProduction_le_resolvedPermissiveDetailed_afterRootResult + ordinal adversary parameter ftsSecret target hroot hparent fuel table rootResult hresult + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonPeekFree.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonPeekFree.lean new file mode 100644 index 00000000..78205221 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonPeekFree.lean @@ -0,0 +1,458 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonFactorization + +/-! +# Target-peek freedom of common root production + +The concrete actions executed by the permissive selector never inspect a hidden position through +the lazy-state peek query. Their decisions use the canonical public state passed as ordinary data. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +def TargetPeekFree (target : Position) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ cache, (computation.run cache).IsQueryBoundP (IsTargetPeek target) 0 + +namespace TargetPeekFree + +theorem pure (target : Position) (value : α) : + TargetPeekFree target + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := by + intro cache + simp + +theorem get (target : Position) : + TargetPeekFree target + (get : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) SplitHashCache) := by + intro cache + simp + +theorem modify (target : Position) (update : SplitHashCache → SplitHashCache) : + TargetPeekFree target + (modify update : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit) := by + intro cache + simp + +theorem bind + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + {target : Position} + (hleft : TargetPeekFree target left) + (hnext : ∀ value, TargetPeekFree target (next value)) : + TargetPeekFree target (left >>= next) := by + intro cache + rw [StateT.run_bind] + have hbound := OracleComp.isQueryBoundP_bind (n := 0) (m := 0) (hleft cache) + (fun result _ => hnext result.1 result.2) + simpa using hbound + +theorem map + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {target : Position} + (hcomputation : TargetPeekFree target computation) (transform : α → β) : + TargetPeekFree target (transform <$> computation) := by + rw [map_eq_bind_pure_comp] + exact hcomputation.bind fun value => TargetPeekFree.pure target (transform value) + +end TargetPeekFree + +theorem splitHashQuery_targetPeekFree + (target : Position) (key : SplitHashKey) : + TargetPeekFree target (splitHashQuery key) := by + intro cache + rw [splitHashQuery_run_eq] + cases hlookup : cache key with + | some output => simp + | none => + change (LazyRevealProbe.hashOutputQuery (Coordinate := Coordinate) >>= fun output => + pure (output, Function.update cache key (some output))).IsQueryBoundP + (IsTargetPeek target) 0 + apply OracleComp.isQueryBoundP_bind (n := 0) (m := 0) + · simp [LazyRevealProbe.hashOutputQuery, IsTargetPeek] + · intro _ _ + simp + +theorem splitUniformImpl_targetPeekFree + (target : Position) (n : unifSpec.Domain) : + TargetPeekFree target (splitUniformImpl n) := by + intro cache + change (((fun output : Fin (n + 1) => (output, cache)) <$> + LazyRevealProbe.uniformQuery (Coordinate := Coordinate) n).IsQueryBoundP + (IsTargetPeek target) 0) + rw [OracleComp.isQueryBoundP_map_iff] + simp [LazyRevealProbe.uniformQuery, IsTargetPeek] + +theorem ensureCoordinate_targetPeekFree + (target : Position) (coordinate : Coordinate) : + TargetPeekFree target (ensureCoordinate coordinate) := by + intro cache + unfold ensureCoordinate + change (((fun value : Unit => (value, cache)) <$> + LazyRevealProbe.ensureQuery coordinate).IsQueryBoundP (IsTargetPeek target) 0) + rw [OracleComp.isQueryBoundP_map_iff] + simp [LazyRevealProbe.ensureQuery, IsTargetPeek] + +theorem revealCoordinateOutput_targetPeekFree + (target : Position) (coordinate : Coordinate) : + TargetPeekFree target (revealCoordinateOutput coordinate) := by + intro cache + change (LazyRevealProbe.revealQuery coordinate >>= fun output => + pure (output, Function.update cache (.hidden coordinate) (some output))).IsQueryBoundP + (IsTargetPeek target) 0 + apply OracleComp.isQueryBoundP_bind (n := 0) (m := 0) + · simp [LazyRevealProbe.revealQuery, IsTargetPeek] + · intro _ _ + simp + +theorem revealCoordinate_targetPeekFree + (target : Position) (coordinate : Coordinate) : + TargetPeekFree target (revealCoordinate coordinate) := by + unfold revealCoordinate + exact (revealCoordinateOutput_targetPeekFree target coordinate).bind fun output => + TargetPeekFree.pure target (truncateHash output) + +theorem revealPosition_targetPeekFree + (target : Position) (position : Position) : + TargetPeekFree target (revealPosition position) := + revealCoordinate_targetPeekFree target (.position position) + +theorem publishCoordinate_targetPeekFree + (target : Position) (coordinate : Coordinate) : + TargetPeekFree target (publishCoordinate coordinate) := by + intro cache + unfold publishCoordinate + change (((fun value : Unit => (value, cache)) <$> + LazyRevealProbe.publishQuery coordinate).IsQueryBoundP (IsTargetPeek target) 0) + rw [OracleComp.isQueryBoundP_map_iff] + simp [LazyRevealProbe.publishQuery, IsTargetPeek] + +theorem probe_targetPeekFree (target : Position) (candidate : Probe) : + TargetPeekFree target (probe candidate) := by + intro cache + unfold probe + change (((fun value : Unit => (value, cache)) <$> + LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate).IsQueryBoundP + (IsTargetPeek target) 0) + rw [OracleComp.isQueryBoundP_map_iff] + simp [LazyRevealProbe.probeQuery, IsTargetPeek] + +theorem executeCandidate?_targetPeekFree + (target : Position) (candidate : Option Probe) : + TargetPeekFree target (executeCandidate? candidate) := by + cases candidate with + | none => exact TargetPeekFree.pure target () + | some candidate => exact probe_targetPeekFree target candidate + +theorem resolvePublicKnownInput_targetPeekFree + (target : Position) (parameter : PublicParameter) + (publicState : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) (input : HashInput) : + TargetPeekFree target + (resolvePublicKnownInput parameter publicState coordinate input) := by + unfold resolvePublicKnownInput + cases hknown : purePeekTableInput parameter publicState coordinate with + | none => exact splitHashQuery_targetPeekFree target (.ordinary input) + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + exact (revealCoordinateOutput_targetPeekFree target coordinate).bind fun output => + (publishCoordinate_targetPeekFree target coordinate).bind fun _ => + (TargetPeekFree.modify target fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output)).bind fun _ => + TargetPeekFree.pure target output + · simp only [heq, ↓reduceIte] + exact splitHashQuery_targetPeekFree target (.ordinary input) + +theorem probingHashQueryPublicAction_targetPeekFree + (target : Position) (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (action : PlannedHashAction) : + TargetPeekFree target + (probingHashQueryPublicAction parameter input publicState action) := by + cases action with + | ordinary => exact splitHashQuery_targetPeekFree target (.ordinary input) + | resolve coordinate => + exact resolvePublicKnownInput_targetPeekFree target parameter publicState coordinate input + +theorem probingHashQueryAfterRootAwarePublicPlan_targetPeekFree + (target : Position) (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) : + TargetPeekFree target + (probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan) := by + unfold probingHashQueryAfterRootAwarePublicPlan + exact (executeCandidate?_targetPeekFree target + (rootAwareCandidateForPlan? parameter input plan)).bind fun _ => + probingHashQueryPublicAction_targetPeekFree target parameter input publicState plan.action + +theorem permissiveRootAwarePublicAction_targetPeekFree + (target : Position) (parameter : PublicParameter) (input : HashInput) + (table : OtsSecretIndex → HashOutput) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) : + (permissiveRootAwarePublicAction parameter input table state cache).IsQueryBoundP + (IsTargetPeek target) 0 := + probingHashQueryAfterRootAwarePublicPlan_targetPeekFree target parameter input + (materializedCanonicalContext table state).state + (permissiveRootAwarePlan parameter input table state) cache + +theorem sequenceFin_targetPeekFree + {n : Nat} (target : Position) + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomputation : ∀ index, TargetPeekFree target (computation index)) : + TargetPeekFree target (sequenceFin computation) := by + induction n with + | zero => + simp only [sequenceFin] + exact TargetPeekFree.pure target Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomputation 0).bind fun head => + (ih (fun index => computation index.succ) + (fun index => hcomputation index.succ)).bind fun tail => + TargetPeekFree.pure target (Fin.cases head tail : Fin (n + 1) → α) + +theorem simulateQ_ordinaryHashImpl_targetPeekFree + (target : Position) (computation : OracleComp HashSpec α) : + TargetPeekFree target (simulateQ ordinaryHashImpl computation) := by + intro cache + apply (OracleComp.isQueryBoundP_false computation 0).simulateQ_run_StateT_of_step + intro input workingCache + exact splitHashQuery_targetPeekFree target (.ordinary input) workingCache + +theorem simulateQ_ordinaryRomImpl_targetPeekFree + (target : Position) (computation : OracleComp OracleWorld α) : + TargetPeekFree target (simulateQ ordinaryRomImpl computation) := by + intro cache + apply (OracleComp.isQueryBoundP_false computation 0).simulateQ_run_StateT_of_step + intro input workingCache + cases input with + | inl n => exact splitUniformImpl_targetPeekFree target n workingCache + | inr hashInput => + exact splitHashQuery_targetPeekFree target (.ordinary hashInput) workingCache + +theorem ensureFullChain_targetPeekFree + (target : Position) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + TargetPeekFree target (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (sequenceFin_targetPeekFree target _ fun step => + ensureCoordinate_targetPeekFree target + (.position (.chain lay tree leafIdx chainIdx step))).bind fun _ => + TargetPeekFree.pure target () + +theorem ensureChainPrefix_targetPeekFree + (target : Position) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + TargetPeekFree target (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (sequenceFin_targetPeekFree target _ fun step => by + split + · exact ensureCoordinate_targetPeekFree target + (.position (.chain lay tree leafIdx chainIdx step)) + · exact TargetPeekFree.pure target ()).bind fun _ => TargetPeekFree.pure target () + +theorem ensureOtsLeaf_targetPeekFree + (target : Position) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + TargetPeekFree target (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (sequenceFin_targetPeekFree target _ fun chainIdx => + ensureFullChain_targetPeekFree target lay tree leafIdx chainIdx).bind fun _ => + ensureCoordinate_targetPeekFree target (.position (.leaf lay tree leafIdx)) + +theorem ensureTreeNode_targetPeekFree + (target : Position) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, TargetPeekFree target (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => ensureOtsLeaf_targetPeekFree target lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (ensureTreeNode_targetPeekFree target lay tree level (2 * nodeIdx)).bind fun _ => + (ensureTreeNode_targetPeekFree target lay tree level (2 * nodeIdx + 1)).bind fun _ => by + split + · exact ensureCoordinate_targetPeekFree target + (.position (.node lay tree ⟨level, by assumption⟩ (leafOfNat nodeIdx))) + · exact TargetPeekFree.pure target () + +theorem maskedTreeNode_targetPeekFree + (target : Position) (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) : + TargetPeekFree target (maskedTreeNode lay tree level nodeIdx) := by + cases level with + | zero => + rw [maskedTreeNode] + exact (ensureTreeNode_targetPeekFree target lay tree 0 nodeIdx).bind fun _ => + revealPosition_targetPeekFree target (.leaf lay tree (leafOfNat nodeIdx)) + | succ current => + rw [maskedTreeNode] + exact (ensureTreeNode_targetPeekFree target lay tree (current + 1) nodeIdx).bind fun _ => by + split + · exact revealPosition_targetPeekFree target + (.node lay tree ⟨current, by assumption⟩ (leafOfNat nodeIdx)) + · exact TargetPeekFree.pure target 0 + +theorem maskedTreeRoot_targetPeekFree + (target : Position) (lay : Layer) (tree : TreeIndex) : + TargetPeekFree target (maskedTreeRoot lay tree) := + maskedTreeNode_targetPeekFree target lay tree (layerHeight lay) 0 + +theorem ensureTreePath_targetPeekFree + (target : Position) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + TargetPeekFree target (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (sequenceFin_targetPeekFree target _ fun level => by + split + · exact ensureTreeNode_targetPeekFree target lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · exact TargetPeekFree.pure target ()).bind fun _ => TargetPeekFree.pure target () + +theorem maskedOtsSignFrom_targetPeekFree + (target : Position) (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter, + TargetPeekFree target + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, _ => TargetPeekFree.pure target none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + exact (simulateQ_ordinaryHashImpl_targetPeekFree target + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter))).bind fun encoded => by + cases encoded with + | none => + exact maskedOtsSignFrom_targetPeekFree target parameter lay tree leafIdx message + attempts (counter + 1) + | some encoding => + exact (sequenceFin_targetPeekFree target _ fun chainIdx => + ensureChainPrefix_targetPeekFree target lay tree leafIdx chainIdx + (encoding chainIdx)).bind fun _ => TargetPeekFree.pure target _ + +theorem maskedOtsSign_targetPeekFree + (target : Position) (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + TargetPeekFree target (maskedOtsSign parameter lay tree leafIdx message) := + maskedOtsSignFrom_targetPeekFree target parameter lay tree leafIdx message + encodingAttemptLimit 0 + +theorem maskedLayerMessage_targetPeekFree + (target : Position) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + TargetPeekFree target (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + split + · exact maskedTreeRoot_targetPeekFree target _ _ + · exact simulateQ_ordinaryHashImpl_targetPeekFree target _ + +theorem maskedSignLayer_targetPeekFree + (target : Position) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + TargetPeekFree target (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + exact (maskedLayerMessage_targetPeekFree target parameter ftsSecret index lay).bind fun message => + (maskedOtsSign_targetPeekFree target parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message).bind fun signed => by + cases signed with + | none => exact TargetPeekFree.pure target none + | some part => + exact (ensureTreePath_targetPeekFree target lay (treeIndexAt index lay) + (leafIndexAt index lay)).bind fun _ => TargetPeekFree.pure target (some part) + +theorem revealPublishedCoordinate_targetPeekFree + (target : Position) (coordinate : Coordinate) : + TargetPeekFree target (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + exact (revealCoordinate_targetPeekFree target coordinate).bind fun value => + (publishCoordinate_targetPeekFree target coordinate).bind fun _ => + TargetPeekFree.pure target value + +theorem revealLayerPathValue_targetPeekFree + (target : Position) (index : Index) (lay : Layer) (level : Fin maxLayerHeight) : + TargetPeekFree target (if level.val < layerHeight lay then + match level.val with + | 0 => revealPublishedCoordinate (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | current + 1 => + if hlevel : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hlevel⟩ + (leafOfNat (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0 + else pure 0) := by + by_cases hbelow : level.val < layerHeight lay + · rw [if_pos hbelow] + cases hvalue : level.val with + | zero => + exact revealPublishedCoordinate_targetPeekFree target (.position (.leaf lay + (treeIndexAt index lay) (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | succ current => + simp only + split + · exact revealPublishedCoordinate_targetPeekFree target (.position (.node lay + (treeIndexAt index lay) ⟨current, by assumption⟩ + (leafOfNat (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + · exact TargetPeekFree.pure target 0 + · rw [if_neg hbelow] + exact TargetPeekFree.pure target 0 + +theorem revealLayerValues_targetPeekFree + (target : Position) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + TargetPeekFree target (revealLayerValues index lay encoding) := by + unfold revealLayerValues + exact (sequenceFin_targetPeekFree target _ fun chainIdx => + revealPublishedCoordinate_targetPeekFree target + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx))).bind fun values => + (sequenceFin_targetPeekFree target _ fun level => + revealLayerPathValue_targetPeekFree target index lay level).bind fun path => + TargetPeekFree.pure target (values, path) + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem maskedSignAfterDigest_targetPeekFree + (target : Position) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + TargetPeekFree target + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest + exact (simulateQ_ordinaryHashImpl_targetPeekFree target + (ftsOpen parameter index leaves (ftsSecret index))).bind fun ftsPath => + (sequenceFin_targetPeekFree target _ fun lay => + maskedSignLayer_targetPeekFree target parameter ftsSecret index lay).bind fun layers => by + cases hparts : traverseOption layers with + | none => exact TargetPeekFree.pure target none + | some parts => + exact (sequenceFin_targetPeekFree target _ fun lay => + revealLayerValues_targetPeekFree target index lay (parts lay).2).bind fun revealed => + TargetPeekFree.pure target (some + (show Signature from + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (revealed lay).1 + authPath := flattenPaths fun lay => (revealed lay).2 })) + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem maskedSign_targetPeekFree + (target : Position) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + TargetPeekFree target (maskedSign parameter root ftsSecret message) := by + unfold maskedSign + exact (simulateQ_ordinaryRomImpl_targetPeekFree target + (signDigestLoop digestAttemptLimit + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ message)).bind fun selected => by + cases selected with + | none => exact TargetPeekFree.pure target none + | some data => + exact maskedSignAfterDigest_targetPeekFree target parameter ftsSecret + data.1 data.2.1 data.2.2 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonSampling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonSampling.lean new file mode 100644 index 00000000..85784444 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonSampling.lean @@ -0,0 +1,328 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonCacheLift + +/-! +# Continuation-aware one-cell factorization + +The distinguished uniform sample remains outside a target-peek-free computation until that +computation reveals the target. This form composes with a recursive outer selector without +conditioning away the sample's independence. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option maxRecDepth 100000 in +theorem valuesLE_of_mem_runPermissiveFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : CleanRunResult α) + (hresult : some result ∈ support + (runPermissiveFromTable state fuel table computation)) : + LazyRevealProbe.ValuesLE state result.state := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + simp [runPermissiveFromTable] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact LazyRevealProbe.ValuesLE.refl state + | query_bind query next ih => + cases query with + | uniform n => + rw [runPermissiveFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output state fuel htail + | hashOutput => + rw [runPermissiveFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output state fuel htail + | ensure coordinate => + rw [runPermissiveFromTable_ensure_query_bind] at hresult + exact (LazyRevealProbe.valuesLE_ensure state coordinate).trans + (ih () (state.ensure coordinate) fuel hresult) + | probe coordinate candidate => + rw [runPermissiveFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] at hresult + exact ih () state remaining hresult + · simp only [hrevealed, ↓reduceIte] at hresult + exact (LazyRevealProbe.valuesLE_addPending state coordinate candidate).trans + (ih () (state.addPending coordinate candidate) remaining hresult) + | peek coordinate => + rw [runPermissiveFromTable_peek_query_bind] at hresult + exact ih (state.values coordinate) state fuel hresult + | publish coordinate => + rw [runPermissiveFromTable_publish_query_bind] at hresult + exact (LazyRevealProbe.valuesLE_publish state coordinate).trans + (ih () (state.publish coordinate) fuel hresult) + | reveal coordinate => + rw [runPermissiveFromTable_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + simp only [hvalue] at hresult + exact ih output state fuel hresult + | none => + simp only [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact (LazyRevealProbe.valuesLE_materialize_of_none state + (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) hvalue).trans + (ih (table ⟨lay, tree, leafIdx, chainIdx⟩) + (state.materialize (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩)) fuel hresult) + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact (LazyRevealProbe.valuesLE_materialize_of_none state + (.position position) output hvalue).trans + (ih output (state.materialize (.position position) output) fuel htail) + +def PreloadedOutputAt (target : Position) (output : HashOutput) : + Option (CleanRunResult α) → Prop + | none => True + | some result => result.state.values (.position target) = some output + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_sample_preload_runPermissiveFromTable_then_tagged + (target : Position) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftFinish : HashOutput → Option (CleanRunResult α) → ProbComp β) + (rightFinish : Option (CleanRunResult α) → ProbComp γ) + (relation : β → γ → Prop) + (hvalue : state.values (.position target) = none) + (hnoPeek : computation.IsQueryBoundP (IsTargetPeek target) 0) + (hpreloaded : ∀ nextState remaining value nextTable, + nextState.values (.position target) = none → + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + leftFinish output (some ⟨preloadPositionValue target output nextState, + remaining, value, nextTable⟩)) + (rightFinish (some ⟨nextState, remaining, value, nextTable⟩)) relation) + (hfailed : ∀ output, RelTriple (leftFinish output none) (rightFinish none) relation) + (hsynchronized : ∀ output left right, + PermissiveCleanRel left right → + PreloadedOutputAt target output left → + RelTriple (leftFinish output left) (rightFinish right) relation) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveFromTable (preloadPositionValue target output state) fuel table computation >>= + leftFinish output) + (runPermissiveFromTable state fuel table computation >>= rightFinish) + relation := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + simp only [runPermissiveFromTable, OracleComp.construct_pure, pure_bind] + exact hpreloaded state fuel value table hvalue + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hnoPeek + have hnext : ∀ output, (next output).IsQueryBoundP (IsTargetPeek target) 0 := by + intro output + simpa using hnoPeek.2 output + cases query with + | uniform n => + simp only [runPermissiveFromTable, OracleComp.construct_query_bind, bind_assoc] + have hleft : evalDist + (LazyRevealProbe.sampleHashOutput >>= fun targetOutput => + (liftM (unifSpec.query n) >>= fun output => + runPermissiveFromTable (preloadPositionValue target targetOutput state) fuel + table (next output) >>= leftFinish targetOutput)) = + evalDist + (liftM (unifSpec.query n) >>= fun output => + LazyRevealProbe.sampleHashOutput >>= fun targetOutput => + runPermissiveFromTable (preloadPositionValue target targetOutput state) fuel + table (next output) >>= leftFinish targetOutput) := + OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + apply relTriple_of_evalDist_eq_left hleft + apply relTriple_bind (relTriple_refl (liftM (unifSpec.query n))) + intro leftOutput rightOutput heq + subst rightOutput + exact ih leftOutput state fuel hvalue (hnext leftOutput) + | hashOutput => + simp only [runPermissiveFromTable, OracleComp.construct_query_bind, bind_assoc] + have hleft : evalDist + (LazyRevealProbe.sampleHashOutput >>= fun targetOutput => + (LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveFromTable (preloadPositionValue target targetOutput state) fuel + table (next output) >>= leftFinish targetOutput)) = + evalDist + (LazyRevealProbe.sampleHashOutput >>= fun output => + LazyRevealProbe.sampleHashOutput >>= fun targetOutput => + runPermissiveFromTable (preloadPositionValue target targetOutput state) fuel + table (next output) >>= leftFinish targetOutput) := + OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + apply relTriple_of_evalDist_eq_left hleft + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + exact ih leftOutput state fuel hvalue (hnext leftOutput) + | ensure coordinate => + simp only [runPermissiveFromTable, OracleComp.construct_query_bind] + simp_rw [← preloadPositionValue_ensure] + exact ih () (state.ensure coordinate) fuel hvalue (hnext ()) + | probe coordinate candidate => + simp only [runPermissiveFromTable, OracleComp.construct_query_bind] + cases fuel with + | zero => + simp only [pure_bind] + rw [show rightFinish none = + ((pure () : ProbComp Unit) >>= fun _ => rightFinish none) by simp] + apply relTriple_bind + (relTriple_true LazyRevealProbe.sampleHashOutput (pure () : ProbComp Unit)) + intro leftOutput _rightOutput _hrelation + exact hfailed leftOutput + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [preloadPositionValue_revealed, hrevealed, ↓reduceIte] + exact ih () state remaining hvalue (hnext ()) + · simp only [preloadPositionValue_revealed, hrevealed, ↓reduceIte] + simp_rw [← preloadPositionValue_addPending] + exact ih () (state.addPending coordinate candidate) remaining hvalue (hnext ()) + | peek coordinate => + simp only [runPermissiveFromTable, OracleComp.construct_query_bind] + have hne : coordinate ≠ .position target := by + intro heq + subst coordinate + have hnot : ¬IsTargetPeek target + (LazyRevealProbe.Query.peek (.position target)) := by + simpa using hnoPeek.1 + exact hnot (by simp [IsTargetPeek]) + simp_rw [preloadPositionValue_values_of_ne target _ state coordinate hne] + exact ih (state.values coordinate) state fuel hvalue + (hnext (state.values coordinate)) + | publish coordinate => + simp only [runPermissiveFromTable, OracleComp.construct_query_bind] + simp_rw [← preloadPositionValue_publish] + exact ih () (state.publish coordinate) fuel hvalue (hnext ()) + | reveal coordinate => + simp only [runPermissiveFromTable, OracleComp.construct_query_bind] + by_cases htarget : coordinate = .position target + · subst coordinate + simp only [preloadPositionValue_values_target, hvalue, bind_assoc] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + have hstate : PermissiveStateRel + (preloadPositionValue target leftOutput state) + (state.materialize (.position target) leftOutput) := + permissiveStateRel_preload_materialize target leftOutput state + have hrunBase := relTriple_runPermissiveFromTable_of_stateRel (next leftOutput) + (preloadPositionValue target leftOutput state) + (state.materialize (.position target) leftOutput) fuel table hstate + have hrun := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hrunBase + (PreloadedOutputAt target leftOutput) + (by + intro result hresult + cases result with + | none => trivial + | some result => + exact valuesLE_of_mem_runPermissiveFromTable (next leftOutput) + (preloadPositionValue target leftOutput state) fuel table result hresult + (.position target) leftOutput (by simp)) + apply relTriple_bind hrun + intro left right hrelation + exact hsynchronized leftOutput left right hrelation.1 hrelation.2 + · simp_rw [preloadPositionValue_values_of_ne target _ state coordinate htarget] + cases hcoordinateValue : state.values coordinate with + | some output => + simp only + exact ih output state fuel hvalue (hnext output) + | none => + simp only + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only + let coordinate : Coordinate := .chainStart lay tree leafIdx chainIdx + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + have hvalue' : (state.materialize coordinate output).values + (.position target) = none := by + simp [coordinate, LazyRevealProbe.State.materialize, hvalue] + have hcoupling := ih output (state.materialize coordinate output) fuel + hvalue' (hnext output) + simp_rw [preloadPositionValue_materialize_of_ne target _ state coordinate + output htarget] at hcoupling + exact hcoupling + | position position => + simp only [bind_assoc] + have hposition : Coordinate.position position ≠ .position target := htarget + have hvalue' (output : HashOutput) : + (state.materialize (.position position) output).values + (.position target) = none := by + simp [LazyRevealProbe.State.materialize, + Function.update_of_ne (Ne.symm hposition), hvalue] + have hleft : evalDist + (LazyRevealProbe.sampleHashOutput >>= fun targetOutput => + LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveFromTable + (preloadPositionValue target targetOutput + (state.materialize (.position position) output)) + fuel table (next output) >>= leftFinish targetOutput) = + evalDist + (LazyRevealProbe.sampleHashOutput >>= fun output => + LazyRevealProbe.sampleHashOutput >>= fun targetOutput => + runPermissiveFromTable + (preloadPositionValue target targetOutput + (state.materialize (.position position) output)) + fuel table (next output) >>= leftFinish targetOutput) := + OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + simp only [preloadPositionValue_materialize_of_ne target _ state + (.position position) _ hposition] at hleft + apply relTriple_of_evalDist_eq_left hleft + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + have hcoupling := ih leftOutput + (state.materialize (.position position) leftOutput) fuel + (hvalue' leftOutput) (hnext leftOutput) + simp_rw [preloadPositionValue_materialize_of_ne target _ state + (.position position) leftOutput hposition] at hcoupling + change RelTriple _ + (runPermissiveFromTable + (state.materialize (.position position) leftOutput) fuel table + (next leftOutput) >>= rightFinish) + relation + exact hcoupling + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_sample_preload_runPermissiveFromTable_then + (target : Position) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftFinish : Option (CleanRunResult α) → ProbComp β) + (rightFinish : Option (CleanRunResult α) → ProbComp γ) + (relation : β → γ → Prop) + (hvalue : state.values (.position target) = none) + (hnoPeek : computation.IsQueryBoundP (IsTargetPeek target) 0) + (hpreloaded : ∀ nextState remaining value nextTable, + nextState.values (.position target) = none → + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + leftFinish (some ⟨preloadPositionValue target output nextState, + remaining, value, nextTable⟩)) + (rightFinish (some ⟨nextState, remaining, value, nextTable⟩)) relation) + (hsynchronized : ∀ left right, + PermissiveCleanRel left right → + RelTriple (leftFinish left) (rightFinish right) relation) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveFromTable (preloadPositionValue target output state) fuel table computation >>= + leftFinish) + (runPermissiveFromTable state fuel table computation >>= rightFinish) + relation := by + apply relTriple_sample_preload_runPermissiveFromTable_then_tagged target computation state fuel + table (fun _ => leftFinish) rightFinish relation hvalue hnoPeek hpreloaded + · intro _output + exact hsynchronized none none trivial + · intro _output left right hrelation _hpreloaded + exact hsynchronized left right hrelation + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonSelectionSampling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonSelectionSampling.lean new file mode 100644 index 00000000..81a0974e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonSelectionSampling.lean @@ -0,0 +1,514 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonSampling + +/-! +# Sampling commute through the detailed selector + +Revealed coordinates grow monotonically through the permissive interpreter and selector. This +discharges the administrative already-revealed branch before the one-cell factorization is lifted +through the target-independent outer computation. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option maxRecDepth 100000 in +theorem revealed_subset_of_mem_runPermissiveFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : CleanRunResult α) + (hresult : some result ∈ support + (runPermissiveFromTable state fuel table computation)) : + state.revealed ⊆ result.state.revealed := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + simp [runPermissiveFromTable] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact Finset.Subset.rfl + | query_bind query next ih => + cases query with + | uniform n => + rw [runPermissiveFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output state fuel htail + | hashOutput => + rw [runPermissiveFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output state fuel htail + | ensure coordinate => + rw [runPermissiveFromTable_ensure_query_bind] at hresult + exact ih () (state.ensure coordinate) fuel hresult + | probe coordinate candidate => + rw [runPermissiveFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] at hresult + exact ih () state remaining hresult + · simp only [hrevealed, ↓reduceIte] at hresult + exact ih () (state.addPending coordinate candidate) remaining hresult + | peek coordinate => + rw [runPermissiveFromTable_peek_query_bind] at hresult + exact ih (state.values coordinate) state fuel hresult + | publish coordinate => + rw [runPermissiveFromTable_publish_query_bind] at hresult + exact (Finset.subset_insert coordinate state.revealed).trans + (ih () (state.publish coordinate) fuel hresult) + | reveal coordinate => + rw [runPermissiveFromTable_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + simp only [hvalue] at hresult + exact ih output state fuel hresult + | none => + simp only [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact ih (table ⟨lay, tree, leafIdx, chainIdx⟩) + (state.materialize (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩)) fuel hresult + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output (state.materialize (.position position) output) fuel htail + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem revealed_subset_of_mem_permissiveDetailedRootAwareOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (selection : PermissivePrivateOrdinalSelection) + (hselection : some selection ∈ support + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache)) : + state.revealed ⊆ selection.state.revealed := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + simp only [permissiveDetailedRootAwareOrdinalSelection, OracleComp.construct_pure] at hselection + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] at hselection + simp at hselection + subst selection + exact Finset.Subset.rfl + · simp [hselected] at hselection + | query_bind query next ih => + rw [permissiveDetailedRootAwareOrdinalSelection, OracleComp.construct_query_bind] at hselection + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] at hselection + simp at hselection + subst selection + exact Finset.Subset.rfl + · simp only [hselected, ↓reduceDIte] at hselection + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hselection + obtain ⟨result, hresult, htail⟩ := hselection + cases result with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] at htail + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] at htail + exact (revealed_subset_of_mem_runPermissiveFromTable + ((splitUniformImpl n).run cache) state fuel table result hresult).trans + (ih result.value.1 candidates result.state result.remaining result.value.2 + htail) + | inr input => + let nextCandidates := + permissiveRootAwareCandidates parameter input table state candidates + by_cases hnextSelected : ordinal < nextCandidates.length + · simp only [nextCandidates, hnextSelected, ↓reduceDIte] at hselection + simp at hselection + subst selection + exact Finset.Subset.rfl + · simp only [nextCandidates, hnextSelected, ↓reduceDIte] at hselection + rw [mem_support_bind_iff] at hselection + obtain ⟨result, hresult, htail⟩ := hselection + cases result with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] at htail + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] at htail + exact (revealed_subset_of_mem_runPermissiveFromTable + (permissiveRootAwarePublicAction parameter input table state cache) + state fuel table result hresult).trans + (ih result.value.1 nextCandidates result.state result.remaining + result.value.2 htail) + | inr message => + rw [mem_support_bind_iff] at hselection + obtain ⟨result, hresult, htail⟩ := hselection + cases result with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] at htail + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] at htail + exact (revealed_subset_of_mem_runPermissiveFromTable + ((maskedSign parameter root ftsSecret message).run cache) + state fuel table result hresult).trans + (ih result.value.1 candidates result.state result.remaining result.value.2 htail) + +theorem unrevealedLayerRootPosition_ne_of_initial_revealed + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (htarget : Coordinate.position target ∈ state.revealed) + (selection : Option PermissivePrivateOrdinalSelection) + (hselection : selection ∈ support + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache)) : + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection ≠ some target := by + cases selection with + | none => simp [permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?] + | some selection => + intro heq + rw [permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?_eq_some_iff] at heq + obtain ⟨selected, hselected, _hcandidate, hunrevealed⟩ := heq + cases hselected + exact hunrevealed + (revealed_subset_of_mem_permissiveDetailedRootAwareOrdinalSelection ordinal parameter root + ftsSecret computation candidates state fuel table cache selection hselection htarget) + +def PermissiveTargetFiberRel (target : Position) : + Option PermissivePrivateOrdinalSelection → + Option PermissivePrivateOrdinalSelection → Prop := + fun left right => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? left = some target → + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? right = some target + +theorem relTriple_permissiveDetailedRootAwareOrdinalSelection_targetFiber_of_stateRel + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (left right : LazyRevealProbe.State Coordinate) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (hstate : PermissiveStateRel left right) : + RelTriple + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + candidates left fuel table cache) + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + candidates right fuel table cache) + (PermissiveTargetFiberRel target) := by + apply relTriple_post_mono + (relTriple_permissiveDetailedRootAwareOrdinalSelection_of_stateRel ordinal parameter root + ftsSecret computation candidates candidates left right fuel table cache rfl hstate) + intro leftSelection rightSelection hselection hleft + rw [hselection.positionFiber_eq] at hleft + exact hleft + +theorem relTriple_sample_preload_runPermissive_finishDetailed + (target : Position) + (computation : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftObserve rightObserve : LazyRevealProbe.State Coordinate → Nat → α → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection)) + (candidates : List Probe) + (hvalue : state.values (.position target) = none) + (hnoPeek : computation.IsQueryBoundP (IsTargetPeek target) 0) + (hpreloaded : ∀ nextState remaining value nextCache, + nextState.values (.position target) = none → + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + leftObserve (preloadPositionValue target output nextState) remaining value nextCache + candidates) + (rightObserve nextState remaining value nextCache candidates) + (PermissiveTargetFiberRel target)) + (hsynchronized : ∀ left right remaining value cache, + PermissiveStateRel left right → + RelTriple + (leftObserve left remaining value cache candidates) + (rightObserve right remaining value cache candidates) + (PermissiveTargetFiberRel target)) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveFromTable (preloadPositionValue target output state) fuel table computation >>= + finishPermissiveDetailedPrivateOrdinalSelection leftObserve candidates) + (runPermissiveFromTable state fuel table computation >>= + finishPermissiveDetailedPrivateOrdinalSelection rightObserve candidates) + (PermissiveTargetFiberRel target) := by + apply relTriple_sample_preload_runPermissiveFromTable_then target computation state fuel table + (finishPermissiveDetailedPrivateOrdinalSelection leftObserve candidates) + (finishPermissiveDetailedPrivateOrdinalSelection rightObserve candidates) + (PermissiveTargetFiberRel target) hvalue hnoPeek + · intro nextState remaining result nextTable hnextValue + rcases result with ⟨value, nextCache⟩ + simp only [finishPermissiveDetailedPrivateOrdinalSelection] + exact hpreloaded nextState remaining value nextCache hnextValue + · intro left right hresult + cases left with + | none => + cases right with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection, + PermissiveTargetFiberRel] + | some right => exact False.elim hresult + | some left => + cases right with + | none => exact False.elim hresult + | some right => + rcases hresult with ⟨hstate, hremaining, hvalue, htable⟩ + have hvalueEq := congrArg Prod.fst hvalue + have hcacheEq := congrArg Prod.snd hvalue + simp only [finishPermissiveDetailedPrivateOrdinalSelection] + rw [← hremaining, ← hvalueEq, ← hcacheEq] + exact hsynchronized left.state right.state left.remaining left.value.1 + left.value.2 hstate + +theorem relTriple_sample_preload_selector_targetFiber_of_initial_revealed + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (hrevealed : Coordinate.position target ∈ state.revealed) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + candidates (preloadPositionValue target output state) fuel table cache) + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache) + (PermissiveTargetFiberRel target) := by + have hbase := relTriple_true + (LazyRevealProbe.sampleHashOutput >>= fun output => + permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + candidates (preloadPositionValue target output state) fuel table cache) + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection ≠ some target) + (by + intro selection hselection + rw [mem_support_bind_iff] at hselection + obtain ⟨output, _houtput, htail⟩ := hselection + exact unrevealedLayerRootPosition_ne_of_initial_revealed ordinal parameter root ftsSecret + computation candidates (preloadPositionValue target output state) fuel table cache target + (by simpa using hrevealed) selection htail) + apply relTriple_post_mono hleft + intro left right hrelation hfiber + exact False.elim (hrelation.2 hfiber) + +theorem permissiveRootAwarePlan_preload_hidden + (target : Position) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) + (hhidden : Coordinate.position target ∉ state.revealed) + (parameter : PublicParameter) (input : HashInput) + (table : OtsSecretIndex → HashOutput) : + permissiveRootAwarePlan parameter input table (preloadPositionValue target output state) = + permissiveRootAwarePlan parameter input table state := by + unfold permissiveRootAwarePlan + exact purePlanProbingHashQuery_eq_of_values_eq + (materializedCanonicalContext_values_preload_hidden table state target output hhidden) + parameter input + +theorem permissiveRootAwareCandidates_preload_hidden + (target : Position) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) + (hhidden : Coordinate.position target ∉ state.revealed) + (parameter : PublicParameter) (input : HashInput) + (table : OtsSecretIndex → HashOutput) (candidates : List Probe) : + permissiveRootAwareCandidates parameter input table + (preloadPositionValue target output state) candidates = + permissiveRootAwareCandidates parameter input table state candidates := by + unfold permissiveRootAwareCandidates + rw [permissiveRootAwarePlan_preload_hidden target output state hhidden] + +theorem permissiveRootAwarePublicAction_preload_hidden + (target : Position) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) + (hhidden : Coordinate.position target ∉ state.revealed) + (parameter : PublicParameter) (input : HashInput) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + permissiveRootAwarePublicAction parameter input table + (preloadPositionValue target output state) cache = + permissiveRootAwarePublicAction parameter input table state cache := by + unfold permissiveRootAwarePublicAction + have hvalues := + materializedCanonicalContext_values_preload_hidden table state target output hhidden + have hplan := permissiveRootAwarePlan_preload_hidden target output state hhidden parameter + input table + calc + _ = permissiveRootAwarePublicActionWithPlan parameter input + (materializedCanonicalContext table state).state + (permissiveRootAwarePlan parameter input table + (preloadPositionValue target output state)) cache := + permissiveRootAwarePublicActionWithPlan_eq_of_values_eq parameter input hvalues _ cache + _ = _ := by rw [hplan] + +theorem permissiveTargetFiberRel_preload_sameSelection + (target : Position) (candidate : Probe) (candidates : List Probe) + (state : LazyRevealProbe.State Coordinate) (output : HashOutput) : + PermissiveTargetFiberRel target + (some ⟨candidate, preloadPositionValue target output state, candidates⟩) + (some ⟨candidate, state, candidates⟩) := by + intro hleft + rw [permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?_eq_some_iff] at hleft ⊢ + obtain ⟨selected, hselected, hcandidate, hunrevealed⟩ := hleft + cases Option.some.inj hselected + exact ⟨⟨candidate, state, candidates⟩, rfl, hcandidate, by + simpa only [preloadPositionValue_revealed] using hunrevealed⟩ + +theorem relTriple_sample_preload_pureSelection_targetFiber + (target : Position) (candidate : Probe) (candidates : List Probe) + (state : LazyRevealProbe.State Coordinate) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + pure (some ⟨candidate, preloadPositionValue target output state, candidates⟩)) + (pure (some ⟨candidate, state, candidates⟩) : + ProbComp (Option PermissivePrivateOrdinalSelection)) + (PermissiveTargetFiberRel target) := by + rw [show (pure (some ⟨candidate, state, candidates⟩) : + ProbComp (Option PermissivePrivateOrdinalSelection)) = + (pure () >>= fun _ => pure (some ⟨candidate, state, candidates⟩)) by simp] + apply relTriple_bind + (relTriple_true LazyRevealProbe.sampleHashOutput (pure () : ProbComp Unit)) + intro output _ _ + exact relTriple_pure_pure + (permissiveTargetFiberRel_preload_sameSelection target candidate candidates state output) + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_sample_preload_permissiveDetailedRootAwareOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (hvalue : state.values (.position target) = none) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + candidates (preloadPositionValue target output state) fuel table cache) + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache) + (PermissiveTargetFiberRel target) := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + by_cases hrevealed : Coordinate.position target ∈ state.revealed + · exact relTriple_sample_preload_selector_targetFiber_of_initial_revealed ordinal + parameter root ftsSecret (pure value) candidates state fuel table cache target hrevealed + · simp only [permissiveDetailedRootAwareOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_sample_preload_pureSelection_targetFiber target + (candidates.get ⟨ordinal, hselected⟩) candidates state + · simp only [hselected, ↓reduceDIte] + apply relTriple_of_evalDist_eq_left + (OracleComp.DeferredSampling.evalDist_bind_const_neverFails + LazyRevealProbe.sampleHashOutput (by + simp [LazyRevealProbe.sampleHashOutput]) (pure none)) + exact relTriple_pure_pure (by simp [PermissiveTargetFiberRel]) + | query_bind query next ih => + by_cases hrevealed : Coordinate.position target ∈ state.revealed + · exact relTriple_sample_preload_selector_targetFiber_of_initial_revealed ordinal + parameter root ftsSecret (liftM (OracleSpec.query query) >>= next) candidates state fuel + table cache target hrevealed + · simp_rw [permissiveDetailedRootAwareOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_sample_preload_pureSelection_targetFiber target + (candidates.get ⟨ordinal, hselected⟩) candidates state + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let observe : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_sample_preload_runPermissive_finishDetailed target + ((splitUniformImpl n).run cache) state fuel table observe observe candidates + hvalue (splitUniformImpl_targetPeekFree target n cache) + · intro nextState remaining output nextCache hnextValue + simpa only [observe] using + ih output candidates nextState remaining nextCache hnextValue + · intro left right remaining output nextCache hstate + exact + relTriple_permissiveDetailedRootAwareOrdinalSelection_targetFiber_of_stateRel + ordinal parameter root ftsSecret (next output) candidates left right + remaining table nextCache target hstate + | inr input => + let nextCandidates := + permissiveRootAwareCandidates parameter input table state candidates + by_cases hnextSelected : ordinal < nextCandidates.length + · simp only [nextCandidates, hnextSelected, ↓reduceDIte] + rw [show (pure (some + ⟨(permissiveRootAwareCandidates parameter input table state candidates).get + ⟨ordinal, hnextSelected⟩, + state, + permissiveRootAwareCandidates parameter input table state candidates⟩) : + ProbComp (Option PermissivePrivateOrdinalSelection)) = + (pure () >>= fun _ => pure (some + ⟨(permissiveRootAwareCandidates parameter input table state candidates).get + ⟨ordinal, hnextSelected⟩, + state, + permissiveRootAwareCandidates parameter input table state candidates⟩)) by simp] + apply relTriple_bind + (relTriple_true LazyRevealProbe.sampleHashOutput (pure () : ProbComp Unit)) + intro output _ _ + rw [permissiveRootAwareCandidates_preload_hidden target output state hrevealed + parameter input table candidates] + have hnextSelected' : ordinal < + (permissiveRootAwareCandidates parameter input table state candidates).length := + hnextSelected + rw [dif_pos hnextSelected'] + exact relTriple_pure_pure + (permissiveTargetFiberRel_preload_sameSelection target + ((permissiveRootAwareCandidates parameter input table state candidates).get + ⟨ordinal, hnextSelected⟩) + (permissiveRootAwareCandidates parameter input table state candidates) + state output) + · simp_rw [permissiveRootAwareCandidates_preload_hidden target _ state hrevealed + parameter input table candidates] + simp only [nextCandidates, hnextSelected, ↓reduceDIte] + simp_rw [permissiveRootAwarePublicAction_preload_hidden target _ state hrevealed + parameter input table cache] + let observe : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + permissiveDetailedRootAwareOrdinalSelection ordinal parameter root + ftsSecret (next output) laterCandidates nextState remaining table nextCache + apply relTriple_sample_preload_runPermissive_finishDetailed target + (permissiveRootAwarePublicAction parameter input table state cache) + state fuel table observe observe nextCandidates hvalue + (permissiveRootAwarePublicAction_targetPeekFree target parameter input table + state cache) + · intro nextState remaining output nextCache hnextValue + simpa only [observe] using + ih output nextCandidates nextState remaining nextCache hnextValue + · intro left right remaining output nextCache hstate + exact + relTriple_permissiveDetailedRootAwareOrdinalSelection_targetFiber_of_stateRel + ordinal parameter root ftsSecret (next output) nextCandidates left right + remaining table nextCache target hstate + | inr message => + let observe : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_sample_preload_runPermissive_finishDetailed target + ((maskedSign parameter root ftsSecret message).run cache) state fuel table + observe observe candidates hvalue + (maskedSign_targetPeekFree target parameter root ftsSecret message cache) + · intro nextState remaining output nextCache hnextValue + simpa only [observe] using + ih output candidates nextState remaining nextCache hnextValue + · intro left right remaining output nextCache hstate + exact + relTriple_permissiveDetailedRootAwareOrdinalSelection_targetFiber_of_stateRel + ordinal parameter root ftsSecret (next output) candidates left right remaining + table nextCache target hstate + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonization.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonization.lean new file mode 100644 index 00000000..bcc72f53 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonization.lean @@ -0,0 +1,282 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonInitial + +/-! +# Commonizing resolved production fibers + +The resolved target-specific detailed selector is coupled to the single target-independent +detailed selector. The deferred target resolution becomes one preloaded sample, while its hidden +cache entry is removed through the ordinary-cache quotient. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +theorem probEvent_bind_le_bind_of_forall_le_of_invariant + {mx : ProbComp α} {left : α → ProbComp β} {right : α → ProbComp γ} + {leftEvent : β → Prop} {rightEvent : γ → Prop} (invariant : α → Prop) + (hinvariant : ∀ value ∈ support mx, invariant value) + (hstep : ∀ value, invariant value → + Pr[leftEvent | left value] ≤ Pr[rightEvent | right value]) : + Pr[leftEvent | mx >>= left] ≤ Pr[rightEvent | mx >>= right] := by + apply probEvent_bind_le_bind_of_forall_le + intro value hvalue + exact hstep value (hinvariant value hvalue) + +theorem materializedDeferredState_freshResolution_rel_preload + (state : LazyRevealProbe.State Coordinate) (target : Position) (output : HashOutput) + (hvalue : state.values (.position target) = none) (hpending : state.pending = ∅) : + PermissiveStateRel + (materializedDeferredState + { state := state.clearPending (.position target) + values := (directDeferredValues state).install target output }) + (preloadPositionValue target output state) := by + rcases state with ⟨pending, values, revealed, ensured⟩ + simp only at hvalue hpending + subst pending + constructor + · funext coordinate + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [materializedDeferredState, LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway, DeferredStructuralValues.install, + DeferredContext.positionValue, preloadPositionValue] + | position position => + by_cases heq : position = target + · subst position + simp [materializedDeferredState, LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway, + DeferredStructuralValues.install, DeferredContext.positionValue, + preloadPositionValue, hvalue] + · have hcoordinate : Coordinate.position position ≠ Coordinate.position target := by + simpa using heq + simp [materializedDeferredState, LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway, directDeferredValues, + DeferredStructuralValues.install, DeferredContext.positionValue, + preloadPositionValue, heq, hcoordinate] + cases values (Coordinate.position position) <;> rfl + · rfl + +set_option maxRecDepth 100000 in +theorem relTriple_resolvedInstalledPermissiveDetailedSelection_common_afterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hvalue : rootResult.state.values (.position target) = none) + (hpending : rootResult.state.pending = ∅) : + RelTriple + (resolvedInstalledPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) + (permissiveDetailedSelectionAfterRootResult ordinal adversary parameter ftsSecret rootResult) + (fun left right => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? left.2 = some target → + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? right = some target) := by + unfold resolvedInstalledPermissiveDetailedSelectionAfterRootResult + permissiveDetailedSelectionAfterRootResult + rw [resolveDeferredPositionValue_fresh target (directDeferredContext rootResult.state)] + · have hhit : ∀ output, ¬rootResult.state.hitAt (.position target) output := by + intro output + simp [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, hpending] + simp only [directDeferredContext, hhit, ↓reduceIte, bind_assoc, pure_bind] + let computation := + retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩ + let sampled := LazyRevealProbe.sampleHashOutput >>= fun output => + permissiveDetailedRootAwareOrdinalSelection ordinal parameter rootResult.value.1 ftsSecret + computation [] (preloadPositionValue target output rootResult.state) + rootResult.remaining rootResult.table rootResult.value.2 + have hperOutput (output : HashOutput) : + RelTriple + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter rootResult.value.1 + ftsSecret computation [] + (materializedDeferredState + { state := rootResult.state.clearPending (.position target) + values := (directDeferredValues rootResult.state).install target output }) + rootResult.remaining rootResult.table + (replaceHiddenRootCache target output rootResult.value.2) >>= fun selection => + pure (truncateHash output, selection)) + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter rootResult.value.1 + ftsSecret computation [] (preloadPositionValue target output rootResult.state) + rootResult.remaining rootResult.table rootResult.value.2) + (fun left right => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? left.2 = some target → + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? right = + some target) := by + let resolvedState := materializedDeferredState + { state := rootResult.state.clearPending (.position target) + values := (directDeferredValues rootResult.state).install target output } + have hcache := + relTriple_permissiveDetailedRootAwareOrdinalSelection_of_ordinaryCacheEq ordinal parameter + rootResult.value.1 ftsSecret computation [] resolvedState rootResult.remaining + rootResult.table (replaceHiddenRootCache target output rootResult.value.2) + rootResult.value.2 + (ordinaryQueryCache_replaceHiddenRootCache target output rootResult.value.2) + have hstate := + relTriple_permissiveDetailedRootAwareOrdinalSelection_targetFiber_of_stateRel ordinal + parameter rootResult.value.1 ftsSecret computation [] resolvedState + (preloadPositionValue target output rootResult.state) rootResult.remaining + rootResult.table rootResult.value.2 target + (materializedDeferredState_freshResolution_rel_preload rootResult.state target output + hvalue hpending) + have hglued := SphincsSecurity.relTriple_trans_exists hcache hstate + have hselection := relTriple_post_mono hglued (by + intro left right hrelation + obtain ⟨middle, hmiddle, hfiber⟩ := hrelation + subst middle + exact hfiber) + have hlift : RelTriple + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter rootResult.value.1 + ftsSecret computation [] resolvedState rootResult.remaining rootResult.table + (replaceHiddenRootCache target output rootResult.value.2) >>= fun selection => + pure (truncateHash output, selection)) + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter rootResult.value.1 + ftsSecret computation [] (preloadPositionValue target output rootResult.state) + rootResult.remaining rootResult.table rootResult.value.2 >>= fun selection => + pure selection) + (fun left right => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? left.2 = some target → + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? right = + some target) := by + apply relTriple_bind hselection + intro left right hrelation + exact relTriple_pure_pure hrelation + simpa only [bind_pure, resolvedState] using hlift + have hbridge : RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + permissiveDetailedRootAwareOrdinalSelection ordinal parameter rootResult.value.1 + ftsSecret computation [] + (materializedDeferredState + { state := rootResult.state.clearPending (.position target) + values := (directDeferredValues rootResult.state).install target output }) + rootResult.remaining rootResult.table + (replaceHiddenRootCache target output rootResult.value.2) >>= fun selection => + pure (truncateHash output, selection)) + sampled + (fun left right => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? left.2 = some target → + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? right = some target) := by + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + exact hperOutput leftOutput + have hsampling := + relTriple_sample_preload_permissiveDetailedRootAwareOrdinalSelection ordinal parameter + rootResult.value.1 ftsSecret computation [] rootResult.state rootResult.remaining + rootResult.table rootResult.value.2 target hvalue + have hglued := SphincsSecurity.relTriple_trans_exists hbridge hsampling + apply relTriple_post_mono hglued + intro left right hrelation hleft + obtain ⟨middle, hfirst, hsecond⟩ := hrelation + exact hsecond (hfirst hleft) + · simpa [directDeferredContext] using hvalue + · simpa [directDeferredContext, directDeferredValues] using hvalue + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_resolvedInstalledPermissiveDetailedSelectionExperiment_fiber_le_common + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + Pr[fun result => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? result.2 = some target | + resolvedInstalledPermissiveDetailedSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret target fuel table] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret fuel + table] := by + unfold resolvedInstalledPermissiveDetailedSelectionExperimentAfterTable + permissiveDetailedSelectionExperimentAfterTable + apply probEvent_bind_le_bind_of_forall_le_of_invariant + (invariant := InitialRootOptionFacts target) + · exact initialRootOptionFacts_of_mem target hroot hparent fuel table + · intro rootResult hinitial + cases rootResult with + | none => + simp [permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?] + | some rootResult => + have hrel : RelTriple + (resolvedInstalledPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) + (permissiveDetailedSelectionAfterRootResult ordinal adversary parameter ftsSecret + rootResult) + (fun left right => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? left.2 = some target → + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? right = some target) := + relTriple_resolvedInstalledPermissiveDetailedSelection_common_afterRootResult ordinal + adversary parameter ftsSecret target rootResult hinitial.1 hinitial.2.2 + apply probEvent_le_of_relTriple + (p := fun result => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? result.2 = some target) + (q := fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target) + hrel + intro left right hrelation hleft + exact hrelation hleft + +set_option maxRecDepth 100000 in +theorem probEvent_materializedRootAwareProduction_le_commonDetailedFiber + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret fuel + table] := by + calc + _ ≤ Pr[fun result => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? result.2 = some target | + resolvedInstalledPermissiveDetailedSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret target fuel table] := + probEvent_materializedRootAwareProduction_le_resolvedPermissiveDetailed ordinal adversary + parameter ftsSecret target hroot hparent fuel table + _ ≤ _ := + probEvent_resolvedInstalledPermissiveDetailedSelectionExperiment_fiber_le_common ordinal + adversary parameter ftsSecret target hroot hparent fuel table + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_successfulDoomedFirstRootFiber_le_commonDetailedFiber + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (hordinal : ordinal < q) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[fun observed => + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret + (2 * q) table] * + (2 * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + calc + _ ≤ Pr[fun result => materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target (2 * q) table] * + (2 * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := + probEvent_successfulDoomedFirstRootFiber_le_two_mul_production ordinal adversary parameter + table ftsSecret q target hroot hparent hordinal hfuel hbound hq + _ ≤ _ := by + gcongr + exact probEvent_materializedRootAwareProduction_le_commonDetailedFiber ordinal adversary + parameter ftsSecret target hroot hparent (2 * q) table + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionNormalize.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionNormalize.lean new file mode 100644 index 00000000..fb0dac56 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionNormalize.lean @@ -0,0 +1,141 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProduction + +/-! +# Common production normalization + +The target-specific production experiment first samples the selected structural output as its +low digest and independent high bits. This module rewrites that eager draw as the ordinary deferred +resolution of the selected position. The remaining normalization can therefore commute one +`resolveDeferredPositionValue` through the target-independent selector. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def resolvedInstalledPermissiveRootAwareSelectionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp (Digest × Option Probe) := do + let resolved ← resolveDeferredPositionValue target + (directDeferredContext rootResult.state) + match resolved with + | none => pure (0, none) + | some resolved => + let selection ← permissiveRootAwareOrdinalSelection ordinal parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState resolved.toDeferredContext) rootResult.remaining + rootResult.table + (replaceHiddenRootCache target resolved.output rootResult.value.2) + pure (truncateHash resolved.output, selection) + +set_option maxRecDepth 100000 in +theorem evalDist_sampledHighInstalledPermissive_eq_resolved + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hstate : rootResult.state.values (.position target) = none) + (hpending : rootResult.state.pending = ∅) : + evalDist + (sampledHighInstalledPermissiveRootAwareSelectionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult) = + evalDist + (resolvedInstalledPermissiveRootAwareSelectionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult) := by + unfold resolvedInstalledPermissiveRootAwareSelectionAfterRootResult + rw [resolveDeferredPositionValue_fresh target (directDeferredContext rootResult.state)] + · have hhit : ∀ output, ¬rootResult.state.hitAt (.position target) output := by + intro output + simp [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, hpending] + simp only [directDeferredContext, hhit, ↓reduceIte] + have hclear : rootResult.state.clearPending (.position target) = rootResult.state := by + rcases hrootState : rootResult.state with ⟨pending, values, revealed, ensured⟩ + simp only [LazyRevealProbe.State.clearPending] + have hp : pending = ∅ := by simpa only [hrootState] using hpending + simp [LazyRevealProbe.State.pendingAway, hp] + rw [hclear] + unfold sampledHighInstalledPermissiveRootAwareSelectionAfterRootResult rootInstalledCache + let parts : ProbComp HashOutput := do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let root ← ($ᵗ Digest : ProbComp Digest) + pure (rootOutputOfParts root high) + have hparts : evalDist parts = evalDist LazyRevealProbe.sampleHashOutput := by + calc + _ = evalDist (do + let root ← ($ᵗ Digest : ProbComp Digest) + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + pure (rootOutputOfParts root high)) := by + exact OracleComp.DeferredSampling.evalDist_bind_comm + ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + ($ᵗ Digest : ProbComp Digest) + (fun high root => pure (rootOutputOfParts root high)) + _ = _ := evalDist_sample_rootOutputOfParts + let continuation := fun output : HashOutput => do + let selection ← permissiveRootAwareOrdinalSelection ordinal parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState + { state := rootResult.state + values := (directDeferredValues rootResult.state).install target output }) + rootResult.remaining rootResult.table + (replaceHiddenRootCache target output rootResult.value.2) + pure (truncateHash output, selection) + calc + _ = evalDist (parts >>= continuation) := by + simp [parts, continuation, directDeferredContext, bind_assoc] + _ = evalDist (LazyRevealProbe.sampleHashOutput >>= continuation) := by + exact evalDist_bind_eq_of_evalDist_eq hparts continuation + _ = _ := by rfl + · simpa [directDeferredContext] using hstate + · simpa [directDeferredContext, directDeferredValues] using hstate + +theorem evalDist_sampledHighInstalledPermissive_eq_resolved_afterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache))) : + evalDist + (sampledHighInstalledPermissiveRootAwareSelectionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult) = + evalDist + (resolvedInstalledPermissiveRootAwareSelectionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult) := by + have habsent := target_absent_of_mem_runCleanFromTable_maskedPublishedTreeRoot target hroot + hparent fuel table rootResult hresult + have hpending := pending_eq_empty_of_mem_runCleanFromTable_maskedPublishedTreeRoot fuel table + rootResult hresult + exact evalDist_sampledHighInstalledPermissive_eq_resolved ordinal adversary parameter ftsSecret + target rootResult habsent.1 hpending + +theorem probEvent_sampledHighInstalledPermissive_eq_resolved_afterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache))) : + Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + sampledHighInstalledPermissiveRootAwareSelectionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult] = + Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + resolvedInstalledPermissiveRootAwareSelectionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult] := by + apply OracleComp.probEvent_congr' (fun _ _ ↦ Iff.rfl) + exact evalDist_sampledHighInstalledPermissive_eq_resolved_afterRootResult ordinal adversary + parameter ftsSecret target hroot hparent fuel table rootResult hresult + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionNormalizeLift.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionNormalizeLift.lean new file mode 100644 index 00000000..1b1a8e3a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionNormalizeLift.lean @@ -0,0 +1,147 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionNormalize + +/-! +# Common production normalization through the public root + +The local sampler normalization is lifted through the probe-free public-root computation. This +gives one target-specific resolved experiment whose only remaining target dependence is the single +deferred position resolution. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def sampledHighInstalledPermissiveRootAwareSelectionExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (Digest × Option Probe) := do + let rootResult ← runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure (0, none) + | some result => + sampledHighInstalledPermissiveRootAwareSelectionAfterRootResult ordinal adversary parameter + ftsSecret target result + +noncomputable def resolvedInstalledPermissiveRootAwareSelectionExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (Digest × Option Probe) := do + let rootResult ← runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure (0, none) + | some result => + resolvedInstalledPermissiveRootAwareSelectionAfterRootResult ordinal adversary parameter + ftsSecret target result + +set_option maxRecDepth 100000 in +theorem evalDist_sampledHighInstalledPermissiveExperiment_eq_resolved + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + evalDist + (sampledHighInstalledPermissiveRootAwareSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret target fuel table) = + evalDist + (resolvedInstalledPermissiveRootAwareSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret target fuel table) := by + unfold sampledHighInstalledPermissiveRootAwareSelectionExperimentAfterTable + resolvedInstalledPermissiveRootAwareSelectionExperimentAfterTable + apply evalDist_bind_congr + intro rootResult hresult + cases rootResult with + | none => rfl + | some rootResult => + exact evalDist_sampledHighInstalledPermissive_eq_resolved_afterRootResult ordinal adversary + parameter ftsSecret target hroot hparent fuel table rootResult hresult + +theorem probEvent_sampledHighInstalledPermissiveExperiment_eq_resolved + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + sampledHighInstalledPermissiveRootAwareSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret target fuel table] = + Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + resolvedInstalledPermissiveRootAwareSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret target fuel table] := by + apply OracleComp.probEvent_congr' (fun _ _ ↦ Iff.rfl) + exact evalDist_sampledHighInstalledPermissiveExperiment_eq_resolved ordinal adversary parameter + ftsSecret target hroot hparent fuel table + +theorem probEvent_materializedRootAwareProduction_le_resolvedPermissive + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] ≤ + Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + resolvedInstalledPermissiveRootAwareSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret target fuel table] := by + calc + _ ≤ Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + sampledHighInstalledPermissiveRootAwareSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret target fuel table] := by + unfold materializedRootAwareOrdinalProductionExperimentAfterTable + sampledHighInstalledPermissiveRootAwareSelectionExperimentAfterTable + apply probEvent_bind_le_bind_of_forall_le + intro rootResult hresult + cases rootResult with + | none => simp [materializedOrdinalSelectionAt] + | some rootResult => + exact probEvent_materializedRootAwareProduction_le_installedPermissive ordinal adversary + parameter ftsSecret target rootResult + _ = _ := probEvent_sampledHighInstalledPermissiveExperiment_eq_resolved ordinal adversary + parameter ftsSecret target hroot hparent fuel table + +theorem probEvent_successfulDoomedFirstRootFiber_le_two_mul_resolvedPermissive + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (hordinal : ordinal < q) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[fun observed => + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + resolvedInstalledPermissiveRootAwareSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret target (2 * q) table] * + (2 * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + calc + _ ≤ Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target (2 * q) table] * + (2 * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := + probEvent_successfulDoomedFirstRootFiber_le_two_mul_production ordinal adversary parameter + table ftsSecret q target hroot hparent hordinal hfuel hbound hq + _ ≤ _ := by + gcongr + exact probEvent_materializedRootAwareProduction_le_resolvedPermissive ordinal adversary + parameter ftsSecret target hroot hparent (2 * q) table + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionOrdinal.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionOrdinal.lean new file mode 100644 index 00000000..dfd9a535 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionOrdinal.lean @@ -0,0 +1,242 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionAggregation + +/-! +# Summing root and non-root production ordinals + +The first hidden hit is charged only at an ordinal below the source query budget. A layer-root hit +costs two digest guesses and every other structural hit costs one. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option linter.constructorNameAsVariable false + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_firstHit_eq_zero_of_q_le_ordinal + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) + (hordinal : q ≤ ordinal) : + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] = 0 := by + apply le_antisymm + · calc + _ ≤ Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenHitAt ordinal | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) + table] := + probEvent_sampledDiagnostic_successfulDoomed_firstExistingHiddenHitAt_le_raw adversary + parameter ftsSecret (2 * q) ordinal + _ ≤ Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := + probEvent_sampledSuccessfulFirstHit_le_selectedSnapshot adversary parameter ftsSecret q + ordinal hexpanded hq + _ = 0 := probEvent_selectedPrivateSnapshotHitAt_eq_zero_of_q_le_ordinal adversary + parameter ftsSecret q ordinal hexpanded hordinal + · exact zero_le + +theorem ObservedMaterializedDiagnostic.firstExistingHiddenHitAt_of_root + {outcome : ObservedMaterializedDiagnostic α} {ordinal : Nat} + (hroot : outcome.FirstExistingHiddenRootHitAt ordinal) : + outcome.FirstExistingHiddenHitAt ordinal := by + obtain ⟨result, _selected, hbefore, _hordinal, hfirst, _hroot⟩ := hroot + exact ⟨result, hbefore, hfirst⟩ + +theorem ObservedMaterializedDiagnostic.firstExistingHiddenHitAt_of_nonRoot + {outcome : ObservedMaterializedDiagnostic α} {ordinal : Nat} + (hnonRoot : outcome.FirstExistingHiddenNonRootHitAt ordinal) : + outcome.FirstExistingHiddenHitAt ordinal := by + obtain ⟨result, _selected, hbefore, _hordinal, hfirst, _hnonRoot⟩ := hnonRoot + exact ⟨result, hbefore, hfirst⟩ + +set_option maxHeartbeats 2000000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_firstRoot_eq_zero_of_q_le_ordinal + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) + (hordinal : q ≤ ordinal) : + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] = 0 := by + apply le_antisymm + · calc + _ ≤ Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] := by + apply probEvent_mono + intro outcome _houtcome hevent + exact ⟨hevent.1, outcome.firstExistingHiddenHitAt_of_root hevent.2⟩ + _ = 0 := + probEvent_sampledDiagnostic_successfulDoomed_firstHit_eq_zero_of_q_le_ordinal + adversary parameter ftsSecret q ordinal hexpanded hq hordinal + · exact zero_le + +set_option maxHeartbeats 2000000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_firstNonRoot_eq_zero_of_q_le_ordinal + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) + (hordinal : q ≤ ordinal) : + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] = 0 := by + apply le_antisymm + · calc + _ ≤ Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] := by + apply probEvent_mono + intro outcome _houtcome hevent + exact ⟨hevent.1, outcome.firstExistingHiddenHitAt_of_nonRoot hevent.2⟩ + _ = 0 := + probEvent_sampledDiagnostic_successfulDoomed_firstHit_eq_zero_of_q_le_ordinal + adversary parameter ftsSecret q ordinal hexpanded hq hordinal + · exact zero_le + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_le_three_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hfuel : 2 * q < Fintype.card Digest) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + ((3 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + classical + let diagnostic := + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q) + let epsilon := ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + calc + _ ≤ ∑ ordinal : Fin (2 * q), + (Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal.val | diagnostic] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal.val | diagnostic]) := + probEvent_sampledDiagnostic_successfulDoomed_le_sum_successfulFirstOrdinals adversary + parameter ftsSecret q hq + _ ≤ ∑ _ordinal : Fin q, 3 * epsilon := by + simp only [Finset.sum_fin_eq_sum_range] + rw [show 2 * q = q + q by omega, Finset.sum_range_add] + have hfirst : + (∑ ordinal ∈ Finset.range q, if h : ordinal < q + q then + (Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal | diagnostic] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal | diagnostic]) + else 0) ≤ + ∑ _ordinal ∈ Finset.range q, 3 * epsilon := by + apply Finset.sum_le_sum + intro ordinal hordinalMem + have hordinal : ordinal < q := Finset.mem_range.1 hordinalMem + have hordinal' : ordinal < q + q := hordinal.trans_le (Nat.le_add_right q q) + simp only [hordinal', ↓reduceDIte] + calc + _ ≤ 2 * epsilon + epsilon := add_le_add + (probEvent_sampledDiagnostic_successfulDoomed_firstRoot_le ordinal adversary + parameter ftsSecret q hordinal hfuel hexpanded hq) + (probEvent_sampledDiagnostic_successfulDoomed_firstNonRoot_le adversary parameter + ftsSecret q ordinal hexpanded hq) + _ = 3 * epsilon := by ring + have hzero : + (∑ ordinal ∈ Finset.range q, if h : q + ordinal < q + q then + (Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt (q + ordinal) | diagnostic] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt (q + ordinal) | diagnostic]) + else 0) = 0 := by + apply Finset.sum_eq_zero + intro ordinal hordinalMem + have hordinal : ordinal < q := Finset.mem_range.1 hordinalMem + simp only [show q + ordinal < q + q by omega, ↓reduceDIte] + rw [probEvent_sampledDiagnostic_successfulDoomed_firstRoot_eq_zero_of_q_le_ordinal + adversary parameter ftsSecret q (q + ordinal) hexpanded hq (by omega)] + rw [probEvent_sampledDiagnostic_successfulDoomed_firstNonRoot_eq_zero_of_q_le_ordinal + adversary parameter ftsSecret q (q + ordinal) hexpanded hq (by omega)] + simp + calc + _ ≤ (∑ _ordinal ∈ Finset.range q, 3 * epsilon) + + (∑ ordinal ∈ Finset.range q, if h : q + ordinal < q + q then + (Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt (q + ordinal) | diagnostic] + + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt (q + ordinal) | diagnostic]) + else 0) := add_le_add hfirst le_rfl + _ = ∑ _ordinal ∈ Finset.range q, 3 * epsilon := by rw [hzero, add_zero] + _ = ∑ ordinal ∈ Finset.range q, if h : ordinal < q then 3 * epsilon else 0 := by + apply Finset.sum_congr rfl + intro ordinal hordinalMem + simp [Finset.mem_range.1 hordinalMem] + _ = (q : ENNReal) * (3 * epsilon) := by simp + _ = _ := by + simp only [epsilon] + push_cast + ring + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnostic_bad_le_five_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hfuel : 2 * q < Fintype.card Digest) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[ObservedMaterializedDiagnostic.Bad | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + ((5 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let diagnostic := + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q) + calc + _ ≤ Pr[fun outcome => outcome.final = none | diagnostic] + + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | diagnostic] := + probEvent_diagnosticBad_le_finalNone_add_successfulDoomed diagnostic + _ ≤ ((2 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + ((3 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply add_le_add + · exact probEvent_sampledObservedMaterializedDiagnostic_final_none_le adversary parameter + ftsSecret (2 * q) q hexpanded (by omega) + · exact probEvent_sampledDiagnostic_successfulDoomed_le_three_mul adversary parameter + ftsSecret q hfuel hexpanded hq + _ = _ := by + push_cast + ring + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveReverse.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveReverse.lean new file mode 100644 index 00000000..22b2ab6e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveReverse.lean @@ -0,0 +1,3051 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveRootAwarePrivateStrong + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +namespace ScratchLocal + +theorem relTriple_of_not_true_mem_support + (left right : ProbComp Bool) (hfalse : true ∉ support left) : + RelTriple left right BoolImp := by + have hbase := relTriple_true left right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun value ↦ value ∈ support left) (fun _ hvalue ↦ hvalue) + apply relTriple_post_mono hsupported + intro leftValue _rightValue hrelation htrue + exact (hfalse (by simpa [htrue] using hrelation.2)).elim + +set_option maxRecDepth 100000 in +theorem finalizationMaterializedCouples_maskedSignAfterDigest_scratch + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + FinalizationMaterializedCouples table + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest + apply (finalizationMaterializedCouples_simulateQ ordinaryHashImpl + (finalizationMaterializedCouples_ordinaryHashImpl table) + (ftsOpen parameter index leaves (ftsSecret index))).bind + intro ftsPath + apply (finalizationMaterializedCouples_sequenceFin + (fun lay : Layer ↦ maskedSignLayer parameter ftsSecret index lay) + (fun lay ↦ finalizationMaterializedCouples_maskedSignLayer table parameter ftsSecret + index lay)).bind + intro layers + cases hparts : traverseOption layers with + | none => exact finalizationMaterializedCouples_pure table none + | some parts => + apply (finalizationMaterializedCouples_sequenceFin + (fun lay : Layer ↦ revealLayerValues index lay (parts lay).2) + (fun lay ↦ finalizationMaterializedCouples_revealLayerValues table index lay + (parts lay).2)).bind + intro revealed + let signature : Signature := + { randomness := randomness + ftsSecret := fun tree ↦ ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay ↦ (parts lay).1 + chainValue := fun lay ↦ (revealed lay).1 + authPath := flattenPaths fun lay ↦ (revealed lay).2 } + exact finalizationMaterializedCouples_pure table (some signature) + +set_option maxRecDepth 100000 in +theorem finalizationMaterializedCouples_maskedSign_scratch + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + FinalizationMaterializedCouples table + (maskedSign parameter root ftsSecret message) := by + unfold maskedSign + apply (finalizationMaterializedCouples_simulateQ ordinaryRomImpl + (finalizationMaterializedCouples_ordinaryRomImpl table) + (signDigestLoop digestAttemptLimit + ⟨parameter, root, fun _ _ _ _ ↦ 0, ftsSecret⟩ message)).bind + intro selected + cases selected with + | none => exact finalizationMaterializedCouples_pure table none + | some data => + exact finalizationMaterializedCouples_maskedSignAfterDigest_scratch table parameter ftsSecret + data.1 data.2.1 data.2.2 + +theorem finalizationContextEq_materializedDeferredContext_scratch + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + FinalizationContextEq table (some context) + (some (materializedDeferredContext context)) := by + have hle := finalizationContextLE_materializedDeferredContext hvalid hcompletable + refine ⟨{ + leftConsistent := hle.view.leftConsistent + rightConsistent := hle.view.rightConsistent + leftStarts := hle.view.leftStarts + rightStarts := hle.view.rightStarts + valueEq := hle.view.valueEq + leftClean := hle.view.leftClean + rightClean := hle.view.rightClean + pendingEq := ?_ }, hvalid, hle.rightValid, hcompletable⟩ + intro coordinate _hnone + rfl + +theorem materializedDeferredState_canonicalize_direct_eq_scratch + (table : OtsSecretIndex → HashOutput) + (state : LazyRevealProbe.State Coordinate) + (hstarts : StartTableAgrees state table) + (hchainValid : ChainState.ValidFor (fun _ ↦ True) state) : + materializedDeferredState + (canonicalizeMaterializedValues table (directDeferredContext state)) = state := by + cases state with + | mk pending values revealed ensured => + simp only [materializedDeferredState, canonicalizeMaterializedValues, + directDeferredContext] + congr + funext coordinate + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + by_cases hrevealed : Coordinate.chainStart lay tree leafIdx chainIdx ∈ revealed + · have hvalue := (hchainValid (.chainStart lay tree leafIdx chainIdx) + (by simp [IsChainCoordinate])).2.1 hrevealed + obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hvalue + have htable := hstarts ⟨lay, tree, leafIdx, chainIdx⟩ output houtput + simp only [publicMaterializedValues, hrevealed, ↓reduceIte, + resolvedCompletionValue] + have houtput' : values (.chainStart lay tree leafIdx chainIdx) = some output := by + simpa using houtput + exact (congrArg some htable).symm.trans houtput'.symm + · have hvalue : values (.chainStart lay tree leafIdx chainIdx) = none := by + by_contra hne + exact hrevealed ((hchainValid (.chainStart lay tree leafIdx chainIdx) + (by simp [IsChainCoordinate])).1 hne) + simp [publicMaterializedValues, hrevealed, hvalue] + | position position => + by_cases hrevealed : Coordinate.position position ∈ revealed + · simp only [publicMaterializedValues, hrevealed, ↓reduceIte, + resolvedCompletionValue, DeferredContext.positionValue, directDeferredValues] + cases values (.position position) <;> simp + · simp only [publicMaterializedValues, hrevealed, ↓reduceIte, + DeferredContext.positionValue, directDeferredValues] + +theorem materializedDeferredState_canonicalize_direct_eq_of_chainStarts + (table : OtsSecretIndex → HashOutput) + (state : LazyRevealProbe.State Coordinate) + (hstarts : StartTableAgrees state table) + (hchainStarts : ∀ lay tree leafIdx chainIdx, + (state.values (.chainStart lay tree leafIdx chainIdx) ≠ none → + .chainStart lay tree leafIdx chainIdx ∈ state.revealed) ∧ + (.chainStart lay tree leafIdx chainIdx ∈ state.revealed → + state.values (.chainStart lay tree leafIdx chainIdx) ≠ none)) : + materializedDeferredState + (canonicalizeMaterializedValues table (directDeferredContext state)) = state := by + cases state with + | mk pending values revealed ensured => + simp only [materializedDeferredState, canonicalizeMaterializedValues, + directDeferredContext] + congr + funext coordinate + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + by_cases hrevealed : Coordinate.chainStart lay tree leafIdx chainIdx ∈ revealed + · have hvalue := (hchainStarts lay tree leafIdx chainIdx).2 hrevealed + obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hvalue + have htable := hstarts ⟨lay, tree, leafIdx, chainIdx⟩ output houtput + simp only [publicMaterializedValues, hrevealed, ↓reduceIte, + resolvedCompletionValue] + have houtput' : values (.chainStart lay tree leafIdx chainIdx) = some output := by + simpa using houtput + exact (congrArg some htable).symm.trans houtput'.symm + · have hvalue : values (.chainStart lay tree leafIdx chainIdx) = none := by + by_contra hne + exact hrevealed ((hchainStarts lay tree leafIdx chainIdx).1 hne) + simp [publicMaterializedValues, hrevealed, hvalue] + | position position => + by_cases hrevealed : Coordinate.position position ∈ revealed + · simp only [publicMaterializedValues, hrevealed, ↓reduceIte, + resolvedCompletionValue, DeferredContext.positionValue, directDeferredValues] + cases values (.position position) <;> simp + · simp only [publicMaterializedValues, hrevealed, ↓reduceIte, + DeferredContext.positionValue, directDeferredValues] + +theorem materializedDeferredState_canonicalize_eq + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hstarts : StartTableAgrees context.state table) + (hchainValid : ChainState.ValidFor (fun _ ↦ True) context.state) + (hconsistent : context.ValuesConsistent) : + materializedDeferredState (canonicalizeMaterializedValues table context) = + materializedDeferredState context := by + cases hstate : context.state with + | mk pending values revealed ensured => + simp only [materializedDeferredState, canonicalizeMaterializedValues, hstate] + congr + funext coordinate + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + have hvalue := canonicalizeMaterializedValues_chain_value table context hstarts + hchainValid (.chainStart lay tree leafIdx chainIdx) (by simp [IsChainCoordinate]) + unfold canonicalizeMaterializedValues at hvalue + rw [hstate] at hvalue + exact hvalue + | position position => + have hvalue := canonicalizeMaterializedValues_positionValue table context hconsistent + position + unfold canonicalizeMaterializedValues at hvalue + rw [hstate] at hvalue + exact hvalue + +theorem evalDist_negatedCanonicalizeDirectDelayedObserve_eq_of_finalizationContextEq_published_scratch + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (fuel : Nat) (value : α) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hrevealed : left.state.revealed = right.state.revealed) + (hleftPublished : PublishedValues left.state) + (hrightPublished : PublishedValues right.state) + [ObserverSynchronized table + (negatedDirectDelayedObserve observe snapshots observations)] : + evalDist + (negatedDirectDelayedObserve + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations left fuel value) = + evalDist + (negatedDirectDelayedObserve + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + snapshots observations right fuel value) := by + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hrightCompletable : DeferredCompletable table right := by + obtain ⟨completion, hcompletion⟩ := hleftCompletable + exact ⟨completion, (hview.deferredCompletion_iff completion).mp hcompletion⟩ + have hleftCanonical := valid_completable_canonicalizeMaterializedValues table left + hleftValid hleftCompletable + have hrightCanonical := valid_completable_canonicalizeMaterializedValues table right + hrightValid hrightCompletable + have hleftNoHit : ¬PrivateStructuralHit (canonicalizeMaterializedValues table left) := + not_privateStructuralHit_of_deferredCompletable hleftCanonical.2 + have hrightNoHit : ¬PrivateStructuralHit (canonicalizeMaterializedValues table right) := + not_privateStructuralHit_of_deferredCompletable hrightCanonical.2 + unfold negatedDirectDelayedObserve canonicalizeDirectDelayedSelectedRootIndicator + simp only [hleftNoHit, hrightNoHit, hleftPublished, hrightPublished, + hleftCanonical.2, hrightCanonical.2, ↓reduceIte] + have hcanonical := canonicalizedFinalizationContextEq + (⟨hview, hleftValid, hrightValid, hleftCompletable⟩ : + FinalizationContextEq table (some left) (some right)) hrevealed + exact ObserverSynchronized.eq_of_synchronized + (table := table) + (observe := negatedDirectDelayedObserve observe snapshots observations) + (canonicalizeMaterializedValues table left) + (canonicalizeMaterializedValues table right) fuel value hcanonical.1 hcanonical.2 hrevealed + +theorem relTriple_finishObserve_reverse_of_finalizationMaterialized_scratch + (table : OtsSecretIndex → HashOutput) + (leftRun rightRun : ProbComp + (Option (ResolvedRunResult (α × SplitHashCache)))) + (leftObserve rightObserve : DeferredContext → Nat → + (α × SplitHashCache) → ProbComp Bool) + (hstep : RelTriple leftRun rightRun (FinalizationMaterializedRunEq table)) + (hrecursive : ∀ left right, + FinalizationMaterializedRunEq table (some left) (some right) → + RelTriple + (rightObserve right.context right.remaining right.value) + (leftObserve left.context left.remaining left.value) + BoolImp) : + RelTriple + (rightRun >>= finishObserve rightObserve) + (leftRun >>= finishObserve leftObserve) + BoolImp := by + apply relTriple_bind (relTriple_symm hstep) + intro right left hrelation + cases right with + | none => + cases left with + | none => exact relTriple_pure_pure (by simp [BoolImp]) + | some left => simp [FinalizationMaterializedRunEq] at hrelation + | some right => + cases left with + | none => simp [FinalizationMaterializedRunEq] at hrelation + | some left => exact hrecursive left right hrelation + +set_option maxRecDepth 100000 in +theorem evalDist_complement_observed_probeFree_eq_runDirectResolvedObserve_scratch + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (continuation : LazyRevealProbe.State Coordinate → Nat → α → ProbComp Bool) + (hprobeFree : computation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) : + evalDist (Bool.not <$> (runObservedCleanFromTable observations state fuel table computation >>= + fun result ↦ match result with + | none => pure false + | some result => continuation result.state result.remaining result.value)) = + evalDist (runDirectResolvedObserve + (fun context remaining value ↦ + Bool.not <$> continuation context.state remaining value) + (directDeferredContext state) fuel table computation) := by + rw [map_bind] + have hobserved := map_attachCleanProbeObservations_runCleanFromTable_of_probeFree computation + observations state fuel table hprobeFree + rw [← hobserved, map_eq_bind_pure_comp, bind_assoc] + have hclean := map_projectResolvedRunResult_runDirect_eq_runClean computation state fuel table + rw [← hclean, map_eq_bind_pure_comp, bind_assoc] + unfold runDirectResolvedObserve + apply evalDist_bind_congr + intro result _hresult + cases result <;> rfl + +def DeferredStructuralValuesLE + (left right : DeferredStructuralValues) : Prop := + ∀ position output, left position = some output → right position = some output + +theorem DeferredStructuralValuesLE.refl (values : DeferredStructuralValues) : + DeferredStructuralValuesLE values values := by + intro position output hvalue + exact hvalue + +theorem DeferredStructuralValuesLE.trans + {left middle right : DeferredStructuralValues} + (hleft : DeferredStructuralValuesLE left middle) + (hright : DeferredStructuralValuesLE middle right) : + DeferredStructuralValuesLE left right := by + intro position output hvalue + exact hright position output (hleft position output hvalue) + +theorem DeferredStructuralValuesLE.install_of_none + {values : DeferredStructuralValues} {position : Position} {installed : HashOutput} + (hmissing : values position = none) : + DeferredStructuralValuesLE values (values.install position installed) := by + intro other output hvalue + have hne : other ≠ position := by + intro heq + subst other + rw [hmissing] at hvalue + contradiction + simpa [DeferredStructuralValues.install, hne] using hvalue + +def DirectWitnessFinalizationMaterializedRunEq + (table : OtsSecretIndex → HashOutput) (initialValues : DeferredStructuralValues) + (leftInitialFuel rightInitialFuel : Nat) : + DirectWitnessResult (α × SplitHashCache) → + DirectDetailedResult (α × SplitHashCache) → Prop + | .done left, .done right => + left.value.1 = right.value.1 ∧ + FinalizationContextEq table (some left.context) (some right.context) ∧ + left.remaining = leftInitialFuel ∧ right.remaining = rightInitialFuel ∧ + left.table = table ∧ right.table = table ∧ + left.value.2 = right.value.2 ∧ + left.context.state.revealed = right.context.state.revealed ∧ + (materializedDeferredState left.context).values = right.context.state.values ∧ + DeferredStructuralValuesLE initialValues left.context.values ∧ + right.context = directDeferredContext right.context.state + | .done _, .stopped _ => False + | _, _ => True + +def DirectWitnessFinalizationMaterializedCouples + (table : OtsSecretIndex → HashOutput) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ left right leftFuel rightFuel leftCache rightCache, + FinalizationContextEq table (some left) (some right) → + leftCache = rightCache → + left.state.revealed = right.state.revealed → + (materializedDeferredState left).values = right.state.values → + right = directDeferredContext right.state → + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table (computation.run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table (computation.run rightCache)) + (DirectWitnessFinalizationMaterializedRunEq table left.values leftFuel rightFuel) + +theorem materializedDeferredState_ensure + (context : DeferredContext) (coordinate : Coordinate) : + materializedDeferredState + { context with state := context.state.ensure coordinate } = + (materializedDeferredState context).ensure coordinate := by + rcases context with ⟨state, values⟩ + rcases state with ⟨pending, stateValues, revealed, ensured⟩ + simp [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.ensure] + +theorem materializedDeferredState_publish + (context : DeferredContext) (coordinate : Coordinate) : + materializedDeferredState + { context with state := context.state.publish coordinate } = + (materializedDeferredState context).publish coordinate := by + rcases context with ⟨state, values⟩ + rcases state with ⟨pending, stateValues, revealed, ensured⟩ + simp [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.publish] + +@[simp] theorem materializedDeferredState_directDeferredContext + (state : LazyRevealProbe.State Coordinate) : + materializedDeferredState (directDeferredContext state) = state := by + rcases state with ⟨pending, values, revealed, ensured⟩ + simp only [materializedDeferredState, directDeferredContext, + directDeferredValues, DeferredContext.positionValue] + congr + funext coordinate + cases coordinate with + | chainStart => rfl + | position position => + change (match values (.position position) with + | some output => some output + | none => values (.position position)) = values (.position position) + cases values (.position position) <;> rfl + +theorem materializedDeferredState_values_materialize_position_of_private + (context : DeferredContext) (position : Position) (output : HashOutput) + (hconsistent : context.ValuesConsistent) + (hprivate : context.values position = some output) : + (materializedDeferredState + { context with state := context.state.materialize (.position position) output }).values = + (materializedDeferredState context).values := by + funext coordinate + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [materializedDeferredState, LazyRevealProbe.State.materialize, + Function.update_of_ne] + | position other => + by_cases heq : other = position + · subst other + cases hvalue : context.state.values (.position position) with + | none => + simp [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, hprivate, hvalue] + | some cached => + have hcached := hconsistent position cached hvalue + rw [hprivate] at hcached + have hsame : output = cached := Option.some.inj hcached + subst cached + simp [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, hprivate, hvalue] + · simp [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by simpa using heq, + heq] + +theorem materializedDeferredState_values_materialize_position_install + (context : DeferredContext) (position : Position) (output : HashOutput) : + (materializedDeferredState + { state := context.state.materialize (.position position) output + values := context.values.install position output }).values = + Function.update (materializedDeferredState context).values + (.position position) (some output) := by + funext coordinate + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [materializedDeferredState, LazyRevealProbe.State.materialize, + Function.update_of_ne] + | position other => + by_cases heq : other = position + · subst other + simp [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, DeferredStructuralValues.install] + · simp [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by simpa using heq, + DeferredStructuralValues.install, heq] + +theorem materializedDeferredState_values_materialize_chainStart + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (index : OtsSecretIndex) : + (materializedDeferredState + { context with state := context.state.materialize index.coordinate (table index) }).values = + Function.update (materializedDeferredState context).values index.coordinate + (some (table index)) := by + rcases index with ⟨indexLay, indexTree, indexLeaf, indexChain⟩ + change + (materializedDeferredState + { context with state := (context.state.materialize + (.chainStart indexLay indexTree indexLeaf indexChain) + (table ⟨indexLay, indexTree, indexLeaf, indexChain⟩)) }).values = + Function.update (materializedDeferredState context).values + (.chainStart indexLay indexTree indexLeaf indexChain) + (some (table ⟨indexLay, indexTree, indexLeaf, indexChain⟩)) + funext coordinate + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + by_cases heq : Coordinate.chainStart lay tree leafIdx chainIdx = + Coordinate.chainStart indexLay indexTree indexLeaf indexChain + · rw [heq] + simp [materializedDeferredState, LazyRevealProbe.State.materialize] + · simp [materializedDeferredState, LazyRevealProbe.State.materialize, + Function.update_of_ne heq] + | position position => + simp [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, OtsSecretIndex.coordinate] + +set_option maxRecDepth 100000 in +theorem FinalizationContextEq.materialize_position_left_of_right_value + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextEq table (some left) (some right)) + (position : Position) (output : HashOutput) + (hleftHidden : left.state.values (.position position) = none) + (hleftPrivate : left.values position = some output) : + FinalizationContextEq table + (some { left with state := left.state.materialize (.position position) output }) + (some right) := by + have hle := (FinalizationContextLE.of_eq hcontext).materialize_position_left + position output hleftHidden hleftPrivate + refine ⟨{ + leftConsistent := hle.view.leftConsistent + rightConsistent := hle.view.rightConsistent + leftStarts := hle.view.leftStarts + rightStarts := hle.view.rightStarts + valueEq := hle.view.valueEq + leftClean := hle.view.leftClean + rightClean := hle.view.rightClean + pendingEq := ?_ }, hle.leftValid, hle.rightValid, hle.leftCompletable⟩ + intro coordinate hnone + have hne : coordinate ≠ .position position := by + intro heq + subst coordinate + simp [resolvedCompletionValue, DeferredContext.positionValue, + LazyRevealProbe.State.materialize] at hnone + have hrightNone : resolvedCompletionValue table right coordinate = none := by + rw [← hle.view.valueEq] + exact hnone + have hleftNone : resolvedCompletionValue table left coordinate = none := by + rw [hcontext.1.valueEq] + exact hrightNone + change (left.state.clearPending (.position position)).pendingAt coordinate = + right.state.pendingAt coordinate + rw [pendingAt_clearPending_of_ne left.state (.position position) coordinate hne] + exact hcontext.1.pendingEq coordinate hleftNone + +set_option maxRecDepth 100000 in +theorem FinalizationContextEq.materialize_position_both + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextEq table (some left) (some right)) + (position : Position) (output : HashOutput) : + FinalizationContextEq table + (some { state := left.state.materialize (.position position) output + values := left.values.install position output }) + (some { state := right.state.materialize (.position position) output + values := right.values.install position output }) := by + have hle := (FinalizationContextLE.of_eq hcontext).materialize_position_both position output + refine ⟨{ + leftConsistent := hle.view.leftConsistent + rightConsistent := hle.view.rightConsistent + leftStarts := hle.view.leftStarts + rightStarts := hle.view.rightStarts + valueEq := hle.view.valueEq + leftClean := hle.view.leftClean + rightClean := hle.view.rightClean + pendingEq := ?_ }, hle.leftValid, hle.rightValid, hle.leftCompletable⟩ + intro coordinate hnone + have hne : coordinate ≠ .position position := by + intro heq + subst coordinate + simp [resolvedCompletionValue, DeferredContext.positionValue, + LazyRevealProbe.State.materialize] at hnone + change (left.state.clearPending (.position position)).pendingAt coordinate = + (right.state.clearPending (.position position)).pendingAt coordinate + rw [pendingAt_clearPending_of_ne left.state (.position position) coordinate hne, + pendingAt_clearPending_of_ne right.state (.position position) coordinate hne] + have hleftNone : resolvedCompletionValue table left coordinate = none := by + cases coordinate with + | chainStart => exact hnone + | position other => + have hother : other ≠ position := by simpa using hne + simpa [resolvedCompletionValue, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by simpa using hother, + DeferredStructuralValues.install, hother] using hnone + exact hcontext.1.pendingEq coordinate hleftNone + +set_option maxRecDepth 100000 in +theorem FinalizationContextEq.materialize_chainStart_left + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextEq table (some left) (some right)) + (index : OtsSecretIndex) : + FinalizationContextEq table + (some { left with state := left.state.materialize index.coordinate (table index) }) + (some right) := by + have hle := (FinalizationContextLE.of_eq hcontext).materialize_chainStart_left index + refine ⟨{ + leftConsistent := hle.view.leftConsistent + rightConsistent := hle.view.rightConsistent + leftStarts := hle.view.leftStarts + rightStarts := hle.view.rightStarts + valueEq := hle.view.valueEq + leftClean := hle.view.leftClean + rightClean := hle.view.rightClean + pendingEq := ?_ }, hle.leftValid, hle.rightValid, hle.leftCompletable⟩ + intro coordinate hnone + have hne : coordinate ≠ index.coordinate := by + intro heq + subst coordinate + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + simp [resolvedCompletionValue, OtsSecretIndex.coordinate] at hnone + have hrightNone : resolvedCompletionValue table right coordinate = none := by + rw [← hle.view.valueEq] + exact hnone + have hleftNone : resolvedCompletionValue table left coordinate = none := by + rw [hcontext.1.valueEq] + exact hrightNone + change (left.state.clearPending index.coordinate).pendingAt coordinate = + right.state.pendingAt coordinate + rw [pendingAt_clearPending_of_ne left.state index.coordinate coordinate hne] + exact hcontext.1.pendingEq coordinate hleftNone + +set_option maxRecDepth 100000 in +theorem FinalizationContextEq.materialize_chainStart_right + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextEq table (some left) (some right)) + (index : OtsSecretIndex) : + FinalizationContextEq table + (some left) + (some { right with state := right.state.materialize index.coordinate (table index) }) := by + have hle := (FinalizationContextLE.of_eq hcontext).materialize_chainStart_right index + refine ⟨{ + leftConsistent := hle.view.leftConsistent + rightConsistent := hle.view.rightConsistent + leftStarts := hle.view.leftStarts + rightStarts := hle.view.rightStarts + valueEq := hle.view.valueEq + leftClean := hle.view.leftClean + rightClean := hle.view.rightClean + pendingEq := ?_ }, hle.leftValid, hle.rightValid, hle.leftCompletable⟩ + intro coordinate hnone + have hne : coordinate ≠ index.coordinate := by + intro heq + subst coordinate + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + simp [resolvedCompletionValue, OtsSecretIndex.coordinate] at hnone + change left.state.pendingAt coordinate = + (right.state.clearPending index.coordinate).pendingAt coordinate + rw [pendingAt_clearPending_of_ne right.state index.coordinate coordinate hne] + exact hcontext.1.pendingEq coordinate hnone + +set_option maxRecDepth 100000 in +theorem FinalizationContextEq.materialize_chainStart_both + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextEq table (some left) (some right)) + (index : OtsSecretIndex) : + FinalizationContextEq table + (some { left with state := left.state.materialize index.coordinate (table index) }) + (some { right with state := right.state.materialize index.coordinate (table index) }) := by + have hle := (FinalizationContextLE.of_eq hcontext).materialize_chainStart_both index + refine ⟨{ + leftConsistent := hle.view.leftConsistent + rightConsistent := hle.view.rightConsistent + leftStarts := hle.view.leftStarts + rightStarts := hle.view.rightStarts + valueEq := hle.view.valueEq + leftClean := hle.view.leftClean + rightClean := hle.view.rightClean + pendingEq := ?_ }, hle.leftValid, hle.rightValid, hle.leftCompletable⟩ + intro coordinate hnone + have hne : coordinate ≠ index.coordinate := by + intro heq + subst coordinate + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + simp [resolvedCompletionValue, OtsSecretIndex.coordinate] at hnone + change (left.state.clearPending index.coordinate).pendingAt coordinate = + (right.state.clearPending index.coordinate).pendingAt coordinate + rw [pendingAt_clearPending_of_ne left.state index.coordinate coordinate hne, + pendingAt_clearPending_of_ne right.state index.coordinate coordinate hne] + have hleftNone : resolvedCompletionValue table left coordinate = none := by + cases coordinate with + | chainStart => exact hnone + | position position => + simpa [resolvedCompletionValue, DeferredContext.positionValue, + LazyRevealProbe.State.materialize, OtsSecretIndex.coordinate] using hnone + exact hcontext.1.pendingEq coordinate hleftNone + +theorem completionSafeStateEq_materialized_right_of_finalizationContextEq + (table : OtsSecretIndex → HashOutput) (left right : DeferredContext) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : (materializedDeferredState left).values = right.state.values) + (hrevealed : left.state.revealed = right.state.revealed) + (hright : right = directDeferredContext right.state) : + CompletionSafeStateEq table (materializedDeferredState left) right.state := by + have hforward := completionSafeStateLE_materialized_of_finalizationContextLE table left right + (FinalizationContextLE.of_eq hcontext) hrevealed hvalues + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hrightCompletable : DeferredCompletable table right := by + obtain ⟨completion, hcompletion⟩ := hleftCompletable + exact ⟨completion, (hview.deferredCompletion_iff completion).mp hcompletion⟩ + have hleftMaterialized := + finalizationContextLE_materializedDeferredContext hleftValid hleftCompletable + have hreverse : FinalizationContextEq table (some right) (some left) := + ⟨hview.symm, hrightValid, hleftValid, hrightCompletable⟩ + have hbackwardContext : FinalizationContextLE table right + (materializedDeferredContext left) := + { view := (FinalizationContextLE.of_eq hreverse).view.trans hleftMaterialized.view + leftValid := hrightValid + rightValid := hleftMaterialized.rightValid + rightCompletable := hleftMaterialized.rightCompletable } + have hrightMaterialized : materializedDeferredState right = right.state := by + rw [hright] + exact materializedDeferredState_directDeferredContext right.state + have hbackwardValues : (materializedDeferredState right).values = + (materializedDeferredState left).values := by + rw [hrightMaterialized, ← hvalues] + have hbackwardRevealed : right.state.revealed = + (materializedDeferredContext left).state.revealed := by + change right.state.revealed = (materializedDeferredState left).revealed + simpa using hrevealed.symm + have hbackward := completionSafeStateLE_materialized_of_finalizationContextLE table right + (materializedDeferredContext left) hbackwardContext hbackwardRevealed (by + change (materializedDeferredState right).values = + (materializedDeferredState left).values + exact hbackwardValues) + refine ⟨hforward, ?_⟩ + rw [hrightMaterialized] at hbackward + exact hbackward + +theorem directWitnessFinalizationMaterializedCouples_pure + (table : OtsSecretIndex → HashOutput) (value : α) : + DirectWitnessFinalizationMaterializedCouples table + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized + hright + rw [StateT.run_pure, StateT.run_pure, runDirectResolvedDetailedFromTable_pure] + simp only [runDirectResolvedWitnessFromTable] + exact relTriple_pure_pure + ⟨rfl, hcontext, rfl, rfl, rfl, rfl, hcache, hrevealed, hmaterialized, + DeferredStructuralValuesLE.refl left.values, hright⟩ + +theorem DirectWitnessFinalizationMaterializedCouples.bind + {table : OtsSecretIndex → HashOutput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : DirectWitnessFinalizationMaterializedCouples table left) + (hnext : ∀ value, DirectWitnessFinalizationMaterializedCouples table (next value)) : + DirectWitnessFinalizationMaterializedCouples table (left >>= next) := by + intro leftContext rightContext leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed + hmaterialized hright + rw [StateT.run_bind, StateT.run_bind, runDirectResolvedWitnessFromTable_bind, + runDirectResolvedDetailedFromTable_bind] + apply relTriple_bind + (hleft leftContext rightContext leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed + hmaterialized hright) + intro leftResult rightResult hresult + cases leftResult with + | stoppedFuel => + cases rightResult with + | stopped reason => exact relTriple_pure_pure trivial + | done rightResult => + have hbase := relTriple_true + (pure (.stoppedFuel : DirectWitnessResult (β × SplitHashCache)) : + ProbComp (DirectWitnessResult (β × SplitHashCache))) + (runDirectResolvedDetailedFromTable rightResult.context rightResult.remaining + rightResult.table ((next rightResult.value.1).run rightResult.value.2)) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result ↦ result = .stoppedFuel) (by intro result hresult; simpa using hresult) + apply relTriple_post_mono hsupported + intro left _right hrelation + rw [hrelation.2] + trivial + | stoppedOrdinary => + cases rightResult with + | stopped reason => exact relTriple_pure_pure trivial + | done rightResult => + have hbase := relTriple_true + (pure (.stoppedOrdinary : DirectWitnessResult (β × SplitHashCache)) : + ProbComp (DirectWitnessResult (β × SplitHashCache))) + (runDirectResolvedDetailedFromTable rightResult.context rightResult.remaining + rightResult.table ((next rightResult.value.1).run rightResult.value.2)) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result ↦ result = .stoppedOrdinary) + (by intro result hresult; simpa using hresult) + apply relTriple_post_mono hsupported + intro left _right hrelation + rw [hrelation.2] + trivial + | stoppedPrivate witness => + cases rightResult with + | stopped reason => exact relTriple_pure_pure trivial + | done rightResult => + have hbase := relTriple_true + (pure (.stoppedPrivate witness : DirectWitnessResult (β × SplitHashCache)) : + ProbComp (DirectWitnessResult (β × SplitHashCache))) + (runDirectResolvedDetailedFromTable rightResult.context rightResult.remaining + rightResult.table ((next rightResult.value.1).run rightResult.value.2)) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result ↦ result = .stoppedPrivate witness) + (by intro result hresult; simpa using hresult) + apply relTriple_post_mono hsupported + intro left _right hrelation + rw [hrelation.2] + trivial + | done leftResult => + cases rightResult with + | stopped reason => simp [DirectWitnessFinalizationMaterializedRunEq] at hresult + | done rightResult => + rcases leftResult with ⟨leftContext, leftRemaining, leftValue, leftTable⟩ + rcases rightResult with ⟨rightContext, rightRemaining, rightValue, rightTable⟩ + rcases leftValue with ⟨leftOutput, leftCache⟩ + rcases rightValue with ⟨rightOutput, rightCache⟩ + simp only [DirectWitnessFinalizationMaterializedRunEq] at hresult + rcases hresult with + ⟨houtput, hcontext, hleftRemaining, hrightRemaining, hleftTable, hrightTable, hcache, + hrevealed, + hmaterialized, hprivateValues, hright⟩ + subst rightOutput + subst leftRemaining + subst rightRemaining + subst leftTable + subst rightTable + have htail := hnext leftOutput leftContext rightContext leftFuel rightFuel leftCache rightCache + hcontext hcache hrevealed hmaterialized hright + apply relTriple_post_mono htail + intro finalLeft finalRight hfinal + cases finalLeft with + | stoppedFuel => trivial + | stoppedOrdinary => trivial + | stoppedPrivate witness => trivial + | done finalLeft => + cases finalRight with + | stopped reason => + simp [DirectWitnessFinalizationMaterializedRunEq] at hfinal + | done finalRight => + simp only [DirectWitnessFinalizationMaterializedRunEq] at hfinal ⊢ + rcases hfinal with + ⟨houtput, hcontext, hleftRemaining, hrightRemaining, hleftTable, hrightTable, + hcache, + hrevealed, hmaterialized, htailValues, hright⟩ + exact ⟨houtput, hcontext, hleftRemaining, hrightRemaining, hleftTable, + hrightTable, hcache, + hrevealed, hmaterialized, hprivateValues.trans htailValues, hright⟩ + +theorem directWitnessFinalizationMaterializedCouples_ensureCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + DirectWitnessFinalizationMaterializedCouples table (ensureCoordinate coordinate) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized + hright + unfold ensureCoordinate + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.ensureQuery, + runDirectResolvedWitnessFromTable_ensure_query_bind, + runDirectResolvedDetailedFromTable_ensure_query_bind, + runDirectResolvedDetailedFromTable_pure] + simp only [runDirectResolvedWitnessFromTable] + apply relTriple_pure_pure + refine ⟨rfl, ⟨hcontext.1.ensure coordinate, hcontext.2.1.ensure coordinate, + hcontext.2.2.1.ensure coordinate, hcontext.2.2.2.ensure coordinate⟩, + rfl, rfl, rfl, rfl, hcache, ?_, ?_, ?_, ?_⟩ + · simpa [LazyRevealProbe.State.ensure] using hrevealed + · simpa [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.ensure] using hmaterialized + · exact DeferredStructuralValuesLE.refl left.values + · rw [hright] + simp [directDeferredContext, directDeferredValues_ensure] + +set_option maxRecDepth 100000 in +theorem directWitnessFinalizationMaterializedCouples_revealCoordinateOutput_position + (table : OtsSecretIndex → HashOutput) (position : Position) : + DirectWitnessFinalizationMaterializedCouples table + (revealCoordinateOutput (.position position)) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized + hright + cases hleftValue : left.state.values (.position position) with + | some output => + have hleftResolved : resolvedCompletionValue table left (.position position) = + some output := by + simp [resolvedCompletionValue, DeferredContext.positionValue, hleftValue] + have hrightResolved : resolvedCompletionValue table right (.position position) = + some output := by + rw [← hcontext.1.valueEq] + exact hleftResolved + have hrightValue : right.state.values (.position position) = some output := by + have hvalue := congrFun hmaterialized (.position position) + simpa [materializedDeferredState_position, DeferredContext.positionValue, + hleftValue] using hvalue.symm + rw [runDirectResolvedWitnessFromTable_revealCoordinateOutput_of_value table + (.position position) left leftFuel leftCache output hleftValue, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + (.position position) right rightFuel rightCache output hrightValue] + apply relTriple_pure_pure + refine ⟨rfl, hcontext, rfl, rfl, rfl, rfl, ?_, hrevealed, hmaterialized, + DeferredStructuralValuesLE.refl left.values, hright⟩ + simpa [hcache] + | none => + cases hrightValue : right.state.values (.position position) with + | some output => + have hprivate := (FinalizationContextLE.of_eq hcontext).view + |>.privateValue_of_left_hidden_of_right_materialized + position output hleftValue hrightValue + rw [runDirectResolvedWitnessFromTable_revealCoordinateOutput_position_of_private + table position left leftFuel leftCache output hleftValue hprivate, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + (.position position) right rightFuel rightCache output hrightValue] + have hresolved : resolvedCompletionValue table left (.position position) = + some output := by + simp [resolvedCompletionValue, DeferredContext.positionValue, hleftValue, hprivate] + have hmiss := hcontext.1.leftClean (.position position) output hresolved + simp only [hmiss, ↓reduceIte] + apply relTriple_pure_pure + refine ⟨rfl, + hcontext.materialize_position_left_of_right_value position output + hleftValue hprivate, + rfl, rfl, rfl, rfl, ?_, ?_, ?_, DeferredStructuralValuesLE.refl left.values, + hright⟩ + · simpa [hcache] + · simpa [LazyRevealProbe.State.materialize] using hrevealed + · rw [materializedDeferredState_values_materialize_position_of_private + left position output hcontext.2.1.valuesConsistent hprivate] + exact hmaterialized + | none => + have hrightPrivate : right.values position = none := by + rw [hright] + simpa [directDeferredContext, directDeferredValues] using hrightValue + have hleftPositionValue : left.positionValue position = none := by + change resolvedCompletionValue table left (.position position) = none + rw [hcontext.1.valueEq] + simp [resolvedCompletionValue, DeferredContext.positionValue, hrightValue, + hrightPrivate] + have hleftPrivate : left.values position = none := by + simpa [DeferredContext.positionValue, hleftValue] using hleftPositionValue + rw [runDirectResolvedWitnessFromTable_revealCoordinateOutput_position_of_fresh + table position left leftFuel leftCache hleftValue hleftPrivate, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_position_of_fresh + table position right rightFuel rightCache hrightValue hrightPrivate] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + have hresolvedNone : resolvedCompletionValue table left (.position position) = none := by + simpa [resolvedCompletionValue] using hleftPositionValue + have hpending := hcontext.1.pendingEq (.position position) hresolvedNone + have hhit : left.state.hitAt (.position position) leftOutput ↔ + right.state.hitAt (.position position) leftOutput := by + change truncateHash leftOutput ∈ left.state.pendingAt (.position position) ↔ + truncateHash leftOutput ∈ right.state.pendingAt (.position position) + rw [hpending] + by_cases hleftHit : left.state.hitAt (.position position) leftOutput + · have hrightHit := hhit.mp hleftHit + simp only [hleftHit, hrightHit, ↓reduceIte] + exact relTriple_pure_pure trivial + · have hrightHit := hhit.not.mp hleftHit + simp only [hleftHit, hrightHit, ↓reduceIte] + apply relTriple_pure_pure + refine ⟨rfl, hcontext.materialize_position_both position leftOutput, + rfl, rfl, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · simpa [hcache] + · simpa [LazyRevealProbe.State.materialize] using hrevealed + · rw [materializedDeferredState_values_materialize_position_install] + simpa [LazyRevealProbe.State.materialize] using + congrArg (fun values : Coordinate → Option HashOutput => + Function.update values (.position position) + (some leftOutput)) hmaterialized + · exact DeferredStructuralValuesLE.install_of_none hleftPrivate + · rw [hright] + simp [directDeferredContext, directDeferredValues_materialize_position] + +theorem directWitnessFinalizationMaterializedCouples_revealPosition + (table : OtsSecretIndex → HashOutput) (position : Position) : + DirectWitnessFinalizationMaterializedCouples table (revealPosition position) := by + unfold revealPosition revealCoordinate + exact (directWitnessFinalizationMaterializedCouples_revealCoordinateOutput_position + table position).bind fun output ↦ + directWitnessFinalizationMaterializedCouples_pure table (truncateHash output) + +set_option maxRecDepth 100000 in +theorem directWitnessFinalizationMaterializedCouples_revealCoordinateOutput_chainStart + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) : + DirectWitnessFinalizationMaterializedCouples table + (revealCoordinateOutput index.coordinate) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized + hright + have hrightCompletable := (FinalizationContextLE.of_eq hcontext).rightCompletable + cases hleftValue : left.state.values index.coordinate with + | some output => + have houtput := hcontext.1.leftStarts index output hleftValue + subst output + rw [runDirectResolvedWitnessFromTable_revealCoordinateOutput_of_value table + index.coordinate left leftFuel leftCache (table index) hleftValue] + cases hrightValue : right.state.values index.coordinate with + | some output => + have houtput := hcontext.1.rightStarts index output hrightValue + subst output + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + index.coordinate right rightFuel rightCache (table index) hrightValue] + apply relTriple_pure_pure + refine ⟨rfl, hcontext, rfl, rfl, rfl, rfl, ?_, hrevealed, hmaterialized, + DeferredStructuralValuesLE.refl left.values, hright⟩ + simpa [hcache] + | none => + have hvalue := congrFun hmaterialized index.coordinate + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + change left.state.values (.chainStart lay tree leafIdx chainIdx) = + some (table ⟨lay, tree, leafIdx, chainIdx⟩) at hleftValue + change right.state.values (.chainStart lay tree leafIdx chainIdx) = none at hrightValue + have hvalue' : left.state.values (.chainStart lay tree leafIdx chainIdx) = + right.state.values (.chainStart lay tree leafIdx chainIdx) := by + simpa [materializedDeferredState, OtsSecretIndex.coordinate] using hvalue + rw [hleftValue, hrightValue] at hvalue' + contradiction + | none => + have hleftMiss : ¬left.state.hitAt index.coordinate (table index) := + hcontext.2.2.2.not_hitAt_chainStart index + rw [runDirectResolvedWitnessFromTable_revealCoordinateOutput_chainStart_of_missing + table index left leftFuel leftCache hleftValue, if_neg hleftMiss] + cases hrightValue : right.state.values index.coordinate with + | some output => + have hvalue := congrFun hmaterialized index.coordinate + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + change left.state.values (.chainStart lay tree leafIdx chainIdx) = none at hleftValue + change right.state.values (.chainStart lay tree leafIdx chainIdx) = some output at hrightValue + have hvalue' : left.state.values (.chainStart lay tree leafIdx chainIdx) = + right.state.values (.chainStart lay tree leafIdx chainIdx) := by + simpa [materializedDeferredState, OtsSecretIndex.coordinate] using hvalue + rw [hleftValue, hrightValue] at hvalue' + contradiction + | none => + have hrightMiss : ¬right.state.hitAt index.coordinate (table index) := + hrightCompletable.not_hitAt_chainStart index + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_chainStart_of_missing + table index right rightFuel rightCache hrightValue, if_neg hrightMiss] + apply relTriple_pure_pure + refine ⟨rfl, hcontext.materialize_chainStart_both index, + rfl, rfl, rfl, rfl, ?_, ?_, ?_, DeferredStructuralValuesLE.refl left.values, ?_⟩ + · simpa [hcache] + · simpa [LazyRevealProbe.State.materialize] using hrevealed + · rw [materializedDeferredState_values_materialize_chainStart table] + simpa [LazyRevealProbe.State.materialize] using + congrArg (fun values : Coordinate → Option HashOutput => + Function.update values index.coordinate + (some (table index))) hmaterialized + · rw [hright] + simp [directDeferredContext, directDeferredValues_materialize_chainStart] + +theorem directWitnessFinalizationMaterializedCouples_revealCoordinateOutput + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + DirectWitnessFinalizationMaterializedCouples table + (revealCoordinateOutput coordinate) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact directWitnessFinalizationMaterializedCouples_revealCoordinateOutput_chainStart table + ⟨lay, tree, leafIdx, chainIdx⟩ + | position position => + exact directWitnessFinalizationMaterializedCouples_revealCoordinateOutput_position + table position + +theorem directWitnessFinalizationMaterializedCouples_revealCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + DirectWitnessFinalizationMaterializedCouples table (revealCoordinate coordinate) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + unfold revealCoordinate + exact (directWitnessFinalizationMaterializedCouples_revealCoordinateOutput_chainStart table + ⟨lay, tree, leafIdx, chainIdx⟩).bind fun output ↦ + directWitnessFinalizationMaterializedCouples_pure table (truncateHash output) + | position position => + exact directWitnessFinalizationMaterializedCouples_revealPosition table position + +theorem directWitnessFinalizationMaterializedCouples_publishCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + DirectWitnessFinalizationMaterializedCouples table (publishCoordinate coordinate) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized + hright + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + unfold publishCoordinate + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.publishQuery, + runDirectResolvedWitnessFromTable_publish_query_bind, + runDirectResolvedDetailedFromTable_publish_query_bind, + runDirectResolvedDetailedFromTable_pure] + simp only [runDirectResolvedWitnessFromTable] + apply relTriple_pure_pure + refine ⟨rfl, + ⟨hview.publish coordinate, hleftValid.publish coordinate, + hrightValid.publish coordinate, hleftCompletable.publish coordinate⟩, + rfl, rfl, rfl, rfl, hcache, ?_, ?_, DeferredStructuralValuesLE.refl left.values, ?_⟩ + · simpa [LazyRevealProbe.State.publish] using congrArg (insert coordinate) hrevealed + · rw [materializedDeferredState_publish] + simpa [LazyRevealProbe.State.publish] using hmaterialized + · rw [hright] + simp [directDeferredContext, directDeferredValues_publish] + +theorem directWitnessFinalizationMaterializedCouples_revealPublishedCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + DirectWitnessFinalizationMaterializedCouples table + (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate revealCoordinate + simp only [bind_assoc, pure_bind] + apply (directWitnessFinalizationMaterializedCouples_revealCoordinateOutput + table coordinate).bind + intro output + apply (directWitnessFinalizationMaterializedCouples_publishCoordinate + table coordinate).bind + intro _ + exact directWitnessFinalizationMaterializedCouples_pure table (truncateHash output) + +set_option maxRecDepth 100000 in +theorem directWitnessFinalizationMaterializedCouples_sequenceFin + {table : OtsSecretIndex → HashOutput} {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, + DirectWitnessFinalizationMaterializedCouples table (computation index)) : + DirectWitnessFinalizationMaterializedCouples table (sequenceFin computation) := by + induction n with + | zero => + simpa [sequenceFin] using + (directWitnessFinalizationMaterializedCouples_pure table Fin.elim0 : + DirectWitnessFinalizationMaterializedCouples table + (pure Fin.elim0 : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Fin 0 → α))) + | succ n ih => + rw [sequenceFin] + apply (hcomponent 0).bind + intro head + apply (ih (fun index : Fin n ↦ computation index.succ) + (fun index ↦ hcomponent index.succ)).bind + intro tail + exact directWitnessFinalizationMaterializedCouples_pure table + (Fin.cases head tail : Fin (n + 1) → α) + +set_option maxRecDepth 100000 in +theorem directWitnessFinalizationMaterializedCouples_splitHashQuery_ordinary + (table : OtsSecretIndex → HashOutput) (input : HashInput) : + DirectWitnessFinalizationMaterializedCouples table + (splitHashQuery (.ordinary input)) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized + hright + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + have hcacheAt : leftCache (.ordinary input) = rightCache (.ordinary input) := + congrFun hcache (.ordinary input) + cases hlookup : leftCache (.ordinary input) with + | some output => + have hrightLookup : rightCache (.ordinary input) = some output := by + rw [← hcacheAt] + exact hlookup + simp only [hrightLookup] + exact directWitnessFinalizationMaterializedCouples_pure table output left right leftFuel + rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized hright + | none => + have hrightLookup : rightCache (.ordinary input) = none := by + rw [← hcacheAt] + exact hlookup + simp only [hrightLookup] + rw [LazyRevealProbe.hashOutputQuery, + runDirectResolvedWitnessFromTable_hashOutput_query_bind, + runDirectResolvedDetailedFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runDirectResolvedWitnessFromTable, runDirectResolvedDetailedFromTable] + apply relTriple_pure_pure + refine ⟨rfl, hcontext, rfl, rfl, rfl, rfl, ?_, hrevealed, hmaterialized, + DeferredStructuralValuesLE.refl left.values, hright⟩ + simpa [hcache] + +theorem directWitnessFinalizationMaterializedCouples_ordinaryHashImpl + (table : OtsSecretIndex → HashOutput) (input : HashInput) : + DirectWitnessFinalizationMaterializedCouples table (ordinaryHashImpl input) := + directWitnessFinalizationMaterializedCouples_splitHashQuery_ordinary table input + +theorem directWitnessFinalizationMaterializedCouples_splitUniformImpl + (table : OtsSecretIndex → HashOutput) (n : unifSpec.Domain) : + DirectWitnessFinalizationMaterializedCouples table (splitUniformImpl n) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized + hright + unfold splitUniformImpl + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.uniformQuery, + runDirectResolvedWitnessFromTable_uniform_query_bind, + runDirectResolvedDetailedFromTable_uniform_query_bind] + apply relTriple_bind (relTriple_refl + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))) + intro leftOutput rightOutput houtput + subst rightOutput + exact directWitnessFinalizationMaterializedCouples_pure table leftOutput left right leftFuel + rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized hright + +theorem directWitnessFinalizationMaterializedCouples_simulateQ + {table : OtsSecretIndex → HashOutput} {spec : OracleSpec ι} + (impl : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))) + (hquery : ∀ query, + DirectWitnessFinalizationMaterializedCouples table (impl query)) + (computation : OracleComp spec α) : + DirectWitnessFinalizationMaterializedCouples table (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp only [simulateQ_pure] + exact directWitnessFinalizationMaterializedCouples_pure table value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (hquery query).bind fun output ↦ ih output + +theorem directWitnessFinalizationMaterializedCouples_ordinaryRomImpl + (table : OtsSecretIndex → HashOutput) (query : OracleWorld.Domain) : + DirectWitnessFinalizationMaterializedCouples table (ordinaryRomImpl query) := by + cases query with + | inl n => exact directWitnessFinalizationMaterializedCouples_splitUniformImpl table n + | inr input => exact directWitnessFinalizationMaterializedCouples_ordinaryHashImpl table input + +theorem directWitnessFinalizationMaterializedCouples_ensureFullChain + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + DirectWitnessFinalizationMaterializedCouples table + (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + apply (directWitnessFinalizationMaterializedCouples_sequenceFin + (fun step : ChainStep => + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step))) + (fun step => directWitnessFinalizationMaterializedCouples_ensureCoordinate table + (.position (.chain lay tree leafIdx chainIdx step)))).bind + intro _ + exact directWitnessFinalizationMaterializedCouples_pure table () + +theorem directWitnessFinalizationMaterializedCouples_ensureOtsLeaf + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + DirectWitnessFinalizationMaterializedCouples table (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + apply (directWitnessFinalizationMaterializedCouples_sequenceFin + (fun chainIdx : ChainIndex => ensureFullChain lay tree leafIdx chainIdx) + (fun chainIdx => directWitnessFinalizationMaterializedCouples_ensureFullChain table lay tree + leafIdx chainIdx)).bind + intro _ + exact directWitnessFinalizationMaterializedCouples_ensureCoordinate table + (.position (.leaf lay tree leafIdx)) + +theorem directWitnessFinalizationMaterializedCouples_ensureTreeNode + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, + DirectWitnessFinalizationMaterializedCouples table (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => + directWitnessFinalizationMaterializedCouples_ensureOtsLeaf table lay tree + (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + apply (directWitnessFinalizationMaterializedCouples_ensureTreeNode table lay tree level + (2 * nodeIdx)).bind + intro _ + apply (directWitnessFinalizationMaterializedCouples_ensureTreeNode table lay tree level + (2 * nodeIdx + 1)).bind + intro _ + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact directWitnessFinalizationMaterializedCouples_ensureCoordinate table + (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact directWitnessFinalizationMaterializedCouples_pure table () + +theorem directWitnessFinalizationMaterializedCouples_maskedTreeNode + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) : + DirectWitnessFinalizationMaterializedCouples table + (maskedTreeNode lay tree level nodeIdx) := by + unfold maskedTreeNode + apply (directWitnessFinalizationMaterializedCouples_ensureTreeNode table lay tree level + nodeIdx).bind + intro _ + cases level with + | zero => + exact directWitnessFinalizationMaterializedCouples_revealPosition table + (.leaf lay tree (leafOfNat nodeIdx)) + | succ current => + by_cases hlevel : current < maxLayerHeight + · simp only [hlevel, ↓reduceDIte] + exact directWitnessFinalizationMaterializedCouples_revealPosition table + (.node lay tree ⟨current, hlevel⟩ (leafOfNat nodeIdx)) + · simp only [hlevel, ↓reduceDIte] + exact directWitnessFinalizationMaterializedCouples_pure table 0 + +theorem directWitnessFinalizationMaterializedCouples_maskedTreeRoot + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + DirectWitnessFinalizationMaterializedCouples table (maskedTreeRoot lay tree) := by + unfold maskedTreeRoot + exact directWitnessFinalizationMaterializedCouples_maskedTreeNode table lay tree + (layerHeight lay) 0 + +theorem directWitnessFinalizationMaterializedCouples_ensureChainPrefix + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + DirectWitnessFinalizationMaterializedCouples table + (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + apply (directWitnessFinalizationMaterializedCouples_sequenceFin + (fun step : ChainStep => + if step.val < digit.val then + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + else pure ()) + (fun step => by + by_cases hstep : step.val < digit.val + · rw [if_pos hstep] + exact directWitnessFinalizationMaterializedCouples_ensureCoordinate table + (.position (.chain lay tree leafIdx chainIdx step)) + · rw [if_neg hstep] + exact directWitnessFinalizationMaterializedCouples_pure table ())).bind + intro _ + exact directWitnessFinalizationMaterializedCouples_pure table () + +theorem directWitnessFinalizationMaterializedCouples_ensureTreePath + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + DirectWitnessFinalizationMaterializedCouples table (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + apply (directWitnessFinalizationMaterializedCouples_sequenceFin + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + ensureTreeNode lay tree level.val (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + else pure ()) + (fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + exact directWitnessFinalizationMaterializedCouples_ensureTreeNode table lay tree + level.val (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · rw [if_neg hlevel] + exact directWitnessFinalizationMaterializedCouples_pure table ())).bind + intro _ + exact directWitnessFinalizationMaterializedCouples_pure table () + +theorem directWitnessFinalizationMaterializedCouples_maskedOtsSignFrom + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter, + DirectWitnessFinalizationMaterializedCouples table + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom] + exact directWitnessFinalizationMaterializedCouples_pure table none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + have hencoded := directWitnessFinalizationMaterializedCouples_simulateQ ordinaryHashImpl + (directWitnessFinalizationMaterializedCouples_ordinaryHashImpl table) + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) + apply hencoded.bind + intro encoded + cases encoded with + | none => + exact directWitnessFinalizationMaterializedCouples_maskedOtsSignFrom table parameter + lay tree leafIdx message attempts (counter + 1) + | some encoding => + apply (directWitnessFinalizationMaterializedCouples_sequenceFin + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx (encoding chainIdx)) + (fun chainIdx => + directWitnessFinalizationMaterializedCouples_ensureChainPrefix table lay tree + leafIdx chainIdx (encoding chainIdx))).bind + intro _ + exact directWitnessFinalizationMaterializedCouples_pure table + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem directWitnessFinalizationMaterializedCouples_maskedOtsSign + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + DirectWitnessFinalizationMaterializedCouples table + (maskedOtsSign parameter lay tree leafIdx message) := + directWitnessFinalizationMaterializedCouples_maskedOtsSignFrom table parameter lay tree + leafIdx message encodingAttemptLimit 0 + +theorem directWitnessFinalizationMaterializedCouples_maskedLayerMessage + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + DirectWitnessFinalizationMaterializedCouples table + (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + by_cases hbelow : lay.val + 1 < numLayers + · rw [dif_pos hbelow] + exact directWitnessFinalizationMaterializedCouples_maskedTreeRoot table + ⟨lay.val + 1, hbelow⟩ (treeIndexAt index ⟨lay.val + 1, hbelow⟩) + · rw [dif_neg hbelow] + exact directWitnessFinalizationMaterializedCouples_simulateQ ordinaryHashImpl + (directWitnessFinalizationMaterializedCouples_ordinaryHashImpl table) + (ftsKey parameter index (ftsSecret index)) + +theorem directWitnessFinalizationMaterializedCouples_maskedSignLayer + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + DirectWitnessFinalizationMaterializedCouples table + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + apply (directWitnessFinalizationMaterializedCouples_maskedLayerMessage table parameter + ftsSecret index lay).bind + intro message + apply (directWitnessFinalizationMaterializedCouples_maskedOtsSign table parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) message).bind + intro selected + cases selected with + | none => exact directWitnessFinalizationMaterializedCouples_pure table none + | some selected => + apply (directWitnessFinalizationMaterializedCouples_ensureTreePath table lay + (treeIndexAt index lay) (leafIndexAt index lay)).bind + intro _ + exact directWitnessFinalizationMaterializedCouples_pure table (some selected) + +set_option maxRecDepth 100000 in +theorem directWitnessFinalizationMaterializedCouples_revealLayerValues + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + DirectWitnessFinalizationMaterializedCouples table + (revealLayerValues index lay encoding) := by + unfold revealLayerValues + apply (directWitnessFinalizationMaterializedCouples_sequenceFin + (fun chainIdx : ChainIndex => + revealPublishedCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx))) + (fun chainIdx => directWitnessFinalizationMaterializedCouples_revealPublishedCoordinate table + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx)))).bind + intro values + apply (directWitnessFinalizationMaterializedCouples_sequenceFin + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + match level.val with + | 0 => revealPublishedCoordinate (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | current + 1 => + if hcurrent : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hcurrent⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0 + else pure 0) + (fun level => by + by_cases hinLayer : level.val < layerHeight lay + · rw [if_pos hinLayer] + cases hvalue : level.val with + | zero => + exact directWitnessFinalizationMaterializedCouples_revealPublishedCoordinate table + (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | succ current => + have hcurrent : current < maxLayerHeight := by + have := level.isLt + omega + simp only + rw [dif_pos hcurrent] + exact directWitnessFinalizationMaterializedCouples_revealPublishedCoordinate table + (.position (.node lay (treeIndexAt index lay) ⟨current, hcurrent⟩ + (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + · rw [if_neg hinLayer] + exact directWitnessFinalizationMaterializedCouples_pure table 0)).bind + intro path + exact directWitnessFinalizationMaterializedCouples_pure table (values, path) + +set_option maxRecDepth 100000 in +theorem directWitnessFinalizationMaterializedCouples_maskedSignAfterDigest + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + DirectWitnessFinalizationMaterializedCouples table + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest + apply (directWitnessFinalizationMaterializedCouples_simulateQ ordinaryHashImpl + (directWitnessFinalizationMaterializedCouples_ordinaryHashImpl table) + (ftsOpen parameter index leaves (ftsSecret index))).bind + intro ftsPath + apply (directWitnessFinalizationMaterializedCouples_sequenceFin + (fun lay : Layer => maskedSignLayer parameter ftsSecret index lay) + (fun lay => directWitnessFinalizationMaterializedCouples_maskedSignLayer table parameter + ftsSecret index lay)).bind + intro layers + cases hparts : traverseOption layers with + | none => exact directWitnessFinalizationMaterializedCouples_pure table none + | some parts => + apply (directWitnessFinalizationMaterializedCouples_sequenceFin + (fun lay : Layer => revealLayerValues index lay (parts lay).2) + (fun lay => directWitnessFinalizationMaterializedCouples_revealLayerValues table index lay + (parts lay).2)).bind + intro revealed + let signature : Signature := + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (revealed lay).1 + authPath := flattenPaths fun lay => (revealed lay).2 } + exact directWitnessFinalizationMaterializedCouples_pure table (some signature) + +set_option maxRecDepth 100000 in +theorem directWitnessFinalizationMaterializedCouples_maskedSign + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + DirectWitnessFinalizationMaterializedCouples table + (maskedSign parameter root ftsSecret message) := by + unfold maskedSign + apply (directWitnessFinalizationMaterializedCouples_simulateQ ordinaryRomImpl + (directWitnessFinalizationMaterializedCouples_ordinaryRomImpl table) + (signDigestLoop digestAttemptLimit + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ message)).bind + intro selected + cases selected with + | none => exact directWitnessFinalizationMaterializedCouples_pure table none + | some data => + exact directWitnessFinalizationMaterializedCouples_maskedSignAfterDigest table parameter + ftsSecret data.1 data.2.1 data.2.2 + +set_option maxRecDepth 100000 in +theorem evalDist_runDirectDetailed_finish_eq_runObservedClean_finish + (computation : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (continuation : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List CleanProbeObservation → ProbComp Bool) + (hprobeFree : computation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) : + evalDist + (runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table computation >>= + fun result => match result with + | .stopped _ => pure false + | .done result => continuation result.context.state result.remaining + result.value.1 result.value.2 observations) = + evalDist + (runObservedCleanFromTable observations state fuel table computation >>= fun result => + match result with + | none => pure false + | some result => continuation result.state result.remaining result.value.1 + result.value.2 result.observations) := by + let finishClean : Option (CleanRunResult (α × SplitHashCache)) → ProbComp Bool + | none => pure false + | some result => continuation result.state result.remaining result.value.1 + result.value.2 observations + let finishObserved : Option (ObservedCleanRunResult (α × SplitHashCache)) → ProbComp Bool + | none => pure false + | some result => continuation result.state result.remaining result.value.1 + result.value.2 result.observations + have hdirect := map_projectDirectDetailedClean_run_eq_clean computation state fuel table + have hobserved := map_attachCleanProbeObservations_runCleanFromTable_of_probeFree computation + observations state fuel table hprobeFree + calc + _ = evalDist + ((projectDirectDetailedClean <$> + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + computation) >>= finishClean) := by + rw [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro result _hresult + cases result <;> rfl + _ = evalDist (runCleanFromTable state fuel table computation >>= finishClean) := by + rw [hdirect] + _ = evalDist + ((attachCleanProbeObservations observations <$> + runCleanFromTable state fuel table computation) >>= finishObserved) := by + rw [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro result _hresult + cases result <;> rfl + _ = _ := by rw [hobserved] + +theorem runDirectDetailed_finish_eq_runObservedClean_finish + (computation : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (continuation : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List CleanProbeObservation → ProbComp Bool) + (hprobeFree : computation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) : + (runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table computation >>= + fun result => match result with + | .stopped _ => pure false + | .done result => continuation result.context.state result.remaining + result.value.1 result.value.2 observations) = + (runObservedCleanFromTable observations state fuel table computation >>= fun result => + match result with + | none => pure false + | some result => continuation result.state result.remaining result.value.1 + result.value.2 result.observations) := by + let finishClean : Option (CleanRunResult (α × SplitHashCache)) → ProbComp Bool + | none => pure false + | some result => continuation result.state result.remaining result.value.1 + result.value.2 observations + let finishObserved : Option (ObservedCleanRunResult (α × SplitHashCache)) → ProbComp Bool + | none => pure false + | some result => continuation result.state result.remaining result.value.1 + result.value.2 result.observations + have hdirect := map_projectDirectDetailedClean_run_eq_clean computation state fuel table + have hobserved := map_attachCleanProbeObservations_runCleanFromTable_of_probeFree computation + observations state fuel table hprobeFree + calc + _ = (projectDirectDetailedClean <$> + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + computation) >>= finishClean := by + rw [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro result + cases result <;> rfl + _ = runCleanFromTable state fuel table computation >>= finishClean := by rw [hdirect] + _ = (attachCleanProbeObservations observations <$> + runCleanFromTable state fuel table computation) >>= finishObserved := by + rw [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro result + cases result <;> rfl + _ = _ := by rw [hobserved] + +theorem relTriple_finishDirectWitness_directDetailed + (table : OtsSecretIndex → HashOutput) (initialValues : DeferredStructuralValues) + (leftInitialFuel rightInitialFuel : Nat) + (leftRun : ProbComp (DirectWitnessResult (α × SplitHashCache))) + (rightRun : ProbComp (DirectDetailedResult (α × SplitHashCache))) + (leftObserve : DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → List CleanProbeObservation → ProbComp Bool) + (rightObserve : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (hstep : RelTriple leftRun rightRun + (DirectWitnessFinalizationMaterializedRunEq table initialValues leftInitialFuel + rightInitialFuel)) + (hnext : ∀ left right, + DirectWitnessResult.done left ∈ support leftRun → + DirectDetailedResult.done right ∈ support rightRun → + DirectWitnessFinalizationMaterializedRunEq table initialValues leftInitialFuel + rightInitialFuel (.done left) (.done right) → + RelTriple + (leftObserve left.context left.remaining left.value snapshots observations) + (rightObserve right.context.state right.remaining right.value.1 right.value.2 + observations) + BoolImp) : + RelTriple + (leftRun >>= finishDirectDelayedSelectedRootIndicator leftObserve snapshots observations) + (rightRun >>= fun result => match result with + | .stopped _ => pure false + | .done result => rightObserve result.context.state result.remaining result.value.1 + result.value.2 observations) + BoolImp := by + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hstep + (fun result => result ∈ support leftRun) (fun _ hresult => hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupported + apply relTriple_bind hbothSupported + intro left right hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases left with + | stoppedFuel => + simp only [finishDirectDelayedSelectedRootIndicator] + exact relTriple_false_any _ + | stoppedOrdinary => + simp only [finishDirectDelayedSelectedRootIndicator] + exact relTriple_false_any _ + | stoppedPrivate witness => + simp only [finishDirectDelayedSelectedRootIndicator] + exact relTriple_false_any _ + | done left => + cases right with + | stopped reason => simp [DirectWitnessFinalizationMaterializedRunEq] at hrelation + | done right => exact hnext left right hleftSupport hrightSupport hrelation + +end ScratchLocal + +open ScratchLocal + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem goodForRoots_of_true_mem_directDelayed_selected_hash + (ordinal : Nat) (parameter : PublicParameter) (publicRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) + (targetOutput : HashOutput) (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) RetainedRestResult) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (candidate : Probe) + (hcandidate : rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state) = some candidate) + (hordinal : snapshots.length = ordinal) + (hobservationLength : observations.length = ordinal) + (hvalid : context.Valid) + (hcompletable : DeferredCompletable table context) + (hpublished : PublishedValues context.state) + (hcanonical : CanonicalMaterializedValues table context) + (hprivate : context.values target = some targetOutput) + (htrue : true ∈ support + (directDelayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret table target + rightRoot + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + snapshots observations context fuel cache)) : + let selection : PrivateOrdinalSelection := + ⟨candidate, context, + (snapshots ++ [(⟨candidate, context⟩ : PlannedProbeSnapshot)]).map + PlannedProbeSnapshot.toProbe⟩ + selection.GoodForRoots target targetOutput rightRoot ordinal := by + dsimp only + have hnotSelected : ¬ordinal < snapshots.length := by omega + have hselected : ordinal < + (appendPlannedSnapshot snapshots (some candidate) context).length := by + simp [appendPlannedSnapshot, hordinal] + rw [directDelayedSelectedRootIndicator_hash_eq_selected ordinal parameter publicRoot + ftsSecret table target rightRoot input next snapshots observations context fuel cache + hnotSelected (by simpa [hcandidate] using hselected)] at htrue + have hget : + (appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).get + ⟨ordinal, by simpa [hcandidate] using hselected⟩ = + (⟨candidate, context⟩ : PlannedProbeSnapshot) := by + subst ordinal + simp [appendPlannedSnapshot, hcandidate, List.get_eq_getElem] + rw [hget] at htrue + unfold delayedSelectedRootIndicator at htrue + rw [mem_support_bind_iff] at htrue + obtain ⟨resolvedOption, hresolvedOption, hrest⟩ := htrue + cases resolvedOption with + | none => simp at hrest + | some resolved => + simp only at hrest + have houtput := + resolveDeferredPositionValue_output_eq_of_private_of_deferredCompletable table target + context targetOutput hprivate hcompletable resolved hresolvedOption + have happend : + appendPlannedSnapshot snapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context = + snapshots ++ [(⟨candidate, context⟩ : PlannedProbeSnapshot)] := by + simp [hcandidate, appendPlannedSnapshot] + rw [happend] at hrest + have hsafe : CandidatesAvoidRoots target (truncateHash targetOutput) rightRoot + ((snapshots ++ [(⟨candidate, context⟩ : PlannedProbeSnapshot)]).map + PlannedProbeSnapshot.toProbe |>.take ordinal) := by + rw [houtput] at hrest + by_cases hsafe : CandidatesAvoidRoots target (truncateHash targetOutput) rightRoot + ((snapshots ++ [(⟨candidate, context⟩ : PlannedProbeSnapshot)]).map + PlannedProbeSnapshot.toProbe |>.take ordinal) + · exact hsafe + · rw [if_neg hsafe] at hrest + simp at hrest + rw [houtput] at hrest + simp only [hsafe, ↓reduceIte] at hrest + rw [support_map] at hrest + obtain ⟨observed, hobserved, hindicator⟩ := hrest + have hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot observed := by + change successfulObservedRootComparisonIndicator table ordinal target + (observed, rightRoot) = true at hindicator + rw [successfulObservedRootComparisonIndicator_eq_true_iff] at hindicator + exact hindicator + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hgood + | some result => + have hresolvedValid := hvalid.of_resolveDeferredPositionValue target resolved + hresolvedOption + have hresolvedCompletable := + hcompletable.of_resolveDeferredPositionValue hvalid target resolved hresolvedOption + have hresolvedCanonical := canonicalMaterializedValues_of_resolveDeferredPositionValue + table target context resolved hpublished hcanonical hresolvedOption + have hcontextLE := finalizationContextLE_materializedDeferredContext hresolvedValid + hresolvedCompletable + have hvalues : + (materializedCanonicalContext table + (materializedDeferredState resolved.toDeferredContext)).state.values = + resolved.state.values := + canonicalized_right_values_eq_of_finalizationContextLE hcontextLE rfl + hresolvedCanonical + have hpreserved := resolveDeferredPositionValue_preserves_state_values target context + resolved hresolvedOption + have hqueryCandidate : rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table + (materializedDeferredState resolved.toDeferredContext)).state) = + some candidate := by + rw [purePlanProbingHashQuery_eq_of_values_eq hvalues parameter input, + purePlanProbingHashQuery_eq_of_values_eq hpreserved parameter input] + exact hcandidate + obtain ⟨⟨⟨⟨_finalResult, _hfinish⟩, + selected, hselectedOrdinal, hfirst, _hroot⟩, hposition⟩, _hcomparison⟩ := hgood + have hobservation := + selected_observation_eq_of_mem_observedMaterializedBoundary_hash_query ordinal + parameter publicRoot ftsSecret input next observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache candidate + hobservationLength hqueryCandidate result hobserved selected hselectedOrdinal + obtain ⟨first, hfirstOrdinal, hfirstHit, _hbeforeFirst⟩ := hfirst + have hfirstSelected : first = selected := + Fin.ext (hfirstOrdinal.trans hselectedOrdinal.symm) + subst first + have hselectedLt : ordinal < result.observations.length := by + rw [← hselectedOrdinal] + exact selected.isLt + have hselectedIndex : + (⟨ordinal, hselectedLt⟩ : Fin result.observations.length) = selected := + Fin.ext hselectedOrdinal.symm + have htargetData : + (result.observations.get selected).coordinate = .position target := by + simp only [observedFirstLayerRootPosition?, hselectedLt, ↓reduceDIte] at hposition + rw [candidateLayerRootPosition?_eq_some_iff, hselectedIndex] at hposition + exact hposition.1 + have hcandidateCoordinate : candidate.coordinate = .position target := by + rw [hobservation] at htargetData + simpa [cleanProbeObservation] using htargetData + rw [ExistingHiddenHitAtOrdinal, hobservation] at hfirstHit + obtain ⟨hselectedHidden, existing, hselectedValue, hselectedCandidate⟩ := hfirstHit + have hresolvedValue : + (materializedDeferredState resolved.toDeferredContext).values + (.position target) = some targetOutput := by + simp only [materializedDeferredState_position] + have hpositionValue := resolveDeferredPositionValue_resolves target context resolved + hresolvedOption + simpa [houtput] using hpositionValue + have hexisting : existing = targetOutput := by + have : (materializedDeferredState resolved.toDeferredContext).values + candidate.coordinate = some existing := by + simpa [cleanProbeObservation] using hselectedValue + rw [hcandidateCoordinate, hresolvedValue] at this + exact Option.some.inj this.symm + have hcandidateDigest : truncateHash targetOutput = candidate.candidate := by + simpa [cleanProbeObservation, hexisting] using hselectedCandidate + have hcandidateEq : candidate = ⟨.position target, truncateHash targetOutput⟩ := by + cases candidate + simp only [Probe.mk.injEq] + exact ⟨hcandidateCoordinate, hcandidateDigest.symm⟩ + have hresolvedHidden : Coordinate.position target ∉ resolved.state.revealed := by + rw [← hcandidateCoordinate] + simpa [cleanProbeObservation, decide_eq_false_iff_not] using hselectedHidden + have hcontextHidden : Coordinate.position target ∉ context.state.revealed := by + rw [resolveDeferredPositionValue_state_eq_clearPending target context resolved + hresolvedOption] at hresolvedHidden + simpa [LazyRevealProbe.State.clearPending] using hresolvedHidden + refine ⟨hcandidateEq, + canonical_value_none_of_not_revealed hcanonical hcontextHidden, + hcontextHidden, hprivate, ?_⟩ + simpa [hordinal] using hsafe + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_directDelayed_observed_shadow + (ordinal : Nat) (parameter : PublicParameter) (publicRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (targetOutput : HashOutput) + (hroot : IsLayerRoot target) + (computation : OracleComp (OracleWorld + SigningSpec) RetainedRestResult) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (context : DeferredContext) (leftFuel rightFuel q bound : Nat) + (cache : SplitHashCache) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, publicRoot, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) computation).IsQueryBoundP + (fun query => query matches Sum.inr _) bound) + (hvalid : context.Valid) + (hcompletable : DeferredCompletable table context) + (hpublished : PublishedValues context.state) + (hcanonical : CanonicalMaterializedValues table context) + (hchainValid : ChainState.ValidFor (fun _ ↦ True) context.state) + (hprivate : context.values target = some targetOutput) + (haligned : SnapshotsObservedAt table snapshots observations) + (hbefore : SnapshotsBefore snapshots context) + (htracked : CleanProbeObservationsTrackedBy observations + (materializedDeferredState context)) + (hcovered : CleanProbeObservationsCoverPending observations + (materializedDeferredState context)) + (hnoHit : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (hpending : PendingCoveredBy + (snapshots.map PlannedProbeSnapshot.toProbe) context) + (hlength : snapshots.length ≤ ordinal) + (hleftLower : bound ≤ leftFuel) (hleftUpper : leftFuel ≤ q) + (hrightLower : q + bound ≤ rightFuel) + (hbudget : rightFuel + (materializedDeferredState context).pending.card < + Fintype.card Digest) : + RelTriple + (directDelayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret table target + rightRoot computation snapshots observations context leftFuel cache) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret computation observations + (materializedDeferredState context) rightFuel table cache) + SuccessfulObservedIndicatorRel := by + induction computation using OracleComp.inductionOn generalizing + snapshots observations context leftFuel rightFuel bound cache with + | pure value => + have hselected : ¬ordinal < snapshots.length := by omega + rw [directDelayedSelectedRootIndicator, OracleComp.construct_pure] + simp only [hselected, ↓reduceDIte] + exact relTriple_false_any _ + | query_bind query next ih => + have hnotSelected : ¬ordinal < snapshots.length := by omega + have hmaterializedStarts : StartTableAgrees (materializedDeferredState context) table := by + intro index output hvalue + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + change (materializedDeferredState context).values + (.chainStart lay tree leafIdx chainIdx) = some output at hvalue + rw [materializedDeferredState_chainStart, hcanonical] at hvalue + have hagrees : Coordinate.chainStart lay tree leafIdx chainIdx ∈ + context.state.revealed ∧ + output = table ⟨lay, tree, leafIdx, chainIdx⟩ := by + simpa [publicMaterializedValues, resolvedCompletionValue] using hvalue.symm + exact hagrees.2 + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + apply relTriple_directDelayed_uniform_observed ordinal parameter publicRoot + rightRoot ftsSecret table target n next snapshots observations context leftFuel + rightFuel cache hnotSelected hcompletable hpublished hcanonical + intro output + exact ih output snapshots observations context leftFuel rightFuel bound + cache (by simpa [IsOuterHash] using hbound.2 output) hvalid hcompletable hpublished + hcanonical hchainValid hprivate haligned hbefore htracked hcovered hnoHit hpending hlength + hleftLower hleftUpper hrightLower hbudget + | inr input => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + change HashOutput → OracleComp (OracleWorld + SigningSpec) + RetainedRestResult at next + let plan := purePlanProbingHashQuery parameter input context.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextSnapshots := appendPlannedSnapshot snapshots candidate? context + by_cases hnowSelected : ordinal < nextSnapshots.length + · obtain ⟨candidate, hcandidate⟩ : ∃ candidate, candidate? = some candidate := by + cases hcandidate : candidate? with + | none => + exfalso + apply hnotSelected + simpa [nextSnapshots, appendPlannedSnapshot, hcandidate] using hnowSelected + | some candidate => exact ⟨candidate, rfl⟩ + have hsnapshotLength : snapshots.length = ordinal := by + simp [nextSnapshots, appendPlannedSnapshot, hcandidate] at hnowSelected + omega + let selection : PrivateOrdinalSelection := + ⟨candidate, context, + (snapshots ++ [(⟨candidate, context⟩ : PlannedProbeSnapshot)]).map + PlannedProbeSnapshot.toProbe⟩ + have hselectionCovered : PendingCoveredBy + (selection.candidates.take ordinal) selection.context := by + simpa [selection, hsnapshotLength] using hpending + by_cases hselectionGood : + selection.GoodForRoots target targetOutput rightRoot ordinal + · let selectedComputation := + liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next + have hsame := + relTriple_directDelayed_selected_hash_observed_of_good ordinal + parameter publicRoot rightRoot ftsSecret table target targetOutput hroot input + next snapshots observations context leftFuel cache hsnapshotLength + (by simpa [plan, candidate?, hcandidate] using hselectionGood.1) + hselectionGood.2.1 hselectionGood.2.2.1 hselectionGood.2.2.2.1 + (by simpa [selection, hsnapshotLength] using hselectionGood.2.2.2.2) + hpending hvalid hcompletable hpublished hcanonical + (by rw [← haligned.length_eq]; exact hsnapshotLength) + haligned.map_toProbe_eq.symm hnoHit + have hfuel := + relTriple_indicator_observedMaterializedBoundary_fuel_of_isQueryBoundP + ordinal parameter publicRoot rightRoot ftsSecret table target + selectedComputation observations (materializedDeferredState context) + leftFuel rightFuel bound cache (by + dsimp only [selectedComputation] + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] + exact hbound) + hmaterializedStarts + hleftLower (by omega) + have hglued := SphincsSecurity.relTriple_trans_exists hsame hfuel + apply relTriple_post_mono hglued + intro source actual hrelation + obtain ⟨middle, hfirst, hsecond⟩ := hrelation + exact fun htrue ↦ hsecond (hfirst htrue) + · apply relTriple_of_not_true_mem_support + intro htrue + apply hselectionGood + simpa [selection, plan, candidate?, hcandidate] using + goodForRoots_of_true_mem_directDelayed_selected_hash ordinal parameter + publicRoot rightRoot ftsSecret table target targetOutput input next snapshots + observations context leftFuel cache candidate + (by simpa [plan, candidate?] using hcandidate) + hsnapshotLength (haligned.length_eq.symm.trans hsnapshotLength) hvalid + hcompletable hpublished hcanonical hprivate htrue + · rw [directDelayedSelectedRootIndicator_hash_eq_not_selected ordinal parameter + publicRoot ftsSecret table target rightRoot input next snapshots observations + context leftFuel cache hnotSelected (by + simpa [nextSnapshots] using hnowSelected)] + rw [observedMaterializedBoundary_hash_query_bind] + simp only [map_bind] + let rightContext := materializedDeferredContext context + have hcontextEq : FinalizationContextEq table (some context) + (some rightContext) := + finalizationContextEq_materializedDeferredContext hvalid hcompletable + have hcontextDirect : FinalizationContextLE table context rightContext := + FinalizationContextLE.of_eq hcontextEq + have hrightValues : + (materializedCanonicalContext table + (materializedDeferredState context)).state.values = + context.state.values := by + change (canonicalizeMaterializedValues table rightContext).state.values = + context.state.values + exact canonicalized_right_values_eq_of_finalizationContextLE hcontextDirect rfl + hcanonical + have hplanEq : + purePlanProbingHashQuery parameter input + (materializedCanonicalContext table + (materializedDeferredState context)).state = plan := by + exact purePlanProbingHashQuery_eq_of_values_eq hrightValues parameter input + rw [hplanEq] + have hpublicExecutor : + probingHashQueryAfterRootAwarePublicPlan parameter input + (materializedCanonicalContext table + (materializedDeferredState context)).state plan = + probingHashQueryAfterRootAwarePublicPlan parameter input context.state plan := + probingHashQueryAfterRootAwarePublicPlan_eq_of_values_eq parameter input + hrightValues plan + rw [hpublicExecutor] + let nextObservations := observationsAfterCandidate observations + (materializedDeferredState context) candidate? + let leftStep : ProbComp + (DirectWitnessResult (HashOutput × SplitHashCache)) := + runDirectResolvedWitnessFromTable context leftFuel table + ((probingHashQueryAfterRootAwarePlan parameter input plan).run cache) + let rightStep : ProbComp + (Option (ObservedCleanRunResult (HashOutput × SplitHashCache))) := + runObservedCleanFromTable observations (materializedDeferredState context) + rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input context.state plan).run + cache) + let observe : DeferredContext → Nat → + (HashOutput × SplitHashCache) → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool := + fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret table + target rightRoot (next value.1) laterSnapshots laterObservations nextContext + remaining value.2 + let rightObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List CleanProbeObservation → ProbComp Bool := + fun state remaining output nextCache laterObservations ↦ + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret (next output) + laterObservations state remaining table nextCache + change RelTriple + (leftStep >>= finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) nextSnapshots + nextObservations) + (rightStep >>= fun result ↦ + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter publicRoot ftsSecret + (next result.value.1) result.observations result.state result.remaining + table result.value.2) + SuccessfulObservedIndicatorRel + change RelTriple _ _ BoolImp + have houter : IsOuterHash (.inl (.inr input)) := by simp [IsOuterHash] + have hboundPositive : 0 < bound := by + rcases hbound.1 with hnot | hpositive + · exact (hnot (by simp)).elim + · exact hpositive + have hleftPositive : 0 < leftFuel := by omega + have hnextLength : nextSnapshots.length ≤ ordinal := + Nat.le_of_not_gt hnowSelected + have hcontinue + (hcandidateCompletable : ∀ candidate, + candidate? = some candidate → + candidate.coordinate ∉ context.state.revealed → + DeferredCompletable table + { context with state := + (context.state.addPending candidate.coordinate candidate.candidate) }) + (hnextAligned : SnapshotsObservedAt table nextSnapshots nextObservations) + (hnextNoHit : ∀ observation ∈ nextObservations, + ¬observation.ExistingHiddenHit) : + RelTriple + (leftStep >>= finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + nextSnapshots nextObservations) + (rightStep >>= fun result ↦ + match result with + | none => pure false + | some result => + rightObserve result.state result.remaining result.value.1 + result.value.2 result.observations) + BoolImp := by + have hstep := + relTriple_runDirectResolvedWitness_rootAwarePrivate_observedFinalizationMaterialized + table parameter input context.state plan observations context rightContext + leftFuel rightFuel cache cache rfl hleftPositive (by omega) hcontextEq rfl rfl + rfl (by rfl) (by + intro candidate hcandidate hhidden + exact hcandidateCompletable candidate (by simpa [candidate?] using hcandidate) + hhidden) + have hfinished := + relTriple_bind_finishDirectDelayed_observed_of_spent table context.values + leftFuel rightFuel (if candidate?.isSome then 1 else 0) nextObservations + leftStep rightStep + (canonicalizeDirectDelayedSelectedRootIndicator table observe) rightObserve + nextSnapshots nextObservations + (by simpa [leftStep, rightStep, candidate?, rightContext, + materializedDeferredContext, directDeferredContext] using hstep) (by + intro leftResult rightResult hleftSupport hrightSupport hrelation + rcases hrelation with + ⟨houtput, hfinal, hleftSpent, hrightSpent, hleftTable, + hrightTable, hcache, hrevealed, hmaterialized, hprivateValues, + hrightDirect⟩ + have hinitialPublished : + PublishedValues (materializedDeferredState context) := by + intro coordinate hcoordinate + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact hpublished _ (by simpa using hcoordinate) + | position position => + have hvalue := hpublished (.position position) (by simpa using hcoordinate) + obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hvalue + simp [materializedDeferredState, DeferredContext.positionValue, + houtput] + have hrightDetailed : DirectDetailedResult.done rightResult ∈ support + (runDirectResolvedDetailedFromTable rightContext rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input context.state + plan).run cache)) := by + have hsupported := hrightSupport + dsimp only [rightStep] at hsupported + rw [← map_projectDirectDetailedObserved_rootAwarePublic parameter input + context.state plan observations (materializedDeferredState context) + rightFuel table cache, support_map] at hsupported + obtain ⟨detailed, hdetailed, heq⟩ := hsupported + cases detailed with + | stopped reason => + simp [projectDirectDetailedObserved] at heq + | done found => + simp [projectDirectDetailedObserved, observedResolvedResult] at heq + have hfoundSupport : some found ∈ support + (runDirectResolvedFromTable + (directDeferredContext (materializedDeferredState context)) + rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input + context.state plan).run cache)) := + mem_support_runDirectResolvedFromTable_of_done_detailed + ((probingHashQueryAfterRootAwarePublicPlan parameter input + context.state plan).run cache) + (directDeferredContext (materializedDeferredState context)) + rightFuel table found hdetailed + have hfoundDirect := direct_context_of_mem_runDirectResolvedFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input + context.state plan).run cache) + (materializedDeferredState context) rightFuel table found + hfoundSupport + have hcontextFound : found.context = rightResult.context := by + rw [hfoundDirect, hrightDirect, heq.1] + cases found with + | mk foundContext foundRemaining foundValue foundTable => + cases rightResult with + | mk resultContext resultRemaining resultValue resultTable => + simp only at hcontextFound + subst resultContext + simp only at heq + rcases heq with + ⟨_stateEq, rfl, rfl, rfl, _observationsEq⟩ + simpa [rightContext, materializedDeferredContext] using + hdetailed + have hrightPublished : PublishedValues rightResult.context.state := + publishedValues_of_done_runDirectResolvedDetailedFromTable + (probingHashQueryAfterRootAwarePublicPlan parameter input context.state + plan) + (preservesPublishedValues_probingHashQueryAfterRootAwarePublicPlan + parameter input context.state plan) + rightContext rightFuel table cache rightResult + (by simpa [rightContext, materializedDeferredContext, + directDeferredContext] using hinitialPublished) + hrightDetailed + have hrightTracked : CleanProbeObservationsTrackedBy nextObservations + rightResult.context.state := by + simpa [rightStep, observedResolvedResult] using + cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input context.state + plan).run cache) + observations (materializedDeferredState context) rightFuel table + htracked (observedResolvedResult nextObservations rightResult) + hrightSupport + have hrightCovered : CleanProbeObservationsCoverPending nextObservations + rightResult.context.state := by + simpa [rightStep, observedResolvedResult] using + cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input context.state + plan).run cache) + observations (materializedDeferredState context) rightFuel table + hcovered (observedResolvedResult nextObservations rightResult) + hrightSupport + have hrightBudget : rightResult.remaining + + rightResult.context.state.pending.card < Fintype.card Digest := by + have hremaining := + remaining_add_pending_card_le_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input context.state + plan).run cache) + observations (materializedDeferredState context) rightFuel table + (observedResolvedResult nextObservations rightResult) hrightSupport + simpa [observedResolvedResult] using hremaining.trans_lt hbudget + have hleftDetailed : DirectDetailedResult.done leftResult ∈ support + (runDirectResolvedDetailedFromTable context leftFuel table + ((probingHashQueryAfterRootAwarePlan parameter input plan).run cache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterRootAwarePlan parameter input plan).run cache) + context leftFuel table, support_map] + exact ⟨.done leftResult, by simpa [leftStep] using hleftSupport, rfl⟩ + have hleftDirect : some leftResult ∈ support + (runDirectResolvedFromTable context leftFuel table + ((probingHashQueryAfterRootAwarePlan parameter input plan).run cache)) := + mem_support_runDirectResolvedFromTable_of_done_detailed + ((probingHashQueryAfterRootAwarePlan parameter input plan).run cache) + context leftFuel table leftResult hleftDetailed + have hpreservesLeft : PreservesChainValid (fun _ ↦ True) + (probingHashQueryAfterRootAwarePlan parameter input plan) := by + have hclosed : ChainForwardClosed (fun _ ↦ True) := by + intro candidate _hallowed _houtput + trivial + unfold probingHashQueryAfterRootAwarePlan + cases hcandidateRoot : rootAwareCandidateForPlan? parameter input plan with + | none => + simp only [executeCandidate?, pure_bind] + cases plan.action with + | ordinary => + exact preservesChainValid_splitHashQuery_ordinary (fun _ ↦ True) + input + | resolve coordinate => + exact preservesChainValid_resolveKnownInput (fun _ ↦ True) hclosed + parameter coordinate input + | some candidate => + apply (preservesChainValid_probe (fun _ ↦ True) candidate).bind + intro _ + cases plan.action with + | ordinary => + exact preservesChainValid_splitHashQuery_ordinary (fun _ ↦ True) + input + | resolve coordinate => + exact preservesChainValid_resolveKnownInput (fun _ ↦ True) hclosed + parameter coordinate input + have hleftChainValid : ChainState.ValidFor (fun _ ↦ True) + leftResult.context.state := + chainValid_of_mem_runDirectResolvedFromTable (fun _ ↦ True) + (probingHashQueryAfterRootAwarePlan parameter input plan) context + leftFuel table cache leftResult hpreservesLeft hchainValid hleftDirect + have hrightChainStarts : ∀ lay tree leafIdx chainIdx, + (rightResult.context.state.values + (.chainStart lay tree leafIdx chainIdx) ≠ none → + .chainStart lay tree leafIdx chainIdx ∈ + rightResult.context.state.revealed) ∧ + (.chainStart lay tree leafIdx chainIdx ∈ + rightResult.context.state.revealed → + rightResult.context.state.values + (.chainStart lay tree leafIdx chainIdx) ≠ none) := by + intro lay tree leafIdx chainIdx + have hleft := hleftChainValid (.chainStart lay tree leafIdx chainIdx) + (by simp [IsChainCoordinate]) + have hvalue := congrFun hmaterialized + (.chainStart lay tree leafIdx chainIdx) + have hvalue' : leftResult.context.state.values + (.chainStart lay tree leafIdx chainIdx) = + rightResult.context.state.values + (.chainStart lay tree leafIdx chainIdx) := by + simpa using hvalue + constructor + · intro hsome + have hleftSome : leftResult.context.state.values + (.chainStart lay tree leafIdx chainIdx) ≠ none := by + rw [hvalue'] + exact hsome + rw [← hrevealed] + exact hleft.1 hleftSome + · intro hrightRevealed + have hleftRevealed : .chainStart lay tree leafIdx chainIdx ∈ + leftResult.context.state.revealed := by + simpa [hrevealed] using hrightRevealed + have hleftSome := hleft.2.1 hleftRevealed + rw [← hvalue'] + exact hleftSome + let canonical := canonicalizeMaterializedValues table rightResult.context + have hrightCompletable : DeferredCompletable table rightResult.context := + (FinalizationContextLE.of_eq hfinal).rightCompletable + have hcanonicalFacts := valid_completable_canonicalizeMaterializedValues + table rightResult.context hfinal.2.2.1 hrightCompletable + have hcanonicalPublished : PublishedValues canonical.state := + hrightPublished.to_canonicalizedMaterializedValues + have hcanonicalCanonical : CanonicalMaterializedValues table canonical := + canonicalizeMaterializedValues_canonical table rightResult.context + hfinal.1.rightConsistent + have hcanonicalState : materializedDeferredState canonical = + rightResult.context.state := by + have heq := materializedDeferredState_canonicalize_direct_eq_of_chainStarts + table rightResult.context.state hfinal.1.rightStarts hrightChainStarts + dsimp only [canonical] + rw [hrightDirect] + exact heq + have hcanonicalChainValid : ChainState.ValidFor (fun _ ↦ True) + canonical.state := by + intro coordinate hcoordinate + constructor + · intro hsome + by_contra hhidden + have hhiddenRight : coordinate ∉ rightResult.context.state.revealed := by + simpa [canonical, canonicalizeMaterializedValues_revealed] using hhidden + change publicMaterializedValues table rightResult.context coordinate ≠ none + at hsome + simp [publicMaterializedValues, hhiddenRight] at hsome + · exact ⟨hcanonicalPublished coordinate, fun _ ↦ trivial⟩ + have hleftPrivate : leftResult.context.values target = + some targetOutput := + hprivateValues target targetOutput hprivate + have hleftMaterializedTarget : + (materializedDeferredState leftResult.context).values + (.position target) = some targetOutput := by + rw [materializedDeferredState_position] + unfold DeferredContext.positionValue + cases hstate : leftResult.context.state.values (.position target) with + | none => simp [hstate, hleftPrivate] + | some existing => + have hagrees := hfinal.1.leftConsistent target existing hstate + rw [hleftPrivate] at hagrees + cases Option.some.inj hagrees + simp [hstate] + have hrightTarget : rightResult.context.state.values (.position target) = + some targetOutput := by + rw [← congrFun hmaterialized (.position target)] + exact hleftMaterializedTarget + have hcanonicalPrivate : canonical.values target = some targetOutput := by + change rightResult.context.values target = some targetOutput + rw [hrightDirect] + simpa [directDeferredContext, directDeferredValues] using hrightTarget + have hcanonicalPending : PendingCoveredBy + (nextSnapshots.map PlannedProbeSnapshot.toProbe) canonical := by + intro entry hentry + have hentryRight : entry ∈ rightResult.context.state.pending := by + simpa [canonical, canonicalizeMaterializedValues_pending] using hentry + obtain ⟨observation, hobservation, hcoordinate, hcand, _hhidden⟩ := + hrightCovered entry hentryRight + refine ⟨observation.toProbe, ?_, hcoordinate, hcand⟩ + rw [hnextAligned.map_toProbe_eq] + exact List.mem_map.mpr ⟨observation, hobservation, rfl⟩ + have hcontextMaterialized : PrivateValuesLE context rightContext := by + intro position output hvalue + change context.positionValue position = some output + unfold DeferredContext.positionValue + cases hstate : context.state.values (.position position) with + | none => simp [hstate, hvalue] + | some existing => + have hagrees := hvalid.valuesConsistent position existing hstate + rw [hvalue] at hagrees + cases Option.some.inj hagrees + simp [hstate] + have hmaterializedToRight : PrivateValuesLE rightContext + rightResult.context := + privateValuesLE_of_done_runDirectResolvedDetailedFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input context.state + plan).run cache) + rightContext rightFuel table rightResult hrightDetailed + have hrightRevealedSubset : context.state.revealed ⊆ + rightResult.context.state.revealed := by + have hsubset := revealed_subset_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input context.state + plan).run cache) + observations (materializedDeferredState context) rightFuel table + (observedResolvedResult nextObservations rightResult) hrightSupport + simpa [observedResolvedResult] using hsubset + have hcanonicalBefore : SnapshotsBefore nextSnapshots canonical := by + simpa [nextSnapshots] using + (((hbefore.appendPlannedSnapshot candidate?).trans + hrightRevealedSubset + (hcontextMaterialized.trans hmaterializedToRight)).canonicalize_right + table) + have hleftPublished : PublishedValues leftResult.context.state := + publishedValues_of_done_runDirectResolvedWitnessFromTable + (probingHashQueryAfterRootAwarePlan parameter input plan) + (preservesPublishedValues_probingHashQueryAfterRootAwarePlan parameter + input plan) + context leftFuel table cache leftResult hpublished + (by simpa [leftStep] using hleftSupport) + letI : ObserverSynchronized table + (negatedDirectDelayedObserve observe nextSnapshots nextObservations) := + ⟨by + intro nextLeft nextRight remaining value hnextContext hnextValues + hnextRevealed + have hlaws := negatedDirectDelayedComputationObserve_observerLaws + ordinal parameter publicRoot ftsSecret table target rightRoot + (next value.1) nextSnapshots nextObservations hnextLength + hnextAligned.map_toProbe_eq.symm hnextNoHit + letI : ObserverSynchronized table + (negatedDirectDelayedComputationObserve ordinal parameter publicRoot + ftsSecret table target rightRoot (next value.1) nextSnapshots + nextObservations) := hlaws.1 + simpa [observe, negatedDirectDelayedObserve, + negatedDirectDelayedComputationObserve] using + ObserverSynchronized.eq_of_synchronized + (table := table) + (observe := negatedDirectDelayedComputationObserve ordinal parameter + publicRoot ftsSecret table target rightRoot (next value.1) + nextSnapshots nextObservations) + nextLeft nextRight remaining value.2 hnextContext hnextValues + hnextRevealed⟩ + let leftCanonicalRun := + canonicalizeDirectDelayedSelectedRootIndicator table observe + leftResult.context leftResult.remaining leftResult.value nextSnapshots + nextObservations + let rightCanonicalRun := + canonicalizeDirectDelayedSelectedRootIndicator table observe + rightResult.context leftResult.remaining leftResult.value nextSnapshots + nextObservations + have hnegatedEq : evalDist (Bool.not <$> leftCanonicalRun) = + evalDist (Bool.not <$> rightCanonicalRun) := + evalDist_negatedCanonicalizeDirectDelayedObserve_eq_of_finalizationContextEq_published + table observe nextSnapshots nextObservations leftResult.context + rightResult.context leftResult.remaining leftResult.value hfinal hrevealed + hleftPublished hrightPublished + have hnegatedRel : RelTriple (Bool.not <$> rightCanonicalRun) + (Bool.not <$> leftCanonicalRun) (EqRel Bool) := by + apply relTriple_of_evalDist_eq_right hnegatedEq.symm + exact relTriple_refl _ + have hnegatedImp : RelTriple (Bool.not <$> rightCanonicalRun) + (Bool.not <$> leftCanonicalRun) BoolImp := by + apply relTriple_post_mono hnegatedRel + intro rightNot leftNot heq htrue + rw [heq] at htrue + exact htrue + have hcanonicalBridge : RelTriple leftCanonicalRun rightCanonicalRun + BoolImp := + relTriple_boolImp_of_not_reverse leftCanonicalRun rightCanonicalRun + hnegatedImp + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hcanonicalFacts.2 + have hrightCanonicalEq : rightCanonicalRun = + directDelayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret + table target rightRoot (next leftResult.value.1) nextSnapshots + nextObservations canonical leftResult.remaining leftResult.value.2 := by + unfold rightCanonicalRun + canonicalizeDirectDelayedSelectedRootIndicator + simp only [canonical, hnotPrivate, hrightPublished, hcanonicalFacts.2, + ↓reduceIte] + rfl + rw [hrightCanonicalEq, houtput, hcache] at hcanonicalBridge + have hspentLe : (if candidate?.isSome then 1 else 0) ≤ 1 := by + split <;> omega + have hrecursive := ih rightResult.value.1 nextSnapshots nextObservations + canonical leftResult.remaining rightResult.remaining (bound - 1) + rightResult.value.2 + (by simpa [IsOuterHash] using hbound.2 rightResult.value.1) + hcanonicalFacts.1 hcanonicalFacts.2 hcanonicalPublished + hcanonicalCanonical hcanonicalChainValid hcanonicalPrivate hnextAligned + hcanonicalBefore + (by rw [hcanonicalState]; exact hrightTracked) + (by rw [hcanonicalState]; exact hrightCovered) + hnextNoHit hcanonicalPending hnextLength + (by omega) (by omega) (by omega) + (by rw [hcanonicalState]; exact hrightBudget) + have hrecursive' : RelTriple + (directDelayedSelectedRootIndicator ordinal parameter publicRoot + ftsSecret table target rightRoot (next rightResult.value.1) + nextSnapshots nextObservations canonical leftResult.remaining + rightResult.value.2) + (rightObserve rightResult.context.state rightResult.remaining + rightResult.value.1 rightResult.value.2 nextObservations) BoolImp := by + change RelTriple _ _ BoolImp at hrecursive + simpa [rightObserve, hcanonicalState] using hrecursive + have hglued := SphincsSecurity.relTriple_trans_exists hcanonicalBridge + hrecursive' + apply relTriple_post_mono hglued + intro leftValue rightValue hrelation + obtain ⟨middle, hleftMiddle, hmiddleRight⟩ := hrelation + exact fun htrue ↦ hmiddleRight (hleftMiddle htrue)) + refine relTriple_of_evalDist_eq_right ?_ hfinished + apply congrArg evalDist + apply bind_congr + intro result + cases result <;> rfl + have htoGoal + (hbase : RelTriple + (leftStep >>= finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + nextSnapshots nextObservations) + (rightStep >>= fun result ↦ + match result with + | none => pure false + | some result => + rightObserve result.state result.remaining result.value.1 + result.value.2 result.observations) + BoolImp) : + RelTriple + (leftStep >>= finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table observe) + nextSnapshots nextObservations) + (rightStep >>= fun result ↦ + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter publicRoot ftsSecret + (next result.value.1) result.observations result.state + result.remaining table result.value.2) + BoolImp := by + refine relTriple_of_evalDist_eq_right ?_ hbase + apply congrArg evalDist + apply bind_congr + intro result + cases result with + | none => + simp [rightObserve, successfulObservedRootComparisonIndicator, + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + | some result => rfl + cases hcandidate : candidate? with + | none => + have hnextSnapshotsEq : nextSnapshots = snapshots := by + simp [nextSnapshots, hcandidate, appendPlannedSnapshot] + have hnextObservationsEq : nextObservations = observations := by + simp [nextObservations, hcandidate, observationsAfterCandidate] + apply htoGoal + apply hcontinue + · intro candidate hsome _hhidden + simp [hcandidate] at hsome + · simpa [hnextSnapshotsEq, hnextObservationsEq] using haligned + · simpa [hnextObservationsEq] using hnoHit + | some candidate => + let actualNextObservations := observations ++ + [cleanProbeObservation (materializedDeferredState context) + candidate.coordinate candidate.candidate] + have hnextObservationsEq : nextObservations = actualNextObservations := by + simp [nextObservations, candidate?, hcandidate, actualNextObservations, + observationsAfterCandidate] + have hnextAligned : SnapshotsObservedAt table nextSnapshots + nextObservations := by + rw [hnextObservationsEq] + simpa [actualNextObservations, nextSnapshots, candidate?, hcandidate, + observationsAfterCandidate, appendPlannedSnapshot] using + (haligned.appendCandidate (some candidate) hcontextDirect rfl hpublished + hcanonical) + by_cases hcandidateRevealed : + candidate.coordinate ∈ context.state.revealed + · have hnewNoHit : + ¬(cleanProbeObservation (materializedDeferredState context) + candidate.coordinate candidate.candidate).ExistingHiddenHit := by + rintro ⟨hhidden, _output, _hvalue, _hcandidate⟩ + simp [cleanProbeObservation, hcandidateRevealed] at hhidden + have hnextNoHit : ∀ observation ∈ nextObservations, + ¬observation.ExistingHiddenHit := by + rw [hnextObservationsEq] + intro observation hobservation + simp only [actualNextObservations, List.mem_append, + List.mem_singleton] at hobservation + rcases hobservation with hold | rfl + · exact hnoHit observation hold + · exact hnewNoHit + apply htoGoal + apply hcontinue + · intro other hother hhidden + have heq : other = candidate := by + apply Option.some.inj + exact hother.symm.trans (by simpa [candidate?] using hcandidate) + subst other + exact (hhidden hcandidateRevealed).elim + · exact hnextAligned + · exact hnextNoHit + · let postContext : DeferredContext := + { context with state := + context.state.addPending candidate.coordinate candidate.candidate } + by_cases hpostCompletable : DeferredCompletable table postContext + · have hrightPostCompletable : DeferredCompletable table + { rightContext with state := + (rightContext.state.addPending candidate.coordinate + candidate.candidate) } := by + exact (deferredCompletable_addPending_iff_of_finalizationViewEq + hcontextEq.1 candidate.coordinate candidate.candidate).mp + (by simpa [postContext] using hpostCompletable) + have hnewNoHit : + ¬(cleanProbeObservation (materializedDeferredState context) + candidate.coordinate candidate.candidate).ExistingHiddenHit := by + simpa [rightContext, materializedDeferredContext, + directDeferredContext] using + (not_existingHiddenHit_cleanProbeObservation_of_addPending_completable + table rightContext candidate hrightPostCompletable) + have hnextNoHit : ∀ observation ∈ nextObservations, + ¬observation.ExistingHiddenHit := by + rw [hnextObservationsEq] + intro observation hobservation + simp only [actualNextObservations, List.mem_append, + List.mem_singleton] at hobservation + rcases hobservation with hold | rfl + · exact hnoHit observation hold + · exact hnewNoHit + apply htoGoal + apply hcontinue + · intro other hother _hhidden + have heq : other = candidate := by + apply Option.some.inj + exact hother.symm.trans (by simpa [candidate?] using hcandidate) + subst other + simpa [postContext] using hpostCompletable + · exact hnextAligned + · exact hnextNoHit + · apply relTriple_of_not_true_mem_support + intro htrue + rw [mem_support_bind_iff] at htrue + obtain ⟨step, hstepSupport, hfinishSupport⟩ := htrue + cases step with + | stoppedFuel => + simp [finishDirectDelayedSelectedRootIndicator] at hfinishSupport + | stoppedOrdinary => + simp [finishDirectDelayedSelectedRootIndicator] at hfinishSupport + | stoppedPrivate witness => + simp [finishDirectDelayedSelectedRootIndicator] at hfinishSupport + | done result => + cases leftFuel with + | zero => omega + | succ remaining => + have hcandidateRoot : rootAwareCandidateForPlan? parameter input + plan = some candidate := by + simpa [candidate?] using hcandidate + have hpostSupport : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable postContext remaining table + ((probingHashQueryPublicAction parameter input context.state + plan.action).run cache)) := by + dsimp only [leftStep] at hstepSupport + rw [runDirectResolvedWitnessFromTable_rootAwarePrivate_eq_public + parameter input plan context (remaining + 1) table cache] + at hstepSupport + unfold probingHashQueryAfterRootAwarePublicPlan at hstepSupport + rw [StateT.run_bind, runDirectResolvedWitnessFromTable_bind] + at hstepSupport + simp only [hcandidateRoot, executeCandidate?, probe, + StateT.run_liftM, LazyRevealProbe.probeQuery, + runDirectResolvedWitnessFromTable_probe_query_bind, + hcandidateRevealed, ↓reduceIte] at hstepSupport + rw [show + runDirectResolvedWitnessFromTable postContext remaining table + (pure ((), cache)) = + pure (.done ⟨postContext, remaining, ((), cache), table⟩) by + simp [runDirectResolvedWitnessFromTable]] at hstepSupport + simp only [pure_bind] at hstepSupport + simpa [postContext] using hstepSupport + have hpostDetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable postContext remaining table + ((probingHashQueryPublicAction parameter input context.state + plan.action).run cache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((probingHashQueryPublicAction parameter input context.state + plan.action).run cache) + postContext remaining table, support_map] + exact ⟨.done result, hpostSupport, rfl⟩ + have hpostDirect : some result ∈ support + (runDirectResolvedFromTable postContext remaining table + ((probingHashQueryPublicAction parameter input context.state + plan.action).run cache)) := + mem_support_runDirectResolvedFromTable_of_done_detailed + ((probingHashQueryPublicAction parameter input context.state + plan.action).run cache) + postContext remaining table result hpostDetailed + have hpostConsistent : postContext.ValuesConsistent := by + intro position output hvalue + exact hvalid.1 position output (by + simpa [postContext, LazyRevealProbe.State.addPending] using + hvalue) + have hpostStarts : StartTableAgrees postContext.state table := by + intro index output hvalue + exact hcontextEq.1.leftStarts index output (by + simpa [postContext, LazyRevealProbe.State.addPending] using + hvalue) + have hresultCore := resolvedCore_of_mem_runDirectResolvedFromTable + ((probingHashQueryPublicAction parameter input context.state + plan.action).run cache) + postContext remaining table result hpostConsistent + hpostStarts hpostDirect + have hresultNotCompletable : + ¬DeferredCompletable table result.context := + not_deferredCompletable_of_mem_runDirectResolvedFromTable + ((probingHashQueryPublicAction parameter input context.state + plan.action).run cache) + postContext remaining table result hpostConsistent + hpostStarts hpostDirect (by + simpa [postContext] using hpostCompletable) + have hcanonicalDoomed := + doomedResolvedContext_canonicalizeMaterializedValues + (⟨hresultCore.2.1, hresultCore.2.2, + hresultNotCompletable⟩ : DoomedResolvedContext table + result.context) + simp [finishDirectDelayedSelectedRootIndicator, + canonicalizeDirectDelayedSelectedRootIndicator, + hcanonicalDoomed.2.2] at hfinishSupport + | inr message => + rw [simulateQ_expandedAdversaryImpl_query_bind_inr] at hbound + change Option Signature → OracleComp (OracleWorld + SigningSpec) + RetainedRestResult at next + rw [directDelayedSelectedRootIndicator_signing_eq ordinal parameter publicRoot + ftsSecret table target rightRoot message next snapshots observations context leftFuel + cache hnotSelected] + rw [observedMaterializedBoundary_sign_query_bind] + simp only [map_bind] + let rightContext := materializedDeferredContext context + have hcontextEq : FinalizationContextEq table (some context) (some rightContext) := by + exact finalizationContextEq_materializedDeferredContext hvalid hcompletable + have hstep := + (directWitnessFinalizationMaterializedCouples_maskedSign table parameter publicRoot + ftsSecret message) context rightContext leftFuel rightFuel cache cache hcontextEq rfl + rfl rfl (by rfl) + let observe : DeferredContext → Nat → + (Option Signature × SplitHashCache) → List PlannedProbeSnapshot → + List CleanProbeObservation → ProbComp Bool := + fun nextContext remaining value laterSnapshots laterObservations => + directDelayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret table + target rightRoot (next value.1) laterSnapshots laterObservations nextContext + remaining value.2 + let rightObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List CleanProbeObservation → ProbComp Bool := + fun state remaining signature nextCache laterObservations => + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret (next signature) + laterObservations state remaining table nextCache + have hfinishProgram := runDirectDetailed_finish_eq_runObservedClean_finish + ((maskedSign parameter publicRoot ftsSecret message).run cache) observations + (materializedDeferredState context) rightFuel table rightObserve + (maskedSign_probeFree parameter publicRoot ftsSecret message cache) + have hrightProgram : + (runObservedCleanFromTable observations (materializedDeferredState context) + rightFuel table ((maskedSign parameter publicRoot ftsSecret message).run cache) >>= + fun result => match result with + | none => pure false + | some result => rightObserve result.state result.remaining result.value.1 + result.value.2 result.observations) = + (runObservedCleanFromTable observations (materializedDeferredState context) + rightFuel table ((maskedSign parameter publicRoot ftsSecret message).run cache) >>= + fun result => + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) <$> match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter publicRoot ftsSecret + (next result.value.1) result.observations result.state result.remaining + table result.value.2) := by + apply bind_congr + intro result + cases result with + | none => + simp [rightObserve, successfulObservedRootComparisonIndicator, + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + | some result => rfl + dsimp only [rightContext, materializedDeferredContext] at hstep + change RelTriple _ + (runObservedCleanFromTable observations (materializedDeferredState context) + rightFuel table ((maskedSign parameter publicRoot ftsSecret message).run cache) >>= + fun result => + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) <$> match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter publicRoot ftsSecret + (next result.value.1) result.observations result.state result.remaining table + result.value.2) + SuccessfulObservedIndicatorRel + change RelTriple _ _ BoolImp + have hcoupled := relTriple_finishDirectWitness_directDetailed table context.values + leftFuel rightFuel + (runDirectResolvedWitnessFromTable context leftFuel table + ((maskedSign parameter publicRoot ftsSecret message).run cache)) + (runDirectResolvedDetailedFromTable + (directDeferredContext (materializedDeferredState context)) rightFuel table + ((maskedSign parameter publicRoot ftsSecret message).run cache)) + (canonicalizeDirectDelayedSelectedRootIndicator table observe) rightObserve snapshots + observations hstep + have hbase := hcoupled (by + intro leftResult rightResult hleftSupport hrightSupport hrelation + rcases hrelation with + ⟨houtput, hfinal, hleftRemaining, hrightRemaining, hleftTable, + hrightTable, hcache, hrevealed, hmaterialized, hprivateValues, + hrightDirect⟩ + have hrightObserved : some (observedResolvedResult observations rightResult) ∈ + support (runObservedCleanFromTable observations + (materializedDeferredState context) rightFuel table + ((maskedSign parameter publicRoot ftsSecret message).run cache)) := by + rw [← map_observedResultOfDetailed_run_eq_observed_of_probeFree + ((maskedSign parameter publicRoot ftsSecret message).run cache) observations + (materializedDeferredState context) rightFuel table + (maskedSign_probeFree parameter publicRoot ftsSecret message cache), support_map] + exact ⟨.done rightResult, hrightSupport, rfl⟩ + have hinitialPublished : PublishedValues (materializedDeferredState context) := by + intro coordinate hcoordinate + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact hpublished _ (by simpa using hcoordinate) + | position position => + have hvalue := hpublished (.position position) (by simpa using hcoordinate) + obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hvalue + simp [materializedDeferredState, DeferredContext.positionValue, houtput] + have hrightPublished : PublishedValues rightResult.context.state := + publishedValues_of_done_runDirectResolvedDetailedFromTable + (maskedSign parameter publicRoot ftsSecret message) + (preservesPublishedValues_maskedSign parameter publicRoot ftsSecret message) + (directDeferredContext (materializedDeferredState context)) rightFuel table cache + rightResult (by simpa [directDeferredContext] using hinitialPublished) + hrightSupport + have hrightTracked : CleanProbeObservationsTrackedBy observations + rightResult.context.state := by + simpa [observedResolvedResult] using + cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((maskedSign parameter publicRoot ftsSecret message).run cache) observations + (materializedDeferredState context) rightFuel table htracked + (observedResolvedResult observations rightResult) hrightObserved + have hrightCovered : CleanProbeObservationsCoverPending observations + rightResult.context.state := by + simpa [observedResolvedResult] using + cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((maskedSign parameter publicRoot ftsSecret message).run cache) observations + (materializedDeferredState context) rightFuel table hcovered + (observedResolvedResult observations rightResult) hrightObserved + have hrightBudget : rightResult.remaining + + rightResult.context.state.pending.card < Fintype.card Digest := by + have hremaining := remaining_add_pending_card_le_of_mem_runObservedCleanFromTable + ((maskedSign parameter publicRoot ftsSecret message).run cache) observations + (materializedDeferredState context) rightFuel table + (observedResolvedResult observations rightResult) hrightObserved + simpa [observedResolvedResult] using hremaining.trans_lt hbudget + have hleftDetailed : DirectDetailedResult.done leftResult ∈ support + (runDirectResolvedDetailedFromTable context leftFuel table + ((maskedSign parameter publicRoot ftsSecret message).run cache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((maskedSign parameter publicRoot ftsSecret message).run cache) context leftFuel + table, support_map] + exact ⟨.done leftResult, hleftSupport, rfl⟩ + have hleftDirect : some leftResult ∈ support + (runDirectResolvedFromTable context leftFuel table + ((maskedSign parameter publicRoot ftsSecret message).run cache)) := + mem_support_runDirectResolvedFromTable_of_done_detailed + ((maskedSign parameter publicRoot ftsSecret message).run cache) context leftFuel + table leftResult hleftDetailed + have hleftChainValid : ChainState.ValidFor (fun _ ↦ True) + leftResult.context.state := + chainValid_of_mem_runDirectResolvedFromTable (fun _ ↦ True) + (maskedSign parameter publicRoot ftsSecret message) context leftFuel table cache + leftResult + (preservesChainValid_maskedSign_true parameter publicRoot ftsSecret message) + hchainValid hleftDirect + have hrightChainStarts : ∀ lay tree leafIdx chainIdx, + (rightResult.context.state.values (.chainStart lay tree leafIdx chainIdx) ≠ none → + .chainStart lay tree leafIdx chainIdx ∈ rightResult.context.state.revealed) ∧ + (.chainStart lay tree leafIdx chainIdx ∈ rightResult.context.state.revealed → + rightResult.context.state.values (.chainStart lay tree leafIdx chainIdx) ≠ + none) := by + intro lay tree leafIdx chainIdx + have hleft := hleftChainValid (.chainStart lay tree leafIdx chainIdx) + (by simp [IsChainCoordinate]) + have hvalue := congrFun hmaterialized (.chainStart lay tree leafIdx chainIdx) + have hvalue' : leftResult.context.state.values + (.chainStart lay tree leafIdx chainIdx) = + rightResult.context.state.values + (.chainStart lay tree leafIdx chainIdx) := by + simpa using hvalue + constructor + · intro hsome + have hleftSome : leftResult.context.state.values + (.chainStart lay tree leafIdx chainIdx) ≠ none := by + rw [hvalue'] + exact hsome + rw [← hrevealed] + exact hleft.1 hleftSome + · intro hrightRevealed + have hleftRevealed : .chainStart lay tree leafIdx chainIdx ∈ + leftResult.context.state.revealed := by simpa [hrevealed] using hrightRevealed + have hleftSome := hleft.2.1 hleftRevealed + rw [← hvalue'] + exact hleftSome + let canonical := canonicalizeMaterializedValues table rightResult.context + have hrightCompletable : DeferredCompletable table rightResult.context := + (FinalizationContextLE.of_eq hfinal).rightCompletable + have hcanonicalFacts := valid_completable_canonicalizeMaterializedValues table + rightResult.context hfinal.2.2.1 hrightCompletable + have hcanonicalPublished : PublishedValues canonical.state := by + exact hrightPublished.to_canonicalizedMaterializedValues + have hcanonicalCanonical : CanonicalMaterializedValues table canonical := by + exact canonicalizeMaterializedValues_canonical table rightResult.context + hfinal.1.rightConsistent + have hcanonicalState : materializedDeferredState canonical = + rightResult.context.state := by + have heq := materializedDeferredState_canonicalize_direct_eq_of_chainStarts table + rightResult.context.state hfinal.1.rightStarts hrightChainStarts + dsimp only [canonical] + rw [hrightDirect] + exact heq + have hcanonicalChainValid : ChainState.ValidFor (fun _ ↦ True) + canonical.state := by + intro coordinate hcoordinate + constructor + · intro hsome + by_contra hhidden + have hhiddenRight : coordinate ∉ rightResult.context.state.revealed := by + simpa [canonical, canonicalizeMaterializedValues_revealed] using hhidden + change publicMaterializedValues table rightResult.context coordinate ≠ none at hsome + simp [publicMaterializedValues, hhiddenRight] at hsome + · exact ⟨hcanonicalPublished coordinate, fun _ ↦ trivial⟩ + have hleftPrivate : leftResult.context.values target = some targetOutput := + hprivateValues target targetOutput hprivate + have hleftMaterializedTarget : + (materializedDeferredState leftResult.context).values (.position target) = + some targetOutput := by + rw [materializedDeferredState_position] + unfold DeferredContext.positionValue + cases hstate : leftResult.context.state.values (.position target) with + | none => simp [hstate, hleftPrivate] + | some existing => + have hagrees := hfinal.1.leftConsistent target existing hstate + rw [hleftPrivate] at hagrees + cases Option.some.inj hagrees + simp [hstate] + have hrightTarget : rightResult.context.state.values (.position target) = + some targetOutput := by + rw [← congrFun hmaterialized (.position target)] + exact hleftMaterializedTarget + have hcanonicalPrivate : canonical.values target = some targetOutput := by + change rightResult.context.values target = some targetOutput + rw [hrightDirect] + simpa [directDeferredContext, directDeferredValues] using hrightTarget + have hrightPendingSubset : rightResult.context.state.pending ⊆ + (directDeferredContext (materializedDeferredState context)).state.pending := + pending_subset_of_done_runDirectResolvedDetailedFromTable_of_probeFree + ((maskedSign parameter publicRoot ftsSecret message).run cache) + (directDeferredContext (materializedDeferredState context)) rightFuel table + rightResult (maskedSign_probeFree parameter publicRoot ftsSecret message cache) + hrightSupport + have hcanonicalPending : PendingCoveredBy + (snapshots.map PlannedProbeSnapshot.toProbe) canonical := by + apply (pendingCoveredBy_canonicalize_iff table + (snapshots.map PlannedProbeSnapshot.toProbe) rightResult.context).2 + apply hpending.of_subset + intro entry hentry + have := hrightPendingSubset hentry + simpa [directDeferredContext, materializedDeferredState] using this + have hcontextMaterialized : PrivateValuesLE context + (directDeferredContext (materializedDeferredState context)) := by + intro position output hvalue + change context.positionValue position = some output + unfold DeferredContext.positionValue + cases hstate : context.state.values (.position position) with + | none => simp [hstate, hvalue] + | some existing => + have hagrees := hvalid.valuesConsistent position existing hstate + rw [hvalue] at hagrees + cases Option.some.inj hagrees + simp [hstate] + have hmaterializedToRight : PrivateValuesLE + (directDeferredContext (materializedDeferredState context)) + rightResult.context := + privateValuesLE_of_done_runDirectResolvedDetailedFromTable + ((maskedSign parameter publicRoot ftsSecret message).run cache) + (directDeferredContext (materializedDeferredState context)) rightFuel table + rightResult hrightSupport + have hrightRevealedSubset : context.state.revealed ⊆ + rightResult.context.state.revealed := by + have hsubset := revealed_subset_of_mem_runObservedCleanFromTable + ((maskedSign parameter publicRoot ftsSecret message).run cache) observations + (materializedDeferredState context) rightFuel table + (observedResolvedResult observations rightResult) hrightObserved + simpa [observedResolvedResult] using hsubset + have hcanonicalBefore : SnapshotsBefore snapshots canonical := + (hbefore.trans hrightRevealedSubset + (hcontextMaterialized.trans hmaterializedToRight)).canonicalize_right table + have hleftPublished : PublishedValues leftResult.context.state := + publishedValues_of_done_runDirectResolvedWitnessFromTable + (maskedSign parameter publicRoot ftsSecret message) + (preservesPublishedValues_maskedSign parameter publicRoot ftsSecret message) + context leftFuel table cache leftResult hpublished hleftSupport + letI : ObserverSynchronized table + (negatedDirectDelayedObserve observe snapshots observations) := ⟨by + intro nextLeft nextRight remaining value hnextContext hnextValues hnextRevealed + have hlaws := negatedDirectDelayedComputationObserve_observerLaws ordinal parameter + publicRoot ftsSecret table target rightRoot (next value.1) snapshots observations + hlength haligned.map_toProbe_eq.symm hnoHit + letI : ObserverSynchronized table + (negatedDirectDelayedComputationObserve ordinal parameter publicRoot ftsSecret + table target rightRoot (next value.1) snapshots observations) := hlaws.1 + simpa [observe, negatedDirectDelayedObserve, + negatedDirectDelayedComputationObserve] using + ObserverSynchronized.eq_of_synchronized + (table := table) + (observe := negatedDirectDelayedComputationObserve ordinal parameter + publicRoot ftsSecret table target rightRoot (next value.1) + snapshots observations) + nextLeft nextRight remaining value.2 hnextContext hnextValues hnextRevealed⟩ + let leftCanonicalRun := canonicalizeDirectDelayedSelectedRootIndicator table observe + leftResult.context leftResult.remaining leftResult.value snapshots observations + let rightCanonicalRun := canonicalizeDirectDelayedSelectedRootIndicator table observe + rightResult.context leftResult.remaining leftResult.value snapshots observations + have hnegatedEq : evalDist (Bool.not <$> leftCanonicalRun) = + evalDist (Bool.not <$> rightCanonicalRun) := by + exact evalDist_negatedCanonicalizeDirectDelayedObserve_eq_of_finalizationContextEq_published + table observe snapshots observations leftResult.context rightResult.context + leftResult.remaining leftResult.value hfinal hrevealed hleftPublished + hrightPublished + have hnegatedRel : RelTriple (Bool.not <$> rightCanonicalRun) + (Bool.not <$> leftCanonicalRun) (EqRel Bool) := by + apply relTriple_of_evalDist_eq_right hnegatedEq.symm + exact relTriple_refl _ + have hnegatedImp : RelTriple (Bool.not <$> rightCanonicalRun) + (Bool.not <$> leftCanonicalRun) BoolImp := by + apply relTriple_post_mono hnegatedRel + intro rightNot leftNot heq + intro htrue + rw [heq] at htrue + exact htrue + have hcanonicalBridge : RelTriple leftCanonicalRun rightCanonicalRun BoolImp := + relTriple_boolImp_of_not_reverse leftCanonicalRun rightCanonicalRun hnegatedImp + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hcanonicalFacts.2 + have hrightCanonicalEq : rightCanonicalRun = + directDelayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret table + target rightRoot (next leftResult.value.1) snapshots observations canonical + leftResult.remaining leftResult.value.2 := by + unfold rightCanonicalRun canonicalizeDirectDelayedSelectedRootIndicator + simp only [canonical, hnotPrivate, hrightPublished, hcanonicalFacts.2, ↓reduceIte] + rfl + rw [hrightCanonicalEq, houtput, hcache] at hcanonicalBridge + have hraw := raw_done_of_mem_runDirectResolvedFromTable + ((maskedSign parameter publicRoot ftsSecret message).run cache) + context leftFuel table leftResult hleftDirect + have hsignOutputLeft : leftResult.value.1 ∈ support + (scheme.sign + (⟨parameter, publicRoot, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey) message) := by + exact maskedSign_done_output_mem_support parameter publicRoot table ftsSecret + message context.state leftResult.context.state cache leftResult.value.2 + leftFuel leftResult.remaining leftResult.value.1 hfinal.1.leftStarts (by + simpa only [SigningSpec, maskedExpandedAdversaryImpl, + maskedSigningImpl] using hraw) + have hsignOutput : rightResult.value.1 ∈ support + (scheme.sign + (⟨parameter, publicRoot, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey) message) := by + rw [← houtput] + exact hsignOutputLeft + have htailBound := isQueryBoundP_of_bind hbound rightResult.value.1 hsignOutput + have hrecursive := ih rightResult.value.1 snapshots observations canonical + leftResult.remaining rightResult.remaining bound rightResult.value.2 + (htailBound.mono (by omega)) + hcanonicalFacts.1 hcanonicalFacts.2 hcanonicalPublished hcanonicalCanonical + hcanonicalChainValid hcanonicalPrivate haligned hcanonicalBefore + (by rw [hcanonicalState]; exact hrightTracked) + (by rw [hcanonicalState]; exact hrightCovered) + hnoHit hcanonicalPending hlength + (by omega) (by omega) (by omega) + (by rw [hcanonicalState]; exact hrightBudget) + have hrecursive' : RelTriple + (directDelayedSelectedRootIndicator ordinal parameter publicRoot ftsSecret table + target rightRoot (next rightResult.value.1) snapshots observations canonical + leftResult.remaining rightResult.value.2) + (rightObserve rightResult.context.state rightResult.remaining + rightResult.value.1 rightResult.value.2 observations) BoolImp := by + change RelTriple _ _ BoolImp at hrecursive + simpa [rightObserve, hcanonicalState] using hrecursive + have hglued := SphincsSecurity.relTriple_trans_exists hcanonicalBridge hrecursive' + apply relTriple_post_mono hglued + intro leftValue rightValue hrelation + obtain ⟨middle, hleftMiddle, hmiddleRight⟩ := hrelation + exact fun htrue ↦ hmiddleRight (hleftMiddle htrue)) + have hfinishEval := congrArg evalDist hfinishProgram + dsimp only [rightObserve] at hfinishEval + refine relTriple_of_evalDist_eq_right ?_ hbase + rw [hfinishEval] + apply congrArg evalDist + apply bind_congr + intro result + cases result with + | none => + simp [successfulObservedRootComparisonIndicator, + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + | some result => rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveRootAwarePrivate.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveRootAwarePrivate.lean new file mode 100644 index 00000000..f3f77294 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveRootAwarePrivate.lean @@ -0,0 +1,342 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptivePrefix +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedLift + +/-! +# Root-aware private hash execution + +The delayed proof executor records every root-aware candidate, so it must execute that same probe. +This module relates the corrected private executor to the materialized public executor used by the +observed game. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem probingHashQueryAfterRootAwarePlan_uncoveredProbeBound + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (candidates : List Probe) + (hplanned : ∀ candidate, + rootAwareCandidateForPlan? parameter input plan = some candidate → candidate ∈ candidates) + (cache : SplitHashCache) : + ((probingHashQueryAfterRootAwarePlan parameter input plan).run cache).IsQueryBoundP + (IsUncoveredProbe candidates) 0 := by + unfold probingHashQueryAfterRootAwarePlan + rw [StateT.run_bind] + apply OracleComp.isQueryBoundP_bind (n := 0) (m := 0) + · cases hcandidate : rootAwareCandidateForPlan? parameter input plan with + | none => simp [executeCandidate?] + | some candidate => + have hmem := hplanned candidate hcandidate + change (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate).IsQueryBoundP + (IsUncoveredProbe candidates) 0 + unfold LazyRevealProbe.probeQuery + rw [OracleComp.isQueryBoundP_query_iff] + simp [IsUncoveredProbe, hmem] + · intro result _hresult + cases plan.action with + | ordinary => + exact OracleComp.IsQueryBoundP.of_imp + (isUncoveredProbe_imp_isProbe candidates) + (splitHashQuery_probeFree (.ordinary input) result.2) + | resolve coordinate => + exact OracleComp.IsQueryBoundP.of_imp + (isUncoveredProbe_imp_isProbe candidates) + (resolveKnownInput_probeFree parameter coordinate input result.2) + +set_option maxRecDepth 100000 in +theorem runDirectResolvedWitnessFromTable_rootAwarePrivate_eq_public + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterRootAwarePlan parameter input plan).run cache) = + runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input context.state plan).run cache) := by + unfold probingHashQueryAfterRootAwarePlan + probingHashQueryAfterRootAwarePublicPlan probingHashQueryPublicAction + cases hcandidate : rootAwareCandidateForPlan? parameter input plan with + | none => + simp only [executeCandidate?, pure_bind] + cases haction : plan.action with + | ordinary => rfl + | resolve coordinate => + exact runDirectResolvedWitnessFromTable_resolveKnownInput_eq_public parameter + coordinate input context fuel table cache + | some candidate => + simp only [executeCandidate?] + rw [StateT.run_bind, StateT.run_bind, runDirectResolvedWitnessFromTable_bind, + runDirectResolvedWitnessFromTable_bind] + simp only [probe, StateT.run_liftM, LazyRevealProbe.probeQuery, + runDirectResolvedWitnessFromTable_probe_query_bind] + cases fuel with + | zero => rfl + | succ remaining => + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + simp only [runDirectResolvedWitnessFromTable] + cases haction : plan.action with + | ordinary => rfl + | resolve coordinate => + exact runDirectResolvedWitnessFromTable_resolveKnownInput_eq_public parameter + coordinate input context remaining table cache + · simp only [hrevealed, ↓reduceIte] + let nextContext : DeferredContext := + { context with state := + context.state.addPending candidate.coordinate candidate.candidate } + rw [show + runDirectResolvedWitnessFromTable nextContext remaining table (pure ((), cache)) = + pure (.done ⟨nextContext, remaining, ((), cache), table⟩) by + simp [runDirectResolvedWitnessFromTable]] + simp only [pure_bind] + cases haction : plan.action with + | ordinary => rfl + | resolve coordinate => + have hbase := runDirectResolvedWitnessFromTable_resolveKnownInput_eq_public + parameter coordinate input nextContext remaining table cache + have hpublic := resolvePublicKnownInput_eq_of_values_eq parameter + (left := nextContext.state) (right := context.state) (by rfl) coordinate input + rw [hpublic] at hbase + exact hbase + +theorem witnessMaterializedStableCouplesBetweenPositive_rootAwarePublicPlan + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) : + WitnessMaterializedStableCouplesBetweenPositive table + (probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan) + (probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan) := by + unfold probingHashQueryAfterRootAwarePublicPlan + cases hcandidate : rootAwareCandidateForPlan? parameter input plan with + | none => + simp only [executeCandidate?, pure_bind] + intro left right leftFuel rightFuel leftCache rightCache _hpositive + exact witnessMaterializedStableCouplesBetween_publicAction table parameter input + publicState plan.action left right leftFuel rightFuel leftCache rightCache + | some candidate => + apply (witnessMaterializedStableCouplesBetween_probe table candidate).bind + intro _ + exact witnessMaterializedStableCouplesBetween_publicAction table parameter input + publicState plan.action + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedWitness_rootAwarePrivate_rootAwarePublic + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hpublicState : publicState = left.state) + (hpositive : 0 < leftFuel) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterRootAwarePlan parameter input plan).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache)) + (DirectWitnessMaterializedStableRunEq table) := by + subst publicState + rw [runDirectResolvedWitnessFromTable_rootAwarePrivate_eq_public parameter input plan left + leftFuel table leftCache] + exact witnessMaterializedStableCouplesBetweenPositive_rootAwarePublicPlan table parameter input + left.state plan left right leftFuel rightFuel leftCache rightCache hpositive hcontext hfuel + hcache hrevealed hvalues hpublished hrightMaterialized + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedWitness_rootAwarePrivate_observedMaterialized + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hpublicState : publicState = left.state) + (hpositive : 0 < leftFuel) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterRootAwarePlan parameter input plan).run leftCache)) + (runObservedCleanFromTable observations right.state rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache)) + (WitnessObservedStepRel table + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan))) := by + have hbase := relTriple_runDirectResolvedWitness_rootAwarePrivate_rootAwarePublic table parameter + input publicState plan left right leftFuel rightFuel leftCache rightCache hpublicState hpositive + hcontext hfuel hcache hrevealed hvalues hpublished hrightMaterialized + have hstrength : RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterRootAwarePlan parameter input plan).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache)) + (fun leftResult rightResult => + WitnessObservedStepRel table + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan)) + leftResult + (projectDirectDetailedObserved + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan)) rightResult)) := by + apply relTriple_post_mono hbase + intro leftResult rightResult hrelation + exact ⟨rightResult, rfl, hrelation⟩ + have hmapped := relTriple_map + (R := fun leftResult rightResult => + WitnessObservedStepRel table + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan)) leftResult rightResult) + (f := id) + (g := projectDirectDetailedObserved + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan))) hstrength + have hpost : RelTriple + (id <$> runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterRootAwarePlan parameter input plan).run leftCache)) + (projectDirectDetailedObserved + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan)) <$> + runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache)) + (WitnessObservedStepRel table + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan))) := hmapped + rw [id_map] at hpost + have hmap : + projectDirectDetailedObserved + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan)) <$> + runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache) = + runObservedCleanFromTable observations right.state rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache) := by + rw [hrightMaterialized] + simpa [directDeferredContext] using + (map_projectDirectDetailedObserved_rootAwarePublic parameter input publicState plan + observations right.state rightFuel table rightCache) + exact relTriple_of_evalDist_eq_right (congrArg evalDist hmap) hpost + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedWitness_rootAwarePrivate_observed_firstStopped + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hpublicState : publicState = left.state) + (hpositive : 0 < leftFuel) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hcandidateCompletable : ∀ candidate, + rootAwareCandidateForPlan? parameter input plan = some candidate → + candidate.coordinate ∉ left.state.revealed → + DeferredCompletable table + { left with state := + left.state.addPending candidate.coordinate candidate.candidate }) + (htracked : CleanProbeObservationsTrackedBy observations right.state) + (hcovered : CleanProbeObservationsCoverPending observations right.state) + (hnextNoHit : ∀ observation ∈ observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan), + ¬observation.ExistingHiddenHit) + (hbudget : rightFuel + right.state.pending.card < Fintype.card Digest) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterRootAwarePlan parameter input plan).run leftCache)) + (runObservedCleanFromTable observations right.state rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache)) + (WitnessObservedFirstStoppedStepRel table + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan))) := by + let executionPlan : PlannedHashQuery := + ⟨rootAwareCandidateForPlan? parameter input plan, plan.action⟩ + have hexecution : probingHashQueryAfterRootAwarePlan parameter input plan = + probingHashQueryAfterPlan parameter input executionPlan := by + rfl + have hlocal := relTriple_runDirectResolvedWitness_rootAwarePrivate_observedMaterialized table + parameter input publicState plan observations left right leftFuel rightFuel leftCache rightCache + hpublicState hpositive hcontext hfuel hcache hrevealed hvalues hpublished hrightMaterialized + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hlocal + (fun result => result ∈ support + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterRootAwarePlan parameter input plan).run leftCache))) + (fun result hresult => hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupported + apply relTriple_post_mono hbothSupported + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hstep, hleftSupport⟩, hrightSupport⟩ + have hnotPrivate : ∀ witness, leftResult ≠ .stoppedPrivate witness := by + intro witness heq + subst leftResult + apply not_stoppedPrivate_mem_afterPlan_of_completable parameter input executionPlan left + leftFuel table leftCache witness hpositive hcontext.leftValid hcontext.leftCompletable + · intro candidate hcandidate hhidden + apply hcandidateCompletable candidate + · simpa [executionPlan] using hcandidate + · exact hhidden + · rw [← hexecution] + exact hleftSupport + apply hstep.to_firstStoppedStep_of_not_private hnotPrivate + · intro resolved hresolved + have htrackedResult := cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run rightCache) + observations right.state rightFuel table htracked + (observedResolvedResult + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan)) resolved) + (by simpa [hresolved] using hrightSupport) + have hcoveredResult := cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run rightCache) + observations right.state rightFuel table hcovered + (observedResolvedResult + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan)) resolved) + (by simpa [hresolved] using hrightSupport) + apply directDeferredContext_valid_of_no_existingHiddenHit + (observedResolvedResult + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan)) resolved) + htrackedResult hcoveredResult + intro hhit + obtain ⟨observation, hobservation, hobservationHit⟩ := hhit + apply hnextNoHit observation + · simpa [observedResolvedResult] using hobservation + · exact hobservationHit + · intro resolved hresolved + have hremaining := remaining_add_pending_card_le_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run rightCache) + observations right.state rightFuel table + (observedResolvedResult + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan)) resolved) + (by simpa [hresolved] using hrightSupport) + simp only [observedResolvedResult] at hremaining + exact (Nat.le_add_left _ _).trans (hremaining.trans_lt hbudget) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveRootAwarePrivateStrong.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveRootAwarePrivateStrong.lean new file mode 100644 index 00000000..a88bac01 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveRootAwarePrivateStrong.lean @@ -0,0 +1,344 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedSignerStrong +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveRootAwarePrivate + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def DirectWitnessFinalizationMaterializedSpentRunEq + (table : OtsSecretIndex → HashOutput) (initialValues : DeferredStructuralValues) + (leftInitialFuel rightInitialFuel spent : Nat) : + DirectWitnessResult (α × SplitHashCache) → + DirectDetailedResult (α × SplitHashCache) → Prop + | .done left, .done right => + left.value.1 = right.value.1 ∧ + FinalizationContextEq table (some left.context) (some right.context) ∧ + left.remaining + spent = leftInitialFuel ∧ + right.remaining + spent = rightInitialFuel ∧ + left.table = table ∧ right.table = table ∧ + left.value.2 = right.value.2 ∧ + left.context.state.revealed = right.context.state.revealed ∧ + (materializedDeferredState left.context).values = right.context.state.values ∧ + DeferredStructuralValuesLE initialValues left.context.values ∧ + right.context = directDeferredContext right.context.state + | .done _, .stopped _ => False + | _, _ => True + +theorem materializedDeferredState_addPending_values + (context : DeferredContext) (coordinate : Coordinate) (candidate : Digest) : + (materializedDeferredState + { context with state := context.state.addPending coordinate candidate }).values = + (materializedDeferredState context).values := by + funext other + cases other <;> + simp [materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.addPending] + +theorem directWitnessFinalizationMaterializedCouples_modify + (table : OtsSecretIndex → HashOutput) (f : SplitHashCache → SplitHashCache) : + DirectWitnessFinalizationMaterializedCouples table + (modify f : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hcache hrevealed hmaterialized + hright + simp only [modify, runDirectResolvedWitnessFromTable, + runDirectResolvedDetailedFromTable] + apply relTriple_pure_pure + refine ⟨rfl, hcontext, rfl, rfl, rfl, rfl, ?_, hrevealed, hmaterialized, + DeferredStructuralValuesLE.refl left.values, hright⟩ + simpa [hcache] + +theorem directWitnessFinalizationMaterializedCouples_resolvePublicKnownInput + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (publicState : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) (input : HashInput) : + DirectWitnessFinalizationMaterializedCouples table + (resolvePublicKnownInput parameter publicState coordinate input) := by + unfold resolvePublicKnownInput + cases hknown : purePeekTableInput parameter publicState coordinate with + | none => + exact directWitnessFinalizationMaterializedCouples_splitHashQuery_ordinary table input + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + apply (directWitnessFinalizationMaterializedCouples_revealCoordinateOutput + table coordinate).bind + intro output + apply (directWitnessFinalizationMaterializedCouples_publishCoordinate + table coordinate).bind + intro _ + apply (directWitnessFinalizationMaterializedCouples_modify table + (fun cache => Function.update cache (.ordinary input) (some output))).bind + intro _ + exact directWitnessFinalizationMaterializedCouples_pure table output + · simp only [heq, ↓reduceIte] + exact directWitnessFinalizationMaterializedCouples_splitHashQuery_ordinary table input + +theorem directWitnessFinalizationMaterializedCouples_publicAction + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (action : PlannedHashAction) : + DirectWitnessFinalizationMaterializedCouples table + (probingHashQueryPublicAction parameter input publicState action) := by + cases action with + | ordinary => + exact directWitnessFinalizationMaterializedCouples_splitHashQuery_ordinary table input + | resolve coordinate => + exact directWitnessFinalizationMaterializedCouples_resolvePublicKnownInput table parameter + publicState coordinate input + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedWitness_rootAwarePrivate_finalizationMaterialized + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hpublicState : publicState = left.state) + (hpositive : 0 < leftFuel) (hfuel : leftFuel ≤ rightFuel) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hcache : leftCache = rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hmaterialized : (materializedDeferredState left).values = right.state.values) + (hright : right = directDeferredContext right.state) + (hcandidateCompletable : ∀ candidate, + rootAwareCandidateForPlan? parameter input plan = some candidate → + candidate.coordinate ∉ left.state.revealed → + DeferredCompletable table + { left with state := + left.state.addPending candidate.coordinate candidate.candidate }) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterRootAwarePlan parameter input plan).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache)) + (DirectWitnessFinalizationMaterializedSpentRunEq table left.values leftFuel rightFuel + (if (rootAwareCandidateForPlan? parameter input plan).isSome then 1 else 0)) := by + subst publicState + rw [runDirectResolvedWitnessFromTable_rootAwarePrivate_eq_public parameter input plan left + leftFuel table leftCache] + unfold probingHashQueryAfterRootAwarePublicPlan + cases hcandidate : rootAwareCandidateForPlan? parameter input plan with + | none => + simp only [executeCandidate?, pure_bind, Option.isSome_none, ↓reduceIte] + have hbase := directWitnessFinalizationMaterializedCouples_publicAction table parameter input + left.state plan.action left right leftFuel rightFuel leftCache rightCache hcontext hcache + hrevealed hmaterialized hright + apply relTriple_post_mono hbase + intro leftResult rightResult hrelation + cases leftResult <;> cases rightResult <;> + simpa [DirectWitnessFinalizationMaterializedSpentRunEq, + DirectWitnessFinalizationMaterializedRunEq] using hrelation + | some candidate => + simp only [executeCandidate?, Option.isSome_some, ↓reduceIte] + rw [StateT.run_bind, StateT.run_bind, runDirectResolvedWitnessFromTable_bind, + runDirectResolvedDetailedFromTable_bind] + simp only [probe, StateT.run_liftM, LazyRevealProbe.probeQuery, + runDirectResolvedWitnessFromTable_probe_query_bind, + runDirectResolvedDetailedFromTable_probe_query_bind] + cases leftFuel with + | zero => omega + | succ leftRemaining => + cases rightFuel with + | zero => omega + | succ rightRemaining => + by_cases hleftRevealed : candidate.coordinate ∈ left.state.revealed + · have hrightRevealed : candidate.coordinate ∈ right.state.revealed := by + rw [← hrevealed] + exact hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + have hbase := directWitnessFinalizationMaterializedCouples_publicAction table + parameter input left.state plan.action left right leftRemaining rightRemaining + leftCache rightCache hcontext hcache hrevealed hmaterialized hright + apply relTriple_post_mono hbase + intro leftResult rightResult hrelation + cases leftResult <;> cases rightResult <;> + simpa [DirectWitnessFinalizationMaterializedSpentRunEq, + DirectWitnessFinalizationMaterializedRunEq] using hrelation + · have hrightRevealed : candidate.coordinate ∉ right.state.revealed := by + rwa [← hrevealed] + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + let nextLeft : DeferredContext := + { left with state := + left.state.addPending candidate.coordinate candidate.candidate } + let nextRight : DeferredContext := + { right with state := + right.state.addPending candidate.coordinate candidate.candidate } + have hleftCompletable : DeferredCompletable table nextLeft := by + exact hcandidateCompletable candidate hcandidate hleftRevealed + have hrightCompletable : DeferredCompletable table nextRight := by + exact (deferredCompletable_addPending_iff_of_finalizationViewEq hcontext.1 + candidate.coordinate candidate.candidate).mp hleftCompletable + have hnextContext : FinalizationContextEq table (some nextLeft) + (some nextRight) := by + refine ⟨hcontext.1.addPending_of_completable candidate.coordinate + candidate.candidate hleftCompletable hrightCompletable, + hcontext.2.1.addPending_of_completable candidate.coordinate + candidate.candidate hleftCompletable, + hcontext.2.2.1.addPending_of_completable candidate.coordinate + candidate.candidate hrightCompletable, + hleftCompletable⟩ + have hnextRevealed : nextLeft.state.revealed = nextRight.state.revealed := by + simpa [nextLeft, nextRight, LazyRevealProbe.State.addPending] using hrevealed + have hnextMaterialized : (materializedDeferredState nextLeft).values = + nextRight.state.values := by + rw [show (materializedDeferredState nextLeft).values = + (materializedDeferredState left).values by + simpa [nextLeft] using materializedDeferredState_addPending_values left + candidate.coordinate candidate.candidate] + simpa [nextRight, LazyRevealProbe.State.addPending] using hmaterialized + have hnextRight : nextRight = directDeferredContext nextRight.state := by + dsimp only [nextRight] + rw [hright] + simp [directDeferredContext, directDeferredValues_addPending] + have hbase := directWitnessFinalizationMaterializedCouples_publicAction table + parameter input left.state plan.action nextLeft nextRight leftRemaining + rightRemaining leftCache rightCache hnextContext hcache hnextRevealed + hnextMaterialized hnextRight + apply relTriple_post_mono hbase + intro leftResult rightResult hrelation + cases leftResult <;> cases rightResult <;> + simpa [DirectWitnessFinalizationMaterializedSpentRunEq, + DirectWitnessFinalizationMaterializedRunEq, nextLeft] using hrelation + +def WitnessObservedFinalizationMaterializedSpentStepRel + (table : OtsSecretIndex → HashOutput) (initialValues : DeferredStructuralValues) + (leftInitialFuel rightInitialFuel spent : Nat) + (observations : List CleanProbeObservation) + (left : DirectWitnessResult (α × SplitHashCache)) + (right : Option (ObservedCleanRunResult (α × SplitHashCache))) : Prop := + ∃ detailed, + projectDirectDetailedObserved observations detailed = right ∧ + DirectWitnessFinalizationMaterializedSpentRunEq table initialValues leftInitialFuel + rightInitialFuel spent left detailed + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedWitness_rootAwarePrivate_observedFinalizationMaterialized + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hpublicState : publicState = left.state) + (hpositive : 0 < leftFuel) (hfuel : leftFuel ≤ rightFuel) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hcache : leftCache = rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hmaterialized : (materializedDeferredState left).values = right.state.values) + (hright : right = directDeferredContext right.state) + (hcandidateCompletable : ∀ candidate, + rootAwareCandidateForPlan? parameter input plan = some candidate → + candidate.coordinate ∉ left.state.revealed → + DeferredCompletable table + { left with state := + left.state.addPending candidate.coordinate candidate.candidate }) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterRootAwarePlan parameter input plan).run leftCache)) + (runObservedCleanFromTable observations right.state rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache)) + (WitnessObservedFinalizationMaterializedSpentStepRel table left.values leftFuel rightFuel + (if (rootAwareCandidateForPlan? parameter input plan).isSome then 1 else 0) + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan))) := by + have hbase := relTriple_runDirectResolvedWitness_rootAwarePrivate_finalizationMaterialized table + parameter input publicState plan left right leftFuel rightFuel leftCache rightCache hpublicState + hpositive hfuel hcontext hcache hrevealed hmaterialized hright hcandidateCompletable + let nextObservations := observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan) + have hstrength : RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterRootAwarePlan parameter input plan).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache)) + (fun leftResult rightResult => + WitnessObservedFinalizationMaterializedSpentStepRel table left.values leftFuel rightFuel + (if (rootAwareCandidateForPlan? parameter input plan).isSome then 1 else 0) + nextObservations leftResult + (projectDirectDetailedObserved nextObservations rightResult)) := by + apply relTriple_post_mono hbase + intro leftResult rightResult hrelation + exact ⟨rightResult, rfl, hrelation⟩ + have hmapped := relTriple_map + (R := WitnessObservedFinalizationMaterializedSpentStepRel table left.values leftFuel rightFuel + (if (rootAwareCandidateForPlan? parameter input plan).isSome then 1 else 0) + nextObservations) + (f := id) (g := projectDirectDetailedObserved nextObservations) hstrength + rw [id_map] at hmapped + have hmap : + projectDirectDetailedObserved nextObservations <$> + runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache) = + runObservedCleanFromTable observations right.state rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache) := by + rw [hright] + simpa [nextObservations, directDeferredContext] using + (map_projectDirectDetailedObserved_rootAwarePublic parameter input publicState plan + observations right.state rightFuel table rightCache) + exact relTriple_of_evalDist_eq_right (congrArg evalDist hmap) hmapped + +theorem relTriple_bind_finishDirectDelayed_observed_of_spent + (table : OtsSecretIndex → HashOutput) (initialValues : DeferredStructuralValues) + (leftInitialFuel rightInitialFuel spent : Nat) + (observations : List CleanProbeObservation) + (leftRun : ProbComp (DirectWitnessResult (α × SplitHashCache))) + (rightRun : ProbComp (Option (ObservedCleanRunResult (α × SplitHashCache)))) + (leftObserve : DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → List CleanProbeObservation → ProbComp Bool) + (rightObserve : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List CleanProbeObservation → ProbComp Bool) + (snapshots : List PlannedProbeSnapshot) + (delayedObservations : List CleanProbeObservation) + (hstep : RelTriple leftRun rightRun + (WitnessObservedFinalizationMaterializedSpentStepRel table initialValues leftInitialFuel + rightInitialFuel spent observations)) + (hnext : ∀ left right, + DirectWitnessResult.done left ∈ support leftRun → + some (observedResolvedResult observations right) ∈ support rightRun → + DirectWitnessFinalizationMaterializedSpentRunEq table initialValues leftInitialFuel + rightInitialFuel spent (.done left) (.done right) → + RelTriple + (leftObserve left.context left.remaining left.value snapshots delayedObservations) + (rightObserve right.context.state right.remaining right.value.1 right.value.2 observations) + BoolImp) : + RelTriple + (leftRun >>= finishDirectDelayedSelectedRootIndicator leftObserve snapshots + delayedObservations) + (rightRun >>= fun result => match result with + | none => pure false + | some result => rightObserve result.state result.remaining result.value.1 result.value.2 + result.observations) + BoolImp := by + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hstep + (fun result => result ∈ support leftRun) (fun _ hresult => hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupported + apply relTriple_bind hbothSupported + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResult with + | stoppedFuel => exact relTriple_false_any _ + | stoppedOrdinary => exact relTriple_false_any _ + | stoppedPrivate witness => exact relTriple_false_any _ + | done left => + rcases hrelation with ⟨detailed, hproject, hrun⟩ + cases detailed with + | stopped reason => + simp [DirectWitnessFinalizationMaterializedSpentRunEq] at hrun + | done right => + have hrightResult : rightResult = + some (observedResolvedResult observations right) := by + simpa [projectDirectDetailedObserved, observedResolvedResult] using hproject.symm + subst rightResult + simp only [finishDirectDelayedSelectedRootIndicator, observedResolvedResult] + exact hnext left right hleftSupport hrightSupport hrun + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveTrace.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveTrace.lean new file mode 100644 index 00000000..189ff310 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveTrace.lean @@ -0,0 +1,692 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveAfterRoot + +/-! +# Adaptive chronological trace invariance + +The normalization may materialize a structural value before a probe that does not select the +tracked ordinal. The two executions then share all operational state and differ only in historical +observation fields. This file records the exact observation semantics used by the terminal event +and proves that the observed interpreter preserves them. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def CleanProbeObservation.EventEq + (left right : CleanProbeObservation) : Prop := + left.toProbe = right.toProbe ∧ + (left.ExistingHiddenHit ↔ right.ExistingHiddenHit) + +def CleanProbeObservationsEventEq + (left right : List CleanProbeObservation) : Prop := + List.Forall₂ CleanProbeObservation.EventEq left right + +theorem CleanProbeObservationsEventEq.length_eq + {left right : List CleanProbeObservation} + (htrace : CleanProbeObservationsEventEq left right) : + left.length = right.length := + List.Forall₂.length_eq htrace + +theorem CleanProbeObservationsEventEq.refl + (observations : List CleanProbeObservation) : + CleanProbeObservationsEventEq observations observations := by + induction observations with + | nil => exact .nil + | cons observation observations ih => + exact .cons ⟨rfl, Iff.rfl⟩ ih + +theorem CleanProbeObservationsEventEq.symm + {left right : List CleanProbeObservation} + (htrace : CleanProbeObservationsEventEq left right) : + CleanProbeObservationsEventEq right left := by + induction htrace with + | nil => exact .nil + | cons hhead _htail ih => + exact .cons ⟨hhead.1.symm, hhead.2.symm⟩ ih + +theorem CleanProbeObservationsEventEq.append_same + {left right : List CleanProbeObservation} + (htrace : CleanProbeObservationsEventEq left right) + (suffix : List CleanProbeObservation) : + CleanProbeObservationsEventEq (left ++ suffix) (right ++ suffix) := by + exact List.rel_append htrace (CleanProbeObservationsEventEq.refl suffix) + +theorem CleanProbeObservation.eventEq_installPositionValueAtProbe_of_clean_of_avoids + (target : Position) (output : HashOutput) (observation : CleanProbeObservation) + (hclean : ¬observation.ExistingHiddenHit) + (havoid : observation.toProbe ≠ + ⟨.position target, truncateHash output⟩) : + (installPositionValueAtProbe target output observation).EventEq observation := by + refine ⟨installPositionValueAtProbe_toProbe target output observation, ?_⟩ + have hinstalled := not_existingHiddenHit_installPositionValueAtProbe_of_avoids target output + observation hclean havoid + constructor + · exact fun hhit => (hinstalled hhit).elim + · exact fun hhit => (hclean hhit).elim + +theorem CleanProbeObservationsEventEq.map_installPositionValueAtProbe_of_clean_of_avoids + (target : Position) (output : HashOutput) + (observations : List CleanProbeObservation) + (hclean : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (havoid : CandidatesAvoidRoot target (truncateHash output) + (observations.map CleanProbeObservation.toProbe)) : + CleanProbeObservationsEventEq + (observations.map (installPositionValueAtProbe target output)) observations := by + induction observations with + | nil => exact .nil + | cons observation observations ih => + apply List.Forall₂.cons + · apply CleanProbeObservation.eventEq_installPositionValueAtProbe_of_clean_of_avoids + · exact hclean observation (by simp) + · intro heq + exact havoid observation.toProbe (by simp) heq + · apply ih + · intro other hother + exact hclean other (by simp [hother]) + · intro candidate hcandidate + exact havoid candidate (by simp [hcandidate]) + +theorem CleanProbeObservationsEventEq.toProbe_eq + {left right : List CleanProbeObservation} + (htrace : CleanProbeObservationsEventEq left right) : + left.map CleanProbeObservation.toProbe = + right.map CleanProbeObservation.toProbe := by + induction htrace with + | nil => rfl + | cons hhead _htail ih => simp [hhead.1, ih] + +theorem CleanProbeObservationsEventEq.get + {left right : List CleanProbeObservation} + (htrace : CleanProbeObservationsEventEq left right) + (index : Nat) (hleft : index < left.length) (hright : index < right.length) : + (left.get ⟨index, hleft⟩).EventEq (right.get ⟨index, hright⟩) := + List.Forall₂.get htrace hleft hright + +def ObservedCleanRunOption.EventEq + (left right : Option (ObservedCleanRunResult α)) : Prop := + match left, right with + | none, none => True + | some left, some right => + left.state = right.state ∧ + left.remaining = right.remaining ∧ + left.value = right.value ∧ + left.table = right.table ∧ + CleanProbeObservationsEventEq left.observations right.observations + | _, _ => False + +theorem ObservedCleanRunOption.EventEq.pure + (leftObservations rightObservations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (value : α) (table : OtsSecretIndex → HashOutput) + (htrace : CleanProbeObservationsEventEq leftObservations rightObservations) : + ObservedCleanRunOption.EventEq + (some ⟨state, fuel, value, table, leftObservations⟩) + (some ⟨state, fuel, value, table, rightObservations⟩) := by + exact ⟨rfl, rfl, rfl, rfl, htrace⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_runObservedCleanFromTable_eventEq + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (leftObservations rightObservations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (htrace : CleanProbeObservationsEventEq leftObservations rightObservations) : + RelTriple + (runObservedCleanFromTable leftObservations state fuel table computation) + (runObservedCleanFromTable rightObservations state fuel table computation) + ObservedCleanRunOption.EventEq := by + induction computation using OracleComp.inductionOn generalizing + leftObservations rightObservations state fuel with + | pure value => + rw [runObservedCleanFromTable, OracleComp.construct_pure, + runObservedCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure + (ObservedCleanRunOption.EventEq.pure leftObservations rightObservations state fuel value + table htrace) + | query_bind query next ih => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + runObservedCleanFromTable, OracleComp.construct_query_bind] + cases query with + | uniform n => + apply relTriple_bind (relTriple_refl (liftM (unifSpec.query n))) + intro leftValue rightValue hvalue + subst rightValue + exact ih leftValue leftObservations rightObservations state fuel htrace + | hashOutput => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftValue rightValue hvalue + subst rightValue + exact ih leftValue leftObservations rightObservations state fuel htrace + | ensure coordinate => + exact ih () leftObservations rightObservations (state.ensure coordinate) fuel htrace + | probe coordinate candidate => + cases fuel with + | zero => + exact relTriple_pure_pure (by simp [ObservedCleanRunOption.EventEq]) + | succ remaining => + let observation := cleanProbeObservation state coordinate candidate + have hnextTrace : CleanProbeObservationsEventEq + (leftObservations ++ [observation]) + (rightObservations ++ [observation]) := + htrace.append_same [observation] + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () (leftObservations ++ [observation]) + (rightObservations ++ [observation]) state remaining hnextTrace + · simp only [hrevealed, ↓reduceIte] + exact ih () (leftObservations ++ [observation]) + (rightObservations ++ [observation]) + (state.addPending coordinate candidate) remaining hnextTrace + | peek coordinate => + exact ih (state.values coordinate) leftObservations rightObservations state fuel htrace + | publish coordinate => + exact ih () leftObservations rightObservations (state.publish coordinate) fuel htrace + | reveal coordinate => + cases hvalue : state.values coordinate with + | some value => + simp only [hvalue] + exact ih value leftObservations rightObservations state fuel htrace + | none => + simp only [hvalue] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let value := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : state.hitAt (.chainStart lay tree leafIdx chainIdx) value + · simp only [value, hhit, ↓reduceIte] + exact relTriple_pure_pure (by simp [ObservedCleanRunOption.EventEq]) + · simp only [value, hhit, ↓reduceIte] + exact ih value leftObservations rightObservations + (state.materialize (.chainStart lay tree leafIdx chainIdx) value) fuel htrace + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + by_cases hhit : state.hitAt (.position position) leftOutput + · simp only [hhit, ↓reduceIte] + exact relTriple_pure_pure (by simp [ObservedCleanRunOption.EventEq]) + · simp only [hhit, ↓reduceIte] + exact ih leftOutput leftObservations rightObservations + (state.materialize (.position position) leftOutput) fuel htrace + +set_option maxRecDepth 100000 in +theorem relTriple_observedMaterializedBoundary_eventEq + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (leftObservations rightObservations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (htrace : CleanProbeObservationsEventEq leftObservations rightObservations) : + RelTriple + (observedMaterializedBoundary parameter root ftsSecret computation leftObservations state + fuel table cache) + (observedMaterializedBoundary parameter root ftsSecret computation rightObservations state + fuel table cache) + ObservedCleanRunOption.EventEq := by + induction computation using OracleComp.inductionOn generalizing + leftObservations rightObservations state fuel cache with + | pure value => + rw [observedMaterializedBoundary, OracleComp.construct_pure, + observedMaterializedBoundary, OracleComp.construct_pure] + exact relTriple_pure_pure + (ObservedCleanRunOption.EventEq.pure leftObservations rightObservations state fuel + (value, cache) table htrace) + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind, + observedMaterializedBoundary, OracleComp.construct_query_bind] + have continueAfter + (leftRun rightRun : ProbComp (Option (ObservedCleanRunResult + ((OracleWorld + SigningSpec).Range query × SplitHashCache)))) + (hrun : RelTriple leftRun rightRun ObservedCleanRunOption.EventEq) : + RelTriple + (leftRun >>= fun result => + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state result.remaining table + result.value.2) + (rightRun >>= fun result => + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state result.remaining table + result.value.2) + ObservedCleanRunOption.EventEq := by + apply relTriple_bind hrun + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure (by trivial) + | some rightResult => simp [ObservedCleanRunOption.EventEq] at hresult + | some leftResult => + cases rightResult with + | none => simp [ObservedCleanRunOption.EventEq] at hresult + | some rightResult => + simp only + rcases hresult with + ⟨hstate, hremaining, hvalue, _htable, hnextTrace⟩ + have hnextValue : leftResult.value.1 = rightResult.value.1 := + congrArg Prod.fst hvalue + have hnextCache : leftResult.value.2 = rightResult.value.2 := + congrArg Prod.snd hvalue + rw [← hstate, ← hremaining, ← hnextValue, ← hnextCache] + exact ih leftResult.value.1 leftResult.observations rightResult.observations + leftResult.state leftResult.remaining leftResult.value.2 hnextTrace + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + change Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α at next + have hstep := relTriple_runObservedCleanFromTable_eventEq + ((splitUniformImpl n).run cache) leftObservations rightObservations state fuel + table htrace + convert continueAfter _ _ hstep using 1 <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + | inr input => + change HashOutput → OracleComp (OracleWorld + SigningSpec) α at next + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + have hstep := relTriple_runObservedCleanFromTable_eventEq + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache) + leftObservations rightObservations state fuel table htrace + convert continueAfter _ _ hstep using 1 <;> + simp only [publicContext, plan, observedMaterializedBoundary] <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + | inr message => + change Option Signature → OracleComp (OracleWorld + SigningSpec) α at next + have hstep := relTriple_runObservedCleanFromTable_eventEq + ((maskedSign parameter root ftsSecret message).run cache) + leftObservations rightObservations state fuel table htrace + convert continueAfter _ _ hstep using 1 <;> + simp only [observedMaterializedBoundary] <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + +theorem firstExistingHiddenHitAt_of_eventEq + (left right : ObservedCleanRunResult α) (ordinal : Nat) + (htrace : CleanProbeObservationsEventEq left.observations right.observations) + (hfirst : FirstExistingHiddenHitAt left ordinal) : + FirstExistingHiddenHitAt right ordinal := by + obtain ⟨selected, hselected, hhit, hearlier⟩ := hfirst + have hlength := htrace.length_eq + let rightSelected : Fin right.observations.length := + ⟨selected.val, by rw [← hlength]; exact selected.isLt⟩ + refine ⟨rightSelected, hselected, ?_, ?_⟩ + · have hget := htrace.get selected.val selected.isLt rightSelected.isLt + exact hget.2.mp hhit + · intro rightEarlier hearlierLt hrightHit + let leftEarlier : Fin left.observations.length := + ⟨rightEarlier.val, by rw [hlength]; exact rightEarlier.isLt⟩ + apply hearlier leftEarlier hearlierLt + have hget := htrace.get rightEarlier.val leftEarlier.isLt rightEarlier.isLt + exact hget.2.mpr hrightHit + +theorem firstExistingHiddenHitAt_iff_of_eventEq + (left right : ObservedCleanRunResult α) (ordinal : Nat) + (htrace : CleanProbeObservationsEventEq left.observations right.observations) : + FirstExistingHiddenHitAt left ordinal ↔ FirstExistingHiddenHitAt right ordinal := by + exact ⟨firstExistingHiddenHitAt_of_eventEq left right ordinal htrace, + firstExistingHiddenHitAt_of_eventEq right left ordinal htrace.symm⟩ + +theorem observedFirstLayerRootPosition?_eq_of_eventEq + (ordinal : Nat) (left right : ObservedCleanRunResult α) + (htrace : CleanProbeObservationsEventEq left.observations right.observations) : + observedFirstLayerRootPosition? ordinal (some left) = + observedFirstLayerRootPosition? ordinal (some right) := by + have hlength := htrace.length_eq + unfold observedFirstLayerRootPosition? + by_cases hleft : ordinal < left.observations.length + · have hright : ordinal < right.observations.length := by omega + simp only [hleft, hright, ↓reduceDIte] + have hget := htrace.get ordinal hleft hright + rw [hget.1] + · have hright : ¬ordinal < right.observations.length := by omega + simp [hleft, hright] + +theorem observedPrefixProbes_eq_of_eventEq + (ordinal : Nat) (left right : ObservedCleanRunResult α) + (htrace : CleanProbeObservationsEventEq left.observations right.observations) : + observedPrefixProbes ordinal (some left) = + observedPrefixProbes ordinal (some right) := by + simp only [observedPrefixProbes] + rw [List.map_take, List.map_take, htrace.toProbe_eq] + +theorem finishObservedCleanRunFromTable_some_of_eventEq + (left right : ObservedCleanRunResult α) + (hrel : ObservedCleanRunOption.EventEq (some left) (some right)) + (hfinish : ∃ finalResult, some finalResult ∈ support + (finishObservedCleanRunFromTable (some left))) : + ∃ finalResult, some finalResult ∈ support + (finishObservedCleanRunFromTable (some right)) := by + rcases hrel with ⟨hstate, _hremaining, _hvalue, htable, _htrace⟩ + obtain ⟨finalResult, hfinal⟩ := hfinish + unfold finishObservedCleanRunFromTable at hfinal + simp only at hfinal + rw [mem_support_bind_iff] at hfinal + obtain ⟨finalized, hfinalized, hreturn⟩ := hfinal + cases finalized with + | none => simp at hreturn + | some finalized => + rcases finalized with ⟨finalState, finalTable⟩ + let rightFinal : ObservedCleanRunResult α := + ⟨finalState, right.remaining, right.value, finalTable, right.observations⟩ + refine ⟨rightFinal, ?_⟩ + unfold finishObservedCleanRunFromTable + rw [mem_support_bind_iff] + refine ⟨some (finalState, finalTable), ?_, ?_⟩ + · simpa [← hstate, ← htable] using hfinalized + · simp [rightFinal] + +theorem finishObservedCleanRunFromTable_some_iff_of_eventEq + (left right : ObservedCleanRunResult α) + (hrel : ObservedCleanRunOption.EventEq (some left) (some right)) : + (∃ finalResult, some finalResult ∈ support + (finishObservedCleanRunFromTable (some left))) ↔ + ∃ finalResult, some finalResult ∈ support + (finishObservedCleanRunFromTable (some right)) := by + rcases hrel with ⟨hstate, hremaining, hvalue, htable, htrace⟩ + exact ⟨ + finishObservedCleanRunFromTable_some_of_eventEq left right + ⟨hstate, hremaining, hvalue, htable, htrace⟩, + finishObservedCleanRunFromTable_some_of_eventEq right left + ⟨hstate.symm, hremaining.symm, hvalue.symm, htable.symm, htrace.symm⟩⟩ + +theorem firstExistingHiddenRootHitAt_of_eventEq + (ordinal : Nat) (left right : ObservedCleanRunResult α) + (htrace : CleanProbeObservationsEventEq left.observations right.observations) + (hfirst : ObservedCleanRunOption.FirstExistingHiddenRootHitAt ordinal (some left)) : + ObservedCleanRunOption.FirstExistingHiddenRootHitAt ordinal (some right) := by + obtain ⟨selected, hselected, hfirst, hroot⟩ := hfirst + have hlength := htrace.length_eq + let rightSelected : Fin right.observations.length := + ⟨selected.val, by rw [← hlength]; exact selected.isLt⟩ + have hget := htrace.get selected.val selected.isLt rightSelected.isLt + exact ⟨rightSelected, hselected, + firstExistingHiddenHitAt_of_eventEq left right ordinal htrace hfirst, by + rw [← hget.1] + exact hroot⟩ + +theorem firstExistingHiddenRootHitAt_iff_of_eventEq + (ordinal : Nat) (left right : ObservedCleanRunResult α) + (htrace : CleanProbeObservationsEventEq left.observations right.observations) : + ObservedCleanRunOption.FirstExistingHiddenRootHitAt ordinal (some left) ↔ + ObservedCleanRunOption.FirstExistingHiddenRootHitAt ordinal (some right) := by + exact ⟨firstExistingHiddenRootHitAt_of_eventEq ordinal left right htrace, + firstExistingHiddenRootHitAt_of_eventEq ordinal right left htrace.symm⟩ + +theorem successfulDoomedFirstRootGoodForComparisonAt_iff_of_eventEq + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (target : Position) (rightRoot : Digest) + (left right : Option (ObservedCleanRunResult α)) + (hrel : ObservedCleanRunOption.EventEq left right) : + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot left ↔ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot right := by + cases left with + | none => + cases right with + | none => rfl + | some right => simp [ObservedCleanRunOption.EventEq] at hrel + | some left => + cases right with + | none => simp [ObservedCleanRunOption.EventEq] at hrel + | some right => + rcases hrel with ⟨hstate, hremaining, hvalue, htable, htrace⟩ + have hfinish := finishObservedCleanRunFromTable_some_iff_of_eventEq left right + ⟨hstate, hremaining, hvalue, htable, htrace⟩ + have hfirst := firstExistingHiddenRootHitAt_iff_of_eventEq ordinal left right htrace + have hposition := observedFirstLayerRootPosition?_eq_of_eventEq ordinal left right htrace + have hprefix := observedPrefixProbes_eq_of_eventEq ordinal left right htrace + simp only [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + rw [hfinish, hfirst, hposition, hprefix] + +set_option maxRecDepth 100000 in +theorem evalDist_delayedSelectedRootIndicator_eq_of_eventEq + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (leftObservations rightObservations : List CleanProbeObservation) + (selection : PrivateOrdinalSelection) (fuel : Nat) (cache : SplitHashCache) + (htrace : CleanProbeObservationsEventEq leftObservations rightObservations) : + evalDist + (delayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + computation leftObservations selection fuel cache) = + evalDist + (delayedSelectedRootIndicator ordinal parameter root ftsSecret table target rightRoot + computation rightObservations selection fuel cache) := by + classical + unfold delayedSelectedRootIndicator + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + by_cases hsafe : CandidatesAvoidRoots target (truncateHash resolved.output) rightRoot + (selection.candidates.take ordinal) + · simp only [hsafe, ↓reduceIte] + apply evalDist_eq_of_relTriple_eqRel + apply relTriple_map + apply relTriple_post_mono + (relTriple_observedMaterializedBoundary_eventEq parameter root ftsSecret computation + leftObservations rightObservations + (materializedDeferredState resolved.toDeferredContext) + fuel table cache htrace) + intro left right hrel + apply Bool.eq_iff_iff.mpr + simp only [Function.comp_apply, successfulObservedRootComparisonIndicator_eq_true_iff] + exact successfulDoomedFirstRootGoodForComparisonAt_iff_of_eventEq table ordinal target + rightRoot left right hrel + · simp [hsafe] + +theorem plannedProbeSnapshots_length_eq_of_toProbe_eq + {left right : List PlannedProbeSnapshot} + (hsnapshots : left.map PlannedProbeSnapshot.toProbe = + right.map PlannedProbeSnapshot.toProbe) : + left.length = right.length := by + simpa using congrArg List.length hsnapshots + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem evalDist_directDelayedSelectedRootIndicator_eq_of_eventEq + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (leftSnapshots rightSnapshots : List PlannedProbeSnapshot) + (leftObservations rightObservations : List CleanProbeObservation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hleftBefore : ¬ordinal < leftSnapshots.length) + (hrightBefore : ¬ordinal < rightSnapshots.length) + (hsnapshots : leftSnapshots.map PlannedProbeSnapshot.toProbe = + rightSnapshots.map PlannedProbeSnapshot.toProbe) + (htrace : CleanProbeObservationsEventEq leftObservations rightObservations) : + evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot computation leftSnapshots leftObservations context fuel cache) = + evalDist + (directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table target + rightRoot computation rightSnapshots rightObservations context fuel cache) := by + induction computation using OracleComp.inductionOn generalizing + leftSnapshots rightSnapshots leftObservations rightObservations context fuel cache with + | pure value => + simp [directDelayedSelectedRootIndicator, hleftBefore, hrightBefore] + | query_bind query next ih => + rw [directDelayedSelectedRootIndicator, OracleComp.construct_query_bind, + directDelayedSelectedRootIndicator, OracleComp.construct_query_bind] + simp only [hleftBefore, hrightBefore, ↓reduceDIte] + have continueAfter + (run : ProbComp (DirectWitnessResult + ((OracleWorld + SigningSpec).Range query × SplitHashCache))) + (nextLeftSnapshots nextRightSnapshots : List PlannedProbeSnapshot) + (nextLeftObservations nextRightObservations : List CleanProbeObservation) + (hnextLeftBefore : ¬ordinal < nextLeftSnapshots.length) + (hnextRightBefore : ¬ordinal < nextRightSnapshots.length) + (hnextSnapshots : nextLeftSnapshots.map PlannedProbeSnapshot.toProbe = + nextRightSnapshots.map PlannedProbeSnapshot.toProbe) + (hnextTrace : CleanProbeObservationsEventEq + nextLeftObservations nextRightObservations) : + evalDist + (run >>= finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table + target rightRoot (next value.1) laterSnapshots laterObservations + nextContext remaining value.2)) + nextLeftSnapshots nextLeftObservations) = + evalDist + (run >>= finishDirectDelayedSelectedRootIndicator + (canonicalizeDirectDelayedSelectedRootIndicator table + (fun nextContext remaining value laterSnapshots laterObservations ↦ + directDelayedSelectedRootIndicator ordinal parameter root ftsSecret table + target rightRoot (next value.1) laterSnapshots laterObservations + nextContext remaining value.2)) + nextRightSnapshots nextRightObservations) := by + apply evalDist_bind_congr + intro result _hresult + cases result with + | stoppedFuel => rfl + | stoppedOrdinary => rfl + | stoppedPrivate output => rfl + | done result => + simp only [finishDirectDelayedSelectedRootIndicator, + canonicalizeDirectDelayedSelectedRootIndicator] + split + · rfl + · split + · split + · exact ih result.value.1 nextLeftSnapshots nextRightSnapshots + nextLeftObservations nextRightObservations + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hnextLeftBefore hnextRightBefore hnextSnapshots hnextTrace + · rfl + · rfl + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + change Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α at next + simp only + exact continueAfter + (runDirectResolvedWitnessFromTable context fuel table + ((splitUniformImpl n).run cache)) leftSnapshots rightSnapshots + leftObservations rightObservations hleftBefore hrightBefore hsnapshots htrace + | inr input => + change HashOutput → OracleComp (OracleWorld + SigningSpec) α at next + simp only + let plan := purePlanProbingHashQuery parameter input context.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextLeftSnapshots := appendPlannedSnapshot leftSnapshots candidate? context + let nextRightSnapshots := appendPlannedSnapshot rightSnapshots candidate? context + let nextLeftObservations := observationsAfterCandidate leftObservations + (materializedDeferredState context) candidate? + let nextRightObservations := observationsAfterCandidate rightObservations + (materializedDeferredState context) candidate? + have hnextSnapshots : nextLeftSnapshots.map PlannedProbeSnapshot.toProbe = + nextRightSnapshots.map PlannedProbeSnapshot.toProbe := by + cases hcandidate : candidate? <;> + simp [nextLeftSnapshots, nextRightSnapshots, appendPlannedSnapshot, + hcandidate, hsnapshots] + have hnextLength : nextLeftSnapshots.length = nextRightSnapshots.length := + plannedProbeSnapshots_length_eq_of_toProbe_eq hnextSnapshots + have hnextTrace : CleanProbeObservationsEventEq + nextLeftObservations nextRightObservations := by + cases hcandidate : candidate? with + | none => + simpa [nextLeftObservations, nextRightObservations, + observationsAfterCandidate, hcandidate] using htrace + | some candidate => + simpa [nextLeftObservations, nextRightObservations, + observationsAfterCandidate, hcandidate] using + htrace.append_same + [cleanProbeObservation (materializedDeferredState context) + candidate.coordinate candidate.candidate] + by_cases hnextSelected : ordinal < nextLeftSnapshots.length + · have hnextSelectedRight : ordinal < nextRightSnapshots.length := by + rw [← hnextLength] + exact hnextSelected + obtain ⟨candidate, hcandidate⟩ : ∃ candidate, candidate? = some candidate := by + cases hcandidate : candidate? with + | none => + simp [nextLeftSnapshots, appendPlannedSnapshot, hcandidate] at hnextSelected + omega + | some candidate => exact ⟨candidate, rfl⟩ + have hleftLength : leftSnapshots.length = ordinal := by + have hnextLength' : nextLeftSnapshots.length = leftSnapshots.length + 1 := by + simp [nextLeftSnapshots, appendPlannedSnapshot, hcandidate] + omega + have hrightLength : rightSnapshots.length = ordinal := by + have hlength := plannedProbeSnapshots_length_eq_of_toProbe_eq hsnapshots + omega + have hleftGet : nextLeftSnapshots.get ⟨ordinal, hnextSelected⟩ = + (⟨candidate, context⟩ : PlannedProbeSnapshot) := by + simp [nextLeftSnapshots, appendPlannedSnapshot, hcandidate, ← hleftLength, + List.get_eq_getElem] + have hrightGet : nextRightSnapshots.get ⟨ordinal, hnextSelectedRight⟩ = + (⟨candidate, context⟩ : PlannedProbeSnapshot) := by + simp [nextRightSnapshots, appendPlannedSnapshot, hcandidate, ← hrightLength, + List.get_eq_getElem] + have hselection : + (⟨(nextLeftSnapshots.get ⟨ordinal, hnextSelected⟩).probe, + (nextLeftSnapshots.get ⟨ordinal, hnextSelected⟩).context, + nextLeftSnapshots.map PlannedProbeSnapshot.toProbe⟩ : + PrivateOrdinalSelection) = + ⟨(nextRightSnapshots.get ⟨ordinal, hnextSelectedRight⟩).probe, + (nextRightSnapshots.get ⟨ordinal, hnextSelectedRight⟩).context, + nextRightSnapshots.map PlannedProbeSnapshot.toProbe⟩ := by + rw [hleftGet, hrightGet, hnextSnapshots] + have hactualLeft : ordinal < + (appendPlannedSnapshot leftSnapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length := by + simpa [nextLeftSnapshots, candidate?, plan] using hnextSelected + have hactualRight : ordinal < + (appendPlannedSnapshot rightSnapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length := by + simpa [nextRightSnapshots, candidate?, plan] using hnextSelectedRight + rw [dif_pos hactualLeft, dif_pos hactualRight] + rw [hselection] + exact evalDist_delayedSelectedRootIndicator_eq_of_eventEq ordinal parameter root + ftsSecret table target rightRoot + ((liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) : + OracleComp (OracleWorld + SigningSpec) HashOutput) >>= next) + leftObservations rightObservations _ fuel cache htrace + · have hnextSelectedRight : ¬ordinal < nextRightSnapshots.length := by + rw [← hnextLength] + exact hnextSelected + have hactualLeft : ¬ordinal < + (appendPlannedSnapshot leftSnapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length := by + simpa [nextLeftSnapshots, candidate?, plan] using hnextSelected + have hactualRight : ¬ordinal < + (appendPlannedSnapshot rightSnapshots + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input context.state)) context).length := by + simpa [nextRightSnapshots, candidate?, plan] using hnextSelectedRight + rw [dif_neg hactualLeft, dif_neg hactualRight] + convert continueAfter + (runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterRootAwarePlan parameter input plan).run cache)) + nextLeftSnapshots nextRightSnapshots nextLeftObservations nextRightObservations + hnextSelected hnextSelectedRight hnextSnapshots hnextTrace using 1 <;> rfl + | inr message => + change Option Signature → OracleComp (OracleWorld + SigningSpec) α at next + simp only + exact continueAfter + (runDirectResolvedWitnessFromTable context fuel table + ((maskedSign parameter root ftsSecret message).run cache)) + leftSnapshots rightSnapshots leftObservations rightObservations hleftBefore + hrightBefore hsnapshots htrace + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdministrative.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdministrative.lean new file mode 100644 index 00000000..daf97215 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdministrative.lean @@ -0,0 +1,1384 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveObservation + +/-! +# Administrative equivalence for materialized runs + +Proof-only hidden-cache entries are write-only during materialized execution. This file packages +the resulting ordinary-cache equivalence without requiring the deferred context to remain valid or +completable after a recorded hit. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def ObservedFuelRel : + Option (ObservedCleanRunResult α) → Option (ObservedCleanRunResult α) → Prop + | some left, some right => + left.state = right.state ∧ left.table = right.table ∧ + left.value = right.value ∧ left.observations = right.observations + | none, none => True + | _, _ => False + +set_option maxRecDepth 100000 in +theorem relTriple_runObservedCleanFromTable_fuel_of_isQueryBoundP + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (leftFuel rightFuel bound : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hleftFuel : bound ≤ leftFuel) (hrightFuel : bound ≤ rightFuel) : + RelTriple + (runObservedCleanFromTable observations state leftFuel table computation) + (runObservedCleanFromTable observations state rightFuel table computation) + ObservedFuelRel := by + induction computation using OracleComp.inductionOn generalizing + observations state leftFuel rightFuel bound with + | pure value => + simp only [runObservedCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl⟩ + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases query with + | uniform n => + simp only [runObservedCleanFromTable, OracleComp.construct_query_bind] + apply relTriple_bind (relTriple_refl (liftM (unifSpec.query n))) + intro leftOutput rightOutput houtput + subst rightOutput + exact ih leftOutput observations state leftFuel rightFuel bound + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 leftOutput) + hleftFuel hrightFuel + | hashOutput => + simp only [runObservedCleanFromTable, OracleComp.construct_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + exact ih leftOutput observations state leftFuel rightFuel bound + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 leftOutput) + hleftFuel hrightFuel + | ensure coordinate => + simp only [runObservedCleanFromTable, OracleComp.construct_query_bind] + exact ih () observations (state.ensure coordinate) leftFuel rightFuel bound + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) hleftFuel hrightFuel + | probe coordinate candidate => + have hpositive : 0 < bound := by + simpa [LazyRevealProbe.IsProbe] using hbound.1 + cases leftFuel with + | zero => omega + | succ leftRemaining => + cases rightFuel with + | zero => omega + | succ rightRemaining => + rw [runObservedCleanFromTable_probe_query_bind, + runObservedCleanFromTable_probe_query_bind] + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () + (observations ++ [cleanProbeObservation state coordinate candidate]) + state leftRemaining rightRemaining (bound - 1) + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) + (by omega) (by omega) + · simp only [hrevealed, ↓reduceIte] + exact ih () + (observations ++ [cleanProbeObservation state coordinate candidate]) + (state.addPending coordinate candidate) + leftRemaining rightRemaining (bound - 1) + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) + (by omega) (by omega) + | peek coordinate => + simp only [runObservedCleanFromTable, OracleComp.construct_query_bind] + exact ih (state.values coordinate) observations state leftFuel rightFuel bound + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 (state.values coordinate)) + hleftFuel hrightFuel + | publish coordinate => + simp only [runObservedCleanFromTable, OracleComp.construct_query_bind] + exact ih () observations (state.publish coordinate) leftFuel rightFuel bound + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) hleftFuel hrightFuel + | reveal coordinate => + rw [runObservedCleanFromTable_reveal_query_bind, + runObservedCleanFromTable_reveal_query_bind] + cases hvalue : state.values coordinate with + | some output => + exact ih output observations state leftFuel rightFuel bound + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + hleftFuel hrightFuel + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit, ObservedFuelRel] + · simp only [output, hhit, ↓reduceIte] + exact ih output observations + (state.materialize (.chainStart lay tree leafIdx chainIdx) output) + leftFuel rightFuel bound + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + hleftFuel hrightFuel + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + by_cases hhit : state.hitAt (.position position) leftOutput + · simp [hhit, ObservedFuelRel] + · simp only [hhit, ↓reduceIte] + exact ih leftOutput observations + (state.materialize (.position position) leftOutput) + leftFuel rightFuel bound + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 leftOutput) + hleftFuel hrightFuel + +def OrdinaryCacheCleanSameRel : + Option (CleanRunResult (α × SplitHashCache)) → + Option (CleanRunResult (α × SplitHashCache)) → Prop + | some left, some right => + left.state = right.state ∧ left.remaining = right.remaining ∧ + left.table = right.table ∧ left.value.1 = right.value.1 ∧ + ordinaryQueryCache left.value.2 = ordinaryQueryCache right.value.2 + | none, none => True + | _, _ => False + +def OrdinaryCacheCouples + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftCache rightCache, + ordinaryQueryCache leftCache = ordinaryQueryCache rightCache → + ∀ state fuel table, + RelTriple + (runCleanFromTable state fuel table (computation.run leftCache)) + (runCleanFromTable state fuel table (computation.run rightCache)) + OrdinaryCacheCleanSameRel + +def ObservedOrdinaryCacheRel + (leftPrefix rightPrefix : List CleanProbeObservation) : + Option (ObservedCleanRunResult (α × SplitHashCache)) → + Option (ObservedCleanRunResult (α × SplitHashCache)) → Prop + | some left, some right => + left.state = right.state ∧ left.remaining = right.remaining ∧ + left.table = right.table ∧ left.value.1 = right.value.1 ∧ + ordinaryQueryCache left.value.2 = ordinaryQueryCache right.value.2 ∧ + ∃ suffix, + left.observations = leftPrefix ++ suffix ∧ + right.observations = rightPrefix ++ suffix + | none, none => True + | _, _ => False + +theorem ordinaryCacheCouples_pure (value : α) : + OrdinaryCacheCouples + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := by + intro leftCache rightCache hcache state fuel table + simp only [StateT.run_pure, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem OrdinaryCacheCouples.bind + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : OrdinaryCacheCouples left) + (hnext : ∀ value, OrdinaryCacheCouples (next value)) : + OrdinaryCacheCouples (left >>= next) := by + intro leftCache rightCache hcache state fuel table + rw [StateT.run_bind, StateT.run_bind, runCleanFromTable_bind, + runCleanFromTable_bind] + apply relTriple_bind (hleft leftCache rightCache hcache state fuel table) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [OrdinaryCacheCleanSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [OrdinaryCacheCleanSameRel] at hresult + | some rightResult => + rcases hresult with ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + simp only + rw [← hstate, ← hremaining, ← htable, ← hvalue] + exact hnext leftResult.value.1 leftResult.value.2 rightResult.value.2 hnextCache + leftResult.state leftResult.remaining leftResult.table + +theorem ordinaryCacheCouples_sequenceFin + {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, OrdinaryCacheCouples (computation index)) : + OrdinaryCacheCouples (sequenceFin computation) := by + induction n with + | zero => + simp only [sequenceFin] + exact ordinaryCacheCouples_pure Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomponent 0).bind fun _ => + (ih (fun index : Fin n => computation index.succ) + (fun index => hcomponent index.succ)).bind fun _ => + ordinaryCacheCouples_pure _ + +theorem ordinaryCacheCouples_splitUniformImpl (n : Nat) : + OrdinaryCacheCouples (splitUniformImpl n) := by + intro leftCache rightCache hcache state fuel table + unfold splitUniformImpl LazyRevealProbe.uniformQuery + rw [StateT.run_liftM, StateT.run_liftM, + runCleanFromTable_uniform_query_bind, runCleanFromTable_uniform_query_bind] + apply relTriple_bind + (relTriple_refl (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem ordinaryCacheCouples_splitHashQuery_ordinary (input : HashInput) : + OrdinaryCacheCouples (splitHashQuery (.ordinary input)) := by + intro leftCache rightCache hcache state fuel table + have hlookup := congrFun hcache input + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + cases hleft : leftCache (.ordinary input) with + | some output => + have hright : rightCache (.ordinary input) = some output := by + change ordinaryQueryCache rightCache input = some output + rw [← hcache] + exact hleft + simp only [hright, runCleanFromTable, OracleComp.construct_pure] + apply relTriple_pure_pure + exact ⟨rfl, rfl, rfl, rfl, hcache⟩ + | none => + have hright : rightCache (.ordinary input) = none := by + change ordinaryQueryCache rightCache input = none + rw [← hcache] + exact hleft + simp only [hright] + unfold LazyRevealProbe.hashOutputQuery + rw [runCleanFromTable_hashOutput_query_bind, + runCleanFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runCleanFromTable, OracleComp.construct_pure] + apply relTriple_pure_pure + refine ⟨rfl, rfl, rfl, rfl, ?_⟩ + rw [ordinaryQueryCache_update, ordinaryQueryCache_update, hcache] + +theorem ordinaryCacheCouples_simulateQ + {spec : OracleSpec ι} + (impl : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))) + (himpl : ∀ query, OrdinaryCacheCouples (impl query)) + (computation : OracleComp spec α) : + OrdinaryCacheCouples (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + rw [simulateQ_pure] + exact ordinaryCacheCouples_pure value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (himpl query).bind fun output => ih output + +theorem ordinaryCacheCouples_simulateQ_ordinaryHashImpl + (computation : OracleComp HashSpec α) : + OrdinaryCacheCouples (simulateQ ordinaryHashImpl computation) := + ordinaryCacheCouples_simulateQ ordinaryHashImpl + ordinaryCacheCouples_splitHashQuery_ordinary computation + +theorem ordinaryCacheCouples_simulateQ_ordinaryRomImpl + (computation : OracleComp OracleWorld α) : + OrdinaryCacheCouples (simulateQ ordinaryRomImpl computation) := by + apply ordinaryCacheCouples_simulateQ ordinaryRomImpl + intro query + cases query with + | inl n => exact ordinaryCacheCouples_splitUniformImpl n + | inr input => exact ordinaryCacheCouples_splitHashQuery_ordinary input + +theorem ordinaryCacheCouples_ensureCoordinate (coordinate : Coordinate) : + OrdinaryCacheCouples (ensureCoordinate coordinate) := by + intro leftCache rightCache hcache state fuel table + rw [runCleanFromTable_ensureCoordinate, runCleanFromTable_ensureCoordinate] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem ordinaryCacheCouples_probe (candidate : Probe) : + OrdinaryCacheCouples (probe candidate) := by + intro leftCache rightCache hcache state fuel table + unfold probe LazyRevealProbe.probeQuery + rw [StateT.run_liftM, StateT.run_liftM, + runCleanFromTable_probe_query_bind, runCleanFromTable_probe_query_bind] + cases fuel with + | zero => exact relTriple_pure_pure trivial + | succ remaining => + by_cases hrevealed : candidate.coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte, runCleanFromTable, + OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + · simp only [hrevealed, ↓reduceIte, runCleanFromTable, + OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem ordinaryCacheCouples_peekCoordinate (coordinate : Coordinate) : + OrdinaryCacheCouples (peekCoordinate coordinate) := by + intro leftCache rightCache hcache state fuel table + rw [peekCoordinate_run_eq, peekCoordinate_run_eq, LazyRevealProbe.peekQuery, + runCleanFromTable_peek_query_bind, runCleanFromTable_peek_query_bind] + simp only [runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem ordinaryCacheCouples_revealCoordinateOutput (coordinate : Coordinate) : + OrdinaryCacheCouples (revealCoordinateOutput coordinate) := by + intro leftCache rightCache hcache state fuel table + rw [revealCoordinateOutput_run_eq, revealCoordinateOutput_run_eq, + LazyRevealProbe.revealQuery, runCleanFromTable_reveal_query_bind, + runCleanFromTable_reveal_query_bind] + cases hvalue : state.values coordinate with + | some output => + simp only [runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache]⟩ + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + by_cases hhit : state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) + · simp [hhit, OrdinaryCacheCleanSameRel] + · simp only [hhit, ↓reduceIte, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache]⟩ + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + by_cases hhit : state.hitAt (.position position) leftOutput + · simp [hhit, OrdinaryCacheCleanSameRel] + · simp only [hhit, ↓reduceIte, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache]⟩ + +theorem ordinaryCacheCouples_revealCoordinate (coordinate : Coordinate) : + OrdinaryCacheCouples (revealCoordinate coordinate) := by + unfold revealCoordinate + exact (ordinaryCacheCouples_revealCoordinateOutput coordinate).bind fun _ => + ordinaryCacheCouples_pure _ + +theorem ordinaryCacheCouples_publishCoordinate (coordinate : Coordinate) : + OrdinaryCacheCouples (publishCoordinate coordinate) := by + intro leftCache rightCache hcache state fuel table + rw [runCleanFromTable_publishCoordinate, runCleanFromTable_publishCoordinate] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem ordinaryCacheCouples_modifyOrdinary (input : HashInput) (output : HashOutput) : + OrdinaryCacheCouples + (modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output)) := by + intro leftCache rightCache hcache state fuel table + simp only [StateT.run_modify, runCleanFromTable, OracleComp.construct_pure] + apply relTriple_pure_pure + refine ⟨rfl, rfl, rfl, rfl, ?_⟩ + rw [ordinaryQueryCache_update, ordinaryQueryCache_update, hcache] + +theorem ordinaryCacheCouples_resolvePublicKnownInput + (parameter : PublicParameter) (publicState : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) (input : HashInput) : + OrdinaryCacheCouples + (resolvePublicKnownInput parameter publicState coordinate input) := by + unfold resolvePublicKnownInput + cases hknown : purePeekTableInput parameter publicState coordinate with + | none => exact ordinaryCacheCouples_splitHashQuery_ordinary input + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + exact (ordinaryCacheCouples_revealCoordinateOutput coordinate).bind fun output => + (ordinaryCacheCouples_publishCoordinate coordinate).bind fun _ => + (ordinaryCacheCouples_modifyOrdinary input output).bind fun _ => + ordinaryCacheCouples_pure output + · simp only [heq, ↓reduceIte] + exact ordinaryCacheCouples_splitHashQuery_ordinary input + +theorem ordinaryCacheCouples_publicAction + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (action : PlannedHashAction) : + OrdinaryCacheCouples + (probingHashQueryPublicAction parameter input publicState action) := by + cases action with + | ordinary => exact ordinaryCacheCouples_splitHashQuery_ordinary input + | resolve coordinate => + exact ordinaryCacheCouples_resolvePublicKnownInput parameter publicState coordinate input + +theorem ordinaryCacheCouples_ensureChainPrefix + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) : + OrdinaryCacheCouples (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (ordinaryCacheCouples_sequenceFin _ fun step => by + by_cases hstep : step.val < digit.val + · rw [if_pos hstep] + exact ordinaryCacheCouples_ensureCoordinate + (.position (.chain lay tree leafIdx chainIdx step)) + · rw [if_neg hstep] + exact ordinaryCacheCouples_pure ()).bind fun _ => + ordinaryCacheCouples_pure () + +theorem ordinaryCacheCouples_ensureFullChain + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) : + OrdinaryCacheCouples (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (ordinaryCacheCouples_sequenceFin _ fun step => + ordinaryCacheCouples_ensureCoordinate + (.position (.chain lay tree leafIdx chainIdx step))).bind fun _ => + ordinaryCacheCouples_pure () + +theorem ordinaryCacheCouples_ensureOtsLeaf + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + OrdinaryCacheCouples (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (ordinaryCacheCouples_sequenceFin _ fun chainIdx => + ordinaryCacheCouples_ensureFullChain lay tree leafIdx chainIdx).bind fun _ => + ordinaryCacheCouples_ensureCoordinate (.position (.leaf lay tree leafIdx)) + +theorem ordinaryCacheCouples_ensureTreeNode + (lay : Layer) (tree : TreeIndex) : ∀ level nodeIdx, + OrdinaryCacheCouples (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => + ordinaryCacheCouples_ensureOtsLeaf lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (ordinaryCacheCouples_ensureTreeNode lay tree level (2 * nodeIdx)).bind fun _ => + (ordinaryCacheCouples_ensureTreeNode lay tree level (2 * nodeIdx + 1)).bind fun _ => by + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact ordinaryCacheCouples_ensureCoordinate + (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact ordinaryCacheCouples_pure () + +theorem ordinaryCacheCouples_ensureTreePath + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + OrdinaryCacheCouples (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (ordinaryCacheCouples_sequenceFin _ fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + exact ordinaryCacheCouples_ensureTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · rw [if_neg hlevel] + exact ordinaryCacheCouples_pure ()).bind fun _ => + ordinaryCacheCouples_pure () + +theorem ordinaryCacheCouples_maskedTreeNode + (lay : Layer) (tree : TreeIndex) : ∀ level nodeIdx, + OrdinaryCacheCouples (maskedTreeNode lay tree level nodeIdx) + | level, nodeIdx => by + unfold maskedTreeNode + apply (ordinaryCacheCouples_ensureTreeNode lay tree level nodeIdx).bind + intro _ + cases level with + | zero => + exact ordinaryCacheCouples_revealCoordinate + (.position (.leaf lay tree (leafOfNat nodeIdx))) + | succ current => + rw [Nat.add_one] + simp only + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact ordinaryCacheCouples_revealCoordinate + (.position (.node lay tree ⟨current, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact ordinaryCacheCouples_pure 0 + +theorem ordinaryCacheCouples_maskedTreeRoot + (lay : Layer) (tree : TreeIndex) : + OrdinaryCacheCouples (maskedTreeRoot lay tree) := + ordinaryCacheCouples_maskedTreeNode lay tree (layerHeight lay) 0 + +theorem ordinaryCacheCouples_maskedOtsSignFrom + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : ∀ attempts counter, + OrdinaryCacheCouples + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom] + exact ordinaryCacheCouples_pure none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + apply (ordinaryCacheCouples_simulateQ_ordinaryHashImpl + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter))).bind + intro encoded + cases encoded with + | none => + exact ordinaryCacheCouples_maskedOtsSignFrom parameter lay tree leafIdx message + attempts (counter + 1) + | some encoding => + exact (ordinaryCacheCouples_sequenceFin _ fun chainIdx => + ordinaryCacheCouples_ensureChainPrefix lay tree leafIdx chainIdx + (encoding chainIdx)).bind fun _ => + ordinaryCacheCouples_pure + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem ordinaryCacheCouples_maskedOtsSign + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : + OrdinaryCacheCouples (maskedOtsSign parameter lay tree leafIdx message) := + ordinaryCacheCouples_maskedOtsSignFrom parameter lay tree leafIdx message + encodingAttemptLimit 0 + +theorem ordinaryCacheCouples_maskedLayerMessage + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + OrdinaryCacheCouples (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + by_cases hbelow : lay.val + 1 < numLayers + · rw [dif_pos hbelow] + exact ordinaryCacheCouples_maskedTreeRoot ⟨lay.val + 1, hbelow⟩ + (treeIndexAt index ⟨lay.val + 1, hbelow⟩) + · rw [dif_neg hbelow] + exact ordinaryCacheCouples_simulateQ_ordinaryHashImpl + (ftsKey parameter index (ftsSecret index)) + +theorem ordinaryCacheCouples_maskedSignLayer + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + OrdinaryCacheCouples (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + apply (ordinaryCacheCouples_maskedLayerMessage parameter ftsSecret index lay).bind + intro message + apply (ordinaryCacheCouples_maskedOtsSign parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) message).bind + intro selected + cases selected with + | none => exact ordinaryCacheCouples_pure none + | some selected => + exact (ordinaryCacheCouples_ensureTreePath lay + (treeIndexAt index lay) (leafIndexAt index lay)).bind fun _ => + ordinaryCacheCouples_pure (some selected) + +theorem ordinaryCacheCouples_revealPublishedCoordinate (coordinate : Coordinate) : + OrdinaryCacheCouples (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + exact (ordinaryCacheCouples_revealCoordinate coordinate).bind fun _ => + (ordinaryCacheCouples_publishCoordinate coordinate).bind fun _ => + ordinaryCacheCouples_pure _ + +theorem ordinaryCacheCouples_revealLayerValues + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + OrdinaryCacheCouples (revealLayerValues index lay encoding) := by + unfold revealLayerValues + apply (ordinaryCacheCouples_sequenceFin _ fun chainIdx => + ordinaryCacheCouples_revealPublishedCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx))).bind + intro values + apply (ordinaryCacheCouples_sequenceFin _ fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + cases hzero : level.val with + | zero => + exact ordinaryCacheCouples_revealPublishedCoordinate + (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | succ current => + rw [Nat.add_one] + simp only + by_cases hcurrent : current < maxLayerHeight + · rw [dif_pos hcurrent] + exact ordinaryCacheCouples_revealPublishedCoordinate + (.position (.node lay (treeIndexAt index lay) ⟨current, hcurrent⟩ + (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + · rw [dif_neg hcurrent] + exact ordinaryCacheCouples_pure 0 + · rw [if_neg hlevel] + exact ordinaryCacheCouples_pure 0).bind + intro path + exact ordinaryCacheCouples_pure (values, path) + +theorem ordinaryCacheCouples_maskedSignAfterDigest + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + OrdinaryCacheCouples + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest + apply (ordinaryCacheCouples_simulateQ_ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index))).bind + intro ftsPath + apply (ordinaryCacheCouples_sequenceFin _ fun lay => + ordinaryCacheCouples_maskedSignLayer parameter ftsSecret index lay).bind + intro layers + cases hparts : traverseOption layers with + | none => exact ordinaryCacheCouples_pure none + | some parts => + apply (ordinaryCacheCouples_sequenceFin _ fun lay => + ordinaryCacheCouples_revealLayerValues index lay (parts lay).2).bind + intro revealed + let signature : Signature := + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (revealed lay).1 + authPath := flattenPaths fun lay => (revealed lay).2 } + exact ordinaryCacheCouples_pure (some signature) + +theorem ordinaryCacheCouples_maskedSign + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + OrdinaryCacheCouples (maskedSign parameter root ftsSecret message) := by + unfold maskedSign + apply (ordinaryCacheCouples_simulateQ_ordinaryRomImpl + (signDigestLoop digestAttemptLimit + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ message)).bind + intro selected + cases selected with + | none => exact ordinaryCacheCouples_pure none + | some data => + exact ordinaryCacheCouples_maskedSignAfterDigest parameter ftsSecret + data.1 data.2.1 data.2.2 + +theorem relTriple_runObservedCleanFromTable_of_ordinaryCacheCouples_probeFree + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcouples : OrdinaryCacheCouples computation) + (hprobeFree : ProbeFree computation) + (leftPrefix rightPrefix : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) : + RelTriple + (runObservedCleanFromTable leftPrefix state fuel table (computation.run leftCache)) + (runObservedCleanFromTable rightPrefix state fuel table (computation.run rightCache)) + (ObservedOrdinaryCacheRel leftPrefix rightPrefix) := by + have hclean := hcouples leftCache rightCache hcache state fuel table + have hstrength : RelTriple + (runCleanFromTable state fuel table (computation.run leftCache)) + (runCleanFromTable state fuel table (computation.run rightCache)) + (fun left right => ObservedOrdinaryCacheRel leftPrefix rightPrefix + (attachCleanProbeObservations leftPrefix left) + (attachCleanProbeObservations rightPrefix right)) := by + apply relTriple_post_mono hclean + intro left right hrelation + cases left with + | none => + cases right with + | none => trivial + | some right => simp [OrdinaryCacheCleanSameRel] at hrelation + | some left => + cases right with + | none => simp [OrdinaryCacheCleanSameRel] at hrelation + | some right => + rcases hrelation with ⟨hstate, hremaining, htable, hvalue, hcache⟩ + exact ⟨hstate, hremaining, htable, hvalue, hcache, + [], by simp, by simp⟩ + have hpost : RelTriple + (attachCleanProbeObservations leftPrefix <$> + runCleanFromTable state fuel table (computation.run leftCache)) + (attachCleanProbeObservations rightPrefix <$> + runCleanFromTable state fuel table (computation.run rightCache)) + (ObservedOrdinaryCacheRel leftPrefix rightPrefix) := by + exact relTriple_map + (f := attachCleanProbeObservations leftPrefix) + (g := attachCleanProbeObservations rightPrefix) hstrength + rw [map_attachCleanProbeObservations_runCleanFromTable_of_probeFree + (computation.run leftCache) leftPrefix state fuel table (hprobeFree leftCache), + map_attachCleanProbeObservations_runCleanFromTable_of_probeFree + (computation.run rightCache) rightPrefix state fuel table (hprobeFree rightCache)] at hpost + exact hpost + +theorem ordinaryCacheCouples_rootAwarePublicPlan + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) : + OrdinaryCacheCouples + (probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan) := by + unfold probingHashQueryAfterRootAwarePublicPlan executeCandidate? + cases rootAwareCandidateForPlan? parameter input plan with + | none => + exact (ordinaryCacheCouples_pure ()).bind fun _ => + ordinaryCacheCouples_publicAction parameter input publicState plan.action + | some candidate => + exact (ordinaryCacheCouples_probe candidate).bind fun _ => + ordinaryCacheCouples_publicAction parameter input publicState plan.action + +theorem probingHashQueryAfterRootAwarePublicPlan_probeBound + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (cache : SplitHashCache) : + OracleComp.IsQueryBoundP + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 := by + unfold probingHashQueryAfterRootAwarePublicPlan + rw [StateT.run_bind] + cases hcandidate : rootAwareCandidateForPlan? parameter input plan with + | none => + simp only [executeCandidate?, StateT.run_pure] + exact OracleComp.isQueryBoundP_bind (n := 0) (m := 1) (by simp) + (fun result _ => + (probingHashQueryPublicAction_probeFree parameter input publicState plan.action + result.2).mono (by omega)) + | some candidate => + simp only [executeCandidate?] + exact OracleComp.isQueryBoundP_bind (n := 1) (m := 0) + (probe_run_isProbeBound candidate cache) + (fun result _ => + probingHashQueryPublicAction_probeFree parameter input publicState plan.action result.2) + +theorem relTriple_runObservedCleanFromTable_rootAwarePublicPlan_ordinaryCache + (parameter : PublicParameter) (input : HashInput) + (publicState state : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (leftPrefix rightPrefix : List CleanProbeObservation) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) : + RelTriple + (runObservedCleanFromTable leftPrefix state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + leftCache)) + (runObservedCleanFromTable rightPrefix state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache)) + (ObservedOrdinaryCacheRel leftPrefix rightPrefix) := by + let computation := probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan + have hclean := ordinaryCacheCouples_rootAwarePublicPlan parameter input publicState plan + leftCache rightCache hcache state fuel table + have hstrength : RelTriple + (runCleanFromTable state fuel table (computation.run leftCache)) + (runCleanFromTable state fuel table (computation.run rightCache)) + (fun left right => ObservedOrdinaryCacheRel leftPrefix rightPrefix + (attachCleanProbeObservations + (observationsAfterCandidate leftPrefix state + (rootAwareCandidateForPlan? parameter input plan)) left) + (attachCleanProbeObservations + (observationsAfterCandidate rightPrefix state + (rootAwareCandidateForPlan? parameter input plan)) right)) := by + apply relTriple_post_mono hclean + intro left right hrelation + cases left with + | none => + cases right with + | none => trivial + | some right => simp [OrdinaryCacheCleanSameRel] at hrelation + | some left => + cases right with + | none => simp [OrdinaryCacheCleanSameRel] at hrelation + | some right => + rcases hrelation with ⟨hstate, hremaining, htable, hvalue, hcache⟩ + refine ⟨hstate, hremaining, htable, hvalue, hcache, ?_⟩ + cases hcandidate : rootAwareCandidateForPlan? parameter input plan with + | none => + exact ⟨[], by simp [observationsAfterCandidate], + by simp [observationsAfterCandidate]⟩ + | some candidate => + let observation := cleanProbeObservation state candidate.coordinate + candidate.candidate + exact ⟨[observation], by + simp [observationsAfterCandidate, observation], by + simp [observationsAfterCandidate, observation]⟩ + have hmapped := relTriple_map + (f := attachCleanProbeObservations + (observationsAfterCandidate leftPrefix state + (rootAwareCandidateForPlan? parameter input plan))) + (g := attachCleanProbeObservations + (observationsAfterCandidate rightPrefix state + (rootAwareCandidateForPlan? parameter input plan))) hstrength + have hpost : RelTriple + (attachCleanProbeObservations + (observationsAfterCandidate leftPrefix state + (rootAwareCandidateForPlan? parameter input plan)) <$> + runCleanFromTable state fuel table (computation.run leftCache)) + (attachCleanProbeObservations + (observationsAfterCandidate rightPrefix state + (rootAwareCandidateForPlan? parameter input plan)) <$> + runCleanFromTable state fuel table (computation.run rightCache)) + (ObservedOrdinaryCacheRel leftPrefix rightPrefix) := by + exact hmapped + unfold computation at hpost + rw [map_attach_runClean_rootAwarePublic_eq_observed parameter input publicState plan + leftPrefix state fuel table leftCache, + map_attach_runClean_rootAwarePublic_eq_observed parameter input publicState plan + rightPrefix state fuel table rightCache] at hpost + exact hpost + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_observedMaterializedBoundary_ordinaryCache + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (leftPrefix rightPrefix : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) : + RelTriple + (observedMaterializedBoundary parameter root ftsSecret computation leftPrefix state + fuel table leftCache) + (observedMaterializedBoundary parameter root ftsSecret computation rightPrefix state + fuel table rightCache) + (ObservedOrdinaryCacheRel leftPrefix rightPrefix) := by + induction computation using OracleComp.inductionOn generalizing + leftPrefix rightPrefix state fuel leftCache rightCache with + | pure value => + rw [observedMaterializedBoundary, OracleComp.construct_pure, + observedMaterializedBoundary, OracleComp.construct_pure] + apply relTriple_pure_pure + exact ⟨rfl, rfl, rfl, rfl, hcache, [], by simp, by simp⟩ + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind, + observedMaterializedBoundary, OracleComp.construct_query_bind] + have continueAfter + (leftRun rightRun : ProbComp (Option (ObservedCleanRunResult + ((OracleWorld + SigningSpec).Range query × SplitHashCache)))) + (hrun : RelTriple leftRun rightRun + (ObservedOrdinaryCacheRel leftPrefix rightPrefix)) : + RelTriple + (leftRun >>= fun result => + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state result.remaining table + result.value.2) + (rightRun >>= fun result => + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state result.remaining table + result.value.2) + (ObservedOrdinaryCacheRel leftPrefix rightPrefix) := by + apply relTriple_bind hrun + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [ObservedOrdinaryCacheRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [ObservedOrdinaryCacheRel] at hresult + | some rightResult => + rcases hresult with ⟨hstate, hremaining, _htable, hvalue, hnextCache, + suffix, hleftObservations, hrightObservations⟩ + simp only + rw [← hstate, ← hremaining, ← hvalue] + have hnext := ih leftResult.value.1 leftResult.observations + rightResult.observations leftResult.state leftResult.remaining + leftResult.value.2 rightResult.value.2 hnextCache + apply relTriple_post_mono hnext + intro laterLeft laterRight hlater + cases laterLeft with + | none => + cases laterRight with + | none => trivial + | some laterRight => simp [ObservedOrdinaryCacheRel] at hlater + | some laterLeft => + cases laterRight with + | none => simp [ObservedOrdinaryCacheRel] at hlater + | some laterRight => + rcases hlater with ⟨hlaterState, hlaterRemaining, hlaterTable, + hlaterValue, hlaterCache, laterSuffix, hlaterLeft, hlaterRight⟩ + refine ⟨hlaterState, hlaterRemaining, hlaterTable, hlaterValue, + hlaterCache, suffix ++ laterSuffix, ?_, ?_⟩ + · rw [hlaterLeft, hleftObservations, List.append_assoc] + · rw [hlaterRight, hrightObservations, List.append_assoc] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + change Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α at next + simp only + have hstep := + relTriple_runObservedCleanFromTable_of_ordinaryCacheCouples_probeFree + (splitUniformImpl n) (ordinaryCacheCouples_splitUniformImpl n) + (splitUniformImpl_probeFree n) leftPrefix rightPrefix state fuel table + leftCache rightCache hcache + convert continueAfter _ _ hstep using 1 <;> + simp only [observedMaterializedBoundary] <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + | inr input => + change HashOutput → OracleComp (OracleWorld + SigningSpec) α at next + simp only + let publicState := + (materializedCanonicalContext table state).state + let plan := purePlanProbingHashQuery parameter input publicState + have hstep := + relTriple_runObservedCleanFromTable_rootAwarePublicPlan_ordinaryCache + parameter input publicState state plan leftPrefix rightPrefix fuel table + leftCache rightCache hcache + convert continueAfter _ _ hstep using 1 <;> + simp only [publicState, plan, observedMaterializedBoundary] <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + | inr message => + change Option Signature → OracleComp (OracleWorld + SigningSpec) α at next + simp only + have hstep := + relTriple_runObservedCleanFromTable_of_ordinaryCacheCouples_probeFree + (maskedSign parameter root ftsSecret message) + (ordinaryCacheCouples_maskedSign parameter root ftsSecret message) + (maskedSign_probeFree parameter root ftsSecret message) + leftPrefix rightPrefix state fuel table leftCache rightCache hcache + convert continueAfter _ _ hstep using 1 <;> + simp only [observedMaterializedBoundary] <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + +theorem mem_support_runRaw_done_of_mem_runObservedCleanFromTable_some_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ObservedCleanRunResult α) + (hprobeFree : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table computation)) : + LazyRevealProbe.RawResult.done result.state result.remaining result.value ∈ + support (LazyRevealProbe.runRaw state fuel computation) := by + rw [← map_attachCleanProbeObservations_runCleanFromTable_of_probeFree computation + observations state fuel table hprobeFree, support_map] at hresult + obtain ⟨clean?, hclean, hresult⟩ := hresult + cases clean? with + | none => simp [attachCleanProbeObservations] at hresult + | some clean => + simp [attachCleanProbeObservations] at hresult + subst result + exact mem_support_runRaw_done_of_mem_runCleanFromTable_some computation state fuel table + clean hclean + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_observedMaterializedBoundary_fuel_of_isQueryBoundP + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (leftFuel rightFuel bound : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) computation).IsQueryBoundP + (fun query => query matches Sum.inr _) bound) + (hagrees : StartTableAgrees state table) + (hleftFuel : bound ≤ leftFuel) (hrightFuel : bound ≤ rightFuel) : + RelTriple + (observedMaterializedBoundary parameter root ftsSecret computation observations state + leftFuel table cache) + (observedMaterializedBoundary parameter root ftsSecret computation observations state + rightFuel table cache) + ObservedFuelRel := by + induction computation using OracleComp.inductionOn generalizing + observations state leftFuel rightFuel bound cache with + | pure value => + rw [observedMaterializedBoundary, OracleComp.construct_pure, + observedMaterializedBoundary, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl⟩ + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind, + observedMaterializedBoundary, OracleComp.construct_query_bind] + have continueAfter + (step : OracleComp (LazyRevealProbe.World Coordinate) + ((OracleWorld + SigningSpec).Range query × SplitHashCache)) + (stepCost tailBound : Nat) + (hstepBound : step.IsQueryBoundP LazyRevealProbe.IsProbe stepCost) + (htailBound : ∀ result, + some result ∈ support + (runObservedCleanFromTable observations state leftFuel table step) → + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (next result.value.1)).IsQueryBoundP + (fun query => query matches Sum.inr _) tailBound) + (hleftTotal : stepCost + tailBound ≤ leftFuel) + (hrightTotal : stepCost + tailBound ≤ rightFuel) : + RelTriple + (runObservedCleanFromTable observations state leftFuel table step >>= fun result => + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state result.remaining table + result.value.2) + (runObservedCleanFromTable observations state rightFuel table step >>= fun result => + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state result.remaining table + result.value.2) + ObservedFuelRel := by + have hstep := relTriple_runObservedCleanFromTable_fuel_of_isQueryBoundP step + observations state leftFuel rightFuel stepCost table hstepBound + (by omega) (by omega) + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hstep + (fun result => result ∈ support + (runObservedCleanFromTable observations state leftFuel table step)) + (fun result hresult => hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupported + apply relTriple_bind hbothSupported + intro leftResult rightResult hresult + rcases hresult with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [ObservedFuelRel] at hrelation + | some leftResult => + cases rightResult with + | none => simp [ObservedFuelRel] at hrelation + | some rightResult => + rcases hrelation with ⟨hstate, _htable, hvalue, hobservations⟩ + have hleftRemaining := fuel_le_remaining_add_of_mem_runObservedCleanFromTable + step observations state leftFuel table leftResult stepCost hstepBound hleftSupport + have hrightRemaining := fuel_le_remaining_add_of_mem_runObservedCleanFromTable + step observations state rightFuel table rightResult stepCost hstepBound + hrightSupport + simp only + rw [← hstate, ← hvalue, ← hobservations] + have hnextAgrees := startTableAgrees_of_mem_runObservedCleanFromTable + step observations state leftFuel table hagrees leftResult hleftSupport + exact ih leftResult.value.1 leftResult.observations leftResult.state + leftResult.remaining rightResult.remaining tailBound leftResult.value.2 + (htailBound leftResult hleftSupport) hnextAgrees.2 (by omega) (by omega) + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + change Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α at next + simp only + have htail : ∀ result, + some result ∈ support + (runObservedCleanFromTable observations state leftFuel table + ((splitUniformImpl n).run cache)) → + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (next result.value.1)).IsQueryBoundP + (fun query => query matches Sum.inr _) bound := by + intro result _hresult + exact hbound.2 result.value.1 + have hrun := continueAfter ((splitUniformImpl n).run cache) 0 bound + (splitUniformImpl_probeFree n cache) htail (by omega) (by omega) + convert hrun using 1 <;> + simp only [observedMaterializedBoundary] <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + | inr input => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + change HashOutput → OracleComp (OracleWorld + SigningSpec) α at next + simp only + have hpositive : 0 < bound := by + rcases hbound.1 with hnot | hpositive + · exact (hnot (by simp)).elim + · exact hpositive + let publicState := (materializedCanonicalContext table state).state + let plan := purePlanProbingHashQuery parameter input publicState + let step := + (probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + cache + have htail : ∀ result, + some result ∈ support + (runObservedCleanFromTable observations state leftFuel table step) → + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (next result.value.1)).IsQueryBoundP + (fun query => query matches Sum.inr _) (bound - 1) := by + intro result _hresult + exact hbound.2 result.value.1 + have hrun := continueAfter step 1 (bound - 1) + (probingHashQueryAfterRootAwarePublicPlan_probeBound parameter input publicState + plan cache) + htail (by omega) (by omega) + convert hrun using 1 <;> + simp only [step, publicState, plan, observedMaterializedBoundary] <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + | inr message => + rw [simulateQ_expandedAdversaryImpl_query_bind_inr] at hbound + change Option Signature → OracleComp (OracleWorld + SigningSpec) α at next + simp only + have htail : ∀ result, + some result ∈ support + (runObservedCleanFromTable observations state leftFuel table + ((maskedSign parameter root ftsSecret message).run cache)) → + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (next result.value.1)).IsQueryBoundP + (fun query => query matches Sum.inr _) bound := by + intro result hresult + have hnextAgrees := startTableAgrees_of_mem_runObservedCleanFromTable + ((maskedSign parameter root ftsSecret message).run cache) observations state + leftFuel table hagrees result hresult + have hraw := + mem_support_runRaw_done_of_mem_runObservedCleanFromTable_some_of_probeFree + ((maskedSign parameter root ftsSecret message).run cache) observations state + leftFuel table result + (maskedSign_probeFree parameter root ftsSecret message cache) hresult + have houtput : result.value.1 ∈ support + (scheme.sign + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey) message) := by + exact maskedSign_done_output_mem_support parameter root table ftsSecret message + state result.state cache result.value.2 leftFuel result.remaining result.value.1 + hnextAgrees.2 hraw + exact isQueryBoundP_of_bind hbound result.value.1 houtput + have hrun := continueAfter ((maskedSign parameter root ftsSecret message).run cache) + 0 bound (maskedSign_probeFree parameter root ftsSecret message cache) htail + (by omega) (by omega) + convert hrun using 1 <;> + simp only [observedMaterializedBoundary] <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + +theorem exists_finishObservedCleanRunFromTable_of_state_table_eq + (left right : ObservedCleanRunResult α) + (hstate : left.state = right.state) (htable : left.table = right.table) + (hleft : ∃ finalResult, some finalResult ∈ support + (finishObservedCleanRunFromTable (some left))) : + ∃ finalResult, some finalResult ∈ support + (finishObservedCleanRunFromTable (some right)) := by + obtain ⟨leftFinal, hleftFinal⟩ := hleft + unfold finishObservedCleanRunFromTable at hleftFinal ⊢ + simp only at hleftFinal ⊢ + rw [mem_support_bind_iff] at hleftFinal + obtain ⟨finalized, hfinalized, hreturn⟩ := hleftFinal + cases finalized with + | none => simp at hreturn + | some finalized => + rcases finalized with ⟨finalState, finalTable⟩ + refine ⟨⟨finalState, right.remaining, right.value, finalTable, + right.observations⟩, ?_⟩ + rw [mem_support_bind_iff] + refine ⟨some (finalState, finalTable), ?_, by simp⟩ + simpa [← hstate, ← htable] using hfinalized + +theorem ObservedOrdinaryCacheRel.successfulDoomedFirstRootGoodForComparisonAt + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (target : Position) (rightRoot : Digest) + (leftPrefix rightPrefix : List CleanProbeObservation) + (hordinal : leftPrefix.length = ordinal) + (hprobes : leftPrefix.map CleanProbeObservation.toProbe = + rightPrefix.map CleanProbeObservation.toProbe) + (_hleftNoHit : ∀ observation ∈ leftPrefix, ¬observation.ExistingHiddenHit) + (hrightNoHit : ∀ observation ∈ rightPrefix, ¬observation.ExistingHiddenHit) + (left right : ObservedCleanRunResult (α × SplitHashCache)) + (hrel : ObservedOrdinaryCacheRel leftPrefix rightPrefix (some left) (some right)) + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some left)) : + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some right) := by + rcases hrel with ⟨hstate, _hremaining, htable, _hvalue, _hcache, + suffix, hleftObservations, hrightObservations⟩ + have hprefixLength : leftPrefix.length = rightPrefix.length := by + simpa using congrArg List.length hprobes + have hrightOrdinal : rightPrefix.length = ordinal := hprefixLength.symm.trans hordinal + have hobservationLength : left.observations.length = right.observations.length := by + rw [hleftObservations, hrightObservations, List.length_append, List.length_append, + hprefixLength] + rcases hgood with ⟨hhitTarget, hcomparison⟩ + rcases hhitTarget with ⟨hsuccessful, hposition⟩ + rcases hsuccessful with ⟨hfinish, hfirstRoot⟩ + rcases hfirstRoot with ⟨selected, hselected, hfirst, hroot⟩ + have hrightSelectedLt : ordinal < right.observations.length := by + rw [← hobservationLength, ← hselected] + exact selected.isLt + have hleftSelectedLt : ordinal < left.observations.length := by + rw [hobservationLength] + exact hrightSelectedLt + let leftSelected : Fin left.observations.length := ⟨ordinal, hleftSelectedLt⟩ + let rightSelected : Fin right.observations.length := ⟨ordinal, hrightSelectedLt⟩ + have hselectedEq : selected = leftSelected := Fin.ext hselected + have hobservationEq : left.observations.get leftSelected = + right.observations.get rightSelected := by + simp [leftSelected, rightSelected, hleftObservations, hrightObservations, + hordinal, hrightOrdinal] + rcases hfirst with ⟨first, hfirstOrdinal, hfirstHit, _hbefore⟩ + have hfirstEq : first = leftSelected := Fin.ext hfirstOrdinal + subst first + have hrightFirst : FirstExistingHiddenHitAt right ordinal := by + refine ⟨rightSelected, rfl, ?_, ?_⟩ + · rw [ExistingHiddenHitAtOrdinal, ← hobservationEq] + exact hfirstHit + · intro earlier hearlier + have hearlierPrefix : earlier.val < rightPrefix.length := by + rw [hrightOrdinal] + exact hearlier + let before : Fin rightPrefix.length := ⟨earlier.val, hearlierPrefix⟩ + have hobservation : right.observations.get earlier = rightPrefix.get before := by + simp [before, hrightObservations, hearlierPrefix] + rw [ExistingHiddenHitAtOrdinal, hobservation] + exact hrightNoHit (rightPrefix.get before) (List.get_mem _ _) + have hrightRoot : + (right.observations.get rightSelected).toProbe.IsLayerRoot := by + rw [← hobservationEq] + rw [← hselectedEq] + exact hroot + have hrightFirstRoot : + ObservedCleanRunOption.FirstExistingHiddenRootHitAt ordinal (some right) := + ⟨rightSelected, rfl, hrightFirst, hrightRoot⟩ + have hrightPosition : + observedFirstLayerRootPosition? ordinal (some right) = some target := by + unfold observedFirstLayerRootPosition? at hposition ⊢ + simp only [hrightSelectedLt, ↓reduceDIte] + simp only [hleftSelectedLt, ↓reduceDIte] at hposition + change candidateLayerRootPosition? (right.observations.get rightSelected).toProbe = + some target + rw [← hobservationEq] + exact hposition + have hrightComparison : CandidatesAvoidRoot target rightRoot + (observedPrefixProbes ordinal (some right)) := by + have hleftTake : left.observations.take ordinal = leftPrefix := by + rw [hleftObservations, ← hordinal, + List.take_append_of_le_length (Nat.le_refl _), + List.take_length] + have hrightTake : right.observations.take ordinal = rightPrefix := by + rw [hrightObservations, ← hrightOrdinal, + List.take_append_of_le_length (Nat.le_refl _), + List.take_length] + simpa [observedPrefixProbes, hleftTake, hrightTake, hprobes] using hcomparison + have hrightFinish := exists_finishObservedCleanRunFromTable_of_state_table_eq + left right hstate htable hfinish + exact ⟨⟨⟨hrightFinish, hrightFirstRoot⟩, + hrightPosition⟩, hrightComparison⟩ + +theorem ObservedFuelRel.successfulDoomedFirstRootGoodForComparisonAt + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (target : Position) (rightRoot : Digest) + (left right : ObservedCleanRunResult (α × SplitHashCache)) + (hrel : ObservedFuelRel (some left) (some right)) + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some left)) : + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some right) := by + rcases hrel with ⟨hstate, htable, _hvalue, hobservations⟩ + rcases hgood with + ⟨⟨⟨hfinish, hfirstRoot⟩, hposition⟩, hcomparison⟩ + have hrightFinish := exists_finishObservedCleanRunFromTable_of_state_table_eq + left right hstate htable hfinish + have hrightPosition : + observedFirstLayerRootPosition? ordinal (some right) = some target := by + rw [← observedFirstLayerRootPosition?_eq_of_observations_eq ordinal left right + hobservations] + exact hposition + obtain ⟨_selected, _hselected, hfirst, _hroot⟩ := hfirstRoot + have hrightFirst := firstExistingHiddenHitAt_of_observations_eq left right ordinal + hobservations hfirst + have hrightFirstRoot : + ObservedCleanRunOption.FirstExistingHiddenRootHitAt ordinal (some right) := + firstExistingHiddenRootHitAt_of_first_of_position right ordinal target hrightFirst + hrightPosition + have hrightComparison : CandidatesAvoidRoot target rightRoot + (observedPrefixProbes ordinal (some right)) := by + rw [← observedPrefixProbes_eq_of_observations_eq ordinal left right hobservations] + exact hcomparison + exact ⟨⟨⟨hrightFinish, hrightFirstRoot⟩, + hrightPosition⟩, hrightComparison⟩ + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_indicator_observedMaterializedBoundary_ordinaryCache + (ordinal : Nat) (parameter : PublicParameter) (publicRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (leftPrefix rightPrefix : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hordinal : leftPrefix.length = ordinal) + (hprobes : leftPrefix.map CleanProbeObservation.toProbe = + rightPrefix.map CleanProbeObservation.toProbe) + (hleftNoHit : ∀ observation ∈ leftPrefix, ¬observation.ExistingHiddenHit) + (hrightNoHit : ∀ observation ∈ rightPrefix, ¬observation.ExistingHiddenHit) : + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret computation leftPrefix state + fuel table leftCache) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret computation rightPrefix state + fuel table rightCache) + SuccessfulObservedIndicatorRel := by + apply relTriple_map + apply relTriple_post_mono + (relTriple_observedMaterializedBoundary_ordinaryCache parameter publicRoot ftsSecret + computation leftPrefix rightPrefix state fuel table leftCache rightCache hcache) + intro leftResult rightResult hrelation hleftGood + change successfulObservedRootComparisonIndicator table ordinal target + (leftResult, rightRoot) = true at hleftGood + rw [successfulObservedRootComparisonIndicator_eq_true_iff] at hleftGood + change successfulObservedRootComparisonIndicator table ordinal target + (rightResult, rightRoot) = true + rw [successfulObservedRootComparisonIndicator_eq_true_iff] + cases leftResult with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hleftGood + | some leftResult => + cases rightResult with + | none => simp [ObservedOrdinaryCacheRel] at hrelation + | some rightResult => + exact hrelation.successfulDoomedFirstRootGoodForComparisonAt table ordinal target + rightRoot leftPrefix rightPrefix hordinal hprobes hleftNoHit hrightNoHit + leftResult rightResult hleftGood + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_indicator_observedMaterializedBoundary_fuel_of_isQueryBoundP + (ordinal : Nat) (parameter : PublicParameter) (publicRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : OtsSecretIndex → HashOutput) (target : Position) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (leftFuel rightFuel bound : Nat) + (cache : SplitHashCache) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, publicRoot, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) computation).IsQueryBoundP + (fun query => query matches Sum.inr _) bound) + (hagrees : StartTableAgrees state table) + (hleftFuel : bound ≤ leftFuel) (hrightFuel : bound ≤ rightFuel) : + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret computation observations state + leftFuel table cache) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter publicRoot ftsSecret computation observations state + rightFuel table cache) + SuccessfulObservedIndicatorRel := by + apply relTriple_map + apply relTriple_post_mono + (relTriple_observedMaterializedBoundary_fuel_of_isQueryBoundP parameter publicRoot ftsSecret + computation observations state leftFuel rightFuel bound table cache hbound hagrees + hleftFuel hrightFuel) + intro leftResult rightResult hrelation hleftGood + change successfulObservedRootComparisonIndicator table ordinal target + (leftResult, rightRoot) = true at hleftGood + rw [successfulObservedRootComparisonIndicator_eq_true_iff] at hleftGood + change successfulObservedRootComparisonIndicator table ordinal target + (rightResult, rightRoot) = true + rw [successfulObservedRootComparisonIndicator_eq_true_iff] + cases leftResult with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hleftGood + | some leftResult => + cases rightResult with + | none => simp [ObservedFuelRel] at hrelation + | some rightResult => + exact hrelation.successfulDoomedFirstRootGoodForComparisonAt table ordinal target + rightRoot leftResult rightResult hleftGood + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareBoundary.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareBoundary.lean new file mode 100644 index 00000000..bc4a21cf --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareBoundary.lean @@ -0,0 +1,60 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareProbability + +/-! +# Root-aware selector boundary + +The fixed-context root-aware swap bound is lifted through the public top-root computation and the independent high half of the selected layer-root output. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] materializedRootAwareAvoidingOrdinalSelection + materializedActualRootAwareAvoidingOrdinalSelection +set_option linter.constructorNameAsVariable false + +theorem probEvent_uniformActualRoot_materializedRootAwareRootInstalledMatches_le_mul + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (output : Digest → HashOutput) + (htruncate : ∀ root, truncateHash (output root) = root) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) + (hhidden : context.state.values (.position target) = none) + (hprivate : Coordinate.position target ∉ context.state.revealed) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (baseCache : SplitHashCache) + (hbase : ∀ leftRoot rightRoot, + swapCanonicalRootEncodingCache parameter target leftRoot rightRoot baseCache = baseCache) : + let rootContext := fun root => + { context with values := context.values.install target (output root) } + Pr[fun result : Digest × Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter + publicRoot target leftRoot rightRoot ftsSecret computation candidates + (materializedDeferredState (rootContext leftRoot)) fuel table + (rootInstalledCache target output baseCache leftRoot) + pure (leftRoot, rightRoot, selection)] ≤ + Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionAt target result.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter + publicRoot target leftRoot leftRoot ftsSecret computation candidates + (materializedDeferredState (rootContext leftRoot)) fuel table + (rootInstalledCache target output baseCache leftRoot) + pure (leftRoot, selection)] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_uniformActualRoot_materializedRootAwareSelectionFamilyMatches_le_mul ordinal + parameter publicRoot target hroot output htruncate ftsSecret computation candidates context + hhidden hprivate fuel table (rootInstalledCache target output baseCache) + · exact rootInstalledCache_target target output baseCache + · intro leftRoot rightRoot + exact fullSwapRootCache_rootInstalledCache parameter target output baseCache leftRoot rightRoot + (hbase leftRoot rightRoot) + +end SphincsSecurity.Concrete.OtsProbeSimulation + diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareExperiment.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareExperiment.lean new file mode 100644 index 00000000..3f9484c7 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareExperiment.lean @@ -0,0 +1,75 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareSample + +/-! +# Root-aware selector experiment + +The sampled fixed-root bound is averaged over the public top-root computation while keeping the production factor in the same experiment. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option linter.constructorNameAsVariable false +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def rootAwareProductionInitialRun + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (Option (CleanRunResult (Digest × SplitHashCache))) := + runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + +noncomputable def materializedRootAwareOrdinalMatchExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (Digest × Digest × Option Probe) := do + let rootResult ← rootAwareProductionInitialRun fuel table + match rootResult with + | none => pure (0, 0, none) + | some result => + sampledHighMaterializedRootAwareSelectionAfterRootResult ordinal adversary parameter + ftsSecret target result + +noncomputable def materializedRootAwareOrdinalProductionExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (Digest × Option Probe) := do + let rootResult ← rootAwareProductionInitialRun fuel table + match rootResult with + | none => pure (0, none) + | some result => + sampledHighMaterializedRootAwareSelectionProductionAfterRootResult ordinal adversary + parameter ftsSecret target result + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_materializedRootAwareOrdinalMatchExperimentAfterTable_le_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + Pr[fun result => materializedOrdinalSelectionMatches target result.1 result.2.2 | + materializedRootAwareOrdinalMatchExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] ≤ + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + classical + unfold materializedRootAwareOrdinalMatchExperimentAfterTable + materializedRootAwareOrdinalProductionExperimentAfterTable + apply probEvent_bind_le_bind_mul_of_forall + intro rootResult hrootResult + cases rootResult with + | none => + rw [probEvent_pure, probEvent_pure] + simp [materializedOrdinalSelectionMatches, materializedOrdinalSelectionAt] + | some result => + exact probEvent_sampledHigh_materializedRootAwareSelectionAfterRootResult_le_mul ordinal + adversary parameter ftsSecret target hroot hparent fuel table result hrootResult + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareOutcome.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareOutcome.lean new file mode 100644 index 00000000..a556fda4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareOutcome.lean @@ -0,0 +1,145 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareExperiment + +/-! +# Root-aware failure-retaining experiment + +The exact shared-prefix outcome is lifted through the public root samplers and projected to the +root-aware optional selector. Its match event therefore inherits the production-weighted one-guess +bound without discarding the explicit failure marker needed by the joint stopped coupling. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option linter.constructorNameAsVariable false +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def sampledHighMaterializedRootAwareOutcomeAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp (Digest × Digest × MaterializedSelectionOutcome) := do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let output := fun root => rootOutputOfParts root high + let context : DeferredContext := directDeferredContext rootResult.state + let rootContext := + { context with values := context.values.install target (output leftRoot) } + let outcome ← materializedActualRootAwareOrdinalSelectionOutcome ordinal parameter + rootResult.value.1 target leftRoot rightRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState rootContext) rootResult.remaining rootResult.table + (rootInstalledCache target output rootResult.value.2 leftRoot) + pure (leftRoot, rightRoot, outcome) + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_sampledHigh_materializedRootAwareOutcome_optional + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + RelTriple + (sampledHighMaterializedRootAwareOutcomeAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) + (sampledHighMaterializedRootAwareSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) + (fun left right => + left.1 = right.1 ∧ left.2.1 = right.2.1 ∧ + MaterializedOutcomeOptionRel target left.1 left.2.2 right.2.2) := by + unfold sampledHighMaterializedRootAwareOutcomeAfterRootResult + sampledHighMaterializedRootAwareSelectionAfterRootResult + apply relTriple_bind (relTriple_refl ($ᵗ RootOutputHigh : ProbComp RootOutputHigh)) + intro leftHigh rightHigh hhigh + subst rightHigh + apply relTriple_bind (relTriple_refl ($ᵗ Digest : ProbComp Digest)) + intro leftRoot rightRoot hroot + subst rightRoot + apply relTriple_bind (relTriple_refl ($ᵗ Digest : ProbComp Digest)) + intro leftComparison rightComparison hcomparison + subst rightComparison + apply relTriple_bind + (relTriple_materializedActualRootAwareOutcome_optionalSelection ordinal parameter + rootResult.value.1 target leftRoot leftComparison ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState + { directDeferredContext rootResult.state with + values := (directDeferredContext rootResult.state).values.install target + (rootOutputOfParts leftRoot leftHigh) }) + rootResult.remaining rootResult.table + (rootInstalledCache target (fun root => rootOutputOfParts root leftHigh) + rootResult.value.2 leftRoot)) + intro leftOutcome rightSelection hselection + exact relTriple_pure_pure ⟨rfl, rfl, hselection⟩ + +noncomputable def materializedRootAwareOrdinalOutcomeExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (Digest × Digest × MaterializedSelectionOutcome) := do + let rootResult ← runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure (0, 0, .failed) + | some result => + sampledHighMaterializedRootAwareOutcomeAfterRootResult ordinal adversary parameter + ftsSecret target result + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_materializedRootAwareOrdinalOutcome_optional + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + RelTriple + (materializedRootAwareOrdinalOutcomeExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table) + (materializedRootAwareOrdinalMatchExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table) + (fun left right => + left.1 = right.1 ∧ left.2.1 = right.2.1 ∧ + MaterializedOutcomeOptionRel target left.1 left.2.2 right.2.2) := by + unfold materializedRootAwareOrdinalOutcomeExperimentAfterTable + materializedRootAwareOrdinalMatchExperimentAfterTable + apply relTriple_bind (relTriple_refl + (runCleanFromTable (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) + intro leftResult rightResult hresult + subst rightResult + cases leftResult with + | none => + exact relTriple_pure_pure ⟨rfl, rfl, fun hmatch => False.elim hmatch⟩ + | some result => + exact relTriple_sampledHigh_materializedRootAwareOutcome_optional ordinal adversary + parameter ftsSecret target result + +theorem probEvent_materializedRootAwareOrdinalOutcome_match_le + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + Pr[fun result => result.2.2.Matches target result.1 | + materializedRootAwareOrdinalOutcomeExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] ≤ + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ Pr[fun result => materializedOrdinalSelectionMatches target result.1 result.2.2 | + materializedRootAwareOrdinalMatchExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] := by + apply probEvent_le_of_relTriple + (relTriple_materializedRootAwareOrdinalOutcome_optional ordinal adversary parameter + ftsSecret target fuel table) + intro left right hrelation hmatch + rw [← hrelation.1] + exact hrelation.2.2 hmatch + _ ≤ _ := probEvent_materializedRootAwareOrdinalMatchExperimentAfterTable_le_mul ordinal + adversary parameter ftsSecret target hroot hparent fuel table + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareProbability.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareProbability.lean new file mode 100644 index 00000000..5e78ce60 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareProbability.lean @@ -0,0 +1,1198 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootSharedPrefix + +/-! +# Root-aware selector probability + +The shared-prefix outcome executes the proof-only encoding probe that the observed handler executes. +This module gives that outcome a clean optional projection and proves its root-swap bound without +discarding the production weight. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable + +noncomputable def materializedRootAwareAvoidingOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (signer : Message → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option Probe) := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + List Probe → LazyRevealProbe.State Coordinate → Nat → + (OtsSecretIndex → HashOutput) → SplitHashCache → ProbComp (Option Probe)) + (fun _value candidates _state _fuel _table _cache => + if hselected : ordinal < candidates.length then + pure (some (candidates.get ⟨ordinal, hselected⟩)) + else pure none) + (fun query next recursivelyRun candidates state fuel table cache => + if hselected : ordinal < candidates.length then + pure (some (candidates.get ⟨ordinal, hselected⟩)) + else + match query with + | .inl (.inl n) => + runCleanFromTable state fuel table ((splitUniformImpl n).run cache) >>= + finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache)) + candidates + | .inl (.inr input) => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + if hnextSelected : ordinal < nextCandidates.length then + pure (some (nextCandidates.get ⟨ordinal, hnextSelected⟩)) + else if RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? then + runCleanFromTable state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache) >>= + finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache)) + nextCandidates + else pure none + | .inr message => + runCleanFromTable state fuel table ((signer message).run cache) >>= + finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache)) + candidates) + computation candidates state fuel table cache + +noncomputable def materializedActualRootAwareAvoidingOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option Probe) := + materializedRootAwareAvoidingOrdinalSelection ordinal parameter target leftRoot rightRoot + (maskedSign parameter publicRoot ftsSecret) computation candidates state fuel table cache + +noncomputable def materializedComparisonRootAwareAvoidingOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftOutput rightOutput : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option Probe) := + materializedRootAwareAvoidingOrdinalSelection ordinal parameter target + (truncateHash leftOutput) (truncateHash rightOutput) + (maskedSignWithTargetComparison parameter publicRoot target (truncateHash rightOutput) + ftsSecret) + computation candidates state fuel table cache + +set_option maxRecDepth 100000 in +theorem materializedRootAwareAvoidingOrdinalSelection_swap_roots + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (signer : Message → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + materializedRootAwareAvoidingOrdinalSelection ordinal parameter target leftRoot rightRoot + signer computation candidates state fuel table cache = + materializedRootAwareAvoidingOrdinalSelection ordinal parameter target rightRoot leftRoot + signer computation candidates state fuel table cache := by + induction computation using OracleComp.inductionOn generalizing + candidates state fuel cache with + | pure value => simp [materializedRootAwareAvoidingOrdinalSelection] + | query_bind query next ih => + rw [materializedRootAwareAvoidingOrdinalSelection, OracleComp.construct_query_bind, + materializedRootAwareAvoidingOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp [hselected] + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + apply bind_congr + intro result + cases result with + | none => rfl + | some result => + unfold finishMaterializedPrivateOrdinalSelection + continueMaterializedPrivateOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ result.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact ih result.value.1 candidates result.state result.remaining + result.value.2 + | inr input => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp [hactual] + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + have hsafe := rootAwareCandidateAvoidsRoots_swap target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) + rw [propext hsafe] + by_cases hholds : RootAwareCandidateAvoidsRoots target rightRoot leftRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) + · simp only [hholds, ↓reduceIte] + apply bind_congr + intro result + cases result with + | none => rfl + | some result => + unfold finishMaterializedPrivateOrdinalSelection + continueMaterializedPrivateOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ result.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact ih result.value.1 nextCandidates result.state result.remaining + result.value.2 + · simp [hholds] + | inr message => + apply bind_congr + intro result + cases result with + | none => rfl + | some result => + unfold finishMaterializedPrivateOrdinalSelection + continueMaterializedPrivateOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ result.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact ih result.value.1 candidates result.state result.remaining result.value.2 + +theorem rootEncodingCacheCouples_probingHashQueryAfterRootAwarePublicPlan_avoids + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (havoid : RootInputAvoids parameter target leftRoot rightRoot input) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan) := by + unfold probingHashQueryAfterRootAwarePublicPlan + apply (rootEncodingCacheCouples_executeCandidate parameter target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input plan)).bind + intro _ + cases plan.action with + | ordinary => + exact rootEncodingCacheCouples_splitHashQuery_avoids parameter target leftRoot + rightRoot input havoid + | resolve coordinate => + exact rootEncodingCacheCouples_resolvePublicKnownInput_avoids parameter target leftRoot + rightRoot publicState coordinate input havoid + +theorem rootHiddenRelates_probingHashQueryAfterRootAwarePublicPlan + (parameter : PublicParameter) + (target : Position) (leftOutput rightOutput : HashOutput) + (input : HashInput) (publicState : LazyRevealProbe.State Coordinate) + (plan : PlannedHashQuery) + (hsafe : plan.action ≠ .resolve (.position target)) : + RootHiddenRelates target leftOutput rightOutput + (probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan) + (probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan) := by + unfold probingHashQueryAfterRootAwarePublicPlan + apply (rootHiddenRelates_executeCandidate target leftOutput rightOutput + (rootAwareCandidateForPlan? parameter input plan)).bind + intro _ _ _ + cases haction : plan.action with + | ordinary => + exact rootHiddenRelates_splitHashQuery_ordinary target leftOutput rightOutput input + | resolve coordinate => + have hne : coordinate ≠ .position target := by + intro heq + apply hsafe + rw [haction, heq] + exact rootHiddenRelates_resolvePublicKnownInput_of_ne parameter target leftOutput + rightOutput publicState coordinate hne input + +set_option maxRecDepth 100000 in +theorem evalDist_targetRootAwarePublicPlan_then_finish_eq + (parameter : PublicParameter) (target : Position) + (leftOutput rightOutput : HashOutput) + (publicState : LazyRevealProbe.State Coordinate) (input : HashInput) + (plan : PlannedHashQuery) (haction : plan.action = .resolve (.position target)) + (leftState rightState : LazyRevealProbe.State Coordinate) + (hstate : RootHiddenStateRel target leftOutput rightOutput leftState rightState) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache) + (leftObserve rightObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option Probe)) + (candidates : List Probe) + (hrecursive : ∀ leftResult rightResult, + RootHiddenCleanSameRel target leftOutput rightOutput + (some leftResult) (some rightResult) → + evalDist (continueMaterializedPrivateOrdinalSelection target leftObserve + leftResult.state leftResult.remaining leftResult.value.1 leftResult.value.2 candidates) = + evalDist (continueMaterializedPrivateOrdinalSelection target rightObserve + rightResult.state rightResult.remaining rightResult.value.1 rightResult.value.2 + candidates)) : + evalDist + (runCleanFromTable leftState fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + leftCache) >>= + finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target leftObserve) candidates) = + evalDist + (runCleanFromTable rightState fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache) >>= + finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target rightObserve) candidates) := by + unfold probingHashQueryAfterRootAwarePublicPlan + rw [haction, StateT.run_bind, StateT.run_bind, + runCleanFromTable_bind, runCleanFromTable_bind] + simp only [bind_assoc] + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (rootHiddenRelates_executeCandidate target leftOutput rightOutput + (rootAwareCandidateForPlan? parameter input plan) + leftState rightState hstate fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => rfl + | some rightResult => simp [RootHiddenCleanSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootHiddenCleanSameRel] at hresult + | some rightResult => + rcases hresult with ⟨hnextState, hremaining, htable, hvalue, hnextCache⟩ + simp only + rw [← hremaining, ← htable] + exact evalDist_targetPublicResolve_then_finish_eq parameter target leftOutput + rightOutput publicState input leftResult.state rightResult.state hnextState + leftResult.remaining leftResult.table leftResult.value.2 rightResult.value.2 + hnextCache leftObserve rightObserve candidates hrecursive + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem evalDist_materializedRootAwareAvoidingOrdinalSelection_encoding + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target (truncateHash leftOutput) + (truncateHash rightOutput) leftCache rightCache) + (hstored : StoredLayerRoot state target (truncateHash leftOutput)) : + evalDist + (materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot target + (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret computation candidates + state fuel table leftCache) = + evalDist + (materializedComparisonRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot + target leftOutput rightOutput ftsSecret computation candidates state fuel table + rightCache) := by + induction computation using OracleComp.inductionOn generalizing + candidates state fuel leftCache rightCache with + | pure value => + simp [materializedActualRootAwareAvoidingOrdinalSelection, + materializedComparisonRootAwareAvoidingOrdinalSelection, + materializedRootAwareAvoidingOrdinalSelection] + | query_bind query next ih => + unfold materializedActualRootAwareAvoidingOrdinalSelection + materializedComparisonRootAwareAvoidingOrdinalSelection + rw [materializedRootAwareAvoidingOrdinalSelection, OracleComp.construct_query_bind, + materializedRootAwareAvoidingOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp [hselected] + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (((rootEncodingCacheCouples_splitUniformImpl parameter target + (truncateHash leftOutput) (truncateHash rightOutput) n).relates.toStored) + leftCache rightCache hcache state fuel table hstored) + intro leftResult rightResult hresult + apply evalDist_finishMaterializedSelection_eq_of_rootEncoding _ _ candidates _ _ + hresult + intro nextLeft nextRight hnextRel + rcases hnextRel with ⟨hclean, hnextStored⟩ + rcases hclean with ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + rw [← hstate, ← hremaining, ← hvalue] + unfold continueMaterializedPrivateOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ nextLeft.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact ih nextLeft.value.1 candidates nextLeft.state nextLeft.remaining + nextLeft.value.2 nextRight.value.2 hnextCache hnextStored + | inr input => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp [hactual] + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + by_cases hsafe : RootAwareCandidateAvoidsRoots target + (truncateHash leftOutput) (truncateHash rightOutput) candidate? + · have hsafeActual : RootAwareCandidateAvoidsRoots target + (truncateHash leftOutput) (truncateHash rightOutput) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + have hinput : RootInputAvoids parameter target + (truncateHash leftOutput) (truncateHash rightOutput) input := by + apply rootInputAvoids_of_rootAwareCandidateAvoidsRoots + simpa [rootAwareCandidateForPlan?_purePlan] using hsafeActual + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (((rootEncodingCacheCouples_probingHashQueryAfterRootAwarePublicPlan_avoids + parameter target (truncateHash leftOutput) (truncateHash rightOutput) input + (materializedCanonicalContext table state).state plan hinput).relates.toStored) + leftCache rightCache hcache state fuel table hstored) + intro leftResult rightResult hresult + apply evalDist_finishMaterializedSelection_eq_of_rootEncoding _ _ + nextCandidates _ _ hresult + intro nextLeft nextRight hnextRel + rcases hnextRel with ⟨hclean, hnextStored⟩ + rcases hclean with ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + rw [← hstate, ← hremaining, ← hvalue] + unfold continueMaterializedPrivateOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ nextLeft.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact ih nextLeft.value.1 nextCandidates nextLeft.state nextLeft.remaining + nextLeft.value.2 nextRight.value.2 hnextCache hnextStored + · have hsafeActual : ¬RootAwareCandidateAvoidsRoots target + (truncateHash leftOutput) (truncateHash rightOutput) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp [hsafeActual] + | inr message => + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (rootEncodingCacheRelatesStored_maskedSign_targetComparison parameter publicRoot + target hroot (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret message + leftCache rightCache hcache state fuel table hstored) + intro leftResult rightResult hresult + apply evalDist_finishMaterializedSelection_eq_of_rootEncoding _ _ candidates _ _ + hresult + intro nextLeft nextRight hnextRel + rcases hnextRel with ⟨hclean, hnextStored⟩ + rcases hclean with ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + rw [← hstate, ← hremaining, ← hvalue] + unfold continueMaterializedPrivateOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ nextLeft.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact ih nextLeft.value.1 candidates nextLeft.state nextLeft.remaining + nextLeft.value.2 nextRight.value.2 hnextCache hnextStored + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem evalDist_materializedRootAwareAvoidingOrdinalSelection_hidden + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) + (leftState rightState : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hstate : RootHiddenStateRel target leftOutput rightOutput leftState rightState) + (hcache : RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache) : + evalDist + (materializedComparisonRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot + target leftOutput rightOutput ftsSecret computation candidates leftState fuel table + leftCache) = + evalDist + (materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot target + (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret computation candidates + rightState fuel table rightCache) := by + classical + induction computation using OracleComp.inductionOn generalizing + candidates leftState rightState fuel leftCache rightCache with + | pure value => + simp [materializedComparisonRootAwareAvoidingOrdinalSelection, + materializedActualRootAwareAvoidingOrdinalSelection, + materializedRootAwareAvoidingOrdinalSelection] + | query_bind query next ih => + unfold materializedComparisonRootAwareAvoidingOrdinalSelection + materializedActualRootAwareAvoidingOrdinalSelection + rw [materializedRootAwareAvoidingOrdinalSelection, OracleComp.construct_query_bind, + materializedRootAwareAvoidingOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp [hselected] + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (rootHiddenRelates_splitUniformImpl target leftOutput rightOutput n + leftState rightState hstate fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + apply evalDist_finishMaterializedSelection_eq_of_rootHidden target leftOutput + rightOutput _ _ candidates _ _ hresult + intro nextLeft nextRight hnextRel + rcases hnextRel with ⟨hnextState, hremaining, htable, hvalue, hnextCache⟩ + rw [← hremaining, ← hvalue] + unfold continueMaterializedPrivateOrdinalSelection + have hreveal : nextLeft.state.revealed = nextRight.state.revealed := + hnextState.revealed + by_cases hrevealed : Coordinate.position target ∈ nextLeft.state.revealed + · have hrightRevealed : Coordinate.position target ∈ nextRight.state.revealed := by + rwa [← hreveal] + simp [hrevealed, hrightRevealed] + · have hrightRevealed : Coordinate.position target ∉ nextRight.state.revealed := by + intro hmem + exact hrevealed (by rwa [hreveal]) + simp only [hrevealed, hrightRevealed, ↓reduceIte] + exact ih nextLeft.value.1 candidates nextLeft.state nextRight.state + nextLeft.remaining nextLeft.value.2 nextRight.value.2 hnextState hnextCache + | inr input => + have hpublic := materializedCanonicalContext_state_eq_of_rootHidden hstate table + rw [← hpublic] + let publicContext := materializedCanonicalContext table leftState + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table leftState).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp [hactual] + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table leftState).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + by_cases hsafe : RootAwareCandidateAvoidsRoots target + (truncateHash leftOutput) (truncateHash rightOutput) candidate? + · have hsafeActual : RootAwareCandidateAvoidsRoots target + (truncateHash leftOutput) (truncateHash rightOutput) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table leftState).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + let leftObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining value nextCache laterCandidates => + materializedComparisonRootAwareAvoidingOrdinalSelection ordinal parameter + publicRoot target leftOutput rightOutput ftsSecret (next value) + laterCandidates nextState remaining table nextCache + let rightObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining value nextCache laterCandidates => + materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter + publicRoot target (truncateHash leftOutput) (truncateHash rightOutput) + ftsSecret (next value) laterCandidates nextState remaining table nextCache + have hrecursive : ∀ nextLeft nextRight, + RootHiddenCleanSameRel target leftOutput rightOutput + (some nextLeft) (some nextRight) → + evalDist (continueMaterializedPrivateOrdinalSelection target leftObserve + nextLeft.state nextLeft.remaining nextLeft.value.1 nextLeft.value.2 + nextCandidates) = + evalDist (continueMaterializedPrivateOrdinalSelection target rightObserve + nextRight.state nextRight.remaining nextRight.value.1 nextRight.value.2 + nextCandidates) := by + intro nextLeft nextRight hnextRel + rcases hnextRel with ⟨hnextState, hremaining, htable, hvalue, hnextCache⟩ + rw [← hremaining, ← hvalue] + unfold continueMaterializedPrivateOrdinalSelection + have hreveal : nextLeft.state.revealed = nextRight.state.revealed := + hnextState.revealed + by_cases hrevealed : Coordinate.position target ∈ nextLeft.state.revealed + · have hrightRevealed : + Coordinate.position target ∈ nextRight.state.revealed := by + rwa [← hreveal] + simp [hrevealed, hrightRevealed] + · have hrightRevealed : + Coordinate.position target ∉ nextRight.state.revealed := by + intro hmem + exact hrevealed (by rwa [hreveal]) + simp only [hrevealed, hrightRevealed, ↓reduceIte] + exact ih nextLeft.value.1 nextCandidates nextLeft.state nextRight.state + nextLeft.remaining nextLeft.value.2 nextRight.value.2 hnextState hnextCache + letI : Decidable + (plan.action = PlannedHashAction.resolve (.position target)) := + Classical.propDecidable _ + by_cases haction : plan.action = .resolve (.position target) + · exact evalDist_targetRootAwarePublicPlan_then_finish_eq parameter target + leftOutput rightOutput (materializedCanonicalContext table leftState).state + input plan haction leftState rightState hstate fuel table leftCache + rightCache hcache leftObserve rightObserve nextCandidates hrecursive + · apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (rootHiddenRelates_probingHashQueryAfterRootAwarePublicPlan parameter target + leftOutput rightOutput input + (materializedCanonicalContext table leftState).state plan haction + leftState rightState hstate fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + exact evalDist_finishMaterializedSelection_eq_of_rootHidden target leftOutput + rightOutput _ _ nextCandidates _ _ hresult hrecursive + · have hsafeActual : ¬RootAwareCandidateAvoidsRoots target + (truncateHash leftOutput) (truncateHash rightOutput) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table leftState).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp [hsafeActual] + | inr message => + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (rootHiddenRelates_maskedSignWithTargetComparison_actual parameter publicRoot + ftsSecret target hroot leftOutput rightOutput message leftState rightState hstate + fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + apply evalDist_finishMaterializedSelection_eq_of_rootHidden target leftOutput + rightOutput _ _ candidates _ _ hresult + intro nextLeft nextRight hnextRel + rcases hnextRel with ⟨hnextState, hremaining, htable, hvalue, hnextCache⟩ + rw [← hremaining, ← hvalue] + unfold continueMaterializedPrivateOrdinalSelection + have hreveal : nextLeft.state.revealed = nextRight.state.revealed := + hnextState.revealed + by_cases hrevealed : Coordinate.position target ∈ nextLeft.state.revealed + · have hrightRevealed : Coordinate.position target ∈ nextRight.state.revealed := by + rwa [← hreveal] + simp [hrevealed, hrightRevealed] + · have hrightRevealed : Coordinate.position target ∉ nextRight.state.revealed := by + intro hmem + exact hrevealed (by rwa [hreveal]) + simp only [hrevealed, hrightRevealed, ↓reduceIte] + exact ih nextLeft.value.1 candidates nextLeft.state nextRight.state + nextLeft.remaining nextLeft.value.2 nextRight.value.2 hnextState hnextCache + +theorem evalDist_materializedRootAwareAvoidingOrdinalSelection_deferred + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) + (leftContext rightContext : DeferredContext) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcontext : RootDeferredContextRel target leftOutput rightOutput + leftContext rightContext) + (hcache : RootDeferredCacheRel parameter target leftOutput rightOutput + leftCache rightCache) : + evalDist + (materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot target + (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret computation candidates + (materializedDeferredState leftContext) fuel table leftCache) = + evalDist + (materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot target + (truncateHash rightOutput) (truncateHash leftOutput) ftsSecret computation candidates + (materializedDeferredState rightContext) fuel table rightCache) := by + obtain ⟨middleCache, hencoding, hhidden⟩ := hcache + have hmaterialized := hcontext.materialized + have hstored : StoredLayerRoot (materializedDeferredState leftContext) target + (truncateHash leftOutput) := + ⟨leftOutput, hmaterialized.state.left_target, rfl⟩ + calc + _ = evalDist + (materializedComparisonRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot + target leftOutput rightOutput ftsSecret computation candidates + (materializedDeferredState leftContext) fuel table middleCache) := + evalDist_materializedRootAwareAvoidingOrdinalSelection_encoding ordinal parameter publicRoot + target hroot leftOutput rightOutput ftsSecret computation candidates + (materializedDeferredState leftContext) fuel table leftCache middleCache hencoding hstored + _ = evalDist + (materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot target + (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret computation candidates + (materializedDeferredState rightContext) fuel table rightCache) := + evalDist_materializedRootAwareAvoidingOrdinalSelection_hidden ordinal parameter publicRoot + target hroot leftOutput rightOutput ftsSecret computation candidates + (materializedDeferredState leftContext) (materializedDeferredState rightContext) fuel table + middleCache rightCache hmaterialized.state hhidden + _ = _ := congrArg evalDist + (materializedRootAwareAvoidingOrdinalSelection_swap_roots ordinal parameter target + (truncateHash leftOutput) (truncateHash rightOutput) + (maskedSign parameter publicRoot ftsSecret) computation candidates + (materializedDeferredState rightContext) fuel table rightCache) + +theorem evalDist_materializedRootAwareAvoidingOrdinalSelection_fullSwap + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) + (hhidden : context.state.values (.position target) = none) + (hprivate : Coordinate.position target ∉ context.state.revealed) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) + (hcache : cache (.hidden (.position target)) = some leftOutput) : + let leftContext := + { context with values := context.values.install target leftOutput } + let rightContext := + { context with values := context.values.install target rightOutput } + evalDist + (materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot target + (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret computation candidates + (materializedDeferredState leftContext) fuel table cache) = + evalDist + (materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot target + (truncateHash rightOutput) (truncateHash leftOutput) ftsSecret computation candidates + (materializedDeferredState rightContext) fuel table + (fullSwapRootCache parameter target (truncateHash leftOutput) + (truncateHash rightOutput) rightOutput cache)) := by + dsimp only + exact evalDist_materializedRootAwareAvoidingOrdinalSelection_deferred ordinal parameter + publicRoot target hroot leftOutput rightOutput ftsSecret computation candidates _ _ fuel table + cache _ (rootDeferredContextRel_install target leftOutput rightOutput context hhidden hprivate) + (rootDeferredCacheRel_fullSwapRootCache parameter target leftOutput rightOutput cache hcache) + +set_option maxRecDepth 100000 in +theorem evalDist_materializedActualRootAwareAvoidingOrdinalSelection_family_swap + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (output : Digest → HashOutput) + (htruncate : ∀ root, truncateHash (output root) = root) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) + (hhidden : context.state.values (.position target) = none) + (hprivate : Coordinate.position target ∉ context.state.revealed) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : Digest → SplitHashCache) + (htargetCache : ∀ root, + cache root (.hidden (.position target)) = some (output root)) + (hcacheSwap : ∀ leftRoot rightRoot, + fullSwapRootCache parameter target leftRoot rightRoot (output rightRoot) + (cache leftRoot) = cache rightRoot) + (leftRoot rightRoot : Digest) : + let rootContext := fun root => + { context with values := context.values.install target (output root) } + evalDist + (materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot target + leftRoot rightRoot ftsSecret computation candidates + (materializedDeferredState (rootContext leftRoot)) fuel table (cache leftRoot)) = + evalDist + (materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot target + rightRoot leftRoot ftsSecret computation candidates + (materializedDeferredState (rootContext rightRoot)) fuel table (cache rightRoot)) := by + dsimp only + have hswap := evalDist_materializedRootAwareAvoidingOrdinalSelection_fullSwap ordinal parameter + publicRoot target hroot (output leftRoot) (output rightRoot) ftsSecret computation candidates + context hhidden hprivate fuel table (cache leftRoot) (htargetCache leftRoot) + rw [htruncate leftRoot, htruncate rightRoot] at hswap + simpa only [hcacheSwap leftRoot rightRoot] using hswap + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_materializedRootAwareAvoidingOrdinalSelection_weaken_comparison + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot matchRoot : Digest) + (signer : Message → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + RelTriple + (materializedRootAwareAvoidingOrdinalSelection ordinal parameter target leftRoot rightRoot signer + computation candidates state fuel table cache) + (materializedRootAwareAvoidingOrdinalSelection ordinal parameter target leftRoot leftRoot signer + computation candidates state fuel table cache) + (MaterializedOptionMatchRel target matchRoot) := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + simp only [materializedRootAwareAvoidingOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure (fun hmatch => hmatch) + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure (fun hmatch => hmatch) + | query_bind query next ih => + rw [materializedRootAwareAvoidingOrdinalSelection, OracleComp.construct_query_bind, + materializedRootAwareAvoidingOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure (fun hmatch => hmatch) + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let leftObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedRootAwareAvoidingOrdinalSelection ordinal parameter target leftRoot + rightRoot signer (next output) laterCandidates nextState remaining table + nextCache + let rightObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedRootAwareAvoidingOrdinalSelection ordinal parameter target leftRoot + leftRoot signer (next output) laterCandidates nextState remaining table + nextCache + apply relTriple_bind + (relTriple_refl + (runCleanFromTable state fuel table ((splitUniformImpl n).run cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishMaterializedSelection_weaken target matchRoot + (continueMaterializedPrivateOrdinalSelection target leftObserve) + (continueMaterializedPrivateOrdinalSelection target rightObserve) + candidates leftResult + intro resolved + unfold continueMaterializedPrivateOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ resolved.state.revealed + · simp [hrevealed, MaterializedOptionMatchRel, + materializedOrdinalSelectionMatches] + · simpa [hrevealed, leftObserve, rightObserve] using + ih resolved.value.1 candidates resolved.state resolved.remaining + resolved.value.2 + | inr input => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + exact relTriple_pure_pure (fun hmatch => hmatch) + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + by_cases hsafe : RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? + · have hsafeActual : RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + have hleftSafe := rootAwareCandidateAvoidsRoots_actual target leftRoot rightRoot + candidate? hsafe + have hleftSafeActual : RootAwareCandidateAvoidsRoots target leftRoot leftRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hleftSafe + simp only [hsafeActual, hleftSafeActual, ↓reduceIte] + let leftObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedRootAwareAvoidingOrdinalSelection ordinal parameter target leftRoot + rightRoot signer (next output) laterCandidates nextState remaining table + nextCache + let rightObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedRootAwareAvoidingOrdinalSelection ordinal parameter target leftRoot + leftRoot signer (next output) laterCandidates nextState remaining table + nextCache + apply relTriple_bind + (relTriple_refl + (runCleanFromTable state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state plan).run + cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishMaterializedSelection_weaken target matchRoot + (continueMaterializedPrivateOrdinalSelection target leftObserve) + (continueMaterializedPrivateOrdinalSelection target rightObserve) + nextCandidates leftResult + intro resolved + unfold continueMaterializedPrivateOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ resolved.state.revealed + · simp [hrevealed, MaterializedOptionMatchRel, + materializedOrdinalSelectionMatches] + · simpa [hrevealed, leftObserve, rightObserve] using + ih resolved.value.1 nextCandidates resolved.state resolved.remaining + resolved.value.2 + · have hsafeActual : ¬RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + exact relTriple_none_any_materializedOptionMatch target matchRoot _ + | inr message => + let leftObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedRootAwareAvoidingOrdinalSelection ordinal parameter target leftRoot + rightRoot signer (next output) laterCandidates nextState remaining table nextCache + let rightObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedRootAwareAvoidingOrdinalSelection ordinal parameter target leftRoot leftRoot + signer (next output) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_refl (runCleanFromTable state fuel table ((signer message).run cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishMaterializedSelection_weaken target matchRoot + (continueMaterializedPrivateOrdinalSelection target leftObserve) + (continueMaterializedPrivateOrdinalSelection target rightObserve) + candidates leftResult + intro resolved + unfold continueMaterializedPrivateOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ resolved.state.revealed + · simp [hrevealed, MaterializedOptionMatchRel, + materializedOrdinalSelectionMatches] + · simpa [hrevealed, leftObserve, rightObserve] using + ih resolved.value.1 candidates resolved.state resolved.remaining resolved.value.2 + +theorem probEvent_materializedRootAwareAvoidingOrdinalSelection_match_le_actual_guard + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot matchRoot : Digest) + (signer : Message → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + Pr[materializedOrdinalSelectionMatches target matchRoot | + materializedRootAwareAvoidingOrdinalSelection ordinal parameter target leftRoot rightRoot + signer computation candidates state fuel table cache] ≤ + Pr[materializedOrdinalSelectionMatches target matchRoot | + materializedRootAwareAvoidingOrdinalSelection ordinal parameter target leftRoot leftRoot + signer computation candidates state fuel table cache] := + probEvent_le_of_relTriple + (relTriple_materializedRootAwareAvoidingOrdinalSelection_weaken_comparison ordinal parameter + target leftRoot rightRoot matchRoot signer computation candidates state fuel table cache) + (fun _ _ hrelation => hrelation) + +set_option maxRecDepth 100000 in +theorem probEvent_sampledComparisonRoot_materializedRootAwareSelectionMatches_le_mul + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot : Digest) + (signer : Message → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2 | do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← materializedRootAwareAvoidingOrdinalSelection ordinal parameter target + leftRoot rightRoot signer computation candidates state fuel table cache + pure (rightRoot, selection)] ≤ + Pr[materializedOrdinalSelectionAt target | + materializedRootAwareAvoidingOrdinalSelection ordinal parameter target leftRoot leftRoot signer + computation candidates state fuel table cache] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let reference := materializedRootAwareAvoidingOrdinalSelection ordinal parameter target leftRoot + leftRoot signer computation candidates state fuel table cache + calc + _ ≤ Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2 | do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← reference + pure (rightRoot, selection)] := by + apply probEvent_bind_le_bind_of_forall_le + intro rightRoot _hrightRoot + rw [show (do + let selection ← materializedRootAwareAvoidingOrdinalSelection ordinal parameter target + leftRoot rightRoot signer computation candidates state fuel table cache + pure (rightRoot, selection)) = + (fun selection => (rightRoot, selection)) <$> + materializedRootAwareAvoidingOrdinalSelection ordinal parameter target leftRoot rightRoot + signer computation candidates state fuel table cache by + simp [map_eq_bind_pure_comp], + show (do + let selection ← reference + pure (rightRoot, selection)) = + (fun selection => (rightRoot, selection)) <$> reference by + simp [map_eq_bind_pure_comp], probEvent_map, probEvent_map] + exact probEvent_materializedRootAwareAvoidingOrdinalSelection_match_le_actual_guard ordinal + parameter target leftRoot rightRoot rightRoot signer computation candidates state fuel table + cache + _ ≤ Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionAt target result.2 ∧ + result.1 = selectedProbeDigest result.2 | do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← reference + pure (rightRoot, selection)] := by + apply probEvent_mono + intro result _hresult hmatch + exact ⟨materializedOrdinalSelectionAt_of_matches hmatch, + materializedOrdinalSelectionMatches_root_eq_selectedProbeDigest hmatch⟩ + _ ≤ _ := by + apply probEvent_uniform_root_matches_distribution_independent_guess_le_mul + (fun _rightRoot => reference) reference + intro rightRoot + rfl + + +set_option maxRecDepth 100000 in +theorem probEvent_uniformActualRoot_materializedRootAwareSelectionFamilyMatches_le_mul + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (output : Digest → HashOutput) + (htruncate : ∀ root, truncateHash (output root) = root) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) + (hhidden : context.state.values (.position target) = none) + (hprivate : Coordinate.position target ∉ context.state.revealed) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : Digest → SplitHashCache) + (htargetCache : ∀ root, + cache root (.hidden (.position target)) = some (output root)) + (hcacheSwap : ∀ leftRoot rightRoot, + fullSwapRootCache parameter target leftRoot rightRoot (output rightRoot) + (cache leftRoot) = cache rightRoot) : + let rootContext := fun root => + { context with values := context.values.install target (output root) } + Pr[fun result : Digest × Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter + publicRoot target leftRoot rightRoot ftsSecret computation candidates + (materializedDeferredState (rootContext leftRoot)) fuel table (cache leftRoot) + pure (leftRoot, rightRoot, selection)] ≤ + Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionAt target result.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter + publicRoot target leftRoot leftRoot ftsSecret computation candidates + (materializedDeferredState (rootContext leftRoot)) fuel table (cache leftRoot) + pure (leftRoot, selection)] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + dsimp only + let run : Digest → Digest → ProbComp (Option Probe) := + fun leftRoot rightRoot => + materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot target leftRoot + rightRoot ftsSecret computation candidates + (materializedDeferredState + { context with values := context.values.install target (output leftRoot) }) + fuel table (cache leftRoot) + let reference : Digest → ProbComp (Option Probe) := + fun leftRoot => + materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot target leftRoot + leftRoot ftsSecret computation candidates + (materializedDeferredState + { context with values := context.values.install target (output leftRoot) }) + fuel table (cache leftRoot) + apply probEvent_uniformActualRoot_match_le_of_swap_of_comparison_mul target run reference + · intro leftRoot rightRoot + exact evalDist_materializedActualRootAwareAvoidingOrdinalSelection_family_swap ordinal parameter + publicRoot target hroot output htruncate ftsSecret computation candidates context hhidden + hprivate fuel table cache htargetCache hcacheSwap leftRoot rightRoot + · intro leftRoot + exact probEvent_sampledComparisonRoot_materializedRootAwareSelectionMatches_le_mul ordinal parameter + target leftRoot (maskedSign parameter publicRoot ftsSecret) computation candidates + (materializedDeferredState + { context with values := context.values.install target (output leftRoot) }) + fuel table (cache leftRoot) + + + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_materializedActualRootAwareOutcome_optionalSelection + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + RelTriple + (materializedActualRootAwareOrdinalSelectionOutcome ordinal parameter publicRoot target + leftRoot rightRoot ftsSecret computation candidates state fuel table cache) + (materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot target + leftRoot rightRoot ftsSecret computation candidates state fuel table cache) + (MaterializedOutcomeOptionRel target leftRoot) := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + simp only [materializedActualRootAwareOrdinalSelectionOutcome, + materializedActualRootAwareAvoidingOrdinalSelection, + materializedRootAwareAvoidingOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length <;> + simp only [hselected, ↓reduceDIte] <;> + exact relTriple_pure_pure (fun hmatch => hmatch) + | query_bind query next ih => + rw [materializedActualRootAwareOrdinalSelectionOutcome, + OracleComp.construct_query_bind, + materializedActualRootAwareAvoidingOrdinalSelection, + materializedRootAwareAvoidingOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure (fun hmatch => hmatch) + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + change Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α at next + let outcomeObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → ProbComp MaterializedSelectionOutcome := + fun nextState remaining output nextCache laterCandidates => + materializedActualRootAwareOrdinalSelectionOutcome ordinal parameter publicRoot + target leftRoot rightRoot ftsSecret (next output) laterCandidates nextState + remaining table nextCache + let optionObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter + publicRoot target leftRoot rightRoot ftsSecret (next output) laterCandidates + nextState remaining table nextCache + apply relTriple_of_evalDist_eq_right + (evalDist_runDetailedMaterializedSelection_eq_clean target optionObserve + candidates state fuel table ((splitUniformImpl n).run cache)) + apply relTriple_bind + (relTriple_refl + (runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + ((splitUniformImpl n).run cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishMaterializedOutcome_option target leftRoot table + outcomeObserve optionObserve candidates leftResult + intro resolved hcompletable hprivate + simpa [outcomeObserve, optionObserve] using + ih resolved.value.1 candidates resolved.context.state resolved.remaining + resolved.value.2 + | inr input => + change HashOutput → OracleComp (OracleWorld + SigningSpec) α at next + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + exact relTriple_pure_pure (fun hmatch => hmatch) + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + by_cases hsafe : RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? + · have hsafeActual : RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + let outcomeObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp MaterializedSelectionOutcome := + fun nextState remaining output nextCache laterCandidates => + materializedActualRootAwareOrdinalSelectionOutcome ordinal parameter + publicRoot target leftRoot rightRoot ftsSecret (next output) + laterCandidates nextState remaining table nextCache + let optionObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter + publicRoot target leftRoot rightRoot ftsSecret (next output) + laterCandidates nextState remaining table nextCache + let inner := + (probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache + apply relTriple_of_evalDist_eq_right + (evalDist_runDetailedMaterializedSelection_eq_clean target optionObserve + nextCandidates state fuel table inner) + apply relTriple_bind + (relTriple_refl + (runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + inner)) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishMaterializedOutcome_option target leftRoot table + outcomeObserve optionObserve nextCandidates leftResult + intro resolved hcompletable hprivate + simpa [outcomeObserve, optionObserve] using + ih resolved.value.1 nextCandidates resolved.context.state + resolved.remaining resolved.value.2 + · have hsafeActual : ¬RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + exact relTriple_pure_pure (fun hmatch => hmatch) + | inr message => + change Option Signature → OracleComp (OracleWorld + SigningSpec) α at next + let outcomeObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → ProbComp MaterializedSelectionOutcome := + fun nextState remaining output nextCache laterCandidates => + materializedActualRootAwareOrdinalSelectionOutcome ordinal parameter publicRoot + target leftRoot rightRoot ftsSecret (next output) laterCandidates nextState + remaining table nextCache + let optionObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter publicRoot + target leftRoot rightRoot ftsSecret (next output) laterCandidates nextState + remaining table nextCache + let inner := (maskedSign parameter publicRoot ftsSecret message).run cache + apply relTriple_of_evalDist_eq_right + (evalDist_runDetailedMaterializedSelection_eq_clean target optionObserve candidates + state fuel table inner) + apply relTriple_bind + (relTriple_refl + (runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table inner)) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishMaterializedOutcome_option target leftRoot table outcomeObserve + optionObserve candidates leftResult + intro resolved hcompletable hprivate + simpa [outcomeObserve, optionObserve] using + ih resolved.value.1 candidates resolved.context.state resolved.remaining + resolved.value.2 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareSample.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareSample.lean new file mode 100644 index 00000000..c1faa646 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareSample.lean @@ -0,0 +1,117 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareBoundary + +/-! +# Root-aware selector sampling + +The installed-cache bound is averaged over the high half of the selected layer-root output while the public top-root result remains fixed. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option linter.constructorNameAsVariable false +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def sampledHighMaterializedRootAwareSelectionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp (Digest × Digest × Option Probe) := do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let output := fun root => rootOutputOfParts root high + let context : DeferredContext := directDeferredContext rootResult.state + let rootContext := + { context with values := context.values.install target (output leftRoot) } + let selection ← materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter + rootResult.value.1 target leftRoot rightRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState rootContext) rootResult.remaining rootResult.table + (rootInstalledCache target output rootResult.value.2 leftRoot) + pure (leftRoot, rightRoot, selection) + +noncomputable def sampledHighMaterializedRootAwareSelectionProductionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp (Digest × Option Probe) := do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let output := fun root => rootOutputOfParts root high + let context : DeferredContext := directDeferredContext rootResult.state + let rootContext := + { context with values := context.values.install target (output leftRoot) } + let selection ← materializedActualRootAwareAvoidingOrdinalSelection ordinal parameter + rootResult.value.1 target leftRoot leftRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState rootContext) rootResult.remaining rootResult.table + (rootInstalledCache target output rootResult.value.2 leftRoot) + pure (leftRoot, selection) + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledHigh_materializedRootAwareSelectionAfterRootResult_le_mul_of_neutral + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hhidden : rootResult.state.values (.position target) = none) + (hprivate : Coordinate.position target ∉ rootResult.state.revealed) + (hbase : ∀ leftRoot rightRoot, + swapCanonicalRootEncodingCache parameter target leftRoot rightRoot rootResult.value.2 = + rootResult.value.2) : + Pr[fun result => materializedOrdinalSelectionMatches target result.1 result.2.2 | + sampledHighMaterializedRootAwareSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult] ≤ + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + sampledHighMaterializedRootAwareSelectionProductionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + unfold sampledHighMaterializedRootAwareSelectionAfterRootResult + sampledHighMaterializedRootAwareSelectionProductionAfterRootResult + apply probEvent_bind_le_bind_mul_of_forall + intro high _hhigh + apply probEvent_uniformActualRoot_materializedRootAwareRootInstalledMatches_le_mul ordinal + parameter rootResult.value.1 target hroot (fun root => rootOutputOfParts root high) + (fun root => truncateHash_rootOutputOfParts root high) ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (directDeferredContext rootResult.state) hhidden hprivate rootResult.remaining + rootResult.table rootResult.value.2 + intro leftRoot rightRoot + exact hbase leftRoot rightRoot + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledHigh_materializedRootAwareSelectionAfterRootResult_le_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) : + Pr[fun result => materializedOrdinalSelectionMatches target result.1 result.2.2 | + sampledHighMaterializedRootAwareSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult] ≤ + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + sampledHighMaterializedRootAwareSelectionProductionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + have habsent : + rootResult.state.values (.position target) = none ∧ + Coordinate.position target ∉ rootResult.state.revealed := + target_absent_of_mem_runCleanFromTable_maskedPublishedTreeRoot target hroot hparent fuel table + rootResult hresult + apply + probEvent_sampledHigh_materializedRootAwareSelectionAfterRootResult_le_mul_of_neutral ordinal + adversary parameter ftsSecret target hroot rootResult habsent.1 habsent.2 + intro leftRoot rightRoot + exact swapCanonicalRootEncodingCache_of_mem_runCleanFromTable_maskedPublishedTreeRoot parameter + target leftRoot rightRoot (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel table rootResult hresult + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareSharedExperiment.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareSharedExperiment.lean new file mode 100644 index 00000000..17b14fa8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareSharedExperiment.lean @@ -0,0 +1,79 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareOutcome +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootJoint + +/-! +# Sampled shared root prefix + +This is the concrete joint experiment whose left projection is the eagerly resolved observed run +and whose right projection is the failure-retaining root-aware outcome. Running the common prefix +once is what preserves the successful stopped gate while the outcome is classified. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option linter.constructorNameAsVariable false +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def sampledHighObservedRootAwareSharedAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp + (Digest × Digest × + Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × + MaterializedSelectionOutcome) := do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let output := fun root => rootOutputOfParts root high + let context : DeferredContext := directDeferredContext rootResult.state + let rootContext := + { context with values := context.values.install target (output leftRoot) } + let pair ← observedRootSelectionSharedPrefix ordinal parameter rootResult.value.1 target leftRoot + rightRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + (materializedDeferredState rootContext) rootResult.remaining rootResult.table + (rootInstalledCache target output rootResult.value.2 leftRoot) + pure (leftRoot, rightRoot, retainObservedRoot rootResult.value.1 pair.1, pair.2) + +noncomputable def sampledHighEagerObservedRootAwareAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp + (Digest × Digest × + Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))) := do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let output := fun root => rootOutputOfParts root high + let context : DeferredContext := directDeferredContext rootResult.state + let rootContext := + { context with values := context.values.install target (output leftRoot) } + let observed ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState rootContext) rootResult.remaining rootResult.table + (rootInstalledCache target output rootResult.value.2 leftRoot) + pure (leftRoot, rightRoot, retainObservedRoot rootResult.value.1 observed) + +noncomputable def observedRootAwareSharedExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp + (Digest × Digest × + Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × + MaterializedSelectionOutcome) := do + let rootResult ← runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure (0, 0, none, .failed) + | some result => + sampledHighObservedRootAwareSharedAfterRootResult ordinal adversary parameter + ftsSecret target result + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareSharedSemantic.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareSharedSemantic.lean new file mode 100644 index 00000000..9d161f47 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareSharedSemantic.lean @@ -0,0 +1,1887 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareSharedExperiment + +/-! +# Successful shared-prefix semantics + +The lemmas in this module eliminate the conservative failure arm of the root-aware outcome under +the successful first-root gate carried by the observed marginal. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option linter.constructorNameAsVariable false +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxRecDepth 100000 in +theorem revealed_subset_of_done_runDirectResolvedDetailedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation)) : + context.state.revealed ⊆ result.context.state.revealed := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runDirectResolvedDetailedFromTable] at hresult + subst result + exact Finset.Subset.rfl + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectResolvedDetailedFromTable_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hrest + | hashOutput => + rw [runDirectResolvedDetailedFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hrest + | ensure coordinate => + rw [runDirectResolvedDetailedFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel hresult + | probe coordinate candidate => + rw [runDirectResolvedDetailedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · exact ih () context remaining (by simpa [hrevealed] using hresult) + · exact ih () + { context with state := context.state.addPending coordinate candidate } + remaining (by simpa [hrevealed] using hresult) + | peek coordinate => + rw [runDirectResolvedDetailedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hresult + | publish coordinate => + rw [runDirectResolvedDetailedFromTable_publish_query_bind] at hresult + have htail := ih () + { context with state := context.state.publish coordinate } fuel hresult + intro other hother + apply htail + simp [LazyRevealProbe.State.publish, hother] + | reveal coordinate => + rw [runDirectResolvedDetailedFromTable_reveal_query_bind] at hresult + cases hstate : context.state.values coordinate with + | some output => + simp only [hstate] at hresult + exact ih output context fuel hresult + | none => + simp only [hstate] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + exact ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel hresult + | position position => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hprivate, hhit] at hresult + · simp only [hprivate, hhit, ↓reduceIte] at hresult + exact ih output + { state := context.state.materialize (.position position) output + values := context.values } + fuel hresult + | none => + simp only [hprivate, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hrest + · simp only [hhit, ↓reduceIte] at hrest + exact ih output + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel hrest + +theorem revealed_subset_of_mem_runObservedCleanFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (result : ObservedCleanRunResult α) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table computation)) : + state.revealed ⊆ result.state.revealed := by + have hclean : some result.toClean ∈ support + (runCleanFromTable state fuel table computation) := by + rw [← map_projectObservedCleanRun_runObservedCleanFromTable computation observations + state fuel table, support_map] + exact ⟨some result, hresult, rfl⟩ + rw [← map_projectDirectDetailedClean_run_eq_clean computation state fuel table, + support_map] at hclean + obtain ⟨detailed, hdetailed, hproject⟩ := hclean + cases detailed with + | stopped reason => + simp [projectDirectDetailedClean, DirectDetailedResult.toOption, + projectResolvedRunResult] at hproject + | done detailed => + have heq : result.toClean = + ⟨detailed.context.state, detailed.remaining, detailed.value, detailed.table⟩ := by + exact Option.some.inj (by simpa [projectDirectDetailedClean, + DirectDetailedResult.toOption, projectResolvedRunResult] using hproject.symm) + have hstate : result.state = detailed.context.state := congrArg CleanRunResult.state heq + rw [hstate] + exact revealed_subset_of_done_runDirectResolvedDetailedFromTable computation + (directDeferredContext state) fuel table detailed hdetailed + +set_option maxRecDepth 100000 in +theorem revealedAtProbe_of_mem_runObservedCleanFromTable_of_initial_revealed : + ∀ (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (target : Position) (ordinal : Nat) + (result : ObservedCleanRunResult α), + Coordinate.position target ∈ state.revealed → + observations.length ≤ ordinal → + some result ∈ support + (runObservedCleanFromTable observations state fuel table computation) → + (hordinal : ordinal < result.observations.length) → + (result.observations.get ⟨ordinal, hordinal⟩).coordinate = .position target → + (result.observations.get ⟨ordinal, hordinal⟩).revealedAtProbe = true + | computation, observations, state, fuel, table, target, ordinal, result, + hrevealed, hlength, hresult, hordinal, hcoordinate => by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table with + | pure value => + simp [runObservedCleanFromTable] at hresult + subst result + simp at hordinal + omega + | query_bind input next ih => + cases input with + | uniform n => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output observations state fuel table hrevealed hlength hrest + | hashOutput => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output observations state fuel table hrevealed hlength hrest + | ensure coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih () observations (state.ensure coordinate) fuel table hrevealed hlength hresult + | probe coordinate candidate => + rw [runObservedCleanFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + let observation := cleanProbeObservation state coordinate candidate + let nextObservations := observations ++ [observation] + have hprefix : nextObservations <+: result.observations := by + by_cases hcoordinateRevealed : coordinate ∈ state.revealed + · exact observations_prefix_of_mem_runObservedCleanFromTable + (next ()) nextObservations state remaining table result + (by simpa [hcoordinateRevealed, nextObservations, observation] using hresult) + · exact observations_prefix_of_mem_runObservedCleanFromTable + (next ()) nextObservations (state.addPending coordinate candidate) remaining + table result + (by simpa [hcoordinateRevealed, nextObservations, observation] using hresult) + by_cases heq : observations.length = ordinal + · have hnextLength : ordinal < nextObservations.length := by + simp [nextObservations, heq] + have hget := hprefix.getElem hnextLength + subst ordinal + have hprobeCoordinate : coordinate = .position target := by + have hcoordinateEq := congrArg CleanProbeObservation.coordinate hget + change result.observations[observations.length].coordinate = + .position target at hcoordinate + simpa [nextObservations, observation, cleanProbeObservation] using + hcoordinateEq.trans hcoordinate + subst coordinate + have hrevealedEq := congrArg CleanProbeObservation.revealedAtProbe hget + change result.observations[observations.length].revealedAtProbe = true + exact hrevealedEq.symm.trans (by + simp [nextObservations, observation, cleanProbeObservation, hrevealed]) + · have hnextLength : nextObservations.length ≤ ordinal := by + simp [nextObservations] + omega + by_cases hcoordinateRevealed : coordinate ∈ state.revealed + · exact ih () nextObservations state remaining table hrevealed hnextLength + (by simpa [hcoordinateRevealed, nextObservations, observation] using hresult) + · exact ih () nextObservations (state.addPending coordinate candidate) remaining + table hrevealed hnextLength + (by simpa [hcoordinateRevealed, nextObservations, observation] using hresult) + | peek coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih (state.values coordinate) observations state fuel table hrevealed hlength + hresult + | publish coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih () observations (state.publish coordinate) fuel table + (by simp [LazyRevealProbe.State.publish, hrevealed]) hlength hresult + | reveal coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + simp only [hvalue] at hresult + exact ih output observations state fuel table hrevealed hlength hresult + | none => + simp only [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + exact ih output observations + (state.materialize (.chainStart lay tree leafIdx chainIdx) output) fuel + table hrevealed hlength hresult + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : state.hitAt (.position position) output + · simp [hhit] at hrest + · simp only [hhit, ↓reduceIte] at hrest + exact ih output observations (state.materialize (.position position) output) + fuel table hrevealed hlength hrest + +theorem revealedAtProbe_of_prefix + {before after : List CleanProbeObservation} {ordinal : Nat} {target : Position} + (hprefix : before <+: after) + (hbefore : ordinal < before.length) (hafter : ordinal < after.length) + (hcoordinate : (after.get ⟨ordinal, hafter⟩).coordinate = .position target) + (hrevealed : (before.get ⟨ordinal, hbefore⟩).revealedAtProbe = true) : + (after.get ⟨ordinal, hafter⟩).revealedAtProbe = true := by + have hget := hprefix.getElem hbefore + have hcoordinateEq := congrArg CleanProbeObservation.coordinate hget + change after[ordinal].coordinate = .position target at hcoordinate + have _hbeforeCoordinate : before[ordinal].coordinate = .position target := + hcoordinateEq.trans hcoordinate + have hrevealedEq := congrArg CleanProbeObservation.revealedAtProbe hget + change before[ordinal].revealedAtProbe = true at hrevealed + change after[ordinal].revealedAtProbe = true + exact hrevealedEq.symm.trans hrevealed + +set_option maxRecDepth 100000 in +theorem revealedAtProbe_of_mem_observedMaterializedBoundary_of_initial_revealed : + ∀ (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (ordinal : Nat) + (result : ObservedCleanRunResult (α × SplitHashCache)), + Coordinate.position target ∈ state.revealed → + observations.length ≤ ordinal → + some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache) → + (hordinal : ordinal < result.observations.length) → + (result.observations.get ⟨ordinal, hordinal⟩).coordinate = .position target → + (result.observations.get ⟨ordinal, hordinal⟩).revealedAtProbe = true + | parameter, root, ftsSecret, computation, observations, state, fuel, table, cache, target, + ordinal, result, hrevealed, hlength, hresult, hordinal, hcoordinate => by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table cache with + | pure value => + simp [observedMaterializedBoundary] at hresult + obtain rfl := hresult + simp at hordinal + omega + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind] at hresult + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + by_cases hbefore : ordinal < step.observations.length + · have hstepRevealed := + revealedAtProbe_of_mem_runObservedCleanFromTable_of_initial_revealed + ((splitUniformImpl n).run cache) observations state fuel table target + ordinal step hrevealed hlength hstep hbefore (by + have hprefix := observations_prefix_of_mem_observedMaterializedBoundary + parameter root ftsSecret (next step.value.1) step.observations + step.state step.remaining table step.value.2 result + (by simpa only [observedMaterializedBoundary] using hrest) + have hget := hprefix.getElem hbefore + have hcoordinateEq := congrArg CleanProbeObservation.coordinate hget + change result.observations[ordinal].coordinate = .position target at hcoordinate + exact hcoordinateEq.trans hcoordinate) + have hprefix := observations_prefix_of_mem_observedMaterializedBoundary + parameter root ftsSecret (next step.value.1) step.observations step.state + step.remaining table step.value.2 result + (by simpa only [observedMaterializedBoundary] using hrest) + exact revealedAtProbe_of_prefix hprefix hbefore hordinal hcoordinate + hstepRevealed + · have hstepRevealed : Coordinate.position target ∈ step.state.revealed := + revealed_subset_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run cache) observations state fuel table step hstep + hrevealed + exact ih step.value.1 step.observations step.state step.remaining table + step.value.2 hstepRevealed (Nat.le_of_not_gt hbefore) + (by simpa only [observedMaterializedBoundary] using hrest) + | inr input => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let stepComputation := + (probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache + by_cases hbefore : ordinal < step.observations.length + · have hprefix := observations_prefix_of_mem_observedMaterializedBoundary + parameter root ftsSecret (next step.value.1) step.observations step.state + step.remaining table step.value.2 result + (by simpa only [observedMaterializedBoundary] using hrest) + have hget := hprefix.getElem hbefore + have hcoordinateEq := congrArg CleanProbeObservation.coordinate hget + have hstepCoordinate : + (step.observations.get ⟨ordinal, hbefore⟩).coordinate = + .position target := by + change result.observations[ordinal].coordinate = .position target at hcoordinate + exact hcoordinateEq.trans hcoordinate + have hstepRevealed := + revealedAtProbe_of_mem_runObservedCleanFromTable_of_initial_revealed + stepComputation observations state fuel table target ordinal step + hrevealed hlength hstep hbefore hstepCoordinate + exact revealedAtProbe_of_prefix hprefix hbefore hordinal hcoordinate + hstepRevealed + · have hstepRevealed : Coordinate.position target ∈ step.state.revealed := + revealed_subset_of_mem_runObservedCleanFromTable stepComputation observations + state fuel table step hstep hrevealed + exact ih step.value.1 step.observations step.state step.remaining table + step.value.2 hstepRevealed (Nat.le_of_not_gt hbefore) + (by simpa only [observedMaterializedBoundary] using hrest) + | inr message => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + let stepComputation := (maskedSign parameter root ftsSecret message).run cache + by_cases hbefore : ordinal < step.observations.length + · have hprefix := observations_prefix_of_mem_observedMaterializedBoundary + parameter root ftsSecret (next step.value.1) step.observations step.state + step.remaining table step.value.2 result + (by simpa only [observedMaterializedBoundary] using hrest) + have hget := hprefix.getElem hbefore + have hcoordinateEq := congrArg CleanProbeObservation.coordinate hget + have hstepCoordinate : + (step.observations.get ⟨ordinal, hbefore⟩).coordinate = .position target := by + change result.observations[ordinal].coordinate = .position target at hcoordinate + exact hcoordinateEq.trans hcoordinate + have hstepRevealed := + revealedAtProbe_of_mem_runObservedCleanFromTable_of_initial_revealed + stepComputation observations state fuel table target ordinal step hrevealed + hlength hstep hbefore hstepCoordinate + exact revealedAtProbe_of_prefix hprefix hbefore hordinal hcoordinate hstepRevealed + · have hstepRevealed : Coordinate.position target ∈ step.state.revealed := + revealed_subset_of_mem_runObservedCleanFromTable stepComputation observations + state fuel table step hstep hrevealed + exact ih step.value.1 step.observations step.state step.remaining table + step.value.2 hstepRevealed (Nat.le_of_not_gt hbefore) + (by simpa only [observedMaterializedBoundary] using hrest) + +theorem observations_eq_of_mem_runObservedCleanFromTable_rootAwarePublic + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ObservedCleanRunResult (HashOutput × SplitHashCache)) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache))) : + result.observations = observationsAfterCandidate observations state + (rootAwareCandidateForPlan? parameter input plan) := by + have hmapped : some result ∈ support + (attachCleanProbeObservations + (observationsAfterCandidate observations state + (rootAwareCandidateForPlan? parameter input plan)) <$> + runCleanFromTable state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache)) := by + rw [map_attach_runClean_rootAwarePublic_eq_observed] + exact hresult + rw [support_map] at hmapped + obtain ⟨clean, _hclean, hattach⟩ := hmapped + cases clean with + | none => simp [attachCleanProbeObservations] at hattach + | some clean => + have heq : result = + (⟨clean.state, clean.remaining, clean.value, clean.table, + observationsAfterCandidate observations state + (rootAwareCandidateForPlan? parameter input plan)⟩ : + ObservedCleanRunResult (HashOutput × SplitHashCache)) := by + simpa [attachCleanProbeObservations] using Option.some.inj hattach.symm + exact congrArg ObservedCleanRunResult.observations heq + +set_option maxRecDepth 100000 in +theorem revealed_subset_of_mem_observedMaterializedBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hresult : some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache)) : + state.revealed ⊆ result.state.revealed := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table cache with + | pure value => + simp [observedMaterializedBoundary] at hresult + obtain rfl := hresult + exact Finset.Subset.rfl + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind] at hresult + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + exact (revealed_subset_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run cache) observations state fuel table step hstep).trans + (ih step.value.1 step.observations step.state step.remaining table + step.value.2 (by simpa only [observedMaterializedBoundary] using hrest)) + | inr input => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + exact (revealed_subset_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache) observations state fuel table step hstep).trans + (ih step.value.1 step.observations step.state step.remaining table + step.value.2 (by simpa only [observedMaterializedBoundary] using hrest)) + | inr message => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + exact (revealed_subset_of_mem_runObservedCleanFromTable + ((maskedSign parameter root ftsSecret message).run cache) observations state fuel + table step hstep).trans + (ih step.value.1 step.observations step.state step.remaining table + step.value.2 (by simpa only [observedMaterializedBoundary] using hrest)) + +theorem finished_probe_matches_of_successful_root + {table : OtsSecretIndex → HashOutput} {ordinal : Nat} {target : Position} + {rightRoot leftRoot : Digest} + {result : ObservedCleanRunResult α} {candidate : Probe} + {selected : Fin result.observations.length} + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result)) + (hselected : selected.val = ordinal) + (hcandidate : candidate = (result.observations.get selected).toProbe) + (hstored : StoredLayerRoot result.state target leftRoot) + (htracked : CleanProbeObservationsTrackedBy result.observations result.state) : + (MaterializedSelectionOutcome.finished (some candidate)).Matches target leftRoot := by + obtain ⟨⟨⟨⟨_finalResult, _hfinish⟩, + goodSelected, hgoodSelected, hfirst, _hroot⟩, + hposition⟩, _hcomparison⟩ := hgood + obtain ⟨hitSelected, hhitSelected, hhit, _hnoEarlier⟩ := hfirst + have hselectedEq : selected = goodSelected := + Fin.ext (hselected.trans hgoodSelected.symm) + have hhitSelectedEq : hitSelected = goodSelected := + Fin.ext (hhitSelected.trans hgoodSelected.symm) + subst selected + subst hitSelected + have hlt : ordinal < result.observations.length := by + rw [← hgoodSelected] + exact goodSelected.isLt + have hindex : (⟨ordinal, hlt⟩ : Fin result.observations.length) = goodSelected := + Fin.ext hgoodSelected.symm + have htargetData : + (result.observations.get goodSelected).coordinate = .position target ∧ + IsLayerRoot target := by + simp only [observedFirstLayerRootPosition?, hlt, ↓reduceDIte] at hposition + rw [candidateLayerRootPosition?_eq_some_iff, hindex] at hposition + exact hposition + obtain ⟨_hhidden, output, hvalueAtProbe, hdigest⟩ := hhit + have htrackedObservation := htracked + (result.observations.get goodSelected) (List.get_mem _ _) + have hfinalValue := htrackedObservation.1 output hvalueAtProbe + obtain ⟨stored, hstoredValue, hstoredDigest⟩ := hstored + rw [htargetData.1] at hfinalValue + have houtput : output = stored := Option.some.inj (hfinalValue.symm.trans hstoredValue) + subst stored + change candidate = ⟨.position target, leftRoot⟩ + rw [hcandidate] + unfold CleanProbeObservation.toProbe + rw [htargetData.1, ← hdigest, hstoredDigest] + +theorem selected_finish_matches_of_successful_root + {table : OtsSecretIndex → HashOutput} {ordinal : Nat} {target : Position} + {rightRoot leftRoot : Digest} + {parameter : PublicParameter} {publicRoot : Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {computation : OracleComp (OracleWorld + SigningSpec) α} + {observations : List CleanProbeObservation} {candidates : List Probe} + {state : LazyRevealProbe.State Coordinate} {fuel : Nat} {cache : SplitHashCache} + (hselected : ordinal < candidates.length) + (haligned : candidates = observations.map CleanProbeObservation.toProbe) + (hstored : StoredLayerRoot state target leftRoot) + (htracked : CleanProbeObservationsTrackedBy observations state) + {result : ObservedCleanRunResult (α × SplitHashCache)} + (hrun : some result ∈ support + (observedMaterializedBoundary parameter publicRoot ftsSecret computation observations state + fuel table cache)) + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result)) : + (MaterializedSelectionOutcome.finished + (some (candidates.get ⟨ordinal, hselected⟩))).Matches target leftRoot := by + have hgood' := hgood + obtain ⟨⟨⟨⟨_finalResult, _hfinish⟩, + goodSelected, hgoodSelected, _hfirst, _hroot⟩, + _hposition⟩, _hcomparison⟩ := hgood + have hobservationSelected : ordinal < observations.length := by + simpa [haligned] using hselected + have hprefix := observations_prefix_of_mem_observedMaterializedBoundary parameter publicRoot + ftsSecret computation observations state fuel table cache result hrun + have hget : observations[ordinal] = result.observations[ordinal] := + hprefix.getElem hobservationSelected + have hresultSelected : ordinal < result.observations.length := by + rw [← hgoodSelected] + exact goodSelected.isLt + have hindex : (⟨ordinal, hresultSelected⟩ : Fin result.observations.length) = goodSelected := + Fin.ext hgoodSelected.symm + have hcandidatesGet : candidates.get ⟨ordinal, hselected⟩ = + (observations.get ⟨ordinal, hobservationSelected⟩).toProbe := by + subst candidates + simp + have hcandidate : candidates.get ⟨ordinal, hselected⟩ = + (result.observations.get goodSelected).toProbe := by + rw [hcandidatesGet, ← hindex] + exact congrArg CleanProbeObservation.toProbe hget + have hstoredFinal : StoredLayerRoot result.state target leftRoot := + storedLayerRoot_mono hstored + (valuesLE_of_mem_observedMaterializedBoundary parameter publicRoot ftsSecret computation + observations state fuel table cache result hrun) + have htrackedFinal := cleanProbeObservationsTrackedBy_of_mem_observedMaterializedBoundary + parameter publicRoot ftsSecret computation observations state fuel table cache htracked result + hrun + exact finished_probe_matches_of_successful_root hgood' hgoodSelected hcandidate hstoredFinal + htrackedFinal + +theorem not_hasExistingHiddenHit_of_prefix_first_at_or_after + {before : List CleanProbeObservation} {result : ObservedCleanRunResult α} + {ordinal : Nat} + (hprefix : before <+: result.observations) + (hlength : before.length ≤ ordinal) + (hfirst : FirstExistingHiddenHitAt result ordinal) : + ¬(⟨result.state, result.remaining, result.value, result.table, before⟩ : + ObservedCleanRunResult α).HasExistingHiddenHit := by + rintro ⟨observation, hobservation, hhit⟩ + obtain ⟨beforeIndex, hget⟩ := List.mem_iff_get.mp hobservation + have hresultIndex : beforeIndex.val < result.observations.length := + lt_of_lt_of_le beforeIndex.isLt hprefix.length_le + let resultIndex : Fin result.observations.length := ⟨beforeIndex.val, hresultIndex⟩ + obtain ⟨selected, hselected, _hselectedHit, hnoEarlier⟩ := hfirst + apply hnoEarlier resultIndex (lt_of_lt_of_le beforeIndex.isLt hlength) + have hprefixGet : before[beforeIndex.val] = result.observations[resultIndex.val] := + hprefix.getElem beforeIndex.isLt + simpa [ExistingHiddenHitAtOrdinal, resultIndex, ← hprefixGet, ← hget] using hhit + +theorem successful_root_not_of_noncompletable_prefix + {table : OtsSecretIndex → HashOutput} {ordinal : Nat} {target : Position} + {rightRoot : Digest} + {parameter : PublicParameter} {publicRoot : Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {computation : OracleComp (OracleWorld + SigningSpec) α} + {observations : List CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} {fuel : Nat} {cache : SplitHashCache} + (hlength : observations.length ≤ ordinal) + (htracked : CleanProbeObservationsTrackedBy observations state) + (hcovered : CleanProbeObservationsCoverPending observations state) + (hstarts : StartTableAgrees state table) + (hbudget : fuel + state.pending.card < Fintype.card Digest) + (hnotCompletable : ¬DeferredCompletable table (directDeferredContext state)) + {result : ObservedCleanRunResult (α × SplitHashCache)} + (hrun : some result ∈ support + (observedMaterializedBoundary parameter publicRoot ftsSecret computation observations state + fuel table cache)) + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result)) : False := by + obtain ⟨⟨⟨⟨finalResult, hfinish⟩, + _selected, _hselected, hfirst, _hroot⟩, + _hposition⟩, _hcomparison⟩ := hgood + have hprefix := observations_prefix_of_mem_observedMaterializedBoundary parameter publicRoot + ftsSecret computation observations state fuel table cache result hrun + have hnoHit : ¬(⟨state, fuel, result.value, table, observations⟩ : + ObservedCleanRunResult (α × SplitHashCache)).HasExistingHiddenHit := by + apply not_hasExistingHiddenHit_of_prefix_first_at_or_after hprefix hlength hfirst + have hvalid : (directDeferredContext state).Valid := + directDeferredContext_valid_of_no_existingHiddenHit + ⟨state, fuel, result.value, table, observations⟩ htracked hcovered hnoHit + have hmissing := missingChainStartHit_of_doomed_direct_valid table state + ⟨hvalid.valuesConsistent, hstarts, hnotCompletable⟩ hvalid (by omega) + exact not_missingChainStartHit_of_successful_observedMaterializedBoundary parameter publicRoot + ftsSecret computation observations state fuel table cache result finalResult hrun hfinish + hmissing + +theorem successful_root_not_of_revealed_prefix + {table : OtsSecretIndex → HashOutput} {ordinal : Nat} {target : Position} + {rightRoot : Digest} + {parameter : PublicParameter} {publicRoot : Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {computation : OracleComp (OracleWorld + SigningSpec) α} + {observations : List CleanProbeObservation} + {state : LazyRevealProbe.State Coordinate} {fuel : Nat} {cache : SplitHashCache} + (hlength : observations.length ≤ ordinal) + (hrevealed : Coordinate.position target ∈ state.revealed) + {result : ObservedCleanRunResult (α × SplitHashCache)} + (hrun : some result ∈ support + (observedMaterializedBoundary parameter publicRoot ftsSecret computation observations state + fuel table cache)) + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result)) : False := by + obtain ⟨⟨⟨⟨_finalResult, _hfinish⟩, + selected, hselected, hfirst, _hroot⟩, + hposition⟩, _hcomparison⟩ := hgood + obtain ⟨hitSelected, hhitSelected, hhit, _hnoEarlier⟩ := hfirst + have hselectedEq : hitSelected = selected := + Fin.ext (hhitSelected.trans hselected.symm) + subst hitSelected + obtain ⟨hhidden, _output, _hvalue, _hdigest⟩ := hhit + have hlt : ordinal < result.observations.length := by + rw [← hselected] + exact selected.isLt + have hindex : (⟨ordinal, hlt⟩ : Fin result.observations.length) = selected := + Fin.ext hselected.symm + have htargetData : + (result.observations.get selected).coordinate = .position target := by + simp only [observedFirstLayerRootPosition?, hlt, ↓reduceDIte] at hposition + rw [candidateLayerRootPosition?_eq_some_iff, hindex] at hposition + exact hposition.1 + have hrevealedAtProbe := + revealedAtProbe_of_mem_observedMaterializedBoundary_of_initial_revealed parameter publicRoot + ftsSecret computation observations state fuel table cache target ordinal result hrevealed + hlength hrun hlt (by simpa [hindex] using htargetData) + rw [hindex] at hrevealedAtProbe + exact Bool.false_ne_true (hhidden.symm.trans hrevealedAtProbe) + +theorem selected_finish_pair_matches_of_successful_root + {table : OtsSecretIndex → HashOutput} {ordinal : Nat} {target : Position} + {rightRoot leftRoot : Digest} + {parameter : PublicParameter} {publicRoot : Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {computation : OracleComp (OracleWorld + SigningSpec) α} + {observations : List CleanProbeObservation} {candidates : List Probe} + {state : LazyRevealProbe.State Coordinate} {fuel : Nat} {cache : SplitHashCache} + (hselected : ordinal < candidates.length) + (haligned : candidates = observations.map CleanProbeObservation.toProbe) + (hstored : StoredLayerRoot state target leftRoot) + (htracked : CleanProbeObservationsTrackedBy observations state) + {pair : Option (ObservedCleanRunResult (α × SplitHashCache)) × + MaterializedSelectionOutcome} + (hpair : pair ∈ support + (finishObservedWithSelectionOutcome parameter publicRoot ftsSecret computation observations + state fuel table cache (.finished (some (candidates.get ⟨ordinal, hselected⟩))))) + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot pair.1) : + pair.2.Matches target leftRoot := by + unfold finishObservedWithSelectionOutcome at hpair + rw [mem_support_bind_iff] at hpair + obtain ⟨observed, hobserved, hreturn⟩ := hpair + simp only [support_pure, Set.mem_singleton_iff] at hreturn + subst pair + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hgood + | some result => + exact selected_finish_matches_of_successful_root hselected haligned hstored htracked + hobserved hgood + +theorem successful_root_not_of_unsafe_hash_prefix + {table : OtsSecretIndex → HashOutput} {ordinal : Nat} {target : Position} + {rightRoot leftRoot : Digest} + {parameter : PublicParameter} {publicRoot : Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {input : HashInput} {next : HashOutput → OracleComp (OracleWorld + SigningSpec) α} + {observations : List CleanProbeObservation} {candidates : List Probe} + {state : LazyRevealProbe.State Coordinate} {fuel : Nat} {cache : SplitHashCache} + {candidate : Probe} + (haligned : candidates = observations.map CleanProbeObservation.toProbe) + (hnextLength : (appendPlannedCandidate candidates (some candidate)).length ≤ ordinal) + (hhidden : Coordinate.position target ∉ state.revealed) + (hstored : StoredLayerRoot state target leftRoot) + (hcandidate : rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state) = some candidate) + (hunsafe : ¬RootAwareCandidateAvoidsRoots target leftRoot rightRoot (some candidate)) + {result : ObservedCleanRunResult (α × SplitHashCache)} + (hrun : some result ∈ support + (observedMaterializedBoundary parameter publicRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations state fuel table cache)) + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result)) : False := by + rw [observedMaterializedBoundary_hash_query_bind, mem_support_bind_iff] at hrun + obtain ⟨step?, hstep, hrest⟩ := hrun + cases step? with + | none => simp at hrest + | some step => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let observation := cleanProbeObservation state candidate.coordinate candidate.candidate + have hcandidateActual : rootAwareCandidateForPlan? parameter input plan = some candidate := by + simpa [plan, publicContext] using hcandidate + have hstepObservations : step.observations = observations ++ [observation] := by + have := observations_eq_of_mem_runObservedCleanFromTable_rootAwarePublic parameter input + publicContext.state plan observations state fuel table cache step hstep + simpa [observationsAfterCandidate, hcandidateActual, observation] using this + have htail : some result ∈ support + (observedMaterializedBoundary parameter publicRoot ftsSecret (next step.value.1) + step.observations step.state step.remaining table step.value.2) := by + simpa only [observedMaterializedBoundary] using hrest + have hprefix := observations_prefix_of_mem_observedMaterializedBoundary parameter publicRoot + ftsSecret (next step.value.1) step.observations step.state step.remaining table step.value.2 + result htail + have hbefore : observations.length < ordinal := by + have hcandidatesLength : candidates.length = observations.length := by + simp [haligned] + simpa [appendPlannedCandidate, hcandidatesLength] using hnextLength + have hstepIndex : observations.length < step.observations.length := by + simp [hstepObservations] + have hresultIndex : observations.length < result.observations.length := + lt_of_lt_of_le hstepIndex hprefix.length_le + have hget := hprefix.getElem hstepIndex + have hobservationEq : + result.observations.get ⟨observations.length, hresultIndex⟩ = observation := by + have hstepGet : step.observations[observations.length] = observation := by + simp [hstepObservations, observation] + have hget' := hget.symm + change result.observations[observations.length] = step.observations[observations.length] + at hget' + exact hget'.trans hstepGet + obtain ⟨⟨⟨⟨_finalResult, _hfinish⟩, + _selected, _hselected, hfirst, _hroot⟩, + _hposition⟩, hcomparison⟩ := hgood + obtain ⟨_firstSelected, _hfirstSelected, _hfirstHit, hnoEarlier⟩ := hfirst + simp only [RootAwareCandidateAvoidsRoots, not_and_or] at hunsafe + rcases hunsafe with hleft | hright + · apply hnoEarlier ⟨observations.length, hresultIndex⟩ hbefore + change (result.observations.get + ⟨observations.length, hresultIndex⟩).ExistingHiddenHit + rw [hobservationEq] + obtain ⟨output, hvalue, hdigest⟩ := hstored + have hcand : candidate = ⟨.position target, leftRoot⟩ := by + exact Option.some.inj (not_ne_iff.mp hleft) + subst candidate + refine ⟨by simp [observation, cleanProbeObservation, hhidden], output, ?_, ?_⟩ + · simpa [observation, cleanProbeObservation] using hvalue + · simpa [observation, cleanProbeObservation] using hdigest + · apply hcomparison observation.toProbe + · unfold observedPrefixProbes + apply List.mem_map.mpr + refine ⟨observation, ?_, rfl⟩ + apply List.mem_take_iff_getElem.mpr + refine ⟨observations.length, by omega, ?_⟩ + change result.observations[observations.length] = observation at hobservationEq + exact hobservationEq + · have hcand : candidate = ⟨.position target, rightRoot⟩ := + Option.some.inj (not_ne_iff.mp hright) + subst candidate + simp [observation, CleanProbeObservation.toProbe, cleanProbeObservation] + +theorem selected_hash_finish_pair_matches_of_successful_root + {table : OtsSecretIndex → HashOutput} {ordinal : Nat} {target : Position} + {rightRoot leftRoot : Digest} + {parameter : PublicParameter} {publicRoot : Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {input : HashInput} {next : HashOutput → OracleComp (OracleWorld + SigningSpec) α} + {observations : List CleanProbeObservation} {candidates : List Probe} + {state : LazyRevealProbe.State Coordinate} {fuel : Nat} {cache : SplitHashCache} + (hnotSelected : ¬ordinal < candidates.length) + (haligned : candidates = observations.map CleanProbeObservation.toProbe) + (hstored : StoredLayerRoot state target leftRoot) + (htracked : CleanProbeObservationsTrackedBy observations state) + (hnextSelected : ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length) + {pair : Option (ObservedCleanRunResult (α × SplitHashCache)) × + MaterializedSelectionOutcome} + (hpair : pair ∈ support + (finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations state fuel table cache + (.finished (some + ((appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).get + ⟨ordinal, hnextSelected⟩))))) + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot pair.1) : + pair.2.Matches target leftRoot := by + unfold finishObservedWithSelectionOutcome at hpair + rw [mem_support_bind_iff] at hpair + obtain ⟨observed, hobserved, hreturn⟩ := hpair + simp only [support_pure, Set.mem_singleton_iff] at hreturn + subst pair + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hgood + | some result => + have hobserved' := hobserved + have hgood' := hgood + let plan := purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state + let candidate? := rootAwareCandidateForPlan? parameter input plan + cases hcandidate : candidate? with + | none => + have hlength : (appendPlannedCandidate candidates candidate?).length = + candidates.length := by simp [appendPlannedCandidate, hcandidate] + exact (hnotSelected (by simpa [plan, candidate?, hlength] using hnextSelected)).elim + | some candidate => + have hcandidatesLength : candidates.length = observations.length := by simp [haligned] + have hordinal : ordinal = observations.length := by + have hnextLength : ordinal < candidates.length + 1 := by + simpa [plan, candidate?, hcandidate, appendPlannedCandidate] using hnextSelected + have holdLength : candidates.length ≤ ordinal := Nat.le_of_not_gt hnotSelected + omega + have hselectedCandidate : + (appendPlannedCandidate candidates candidate?).get + ⟨ordinal, by simpa [plan, candidate?] using hnextSelected⟩ = candidate := by + subst ordinal + subst candidates + simp [appendPlannedCandidate, candidate?, hcandidate] + rw [observedMaterializedBoundary_hash_query_bind, mem_support_bind_iff] at hobserved + obtain ⟨step?, hstep, hrest⟩ := hobserved + cases step? with + | none => simp at hrest + | some step => + let publicContext := materializedCanonicalContext table state + have hplan : plan = purePlanProbingHashQuery parameter input publicContext.state := rfl + let observation := cleanProbeObservation state candidate.coordinate candidate.candidate + have hcandidateActual : rootAwareCandidateForPlan? parameter input plan = + some candidate := hcandidate + have hstepObservations : step.observations = observations ++ [observation] := by + have := observations_eq_of_mem_runObservedCleanFromTable_rootAwarePublic parameter + input publicContext.state plan observations state fuel table cache step hstep + simpa [observationsAfterCandidate, hcandidateActual, observation] using this + have htail : some result ∈ support + (observedMaterializedBoundary parameter publicRoot ftsSecret (next step.value.1) + step.observations step.state step.remaining table step.value.2) := by + simpa only [observedMaterializedBoundary] using hrest + have hprefix := observations_prefix_of_mem_observedMaterializedBoundary parameter + publicRoot ftsSecret (next step.value.1) step.observations step.state step.remaining + table step.value.2 result htail + have hstepIndex : observations.length < step.observations.length := by + simp [hstepObservations] + have hresultIndex : observations.length < result.observations.length := + lt_of_lt_of_le hstepIndex hprefix.length_le + have hget := hprefix.getElem hstepIndex + have hobservationEq : + result.observations.get ⟨observations.length, hresultIndex⟩ = observation := by + have hstepGet : step.observations[observations.length] = observation := by + simp [hstepObservations, observation] + have hget' := hget.symm + change result.observations[observations.length] = + step.observations[observations.length] at hget' + exact hget'.trans hstepGet + obtain ⟨⟨⟨⟨_finalResult, _hfinish⟩, + selected, hselectedOrdinal, _hfirst, _hroot⟩, + _hposition⟩, _hcomparison⟩ := hgood + have hselectedEq : selected = ⟨observations.length, hresultIndex⟩ := by + exact Fin.ext (hselectedOrdinal.trans hordinal) + have hcandidateFinal : candidate = + (result.observations.get selected).toProbe := by + rw [hselectedEq, hobservationEq] + simp [observation, CleanProbeObservation.toProbe, cleanProbeObservation] + have hstoredFinal : StoredLayerRoot result.state target leftRoot := + storedLayerRoot_mono hstored + (valuesLE_of_mem_observedMaterializedBoundary parameter publicRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations state fuel table cache result hobserved') + have htrackedFinal := + cleanProbeObservationsTrackedBy_of_mem_observedMaterializedBoundary parameter + publicRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) + observations state fuel table cache htracked result hobserved' + have houtcomeCandidate : + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).get + ⟨ordinal, hnextSelected⟩ = candidate := by + simpa [plan, candidate?] using hselectedCandidate + rw [houtcomeCandidate] + exact finished_probe_matches_of_successful_root hgood' hselectedOrdinal + hcandidateFinal hstoredFinal htrackedFinal + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 4000000 in +theorem successful_root_forces_match_of_mem_observedRootSelectionSharedPrefix + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) (candidates : List Probe) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (haligned : candidates = observations.map CleanProbeObservation.toProbe) + (hstored : StoredLayerRoot state target leftRoot) + (htargetHidden : Coordinate.position target ∉ state.revealed) + (htracked : CleanProbeObservationsTrackedBy observations state) + (hcovered : CleanProbeObservationsCoverPending observations state) + (hstarts : StartTableAgrees state table) + (hbudget : fuel + state.pending.card < Fintype.card Digest) + (pair : Option (ObservedCleanRunResult (α × SplitHashCache)) × + MaterializedSelectionOutcome) + (hpair : pair ∈ support + (observedRootSelectionSharedPrefix ordinal parameter publicRoot target leftRoot rightRoot + ftsSecret computation observations candidates state fuel table cache)) + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot pair.1) : + pair.2.Matches target leftRoot := by + induction computation using OracleComp.inductionOn generalizing + observations candidates state fuel cache pair with + | pure value => + rw [observedRootSelectionSharedPrefix, OracleComp.construct_pure] at hpair + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte, support_pure, Set.mem_singleton_iff] at hpair + subst pair + exact selected_finish_matches_of_successful_root hselected haligned hstored htracked + (show some + (⟨state, fuel, (value, cache), table, observations⟩ : + ObservedCleanRunResult (α × SplitHashCache)) ∈ support + (observedMaterializedBoundary parameter publicRoot ftsSecret (pure value) + observations state fuel table cache) by + rw [observedMaterializedBoundary, OracleComp.construct_pure] + simp) hgood + · simp only [hselected, ↓reduceDIte, support_pure, Set.mem_singleton_iff] at hpair + subst pair + obtain ⟨⟨⟨⟨_finalResult, _hfinish⟩, + selected, hselectedOrdinal, _hfirst, _hroot⟩, + _hposition⟩, _hcomparison⟩ := hgood + have hobservationLength : ordinal < observations.length := by + rw [← hselectedOrdinal] + exact selected.isLt + have hcandidatesLength : candidates.length = observations.length := by + simp [haligned] + exact (hselected (by omega)).elim + | query_bind query next ih => + rw [observedRootSelectionSharedPrefix_query_bind] at hpair + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] at hpair + exact selected_finish_pair_matches_of_successful_root hselected haligned hstored htracked + hpair hgood + · simp only [hselected, ↓reduceDIte] at hpair + have hlength : observations.length ≤ ordinal := by + have hcandidatesLength : candidates.length = observations.length := by simp [haligned] + omega + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hpair + obtain ⟨detailed, hdetailed, hcontinue⟩ := hpair + cases detailed with + | stopped reason => + simp [continueObservedRootSelectionSharedPrefix] at hcontinue + subst pair + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hgood + | done step => + unfold continueObservedRootSelectionSharedPrefix at hcontinue + by_cases hcompletable : + DeferredCompletable table (directDeferredContext step.context.state) + · simp only [hcompletable, ↓reduceIte] at hcontinue + by_cases hrevealed : Coordinate.position target ∈ step.context.state.revealed + · simp only [hrevealed, ↓reduceIte] at hcontinue + unfold finishObservedWithSelectionOutcome at hcontinue + rw [mem_support_bind_iff] at hcontinue + obtain ⟨observed, hobserved, hreturn⟩ := hcontinue + simp only [support_pure, Set.mem_singleton_iff] at hreturn + subst pair + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + at hgood + | some result => + exact (successful_root_not_of_revealed_prefix hlength hrevealed + hobserved hgood).elim + · simp only [hrevealed, ↓reduceIte] at hcontinue + let observedStep : ObservedCleanRunResult (Fin (n + 1) × SplitHashCache) := + ⟨step.context.state, step.remaining, step.value, step.table, observations⟩ + have hobservedStep : some observedStep ∈ support + (runObservedCleanFromTable observations state fuel table + ((splitUniformImpl n).run cache)) := by + have hmapped : some observedStep ∈ support + (observedResultOfDetailed observations <$> + runDirectResolvedDetailedFromTable (directDeferredContext state) + fuel table ((splitUniformImpl n).run cache)) := by + rw [support_map] + exact ⟨.done step, hdetailed, rfl⟩ + rw [map_observedResultOfDetailed_run_eq_observed_of_probeFree + ((splitUniformImpl n).run cache) observations state fuel table + (splitUniformImpl_probeFree n cache)] at hmapped + exact hmapped + have hnextTracked := + cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run cache) observations state fuel table htracked + observedStep hobservedStep + have hnextCovered := + cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run cache) observations state fuel table hcovered + observedStep hobservedStep + have hnextStarts := startTableAgrees_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run cache) observations state fuel table hstarts + observedStep hobservedStep + have hnextStored : StoredLayerRoot step.context.state target leftRoot := + storedLayerRoot_mono hstored + (valuesLE_of_done_runDirectResolvedDetailedFromTable + ((splitUniformImpl n).run cache) (directDeferredContext state) fuel + table step hdetailed) + have hnextBudget : step.remaining + step.context.state.pending.card < + Fintype.card Digest := by + have hstepBound := remaining_add_pending_card_le_of_done_runDirectResolvedDetailedFromTable + ((splitUniformImpl n).run cache) (directDeferredContext state) fuel table + step hdetailed + simp only [directDeferredContext] at hstepBound + omega + exact ih step.value.1 observations candidates step.context.state + step.remaining step.value.2 haligned hnextStored hrevealed hnextTracked + hnextCovered hnextStarts.2 hnextBudget pair hcontinue hgood + · simp only [hcompletable, ↓reduceIte] at hcontinue + unfold finishObservedWithSelectionOutcome at hcontinue + rw [mem_support_bind_iff] at hcontinue + obtain ⟨observed, hobserved, hreturn⟩ := hcontinue + simp only [support_pure, Set.mem_singleton_iff] at hreturn + subst pair + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + at hgood + | some result => + let observedStep : ObservedCleanRunResult (Fin (n + 1) × SplitHashCache) := + ⟨step.context.state, step.remaining, step.value, step.table, observations⟩ + have hobservedStep : some observedStep ∈ support + (runObservedCleanFromTable observations state fuel table + ((splitUniformImpl n).run cache)) := by + have hmapped : some observedStep ∈ support + (observedResultOfDetailed observations <$> + runDirectResolvedDetailedFromTable (directDeferredContext state) + fuel table ((splitUniformImpl n).run cache)) := by + rw [support_map] + exact ⟨.done step, hdetailed, rfl⟩ + rw [map_observedResultOfDetailed_run_eq_observed_of_probeFree + ((splitUniformImpl n).run cache) observations state fuel table + (splitUniformImpl_probeFree n cache)] at hmapped + exact hmapped + have hnextTracked := + cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run cache) observations state fuel table htracked + observedStep hobservedStep + have hnextCovered := + cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run cache) observations state fuel table hcovered + observedStep hobservedStep + have hnextStarts := startTableAgrees_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run cache) observations state fuel table hstarts + observedStep hobservedStep + have hnextBudget : step.remaining + step.context.state.pending.card < + Fintype.card Digest := by + have hstepBound := remaining_add_pending_card_le_of_done_runDirectResolvedDetailedFromTable + ((splitUniformImpl n).run cache) (directDeferredContext state) fuel + table step hdetailed + simp only [directDeferredContext] at hstepBound + omega + exact (successful_root_not_of_noncompletable_prefix hlength hnextTracked + hnextCovered hnextStarts.2 hnextBudget hcompletable hobserved hgood).elim + | inr input => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + let nextObservations := observationsAfterCandidate observations state candidate? + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [nextCandidates, candidate?, plan, publicContext] using hnextSelected + simp only [hactual, ↓reduceDIte] at hpair + exact selected_hash_finish_pair_matches_of_successful_root hselected haligned + hstored htracked hactual hpair hgood + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [nextCandidates, candidate?, plan, publicContext] using hnextSelected + simp only [hactual, ↓reduceDIte] at hpair + by_cases hsafe : RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? + · have hactualSafe : RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [candidate?, plan, publicContext] using hsafe + simp only [hactualSafe, ↓reduceIte, mem_support_bind_iff] at hpair + obtain ⟨detailed, hdetailed, hcontinue⟩ := hpair + cases detailed with + | stopped reason => + simp [continueObservedRootSelectionSharedPrefix] at hcontinue + subst pair + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + at hgood + | done step => + unfold continueObservedRootSelectionSharedPrefix at hcontinue + by_cases hcompletable : + DeferredCompletable table (directDeferredContext step.context.state) + · simp only [hcompletable, ↓reduceIte] at hcontinue + by_cases hrevealed : + Coordinate.position target ∈ step.context.state.revealed + · simp only [hrevealed, ↓reduceIte] at hcontinue + unfold finishObservedWithSelectionOutcome at hcontinue + rw [mem_support_bind_iff] at hcontinue + obtain ⟨observed, hobserved, hreturn⟩ := hcontinue + simp only [support_pure, Set.mem_singleton_iff] at hreturn + subst pair + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + at hgood + | some result => + have hnextLength : nextObservations.length ≤ ordinal := by + cases hcandidate : candidate? with + | none => + simpa [nextObservations, nextCandidates, observationsAfterCandidate, + appendPlannedCandidate, hcandidate, haligned] using + Nat.le_of_not_gt hnextSelected + | some candidate => + simpa [nextObservations, nextCandidates, observationsAfterCandidate, + appendPlannedCandidate, hcandidate, haligned] using + Nat.le_of_not_gt hnextSelected + exact (successful_root_not_of_revealed_prefix hnextLength hrevealed + hobserved hgood).elim + · simp only [hrevealed, ↓reduceIte] at hcontinue + let observedStep : ObservedCleanRunResult (HashOutput × SplitHashCache) := + ⟨step.context.state, step.remaining, step.value, step.table, + nextObservations⟩ + have hobservedStep : some observedStep ∈ support + (runObservedCleanFromTable observations state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input + publicContext.state plan).run cache)) := by + have hmapped : some observedStep ∈ support + (projectDirectDetailedObserved nextObservations <$> + runDirectResolvedDetailedFromTable (directDeferredContext state) + fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input + publicContext.state plan).run cache)) := by + rw [support_map] + exact ⟨.done step, hdetailed, rfl⟩ + rw [map_projectDirectDetailedObserved_rootAwarePublic parameter input + publicContext.state plan observations state fuel table cache] + at hmapped + exact hmapped + have hnextAligned : nextCandidates = + nextObservations.map CleanProbeObservation.toProbe := by + cases hcandidate : candidate? with + | none => + simp [nextCandidates, nextObservations, appendPlannedCandidate, + observationsAfterCandidate, hcandidate, haligned] + | some candidate => + simp [nextCandidates, nextObservations, appendPlannedCandidate, + observationsAfterCandidate, hcandidate, haligned, + CleanProbeObservation.toProbe, cleanProbeObservation] + have hnextTracked := + cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input + publicContext.state plan).run cache) + observations state fuel table htracked observedStep hobservedStep + have hnextCovered := + cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input + publicContext.state plan).run cache) + observations state fuel table hcovered observedStep hobservedStep + have hnextStarts := startTableAgrees_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input + publicContext.state plan).run cache) + observations state fuel table hstarts observedStep hobservedStep + have hnextStored : StoredLayerRoot step.context.state target leftRoot := + storedLayerRoot_mono hstored + (valuesLE_of_done_runDirectResolvedDetailedFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input + publicContext.state plan).run cache) + (directDeferredContext state) fuel table step hdetailed) + have hnextBudget : step.remaining + step.context.state.pending.card < + Fintype.card Digest := by + have hstepBound := + remaining_add_pending_card_le_of_done_runDirectResolvedDetailedFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input + publicContext.state plan).run cache) + (directDeferredContext state) fuel table step hdetailed + simp only [directDeferredContext] at hstepBound + omega + exact ih step.value.1 nextObservations nextCandidates step.context.state + step.remaining step.value.2 hnextAligned hnextStored hrevealed + hnextTracked hnextCovered hnextStarts.2 hnextBudget pair hcontinue hgood + · simp only [hcompletable, ↓reduceIte] at hcontinue + unfold finishObservedWithSelectionOutcome at hcontinue + rw [mem_support_bind_iff] at hcontinue + obtain ⟨observed, hobserved, hreturn⟩ := hcontinue + simp only [support_pure, Set.mem_singleton_iff] at hreturn + subst pair + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + at hgood + | some result => + let observedStep : ObservedCleanRunResult (HashOutput × SplitHashCache) := + ⟨step.context.state, step.remaining, step.value, step.table, + nextObservations⟩ + have hobservedStep : some observedStep ∈ support + (runObservedCleanFromTable observations state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input + publicContext.state plan).run cache)) := by + have hmapped : some observedStep ∈ support + (projectDirectDetailedObserved nextObservations <$> + runDirectResolvedDetailedFromTable + (directDeferredContext state) fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input + publicContext.state plan).run cache)) := by + rw [support_map] + exact ⟨.done step, hdetailed, rfl⟩ + rw [map_projectDirectDetailedObserved_rootAwarePublic parameter input + publicContext.state plan observations state fuel table cache] + at hmapped + exact hmapped + have hnextTracked := + cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input + publicContext.state plan).run cache) + observations state fuel table htracked observedStep hobservedStep + have hnextCovered := + cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input + publicContext.state plan).run cache) + observations state fuel table hcovered observedStep hobservedStep + have hnextStarts := startTableAgrees_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input + publicContext.state plan).run cache) + observations state fuel table hstarts observedStep hobservedStep + have hnextLength : nextObservations.length ≤ ordinal := by + cases hcandidate : candidate? with + | none => + simpa [nextObservations, nextCandidates, + observationsAfterCandidate, appendPlannedCandidate, + hcandidate, haligned] using Nat.le_of_not_gt hnextSelected + | some candidate => + simpa [nextObservations, nextCandidates, + observationsAfterCandidate, appendPlannedCandidate, + hcandidate, haligned] using Nat.le_of_not_gt hnextSelected + have hnextBudget : step.remaining + step.context.state.pending.card < + Fintype.card Digest := by + have hstepBound := + remaining_add_pending_card_le_of_done_runDirectResolvedDetailedFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input + publicContext.state plan).run cache) + (directDeferredContext state) fuel table step hdetailed + simp only [directDeferredContext] at hstepBound + omega + exact (successful_root_not_of_noncompletable_prefix hnextLength + hnextTracked hnextCovered hnextStarts.2 hnextBudget hcompletable + hobserved hgood).elim + · have hactualSafe : ¬RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [candidate?, plan, publicContext] using hsafe + simp only [hactualSafe, ↓reduceIte] at hpair + unfold finishObservedWithSelectionOutcome at hpair + rw [mem_support_bind_iff] at hpair + obtain ⟨observed, hobserved, hreturn⟩ := hpair + simp only [support_pure, Set.mem_singleton_iff] at hreturn + subst pair + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + at hgood + | some result => + cases hcandidate : candidate? with + | none => + simp [RootAwareCandidateAvoidsRoots, hcandidate] at hsafe + | some candidate => + have hcandActual : rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state) = + some candidate := by + simpa [candidate?, plan, publicContext] using hcandidate + have hnextLength : + (appendPlannedCandidate candidates (some candidate)).length ≤ + ordinal := by + simpa [nextCandidates, candidate?, hcandidate] using + Nat.le_of_not_gt hnextSelected + exact (successful_root_not_of_unsafe_hash_prefix haligned hnextLength + htargetHidden hstored hcandActual (by + simpa [candidate?, hcandidate] using hsafe) hobserved hgood).elim + | inr message => + rw [mem_support_bind_iff] at hpair + obtain ⟨detailed, hdetailed, hcontinue⟩ := hpair + cases detailed with + | stopped reason => + simp [continueObservedRootSelectionSharedPrefix] at hcontinue + subst pair + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hgood + | done step => + unfold continueObservedRootSelectionSharedPrefix at hcontinue + by_cases hcompletable : + DeferredCompletable table (directDeferredContext step.context.state) + · simp only [hcompletable, ↓reduceIte] at hcontinue + by_cases hrevealed : Coordinate.position target ∈ step.context.state.revealed + · simp only [hrevealed, ↓reduceIte] at hcontinue + unfold finishObservedWithSelectionOutcome at hcontinue + rw [mem_support_bind_iff] at hcontinue + obtain ⟨observed, hobserved, hreturn⟩ := hcontinue + simp only [support_pure, Set.mem_singleton_iff] at hreturn + subst pair + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + at hgood + | some result => + exact (successful_root_not_of_revealed_prefix hlength hrevealed hobserved + hgood).elim + · simp only [hrevealed, ↓reduceIte] at hcontinue + let observedStep : + ObservedCleanRunResult (Option Signature × SplitHashCache) := + ⟨step.context.state, step.remaining, step.value, step.table, observations⟩ + have hobservedStep : some observedStep ∈ support + (runObservedCleanFromTable observations state fuel table + ((maskedSign parameter publicRoot ftsSecret message).run cache)) := by + have hmapped : some observedStep ∈ support + (observedResultOfDetailed observations <$> + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel + table ((maskedSign parameter publicRoot ftsSecret message).run + cache)) := by + rw [support_map] + exact ⟨.done step, hdetailed, rfl⟩ + rw [map_observedResultOfDetailed_run_eq_observed_of_probeFree + ((maskedSign parameter publicRoot ftsSecret message).run cache) + observations state fuel table + (maskedSign_probeFree parameter publicRoot ftsSecret message cache)] + at hmapped + exact hmapped + have hnextTracked := + cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((maskedSign parameter publicRoot ftsSecret message).run cache) + observations state fuel table htracked observedStep hobservedStep + have hnextCovered := + cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((maskedSign parameter publicRoot ftsSecret message).run cache) + observations state fuel table hcovered observedStep hobservedStep + have hnextStarts := startTableAgrees_of_mem_runObservedCleanFromTable + ((maskedSign parameter publicRoot ftsSecret message).run cache) + observations state fuel table hstarts observedStep hobservedStep + have hnextStored : StoredLayerRoot step.context.state target leftRoot := + storedLayerRoot_mono hstored + (valuesLE_of_done_runDirectResolvedDetailedFromTable + ((maskedSign parameter publicRoot ftsSecret message).run cache) + (directDeferredContext state) fuel table step hdetailed) + have hnextBudget : step.remaining + step.context.state.pending.card < + Fintype.card Digest := by + have hstepBound := + remaining_add_pending_card_le_of_done_runDirectResolvedDetailedFromTable + ((maskedSign parameter publicRoot ftsSecret message).run cache) + (directDeferredContext state) fuel table step hdetailed + simp only [directDeferredContext] at hstepBound + omega + exact ih step.value.1 observations candidates step.context.state + step.remaining step.value.2 haligned hnextStored hrevealed hnextTracked + hnextCovered hnextStarts.2 hnextBudget pair hcontinue hgood + · simp only [hcompletable, ↓reduceIte] at hcontinue + unfold finishObservedWithSelectionOutcome at hcontinue + rw [mem_support_bind_iff] at hcontinue + obtain ⟨observed, hobserved, hreturn⟩ := hcontinue + simp only [support_pure, Set.mem_singleton_iff] at hreturn + subst pair + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + at hgood + | some result => + let observedStep : + ObservedCleanRunResult (Option Signature × SplitHashCache) := + ⟨step.context.state, step.remaining, step.value, step.table, observations⟩ + have hobservedStep : some observedStep ∈ support + (runObservedCleanFromTable observations state fuel table + ((maskedSign parameter publicRoot ftsSecret message).run cache)) := by + have hmapped : some observedStep ∈ support + (observedResultOfDetailed observations <$> + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel + table ((maskedSign parameter publicRoot ftsSecret message).run + cache)) := by + rw [support_map] + exact ⟨.done step, hdetailed, rfl⟩ + rw [map_observedResultOfDetailed_run_eq_observed_of_probeFree + ((maskedSign parameter publicRoot ftsSecret message).run cache) + observations state fuel table + (maskedSign_probeFree parameter publicRoot ftsSecret message cache)] + at hmapped + exact hmapped + have hnextTracked := + cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((maskedSign parameter publicRoot ftsSecret message).run cache) + observations state fuel table htracked observedStep hobservedStep + have hnextCovered := + cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((maskedSign parameter publicRoot ftsSecret message).run cache) + observations state fuel table hcovered observedStep hobservedStep + have hnextStarts := startTableAgrees_of_mem_runObservedCleanFromTable + ((maskedSign parameter publicRoot ftsSecret message).run cache) + observations state fuel table hstarts observedStep hobservedStep + have hnextBudget : step.remaining + step.context.state.pending.card < + Fintype.card Digest := by + have hstepBound := + remaining_add_pending_card_le_of_done_runDirectResolvedDetailedFromTable + ((maskedSign parameter publicRoot ftsSecret message).run cache) + (directDeferredContext state) fuel table step hdetailed + simp only [directDeferredContext] at hstepBound + omega + exact (successful_root_not_of_noncompletable_prefix hlength hnextTracked + hnextCovered hnextStarts.2 hnextBudget hcompletable hobserved hgood).elim + +theorem successful_root_forces_match_after_installed_root + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) + (high : RootOutputHigh) (leftRoot rightRoot : Digest) + (habsent : rootResult.state.values (.position target) = none ∧ + Coordinate.position target ∉ rootResult.state.revealed) + (hpending : rootResult.state.pending = ∅) + (hstarts : StartTableAgrees rootResult.state rootResult.table) + (hbudget : rootResult.remaining < Fintype.card Digest) + (pair : Option (ObservedCleanRunResult (RetainedRestResult × SplitHashCache)) × + MaterializedSelectionOutcome) + (hpair : pair ∈ support + (observedRootSelectionSharedPrefix ordinal parameter rootResult.value.1 target leftRoot + rightRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + (materializedDeferredState + { directDeferredContext rootResult.state with + values := (directDeferredContext rootResult.state).values.install target + (rootOutputOfParts leftRoot high) }) + rootResult.remaining rootResult.table + (rootInstalledCache target (fun root => rootOutputOfParts root high) + rootResult.value.2 leftRoot))) + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + rootResult.table ordinal target rightRoot + (retainObservedRoot rootResult.value.1 pair.1)) : + pair.2.Matches target leftRoot := by + let context : DeferredContext := directDeferredContext rootResult.state + let rootContext := + { context with values := context.values.install target (rootOutputOfParts leftRoot high) } + let initialState := materializedDeferredState rootContext + have hstored : StoredLayerRoot initialState target leftRoot := by + refine ⟨rootOutputOfParts leftRoot high, ?_, truncateHash_rootOutputOfParts leftRoot high⟩ + simp only [initialState, materializedDeferredState_position] + unfold DeferredContext.positionValue + rw [show rootContext.state.values (.position target) = none by + simpa [rootContext, context, directDeferredContext] using habsent.1] + simp [rootContext, context, directDeferredContext, DeferredStructuralValues.install] + have hhidden : Coordinate.position target ∉ initialState.revealed := by + change Coordinate.position target ∉ rootResult.state.revealed + exact habsent.2 + have htracked : CleanProbeObservationsTrackedBy [] initialState := by + simp [CleanProbeObservationsTrackedBy] + have hcovered : CleanProbeObservationsCoverPending [] initialState := by + intro entry hentry + have : entry ∈ rootResult.state.pending := by + simpa [initialState, rootContext, context, directDeferredContext] using hentry + rw [hpending] at this + simp at this + have hstartsInitial : StartTableAgrees initialState rootResult.table := by + intro index output hvalue + apply hstarts index output + simpa [initialState, rootContext, context, directDeferredContext, + OtsSecretIndex.coordinate] using hvalue + have hbudgetInitial : rootResult.remaining + initialState.pending.card < + Fintype.card Digest := by + simpa [initialState, rootContext, context, directDeferredContext, hpending] using hbudget + have hgoodPair : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + rootResult.table ordinal target rightRoot pair.1 := by + cases hpairFirst : pair.1 with + | none => + rw [hpairFirst] at hgood + simp [retainObservedRoot, + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hgood + | some result => + rw [hpairFirst] at hgood + simp only [retainObservedRoot] at hgood + rcases hgood with ⟨⟨⟨hfinish, hfirst⟩, hposition⟩, havoid⟩ + refine ⟨⟨⟨?_, ?_⟩, ?_⟩, ?_⟩ + · obtain ⟨finalResult, hfinalResult⟩ := hfinish + unfold finishObservedCleanRunFromTable at hfinalResult + rw [mem_support_bind_iff] at hfinalResult + obtain ⟨finalized, hfinalized, hreturn⟩ := hfinalResult + cases finalized with + | none => simp at hreturn + | some finalized => + obtain ⟨finalState, finalTable⟩ := finalized + refine ⟨⟨finalState, result.remaining, result.value, finalTable, + result.observations⟩, ?_⟩ + unfold finishObservedCleanRunFromTable + rw [mem_support_bind_iff] + exact ⟨some (finalState, finalTable), hfinalized, by simp⟩ + · simpa [ObservedCleanRunOption.FirstExistingHiddenRootHitAt, FirstExistingHiddenHitAt, + ExistingHiddenHitAtOrdinal] using hfirst + · simpa [observedFirstLayerRootPosition?] using hposition + · simpa [observedPrefixProbes] using havoid + exact successful_root_forces_match_of_mem_observedRootSelectionSharedPrefix ordinal parameter + rootResult.value.1 target leftRoot rightRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] initialState + rootResult.remaining rootResult.table + (rootInstalledCache target (fun root => rootOutputOfParts root high) rootResult.value.2 leftRoot) + rfl hstored hhidden htracked hcovered hstartsInitial hbudgetInitial pair (by + simpa [initialState, rootContext, context] using hpair) hgoodPair + +theorem map_observed_sampledHighObservedRootAwareSharedAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + (fun result => (result.1, result.2.1, result.2.2.1)) <$> + sampledHighObservedRootAwareSharedAfterRootResult ordinal adversary parameter + ftsSecret target rootResult = + sampledHighEagerObservedRootAwareAfterRootResult ordinal adversary parameter + ftsSecret target rootResult := by + unfold sampledHighObservedRootAwareSharedAfterRootResult + sampledHighEagerObservedRootAwareAfterRootResult + simp only [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro high + apply bind_congr + intro leftRoot + apply bind_congr + intro rightRoot + let state := materializedDeferredState + { directDeferredContext rootResult.state with + values := (directDeferredContext rootResult.state).values.install target + (rootOutputOfParts leftRoot high) } + let cache := rootInstalledCache target (fun root => rootOutputOfParts root high) + rootResult.value.2 leftRoot + simp only [pure_bind, Function.comp_apply] + calc + _ = (fun observed => (leftRoot, rightRoot, + retainObservedRoot rootResult.value.1 observed)) <$> + (Prod.fst <$> observedRootSelectionSharedPrefix ordinal parameter rootResult.value.1 + target leftRoot rightRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + state rootResult.remaining rootResult.table cache) := by + rw [map_eq_bind_pure_comp, map_eq_bind_pure_comp, bind_assoc] + rfl + _ = _ := by + rw [map_fst_observedRootSelectionSharedPrefix] + rfl + +theorem evalDist_map_outcome_sampledHighObservedRootAwareSharedAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + evalDist ((fun result => (result.1, result.2.1, result.2.2.2)) <$> + sampledHighObservedRootAwareSharedAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) = + evalDist + (sampledHighMaterializedRootAwareOutcomeAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) := by + unfold sampledHighObservedRootAwareSharedAfterRootResult + sampledHighMaterializedRootAwareOutcomeAfterRootResult + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro high _hhigh + apply evalDist_bind_congr + intro leftRoot _hleftRoot + apply evalDist_bind_congr + intro rightRoot _hrightRoot + let state := materializedDeferredState + { directDeferredContext rootResult.state with + values := (directDeferredContext rootResult.state).values.install target + (rootOutputOfParts leftRoot high) } + let cache := rootInstalledCache target (fun root => rootOutputOfParts root high) + rootResult.value.2 leftRoot + calc + _ = evalDist ((fun outcome => (leftRoot, rightRoot, outcome)) <$> + (Prod.snd <$> observedRootSelectionSharedPrefix ordinal parameter rootResult.value.1 + target leftRoot rightRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + state rootResult.remaining rootResult.table cache)) := by + rw [map_eq_bind_pure_comp, map_eq_bind_pure_comp, bind_assoc] + rfl + _ = evalDist ((fun outcome => (leftRoot, rightRoot, outcome)) <$> + materializedActualRootAwareOrdinalSelectionOutcome ordinal parameter rootResult.value.1 + target leftRoot rightRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] state + rootResult.remaining rootResult.table cache) := by + have hmarginal := evalDist_map_snd_observedRootSelectionSharedPrefix ordinal parameter + rootResult.value.1 target leftRoot rightRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] state + rootResult.remaining rootResult.table cache + simpa only [evalDist_map, Functor.map_map] using + congrArg (Functor.map fun outcome => (leftRoot, rightRoot, outcome)) hmarginal + _ = _ := rfl + +theorem relTriple_sampledHighEagerObservedRootComparison_materializedRootAwareOutcome + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) + (habsent : rootResult.state.values (.position target) = none ∧ + Coordinate.position target ∉ rootResult.state.revealed) + (hpending : rootResult.state.pending = ∅) + (hstarts : StartTableAgrees rootResult.state rootResult.table) + (hbudget : rootResult.remaining < Fintype.card Digest) : + RelTriple + ((fun result => (result.2.2, result.2.1)) <$> + sampledHighEagerObservedRootAwareAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) + (sampledHighMaterializedRootAwareOutcomeAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) + (SuccessfulObservedRootMaterializedMatchRel rootResult.table ordinal target) := by + let shared := sampledHighObservedRootAwareSharedAfterRootResult ordinal adversary parameter + ftsSecret target rootResult + have hbase := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + (relTriple_refl shared) (fun result => result ∈ support shared) + (fun result hresult => hresult) + have hsemantic : RelTriple shared shared + (fun left right => + SuccessfulObservedRootMaterializedMatchRel rootResult.table ordinal target + (left.2.2.1, left.2.1) (right.1, right.2.1, right.2.2.2)) := by + apply relTriple_post_mono hbase + intro left right hrelation + obtain ⟨heq, hleft⟩ := hrelation + subst right + intro hgood + unfold shared sampledHighObservedRootAwareSharedAfterRootResult at hleft + rw [mem_support_bind_iff] at hleft + obtain ⟨high, _hhigh, hleft⟩ := hleft + rw [mem_support_bind_iff] at hleft + obtain ⟨leftRoot, _hleftRoot, hleft⟩ := hleft + rw [mem_support_bind_iff] at hleft + obtain ⟨rightRoot, _hrightRoot, hleft⟩ := hleft + rw [mem_support_bind_iff] at hleft + obtain ⟨pair, hpair, hreturn⟩ := hleft + simp only [support_pure, Set.mem_singleton_iff] at hreturn + subst left + exact successful_root_forces_match_after_installed_root ordinal adversary parameter ftsSecret + target rootResult high leftRoot rightRoot habsent hpending hstarts hbudget pair hpair hgood + have hmapped := relTriple_map + (f := fun result : Digest × Digest × + Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × + MaterializedSelectionOutcome => (result.2.2.1, result.2.1)) + (g := fun result : Digest × Digest × + Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × + MaterializedSelectionOutcome => (result.1, result.2.1, result.2.2.2)) hsemantic + have hleft : evalDist + ((fun result => (result.2.2.1, result.2.1)) <$> shared) = + evalDist ((fun result => (result.2.2, result.2.1)) <$> + sampledHighEagerObservedRootAwareAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) := by + rw [← map_observed_sampledHighObservedRootAwareSharedAfterRootResult ordinal adversary + parameter ftsSecret target rootResult] + simp only [Functor.map_map] + rfl + apply relTriple_of_evalDist_eq_left hleft.symm + apply relTriple_of_evalDist_eq_right + (evalDist_map_outcome_sampledHighObservedRootAwareSharedAfterRootResult ordinal adversary + parameter ftsSecret target rootResult) + exact hmapped + +noncomputable def eagerObservedRootComparisonExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp + (Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest) := do + let rootResult ← runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure (none, 0) + | some result => + (fun sampled => (sampled.2.2, sampled.2.1)) <$> + sampledHighEagerObservedRootAwareAfterRootResult ordinal adversary parameter + ftsSecret target result + +def RootResultReadyForSharedSemantic + (target : Position) (table : OtsSecretIndex → HashOutput) : + Option (CleanRunResult (Digest × SplitHashCache)) → Prop + | none => True + | some result => + result.state.values (.position target) = none ∧ + Coordinate.position target ∉ result.state.revealed ∧ + result.state.pending = ∅ ∧ result.table = table ∧ + StartTableAgrees result.state table ∧ + result.remaining < Fintype.card Digest + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem rootResultReadyForSharedSemantic_of_mem + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hfuel : fuel < Fintype.card Digest) + (output : Option (CleanRunResult (Digest × SplitHashCache))) + (houtput : output ∈ support + (runCleanFromTable (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) : + RootResultReadyForSharedSemantic target table output := by + cases output with + | none => trivial + | some result => + have habsent : result.state.values (.position target) = none ∧ + Coordinate.position target ∉ result.state.revealed := + target_absent_of_mem_runCleanFromTable_maskedPublishedTreeRoot target hroot hparent fuel + table result houtput + have hpending : result.state.pending = ∅ := + pending_eq_empty_of_mem_runCleanFromTable_maskedPublishedTreeRoot fuel table result houtput + have htable : result.table = table ∧ StartTableAgrees result.state table := + startTableAgrees_of_mem_runCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (startTableAgrees_empty table) result houtput + have hobserved : some + (⟨result.state, result.remaining, result.value, result.table, []⟩ : + ObservedCleanRunResult (Digest × SplitHashCache)) ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + rw [← map_attachCleanProbeObservations_runCleanFromTable_of_probeFree + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty fuel + table (maskedPublishedTreeRoot_probeFree emptySplitHashCache), support_map] + exact ⟨some result, houtput, rfl⟩ + have hremaining : result.remaining ≤ fuel := + remaining_le_of_mem_runObservedCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty fuel + table ⟨result.state, result.remaining, result.value, result.table, []⟩ hobserved + exact ⟨habsent.1, habsent.2, hpending, htable.1, htable.2, + hremaining.trans_lt hfuel⟩ + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_eagerObservedRootComparison_materializedRootAwareOutcomeAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hfuel : fuel < Fintype.card Digest) : + RelTriple + (eagerObservedRootComparisonExperimentAfterTable ordinal adversary parameter ftsSecret + target fuel table) + (materializedRootAwareOrdinalOutcomeExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table) + (SuccessfulObservedRootMaterializedMatchRel table ordinal target) := by + let rootRun := runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + have hbase := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + (relTriple_refl rootRun) (RootResultReadyForSharedSemantic target table) + (rootResultReadyForSharedSemantic_of_mem target hroot hparent fuel table hfuel) + unfold eagerObservedRootComparisonExperimentAfterTable + materializedRootAwareOrdinalOutcomeExperimentAfterTable + apply relTriple_bind hbase + intro leftResult rightResult hrelation + obtain ⟨heq, hready⟩ := hrelation + subst rightResult + cases leftResult with + | none => + apply relTriple_pure_pure + intro hgood + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hgood + | some result => + obtain ⟨hvalue, hrevealed, hpending, htable, hstarts, hbudget⟩ := hready + have hstartsResult : StartTableAgrees result.state result.table := by + rw [htable] + exact hstarts + rw [← htable] + exact relTriple_sampledHighEagerObservedRootComparison_materializedRootAwareOutcome ordinal + adversary parameter ftsSecret target result ⟨hvalue, hrevealed⟩ hpending hstartsResult + hbudget + +theorem probEvent_eagerObservedRootComparison_le_production_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hfuel : fuel < Fintype.card Digest) : + Pr[fun result => + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | + eagerObservedRootComparisonExperimentAfterTable ordinal adversary parameter ftsSecret + target fuel table] ≤ + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ Pr[fun result => result.2.2.Matches target result.1 | + materializedRootAwareOrdinalOutcomeExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] := by + apply probEvent_le_of_relTriple + (relTriple_eagerObservedRootComparison_materializedRootAwareOutcomeAfterTable ordinal + adversary parameter ftsSecret target hroot hparent fuel table hfuel) + intro observed outcome hrelation hgood + exact hrelation hgood + _ ≤ _ := probEvent_materializedRootAwareOrdinalOutcome_match_le ordinal adversary parameter + ftsSecret target hroot hparent fuel table + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootComparison.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootComparison.lean new file mode 100644 index 00000000..c5159bc9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootComparison.lean @@ -0,0 +1,334 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRoot + +/-! +# Comparison-root exception for stopped layer roots + +The successful diagnostic prefix avoids the actual selected root. The independent comparison root +used by the exchangeable root experiment can still equal an earlier candidate. This file isolates +that exception and keeps its probability proportional to the production mass of the selected root +fiber. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +def snapshotPrefixCandidateDigests + (ordinal : Nat) (source : PrivateWitnessSnapshotOutput) : List Digest := + (source.2.take ordinal).map fun snapshot => snapshot.probe.candidate + +def SelectedPrivateSnapshotCleanRootComparisonExceptionAt + (table : OtsSecretIndex → HashOutput) + (source : PrivateWitnessSnapshotOutput) (ordinal : Nat) + (target : Position) (rightRoot : Digest) : Prop := + ∃ selected : Fin source.2.length, ∃ output, + selected.val = ordinal ∧ + selectedPrivateSnapshotOrdinal? ordinal source.2 = + some (privateOrdinalSelectionOfSnapshot selected) ∧ + (privateOrdinalSelectionOfSnapshot selected).GoodForActualRoot target output ordinal ∧ + IsLayerRoot target ∧ + SnapshotsAvoidExistingHiddenPositionHits table (source.2.take ordinal) ∧ + ¬CandidatesAvoidRoot target rightRoot + ((privateOrdinalSelectionOfSnapshot selected).candidates.take ordinal) + +def SelectedPrivateSnapshotCleanRootGoodForComparisonAt + (table : OtsSecretIndex → HashOutput) + (source : PrivateWitnessSnapshotOutput) (ordinal : Nat) + (target : Position) (rightRoot : Digest) : Prop := + ∃ selected : Fin source.2.length, ∃ output, + selected.val = ordinal ∧ + selectedPrivateSnapshotOrdinal? ordinal source.2 = + some (privateOrdinalSelectionOfSnapshot selected) ∧ + (privateOrdinalSelectionOfSnapshot selected).GoodForActualRoot target output ordinal ∧ + IsLayerRoot target ∧ + SnapshotsAvoidExistingHiddenPositionHits table (source.2.take ordinal) ∧ + CandidatesAvoidRoot target rightRoot + ((privateOrdinalSelectionOfSnapshot selected).candidates.take ordinal) + +theorem SelectedPrivateSnapshotCleanRootGoodForComparisonAt.goodForRoots + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} {ordinal : Nat} + {target : Position} {rightRoot : Digest} + (hgood : SelectedPrivateSnapshotCleanRootGoodForComparisonAt + table source ordinal target rightRoot) : + ∃ selected : Fin source.2.length, ∃ output, + selected.val = ordinal ∧ + selectedPrivateSnapshotOrdinal? ordinal source.2 = + some (privateOrdinalSelectionOfSnapshot selected) ∧ + (privateOrdinalSelectionOfSnapshot selected).GoodForRoots + target output rightRoot ordinal := by + obtain ⟨selected, output, hordinal, hselection, hactual, _hroot, _hclean, hright⟩ := hgood + exact ⟨selected, output, hordinal, hselection, hactual.goodForRoots hright⟩ + +theorem SelectedPrivateSnapshotCleanRootComparisonExceptionAt.cleanRootHit + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} {ordinal : Nat} + {target : Position} {rightRoot : Digest} + (hexception : SelectedPrivateSnapshotCleanRootComparisonExceptionAt + table source ordinal target rightRoot) : + SelectedPrivateSnapshotCleanRootHitAt table source ordinal := by + obtain ⟨selected, output, hordinal, hselection, hgood, hroot, hclean, _hcomparison⟩ := + hexception + exact ⟨selected, target, output, hordinal, hselection, hgood, hroot, hclean⟩ + +theorem SelectedPrivateSnapshotCleanRootComparisonExceptionAt.position + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} {ordinal : Nat} + {target : Position} {rightRoot : Digest} + (hexception : SelectedPrivateSnapshotCleanRootComparisonExceptionAt + table source ordinal target rightRoot) : + selectedPrivateSnapshotLayerRootPosition? ordinal source = some target := by + obtain ⟨selected, output, hordinal, _hselection, hgood, hroot, _hclean, _hcomparison⟩ := + hexception + unfold selectedPrivateSnapshotLayerRootPosition? + have hlt : ordinal < source.2.length := by rw [← hordinal]; exact selected.isLt + rw [dif_pos hlt, candidateLayerRootPosition?_eq_some_iff] + have hindex : (⟨ordinal, hlt⟩ : Fin source.2.length) = selected := Fin.ext hordinal.symm + rw [hindex] + have hcandidate := hgood.1 + rw [privateOrdinalSelectionOfSnapshot_candidate] at hcandidate + have hcandidate' : (source.2.get selected).probe = + ⟨.position target, truncateHash output⟩ := by + simpa [snapshotProbeOrdinal] using hcandidate + exact ⟨congrArg Probe.coordinate hcandidate', hroot⟩ + +theorem not_candidatesAvoidRoot_mem_candidate_map + {target : Position} {root : Digest} {candidates : List Probe} + (havoid : ¬CandidatesAvoidRoot target root candidates) : + root ∈ candidates.map Probe.candidate := by + classical + by_contra hmem + apply havoid + intro candidate hcandidate heq + apply hmem + rw [List.mem_map] + exact ⟨candidate, hcandidate, by rw [heq]⟩ + +theorem SelectedPrivateSnapshotCleanRootComparisonExceptionAt.comparison_mem + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} {ordinal : Nat} + {target : Position} {rightRoot : Digest} + (hexception : SelectedPrivateSnapshotCleanRootComparisonExceptionAt + table source ordinal target rightRoot) : + rightRoot ∈ snapshotPrefixCandidateDigests ordinal source := by + obtain ⟨selected, _output, hordinal, _hselection, _hgood, _hroot, _hclean, + hcomparison⟩ := hexception + have hmem := not_candidatesAvoidRoot_mem_candidate_map hcomparison + unfold snapshotPrefixCandidateDigests + rw [← hordinal] at hmem ⊢ + rw [privateOrdinalSelectionOfSnapshot_candidates_take] at hmem + simpa [List.map_take, Function.comp_def] using hmem + +theorem probEvent_cleanRootFiber_comparisonException_le + (table : OtsSecretIndex → HashOutput) + (run : ProbComp PrivateWitnessSnapshotOutput) (ordinal : Nat) (target : Position) : + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + SelectedPrivateSnapshotCleanRootComparisonExceptionAt + table result.1 ordinal target result.2 | do + let source ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] ≤ + Pr[fun source => SelectedPrivateSnapshotCleanRootHitAt table source ordinal ∧ + selectedPrivateSnapshotLayerRootPosition? ordinal source = some target | run] * + ((ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + let gate := fun source : PrivateWitnessSnapshotOutput => + SelectedPrivateSnapshotCleanRootHitAt table source ordinal ∧ + selectedPrivateSnapshotLayerRootPosition? ordinal source = some target + let values := snapshotPrefixCandidateDigests ordinal + calc + _ ≤ Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + gate result.1 ∧ result.2 ∈ values result.1 | do + let source ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] := by + apply probEvent_mono + intro result _hresult hexception + exact ⟨⟨hexception.cleanRootHit, hexception.position⟩, hexception.comparison_mem⟩ + _ ≤ Pr[gate | run] * + ((ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply probEvent_gate_and_uniformDigest_mem_list_le run gate values ordinal + intro source _hsource _hgate + unfold values snapshotPrefixCandidateDigests + simp + _ = _ := rfl + +theorem relTriple_pair_uniform_right + (run : ProbComp α) [SampleableType β] : + RelTriple run (do + let value ← run + let sampled ← ($ᵗ β : ProbComp β) + pure (value, sampled)) (fun value result => value = result.1) := by + apply relTriple_of_evalDist_eq_left + (show evalDist run = evalDist (run >>= pure) by simp) + apply relTriple_bind (relTriple_refl run) + intro left right heq + subst right + have hbase := relTriple_true (pure left : ProbComp α) (do + let sampled ← ($ᵗ β : ProbComp β) + pure (left, sampled)) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun value => value = left) (by intro value hvalue; simpa using hvalue) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro value result hrelation + rw [hrelation.1.2] + rw [mem_support_bind_iff] at hrelation + obtain ⟨sampled, _hsampled, hresult⟩ := hrelation.2 + symm + simpa using congrArg Prod.fst (show result = (left, sampled) by simpa using hresult) + +theorem cleanRootFiber_split_comparison + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} {ordinal : Nat} + {target : Position} {rightRoot : Digest} + (hhit : SelectedPrivateSnapshotCleanRootHitAt table source ordinal) + (hposition : selectedPrivateSnapshotLayerRootPosition? ordinal source = some target) : + SelectedPrivateSnapshotCleanRootGoodForComparisonAt + table source ordinal target rightRoot ∨ + SelectedPrivateSnapshotCleanRootComparisonExceptionAt + table source ordinal target rightRoot := by + obtain ⟨selected, sourceTarget, output, hordinal, hselection, hactual, hroot, hclean⟩ := hhit + have htarget : sourceTarget = target := by + have hsourcePosition : + selectedPrivateSnapshotLayerRootPosition? ordinal source = some sourceTarget := by + unfold selectedPrivateSnapshotLayerRootPosition? + have hlt : ordinal < source.2.length := by rw [← hordinal]; exact selected.isLt + rw [dif_pos hlt, candidateLayerRootPosition?_eq_some_iff] + have hindex : (⟨ordinal, hlt⟩ : Fin source.2.length) = selected := + Fin.ext hordinal.symm + rw [hindex] + have hcandidate := hactual.1 + rw [privateOrdinalSelectionOfSnapshot_candidate] at hcandidate + have hcandidate' : (source.2.get selected).probe = + ⟨.position sourceTarget, truncateHash output⟩ := by + simpa [snapshotProbeOrdinal] using hcandidate + exact ⟨congrArg Probe.coordinate hcandidate', hroot⟩ + rw [hposition] at hsourcePosition + exact (Option.some.inj hsourcePosition).symm + subst sourceTarget + by_cases hright : CandidatesAvoidRoot target rightRoot + ((privateOrdinalSelectionOfSnapshot selected).candidates.take ordinal) + · exact Or.inl ⟨selected, output, hordinal, hselection, hactual, hroot, hclean, hright⟩ + · exact Or.inr ⟨selected, output, hordinal, hselection, hactual, hroot, hclean, hright⟩ + +theorem probEvent_cleanRootFiber_le_goodComparison_add_exception + (table : OtsSecretIndex → HashOutput) + (run : ProbComp PrivateWitnessSnapshotOutput) (ordinal : Nat) (target : Position) : + Pr[fun source => SelectedPrivateSnapshotCleanRootHitAt table source ordinal ∧ + selectedPrivateSnapshotLayerRootPosition? ordinal source = some target | run] ≤ + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + SelectedPrivateSnapshotCleanRootGoodForComparisonAt + table result.1 ordinal target result.2 | do + let source ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] + + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + SelectedPrivateSnapshotCleanRootComparisonExceptionAt + table result.1 ordinal target result.2 | do + let source ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] := by + let paired : ProbComp (PrivateWitnessSnapshotOutput × Digest) := do + let source ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot) + calc + _ ≤ Pr[fun result => SelectedPrivateSnapshotCleanRootHitAt table result.1 ordinal ∧ + selectedPrivateSnapshotLayerRootPosition? ordinal result.1 = some target | paired] := by + apply probEvent_le_of_relTriple (relTriple_pair_uniform_right run) + intro source result hrelation hevent + rwa [← hrelation] + _ ≤ Pr[fun result => + SelectedPrivateSnapshotCleanRootGoodForComparisonAt + table result.1 ordinal target result.2 ∨ + SelectedPrivateSnapshotCleanRootComparisonExceptionAt + table result.1 ordinal target result.2 | paired] := by + apply probEvent_mono + intro result _hresult hevent + exact cleanRootFiber_split_comparison hevent.1 hevent.2 + _ ≤ _ := probEvent_or_le _ _ _ + +theorem probEvent_cleanRootFiber_le_goodComparison_add_weighted_exception + (table : OtsSecretIndex → HashOutput) + (run : ProbComp PrivateWitnessSnapshotOutput) (ordinal : Nat) (target : Position) : + Pr[fun source => SelectedPrivateSnapshotCleanRootHitAt table source ordinal ∧ + selectedPrivateSnapshotLayerRootPosition? ordinal source = some target | run] ≤ + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + SelectedPrivateSnapshotCleanRootGoodForComparisonAt + table result.1 ordinal target result.2 | do + let source ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] + + Pr[fun source => SelectedPrivateSnapshotCleanRootHitAt table source ordinal ∧ + selectedPrivateSnapshotLayerRootPosition? ordinal source = some target | run] * + ((ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + exact (probEvent_cleanRootFiber_le_goodComparison_add_exception table run ordinal target).trans + (add_le_add_right + (probEvent_cleanRootFiber_comparisonException_le table run ordinal target) _) + +def privateOrdinalSelectionGoodForSomeOutput + (target : Position) (rightRoot : Digest) (ordinal : Nat) : + Option PrivateOrdinalSelection → Prop + | none => False + | some selection => ∃ output, + selection.GoodForRoots target output rightRoot ordinal + +theorem relTriple_snapshotComparison_privateOrdinalSelectionComparison + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + RelTriple + (do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret fuel + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)) + (do + let selection ← granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter + table ftsSecret fuel + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot)) + (fun left right => + SnapshotOrdinalSelectionRel ordinal left.1 right.1 ∧ left.2 = right.2) := by + apply relTriple_bind + (relTriple_granularAllCanonicalSnapshot_privateOrdinalSelection ordinal adversary parameter + table ftsSecret fuel) + intro source selection hselection + apply relTriple_bind (relTriple_refl ($ᵗ Digest : ProbComp Digest)) + intro leftRoot rightRoot hroot + subst rightRoot + exact relTriple_pure_pure ⟨hselection, rfl⟩ + +theorem probEvent_goodComparison_le_privateOrdinalSelection + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) : + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + SelectedPrivateSnapshotCleanRootGoodForComparisonAt + table result.1 ordinal target result.2 | do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret fuel + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] ≤ + Pr[fun result : Option PrivateOrdinalSelection × Digest => + privateOrdinalSelectionGoodForSomeOutput target result.2 ordinal result.1 | do + let selection ← granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter + table ftsSecret fuel + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot)] := by + apply probEvent_le_of_relTriple + (relTriple_snapshotComparison_privateOrdinalSelectionComparison ordinal adversary parameter + table ftsSecret fuel) + intro source selection hrelation hgood + obtain ⟨selected, output, _hordinal, hselected, hactual⟩ := hgood.goodForRoots + have hselection : selection.1 = + some (privateOrdinalSelectionOfSnapshot selected) := by + exact hrelation.1.symm.trans hselected + rw [hselection] + exact ⟨output, by simpa [hrelation.2] using hactual⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootEager.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootEager.lean new file mode 100644 index 00000000..f4cdf4a3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootEager.lean @@ -0,0 +1,1268 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootComparison + +/-! +# Eager layer-root selection + +The source selector may learn its selected layer root lazily during an earlier signer or structural +computation. The materialized comparison samples that root before the retained run. This file +connects the two schedules while retaining the installed root in the comparison state. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +noncomputable def candidateFinalizationObserve + (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (fuel : Nat) (candidate : Probe) : ProbComp Bool := + runResolvedObserve (resolvedFinalizationObserve table) context (fuel + 1) table (do + (probe candidate).run emptySplitHashCache) + +theorem evalDist_candidateFinalizationObserve_eq_true_of_goodForRoots + (table : OtsSecretIndex → HashOutput) + (selection : PrivateOrdinalSelection) (fuel : Nat) + (target : Position) (output : HashOutput) (rightRoot : Digest) (ordinal : Nat) + (hvalid : selection.context.Valid) + (hcompletable : DeferredCompletable table selection.context) + (hgood : selection.GoodForRoots target output rightRoot ordinal) : + evalDist (candidateFinalizationObserve table selection.context fuel selection.candidate) = + evalDist (pure true : ProbComp Bool) := by + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + obtain ⟨completion, hcompletion⟩ := hcompletable + have hdoomed : ¬DeferredCompletable table + { selection.context with + state := selection.context.state.addPending + (.position target) (truncateHash output) } := by + simpa using not_congr + (deferredCompletable_addPending_position_iff target output (truncateHash output) + hcompletion hgood.2.2.2.1) + unfold candidateFinalizationObserve + rw [show selection.candidate = ⟨.position target, truncateHash output⟩ from hgood.1] + unfold probe + rw [StateT.run_liftM, LazyRevealProbe.probeQuery, + runResolvedObserve, runResolvedFromTable_probe_query_bind] + simp only [hgood.2.2.1, ↓reduceIte] + exact evalDist_runResolvedObserve_eq_true_of_not_completable_auto + { selection.context with + state := selection.context.state.addPending (.position target) (truncateHash output) } + fuel table (pure ((), emptySplitHashCache)) + (hvalid.valuesConsistent.addPending (.position target) (truncateHash output)) + (hstarts.addPending (.position target) (truncateHash output)) hdoomed + +instance candidateFinalizationObserve_observerDooms + (table : OtsSecretIndex → HashOutput) : + ObserverDooms table (candidateFinalizationObserve table) where + eq_true context fuel candidate hconsistent hstarts hdoomed := by + exact evalDist_runResolvedObserve_eq_true_of_not_completable_auto + (observe := resolvedFinalizationObserve table) context (fuel + 1) table + ((probe candidate).run emptySplitHashCache) hconsistent hstarts hdoomed + +instance candidateFinalizationObserve_observerSynchronized + (table : OtsSecretIndex → HashOutput) : + ObserverSynchronized table (candidateFinalizationObserve table) where + eq_of_synchronized left right fuel candidate hcontext hvalues hrevealed := by + exact evalDist_runResolvedObserve_eq_of_finalizationSynchronized + (observe := resolvedFinalizationObserve table) + ((probe candidate).run emptySplitHashCache) left right (fuel + 1) table hcontext + hvalues hrevealed + +instance candidateFinalizationObserve_observerPositionNeutral + (table : OtsSecretIndex → HashOutput) : + ObserverPositionNeutral table (candidateFinalizationObserve table) where + eq_resolve position context fuel candidate hvalid hcompletable hensured := by + exact evalDist_resolveDeferredPositionValue_then_runResolvedObserve_auto position + (observe := resolvedFinalizationObserve table) + ((probe candidate).run emptySplitHashCache) context (fuel + 1) table hvalid + hcompletable hensured + +noncomputable def ordinalRootFinalizationObserve + (table : OtsSecretIndex → HashOutput) (target : Position) + (rightRoot : Digest) (ordinal : Nat) + (context : DeferredContext) (fuel : Nat) (candidates : List Probe) : ProbComp Bool := by + classical + exact if hselected : ordinal < candidates.length then + let candidate := candidates.get ⟨ordinal, hselected⟩ + if candidate.coordinate = .position target ∧ + CandidatesAvoidRoot target rightRoot (candidates.take ordinal) then + candidateFinalizationObserve table context fuel candidate + else resolvedFinalizationObserve table context fuel () + else resolvedFinalizationObserve table context fuel () + +instance ordinalRootFinalizationObserve_observerDooms + (table : OtsSecretIndex → HashOutput) (target : Position) + (rightRoot : Digest) (ordinal : Nat) (candidates : List Probe) : + ObserverDooms table + (fun context fuel (_value : Unit) => + ordinalRootFinalizationObserve table target rightRoot ordinal context fuel candidates) where + eq_true context fuel _value hconsistent hstarts hdoomed := by + unfold ordinalRootFinalizationObserve + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + by_cases hgate : + (candidates.get ⟨ordinal, hselected⟩).coordinate = .position target ∧ + CandidatesAvoidRoot target rightRoot (candidates.take ordinal) + · simp only [hgate] + exact ObserverDooms.eq_true + (table := table) (observe := candidateFinalizationObserve table) + context fuel _ hconsistent hstarts hdoomed + · simp only [hgate] + exact ObserverDooms.eq_true + (table := table) (observe := resolvedFinalizationObserve table) + context fuel () hconsistent hstarts hdoomed + · simp only [hselected, ↓reduceDIte] + exact ObserverDooms.eq_true + (table := table) (observe := resolvedFinalizationObserve table) + context fuel () hconsistent hstarts hdoomed + +instance ordinalRootFinalizationObserve_observerSynchronized + (table : OtsSecretIndex → HashOutput) (target : Position) + (rightRoot : Digest) (ordinal : Nat) (candidates : List Probe) : + ObserverSynchronized table + (fun context fuel (_value : Unit) => + ordinalRootFinalizationObserve table target rightRoot ordinal context fuel candidates) where + eq_of_synchronized left right fuel _value hcontext hvalues hrevealed := by + unfold ordinalRootFinalizationObserve + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + by_cases hgate : + (candidates.get ⟨ordinal, hselected⟩).coordinate = .position target ∧ + CandidatesAvoidRoot target rightRoot (candidates.take ordinal) + · simp only [hgate] + exact ObserverSynchronized.eq_of_synchronized + (table := table) (observe := candidateFinalizationObserve table) + left right fuel _ hcontext hvalues hrevealed + · simp only [hgate] + exact ObserverSynchronized.eq_of_synchronized + (table := table) (observe := resolvedFinalizationObserve table) + left right fuel () hcontext hvalues hrevealed + · simp only [hselected, ↓reduceDIte] + exact ObserverSynchronized.eq_of_synchronized + (table := table) (observe := resolvedFinalizationObserve table) + left right fuel () hcontext hvalues hrevealed + +instance ordinalRootFinalizationObserve_observerPositionNeutral + (table : OtsSecretIndex → HashOutput) (target : Position) + (rightRoot : Digest) (ordinal : Nat) (candidates : List Probe) : + ObserverPositionNeutral table + (fun context fuel (_value : Unit) => + ordinalRootFinalizationObserve table target rightRoot ordinal context fuel candidates) where + eq_resolve position context fuel _value hvalid hcompletable hensured := by + unfold ordinalRootFinalizationObserve + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + by_cases hgate : + (candidates.get ⟨ordinal, hselected⟩).coordinate = .position target ∧ + CandidatesAvoidRoot target rightRoot (candidates.take ordinal) + · simp only [hgate] + exact ObserverPositionNeutral.eq_resolve + (table := table) (observe := candidateFinalizationObserve table) + position context fuel _ hvalid hcompletable hensured + · simp only [hgate] + exact ObserverPositionNeutral.eq_resolve + (table := table) (observe := resolvedFinalizationObserve table) + position context fuel () hvalid hcompletable hensured + · simp only [hselected, ↓reduceDIte] + exact ObserverPositionNeutral.eq_resolve + (table := table) (observe := resolvedFinalizationObserve table) + position context fuel () hvalid hcompletable hensured + +noncomputable def directBoundaryPrivateOrdinalFinalizationRisk + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : ProbComp Bool := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + List Probe → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → + SplitHashCache → ProbComp Bool) + (fun _value candidates context fuel table _cache => + ordinalRootFinalizationObserve table target rightRoot ordinal context fuel candidates) + (fun query _next recursivelyRun candidates context fuel table cache => + if hselected : ordinal < candidates.length then + ordinalRootFinalizationObserve table target rightRoot ordinal context fuel candidates + else + match query with + | .inl (.inl n) => + runResolvedObserve + (canonicalizeObserve table + (fun nextContext remaining value => + recursivelyRun value.1 candidates nextContext remaining table value.2)) + context fuel table ((splitUniformImpl n).run cache) + | .inl (.inr input) => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + if hnextSelected : ordinal < nextCandidates.length then + ordinalRootFinalizationObserve table target rightRoot ordinal context fuel + nextCandidates + else + runResolvedObserve + (canonicalizeObserve table + (fun nextContext remaining value => + recursivelyRun value.1 nextCandidates nextContext remaining table value.2)) + context fuel table ((probingHashQueryAfterPlan parameter input plan).run cache) + | .inr message => + runResolvedObserve + (canonicalizeObserve table + (fun nextContext remaining value => + recursivelyRun value.1 candidates nextContext remaining table value.2)) + context fuel table ((maskedSign parameter root ftsSecret message).run cache)) + computation candidates context fuel table cache + +set_option maxRecDepth 100000 in +theorem directBoundaryPrivateOrdinalFinalizationRisk_dooms + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) : + evalDist (directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root ftsSecret + target rightRoot computation candidates context fuel table cache) = + evalDist (pure true : ProbComp Bool) := by + induction computation using OracleComp.inductionOn generalizing + candidates context fuel cache with + | pure value => + rw [directBoundaryPrivateOrdinalFinalizationRisk, OracleComp.construct_pure] + exact ObserverDooms.eq_true + (table := table) + (observe := fun context fuel (_value : Unit) => + ordinalRootFinalizationObserve table target rightRoot ordinal context fuel candidates) + context fuel () hconsistent hstarts hdoomed + | query_bind query next ih => + rw [directBoundaryPrivateOrdinalFinalizationRisk, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact ObserverDooms.eq_true + (table := table) + (observe := fun context fuel (_value : Unit) => + ordinalRootFinalizationObserve table target rightRoot ordinal context fuel candidates) + context fuel () hconsistent hstarts hdoomed + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let nextObserve : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root ftsSecret + target rightRoot (next value.1) candidates nextContext remaining table value.2 + letI : ObserverDooms table nextObserve := ⟨by + intro nextContext remaining value hnextConsistent hnextStarts hnextDoomed + exact ih value.1 candidates nextContext remaining value.2 hnextConsistent + hnextStarts hnextDoomed⟩ + exact evalDist_runResolvedObserve_eq_true_of_not_completable_auto + (observe := canonicalizeObserve table nextObserve) context fuel table + ((splitUniformImpl n).run cache) hconsistent hstarts hdoomed + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + exact ObserverDooms.eq_true + (table := table) + (observe := fun context fuel (_value : Unit) => + ordinalRootFinalizationObserve table target rightRoot ordinal context fuel + nextCandidates) + context fuel () hconsistent hstarts hdoomed + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + let nextObserve : DeferredContext → Nat → + (HashOutput × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root + ftsSecret target rightRoot (next value.1) nextCandidates nextContext + remaining table value.2 + letI : ObserverDooms table nextObserve := ⟨by + intro nextContext remaining value hnextConsistent hnextStarts hnextDoomed + exact ih value.1 nextCandidates nextContext remaining value.2 hnextConsistent + hnextStarts hnextDoomed⟩ + exact evalDist_runResolvedObserve_eq_true_of_not_completable_auto + (observe := canonicalizeObserve table nextObserve) context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) + hconsistent hstarts hdoomed + | inr message => + let nextObserve : DeferredContext → Nat → + (Option Signature × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root ftsSecret + target rightRoot (next value.1) candidates nextContext remaining table value.2 + letI : ObserverDooms table nextObserve := ⟨by + intro nextContext remaining value hnextConsistent hnextStarts hnextDoomed + exact ih value.1 candidates nextContext remaining value.2 hnextConsistent + hnextStarts hnextDoomed⟩ + exact evalDist_runResolvedObserve_eq_true_of_not_completable_auto + (observe := canonicalizeObserve table nextObserve) context fuel table + ((maskedSign parameter root ftsSecret message).run cache) + hconsistent hstarts hdoomed + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 4000000 in +theorem directBoundaryPrivateOrdinalFinalizationRisk_synchronized + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (left right : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) + (hrevealed : left.state.revealed = right.state.revealed) : + evalDist (directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root ftsSecret + target rightRoot computation candidates left fuel table cache) = + evalDist (directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root ftsSecret + target rightRoot computation candidates right fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing + candidates left right fuel cache with + | pure value => + rw [directBoundaryPrivateOrdinalFinalizationRisk, OracleComp.construct_pure, + directBoundaryPrivateOrdinalFinalizationRisk, OracleComp.construct_pure] + exact ObserverSynchronized.eq_of_synchronized + (table := table) + (observe := fun context fuel (_value : Unit) => + ordinalRootFinalizationObserve table target rightRoot ordinal context fuel candidates) + left right fuel () hcontext hvalues hrevealed + | query_bind query next ih => + by_cases hselected : ordinal < candidates.length + · simp only [directBoundaryPrivateOrdinalFinalizationRisk, + OracleComp.construct_query_bind, hselected, ↓reduceDIte] + exact ObserverSynchronized.eq_of_synchronized + (table := table) + (observe := fun context fuel (_value : Unit) => + ordinalRootFinalizationObserve table target rightRoot ordinal context fuel candidates) + left right fuel () hcontext hvalues hrevealed + · cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + simp only [directBoundaryPrivateOrdinalFinalizationRisk, + OracleComp.construct_query_bind, hselected, ↓reduceDIte] + let nextObserve : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root ftsSecret + target rightRoot (next value.1) candidates nextContext remaining table value.2 + letI : ObserverDooms table nextObserve := ⟨by + intro nextContext remaining value hnextConsistent hnextStarts hnextDoomed + exact directBoundaryPrivateOrdinalFinalizationRisk_dooms ordinal parameter root + ftsSecret target rightRoot (next value.1) candidates nextContext remaining table + value.2 hnextConsistent hnextStarts hnextDoomed⟩ + letI : ObserverSynchronized table nextObserve := ⟨by + intro nextLeft nextRight remaining value hnextContext hnextValues hnextRevealed + exact ih value.1 candidates nextLeft nextRight remaining value.2 hnextContext + hnextValues hnextRevealed⟩ + exact evalDist_runResolvedObserve_eq_of_finalizationSynchronized + (observe := canonicalizeObserve table nextObserve) + ((splitUniformImpl n).run cache) left right fuel table hcontext hvalues hrevealed + | inr input => + have hplan : purePlanProbingHashQuery parameter input left.state = + purePlanProbingHashQuery parameter input right.state := + purePlanProbingHashQuery_eq_of_values_eq hvalues parameter input + have hcandidate : rootAwarePlannedCandidate? parameter input left.state = + rootAwarePlannedCandidate? parameter input right.state := by + unfold rootAwarePlannedCandidate? + rw [hplan] + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input left.state) + simp only [directBoundaryPrivateOrdinalFinalizationRisk, + OracleComp.construct_query_bind, hselected, ↓reduceDIte, ← hplan, ← hcandidate] + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input left.state)).length := by + simpa [nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + exact ObserverSynchronized.eq_of_synchronized + (table := table) + (observe := fun context fuel (_value : Unit) => + ordinalRootFinalizationObserve table target rightRoot ordinal context fuel + nextCandidates) + left right fuel () hcontext hvalues hrevealed + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input left.state)).length := by + simpa [nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + let nextObserve : DeferredContext → Nat → + (HashOutput × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root + ftsSecret target rightRoot (next value.1) nextCandidates nextContext + remaining table value.2 + letI : ObserverDooms table nextObserve := ⟨by + intro nextContext remaining value hnextConsistent hnextStarts hnextDoomed + exact directBoundaryPrivateOrdinalFinalizationRisk_dooms ordinal parameter root + ftsSecret target rightRoot (next value.1) nextCandidates nextContext remaining + table value.2 hnextConsistent hnextStarts hnextDoomed⟩ + letI : ObserverSynchronized table nextObserve := ⟨by + intro nextLeft nextRight remaining value hnextContext hnextValues hnextRevealed + exact ih value.1 nextCandidates nextLeft nextRight remaining value.2 + hnextContext hnextValues hnextRevealed⟩ + exact evalDist_runResolvedObserve_eq_of_finalizationSynchronized + (observe := canonicalizeObserve table nextObserve) + ((probingHashQueryAfterPlan parameter input + (purePlanProbingHashQuery parameter input left.state)).run cache) + left right fuel table hcontext hvalues hrevealed + | inr message => + simp only [directBoundaryPrivateOrdinalFinalizationRisk, + OracleComp.construct_query_bind, hselected, ↓reduceDIte] + let nextObserve : DeferredContext → Nat → + (Option Signature × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root ftsSecret + target rightRoot (next value.1) candidates nextContext remaining table value.2 + letI : ObserverDooms table nextObserve := ⟨by + intro nextContext remaining value hnextConsistent hnextStarts hnextDoomed + exact directBoundaryPrivateOrdinalFinalizationRisk_dooms ordinal parameter root + ftsSecret target rightRoot (next value.1) candidates nextContext remaining table + value.2 hnextConsistent hnextStarts hnextDoomed⟩ + letI : ObserverSynchronized table nextObserve := ⟨by + intro nextLeft nextRight remaining value hnextContext hnextValues hnextRevealed + exact ih value.1 candidates nextLeft nextRight remaining value.2 hnextContext + hnextValues hnextRevealed⟩ + exact evalDist_runResolvedObserve_eq_of_finalizationSynchronized + (observe := canonicalizeObserve table nextObserve) + ((maskedSign parameter root ftsSecret message).run cache) + left right fuel table hcontext hvalues hrevealed + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 4000000 in +theorem evalDist_resolveDeferredPositionValue_then_directBoundaryPrivateOrdinalFinalizationRisk + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rightRoot : Digest) + (position : Position) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : Coordinate.position position ∈ context.state.ensured) : + evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root ftsSecret target + rightRoot computation candidates resolved.toDeferredContext fuel table cache) = + evalDist (directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root ftsSecret + target rightRoot computation candidates context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing + candidates context fuel cache position with + | pure value => + rw [directBoundaryPrivateOrdinalFinalizationRisk, OracleComp.construct_pure] + exact ObserverPositionNeutral.eq_resolve + (table := table) + (observe := fun context fuel (_value : Unit) => + ordinalRootFinalizationObserve table target rightRoot ordinal context fuel candidates) + position context fuel () hvalid hcompletable hensured + | query_bind query next ih => + by_cases hselected : ordinal < candidates.length + · simp only [directBoundaryPrivateOrdinalFinalizationRisk, + OracleComp.construct_query_bind, hselected, ↓reduceDIte] + exact ObserverPositionNeutral.eq_resolve + (table := table) + (observe := fun context fuel (_value : Unit) => + ordinalRootFinalizationObserve table target rightRoot ordinal context fuel candidates) + position context fuel () hvalid hcompletable hensured + · cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + simp only [directBoundaryPrivateOrdinalFinalizationRisk, + OracleComp.construct_query_bind, hselected, ↓reduceDIte] + let nextObserve : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root ftsSecret + target rightRoot (next value.1) candidates nextContext remaining table value.2 + letI : ObserverDooms table nextObserve := ⟨by + intro nextContext remaining value hnextConsistent hnextStarts hnextDoomed + exact directBoundaryPrivateOrdinalFinalizationRisk_dooms ordinal parameter root + ftsSecret target rightRoot (next value.1) candidates nextContext remaining table + value.2 hnextConsistent hnextStarts hnextDoomed⟩ + letI : ObserverPositionNeutral table nextObserve := ⟨by + intro position nextContext remaining value hnextValid hnextCompletable + hnextEnsured + exact ih value.1 position candidates nextContext remaining value.2 hnextValid + hnextCompletable hnextEnsured⟩ + have hmove := + evalDist_resolveDeferredPositionValue_then_runResolvedObserve_auto position + (observe := canonicalizeObserve table nextObserve) + ((splitUniformImpl n).run cache) context fuel table hvalid hcompletable hensured + exact hmove + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + let nextObserve : DeferredContext → Nat → + (HashOutput × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root ftsSecret + target rightRoot (next value.1) nextCandidates nextContext remaining table + value.2 + have hnormalize : evalDist (resolveDeferredPositionValue position context >>= + fun resolved => match resolved with + | none => pure true + | some resolved => + if hnextSelected : ordinal < nextCandidates.length then + ordinalRootFinalizationObserve table target rightRoot ordinal + resolved.toDeferredContext fuel nextCandidates + else runResolvedObserve (canonicalizeObserve table nextObserve) + resolved.toDeferredContext fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache)) = + evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root + ftsSecret target rightRoot + (liftM (OracleSpec.query (Sum.inl (Sum.inr input))) >>= next) + candidates resolved.toDeferredContext fuel table cache) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hvalues := resolveDeferredPositionValue_preserves_state_values position + context resolved hresolved + have hplan : purePlanProbingHashQuery parameter input resolved.state = plan := by + simpa [plan] using + (purePlanProbingHashQuery_eq_of_values_eq hvalues parameter input) + have hcandidate : + rootAwarePlannedCandidate? parameter input resolved.state = + rootAwarePlannedCandidate? parameter input context.state := by + unfold rootAwarePlannedCandidate? + rw [hplan] + simp only [directBoundaryPrivateOrdinalFinalizationRisk, + OracleComp.construct_query_bind, hselected, ↓reduceDIte, hplan, hcandidate] + rfl + rw [← hnormalize] + rw [directBoundaryPrivateOrdinalFinalizationRisk, + OracleComp.construct_query_bind] + simp only [hselected, ↓reduceDIte] + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [nextCandidates] using hnextSelected + simp only [hnextSelected, hactual, ↓reduceDIte] + have hneutral := ObserverPositionNeutral.eq_resolve + (table := table) + (observe := fun context fuel (_value : Unit) => + ordinalRootFinalizationObserve table target rightRoot ordinal context fuel + nextCandidates) + position context fuel () hvalid hcompletable hensured + exact hneutral + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [nextCandidates] using hnextSelected + simp only [hnextSelected, hactual, ↓reduceDIte] + letI : ObserverDooms table nextObserve := ⟨by + intro nextContext remaining value hnextConsistent hnextStarts hnextDoomed + exact directBoundaryPrivateOrdinalFinalizationRisk_dooms ordinal parameter root + ftsSecret target rightRoot (next value.1) nextCandidates nextContext remaining + table value.2 hnextConsistent hnextStarts hnextDoomed⟩ + letI : ObserverPositionNeutral table nextObserve := ⟨by + intro nextPosition nextContext remaining value hnextValid hnextCompletable + hnextEnsured + exact ih value.1 nextPosition nextCandidates nextContext remaining value.2 + hnextValid hnextCompletable hnextEnsured⟩ + have hmove := + evalDist_resolveDeferredPositionValue_then_runResolvedObserve_auto position + (observe := canonicalizeObserve table nextObserve) + ((probingHashQueryAfterPlan parameter input plan).run cache) context fuel table + hvalid hcompletable hensured + exact hmove + | inr message => + simp only [directBoundaryPrivateOrdinalFinalizationRisk, + OracleComp.construct_query_bind, hselected, ↓reduceDIte] + let nextObserve : DeferredContext → Nat → + (Option Signature × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root ftsSecret + target rightRoot (next value.1) candidates nextContext remaining table value.2 + letI : ObserverDooms table nextObserve := ⟨by + intro nextContext remaining value hnextConsistent hnextStarts hnextDoomed + exact directBoundaryPrivateOrdinalFinalizationRisk_dooms ordinal parameter root + ftsSecret target rightRoot (next value.1) candidates nextContext remaining table + value.2 hnextConsistent hnextStarts hnextDoomed⟩ + letI : ObserverPositionNeutral table nextObserve := ⟨by + intro position nextContext remaining value hnextValid hnextCompletable hnextEnsured + exact ih value.1 position candidates nextContext remaining value.2 hnextValid + hnextCompletable hnextEnsured⟩ + have hmove := + evalDist_resolveDeferredPositionValue_then_runResolvedObserve_auto position + (observe := canonicalizeObserve table nextObserve) + ((maskedSign parameter root ftsSecret message).run cache) context fuel table hvalid + hcompletable hensured + exact hmove + +def PrivateOrdinalRootRiskRel + (target : Position) (rightRoot : Digest) (ordinal : Nat) + (selection : Option PrivateOrdinalSelection) (hit : Bool) : Prop := + privateOrdinalSelectionGoodForSomeOutput target rightRoot ordinal selection → hit = true + +theorem relTriple_pureSelection_rootRisk + (target : Position) (rightRoot : Digest) (ordinal : Nat) + (selection : Option PrivateOrdinalSelection) (risk : ProbComp Bool) + (hfire : privateOrdinalSelectionGoodForSomeOutput target rightRoot ordinal selection → + evalDist risk = evalDist (pure true : ProbComp Bool)) : + RelTriple (pure selection : ProbComp (Option PrivateOrdinalSelection)) risk + (PrivateOrdinalRootRiskRel target rightRoot ordinal) := by + by_cases hgood : + privateOrdinalSelectionGoodForSomeOutput target rightRoot ordinal selection + · have hbase := relTriple_true + (pure selection : ProbComp (Option PrivateOrdinalSelection)) + (pure true : ProbComp Bool) + have hsupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + have hrel : RelTriple + (pure selection : ProbComp (Option PrivateOrdinalSelection)) + (pure true : ProbComp Bool) + (PrivateOrdinalRootRiskRel target rightRoot ordinal) := by + apply relTriple_post_mono hsupport + intro _left right hrelation _hleft + simpa using hrelation.2 + exact relTriple_of_evalDist_eq_right (hfire hgood).symm hrel + · apply relTriple_post_mono + (SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + (relTriple_true (pure selection : ProbComp (Option PrivateOrdinalSelection)) risk) + (fun left => left = selection) (by intro left hleft; simpa using hleft)) + intro left _right hrelation hleft + exact False.elim (hgood (hrelation.2 ▸ hleft)) + +theorem relTriple_selected_ordinalRootFinalizationObserve + (table : OtsSecretIndex → HashOutput) + (target : Position) (rightRoot : Digest) (ordinal : Nat) + (context : DeferredContext) (fuel : Nat) (candidates : List Probe) + (hselected : ordinal < candidates.length) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + RelTriple + (pure (some ⟨candidates.get ⟨ordinal, hselected⟩, context, candidates⟩) : + ProbComp (Option PrivateOrdinalSelection)) + (ordinalRootFinalizationObserve table target rightRoot ordinal context fuel candidates) + (PrivateOrdinalRootRiskRel target rightRoot ordinal) := by + apply relTriple_pureSelection_rootRisk + rintro ⟨output, hgood⟩ + have hright : CandidatesAvoidRoot target rightRoot (candidates.take ordinal) := by + intro candidate hcandidate + exact (hgood.2.2.2.2 candidate hcandidate).2 + have hcoordinate : + (candidates.get ⟨ordinal, hselected⟩).coordinate = .position target := by + simpa using congrArg Probe.coordinate hgood.1 + unfold ordinalRootFinalizationObserve + simp only [hselected, ↓reduceDIte, hcoordinate, hright, and_self, if_true] + exact evalDist_candidateFinalizationObserve_eq_true_of_goodForRoots table + ⟨candidates.get ⟨ordinal, hselected⟩, context, candidates⟩ fuel target output + rightRoot ordinal hvalid hcompletable hgood + +set_option maxRecDepth 100000 in +theorem relTriple_runWitnessSelection_runResolvedObserve + (table : OtsSecretIndex → HashOutput) + (target : Position) (rightRoot : Digest) (ordinal : Nat) + (selectionObserve : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (riskObserve : DeferredContext → Nat → α → ProbComp Bool) + [ObserverDooms table riskObserve] [ObserverSynchronized table riskObserve] + [ObserverPositionNeutral table riskObserve] + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hobserve : ∀ result, + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) → + RelTriple + (selectionObserve result.context result.remaining result.value candidates) + (riskObserve result.context result.remaining result.value) + (PrivateOrdinalRootRiskRel target rightRoot ordinal)) : + RelTriple + (runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectPrivateOrdinalSelection selectionObserve candidates) + (runResolvedObserve riskObserve context fuel table computation) + (PrivateOrdinalRootRiskRel target rightRoot ordinal) := by + apply relTriple_of_evalDist_eq_left + (evalDist_runWitnessSelection_eq_detailed selectionObserve candidates context fuel table + computation) + apply relTriple_of_evalDist_eq_right + (evalDist_runResolvedObserve_eq_runDirectResolvedObserve riskObserve context fuel table + computation hvalid hcompletable).symm + unfold runDirectResolvedObserve + rw [← map_toOption_runDirectResolvedDetailedFromTable computation context fuel table, + map_eq_bind_pure_comp, bind_assoc] + let run := runDirectResolvedDetailedFromTable context fuel table computation + have hrun := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + (relTriple_refl run) (fun result => result ∈ support run) + (fun result hresult => hresult) + apply relTriple_bind hrun + intro leftResult rightResult hrelation + rcases hrelation with ⟨heq, hleftMem⟩ + subst rightResult + cases leftResult with + | stopped reason => + simp only [finishDirectDetailedPrivateOrdinalSelection, Function.comp_apply, pure_bind, + DirectDetailedResult.toOption, finishObserve] + apply relTriple_pureSelection_rootRisk + simp [privateOrdinalSelectionGoodForSomeOutput] + | done result => + simpa [finishDirectDetailedPrivateOrdinalSelection, Function.comp_apply, + DirectDetailedResult.toOption, finishObserve] using hobserve result hleftMem + +theorem relTriple_canonicalSelection_canonicalObserve + (table : OtsSecretIndex → HashOutput) + (target : Position) (rightRoot : Digest) (ordinal : Nat) + (selectionObserve : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (riskObserve : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hrecursive : PublishedValues context.state → + DeferredCompletable table (canonicalizeMaterializedValues table context) → + RelTriple + (selectionObserve (canonicalizeMaterializedValues table context) fuel value candidates) + (riskObserve (canonicalizeMaterializedValues table context) fuel value) + (PrivateOrdinalRootRiskRel target rightRoot ordinal)) : + RelTriple + (canonicalizeDirectPrivateOrdinalSelection table selectionObserve context fuel value + candidates) + (canonicalizeObserve table riskObserve context fuel value) + (PrivateOrdinalRootRiskRel target rightRoot ordinal) := by + classical + unfold canonicalizeDirectPrivateOrdinalSelection canonicalizeObserve + let canonical := canonicalizeMaterializedValues table context + by_cases hhit : PrivateStructuralHit canonical + · simp only [canonical, hhit] + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + apply relTriple_pureSelection_rootRisk + simp [privateOrdinalSelectionGoodForSomeOutput] + · simp only [hpublished, ↓reduceIte] + apply relTriple_pureSelection_rootRisk + simp [privateOrdinalSelectionGoodForSomeOutput] + · simp only [canonical, hhit] + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table canonical + · simpa [canonical, hcompletable] using hrecursive hpublished hcompletable + · simp only [canonical, hcompletable, ↓reduceIte] + apply relTriple_pureSelection_rootRisk + simp [privateOrdinalSelectionGoodForSomeOutput] + · simp only [hpublished, ↓reduceIte] + apply relTriple_pureSelection_rootRisk + simp [privateOrdinalSelectionGoodForSomeOutput] + +theorem resolvedCore_of_done_runDirectResolvedDetailedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation)) : + result.table = table ∧ result.context.ValuesConsistent ∧ + StartTableAgrees result.context.state table := by + apply resolvedCore_of_mem_runDirectResolvedFromTable computation context fuel table result + hconsistent hstarts + rw [← map_toOption_runDirectResolvedDetailedFromTable computation context fuel table, + support_map] + exact ⟨.done result, hresult, rfl⟩ + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 4000000 in +theorem relTriple_directBoundaryPrivateOrdinalSelection_finalizationRisk + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rightRoot : Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + RelTriple + (directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret computation + candidates context fuel table cache) + (directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root ftsSecret target + rightRoot computation candidates context fuel table cache) + (PrivateOrdinalRootRiskRel target rightRoot ordinal) := by + induction computation using OracleComp.inductionOn generalizing + candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryPrivateOrdinalSelection, OracleComp.construct_pure, + directBoundaryPrivateOrdinalFinalizationRisk, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp only [selectedPrivateOrdinal?, hselected, ↓reduceDIte] + exact relTriple_selected_ordinalRootFinalizationObserve table target rightRoot ordinal + context fuel candidates hselected hvalid hcompletable + · simp only [selectedPrivateOrdinal?, hselected, ↓reduceDIte] + apply relTriple_pureSelection_rootRisk + simp [privateOrdinalSelectionGoodForSomeOutput] + | query_bind query next ih => + rw [directDetailedBoundaryPrivateOrdinalSelection, OracleComp.construct_query_bind, + directBoundaryPrivateOrdinalFinalizationRisk, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_selected_ordinalRootFinalizationObserve table target rightRoot ordinal + context fuel candidates hselected hvalid hcompletable + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let nextSelection : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection) := + fun nextContext remaining value laterCandidates => + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret + (next value.1) laterCandidates nextContext remaining table value.2 + let nextRisk : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root ftsSecret + target rightRoot (next value.1) candidates nextContext remaining table value.2 + letI : ObserverDooms table nextRisk := ⟨by + intro nextContext remaining value hconsistent hstarts hdoomed + exact directBoundaryPrivateOrdinalFinalizationRisk_dooms ordinal parameter root + ftsSecret target rightRoot (next value.1) candidates nextContext remaining table + value.2 hconsistent hstarts hdoomed⟩ + letI : ObserverSynchronized table nextRisk := ⟨by + intro left right remaining value hcontext hvalues hrevealed + exact directBoundaryPrivateOrdinalFinalizationRisk_synchronized ordinal + parameter root ftsSecret target rightRoot (next value.1) candidates left right + remaining table value.2 hcontext hvalues hrevealed⟩ + letI : ObserverPositionNeutral table nextRisk := ⟨by + intro position nextContext remaining value hnextValid hnextCompletable hensured + exact evalDist_resolveDeferredPositionValue_then_directBoundaryPrivateOrdinalFinalizationRisk + ordinal parameter root ftsSecret target rightRoot position (next value.1) + candidates nextContext remaining table value.2 hnextValid hnextCompletable + hensured⟩ + apply relTriple_runWitnessSelection_runResolvedObserve table target rightRoot ordinal + (canonicalizeDirectPrivateOrdinalSelection table nextSelection) + (canonicalizeObserve table nextRisk) candidates context fuel + ((splitUniformImpl n).run cache) hvalid hcompletable + intro result hresult + have hcore := resolvedCore_of_done_runDirectResolvedDetailedFromTable + ((splitUniformImpl n).run cache) context fuel table result + hvalid.valuesConsistent (startTableAgrees_of_deferredCompletable hcompletable) + hresult + apply relTriple_canonicalSelection_canonicalObserve table target rightRoot ordinal + nextSelection nextRisk result.context result.remaining result.value candidates + intro _hpublished hcanonicalCompletable + have hcanonicalConsistent := canonicalizeMaterializedValues_valuesConsistent table + result.context hcore.2.1 + have hcanonicalStarts := canonicalizeMaterializedValues_startTableAgrees table + result.context + have hcanonicalValid := valid_of_resolvedCore_completable table + (canonicalizeMaterializedValues table result.context) hcanonicalConsistent + hcanonicalStarts hcanonicalCompletable + simpa [nextSelection, nextRisk] using + (ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hcanonicalValid hcanonicalCompletable) + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + exact relTriple_selected_ordinalRootFinalizationObserve table target rightRoot + ordinal context fuel nextCandidates hnextSelected hvalid hcompletable + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + let nextSelection : DeferredContext → Nat → + (HashOutput × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection) := + fun nextContext remaining value laterCandidates => + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root + ftsSecret (next value.1) laterCandidates nextContext remaining table value.2 + let nextRisk : DeferredContext → Nat → + (HashOutput × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root ftsSecret + target rightRoot (next value.1) nextCandidates nextContext remaining table + value.2 + letI : ObserverDooms table nextRisk := ⟨by + intro nextContext remaining value hconsistent hstarts hdoomed + exact directBoundaryPrivateOrdinalFinalizationRisk_dooms ordinal parameter root + ftsSecret target rightRoot (next value.1) nextCandidates nextContext remaining + table value.2 hconsistent hstarts hdoomed⟩ + letI : ObserverSynchronized table nextRisk := ⟨by + intro left right remaining value hcontext hvalues hrevealed + exact directBoundaryPrivateOrdinalFinalizationRisk_synchronized ordinal + parameter root ftsSecret target rightRoot (next value.1) nextCandidates left + right remaining table value.2 hcontext hvalues hrevealed⟩ + letI : ObserverPositionNeutral table nextRisk := ⟨by + intro position nextContext remaining value hnextValid hnextCompletable hensured + exact evalDist_resolveDeferredPositionValue_then_directBoundaryPrivateOrdinalFinalizationRisk + ordinal parameter root ftsSecret target rightRoot position (next value.1) + nextCandidates nextContext remaining table value.2 hnextValid + hnextCompletable hensured⟩ + apply relTriple_runWitnessSelection_runResolvedObserve table target rightRoot + ordinal (canonicalizeDirectPrivateOrdinalSelection table nextSelection) + (canonicalizeObserve table nextRisk) nextCandidates context fuel + ((probingHashQueryAfterPlan parameter input plan).run cache) hvalid hcompletable + intro result hresult + have hcore := resolvedCore_of_done_runDirectResolvedDetailedFromTable + ((probingHashQueryAfterPlan parameter input plan).run cache) context fuel table + result hvalid.valuesConsistent + (startTableAgrees_of_deferredCompletable hcompletable) hresult + apply relTriple_canonicalSelection_canonicalObserve table target rightRoot ordinal + nextSelection nextRisk result.context result.remaining result.value + nextCandidates + intro _hpublished hcanonicalCompletable + have hcanonicalConsistent := + canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1 + have hcanonicalStarts := canonicalizeMaterializedValues_startTableAgrees table + result.context + have hcanonicalValid := valid_of_resolvedCore_completable table + (canonicalizeMaterializedValues table result.context) hcanonicalConsistent + hcanonicalStarts hcanonicalCompletable + simpa [nextSelection, nextRisk] using + (ih result.value.1 nextCandidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hcanonicalValid hcanonicalCompletable) + | inr message => + let nextSelection : DeferredContext → Nat → + (Option Signature × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection) := + fun nextContext remaining value laterCandidates => + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret + (next value.1) laterCandidates nextContext remaining table value.2 + let nextRisk : DeferredContext → Nat → + (Option Signature × SplitHashCache) → ProbComp Bool := + fun nextContext remaining value => + directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter root ftsSecret + target rightRoot (next value.1) candidates nextContext remaining table value.2 + letI : ObserverDooms table nextRisk := ⟨by + intro nextContext remaining value hconsistent hstarts hdoomed + exact directBoundaryPrivateOrdinalFinalizationRisk_dooms ordinal parameter root + ftsSecret target rightRoot (next value.1) candidates nextContext remaining table + value.2 hconsistent hstarts hdoomed⟩ + letI : ObserverSynchronized table nextRisk := ⟨by + intro left right remaining value hcontext hvalues hrevealed + exact directBoundaryPrivateOrdinalFinalizationRisk_synchronized ordinal parameter + root ftsSecret target rightRoot (next value.1) candidates left right remaining table + value.2 hcontext hvalues hrevealed⟩ + letI : ObserverPositionNeutral table nextRisk := ⟨by + intro position nextContext remaining value hnextValid hnextCompletable hensured + exact evalDist_resolveDeferredPositionValue_then_directBoundaryPrivateOrdinalFinalizationRisk + ordinal parameter root ftsSecret target rightRoot position (next value.1) candidates + nextContext remaining table value.2 hnextValid hnextCompletable hensured⟩ + apply relTriple_runWitnessSelection_runResolvedObserve table target rightRoot ordinal + (canonicalizeDirectPrivateOrdinalSelection table nextSelection) + (canonicalizeObserve table nextRisk) candidates context fuel + ((maskedSign parameter root ftsSecret message).run cache) hvalid hcompletable + intro result hresult + have hcore := resolvedCore_of_done_runDirectResolvedDetailedFromTable + ((maskedSign parameter root ftsSecret message).run cache) context fuel table result + hvalid.valuesConsistent (startTableAgrees_of_deferredCompletable hcompletable) + hresult + apply relTriple_canonicalSelection_canonicalObserve table target rightRoot ordinal + nextSelection nextRisk result.context result.remaining result.value candidates + intro _hpublished hcanonicalCompletable + have hcanonicalConsistent := canonicalizeMaterializedValues_valuesConsistent table + result.context hcore.2.1 + have hcanonicalStarts := canonicalizeMaterializedValues_startTableAgrees table + result.context + have hcanonicalValid := valid_of_resolvedCore_completable table + (canonicalizeMaterializedValues table result.context) hcanonicalConsistent + hcanonicalStarts hcanonicalCompletable + simpa [nextSelection, nextRisk] using + (ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hcanonicalValid hcanonicalCompletable) + +noncomputable def granularPrivateOrdinalFinalizationObserve + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rightRoot : Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp Bool := + directBoundaryPrivateOrdinalFinalizationRisk ordinal parameter value.1 ftsSecret target + rightRoot (retainedGameRestComputation adversary ⟨value.1, parameter⟩) [] context fuel + table value.2 + +noncomputable def granularPrivateOrdinalSelectionObserve + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) : + ProbComp (Option PrivateOrdinalSelection) := + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) candidates context fuel table + value.2 + +instance granularPrivateOrdinalFinalizationObserve_observerDooms + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rightRoot : Digest) : + ObserverDooms table + (granularPrivateOrdinalFinalizationObserve ordinal adversary parameter table ftsSecret + target rightRoot) where + eq_true context fuel value hconsistent hstarts hdoomed := by + exact directBoundaryPrivateOrdinalFinalizationRisk_dooms ordinal parameter value.1 ftsSecret + target rightRoot (retainedGameRestComputation adversary ⟨value.1, parameter⟩) [] context + fuel table value.2 hconsistent hstarts hdoomed + +instance granularPrivateOrdinalFinalizationObserve_observerSynchronized + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rightRoot : Digest) : + ObserverSynchronized table + (granularPrivateOrdinalFinalizationObserve ordinal adversary parameter table ftsSecret + target rightRoot) where + eq_of_synchronized left right fuel value hcontext hvalues hrevealed := by + exact directBoundaryPrivateOrdinalFinalizationRisk_synchronized ordinal parameter value.1 + ftsSecret target rightRoot (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + [] left right fuel table value.2 hcontext hvalues hrevealed + +instance granularPrivateOrdinalFinalizationObserve_observerPositionNeutral + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rightRoot : Digest) : + ObserverPositionNeutral table + (granularPrivateOrdinalFinalizationObserve ordinal adversary parameter table ftsSecret + target rightRoot) where + eq_resolve position context fuel value hvalid hcompletable hensured := by + exact evalDist_resolveDeferredPositionValue_then_directBoundaryPrivateOrdinalFinalizationRisk + ordinal parameter value.1 ftsSecret target rightRoot position + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) [] context fuel table value.2 + hvalid hcompletable hensured + +noncomputable def granularAllCanonicalPrivateOrdinalFinalizationRisk + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) (rightRoot : Digest) : ProbComp Bool := + runResolvedObserve + (canonicalizeObserve table + (granularPrivateOrdinalFinalizationObserve ordinal adversary parameter table ftsSecret + target rightRoot)) + emptyWitnessDeferredContext fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +theorem relTriple_granularPrivateOrdinalSelectionObserve_finalizationObserve + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rightRoot : Digest) + (context : DeferredContext) (fuel : Nat) (value : Digest × SplitHashCache) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + RelTriple + (granularPrivateOrdinalSelectionObserve ordinal adversary parameter table ftsSecret + context fuel value []) + (granularPrivateOrdinalFinalizationObserve ordinal adversary parameter table ftsSecret + target rightRoot context fuel value) + (PrivateOrdinalRootRiskRel target rightRoot ordinal) := by + exact relTriple_directBoundaryPrivateOrdinalSelection_finalizationRisk ordinal parameter + value.1 ftsSecret target rightRoot + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) [] context fuel table value.2 + hvalid hcompletable + +theorem relTriple_canonicalGranularPrivateOrdinalSelection_finalizationObserve + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rightRoot : Digest) + (context : DeferredContext) (fuel : Nat) (value : Digest × SplitHashCache) + (hconsistent : context.ValuesConsistent) : + RelTriple + (canonicalizeDirectPrivateOrdinalSelection table + (granularPrivateOrdinalSelectionObserve ordinal adversary parameter table ftsSecret) + context fuel value []) + (canonicalizeObserve table + (granularPrivateOrdinalFinalizationObserve ordinal adversary parameter table ftsSecret + target rightRoot) context fuel value) + (PrivateOrdinalRootRiskRel target rightRoot ordinal) := by + apply relTriple_canonicalSelection_canonicalObserve table target rightRoot ordinal + (granularPrivateOrdinalSelectionObserve ordinal adversary parameter table ftsSecret) + (granularPrivateOrdinalFinalizationObserve ordinal adversary parameter table ftsSecret target + rightRoot) context fuel value [] + intro _hpublished hcanonicalCompletable + have hcanonicalConsistent := canonicalizeMaterializedValues_valuesConsistent table context + hconsistent + have hcanonicalStarts := canonicalizeMaterializedValues_startTableAgrees table context + have hcanonicalValid := valid_of_resolvedCore_completable table + (canonicalizeMaterializedValues table context) hcanonicalConsistent hcanonicalStarts + hcanonicalCompletable + exact relTriple_granularPrivateOrdinalSelectionObserve_finalizationObserve ordinal adversary + parameter table ftsSecret target rightRoot (canonicalizeMaterializedValues table context) fuel + value hcanonicalValid hcanonicalCompletable + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxRecDepth 100000 in +set_option maxHeartbeats 4000000 in +theorem relTriple_granularAllCanonicalPrivateOrdinalSelection_finalizationRisk + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) (rightRoot : Digest) : + RelTriple + (granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret fuel) + (granularAllCanonicalPrivateOrdinalFinalizationRisk ordinal adversary parameter table + ftsSecret fuel target rightRoot) + (PrivateOrdinalRootRiskRel target rightRoot ordinal) := by + unfold granularAllCanonicalPrivateOrdinalSelection + granularAllCanonicalPrivateOrdinalFinalizationRisk + change RelTriple + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) >>= + finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (granularPrivateOrdinalSelectionObserve ordinal adversary parameter table ftsSecret)) []) + (runResolvedObserve + (canonicalizeObserve table + (granularPrivateOrdinalFinalizationObserve ordinal adversary parameter table ftsSecret + target rightRoot)) + emptyWitnessDeferredContext fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)) + (PrivateOrdinalRootRiskRel target rightRoot ordinal) + apply relTriple_runWitnessSelection_runResolvedObserve table target rightRoot ordinal + (canonicalizeDirectPrivateOrdinalSelection table + (granularPrivateOrdinalSelectionObserve ordinal adversary parameter table ftsSecret)) + (canonicalizeObserve table + (granularPrivateOrdinalFinalizationObserve ordinal adversary parameter table ftsSecret target + rightRoot)) [] emptyWitnessDeferredContext fuel + (maskedPublishedTreeRoot.run emptySplitHashCache) DeferredContext.valid_empty + (deferredCompletable_empty table) + intro result hresult + have hcore := resolvedCore_of_done_runDirectResolvedDetailedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) emptyWitnessDeferredContext fuel table result + DeferredContext.valid_empty.valuesConsistent (startTableAgrees_empty table) hresult + exact relTriple_canonicalGranularPrivateOrdinalSelection_finalizationObserve ordinal adversary + parameter table ftsSecret target rightRoot result.context result.remaining result.value + hcore.2.1 + +theorem probEvent_privateOrdinalSelectionGoodForSomeOutput_le_finalizationRisk + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) (rightRoot : Digest) : + Pr[privateOrdinalSelectionGoodForSomeOutput target rightRoot ordinal | + granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret + fuel] ≤ + Pr[= true | granularAllCanonicalPrivateOrdinalFinalizationRisk ordinal adversary parameter + table ftsSecret fuel target rightRoot] := by + calc + _ ≤ Pr[fun hit : Bool => hit = true | + granularAllCanonicalPrivateOrdinalFinalizationRisk ordinal adversary parameter table + ftsSecret fuel target rightRoot] := by + apply probEvent_le_of_relTriple + (relTriple_granularAllCanonicalPrivateOrdinalSelection_finalizationRisk ordinal adversary + parameter table ftsSecret fuel target rightRoot) + intro selection hit hrelation hgood + exact hrelation hgood + _ = _ := probEvent_eq_eq_probOutput _ true + +noncomputable def eagerGranularAllCanonicalPrivateOrdinalFinalizationRisk + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) (rightRoot : Digest) : ProbComp Bool := do + let resolved ← resolveDeferredPositionValue target emptyWitnessDeferredContext + match resolved with + | none => pure true + | some resolved => + runResolvedObserve + (canonicalizeObserve table + (granularPrivateOrdinalFinalizationObserve ordinal adversary parameter table ftsSecret + target rightRoot)) + resolved.toDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + +theorem evalDist_eagerGranularAllCanonicalPrivateOrdinalFinalizationRisk_eq + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) (rightRoot : Digest) : + evalDist (eagerGranularAllCanonicalPrivateOrdinalFinalizationRisk ordinal adversary parameter + table ftsSecret fuel target rightRoot) = + evalDist (granularAllCanonicalPrivateOrdinalFinalizationRisk ordinal adversary parameter + table ftsSecret fuel target rightRoot) := by + unfold eagerGranularAllCanonicalPrivateOrdinalFinalizationRisk + granularAllCanonicalPrivateOrdinalFinalizationRisk + exact evalDist_resolveDeferredPositionValue_then_runResolvedObserve_any target + (maskedPublishedTreeRoot.run emptySplitHashCache) emptyWitnessDeferredContext fuel table + DeferredContext.valid_empty (deferredCompletable_empty table) + +noncomputable def eagerGranularPrivateOrdinalFinalizationRiskAfterOutput + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) (rightRoot : Digest) + (output : HashOutput) : ProbComp Bool := + runResolvedObserve + (canonicalizeObserve table + (granularPrivateOrdinalFinalizationObserve ordinal adversary parameter table ftsSecret + target rightRoot)) + { emptyWitnessDeferredContext with + values := emptyWitnessDeferredContext.values.install target output } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +theorem evalDist_eagerGranularAllCanonicalPrivateOrdinalFinalizationRisk_eq_sample + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) (rightRoot : Digest) : + evalDist (eagerGranularAllCanonicalPrivateOrdinalFinalizationRisk ordinal adversary parameter + table ftsSecret fuel target rightRoot) = + evalDist (LazyRevealProbe.sampleHashOutput >>= fun output => + eagerGranularPrivateOrdinalFinalizationRiskAfterOutput ordinal adversary parameter table + ftsSecret fuel target rightRoot output) := by + unfold eagerGranularAllCanonicalPrivateOrdinalFinalizationRisk + eagerGranularPrivateOrdinalFinalizationRiskAfterOutput + resolveDeferredPositionValue emptyWitnessDeferredContext + simp [LazyRevealProbe.State.empty, LazyRevealProbe.State.hitAt, + LazyRevealProbe.State.pendingAt, LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway, + emptyDeferredStructuralValues] + +theorem evalDist_eagerGranularAllCanonicalPrivateOrdinalFinalizationRisk_eq_rootParts + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) (rightRoot : Digest) : + evalDist (eagerGranularAllCanonicalPrivateOrdinalFinalizationRisk ordinal adversary parameter + table ftsSecret fuel target rightRoot) = + evalDist (do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + eagerGranularPrivateOrdinalFinalizationRiskAfterOutput ordinal adversary parameter table + ftsSecret fuel target rightRoot (rootOutputOfParts leftRoot high)) := by + rw [evalDist_eagerGranularAllCanonicalPrivateOrdinalFinalizationRisk_eq_sample] + let parts : ProbComp HashOutput := do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + pure (rootOutputOfParts leftRoot high) + calc + _ = evalDist (parts >>= fun output => + eagerGranularPrivateOrdinalFinalizationRiskAfterOutput ordinal adversary parameter table + ftsSecret fuel target rightRoot output) := by + rw [evalDist_bind, evalDist_bind, show evalDist parts = + evalDist LazyRevealProbe.sampleHashOutput from evalDist_sample_rootOutputOfParts] + _ = _ := by simp [parts, bind_assoc] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootJoint.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootJoint.lean new file mode 100644 index 00000000..ed2b8790 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootJoint.lean @@ -0,0 +1,822 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootSharedPrefix +import SphincsSecurity.Proof.MarginalCoupling + +/-! +# Joint stopped layer-root endpoint + +The successful stopped diagnostic must remain correlated with the materialized root-selection +outcome. The fixed-target definitions below keep that success gate on the observed run and split the +independent comparison-root exception before the stopped coupling is applied. The older source-only +interface is retained as a conditional endpoint, but it is not used to duplicate a comparison failure +across position fibers. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +noncomputable def observedFirstLayerRootPosition? + (ordinal : Nat) : Option (ObservedCleanRunResult α) → Option Position + | none => none + | some result => + if hselected : ordinal < result.observations.length then + candidateLayerRootPosition? + (result.observations.get ⟨ordinal, hselected⟩).toProbe + else none + +def ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (target : Position) + (observed : Option (ObservedCleanRunResult α)) : Prop := + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt + table ordinal observed ∧ + observedFirstLayerRootPosition? ordinal observed = some target + +theorem successfulDoomedFirstRootHitAtTarget_root + {table : OtsSecretIndex → HashOutput} {ordinal : Nat} {target : Position} + {observed : Option (ObservedCleanRunResult α)} + (hhit : ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed) : + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt + table ordinal observed := + hhit.1 + +theorem observedFirstLayerRootPosition?_eq_some_of_successfulDoomedFirstRoot + {table : OtsSecretIndex → HashOutput} {ordinal : Nat} + {observed : Option (ObservedCleanRunResult α)} + (hhit : ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt + table ordinal observed) : + ∃ target, observedFirstLayerRootPosition? ordinal observed = some target := by + cases observed with + | none => simp [ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hhit + | some result => + obtain ⟨_hfinish, selected, hselected, _hfirst, hroot⟩ := hhit + obtain ⟨target, hcoordinate, htargetRoot⟩ := hroot + have hlt : ordinal < result.observations.length := by + rw [← hselected] + exact selected.isLt + have hindex : (⟨ordinal, hlt⟩ : Fin result.observations.length) = selected := + Fin.ext hselected.symm + refine ⟨target, ?_⟩ + simp only [observedFirstLayerRootPosition?, hlt, ↓reduceDIte] + rw [candidateLayerRootPosition?_eq_some_iff, hindex] + exact ⟨hcoordinate, htargetRoot⟩ + +theorem not_successfulDoomedFirstRoot_of_position_eq_none + {table : OtsSecretIndex → HashOutput} {ordinal : Nat} + {observed : Option (ObservedCleanRunResult α)} + (hposition : observedFirstLayerRootPosition? ordinal observed = none) : + ¬ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt + table ordinal observed := by + intro hhit + obtain ⟨target, htarget⟩ := + observedFirstLayerRootPosition?_eq_some_of_successfulDoomedFirstRoot hhit + rw [hposition] at htarget + simp at htarget + +theorem probEvent_successfulDoomedFirstRoot_le_of_position_fibers + (table : OtsSecretIndex → HashOutput) + (run : ProbComp (Option (ObservedCleanRunResult α))) (ordinal : Nat) + (hfiber : ∀ target, + Pr[fun observed => + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed | run] ≤ + Pr[fun observed => observedFirstLayerRootPosition? ordinal observed = some target | run] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[fun observed => + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt + table ordinal observed | run] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_le_of_uniform_weighted_fibers run + (ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal) + (observedFirstLayerRootPosition? ordinal) + (((2 ^ digestBits : Nat) : ENNReal)⁻¹) + intro position? + cases position? with + | none => + have hzero : Pr[fun observed => + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt + table ordinal observed ∧ + observedFirstLayerRootPosition? ordinal observed = none | run] = 0 := by + apply probEvent_eq_zero + intro observed _hobserved hevent + exact not_successfulDoomedFirstRoot_of_position_eq_none hevent.2 hevent.1 + rw [hzero] + exact zero_le + | some target => exact hfiber target + +def observedPrefixProbes + (ordinal : Nat) : Option (ObservedCleanRunResult α) → List Probe + | none => [] + | some result => + (result.observations.take ordinal).map CleanProbeObservation.toProbe + +def ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (target : Position) (rightRoot : Digest) + (observed : Option (ObservedCleanRunResult α)) : Prop := + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed ∧ + CandidatesAvoidRoot target rightRoot (observedPrefixProbes ordinal observed) + +def ObservedCleanRunOption.SuccessfulFirstRootComparisonExceptionAt + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (target : Position) (rightRoot : Digest) + (observed : Option (ObservedCleanRunResult α)) : Prop := + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed ∧ + ¬CandidatesAvoidRoot target rightRoot (observedPrefixProbes ordinal observed) + +theorem successfulDoomedFirstRootFiber_split_comparison + {table : OtsSecretIndex → HashOutput} {ordinal : Nat} {target : Position} + {rightRoot : Digest} {observed : Option (ObservedCleanRunResult α)} + (hhit : ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed) : + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot observed ∨ + ObservedCleanRunOption.SuccessfulFirstRootComparisonExceptionAt + table ordinal target rightRoot observed := by + by_cases havoid : CandidatesAvoidRoot target rightRoot + (observedPrefixProbes ordinal observed) + · exact Or.inl ⟨hhit, havoid⟩ + · exact Or.inr ⟨hhit, havoid⟩ + +theorem observedPrefixProbes_length_le + (ordinal : Nat) (observed : Option (ObservedCleanRunResult α)) : + (observedPrefixProbes ordinal observed).length ≤ ordinal := by + cases observed with + | none => simp [observedPrefixProbes] + | some result => simp [observedPrefixProbes] + +theorem probEvent_successfulDoomedFirstRootComparisonExceptionAt_le + (table : OtsSecretIndex → HashOutput) + (run : ProbComp (Option (ObservedCleanRunResult α))) + (ordinal : Nat) (target : Position) : + Pr[fun result : Option (ObservedCleanRunResult α) × Digest => + ObservedCleanRunOption.SuccessfulFirstRootComparisonExceptionAt + table ordinal target result.2 result.1 | do + let observed ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] ≤ + Pr[fun observed => ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed | run] * + ((ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + let gate := fun observed : Option (ObservedCleanRunResult α) => + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed + let values := fun observed : Option (ObservedCleanRunResult α) => + (observedPrefixProbes ordinal observed).map Probe.candidate + calc + _ ≤ Pr[fun result : Option (ObservedCleanRunResult α) × Digest => + gate result.1 ∧ result.2 ∈ values result.1 | do + let observed ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] := by + apply probEvent_mono + intro result _hresult hexception + exact ⟨hexception.1, + not_candidatesAvoidRoot_mem_candidate_map hexception.2⟩ + _ ≤ Pr[gate | run] * + ((ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply probEvent_gate_and_uniformDigest_mem_list_le run gate values ordinal + intro observed _hobserved _hgate + simpa [values] using observedPrefixProbes_length_le ordinal observed + _ = _ := rfl + +theorem probEvent_successfulDoomedFirstRootFiber_le_goodComparison_add_weightedException + (table : OtsSecretIndex → HashOutput) + (run : ProbComp (Option (ObservedCleanRunResult α))) + (ordinal : Nat) (target : Position) : + Pr[fun observed => ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed | run] ≤ + Pr[fun result : Option (ObservedCleanRunResult α) × Digest => + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] + + Pr[fun observed => ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed | run] * + ((ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + let paired : ProbComp (Option (ObservedCleanRunResult α) × Digest) := do + let observed ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot) + calc + _ ≤ Pr[fun result => + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 ∨ + ObservedCleanRunOption.SuccessfulFirstRootComparisonExceptionAt + table ordinal target result.2 result.1 | paired] := by + apply probEvent_le_of_relTriple (relTriple_pair_uniform_right run) + intro observed result hrelation hhit + rw [← hrelation] + exact successfulDoomedFirstRootFiber_split_comparison hhit + _ ≤ Pr[fun result => + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | paired] + + Pr[fun result => + ObservedCleanRunOption.SuccessfulFirstRootComparisonExceptionAt + table ordinal target result.2 result.1 | paired] := probEvent_or_le _ _ _ + _ ≤ _ := add_le_add_right + (probEvent_successfulDoomedFirstRootComparisonExceptionAt_le + table run ordinal target) _ + +theorem SnapshotObservedFirstStoppedRel.cleanRootGoodForComparisonAt_of_successful + {table : OtsSecretIndex → HashOutput} {ordinal : Nat} {target : Position} + {source : PrivateWitnessSnapshotOutput} + {observed : Option (ObservedCleanRunResult (α × SplitHashCache))} + {rightRoot : Digest} + (hrelation : SnapshotObservedFirstStoppedRel table source observed) + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot observed) : + SelectedPrivateSnapshotCleanRootGoodForComparisonAt + table source ordinal target rightRoot := by + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hgood + | some result => + obtain ⟨⟨⟨⟨finalResult, hfinish⟩, + selected, hselected, hfirst, hroot⟩, hposition⟩, hcomparison⟩ := hgood + rcases hrelation.selectedAligned_or_chain_of_successful_firstHit + finalResult hfinish ordinal hfirst with ⟨hhit, haligned⟩ | hchain + · have hclean := hrelation.selectedCleanRoot_of_successful_firstRoot + finalResult hfinish ordinal selected hselected hfirst hroot + obtain ⟨sourceSelected, sourceTarget, output, hsourceSelected, hselection, + hactual, hsourceRoot, hsourceClean⟩ := hclean + obtain ⟨alignedSource, alignedObserved, halignedSource, halignedObserved, + hcandidates, hprefix, _hsnapshots⟩ := haligned + have hsourceEq : sourceSelected = alignedSource := + Fin.ext (hsourceSelected.trans halignedSource.symm) + have hobservedEq : alignedObserved = selected := + Fin.ext (halignedObserved.trans hselected.symm) + have hselectedLt : ordinal < result.observations.length := by + rw [← hselected] + exact selected.isLt + have hselectedIndex : + (⟨ordinal, hselectedLt⟩ : Fin result.observations.length) = selected := + Fin.ext hselected.symm + have htargetData : + (result.observations.get selected).coordinate = .position target ∧ + IsLayerRoot target := by + simp only [observedFirstLayerRootPosition?, hselectedLt, ↓reduceDIte] at hposition + rw [candidateLayerRootPosition?_eq_some_iff, hselectedIndex] at hposition + exact hposition + have htarget : sourceTarget = target := by + have hsourceCoordinate : + (source.2.get sourceSelected).probe.coordinate = .position sourceTarget := by + have hcandidate := congrArg Probe.coordinate hactual.1 + simpa using hcandidate + have halignedCoordinate : + (source.2.get alignedSource).probe.coordinate = + (result.observations.get alignedObserved).coordinate := by + exact congrArg Probe.coordinate hcandidates + rw [hsourceEq, halignedCoordinate, hobservedEq, htargetData.1] at hsourceCoordinate + exact (Coordinate.position.inj hsourceCoordinate).symm + subst sourceTarget + have hsourceComparison : CandidatesAvoidRoot target rightRoot + ((privateOrdinalSelectionOfSnapshot sourceSelected).candidates.take ordinal) := by + rw [← hsourceSelected, + privateOrdinalSelectionOfSnapshot_candidates_take, hsourceSelected] + rw [hprefix] + simpa [observedPrefixProbes, List.map_take] using hcomparison + exact ⟨sourceSelected, output, hsourceSelected, hselection, hactual, + hsourceRoot, hsourceClean, hsourceComparison⟩ + · exact (not_firstExistingHiddenRootHitAt_of_firstChainStart hchain hfirst selected + hselected hroot).elim + +def SuccessfulObservedCleanRootRel + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (target : Position) : + (PrivateWitnessSnapshotOutput × Digest) → + (Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest) → Prop := + fun source observed => + source.2 = observed.2 ∧ + (ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target observed.2 observed.1 → + SelectedPrivateSnapshotCleanRootGoodForComparisonAt + table source.1 ordinal target source.2) + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_snapshotComparison_observedSuccessfulRootComparison + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + RelTriple + (do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret q + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)) + (do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)) + (SuccessfulObservedCleanRootRel table ordinal target) := by + apply relTriple_bind + (relTriple_granularAllSnapshot_observedMaterializedRetained_firstStopped adversary parameter + ftsSecret q table hbound hq) + intro source observed hrelation + apply relTriple_bind (relTriple_refl ($ᵗ Digest : ProbComp Digest)) + intro leftRoot rightRoot hroot + subst rightRoot + apply relTriple_pure_pure + refine ⟨rfl, ?_⟩ + intro hgood + exact hrelation.cleanRootGoodForComparisonAt_of_successful hgood + +def SuccessfulObservedPendingSelectorRel + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (target : Position) : + (Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest) → + (Option PrivateOrdinalSelection × Digest) → Prop := + fun observed selection => + ∃ source : PrivateWitnessSnapshotOutput × Digest, + SuccessfulObservedCleanRootRel table ordinal target source observed ∧ + (SnapshotOrdinalSelectionRel ordinal source.1 selection.1 ∧ + source.2 = selection.2) ∧ + PrivateOrdinalSelectionPendingCovered ordinal selection.1 + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_snapshotComparison_privateOrdinalSelectionComparison_pendingCovered + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + RelTriple + (do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret fuel + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)) + (do + let selection ← granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter + table ftsSecret fuel + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot)) + (fun left right => + (SnapshotOrdinalSelectionRel ordinal left.1 right.1 ∧ left.2 = right.2) ∧ + PrivateOrdinalSelectionPendingCovered ordinal right.1) := by + apply relTriple_bind + (relTriple_granularAllCanonicalSnapshot_privateOrdinalSelection_pendingCovered ordinal adversary + parameter table ftsSecret fuel) + intro source selection hselection + apply relTriple_bind (relTriple_refl ($ᵗ Digest : ProbComp Digest)) + intro leftRoot rightRoot hroot + subst rightRoot + exact relTriple_pure_pure ⟨⟨hselection.1, rfl⟩, hselection.2⟩ + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_observedSuccessfulRootComparison_pendingSelector + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + RelTriple + (do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)) + (do + let selection ← granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table + ftsSecret q + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot)) + (SuccessfulObservedPendingSelectorRel table ordinal target) := by + have hobserved := relTriple_snapshotComparison_observedSuccessfulRootComparison ordinal adversary + parameter table ftsSecret q target hbound hq + have hselection := + relTriple_snapshotComparison_privateOrdinalSelectionComparison_pendingCovered ordinal adversary + parameter table ftsSecret q + have hglued := SphincsSecurity.relTriple_trans_exists (relTriple_symm hobserved) + hselection + apply relTriple_post_mono hglued + intro observed selection hrelation + obtain ⟨source, hsource, hselection⟩ := hrelation + exact ⟨source, hsource, hselection.1, hselection.2⟩ + +theorem SuccessfulObservedPendingSelectorRel.goodForRoots_pendingCovered + {table : OtsSecretIndex → HashOutput} {ordinal : Nat} {target : Position} + {observed : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest} + {selection : Option PrivateOrdinalSelection × Digest} + (hrelation : SuccessfulObservedPendingSelectorRel table ordinal target observed selection) + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target observed.2 observed.1) : + ∃ selected output, + selection.1 = some selected ∧ + selected.GoodForRoots target output selection.2 ordinal ∧ + PrivateOrdinalSelectionPendingCovered ordinal selection.1 := by + obtain ⟨source, hsource, hselection, hpending⟩ := hrelation + have hsourceGood := hsource.2 hgood + obtain ⟨selectedIndex, output, _hordinal, hselected, hgoodRoots⟩ := + hsourceGood.goodForRoots + have hselectionEq : selection.1 = + some (privateOrdinalSelectionOfSnapshot selectedIndex) := + hselection.1.symm.trans hselected + refine ⟨privateOrdinalSelectionOfSnapshot selectedIndex, output, hselectionEq, ?_, ?_⟩ + · rw [← hselection.2] + exact hgoodRoots + · exact hpending + +theorem probEvent_observedSuccessfulRootComparison_le_snapshotComparison + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest => + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] ≤ + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + SelectedPrivateSnapshotCleanRootGoodForComparisonAt + table result.1 ordinal target result.2 | do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret q + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] := by + apply probEvent_le_of_relTriple + (relTriple_symm + (relTriple_snapshotComparison_observedSuccessfulRootComparison ordinal adversary parameter + table ftsSecret q target hbound hq)) + intro observed source hrelation hgood + exact hrelation.2 hgood + +def SuccessfulObservedRootMaterializedMatchRel + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (target : Position) : + (Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest) → + (Digest × Digest × MaterializedSelectionOutcome) → Prop := + fun observed outcome => + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target observed.2 observed.1 → + outcome.2.2.Matches target outcome.1 + +theorem probEvent_observedSuccessfulRootComparison_le_materializedMatch + (table : OtsSecretIndex → HashOutput) + (observed : ProbComp + (Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)))) + (outcome : ProbComp (Digest × Digest × MaterializedSelectionOutcome)) + (ordinal : Nat) (target : Position) + (hrel : RelTriple + (do + let result ← observed + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (result, rightRoot)) + outcome (SuccessfulObservedRootMaterializedMatchRel table ordinal target)) : + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest => + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let result ← observed + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (result, rightRoot)] ≤ + Pr[fun result => result.2.2.Matches target result.1 | outcome] := by + apply probEvent_le_of_relTriple hrel + intro left right hrelation hgood + exact hrelation hgood + +theorem probEvent_observedSuccessfulRootComparison_le_production_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (hrel : RelTriple + (do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)) + (materializedRootOrdinalOutcomeExperimentAfterTable ordinal adversary parameter ftsSecret + target q table) + (SuccessfulObservedRootMaterializedMatchRel table ordinal target)) : + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest => + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] ≤ + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + materializedRootOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target q table] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ Pr[fun result => result.2.2.Matches target result.1 | + materializedRootOrdinalOutcomeExperimentAfterTable ordinal adversary parameter + ftsSecret target q table] := + probEvent_observedSuccessfulRootComparison_le_materializedMatch table + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table) + (materializedRootOrdinalOutcomeExperimentAfterTable ordinal adversary parameter ftsSecret + target q table) ordinal target hrel + _ ≤ _ := probEvent_materializedRootOrdinalOutcome_match_le ordinal adversary parameter + ftsSecret target hroot hparent q table + +def CleanRootMaterializedMatchRel + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (target : Position) : + (PrivateWitnessSnapshotOutput × Digest) → + (Digest × Digest × MaterializedSelectionOutcome) → Prop := + fun source outcome => + SelectedPrivateSnapshotCleanRootGoodForComparisonAt + table source.1 ordinal target source.2 → + outcome.2.2.Matches target outcome.1 + +theorem not_target_hitAt_of_goodForRoots_of_pendingCovered + {target : Position} {leftOutput : HashOutput} {rightRoot : Digest} + {ordinal : Nat} {selection : PrivateOrdinalSelection} + (hgood : selection.GoodForRoots target leftOutput rightRoot ordinal) + (hcovered : PendingCoveredBy (selection.candidates.take ordinal) selection.context) : + ¬selection.context.state.hitAt (.position target) leftOutput := by + intro hhit + have hpending : (Coordinate.position target, truncateHash leftOutput) ∈ + selection.context.state.pending := by + rw [← LazyRevealProbe.State.mem_pendingAt_iff] + exact hhit + obtain ⟨candidate, hcandidate, hcoordinate, hdigest⟩ := hcovered _ hpending + have havoid := hgood.2.2.2.2 candidate hcandidate + apply havoid.1 + cases candidate + simp only [Probe.mk.injEq] + exact ⟨hcoordinate, hdigest⟩ + +theorem resolveDeferredPositionValue_eq_good_output + {target : Position} {leftOutput : HashOutput} {rightRoot : Digest} + {ordinal : Nat} {selection : PrivateOrdinalSelection} + (hgood : selection.GoodForRoots target leftOutput rightRoot ordinal) + (hcovered : PendingCoveredBy (selection.candidates.take ordinal) selection.context) : + resolveDeferredPositionValue target selection.context = + pure (some (DeferredResolution.mk + { state := selection.context.state.clearPending (.position target) + values := selection.context.values } + leftOutput)) := by + rw [resolveDeferredPositionValue_of_deferred_value target selection.context leftOutput + hgood.2.1 hgood.2.2.2.1] + simp [not_target_hitAt_of_goodForRoots_of_pendingCovered hgood hcovered] + +def PrivateOrdinalGoodRel + (target : Position) (rightRoot : Digest) (ordinal : Nat) : + Option PrivateOrdinalSelection → Option PrivateOrdinalSelection → Prop := + fun left right => + privateOrdinalSelectionGoodForSomeOutput target rightRoot ordinal left → + privateOrdinalSelectionGoodForSomeOutput target rightRoot ordinal right + +theorem goodForRoots_clearPending_target + {target : Position} {leftOutput : HashOutput} {rightRoot : Digest} + {ordinal : Nat} {selection : PrivateOrdinalSelection} + (hgood : selection.GoodForRoots target leftOutput rightRoot ordinal) : + ({ selection with + context := { selection.context with + state := selection.context.state.clearPending (.position target) } } : + PrivateOrdinalSelection).GoodForRoots target leftOutput rightRoot ordinal := by + rcases hgood with ⟨hcandidate, hstate, hrevealed, hvalue, havoid⟩ + exact ⟨hcandidate, by simpa [LazyRevealProbe.State.clearPending] using hstate, + by simpa [LazyRevealProbe.State.clearPending] using hrevealed, hvalue, havoid⟩ + +theorem relTriple_goodSelection_resolveDeferredPositionValue + (target : Position) (rightRoot : Digest) (ordinal : Nat) + (selection : PrivateOrdinalSelection) + (hcovered : PendingCoveredBy (selection.candidates.take ordinal) selection.context) : + RelTriple + (pure (some selection) : ProbComp (Option PrivateOrdinalSelection)) + (resolveDeferredPositionValue target selection.context >>= fun resolved => + match resolved with + | none => pure none + | some resolved => pure (some + { selection with context := resolved.toDeferredContext })) + (PrivateOrdinalGoodRel target rightRoot ordinal) := by + by_cases hgood : privateOrdinalSelectionGoodForSomeOutput target rightRoot ordinal (some selection) + · obtain ⟨leftOutput, hgood⟩ := hgood + rw [resolveDeferredPositionValue_eq_good_output hgood hcovered] + simp only [pure_bind] + apply relTriple_pure_pure + intro _hleft + exact ⟨leftOutput, by + simpa [DeferredResolution.toDeferredContext] using goodForRoots_clearPending_target hgood⟩ + · apply relTriple_post_mono + (SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + (relTriple_true + (pure (some selection) : ProbComp (Option PrivateOrdinalSelection)) + (show ProbComp (Option PrivateOrdinalSelection) from + resolveDeferredPositionValue target selection.context >>= fun resolved => + match resolved with + | none => pure none + | some resolved => pure (some + { selection with context := resolved.toDeferredContext }))) + (fun left => left = some selection) (by intro left hleft; simpa using hleft)) + intro left _right _hrelation hleft + exact (hgood (_hrelation.2 ▸ hleft)).elim + +noncomputable def resolvePrivateOrdinalSelection + (target : Position) : Option PrivateOrdinalSelection → + ProbComp (Option PrivateOrdinalSelection) + | none => pure none + | some selection => + resolveDeferredPositionValue target selection.context >>= fun resolved => + match resolved with + | none => pure none + | some resolved => pure (some + { selection with context := resolved.toDeferredContext }) + +theorem relTriple_privateOrdinalSelection_resolve + (target : Position) (rightRoot : Digest) (ordinal : Nat) + (selection : Option PrivateOrdinalSelection) + (hcovered : PrivateOrdinalSelectionPendingCovered ordinal selection) : + RelTriple + (pure selection : ProbComp (Option PrivateOrdinalSelection)) + (resolvePrivateOrdinalSelection target selection) + (fun left right => + PrivateOrdinalGoodRel target rightRoot ordinal left right ∧ left = selection) := by + apply SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + · cases selection with + | none => + exact relTriple_pure_pure (fun hgood => False.elim hgood) + | some selection => + exact relTriple_goodSelection_resolveDeferredPositionValue target rightRoot ordinal + selection hcovered + · intro left hleft + simpa using hleft + +def SuccessfulObservedResolvedSelectorRel + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (target : Position) : + (Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest) → + (Option PrivateOrdinalSelection × Digest) → Prop := + fun observed resolved => + ∃ selection : Option PrivateOrdinalSelection × Digest, + SuccessfulObservedPendingSelectorRel table ordinal target observed selection ∧ + PrivateOrdinalGoodRel target selection.2 ordinal selection.1 resolved.1 ∧ + selection.2 = resolved.2 + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_observedSuccessfulRootComparison_resolvedSelector + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + RelTriple + (do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)) + (do + let selection ← granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter + table ftsSecret q + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let resolved ← resolvePrivateOrdinalSelection target selection + pure (resolved, rightRoot)) + (SuccessfulObservedResolvedSelectorRel table ordinal target) := by + have hbase := relTriple_observedSuccessfulRootComparison_pendingSelector ordinal adversary + parameter table ftsSecret q target hbound hq + have hboundPair : RelTriple + ((do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)) >>= fun observed => pure observed) + ((do + let selection ← granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter + table ftsSecret q + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot)) >>= fun selection => do + let resolved ← resolvePrivateOrdinalSelection target selection.1 + pure (resolved, selection.2)) + (SuccessfulObservedResolvedSelectorRel table ordinal target) := by + apply relTriple_bind hbase + intro observed selection hrelation + obtain ⟨source, hsource, hselection, hpending⟩ := hrelation + have hinner : RelTriple + ((pure selection.1 : ProbComp (Option PrivateOrdinalSelection)) >>= fun _ => pure observed) + (resolvePrivateOrdinalSelection target selection.1 >>= fun resolved => + pure (resolved, selection.2)) + (SuccessfulObservedResolvedSelectorRel table ordinal target) := by + apply relTriple_bind + (relTriple_privateOrdinalSelection_resolve target selection.2 ordinal selection.1 + hpending) + intro original resolved hresolved + have hgoodRel : PrivateOrdinalGoodRel target selection.2 ordinal selection.1 resolved := by + rw [← hresolved.2] + exact hresolved.1 + exact relTriple_pure_pure + ⟨selection, ⟨source, hsource, hselection, hpending⟩, hgoodRel, rfl⟩ + simpa using hinner + simpa [bind_assoc] using hboundPair + +theorem SuccessfulObservedResolvedSelectorRel.goodForRoots + {table : OtsSecretIndex → HashOutput} {ordinal : Nat} {target : Position} + {observed : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest} + {resolved : Option PrivateOrdinalSelection × Digest} + (hrelation : SuccessfulObservedResolvedSelectorRel table ordinal target observed resolved) + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target observed.2 observed.1) : + privateOrdinalSelectionGoodForSomeOutput target resolved.2 ordinal resolved.1 := by + obtain ⟨selection, hselection, hresolved, hroot⟩ := hrelation + obtain ⟨selected, output, hselected, hgoodRoots, _hcovered⟩ := + hselection.goodForRoots_pendingCovered hgood + rw [← hroot] + exact hresolved (by rw [hselected]; exact ⟨output, hgoodRoots⟩) + +theorem probEvent_cleanRootGoodForComparison_le_materializedMatch + (table : OtsSecretIndex → HashOutput) + (source : ProbComp PrivateWitnessSnapshotOutput) + (outcome : ProbComp (Digest × Digest × MaterializedSelectionOutcome)) + (ordinal : Nat) (target : Position) + (hrel : RelTriple + (do + let result ← source + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (result, rightRoot)) + outcome (CleanRootMaterializedMatchRel table ordinal target)) : + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + SelectedPrivateSnapshotCleanRootGoodForComparisonAt + table result.1 ordinal target result.2 | do + let result ← source + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (result, rightRoot)] ≤ + Pr[fun result => result.2.2.Matches target result.1 | outcome] := by + apply probEvent_le_of_relTriple hrel + intro left right hrelation hgood + exact hrelation hgood + +theorem probEvent_cleanRootGoodForComparison_le_production_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) + (hrel : RelTriple + (do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret fuel + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)) + (materializedRootOrdinalOutcomeExperimentAfterTable ordinal adversary parameter ftsSecret + target fuel table) + (CleanRootMaterializedMatchRel table ordinal target)) : + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + SelectedPrivateSnapshotCleanRootGoodForComparisonAt + table result.1 ordinal target result.2 | do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret fuel + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] ≤ + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + materializedRootOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ Pr[fun result => result.2.2.Matches target result.1 | + materializedRootOrdinalOutcomeExperimentAfterTable ordinal adversary parameter ftsSecret + target fuel table] := + probEvent_cleanRootGoodForComparison_le_materializedMatch table + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel) + (materializedRootOrdinalOutcomeExperimentAfterTable ordinal adversary parameter ftsSecret + target fuel table) ordinal target hrel + _ ≤ _ := probEvent_materializedRootOrdinalOutcome_match_le ordinal adversary parameter ftsSecret + target hroot hparent fuel table + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEager.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEager.lean new file mode 100644 index 00000000..03aa3687 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEager.lean @@ -0,0 +1,580 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareSharedSemantic +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerObservation +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerState +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerSuffix +import SphincsSecurity.Proof.OtsProbeResolvedPrivateRetainedCommutation +import VCVio.OracleComp.EvalDist + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +def RawObservedPendingSelectorRel + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) : + (Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest) → + (Option PrivateOrdinalSelection × Digest) → Prop := + fun observed selection ↦ + ∃ source : PrivateWitnessSnapshotOutput × Digest, + source.2 = observed.2 ∧ + SnapshotObservedFirstStoppedRel table source.1 observed.1 ∧ + SnapshotOrdinalSelectionRel ordinal source.1 selection.1 ∧ + source.2 = selection.2 ∧ + PrivateOrdinalSelectionPendingCovered ordinal selection.1 + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_observedRootComparison_privateOrdinalSelection_raw + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + RelTriple + (do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)) + (do + let selection ← granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter + table ftsSecret q + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot)) + (RawObservedPendingSelectorRel table ordinal) := by + have hsourceObserved : RelTriple + (do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret q + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)) + (do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)) + (fun source observed ↦ source.2 = observed.2 ∧ + SnapshotObservedFirstStoppedRel table source.1 observed.1) := by + apply relTriple_bind + (relTriple_granularAllSnapshot_observedMaterializedRetained_firstStopped adversary + parameter ftsSecret q table hbound hq) + intro source observed hrelation + apply relTriple_bind (relTriple_refl ($ᵗ Digest : ProbComp Digest)) + intro leftRoot rightRoot hroot + subst rightRoot + exact relTriple_pure_pure ⟨rfl, hrelation⟩ + have hsourceSelection := + relTriple_snapshotComparison_privateOrdinalSelectionComparison_pendingCovered ordinal + adversary parameter table ftsSecret q + have hglued := SphincsSecurity.relTriple_trans_exists (relTriple_symm hsourceObserved) + hsourceSelection + apply relTriple_post_mono hglued + intro observed selection hrelation + obtain ⟨source, hsource, hselection⟩ := hrelation + exact ⟨source, hsource.1, hsource.2, hselection.1.1, hselection.1.2, + hselection.2⟩ + +def RawObservedResolvedSelectorRel + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (target : Position) : + (Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest) → + (Option PrivateOrdinalSelection × Digest) → Prop := + fun observed resolved ↦ + ∃ selection : Option PrivateOrdinalSelection × Digest, + RawObservedPendingSelectorRel table ordinal observed selection ∧ + PrivateOrdinalGoodRel target selection.2 ordinal selection.1 resolved.1 ∧ + selection.2 = resolved.2 + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_observedRootComparison_resolvedSelector_raw + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + RelTriple + (do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)) + (do + let selection ← granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter + table ftsSecret q + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let resolved ← resolvePrivateOrdinalSelection target selection + pure (resolved, rightRoot)) + (RawObservedResolvedSelectorRel table ordinal target) := by + have hbase := relTriple_observedRootComparison_privateOrdinalSelection_raw ordinal adversary + parameter table ftsSecret q hbound hq + have hboundPair : RelTriple + ((do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)) >>= pure) + ((do + let selection ← granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter + table ftsSecret q + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot)) >>= fun selection ↦ do + let resolved ← resolvePrivateOrdinalSelection target selection.1 + pure (resolved, selection.2)) + (RawObservedResolvedSelectorRel table ordinal target) := by + apply relTriple_bind hbase + intro observed selection hrelation + obtain ⟨source, hsourceRoot, hsourceObserved, hsourceSelection, hselectionRoot, + hpending⟩ := hrelation + have hinner : RelTriple + ((pure selection.1 : ProbComp (Option PrivateOrdinalSelection)) >>= fun _ ↦ + pure observed) + (resolvePrivateOrdinalSelection target selection.1 >>= fun resolved ↦ + pure (resolved, selection.2)) + (RawObservedResolvedSelectorRel table ordinal target) := by + apply relTriple_bind + (relTriple_privateOrdinalSelection_resolve target selection.2 ordinal selection.1 hpending) + intro original resolved hresolved + have hgoodRel : PrivateOrdinalGoodRel target selection.2 ordinal selection.1 resolved := by + rw [← hresolved.2] + exact hresolved.1 + exact relTriple_pure_pure + ⟨selection, + ⟨source, hsourceRoot, hsourceObserved, hsourceSelection, hselectionRoot, hpending⟩, + hgoodRel, rfl⟩ + simpa using hinner + simpa [bind_assoc] using hboundPair + +theorem RawObservedPendingSelectorRel.data_of_good + {table : OtsSecretIndex → HashOutput} {ordinal : Nat} {target : Position} + {result : ObservedCleanRunResult (RetainedGameResult × SplitHashCache)} + {rightRoot : Digest} {selection : Option PrivateOrdinalSelection × Digest} + (hrelation : RawObservedPendingSelectorRel table ordinal (some result, rightRoot) selection) + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result)) : + ∃ selected output, + selection.1 = some selected ∧ + selected.GoodForRoots target output selection.2 ordinal ∧ + PendingCoveredBy (selected.candidates.take ordinal) selected.context ∧ + (∀ observed : Fin result.observations.length, + observed.val = ordinal → + (result.observations.get observed).coordinate = .position target ∧ + (result.observations.get observed).revealedAtProbe = false ∧ + truncateHash output = (result.observations.get observed).candidate) ∧ + (∀ earlier : Fin result.observations.length, + earlier.val < ordinal → + (result.observations.get earlier).toProbe ≠ + ⟨.position target, truncateHash output⟩) ∧ + IsLayerRoot target := by + obtain ⟨source, hsourceRoot, hsourceObserved, hsourceSelection, hselectionRoot, + hpending⟩ := hrelation + have hsourceGood := hsourceObserved.cleanRootGoodForComparisonAt_of_successful hgood + obtain ⟨sourceSelected, output, hsourceOrdinal, hselectedSource, hgoodRoots⟩ := + hsourceGood.goodForRoots + have hselection : selection.1 = + some (privateOrdinalSelectionOfSnapshot sourceSelected) := by + rw [← hsourceSelection, hselectedSource] + let selected := privateOrdinalSelectionOfSnapshot sourceSelected + have hselectedGood : selected.GoodForRoots target output selection.2 ordinal := by + rw [← hselectionRoot, hsourceRoot] + exact hgoodRoots + have hcovered : PendingCoveredBy (selected.candidates.take ordinal) selected.context := by + rw [hselection] at hpending + exact hpending + have hgoodData := hgood + obtain ⟨⟨⟨⟨finalResult, hfinish⟩, + observedSelected, hobservedOrdinal, hfirst, hobservedRoot⟩, hposition⟩, + _hcomparison⟩ := hgoodData + rcases hsourceObserved.selectedAligned_or_chain_of_successful_firstHit + finalResult hfinish ordinal hfirst with halignedData | hchain + · obtain ⟨_hsourceHit, haligned⟩ := halignedData + obtain ⟨alignedSource, alignedObserved, halignedSource, halignedObserved, + hcandidates, hprefix, _hsnapshots⟩ := haligned + have hsourceEq : alignedSource = sourceSelected := + Fin.ext (halignedSource.trans hsourceOrdinal.symm) + have hobservedEq : alignedObserved = observedSelected := + Fin.ext (halignedObserved.trans hobservedOrdinal.symm) + have hselectedLt : ordinal < result.observations.length := by + rw [← hobservedOrdinal] + exact observedSelected.isLt + have hselectedIndex : + (⟨ordinal, hselectedLt⟩ : Fin result.observations.length) = observedSelected := + Fin.ext hobservedOrdinal.symm + have htargetData : + (result.observations.get observedSelected).coordinate = .position target ∧ + IsLayerRoot target := by + simp only [observedFirstLayerRootPosition?, hselectedLt, ↓reduceDIte] at hposition + rw [candidateLayerRootPosition?_eq_some_iff, hselectedIndex] at hposition + exact hposition + have hselectedDigest : truncateHash output = + (result.observations.get observedSelected).candidate := by + have hcandidate := hselectedGood.1 + rw [privateOrdinalSelectionOfSnapshot_candidate] at hcandidate + have hsourceCandidate : (source.1.2.get sourceSelected).probe = + ⟨.position target, truncateHash output⟩ := by + simpa [snapshotProbeOrdinal] using hcandidate + have halignedCandidate : (source.1.2.get alignedSource).probe = + (result.observations.get alignedObserved).toProbe := hcandidates + rw [hsourceEq, hsourceCandidate, hobservedEq] at halignedCandidate + simpa [CleanProbeObservation.toProbe] using congrArg Probe.candidate halignedCandidate + have hselectedHidden : + (result.observations.get observedSelected).revealedAtProbe = false := by + obtain ⟨_firstSelected, _hfirstOrdinal, hhit, _hbefore⟩ := hfirst + have hsame : _firstSelected = observedSelected := + Fin.ext (_hfirstOrdinal.trans hobservedOrdinal.symm) + subst _firstSelected + exact hhit.1 + refine ⟨selected, output, hselection, hselectedGood, hcovered, ?_, ?_, + htargetData.2⟩ + · intro observed hobserved + have heq : observed = observedSelected := + Fin.ext (hobserved.trans hobservedOrdinal.symm) + subst observed + exact ⟨htargetData.1, hselectedHidden, hselectedDigest⟩ + · intro earlier hearlier heq + have hprefixAvoid := hselectedGood.2.2.2.2 + have hobservationMem : (result.observations.get earlier).toProbe ∈ + (result.observations.map CleanProbeObservation.toProbe).take ordinal := by + rw [List.mem_iff_get] + let index : Fin + ((result.observations.map CleanProbeObservation.toProbe).take ordinal).length := + ⟨earlier.val, by simp [hearlier]⟩ + refine ⟨index, ?_⟩ + simp [index] + have hselectedMem : (result.observations.get earlier).toProbe ∈ + selected.candidates.take ordinal := by + change (result.observations.get earlier).toProbe ∈ + (privateOrdinalSelectionOfSnapshot sourceSelected).candidates.take ordinal + rw [← hsourceOrdinal, + privateOrdinalSelectionOfSnapshot_candidates_take, hsourceOrdinal, hprefix] + exact hobservationMem + exact (hprefixAvoid _ hselectedMem).1 heq + · exact (not_firstExistingHiddenRootHitAt_of_firstChainStart hchain hfirst observedSelected + hobservedOrdinal hobservedRoot).elim + +noncomputable def resolvedEagerObservedRootComparisonAfterRootResult + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp + (Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest) := do + let resolved ← resolveDeferredPositionValue target (directDeferredContext rootResult.state) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + match resolved with + | none => pure (none, rightRoot) + | some resolved => do + let observed ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState resolved.toDeferredContext) rootResult.remaining rootResult.table + (replaceHiddenRootCache target resolved.output rootResult.value.2) + pure (retainObservedRoot rootResult.value.1 observed, rightRoot) + +theorem evalDist_resolvedEagerObservedRootComparisonAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) + (habsent : rootResult.state.values (.position target) = none) + (hpending : rootResult.state.pending = ∅) : + evalDist + (resolvedEagerObservedRootComparisonAfterRootResult adversary parameter ftsSecret target + rootResult) = + evalDist ((fun sampled => (sampled.2.2, sampled.2.1)) <$> + sampledHighEagerObservedRootAwareAfterRootResult ordinal adversary parameter ftsSecret + target rootResult) := by + unfold resolvedEagerObservedRootComparisonAfterRootResult + rw [resolveDeferredPositionValue_fresh target (directDeferredContext rootResult.state)] + · have hhit : ∀ output, ¬rootResult.state.hitAt (.position target) output := by + intro output + simp [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, hpending] + simp only [directDeferredContext, hhit, ↓reduceIte] + unfold sampledHighEagerObservedRootAwareAfterRootResult + simp only [map_eq_bind_pure_comp, bind_assoc] + simp only [pure_bind] + have hclear : rootResult.state.clearPending (.position target) = rootResult.state := by + rcases hstate : rootResult.state with ⟨pending, values, revealed, ensured⟩ + simp only [LazyRevealProbe.State.clearPending] + have hp : pending = ∅ := by simpa only [hstate] using hpending + simp [LazyRevealProbe.State.pendingAway, hp] + rw [hclear] + unfold rootInstalledCache + let parts : ProbComp HashOutput := do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let root ← ($ᵗ Digest : ProbComp Digest) + pure (rootOutputOfParts root high) + have hparts : evalDist parts = evalDist LazyRevealProbe.sampleHashOutput := by + calc + _ = evalDist (do + let root ← ($ᵗ Digest : ProbComp Digest) + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + pure (rootOutputOfParts root high)) := by + exact OracleComp.DeferredSampling.evalDist_bind_comm + ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + ($ᵗ Digest : ProbComp Digest) + (fun high root => pure (rootOutputOfParts root high)) + _ = _ := evalDist_sample_rootOutputOfParts + let continuation := fun output : HashOutput => do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let observed ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState + { state := rootResult.state + values := (directDeferredValues rootResult.state).install target output }) + rootResult.remaining rootResult.table + (replaceHiddenRootCache target output rootResult.value.2) + pure (retainObservedRoot rootResult.value.1 observed, rightRoot) + calc + _ = evalDist (LazyRevealProbe.sampleHashOutput >>= continuation) := by + rfl + _ = evalDist (parts >>= continuation) := by + rw [evalDist_bind, evalDist_bind, hparts] + _ = _ := by + simp [parts, continuation, directDeferredContext, bind_assoc] + · simpa [directDeferredContext] using habsent + · simpa [directDeferredContext, directDeferredValues] using habsent + +noncomputable def resolvedEagerObservedRootComparisonExperimentAfterTable + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp + (Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest) := do + let rootResult ← runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure (none, 0) + | some result => + resolvedEagerObservedRootComparisonAfterRootResult adversary parameter ftsSecret target result + +set_option maxRecDepth 100000 in +theorem evalDist_resolvedEagerObservedRootComparisonExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + evalDist + (resolvedEagerObservedRootComparisonExperimentAfterTable adversary parameter ftsSecret + target fuel table) = + evalDist + (eagerObservedRootComparisonExperimentAfterTable ordinal adversary parameter ftsSecret + target fuel table) := by + unfold resolvedEagerObservedRootComparisonExperimentAfterTable + eagerObservedRootComparisonExperimentAfterTable + apply evalDist_bind_congr + intro rootResult hresult + cases rootResult with + | none => rfl + | some result => + have habsent := target_absent_of_mem_runCleanFromTable_maskedPublishedTreeRoot target hroot + hparent fuel table result hresult + have hpending := pending_eq_empty_of_mem_runCleanFromTable_maskedPublishedTreeRoot fuel table + result hresult + exact evalDist_resolvedEagerObservedRootComparisonAfterRootResult ordinal adversary parameter + ftsSecret target result habsent.1 hpending + +def SuccessfulObservedLazyEagerRel + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (target : Position) : + (Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest) → + (Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest) → + Prop := + fun lazy eager ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target lazy.2 lazy.1 → + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target eager.2 eager.1 + +theorem probEvent_successfulObservedRootComparison_eq_indicator + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (target : Position) + (run : ProbComp + (Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest)) : + Pr[fun result ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | run] = + Pr[= true | + successfulObservedRootComparisonIndicator table ordinal target <$> run] := by + calc + _ = Pr[fun result ↦ + successfulObservedRootComparisonIndicator table ordinal target result = true | run] := by + apply OracleComp.probEvent_congr' (fun result _ ↦ by simp) rfl + _ = _ := by + rw [← probEvent_eq_eq_probOutput, probEvent_map] + rfl + +theorem probEvent_observedRootComparison_le_resolvedEager_of_indicator + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) + (hrel : RelTriple + (successfulObservedRootComparisonIndicator table ordinal target <$> (do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot))) + (successfulObservedRootComparisonIndicator table ordinal target <$> + resolvedEagerObservedRootComparisonExperimentAfterTable adversary parameter ftsSecret + target (2 * q) table) + (fun lazy eager ↦ lazy = true → eager = true)) : + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] ≤ + Pr[fun result ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | + resolvedEagerObservedRootComparisonExperimentAfterTable adversary parameter ftsSecret + target (2 * q) table] := by + rw [probEvent_successfulObservedRootComparison_eq_indicator, + probEvent_successfulObservedRootComparison_eq_indicator] + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput] + apply probEvent_le_of_relTriple hrel + intro lazy eager hrelation hlazy + exact hrelation hlazy + +theorem probEvent_observedRootComparison_le_resolvedEager + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) + (hrel : RelTriple + (do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)) + (resolvedEagerObservedRootComparisonExperimentAfterTable adversary parameter ftsSecret + target (2 * q) table) + (SuccessfulObservedLazyEagerRel table ordinal target)) : + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] ≤ + Pr[fun result ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | + resolvedEagerObservedRootComparisonExperimentAfterTable adversary parameter ftsSecret + target (2 * q) table] := by + apply probEvent_le_of_relTriple hrel + intro lazy eager hrelation hgood + exact hrelation hgood + +theorem probEvent_observedRootComparison_le_production_mul_of_lazyEager + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (hfuel : 2 * q < Fintype.card Digest) + (hrel : RelTriple + (do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)) + (resolvedEagerObservedRootComparisonExperimentAfterTable adversary parameter ftsSecret + target (2 * q) table) + (SuccessfulObservedLazyEagerRel table ordinal target)) : + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] ≤ + Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target (2 * q) table] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ Pr[fun result ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | + resolvedEagerObservedRootComparisonExperimentAfterTable adversary parameter ftsSecret + target (2 * q) table] := + probEvent_observedRootComparison_le_resolvedEager ordinal adversary parameter table + ftsSecret q target hrel + _ = Pr[fun result ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | + eagerObservedRootComparisonExperimentAfterTable ordinal adversary parameter ftsSecret + target (2 * q) table] := by + apply OracleComp.probEvent_congr' (fun _ _ ↦ Iff.rfl) + exact evalDist_resolvedEagerObservedRootComparisonExperimentAfterTable ordinal adversary + parameter ftsSecret target hroot hparent (2 * q) table + _ ≤ _ := probEvent_eagerObservedRootComparison_le_production_mul ordinal adversary parameter + ftsSecret target hroot hparent (2 * q) table hfuel + +theorem probEvent_observedRootComparison_le_production_mul_of_indicator + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (hfuel : 2 * q < Fintype.card Digest) + (hrel : RelTriple + (successfulObservedRootComparisonIndicator table ordinal target <$> (do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot))) + (successfulObservedRootComparisonIndicator table ordinal target <$> + resolvedEagerObservedRootComparisonExperimentAfterTable adversary parameter ftsSecret + target (2 * q) table) + (fun lazy eager ↦ lazy = true → eager = true)) : + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] ≤ + Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target (2 * q) table] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ Pr[fun result ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | + resolvedEagerObservedRootComparisonExperimentAfterTable adversary parameter ftsSecret + target (2 * q) table] := + probEvent_observedRootComparison_le_resolvedEager_of_indicator ordinal adversary parameter + table ftsSecret q target hrel + _ = Pr[fun result ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | + eagerObservedRootComparisonExperimentAfterTable ordinal adversary parameter ftsSecret + target (2 * q) table] := by + apply OracleComp.probEvent_congr' (fun _ _ ↦ Iff.rfl) + exact evalDist_resolvedEagerObservedRootComparisonExperimentAfterTable ordinal adversary + parameter ftsSecret target hroot hparent (2 * q) table + _ ≤ _ := probEvent_eagerObservedRootComparison_le_production_mul ordinal adversary parameter + ftsSecret target hroot hparent (2 * q) table hfuel + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerBridge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerBridge.lean new file mode 100644 index 00000000..3200507d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerBridge.lean @@ -0,0 +1,234 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEager + +/-! +# Fixed-root lazy and eager prefix bridge + +The public-root computation is probe-free, so its observed result is just the clean result with an +empty observation list attached. This file factors that common prefix out of the remaining +event-preserving coupling. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def lazyObservedRootComparisonExperimentAfterTable + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp + (Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest) := do + let rootResult ← runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (none, rightRoot) + | some result => do + let observed ← observedMaterializedBoundary parameter result.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) [] result.state + result.remaining table result.value.2 + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (retainObservedRoot result.value.1 observed, rightRoot) + +set_option maxRecDepth 100000 in +theorem evalDist_lazyObservedRootComparisonExperimentAfterTable + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + evalDist (lazyObservedRootComparisonExperimentAfterTable adversary parameter ftsSecret + fuel table) = + evalDist (do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + fuel table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)) := by + unfold lazyObservedRootComparisonExperimentAfterTable + observedMaterializedRetainedRunFromTable + rw [← map_attachCleanProbeObservations_runCleanFromTable_of_probeFree + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty fuel table + (maskedPublishedTreeRoot_probeFree emptySplitHashCache)] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro rootResult _hrootResult + cases rootResult with + | none => rfl + | some result => + simp only [Function.comp_apply, pure_bind, attachCleanProbeObservations] + simp only [bind_assoc] + apply evalDist_bind_congr + intro observed _hobserved + cases observed <;> rfl + +def SuccessfulObservedIndicatorRel : Bool → Bool → Prop := + fun lazy eager ↦ lazy = true → eager = true + +set_option maxRecDepth 100000 in +theorem relTriple_indicator_lazyObserved_resolvedEager_of_afterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) + (hbridge : ∀ rootResult : CleanRunResult (Digest × SplitHashCache), + some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) → + RelTriple + (successfulObservedRootComparisonIndicator table ordinal target <$> (do + let observed ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining table rootResult.value.2 + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (retainObservedRoot rootResult.value.1 observed, rightRoot))) + (successfulObservedRootComparisonIndicator table ordinal target <$> + resolvedEagerObservedRootComparisonAfterRootResult adversary parameter ftsSecret target + rootResult) + SuccessfulObservedIndicatorRel) : + RelTriple + (successfulObservedRootComparisonIndicator table ordinal target <$> + lazyObservedRootComparisonExperimentAfterTable adversary parameter ftsSecret fuel table) + (successfulObservedRootComparisonIndicator table ordinal target <$> + resolvedEagerObservedRootComparisonExperimentAfterTable adversary parameter ftsSecret + target fuel table) + SuccessfulObservedIndicatorRel := by + unfold lazyObservedRootComparisonExperimentAfterTable + resolvedEagerObservedRootComparisonExperimentAfterTable + have hroot := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + (relTriple_refl + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (fun result ↦ result ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (fun _ hresult ↦ hresult) + simp only [map_eq_bind_pure_comp, bind_assoc] + apply relTriple_bind hroot + intro leftRoot rightRoot hrelation + obtain ⟨rfl, hleftRoot⟩ := hrelation + cases leftRoot with + | none => + apply relTriple_of_evalDist_eq_left + (show evalDist + (successfulObservedRootComparisonIndicator table ordinal target <$> (do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (none, rightRoot))) = evalDist (pure false : ProbComp Bool) by + simp [successfulObservedRootComparisonIndicator, + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] + rw [map_eq_bind_pure_comp] + apply SPMF.ext + intro output + change Pr[= output | liftM (PMF.uniformOfFintype Digest) >>= fun _ => + (pure false : SPMF Bool)] = Pr[= output | (pure false : SPMF Bool)] + rw [probOutput_bind_const] + have hzero : Pr[⊥ | (liftM (PMF.uniformOfFintype Digest) : SPMF Digest)] = 0 := + probFailure_of_liftM_PMF _ + rw [hzero] + simp) + have hpure : RelTriple (pure false : ProbComp Bool) (pure false : ProbComp Bool) + SuccessfulObservedIndicatorRel := + relTriple_pure_pure (fun hfalse ↦ by simp at hfalse) + simpa [successfulObservedRootComparisonIndicator, + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] using hpure + | some rootResult => + simpa only [map_eq_bind_pure_comp] using hbridge rootResult hleftRoot + +theorem relTriple_indicator_observedRootComparison_resolvedEager_of_afterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) + (hbridge : ∀ rootResult : CleanRunResult (Digest × SplitHashCache), + some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) → + RelTriple + (successfulObservedRootComparisonIndicator table ordinal target <$> (do + let observed ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining table rootResult.value.2 + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (retainObservedRoot rootResult.value.1 observed, rightRoot))) + (successfulObservedRootComparisonIndicator table ordinal target <$> + resolvedEagerObservedRootComparisonAfterRootResult adversary parameter ftsSecret target + rootResult) + SuccessfulObservedIndicatorRel) : + RelTriple + (successfulObservedRootComparisonIndicator table ordinal target <$> (do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + fuel table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot))) + (successfulObservedRootComparisonIndicator table ordinal target <$> + resolvedEagerObservedRootComparisonExperimentAfterTable adversary parameter ftsSecret + target fuel table) + SuccessfulObservedIndicatorRel := by + apply relTriple_of_evalDist_eq_left + (show evalDist + (successfulObservedRootComparisonIndicator table ordinal target <$> (do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + fuel table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot))) = + evalDist + (successfulObservedRootComparisonIndicator table ordinal target <$> + lazyObservedRootComparisonExperimentAfterTable adversary parameter ftsSecret + fuel table) by + simp only [evalDist_map] + rw [evalDist_lazyObservedRootComparisonExperimentAfterTable]) + exact relTriple_indicator_lazyObserved_resolvedEager_of_afterRootResult ordinal adversary + parameter table ftsSecret fuel target hbridge + +set_option maxRecDepth 100000 in +theorem probEvent_observedRootComparison_le_production_mul_of_afterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (hfuel : 2 * q < Fintype.card Digest) + (hbridge : ∀ rootResult : CleanRunResult (Digest × SplitHashCache), + some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache)) → + RelTriple + (successfulObservedRootComparisonIndicator table ordinal target <$> (do + let observed ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining table rootResult.value.2 + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (retainObservedRoot rootResult.value.1 observed, rightRoot))) + (successfulObservedRootComparisonIndicator table ordinal target <$> + resolvedEagerObservedRootComparisonAfterRootResult adversary parameter ftsSecret target + rootResult) + SuccessfulObservedIndicatorRel) : + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] ≤ + Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target (2 * q) table] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_observedRootComparison_le_production_mul_of_indicator ordinal adversary parameter + table ftsSecret q target hroot hparent hfuel + exact relTriple_indicator_observedRootComparison_resolvedEager_of_afterRootResult ordinal + adversary parameter table ftsSecret (2 * q) target hbridge + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerObservation.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerObservation.lean new file mode 100644 index 00000000..309efa46 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerObservation.lean @@ -0,0 +1,282 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootJoint + +/-! +# Observation transport across an installed root + +Installing one hidden structural value early changes only the stored value recorded by probes at +that position. Probe identity and publication status stay unchanged. The comparison-root avoidance +condition therefore preserves the clean strict prefix, while the selected matching probe remains a +hidden hit. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +def installPositionValueAtProbe + (target : Position) (output : HashOutput) + (observation : CleanProbeObservation) : CleanProbeObservation := + if observation.coordinate = .position target then + { observation with valueAtProbe := some output } + else observation + +@[simp] theorem installPositionValueAtProbe_coordinate + (target : Position) (output : HashOutput) (observation : CleanProbeObservation) : + (installPositionValueAtProbe target output observation).coordinate = observation.coordinate := by + unfold installPositionValueAtProbe + split <;> rfl + +@[simp] theorem installPositionValueAtProbe_candidate + (target : Position) (output : HashOutput) (observation : CleanProbeObservation) : + (installPositionValueAtProbe target output observation).candidate = observation.candidate := by + unfold installPositionValueAtProbe + split <;> rfl + +@[simp] theorem installPositionValueAtProbe_revealedAtProbe + (target : Position) (output : HashOutput) (observation : CleanProbeObservation) : + (installPositionValueAtProbe target output observation).revealedAtProbe = + observation.revealedAtProbe := by + unfold installPositionValueAtProbe + split <;> rfl + +@[simp] theorem installPositionValueAtProbe_toProbe + (target : Position) (output : HashOutput) (observation : CleanProbeObservation) : + (installPositionValueAtProbe target output observation).toProbe = observation.toProbe := by + unfold installPositionValueAtProbe CleanProbeObservation.toProbe + split <;> rfl + +theorem installPositionValueAtProbe_existingHiddenHit_iff_of_target + (target : Position) (output : HashOutput) (observation : CleanProbeObservation) + (hcoordinate : observation.coordinate = .position target) : + (installPositionValueAtProbe target output observation).ExistingHiddenHit ↔ + observation.revealedAtProbe = false ∧ + truncateHash output = observation.candidate := by + simp [installPositionValueAtProbe, hcoordinate, CleanProbeObservation.ExistingHiddenHit] + +theorem installPositionValueAtProbe_existingHiddenHit_iff_of_ne + (target : Position) (output : HashOutput) (observation : CleanProbeObservation) + (hcoordinate : observation.coordinate ≠ .position target) : + (installPositionValueAtProbe target output observation).ExistingHiddenHit ↔ + observation.ExistingHiddenHit := by + simp [installPositionValueAtProbe, hcoordinate] + +theorem not_existingHiddenHit_installPositionValueAtProbe_of_avoids + (target : Position) (output : HashOutput) (observation : CleanProbeObservation) + (hclean : ¬observation.ExistingHiddenHit) + (havoid : observation.toProbe ≠ + ⟨.position target, truncateHash output⟩) : + ¬(installPositionValueAtProbe target output observation).ExistingHiddenHit := by + by_cases hcoordinate : observation.coordinate = .position target + · rw [installPositionValueAtProbe_existingHiddenHit_iff_of_target target output observation + hcoordinate] + intro hhit + apply havoid + cases observation + simp only [CleanProbeObservation.toProbe, Probe.mk.injEq] at hcoordinate ⊢ + exact ⟨hcoordinate, hhit.2.symm⟩ + · rw [installPositionValueAtProbe_existingHiddenHit_iff_of_ne target output observation + hcoordinate] + exact hclean + +theorem map_toProbe_map_installPositionValueAtProbe + (target : Position) (output : HashOutput) + (observations : List CleanProbeObservation) : + (observations.map (installPositionValueAtProbe target output)).map + CleanProbeObservation.toProbe = + observations.map CleanProbeObservation.toProbe := by + rw [List.map_map] + apply List.map_congr_left + intro observation _hobservation + exact installPositionValueAtProbe_toProbe target output observation + +@[simp] theorem observedPrefixProbes_map_installPositionValueAtProbe + (target : Position) (output : HashOutput) + (result : ObservedCleanRunResult α) (ordinal : Nat) : + observedPrefixProbes ordinal + (some { result with observations := + result.observations.map (installPositionValueAtProbe target output) }) = + observedPrefixProbes ordinal (some result) := by + simp only [observedPrefixProbes] + rw [List.map_take, map_toProbe_map_installPositionValueAtProbe] + rw [List.map_take] + +@[simp] theorem observedFirstLayerRootPosition?_map_installPositionValueAtProbe + (target : Position) (output : HashOutput) + (result : ObservedCleanRunResult α) (ordinal : Nat) : + observedFirstLayerRootPosition? ordinal + (some { result with observations := + result.observations.map (installPositionValueAtProbe target output) }) = + observedFirstLayerRootPosition? ordinal (some result) := by + simp only [observedFirstLayerRootPosition?] + by_cases horiginal : ordinal < result.observations.length + · have hmapped : ordinal < + (result.observations.map (installPositionValueAtProbe target output)).length := by + simpa only [List.length_map] using horiginal + rw [dif_pos hmapped, dif_pos horiginal] + simp only [List.get_eq_getElem, List.getElem_map, + installPositionValueAtProbe_toProbe] + · have hmapped : ¬ordinal < + (result.observations.map (installPositionValueAtProbe target output)).length := by + simpa only [List.length_map] using horiginal + rw [dif_neg hmapped, dif_neg horiginal] + +theorem observedPrefixProbes_eq_of_observations_eq + (ordinal : Nat) (left right : ObservedCleanRunResult α) + (hobservations : left.observations = right.observations) : + observedPrefixProbes ordinal (some left) = + observedPrefixProbes ordinal (some right) := by + simp only [observedPrefixProbes] + rw [hobservations] + +theorem observedFirstLayerRootPosition?_eq_of_observations_eq + (ordinal : Nat) (left right : ObservedCleanRunResult α) + (hobservations : left.observations = right.observations) : + observedFirstLayerRootPosition? ordinal (some left) = + observedFirstLayerRootPosition? ordinal (some right) := by + simp only [observedFirstLayerRootPosition?] + rw [hobservations] + +theorem firstExistingHiddenHitAt_of_observations_eq + (left right : ObservedCleanRunResult α) (ordinal : Nat) + (hobservations : left.observations = right.observations) + (hfirst : FirstExistingHiddenHitAt left ordinal) : + FirstExistingHiddenHitAt right ordinal := by + obtain ⟨selected, hordinal, hhit, hbefore⟩ := hfirst + let rightSelected : Fin right.observations.length := + ⟨selected.val, by rw [← hobservations]; exact selected.isLt⟩ + refine ⟨rightSelected, hordinal, ?_, ?_⟩ + · have hget : right.observations.get rightSelected = + left.observations.get selected := by + subst rightSelected + simp [hobservations] + rw [ExistingHiddenHitAtOrdinal, hget] + exact hhit + · intro rightEarlier hearlier + let leftEarlier : Fin left.observations.length := + ⟨rightEarlier.val, by rw [hobservations]; exact rightEarlier.isLt⟩ + have hget : right.observations.get rightEarlier = + left.observations.get leftEarlier := by + subst leftEarlier + simp [hobservations] + rw [ExistingHiddenHitAtOrdinal, hget] + exact hbefore leftEarlier hearlier + +theorem firstExistingHiddenRootHitAt_of_first_of_position + (result : ObservedCleanRunResult α) (ordinal : Nat) (target : Position) + (hfirst : FirstExistingHiddenHitAt result ordinal) + (hposition : observedFirstLayerRootPosition? ordinal (some result) = some target) : + ObservedCleanRunOption.FirstExistingHiddenRootHitAt ordinal (some result) := by + have hfirstData := hfirst + obtain ⟨selected, hordinal, _hhit, _hbefore⟩ := hfirstData + refine ⟨selected, hordinal, hfirst, ?_⟩ + have hlt : ordinal < result.observations.length := by + rw [← hordinal] + exact selected.isLt + simp only [observedFirstLayerRootPosition?, hlt, ↓reduceDIte] at hposition + have hindex : (⟨ordinal, hlt⟩ : Fin result.observations.length) = selected := + Fin.ext hordinal.symm + rw [hindex, candidateLayerRootPosition?_eq_some_iff] at hposition + exact ⟨target, hposition.1, hposition.2⟩ + +theorem no_existingHiddenHit_map_installPositionValueAtProbe_of_avoids + (target : Position) (output : HashOutput) + (observations : List CleanProbeObservation) + (hclean : ∀ observation ∈ observations, ¬observation.ExistingHiddenHit) + (havoid : CandidatesAvoidRoot target (truncateHash output) + (observations.map CleanProbeObservation.toProbe)) : + ∀ observation ∈ observations.map (installPositionValueAtProbe target output), + ¬observation.ExistingHiddenHit := by + intro observation hobservation + rw [List.mem_map] at hobservation + obtain ⟨before, hbefore, rfl⟩ := hobservation + apply not_existingHiddenHit_installPositionValueAtProbe_of_avoids target output before + (hclean before hbefore) + apply havoid before.toProbe + rw [List.mem_map] + exact ⟨before, hbefore, rfl⟩ + +theorem installPositionValueAtProbe_eq_self + (target : Position) (output : HashOutput) (observation : CleanProbeObservation) + (hvalue : observation.coordinate = .position target → + observation.valueAtProbe = some output) : + installPositionValueAtProbe target output observation = observation := by + unfold installPositionValueAtProbe + split + · rename_i hcoordinate + cases observation + simp only [CleanProbeObservation.mk.injEq] + simpa using (hvalue hcoordinate).symm + · rfl + +theorem installPositionValueAtProbe_cleanProbeObservation_eq_self + (target : Position) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) + (htarget : state.values (.position target) = some output) + (coordinate : Coordinate) (candidate : Digest) : + installPositionValueAtProbe target output + (cleanProbeObservation state coordinate candidate) = + cleanProbeObservation state coordinate candidate := by + apply installPositionValueAtProbe_eq_self + intro hcoordinate + have : coordinate = .position target := by + simpa [cleanProbeObservation] using hcoordinate + subst coordinate + simp [cleanProbeObservation, htarget] + +theorem map_installPositionValueAtProbe_append_cleanProbeObservation + (target : Position) (output : HashOutput) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) + (htarget : state.values (.position target) = some output) + (coordinate : Coordinate) (candidate : Digest) : + (observations ++ [cleanProbeObservation state coordinate candidate]).map + (installPositionValueAtProbe target output) = + observations.map (installPositionValueAtProbe target output) ++ + [cleanProbeObservation state coordinate candidate] := by + rw [List.map_append] + simp [installPositionValueAtProbe_cleanProbeObservation_eq_self target output state htarget] + +theorem firstExistingHiddenHitAt_map_installPositionValueAtProbe + (target : Position) (output : HashOutput) + (result : ObservedCleanRunResult α) (ordinal : Nat) + (hfirst : FirstExistingHiddenHitAt result ordinal) + (hselected : ∀ selected : Fin result.observations.length, + selected.val = ordinal → + (result.observations.get selected).coordinate = .position target ∧ + (result.observations.get selected).revealedAtProbe = false ∧ + truncateHash output = (result.observations.get selected).candidate) + (havoid : ∀ earlier : Fin result.observations.length, + earlier.val < ordinal → + (result.observations.get earlier).toProbe ≠ + ⟨.position target, truncateHash output⟩) : + FirstExistingHiddenHitAt + { result with observations := + result.observations.map (installPositionValueAtProbe target output) } + ordinal := by + obtain ⟨selected, hordinal, _hhit, hbefore⟩ := hfirst + let mappedSelected : Fin + (result.observations.map (installPositionValueAtProbe target output)).length := + ⟨selected.val, by simpa only [List.length_map] using selected.isLt⟩ + refine ⟨mappedSelected, hordinal, ?_, ?_⟩ + · have hselectedData := hselected selected hordinal + have hget : + (result.observations.map (installPositionValueAtProbe target output)).get mappedSelected = + installPositionValueAtProbe target output (result.observations.get selected) := by + simp [mappedSelected] + rw [ExistingHiddenHitAtOrdinal, hget, + installPositionValueAtProbe_existingHiddenHit_iff_of_target target output + (result.observations.get selected) hselectedData.1] + exact hselectedData.2 + · intro mappedEarlier hearlier + let earlier : Fin result.observations.length := + ⟨mappedEarlier.val, by simpa using mappedEarlier.isLt⟩ + have hclean : ¬(result.observations.get earlier).ExistingHiddenHit := + hbefore earlier hearlier + have hsafe := not_existingHiddenHit_installPositionValueAtProbe_of_avoids + target output (result.observations.get earlier) hclean (havoid earlier hearlier) + have hget : + (result.observations.map (installPositionValueAtProbe target output)).get mappedEarlier = + installPositionValueAtProbe target output (result.observations.get earlier) := by + simp [earlier] + rw [ExistingHiddenHitAtOrdinal, hget] + exact hsafe + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerSelected.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerSelected.lean new file mode 100644 index 00000000..21a2a7eb --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerSelected.lean @@ -0,0 +1,149 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerSuffix + +/-! +# Selected-root lazy and eager handoff + +At the selected query boundary, strict-prefix coverage makes resolution of the selected root +deterministic and collision-free. This file composes that fact with the synchronized suffix, so the +outer adaptive lift does not have to inspect the root-output sampler. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_indicator_resolveSelectedRoot_then_observedMaterializedBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (output : HashOutput) (rightRoot : Digest) + (ordinal : Nat) (hroot : IsLayerRoot target) + (selection : PrivateOrdinalSelection) + (hgood : selection.GoodForRoots target output rightRoot ordinal) + (hcovered : PendingCoveredBy (selection.candidates.take ordinal) selection.context) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) + (hselectedHit : ∀ result : ObservedCleanRunResult (α × SplitHashCache), + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result) → + ∀ selected : Fin result.observations.length, selected.val = ordinal → + (result.observations.get selected).coordinate = .position target ∧ + (result.observations.get selected).revealedAtProbe = false ∧ + truncateHash output = (result.observations.get selected).candidate) + (hactualAvoid : ∀ result : ObservedCleanRunResult (α × SplitHashCache), + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result) → + ∀ earlier : Fin result.observations.length, earlier.val < ordinal → + (result.observations.get earlier).toProbe ≠ + ⟨.position target, truncateHash output⟩) : + RelTriple + (resolveDeferredPositionValue target selection.context >>= fun resolved => + match resolved with + | none => pure false + | some resolved => + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) <$> + observedMaterializedBoundary parameter root ftsSecret computation observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) <$> + observedMaterializedBoundary parameter root ftsSecret computation + (observations.map (installPositionValueAtProbe target output)) + (materializedDeferredState + { selection.context with + values := selection.context.values.install target output }) + fuel table cache) + (fun lazy eager => lazy = true → eager = true) := by + let resolved : DeferredResolution := + ⟨{ state := selection.context.state.clearPending (.position target) + values := selection.context.values }, output⟩ + have hresolve : resolveDeferredPositionValue target selection.context = pure (some resolved) := by + simpa [resolved] using resolveDeferredPositionValue_eq_good_output hgood hcovered + have hresolved : some resolved ∈ support + (resolveDeferredPositionValue target selection.context) := by + rw [hresolve] + simp + rw [hresolve] + simp only [pure_bind] + exact relTriple_indicator_observedMaterializedBoundary_after_target_resolution parameter root + ftsSecret target output rightRoot ordinal hroot selection hgood hcovered resolved hresolved + computation observations fuel table cache hselectedHit hactualAvoid + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_indicator_resolveSelectedRoot_then_observedMaterializedBoundary_supported + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (output : HashOutput) (rightRoot : Digest) + (ordinal : Nat) (hroot : IsLayerRoot target) + (selection : PrivateOrdinalSelection) + (hgood : selection.GoodForRoots target output rightRoot ordinal) + (hcovered : PendingCoveredBy (selection.candidates.take ordinal) selection.context) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) + (hselectedHit : ∀ (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target selection.context)) + (result : ObservedCleanRunResult (α × SplitHashCache)), + some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache) → + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result) → + ∀ selected : Fin result.observations.length, selected.val = ordinal → + (result.observations.get selected).coordinate = .position target ∧ + (result.observations.get selected).revealedAtProbe = false ∧ + truncateHash output = (result.observations.get selected).candidate) + (hactualAvoid : ∀ (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target selection.context)) + (result : ObservedCleanRunResult (α × SplitHashCache)), + some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache) → + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result) → + ∀ earlier : Fin result.observations.length, earlier.val < ordinal → + (result.observations.get earlier).toProbe ≠ + ⟨.position target, truncateHash output⟩) : + RelTriple + (resolveDeferredPositionValue target selection.context >>= fun resolved => + match resolved with + | none => pure false + | some resolved => + (successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) <$> + observedMaterializedBoundary parameter root ftsSecret computation observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) <$> + observedMaterializedBoundary parameter root ftsSecret computation + (observations.map (installPositionValueAtProbe target output)) + (materializedDeferredState + { selection.context with + values := selection.context.values.install target output }) + fuel table cache) + (fun lazy eager => lazy = true → eager = true) := by + let resolved : DeferredResolution := + ⟨{ state := selection.context.state.clearPending (.position target) + values := selection.context.values }, output⟩ + have hresolve : resolveDeferredPositionValue target selection.context = pure (some resolved) := by + simpa [resolved] using resolveDeferredPositionValue_eq_good_output hgood hcovered + have hresolved : some resolved ∈ support + (resolveDeferredPositionValue target selection.context) := by + rw [hresolve] + simp + rw [hresolve] + simp only [pure_bind] + exact relTriple_indicator_observedMaterializedBoundary_after_target_resolution_supported + parameter root ftsSecret target output rightRoot ordinal hroot selection hgood hcovered + resolved hresolved computation observations fuel table cache + (hselectedHit resolved hresolved) (hactualAvoid resolved hresolved) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerState.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerState.lean new file mode 100644 index 00000000..15862c18 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerState.lean @@ -0,0 +1,401 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootProbeCoupling +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionDeferred +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionMaterialize + +/-! +# Safe pending differences after root synchronization + +After the delayed execution materializes the selected root, the eager execution can differ only by retaining earlier candidates at that root. Those candidates avoid the installed digest. This relation records exactly that difference. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +structure SafeTargetPendingLE + (target : Position) (output : HashOutput) + (left right : LazyRevealProbe.State Coordinate) : Prop where + pending : left.pending ⊆ right.pending + values : left.values = right.values + revealed : left.revealed = right.revealed + ensured : left.ensured = right.ensured + target_value : left.values (.position target) = some output + extra : ∀ coordinate candidate, + (coordinate, candidate) ∈ right.pending → + (coordinate, candidate) ∈ left.pending ∨ + (coordinate = .position target ∧ candidate ≠ truncateHash output) + +theorem SafeTargetPendingLE.refl + (target : Position) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) + (htarget : state.values (.position target) = some output) : + SafeTargetPendingLE target output state state := + ⟨fun _ hentry => hentry, rfl, rfl, rfl, htarget, + fun _ _ hentry => Or.inl hentry⟩ + +theorem SafeTargetPendingLE.toProbeStateLE + {target : Position} {output : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : SafeTargetPendingLE target output left right) + (hroot : IsLayerRoot target) : + ProbeStateLE left right := by + refine ⟨hrel.pending, hrel.values, hrel.revealed, hrel.ensured, ?_⟩ + intro coordinate candidate hentry + rcases hrel.extra coordinate candidate hentry with hleft | ⟨hcoordinate, _hsafe⟩ + · exact Or.inl hleft + · exact Or.inr ⟨target, hcoordinate, hroot⟩ + +theorem SafeTargetPendingLE.right_target_value + {target : Position} {output : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : SafeTargetPendingLE target output left right) : + right.values (.position target) = some output := by + rw [← hrel.values] + exact hrel.target_value + +theorem SafeTargetPendingLE.hitAt_iff_of_ne + {target : Position} {output : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : SafeTargetPendingLE target output left right) + (coordinate : Coordinate) (value : HashOutput) + (hne : coordinate ≠ .position target) : + left.hitAt coordinate value ↔ right.hitAt coordinate value := by + unfold LazyRevealProbe.State.hitAt + rw [LazyRevealProbe.State.mem_pendingAt_iff, + LazyRevealProbe.State.mem_pendingAt_iff] + constructor + · intro hentry + exact hrel.pending hentry + · intro hentry + rcases hrel.extra coordinate (truncateHash value) hentry with hleft | hextra + · exact hleft + · exact (hne hextra.1).elim + +theorem SafeTargetPendingLE.addPending + {target : Position} {output : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : SafeTargetPendingLE target output left right) + (coordinate : Coordinate) (candidate : Digest) : + SafeTargetPendingLE target output + (left.addPending coordinate candidate) + (right.addPending coordinate candidate) := by + refine ⟨?_, hrel.values, hrel.revealed, hrel.ensured, hrel.target_value, ?_⟩ + · intro entry hentry + simp only [LazyRevealProbe.State.addPending, Finset.mem_insert] at hentry ⊢ + exact hentry.elim Or.inl (fun hold => Or.inr (hrel.pending hold)) + · intro other otherCandidate hentry + simp only [LazyRevealProbe.State.addPending, Finset.mem_insert] at hentry ⊢ + rcases hentry with hnew | hold + · exact Or.inl (Or.inl hnew) + · rcases hrel.extra other otherCandidate hold with hleft | hextra + · exact Or.inl (Or.inr hleft) + · exact Or.inr hextra + +theorem SafeTargetPendingLE.ensure + {target : Position} {output : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : SafeTargetPendingLE target output left right) + (coordinate : Coordinate) : + SafeTargetPendingLE target output + (left.ensure coordinate) (right.ensure coordinate) := by + refine ⟨hrel.pending, hrel.values, hrel.revealed, ?_, hrel.target_value, hrel.extra⟩ + simp [LazyRevealProbe.State.ensure, hrel.ensured] + +theorem SafeTargetPendingLE.publish + {target : Position} {output : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : SafeTargetPendingLE target output left right) + (coordinate : Coordinate) : + SafeTargetPendingLE target output + (left.publish coordinate) (right.publish coordinate) := by + refine ⟨hrel.pending, hrel.values, ?_, hrel.ensured, hrel.target_value, hrel.extra⟩ + simp [LazyRevealProbe.State.publish, hrel.revealed] + +theorem SafeTargetPendingLE.clearPending + {target : Position} {output : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : SafeTargetPendingLE target output left right) + (coordinate : Coordinate) : + SafeTargetPendingLE target output + (left.clearPending coordinate) (right.clearPending coordinate) := by + refine ⟨?_, hrel.values, hrel.revealed, hrel.ensured, hrel.target_value, ?_⟩ + · intro entry hentry + simp only [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway, + Finset.mem_filter] at hentry ⊢ + exact ⟨hrel.pending hentry.1, hentry.2⟩ + · intro other candidate hentry + simp only [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway, + Finset.mem_filter] at hentry ⊢ + rcases hrel.extra other candidate hentry.1 with hleft | hextra + · exact Or.inl ⟨hleft, hentry.2⟩ + · exact Or.inr hextra + +theorem SafeTargetPendingLE.materialize_of_ne + {target : Position} {output : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : SafeTargetPendingLE target output left right) + (coordinate : Coordinate) (value : HashOutput) + (hne : coordinate ≠ .position target) : + SafeTargetPendingLE target output + (left.materialize coordinate value) + (right.materialize coordinate value) := by + refine ⟨?_, ?_, hrel.revealed, ?_, ?_, ?_⟩ + · intro entry hentry + simp only [LazyRevealProbe.State.materialize, LazyRevealProbe.State.pendingAway, + Finset.mem_filter] at hentry ⊢ + exact ⟨hrel.pending hentry.1, hentry.2⟩ + · simp [LazyRevealProbe.State.materialize, hrel.values] + · simp [LazyRevealProbe.State.materialize, hrel.ensured] + · simp [LazyRevealProbe.State.materialize, Function.update_of_ne (Ne.symm hne), + hrel.target_value] + · intro other candidate hentry + simp only [LazyRevealProbe.State.materialize, LazyRevealProbe.State.pendingAway, + Finset.mem_filter] at hentry ⊢ + rcases hrel.extra other candidate hentry.1 with hleft | hextra + · exact Or.inl ⟨hleft, hentry.2⟩ + · exact Or.inr hextra + +theorem SafeTargetPendingLE.complete_of_ne + {target : Position} {output : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : SafeTargetPendingLE target output left right) + (coordinate : Coordinate) (value : HashOutput) + (hne : coordinate ≠ .position target) : + SafeTargetPendingLE target output + (left.complete coordinate value) + (right.complete coordinate value) := by + refine ⟨?_, ?_, hrel.revealed, hrel.ensured, ?_, ?_⟩ + · intro entry hentry + simp only [LazyRevealProbe.State.complete, LazyRevealProbe.State.pendingAway, + Finset.mem_filter] at hentry ⊢ + exact ⟨hrel.pending hentry.1, hentry.2⟩ + · simp [LazyRevealProbe.State.complete, hrel.values] + · simp [LazyRevealProbe.State.complete, Function.update_of_ne (Ne.symm hne), + hrel.target_value] + · intro other candidate hentry + simp only [LazyRevealProbe.State.complete, LazyRevealProbe.State.pendingAway, + Finset.mem_filter] at hentry ⊢ + rcases hrel.extra other candidate hentry.1 with hleft | hextra + · exact Or.inl ⟨hleft, hentry.2⟩ + · exact Or.inr hextra + +theorem SafeTargetPendingLE.coordinates_eq_of_target_mem + {target : Position} {output : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : SafeTargetPendingLE target output left right) + (htarget : Coordinate.position target ∈ left.coordinates) : + left.coordinates = right.coordinates := by + apply Finset.Subset.antisymm + · intro coordinate hcoordinate + unfold LazyRevealProbe.State.coordinates at hcoordinate ⊢ + simp only [Finset.mem_union, Finset.mem_image] at hcoordinate ⊢ + rcases hcoordinate with hensured | ⟨entry, hentry, rfl⟩ + · left + rw [← hrel.ensured] + exact hensured + · right + exact ⟨entry, hrel.pending hentry, rfl⟩ + · intro coordinate hcoordinate + unfold LazyRevealProbe.State.coordinates at hcoordinate ⊢ + simp only [Finset.mem_union, Finset.mem_image] at hcoordinate ⊢ + rcases hcoordinate with hensured | ⟨entry, hentry, rfl⟩ + · left + rw [hrel.ensured] + exact hensured + · rcases hrel.extra entry.1 entry.2 hentry with hleft | ⟨hcoordinate, _hsafe⟩ + · right + exact ⟨entry, hleft, rfl⟩ + · have htarget' : Coordinate.position target ∈ left.ensured ∨ + ∃ candidate, (Coordinate.position target, candidate) ∈ left.pending := by + simpa [LazyRevealProbe.State.coordinates] using htarget + simpa [hcoordinate] using htarget' + +theorem SafeTargetPendingLE.clearPending_target_eq + {target : Position} {output : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : SafeTargetPendingLE target output left right) : + left.clearPending (.position target) = right.clearPending (.position target) := by + rcases left with ⟨leftPending, leftValues, leftRevealed, leftEnsured⟩ + rcases right with ⟨rightPending, rightValues, rightRevealed, rightEnsured⟩ + simp only [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.mk.injEq] + refine ⟨?_, hrel.values, hrel.revealed, hrel.ensured⟩ + apply Finset.ext + intro entry + simp only [LazyRevealProbe.State.pendingAway, Finset.mem_filter] + constructor + · intro hentry + exact ⟨hrel.pending hentry.1, hentry.2⟩ + · intro hentry + rcases hrel.extra entry.1 entry.2 hentry.1 with hleft | hextra + · exact ⟨hleft, hentry.2⟩ + · exact (hentry.2 hextra.1).elim + +theorem SafeTargetPendingLE.eq_of_target_not_mem_right_coordinates + {target : Position} {output : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : SafeTargetPendingLE target output left right) + (htarget : Coordinate.position target ∉ right.coordinates) : + left = right := by + have hleftTarget : Coordinate.position target ∉ left.coordinates := by + intro hmem + unfold LazyRevealProbe.State.coordinates at hmem htarget + simp only [Finset.mem_union, Finset.mem_image] at hmem htarget + rcases hmem with hensured | ⟨entry, hentry, heq⟩ + · exact htarget (Or.inl (hrel.ensured ▸ hensured)) + · exact htarget (Or.inr ⟨entry, hrel.pending hentry, heq⟩) + have hleftClear : left.clearPending (.position target) = left := + clearPending_eq_self_of_not_mem_coordinates left (.position target) + hleftTarget + have hrightClear : right.clearPending (.position target) = right := + clearPending_eq_self_of_not_mem_coordinates right (.position target) htarget + rw [← hleftClear, ← hrightClear] + exact hrel.clearPending_target_eq + +theorem SafeTargetPendingLE.erase_target_coordinates_eq_of_not_mem_left + {target : Position} {output : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : SafeTargetPendingLE target output left right) + (htarget : Coordinate.position target ∉ left.coordinates) : + right.coordinates.erase (.position target) = left.coordinates := by + apply Finset.ext + intro coordinate + simp only [Finset.mem_erase] + constructor + · intro hcoordinate + unfold LazyRevealProbe.State.coordinates at hcoordinate htarget ⊢ + simp only [Finset.mem_union, Finset.mem_image] at hcoordinate htarget ⊢ + rcases hcoordinate.2 with hensured | ⟨entry, hentry, heq⟩ + · left + rw [hrel.ensured] + exact hensured + · rcases hrel.extra entry.1 entry.2 hentry with hleft | hextra + · right + exact ⟨entry, hleft, heq⟩ + · exact (hcoordinate.1 (heq ▸ hextra.1)).elim + · intro hcoordinate + refine ⟨?_, ?_⟩ + · intro heq + exact htarget (heq ▸ hcoordinate) + · unfold LazyRevealProbe.State.coordinates at hcoordinate ⊢ + simp only [Finset.mem_union, Finset.mem_image] at hcoordinate ⊢ + rcases hcoordinate with hensured | ⟨entry, hentry, heq⟩ + · left + rw [← hrel.ensured] + exact hensured + · right + exact ⟨entry, hrel.pending hentry, heq⟩ + +theorem SafeTargetPendingLE.clean_extra + {target : Position} {output : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : SafeTargetPendingLE target output left right) + (coordinate : Coordinate) (candidate : Digest) + (hentry : (coordinate, candidate) ∈ right.pending) + (hnotLeft : (coordinate, candidate) ∉ left.pending) : + coordinate = .position target ∧ candidate ≠ truncateHash output := by + rcases hrel.extra coordinate candidate hentry with hleft | hextra + · exact (hnotLeft hleft).elim + · exact hextra + +theorem safeTargetPendingLE_materialized_completePrivatePosition + (target : Position) (output : HashOutput) (context : DeferredContext) + (hhidden : context.state.values (.position target) = none) + (hsafe : ∀ candidate, + (Coordinate.position target, candidate) ∈ context.state.pending → + candidate ≠ truncateHash output) : + SafeTargetPendingLE target output + (materializedDeferredState + (completePrivatePosition target context output).toDeferredContext) + (materializedDeferredState + { context with values := context.values.install target output }) := by + refine ⟨?_, ?_, rfl, rfl, ?_, ?_⟩ + · intro entry hentry + simp only [materializedDeferredState_pending, completePrivatePosition, + LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway, Finset.mem_filter] at hentry ⊢ + exact hentry.1 + · funext coordinate + cases coordinate with + | chainStart lay tree leafIdx chainIdx => rfl + | position position => + by_cases heq : position = target + · subst position + simp [materializedDeferredState, DeferredContext.positionValue, + completePrivatePosition, DeferredStructuralValues.install] + · simp [materializedDeferredState, DeferredContext.positionValue, + completePrivatePosition, DeferredStructuralValues.install, + Function.update_of_ne heq] + · simp [materializedDeferredState, DeferredContext.positionValue, + completePrivatePosition, DeferredStructuralValues.install, hhidden] + · intro coordinate candidate hentry + simp only [materializedDeferredState_pending] at hentry ⊢ + by_cases heq : coordinate = .position target + · exact Or.inr ⟨heq, hsafe candidate (heq ▸ hentry)⟩ + · exact Or.inl (by + simp only [completePrivatePosition, LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway, + Finset.mem_filter] + exact ⟨hentry, heq⟩) + +theorem safeTargetPendingLE_of_goodForRoots_pendingCovered + {target : Position} {output : HashOutput} {rightRoot : Digest} + {ordinal : Nat} {selection : PrivateOrdinalSelection} + (hgood : selection.GoodForRoots target output rightRoot ordinal) + (hcovered : PendingCoveredBy (selection.candidates.take ordinal) selection.context) : + SafeTargetPendingLE target output + (materializedDeferredState + (completePrivatePosition target selection.context output).toDeferredContext) + (materializedDeferredState + { selection.context with + values := selection.context.values.install target output }) := by + apply safeTargetPendingLE_materialized_completePrivatePosition target output selection.context + hgood.2.1 + intro candidate hentry heq + obtain ⟨probe, hprobe, hcoordinate, hdigest⟩ := hcovered _ hentry + have havoid := (hgood.2.2.2.2 probe hprobe).1 + apply havoid + cases probe + simp only [Probe.mk.injEq] at hcoordinate hdigest ⊢ + exact ⟨hcoordinate, hdigest.trans heq⟩ + +theorem safeTargetPendingLE_of_resolveDeferredPositionValue + {target : Position} {output : HashOutput} {rightRoot : Digest} + {ordinal : Nat} {selection : PrivateOrdinalSelection} + (hgood : selection.GoodForRoots target output rightRoot ordinal) + (hcovered : PendingCoveredBy (selection.candidates.take ordinal) selection.context) + (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target selection.context)) : + SafeTargetPendingLE target output + (materializedDeferredState resolved.toDeferredContext) + (materializedDeferredState + { selection.context with + values := selection.context.values.install target output }) := by + have hnotHit : ¬selection.context.state.hitAt (.position target) output := by + intro hhit + have hentry : (Coordinate.position target, truncateHash output) ∈ + selection.context.state.pending := by + rw [← LazyRevealProbe.State.mem_pendingAt_iff] + exact hhit + obtain ⟨probe, hprobe, hcoordinate, hdigest⟩ := hcovered _ hentry + have havoid := (hgood.2.2.2.2 probe hprobe).1 + apply havoid + cases probe + simp only [Probe.mk.injEq] at hcoordinate hdigest ⊢ + exact ⟨hcoordinate, hdigest⟩ + have hinstall : selection.context.values.install target output = + selection.context.values := by + unfold DeferredStructuralValues.install + conv_lhs => rw [← hgood.2.2.2.1] + exact Function.update_eq_self _ _ + have hrun : resolveDeferredPositionValue target selection.context = + pure (some (completePrivatePosition target selection.context output)) := by + rw [resolveDeferredPositionValue_of_deferred_value target selection.context output + hgood.2.1 hgood.2.2.2.1] + simp [hnotHit, completePrivatePosition, hinstall] + rw [hrun] at hresolved + simp only [support_pure, Set.mem_singleton_iff, Option.some.injEq] at hresolved + subst resolved + exact safeTargetPendingLE_of_goodForRoots_pendingCovered hgood hcovered + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerSuffix.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerSuffix.lean new file mode 100644 index 00000000..b00c245e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerSuffix.lean @@ -0,0 +1,894 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerObservation +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerState +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalProbability + +/-! +# Synchronized lazy and eager suffixes + +Once both executions store the selected root, a safe pending difference at that root is preserved by every lazy-oracle computation. The eager observation log is the installed-root image of the lazy log. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +noncomputable def successfulObservedRootComparisonIndicator + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (target : Position) : + Option (ObservedCleanRunResult α) × Digest → Bool := + by + classical + exact fun result ↦ decide + (ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1) + +@[simp] theorem successfulObservedRootComparisonIndicator_eq_true_iff + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (target : Position) + (result : Option (ObservedCleanRunResult α) × Digest) : + successfulObservedRootComparisonIndicator table ordinal target result = true ↔ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 := by + classical + simp [successfulObservedRootComparisonIndicator] + +def ObservedSafeTargetPendingRel + (target : Position) (output : HashOutput) : + Option (ObservedCleanRunResult α) → Option (ObservedCleanRunResult α) → Prop + | none, none => True + | some left, some right => + left.value = right.value ∧ + left.table = right.table ∧ + left.remaining = right.remaining ∧ + right.observations = + left.observations.map (installPositionValueAtProbe target output) ∧ + SafeTargetPendingLE target output left.state right.state + | _, _ => False + +def FinalizedSafeTargetPendingRel + (target : Position) (output : HashOutput) : + Option (LazyRevealProbe.State Coordinate × (OtsSecretIndex → HashOutput)) → + Option (LazyRevealProbe.State Coordinate × (OtsSecretIndex → HashOutput)) → Prop + | none, none => True + | some left, some right => + left.2 = right.2 ∧ SafeTargetPendingLE target output left.1 right.1 + | _, _ => False + +set_option maxRecDepth 100000 in +theorem relTriple_finalizeCleanFromTable_safeTargetPending + (target : Position) (output : HashOutput) + (coordinates : List Coordinate) + (left right : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) + (hstate : SafeTargetPendingLE target output left right) : + RelTriple + (finalizeCleanFromTable coordinates left table) + (finalizeCleanFromTable coordinates right table) + (FinalizedSafeTargetPendingRel target output) := by + induction coordinates generalizing left right with + | nil => + exact relTriple_pure_pure ⟨rfl, hstate⟩ + | cons coordinate remaining ih => + rw [finalizeCleanFromTable.eq_def, finalizeCleanFromTable.eq_def] + have hvalue : left.values coordinate = right.values coordinate := by + rw [hstate.values] + cases hrightValue : right.values coordinate with + | some value => + have hleftValue : left.values coordinate = some value := by + rw [hvalue, hrightValue] + simp only [hleftValue, hrightValue] + exact ih (left.clearPending coordinate) (right.clearPending coordinate) + (hstate.clearPending coordinate) + | none => + have hleftValue : left.values coordinate = none := by + rw [hvalue, hrightValue] + simp only [hleftValue, hrightValue] + have hne : coordinate ≠ .position target := by + intro heq + subst coordinate + rw [hstate.right_target_value] at hrightValue + simp at hrightValue + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let value := table ⟨lay, tree, leafIdx, chainIdx⟩ + have hhit := hstate.hitAt_iff_of_ne + (.chainStart lay tree leafIdx chainIdx) value (by simp) + by_cases hleftHit : left.hitAt + (.chainStart lay tree leafIdx chainIdx) value + · have hrightHit := hhit.mp hleftHit + simp only [value, hleftHit, hrightHit, ↓reduceIte] + exact relTriple_pure_pure (by trivial) + · have hrightHit : ¬right.hitAt + (.chainStart lay tree leafIdx chainIdx) value := by + simpa [hhit] using hleftHit + simp only [value, hleftHit, hrightHit, ↓reduceIte] + exact ih + (left.complete (.chainStart lay tree leafIdx chainIdx) value) + (right.complete (.chainStart lay tree leafIdx chainIdx) value) + (hstate.complete_of_ne (.chainStart lay tree leafIdx chainIdx) value (by simp)) + | position position => + have hposition : Coordinate.position position ≠ .position target := hne + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + have hhit := hstate.hitAt_iff_of_ne (.position position) leftOutput hposition + by_cases hleftHit : left.hitAt (.position position) leftOutput + · have hrightHit := hhit.mp hleftHit + simp only [hleftHit, hrightHit, ↓reduceIte] + exact relTriple_pure_pure (by trivial) + · have hrightHit : ¬right.hitAt (.position position) leftOutput := by + simpa [hhit] using hleftHit + simp only [hleftHit, hrightHit, ↓reduceIte] + exact ih + (left.complete (.position position) leftOutput) + (right.complete (.position position) leftOutput) + (hstate.complete_of_ne (.position position) leftOutput hposition) + +set_option maxRecDepth 100000 in +theorem relTriple_finalizeCleanFromTable_safeTargetPending_coordinates + (target : Position) (output : HashOutput) + (left right : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) + (hstate : SafeTargetPendingLE target output left right) : + RelTriple + (finalizeCleanFromTable left.coordinates.toList left table) + (finalizeCleanFromTable right.coordinates.toList right table) + (FinalizedSafeTargetPendingRel target output) := by + by_cases hleftTarget : Coordinate.position target ∈ left.coordinates + · have hcoordinates := hstate.coordinates_eq_of_target_mem hleftTarget + rw [← hcoordinates] + exact relTriple_finalizeCleanFromTable_safeTargetPending target output + left.coordinates.toList left right table hstate + · have heval : + evalDist (finalizeCleanFromTable right.coordinates.toList right table) = + evalDist (finalizeCleanFromTable left.coordinates.toList left table) := by + by_cases hrightTarget : Coordinate.position target ∈ right.coordinates + · have herase := hstate.erase_target_coordinates_eq_of_not_mem_left hleftTarget + have hperm : List.Perm + (right.coordinates.toList.erase (.position target)) left.coordinates.toList := by + apply List.perm_of_nodup_nodup_toFinset_eq + · exact right.coordinates.nodup_toList.erase _ + · exact left.coordinates.nodup_toList + · apply Finset.ext + intro coordinate + simp only [List.mem_toFinset, right.coordinates.nodup_toList.mem_erase_iff, + Finset.mem_toList] + rw [← Finset.mem_erase, herase] + calc + _ = evalDist (finalizeCleanFromTable + (.position target :: right.coordinates.toList.erase (.position target)) + right table) := + evalDist_finalizeCleanFromTable_move_to_front (.position target) + right.coordinates.toList right table (by simpa using hrightTarget) + _ = evalDist (finalizeCleanFromTable + (right.coordinates.toList.erase (.position target)) + (right.clearPending (.position target)) table) := + congrArg evalDist + (finalizeCleanFromTable_cons_of_some (.position target) + (right.coordinates.toList.erase (.position target)) right table output + hstate.right_target_value) + _ = evalDist (finalizeCleanFromTable + (right.coordinates.toList.erase (.position target)) left table) := by + rw [← hstate.clearPending_target_eq, + clearPending_eq_self_of_not_mem_coordinates left (.position target) hleftTarget] + _ = _ := evalDist_finalizeCleanFromTable_perm hperm left table + · have heq := hstate.eq_of_target_not_mem_right_coordinates hrightTarget + subst right + rfl + let run := finalizeCleanFromTable left.coordinates.toList left table + have hbase := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + (relTriple_refl run) (fun result => result ∈ support run) + (fun result hresult => hresult) + have hpost : RelTriple run run (FinalizedSafeTargetPendingRel target output) := by + apply relTriple_post_mono hbase + intro leftFinal rightFinal hrelation + obtain ⟨rfl, hleftFinal⟩ := hrelation + cases leftFinal with + | none => trivial + | some final => + rcases final with ⟨finalState, finalTable⟩ + refine ⟨rfl, SafeTargetPendingLE.refl target output finalState ?_⟩ + exact values_eq_of_mem_finalizeCleanFromTable_of_not_mem + (.position target) left.coordinates.toList left table output + (by simpa using hleftTarget) hstate.target_value finalState finalTable hleftFinal + exact relTriple_of_evalDist_eq_right heval.symm hpost + +theorem relTriple_finishObservedCleanRunFromTable_safeTargetPending + (target : Position) (output : HashOutput) + (left right : ObservedCleanRunResult α) + (hrel : ObservedSafeTargetPendingRel target output (some left) (some right)) + (htarget : Coordinate.position target ∈ left.state.coordinates) : + RelTriple + (finishObservedCleanRunFromTable (some left)) + (finishObservedCleanRunFromTable (some right)) + (ObservedSafeTargetPendingRel target output) := by + rcases hrel with ⟨hvalue, htable, hremaining, hobservations, hstate⟩ + unfold finishObservedCleanRunFromTable + simp only + have hcoordinates := hstate.coordinates_eq_of_target_mem htarget + rw [← hcoordinates, ← htable] + apply relTriple_bind + (relTriple_finalizeCleanFromTable_safeTargetPending target output + left.state.coordinates.toList left.state right.state left.table hstate) + intro leftFinal rightFinal hfinal + cases leftFinal with + | none => + cases rightFinal with + | none => exact relTriple_pure_pure (by trivial) + | some rightFinal => simp [FinalizedSafeTargetPendingRel] at hfinal + | some leftFinal => + cases rightFinal with + | none => simp [FinalizedSafeTargetPendingRel] at hfinal + | some rightFinal => + rcases leftFinal with ⟨leftState, leftTable⟩ + rcases rightFinal with ⟨rightState, rightTable⟩ + rcases hfinal with ⟨hfinalTable, hfinalState⟩ + exact relTriple_pure_pure + ⟨hvalue, hfinalTable, hremaining, hobservations, hfinalState⟩ + +theorem relTriple_finishObservedCleanRunFromTable_safeTargetPending_coordinates + (target : Position) (output : HashOutput) + (left right : ObservedCleanRunResult α) + (hrel : ObservedSafeTargetPendingRel target output (some left) (some right)) : + RelTriple + (finishObservedCleanRunFromTable (some left)) + (finishObservedCleanRunFromTable (some right)) + (ObservedSafeTargetPendingRel target output) := by + rcases hrel with ⟨hvalue, htable, hremaining, hobservations, hstate⟩ + unfold finishObservedCleanRunFromTable + simp only + rw [← htable] + apply relTriple_bind + (relTriple_finalizeCleanFromTable_safeTargetPending_coordinates target output + left.state right.state left.table hstate) + intro leftFinal rightFinal hfinal + cases leftFinal with + | none => + cases rightFinal with + | none => exact relTriple_pure_pure (by trivial) + | some rightFinal => simp [FinalizedSafeTargetPendingRel] at hfinal + | some leftFinal => + cases rightFinal with + | none => simp [FinalizedSafeTargetPendingRel] at hfinal + | some rightFinal => + rcases leftFinal with ⟨leftState, leftTable⟩ + rcases rightFinal with ⟨rightState, rightTable⟩ + rcases hfinal with ⟨hfinalTable, hfinalState⟩ + exact relTriple_pure_pure + ⟨hvalue, hfinalTable, hremaining, hobservations, hfinalState⟩ + +theorem ObservedSafeTargetPendingRel.successfulDoomedFirstRootGoodForComparisonAt + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (target : Position) (output : HashOutput) (rightRoot : Digest) + (left right : ObservedCleanRunResult α) + (hrel : ObservedSafeTargetPendingRel target output (some left) (some right)) + (hroot : IsLayerRoot target) + (hselectedHit : ∀ selected : Fin left.observations.length, + selected.val = ordinal → + (left.observations.get selected).coordinate = .position target ∧ + (left.observations.get selected).revealedAtProbe = false ∧ + truncateHash output = (left.observations.get selected).candidate) + (hactualAvoid : ∀ earlier : Fin left.observations.length, + earlier.val < ordinal → + (left.observations.get earlier).toProbe ≠ + ⟨.position target, truncateHash output⟩) + (hgood : ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some left)) : + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some right) := by + rcases hrel with ⟨_hvalue, _htable, _hremaining, hobservations, hstate⟩ + rcases hgood with ⟨⟨⟨hfinish, hfirstRoot⟩, hposition⟩, hcomparison⟩ + rcases hfinish with ⟨leftFinal, hleftFinal⟩ + have hfinishRel := + relTriple_finishObservedCleanRunFromTable_safeTargetPending_coordinates + target output left right + ⟨_hvalue, _htable, _hremaining, hobservations, hstate⟩ + obtain ⟨rightFinal?, hrightFinal, hfinalRel⟩ := + exists_right_mem_support_of_relTriple hfinishRel hleftFinal + have hrightFinish : ∃ rightFinal, some rightFinal ∈ support + (finishObservedCleanRunFromTable (some right)) := by + cases rightFinal? with + | none => simp [ObservedSafeTargetPendingRel] at hfinalRel + | some rightFinal => exact ⟨rightFinal, hrightFinal⟩ + rcases hfirstRoot with ⟨selected, hselected, hfirst, _hselectedRoot⟩ + have hfirstInstalled := firstExistingHiddenHitAt_map_installPositionValueAtProbe + target output left ordinal hfirst hselectedHit hactualAvoid + let installed : ObservedCleanRunResult α := + { left with observations := + left.observations.map (installPositionValueAtProbe target output) } + have hfirstRight : FirstExistingHiddenHitAt right ordinal := by + apply firstExistingHiddenHitAt_of_observations_eq installed right ordinal + · exact hobservations.symm + · exact hfirstInstalled + have hpositionInstalled : + observedFirstLayerRootPosition? ordinal (some installed) = some target := by + exact (observedFirstLayerRootPosition?_map_installPositionValueAtProbe + target output left ordinal).trans hposition + have hpositionRight : + observedFirstLayerRootPosition? ordinal (some right) = some target := by + rw [← hpositionInstalled] + exact (observedFirstLayerRootPosition?_eq_of_observations_eq ordinal installed right + hobservations.symm).symm + have hfirstRootRight := firstExistingHiddenRootHitAt_of_first_of_position + right ordinal target hfirstRight hpositionRight + have hcomparisonRight : CandidatesAvoidRoot target rightRoot + (observedPrefixProbes ordinal (some right)) := by + rw [← observedPrefixProbes_eq_of_observations_eq ordinal installed right + hobservations.symm] + simpa [installed] using hcomparison + exact ⟨⟨⟨hrightFinish, hfirstRootRight⟩, + hpositionRight⟩, hcomparisonRight⟩ + +theorem ObservedSafeTargetPendingRel.pure + (target : Position) (output : HashOutput) + (leftObservations rightObservations : List CleanProbeObservation) + (leftState rightState : LazyRevealProbe.State Coordinate) + (fuel : Nat) (value : α) (table : OtsSecretIndex → HashOutput) + (hobservations : rightObservations = + leftObservations.map (installPositionValueAtProbe target output)) + (hstate : SafeTargetPendingLE target output leftState rightState) : + ObservedSafeTargetPendingRel target output + (some ⟨leftState, fuel, value, table, leftObservations⟩) + (some ⟨rightState, fuel, value, table, rightObservations⟩) := by + exact ⟨rfl, rfl, rfl, hobservations, hstate⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_runObservedCleanFromTable_safeTargetPending + (target : Position) (output : HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (leftObservations rightObservations : List CleanProbeObservation) + (leftState rightState : LazyRevealProbe.State Coordinate) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hobservations : rightObservations = + leftObservations.map (installPositionValueAtProbe target output)) + (hstate : SafeTargetPendingLE target output leftState rightState) : + RelTriple + (runObservedCleanFromTable leftObservations leftState fuel table computation) + (runObservedCleanFromTable rightObservations rightState fuel table computation) + (ObservedSafeTargetPendingRel target output) := by + induction computation using OracleComp.inductionOn generalizing + leftObservations rightObservations leftState rightState fuel with + | pure value => + rw [runObservedCleanFromTable, OracleComp.construct_pure, + runObservedCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure + (ObservedSafeTargetPendingRel.pure target output leftObservations rightObservations + leftState rightState fuel value table hobservations hstate) + | query_bind query next ih => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + runObservedCleanFromTable, OracleComp.construct_query_bind] + cases query with + | uniform n => + apply relTriple_bind (relTriple_refl (liftM (unifSpec.query n))) + intro leftValue rightValue hvalue + subst rightValue + exact ih leftValue leftObservations rightObservations leftState rightState fuel + hobservations hstate + | hashOutput => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftValue rightValue hvalue + subst rightValue + exact ih leftValue leftObservations rightObservations leftState rightState fuel + hobservations hstate + | ensure coordinate => + exact ih () leftObservations rightObservations + (leftState.ensure coordinate) (rightState.ensure coordinate) fuel + hobservations (hstate.ensure coordinate) + | probe coordinate candidate => + cases fuel with + | zero => + exact relTriple_pure_pure (by + simp [ObservedSafeTargetPendingRel]) + | succ remaining => + let leftObservation := cleanProbeObservation leftState coordinate candidate + let rightObservation := cleanProbeObservation rightState coordinate candidate + have hrightObservation : rightObservation = leftObservation := by + unfold leftObservation rightObservation cleanProbeObservation + simp [hstate.values, hstate.revealed] + have hnextObservations : + rightObservations ++ [rightObservation] = + (leftObservations ++ [leftObservation]).map + (installPositionValueAtProbe target output) := by + rw [List.map_append, hobservations, hrightObservation] + simp [leftObservation, + installPositionValueAtProbe_cleanProbeObservation_eq_self target output + leftState hstate.target_value] + have hrevealed : coordinate ∈ leftState.revealed ↔ + coordinate ∈ rightState.revealed := by + rw [hstate.revealed] + by_cases hleftRevealed : coordinate ∈ leftState.revealed + · have hrightRevealed : coordinate ∈ rightState.revealed := + hrevealed.mp hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + exact ih () (leftObservations ++ [leftObservation]) + (rightObservations ++ [rightObservation]) leftState rightState remaining + hnextObservations hstate + · have hrightRevealed : coordinate ∉ rightState.revealed := by + simpa [hrevealed] using hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + exact ih () (leftObservations ++ [leftObservation]) + (rightObservations ++ [rightObservation]) + (leftState.addPending coordinate candidate) + (rightState.addPending coordinate candidate) remaining + hnextObservations (hstate.addPending coordinate candidate) + | peek coordinate => + simp only + have hvalue : leftState.values coordinate = rightState.values coordinate := by + rw [hstate.values] + rw [hvalue] + exact ih (rightState.values coordinate) leftObservations rightObservations + leftState rightState fuel hobservations hstate + | publish coordinate => + simp only + exact ih () leftObservations rightObservations + (leftState.publish coordinate) (rightState.publish coordinate) fuel + hobservations (hstate.publish coordinate) + | reveal coordinate => + simp only + have hvalue : leftState.values coordinate = rightState.values coordinate := by + rw [hstate.values] + cases hrightValue : rightState.values coordinate with + | some value => + have hleftValue : leftState.values coordinate = some value := by + rw [hvalue, hrightValue] + simp only [hleftValue] + exact ih value leftObservations rightObservations leftState rightState fuel + hobservations hstate + | none => + have hleftValue : leftState.values coordinate = none := by + rw [hvalue, hrightValue] + simp only [hleftValue] + have hne : coordinate ≠ .position target := by + intro heq + subst coordinate + rw [hstate.right_target_value] at hrightValue + simp at hrightValue + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let value := table ⟨lay, tree, leafIdx, chainIdx⟩ + have hhit := hstate.hitAt_iff_of_ne + (.chainStart lay tree leafIdx chainIdx) value (by simp) + by_cases hleftHit : leftState.hitAt + (.chainStart lay tree leafIdx chainIdx) value + · have hrightHit := hhit.mp hleftHit + simp only [value, hleftHit, hrightHit, ↓reduceIte] + exact relTriple_pure_pure (by simp [ObservedSafeTargetPendingRel]) + · have hrightHit : ¬rightState.hitAt + (.chainStart lay tree leafIdx chainIdx) value := by + simpa [hhit] using hleftHit + simp only [value, hleftHit, hrightHit, ↓reduceIte] + exact ih value leftObservations rightObservations + (leftState.materialize (.chainStart lay tree leafIdx chainIdx) value) + (rightState.materialize (.chainStart lay tree leafIdx chainIdx) value) fuel + hobservations + (hstate.materialize_of_ne (.chainStart lay tree leafIdx chainIdx) value + (by simp)) + | position position => + have hposition : Coordinate.position position ≠ .position target := hne + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + have hhit := hstate.hitAt_iff_of_ne (.position position) leftOutput hposition + by_cases hleftHit : leftState.hitAt (.position position) leftOutput + · have hrightHit := hhit.mp hleftHit + simp only [hleftHit, hrightHit, ↓reduceIte] + exact relTriple_pure_pure (by simp [ObservedSafeTargetPendingRel]) + · have hrightHit : ¬rightState.hitAt (.position position) leftOutput := by + simpa [hhit] using hleftHit + simp only [hleftHit, hrightHit, ↓reduceIte] + exact ih leftOutput leftObservations rightObservations + (leftState.materialize (.position position) leftOutput) + (rightState.materialize (.position position) leftOutput) fuel + hobservations + (hstate.materialize_of_ne (.position position) leftOutput hposition) + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_observedMaterializedBoundary_safeTargetPending + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (output : HashOutput) (hroot : IsLayerRoot target) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (leftObservations rightObservations : List CleanProbeObservation) + (leftState rightState : LazyRevealProbe.State Coordinate) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) + (hobservations : rightObservations = + leftObservations.map (installPositionValueAtProbe target output)) + (hstate : SafeTargetPendingLE target output leftState rightState) : + RelTriple + (observedMaterializedBoundary parameter root ftsSecret computation leftObservations + leftState fuel table cache) + (observedMaterializedBoundary parameter root ftsSecret computation rightObservations + rightState fuel table cache) + (ObservedSafeTargetPendingRel target output) := by + induction computation using OracleComp.inductionOn generalizing + leftObservations rightObservations leftState rightState fuel cache with + | pure value => + rw [observedMaterializedBoundary, OracleComp.construct_pure, + observedMaterializedBoundary, OracleComp.construct_pure] + exact relTriple_pure_pure + (ObservedSafeTargetPendingRel.pure target output leftObservations rightObservations + leftState rightState fuel (value, cache) table hobservations hstate) + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind, + observedMaterializedBoundary, OracleComp.construct_query_bind] + have continueAfter + (leftRun rightRun : ProbComp (Option (ObservedCleanRunResult + ((OracleWorld + SigningSpec).Range query × SplitHashCache)))) + (hrun : RelTriple leftRun rightRun + (ObservedSafeTargetPendingRel target output)) : + RelTriple + (leftRun >>= fun result => + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state result.remaining table + result.value.2) + (rightRun >>= fun result => + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state result.remaining table + result.value.2) + (ObservedSafeTargetPendingRel target output) := by + apply relTriple_bind hrun + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure (by trivial) + | some rightResult => simp [ObservedSafeTargetPendingRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [ObservedSafeTargetPendingRel] at hresult + | some rightResult => + simp only + rcases hresult with + ⟨hvalue, _htable, hremaining, hnextObservations, hnextState⟩ + have houtput : leftResult.value.1 = rightResult.value.1 := + congrArg Prod.fst hvalue + have hnextCache : leftResult.value.2 = rightResult.value.2 := + congrArg Prod.snd hvalue + rw [← houtput, ← hnextCache, ← hremaining] + exact ih leftResult.value.1 leftResult.observations rightResult.observations + leftResult.state rightResult.state leftResult.remaining leftResult.value.2 + hnextObservations hnextState + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + change Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α at next + simp only + have hstep := relTriple_runObservedCleanFromTable_safeTargetPending target output + ((splitUniformImpl n).run cache) leftObservations rightObservations leftState + rightState fuel table hobservations hstate + convert continueAfter _ _ hstep using 1 <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + | inr input => + change HashOutput → OracleComp (OracleWorld + SigningSpec) α at next + simp only + let leftPublic := materializedCanonicalContext table leftState + let rightPublic := materializedCanonicalContext table rightState + have hpublicValues : leftPublic.state.values = rightPublic.state.values := + materializedCanonicalContext_values_eq_of_probeStateLE table + (hstate.toProbeStateLE hroot) + have hplan : purePlanProbingHashQuery parameter input leftPublic.state = + purePlanProbingHashQuery parameter input rightPublic.state := + purePlanProbingHashQuery_eq_of_values_eq hpublicValues parameter input + let plan := purePlanProbingHashQuery parameter input leftPublic.state + have hexecutor : + probingHashQueryAfterRootAwarePublicPlan parameter input leftPublic.state plan = + probingHashQueryAfterRootAwarePublicPlan parameter input rightPublic.state + plan := + probingHashQueryAfterRootAwarePublicPlan_eq_of_values_eq parameter input + hpublicValues plan + rw [← hplan, ← hexecutor] + have hstep := relTriple_runObservedCleanFromTable_safeTargetPending target output + ((probingHashQueryAfterRootAwarePublicPlan parameter input leftPublic.state + plan).run cache) + leftObservations rightObservations leftState rightState fuel table hobservations + hstate + convert continueAfter _ _ hstep using 1 <;> + simp only [leftPublic, plan, observedMaterializedBoundary] <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + | inr message => + change Option Signature → OracleComp (OracleWorld + SigningSpec) α at next + simp only + have hstep := relTriple_runObservedCleanFromTable_safeTargetPending target output + ((maskedSign parameter root ftsSecret message).run cache) + leftObservations rightObservations leftState rightState fuel table hobservations hstate + convert continueAfter _ _ hstep using 1 <;> + simp only [observedMaterializedBoundary] <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_observedMaterializedBoundary_after_target_resolution + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (output : HashOutput) (rightRoot : Digest) + (ordinal : Nat) (hroot : IsLayerRoot target) + (selection : PrivateOrdinalSelection) + (hgood : selection.GoodForRoots target output rightRoot ordinal) + (hcovered : PendingCoveredBy (selection.candidates.take ordinal) selection.context) + (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target selection.context)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) : + RelTriple + (observedMaterializedBoundary parameter root ftsSecret computation observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache) + (observedMaterializedBoundary parameter root ftsSecret computation + (observations.map (installPositionValueAtProbe target output)) + (materializedDeferredState + { selection.context with + values := selection.context.values.install target output }) + fuel table cache) + (ObservedSafeTargetPendingRel target output) := by + apply relTriple_observedMaterializedBoundary_safeTargetPending parameter root ftsSecret target + output hroot computation observations + (observations.map (installPositionValueAtProbe target output)) + (materializedDeferredState resolved.toDeferredContext) + (materializedDeferredState + { selection.context with + values := selection.context.values.install target output }) + fuel table cache rfl + exact safeTargetPendingLE_of_resolveDeferredPositionValue hgood hcovered resolved hresolved + +theorem relTriple_observedMaterializedBoundary_after_target_resolution_successful + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (output : HashOutput) (rightRoot : Digest) + (ordinal : Nat) (hroot : IsLayerRoot target) + (selection : PrivateOrdinalSelection) + (hgood : selection.GoodForRoots target output rightRoot ordinal) + (hcovered : PendingCoveredBy (selection.candidates.take ordinal) selection.context) + (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target selection.context)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) + (hselectedHit : ∀ result : ObservedCleanRunResult (α × SplitHashCache), + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result) → + ∀ selected : Fin result.observations.length, selected.val = ordinal → + (result.observations.get selected).coordinate = .position target ∧ + (result.observations.get selected).revealedAtProbe = false ∧ + truncateHash output = (result.observations.get selected).candidate) + (hactualAvoid : ∀ result : ObservedCleanRunResult (α × SplitHashCache), + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result) → + ∀ earlier : Fin result.observations.length, earlier.val < ordinal → + (result.observations.get earlier).toProbe ≠ + ⟨.position target, truncateHash output⟩) : + RelTriple + (observedMaterializedBoundary parameter root ftsSecret computation observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache) + (observedMaterializedBoundary parameter root ftsSecret computation + (observations.map (installPositionValueAtProbe target output)) + (materializedDeferredState + { selection.context with + values := selection.context.values.install target output }) + fuel table cache) + (fun lazy eager ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot lazy → + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot eager) := by + have hbase := relTriple_observedMaterializedBoundary_after_target_resolution parameter root + ftsSecret target output rightRoot ordinal hroot selection hgood hcovered resolved hresolved + computation observations fuel table cache + apply relTriple_post_mono hbase + intro lazy eager hrelation hlazy + cases lazy with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hlazy + | some result => + cases eager with + | none => simp [ObservedSafeTargetPendingRel] at hrelation + | some eagerResult => + exact ObservedSafeTargetPendingRel.successfulDoomedFirstRootGoodForComparisonAt table + ordinal target output rightRoot result eagerResult hrelation hroot + (hselectedHit result hlazy) (hactualAvoid result hlazy) hlazy + +theorem relTriple_indicator_observedMaterializedBoundary_after_target_resolution + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (output : HashOutput) (rightRoot : Digest) + (ordinal : Nat) (hroot : IsLayerRoot target) + (selection : PrivateOrdinalSelection) + (hgood : selection.GoodForRoots target output rightRoot ordinal) + (hcovered : PendingCoveredBy (selection.candidates.take ordinal) selection.context) + (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target selection.context)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) + (hselectedHit : ∀ result : ObservedCleanRunResult (α × SplitHashCache), + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result) → + ∀ selected : Fin result.observations.length, selected.val = ordinal → + (result.observations.get selected).coordinate = .position target ∧ + (result.observations.get selected).revealedAtProbe = false ∧ + truncateHash output = (result.observations.get selected).candidate) + (hactualAvoid : ∀ result : ObservedCleanRunResult (α × SplitHashCache), + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result) → + ∀ earlier : Fin result.observations.length, earlier.val < ordinal → + (result.observations.get earlier).toProbe ≠ + ⟨.position target, truncateHash output⟩) : + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) <$> + observedMaterializedBoundary parameter root ftsSecret computation observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) <$> + observedMaterializedBoundary parameter root ftsSecret computation + (observations.map (installPositionValueAtProbe target output)) + (materializedDeferredState + { selection.context with + values := selection.context.values.install target output }) + fuel table cache) + (fun lazy eager => lazy = true → eager = true) := by + have hbase := relTriple_observedMaterializedBoundary_after_target_resolution_successful + parameter root ftsSecret target output rightRoot ordinal hroot selection hgood hcovered + resolved hresolved computation observations fuel table cache hselectedHit hactualAvoid + apply relTriple_map + apply relTriple_post_mono hbase + intro lazy eager hrelation hlazy + have hlazyGood : + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot lazy := by + simpa using hlazy + have heagerGood := hrelation hlazyGood + simpa using heagerGood + +theorem relTriple_observedMaterializedBoundary_after_target_resolution_successful_supported + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (output : HashOutput) (rightRoot : Digest) + (ordinal : Nat) (hroot : IsLayerRoot target) + (selection : PrivateOrdinalSelection) + (hgood : selection.GoodForRoots target output rightRoot ordinal) + (hcovered : PendingCoveredBy (selection.candidates.take ordinal) selection.context) + (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target selection.context)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) + (hselectedHit : ∀ result : ObservedCleanRunResult (α × SplitHashCache), + some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache) → + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result) → + ∀ selected : Fin result.observations.length, selected.val = ordinal → + (result.observations.get selected).coordinate = .position target ∧ + (result.observations.get selected).revealedAtProbe = false ∧ + truncateHash output = (result.observations.get selected).candidate) + (hactualAvoid : ∀ result : ObservedCleanRunResult (α × SplitHashCache), + some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache) → + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result) → + ∀ earlier : Fin result.observations.length, earlier.val < ordinal → + (result.observations.get earlier).toProbe ≠ + ⟨.position target, truncateHash output⟩) : + RelTriple + (observedMaterializedBoundary parameter root ftsSecret computation observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache) + (observedMaterializedBoundary parameter root ftsSecret computation + (observations.map (installPositionValueAtProbe target output)) + (materializedDeferredState + { selection.context with + values := selection.context.values.install target output }) + fuel table cache) + (fun lazy eager ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot lazy → + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot eager) := by + let lazyRun := observedMaterializedBoundary parameter root ftsSecret computation observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache + have hbase := relTriple_observedMaterializedBoundary_after_target_resolution parameter root + ftsSecret target output rightRoot ordinal hroot selection hgood hcovered resolved hresolved + computation observations fuel table cache + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support lazyRun) (fun _ hresult => hresult) + apply relTriple_post_mono hsupported + intro lazy eager hrelation hlazy + rcases hrelation with ⟨hrelation, hlazySupport⟩ + cases lazy with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt] at hlazy + | some result => + cases eager with + | none => simp [ObservedSafeTargetPendingRel] at hrelation + | some eagerResult => + exact ObservedSafeTargetPendingRel.successfulDoomedFirstRootGoodForComparisonAt table + ordinal target output rightRoot result eagerResult hrelation hroot + (hselectedHit result (by simpa [lazyRun] using hlazySupport) hlazy) + (hactualAvoid result (by simpa [lazyRun] using hlazySupport) hlazy) hlazy + +theorem relTriple_indicator_observedMaterializedBoundary_after_target_resolution_supported + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (output : HashOutput) (rightRoot : Digest) + (ordinal : Nat) (hroot : IsLayerRoot target) + (selection : PrivateOrdinalSelection) + (hgood : selection.GoodForRoots target output rightRoot ordinal) + (hcovered : PendingCoveredBy (selection.candidates.take ordinal) selection.context) + (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue target selection.context)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) + (hselectedHit : ∀ result : ObservedCleanRunResult (α × SplitHashCache), + some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache) → + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result) → + ∀ selected : Fin result.observations.length, selected.val = ordinal → + (result.observations.get selected).coordinate = .position target ∧ + (result.observations.get selected).revealedAtProbe = false ∧ + truncateHash output = (result.observations.get selected).candidate) + (hactualAvoid : ∀ result : ObservedCleanRunResult (α × SplitHashCache), + some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache) → + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result) → + ∀ earlier : Fin result.observations.length, earlier.val < ordinal → + (result.observations.get earlier).toProbe ≠ + ⟨.position target, truncateHash output⟩) : + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) <$> + observedMaterializedBoundary parameter root ftsSecret computation observations + (materializedDeferredState resolved.toDeferredContext) fuel table cache) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed => (observed, rightRoot)) <$> + observedMaterializedBoundary parameter root ftsSecret computation + (observations.map (installPositionValueAtProbe target output)) + (materializedDeferredState + { selection.context with + values := selection.context.values.install target output }) + fuel table cache) + (fun lazy eager => lazy = true → eager = true) := by + have hbase := + relTriple_observedMaterializedBoundary_after_target_resolution_successful_supported + parameter root ftsSecret target output rightRoot ordinal hroot selection hgood hcovered + resolved hresolved computation observations fuel table cache hselectedHit hactualAvoid + apply relTriple_map + apply relTriple_post_mono hbase + intro lazy eager hrelation hlazy + have hlazyGood : + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target rightRoot lazy := by + simpa using hlazy + have heagerGood := hrelation hlazyGood + simpa using heagerGood + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootSharedPrefix.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootSharedPrefix.lean new file mode 100644 index 00000000..674b3e7c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootSharedPrefix.lean @@ -0,0 +1,964 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootEager + +/-! +# Shared observed and root-selection prefix + +The observed materialized execution and the failure-retaining root-selection outcome execute the +same prefix. This module runs that prefix once. When selection or failure becomes determined, it +freezes the outcome and lets only the observed execution finish. The two projections are therefore +the original observed run and the original materialized outcome, while their joint support retains +the correlation needed to exclude a conservative failure on a successful observed run. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable + +private theorem spmf_bind_const_of_no_failure_local + {p : SPMF α} (hp : Pr[⊥ | p] = 0) (q : SPMF β) : + (p >>= fun _ => q) = q := by + apply SPMF.ext + intro value + change Pr[= value | p >>= fun _ => q] = Pr[= value | q] + rw [probOutput_bind_eq_tsum, ENNReal.tsum_mul_right, tsum_probOutput_eq_sub, hp, + tsub_zero, one_mul] + +private theorem map_bind_of_map_eq + (p : ProbComp α) (f : α → ProbComp β) (project : β → γ) + (observe : α → δ) (q : ProbComp δ) (g : δ → ProbComp γ) + (hp : observe <$> p = q) + (hf : ∀ value, project <$> f value = g (observe value)) : + project <$> (p >>= f) = q >>= g := by + rw [map_bind, ← hp, bind_map_left] + apply bind_congr + exact hf + +private theorem evalDist_map_bind_congr + (p : ProbComp α) (f : α → ProbComp β) (project : β → γ) + (g : α → ProbComp γ) + (hf : ∀ value, evalDist (project <$> f value) = evalDist (g value)) : + evalDist (project <$> (p >>= f)) = evalDist (p >>= g) := by + rw [map_bind, evalDist_bind, evalDist_bind] + apply bind_congr + exact hf + +def observedResultOfDetailed + (observations : List CleanProbeObservation) : + DirectDetailedResult (α × SplitHashCache) → + Option (ObservedCleanRunResult (α × SplitHashCache)) := + projectDirectDetailedObserved observations + +theorem map_observedResultOfDetailed_run_eq_observed_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) + (α × SplitHashCache)) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hprobeFree : computation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) : + observedResultOfDetailed observations <$> + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table computation = + runObservedCleanFromTable observations state fuel table computation := by + unfold observedResultOfDetailed + calc + _ = attachCleanProbeObservations observations <$> + (projectDirectDetailedClean <$> + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + computation) := by + rw [Functor.map_map] + apply map_congr + intro result + exact projectDirectDetailedObserved_eq_attach observations result + _ = attachCleanProbeObservations observations <$> + runCleanFromTable state fuel table computation := by + rw [map_projectDirectDetailedClean_run_eq_clean] + _ = _ := map_attachCleanProbeObservations_runCleanFromTable_of_probeFree computation + observations state fuel table hprobeFree + +noncomputable def finishObservedWithSelectionOutcome + (parameter : PublicParameter) (publicRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (outcome : MaterializedSelectionOutcome) : + ProbComp + (Option (ObservedCleanRunResult (α × SplitHashCache)) × + MaterializedSelectionOutcome) := do + let observed ← observedMaterializedBoundary parameter publicRoot ftsSecret computation + observations state fuel table cache + pure (observed, outcome) + +theorem map_fst_finishObservedWithSelectionOutcome + (parameter : PublicParameter) (publicRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (outcome : MaterializedSelectionOutcome) : + Prod.fst <$> finishObservedWithSelectionOutcome parameter publicRoot ftsSecret computation + observations state fuel table cache outcome = + observedMaterializedBoundary parameter publicRoot ftsSecret computation observations state + fuel table cache := by + simp [finishObservedWithSelectionOutcome, map_eq_bind_pure_comp, bind_assoc] + +theorem map_snd_finishObservedWithSelectionOutcome + (parameter : PublicParameter) (publicRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (outcome : MaterializedSelectionOutcome) : + evalDist (Prod.snd <$> finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + computation observations state fuel table cache outcome) = + evalDist (pure outcome : ProbComp MaterializedSelectionOutcome) := by + simp only [finishObservedWithSelectionOutcome, map_bind, map_pure] + rw [evalDist_bind] + exact spmf_bind_const_of_no_failure_local + (p := evalDist (observedMaterializedBoundary parameter publicRoot ftsSecret computation + observations state fuel table cache)) + (probFailure_eq_zero (mx := observedMaterializedBoundary parameter publicRoot ftsSecret + computation observations state fuel table cache)) + (evalDist (pure outcome : ProbComp MaterializedSelectionOutcome)) + +noncomputable def continueObservedRootSelectionSharedPrefix + (parameter : PublicParameter) (publicRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (next : α → OracleComp (OracleWorld + SigningSpec) β) + (observations : List CleanProbeObservation) (candidates : List Probe) + (table : OtsSecretIndex → HashOutput) + (recursivelyRun : α → List CleanProbeObservation → List Probe → + LazyRevealProbe.State Coordinate → Nat → (OtsSecretIndex → HashOutput) → + SplitHashCache → + ProbComp + (Option (ObservedCleanRunResult (β × SplitHashCache)) × + MaterializedSelectionOutcome)) : + DirectDetailedResult (α × SplitHashCache) → + ProbComp + (Option (ObservedCleanRunResult (β × SplitHashCache)) × + MaterializedSelectionOutcome) := by + classical + exact fun detailed => match detailed with + | .stopped _ => pure (none, .failed) + | .done result => + if DeferredCompletable table (directDeferredContext result.context.state) then + if Coordinate.position target ∈ result.context.state.revealed then + finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (next result.value.1) observations result.context.state result.remaining table + result.value.2 .failed + else + recursivelyRun result.value.1 observations candidates result.context.state + result.remaining table result.value.2 + else + finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (next result.value.1) observations result.context.state result.remaining table + result.value.2 .failed + +theorem map_fst_continueObservedRootSelectionSharedPrefix + (parameter : PublicParameter) (publicRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (next : α → OracleComp (OracleWorld + SigningSpec) β) + (observations : List CleanProbeObservation) (candidates : List Probe) + (table : OtsSecretIndex → HashOutput) + (recursivelyRun : α → List CleanProbeObservation → List Probe → + LazyRevealProbe.State Coordinate → Nat → (OtsSecretIndex → HashOutput) → + SplitHashCache → + ProbComp + (Option (ObservedCleanRunResult (β × SplitHashCache)) × + MaterializedSelectionOutcome)) + (hrecursive : ∀ value state fuel cache, + Prod.fst <$> recursivelyRun value observations candidates state fuel table cache = + observedMaterializedBoundary parameter publicRoot ftsSecret (next value) observations + state fuel table cache) + (detailed : DirectDetailedResult (α × SplitHashCache)) : + Prod.fst <$> continueObservedRootSelectionSharedPrefix parameter publicRoot ftsSecret target + next observations candidates table recursivelyRun detailed = + match observedResultOfDetailed observations detailed with + | none => pure none + | some result => + observedMaterializedBoundary parameter publicRoot ftsSecret (next result.value.1) + result.observations result.state result.remaining table result.value.2 := by + cases detailed with + | stopped reason => rfl + | done result => + unfold continueObservedRootSelectionSharedPrefix observedResultOfDetailed + projectDirectDetailedObserved + by_cases hcompletable : + DeferredCompletable table (directDeferredContext result.context.state) + · simp only [hcompletable, ↓reduceIte] + by_cases hrevealed : Coordinate.position target ∈ result.context.state.revealed + · simp only [hrevealed, ↓reduceIte] + exact map_fst_finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (next result.value.1) observations result.context.state result.remaining table + result.value.2 .failed + · simp only [hrevealed, ↓reduceIte] + exact hrecursive result.value.1 result.context.state result.remaining result.value.2 + · simp only [hcompletable, ↓reduceIte] + exact map_fst_finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (next result.value.1) observations result.context.state result.remaining table + result.value.2 .failed + +theorem evalDist_map_snd_continueObservedRootSelectionSharedPrefix + (parameter : PublicParameter) (publicRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (next : α → OracleComp (OracleWorld + SigningSpec) β) + (observations : List CleanProbeObservation) (candidates : List Probe) + (table : OtsSecretIndex → HashOutput) + (recursivelyRun : α → List CleanProbeObservation → List Probe → + LazyRevealProbe.State Coordinate → Nat → (OtsSecretIndex → HashOutput) → + SplitHashCache → + ProbComp + (Option (ObservedCleanRunResult (β × SplitHashCache)) × + MaterializedSelectionOutcome)) + (outcomeObserve : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp MaterializedSelectionOutcome) + (hrecursive : ∀ value state fuel cache, + evalDist (Prod.snd <$> + recursivelyRun value observations candidates state fuel table cache) = + evalDist (outcomeObserve state fuel value cache candidates)) + (detailed : DirectDetailedResult (α × SplitHashCache)) : + evalDist (Prod.snd <$> + continueObservedRootSelectionSharedPrefix parameter publicRoot ftsSecret target next + observations candidates table recursivelyRun detailed) = + evalDist + (finishMaterializedSelectionOutcome target table outcomeObserve candidates detailed) := by + cases detailed with + | stopped reason => simp [continueObservedRootSelectionSharedPrefix, + finishMaterializedSelectionOutcome] + | done result => + unfold continueObservedRootSelectionSharedPrefix finishMaterializedSelectionOutcome + by_cases hcompletable : + DeferredCompletable table (directDeferredContext result.context.state) + · simp only [hcompletable, ↓reduceIte] + by_cases hrevealed : Coordinate.position target ∈ result.context.state.revealed + · simp only [hrevealed, ↓reduceIte] + exact map_snd_finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (next result.value.1) observations result.context.state result.remaining table + result.value.2 .failed + · simp only [hrevealed, ↓reduceIte] + exact hrecursive result.value.1 result.context.state result.remaining result.value.2 + · simp only [hcompletable, ↓reduceIte] + exact map_snd_finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (next result.value.1) observations result.context.state result.remaining table + result.value.2 .failed + +noncomputable def materializedActualRootAwareOrdinalSelectionOutcome + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp MaterializedSelectionOutcome := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + List Probe → LazyRevealProbe.State Coordinate → Nat → + (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp MaterializedSelectionOutcome) + (fun _value candidates _state _fuel _table _cache => + if hselected : ordinal < candidates.length then + pure (.finished (some (candidates.get ⟨ordinal, hselected⟩))) + else pure (.finished none)) + (fun query next recursivelyRun candidates state fuel table cache => + if hselected : ordinal < candidates.length then + pure (.finished (some (candidates.get ⟨ordinal, hselected⟩))) + else + match query with + | .inl (.inl n) => + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + ((splitUniformImpl n).run cache) >>= + finishMaterializedSelectionOutcome target table + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache) + candidates + | .inl (.inr input) => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + if hnextSelected : ordinal < nextCandidates.length then + pure (.finished (some (nextCandidates.get ⟨ordinal, hnextSelected⟩))) + else if RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? then + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache) >>= + finishMaterializedSelectionOutcome target table + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache) + nextCandidates + else pure (.finished none) + | .inr message => + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + ((maskedSign parameter publicRoot ftsSecret message).run cache) >>= + finishMaterializedSelectionOutcome target table + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache) + candidates) + computation candidates state fuel table cache + +theorem materializedActualRootAwareOrdinalSelectionOutcome_uniform_query_bind + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (n : Nat) + (next : Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + materializedActualRootAwareOrdinalSelectionOutcome ordinal parameter publicRoot target leftRoot + rightRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inl n))) >>= next) candidates state fuel table cache = + if hselected : ordinal < candidates.length then + pure (.finished (some (candidates.get ⟨ordinal, hselected⟩))) + else + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + ((splitUniformImpl n).run cache) >>= + finishMaterializedSelectionOutcome target table + (fun nextState remaining value nextCache laterCandidates => + materializedActualRootAwareOrdinalSelectionOutcome ordinal parameter publicRoot + target leftRoot rightRoot ftsSecret (next value) laterCandidates nextState + remaining table nextCache) + candidates := by + rw [materializedActualRootAwareOrdinalSelectionOutcome, + OracleComp.construct_query_bind] + unfold materializedActualRootAwareOrdinalSelectionOutcome + rfl + +theorem materializedActualRootAwareOrdinalSelectionOutcome_hash_query_bind + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + materializedActualRootAwareOrdinalSelectionOutcome ordinal parameter publicRoot target leftRoot + rightRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) candidates state fuel table cache = + if hselected : ordinal < candidates.length then + pure (.finished (some (candidates.get ⟨ordinal, hselected⟩))) + else + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + if hnextSelected : ordinal < nextCandidates.length then + pure (.finished (some (nextCandidates.get ⟨ordinal, hnextSelected⟩))) + else if RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? then + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache) >>= + finishMaterializedSelectionOutcome target table + (fun nextState remaining value nextCache laterCandidates => + materializedActualRootAwareOrdinalSelectionOutcome ordinal parameter publicRoot + target leftRoot rightRoot ftsSecret (next value) laterCandidates nextState + remaining table nextCache) + nextCandidates + else pure (.finished none) := by + rw [materializedActualRootAwareOrdinalSelectionOutcome, + OracleComp.construct_query_bind] + unfold materializedActualRootAwareOrdinalSelectionOutcome + rfl + +theorem materializedActualRootAwareOrdinalSelectionOutcome_sign_query_bind + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : SignRequest) + (next : Option Signature → OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + materializedActualRootAwareOrdinalSelectionOutcome ordinal parameter publicRoot target leftRoot + rightRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) (Sum.inr message)) >>= next) + candidates state fuel table cache = + if hselected : ordinal < candidates.length then + pure (.finished (some (candidates.get ⟨ordinal, hselected⟩))) + else + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + ((maskedSign parameter publicRoot ftsSecret message).run cache) >>= + finishMaterializedSelectionOutcome target table + (fun nextState remaining value nextCache laterCandidates => + materializedActualRootAwareOrdinalSelectionOutcome ordinal parameter publicRoot + target leftRoot rightRoot ftsSecret (next value) laterCandidates nextState + remaining table nextCache) + candidates := by + rw [materializedActualRootAwareOrdinalSelectionOutcome, + OracleComp.construct_query_bind] + unfold materializedActualRootAwareOrdinalSelectionOutcome + rfl + +noncomputable def observedRootSelectionSharedPrefix + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) (candidates : List Probe) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp + (Option (ObservedCleanRunResult (α × SplitHashCache)) × + MaterializedSelectionOutcome) := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + List CleanProbeObservation → List Probe → LazyRevealProbe.State Coordinate → Nat → + (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp + (Option (ObservedCleanRunResult (α × SplitHashCache)) × + MaterializedSelectionOutcome)) + (fun value observations candidates state fuel table cache => + let observed : ObservedCleanRunResult (α × SplitHashCache) := + ⟨state, fuel, (value, cache), table, observations⟩ + if hselected : ordinal < candidates.length then + pure (some observed, .finished (some (candidates.get ⟨ordinal, hselected⟩))) + else pure (some observed, .finished none)) + (fun query next recursivelyRun observations candidates state fuel table cache => + if hselected : ordinal < candidates.length then + finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (liftM (OracleSpec.query query) >>= next) observations state fuel table cache + (.finished (some (candidates.get ⟨ordinal, hselected⟩))) + else + match query with + | .inl (.inl n) => do + let detailed ← runDirectResolvedDetailedFromTable (directDeferredContext state) fuel + table ((splitUniformImpl n).run cache) + continueObservedRootSelectionSharedPrefix parameter publicRoot ftsSecret target next + observations candidates table recursivelyRun detailed + | .inl (.inr input) => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + let nextObservations := observationsAfterCandidate observations state candidate? + if hnextSelected : ordinal < nextCandidates.length then + finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (liftM (OracleSpec.query (Sum.inl (Sum.inr input))) >>= next) observations state fuel + table cache + (.finished (some (nextCandidates.get ⟨ordinal, hnextSelected⟩))) + else if RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? then do + let detailed ← runDirectResolvedDetailedFromTable (directDeferredContext state) fuel + table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state plan).run + cache) + continueObservedRootSelectionSharedPrefix parameter publicRoot ftsSecret target next + nextObservations nextCandidates table recursivelyRun detailed + else + finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (liftM (OracleSpec.query (Sum.inl (Sum.inr input))) >>= next) observations state fuel + table cache (.finished none) + | .inr message => do + let detailed ← runDirectResolvedDetailedFromTable (directDeferredContext state) fuel + table ((maskedSign parameter publicRoot ftsSecret message).run cache) + continueObservedRootSelectionSharedPrefix parameter publicRoot ftsSecret target next + observations candidates table recursivelyRun detailed) + computation observations candidates state fuel table cache + +theorem observedRootSelectionSharedPrefix_query_bind + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range query → + OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) (candidates : List Probe) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + observedRootSelectionSharedPrefix ordinal parameter publicRoot target leftRoot rightRoot + ftsSecret (liftM (OracleSpec.query query) >>= next) observations candidates state fuel table + cache = (if hselected : ordinal < candidates.length then + finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (liftM (OracleSpec.query query) >>= next) observations state fuel table cache + (.finished (some (candidates.get ⟨ordinal, hselected⟩))) + else + match query with + | .inl (.inl n) => do + let detailed ← runDirectResolvedDetailedFromTable (directDeferredContext state) fuel + table ((splitUniformImpl n).run cache) + continueObservedRootSelectionSharedPrefix parameter publicRoot ftsSecret target next + observations candidates table + (fun value => + observedRootSelectionSharedPrefix ordinal parameter publicRoot target leftRoot + rightRoot ftsSecret (next value)) + detailed + | .inl (.inr input) => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + let nextObservations := observationsAfterCandidate observations state candidate? + if hnextSelected : ordinal < nextCandidates.length then + finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (liftM (OracleSpec.query (Sum.inl (Sum.inr input))) >>= next) observations state fuel + table cache + (.finished (some (nextCandidates.get ⟨ordinal, hnextSelected⟩))) + else if RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? then do + let detailed ← runDirectResolvedDetailedFromTable (directDeferredContext state) fuel + table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache) + continueObservedRootSelectionSharedPrefix parameter publicRoot ftsSecret target next + nextObservations nextCandidates table + (fun value => + observedRootSelectionSharedPrefix ordinal parameter publicRoot target leftRoot + rightRoot ftsSecret (next value)) + detailed + else + finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (liftM (OracleSpec.query (Sum.inl (Sum.inr input))) >>= next) observations state fuel + table cache (.finished none) + | .inr message => do + let detailed ← runDirectResolvedDetailedFromTable (directDeferredContext state) fuel + table ((maskedSign parameter publicRoot ftsSecret message).run cache) + continueObservedRootSelectionSharedPrefix parameter publicRoot ftsSecret target next + observations candidates table + (fun value => + observedRootSelectionSharedPrefix ordinal parameter publicRoot target leftRoot + rightRoot ftsSecret (next value)) + detailed) := by + rw [observedRootSelectionSharedPrefix, OracleComp.construct_query_bind] + unfold observedRootSelectionSharedPrefix + cases query with + | inl worldQuery => cases worldQuery <;> rfl + | inr message => rfl + +theorem observedMaterializedBoundary_uniform_query_bind + (parameter : PublicParameter) (publicRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (n : Nat) + (next : Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + observedMaterializedBoundary parameter publicRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inl n))) >>= next) observations state fuel table + cache = (do + let result ← runObservedCleanFromTable observations state fuel table + ((splitUniformImpl n).run cache) + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter publicRoot ftsSecret (next result.value.1) + result.observations result.state result.remaining table result.value.2) := by + rw [observedMaterializedBoundary, OracleComp.construct_query_bind] + unfold observedMaterializedBoundary + rfl + +theorem observedMaterializedBoundary_hash_query_bind + (parameter : PublicParameter) (publicRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + observedMaterializedBoundary parameter publicRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (Sum.inl (Sum.inr input))) >>= next) observations state fuel table + cache = (do + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let result ← runObservedCleanFromTable observations state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state plan).run + cache) + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter publicRoot ftsSecret (next result.value.1) + result.observations result.state result.remaining table result.value.2) := by + rw [observedMaterializedBoundary, OracleComp.construct_query_bind] + unfold observedMaterializedBoundary + rfl + +theorem observedMaterializedBoundary_sign_query_bind + (parameter : PublicParameter) (publicRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : SignRequest) + (next : Option Signature → OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + observedMaterializedBoundary parameter publicRoot ftsSecret + (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) (Sum.inr message)) >>= next) + observations state fuel table cache = (do + let result ← runObservedCleanFromTable observations state fuel table + ((maskedSign parameter publicRoot ftsSecret message).run cache) + match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter publicRoot ftsSecret (next result.value.1) + result.observations result.state result.remaining table result.value.2) := by + rw [observedMaterializedBoundary, OracleComp.construct_query_bind] + unfold observedMaterializedBoundary + rfl + +theorem map_fst_continueObservedRootSelectionSharedPrefix_recurse + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (next : α → OracleComp (OracleWorld + SigningSpec) β) + (observations : List CleanProbeObservation) (candidates : List Probe) + (table : OtsSecretIndex → HashOutput) + (hrecursive : ∀ value state fuel cache, + Prod.fst <$> observedRootSelectionSharedPrefix ordinal parameter publicRoot target leftRoot + rightRoot ftsSecret (next value) observations candidates state fuel table cache = + observedMaterializedBoundary parameter publicRoot ftsSecret (next value) observations state + fuel table cache) + (detailed : DirectDetailedResult (α × SplitHashCache)) : + Prod.fst <$> continueObservedRootSelectionSharedPrefix parameter publicRoot ftsSecret target + next observations candidates table + (fun value => observedRootSelectionSharedPrefix ordinal parameter publicRoot target leftRoot + rightRoot ftsSecret (next value)) detailed = + match observedResultOfDetailed observations detailed with + | none => pure none + | some result => + observedMaterializedBoundary parameter publicRoot ftsSecret (next result.value.1) + result.observations result.state result.remaining table result.value.2 := by + exact map_fst_continueObservedRootSelectionSharedPrefix parameter publicRoot ftsSecret target next + observations candidates table + (fun value => observedRootSelectionSharedPrefix ordinal parameter publicRoot target leftRoot + rightRoot ftsSecret (next value)) hrecursive detailed + +theorem evalDist_map_snd_continueObservedRootSelectionSharedPrefix_recurse + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (next : α → OracleComp (OracleWorld + SigningSpec) β) + (observations : List CleanProbeObservation) (candidates : List Probe) + (table : OtsSecretIndex → HashOutput) + (hrecursive : ∀ value state fuel cache, + evalDist (Prod.snd <$> + observedRootSelectionSharedPrefix ordinal parameter publicRoot target leftRoot rightRoot + ftsSecret (next value) observations candidates state fuel table cache) = + evalDist + (materializedActualRootAwareOrdinalSelectionOutcome ordinal parameter publicRoot target + leftRoot rightRoot ftsSecret (next value) candidates state fuel table cache)) + (detailed : DirectDetailedResult (α × SplitHashCache)) : + evalDist (Prod.snd <$> + continueObservedRootSelectionSharedPrefix parameter publicRoot ftsSecret target next + observations candidates table + (fun value => observedRootSelectionSharedPrefix ordinal parameter publicRoot target + leftRoot rightRoot ftsSecret (next value)) detailed) = + evalDist + (finishMaterializedSelectionOutcome target table + (fun nextState remaining value nextCache laterCandidates => + materializedActualRootAwareOrdinalSelectionOutcome ordinal parameter publicRoot target + leftRoot rightRoot ftsSecret (next value) laterCandidates nextState remaining table + nextCache) + candidates detailed) := by + exact evalDist_map_snd_continueObservedRootSelectionSharedPrefix parameter publicRoot ftsSecret + target next observations candidates table + (fun value => observedRootSelectionSharedPrefix ordinal parameter publicRoot target leftRoot + rightRoot ftsSecret (next value)) + (fun nextState remaining value nextCache laterCandidates => + materializedActualRootAwareOrdinalSelectionOutcome ordinal parameter publicRoot target + leftRoot rightRoot ftsSecret (next value) laterCandidates nextState remaining table + nextCache) + hrecursive detailed + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 4000000 in +theorem map_fst_observedRootSelectionSharedPrefix + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) (candidates : List Probe) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + Prod.fst <$> observedRootSelectionSharedPrefix ordinal parameter publicRoot target leftRoot + rightRoot ftsSecret computation observations candidates state fuel table cache = + observedMaterializedBoundary parameter publicRoot ftsSecret computation observations state + fuel table cache := by + induction computation using OracleComp.inductionOn generalizing + observations candidates state fuel cache with + | pure value => + rw [observedRootSelectionSharedPrefix, OracleComp.construct_pure, + observedMaterializedBoundary, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length <;> simp [hselected] + | query_bind query next ih => + rw [observedRootSelectionSharedPrefix_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact map_fst_finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (liftM (OracleSpec.query query) >>= next) observations state fuel table cache + (.finished (some (candidates.get ⟨ordinal, hselected⟩))) + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [observedMaterializedBoundary_uniform_query_bind] + apply map_bind_of_map_eq + (observe := observedResultOfDetailed observations) + · exact map_observedResultOfDetailed_run_eq_observed_of_probeFree + ((splitUniformImpl n).run cache) observations state fuel table + (splitUniformImpl_probeFree n cache) + · intro detailed + cases detailed with + | stopped reason => + exact map_fst_continueObservedRootSelectionSharedPrefix_recurse ordinal + parameter publicRoot target leftRoot rightRoot ftsSecret next observations + candidates table + (fun value nextState remaining nextCache => + ih value observations candidates nextState remaining nextCache) + (.stopped reason) + | done result => + exact map_fst_continueObservedRootSelectionSharedPrefix_recurse ordinal + parameter publicRoot target leftRoot rightRoot ftsSecret next observations + candidates table + (fun value nextState remaining nextCache => + ih value observations candidates nextState remaining nextCache) + (.done result) + | inr input => + rw [observedMaterializedBoundary_hash_query_bind] + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + let nextObservations := observationsAfterCandidate observations state candidate? + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [nextCandidates, candidate?, plan, publicContext] using hnextSelected + simp only [hactual, ↓reduceDIte] + exact map_fst_finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (liftM (OracleSpec.query (Sum.inl (Sum.inr input))) >>= next) observations state + fuel table cache (.finished + (some ((appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).get + ⟨ordinal, hactual⟩))) + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [nextCandidates, candidate?, plan, publicContext] using hnextSelected + simp only [hactual, ↓reduceDIte] + by_cases hsafe : + RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? + · have hactualSafe : RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [candidate?, plan, publicContext] using hsafe + simp only [hactualSafe, ↓reduceIte] + apply map_bind_of_map_eq + (observe := observedResultOfDetailed nextObservations) + · unfold observedResultOfDetailed nextObservations candidate? plan + publicContext + exact map_projectDirectDetailedObserved_rootAwarePublic parameter input + (materializedCanonicalContext table state).state + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state) + observations state fuel table cache + · intro detailed + cases detailed with + | stopped reason => + exact map_fst_continueObservedRootSelectionSharedPrefix_recurse ordinal + parameter publicRoot target leftRoot rightRoot ftsSecret next + nextObservations nextCandidates table + (fun value nextState remaining nextCache => ih value nextObservations + nextCandidates nextState remaining nextCache) + (.stopped reason) + | done result => + exact map_fst_continueObservedRootSelectionSharedPrefix_recurse ordinal + parameter publicRoot target leftRoot rightRoot ftsSecret next + nextObservations nextCandidates table + (fun value nextState remaining nextCache => ih value nextObservations + nextCandidates nextState remaining nextCache) + (.done result) + · have hactualSafe : ¬RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [candidate?, plan, publicContext] using hsafe + simp only [hactualSafe, ↓reduceIte] + exact map_fst_finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (liftM (OracleSpec.query (Sum.inl (Sum.inr input))) >>= next) observations + state fuel table cache (.finished none) + | inr message => + rw [observedMaterializedBoundary_sign_query_bind] + apply map_bind_of_map_eq + (observe := observedResultOfDetailed observations) + · exact map_observedResultOfDetailed_run_eq_observed_of_probeFree + ((maskedSign parameter publicRoot ftsSecret message).run cache) observations state + fuel table (maskedSign_probeFree parameter publicRoot ftsSecret message cache) + · intro detailed + cases detailed with + | stopped reason => + exact map_fst_continueObservedRootSelectionSharedPrefix_recurse ordinal + parameter publicRoot target leftRoot rightRoot ftsSecret next observations + candidates table + (fun value nextState remaining nextCache => + ih value observations candidates nextState remaining nextCache) + (.stopped reason) + | done result => + exact map_fst_continueObservedRootSelectionSharedPrefix_recurse ordinal + parameter publicRoot target leftRoot rightRoot ftsSecret next observations + candidates table + (fun value nextState remaining nextCache => + ih value observations candidates nextState remaining nextCache) + (.done result) + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 4000000 in +theorem evalDist_map_snd_observedRootSelectionSharedPrefix + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) (candidates : List Probe) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + evalDist (Prod.snd <$> + observedRootSelectionSharedPrefix ordinal parameter publicRoot target leftRoot rightRoot + ftsSecret computation observations candidates state fuel table cache) = + evalDist + (materializedActualRootAwareOrdinalSelectionOutcome ordinal parameter publicRoot target + leftRoot rightRoot ftsSecret computation candidates state fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing + observations candidates state fuel cache with + | pure value => + rw [observedRootSelectionSharedPrefix, OracleComp.construct_pure, + materializedActualRootAwareOrdinalSelectionOutcome, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length <;> simp [hselected] + | query_bind query next ih => + rw [observedRootSelectionSharedPrefix_query_bind] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [materializedActualRootAwareOrdinalSelectionOutcome_uniform_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact map_snd_finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (liftM (OracleSpec.query (Sum.inl (Sum.inl n))) >>= next) observations state fuel + table cache (.finished (some (candidates.get ⟨ordinal, hselected⟩))) + · simp only [hselected, ↓reduceDIte] + apply evalDist_map_bind_congr + intro detailed + cases detailed with + | stopped reason => + exact + evalDist_map_snd_continueObservedRootSelectionSharedPrefix_recurse ordinal + parameter publicRoot target leftRoot rightRoot ftsSecret next observations + candidates table + (fun value nextState remaining nextCache => + ih value observations candidates nextState remaining nextCache) + (.stopped reason) + | done result => + exact + evalDist_map_snd_continueObservedRootSelectionSharedPrefix_recurse ordinal + parameter publicRoot target leftRoot rightRoot ftsSecret next observations + candidates table + (fun value nextState remaining nextCache => + ih value observations candidates nextState remaining nextCache) + (.done result) + | inr input => + rw [materializedActualRootAwareOrdinalSelectionOutcome_hash_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact map_snd_finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (liftM (OracleSpec.query (Sum.inl (Sum.inr input))) >>= next) observations state + fuel table cache (.finished (some (candidates.get ⟨ordinal, hselected⟩))) + · simp only [hselected, ↓reduceDIte] + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + let nextObservations := observationsAfterCandidate observations state candidate? + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [nextCandidates, candidate?, plan, publicContext] using hnextSelected + simp only [hactual, ↓reduceDIte] + exact map_snd_finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (liftM (OracleSpec.query (Sum.inl (Sum.inr input))) >>= next) observations state + fuel table cache (.finished + (some ((appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).get + ⟨ordinal, hactual⟩))) + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [nextCandidates, candidate?, plan, publicContext] using hnextSelected + simp only [hactual, ↓reduceDIte] + by_cases hsafe : + RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? + · have hactualSafe : RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [candidate?, plan, publicContext] using hsafe + simp only [hactualSafe, ↓reduceIte] + apply evalDist_map_bind_congr + intro detailed + cases detailed with + | stopped reason => + exact + evalDist_map_snd_continueObservedRootSelectionSharedPrefix_recurse + ordinal parameter publicRoot target leftRoot rightRoot ftsSecret next + nextObservations nextCandidates table + (fun value nextState remaining nextCache => ih value nextObservations + nextCandidates nextState remaining nextCache) + (.stopped reason) + | done result => + exact + evalDist_map_snd_continueObservedRootSelectionSharedPrefix_recurse + ordinal parameter publicRoot target leftRoot rightRoot ftsSecret next + nextObservations nextCandidates table + (fun value nextState remaining nextCache => ih value nextObservations + nextCandidates nextState remaining nextCache) + (.done result) + · have hactualSafe : ¬RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [candidate?, plan, publicContext] using hsafe + simp only [hactualSafe, ↓reduceIte] + exact map_snd_finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (liftM (OracleSpec.query (Sum.inl (Sum.inr input))) >>= next) observations + state fuel table cache (.finished none) + | inr message => + rw [materializedActualRootAwareOrdinalSelectionOutcome_sign_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact map_snd_finishObservedWithSelectionOutcome parameter publicRoot ftsSecret + (liftM (OracleSpec.query (Sum.inr message)) >>= next) observations state fuel table + cache (.finished (some (candidates.get ⟨ordinal, hselected⟩))) + · simp only [hselected, ↓reduceDIte] + apply evalDist_map_bind_congr + intro detailed + cases detailed with + | stopped reason => + exact evalDist_map_snd_continueObservedRootSelectionSharedPrefix_recurse ordinal + parameter publicRoot target leftRoot rightRoot ftsSecret next observations + candidates table + (fun value nextState remaining nextCache => + ih value observations candidates nextState remaining nextCache) + (.stopped reason) + | done result => + exact evalDist_map_snd_continueObservedRootSelectionSharedPrefix_recurse ordinal + parameter publicRoot target leftRoot rightRoot ftsSecret next observations + candidates table + (fun value nextState remaining nextCache => + ih value observations candidates nextState remaining nextCache) + (.done result) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSample.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSample.lean new file mode 100644 index 00000000..cff7a4a8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSample.lean @@ -0,0 +1,252 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedChainProbability + +/-! +# Sampled stopped diagnostic projection + +The diagnostic is classified by one first-hit ordinal before inspecting the coordinate kind. This +keeps the selected structural charge at one unit per ordinal. The chain-start alternative remains +attached to that same ordinal. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +def ObservedMaterializedDiagnostic.FirstExistingHiddenHitAt + (ordinal : Nat) (outcome : ObservedMaterializedDiagnostic α) : Prop := + ∃ result, outcome.before = some result ∧ + SphincsSecurity.Concrete.OtsProbeSimulation.FirstExistingHiddenHitAt result ordinal + +def ObservedCleanRunOption.SuccessfulFirstExistingHiddenHitAt + (ordinal : Nat) : Option (ObservedCleanRunResult α) → Prop + | none => False + | some result => + (∃ finalResult, some finalResult ∈ support + (finishObservedCleanRunFromTable (some result))) ∧ + SphincsSecurity.Concrete.OtsProbeSimulation.FirstExistingHiddenHitAt result ordinal + +theorem SnapshotObservedFirstStoppedRel.selected_or_chain_of_successful_firstHit + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} + {result : ObservedCleanRunResult (α × SplitHashCache)} + (hrelation : SnapshotObservedFirstStoppedRel table source (some result)) + (finalResult : ObservedCleanRunResult (α × SplitHashCache)) + (hfinish : some finalResult ∈ support + (finishObservedCleanRunFromTable (some result))) + (ordinal : Nat) + (hfirst : SphincsSecurity.Concrete.OtsProbeSimulation.FirstExistingHiddenHitAt + result ordinal) : + SelectedPrivateSnapshotHitAt source ordinal ∨ + FirstExistingHiddenChainStartHitAt result.observations ordinal := by + have hfirstData := hfirst + obtain ⟨selected, hselected, _hhit, _hbefore⟩ := hfirstData + by_cases hroot : (result.observations.get selected).toProbe.IsLayerRoot + · left + apply hrelation.selected_of_successful_firstRoot finalResult hfinish ordinal hfirst + intro other hother + have heq : other = selected := Fin.ext (hother.trans hselected.symm) + subst other + exact hroot + · rcases hrelation.selected_or_chain_of_successful_firstNonRoot finalResult hfinish ordinal + hfirst with hselectedSource | hchain + · exact Or.inl hselectedSource + · exact Or.inr (hchain.at_of_firstExistingHiddenHitAt hfirst) + +attribute [local irreducible] + observedMaterializedRetainedRunFromTable finishObservedMaterializedDiagnostic in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_finishDiagnostic_successfulDoomed_firstExistingHiddenHitAt_le + (table : OtsSecretIndex → HashOutput) + (run : ProbComp (Option (ObservedCleanRunResult α))) (ordinal : Nat) : + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenHitAt ordinal | + run >>= finishObservedMaterializedDiagnostic table] ≤ + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenHitAt ordinal | run] := by + apply probEvent_bind_le_probEvent + intro result _hresult hnot + apply probEvent_eq_zero + intro outcome houtcome hevent + obtain ⟨before, finalResult, hresult, hbefore, _hfinalEq, hfinish, _hdoomed⟩ := + successfulDoomed_data_of_mem_finishObservedMaterializedDiagnostic table result outcome + houtcome hevent.1 + obtain ⟨firstResult, hfirstBefore, hfirst⟩ := hevent.2 + have heq : firstResult = before := Option.some.inj (hfirstBefore.symm.trans hbefore) + subst firstResult + subst result + exact hnot ⟨⟨finalResult, hfinish⟩, hfirst⟩ + +attribute [local irreducible] + observedMaterializedRetainedRunFromTable finishObservedMaterializedDiagnostic in +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_firstExistingHiddenHitAt_le_raw + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel ordinal : Nat) : + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel] ≤ + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenHitAt ordinal | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table] := by + change Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenHitAt ordinal | + sampleOtsHashTable >>= fun table => + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table >>= + finishObservedMaterializedDiagnostic table] ≤ + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenHitAt ordinal | + sampleOtsHashTable >>= fun table => + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table] + rw [probEvent_bind_eq_tsum (mx := sampleOtsHashTable)] + rw [probEvent_bind_eq_tsum (mx := sampleOtsHashTable)] + apply ENNReal.tsum_le_tsum + intro table + by_cases htable : table ∈ support sampleOtsHashTable + · exact mul_le_mul' le_rfl + (probEvent_finishDiagnostic_successfulDoomed_firstExistingHiddenHitAt_le + (α := RetainedGameResult × SplitHashCache) table + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table) ordinal) + · simp [probOutput_eq_zero_of_not_mem_support htable] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledSuccessfulFirstHit_le_selectedSnapshot_add_chainStartAt + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenHitAt ordinal | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] + + Pr[fun observed => (match observed with + | none => False + | some result => FirstExistingHiddenChainStartHitAt result.observations ordinal) | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] := by + let source := sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q + let observed := do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table + apply probEvent_le_failure_add_residual_of_relTriple observed source + (fun observed source => ∃ table, SnapshotObservedFirstStoppedRel table source observed) + (ObservedCleanRunOption.SuccessfulFirstExistingHiddenHitAt ordinal) + (fun observed => match observed with + | none => False + | some result => FirstExistingHiddenChainStartHitAt result.observations ordinal) + (fun source => SelectedPrivateSnapshotHitAt source ordinal) + (relTriple_symm + (relTriple_sampledGranularAllCanonical_observedMaterializedRetained_firstStopped adversary + parameter ftsSecret q hbound hq)) + intro right left hrelation hevent hnotChain + obtain ⟨table, hrelation⟩ := hrelation + cases right with + | none => simp [ObservedCleanRunOption.SuccessfulFirstExistingHiddenHitAt] at hevent + | some result => + obtain ⟨⟨finalResult, hfinish⟩, hfirst⟩ := hevent + rcases hrelation.selected_or_chain_of_successful_firstHit finalResult hfinish ordinal hfirst + with hselected | hchain + · exact hselected + · exact (hnotChain hchain).elim + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledSuccessfulFirstHit_le_selectedSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenHitAt ordinal | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := by + calc + _ ≤ Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] + + Pr[fun observed => (match observed with + | none => False + | some result => FirstExistingHiddenChainStartHitAt result.observations ordinal) | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] := by + exact probEvent_sampledSuccessfulFirstHit_le_selectedSnapshot_add_chainStartAt adversary + parameter ftsSecret q ordinal hbound hq + _ = _ := by + have hzero := probEvent_sampled_firstExistingHiddenChainStartHitAt_eq_zero adversary + parameter ftsSecret (2 * q) ordinal + change Pr[fun observed => (match observed with + | none => False + | some result => FirstExistingHiddenChainStartHitAt result.observations ordinal) | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] = 0 + at hzero + rw [hzero] + simp + +attribute [local irreducible] sampledObservedMaterializedDiagnostic in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +set_option linter.constructorNameAsVariable false in +theorem probEvent_sampledDiagnostic_successfulDoomed_le_sum_firstHits + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : q ≤ 2 ^ securityBits) : + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + ∑ ordinal : Fin (2 * q), + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenHitAt ordinal.val | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] := by + classical + let run := sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q) + calc + _ ≤ Pr[fun outcome => ∃ ordinal ∈ (Finset.univ : Finset (Fin (2 * q))), + outcome.SuccessfulDoomed ∧ outcome.FirstExistingHiddenHitAt ordinal.val | run] := by + apply probEvent_mono + intro outcome houtcome hsuccess + have hhit := hasExistingHiddenHit_of_mem_sampledDiagnostic_successfulDoomed adversary + parameter ftsSecret q hq outcome houtcome hsuccess + rcases ObservedMaterializedDiagnostic.firstExistingHidden_root_or_nonRoot hhit with + hroot | hnonRoot + · obtain ⟨ordinal, result, sourceOrdinal, hbefore, hordinal, hfirst, _hroot⟩ := hroot + have hlength := observations_length_le_of_mem_sampledDiagnostic_before adversary parameter + ftsSecret (2 * q) outcome result houtcome hbefore + have hlt : ordinal < 2 * q := by omega + let bounded : Fin (2 * q) := ⟨ordinal, hlt⟩ + have hfirstAt : FirstExistingHiddenHitAt result ordinal := + hordinal ▸ firstExistingHiddenHitAt_of_firstExistingHiddenHitOrdinal?_eq_some hfirst + exact ⟨bounded, Finset.mem_univ bounded, hsuccess, result, hbefore, by + simpa [bounded] using hfirstAt⟩ + · obtain ⟨ordinal, result, sourceOrdinal, hbefore, hordinal, hfirst, _hnonRoot⟩ := + hnonRoot + have hlength := observations_length_le_of_mem_sampledDiagnostic_before adversary parameter + ftsSecret (2 * q) outcome result houtcome hbefore + have hlt : ordinal < 2 * q := by omega + let bounded : Fin (2 * q) := ⟨ordinal, hlt⟩ + have hfirstAt : FirstExistingHiddenHitAt result ordinal := + hordinal ▸ firstExistingHiddenHitAt_of_firstExistingHiddenHitOrdinal?_eq_some hfirst + exact ⟨bounded, Finset.mem_univ bounded, hsuccess, result, hbefore, by + simpa [bounded] using hfirstAt⟩ + _ ≤ ∑ ordinal : Fin (2 * q), + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenHitAt ordinal.val | run] := + probEvent_exists_finset_le_sum Finset.univ run fun (ordinal : Fin (2 * q)) outcome => + outcome.SuccessfulDoomed ∧ outcome.FirstExistingHiddenHitAt ordinal.val + _ = _ := by simp only [run] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSelection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSelection.lean new file mode 100644 index 00000000..1f5a0996 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSelection.lean @@ -0,0 +1,78 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSample +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionBoundary + +/-! +# Selected stopped snapshots as ordinal selections + +The stopped structural marker contains exactly the candidate-time data read by the ordinal +selection experiment. This file packages that deterministic projection before the root and +non-root probability branches are coupled. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +def PrivateOrdinalSelection.GoodForActualRoot + (target : Position) (output : HashOutput) (ordinal : Nat) + (selection : PrivateOrdinalSelection) : Prop := + selection.candidate = ⟨.position target, truncateHash output⟩ ∧ + selection.context.state.values (.position target) = none ∧ + Coordinate.position target ∉ selection.context.state.revealed ∧ + selection.context.values target = some output ∧ + CandidatesAvoidRoot target (truncateHash output) + (selection.candidates.take ordinal) + +theorem PrivateOrdinalSelection.GoodForActualRoot.goodForRoots + {selection : PrivateOrdinalSelection} {target : Position} + {output : HashOutput} {rightRoot : Digest} {ordinal : Nat} + (hactual : selection.GoodForActualRoot target output ordinal) + (hright : CandidatesAvoidRoot target rightRoot + (selection.candidates.take ordinal)) : + selection.GoodForRoots target output rightRoot ordinal := by + refine ⟨hactual.1, hactual.2.1, hactual.2.2.1, hactual.2.2.2.1, ?_⟩ + intro candidate hcandidate + exact ⟨hactual.2.2.2.2 candidate hcandidate, hright candidate hcandidate⟩ + +theorem selectedPrivateSnapshotOrdinal?_goodForActualRoot + {source : PrivateWitnessSnapshotOutput} {ordinal : Nat} + (hhit : SelectedPrivateSnapshotHitAt source ordinal) : + ∃ selected : Fin source.2.length, ∃ target output, + selected.val = ordinal ∧ + selectedPrivateSnapshotOrdinal? ordinal source.2 = + some (privateOrdinalSelectionOfSnapshot selected) ∧ + (privateOrdinalSelectionOfSnapshot selected).GoodForActualRoot + target output ordinal := by + obtain ⟨selected, hordinal, target, output, hcandidate, hstate, hhidden, hvalue, + havoid⟩ := hhit + subst ordinal + refine ⟨selected, target, output, rfl, ?_, ?_⟩ + · rw [selectedPrivateSnapshotOrdinal?_eq_some selected.isLt] + · refine ⟨?_, hstate, hhidden, hvalue, ?_⟩ + · exact hcandidate + · rw [privateOrdinalSelectionOfSnapshot_candidates_take] + exact havoid + +theorem selectedPrivateSnapshotHitAt_root_or_nonRoot + {source : PrivateWitnessSnapshotOutput} {ordinal : Nat} + (hhit : SelectedPrivateSnapshotHitAt source ordinal) : + (∃ selected : Fin source.2.length, ∃ target output, + selected.val = ordinal ∧ + selectedPrivateSnapshotOrdinal? ordinal source.2 = + some (privateOrdinalSelectionOfSnapshot selected) ∧ + (privateOrdinalSelectionOfSnapshot selected).GoodForActualRoot target output ordinal ∧ + IsLayerRoot target) ∨ + (∃ selected : Fin source.2.length, ∃ target output, + selected.val = ordinal ∧ + selectedPrivateSnapshotOrdinal? ordinal source.2 = + some (privateOrdinalSelectionOfSnapshot selected) ∧ + (privateOrdinalSelectionOfSnapshot selected).GoodForActualRoot target output ordinal ∧ + ¬IsLayerRoot target) := by + classical + obtain ⟨selected, target, output, hordinal, hselection, hgood⟩ := + selectedPrivateSnapshotOrdinal?_goodForActualRoot hhit + by_cases hroot : IsLayerRoot target + · exact Or.inl ⟨selected, target, output, hordinal, hselection, hgood, hroot⟩ + · exact Or.inr ⟨selected, target, output, hordinal, hselection, hgood, hroot⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSelectorCoupling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSelectorCoupling.lean new file mode 100644 index 00000000..a57225cd --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSelectorCoupling.lean @@ -0,0 +1,486 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedProbability + +/-! +# Snapshot to ordinal-selector coupling + +The chronological snapshot source and the ordinal selector follow the same direct execution until +the selected candidate is appended. The selector then stops, while every later source output keeps +that exact prefix. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option maxRecDepth 100000 +set_option maxHeartbeats 2000000 +set_option linter.constructorNameAsVariable false + +def SnapshotOrdinalSelectionRel + (ordinal : Nat) (source : PrivateWitnessSnapshotOutput) + (selection : Option PrivateOrdinalSelection) : Prop := + selectedPrivateSnapshotOrdinal? ordinal source.2 = selection + +theorem privateOrdinalSelectionOfSnapshot_eq_of_prefix + {initial final : List PlannedProbeSnapshot} (hprefix : initial <+: final) + {ordinal : Nat} (hselected : ordinal < initial.length) : + privateOrdinalSelectionOfSnapshot (⟨ordinal, hselected.trans_le hprefix.length_le⟩ : + Fin final.length) = + privateOrdinalSelectionOfSnapshot (⟨ordinal, hselected⟩ : Fin initial.length) := by + obtain ⟨tail, rfl⟩ := hprefix + have htake : ordinal + 1 ≤ initial.length := by omega + simp [privateOrdinalSelectionOfSnapshot, List.get_eq_getElem, + hselected, List.map_take, List.take_append_of_le_length, htake] + +theorem selectedPrivateSnapshotOrdinal?_eq_of_prefix + {initial final : List PlannedProbeSnapshot} (hprefix : initial <+: final) + {ordinal : Nat} (hselected : ordinal < initial.length) : + selectedPrivateSnapshotOrdinal? ordinal final = + some (privateOrdinalSelectionOfSnapshot ⟨ordinal, hselected⟩) := by + have hfinal : ordinal < final.length := hselected.trans_le hprefix.length_le + rw [selectedPrivateSnapshotOrdinal?_eq_some hfinal] + exact congrArg some (privateOrdinalSelectionOfSnapshot_eq_of_prefix hprefix hselected) + +theorem privateOrdinalSelectionOfSnapshot_eq_selected_of_last + {snapshots : List PlannedProbeSnapshot} {ordinal : Nat} + (hlength : snapshots.length = ordinal + 1) : + privateOrdinalSelectionOfSnapshot + (⟨ordinal, by omega⟩ : Fin snapshots.length) = + ⟨(snapshots.map PlannedProbeSnapshot.toProbe).get + ⟨ordinal, by simpa [hlength]⟩, + (snapshots.get ⟨ordinal, by omega⟩).context, + snapshots.map PlannedProbeSnapshot.toProbe⟩ := by + simp [privateOrdinalSelectionOfSnapshot, snapshotProbeOrdinal, hlength] + +theorem relTriple_source_pure_lastSnapshotSelection + (ordinal : Nat) (snapshots : List PlannedProbeSnapshot) + (hlength : snapshots.length = ordinal + 1) + (source : ProbComp PrivateWitnessSnapshotOutput) + (hextends : ∀ output ∈ support source, + PrivateWitnessSnapshotExtends snapshots output) : + RelTriple source + (pure (some + ⟨(snapshots.map PlannedProbeSnapshot.toProbe).get + ⟨ordinal, by simpa [hlength]⟩, + (snapshots.get ⟨ordinal, by omega⟩).context, + snapshots.map PlannedProbeSnapshot.toProbe⟩) : + ProbComp (Option PrivateOrdinalSelection)) + (SnapshotOrdinalSelectionRel ordinal) := by + have hbase := relTriple_true source + (pure (some + ⟨(snapshots.map PlannedProbeSnapshot.toProbe).get + ⟨ordinal, by simpa [hlength]⟩, + (snapshots.get ⟨ordinal, by omega⟩).context, + snapshots.map PlannedProbeSnapshot.toProbe⟩) : + ProbComp (Option PrivateOrdinalSelection)) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun output => PrivateWitnessSnapshotExtends snapshots output) hextends + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro output selection hrelation + have hselection : selection = some + ⟨(snapshots.map PlannedProbeSnapshot.toProbe).get + ⟨ordinal, by simpa [hlength]⟩, + (snapshots.get ⟨ordinal, by omega⟩).context, + snapshots.map PlannedProbeSnapshot.toProbe⟩ := by + simpa using hrelation.2 + subst selection + unfold SnapshotOrdinalSelectionRel + rw [selectedPrivateSnapshotOrdinal?_eq_of_prefix hrelation.1.2 (by omega)] + congr 1 + exact privateOrdinalSelectionOfSnapshot_eq_selected_of_last hlength + +theorem relTriple_pureSnapshot_pure_none + (ordinal : Nat) (witness : Option PrivateHitWitness) + (snapshots : List PlannedProbeSnapshot) + (hnotSelected : ¬ordinal < snapshots.length) : + RelTriple + (pure (witness, snapshots) : ProbComp PrivateWitnessSnapshotOutput) + (pure none : ProbComp (Option PrivateOrdinalSelection)) + (SnapshotOrdinalSelectionRel ordinal) := by + apply relTriple_pure_pure + unfold SnapshotOrdinalSelectionRel selectedPrivateSnapshotOrdinal? + simp [hnotSelected] + +theorem relTriple_finishSnapshot_privateOrdinalSelection + (ordinal : Nat) + (sourceObserve : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (selectionObserve : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (snapshots : List PlannedProbeSnapshot) (result : DirectWitnessResult α) + (hnotSelected : ¬ordinal < snapshots.length) + (hcontinuation : ∀ resolved, result = .done resolved → + RelTriple + (sourceObserve resolved.context resolved.remaining resolved.value snapshots) + (selectionObserve resolved.context resolved.remaining resolved.value + (snapshots.map PlannedProbeSnapshot.toProbe)) + (SnapshotOrdinalSelectionRel ordinal)) : + RelTriple + (finishDirectWitnessSnapshotObserve sourceObserve snapshots result) + (finishDirectPrivateOrdinalSelection selectionObserve + (snapshots.map PlannedProbeSnapshot.toProbe) result) + (SnapshotOrdinalSelectionRel ordinal) := by + cases result with + | stoppedFuel => exact relTriple_pureSnapshot_pure_none ordinal none snapshots hnotSelected + | stoppedOrdinary => exact relTriple_pureSnapshot_pure_none ordinal none snapshots hnotSelected + | stoppedPrivate witness => + exact relTriple_pureSnapshot_pure_none ordinal (some witness) snapshots hnotSelected + | done resolved => exact hcontinuation resolved rfl + +theorem relTriple_canonicalizeSnapshot_privateOrdinalSelection + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (sourceObserve : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (selectionObserve : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (context : DeferredContext) (fuel : Nat) (value : α) + (snapshots : List PlannedProbeSnapshot) + (hnotSelected : ¬ordinal < snapshots.length) + (hcontinuation : + RelTriple + (sourceObserve (canonicalizeMaterializedValues table context) fuel value snapshots) + (selectionObserve (canonicalizeMaterializedValues table context) fuel value + (snapshots.map PlannedProbeSnapshot.toProbe)) + (SnapshotOrdinalSelectionRel ordinal)) : + RelTriple + (canonicalizeDirectWitnessSnapshotObserve table sourceObserve context fuel value snapshots) + (canonicalizeDirectPrivateOrdinalSelection table selectionObserve context fuel value + (snapshots.map PlannedProbeSnapshot.toProbe)) + (SnapshotOrdinalSelectionRel ordinal) := by + classical + unfold canonicalizeDirectWitnessSnapshotObserve canonicalizeDirectPrivateOrdinalSelection + let canonical := canonicalizeMaterializedValues table context + by_cases hhit : PrivateStructuralHit canonical + · simp only [canonical, hhit, ↓reduceDIte, if_pos] + exact relTriple_pureSnapshot_pure_none ordinal + (some (privateHitWitnessOf canonical hhit)) snapshots hnotSelected + · simp only [canonical, hhit, ↓reduceDIte, if_neg] + change ¬PrivateStructuralHit (canonicalizeMaterializedValues table context) at hhit + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + unfold classifyDirectWitnessSnapshotObserve + by_cases hcompletable : DeferredCompletable table canonical + · change DeferredCompletable table + (canonicalizeMaterializedValues table context) at hcompletable + simpa [hhit, hcompletable] using hcontinuation + · change ¬DeferredCompletable table + (canonicalizeMaterializedValues table context) at hcompletable + simpa [hhit, hcompletable] using + (relTriple_pureSnapshot_pure_none ordinal none snapshots hnotSelected) + · simp only [hpublished, ↓reduceIte] + exact relTriple_pureSnapshot_pure_none ordinal none snapshots hnotSelected + +theorem relTriple_retainedFinalizationSnapshot_pure_none + (table : OtsSecretIndex → HashOutput) (root : Digest) (ordinal : Nat) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) + (snapshots : List PlannedProbeSnapshot) + (hnotSelected : ¬ordinal < snapshots.length) : + RelTriple + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table root context fuel value + snapshots) + (pure none : ProbComp (Option PrivateOrdinalSelection)) + (SnapshotOrdinalSelectionRel ordinal) := by + unfold retainedResolvedFinalizationPrivateWitnessSnapshotObserve + by_cases hhit : PrivateStructuralHit context + · simp only [hhit, ↓reduceDIte] + exact relTriple_pureSnapshot_pure_none ordinal + (some (privateHitWitnessOf context hhit)) snapshots hnotSelected + · simp only [hhit, ↓reduceDIte] + exact relTriple_pureSnapshot_pure_none ordinal none snapshots hnotSelected + +theorem relTriple_runSnapshot_privateOrdinalSelection + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (sourceObserve : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (selectionObserve : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (snapshots : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hnotSelected : ¬ordinal < snapshots.length) + (hcontinuation : ∀ result : ResolvedRunResult α, + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation) → + RelTriple + (sourceObserve (canonicalizeMaterializedValues table result.context) + result.remaining result.value snapshots) + (selectionObserve (canonicalizeMaterializedValues table result.context) + result.remaining result.value (snapshots.map PlannedProbeSnapshot.toProbe)) + (SnapshotOrdinalSelectionRel ordinal)) : + RelTriple + (runDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table sourceObserve) + snapshots context fuel table computation) + (runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table selectionObserve) + (snapshots.map PlannedProbeSnapshot.toProbe)) + (SnapshotOrdinalSelectionRel ordinal) := by + unfold runDirectWitnessSnapshotObserve + have hbase := relTriple_refl + (runDirectResolvedWitnessFromTable context fuel table computation) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) + (fun result hresult => hresult) + apply relTriple_bind hsupported + intro leftResult rightResult hresult + cases hresult.1 + apply relTriple_finishSnapshot_privateOrdinalSelection ordinal _ _ snapshots leftResult + hnotSelected + intro resolved heq + subst leftResult + apply relTriple_canonicalizeSnapshot_privateOrdinalSelection table ordinal _ _ + resolved.context resolved.remaining resolved.value snapshots hnotSelected + exact hcontinuation resolved hresult.2 + +set_option maxHeartbeats 4000000 in +theorem relTriple_directSnapshot_privateOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (terminalObserve : DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hterminal : ∀ nextContext remaining value nextSnapshots, + ¬ordinal < nextSnapshots.length → + RelTriple + (terminalObserve nextContext remaining value nextSnapshots) + (pure none : ProbComp (Option PrivateOrdinalSelection)) + (SnapshotOrdinalSelectionRel ordinal)) + (hterminalExtends : ∀ nextContext remaining value nextSnapshots output, + output ∈ support (terminalObserve nextContext remaining value nextSnapshots) → + PrivateWitnessSnapshotExtends nextSnapshots output) + (hnotSelected : ¬ordinal < snapshots.length) : + RelTriple + (directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root ftsSecret + computation terminalObserve + snapshots context fuel table cache) + (directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret computation + (snapshots.map PlannedProbeSnapshot.toProbe) context fuel table cache) + (SnapshotOrdinalSelectionRel ordinal) := by + induction computation using OracleComp.inductionOn generalizing snapshots context fuel cache with + | pure value => + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, OracleComp.construct_pure, + directDetailedBoundaryPrivateOrdinalSelection, OracleComp.construct_pure] + have hnotMapped : ¬ordinal < + (snapshots.map PlannedProbeSnapshot.toProbe).length := by simpa using hnotSelected + simp only [selectedPrivateOrdinal?, hnotMapped, ↓reduceDIte] + exact hterminal context fuel (value, cache) snapshots hnotSelected + | query_bind query next ih => + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_query_bind, directDetailedBoundaryPrivateOrdinalSelection, + OracleComp.construct_query_bind] + have hnotMapped : ¬ordinal < + (snapshots.map PlannedProbeSnapshot.toProbe).length := by simpa using hnotSelected + simp only [hnotMapped, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + change Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α at next + let sourceObserve : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput := + fun nextContext remaining value nextSnapshots => + directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root + ftsSecret (next value.1) terminalObserve + nextSnapshots nextContext remaining table value.2 + let selectionObserve : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection) := + fun nextContext remaining value candidates => + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret + (next value.1) candidates nextContext remaining table value.2 + apply relTriple_runSnapshot_privateOrdinalSelection table ordinal sourceObserve + selectionObserve snapshots context fuel ((splitUniformImpl n).run cache) + hnotSelected + intro result _hresult + simpa [sourceObserve, selectionObserve] using + (ih result.value.1 snapshots + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hnotSelected) + | inr input => + change HashOutput → OracleComp (OracleWorld + SigningSpec) α at next + simp only + let plan := purePlanProbingHashQuery parameter input context.state + let candidate? := rootAwarePlannedCandidate? parameter input context.state + let nextSnapshots := appendPlannedSnapshot snapshots candidate? context + let nextCandidates := appendPlannedCandidate + (snapshots.map PlannedProbeSnapshot.toProbe) candidate? + have hmap : nextSnapshots.map PlannedProbeSnapshot.toProbe = nextCandidates := by + exact map_toProbe_appendPlannedSnapshot snapshots candidate? context + change RelTriple + (runDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table + (fun nextContext remaining value laterSnapshots => + directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root + ftsSecret (next value.1) terminalObserve laterSnapshots nextContext remaining + table value.2)) + nextSnapshots context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache)) + (if hnext : ordinal < nextCandidates.length then + pure (some ⟨nextCandidates.get ⟨ordinal, hnext⟩, context, nextCandidates⟩) + else + runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) >>= + finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (fun nextContext remaining value laterCandidates => + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root + ftsSecret (next value.1) laterCandidates nextContext remaining table + value.2)) + nextCandidates) + (SnapshotOrdinalSelectionRel ordinal) + by_cases hnextSelected : ordinal < nextSnapshots.length + · have hnextMapped : ordinal < nextCandidates.length := by simpa [← hmap] + using hnextSelected + have hlength : nextSnapshots.length = ordinal + 1 := by + cases hcandidate : candidate? with + | none => + simp [nextSnapshots, appendPlannedSnapshot, hcandidate] at hnextSelected + exact False.elim (hnotSelected hnextSelected) + | some candidate => + simp [nextSnapshots, appendPlannedSnapshot, hcandidate] at hnextSelected ⊢ + omega + obtain ⟨candidate, hcandidate⟩ : ∃ candidate, candidate? = some candidate := by + cases hcandidate : candidate? with + | none => + simp [nextSnapshots, appendPlannedSnapshot, hcandidate] at hnextSelected + exact False.elim (hnotSelected hnextSelected) + | some candidate => exact ⟨candidate, rfl⟩ + have hordinal : ordinal = snapshots.length := by + simp [nextSnapshots, appendPlannedSnapshot, hcandidate] at hnextSelected + omega + have hcandidateActual : + rootAwarePlannedCandidate? parameter input context.state = some candidate := by + simpa [candidate?] using hcandidate + let source := + runDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table + (fun nextContext remaining value laterSnapshots => + directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter + root ftsSecret (next value.1) terminalObserve + laterSnapshots nextContext remaining table value.2)) + nextSnapshots context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) + have hextends : ∀ output ∈ support source, + PrivateWitnessSnapshotExtends nextSnapshots output := by + intro output houtput + unfold source at houtput + apply privateWitnessSnapshotExtends_of_mem_runDirectWitnessSnapshotObserve _ + nextSnapshots context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) + (output := output) (houtput := houtput) + intro result _hresult nextOutput hnextOutput + apply privateWitnessSnapshotExtends_of_mem_canonicalizeDirectWitnessSnapshotObserve + table _ result.context result.remaining result.value nextSnapshots + (output := nextOutput) (houtput := hnextOutput) + intro finalOutput hfinalOutput + apply privateWitnessSnapshotExtends_of_mem_directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve + parameter root ftsSecret (next result.value.1) + terminalObserve + nextSnapshots (canonicalizeMaterializedValues table result.context) + result.remaining table result.value.2 (output := finalOutput) + (houtput := hfinalOutput) + intro finalContext finalRemaining finalValue finalSnapshots retainedOutput + hretained + exact hterminalExtends finalContext finalRemaining finalValue finalSnapshots + retainedOutput hretained + have hselectedRel := relTriple_source_pure_lastSnapshotSelection ordinal + nextSnapshots hlength source hextends + have hactual : snapshots.length < + (appendPlannedCandidate (snapshots.map PlannedProbeSnapshot.toProbe) + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simp [hcandidateActual, appendPlannedCandidate] + simpa [source, plan, nextSnapshots, nextCandidates, hcandidate, hcandidateActual, + hordinal, hactual, appendPlannedSnapshot, appendPlannedCandidate] + using hselectedRel + · have hnextMapped : ¬ordinal < nextCandidates.length := by + simpa [← hmap] using hnextSelected + have hactual : ¬ordinal < + (appendPlannedCandidate (snapshots.map PlannedProbeSnapshot.toProbe) + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [candidate?, nextCandidates] using hnextMapped + let sourceObserve : DeferredContext → Nat → + (HashOutput × SplitHashCache) → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput := + fun nextContext remaining value laterSnapshots => + directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root + ftsSecret (next value.1) terminalObserve + laterSnapshots nextContext remaining table value.2 + let selectionObserve : DeferredContext → Nat → + (HashOutput × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection) := + fun nextContext remaining value candidates => + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret + (next value.1) candidates nextContext remaining table value.2 + have hrel := relTriple_runSnapshot_privateOrdinalSelection table ordinal + sourceObserve selectionObserve nextSnapshots context fuel + ((probingHashQueryAfterPlan parameter input plan).run cache) hnextSelected + (by + intro result _hresult + simpa [sourceObserve, selectionObserve, hmap] using + (ih result.value.1 nextSnapshots + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hnextSelected)) + simpa [sourceObserve, selectionObserve, plan, candidate?, nextSnapshots, + nextCandidates, hmap, hnextMapped, hactual] using hrel + | inr message => + change Option Signature → OracleComp (OracleWorld + SigningSpec) α at next + let sourceObserve : DeferredContext → Nat → + (Option Signature × SplitHashCache) → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput := + fun nextContext remaining value nextSnapshots => + directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root + ftsSecret (next value.1) terminalObserve + nextSnapshots nextContext remaining table value.2 + let selectionObserve : DeferredContext → Nat → + (Option Signature × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection) := + fun nextContext remaining value candidates => + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret + (next value.1) candidates nextContext remaining table value.2 + apply relTriple_runSnapshot_privateOrdinalSelection table ordinal sourceObserve + selectionObserve snapshots context fuel + ((maskedSign parameter root ftsSecret message).run cache) hnotSelected + intro result _hresult + simpa [sourceObserve, selectionObserve] using + (ih result.value.1 snapshots + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hnotSelected) + +theorem relTriple_granularRetainedSnapshot_privateOrdinalSelection + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (snapshots : List PlannedProbeSnapshot) + (hnotSelected : ¬ordinal < snapshots.length) : + RelTriple + (granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter + table ftsSecret context fuel value snapshots) + (directDetailedBoundaryPrivateOrdinalSelection ordinal parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (snapshots.map PlannedProbeSnapshot.toProbe) context fuel table value.2) + (SnapshotOrdinalSelectionRel ordinal) := by + unfold granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve + apply relTriple_directSnapshot_privateOrdinalSelection ordinal parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table value.1) + snapshots context fuel table value.2 + · intro nextContext remaining nextValue nextSnapshots hnot + exact relTriple_retainedFinalizationSnapshot_pure_none table value.1 ordinal nextContext + remaining nextValue nextSnapshots hnot + · intro nextContext remaining nextValue nextSnapshots output houtput + exact privateWitnessSnapshotExtends_of_mem_retainedResolvedFinalizationPrivateWitnessSnapshotObserve + table value.1 nextContext remaining nextValue nextSnapshots output houtput + · exact hnotSelected + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSource.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSource.lean new file mode 100644 index 00000000..1ff21786 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSource.lean @@ -0,0 +1,793 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStopped + +/-! +# Monotone stopped-source snapshots + +The source experiment only appends planned snapshots. A snapshot selected when the comparison first +stops therefore remains an exact prefix entry after an arbitrary source continuation. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def PrivateWitnessSnapshotExtends + (snapshots : List PlannedProbeSnapshot) (output : PrivateWitnessSnapshotOutput) : Prop := + snapshots <+: output.2 + +theorem privateWitnessSnapshotExtends_of_mem_finishDirectWitnessSnapshotObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) (result : DirectWitnessResult α) + (hobserve : ∀ resolved : ResolvedRunResult α, + result = .done resolved → + ∀ output ∈ support (observe resolved.context resolved.remaining resolved.value snapshots), + PrivateWitnessSnapshotExtends snapshots output) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (finishDirectWitnessSnapshotObserve observe snapshots result)) : + PrivateWitnessSnapshotExtends snapshots output := by + cases result with + | stoppedFuel => + simp [finishDirectWitnessSnapshotObserve] at houtput + subst output + simp [PrivateWitnessSnapshotExtends] + | stoppedOrdinary => + simp [finishDirectWitnessSnapshotObserve] at houtput + subst output + simp [PrivateWitnessSnapshotExtends] + | stoppedPrivate witness => + simp [finishDirectWitnessSnapshotObserve] at houtput + subst output + simp [PrivateWitnessSnapshotExtends] + | done resolved => exact hobserve resolved rfl output houtput + +theorem privateWitnessSnapshotExtends_of_mem_runDirectWitnessSnapshotObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hobserve : ∀ result : ResolvedRunResult α, + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation) → + ∀ output ∈ support (observe result.context result.remaining result.value snapshots), + PrivateWitnessSnapshotExtends snapshots output) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (runDirectWitnessSnapshotObserve observe snapshots context fuel table computation)) : + PrivateWitnessSnapshotExtends snapshots output := by + unfold runDirectWitnessSnapshotObserve at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + exact privateWitnessSnapshotExtends_of_mem_finishDirectWitnessSnapshotObserve observe snapshots + result (by + intro resolved heq + subst result + exact hobserve resolved hresult) + output hfinish + +theorem privateWitnessSnapshotExtends_of_mem_classifyDirectWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (context : DeferredContext) (fuel : Nat) (value : α) + (snapshots : List PlannedProbeSnapshot) + (hobserve : ∀ output ∈ support (observe context fuel value snapshots), + PrivateWitnessSnapshotExtends snapshots output) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (classifyDirectWitnessSnapshotObserve table observe context fuel value snapshots)) : + PrivateWitnessSnapshotExtends snapshots output := by + unfold classifyDirectWitnessSnapshotObserve at houtput + by_cases hhit : PrivateStructuralHit context + · simp [hhit] at houtput + subst output + simp [PrivateWitnessSnapshotExtends] + · simp only [hhit, ↓reduceDIte] at houtput + by_cases hcompletable : DeferredCompletable table context + · simp only [hcompletable, ↓reduceIte] at houtput + exact hobserve output houtput + · simp [hcompletable] at houtput + subst output + simp [PrivateWitnessSnapshotExtends] + +theorem privateWitnessSnapshotExtends_of_mem_canonicalizeDirectWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (context : DeferredContext) (fuel : Nat) (value : α) + (snapshots : List PlannedProbeSnapshot) + (hobserve : ∀ output ∈ support + (observe (canonicalizeMaterializedValues table context) fuel value snapshots), + PrivateWitnessSnapshotExtends snapshots output) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (canonicalizeDirectWitnessSnapshotObserve table observe context fuel value snapshots)) : + PrivateWitnessSnapshotExtends snapshots output := by + unfold canonicalizeDirectWitnessSnapshotObserve at houtput + let canonical := canonicalizeMaterializedValues table context + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit] at houtput + subst output + simp [PrivateWitnessSnapshotExtends] + · simp only [canonical, hhit, ↓reduceDIte] at houtput + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] at houtput + exact privateWitnessSnapshotExtends_of_mem_classifyDirectWitnessSnapshotObserve table observe + canonical fuel value snapshots hobserve output houtput + · simp [hpublished] at houtput + subst output + simp [PrivateWitnessSnapshotExtends] + +set_option maxRecDepth 100000 in +theorem privateWitnessSnapshotExtends_of_mem_directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hobserve : ∀ nextContext remaining value nextSnapshots output, + output ∈ support (observe nextContext remaining value nextSnapshots) → + PrivateWitnessSnapshotExtends nextSnapshots output) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root ftsSecret + computation observe snapshots context fuel table cache)) : + PrivateWitnessSnapshotExtends snapshots output := by + induction computation using OracleComp.inductionOn generalizing snapshots context fuel cache output with + | pure value => + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_pure] at houtput + exact hobserve context fuel (value, cache) snapshots output houtput + | query_bind query next ih => + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_query_bind] at houtput + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + apply privateWitnessSnapshotExtends_of_mem_runDirectWitnessSnapshotObserve _ + snapshots context fuel table ((splitUniformImpl n).run cache) (output := output) + (houtput := houtput) + intro result _hresult nextOutput hnextOutput + apply privateWitnessSnapshotExtends_of_mem_canonicalizeDirectWitnessSnapshotObserve + table _ result.context result.remaining result.value snapshots + (output := nextOutput) (houtput := hnextOutput) + intro finalOutput hfinalOutput + exact ih result.value.1 snapshots + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 finalOutput hfinalOutput + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let nextSnapshots := appendPlannedSnapshot snapshots + (rootAwarePlannedCandidate? parameter input context.state) context + have hprefix : snapshots <+: nextSnapshots := by + cases hcandidate : rootAwarePlannedCandidate? parameter input context.state <;> + simp [nextSnapshots, appendPlannedSnapshot, hcandidate] + have hnext : PrivateWitnessSnapshotExtends nextSnapshots output := by + apply privateWitnessSnapshotExtends_of_mem_runDirectWitnessSnapshotObserve _ + nextSnapshots context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) (output := output) + (houtput := houtput) + intro result _hresult nextOutput hnextOutput + apply privateWitnessSnapshotExtends_of_mem_canonicalizeDirectWitnessSnapshotObserve + table _ result.context result.remaining result.value nextSnapshots + (output := nextOutput) (houtput := hnextOutput) + intro finalOutput hfinalOutput + exact ih result.value.1 nextSnapshots + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 finalOutput hfinalOutput + exact hprefix.trans hnext + | inr message => + apply privateWitnessSnapshotExtends_of_mem_runDirectWitnessSnapshotObserve _ snapshots + context fuel table ((maskedSign parameter root ftsSecret message).run cache) + (output := output) (houtput := houtput) + intro result _hresult nextOutput hnextOutput + apply privateWitnessSnapshotExtends_of_mem_canonicalizeDirectWitnessSnapshotObserve + table _ result.context result.remaining result.value snapshots + (output := nextOutput) (houtput := hnextOutput) + intro finalOutput hfinalOutput + exact ih result.value.1 snapshots + (canonicalizeMaterializedValues table result.context) result.remaining result.value.2 + finalOutput hfinalOutput + +theorem privateWitnessSnapshotExtends_of_mem_retainedResolvedFinalizationPrivateWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) + (snapshots : List PlannedProbeSnapshot) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table root context fuel value + snapshots)) : + PrivateWitnessSnapshotExtends snapshots output := by + unfold retainedResolvedFinalizationPrivateWitnessSnapshotObserve at houtput + by_cases hhit : PrivateStructuralHit context <;> + simp [hhit] at houtput <;> subst output <;> simp [PrivateWitnessSnapshotExtends] + +theorem privateWitnessSnapshotExtends_of_mem_granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (snapshots : List PlannedProbeSnapshot) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter + table ftsSecret context fuel value snapshots)) : + PrivateWitnessSnapshotExtends snapshots output := by + unfold granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve at houtput + apply privateWitnessSnapshotExtends_of_mem_directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve + parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table value.1) + snapshots context fuel table value.2 (output := output) (houtput := houtput) + intro nextContext remaining nextValue nextSnapshots nextOutput hnextOutput + exact privateWitnessSnapshotExtends_of_mem_retainedResolvedFinalizationPrivateWitnessSnapshotObserve + table value.1 nextContext remaining nextValue nextSnapshots nextOutput hnextOutput + +def SelectedPrivateSnapshotHitAt + (source : PrivateWitnessSnapshotOutput) (ordinal : Nat) : Prop := + ∃ selected : Fin source.2.length, selected.val = ordinal ∧ + ∃ position output, + (source.2.get selected).probe = ⟨.position position, truncateHash output⟩ ∧ + (source.2.get selected).context.state.values (.position position) = none ∧ + Coordinate.position position ∉ (source.2.get selected).context.state.revealed ∧ + (source.2.get selected).context.values position = some output ∧ + CandidatesAvoidRoot position (truncateHash output) + ((source.2.map PlannedProbeSnapshot.toProbe).take ordinal) + +def SelectedSnapshotObservationAlignedAt + (table : OtsSecretIndex → HashOutput) (source : PrivateWitnessSnapshotOutput) + (result : ObservedCleanRunResult α) (ordinal : Nat) : Prop := + ∃ sourceOrdinal : Fin source.2.length, + ∃ observedOrdinal : Fin result.observations.length, + sourceOrdinal.val = ordinal ∧ observedOrdinal.val = ordinal ∧ + (source.2.get sourceOrdinal).probe = + (result.observations.get observedOrdinal).toProbe ∧ + (source.2.map PlannedProbeSnapshot.toProbe).take ordinal = + (result.observations.map CleanProbeObservation.toProbe).take ordinal ∧ + SnapshotsObservedAt table (source.2.take ordinal) + (result.observations.take ordinal) + +theorem SelectedSnapshotObservationAlignedAt.prefix + {source : PrivateWitnessSnapshotOutput} + {before : ObservedCleanRunResult α} {after : ObservedCleanRunResult β} + {ordinal : Nat} + (haligned : SelectedSnapshotObservationAlignedAt table source before ordinal) + (hprefix : before.observations <+: after.observations) : + SelectedSnapshotObservationAlignedAt table source after ordinal := by + obtain ⟨sourceOrdinal, observedOrdinal, hsource, hobserved, heq, hprefixEq, + hsnapshots⟩ := haligned + have hlt : observedOrdinal.val < after.observations.length := + observedOrdinal.isLt.trans_le hprefix.length_le + let observedOrdinal' : Fin after.observations.length := ⟨observedOrdinal.val, hlt⟩ + refine ⟨sourceOrdinal, observedOrdinal', hsource, hobserved, ?_, ?_, ?_⟩ + have hget : after.observations[observedOrdinal.val] = + before.observations[observedOrdinal.val] := (hprefix.getElem observedOrdinal.isLt).symm + simpa [observedOrdinal', hget] using heq + obtain ⟨tail, htail⟩ := hprefix + rw [← htail] + rw [List.map_append, List.take_append_of_le_length] + · exact hprefixEq + · simpa using Nat.le_of_lt (hobserved ▸ observedOrdinal.isLt) + obtain ⟨tail, htail⟩ := hprefix + rw [← htail] + simpa [List.take_append_of_le_length (Nat.le_of_lt (hobserved ▸ + observedOrdinal.isLt))] using hsnapshots + +theorem privateCandidate_eq_of_addPending_privateStructuralHit + (candidate : Probe) (context : DeferredContext) + (hclean : ¬PrivateStructuralHit context) + (hhit : PrivateStructuralHit + ({ context with + state := context.state.addPending candidate.coordinate candidate.candidate } : + DeferredContext)) : + ∃ position output, + candidate = ⟨.position position, truncateHash output⟩ ∧ + context.state.values (.position position) = none ∧ + context.values position = some output := by + obtain ⟨position, output, hvalue, hprivate, hpending⟩ := hhit + have hvalue' : context.state.values (.position position) = none := by + simpa [LazyRevealProbe.State.addPending] using hvalue + have hprivate' : context.values position = some output := by simpa using hprivate + have hmember : + (Coordinate.position position, truncateHash output) ∈ + (context.state.addPending candidate.coordinate candidate.candidate).pending := by + rw [← LazyRevealProbe.State.mem_pendingAt_iff] + exact hpending + rw [LazyRevealProbe.State.addPending] at hmember + simp only [Finset.mem_insert] at hmember + rcases hmember with hnew | hold + · refine ⟨position, output, ?_, hvalue', hprivate'⟩ + cases candidate with + | mk coordinate digest => + cases hnew + rfl + · exact (hclean ⟨position, output, hvalue', hprivate', by + unfold LazyRevealProbe.State.hitAt + rw [LazyRevealProbe.State.mem_pendingAt_iff] + exact hold⟩).elim + +theorem selectedPrivateSnapshotHitAt_of_appended_privateStructuralHit + (snapshots : List PlannedProbeSnapshot) (candidate : Probe) + (context : DeferredContext) (source : PrivateWitnessSnapshotOutput) + (hextends : PrivateWitnessSnapshotExtends + (snapshots ++ [(⟨candidate, context⟩ : PlannedProbeSnapshot)]) source) + (hcompletable : DeferredCompletable table context) + (hhidden : candidate.coordinate ∉ context.state.revealed) + (havoid : ∀ position output, + candidate = ⟨.position position, truncateHash output⟩ → + context.state.values (.position position) = none → + context.values position = some output → + CandidatesAvoidRoot position (truncateHash output) + (snapshots.map PlannedProbeSnapshot.toProbe)) + (hhit : PrivateStructuralHit + ({ context with + state := context.state.addPending candidate.coordinate candidate.candidate } : + DeferredContext)) : + SelectedPrivateSnapshotHitAt source snapshots.length := by + have hclean : ¬PrivateStructuralHit context := + not_privateStructuralHit_of_deferredCompletable hcompletable + obtain ⟨position, output, hcandidate, hvalue, hprivate⟩ := + privateCandidate_eq_of_addPending_privateStructuralHit candidate context hclean hhit + have hltCurrent : snapshots.length < + (snapshots ++ [(⟨candidate, context⟩ : PlannedProbeSnapshot)]).length := by + simp + have hltSource : snapshots.length < source.2.length := + hltCurrent.trans_le hextends.length_le + let selected : Fin source.2.length := ⟨snapshots.length, hltSource⟩ + have hselected : source.2.get selected = ⟨candidate, context⟩ := by + change source.2[snapshots.length] = ⟨candidate, context⟩ + have hpref : + (snapshots ++ [(⟨candidate, context⟩ : PlannedProbeSnapshot)])[snapshots.length] = + source.2[snapshots.length] := hextends.getElem hltCurrent + rw [← hpref] + simp + refine ⟨selected, rfl, position, output, ?_, ?_, ?_, ?_, ?_⟩ + · rw [hselected] + simpa using hcandidate + · rw [hselected] + exact hvalue + · rw [hselected] + rw [hcandidate] at hhidden + exact hhidden + · rw [hselected] + exact hprivate + · rw [← List.map_take] + obtain ⟨tail, htail⟩ := hextends + rw [← htail] + simp only [List.append_assoc, List.take_left] + exact havoid position output hcandidate hvalue hprivate + +theorem FirstExistingHiddenHitAt.prefix + {before : ObservedCleanRunResult α} {after : ObservedCleanRunResult β} + {ordinal : Nat} + (hfirst : FirstExistingHiddenHitAt before ordinal) + (hprefix : before.observations <+: after.observations) : + FirstExistingHiddenHitAt after ordinal := by + obtain ⟨selected, hordinal, hhit, hbefore⟩ := hfirst + have hselectedLt : selected.val < after.observations.length := + selected.isLt.trans_le hprefix.length_le + let selected' : Fin after.observations.length := ⟨selected.val, hselectedLt⟩ + refine ⟨selected', hordinal, ?_, ?_⟩ + · have hget : after.observations[selected.val] = before.observations[selected.val] := + (hprefix.getElem selected.isLt).symm + simpa [ExistingHiddenHitAtOrdinal, selected', hget] using hhit + · intro earlier hearlier + have hearlierBefore : earlier.val < before.observations.length := by + have : earlier.val < selected.val := by omega + exact this.trans selected.isLt + let earlier' : Fin before.observations.length := ⟨earlier.val, hearlierBefore⟩ + have hget : after.observations[earlier.val] = before.observations[earlier.val] := + (hprefix.getElem hearlierBefore).symm + simpa [ExistingHiddenHitAtOrdinal, earlier', hget] using + hbefore earlier' (by omega) + +theorem firstExistingHiddenHitAt_append_of_privateStructuralHit + (table : OtsSecretIndex → HashOutput) + (candidate : Probe) (observations : List CleanProbeObservation) + (left right : DeferredContext) + (hcontext : FinalizationContextLE table left right) + (hrightMaterialized : right = directDeferredContext right.state) + (hhidden : candidate.coordinate ∉ right.state.revealed) + (hnoEarlier : ∀ observation ∈ observations, + ¬observation.ExistingHiddenHit) + (hhit : PrivateStructuralHit + ({ left with + state := left.state.addPending candidate.coordinate candidate.candidate } : + DeferredContext)) : + FirstExistingHiddenHitAt + (⟨right.state, 0, (), table, + observations ++ [cleanProbeObservation right.state + candidate.coordinate candidate.candidate]⟩ : ObservedCleanRunResult Unit) + observations.length := by + have hclean : ¬PrivateStructuralHit left := + not_privateStructuralHit_of_deferredCompletable hcontext.leftCompletable + obtain ⟨position, output, hcandidate, hleftValue, hprivate⟩ := + privateCandidate_eq_of_addPending_privateStructuralHit candidate left hclean hhit + subst candidate + have hrightValue : right.state.values (.position position) = some output := by + have hleftPosition : left.positionValue position = some output := by + simp [DeferredContext.positionValue, hleftValue, hprivate] + have hresolved : resolvedCompletionValue table right (.position position) = some output := by + rw [← hcontext.view.valueEq] + simpa [resolvedCompletionValue] using hleftPosition + rw [hrightMaterialized] at hresolved + cases hright : right.state.values (.position position) with + | none => + simp [resolvedCompletionValue, directDeferredContext, directDeferredValues, + DeferredContext.positionValue, hright] at hresolved + | some existing => + have heq : existing = output := by + simpa [resolvedCompletionValue, directDeferredContext, directDeferredValues, + DeferredContext.positionValue, hright] using hresolved + simpa [hright, heq] + let observation := cleanProbeObservation right.state + (.position position) (truncateHash output) + have hobservation : observation.ExistingHiddenHit := by + refine ⟨?_, output, ?_, ?_⟩ + · simp [observation, cleanProbeObservation, hhidden] + · simpa [observation, cleanProbeObservation, hrightValue] + · simp [observation, cleanProbeObservation] + have hlength : observations.length < (observations ++ [observation]).length := by simp + let selected : Fin (observations ++ [observation]).length := + ⟨observations.length, hlength⟩ + change FirstExistingHiddenHitAt + (⟨right.state, 0, (), table, observations ++ [observation]⟩ : + ObservedCleanRunResult Unit) observations.length + refine ⟨selected, rfl, ?_, ?_⟩ + · simpa [ExistingHiddenHitAtOrdinal, selected, observation] using hobservation + · intro earlier hearlier + have hearlierLength : earlier.val < observations.length := by + simpa [selected] using hearlier + let before : Fin observations.length := ⟨earlier.val, hearlierLength⟩ + have hbefore := hnoEarlier (observations.get before) (List.get_mem _ _) + simpa [ExistingHiddenHitAtOrdinal, selected, before, observation, + List.getElem_append, hearlierLength] using hbefore + +def SnapshotObservedSelectedStoppedRel + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (source : PrivateWitnessSnapshotOutput) + (observed : Option (ObservedCleanRunResult (α × SplitHashCache))) : Prop := + observed = none ∨ + ∃ result, observed = some result ∧ + result.table = table ∧ + DoomedResolvedContext table (directDeferredContext result.state) ∧ + FirstExistingHiddenHitAt result ordinal ∧ + SelectedPrivateSnapshotHitAt source ordinal ∧ + SelectedSnapshotObservationAlignedAt table source result ordinal + +theorem missingChainStartHit_of_doomed_direct_valid + (table : OtsSecretIndex → HashOutput) + (state : LazyRevealProbe.State Coordinate) + (hdoomed : DoomedResolvedContext table (directDeferredContext state)) + (hvalid : (directDeferredContext state).Valid) + (hcard : state.pending.card < Fintype.card Digest) : + MissingChainStartHit table (directDeferredContext state) := by + have hcauses := privateStructuralHit_or_missingChainStartHit_of_not_completable table + (directDeferredContext state) hvalid hdoomed.2.1 hcard hdoomed.2.2 + exact hcauses.resolve_left (not_privateStructuralHit_of_directDeferredContext _ rfl) + +def SnapshotObservedFirstStoppedRel + (table : OtsSecretIndex → HashOutput) + (source : PrivateWitnessSnapshotOutput) + (observed : Option (ObservedCleanRunResult (α × SplitHashCache))) : Prop := + observed = none ∨ + (∃ result aligned, observed = some result ∧ + aligned <+: result.observations ∧ + SnapshotsObservedAt table source.2 aligned ∧ + (∀ observation ∈ result.observations, ¬observation.ExistingHiddenHit) ∧ + ∀ witness, source.1 = some witness → + result.state.values (.position witness.position) = some witness.output) ∨ + (∃ result ordinal, observed = some result ∧ + result.table = table ∧ + DoomedResolvedContext table (directDeferredContext result.state) ∧ + FirstExistingHiddenHitAt result ordinal ∧ + SelectedPrivateSnapshotHitAt source ordinal ∧ + SelectedSnapshotObservationAlignedAt table source result ordinal) ∨ + ∃ result, observed = some result ∧ + result.table = table ∧ + DoomedResolvedContext table (directDeferredContext result.state) ∧ + ObservedStoppedCause table result + +theorem SnapshotObservedSelectedStoppedRel.to_firstStopped + {table : OtsSecretIndex → HashOutput} {ordinal : Nat} + {source : PrivateWitnessSnapshotOutput} + {observed : Option (ObservedCleanRunResult (α × SplitHashCache))} + (hrelation : SnapshotObservedSelectedStoppedRel table ordinal source observed) : + SnapshotObservedFirstStoppedRel table source observed := by + rcases hrelation with hfailed | + ⟨result, hresult, htable, hdoomed, hfirst, hselected, haligned⟩ + · exact Or.inl hfailed + · exact Or.inr (Or.inr (Or.inl + ⟨result, ordinal, hresult, htable, hdoomed, hfirst, hselected, haligned⟩)) + +set_option maxRecDepth 100000 in +theorem relTriple_source_observedMaterializedBoundary_selectedStopped + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (source : ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) + (candidate : Probe) (context : DeferredContext) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hsource : ∀ output ∈ support source, + PrivateWitnessSnapshotExtends + (snapshots ++ [(⟨candidate, context⟩ : PlannedProbeSnapshot)]) output) + (hcompletable : DeferredCompletable table context) + (hhidden : candidate.coordinate ∉ context.state.revealed) + (havoid : ∀ position output, + candidate = ⟨.position position, truncateHash output⟩ → + context.state.values (.position position) = none → + context.values position = some output → + CandidatesAvoidRoot position (truncateHash output) + (snapshots.map PlannedProbeSnapshot.toProbe)) + (hhit : PrivateStructuralHit + ({ context with + state := context.state.addPending candidate.coordinate candidate.candidate } : + DeferredContext)) + (hfirst : FirstExistingHiddenHitAt + (⟨state, fuel, (), table, observations⟩ : ObservedCleanRunResult Unit) snapshots.length) + (hselectedAligned : ∀ output ∈ support source, + SelectedSnapshotObservationAlignedAt table output + (⟨state, fuel, (), table, observations⟩ : ObservedCleanRunResult Unit) + snapshots.length) + (hdoomed : DoomedResolvedContext table (directDeferredContext state)) : + RelTriple source + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache) + (SnapshotObservedSelectedStoppedRel table snapshots.length) := by + have hbase := relTriple_true source + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun output => output ∈ support source) (fun output houtput => houtput) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro sourceOutput observed hrelation + cases observed with + | none => exact Or.inl rfl + | some result => + right + have hprefix := observations_prefix_of_mem_observedMaterializedBoundary parameter root + ftsSecret computation observations state fuel table cache result hrelation.2 + have hdoomedResult := materializedDoomed_of_mem_observedMaterializedBoundary parameter root + ftsSecret computation observations state fuel table cache result hdoomed hrelation.2 + refine ⟨result, rfl, hdoomedResult.1, hdoomedResult.2, ?_, ?_, ?_⟩ + exact hfirst.prefix hprefix + exact selectedPrivateSnapshotHitAt_of_appended_privateStructuralHit snapshots candidate + context sourceOutput (hsource sourceOutput hrelation.1.2) hcompletable hhidden havoid hhit + exact (hselectedAligned sourceOutput hrelation.1.2).prefix hprefix + +set_option maxRecDepth 100000 in +theorem relTriple_source_observedMaterializedBoundary_firstStopped_of_selected + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (source : ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) + (candidate : Probe) (context : DeferredContext) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hsource : ∀ output ∈ support source, + PrivateWitnessSnapshotExtends + (snapshots ++ [(⟨candidate, context⟩ : PlannedProbeSnapshot)]) output) + (hcompletable : DeferredCompletable table context) + (hhidden : candidate.coordinate ∉ context.state.revealed) + (havoid : ∀ position output, + candidate = ⟨.position position, truncateHash output⟩ → + context.state.values (.position position) = none → + context.values position = some output → + CandidatesAvoidRoot position (truncateHash output) + (snapshots.map PlannedProbeSnapshot.toProbe)) + (hhit : PrivateStructuralHit + ({ context with + state := context.state.addPending candidate.coordinate candidate.candidate } : + DeferredContext)) + (hfirst : FirstExistingHiddenHitAt + (⟨state, fuel, (), table, observations⟩ : ObservedCleanRunResult Unit) snapshots.length) + (hselectedAligned : ∀ output ∈ support source, + SelectedSnapshotObservationAlignedAt table output + (⟨state, fuel, (), table, observations⟩ : ObservedCleanRunResult Unit) + snapshots.length) + (hdoomed : DoomedResolvedContext table (directDeferredContext state)) : + RelTriple source + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache) + (SnapshotObservedFirstStoppedRel table) := by + apply relTriple_post_mono + (relTriple_source_observedMaterializedBoundary_selectedStopped parameter root ftsSecret + computation source snapshots candidate context observations state fuel table cache hsource + hcompletable hhidden havoid hhit hfirst hselectedAligned hdoomed) + intro sourceOutput observed hrelation + exact hrelation.to_firstStopped + +set_option maxRecDepth 100000 in +theorem relTriple_any_observedMaterializedBoundary_firstStopped_of_cause + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (source : ProbComp PrivateWitnessSnapshotOutput) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hdoomed : DoomedResolvedContext table (directDeferredContext state)) + (hcause : MissingChainStartHit table (directDeferredContext state) ∨ + FirstExistingHiddenChainStartHit observations) : + RelTriple source + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache) + (SnapshotObservedFirstStoppedRel table) := by + have hbase := relTriple_true source + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + apply relTriple_post_mono hboth + intro sourceOutput observed hrelation + cases observed with + | none => exact Or.inl rfl + | some result => + right + right + right + refine ⟨result, rfl, ?_, ?_, ?_⟩ + · exact (materializedDoomed_of_mem_observedMaterializedBoundary parameter root ftsSecret + computation observations state fuel table cache result hdoomed hrelation.2).1 + · exact (materializedDoomed_of_mem_observedMaterializedBoundary parameter root ftsSecret + computation observations state fuel table cache result hdoomed hrelation.2).2 + · exact observedStoppedCause_of_mem_observedMaterializedBoundary parameter root ftsSecret + computation observations state fuel table cache result hcause hrelation.2 + +theorem SnapshotObservedFirstStoppedRel.selected_of_successful_firstRoot + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} + {result : ObservedCleanRunResult (α × SplitHashCache)} + (hrelation : SnapshotObservedFirstStoppedRel table source (some result)) + (finalResult : ObservedCleanRunResult (α × SplitHashCache)) + (hfinish : some finalResult ∈ support + (finishObservedCleanRunFromTable (some result))) + (ordinal : Nat) + (hfirst : FirstExistingHiddenHitAt result ordinal) + (hroot : ∀ selected : Fin result.observations.length, + selected.val = ordinal → + (result.observations.get selected).toProbe.IsLayerRoot) : + SelectedPrivateSnapshotHitAt source ordinal := by + rcases hrelation with hnone | haligned | hselected | hstopped + · simp at hnone + · obtain ⟨other, aligned, hresult, _hprefix, _hsnapshots, hnoHit, _hstored⟩ := haligned + have heq : other = result := Option.some.inj hresult.symm + subst other + obtain ⟨selected, _hordinal, hhit, _hbefore⟩ := hfirst + exact (hnoHit (result.observations.get selected) (List.get_mem _ _) hhit).elim + · obtain ⟨other, selectedOrdinal, hresult, _htable, _hdoomed, + hselectedFirst, hselected, _haligned⟩ := hselected + have heq : other = result := Option.some.inj hresult.symm + subst other + obtain ⟨left, hleftOrdinal, hleftHit, hleftBefore⟩ := hselectedFirst + obtain ⟨right, hrightOrdinal, hrightHit, hrightBefore⟩ := hfirst + have hsame : left = right := firstExistingHiddenHit_selected_unique + ⟨hleftHit, by + intro earlier hearlier + exact hleftBefore earlier (by omega)⟩ + ⟨hrightHit, by + intro earlier hearlier + exact hrightBefore earlier (by omega)⟩ + have hordinals : selectedOrdinal = ordinal := by + have hvals := congrArg Fin.val hsame + omega + simpa [hordinals] using hselected + · obtain ⟨other, hresult, htable, _hdoomed, hcause⟩ := hstopped + have heq : other = result := Option.some.inj hresult.symm + subst other + rcases hcause with hmissing | hchain + · rw [← htable] at hmissing + exact (not_missingChainStartHit_of_mem_finishObservedCleanRunFromTable result finalResult + hfinish hmissing).elim + · obtain ⟨selected, hselected, _hhit⟩ := hchain.selected_eq hfirst + exact (not_firstExistingHiddenRootHitAt_of_firstChainStart hchain hfirst selected hselected + (hroot selected hselected)).elim + +theorem SnapshotObservedFirstStoppedRel.selected_or_chain_of_successful_firstNonRoot + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} + {result : ObservedCleanRunResult (α × SplitHashCache)} + (hrelation : SnapshotObservedFirstStoppedRel table source (some result)) + (finalResult : ObservedCleanRunResult (α × SplitHashCache)) + (hfinish : some finalResult ∈ support + (finishObservedCleanRunFromTable (some result))) + (ordinal : Nat) + (hfirst : FirstExistingHiddenHitAt result ordinal) : + SelectedPrivateSnapshotHitAt source ordinal ∨ + FirstExistingHiddenChainStartHit result.observations := by + rcases hrelation with hnone | haligned | hselected | hstopped + · simp at hnone + · obtain ⟨other, aligned, hresult, _hprefix, _hsnapshots, hnoHit, _hstored⟩ := haligned + have heq : other = result := Option.some.inj hresult.symm + subst other + obtain ⟨selected, _hordinal, hhit, _hbefore⟩ := hfirst + exact (hnoHit (result.observations.get selected) (List.get_mem _ _) hhit).elim + · left + obtain ⟨other, selectedOrdinal, hresult, _htable, _hdoomed, + hselectedFirst, hselected, _haligned⟩ := hselected + have heq : other = result := Option.some.inj hresult.symm + subst other + obtain ⟨left, hleftOrdinal, hleftHit, hleftBefore⟩ := hselectedFirst + obtain ⟨right, hrightOrdinal, hrightHit, hrightBefore⟩ := hfirst + have hsame : left = right := firstExistingHiddenHit_selected_unique + ⟨hleftHit, by + intro earlier hearlier + exact hleftBefore earlier (by omega)⟩ + ⟨hrightHit, by + intro earlier hearlier + exact hrightBefore earlier (by omega)⟩ + have hordinals : selectedOrdinal = ordinal := by + have hvals := congrArg Fin.val hsame + omega + simpa [hordinals] using hselected + · obtain ⟨other, hresult, htable, _hdoomed, hcause⟩ := hstopped + have heq : other = result := Option.some.inj hresult.symm + subst other + rcases hcause with hmissing | hchain + · rw [← htable] at hmissing + exact (not_missingChainStartHit_of_mem_finishObservedCleanRunFromTable result finalResult + hfinish hmissing).elim + · exact Or.inr hchain + +theorem SnapshotObservedFirstStoppedRel.selectedAligned_or_chain_of_successful_firstHit + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} + {result : ObservedCleanRunResult (α × SplitHashCache)} + (hrelation : SnapshotObservedFirstStoppedRel table source (some result)) + (finalResult : ObservedCleanRunResult (α × SplitHashCache)) + (hfinish : some finalResult ∈ support + (finishObservedCleanRunFromTable (some result))) + (ordinal : Nat) + (hfirst : FirstExistingHiddenHitAt result ordinal) : + (SelectedPrivateSnapshotHitAt source ordinal ∧ + SelectedSnapshotObservationAlignedAt table source result ordinal) ∨ + FirstExistingHiddenChainStartHit result.observations := by + rcases hrelation with hnone | haligned | hselected | hstopped + · simp at hnone + · obtain ⟨other, _aligned, hresult, _hprefix, _hsnapshots, hnoHit, _hstored⟩ := + haligned + have heq : other = result := Option.some.inj hresult.symm + subst other + obtain ⟨selected, _hordinal, hhit, _hbefore⟩ := hfirst + exact (hnoHit (result.observations.get selected) (List.get_mem _ _) hhit).elim + · left + obtain ⟨other, selectedOrdinal, hresult, _htable, _hdoomed, + hselectedFirst, hselectedHit, hselectedAligned⟩ := hselected + have heq : other = result := Option.some.inj hresult.symm + subst other + obtain ⟨left, _hleftOrdinal, hleftHit, hleftBefore⟩ := hselectedFirst + obtain ⟨right, _hrightOrdinal, hrightHit, hrightBefore⟩ := hfirst + have hsame : left = right := firstExistingHiddenHit_selected_unique + ⟨hleftHit, by + intro earlier hearlier + exact hleftBefore earlier (by omega)⟩ + ⟨hrightHit, by + intro earlier hearlier + exact hrightBefore earlier (by omega)⟩ + have hordinals : selectedOrdinal = ordinal := by + have hvals := congrArg Fin.val hsame + omega + simpa [hordinals] using And.intro hselectedHit hselectedAligned + · obtain ⟨other, hresult, htable, _hdoomed, hcause⟩ := hstopped + have heq : other = result := Option.some.inj hresult.symm + subst other + rcases hcause with hmissing | hchain + · rw [← htable] at hmissing + exact (not_missingChainStartHit_of_mem_finishObservedCleanRunFromTable result finalResult + hfinish hmissing).elim + · exact Or.inr hchain diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedTop.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedTop.lean new file mode 100644 index 00000000..864e6e63 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedTop.lean @@ -0,0 +1,230 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedTopKernel +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopStep + +/-! +# Stopped public-root lift + +The first-stopped relation is carried through the probe-free public-root computation and the root +is restored in the retained game result. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +theorem SnapshotObservedFirstStoppedRel.retainRoot + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} + {observed : Option + (ObservedCleanRunResult (RetainedRestResult × SplitHashCache))} + (hrelation : SnapshotObservedFirstStoppedRel table source observed) + (root : Digest) : + SnapshotObservedFirstStoppedRel table source (retainObservedRoot root observed) := by + rcases hrelation with hfailed | haligned | hselected | hstopped + · left + subst observed + rfl + · right + left + obtain ⟨result, aligned, hresult, hprefix, hsnapshots, hnoHit, hstored⟩ := haligned + subst observed + exact ⟨_, aligned, rfl, hprefix, hsnapshots, hnoHit, hstored⟩ + · right + right + left + obtain ⟨result, ordinal, hresult, htable, hdoomed, hfirst, hselected⟩ := hselected + subst observed + exact ⟨_, ordinal, rfl, htable, hdoomed, hfirst, hselected⟩ + · right + right + right + obtain ⟨result, hresult, htable, hdoomed, hcause⟩ := hstopped + subst observed + exact ⟨_, rfl, htable, hdoomed, hcause⟩ + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem relTriple_finishAfterPublishedRoot_firstStopped + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) + (leftResult : DirectWitnessResult (Digest × SplitHashCache)) + (rightResult : Option (ObservedCleanRunResult (Digest × SplitHashCache))) + (hstep : WitnessObservedFirstStoppedStepRel table [] leftResult rightResult) + (hleftSupport : leftResult ∈ support + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext q table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hrightSupport : rightResult ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache))) : + RelTriple + (finishDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table + (retainedSnapshotObserve adversary parameter table ftsSecret)) [] leftResult) + (match rightResult with + | none => pure none + | some rootResult => do + let restResult ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table rootResult.value.2 + match restResult with + | none => pure none + | some restResult => pure (some + { restResult with + value := ((rootResult.value.1, restResult.value.1), restResult.value.2) })) + (SnapshotObservedFirstStoppedRel table) := by + have hfinish := relTriple_finishWitnessObservedFirstStoppedStep (α := Digest) + (β := RetainedRestResult) parameter id ftsSecret + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩) + (retainedSnapshotObserve adversary parameter table ftsSecret) [] [] table leftResult + rightResult hstep (by + intro nextLeft nextRight hleftEq hrightEq hclean + have hleftDone : DirectWitnessResult.done nextLeft ∈ support + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext q table + (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + rw [← hleftEq] + exact hleftSupport + have hrightDone : some (observedResolvedResult [] nextRight) ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + rw [← hrightEq] + exact hrightSupport + exact relTriple_afterPublishedRoot_firstStopped adversary parameter ftsSecret q table hbound + hq nextLeft nextRight hleftDone hrightDone hclean) + cases rightResult with + | none => + have hretained := relTriple_post_mono hfinish + (fun source observed hrelation => hrelation.retainRoot 0) + have hmapped := relTriple_map (f := id) (g := retainObservedRoot 0) hretained + rw [id_map] at hmapped + rw [map_retainObservedRoot_eq, pure_bind] at hmapped + exact hmapped + | some rootResult => + have hretained := relTriple_post_mono hfinish + (fun source observed hrelation => hrelation.retainRoot rootResult.value.1) + have hmapped := relTriple_map (f := id) + (g := retainObservedRoot rootResult.value.1) hretained + rw [id_map] at hmapped + rw [map_retainObservedRoot_eq] at hmapped + exact hmapped + +set_option maxHeartbeats 10000000 in +set_option maxRecDepth 100000 in +theorem relTriple_granularAllSnapshot_observedMaterializedRetained_firstStopped + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + RelTriple + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q) + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table) + (SnapshotObservedFirstStoppedRel table) := by + let initial : DeferredContext := emptyWitnessDeferredContext + have hcontext : FinalizationContextLE table initial + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) := + finalizationContextLE_empty table + have hbase := (witnessMaterializedStableCouples_maskedPublishedTreeRoot table) + initial (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + q (2 * q) emptySplitHashCache emptySplitHashCache hcontext (by omega) rfl rfl + (fun _ _ hvalue => hvalue) publishedValues_empty rfl + have hcapacity : 2 * q < Fintype.card Digest := by + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + norm_num [securityBits, digestBits] at hq ⊢ + omega + have hlocal := relTriple_runDirectResolvedWitness_observed_firstStopped_of_probeFree table + (maskedPublishedTreeRoot.run emptySplitHashCache) + (maskedPublishedTreeRoot.run emptySplitHashCache) [] initial + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + q (2 * q) hbase (maskedPublishedTreeRoot_probeFree emptySplitHashCache) + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) hcontext.leftValid + hcontext.leftCompletable rfl (by simp [CleanProbeObservationsTrackedBy]) + (by simp [CleanProbeObservationsCoverPending, directDeferredContext, + LazyRevealProbe.State.empty]) (by simp) + (by simpa [directDeferredContext, LazyRevealProbe.State.empty] using hcapacity) + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hlocal + (fun result => result ∈ support + (runDirectResolvedWitnessFromTable initial q table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (fun result hresult => hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupported + unfold granularAllCanonicalPrivateWitnessSnapshot + observedMaterializedRetainedRunFromTable runDirectWitnessSnapshotObserve + change RelTriple + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext q table + (maskedPublishedTreeRoot.run emptySplitHashCache) >>= + finishDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table + (granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter + table ftsSecret)) []) + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache) >>= fun rootResult => + match rootResult with + | none => pure none + | some rootResult => do + let restResult ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table rootResult.value.2 + match restResult with + | none => pure none + | some restResult => pure (some + { restResult with + value := ((rootResult.value.1, restResult.value.1), restResult.value.2) })) + (SnapshotObservedFirstStoppedRel table) + apply relTriple_bind hbothSupported + intro leftResult rightResult hstep + rcases hstep with ⟨⟨hstep, hleftSupport⟩, hrightSupport⟩ + exact relTriple_finishAfterPublishedRoot_firstStopped adversary parameter ftsSecret q table + hbound hq leftResult rightResult hstep (by simpa [initial] using hleftSupport) hrightSupport + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_sampledGranularAllCanonical_observedMaterializedRetained_firstStopped + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + RelTriple + (sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q) + (sampleOtsHashTable >>= fun table => + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table) + (fun source observed => ∃ table, SnapshotObservedFirstStoppedRel table source observed) := by + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot + apply relTriple_bind (relTriple_refl sampleOtsHashTable) + intro leftTable rightTable htable + subst rightTable + apply relTriple_post_mono + (relTriple_granularAllSnapshot_observedMaterializedRetained_firstStopped adversary parameter + ftsSecret q leftTable (hbound leftTable) hq) + intro source observed hrelation + exact ⟨leftTable, hrelation⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedTopKernel.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedTopKernel.lean new file mode 100644 index 00000000..4e9e74de --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedTopKernel.lean @@ -0,0 +1,105 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedLift +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopKernel + +/-! +# Stopped published-root continuation kernel + +The probe-free public-root computation initializes the adaptive stopped lift with an empty, +tracked observation log and enough digest-space slack for every remaining pending probe. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_afterPublishedRoot_firstStopped + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) + (left right : ResolvedRunResult (Digest × SplitHashCache)) + (hleftSupport : DirectWitnessResult.done left ∈ support + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext q table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hrightSupport : some (observedResolvedResult [] right) ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hclean : OrdinaryMaterializedRunEq table left right) : + RelTriple + (canonicalizeDirectWitnessSnapshotObserve table + (retainedSnapshotObserve adversary parameter table ftsSecret) + left.context left.remaining left.value []) + (observedMaterializedBoundary parameter right.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨right.value.1, parameter⟩) + [] right.context.state right.remaining table right.value.2) + (SnapshotObservedFirstStoppedRel table) := by + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table left.context + have hleftCompletable : DeferredCompletable table canonical := + hcanonicalRun.context_le.leftCompletable + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hleftFuelPreserved : q ≤ left.remaining := + fuel_le_remaining_of_doneWitness_maskedPublishedTreeRoot table q left hleftSupport + have hrightFuelPreserved : 2 * q ≤ right.remaining := + fuel_le_remaining_of_mem_observed_maskedPublishedTreeRoot table (2 * q) right hrightSupport + have hleftRemainingUpper : left.remaining ≤ q := + remaining_le_fuel_of_doneWitness_maskedPublishedTreeRoot table q left hleftSupport + have hinitialTracked : CleanProbeObservationsTrackedBy [] + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) := by + simp [CleanProbeObservationsTrackedBy] + have hinitialCovered : CleanProbeObservationsCoverPending [] + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) := by + simp [CleanProbeObservationsCoverPending, LazyRevealProbe.State.empty] + have hrightTracked : CleanProbeObservationsTrackedBy [] right.context.state := by + simpa [observedResolvedResult] using + (cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty + (2 * q) table hinitialTracked (observedResolvedResult [] right) hrightSupport) + have hrightCovered : CleanProbeObservationsCoverPending [] right.context.state := by + simpa [observedResolvedResult] using + (cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty + (2 * q) table hinitialCovered (observedResolvedResult [] right) hrightSupport) + have hcapacity : 2 * q < Fintype.card Digest := by + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + norm_num [securityBits, digestBits] at hq ⊢ + omega + have hbudget : right.remaining + right.context.state.pending.card < + Fintype.card Digest := by + have hremaining := remaining_add_pending_card_le_of_mem_runObservedCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty + (2 * q) table (observedResolvedResult [] right) hrightSupport + simp only [observedResolvedResult] at hremaining + exact hremaining.trans_lt (by simpa [LazyRevealProbe.State.empty] using hcapacity) + unfold canonicalizeDirectWitnessSnapshotObserve classifyDirectWitnessSnapshotObserve + simp only [canonical, hnotPrivate, ↓reduceDIte, hclean.left_published, ↓reduceIte, + hleftCompletable] + rw [← hclean.value_eq] + simpa [retainedSnapshotObserve, + granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve] using + (relTriple_directSnapshotBoundary_observedMaterialized_firstStopped parameter left.value.1 + ftsSecret (retainedGameRestComputation adversary ⟨left.value.1, parameter⟩) + [] [] canonical right.context left.remaining right.remaining table + left.value.2 right.value.2 q q (hbound left.value.1) + hcanonicalRun.context_le hcanonicalRun.cache_eq hcanonicalRun.revealed_eq + hcanonicalRun.values_le hcanonicalRun.left_published hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table left.context + hclean.context_le.view.leftConsistent) + (by simp [SnapshotsObservedAt]) (SnapshotsBefore.nil canonical) + hrightTracked hrightCovered (by simp) + (by omega) (by omega) (by omega) hbudget) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalCoupling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalCoupling.lean new file mode 100644 index 00000000..46e352fe --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalCoupling.lean @@ -0,0 +1,1826 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceHidden + +/-! +# Global root coupling boundary + +This file states the target-neutral postcondition of the adaptive coupling. A successful observed +run must turn every source-side layer-root witness into a delayed source snapshot. The failure +alternative is therefore charged once, before any ordinal or position is selected. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +def SnapshotObservedRootRel + (source : PrivateWitnessSnapshotOutput) + (observed : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))) : Prop := + observed = none ∨ + (WitnessFirstUsesSomeLayerRoot (erasePrivateWitnessSnapshotOutput source) → + WitnessFirstUsesSomeDelayedLayerRootSnapshot source) + +def PlannedProbeSnapshot.ObservedAt + (table : OtsSecretIndex → HashOutput) + (snapshot : PlannedProbeSnapshot) (observation : CleanProbeObservation) : Prop := + observation.toProbe = snapshot.probe ∧ + (∀ position, observation.coordinate = .position position → + observation.valueAtProbe = snapshot.context.positionValue position) ∧ + observation.revealedAtProbe = + decide (observation.coordinate ∈ snapshot.context.state.revealed) ∧ + PublishedValues snapshot.context.state ∧ + CanonicalMaterializedValues table snapshot.context + +def SnapshotsObservedAt + (table : OtsSecretIndex → HashOutput) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) : Prop := + List.Forall₂ (PlannedProbeSnapshot.ObservedAt table) snapshots observations + +theorem SnapshotsObservedAt.map_toProbe_eq + {table : OtsSecretIndex → HashOutput} + {snapshots : List PlannedProbeSnapshot} + {observations : List CleanProbeObservation} + (haligned : SnapshotsObservedAt table snapshots observations) : + snapshots.map PlannedProbeSnapshot.toProbe = + observations.map CleanProbeObservation.toProbe := by + induction haligned with + | nil => rfl + | cons hhead htail ih => + simp only [List.map_cons, PlannedProbeSnapshot.toProbe, ih, List.cons.injEq, and_true] + exact hhead.1.symm + +theorem SnapshotsObservedAt.published + {table : OtsSecretIndex → HashOutput} + {snapshots : List PlannedProbeSnapshot} + {observations : List CleanProbeObservation} + (haligned : SnapshotsObservedAt table snapshots observations) : + ∀ snapshot ∈ snapshots, PublishedValues snapshot.context.state := by + induction haligned with + | nil => simp + | cons hhead htail ih => + intro snapshot hsnapshot + simp only [List.mem_cons] at hsnapshot + rcases hsnapshot with rfl | hrest + · exact hhead.2.2.2.1 + · exact ih snapshot hrest + +theorem SnapshotsObservedAt.append + {table : OtsSecretIndex → HashOutput} + {snapshots : List PlannedProbeSnapshot} + {observations : List CleanProbeObservation} + (haligned : SnapshotsObservedAt table snapshots observations) + {snapshot : PlannedProbeSnapshot} {observation : CleanProbeObservation} + (hnext : snapshot.ObservedAt table observation) : + SnapshotsObservedAt table (snapshots ++ [snapshot]) + (observations ++ [observation]) := by + induction haligned with + | nil => exact .cons hnext .nil + | cons hhead htail ih => exact .cons hhead ih + +def PlannedProbeSnapshot.Before (snapshot : PlannedProbeSnapshot) + (context : DeferredContext) : Prop := + snapshot.context.state.revealed ⊆ context.state.revealed ∧ + PrivateValuesLE snapshot.context context + +def SnapshotsBefore (snapshots : List PlannedProbeSnapshot) + (context : DeferredContext) : Prop := + ∀ snapshot ∈ snapshots, snapshot.Before context + +theorem SnapshotsBefore.nil (context : DeferredContext) : + SnapshotsBefore [] context := by + simp [SnapshotsBefore] + +theorem SnapshotsBefore.append_self + {snapshots : List PlannedProbeSnapshot} {context : DeferredContext} + (hbefore : SnapshotsBefore snapshots context) : + SnapshotsBefore (snapshots ++ [⟨candidate, context⟩]) context := by + intro snapshot hsnapshot + simp only [List.mem_append, List.mem_singleton] at hsnapshot + rcases hsnapshot with hold | rfl + · exact hbefore snapshot hold + · exact ⟨Finset.Subset.rfl, PrivateValuesLE.refl context⟩ + +theorem SnapshotsBefore.appendPlannedSnapshot + {snapshots : List PlannedProbeSnapshot} {context : DeferredContext} + (hbefore : SnapshotsBefore snapshots context) (candidate? : Option Probe) : + SnapshotsBefore (appendPlannedSnapshot snapshots candidate? context) context := by + cases candidate? with + | none => exact hbefore + | some candidate => exact hbefore.append_self + +theorem SnapshotsBefore.trans + {snapshots : List PlannedProbeSnapshot} {left right : DeferredContext} + (hbefore : SnapshotsBefore snapshots left) + (hrevealed : left.state.revealed ⊆ right.state.revealed) + (hvalues : PrivateValuesLE left right) : + SnapshotsBefore snapshots right := by + intro snapshot hsnapshot + have hsnapshot := hbefore snapshot hsnapshot + exact ⟨hsnapshot.1.trans hrevealed, hsnapshot.2.trans hvalues⟩ + +set_option maxRecDepth 100000 in +theorem SnapshotsBefore.of_done_runDirectResolvedWitnessFromTable + {snapshots : List PlannedProbeSnapshot} + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hbefore : SnapshotsBefore snapshots context) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) : + SnapshotsBefore snapshots result.context := by + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) := by + rw [← map_erase_runDirectResolvedWitnessFromTable computation context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + exact hbefore.trans + (revealed_subset_done_of_mem_runDirectResolvedWitnessFromTable computation context fuel table + result hresult) + (privateValuesLE_of_done_runDirectResolvedDetailedFromTable computation context fuel table + result hdetailed) + +theorem PrivateValuesLE.canonicalize_right + {left right : DeferredContext} (hle : PrivateValuesLE left right) + (table : OtsSecretIndex → HashOutput) : + PrivateValuesLE left (canonicalizeMaterializedValues table right) := by + intro position output hvalue + exact hle position output hvalue + +theorem SnapshotsBefore.canonicalize_right + {snapshots : List PlannedProbeSnapshot} {context : DeferredContext} + (hbefore : SnapshotsBefore snapshots context) + (table : OtsSecretIndex → HashOutput) : + SnapshotsBefore snapshots (canonicalizeMaterializedValues table context) := by + apply hbefore.trans + · rw [canonicalizeMaterializedValues_revealed] + · exact (PrivateValuesLE.refl context).canonicalize_right table + +theorem SnapshotsBefore.revealed_subset_privateWitness + {snapshots : List PlannedProbeSnapshot} + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (witness : PrivateHitWitness) + (hbefore : SnapshotsBefore snapshots context) + (hresult : DirectWitnessResult.stoppedPrivate witness ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) : + ∀ snapshot ∈ snapshots, + snapshot.context.state.revealed ⊆ witness.revealed := by + intro snapshot hsnapshot + exact (hbefore snapshot hsnapshot).1.trans + (revealed_subset_privateWitness_of_mem_runDirectResolvedWitnessFromTable computation context + fuel table witness hresult) + +theorem SnapshotsBefore.privateValue_eq_privateWitness + {snapshots : List PlannedProbeSnapshot} + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (witness : PrivateHitWitness) + (hbefore : SnapshotsBefore snapshots context) + (hresult : DirectWitnessResult.stoppedPrivate witness ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) + {snapshot : PlannedProbeSnapshot} (hsnapshot : snapshot ∈ snapshots) + {output : HashOutput} + (hvalue : snapshot.context.values witness.position = some output) : + output = witness.output := by + have hcurrent := (hbefore snapshot hsnapshot).2 witness.position output hvalue + exact privateValue_eq_privateWitness_of_mem_runDirectResolvedWitnessFromTable computation + context fuel table witness witness.position output hcurrent rfl hresult + +set_option maxRecDepth 100000 in +theorem runDirectResolvedWitnessFromTable_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (left : OracleComp (LazyRevealProbe.World Coordinate) α) + (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) : + runDirectResolvedWitnessFromTable context fuel table (left >>= next) = + runDirectResolvedWitnessFromTable context fuel table left >>= fun result => + match result with + | .stoppedFuel => pure .stoppedFuel + | .stoppedOrdinary => pure .stoppedOrdinary + | .stoppedPrivate witness => pure (.stoppedPrivate witness) + | .done result => + runDirectResolvedWitnessFromTable result.context result.remaining result.table + (next result.value) := by + induction left using OracleComp.inductionOn generalizing context fuel with + | pure value => simp [runDirectResolvedWitnessFromTable] + | query_bind input continuation ih => + cases input with + | uniform n => + rw [bind_assoc, runDirectResolvedWitnessFromTable_uniform_query_bind, + runDirectResolvedWitnessFromTable_uniform_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output context fuel + | hashOutput => + rw [bind_assoc, runDirectResolvedWitnessFromTable_hashOutput_query_bind, + runDirectResolvedWitnessFromTable_hashOutput_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output context fuel + | ensure coordinate => + rw [bind_assoc, runDirectResolvedWitnessFromTable_ensure_query_bind, + runDirectResolvedWitnessFromTable_ensure_query_bind] + exact ih () { context with state := context.state.ensure coordinate } fuel + | probe coordinate candidate => + rw [bind_assoc, runDirectResolvedWitnessFromTable_probe_query_bind, + runDirectResolvedWitnessFromTable_probe_query_bind] + cases fuel with + | zero => simp + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () context remaining + · simp only [hrevealed, ↓reduceIte] + exact ih () + { context with state := context.state.addPending coordinate candidate } + remaining + | peek coordinate => + rw [bind_assoc, runDirectResolvedWitnessFromTable_peek_query_bind, + runDirectResolvedWitnessFromTable_peek_query_bind] + exact ih (context.state.values coordinate) context fuel + | publish coordinate => + rw [bind_assoc, runDirectResolvedWitnessFromTable_publish_query_bind, + runDirectResolvedWitnessFromTable_publish_query_bind] + exact ih () { context with state := context.state.publish coordinate } fuel + | reveal coordinate => + rw [bind_assoc, runDirectResolvedWitnessFromTable_reveal_query_bind, + runDirectResolvedWitnessFromTable_reveal_query_bind] + cases hvalue : context.state.values coordinate with + | some output => exact ih output context fuel + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] + · simp only [output, hhit, ↓reduceIte] + exact ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel + | position position => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hprivate, hhit] + · simp only [hprivate, hhit, ↓reduceIte] + exact ih output + { state := context.state.materialize (.position position) output + values := context.values } + fuel + | none => + simp only [hprivate, bind_assoc] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + exact ih output + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel + +def DirectWitnessPublishedResult : DirectWitnessResult α → Prop + | .stoppedFuel => True + | .stoppedOrdinary => True + | .stoppedPrivate witness => + Coordinate.position witness.position ∉ witness.revealed + | .done result => PublishedValues result.context.state + +def DirectWitnessPreservesPublished + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ context cache fuel table result, + PublishedValues context.state → + result ∈ support + (runDirectResolvedWitnessFromTable context fuel table (computation.run cache)) → + DirectWitnessPublishedResult result + +theorem DirectWitnessPreservesPublished.result + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + (hpreserves : DirectWitnessPreservesPublished computation) + (context : DeferredContext) (cache : SplitHashCache) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (result : DirectWitnessResult (α × SplitHashCache)) + (hpublished : PublishedValues context.state) + (hresult : result ∈ support + (runDirectResolvedWitnessFromTable context fuel table (computation.run cache))) : + DirectWitnessPublishedResult result := by + exact hpreserves context cache fuel table result hpublished hresult + +theorem DirectWitnessPreservesPublished.pure (value : α) : + DirectWitnessPreservesPublished + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := by + intro context cache fuel table result hpublished hresult + simp [runDirectResolvedWitnessFromTable] at hresult + subst result + exact hpublished + +theorem DirectWitnessPreservesPublished.bind + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : DirectWitnessPreservesPublished left) + (hnext : ∀ value, DirectWitnessPreservesPublished (next value)) : + DirectWitnessPreservesPublished (left >>= next) := by + intro context cache fuel table result hpublished hresult + rw [StateT.run_bind, runDirectResolvedWitnessFromTable_bind, + mem_support_bind_iff] at hresult + obtain ⟨middle, hmiddle, hrest⟩ := hresult + have hmiddlePublished := hleft context cache fuel table middle hpublished hmiddle + cases middle with + | stoppedFuel => + simp at hrest + subst result + trivial + | stoppedOrdinary => + simp at hrest + subst result + trivial + | stoppedPrivate witness => + simp at hrest + subst result + exact hmiddlePublished + | done middle => + exact hnext middle.value.1 middle.context middle.value.2 middle.remaining middle.table + result hmiddlePublished hrest + +theorem directWitnessPreservesPublished_revealCoordinateOutput + (coordinate : Coordinate) : + DirectWitnessPreservesPublished (revealCoordinateOutput coordinate) := by + intro context cache fuel table result hpublished hresult + rw [revealCoordinateOutput_run, LazyRevealProbe.revealQuery, + runDirectResolvedWitnessFromTable_reveal_query_bind] at hresult + cases hvalue : context.state.values coordinate with + | some output => + simp [hvalue, runDirectResolvedWitnessFromTable] at hresult + subst result + exact hpublished + | none => + simp only [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + subst result + trivial + · simp [output, hhit, runDirectResolvedWitnessFromTable] at hresult + subst result + exact hpublished.materialize _ _ + | position position => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hprivate, hhit] at hresult + subst result + exact hpublished.not_revealed_of_value_none hvalue + · simp [hprivate, hhit, runDirectResolvedWitnessFromTable] at hresult + subst result + exact hpublished.materialize _ _ + | none => + simp only [hprivate, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hrest + subst result + trivial + · simp [hhit, runDirectResolvedWitnessFromTable] at hrest + subst result + exact hpublished.materialize _ _ + +theorem directWitnessPreservesPublished_revealCoordinate + (coordinate : Coordinate) : + DirectWitnessPreservesPublished (revealCoordinate coordinate) := by + unfold revealCoordinate + exact (directWitnessPreservesPublished_revealCoordinateOutput coordinate).bind fun _ => + DirectWitnessPreservesPublished.pure _ + +set_option maxRecDepth 100000 in +theorem directWitnessPreservesPublished_revealCoordinateOutput_publish + (coordinate : Coordinate) : + DirectWitnessPreservesPublished (do + let output ← revealCoordinateOutput coordinate + publishCoordinate coordinate + pure output) := by + intro context cache fuel table result hpublished hresult + rw [StateT.run_bind, runDirectResolvedWitnessFromTable_bind, + mem_support_bind_iff] at hresult + obtain ⟨middle, hmiddle, hrest⟩ := hresult + have hmiddlePublished := directWitnessPreservesPublished_revealCoordinateOutput coordinate + context cache fuel table middle hpublished hmiddle + cases middle with + | stoppedFuel => + simp at hrest + subst result + trivial + | stoppedOrdinary => + simp at hrest + subst result + trivial + | stoppedPrivate witness => + simp at hrest + subst result + exact hmiddlePublished + | done middle => + have hdetailed : DirectDetailedResult.done middle ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((revealCoordinateOutput coordinate).run cache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((revealCoordinateOutput coordinate).run cache) context fuel table, + support_map] + exact ⟨DirectWitnessResult.done middle, hmiddle, rfl⟩ + have hvalue := + value_of_done_runDirectResolvedDetailedFromTable_revealCoordinateOutput table coordinate + context fuel cache middle hdetailed + change result ∈ support + (runDirectResolvedWitnessFromTable middle.context middle.remaining middle.table + ((publishCoordinate coordinate >>= fun _ => + pure middle.value.1).run middle.value.2)) at hrest + simp only [publishCoordinate, StateT.run_bind, StateT.run_liftM, + StateT.run_pure, bind_assoc, pure_bind] at hrest + rw [LazyRevealProbe.publishQuery, + runDirectResolvedWitnessFromTable_publish_query_bind] at hrest + simp [runDirectResolvedWitnessFromTable] at hrest + subst result + exact hmiddlePublished.publish_of_value coordinate middle.value.1 hvalue + +theorem directWitnessPreservesPublished_revealPublishedCoordinate + (coordinate : Coordinate) : + DirectWitnessPreservesPublished (revealPublishedCoordinate coordinate) := by + have hpreserves := + (directWitnessPreservesPublished_revealCoordinateOutput_publish coordinate).bind + fun output => DirectWitnessPreservesPublished.pure (truncateHash output) + simpa only [revealPublishedCoordinate, revealCoordinate, bind_assoc, pure_bind] using hpreserves + +theorem directWitnessPreservesPublished_modify + (update : SplitHashCache → SplitHashCache) : + DirectWitnessPreservesPublished + (modify update : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit) := by + intro context cache fuel table result hpublished hresult + simp [StateT.run_modify, runDirectResolvedWitnessFromTable] at hresult + subst result + exact hpublished + +theorem directWitnessPreservesPublished_splitHashQuery (key : SplitHashKey) : + DirectWitnessPreservesPublished (splitHashQuery key) := by + intro context cache fuel table result hpublished hresult + rw [splitHashQuery_run_eq] at hresult + cases hlookup : cache key with + | some output => + rw [hlookup] at hresult + simp [runDirectResolvedWitnessFromTable] at hresult + subst result + exact hpublished + | none => + rw [hlookup] at hresult + dsimp only at hresult + rw [LazyRevealProbe.hashOutputQuery, + runDirectResolvedWitnessFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hdone⟩ := hresult + simp [runDirectResolvedWitnessFromTable] at hdone + subst result + exact hpublished + +theorem directWitnessPreservesPublished_peekCoordinate + (coordinate : Coordinate) : + DirectWitnessPreservesPublished (peekCoordinate coordinate) := by + intro context cache fuel table result hpublished hresult + rw [peekCoordinate_run_eq, LazyRevealProbe.peekQuery, + runDirectResolvedWitnessFromTable_peek_query_bind] at hresult + simp [runDirectResolvedWitnessFromTable] at hresult + subst result + exact hpublished + +theorem directWitnessPreservesPublished_ensureCoordinate + (coordinate : Coordinate) : + DirectWitnessPreservesPublished (ensureCoordinate coordinate) := by + intro context cache fuel table result hpublished hresult + unfold ensureCoordinate at hresult + rw [StateT.run_liftM, LazyRevealProbe.ensureQuery, + runDirectResolvedWitnessFromTable_ensure_query_bind] at hresult + simp [runDirectResolvedWitnessFromTable] at hresult + subst result + change PublishedValues (context.state.ensure coordinate) + simpa [PublishedValues, LazyRevealProbe.State.ensure] using hpublished + +theorem directWitnessPreservesPublished_probe (candidate : Probe) : + DirectWitnessPreservesPublished (probe candidate) := by + intro context cache fuel table result hpublished hresult + unfold probe at hresult + rw [StateT.run_liftM, LazyRevealProbe.probeQuery, + runDirectResolvedWitnessFromTable_probe_query_bind] at hresult + cases fuel with + | zero => + simp at hresult + subst result + trivial + | succ remaining => + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · simp [hrevealed, runDirectResolvedWitnessFromTable] at hresult + subst result + exact hpublished + · simp [hrevealed, runDirectResolvedWitnessFromTable] at hresult + subst result + change PublishedValues (context.state.addPending + candidate.coordinate candidate.candidate) + simpa [PublishedValues, LazyRevealProbe.State.addPending] using hpublished + +theorem directWitnessPreservesPublished_sequenceFin {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, DirectWitnessPreservesPublished (computation index)) : + DirectWitnessPreservesPublished (sequenceFin computation) := by + induction n with + | zero => simpa [sequenceFin] using DirectWitnessPreservesPublished.pure Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomponent 0).bind fun _ => + (ih (fun index : Fin n => computation index.succ) + (fun index => hcomponent index.succ)).bind fun _ => + DirectWitnessPreservesPublished.pure _ + +theorem directWitnessPreservesPublished_splitUniformImpl (n : Nat) : + DirectWitnessPreservesPublished (splitUniformImpl n) := by + intro context cache fuel table result hpublished hresult + change result ∈ support (runDirectResolvedWitnessFromTable context fuel table + (LazyRevealProbe.uniformQuery n >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.uniformQuery, + runDirectResolvedWitnessFromTable_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hdone⟩ := hresult + simp [runDirectResolvedWitnessFromTable] at hdone + subst result + exact hpublished + +def DirectWitnessPreservesPublishedImpl {spec : OracleSpec ι} + (impl : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))) : Prop := + ∀ query, DirectWitnessPreservesPublished (impl query) + +theorem DirectWitnessPreservesPublishedImpl.simulateQ + {spec : OracleSpec ι} + {impl : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))} + (himpl : DirectWitnessPreservesPublishedImpl impl) + (computation : OracleComp spec α) : + DirectWitnessPreservesPublished (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => exact DirectWitnessPreservesPublished.pure value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (himpl query).bind ih + +theorem directWitnessPreservesPublishedImpl_ordinaryHashImpl : + DirectWitnessPreservesPublishedImpl ordinaryHashImpl := + fun input => directWitnessPreservesPublished_splitHashQuery (.ordinary input) + +theorem directWitnessPreservesPublished_simulateQ_ordinaryHashImpl + (computation : OracleComp HashSpec α) : + DirectWitnessPreservesPublished (simulateQ ordinaryHashImpl computation) := + directWitnessPreservesPublishedImpl_ordinaryHashImpl.simulateQ computation + +theorem directWitnessPreservesPublished_peekPositionValues : ∀ positions, + DirectWitnessPreservesPublished (peekPositionValues positions) + | [] => DirectWitnessPreservesPublished.pure _ + | position :: remaining => by + rw [peekPositionValues] + exact (directWitnessPreservesPublished_peekCoordinate (.position position)).bind + fun value => match value with + | none => DirectWitnessPreservesPublished.pure none + | some _ => (directWitnessPreservesPublished_peekPositionValues remaining).bind + fun values => match values with + | none => DirectWitnessPreservesPublished.pure none + | some values => DirectWitnessPreservesPublished.pure (some (_ :: values)) + +theorem directWitnessPreservesPublished_peekTableInput + (parameter : PublicParameter) : ∀ coordinate, + DirectWitnessPreservesPublished (peekTableInput parameter coordinate) + | .chainStart _ _ _ _ => DirectWitnessPreservesPublished.pure none + | .position position => by + cases position with + | chain lay tree leafIdx chainIdx step => + simp only [peekTableInput] + by_cases hstep : step.val = 0 + · rw [if_pos hstep] + exact (directWitnessPreservesPublished_peekCoordinate + (.chainStart lay tree leafIdx chainIdx)).bind fun value => + match value with + | none => DirectWitnessPreservesPublished.pure none + | some value => DirectWitnessPreservesPublished.pure (some + (tweakableHashInput parameter + (Position.chain lay tree leafIdx chainIdx step).domain + (digestBytes value))) + · rw [if_neg hstep] + exact (directWitnessPreservesPublished_peekPositionValues + (Position.chain lay tree leafIdx chainIdx step).children).bind fun value => + match value with + | none => DirectWitnessPreservesPublished.pure none + | some values => DirectWitnessPreservesPublished.pure (some + (tweakableHashInput parameter + (Position.chain lay tree leafIdx chainIdx step).domain + (values.flatMap digestBytes))) + | leaf lay tree leafIdx => + simp only [peekTableInput] + exact (directWitnessPreservesPublished_peekPositionValues + (Position.leaf lay tree leafIdx).children).bind fun value => + match value with + | none => DirectWitnessPreservesPublished.pure none + | some values => DirectWitnessPreservesPublished.pure (some + (tweakableHashInput parameter (Position.leaf lay tree leafIdx).domain + (values.flatMap digestBytes))) + | node lay tree level nodeIdx => + simp only [peekTableInput] + exact (directWitnessPreservesPublished_peekPositionValues + (Position.node lay tree level nodeIdx).children).bind fun value => + match value with + | none => DirectWitnessPreservesPublished.pure none + | some values => DirectWitnessPreservesPublished.pure (some + (tweakableHashInput parameter (Position.node lay tree level nodeIdx).domain + (values.flatMap digestBytes))) + | ftsLeaf index tree leafIdx => + simp only [peekTableInput] + exact (directWitnessPreservesPublished_peekPositionValues + (Position.ftsLeaf index tree leafIdx).children).bind fun value => + match value with + | none => DirectWitnessPreservesPublished.pure none + | some values => DirectWitnessPreservesPublished.pure (some + (tweakableHashInput parameter (Position.ftsLeaf index tree leafIdx).domain + (values.flatMap digestBytes))) + | ftsNode index tree level nodeIdx => + simp only [peekTableInput] + exact (directWitnessPreservesPublished_peekPositionValues + (Position.ftsNode index tree level nodeIdx).children).bind fun value => + match value with + | none => DirectWitnessPreservesPublished.pure none + | some values => DirectWitnessPreservesPublished.pure (some + (tweakableHashInput parameter + (Position.ftsNode index tree level nodeIdx).domain + (values.flatMap digestBytes))) + | ftsRoots index => + simp only [peekTableInput] + exact (directWitnessPreservesPublished_peekPositionValues + (Position.ftsRoots index).children).bind fun value => + match value with + | none => DirectWitnessPreservesPublished.pure none + | some values => DirectWitnessPreservesPublished.pure (some + (tweakableHashInput parameter (Position.ftsRoots index).domain + (values.flatMap digestBytes))) +theorem directWitnessPreservesPublished_resolveKnownInput + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) : + DirectWitnessPreservesPublished (resolveKnownInput parameter coordinate input) := by + unfold resolveKnownInput + exact (directWitnessPreservesPublished_peekTableInput parameter coordinate).bind fun known => + match known with + | none => directWitnessPreservesPublished_splitHashQuery (.ordinary input) + | some knownInput => by + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + exact (directWitnessPreservesPublished_revealCoordinateOutput_publish coordinate).bind + fun output => (directWitnessPreservesPublished_modify fun cache => + Function.update cache (.ordinary input) (some output)).bind fun _ => + DirectWitnessPreservesPublished.pure output + · simp only [heq, ↓reduceIte] + exact directWitnessPreservesPublished_splitHashQuery (.ordinary input) + +theorem directWitnessPreservesPublished_executeCandidate? + (candidate? : Option Probe) : + DirectWitnessPreservesPublished (executeCandidate? candidate?) := by + cases candidate? with + | none => exact DirectWitnessPreservesPublished.pure () + | some candidate => exact directWitnessPreservesPublished_probe candidate + +theorem directWitnessPreservesPublished_probingHashQueryAfterPlan + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) : + DirectWitnessPreservesPublished + (probingHashQueryAfterPlan parameter input plan) := by + unfold probingHashQueryAfterPlan executePlannedHashQuery + exact (directWitnessPreservesPublished_executeCandidate? plan.candidate?).bind fun _ => + match plan.action with + | .ordinary => directWitnessPreservesPublished_splitHashQuery (.ordinary input) + | .resolve coordinate => + directWitnessPreservesPublished_resolveKnownInput parameter coordinate input + +theorem directWitnessPreservesPublished_ensureFullChain + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + DirectWitnessPreservesPublished (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (directWitnessPreservesPublished_sequenceFin _ fun step => + directWitnessPreservesPublished_ensureCoordinate + (.position (.chain lay tree leafIdx chainIdx step))).bind fun _ => + DirectWitnessPreservesPublished.pure () + +theorem directWitnessPreservesPublished_ensureChainPrefix + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (digit : Digit) : + DirectWitnessPreservesPublished + (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (directWitnessPreservesPublished_sequenceFin _ fun step => by + split + · exact directWitnessPreservesPublished_ensureCoordinate + (.position (.chain lay tree leafIdx chainIdx step)) + · exact DirectWitnessPreservesPublished.pure ()).bind fun _ => + DirectWitnessPreservesPublished.pure () + +theorem directWitnessPreservesPublished_ensureOtsLeaf + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + DirectWitnessPreservesPublished (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (directWitnessPreservesPublished_sequenceFin _ fun chainIdx => + directWitnessPreservesPublished_ensureFullChain lay tree leafIdx chainIdx).bind fun _ => + directWitnessPreservesPublished_ensureCoordinate (.position (.leaf lay tree leafIdx)) + +theorem directWitnessPreservesPublished_ensureTreeNode + (lay : Layer) (tree : TreeIndex) : ∀ level nodeIdx, + DirectWitnessPreservesPublished (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => by + rw [ensureTreeNode] + exact directWitnessPreservesPublished_ensureOtsLeaf lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (directWitnessPreservesPublished_ensureTreeNode lay tree level + (2 * nodeIdx)).bind fun _ => + (directWitnessPreservesPublished_ensureTreeNode lay tree level + (2 * nodeIdx + 1)).bind fun _ => by + split + · exact directWitnessPreservesPublished_ensureCoordinate _ + · exact DirectWitnessPreservesPublished.pure () + +theorem directWitnessPreservesPublished_maskedTreeNode + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) : + DirectWitnessPreservesPublished (maskedTreeNode lay tree level nodeIdx) := by + cases level with + | zero => + rw [maskedTreeNode] + exact (directWitnessPreservesPublished_ensureTreeNode lay tree 0 nodeIdx).bind fun _ => + directWitnessPreservesPublished_revealCoordinate _ + | succ current => + rw [maskedTreeNode] + exact (directWitnessPreservesPublished_ensureTreeNode lay tree (current + 1) + nodeIdx).bind fun _ => by + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact directWitnessPreservesPublished_revealCoordinate _ + · rw [dif_neg hlevel] + exact DirectWitnessPreservesPublished.pure 0 + +theorem directWitnessPreservesPublished_maskedTreeRoot + (lay : Layer) (tree : TreeIndex) : + DirectWitnessPreservesPublished (maskedTreeRoot lay tree) := + directWitnessPreservesPublished_maskedTreeNode lay tree (layerHeight lay) 0 + +theorem directWitnessPreservesPublished_ensureTreePath + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + DirectWitnessPreservesPublished (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (directWitnessPreservesPublished_sequenceFin _ fun level => by + split + · exact directWitnessPreservesPublished_ensureTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · exact DirectWitnessPreservesPublished.pure ()).bind fun _ => + DirectWitnessPreservesPublished.pure () + +theorem directWitnessPreservesPublished_maskedPublishedTreeRoot : + DirectWitnessPreservesPublished maskedPublishedTreeRoot := by + unfold maskedPublishedTreeRoot + exact (directWitnessPreservesPublished_ensureTreeNode topLayer rootTree + (layerHeight topLayer) 0).bind fun _ => + directWitnessPreservesPublished_revealPublishedCoordinate + (.position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0)) + +theorem directWitnessPreservesPublished_maskedLayerMessage + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + DirectWitnessPreservesPublished (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + split + · exact directWitnessPreservesPublished_maskedTreeRoot _ _ + · exact directWitnessPreservesPublished_simulateQ_ordinaryHashImpl _ + +theorem directWitnessPreservesPublished_maskedOtsSignFrom + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : ∀ attempts counter, + DirectWitnessPreservesPublished + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, _ => DirectWitnessPreservesPublished.pure none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + exact (directWitnessPreservesPublished_simulateQ_ordinaryHashImpl _).bind fun encoded => + match encoded with + | none => directWitnessPreservesPublished_maskedOtsSignFrom parameter lay tree leafIdx + message attempts (counter + 1) + | some encoding => + (directWitnessPreservesPublished_sequenceFin _ fun chainIdx => + directWitnessPreservesPublished_ensureChainPrefix lay tree leafIdx chainIdx + (encoding chainIdx)).bind fun _ => DirectWitnessPreservesPublished.pure _ + +theorem directWitnessPreservesPublished_maskedOtsSign + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : + DirectWitnessPreservesPublished + (maskedOtsSign parameter lay tree leafIdx message) := + directWitnessPreservesPublished_maskedOtsSignFrom parameter lay tree leafIdx message + encodingAttemptLimit 0 + +theorem directWitnessPreservesPublished_maskedSignLayer + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + DirectWitnessPreservesPublished (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + exact (directWitnessPreservesPublished_maskedLayerMessage parameter ftsSecret index lay).bind + fun message => + (directWitnessPreservesPublished_maskedOtsSign parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message).bind fun result => + match result with + | none => DirectWitnessPreservesPublished.pure none + | some _ => + (directWitnessPreservesPublished_ensureTreePath lay (treeIndexAt index lay) + (leafIndexAt index lay)).bind fun _ => DirectWitnessPreservesPublished.pure _ + +theorem directWitnessPreservesPublished_revealLayerValues + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + DirectWitnessPreservesPublished (revealLayerValues index lay encoding) := by + unfold revealLayerValues + exact (directWitnessPreservesPublished_sequenceFin _ fun chainIdx => + directWitnessPreservesPublished_revealPublishedCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + (encoding chainIdx))).bind fun _ => + (directWitnessPreservesPublished_sequenceFin _ fun level => by + split + · cases hlevelValue : level.val with + | zero => exact directWitnessPreservesPublished_revealPublishedCoordinate _ + | succ current => + rw [show current + 1 = Nat.succ current by omega] + change DirectWitnessPreservesPublished + (if hlevel : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hlevel⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0) + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact directWitnessPreservesPublished_revealPublishedCoordinate _ + · rw [dif_neg hlevel] + exact DirectWitnessPreservesPublished.pure 0 + · exact DirectWitnessPreservesPublished.pure 0).bind fun _ => + DirectWitnessPreservesPublished.pure _ + +theorem directWitnessPreservesPublished_ordinarySignDigestLoop + (secretKey : SecretKey) (attempts : Nat) (message : Message) : + DirectWitnessPreservesPublished + (simulateQ ordinaryRomImpl (signDigestLoop attempts secretKey message)) := by + induction attempts with + | zero => + rw [signDigestLoop, simulateQ_pure] + exact DirectWitnessPreservesPublished.pure none + | succ attempts ih => + rw [signDigestLoop, simulateQ_bind] + have hrandomness : DirectWitnessPreservesPublished + (simulateQ ordinaryRomImpl (liftM sampleRandomness)) := by + rw [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_left] + exact (show DirectWitnessPreservesPublishedImpl splitUniformImpl from + fun n => directWitnessPreservesPublished_splitUniformImpl n).simulateQ + sampleRandomness + exact hrandomness.bind fun randomness => by + rw [simulateQ_bind] + have hattempt : DirectWitnessPreservesPublished + (simulateQ ordinaryRomImpl + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))))) := by + rw [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_right] + exact directWitnessPreservesPublished_simulateQ_ordinaryHashImpl _ + exact hattempt.bind fun attempt => by + cases attempt with + | none => exact ih + | some selected => exact DirectWitnessPreservesPublished.pure _ + +theorem directWitnessPreservesPublished_maskedSignAfterDigest + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + DirectWitnessPreservesPublished + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest + exact (directWitnessPreservesPublished_simulateQ_ordinaryHashImpl _).bind fun _ => + (directWitnessPreservesPublished_sequenceFin _ fun lay => + directWitnessPreservesPublished_maskedSignLayer parameter ftsSecret index lay).bind + fun layers => match traverseOption layers with + | none => DirectWitnessPreservesPublished.pure none + | some parts => (directWitnessPreservesPublished_sequenceFin _ fun lay => + directWitnessPreservesPublished_revealLayerValues index lay (parts lay).2).bind + fun _ => DirectWitnessPreservesPublished.pure _ + +theorem directWitnessPreservesPublished_maskedSign + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + DirectWitnessPreservesPublished (maskedSign parameter root ftsSecret message) := by + unfold maskedSign + exact (directWitnessPreservesPublished_ordinarySignDigestLoop + (⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ : SecretKey) digestAttemptLimit + message).bind fun selected => match selected with + | none => DirectWitnessPreservesPublished.pure none + | some data => directWitnessPreservesPublished_maskedSignAfterDigest parameter ftsSecret + data.1 data.2.1 data.2.2 + +def SourceSnapshotStopInvariant (output : PrivateWitnessSnapshotOutput) : Prop := + ∀ witness, output.1 = some witness → + Coordinate.position witness.position ∉ witness.revealed ∧ + ∀ snapshot ∈ output.2, + snapshot.context.state.revealed ⊆ witness.revealed ∧ + ∀ value, snapshot.context.values witness.position = some value → + value = witness.output + +theorem sourceSnapshotStopInvariant_none + (snapshots : List PlannedProbeSnapshot) : + SourceSnapshotStopInvariant (none, snapshots) := by + intro witness hwitness + simp at hwitness + +theorem sourceSnapshotStopInvariant_privateHitWitnessOf + {snapshots : List PlannedProbeSnapshot} {context : DeferredContext} + (hbefore : SnapshotsBefore snapshots context) + (hpublished : PublishedValues context.state) + (hhit : PrivateStructuralHit context) : + SourceSnapshotStopInvariant + (some (privateHitWitnessOf context hhit), snapshots) := by + intro witness hwitness + have hwitnessEq : witness = privateHitWitnessOf context hhit := Option.some.inj hwitness.symm + subst witness + have hspec := privateHitWitnessOf_spec context hhit + constructor + · exact hpublished.not_revealed_of_value_none hspec.1 + · intro snapshot hsnapshot + have hsnapshotBefore := hbefore snapshot hsnapshot + constructor + · simpa [privateHitWitnessOf] using hsnapshotBefore.1 + · intro value hvalue + have hcurrent := hsnapshotBefore.2 _ value hvalue + exact Option.some.inj (hcurrent.symm.trans hspec.2.1) + +set_option maxRecDepth 100000 in +theorem sourceSnapshotStopInvariant_stoppedPrivate + {snapshots : List PlannedProbeSnapshot} + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (witness : PrivateHitWitness) + (hbefore : SnapshotsBefore snapshots context) + (hhidden : Coordinate.position witness.position ∉ witness.revealed) + (hresult : DirectWitnessResult.stoppedPrivate witness ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) : + SourceSnapshotStopInvariant (some witness, snapshots) := by + intro selected hselected + have heq : selected = witness := Option.some.inj hselected.symm + subst selected + refine ⟨hhidden, ?_⟩ + intro snapshot hsnapshot + constructor + · exact hbefore.revealed_subset_privateWitness computation context fuel table witness hresult + snapshot hsnapshot + · intro value hvalue + exact hbefore.privateValue_eq_privateWitness computation context fuel table witness hresult + hsnapshot hvalue + +set_option maxRecDepth 100000 in +theorem sourceSnapshotStopInvariant_of_mem_runDirectWitnessSnapshotObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hbefore : SnapshotsBefore snapshots context) + (hpreserves : ∀ result, + result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation) → + DirectWitnessPublishedResult result) + (hobserve : ∀ result output, + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation) → + SnapshotsBefore snapshots result.context → + PublishedValues result.context.state → + output ∈ support + (observe result.context result.remaining result.value snapshots) → + SourceSnapshotStopInvariant output) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (runDirectWitnessSnapshotObserve observe snapshots context fuel table computation)) : + SourceSnapshotStopInvariant output := by + unfold runDirectWitnessSnapshotObserve at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + have hresultPublished := hpreserves result hresult + cases result with + | stoppedFuel => + simp [finishDirectWitnessSnapshotObserve] at hfinish + subst output + exact sourceSnapshotStopInvariant_none snapshots + | stoppedOrdinary => + simp [finishDirectWitnessSnapshotObserve] at hfinish + subst output + exact sourceSnapshotStopInvariant_none snapshots + | stoppedPrivate witness => + simp [finishDirectWitnessSnapshotObserve] at hfinish + subst output + exact sourceSnapshotStopInvariant_stoppedPrivate computation context fuel table witness + hbefore hresultPublished hresult + | done result => + apply hobserve result output hresult + · exact hbefore.of_done_runDirectResolvedWitnessFromTable computation context fuel table + result hresult + · exact hresultPublished + · simpa [finishDirectWitnessSnapshotObserve] using hfinish + +theorem sourceSnapshotStopInvariant_of_mem_classifyDirectWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (context : DeferredContext) (fuel : Nat) (value : α) + (snapshots : List PlannedProbeSnapshot) + (hbefore : SnapshotsBefore snapshots context) + (hpublished : PublishedValues context.state) + (hobserve : ∀ output ∈ support (observe context fuel value snapshots), + SourceSnapshotStopInvariant output) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (classifyDirectWitnessSnapshotObserve table observe context fuel value snapshots)) : + SourceSnapshotStopInvariant output := by + classical + unfold classifyDirectWitnessSnapshotObserve at houtput + by_cases hhit : PrivateStructuralHit context + · simp [hhit] at houtput + subst output + exact sourceSnapshotStopInvariant_privateHitWitnessOf hbefore hpublished hhit + · simp only [hhit, ↓reduceDIte] at houtput + by_cases hcompletable : DeferredCompletable table context + · exact hobserve output (by simpa [hcompletable] using houtput) + · simp [hcompletable] at houtput + subst output + exact sourceSnapshotStopInvariant_none snapshots + +theorem sourceSnapshotStopInvariant_of_mem_canonicalizeDirectWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (context : DeferredContext) (fuel : Nat) (value : α) + (snapshots : List PlannedProbeSnapshot) + (hbefore : SnapshotsBefore snapshots context) + (hpublished : PublishedValues context.state) + (hobserve : ∀ output ∈ support + (observe (canonicalizeMaterializedValues table context) fuel value snapshots), + SourceSnapshotStopInvariant output) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (canonicalizeDirectWitnessSnapshotObserve table observe context fuel value snapshots)) : + SourceSnapshotStopInvariant output := by + classical + let canonical := canonicalizeMaterializedValues table context + have hcanonicalBefore : SnapshotsBefore snapshots canonical := + hbefore.canonicalize_right table + have hcanonicalPublished : PublishedValues canonical.state := + hpublished.to_canonicalizedMaterializedValues + unfold canonicalizeDirectWitnessSnapshotObserve at houtput + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit] at houtput + subst output + exact sourceSnapshotStopInvariant_privateHitWitnessOf hcanonicalBefore hcanonicalPublished + hhit + · simp only [canonical, hhit, ↓reduceDIte, hpublished, ↓reduceIte] at houtput + exact sourceSnapshotStopInvariant_of_mem_classifyDirectWitnessSnapshotObserve table observe + canonical fuel value snapshots hcanonicalBefore hcanonicalPublished hobserve output houtput + +theorem sourceSnapshotStopInvariant_of_mem_retainedResolvedFinalization + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) + (snapshots : List PlannedProbeSnapshot) + (hbefore : SnapshotsBefore snapshots context) + (hpublished : PublishedValues context.state) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table root context fuel value + snapshots)) : + SourceSnapshotStopInvariant output := by + classical + unfold retainedResolvedFinalizationPrivateWitnessSnapshotObserve at houtput + by_cases hhit : PrivateStructuralHit context + · simp [hhit] at houtput + subst output + exact sourceSnapshotStopInvariant_privateHitWitnessOf hbefore hpublished hhit + · simp [hhit] at houtput + subst output + exact sourceSnapshotStopInvariant_none snapshots + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem sourceSnapshotStopInvariant_of_mem_directDetailedBoundaryNormalized + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hbefore : SnapshotsBefore snapshots context) + (hpublished : PublishedValues context.state) + (hobserve : ∀ nextContext remaining value nextSnapshots, + SnapshotsBefore nextSnapshots nextContext → PublishedValues nextContext.state → + ∀ output ∈ support (observe nextContext remaining value nextSnapshots), + SourceSnapshotStopInvariant output) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root ftsSecret + computation observe snapshots context fuel table cache)) : + SourceSnapshotStopInvariant output := by + induction computation using OracleComp.inductionOn generalizing + snapshots context fuel cache output with + | pure value => + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_pure] at houtput + exact hobserve context fuel (value, cache) snapshots hbefore hpublished output houtput + | query_bind query next ih => + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_query_bind] at houtput + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + refine sourceSnapshotStopInvariant_of_mem_runDirectWitnessSnapshotObserve _ + snapshots context fuel table ((splitUniformImpl n).run cache) hbefore ?_ ?_ + output houtput + · intro result hresult + exact directWitnessPreservesPublished_splitUniformImpl n context cache fuel table + result hpublished hresult + · intro result nextOutput hresult hnextBefore hnextPublished hnext + apply sourceSnapshotStopInvariant_of_mem_canonicalizeDirectWitnessSnapshotObserve + table _ result.context result.remaining result.value snapshots hnextBefore + hnextPublished _ nextOutput hnext + intro finalOutput hfinal + exact ih result.value.1 snapshots + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 (hnextBefore.canonicalize_right table) + hnextPublished.to_canonicalizedMaterializedValues finalOutput hfinal + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let nextSnapshots := appendPlannedSnapshot snapshots + (rootAwarePlannedCandidate? parameter input context.state) context + have hnextBefore : SnapshotsBefore nextSnapshots context := + hbefore.appendPlannedSnapshot _ + refine sourceSnapshotStopInvariant_of_mem_runDirectWitnessSnapshotObserve _ + nextSnapshots context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) hnextBefore ?_ ?_ + output houtput + · intro result hresult + exact directWitnessPreservesPublished_probingHashQueryAfterPlan parameter input plan + context cache fuel table result hpublished hresult + · intro result nextOutput hresult hlaterBefore hlaterPublished hnext + apply sourceSnapshotStopInvariant_of_mem_canonicalizeDirectWitnessSnapshotObserve + table _ result.context result.remaining result.value nextSnapshots hlaterBefore + hlaterPublished _ nextOutput hnext + intro finalOutput hfinal + exact ih result.value.1 nextSnapshots + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 (hlaterBefore.canonicalize_right table) + hlaterPublished.to_canonicalizedMaterializedValues finalOutput hfinal + | inr message => + refine sourceSnapshotStopInvariant_of_mem_runDirectWitnessSnapshotObserve _ snapshots + context fuel table ((maskedSign parameter root ftsSecret message).run cache) hbefore + ?_ ?_ output houtput + · intro result hresult + exact directWitnessPreservesPublished_maskedSign parameter root ftsSecret message + context cache fuel table result hpublished hresult + · intro result nextOutput hresult hnextBefore hnextPublished hnext + apply sourceSnapshotStopInvariant_of_mem_canonicalizeDirectWitnessSnapshotObserve + table _ result.context result.remaining result.value snapshots hnextBefore + hnextPublished _ nextOutput hnext + intro finalOutput hfinal + exact ih result.value.1 snapshots + (canonicalizeMaterializedValues table result.context) result.remaining result.value.2 + (hnextBefore.canonicalize_right table) + hnextPublished.to_canonicalizedMaterializedValues finalOutput hfinal + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem sourceSnapshotStopInvariant_of_mem_granularDetailedRetainedRest + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (snapshots : List PlannedProbeSnapshot) + (hbefore : SnapshotsBefore snapshots context) + (hpublished : PublishedValues context.state) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter + table ftsSecret context fuel value snapshots)) : + SourceSnapshotStopInvariant output := by + unfold granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve at houtput + apply sourceSnapshotStopInvariant_of_mem_directDetailedBoundaryNormalized parameter value.1 + ftsSecret (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table value.1) + snapshots context fuel table value.2 hbefore hpublished _ output houtput + intro nextContext remaining nextValue nextSnapshots hnextBefore hnextPublished finalOutput hfinal + exact sourceSnapshotStopInvariant_of_mem_retainedResolvedFinalization table value.1 nextContext + remaining nextValue nextSnapshots hnextBefore hnextPublished finalOutput hfinal + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem sourceSnapshotStopInvariant_of_mem_granularAll + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (granularAllDirectBoundaryNormalizedPrivateWitnessSnapshot adversary parameter table + ftsSecret fuel)) : + SourceSnapshotStopInvariant output := by + let initialContext : DeferredContext := + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + change output ∈ support (runDirectWitnessSnapshotObserve + (granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter table + ftsSecret) [] initialContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) at houtput + have hbefore : SnapshotsBefore ([] : List PlannedProbeSnapshot) initialContext := + SnapshotsBefore.nil initialContext + have hpreserves : DirectWitnessPreservesPublished maskedPublishedTreeRoot := + directWitnessPreservesPublished_maskedPublishedTreeRoot + have hinitialPublished : PublishedValues initialContext.state := by + exact publishedValues_empty + let hpreservesResult := fun result => + hpreserves.result initialContext emptySplitHashCache fuel table result hinitialPublished + have hobserve : ∀ result nextOutput, + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable initialContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) → + SnapshotsBefore [] result.context → + PublishedValues result.context.state → + nextOutput ∈ support + (granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter + table ftsSecret result.context result.remaining result.value []) → + SourceSnapshotStopInvariant nextOutput := by + intro result nextOutput _ hnextBefore hpublished hnext + exact sourceSnapshotStopInvariant_of_mem_granularDetailedRetainedRest adversary parameter table + ftsSecret result.context result.remaining result.value [] hnextBefore hpublished nextOutput + hnext + exact sourceSnapshotStopInvariant_of_mem_runDirectWitnessSnapshotObserve + (observe := granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary + parameter table ftsSecret) + (snapshots := []) (context := initialContext) (fuel := fuel) (table := table) + (computation := maskedPublishedTreeRoot.run emptySplitHashCache) + hbefore hpreservesResult hobserve output houtput + +attribute [local irreducible] + granularAllDirectBoundaryNormalizedPrivateWitnessSnapshot maskedPublishedTreeRoot in +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem sourceSnapshotStopInvariant_of_mem_sampledGranularAll + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (sampledGranularAllDirectBoundaryNormalizedPrivateWitnessSnapshot adversary parameter + ftsSecret fuel)) : + SourceSnapshotStopInvariant output := by + change output ∈ support (sampleOtsHashTable >>= fun table => + granularAllDirectBoundaryNormalizedPrivateWitnessSnapshot adversary parameter table ftsSecret + fuel) at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨table, _htable, hrest⟩ := houtput + exact sourceSnapshotStopInvariant_of_mem_granularAll adversary parameter table ftsSecret fuel + output hrest + +set_option maxRecDepth 100000 in +theorem selectedObservationHidden_of_sourceSnapshotStopInvariant + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} + {observations : List CleanProbeObservation} + (hsource : SourceSnapshotStopInvariant source) + (haligned : SnapshotsObservedAt table source.2 observations) : + ∀ witness + (sourceOrdinal : Fin + (erasePrivateWitnessSnapshotOutput source).2.length) + (observationOrdinal : Fin observations.length), + (erasePrivateWitnessSnapshotOutput source).1 = some witness → + sourceOrdinal.val = observationOrdinal.val → + firstPrivateWitnessOrdinal? witness + (erasePrivateWitnessSnapshotOutput source).2 = some sourceOrdinal → + (observations.get observationOrdinal).revealedAtProbe = false := by + intro witness sourceOrdinal observationOrdinal hwitness hordinal hfirst + have hwitnessSource : source.1 = some witness := by + simpa [erasePrivateWitnessSnapshotOutput] using hwitness + have hsourceFacts := hsource witness hwitnessSource + have hsourceLength : + (erasePrivateWitnessSnapshotOutput source).2.length = source.2.length := by + simp [erasePrivateWitnessSnapshotOutput] + let snapshotOrdinal : Fin source.2.length := + ⟨sourceOrdinal.val, by + rw [← hsourceLength] + exact sourceOrdinal.isLt⟩ + have hobservationLt : snapshotOrdinal.val < observations.length := by + rw [← haligned.length_eq] + exact snapshotOrdinal.isLt + let alignedObservationOrdinal : Fin observations.length := + ⟨snapshotOrdinal.val, hobservationLt⟩ + have halignedOrdinal : alignedObservationOrdinal = observationOrdinal := by + apply Fin.ext + exact hordinal + have hpair := haligned.get snapshotOrdinal.isLt hobservationLt + have hpair' : PlannedProbeSnapshot.ObservedAt table + (source.2.get snapshotOrdinal) (observations.get observationOrdinal) := by + simpa [alignedObservationOrdinal, halignedOrdinal] using hpair + have hsourceProbe : + (erasePrivateWitnessSnapshotOutput source).2.get sourceOrdinal = + (source.2.get snapshotOrdinal).probe := by + simp [erasePrivateWitnessSnapshotOutput, snapshotOrdinal] + have hmatch := privateWitnessAtOrdinal_of_firstPrivateWitnessOrdinal?_eq_some hfirst + unfold PrivateWitnessAtOrdinal at hmatch + rw [hsourceProbe] at hmatch + have hcoordinate : (observations.get observationOrdinal).coordinate = + Coordinate.position witness.position := by + have hprobe : (observations.get observationOrdinal).toProbe = + (source.2.get snapshotOrdinal).probe := by + exact hpair'.1 + exact congrArg Probe.coordinate hprobe |>.trans hmatch.1 + have hsnapshotHidden : Coordinate.position witness.position ∉ + (source.2.get snapshotOrdinal).context.state.revealed := by + intro hrevealed + exact hsourceFacts.1 + ((hsourceFacts.2 (source.2.get snapshotOrdinal) (List.get_mem _ _)).1 hrevealed) + rw [hpair'.2.2.1] + simp only [decide_eq_false_iff_not] + rwa [hcoordinate] + +theorem PlannedProbeSnapshot.observedAt_of_finalizationContextLE + (table : OtsSecretIndex → HashOutput) + (snapshot : PlannedProbeSnapshot) + (state : LazyRevealProbe.State Coordinate) + (hcontext : FinalizationContextLE table snapshot.context + (directDeferredContext state)) + (hrevealed : snapshot.context.state.revealed = state.revealed) + (hpublished : PublishedValues snapshot.context.state) + (hcanonical : CanonicalMaterializedValues table snapshot.context) : + snapshot.ObservedAt table + (cleanProbeObservation state snapshot.probe.coordinate snapshot.probe.candidate) := by + refine ⟨rfl, ?_, ?_, hpublished, hcanonical⟩ + · intro position hcoordinate + unfold cleanProbeObservation + change state.values snapshot.probe.coordinate = snapshot.context.positionValue position + change snapshot.probe.coordinate = .position position at hcoordinate + rw [hcoordinate] + have hvalue := congrFun hcontext.view.valueEq (.position position) + cases hstate : state.values (.position position) <;> + simpa [resolvedCompletionValue, directDeferredContext, directDeferredValues, + DeferredContext.positionValue, hstate] using hvalue.symm + · change decide (snapshot.probe.coordinate ∈ state.revealed) = + decide (snapshot.probe.coordinate ∈ snapshot.context.state.revealed) + rw [hrevealed] + +theorem canonical_value_none_of_not_revealed + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hcanonical : CanonicalMaterializedValues table context) + {coordinate : Coordinate} (hhidden : coordinate ∉ context.state.revealed) : + context.state.values coordinate = none := by + rw [hcanonical] + simp [publicMaterializedValues, hhidden] + +set_option maxRecDepth 100000 in +theorem witnessFirstUsesSomeDelayedLayerRootSnapshot_of_observedDelayed + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} + {observations : List CleanProbeObservation} + (haligned : SnapshotsObservedAt table source.2 observations) + (hdelayed : WitnessFirstUsesDelayedLayerRoot + (erasePrivateWitnessSnapshotOutput source) observations) + (hselectedHidden : ∀ witness + (sourceOrdinal : Fin + (erasePrivateWitnessSnapshotOutput source).2.length) + (observationOrdinal : Fin observations.length), + source.1 = some witness → + sourceOrdinal.val = observationOrdinal.val → + firstPrivateWitnessOrdinal? witness + (erasePrivateWitnessSnapshotOutput source).2 = some sourceOrdinal → + (observations.get observationOrdinal).revealedAtProbe = false) : + WitnessFirstUsesSomeDelayedLayerRootSnapshot source := by + obtain ⟨witness, sourceOrdinal, observationOrdinal, hwitness, hordinal, + hfirst, hroot, hvalue⟩ := hdelayed + have hsourceLength : + (erasePrivateWitnessSnapshotOutput source).2.length = source.2.length := by + simp [erasePrivateWitnessSnapshotOutput] + let snapshotOrdinal : Fin source.2.length := + ⟨sourceOrdinal.val, by + rw [← hsourceLength] + exact sourceOrdinal.isLt⟩ + have hobservationLt : snapshotOrdinal.val < observations.length := by + rw [← haligned.length_eq] + exact snapshotOrdinal.isLt + have hpair := haligned.get snapshotOrdinal.isLt hobservationLt + let alignedObservationOrdinal : Fin observations.length := + ⟨snapshotOrdinal.val, hobservationLt⟩ + have halignedOrdinal : alignedObservationOrdinal = observationOrdinal := by + apply Fin.ext + exact hordinal + have hpair' : PlannedProbeSnapshot.ObservedAt table + (source.2.get snapshotOrdinal) (observations.get observationOrdinal) := by + simpa [alignedObservationOrdinal, halignedOrdinal] using hpair + have hprobe : + (observations.get observationOrdinal).toProbe = + (source.2.get snapshotOrdinal).probe := by + rw [← halignedOrdinal] + exact hpair.1 + have hcoordinate : + (observations.get observationOrdinal).coordinate = + Coordinate.position witness.position := by + have hsourceProbe : + (erasePrivateWitnessSnapshotOutput source).2.get sourceOrdinal = + (source.2.get snapshotOrdinal).probe := by + simp [erasePrivateWitnessSnapshotOutput, snapshotOrdinal] + have hmatch := privateWitnessAtOrdinal_of_firstPrivateWitnessOrdinal?_eq_some hfirst + unfold PrivateWitnessAtOrdinal at hmatch + rw [hsourceProbe] at hmatch + exact congrArg Probe.coordinate hprobe |>.trans hmatch.1 + have hhiddenObservation := hselectedHidden witness sourceOrdinal observationOrdinal hwitness + hordinal hfirst + have hhiddenSnapshot : Coordinate.position witness.position ∉ + (source.2.get snapshotOrdinal).context.state.revealed := by + intro hrevealed + have hfalse : decide ((observations.get observationOrdinal).coordinate ∈ + (source.2.get snapshotOrdinal).context.state.revealed) = false := + hpair'.2.2.1.symm.trans hhiddenObservation + simp only [decide_eq_false_iff_not] at hfalse + apply hfalse + rw [hcoordinate] + exact hrevealed + have hstate : (source.2.get snapshotOrdinal).context.state.values + (.position witness.position) = none := + canonical_value_none_of_not_revealed hpair.2.2.2.2 hhiddenSnapshot + have hpositionValue : (source.2.get snapshotOrdinal).context.positionValue + witness.position = some witness.output := by + have hcompletion := hpair'.2.1 witness.position hcoordinate + exact hcompletion.symm.trans hvalue + have hsourceFirst : firstPrivateWitnessOrdinal? witness + (source.2.map PlannedProbeSnapshot.toProbe) = + some (snapshotProbeOrdinal snapshotOrdinal) := by + simpa [erasePrivateWitnessSnapshotOutput, snapshotProbeOrdinal, snapshotOrdinal] using hfirst + have hwitnessSource : source.1 = some witness := by + simpa [erasePrivateWitnessSnapshotOutput] using hwitness + have hsourceProbe : + (erasePrivateWitnessSnapshotOutput source).2.get sourceOrdinal = + (source.2.get snapshotOrdinal).probe := by + simp [erasePrivateWitnessSnapshotOutput, snapshotOrdinal] + have hsnapshotRoot : (source.2.get snapshotOrdinal).probe.IsLayerRoot := by + rw [← hsourceProbe] + exact hroot + refine ⟨snapshotOrdinal.val, witness, snapshotOrdinal, hwitnessSource, rfl, + hsourceFirst, hsnapshotRoot, hstate, hhiddenSnapshot, ?_⟩ + exact deferredValue_eq_of_positionValue_eq_of_state_none hstate hpositionValue + +set_option maxRecDepth 100000 in +theorem witnessFirstUsesSomeDelayedLayerRootSnapshot_of_aligned_tracked + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} + {result : ObservedCleanRunResult α} + (haligned : SnapshotsObservedAt table source.2 result.observations) + (hfirst : WitnessFirstUsesSomeLayerRoot + (erasePrivateWitnessSnapshotOutput source)) + (htracked : CleanProbeObservationsTrackedBy result.observations result.state) + (hstored : ∀ witness, + (erasePrivateWitnessSnapshotOutput source).1 = some witness → + result.state.values (Coordinate.position witness.position) = some witness.output) + (hselectedHidden : ∀ witness + (sourceOrdinal : Fin + (erasePrivateWitnessSnapshotOutput source).2.length) + (observationOrdinal : Fin result.observations.length), + (erasePrivateWitnessSnapshotOutput source).1 = some witness → + sourceOrdinal.val = observationOrdinal.val → + firstPrivateWitnessOrdinal? witness + (erasePrivateWitnessSnapshotOutput source).2 = some sourceOrdinal → + (result.observations.get observationOrdinal).revealedAtProbe = false) : + WitnessFirstUsesSomeDelayedLayerRootSnapshot source := by + apply witnessFirstUsesSomeDelayedLayerRootSnapshot_of_observedDelayed haligned + (witnessFirstUsesDelayedLayerRoot_of_aligned_tracked hfirst ?_ htracked hstored + hselectedHidden) + hselectedHidden + change source.2.map PlannedProbeSnapshot.toProbe <+: + result.observations.map CleanProbeObservation.toProbe + rw [haligned.map_toProbe_eq] + +set_option maxRecDepth 100000 in +theorem witnessFirstUsesSomeDelayedLayerRootSnapshot_of_aligned_tracked_sourceInvariant + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} + {result : ObservedCleanRunResult α} + (hsource : SourceSnapshotStopInvariant source) + (haligned : SnapshotsObservedAt table source.2 result.observations) + (hfirst : WitnessFirstUsesSomeLayerRoot + (erasePrivateWitnessSnapshotOutput source)) + (htracked : CleanProbeObservationsTrackedBy result.observations result.state) + (hstored : ∀ witness, + (erasePrivateWitnessSnapshotOutput source).1 = some witness → + result.state.values (Coordinate.position witness.position) = some witness.output) : + WitnessFirstUsesSomeDelayedLayerRootSnapshot source := by + exact witnessFirstUsesSomeDelayedLayerRootSnapshot_of_aligned_tracked haligned hfirst htracked + hstored (selectedObservationHidden_of_sourceSnapshotStopInvariant hsource haligned) + +def attachCleanProbeObservations (observations : List CleanProbeObservation) : + Option (CleanRunResult α) → Option (ObservedCleanRunResult α) + | none => none + | some result => some + ⟨result.state, result.remaining, result.value, result.table, observations⟩ + +set_option maxRecDepth 100000 in +theorem map_attachCleanProbeObservations_runCleanFromTable_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hprobeFree : computation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) : + attachCleanProbeObservations observations <$> + runCleanFromTable state fuel table computation = + runObservedCleanFromTable observations state fuel table computation := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + simp [runCleanFromTable, runObservedCleanFromTable, + attachCleanProbeObservations] + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hprobeFree + cases query with + | uniform n => + rw [runCleanFromTable, runObservedCleanFromTable, + OracleComp.construct_query_bind, OracleComp.construct_query_bind, + map_bind] + apply bind_congr + intro output + exact ih output state fuel (hprobeFree.2 output) + | hashOutput => + rw [runCleanFromTable, runObservedCleanFromTable, + OracleComp.construct_query_bind, OracleComp.construct_query_bind, + map_bind] + apply bind_congr + intro output + exact ih output state fuel (hprobeFree.2 output) + | ensure coordinate => + rw [runCleanFromTable, runObservedCleanFromTable, + OracleComp.construct_query_bind, OracleComp.construct_query_bind] + exact ih () (state.ensure coordinate) fuel (hprobeFree.2 ()) + | probe coordinate candidate => + simp [LazyRevealProbe.IsProbe] at hprobeFree + | peek coordinate => + rw [runCleanFromTable, runObservedCleanFromTable, + OracleComp.construct_query_bind, OracleComp.construct_query_bind] + exact ih (state.values coordinate) state fuel (hprobeFree.2 _) + | publish coordinate => + rw [runCleanFromTable, runObservedCleanFromTable, + OracleComp.construct_query_bind, OracleComp.construct_query_bind] + exact ih () (state.publish coordinate) fuel (hprobeFree.2 ()) + | reveal coordinate => + rw [runCleanFromTable, runObservedCleanFromTable, + OracleComp.construct_query_bind, OracleComp.construct_query_bind] + cases hvalue : state.values coordinate with + | some output => + simp only [hvalue] + exact ih output state fuel (hprobeFree.2 output) + | none => + simp only [hvalue] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit, attachCleanProbeObservations] + · simp only [output, hhit, ↓reduceIte] + exact ih output + (state.materialize (.chainStart lay tree leafIdx chainIdx) output) + fuel (hprobeFree.2 output) + | position position => + rw [map_bind] + apply bind_congr + intro output + by_cases hhit : state.hitAt (.position position) output + · simp [hhit, attachCleanProbeObservations] + · simp only [hhit, ↓reduceIte] + exact ih output (state.materialize (.position position) output) + fuel (hprobeFree.2 output) + +theorem runObservedCleanFromTable_reveal_query_bind + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) : + runObservedCleanFromTable observations state fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.reveal coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = + (match state.values coordinate with + | some output => + runObservedCleanFromTable observations state fuel table (next output) + | none => + match coordinate with + | .chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + if state.hitAt coordinate output then pure none + else runObservedCleanFromTable observations + (state.materialize coordinate output) fuel table (next output) + | .position _ => do + let output ← LazyRevealProbe.sampleHashOutput + if state.hitAt coordinate output then pure none + else + runObservedCleanFromTable observations + (state.materialize coordinate output) fuel table (next output)) := by + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] + cases coordinate <;> rfl + +theorem runObservedCleanFromTable_bind + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (left : OracleComp (LazyRevealProbe.World Coordinate) α) + (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) : + runObservedCleanFromTable observations state fuel table (left >>= next) = + runObservedCleanFromTable observations state fuel table left >>= fun result => + match result with + | none => pure none + | some result => + runObservedCleanFromTable result.observations result.state result.remaining + result.table (next result.value) := by + induction left using OracleComp.inductionOn generalizing observations state fuel with + | pure value => simp [runObservedCleanFromTable] + | query_bind query continuation ih => + cases query with + | uniform n => + rw [bind_assoc, runObservedCleanFromTable, OracleComp.construct_query_bind, + runObservedCleanFromTable, OracleComp.construct_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output observations state fuel + | hashOutput => + rw [bind_assoc, runObservedCleanFromTable, OracleComp.construct_query_bind, + runObservedCleanFromTable, OracleComp.construct_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output observations state fuel + | ensure coordinate => + rw [bind_assoc, runObservedCleanFromTable, OracleComp.construct_query_bind, + runObservedCleanFromTable, OracleComp.construct_query_bind] + exact ih () observations (state.ensure coordinate) fuel + | probe coordinate candidate => + rw [bind_assoc, runObservedCleanFromTable_probe_query_bind, + runObservedCleanFromTable_probe_query_bind] + cases fuel with + | zero => simp + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () + (observations ++ [cleanProbeObservation state coordinate candidate]) + state remaining + · simp only [hrevealed, ↓reduceIte] + exact ih () + (observations ++ [cleanProbeObservation state coordinate candidate]) + (state.addPending coordinate candidate) remaining + | peek coordinate => + rw [bind_assoc, runObservedCleanFromTable, OracleComp.construct_query_bind, + runObservedCleanFromTable, OracleComp.construct_query_bind] + exact ih (state.values coordinate) observations state fuel + | publish coordinate => + rw [bind_assoc, runObservedCleanFromTable, OracleComp.construct_query_bind, + runObservedCleanFromTable, OracleComp.construct_query_bind] + exact ih () observations (state.publish coordinate) fuel + | reveal coordinate => + rw [bind_assoc, runObservedCleanFromTable_reveal_query_bind, + runObservedCleanFromTable_reveal_query_bind] + cases hvalue : state.values coordinate with + | some output => exact ih output observations state fuel + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] + · simp only [output, hhit, ↓reduceIte] + exact ih output observations + (state.materialize (.chainStart lay tree leafIdx chainIdx) output) fuel + | position position => + simp only [bind_assoc] + apply bind_congr + intro output + by_cases hhit : state.hitAt (.position position) output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + exact ih output observations + (state.materialize (.position position) output) fuel + +theorem relTriple_graph_of_map_eq + (left : ProbComp α) (right : ProbComp β) (project : α → β) + (hproject : project <$> left = right) : + RelTriple left right (fun leftOutput rightOutput => + project leftOutput = rightOutput) := by + have hgraph : RelTriple left (project <$> left) + (fun leftOutput rightOutput => project leftOutput = rightOutput) := by + have hbase : RelTriple left left (fun leftOutput rightOutput => + project leftOutput = project rightOutput) := by + apply relTriple_post_mono (relTriple_refl left) + intro leftOutput rightOutput heq + subst rightOutput + rfl + have hmapped : RelTriple (id <$> left) (project <$> left) + (fun leftOutput rightOutput => project leftOutput = rightOutput) := + relTriple_map + (R := fun leftOutput rightOutput => project leftOutput = rightOutput) + (f := id) (g := project) hbase + simpa using hmapped + exact relTriple_of_evalDist_eq_right (congrArg evalDist hproject) hgraph + +theorem relTriple_sampledSnapshot_privateWitnessPlan + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + RelTriple + (sampledGranularAllDirectBoundaryNormalizedPrivateWitnessSnapshot adversary parameter + ftsSecret fuel) + (sampledGranularAllDirectBoundaryNormalizedPrivateWitnessPlan adversary parameter + ftsSecret fuel) + (fun snapshot plan => erasePrivateWitnessSnapshotOutput snapshot = plan) := by + exact relTriple_graph_of_map_eq _ _ erasePrivateWitnessSnapshotOutput + (map_erase_sampledGranularAllDirectBoundaryNormalizedPrivateWitnessSnapshot adversary + parameter ftsSecret fuel) + +theorem probEvent_root_le_observedFailure_add_delayed_of_relTriple + (source : ProbComp PrivateWitnessSnapshotOutput) + (observed : ProbComp (Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)))) + (hrel : RelTriple source observed SnapshotObservedRootRel) : + Pr[fun output => + WitnessFirstUsesSomeLayerRoot (erasePrivateWitnessSnapshotOutput output) | source] ≤ + Pr[= none | observed] + + Pr[WitnessFirstUsesSomeDelayedLayerRootSnapshot | source] := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_le_failure_add_residual_of_relTriple source observed + SnapshotObservedRootRel + (fun output => + WitnessFirstUsesSomeLayerRoot (erasePrivateWitnessSnapshotOutput output)) + WitnessFirstUsesSomeDelayedLayerRootSnapshot (fun output => output = none) hrel + intro sourceOutput observedOutput hrelation hroot hnotDelayed + rcases hrelation with hfailure | hsuccess + · exact hfailure + · exact False.elim (hnotDelayed (hsuccess hroot)) + +theorem probEvent_root_map_erase_sampledSnapshot_eq + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun output => + WitnessFirstUsesSomeLayerRoot (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllDirectBoundaryNormalizedPrivateWitnessSnapshot adversary parameter + ftsSecret fuel] = + Pr[WitnessFirstUsesSomeLayerRoot | + sampledGranularAllDirectBoundaryNormalizedPrivateWitnessPlan adversary parameter + ftsSecret fuel] := by + calc + _ = Pr[WitnessFirstUsesSomeLayerRoot | + erasePrivateWitnessSnapshotOutput <$> + sampledGranularAllDirectBoundaryNormalizedPrivateWitnessSnapshot adversary parameter + ftsSecret fuel] := by + rw [probEvent_map] + exact OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) rfl + _ = _ := OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + (congrArg evalDist + (map_erase_sampledGranularAllDirectBoundaryNormalizedPrivateWitnessSnapshot adversary + parameter ftsSecret fuel)) + +theorem probEvent_sampledPlan_root_le_observedFailure_add_delayed + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (hrel : RelTriple + (sampledGranularAllDirectBoundaryNormalizedPrivateWitnessSnapshot adversary parameter + ftsSecret fuel) + (sampledObservedRootAwareClean adversary parameter ftsSecret fuel) + SnapshotObservedRootRel) : + Pr[WitnessFirstUsesSomeLayerRoot | + sampledGranularAllDirectBoundaryNormalizedPrivateWitnessPlan adversary parameter + ftsSecret fuel] ≤ + Pr[= none | sampledObservedRootAwareClean adversary parameter ftsSecret fuel] + + Pr[WitnessFirstUsesSomeDelayedLayerRootSnapshot | + sampledGranularAllDirectBoundaryNormalizedPrivateWitnessSnapshot adversary parameter + ftsSecret fuel] := by + rw [← probEvent_root_map_erase_sampledSnapshot_eq adversary parameter ftsSecret fuel] + exact probEvent_root_le_observedFailure_add_delayed_of_relTriple _ _ hrel + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalFinish.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalFinish.lean new file mode 100644 index 00000000..f9d8afa8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalFinish.lean @@ -0,0 +1,98 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTop + +/-! +# Global materialized comparison finalization + +The adaptive comparison keeps a single clean-or-doomed alternative through the retained run. This +module discharges that alternative once, at finalization, and preserves the source witness value and +the chronological probe observations on every successful completion. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem observations_eq_of_mem_finishObservedCleanRunFromTable + (result finalResult : ObservedCleanRunResult α) + (hresult : some finalResult ∈ support + (finishObservedCleanRunFromTable (some result))) : + finalResult.observations = result.observations := by + unfold finishObservedCleanRunFromTable at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨finalized, _hfinalized, hreturn⟩ := hresult + cases finalized with + | none => simp at hreturn + | some value => + rcases value with ⟨finalState, finalTable⟩ + simp only [support_pure, Set.mem_singleton_iff, Option.some.injEq] at hreturn + obtain ⟨rfl, rfl, rfl, rfl, rfl⟩ := hreturn + rfl + +theorem relTriple_pure_finishObservedMaterialized_of_stable + (table : OtsSecretIndex → HashOutput) + (source : PrivateWitnessSnapshotOutput) + (observed : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))) + (hrelation : SnapshotObservedPrefixStableRel table source observed) : + RelTriple + (pure source : ProbComp PrivateWitnessSnapshotOutput) + (finishObservedMaterializedCleanRunFromTable table observed) + (SnapshotObservedPrefixValueRel table) := by + rcases hrelation with hfailed | hsuccess | hdoomed + · subst observed + simp [finishObservedMaterializedCleanRunFromTable, + SnapshotObservedPrefixValueRel] + · obtain ⟨result, aligned, hresult, hprefix, haligned, hstored⟩ := hsuccess + subst observed + by_cases hcompletable : + DeferredCompletable table (directDeferredContext result.state) + · simp only [finishObservedMaterializedCleanRunFromTable, hcompletable, ↓reduceIte] + have hbase := relTriple_true (pure source : ProbComp PrivateWitnessSnapshotOutput) + (finishObservedCleanRunFromTable (some result)) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun output => output = source) (by + intro output houtput + simpa using houtput) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro left final hfacts + rcases hfacts with ⟨⟨_htrue, hleftEq⟩, hfinalSupport⟩ + subst left + cases final with + | none => exact Or.inl rfl + | some finalResult => + right + refine ⟨finalResult, aligned, rfl, ?_, haligned, ?_⟩ + · rw [observations_eq_of_mem_finishObservedCleanRunFromTable result finalResult + hfinalSupport] + exact hprefix + · intro witness hwitness + exact valuesLE_of_mem_finishObservedCleanRunFromTable result finalResult + hfinalSupport (.position witness.position) witness.output + (hstored witness hwitness) + · simp [finishObservedMaterializedCleanRunFromTable, hcompletable, + SnapshotObservedPrefixValueRel] + · obtain ⟨result, hresult, hdoomed⟩ := hdoomed + subst observed + have hnotCompletable : + ¬DeferredCompletable table (directDeferredContext result.state) := hdoomed.2.2 + simp [finishObservedMaterializedCleanRunFromTable, hnotCompletable, + SnapshotObservedPrefixValueRel] + +theorem relTriple_finishObservedMaterialized_of_stable + (table : OtsSecretIndex → HashOutput) + (source : ProbComp PrivateWitnessSnapshotOutput) + (observed : ProbComp (Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)))) + (hrelation : RelTriple source observed (SnapshotObservedPrefixStableRel table)) : + RelTriple source + (observed >>= finishObservedMaterializedCleanRunFromTable table) + (SnapshotObservedPrefixValueRel table) := by + have hbound := relTriple_bind hrelation fun sourceOutput observedOutput houtput => + relTriple_pure_finishObservedMaterialized_of_stable table sourceOutput observedOutput houtput + simpa using hbound + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalLift.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalLift.lean new file mode 100644 index 00000000..9b83552d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalLift.lean @@ -0,0 +1,1189 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalOperational + +/-! +# Adaptive materialized observation lift + +The local source-to-observation coupling is lifted through the complete retained computation while +keeping the shared clean-failure alternative outside every root position and ordinal. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option maxRecDepth 100000 in +theorem valuesLE_of_mem_runObservedCleanFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (result : ObservedCleanRunResult α) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table computation)) : + LazyRevealProbe.ValuesLE state result.state := by + have hclean : some result.toClean ∈ support + (runCleanFromTable state fuel table computation) := by + rw [← map_projectObservedCleanRun_runObservedCleanFromTable computation observations + state fuel table, support_map] + exact ⟨some result, hresult, rfl⟩ + rw [← map_projectDirectDetailedClean_run_eq_clean computation state fuel table, + support_map] at hclean + obtain ⟨detailed, hdetailed, hproject⟩ := hclean + cases detailed with + | stopped reason => + simp [projectDirectDetailedClean, DirectDetailedResult.toOption, + projectResolvedRunResult] at hproject + | done detailed => + have heq : result.toClean = + ⟨detailed.context.state, detailed.remaining, detailed.value, detailed.table⟩ := by + exact Option.some.inj (by simpa [projectDirectDetailedClean, + DirectDetailedResult.toOption, projectResolvedRunResult] using hproject.symm) + have hstate : result.state = detailed.context.state := congrArg CleanRunResult.state heq + rw [hstate] + exact valuesLE_of_done_runDirectResolvedDetailedFromTable computation + (directDeferredContext state) fuel table detailed hdetailed + +theorem LazyRevealProbe.valuesLE_clearPending + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) : + LazyRevealProbe.ValuesLE state (state.clearPending coordinate) := by + intro other output hvalue + exact hvalue + +theorem LazyRevealProbe.valuesLE_complete_of_none + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (output : HashOutput) (hnone : state.values coordinate = none) : + LazyRevealProbe.ValuesLE state (state.complete coordinate output) := by + intro other stored hvalue + by_cases heq : other = coordinate + · subst other + rw [hnone] at hvalue + simp at hvalue + · simpa [LazyRevealProbe.State.complete, Function.update_of_ne heq] using hvalue + +set_option maxRecDepth 100000 in +theorem valuesLE_of_mem_finalizeCleanFromTable : + ∀ (coordinates : List Coordinate) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) + (finalState : LazyRevealProbe.State Coordinate) + (finalTable : OtsSecretIndex → HashOutput), + some (finalState, finalTable) ∈ support + (finalizeCleanFromTable coordinates state table) → + LazyRevealProbe.ValuesLE state finalState + | [], state, table, finalState, finalTable, hresult => by + simp [finalizeCleanFromTable] at hresult + obtain ⟨rfl, rfl⟩ := hresult + exact fun _ _ hvalue => hvalue + | coordinate :: remaining, state, table, finalState, finalTable, hresult => by + rw [finalizeCleanFromTable.eq_def] at hresult + cases hvalue : state.values coordinate with + | some output => + simp only [hvalue] at hresult + exact (LazyRevealProbe.valuesLE_clearPending state coordinate).trans + (valuesLE_of_mem_finalizeCleanFromTable remaining + (state.clearPending coordinate) table finalState finalTable hresult) + | none => + simp only [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : state.hitAt (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + exact (LazyRevealProbe.valuesLE_complete_of_none state + (.chainStart lay tree leafIdx chainIdx) output hvalue).trans + (valuesLE_of_mem_finalizeCleanFromTable remaining + (state.complete (.chainStart lay tree leafIdx chainIdx) output) table + finalState finalTable hresult) + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : state.hitAt (.position position) output + · simp [hhit] at hrest + · simp only [hhit, ↓reduceIte] at hrest + exact (LazyRevealProbe.valuesLE_complete_of_none state (.position position) + output hvalue).trans + (valuesLE_of_mem_finalizeCleanFromTable remaining + (state.complete (.position position) output) table finalState finalTable + hrest) + +theorem valuesLE_of_mem_finishObservedCleanRunFromTable + (result finalResult : ObservedCleanRunResult α) + (hresult : some finalResult ∈ support + (finishObservedCleanRunFromTable (some result))) : + LazyRevealProbe.ValuesLE result.state finalResult.state := by + unfold finishObservedCleanRunFromTable at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨finalized, hfinalized, hreturn⟩ := hresult + cases finalized with + | none => simp at hreturn + | some value => + rcases value with ⟨finalState, finalTable⟩ + simp only [support_pure, Set.mem_singleton_iff, Option.some.injEq] at hreturn + obtain ⟨rfl, rfl, rfl, rfl, rfl⟩ := hreturn + exact valuesLE_of_mem_finalizeCleanFromTable result.state.coordinates.toList result.state + result.table finalState finalTable hfinalized + +set_option maxRecDepth 100000 in +theorem observations_prefix_of_mem_runObservedCleanFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (result : ObservedCleanRunResult α) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table computation)) : + observations <+: result.observations := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table with + | pure value => + simp [runObservedCleanFromTable] at hresult + subst result + exact List.prefix_rfl + | query_bind query next ih => + cases query with + | uniform n => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output observations state fuel table hrest + | hashOutput => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output observations state fuel table hrest + | ensure coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih () observations (state.ensure coordinate) fuel table hresult + | probe coordinate candidate => + rw [runObservedCleanFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · exact List.prefix_append observations + [cleanProbeObservation state coordinate candidate] |>.trans + (ih () (observations ++ [cleanProbeObservation state coordinate candidate]) + state remaining table (by simpa [hrevealed] using hresult)) + · exact List.prefix_append observations + [cleanProbeObservation state coordinate candidate] |>.trans + (ih () (observations ++ [cleanProbeObservation state coordinate candidate]) + (state.addPending coordinate candidate) remaining table + (by simpa [hrevealed] using hresult)) + | peek coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih (state.values coordinate) observations state fuel table hresult + | publish coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + exact ih () observations (state.publish coordinate) fuel table hresult + | reveal coordinate => + rw [runObservedCleanFromTable, OracleComp.construct_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + simp only [hvalue] at hresult + exact ih output observations state fuel table hresult + | none => + simp only [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : state.hitAt (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + exact ih output observations + (state.materialize (.chainStart lay tree leafIdx chainIdx) output) fuel table + hresult + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : state.hitAt (.position position) output + · simp [hhit] at hrest + · simp only [hhit, ↓reduceIte] at hrest + exact ih output observations (state.materialize (.position position) output) + fuel table hrest + +set_option maxRecDepth 100000 in +theorem remaining_le_of_mem_runObservedCleanFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (result : ObservedCleanRunResult α) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table computation)) : + result.remaining ≤ fuel := by + have hclean : some result.toClean ∈ support + (runCleanFromTable state fuel table computation) := by + rw [← map_projectObservedCleanRun_runObservedCleanFromTable computation observations + state fuel table, support_map] + exact ⟨some result, hresult, rfl⟩ + rw [← map_projectDirectDetailedClean_run_eq_clean computation state fuel table, + support_map] at hclean + obtain ⟨detailed, hdetailed, hproject⟩ := hclean + cases detailed with + | stopped reason => + simp [projectDirectDetailedClean, DirectDetailedResult.toOption, + projectResolvedRunResult] at hproject + | done detailed => + have heq : result.toClean = + ⟨detailed.context.state, detailed.remaining, detailed.value, detailed.table⟩ := by + exact Option.some.inj (by simpa [projectDirectDetailedClean, + DirectDetailedResult.toOption, projectResolvedRunResult] using hproject.symm) + have hremaining : result.remaining = detailed.remaining := + congrArg CleanRunResult.remaining heq + rw [hremaining] + exact remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable computation + (directDeferredContext state) fuel table detailed hdetailed + +set_option maxRecDepth 100000 in +theorem fuel_le_remaining_add_of_mem_runObservedCleanFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (result : ObservedCleanRunResult α) (bound : Nat) + (hbound : computation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) bound) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table computation)) : + fuel ≤ result.remaining + bound := by + have hclean : some result.toClean ∈ support + (runCleanFromTable state fuel table computation) := by + rw [← map_projectObservedCleanRun_runObservedCleanFromTable computation observations + state fuel table, support_map] + exact ⟨some result, hresult, rfl⟩ + rw [← map_projectDirectDetailedClean_run_eq_clean computation state fuel table, + support_map] at hclean + obtain ⟨detailed, hdetailed, hproject⟩ := hclean + cases detailed with + | stopped reason => + simp [projectDirectDetailedClean, DirectDetailedResult.toOption, + projectResolvedRunResult] at hproject + | done detailed => + have heq : result.toClean = + ⟨detailed.context.state, detailed.remaining, detailed.value, detailed.table⟩ := by + exact Option.some.inj (by simpa [projectDirectDetailedClean, + DirectDetailedResult.toOption, projectResolvedRunResult] using hproject.symm) + have hremaining : result.remaining = detailed.remaining := + congrArg CleanRunResult.remaining heq + rw [hremaining] + exact fuel_le_remaining_add_of_done_runDirectResolvedDetailedFromTable computation + (directDeferredContext state) fuel table detailed bound hbound hdetailed + +set_option maxRecDepth 100000 in +theorem materializedDoomed_of_mem_runObservedCleanFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (result : ObservedCleanRunResult α) + (hdoomed : DoomedResolvedContext table (directDeferredContext state)) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table computation)) : + result.table = table ∧ + DoomedResolvedContext table (directDeferredContext result.state) := by + have hclean : some result.toClean ∈ support + (runCleanFromTable state fuel table computation) := by + rw [← map_projectObservedCleanRun_runObservedCleanFromTable computation observations + state fuel table, support_map] + exact ⟨some result, hresult, rfl⟩ + rw [← map_projectDirectDetailedClean_run_eq_clean computation state fuel table, + support_map] at hclean + obtain ⟨detailed, hdetailed, hproject⟩ := hclean + cases detailed with + | stopped reason => + simp [projectDirectDetailedClean, DirectDetailedResult.toOption, + projectResolvedRunResult] at hproject + | done detailed => + have heq : result.toClean = + ⟨detailed.context.state, detailed.remaining, detailed.value, detailed.table⟩ := by + exact Option.some.inj (by simpa [projectDirectDetailedClean, + DirectDetailedResult.toOption, projectResolvedRunResult] using hproject.symm) + have hstate : result.state = detailed.context.state := congrArg CleanRunResult.state heq + have htable : result.table = detailed.table := congrArg CleanRunResult.table heq + have hdoom := finalizationDoomedRun_of_mem_runDirectResolvedDetailedFromTable table + computation (directDeferredContext state) fuel detailed hdoomed hdetailed + have hmaterialized := directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + computation state fuel table (.done detailed) hdetailed + rw [hstate, htable, hdoom.1, ← hmaterialized] + exact ⟨rfl, hdoom.2⟩ + +set_option maxRecDepth 100000 in +theorem valuesLE_of_mem_observedMaterializedBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hresult : some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache)) : + LazyRevealProbe.ValuesLE state result.state := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table cache with + | pure value => + simp [observedMaterializedBoundary] at hresult + obtain rfl := hresult + exact LazyRevealProbe.ValuesLE.refl state + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind] at hresult + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + exact (valuesLE_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run cache) observations state fuel table step hstep).trans + (ih step.value.1 step.observations step.state step.remaining table + step.value.2 (by simpa only [observedMaterializedBoundary] using hrest)) + | inr input => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + exact (valuesLE_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache) observations state fuel table step hstep).trans + (ih step.value.1 step.observations step.state step.remaining table + step.value.2 (by simpa only [observedMaterializedBoundary] using hrest)) + | inr message => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + exact (valuesLE_of_mem_runObservedCleanFromTable + ((maskedSign parameter root ftsSecret message).run cache) observations state fuel + table step hstep).trans + (ih step.value.1 step.observations step.state step.remaining table + step.value.2 (by simpa only [observedMaterializedBoundary] using hrest)) + +set_option maxRecDepth 100000 in +theorem observations_prefix_of_mem_observedMaterializedBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hresult : some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache)) : + observations <+: result.observations := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table cache with + | pure value => + simp [observedMaterializedBoundary] at hresult + obtain rfl := hresult + exact List.prefix_rfl + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind] at hresult + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + exact (observations_prefix_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run cache) observations state fuel table step hstep).trans + (ih step.value.1 step.observations step.state step.remaining table + step.value.2 (by simpa only [observedMaterializedBoundary] using hrest)) + | inr input => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + exact (observations_prefix_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache) observations state fuel table step hstep).trans + (ih step.value.1 step.observations step.state step.remaining table + step.value.2 (by simpa only [observedMaterializedBoundary] using hrest)) + | inr message => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + exact (observations_prefix_of_mem_runObservedCleanFromTable + ((maskedSign parameter root ftsSecret message).run cache) observations state fuel + table step hstep).trans + (ih step.value.1 step.observations step.state step.remaining table + step.value.2 (by simpa only [observedMaterializedBoundary] using hrest)) + +set_option maxRecDepth 100000 in +theorem materializedDoomed_of_mem_observedMaterializedBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hdoomed : DoomedResolvedContext table (directDeferredContext state)) + (hresult : some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache)) : + result.table = table ∧ + DoomedResolvedContext table (directDeferredContext result.state) := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table cache with + | pure value => + simp [observedMaterializedBoundary] at hresult + obtain rfl := hresult + exact ⟨rfl, hdoomed⟩ + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind] at hresult + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + have hnext := materializedDoomed_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run cache) observations state fuel table step hdoomed hstep + simp only at hrest + exact ih step.value.1 step.observations step.state step.remaining table + step.value.2 hnext.2 (by + simpa only [observedMaterializedBoundary] using hrest) + | inr input => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + have hnext := materializedDoomed_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache) observations state fuel table step hdoomed hstep + simp only at hrest + exact ih step.value.1 step.observations step.state step.remaining table + step.value.2 hnext.2 (by + simpa only [observedMaterializedBoundary] using hrest) + | inr message => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + have hnext := materializedDoomed_of_mem_runObservedCleanFromTable + ((maskedSign parameter root ftsSecret message).run cache) observations state fuel + table step hdoomed hstep + simp only at hrest + exact ih step.value.1 step.observations step.state step.remaining table + step.value.2 hnext.2 (by + simpa only [observedMaterializedBoundary] using hrest) + +def SnapshotObservedPrefixStableRel + (table : OtsSecretIndex → HashOutput) + (source : PrivateWitnessSnapshotOutput) + (observed : Option + (ObservedCleanRunResult (α × SplitHashCache))) : Prop := + observed = none ∨ + (∃ result aligned, observed = some result ∧ + aligned <+: result.observations ∧ + SnapshotsObservedAt table source.2 aligned ∧ + (∀ witness, source.1 = some witness → + result.state.values (.position witness.position) = some witness.output)) ∨ + (∃ result, observed = some result ∧ + DoomedResolvedContext table (directDeferredContext result.state)) + +def observedResolvedResult + (observations : List CleanProbeObservation) + (result : ResolvedRunResult (α × SplitHashCache)) : + ObservedCleanRunResult (α × SplitHashCache) := + ⟨result.context.state, result.remaining, result.value, result.table, observations⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_pure_snapshot_observedMaterializedBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (source : PrivateWitnessSnapshotOutput) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (haligned : SnapshotsObservedAt table source.2 observations) + (hstable : (∀ witness, source.1 = some witness → + state.values (.position witness.position) = some witness.output) ∨ + DoomedResolvedContext table (directDeferredContext state)) : + RelTriple + (pure source : ProbComp PrivateWitnessSnapshotOutput) + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache) + (SnapshotObservedPrefixStableRel table) := by + have hbase := relTriple_true + (pure source : ProbComp PrivateWitnessSnapshotOutput) + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun output => output ∈ support (pure source : ProbComp PrivateWitnessSnapshotOutput)) + (fun output houtput => houtput) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro left right hrelation + have hleftEq : left = source := by simpa using hrelation.1.2 + subst left + cases right with + | none => exact Or.inl rfl + | some result => + rcases hstable with hstored | hdoomed + · right + left + refine ⟨result, observations, rfl, + observations_prefix_of_mem_observedMaterializedBoundary parameter root ftsSecret + computation observations state fuel table cache result hrelation.2, + haligned, ?_⟩ + intro witness hwitness + exact valuesLE_of_mem_observedMaterializedBoundary parameter root ftsSecret computation + observations state fuel table cache result hrelation.2 _ witness.output + (hstored witness hwitness) + · right + right + exact ⟨result, rfl, + (materializedDoomed_of_mem_observedMaterializedBoundary parameter root ftsSecret + computation observations state fuel table cache result hdoomed hrelation.2).2⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_any_observedMaterializedBoundary_of_doomed + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (left : ProbComp PrivateWitnessSnapshotOutput) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hdoomed : DoomedResolvedContext table (directDeferredContext state)) : + RelTriple left + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache) + (SnapshotObservedPrefixStableRel table) := by + have hbase := relTriple_true left + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + apply relTriple_post_mono hboth + intro source observed hrelation + cases observed with + | none => exact Or.inl rfl + | some result => + right + right + exact ⟨result, rfl, + (materializedDoomed_of_mem_observedMaterializedBoundary parameter root ftsSecret + computation observations state fuel table cache result hdoomed hrelation.2).2⟩ + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_finishWitnessObservedStep + (parameter : PublicParameter) (rootOf : α → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (next : α → OracleComp (OracleWorld + SigningSpec) β) + (leftObserve : DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (table : OtsSecretIndex → HashOutput) + (leftResult : DirectWitnessResult (α × SplitHashCache)) + (rightResult : Option (ObservedCleanRunResult (α × SplitHashCache))) + (hrelation : WitnessObservedStepRel table observations leftResult rightResult) + (haligned : SnapshotsObservedAt table snapshots observations) + (hrecursive : ∀ left right, + leftResult = .done left → + rightResult = some (observedResolvedResult observations right) → + OrdinaryMaterializedRunEq table left right → + RelTriple + (canonicalizeDirectWitnessSnapshotObserve table leftObserve left.context left.remaining + ((left.value.1, left.value.2)) snapshots) + (observedMaterializedBoundary parameter (rootOf right.value.1) ftsSecret + (next right.value.1) + observations right.context.state right.remaining table right.value.2) + (SnapshotObservedPrefixStableRel table)) : + RelTriple + (finishDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table leftObserve) snapshots leftResult) + (match rightResult with + | none => pure none + | some result => + observedMaterializedBoundary parameter (rootOf result.value.1) ftsSecret + (next result.value.1) + result.observations result.state result.remaining table result.value.2) + (SnapshotObservedPrefixStableRel table) := by + obtain ⟨detailed, hproject, hstable⟩ := hrelation + cases detailed with + | stopped reason => + have hright : rightResult = none := by + simpa [projectDirectDetailedObserved] using hproject.symm + subst rightResult + have hbase := relTriple_true + (finishDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table leftObserve) snapshots leftResult) + (pure none : ProbComp + (Option (ObservedCleanRunResult (β × SplitHashCache)))) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + apply relTriple_post_mono hsupported + intro source observed hrel + have : observed = none := by simpa using hrel.2 + subst observed + exact Or.inl rfl + | done right => + have hright : rightResult = some + (observedResolvedResult observations right) := by + simpa [projectDirectDetailedObserved, observedResolvedResult] using hproject.symm + subst rightResult + simp only [projectDirectDetailedObserved, finishDirectWitnessSnapshotObserve] + cases leftResult with + | stoppedFuel => + change RelTriple (pure (none, snapshots)) + (observedMaterializedBoundary parameter (rootOf right.value.1) ftsSecret + (next right.value.1) + observations right.context.state right.remaining table right.value.2) + (SnapshotObservedPrefixStableRel table) + exact relTriple_pure_snapshot_observedMaterializedBoundary parameter + (rootOf right.value.1) ftsSecret + (next right.value.1) (none, snapshots) observations right.context.state + right.remaining table right.value.2 + haligned + (Or.inr (by rw [← hstable.2]; exact hstable.1.2)) + | stoppedOrdinary => + change RelTriple (pure (none, snapshots)) + (observedMaterializedBoundary parameter (rootOf right.value.1) ftsSecret + (next right.value.1) + observations right.context.state right.remaining table right.value.2) + (SnapshotObservedPrefixStableRel table) + exact relTriple_pure_snapshot_observedMaterializedBoundary parameter + (rootOf right.value.1) ftsSecret + (next right.value.1) (none, snapshots) observations right.context.state + right.remaining table right.value.2 + haligned + (Or.inr (by rw [← hstable.2]; exact hstable.1.2)) + | stoppedPrivate witness => + change RelTriple (pure (some witness, snapshots)) + (observedMaterializedBoundary parameter (rootOf right.value.1) ftsSecret + (next right.value.1) + observations right.context.state right.remaining table right.value.2) + (SnapshotObservedPrefixStableRel table) + rcases hstable with hstored | hdoomed + · exact relTriple_pure_snapshot_observedMaterializedBoundary parameter + (rootOf right.value.1) ftsSecret + (next right.value.1) (some witness, snapshots) observations right.context.state + right.remaining table right.value.2 + haligned + (Or.inl (by + intro other hother + have : other = witness := Option.some.inj hother.symm + subst other + exact hstored.1)) + · exact relTriple_pure_snapshot_observedMaterializedBoundary parameter + (rootOf right.value.1) ftsSecret + (next right.value.1) (some witness, snapshots) observations right.context.state + right.remaining table right.value.2 + haligned + (Or.inr (by rw [← hdoomed.2]; exact hdoomed.1.2)) + | done left => + change RelTriple + (canonicalizeDirectWitnessSnapshotObserve table leftObserve left.context + left.remaining left.value snapshots) + (observedMaterializedBoundary parameter (rootOf right.value.1) ftsSecret + (next right.value.1) + observations right.context.state right.remaining table right.value.2) + (SnapshotObservedPrefixStableRel table) + rcases hstable with hclean | hdoomed + · exact hrecursive left right rfl hright hclean + · exact relTriple_any_observedMaterializedBoundary_of_doomed parameter + (rootOf right.value.1) ftsSecret + (next right.value.1) + (canonicalizeDirectWitnessSnapshotObserve table leftObserve left.context + left.remaining left.value snapshots) + observations right.context.state right.remaining table right.value.2 + (by rw [← hdoomed.2]; exact hdoomed.1.2) + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedWitness_observed_of_probeFree + (table : OtsSecretIndex → HashOutput) + (leftComputation rightComputation : + OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (hbase : RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table leftComputation) + (runDirectResolvedDetailedFromTable right rightFuel table rightComputation) + (DirectWitnessMaterializedStableRunEq table)) + (hprobeFree : rightComputation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table leftComputation) + (runObservedCleanFromTable observations right.state rightFuel table rightComputation) + (WitnessObservedStepRel table observations) := by + have hstrength : RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table leftComputation) + (runDirectResolvedDetailedFromTable right rightFuel table rightComputation) + (fun leftResult rightResult => + WitnessObservedStepRel table observations leftResult + (projectDirectDetailedObserved observations rightResult)) := by + apply relTriple_post_mono hbase + intro leftResult rightResult hrelation + exact ⟨rightResult, rfl, hrelation⟩ + have hmapped := relTriple_map + (R := WitnessObservedStepRel table observations) + (f := id) (g := projectDirectDetailedObserved observations) hstrength + rw [id_map] at hmapped + have hmap : projectDirectDetailedObserved observations <$> + runDirectResolvedDetailedFromTable right rightFuel table rightComputation = + runObservedCleanFromTable observations right.state rightFuel table rightComputation := by + rw [hrightMaterialized] + calc + _ = attachCleanProbeObservations observations <$> + (projectDirectDetailedClean <$> + runDirectResolvedDetailedFromTable (directDeferredContext right.state) rightFuel table + rightComputation) := by + rw [Functor.map_map] + apply map_congr + intro result + exact projectDirectDetailedObserved_eq_attach observations result + _ = attachCleanProbeObservations observations <$> + runCleanFromTable right.state rightFuel table rightComputation := by + rw [map_projectDirectDetailedClean_run_eq_clean] + _ = _ := map_attachCleanProbeObservations_runCleanFromTable_of_probeFree rightComputation + observations right.state rightFuel table hprobeFree + exact relTriple_of_evalDist_eq_right (congrArg evalDist hmap) hmapped + +theorem probingHashQueryAfterPlan_isProbeBound_one + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (cache : SplitHashCache) : + ((probingHashQueryAfterPlan parameter input plan).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 := by + unfold probingHashQueryAfterPlan executePlannedHashQuery + rw [StateT.run_bind] + apply OracleComp.isQueryBoundP_bind (n := 1) (m := 0) + · exact executeCandidate?_isProbeBound_one plan.candidate? cache + · intro result _hresult + cases plan.action with + | ordinary => exact splitHashQuery_probeFree (.ordinary input) result.2 + | resolve coordinate => exact resolveKnownInput_probeFree parameter coordinate input result.2 + +theorem probingHashQueryAfterRootAwarePublicPlan_isProbeBound_one + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (cache : SplitHashCache) : + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 := by + unfold probingHashQueryAfterRootAwarePublicPlan + rw [StateT.run_bind] + apply OracleComp.isQueryBoundP_bind (n := 1) (m := 0) + · exact executeCandidate?_isProbeBound_one _ cache + · intro result _hresult + exact probingHashQueryPublicAction_probeFree parameter input publicState plan.action result.2 + +theorem probingHashQueryAfterRootAwarePublicPlan_eq_of_values_eq + (parameter : PublicParameter) (input : HashInput) + {left right : LazyRevealProbe.State Coordinate} + (hvalues : left.values = right.values) (plan : PlannedHashQuery) : + probingHashQueryAfterRootAwarePublicPlan parameter input left plan = + probingHashQueryAfterRootAwarePublicPlan parameter input right plan := by + unfold probingHashQueryAfterRootAwarePublicPlan probingHashQueryPublicAction + apply bind_congr + intro _ + cases plan.action with + | ordinary => rfl + | resolve coordinate => + exact resolvePublicKnownInput_eq_of_values_eq parameter hvalues coordinate input + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_directSnapshotBoundary_observedMaterialized + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) RetainedRestResult) + (snapshots : List PlannedProbeSnapshot) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) (q bound : Nat) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) computation).IsQueryBoundP + (fun query => query matches Sum.inr _) bound) + (hcontext : FinalizationContextLE table left right) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hcanonical : CanonicalMaterializedValues table left) + (haligned : SnapshotsObservedAt table snapshots observations) + (hleftLower : bound ≤ leftFuel) (hleftUpper : leftFuel ≤ q) + (hrightLower : q + bound ≤ rightFuel) : + RelTriple + (directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root ftsSecret + computation (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table root) + snapshots left leftFuel table leftCache) + (observedMaterializedBoundary parameter root ftsSecret computation observations right.state + rightFuel table rightCache) + (SnapshotObservedPrefixStableRel table) := by + induction computation using OracleComp.inductionOn generalizing + snapshots observations left right leftFuel rightFuel leftCache rightCache bound with + | pure value => + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_pure, observedMaterializedBoundary, OracleComp.construct_pure] + have hnotPrivate : ¬PrivateStructuralHit left := + not_privateStructuralHit_of_deferredCompletable hcontext.leftCompletable + simp [retainedResolvedFinalizationPrivateWitnessSnapshotObserve, hnotPrivate] + right + left + exact ⟨_, observations, rfl, List.prefix_rfl, haligned, by simp⟩ + | query_bind query next ih => + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_query_bind, observedMaterializedBoundary, + OracleComp.construct_query_bind] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + simp only + let leftObserve : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput := + fun nextContext remaining value laterSnapshots => + directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root + ftsSecret (next value.1) + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table root) + laterSnapshots nextContext remaining table value.2 + have hbase := (witnessMaterializedStableCouples_splitUniformImpl table n) + left right leftFuel rightFuel leftCache rightCache hcontext (by omega) hcache + hrevealed hvalues hpublished hrightMaterialized + have hlocal := relTriple_runDirectResolvedWitness_observed_of_probeFree table + ((splitUniformImpl n).run leftCache) ((splitUniformImpl n).run rightCache) + observations left right leftFuel rightFuel + hbase (splitUniformImpl_probeFree n rightCache) hrightMaterialized + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hlocal + (fun result => result ∈ support + (runDirectResolvedWitnessFromTable left leftFuel table + ((splitUniformImpl n).run leftCache))) + (fun result hresult => hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support + hleftSupported + unfold runDirectWitnessSnapshotObserve + apply relTriple_bind hbothSupported + intro leftResult rightResult hstep + rcases hstep with ⟨⟨hstep, hleftSupport⟩, hrightSupport⟩ + change RelTriple + (finishDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table leftObserve) snapshots + leftResult) + (match rightResult with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state result.remaining + table result.value.2) + (SnapshotObservedPrefixStableRel table) + have hfinish := relTriple_finishWitnessObservedStep (α := Fin (n + 1)) + (β := RetainedRestResult) parameter (fun _ => root) ftsSecret next leftObserve + snapshots observations table leftResult rightResult hstep haligned (by + intro nextLeft nextRight hleftEq hrightEq hclean + rw [hleftEq] at hleftSupport + rw [hrightEq] at hrightSupport + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hleftCompletable : DeferredCompletable table canonical := + hcanonicalRun.context_le.leftCompletable + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hleftFuelPreserved : leftFuel ≤ nextLeft.remaining := by + have := fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table nextLeft 0 + (splitUniformImpl_probeFree n leftCache) hleftSupport + omega + have hrightFuelPreserved : rightFuel ≤ nextRight.remaining := by + have := fuel_le_remaining_add_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run rightCache) observations right.state rightFuel table + (observedResolvedResult observations nextRight) 0 + (splitUniformImpl_probeFree n rightCache) hrightSupport + simpa [observedResolvedResult] using this + have hleftRemainingUpper : nextLeft.remaining ≤ leftFuel := + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table nextLeft + (by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩) + unfold canonicalizeDirectWitnessSnapshotObserve + classifyDirectWitnessSnapshotObserve + simp only [canonical, hnotPrivate, ↓reduceDIte, hclean.left_published, + ↓reduceIte, hleftCompletable] + rw [← hclean.value_eq] + simpa [leftObserve] using + (ih nextLeft.value.1 snapshots observations canonical nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 bound + (hbound.2 nextLeft.value.1) hcanonicalRun.context_le hcanonicalRun.cache_eq + hcanonicalRun.revealed_eq hcanonicalRun.values_le + hcanonicalRun.left_published hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table nextLeft.context + hclean.context_le.view.leftConsistent) + haligned (by omega) (by omega) (by omega))) + convert hfinish using 1 + cases rightResult <;> rfl + | inr input => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + simp only + have hrightValues : + (materializedCanonicalContext table right.state).state.values = + left.state.values := by + unfold materializedCanonicalContext + rw [← hrightMaterialized] + exact canonicalized_right_values_eq_of_finalizationContextLE hcontext + hrevealed hcanonical + have hplanEq : + purePlanProbingHashQuery parameter input + (materializedCanonicalContext table right.state).state = + purePlanProbingHashQuery parameter input left.state := + purePlanProbingHashQuery_eq_of_values_eq hrightValues parameter input + rw [hplanEq] + rw [← rootAwareCandidateForPlan?_purePlan parameter input left.state] + let plan := purePlanProbingHashQuery parameter input left.state + have hpublicExecutor : + probingHashQueryAfterRootAwarePublicPlan parameter input + (materializedCanonicalContext table right.state).state plan = + probingHashQueryAfterRootAwarePublicPlan parameter input left.state plan := + probingHashQueryAfterRootAwarePublicPlan_eq_of_values_eq parameter input + hrightValues plan + rw [hpublicExecutor] + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextSnapshots := appendPlannedSnapshot snapshots candidate? left + let nextObservations := observationsAfterCandidate observations right.state candidate? + have hcontextDirect : + FinalizationContextLE table left (directDeferredContext right.state) := by + rwa [← hrightMaterialized] + have hnextAligned : SnapshotsObservedAt table nextSnapshots nextObservations := by + exact haligned.appendCandidate candidate? hcontextDirect hrevealed hpublished + hcanonical + have houter : IsOuterHash (.inl (.inr input)) := by simp [IsOuterHash] + have hboundPositive : 0 < bound := by + rcases hbound.1 with hnot | hpositive + · exact (hnot (by simp)).elim + · exact hpositive + have hleftPositive : 0 < leftFuel := by omega + have hstrictFuel : leftFuel < rightFuel := by omega + have hlocal := + relTriple_runDirectResolvedWitness_afterPlan_observedMaterialized table parameter + input left.state plan observations left right leftFuel rightFuel leftCache + rightCache rfl hleftPositive hstrictFuel hcontext hcache hrevealed hvalues + hpublished hrightMaterialized + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hlocal + (fun result => result ∈ support + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache))) + (fun result hresult => hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support + hleftSupported + let leftObserve : DeferredContext → Nat → + (HashOutput × SplitHashCache) → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput := + fun nextContext remaining value laterSnapshots => + directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root + ftsSecret (next value.1) + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table root) + laterSnapshots nextContext remaining table value.2 + unfold runDirectWitnessSnapshotObserve + apply relTriple_bind hbothSupported + intro leftResult rightResult hstep + rcases hstep with ⟨⟨hstep, hleftSupport⟩, hrightSupport⟩ + have hfinish := relTriple_finishWitnessObservedStep (α := HashOutput) + (β := RetainedRestResult) parameter (fun _ => root) ftsSecret next leftObserve + nextSnapshots nextObservations table leftResult rightResult hstep hnextAligned (by + intro nextLeft nextRight hleftEq hrightEq hclean + rw [hleftEq] at hleftSupport + rw [hrightEq] at hrightSupport + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hleftCompletable : DeferredCompletable table canonical := + hcanonicalRun.context_le.leftCompletable + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hleftFuelSpent : leftFuel ≤ nextLeft.remaining + 1 := + fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterPlan parameter input plan).run leftCache) left leftFuel + table nextLeft 1 + (probingHashQueryAfterPlan_isProbeBound_one parameter input plan leftCache) + hleftSupport + have hrightFuelSpent : rightFuel ≤ nextRight.remaining + 1 := by + have := fuel_le_remaining_add_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input left.state plan).run + rightCache) observations right.state rightFuel table + (observedResolvedResult nextObservations nextRight) 1 + (probingHashQueryAfterRootAwarePublicPlan_isProbeBound_one parameter input + left.state plan rightCache) hrightSupport + simpa [observedResolvedResult] using this + have hleftRemainingUpper : nextLeft.remaining ≤ leftFuel := + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((probingHashQueryAfterPlan parameter input plan).run leftCache) left leftFuel + table nextLeft (by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterPlan parameter input plan).run leftCache) left + leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩) + unfold canonicalizeDirectWitnessSnapshotObserve + classifyDirectWitnessSnapshotObserve + simp only [canonical, hnotPrivate, ↓reduceDIte, hclean.left_published, + ↓reduceIte, hleftCompletable] + rw [← hclean.value_eq] + simpa [leftObserve, IsOuterHash] using + (ih nextLeft.value.1 nextSnapshots nextObservations canonical + nextRight.context nextLeft.remaining nextRight.remaining nextLeft.value.2 + nextRight.value.2 (bound - 1) + (by simpa [IsOuterHash] using hbound.2 nextLeft.value.1) + hcanonicalRun.context_le hcanonicalRun.cache_eq hcanonicalRun.revealed_eq + hcanonicalRun.values_le hcanonicalRun.left_published + hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table nextLeft.context + hclean.context_le.view.leftConsistent) + hnextAligned (by omega) (by omega) (by omega))) + convert hfinish using 1 + · rfl + · cases rightResult <;> rfl + | inr message => + rw [simulateQ_expandedAdversaryImpl_query_bind_inr] at hbound + simp only + let leftObserve : DeferredContext → Nat → + (Option Signature × SplitHashCache) → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput := + fun nextContext remaining value laterSnapshots => + directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root + ftsSecret (next value.1) + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table root) + laterSnapshots nextContext remaining table value.2 + have hbase := (witnessMaterializedStableCouples_maskedSign table parameter root + ftsSecret message) left right leftFuel rightFuel leftCache rightCache hcontext + (by omega) hcache hrevealed hvalues hpublished hrightMaterialized + have hlocal := relTriple_runDirectResolvedWitness_observed_of_probeFree table + ((maskedSign parameter root ftsSecret message).run leftCache) + ((maskedSign parameter root ftsSecret message).run rightCache) + observations left right leftFuel rightFuel hbase + (maskedSign_probeFree parameter root ftsSecret message rightCache) hrightMaterialized + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hlocal + (fun result => result ∈ support + (runDirectResolvedWitnessFromTable left leftFuel table + ((maskedSign parameter root ftsSecret message).run leftCache))) + (fun result hresult => hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support + hleftSupported + unfold runDirectWitnessSnapshotObserve + apply relTriple_bind hbothSupported + intro leftResult rightResult hstep + rcases hstep with ⟨⟨hstep, hleftSupport⟩, hrightSupport⟩ + have hfinish := relTriple_finishWitnessObservedStep (α := Option Signature) + (β := RetainedRestResult) parameter (fun _ => root) ftsSecret next leftObserve + snapshots observations table leftResult rightResult hstep haligned (by + intro nextLeft nextRight hleftEq hrightEq hclean + rw [hleftEq] at hleftSupport + rw [hrightEq] at hrightSupport + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hleftCompletable : DeferredCompletable table canonical := + hcanonicalRun.context_le.leftCompletable + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hleftFuelPreserved : leftFuel ≤ nextLeft.remaining := by + have := fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) left leftFuel table + nextLeft 0 (maskedSign_probeFree parameter root ftsSecret message leftCache) + hleftSupport + omega + have hrightFuelPreserved : rightFuel ≤ nextRight.remaining := by + have := fuel_le_remaining_add_of_mem_runObservedCleanFromTable + ((maskedSign parameter root ftsSecret message).run rightCache) observations + right.state rightFuel table (observedResolvedResult observations nextRight) 0 + (maskedSign_probeFree parameter root ftsSecret message rightCache) hrightSupport + simpa [observedResolvedResult] using this + have hleftRemainingUpper : nextLeft.remaining ≤ leftFuel := + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) left leftFuel table + nextLeft (by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) left leftFuel + table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩) + unfold canonicalizeDirectWitnessSnapshotObserve + classifyDirectWitnessSnapshotObserve + simp only [canonical, hnotPrivate, ↓reduceDIte, hclean.left_published, + ↓reduceIte, hleftCompletable] + rw [← hclean.value_eq] + have hdetailed : DirectDetailedResult.done nextLeft ∈ support + (runDirectResolvedDetailedFromTable left leftFuel table + ((maskedSign parameter root ftsSecret message).run leftCache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩ + have hdirect : some nextLeft ∈ support + (runDirectResolvedFromTable left leftFuel table + ((maskedSign parameter root ftsSecret message).run leftCache)) := + mem_support_runDirectResolvedFromTable_of_done_detailed + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table nextLeft hdetailed + have hraw := raw_done_of_mem_runDirectResolvedFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table nextLeft hdirect + have houtput : nextLeft.value.1 ∈ support + (scheme.sign + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey) message) := by + exact maskedSign_done_output_mem_support parameter root table ftsSecret + message left.state nextLeft.context.state leftCache nextLeft.value.2 + leftFuel nextLeft.remaining nextLeft.value.1 + hclean.context_le.view.leftStarts (by + simpa only [SigningSpec, maskedExpandedAdversaryImpl, + maskedSigningImpl] using hraw) + have htailBound := isQueryBoundP_of_bind hbound nextLeft.value.1 houtput + simpa [leftObserve, IsOuterHash] using + (ih nextLeft.value.1 snapshots observations canonical nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 bound + (htailBound.mono (by omega)) + hcanonicalRun.context_le hcanonicalRun.cache_eq hcanonicalRun.revealed_eq + hcanonicalRun.values_le hcanonicalRun.left_published + hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table nextLeft.context + hclean.context_le.view.leftConsistent) + haligned (by omega) (by omega) (by omega))) + convert hfinish using 1 + · rfl + · cases rightResult <;> rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalOperational.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalOperational.lean new file mode 100644 index 00000000..10ae20d2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalOperational.lean @@ -0,0 +1,2662 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalCoupling + +/-! +# Operational global root coupling + +The adaptive induction in this file has a deliberately small successful postcondition. Source +chronology and comparison observation tracking are unary support invariants, so the two-run kernel +only carries snapshot alignment and the final value at a retained private witness. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option maxRecDepth 100000 in +theorem experiment_fuel_eq_of_isQueryBoundP + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (leftFuel rightFuel bound : Nat) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hleftFuel : bound ≤ leftFuel) (hrightFuel : bound ≤ rightFuel) : + LazyRevealProbe.experiment state leftFuel computation = + LazyRevealProbe.experiment state rightFuel computation := by + induction computation using OracleComp.inductionOn generalizing + state leftFuel rightFuel bound with + | pure value => + rfl + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases query with + | uniform n => + rw [LazyRevealProbe.experiment_uniform_query_bind, + LazyRevealProbe.experiment_uniform_query_bind] + apply bind_congr + intro output + exact ih output state leftFuel rightFuel bound + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + hleftFuel hrightFuel + | hashOutput => + rw [LazyRevealProbe.experiment_hashOutput_query_bind, + LazyRevealProbe.experiment_hashOutput_query_bind] + apply bind_congr + intro output + exact ih output state leftFuel rightFuel bound + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + hleftFuel hrightFuel + | ensure coordinate => + rw [LazyRevealProbe.experiment_ensure_query_bind, + LazyRevealProbe.experiment_ensure_query_bind] + exact ih () (state.ensure coordinate) leftFuel rightFuel bound + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) hleftFuel hrightFuel + | probe coordinate candidate => + have hpositive : 0 < bound := by + simpa [LazyRevealProbe.IsProbe] using hbound.1 + cases leftFuel with + | zero => omega + | succ leftRemaining => + cases rightFuel with + | zero => omega + | succ rightRemaining => + rw [LazyRevealProbe.experiment_probe_query_bind, + LazyRevealProbe.experiment_probe_query_bind] + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () state leftRemaining rightRemaining (bound - 1) + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) (by omega) (by omega) + · simp only [hrevealed, ↓reduceIte] + exact ih () (state.addPending coordinate candidate) + leftRemaining rightRemaining (bound - 1) + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) (by omega) (by omega) + | peek coordinate => + rw [LazyRevealProbe.experiment_peek_query_bind, + LazyRevealProbe.experiment_peek_query_bind] + exact ih (state.values coordinate) state leftFuel rightFuel bound + (by simpa [LazyRevealProbe.IsProbe] using + hbound.2 (state.values coordinate)) hleftFuel hrightFuel + | publish coordinate => + rw [LazyRevealProbe.experiment_publish_query_bind, + LazyRevealProbe.experiment_publish_query_bind] + exact ih () (state.publish coordinate) leftFuel rightFuel bound + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) hleftFuel hrightFuel + | reveal coordinate => + rw [LazyRevealProbe.experiment_reveal_query_bind, + LazyRevealProbe.experiment_reveal_query_bind] + cases hvalue : state.values coordinate with + | some output => + exact ih output state leftFuel rightFuel bound + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + hleftFuel hrightFuel + | none => + apply bind_congr + intro output + by_cases hhit : state.hitAt coordinate output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + exact ih output (state.materialize coordinate output) + leftFuel rightFuel bound + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + hleftFuel hrightFuel + +set_option maxRecDepth 100000 in +theorem probEvent_sampledRunThenFinalizeClean_empty_none_le_of_queryBound + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (fuel bound : Nat) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hfuel : bound ≤ fuel) : + Pr[= none | sampledRunThenFinalizeClean + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel computation] ≤ + (bound : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + have hboundFuel := hbound.mono hfuel + calc + _ = Pr[= none | detailedExperimentCleanWithCompletionTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel computation] := + OracleComp.probOutput_congr rfl + (by + unfold sampledRunThenFinalizeClean + exact evalDist_runThenFinalizeCleanFromTable_eq_detailed computation + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel) + _ = Pr[= true | LazyRevealProbe.experiment + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel computation] := + probEvent_detailedExperimentClean_none_eq_hit computation + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel hboundFuel + _ = Pr[= true | LazyRevealProbe.experiment + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + bound computation] := by + apply OracleComp.probOutput_congr rfl + exact congrArg evalDist + (experiment_fuel_eq_of_isQueryBoundP computation LazyRevealProbe.State.empty + fuel bound bound hbound hfuel (by omega)) + _ ≤ _ := by + rw [← probEvent_eq_eq_probOutput] + exact LazyRevealProbe.experiment_empty_probability_le bound computation + +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledObservedRootAwareClean_none_le_of_fuel + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) + (hbound : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash q) + (hfuel : q ≤ fuel) : + Pr[= none | + sampledObservedRootAwareClean adversary parameter ftsSecret fuel] ≤ + (q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ = Pr[= none | projectObservedCleanRun <$> + sampledObservedRootAwareClean adversary parameter ftsSecret fuel] := by + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput, probEvent_map] + apply OracleComp.probEvent_congr' + · intro result _hresult + cases result <;> simp [projectObservedCleanRun] + · rfl + _ = Pr[= none | sampledRunThenFinalizeClean + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel + (rootAwareCleanRetainedRun adversary parameter ftsSecret)] := + OracleComp.probOutput_congr rfl + (congrArg evalDist + (map_projectObservedCleanRun_sampledObservedRootAwareClean adversary parameter + ftsSecret fuel)) + _ ≤ _ := probEvent_sampledRunThenFinalizeClean_empty_none_le_of_queryBound + (rootAwareCleanRetainedRun adversary parameter ftsSecret) fuel q + (rootAwareCleanRetainedRun_isProbeBound adversary parameter ftsSecret q hbound) hfuel + +def SnapshotObservedValueRel + (table : OtsSecretIndex → HashOutput) + (source : PrivateWitnessSnapshotOutput) + (observed : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))) : Prop := + observed = none ∨ + ∃ result, observed = some result ∧ + SnapshotsObservedAt table source.2 result.observations ∧ + ∀ witness, source.1 = some witness → + result.state.values (.position witness.position) = some witness.output + +def SnapshotObservedPrefixValueRel + (table : OtsSecretIndex → HashOutput) + (source : PrivateWitnessSnapshotOutput) + (observed : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))) : Prop := + observed = none ∨ + ∃ result aligned, observed = some result ∧ + aligned <+: result.observations ∧ + SnapshotsObservedAt table source.2 aligned ∧ + ∀ witness, source.1 = some witness → + result.state.values (.position witness.position) = some witness.output + +theorem SnapshotObservedValueRel.to_rootRel + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} + {observed : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))} + (hrelation : SnapshotObservedValueRel table source observed) + (hsource : SourceSnapshotStopInvariant source) + (htracked : ∀ result, observed = some result → + CleanProbeObservationsTrackedBy result.observations result.state) : + SnapshotObservedRootRel source observed := by + rcases hrelation with hfailed | ⟨result, hresult, haligned, hstored⟩ + · exact Or.inl hfailed + · right + intro hfirst + subst observed + exact witnessFirstUsesSomeDelayedLayerRootSnapshot_of_aligned_tracked_sourceInvariant + hsource haligned hfirst (htracked result rfl) (by + intro witness hwitness + exact hstored witness (by simpa [erasePrivateWitnessSnapshotOutput] using hwitness)) + +theorem relTriple_snapshotObservedRoot_of_valueRel + {table : OtsSecretIndex → HashOutput} + {source : ProbComp PrivateWitnessSnapshotOutput} + {observed : ProbComp (Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)))} + (hrelation : RelTriple source observed (SnapshotObservedValueRel table)) + (hsource : ∀ output ∈ support source, SourceSnapshotStopInvariant output) + (htracked : ∀ output ∈ support observed, ∀ result, output = some result → + CleanProbeObservationsTrackedBy result.observations result.state) : + RelTriple source observed SnapshotObservedRootRel := by + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hrelation + SourceSnapshotStopInvariant hsource + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro left right hfacts + exact hfacts.1.1.to_rootRel hfacts.1.2 fun result hresult => + htracked right hfacts.2 result hresult + +theorem SnapshotObservedPrefixValueRel.to_rootRel + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} + {observed : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))} + (hrelation : SnapshotObservedPrefixValueRel table source observed) + (hsource : SourceSnapshotStopInvariant source) + (htracked : ∀ result, observed = some result → + CleanProbeObservationsTrackedBy result.observations result.state) : + SnapshotObservedRootRel source observed := by + rcases hrelation with hfailed | ⟨result, aligned, hresult, hprefix, haligned, hstored⟩ + · exact Or.inl hfailed + · right + intro hfirst + subst observed + let trimmed : ObservedCleanRunResult (RetainedGameResult × SplitHashCache) := + { result with observations := aligned } + have htrimmedTracked : + CleanProbeObservationsTrackedBy trimmed.observations trimmed.state := by + intro observation hobservation + exact htracked result rfl observation (hprefix.subset hobservation) + exact witnessFirstUsesSomeDelayedLayerRootSnapshot_of_aligned_tracked_sourceInvariant + hsource haligned hfirst htrimmedTracked (by + intro witness hwitness + exact hstored witness (by simpa [erasePrivateWitnessSnapshotOutput] using hwitness)) + +theorem relTriple_snapshotObservedRoot_of_prefixValueRel + {table : OtsSecretIndex → HashOutput} + {source : ProbComp PrivateWitnessSnapshotOutput} + {observed : ProbComp (Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)))} + (hrelation : RelTriple source observed (SnapshotObservedPrefixValueRel table)) + (hsource : ∀ output ∈ support source, SourceSnapshotStopInvariant output) + (htracked : ∀ output ∈ support observed, ∀ result, output = some result → + CleanProbeObservationsTrackedBy result.observations result.state) : + RelTriple source observed SnapshotObservedRootRel := by + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hrelation + SourceSnapshotStopInvariant hsource + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro left right hfacts + exact hfacts.1.1.to_rootRel hfacts.1.2 fun result hresult => + htracked right hfacts.2 result hresult + +def DirectWitnessMaterializedStableRunEq + (table : OtsSecretIndex → HashOutput) : + DirectWitnessResult (α × SplitHashCache) → + DirectDetailedResult (α × SplitHashCache) → Prop + | .stoppedPrivate witness, .done right => + (right.context.state.values (.position witness.position) = some witness.output ∧ + right.context = directDeferredContext right.context.state) ∨ + OrdinaryMaterializedDoomedRun table right + | .stoppedPrivate _, _ => True + | .stoppedOrdinary, .stopped .privateStructuralHit => False + | .stoppedOrdinary, .stopped _ => True + | .stoppedOrdinary, .done right => OrdinaryMaterializedDoomedRun table right + | .stoppedFuel, .stopped .ordinaryHit => True + | .stoppedFuel, .stopped .fuelExhausted => True + | .stoppedFuel, .done right => OrdinaryMaterializedDoomedRun table right + | .stoppedFuel, _ => False + | .done _, .stopped .privateStructuralHit => False + | .done _, .stopped _ => True + | .done left, .done right => + OrdinaryMaterializedRunEq table left right ∨ + OrdinaryMaterializedDoomedRun table right + +theorem DirectWitnessMaterializedStableRunEq.erase + {table : OtsSecretIndex → HashOutput} + {left : DirectWitnessResult (α × SplitHashCache)} + {right : DirectDetailedResult (α × SplitHashCache)} + (hrelation : DirectWitnessMaterializedStableRunEq table left right) : + DirectDetailedOrdinaryStableRunEq table left.erase right := by + cases left with + | stoppedFuel => + cases right with + | stopped reason => cases reason <;> exact hrelation + | done result => exact hrelation + | stoppedOrdinary => + cases right with + | stopped reason => cases reason <;> exact hrelation + | done result => exact hrelation + | stoppedPrivate witness => trivial + | done left => + cases right with + | stopped reason => cases reason <;> exact hrelation + | done right => exact hrelation + +def WitnessMaterializedStableCouplesBetween + (table : OtsSecretIndex → HashOutput) + (left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftContext rightContext leftFuel rightFuel leftCache rightCache, + FinalizationContextLE table leftContext rightContext → + leftFuel ≤ rightFuel → + ordinaryQueryCache leftCache = ordinaryQueryCache rightCache → + leftContext.state.revealed = rightContext.state.revealed → + LazyRevealProbe.ValuesLE leftContext.state rightContext.state → + PublishedValues leftContext.state → + rightContext = directDeferredContext rightContext.state → + RelTriple + (runDirectResolvedWitnessFromTable leftContext leftFuel table (left.run leftCache)) + (runDirectResolvedDetailedFromTable rightContext rightFuel table (right.run rightCache)) + (DirectWitnessMaterializedStableRunEq table) + +abbrev WitnessMaterializedStableCouples + (table : OtsSecretIndex → HashOutput) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + WitnessMaterializedStableCouplesBetween table computation computation + +theorem WitnessMaterializedStableCouplesBetween.toDetailed + {table : OtsSecretIndex → HashOutput} + {left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + (hcouples : WitnessMaterializedStableCouplesBetween table left right) : + OrdinaryMaterializedStableCouplesBetween table left right := by + intro leftContext rightContext leftFuel rightFuel leftCache rightCache hcontext hfuel + hcache hrevealed hvalues hpublished hrightMaterialized + have hrun := hcouples leftContext rightContext leftFuel rightFuel leftCache rightCache hcontext + hfuel hcache hrevealed hvalues hpublished hrightMaterialized + rw [← map_erase_runDirectResolvedWitnessFromTable + (left.run leftCache) leftContext leftFuel table] + have hbind := relTriple_bind hrun fun leftResult rightResult hrelation => + relTriple_pure_pure (b := rightResult) hrelation.erase + simpa using hbind + +theorem witnessMaterializedStableCouples_pure + (table : OtsSecretIndex → HashOutput) (value : α) : + WitnessMaterializedStableCouples table + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + rw [StateT.run_pure, StateT.run_pure, + runDirectResolvedDetailedFromTable_pure] + simp only [runDirectResolvedWitnessFromTable] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := hcache + revealed_eq := hrevealed + values_le := hvalues + left_published := hpublished + right_materialized := hrightMaterialized } + +set_option maxRecDepth 100000 in +theorem valuesLE_of_done_runDirectResolvedDetailedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation)) : + LazyRevealProbe.ValuesLE context.state result.context.state := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runDirectResolvedDetailedFromTable] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact LazyRevealProbe.ValuesLE.refl context.state + | query_bind query next ih => + cases query with + | uniform n => + rw [runDirectResolvedDetailedFromTable_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel htail + | hashOutput => + rw [runDirectResolvedDetailedFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel htail + | ensure coordinate => + rw [runDirectResolvedDetailedFromTable_ensure_query_bind] at hresult + exact (LazyRevealProbe.valuesLE_ensure context.state coordinate).trans + (ih () { context with state := context.state.ensure coordinate } fuel hresult) + | probe coordinate candidate => + rw [runDirectResolvedDetailedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] at hresult + exact ih () context remaining hresult + · simp only [hrevealed, ↓reduceIte] at hresult + exact (LazyRevealProbe.valuesLE_addPending context.state coordinate candidate).trans + (ih () { context with state := context.state.addPending coordinate candidate } + remaining hresult) + | peek coordinate => + rw [runDirectResolvedDetailedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hresult + | publish coordinate => + rw [runDirectResolvedDetailedFromTable_publish_query_bind] at hresult + exact (LazyRevealProbe.valuesLE_publish context.state coordinate).trans + (ih () { context with state := context.state.publish coordinate } fuel hresult) + | reveal coordinate => + rw [runDirectResolvedDetailedFromTable_reveal_query_bind] at hresult + cases hvalue : context.state.values coordinate with + | some output => + simp only [hvalue] at hresult + exact ih output context fuel hresult + | none => + simp only [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + exact (LazyRevealProbe.valuesLE_materialize_of_none context.state + (.chainStart lay tree leafIdx chainIdx) output hvalue).trans + (ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel hresult) + | position position => + cases hprivate : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hprivate, hhit] at hresult + · simp only [hprivate, hhit, ↓reduceIte] at hresult + exact (LazyRevealProbe.valuesLE_materialize_of_none context.state + (.position position) output hvalue).trans + (ih output + { state := context.state.materialize (.position position) output + values := context.values } + fuel hresult) + | none => + simp only [hprivate, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at htail + · simp only [hhit, ↓reduceIte] at htail + exact (LazyRevealProbe.valuesLE_materialize_of_none context.state + (.position position) output hvalue).trans + (ih output + { state := context.state.materialize (.position position) output + values := context.values.install position output } + fuel htail) + +set_option maxRecDepth 100000 in +theorem relTriple_pure_stoppedPrivate_run_of_materialized_value + (relationTable runnerTable : OtsSecretIndex → HashOutput) + (witness : PrivateHitWitness) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) + (α × SplitHashCache)) + (hvalue : state.values (.position witness.position) = some witness.output) : + RelTriple + (pure (.stoppedPrivate witness) : + ProbComp (DirectWitnessResult (α × SplitHashCache))) + (runDirectResolvedDetailedFromTable (directDeferredContext state) fuel runnerTable computation) + (DirectWitnessMaterializedStableRunEq relationTable) := by + have hbase := relTriple_true + (pure (.stoppedPrivate witness) : + ProbComp (DirectWitnessResult (α × SplitHashCache))) + (runDirectResolvedDetailedFromTable (directDeferredContext state) fuel runnerTable computation) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (pure (.stoppedPrivate witness) : + ProbComp (DirectWitnessResult (α × SplitHashCache)))) + (fun result hresult => hresult) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro leftResult rightResult hrelation + have hleft : leftResult = .stoppedPrivate witness := by + simpa using hrelation.1.2 + subst leftResult + have hmaterialized := directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + computation state fuel runnerTable rightResult hrelation.2 + cases rightResult with + | stopped reason => + cases reason with + | privateStructuralHit => exact False.elim hmaterialized + | ordinaryHit => trivial + | fuelExhausted => trivial + | done result => + left + exact ⟨valuesLE_of_done_runDirectResolvedDetailedFromTable computation + (directDeferredContext state) fuel runnerTable result hrelation.2 + (.position witness.position) witness.output hvalue, + hmaterialized⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_any_run_of_materializedDoomed_witness + (table : OtsSecretIndex → HashOutput) + (leftRun : ProbComp (DirectWitnessResult (α × SplitHashCache))) + (rightComputation : OracleComp (LazyRevealProbe.World Coordinate) + (α × SplitHashCache)) + (right : DeferredContext) (rightFuel : Nat) + (hrightDoomed : DoomedResolvedContext table right) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple leftRun + (runDirectResolvedDetailedFromTable right rightFuel table rightComputation) + (DirectWitnessMaterializedStableRunEq table) := by + have hbase := relTriple_true leftRun + (runDirectResolvedDetailedFromTable right rightFuel table rightComputation) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + apply relTriple_post_mono hboth + intro leftResult rightResult hrelation + have hrightShape : DirectDetailedMaterialized rightResult := by + have hrightSupport := hrelation.2 + rw [hrightMaterialized] at hrightSupport + exact directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + rightComputation right.state rightFuel table rightResult hrightSupport + cases rightResult with + | stopped reason => + cases reason with + | privateStructuralHit => exact False.elim hrightShape + | ordinaryHit => + cases leftResult <;> trivial + | fuelExhausted => + cases leftResult <;> trivial + | done rightResult => + have hdoomed := finalizationDoomedRun_of_mem_runDirectResolvedDetailedFromTable table + rightComputation right rightFuel rightResult hrightDoomed hrelation.2 + have hrightDoomedRun : OrdinaryMaterializedDoomedRun table rightResult := + ⟨hdoomed, hrightShape⟩ + cases leftResult with + | stoppedFuel => exact hrightDoomedRun + | stoppedOrdinary => exact hrightDoomedRun + | stoppedPrivate witness => exact Or.inr hrightDoomedRun + | done leftResult => exact Or.inr hrightDoomedRun + +theorem relTriple_any_pure_nonprivateStop_witness + (table : OtsSecretIndex → HashOutput) + (leftRun : ProbComp (DirectWitnessResult (α × SplitHashCache))) + (reason : DirectStopReason) (hreason : reason ≠ .privateStructuralHit) : + RelTriple leftRun + (pure (.stopped reason) : + ProbComp (DirectDetailedResult (α × SplitHashCache))) + (DirectWitnessMaterializedStableRunEq table) := by + have hbase := relTriple_true leftRun + (pure (.stopped reason) : + ProbComp (DirectDetailedResult (α × SplitHashCache))) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + apply relTriple_post_mono hsupported + intro leftResult rightResult hrelation + have hright : rightResult = .stopped reason := by + simpa using hrelation.2 + subst rightResult + cases reason with + | privateStructuralHit => contradiction + | ordinaryHit => cases leftResult <;> trivial + | fuelExhausted => cases leftResult <;> trivial + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedWitness_detailed_bind_with_support_stable + (table : OtsSecretIndex → HashOutput) + (left right : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (leftNext rightNext : α → SplitHashCache → + OracleComp (LazyRevealProbe.World Coordinate) (β × SplitHashCache)) + (leftContext rightContext : DeferredContext) (leftFuel rightFuel : Nat) + (hleft : RelTriple + (runDirectResolvedWitnessFromTable leftContext leftFuel table left) + (runDirectResolvedDetailedFromTable rightContext rightFuel table right) + (DirectWitnessMaterializedStableRunEq table)) + (hclean : ∀ (leftResult rightResult : + ResolvedRunResult (α × SplitHashCache)), + DirectWitnessResult.done leftResult ∈ support + (runDirectResolvedWitnessFromTable leftContext leftFuel table left) → + DirectDetailedResult.done rightResult ∈ support + (runDirectResolvedDetailedFromTable rightContext rightFuel table right) → + OrdinaryMaterializedRunEq table leftResult rightResult → + RelTriple + (runDirectResolvedWitnessFromTable leftResult.context leftResult.remaining + leftResult.table (leftNext leftResult.value.1 leftResult.value.2)) + (runDirectResolvedDetailedFromTable rightResult.context rightResult.remaining + rightResult.table (rightNext rightResult.value.1 rightResult.value.2)) + (DirectWitnessMaterializedStableRunEq table)) : + RelTriple + (runDirectResolvedWitnessFromTable leftContext leftFuel table + (left >>= fun value => leftNext value.1 value.2)) + (runDirectResolvedDetailedFromTable rightContext rightFuel table + (right >>= fun value => rightNext value.1 value.2)) + (DirectWitnessMaterializedStableRunEq table) := by + rw [runDirectResolvedWitnessFromTable_bind, + runDirectResolvedDetailedFromTable_bind] + have hleftWithSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hleft + (fun result => result ∈ support + (runDirectResolvedWitnessFromTable leftContext leftFuel table left)) + (fun result hresult => hresult) + have hbothWithSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftWithSupport + apply relTriple_bind hbothWithSupport + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResult with + | stoppedFuel => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => exact relTriple_pure_pure trivial + | fuelExhausted => exact relTriple_pure_pure trivial + | done rightResult => + simp only + rw [hrelation.1.1] + exact relTriple_any_run_of_materializedDoomed_witness table + (pure .stoppedFuel) + (rightNext rightResult.value.1 rightResult.value.2) + rightResult.context rightResult.remaining hrelation.1.2 hrelation.2 + | stoppedOrdinary => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => exact relTriple_pure_pure trivial + | fuelExhausted => exact relTriple_pure_pure trivial + | done rightResult => + simp only + rw [hrelation.1.1] + exact relTriple_any_run_of_materializedDoomed_witness table + (pure .stoppedOrdinary) + (rightNext rightResult.value.1 rightResult.value.2) + rightResult.context rightResult.remaining hrelation.1.2 hrelation.2 + | stoppedPrivate witness => + cases rightResult with + | stopped rightReason => exact relTriple_pure_pure trivial + | done rightResult => + rcases hrelation with hstored | hdoomed + · simp only + rw [hstored.2] + exact relTriple_pure_stoppedPrivate_run_of_materialized_value table + rightResult.table witness rightResult.context.state rightResult.remaining + (rightNext rightResult.value.1 rightResult.value.2) hstored.1 + · simp only + rw [hdoomed.1.1] + exact relTriple_any_run_of_materializedDoomed_witness table + (pure (.stoppedPrivate witness)) + (rightNext rightResult.value.1 rightResult.value.2) + rightResult.context rightResult.remaining hdoomed.1.2 hdoomed.2 + | done leftResult => + cases rightResult with + | stopped rightReason => + cases rightReason with + | privateStructuralHit => contradiction + | ordinaryHit => + exact relTriple_any_pure_nonprivateStop_witness table _ .ordinaryHit (by decide) + | fuelExhausted => + exact relTriple_any_pure_nonprivateStop_witness table _ .fuelExhausted (by decide) + | done rightResult => + rcases hrelation with hcleanRelation | hdoomedRelation + · exact hclean leftResult rightResult hleftSupport hrightSupport hcleanRelation + · simp only + rw [hdoomedRelation.1.1] + exact relTriple_any_run_of_materializedDoomed_witness table + (runDirectResolvedWitnessFromTable leftResult.context leftResult.remaining + leftResult.table (leftNext leftResult.value.1 leftResult.value.2)) + (rightNext rightResult.value.1 rightResult.value.2) + rightResult.context rightResult.remaining hdoomedRelation.1.2 hdoomedRelation.2 + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedWitness_detailed_bind_stable + (table : OtsSecretIndex → HashOutput) + (left right : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (leftNext rightNext : α → SplitHashCache → + OracleComp (LazyRevealProbe.World Coordinate) (β × SplitHashCache)) + (leftContext rightContext : DeferredContext) (leftFuel rightFuel : Nat) + (hleft : RelTriple + (runDirectResolvedWitnessFromTable leftContext leftFuel table left) + (runDirectResolvedDetailedFromTable rightContext rightFuel table right) + (DirectWitnessMaterializedStableRunEq table)) + (hclean : ∀ (leftResult rightResult : + ResolvedRunResult (α × SplitHashCache)), + OrdinaryMaterializedRunEq table leftResult rightResult → + RelTriple + (runDirectResolvedWitnessFromTable leftResult.context leftResult.remaining + leftResult.table (leftNext leftResult.value.1 leftResult.value.2)) + (runDirectResolvedDetailedFromTable rightResult.context rightResult.remaining + rightResult.table (rightNext rightResult.value.1 rightResult.value.2)) + (DirectWitnessMaterializedStableRunEq table)) : + RelTriple + (runDirectResolvedWitnessFromTable leftContext leftFuel table + (left >>= fun value => leftNext value.1 value.2)) + (runDirectResolvedDetailedFromTable rightContext rightFuel table + (right >>= fun value => rightNext value.1 value.2)) + (DirectWitnessMaterializedStableRunEq table) := by + apply relTriple_runDirectResolvedWitness_detailed_bind_with_support_stable table left right + leftNext rightNext leftContext rightContext leftFuel rightFuel hleft + intro leftResult rightResult _hleftSupport _hrightSupport hrelation + exact hclean leftResult rightResult hrelation + +theorem WitnessMaterializedStableCouples.bind + {table : OtsSecretIndex → HashOutput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : WitnessMaterializedStableCouples table left) + (hnext : ∀ value, WitnessMaterializedStableCouples table (next value)) : + WitnessMaterializedStableCouples table (left >>= next) := by + intro leftContext rightContext leftFuel rightFuel leftCache rightCache hcontext hfuel hcache + hrevealed hvalues hpublished hrightMaterialized + rw [StateT.run_bind, StateT.run_bind] + apply relTriple_runDirectResolvedWitness_detailed_bind_stable table + (left.run leftCache) (left.run rightCache) + (fun value cache => (next value).run cache) + (fun value cache => (next value).run cache) + leftContext rightContext leftFuel rightFuel + · exact hleft leftContext rightContext leftFuel rightFuel leftCache rightCache hcontext hfuel + hcache hrevealed hvalues hpublished hrightMaterialized + · intro leftResult rightResult hrelation + rw [hrelation.left_table, hrelation.right_table, ← hrelation.value_eq] + exact hnext leftResult.value.1 leftResult.context rightResult.context + leftResult.remaining rightResult.remaining leftResult.value.2 rightResult.value.2 + hrelation.context_le hrelation.remaining_le hrelation.cache_eq hrelation.revealed_eq + hrelation.values_le hrelation.left_published hrelation.right_materialized + +theorem WitnessMaterializedStableCouples.toBetween + {table : OtsSecretIndex → HashOutput} + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + (hcomputation : WitnessMaterializedStableCouples table computation) : + WitnessMaterializedStableCouplesBetween table computation computation := + hcomputation + +theorem witnessMaterializedStableCouplesBetween_pure + (table : OtsSecretIndex → HashOutput) (leftValue rightValue : α) + (hvalue : leftValue = rightValue) : + WitnessMaterializedStableCouplesBetween table + (pure leftValue) (pure rightValue) := by + subst rightValue + exact (witnessMaterializedStableCouples_pure table leftValue).toBetween + +theorem WitnessMaterializedStableCouplesBetween.bind + {table : OtsSecretIndex → HashOutput} + {left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {leftNext rightNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hfirst : WitnessMaterializedStableCouplesBetween table left right) + (hnext : ∀ value, WitnessMaterializedStableCouplesBetween table + (leftNext value) (rightNext value)) : + WitnessMaterializedStableCouplesBetween table + (left >>= leftNext) (right >>= rightNext) := by + intro leftContext rightContext leftFuel rightFuel leftCache rightCache hcontext hfuel hcache + hrevealed hvalues hpublished hrightMaterialized + rw [StateT.run_bind, StateT.run_bind] + apply relTriple_runDirectResolvedWitness_detailed_bind_stable table + (left.run leftCache) (right.run rightCache) + (fun value cache => (leftNext value).run cache) + (fun value cache => (rightNext value).run cache) + leftContext rightContext leftFuel rightFuel + · exact hfirst leftContext rightContext leftFuel rightFuel leftCache rightCache hcontext hfuel + hcache hrevealed hvalues hpublished hrightMaterialized + · intro leftResult rightResult hrelation + rw [hrelation.left_table, hrelation.right_table, ← hrelation.value_eq] + exact hnext leftResult.value.1 leftResult.context rightResult.context + leftResult.remaining rightResult.remaining leftResult.value.2 rightResult.value.2 + hrelation.context_le hrelation.remaining_le hrelation.cache_eq hrelation.revealed_eq + hrelation.values_le hrelation.left_published hrelation.right_materialized + +def WitnessMaterializedStableCouplesBetweenPositive + (table : OtsSecretIndex → HashOutput) + (left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftContext rightContext leftFuel rightFuel leftCache rightCache, + 0 < leftFuel → + FinalizationContextLE table leftContext rightContext → + leftFuel ≤ rightFuel → + ordinaryQueryCache leftCache = ordinaryQueryCache rightCache → + leftContext.state.revealed = rightContext.state.revealed → + LazyRevealProbe.ValuesLE leftContext.state rightContext.state → + PublishedValues leftContext.state → + rightContext = directDeferredContext rightContext.state → + RelTriple + (runDirectResolvedWitnessFromTable leftContext leftFuel table (left.run leftCache)) + (runDirectResolvedDetailedFromTable rightContext rightFuel table (right.run rightCache)) + (DirectWitnessMaterializedStableRunEq table) + +theorem WitnessMaterializedStableCouplesBetweenPositive.bind + {table : OtsSecretIndex → HashOutput} + {left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {leftNext rightNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hfirst : WitnessMaterializedStableCouplesBetweenPositive table left right) + (hnext : ∀ value, WitnessMaterializedStableCouplesBetween table + (leftNext value) (rightNext value)) : + WitnessMaterializedStableCouplesBetweenPositive table + (left >>= leftNext) (right >>= rightNext) := by + intro leftContext rightContext leftFuel rightFuel leftCache rightCache hpositive hcontext hfuel + hcache hrevealed hvalues hpublished hrightMaterialized + rw [StateT.run_bind, StateT.run_bind] + apply relTriple_runDirectResolvedWitness_detailed_bind_stable table + (left.run leftCache) (right.run rightCache) + (fun value cache => (leftNext value).run cache) + (fun value cache => (rightNext value).run cache) + leftContext rightContext leftFuel rightFuel + · exact hfirst leftContext rightContext leftFuel rightFuel leftCache rightCache hpositive + hcontext hfuel hcache hrevealed hvalues hpublished hrightMaterialized + · intro leftResult rightResult hrelation + rw [hrelation.left_table, hrelation.right_table, ← hrelation.value_eq] + exact hnext leftResult.value.1 leftResult.context rightResult.context + leftResult.remaining rightResult.remaining leftResult.value.2 rightResult.value.2 + hrelation.context_le hrelation.remaining_le hrelation.cache_eq hrelation.revealed_eq + hrelation.values_le hrelation.left_published hrelation.right_materialized + +set_option maxRecDepth 100000 in +theorem witnessMaterializedStableCouplesBetween_probe + (table : OtsSecretIndex → HashOutput) (candidate : Probe) : + WitnessMaterializedStableCouplesBetweenPositive table + (probe candidate) (probe candidate) := by + intro left right leftFuel rightFuel leftCache rightCache hpositive hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + cases leftFuel with + | zero => omega + | succ leftRemaining => + obtain ⟨rightRemaining, hrightFuel⟩ : ∃ rightRemaining, + rightFuel = rightRemaining + 1 := by + refine ⟨rightFuel - 1, ?_⟩ + omega + subst rightFuel + unfold probe + simp only [StateT.run_liftM] + unfold LazyRevealProbe.probeQuery + rw [runDirectResolvedWitnessFromTable_probe_query_bind, + runDirectResolvedDetailedFromTable_probe_query_bind] + by_cases hleftRevealed : candidate.coordinate ∈ left.state.revealed + · have hrightRevealed : candidate.coordinate ∈ right.state.revealed := by + rw [← hrevealed] + exact hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + exact (witnessMaterializedStableCouples_pure table ()) + left right leftRemaining rightRemaining leftCache rightCache hcontext (by omega) + hcache hrevealed hvalues hpublished hrightMaterialized + · have hrightRevealed : candidate.coordinate ∉ right.state.revealed := by + rwa [← hrevealed] + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + let nextLeft : DeferredContext := + { left with state := left.state.addPending candidate.coordinate candidate.candidate } + let nextRight : DeferredContext := + { right with state := right.state.addPending candidate.coordinate candidate.candidate } + by_cases hcompletable : DeferredCompletable table nextRight + · have hnext := hcontext.addPending_both_of_right_completable + candidate.coordinate candidate.candidate hcompletable + have hnextPublished : PublishedValues nextLeft.state := by + simpa [nextLeft, PublishedValues, LazyRevealProbe.State.addPending] using hpublished + exact (witnessMaterializedStableCouples_pure table ()) + nextLeft nextRight leftRemaining rightRemaining leftCache rightCache hnext (by omega) + hcache hrevealed hvalues hnextPublished (by + show nextRight = directDeferredContext nextRight.state + dsimp [nextRight] + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_addPending]) + · simp only [runDirectResolvedWitnessFromTable] + rw [runDirectResolvedDetailedFromTable_pure] + apply relTriple_pure_pure + right + exact ⟨⟨rfl, hcontext.view.rightConsistent.addPending + candidate.coordinate candidate.candidate, + hcontext.view.rightStarts.addPending + candidate.coordinate candidate.candidate, hcompletable⟩, by + show nextRight = directDeferredContext nextRight.state + dsimp [nextRight] + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_addPending]⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_pure_probe_right_witness + (table : OtsSecretIndex → HashOutput) (candidate : Probe) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hstrictFuel : leftFuel < rightFuel) + (hcontext : FinalizationContextLE table left right) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table (pure ((), leftCache))) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probe candidate).run rightCache)) + (DirectWitnessMaterializedStableRunEq table) := by + cases rightFuel with + | zero => omega + | succ rightRemaining => + unfold probe + simp only [StateT.run_liftM] + unfold LazyRevealProbe.probeQuery + rw [runDirectResolvedDetailedFromTable_probe_query_bind] + simp only [runDirectResolvedWitnessFromTable] + by_cases hrightRevealed : candidate.coordinate ∈ right.state.revealed + · simp only [hrightRevealed, ↓reduceIte] + exact witnessMaterializedStableCouples_pure table () left right leftFuel rightRemaining + leftCache rightCache hcontext (by omega) hcache hrevealed hvalues hpublished + hrightMaterialized + · simp only [hrightRevealed, ↓reduceIte] + let nextRight : DeferredContext := + { right with state := right.state.addPending candidate.coordinate candidate.candidate } + by_cases hcompletable : DeferredCompletable table nextRight + · have hnext := hcontext.addPending_right_of_completable + candidate.coordinate candidate.candidate hcompletable + exact witnessMaterializedStableCouples_pure table () left nextRight leftFuel + rightRemaining leftCache rightCache hnext (by omega) hcache hrevealed hvalues + hpublished (by + show nextRight = directDeferredContext nextRight.state + dsimp [nextRight] + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_addPending]) + · rw [runDirectResolvedDetailedFromTable_pure] + apply relTriple_pure_pure + right + exact ⟨⟨rfl, hcontext.view.rightConsistent.addPending + candidate.coordinate candidate.candidate, + hcontext.view.rightStarts.addPending + candidate.coordinate candidate.candidate, hcompletable⟩, by + show nextRight = directDeferredContext nextRight.state + dsimp [nextRight] + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_addPending]⟩ + +theorem runDirectResolvedWitnessFromTable_peekCoordinate + (coordinate : Coordinate) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runDirectResolvedWitnessFromTable context fuel table + ((peekCoordinate coordinate).run cache) = + pure (.done ⟨context, fuel, + (truncateHash <$> context.state.values coordinate, cache), table⟩) := by + unfold peekCoordinate LazyRevealProbe.peekQuery + rw [StateT.run_bind, runDirectResolvedWitnessFromTable_bind] + simp only [StateT.run_liftM] + rw [runDirectResolvedWitnessFromTable_peek_query_bind] + simp [runDirectResolvedWitnessFromTable] + +theorem runDirectResolvedWitnessFromTable_peekPositionValues_eq_pure + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ∀ positions, + runDirectResolvedWitnessFromTable context fuel table + ((peekPositionValues positions).run cache) = + pure (.done ⟨context, fuel, + (purePeekPositionValues context.state positions, cache), table⟩) + | [] => by + simp [peekPositionValues, purePeekPositionValues, + runDirectResolvedWitnessFromTable] + | position :: remaining => by + rw [peekPositionValues, StateT.run_bind, runDirectResolvedWitnessFromTable_bind, + runDirectResolvedWitnessFromTable_peekCoordinate] + cases hvalue : truncateHash <$> context.state.values (.position position) with + | none => + simp [purePeekPositionValues, hvalue, runDirectResolvedWitnessFromTable] + | some value => + simp only [pure_bind] + rw [StateT.run_bind, runDirectResolvedWitnessFromTable_bind, + runDirectResolvedWitnessFromTable_peekPositionValues_eq_pure context fuel table cache + remaining] + cases htail : purePeekPositionValues context.state remaining <;> + simp [purePeekPositionValues, hvalue, htail, runDirectResolvedWitnessFromTable] + +set_option maxRecDepth 100000 in +theorem runDirectResolvedWitnessFromTable_peekTableInput_eq_pure + (parameter : PublicParameter) (coordinate : Coordinate) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runDirectResolvedWitnessFromTable context fuel table + ((peekTableInput parameter coordinate).run cache) = + pure (.done ⟨context, fuel, + (purePeekTableInput parameter context.state coordinate, cache), table⟩) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [peekTableInput, purePeekTableInput, runDirectResolvedWitnessFromTable] + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput.eq_2] + by_cases hzero : step.val = 0 + · rw [if_pos hzero] + rw [StateT.run_bind, runDirectResolvedWitnessFromTable_bind, + runDirectResolvedWitnessFromTable_peekCoordinate] + cases hvalue : truncateHash <$> + context.state.values (.chainStart lay tree leafIdx chainIdx) <;> + simp [purePeekTableInput, hzero, hvalue, + runDirectResolvedWitnessFromTable] + · rw [if_neg hzero] + rw [StateT.run_bind, runDirectResolvedWitnessFromTable_bind, + runDirectResolvedWitnessFromTable_peekPositionValues_eq_pure] + cases hvalues : purePeekPositionValues context.state + (Position.chain lay tree leafIdx chainIdx step).children <;> + simp [purePeekTableInput, hzero, hvalues, + runDirectResolvedWitnessFromTable] + | leaf lay tree leafIdx => + simp only [peekTableInput] + rw [StateT.run_bind, runDirectResolvedWitnessFromTable_bind, + runDirectResolvedWitnessFromTable_peekPositionValues_eq_pure] + cases hvalues : purePeekPositionValues context.state _ <;> + simp [purePeekTableInput, hvalues, runDirectResolvedWitnessFromTable] + | node lay tree level nodeIdx => + simp only [peekTableInput] + rw [StateT.run_bind, runDirectResolvedWitnessFromTable_bind, + runDirectResolvedWitnessFromTable_peekPositionValues_eq_pure] + cases hvalues : purePeekPositionValues context.state _ <;> + simp [purePeekTableInput, hvalues, runDirectResolvedWitnessFromTable] + | ftsLeaf index tree leafIdx => + simp only [peekTableInput] + rw [StateT.run_bind, runDirectResolvedWitnessFromTable_bind, + runDirectResolvedWitnessFromTable_peekPositionValues_eq_pure] + cases hvalues : purePeekPositionValues context.state _ <;> + simp [purePeekTableInput, hvalues, runDirectResolvedWitnessFromTable] + | ftsNode index tree level nodeIdx => + simp only [peekTableInput] + rw [StateT.run_bind, runDirectResolvedWitnessFromTable_bind, + runDirectResolvedWitnessFromTable_peekPositionValues_eq_pure] + cases hvalues : purePeekPositionValues context.state _ <;> + simp [purePeekTableInput, hvalues, runDirectResolvedWitnessFromTable] + | ftsRoots index => + simp only [peekTableInput] + rw [StateT.run_bind, runDirectResolvedWitnessFromTable_bind, + runDirectResolvedWitnessFromTable_peekPositionValues_eq_pure] + cases hvalues : purePeekPositionValues context.state _ <;> + simp [purePeekTableInput, hvalues, runDirectResolvedWitnessFromTable] + +set_option maxRecDepth 100000 in +theorem runDirectResolvedWitnessFromTable_resolveKnownInput_eq_public + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runDirectResolvedWitnessFromTable context fuel table + ((resolveKnownInput parameter coordinate input).run cache) = + runDirectResolvedWitnessFromTable context fuel table + ((resolvePublicKnownInput parameter context.state coordinate input).run cache) := by + unfold resolveKnownInput resolvePublicKnownInput + rw [StateT.run_bind, runDirectResolvedWitnessFromTable_bind, + runDirectResolvedWitnessFromTable_peekTableInput_eq_pure] + simp only [pure_bind] + cases hknown : purePeekTableInput parameter context.state coordinate with + | none => rfl + | some knownInput => + by_cases heq : knownInput = input <;> simp [heq] + +set_option maxRecDepth 100000 in +theorem runDirectResolvedWitnessFromTable_afterPlan_eq_publicPlan + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) = + runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterPublicPlan parameter input context.state plan).run cache) := by + unfold probingHashQueryAfterPlan probingHashQueryAfterPublicPlan executePlannedHashQuery + cases hcandidate : plan.candidate? with + | none => + simp only [executeCandidate?, pure_bind] + cases haction : plan.action with + | ordinary => rfl + | resolve coordinate => + exact runDirectResolvedWitnessFromTable_resolveKnownInput_eq_public parameter + coordinate input context fuel table cache + | some candidate => + simp only [executeCandidate?] + rw [StateT.run_bind, StateT.run_bind, runDirectResolvedWitnessFromTable_bind, + runDirectResolvedWitnessFromTable_bind] + simp only [probe, StateT.run_liftM, LazyRevealProbe.probeQuery, + runDirectResolvedWitnessFromTable_probe_query_bind] + cases fuel with + | zero => rfl + | succ remaining => + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + simp only [runDirectResolvedWitnessFromTable] + cases haction : plan.action with + | ordinary => rfl + | resolve coordinate => + exact runDirectResolvedWitnessFromTable_resolveKnownInput_eq_public parameter + coordinate input context remaining table cache + · simp only [hrevealed, ↓reduceIte] + let nextContext : DeferredContext := + { context with state := + context.state.addPending candidate.coordinate candidate.candidate } + rw [show + runDirectResolvedWitnessFromTable nextContext remaining table (pure ((), cache)) = + pure (.done ⟨nextContext, remaining, ((), cache), table⟩) by + simp [runDirectResolvedWitnessFromTable]] + simp only [pure_bind] + cases haction : plan.action with + | ordinary => rfl + | resolve coordinate => + have hbase := runDirectResolvedWitnessFromTable_resolveKnownInput_eq_public + parameter coordinate input nextContext remaining table cache + have hpublic := resolvePublicKnownInput_eq_of_values_eq parameter + (left := nextContext.state) (right := context.state) (by + rfl) coordinate input + rw [hpublic] at hbase + exact hbase + +theorem runDirectResolvedWitnessFromTable_publishOrdinaryInput + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (input : HashInput) (output : HashOutput) (context : DeferredContext) + (fuel : Nat) (cache : SplitHashCache) : + runDirectResolvedWitnessFromTable context fuel table + ((publishOrdinaryInput coordinate input output).run cache) = + pure (.done ⟨ + { context with state := context.state.publish coordinate }, + fuel, + (output, Function.update cache (.ordinary input) (some output)), + table⟩) := by + unfold publishOrdinaryInput publishCoordinate + rw [StateT.run_bind, runDirectResolvedWitnessFromTable_bind] + simp only [StateT.run_liftM, LazyRevealProbe.publishQuery] + rw [runDirectResolvedWitnessFromTable_publish_query_bind] + simp [StateT.run_modify, runDirectResolvedWitnessFromTable] + +theorem relTriple_runDirectResolvedWitness_publishOrdinaryInput_stable + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (input : HashInput) (output : HashOutput) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hleftValue : left.state.values coordinate = some output) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((publishOrdinaryInput coordinate input output).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((publishOrdinaryInput coordinate input output).run rightCache)) + (DirectWitnessMaterializedStableRunEq table) := by + have hrightValue : right.state.values coordinate = some output := + hvalues coordinate output hleftValue + rw [runDirectResolvedWitnessFromTable_publishOrdinaryInput, + runDirectResolvedDetailedFromTable_publishOrdinaryInput] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext.publish coordinate + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update, ordinaryQueryCache_update, hcache] + revealed_eq := by + simpa [LazyRevealProbe.State.publish] using congrArg (insert coordinate) hrevealed + values_le := hvalues + left_published := hpublished.publish_of_value coordinate output hleftValue + right_materialized := by + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_publish] } + +theorem witnessMaterializedStableCouples_ensureCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + WitnessMaterializedStableCouples table (ensureCoordinate coordinate) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + unfold ensureCoordinate + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.ensureQuery, + runDirectResolvedWitnessFromTable_ensure_query_bind, + runDirectResolvedDetailedFromTable_ensure_query_bind, + runDirectResolvedDetailedFromTable_pure] + simp only [runDirectResolvedWitnessFromTable] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext.ensure coordinate + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := hcache + revealed_eq := by + simpa [LazyRevealProbe.State.ensure] using hrevealed + values_le := by + intro other output hvalue + exact hvalues other output hvalue + left_published := by + simpa [PublishedValues, LazyRevealProbe.State.ensure] using hpublished + right_materialized := by + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_ensure] } + +theorem witnessMaterializedStableCouples_sequenceFin + {table : OtsSecretIndex → HashOutput} {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, + WitnessMaterializedStableCouples table (computation index)) : + WitnessMaterializedStableCouples table (sequenceFin computation) := by + induction n with + | zero => + simpa [sequenceFin] using + (witnessMaterializedStableCouples_pure table Fin.elim0 : + WitnessMaterializedStableCouples table + (pure Fin.elim0 : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Fin 0 → α))) + | succ n ih => + rw [sequenceFin] + apply (hcomponent 0).bind + intro head + apply (ih (fun index : Fin n => computation index.succ) + (fun index => hcomponent index.succ)).bind + intro tail + exact witnessMaterializedStableCouples_pure table + (Fin.cases head tail : Fin (n + 1) → α) + +set_option maxRecDepth 100000 in +theorem witnessMaterializedStableCouples_splitHashQuery_ordinary + (table : OtsSecretIndex → HashOutput) (input : HashInput) : + WitnessMaterializedStableCouples table + (splitHashQuery (.ordinary input)) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + have hcacheAt : leftCache (.ordinary input) = rightCache (.ordinary input) := + congrFun hcache input + cases hlookup : leftCache (.ordinary input) with + | some output => + have hright : rightCache (.ordinary input) = some output := by + rw [← hcacheAt] + exact hlookup + simp only [hright] + exact witnessMaterializedStableCouples_pure table output left right leftFuel rightFuel + leftCache rightCache hcontext hfuel hcache hrevealed hvalues hpublished + hrightMaterialized + | none => + have hright : rightCache (.ordinary input) = none := by + rw [← hcacheAt] + exact hlookup + simp only [hright] + rw [LazyRevealProbe.hashOutputQuery, + runDirectResolvedWitnessFromTable_hashOutput_query_bind, + runDirectResolvedDetailedFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runDirectResolvedWitnessFromTable, + runDirectResolvedDetailedFromTable] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update, ordinaryQueryCache_update, hcache] + revealed_eq := hrevealed + values_le := hvalues + left_published := hpublished + right_materialized := hrightMaterialized } + +theorem witnessMaterializedStableCouples_ordinaryHashImpl + (table : OtsSecretIndex → HashOutput) (input : HashInput) : + WitnessMaterializedStableCouples table (ordinaryHashImpl input) := + witnessMaterializedStableCouples_splitHashQuery_ordinary table input + +theorem witnessMaterializedStableCouples_splitUniformImpl + (table : OtsSecretIndex → HashOutput) (n : unifSpec.Domain) : + WitnessMaterializedStableCouples table (splitUniformImpl n) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + unfold splitUniformImpl + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.uniformQuery, + runDirectResolvedWitnessFromTable_uniform_query_bind, + runDirectResolvedDetailedFromTable_uniform_query_bind] + apply relTriple_bind (relTriple_refl + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))) + intro leftOutput rightOutput houtput + subst rightOutput + exact witnessMaterializedStableCouples_pure table leftOutput left right leftFuel rightFuel + leftCache rightCache hcontext hfuel hcache hrevealed hvalues hpublished + hrightMaterialized + +theorem witnessMaterializedStableCouples_simulateQ + {table : OtsSecretIndex → HashOutput} {spec : OracleSpec ι} + (impl : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))) + (hquery : ∀ query, WitnessMaterializedStableCouples table (impl query)) + (computation : OracleComp spec α) : + WitnessMaterializedStableCouples table (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp only [simulateQ_pure] + exact witnessMaterializedStableCouples_pure table value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (hquery query).bind fun output => ih output + +theorem runDirectResolvedWitnessFromTable_revealCoordinateOutput_of_value + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (output : HashOutput) + (hvalue : context.state.values coordinate = some output) : + runDirectResolvedWitnessFromTable context fuel table + ((revealCoordinateOutput coordinate).run cache) = + pure (.done ⟨context, fuel, + (output, Function.update cache (.hidden coordinate) (some output)), table⟩) := by + unfold revealCoordinateOutput + rw [StateT.run_bind, runDirectResolvedWitnessFromTable_bind] + simp only [StateT.run_liftM] + rw [LazyRevealProbe.revealQuery, + runDirectResolvedWitnessFromTable_reveal_query_bind, hvalue] + simp [StateT.run_modify, runDirectResolvedWitnessFromTable] + +theorem runDirectResolvedWitnessFromTable_revealCoordinateOutput_position_of_private + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (output : HashOutput) + (hhidden : context.state.values (.position position) = none) + (hprivate : context.values position = some output) : + runDirectResolvedWitnessFromTable context fuel table + ((revealCoordinateOutput (.position position)).run cache) = + if context.state.hitAt (.position position) output then + pure (.stoppedPrivate ⟨position, output, context.state.revealed⟩) + else + pure (.done ⟨ + { state := context.state.materialize (.position position) output + values := context.values }, + fuel, + (output, Function.update cache (.hidden (.position position)) (some output)), + table⟩) := by + unfold revealCoordinateOutput + rw [StateT.run_bind, runDirectResolvedWitnessFromTable_bind] + simp only [StateT.run_liftM] + rw [LazyRevealProbe.revealQuery, + runDirectResolvedWitnessFromTable_reveal_query_bind] + by_cases hhit : context.state.hitAt (.position position) output <;> + simp [hhidden, hprivate, hhit, StateT.run_modify, + runDirectResolvedWitnessFromTable] + +theorem runDirectResolvedWitnessFromTable_revealCoordinateOutput_position_of_fresh + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hhidden : context.state.values (.position position) = none) + (hprivate : context.values position = none) : + runDirectResolvedWitnessFromTable context fuel table + ((revealCoordinateOutput (.position position)).run cache) = (do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt (.position position) output then + pure .stoppedOrdinary + else + pure (.done ⟨ + { state := context.state.materialize (.position position) output + values := context.values.install position output }, + fuel, + (output, Function.update cache (.hidden (.position position)) (some output)), + table⟩)) := by + unfold revealCoordinateOutput + rw [StateT.run_bind, runDirectResolvedWitnessFromTable_bind] + simp only [StateT.run_liftM] + rw [LazyRevealProbe.revealQuery, + runDirectResolvedWitnessFromTable_reveal_query_bind] + simp [hhidden, hprivate, StateT.run_modify, runDirectResolvedWitnessFromTable] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output <;> simp [hhit] + +set_option maxRecDepth 100000 in +theorem witnessMaterializedStableCouples_revealCoordinateOutput_position + (table : OtsSecretIndex → HashOutput) (position : Position) : + WitnessMaterializedStableCouples table + (revealCoordinateOutput (.position position)) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + cases hleftValue : left.state.values (.position position) with + | some output => + have hrightValue : right.state.values (.position position) = some output := + hvalues (.position position) output hleftValue + rw [runDirectResolvedWitnessFromTable_revealCoordinateOutput_of_value table + (.position position) left leftFuel leftCache output hleftValue, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + (.position position) right rightFuel rightCache output hrightValue] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache] + revealed_eq := hrevealed + values_le := hvalues + left_published := hpublished + right_materialized := hrightMaterialized } + | none => + cases hrightValue : right.state.values (.position position) with + | some output => + have hprivate := hcontext.view.privateValue_of_left_hidden_of_right_materialized + position output hleftValue hrightValue + rw [runDirectResolvedWitnessFromTable_revealCoordinateOutput_position_of_private + table position left leftFuel leftCache output hleftValue hprivate, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + (.position position) right rightFuel rightCache output hrightValue] + by_cases hhit : left.state.hitAt (.position position) output + · simp only [hhit, ↓reduceIte] + apply relTriple_pure_pure + left + exact ⟨hrightValue, hrightMaterialized⟩ + · simp only [hhit, ↓reduceIte] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext.materialize_position_left position output + hleftValue hprivate + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache] + revealed_eq := by + simpa [LazyRevealProbe.State.materialize] using hrevealed + values_le := hvalues.materialize_left (.position position) output hrightValue + left_published := hpublished.materialize (.position position) output + right_materialized := hrightMaterialized } + | none => + have hrightPrivate : right.values position = none := by + rw [hrightMaterialized] + simpa [directDeferredContext, directDeferredValues] using hrightValue + have hleftPositionValue : left.positionValue position = none := by + change resolvedCompletionValue table left (.position position) = none + rw [hcontext.view.valueEq] + simp [resolvedCompletionValue, DeferredContext.positionValue, hrightValue, + hrightPrivate] + have hleftPrivate : left.values position = none := by + simpa [DeferredContext.positionValue, hleftValue] using hleftPositionValue + rw [runDirectResolvedWitnessFromTable_revealCoordinateOutput_position_of_fresh + table position left leftFuel leftCache hleftValue hleftPrivate, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_position_of_fresh + table position right rightFuel rightCache hrightValue hrightPrivate] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + by_cases hleftHit : left.state.hitAt (.position position) leftOutput + · have hresolvedNone : + resolvedCompletionValue table left (.position position) = none := by + simpa [resolvedCompletionValue] using hleftPositionValue + have hrightHit : right.state.hitAt (.position position) leftOutput := by + unfold LazyRevealProbe.State.hitAt at hleftHit ⊢ + exact hcontext.view.pendingLE (.position position) hresolvedNone hleftHit + simp only [hleftHit, hrightHit, ↓reduceIte] + exact relTriple_pure_pure trivial + · by_cases hrightHit : right.state.hitAt (.position position) leftOutput + · simp only [hleftHit, hrightHit, ↓reduceIte] + exact relTriple_pure_pure trivial + · simp only [hleftHit, hrightHit, ↓reduceIte] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext.materialize_position_both position leftOutput + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, + hcache] + revealed_eq := by + simpa [LazyRevealProbe.State.materialize] using hrevealed + values_le := hvalues.materialize_both (.position position) leftOutput + left_published := hpublished.materialize (.position position) leftOutput + right_materialized := by + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_materialize_position] } + +theorem witnessMaterializedStableCouples_revealPosition + (table : OtsSecretIndex → HashOutput) (position : Position) : + WitnessMaterializedStableCouples table (revealPosition position) := by + unfold revealPosition revealCoordinate + exact (witnessMaterializedStableCouples_revealCoordinateOutput_position table position).bind + fun output => witnessMaterializedStableCouples_pure table (truncateHash output) + +theorem runDirectResolvedWitnessFromTable_revealCoordinateOutput_chainStart_of_missing + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hmissing : context.state.values index.coordinate = none) : + runDirectResolvedWitnessFromTable context fuel table + ((revealCoordinateOutput index.coordinate).run cache) = + if context.state.hitAt index.coordinate (table index) then + pure .stoppedOrdinary + else + pure (.done ⟨ + { context with + state := context.state.materialize index.coordinate (table index) }, + fuel, + (table index, Function.update cache (.hidden index.coordinate) (some (table index))), + table⟩) := by + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + change context.state.values (.chainStart lay tree leafIdx chainIdx) = none at hmissing + unfold revealCoordinateOutput + rw [StateT.run_bind, runDirectResolvedWitnessFromTable_bind] + simp only [StateT.run_liftM] + rw [LazyRevealProbe.revealQuery, + runDirectResolvedWitnessFromTable_reveal_query_bind] + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) (table ⟨lay, tree, leafIdx, chainIdx⟩) <;> + simp [OtsSecretIndex.coordinate, hmissing, hhit, StateT.run_modify, + runDirectResolvedWitnessFromTable] + +set_option maxRecDepth 100000 in +theorem witnessMaterializedStableCouples_revealCoordinateOutput_chainStart + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) : + WitnessMaterializedStableCouples table + (revealCoordinateOutput index.coordinate) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + cases hleftValue : left.state.values index.coordinate with + | some output => + have hrightValue : right.state.values index.coordinate = some output := + hvalues index.coordinate output hleftValue + rw [runDirectResolvedWitnessFromTable_revealCoordinateOutput_of_value table + index.coordinate left leftFuel leftCache output hleftValue, + runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + index.coordinate right rightFuel rightCache output hrightValue] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache] + revealed_eq := hrevealed + values_le := hvalues + left_published := hpublished + right_materialized := hrightMaterialized } + | none => + have hleftMiss : ¬left.state.hitAt index.coordinate (table index) := + hcontext.leftCompletable.not_hitAt_chainStart index + rw [runDirectResolvedWitnessFromTable_revealCoordinateOutput_chainStart_of_missing + table index left leftFuel leftCache hleftValue, if_neg hleftMiss] + cases hrightValue : right.state.values index.coordinate with + | some output => + have houtput : output = table index := + hcontext.view.rightStarts index output hrightValue + subst output + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_of_value table + index.coordinate right rightFuel rightCache (table index) hrightValue] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext.materialize_chainStart_left index + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache] + revealed_eq := by + simpa [LazyRevealProbe.State.materialize] using hrevealed + values_le := hvalues.materialize_left index.coordinate (table index) hrightValue + left_published := hpublished.materialize index.coordinate (table index) + right_materialized := hrightMaterialized } + | none => + have hrightMiss : ¬right.state.hitAt index.coordinate (table index) := + hcontext.rightCompletable.not_hitAt_chainStart index + rw [runDirectResolvedDetailedFromTable_revealCoordinateOutput_chainStart_of_missing + table index right rightFuel rightCache hrightValue, if_neg hrightMiss] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext.materialize_chainStart_both index + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, hcache] + revealed_eq := by + simpa [LazyRevealProbe.State.materialize] using hrevealed + values_le := hvalues.materialize_both index.coordinate (table index) + left_published := hpublished.materialize index.coordinate (table index) + right_materialized := by + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_materialize_chainStart] } + +theorem witnessMaterializedStableCouples_revealCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + WitnessMaterializedStableCouples table (revealCoordinate coordinate) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + unfold revealCoordinate + exact (witnessMaterializedStableCouples_revealCoordinateOutput_chainStart table + ⟨lay, tree, leafIdx, chainIdx⟩).bind fun output => + witnessMaterializedStableCouples_pure table (truncateHash output) + | position position => + exact witnessMaterializedStableCouples_revealPosition table position + +theorem witnessMaterializedStableCouples_revealCoordinateOutput + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + WitnessMaterializedStableCouples table (revealCoordinateOutput coordinate) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact witnessMaterializedStableCouples_revealCoordinateOutput_chainStart table + ⟨lay, tree, leafIdx, chainIdx⟩ + | position position => + exact witnessMaterializedStableCouples_revealCoordinateOutput_position table position + +set_option maxRecDepth 100000 in +theorem witnessMaterializedStableCouplesBetween_revealPublishOrdinaryInput + (table : OtsSecretIndex → HashOutput) + (coordinate : Coordinate) (input : HashInput) : + WitnessMaterializedStableCouplesBetween table + (revealPublishOrdinaryInput coordinate input) + (revealPublishOrdinaryInput coordinate input) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + unfold revealPublishOrdinaryInput + rw [StateT.run_bind, StateT.run_bind] + apply relTriple_runDirectResolvedWitness_detailed_bind_with_support_stable table + ((revealCoordinateOutput coordinate).run leftCache) + ((revealCoordinateOutput coordinate).run rightCache) + (fun output cache => (publishOrdinaryInput coordinate input output).run cache) + (fun output cache => (publishOrdinaryInput coordinate input output).run cache) + left right leftFuel rightFuel + · exact witnessMaterializedStableCouples_revealCoordinateOutput table coordinate + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed hvalues + hpublished hrightMaterialized + · intro leftResult rightResult hleftSupport _hrightSupport hrelation + have hleftDetailed : DirectDetailedResult.done leftResult ∈ support + (runDirectResolvedDetailedFromTable left leftFuel table + ((revealCoordinateOutput coordinate).run leftCache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((revealCoordinateOutput coordinate).run leftCache) left leftFuel table, + support_map] + exact ⟨DirectWitnessResult.done leftResult, hleftSupport, rfl⟩ + have hleftValue := + value_of_done_runDirectResolvedDetailedFromTable_revealCoordinateOutput table coordinate + left leftFuel leftCache leftResult hleftDetailed + rw [hrelation.left_table, hrelation.right_table, ← hrelation.value_eq] + exact relTriple_runDirectResolvedWitness_publishOrdinaryInput_stable table coordinate input + leftResult.value.1 leftResult.context rightResult.context leftResult.remaining + rightResult.remaining leftResult.value.2 rightResult.value.2 hrelation.context_le + hrelation.remaining_le hrelation.cache_eq hrelation.revealed_eq hrelation.values_le + hrelation.left_published hleftValue hrelation.right_materialized + +theorem witnessMaterializedStableCouplesBetween_resolvePublicKnownInput + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (publicState : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) (input : HashInput) : + WitnessMaterializedStableCouplesBetween table + (resolvePublicKnownInput parameter publicState coordinate input) + (resolvePublicKnownInput parameter publicState coordinate input) := by + unfold resolvePublicKnownInput + cases hknown : purePeekTableInput parameter publicState coordinate with + | none => + exact (witnessMaterializedStableCouples_splitHashQuery_ordinary table input).toBetween + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + exact witnessMaterializedStableCouplesBetween_revealPublishOrdinaryInput table coordinate + input + · simp only [heq, ↓reduceIte] + exact (witnessMaterializedStableCouples_splitHashQuery_ordinary table input).toBetween + +theorem witnessMaterializedStableCouplesBetween_publicPlan_of_none + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (hcandidate : plan.candidate? = none) : + WitnessMaterializedStableCouplesBetween table + (probingHashQueryAfterPublicPlan parameter input publicState plan) + (probingHashQueryAfterPublicPlan parameter input publicState plan) := by + unfold probingHashQueryAfterPublicPlan + rw [show executeCandidate? plan.candidate? = pure () by simp [hcandidate]] + simp only [pure_bind] + cases plan.action with + | ordinary => + exact (witnessMaterializedStableCouples_splitHashQuery_ordinary table input).toBetween + | resolve coordinate => + exact witnessMaterializedStableCouplesBetween_resolvePublicKnownInput table parameter + publicState coordinate input + +theorem witnessMaterializedStableCouplesBetweenPositive_publicPlan + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) : + WitnessMaterializedStableCouplesBetweenPositive table + (probingHashQueryAfterPublicPlan parameter input publicState plan) + (probingHashQueryAfterPublicPlan parameter input publicState plan) := by + unfold probingHashQueryAfterPublicPlan executeCandidate? + cases planCandidate : plan.candidate? with + | none => + simp only [pure_bind] + cases plan.action with + | ordinary => + intro left right leftFuel rightFuel leftCache rightCache _hpositive + exact (witnessMaterializedStableCouples_splitHashQuery_ordinary table input).toBetween + left right leftFuel rightFuel leftCache rightCache + | resolve coordinate => + intro left right leftFuel rightFuel leftCache rightCache _hpositive + exact witnessMaterializedStableCouplesBetween_resolvePublicKnownInput table parameter + publicState coordinate input left right leftFuel rightFuel leftCache rightCache + | some candidate => + apply (witnessMaterializedStableCouplesBetween_probe table candidate).bind + intro _ + cases plan.action with + | ordinary => + exact (witnessMaterializedStableCouples_splitHashQuery_ordinary table input).toBetween + | resolve coordinate => + exact witnessMaterializedStableCouplesBetween_resolvePublicKnownInput table parameter + publicState coordinate input + +noncomputable def probingHashQueryPublicAction + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (action : PlannedHashAction) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput := + match action with + | .ordinary => splitHashQuery (.ordinary input) + | .resolve coordinate => resolvePublicKnownInput parameter publicState coordinate input + +noncomputable def probingHashQueryAfterRootAwarePublicPlan + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput := do + executeCandidate? (rootAwareCandidateForPlan? parameter input plan) + probingHashQueryPublicAction parameter input publicState plan.action + +theorem probingHashQueryAfterRootAwarePublicPlan_eq_publicPlan_of_candidate + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (candidate : Probe) (hcandidate : plan.candidate? = some candidate) : + probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan = + probingHashQueryAfterPublicPlan parameter input publicState plan := by + unfold probingHashQueryAfterRootAwarePublicPlan probingHashQueryAfterPublicPlan + probingHashQueryPublicAction rootAwareCandidateForPlan? + rw [hcandidate] + cases plan.action <;> rfl + +theorem probingHashQueryAfterRootAwarePublicPlan_eq_probe_then_publicPlan + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (candidate : Probe) (hplan : plan.candidate? = none) + (hdecode : decodeEncodingLayerRootCandidate? parameter input = some candidate) : + probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan = (do + probe candidate + probingHashQueryAfterPublicPlan parameter input publicState plan) := by + unfold probingHashQueryAfterRootAwarePublicPlan probingHashQueryAfterPublicPlan + probingHashQueryPublicAction rootAwareCandidateForPlan? + rw [hplan, hdecode] + cases plan.action <;> rfl + +theorem probingHashQueryAfterRootAwarePublicPlan_eq_publicPlan_of_none + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (hplan : plan.candidate? = none) + (hdecode : decodeEncodingLayerRootCandidate? parameter input = none) : + probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan = + probingHashQueryAfterPublicPlan parameter input publicState plan := by + unfold probingHashQueryAfterRootAwarePublicPlan probingHashQueryAfterPublicPlan + probingHashQueryPublicAction rootAwareCandidateForPlan? + rw [hplan, hdecode] + cases plan.action <;> rfl + +theorem witnessMaterializedStableCouplesBetween_publicAction + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (action : PlannedHashAction) : + WitnessMaterializedStableCouplesBetween table + (probingHashQueryPublicAction parameter input publicState action) + (probingHashQueryPublicAction parameter input publicState action) := by + cases action with + | ordinary => + exact (witnessMaterializedStableCouples_splitHashQuery_ordinary table input).toBetween + | resolve coordinate => + exact witnessMaterializedStableCouplesBetween_resolvePublicKnownInput table parameter + publicState coordinate input + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedWitness_afterPlan_rootAwarePublic + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hpublicState : publicState = left.state) + (hpositive : 0 < leftFuel) (hstrictFuel : leftFuel < rightFuel) + (hcontext : FinalizationContextLE table left right) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache)) + (DirectWitnessMaterializedStableRunEq table) := by + subst publicState + rw [runDirectResolvedWitnessFromTable_afterPlan_eq_publicPlan parameter input plan left + leftFuel table leftCache] + cases hplan : plan.candidate? with + | some candidate => + rw [probingHashQueryAfterRootAwarePublicPlan_eq_publicPlan_of_candidate parameter input + left.state plan candidate hplan] + exact witnessMaterializedStableCouplesBetweenPositive_publicPlan table parameter input + left.state plan left right leftFuel rightFuel leftCache rightCache hpositive hcontext + (by omega) hcache hrevealed hvalues hpublished hrightMaterialized + | none => + cases hdecode : decodeEncodingLayerRootCandidate? parameter input with + | none => + rw [probingHashQueryAfterRootAwarePublicPlan_eq_publicPlan_of_none parameter input + left.state plan hplan hdecode] + exact witnessMaterializedStableCouplesBetween_publicPlan_of_none table parameter input + left.state plan hplan left right leftFuel rightFuel leftCache rightCache hcontext + (by omega) hcache hrevealed hvalues hpublished hrightMaterialized + | some candidate => + rw [probingHashQueryAfterRootAwarePublicPlan_eq_probe_then_publicPlan parameter input + left.state plan candidate hplan hdecode] + unfold probingHashQueryAfterPublicPlan + rw [show executeCandidate? plan.candidate? = pure () by simp [hplan]] + simp only [pure_bind, StateT.run_bind] + have hcoupling (action : PlannedHashAction) := + relTriple_runDirectResolvedWitness_detailed_bind_stable table + (pure ((), leftCache)) ((probe candidate).run rightCache) + (fun _ cache => + (probingHashQueryPublicAction parameter input left.state action).run cache) + (fun _ cache => + (probingHashQueryPublicAction parameter input left.state action).run cache) + left right leftFuel rightFuel + (relTriple_pure_probe_right_witness table candidate left right leftFuel rightFuel + leftCache rightCache hstrictFuel hcontext hcache hrevealed hvalues hpublished + hrightMaterialized) + (fun leftResult rightResult hrelation => by + rw [hrelation.left_table, hrelation.right_table] + exact witnessMaterializedStableCouplesBetween_publicAction table parameter input + left.state action leftResult.context rightResult.context + leftResult.remaining rightResult.remaining leftResult.value.2 rightResult.value.2 + hrelation.context_le hrelation.remaining_le hrelation.cache_eq + hrelation.revealed_eq hrelation.values_le hrelation.left_published + hrelation.right_materialized) + cases haction : plan.action <;> + simpa [haction, probingHashQueryPublicAction] using hcoupling plan.action + +theorem witnessMaterializedStableCouples_ordinaryRomImpl + (table : OtsSecretIndex → HashOutput) (query : OracleWorld.Domain) : + WitnessMaterializedStableCouples table (ordinaryRomImpl query) := by + cases query with + | inl n => exact witnessMaterializedStableCouples_splitUniformImpl table n + | inr input => exact witnessMaterializedStableCouples_ordinaryHashImpl table input + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedWitness_publishCoordinate_then_pure_stable + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (value : α) (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hleftValue : ∃ output, left.state.values coordinate = some output) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((publishCoordinate coordinate >>= fun _ => pure value).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((publishCoordinate coordinate >>= fun _ => pure value).run rightCache)) + (DirectWitnessMaterializedStableRunEq table) := by + obtain ⟨output, hleftValue⟩ := hleftValue + have hrightValue : right.state.values coordinate = some output := + hvalues coordinate output hleftValue + unfold publishCoordinate + rw [StateT.run_bind, StateT.run_bind] + simp only [StateT.run_liftM] + simp only [StateT.run_pure, bind_assoc, pure_bind] + unfold LazyRevealProbe.publishQuery + rw [runDirectResolvedWitnessFromTable_publish_query_bind, + runDirectResolvedDetailedFromTable_publish_query_bind, + runDirectResolvedDetailedFromTable_pure] + simp only [runDirectResolvedWitnessFromTable] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext.publish coordinate + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := hcache + revealed_eq := by + simpa [LazyRevealProbe.State.publish] using congrArg (insert coordinate) hrevealed + values_le := by + intro other otherOutput hvalue + exact hvalues other otherOutput hvalue + left_published := hpublished.publish_of_value coordinate output hleftValue + right_materialized := by + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_publish] } + +set_option maxRecDepth 100000 in +theorem witnessMaterializedStableCouples_revealPublishedCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + WitnessMaterializedStableCouples table (revealPublishedCoordinate coordinate) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + unfold revealPublishedCoordinate revealCoordinate + simp only [bind_assoc, pure_bind] + rw [StateT.run_bind, StateT.run_bind] + apply relTriple_runDirectResolvedWitness_detailed_bind_with_support_stable table + ((revealCoordinateOutput coordinate).run leftCache) + ((revealCoordinateOutput coordinate).run rightCache) + (fun output cache => + ((publishCoordinate coordinate >>= fun _ => pure (truncateHash output)).run cache)) + (fun output cache => + ((publishCoordinate coordinate >>= fun _ => pure (truncateHash output)).run cache)) + left right leftFuel rightFuel + · exact witnessMaterializedStableCouples_revealCoordinateOutput table coordinate + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed hvalues + hpublished hrightMaterialized + · intro leftResult rightResult hleftSupport _hrightSupport hrelation + have hleftDetailed : DirectDetailedResult.done leftResult ∈ support + (runDirectResolvedDetailedFromTable left leftFuel table + ((revealCoordinateOutput coordinate).run leftCache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((revealCoordinateOutput coordinate).run leftCache) left leftFuel table, + support_map] + exact ⟨DirectWitnessResult.done leftResult, hleftSupport, rfl⟩ + have hleftValue := + value_of_done_runDirectResolvedDetailedFromTable_revealCoordinateOutput table coordinate + left leftFuel leftCache leftResult hleftDetailed + rw [hrelation.left_table, hrelation.right_table, ← hrelation.value_eq] + exact relTriple_runDirectResolvedWitness_publishCoordinate_then_pure_stable table + coordinate (truncateHash leftResult.value.1) leftResult.context rightResult.context + leftResult.remaining rightResult.remaining leftResult.value.2 rightResult.value.2 + hrelation.context_le hrelation.remaining_le hrelation.cache_eq hrelation.revealed_eq + hrelation.values_le hrelation.left_published ⟨leftResult.value.1, hleftValue⟩ + hrelation.right_materialized + +theorem witnessMaterializedStableCouples_ensureFullChain + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + WitnessMaterializedStableCouples table + (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + apply (witnessMaterializedStableCouples_sequenceFin + (fun step : ChainStep => + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step))) + (fun step => witnessMaterializedStableCouples_ensureCoordinate table + (.position (.chain lay tree leafIdx chainIdx step)))).bind + intro _ + exact witnessMaterializedStableCouples_pure table () + +theorem witnessMaterializedStableCouples_ensureOtsLeaf + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + WitnessMaterializedStableCouples table (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + apply (witnessMaterializedStableCouples_sequenceFin + (fun chainIdx : ChainIndex => ensureFullChain lay tree leafIdx chainIdx) + (fun chainIdx => witnessMaterializedStableCouples_ensureFullChain table lay tree leafIdx + chainIdx)).bind + intro _ + exact witnessMaterializedStableCouples_ensureCoordinate table + (.position (.leaf lay tree leafIdx)) + +theorem witnessMaterializedStableCouples_ensureTreeNode + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, + WitnessMaterializedStableCouples table (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => + witnessMaterializedStableCouples_ensureOtsLeaf table lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + apply (witnessMaterializedStableCouples_ensureTreeNode table lay tree level + (2 * nodeIdx)).bind + intro _ + apply (witnessMaterializedStableCouples_ensureTreeNode table lay tree level + (2 * nodeIdx + 1)).bind + intro _ + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact witnessMaterializedStableCouples_ensureCoordinate table + (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact witnessMaterializedStableCouples_pure table () + +theorem witnessMaterializedStableCouples_maskedTreeNode + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) : + WitnessMaterializedStableCouples table (maskedTreeNode lay tree level nodeIdx) := by + unfold maskedTreeNode + apply (witnessMaterializedStableCouples_ensureTreeNode table lay tree level nodeIdx).bind + intro _ + cases level with + | zero => + exact witnessMaterializedStableCouples_revealPosition table + (.leaf lay tree (leafOfNat nodeIdx)) + | succ current => + by_cases hlevel : current < maxLayerHeight + · simp only [hlevel, ↓reduceDIte] + exact witnessMaterializedStableCouples_revealPosition table + (.node lay tree ⟨current, hlevel⟩ (leafOfNat nodeIdx)) + · simp only [hlevel, ↓reduceDIte] + exact witnessMaterializedStableCouples_pure table 0 + +theorem witnessMaterializedStableCouples_maskedTreeRoot + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + WitnessMaterializedStableCouples table (maskedTreeRoot lay tree) := by + unfold maskedTreeRoot + exact witnessMaterializedStableCouples_maskedTreeNode table lay tree (layerHeight lay) 0 + +theorem witnessMaterializedStableCouples_ensureChainPrefix + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + WitnessMaterializedStableCouples table + (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + apply (witnessMaterializedStableCouples_sequenceFin + (fun step : ChainStep => + if step.val < digit.val then + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + else pure ()) + (fun step => by + by_cases hstep : step.val < digit.val + · rw [if_pos hstep] + exact witnessMaterializedStableCouples_ensureCoordinate table + (.position (.chain lay tree leafIdx chainIdx step)) + · rw [if_neg hstep] + exact witnessMaterializedStableCouples_pure table ())).bind + intro _ + exact witnessMaterializedStableCouples_pure table () + +theorem witnessMaterializedStableCouples_ensureTreePath + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + WitnessMaterializedStableCouples table (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + apply (witnessMaterializedStableCouples_sequenceFin + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + ensureTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + else pure ()) + (fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + exact witnessMaterializedStableCouples_ensureTreeNode table lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · rw [if_neg hlevel] + exact witnessMaterializedStableCouples_pure table ())).bind + intro _ + exact witnessMaterializedStableCouples_pure table () + +theorem witnessMaterializedStableCouples_maskedOtsSignFrom + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter, + WitnessMaterializedStableCouples table + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom] + exact witnessMaterializedStableCouples_pure table none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + have hencoded := witnessMaterializedStableCouples_simulateQ ordinaryHashImpl + (witnessMaterializedStableCouples_ordinaryHashImpl table) + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter)) + apply hencoded.bind + intro encoded + cases encoded with + | none => + exact witnessMaterializedStableCouples_maskedOtsSignFrom table parameter lay tree + leafIdx message attempts (counter + 1) + | some encoding => + apply (witnessMaterializedStableCouples_sequenceFin + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx + (encoding chainIdx)) + (fun chainIdx => witnessMaterializedStableCouples_ensureChainPrefix table lay tree + leafIdx chainIdx (encoding chainIdx))).bind + intro _ + exact witnessMaterializedStableCouples_pure table + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem witnessMaterializedStableCouples_maskedOtsSign + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + WitnessMaterializedStableCouples table + (maskedOtsSign parameter lay tree leafIdx message) := + witnessMaterializedStableCouples_maskedOtsSignFrom table parameter lay tree leafIdx message + encodingAttemptLimit 0 + +theorem witnessMaterializedStableCouples_maskedLayerMessage + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + WitnessMaterializedStableCouples table + (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + by_cases hbelow : lay.val + 1 < numLayers + · rw [dif_pos hbelow] + exact witnessMaterializedStableCouples_maskedTreeRoot table ⟨lay.val + 1, hbelow⟩ + (treeIndexAt index ⟨lay.val + 1, hbelow⟩) + · rw [dif_neg hbelow] + exact witnessMaterializedStableCouples_simulateQ ordinaryHashImpl + (witnessMaterializedStableCouples_ordinaryHashImpl table) + (ftsKey parameter index (ftsSecret index)) + +theorem witnessMaterializedStableCouples_maskedSignLayer + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + WitnessMaterializedStableCouples table + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + apply (witnessMaterializedStableCouples_maskedLayerMessage table parameter ftsSecret index + lay).bind + intro message + apply (witnessMaterializedStableCouples_maskedOtsSign table parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) message).bind + intro selected + cases selected with + | none => exact witnessMaterializedStableCouples_pure table none + | some selected => + apply (witnessMaterializedStableCouples_ensureTreePath table lay + (treeIndexAt index lay) (leafIndexAt index lay)).bind + intro _ + exact witnessMaterializedStableCouples_pure table (some selected) + +set_option maxRecDepth 100000 in +theorem witnessMaterializedStableCouples_revealLayerValues + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + WitnessMaterializedStableCouples table (revealLayerValues index lay encoding) := by + unfold revealLayerValues + apply (witnessMaterializedStableCouples_sequenceFin + (fun chainIdx : ChainIndex => + revealPublishedCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx))) + (fun chainIdx => witnessMaterializedStableCouples_revealPublishedCoordinate table + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx)))).bind + intro values + apply (witnessMaterializedStableCouples_sequenceFin + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + match level.val with + | 0 => revealPublishedCoordinate (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | current + 1 => + if hcurrent : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hcurrent⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0 + else pure 0) + (fun level => by + by_cases hinLayer : level.val < layerHeight lay + · rw [if_pos hinLayer] + cases hvalue : level.val with + | zero => + exact witnessMaterializedStableCouples_revealPublishedCoordinate table + (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | succ current => + have hcurrent : current < maxLayerHeight := by + have := level.isLt + omega + simp only + rw [dif_pos hcurrent] + exact witnessMaterializedStableCouples_revealPublishedCoordinate table + (.position (.node lay (treeIndexAt index lay) ⟨current, hcurrent⟩ + (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + · rw [if_neg hinLayer] + exact witnessMaterializedStableCouples_pure table 0)).bind + intro path + exact witnessMaterializedStableCouples_pure table (values, path) + +set_option maxRecDepth 100000 in +theorem witnessMaterializedStableCouples_maskedSignAfterDigest + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + WitnessMaterializedStableCouples table + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest + apply (witnessMaterializedStableCouples_simulateQ ordinaryHashImpl + (witnessMaterializedStableCouples_ordinaryHashImpl table) + (ftsOpen parameter index leaves (ftsSecret index))).bind + intro ftsPath + apply (witnessMaterializedStableCouples_sequenceFin + (fun lay : Layer => maskedSignLayer parameter ftsSecret index lay) + (fun lay => witnessMaterializedStableCouples_maskedSignLayer table parameter ftsSecret + index lay)).bind + intro layers + cases hparts : traverseOption layers with + | none => exact witnessMaterializedStableCouples_pure table none + | some parts => + apply (witnessMaterializedStableCouples_sequenceFin + (fun lay : Layer => revealLayerValues index lay (parts lay).2) + (fun lay => witnessMaterializedStableCouples_revealLayerValues table index lay + (parts lay).2)).bind + intro revealed + let signature : Signature := + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (revealed lay).1 + authPath := flattenPaths fun lay => (revealed lay).2 } + exact witnessMaterializedStableCouples_pure table (some signature) + +set_option maxRecDepth 100000 in +theorem witnessMaterializedStableCouples_maskedSign + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + WitnessMaterializedStableCouples table + (maskedSign parameter root ftsSecret message) := by + unfold maskedSign + apply (witnessMaterializedStableCouples_simulateQ ordinaryRomImpl + (witnessMaterializedStableCouples_ordinaryRomImpl table) + (signDigestLoop digestAttemptLimit + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ message)).bind + intro selected + cases selected with + | none => exact witnessMaterializedStableCouples_pure table none + | some data => + exact witnessMaterializedStableCouples_maskedSignAfterDigest table parameter ftsSecret + data.1 data.2.1 data.2.2 + +theorem witnessMaterializedStableCouples_maskedSigningImpl + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + WitnessMaterializedStableCouples table + (maskedSigningImpl parameter root ftsSecret message) := + witnessMaterializedStableCouples_maskedSign table parameter root ftsSecret message + +theorem witnessMaterializedStableCouples_maskedPublishedTreeRoot + (table : OtsSecretIndex → HashOutput) : + WitnessMaterializedStableCouples table maskedPublishedTreeRoot := by + unfold maskedPublishedTreeRoot + apply (witnessMaterializedStableCouples_ensureTreeNode table topLayer rootTree + (layerHeight topLayer) 0).bind + intro _ + exact witnessMaterializedStableCouples_revealPublishedCoordinate table + (.position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0)) + +def observationsAfterCandidate + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) : Option Probe → List CleanProbeObservation + | none => observations + | some candidate => + observations ++ [cleanProbeObservation state candidate.coordinate candidate.candidate] + +def projectDirectDetailedObserved + (observations : List CleanProbeObservation) : + DirectDetailedResult (α × SplitHashCache) → + Option (ObservedCleanRunResult (α × SplitHashCache)) + | .stopped _ => none + | .done result => some + ⟨result.context.state, result.remaining, result.value, result.table, observations⟩ + +theorem projectDirectDetailedObserved_eq_attach + (observations : List CleanProbeObservation) + (result : DirectDetailedResult (α × SplitHashCache)) : + projectDirectDetailedObserved observations result = + attachCleanProbeObservations observations (projectDirectDetailedClean result) := by + cases result with + | stopped reason => rfl + | done result => rfl + +theorem probingHashQueryPublicAction_probeFree + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (action : PlannedHashAction) + (cache : SplitHashCache) : + ((probingHashQueryPublicAction parameter input publicState action).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0 := by + cases action with + | ordinary => exact splitHashQuery_probeFree (.ordinary input) cache + | resolve coordinate => + simp only [probingHashQueryPublicAction] + unfold resolvePublicKnownInput + cases hknown : purePeekTableInput parameter publicState coordinate with + | none => exact splitHashQuery_probeFree (.ordinary input) cache + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + exact ((revealCoordinateOutput_probeFree coordinate).bind fun output => + (publishCoordinate_probeFree coordinate).bind fun _ => by + exact (ProbeFree.modify fun workingCache : SplitHashCache => + Function.update workingCache (.ordinary input) (some output)).bind fun _ => + ProbeFree.pure output) cache + · simp only [heq, ↓reduceIte] + exact splitHashQuery_probeFree (.ordinary input) cache + +set_option maxRecDepth 100000 in +theorem map_attach_runClean_rootAwarePublic_eq_observed + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + attachCleanProbeObservations + (observationsAfterCandidate observations state + (rootAwareCandidateForPlan? parameter input plan)) <$> + runCleanFromTable state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) = + runObservedCleanFromTable observations state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) := by + unfold probingHashQueryAfterRootAwarePublicPlan + rw [StateT.run_bind, runCleanFromTable_bind, runObservedCleanFromTable_bind] + cases hcandidate : rootAwareCandidateForPlan? parameter input plan with + | none => + simp only [executeCandidate?, StateT.run_pure, runCleanFromTable, + runObservedCleanFromTable, observationsAfterCandidate] + exact map_attachCleanProbeObservations_runCleanFromTable_of_probeFree + ((probingHashQueryPublicAction parameter input publicState plan.action).run cache) + observations state fuel table + (probingHashQueryPublicAction_probeFree parameter input publicState plan.action cache) + | some candidate => + simp only [executeCandidate?, probe, StateT.run_liftM, LazyRevealProbe.probeQuery, + runCleanFromTable_probe_query_bind, runObservedCleanFromTable_probe_query_bind] + cases fuel with + | zero => simp [attachCleanProbeObservations] + | succ remaining => + by_cases hrevealed : candidate.coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte, observationsAfterCandidate] + exact map_attachCleanProbeObservations_runCleanFromTable_of_probeFree + ((probingHashQueryPublicAction parameter input publicState plan.action).run cache) + (observations ++ + [cleanProbeObservation state candidate.coordinate candidate.candidate]) + state remaining table + (probingHashQueryPublicAction_probeFree parameter input publicState plan.action cache) + · simp only [hrevealed, ↓reduceIte, observationsAfterCandidate] + exact map_attachCleanProbeObservations_runCleanFromTable_of_probeFree + ((probingHashQueryPublicAction parameter input publicState plan.action).run cache) + (observations ++ + [cleanProbeObservation state candidate.coordinate candidate.candidate]) + (state.addPending candidate.coordinate candidate.candidate) remaining table + (probingHashQueryPublicAction_probeFree parameter input publicState plan.action cache) + +set_option maxRecDepth 100000 in +theorem map_projectDirectDetailedObserved_rootAwarePublic + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + projectDirectDetailedObserved + (observationsAfterCandidate observations state + (rootAwareCandidateForPlan? parameter input plan)) <$> + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) = + runObservedCleanFromTable observations state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) := by + calc + _ = attachCleanProbeObservations + (observationsAfterCandidate observations state + (rootAwareCandidateForPlan? parameter input plan)) <$> + (projectDirectDetailedClean <$> + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + cache)) := by + rw [Functor.map_map] + apply map_congr + intro result + exact projectDirectDetailedObserved_eq_attach _ result + _ = attachCleanProbeObservations + (observationsAfterCandidate observations state + (rootAwareCandidateForPlan? parameter input plan)) <$> + runCleanFromTable state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + cache) := by + rw [map_projectDirectDetailedClean_run_eq_clean] + _ = _ := map_attach_runClean_rootAwarePublic_eq_observed parameter input publicState plan + observations state fuel table cache + +def WitnessObservedStepRel + (table : OtsSecretIndex → HashOutput) + (observations : List CleanProbeObservation) + (left : DirectWitnessResult (α × SplitHashCache)) + (right : Option (ObservedCleanRunResult (α × SplitHashCache))) : Prop := + ∃ detailed, + projectDirectDetailedObserved observations detailed = right ∧ + DirectWitnessMaterializedStableRunEq table left detailed + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedWitness_afterPlan_observedMaterialized + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (observations : List CleanProbeObservation) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hpublicState : publicState = left.state) + (hpositive : 0 < leftFuel) (hstrictFuel : leftFuel < rightFuel) + (hcontext : FinalizationContextLE table left right) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache)) + (runObservedCleanFromTable observations right.state rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache)) + (WitnessObservedStepRel table + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan))) := by + have hbase := relTriple_runDirectResolvedWitness_afterPlan_rootAwarePublic table parameter input + publicState plan left right leftFuel rightFuel leftCache rightCache hpublicState hpositive + hstrictFuel hcontext hcache hrevealed hvalues hpublished hrightMaterialized + have hstrength : RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache)) + (fun leftResult rightResult => + WitnessObservedStepRel table + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan)) + leftResult + (projectDirectDetailedObserved + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan)) rightResult)) := by + apply relTriple_post_mono hbase + intro leftResult rightResult hrelation + exact ⟨rightResult, rfl, hrelation⟩ + have hmapped := relTriple_map + (R := fun leftResult rightResult => + WitnessObservedStepRel table + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan)) leftResult rightResult) + (f := id) + (g := projectDirectDetailedObserved + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan))) hstrength + have hpost : RelTriple + (id <$> runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache)) + (projectDirectDetailedObserved + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan)) <$> + runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache)) + (WitnessObservedStepRel table + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan))) := by + exact hmapped + rw [id_map] at hpost + have hmap : + projectDirectDetailedObserved + (observationsAfterCandidate observations right.state + (rootAwareCandidateForPlan? parameter input plan)) <$> + runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache) = + runObservedCleanFromTable observations right.state rightFuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + rightCache) := by + rw [hrightMaterialized] + simpa [directDeferredContext] using + (map_projectDirectDetailedObserved_rootAwarePublic parameter input publicState plan + observations right.state rightFuel table rightCache) + exact relTriple_of_evalDist_eq_right (congrArg evalDist hmap) hpost + +theorem SnapshotsObservedAt.appendCandidate + {table : OtsSecretIndex → HashOutput} + {snapshots : List PlannedProbeSnapshot} + {observations : List CleanProbeObservation} + {left : DeferredContext} {rightState : LazyRevealProbe.State Coordinate} + (haligned : SnapshotsObservedAt table snapshots observations) + (candidate? : Option Probe) + (hcontext : FinalizationContextLE table left (directDeferredContext rightState)) + (hrevealed : left.state.revealed = rightState.revealed) + (hpublished : PublishedValues left.state) + (hcanonical : CanonicalMaterializedValues table left) : + SnapshotsObservedAt table + (appendPlannedSnapshot snapshots candidate? left) + (observationsAfterCandidate observations rightState candidate?) := by + cases candidate? with + | none => exact haligned + | some candidate => + apply haligned.append + exact PlannedProbeSnapshot.observedAt_of_finalizationContextLE table + ⟨candidate, left⟩ rightState hcontext hrevealed hpublished hcanonical + +theorem fuel_le_remaining_add_of_done_runDirectResolvedDetailedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (bound : Nat) + (hbound : computation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) bound) + (hresult : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation)) : + fuel ≤ result.remaining + bound := by + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + computation context fuel table result hresult + have hraw := raw_done_of_mem_runDirectResolvedFromTable computation context fuel table result + hdirect + exact LazyRevealProbe.fuel_le_remaining_add_of_mem_support_runRaw_done + context.state result.context.state fuel result.remaining bound computation result.value hbound + hraw + +theorem fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (bound : Nat) + (hbound : computation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) bound) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) : + fuel ≤ result.remaining + bound := by + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) := by + rw [← map_erase_runDirectResolvedWitnessFromTable computation context fuel table, + support_map] + exact ⟨.done result, hresult, rfl⟩ + exact fuel_le_remaining_add_of_done_runDirectResolvedDetailedFromTable computation context fuel + table result bound hbound hdetailed + +noncomputable def observedMaterializedBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option (ObservedCleanRunResult (α × SplitHashCache))) := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + List CleanProbeObservation → LazyRevealProbe.State Coordinate → Nat → + (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp (Option (ObservedCleanRunResult (α × SplitHashCache)))) + (fun value observations state fuel table cache => + pure (some ⟨state, fuel, (value, cache), table, observations⟩)) + (fun query _next recursivelyRun observations state fuel table cache => + match query with + | .inl (.inl n) => do + let result ← runObservedCleanFromTable observations state fuel table + ((splitUniformImpl n).run cache) + match result with + | none => pure none + | some result => + recursivelyRun result.value.1 result.observations result.state result.remaining + table result.value.2 + | .inl (.inr input) => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + do + let result ← runObservedCleanFromTable observations state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state plan).run + cache) + match result with + | none => pure none + | some result => + recursivelyRun result.value.1 result.observations result.state result.remaining + table result.value.2 + | .inr message => do + let result ← runObservedCleanFromTable observations state fuel table + ((maskedSign parameter root ftsSecret message).run cache) + match result with + | none => pure none + | some result => + recursivelyRun result.value.1 result.observations result.state result.remaining + table result.value.2) + computation observations state fuel table cache + +noncomputable def observedMaterializedRetainedRunFromTable + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))) := do + let rootResult ← runObservedCleanFromTable [] LazyRevealProbe.State.empty fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure none + | some rootResult => do + let restResult ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table + rootResult.value.2 + match restResult with + | none => pure none + | some restResult => + pure (some + { restResult with + value := ((rootResult.value.1, restResult.value.1), restResult.value.2) }) + +noncomputable def finishObservedMaterializedCleanRunFromTable + (table : OtsSecretIndex → HashOutput) + (result : Option (ObservedCleanRunResult α)) : + ProbComp (Option (ObservedCleanRunResult α)) := by + classical + exact match result with + | none => pure none + | some result => + if DeferredCompletable table (directDeferredContext result.state) then + finishObservedCleanRunFromTable (some result) + else + pure none + +noncomputable def sampledObservedMaterializedClean + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp (Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))) := do + let table ← sampleOtsHashTable + let result ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table + finishObservedMaterializedCleanRunFromTable table result + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalProbability.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalProbability.lean new file mode 100644 index 00000000..c42108d3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalProbability.lean @@ -0,0 +1,1957 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSample + +/-! +# Materialized comparison probability + +The observation log is proof-only. This file first erases it from the standalone materialized +comparison, leaving the clean state, value, table and remaining probe fuel unchanged. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option linter.constructorNameAsVariable false + +noncomputable def materializedCleanBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option (CleanRunResult (α × SplitHashCache))) := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + LazyRevealProbe.State Coordinate → Nat → + (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp (Option (CleanRunResult (α × SplitHashCache)))) + (fun value state fuel table cache => + pure (some ⟨state, fuel, (value, cache), table⟩)) + (fun query _next recursivelyRun state fuel table cache => + match query with + | .inl (.inl n) => do + let result ← runCleanFromTable state fuel table ((splitUniformImpl n).run cache) + match result with + | none => pure none + | some result => + recursivelyRun result.value.1 result.state result.remaining table result.value.2 + | .inl (.inr input) => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + do + let result ← runCleanFromTable state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state plan).run + cache) + match result with + | none => pure none + | some result => + recursivelyRun result.value.1 result.state result.remaining table result.value.2 + | .inr message => do + let result ← runCleanFromTable state fuel table + ((maskedSign parameter root ftsSecret message).run cache) + match result with + | none => pure none + | some result => + recursivelyRun result.value.1 result.state result.remaining table result.value.2) + computation state fuel table cache + +set_option maxRecDepth 100000 in +theorem map_projectObservedCleanRun_observedMaterializedBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + projectObservedCleanRun <$> + observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache = + materializedCleanBoundary parameter root ftsSecret computation state fuel table cache := by + induction computation using OracleComp.inductionOn generalizing observations state fuel cache with + | pure value => + simp [observedMaterializedBoundary, materializedCleanBoundary, projectObservedCleanRun, + ObservedCleanRunResult.toClean] + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind, + materializedCleanBoundary, OracleComp.construct_query_bind] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [map_bind] + calc + _ = runObservedCleanFromTable observations state fuel table + ((splitUniformImpl n).run cache) >>= fun result => + projectObservedCleanRun <$> match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state + result.remaining table result.value.2 := by rfl + _ = runObservedCleanFromTable observations state fuel table + ((splitUniformImpl n).run cache) >>= fun result => + match result with + | none => pure none + | some result => + materializedCleanBoundary parameter root ftsSecret + (next result.value.1) result.state result.remaining table + result.value.2 := by + apply bind_congr + intro result + cases result with + | none => simp [projectObservedCleanRun] + | some result => + simpa using (ih result.value.1 result.observations result.state + result.remaining result.value.2) + _ = (projectObservedCleanRun <$> + runObservedCleanFromTable observations state fuel table + ((splitUniformImpl n).run cache)) >>= fun result => + match result with + | none => pure none + | some result => + materializedCleanBoundary parameter root ftsSecret + (next result.value.1) result.state result.remaining table + result.value.2 := by + rw [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro result + cases result <;> rfl + _ = _ := by + rw [map_projectObservedCleanRun_runObservedCleanFromTable] + rfl + | inr input => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + rw [map_bind] + calc + _ = runObservedCleanFromTable observations state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input + publicContext.state plan).run cache) >>= fun result => + projectObservedCleanRun <$> match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state + result.remaining table result.value.2 := by rfl + _ = runObservedCleanFromTable observations state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input + publicContext.state plan).run cache) >>= fun result => + match result with + | none => pure none + | some result => + materializedCleanBoundary parameter root ftsSecret + (next result.value.1) result.state result.remaining table + result.value.2 := by + apply bind_congr + intro result + cases result with + | none => simp [projectObservedCleanRun] + | some result => + simpa using (ih result.value.1 result.observations result.state + result.remaining result.value.2) + _ = (projectObservedCleanRun <$> + runObservedCleanFromTable observations state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input + publicContext.state plan).run cache)) >>= fun result => + match result with + | none => pure none + | some result => + materializedCleanBoundary parameter root ftsSecret + (next result.value.1) result.state result.remaining table + result.value.2 := by + rw [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro result + cases result <;> rfl + _ = _ := by + rw [map_projectObservedCleanRun_runObservedCleanFromTable] + rfl + | inr message => + rw [map_bind] + calc + _ = runObservedCleanFromTable observations state fuel table + ((maskedSign parameter root ftsSecret message).run cache) >>= fun result => + projectObservedCleanRun <$> match result with + | none => pure none + | some result => + observedMaterializedBoundary parameter root ftsSecret + (next result.value.1) result.observations result.state result.remaining + table result.value.2 := by rfl + _ = runObservedCleanFromTable observations state fuel table + ((maskedSign parameter root ftsSecret message).run cache) >>= fun result => + match result with + | none => pure none + | some result => + materializedCleanBoundary parameter root ftsSecret + (next result.value.1) result.state result.remaining table result.value.2 := by + apply bind_congr + intro result + cases result with + | none => simp [projectObservedCleanRun] + | some result => + simpa using (ih result.value.1 result.observations result.state + result.remaining result.value.2) + _ = (projectObservedCleanRun <$> + runObservedCleanFromTable observations state fuel table + ((maskedSign parameter root ftsSecret message).run cache)) >>= fun result => + match result with + | none => pure none + | some result => + materializedCleanBoundary parameter root ftsSecret + (next result.value.1) result.state result.remaining table result.value.2 := by + rw [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro result + cases result <;> rfl + _ = _ := by + rw [map_projectObservedCleanRun_runObservedCleanFromTable] + rfl + +theorem materializedCanonicalContext_values_eq_of_probeStateLE + (table : OtsSecretIndex → HashOutput) + {left right : LazyRevealProbe.State Coordinate} + (hstate : ProbeStateLE left right) : + (materializedCanonicalContext table left).state.values = + (materializedCanonicalContext table right).state.values := by + change publicMaterializedValues table (directDeferredContext left) = + publicMaterializedValues table (directDeferredContext right) + funext coordinate + unfold publicMaterializedValues + have hrevealed : coordinate ∈ left.revealed ↔ coordinate ∈ right.revealed := + hstate.revealed_iff coordinate + by_cases hleftRevealed : coordinate ∈ left.revealed + · have hrightRevealed : coordinate ∈ right.revealed := hrevealed.mp hleftRevealed + simp only [directDeferredContext, hleftRevealed, hrightRevealed, ↓reduceIte] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => simp [resolvedCompletionValue] + | position position => + simp [resolvedCompletionValue, DeferredContext.positionValue, directDeferredValues, + hstate.values] + · have hrightRevealed : coordinate ∉ right.revealed := by + simpa [hrevealed] using hleftRevealed + simp [directDeferredContext, hleftRevealed, hrightRevealed] + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_materializedCleanBoundary_probeLE + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (leftState rightState : LazyRevealProbe.State Coordinate) + (leftFuel rightFuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hstate : ProbeStateLE leftState rightState) + (hfuel : rightFuel ≤ leftFuel) (hcache : leftCache = rightCache) : + RelTriple + (materializedCleanBoundary parameter root ftsSecret computation leftState leftFuel table + leftCache) + (materializedCleanBoundary parameter root ftsSecret computation rightState rightFuel table + rightCache) + CleanRunProbeLE := by + induction computation using OracleComp.inductionOn generalizing leftState rightState leftFuel + rightFuel leftCache rightCache with + | pure value => + subst rightCache + simp [materializedCleanBoundary, CleanRunProbeLE, hstate, hfuel] + | query_bind query next ih => + rw [materializedCleanBoundary, OracleComp.construct_query_bind, + materializedCleanBoundary, OracleComp.construct_query_bind] + have continueAfter + (leftRun rightRun : ProbComp (Option (CleanRunResult + ((OracleWorld + SigningSpec).Range query × SplitHashCache)))) + (hrun : RelTriple leftRun rightRun CleanRunProbeLE) : + RelTriple + (leftRun >>= fun result => + match result with + | none => pure none + | some result => + materializedCleanBoundary parameter root ftsSecret + (next result.value.1) result.state result.remaining table result.value.2) + (rightRun >>= fun result => + match result with + | none => pure none + | some result => + materializedCleanBoundary parameter root ftsSecret + (next result.value.1) result.state result.remaining table result.value.2) + CleanRunProbeLE := by + apply relTriple_bind hrun + intro leftResult rightResult hresult + cases rightResult with + | none => exact relTriple_any_pure_none_clean _ + | some rightResult => + cases leftResult with + | none => simp [CleanRunProbeLE] at hresult + | some leftResult => + simp only + rcases hresult with ⟨hvalue, htable, hremaining, hnextState⟩ + have houtput : leftResult.value.1 = rightResult.value.1 := + congrArg Prod.fst hvalue + have hnextCache : leftResult.value.2 = rightResult.value.2 := + congrArg Prod.snd hvalue + rw [← houtput, ← hnextCache] + exact ih leftResult.value.1 leftResult.state rightResult.state + leftResult.remaining rightResult.remaining leftResult.value.2 + leftResult.value.2 hnextState hremaining rfl + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + change Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α at next + simp only + subst rightCache + have hstep := relTriple_runCleanFromTable_probeStateLE + ((splitUniformImpl n).run leftCache) leftState rightState leftFuel rightFuel + table hstate hfuel + convert (continueAfter _ _ hstep) using 1 <;> rfl + | inr input => + change HashOutput → OracleComp (OracleWorld + SigningSpec) α at next + simp only + let leftPublic := materializedCanonicalContext table leftState + let rightPublic := materializedCanonicalContext table rightState + have hpublicValues : leftPublic.state.values = rightPublic.state.values := + materializedCanonicalContext_values_eq_of_probeStateLE table hstate + have hplan : purePlanProbingHashQuery parameter input leftPublic.state = + purePlanProbingHashQuery parameter input rightPublic.state := + purePlanProbingHashQuery_eq_of_values_eq hpublicValues parameter input + let plan := purePlanProbingHashQuery parameter input leftPublic.state + have hexecutor : + probingHashQueryAfterRootAwarePublicPlan parameter input leftPublic.state plan = + probingHashQueryAfterRootAwarePublicPlan parameter input rightPublic.state + plan := + probingHashQueryAfterRootAwarePublicPlan_eq_of_values_eq parameter input + hpublicValues plan + rw [← hplan] + subst rightCache + rw [← hexecutor] + have hstep := relTriple_runCleanFromTable_probeStateLE + ((probingHashQueryAfterRootAwarePublicPlan parameter input leftPublic.state + plan).run leftCache) + leftState rightState leftFuel rightFuel table hstate hfuel + convert (continueAfter _ _ hstep) using 1 <;> + simp only [leftPublic, plan, materializedCleanBoundary] <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + | inr message => + change Option Signature → OracleComp (OracleWorld + SigningSpec) α at next + simp only + subst rightCache + have hstep := relTriple_runCleanFromTable_probeStateLE + ((maskedSign parameter root ftsSecret message).run leftCache) + leftState rightState leftFuel rightFuel table hstate hfuel + convert (continueAfter _ _ hstep) using 1 <;> + simp only [materializedCleanBoundary] <;> + apply bind_congr <;> intro result <;> cases result <;> rfl + +noncomputable def materializedCleanRetainedRunFromTable + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (Option (CleanRunResult (RetainedGameResult × SplitHashCache))) := do + let rootResult ← runCleanFromTable LazyRevealProbe.State.empty fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure none + | some rootResult => do + let restResult ← materializedCleanBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.state rootResult.remaining table rootResult.value.2 + match restResult with + | none => pure none + | some restResult => + pure (some + { restResult with + value := ((rootResult.value.1, restResult.value.1), restResult.value.2) }) + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_materializedCleanRetainedRunFromTable_probeLE + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (leftFuel rightFuel : Nat) (table : OtsSecretIndex → HashOutput) + (hfuel : rightFuel ≤ leftFuel) : + RelTriple + (materializedCleanRetainedRunFromTable adversary parameter ftsSecret leftFuel table) + (materializedCleanRetainedRunFromTable adversary parameter ftsSecret rightFuel table) + CleanRunProbeLE := by + unfold materializedCleanRetainedRunFromTable + have hroot := relTriple_runCleanFromTable_probeStateLE + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + LazyRevealProbe.State.empty leftFuel rightFuel table (ProbeStateLE.refl _) hfuel + apply relTriple_bind hroot + intro leftRoot rightRoot hrootResult + cases rightRoot with + | none => exact relTriple_any_pure_none_clean _ + | some rightRoot => + cases leftRoot with + | none => simp [CleanRunProbeLE] at hrootResult + | some leftRoot => + simp only + rcases hrootResult with ⟨hvalue, htable, hremaining, hstate⟩ + have hrootValue : leftRoot.value.1 = rightRoot.value.1 := + congrArg Prod.fst hvalue + have hcache : leftRoot.value.2 = rightRoot.value.2 := + congrArg Prod.snd hvalue + rw [← hrootValue, ← hcache] + have hrest := relTriple_materializedCleanBoundary_probeLE parameter + leftRoot.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨leftRoot.value.1, parameter⟩) + leftRoot.state rightRoot.state leftRoot.remaining rightRoot.remaining table + leftRoot.value.2 leftRoot.value.2 hstate hremaining rfl + apply relTriple_bind hrest + intro leftRest rightRest hrestResult + cases rightRest with + | none => exact relTriple_any_pure_none_clean _ + | some rightRest => + cases leftRest with + | none => simp [CleanRunProbeLE] at hrestResult + | some leftRest => + rcases hrestResult with ⟨hrestValue, hrestTable, hrestRemaining, + hrestState⟩ + exact relTriple_pure_pure ⟨by + rw [hrestValue], hrestTable, hrestRemaining, hrestState⟩ + +noncomputable def finishMaterializedCleanRunFromTable + (table : OtsSecretIndex → HashOutput) + (result : Option (CleanRunResult α)) : + ProbComp (Option (CleanRunResult α)) := by + classical + exact match result with + | none => pure none + | some result => + if DeferredCompletable table (directDeferredContext result.state) then + finishCleanRunFromTable (some result) + else + pure none + +theorem deferredCompletable_direct_of_probeStateLE + (table : OtsSecretIndex → HashOutput) + {left right : LazyRevealProbe.State Coordinate} + (hstate : ProbeStateLE left right) + (hcompletable : DeferredCompletable table (directDeferredContext right)) : + DeferredCompletable table (directDeferredContext left) := by + obtain ⟨completion, hvalues, hprivate, hpending, htable⟩ := hcompletable + refine ⟨completion, ?_, ?_, ?_, htable⟩ + · intro coordinate output hvalue + apply hvalues coordinate output + simpa [directDeferredContext, hstate.values] using hvalue + · intro position output hvalue + apply hprivate position output + simpa [directDeferredContext, directDeferredValues, hstate.values] using hvalue + · intro coordinate candidate hpendingLeft + exact hpending coordinate candidate (hstate.pending hpendingLeft) + +theorem relTriple_finishMaterializedCleanRunFromTable_probeLE + (table : OtsSecretIndex → HashOutput) + (left right : Option (CleanRunResult α)) + (hrelation : CleanRunProbeLE left right) : + RelTriple + (finishMaterializedCleanRunFromTable table left) + (finishMaterializedCleanRunFromTable table right) + CleanFinishFailureLE := by + classical + cases right with + | none => exact relTriple_cleanFinish_any_pure_none _ + | some rightResult => + cases left with + | none => simp [CleanRunProbeLE] at hrelation + | some leftResult => + rcases hrelation with ⟨hvalue, htable, hremaining, hstate⟩ + by_cases hleftCompletable : + DeferredCompletable table (directDeferredContext leftResult.state) + · by_cases hrightCompletable : + DeferredCompletable table (directDeferredContext rightResult.state) + · simp only [finishMaterializedCleanRunFromTable, hleftCompletable, + hrightCompletable, ↓reduceIte] + exact relTriple_finishCleanRunFromTable_probeLE (some leftResult) + (some rightResult) ⟨hvalue, htable, hremaining, hstate⟩ + · simp only [finishMaterializedCleanRunFromTable, hleftCompletable, + hrightCompletable, ↓reduceIte] + exact relTriple_cleanFinish_any_pure_none _ + · have hrightNotCompletable : + ¬DeferredCompletable table (directDeferredContext rightResult.state) := by + intro hrightCompletable + exact hleftCompletable + (deferredCompletable_direct_of_probeStateLE table hstate hrightCompletable) + simp [finishMaterializedCleanRunFromTable, hleftCompletable, + hrightNotCompletable, CleanFinishFailureLE] + +noncomputable def sampledMaterializedClean + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp (Option (CleanRunResult (RetainedGameResult × SplitHashCache))) := do + let table ← sampleOtsHashTable + let result ← materializedCleanRetainedRunFromTable adversary parameter ftsSecret fuel table + finishMaterializedCleanRunFromTable table result + +set_option maxRecDepth 100000 in +theorem relTriple_sampledMaterializedClean_fuelLE + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (leftFuel rightFuel : Nat) (hfuel : rightFuel ≤ leftFuel) : + RelTriple + (sampledMaterializedClean adversary parameter ftsSecret leftFuel) + (sampledMaterializedClean adversary parameter ftsSecret rightFuel) + CleanFinishFailureLE := by + unfold sampledMaterializedClean + apply relTriple_bind (relTriple_refl sampleOtsHashTable) + intro leftTable rightTable htable + subst rightTable + apply relTriple_bind + (relTriple_materializedCleanRetainedRunFromTable_probeLE adversary parameter ftsSecret + leftFuel rightFuel leftTable hfuel) + intro leftResult rightResult hresult + exact relTriple_finishMaterializedCleanRunFromTable_probeLE leftTable leftResult rightResult + hresult + +theorem probEvent_sampledMaterializedClean_none_fuel_mono + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (leftFuel rightFuel : Nat) (hfuel : rightFuel ≤ leftFuel) : + Pr[= none | sampledMaterializedClean adversary parameter ftsSecret leftFuel] ≤ + Pr[= none | sampledMaterializedClean adversary parameter ftsSecret rightFuel] := by + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput] + apply probEvent_le_of_relTriple + (relTriple_sampledMaterializedClean_fuelLE adversary parameter ftsSecret leftFuel rightFuel + hfuel) + intro left right hrelation hleft + exact hrelation hleft + +def canonicalPublicProbeState (state : LazyRevealProbe.State Coordinate) : + LazyRevealProbe.State Coordinate := + { state with + values := fun coordinate => + if coordinate ∈ state.revealed then state.values coordinate else none } + +theorem canonicalPublicProbeState_eq_materializedCanonicalContext_state + (table : OtsSecretIndex → HashOutput) + (state : LazyRevealProbe.State Coordinate) + (hstarts : StartTableAgrees state table) + (hpublished : PublishedValues state) : + canonicalPublicProbeState state = + (materializedCanonicalContext table state).state := by + cases state with + | mk pending values revealed ensured => + unfold canonicalPublicProbeState materializedCanonicalContext + canonicalizeMaterializedValues + rw [LazyRevealProbe.State.mk.injEq] + refine ⟨rfl, ?_, rfl, rfl⟩ + funext coordinate + unfold publicMaterializedValues + by_cases hrevealed : coordinate ∈ revealed + · simp only [hrevealed, ↓reduceIte, directDeferredContext] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + cases hvalue : values (.chainStart lay tree leafIdx chainIdx) with + | none => exact False.elim (hpublished _ hrevealed hvalue) + | some output => + have heq := hstarts ⟨lay, tree, leafIdx, chainIdx⟩ output hvalue + simp [resolvedCompletionValue, heq] + | position position => + cases hvalue : values (.position position) with + | none => exact False.elim (hpublished _ hrevealed hvalue) + | some output => + simp [resolvedCompletionValue, DeferredContext.positionValue, hvalue] + · simp [hrevealed, directDeferredContext] + +noncomputable def finishCleanFailureObserve + (observe : (OtsSecretIndex → HashOutput) → + LazyRevealProbe.State Coordinate → Nat → α → ProbComp Bool) : + Option (CleanRunResult α) → ProbComp Bool + | none => pure true + | some result => observe result.table result.state result.remaining result.value + +set_option maxRecDepth 100000 in +theorem evalDist_runDirectDetailedSafeOrdinary_eq_cleanFailureObserve + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observe : (OtsSecretIndex → HashOutput) → + LazyRevealProbe.State Coordinate → Nat → α → ProbComp Bool) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe fuel) : + 𝒟[runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + computation >>= + finishDirectDetailedSafeOrdinaryObserve + (fun nextTable context remaining value => + observe nextTable context.state remaining value)] = + 𝒟[runCleanFromTable state fuel table computation >>= + finishCleanFailureObserve observe] := by + let detailed := runDirectResolvedDetailedFromTable + (directDeferredContext state) fuel table computation + calc + _ = 𝒟[(projectDirectDetailedClean <$> detailed) >>= + finishCleanFailureObserve observe] := by + rw [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro result hresult + simp only [Function.comp_apply, pure_bind] + have hshape := directDetailedMaterialized_of_mem_runDirectResolvedDetailedFromTable + computation state fuel table result hresult + cases result with + | stopped reason => + cases reason with + | ordinaryHit => rfl + | privateStructuralHit => exact False.elim hshape + | fuelExhausted => + exact False.elim + (fuelExhausted_not_mem_support_runDirectResolvedDetailedFromTable + computation (directDeferredContext state) fuel table hbound hresult) + | done result => + simp [finishDirectDetailedSafeOrdinaryObserve, finishCleanFailureObserve, + projectDirectDetailedClean, DirectDetailedResult.toOption, + projectResolvedRunResult] + _ = _ := by + rw [map_projectDirectDetailedClean_run_eq_clean] + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem evalDist_runDirectDetailedSafeOrdinary_eq_sampledCleanFailureObserve + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observe : (OtsSecretIndex → HashOutput) → + LazyRevealProbe.State Coordinate → Nat → α → ProbComp Bool) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe fuel) : + 𝒟[runDirectDetailedSafeOrdinaryWithCompletionTable + (fun nextTable context remaining value => + observe nextTable context.state remaining value) + (directDeferredContext state) fuel computation] = + 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable state base + let result ← runCleanFromTable state fuel table computation + finishCleanFailureObserve observe result] := by + calc + _ = 𝒟[(do + let base ← sampleOtsHashTable + let table := completedStartTable state base + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + computation) >>= + finishDirectDetailedSafeOrdinaryObserve + (fun nextTable context remaining value => + observe nextTable context.state remaining value)] := + (evalDist_sampled_runDirectDetailedSafeOrdinary_eq_completionTable computation + (fun nextTable context remaining value => + observe nextTable context.state remaining value) + (directDeferredContext state) fuel).symm + _ = _ := by + rw [bind_assoc, evalDist_bind, evalDist_bind] + apply congrArg + funext base + exact evalDist_runDirectDetailedSafeOrdinary_eq_cleanFailureObserve computation observe + state fuel (completedStartTable state base) hbound + +set_option maxRecDepth 100000 in +theorem fuel_le_remaining_add_of_mem_runCleanFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : CleanRunResult α) + (bound : Nat) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hresult : some result ∈ support + (runCleanFromTable state fuel table computation)) : + fuel ≤ result.remaining + bound := by + rw [← map_projectDirectDetailedClean_run_eq_clean computation state fuel table, + support_map] at hresult + obtain ⟨detailed, hdetailed, hproject⟩ := hresult + cases detailed with + | stopped reason => + simp [projectDirectDetailedClean, DirectDetailedResult.toOption, + projectResolvedRunResult] at hproject + | done detailed => + have heq : result = + ⟨detailed.context.state, detailed.remaining, detailed.value, detailed.table⟩ := + Option.some.inj (by simpa [projectDirectDetailedClean, + DirectDetailedResult.toOption, projectResolvedRunResult] using hproject.symm) + rw [heq] + exact fuel_le_remaining_add_of_done_runDirectResolvedDetailedFromTable computation + (directDeferredContext state) fuel table detailed bound hbound hdetailed + +set_option maxRecDepth 100000 in +theorem publishedValues_of_mem_runCleanFromTable + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (result : CleanRunResult (α × SplitHashCache)) + (hpublished : PublishedValues state) + (hpreserves : PreservesPublishedValues computation) + (hresult : some result ∈ support + (runCleanFromTable state fuel table (computation.run cache))) : + PublishedValues result.state := by + rw [← map_projectDirectDetailedClean_run_eq_clean (computation.run cache) state fuel table, + support_map] at hresult + obtain ⟨detailed, hdetailed, hproject⟩ := hresult + cases detailed with + | stopped reason => + simp [projectDirectDetailedClean, DirectDetailedResult.toOption, + projectResolvedRunResult] at hproject + | done detailed => + have heq : result = + ⟨detailed.context.state, detailed.remaining, detailed.value, detailed.table⟩ := + Option.some.inj (by simpa [projectDirectDetailedClean, + DirectDetailedResult.toOption, projectResolvedRunResult] using hproject.symm) + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + (computation.run cache) (directDeferredContext state) fuel table detailed hdetailed + have hraw := raw_done_of_mem_runDirectResolvedFromTable + (computation.run cache) (directDeferredContext state) fuel table detailed hdirect + rw [heq] + exact hpreserves state cache fuel detailed.context.state detailed.remaining + detailed.value.1 detailed.value.2 hpublished hraw + +noncomputable def materializedCleanBoundaryFailureFromTable + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : ProbComp Bool := do + let result ← materializedCleanBoundary parameter root ftsSecret computation state fuel table + cache + let final ← finishCleanRunFromTable result + pure final.isNone + +noncomputable def sampledMaterializedCleanBoundaryFailure + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) : ProbComp Bool := do + let base ← sampleOtsHashTable + materializedCleanBoundaryFailureFromTable parameter root ftsSecret computation state fuel + (completedStartTable state base) cache + +theorem materializedCleanBoundaryFailureFromTable_uniform_query_bind + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (n : Nat) (next : Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hstarts : StartTableAgrees state table) : + 𝒟[materializedCleanBoundaryFailureFromTable parameter root ftsSecret + ((liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (.inl (.inl n)))) >>= next) state fuel table cache] = 𝒟[do + let result ← runCleanFromTable state fuel table ((splitUniformImpl n).run cache) + finishCleanFailureObserve + (fun nextTable nextState remaining value => + materializedCleanBoundaryFailureFromTable parameter root ftsSecret + (next (value : Fin (n + 1) × SplitHashCache).1) nextState remaining nextTable + value.2) + result] := by + rw [materializedCleanBoundaryFailureFromTable, materializedCleanBoundary, + OracleComp.construct_query_bind] + simp only [bind_assoc] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have htable := (startTableAgrees_of_mem_runCleanFromTable + ((splitUniformImpl n).run cache) state fuel table hstarts result hresult).1 + simp [finishCleanFailureObserve, materializedCleanBoundaryFailureFromTable, + materializedCleanBoundary, htable] + +theorem materializedCleanBoundaryFailureFromTable_hash_query_bind + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hstarts : StartTableAgrees state table) (hpublished : PublishedValues state) : + let publicState := canonicalPublicProbeState state + let plan := purePlanProbingHashQuery parameter input publicState + 𝒟[materializedCleanBoundaryFailureFromTable parameter root ftsSecret + ((liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (.inl (.inr input)))) >>= next) state fuel table cache] = 𝒟[do + let result ← runCleanFromTable state fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) + finishCleanFailureObserve + (fun nextTable nextState remaining value => + materializedCleanBoundaryFailureFromTable parameter root ftsSecret + (next (value : HashOutput × SplitHashCache).1) nextState remaining nextTable + value.2) + result] := by + dsimp only + have hpublic := canonicalPublicProbeState_eq_materializedCanonicalContext_state table state + hstarts hpublished + rw [materializedCleanBoundaryFailureFromTable, materializedCleanBoundary, + OracleComp.construct_query_bind] + simp only + rw [← hpublic] + simp only [bind_assoc] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have htable := (startTableAgrees_of_mem_runCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input + (canonicalPublicProbeState state) + (purePlanProbingHashQuery parameter input (canonicalPublicProbeState state))).run cache) + state fuel table hstarts result hresult).1 + simp [finishCleanFailureObserve, materializedCleanBoundaryFailureFromTable, + materializedCleanBoundary, htable] + +theorem materializedCleanBoundaryFailureFromTable_sign_query_bind + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (message : SignRequest) + (next : Option Signature → OracleComp (OracleWorld + SigningSpec) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hstarts : StartTableAgrees state table) : + 𝒟[materializedCleanBoundaryFailureFromTable parameter root ftsSecret + ((liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (.inr message))) >>= next) state fuel table cache] = 𝒟[do + let result ← runCleanFromTable state fuel table + ((maskedSign parameter root ftsSecret message).run cache) + finishCleanFailureObserve + (fun nextTable nextState remaining value => + materializedCleanBoundaryFailureFromTable parameter root ftsSecret + (next (value : Option Signature × SplitHashCache).1) nextState remaining nextTable + value.2) + result] := by + rw [materializedCleanBoundaryFailureFromTable, materializedCleanBoundary, + OracleComp.construct_query_bind] + simp only [bind_assoc] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have htable := (startTableAgrees_of_mem_runCleanFromTable + ((maskedSign parameter root ftsSecret message).run cache) + state fuel table hstarts result hresult).1 + simp [finishCleanFailureObserve, materializedCleanBoundaryFailureFromTable, + materializedCleanBoundary, htable] + +theorem preservesPublishedValues_resolvePublicKnownInput + (parameter : PublicParameter) (publicState : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) (input : HashInput) : + PreservesPublishedValues + (resolvePublicKnownInput parameter publicState coordinate input) := by + unfold resolvePublicKnownInput + cases hknown : purePeekTableInput parameter publicState coordinate with + | none => + exact PreservesPublishedValues.of_preservesCoordinate fun other => + preservesCoordinate_splitHashQuery other (.ordinary input) + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + have hpreserves := + (preservesPublishedValues_revealCoordinateOutput_publish coordinate).bind + fun output => + (PreservesPublishedValues.of_preservesCoordinate fun other => + preservesCoordinate_modify other fun cache => + Function.update cache (.ordinary input) (some output)).bind fun _ => + PreservesPublishedValues.pure output + simpa only [bind_assoc, pure_bind] using hpreserves + · simp only [heq, ↓reduceIte] + exact PreservesPublishedValues.of_preservesCoordinate fun other => + preservesCoordinate_splitHashQuery other (.ordinary input) + +theorem preservesPublishedValues_probingHashQueryAfterRootAwarePublicPlan + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) : + PreservesPublishedValues + (probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan) := by + unfold probingHashQueryAfterRootAwarePublicPlan + apply (preservesPublishedValues_executeCandidate + (rootAwareCandidateForPlan? parameter input plan)).bind + intro _ + cases plan.action with + | ordinary => exact preservesPublishedValues_splitHashQuery_ordinary input + | resolve coordinate => + exact preservesPublishedValues_resolvePublicKnownInput parameter publicState coordinate input + +noncomputable def guardedMaterializedCleanContinuation + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (next : β → OracleComp (OracleWorld + SigningSpec) α) + (bound : Nat) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (fuel : Nat) + (value : β × SplitHashCache) : ProbComp Bool := by + classical + exact if PublishedValues context.state ∧ bound ≤ fuel then + materializedCleanBoundaryFailureFromTable parameter root ftsSecret (next value.1) + context.state fuel table value.2 + else + pure false + +set_option maxRecDepth 100000 in +theorem evalDist_sampledCleanStep_eq_safeGuardedContinuation + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (next : β → OracleComp (OracleWorld + SigningSpec) α) + (inner : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) (stepBound nextBound : Nat) + (hpublished : PublishedValues state) + (hinnerBound : (inner.run cache).IsQueryBoundP LazyRevealProbe.IsProbe stepBound) + (hpreserves : PreservesPublishedValues inner) + (hbudget : nextBound + stepBound ≤ fuel) : + 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable state base + let result ← runCleanFromTable state fuel table (inner.run cache) + finishCleanFailureObserve + (fun nextTable nextState remaining value => + materializedCleanBoundaryFailureFromTable parameter root ftsSecret + (next (value : β × SplitHashCache).1) nextState remaining nextTable value.2) + result] = + 𝒟[runDirectDetailedSafeOrdinaryWithCompletionTable + (guardedMaterializedCleanContinuation parameter root ftsSecret next nextBound) + (directDeferredContext state) fuel (inner.run cache)] := by + symm + calc + _ = 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable state base + let result ← runCleanFromTable state fuel table (inner.run cache) + finishCleanFailureObserve + (fun nextTable nextState remaining value => + guardedMaterializedCleanContinuation parameter root ftsSecret next nextBound + nextTable (directDeferredContext nextState) remaining value) + result] := + evalDist_runDirectDetailedSafeOrdinary_eq_sampledCleanFailureObserve + (inner.run cache) + (fun nextTable nextState remaining value => + guardedMaterializedCleanContinuation parameter root ftsSecret next nextBound + nextTable (directDeferredContext nextState) remaining + (value : β × SplitHashCache)) + state fuel (hinnerBound.mono (by omega)) + _ = _ := by + apply evalDist_bind_congr + intro base _hbase + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hnextPublished := publishedValues_of_mem_runCleanFromTable inner state cache fuel + (completedStartTable state base) result hpublished hpreserves hresult + have hfuel := fuel_le_remaining_add_of_mem_runCleanFromTable (inner.run cache) state fuel + (completedStartTable state base) result stepBound hinnerBound hresult + have hnextBudget : nextBound ≤ result.remaining := by omega + simp only [finishCleanFailureObserve] + unfold guardedMaterializedCleanContinuation + simp only [directDeferredContext] + rw [if_pos ⟨hnextPublished, hnextBudget⟩] + +noncomputable def supportedGuardedMaterializedCleanContinuation + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (next : β → OracleComp (OracleWorld + SigningSpec) α) + (bound : Nat) (initialState : LazyRevealProbe.State Coordinate) + (admissible : LazyRevealProbe.State Coordinate → β → Prop) + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) (fuel : Nat) + (value : β × SplitHashCache) : ProbComp Bool := by + classical + exact if PublishedValues context.state ∧ bound ≤ fuel ∧ + LazyRevealProbe.ValuesLE initialState context.state ∧ + StartTableAgrees initialState table ∧ StartTableAgrees context.state table ∧ + admissible context.state value.1 then + materializedCleanBoundaryFailureFromTable parameter root ftsSecret (next value.1) + context.state fuel table value.2 + else + pure false + +set_option maxRecDepth 100000 in +theorem evalDist_sampledCleanStep_eq_safeSupportedGuardedContinuation + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (next : β → OracleComp (OracleWorld + SigningSpec) α) + (inner : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (cache : SplitHashCache) (stepBound nextBound : Nat) + (admissible : LazyRevealProbe.State Coordinate → β → Prop) + (hpublished : PublishedValues state) + (hinnerBound : (inner.run cache).IsQueryBoundP LazyRevealProbe.IsProbe stepBound) + (hpreserves : PreservesPublishedValues inner) + (hadmissible : ∀ table result, + StartTableAgrees state table → + some result ∈ support (runCleanFromTable state fuel table (inner.run cache)) → + admissible result.state result.value.1) + (hbudget : nextBound + stepBound ≤ fuel) : + 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable state base + let result ← runCleanFromTable state fuel table (inner.run cache) + finishCleanFailureObserve + (fun nextTable nextState remaining value ↦ + materializedCleanBoundaryFailureFromTable parameter root ftsSecret + (next (value : β × SplitHashCache).1) nextState remaining nextTable value.2) + result] = + 𝒟[runDirectDetailedSafeOrdinaryWithCompletionTable + (supportedGuardedMaterializedCleanContinuation parameter root ftsSecret next nextBound + state admissible) + (directDeferredContext state) fuel (inner.run cache)] := by + symm + calc + _ = 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable state base + let result ← runCleanFromTable state fuel table (inner.run cache) + finishCleanFailureObserve + (fun nextTable nextState remaining value ↦ + supportedGuardedMaterializedCleanContinuation parameter root ftsSecret next nextBound + state admissible nextTable (directDeferredContext nextState) remaining value) + result] := + evalDist_runDirectDetailedSafeOrdinary_eq_sampledCleanFailureObserve + (inner.run cache) + (fun nextTable nextState remaining value ↦ + supportedGuardedMaterializedCleanContinuation parameter root ftsSecret next nextBound + state admissible nextTable (directDeferredContext nextState) remaining + (value : β × SplitHashCache)) + state fuel (hinnerBound.mono (by omega)) + _ = _ := by + apply evalDist_bind_congr + intro base _hbase + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + let table := completedStartTable state base + have hinitialStarts : StartTableAgrees state table := + startTableAgrees_completedStartTable state base + have hnextStarts := startTableAgrees_of_mem_runCleanFromTable + (inner.run cache) state fuel table hinitialStarts result hresult + have hraw := mem_support_runRaw_done_of_mem_runCleanFromTable_some + (inner.run cache) state fuel table result hresult + have hvalues := LazyRevealProbe.valuesLE_of_mem_runRaw_done + (inner.run cache) state result.state fuel result.remaining result.value hraw + have hnextPublished := publishedValues_of_mem_runCleanFromTable inner state cache fuel + table result hpublished hpreserves hresult + have hfuel := fuel_le_remaining_add_of_mem_runCleanFromTable (inner.run cache) state fuel + table result stepBound hinnerBound hresult + have hnextBudget : nextBound ≤ result.remaining := by omega + have hallowed := hadmissible table result hinitialStarts hresult + simp only [finishCleanFailureObserve] + unfold supportedGuardedMaterializedCleanContinuation + simp only [directDeferredContext] + rw [hnextStarts.1] + rw [if_pos + ⟨hnextPublished, hnextBudget, hvalues, hinitialStarts, hnextStarts.2, hallowed⟩] + +theorem probEvent_sampledRunThenFinalizeClean_none_le + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe fuel) : + Pr[= none | sampledRunThenFinalizeClean state fuel computation] ≤ + ((fuel + state.pending.card : Nat) : ENNReal) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ = Pr[= none | detailedExperimentCleanWithCompletionTable state fuel computation] := + OracleComp.probOutput_congr rfl + (by + unfold sampledRunThenFinalizeClean + exact evalDist_runThenFinalizeCleanFromTable_eq_detailed computation state fuel) + _ = Pr[= true | LazyRevealProbe.experiment state fuel computation] := + probEvent_detailedExperimentClean_none_eq_hit computation state fuel hbound + _ ≤ _ := by + rw [← probEvent_eq_eq_probOutput] + exact LazyRevealProbe.experiment_probability_le state fuel computation + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_sampledMaterializedCleanBoundaryFailure_le + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (state : LazyRevealProbe.State Coordinate) (fuel bound : Nat) + (cache : SplitHashCache) + (hbound : ∀ table, + StartTableAgrees state table → + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + computation).IsQueryBoundP (fun query => query matches Sum.inr _) bound) + (hbudget : bound ≤ fuel) + (hpublished : PublishedValues state) : + Pr[= true | + sampledMaterializedCleanBoundaryFailure parameter root ftsSecret computation state fuel + cache] ≤ + ((fuel + state.pending.card : Nat) : ENNReal) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + induction computation using OracleComp.inductionOn generalizing state fuel bound cache with + | pure value => + have hdist : + 𝒟[Option.isNone <$> sampledRunThenFinalizeClean state fuel + (pure (value, cache) : OracleComp (LazyRevealProbe.World Coordinate) + (α × SplitHashCache))] = + 𝒟[sampledMaterializedCleanBoundaryFailure parameter root ftsSecret + (pure value) state fuel cache] := by + unfold sampledRunThenFinalizeClean sampledMaterializedCleanBoundaryFailure + materializedCleanBoundaryFailureFromTable + rw [map_bind] + apply evalDist_bind_congr + intro base _hbase + rw [runCleanFromTable_pure_oracle] + simp [materializedCleanBoundary] + calc + _ = Pr[= true | Option.isNone <$> sampledRunThenFinalizeClean state fuel + (pure (value, cache) : OracleComp (LazyRevealProbe.World Coordinate) + (α × SplitHashCache))] := + OracleComp.probOutput_congr rfl hdist.symm + _ = Pr[= none | sampledRunThenFinalizeClean state fuel + (pure (value, cache) : OracleComp (LazyRevealProbe.World Coordinate) + (α × SplitHashCache))] := by + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput, probEvent_map] + apply OracleComp.probEvent_congr' + · intro result _hresult + cases result <;> simp + · rfl + _ ≤ _ := probEvent_sampledRunThenFinalizeClean_none_le + (pure (value, cache) : OracleComp (LazyRevealProbe.World Coordinate) + (α × SplitHashCache)) state fuel (by simp) + | query_bind query next ih => + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + have hinnerBound : ((splitUniformImpl n).run cache).IsQueryBoundP + LazyRevealProbe.IsProbe 0 := splitUniformImpl_probeFree n cache + have hstep := evalDist_sampledCleanStep_eq_safeSupportedGuardedContinuation + parameter root ftsSecret next (splitUniformImpl n) state fuel cache 0 bound + (fun _ _ ↦ True) hpublished hinnerBound + (preservesPublishedValuesImpl_splitUniformImpl n) (by simp) (by omega) + have hdist : + 𝒟[sampledMaterializedCleanBoundaryFailure parameter root ftsSecret + ((liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (.inl (.inl n)))) >>= next) state fuel cache] = + 𝒟[runDirectDetailedSafeOrdinaryWithCompletionTable + (supportedGuardedMaterializedCleanContinuation parameter root ftsSecret next + bound state (fun _ _ ↦ True)) + (directDeferredContext state) fuel ((splitUniformImpl n).run cache)] := by + calc + _ = 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable state base + let result ← runCleanFromTable state fuel table + ((splitUniformImpl n).run cache) + finishCleanFailureObserve + (fun nextTable nextState remaining value => + materializedCleanBoundaryFailureFromTable parameter root ftsSecret + (next (value : Fin (n + 1) × SplitHashCache).1) nextState remaining + nextTable value.2) + result] := by + unfold sampledMaterializedCleanBoundaryFailure + apply evalDist_bind_congr + intro base _hbase + exact materializedCleanBoundaryFailureFromTable_uniform_query_bind parameter + root ftsSecret n next state fuel (completedStartTable state base) cache + (startTableAgrees_completedStartTable state base) + _ = _ := hstep + calc + _ = Pr[= true | runDirectDetailedSafeOrdinaryWithCompletionTable + (supportedGuardedMaterializedCleanContinuation parameter root ftsSecret next + bound state (fun _ _ ↦ True)) + (directDeferredContext state) fuel ((splitUniformImpl n).run cache)] := + OracleComp.probOutput_congr rfl hdist + _ ≤ _ := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_runDirectDetailedSafeOrdinaryWithCompletionTable_le + intro nextContext remaining value + rw [probEvent_eq_eq_probOutput] + by_cases hguard : PublishedValues nextContext.state ∧ bound ≤ remaining ∧ + LazyRevealProbe.ValuesLE state nextContext.state + · rcases hguard with ⟨hnextPublished, hnextBudget, hvalues⟩ + have hinitial : ∀ base, + StartTableAgrees state (completedStartTable nextContext.state base) := by + intro base index output hvalue + exact startTableAgrees_completedStartTable nextContext.state base index output + (hvalues index.coordinate output hvalue) + simpa [supportedGuardedMaterializedCleanContinuation, hnextPublished, + hnextBudget, hvalues, hinitial, + startTableAgrees_completedStartTable, + sampledMaterializedCleanBoundaryFailure] using + (ih value.1 nextContext.state remaining bound value.2 + (by + intro table hagrees + have hinitial' : StartTableAgrees state table := by + intro index output hvalue + exact hagrees index output (hvalues index.coordinate output hvalue) + have hsource := hbound table hinitial' + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hsource + exact hsource.2 value.1) + hnextBudget hnextPublished) + · have hcondition : ∀ base, + ¬(PublishedValues nextContext.state ∧ bound ≤ remaining ∧ + LazyRevealProbe.ValuesLE state nextContext.state ∧ + StartTableAgrees state + (completedStartTable nextContext.state base) ∧ + StartTableAgrees nextContext.state + (completedStartTable nextContext.state base) ∧ True) := by + intro base hfull + exact hguard ⟨hfull.1, hfull.2.1, hfull.2.2.1⟩ + simp only [supportedGuardedMaterializedCleanContinuation] + simp_rw [if_neg (hcondition _)] + have hdist : 𝒟[(do + let _base ← sampleOtsHashTable + pure false : ProbComp Bool)] = 𝒟[(pure false : ProbComp Bool)] := + evalDist_sampleOtsHashTable_bind_const _ + have hpure : Pr[= true | (pure false : ProbComp Bool)] ≤ + ((remaining + nextContext.state.pending.card : Nat) : ENNReal) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + simpa only [probOutput_pure, Bool.true_eq_false, ↓reduceIte] using + (zero_le : (0 : ENNReal) ≤ + ((remaining + nextContext.state.pending.card : Nat) : ENNReal) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + exact (OracleComp.probOutput_congr rfl hdist).le.trans hpure + | inr input => + let publicState := canonicalPublicProbeState state + let plan := purePlanProbingHashQuery parameter input publicState + let inner := probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan + let nextBound := bound - 1 + have hpositive : 0 < bound := by + let table := completedStartTable state (fun _ ↦ 0) + have hsource := hbound table (startTableAgrees_completedStartTable state _) + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hsource + rcases hsource.1 with hnot | hpositive + · exact (hnot (by simp [IsOuterHash])).elim + · exact hpositive + have hinnerBound : (inner.run cache).IsQueryBoundP + LazyRevealProbe.IsProbe 1 := + probingHashQueryAfterRootAwarePublicPlan_isProbeBound_one parameter input + publicState plan cache + have hstep := evalDist_sampledCleanStep_eq_safeSupportedGuardedContinuation + parameter root ftsSecret next inner state fuel cache 1 nextBound + (fun _ _ ↦ True) hpublished hinnerBound + (preservesPublishedValues_probingHashQueryAfterRootAwarePublicPlan parameter input + publicState plan) + (by simp) + (by dsimp only [nextBound]; omega) + have hdist : + 𝒟[sampledMaterializedCleanBoundaryFailure parameter root ftsSecret + ((liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (.inl (.inr input)))) >>= next) state fuel cache] = + 𝒟[runDirectDetailedSafeOrdinaryWithCompletionTable + (supportedGuardedMaterializedCleanContinuation parameter root ftsSecret next + nextBound state (fun _ _ ↦ True)) + (directDeferredContext state) fuel (inner.run cache)] := by + calc + _ = 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable state base + let result ← runCleanFromTable state fuel table (inner.run cache) + finishCleanFailureObserve + (fun nextTable nextState remaining value => + materializedCleanBoundaryFailureFromTable parameter root ftsSecret + (next (value : HashOutput × SplitHashCache).1) nextState remaining + nextTable value.2) + result] := by + unfold sampledMaterializedCleanBoundaryFailure + apply evalDist_bind_congr + intro base _hbase + simpa only [publicState, plan, inner] using + (materializedCleanBoundaryFailureFromTable_hash_query_bind parameter root + ftsSecret input next state fuel (completedStartTable state base) cache + (startTableAgrees_completedStartTable state base) hpublished) + _ = _ := hstep + calc + _ = Pr[= true | runDirectDetailedSafeOrdinaryWithCompletionTable + (supportedGuardedMaterializedCleanContinuation parameter root ftsSecret next + nextBound state (fun _ _ ↦ True)) + (directDeferredContext state) fuel (inner.run cache)] := + OracleComp.probOutput_congr rfl hdist + _ ≤ _ := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_runDirectDetailedSafeOrdinaryWithCompletionTable_le + intro nextContext remaining value + rw [probEvent_eq_eq_probOutput] + by_cases hguard : PublishedValues nextContext.state ∧ + nextBound ≤ remaining ∧ + LazyRevealProbe.ValuesLE state nextContext.state + · rcases hguard with ⟨hnextPublished, hnextBudget, hvalues⟩ + have hinitial : ∀ base, + StartTableAgrees state (completedStartTable nextContext.state base) := by + intro base index output hvalue + exact startTableAgrees_completedStartTable nextContext.state base index output + (hvalues index.coordinate output hvalue) + simpa [supportedGuardedMaterializedCleanContinuation, hnextPublished, + hnextBudget, hvalues, hinitial, + startTableAgrees_completedStartTable, + sampledMaterializedCleanBoundaryFailure] using + (ih value.1 nextContext.state remaining nextBound value.2 + (by + intro table hagrees + have hinitial' : StartTableAgrees state table := by + intro index output hvalue + exact hagrees index output (hvalues index.coordinate output hvalue) + have hsource := hbound table hinitial' + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hsource + dsimp only [nextBound] + simpa using hsource.2 value.1) + hnextBudget hnextPublished) + · have hcondition : ∀ base, + ¬(PublishedValues nextContext.state ∧ nextBound ≤ remaining ∧ + LazyRevealProbe.ValuesLE state nextContext.state ∧ + StartTableAgrees state + (completedStartTable nextContext.state base) ∧ + StartTableAgrees nextContext.state + (completedStartTable nextContext.state base) ∧ True) := by + intro base hfull + exact hguard ⟨hfull.1, hfull.2.1, hfull.2.2.1⟩ + simp only [supportedGuardedMaterializedCleanContinuation] + simp_rw [if_neg (hcondition _)] + have hdist : 𝒟[(do + let _base ← sampleOtsHashTable + pure false : ProbComp Bool)] = 𝒟[(pure false : ProbComp Bool)] := + evalDist_sampleOtsHashTable_bind_const _ + have hpure : Pr[= true | (pure false : ProbComp Bool)] ≤ + ((remaining + nextContext.state.pending.card : Nat) : ENNReal) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + simpa only [probOutput_pure, Bool.true_eq_false, ↓reduceIte] using + (zero_le : (0 : ENNReal) ≤ + ((remaining + nextContext.state.pending.card : Nat) : ENNReal) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + exact (OracleComp.probOutput_congr rfl hdist).le.trans hpure + | inr message => + have hinnerBound : ((maskedSign parameter root ftsSecret message).run cache).IsQueryBoundP + LazyRevealProbe.IsProbe 0 := + maskedSign_probeFree parameter root ftsSecret message cache + let admissible := fun (finalState : LazyRevealProbe.State Coordinate) + (output : (OracleWorld + SigningSpec).Range (.inr message)) ↦ ∀ table, + StartTableAgrees finalState table → + output ∈ support + (scheme.sign + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey) + message) + have hstep := evalDist_sampledCleanStep_eq_safeSupportedGuardedContinuation + parameter root ftsSecret next (maskedSign parameter root ftsSecret message) + state fuel cache 0 bound admissible hpublished hinnerBound + (preservesPublishedValues_maskedSign parameter root ftsSecret message) + (by + intro table result _hstarts hresult nextTable hnextStarts + have hraw := mem_support_runRaw_done_of_mem_runCleanFromTable_some + ((maskedSign parameter root ftsSecret message).run cache) state fuel table result + hresult + exact maskedSign_done_output_mem_support parameter root nextTable ftsSecret message + state result.state cache result.value.2 fuel result.remaining result.value.1 + hnextStarts hraw) + (by omega) + have hdist : + 𝒟[sampledMaterializedCleanBoundaryFailure parameter root ftsSecret + ((liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (.inr message))) >>= next) state fuel cache] = + 𝒟[runDirectDetailedSafeOrdinaryWithCompletionTable + (supportedGuardedMaterializedCleanContinuation parameter root ftsSecret next + bound state admissible) + (directDeferredContext state) fuel + ((maskedSign parameter root ftsSecret message).run cache)] := by + calc + _ = 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable state base + let result ← runCleanFromTable state fuel table + ((maskedSign parameter root ftsSecret message).run cache) + finishCleanFailureObserve + (fun nextTable nextState remaining value => + materializedCleanBoundaryFailureFromTable parameter root ftsSecret + (next (value : Option Signature × SplitHashCache).1) nextState remaining + nextTable value.2) + result] := by + unfold sampledMaterializedCleanBoundaryFailure + apply evalDist_bind_congr + intro base _hbase + exact materializedCleanBoundaryFailureFromTable_sign_query_bind parameter root + ftsSecret message next state fuel (completedStartTable state base) cache + (startTableAgrees_completedStartTable state base) + _ = _ := hstep + calc + _ = Pr[= true | runDirectDetailedSafeOrdinaryWithCompletionTable + (supportedGuardedMaterializedCleanContinuation parameter root ftsSecret next + bound state admissible) + (directDeferredContext state) fuel + ((maskedSign parameter root ftsSecret message).run cache)] := + OracleComp.probOutput_congr rfl hdist + _ ≤ _ := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_runDirectDetailedSafeOrdinaryWithCompletionTable_le + intro nextContext remaining value + rw [probEvent_eq_eq_probOutput] + by_cases hguard : PublishedValues nextContext.state ∧ bound ≤ remaining ∧ + LazyRevealProbe.ValuesLE state nextContext.state ∧ + admissible nextContext.state value.1 + · rcases hguard with + ⟨hnextPublished, hnextBudget, hvalues, hallowed⟩ + have hinitial : ∀ base, + StartTableAgrees state (completedStartTable nextContext.state base) := by + intro base index output hvalue + exact startTableAgrees_completedStartTable nextContext.state base index output + (hvalues index.coordinate output hvalue) + simpa [supportedGuardedMaterializedCleanContinuation, hnextPublished, + hnextBudget, hvalues, hinitial, startTableAgrees_completedStartTable, + hallowed, sampledMaterializedCleanBoundaryFailure] using + (ih value.1 nextContext.state remaining bound value.2 + (by + intro table hagrees + have hinitial' : StartTableAgrees state table := by + intro index output hvalue + exact hagrees index output (hvalues index.coordinate output hvalue) + have hsource := hbound table hinitial' + rw [simulateQ_expandedAdversaryImpl_query_bind_inr] at hsource + exact isQueryBoundP_of_bind hsource value.1 (hallowed table hagrees)) + hnextBudget hnextPublished) + · have hcondition : ∀ base, + ¬(PublishedValues nextContext.state ∧ bound ≤ remaining ∧ + LazyRevealProbe.ValuesLE state nextContext.state ∧ + StartTableAgrees state (completedStartTable nextContext.state base) ∧ + StartTableAgrees nextContext.state + (completedStartTable nextContext.state base) ∧ + admissible nextContext.state value.1) := by + intro base hfull + exact hguard + ⟨hfull.1, hfull.2.1, hfull.2.2.1, hfull.2.2.2.2.2⟩ + simp only [supportedGuardedMaterializedCleanContinuation] + simp_rw [if_neg (hcondition _)] + have hdist : 𝒟[(do + let _base ← sampleOtsHashTable + pure false : ProbComp Bool)] = 𝒟[(pure false : ProbComp Bool)] := + evalDist_sampleOtsHashTable_bind_const _ + have hpure : Pr[= true | (pure false : ProbComp Bool)] ≤ + ((remaining + nextContext.state.pending.card : Nat) : ENNReal) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + simpa only [probOutput_pure, Bool.true_eq_false, ↓reduceIte] using + (zero_le : (0 : ENNReal) ≤ + ((remaining + nextContext.state.pending.card : Nat) : ENNReal) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + exact (OracleComp.probOutput_congr rfl hdist).le.trans hpure + +noncomputable def sampledMaterializedCleanUnguarded + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp (Option (CleanRunResult (RetainedGameResult × SplitHashCache))) := do + let table ← sampleOtsHashTable + let result ← materializedCleanRetainedRunFromTable adversary parameter ftsSecret fuel table + finishCleanRunFromTable result + +noncomputable def guardedMaterializedRootContinuation + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (bound : Nat) + (table : OtsSecretIndex → HashOutput) (state : LazyRevealProbe.State Coordinate) + (fuel : Nat) (value : Digest × SplitHashCache) : ProbComp Bool := by + classical + exact if PublishedValues state ∧ bound ≤ fuel then + materializedCleanBoundaryFailureFromTable parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + state fuel table value.2 + else + pure false + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_sampledMaterializedCleanUnguarded_isNone_eq_safeRoot_of_fuel + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel bound : Nat) + (hbudget : bound ≤ fuel) : + 𝒟[Option.isNone <$> + sampledMaterializedCleanUnguarded adversary parameter ftsSecret fuel] = + 𝒟[runDirectDetailedSafeOrdinaryWithCompletionTable + (fun table context remaining value => + guardedMaterializedRootContinuation adversary parameter ftsSecret bound table + context.state remaining value) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) fuel + (maskedPublishedTreeRoot.run emptySplitHashCache)] := by + have hsafe := evalDist_runDirectDetailedSafeOrdinary_eq_sampledCleanFailureObserve + (maskedPublishedTreeRoot.run emptySplitHashCache) + (fun table state remaining value => + guardedMaterializedRootContinuation adversary parameter ftsSecret bound table + state remaining value) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel + (maskedPublishedTreeRoot_probeFree emptySplitHashCache |>.mono (by omega)) + calc + _ = 𝒟[do + let base ← sampleOtsHashTable + let table := completedStartTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) base + let result ← runCleanFromTable LazyRevealProbe.State.empty fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + finishCleanFailureObserve + (fun nextTable state remaining value => + guardedMaterializedRootContinuation adversary parameter ftsSecret bound nextTable + state remaining value) + result] := by + unfold sampledMaterializedCleanUnguarded materializedCleanRetainedRunFromTable + rw [map_bind] + apply evalDist_bind_congr + intro table _htable + rw [completedStartTable_empty, map_bind] + simp only [bind_assoc] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hpublished := publishedValues_of_mem_runCleanFromTable maskedPublishedTreeRoot + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) emptySplitHashCache fuel + table result (by simp [PublishedValues, LazyRevealProbe.State.empty]) + preservesPublishedValues_maskedPublishedTreeRoot hresult + have hfuel := fuel_le_remaining_add_of_mem_runCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table result 0 + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) hresult + have hremaining : bound ≤ result.remaining := by omega + have hguard : PublishedValues result.state ∧ bound ≤ result.remaining := + ⟨hpublished, hremaining⟩ + have htable := (startTableAgrees_of_mem_runCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (startTableAgrees_empty table) result hresult).1 + simp only [finishCleanFailureObserve, guardedMaterializedRootContinuation, + if_pos hguard] + rw [← htable] + unfold materializedCleanBoundaryFailureFromTable + simp only [bind_assoc] + apply evalDist_bind_congr + intro restResult _hrestResult + cases restResult with + | none => simp [finishCleanRunFromTable] + | some restResult => + simp only [finishCleanRunFromTable, pure_bind] + rw [map_bind] + simp only [bind_assoc] + apply evalDist_bind_congr + intro finalized _hfinalized + cases finalized <;> rfl + _ = _ := hsafe.symm + +theorem evalDist_sampledMaterializedCleanUnguarded_isNone_eq_safeRoot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) : + 𝒟[Option.isNone <$> + sampledMaterializedCleanUnguarded adversary parameter ftsSecret q] = + 𝒟[runDirectDetailedSafeOrdinaryWithCompletionTable + (fun table context remaining value => + guardedMaterializedRootContinuation adversary parameter ftsSecret q table + context.state remaining value) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) q + (maskedPublishedTreeRoot.run emptySplitHashCache)] := + evalDist_sampledMaterializedCleanUnguarded_isNone_eq_safeRoot_of_fuel adversary parameter + ftsSecret q q le_rfl + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledMaterializedCleanUnguarded_none_le_of_fuel + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hbudget : q ≤ fuel) : + Pr[= none | sampledMaterializedCleanUnguarded adversary parameter ftsSecret fuel] ≤ + (fuel : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ = Pr[= true | Option.isNone <$> + sampledMaterializedCleanUnguarded adversary parameter ftsSecret fuel] := by + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput, probEvent_map] + apply OracleComp.probEvent_congr' + · intro result _hresult + cases result <;> simp + · rfl + _ = Pr[= true | runDirectDetailedSafeOrdinaryWithCompletionTable + (fun table context remaining value => + guardedMaterializedRootContinuation adversary parameter ftsSecret q table + context.state remaining value) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) fuel + (maskedPublishedTreeRoot.run emptySplitHashCache)] := + OracleComp.probOutput_congr rfl + (evalDist_sampledMaterializedCleanUnguarded_isNone_eq_safeRoot_of_fuel adversary parameter + ftsSecret fuel q hbudget) + _ ≤ _ := by + rw [← probEvent_eq_eq_probOutput] + have hsafe := probEvent_runDirectDetailedSafeOrdinaryWithCompletionTable_le + (maskedPublishedTreeRoot.run emptySplitHashCache) + (fun table context remaining value => + guardedMaterializedRootContinuation adversary parameter ftsSecret q table + context.state remaining value) + (by + intro context remaining value + rw [probEvent_eq_eq_probOutput] + by_cases hguard : PublishedValues context.state ∧ q ≤ remaining + · simpa [guardedMaterializedRootContinuation, hguard, + sampledMaterializedCleanBoundaryFailure] using + (probEvent_sampledMaterializedCleanBoundaryFailure_le parameter value.1 + ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + context.state remaining q value.2 (fun table _ ↦ hbound table value.1) + hguard.2 hguard.1) + · simp [guardedMaterializedRootContinuation, hguard]) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) fuel + simpa [emptyWitnessDeferredContext, LazyRevealProbe.State.empty] using hsafe + +theorem probEvent_sampledMaterializedCleanUnguarded_none_le + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + Pr[= none | sampledMaterializedCleanUnguarded adversary parameter ftsSecret q] ≤ + (q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + probEvent_sampledMaterializedCleanUnguarded_none_le_of_fuel adversary parameter ftsSecret q q + hbound le_rfl + +noncomputable def materializedSafeBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : ProbComp Bool := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + (DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) → + DeferredContext → Nat → SplitHashCache → ProbComp Bool) + (fun value observe context fuel cache => observe context fuel (value, cache)) + (fun query _next recursivelyRun observe context fuel cache => + match query with + | .inl (.inl n) => + runDirectDetailedSafeOrdinaryWithCompletionTable + (fun _ nextContext remaining value => + recursivelyRun value.1 observe nextContext remaining value.2) + context fuel ((splitUniformImpl n).run cache) + | .inl (.inr input) => + let publicState := canonicalPublicProbeState context.state + let plan := purePlanProbingHashQuery parameter input publicState + runDirectDetailedSafeOrdinaryWithCompletionTable + (fun _ nextContext remaining value => + recursivelyRun value.1 observe nextContext remaining value.2) + context fuel + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run + cache) + | .inr message => + runDirectDetailedSafeOrdinaryWithCompletionTable + (fun _ nextContext remaining value => + recursivelyRun value.1 observe nextContext remaining value.2) + context fuel ((maskedSign parameter root ftsSecret message).run cache)) + computation observe context fuel cache + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_materializedSafeBoundary_le + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + (hobserve : ∀ context fuel value, + Pr[= true | observe context fuel value] ≤ + ((fuel + context.state.pending.card : Nat) : ENNReal) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + Pr[= true | + materializedSafeBoundary parameter root ftsSecret computation observe context fuel + cache] ≤ + ((fuel + context.state.pending.card : Nat) : ENNReal) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + simpa [materializedSafeBoundary] using hobserve context fuel (value, cache) + | query_bind query next ih => + rw [materializedSafeBoundary, OracleComp.construct_query_bind] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + simp only + rw [← probEvent_eq_eq_probOutput] + apply probEvent_runDirectDetailedSafeOrdinaryWithCompletionTable_le + intro nextContext remaining value + have hdist : + 𝒟[do + let _base ← sampleOtsHashTable + materializedSafeBoundary parameter root ftsSecret (next value.1) + observe nextContext remaining value.2] = + 𝒟[materializedSafeBoundary parameter root ftsSecret (next value.1) + observe nextContext remaining value.2] := + evalDist_sampleOtsHashTable_bind_const _ + have hih := ih value.1 nextContext remaining value.2 + rw [← probEvent_eq_eq_probOutput] at hih + exact (OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) hdist).le.trans hih + | inr input => + simp only + rw [← probEvent_eq_eq_probOutput] + apply probEvent_runDirectDetailedSafeOrdinaryWithCompletionTable_le + intro nextContext remaining value + have hdist : + 𝒟[do + let _base ← sampleOtsHashTable + materializedSafeBoundary parameter root ftsSecret (next value.1) + observe nextContext remaining value.2] = + 𝒟[materializedSafeBoundary parameter root ftsSecret (next value.1) + observe nextContext remaining value.2] := + evalDist_sampleOtsHashTable_bind_const _ + have hih := ih value.1 nextContext remaining value.2 + rw [← probEvent_eq_eq_probOutput] at hih + exact (OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) hdist).le.trans hih + | inr message => + simp only + rw [← probEvent_eq_eq_probOutput] + apply probEvent_runDirectDetailedSafeOrdinaryWithCompletionTable_le + intro nextContext remaining value + have hdist : + 𝒟[do + let _base ← sampleOtsHashTable + materializedSafeBoundary parameter root ftsSecret (next value.1) + observe nextContext remaining value.2] = + 𝒟[materializedSafeBoundary parameter root ftsSecret (next value.1) + observe nextContext remaining value.2] := + evalDist_sampleOtsHashTable_bind_const _ + have hih := ih value.1 nextContext remaining value.2 + rw [← probEvent_eq_eq_probOutput] at hih + exact (OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) hdist).le.trans hih + +noncomputable def materializedSafeFinalObserve + (context : DeferredContext) (_fuel : Nat) + (_value : RetainedRestResult × SplitHashCache) : ProbComp Bool := + LazyRevealProbe.finalize context.state + +theorem probEvent_materializedSafeFinalObserve_le + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) : + Pr[= true | materializedSafeFinalObserve context fuel value] ≤ + ((fuel + context.state.pending.card : Nat) : ENNReal) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + unfold materializedSafeFinalObserve + rw [← probEvent_eq_eq_probOutput] + refine (LazyRevealProbe.finalize_probability_le context.state).trans ?_ + have hnat : context.state.pending.card ≤ fuel + context.state.pending.card := by omega + exact mul_le_mul_of_nonneg_right (by exact_mod_cast hnat) zero_le + +noncomputable def materializedSafeRetained + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : ProbComp Bool := + runDirectDetailedSafeOrdinaryWithCompletionTable + (fun _ context remaining value => + materializedSafeBoundary parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + materializedSafeFinalObserve context remaining value.2) + emptyWitnessDeferredContext fuel (maskedPublishedTreeRoot.run emptySplitHashCache) + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxRecDepth 100000 in +theorem probEvent_materializedSafeRetained_le + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[= true | materializedSafeRetained adversary parameter ftsSecret fuel] ≤ + (fuel : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + unfold materializedSafeRetained + have hbound := probEvent_runDirectDetailedSafeOrdinaryWithCompletionTable_le + (maskedPublishedTreeRoot.run emptySplitHashCache) + (fun _ context remaining value => + materializedSafeBoundary parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + materializedSafeFinalObserve context remaining value.2) + (by + intro context remaining value + have hdist : + 𝒟[do + let _base ← sampleOtsHashTable + materializedSafeBoundary parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + materializedSafeFinalObserve context remaining value.2] = + 𝒟[materializedSafeBoundary parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + materializedSafeFinalObserve context remaining value.2] := + evalDist_sampleOtsHashTable_bind_const _ + have hsafe := probEvent_materializedSafeBoundary_le parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + materializedSafeFinalObserve probEvent_materializedSafeFinalObserve_le context remaining + value.2 + rw [← probEvent_eq_eq_probOutput] at hsafe + exact (OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) hdist).le.trans hsafe) + emptyWitnessDeferredContext fuel + simpa [emptyWitnessDeferredContext, LazyRevealProbe.State.empty] using hbound + +attribute [local irreducible] observedMaterializedRetainedRunFromTable in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem map_projectObservedCleanRun_observedMaterializedRetainedRunFromTable + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + projectObservedCleanRun <$> + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table = + materializedCleanRetainedRunFromTable adversary parameter ftsSecret fuel table := by + rw [observedMaterializedRetainedRunFromTable, materializedCleanRetainedRunFromTable, map_bind] + calc + _ = (runObservedCleanFromTable [] LazyRevealProbe.State.empty fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) >>= fun rootResult => + match rootResult with + | none => pure none + | some rootResult => do + let restResult ← materializedCleanBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.state rootResult.remaining table rootResult.value.2 + match restResult with + | none => pure none + | some restResult => pure (some + { restResult with + value := ((rootResult.value.1, restResult.value.1), restResult.value.2) })) := by + apply bind_congr + intro rootResult + cases rootResult with + | none => simp [projectObservedCleanRun] + | some rootResult => + simp only + rw [map_bind] + calc + _ = observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary + ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table + rootResult.value.2 >>= fun restResult => + match restResult with + | none => pure none + | some restResult => pure (some + { restResult.toClean with + value := ((rootResult.value.1, restResult.value.1), + restResult.value.2) }) := by + apply bind_congr + intro restResult + cases restResult <;> + simp [projectObservedCleanRun, ObservedCleanRunResult.toClean] + _ = (projectObservedCleanRun <$> + observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary + ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table + rootResult.value.2) >>= fun restResult => + match restResult with + | none => pure none + | some restResult => pure (some + { restResult with + value := ((rootResult.value.1, restResult.value.1), + restResult.value.2) }) := by + rw [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro restResult + cases restResult <;> rfl + _ = materializedCleanBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary + ⟨rootResult.value.1, parameter⟩) + rootResult.state rootResult.remaining table rootResult.value.2 >>= + fun restResult => + match restResult with + | none => pure none + | some restResult => pure (some + { restResult with + value := ((rootResult.value.1, restResult.value.1), + restResult.value.2) }) := by + rw [map_projectObservedCleanRun_observedMaterializedBoundary] + _ = _ := by rfl + _ = ((projectObservedCleanRun <$> + runObservedCleanFromTable [] LazyRevealProbe.State.empty fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) >>= fun rootResult => + match rootResult with + | none => pure none + | some rootResult => do + let restResult ← materializedCleanBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.state rootResult.remaining table rootResult.value.2 + match restResult with + | none => pure none + | some restResult => pure (some + { restResult with + value := ((rootResult.value.1, restResult.value.1), restResult.value.2) })) := by + rw [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro rootResult + cases rootResult <;> rfl + _ = _ := by rw [map_projectObservedCleanRun_runObservedCleanFromTable] + +theorem map_projectObservedCleanRun_finishObservedMaterializedCleanRunFromTable + (table : OtsSecretIndex → HashOutput) + (result : Option (ObservedCleanRunResult α)) : + projectObservedCleanRun <$> + finishObservedMaterializedCleanRunFromTable table result = + finishMaterializedCleanRunFromTable table (projectObservedCleanRun result) := by + classical + cases result with + | none => + simp [finishObservedMaterializedCleanRunFromTable, + finishMaterializedCleanRunFromTable, projectObservedCleanRun] + | some result => + unfold finishObservedMaterializedCleanRunFromTable + finishMaterializedCleanRunFromTable + change projectObservedCleanRun <$> + (if DeferredCompletable table (directDeferredContext result.state) then + finishObservedCleanRunFromTable (some result) + else pure none) = + if DeferredCompletable table (directDeferredContext result.state) then + finishCleanRunFromTable (some result.toClean) + else pure none + by_cases hcompletable : + DeferredCompletable table (directDeferredContext result.state) + · simp only [hcompletable, ↓reduceIte] + simpa [projectObservedCleanRun] using + (map_projectObservedCleanRun_finishObservedCleanRunFromTable (some result)) + · simp [hcompletable, projectObservedCleanRun] + +set_option maxRecDepth 100000 in +theorem map_projectObservedCleanRun_sampledObservedMaterializedClean + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + projectObservedCleanRun <$> + sampledObservedMaterializedClean adversary parameter ftsSecret fuel = + sampledMaterializedClean adversary parameter ftsSecret fuel := by + unfold sampledObservedMaterializedClean sampledMaterializedClean + rw [map_bind] + apply bind_congr + intro table + rw [map_bind] + calc + _ = observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table >>= + fun result => finishMaterializedCleanRunFromTable table + (projectObservedCleanRun result) := by + apply bind_congr + intro result + exact map_projectObservedCleanRun_finishObservedMaterializedCleanRunFromTable table result + _ = (projectObservedCleanRun <$> + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table) >>= + finishMaterializedCleanRunFromTable table := by + rw [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro result + rfl + _ = _ := by + rw [map_projectObservedCleanRun_observedMaterializedRetainedRunFromTable] + +theorem probEvent_sampledObservedMaterializedClean_none_eq_clean + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[= none | sampledObservedMaterializedClean adversary parameter ftsSecret fuel] = + Pr[= none | sampledMaterializedClean adversary parameter ftsSecret fuel] := by + calc + _ = Pr[= none | projectObservedCleanRun <$> + sampledObservedMaterializedClean adversary parameter ftsSecret fuel] := by + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput, probEvent_map] + apply OracleComp.probEvent_congr' + · intro result _hresult + cases result <;> simp [projectObservedCleanRun] + · rfl + _ = _ := OracleComp.probOutput_congr rfl + (congrArg evalDist + (map_projectObservedCleanRun_sampledObservedMaterializedClean adversary parameter + ftsSecret fuel)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSample.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSample.lean new file mode 100644 index 00000000..666ecca0 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSample.lean @@ -0,0 +1,209 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSampleTracking + +/-! +# Sampled global root relation + +The canonical source and materialized comparison are related through table sampling after their +fixed-table chronology and observation invariants have been established. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def SnapshotObservedRootOrDoomedRel + (table : OtsSecretIndex → HashOutput) + (source : PrivateWitnessSnapshotOutput) + (observed : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))) : Prop := + observed = none ∨ + (∃ result, observed = some result ∧ + (WitnessFirstUsesSomeLayerRoot (erasePrivateWitnessSnapshotOutput source) → + WitnessFirstUsesSomeDelayedLayerRootSnapshot source)) ∨ + ∃ result, observed = some result ∧ + DoomedResolvedContext table (directDeferredContext result.state) + +attribute [local irreducible] observedMaterializedRetainedRunFromTable in +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_granularAllCanonical_observedMaterialized_rootOrDoomed + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + RelTriple + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q) + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table) + (SnapshotObservedRootOrDoomedRel table) := by + have hrelation := relTriple_granularAllSnapshot_observedMaterializedRetained adversary parameter + ftsSecret q table hbound + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hrelation + SourceSnapshotStopInvariant + (sourceSnapshotStopInvariant_of_mem_granularAllCanonical adversary parameter table + ftsSecret q) + have htracked : RelTriple + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q) + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table) + (fun source observed => + (SnapshotObservedPrefixStableRel table source observed ∧ + SourceSnapshotStopInvariant source) ∧ + ObservedMaterializedOutputTracked observed) := + relTriple_and_observedMaterializedOutputTracked + (adversary := adversary) (parameter := parameter) (ftsSecret := ftsSecret) + (fuel := 2 * q) (table := table) + (source := granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q) + (relation := fun source observed => + SnapshotObservedPrefixStableRel table source observed ∧ + SourceSnapshotStopInvariant source) + hleft + apply relTriple_post_mono htracked + intro source observed hfacts + rcases hfacts with ⟨⟨hstable, hsource⟩, htrackedOutput⟩ + rcases hstable with hfailed | hsuccess | hdoomed + · exact Or.inl hfailed + · obtain ⟨result, aligned, hresult, hprefix, haligned, hstored⟩ := hsuccess + have hvalue : SnapshotObservedPrefixValueRel table source observed := + Or.inr ⟨result, aligned, hresult, hprefix, haligned, hstored⟩ + have hroot : SnapshotObservedRootRel source observed := hvalue.to_rootRel hsource (by + intro trackedResult htrackedResult + have heq : trackedResult = result := Option.some.inj (htrackedResult.symm.trans hresult) + subst trackedResult + simpa only [hresult, ObservedMaterializedOutputTracked] using htrackedOutput) + rcases hroot with hfailed | himplication + · exact Or.inl hfailed + · exact Or.inr (Or.inl ⟨result, hresult, himplication⟩) + · obtain ⟨result, hresult, hdoomed⟩ := hdoomed + exact Or.inr (Or.inr ⟨result, hresult, hdoomed⟩) + +theorem relTriple_pure_finishObservedMaterialized_of_rootOrDoomed + (table : OtsSecretIndex → HashOutput) + (source : PrivateWitnessSnapshotOutput) + (observed : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))) + (hrelation : SnapshotObservedRootOrDoomedRel table source observed) : + RelTriple + (pure source : ProbComp PrivateWitnessSnapshotOutput) + (finishObservedMaterializedCleanRunFromTable table observed) + SnapshotObservedRootRel := by + rcases hrelation with hfailed | hsuccess | hdoomed + · subst observed + simp [finishObservedMaterializedCleanRunFromTable, SnapshotObservedRootRel] + · obtain ⟨result, hresult, himplication⟩ := hsuccess + subst observed + by_cases hcompletable : + DeferredCompletable table (directDeferredContext result.state) + · simp only [finishObservedMaterializedCleanRunFromTable, hcompletable, ↓reduceIte] + have hbase := relTriple_true (pure source : ProbComp PrivateWitnessSnapshotOutput) + (finishObservedCleanRunFromTable (some result)) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun output => output = source) (by intro output houtput; simpa using houtput) + apply relTriple_post_mono hleft + intro left final hfacts + rw [hfacts.2] + cases final with + | none => exact Or.inl rfl + | some _ => exact Or.inr himplication + · simp [finishObservedMaterializedCleanRunFromTable, hcompletable, + SnapshotObservedRootRel] + · obtain ⟨result, hresult, hdoomedContext⟩ := hdoomed + subst observed + simp [finishObservedMaterializedCleanRunFromTable, hdoomedContext.2.2, + SnapshotObservedRootRel] + +set_option maxRecDepth 100000 in +theorem relTriple_finishObservedMaterialized_of_rootOrDoomed + (table : OtsSecretIndex → HashOutput) + (source : ProbComp PrivateWitnessSnapshotOutput) + (observed : ProbComp (Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)))) + (hrelation : RelTriple source observed (SnapshotObservedRootOrDoomedRel table)) : + RelTriple source + (observed >>= finishObservedMaterializedCleanRunFromTable table) + SnapshotObservedRootRel := by + have hbound := relTriple_bind hrelation fun sourceOutput observedOutput houtput => + relTriple_pure_finishObservedMaterialized_of_rootOrDoomed table sourceOutput observedOutput + houtput + simpa using hbound + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_granularAllCanonical_finishedMaterialized_rootRel + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + RelTriple + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q) + (finishedObservedMaterializedRunFromTable adversary parameter ftsSecret (2 * q) table) + SnapshotObservedRootRel := by + unfold finishedObservedMaterializedRunFromTable + exact relTriple_finishObservedMaterialized_of_rootOrDoomed table _ _ + (relTriple_granularAllCanonical_observedMaterialized_rootOrDoomed adversary parameter ftsSecret + q table hbound) + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_sampledGranularAllCanonical_finishedMaterialized_rootRel + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + RelTriple + (sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q) + (sampledObservedMaterializedClean adversary parameter ftsSecret (2 * q)) + SnapshotObservedRootRel := by + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot sampledObservedMaterializedClean + change RelTriple + (sampleOtsHashTable >>= fun table => + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q) + (sampleOtsHashTable >>= fun table => + finishedObservedMaterializedRunFromTable adversary parameter ftsSecret (2 * q) table) + SnapshotObservedRootRel + apply relTriple_bind (relTriple_refl sampleOtsHashTable) + intro leftTable rightTable htable + subst rightTable + exact relTriple_granularAllCanonical_finishedMaterialized_rootRel adversary parameter ftsSecret q + leftTable (hbound leftTable) + +theorem probEvent_sampledGranularAllCanonical_root_le_materializedFailure_add_delayed + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + Pr[fun output => + WitnessFirstUsesSomeLayerRoot (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + Pr[= none | sampledObservedMaterializedClean adversary parameter ftsSecret (2 * q)] + + Pr[WitnessFirstUsesSomeDelayedLayerRootSnapshot | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := by + exact probEvent_root_le_observedFailure_add_delayed_of_relTriple _ _ + (relTriple_sampledGranularAllCanonical_finishedMaterialized_rootRel adversary parameter + ftsSecret q hbound) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSampleBase.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSampleBase.lean new file mode 100644 index 00000000..8c124a44 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSampleBase.lean @@ -0,0 +1,134 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalFinish + +/-! +# Fixed-table and sampled materialized comparison + +The completed fixed-table comparison is named here before its source invariant and observation +tracking are compiled in separate modules. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +noncomputable def sampledGranularAllCanonicalPrivateWitnessSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp PrivateWitnessSnapshotOutput := do + let table ← sampleOtsHashTable + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel + +noncomputable def finishedObservedMaterializedRunFromTable + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))) := + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table >>= + finishObservedMaterializedCleanRunFromTable table + +theorem relTriple_granularAllCanonical_finishedMaterialized + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + RelTriple + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q) + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table >>= + finishObservedMaterializedCleanRunFromTable table) + (SnapshotObservedPrefixValueRel table) := + relTriple_finishObservedMaterialized_of_stable table _ _ + (relTriple_granularAllSnapshot_observedMaterializedRetained adversary parameter ftsSecret q + table hbound) + +theorem relTriple_granularAllCanonical_finishedMaterializedRunFromTable + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + RelTriple + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q) + (finishedObservedMaterializedRunFromTable adversary parameter ftsSecret (2 * q) table) + (SnapshotObservedPrefixValueRel table) := by + unfold finishedObservedMaterializedRunFromTable + exact relTriple_granularAllCanonical_finishedMaterialized adversary parameter ftsSecret q table + hbound + +set_option maxRecDepth 100000 in +theorem relTriple_sampledGranularAllCanonical_finishedMaterialized + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + RelTriple + (sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q) + (sampledObservedMaterializedClean adversary parameter ftsSecret (2 * q)) + (fun source observed => ∃ table, SnapshotObservedPrefixValueRel table source observed) := by + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot sampledObservedMaterializedClean + apply relTriple_bind (relTriple_refl sampleOtsHashTable) + intro leftTable rightTable htable + subst rightTable + apply relTriple_post_mono + (relTriple_granularAllCanonical_finishedMaterialized adversary parameter ftsSecret q leftTable + (hbound leftTable)) + intro source observed hrelation + exact ⟨leftTable, hrelation⟩ + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem sourceSnapshotStopInvariant_of_mem_granularAllCanonical + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel)) : + SourceSnapshotStopInvariant output := by + change output ∈ support (runDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table + (granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter + table ftsSecret)) [] emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) at houtput + have hbefore : SnapshotsBefore ([] : List PlannedProbeSnapshot) emptyWitnessDeferredContext := + SnapshotsBefore.nil emptyWitnessDeferredContext + have hpreserves : DirectWitnessPreservesPublished maskedPublishedTreeRoot := + directWitnessPreservesPublished_maskedPublishedTreeRoot + have hpreservesResult := fun result => + hpreserves.result emptyWitnessDeferredContext emptySplitHashCache fuel table result + publishedValues_empty + apply sourceSnapshotStopInvariant_of_mem_runDirectWitnessSnapshotObserve + (observe := canonicalizeDirectWitnessSnapshotObserve table + (granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter + table ftsSecret)) + (snapshots := []) (context := emptyWitnessDeferredContext) (fuel := fuel) (table := table) + (computation := maskedPublishedTreeRoot.run emptySplitHashCache) + hbefore hpreservesResult _ output houtput + intro result nextOutput _ hnextBefore hpublished hnext + apply sourceSnapshotStopInvariant_of_mem_canonicalizeDirectWitnessSnapshotObserve table _ + result.context result.remaining result.value [] hnextBefore hpublished _ nextOutput hnext + intro finalOutput hfinal + exact sourceSnapshotStopInvariant_of_mem_granularDetailedRetainedRest adversary parameter table + ftsSecret (canonicalizeMaterializedValues table result.context) result.remaining result.value [] + (hnextBefore.canonicalize_right table) hpublished.to_canonicalizedMaterializedValues + finalOutput hfinal + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSampleTracking.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSampleTracking.lean new file mode 100644 index 00000000..f41f3cc6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSampleTracking.lean @@ -0,0 +1,561 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSampleBase + +/-! +# Materialized comparison observation tracking + +Successful observed executions preserve the tracking invariant through the retained runner and its +guarded clean finalizer. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option maxRecDepth 100000 in +theorem cleanProbeObservationsTrackedBy_of_mem_observedMaterializedBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (htracked : CleanProbeObservationsTrackedBy observations state) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hresult : some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache)) : + CleanProbeObservationsTrackedBy result.observations result.state := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table cache with + | pure value => + simp [observedMaterializedBoundary] at hresult + obtain rfl := hresult + exact htracked + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind] at hresult + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + exact ih step.value.1 step.observations step.state step.remaining table + step.value.2 + (cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run cache) observations state fuel table htracked step + hstep) + (by simpa only [observedMaterializedBoundary] using hrest) + | inr input => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + exact ih step.value.1 step.observations step.state step.remaining table + step.value.2 + (cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache) observations state fuel table htracked step hstep) + (by simpa only [observedMaterializedBoundary] using hrest) + | inr message => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + exact ih step.value.1 step.observations step.state step.remaining table step.value.2 + (cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + ((maskedSign parameter root ftsSecret message).run cache) observations state fuel + table htracked step hstep) + (by simpa only [observedMaterializedBoundary] using hrest) + +set_option maxRecDepth 100000 in +theorem cleanProbeObservationsCoverPending_of_mem_observedMaterializedBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcovered : CleanProbeObservationsCoverPending observations state) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hresult : some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache)) : + CleanProbeObservationsCoverPending result.observations result.state := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table cache with + | pure value => + simp [observedMaterializedBoundary] at hresult + obtain rfl := hresult + exact hcovered + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind] at hresult + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + exact ih step.value.1 step.observations step.state step.remaining table + step.value.2 + (cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run cache) observations state fuel table hcovered step + hstep) + (by simpa only [observedMaterializedBoundary] using hrest) + | inr input => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + exact ih step.value.1 step.observations step.state step.remaining table + step.value.2 + (cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache) observations state fuel table hcovered step hstep) + (by simpa only [observedMaterializedBoundary] using hrest) + | inr message => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + exact ih step.value.1 step.observations step.state step.remaining table step.value.2 + (cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + ((maskedSign parameter root ftsSecret message).run cache) observations state fuel + table hcovered step hstep) + (by simpa only [observedMaterializedBoundary] using hrest) + +set_option maxRecDepth 100000 in +theorem remaining_add_pending_card_le_of_mem_observedMaterializedBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hresult : some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache)) : + result.remaining + result.state.pending.card ≤ fuel + state.pending.card := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table cache with + | pure value => + simp [observedMaterializedBoundary] at hresult + obtain rfl := hresult + simp + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind] at hresult + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + have hfirst := remaining_add_pending_card_le_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run cache) observations state fuel table step hstep + have htail := ih step.value.1 step.observations step.state step.remaining table + step.value.2 (by simpa only [observedMaterializedBoundary] using hrest) + omega + | inr input => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + have hfirst := remaining_add_pending_card_le_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache) observations state fuel table step hstep + have htail := ih step.value.1 step.observations step.state step.remaining table + step.value.2 (by simpa only [observedMaterializedBoundary] using hrest) + omega + | inr message => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + have hfirst := remaining_add_pending_card_le_of_mem_runObservedCleanFromTable + ((maskedSign parameter root ftsSecret message).run cache) observations state fuel + table step hstep + have htail := ih step.value.1 step.observations step.state step.remaining table + step.value.2 (by simpa only [observedMaterializedBoundary] using hrest) + omega + +set_option maxRecDepth 100000 in +theorem observations_length_add_remaining_eq_of_mem_observedMaterializedBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hresult : some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache)) : + result.observations.length + result.remaining = observations.length + fuel := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table cache with + | pure value => + simp [observedMaterializedBoundary] at hresult + obtain rfl := hresult + rfl + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind] at hresult + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + have hfirst := + observations_length_add_remaining_eq_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run cache) observations state fuel table step hstep + have htail := ih step.value.1 step.observations step.state step.remaining table + step.value.2 (by simpa only [observedMaterializedBoundary] using hrest) + omega + | inr input => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + have hfirst := + observations_length_add_remaining_eq_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache) observations state fuel table step hstep + have htail := ih step.value.1 step.observations step.state step.remaining table + step.value.2 (by simpa only [observedMaterializedBoundary] using hrest) + omega + | inr message => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + have hfirst := + observations_length_add_remaining_eq_of_mem_runObservedCleanFromTable + ((maskedSign parameter root ftsSecret message).run cache) observations state fuel + table step hstep + have htail := ih step.value.1 step.observations step.state step.remaining table + step.value.2 (by simpa only [observedMaterializedBoundary] using hrest) + omega + +set_option maxRecDepth 100000 in +theorem startTableAgrees_of_mem_observedMaterializedBoundary + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hagrees : StartTableAgrees state table) + (result : ObservedCleanRunResult (α × SplitHashCache)) + (hresult : some result ∈ support + (observedMaterializedBoundary parameter root ftsSecret computation observations state fuel + table cache)) : + result.table = table ∧ StartTableAgrees result.state table := by + induction computation using OracleComp.inductionOn generalizing + observations state fuel table cache with + | pure value => + simp [observedMaterializedBoundary] at hresult + obtain rfl := hresult + exact ⟨rfl, hagrees⟩ + | query_bind query next ih => + rw [observedMaterializedBoundary, OracleComp.construct_query_bind] at hresult + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + have hfirst := startTableAgrees_of_mem_runObservedCleanFromTable + ((splitUniformImpl n).run cache) observations state fuel table hagrees step + hstep + exact ih step.value.1 step.observations step.state step.remaining table + step.value.2 hfirst.2 + (by simpa only [observedMaterializedBoundary] using hrest) + | inr input => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + have hfirst := startTableAgrees_of_mem_runObservedCleanFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state + plan).run cache) observations state fuel table hagrees step hstep + exact ih step.value.1 step.observations step.state step.remaining table + step.value.2 hfirst.2 + (by simpa only [observedMaterializedBoundary] using hrest) + | inr message => + rw [mem_support_bind_iff] at hresult + obtain ⟨step?, hstep, hrest⟩ := hresult + cases step? with + | none => simp at hrest + | some step => + have hfirst := startTableAgrees_of_mem_runObservedCleanFromTable + ((maskedSign parameter root ftsSecret message).run cache) observations state fuel + table hagrees step hstep + exact ih step.value.1 step.observations step.state step.remaining table step.value.2 + hfirst.2 (by simpa only [observedMaterializedBoundary] using hrest) + +def ObservedMaterializedOutputTracked : + Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) → Prop + | none => True + | some result => + CleanProbeObservationsTrackedBy result.observations result.state + +def ObservedMaterializedOutputCovered : + Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) → Prop + | none => True + | some result => + CleanProbeObservationsCoverPending result.observations result.state + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxRecDepth 100000 in +theorem observedMaterializedOutputTracked_of_mem_retainedRunFromTable + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (output : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))) + (houtput : output ∈ support + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table)) : + ObservedMaterializedOutputTracked output := by + unfold observedMaterializedRetainedRunFromTable at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨rootResult?, hroot, hrest⟩ := houtput + cases rootResult? with + | none => + simp at hrest + subst output + trivial + | some rootResult => + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult?, hrestResult, hreturn⟩ := hrest + cases restResult? with + | none => + simp at hreturn + subst output + trivial + | some restResult => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + subst output + have hrootTracked : + CleanProbeObservationsTrackedBy rootResult.observations rootResult.state := + cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty + fuel table (by intro observation hobservation; simp at hobservation) rootResult hroot + exact cleanProbeObservationsTrackedBy_of_mem_observedMaterializedBoundary parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table rootResult.value.2 + hrootTracked restResult hrestResult + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxRecDepth 100000 in +theorem observedMaterializedOutputCovered_of_mem_retainedRunFromTable + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (output : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache))) + (houtput : output ∈ support + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table)) : + ObservedMaterializedOutputCovered output := by + unfold observedMaterializedRetainedRunFromTable at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨rootResult?, hroot, hrest⟩ := houtput + cases rootResult? with + | none => + simp at hrest + subst output + trivial + | some rootResult => + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult?, hrestResult, hreturn⟩ := hrest + cases restResult? with + | none => + simp at hreturn + subst output + trivial + | some restResult => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + subst output + have hrootCovered : + CleanProbeObservationsCoverPending rootResult.observations rootResult.state := + cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) [] + LazyRevealProbe.State.empty fuel table (by + intro entry hentry + have : False := by + simpa [directDeferredContext, LazyRevealProbe.State.empty] using hentry + contradiction) rootResult hroot + exact cleanProbeObservationsCoverPending_of_mem_observedMaterializedBoundary parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table rootResult.value.2 + hrootCovered restResult hrestResult + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxRecDepth 100000 in +theorem pending_card_le_fuel_of_mem_observedMaterializedRetainedRunFromTable + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) + (hresult : some result ∈ support + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table)) : + result.state.pending.card ≤ fuel := by + unfold observedMaterializedRetainedRunFromTable at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨rootResult?, hroot, hrest⟩ := hresult + cases rootResult? with + | none => simp at hrest + | some rootResult => + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult?, hrestResult, hreturn⟩ := hrest + cases restResult? with + | none => simp at hreturn + | some restResult => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + obtain rfl := Option.some.inj hreturn + have hrootBudget := remaining_add_pending_card_le_of_mem_runObservedCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty fuel + table rootResult hroot + have hrootBudget' : + rootResult.remaining + rootResult.state.pending.card ≤ fuel := by + simpa [LazyRevealProbe.State.empty] using hrootBudget + have hrestBudget := + remaining_add_pending_card_le_of_mem_observedMaterializedBoundary parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table rootResult.value.2 + restResult hrestResult + change restResult.state.pending.card ≤ fuel + omega + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxRecDepth 100000 in +theorem observations_length_le_fuel_of_mem_observedMaterializedRetainedRunFromTable + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) + (hresult : some result ∈ support + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table)) : + result.observations.length ≤ fuel := by + unfold observedMaterializedRetainedRunFromTable at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨rootResult?, hroot, hrest⟩ := hresult + cases rootResult? with + | none => simp at hrest + | some rootResult => + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult?, hrestResult, hreturn⟩ := hrest + cases restResult? with + | none => simp at hreturn + | some restResult => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + obtain rfl := Option.some.inj hreturn + have hrootLength := + observations_length_add_remaining_eq_of_mem_runObservedCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty fuel + table rootResult hroot + have hrestLength := + observations_length_add_remaining_eq_of_mem_observedMaterializedBoundary parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table rootResult.value.2 + restResult hrestResult + simp only [List.length_nil, Nat.zero_add] at hrootLength + change restResult.observations.length ≤ fuel + omega + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxRecDepth 100000 in +theorem table_eq_and_startTableAgrees_of_mem_observedMaterializedRetainedRunFromTable + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) + (hresult : some result ∈ support + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table)) : + result.table = table ∧ StartTableAgrees result.state table := by + unfold observedMaterializedRetainedRunFromTable at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨rootResult?, hroot, hrest⟩ := hresult + cases rootResult? with + | none => simp at hrest + | some rootResult => + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult?, hrestResult, hreturn⟩ := hrest + cases restResult? with + | none => simp at hreturn + | some restResult => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + obtain rfl := Option.some.inj hreturn + have hrootAgrees := startTableAgrees_of_mem_runObservedCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty fuel + table (startTableAgrees_empty table) rootResult hroot + exact startTableAgrees_of_mem_observedMaterializedBoundary parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table rootResult.value.2 + hrootAgrees.2 restResult hrestResult + +attribute [local irreducible] observedMaterializedRetainedRunFromTable in +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_and_observedMaterializedOutputTracked + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (source : ProbComp α) + (relation : α → Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) → Prop) + (hrelation : RelTriple source + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table) + relation) : + RelTriple source + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table) + (fun left right => relation left right ∧ ObservedMaterializedOutputTracked right) := by + have hright := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hrelation + apply relTriple_post_mono hright + intro left right hfacts + exact ⟨hfacts.1, + observedMaterializedOutputTracked_of_mem_retainedRunFromTable + (adversary := adversary) (parameter := parameter) (ftsSecret := ftsSecret) + (fuel := fuel) (table := table) (output := right) hfacts.2⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSource.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSource.lean new file mode 100644 index 00000000..fea860a2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSource.lean @@ -0,0 +1,629 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobal + +/-! +# Context-annotated root source trace + +The global clean split needs a residual event on the source run. Each planned candidate therefore +retains the deferred context in which it was created. Erasing those contexts recovers the existing +private witness plan exactly. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +structure PlannedProbeSnapshot where + probe : Probe + context : DeferredContext + +abbrev PrivateWitnessSnapshotOutput := + Option PrivateHitWitness × List PlannedProbeSnapshot + +@[simp] def PlannedProbeSnapshot.toProbe (snapshot : PlannedProbeSnapshot) : Probe := + snapshot.probe + +def erasePrivateWitnessSnapshotOutput + (output : PrivateWitnessSnapshotOutput) : PrivateWitnessPlanOutput := + (output.1, output.2.map PlannedProbeSnapshot.toProbe) + +def appendPlannedSnapshot + (snapshots : List PlannedProbeSnapshot) (candidate? : Option Probe) + (context : DeferredContext) : List PlannedProbeSnapshot := + match candidate? with + | none => snapshots + | some candidate => snapshots ++ [⟨candidate, context⟩] + +@[simp] theorem map_toProbe_appendPlannedSnapshot + (snapshots : List PlannedProbeSnapshot) (candidate? : Option Probe) + (context : DeferredContext) : + (appendPlannedSnapshot snapshots candidate? context).map PlannedProbeSnapshot.toProbe = + appendPlannedCandidate (snapshots.map PlannedProbeSnapshot.toProbe) candidate? := by + cases candidate? <;> simp [appendPlannedSnapshot, appendPlannedCandidate] + +noncomputable def finishDirectWitnessSnapshotObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) : DirectWitnessResult α → + ProbComp PrivateWitnessSnapshotOutput + | .stoppedFuel => pure (none, snapshots) + | .stoppedOrdinary => pure (none, snapshots) + | .stoppedPrivate witness => pure (some witness, snapshots) + | .done result => observe result.context result.remaining result.value snapshots + +noncomputable def classifyDirectWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (context : DeferredContext) (fuel : Nat) (value : α) + (snapshots : List PlannedProbeSnapshot) : + ProbComp PrivateWitnessSnapshotOutput := by + classical + exact if hhit : PrivateStructuralHit context then + pure (some (privateHitWitnessOf context hhit), snapshots) + else if DeferredCompletable table context then + observe context fuel value snapshots + else + pure (none, snapshots) + +noncomputable def canonicalizeDirectWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (context : DeferredContext) (fuel : Nat) (value : α) + (snapshots : List PlannedProbeSnapshot) : + ProbComp PrivateWitnessSnapshotOutput := by + classical + let canonical := canonicalizeMaterializedValues table context + exact if hhit : PrivateStructuralHit canonical then + pure (some (privateHitWitnessOf canonical hhit), snapshots) + else if PublishedValues context.state then + classifyDirectWitnessSnapshotObserve table observe canonical fuel value snapshots + else + pure (none, snapshots) + +noncomputable def runDirectWitnessSnapshotObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + ProbComp PrivateWitnessSnapshotOutput := + runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectWitnessSnapshotObserve observe snapshots + +theorem map_erase_finishDirectWitnessSnapshotObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (planObserve : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (snapshots : List PlannedProbeSnapshot) (result : DirectWitnessResult α) + (hproject : ∀ context fuel value snapshots, + erasePrivateWitnessSnapshotOutput <$> observe context fuel value snapshots = + planObserve context fuel value + (snapshots.map PlannedProbeSnapshot.toProbe)) : + erasePrivateWitnessSnapshotOutput <$> + finishDirectWitnessSnapshotObserve observe snapshots result = + finishDirectWitnessPlanObserve planObserve + (snapshots.map PlannedProbeSnapshot.toProbe) result := by + cases result with + | stoppedFuel => simp [finishDirectWitnessSnapshotObserve, + finishDirectWitnessPlanObserve, erasePrivateWitnessSnapshotOutput] + | stoppedOrdinary => simp [finishDirectWitnessSnapshotObserve, + finishDirectWitnessPlanObserve, erasePrivateWitnessSnapshotOutput] + | stoppedPrivate witness => simp [finishDirectWitnessSnapshotObserve, + finishDirectWitnessPlanObserve, erasePrivateWitnessSnapshotOutput] + | done result => exact hproject result.context result.remaining result.value snapshots + +theorem map_erase_classifyDirectWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (planObserve : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (context : DeferredContext) (fuel : Nat) (value : α) + (snapshots : List PlannedProbeSnapshot) + (hproject : ∀ nextContext remaining nextValue nextSnapshots, + erasePrivateWitnessSnapshotOutput <$> + observe nextContext remaining nextValue nextSnapshots = + planObserve nextContext remaining nextValue + (nextSnapshots.map PlannedProbeSnapshot.toProbe)) : + erasePrivateWitnessSnapshotOutput <$> + classifyDirectWitnessSnapshotObserve table observe context fuel value snapshots = + classifyDirectWitnessPlanObserve table planObserve context fuel value + (snapshots.map PlannedProbeSnapshot.toProbe) := by + classical + unfold classifyDirectWitnessSnapshotObserve classifyDirectWitnessPlanObserve + by_cases hhit : PrivateStructuralHit context + · simp [hhit, erasePrivateWitnessSnapshotOutput] + · simp only [hhit, ↓reduceDIte] + by_cases hcompletable : DeferredCompletable table context + · simp only [hcompletable, ↓reduceIte] + exact hproject context fuel value snapshots + · simp [hcompletable, erasePrivateWitnessSnapshotOutput] + +theorem map_erase_canonicalizeDirectWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (planObserve : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (context : DeferredContext) (fuel : Nat) (value : α) + (snapshots : List PlannedProbeSnapshot) + (hproject : ∀ nextContext remaining nextValue nextSnapshots, + erasePrivateWitnessSnapshotOutput <$> + observe nextContext remaining nextValue nextSnapshots = + planObserve nextContext remaining nextValue + (nextSnapshots.map PlannedProbeSnapshot.toProbe)) : + erasePrivateWitnessSnapshotOutput <$> + canonicalizeDirectWitnessSnapshotObserve table observe context fuel value snapshots = + canonicalizeDirectWitnessPlanObserve table planObserve context fuel value + (snapshots.map PlannedProbeSnapshot.toProbe) := by + classical + unfold canonicalizeDirectWitnessSnapshotObserve canonicalizeDirectWitnessPlanObserve + let canonical := canonicalizeMaterializedValues table context + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit, erasePrivateWitnessSnapshotOutput] + · simp only [canonical, hhit, ↓reduceDIte] + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + exact map_erase_classifyDirectWitnessSnapshotObserve table observe planObserve canonical + fuel value snapshots hproject + · simp [hpublished, erasePrivateWitnessSnapshotOutput] + +theorem map_erase_runDirectWitnessSnapshotObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (planObserve : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (snapshots : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hproject : ∀ nextContext remaining value nextSnapshots, + erasePrivateWitnessSnapshotOutput <$> + observe nextContext remaining value nextSnapshots = + planObserve nextContext remaining value + (nextSnapshots.map PlannedProbeSnapshot.toProbe)) : + erasePrivateWitnessSnapshotOutput <$> + runDirectWitnessSnapshotObserve observe snapshots context fuel table computation = + runDirectWitnessPlanObserve planObserve + (snapshots.map PlannedProbeSnapshot.toProbe) context fuel table computation := by + unfold runDirectWitnessSnapshotObserve runDirectWitnessPlanObserve + rw [map_bind] + apply bind_congr + intro result + exact map_erase_finishDirectWitnessSnapshotObserve observe planObserve snapshots result hproject + +noncomputable def directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp PrivateWitnessSnapshotOutput := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + (DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → ProbComp PrivateWitnessSnapshotOutput) → + List PlannedProbeSnapshot → DeferredContext → Nat → + (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp PrivateWitnessSnapshotOutput) + (fun value observe snapshots context fuel _table cache => + observe context fuel (value, cache) snapshots) + (fun query _next recursivelyRun observe snapshots context fuel table cache => + match query with + | .inl (.inl n) => + runDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table + (fun nextContext remaining value nextSnapshots => + recursivelyRun value.1 observe nextSnapshots nextContext remaining table + value.2)) + snapshots context fuel table ((splitUniformImpl n).run cache) + | .inl (.inr input) => + let plan := purePlanProbingHashQuery parameter input context.state + let nextSnapshots := appendPlannedSnapshot snapshots + (rootAwarePlannedCandidate? parameter input context.state) context + runDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table + (fun nextContext remaining value laterSnapshots => + recursivelyRun value.1 observe laterSnapshots nextContext remaining table + value.2)) + nextSnapshots context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) + | .inr message => + runDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table + (fun nextContext remaining value nextSnapshots => + recursivelyRun value.1 observe nextSnapshots nextContext remaining table + value.2)) + snapshots context fuel table + ((maskedSign parameter root ftsSecret message).run cache)) + computation observe snapshots context fuel table cache + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem map_erase_directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → ProbComp PrivateWitnessSnapshotOutput) + (planObserve : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp PrivateWitnessPlanOutput) + (snapshots : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hproject : ∀ nextContext remaining value nextSnapshots, + erasePrivateWitnessSnapshotOutput <$> + observe nextContext remaining value nextSnapshots = + planObserve nextContext remaining value + (nextSnapshots.map PlannedProbeSnapshot.toProbe)) : + erasePrivateWitnessSnapshotOutput <$> + directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root ftsSecret + computation observe snapshots context fuel table cache = + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + computation planObserve (snapshots.map PlannedProbeSnapshot.toProbe) context fuel table + cache := by + induction computation using OracleComp.inductionOn generalizing snapshots context fuel cache with + | pure value => + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_pure, + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, OracleComp.construct_pure] + exact hproject context fuel (value, cache) snapshots + | query_bind query next ih => + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_query_bind] + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind] + apply map_erase_runDirectWitnessSnapshotObserve + intro nextContext remaining value nextSnapshots + apply map_erase_canonicalizeDirectWitnessSnapshotObserve + intro finalContext finalRemaining finalValue finalSnapshots + exact ih finalValue.1 finalSnapshots finalContext finalRemaining finalValue.2 + | inr input => + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_query_bind] + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind] + let plan := purePlanProbingHashQuery parameter input context.state + let nextSnapshots := appendPlannedSnapshot snapshots + (rootAwarePlannedCandidate? parameter input context.state) context + dsimp only + rw [← map_toProbe_appendPlannedSnapshot] + apply map_erase_runDirectWitnessSnapshotObserve + intro nextContext remaining value laterSnapshots + apply map_erase_canonicalizeDirectWitnessSnapshotObserve + intro finalContext finalRemaining finalValue finalSnapshots + exact ih finalValue.1 finalSnapshots finalContext finalRemaining finalValue.2 + | inr message => + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_query_bind] + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind] + apply map_erase_runDirectWitnessSnapshotObserve + intro nextContext remaining value nextSnapshots + apply map_erase_canonicalizeDirectWitnessSnapshotObserve + intro finalContext finalRemaining finalValue finalSnapshots + exact ih finalValue.1 finalSnapshots finalContext finalRemaining finalValue.2 + +noncomputable def retainedResolvedFinalizationPrivateWitnessSnapshotObserve + (_table : OtsSecretIndex → HashOutput) (_root : Digest) + (context : DeferredContext) (_fuel : Nat) + (_value : RetainedRestResult × SplitHashCache) + (snapshots : List PlannedProbeSnapshot) : + ProbComp PrivateWitnessSnapshotOutput := by + classical + exact if hhit : PrivateStructuralHit context then + pure (some (privateHitWitnessOf context hhit), snapshots) + else + pure (none, snapshots) + +theorem map_erase_retainedResolvedFinalizationPrivateWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) + (snapshots : List PlannedProbeSnapshot) : + erasePrivateWitnessSnapshotOutput <$> + retainedResolvedFinalizationPrivateWitnessSnapshotObserve table root context fuel value + snapshots = + retainedResolvedFinalizationPrivateWitnessPlanObserve table root context fuel value + (snapshots.map PlannedProbeSnapshot.toProbe) := by + classical + unfold retainedResolvedFinalizationPrivateWitnessSnapshotObserve + retainedResolvedFinalizationPrivateWitnessPlanObserve + by_cases hhit : PrivateStructuralHit context <;> + simp [hhit, erasePrivateWitnessSnapshotOutput] + +noncomputable def granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (snapshots : List PlannedProbeSnapshot) : + ProbComp PrivateWitnessSnapshotOutput := + directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table value.1) + snapshots context fuel table value.2 + +theorem map_erase_granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (snapshots : List PlannedProbeSnapshot) : + erasePrivateWitnessSnapshotOutput <$> + granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter + table ftsSecret context fuel value snapshots = + granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value (snapshots.map PlannedProbeSnapshot.toProbe) := by + unfold granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve + granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve + apply map_erase_directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve + intro nextContext remaining nextValue nextSnapshots + exact map_erase_retainedResolvedFinalizationPrivateWitnessSnapshotObserve table value.1 + nextContext remaining nextValue nextSnapshots + +noncomputable def granularAllDirectBoundaryNormalizedPrivateWitnessSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp PrivateWitnessSnapshotOutput := + runDirectWitnessSnapshotObserve + (granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter table + ftsSecret) + [] + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +theorem map_erase_granularAllDirectBoundaryNormalizedPrivateWitnessSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + erasePrivateWitnessSnapshotOutput <$> + granularAllDirectBoundaryNormalizedPrivateWitnessSnapshot adversary parameter table + ftsSecret fuel = + granularAllDirectBoundaryNormalizedPrivateWitnessPlan adversary parameter table ftsSecret + fuel := by + unfold granularAllDirectBoundaryNormalizedPrivateWitnessSnapshot + granularAllDirectBoundaryNormalizedPrivateWitnessPlan + apply map_erase_runDirectWitnessSnapshotObserve + intro nextContext remaining value nextSnapshots + exact map_erase_granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary + parameter table ftsSecret nextContext remaining value nextSnapshots + +noncomputable def sampledGranularAllDirectBoundaryNormalizedPrivateWitnessSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp PrivateWitnessSnapshotOutput := do + let table ← sampleOtsHashTable + granularAllDirectBoundaryNormalizedPrivateWitnessSnapshot adversary parameter table ftsSecret + fuel + +theorem map_erase_sampledGranularAllDirectBoundaryNormalizedPrivateWitnessSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + erasePrivateWitnessSnapshotOutput <$> + sampledGranularAllDirectBoundaryNormalizedPrivateWitnessSnapshot adversary parameter + ftsSecret fuel = + sampledGranularAllDirectBoundaryNormalizedPrivateWitnessPlan adversary parameter ftsSecret + fuel := by + unfold sampledGranularAllDirectBoundaryNormalizedPrivateWitnessSnapshot + sampledGranularAllDirectBoundaryNormalizedPrivateWitnessPlan + rw [map_bind] + apply bind_congr + intro table + exact map_erase_granularAllDirectBoundaryNormalizedPrivateWitnessSnapshot adversary parameter + table ftsSecret fuel + +def snapshotProbeOrdinal + {snapshots : List PlannedProbeSnapshot} (ordinal : Fin snapshots.length) : + Fin (snapshots.map PlannedProbeSnapshot.toProbe).length := + ⟨ordinal.val, by + rw [List.length_map] + exact ordinal.isLt⟩ + +@[simp] theorem snapshotProbeOrdinal_val + {snapshots : List PlannedProbeSnapshot} (ordinal : Fin snapshots.length) : + (snapshotProbeOrdinal ordinal).val = ordinal.val := rfl + +def privateOrdinalSelectionOfSnapshot + {snapshots : List PlannedProbeSnapshot} (ordinal : Fin snapshots.length) : + PrivateOrdinalSelection := + { candidate := (snapshots.get ordinal).probe + context := (snapshots.get ordinal).context + candidates := + (snapshots.take (ordinal.val + 1)).map PlannedProbeSnapshot.toProbe } + +noncomputable def selectedPrivateSnapshotOrdinal? + (ordinal : Nat) (snapshots : List PlannedProbeSnapshot) : + Option PrivateOrdinalSelection := + if hselected : ordinal < snapshots.length then + some (privateOrdinalSelectionOfSnapshot ⟨ordinal, hselected⟩) + else none + +@[simp] theorem privateOrdinalSelectionOfSnapshot_candidate + {snapshots : List PlannedProbeSnapshot} (ordinal : Fin snapshots.length) : + (privateOrdinalSelectionOfSnapshot ordinal).candidate = + (snapshots.map PlannedProbeSnapshot.toProbe).get (snapshotProbeOrdinal ordinal) := by + simp [privateOrdinalSelectionOfSnapshot, snapshotProbeOrdinal] + +@[simp] theorem privateOrdinalSelectionOfSnapshot_context + {snapshots : List PlannedProbeSnapshot} (ordinal : Fin snapshots.length) : + (privateOrdinalSelectionOfSnapshot ordinal).context = + (snapshots.get ordinal).context := rfl + +theorem privateOrdinalSelectionOfSnapshot_candidates + {snapshots : List PlannedProbeSnapshot} (ordinal : Fin snapshots.length) : + (privateOrdinalSelectionOfSnapshot ordinal).candidates = + (snapshots.map PlannedProbeSnapshot.toProbe).take (ordinal.val + 1) := by + simp [privateOrdinalSelectionOfSnapshot, List.map_take] + +theorem privateOrdinalSelectionOfSnapshot_candidates_take + {snapshots : List PlannedProbeSnapshot} (ordinal : Fin snapshots.length) : + (privateOrdinalSelectionOfSnapshot ordinal).candidates.take ordinal.val = + (snapshots.map PlannedProbeSnapshot.toProbe).take ordinal.val := by + rw [privateOrdinalSelectionOfSnapshot_candidates, List.take_take] + simp + +theorem selectedPrivateSnapshotOrdinal?_eq_some + {ordinal : Nat} {snapshots : List PlannedProbeSnapshot} + (hselected : ordinal < snapshots.length) : + selectedPrivateSnapshotOrdinal? ordinal snapshots = + some (privateOrdinalSelectionOfSnapshot ⟨ordinal, hselected⟩) := by + simp [selectedPrivateSnapshotOrdinal?, hselected] + +def WitnessFirstUsesDelayedLayerRootSnapshotOrdinal + (ordinal : Nat) (output : PrivateWitnessSnapshotOutput) : Prop := + ∃ witness, ∃ sourceOrdinal : Fin output.2.length, + output.1 = some witness ∧ sourceOrdinal.val = ordinal ∧ + firstPrivateWitnessOrdinal? witness + (output.2.map PlannedProbeSnapshot.toProbe) = + some (snapshotProbeOrdinal sourceOrdinal) ∧ + (output.2.get sourceOrdinal).probe.IsLayerRoot ∧ + (output.2.get sourceOrdinal).context.state.values + (.position witness.position) = none ∧ + Coordinate.position witness.position ∉ + (output.2.get sourceOrdinal).context.state.revealed ∧ + (output.2.get sourceOrdinal).context.values witness.position = + some witness.output + +def WitnessFirstUsesSomeDelayedLayerRootSnapshot + (output : PrivateWitnessSnapshotOutput) : Prop := + ∃ ordinal, WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal output + +def CandidatesAvoidRoot + (target : Position) (root : Digest) (candidates : List Probe) : Prop := + ∀ candidate ∈ candidates, candidate ≠ ⟨.position target, root⟩ + +theorem candidatesTake_avoid_witnessRoot_of_first + {ordinal : Nat} {output : PrivateWitnessPlanOutput} + {witness : PrivateHitWitness} + (hfirst : WitnessFirstUsesOrdinal ordinal output) + (hwitness : output.1 = some witness) : + CandidatesAvoidRoot witness.position (truncateHash witness.output) + (output.2.take ordinal) := by + intro candidate hcandidate heq + obtain ⟨prefixOrdinal, hget⟩ := List.mem_iff_get.mp hcandidate + have htakeLength : (output.2.take ordinal).length = + min ordinal output.2.length := List.length_take + have hltLength : prefixOrdinal.val < output.2.length := by + omega + let earlier : Fin output.2.length := ⟨prefixOrdinal.val, hltLength⟩ + have hgetFull : output.2.get earlier = candidate := by + rw [← hget] + simp [earlier] + have hltOrdinal : earlier.val < ordinal := by + dsimp only [earlier] + omega + have hcoordinate : (output.2.get earlier).coordinate = + Coordinate.position witness.position := by + rw [hgetFull, heq] + have hne := earlier_candidate_ne_of_witnessFirstUsesOrdinal hfirst witness hwitness earlier + hltOrdinal witness.position hcoordinate rfl + rw [hgetFull, heq] at hne + exact hne rfl + +theorem candidatesAvoidRoots_of_first_of_avoid_right + {ordinal : Nat} {output : PrivateWitnessPlanOutput} + {witness : PrivateHitWitness} {rightRoot : Digest} + (hfirst : WitnessFirstUsesOrdinal ordinal output) + (hwitness : output.1 = some witness) + (hright : CandidatesAvoidRoot witness.position rightRoot + (output.2.take ordinal)) : + CandidatesAvoidRoots witness.position (truncateHash witness.output) rightRoot + (output.2.take ordinal) := by + intro candidate hcandidate + exact ⟨candidatesTake_avoid_witnessRoot_of_first hfirst hwitness candidate hcandidate, + hright candidate hcandidate⟩ + +theorem witnessFirstUsesLayerRootOrdinal_erase_of_delayedSnapshot + {ordinal : Nat} {output : PrivateWitnessSnapshotOutput} + (hdelayed : WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal output) : + WitnessFirstUsesLayerRootOrdinal ordinal + (erasePrivateWitnessSnapshotOutput output) := by + obtain ⟨witness, sourceOrdinal, hwitness, hordinal, hfirst, hroot, + _hstate, _hrevealed, _hvalue⟩ := hdelayed + unfold erasePrivateWitnessSnapshotOutput + change (privateOrdinalSelectionOfSnapshot sourceOrdinal).candidate.IsLayerRoot at hroot + rw [privateOrdinalSelectionOfSnapshot_candidate] at hroot + exact ⟨witness, snapshotProbeOrdinal sourceOrdinal, hwitness, hordinal, + hfirst, hroot⟩ + +theorem privateOrdinalSelectionOfSnapshot_goodForRoots_of_delayed + {ordinal : Nat} {output : PrivateWitnessSnapshotOutput} + {witness : PrivateHitWitness} {sourceOrdinal : Fin output.2.length} + {rightRoot : Digest} + (_hwitness : output.1 = some witness) + (hordinal : sourceOrdinal.val = ordinal) + (hfirst : firstPrivateWitnessOrdinal? witness + (output.2.map PlannedProbeSnapshot.toProbe) = + some (snapshotProbeOrdinal sourceOrdinal)) + (hstate : (output.2.get sourceOrdinal).context.state.values + (.position witness.position) = none) + (hrevealed : Coordinate.position witness.position ∉ + (output.2.get sourceOrdinal).context.state.revealed) + (hvalue : (output.2.get sourceOrdinal).context.values witness.position = + some witness.output) + (havoid : CandidatesAvoidRoots witness.position (truncateHash witness.output) + rightRoot + ((output.2.map PlannedProbeSnapshot.toProbe).take ordinal)) : + (privateOrdinalSelectionOfSnapshot sourceOrdinal).GoodForRoots + witness.position witness.output rightRoot ordinal := by + subst ordinal + have hmatch := privateWitnessAtOrdinal_of_firstPrivateWitnessOrdinal?_eq_some hfirst + unfold PrivateWitnessAtOrdinal at hmatch + constructor + · rw [privateOrdinalSelectionOfSnapshot_candidate] + exact congrArg₂ Probe.mk hmatch.1 hmatch.2.symm + · refine ⟨hstate, hrevealed, hvalue, ?_⟩ + rw [privateOrdinalSelectionOfSnapshot_candidates_take] + exact havoid + +theorem selectedPrivateSnapshotOrdinal?_goodForRoots_of_delayed + {ordinal : Nat} {output : PrivateWitnessSnapshotOutput} + {rightRoot : Digest} + (hdelayed : WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal output) + (hright : ∀ witness sourceOrdinal, + output.1 = some witness → sourceOrdinal.val = ordinal → + firstPrivateWitnessOrdinal? witness + (output.2.map PlannedProbeSnapshot.toProbe) = + some (snapshotProbeOrdinal sourceOrdinal) → + CandidatesAvoidRoot witness.position rightRoot + ((output.2.map PlannedProbeSnapshot.toProbe).take ordinal)) : + ∃ witness sourceOrdinal, + output.1 = some witness ∧ sourceOrdinal.val = ordinal ∧ + firstPrivateWitnessOrdinal? witness + (output.2.map PlannedProbeSnapshot.toProbe) = + some (snapshotProbeOrdinal sourceOrdinal) ∧ + selectedPrivateSnapshotOrdinal? ordinal output.2 = + some (privateOrdinalSelectionOfSnapshot sourceOrdinal) ∧ + (privateOrdinalSelectionOfSnapshot sourceOrdinal).GoodForRoots + witness.position witness.output rightRoot ordinal := by + obtain ⟨witness, sourceOrdinal, hwitness, hordinal, hfirst, _hroot, + hstate, hrevealed, hvalue⟩ := hdelayed + have huses : WitnessFirstUsesOrdinal ordinal + (erasePrivateWitnessSnapshotOutput output) := by + unfold erasePrivateWitnessSnapshotOutput + exact ⟨witness, snapshotProbeOrdinal sourceOrdinal, hwitness, hordinal, hfirst⟩ + have havoid := candidatesAvoidRoots_of_first_of_avoid_right huses hwitness + (hright witness sourceOrdinal hwitness hordinal hfirst) + have hselected : ordinal < output.2.length := by + rw [← hordinal] + exact sourceOrdinal.isLt + have hselection : selectedPrivateSnapshotOrdinal? ordinal output.2 = + some (privateOrdinalSelectionOfSnapshot sourceOrdinal) := by + rw [selectedPrivateSnapshotOrdinal?_eq_some hselected] + congr + exact hordinal.symm + exact ⟨witness, sourceOrdinal, hwitness, hordinal, hfirst, hselection, + privateOrdinalSelectionOfSnapshot_goodForRoots_of_delayed hwitness hordinal hfirst hstate + hrevealed hvalue havoid⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceAssembly.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceAssembly.lean new file mode 100644 index 00000000..99e27ede --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceAssembly.lean @@ -0,0 +1,161 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootClosed + +/-! +# Canonical private-witness assembly + +The canonical witness source is covered by its recorded candidates. Splitting its first witness +between layer roots and all other structural positions combines the diagnostic, delayed-root and +non-root estimates. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] + maskedPublishedTreeRoot sampledGranularAllCanonicalPrivateWitnessSnapshot + granularAllCanonicalPrivateWitnessSnapshot +set_option linter.constructorNameAsVariable false + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem privateWitnessCovered_of_mem_granularAllCanonicalPlan + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (output : PrivateWitnessPlanOutput) + (houtput : output ∈ support + (granularAllCanonicalPrivateWitnessPlan adversary parameter table ftsSecret fuel)) : + PrivateWitnessCovered output := by + unfold granularAllCanonicalPrivateWitnessPlan at houtput + apply privateWitnessCovered_of_mem_runDirectWitnessPlanObserve _ [] + emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + · simp [PendingCoveredBy, emptyWitnessDeferredContext, LazyRevealProbe.State.empty] + · exact OracleComp.IsQueryBoundP.of_imp (isUncoveredProbe_imp_isProbe []) + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) + · intro result _hresult hcovered nextOutput hnextOutput + apply privateWitnessCovered_of_mem_canonicalizeDirectWitnessPlanObserve table _ + result.context result.remaining result.value [] hcovered + (output := nextOutput) (houtput := hnextOutput) + intro finalOutput hfinalOutput + have hcanonicalCovered : PendingCoveredBy [] + (canonicalizeMaterializedValues table result.context) := + (pendingCoveredBy_canonicalize_iff table [] result.context).2 hcovered + exact privateWitnessCovered_of_mem_granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve + adversary parameter table ftsSecret (canonicalizeMaterializedValues table result.context) + result.remaining result.value [] hcanonicalCovered finalOutput hfinalOutput + · exact houtput + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem privateWitnessCovered_erase_of_mem_sampledGranularAllCanonical + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret fuel)) : + PrivateWitnessCovered (erasePrivateWitnessSnapshotOutput output) := by + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨table, _htable, hfixed⟩ := houtput + have herased : erasePrivateWitnessSnapshotOutput output ∈ support + (granularAllCanonicalPrivateWitnessPlan adversary parameter table ftsSecret fuel) := by + rw [← map_erase_granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret fuel, support_map] + exact ⟨output, hfixed, rfl⟩ + exact privateWitnessCovered_of_mem_granularAllCanonicalPlan adversary parameter table ftsSecret + fuel (erasePrivateWitnessSnapshotOutput output) herased + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_sampledCanonical_privateWitness_le_eight_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hexpanded : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[fun output => output.1.isSome = true | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + ((8 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let diagnostic := sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q) + have hfuel : 2 * q < Fintype.card Digest := by + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + norm_num [securityBits, digestBits] at hq ⊢ + omega + have hdiagnostic : + Pr[fun outcome => outcome.final = none | diagnostic] + + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | diagnostic] ≤ + ((5 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ ((2 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + ((3 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply add_le_add + · exact probEvent_sampledObservedMaterializedDiagnostic_final_none_le adversary + parameter ftsSecret (2 * q) q hexpanded (by omega) + · exact probEvent_sampledDiagnostic_successfulDoomed_le_three_mul adversary parameter + ftsSecret q hfuel hexpanded hq + _ = _ := by + push_cast + ring + have hsplit : + Pr[fun output => output.1.isSome = true | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + Pr[fun output => WitnessFirstUsesSomeLayerRoot + (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] + + Pr[fun output => WitnessFirstUsesSomeNonLayerRoot + (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := by + calc + _ ≤ Pr[fun output => + WitnessFirstUsesSomeLayerRoot (erasePrivateWitnessSnapshotOutput output) ∨ + WitnessFirstUsesSomeNonLayerRoot (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := by + apply probEvent_mono + intro output houtput hwitness + have hcovered : PrivateWitnessCovered (erasePrivateWitnessSnapshotOutput output) := by + apply privateWitnessCovered_erase_of_mem_sampledGranularAllCanonical + (adversary := adversary) (parameter := parameter) (ftsSecret := ftsSecret) + (fuel := q) (output := output) + exact houtput + have herased : (erasePrivateWitnessSnapshotOutput output).1.isSome = true := by + simpa [erasePrivateWitnessSnapshotOutput] using hwitness + exact witnessFirstUsesSome_root_or_nonRoot hcovered herased + _ ≤ _ := probEvent_or_le _ _ _ + calc + _ ≤ Pr[fun output => WitnessFirstUsesSomeLayerRoot + (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] + + Pr[fun output => WitnessFirstUsesSomeNonLayerRoot + (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := hsplit + _ ≤ (Pr[fun outcome => outcome.final = none | diagnostic] + + Pr[ObservedMaterializedDiagnostic.SuccessfulDoomed | diagnostic] + + Pr[WitnessFirstUsesSomeDelayedLayerRootSnapshot | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q]) + + Pr[fun output => WitnessFirstUsesSomeNonLayerRoot + (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := by + gcongr + exact probEvent_sampledCanonical_root_le_diagnostic adversary parameter ftsSecret q + hexpanded + _ ≤ (((5 * q : Nat) : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + (2 * q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + + (q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply add_le_add + · apply add_le_add + · exact hdiagnostic + · exact probEvent_sampledCanonical_delayed_le_two_mul_closed adversary parameter + ftsSecret q hexpanded hq + · exact probEvent_sampledCanonical_nonRoot_le_mul adversary parameter ftsSecret q hexpanded + _ = _ := by + push_cast + ring + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedComparison.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedComparison.lean new file mode 100644 index 00000000..1910dd46 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedComparison.lean @@ -0,0 +1,166 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedFiber + +/-! +# Delayed source comparison root + +An independent comparison root turns the delayed actual-root match into the exchangeable +root-selection event. The only exception is equality with one of the earlier candidate digests. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option linter.constructorNameAsVariable false + +def DelayedRootGoodForComparisonAt + (source : PrivateWitnessSnapshotOutput) (ordinal : Nat) + (target : Position) (rightRoot : Digest) : Prop := + WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal source ∧ + delayedSnapshotLayerRootPosition? ordinal source = some target ∧ + CandidatesAvoidRoot target rightRoot + ((source.2.map PlannedProbeSnapshot.toProbe).take ordinal) + +def DelayedRootComparisonExceptionAt + (source : PrivateWitnessSnapshotOutput) (ordinal : Nat) + (target : Position) (rightRoot : Digest) : Prop := + WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal source ∧ + delayedSnapshotLayerRootPosition? ordinal source = some target ∧ + ¬CandidatesAvoidRoot target rightRoot + ((source.2.map PlannedProbeSnapshot.toProbe).take ordinal) + +theorem delayedRootFiber_split_comparison + {source : PrivateWitnessSnapshotOutput} {ordinal : Nat} + {target : Position} {rightRoot : Digest} + (hdelayed : WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal source) + (hposition : delayedSnapshotLayerRootPosition? ordinal source = some target) : + DelayedRootGoodForComparisonAt source ordinal target rightRoot ∨ + DelayedRootComparisonExceptionAt source ordinal target rightRoot := by + by_cases hright : CandidatesAvoidRoot target rightRoot + ((source.2.map PlannedProbeSnapshot.toProbe).take ordinal) + · exact Or.inl ⟨hdelayed, hposition, hright⟩ + · exact Or.inr ⟨hdelayed, hposition, hright⟩ + +theorem DelayedRootComparisonExceptionAt.comparison_mem + {source : PrivateWitnessSnapshotOutput} {ordinal : Nat} + {target : Position} {rightRoot : Digest} + (hexception : DelayedRootComparisonExceptionAt source ordinal target rightRoot) : + rightRoot ∈ snapshotPrefixCandidateDigests ordinal source := by + have hmem := not_candidatesAvoidRoot_mem_candidate_map hexception.2.2 + unfold snapshotPrefixCandidateDigests + simpa [List.map_take, Function.comp_def] using hmem + +theorem probEvent_delayedRootFiber_comparisonException_le + (run : ProbComp PrivateWitnessSnapshotOutput) (ordinal : Nat) (target : Position) : + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + DelayedRootComparisonExceptionAt result.1 ordinal target result.2 | do + let source ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] ≤ + Pr[fun source => + WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal source ∧ + delayedSnapshotLayerRootPosition? ordinal source = some target | run] * + ((ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + let gate := fun source : PrivateWitnessSnapshotOutput => + WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal source ∧ + delayedSnapshotLayerRootPosition? ordinal source = some target + let values := snapshotPrefixCandidateDigests ordinal + calc + _ ≤ Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + gate result.1 ∧ result.2 ∈ values result.1 | do + let source ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] := by + apply probEvent_mono + intro result _hresult hexception + exact ⟨⟨hexception.1, hexception.2.1⟩, hexception.comparison_mem⟩ + _ ≤ Pr[gate | run] * + ((ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply probEvent_gate_and_uniformDigest_mem_list_le run gate values ordinal + intro source _hsource _hgate + unfold values snapshotPrefixCandidateDigests + simp + _ = _ := rfl + +theorem probEvent_delayedRootFiber_le_goodComparison_add_weightedException + (run : ProbComp PrivateWitnessSnapshotOutput) (ordinal : Nat) (target : Position) : + Pr[fun source => + WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal source ∧ + delayedSnapshotLayerRootPosition? ordinal source = some target | run] ≤ + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + DelayedRootGoodForComparisonAt result.1 ordinal target result.2 | do + let source ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] + + Pr[fun source => + WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal source ∧ + delayedSnapshotLayerRootPosition? ordinal source = some target | run] * + ((ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + let paired : ProbComp (PrivateWitnessSnapshotOutput × Digest) := do + let source ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot) + calc + _ ≤ Pr[fun result => + (WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal result.1 ∧ + delayedSnapshotLayerRootPosition? ordinal result.1 = some target) | paired] := by + apply probEvent_le_of_relTriple (relTriple_pair_uniform_right run) + intro source result hrelation hevent + rwa [← hrelation] + _ ≤ Pr[fun result => + DelayedRootGoodForComparisonAt result.1 ordinal target result.2 ∨ + DelayedRootComparisonExceptionAt result.1 ordinal target result.2 | paired] := by + apply probEvent_mono + intro result _hresult hevent + exact delayedRootFiber_split_comparison hevent.1 hevent.2 + _ ≤ Pr[fun result => DelayedRootGoodForComparisonAt result.1 ordinal target result.2 | + paired] + + Pr[fun result => DelayedRootComparisonExceptionAt result.1 ordinal target result.2 | + paired] := probEvent_or_le _ _ _ + _ ≤ _ := add_le_add_right + (probEvent_delayedRootFiber_comparisonException_le run ordinal target) _ + +theorem DelayedRootGoodForComparisonAt.goodForRoots + {source : PrivateWitnessSnapshotOutput} {ordinal : Nat} + {target : Position} {rightRoot : Digest} + (hgood : DelayedRootGoodForComparisonAt source ordinal target rightRoot) : + ∃ selected : Fin source.2.length, ∃ output, + selectedPrivateSnapshotOrdinal? ordinal source.2 = + some (privateOrdinalSelectionOfSnapshot selected) ∧ + (privateOrdinalSelectionOfSnapshot selected).GoodForRoots + target output rightRoot ordinal := by + obtain ⟨witness, selected, _hwitness, hordinal, _hfirst, hselection, hactual, _hroot⟩ := + delayedOrdinal_goodForActualRoot hgood.1 hgood.2.1 + exact ⟨selected, witness.output, hselection, hactual.goodForRoots (by + rw [← hordinal, privateOrdinalSelectionOfSnapshot_candidates_take] + simpa [hordinal] using hgood.2.2)⟩ + +theorem probEvent_delayedGoodComparison_le_privateOrdinalSelection + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) : + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + DelayedRootGoodForComparisonAt result.1 ordinal target result.2 | do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret fuel + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] ≤ + Pr[fun result : Option PrivateOrdinalSelection × Digest => + privateOrdinalSelectionGoodForSomeOutput target result.2 ordinal result.1 | do + let selection ← granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter + table ftsSecret fuel + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot)] := by + apply probEvent_le_of_relTriple + (relTriple_snapshotComparison_privateOrdinalSelectionComparison ordinal adversary parameter + table ftsSecret fuel) + intro source selection hrelation hgood + obtain ⟨selected, output, hselected, hroots⟩ := hgood.goodForRoots + have hselection : selection.1 = some (privateOrdinalSelectionOfSnapshot selected) := + hrelation.1.symm.trans hselected + rw [hselection] + exact ⟨output, by simpa [hrelation.2] using hroots⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedCoupling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedCoupling.lean new file mode 100644 index 00000000..770d4d42 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedCoupling.lean @@ -0,0 +1,177 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalizedSignerStrong +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProduction + +/-! +# Delayed source permissive coupling + +A completed deferred execution is coupled to the same computation in the permissive materialized +interpreter. Stopped deferred executions impose no obligation. This is the local action rule used by +the delayed-root selector bridge. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def DirectWitnessRejected + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) : Prop := + let canonical := canonicalizeMaterializedValues table result.context + PrivateStructuralHit canonical ∨ + ¬PublishedValues result.context.state ∨ + ¬DeferredCompletable table canonical + +def DirectWitnessPermissiveRunRel + (table : OtsSecretIndex → HashOutput) : + DirectWitnessResult α → Option (CleanRunResult α) → Prop + | .done left, right => + DirectWitnessRejected table left ∨ + ∃ clean, right = some clean ∧ + left.value = clean.value ∧ + left.remaining = clean.remaining ∧ + left.table = table ∧ + clean.table = table ∧ + left.context.state.revealed = clean.state.revealed ∧ + (materializedDeferredState left.context).values = clean.state.values ∧ + ChainState.ValidFor (fun _ ↦ True) left.context.state ∧ + FinalizationContextEq table (some left.context) + (some (directDeferredContext clean.state)) + | _, _ => True + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedWitness_runCleanFromTable + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hchainValid : ChainState.ValidFor (fun _ ↦ True) context.state) + (hpreserves : PreservesChainValid (fun _ ↦ True) computation) + (hcouples : DirectWitnessFinalizationMaterializedCouples table computation) : + RelTriple + (runDirectResolvedWitnessFromTable context fuel table (computation.run cache)) + (runCleanFromTable (materializedDeferredState context) fuel table + (computation.run cache)) + (DirectWitnessPermissiveRunRel table) := by + let materialized := materializedDeferredContext context + have hcontext : FinalizationContextEq table (some context) (some materialized) := + finalizationContextEq_materializedDeferredContext hvalid hcompletable + have hstrong := hcouples context materialized fuel fuel cache cache hcontext rfl rfl rfl (by + simp [materialized, materializedDeferredContext, directDeferredContext]) + have hstrongSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hstrong + (fun result => match result with + | .done resolved => ChainState.ValidFor (fun _ ↦ True) resolved.context.state + | _ => True) (by + intro result hresult + cases result with + | stoppedFuel => trivial + | stoppedOrdinary => trivial + | stoppedPrivate witness => trivial + | done resolved => + have hdetailed : DirectDetailedResult.done resolved ∈ support + (runDirectResolvedDetailedFromTable context fuel table + (computation.run cache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + (computation.run cache) context fuel table, support_map] + exact ⟨.done resolved, hresult, rfl⟩ + have hdirect : some resolved ∈ support + (runDirectResolvedFromTable context fuel table (computation.run cache)) := + mem_support_runDirectResolvedFromTable_of_done_detailed + (computation.run cache) context fuel table resolved hdetailed + exact chainValid_of_mem_runDirectResolvedFromTable (fun _ ↦ True) computation + context fuel table cache resolved hpreserves hchainValid hdirect) + have hstrength : RelTriple + (runDirectResolvedWitnessFromTable context fuel table (computation.run cache)) + (runDirectResolvedDetailedFromTable materialized fuel table (computation.run cache)) + (fun left right ↦ DirectWitnessPermissiveRunRel table left + (projectDirectDetailedClean right)) := by + apply relTriple_post_mono hstrongSupported + intro left right hrelation + rcases hrelation with ⟨hrelation, hleftChainValid⟩ + cases left with + | stoppedFuel => trivial + | stoppedOrdinary => trivial + | stoppedPrivate witness => trivial + | done left => + cases right with + | stopped reason => + simp [DirectWitnessFinalizationMaterializedRunEq] at hrelation + | done right => + rcases hrelation with + ⟨hvalue, _hcontext, hremaining, _hrightRemaining, htable, _hrightTable, + hcache, hrevealed, hmaterialized, _hle, _hright⟩ + let clean : CleanRunResult (α × SplitHashCache) := + ⟨right.context.state, right.remaining, right.value, right.table⟩ + refine Or.inr ⟨clean, rfl, Prod.ext hvalue hcache, + hremaining.trans _hrightRemaining.symm, + htable, _hrightTable, hrevealed, hmaterialized, hleftChainValid, ?_⟩ + rw [_hright] at _hcontext + exact _hcontext + have hproject : RelTriple + (runDirectResolvedWitnessFromTable context fuel table (computation.run cache)) + (projectDirectDetailedClean <$> + runDirectResolvedDetailedFromTable materialized fuel table (computation.run cache)) + (DirectWitnessPermissiveRunRel table) := by + have hmapped := relTriple_map (R := DirectWitnessPermissiveRunRel table) + (f := id) (g := projectDirectDetailedClean) hstrength + rw [id_map] at hmapped + exact hmapped + have hprojectEq : + projectDirectDetailedClean <$> + runDirectResolvedDetailedFromTable materialized fuel table (computation.run cache) = + runCleanFromTable (materializedDeferredState context) fuel table + (computation.run cache) := by + simpa [materialized, materializedDeferredContext] using + (map_projectDirectDetailedClean_run_eq_clean (computation.run cache) + (materializedDeferredState context) fuel table) + exact relTriple_of_evalDist_eq_right (congrArg evalDist hprojectEq) hproject + +set_option maxRecDepth 100000 in +theorem relTriple_runDirectResolvedWitness_runPermissiveFromTable + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hchainValid : ChainState.ValidFor (fun _ ↦ True) context.state) + (hpreserves : PreservesChainValid (fun _ ↦ True) computation) + (hcouples : DirectWitnessFinalizationMaterializedCouples table computation) : + RelTriple + (runDirectResolvedWitnessFromTable context fuel table (computation.run cache)) + (runPermissiveFromTable (materializedDeferredState context) fuel table + (computation.run cache)) + (DirectWitnessPermissiveRunRel table) := by + have hclean := relTriple_runDirectResolvedWitness_runCleanFromTable computation context fuel table + cache hvalid hcompletable hchainValid hpreserves hcouples + have hpermissive := relTriple_runCleanFromTable_runPermissiveFromTable + (computation.run cache) (materializedDeferredState context) fuel table + have hglued := SphincsSecurity.relTriple_trans_exists hclean hpermissive + apply relTriple_post_mono hglued + intro left right hrelation + obtain ⟨middle, hleft, hright⟩ := hrelation + cases left with + | stoppedFuel => trivial + | stoppedOrdinary => trivial + | stoppedPrivate witness => trivial + | done left => + cases middle with + | none => + exact Or.inl (by + rcases hleft with hreject | ⟨clean, hnone, _⟩ + · exact hreject + · cases hnone) + | some middle => + cases right with + | none => + simp only [CleanPermissiveRel] at hright + cases hright + | some right => + have heq : right = middle := by + exact Option.some.inj (by simpa [CleanPermissiveRel] using hright) + subst right + rcases hleft with hreject | ⟨clean, hclean, hfields⟩ + · exact Or.inl hreject + · exact Or.inr ⟨clean, hclean, hfields⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedFiber.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedFiber.lean new file mode 100644 index 00000000..8029276b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedFiber.lean @@ -0,0 +1,173 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceNonRootProbability +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedSelectionSampling + +/-! +# Delayed source position fibers + +A delayed layer-root witness selects one concrete root position. The target-independent permissive +production experiment supplies the comparison weights used to sum those fibers without enumerating +structural positions. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option linter.constructorNameAsVariable false + +noncomputable def delayedSnapshotLayerRootPosition? + (ordinal : Nat) (source : PrivateWitnessSnapshotOutput) : Option Position := + if hselected : ordinal < source.2.length then + candidateLayerRootPosition? (source.2.get ⟨ordinal, hselected⟩).probe + else none + +theorem delayedSnapshotLayerRootPosition?_eq_some_of_delayed + {ordinal : Nat} {source : PrivateWitnessSnapshotOutput} + (hdelayed : WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal source) : + ∃ target, delayedSnapshotLayerRootPosition? ordinal source = some target := by + obtain ⟨witness, sourceOrdinal, _hwitness, hordinal, _hfirst, hroot, + _hstate, _hrevealed, _hvalue⟩ := hdelayed + have hlt : ordinal < source.2.length := by + rw [← hordinal] + exact sourceOrdinal.isLt + have hselected : (⟨ordinal, hlt⟩ : Fin source.2.length) = sourceOrdinal := + Fin.ext hordinal.symm + obtain ⟨target, hcoordinate, htargetRoot⟩ := hroot + refine ⟨target, ?_⟩ + unfold delayedSnapshotLayerRootPosition? + rw [dif_pos hlt, candidateLayerRootPosition?_eq_some_iff, hselected] + exact ⟨hcoordinate, htargetRoot⟩ + +theorem not_delayed_of_delayedSnapshotLayerRootPosition?_eq_none + {ordinal : Nat} {source : PrivateWitnessSnapshotOutput} + (hposition : delayedSnapshotLayerRootPosition? ordinal source = none) : + ¬WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal source := by + intro hdelayed + obtain ⟨target, htarget⟩ := + delayedSnapshotLayerRootPosition?_eq_some_of_delayed hdelayed + rw [hposition] at htarget + simp at htarget + +theorem delayedOrdinal_goodForActualRoot + {ordinal : Nat} {source : PrivateWitnessSnapshotOutput} {target : Position} + (hdelayed : WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal source) + (hposition : delayedSnapshotLayerRootPosition? ordinal source = some target) : + ∃ witness sourceOrdinal, + source.1 = some witness ∧ sourceOrdinal.val = ordinal ∧ + firstPrivateWitnessOrdinal? witness + (source.2.map PlannedProbeSnapshot.toProbe) = + some (snapshotProbeOrdinal sourceOrdinal) ∧ + selectedPrivateSnapshotOrdinal? ordinal source.2 = + some (privateOrdinalSelectionOfSnapshot sourceOrdinal) ∧ + (privateOrdinalSelectionOfSnapshot sourceOrdinal).GoodForActualRoot + target witness.output ordinal ∧ + IsLayerRoot target := by + obtain ⟨witness, sourceOrdinal, hwitness, hordinal, hfirst, hroot, + hstate, hrevealed, hvalue⟩ := hdelayed + have hlt : ordinal < source.2.length := by + rw [← hordinal] + exact sourceOrdinal.isLt + have hindex : (⟨ordinal, hlt⟩ : Fin source.2.length) = sourceOrdinal := + Fin.ext hordinal.symm + obtain ⟨sourceTarget, hcoordinate, hsourceRoot⟩ := hroot + have hsourcePosition : delayedSnapshotLayerRootPosition? ordinal source = some sourceTarget := by + unfold delayedSnapshotLayerRootPosition? + rw [dif_pos hlt, candidateLayerRootPosition?_eq_some_iff, hindex] + exact ⟨hcoordinate, hsourceRoot⟩ + have htarget : target = sourceTarget := by + rw [hposition] at hsourcePosition + exact Option.some.inj hsourcePosition + subst sourceTarget + have hmatch := privateWitnessAtOrdinal_of_firstPrivateWitnessOrdinal?_eq_some hfirst + unfold PrivateWitnessAtOrdinal at hmatch + have hmatchCoordinate : (source.2.get sourceOrdinal).probe.coordinate = + .position witness.position := by + simpa [snapshotProbeOrdinal] using hmatch.1 + have hwitnessTarget : witness.position = target := by + simpa using hmatchCoordinate.symm.trans hcoordinate + subst target + have hcandidate : (privateOrdinalSelectionOfSnapshot sourceOrdinal).candidate = + ⟨.position witness.position, truncateHash witness.output⟩ := by + rw [privateOrdinalSelectionOfSnapshot_candidate] + exact congrArg₂ Probe.mk hmatch.1 hmatch.2.symm + have huses : WitnessFirstUsesOrdinal ordinal + (erasePrivateWitnessSnapshotOutput source) := by + unfold erasePrivateWitnessSnapshotOutput + exact ⟨witness, snapshotProbeOrdinal sourceOrdinal, hwitness, hordinal, hfirst⟩ + have havoid := candidatesTake_avoid_witnessRoot_of_first huses hwitness + have hselection : selectedPrivateSnapshotOrdinal? ordinal source.2 = + some (privateOrdinalSelectionOfSnapshot sourceOrdinal) := by + rw [selectedPrivateSnapshotOrdinal?_eq_some hlt] + congr + have hactual : (privateOrdinalSelectionOfSnapshot sourceOrdinal).GoodForActualRoot + witness.position witness.output ordinal := + ⟨hcandidate, by simpa using hstate, by simpa using hrevealed, by simpa using hvalue, by + rw [← hordinal, privateOrdinalSelectionOfSnapshot_candidates_take] + simpa [erasePrivateWitnessSnapshotOutput, hordinal] using havoid⟩ + exact ⟨witness, sourceOrdinal, hwitness, hordinal, hfirst, hselection, hactual, hsourceRoot⟩ + +theorem probEvent_delayedOrdinal_le_of_common_position_fibers + (source : ProbComp PrivateWitnessSnapshotOutput) + (common : ProbComp (Option PermissivePrivateOrdinalSelection)) + (ordinal : Nat) + (hfiber : ∀ target, + Pr[fun output => + WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal output ∧ + delayedSnapshotLayerRootPosition? ordinal output = some target | source] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + common] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal | source] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_le_of_common_position_fibers source + (WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal) + (delayedSnapshotLayerRootPosition? ordinal) common + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? + (((2 ^ digestBits : Nat) : ENNReal)⁻¹) + · intro output hdelayed + obtain ⟨target, htarget⟩ := + delayedSnapshotLayerRootPosition?_eq_some_of_delayed hdelayed + rw [htarget] + simp + · exact hfiber + +theorem probEvent_granularAllCanonical_delayedOrdinal_le_of_common_position_fibers + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (hfiber : ∀ target, + Pr[fun output => + WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal output ∧ + delayedSnapshotLayerRootPosition? ordinal output = some target | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + probEvent_delayedOrdinal_le_of_common_position_fibers _ _ ordinal hfiber + +theorem probEvent_sampledCanonical_delayedOrdinal_le_of_table_position_fibers + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (hfiber : ∀ table target, + Pr[fun output => + WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal output ∧ + delayedSnapshotLayerRootPosition? ordinal output = some target | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret fuel] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot + apply probEvent_bind_le_of_forall_le + intro table _htable + exact probEvent_granularAllCanonical_delayedOrdinal_le_of_common_position_fibers ordinal + adversary parameter table ftsSecret fuel (hfiber table) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedProbability.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedProbability.lean new file mode 100644 index 00000000..48fcf81a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedProbability.lean @@ -0,0 +1,184 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedComparison +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootProduction +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwapProbability + +/-! +# Delayed source probability assembly + +The comparison-root exception is absorbed before target fibers are summed. This file packages the +position, table and ordinal arithmetic around the remaining weight-preserving selector coupling. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option linter.constructorNameAsVariable false + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_delayedRootFiber_le_two_mul_common + (run : ProbComp PrivateWitnessSnapshotOutput) + (common : ProbComp (Option PermissivePrivateOrdinalSelection)) + (ordinal q : Nat) (target : Position) + (hordinal : ordinal < q) (hq : q ≤ 2 ^ securityBits) + (hgood : + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + DelayedRootGoodForComparisonAt result.1 ordinal target result.2 | do + let source ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + common] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[fun source => + WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal source ∧ + delayedSnapshotLayerRootPosition? ordinal source = some target | run] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + common] * (2 * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + let probability := Pr[fun source => + WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal source ∧ + delayedSnapshotLayerRootPosition? ordinal source = some target | run] + let weight := Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + common] + let epsilon := ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + have hsplit : probability ≤ + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + DelayedRootGoodForComparisonAt result.1 ordinal target result.2 | do + let source ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] + + probability * ((ordinal : ENNReal) * epsilon) := by + exact probEvent_delayedRootFiber_le_goodComparison_add_weightedException + run ordinal target + have hhalf : (ordinal : ENNReal) * epsilon ≤ (2 : ENNReal)⁻¹ := by + exact ordinal_mul_inv_digest_le_inv_two ordinal q hordinal hq + have habsorb : probability ≤ 2 * (weight * epsilon) := by + apply le_two_mul_of_le_add_mul_inv_two probability (weight * epsilon) + · exact probEvent_le_one + · apply ne_top_of_le_ne_top (by norm_num : (1 : ENNReal) ≠ ∞) + calc + weight * epsilon ≤ 1 * 1 := by + apply mul_le_mul probEvent_le_one + · simp [epsilon, digestBits] + · exact bot_le + · exact bot_le + _ = 1 := one_mul 1 + · calc + probability ≤ + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + DelayedRootGoodForComparisonAt result.1 ordinal target result.2 | do + let source ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] + + probability * ((ordinal : ENNReal) * epsilon) := hsplit + _ ≤ weight * epsilon + probability * (2 : ENNReal)⁻¹ := by + exact add_le_add hgood (mul_le_mul_right hhalf probability) + change probability ≤ weight * (2 * epsilon) + calc + probability ≤ 2 * (weight * epsilon) := habsorb + _ = weight * (2 * epsilon) := by ac_rfl + +theorem probEvent_granularAllCanonical_delayedOrdinal_le_two_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hordinal : ordinal < q) (hq : q ≤ 2 ^ securityBits) + (hgood : ∀ target, + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + DelayedRootGoodForComparisonAt result.1 ordinal target result.2 | do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret q + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret q table] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q] ≤ + 2 * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_le_of_common_position_fibers + (leftPosition := delayedSnapshotLayerRootPosition? ordinal) + (common := delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret q table) + (commonPosition := permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?) + · intro output hdelayed + obtain ⟨target, htarget⟩ := + delayedSnapshotLayerRootPosition?_eq_some_of_delayed hdelayed + rw [htarget] + simp + · intro target + exact probEvent_delayedRootFiber_le_two_mul_common + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q) + (delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret q table) + ordinal q target hordinal hq (hgood target) + +theorem probEvent_sampledCanonical_delayedOrdinal_le_two_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hordinal : ordinal < q) (hq : q ≤ 2 ^ securityBits) + (hgood : ∀ table target, + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + DelayedRootGoodForComparisonAt result.1 ordinal target result.2 | do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret q + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret q table] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + 2 * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot + apply probEvent_bind_le_of_forall_le + intro table _htable + exact probEvent_granularAllCanonical_delayedOrdinal_le_two_mul ordinal adversary parameter table + ftsSecret q hordinal hq (hgood table) + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledCanonical_delayed_le_two_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) + (hgood : ∀ (ordinal : Fin q) table target, + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + DelayedRootGoodForComparisonAt result.1 ordinal.val target result.2 | do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret q + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal.val adversary parameter + ftsSecret q table] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[WitnessFirstUsesSomeDelayedLayerRootSnapshot | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + (2 * q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ ∑ ordinal : Fin q, + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal.val | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := + probEvent_sampledCanonical_delayed_le_sum_ordinals adversary parameter ftsSecret q hbound + _ ≤ ∑ _ordinal : Fin q, 2 * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + exact Finset.sum_le_sum fun ordinal _ => + probEvent_sampledCanonical_delayedOrdinal_le_two_mul ordinal.val adversary parameter + ftsSecret q ordinal.isLt hq (hgood ordinal) + _ = _ := by + simp + ring + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootBridge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootBridge.lean new file mode 100644 index 00000000..0df37e28 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootBridge.lean @@ -0,0 +1,142 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootProduction + +/-! +# Delayed source to materialized root bridge + +The delayed source coupling retains the selected candidate, its hidden value and the complete +candidate prefix. This packages exactly the common-selector event that can survive the +failure-retaining materialized root selector. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def PermissiveDelayedRootGuessAt + (target : Position) (output : HashOutput) (rightRoot : Digest) (ordinal : Nat) : + Option PermissivePrivateOrdinalSelection → Prop + | none => False + | some selection => + selection.candidate = ⟨.position target, truncateHash output⟩ ∧ + selection.state.values (.position target) = some output ∧ + Coordinate.position target ∉ selection.state.revealed ∧ + CandidatesAvoidRoots target (truncateHash output) rightRoot + (selection.candidates.take ordinal) + +def PermissiveDelayedRootGuess + (target : Position) (rightRoot : Digest) (ordinal : Nat) : + Option PermissivePrivateOrdinalSelection → Prop := + fun selection => ∃ output, PermissiveDelayedRootGuessAt target output rightRoot ordinal selection + +theorem DelayedPermissiveSelectionRel.delayedRootGuess + {target : Position} {rightRoot : Digest} {ordinal : Nat} + {left : Option PrivateOrdinalSelection} + {right : Option PermissivePrivateOrdinalSelection} + (hrel : DelayedPermissiveSelectionRel target rightRoot ordinal left right) + (hgood : privateOrdinalSelectionGoodForSomeOutput target rightRoot ordinal left) : + PermissiveDelayedRootGuess target rightRoot ordinal right := by + obtain ⟨output, leftSelection, rightSelection, hleft, hright, hleftGood, hcandidate, + hcandidates, hposition, hvalue⟩ := hrel hgood + rw [hright] + refine ⟨output, hcandidate.symm.trans hleftGood.1, hvalue, ?_, ?_⟩ + · obtain ⟨selected, hselected, _hroot, hunrevealed⟩ := + (permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?_eq_some_iff target + (some rightSelection)).mp hposition + cases Option.some.inj hselected + exact hunrevealed + rw [← hcandidates] + exact hleftGood.2.2.2.2 + +theorem probEvent_privateOrdinalSelectionGoodForSomeOutput_le_delayedRootGuess + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) (rightRoot : Digest) + (hroot : IsLayerRoot target) : + Pr[privateOrdinalSelectionGoodForSomeOutput target rightRoot ordinal | + granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret + fuel] ≤ + Pr[PermissiveDelayedRootGuess target rightRoot ordinal | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table] := by + apply probEvent_le_of_relTriple + (relTriple_granularAllCanonicalPrivateOrdinalSelection_permissiveDelayed ordinal adversary + parameter table ftsSecret fuel target rightRoot hroot) + intro left right hrelation hgood + exact hrelation.delayedRootGuess hgood + +theorem candidates_isPrefix_of_mem_delayedPermissiveDetailedOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (selection : PermissivePrivateOrdinalSelection) + (hselection : some selection ∈ support + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache)) : + candidates.IsPrefix selection.candidates := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + simp only [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_pure] at hselection + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] at hselection + simp only [support_pure, Set.mem_singleton_iff, Option.some.injEq] at hselection + subst selection + simpa using List.prefix_refl candidates + · simp [hselected] at hselection + | query_bind query next ih => + rw [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_query_bind] at hselection + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] at hselection + simp only [support_pure, Set.mem_singleton_iff, Option.some.injEq] at hselection + subst selection + simpa using List.prefix_refl candidates + · simp only [hselected, ↓reduceDIte] at hselection + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hselection + obtain ⟨result, _hresult, htail⟩ := hselection + cases result with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] at htail + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] at htail + exact ih result.value.1 candidates result.state result.remaining result.value.2 + htail + | inr input => + let nextCandidates := + permissiveRootAwareCandidates parameter input table state candidates + have hprefix : candidates.IsPrefix nextCandidates := by + unfold nextCandidates permissiveRootAwareCandidates + cases rootAwareCandidateForPlan? parameter input + (permissiveRootAwarePlan parameter input table state) <;> + simp [appendPlannedCandidate] + by_cases hnextSelected : ordinal < nextCandidates.length + · simp only [nextCandidates, hnextSelected, ↓reduceDIte] at hselection + simp only [support_pure, Set.mem_singleton_iff, Option.some.injEq] at hselection + subst selection + exact hprefix + · simp only [nextCandidates, hnextSelected, ↓reduceDIte] at hselection + rw [mem_support_bind_iff] at hselection + obtain ⟨result, _hresult, htail⟩ := hselection + cases result with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] at htail + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] at htail + exact hprefix.trans + (ih result.value.1 nextCandidates result.state result.remaining + result.value.2 htail) + | inr message => + rw [mem_support_bind_iff] at hselection + obtain ⟨result, _hresult, htail⟩ := hselection + cases result with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] at htail + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] at htail + exact ih result.value.1 candidates result.state result.remaining result.value.2 + htail + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootClosed.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootClosed.lean new file mode 100644 index 00000000..72eafcc0 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootClosed.lean @@ -0,0 +1,121 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootEndpoint +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceStructuralParentTop + +/-! +# Closed delayed-root bound + +Source snapshots retain the structural-parent fact supplied by the root-aware candidate planner. +Consequently every nonempty delayed root fiber satisfies the hypotheses of the tagged root exchange. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot + +theorem root_and_parent_of_delayedRootGoodForComparisonAt + {adversary : Adversary} {parameter : PublicParameter} + {table : OtsSecretIndex → HashOutput} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {fuel ordinal : Nat} {target : Position} {rightRoot : Digest} + {source : PrivateWitnessSnapshotOutput} + (hsource : source ∈ support + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel)) + (hgood : DelayedRootGoodForComparisonAt source ordinal target rightRoot) : + IsLayerRoot target ∧ ∃ parent, Position.parentOf target = some parent := by + obtain ⟨_witness, selected, _hwitness, _hordinal, _hfirst, _hselection, hactual, hroot⟩ := + delayedOrdinal_goodForActualRoot hgood.1 hgood.2.1 + have hparents := + snapshotsHaveStructuralParents_of_mem_granularAllCanonicalPrivateWitnessSnapshot adversary + parameter table ftsSecret fuel source hsource + have hcandidateParent : + (privateOrdinalSelectionOfSnapshot selected).candidate.HasStructuralParent := by + rw [privateOrdinalSelectionOfSnapshot_candidate] + exact candidateHasStructuralParent_get hparents selected.val (by + simp only [List.length_map] + exact selected.isLt) + refine ⟨hroot, ?_⟩ + rw [hactual.1] at hcandidateParent + simpa [Probe.HasStructuralParent] using hcandidateParent + +theorem root_and_parent_of_existing_delayedRootGoodComparisonFiber + {adversary : Adversary} {parameter : PublicParameter} + {table : OtsSecretIndex → HashOutput} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {fuel ordinal : Nat} {target : Position} + (hexists : ∃ result ∈ support (do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret fuel + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)), + DelayedRootGoodForComparisonAt result.1 ordinal target result.2) : + IsLayerRoot target ∧ ∃ parent, Position.parentOf target = some parent := by + obtain ⟨result, hresult, hgood⟩ := hexists + rw [mem_support_bind_iff] at hresult + obtain ⟨source, hsource, hresult⟩ := hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨rightRoot, _hrightRoot, hreturn⟩ := hresult + simp only [support_pure, Set.mem_singleton_iff] at hreturn + subst result + exact root_and_parent_of_delayedRootGoodForComparisonAt hsource hgood + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem probEvent_delayedGoodComparison_le_common_mul_allTargets + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) : + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + DelayedRootGoodForComparisonAt result.1 ordinal target result.2 | do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret fuel + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + by_cases hexists : ∃ result ∈ support (do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret fuel + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)), + DelayedRootGoodForComparisonAt result.1 ordinal target result.2 + · have hstructure := root_and_parent_of_existing_delayedRootGoodComparisonFiber hexists + exact probEvent_delayedGoodComparison_le_common_mul ordinal adversary parameter table + ftsSecret fuel target hstructure.1 hstructure.2 + · simp only [not_exists, not_and] at hexists + have hzero : Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + DelayedRootGoodForComparisonAt result.1 ordinal target result.2 | do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret fuel + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] = 0 := by + apply probEvent_eq_zero + intro result hsupport hevent + exact hexists result hsupport hevent + rw [hzero] + exact zero_le + +theorem probEvent_sampledCanonical_delayed_le_two_mul_closed + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ securityBits) : + Pr[WitnessFirstUsesSomeDelayedLayerRootSnapshot | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + (2 * q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_sampledCanonical_delayed_le_two_mul adversary parameter ftsSecret q hbound hq + intro ordinal table target + exact probEvent_delayedGoodComparison_le_common_mul_allTargets ordinal.val adversary parameter + table ftsSecret q target + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootEndpoint.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootEndpoint.lean new file mode 100644 index 00000000..70587ac4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootEndpoint.lean @@ -0,0 +1,134 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedProbability +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwapAfterTable + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option maxRecDepth 100000 in +theorem probEvent_uniformRight_privateOrdinalSelection_le_delayedRootGuess + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) (hroot : IsLayerRoot target) : + Pr[fun result : Option PrivateOrdinalSelection × Digest => + privateOrdinalSelectionGoodForSomeOutput target result.2 ordinal result.1 | do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter + table ftsSecret fuel + pure (selection, rightRoot)] ≤ + Pr[fun result : Option PermissivePrivateOrdinalSelection × Digest => + PermissiveDelayedRootGuess target result.2 ordinal result.1 | do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret fuel table + pure (selection, rightRoot)] := by + exact probEvent_bind_le_bind_of_forall_le + (mx := ($ᵗ Digest : ProbComp Digest)) + (left := fun rightRoot => + (fun selection => (selection, rightRoot)) <$> + granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret fuel) + (right := fun rightRoot => + (fun selection => (selection, rightRoot)) <$> + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table) + (leftEvent := fun result : Option PrivateOrdinalSelection × Digest => + privateOrdinalSelectionGoodForSomeOutput target result.2 ordinal result.1) + (rightEvent := fun result : Option PermissivePrivateOrdinalSelection × Digest => + PermissiveDelayedRootGuess target result.2 ordinal result.1) + (fun rightRoot _hrightRoot => by + rw [probEvent_map, probEvent_map] + change Pr[privateOrdinalSelectionGoodForSomeOutput target rightRoot ordinal | + granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret + fuel] ≤ + Pr[PermissiveDelayedRootGuess target rightRoot ordinal | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table] + exact probEvent_privateOrdinalSelectionGoodForSomeOutput_le_delayedRootGuess ordinal + adversary parameter table ftsSecret fuel target rightRoot hroot) + +set_option maxRecDepth 100000 in +theorem probEvent_privateOrdinalSelectionGoodForSomeOutput_pair_le_delayedRootGuess + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) (hroot : IsLayerRoot target) : + Pr[fun result : Option PrivateOrdinalSelection × Digest => + privateOrdinalSelectionGoodForSomeOutput target result.2 ordinal result.1 | do + let selection ← granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter + table ftsSecret fuel + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot)] ≤ + Pr[fun result : Option PermissivePrivateOrdinalSelection × Digest => + PermissiveDelayedRootGuess target result.2 ordinal result.1 | do + let selection ← delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret fuel table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot)] := by + let left := granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table + ftsSecret fuel + let right := delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table + let leftEvent := fun result : Option PrivateOrdinalSelection × Digest => + privateOrdinalSelectionGoodForSomeOutput target result.2 ordinal result.1 + let rightEvent := fun result : Option PermissivePrivateOrdinalSelection × Digest => + PermissiveDelayedRootGuess target result.2 ordinal result.1 + calc + _ = Pr[leftEvent | do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← left + pure (selection, rightRoot)] := by + apply OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + exact OracleComp.DeferredSampling.evalDist_bind_comm left + ($ᵗ Digest : ProbComp Digest) (fun selection rightRoot => pure (selection, rightRoot)) + _ ≤ Pr[rightEvent | do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← right + pure (selection, rightRoot)] := by + exact probEvent_uniformRight_privateOrdinalSelection_le_delayedRootGuess ordinal adversary + parameter table ftsSecret fuel target hroot + _ = _ := by + apply OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + exact (OracleComp.DeferredSampling.evalDist_bind_comm right + ($ᵗ Digest : ProbComp Digest) + (fun selection rightRoot => pure (selection, rightRoot))).symm + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem probEvent_delayedGoodComparison_le_common_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) : + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + DelayedRootGoodForComparisonAt result.1 ordinal target result.2 | do + let source ← granularAllCanonicalPrivateWitnessSnapshot adversary parameter table + ftsSecret fuel + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ Pr[fun result : Option PrivateOrdinalSelection × Digest => + privateOrdinalSelectionGoodForSomeOutput target result.2 ordinal result.1 | do + let selection ← granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter + table ftsSecret fuel + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot)] := + probEvent_delayedGoodComparison_le_privateOrdinalSelection ordinal adversary parameter table + ftsSecret fuel target + _ ≤ Pr[fun result : Option PermissivePrivateOrdinalSelection × Digest => + PermissiveDelayedRootGuess target result.2 ordinal result.1 | do + let selection ← delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret fuel table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot)] := + probEvent_privateOrdinalSelectionGoodForSomeOutput_pair_le_delayedRootGuess ordinal + adversary parameter table ftsSecret fuel target hroot + _ ≤ _ := probEvent_delayedRootGuess_afterTable_le_common_mul ordinal adversary parameter + ftsSecret target hroot hparent fuel table + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootProduction.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootProduction.lean new file mode 100644 index 00000000..999aaee6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootProduction.lean @@ -0,0 +1,421 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedSelectionSampling +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionInitial + +/-! +# Delayed source root production + +The older materialized root selector has exactly the delayed source hash schedule: it records the root-aware candidate and executes only the source public action. This module reuses its root-swap bound and connects its production marginal to the delayed permissive selector. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option linter.constructorNameAsVariable false +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_materializedRoot_permissiveDelayedOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hunrevealed : Coordinate.position target ∉ state.revealed) : + RelTriple + (materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot target + leftRoot rightRoot ftsSecret computation candidates state fuel table cache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter publicRoot ftsSecret + computation candidates state fuel table cache) + (MaterializedPermissiveDetailedSelectionRel target) := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + simp only [materializedActualRootAvoidingOrdinalSelection, + materializedRootAvoidingOrdinalSelection, + delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_selected_materializedPermissiveDetailedSelection target hroot + (candidates.get ⟨ordinal, hselected⟩) state candidates hunrevealed + · simp only [hselected, ↓reduceDIte] + apply relTriple_pure_pure + simp [MaterializedPermissiveDetailedSelectionRel, materializedOrdinalSelectionAt] + | query_bind query next ih => + rw [materializedActualRootAvoidingOrdinalSelection, + materializedRootAvoidingOrdinalSelection, OracleComp.construct_query_bind, + delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_selected_materializedPermissiveDetailedSelection target hroot + (candidates.get ⟨ordinal, hselected⟩) state candidates hunrevealed + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let leftObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedActualRootAvoidingOrdinalSelection ordinal parameter + publicRoot target leftRoot rightRoot ftsSecret (next output) laterCandidates + nextState remaining table nextCache + let rightObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter publicRoot + ftsSecret (next output) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_runCleanFromTable_runPermissiveFromTable + ((splitUniformImpl n).run cache) state fuel table) + intro leftResult rightResult hresult + apply relTriple_finishMaterializedPermissiveDetailedSelection target leftObserve + rightObserve candidates leftResult rightResult hresult + intro result hnextUnrevealed + simpa [leftObserve, rightObserve] using + ih result.value.1 candidates result.state result.remaining result.value.2 + hnextUnrevealed + | inr input => + simp only + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + have hnextCandidates : + permissiveRootAwareCandidates parameter input table state candidates = + nextCandidates := by + rfl + by_cases hnextSelected : ordinal < nextCandidates.length + · have hleftSelected : ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + have hrightSelected : ordinal < + (permissiveRootAwareCandidates parameter input table state candidates).length := + by simpa [hnextCandidates] using hnextSelected + simp only [hleftSelected, hrightSelected, ↓reduceDIte] + exact relTriple_pure_selected_materializedPermissiveDetailedSelection target + hroot (nextCandidates.get ⟨ordinal, hnextSelected⟩) state nextCandidates + hunrevealed + · have hleftSelected : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + have hrightSelected : ¬ordinal < + (permissiveRootAwareCandidates parameter input table state candidates).length := + by simpa [hnextCandidates] using hnextSelected + simp only [hleftSelected, hrightSelected, ↓reduceDIte] + by_cases hsafe : RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? + · have hsafeActual : RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + let leftObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedActualRootAvoidingOrdinalSelection ordinal parameter + publicRoot target leftRoot rightRoot ftsSecret (next output) + laterCandidates nextState remaining table nextCache + let rightObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter publicRoot + ftsSecret (next output) laterCandidates nextState remaining table nextCache + let inner := + (probingHashQueryAfterPublicPlan parameter input publicContext.state plan).run + cache + have hrightAction : + delayedPermissivePublicAction parameter input table state cache = inner := by + rfl + rw [hrightAction] + apply relTriple_bind + (relTriple_runCleanFromTable_runPermissiveFromTable inner state fuel table) + intro leftResult rightResult hresult + apply relTriple_finishMaterializedPermissiveDetailedSelection target + leftObserve rightObserve nextCandidates leftResult rightResult hresult + intro result hnextUnrevealed + simpa [leftObserve, rightObserve] using + ih result.value.1 nextCandidates result.state result.remaining result.value.2 + hnextUnrevealed + · have hsafeActual : ¬RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + exact relTriple_none_any_materializedPermissiveDetailedSelection target _ + | inr message => + let leftObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot + target leftRoot rightRoot ftsSecret (next output) laterCandidates nextState + remaining table nextCache + let rightObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter publicRoot ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_runCleanFromTable_runPermissiveFromTable + ((maskedSign parameter publicRoot ftsSecret message).run cache) state fuel table) + intro leftResult rightResult hresult + apply relTriple_finishMaterializedPermissiveDetailedSelection target leftObserve + rightObserve candidates leftResult rightResult hresult + intro result hnextUnrevealed + simpa [leftObserve, rightObserve] using + ih result.value.1 candidates result.state result.remaining result.value.2 + hnextUnrevealed + +noncomputable def sampledHighInstalledDelayedSelectionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp (Digest × Option PermissivePrivateOrdinalSelection) := do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let output := fun root => rootOutputOfParts root high + let selection ← delayedPermissiveDetailedOrdinalSelection ordinal parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (preloadPositionValue target (output leftRoot) rootResult.state) rootResult.remaining + rootResult.table + (rootInstalledCache target output rootResult.value.2 leftRoot) + pure (leftRoot, selection) + +theorem relTriple_sampledHigh_materializedRootProduction_installedDelayed + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hvalue : rootResult.state.values (.position target) = none) + (hunrevealed : Coordinate.position target ∉ rootResult.state.revealed) : + RelTriple + (sampledHighMaterializedRootSelectionProductionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult) + (sampledHighInstalledDelayedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) + (fun left right => left.1 = right.1 ∧ + MaterializedPermissiveDetailedSelectionRel target left.2 right.2) := by + unfold sampledHighMaterializedRootSelectionProductionAfterRootResult + sampledHighInstalledDelayedSelectionAfterRootResult + apply relTriple_bind (relTriple_refl ($ᵗ RootOutputHigh : ProbComp RootOutputHigh)) + intro leftHigh rightHigh hhigh + subst rightHigh + apply relTriple_bind (relTriple_refl ($ᵗ Digest : ProbComp Digest)) + intro leftRoot rightRoot hrootEq + subst rightRoot + let output := fun root => rootOutputOfParts root leftHigh + let context : DeferredContext := directDeferredContext rootResult.state + let rootContext := + { context with values := context.values.install target (output leftRoot) } + have hrootUnrevealed : Coordinate.position target ∉ + (materializedDeferredState rootContext).revealed := by + change Coordinate.position target ∉ rootResult.state.revealed + exact hunrevealed + have hbase := + (relTriple_materializedRoot_permissiveDelayedOrdinalSelection ordinal parameter + rootResult.value.1 target hroot leftRoot leftRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState rootContext) rootResult.remaining rootResult.table + (rootInstalledCache target output rootResult.value.2 leftRoot) hrootUnrevealed) + have hstate : PermissiveStateRel (materializedDeferredState rootContext) + (preloadPositionValue target (output leftRoot) rootResult.state) := by + constructor + · funext coordinate + cases coordinate with + | chainStart => rfl + | position position => + by_cases heq : position = target + · subst position + simp [rootContext, context, DeferredContext.positionValue, directDeferredContext, + DeferredStructuralValues.install, hvalue] + · have hcoordinate : Coordinate.position position ≠ Coordinate.position target := by + simpa using heq + simp only [rootContext, context, materializedDeferredState_position, + DeferredContext.positionValue, directDeferredContext, + DeferredStructuralValues.install, Function.update_of_ne heq, + preloadPositionValue_values_of_ne target (output leftRoot) rootResult.state + (.position position) hcoordinate] + unfold directDeferredValues + cases rootResult.state.values (.position position) <;> rfl + · rfl + have htransport := + relTriple_delayedPermissiveDetailedOrdinalSelection_of_stateRel ordinal parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + (materializedDeferredState rootContext) + (preloadPositionValue target (output leftRoot) rootResult.state) + rootResult.remaining rootResult.table + (rootInstalledCache target output rootResult.value.2 leftRoot) rfl hstate + have hglued := SphincsSecurity.relTriple_trans_exists hbase htransport + have hcombined : RelTriple + (materializedActualRootAvoidingOrdinalSelection ordinal parameter rootResult.value.1 target + leftRoot leftRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState rootContext) rootResult.remaining rootResult.table + (rootInstalledCache target output rootResult.value.2 leftRoot)) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (preloadPositionValue target (output leftRoot) rootResult.state) rootResult.remaining + rootResult.table (rootInstalledCache target output rootResult.value.2 leftRoot)) + (MaterializedPermissiveDetailedSelectionRel target) := by + apply relTriple_post_mono hglued + intro left right hrelation + obtain ⟨middle, hleft, hright⟩ := hrelation + intro hselected + have hmiddle := hleft hselected + exact hright.positionFiber_eq.symm.trans hmiddle + apply relTriple_bind hcombined + intro leftSelection rightSelection hselection + exact relTriple_pure_pure ⟨rfl, hselection⟩ + +theorem probEvent_materializedRootProduction_le_sampledHighInstalledDelayed + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hvalue : rootResult.state.values (.position target) = none) + (hunrevealed : Coordinate.position target ∉ rootResult.state.revealed) : + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + sampledHighMaterializedRootSelectionProductionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult] ≤ + Pr[fun result => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? result.2 = some target | + sampledHighInstalledDelayedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult] := by + apply probEvent_le_of_relTriple + (relTriple_sampledHigh_materializedRootProduction_installedDelayed ordinal adversary + parameter ftsSecret target hroot rootResult hvalue hunrevealed) + intro left right hrelation hleft + exact hrelation.2 hleft + +theorem evalDist_sampledHighInstalledDelayed_snd_eq_installed + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + evalDist + (Prod.snd <$> + sampledHighInstalledDelayedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) = + evalDist + (installedDelayedPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) := by + let parts : ProbComp HashOutput := do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let root ← ($ᵗ Digest : ProbComp Digest) + pure (rootOutputOfParts root high) + have hparts : evalDist parts = evalDist LazyRevealProbe.sampleHashOutput := by + calc + _ = evalDist (do + let root ← ($ᵗ Digest : ProbComp Digest) + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + pure (rootOutputOfParts root high)) := by + exact OracleComp.DeferredSampling.evalDist_bind_comm + ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + ($ᵗ Digest : ProbComp Digest) + (fun high root => pure (rootOutputOfParts root high)) + _ = _ := evalDist_sample_rootOutputOfParts + let continuation := fun output : HashOutput => + delayedPermissiveDetailedOrdinalSelection ordinal parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (preloadPositionValue target output rootResult.state) rootResult.remaining rootResult.table + (replaceHiddenRootCache target output rootResult.value.2) + calc + _ = evalDist (parts >>= continuation) := by + simp [sampledHighInstalledDelayedSelectionAfterRootResult, parts, continuation, + rootInstalledCache, bind_assoc, map_eq_bind_pure_comp] + _ = evalDist (LazyRevealProbe.sampleHashOutput >>= continuation) := + evalDist_bind_eq_of_evalDist_eq hparts continuation + _ = _ := by + rfl + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem probEvent_materializedRootProduction_le_installedDelayed + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + materializedRootOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + installedDelayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret target fuel table] := by + unfold materializedRootOrdinalProductionExperimentAfterTable + installedDelayedPermissiveDetailedSelectionExperimentAfterTable + apply probEvent_bind_le_bind_of_forall_le + intro rootResult hresult + cases rootResult with + | none => + simp [materializedOrdinalSelectionAt, + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?] + | some rootResult => + have habsent := target_absent_of_mem_runCleanFromTable_maskedPublishedTreeRoot target hroot + hparent fuel table rootResult hresult + calc + _ ≤ Pr[fun result => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? result.2 = some target | + sampledHighInstalledDelayedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult] := + probEvent_materializedRootProduction_le_sampledHighInstalledDelayed ordinal adversary + parameter ftsSecret target hroot rootResult habsent.1 habsent.2 + _ = Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + Prod.snd <$> sampledHighInstalledDelayedSelectionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult] := by + rw [probEvent_map] + rfl + _ = _ := by + apply OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + exact evalDist_sampledHighInstalledDelayed_snd_eq_installed ordinal adversary parameter + ftsSecret target rootResult + +set_option maxRecDepth 100000 in +theorem probEvent_materializedRootOrdinalMatch_le_common_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + Pr[fun result => materializedOrdinalSelectionMatches target result.1 result.2.2 | + materializedRootOrdinalMatchExperimentAfterTable ordinal adversary parameter ftsSecret + target fuel table] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ Pr[fun result => materializedOrdinalSelectionAt target result.2 | + materializedRootOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + probEvent_materializedRootOrdinalMatchExperimentAfterTable_le_mul ordinal adversary + parameter ftsSecret target hroot hparent fuel table + _ ≤ Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + installedDelayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret target fuel table] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + gcongr + exact probEvent_materializedRootProduction_le_installedDelayed ordinal adversary parameter + ftsSecret target hroot hparent fuel table + _ ≤ _ := by + gcongr + exact probEvent_installedDelayedSelection_fiber_le_common ordinal adversary parameter + ftsSecret target hroot hparent fuel table + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwap.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwap.lean new file mode 100644 index 00000000..42b28dc9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwap.lean @@ -0,0 +1,878 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootBridge + +/-! +# Delayed selector root swap + +The delayed selector must retain executions that encounter an unrelated pending hit. Its root +exchange therefore runs in the permissive interpreter itself, rather than passing through the +failure-discarding materialized selector. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def RootHiddenPermissiveRelatesWith + (target : Position) (leftOutput rightOutput : HashOutput) + (valueRel : α → β → Prop) + (left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β) : Prop := + ∀ leftState rightState, + RootHiddenStateRel target leftOutput rightOutput leftState rightState → + ∀ fuel table leftCache rightCache, + RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache → + RelTriple + (runPermissiveFromTable leftState fuel table (left.run leftCache)) + (runPermissiveFromTable rightState fuel table (right.run rightCache)) + (RootHiddenCleanRelWith target leftOutput rightOutput valueRel) + +theorem rootHiddenPermissiveRelatesWith_pure + (target : Position) (leftOutput rightOutput : HashOutput) + (leftValue : α) (rightValue : β) (hvalue : R leftValue rightValue) : + RootHiddenPermissiveRelatesWith target leftOutput rightOutput R + (pure leftValue) (pure rightValue) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + simp only [StateT.run_pure, runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, hvalue, hcache⟩ + +theorem RootHiddenPermissiveRelatesWith.bind + {target : Position} {leftOutput rightOutput : HashOutput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + {leftNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) γ} + {rightNext : β → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) δ} + (hfirst : RootHiddenPermissiveRelatesWith target leftOutput rightOutput R left right) + (hnext : ∀ leftValue rightValue, R leftValue rightValue → + RootHiddenPermissiveRelatesWith target leftOutput rightOutput S + (leftNext leftValue) (rightNext rightValue)) : + RootHiddenPermissiveRelatesWith target leftOutput rightOutput S + (left >>= leftNext) (right >>= rightNext) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + rw [StateT.run_bind, StateT.run_bind, runPermissiveFromTable_bind, + runPermissiveFromTable_bind] + apply relTriple_bind + (hfirst leftState rightState hstate fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [RootHiddenCleanRelWith] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootHiddenCleanRelWith] at hresult + | some rightResult => + rcases hresult with ⟨hnextState, hremaining, htable, hvalue, hnextCache⟩ + simp only + rw [← hremaining, ← htable] + exact hnext leftResult.value.1 rightResult.value.1 hvalue + leftResult.state rightResult.state hnextState leftResult.remaining leftResult.table + leftResult.value.2 rightResult.value.2 hnextCache + +def RootHiddenPermissiveRelates + (target : Position) (leftOutput rightOutput : HashOutput) + (left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + RootHiddenPermissiveRelatesWith target leftOutput rightOutput (fun x y => x = y) left right + +theorem rootHiddenPermissiveRelates_pure + (target : Position) (leftOutput rightOutput : HashOutput) (value : α) : + RootHiddenPermissiveRelates target leftOutput rightOutput (pure value) (pure value) := + rootHiddenPermissiveRelatesWith_pure target leftOutput rightOutput value value rfl + +theorem rootHiddenPermissiveRelates_splitUniformImpl + (target : Position) (leftOutput rightOutput : HashOutput) (n : Nat) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (splitUniformImpl n) (splitUniformImpl n) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + unfold splitUniformImpl LazyRevealProbe.uniformQuery + rw [StateT.run_liftM, StateT.run_liftM, + runPermissiveFromTable_uniform_query_bind, runPermissiveFromTable_uniform_query_bind] + apply relTriple_bind + (relTriple_refl (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))) + intro leftValue rightValue hvalue + subst rightValue + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, rfl, hcache⟩ + +theorem rootHiddenPermissiveRelates_ensureCoordinate + (target : Position) (leftOutput rightOutput : HashOutput) + (coordinate : Coordinate) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (ensureCoordinate coordinate) (ensureCoordinate coordinate) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + unfold ensureCoordinate LazyRevealProbe.ensureQuery + rw [StateT.run_liftM, StateT.run_liftM, + runPermissiveFromTable_ensure_query_bind, runPermissiveFromTable_ensure_query_bind] + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate.ensure coordinate, rfl, rfl, trivial, hcache⟩ + +theorem rootHiddenPermissiveRelates_probe + (target : Position) (leftOutput rightOutput : HashOutput) + (candidate : Probe) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (probe candidate) (probe candidate) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + unfold probe LazyRevealProbe.probeQuery + rw [StateT.run_liftM, StateT.run_liftM, + runPermissiveFromTable_probe_query_bind, runPermissiveFromTable_probe_query_bind] + cases fuel with + | zero => exact relTriple_pure_pure trivial + | succ remaining => + have hrevealed : candidate.coordinate ∈ leftState.revealed ↔ + candidate.coordinate ∈ rightState.revealed := by rw [hstate.revealed] + by_cases hleftRevealed : candidate.coordinate ∈ leftState.revealed + · have hrightRevealed := hrevealed.mp hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte, + runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, trivial, hcache⟩ + · have hrightRevealed : candidate.coordinate ∉ rightState.revealed := + fun hmem => hleftRevealed (hrevealed.mpr hmem) + simp only [hleftRevealed, hrightRevealed, ↓reduceIte, + runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure + ⟨hstate.addPending candidate.coordinate candidate.candidate, + rfl, rfl, trivial, hcache⟩ + +theorem rootHiddenPermissiveRelates_splitHashQuery_ordinary + (target : Position) (leftOutput rightOutput : HashOutput) + (input : HashInput) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (splitHashQuery (.ordinary input)) (splitHashQuery (.ordinary input)) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + have hlookup := hcache.ordinary input + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + cases hleft : leftCache (.ordinary input) with + | some output => + have hright : rightCache (.ordinary input) = some output := by + rw [← hlookup] + exact hleft + simp only [hright, runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, rfl, hcache⟩ + | none => + have hright : rightCache (.ordinary input) = none := by + rw [← hlookup] + exact hleft + simp only [hright] + unfold LazyRevealProbe.hashOutputQuery + rw [runPermissiveFromTable_hashOutput_query_bind, + runPermissiveFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftSample rightSample hsample + subst rightSample + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, rfl, + hcache.update_same_ordinary input leftSample⟩ + +theorem rootHiddenPermissiveRelates_revealCoordinate_of_ne + (target : Position) (leftOutput rightOutput : HashOutput) + (coordinate : Coordinate) (hne : coordinate ≠ .position target) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (revealCoordinate coordinate) (revealCoordinate coordinate) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + rw [revealCoordinate_run, revealCoordinate_run, LazyRevealProbe.revealQuery, + runPermissiveFromTable_reveal_query_bind, runPermissiveFromTable_reveal_query_bind] + have hvalue := hstate.other_values coordinate hne + cases hleft : leftState.values coordinate with + | some output => + have hright : rightState.values coordinate = some output := by + rw [← hvalue] + exact hleft + simp only [hright, runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, rfl, + hcache.update_same_hidden_of_ne coordinate output hne⟩ + | none => + have hright : rightState.values coordinate = none := by + rw [← hvalue] + exact hleft + simp only [hright] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure + ⟨hstate.materialize_other (.chainStart lay tree leafIdx chainIdx) output hne, + rfl, rfl, rfl, + hcache.update_same_hidden_of_ne + (.chainStart lay tree leafIdx chainIdx) output hne⟩ + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftSample rightSample hsample + subst rightSample + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure + ⟨hstate.materialize_other (.position position) leftSample hne, + rfl, rfl, rfl, + hcache.update_same_hidden_of_ne (.position position) leftSample hne⟩ + +theorem rootHiddenPermissiveRelates_publishCoordinate_of_ne + (target : Position) (leftOutput rightOutput : HashOutput) + (coordinate : Coordinate) (hne : coordinate ≠ .position target) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (publishCoordinate coordinate) (publishCoordinate coordinate) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + unfold publishCoordinate LazyRevealProbe.publishQuery + rw [StateT.run_liftM, StateT.run_liftM, + runPermissiveFromTable_publish_query_bind, runPermissiveFromTable_publish_query_bind] + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure + ⟨hstate.publish_of_ne coordinate hne, rfl, rfl, trivial, hcache⟩ + +theorem rootHiddenPermissiveRelates_revealCoordinateOutput_of_ne + (target : Position) (leftOutput rightOutput : HashOutput) + (coordinate : Coordinate) (hne : coordinate ≠ .position target) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (revealCoordinateOutput coordinate) (revealCoordinateOutput coordinate) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + rw [revealCoordinateOutput_run_eq, revealCoordinateOutput_run_eq, + LazyRevealProbe.revealQuery, runPermissiveFromTable_reveal_query_bind, + runPermissiveFromTable_reveal_query_bind] + have hvalue := hstate.other_values coordinate hne + cases hleft : leftState.values coordinate with + | some output => + have hright : rightState.values coordinate = some output := by + rw [← hvalue] + exact hleft + simp only [hright, runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, rfl, + hcache.update_same_hidden_of_ne coordinate output hne⟩ + | none => + have hright : rightState.values coordinate = none := by + rw [← hvalue] + exact hleft + simp only [hright] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure + ⟨hstate.materialize_other (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) hne, + rfl, rfl, rfl, + hcache.update_same_hidden_of_ne (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) hne⟩ + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftSample rightSample hsample + subst rightSample + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure + ⟨hstate.materialize_other (.position position) leftSample hne, + rfl, rfl, rfl, + hcache.update_same_hidden_of_ne (.position position) leftSample hne⟩ + +theorem rootHiddenPermissiveRelates_modifyOrdinary + (target : Position) (leftOutput rightOutput : HashOutput) + (input : HashInput) (output : HashOutput) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output)) + (modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output)) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + simp only [StateT.run_modify, runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure + ⟨hstate, rfl, rfl, trivial, hcache.update_same_ordinary input output⟩ + +theorem rootHiddenPermissiveRelates_executeCandidate + (target : Position) (leftOutput rightOutput : HashOutput) + (candidate? : Option Probe) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (executeCandidate? candidate?) (executeCandidate? candidate?) := by + cases candidate? with + | none => exact rootHiddenPermissiveRelates_pure target leftOutput rightOutput () + | some candidate => exact rootHiddenPermissiveRelates_probe target leftOutput rightOutput candidate + +theorem rootHiddenPermissiveRelates_resolvePublicKnownInput_of_ne + (parameter : PublicParameter) + (target : Position) (leftOutput rightOutput : HashOutput) + (publicState : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) (hne : coordinate ≠ .position target) + (input : HashInput) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (resolvePublicKnownInput parameter publicState coordinate input) + (resolvePublicKnownInput parameter publicState coordinate input) := by + unfold resolvePublicKnownInput + cases hknown : purePeekTableInput parameter publicState coordinate with + | none => + exact rootHiddenPermissiveRelates_splitHashQuery_ordinary target leftOutput rightOutput input + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + exact (rootHiddenPermissiveRelates_revealCoordinateOutput_of_ne target leftOutput + rightOutput coordinate hne).bind fun leftValue rightValue hvalue => by + subst rightValue + exact (rootHiddenPermissiveRelates_publishCoordinate_of_ne target leftOutput + rightOutput coordinate hne).bind fun _ _ _ => + (rootHiddenPermissiveRelates_modifyOrdinary target leftOutput rightOutput input + leftValue).bind fun _ _ _ => + rootHiddenPermissiveRelates_pure target leftOutput rightOutput leftValue + · simp only [heq, ↓reduceIte] + exact rootHiddenPermissiveRelates_splitHashQuery_ordinary target leftOutput rightOutput input + +theorem rootHiddenPermissiveRelates_probingHashQueryAfterPublicPlan + (parameter : PublicParameter) + (target : Position) (leftOutput rightOutput : HashOutput) + (input : HashInput) (publicState : LazyRevealProbe.State Coordinate) + (plan : PlannedHashQuery) + (hsafe : plan.action ≠ .resolve (.position target)) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (probingHashQueryAfterPublicPlan parameter input publicState plan) + (probingHashQueryAfterPublicPlan parameter input publicState plan) := by + unfold probingHashQueryAfterPublicPlan + exact (rootHiddenPermissiveRelates_executeCandidate target leftOutput rightOutput + plan.candidate?).bind fun _ _ _ => by + cases haction : plan.action with + | ordinary => + exact rootHiddenPermissiveRelates_splitHashQuery_ordinary target leftOutput + rightOutput input + | resolve coordinate => + have hne : coordinate ≠ .position target := by + intro heq + apply hsafe + rw [haction, heq] + exact rootHiddenPermissiveRelates_resolvePublicKnownInput_of_ne parameter target + leftOutput rightOutput publicState coordinate hne input + +theorem rootHiddenPermissiveRelates_revealPublishedCoordinate_of_ne + (target : Position) (leftOutput rightOutput : HashOutput) + (coordinate : Coordinate) (hne : coordinate ≠ .position target) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (revealPublishedCoordinate coordinate) (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + exact (rootHiddenPermissiveRelates_revealCoordinate_of_ne target leftOutput rightOutput + coordinate hne).bind fun leftValue rightValue hvalue => + (rootHiddenPermissiveRelates_publishCoordinate_of_ne target leftOutput rightOutput + coordinate hne).bind fun _ _ _ => by + subst rightValue + exact rootHiddenPermissiveRelates_pure target leftOutput rightOutput leftValue + +def RootHiddenPermissiveTargetRevealRel + (target : Position) (leftOutput rightOutput : HashOutput) : + Option (CleanRunResult (Digest × SplitHashCache)) → + Option (CleanRunResult (Digest × SplitHashCache)) → Prop + | some left, some right => + RootHiddenStateRel target leftOutput rightOutput left.state right.state ∧ + left.remaining = right.remaining ∧ left.table = right.table ∧ + left.value.1 = truncateHash leftOutput ∧ + right.value.1 = truncateHash rightOutput ∧ + RootHiddenCacheRel target leftOutput rightOutput left.value.2 right.value.2 + | none, none => True + | _, _ => False + +theorem relTriple_rootHiddenPermissive_revealPosition_target + (target : Position) (leftOutput rightOutput : HashOutput) + (leftState rightState : LazyRevealProbe.State Coordinate) + (hstate : RootHiddenStateRel target leftOutput rightOutput leftState rightState) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache) : + RelTriple + (runPermissiveFromTable leftState fuel table ((revealPosition target).run leftCache)) + (runPermissiveFromTable rightState fuel table ((revealPosition target).run rightCache)) + (RootHiddenPermissiveTargetRevealRel target leftOutput rightOutput) := by + rw [revealPosition_run, revealPosition_run, LazyRevealProbe.revealQuery, + runPermissiveFromTable_reveal_query_bind, runPermissiveFromTable_reveal_query_bind, + hstate.left_target, hstate.right_target] + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure + ⟨hstate, rfl, rfl, rfl, rfl, hcache.update_targets⟩ + +theorem rootHiddenPermissiveRelates_sequenceFin + (target : Position) (leftOutput rightOutput : HashOutput) {n : Nat} + (left right : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, + RootHiddenPermissiveRelates target leftOutput rightOutput (left index) (right index)) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (sequenceFin left) (sequenceFin right) := by + induction n with + | zero => + simp only [sequenceFin] + exact rootHiddenPermissiveRelates_pure target leftOutput rightOutput Fin.elim0 + | succ n ih => + rw [sequenceFin, sequenceFin] + exact (hcomponent 0).bind fun leftHead rightHead hhead => + (ih (fun index : Fin n => left index.succ) (fun index : Fin n => right index.succ) + (fun index => hcomponent index.succ)).bind fun leftTail rightTail htail => by + subst rightHead + subst rightTail + exact rootHiddenPermissiveRelates_pure target leftOutput rightOutput + (Fin.cases leftHead leftTail : Fin (n + 1) → α) + +theorem rootHiddenPermissiveRelates_ensureFullChain + (target : Position) (leftOutput rightOutput : HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (ensureFullChain lay tree leafIdx chainIdx) + (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (rootHiddenPermissiveRelates_sequenceFin target leftOutput rightOutput _ _ + (fun step => rootHiddenPermissiveRelates_ensureCoordinate target leftOutput rightOutput + (.position (.chain lay tree leafIdx chainIdx step)))).bind fun _ _ _ => + rootHiddenPermissiveRelates_pure target leftOutput rightOutput () + +theorem rootHiddenPermissiveRelates_ensureOtsLeaf + (target : Position) (leftOutput rightOutput : HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (ensureOtsLeaf lay tree leafIdx) (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (rootHiddenPermissiveRelates_sequenceFin target leftOutput rightOutput _ _ + (fun chainIdx => rootHiddenPermissiveRelates_ensureFullChain target leftOutput rightOutput + lay tree leafIdx chainIdx)).bind fun _ _ _ => + rootHiddenPermissiveRelates_ensureCoordinate target leftOutput rightOutput + (.position (.leaf lay tree leafIdx)) + +theorem rootHiddenPermissiveRelates_ensureTreeNode + (target : Position) (leftOutput rightOutput : HashOutput) + (lay : Layer) (tree : TreeIndex) : ∀ level nodeIdx, + RootHiddenPermissiveRelates target leftOutput rightOutput + (ensureTreeNode lay tree level nodeIdx) + (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => by + rw [ensureTreeNode] + exact rootHiddenPermissiveRelates_ensureOtsLeaf target leftOutput rightOutput lay tree + (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (rootHiddenPermissiveRelates_ensureTreeNode target leftOutput rightOutput lay tree level + (2 * nodeIdx)).bind fun _ _ _ => + (rootHiddenPermissiveRelates_ensureTreeNode target leftOutput rightOutput lay tree level + (2 * nodeIdx + 1)).bind fun _ _ _ => by + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact rootHiddenPermissiveRelates_ensureCoordinate target leftOutput rightOutput + (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact rootHiddenPermissiveRelates_pure target leftOutput rightOutput () + +theorem rootHiddenPermissiveRelates_ensureChainPrefix + (target : Position) (leftOutput rightOutput : HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (ensureChainPrefix lay tree leafIdx chainIdx digit) + (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (rootHiddenPermissiveRelates_sequenceFin target leftOutput rightOutput _ _ + (fun step => by + by_cases hstep : step.val < digit.val + · rw [if_pos hstep] + exact rootHiddenPermissiveRelates_ensureCoordinate target leftOutput rightOutput + (.position (.chain lay tree leafIdx chainIdx step)) + · rw [if_neg hstep] + exact rootHiddenPermissiveRelates_pure target leftOutput rightOutput ())).bind + fun _ _ _ => rootHiddenPermissiveRelates_pure target leftOutput rightOutput () + +theorem rootHiddenPermissiveRelates_ensureTreePath + (target : Position) (leftOutput rightOutput : HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (ensureTreePath lay tree leafIdx) (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (rootHiddenPermissiveRelates_sequenceFin target leftOutput rightOutput _ _ + (fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + exact rootHiddenPermissiveRelates_ensureTreeNode target leftOutput rightOutput lay tree + level.val (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · rw [if_neg hlevel] + exact rootHiddenPermissiveRelates_pure target leftOutput rightOutput ())).bind + fun _ _ _ => rootHiddenPermissiveRelates_pure target leftOutput rightOutput () + +theorem rootHiddenPermissiveRelates_simulateQ + {spec : OracleSpec ι} + (target : Position) (leftOutput rightOutput : HashOutput) + (leftImpl rightImpl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (himpl : ∀ query, + RootHiddenPermissiveRelates target leftOutput rightOutput + (leftImpl query) (rightImpl query)) + (computation : OracleComp spec α) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (simulateQ leftImpl computation) (simulateQ rightImpl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + rw [simulateQ_pure, simulateQ_pure] + exact rootHiddenPermissiveRelates_pure target leftOutput rightOutput value + | query_bind query next ih => + rw [simulateQ_query_bind, simulateQ_query_bind] + exact (himpl query).bind fun leftValue rightValue hvalue => by + subst rightValue + exact ih leftValue + +theorem rootHiddenPermissiveRelates_ordinaryHashImpl + (target : Position) (leftOutput rightOutput : HashOutput) + (input : HashInput) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (ordinaryHashImpl input) (ordinaryHashImpl input) := + rootHiddenPermissiveRelates_splitHashQuery_ordinary target leftOutput rightOutput input + +theorem rootHiddenPermissiveRelates_maskedOtsSignFrom + (target : Position) (leftOutput rightOutput : HashOutput) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : ∀ attempts counter, + RootHiddenPermissiveRelates target leftOutput rightOutput + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom] + exact rootHiddenPermissiveRelates_pure target leftOutput rightOutput none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + apply (rootHiddenPermissiveRelates_simulateQ target leftOutput rightOutput + ordinaryHashImpl ordinaryHashImpl + (rootHiddenPermissiveRelates_ordinaryHashImpl target leftOutput rightOutput) + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter))).bind + intro leftEncoded rightEncoded hencoded + subst rightEncoded + cases leftEncoded with + | none => + exact rootHiddenPermissiveRelates_maskedOtsSignFrom target leftOutput rightOutput + parameter lay tree leafIdx message attempts (counter + 1) + | some encoding => + exact (rootHiddenPermissiveRelates_sequenceFin target leftOutput rightOutput _ _ + (fun chainIdx => + rootHiddenPermissiveRelates_ensureChainPrefix target leftOutput rightOutput + lay tree leafIdx chainIdx (encoding chainIdx))).bind fun _ _ _ => + rootHiddenPermissiveRelates_pure target leftOutput rightOutput + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem rootHiddenPermissiveRelates_maskedOtsSign + (target : Position) (leftOutput rightOutput : HashOutput) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (maskedOtsSign parameter lay tree leafIdx message) + (maskedOtsSign parameter lay tree leafIdx message) := + rootHiddenPermissiveRelates_maskedOtsSignFrom target leftOutput rightOutput parameter lay tree + leafIdx message encodingAttemptLimit 0 + +theorem rootHiddenPermissiveRelates_maskedOtsLayerAfterMessage + (target : Position) (leftOutput rightOutput : HashOutput) + (parameter : PublicParameter) (index : Index) (lay : Layer) (message : Digest) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (maskedOtsLayerAfterMessage parameter index lay message) + (maskedOtsLayerAfterMessage parameter index lay message) := by + unfold maskedOtsLayerAfterMessage + apply (rootHiddenPermissiveRelates_maskedOtsSign target leftOutput rightOutput parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) message).bind + intro leftResult rightResult hresult + subst rightResult + cases leftResult with + | none => exact rootHiddenPermissiveRelates_pure target leftOutput rightOutput none + | some part => + exact (rootHiddenPermissiveRelates_ensureTreePath target leftOutput rightOutput lay + (treeIndexAt index lay) (leafIndexAt index lay)).bind fun _ _ _ => + rootHiddenPermissiveRelates_pure target leftOutput rightOutput (some part) + +theorem relTriple_rootHiddenPermissive_maskedTreeRoot_target + (lay : Layer) (tree : TreeIndex) + (leftOutput rightOutput : HashOutput) + (leftState rightState : LazyRevealProbe.State Coordinate) + (hstate : RootHiddenStateRel (layerRootPosition lay tree) leftOutput rightOutput + leftState rightState) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel (layerRootPosition lay tree) leftOutput rightOutput + leftCache rightCache) : + RelTriple + (runPermissiveFromTable leftState fuel table ((maskedTreeRoot lay tree).run leftCache)) + (runPermissiveFromTable rightState fuel table ((maskedTreeRoot lay tree).run rightCache)) + (RootHiddenPermissiveTargetRevealRel + (layerRootPosition lay tree) leftOutput rightOutput) := by + rw [maskedTreeRoot_eq_ensure_reveal, StateT.run_bind, StateT.run_bind, + runPermissiveFromTable_bind, runPermissiveFromTable_bind] + apply relTriple_bind + (rootHiddenPermissiveRelates_ensureTreeNode (layerRootPosition lay tree) leftOutput rightOutput + lay tree (layerHeight lay) 0 leftState rightState hstate fuel table leftCache rightCache + hcache) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [RootHiddenCleanRelWith] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootHiddenCleanRelWith] at hresult + | some rightResult => + rcases hresult with ⟨hnextState, hremaining, htable, _hvalue, hnextCache⟩ + simp only + rw [← hremaining, ← htable] + exact relTriple_rootHiddenPermissive_revealPosition_target + (layerRootPosition lay tree) leftOutput rightOutput leftResult.state + rightResult.state hnextState leftResult.remaining leftResult.table + leftResult.value.2 rightResult.value.2 hnextCache + +theorem relTriple_rootHiddenPermissive_maskedLayerMessage_target + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (index : Index) (lay : Layer) + (htarget : layerMessagePosition index lay = target) + (leftOutput rightOutput : HashOutput) + (leftState rightState : LazyRevealProbe.State Coordinate) + (hstate : RootHiddenStateRel target leftOutput rightOutput leftState rightState) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache) : + RelTriple + (runPermissiveFromTable leftState fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run leftCache)) + (runPermissiveFromTable rightState fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run rightCache)) + (RootHiddenPermissiveTargetRevealRel target leftOutput rightOutput) := by + obtain ⟨below, hcomputation, hposition⟩ := + layerMessage_root_witness_of_isLayerRoot parameter ftsSecret target hroot index lay htarget + have htargetRoot : target = layerRootPosition below (treeIndexAt index below) := + htarget.symm.trans hposition + rw [hcomputation] + rw [htargetRoot] at hstate hcache ⊢ + exact relTriple_rootHiddenPermissive_maskedTreeRoot_target below (treeIndexAt index below) + leftOutput rightOutput leftState rightState hstate fuel table leftCache rightCache hcache + +theorem rootHiddenPermissiveRelates_maskedSignLayer_comparison_actual + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (index : Index) (lay : Layer) + (htarget : layerMessagePosition index lay = target) + (leftOutput rightOutput : HashOutput) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (maskedSignLayerWithComparisonRoot parameter ftsSecret index lay + (truncateHash rightOutput)) + (maskedSignLayer parameter ftsSecret index lay) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + unfold maskedSignLayerWithComparisonRoot maskedSignLayer + rw [StateT.run_bind, StateT.run_bind, runPermissiveFromTable_bind, + runPermissiveFromTable_bind] + apply relTriple_bind + (relTriple_rootHiddenPermissive_maskedLayerMessage_target parameter ftsSecret target hroot + index lay htarget leftOutput rightOutput leftState rightState hstate fuel table leftCache + rightCache hcache) + intro leftMessage rightMessage hmessage + cases leftMessage with + | none => + cases rightMessage with + | none => exact relTriple_pure_pure trivial + | some rightMessage => simp [RootHiddenPermissiveTargetRevealRel] at hmessage + | some leftMessage => + cases rightMessage with + | none => simp [RootHiddenPermissiveTargetRevealRel] at hmessage + | some rightMessage => + rcases hmessage with ⟨hnextState, hremaining, htable, _hleftMessage, + hrightMessage, hnextCache⟩ + simp only + rw [← hremaining, ← htable, hrightMessage] + exact rootHiddenPermissiveRelates_maskedOtsLayerAfterMessage target leftOutput + rightOutput parameter index lay (truncateHash rightOutput) leftMessage.state + rightMessage.state hnextState leftMessage.remaining leftMessage.table + leftMessage.value.2 rightMessage.value.2 hnextCache + +theorem rootHiddenPermissiveRelates_maskedTreeRoot_of_ne + (target : Position) (leftOutput rightOutput : HashOutput) + (lay : Layer) (tree : TreeIndex) + (hne : layerRootPosition lay tree ≠ target) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (maskedTreeRoot lay tree) (maskedTreeRoot lay tree) := by + rw [maskedTreeRoot_eq_ensure_reveal] + exact (rootHiddenPermissiveRelates_ensureTreeNode target leftOutput rightOutput lay tree + (layerHeight lay) 0).bind fun _ _ _ => + rootHiddenPermissiveRelates_revealCoordinate_of_ne target leftOutput rightOutput + (.position (layerRootPosition lay tree)) (by simpa using hne) + +theorem rootHiddenPermissiveRelates_maskedLayerMessage_of_ne + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (leftOutput rightOutput : HashOutput) + (index : Index) (lay : Layer) + (hne : layerMessagePosition index lay ≠ target) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (maskedLayerMessage parameter ftsSecret index lay) + (maskedLayerMessage parameter ftsSecret index lay) := by + fin_cases lay + · rw [maskedLayerMessage, dif_pos (by decide)] + apply rootHiddenPermissiveRelates_maskedTreeRoot_of_ne + simpa [layerMessagePosition_top, layerRootPosition] + · rw [maskedLayerMessage, dif_pos (by decide)] + apply rootHiddenPermissiveRelates_maskedTreeRoot_of_ne + simpa [layerMessagePosition_middle, layerRootPosition] + · rw [maskedLayerMessage, dif_neg (by decide)] + exact rootHiddenPermissiveRelates_simulateQ target leftOutput rightOutput ordinaryHashImpl + ordinaryHashImpl (rootHiddenPermissiveRelates_ordinaryHashImpl target leftOutput rightOutput) + (ftsKey parameter index (ftsSecret index)) + +theorem rootHiddenPermissiveRelates_maskedSignLayer_of_ne + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (leftOutput rightOutput : HashOutput) + (index : Index) (lay : Layer) + (hne : layerMessagePosition index lay ≠ target) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (maskedSignLayer parameter ftsSecret index lay) + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + exact (rootHiddenPermissiveRelates_maskedLayerMessage_of_ne parameter ftsSecret target + leftOutput rightOutput index lay hne).bind fun leftMessage rightMessage hmessage => by + subst rightMessage + exact rootHiddenPermissiveRelates_maskedOtsLayerAfterMessage target leftOutput rightOutput + parameter index lay leftMessage + +theorem rootHiddenPermissiveRelates_maskedSignLayerWithTargetComparison_actual + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (index : Index) (lay : Layer) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (maskedSignLayerWithTargetComparison parameter target (truncateHash rightOutput) + ftsSecret index lay) + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayerWithTargetComparison + by_cases htarget : layerMessagePosition index lay = target + · rw [if_pos htarget] + exact rootHiddenPermissiveRelates_maskedSignLayer_comparison_actual parameter ftsSecret target + hroot index lay htarget leftOutput rightOutput + · rw [if_neg htarget] + exact rootHiddenPermissiveRelates_maskedSignLayer_of_ne parameter ftsSecret target + leftOutput rightOutput index lay htarget + +theorem rootHiddenPermissiveRelates_maskedSignLayersWithTargetComparison_actual + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) (index : Index) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (maskedSignLayersWithTargetComparison parameter target (truncateHash rightOutput) + ftsSecret index) + (sequenceFin fun lay => maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayersWithTargetComparison + exact rootHiddenPermissiveRelates_sequenceFin target leftOutput rightOutput _ _ fun lay => + rootHiddenPermissiveRelates_maskedSignLayerWithTargetComparison_actual parameter ftsSecret + target hroot leftOutput rightOutput index lay + +theorem rootHiddenPermissiveRelates_revealLayerValues + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (revealLayerValues index lay encoding) (revealLayerValues index lay encoding) := by + unfold revealLayerValues + apply (rootHiddenPermissiveRelates_sequenceFin target leftOutput rightOutput _ _ fun chainIdx => + rootHiddenPermissiveRelates_revealPublishedCoordinate_of_ne target leftOutput rightOutput + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + (encoding chainIdx)) + (chainValueCoordinate_ne_layerRoot hroot lay (treeIndexAt index lay) + (leafIndexAt index lay) chainIdx (encoding chainIdx))).bind + intro leftValues rightValues hvalues + subst rightValues + apply (rootHiddenPermissiveRelates_sequenceFin target leftOutput rightOutput _ _ fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + cases hzero : level.val with + | zero => + exact rootHiddenPermissiveRelates_revealPublishedCoordinate_of_ne target leftOutput + rightOutput (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) (by + obtain ⟨rootLay, rootTree, rfl⟩ := hroot + simp [layerRootPosition]) + | succ current => + rw [Nat.add_one] + simp only + by_cases hcurrent : current < maxLayerHeight + · rw [dif_pos hcurrent] + exact rootHiddenPermissiveRelates_revealPublishedCoordinate_of_ne target leftOutput + rightOutput (.position (.node lay (treeIndexAt index lay) ⟨current, hcurrent⟩ + (leafOfNat (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + (by + intro heq + exact (pathNode_ne_layerRoot hroot lay (treeIndexAt index lay) current hcurrent _ + (by omega)) (Coordinate.position.inj heq)) + · rw [dif_neg hcurrent] + exact rootHiddenPermissiveRelates_pure target leftOutput rightOutput 0 + · rw [if_neg hlevel] + exact rootHiddenPermissiveRelates_pure target leftOutput rightOutput 0).bind + intro leftPath rightPath hpath + subst rightPath + exact rootHiddenPermissiveRelates_pure target leftOutput rightOutput (leftValues, leftPath) + +theorem rootHiddenPermissiveRelates_maskedSignAfterDigestWithTargetComparison_actual + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (maskedSignAfterDigestWithTargetComparison parameter target (truncateHash rightOutput) + ftsSecret randomness index leaves) + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigestWithTargetComparison maskedSignAfterDigest + apply (rootHiddenPermissiveRelates_simulateQ target leftOutput rightOutput ordinaryHashImpl + ordinaryHashImpl (rootHiddenPermissiveRelates_ordinaryHashImpl target leftOutput rightOutput) + (ftsOpen parameter index leaves (ftsSecret index))).bind + intro leftPath rightPath hpath + subst rightPath + apply (rootHiddenPermissiveRelates_maskedSignLayersWithTargetComparison_actual parameter ftsSecret + target hroot leftOutput rightOutput index).bind + intro leftLayers rightLayers hlayers + subst rightLayers + cases hparts : traverseOption leftLayers with + | none => exact rootHiddenPermissiveRelates_pure target leftOutput rightOutput none + | some parts => + apply (rootHiddenPermissiveRelates_sequenceFin target leftOutput rightOutput _ _ fun lay => + rootHiddenPermissiveRelates_revealLayerValues target hroot leftOutput rightOutput index lay + (parts lay).2).bind + intro leftRevealed rightRevealed hrevealed + subst rightRevealed + let signature : Signature := + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := leftPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (leftRevealed lay).1 + authPath := flattenPaths fun lay => (leftRevealed lay).2 } + exact rootHiddenPermissiveRelates_pure target leftOutput rightOutput (some signature) + +theorem rootHiddenPermissiveRelates_ordinaryRomImpl + (target : Position) (leftOutput rightOutput : HashOutput) + (query : OracleWorld.Domain) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (ordinaryRomImpl query) (ordinaryRomImpl query) := by + cases query with + | inl n => exact rootHiddenPermissiveRelates_splitUniformImpl target leftOutput rightOutput n + | inr input => exact rootHiddenPermissiveRelates_ordinaryHashImpl target leftOutput rightOutput input + +theorem rootHiddenPermissiveRelates_maskedSignWithTargetComparison_actual + (parameter : PublicParameter) (publicRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) (message : Message) : + RootHiddenPermissiveRelates target leftOutput rightOutput + (maskedSignWithTargetComparison parameter publicRoot target (truncateHash rightOutput) + ftsSecret message) + (maskedSign parameter publicRoot ftsSecret message) := by + unfold maskedSignWithTargetComparison maskedSign + let secretKey : SecretKey := + ⟨parameter, publicRoot, fun _ _ _ _ => 0, ftsSecret⟩ + apply (rootHiddenPermissiveRelates_simulateQ target leftOutput rightOutput ordinaryRomImpl + ordinaryRomImpl (rootHiddenPermissiveRelates_ordinaryRomImpl target leftOutput rightOutput) + (signDigestLoop digestAttemptLimit secretKey message)).bind + intro leftSelected rightSelected hselected + subst rightSelected + cases leftSelected with + | none => exact rootHiddenPermissiveRelates_pure target leftOutput rightOutput none + | some selected => + exact rootHiddenPermissiveRelates_maskedSignAfterDigestWithTargetComparison_actual parameter + ftsSecret target hroot leftOutput rightOutput selected.1 selected.2.1 selected.2.2 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwapAfterTable.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwapAfterTable.lean new file mode 100644 index 00000000..261bceb8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwapAfterTable.lean @@ -0,0 +1,187 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwapProbability + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +noncomputable def delayedRootGuessAfterInitialResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Option (CleanRunResult (Digest × SplitHashCache)) → + ProbComp (Option PermissivePrivateOrdinalSelection × Digest) + | none => do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (none, rightRoot) + | some rootResult => do + let selection ← delayedPermissiveDetailedSelectionAfterRootResult ordinal adversary + parameter ftsSecret rootResult + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot) + +noncomputable def installedDelayedSelectionAfterInitialResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (target : Position) : + Option (CleanRunResult (Digest × SplitHashCache)) → + ProbComp (Option PermissivePrivateOrdinalSelection) + | none => pure none + | some rootResult => + installedDelayedPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult + +set_option maxRecDepth 100000 in +theorem probEvent_delayedRootGuess_afterInitialResult_le_installed_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (result : Option (CleanRunResult (Digest × SplitHashCache))) + (habsent : InitialRootOptionFacts target result) + (hswap : InitialRootSwapFacts parameter target result) : + Pr[fun result : Option PermissivePrivateOrdinalSelection × Digest => + PermissiveDelayedRootGuess target result.2 ordinal result.1 | + delayedRootGuessAfterInitialResult ordinal adversary parameter ftsSecret result] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + installedDelayedSelectionAfterInitialResult ordinal adversary parameter ftsSecret target + result] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + cases result with + | none => + simp [delayedRootGuessAfterInitialResult, installedDelayedSelectionAfterInitialResult, + PermissiveDelayedRootGuess, PermissiveDelayedRootGuessAt, + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?] + | some rootResult => + change rootResult.state.values (.position target) = none ∧ + Coordinate.position target ∉ rootResult.state.revealed ∧ + rootResult.state.pending = ∅ at habsent + change ∀ leftRoot rightRoot, + swapCanonicalRootEncodingCache parameter target leftRoot rightRoot rootResult.value.2 = + rootResult.value.2 at hswap + exact probEvent_delayedRootGuess_afterRootResult_le_installed_mul ordinal adversary parameter + ftsSecret target hroot rootResult habsent.1 habsent.2.1 hswap + +set_option maxRecDepth 100000 in +theorem evalDist_delayedRootGuess_afterTable_eq_initial_bind + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + evalDist (do + let selection ← delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret fuel table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot)) = + evalDist (rootAwareProductionInitialRun fuel table >>= + delayedRootGuessAfterInitialResult ordinal adversary parameter ftsSecret) := by + unfold delayedPermissiveDetailedSelectionExperimentAfterTable + delayedRootGuessAfterInitialResult delayedPermissiveDetailedSelectionAfterRootResult + simp only [bind_assoc] + apply evalDist_bind_congr + intro result + cases result <;> intro _ <;> rfl + +theorem probEvent_bind_le_bind_mul_of_forall_of_invariant + (first : ProbComp ι) (left : ι → ProbComp α) (right : ι → ProbComp β) + (event : α → Prop) (gate : β → Prop) (epsilon : ENNReal) + (invariant : ι → Prop) + (hinvariant : ∀ index ∈ support first, invariant index) + (hbound : ∀ index, invariant index → + Pr[event | left index] ≤ Pr[gate | right index] * epsilon) : + Pr[event | first >>= left] ≤ Pr[gate | first >>= right] * epsilon := + probEvent_bind_le_bind_mul_of_forall first left right event gate epsilon + (fun index hindex => hbound index (hinvariant index hindex)) + +set_option maxRecDepth 100000 in +theorem probEvent_initial_bind_delayedRootGuess_le_installed_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + Pr[fun result : Option PermissivePrivateOrdinalSelection × Digest => + PermissiveDelayedRootGuess target result.2 ordinal result.1 | + rootAwareProductionInitialRun fuel table >>= + delayedRootGuessAfterInitialResult ordinal adversary parameter ftsSecret] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + rootAwareProductionInitialRun fuel table >>= + installedDelayedSelectionAfterInitialResult ordinal adversary parameter ftsSecret target] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + exact probEvent_bind_le_bind_mul_of_forall_of_invariant + (first := rootAwareProductionInitialRun fuel table) + (left := delayedRootGuessAfterInitialResult ordinal adversary parameter ftsSecret) + (right := installedDelayedSelectionAfterInitialResult ordinal adversary parameter ftsSecret + target) + (event := fun result : Option PermissivePrivateOrdinalSelection × Digest => + PermissiveDelayedRootGuess target result.2 ordinal result.1) + (gate := fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target) + (epsilon := ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + (invariant := InitialRootAllFacts parameter target) + (initialRootAllFacts_of_mem parameter target hroot hparent fuel table) + (fun result hfacts => + probEvent_delayedRootGuess_afterInitialResult_le_installed_mul ordinal adversary parameter + ftsSecret target hroot result hfacts.1 hfacts.2) + +set_option maxRecDepth 100000 in +theorem probEvent_delayedRootGuess_afterTable_le_installed_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + Pr[fun result : Option PermissivePrivateOrdinalSelection × Digest => + PermissiveDelayedRootGuess target result.2 ordinal result.1 | do + let selection ← delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret fuel table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot)] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + installedDelayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ = Pr[fun result : Option PermissivePrivateOrdinalSelection × Digest => + PermissiveDelayedRootGuess target result.2 ordinal result.1 | + rootAwareProductionInitialRun fuel table >>= + delayedRootGuessAfterInitialResult ordinal adversary parameter ftsSecret] := by + apply OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + exact evalDist_delayedRootGuess_afterTable_eq_initial_bind ordinal adversary parameter + ftsSecret fuel table + _ ≤ Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + rootAwareProductionInitialRun fuel table >>= + installedDelayedSelectionAfterInitialResult ordinal adversary parameter ftsSecret target] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + probEvent_initial_bind_delayedRootGuess_le_installed_mul ordinal adversary parameter + ftsSecret target hroot hparent fuel table + _ = _ := by + rfl + +set_option maxRecDepth 100000 in +theorem probEvent_delayedRootGuess_afterTable_le_common_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + Pr[fun result : Option PermissivePrivateOrdinalSelection × Digest => + PermissiveDelayedRootGuess target result.2 ordinal result.1 | do + let selection ← delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret fuel table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot)] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + installedDelayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + probEvent_delayedRootGuess_afterTable_le_installed_mul ordinal adversary parameter ftsSecret + target hroot hparent fuel table + _ ≤ _ := by + gcongr + exact probEvent_installedDelayedSelection_fiber_le_common ordinal adversary parameter + ftsSecret target hroot hparent fuel table + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwapEncoding.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwapEncoding.lean new file mode 100644 index 00000000..93ec4cda --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwapEncoding.lean @@ -0,0 +1,1399 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwap + +/-! +# Permissive encoding-root swap + +The first half of the delayed root exchange changes the root used in encoding inputs while keeping +the hidden structural state fixed. This relation retains permissive executions, including an +unrelated pending hit. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def RootEncodingPermissiveCleanSameRel + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) : + Option (CleanRunResult (α × SplitHashCache)) → + Option (CleanRunResult (α × SplitHashCache)) → Prop + | some left, some right => + left.state = right.state ∧ left.remaining = right.remaining ∧ + left.table = right.table ∧ left.value.1 = right.value.1 ∧ + RootEncodingCacheRel parameter target leftRoot rightRoot left.value.2 right.value.2 + | none, none => True + | _, _ => False + +def RootEncodingPermissiveRelates + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftCache rightCache, + RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache → + ∀ state fuel table, + RelTriple + (runPermissiveFromTable state fuel table (left.run leftCache)) + (runPermissiveFromTable state fuel table (right.run rightCache)) + (RootEncodingPermissiveCleanSameRel parameter target leftRoot rightRoot) + +def RootEncodingPermissiveCouples + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + RootEncodingPermissiveRelates parameter target leftRoot rightRoot computation computation + +theorem rootEncodingPermissiveCouples_pure + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (value : α) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := by + intro leftCache rightCache hcache state fuel table + simp only [StateT.run_pure, runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem RootEncodingPermissiveRelates.bind + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {leftNext rightNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hfirst : RootEncodingPermissiveRelates parameter target leftRoot rightRoot left right) + (hnext : ∀ leftValue rightValue, leftValue = rightValue → + RootEncodingPermissiveRelates parameter target leftRoot rightRoot + (leftNext leftValue) (rightNext rightValue)) : + RootEncodingPermissiveRelates parameter target leftRoot rightRoot + (left >>= leftNext) (right >>= rightNext) := by + intro leftCache rightCache hcache state fuel table + rw [StateT.run_bind, StateT.run_bind, runPermissiveFromTable_bind, + runPermissiveFromTable_bind] + apply relTriple_bind (hfirst leftCache rightCache hcache state fuel table) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [RootEncodingPermissiveCleanSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootEncodingPermissiveCleanSameRel] at hresult + | some rightResult => + rcases hresult with ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + simp only + rw [← hstate, ← hremaining, ← htable, ← hvalue] + exact hnext leftResult.value.1 leftResult.value.1 rfl leftResult.value.2 + rightResult.value.2 hnextCache leftResult.state leftResult.remaining leftResult.table + +theorem RootEncodingPermissiveCouples.bind + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hfirst : RootEncodingPermissiveCouples parameter target leftRoot rightRoot left) + (hnext : ∀ value, + RootEncodingPermissiveCouples parameter target leftRoot rightRoot (next value)) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot (left >>= next) := + RootEncodingPermissiveRelates.bind hfirst fun leftValue rightValue hvalue => by + subst rightValue + exact hnext leftValue + +theorem rootEncodingPermissiveCouples_sequenceFin + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (computation index)) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (sequenceFin computation) := by + induction n with + | zero => + simp only [sequenceFin] + exact rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomponent 0).bind fun head => + (ih (fun index : Fin n => computation index.succ) + (fun index => hcomponent index.succ)).bind fun tail => + rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot + (Fin.cases head tail : Fin (n + 1) → α) + +theorem rootEncodingPermissiveCouples_ensureCoordinate + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (coordinate : Coordinate) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (ensureCoordinate coordinate) := by + intro leftCache rightCache hcache state fuel table + unfold ensureCoordinate LazyRevealProbe.ensureQuery + rw [StateT.run_liftM, StateT.run_liftM, + runPermissiveFromTable_ensure_query_bind, runPermissiveFromTable_ensure_query_bind] + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem rootEncodingPermissiveCouples_splitUniformImpl + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (n : Nat) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (splitUniformImpl n) := by + intro leftCache rightCache hcache state fuel table + unfold splitUniformImpl LazyRevealProbe.uniformQuery + rw [StateT.run_liftM, StateT.run_liftM, + runPermissiveFromTable_uniform_query_bind, runPermissiveFromTable_uniform_query_bind] + apply relTriple_bind + (relTriple_refl (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem relTriple_rootEncodingPermissive_splitHashQuery_same_nonroot + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (key : SplitHashKey) + (hkey : ¬RootEncodingKey parameter target key) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + RelTriple + (runPermissiveFromTable state fuel table ((splitHashQuery key).run leftCache)) + (runPermissiveFromTable state fuel table ((splitHashQuery key).run rightCache)) + (RootEncodingPermissiveCleanSameRel parameter target leftRoot rightRoot) := by + have hlookup := hcache.lookup_nonroot key hkey + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + cases hleft : leftCache key with + | some output => + have hright : rightCache key = some output := by + rw [← hlookup] + exact hleft + simp only [hright, runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + | none => + have hright : rightCache key = none := by + rw [← hlookup] + exact hleft + simp only [hright] + unfold LazyRevealProbe.hashOutputQuery + rw [runPermissiveFromTable_hashOutput_query_bind, + runPermissiveFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_nonroot key leftOutput hkey⟩ + +theorem rootEncodingPermissiveCouples_splitHashQuery_same_nonroot + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (key : SplitHashKey) + (hkey : ¬RootEncodingKey parameter target key) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (splitHashQuery key) := by + intro leftCache rightCache hcache state fuel table + exact relTriple_rootEncodingPermissive_splitHashQuery_same_nonroot parameter target leftRoot + rightRoot key hkey leftCache rightCache hcache state fuel table + +theorem rootEncodingPermissiveCouples_revealCoordinate + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (coordinate : Coordinate) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (revealCoordinate coordinate) := by + intro leftCache rightCache hcache state fuel table + rw [revealCoordinate_run, revealCoordinate_run, LazyRevealProbe.revealQuery, + runPermissiveFromTable_reveal_query_bind, runPermissiveFromTable_reveal_query_bind] + have hhidden : ¬RootEncodingKey parameter target (.hidden coordinate) := + not_rootEncodingKey_hidden parameter target coordinate + cases hvalue : state.values coordinate with + | some output => + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_nonroot (.hidden coordinate) output hhidden⟩ + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_nonroot + (.hidden (.chainStart lay tree leafIdx chainIdx)) + (table ⟨lay, tree, leafIdx, chainIdx⟩) hhidden⟩ + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_nonroot (.hidden (.position position)) leftOutput hhidden⟩ + +theorem rootEncodingPermissiveCouples_publishCoordinate + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (coordinate : Coordinate) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (publishCoordinate coordinate) := by + intro leftCache rightCache hcache state fuel table + unfold publishCoordinate LazyRevealProbe.publishQuery + rw [StateT.run_liftM, StateT.run_liftM, + runPermissiveFromTable_publish_query_bind, runPermissiveFromTable_publish_query_bind] + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem relTriple_rootEncodingPermissive_splitHashQuery_encodingRetryInput + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (position : EncodingPosition) (counter : Nat) + (hposition : EncodingPositionNamesRoot target position) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + RelTriple + (runPermissiveFromTable state fuel table + ((splitHashQuery (.ordinary + (encodingRetryInput parameter position leftRoot counter))).run leftCache)) + (runPermissiveFromTable state fuel table + ((splitHashQuery (.ordinary + (encodingRetryInput parameter position rightRoot counter))).run rightCache)) + (RootEncodingPermissiveCleanSameRel parameter target leftRoot rightRoot) := by + let leftInput := encodingRetryInput parameter position leftRoot counter + let rightInput := encodingRetryInput parameter position rightRoot counter + have hlookup := hcache.retry position counter hposition + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + cases hleft : leftCache (.ordinary leftInput) with + | some output => + have hright : rightCache (.ordinary rightInput) = some output := by + rw [← hlookup] + exact hleft + simp only [rightInput, hright, runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + | none => + have hright : rightCache (.ordinary rightInput) = none := by + rw [← hlookup] + exact hleft + simp only [rightInput, hright] + unfold LazyRevealProbe.hashOutputQuery + rw [runPermissiveFromTable_hashOutput_query_bind, + runPermissiveFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_retry position counter hposition leftOutput⟩ + +theorem relTriple_rootEncodingPermissiveAttemptRun + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (position : EncodingPosition) (counter : Nat) + (hposition : EncodingPositionNamesRoot target position) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + RelTriple + (runPermissiveFromTable state fuel table + (rootEncodingAttemptRun parameter position leftRoot counter leftCache)) + (runPermissiveFromTable state fuel table + (rootEncodingAttemptRun parameter position rightRoot counter rightCache)) + (RootEncodingPermissiveCleanSameRel parameter target leftRoot rightRoot) := by + unfold rootEncodingAttemptRun + rw [runPermissiveFromTable_bind, runPermissiveFromTable_bind] + apply relTriple_bind + (relTriple_rootEncodingPermissive_splitHashQuery_encodingRetryInput parameter target leftRoot + rightRoot position counter hposition leftCache rightCache hcache state fuel table) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [RootEncodingPermissiveCleanSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootEncodingPermissiveCleanSameRel] at hresult + | some rightResult => + rcases hresult with ⟨hstate, hremaining, htable, houtput, hnextCache⟩ + simp only + rw [← hstate, ← hremaining, ← htable, ← houtput] + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hnextCache⟩ + +theorem rootEncodingPermissiveRelates_encode + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (position : EncodingPosition) (counter : Nat) + (hposition : EncodingPositionNamesRoot target position) : + RootEncodingPermissiveRelates parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl + (encode parameter position.lay position.tree position.leafIdx leftRoot + (BitVec.ofNat counterBits counter))) + (simulateQ ordinaryHashImpl + (encode parameter position.lay position.tree position.leafIdx rightRoot + (BitVec.ofNat counterBits counter))) := by + intro leftCache rightCache hcache state fuel table + rw [← rootEncodingAttemptRun_eq_encode parameter position leftRoot counter leftCache, + ← rootEncodingAttemptRun_eq_encode parameter position rightRoot counter rightCache] + exact relTriple_rootEncodingPermissiveAttemptRun parameter target leftRoot rightRoot position + counter hposition leftCache rightCache hcache state fuel table + +theorem rootEncodingPermissiveRelates_maskedOtsSignFrom + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) + (hposition : EncodingPositionNamesRoot target ⟨lay, tree, leafIdx⟩) : + ∀ attempts counter, + RootEncodingPermissiveRelates parameter target leftRoot rightRoot + (maskedOtsSignFrom parameter lay tree leafIdx leftRoot attempts counter) + (maskedOtsSignFrom parameter lay tree leafIdx rightRoot attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom, maskedOtsSignFrom] + exact rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot none + | attempts + 1, counter => by + rw [maskedOtsSignFrom, maskedOtsSignFrom] + apply (rootEncodingPermissiveRelates_encode parameter target leftRoot rightRoot + ⟨lay, tree, leafIdx⟩ counter hposition).bind + intro leftEncoded rightEncoded hencoded + subst rightEncoded + cases leftEncoded with + | none => + exact rootEncodingPermissiveRelates_maskedOtsSignFrom parameter target leftRoot + rightRoot lay tree leafIdx hposition attempts (counter + 1) + | some encoding => + exact (rootEncodingPermissiveCouples_sequenceFin parameter target leftRoot rightRoot + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx (encoding chainIdx)) + (fun chainIdx => by + unfold ensureChainPrefix + apply (rootEncodingPermissiveCouples_sequenceFin parameter target leftRoot + rightRoot _ fun step => by + by_cases hstep : step.val < (encoding chainIdx).val + · rw [if_pos hstep] + exact rootEncodingPermissiveCouples_ensureCoordinate parameter target + leftRoot rightRoot (.position (.chain lay tree leafIdx chainIdx step)) + · rw [if_neg hstep] + exact rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot + ()).bind fun _ => + rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot + ())).bind fun _ => + rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem rootEncodingPermissiveRelates_maskedOtsSign + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) + (hposition : EncodingPositionNamesRoot target ⟨lay, tree, leafIdx⟩) : + RootEncodingPermissiveRelates parameter target leftRoot rightRoot + (maskedOtsSign parameter lay tree leafIdx leftRoot) + (maskedOtsSign parameter lay tree leafIdx rightRoot) := + rootEncodingPermissiveRelates_maskedOtsSignFrom parameter target leftRoot rightRoot lay tree + leafIdx hposition encodingAttemptLimit 0 + +theorem rootEncodingPermissiveCouples_ensureFullChain + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (rootEncodingPermissiveCouples_sequenceFin parameter target leftRoot rightRoot _ + fun step => rootEncodingPermissiveCouples_ensureCoordinate parameter target leftRoot rightRoot + (.position (.chain lay tree leafIdx chainIdx step))).bind fun _ => + rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot () + +theorem rootEncodingPermissiveCouples_ensureOtsLeaf + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (rootEncodingPermissiveCouples_sequenceFin parameter target leftRoot rightRoot _ + fun chainIdx => rootEncodingPermissiveCouples_ensureFullChain parameter target leftRoot + rightRoot lay tree leafIdx chainIdx).bind fun _ => + rootEncodingPermissiveCouples_ensureCoordinate parameter target leftRoot rightRoot + (.position (.leaf lay tree leafIdx)) + +theorem rootEncodingPermissiveCouples_ensureTreeNode + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) : ∀ level nodeIdx, + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => by + rw [ensureTreeNode] + exact rootEncodingPermissiveCouples_ensureOtsLeaf parameter target leftRoot rightRoot lay + tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (rootEncodingPermissiveCouples_ensureTreeNode parameter target leftRoot rightRoot lay + tree level (2 * nodeIdx)).bind fun _ => + (rootEncodingPermissiveCouples_ensureTreeNode parameter target leftRoot rightRoot lay + tree level (2 * nodeIdx + 1)).bind fun _ => by + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact rootEncodingPermissiveCouples_ensureCoordinate parameter target leftRoot + rightRoot (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot () + +theorem rootEncodingPermissiveCouples_ensureTreePath + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (rootEncodingPermissiveCouples_sequenceFin parameter target leftRoot rightRoot _ + fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + exact rootEncodingPermissiveCouples_ensureTreeNode parameter target leftRoot rightRoot lay + tree level.val (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · rw [if_neg hlevel] + exact rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot ()).bind + fun _ => rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot () + +theorem rootEncodingPermissiveCouples_revealPublishedCoordinate + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (coordinate : Coordinate) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + exact (rootEncodingPermissiveCouples_revealCoordinate parameter target leftRoot rightRoot + coordinate).bind fun _ => + (rootEncodingPermissiveCouples_publishCoordinate parameter target leftRoot rightRoot + coordinate).bind fun _ => + rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot _ + +theorem rootEncodingPermissiveCouples_revealLayerValues + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (revealLayerValues index lay encoding) := by + unfold revealLayerValues + apply (rootEncodingPermissiveCouples_sequenceFin parameter target leftRoot rightRoot _ + fun chainIdx => rootEncodingPermissiveCouples_revealPublishedCoordinate parameter target + leftRoot rightRoot + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + (encoding chainIdx))).bind + intro values + apply (rootEncodingPermissiveCouples_sequenceFin parameter target leftRoot rightRoot _ + fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + cases hzero : level.val with + | zero => + exact rootEncodingPermissiveCouples_revealPublishedCoordinate parameter target + leftRoot rightRoot (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | succ current => + rw [Nat.add_one] + simp only + by_cases hcurrent : current < maxLayerHeight + · rw [dif_pos hcurrent] + exact rootEncodingPermissiveCouples_revealPublishedCoordinate parameter target + leftRoot rightRoot (.position (.node lay (treeIndexAt index lay) + ⟨current, hcurrent⟩ + (leafOfNat (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + · rw [dif_neg hcurrent] + exact rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot 0 + · rw [if_neg hlevel] + exact rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot 0).bind + intro path + exact rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot (values, path) + +theorem rootEncodingPermissiveCouples_tweakableHash_of_not_encoding + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (domain : HashDomain) (payload : HashInput) + (hinRange : domain.InRange) + (hnotEncoding : ∀ lay tree leafIdx, domain ≠ .encoding lay tree leafIdx) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl (tweakableHash parameter domain payload)) := by + unfold tweakableHash oracleHash + simp only [simulateQ_bind, HasQuery.instOfMonadLift_query, simulateQ_spec_query, + simulateQ_pure] + exact (rootEncodingPermissiveCouples_splitHashQuery_same_nonroot parameter target leftRoot + rightRoot (.ordinary (tweakableHashInput parameter domain payload)) + (not_encodingInputNamesRoot_tweakableHashInput_of_not_encoding parameter target domain + payload hinRange hnotEncoding)).bind fun _ => + rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot _ + +theorem rootEncodingPermissiveCouples_ftsLeafHash + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) (tree : FtsTree) + (leafIdx : FtsLeaf) (secret : Digest) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl (ftsLeafHash parameter index tree leafIdx secret)) := by + unfold ftsLeafHash + exact rootEncodingPermissiveCouples_tweakableHash_of_not_encoding parameter target leftRoot + rightRoot (.ftsLeaf index tree leafIdx) (digestBytes secret) (by trivial) (by simp) + +theorem rootEncodingPermissiveCouples_ftsNode + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) (tree : FtsTree) + (secret : FtsLeaf → Digest) : ∀ level nodeIdx, + level ≤ ftsTreeHeight → + 2 ^ level * (nodeIdx + 1) ≤ 2 ^ ftsTreeHeight → + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl (ftsNode parameter index tree secret level nodeIdx)) + | 0, nodeIdx, _hlevel, _hspan => by + rw [ftsNode_zero_eq] + exact rootEncodingPermissiveCouples_ftsLeafHash parameter target leftRoot rightRoot index + tree (ftsLeafOfNat nodeIdx) (secret (ftsLeafOfNat nodeIdx)) + | level + 1, nodeIdx, hlevel, hspan => by + rw [ftsNode_succ_eq] + simp only [simulateQ_bind] + have hleftSpan : 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ ftsTreeHeight := by + rw [pow_succ] at hspan + calc + 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ level * (2 * (nodeIdx + 1)) := + Nat.mul_le_mul_left _ (by omega) + _ = 2 ^ level * 2 * (nodeIdx + 1) := by ring + _ ≤ 2 ^ ftsTreeHeight := hspan + have hrightSpan : 2 ^ level * (2 * nodeIdx + 1 + 1) ≤ 2 ^ ftsTreeHeight := by + rw [pow_succ] at hspan + calc + 2 ^ level * (2 * nodeIdx + 1 + 1) = 2 ^ level * 2 * (nodeIdx + 1) := by ring + _ ≤ 2 ^ ftsTreeHeight := hspan + have hinRange : (HashDomain.ftsNode index tree (level + 1) nodeIdx).InRange := by + show level + 1 < 2 ^ 32 ∧ nodeIdx < 2 ^ 32 + constructor + · have : ftsTreeHeight < 2 ^ 32 := by norm_num [ftsTreeHeight] + omega + · have hnode : nodeIdx < 2 ^ ftsTreeHeight := by + have hpow : 0 < 2 ^ (level + 1) := Nat.two_pow_pos _ + nlinarith + have : 2 ^ ftsTreeHeight ≤ 2 ^ 32 := Nat.pow_le_pow_right (by omega) (by + norm_num [ftsTreeHeight]) + omega + exact (rootEncodingPermissiveCouples_ftsNode parameter target leftRoot rightRoot index tree + secret level (2 * nodeIdx) (by omega) hleftSpan).bind fun left => + (rootEncodingPermissiveCouples_ftsNode parameter target leftRoot rightRoot index tree + secret level (2 * nodeIdx + 1) (by omega) hrightSpan).bind fun right => + rootEncodingPermissiveCouples_tweakableHash_of_not_encoding parameter target + leftRoot rightRoot (.ftsNode index tree (level + 1) nodeIdx) + (nodePayload left right) hinRange (by simp) + +theorem rootEncodingPermissiveCouples_ftsKey + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) + (secret : FtsTree → FtsLeaf → Digest) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl (ftsKey parameter index secret)) := by + unfold ftsKey + rw [simulateQ_bind, simulateQ_ordinaryHashImpl_sequenceFin] + exact (rootEncodingPermissiveCouples_sequenceFin parameter target leftRoot rightRoot _ + fun tree => rootEncodingPermissiveCouples_ftsNode parameter target leftRoot rightRoot index + tree (secret tree) ftsTreeHeight 0 le_rfl (by simp)).bind fun roots => + rootEncodingPermissiveCouples_tweakableHash_of_not_encoding parameter target leftRoot + rightRoot (.ftsRoots index) (ftsRootsPayload roots) (by trivial) (by simp) + +theorem rootEncodingPermissiveCouples_ftsOpen + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) + (leaves : DigestTree → FtsLeaf) + (secret : FtsTree → FtsLeaf → Digest) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl (ftsOpen parameter index leaves secret)) := by + unfold ftsOpen + rw [simulateQ_ordinaryHashImpl_sequenceFin] + apply rootEncodingPermissiveCouples_sequenceFin + intro tree + rw [simulateQ_ordinaryHashImpl_sequenceFin] + apply rootEncodingPermissiveCouples_sequenceFin + intro level + exact rootEncodingPermissiveCouples_ftsNode parameter target leftRoot rightRoot index tree + (secret tree) level.val (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1) + (Nat.le_of_lt level.isLt) + (FtsProbeSimulation.ftsOpen_node_bound (leaves (ftsIndexOf tree)) level) + +theorem rootEncodingPermissiveCouples_simulateQ_splitUniformImpl + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (computation : ProbComp α) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (simulateQ splitUniformImpl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + rw [simulateQ_pure] + exact rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot value + | query_bind n next ih => + rw [simulateQ_query_bind] + exact (rootEncodingPermissiveCouples_splitUniformImpl parameter target leftRoot rightRoot + n).bind fun output => ih output + +theorem rootEncodingPermissiveCouples_messageDigest + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (publicRoot : Digest) + (message : Message) (randomness : Randomness) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl + (messageDigest parameter publicRoot message randomness)) := by + unfold messageDigest oracleHash + simp only [simulateQ_bind, HasQuery.instOfMonadLift_query, simulateQ_spec_query, + simulateQ_pure, ordinaryHashImpl] + exact (rootEncodingPermissiveCouples_splitHashQuery_same_nonroot parameter target leftRoot + rightRoot (.ordinary (tweakableHashInput parameter .message + (messageDigestPayload publicRoot message randomness))) + (not_encodingInputNamesRoot_tweakableHashInput_of_not_encoding parameter target .message + _ (by trivial) (by simp))).bind fun output => + rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot + (truncateMessageDigest output) + +theorem rootEncodingPermissiveCouples_signAttempt + (target : Position) (leftRoot rightRoot : Digest) + (secretKey : SecretKey) (message : Message) (randomness : Randomness) : + RootEncodingPermissiveCouples secretKey.parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl (signAttempt secretKey message randomness)) := by + unfold signAttempt + simp only [simulateQ_bind] + exact (rootEncodingPermissiveCouples_messageDigest secretKey.parameter target leftRoot + rightRoot secretKey.root message randomness).bind fun digest => by + split <;> + exact rootEncodingPermissiveCouples_pure secretKey.parameter target leftRoot rightRoot _ + +theorem rootEncodingPermissiveCouples_signDigestLoop + (target : Position) (leftRoot rightRoot : Digest) + (secretKey : SecretKey) (message : Message) : ∀ attempts, + RootEncodingPermissiveCouples secretKey.parameter target leftRoot rightRoot + (simulateQ ordinaryRomImpl (signDigestLoop attempts secretKey message)) + | 0 => by + rw [signDigestLoop, simulateQ_pure] + exact rootEncodingPermissiveCouples_pure secretKey.parameter target leftRoot rightRoot none + | attempts + 1 => by + rw [signDigestLoop, simulateQ_bind] + have hrandomness : RootEncodingPermissiveCouples secretKey.parameter target leftRoot + rightRoot (simulateQ ordinaryRomImpl (liftM sampleRandomness)) := by + rw [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_left] + exact rootEncodingPermissiveCouples_simulateQ_splitUniformImpl secretKey.parameter target + leftRoot rightRoot sampleRandomness + exact hrandomness.bind fun randomness => by + rw [simulateQ_bind] + have hattempt : RootEncodingPermissiveCouples secretKey.parameter target leftRoot + rightRoot (simulateQ ordinaryRomImpl + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))))) := by + rw [ordinaryRomImpl, QueryImpl.simulateQ_add_liftM_right] + exact rootEncodingPermissiveCouples_signAttempt target leftRoot rightRoot secretKey + message randomness + exact hattempt.bind fun attempt => by + cases attempt with + | none => + exact rootEncodingPermissiveCouples_signDigestLoop target leftRoot rightRoot + secretKey message attempts + | some selected => + rw [simulateQ_pure] + exact rootEncodingPermissiveCouples_pure secretKey.parameter target leftRoot + rightRoot (some (randomness, selected.1, selected.2)) + +theorem rootEncodingPermissiveCouples_encode_of_not_positionNames + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (position : EncodingPosition) + (message : Digest) (counter : Nat) + (hnotPosition : ¬EncodingPositionNamesRoot target position) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (simulateQ ordinaryHashImpl + (encode parameter position.lay position.tree position.leafIdx message + (BitVec.ofNat counterBits counter))) := by + unfold encode tweakableHash oracleHash + simp only [simulateQ_bind, HasQuery.instOfMonadLift_query, simulateQ_spec_query, + simulateQ_pure, ordinaryHashImpl, bind_assoc, pure_bind] + exact (rootEncodingPermissiveCouples_splitHashQuery_same_nonroot parameter target leftRoot + rightRoot (.ordinary (encodingRetryInput parameter position message counter)) + (not_encodingInputNamesRoot_encodingRetryInput_of_not_positionNames hnotPosition message + counter)).bind fun output => + rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot + (TargetSum.decodeDigest (truncateHash output)) + +theorem rootEncodingPermissiveCouples_maskedOtsSignFrom_of_not_positionNames + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) + (hnotPosition : ¬EncodingPositionNamesRoot target ⟨lay, tree, leafIdx⟩) : + ∀ attempts counter, + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom] + exact rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + apply (rootEncodingPermissiveCouples_encode_of_not_positionNames parameter target leftRoot + rightRoot ⟨lay, tree, leafIdx⟩ message counter hnotPosition).bind + intro encoded + cases encoded with + | none => + exact rootEncodingPermissiveCouples_maskedOtsSignFrom_of_not_positionNames parameter + target leftRoot rightRoot lay tree leafIdx message hnotPosition attempts (counter + 1) + | some encoding => + exact (rootEncodingPermissiveCouples_sequenceFin parameter target leftRoot rightRoot _ + fun chainIdx => by + unfold ensureChainPrefix + exact (rootEncodingPermissiveCouples_sequenceFin parameter target leftRoot + rightRoot _ fun step => by + by_cases hstep : step.val < (encoding chainIdx).val + · rw [if_pos hstep] + exact rootEncodingPermissiveCouples_ensureCoordinate parameter target + leftRoot rightRoot (.position (.chain lay tree leafIdx chainIdx step)) + · rw [if_neg hstep] + exact rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot + ()).bind fun _ => + rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot + ()).bind fun _ => + rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem rootEncodingPermissiveCouples_maskedOtsSign_of_not_positionNames + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) + (hnotPosition : ¬EncodingPositionNamesRoot target ⟨lay, tree, leafIdx⟩) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (maskedOtsSign parameter lay tree leafIdx message) := + rootEncodingPermissiveCouples_maskedOtsSignFrom_of_not_positionNames parameter target leftRoot + rightRoot lay tree leafIdx message hnotPosition encodingAttemptLimit 0 + +theorem rootEncodingPermissiveCouples_maskedOtsLayerAfterMessage_of_not_positionNames + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (index : Index) (lay : Layer) + (message : Digest) + (hnotPosition : ¬EncodingPositionNamesRoot target + ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (maskedOtsLayerAfterMessage parameter index lay message) := by + unfold maskedOtsLayerAfterMessage + exact (rootEncodingPermissiveCouples_maskedOtsSign_of_not_positionNames parameter target + leftRoot rightRoot lay (treeIndexAt index lay) (leafIndexAt index lay) message + hnotPosition).bind fun selected => by + cases selected with + | none => exact rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot none + | some selected => + exact (rootEncodingPermissiveCouples_ensureTreePath parameter target leftRoot rightRoot + lay (treeIndexAt index lay) (leafIndexAt index lay)).bind fun _ => + rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot + (some selected) + +theorem rootEncodingPermissiveRelates_maskedOtsLayerAfterMessage + (parameter : PublicParameter) (index : Index) (lay : Layer) + (hnotBottom : lay ≠ bottomLayer) (leftRoot rightRoot : Digest) : + RootEncodingPermissiveRelates parameter (layerMessagePosition index lay) leftRoot rightRoot + (maskedOtsLayerAfterMessage parameter index lay leftRoot) + (maskedOtsLayerAfterMessage parameter index lay rightRoot) := by + have hposition : EncodingPositionNamesRoot (layerMessagePosition index lay) + ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩ := + ⟨index, rfl, rfl, hnotBottom, rfl⟩ + unfold maskedOtsLayerAfterMessage + apply (rootEncodingPermissiveRelates_maskedOtsSign parameter + (layerMessagePosition index lay) leftRoot rightRoot lay (treeIndexAt index lay) + (leafIndexAt index lay) hposition).bind + intro leftSelected rightSelected hselected + subst rightSelected + cases leftSelected with + | none => + exact rootEncodingPermissiveCouples_pure parameter (layerMessagePosition index lay) + leftRoot rightRoot none + | some selected => + exact (rootEncodingPermissiveCouples_ensureTreePath parameter + (layerMessagePosition index lay) leftRoot rightRoot lay (treeIndexAt index lay) + (leafIndexAt index lay)).bind fun _ => + rootEncodingPermissiveCouples_pure parameter (layerMessagePosition index lay) + leftRoot rightRoot (some selected) + +theorem rootEncodingPermissiveCouples_maskedTreeNode + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) : ∀ level nodeIdx, + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (maskedTreeNode lay tree level nodeIdx) + | level, nodeIdx => by + unfold maskedTreeNode + apply (rootEncodingPermissiveCouples_ensureTreeNode parameter target leftRoot rightRoot lay + tree level nodeIdx).bind + intro _ + cases level with + | zero => + exact rootEncodingPermissiveCouples_revealCoordinate parameter target leftRoot + rightRoot (.position (.leaf lay tree (leafOfNat nodeIdx))) + | succ current => + rw [Nat.add_one] + simp only + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact rootEncodingPermissiveCouples_revealCoordinate parameter target leftRoot + rightRoot (.position (.node lay tree ⟨current, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot 0 + +theorem rootEncodingPermissiveCouples_maskedTreeRoot + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (lay : Layer) (tree : TreeIndex) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (maskedTreeRoot lay tree) := + rootEncodingPermissiveCouples_maskedTreeNode parameter target leftRoot rightRoot lay tree + (layerHeight lay) 0 + +theorem rootEncodingPermissiveCouples_maskedLayerMessage + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + by_cases hbelow : lay.val + 1 < numLayers + · rw [dif_pos hbelow] + exact rootEncodingPermissiveCouples_maskedTreeRoot parameter target leftRoot rightRoot + ⟨lay.val + 1, hbelow⟩ (treeIndexAt index ⟨lay.val + 1, hbelow⟩) + · rw [dif_neg hbelow] + exact rootEncodingPermissiveCouples_ftsKey parameter target leftRoot rightRoot index + (ftsSecret index) + +set_option maxRecDepth 100000 in +theorem storedLayerRoot_of_mem_runPermissiveFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : CleanRunResult α) + (position : Position) (root : Digest) + (hroot : StoredLayerRoot state position root) + (hresult : some result ∈ support + (runPermissiveFromTable state fuel table computation)) : + StoredLayerRoot result.state position root := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + simp [runPermissiveFromTable] at hresult + subst result + exact hroot + | query_bind input next ih => + cases input with + | uniform n => + rw [runPermissiveFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output state fuel hroot hrest + | hashOutput => + rw [runPermissiveFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output state fuel hroot hrest + | ensure coordinate => + rw [runPermissiveFromTable_ensure_query_bind] at hresult + exact ih () (state.ensure coordinate) fuel (hroot.ensure coordinate) hresult + | probe coordinate candidate => + rw [runPermissiveFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · exact ih () state remaining hroot (by simpa [hrevealed] using hresult) + · exact ih () (state.addPending coordinate candidate) remaining + (hroot.addPending coordinate candidate) (by simpa [hrevealed] using hresult) + | peek coordinate => + rw [runPermissiveFromTable_peek_query_bind] at hresult + exact ih (state.values coordinate) state fuel hroot hresult + | publish coordinate => + rw [runPermissiveFromTable_publish_query_bind] at hresult + exact ih () (state.publish coordinate) fuel (hroot.publish coordinate) hresult + | reveal coordinate => + rw [runPermissiveFromTable_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + rw [hvalue] at hresult + exact ih output state fuel hroot hresult + | none => + have hne : coordinate ≠ .position position := by + intro heq + subst coordinate + obtain ⟨stored, hstored, _⟩ := hroot + rw [hvalue] at hstored + simp at hstored + rw [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact ih (table ⟨lay, tree, leafIdx, chainIdx⟩) + (state.materialize (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩)) fuel + (hroot.materialize_of_ne _ _ hne) hresult + | position revealedPosition => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output (state.materialize (.position revealedPosition) output) fuel + (hroot.materialize_of_ne _ _ hne) hrest + +def RootEncodingPermissiveStoredRel + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) : + Option (CleanRunResult (α × SplitHashCache)) → + Option (CleanRunResult (α × SplitHashCache)) → Prop + | some left, some right => + RootEncodingPermissiveCleanSameRel parameter target leftRoot rightRoot + (some left) (some right) ∧ StoredLayerRoot left.state target leftRoot + | none, none => True + | _, _ => False + +def RootEncodingPermissiveRelatesStored + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftCache rightCache, + RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache → + ∀ state fuel table, StoredLayerRoot state target leftRoot → + RelTriple + (runPermissiveFromTable state fuel table (left.run leftCache)) + (runPermissiveFromTable state fuel table (right.run rightCache)) + (RootEncodingPermissiveStoredRel parameter target leftRoot rightRoot) + +theorem RootEncodingPermissiveRelates.toStored + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} + {left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + (hrel : RootEncodingPermissiveRelates parameter target leftRoot rightRoot left right) : + RootEncodingPermissiveRelatesStored parameter target leftRoot rightRoot left right := by + intro leftCache rightCache hcache state fuel table hstored + let leftRun := runPermissiveFromTable state fuel table (left.run leftCache) + have hboth := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + (hrel leftCache rightCache hcache state fuel table) + (fun result => result ∈ support leftRun) (fun result hresult => hresult) + apply relTriple_post_mono hboth + intro leftResult rightResult hresult + rcases hresult with ⟨hrelation, hleftSupport⟩ + cases leftResult with + | none => + cases rightResult with + | none => trivial + | some rightResult => simp [RootEncodingPermissiveCleanSameRel] at hrelation + | some leftResult => + cases rightResult with + | none => simp [RootEncodingPermissiveCleanSameRel] at hrelation + | some rightResult => + exact ⟨hrelation, storedLayerRoot_of_mem_runPermissiveFromTable (left.run leftCache) + state fuel table leftResult target leftRoot hstored hleftSupport⟩ + +theorem RootEncodingPermissiveRelatesStored.bind + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {leftNext rightNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hfirst : RootEncodingPermissiveRelatesStored parameter target leftRoot rightRoot left right) + (hnext : ∀ leftValue rightValue, leftValue = rightValue → + RootEncodingPermissiveRelatesStored parameter target leftRoot rightRoot + (leftNext leftValue) (rightNext rightValue)) : + RootEncodingPermissiveRelatesStored parameter target leftRoot rightRoot + (left >>= leftNext) (right >>= rightNext) := by + intro leftCache rightCache hcache state fuel table hstored + rw [StateT.run_bind, StateT.run_bind, runPermissiveFromTable_bind, + runPermissiveFromTable_bind] + apply relTriple_bind (hfirst leftCache rightCache hcache state fuel table hstored) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [RootEncodingPermissiveStoredRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootEncodingPermissiveStoredRel] at hresult + | some rightResult => + rcases hresult with + ⟨⟨hstate, hremaining, htable, hvalue, hnextCache⟩, hnextStored⟩ + simp only + rw [← hstate, ← hremaining, ← htable, ← hvalue] + exact hnext leftResult.value.1 leftResult.value.1 rfl leftResult.value.2 + rightResult.value.2 hnextCache leftResult.state leftResult.remaining leftResult.table + hnextStored + +theorem rootEncodingPermissiveRelatesStored_sequenceFin + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) {n : Nat} + (left right : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, + RootEncodingPermissiveRelatesStored parameter target leftRoot rightRoot + (left index) (right index)) : + RootEncodingPermissiveRelatesStored parameter target leftRoot rightRoot + (sequenceFin left) (sequenceFin right) := by + induction n with + | zero => + simp only [sequenceFin] + exact (rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot + Fin.elim0).toStored + | succ n ih => + rw [sequenceFin, sequenceFin] + exact (hcomponent 0).bind fun leftHead rightHead hhead => + (ih (fun index : Fin n => left index.succ) (fun index : Fin n => right index.succ) + (fun index => hcomponent index.succ)).bind fun leftTail rightTail htail => by + subst rightHead + subst rightTail + exact (rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot + (Fin.cases leftHead leftTail : Fin (n + 1) → α)).toStored + +set_option maxRecDepth 100000 in +theorem maskedTreeRoot_eq_of_stored_permissive + (lay : Layer) (tree : TreeIndex) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : CleanRunResult (Digest × SplitHashCache)) (root : Digest) + (hroot : StoredLayerRoot state (layerRootPosition lay tree) root) + (hresult : some result ∈ support + (runPermissiveFromTable state fuel table ((maskedTreeRoot lay tree).run cache))) : + result.value.1 = root ∧ StoredLayerRoot result.state (layerRootPosition lay tree) root := by + have hpos : 0 < layerHeight lay := by + unfold layerHeight + split <;> norm_num [maxLayerHeight] + have hlevel : layerHeight lay - 1 < maxLayerHeight := by + have hle := layerHeight_le lay + omega + unfold maskedTreeRoot at hresult + rw [show layerHeight lay = (layerHeight lay - 1) + 1 by omega, + maskedTreeNode, StateT.run_bind, runPermissiveFromTable_bind, + mem_support_bind_iff] at hresult + obtain ⟨administrative, hadministrative, hreveal⟩ := hresult + cases administrative with + | none => simp at hreveal + | some administrative => + have hmiddleRoot := storedLayerRoot_of_mem_runPermissiveFromTable + ((ensureTreeNode lay tree (layerHeight lay - 1 + 1) 0).run cache) + state fuel table administrative (layerRootPosition lay tree) root hroot + hadministrative + simp only at hreveal + rw [dif_pos hlevel] at hreveal + obtain ⟨output, hstored, htruncate⟩ := hmiddleRoot + change some result ∈ support + (runPermissiveFromTable administrative.state administrative.remaining + administrative.table + ((revealCoordinate (.position (layerRootPosition lay tree))).run + administrative.value.2)) at hreveal + rw [revealCoordinate_run, LazyRevealProbe.revealQuery, + runPermissiveFromTable_reveal_query_bind, hstored] at hreveal + simp [runPermissiveFromTable] at hreveal + subst result + exact ⟨htruncate, ⟨output, hstored, htruncate⟩⟩ + +theorem maskedLayerMessage_value_eq_of_stored_permissive + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) (root : Digest) + (index : Index) (lay : Layer) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : CleanRunResult (Digest × SplitHashCache)) + (hstored : StoredLayerRoot state target root) + (htarget : layerMessagePosition index lay = target) + (hresult : some result ∈ support + (runPermissiveFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run cache))) : + result.value.1 = root := by + obtain ⟨below, hcomputation, hposition⟩ := + layerMessage_root_witness_of_isLayerRoot parameter ftsSecret target hroot index lay htarget + rw [hcomputation] at hresult + have hstoredRoot : StoredLayerRoot state + (layerRootPosition below (treeIndexAt index below)) root := by + rw [← hposition, htarget] + exact hstored + exact (maskedTreeRoot_eq_of_stored_permissive below (treeIndexAt index below) state cache fuel + table result root hstoredRoot hresult).1 + +theorem rootEncodingPermissiveCouples_maskedSignLayer_of_layerMessagePosition_ne + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) + (hne : layerMessagePosition index lay ≠ target) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + exact (rootEncodingPermissiveCouples_maskedLayerMessage parameter target leftRoot rightRoot + ftsSecret index lay).bind fun message => + rootEncodingPermissiveCouples_maskedOtsLayerAfterMessage_of_not_positionNames parameter + target leftRoot rightRoot index lay message + (not_encodingPositionNamesRoot_of_layerMessagePosition_ne target index lay hne) + +theorem rootEncodingPermissiveRelatesStored_maskedSignLayer_targetComparison + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + RootEncodingPermissiveRelatesStored parameter target leftRoot rightRoot + (maskedSignLayer parameter ftsSecret index lay) + (maskedSignLayerWithTargetComparison parameter target rightRoot ftsSecret index lay) := by + by_cases htarget : layerMessagePosition index lay = target + · rw [maskedSignLayerWithTargetComparison, if_pos htarget] + intro leftCache rightCache hcache state fuel table hstored + unfold maskedSignLayer maskedSignLayerWithComparisonRoot + change RelTriple + (runPermissiveFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay >>= fun message => + maskedOtsLayerAfterMessage parameter index lay message).run leftCache)) + (runPermissiveFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay >>= fun _ => + maskedOtsLayerAfterMessage parameter index lay rightRoot).run rightCache)) _ + rw [StateT.run_bind, StateT.run_bind, runPermissiveFromTable_bind, + runPermissiveFromTable_bind] + let leftMessageRun := runPermissiveFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run leftCache) + have hmessages := + (rootEncodingPermissiveCouples_maskedLayerMessage parameter target leftRoot rightRoot + ftsSecret index lay).toStored leftCache rightCache hcache state fuel table hstored + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hmessages + (fun result => result ∈ support leftMessageRun) (fun result hresult => hresult) + apply relTriple_bind hsupported + intro leftResult rightResult hresult + rcases hresult with ⟨hrelation, hleftSupport⟩ + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [RootEncodingPermissiveStoredRel] at hrelation + | some leftResult => + cases rightResult with + | none => simp [RootEncodingPermissiveStoredRel] at hrelation + | some rightResult => + rcases hrelation with + ⟨⟨hstate, hremaining, htable, _hmessage, hnextCache⟩, hnextStored⟩ + have hactual := maskedLayerMessage_value_eq_of_stored_permissive parameter ftsSecret + target hroot leftRoot index lay state leftCache fuel table leftResult hstored htarget + hleftSupport + simp only + rw [← hstate, ← hremaining, ← htable, hactual] + rw [← htarget] at hnextCache hnextStored ⊢ + exact (rootEncodingPermissiveRelates_maskedOtsLayerAfterMessage parameter index lay + (layer_ne_bottom_of_layerMessagePosition_isLayerRoot htarget hroot) leftRoot + rightRoot).toStored leftResult.value.2 rightResult.value.2 hnextCache leftResult.state + leftResult.remaining leftResult.table hnextStored + · rw [maskedSignLayerWithTargetComparison, if_neg htarget] + exact (rootEncodingPermissiveCouples_maskedSignLayer_of_layerMessagePosition_ne parameter + target leftRoot rightRoot ftsSecret index lay htarget).toStored + +theorem rootEncodingPermissiveRelatesStored_maskedSignLayers_targetComparison + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) : + RootEncodingPermissiveRelatesStored parameter target leftRoot rightRoot + (sequenceFin fun lay => maskedSignLayer parameter ftsSecret index lay) + (maskedSignLayersWithTargetComparison parameter target rightRoot ftsSecret index) := by + unfold maskedSignLayersWithTargetComparison + apply rootEncodingPermissiveRelatesStored_sequenceFin + intro lay + exact rootEncodingPermissiveRelatesStored_maskedSignLayer_targetComparison parameter target + hroot leftRoot rightRoot ftsSecret index lay + +theorem rootEncodingPermissiveRelatesStored_maskedSignAfterDigest_targetComparison + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + RootEncodingPermissiveRelatesStored parameter target leftRoot rightRoot + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) + (maskedSignAfterDigestWithTargetComparison parameter target rightRoot ftsSecret + randomness index leaves) := by + unfold maskedSignAfterDigest maskedSignAfterDigestWithTargetComparison + apply (rootEncodingPermissiveCouples_ftsOpen parameter target leftRoot rightRoot index leaves + (ftsSecret index)).toStored.bind + intro leftPath rightPath hpath + subst rightPath + apply (rootEncodingPermissiveRelatesStored_maskedSignLayers_targetComparison parameter target + hroot leftRoot rightRoot ftsSecret index).bind + intro leftLayers rightLayers hlayers + subst rightLayers + cases hparts : traverseOption leftLayers with + | none => + exact (rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot none).toStored + | some parts => + apply (rootEncodingPermissiveCouples_sequenceFin parameter target leftRoot rightRoot + (fun lay => revealLayerValues index lay (parts lay).2) + (fun lay => rootEncodingPermissiveCouples_revealLayerValues parameter target leftRoot + rightRoot index lay (parts lay).2)).toStored.bind + intro leftRevealed rightRevealed hrevealed + subst rightRevealed + let signature : Signature := + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := leftPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (leftRevealed lay).1 + authPath := flattenPaths fun lay => (leftRevealed lay).2 } + exact (rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot + (some signature)).toStored + +theorem rootEncodingPermissiveRelatesStored_maskedSign_targetComparison + (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + RootEncodingPermissiveRelatesStored parameter target leftRoot rightRoot + (maskedSign parameter publicRoot ftsSecret message) + (maskedSignWithTargetComparison parameter publicRoot target rightRoot ftsSecret message) := by + unfold maskedSign maskedSignWithTargetComparison + let secretKey : SecretKey := + ⟨parameter, publicRoot, fun _ _ _ _ => 0, ftsSecret⟩ + apply (rootEncodingPermissiveCouples_signDigestLoop target leftRoot rightRoot secretKey message + digestAttemptLimit).toStored.bind + intro leftSelected rightSelected hselected + subst rightSelected + cases leftSelected with + | none => + exact (rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot none).toStored + | some selected => + exact rootEncodingPermissiveRelatesStored_maskedSignAfterDigest_targetComparison parameter + target hroot leftRoot rightRoot ftsSecret selected.1 selected.2.1 selected.2.2 + +theorem rootEncodingPermissiveCouples_probe + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (candidate : Probe) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (probe candidate) := by + intro leftCache rightCache hcache state fuel table + unfold probe LazyRevealProbe.probeQuery + rw [StateT.run_liftM, StateT.run_liftM, + runPermissiveFromTable_probe_query_bind, runPermissiveFromTable_probe_query_bind] + cases fuel with + | zero => exact relTriple_pure_pure trivial + | succ remaining => + by_cases hrevealed : candidate.coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte, runPermissiveFromTable, + OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + · simp only [hrevealed, ↓reduceIte, runPermissiveFromTable, + OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + +theorem rootEncodingPermissiveCouples_executeCandidate + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (candidate : Option Probe) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (executeCandidate? candidate) := by + cases candidate with + | none => + simp only [executeCandidate?] + exact rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot () + | some candidate => + simp only [executeCandidate?] + exact rootEncodingPermissiveCouples_probe parameter target leftRoot rightRoot candidate + +theorem rootEncodingPermissiveCouples_splitHashQuery_avoids + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) + (havoid : RootInputAvoids parameter target leftRoot rightRoot input) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (splitHashQuery (.ordinary input)) := by + intro leftCache rightCache hcache state fuel table + have hlookup := hcache.lookup_avoids input havoid + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + cases hleftLookup : leftCache (.ordinary input) with + | some output => + have hrightLookup : rightCache (.ordinary input) = some output := by + rw [← hlookup] + exact hleftLookup + simp only [hrightLookup, runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, hcache⟩ + | none => + have hrightLookup : rightCache (.ordinary input) = none := by + rw [← hlookup] + exact hleftLookup + simp only [hrightLookup] + unfold LazyRevealProbe.hashOutputQuery + rw [runPermissiveFromTable_hashOutput_query_bind, + runPermissiveFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_avoids input havoid leftOutput⟩ + +theorem rootEncodingPermissiveCouples_revealCoordinateOutput + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (coordinate : Coordinate) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (revealCoordinateOutput coordinate) := by + intro leftCache rightCache hcache state fuel table + rw [revealCoordinateOutput_run_eq, revealCoordinateOutput_run_eq, + LazyRevealProbe.revealQuery, runPermissiveFromTable_reveal_query_bind, + runPermissiveFromTable_reveal_query_bind] + have hhidden : ¬RootEncodingKey parameter target (.hidden coordinate) := + not_rootEncodingKey_hidden parameter target coordinate + cases hvalue : state.values coordinate with + | some output => + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_nonroot (.hidden coordinate) output hhidden⟩ + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_nonroot + (.hidden (.chainStart lay tree leafIdx chainIdx)) + (table ⟨lay, tree, leafIdx, chainIdx⟩) hhidden⟩ + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_nonroot (.hidden (.position position)) leftOutput hhidden⟩ + +theorem rootEncodingPermissiveCouples_modifyOrdinary_avoids + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) + (havoid : RootInputAvoids parameter target leftRoot rightRoot input) + (output : HashOutput) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output)) := by + intro leftCache rightCache hcache state fuel table + simp only [StateT.run_modify, runPermissiveFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨rfl, rfl, rfl, rfl, + hcache.update_same_avoids input havoid output⟩ + +theorem rootEncodingPermissiveCouples_resolvePublicKnownInput_avoids + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (publicState : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) (input : HashInput) + (havoid : RootInputAvoids parameter target leftRoot rightRoot input) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (resolvePublicKnownInput parameter publicState coordinate input) := by + unfold resolvePublicKnownInput + cases hknown : purePeekTableInput parameter publicState coordinate with + | none => + exact rootEncodingPermissiveCouples_splitHashQuery_avoids parameter target leftRoot + rightRoot input havoid + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + exact (rootEncodingPermissiveCouples_revealCoordinateOutput parameter target leftRoot + rightRoot coordinate).bind fun output => + (rootEncodingPermissiveCouples_publishCoordinate parameter target leftRoot rightRoot + coordinate).bind fun _ => + (rootEncodingPermissiveCouples_modifyOrdinary_avoids parameter target leftRoot + rightRoot input havoid output).bind fun _ => + rootEncodingPermissiveCouples_pure parameter target leftRoot rightRoot output + · simp only [heq, ↓reduceIte] + exact rootEncodingPermissiveCouples_splitHashQuery_avoids parameter target leftRoot + rightRoot input havoid + +theorem rootEncodingPermissiveCouples_probingHashQueryAfterPublicPlan_avoids + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (havoid : RootInputAvoids parameter target leftRoot rightRoot input) : + RootEncodingPermissiveCouples parameter target leftRoot rightRoot + (probingHashQueryAfterPublicPlan parameter input publicState plan) := by + unfold probingHashQueryAfterPublicPlan + exact (rootEncodingPermissiveCouples_executeCandidate parameter target leftRoot rightRoot + plan.candidate?).bind fun _ => by + cases plan.action with + | ordinary => + exact rootEncodingPermissiveCouples_splitHashQuery_avoids parameter target leftRoot + rightRoot input havoid + | resolve coordinate => + exact rootEncodingPermissiveCouples_resolvePublicKnownInput_avoids parameter target + leftRoot rightRoot publicState coordinate input havoid + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwapProbability.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwapProbability.lean new file mode 100644 index 00000000..a2eb5a45 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwapProbability.lean @@ -0,0 +1,1875 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwapSelector + +/-! +# Permissive root-swap probability + +The symmetric two-root selector is dominated, for a fixed match event, by the selector whose +comparison guard repeats the actual root. This makes the comparison root independent of the +selected probe. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +def PermissiveOptionMatchRel + (target : Position) (matchRoot : Digest) : + Option PermissivePrivateOrdinalSelection → + Option PermissivePrivateOrdinalSelection → Prop := + fun left right => + materializedOrdinalSelectionMatches target matchRoot + (erasePermissivePrivateOrdinalSelection left) → + materializedOrdinalSelectionMatches target matchRoot + (erasePermissivePrivateOrdinalSelection right) + +theorem relTriple_none_any_permissiveOptionMatch + (target : Position) (matchRoot : Digest) + (right : ProbComp (Option PermissivePrivateOrdinalSelection)) : + RelTriple (pure none : ProbComp (Option PermissivePrivateOrdinalSelection)) right + (PermissiveOptionMatchRel target matchRoot) := by + have hbase := relTriple_true + (pure none : ProbComp (Option PermissivePrivateOrdinalSelection)) right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun value => value = none) (by intro value hvalue; simpa using hvalue) + apply relTriple_post_mono hsupported + intro left right hrelation + rw [hrelation.2] + simp [PermissiveOptionMatchRel, materializedOrdinalSelectionMatches, + erasePermissivePrivateOrdinalSelection] + +theorem relTriple_finishPermissiveSelection_weaken + (target : Position) (matchRoot : Digest) + (leftObserve rightObserve : LazyRevealProbe.State Coordinate → Nat → α → + SplitHashCache → List Probe → ProbComp (Option PermissivePrivateOrdinalSelection)) + (candidates : List Probe) + (result : Option (CleanRunResult (α × SplitHashCache))) + (hrecursive : ∀ (resolved : CleanRunResult (α × SplitHashCache)), + RelTriple + (continuePermissiveRootAvoidingDetailedOrdinalSelection target leftObserve + resolved.state resolved.remaining resolved.value.1 resolved.value.2 candidates) + (continuePermissiveRootAvoidingDetailedOrdinalSelection target rightObserve + resolved.state resolved.remaining resolved.value.1 resolved.value.2 candidates) + (PermissiveOptionMatchRel target matchRoot)) : + RelTriple + (finishPermissiveDetailedPrivateOrdinalSelection + (continuePermissiveRootAvoidingDetailedOrdinalSelection target leftObserve) + candidates result) + (finishPermissiveDetailedPrivateOrdinalSelection + (continuePermissiveRootAvoidingDetailedOrdinalSelection target rightObserve) + candidates result) + (PermissiveOptionMatchRel target matchRoot) := by + cases result with + | none => exact relTriple_pure_pure (fun h => h) + | some resolved => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] + exact hrecursive resolved + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_permissiveRootAvoidingDetailedOrdinalSelection_weakenComparison + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot matchRoot : Digest) + (signer : Message → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + RelTriple + (permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter target leftRoot rightRoot + signer computation candidates state fuel table cache) + (permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter target leftRoot leftRoot + signer computation candidates state fuel table cache) + (PermissiveOptionMatchRel target matchRoot) := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + simp only [permissiveRootAvoidingDetailedOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length <;> + simp only [hselected, ↓reduceDIte] <;> + exact relTriple_pure_pure (fun h => h) + | query_bind query next ih => + rw [permissiveRootAvoidingDetailedOrdinalSelection, OracleComp.construct_query_bind, + permissiveRootAvoidingDetailedOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure (fun h => h) + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let leftObserve := + fun nextState remaining value nextCache laterCandidates => + permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter target + leftRoot rightRoot signer (next value) laterCandidates nextState remaining + table nextCache + let rightObserve := + fun nextState remaining value nextCache laterCandidates => + permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter target + leftRoot leftRoot signer (next value) laterCandidates nextState remaining + table nextCache + apply relTriple_bind + (relTriple_refl + (runPermissiveFromTable state fuel table ((splitUniformImpl n).run cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishPermissiveSelection_weaken target matchRoot leftObserve + rightObserve candidates leftResult + intro resolved + unfold continuePermissiveRootAvoidingDetailedOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ resolved.state.revealed + · simp [hrevealed, PermissiveOptionMatchRel, + materializedOrdinalSelectionMatches, + erasePermissivePrivateOrdinalSelection] + · simpa [hrevealed, leftObserve, rightObserve] using + ih resolved.value.1 candidates resolved.state resolved.remaining + resolved.value.2 + | inr input => + let nextCandidates := permissiveRootAwareCandidates parameter input table state + candidates + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (permissiveRootAwareCandidates parameter input table state candidates).length := by + simpa [nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + exact relTriple_pure_pure (fun h => h) + · have hactual : ¬ordinal < + (permissiveRootAwareCandidates parameter input table state candidates).length := by + simpa [nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + by_cases hsafe : RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? + · have hsafeActual : RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + have hleftSafe := rootAwareCandidateAvoidsRoots_actual target leftRoot rightRoot + candidate? hsafe + have hleftSafeActual : RootAwareCandidateAvoidsRoots target leftRoot leftRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hleftSafe + simp only [hsafeActual, hleftSafeActual, ↓reduceIte] + let leftObserve := + fun nextState remaining value nextCache laterCandidates => + permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter target + leftRoot rightRoot signer (next value) laterCandidates nextState remaining + table nextCache + let rightObserve := + fun nextState remaining value nextCache laterCandidates => + permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter target + leftRoot leftRoot signer (next value) laterCandidates nextState remaining + table nextCache + apply relTriple_bind + (relTriple_refl + (runPermissiveFromTable state fuel table + (delayedPermissivePublicAction parameter input table state cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishPermissiveSelection_weaken target matchRoot leftObserve + rightObserve nextCandidates leftResult + intro resolved + unfold continuePermissiveRootAvoidingDetailedOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ resolved.state.revealed + · simp [hrevealed, PermissiveOptionMatchRel, + materializedOrdinalSelectionMatches, + erasePermissivePrivateOrdinalSelection] + · simpa [hrevealed, leftObserve, rightObserve] using + ih resolved.value.1 nextCandidates resolved.state resolved.remaining + resolved.value.2 + · have hsafeActual : ¬RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + exact relTriple_none_any_permissiveOptionMatch target matchRoot _ + | inr message => + let leftObserve := + fun nextState remaining value nextCache laterCandidates => + permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter target leftRoot + rightRoot signer (next value) laterCandidates nextState remaining table nextCache + let rightObserve := + fun nextState remaining value nextCache laterCandidates => + permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter target leftRoot + leftRoot signer (next value) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_refl + (runPermissiveFromTable state fuel table ((signer message).run cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishPermissiveSelection_weaken target matchRoot leftObserve + rightObserve candidates leftResult + intro resolved + unfold continuePermissiveRootAvoidingDetailedOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ resolved.state.revealed + · simp [hrevealed, PermissiveOptionMatchRel, materializedOrdinalSelectionMatches, + erasePermissivePrivateOrdinalSelection] + · simpa [hrevealed, leftObserve, rightObserve] using + ih resolved.value.1 candidates resolved.state resolved.remaining resolved.value.2 + +theorem probEvent_permissiveRootAvoidingSelection_match_le_reference + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot matchRoot : Digest) + (signer : Message → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + Pr[fun selection => materializedOrdinalSelectionMatches target matchRoot + (erasePermissivePrivateOrdinalSelection selection) | + permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter target leftRoot rightRoot + signer computation candidates state fuel table cache] ≤ + Pr[fun selection => materializedOrdinalSelectionMatches target matchRoot + (erasePermissivePrivateOrdinalSelection selection) | + permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter target leftRoot leftRoot + signer computation candidates state fuel table cache] := + probEvent_le_of_relTriple + (relTriple_permissiveRootAvoidingDetailedOrdinalSelection_weakenComparison ordinal parameter + target leftRoot rightRoot matchRoot signer computation candidates state fuel table cache) + (fun _ _ hrelation => hrelation) + +set_option maxRecDepth 100000 in +theorem probEvent_sampledComparisonRoot_permissiveRootAvoidingSelection_le_mul + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot : Digest) + (signer : Message → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + Pr[fun result : Digest × Option PermissivePrivateOrdinalSelection => + materializedOrdinalSelectionMatches target result.1 + (erasePermissivePrivateOrdinalSelection result.2) | do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter target + leftRoot rightRoot signer computation candidates state fuel table cache + pure (rightRoot, selection)] ≤ + Pr[fun selection => materializedOrdinalSelectionAt target + (erasePermissivePrivateOrdinalSelection selection) | + permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter target leftRoot leftRoot + signer computation candidates state fuel table cache] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let reference := permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter target + leftRoot leftRoot signer computation candidates state fuel table cache + calc + _ ≤ Pr[fun result : Digest × Option PermissivePrivateOrdinalSelection => + materializedOrdinalSelectionMatches target result.1 + (erasePermissivePrivateOrdinalSelection result.2) | do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← reference + pure (rightRoot, selection)] := by + apply probEvent_bind_le_bind_of_forall_le + intro rightRoot _hrightRoot + rw [show (do + let selection ← permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter + target leftRoot rightRoot signer computation candidates state fuel table cache + pure (rightRoot, selection)) = + (fun selection => (rightRoot, selection)) <$> + permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter target leftRoot + rightRoot signer computation candidates state fuel table cache by + simp [map_eq_bind_pure_comp], + show (do + let selection ← reference + pure (rightRoot, selection)) = + (fun selection => (rightRoot, selection)) <$> reference by + simp [map_eq_bind_pure_comp], probEvent_map, probEvent_map] + exact probEvent_permissiveRootAvoidingSelection_match_le_reference ordinal parameter target + leftRoot rightRoot rightRoot signer computation candidates state fuel table cache + _ ≤ Pr[fun result : Digest × Option PermissivePrivateOrdinalSelection => + materializedOrdinalSelectionAt target + (erasePermissivePrivateOrdinalSelection result.2) ∧ + result.1 = selectedProbeDigest + (erasePermissivePrivateOrdinalSelection result.2) | do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← reference + pure (rightRoot, selection)] := by + apply probEvent_mono + intro result _hresult hmatch + exact ⟨materializedOrdinalSelectionAt_of_matches hmatch, + materializedOrdinalSelectionMatches_root_eq_selectedProbeDigest hmatch⟩ + _ ≤ _ := by + exact probEvent_uniform_root_matches_distribution_independent_guess_le_mul + (fun _rightRoot => reference) reference (fun _rightRoot => rfl) + (fun selection => selectedProbeDigest (erasePermissivePrivateOrdinalSelection selection)) + (fun selection => materializedOrdinalSelectionAt target + (erasePermissivePrivateOrdinalSelection selection)) + +theorem evalDist_map_erase_permissiveRootAvoidingSelection_family_swap + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (output : Digest → HashOutput) (htruncate : ∀ root, truncateHash (output root) = root) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) + (hprivate : Coordinate.position target ∉ state.revealed) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : Digest → SplitHashCache) + (htargetCache : ∀ root, + cache root (.hidden (.position target)) = some (output root)) + (hcacheSwap : ∀ leftRoot rightRoot, + fullSwapRootCache parameter target leftRoot rightRoot (output rightRoot) + (cache leftRoot) = cache rightRoot) + (leftRoot rightRoot : Digest) : + evalDist + (erasePermissivePrivateOrdinalSelection <$> + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot target + leftRoot rightRoot ftsSecret computation candidates + (preloadPositionValue target (output leftRoot) state) fuel table (cache leftRoot)) = + evalDist + (erasePermissivePrivateOrdinalSelection <$> + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot target + rightRoot leftRoot ftsSecret computation candidates + (preloadPositionValue target (output rightRoot) state) fuel table + (cache rightRoot)) := by + have hswap := + evalDist_map_erase_permissiveRootAvoidingDetailedOrdinalSelection_fullSwap ordinal parameter + publicRoot target hroot (output leftRoot) (output rightRoot) ftsSecret computation candidates + state hprivate fuel table (cache leftRoot) (htargetCache leftRoot) + rw [htruncate leftRoot, htruncate rightRoot] at hswap + simpa only [hcacheSwap leftRoot rightRoot] using hswap + +set_option maxRecDepth 100000 in +theorem probEvent_uniformActualRoot_permissiveRootAvoidingSelection_le_mul + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (output : Digest → HashOutput) (htruncate : ∀ root, truncateHash (output root) = root) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) + (hprivate : Coordinate.position target ∉ state.revealed) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : Digest → SplitHashCache) + (htargetCache : ∀ root, + cache root (.hidden (.position target)) = some (output root)) + (hcacheSwap : ∀ leftRoot rightRoot, + fullSwapRootCache parameter target leftRoot rightRoot (output rightRoot) + (cache leftRoot) = cache rightRoot) : + Pr[fun result : Digest × Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← erasePermissivePrivateOrdinalSelection <$> + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot target + leftRoot rightRoot ftsSecret computation candidates + (preloadPositionValue target (output leftRoot) state) fuel table (cache leftRoot) + pure (leftRoot, rightRoot, selection)] ≤ + Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionAt target result.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← erasePermissivePrivateOrdinalSelection <$> + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot target + leftRoot leftRoot ftsSecret computation candidates + (preloadPositionValue target (output leftRoot) state) fuel table (cache leftRoot) + pure (leftRoot, selection)] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let run : Digest → Digest → ProbComp (Option Probe) := + fun leftRoot rightRoot => erasePermissivePrivateOrdinalSelection <$> + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot target + leftRoot rightRoot ftsSecret computation candidates + (preloadPositionValue target (output leftRoot) state) fuel table (cache leftRoot) + let reference : Digest → ProbComp (Option Probe) := + fun leftRoot => erasePermissivePrivateOrdinalSelection <$> + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot target + leftRoot leftRoot ftsSecret computation candidates + (preloadPositionValue target (output leftRoot) state) fuel table (cache leftRoot) + apply probEvent_uniformActualRoot_match_le_of_swap_of_comparison_mul target run reference + · intro leftRoot rightRoot + exact evalDist_map_erase_permissiveRootAvoidingSelection_family_swap ordinal parameter + publicRoot target hroot output htruncate ftsSecret computation candidates state hprivate fuel + table cache htargetCache hcacheSwap leftRoot rightRoot + · intro leftRoot + simp only [run, reference] + rw [probEvent_map] + let raw := fun rightRoot => + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot target + leftRoot rightRoot ftsSecret computation candidates + (preloadPositionValue target (output leftRoot) state) fuel table (cache leftRoot) + change Pr[fun result => materializedOrdinalSelectionMatches target result.1 result.2 | do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← erasePermissivePrivateOrdinalSelection <$> raw rightRoot + pure (rightRoot, selection)] ≤ + Pr[materializedOrdinalSelectionAt target ∘ erasePermissivePrivateOrdinalSelection | + raw leftRoot] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + have hmap : + (do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← erasePermissivePrivateOrdinalSelection <$> raw rightRoot + pure (rightRoot, selection)) = + (fun result : Digest × Option PermissivePrivateOrdinalSelection => + (result.1, erasePermissivePrivateOrdinalSelection result.2)) <$> (do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← raw rightRoot + pure (rightRoot, selection)) := by + simp [map_eq_bind_pure_comp] + rw [hmap, probEvent_map] + simpa [raw, permissiveActualRootAvoidingDetailedOrdinalSelection, Function.comp_def] using + (probEvent_sampledComparisonRoot_permissiveRootAvoidingSelection_le_mul ordinal parameter + target leftRoot (maskedSign parameter publicRoot ftsSecret) computation candidates + (preloadPositionValue target (output leftRoot) state) fuel table (cache leftRoot)) + +def PermissiveFilteredSelectionRel + (target : Position) : Option PermissivePrivateOrdinalSelection → + Option PermissivePrivateOrdinalSelection → Prop + | none, _ => True + | some left, some right => + left = right ∧ Coordinate.position target ∉ left.state.revealed + | some _, none => False + +def PermissiveRootFilterCompleteRel + (target : Position) (output : HashOutput) (rightRoot : Digest) (ordinal : Nat) : + Option PermissivePrivateOrdinalSelection → + Option PermissivePrivateOrdinalSelection → Prop := + fun left right => + PermissiveDelayedRootGuessAt target output rightRoot ordinal right → left = right + +theorem relTriple_none_delayed_of_target_revealed + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (output : HashOutput) (rightRoot : Digest) + (hrevealed : Coordinate.position target ∈ state.revealed) : + RelTriple (pure none : ProbComp (Option PermissivePrivateOrdinalSelection)) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache) + (PermissiveRootFilterCompleteRel target output rightRoot ordinal) := by + have hbase := relTriple_true + (pure none : ProbComp (Option PermissivePrivateOrdinalSelection)) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache) + have hleft := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun value => value = none) (by intro value hvalue; simpa using hvalue) + have hboth := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro left right hrelation hgood + rcases hrelation with ⟨⟨_htrue, hleftNone⟩, hrightSupport⟩ + subst left + cases right with + | none => rfl + | some selection => + exfalso + exact hgood.2.2.1 + (revealed_subset_of_mem_delayedPermissiveDetailedOrdinalSelection ordinal parameter root + ftsSecret computation candidates state fuel table cache selection hrightSupport hrevealed) + +theorem relTriple_none_delayed_of_unsafe_prefix + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (output : HashOutput) (rightRoot : Digest) + (candidate : Probe) (hmem : candidate ∈ candidates) + (hlength : candidates.length ≤ ordinal) + (hunsafe : ¬candidate.AvoidsRoots target (truncateHash output) rightRoot) : + RelTriple (pure none : ProbComp (Option PermissivePrivateOrdinalSelection)) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache) + (PermissiveRootFilterCompleteRel target output rightRoot ordinal) := by + have hbase := relTriple_true + (pure none : ProbComp (Option PermissivePrivateOrdinalSelection)) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache) + have hleft := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun value => value = none) (by intro value hvalue; simpa using hvalue) + have hboth := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro left right hrelation hgood + rcases hrelation with ⟨⟨_htrue, hleftNone⟩, hrightSupport⟩ + subst left + cases right with + | none => rfl + | some selection => + exfalso + have hprefix := candidates_isPrefix_of_mem_delayedPermissiveDetailedOrdinalSelection + ordinal parameter root ftsSecret computation candidates state fuel table cache selection + hrightSupport + have htake := hprefix.take ordinal + have htakePrefix : candidates.IsPrefix (selection.candidates.take ordinal) := by + rw [(List.take_eq_self_iff candidates).2 hlength] at htake + exact htake + have hcandidate : candidate ∈ selection.candidates.take ordinal := + htakePrefix.sublist.subset hmem + exact hunsafe (hgood.2.2.2 candidate hcandidate) + +theorem relTriple_finishPermissiveRootFilterComplete + (target : Position) (output : HashOutput) (rightRoot : Digest) (ordinal : Nat) + (leftObserve rightObserve : LazyRevealProbe.State Coordinate → Nat → α → + SplitHashCache → List Probe → ProbComp (Option PermissivePrivateOrdinalSelection)) + (candidates : List Probe) + (result : Option (CleanRunResult (α × SplitHashCache))) + (hrecursive : ∀ (resolved : CleanRunResult (α × SplitHashCache)), + Coordinate.position target ∉ resolved.state.revealed → + RelTriple + (leftObserve resolved.state resolved.remaining resolved.value.1 resolved.value.2 candidates) + (rightObserve resolved.state resolved.remaining resolved.value.1 resolved.value.2 candidates) + (PermissiveRootFilterCompleteRel target output rightRoot ordinal)) + (hrevealed : ∀ (resolved : CleanRunResult (α × SplitHashCache)), + Coordinate.position target ∈ resolved.state.revealed → + RelTriple (pure none : ProbComp (Option PermissivePrivateOrdinalSelection)) + (rightObserve resolved.state resolved.remaining resolved.value.1 resolved.value.2 candidates) + (PermissiveRootFilterCompleteRel target output rightRoot ordinal)) : + RelTriple + (finishPermissiveDetailedPrivateOrdinalSelection + (continuePermissiveRootAvoidingDetailedOrdinalSelection target leftObserve) + candidates result) + (finishPermissiveDetailedPrivateOrdinalSelection rightObserve candidates result) + (PermissiveRootFilterCompleteRel target output rightRoot ordinal) := by + cases result with + | none => exact relTriple_pure_pure (fun hgood => False.elim hgood) + | some resolved => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] + unfold continuePermissiveRootAvoidingDetailedOrdinalSelection + by_cases htarget : Coordinate.position target ∈ resolved.state.revealed + · simp only [htarget, ↓reduceIte] + exact hrevealed resolved htarget + · simp only [htarget, ↓reduceIte] + exact hrecursive resolved htarget + +theorem relTriple_none_finishDelayed_of_unsafe_prefix + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (next : α → OracleComp (OracleWorld + SigningSpec) β) + (step : ProbComp (Option (CleanRunResult (α × SplitHashCache)))) + (candidates : List Probe) (table : OtsSecretIndex → HashOutput) + (target : Position) (output : HashOutput) (rightRoot : Digest) + (candidate : Probe) (hmem : candidate ∈ candidates) + (hlength : candidates.length ≤ ordinal) + (hunsafe : ¬candidate.AvoidsRoots target (truncateHash output) rightRoot) : + RelTriple (pure none : ProbComp (Option PermissivePrivateOrdinalSelection)) + (step >>= finishPermissiveDetailedPrivateOrdinalSelection + (fun state fuel value cache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next value) laterCandidates state fuel table cache) + candidates) + (PermissiveRootFilterCompleteRel target output rightRoot ordinal) := by + let right := step >>= finishPermissiveDetailedPrivateOrdinalSelection + (fun state fuel value cache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next value) laterCandidates state fuel table cache) + candidates + have hbase := relTriple_true + (pure none : ProbComp (Option PermissivePrivateOrdinalSelection)) right + have hleft := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun value => value = none) (by intro value hvalue; simpa using hvalue) + have hboth := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro left rightSelection hrelation hgood + rcases hrelation with ⟨⟨_htrue, hleftNone⟩, hrightSupport⟩ + subst left + cases rightSelection with + | none => rfl + | some selection => + exfalso + change some selection ∈ support right at hrightSupport + unfold right at hrightSupport + rw [mem_support_bind_iff] at hrightSupport + obtain ⟨result, _hresult, hfinish⟩ := hrightSupport + cases result with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] at hfinish + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] at hfinish + have hprefix := candidates_isPrefix_of_mem_delayedPermissiveDetailedOrdinalSelection + ordinal parameter root ftsSecret (next result.value.1) candidates result.state + result.remaining table result.value.2 selection hfinish + have htake := hprefix.take ordinal + have htakePrefix : candidates.IsPrefix (selection.candidates.take ordinal) := by + rw [(List.take_eq_self_iff candidates).2 hlength] at htake + exact htake + have hcandidate : candidate ∈ selection.candidates.take ordinal := + htakePrefix.sublist.subset hmem + exact hunsafe (hgood.2.2.2 candidate hcandidate) + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_delayed_permissiveRootAvoidingDetailedOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (target : Position) (output : HashOutput) (rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + RelTriple + (permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter root target + (truncateHash output) rightRoot ftsSecret computation candidates state fuel table cache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache) + (PermissiveRootFilterCompleteRel target output rightRoot ordinal) := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + simp only [permissiveActualRootAvoidingDetailedOrdinalSelection, + permissiveRootAvoidingDetailedOrdinalSelection, + delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length <;> + simp only [hselected, ↓reduceDIte] <;> + exact relTriple_pure_pure (fun _ => rfl) + | query_bind query next ih => + unfold permissiveActualRootAvoidingDetailedOrdinalSelection + rw [permissiveRootAvoidingDetailedOrdinalSelection, OracleComp.construct_query_bind, + delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure (fun _ => rfl) + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let leftObserve := + fun nextState remaining value nextCache laterCandidates => + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter root + target (truncateHash output) rightRoot ftsSecret (next value) + laterCandidates nextState remaining table nextCache + let rightObserve := + fun nextState remaining value nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next value) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_refl + (runPermissiveFromTable state fuel table ((splitUniformImpl n).run cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishPermissiveRootFilterComplete target output rightRoot ordinal + leftObserve rightObserve candidates leftResult + · intro resolved _hunrevealed + simpa only [leftObserve, rightObserve] using + ih resolved.value.1 candidates resolved.state resolved.remaining + resolved.value.2 + · intro resolved hrevealed + exact relTriple_none_delayed_of_target_revealed ordinal parameter root ftsSecret + (next resolved.value.1) candidates resolved.state resolved.remaining table + resolved.value.2 target output rightRoot hrevealed + | inr input => + let nextCandidates := permissiveRootAwareCandidates parameter input table state + candidates + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (permissiveRootAwareCandidates parameter input table state candidates).length := + by simpa [nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + exact relTriple_pure_pure (fun _ => rfl) + · have hactual : ¬ordinal < + (permissiveRootAwareCandidates parameter input table state candidates).length := + by simpa [nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + let candidate? := rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state) + by_cases hsafe : RootAwareCandidateAvoidsRoots target (truncateHash output) + rightRoot candidate? + · have hsafeActual : RootAwareCandidateAvoidsRoots target (truncateHash output) + rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + let leftObserve := + fun nextState remaining value nextCache laterCandidates => + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter root + target (truncateHash output) rightRoot ftsSecret (next value) + laterCandidates nextState remaining table nextCache + let rightObserve := + fun nextState remaining value nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next value) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_refl + (runPermissiveFromTable state fuel table + (delayedPermissivePublicAction parameter input table state cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishPermissiveRootFilterComplete target output rightRoot + ordinal leftObserve rightObserve nextCandidates leftResult + · intro resolved _hunrevealed + simpa only [leftObserve, rightObserve] using + ih resolved.value.1 nextCandidates resolved.state resolved.remaining + resolved.value.2 + · intro resolved hrevealed + exact relTriple_none_delayed_of_target_revealed ordinal parameter root + ftsSecret (next resolved.value.1) nextCandidates resolved.state + resolved.remaining table resolved.value.2 target output rightRoot hrevealed + · have hsafeActual : ¬RootAwareCandidateAvoidsRoots target + (truncateHash output) rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + cases hcandidate : candidate? with + | none => + exfalso + exact hsafe (by simp [RootAwareCandidateAvoidsRoots, hcandidate]) + | some candidate => + have hunsafe : ¬candidate.AvoidsRoots target (truncateHash output) + rightRoot := by + rw [← rootAwareCandidateAvoidsRoots_iff] + simpa [hcandidate] using hsafe + have hcandidateActual : + rootAwareCandidateForPlan? parameter input + (permissiveRootAwarePlan parameter input table state) = + some candidate := by + simpa [candidate?, permissiveRootAwarePlan] using hcandidate + have hmem : candidate ∈ nextCandidates := by + simp [nextCandidates, permissiveRootAwareCandidates, + appendPlannedCandidate, hcandidateActual] + have hlength : nextCandidates.length ≤ ordinal := by omega + let step := runPermissiveFromTable state fuel table + (delayedPermissivePublicAction parameter input table state cache) + let rightObserve := + fun nextState remaining value nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root + ftsSecret (next value) laterCandidates nextState remaining table + nextCache + change RelTriple + (pure none : ProbComp (Option PermissivePrivateOrdinalSelection)) + (step >>= finishPermissiveDetailedPrivateOrdinalSelection rightObserve + nextCandidates) + (PermissiveRootFilterCompleteRel target output rightRoot ordinal) + exact relTriple_none_finishDelayed_of_unsafe_prefix ordinal parameter root + ftsSecret next step nextCandidates table target output rightRoot candidate + hmem hlength hunsafe + | inr message => + let leftObserve := + fun nextState remaining value nextCache laterCandidates => + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter root target + (truncateHash output) rightRoot ftsSecret (next value) laterCandidates nextState + remaining table nextCache + let rightObserve := + fun nextState remaining value nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next value) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_refl + (runPermissiveFromTable state fuel table + ((maskedSign parameter root ftsSecret message).run cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishPermissiveRootFilterComplete target output rightRoot ordinal + leftObserve rightObserve candidates leftResult + · intro resolved _hunrevealed + simpa only [leftObserve, rightObserve] using + ih resolved.value.1 candidates resolved.state resolved.remaining resolved.value.2 + · intro resolved hrevealed + exact relTriple_none_delayed_of_target_revealed ordinal parameter root ftsSecret + (next resolved.value.1) candidates resolved.state resolved.remaining table + resolved.value.2 target output rightRoot hrevealed + +def PermissiveTaggedDelayedRootGuessRel + (target : Position) (rightRoot : Digest) (ordinal : Nat) : + (HashOutput × Option PermissivePrivateOrdinalSelection) → + Option PermissivePrivateOrdinalSelection → Prop := + fun left right => + PermissiveDelayedRootGuess target rightRoot ordinal right → + PermissiveDelayedRootGuessAt target left.1 rightRoot ordinal left.2 + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem valuesLE_of_mem_delayedPermissiveDetailedOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (selection : PermissivePrivateOrdinalSelection) + (hselection : some selection ∈ support + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache)) : + LazyRevealProbe.ValuesLE state selection.state := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + simp only [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_pure] at hselection + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] at hselection + simp at hselection + subst selection + exact LazyRevealProbe.ValuesLE.refl state + · simp [hselected] at hselection + | query_bind query next ih => + rw [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_query_bind] at hselection + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] at hselection + simp at hselection + subst selection + exact LazyRevealProbe.ValuesLE.refl state + · simp only [hselected, ↓reduceDIte] at hselection + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hselection + obtain ⟨result, hresult, htail⟩ := hselection + cases result with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] at htail + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] at htail + exact (valuesLE_of_mem_runPermissiveFromTable + ((splitUniformImpl n).run cache) state fuel table result hresult).trans + (ih result.value.1 candidates result.state result.remaining result.value.2 + htail) + | inr input => + let nextCandidates := + permissiveRootAwareCandidates parameter input table state candidates + by_cases hnextSelected : ordinal < nextCandidates.length + · simp only [nextCandidates, hnextSelected, ↓reduceDIte] at hselection + simp at hselection + subst selection + exact LazyRevealProbe.ValuesLE.refl state + · simp only [nextCandidates, hnextSelected, ↓reduceDIte] at hselection + rw [mem_support_bind_iff] at hselection + obtain ⟨result, hresult, htail⟩ := hselection + cases result with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] at htail + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] at htail + exact (valuesLE_of_mem_runPermissiveFromTable + (delayedPermissivePublicAction parameter input table state cache) + state fuel table result hresult).trans + (ih result.value.1 nextCandidates result.state result.remaining + result.value.2 htail) + | inr message => + rw [mem_support_bind_iff] at hselection + obtain ⟨result, hresult, htail⟩ := hselection + cases result with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] at htail + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] at htail + exact (valuesLE_of_mem_runPermissiveFromTable + ((maskedSign parameter root ftsSecret message).run cache) + state fuel table result hresult).trans + (ih result.value.1 candidates result.state result.remaining result.value.2 htail) + +theorem PermissiveDetailedSelectionRel.delayedRootGuessAt + {target : Position} {output : HashOutput} {rightRoot : Digest} {ordinal : Nat} + {left right : Option PermissivePrivateOrdinalSelection} + (hrel : PermissiveDetailedSelectionRel left right) + (hgood : PermissiveDelayedRootGuessAt target output rightRoot ordinal right) : + PermissiveDelayedRootGuessAt target output rightRoot ordinal left := by + cases left with + | none => + cases right with + | none => exact hgood + | some right => simp [PermissiveDetailedSelectionRel] at hrel + | some left => + cases right with + | none => simp [PermissiveDetailedSelectionRel] at hrel + | some right => + rcases hrel with ⟨hcandidate, hcandidates, hstate⟩ + refine ⟨hcandidate.trans hgood.1, ?_, ?_, ?_⟩ + · rw [hstate.values] + exact hgood.2.1 + · rw [hstate.revealed] + exact hgood.2.2.1 + · rw [hcandidates] + exact hgood.2.2.2 + +theorem relTriple_tagged_delayedSelection_of_stateRel + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (left right : LazyRevealProbe.State Coordinate) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (output : HashOutput) (rightRoot : Digest) + (hstate : PermissiveStateRel left right) + (hvalue : left.values (.position target) = some output) : + RelTriple + ((fun selection => (output, selection)) <$> + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates left fuel table cache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates right fuel table cache) + (PermissiveTaggedDelayedRootGuessRel target rightRoot ordinal) := by + have hbase := relTriple_delayedPermissiveDetailedOrdinalSelection_of_stateRel ordinal parameter + root ftsSecret computation candidates candidates left right fuel table cache rfl hstate + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun selection => match selection with + | none => True + | some selection => selection.state.values (.position target) = some output) + (by + intro selection hselection + cases selection with + | none => trivial + | some selection => + exact valuesLE_of_mem_delayedPermissiveDetailedOrdinalSelection ordinal parameter root + ftsSecret computation candidates left fuel table cache selection hselection + (.position target) output hvalue) + rw [map_eq_bind_pure_comp, + show delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates right fuel table cache = + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates right fuel table cache >>= pure) by simp] + apply relTriple_bind hsupported + intro leftSelection rightSelection hselection + apply relTriple_pure_pure + intro hgood + obtain ⟨rightOutput, hrightGood⟩ := hgood + have hleftGood := hselection.1.delayedRootGuessAt hrightGood + cases leftSelection with + | none => exact False.elim hleftGood + | some leftSelection => + have heq : rightOutput = output := + Option.some.inj (hleftGood.2.1.symm.trans hselection.2) + subst rightOutput + exact hleftGood + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_sample_preload_runPermissive_finishDetailed_taggedGuess + (target : Position) (rightRoot : Digest) (ordinal : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftObserve rightObserve : LazyRevealProbe.State Coordinate → Nat → α → + SplitHashCache → List Probe → ProbComp (Option PermissivePrivateOrdinalSelection)) + (candidates : List Probe) + (hvalue : state.values (.position target) = none) + (hnoPeek : computation.IsQueryBoundP (IsTargetPeek target) 0) + (hpreloaded : ∀ nextState remaining value nextCache, + nextState.values (.position target) = none → + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + (fun selection => (output, selection)) <$> + leftObserve (preloadPositionValue target output nextState) remaining value nextCache + candidates) + (rightObserve nextState remaining value nextCache candidates) + (PermissiveTaggedDelayedRootGuessRel target rightRoot ordinal)) + (hsynchronized : ∀ output left right remaining value nextCache, + PermissiveStateRel left right → + left.values (.position target) = some output → + RelTriple + ((fun selection => (output, selection)) <$> + leftObserve left remaining value nextCache candidates) + (rightObserve right remaining value nextCache candidates) + (PermissiveTaggedDelayedRootGuessRel target rightRoot ordinal)) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + (fun selection => (output, selection)) <$> + (runPermissiveFromTable (preloadPositionValue target output state) fuel table + computation >>= + finishPermissiveDetailedPrivateOrdinalSelection leftObserve candidates)) + (runPermissiveFromTable state fuel table computation >>= + finishPermissiveDetailedPrivateOrdinalSelection rightObserve candidates) + (PermissiveTaggedDelayedRootGuessRel target rightRoot ordinal) := by + let leftFinish : HashOutput → Option (CleanRunResult (α × SplitHashCache)) → + ProbComp (HashOutput × Option PermissivePrivateOrdinalSelection) := + fun output result => (fun selection => (output, selection)) <$> + finishPermissiveDetailedPrivateOrdinalSelection leftObserve candidates result + let rightFinish : Option (CleanRunResult (α × SplitHashCache)) → + ProbComp (Option PermissivePrivateOrdinalSelection) := + finishPermissiveDetailedPrivateOrdinalSelection rightObserve candidates + simp only [map_eq_bind_pure_comp, bind_assoc] + change RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveFromTable (preloadPositionValue target output state) fuel table computation >>= + leftFinish output) + (runPermissiveFromTable state fuel table computation >>= rightFinish) + (PermissiveTaggedDelayedRootGuessRel target rightRoot ordinal) + apply relTriple_sample_preload_runPermissiveFromTable_then_tagged target computation state fuel + table leftFinish rightFinish + (PermissiveTaggedDelayedRootGuessRel target rightRoot ordinal) hvalue hnoPeek + · intro nextState remaining result nextTable hnextValue + rcases result with ⟨value, nextCache⟩ + simpa only [leftFinish, rightFinish, finishPermissiveDetailedPrivateOrdinalSelection, + map_eq_bind_pure_comp] using + hpreloaded nextState remaining value nextCache hnextValue + · intro output + exact relTriple_pure_pure (fun hgood => by + simp [PermissiveDelayedRootGuess, PermissiveDelayedRootGuessAt] at hgood) + · intro output left right hrelation hpreloadedOutput + cases left with + | none => + cases right with + | none => exact relTriple_pure_pure (fun hgood => by + simp [PermissiveDelayedRootGuess, PermissiveDelayedRootGuessAt] at hgood) + | some right => exact False.elim hrelation + | some left => + cases right with + | none => exact False.elim hrelation + | some right => + rcases hrelation with ⟨hstate, hremaining, hvalueEq, _htable⟩ + simp only [leftFinish, rightFinish, + finishPermissiveDetailedPrivateOrdinalSelection] + rw [← hremaining, ← hvalueEq] + exact hsynchronized output left.state right.state left.remaining left.value.1 + left.value.2 hstate hpreloadedOutput + +theorem relTriple_sample_preload_pureSelection_taggedGuess + (target : Position) (rightRoot : Digest) (ordinal : Nat) + (candidate : Probe) (candidates : List Probe) + (state : LazyRevealProbe.State Coordinate) + (hvalue : state.values (.position target) = none) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + (pure (output, some ⟨candidate, preloadPositionValue target output state, candidates⟩) : + ProbComp (HashOutput × Option PermissivePrivateOrdinalSelection))) + (pure (some ⟨candidate, state, candidates⟩) : + ProbComp (Option PermissivePrivateOrdinalSelection)) + (PermissiveTaggedDelayedRootGuessRel target rightRoot ordinal) := by + rw [show (pure (some ⟨candidate, state, candidates⟩) : + ProbComp (Option PermissivePrivateOrdinalSelection)) = + ((pure () : ProbComp Unit) >>= fun _ => pure (some ⟨candidate, state, candidates⟩)) by simp] + apply relTriple_bind + (relTriple_true LazyRevealProbe.sampleHashOutput (pure () : ProbComp Unit)) + intro output _unit _hrelation + apply relTriple_pure_pure + intro hgood + obtain ⟨_rightOutput, hgood⟩ := hgood + exfalso + have himpossible := hgood.2.1 + rw [hvalue] at himpossible + simp at himpossible + +theorem relTriple_sample_preload_pureNone_taggedGuess + (target : Position) (rightRoot : Digest) (ordinal : Nat) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + pure (output, (none : Option PermissivePrivateOrdinalSelection))) + (pure none : ProbComp (Option PermissivePrivateOrdinalSelection)) + (PermissiveTaggedDelayedRootGuessRel target rightRoot ordinal) := by + rw [show (pure none : ProbComp (Option PermissivePrivateOrdinalSelection)) = + ((pure () : ProbComp Unit) >>= fun _ => + pure (none : Option PermissivePrivateOrdinalSelection)) by simp] + apply relTriple_bind + (relTriple_true LazyRevealProbe.sampleHashOutput (pure () : ProbComp Unit)) + intro output _unit _hrelation + exact relTriple_pure_pure (fun hgood => by + simp [PermissiveDelayedRootGuess, PermissiveDelayedRootGuessAt] at hgood) + +theorem relTriple_sample_preload_delayedSelector_taggedGuess_of_initial_revealed + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (rightRoot : Digest) + (hrevealed : Coordinate.position target ∈ state.revealed) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + (fun selection => (output, selection)) <$> + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates (preloadPositionValue target output state) fuel table cache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache) + (PermissiveTaggedDelayedRootGuessRel target rightRoot ordinal) := by + have hbase := relTriple_true + (LazyRevealProbe.sampleHashOutput >>= fun output => + (fun selection => (output, selection)) <$> + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates (preloadPositionValue target output state) fuel table cache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache) + have hright := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + apply relTriple_post_mono hright + intro left right hrelation hgood + rcases hrelation with ⟨_htrue, hrightSupport⟩ + cases right with + | none => simp [PermissiveDelayedRootGuess, PermissiveDelayedRootGuessAt] at hgood + | some selection => + obtain ⟨_rightOutput, hgood⟩ := hgood + exfalso + exact hgood.2.2.1 + (revealed_subset_of_mem_delayedPermissiveDetailedOrdinalSelection ordinal parameter root + ftsSecret computation candidates state fuel table cache selection hrightSupport hrevealed) + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_sample_preload_delayedPermissiveDetailedOrdinalSelection_taggedGuess + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (rightRoot : Digest) + (hvalue : state.values (.position target) = none) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + (fun selection => (output, selection)) <$> + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates (preloadPositionValue target output state) fuel table cache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache) + (PermissiveTaggedDelayedRootGuessRel target rightRoot ordinal) := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + by_cases hrevealed : Coordinate.position target ∈ state.revealed + · exact relTriple_sample_preload_delayedSelector_taggedGuess_of_initial_revealed ordinal + parameter root ftsSecret (pure value) candidates state fuel table cache target rightRoot + hrevealed + · simp only [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_sample_preload_pureSelection_taggedGuess target rightRoot ordinal + (candidates.get ⟨ordinal, hselected⟩) candidates state hvalue + · simp only [hselected, ↓reduceDIte, map_pure] + exact relTriple_sample_preload_pureNone_taggedGuess target rightRoot ordinal + | query_bind query next ih => + by_cases hrevealed : Coordinate.position target ∈ state.revealed + · exact relTriple_sample_preload_delayedSelector_taggedGuess_of_initial_revealed ordinal + parameter root ftsSecret (liftM (OracleSpec.query query) >>= next) candidates state fuel + table cache target rightRoot hrevealed + · simp_rw [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_sample_preload_pureSelection_taggedGuess target rightRoot ordinal + (candidates.get ⟨ordinal, hselected⟩) candidates state hvalue + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let observe := fun nextState remaining value nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next value) laterCandidates nextState remaining table nextCache + apply relTriple_sample_preload_runPermissive_finishDetailed_taggedGuess target + rightRoot ordinal ((splitUniformImpl n).run cache) state fuel table observe + observe candidates hvalue (splitUniformImpl_targetPeekFree target n cache) + · intro nextState remaining value nextCache hnextValue + simpa only [observe] using + ih value candidates nextState remaining nextCache hnextValue + · intro output left right remaining value nextCache hstate houtput + exact relTriple_tagged_delayedSelection_of_stateRel ordinal parameter root + ftsSecret (next value) candidates left right remaining table nextCache target + output rightRoot hstate houtput + | inr input => + let nextCandidates := + permissiveRootAwareCandidates parameter input table state candidates + by_cases hnextSelected : ordinal < nextCandidates.length + · simp only [nextCandidates, hnextSelected, ↓reduceDIte] + rw [show (pure (some + ⟨(permissiveRootAwareCandidates parameter input table state candidates).get + ⟨ordinal, hnextSelected⟩, state, + permissiveRootAwareCandidates parameter input table state candidates⟩) : + ProbComp (Option PermissivePrivateOrdinalSelection)) = + ((pure () : ProbComp Unit) >>= fun _ => pure (some + ⟨(permissiveRootAwareCandidates parameter input table state candidates).get + ⟨ordinal, hnextSelected⟩, state, + permissiveRootAwareCandidates parameter input table state candidates⟩)) by + simp] + apply relTriple_bind + (relTriple_true LazyRevealProbe.sampleHashOutput (pure () : ProbComp Unit)) + intro output _unit _hrelation + rw [permissiveRootAwareCandidates_preload_hidden target output state hrevealed + parameter input table candidates] + rw [dif_pos hnextSelected] + exact relTriple_pure_pure (by + intro hgood + obtain ⟨_rightOutput, hgood⟩ := hgood + exfalso + have himpossible := hgood.2.1 + rw [hvalue] at himpossible + simp at himpossible) + · simp_rw [permissiveRootAwareCandidates_preload_hidden target _ state hrevealed + parameter input table candidates] + simp only [nextCandidates, hnextSelected, ↓reduceDIte] + simp_rw [delayedPermissivePublicAction_preload_hidden target _ state hrevealed + parameter input table cache] + let observe := fun nextState remaining value nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next value) laterCandidates nextState remaining table nextCache + apply relTriple_sample_preload_runPermissive_finishDetailed_taggedGuess target + rightRoot ordinal + (delayedPermissivePublicAction parameter input table state cache) state fuel + table observe observe nextCandidates hvalue + (delayedPermissivePublicAction_targetPeekFree target parameter input table + state cache) + · intro nextState remaining value nextCache hnextValue + simpa only [observe] using + ih value nextCandidates nextState remaining nextCache hnextValue + · intro output left right remaining value nextCache hstate houtput + exact relTriple_tagged_delayedSelection_of_stateRel ordinal parameter root + ftsSecret (next value) nextCandidates left right remaining table nextCache + target output rightRoot hstate houtput + | inr message => + let observe := fun nextState remaining value nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next value) laterCandidates nextState remaining table nextCache + apply relTriple_sample_preload_runPermissive_finishDetailed_taggedGuess target + rightRoot ordinal ((maskedSign parameter root ftsSecret message).run cache) state + fuel table observe observe candidates hvalue + (maskedSign_targetPeekFree target parameter root ftsSecret message cache) + · intro nextState remaining value nextCache hnextValue + simpa only [observe] using + ih value candidates nextState remaining nextCache hnextValue + · intro output left right remaining value nextCache hstate houtput + exact relTriple_tagged_delayedSelection_of_stateRel ordinal parameter root + ftsSecret (next value) candidates left right remaining table nextCache target + output rightRoot hstate houtput + +theorem probEvent_delayedRootGuess_le_taggedPreloaded + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (rightRoot : Digest) + (hvalue : state.values (.position target) = none) : + Pr[PermissiveDelayedRootGuess target rightRoot ordinal | + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache] ≤ + Pr[fun result : HashOutput × Option PermissivePrivateOrdinalSelection => + PermissiveDelayedRootGuessAt target result.1 rightRoot ordinal result.2 | + LazyRevealProbe.sampleHashOutput >>= fun output => + (fun selection => (output, selection)) <$> + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates (preloadPositionValue target output state) fuel table cache] := by + apply probEvent_le_of_relTriple + (relTriple_symm + (relTriple_sample_preload_delayedPermissiveDetailedOrdinalSelection_taggedGuess ordinal + parameter root ftsSecret computation candidates state fuel table cache target rightRoot + hvalue)) + intro right left hrelation hgood + exact hrelation hgood + +theorem probEvent_taggedPreloaded_le_taggedInstalled + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (rightRoot : Digest) : + Pr[fun result : HashOutput × Option PermissivePrivateOrdinalSelection => + PermissiveDelayedRootGuessAt target result.1 rightRoot ordinal result.2 | + LazyRevealProbe.sampleHashOutput >>= fun output => + (fun selection => (output, selection)) <$> + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates (preloadPositionValue target output state) fuel table cache] ≤ + Pr[fun result : HashOutput × Option PermissivePrivateOrdinalSelection => + PermissiveDelayedRootGuessAt target result.1 rightRoot ordinal result.2 | + LazyRevealProbe.sampleHashOutput >>= fun output => + (fun selection => (output, selection)) <$> + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates (preloadPositionValue target output state) fuel table + (replaceHiddenRootCache target output cache)] := by + apply probEvent_bind_le_bind_of_forall_le + intro output _houtput + rw [probEvent_map, probEvent_map] + apply probEvent_le_of_relTriple + (relTriple_delayedPermissiveDetailedOrdinalSelection_of_ordinaryCacheEq ordinal parameter root + ftsSecret computation candidates (preloadPositionValue target output state) fuel table cache + (replaceHiddenRootCache target output cache) + (ordinaryQueryCache_replaceHiddenRootCache target output cache)) + intro left right heq hgood + rwa [← heq] + +theorem relTriple_none_any_permissiveFilteredSelection + (target : Position) + (right : ProbComp (Option PermissivePrivateOrdinalSelection)) : + RelTriple (pure none : ProbComp (Option PermissivePrivateOrdinalSelection)) right + (PermissiveFilteredSelectionRel target) := by + have hbase := relTriple_true + (pure none : ProbComp (Option PermissivePrivateOrdinalSelection)) right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun value => value = none) (by intro value hvalue; simpa using hvalue) + apply relTriple_post_mono hsupported + intro left right hrelation + rw [hrelation.2] + trivial + +theorem relTriple_finishPermissiveFilteredSelection + (target : Position) + (leftObserve rightObserve : LazyRevealProbe.State Coordinate → Nat → α → + SplitHashCache → List Probe → ProbComp (Option PermissivePrivateOrdinalSelection)) + (candidates : List Probe) + (result : Option (CleanRunResult (α × SplitHashCache))) + (hrecursive : ∀ (resolved : CleanRunResult (α × SplitHashCache)), + Coordinate.position target ∉ resolved.state.revealed → + RelTriple + (leftObserve resolved.state resolved.remaining resolved.value.1 resolved.value.2 candidates) + (rightObserve resolved.state resolved.remaining resolved.value.1 resolved.value.2 candidates) + (PermissiveFilteredSelectionRel target)) : + RelTriple + (finishPermissiveDetailedPrivateOrdinalSelection + (continuePermissiveRootAvoidingDetailedOrdinalSelection target leftObserve) + candidates result) + (finishPermissiveDetailedPrivateOrdinalSelection rightObserve candidates result) + (PermissiveFilteredSelectionRel target) := by + cases result with + | none => exact relTriple_pure_pure trivial + | some resolved => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] + unfold continuePermissiveRootAvoidingDetailedOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ resolved.state.revealed + · simp only [hrevealed, ↓reduceIte] + exact relTriple_none_any_permissiveFilteredSelection target _ + · simp only [hrevealed, ↓reduceIte] + exact hrecursive resolved hrevealed + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_permissiveRootAvoidingDetailedOrdinalSelection_delayed + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) + (hprivate : Coordinate.position target ∉ state.revealed) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + RelTriple + (permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter root target + leftRoot rightRoot ftsSecret computation candidates state fuel table cache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache) + (PermissiveFilteredSelectionRel target) := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + simp only [permissiveActualRootAvoidingDetailedOrdinalSelection, + permissiveRootAvoidingDetailedOrdinalSelection, + delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure ⟨rfl, hprivate⟩ + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure trivial + | query_bind query next ih => + unfold permissiveActualRootAvoidingDetailedOrdinalSelection + rw [permissiveRootAvoidingDetailedOrdinalSelection, OracleComp.construct_query_bind, + delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure ⟨rfl, hprivate⟩ + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let leftObserve := + fun nextState remaining value nextCache laterCandidates => + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter root + target leftRoot rightRoot ftsSecret (next value) laterCandidates nextState + remaining table nextCache + let rightObserve := + fun nextState remaining value nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next value) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_refl + (runPermissiveFromTable state fuel table ((splitUniformImpl n).run cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishPermissiveFilteredSelection target leftObserve rightObserve + candidates leftResult + intro resolved hresolvedPrivate + simpa only [leftObserve, rightObserve] using + ih resolved.value.1 candidates resolved.state hresolvedPrivate resolved.remaining + resolved.value.2 + | inr input => + let nextCandidates := permissiveRootAwareCandidates parameter input table state + candidates + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (permissiveRootAwareCandidates parameter input table state candidates).length := by + simpa [nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + exact relTriple_pure_pure ⟨rfl, hprivate⟩ + · have hactual : ¬ordinal < + (permissiveRootAwareCandidates parameter input table state candidates).length := by + simpa [nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + let candidate? := rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state) + by_cases hsafe : RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? + · have hsafeActual : RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + let leftObserve := + fun nextState remaining value nextCache laterCandidates => + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter root + target leftRoot rightRoot ftsSecret (next value) laterCandidates nextState + remaining table nextCache + let rightObserve := + fun nextState remaining value nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next value) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_refl + (runPermissiveFromTable state fuel table + (delayedPermissivePublicAction parameter input table state cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishPermissiveFilteredSelection target leftObserve + rightObserve nextCandidates leftResult + intro resolved hresolvedPrivate + simpa only [leftObserve, rightObserve] using + ih resolved.value.1 nextCandidates resolved.state hresolvedPrivate + resolved.remaining resolved.value.2 + · have hsafeActual : ¬RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + exact relTriple_none_any_permissiveFilteredSelection target _ + | inr message => + let leftObserve := + fun nextState remaining value nextCache laterCandidates => + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter root target + leftRoot rightRoot ftsSecret (next value) laterCandidates nextState remaining table + nextCache + let rightObserve := + fun nextState remaining value nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next value) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_refl + (runPermissiveFromTable state fuel table + ((maskedSign parameter root ftsSecret message).run cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishPermissiveFilteredSelection target leftObserve rightObserve + candidates leftResult + intro resolved hresolvedPrivate + simpa only [leftObserve, rightObserve] using + ih resolved.value.1 candidates resolved.state hresolvedPrivate resolved.remaining + resolved.value.2 + +theorem PermissiveFilteredSelectionRel.targetFiber + {target : Position} + {left right : Option PermissivePrivateOrdinalSelection} + (hroot : IsLayerRoot target) + (hrel : PermissiveFilteredSelectionRel target left right) + (hat : materializedOrdinalSelectionAt target + (erasePermissivePrivateOrdinalSelection left)) : + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? right = some target := by + cases left with + | none => simp [erasePermissivePrivateOrdinalSelection, + materializedOrdinalSelectionAt] at hat + | some left => + cases right with + | none => simp [PermissiveFilteredSelectionRel] at hrel + | some right => + rcases hrel with ⟨rfl, hprivate⟩ + simp only [erasePermissivePrivateOrdinalSelection] at hat + exact permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?_eq_some_of_candidate + hat hroot hprivate + +theorem probEvent_permissiveRootAvoidingSelection_le_delayedFiber + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (hroot : IsLayerRoot target) (root leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) + (hprivate : Coordinate.position target ∉ state.revealed) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + Pr[fun selection => materializedOrdinalSelectionAt target + (erasePermissivePrivateOrdinalSelection selection) | + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter root target + leftRoot rightRoot ftsSecret computation candidates state fuel table cache] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache] := by + apply probEvent_le_of_relTriple + (relTriple_permissiveRootAvoidingDetailedOrdinalSelection_delayed ordinal parameter target + leftRoot rightRoot root ftsSecret computation candidates state hprivate fuel table cache) + intro left right hrelation hleft + exact hrelation.targetFiber hroot hleft + +set_option maxRecDepth 100000 in +theorem probEvent_sampledHigh_permissiveRootAvoidingSelection_le_installedDelayed + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hunrevealed : Coordinate.position target ∉ rootResult.state.revealed) : + Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionAt target result.2 | do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let output := fun root => rootOutputOfParts root high + let selection ← erasePermissivePrivateOrdinalSelection <$> + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter + rootResult.value.1 target leftRoot leftRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (preloadPositionValue target (output leftRoot) rootResult.state) rootResult.remaining + rootResult.table (rootInstalledCache target output rootResult.value.2 leftRoot) + pure (leftRoot, selection)] ≤ + Pr[fun result => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? result.2 = some target | + sampledHighInstalledDelayedSelectionAfterRootResult ordinal adversary parameter ftsSecret + target rootResult] := by + unfold sampledHighInstalledDelayedSelectionAfterRootResult + apply probEvent_bind_le_bind_of_forall_le + intro high _hhigh + apply probEvent_bind_le_bind_of_forall_le + intro leftRoot _hleftRoot + let output := fun root => rootOutputOfParts root high + let left := permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter + rootResult.value.1 target leftRoot leftRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (preloadPositionValue target (output leftRoot) rootResult.state) rootResult.remaining + rootResult.table (rootInstalledCache target output rootResult.value.2 leftRoot) + let leftErased := erasePermissivePrivateOrdinalSelection <$> left + let right := delayedPermissiveDetailedOrdinalSelection ordinal parameter rootResult.value.1 + ftsSecret (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (preloadPositionValue target (output leftRoot) rootResult.state) rootResult.remaining + rootResult.table (rootInstalledCache target output rootResult.value.2 leftRoot) + rw [show (do let selection ← leftErased; pure (leftRoot, selection)) = + (fun selection => (leftRoot, selection)) <$> leftErased by simp [map_eq_bind_pure_comp], + show (do let selection ← right; pure (leftRoot, selection)) = + (fun selection => (leftRoot, selection)) <$> right by simp [map_eq_bind_pure_comp], + probEvent_map, probEvent_map, probEvent_map] + exact probEvent_permissiveRootAvoidingSelection_le_delayedFiber ordinal parameter target hroot + rootResult.value.1 leftRoot leftRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (preloadPositionValue target (output leftRoot) rootResult.state) + (by simpa [output] using hunrevealed) rootResult.remaining rootResult.table + (rootInstalledCache target output rootResult.value.2 leftRoot) + +set_option maxRecDepth 100000 in +theorem probEvent_sampledRoots_taggedInstalledGuess_le_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hunrevealed : Coordinate.position target ∉ rootResult.state.revealed) + (hcacheSwap : ∀ high leftRoot rightRoot, + fullSwapRootCache parameter target leftRoot rightRoot + (rootOutputOfParts rightRoot high) + (replaceHiddenRootCache target (rootOutputOfParts leftRoot high) rootResult.value.2) = + replaceHiddenRootCache target (rootOutputOfParts rightRoot high) rootResult.value.2) : + Pr[fun result : HashOutput × Digest × Option PermissivePrivateOrdinalSelection => + PermissiveDelayedRootGuessAt target result.1 result.2.1 ordinal result.2.2 | do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let output := rootOutputOfParts leftRoot high + let selection ← delayedPermissiveDetailedOrdinalSelection ordinal parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (preloadPositionValue target output rootResult.state) rootResult.remaining rootResult.table + (replaceHiddenRootCache target output rootResult.value.2) + pure (output, rightRoot, selection)] ≤ + Pr[fun result => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? result.2 = some target | + sampledHighInstalledDelayedSelectionAfterRootResult ordinal adversary parameter ftsSecret + target rootResult] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let delayed := fun high leftRoot => + delayedPermissiveDetailedOrdinalSelection ordinal parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (preloadPositionValue target (rootOutputOfParts leftRoot high) rootResult.state) + rootResult.remaining rootResult.table + (replaceHiddenRootCache target (rootOutputOfParts leftRoot high) rootResult.value.2) + let actual := fun high leftRoot rightRoot => + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter rootResult.value.1 + target (truncateHash (rootOutputOfParts leftRoot high)) rightRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (preloadPositionValue target (rootOutputOfParts leftRoot high) rootResult.state) + rootResult.remaining rootResult.table + (replaceHiddenRootCache target (rootOutputOfParts leftRoot high) rootResult.value.2) + calc + _ ≤ Pr[fun result : Digest × Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2.2 | do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← erasePermissivePrivateOrdinalSelection <$> + actual high leftRoot rightRoot + pure (leftRoot, rightRoot, selection)] := by + apply probEvent_bind_le_bind_of_forall_le + intro high _hhigh + apply probEvent_bind_le_bind_of_forall_le + intro leftRoot _hleftRoot + apply probEvent_bind_le_bind_of_forall_le + intro rightRoot _hrightRoot + have hdelayed : (do + let selection ← delayed high leftRoot + pure (rootOutputOfParts leftRoot high, rightRoot, selection)) = + (fun selection => (rootOutputOfParts leftRoot high, rightRoot, selection)) <$> + delayed high leftRoot := by simp [map_eq_bind_pure_comp] + have hactual : (do + let selection ← erasePermissivePrivateOrdinalSelection <$> + actual high leftRoot rightRoot + pure (leftRoot, rightRoot, selection)) = + (fun selection => (leftRoot, rightRoot, selection)) <$> + (erasePermissivePrivateOrdinalSelection <$> actual high leftRoot rightRoot) := by + simp [map_eq_bind_pure_comp] + rw [hdelayed, hactual, probEvent_map, probEvent_map, probEvent_map] + change Pr[PermissiveDelayedRootGuessAt target (rootOutputOfParts leftRoot high) rightRoot + ordinal | delayed high leftRoot] ≤ + Pr[materializedOrdinalSelectionMatches target leftRoot ∘ + erasePermissivePrivateOrdinalSelection | actual high leftRoot rightRoot] + apply probEvent_le_of_relTriple + (relTriple_symm + (relTriple_delayed_permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter + rootResult.value.1 target (rootOutputOfParts leftRoot high) rightRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (preloadPositionValue target (rootOutputOfParts leftRoot high) rootResult.state) + rootResult.remaining rootResult.table + (replaceHiddenRootCache target (rootOutputOfParts leftRoot high) + rootResult.value.2))) + intro right left hrelation hgood + have heq := hrelation hgood + rw [heq] + cases right with + | none => exact False.elim hgood + | some selection => + simpa [Function.comp_def, materializedOrdinalSelectionMatches, + erasePermissivePrivateOrdinalSelection, truncateHash_rootOutputOfParts] using hgood.1 + _ ≤ Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionAt target result.2 | do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← erasePermissivePrivateOrdinalSelection <$> actual high leftRoot leftRoot + pure (leftRoot, selection)] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_bind_le_bind_mul_of_forall + intro high _hhigh + simpa [actual, truncateHash_rootOutputOfParts, rootInstalledCache] using + (probEvent_uniformActualRoot_permissiveRootAvoidingSelection_le_mul ordinal parameter + rootResult.value.1 target hroot (fun root => rootOutputOfParts root high) + (fun root => truncateHash_rootOutputOfParts root high) ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state hunrevealed rootResult.remaining rootResult.table + (fun root => replaceHiddenRootCache target (rootOutputOfParts root high) + rootResult.value.2) + (by intro root; simp [replaceHiddenRootCache]) + (hcacheSwap high)) + _ ≤ _ := by + gcongr + simpa [actual, truncateHash_rootOutputOfParts, rootInstalledCache] using + (probEvent_sampledHigh_permissiveRootAvoidingSelection_le_installedDelayed ordinal + adversary parameter ftsSecret target hroot rootResult hunrevealed) + +set_option maxRecDepth 100000 in +theorem probEvent_delayedRootGuess_afterRootResult_le_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hvalue : rootResult.state.values (.position target) = none) + (hunrevealed : Coordinate.position target ∉ rootResult.state.revealed) + (hcacheSwap : ∀ high leftRoot rightRoot, + fullSwapRootCache parameter target leftRoot rightRoot + (rootOutputOfParts rightRoot high) + (replaceHiddenRootCache target (rootOutputOfParts leftRoot high) rootResult.value.2) = + replaceHiddenRootCache target (rootOutputOfParts rightRoot high) rootResult.value.2) : + Pr[fun result : Option PermissivePrivateOrdinalSelection × Digest => + PermissiveDelayedRootGuess target result.2 ordinal result.1 | do + let selection ← delayedPermissiveDetailedOrdinalSelection ordinal parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining rootResult.table rootResult.value.2 + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot)] ≤ + Pr[fun result => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? result.2 = some target | + sampledHighInstalledDelayedSelectionAfterRootResult ordinal adversary parameter ftsSecret + target rootResult] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let raw := delayedPermissiveDetailedOrdinalSelection ordinal parameter rootResult.value.1 + ftsSecret (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining rootResult.table rootResult.value.2 + let installed := fun output => + delayedPermissiveDetailedOrdinalSelection ordinal parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (preloadPositionValue target output rootResult.state) rootResult.remaining rootResult.table + (replaceHiddenRootCache target output rootResult.value.2) + let reordered : ProbComp (Option PermissivePrivateOrdinalSelection × Digest) := do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← raw + pure (selection, rightRoot) + let tagged : ProbComp (HashOutput × Digest × Option PermissivePrivateOrdinalSelection) := do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let output ← LazyRevealProbe.sampleHashOutput + let selection ← installed output + pure (output, rightRoot, selection) + have hreorder : evalDist (do + let selection ← raw + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot)) = evalDist reordered := by + exact OracleComp.DeferredSampling.evalDist_bind_comm raw + ($ᵗ Digest : ProbComp Digest) (fun selection rightRoot => pure (selection, rightRoot)) + calc + _ = Pr[fun result : Option PermissivePrivateOrdinalSelection × Digest => + PermissiveDelayedRootGuess target result.2 ordinal result.1 | reordered] := by + apply OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + exact hreorder + _ ≤ Pr[fun result : HashOutput × Digest × Option PermissivePrivateOrdinalSelection => + PermissiveDelayedRootGuessAt target result.1 result.2.1 ordinal result.2.2 | + tagged] := by + unfold reordered tagged + apply probEvent_bind_le_bind_of_forall_le + intro rightRoot _hrightRoot + have hraw : (do let selection ← raw; pure (selection, rightRoot)) = + (fun selection => (selection, rightRoot)) <$> raw := by + simp [map_eq_bind_pure_comp] + have htaggedPair : (do + let output ← LazyRevealProbe.sampleHashOutput + let selection ← installed output + pure (output, rightRoot, selection)) = + (fun result : HashOutput × Option PermissivePrivateOrdinalSelection => + (result.1, rightRoot, result.2)) <$> (do + let output ← LazyRevealProbe.sampleHashOutput + (fun selection => (output, selection)) <$> installed output) := by + simp [map_eq_bind_pure_comp, bind_assoc] + rw [hraw, htaggedPair, probEvent_map, probEvent_map] + calc + _ ≤ Pr[fun result : HashOutput × Option PermissivePrivateOrdinalSelection => + PermissiveDelayedRootGuessAt target result.1 rightRoot ordinal result.2 | + LazyRevealProbe.sampleHashOutput >>= fun output => + (fun selection => (output, selection)) <$> + delayedPermissiveDetailedOrdinalSelection ordinal parameter rootResult.value.1 + ftsSecret + (retainedGameRestComputation adversary + ⟨rootResult.value.1, parameter⟩) [] + (preloadPositionValue target output rootResult.state) rootResult.remaining + rootResult.table rootResult.value.2] := + probEvent_delayedRootGuess_le_taggedPreloaded ordinal parameter rootResult.value.1 + ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining rootResult.table rootResult.value.2 target + rightRoot hvalue + _ ≤ _ := by + change Pr[fun result : HashOutput × Option PermissivePrivateOrdinalSelection => + PermissiveDelayedRootGuessAt target result.1 rightRoot ordinal result.2 | + LazyRevealProbe.sampleHashOutput >>= fun output => + (fun selection => (output, selection)) <$> + delayedPermissiveDetailedOrdinalSelection ordinal parameter rootResult.value.1 + ftsSecret + (retainedGameRestComputation adversary + ⟨rootResult.value.1, parameter⟩) [] + (preloadPositionValue target output rootResult.state) rootResult.remaining + rootResult.table rootResult.value.2] ≤ + Pr[fun result : HashOutput × Option PermissivePrivateOrdinalSelection => + PermissiveDelayedRootGuessAt target result.1 rightRoot ordinal result.2 | + LazyRevealProbe.sampleHashOutput >>= fun output => + (fun selection => (output, selection)) <$> installed output] + simpa only [installed] using + (probEvent_taggedPreloaded_le_taggedInstalled ordinal parameter rootResult.value.1 + ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining rootResult.table rootResult.value.2 target + rightRoot) + _ = Pr[fun result : HashOutput × Digest × Option PermissivePrivateOrdinalSelection => + PermissiveDelayedRootGuessAt target result.1 result.2.1 ordinal result.2.2 | do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let output := rootOutputOfParts leftRoot high + let selection ← installed output + pure (output, rightRoot, selection)] := by + let parts : ProbComp HashOutput := do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let root ← ($ᵗ Digest : ProbComp Digest) + pure (rootOutputOfParts root high) + have hparts : evalDist parts = evalDist LazyRevealProbe.sampleHashOutput := by + calc + _ = evalDist (do + let root ← ($ᵗ Digest : ProbComp Digest) + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + pure (rootOutputOfParts root high)) := by + exact OracleComp.DeferredSampling.evalDist_bind_comm + ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + ($ᵗ Digest : ProbComp Digest) + (fun high root => pure (rootOutputOfParts root high)) + _ = _ := evalDist_sample_rootOutputOfParts + let continuation := fun output : HashOutput => do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← installed output + pure (output, rightRoot, selection) + have htagged : evalDist tagged = evalDist (parts >>= continuation) := by + calc + _ = evalDist (LazyRevealProbe.sampleHashOutput >>= continuation) := by + unfold tagged continuation + exact OracleComp.DeferredSampling.evalDist_bind_comm + ($ᵗ Digest : ProbComp Digest) LazyRevealProbe.sampleHashOutput + (fun rightRoot output => do + let selection ← installed output + pure (output, rightRoot, selection)) + _ = _ := (evalDist_bind_eq_of_evalDist_eq hparts continuation).symm + apply OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + calc + evalDist tagged = evalDist (parts >>= continuation) := htagged + _ = _ := by simp [parts, continuation, bind_assoc] + _ ≤ _ := probEvent_sampledRoots_taggedInstalledGuess_le_mul ordinal adversary parameter + ftsSecret target hroot rootResult hunrevealed hcacheSwap + +theorem fullSwapRootCache_replace_of_swapCanonical_eq + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (leftOutput rightOutput : HashOutput) + (cache : SplitHashCache) + (hcache : swapCanonicalRootEncodingCache parameter target leftRoot rightRoot cache = cache) : + fullSwapRootCache parameter target leftRoot rightRoot rightOutput + (replaceHiddenRootCache target leftOutput cache) = + replaceHiddenRootCache target rightOutput cache := by + unfold fullSwapRootCache + funext key + cases key with + | ordinary input => + simpa [swapCanonicalRootEncodingCache, replaceHiddenRootCache] using + congrFun hcache (.ordinary input) + | hidden coordinate => + by_cases heq : coordinate = .position target + · subst coordinate + simp [replaceHiddenRootCache] + · simp [swapCanonicalRootEncodingCache, replaceHiddenRootCache, heq] + +set_option maxRecDepth 100000 in +theorem probEvent_delayedRootGuess_afterRootResult_le_installed_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hvalue : rootResult.state.values (.position target) = none) + (hunrevealed : Coordinate.position target ∉ rootResult.state.revealed) + (hbaseSwap : ∀ leftRoot rightRoot, + swapCanonicalRootEncodingCache parameter target leftRoot rightRoot + rootResult.value.2 = rootResult.value.2) : + Pr[fun result : Option PermissivePrivateOrdinalSelection × Digest => + PermissiveDelayedRootGuess target result.2 ordinal result.1 | do + let selection ← delayedPermissiveDetailedOrdinalSelection ordinal parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining rootResult.table rootResult.value.2 + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (selection, rightRoot)] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + installedDelayedPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + have hfullSwap (high : RootOutputHigh) (leftRoot rightRoot : Digest) : + fullSwapRootCache parameter target leftRoot rightRoot + (rootOutputOfParts rightRoot high) + (replaceHiddenRootCache target (rootOutputOfParts leftRoot high) + rootResult.value.2) = + replaceHiddenRootCache target (rootOutputOfParts rightRoot high) + rootResult.value.2 := by + exact fullSwapRootCache_replace_of_swapCanonical_eq parameter target leftRoot rightRoot + (rootOutputOfParts leftRoot high) (rootOutputOfParts rightRoot high) + rootResult.value.2 (hbaseSwap leftRoot rightRoot) + calc + _ ≤ Pr[fun result => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? result.2 = some target | + sampledHighInstalledDelayedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult] * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + probEvent_delayedRootGuess_afterRootResult_le_mul ordinal adversary parameter ftsSecret + target hroot rootResult hvalue hunrevealed hfullSwap + _ = _ := by + congr 1 + rw [show Pr[fun result => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? result.2 = some target | + sampledHighInstalledDelayedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult] = + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + Prod.snd <$> sampledHighInstalledDelayedSelectionAfterRootResult ordinal adversary + parameter ftsSecret target rootResult] by + rw [probEvent_map] + rfl] + apply OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + exact evalDist_sampledHighInstalledDelayed_snd_eq_installed ordinal adversary parameter + ftsSecret target rootResult + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwapSelector.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwapSelector.lean new file mode 100644 index 00000000..6d285aa4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwapSelector.lean @@ -0,0 +1,1045 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedRootSwapEncoding + +/-! +# Root-avoiding permissive delayed selector + +This selector retains the delayed source schedule and rejects only when the next recorded root +candidate is one of the two distinguished roots. The guard is symmetric in those roots. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable + +noncomputable def continuePermissiveRootAvoidingDetailedOrdinalSelection + (target : Position) + (observe : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp (Option PermissivePrivateOrdinalSelection)) + (state : LazyRevealProbe.State Coordinate) (remaining : Nat) (value : α) + (cache : SplitHashCache) (candidates : List Probe) : + ProbComp (Option PermissivePrivateOrdinalSelection) := + if Coordinate.position target ∈ state.revealed then pure none + else observe state remaining value cache candidates + +noncomputable def permissiveRootAvoidingDetailedOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (signer : Message → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option PermissivePrivateOrdinalSelection) := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + List Probe → LazyRevealProbe.State Coordinate → Nat → + (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp (Option PermissivePrivateOrdinalSelection)) + (fun _value candidates state _fuel _table _cache => + if hselected : ordinal < candidates.length then + pure (some ⟨candidates.get ⟨ordinal, hselected⟩, state, candidates⟩) + else pure none) + (fun query _next recursivelyRun candidates state fuel table cache => + if hselected : ordinal < candidates.length then + pure (some ⟨candidates.get ⟨ordinal, hselected⟩, state, candidates⟩) + else + match query with + | .inl (.inl n) => + runPermissiveFromTable state fuel table ((splitUniformImpl n).run cache) >>= + finishPermissiveDetailedPrivateOrdinalSelection + (continuePermissiveRootAvoidingDetailedOrdinalSelection target + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache)) + candidates + | .inl (.inr input) => + let nextCandidates := permissiveRootAwareCandidates parameter input table state + candidates + if hnextSelected : ordinal < nextCandidates.length then + pure (some ⟨nextCandidates.get ⟨ordinal, hnextSelected⟩, state, + nextCandidates⟩) + else + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + if RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? then + runPermissiveFromTable state fuel table + (delayedPermissivePublicAction parameter input table state cache) >>= + finishPermissiveDetailedPrivateOrdinalSelection + (continuePermissiveRootAvoidingDetailedOrdinalSelection target + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache)) + nextCandidates + else pure none + | .inr message => + runPermissiveFromTable state fuel table ((signer message).run cache) >>= + finishPermissiveDetailedPrivateOrdinalSelection + (continuePermissiveRootAvoidingDetailedOrdinalSelection target + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache)) + candidates) + computation candidates state fuel table cache + +noncomputable def permissiveActualRootAvoidingDetailedOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option PermissivePrivateOrdinalSelection) := + permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter target leftRoot rightRoot + (maskedSign parameter publicRoot ftsSecret) computation candidates state fuel table cache + +noncomputable def permissiveComparisonRootAvoidingDetailedOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftOutput rightOutput : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option PermissivePrivateOrdinalSelection) := + permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter target + (truncateHash leftOutput) (truncateHash rightOutput) + (maskedSignWithTargetComparison parameter publicRoot target (truncateHash rightOutput) + ftsSecret) + computation candidates state fuel table cache + +set_option maxRecDepth 100000 in +theorem permissiveRootAvoidingDetailedOrdinalSelection_swap_roots + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (signer : Message → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter target leftRoot rightRoot + signer computation candidates state fuel table cache = + permissiveRootAvoidingDetailedOrdinalSelection ordinal parameter target rightRoot leftRoot + signer computation candidates state fuel table cache := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => simp [permissiveRootAvoidingDetailedOrdinalSelection] + | query_bind query next ih => + rw [permissiveRootAvoidingDetailedOrdinalSelection, OracleComp.construct_query_bind, + permissiveRootAvoidingDetailedOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp [hselected] + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + apply bind_congr + intro result + cases result with + | none => rfl + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] + unfold continuePermissiveRootAvoidingDetailedOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ result.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact ih result.value.1 candidates result.state result.remaining + result.value.2 + | inr input => + let nextCandidates := permissiveRootAwareCandidates parameter input table state + candidates + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (permissiveRootAwareCandidates parameter input table state candidates).length := by + simpa [nextCandidates] using hnextSelected + simp [hactual] + · have hactual : ¬ordinal < + (permissiveRootAwareCandidates parameter input table state candidates).length := by + simpa [nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + have hsafe := rootAwareCandidateAvoidsRoots_swap target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) + rw [propext hsafe] + by_cases hholds : RootAwareCandidateAvoidsRoots target rightRoot leftRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) + · simp only [hholds, ↓reduceIte] + apply bind_congr + intro result + cases result with + | none => rfl + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] + unfold continuePermissiveRootAvoidingDetailedOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ result.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact ih result.value.1 nextCandidates result.state result.remaining + result.value.2 + · simp [hholds] + | inr message => + apply bind_congr + intro result + cases result with + | none => rfl + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] + unfold continuePermissiveRootAvoidingDetailedOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ result.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact ih result.value.1 candidates result.state result.remaining result.value.2 + +theorem evalDist_finishPermissiveSelection_eq_of_rootEncoding + (observeLeft observeRight : LazyRevealProbe.State Coordinate → Nat → α → + SplitHashCache → List Probe → ProbComp (Option PermissivePrivateOrdinalSelection)) + (candidates : List Probe) + (left right : Option (CleanRunResult (α × SplitHashCache))) + (hrel : RootEncodingPermissiveStoredRel parameter target leftRoot rightRoot left right) + (hnext : ∀ leftResult rightResult, + RootEncodingPermissiveStoredRel parameter target leftRoot rightRoot + (some leftResult) (some rightResult) → + evalDist (observeLeft leftResult.state leftResult.remaining leftResult.value.1 + leftResult.value.2 candidates) = + evalDist (observeRight rightResult.state rightResult.remaining rightResult.value.1 + rightResult.value.2 candidates)) : + evalDist (finishPermissiveDetailedPrivateOrdinalSelection observeLeft candidates left) = + evalDist (finishPermissiveDetailedPrivateOrdinalSelection observeRight candidates right) := by + cases left with + | none => + cases right with + | none => rfl + | some right => simp [RootEncodingPermissiveStoredRel] at hrel + | some left => + cases right with + | none => simp [RootEncodingPermissiveStoredRel] at hrel + | some right => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] + exact hnext left right hrel + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem evalDist_permissiveRootAvoidingDetailedOrdinalSelection_encoding + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target (truncateHash leftOutput) + (truncateHash rightOutput) leftCache rightCache) + (hstored : StoredLayerRoot state target (truncateHash leftOutput)) : + evalDist + (permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot target + (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret computation candidates + state fuel table leftCache) = + evalDist + (permissiveComparisonRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot + target leftOutput rightOutput ftsSecret computation candidates state fuel table + rightCache) := by + induction computation using OracleComp.inductionOn generalizing + candidates state fuel leftCache rightCache with + | pure value => + simp [permissiveActualRootAvoidingDetailedOrdinalSelection, + permissiveComparisonRootAvoidingDetailedOrdinalSelection, + permissiveRootAvoidingDetailedOrdinalSelection] + | query_bind query next ih => + unfold permissiveActualRootAvoidingDetailedOrdinalSelection + permissiveComparisonRootAvoidingDetailedOrdinalSelection + rw [permissiveRootAvoidingDetailedOrdinalSelection, OracleComp.construct_query_bind, + permissiveRootAvoidingDetailedOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp [hselected] + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let leftObserve := continuePermissiveRootAvoidingDetailedOrdinalSelection target + fun nextState remaining value nextCache laterCandidates => + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter + publicRoot target (truncateHash leftOutput) (truncateHash rightOutput) + ftsSecret (next value) laterCandidates nextState remaining table nextCache + let rightObserve := continuePermissiveRootAvoidingDetailedOrdinalSelection target + fun nextState remaining value nextCache laterCandidates => + permissiveComparisonRootAvoidingDetailedOrdinalSelection ordinal parameter + publicRoot target leftOutput rightOutput ftsSecret (next value) + laterCandidates nextState remaining table nextCache + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + ((rootEncodingPermissiveCouples_splitUniformImpl parameter target + (truncateHash leftOutput) (truncateHash rightOutput) n).toStored + leftCache rightCache hcache state fuel table hstored) + intro leftResult rightResult hresult + apply evalDist_finishPermissiveSelection_eq_of_rootEncoding leftObserve + rightObserve candidates leftResult rightResult hresult + intro nextLeft nextRight hnext + rcases hnext with ⟨⟨hstate, hremaining, htable, hvalue, hnextCache⟩, + hnextStored⟩ + rw [← hstate, ← hremaining, ← hvalue] + simp only [leftObserve, rightObserve] + unfold continuePermissiveRootAvoidingDetailedOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ nextLeft.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact ih nextLeft.value.1 candidates nextLeft.state nextLeft.remaining + nextLeft.value.2 nextRight.value.2 hnextCache hnextStored + | inr input => + let nextCandidates := permissiveRootAwareCandidates parameter input table state + candidates + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (permissiveRootAwareCandidates parameter input table state candidates).length := by + simpa [nextCandidates] using hnextSelected + simp [hactual] + · have hactual : ¬ordinal < + (permissiveRootAwareCandidates parameter input table state candidates).length := by + simpa [nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + by_cases hsafe : RootAwareCandidateAvoidsRoots target + (truncateHash leftOutput) (truncateHash rightOutput) candidate? + · have hsafeActual : RootAwareCandidateAvoidsRoots target + (truncateHash leftOutput) (truncateHash rightOutput) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + have hinput : RootInputAvoids parameter target + (truncateHash leftOutput) (truncateHash rightOutput) input := by + apply rootInputAvoids_of_rootAwareCandidateAvoidsRoots + simpa [rootAwareCandidateForPlan?_purePlan] using hsafeActual + let leftObserve := + continuePermissiveRootAvoidingDetailedOrdinalSelection target + fun nextState remaining value nextCache laterCandidates => + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter + publicRoot target (truncateHash leftOutput) (truncateHash rightOutput) + ftsSecret (next value) laterCandidates nextState remaining table + nextCache + let rightObserve := + continuePermissiveRootAvoidingDetailedOrdinalSelection target + fun nextState remaining value nextCache laterCandidates => + permissiveComparisonRootAvoidingDetailedOrdinalSelection ordinal + parameter publicRoot target leftOutput rightOutput ftsSecret + (next value) laterCandidates nextState remaining table nextCache + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + ((rootEncodingPermissiveCouples_probingHashQueryAfterPublicPlan_avoids + parameter target (truncateHash leftOutput) (truncateHash rightOutput) + input publicContext.state plan hinput).toStored leftCache rightCache hcache + state fuel table hstored) + intro leftResult rightResult hresult + apply evalDist_finishPermissiveSelection_eq_of_rootEncoding leftObserve + rightObserve nextCandidates leftResult rightResult hresult + intro nextLeft nextRight hnext + rcases hnext with + ⟨⟨hstate, hremaining, htable, hvalue, hnextCache⟩, hnextStored⟩ + rw [← hstate, ← hremaining, ← hvalue] + simp only [leftObserve, rightObserve] + unfold continuePermissiveRootAvoidingDetailedOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ nextLeft.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact ih nextLeft.value.1 nextCandidates nextLeft.state nextLeft.remaining + nextLeft.value.2 nextRight.value.2 hnextCache hnextStored + · have hsafeActual : ¬RootAwareCandidateAvoidsRoots target + (truncateHash leftOutput) (truncateHash rightOutput) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp [hsafeActual] + | inr message => + let leftObserve := continuePermissiveRootAvoidingDetailedOrdinalSelection target + fun nextState remaining value nextCache laterCandidates => + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot + target (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret + (next value) laterCandidates nextState remaining table nextCache + let rightObserve := continuePermissiveRootAvoidingDetailedOrdinalSelection target + fun nextState remaining value nextCache laterCandidates => + permissiveComparisonRootAvoidingDetailedOrdinalSelection ordinal parameter + publicRoot target leftOutput rightOutput ftsSecret (next value) laterCandidates + nextState remaining table nextCache + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (rootEncodingPermissiveRelatesStored_maskedSign_targetComparison parameter + publicRoot target hroot (truncateHash leftOutput) (truncateHash rightOutput) + ftsSecret message leftCache rightCache hcache state fuel table hstored) + intro leftResult rightResult hresult + apply evalDist_finishPermissiveSelection_eq_of_rootEncoding leftObserve rightObserve + candidates leftResult rightResult hresult + intro nextLeft nextRight hnext + rcases hnext with ⟨⟨hstate, hremaining, htable, hvalue, hnextCache⟩, + hnextStored⟩ + rw [← hstate, ← hremaining, ← hvalue] + simp only [leftObserve, rightObserve] + unfold continuePermissiveRootAvoidingDetailedOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ nextLeft.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact ih nextLeft.value.1 candidates nextLeft.state nextLeft.remaining + nextLeft.value.2 nextRight.value.2 hnextCache hnextStored + +def RootHiddenPermissiveSelectionRel + (target : Position) (leftOutput rightOutput : HashOutput) : + Option PermissivePrivateOrdinalSelection → + Option PermissivePrivateOrdinalSelection → Prop + | none, none => True + | some left, some right => + left.candidate = right.candidate ∧ left.candidates = right.candidates ∧ + RootHiddenStateRel target leftOutput rightOutput left.state right.state + | _, _ => False + +theorem relTriple_finishPermissiveSelection_of_rootHidden + (target : Position) (leftOutput rightOutput : HashOutput) + (observeLeft observeRight : LazyRevealProbe.State Coordinate → Nat → α → + SplitHashCache → List Probe → ProbComp (Option PermissivePrivateOrdinalSelection)) + (candidates : List Probe) + (left right : Option (CleanRunResult (α × SplitHashCache))) + (hrel : RootHiddenCleanRelWith target leftOutput rightOutput (fun x y => x = y) left right) + (hnext : ∀ leftResult rightResult, + RootHiddenCleanRelWith target leftOutput rightOutput (fun x y => x = y) + (some leftResult) (some rightResult) → + RelTriple + (observeLeft leftResult.state leftResult.remaining leftResult.value.1 + leftResult.value.2 candidates) + (observeRight rightResult.state rightResult.remaining rightResult.value.1 + rightResult.value.2 candidates) + (RootHiddenPermissiveSelectionRel target leftOutput rightOutput)) : + RelTriple + (finishPermissiveDetailedPrivateOrdinalSelection observeLeft candidates left) + (finishPermissiveDetailedPrivateOrdinalSelection observeRight candidates right) + (RootHiddenPermissiveSelectionRel target leftOutput rightOutput) := by + cases left with + | none => + cases right with + | none => exact relTriple_pure_pure trivial + | some right => simp [RootHiddenCleanRelWith] at hrel + | some left => + cases right with + | none => simp [RootHiddenCleanRelWith] at hrel + | some right => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] + exact hnext left right hrel + +theorem runPermissiveFromTable_publishOrdinaryInput + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (input : HashInput) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) (cache : SplitHashCache) : + runPermissiveFromTable state fuel table + ((publishOrdinaryInput coordinate input output).run cache) = + pure (some + { state := state.publish coordinate + remaining := fuel + value := (output, Function.update cache (.ordinary input) (some output)) + table := table }) := by + unfold publishOrdinaryInput + rw [StateT.run_bind, runPermissiveFromTable_bind] + unfold publishCoordinate LazyRevealProbe.publishQuery + rw [StateT.run_liftM, runPermissiveFromTable_publish_query_bind] + simp [StateT.run_modify, runPermissiveFromTable] + +theorem runPermissiveFromTable_revealPublishOrdinaryInput_of_value + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (input : HashInput) (state : LazyRevealProbe.State Coordinate) + (fuel : Nat) (cache : SplitHashCache) (output : HashOutput) + (hvalue : state.values coordinate = some output) : + runPermissiveFromTable state fuel table + ((revealPublishOrdinaryInput coordinate input).run cache) = + pure (some + { state := state.publish coordinate + remaining := fuel + value := (output, Function.update + (Function.update cache (.hidden coordinate) (some output)) + (.ordinary input) (some output)) + table := table }) := by + unfold revealPublishOrdinaryInput + rw [StateT.run_bind, runPermissiveFromTable_bind, revealCoordinateOutput_run_eq, + LazyRevealProbe.revealQuery, runPermissiveFromTable_reveal_query_bind, hvalue] + simp only [runPermissiveFromTable, OracleComp.construct_pure, pure_bind] + change runPermissiveFromTable state fuel table + ((publishOrdinaryInput coordinate input output).run + (Function.update cache (.hidden coordinate) (some output))) = _ + exact runPermissiveFromTable_publishOrdinaryInput table coordinate input output state fuel + (Function.update cache (.hidden coordinate) (some output)) + +set_option maxRecDepth 100000 in +theorem relTriple_targetPublicResolve_then_finishPermissive + (parameter : PublicParameter) (target : Position) + (leftOutput rightOutput : HashOutput) + (publicState : LazyRevealProbe.State Coordinate) (input : HashInput) + (leftState rightState : LazyRevealProbe.State Coordinate) + (hstate : RootHiddenStateRel target leftOutput rightOutput leftState rightState) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache) + (leftObserve rightObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option PermissivePrivateOrdinalSelection)) + (candidates : List Probe) + (hrecursive : ∀ leftResult rightResult, + RootHiddenCleanRelWith target leftOutput rightOutput (fun x y => x = y) + (some leftResult) (some rightResult) → + RelTriple + (continuePermissiveRootAvoidingDetailedOrdinalSelection target leftObserve + leftResult.state leftResult.remaining leftResult.value.1 leftResult.value.2 candidates) + (continuePermissiveRootAvoidingDetailedOrdinalSelection target rightObserve + rightResult.state rightResult.remaining rightResult.value.1 rightResult.value.2 + candidates) + (RootHiddenPermissiveSelectionRel target leftOutput rightOutput)) : + RelTriple + (runPermissiveFromTable leftState fuel table + ((resolvePublicKnownInput parameter publicState (.position target) input).run + leftCache) >>= + finishPermissiveDetailedPrivateOrdinalSelection + (continuePermissiveRootAvoidingDetailedOrdinalSelection target leftObserve) candidates) + (runPermissiveFromTable rightState fuel table + ((resolvePublicKnownInput parameter publicState (.position target) input).run + rightCache) >>= + finishPermissiveDetailedPrivateOrdinalSelection + (continuePermissiveRootAvoidingDetailedOrdinalSelection target rightObserve) candidates) + (RootHiddenPermissiveSelectionRel target leftOutput rightOutput) := by + unfold resolvePublicKnownInput + cases hknown : purePeekTableInput parameter publicState (.position target) with + | none => + apply relTriple_bind + (rootHiddenPermissiveRelates_splitHashQuery_ordinary target leftOutput rightOutput input + leftState rightState hstate fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + exact relTriple_finishPermissiveSelection_of_rootHidden target leftOutput rightOutput _ _ + candidates leftResult rightResult hresult hrecursive + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + change RelTriple + (runPermissiveFromTable leftState fuel table + ((revealPublishOrdinaryInput (.position target) input).run leftCache) >>= + finishPermissiveDetailedPrivateOrdinalSelection + (continuePermissiveRootAvoidingDetailedOrdinalSelection target leftObserve) + candidates) + (runPermissiveFromTable rightState fuel table + ((revealPublishOrdinaryInput (.position target) input).run rightCache) >>= + finishPermissiveDetailedPrivateOrdinalSelection + (continuePermissiveRootAvoidingDetailedOrdinalSelection target rightObserve) + candidates) + (RootHiddenPermissiveSelectionRel target leftOutput rightOutput) + rw [runPermissiveFromTable_revealPublishOrdinaryInput_of_value table + (.position target) input leftState fuel leftCache leftOutput hstate.left_target, + runPermissiveFromTable_revealPublishOrdinaryInput_of_value table + (.position target) input rightState fuel rightCache rightOutput hstate.right_target] + simp [finishPermissiveDetailedPrivateOrdinalSelection, + continuePermissiveRootAvoidingDetailedOrdinalSelection, + LazyRevealProbe.State.publish, RootHiddenPermissiveSelectionRel] + · simp only [heq, ↓reduceIte] + apply relTriple_bind + (rootHiddenPermissiveRelates_splitHashQuery_ordinary target leftOutput rightOutput input + leftState rightState hstate fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + exact relTriple_finishPermissiveSelection_of_rootHidden target leftOutput rightOutput _ _ + candidates leftResult rightResult hresult hrecursive + +set_option maxRecDepth 100000 in +theorem relTriple_targetPublicPlan_then_finishPermissive + (parameter : PublicParameter) (target : Position) + (leftOutput rightOutput : HashOutput) + (publicState : LazyRevealProbe.State Coordinate) (input : HashInput) + (plan : PlannedHashQuery) (haction : plan.action = .resolve (.position target)) + (leftState rightState : LazyRevealProbe.State Coordinate) + (hstate : RootHiddenStateRel target leftOutput rightOutput leftState rightState) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache) + (leftObserve rightObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option PermissivePrivateOrdinalSelection)) + (candidates : List Probe) + (hrecursive : ∀ leftResult rightResult, + RootHiddenCleanRelWith target leftOutput rightOutput (fun x y => x = y) + (some leftResult) (some rightResult) → + RelTriple + (continuePermissiveRootAvoidingDetailedOrdinalSelection target leftObserve + leftResult.state leftResult.remaining leftResult.value.1 leftResult.value.2 candidates) + (continuePermissiveRootAvoidingDetailedOrdinalSelection target rightObserve + rightResult.state rightResult.remaining rightResult.value.1 rightResult.value.2 + candidates) + (RootHiddenPermissiveSelectionRel target leftOutput rightOutput)) : + RelTriple + (runPermissiveFromTable leftState fuel table + ((probingHashQueryAfterPublicPlan parameter input publicState plan).run leftCache) >>= + finishPermissiveDetailedPrivateOrdinalSelection + (continuePermissiveRootAvoidingDetailedOrdinalSelection target leftObserve) candidates) + (runPermissiveFromTable rightState fuel table + ((probingHashQueryAfterPublicPlan parameter input publicState plan).run rightCache) >>= + finishPermissiveDetailedPrivateOrdinalSelection + (continuePermissiveRootAvoidingDetailedOrdinalSelection target rightObserve) candidates) + (RootHiddenPermissiveSelectionRel target leftOutput rightOutput) := by + unfold probingHashQueryAfterPublicPlan + rw [haction, StateT.run_bind, StateT.run_bind, + runPermissiveFromTable_bind, runPermissiveFromTable_bind] + simp only [bind_assoc] + apply relTriple_bind + (rootHiddenPermissiveRelates_executeCandidate target leftOutput rightOutput plan.candidate? + leftState rightState hstate fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some right => simp [RootHiddenCleanRelWith] at hresult + | some left => + cases rightResult with + | none => simp [RootHiddenCleanRelWith] at hresult + | some right => + rcases hresult with ⟨hnextState, hremaining, htable, _hvalue, hnextCache⟩ + simp only + rw [← hremaining, ← htable] + exact relTriple_targetPublicResolve_then_finishPermissive parameter target leftOutput + rightOutput publicState input left.state right.state hnextState left.remaining left.table + left.value.2 right.value.2 hnextCache leftObserve rightObserve candidates hrecursive + +set_option maxRecDepth 100000 in +theorem relTriple_permissiveRootAvoiding_hash_hidden + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftOutput rightOutput : HashOutput) (input : HashInput) + (candidates : List Probe) + (leftState rightState : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hstate : RootHiddenStateRel target leftOutput rightOutput leftState rightState) + (hcache : RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache) + (leftObserve rightObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option PermissivePrivateOrdinalSelection)) + (hrecursive : ∀ leftResult rightResult, + RootHiddenCleanRelWith target leftOutput rightOutput (fun x y => x = y) + (some leftResult) (some rightResult) → + RelTriple + (continuePermissiveRootAvoidingDetailedOrdinalSelection target leftObserve + leftResult.state leftResult.remaining leftResult.value.1 leftResult.value.2 + (permissiveRootAwareCandidates parameter input table leftState candidates)) + (continuePermissiveRootAvoidingDetailedOrdinalSelection target rightObserve + rightResult.state rightResult.remaining rightResult.value.1 rightResult.value.2 + (permissiveRootAwareCandidates parameter input table rightState candidates)) + (RootHiddenPermissiveSelectionRel target leftOutput rightOutput)) : + RelTriple + (if hselected : ordinal < + (permissiveRootAwareCandidates parameter input table leftState candidates).length then + pure (some + ⟨(permissiveRootAwareCandidates parameter input table leftState candidates).get + ⟨ordinal, hselected⟩, leftState, + permissiveRootAwareCandidates parameter input table leftState candidates⟩) + else + let publicContext := materializedCanonicalContext table leftState + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + if RootAwareCandidateAvoidsRoots target (truncateHash leftOutput) + (truncateHash rightOutput) candidate? then + runPermissiveFromTable leftState fuel table + (delayedPermissivePublicAction parameter input table leftState leftCache) >>= + finishPermissiveDetailedPrivateOrdinalSelection + (continuePermissiveRootAvoidingDetailedOrdinalSelection target leftObserve) + (permissiveRootAwareCandidates parameter input table leftState candidates) + else pure none) + (if hselected : ordinal < + (permissiveRootAwareCandidates parameter input table rightState candidates).length then + pure (some + ⟨(permissiveRootAwareCandidates parameter input table rightState candidates).get + ⟨ordinal, hselected⟩, rightState, + permissiveRootAwareCandidates parameter input table rightState candidates⟩) + else + let publicContext := materializedCanonicalContext table rightState + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + if RootAwareCandidateAvoidsRoots target (truncateHash leftOutput) + (truncateHash rightOutput) candidate? then + runPermissiveFromTable rightState fuel table + (delayedPermissivePublicAction parameter input table rightState rightCache) >>= + finishPermissiveDetailedPrivateOrdinalSelection + (continuePermissiveRootAvoidingDetailedOrdinalSelection target rightObserve) + (permissiveRootAwareCandidates parameter input table rightState candidates) + else pure none) + (RootHiddenPermissiveSelectionRel target leftOutput rightOutput) := by + have hpublic := materializedCanonicalContext_state_eq_of_rootHidden hstate table + have hcandidates : + permissiveRootAwareCandidates parameter input table leftState candidates = + permissiveRootAwareCandidates parameter input table rightState candidates := by + unfold permissiveRootAwareCandidates permissiveRootAwarePlan + rw [hpublic] + by_cases hselected : ordinal < + (permissiveRootAwareCandidates parameter input table leftState candidates).length + · have hselectedRight : ordinal < + (permissiveRootAwareCandidates parameter input table rightState candidates).length := by + rw [← hcandidates] + exact hselected + simp only [hselected, hselectedRight, ↓reduceDIte] + apply relTriple_pure_pure + simp [RootHiddenPermissiveSelectionRel, hcandidates, hstate] + · have hselectedRight : ¬ordinal < + (permissiveRootAwareCandidates parameter input table rightState candidates).length := by + rw [← hcandidates] + exact hselected + simp only [hselected, hselectedRight, ↓reduceDIte] + have hcandidate : + rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table leftState).state) = + rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table rightState).state) := by + rw [hpublic] + by_cases hsafe : RootAwareCandidateAvoidsRoots target (truncateHash leftOutput) + (truncateHash rightOutput) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table leftState).state)) + · have hsafeRight : RootAwareCandidateAvoidsRoots target (truncateHash leftOutput) + (truncateHash rightOutput) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table rightState).state)) := by + rw [← hcandidate] + exact hsafe + simp only [hsafe, hsafeRight, ↓reduceIte] + let publicState := (materializedCanonicalContext table leftState).state + let plan := purePlanProbingHashQuery parameter input publicState + have hleftAction : + delayedPermissivePublicAction parameter input table leftState leftCache = + (probingHashQueryAfterPublicPlan parameter input publicState plan).run leftCache := by + rfl + have hrightAction : + delayedPermissivePublicAction parameter input table rightState rightCache = + (probingHashQueryAfterPublicPlan parameter input publicState plan).run rightCache := by + unfold delayedPermissivePublicAction + dsimp only + rw [← hpublic] + rw [hleftAction, hrightAction, ← hcandidates] + letI : Decidable (plan.action = PlannedHashAction.resolve (.position target)) := + Classical.propDecidable _ + by_cases haction : plan.action = .resolve (.position target) + · exact relTriple_targetPublicPlan_then_finishPermissive parameter target leftOutput + rightOutput publicState input plan haction leftState rightState hstate fuel table leftCache + rightCache hcache leftObserve rightObserve + (permissiveRootAwareCandidates parameter input table leftState candidates) + (by simpa [hcandidates] using hrecursive) + · apply relTriple_bind + (rootHiddenPermissiveRelates_probingHashQueryAfterPublicPlan parameter target leftOutput + rightOutput input publicState plan haction leftState rightState hstate fuel table + leftCache rightCache hcache) + intro leftResult rightResult hresult + apply relTriple_finishPermissiveSelection_of_rootHidden target leftOutput rightOutput _ _ + (permissiveRootAwareCandidates parameter input table leftState candidates) + leftResult rightResult hresult + simpa [hcandidates] using hrecursive + · have hsafeRight : ¬RootAwareCandidateAvoidsRoots target (truncateHash leftOutput) + (truncateHash rightOutput) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table rightState).state)) := by + rw [← hcandidate] + exact hsafe + simp [hsafe, hsafeRight, RootHiddenPermissiveSelectionRel] + +set_option maxHeartbeats 100000 in +set_option maxRecDepth 100000 in +theorem relTriple_permissiveRootAvoidingDetailedOrdinalSelection_hidden + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) + (leftState rightState : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hstate : RootHiddenStateRel target leftOutput rightOutput leftState rightState) + (hcache : RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache) : + RelTriple + (permissiveComparisonRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot + target leftOutput rightOutput ftsSecret computation candidates leftState fuel table + leftCache) + (permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot target + (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret computation candidates + rightState fuel table rightCache) + (RootHiddenPermissiveSelectionRel target leftOutput rightOutput) := by + classical + induction computation using OracleComp.inductionOn generalizing + candidates leftState rightState fuel leftCache rightCache with + | pure value => + simp only [permissiveComparisonRootAvoidingDetailedOrdinalSelection, + permissiveActualRootAvoidingDetailedOrdinalSelection, + permissiveRootAvoidingDetailedOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure ⟨rfl, rfl, hstate⟩ + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure trivial + | query_bind query next ih => + unfold permissiveComparisonRootAvoidingDetailedOrdinalSelection + permissiveActualRootAvoidingDetailedOrdinalSelection + rw [permissiveRootAvoidingDetailedOrdinalSelection, OracleComp.construct_query_bind, + permissiveRootAvoidingDetailedOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure ⟨rfl, rfl, hstate⟩ + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let leftObserve := + fun nextState remaining value nextCache laterCandidates => + permissiveComparisonRootAvoidingDetailedOrdinalSelection ordinal parameter + publicRoot target leftOutput rightOutput ftsSecret (next value) + laterCandidates nextState remaining table nextCache + let rightObserve := + fun nextState remaining value nextCache laterCandidates => + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter + publicRoot target (truncateHash leftOutput) (truncateHash rightOutput) + ftsSecret (next value) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (rootHiddenPermissiveRelates_splitUniformImpl target leftOutput rightOutput n + leftState rightState hstate fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + apply relTriple_finishPermissiveSelection_of_rootHidden target leftOutput + rightOutput _ _ candidates leftResult rightResult hresult + intro nextLeft nextRight hnext + rcases hnext with ⟨hnextState, hremaining, htable, hvalue, hnextCache⟩ + rw [← hremaining, ← hvalue] + simp only [leftObserve, rightObserve] + unfold continuePermissiveRootAvoidingDetailedOrdinalSelection + have hreveal := hnextState.revealed + by_cases hrevealed : Coordinate.position target ∈ nextLeft.state.revealed + · have hrightRevealed : + Coordinate.position target ∈ nextRight.state.revealed := by + rwa [← hreveal] + simp [hrevealed, hrightRevealed, RootHiddenPermissiveSelectionRel] + · have hrightRevealed : + Coordinate.position target ∉ nextRight.state.revealed := by + intro hmem + exact hrevealed (by rwa [hreveal]) + simp only [hrevealed, hrightRevealed, ↓reduceIte] + exact ih nextLeft.value.1 candidates nextLeft.state nextRight.state + nextLeft.remaining nextLeft.value.2 nextRight.value.2 hnextState hnextCache + | inr input => + let leftObserve := + fun nextState remaining value nextCache laterCandidates => + permissiveComparisonRootAvoidingDetailedOrdinalSelection ordinal parameter + publicRoot target leftOutput rightOutput ftsSecret (next value) + laterCandidates nextState remaining table nextCache + let rightObserve := + fun nextState remaining value nextCache laterCandidates => + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter + publicRoot target (truncateHash leftOutput) (truncateHash rightOutput) + ftsSecret (next value) laterCandidates nextState remaining table nextCache + apply relTriple_permissiveRootAvoiding_hash_hidden ordinal parameter target + leftOutput rightOutput input candidates leftState rightState fuel table leftCache + rightCache hstate hcache leftObserve rightObserve + intro nextLeft nextRight hnext + rcases hnext with ⟨hnextState, hremaining, _htable, hvalue, hnextCache⟩ + rw [← hremaining, ← hvalue] + simp only [leftObserve, rightObserve] + unfold continuePermissiveRootAvoidingDetailedOrdinalSelection + have hcandidates : + permissiveRootAwareCandidates parameter input table leftState candidates = + permissiveRootAwareCandidates parameter input table rightState candidates := by + unfold permissiveRootAwareCandidates permissiveRootAwarePlan + rw [materializedCanonicalContext_state_eq_of_rootHidden hstate table] + rw [← hcandidates] + have hreveal := hnextState.revealed + by_cases hrevealed : Coordinate.position target ∈ nextLeft.state.revealed + · have hrightRevealed : + Coordinate.position target ∈ nextRight.state.revealed := by + rwa [← hreveal] + simp [hrevealed, hrightRevealed, RootHiddenPermissiveSelectionRel] + · have hrightRevealed : + Coordinate.position target ∉ nextRight.state.revealed := by + intro hmem + exact hrevealed (by rwa [hreveal]) + simp only [hrevealed, hrightRevealed, ↓reduceIte] + exact ih nextLeft.value.1 + (permissiveRootAwareCandidates parameter input table leftState candidates) + nextLeft.state nextRight.state nextLeft.remaining nextLeft.value.2 + nextRight.value.2 hnextState hnextCache + | inr message => + let leftObserve := + fun nextState remaining value nextCache laterCandidates => + permissiveComparisonRootAvoidingDetailedOrdinalSelection ordinal parameter + publicRoot target leftOutput rightOutput ftsSecret (next value) laterCandidates + nextState remaining table nextCache + let rightObserve := + fun nextState remaining value nextCache laterCandidates => + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot + target (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret + (next value) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (rootHiddenPermissiveRelates_maskedSignWithTargetComparison_actual parameter + publicRoot ftsSecret target hroot leftOutput rightOutput message leftState rightState + hstate fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + apply relTriple_finishPermissiveSelection_of_rootHidden target leftOutput rightOutput + _ _ candidates leftResult rightResult hresult + intro nextLeft nextRight hnext + rcases hnext with ⟨hnextState, hremaining, _htable, hvalue, hnextCache⟩ + rw [← hremaining, ← hvalue] + simp only [leftObserve, rightObserve] + unfold continuePermissiveRootAvoidingDetailedOrdinalSelection + have hreveal := hnextState.revealed + by_cases hrevealed : Coordinate.position target ∈ nextLeft.state.revealed + · have hrightRevealed : + Coordinate.position target ∈ nextRight.state.revealed := by + rwa [← hreveal] + simp [hrevealed, hrightRevealed, RootHiddenPermissiveSelectionRel] + · have hrightRevealed : + Coordinate.position target ∉ nextRight.state.revealed := by + intro hmem + exact hrevealed (by rwa [hreveal]) + simp only [hrevealed, hrightRevealed, ↓reduceIte] + exact ih nextLeft.value.1 candidates nextLeft.state nextRight.state + nextLeft.remaining nextLeft.value.2 nextRight.value.2 hnextState hnextCache + +theorem RootHiddenPermissiveSelectionRel.erase + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : Option PermissivePrivateOrdinalSelection} + (hrel : RootHiddenPermissiveSelectionRel target leftOutput rightOutput left right) : + erasePermissivePrivateOrdinalSelection left = + erasePermissivePrivateOrdinalSelection right := by + cases left with + | none => + cases right with + | none => rfl + | some right => simp [RootHiddenPermissiveSelectionRel] at hrel + | some left => + cases right with + | none => simp [RootHiddenPermissiveSelectionRel] at hrel + | some right => + simp only [RootHiddenPermissiveSelectionRel] at hrel + simp [erasePermissivePrivateOrdinalSelection, hrel.1] + +theorem evalDist_map_erase_permissiveRootAvoidingDetailedOrdinalSelection_hidden + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) + (leftState rightState : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hstate : RootHiddenStateRel target leftOutput rightOutput leftState rightState) + (hcache : RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache) : + evalDist + (erasePermissivePrivateOrdinalSelection <$> + permissiveComparisonRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot + target leftOutput rightOutput ftsSecret computation candidates leftState fuel table + leftCache) = + evalDist + (erasePermissivePrivateOrdinalSelection <$> + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot target + (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret computation candidates + rightState fuel table rightCache) := by + have hrel := relTriple_permissiveRootAvoidingDetailedOrdinalSelection_hidden ordinal parameter + publicRoot target hroot leftOutput rightOutput ftsSecret computation candidates leftState + rightState fuel table leftCache rightCache hstate hcache + have hprojected := relTriple_post_mono hrel fun left right relation => relation.erase + have hmapped : RelTriple + (erasePermissivePrivateOrdinalSelection <$> + permissiveComparisonRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot + target leftOutput rightOutput ftsSecret computation candidates leftState fuel table + leftCache) + (erasePermissivePrivateOrdinalSelection <$> + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot target + (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret computation candidates + rightState fuel table rightCache) + (fun left right => left = right) := relTriple_map hprojected + exact evalDist_eq_of_relTriple_eqRel hmapped + +theorem rootHiddenStateRel_preloadPositionValue + (target : Position) (leftOutput rightOutput : HashOutput) + (state : LazyRevealProbe.State Coordinate) + (hprivate : Coordinate.position target ∉ state.revealed) : + RootHiddenStateRel target leftOutput rightOutput + (preloadPositionValue target leftOutput state) + (preloadPositionValue target rightOutput state) := by + refine ⟨rfl, rfl, rfl, hprivate, ?_, ?_, ?_⟩ + · simp + · simp + · intro coordinate hne + rw [preloadPositionValue_values_of_ne target leftOutput state coordinate hne, + preloadPositionValue_values_of_ne target rightOutput state coordinate hne] + +set_option maxRecDepth 100000 in +theorem evalDist_map_erase_permissiveRootAvoidingDetailedOrdinalSelection_fullSwap + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) + (hprivate : Coordinate.position target ∉ state.revealed) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) + (hcache : cache (.hidden (.position target)) = some leftOutput) : + evalDist + (erasePermissivePrivateOrdinalSelection <$> + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot target + (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret computation candidates + (preloadPositionValue target leftOutput state) fuel table cache) = + evalDist + (erasePermissivePrivateOrdinalSelection <$> + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot target + (truncateHash rightOutput) (truncateHash leftOutput) ftsSecret computation candidates + (preloadPositionValue target rightOutput state) fuel table + (fullSwapRootCache parameter target (truncateHash leftOutput) + (truncateHash rightOutput) rightOutput cache)) := by + let middleCache := swapCanonicalRootEncodingCache parameter target + (truncateHash leftOutput) (truncateHash rightOutput) cache + let rightCache := fullSwapRootCache parameter target (truncateHash leftOutput) + (truncateHash rightOutput) rightOutput cache + have hstored : StoredLayerRoot (preloadPositionValue target leftOutput state) target + (truncateHash leftOutput) := ⟨leftOutput, by simp, rfl⟩ + have hencoding := rootEncodingCacheRel_swapCanonical parameter target + (truncateHash leftOutput) (truncateHash rightOutput) cache + have hab := evalDist_permissiveRootAvoidingDetailedOrdinalSelection_encoding ordinal parameter + publicRoot target hroot leftOutput rightOutput ftsSecret computation candidates + (preloadPositionValue target leftOutput state) fuel table cache middleCache hencoding hstored + have habMapped : + evalDist + (erasePermissivePrivateOrdinalSelection <$> + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot target + (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret computation candidates + (preloadPositionValue target leftOutput state) fuel table cache) = + evalDist + (erasePermissivePrivateOrdinalSelection <$> + permissiveComparisonRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot + target leftOutput rightOutput ftsSecret computation candidates + (preloadPositionValue target leftOutput state) fuel table middleCache) := by + rw [evalDist_map, evalDist_map, hab] + have hstate := rootHiddenStateRel_preloadPositionValue target leftOutput rightOutput state hprivate + have hhidden : RootHiddenCacheRel target leftOutput rightOutput middleCache rightCache := by + exact rootHiddenCacheRel_fullSwapRootCache parameter target leftOutput rightOutput cache hcache + have hbc := + evalDist_map_erase_permissiveRootAvoidingDetailedOrdinalSelection_hidden ordinal parameter + publicRoot target hroot leftOutput rightOutput ftsSecret computation candidates + (preloadPositionValue target leftOutput state) + (preloadPositionValue target rightOutput state) fuel table middleCache rightCache hstate hhidden + calc + _ = evalDist + (erasePermissivePrivateOrdinalSelection <$> + permissiveComparisonRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot + target leftOutput rightOutput ftsSecret computation candidates + (preloadPositionValue target leftOutput state) fuel table middleCache) := habMapped + _ = evalDist + (erasePermissivePrivateOrdinalSelection <$> + permissiveActualRootAvoidingDetailedOrdinalSelection ordinal parameter publicRoot target + (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret computation candidates + (preloadPositionValue target rightOutput state) fuel table rightCache) := hbc + _ = _ := by + exact congrArg evalDist (congrArg (Functor.map erasePermissivePrivateOrdinalSelection) + (permissiveRootAvoidingDetailedOrdinalSelection_swap_roots ordinal parameter target + (truncateHash leftOutput) (truncateHash rightOutput) + (maskedSign parameter publicRoot ftsSecret) computation candidates + (preloadPositionValue target rightOutput state) fuel table rightCache)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedSelectionSampling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedSelectionSampling.lean new file mode 100644 index 00000000..58d6832a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedSelectionSampling.lean @@ -0,0 +1,1162 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedSelector +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonSelectionSampling +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonization + +/-! +# Delayed selector target preloading + +Sampling one hidden structural value before the delayed permissive selector does not increase the +selector's fiber at that position. This is the target-independent step that removes the fixed +position after the fresh-output charge has been exposed. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option linter.constructorNameAsVariable false + +theorem revealed_subset_of_mem_delayedPermissiveDetailedOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (selection : PermissivePrivateOrdinalSelection) + (hselection : some selection ∈ support + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache)) : + state.revealed ⊆ selection.state.revealed := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + simp only [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_pure] at hselection + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] at hselection + simp at hselection + subst selection + exact Finset.Subset.rfl + · simp [hselected] at hselection + | query_bind query next ih => + rw [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_query_bind] at hselection + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] at hselection + simp at hselection + subst selection + exact Finset.Subset.rfl + · simp only [hselected, ↓reduceDIte] at hselection + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hselection + obtain ⟨result, hresult, htail⟩ := hselection + cases result with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] at htail + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] at htail + exact (revealed_subset_of_mem_runPermissiveFromTable + ((splitUniformImpl n).run cache) state fuel table result hresult).trans + (ih result.value.1 candidates result.state result.remaining result.value.2 + htail) + | inr input => + let nextCandidates := + permissiveRootAwareCandidates parameter input table state candidates + by_cases hnextSelected : ordinal < nextCandidates.length + · simp only [nextCandidates, hnextSelected, ↓reduceDIte] at hselection + simp at hselection + subst selection + exact Finset.Subset.rfl + · simp only [nextCandidates, hnextSelected, ↓reduceDIte] at hselection + rw [mem_support_bind_iff] at hselection + obtain ⟨result, hresult, htail⟩ := hselection + cases result with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] at htail + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] at htail + exact (revealed_subset_of_mem_runPermissiveFromTable + (delayedPermissivePublicAction parameter input table state cache) + state fuel table result hresult).trans + (ih result.value.1 nextCandidates result.state result.remaining + result.value.2 htail) + | inr message => + rw [mem_support_bind_iff] at hselection + obtain ⟨result, hresult, htail⟩ := hselection + cases result with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] at htail + | some result => + simp only [finishPermissiveDetailedPrivateOrdinalSelection] at htail + exact (revealed_subset_of_mem_runPermissiveFromTable + ((maskedSign parameter root ftsSecret message).run cache) + state fuel table result hresult).trans + (ih result.value.1 candidates result.state result.remaining result.value.2 htail) + +theorem delayedUnrevealedLayerRootPosition_ne_of_initial_revealed + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (htarget : Coordinate.position target ∈ state.revealed) + (selection : Option PermissivePrivateOrdinalSelection) + (hselection : selection ∈ support + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache)) : + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection ≠ some target := by + cases selection with + | none => simp [permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?] + | some selection => + intro heq + rw [permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?_eq_some_iff] at heq + obtain ⟨selected, hselected, _hcandidate, hunrevealed⟩ := heq + cases hselected + exact hunrevealed + (revealed_subset_of_mem_delayedPermissiveDetailedOrdinalSelection ordinal parameter root + ftsSecret computation candidates state fuel table cache selection hselection htarget) + +theorem delayedPermissivePublicAction_preload_hidden + (target : Position) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) + (hhidden : Coordinate.position target ∉ state.revealed) + (parameter : PublicParameter) (input : HashInput) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + delayedPermissivePublicAction parameter input table + (preloadPositionValue target output state) cache = + delayedPermissivePublicAction parameter input table state cache := by + unfold delayedPermissivePublicAction + dsimp only + have hvalues := + materializedCanonicalContext_values_preload_hidden table state target output hhidden + have hplan := purePlanProbingHashQuery_eq_of_values_eq hvalues parameter input + rw [hplan] + exact congrArg (fun computation => computation.run cache) + (probingHashQueryAfterPublicPlan_eq_of_values_eq parameter input hvalues _) + +theorem delayedPermissivePublicAction_targetPeekFree + (target : Position) (parameter : PublicParameter) (input : HashInput) + (table : OtsSecretIndex → HashOutput) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) : + (delayedPermissivePublicAction parameter input table state cache).IsQueryBoundP + (IsTargetPeek target) 0 := by + unfold delayedPermissivePublicAction + apply (show TargetPeekFree target + (probingHashQueryAfterPublicPlan parameter input + (materializedCanonicalContext table state).state + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) by + unfold probingHashQueryAfterPublicPlan + exact (executeCandidate?_targetPeekFree target + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state).candidate?).bind fun _ => + probingHashQueryPublicAction_targetPeekFree target parameter input + (materializedCanonicalContext table state).state + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state).action) cache + +theorem permissiveOrdinaryCacheCouples_publicPlan + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) : + PermissiveOrdinaryCacheCouples + (probingHashQueryAfterPublicPlan parameter input publicState plan) := by + unfold probingHashQueryAfterPublicPlan + exact (permissiveOrdinaryCacheCouples_executeCandidate? plan.candidate?).bind fun _ => + permissiveOrdinaryCacheCouples_publicAction parameter input publicState plan.action + +set_option maxRecDepth 100000 in +theorem relTriple_delayedPermissiveDetailedOrdinalSelection_of_ordinaryCacheEq + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (leftCache rightCache : SplitHashCache) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) : + RelTriple + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table leftCache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table rightCache) + (fun left right => left = right) := by + induction computation using OracleComp.inductionOn generalizing + candidates state fuel leftCache rightCache with + | pure value => + simp only [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length <;> simp [hselected] + | query_bind query next ih => + rw [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_query_bind, + delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp [hselected] + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + apply relTriple_bind + (permissiveOrdinaryCacheCouples_splitUniformImpl n leftCache rightCache hcache + state fuel table) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] + | some rightResult => exact False.elim hresult + | some leftResult => + cases rightResult with + | none => exact False.elim hresult + | some rightResult => + rcases hresult with + ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + simp only [finishPermissiveDetailedPrivateOrdinalSelection] + simpa only [hstate, hremaining, hvalue, + delayedPermissiveDetailedOrdinalSelection] using + ih leftResult.value.1 candidates leftResult.state + leftResult.remaining leftResult.value.2 rightResult.value.2 hnextCache + | inr input => + let nextCandidates := + permissiveRootAwareCandidates parameter input table state candidates + by_cases hnextSelected : ordinal < nextCandidates.length + · simp [nextCandidates, hnextSelected] + · simp only [nextCandidates, hnextSelected, ↓reduceDIte] + have haction := + permissiveOrdinaryCacheCouples_publicPlan parameter input + (materializedCanonicalContext table state).state + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state) + leftCache rightCache hcache state fuel table + apply relTriple_bind (by + simpa only [delayedPermissivePublicAction] using haction) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] + | some rightResult => exact False.elim hresult + | some leftResult => + cases rightResult with + | none => exact False.elim hresult + | some rightResult => + rcases hresult with + ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + simp only [finishPermissiveDetailedPrivateOrdinalSelection] + simpa only [hstate, hremaining, hvalue, + delayedPermissiveDetailedOrdinalSelection] using + ih leftResult.value.1 nextCandidates leftResult.state + leftResult.remaining leftResult.value.2 rightResult.value.2 hnextCache + | inr message => + apply relTriple_bind + (permissiveOrdinaryCacheCouples_maskedSign parameter root ftsSecret message + leftCache rightCache hcache state fuel table) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] + | some rightResult => exact False.elim hresult + | some leftResult => + cases rightResult with + | none => exact False.elim hresult + | some rightResult => + rcases hresult with ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + simp only [finishPermissiveDetailedPrivateOrdinalSelection] + simpa only [hstate, hremaining, hvalue, + delayedPermissiveDetailedOrdinalSelection] using + ih leftResult.value.1 candidates leftResult.state leftResult.remaining + leftResult.value.2 rightResult.value.2 hnextCache + +theorem relTriple_delayedPermissiveDetailedOrdinalSelection_targetFiber_of_stateRel + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (left right : LazyRevealProbe.State Coordinate) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (hstate : PermissiveStateRel left right) : + RelTriple + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates left fuel table cache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates right fuel table cache) + (PermissiveTargetFiberRel target) := by + apply relTriple_post_mono + (relTriple_delayedPermissiveDetailedOrdinalSelection_of_stateRel ordinal parameter root + ftsSecret computation candidates candidates left right fuel table cache rfl hstate) + intro leftSelection rightSelection hselection hleft + rw [hselection.positionFiber_eq] at hleft + exact hleft + +noncomputable def permissivePrivateOrdinalSelectionTargetProbe? + (target : Position) : Option PermissivePrivateOrdinalSelection → Option Probe + | none => none + | some selection => + if permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? (some selection) = + some target then + some selection.candidate + else + none + +def PermissiveTargetProbeRel (target : Position) : + Option PermissivePrivateOrdinalSelection → + Option PermissivePrivateOrdinalSelection → Prop := + fun left right => + permissivePrivateOrdinalSelectionTargetProbe? target left = + permissivePrivateOrdinalSelectionTargetProbe? target right + +def PermissiveTargetGuess (target : Position) : + Option PermissivePrivateOrdinalSelection → Prop + | none => False + | some selection => ∃ output, + permissivePrivateOrdinalSelectionTargetProbe? target (some selection) = + some selection.candidate ∧ + selection.state.values (.position target) = some output ∧ + selection.candidate.candidate = truncateHash output + +theorem DelayedPermissiveSelectionRel.targetGuess + {target : Position} {rightRoot : Digest} {ordinal : Nat} + {left : Option PrivateOrdinalSelection} + {right : Option PermissivePrivateOrdinalSelection} + (hrel : DelayedPermissiveSelectionRel target rightRoot ordinal left right) + (hgood : privateOrdinalSelectionGoodForSomeOutput target rightRoot ordinal left) : + PermissiveTargetGuess target right := by + obtain ⟨leftOutput, leftSelection, rightSelection, hdata⟩ := hrel hgood + have hright := hdata.2.1 + have hleftGood := hdata.2.2.1 + have hcandidate := hdata.2.2.2.1 + have hposition := hdata.2.2.2.2.2.1 + have hvalue := hdata.2.2.2.2.2.2 + rw [hright] + refine ⟨leftOutput, ?_, hvalue, ?_⟩ + · simp only [permissivePrivateOrdinalSelectionTargetProbe?] + rw [if_pos hposition] + · rw [← hcandidate] + exact congrArg Probe.candidate hleftGood.1 + +theorem PermissiveDetailedSelectionRel.targetGuess_iff + {target : Position} {left right : Option PermissivePrivateOrdinalSelection} + (hrel : PermissiveDetailedSelectionRel left right) : + PermissiveTargetGuess target left ↔ PermissiveTargetGuess target right := by + cases left with + | none => + cases right with + | none => simp [PermissiveTargetGuess] + | some right => exact False.elim hrel + | some left => + cases right with + | none => exact False.elim hrel + | some right => + rcases hrel with ⟨hcandidate, _hcandidates, hstate⟩ + have hprobe : permissivePrivateOrdinalSelectionTargetProbe? target (some left) = + permissivePrivateOrdinalSelectionTargetProbe? target (some right) := by + have hposition := + (show PermissiveDetailedSelectionRel (some left) (some right) from + ⟨hcandidate, _hcandidates, hstate⟩).positionFiber_eq + simp only [permissivePrivateOrdinalSelectionTargetProbe?] + rw [hposition, hcandidate] + constructor + · rintro ⟨output, htarget, hvalue, hdigest⟩ + refine ⟨output, ?_, ?_, ?_⟩ + · rw [← hprobe] + simpa [hcandidate] using htarget + · rw [← hstate.values] + exact hvalue + · rw [← hcandidate] + exact hdigest + · rintro ⟨output, htarget, hvalue, hdigest⟩ + refine ⟨output, ?_, ?_, ?_⟩ + · rw [hprobe] + simpa [hcandidate] using htarget + · rw [hstate.values] + exact hvalue + · rw [hcandidate] + exact hdigest + +theorem DelayedPermissiveSelectionRel.targetProbe_eq + {target : Position} {leftOutput : HashOutput} {rightRoot : Digest} {ordinal : Nat} + {left : PrivateOrdinalSelection} + {right : Option PermissivePrivateOrdinalSelection} + (hrel : DelayedPermissiveSelectionRel target rightRoot ordinal (some left) right) + (hgood : left.GoodForRoots target leftOutput rightRoot ordinal) : + permissivePrivateOrdinalSelectionTargetProbe? target right = some left.candidate := by + obtain ⟨_output, leftSelection, rightSelection, hdata⟩ := + hrel ⟨leftOutput, hgood⟩ + have hleft := hdata.1 + have hright := hdata.2.1 + have hcandidate := hdata.2.2.2.1 + have hposition := hdata.2.2.2.2.2.1 + cases Option.some.inj hleft + rw [hright] + simp only [permissivePrivateOrdinalSelectionTargetProbe?] + rw [if_pos hposition, hcandidate] + +theorem PermissiveDetailedSelectionRel.targetProbe_eq + {target : Position} {left right : Option PermissivePrivateOrdinalSelection} + (hrel : PermissiveDetailedSelectionRel left right) : + PermissiveTargetProbeRel target left right := by + cases left with + | none => + cases right with + | none => rfl + | some right => exact False.elim hrel + | some left => + cases right with + | none => exact False.elim hrel + | some right => + have hposition := hrel.positionFiber_eq + rcases hrel with ⟨hcandidate, _hcandidates, hstate⟩ + unfold PermissiveTargetProbeRel + simp only [permissivePrivateOrdinalSelectionTargetProbe?] + rw [hposition, hcandidate] + +theorem relTriple_delayedPermissiveDetailedOrdinalSelection_targetProbe_of_stateRel + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (left right : LazyRevealProbe.State Coordinate) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (hstate : PermissiveStateRel left right) : + RelTriple + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates left fuel table cache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates right fuel table cache) + (PermissiveTargetProbeRel target) := by + apply relTriple_post_mono + (relTriple_delayedPermissiveDetailedOrdinalSelection_of_stateRel ordinal parameter root + ftsSecret computation candidates candidates left right fuel table cache rfl hstate) + intro leftSelection rightSelection hselection + exact hselection.targetProbe_eq + +theorem permissivePrivateOrdinalSelectionTargetProbe?_eq_none_of_position_ne + (target : Position) (selection : Option PermissivePrivateOrdinalSelection) + (hne : permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection ≠ + some target) : + permissivePrivateOrdinalSelectionTargetProbe? target selection = none := by + cases selection with + | none => rfl + | some selection => + simp [permissivePrivateOrdinalSelectionTargetProbe?, hne] + +theorem permissiveTargetProbeRel_preload_sameSelection + (target : Position) (candidate : Probe) (candidates : List Probe) + (state : LazyRevealProbe.State Coordinate) (output : HashOutput) : + PermissiveTargetProbeRel target + (some ⟨candidate, preloadPositionValue target output state, candidates⟩) + (some ⟨candidate, state, candidates⟩) := by + unfold PermissiveTargetProbeRel permissivePrivateOrdinalSelectionTargetProbe? + have hposition : + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? + (some ⟨candidate, preloadPositionValue target output state, candidates⟩) = + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? + (some ⟨candidate, state, candidates⟩) := by + simp only [permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?] + rw [preloadPositionValue_revealed] + change (if permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? + (some ⟨candidate, preloadPositionValue target output state, candidates⟩) = some target then + some candidate else none) = + (if permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? + (some ⟨candidate, state, candidates⟩) = some target then some candidate else none) + rw [hposition] + +theorem relTriple_sample_preload_pureSelection_targetProbe + (target : Position) (candidate : Probe) (candidates : List Probe) + (state : LazyRevealProbe.State Coordinate) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + pure (some ⟨candidate, preloadPositionValue target output state, candidates⟩)) + (pure (some ⟨candidate, state, candidates⟩) : + ProbComp (Option PermissivePrivateOrdinalSelection)) + (PermissiveTargetProbeRel target) := by + rw [show (pure (some ⟨candidate, state, candidates⟩) : + ProbComp (Option PermissivePrivateOrdinalSelection)) = + (pure () >>= fun _ => pure (some ⟨candidate, state, candidates⟩)) by simp] + apply relTriple_bind + (relTriple_true LazyRevealProbe.sampleHashOutput (pure () : ProbComp Unit)) + intro output _ _ + exact relTriple_pure_pure + (permissiveTargetProbeRel_preload_sameSelection target candidate candidates state output) + +theorem relTriple_sample_preload_runPermissive_finishDetailed_targetProbe + (target : Position) + (computation : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftObserve rightObserve : LazyRevealProbe.State Coordinate → Nat → α → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection)) + (candidates : List Probe) + (hvalue : state.values (.position target) = none) + (hnoPeek : computation.IsQueryBoundP (IsTargetPeek target) 0) + (hpreloaded : ∀ nextState remaining value nextCache, + nextState.values (.position target) = none → + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + leftObserve (preloadPositionValue target output nextState) remaining value nextCache + candidates) + (rightObserve nextState remaining value nextCache candidates) + (PermissiveTargetProbeRel target)) + (hsynchronized : ∀ left right remaining value cache, + PermissiveStateRel left right → + RelTriple + (leftObserve left remaining value cache candidates) + (rightObserve right remaining value cache candidates) + (PermissiveTargetProbeRel target)) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + runPermissiveFromTable (preloadPositionValue target output state) fuel table computation >>= + finishPermissiveDetailedPrivateOrdinalSelection leftObserve candidates) + (runPermissiveFromTable state fuel table computation >>= + finishPermissiveDetailedPrivateOrdinalSelection rightObserve candidates) + (PermissiveTargetProbeRel target) := by + apply relTriple_sample_preload_runPermissiveFromTable_then target computation state fuel table + (finishPermissiveDetailedPrivateOrdinalSelection leftObserve candidates) + (finishPermissiveDetailedPrivateOrdinalSelection rightObserve candidates) + (PermissiveTargetProbeRel target) hvalue hnoPeek + · intro nextState remaining result nextTable hnextValue + rcases result with ⟨value, nextCache⟩ + simp only [finishPermissiveDetailedPrivateOrdinalSelection] + exact hpreloaded nextState remaining value nextCache hnextValue + · intro left right hresult + cases left with + | none => + cases right with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection, + PermissiveTargetProbeRel] + | some right => exact False.elim hresult + | some left => + cases right with + | none => exact False.elim hresult + | some right => + rcases hresult with ⟨hstate, hremaining, hvalue, htable⟩ + have hvalueEq := congrArg Prod.fst hvalue + have hcacheEq := congrArg Prod.snd hvalue + simp only [finishPermissiveDetailedPrivateOrdinalSelection] + rw [← hremaining, ← hvalueEq, ← hcacheEq] + exact hsynchronized left.state right.state left.remaining left.value.1 + left.value.2 hstate + +theorem relTriple_sample_preload_delayedSelector_targetProbe_of_initial_revealed + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (hrevealed : Coordinate.position target ∈ state.revealed) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates (preloadPositionValue target output state) fuel table cache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache) + (PermissiveTargetProbeRel target) := by + have hbase := relTriple_true + (LazyRevealProbe.sampleHashOutput >>= fun output => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates (preloadPositionValue target output state) fuel table cache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun selection => + permissivePrivateOrdinalSelectionTargetProbe? target selection = none) + (by + intro selection hselection + rw [mem_support_bind_iff] at hselection + obtain ⟨output, _houtput, htail⟩ := hselection + apply permissivePrivateOrdinalSelectionTargetProbe?_eq_none_of_position_ne + exact delayedUnrevealedLayerRootPosition_ne_of_initial_revealed ordinal parameter root + ftsSecret computation candidates (preloadPositionValue target output state) fuel table + cache target (by simpa using hrevealed) selection htail) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro left right hrelation + rcases hrelation with ⟨⟨_relation, hleftNone⟩, hrightSupport⟩ + have hrightNone : permissivePrivateOrdinalSelectionTargetProbe? target right = none := by + apply permissivePrivateOrdinalSelectionTargetProbe?_eq_none_of_position_ne + exact delayedUnrevealedLayerRootPosition_ne_of_initial_revealed ordinal parameter root + ftsSecret computation candidates state fuel table cache target hrevealed right hrightSupport + unfold PermissiveTargetProbeRel + rw [hleftNone, hrightNone] + +theorem relTriple_sample_preload_delayedSelector_targetFiber_of_initial_revealed + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (hrevealed : Coordinate.position target ∈ state.revealed) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates (preloadPositionValue target output state) fuel table cache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache) + (PermissiveTargetFiberRel target) := by + have hbase := relTriple_true + (LazyRevealProbe.sampleHashOutput >>= fun output => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates (preloadPositionValue target output state) fuel table cache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection ≠ some target) + (by + intro selection hselection + rw [mem_support_bind_iff] at hselection + obtain ⟨output, _houtput, htail⟩ := hselection + exact delayedUnrevealedLayerRootPosition_ne_of_initial_revealed ordinal parameter root + ftsSecret computation candidates (preloadPositionValue target output state) fuel table + cache target (by simpa using hrevealed) selection htail) + apply relTriple_post_mono hleft + intro left right hrelation hfiber + exact False.elim (hrelation.2 hfiber) + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_sample_preload_delayedPermissiveDetailedOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (hvalue : state.values (.position target) = none) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates (preloadPositionValue target output state) fuel table cache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache) + (PermissiveTargetFiberRel target) := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + by_cases hrevealed : Coordinate.position target ∈ state.revealed + · exact relTriple_sample_preload_delayedSelector_targetFiber_of_initial_revealed ordinal + parameter root ftsSecret (pure value) candidates state fuel table cache target hrevealed + · simp only [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_sample_preload_pureSelection_targetFiber target + (candidates.get ⟨ordinal, hselected⟩) candidates state + · simp only [hselected, ↓reduceDIte] + apply relTriple_of_evalDist_eq_left + (OracleComp.DeferredSampling.evalDist_bind_const_neverFails + LazyRevealProbe.sampleHashOutput (by + simp [LazyRevealProbe.sampleHashOutput]) (pure none)) + exact relTriple_pure_pure (by simp [PermissiveTargetFiberRel]) + | query_bind query next ih => + by_cases hrevealed : Coordinate.position target ∈ state.revealed + · exact relTriple_sample_preload_delayedSelector_targetFiber_of_initial_revealed ordinal + parameter root ftsSecret (liftM (OracleSpec.query query) >>= next) candidates state fuel + table cache target hrevealed + · simp_rw [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_sample_preload_pureSelection_targetFiber target + (candidates.get ⟨ordinal, hselected⟩) candidates state + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let observe : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_sample_preload_runPermissive_finishDetailed target + ((splitUniformImpl n).run cache) state fuel table observe observe candidates + hvalue (splitUniformImpl_targetPeekFree target n cache) + · intro nextState remaining output nextCache hnextValue + simpa only [observe] using + ih output candidates nextState remaining nextCache hnextValue + · intro left right remaining output nextCache hstate + exact + relTriple_delayedPermissiveDetailedOrdinalSelection_targetFiber_of_stateRel + ordinal parameter root ftsSecret (next output) candidates left right + remaining table nextCache target hstate + | inr input => + let nextCandidates := + permissiveRootAwareCandidates parameter input table state candidates + by_cases hnextSelected : ordinal < nextCandidates.length + · simp only [nextCandidates, hnextSelected, ↓reduceDIte] + rw [show (pure (some + ⟨(permissiveRootAwareCandidates parameter input table state candidates).get + ⟨ordinal, hnextSelected⟩, + state, + permissiveRootAwareCandidates parameter input table state candidates⟩) : + ProbComp (Option PermissivePrivateOrdinalSelection)) = + (pure () >>= fun _ => pure (some + ⟨(permissiveRootAwareCandidates parameter input table state candidates).get + ⟨ordinal, hnextSelected⟩, + state, + permissiveRootAwareCandidates parameter input table state candidates⟩)) by simp] + apply relTriple_bind + (relTriple_true LazyRevealProbe.sampleHashOutput (pure () : ProbComp Unit)) + intro output _ _ + rw [permissiveRootAwareCandidates_preload_hidden target output state hrevealed + parameter input table candidates] + have hnextSelected' : ordinal < + (permissiveRootAwareCandidates parameter input table state candidates).length := + hnextSelected + rw [dif_pos hnextSelected'] + exact relTriple_pure_pure + (permissiveTargetFiberRel_preload_sameSelection target + ((permissiveRootAwareCandidates parameter input table state candidates).get + ⟨ordinal, hnextSelected⟩) + (permissiveRootAwareCandidates parameter input table state candidates) + state output) + · simp_rw [permissiveRootAwareCandidates_preload_hidden target _ state hrevealed + parameter input table candidates] + simp only [nextCandidates, hnextSelected, ↓reduceDIte] + simp_rw [delayedPermissivePublicAction_preload_hidden target _ state hrevealed + parameter input table cache] + let observe : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_sample_preload_runPermissive_finishDetailed target + (delayedPermissivePublicAction parameter input table state cache) + state fuel table observe observe nextCandidates hvalue + (delayedPermissivePublicAction_targetPeekFree target parameter input table + state cache) + · intro nextState remaining output nextCache hnextValue + simpa only [observe] using + ih output nextCandidates nextState remaining nextCache hnextValue + · intro left right remaining output nextCache hstate + exact + relTriple_delayedPermissiveDetailedOrdinalSelection_targetFiber_of_stateRel + ordinal parameter root ftsSecret (next output) nextCandidates left right + remaining table nextCache target hstate + | inr message => + let observe : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_sample_preload_runPermissive_finishDetailed target + ((maskedSign parameter root ftsSecret message).run cache) state fuel table + observe observe candidates hvalue + (maskedSign_targetPeekFree target parameter root ftsSecret message cache) + · intro nextState remaining output nextCache hnextValue + simpa only [observe] using + ih output candidates nextState remaining nextCache hnextValue + · intro left right remaining output nextCache hstate + exact + relTriple_delayedPermissiveDetailedOrdinalSelection_targetFiber_of_stateRel + ordinal parameter root ftsSecret (next output) candidates left right remaining + table nextCache target hstate + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_sample_preload_delayedPermissiveDetailedOrdinalSelection_targetProbe + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (target : Position) (hvalue : state.values (.position target) = none) : + RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates (preloadPositionValue target output state) fuel table cache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache) + (PermissiveTargetProbeRel target) := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + by_cases hrevealed : Coordinate.position target ∈ state.revealed + · exact relTriple_sample_preload_delayedSelector_targetProbe_of_initial_revealed ordinal + parameter root ftsSecret (pure value) candidates state fuel table cache target hrevealed + · simp only [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_sample_preload_pureSelection_targetProbe target + (candidates.get ⟨ordinal, hselected⟩) candidates state + · simp only [hselected, ↓reduceDIte] + apply relTriple_of_evalDist_eq_left + (OracleComp.DeferredSampling.evalDist_bind_const_neverFails + LazyRevealProbe.sampleHashOutput (by + simp [LazyRevealProbe.sampleHashOutput]) (pure none)) + exact relTriple_pure_pure (by simp [PermissiveTargetProbeRel]) + | query_bind query next ih => + by_cases hrevealed : Coordinate.position target ∈ state.revealed + · exact relTriple_sample_preload_delayedSelector_targetProbe_of_initial_revealed ordinal + parameter root ftsSecret (liftM (OracleSpec.query query) >>= next) candidates state fuel + table cache target hrevealed + · simp_rw [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_sample_preload_pureSelection_targetProbe target + (candidates.get ⟨ordinal, hselected⟩) candidates state + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let observe : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_sample_preload_runPermissive_finishDetailed_targetProbe target + ((splitUniformImpl n).run cache) state fuel table observe observe candidates + hvalue (splitUniformImpl_targetPeekFree target n cache) + · intro nextState remaining output nextCache hnextValue + simpa only [observe] using + ih output candidates nextState remaining nextCache hnextValue + · intro left right remaining output nextCache hstate + exact + relTriple_delayedPermissiveDetailedOrdinalSelection_targetProbe_of_stateRel + ordinal parameter root ftsSecret (next output) candidates left right + remaining table nextCache target hstate + | inr input => + let nextCandidates := + permissiveRootAwareCandidates parameter input table state candidates + by_cases hnextSelected : ordinal < nextCandidates.length + · simp only [nextCandidates, hnextSelected, ↓reduceDIte] + rw [show (pure (some + ⟨(permissiveRootAwareCandidates parameter input table state candidates).get + ⟨ordinal, hnextSelected⟩, + state, + permissiveRootAwareCandidates parameter input table state candidates⟩) : + ProbComp (Option PermissivePrivateOrdinalSelection)) = + (pure () >>= fun _ => pure (some + ⟨(permissiveRootAwareCandidates parameter input table state candidates).get + ⟨ordinal, hnextSelected⟩, + state, + permissiveRootAwareCandidates parameter input table state candidates⟩)) by simp] + apply relTriple_bind + (relTriple_true LazyRevealProbe.sampleHashOutput (pure () : ProbComp Unit)) + intro output _ _ + rw [permissiveRootAwareCandidates_preload_hidden target output state hrevealed + parameter input table candidates] + have hnextSelected' : ordinal < + (permissiveRootAwareCandidates parameter input table state candidates).length := + hnextSelected + rw [dif_pos hnextSelected'] + exact relTriple_pure_pure + (permissiveTargetProbeRel_preload_sameSelection target + ((permissiveRootAwareCandidates parameter input table state candidates).get + ⟨ordinal, hnextSelected⟩) + (permissiveRootAwareCandidates parameter input table state candidates) + state output) + · simp_rw [permissiveRootAwareCandidates_preload_hidden target _ state hrevealed + parameter input table candidates] + simp only [nextCandidates, hnextSelected, ↓reduceDIte] + simp_rw [delayedPermissivePublicAction_preload_hidden target _ state hrevealed + parameter input table cache] + let observe : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_sample_preload_runPermissive_finishDetailed_targetProbe target + (delayedPermissivePublicAction parameter input table state cache) + state fuel table observe observe nextCandidates hvalue + (delayedPermissivePublicAction_targetPeekFree target parameter input table + state cache) + · intro nextState remaining output nextCache hnextValue + simpa only [observe] using + ih output nextCandidates nextState remaining nextCache hnextValue + · intro left right remaining output nextCache hstate + exact + relTriple_delayedPermissiveDetailedOrdinalSelection_targetProbe_of_stateRel + ordinal parameter root ftsSecret (next output) nextCandidates left right + remaining table nextCache target hstate + | inr message => + let observe : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_sample_preload_runPermissive_finishDetailed_targetProbe target + ((maskedSign parameter root ftsSecret message).run cache) state fuel table + observe observe candidates hvalue + (maskedSign_targetPeekFree target parameter root ftsSecret message cache) + · intro nextState remaining output nextCache hnextValue + simpa only [observe] using + ih output candidates nextState remaining nextCache hnextValue + · intro left right remaining output nextCache hstate + exact + relTriple_delayedPermissiveDetailedOrdinalSelection_targetProbe_of_stateRel + ordinal parameter root ftsSecret (next output) candidates left right remaining + table nextCache target hstate + +noncomputable def preloadedDelayedPermissiveDetailedSelectionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp (Option PermissivePrivateOrdinalSelection) := do + let output ← LazyRevealProbe.sampleHashOutput + delayedPermissiveDetailedOrdinalSelection ordinal parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (preloadPositionValue target output rootResult.state) rootResult.remaining rootResult.table + rootResult.value.2 + +noncomputable def installedDelayedPermissiveDetailedSelectionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp (Option PermissivePrivateOrdinalSelection) := do + let output ← LazyRevealProbe.sampleHashOutput + delayedPermissiveDetailedOrdinalSelection ordinal parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (preloadPositionValue target output rootResult.state) rootResult.remaining rootResult.table + (replaceHiddenRootCache target output rootResult.value.2) + +theorem relTriple_installedDelayedSelection_preloaded_afterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + RelTriple + (installedDelayedPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) + (preloadedDelayedPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) + (fun left right => left = right) := by + unfold installedDelayedPermissiveDetailedSelectionAfterRootResult + preloadedDelayedPermissiveDetailedSelectionAfterRootResult + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + exact relTriple_delayedPermissiveDetailedOrdinalSelection_of_ordinaryCacheEq ordinal parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (preloadPositionValue target leftOutput rootResult.state) rootResult.remaining rootResult.table + (replaceHiddenRootCache target leftOutput rootResult.value.2) rootResult.value.2 + (ordinaryQueryCache_replaceHiddenRootCache target leftOutput rootResult.value.2) + +theorem relTriple_preloadedDelayedSelection_common_afterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hvalue : rootResult.state.values (.position target) = none) : + RelTriple + (preloadedDelayedPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) + (delayedPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter ftsSecret + rootResult) + (PermissiveTargetFiberRel target) := by + unfold preloadedDelayedPermissiveDetailedSelectionAfterRootResult + delayedPermissiveDetailedSelectionAfterRootResult + exact relTriple_sample_preload_delayedPermissiveDetailedOrdinalSelection ordinal parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] rootResult.state + rootResult.remaining rootResult.table rootResult.value.2 target hvalue + +theorem relTriple_preloadedDelayedSelection_common_targetProbe_afterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hvalue : rootResult.state.values (.position target) = none) : + RelTriple + (preloadedDelayedPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) + (delayedPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter ftsSecret + rootResult) + (PermissiveTargetProbeRel target) := by + unfold preloadedDelayedPermissiveDetailedSelectionAfterRootResult + delayedPermissiveDetailedSelectionAfterRootResult + exact relTriple_sample_preload_delayedPermissiveDetailedOrdinalSelection_targetProbe ordinal + parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] rootResult.state + rootResult.remaining rootResult.table rootResult.value.2 target hvalue + +theorem relTriple_installedDelayedSelection_common_targetProbe_afterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hvalue : rootResult.state.values (.position target) = none) : + RelTriple + (installedDelayedPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) + (delayedPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter ftsSecret + rootResult) + (PermissiveTargetProbeRel target) := by + have hglued := SphincsSecurity.relTriple_trans_exists + (relTriple_installedDelayedSelection_preloaded_afterRootResult ordinal adversary parameter + ftsSecret target rootResult) + (relTriple_preloadedDelayedSelection_common_targetProbe_afterRootResult ordinal adversary + parameter ftsSecret target rootResult hvalue) + apply relTriple_post_mono hglued + intro left right hrelation + obtain ⟨middle, hleft, hright⟩ := hrelation + subst middle + exact hright + +noncomputable def preloadedDelayedPermissiveDetailedSelectionExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (Option PermissivePrivateOrdinalSelection) := do + let rootResult ← rootAwareProductionInitialRun fuel table + match rootResult with + | none => pure none + | some result => + preloadedDelayedPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target result + +noncomputable def installedDelayedPermissiveDetailedSelectionExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (Option PermissivePrivateOrdinalSelection) := do + let rootResult ← rootAwareProductionInitialRun fuel table + match rootResult with + | none => pure none + | some result => + installedDelayedPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret target result + +set_option maxRecDepth 100000 in +theorem relTriple_installedDelayedSelection_common_targetProbe_afterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + RelTriple + (installedDelayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret target fuel table) + (delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table) + (PermissiveTargetProbeRel target) := by + unfold installedDelayedPermissiveDetailedSelectionExperimentAfterTable + delayedPermissiveDetailedSelectionExperimentAfterTable + let initial := rootAwareProductionInitialRun fuel table + have hbase := relTriple_refl initial + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (InitialRootOptionFacts target) + (initialRootOptionFacts_of_mem target hroot hparent fuel table) + apply relTriple_bind hsupported + intro leftResult rightResult hrelation + rcases hrelation with ⟨heq, hinitial⟩ + subst rightResult + cases leftResult with + | none => exact relTriple_pure_pure rfl + | some rootResult => + exact relTriple_installedDelayedSelection_common_targetProbe_afterRootResult ordinal + adversary parameter ftsSecret target rootResult hinitial.1 + +set_option maxRecDepth 100000 in +theorem evalDist_installedDelayedSelection_common_targetProbe_afterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + evalDist + (permissivePrivateOrdinalSelectionTargetProbe? target <$> + installedDelayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret target fuel table) = + evalDist + (permissivePrivateOrdinalSelectionTargetProbe? target <$> + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table) := by + have hrel := relTriple_installedDelayedSelection_common_targetProbe_afterTable ordinal adversary + parameter ftsSecret target hroot hparent fuel table + have hmapped : RelTriple + (permissivePrivateOrdinalSelectionTargetProbe? target <$> + installedDelayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary + parameter ftsSecret target fuel table) + (permissivePrivateOrdinalSelectionTargetProbe? target <$> + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table) + (fun left right => left = right) := + relTriple_map hrel + exact evalDist_eq_of_relTriple_eqRel hmapped + +set_option maxRecDepth 100000 in +theorem probEvent_preloadedDelayedSelection_fiber_le_common + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + preloadedDelayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table] := by + unfold preloadedDelayedPermissiveDetailedSelectionExperimentAfterTable + delayedPermissiveDetailedSelectionExperimentAfterTable + apply probEvent_bind_le_bind_of_forall_le_of_invariant + (invariant := InitialRootOptionFacts target) + · exact initialRootOptionFacts_of_mem target hroot hparent fuel table + · intro rootResult hinitial + cases rootResult with + | none => + simp [permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?] + | some rootResult => + apply probEvent_le_of_relTriple + (relTriple_preloadedDelayedSelection_common_afterRootResult ordinal adversary parameter + ftsSecret target rootResult hinitial.1) + intro left right hrelation hleft + exact hrelation hleft + +set_option maxRecDepth 100000 in +theorem probEvent_installedDelayedSelection_fiber_le_common + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + installedDelayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table] := by + calc + _ ≤ Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + preloadedDelayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] := by + unfold installedDelayedPermissiveDetailedSelectionExperimentAfterTable + preloadedDelayedPermissiveDetailedSelectionExperimentAfterTable + apply probEvent_bind_le_bind_of_forall_le + intro rootResult _hrootResult + cases rootResult with + | none => simp [permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?] + | some rootResult => + apply probEvent_le_of_relTriple + (relTriple_installedDelayedSelection_preloaded_afterRootResult ordinal adversary + parameter ftsSecret target rootResult) + intro left right heq hleft + rwa [← heq] + _ ≤ _ := probEvent_preloadedDelayedSelection_fiber_le_common ordinal adversary parameter + ftsSecret target hroot hparent fuel table + +set_option maxRecDepth 100000 in +theorem probEvent_privateOrdinalSelectionGoodForSomeOutput_le_targetGuess + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) (rightRoot : Digest) + (hroot : IsLayerRoot target) : + Pr[privateOrdinalSelectionGoodForSomeOutput target rightRoot ordinal | + granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret + fuel] ≤ + Pr[PermissiveTargetGuess target | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table] := by + apply probEvent_le_of_relTriple + (relTriple_granularAllCanonicalPrivateOrdinalSelection_permissiveDelayed ordinal adversary + parameter table ftsSecret fuel target rightRoot hroot) + intro left right hrelation hgood + exact hrelation.targetGuess hgood + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedSelector.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedSelector.lean new file mode 100644 index 00000000..2335cfdd --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedSelector.lean @@ -0,0 +1,1032 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceDelayedCoupling +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonExperiment +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionCommonCache +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveReverse + +/-! +# Delayed source common selector + +The delayed-source comparison records every root-aware candidate, including an encoding-domain +candidate, but executes only the hash action made by the source game. Keeping that schedule avoids +turning a proof-only candidate at an earlier ordinal into a spurious revealed position. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +def DelayedPermissiveSelectionRel + (target : Position) (rightRoot : Digest) (ordinal : Nat) : + Option PrivateOrdinalSelection → Option PermissivePrivateOrdinalSelection → Prop := + fun left right => + privateOrdinalSelectionGoodForSomeOutput target rightRoot ordinal left → + ∃ leftOutput leftSelection rightSelection, + left = some leftSelection ∧ right = some rightSelection ∧ + leftSelection.GoodForRoots target leftOutput rightRoot ordinal ∧ + leftSelection.candidate = rightSelection.candidate ∧ + leftSelection.candidates = rightSelection.candidates ∧ + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? (some rightSelection) = + some target ∧ + rightSelection.state.values (.position target) = some leftOutput + +theorem delayedPermissiveSelectionRel_selected + (target : Position) (rightRoot : Digest) (ordinal : Nat) + (hroot : IsLayerRoot target) (candidate : Probe) + (candidates : List Probe) (left : DeferredContext) + (right : LazyRevealProbe.State Coordinate) + (hvalues : (materializedDeferredState left).values = right.values) + (hrevealed : left.state.revealed = right.revealed) : + DelayedPermissiveSelectionRel target rightRoot ordinal + (some ⟨candidate, left, candidates⟩) (some ⟨candidate, right, candidates⟩) := by + intro hgood + obtain ⟨leftOutput, hgood⟩ := hgood + change PrivateOrdinalSelection.GoodForRoots target leftOutput rightRoot ordinal + ⟨candidate, left, candidates⟩ at hgood + refine ⟨leftOutput, ⟨candidate, left, candidates⟩, ⟨candidate, right, candidates⟩, rfl, rfl, + hgood, rfl, rfl, ?_, ?_⟩ + · exact permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?_eq_some_of_candidate + (by simpa using congrArg Probe.coordinate hgood.1) hroot + (by simpa [← hrevealed] using hgood.2.2.1) + · rw [← hvalues] + simp only [materializedDeferredState, DeferredContext.positionValue] + rw [hgood.2.1] + exact hgood.2.2.2.1 + +theorem relTriple_none_any_delayedPermissiveSelection + (target : Position) (rightRoot : Digest) (ordinal : Nat) + (right : ProbComp (Option PermissivePrivateOrdinalSelection)) : + RelTriple (pure none : ProbComp (Option PrivateOrdinalSelection)) right + (DelayedPermissiveSelectionRel target rightRoot ordinal) := by + have hbase := relTriple_true (pure none : ProbComp (Option PrivateOrdinalSelection)) right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun value => value = none) (by + intro value hvalue + simpa using hvalue) + apply relTriple_post_mono hsupported + intro left right hrelation + rw [hrelation.2] + simp [DelayedPermissiveSelectionRel, privateOrdinalSelectionGoodForSomeOutput] + +set_option maxRecDepth 100000 in +theorem relTriple_finishDirect_delayedPermissiveSelection + (target : Position) (rightRoot : Digest) (ordinal : Nat) + (table : OtsSecretIndex → HashOutput) + (leftObserve : DeferredContext → Nat → (α × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (rightObserve : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp (Option PermissivePrivateOrdinalSelection)) + (leftCandidates rightCandidates : List Probe) + (left : DirectWitnessResult (α × SplitHashCache)) + (right : Option (CleanRunResult (α × SplitHashCache))) + (hrelation : DirectWitnessPermissiveRunRel table left right) + (hrecursive : ∀ leftResult rightResult, + left = .done leftResult → right = some rightResult → + leftResult.value = rightResult.value → + leftResult.remaining = rightResult.remaining → + (materializedDeferredState + (canonicalizeMaterializedValues table leftResult.context)).values = + rightResult.state.values → + (canonicalizeMaterializedValues table leftResult.context).state.revealed = + rightResult.state.revealed → + (canonicalizeMaterializedValues table leftResult.context).Valid → + DeferredCompletable table (canonicalizeMaterializedValues table leftResult.context) → + ChainState.ValidFor (fun _ ↦ True) + (canonicalizeMaterializedValues table leftResult.context).state → + CanonicalMaterializedValues table + (canonicalizeMaterializedValues table leftResult.context) → + PublishedValues + (canonicalizeMaterializedValues table leftResult.context).state → + RelTriple + (leftObserve (canonicalizeMaterializedValues table leftResult.context) + leftResult.remaining leftResult.value leftCandidates) + (rightObserve rightResult.state rightResult.remaining rightResult.value.1 + rightResult.value.2 rightCandidates) + (DelayedPermissiveSelectionRel target rightRoot ordinal)) : + RelTriple + (finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table leftObserve) leftCandidates left) + (finishPermissiveDetailedPrivateOrdinalSelection rightObserve rightCandidates right) + (DelayedPermissiveSelectionRel target rightRoot ordinal) := by + cases left with + | stoppedFuel => + exact relTriple_none_any_delayedPermissiveSelection target rightRoot ordinal _ + | stoppedOrdinary => + exact relTriple_none_any_delayedPermissiveSelection target rightRoot ordinal _ + | stoppedPrivate witness => + exact relTriple_none_any_delayedPermissiveSelection target rightRoot ordinal _ + | done leftResult => + rcases hrelation with hreject | ⟨rightResult, hright, hvalue, hremaining, + _hleftTable, _hrightTable, hrevealed, hmaterialized, hchainValid, hcontext⟩ + · rcases hreject with hprivate | hpublished | hcompletable + · rw [show finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table leftObserve) leftCandidates + (.done leftResult) = pure none by + simp [finishDirectPrivateOrdinalSelection, + canonicalizeDirectPrivateOrdinalSelection, hprivate]] + exact relTriple_none_any_delayedPermissiveSelection target rightRoot ordinal _ + · rw [show finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table leftObserve) leftCandidates + (.done leftResult) = pure none by + simp [finishDirectPrivateOrdinalSelection, + canonicalizeDirectPrivateOrdinalSelection, hpublished]] + exact relTriple_none_any_delayedPermissiveSelection target rightRoot ordinal _ + · rw [show finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table leftObserve) leftCandidates + (.done leftResult) = pure none by + simp [finishDirectPrivateOrdinalSelection, + canonicalizeDirectPrivateOrdinalSelection, hcompletable]] + exact relTriple_none_any_delayedPermissiveSelection target rightRoot ordinal _ + · subst right + let canonical := canonicalizeMaterializedValues table leftResult.context + unfold finishDirectPrivateOrdinalSelection + finishPermissiveDetailedPrivateOrdinalSelection + canonicalizeDirectPrivateOrdinalSelection + by_cases hprivate : PrivateStructuralHit canonical + · simp only [canonical, hprivate, ↓reduceIte] + exact relTriple_none_any_delayedPermissiveSelection target rightRoot ordinal _ + · simp only [canonical, hprivate, ↓reduceIte] + by_cases hpublished : PublishedValues leftResult.context.state + · simp only [hpublished, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table + (canonicalizeMaterializedValues table leftResult.context) + · simp only [hcompletable, ↓reduceIte] + have hcanonicalMaterialized : + (materializedDeferredState canonical).values = rightResult.state.values := by + rw [ScratchLocal.materializedDeferredState_canonicalize_eq table leftResult.context + hcontext.1.leftStarts hchainValid hcontext.2.1.valuesConsistent] + exact hmaterialized + have hcanonicalRevealed : + canonical.state.revealed = rightResult.state.revealed := by + simpa [canonical, canonicalizeMaterializedValues_revealed] using hrevealed + have hcanonicalValid : canonical.Valid := + canonicalizeMaterializedValues_valid table leftResult.context hcontext.2.1 + hcontext.1.leftClean + have hcanonicalChainValid : ChainState.ValidFor (fun _ ↦ True) canonical.state := + hchainValid.canonicalizeMaterializedValues table hcontext.1.leftStarts + have hcanonicalCanonical : CanonicalMaterializedValues table canonical := + canonicalizeMaterializedValues_canonical table leftResult.context + hcontext.2.1.valuesConsistent + have hcanonicalPublished : PublishedValues canonical.state := + hpublished.to_canonicalizedMaterializedValues + simpa [hvalue, hremaining] using + hrecursive leftResult rightResult rfl rfl hvalue hremaining + hcanonicalMaterialized hcanonicalRevealed hcanonicalValid hcompletable + hcanonicalChainValid hcanonicalCanonical hcanonicalPublished + · simp only [hcompletable, ↓reduceIte] + exact relTriple_none_any_delayedPermissiveSelection target rightRoot + ordinal _ + · simp only [hpublished, ↓reduceIte] + exact relTriple_none_any_delayedPermissiveSelection target rightRoot + ordinal _ + +noncomputable def delayedPermissivePublicAction + (parameter : PublicParameter) (input : HashInput) + (table : OtsSecretIndex → HashOutput) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) : + OracleComp (LazyRevealProbe.World Coordinate) (HashOutput × SplitHashCache) := + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + (probingHashQueryAfterPublicPlan parameter input publicContext.state plan).run cache + +noncomputable def delayedPermissiveDetailedOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option PermissivePrivateOrdinalSelection) := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + List Probe → LazyRevealProbe.State Coordinate → Nat → + (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp (Option PermissivePrivateOrdinalSelection)) + (fun _value candidates state _fuel _table _cache => + if hselected : ordinal < candidates.length then + pure (some ⟨candidates.get ⟨ordinal, hselected⟩, state, candidates⟩) + else pure none) + (fun query _next recursivelyRun candidates state fuel table cache => + if hselected : ordinal < candidates.length then + pure (some ⟨candidates.get ⟨ordinal, hselected⟩, state, candidates⟩) + else + match query with + | .inl (.inl n) => + runPermissiveFromTable state fuel table ((splitUniformImpl n).run cache) >>= + finishPermissiveDetailedPrivateOrdinalSelection + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache) + candidates + | .inl (.inr input) => + let nextCandidates := permissiveRootAwareCandidates parameter input table state + candidates + if hnextSelected : ordinal < nextCandidates.length then + pure (some ⟨nextCandidates.get ⟨ordinal, hnextSelected⟩, state, + nextCandidates⟩) + else + runPermissiveFromTable state fuel table + (delayedPermissivePublicAction parameter input table state cache) >>= + finishPermissiveDetailedPrivateOrdinalSelection + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache) + nextCandidates + | .inr message => + runPermissiveFromTable state fuel table + ((maskedSign parameter root ftsSecret message).run cache) >>= + finishPermissiveDetailedPrivateOrdinalSelection + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache) + candidates) + computation candidates state fuel table cache + +theorem delayedPermissivePublicAction_eq_of_stateRel + (parameter : PublicParameter) (input : HashInput) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + {left right : LazyRevealProbe.State Coordinate} + (hstate : PermissiveStateRel left right) : + delayedPermissivePublicAction parameter input table left cache = + delayedPermissivePublicAction parameter input table right cache := by + unfold delayedPermissivePublicAction + dsimp only + have hplan := permissiveRootAwarePlan_eq_of_stateRel parameter input table hstate + have hvalues := materializedCanonicalContext_values_eq_of_permissiveStateRel table hstate + unfold permissiveRootAwarePlan at hplan + rw [hplan] + exact congrArg (fun computation => computation.run cache) + (probingHashQueryAfterPublicPlan_eq_of_values_eq parameter input hvalues _) + +theorem materializedCanonicalContext_values_eq_canonicalContext + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hcanonical : CanonicalMaterializedValues table context) : + (materializedCanonicalContext table (materializedDeferredState context)).state.values = + context.state.values := by + have hle := finalizationContextLE_materializedDeferredContext hvalid hcompletable + have hrevealed : context.state.revealed = + (materializedDeferredContext context).state.revealed := by + simp [materializedDeferredContext, directDeferredContext, materializedDeferredState] + have hvalues := canonicalized_right_values_eq_of_finalizationContextLE hle hrevealed hcanonical + simpa [materializedCanonicalContext, materializedDeferredContext] using hvalues + +theorem permissiveRootAwareCandidates_materializedDeferredState_eq + (parameter : PublicParameter) (input : HashInput) + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (candidates : List Probe) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hcanonical : CanonicalMaterializedValues table context) : + permissiveRootAwareCandidates parameter input table (materializedDeferredState context) + candidates = + appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) := by + unfold permissiveRootAwareCandidates permissiveRootAwarePlan + rw [purePlanProbingHashQuery_eq_of_values_eq + (materializedCanonicalContext_values_eq_canonicalContext table context hvalid hcompletable + hcanonical) parameter input] + rw [rootAwareCandidateForPlan?_purePlan] + +theorem delayedPermissivePublicAction_materializedDeferredState_eq + (parameter : PublicParameter) (input : HashInput) + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (cache : SplitHashCache) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hcanonical : CanonicalMaterializedValues table context) : + delayedPermissivePublicAction parameter input table (materializedDeferredState context) cache = + (probingHashQueryAfterPublicPlan parameter input context.state + (purePlanProbingHashQuery parameter input context.state)).run cache := by + unfold delayedPermissivePublicAction + dsimp only + have hvalues := materializedCanonicalContext_values_eq_canonicalContext table context hvalid + hcompletable hcanonical + have hplan := purePlanProbingHashQuery_eq_of_values_eq hvalues parameter input + rw [hplan] + exact congrArg (fun computation => computation.run cache) + (probingHashQueryAfterPublicPlan_eq_of_values_eq parameter input hvalues _) + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem relTriple_delayedPermissiveDetailedOrdinalSelection_of_stateRel + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (leftCandidates rightCandidates : List Probe) + (left right : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcandidates : leftCandidates = rightCandidates) + (hstate : PermissiveStateRel left right) : + RelTriple + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + leftCandidates left fuel table cache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + rightCandidates right fuel table cache) + PermissiveDetailedSelectionRel := by + induction computation using OracleComp.inductionOn generalizing + leftCandidates rightCandidates left right fuel cache with + | pure value => + subst rightCandidates + simp only [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < leftCandidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure ⟨rfl, rfl, hstate⟩ + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure trivial + | query_bind query next ih => + subst rightCandidates + rw [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_query_bind, + delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < leftCandidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure ⟨rfl, rfl, hstate⟩ + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let observe : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_runPermissiveFromTable_of_stateRel + ((splitUniformImpl n).run cache) left right fuel table hstate) + intro leftResult rightResult hresult + apply relTriple_finishPermissiveDetailedSelection observe observe leftCandidates + leftCandidates leftResult rightResult rfl hresult + intro nextLeft nextRight hnext + rcases hnext with ⟨hnextState, hremaining, hvalue, htable⟩ + simpa only [observe, hremaining, hvalue, + delayedPermissiveDetailedOrdinalSelection] using + ih nextLeft.value.1 leftCandidates leftCandidates nextLeft.state nextRight.state + nextLeft.remaining nextLeft.value.2 rfl hnextState + | inr input => + let leftNext := + permissiveRootAwareCandidates parameter input table left leftCandidates + let rightNext := + permissiveRootAwareCandidates parameter input table right leftCandidates + have hnext : leftNext = rightNext := + permissiveRootAwareCandidates_eq_of_stateRel parameter input table + leftCandidates hstate + by_cases hnextSelected : ordinal < leftNext.length + · have hrightSelected : ordinal < rightNext.length := by rwa [← hnext] + simp only [leftNext, rightNext, hnextSelected, hrightSelected, ↓reduceDIte] + have hcandidate : + (permissiveRootAwareCandidates parameter input table left leftCandidates).get + ⟨ordinal, hnextSelected⟩ = + (permissiveRootAwareCandidates parameter input table right leftCandidates).get + ⟨ordinal, hrightSelected⟩ := by + dsimp only [leftNext, rightNext] at hnext + rw [List.get_eq_getElem, List.get_eq_getElem] + simpa only [hnext] + exact relTriple_pure_pure ⟨hcandidate, hnext, hstate⟩ + · have hrightSelected : ¬ordinal < rightNext.length := by rwa [← hnext] + simp only [leftNext, rightNext, hnextSelected, hrightSelected, ↓reduceDIte] + let observe : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (by + rw [delayedPermissivePublicAction_eq_of_stateRel parameter input table cache + hstate] + exact relTriple_runPermissiveFromTable_of_stateRel _ left right fuel table + hstate) + intro leftResult rightResult hresult + apply relTriple_finishPermissiveDetailedSelection observe observe leftNext + rightNext leftResult rightResult hnext hresult + intro nextLeft nextRight hnextResult + rcases hnextResult with ⟨hnextState, hremaining, hvalue, htable⟩ + simpa only [observe, hremaining, hvalue, + delayedPermissiveDetailedOrdinalSelection] using + ih nextLeft.value.1 leftNext rightNext nextLeft.state nextRight.state + nextLeft.remaining nextLeft.value.2 hnext hnextState + | inr message => + let observe : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_runPermissiveFromTable_of_stateRel + ((maskedSign parameter root ftsSecret message).run cache) + left right fuel table hstate) + intro leftResult rightResult hresult + apply relTriple_finishPermissiveDetailedSelection observe observe leftCandidates + leftCandidates leftResult rightResult rfl hresult + intro nextLeft nextRight hnext + rcases hnext with ⟨hnextState, hremaining, hvalue, htable⟩ + simpa only [observe, hremaining, hvalue, + delayedPermissiveDetailedOrdinalSelection] using + ih nextLeft.value.1 leftCandidates leftCandidates nextLeft.state nextRight.state + nextLeft.remaining nextLeft.value.2 rfl hnextState + +theorem relTriple_delayedPermissiveSelection_trans + (target : Position) (rightRoot : Digest) (ordinal : Nat) + {left : ProbComp (Option PrivateOrdinalSelection)} + {middle right : ProbComp (Option PermissivePrivateOrdinalSelection)} + (hleft : RelTriple left middle + (DelayedPermissiveSelectionRel target rightRoot ordinal)) + (hright : RelTriple middle right PermissiveDetailedSelectionRel) : + RelTriple left right + (DelayedPermissiveSelectionRel target rightRoot ordinal) := by + have hglued := SphincsSecurity.relTriple_trans_exists hleft hright + apply relTriple_post_mono hglued + intro leftSelection rightSelection hrelation hgood + obtain ⟨middleSelection, hfirst, hsecond⟩ := hrelation + have hmiddle := hfirst hgood + obtain ⟨leftOutput, leftSelected, middleSelected, hleftSelected, hmiddleSelected, hleftGood, + hcandidate, hcandidates, hposition, hvalue⟩ := hmiddle + cases hmiddleSelected + cases rightSelection with + | none => exact False.elim hsecond + | some rightSelected => + have hpositionEq := hsecond.positionFiber_eq + rcases hsecond with ⟨hmiddleCandidate, hmiddleCandidates, hstate⟩ + refine ⟨leftOutput, leftSelected, rightSelected, hleftSelected, rfl, + hleftGood, hcandidate.trans hmiddleCandidate, + hcandidates.trans hmiddleCandidates, ?_, ?_⟩ + · rw [← hpositionEq] + exact hposition + · rw [← hstate.values] + exact hvalue + +def DelayedHashActionCouples + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) : Prop := + ∀ (input : HashInput) (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache), + context.Valid → DeferredCompletable table context → + ChainState.ValidFor (fun _ ↦ True) context.state → + CanonicalMaterializedValues table context → + PublishedValues context.state → + RelTriple + (runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterPlan parameter input + (purePlanProbingHashQuery parameter input context.state)).run cache)) + (runPermissiveFromTable (materializedDeferredState context) fuel table + (delayedPermissivePublicAction parameter input table + (materializedDeferredState context) cache)) + (DirectWitnessPermissiveRunRel table) + +set_option maxRecDepth 100000 in +theorem delayedHashActionCouples + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) : + DelayedHashActionCouples table parameter := by + intro input context fuel cache hvalid hcompletable hchainValid hcanonical _hpublished + let plan := purePlanProbingHashQuery parameter input context.state + rw [runDirectResolvedWitnessFromTable_afterPlan_eq_publicPlan parameter input plan context fuel + table cache] + rw [delayedPermissivePublicAction_materializedDeferredState_eq parameter input table context + cache hvalid hcompletable hcanonical] + change RelTriple + (runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterPublicPlan parameter input context.state plan).run cache)) + (runPermissiveFromTable (materializedDeferredState context) fuel table + ((probingHashQueryAfterPublicPlan parameter input context.state plan).run cache)) + (DirectWitnessPermissiveRunRel table) + unfold probingHashQueryAfterPublicPlan + cases hcandidate : plan.candidate? with + | none => + simp only [executeCandidate?, pure_bind] + exact relTriple_runDirectResolvedWitness_runPermissiveFromTable + (probingHashQueryPublicAction parameter input context.state plan.action) + context fuel table cache hvalid hcompletable hchainValid + (preservesChainValid_probingHashQueryPublicAction_true parameter input context.state + plan.action) + (directWitnessFinalizationMaterializedCouples_publicAction table parameter input + context.state plan.action) + | some candidate => + cases fuel with + | zero => + simp [executeCandidate?, probe, LazyRevealProbe.probeQuery, + runDirectResolvedWitnessFromTable, runPermissiveFromTable, + DirectWitnessPermissiveRunRel] + | succ remaining => + simp only [executeCandidate?, StateT.run_bind, probe, StateT.run_liftM, + LazyRevealProbe.probeQuery, bind_assoc, pure_bind] + rw [runDirectResolvedWitnessFromTable_probe_query_bind, + runPermissiveFromTable_probe_query_bind] + have hmaterializedRevealed : + candidate.coordinate ∈ (materializedDeferredState context).revealed ↔ + candidate.coordinate ∈ context.state.revealed := by + rfl + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · have hrightRevealed : + candidate.coordinate ∈ (materializedDeferredState context).revealed := + hmaterializedRevealed.mpr hrevealed + simp only [hrevealed, hrightRevealed, ↓reduceIte] + exact relTriple_runDirectResolvedWitness_runPermissiveFromTable + (probingHashQueryPublicAction parameter input context.state plan.action) + context remaining table cache hvalid hcompletable hchainValid + (preservesChainValid_probingHashQueryPublicAction_true parameter input context.state + plan.action) + (directWitnessFinalizationMaterializedCouples_publicAction table parameter input + context.state plan.action) + · have hrightRevealed : + candidate.coordinate ∉ (materializedDeferredState context).revealed := by + rwa [hmaterializedRevealed] + simp only [hrevealed, hrightRevealed, ↓reduceIte] + let nextContext : DeferredContext := + { context with state := + context.state.addPending candidate.coordinate candidate.candidate } + have hmaterialized : materializedDeferredState nextContext = + (materializedDeferredState context).addPending candidate.coordinate + candidate.candidate := by + rcases context with ⟨state, values⟩ + rcases state with ⟨pending, stateValues, revealed, ensured⟩ + simp [nextContext, materializedDeferredState, DeferredContext.positionValue, + LazyRevealProbe.State.addPending] + rw [← hmaterialized] + by_cases hnextCompletable : DeferredCompletable table nextContext + · have hnextValid : nextContext.Valid := + hvalid.addPending_of_completable candidate.coordinate candidate.candidate + hnextCompletable + have hnextChainValid : ChainState.ValidFor (fun _ ↦ True) nextContext.state := by + exact hchainValid.addPending candidate.coordinate candidate.candidate + exact relTriple_runDirectResolvedWitness_runPermissiveFromTable + (probingHashQueryPublicAction parameter input context.state plan.action) + nextContext remaining table cache hnextValid hnextCompletable hnextChainValid + (preservesChainValid_probingHashQueryPublicAction_true parameter input context.state + plan.action) + (directWitnessFinalizationMaterializedCouples_publicAction table parameter input + context.state plan.action) + · let computation := + (probingHashQueryPublicAction parameter input context.state plan.action).run cache + have hbase := relTriple_true + (runDirectResolvedWitnessFromTable nextContext remaining table computation) + (runPermissiveFromTable (materializedDeferredState nextContext) remaining table + computation) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (runDirectResolvedWitnessFromTable nextContext remaining table computation)) + (fun result hresult => hresult) + apply relTriple_post_mono hsupported + intro leftResult _rightResult hrelation + cases leftResult with + | stoppedFuel => trivial + | stoppedOrdinary => trivial + | stoppedPrivate witness => trivial + | done result => + apply Or.inl + apply Or.inr + apply Or.inr + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable nextContext remaining table + computation) := by + rw [← map_erase_runDirectResolvedWitnessFromTable computation nextContext + remaining table, support_map] + exact ⟨.done result, hrelation.2, rfl⟩ + have hdirect : some result ∈ support + (runDirectResolvedFromTable nextContext remaining table computation) := + mem_support_runDirectResolvedFromTable_of_done_detailed computation nextContext + remaining table result hdetailed + have hconsistent : nextContext.ValuesConsistent := + hvalid.valuesConsistent.addPending candidate.coordinate candidate.candidate + have hstarts : StartTableAgrees nextContext.state table := by + have hcontextStarts : StartTableAgrees context.state table := by + rw [← canonicalizeMaterializedValues_eq_of_canonical table context hcanonical] + exact canonicalizeMaterializedValues_startTableAgrees table context + exact hcontextStarts.addPending candidate.coordinate candidate.candidate + have hfinalCore := resolvedCore_of_mem_runDirectResolvedFromTable computation + nextContext remaining table result hconsistent hstarts hdirect + have hfinalNotCompletable := + not_deferredCompletable_of_mem_runDirectResolvedFromTable computation + nextContext remaining table result hconsistent hstarts hdirect + hnextCompletable + exact (doomedResolvedContext_canonicalizeMaterializedValues + (table := table) (context := result.context) + ⟨hfinalCore.2.1, hfinalCore.2.2, hfinalNotCompletable⟩).2.2 + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_directBoundary_delayedPermissiveDetailedOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (target : Position) (rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hroot : IsLayerRoot target) (hvalid : context.Valid) + (hcompletable : DeferredCompletable table context) + (hchainValid : ChainState.ValidFor (fun _ ↦ True) context.state) + (hcanonical : CanonicalMaterializedValues table context) + (hpublished : PublishedValues context.state) + (hhash : DelayedHashActionCouples table parameter) : + RelTriple + (directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret computation + candidates context fuel table cache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates (materializedDeferredState context) fuel table cache) + (DelayedPermissiveSelectionRel target rightRoot ordinal) := by + induction computation using OracleComp.inductionOn generalizing + candidates context fuel cache with + | pure value => + simp only [directDetailedBoundaryPrivateOrdinalSelection, + delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp only [selectedPrivateOrdinal?, hselected, ↓reduceDIte] + exact relTriple_pure_pure + (delayedPermissiveSelectionRel_selected target rightRoot ordinal hroot + _ candidates context (materializedDeferredState context) rfl (by + simp [materializedDeferredState])) + · simp only [selectedPrivateOrdinal?, hselected, ↓reduceDIte] + exact relTriple_pure_pure (by + simp [DelayedPermissiveSelectionRel, privateOrdinalSelectionGoodForSomeOutput]) + | query_bind query next ih => + rw [directDetailedBoundaryPrivateOrdinalSelection, OracleComp.construct_query_bind, + delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure + (delayedPermissiveSelectionRel_selected target rightRoot ordinal hroot + _ candidates context (materializedDeferredState context) rfl (by + simp [materializedDeferredState])) + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let leftObserve : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection) := + fun nextContext remaining value laterCandidates => + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret + (next value.1) laterCandidates nextContext remaining table value.2 + let rightObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_runDirectResolvedWitness_runPermissiveFromTable + (splitUniformImpl n) context fuel table cache hvalid hcompletable hchainValid + (preservesChainValid_splitUniformImpl (fun _ ↦ True) n) + (directWitnessFinalizationMaterializedCouples_splitUniformImpl table n)) + intro leftResult rightResult hresult + apply relTriple_finishDirect_delayedPermissiveSelection target rightRoot + ordinal table leftObserve rightObserve candidates candidates leftResult + rightResult hresult + intro nextLeft nextRight _hleft _hright hvalue hremaining hvalues hrevealed + hnextValid hnextCompletable hnextChainValid hnextCanonical hnextPublished + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hbase := ih nextLeft.value.1 candidates canonical nextLeft.remaining + nextLeft.value.2 hnextValid hnextCompletable hnextChainValid + hnextCanonical hnextPublished + have hstate : PermissiveStateRel (materializedDeferredState canonical) + nextRight.state := ⟨hvalues, hrevealed⟩ + have htransport := + relTriple_delayedPermissiveDetailedOrdinalSelection_of_stateRel ordinal + parameter root ftsSecret (next nextLeft.value.1) candidates candidates + (materializedDeferredState canonical) nextRight.state nextLeft.remaining table + nextLeft.value.2 rfl hstate + simpa only [leftObserve, rightObserve, canonical, ← hvalue, ← hremaining] using + relTriple_delayedPermissiveSelection_trans target rightRoot ordinal + hbase htransport + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + have hrightCandidates : + permissiveRootAwareCandidates parameter input table + (materializedDeferredState context) candidates = nextCandidates := by + exact permissiveRootAwareCandidates_materializedDeferredState_eq parameter input + table context candidates hvalid hcompletable hcanonical + by_cases hnextSelected : ordinal < nextCandidates.length + · have hrightSelected : ordinal < + (permissiveRootAwareCandidates parameter input table + (materializedDeferredState context) candidates).length := by + rwa [hrightCandidates] + simp only [nextCandidates, hnextSelected, hrightSelected, ↓reduceDIte] + have hcandidate : + nextCandidates.get ⟨ordinal, hnextSelected⟩ = + (permissiveRootAwareCandidates parameter input table + (materializedDeferredState context) candidates).get + ⟨ordinal, hrightSelected⟩ := by + rw [List.get_eq_getElem, List.get_eq_getElem] + simpa only [hrightCandidates] + apply relTriple_pure_pure + change DelayedPermissiveSelectionRel target rightRoot ordinal + (some ⟨nextCandidates.get ⟨ordinal, hnextSelected⟩, context, + nextCandidates⟩) + (some ⟨(permissiveRootAwareCandidates parameter input table + (materializedDeferredState context) candidates).get + ⟨ordinal, hrightSelected⟩, + materializedDeferredState context, + permissiveRootAwareCandidates parameter input table + (materializedDeferredState context) candidates⟩) + intro hgood + obtain ⟨leftOutput, hgood⟩ := hgood + change PrivateOrdinalSelection.GoodForRoots target leftOutput rightRoot ordinal + ⟨nextCandidates.get ⟨ordinal, hnextSelected⟩, context, + nextCandidates⟩ at hgood + refine ⟨leftOutput, ⟨nextCandidates.get ⟨ordinal, hnextSelected⟩, context, + nextCandidates⟩, + ⟨(permissiveRootAwareCandidates parameter input table + (materializedDeferredState context) candidates).get + ⟨ordinal, hrightSelected⟩, + materializedDeferredState context, + permissiveRootAwareCandidates parameter input table + (materializedDeferredState context) candidates⟩, + rfl, rfl, hgood, hcandidate, ?_, ?_, ?_⟩ + · exact hrightCandidates.symm + · apply permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?_eq_some_of_candidate + · have hsource := congrArg Probe.coordinate hgood.1 + change (nextCandidates.get ⟨ordinal, hnextSelected⟩).coordinate = + .position target at hsource + have hsame := congrArg Probe.coordinate hcandidate.symm + exact hsame.trans hsource + · exact hroot + · simpa [materializedDeferredState] using hgood.2.2.1 + · simp only [materializedDeferredState, DeferredContext.positionValue] + rw [hgood.2.1] + exact hgood.2.2.2.1 + · have hrightSelected : ¬ordinal < + (permissiveRootAwareCandidates parameter input table + (materializedDeferredState context) candidates).length := by + rwa [hrightCandidates] + simp only [nextCandidates, hnextSelected, hrightSelected, ↓reduceDIte] + let leftObserve : DeferredContext → Nat → + (HashOutput × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection) := + fun nextContext remaining value laterCandidates => + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root + ftsSecret (next value.1) laterCandidates nextContext remaining table value.2 + let rightObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_bind (hhash input context fuel cache hvalid hcompletable + hchainValid hcanonical hpublished) + intro leftResult rightResult hresult + apply relTriple_finishDirect_delayedPermissiveSelection target rightRoot ordinal + table leftObserve rightObserve nextCandidates + (permissiveRootAwareCandidates parameter input table + (materializedDeferredState context) candidates) + leftResult rightResult hresult + intro nextLeft nextRight _hleft _hright hvalue hremaining hvalues hrevealed + hnextValid hnextCompletable hnextChainValid hnextCanonical hnextPublished + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hbase := ih nextLeft.value.1 nextCandidates canonical nextLeft.remaining + nextLeft.value.2 hnextValid hnextCompletable hnextChainValid + hnextCanonical hnextPublished + have hstate : PermissiveStateRel (materializedDeferredState canonical) + nextRight.state := ⟨hvalues, hrevealed⟩ + have htransport := + relTriple_delayedPermissiveDetailedOrdinalSelection_of_stateRel ordinal + parameter root ftsSecret (next nextLeft.value.1) nextCandidates + (permissiveRootAwareCandidates parameter input table + (materializedDeferredState context) candidates) + (materializedDeferredState canonical) nextRight.state nextLeft.remaining + table nextLeft.value.2 hrightCandidates.symm hstate + simpa only [leftObserve, rightObserve, canonical, ← hvalue, ← hremaining] using + relTriple_delayedPermissiveSelection_trans target rightRoot ordinal + hbase htransport + | inr message => + let leftObserve : DeferredContext → Nat → + (Option Signature × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection) := + fun nextContext remaining value laterCandidates => + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret + (next value.1) laterCandidates nextContext remaining table value.2 + let rightObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_runDirectResolvedWitness_runPermissiveFromTable + (maskedSign parameter root ftsSecret message) context fuel table cache hvalid + hcompletable hchainValid + (preservesChainValid_maskedSign_true parameter root ftsSecret message) + (directWitnessFinalizationMaterializedCouples_maskedSign table parameter root + ftsSecret message)) + intro leftResult rightResult hresult + apply relTriple_finishDirect_delayedPermissiveSelection target rightRoot + ordinal table leftObserve rightObserve candidates candidates leftResult + rightResult hresult + intro nextLeft nextRight _hleft _hright hvalue hremaining hvalues hrevealed + hnextValid hnextCompletable hnextChainValid hnextCanonical hnextPublished + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hbase := ih nextLeft.value.1 candidates canonical nextLeft.remaining + nextLeft.value.2 hnextValid hnextCompletable hnextChainValid + hnextCanonical hnextPublished + have hstate : PermissiveStateRel (materializedDeferredState canonical) + nextRight.state := ⟨hvalues, hrevealed⟩ + have htransport := + relTriple_delayedPermissiveDetailedOrdinalSelection_of_stateRel ordinal parameter + root ftsSecret (next nextLeft.value.1) candidates candidates + (materializedDeferredState canonical) nextRight.state nextLeft.remaining table + nextLeft.value.2 rfl hstate + simpa only [leftObserve, rightObserve, canonical, ← hvalue, ← hremaining] using + relTriple_delayedPermissiveSelection_trans target rightRoot ordinal + hbase htransport + +noncomputable def delayedPermissiveDetailedSelectionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp (Option PermissivePrivateOrdinalSelection) := + delayedPermissiveDetailedOrdinalSelection ordinal parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] rootResult.state + rootResult.remaining rootResult.table rootResult.value.2 + +theorem directWitnessFinalizationMaterializedCouples_maskedPublishedTreeRoot + (table : OtsSecretIndex → HashOutput) : + DirectWitnessFinalizationMaterializedCouples table maskedPublishedTreeRoot := by + unfold maskedPublishedTreeRoot + apply (directWitnessFinalizationMaterializedCouples_ensureTreeNode table topLayer rootTree + (layerHeight topLayer) 0).bind + intro _ + exact directWitnessFinalizationMaterializedCouples_revealPublishedCoordinate table + (.position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0)) + +noncomputable def delayedPermissiveDetailedSelectionObserve + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (state : LazyRevealProbe.State Coordinate) (remaining : Nat) + (root : Digest) (cache : SplitHashCache) (candidates : List Probe) : + ProbComp (Option PermissivePrivateOrdinalSelection) := + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (retainedGameRestComputation adversary ⟨root, parameter⟩) candidates state remaining table cache + +noncomputable def finishDelayedPermissiveDetailedSelection + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : Option (CleanRunResult (Digest × SplitHashCache))) : + ProbComp (Option PermissivePrivateOrdinalSelection) := + finishPermissiveDetailedPrivateOrdinalSelection + (delayedPermissiveDetailedSelectionObserve ordinal adversary parameter table ftsSecret) [] result + +noncomputable def delayedPermissiveDetailedSelectionExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (Option PermissivePrivateOrdinalSelection) := do + let rootResult ← rootAwareProductionInitialRun fuel table + match rootResult with + | none => pure none + | some result => + delayedPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter ftsSecret result + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_finishGranularPrivateOrdinalSelection_delayed + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rightRoot : Digest) (hroot : IsLayerRoot target) + (leftResult : DirectWitnessResult (Digest × SplitHashCache)) + (rightResult : Option (CleanRunResult (Digest × SplitHashCache))) + (hresult : DirectWitnessPermissiveRunRel table leftResult rightResult) : + RelTriple + (finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (granularPrivateOrdinalSelectionObserve ordinal adversary parameter table ftsSecret)) [] + leftResult) + (finishDelayedPermissiveDetailedSelection ordinal adversary parameter table ftsSecret + rightResult) + (DelayedPermissiveSelectionRel target rightRoot ordinal) := by + unfold finishDelayedPermissiveDetailedSelection + apply relTriple_finishDirect_delayedPermissiveSelection target rightRoot ordinal table + (granularPrivateOrdinalSelectionObserve ordinal adversary parameter table ftsSecret) + (delayedPermissiveDetailedSelectionObserve ordinal adversary parameter table ftsSecret) + [] [] leftResult rightResult hresult + intro left right _hleft _hright hvalue hremaining hvalues hrevealed hvalid hcompletable + hchainValid hcanonical hpublished + have hbase := relTriple_directBoundary_delayedPermissiveDetailedOrdinalSelection ordinal + parameter left.value.1 target rightRoot ftsSecret + (retainedGameRestComputation adversary ⟨left.value.1, parameter⟩) [] + (canonicalizeMaterializedValues table left.context) left.remaining table left.value.2 hroot + hvalid hcompletable hchainValid hcanonical hpublished (delayedHashActionCouples table parameter) + have hstate : PermissiveStateRel + (materializedDeferredState (canonicalizeMaterializedValues table left.context)) right.state := + ⟨hvalues, hrevealed⟩ + have htransport := + relTriple_delayedPermissiveDetailedOrdinalSelection_of_stateRel ordinal parameter left.value.1 + ftsSecret (retainedGameRestComputation adversary ⟨left.value.1, parameter⟩) [] [] + (materializedDeferredState (canonicalizeMaterializedValues table left.context)) right.state + left.remaining table left.value.2 rfl hstate + simpa only [granularPrivateOrdinalSelectionObserve, delayedPermissiveDetailedSelectionObserve, + ← hvalue, ← hremaining] using + relTriple_delayedPermissiveSelection_trans target rightRoot ordinal hbase htransport + +theorem granularAllCanonicalPrivateOrdinalSelection_eq_bind_finish + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret fuel = + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) >>= + finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (granularPrivateOrdinalSelectionObserve ordinal adversary parameter table ftsSecret)) + []) := by + rfl + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_granularAllCanonicalPrivateOrdinalSelection_permissiveDelayed + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (target : Position) (rightRoot : Digest) + (hroot : IsLayerRoot target) : + RelTriple + (granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret fuel) + (delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table) + (DelayedPermissiveSelectionRel target rightRoot ordinal) := by + rw [granularAllCanonicalPrivateOrdinalSelection_eq_bind_finish] + unfold delayedPermissiveDetailedSelectionExperimentAfterTable rootAwareProductionInitialRun + have hempty : materializedDeferredState emptyWitnessDeferredContext = + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) := by + unfold materializedDeferredState emptyWitnessDeferredContext LazyRevealProbe.State.empty + rw [LazyRevealProbe.State.mk.injEq] + refine ⟨rfl, ?_, rfl, rfl⟩ + funext coordinate + cases coordinate <;> rfl + have hinitial : RelTriple + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) + (runCleanFromTable (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)) + (DirectWitnessPermissiveRunRel table) := by + rw [← hempty] + exact relTriple_runDirectResolvedWitness_runCleanFromTable maskedPublishedTreeRoot + emptyWitnessDeferredContext fuel table emptySplitHashCache DeferredContext.valid_empty + (deferredCompletable_empty table) + (by simp [ChainState.ValidFor, emptyWitnessDeferredContext, + LazyRevealProbe.State.empty]) + preservesChainValid_maskedPublishedTreeRoot_true + (directWitnessFinalizationMaterializedCouples_maskedPublishedTreeRoot table) + refine relTriple_bind + (R := DirectWitnessPermissiveRunRel table) + hinitial ?_ + intro leftResult rightResult hresult + have hfixed := relTriple_finishGranularPrivateOrdinalSelection_delayed ordinal adversary + parameter table ftsSecret target rightRoot hroot leftResult rightResult hresult + cases leftResult with + | stoppedFuel => + exact relTriple_none_any_delayedPermissiveSelection target rightRoot ordinal _ + | stoppedOrdinary => + exact relTriple_none_any_delayedPermissiveSelection target rightRoot ordinal _ + | stoppedPrivate witness => + exact relTriple_none_any_delayedPermissiveSelection target rightRoot ordinal _ + | done leftResult => + rcases hresult with hreject | ⟨cleanResult, hright, hvalue, hremaining, + hleftTable, hrightTable, hrevealed, hmaterialized, hchainValid, hcontext⟩ + · rcases hreject with hprivate | hpublished | hcompletable + · rw [show finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (granularPrivateOrdinalSelectionObserve ordinal adversary parameter table + ftsSecret)) [] (.done leftResult) = pure none by + simp [finishDirectPrivateOrdinalSelection, + canonicalizeDirectPrivateOrdinalSelection, hprivate]] + exact relTriple_none_any_delayedPermissiveSelection target rightRoot ordinal _ + · rw [show finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (granularPrivateOrdinalSelectionObserve ordinal adversary parameter table + ftsSecret)) [] (.done leftResult) = pure none by + simp [finishDirectPrivateOrdinalSelection, + canonicalizeDirectPrivateOrdinalSelection, hpublished]] + exact relTriple_none_any_delayedPermissiveSelection target rightRoot ordinal _ + · rw [show finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (granularPrivateOrdinalSelectionObserve ordinal adversary parameter table + ftsSecret)) [] (.done leftResult) = pure none by + simp [finishDirectPrivateOrdinalSelection, + canonicalizeDirectPrivateOrdinalSelection, hcompletable]] + exact relTriple_none_any_delayedPermissiveSelection target rightRoot ordinal _ + · subst rightResult + change RelTriple + (finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (granularPrivateOrdinalSelectionObserve ordinal adversary parameter table + ftsSecret)) [] (.done leftResult)) + (delayedPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret cleanResult) + (DelayedPermissiveSelectionRel target rightRoot ordinal) + rw [show delayedPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret cleanResult = + finishDelayedPermissiveDetailedSelection ordinal adversary parameter table ftsSecret + (some cleanResult) by + simp only [delayedPermissiveDetailedSelectionAfterRootResult, + finishDelayedPermissiveDetailedSelection, + finishPermissiveDetailedPrivateOrdinalSelection, + delayedPermissiveDetailedSelectionObserve] + rw [hrightTable]] + exact hfixed + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceHidden.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceHidden.lean new file mode 100644 index 00000000..f7daf275 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceHidden.lean @@ -0,0 +1,620 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSource + +/-! +# Chronological hiddenness of source snapshots + +The retained private witness records the revealed-coordinate set at its exact stop. This file +proves that revealed coordinates only grow on the way to such a stop. Combined with canonical +candidate-time contexts, this makes the selected layer-root snapshot hidden. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +theorem PublishedValues.not_revealed_of_value_none + {context : DeferredContext} + (hpublished : PublishedValues context.state) + {coordinate : Coordinate} (hvalue : context.state.values coordinate = none) : + coordinate ∉ context.state.revealed := by + intro hrevealed + exact (hpublished coordinate hrevealed) hvalue + +theorem deferredValue_eq_of_positionValue_eq_of_state_none + {context : DeferredContext} {position : Position} {output : HashOutput} + (hstate : context.state.values (.position position) = none) + (hvalue : context.positionValue position = some output) : + context.values position = some output := by + simpa [DeferredContext.positionValue, hstate] using hvalue + +theorem witnessFirstUsesSomeDelayedLayerRootSnapshot_of_sourceFacts + {output : PrivateWitnessSnapshotOutput} + (hroot : WitnessFirstUsesSomeLayerRoot + (erasePrivateWitnessSnapshotOutput output)) + (hpublished : ∀ snapshot ∈ output.2, + PublishedValues snapshot.context.state) + (hsource : ∀ witness (sourceOrdinal : Fin output.2.length), + output.1 = some witness → + firstPrivateWitnessOrdinal? witness + (output.2.map PlannedProbeSnapshot.toProbe) = + some (snapshotProbeOrdinal sourceOrdinal) → + (output.2.get sourceOrdinal).context.state.values + (.position witness.position) = none ∧ + (output.2.get sourceOrdinal).context.positionValue witness.position = + some witness.output) : + WitnessFirstUsesSomeDelayedLayerRootSnapshot output := by + unfold erasePrivateWitnessSnapshotOutput at hroot + obtain ⟨ordinal, witness, planOrdinal, hwitness, hordinal, hfirst, hrootProbe⟩ := hroot + let sourceOrdinal : Fin output.2.length := + ⟨planOrdinal.val, by simpa only [List.length_map] using planOrdinal.isLt⟩ + have hplanOrdinal : snapshotProbeOrdinal sourceOrdinal = planOrdinal := by + apply Fin.ext + rfl + have hsourceFirst : firstPrivateWitnessOrdinal? witness + (output.2.map PlannedProbeSnapshot.toProbe) = + some (snapshotProbeOrdinal sourceOrdinal) := by + rw [hplanOrdinal] + exact hfirst + obtain ⟨hstate, hpositionValue⟩ := + hsource witness sourceOrdinal hwitness hsourceFirst + have hsnapshotPublished := hpublished (output.2.get sourceOrdinal) + (List.get_mem _ _) + refine ⟨ordinal, witness, sourceOrdinal, hwitness, ?_, hsourceFirst, ?_, hstate, ?_, ?_⟩ + · exact hordinal ▸ rfl + · rw [← hplanOrdinal] at hrootProbe + simpa only [List.get_eq_getElem, List.getElem_map, + PlannedProbeSnapshot.toProbe, snapshotProbeOrdinal_val] using hrootProbe + · exact hsnapshotPublished.not_revealed_of_value_none hstate + · exact deferredValue_eq_of_positionValue_eq_of_state_none hstate hpositionValue + +set_option maxRecDepth 100000 in +theorem revealed_subset_privateWitness_of_mem_runDirectResolvedWitnessFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (witness : PrivateHitWitness) + (hresult : DirectWitnessResult.stoppedPrivate witness ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) : + context.state.revealed ⊆ witness.revealed := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runDirectResolvedWitnessFromTable] at hresult + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectResolvedWitnessFromTable_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hrest + | hashOutput => + rw [runDirectResolvedWitnessFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hrest + | ensure coordinate => + rw [runDirectResolvedWitnessFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel hresult + | probe coordinate candidate => + rw [runDirectResolvedWitnessFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · exact ih () context remaining (by simpa [hrevealed] using hresult) + · exact ih () + { context with state := context.state.addPending coordinate candidate } + remaining (by simpa [hrevealed] using hresult) + | peek coordinate => + rw [runDirectResolvedWitnessFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hresult + | publish coordinate => + rw [runDirectResolvedWitnessFromTable_publish_query_bind] at hresult + have htail := ih () + { context with state := context.state.publish coordinate } fuel hresult + intro other hother + apply htail + simp [LazyRevealProbe.State.publish, hother] + | reveal coordinate => + rw [runDirectResolvedWitnessFromTable_reveal_query_bind] at hresult + cases hstate : context.state.values coordinate with + | some output => + simp only [hstate] at hresult + exact ih output context fuel hresult + | none => + simp only [hstate] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + exact ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel hresult + | position target => + cases hprivate : context.values target with + | some output => + by_cases hhit : context.state.hitAt (.position target) output + · simp only [hprivate, hhit, ↓reduceIte] at hresult + have hwitness : witness = + ⟨target, output, context.state.revealed⟩ := by + simpa using hresult + subst witness + exact Finset.Subset.rfl + · simp only [hprivate, hhit, ↓reduceIte] at hresult + exact ih output + { state := context.state.materialize (.position target) output + values := context.values } + fuel hresult + | none => + simp only [hprivate, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : context.state.hitAt (.position target) output + · simp [hhit] at hrest + · simp only [hhit, ↓reduceIte] at hrest + exact ih output + { state := context.state.materialize (.position target) output + values := context.values.install target output } + fuel hrest + +set_option maxRecDepth 100000 in +theorem revealed_subset_done_of_mem_runDirectResolvedWitnessFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) : + context.state.revealed ⊆ result.context.state.revealed := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runDirectResolvedWitnessFromTable] at hresult + subst result + exact Finset.Subset.rfl + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectResolvedWitnessFromTable_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hrest + | hashOutput => + rw [runDirectResolvedWitnessFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hrest + | ensure coordinate => + rw [runDirectResolvedWitnessFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel hresult + | probe coordinate candidate => + rw [runDirectResolvedWitnessFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · exact ih () context remaining (by simpa [hrevealed] using hresult) + · exact ih () + { context with state := context.state.addPending coordinate candidate } + remaining (by simpa [hrevealed] using hresult) + | peek coordinate => + rw [runDirectResolvedWitnessFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hresult + | publish coordinate => + rw [runDirectResolvedWitnessFromTable_publish_query_bind] at hresult + have htail := ih () + { context with state := context.state.publish coordinate } fuel hresult + intro other hother + apply htail + simp [LazyRevealProbe.State.publish, hother] + | reveal coordinate => + rw [runDirectResolvedWitnessFromTable_reveal_query_bind] at hresult + cases hstate : context.state.values coordinate with + | some output => + simp only [hstate] at hresult + exact ih output context fuel hresult + | none => + simp only [hstate] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + exact ih output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + fuel hresult + | position target => + cases hprivate : context.values target with + | some output => + by_cases hhit : context.state.hitAt (.position target) output + · simp [hprivate, hhit] at hresult + · simp only [hprivate, hhit, ↓reduceIte] at hresult + exact ih output + { state := context.state.materialize (.position target) output + values := context.values } + fuel hresult + | none => + simp only [hprivate, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : context.state.hitAt (.position target) output + · simp [hhit] at hrest + · simp only [hhit, ↓reduceIte] at hrest + exact ih output + { state := context.state.materialize (.position target) output + values := context.values.install target output } + fuel hrest + +set_option maxRecDepth 100000 in +theorem privateValue_eq_privateWitness_of_mem_runDirectResolvedWitnessFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (witness : PrivateHitWitness) + (position : Position) (output : HashOutput) + (hvalue : context.values position = some output) + (hposition : position = witness.position) + (hresult : DirectWitnessResult.stoppedPrivate witness ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) : + output = witness.output := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => simp [runDirectResolvedWitnessFromTable] at hresult + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectResolvedWitnessFromTable_uniform_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨sampled, _hsampled, hrest⟩ := hresult + exact ih sampled context fuel hvalue hrest + | hashOutput => + rw [runDirectResolvedWitnessFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨sampled, _hsampled, hrest⟩ := hresult + exact ih sampled context fuel hvalue hrest + | ensure coordinate => + rw [runDirectResolvedWitnessFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel hvalue hresult + | probe coordinate candidate => + rw [runDirectResolvedWitnessFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · exact ih () context remaining hvalue (by simpa [hrevealed] using hresult) + · exact ih () + { context with state := context.state.addPending coordinate candidate } + remaining hvalue (by simpa [hrevealed] using hresult) + | peek coordinate => + rw [runDirectResolvedWitnessFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hvalue hresult + | publish coordinate => + rw [runDirectResolvedWitnessFromTable_publish_query_bind] at hresult + exact ih () { context with state := context.state.publish coordinate } fuel hvalue hresult + | reveal coordinate => + rw [runDirectResolvedWitnessFromTable_reveal_query_bind] at hresult + cases hstate : context.state.values coordinate with + | some sampled => + simp only [hstate] at hresult + exact ih sampled context fuel hvalue hresult + | none => + simp only [hstate] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let sampled := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) sampled + · simp [sampled, hhit] at hresult + · simp only [sampled, hhit, ↓reduceIte] at hresult + exact ih sampled + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) sampled + values := context.values } + fuel hvalue hresult + | position target => + cases hprivate : context.values target with + | some sampled => + by_cases hhit : context.state.hitAt (.position target) sampled + · simp only [hprivate, hhit, ↓reduceIte] at hresult + have hwitness : witness = + ⟨target, sampled, context.state.revealed⟩ := by + simpa using hresult + subst witness + subst position + exact Option.some.inj (hvalue.symm.trans hprivate) + · simp only [hprivate, hhit, ↓reduceIte] at hresult + exact ih sampled + { state := context.state.materialize (.position target) sampled + values := context.values } + fuel hvalue hresult + | none => + simp only [hprivate, mem_support_bind_iff] at hresult + obtain ⟨sampled, _hsampled, hrest⟩ := hresult + by_cases hhit : context.state.hitAt (.position target) sampled + · simp [hhit] at hrest + · simp only [hhit, ↓reduceIte] at hrest + have hne : position ≠ target := by + intro heq + subst target + rw [hprivate] at hvalue + simp at hvalue + have hnextValue : + context.values.install target sampled position = some output := by + simpa [DeferredStructuralValues.install, + Function.update_of_ne hne] using hvalue + exact ih sampled + { state := context.state.materialize (.position target) sampled + values := context.values.install target sampled } + fuel hnextValue hrest + +theorem publishedValues_of_done_runDirectResolvedWitnessFromTable + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hpreserves : PreservesPublishedValues computation) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) + (hpublished : PublishedValues context.state) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table (computation.run cache))) : + PublishedValues result.context.state := by + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table (computation.run cache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable (computation.run cache) context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + exact publishedValues_of_done_runDirectResolvedDetailedFromTable computation hpreserves context + fuel table cache result hpublished hdetailed + +def SnapshotsPublished (snapshots : List PlannedProbeSnapshot) : Prop := + ∀ snapshot ∈ snapshots, PublishedValues snapshot.context.state + +theorem SnapshotsPublished.appendPlannedSnapshot + {snapshots : List PlannedProbeSnapshot} + (hsnapshots : SnapshotsPublished snapshots) + (candidate? : Option Probe) (context : DeferredContext) + (hpublished : PublishedValues context.state) : + SnapshotsPublished (appendPlannedSnapshot snapshots candidate? context) := by + cases candidate? with + | none => exact hsnapshots + | some candidate => + intro snapshot hsnapshot + change snapshot ∈ snapshots ++ [⟨candidate, context⟩] at hsnapshot + simp only [List.mem_append, List.mem_singleton] at hsnapshot + rcases hsnapshot with hold | rfl + · exact hsnapshots snapshot hold + · exact hpublished + +theorem snapshotsPublished_of_mem_finishDirectWitnessSnapshotObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) (result : DirectWitnessResult α) + (hsnapshots : SnapshotsPublished snapshots) + (hobserve : ∀ resolved output, + result = .done resolved → + output ∈ support + (observe resolved.context resolved.remaining resolved.value snapshots) → + SnapshotsPublished output.2) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (finishDirectWitnessSnapshotObserve observe snapshots result)) : + SnapshotsPublished output.2 := by + cases result with + | stoppedFuel => + simp [finishDirectWitnessSnapshotObserve] at houtput + subst output + exact hsnapshots + | stoppedOrdinary => + simp [finishDirectWitnessSnapshotObserve] at houtput + subst output + exact hsnapshots + | stoppedPrivate witness => + simp [finishDirectWitnessSnapshotObserve] at houtput + subst output + exact hsnapshots + | done resolved => + exact hobserve resolved output rfl (by + simpa [finishDirectWitnessSnapshotObserve] using houtput) + +theorem snapshotsPublished_of_mem_runDirectWitnessSnapshotObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hsnapshots : SnapshotsPublished snapshots) + (hobserve : ∀ result output, + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation) → + output ∈ support + (observe result.context result.remaining result.value snapshots) → + SnapshotsPublished output.2) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (runDirectWitnessSnapshotObserve observe snapshots context fuel table computation)) : + SnapshotsPublished output.2 := by + unfold runDirectWitnessSnapshotObserve at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + apply snapshotsPublished_of_mem_finishDirectWitnessSnapshotObserve observe snapshots result + hsnapshots _ output hfinish + intro resolved nextOutput heq hnext + subst result + exact hobserve resolved nextOutput hresult hnext + +theorem snapshotsPublished_of_mem_classifyDirectWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (context : DeferredContext) (fuel : Nat) (value : α) + (snapshots : List PlannedProbeSnapshot) + (hsnapshots : SnapshotsPublished snapshots) + (hobserve : ∀ output ∈ support (observe context fuel value snapshots), + SnapshotsPublished output.2) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (classifyDirectWitnessSnapshotObserve table observe context fuel value snapshots)) : + SnapshotsPublished output.2 := by + classical + unfold classifyDirectWitnessSnapshotObserve at houtput + by_cases hhit : PrivateStructuralHit context + · simp [hhit] at houtput + subst output + exact hsnapshots + · simp only [hhit, ↓reduceDIte] at houtput + by_cases hcompletable : DeferredCompletable table context + · exact hobserve output (by simpa [hcompletable] using houtput) + · simp [hcompletable] at houtput + subst output + exact hsnapshots + +theorem snapshotsPublished_of_mem_canonicalizeDirectWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (context : DeferredContext) (fuel : Nat) (value : α) + (snapshots : List PlannedProbeSnapshot) + (hsnapshots : SnapshotsPublished snapshots) + (hobserve : PublishedValues context.state → + ∀ output ∈ support + (observe (canonicalizeMaterializedValues table context) fuel value snapshots), + SnapshotsPublished output.2) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (canonicalizeDirectWitnessSnapshotObserve table observe context fuel value snapshots)) : + SnapshotsPublished output.2 := by + classical + let canonical := canonicalizeMaterializedValues table context + unfold canonicalizeDirectWitnessSnapshotObserve at houtput + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit] at houtput + subst output + exact hsnapshots + · simp only [canonical, hhit, ↓reduceDIte] at houtput + by_cases hpublished : PublishedValues context.state + · apply snapshotsPublished_of_mem_classifyDirectWitnessSnapshotObserve table observe canonical + fuel value snapshots hsnapshots + · exact hobserve hpublished + · simpa [hpublished] using houtput + · simp [hpublished] at houtput + subst output + exact hsnapshots + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem snapshotsPublished_of_mem_directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hsnapshots : SnapshotsPublished snapshots) + (hpublished : PublishedValues context.state) + (hobserve : ∀ nextContext remaining value nextSnapshots, + SnapshotsPublished nextSnapshots → PublishedValues nextContext.state → + ∀ output ∈ support (observe nextContext remaining value nextSnapshots), + SnapshotsPublished output.2) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root ftsSecret + computation observe snapshots context fuel table cache)) : + SnapshotsPublished output.2 := by + induction computation using OracleComp.inductionOn generalizing + snapshots context fuel cache output with + | pure value => + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_pure] at houtput + exact hobserve context fuel (value, cache) snapshots hsnapshots hpublished output houtput + | query_bind query next ih => + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_query_bind] at houtput + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + apply snapshotsPublished_of_mem_runDirectWitnessSnapshotObserve _ snapshots + context fuel table ((splitUniformImpl n).run cache) hsnapshots _ output houtput + intro result nextOutput _hresult hnext + apply snapshotsPublished_of_mem_canonicalizeDirectWitnessSnapshotObserve table _ + result.context result.remaining result.value snapshots hsnapshots _ nextOutput hnext + intro hnextPublished finalOutput hfinal + exact ih result.value.1 snapshots + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hsnapshots + hnextPublished.to_canonicalizedMaterializedValues finalOutput hfinal + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let nextSnapshots := appendPlannedSnapshot snapshots + (rootAwarePlannedCandidate? parameter input context.state) context + have hnextSnapshots : SnapshotsPublished nextSnapshots := + hsnapshots.appendPlannedSnapshot _ context hpublished + apply snapshotsPublished_of_mem_runDirectWitnessSnapshotObserve _ nextSnapshots + context fuel table ((probingHashQueryAfterPlan parameter input plan).run cache) + hnextSnapshots _ output houtput + intro result nextOutput _hresult hnext + apply snapshotsPublished_of_mem_canonicalizeDirectWitnessSnapshotObserve table _ + result.context result.remaining result.value nextSnapshots hnextSnapshots _ + nextOutput hnext + intro hnextPublished finalOutput hfinal + exact ih result.value.1 nextSnapshots + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hnextSnapshots + hnextPublished.to_canonicalizedMaterializedValues finalOutput hfinal + | inr message => + apply snapshotsPublished_of_mem_runDirectWitnessSnapshotObserve _ snapshots context fuel + table ((maskedSign parameter root ftsSecret message).run cache) hsnapshots _ output + houtput + intro result nextOutput _hresult hnext + apply snapshotsPublished_of_mem_canonicalizeDirectWitnessSnapshotObserve table _ + result.context result.remaining result.value snapshots hsnapshots _ nextOutput hnext + intro hnextPublished finalOutput hfinal + exact ih result.value.1 snapshots + (canonicalizeMaterializedValues table result.context) result.remaining result.value.2 + hsnapshots hnextPublished.to_canonicalizedMaterializedValues finalOutput hfinal + +theorem snapshotsPublished_of_mem_retainedResolvedFinalizationPrivateWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) + (snapshots : List PlannedProbeSnapshot) + (hsnapshots : SnapshotsPublished snapshots) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table root context fuel value + snapshots)) : + SnapshotsPublished output.2 := by + classical + unfold retainedResolvedFinalizationPrivateWitnessSnapshotObserve at houtput + by_cases hhit : PrivateStructuralHit context <;> simp [hhit] at houtput <;> + subst output <;> exact hsnapshots + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem snapshotsPublished_of_mem_granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (snapshots : List PlannedProbeSnapshot) + (hsnapshots : SnapshotsPublished snapshots) + (hpublished : PublishedValues context.state) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter + table ftsSecret context fuel value snapshots)) : + SnapshotsPublished output.2 := by + unfold granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve at houtput + apply snapshotsPublished_of_mem_directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve + parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table value.1) + snapshots context fuel table value.2 hsnapshots hpublished _ output houtput + intro nextContext remaining nextValue nextSnapshots hnextSnapshots _hnextPublished + finalOutput hfinal + exact snapshotsPublished_of_mem_retainedResolvedFinalizationPrivateWitnessSnapshotObserve table + value.1 nextContext remaining nextValue nextSnapshots hnextSnapshots finalOutput hfinal + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceNonRootProbability.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceNonRootProbability.lean new file mode 100644 index 00000000..8b06c43d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceNonRootProbability.lean @@ -0,0 +1,141 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceProbability +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalNonRootRisk + +/-! +# Canonical source non-root probability + +Erasing snapshot contexts from the canonical source gives the existing witness-plan observer. +Its first non-root witness at a fixed ordinal is bounded by the candidate-time non-root monitor. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot +set_option linter.constructorNameAsVariable false + +noncomputable def granularAllCanonicalPrivateWitnessPlan + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp PrivateWitnessPlanOutput := + runDirectWitnessPlanObserve + (canonicalizeDirectWitnessPlanObserve table + (granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret)) + [] emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + +theorem map_erase_granularAllCanonicalPrivateWitnessSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + erasePrivateWitnessSnapshotOutput <$> + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel = + granularAllCanonicalPrivateWitnessPlan adversary parameter table ftsSecret fuel := by + unfold granularAllCanonicalPrivateWitnessSnapshot granularAllCanonicalPrivateWitnessPlan + apply map_erase_runDirectWitnessSnapshotObserve + intro context remaining value snapshots + apply map_erase_canonicalizeDirectWitnessSnapshotObserve + intro nextContext nextRemaining nextValue nextSnapshots + exact map_erase_granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary + parameter table ftsSecret nextContext nextRemaining nextValue nextSnapshots + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_granularAllCanonicalPlan_firstUsesNonRootOrdinal_le + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + granularAllCanonicalPrivateWitnessPlan adversary parameter table ftsSecret fuel] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ Pr[fun hit : Bool => hit = true | + granularAllCanonicalPrivateOrdinalNonRootRisk ordinal adversary parameter table ftsSecret + fuel] := by + unfold granularAllCanonicalPrivateWitnessPlan + granularAllCanonicalPrivateOrdinalNonRootRisk + apply probEvent_runDirectWitnessPlanFirstUsesNonRootOrdinal_le_risk ordinal _ _ [] + emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) (by simp) + intro result hresult + apply probEvent_canonicalizeWitnessPlanFirstUsesNonRootOrdinal_le_risk table ordinal _ _ + result.context result.remaining result.value [] (by simp) + dsimp only + intro _hprivate hpublished _hcompletable + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) emptyWitnessDeferredContext fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hcore := resolvedCore_of_done_runDirectResolvedDetailedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) emptyWitnessDeferredContext fuel table + result DeferredContext.valid_empty.valuesConsistent (startTableAgrees_empty table) hdetailed + exact probEvent_granularDetailedRetainedRestWitnessFirstUsesNonRootOrdinal_le_nonRootRisk + adversary parameter table ftsSecret ordinal + (canonicalizeMaterializedValues table result.context) result.remaining result.value [] + (by simp) (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + hpublished.to_canonicalizedMaterializedValues + _ ≤ _ := probEvent_granularAllCanonicalPrivateOrdinalNonRootRisk_le ordinal adversary + parameter table ftsSecret fuel + +theorem probEvent_granularAllCanonicalSnapshot_firstUsesNonRootOrdinal_le + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun output => WitnessFirstUsesNonLayerRootOrdinal ordinal + (erasePrivateWitnessSnapshotOutput output) | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ = Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + erasePrivateWitnessSnapshotOutput <$> + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel] := by + rw [probEvent_map] + exact OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) rfl + _ = Pr[WitnessFirstUsesNonLayerRootOrdinal ordinal | + granularAllCanonicalPrivateWitnessPlan adversary parameter table ftsSecret fuel] := + OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + (congrArg evalDist + (map_erase_granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret + fuel)) + _ ≤ _ := probEvent_granularAllCanonicalPlan_firstUsesNonRootOrdinal_le ordinal adversary + parameter table ftsSecret fuel + +theorem probEvent_sampledCanonical_firstUsesNonRootOrdinal_le + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun output => WitnessFirstUsesNonLayerRootOrdinal ordinal + (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret fuel] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot + apply probEvent_bind_le_of_forall_le + intro table _htable + exact probEvent_granularAllCanonicalSnapshot_firstUsesNonRootOrdinal_le ordinal adversary + parameter table ftsSecret fuel + +theorem probEvent_sampledCanonical_nonRoot_le_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + Pr[fun output => WitnessFirstUsesSomeNonLayerRoot + (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + (q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + probEvent_sampledCanonical_nonRoot_le_mul_of_ordinals adversary parameter ftsSecret q hbound + (fun ordinal => probEvent_sampledCanonical_firstUsesNonRootOrdinal_le ordinal.val adversary + parameter ftsSecret q) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceProbability.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceProbability.lean new file mode 100644 index 00000000..b0bf22e0 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceProbability.lean @@ -0,0 +1,185 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveProductionOrdinal + +/-! +# Source-side ordinal aggregation + +The delayed layer-root and non-root residuals are both indexed by the first source candidate used +by the retained private witness. Supported canonical sources contain at most `q` candidates, so +fixed-ordinal estimates sum over `Fin q` without a structural-position union. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot +set_option linter.constructorNameAsVariable false + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledCanonical_delayed_le_sum_ordinals + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + Pr[WitnessFirstUsesSomeDelayedLayerRootSnapshot | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + ∑ ordinal : Fin q, + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal.val | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := by + classical + calc + _ ≤ Pr[fun output => ∃ ordinal ∈ (Finset.univ : Finset (Fin q)), + WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal.val output | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := by + apply probEvent_mono + intro (output : PrivateWitnessSnapshotOutput) houtput hdelayed + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨table, _htable, hrest⟩ := houtput + have hlength : output.2.length ≤ q := + snapshots_length_le_of_mem_granularAllCanonical + (adversary := adversary) (parameter := parameter) (table := table) + (ftsSecret := ftsSecret) (q := q) (hbound := hbound table) (output := output) + (houtput := hrest) + obtain ⟨ordinal, witness, sourceOrdinal, hwitness, hordinal, hfirst, hroot, + hstate, hrevealed, hvalue⟩ := hdelayed + have hlt : ordinal < q := by + rw [← hordinal] + exact sourceOrdinal.isLt.trans_le hlength + let bounded : Fin q := ⟨ordinal, hlt⟩ + exact ⟨bounded, Finset.mem_univ bounded, witness, sourceOrdinal, hwitness, + hordinal, hfirst, hroot, hstate, hrevealed, hvalue⟩ + _ ≤ ∑ ordinal ∈ (Finset.univ : Finset (Fin q)), + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal.val | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := + probEvent_exists_finset_le_sum Finset.univ + (sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q) + (fun (ordinal : Fin q) (output : PrivateWitnessSnapshotOutput) => + WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal.val output) + _ = _ := by simp + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledCanonical_delayed_le_mul_of_ordinals + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hordinal : ∀ ordinal : Fin q, + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal.val | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[WitnessFirstUsesSomeDelayedLayerRootSnapshot | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + (q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ ∑ ordinal : Fin q, + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal.val | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := + probEvent_sampledCanonical_delayed_le_sum_ordinals adversary parameter ftsSecret q hbound + _ ≤ ∑ _ordinal : Fin q, ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + exact Finset.sum_le_sum fun ordinal _ => hordinal ordinal + _ = _ := by simp + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledCanonical_nonRoot_le_sum_ordinals + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + Pr[fun output => WitnessFirstUsesSomeNonLayerRoot + (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + ∑ ordinal : Fin q, + Pr[fun output => WitnessFirstUsesNonLayerRootOrdinal ordinal.val + (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := by + classical + calc + _ ≤ Pr[fun output => ∃ ordinal ∈ (Finset.univ : Finset (Fin q)), + WitnessFirstUsesNonLayerRootOrdinal ordinal.val + (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := by + apply probEvent_mono + intro (output : PrivateWitnessSnapshotOutput) houtput hnonRoot + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨table, _htable, hrest⟩ := houtput + have hlength : output.2.length ≤ q := + snapshots_length_le_of_mem_granularAllCanonical + (adversary := adversary) (parameter := parameter) (table := table) + (ftsSecret := ftsSecret) (q := q) (hbound := hbound table) (output := output) + (houtput := hrest) + obtain ⟨ordinal, witness, sourceOrdinal, hwitness, hordinal, hfirst, hroot⟩ := + hnonRoot + have herasedLength : + (erasePrivateWitnessSnapshotOutput output).2.length = output.2.length := by + simp [erasePrivateWitnessSnapshotOutput] + have hlt : ordinal < q := by + rw [← hordinal] + have hsourceLt : sourceOrdinal.val < output.2.length := by + simpa only [herasedLength] using sourceOrdinal.isLt + exact hsourceLt.trans_le hlength + let bounded : Fin q := ⟨ordinal, hlt⟩ + exact ⟨bounded, Finset.mem_univ bounded, witness, sourceOrdinal, hwitness, + hordinal, hfirst, hroot⟩ + _ ≤ ∑ ordinal ∈ (Finset.univ : Finset (Fin q)), + Pr[fun output => WitnessFirstUsesNonLayerRootOrdinal ordinal.val + (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := + probEvent_exists_finset_le_sum Finset.univ + (sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q) + (fun (ordinal : Fin q) (output : PrivateWitnessSnapshotOutput) => + WitnessFirstUsesNonLayerRootOrdinal ordinal.val + (erasePrivateWitnessSnapshotOutput output)) + _ = _ := by simp + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledCanonical_nonRoot_le_mul_of_ordinals + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hordinal : ∀ ordinal : Fin q, + Pr[fun output => WitnessFirstUsesNonLayerRootOrdinal ordinal.val + (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[fun output => WitnessFirstUsesSomeNonLayerRoot + (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] ≤ + (q : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ ∑ ordinal : Fin q, + Pr[fun output => WitnessFirstUsesNonLayerRootOrdinal ordinal.val + (erasePrivateWitnessSnapshotOutput output) | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := + probEvent_sampledCanonical_nonRoot_le_sum_ordinals adversary parameter ftsSecret q hbound + _ ≤ ∑ _ordinal : Fin q, ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + exact Finset.sum_le_sum fun ordinal _ => hordinal ordinal + _ = _ := by simp + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceStructuralParent.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceStructuralParent.lean new file mode 100644 index 00000000..64651b62 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceStructuralParent.lean @@ -0,0 +1,249 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTop +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenRiskBound +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenFreshSigner + +/-! +# Structural parents of source snapshots + +Every snapshot recorded by the source interpreter comes from the root-aware candidate planner. This +file records the resulting support invariant needed to exclude the published top root from the +delayed-root exchange. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +def SnapshotsHaveStructuralParents (snapshots : List PlannedProbeSnapshot) : Prop := + CandidatesHaveStructuralParent (snapshots.map PlannedProbeSnapshot.toProbe) + +theorem snapshotsHaveStructuralParents_nil : + SnapshotsHaveStructuralParents [] := by + exact candidatesHaveStructuralParent_nil + +theorem SnapshotsHaveStructuralParents.appendPlanned + {snapshots : List PlannedProbeSnapshot} + (hparents : SnapshotsHaveStructuralParents snapshots) + (candidate? : Option Probe) (context : DeferredContext) + (hcandidate : ∀ candidate, candidate? = some candidate → + candidate.HasStructuralParent) : + SnapshotsHaveStructuralParents (appendPlannedSnapshot snapshots candidate? context) := by + unfold SnapshotsHaveStructuralParents + rw [map_toProbe_appendPlannedSnapshot] + exact CandidatesHaveStructuralParent.appendPlanned hparents candidate? hcandidate + +theorem snapshotsHaveStructuralParents_of_mem_finishDirectWitnessSnapshotObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) (result : DirectWitnessResult α) + (hparents : SnapshotsHaveStructuralParents snapshots) + (hobserve : ∀ resolved : ResolvedRunResult α, + result = .done resolved → + ∀ output ∈ support (observe resolved.context resolved.remaining resolved.value snapshots), + SnapshotsHaveStructuralParents output.2) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (finishDirectWitnessSnapshotObserve observe snapshots result)) : + SnapshotsHaveStructuralParents output.2 := by + cases result with + | stoppedFuel => + simp [finishDirectWitnessSnapshotObserve] at houtput + simpa [houtput] using hparents + | stoppedOrdinary => + simp [finishDirectWitnessSnapshotObserve] at houtput + simpa [houtput] using hparents + | stoppedPrivate witness => + simp [finishDirectWitnessSnapshotObserve] at houtput + simpa [houtput] using hparents + | done resolved => exact hobserve resolved rfl output houtput + +theorem snapshotsHaveStructuralParents_of_mem_runDirectWitnessSnapshotObserve + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hparents : SnapshotsHaveStructuralParents snapshots) + (hobserve : ∀ result : ResolvedRunResult α, + DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation) → + ∀ output ∈ support (observe result.context result.remaining result.value snapshots), + SnapshotsHaveStructuralParents output.2) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (runDirectWitnessSnapshotObserve observe snapshots context fuel table computation)) : + SnapshotsHaveStructuralParents output.2 := by + unfold runDirectWitnessSnapshotObserve at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + exact snapshotsHaveStructuralParents_of_mem_finishDirectWitnessSnapshotObserve observe snapshots + result hparents (by + intro resolved heq + subst result + exact hobserve resolved hresult) + output hfinish + +theorem snapshotsHaveStructuralParents_of_mem_classifyDirectWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (context : DeferredContext) (fuel : Nat) (value : α) + (snapshots : List PlannedProbeSnapshot) + (hparents : SnapshotsHaveStructuralParents snapshots) + (hobserve : ∀ output ∈ support (observe context fuel value snapshots), + SnapshotsHaveStructuralParents output.2) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (classifyDirectWitnessSnapshotObserve table observe context fuel value snapshots)) : + SnapshotsHaveStructuralParents output.2 := by + unfold classifyDirectWitnessSnapshotObserve at houtput + by_cases hhit : PrivateStructuralHit context + · simp [hhit] at houtput + simpa [houtput] using hparents + · simp only [hhit, ↓reduceDIte] at houtput + by_cases hcompletable : DeferredCompletable table context + · simp only [hcompletable, ↓reduceIte] at houtput + exact hobserve output houtput + · simp [hcompletable] at houtput + simpa [houtput] using hparents + +theorem snapshotsHaveStructuralParents_of_mem_canonicalizeDirectWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List PlannedProbeSnapshot → + ProbComp PrivateWitnessSnapshotOutput) + (context : DeferredContext) (fuel : Nat) (value : α) + (snapshots : List PlannedProbeSnapshot) + (hparents : SnapshotsHaveStructuralParents snapshots) + (hobserve : ∀ output ∈ support + (observe (canonicalizeMaterializedValues table context) fuel value snapshots), + SnapshotsHaveStructuralParents output.2) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (canonicalizeDirectWitnessSnapshotObserve table observe context fuel value snapshots)) : + SnapshotsHaveStructuralParents output.2 := by + unfold canonicalizeDirectWitnessSnapshotObserve at houtput + let canonical := canonicalizeMaterializedValues table context + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit] at houtput + simpa [houtput] using hparents + · simp only [canonical, hhit, ↓reduceDIte] at houtput + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] at houtput + exact snapshotsHaveStructuralParents_of_mem_classifyDirectWitnessSnapshotObserve table + observe canonical fuel value snapshots hparents hobserve output houtput + · simp [hpublished] at houtput + simpa [houtput] using hparents + +set_option maxRecDepth 100000 in +theorem snapshotsHaveStructuralParents_of_mem_directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List PlannedProbeSnapshot → ProbComp PrivateWitnessSnapshotOutput) + (snapshots : List PlannedProbeSnapshot) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hparents : SnapshotsHaveStructuralParents snapshots) + (hobserve : ∀ nextContext remaining value nextSnapshots output, + SnapshotsHaveStructuralParents nextSnapshots → + output ∈ support (observe nextContext remaining value nextSnapshots) → + SnapshotsHaveStructuralParents output.2) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve parameter root ftsSecret + computation observe snapshots context fuel table cache)) : + SnapshotsHaveStructuralParents output.2 := by + induction computation using OracleComp.inductionOn generalizing snapshots context fuel cache output with + | pure value => + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_pure] at houtput + exact hobserve context fuel (value, cache) snapshots output hparents houtput + | query_bind query next ih => + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_query_bind] at houtput + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + apply snapshotsHaveStructuralParents_of_mem_runDirectWitnessSnapshotObserve _ + snapshots context fuel table ((splitUniformImpl n).run cache) hparents + (output := output) (houtput := houtput) + intro result _hresult nextOutput hnextOutput + apply snapshotsHaveStructuralParents_of_mem_canonicalizeDirectWitnessSnapshotObserve + table _ result.context result.remaining result.value snapshots hparents + (output := nextOutput) (houtput := hnextOutput) + intro finalOutput hfinalOutput + exact ih result.value.1 snapshots + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hparents finalOutput hfinalOutput + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let candidate? := rootAwarePlannedCandidate? parameter input context.state + let nextSnapshots := appendPlannedSnapshot snapshots candidate? context + have hnextParents : SnapshotsHaveStructuralParents nextSnapshots := by + apply hparents.appendPlanned candidate? context + intro candidate hcandidate + exact rootAwarePlannedCandidate?_hasStructuralParent hcandidate + apply snapshotsHaveStructuralParents_of_mem_runDirectWitnessSnapshotObserve _ + nextSnapshots context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) hnextParents + (output := output) (houtput := houtput) + intro result _hresult nextOutput hnextOutput + apply snapshotsHaveStructuralParents_of_mem_canonicalizeDirectWitnessSnapshotObserve + table _ result.context result.remaining result.value nextSnapshots hnextParents + (output := nextOutput) (houtput := hnextOutput) + intro finalOutput hfinalOutput + exact ih result.value.1 nextSnapshots + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hnextParents finalOutput hfinalOutput + | inr message => + apply snapshotsHaveStructuralParents_of_mem_runDirectWitnessSnapshotObserve _ snapshots + context fuel table ((maskedSign parameter root ftsSecret message).run cache) hparents + (output := output) (houtput := houtput) + intro result _hresult nextOutput hnextOutput + apply snapshotsHaveStructuralParents_of_mem_canonicalizeDirectWitnessSnapshotObserve + table _ result.context result.remaining result.value snapshots hparents + (output := nextOutput) (houtput := hnextOutput) + intro finalOutput hfinalOutput + exact ih result.value.1 snapshots + (canonicalizeMaterializedValues table result.context) result.remaining result.value.2 + hparents finalOutput hfinalOutput + +theorem snapshotsHaveStructuralParents_of_mem_retainedResolvedFinalizationPrivateWitnessSnapshotObserve + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) + (snapshots : List PlannedProbeSnapshot) + (hparents : SnapshotsHaveStructuralParents snapshots) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table root context fuel value + snapshots)) : + SnapshotsHaveStructuralParents output.2 := by + unfold retainedResolvedFinalizationPrivateWitnessSnapshotObserve at houtput + by_cases hhit : PrivateStructuralHit context <;> + simp [hhit] at houtput <;> simpa [houtput] using hparents + +theorem snapshotsHaveStructuralParents_of_mem_granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (snapshots : List PlannedProbeSnapshot) + (hparents : SnapshotsHaveStructuralParents snapshots) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter + table ftsSecret context fuel value snapshots)) : + SnapshotsHaveStructuralParents output.2 := by + unfold granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve at houtput + apply snapshotsHaveStructuralParents_of_mem_directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve + parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivateWitnessSnapshotObserve table value.1) + snapshots context fuel table value.2 hparents (output := output) (houtput := houtput) + intro nextContext remaining nextValue nextSnapshots nextOutput hnextParents hnextOutput + exact snapshotsHaveStructuralParents_of_mem_retainedResolvedFinalizationPrivateWitnessSnapshotObserve + table value.1 nextContext remaining nextValue nextSnapshots hnextParents nextOutput hnextOutput + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceStructuralParentTop.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceStructuralParentTop.lean new file mode 100644 index 00000000..1f76aeea --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceStructuralParentTop.lean @@ -0,0 +1,53 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSourceStructuralParent + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxRecDepth 100000 in +theorem snapshotsHaveStructuralParents_of_mem_granularCanonicalPrivateWitnessSnapshotObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : ResolvedRunResult (Digest × SplitHashCache)) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (canonicalizeDirectWitnessSnapshotObserve table + (granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter + table ftsSecret) + result.context result.remaining result.value [])) : + SnapshotsHaveStructuralParents output.2 := by + apply snapshotsHaveStructuralParents_of_mem_canonicalizeDirectWitnessSnapshotObserve table + (granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter table + ftsSecret) + result.context result.remaining result.value [] snapshotsHaveStructuralParents_nil + (output := output) (houtput := houtput) + intro finalOutput hfinalOutput + exact snapshotsHaveStructuralParents_of_mem_granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve + adversary parameter table ftsSecret + (canonicalizeMaterializedValues table result.context) result.remaining result.value [] + snapshotsHaveStructuralParents_nil finalOutput hfinalOutput + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem snapshotsHaveStructuralParents_of_mem_granularAllCanonicalPrivateWitnessSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (output : PrivateWitnessSnapshotOutput) + (houtput : output ∈ support + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel)) : + SnapshotsHaveStructuralParents output.2 := by + unfold granularAllCanonicalPrivateWitnessSnapshot runDirectWitnessSnapshotObserve at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨result, _hresult, hfinish⟩ := houtput + apply snapshotsHaveStructuralParents_of_mem_finishDirectWitnessSnapshotObserve _ [] result + snapshotsHaveStructuralParents_nil (output := output) (houtput := hfinish) + intro resolved heq nextOutput hnextOutput + subst result + exact snapshotsHaveStructuralParents_of_mem_granularCanonicalPrivateWitnessSnapshotObserve + adversary parameter table ftsSecret resolved nextOutput hnextOutput + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTop.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTop.lean new file mode 100644 index 00000000..b7c0da12 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTop.lean @@ -0,0 +1,99 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopStep + +/-! +# Published-root materialized observation lift + +The retained-rest comparison is attached to the probe-free public root computation here, after the +adaptive induction has been compiled as its own module. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def granularAllCanonicalPrivateWitnessSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp PrivateWitnessSnapshotOutput := + runDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table + (granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter + table ftsSecret)) + [] emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + +set_option maxHeartbeats 10000000 in +set_option maxRecDepth 100000 in +theorem relTriple_granularAllSnapshot_observedMaterializedRetained + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + RelTriple + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q) + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table) + (SnapshotObservedPrefixStableRel table) := by + let initial : DeferredContext := emptyWitnessDeferredContext + have hcontext : FinalizationContextLE table initial + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) := + finalizationContextLE_empty table + have hbase := (witnessMaterializedStableCouples_maskedPublishedTreeRoot table) + initial (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + q (2 * q) emptySplitHashCache emptySplitHashCache hcontext (by omega) rfl rfl + (fun _ _ hvalue => hvalue) publishedValues_empty rfl + have hlocal := relTriple_runDirectResolvedWitness_observed_of_probeFree table + (maskedPublishedTreeRoot.run emptySplitHashCache) + (maskedPublishedTreeRoot.run emptySplitHashCache) [] initial + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + q (2 * q) hbase (maskedPublishedTreeRoot_probeFree emptySplitHashCache) rfl + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hlocal + (fun result => result ∈ support + (runDirectResolvedWitnessFromTable initial q table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (fun result hresult => hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupported + unfold granularAllCanonicalPrivateWitnessSnapshot + observedMaterializedRetainedRunFromTable runDirectWitnessSnapshotObserve + change RelTriple + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext q table + (maskedPublishedTreeRoot.run emptySplitHashCache) >>= + finishDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table + (granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter + table ftsSecret)) []) + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache) >>= fun rootResult => + match rootResult with + | none => pure none + | some rootResult => do + let restResult ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table rootResult.value.2 + match restResult with + | none => pure none + | some restResult => pure (some + { restResult with + value := ((rootResult.value.1, restResult.value.1), restResult.value.2) })) + (SnapshotObservedPrefixStableRel table) + apply relTriple_bind hbothSupported + intro leftResult rightResult hstep + rcases hstep with ⟨⟨hstep, hleftSupport⟩, hrightSupport⟩ + exact relTriple_finishAfterPublishedRoot adversary parameter ftsSecret q table hbound leftResult + rightResult hstep (by simpa [initial] using hleftSupport) hrightSupport + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopBase.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopBase.lean new file mode 100644 index 00000000..9efba61e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopBase.lean @@ -0,0 +1,9 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalLift + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +def emptyWitnessDeferredContext : DeferredContext := + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopFuel.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopFuel.lean new file mode 100644 index 00000000..cc660aa9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopFuel.lean @@ -0,0 +1 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopFuelRight diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopFuelLeftLower.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopFuelLeftLower.lean new file mode 100644 index 00000000..fba6aae9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopFuelLeftLower.lean @@ -0,0 +1,42 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopBase + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxRecDepth 100000 in +theorem remaining_eq_fuel_of_doneWitness_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hprobeFree : computation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) : + result.remaining = fuel := by + have hlower := fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + computation context fuel table result 0 hprobeFree hresult + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) := by + rw [← map_erase_runDirectResolvedWitnessFromTable computation context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hupper := remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable computation context + fuel table result hdetailed + omega + +set_option maxHeartbeats 1000000 in +theorem fuel_le_remaining_of_doneWitness_maskedPublishedTreeRoot + (table : OtsSecretIndex → HashOutput) (fuel : Nat) + (result : ResolvedRunResult (Digest × SplitHashCache)) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache))) : + fuel ≤ result.remaining := by + exact (remaining_eq_fuel_of_doneWitness_of_probeFree + (maskedPublishedTreeRoot.run emptySplitHashCache) emptyWitnessDeferredContext fuel table result + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) hresult).ge + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopFuelLeftUpper.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopFuelLeftUpper.lean new file mode 100644 index 00000000..5c49c897 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopFuelLeftUpper.lean @@ -0,0 +1,21 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopFuelLeftLower + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxHeartbeats 1000000 in +theorem remaining_le_fuel_of_doneWitness_maskedPublishedTreeRoot + (table : OtsSecretIndex → HashOutput) (fuel : Nat) + (result : ResolvedRunResult (Digest × SplitHashCache)) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache))) : + result.remaining ≤ fuel := by + exact (remaining_eq_fuel_of_doneWitness_of_probeFree + (maskedPublishedTreeRoot.run emptySplitHashCache) emptyWitnessDeferredContext fuel table result + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) hresult).le + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopFuelRight.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopFuelRight.lean new file mode 100644 index 00000000..b525e2a7 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopFuelRight.lean @@ -0,0 +1,40 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopFuelLeftUpper + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxRecDepth 100000 in +theorem remaining_eq_fuel_of_mem_observed_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observations : List CleanProbeObservation) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ObservedCleanRunResult α) + (hprobeFree : computation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) + (hresult : some result ∈ support + (runObservedCleanFromTable observations state fuel table computation)) : + result.remaining = fuel := by + have hlower := fuel_le_remaining_add_of_mem_runObservedCleanFromTable computation observations + state fuel table result 0 hprobeFree hresult + have hupper := remaining_le_of_mem_runObservedCleanFromTable computation observations state fuel + table result hresult + omega + +set_option maxHeartbeats 1000000 in +theorem fuel_le_remaining_of_mem_observed_maskedPublishedTreeRoot + (table : OtsSecretIndex → HashOutput) (fuel : Nat) + (result : ResolvedRunResult (Digest × SplitHashCache)) + (hresult : some (observedResolvedResult [] result) ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache))) : + fuel ≤ result.remaining := by + have heq := remaining_eq_fuel_of_mem_observed_of_probeFree + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty fuel table + (observedResolvedResult [] result) (maskedPublishedTreeRoot_probeFree emptySplitHashCache) + hresult + simpa [observedResolvedResult] using heq.ge + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopKernel.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopKernel.lean new file mode 100644 index 00000000..6ad60c1f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopKernel.lean @@ -0,0 +1,83 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopFuel + +/-! +# Published-root continuation kernel + +This module isolates the continuation after the probe-free public-root computation. Keeping this +kernel separate prevents the complete root wrapper from serializing one deeply nested proof term. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def retainedSnapshotObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + DeferredContext → Nat → (Digest × SplitHashCache) → + List PlannedProbeSnapshot → ProbComp PrivateWitnessSnapshotOutput := + granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter table + ftsSecret + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_afterPublishedRoot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (left right : ResolvedRunResult (Digest × SplitHashCache)) + (hleftSupport : DirectWitnessResult.done left ∈ support + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext q table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hrightSupport : some (observedResolvedResult [] right) ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hclean : OrdinaryMaterializedRunEq table left right) : + RelTriple + (canonicalizeDirectWitnessSnapshotObserve table + (retainedSnapshotObserve adversary parameter table ftsSecret) + left.context left.remaining left.value []) + (observedMaterializedBoundary parameter right.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨right.value.1, parameter⟩) + [] right.context.state right.remaining table right.value.2) + (SnapshotObservedPrefixStableRel table) := by + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table left.context + have hleftCompletable : DeferredCompletable table canonical := + hcanonicalRun.context_le.leftCompletable + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hleftFuelPreserved : q ≤ left.remaining := + fuel_le_remaining_of_doneWitness_maskedPublishedTreeRoot table q left hleftSupport + have hrightFuelPreserved : 2 * q ≤ right.remaining := + fuel_le_remaining_of_mem_observed_maskedPublishedTreeRoot table (2 * q) right hrightSupport + have hleftRemainingUpper : left.remaining ≤ q := + remaining_le_fuel_of_doneWitness_maskedPublishedTreeRoot table q left hleftSupport + unfold canonicalizeDirectWitnessSnapshotObserve classifyDirectWitnessSnapshotObserve + simp only [canonical, hnotPrivate, ↓reduceDIte, hclean.left_published, ↓reduceIte, + hleftCompletable] + rw [← hclean.value_eq] + simpa [retainedSnapshotObserve, + granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve] using + (relTriple_directSnapshotBoundary_observedMaterialized parameter left.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨left.value.1, parameter⟩) + [] [] canonical right.context left.remaining right.remaining table + left.value.2 right.value.2 q q (hbound left.value.1) + hcanonicalRun.context_le hcanonicalRun.cache_eq hcanonicalRun.revealed_eq + hcanonicalRun.values_le hcanonicalRun.left_published hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table left.context + hclean.context_le.view.leftConsistent) + (by simp [SnapshotsObservedAt]) (by omega) (by omega) (by omega)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopStep.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopStep.lean new file mode 100644 index 00000000..63bbafd5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopStep.lean @@ -0,0 +1,135 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopKernel + +/-! +# Published-root result step + +This module packages the retained continuation for one coupled result of the probe-free public-root +computation. It keeps the complete root wrapper small enough to elaborate independently. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +def retainObservedRoot (root : Digest) : + Option (ObservedCleanRunResult (RetainedRestResult × SplitHashCache)) → + Option (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) + | none => none + | some result => some + { result with value := ((root, result.value.1), result.value.2) } + +theorem SnapshotObservedPrefixStableRel.retainRoot + {table : OtsSecretIndex → HashOutput} + {source : PrivateWitnessSnapshotOutput} + {observed : Option + (ObservedCleanRunResult (RetainedRestResult × SplitHashCache))} + (hrelation : SnapshotObservedPrefixStableRel table source observed) + (root : Digest) : + SnapshotObservedPrefixStableRel table source (retainObservedRoot root observed) := by + rcases hrelation with hfailed | hsuccess | hdoomed + · left + subst observed + rfl + · right + left + obtain ⟨result, aligned, hresult, hprefix, haligned, hstored⟩ := hsuccess + subst observed + exact ⟨_, aligned, rfl, hprefix, haligned, hstored⟩ + · right + right + obtain ⟨result, hresult, hdoomed⟩ := hdoomed + subst observed + exact ⟨_, rfl, hdoomed⟩ + +theorem map_retainObservedRoot_eq + (root : Digest) + (run : ProbComp + (Option (ObservedCleanRunResult (RetainedRestResult × SplitHashCache)))) : + retainObservedRoot root <$> run = + (run >>= fun result => + match result with + | none => pure none + | some result => pure (some + { result with value := ((root, result.value.1), result.value.2) })) := by + rw [map_eq_bind_pure_comp] + apply bind_congr + intro result + cases result <;> rfl + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem relTriple_finishAfterPublishedRoot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (leftResult : DirectWitnessResult (Digest × SplitHashCache)) + (rightResult : Option (ObservedCleanRunResult (Digest × SplitHashCache))) + (hstep : WitnessObservedStepRel table [] leftResult rightResult) + (hleftSupport : leftResult ∈ support + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext q table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hrightSupport : rightResult ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache))) : + RelTriple + (finishDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table + (retainedSnapshotObserve adversary parameter table ftsSecret)) [] leftResult) + (match rightResult with + | none => pure none + | some rootResult => do + let restResult ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table rootResult.value.2 + match restResult with + | none => pure none + | some restResult => pure (some + { restResult with + value := ((rootResult.value.1, restResult.value.1), restResult.value.2) })) + (SnapshotObservedPrefixStableRel table) := by + have hfinish := relTriple_finishWitnessObservedStep (α := Digest) + (β := RetainedRestResult) parameter id ftsSecret + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩) + (retainedSnapshotObserve adversary parameter table ftsSecret) [] [] table leftResult + rightResult hstep (by simp [SnapshotsObservedAt]) (by + intro nextLeft nextRight hleftEq hrightEq hclean + have hleftDone : DirectWitnessResult.done nextLeft ∈ support + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext q table + (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + rw [← hleftEq] + exact hleftSupport + have hrightDone : some (observedResolvedResult [] nextRight) ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + rw [← hrightEq] + exact hrightSupport + exact relTriple_afterPublishedRoot adversary parameter ftsSecret q table hbound nextLeft + nextRight hleftDone hrightDone hclean) + cases rightResult with + | none => + have hretained := relTriple_post_mono hfinish + (fun source observed hrelation => hrelation.retainRoot 0) + have hmapped := relTriple_map (f := id) (g := retainObservedRoot 0) hretained + rw [id_map] at hmapped + rw [map_retainObservedRoot_eq, pure_bind] at hmapped + exact hmapped + | some rootResult => + have hretained := relTriple_post_mono hfinish + (fun source observed hrelation => hrelation.retainRoot rootResult.value.1) + have hmapped := relTriple_map (f := id) + (g := retainObservedRoot rootResult.value.1) hretained + rw [id_map] at hmapped + rw [map_retainObservedRoot_eq] at hmapped + exact hmapped + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootProbe.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootProbe.lean new file mode 100644 index 00000000..46b7111a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootProbe.lean @@ -0,0 +1,322 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalNonRootRisk + +/-! +# Root-aware comparison probe + +The delayed comparison schedule executes the root-aware candidate selected from one outer hash +query. When the ordinary structural planner already selected a candidate this is the existing +planned suffix. Otherwise an encoding-domain layer-root guess is installed as one proof-only probe +before the same probe-free action. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +noncomputable def rootAwareCandidateForPlan? + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) : Option Probe := + match plan.candidate? with + | some candidate => some candidate + | none => decodeEncodingLayerRootCandidate? parameter input + +theorem rootAwareCandidateForPlan?_purePlan + (parameter : PublicParameter) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) : + rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input state) = + rootAwarePlannedCandidate? parameter input state := by + rfl + +noncomputable def probingHashQueryAfterRootAwarePlan + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput := do + executeCandidate? (rootAwareCandidateForPlan? parameter input plan) + match plan.action with + | .ordinary => splitHashQuery (.ordinary input) + | .resolve coordinate => resolveKnownInput parameter coordinate input + +theorem probingHashQueryAfterRootAwarePlan_eq_afterPlan_of_candidate + (parameter : PublicParameter) (input : HashInput) + (plan : PlannedHashQuery) + (candidate : Probe) (hcandidate : plan.candidate? = some candidate) : + probingHashQueryAfterRootAwarePlan parameter input plan = + probingHashQueryAfterPlan parameter input plan := by + unfold probingHashQueryAfterRootAwarePlan probingHashQueryAfterPlan + executePlannedHashQuery rootAwareCandidateForPlan? + rw [hcandidate] + cases plan.action <;> rfl + +theorem probingHashQueryAfterRootAwarePlan_eq_probe_then_afterPlan + (parameter : PublicParameter) (input : HashInput) + (plan : PlannedHashQuery) + (candidate : Probe) (hplan : plan.candidate? = none) + (hdecode : decodeEncodingLayerRootCandidate? parameter input = some candidate) : + probingHashQueryAfterRootAwarePlan parameter input plan = (do + probe candidate + probingHashQueryAfterPlan parameter input plan) := by + unfold probingHashQueryAfterRootAwarePlan probingHashQueryAfterPlan + executePlannedHashQuery rootAwareCandidateForPlan? + rw [hplan, hdecode] + cases plan.action <;> rfl + +theorem rootAwarePlannedCandidate?_isLayerRoot_of_plan_none + {parameter : PublicParameter} {input : HashInput} + {plan : PlannedHashQuery} + {candidate : Probe} (hplan : plan.candidate? = none) + (hcandidate : rootAwareCandidateForPlan? parameter input plan = some candidate) : + candidate.IsLayerRoot := by + unfold rootAwareCandidateForPlan? at hcandidate + rw [hplan] at hcandidate + exact decodeEncodingLayerRootCandidate?_some_isLayerRoot hcandidate + +theorem rootAwarePlannedCandidate?_hasParent_of_plan_none + {parameter : PublicParameter} {input : HashInput} + {plan : PlannedHashQuery} + {candidate : Probe} (hplan : plan.candidate? = none) + (hcandidate : rootAwareCandidateForPlan? parameter input plan = some candidate) : + candidate.HasStructuralParent := by + unfold rootAwareCandidateForPlan? at hcandidate + rw [hplan] at hcandidate + exact encodingLayerRootCandidateAt_hasStructuralParent + ((decodeEncodingLayerRootCandidate?_eq_some_iff parameter input candidate).mp hcandidate) + +theorem executeCandidate?_isProbeBound_one (candidate? : Option Probe) + (cache : SplitHashCache) : + ((executeCandidate? candidate?).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 := by + cases candidate? with + | none => simp [executeCandidate?] + | some candidate => + change ((probe candidate).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 + unfold probe + simp only [StateT.run_liftM] + exact LazyRevealProbe.probeQuery_isProbeBound candidate.coordinate candidate.candidate + +theorem probingHashQueryAfterRootAwarePlan_isProbeBound + (parameter : PublicParameter) (input : HashInput) + (plan : PlannedHashQuery) (cache : SplitHashCache) : + ((probingHashQueryAfterRootAwarePlan parameter input plan).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 := by + unfold probingHashQueryAfterRootAwarePlan + rw [StateT.run_bind] + apply OracleComp.isQueryBoundP_bind (n := 1) (m := 0) + · exact executeCandidate?_isProbeBound_one + (rootAwareCandidateForPlan? parameter input plan) cache + · intro result _hresult + cases plan.action with + | ordinary => exact splitHashQuery_probeFree (.ordinary input) result.2 + | resolve coordinate => exact resolveKnownInput_probeFree parameter coordinate input result.2 + +theorem preservesPublishedValues_probingHashQueryAfterRootAwarePlan + (parameter : PublicParameter) (input : HashInput) + (plan : PlannedHashQuery) : + PreservesPublishedValues + (probingHashQueryAfterRootAwarePlan parameter input plan) := by + unfold probingHashQueryAfterRootAwarePlan + apply (preservesPublishedValues_executeCandidate + (rootAwareCandidateForPlan? parameter input plan)).bind + intro _ + cases plan.action with + | ordinary => exact preservesPublishedValues_splitHashQuery_ordinary input + | resolve coordinate => exact preservesPublishedValues_resolveKnownInput parameter coordinate input + +set_option maxRecDepth 100000 in +theorem probingHashQuery_eq_plan_then_afterPlan + (parameter : PublicParameter) (input : HashInput) : + probingHashQuery parameter input = (do + let plan ← planProbingHashQuery parameter input + probingHashQueryAfterPlan parameter input plan) := by + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases hposition : decodePosition? parameter input with + | none => + exact probingHashQuery_eq_plan_then_afterPlan_of_probe_some_nonleaf parameter input + candidate hprobe (by + rintro ⟨lay, tree, leafIdx, heq⟩ + simp [hposition] at heq) + | some position => + cases position with + | leaf lay tree leafIdx => + exact probingHashQuery_eq_plan_then_afterPlan_leaf parameter input candidate lay + tree leafIdx hprobe hposition + | chain | node | ftsLeaf | ftsNode | ftsRoots => + exact probingHashQuery_eq_plan_then_afterPlan_of_probe_some_nonleaf parameter input + candidate hprobe (by + rintro ⟨lay, tree, leafIdx, heq⟩ + simp [hposition] at heq) + | none => + cases hposition : decodePosition? parameter input with + | none => + exact probingHashQuery_eq_plan_then_afterPlan_of_probe_none_nonnode parameter input + hprobe (by + rintro ⟨lay, tree, level, nodeIdx, heq⟩ + simp [hposition] at heq) + | some position => + cases position with + | node lay tree level nodeIdx => + exact probingHashQuery_eq_plan_then_afterPlan_node parameter input lay tree level + nodeIdx hprobe hposition + | chain | leaf | ftsLeaf | ftsNode | ftsRoots => + exact probingHashQuery_eq_plan_then_afterPlan_of_probe_none_nonnode parameter input + hprobe (by + rintro ⟨lay, tree, level, nodeIdx, heq⟩ + simp [hposition] at heq) + +noncomputable def rootAwareProbingHashQuery + (parameter : PublicParameter) (input : HashInput) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput := do + let plan ← planProbingHashQuery parameter input + probingHashQueryAfterRootAwarePlan parameter input plan + +theorem rootAwareProbingHashQuery_isProbeBound + (parameter : PublicParameter) (input : HashInput) (cache : SplitHashCache) : + ((rootAwareProbingHashQuery parameter input).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 := by + unfold rootAwareProbingHashQuery + rw [StateT.run_bind] + apply OracleComp.isQueryBoundP_bind (n := 0) (m := 1) + · exact planProbingHashQuery_probeFree parameter input cache + · intro result _hresult + exact probingHashQueryAfterRootAwarePlan_isProbeBound parameter input result.1 result.2 + +noncomputable def rootAwareProbingHashImpl (parameter : PublicParameter) : + QueryImpl HashSpec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate))) := + fun input => rootAwareProbingHashQuery parameter input + +noncomputable def rootAwareProbingRomImpl (parameter : PublicParameter) : + QueryImpl OracleWorld + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate))) := + splitUniformImpl + rootAwareProbingHashImpl parameter + +theorem rootAwareProbingRomImpl_step_isProbeBound + (parameter : PublicParameter) (query : OracleWorld.Domain) (cache : SplitHashCache) : + ((rootAwareProbingRomImpl parameter query).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) + (if query matches .inr _ then 1 else 0) := by + cases query with + | inl n => + simpa [rootAwareProbingRomImpl] using splitUniformImpl_probeFree n cache + | inr input => + change ((rootAwareProbingHashQuery parameter input).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 + exact rootAwareProbingHashQuery_isProbeBound parameter input cache + +noncomputable def rootAwareMaskedExpandedAdversaryImpl + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + QueryImpl (OracleWorld + SigningSpec) + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate))) := + rootAwareProbingRomImpl parameter + maskedSigningImpl parameter root ftsSecret + +theorem rootAwareMaskedExpandedAdversaryImpl_step_isProbeBound + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) (cache : SplitHashCache) : + ((rootAwareMaskedExpandedAdversaryImpl parameter root ftsSecret query).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) + (if IsOuterHash query then 1 else 0) := by + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + simpa [rootAwareMaskedExpandedAdversaryImpl, rootAwareProbingRomImpl, + IsOuterHash] using splitUniformImpl_probeFree n cache + | inr input => + change ((rootAwareProbingHashQuery parameter input).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 1 + exact rootAwareProbingHashQuery_isProbeBound parameter input cache + | inr message => + simpa [rootAwareMaskedExpandedAdversaryImpl, maskedSigningImpl, IsOuterHash] using + maskedSign_probeFree parameter root ftsSecret message cache + +theorem simulateQ_rootAwareMaskedExpandedAdversaryImpl_run_isProbeBound + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) (q : Nat) + (hbound : computation.IsQueryBoundP IsOuterHash q) + (cache : SplitHashCache) : + ((simulateQ (rootAwareMaskedExpandedAdversaryImpl parameter root ftsSecret) + computation).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) q := by + apply hbound.simulateQ_run_StateT_of_step + (q := LazyRevealProbe.IsProbe (Coordinate := Coordinate)) + exact rootAwareMaskedExpandedAdversaryImpl_step_isProbeBound parameter root ftsSecret + +noncomputable def rootAwareCleanRetainedRun + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + OracleComp (LazyRevealProbe.World Coordinate) + (RetainedGameResult × SplitHashCache) := do + let rootResult ← maskedPublishedTreeRoot.run emptySplitHashCache + let restResult ← + (simulateQ + (rootAwareMaskedExpandedAdversaryImpl parameter rootResult.1 ftsSecret) + (retainedGameRestComputation adversary ⟨rootResult.1, parameter⟩)).run rootResult.2 + pure ((rootResult.1, restResult.1), restResult.2) + +set_option maxRecDepth 100000 in +theorem rootAwareCleanRetainedRun_isProbeBound + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash q) : + (rootAwareCleanRetainedRun adversary parameter ftsSecret).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) q := by + unfold rootAwareCleanRetainedRun + have htail : ∀ rootResult ∈ support (maskedPublishedTreeRoot.run emptySplitHashCache), + (do + let restResult ← + (simulateQ + (rootAwareMaskedExpandedAdversaryImpl parameter rootResult.1 ftsSecret) + (retainedGameRestComputation adversary ⟨rootResult.1, parameter⟩)).run rootResult.2 + pure ((rootResult.1, restResult.1), restResult.2)).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) q := by + intro rootResult _hroot + change ((fun restResult => ((rootResult.1, restResult.1), restResult.2)) <$> + (simulateQ + (rootAwareMaskedExpandedAdversaryImpl parameter rootResult.1 ftsSecret) + (retainedGameRestComputation adversary ⟨rootResult.1, parameter⟩)).run + rootResult.2).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) q + rw [OracleComp.isQueryBoundP_map_iff] + exact simulateQ_rootAwareMaskedExpandedAdversaryImpl_run_isProbeBound parameter + rootResult.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.1, parameter⟩) q + (hbound rootResult.1) rootResult.2 + simpa only [Nat.zero_add] using OracleComp.isQueryBoundP_bind + (n := 0) (m := q) (maskedPublishedTreeRoot_probeFree emptySplitHashCache) htail + +theorem probEvent_rootAwareCleanRetainedRun_le + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) : + Pr[fun hit : Bool => hit = true | + LazyRevealProbe.experiment + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) q + (rootAwareCleanRetainedRun adversary parameter ftsSecret)] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + LazyRevealProbe.experiment_empty_probability_le q + (rootAwareCleanRetainedRun adversary parameter ftsSecret) + +theorem probEvent_sampledRootAwareCleanRetainedRun_none_le + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash q) : + Pr[= none | sampledRunThenFinalizeClean + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) q + (rootAwareCleanRetainedRun adversary parameter ftsSecret)] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + probEvent_sampledRunThenFinalizeClean_empty_none_le + (rootAwareCleanRetainedRun adversary parameter ftsSecret) q + (rootAwareCleanRetainedRun_isProbeBound adversary parameter ftsSecret q hbound) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootProbeCoupling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootProbeCoupling.lean new file mode 100644 index 00000000..58c3c2e3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootProbeCoupling.lean @@ -0,0 +1,879 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootProbe + +/-! +# Root-probe coupling + +The root-aware run differs from the original run only by additional pending probes. A successful +root-aware execution therefore determines the original execution with the same values, public +state and outputs. The additional pending set may instead stop the root-aware execution, which is +the failure event used by the probability bound. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +structure ProbeStateLE (left right : LazyRevealProbe.State Coordinate) : Prop where + pending : left.pending ⊆ right.pending + values : left.values = right.values + revealed : left.revealed = right.revealed + ensured : left.ensured = right.ensured + extraRoot : ∀ coordinate candidate, + (coordinate, candidate) ∈ right.pending → + (coordinate, candidate) ∈ left.pending ∨ + (⟨coordinate, candidate⟩ : Probe).IsLayerRoot + +theorem ProbeStateLE.refl (state : LazyRevealProbe.State Coordinate) : + ProbeStateLE state state := + ⟨fun _ h => h, rfl, rfl, rfl, fun _ _ h => Or.inl h⟩ + +theorem ProbeStateLE.trans {left middle right : LazyRevealProbe.State Coordinate} + (hleft : ProbeStateLE left middle) (hright : ProbeStateLE middle right) : + ProbeStateLE left right := + ⟨fun _ hentry => hright.pending (hleft.pending hentry), + hleft.values.trans hright.values, + hleft.revealed.trans hright.revealed, + hleft.ensured.trans hright.ensured, + fun coordinate candidate hentry => by + rcases hright.extraRoot coordinate candidate hentry with hmiddle | hroot + · exact hleft.extraRoot coordinate candidate hmiddle + · exact Or.inr hroot⟩ + +theorem ProbeStateLE.hitAt + {left right : LazyRevealProbe.State Coordinate} + (hle : ProbeStateLE left right) (coordinate : Coordinate) (output : HashOutput) : + left.hitAt coordinate output → right.hitAt coordinate output := by + intro hhit + unfold LazyRevealProbe.State.hitAt at hhit ⊢ + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit ⊢ + exact hle.pending hhit + +theorem ProbeStateLE.not_hitAt_left + {left right : LazyRevealProbe.State Coordinate} + (hle : ProbeStateLE left right) (coordinate : Coordinate) (output : HashOutput) + (hmiss : ¬right.hitAt coordinate output) : + ¬left.hitAt coordinate output := + fun hhit => hmiss (hle.hitAt coordinate output hhit) + +theorem ProbeStateLE.chainStart_pending_of_right + {left right : LazyRevealProbe.State Coordinate} + (hle : ProbeStateLE left right) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (candidate : Digest) + (hentry : (Coordinate.chainStart lay tree leafIdx chainIdx, candidate) ∈ right.pending) : + (Coordinate.chainStart lay tree leafIdx chainIdx, candidate) ∈ left.pending := by + rcases hle.extraRoot _ _ hentry with hleft | ⟨position, hcoordinate, _hroot⟩ + · exact hleft + · cases hcoordinate + +theorem ProbeStateLE.addPendingRight + {left right : LazyRevealProbe.State Coordinate} + (hle : ProbeStateLE left right) (coordinate : Coordinate) (candidate : Digest) + (hroot : (⟨coordinate, candidate⟩ : Probe).IsLayerRoot) : + ProbeStateLE left (right.addPending coordinate candidate) := by + refine ⟨?_, hle.values, hle.revealed, hle.ensured, ?_⟩ + intro entry hentry + exact Finset.mem_insert_of_mem (hle.pending hentry) + intro other otherCandidate hentry + simp only [LazyRevealProbe.State.addPending, Finset.mem_insert] at hentry + rcases hentry with hnew | hold + · have hcoordinate : other = coordinate := congrArg Prod.fst hnew + have hcandidate : otherCandidate = candidate := congrArg Prod.snd hnew + subst other + subst otherCandidate + exact Or.inr hroot + · exact hle.extraRoot other otherCandidate hold + +theorem ProbeStateLE.addPending + {left right : LazyRevealProbe.State Coordinate} + (hle : ProbeStateLE left right) (coordinate : Coordinate) (candidate : Digest) : + ProbeStateLE (left.addPending coordinate candidate) + (right.addPending coordinate candidate) := by + refine ⟨?_, hle.values, hle.revealed, hle.ensured, ?_⟩ + intro entry hentry + simp only [LazyRevealProbe.State.addPending, Finset.mem_insert] at hentry ⊢ + exact hentry.elim Or.inl (fun hold => Or.inr (hle.pending hold)) + intro other otherCandidate hentry + simp only [LazyRevealProbe.State.addPending, Finset.mem_insert] at hentry ⊢ + rcases hentry with hnew | hold + · exact Or.inl (Or.inl hnew) + · rcases hle.extraRoot other otherCandidate hold with hleft | hroot + · exact Or.inl (Or.inr hleft) + · exact Or.inr hroot + +theorem ProbeStateLE.ensure + {left right : LazyRevealProbe.State Coordinate} + (hle : ProbeStateLE left right) (coordinate : Coordinate) : + ProbeStateLE (left.ensure coordinate) (right.ensure coordinate) := by + refine ⟨hle.pending, hle.values, hle.revealed, ?_, hle.extraRoot⟩ + simp [LazyRevealProbe.State.ensure, hle.ensured] + +theorem ProbeStateLE.publish + {left right : LazyRevealProbe.State Coordinate} + (hle : ProbeStateLE left right) (coordinate : Coordinate) : + ProbeStateLE (left.publish coordinate) (right.publish coordinate) := by + refine ⟨hle.pending, hle.values, ?_, hle.ensured, hle.extraRoot⟩ + simp [LazyRevealProbe.State.publish, hle.revealed] + +theorem ProbeStateLE.materialize + {left right : LazyRevealProbe.State Coordinate} + (hle : ProbeStateLE left right) (coordinate : Coordinate) (output : HashOutput) : + ProbeStateLE (left.materialize coordinate output) + (right.materialize coordinate output) := by + refine ⟨?_, ?_, hle.revealed, ?_, ?_⟩ + · intro entry hentry + simp only [LazyRevealProbe.State.materialize, LazyRevealProbe.State.pendingAway, + Finset.mem_filter] at hentry ⊢ + exact ⟨hle.pending hentry.1, hentry.2⟩ + · simp [LazyRevealProbe.State.materialize, hle.values] + · simp [LazyRevealProbe.State.materialize, hle.ensured] + · intro other candidate hentry + simp only [LazyRevealProbe.State.materialize, LazyRevealProbe.State.pendingAway, + Finset.mem_filter] at hentry ⊢ + rcases hle.extraRoot other candidate hentry.1 with hleft | hroot + · exact Or.inl ⟨hleft, hentry.2⟩ + · exact Or.inr hroot + +theorem ProbeStateLE.clearPending + {left right : LazyRevealProbe.State Coordinate} + (hle : ProbeStateLE left right) (coordinate : Coordinate) : + ProbeStateLE (left.clearPending coordinate) (right.clearPending coordinate) := by + refine ⟨?_, hle.values, hle.revealed, hle.ensured, ?_⟩ + intro entry hentry + simp only [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway, + Finset.mem_filter] at hentry ⊢ + exact ⟨hle.pending hentry.1, hentry.2⟩ + intro other candidate hentry + simp only [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway, + Finset.mem_filter] at hentry ⊢ + rcases hle.extraRoot other candidate hentry.1 with hleft | hroot + · exact Or.inl ⟨hleft, hentry.2⟩ + · exact Or.inr hroot + +theorem ProbeStateLE.complete + {left right : LazyRevealProbe.State Coordinate} + (hle : ProbeStateLE left right) (coordinate : Coordinate) (output : HashOutput) : + ProbeStateLE (left.complete coordinate output) (right.complete coordinate output) := by + refine ⟨?_, ?_, hle.revealed, hle.ensured, ?_⟩ + · intro entry hentry + simp only [LazyRevealProbe.State.complete, LazyRevealProbe.State.pendingAway, + Finset.mem_filter] at hentry ⊢ + exact ⟨hle.pending hentry.1, hentry.2⟩ + · simp [LazyRevealProbe.State.complete, hle.values] + · intro other candidate hentry + simp only [LazyRevealProbe.State.complete, LazyRevealProbe.State.pendingAway, + Finset.mem_filter] at hentry ⊢ + rcases hle.extraRoot other candidate hentry.1 with hleft | hroot + · exact Or.inl ⟨hleft, hentry.2⟩ + · exact Or.inr hroot + +theorem ProbeStateLE.coordinates + {left right : LazyRevealProbe.State Coordinate} + (hle : ProbeStateLE left right) : left.coordinates ⊆ right.coordinates := by + intro coordinate hcoordinate + unfold LazyRevealProbe.State.coordinates at hcoordinate ⊢ + simp only [Finset.mem_union, Finset.mem_image] at hcoordinate ⊢ + rcases hcoordinate with hensured | ⟨entry, hentry, hvalue⟩ + · left + rw [← hle.ensured] + exact hensured + · right + exact ⟨entry, hle.pending hentry, hvalue⟩ + +theorem ProbeStateLE.revealed_iff + {left right : LazyRevealProbe.State Coordinate} + (hle : ProbeStateLE left right) (coordinate : Coordinate) : + coordinate ∈ left.revealed ↔ coordinate ∈ right.revealed := by + rw [hle.revealed] + +def CleanRunProbeLE (left right : Option (CleanRunResult α)) : Prop := + match left, right with + | _, none => True + | none, some _ => False + | some leftResult, some rightResult => + leftResult.value = rightResult.value ∧ + leftResult.table = rightResult.table ∧ + rightResult.remaining ≤ leftResult.remaining ∧ + ProbeStateLE leftResult.state rightResult.state + +theorem CleanRunProbeLE.failure_right (left : Option (CleanRunResult α)) : + CleanRunProbeLE left none := by + cases left <;> trivial + +theorem CleanRunProbeLE.some_iff + (leftResult rightResult : CleanRunResult α) : + CleanRunProbeLE (some leftResult) (some rightResult) ↔ + leftResult.value = rightResult.value ∧ + leftResult.table = rightResult.table ∧ + rightResult.remaining ≤ leftResult.remaining ∧ + ProbeStateLE leftResult.state rightResult.state := by + rfl + +def FinalizeFailureLE + (left right : Option (LazyRevealProbe.State Coordinate × + (OtsSecretIndex → HashOutput))) : Prop := + left = none → right = none + +def CleanFinishFailureLE + (left right : Option (CleanRunResult α)) : Prop := + left = none → right = none + +theorem relTriple_finalize_any_pure_none + (run : ProbComp (Option (LazyRevealProbe.State Coordinate × + (OtsSecretIndex → HashOutput)))) : + RelTriple run + (pure none : ProbComp (Option (LazyRevealProbe.State Coordinate × + (OtsSecretIndex → HashOutput)))) FinalizeFailureLE := by + have hbase : RelTriple (run >>= pure) (run >>= fun _ => pure none) + FinalizeFailureLE := by + apply relTriple_bind (relTriple_refl run) + intro left right heq + subst right + exact relTriple_pure_pure (by simp [FinalizeFailureLE]) + have hleft : 𝒟[run] = 𝒟[run >>= pure] := by rw [bind_pure] + have hright : 𝒟[run >>= fun _ => pure none] = + 𝒟[(pure none : ProbComp (Option (LazyRevealProbe.State Coordinate × + (OtsSecretIndex → HashOutput))))] := + OracleComp.DeferredSampling.evalDist_bind_const_neverFails run + (probFailure_eq_zero (mx := run)) (pure none) + exact relTriple_of_evalDist_eq_left hleft + (relTriple_of_evalDist_eq_right hright hbase) + +theorem relTriple_finalize_pure_some_any + (result : LazyRevealProbe.State Coordinate × (OtsSecretIndex → HashOutput)) + (run : ProbComp (Option (LazyRevealProbe.State Coordinate × + (OtsSecretIndex → HashOutput)))) : + RelTriple + (pure (some result) : ProbComp (Option (LazyRevealProbe.State Coordinate × + (OtsSecretIndex → HashOutput)))) run FinalizeFailureLE := by + have hbase := relTriple_true + (pure (some result) : ProbComp (Option (LazyRevealProbe.State Coordinate × + (OtsSecretIndex → HashOutput)))) run + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun output => output = some result) (by + intro output houtput + simpa using houtput) + exact relTriple_post_mono hsupported fun left _ hrelation => by + rw [hrelation.2] + simp [FinalizeFailureLE] + +theorem relTriple_cleanFinish_any_pure_none + (run : ProbComp (Option (CleanRunResult α))) : + RelTriple run (pure none : ProbComp (Option (CleanRunResult α))) + CleanFinishFailureLE := by + have hbase : RelTriple (run >>= pure) (run >>= fun _ => pure none) + CleanFinishFailureLE := by + apply relTriple_bind (relTriple_refl run) + intro left right heq + subst right + exact relTriple_pure_pure (by simp [CleanFinishFailureLE]) + have hleft : 𝒟[run] = 𝒟[run >>= pure] := by rw [bind_pure] + have hright : 𝒟[run >>= fun _ => pure none] = + 𝒟[(pure none : ProbComp (Option (CleanRunResult α)))] := + OracleComp.DeferredSampling.evalDist_bind_const_neverFails run + (probFailure_eq_zero (mx := run)) (pure none) + exact relTriple_of_evalDist_eq_left hleft + (relTriple_of_evalDist_eq_right hright hbase) + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_finalizeCleanFromTable_probeStateLE : + ∀ (leftCoordinates rightCoordinates : List Coordinate) + (leftState rightState : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput), + leftCoordinates.Nodup → rightCoordinates.Nodup → + (∀ coordinate ∈ leftCoordinates, coordinate ∈ rightCoordinates) → + ProbeStateLE leftState rightState → + RelTriple + (finalizeCleanFromTable leftCoordinates leftState table) + (finalizeCleanFromTable rightCoordinates rightState table) + FinalizeFailureLE + | [], rightCoordinates, leftState, rightState, table, + _hleftNodup, _hrightNodup, _hsubset, _hstate => by + simp only [finalizeCleanFromTable] + exact relTriple_finalize_pure_some_any (leftState, table) _ + | coordinate :: leftRemaining, rightCoordinates, leftState, rightState, table, + hleftNodup, hrightNodup, hsubset, hstate => by + have hcoordinate : coordinate ∈ rightCoordinates := + hsubset coordinate (by simp) + apply relTriple_of_evalDist_eq_right + (evalDist_finalizeCleanFromTable_move_to_front coordinate rightCoordinates rightState + table hcoordinate).symm + have hrightMovedNodup : (coordinate :: rightCoordinates.erase coordinate).Nodup := + (List.perm_cons_erase hcoordinate).nodup_iff.mp hrightNodup + have htailSubset : ∀ other ∈ leftRemaining, + other ∈ rightCoordinates.erase coordinate := by + intro other hother + have hne : other ≠ coordinate := by + intro heq + subst other + exact (List.nodup_cons.mp hleftNodup).1 hother + exact (List.mem_erase_of_ne hne).2 (hsubset other (by simp [hother])) + have hvalue : leftState.values coordinate = rightState.values coordinate := by + rw [hstate.values] + cases hrightValue : rightState.values coordinate with + | some output => + have hleftValue : leftState.values coordinate = some output := by + rw [hvalue, hrightValue] + rw [finalizeCleanFromTable_cons_of_some coordinate leftRemaining leftState table output + hleftValue, + finalizeCleanFromTable_cons_of_some coordinate + (rightCoordinates.erase coordinate) rightState table output hrightValue] + exact relTriple_finalizeCleanFromTable_probeStateLE leftRemaining + (rightCoordinates.erase coordinate) (leftState.clearPending coordinate) + (rightState.clearPending coordinate) table (List.nodup_cons.mp hleftNodup).2 + (List.nodup_cons.mp hrightMovedNodup).2 htailSubset + (hstate.clearPending coordinate) + | none => + have hleftValue : leftState.values coordinate = none := by + rw [hvalue, hrightValue] + rw [finalizeCleanFromTable_cons_of_none coordinate leftRemaining leftState table + hleftValue, + finalizeCleanFromTable_cons_of_none coordinate + (rightCoordinates.erase coordinate) rightState table hrightValue] + apply relTriple_bind + (relTriple_refl (completionOutputFromTable coordinate table)) + intro leftOutput rightOutput houtput + subst rightOutput + by_cases hrightHit : rightState.hitAt coordinate leftOutput + · simp only [hrightHit, ↓reduceIte] + exact relTriple_finalize_any_pure_none _ + · have hleftHit : ¬leftState.hitAt coordinate leftOutput := + hstate.not_hitAt_left coordinate leftOutput hrightHit + simp only [hleftHit, hrightHit, ↓reduceIte] + exact relTriple_finalizeCleanFromTable_probeStateLE leftRemaining + (rightCoordinates.erase coordinate) (leftState.complete coordinate leftOutput) + (rightState.complete coordinate leftOutput) table + (List.nodup_cons.mp hleftNodup).2 + (List.nodup_cons.mp hrightMovedNodup).2 htailSubset + (hstate.complete coordinate leftOutput) + +theorem relTriple_finishCleanRunFromTable_probeLE + (left right : Option (CleanRunResult α)) + (hrelation : CleanRunProbeLE left right) : + RelTriple (finishCleanRunFromTable left) (finishCleanRunFromTable right) + CleanFinishFailureLE := by + cases right with + | none => exact relTriple_cleanFinish_any_pure_none _ + | some rightResult => + cases left with + | none => simp [CleanRunProbeLE] at hrelation + | some leftResult => + rcases hrelation with ⟨hvalue, htable, hremaining, hstate⟩ + simp only [finishCleanRunFromTable] + rw [← htable] + apply relTriple_bind + (relTriple_finalizeCleanFromTable_probeStateLE + leftResult.state.coordinates.toList rightResult.state.coordinates.toList + leftResult.state rightResult.state leftResult.table + (Finset.nodup_toList _) (Finset.nodup_toList _) + (by + intro coordinate hcoordinate + have : coordinate ∈ leftResult.state.coordinates := by simpa using hcoordinate + have := hstate.coordinates this + simpa using this) + hstate) + intro leftFinal rightFinal hfinal + cases rightFinal with + | none => + cases leftFinal with + | none => exact relTriple_pure_pure (by simp [CleanFinishFailureLE]) + | some leftFinal => exact relTriple_pure_pure (by simp [CleanFinishFailureLE]) + | some rightFinal => + cases leftFinal with + | none => + have hcontra := hfinal rfl + simp at hcontra + | some leftFinal => exact relTriple_pure_pure (by simp [CleanFinishFailureLE]) + +theorem relTriple_any_pure_none_clean + (run : ProbComp (Option (CleanRunResult α))) : + RelTriple run (pure none : ProbComp (Option (CleanRunResult α))) CleanRunProbeLE := by + have hbase : RelTriple (run >>= pure) (run >>= fun _ => pure none) CleanRunProbeLE := by + apply relTriple_bind (relTriple_refl run) + intro left right heq + subst right + exact relTriple_pure_pure (CleanRunProbeLE.failure_right left) + have hleft : 𝒟[run] = 𝒟[run >>= pure] := by rw [bind_pure] + have hright : 𝒟[run >>= fun _ => pure none] = + 𝒟[(pure none : ProbComp (Option (CleanRunResult α)))] := + OracleComp.DeferredSampling.evalDist_bind_const_neverFails run + (probFailure_eq_zero (mx := run)) (pure none) + exact relTriple_of_evalDist_eq_left hleft + (relTriple_of_evalDist_eq_right hright hbase) + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_runCleanFromTable_probeStateLE + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (leftState rightState : LazyRevealProbe.State Coordinate) + (leftFuel rightFuel : Nat) (table : OtsSecretIndex → HashOutput) + (hstate : ProbeStateLE leftState rightState) + (hfuel : rightFuel ≤ leftFuel) : + RelTriple + (runCleanFromTable leftState leftFuel table computation) + (runCleanFromTable rightState rightFuel table computation) + CleanRunProbeLE := by + induction computation using OracleComp.inductionOn generalizing + leftState rightState leftFuel rightFuel with + | pure value => + simp only [runCleanFromTable, OracleComp.construct_pure] + apply relTriple_pure_pure + exact ⟨rfl, rfl, hfuel, hstate⟩ + | query_bind query next ih => + cases query with + | uniform n => + rw [runCleanFromTable_uniform_query_bind, runCleanFromTable_uniform_query_bind] + apply relTriple_bind + (relTriple_refl (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))) + intro leftOutput rightOutput houtput + subst rightOutput + exact ih leftOutput leftState rightState leftFuel rightFuel hstate hfuel + | hashOutput => + rw [runCleanFromTable_hashOutput_query_bind, + runCleanFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + exact ih leftOutput leftState rightState leftFuel rightFuel hstate hfuel + | ensure coordinate => + rw [runCleanFromTable_ensure_query_bind, runCleanFromTable_ensure_query_bind] + exact ih () (leftState.ensure coordinate) (rightState.ensure coordinate) + leftFuel rightFuel (hstate.ensure coordinate) hfuel + | probe coordinate candidate => + rw [runCleanFromTable_probe_query_bind, runCleanFromTable_probe_query_bind] + cases rightFuel with + | zero => exact relTriple_any_pure_none_clean _ + | succ rightRemaining => + have hleftNe : leftFuel ≠ 0 := by omega + obtain ⟨leftRemaining, hleftFuel⟩ := Nat.exists_eq_succ_of_ne_zero hleftNe + subst leftFuel + have hremaining : rightRemaining ≤ leftRemaining := + Nat.le_of_succ_le_succ hfuel + have hrevealed := hstate.revealed_iff coordinate + by_cases hleftRevealed : coordinate ∈ leftState.revealed + · have hrightRevealed : coordinate ∈ rightState.revealed := + hrevealed.mp hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + exact ih () leftState rightState leftRemaining rightRemaining hstate hremaining + · have hrightRevealed : coordinate ∉ rightState.revealed := by + simpa [hrevealed] using hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + exact ih () (leftState.addPending coordinate candidate) + (rightState.addPending coordinate candidate) leftRemaining rightRemaining + (hstate.addPending coordinate candidate) hremaining + | peek coordinate => + rw [runCleanFromTable_peek_query_bind, runCleanFromTable_peek_query_bind] + have hvalue : leftState.values coordinate = rightState.values coordinate := by + rw [hstate.values] + rw [hvalue] + exact ih (rightState.values coordinate) leftState rightState leftFuel rightFuel + hstate hfuel + | publish coordinate => + rw [runCleanFromTable_publish_query_bind, runCleanFromTable_publish_query_bind] + exact ih () (leftState.publish coordinate) (rightState.publish coordinate) + leftFuel rightFuel (hstate.publish coordinate) hfuel + | reveal coordinate => + rw [runCleanFromTable_reveal_query_bind, runCleanFromTable_reveal_query_bind] + have hvalue : leftState.values coordinate = rightState.values coordinate := by + rw [hstate.values] + cases hrightValue : rightState.values coordinate with + | some output => + have hleftValue : leftState.values coordinate = some output := by + rw [hvalue, hrightValue] + simp only [hleftValue] + exact ih output leftState rightState leftFuel rightFuel hstate hfuel + | none => + have hleftValue : leftState.values coordinate = none := by + rw [hvalue, hrightValue] + simp only [hleftValue] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hrightHit : rightState.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp only [output, hrightHit, ↓reduceIte] + exact relTriple_any_pure_none_clean _ + · have hleftHit : ¬leftState.hitAt + (.chainStart lay tree leafIdx chainIdx) output := + hstate.not_hitAt_left _ _ hrightHit + simp only [output, hleftHit, hrightHit, ↓reduceIte] + exact ih output + (leftState.materialize (.chainStart lay tree leafIdx chainIdx) output) + (rightState.materialize (.chainStart lay tree leafIdx chainIdx) output) + leftFuel rightFuel + (hstate.materialize (.chainStart lay tree leafIdx chainIdx) output) hfuel + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + by_cases hrightHit : rightState.hitAt (.position position) leftOutput + · simp only [hrightHit, ↓reduceIte] + exact relTriple_any_pure_none_clean _ + · have hleftHit : ¬leftState.hitAt (.position position) leftOutput := + hstate.not_hitAt_left _ _ hrightHit + simp only [hleftHit, hrightHit, ↓reduceIte] + exact ih leftOutput + (leftState.materialize (.position position) leftOutput) + (rightState.materialize (.position position) leftOutput) + leftFuel rightFuel + (hstate.materialize (.position position) leftOutput) hfuel + +theorem relTriple_runCleanFromTable_addProbeRight + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (leftState rightState : LazyRevealProbe.State Coordinate) + (leftFuel rightFuel : Nat) (table : OtsSecretIndex → HashOutput) + (coordinate : Coordinate) (candidate : Digest) + (hstate : ProbeStateLE leftState rightState) + (hroot : (⟨coordinate, candidate⟩ : Probe).IsLayerRoot) + (hfuel : rightFuel ≤ leftFuel) : + RelTriple + (runCleanFromTable leftState leftFuel table computation) + (runCleanFromTable rightState rightFuel table + (LazyRevealProbe.probeQuery coordinate candidate >>= fun _ => computation)) + CleanRunProbeLE := by + rw [LazyRevealProbe.probeQuery, runCleanFromTable_probe_query_bind] + cases rightFuel with + | zero => exact relTriple_any_pure_none_clean _ + | succ rightRemaining => + have hremaining : rightRemaining ≤ leftFuel := by omega + have hrevealed := hstate.revealed_iff coordinate + by_cases hleftRevealed : coordinate ∈ leftState.revealed + · have hrightRevealed : coordinate ∈ rightState.revealed := hrevealed.mp hleftRevealed + simp only [hrightRevealed, ↓reduceIte] + exact relTriple_runCleanFromTable_probeStateLE computation leftState rightState + leftFuel rightRemaining table hstate hremaining + · have hrightRevealed : coordinate ∉ rightState.revealed := by + simpa [hrevealed] using hleftRevealed + simp only [hrightRevealed, ↓reduceIte] + exact relTriple_runCleanFromTable_probeStateLE computation leftState + (rightState.addPending coordinate candidate) leftFuel rightRemaining table + (hstate.addPendingRight coordinate candidate hroot) hremaining + +set_option maxRecDepth 100000 in +theorem relTriple_runCleanFromTable_afterPlan_rootAware + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (leftState rightState : LazyRevealProbe.State Coordinate) + (leftFuel rightFuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hstate : ProbeStateLE leftState rightState) + (hfuel : rightFuel ≤ leftFuel) (hcache : leftCache = rightCache) : + RelTriple + (runCleanFromTable leftState leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache)) + (runCleanFromTable rightState rightFuel table + ((probingHashQueryAfterRootAwarePlan parameter input plan).run rightCache)) + CleanRunProbeLE := by + subst rightCache + cases hplan : plan.candidate? with + | some candidate => + rw [probingHashQueryAfterRootAwarePlan_eq_afterPlan_of_candidate parameter input plan + candidate hplan] + exact relTriple_runCleanFromTable_probeStateLE _ leftState rightState leftFuel rightFuel + table hstate hfuel + | none => + cases hdecode : decodeEncodingLayerRootCandidate? parameter input with + | none => + have heq : probingHashQueryAfterRootAwarePlan parameter input plan = + probingHashQueryAfterPlan parameter input plan := by + unfold probingHashQueryAfterRootAwarePlan probingHashQueryAfterPlan + executePlannedHashQuery rootAwareCandidateForPlan? + rw [hplan, hdecode] + cases plan.action <;> rfl + rw [heq] + exact relTriple_runCleanFromTable_probeStateLE _ leftState rightState leftFuel + rightFuel table hstate hfuel + | some candidate => + rw [probingHashQueryAfterRootAwarePlan_eq_probe_then_afterPlan parameter input plan + candidate hplan hdecode] + simpa [StateT.run_bind, probe, StateT.run_liftM] using + (relTriple_runCleanFromTable_addProbeRight + ((probingHashQueryAfterPlan parameter input plan).run leftCache) + leftState rightState leftFuel rightFuel table candidate.coordinate + candidate.candidate hstate + (decodeEncodingLayerRootCandidate?_some_isLayerRoot hdecode) hfuel) + +theorem relTriple_runCleanFromTable_bind_probeLE + (left : OracleComp (LazyRevealProbe.World Coordinate) α) + (leftNext : α → OracleComp (LazyRevealProbe.World Coordinate) β) + (right : OracleComp (LazyRevealProbe.World Coordinate) α) + (rightNext : α → OracleComp (LazyRevealProbe.World Coordinate) β) + (leftState rightState : LazyRevealProbe.State Coordinate) + (leftFuel rightFuel : Nat) (table : OtsSecretIndex → HashOutput) + (hleft : RelTriple + (runCleanFromTable leftState leftFuel table left) + (runCleanFromTable rightState rightFuel table right) + CleanRunProbeLE) + (hnext : ∀ leftResult rightResult, + CleanRunProbeLE (some leftResult) (some rightResult) → + RelTriple + (runCleanFromTable leftResult.state leftResult.remaining leftResult.table + (leftNext leftResult.value)) + (runCleanFromTable rightResult.state rightResult.remaining rightResult.table + (rightNext rightResult.value)) + CleanRunProbeLE) : + RelTriple + (runCleanFromTable leftState leftFuel table (left >>= leftNext)) + (runCleanFromTable rightState rightFuel table (right >>= rightNext)) + CleanRunProbeLE := by + rw [runCleanFromTable_bind, runCleanFromTable_bind] + apply relTriple_bind hleft + intro leftResult rightResult hrelation + cases rightResult with + | none => + cases leftResult with + | none => exact relTriple_pure_pure trivial + | some leftResult => exact relTriple_any_pure_none_clean _ + | some rightResult => + cases leftResult with + | none => simp [CleanRunProbeLE] at hrelation + | some leftResult => exact hnext leftResult rightResult hrelation + +set_option maxRecDepth 100000 in +theorem relTriple_runCleanFromTable_probingHashQuery_rootAware + (parameter : PublicParameter) (input : HashInput) + (leftState rightState : LazyRevealProbe.State Coordinate) + (leftFuel rightFuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hstate : ProbeStateLE leftState rightState) + (hfuel : rightFuel ≤ leftFuel) (hcache : leftCache = rightCache) : + RelTriple + (runCleanFromTable leftState leftFuel table + ((probingHashQuery parameter input).run leftCache)) + (runCleanFromTable rightState rightFuel table + ((rootAwareProbingHashQuery parameter input).run rightCache)) + CleanRunProbeLE := by + subst rightCache + rw [probingHashQuery_eq_plan_then_afterPlan] + unfold rootAwareProbingHashQuery + rw [StateT.run_bind, StateT.run_bind] + apply relTriple_runCleanFromTable_bind_probeLE + · exact relTriple_runCleanFromTable_probeStateLE + ((planProbingHashQuery parameter input).run leftCache) + leftState rightState leftFuel rightFuel table hstate hfuel + · intro leftResult rightResult hrelation + rcases hrelation with ⟨hvalue, htable, hremaining, hnextState⟩ + have hplan : leftResult.value.1 = rightResult.value.1 := congrArg Prod.fst hvalue + have hnextCache : leftResult.value.2 = rightResult.value.2 := congrArg Prod.snd hvalue + rw [← hplan, ← hnextCache, ← htable] + exact relTriple_runCleanFromTable_afterPlan_rootAware parameter input leftResult.value.1 + leftResult.state rightResult.state leftResult.remaining rightResult.remaining + leftResult.table leftResult.value.2 leftResult.value.2 hnextState hremaining rfl + +theorem relTriple_runCleanFromTable_maskedExpanded_step_rootAware + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (query : (OracleWorld + SigningSpec).Domain) + (leftState rightState : LazyRevealProbe.State Coordinate) + (leftFuel rightFuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hstate : ProbeStateLE leftState rightState) + (hfuel : rightFuel ≤ leftFuel) (hcache : leftCache = rightCache) : + RelTriple + (runCleanFromTable leftState leftFuel table + ((maskedExpandedAdversaryImpl parameter root ftsSecret query).run leftCache)) + (runCleanFromTable rightState rightFuel table + ((rootAwareMaskedExpandedAdversaryImpl parameter root ftsSecret query).run rightCache)) + CleanRunProbeLE := by + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + subst rightCache + exact relTriple_runCleanFromTable_probeStateLE + ((splitUniformImpl n).run leftCache) leftState rightState leftFuel rightFuel table + hstate hfuel + | inr input => + exact relTriple_runCleanFromTable_probingHashQuery_rootAware parameter input leftState + rightState leftFuel rightFuel table leftCache rightCache hstate hfuel hcache + | inr message => + subst rightCache + exact relTriple_runCleanFromTable_probeStateLE + ((maskedSign parameter root ftsSecret message).run leftCache) + leftState rightState leftFuel rightFuel table hstate hfuel + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_runCleanFromTable_simulateQ_rootAware + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (leftState rightState : LazyRevealProbe.State Coordinate) + (leftFuel rightFuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hstate : ProbeStateLE leftState rightState) + (hfuel : rightFuel ≤ leftFuel) (hcache : leftCache = rightCache) : + RelTriple + (runCleanFromTable leftState leftFuel table + ((simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + computation).run leftCache)) + (runCleanFromTable rightState rightFuel table + ((simulateQ (rootAwareMaskedExpandedAdversaryImpl parameter root ftsSecret) + computation).run rightCache)) + CleanRunProbeLE := by + induction computation using OracleComp.inductionOn generalizing + leftState rightState leftFuel rightFuel table leftCache rightCache with + | pure value => + subst rightCache + simp only [simulateQ_pure, StateT.run_pure] + exact relTriple_runCleanFromTable_probeStateLE (pure (value, leftCache)) + leftState rightState leftFuel rightFuel table hstate hfuel + | query_bind query next ih => + rw [simulateQ_query_bind, simulateQ_query_bind, StateT.run_bind, StateT.run_bind] + apply relTriple_runCleanFromTable_bind_probeLE + · exact relTriple_runCleanFromTable_maskedExpanded_step_rootAware parameter root ftsSecret + query leftState rightState leftFuel rightFuel table leftCache rightCache hstate hfuel + hcache + · intro leftResult rightResult hrelation + rcases hrelation with ⟨hvalue, htable, hremaining, hnextState⟩ + have houtput : leftResult.value.1 = rightResult.value.1 := congrArg Prod.fst hvalue + have hnextCache : leftResult.value.2 = rightResult.value.2 := congrArg Prod.snd hvalue + rw [← houtput, ← hnextCache, ← htable] + exact ih ((OracleSpec.query query).cont leftResult.value.1) + leftResult.state rightResult.state + leftResult.remaining rightResult.remaining leftResult.table leftResult.value.2 + leftResult.value.2 hnextState hremaining rfl + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_runCleanFromTable_deferred_rootAware + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + RelTriple + (runCleanFromTable LazyRevealProbe.State.empty fuel table + (deferredCleanRetainedRun adversary parameter ftsSecret)) + (runCleanFromTable LazyRevealProbe.State.empty fuel table + (rootAwareCleanRetainedRun adversary parameter ftsSecret)) + CleanRunProbeLE := by + unfold deferredCleanRetainedRun rootAwareCleanRetainedRun + apply relTriple_runCleanFromTable_bind_probeLE + · exact relTriple_runCleanFromTable_probeStateLE + (maskedPublishedTreeRoot.run emptySplitHashCache) + LazyRevealProbe.State.empty LazyRevealProbe.State.empty fuel fuel table + (ProbeStateLE.refl _) le_rfl + · intro leftRoot rightRoot hrootRelation + rcases hrootRelation with ⟨hrootValue, hrootTable, hrootRemaining, hrootState⟩ + have hroot : leftRoot.value.1 = rightRoot.value.1 := congrArg Prod.fst hrootValue + have hrootCache : leftRoot.value.2 = rightRoot.value.2 := congrArg Prod.snd hrootValue + rw [← hroot, ← hrootCache, ← hrootTable] + have hleftRest : deferredCleanRetainedRest adversary parameter leftRoot.value.1 ftsSecret + leftRoot.value.2 = + (simulateQ (maskedExpandedAdversaryImpl parameter leftRoot.value.1 ftsSecret) + (retainedGameRestComputation adversary + ⟨leftRoot.value.1, parameter⟩)).run leftRoot.value.2 := by + unfold deferredCleanRetainedRest + rw [simulateQ_maskedExpanded_retainedGameRestComputation] + apply relTriple_runCleanFromTable_bind_probeLE + · rw [hleftRest] + exact relTriple_runCleanFromTable_simulateQ_rootAware parameter leftRoot.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨leftRoot.value.1, parameter⟩) + leftRoot.state rightRoot.state leftRoot.remaining rightRoot.remaining leftRoot.table + leftRoot.value.2 leftRoot.value.2 hrootState hrootRemaining rfl + · intro leftRest rightRest hrestRelation + rcases hrestRelation with ⟨hrestValue, hrestTable, hrestRemaining, hrestState⟩ + have hrestOutput : leftRest.value.1 = rightRest.value.1 := congrArg Prod.fst hrestValue + have hrestCache : leftRest.value.2 = rightRest.value.2 := congrArg Prod.snd hrestValue + rw [← hrestOutput, ← hrestCache, ← hrestTable] + exact relTriple_runCleanFromTable_probeStateLE + (pure ((leftRoot.value.1, leftRest.value.1), leftRest.value.2)) + leftRest.state rightRest.state leftRest.remaining rightRest.remaining leftRest.table + hrestState hrestRemaining + +theorem relTriple_runThenFinalizeCleanFromTable_deferred_rootAware + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + RelTriple + (runCleanFromTable LazyRevealProbe.State.empty fuel table + (deferredCleanRetainedRun adversary parameter ftsSecret) >>= finishCleanRunFromTable) + (runCleanFromTable LazyRevealProbe.State.empty fuel table + (rootAwareCleanRetainedRun adversary parameter ftsSecret) >>= finishCleanRunFromTable) + CleanFinishFailureLE := by + apply relTriple_bind + (relTriple_runCleanFromTable_deferred_rootAware adversary parameter ftsSecret fuel table) + intro leftRun rightRun hrun + exact relTriple_finishCleanRunFromTable_probeLE leftRun rightRun hrun + +theorem probEvent_runThenFinalizeCleanFromTable_deferred_le_rootAware + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + Pr[= none | runCleanFromTable LazyRevealProbe.State.empty fuel table + (deferredCleanRetainedRun adversary parameter ftsSecret) >>= finishCleanRunFromTable] ≤ + Pr[= none | runCleanFromTable LazyRevealProbe.State.empty fuel table + (rootAwareCleanRetainedRun adversary parameter ftsSecret) >>= + finishCleanRunFromTable] := by + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput] + apply probEvent_le_of_relTriple + (relTriple_runThenFinalizeCleanFromTable_deferred_rootAware adversary parameter ftsSecret + fuel table) + intro left right hrelation hleft + exact hrelation hleft + +noncomputable def sampledDeferredCleanThroughTable + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp (Option (CleanRunResult (RetainedGameResult × SplitHashCache))) := do + let base ← sampleOtsHashTable + let table := completedStartTable LazyRevealProbe.State.empty base + let result ← runCleanFromTable LazyRevealProbe.State.empty fuel table + (deferredCleanRetainedRun adversary parameter ftsSecret) + finishCleanRunFromTable result + +noncomputable def sampledRootAwareCleanThroughTable + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp (Option (CleanRunResult (RetainedGameResult × SplitHashCache))) := do + let base ← sampleOtsHashTable + let table := completedStartTable LazyRevealProbe.State.empty base + let result ← runCleanFromTable LazyRevealProbe.State.empty fuel table + (rootAwareCleanRetainedRun adversary parameter ftsSecret) + finishCleanRunFromTable result + +theorem sampledDeferredCleanThroughTable_eq + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + sampledDeferredCleanThroughTable adversary parameter ftsSecret fuel = + sampledRunThenFinalizeClean LazyRevealProbe.State.empty fuel + (deferredCleanRetainedRun adversary parameter ftsSecret) := by + rfl + +theorem sampledRootAwareCleanThroughTable_eq + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + sampledRootAwareCleanThroughTable adversary parameter ftsSecret fuel = + sampledRunThenFinalizeClean LazyRevealProbe.State.empty fuel + (rootAwareCleanRetainedRun adversary parameter ftsSecret) := by + rfl + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 1000000 in +theorem probEvent_sampledDeferredClean_none_le_rootAware + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[= none | sampledRunThenFinalizeClean + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel + (deferredCleanRetainedRun adversary parameter ftsSecret)] ≤ + Pr[= none | sampledRunThenFinalizeClean + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel + (rootAwareCleanRetainedRun adversary parameter ftsSecret)] := by + rw [← sampledDeferredCleanThroughTable_eq adversary parameter ftsSecret fuel, + ← sampledRootAwareCleanThroughTable_eq adversary parameter ftsSecret fuel] + unfold sampledDeferredCleanThroughTable sampledRootAwareCleanThroughTable + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_bind_of_forall_le + intro base _hbase + dsimp only + rw [show (fun result : Option + (CleanRunResult (RetainedGameResult × SplitHashCache)) => + finishCleanRunFromTable result) = finishCleanRunFromTable by + funext result + rfl] + have hbound := probEvent_runThenFinalizeCleanFromTable_deferred_le_rootAware adversary + parameter ftsSecret fuel (completedStartTable LazyRevealProbe.State.empty base) + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput] at hbound + exact hbound + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelection.lean new file mode 100644 index 00000000..7d091c2a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelection.lean @@ -0,0 +1,646 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootDeferred + +/-! +# Layer-root ordinal selection + +The hidden ordinal risk is factored at the instant its candidate becomes available. The prefix +records that candidate together with the canonical deferred context, but does not inspect the +private structural output. The final equality test is therefore the only place where the selected +layer root is read. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +structure PrivateOrdinalSelection where + candidate : Probe + context : DeferredContext + candidates : List Probe + +noncomputable def selectedPrivateOrdinal? + (ordinal : Nat) (candidates : List Probe) (context : DeferredContext) : + Option PrivateOrdinalSelection := + if hselected : ordinal < candidates.length then + some ⟨candidates.get ⟨ordinal, hselected⟩, context, candidates⟩ + else none + +noncomputable def finishDirectPrivateOrdinalSelection + (observe : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (candidates : List Probe) : DirectWitnessResult α → + ProbComp (Option PrivateOrdinalSelection) + | .stoppedFuel => pure none + | .stoppedOrdinary => pure none + | .stoppedPrivate _ => pure none + | .done result => observe result.context result.remaining result.value candidates + +noncomputable def canonicalizeDirectPrivateOrdinalSelection + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) : + ProbComp (Option PrivateOrdinalSelection) := by + classical + let canonical := canonicalizeMaterializedValues table context + exact if PrivateStructuralHit canonical then pure none + else if PublishedValues context.state then + if DeferredCompletable table canonical then + observe canonical fuel value candidates + else pure none + else pure none + +noncomputable def directDetailedBoundaryPrivateOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option PrivateOrdinalSelection) := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + List Probe → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → + SplitHashCache → ProbComp (Option PrivateOrdinalSelection)) + (fun _value candidates context _fuel _table _cache => + pure (selectedPrivateOrdinal? ordinal candidates context)) + (fun query _next recursivelyRun candidates context fuel table cache => + if hselected : ordinal < candidates.length then + pure (some ⟨candidates.get ⟨ordinal, hselected⟩, context, candidates⟩) + else + match query with + | .inl (.inl n) => + runDirectResolvedWitnessFromTable context fuel table ((splitUniformImpl n).run cache) >>= + finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (fun nextContext remaining value laterCandidates => + recursivelyRun value.1 laterCandidates nextContext remaining table value.2)) + candidates + | .inl (.inr input) => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + if hnextSelected : ordinal < nextCandidates.length then + pure (some ⟨nextCandidates.get ⟨ordinal, hnextSelected⟩, context, + nextCandidates⟩) + else + runDirectResolvedWitnessFromTable context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) >>= + finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (fun nextContext remaining value laterCandidates => + recursivelyRun value.1 laterCandidates nextContext remaining table value.2)) + nextCandidates + | .inr message => + runDirectResolvedWitnessFromTable context fuel table + ((maskedSign parameter root ftsSecret message).run cache) >>= + finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (fun nextContext remaining value laterCandidates => + recursivelyRun value.1 laterCandidates nextContext remaining table value.2)) + candidates) + computation candidates context fuel table cache + +noncomputable def privateOrdinalSelectionFire : + Option PrivateOrdinalSelection → ProbComp Bool + | none => pure false + | some selection => hiddenPrivateCandidateFire selection.candidate selection.context + +theorem directDetailedBoundaryPrivateOrdinalSelection_eq_selected + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hselected : ordinal < candidates.length) : + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret computation + candidates context fuel table cache = + pure (some ⟨candidates.get ⟨ordinal, hselected⟩, context, candidates⟩) := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryPrivateOrdinalSelection, OracleComp.construct_pure] + simp [selectedPrivateOrdinal?, hselected] + | query_bind query next ih => + rw [directDetailedBoundaryPrivateOrdinalSelection, OracleComp.construct_query_bind] + simp only [hselected, ↓reduceDIte] + +def PrivateOrdinalSelectionExtends + (initial : List Probe) : Option PrivateOrdinalSelection → Prop + | none => True + | some selection => initial.IsPrefix selection.candidates + +theorem PrivateOrdinalSelectionExtends.mono + {first second : List Probe} {selection : Option PrivateOrdinalSelection} + (hprefix : first.IsPrefix second) + (hextends : PrivateOrdinalSelectionExtends second selection) : + PrivateOrdinalSelectionExtends first selection := by + cases selection with + | none => trivial + | some selection => exact hprefix.trans hextends + +theorem privateOrdinalSelectionExtends_selectedPrivateOrdinal + (ordinal : Nat) (candidates : List Probe) (context : DeferredContext) : + PrivateOrdinalSelectionExtends candidates + (selectedPrivateOrdinal? ordinal candidates context) := by + unfold selectedPrivateOrdinal? + split <;> simp [PrivateOrdinalSelectionExtends] + +theorem privateOrdinalSelectionExtends_of_mem_finish + (observe : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (candidates : List Probe) (result : DirectWitnessResult α) + (hobserve : ∀ resolved output, + result = .done resolved → + output ∈ support + (observe resolved.context resolved.remaining resolved.value candidates) → + PrivateOrdinalSelectionExtends candidates output) + (output : Option PrivateOrdinalSelection) + (houtput : output ∈ support + (finishDirectPrivateOrdinalSelection observe candidates result)) : + PrivateOrdinalSelectionExtends candidates output := by + cases result with + | stoppedFuel => simp [finishDirectPrivateOrdinalSelection] at houtput; subst output; trivial + | stoppedOrdinary => simp [finishDirectPrivateOrdinalSelection] at houtput; subst output; trivial + | stoppedPrivate witness => + simp [finishDirectPrivateOrdinalSelection] at houtput + subst output + trivial + | done resolved => + exact hobserve resolved output rfl houtput + +theorem privateOrdinalSelectionExtends_of_mem_canonicalize + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (context : DeferredContext) (fuel : Nat) (value : α) + (candidates : List Probe) + (hobserve : ∀ nextContext output, + output ∈ support (observe nextContext fuel value candidates) → + PrivateOrdinalSelectionExtends candidates output) + (output : Option PrivateOrdinalSelection) + (houtput : output ∈ support + (canonicalizeDirectPrivateOrdinalSelection table observe context fuel value candidates)) : + PrivateOrdinalSelectionExtends candidates output := by + classical + unfold canonicalizeDirectPrivateOrdinalSelection at houtput + let canonical := canonicalizeMaterializedValues table context + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit] at houtput + subst output + trivial + · simp only [canonical, hhit, ↓reduceIte] at houtput + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] at houtput + by_cases hcompletable : DeferredCompletable table canonical + · change DeferredCompletable table (canonicalizeMaterializedValues table context) + at hcompletable + rw [if_pos hcompletable] at houtput + exact hobserve canonical output houtput + · change ¬DeferredCompletable table (canonicalizeMaterializedValues table context) + at hcompletable + rw [if_neg hcompletable] at houtput + simp only [support_pure, Set.mem_singleton_iff] at houtput + subst output + trivial + · simp [hpublished] at houtput + subst output + trivial + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem privateOrdinalSelectionExtends_of_mem_direct + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (output : Option PrivateOrdinalSelection) + (houtput : output ∈ support + (directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret computation + candidates context fuel table cache)) : + PrivateOrdinalSelectionExtends candidates output := by + induction computation using OracleComp.inductionOn generalizing + candidates context fuel cache output with + | pure value => + rw [directDetailedBoundaryPrivateOrdinalSelection, OracleComp.construct_pure] at houtput + simp only [support_pure, Set.mem_singleton_iff] at houtput + subst output + exact privateOrdinalSelectionExtends_selectedPrivateOrdinal ordinal candidates context + | query_bind query next ih => + rw [directDetailedBoundaryPrivateOrdinalSelection, + OracleComp.construct_query_bind] at houtput + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte, support_pure, Set.mem_singleton_iff] at houtput + subst output + simp [PrivateOrdinalSelectionExtends] + · simp only [hselected, ↓reduceDIte] at houtput + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + apply privateOrdinalSelectionExtends_of_mem_finish _ candidates result + (output := output) (houtput := hfinish) + intro resolved nextOutput heq hnextOutput + subst result + apply privateOrdinalSelectionExtends_of_mem_canonicalize table _ + resolved.context resolved.remaining resolved.value candidates + (output := nextOutput) (houtput := hnextOutput) + intro nextContext finalOutput hfinalOutput + exact ih resolved.value.1 candidates nextContext resolved.remaining + resolved.value.2 finalOutput hfinalOutput + | inr input => + let publicContext := context + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte, support_pure, + Set.mem_singleton_iff] at houtput + subst output + have hprefix : candidates.IsPrefix nextCandidates := by + unfold nextCandidates appendPlannedCandidate + cases rootAwarePlannedCandidate? parameter input context.state <;> simp + exact hprefix + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + have hprefix : candidates.IsPrefix nextCandidates := by + unfold nextCandidates appendPlannedCandidate + cases rootAwarePlannedCandidate? parameter input context.state <;> simp + apply PrivateOrdinalSelectionExtends.mono hprefix + apply privateOrdinalSelectionExtends_of_mem_finish _ nextCandidates result + (output := output) (houtput := hfinish) + intro resolved nextOutput heq hnextOutput + subst result + apply privateOrdinalSelectionExtends_of_mem_canonicalize table _ + resolved.context resolved.remaining resolved.value nextCandidates + (output := nextOutput) (houtput := hnextOutput) + intro nextContext finalOutput hfinalOutput + exact ih resolved.value.1 nextCandidates nextContext resolved.remaining + resolved.value.2 finalOutput hfinalOutput + | inr message => + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + apply privateOrdinalSelectionExtends_of_mem_finish _ candidates result + (output := output) (houtput := hfinish) + intro resolved nextOutput heq hnextOutput + subst result + apply privateOrdinalSelectionExtends_of_mem_canonicalize table _ + resolved.context resolved.remaining resolved.value candidates + (output := nextOutput) (houtput := hnextOutput) + intro nextContext finalOutput hfinalOutput + exact ih resolved.value.1 candidates nextContext resolved.remaining + resolved.value.2 finalOutput hfinalOutput + +def PrivateOrdinalSelectionPendingCovered + (ordinal : Nat) : Option PrivateOrdinalSelection → Prop + | none => True + | some selection => + PendingCoveredBy (selection.candidates.take ordinal) selection.context + +theorem privateOrdinalSelectionPendingCovered_of_mem_finish + (ordinal : Nat) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (candidates : List Probe) (result : DirectWitnessResult α) + (hobserve : ∀ resolved output, + result = .done resolved → + output ∈ support + (observe resolved.context resolved.remaining resolved.value candidates) → + PrivateOrdinalSelectionPendingCovered ordinal output) + (output : Option PrivateOrdinalSelection) + (houtput : output ∈ support + (finishDirectPrivateOrdinalSelection observe candidates result)) : + PrivateOrdinalSelectionPendingCovered ordinal output := by + cases result with + | stoppedFuel => simp [finishDirectPrivateOrdinalSelection] at houtput; subst output; trivial + | stoppedOrdinary => simp [finishDirectPrivateOrdinalSelection] at houtput; subst output; trivial + | stoppedPrivate witness => + simp [finishDirectPrivateOrdinalSelection] at houtput + subst output + trivial + | done resolved => exact hobserve resolved output rfl houtput + +theorem privateOrdinalSelectionPendingCovered_of_mem_canonicalize + (ordinal : Nat) (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (context : DeferredContext) (fuel : Nat) (value : α) + (candidates : List Probe) + (hobserve : ∀ nextContext output, + PendingCoveredBy candidates nextContext → + output ∈ support (observe nextContext fuel value candidates) → + PrivateOrdinalSelectionPendingCovered ordinal output) + (hcovered : PendingCoveredBy candidates context) + (output : Option PrivateOrdinalSelection) + (houtput : output ∈ support + (canonicalizeDirectPrivateOrdinalSelection table observe context fuel value candidates)) : + PrivateOrdinalSelectionPendingCovered ordinal output := by + classical + unfold canonicalizeDirectPrivateOrdinalSelection at houtput + let canonical := canonicalizeMaterializedValues table context + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit] at houtput + subst output + trivial + · simp only [canonical, hhit, ↓reduceIte] at houtput + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] at houtput + by_cases hcompletable : DeferredCompletable table canonical + · rw [if_pos hcompletable] at houtput + apply hobserve canonical output + · exact (pendingCoveredBy_canonicalize_iff table candidates context).2 hcovered + · exact houtput + · rw [if_neg hcompletable] at houtput + simp only [support_pure, Set.mem_singleton_iff] at houtput + subst output + trivial + · simp [hpublished] at houtput + subst output + trivial + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem privateOrdinalSelectionPendingCovered_of_mem_direct + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcovered : PendingCoveredBy candidates context) + (hlength : candidates.length ≤ ordinal) + (output : Option PrivateOrdinalSelection) + (houtput : output ∈ support + (directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret computation + candidates context fuel table cache)) : + PrivateOrdinalSelectionPendingCovered ordinal output := by + induction computation using OracleComp.inductionOn generalizing + candidates context fuel cache output with + | pure value => + rw [directDetailedBoundaryPrivateOrdinalSelection, OracleComp.construct_pure] at houtput + have hnotSelected : ¬ordinal < candidates.length := by omega + simp [selectedPrivateOrdinal?, hnotSelected] at houtput + subst output + trivial + | query_bind query next ih => + rw [directDetailedBoundaryPrivateOrdinalSelection, + OracleComp.construct_query_bind] at houtput + have hnotSelected : ¬ordinal < candidates.length := by omega + simp only [hnotSelected, ↓reduceDIte] at houtput + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + apply privateOrdinalSelectionPendingCovered_of_mem_finish ordinal _ candidates result + (output := output) (houtput := hfinish) + intro resolved nextOutput heq hnextOutput + subst result + have hdetailed : DirectDetailedResult.done resolved ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((splitUniformImpl n).run cache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((splitUniformImpl n).run cache) context fuel table, support_map] + exact ⟨DirectWitnessResult.done resolved, hresult, rfl⟩ + have hprobeBound : ((splitUniformImpl n).run cache).IsQueryBoundP + (IsUncoveredProbe candidates) 0 := + OracleComp.IsQueryBoundP.of_imp (isUncoveredProbe_imp_isProbe candidates) + (splitUniformImpl_probeFree n cache) + have hnextCovered := pendingCoveredBy_of_done_runDirectResolvedDetailedFromTable + candidates ((splitUniformImpl n).run cache) context fuel table resolved hcovered + hprobeBound hdetailed + apply privateOrdinalSelectionPendingCovered_of_mem_canonicalize ordinal table _ + resolved.context resolved.remaining resolved.value candidates _ hnextCovered + nextOutput hnextOutput + intro nextContext finalOutput hfinalCovered hfinalOutput + exact ih resolved.value.1 candidates nextContext resolved.remaining resolved.value.2 + hfinalCovered hlength finalOutput hfinalOutput + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let candidate? := rootAwarePlannedCandidate? parameter input context.state + let nextCandidates := appendPlannedCandidate candidates candidate? + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte, support_pure, + Set.mem_singleton_iff] at houtput + subst output + change PendingCoveredBy (nextCandidates.take ordinal) context + cases hcandidate : candidate? with + | none => + have hnextEq : nextCandidates = candidates := by + simp [nextCandidates, appendPlannedCandidate, hcandidate] + exfalso + rw [hnextEq] at hnextSelected + omega + | some candidate => + have hlengthEq : candidates.length = ordinal := by + have hnextLength : nextCandidates.length = candidates.length + 1 := by + simp [nextCandidates, appendPlannedCandidate, hcandidate] + omega + have htake : nextCandidates.take ordinal = candidates := by + simp [nextCandidates, appendPlannedCandidate, hcandidate, hlengthEq] + rwa [htake] + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + have hnextLength : nextCandidates.length ≤ ordinal := by omega + have hnextCoveredAtStart : PendingCoveredBy nextCandidates context := by + apply hcovered.mono_candidates + unfold nextCandidates candidate? appendPlannedCandidate + cases rootAwarePlannedCandidate? parameter input context.state <;> simp + apply privateOrdinalSelectionPendingCovered_of_mem_finish ordinal _ nextCandidates + result (output := output) (houtput := hfinish) + intro resolved nextOutput heq hnextOutput + subst result + have hplanMem : ∀ candidate, plan.candidate? = some candidate → + candidate ∈ nextCandidates := by + intro candidate hcandidate + have hrecorded := rootAwarePlannedCandidate?_eq_of_plan_some hcandidate + simp [nextCandidates, candidate?, appendPlannedCandidate, hrecorded] + have hprobeBound := probingHashQueryAfterPlan_probeBound parameter input plan + nextCandidates hplanMem cache + have hdetailed : DirectDetailedResult.done resolved ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterPlan parameter input plan).run cache) context fuel table, + support_map] + exact ⟨DirectWitnessResult.done resolved, hresult, rfl⟩ + have hnextCovered := pendingCoveredBy_of_done_runDirectResolvedDetailedFromTable + nextCandidates ((probingHashQueryAfterPlan parameter input plan).run cache) + context fuel table resolved hnextCoveredAtStart hprobeBound hdetailed + apply privateOrdinalSelectionPendingCovered_of_mem_canonicalize ordinal table _ + resolved.context resolved.remaining resolved.value nextCandidates _ hnextCovered + nextOutput hnextOutput + intro nextContext finalOutput hfinalCovered hfinalOutput + exact ih resolved.value.1 nextCandidates nextContext resolved.remaining + resolved.value.2 hfinalCovered hnextLength finalOutput hfinalOutput + | inr message => + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + apply privateOrdinalSelectionPendingCovered_of_mem_finish ordinal _ candidates result + (output := output) (houtput := hfinish) + intro resolved nextOutput heq hnextOutput + subst result + have hprobeBound : ((maskedSign parameter root ftsSecret message).run cache).IsQueryBoundP + (IsUncoveredProbe candidates) 0 := + OracleComp.IsQueryBoundP.of_imp (isUncoveredProbe_imp_isProbe candidates) + (maskedSign_probeFree parameter root ftsSecret message cache) + have hdetailed : DirectDetailedResult.done resolved ∈ support + (runDirectResolvedDetailedFromTable context fuel table + ((maskedSign parameter root ftsSecret message).run cache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((maskedSign parameter root ftsSecret message).run cache) context fuel table, + support_map] + exact ⟨DirectWitnessResult.done resolved, hresult, rfl⟩ + have hnextCovered := pendingCoveredBy_of_done_runDirectResolvedDetailedFromTable + candidates ((maskedSign parameter root ftsSecret message).run cache) context fuel table + resolved hcovered hprobeBound hdetailed + apply privateOrdinalSelectionPendingCovered_of_mem_canonicalize ordinal table _ + resolved.context resolved.remaining resolved.value candidates _ hnextCovered + nextOutput hnextOutput + intro nextContext finalOutput hfinalCovered hfinalOutput + exact ih resolved.value.1 candidates nextContext resolved.remaining resolved.value.2 + hfinalCovered hlength finalOutput hfinalOutput + +theorem finishDirectPrivateOrdinalSelection_bind_fire + (selectionObserve : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (riskObserve : DeferredContext → Nat → α → List Probe → ProbComp Bool) + (candidates : List Probe) (result : DirectWitnessResult α) + (hobserve : ∀ context fuel value laterCandidates, + selectionObserve context fuel value laterCandidates >>= privateOrdinalSelectionFire = + riskObserve context fuel value laterCandidates) : + finishDirectPrivateOrdinalSelection selectionObserve candidates result >>= + privateOrdinalSelectionFire = + finishDirectWitnessOrdinalRisk riskObserve candidates result := by + cases result with + | stoppedFuel => simp [finishDirectPrivateOrdinalSelection, + finishDirectWitnessOrdinalRisk, privateOrdinalSelectionFire] + | stoppedOrdinary => simp [finishDirectPrivateOrdinalSelection, + finishDirectWitnessOrdinalRisk, privateOrdinalSelectionFire] + | stoppedPrivate witness => simp [finishDirectPrivateOrdinalSelection, + finishDirectWitnessOrdinalRisk, privateOrdinalSelectionFire] + | done result => + simpa [finishDirectPrivateOrdinalSelection, finishDirectWitnessOrdinalRisk] using + hobserve result.context result.remaining result.value candidates + +theorem canonicalizeDirectPrivateOrdinalSelection_bind_fire + (table : OtsSecretIndex → HashOutput) + (selectionObserve : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (riskObserve : DeferredContext → Nat → α → List Probe → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hobserve : ∀ nextContext remaining nextValue laterCandidates, + selectionObserve nextContext remaining nextValue laterCandidates >>= + privateOrdinalSelectionFire = + riskObserve nextContext remaining nextValue laterCandidates) : + canonicalizeDirectPrivateOrdinalSelection table selectionObserve context fuel value + candidates >>= + privateOrdinalSelectionFire = + canonicalizeDirectWitnessOrdinalRisk table riskObserve context fuel value candidates := by + classical + unfold canonicalizeDirectPrivateOrdinalSelection canonicalizeDirectWitnessOrdinalRisk + let canonical := canonicalizeMaterializedValues table context + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit, privateOrdinalSelectionFire] + · simp only [canonical, hhit, ↓reduceIte] + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table canonical + · simpa [canonical, hcompletable] using + (hobserve canonical fuel value candidates) + · simp [canonical, hcompletable, privateOrdinalSelectionFire] + · simp [hpublished, privateOrdinalSelectionFire] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem directDetailedBoundaryPrivateOrdinalHiddenRisk_eq_selection_bind_fire + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret computation + candidates context fuel table cache >>= + privateOrdinalSelectionFire = + directDetailedBoundaryPrivateOrdinalHiddenRisk ordinal parameter root ftsSecret computation + candidates context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing + candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryPrivateOrdinalSelection, OracleComp.construct_pure, + directDetailedBoundaryPrivateOrdinalHiddenRisk, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp [selectedPrivateOrdinal?, hselected, privateOrdinalSelectionFire] + · simp [selectedPrivateOrdinal?, hselected, privateOrdinalSelectionFire] + | query_bind query next ih => + rw [directDetailedBoundaryPrivateOrdinalSelection, OracleComp.construct_query_bind, + directDetailedBoundaryPrivateOrdinalHiddenRisk, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp [hselected, privateOrdinalSelectionFire] + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [bind_assoc] + apply bind_congr + intro result + apply finishDirectPrivateOrdinalSelection_bind_fire + intro nextContext remaining value laterCandidates + apply canonicalizeDirectPrivateOrdinalSelection_bind_fire + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [nextCandidates] using hnextSelected + simp [hactual, privateOrdinalSelectionFire] + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state)).length := by + simpa [nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + rw [bind_assoc] + apply bind_congr + intro result + apply finishDirectPrivateOrdinalSelection_bind_fire + intro nextContext remaining value laterCandidates + apply canonicalizeDirectPrivateOrdinalSelection_bind_fire + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + | inr message => + rw [bind_assoc] + apply bind_congr + intro result + apply finishDirectPrivateOrdinalSelection_bind_fire + intro nextContext remaining value laterCandidates + apply canonicalizeDirectPrivateOrdinalSelection_bind_fire + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionBoundary.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionBoundary.lean new file mode 100644 index 00000000..7b3970bd --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionBoundary.lean @@ -0,0 +1,534 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionInitial + +/-! +# Root-selection boundary + +The failure-retaining materialized prefix is averaged over the same top-root result and root-output +parts as the exchangeable optional prefix. Its selected branch projects to that optional prefix, +while its failure branch remains explicit for the shared clean-finalization charge. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option maxRecDepth 100000 +set_option maxHeartbeats 2000000 +set_option linter.constructorNameAsVariable false + +set_option maxRecDepth 100000 in +theorem pending_subset_of_done_runRaw_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state finalState : LazyRevealProbe.State Coordinate) (fuel remaining : Nat) + (value : α) + (hprobeFree : computation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) + (hresult : LazyRevealProbe.RawResult.done finalState remaining value ∈ + support (LazyRevealProbe.runRaw state fuel computation)) : + finalState.pending ⊆ state.pending := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure output => + simp [LazyRevealProbe.runRaw] at hresult + rcases hresult with ⟨rfl, rfl, rfl⟩ + exact Finset.Subset.rfl + | query_bind query next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hprobeFree + cases query with + | uniform n => + rw [LazyRevealProbe.runRaw_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output state fuel (hprobeFree.2 output) htail + | hashOutput => + rw [LazyRevealProbe.runRaw_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output state fuel (hprobeFree.2 output) htail + | ensure coordinate => + rw [LazyRevealProbe.runRaw_ensure_query_bind] at hresult + exact ih () (state.ensure coordinate) fuel (hprobeFree.2 ()) hresult + | probe coordinate candidate => + simp [LazyRevealProbe.IsProbe] at hprobeFree + | peek coordinate => + rw [LazyRevealProbe.runRaw_peek_query_bind] at hresult + exact ih (state.values coordinate) state fuel (hprobeFree.2 _) hresult + | publish coordinate => + rw [LazyRevealProbe.runRaw_publish_query_bind] at hresult + exact ih () (state.publish coordinate) fuel (hprobeFree.2 ()) hresult + | reveal coordinate => + rw [LazyRevealProbe.runRaw_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + simp only [hvalue] at hresult + exact ih output state fuel (hprobeFree.2 output) hresult + | none => + simp only [hvalue, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + by_cases hhit : state.hitAt coordinate output + · simp [hhit] at htail + · simp only [hhit, ↓reduceIte] at htail + exact (ih output (state.materialize coordinate output) fuel + (hprobeFree.2 output) htail).trans (Finset.filter_subset _ _) + +attribute [local irreducible] maskedPublishedTreeRoot + +theorem pending_eq_empty_of_mem_runCleanFromTable_maskedPublishedTreeRoot + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : CleanRunResult (Digest × SplitHashCache)) + (hresult : some result ∈ support + (runCleanFromTable (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) : + result.state.pending = ∅ := by + have hraw := mem_support_runRaw_done_of_mem_runCleanFromTable_some + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table result hresult + have hsubset := pending_subset_of_done_runRaw_of_probeFree + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) result.state fuel + result.remaining result.value (maskedPublishedTreeRoot_probeFree emptySplitHashCache) hraw + simpa [LazyRevealProbe.State.empty] using hsubset + +theorem rootContext_invariants_of_mem_runCleanFromTable + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (high : RootOutputHigh) (leftRoot : Digest) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : CleanRunResult (Digest × SplitHashCache)) + (hresult : some result ∈ support + (runCleanFromTable (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) : + let context : DeferredContext := + { directDeferredContext result.state with + values := (directDeferredContext result.state).values.install target + (rootOutputOfParts leftRoot high) } + context.Valid ∧ DeferredCompletable result.table context ∧ PublishedValues result.state := by + let output := rootOutputOfParts leftRoot high + let context : DeferredContext := + { directDeferredContext result.state with + values := (directDeferredContext result.state).values.install target output } + have hpending := pending_eq_empty_of_mem_runCleanFromTable_maskedPublishedTreeRoot + fuel table result hresult + have habsent := target_absent_of_mem_runCleanFromTable_maskedPublishedTreeRoot target hroot + hparent fuel table result hresult + have hvalid : context.Valid := by + constructor + · intro position existing hvalue + by_cases heq : position = target + · subst position + have hvalue' : result.state.values (.position target) = some existing := by + simpa [context, directDeferredContext] using hvalue + rw [habsent.1] at hvalue' + contradiction + · simpa [context, directDeferredContext, directDeferredValues, + DeferredStructuralValues.install, heq] using hvalue + · intro coordinate existing hvalue + exact not_hitAt_of_pending_eq_empty context coordinate existing (by + simpa [context, directDeferredContext] using hpending) + have hstartsResult := startTableAgrees_of_mem_runCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (startTableAgrees_empty table) result hresult + have hprivate : ¬PrivateStructuralHit context := by + rintro ⟨position, existing, _hhidden, _hvalue, hhit⟩ + exact not_hitAt_of_pending_eq_empty context (.position position) existing (by + simpa [context, directDeferredContext] using hpending) hhit + have hstart : ¬MissingChainStartHit table context := by + rintro ⟨index, _hvalue, hhit⟩ + exact not_hitAt_of_pending_eq_empty context index.coordinate (table index) (by + simpa [context, directDeferredContext] using hpending) hhit + have hcard : context.state.pending.card < Fintype.card Digest := by + rw [show context.state.pending = ∅ by simpa [context, directDeferredContext] using hpending] + simp + have hcompletable : DeferredCompletable result.table context := by + rw [hstartsResult.1] + exact deferredCompletable_of_valid_of_no_boundary_hit table context hvalid hstartsResult.2 + hprivate hstart hcard + have hraw := mem_support_runRaw_done_of_mem_runCleanFromTable_some + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table result hresult + have hpublished : PublishedValues result.state := + preservesPublishedValues_maskedPublishedTreeRoot + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) emptySplitHashCache fuel + result.state result.remaining result.value.1 result.value.2 publishedValues_empty hraw + exact ⟨hvalid, hcompletable, hpublished⟩ + +noncomputable def directRootSelectionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (high : RootOutputHigh) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (leftRoot _rightRoot : Digest) : ProbComp (Option PrivateOrdinalSelection) := + let output := fun root => rootOutputOfParts root high + let context : DeferredContext := directDeferredContext rootResult.state + let rootContext := + { context with values := context.values.install target (output leftRoot) } + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (canonicalizeMaterializedValues rootResult.table rootContext) rootResult.remaining + rootResult.table (rootInstalledCache target output rootResult.value.2 leftRoot) + +noncomputable def materializedRootSelectionOutcomeAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (high : RootOutputHigh) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (leftRoot rightRoot : Digest) : ProbComp MaterializedSelectionOutcome := + let output := fun root => rootOutputOfParts root high + let context : DeferredContext := directDeferredContext rootResult.state + let rootContext := + { context with values := context.values.install target (output leftRoot) } + materializedActualRootAvoidingOrdinalSelectionOutcome ordinal parameter rootResult.value.1 target + leftRoot rightRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState rootContext) rootResult.remaining rootResult.table + (rootInstalledCache target output rootResult.value.2 leftRoot) + +set_option maxRecDepth 100000 in +theorem relTriple_directRootSelectionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (high : RootOutputHigh) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (leftRoot rightRoot : Digest) + (hvalid : + ({ directDeferredContext rootResult.state with + values := (directDeferredContext rootResult.state).values.install target + (rootOutputOfParts leftRoot high) } : DeferredContext).Valid) + (hcompletable : DeferredCompletable rootResult.table + { directDeferredContext rootResult.state with + values := (directDeferredContext rootResult.state).values.install target + (rootOutputOfParts leftRoot high) }) + (hpublished : PublishedValues rootResult.state) : + RelTriple + (directRootSelectionAfterRootResult ordinal adversary parameter ftsSecret target high + rootResult leftRoot rightRoot) + (materializedRootSelectionOutcomeAfterRootResult ordinal adversary parameter ftsSecret + target high rootResult leftRoot rightRoot) + (RootSelectionBridgeRel target (rootOutputOfParts leftRoot high) rightRoot ordinal) := by + let output := fun root => rootOutputOfParts root high + let rootContext : DeferredContext := + { directDeferredContext rootResult.state with + values := (directDeferredContext rootResult.state).values.install target (output leftRoot) } + let materializedContext := materializedDeferredContext rootContext + have hbase : FinalizationContextLE rootResult.table rootContext materializedContext := + finalizationContextLE_materializedDeferredContext hvalid hcompletable + have hcontext : FinalizationContextLE rootResult.table + (canonicalizeMaterializedValues rootResult.table rootContext) materializedContext := + hbase.canonicalize_left + have hvalues : LazyRevealProbe.ValuesLE + (canonicalizeMaterializedValues rootResult.table rootContext).state + materializedContext.state := + (valuesLE_canonicalizeMaterializedValues_left rootResult.table rootContext + hbase.view.leftStarts hpublished).trans + (valuesLE_materializedDeferredState rootContext) + have hrel := relTriple_directRootSelection_materializedOutcome ordinal parameter + rootResult.value.1 target (output leftRoot) rightRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (canonicalizeMaterializedValues rootResult.table rootContext) materializedContext + rootResult.remaining rootResult.remaining rootResult.table + (rootInstalledCache target output rootResult.value.2 leftRoot) + (rootInstalledCache target output rootResult.value.2 leftRoot) + hcontext le_rfl rfl rfl hvalues hpublished.to_canonicalizedMaterializedValues rfl + (canonicalizeMaterializedValues_canonical rootResult.table rootContext + hvalid.valuesConsistent) + (CandidatesAvoidRoots.nil target (truncateHash (output leftRoot)) rightRoot) + simpa [directRootSelectionAfterRootResult, + materializedRootSelectionOutcomeAfterRootResult, output, rootContext, materializedContext, + materializedDeferredContext, directDeferredContext] + using hrel + +noncomputable def sampledHighDirectRootSelectionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp (HashOutput × Digest × Option PrivateOrdinalSelection) := do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← directRootSelectionAfterRootResult ordinal adversary parameter ftsSecret + target high rootResult leftRoot rightRoot + pure (rootOutputOfParts leftRoot high, rightRoot, selection) + +theorem relTriple_materializedRootSelectionOutcomeAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (high : RootOutputHigh) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (leftRoot rightRoot : Digest) : + RelTriple + (materializedRootSelectionOutcomeAfterRootResult ordinal adversary parameter ftsSecret + target high rootResult leftRoot rightRoot) + (materializedRootSelectionAfterRootResult ordinal adversary parameter ftsSecret target high + rootResult leftRoot rightRoot) + (MaterializedOutcomeOptionRel target leftRoot) := by + unfold materializedRootSelectionOutcomeAfterRootResult + materializedRootSelectionAfterRootResult + exact relTriple_materializedActualOutcome_optionalSelection ordinal parameter rootResult.value.1 + target leftRoot rightRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState + { directDeferredContext rootResult.state with + values := (directDeferredContext rootResult.state).values.install target + (rootOutputOfParts leftRoot high) }) + rootResult.remaining rootResult.table + (rootInstalledCache target (fun root => rootOutputOfParts root high) rootResult.value.2 leftRoot) + +noncomputable def sampledHighMaterializedRootSelectionOutcomeAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp (Digest × Digest × MaterializedSelectionOutcome) := do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let outcome ← materializedRootSelectionOutcomeAfterRootResult ordinal adversary parameter + ftsSecret target high rootResult leftRoot rightRoot + pure (leftRoot, rightRoot, outcome) + +set_option maxRecDepth 100000 in +theorem relTriple_sampledHigh_directRootSelectionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) : + RelTriple + (sampledHighDirectRootSelectionAfterRootResult ordinal adversary parameter ftsSecret target + rootResult) + (sampledHighMaterializedRootSelectionOutcomeAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) + (fun left right => + truncateHash left.1 = right.1 ∧ left.2.1 = right.2.1 ∧ + RootSelectionBridgeRel target left.1 left.2.1 ordinal left.2.2 right.2.2) := by + unfold sampledHighDirectRootSelectionAfterRootResult + sampledHighMaterializedRootSelectionOutcomeAfterRootResult + apply relTriple_bind (relTriple_refl ($ᵗ RootOutputHigh : ProbComp RootOutputHigh)) + intro leftHigh rightHigh hhigh + subst rightHigh + apply relTriple_bind (relTriple_refl ($ᵗ Digest : ProbComp Digest)) + intro leftRoot rightRoot hleftRoot + subst rightRoot + apply relTriple_bind (relTriple_refl ($ᵗ Digest : ProbComp Digest)) + intro leftComparison rightComparison hcomparison + subst rightComparison + obtain ⟨hvalid, hcompletable, hpublished⟩ := + rootContext_invariants_of_mem_runCleanFromTable target hroot hparent leftHigh leftRoot fuel + table rootResult hresult + apply relTriple_bind + (relTriple_directRootSelectionAfterRootResult ordinal adversary parameter ftsSecret target + leftHigh rootResult leftRoot leftComparison hvalid hcompletable hpublished) + intro leftSelection rightOutcome hselection + exact relTriple_pure_pure + ⟨truncateHash_rootOutputOfParts leftRoot leftHigh, rfl, hselection⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_sampledHigh_materializedRootSelectionOutcomeAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + RelTriple + (sampledHighMaterializedRootSelectionOutcomeAfterRootResult ordinal adversary parameter + ftsSecret target rootResult) + (sampledHighMaterializedRootSelectionAfterRootResult ordinal adversary parameter ftsSecret + target rootResult) + (fun left right => + left.1 = right.1 ∧ left.2.1 = right.2.1 ∧ + MaterializedOutcomeOptionRel target left.1 left.2.2 right.2.2) := by + unfold sampledHighMaterializedRootSelectionOutcomeAfterRootResult + sampledHighMaterializedRootSelectionAfterRootResult + apply relTriple_bind (relTriple_refl ($ᵗ RootOutputHigh : ProbComp RootOutputHigh)) + intro leftHigh rightHigh hhigh + subst rightHigh + apply relTriple_bind (relTriple_refl ($ᵗ Digest : ProbComp Digest)) + intro leftRoot rightRoot hroot + subst rightRoot + apply relTriple_bind (relTriple_refl ($ᵗ Digest : ProbComp Digest)) + intro leftComparison rightComparison hcomparison + subst rightComparison + apply relTriple_bind + (relTriple_materializedRootSelectionOutcomeAfterRootResult ordinal adversary parameter + ftsSecret target leftHigh rootResult leftRoot leftComparison) + intro leftOutcome rightSelection hselection + exact relTriple_pure_pure ⟨rfl, rfl, hselection⟩ + +theorem probEvent_sampledHigh_materializedRootSelectionOutcome_match_le + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + Pr[fun result => result.2.2.Matches target result.1 | + sampledHighMaterializedRootSelectionOutcomeAfterRootResult ordinal adversary parameter + ftsSecret target rootResult] ≤ + Pr[fun result => materializedOrdinalSelectionMatches target result.1 result.2.2 | + sampledHighMaterializedRootSelectionAfterRootResult ordinal adversary parameter ftsSecret + target rootResult] := by + apply probEvent_le_of_relTriple + (relTriple_sampledHigh_materializedRootSelectionOutcomeAfterRootResult ordinal adversary + parameter ftsSecret target rootResult) + intro left right hrel hmatch + rw [← hrel.1] + exact hrel.2.2 hmatch + +noncomputable def materializedRootOrdinalOutcomeExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (Digest × Digest × MaterializedSelectionOutcome) := do + let rootResult ← runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure (0, 0, .failed) + | some result => + sampledHighMaterializedRootSelectionOutcomeAfterRootResult ordinal adversary parameter + ftsSecret target result + +noncomputable def directRootOrdinalSelectionExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (HashOutput × Digest × Option PrivateOrdinalSelection) := do + let rootResult ← runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure (hashOutputOfDigest 0, 0, none) + | some result => + sampledHighDirectRootSelectionAfterRootResult ordinal adversary parameter ftsSecret target + result + +set_option maxRecDepth 100000 in +theorem relTriple_directRootOrdinalSelectionExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + RelTriple + (directRootOrdinalSelectionExperimentAfterTable ordinal adversary parameter ftsSecret target + fuel table) + (materializedRootOrdinalOutcomeExperimentAfterTable ordinal adversary parameter ftsSecret + target fuel table) + (fun left right => + truncateHash left.1 = right.1 ∧ left.2.1 = right.2.1 ∧ + RootSelectionBridgeRel target left.1 left.2.1 ordinal left.2.2 right.2.2) := by + unfold directRootOrdinalSelectionExperimentAfterTable + materializedRootOrdinalOutcomeExperimentAfterTable + let rootRun := runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + have hbase := relTriple_refl rootRun + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support rootRun) (fun result hresult => hresult) + apply relTriple_bind hsupported + intro leftRootResult rightRootResult hrootResult + have heq : leftRootResult = rightRootResult := hrootResult.1 + rw [← heq] + cases leftRootResult with + | none => + exact relTriple_pure_pure ⟨truncateHash_hashOutputOfDigest 0, rfl, + rootSelectionBridgeRel_none_left target (hashOutputOfDigest 0) 0 ordinal .failed⟩ + | some result => + exact relTriple_sampledHigh_directRootSelectionAfterRootResult ordinal adversary parameter + ftsSecret target hroot hparent fuel table result hrootResult.2 + +set_option maxRecDepth 100000 in +theorem relTriple_materializedRootOrdinalOutcomeExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + RelTriple + (materializedRootOrdinalOutcomeExperimentAfterTable ordinal adversary parameter ftsSecret + target fuel table) + (materializedRootOrdinalMatchExperimentAfterTable ordinal adversary parameter ftsSecret + target fuel table) + (fun left right => + left.1 = right.1 ∧ left.2.1 = right.2.1 ∧ + MaterializedOutcomeOptionRel target left.1 left.2.2 right.2.2) := by + unfold materializedRootOrdinalOutcomeExperimentAfterTable + materializedRootOrdinalMatchExperimentAfterTable + apply relTriple_bind (relTriple_refl + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + intro leftRootResult rightRootResult hrootResult + subst rightRootResult + cases leftRootResult with + | none => + exact relTriple_pure_pure ⟨rfl, rfl, fun hmatch => False.elim hmatch⟩ + | some result => + exact relTriple_sampledHigh_materializedRootSelectionOutcomeAfterRootResult ordinal + adversary parameter ftsSecret target result + +theorem probEvent_materializedRootOrdinalOutcome_match_le + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + Pr[fun result => result.2.2.Matches target result.1 | + materializedRootOrdinalOutcomeExperimentAfterTable ordinal adversary parameter ftsSecret + target fuel table] ≤ + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + materializedRootOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ Pr[fun result => materializedOrdinalSelectionMatches target result.1 result.2.2 | + materializedRootOrdinalMatchExperimentAfterTable ordinal adversary parameter ftsSecret + target fuel table] := by + apply probEvent_le_of_relTriple + (relTriple_materializedRootOrdinalOutcomeExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table) + intro left right hrel hmatch + rw [← hrel.1] + exact hrel.2.2 hmatch + _ ≤ _ := probEvent_materializedRootOrdinalMatchExperimentAfterTable_le_mul ordinal + adversary parameter ftsSecret target hroot hparent fuel table + +theorem probEvent_directRootOrdinalSelection_good_le_failure_add_production_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + Pr[fun result => + privateOrdinalSelectionGoodForRoots target result.1 result.2.1 ordinal result.2.2 | + directRootOrdinalSelectionExperimentAfterTable ordinal adversary parameter ftsSecret + target fuel table] ≤ + Pr[fun result => result.2.2.isFailure | + materializedRootOrdinalOutcomeExperimentAfterTable ordinal adversary parameter ftsSecret + target fuel table] + + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + materializedRootOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ Pr[fun result => result.2.2.isFailure ∨ result.2.2.Matches target result.1 | + materializedRootOrdinalOutcomeExperimentAfterTable ordinal adversary parameter ftsSecret + target fuel table] := by + apply probEvent_le_of_relTriple + (relTriple_directRootOrdinalSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret target hroot hparent fuel table) + intro left right hrel hgood + have hbridge := hrel.2.2 hgood + rcases hbridge with hfailure | hmatch + · exact Or.inl hfailure + · rw [← hrel.1] + exact Or.inr hmatch + _ ≤ Pr[fun result => result.2.2.isFailure | + materializedRootOrdinalOutcomeExperimentAfterTable ordinal adversary parameter ftsSecret + target fuel table] + + Pr[fun result => result.2.2.Matches target result.1 | + materializedRootOrdinalOutcomeExperimentAfterTable ordinal adversary parameter ftsSecret + target fuel table] := + probEvent_or_le _ _ _ + _ ≤ _ := by + gcongr + exact probEvent_materializedRootOrdinalOutcome_match_le ordinal adversary parameter ftsSecret + target hroot hparent fuel table + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionDeferred.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionDeferred.lean new file mode 100644 index 00000000..b3ca9449 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionDeferred.lean @@ -0,0 +1,880 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionProbability + +/-! +# Deferred selection to materialized selection + +The ordinary refinement relation is generalized to two computations. This is the semantic bridge +between the real deferred planned suffix and the materialized suffix that executes the same public +plan. A private first fire on the deferred side remains an admissible stopped outcome; a +materialization-only discrepancy makes the right side doomed. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def Probe.AvoidsRoots + (target : Position) (leftRoot rightRoot : Digest) (candidate : Probe) : Prop := + candidate ≠ ⟨.position target, leftRoot⟩ ∧ + candidate ≠ ⟨.position target, rightRoot⟩ + +def CandidatesAvoidRoots + (target : Position) (leftRoot rightRoot : Digest) + (candidates : List Probe) : Prop := + ∀ candidate ∈ candidates, candidate.AvoidsRoots target leftRoot rightRoot + +def PrivateOrdinalSelection.GoodForRoots + (target : Position) (leftOutput : HashOutput) + (rightRoot : Digest) (ordinal : Nat) + (selection : PrivateOrdinalSelection) : Prop := + selection.candidate = ⟨.position target, truncateHash leftOutput⟩ ∧ + selection.context.state.values (.position target) = none ∧ + Coordinate.position target ∉ selection.context.state.revealed ∧ + selection.context.values target = some leftOutput ∧ + CandidatesAvoidRoots target (truncateHash leftOutput) rightRoot + (selection.candidates.take ordinal) + +def privateOrdinalSelectionGoodForRoots + (target : Position) (leftOutput : HashOutput) + (rightRoot : Digest) (ordinal : Nat) : + Option PrivateOrdinalSelection → Prop + | none => False + | some selection => selection.GoodForRoots target leftOutput rightRoot ordinal + +def materializedOrdinalSelectionMatches + (target : Position) (root : Digest) : Option Probe → Prop + | none => False + | some candidate => candidate = ⟨.position target, root⟩ + +theorem canonicalized_right_values_eq_of_finalizationContextLE + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hcontext : FinalizationContextLE table left right) + (hrevealed : left.state.revealed = right.state.revealed) + (hcanonical : CanonicalMaterializedValues table left) : + (canonicalizeMaterializedValues table right).state.values = left.state.values := by + funext coordinate + rw [hcanonical] + unfold canonicalizeMaterializedValues publicMaterializedValues + by_cases hleftRevealed : coordinate ∈ left.state.revealed + · have hrightRevealed : coordinate ∈ right.state.revealed := by + rw [← hrevealed] + exact hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + exact (congrFun hcontext.view.valueEq coordinate).symm + · have hrightRevealed : coordinate ∉ right.state.revealed := by + intro hmem + exact hleftRevealed (by rwa [hrevealed]) + simp [hleftRevealed, hrightRevealed] + +theorem CandidatesAvoidRoots.nil + (target : Position) (leftRoot rightRoot : Digest) : + CandidatesAvoidRoots target leftRoot rightRoot [] := by + simp [CandidatesAvoidRoots] + +theorem CandidatesAvoidRoots.append + {target : Position} {leftRoot rightRoot : Digest} + {candidates : List Probe} + (hprefix : CandidatesAvoidRoots target leftRoot rightRoot candidates) + (candidate : Probe) (hcandidate : candidate.AvoidsRoots target leftRoot rightRoot) : + CandidatesAvoidRoots target leftRoot rightRoot (candidates ++ [candidate]) := by + intro other hmem + rcases List.mem_append.mp hmem with hleft | hright + · exact hprefix other hleft + · have heq : other = candidate := by simpa using hright + subst other + exact hcandidate + +theorem rootAwareCandidateAvoidsRoots_iff + (target : Position) (leftRoot rightRoot : Digest) (candidate : Probe) : + RootAwareCandidateAvoidsRoots target leftRoot rightRoot (some candidate) ↔ + candidate.AvoidsRoots target leftRoot rightRoot := by + simp [RootAwareCandidateAvoidsRoots, Probe.AvoidsRoots] + +theorem not_goodForRoots_of_unsafe_prefix + {target : Position} {leftOutput : HashOutput} {rightRoot : Digest} + {ordinal : Nat} {selection : PrivateOrdinalSelection} + {initial : List Probe} {candidate : Probe} + (hgood : selection.GoodForRoots target leftOutput rightRoot ordinal) + (hprefix : initial.IsPrefix selection.candidates) + (hlength : initial.length ≤ ordinal) + (hmem : candidate ∈ initial) + (hunsafe : ¬candidate.AvoidsRoots target (truncateHash leftOutput) rightRoot) : False := by + have htake := hprefix.take ordinal + have htakePrefix : initial.IsPrefix (selection.candidates.take ordinal) := by + rw [(List.take_eq_self_iff initial).2 hlength] at htake + exact htake + have hcandidate : candidate ∈ selection.candidates.take ordinal := + htakePrefix.sublist.subset hmem + exact hunsafe (hgood.2.2.2.2 candidate hcandidate) + +theorem firstMissingInputCoordinatePlan_eq_of_values_eq + {left right : LazyRevealProbe.State Coordinate} + (hvalues : left.values = right.values) + (input : HashInput) : ∀ slot coordinates, + firstMissingInputCoordinatePlan left input slot coordinates = + firstMissingInputCoordinatePlan right input slot coordinates := by + intro slot coordinates + induction coordinates generalizing slot with + | nil => rfl + | cons coordinate remaining ih => + rw [firstMissingInputCoordinatePlan, firstMissingInputCoordinatePlan] + have hvalue := congrFun hvalues coordinate + cases hleft : left.values coordinate with + | none => + have hright : right.values coordinate = none := by rwa [← hvalue] + rw [hright] + | some output => + have hright : right.values coordinate = some output := by rwa [← hvalue] + rw [hright] + exact ih (slot + 1) + +theorem leafInputProbePlan_eq_of_values_eq + {left right : LazyRevealProbe.State Coordinate} + (hvalues : left.values = right.values) + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + leafInputProbePlan left input candidate lay tree leafIdx = + leafInputProbePlan right input candidate lay tree leafIdx := by + unfold leafInputProbePlan + have hvalue := congrFun hvalues candidate.coordinate + cases hleft : left.values candidate.coordinate with + | none => + have hright : right.values candidate.coordinate = none := by rwa [← hvalue] + rw [hright] + | some output => + have hright : right.values candidate.coordinate = some output := by rwa [← hvalue] + rw [hright] + exact firstMissingInputCoordinatePlan_eq_of_values_eq hvalues input 0 _ + +theorem purePlanProbingHashQuery_eq_of_values_eq + {left right : LazyRevealProbe.State Coordinate} + (hvalues : left.values = right.values) + (parameter : PublicParameter) (input : HashInput) : + purePlanProbingHashQuery parameter input left = + purePlanProbingHashQuery parameter input right := by + unfold purePlanProbingHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases hposition : decodePosition? parameter input with + | none => rfl + | some position => + cases position with + | leaf lay tree leafIdx => + simp only + rw [leafInputProbePlan_eq_of_values_eq hvalues] + | chain | node | ftsLeaf | ftsNode | ftsRoots => rfl + | none => + cases hposition : decodePosition? parameter input with + | none => rfl + | some position => + cases position with + | node lay tree level nodeIdx => + simp only + rw [firstMissingInputCoordinatePlan_eq_of_values_eq hvalues] + | chain | leaf | ftsLeaf | ftsNode | ftsRoots => rfl + +def OrdinaryMaterializedStableCouplesBetween + (table : OtsSecretIndex → HashOutput) + (left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftContext rightContext leftFuel rightFuel leftCache rightCache, + FinalizationContextLE table leftContext rightContext → + leftFuel ≤ rightFuel → + ordinaryQueryCache leftCache = ordinaryQueryCache rightCache → + leftContext.state.revealed = rightContext.state.revealed → + LazyRevealProbe.ValuesLE leftContext.state rightContext.state → + PublishedValues leftContext.state → + rightContext = directDeferredContext rightContext.state → + RelTriple + (runDirectResolvedDetailedFromTable leftContext leftFuel table + (left.run leftCache)) + (runDirectResolvedDetailedFromTable rightContext rightFuel table + (right.run rightCache)) + (DirectDetailedOrdinaryStableRunEq table) + +theorem OrdinaryMaterializedStableCouples.toBetween + {table : OtsSecretIndex → HashOutput} + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + (hcomputation : OrdinaryMaterializedStableCouples table computation) : + OrdinaryMaterializedStableCouplesBetween table computation computation := + hcomputation + +theorem ordinaryMaterializedStableCouplesBetween_pure + (table : OtsSecretIndex → HashOutput) (leftValue rightValue : α) + (hvalue : leftValue = rightValue) : + OrdinaryMaterializedStableCouplesBetween table + (pure leftValue) (pure rightValue) := by + subst rightValue + exact (ordinaryMaterializedStableCouples_pure table leftValue).toBetween + +theorem OrdinaryMaterializedStableCouplesBetween.bind + {table : OtsSecretIndex → HashOutput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {leftNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + {rightNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hfirst : OrdinaryMaterializedStableCouplesBetween table left right) + (hnext : ∀ value, + OrdinaryMaterializedStableCouplesBetween table + (leftNext value) (rightNext value)) : + OrdinaryMaterializedStableCouplesBetween table + (left >>= leftNext) (right >>= rightNext) := by + intro leftContext rightContext leftFuel rightFuel leftCache rightCache hcontext hfuel hcache + hrevealed hvalues hpublished hrightMaterialized + rw [StateT.run_bind, StateT.run_bind] + apply relTriple_runDirectResolvedDetailed_bind_stable table + (left.run leftCache) (right.run rightCache) + (fun value cache => (leftNext value).run cache) + (fun value cache => (rightNext value).run cache) + leftContext rightContext leftFuel rightFuel + · exact hfirst leftContext rightContext leftFuel rightFuel leftCache rightCache hcontext hfuel + hcache hrevealed hvalues hpublished hrightMaterialized + · intro leftResult rightResult hrelation + have hvalue : leftResult.value.1 = rightResult.value.1 := hrelation.value_eq + rw [← hvalue] + rw [hrelation.left_table, hrelation.right_table] + exact hnext leftResult.value.1 + leftResult.context rightResult.context leftResult.remaining rightResult.remaining + leftResult.value.2 rightResult.value.2 hrelation.context_le hrelation.remaining_le + hrelation.cache_eq hrelation.revealed_eq hrelation.values_le hrelation.left_published + hrelation.right_materialized + +def OrdinaryMaterializedStableCouplesBetweenPositive + (table : OtsSecretIndex → HashOutput) + (left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftContext rightContext leftFuel rightFuel leftCache rightCache, + 0 < leftFuel → + FinalizationContextLE table leftContext rightContext → + leftFuel ≤ rightFuel → + ordinaryQueryCache leftCache = ordinaryQueryCache rightCache → + leftContext.state.revealed = rightContext.state.revealed → + LazyRevealProbe.ValuesLE leftContext.state rightContext.state → + PublishedValues leftContext.state → + rightContext = directDeferredContext rightContext.state → + RelTriple + (runDirectResolvedDetailedFromTable leftContext leftFuel table + (left.run leftCache)) + (runDirectResolvedDetailedFromTable rightContext rightFuel table + (right.run rightCache)) + (DirectDetailedOrdinaryStableRunEq table) + +theorem OrdinaryMaterializedStableCouplesBetweenPositive.bind + {table : OtsSecretIndex → HashOutput} + {left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {leftNext rightNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hfirst : OrdinaryMaterializedStableCouplesBetweenPositive table left right) + (hnext : ∀ value, OrdinaryMaterializedStableCouplesBetween table + (leftNext value) (rightNext value)) : + OrdinaryMaterializedStableCouplesBetweenPositive table + (left >>= leftNext) (right >>= rightNext) := by + intro leftContext rightContext leftFuel rightFuel leftCache rightCache hpositive hcontext hfuel + hcache hrevealed hvalues hpublished hrightMaterialized + rw [StateT.run_bind, StateT.run_bind] + apply relTriple_runDirectResolvedDetailed_bind_stable table + (left.run leftCache) (right.run rightCache) + (fun value cache => (leftNext value).run cache) + (fun value cache => (rightNext value).run cache) + leftContext rightContext leftFuel rightFuel + · exact hfirst leftContext rightContext leftFuel rightFuel leftCache rightCache hpositive + hcontext hfuel hcache hrevealed hvalues hpublished hrightMaterialized + · intro leftResult rightResult hrelation + have hvalue : leftResult.value.1 = rightResult.value.1 := hrelation.value_eq + rw [← hvalue, hrelation.left_table, hrelation.right_table] + exact hnext leftResult.value.1 + leftResult.context rightResult.context leftResult.remaining rightResult.remaining + leftResult.value.2 rightResult.value.2 hrelation.context_le hrelation.remaining_le + hrelation.cache_eq hrelation.revealed_eq hrelation.values_le hrelation.left_published + hrelation.right_materialized + +set_option maxRecDepth 100000 in +theorem ordinaryMaterializedStableCouplesBetween_probe + (table : OtsSecretIndex → HashOutput) (candidate : Probe) : + OrdinaryMaterializedStableCouplesBetweenPositive table + (probe candidate) (probe candidate) := by + intro left right leftFuel rightFuel leftCache rightCache hpositive hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + cases leftFuel with + | zero => omega + | succ leftRemaining => + obtain ⟨rightRemaining, hrightFuel⟩ : ∃ rightRemaining, + rightFuel = rightRemaining + 1 := by + refine ⟨rightFuel - 1, ?_⟩ + omega + subst rightFuel + unfold probe + simp only [StateT.run_liftM] + unfold LazyRevealProbe.probeQuery + rw [runDirectResolvedDetailedFromTable_probe_query_bind, + runDirectResolvedDetailedFromTable_probe_query_bind] + by_cases hleftRevealed : candidate.coordinate ∈ left.state.revealed + · have hrightRevealed : candidate.coordinate ∈ right.state.revealed := by + rw [← hrevealed] + exact hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + exact (ordinaryMaterializedStableCouples_pure table ()).toBetween + left right leftRemaining rightRemaining leftCache rightCache hcontext (by omega) + hcache hrevealed hvalues hpublished hrightMaterialized + · have hrightRevealed : candidate.coordinate ∉ right.state.revealed := by + rwa [← hrevealed] + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + let nextLeft : DeferredContext := + { left with state := left.state.addPending candidate.coordinate candidate.candidate } + let nextRight : DeferredContext := + { right with state := right.state.addPending candidate.coordinate candidate.candidate } + by_cases hcompletable : DeferredCompletable table nextRight + · have hnext := hcontext.addPending_both_of_right_completable + candidate.coordinate candidate.candidate hcompletable + have hnextPublished : PublishedValues nextLeft.state := by + simpa [nextLeft, PublishedValues, LazyRevealProbe.State.addPending] using hpublished + exact (ordinaryMaterializedStableCouples_pure table ()).toBetween + nextLeft nextRight leftRemaining rightRemaining leftCache rightCache hnext (by omega) + hcache hrevealed hvalues hnextPublished (by + show nextRight = directDeferredContext nextRight.state + dsimp [nextRight] + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_addPending]) + · rw [runDirectResolvedDetailedFromTable_pure, + runDirectResolvedDetailedFromTable_pure] + apply relTriple_pure_pure + right + exact ⟨⟨rfl, hcontext.view.rightConsistent.addPending + candidate.coordinate candidate.candidate, + hcontext.view.rightStarts.addPending + candidate.coordinate candidate.candidate, hcompletable⟩, by + show nextRight = directDeferredContext nextRight.state + dsimp [nextRight] + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_addPending]⟩ + +theorem ordinaryMaterializedStableCouplesBetween_executeCandidate + (table : OtsSecretIndex → HashOutput) (candidate? : Option Probe) : + OrdinaryMaterializedStableCouplesBetweenPositive table + (executeCandidate? candidate?) (executeCandidate? candidate?) := by + cases candidate? with + | none => + intro left right leftFuel rightFuel leftCache rightCache _hpositive + exact ordinaryMaterializedStableCouplesBetween_pure table () () rfl + left right leftFuel rightFuel leftCache rightCache + | some candidate => exact ordinaryMaterializedStableCouplesBetween_probe table candidate + +theorem relTriple_runDirectResolvedDetailed_publishOrdinaryInput_stable + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (input : HashInput) (output : HashOutput) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hleftValue : left.state.values coordinate = some output) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((publishOrdinaryInput coordinate input output).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((publishOrdinaryInput coordinate input output).run rightCache)) + (DirectDetailedOrdinaryStableRunEq table) := by + have hrightValue : right.state.values coordinate = some output := + hvalues coordinate output hleftValue + rw [runDirectResolvedDetailedFromTable_publishOrdinaryInput, + runDirectResolvedDetailedFromTable_publishOrdinaryInput] + apply relTriple_pure_pure + left + exact + { value_eq := rfl + context_le := hcontext.publish coordinate + remaining_le := hfuel + left_table := rfl + right_table := rfl + cache_eq := by + rw [ordinaryQueryCache_update, ordinaryQueryCache_update, hcache] + revealed_eq := by + simpa [LazyRevealProbe.State.publish] using congrArg (insert coordinate) hrevealed + values_le := hvalues + left_published := hpublished.publish_of_value coordinate output hleftValue + right_materialized := by + rw [hrightMaterialized] + simp [directDeferredContext, directDeferredValues_publish] } + +set_option maxRecDepth 100000 in +theorem ordinaryMaterializedStableCouplesBetween_revealPublishOrdinaryInput + (table : OtsSecretIndex → HashOutput) + (coordinate : Coordinate) (input : HashInput) : + OrdinaryMaterializedStableCouplesBetween table + (revealPublishOrdinaryInput coordinate input) + (revealPublishOrdinaryInput coordinate input) := by + intro left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed + hvalues hpublished hrightMaterialized + unfold revealPublishOrdinaryInput + rw [StateT.run_bind, StateT.run_bind] + apply relTriple_runDirectResolvedDetailed_bind_with_support_stable table + ((revealCoordinateOutput coordinate).run leftCache) + ((revealCoordinateOutput coordinate).run rightCache) + (fun output cache => (publishOrdinaryInput coordinate input output).run cache) + (fun output cache => (publishOrdinaryInput coordinate input output).run cache) + left right leftFuel rightFuel + · exact ordinaryMaterializedStableCouples_revealCoordinateOutput table coordinate + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed hvalues + hpublished hrightMaterialized + · intro leftResult rightResult hleftSupport _hrightSupport hrelation + have hleftValue := + value_of_done_runDirectResolvedDetailedFromTable_revealCoordinateOutput table coordinate + left leftFuel leftCache leftResult hleftSupport + rw [hrelation.left_table, hrelation.right_table, ← hrelation.value_eq] + exact relTriple_runDirectResolvedDetailed_publishOrdinaryInput_stable table coordinate input + leftResult.value.1 leftResult.context rightResult.context leftResult.remaining + rightResult.remaining leftResult.value.2 rightResult.value.2 hrelation.context_le + hrelation.remaining_le hrelation.cache_eq hrelation.revealed_eq hrelation.values_le + hrelation.left_published hleftValue hrelation.right_materialized + +theorem ordinaryMaterializedStableCouplesBetween_resolvePublicKnownInput + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (publicState : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) (input : HashInput) : + OrdinaryMaterializedStableCouplesBetween table + (resolvePublicKnownInput parameter publicState coordinate input) + (resolvePublicKnownInput parameter publicState coordinate input) := by + unfold resolvePublicKnownInput + cases hknown : purePeekTableInput parameter publicState coordinate with + | none => + exact (ordinaryMaterializedStableCouples_splitHashQuery_ordinary table input).toBetween + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + simpa [revealPublishOrdinaryInput, publishOrdinaryInput] using + ordinaryMaterializedStableCouplesBetween_revealPublishOrdinaryInput table coordinate + input + · simp only [heq, ↓reduceIte] + exact (ordinaryMaterializedStableCouples_splitHashQuery_ordinary table input).toBetween + +theorem ordinaryMaterializedStableCouplesBetweenPositive_publicPlan + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) : + OrdinaryMaterializedStableCouplesBetweenPositive table + (probingHashQueryAfterPublicPlan parameter input publicState plan) + (probingHashQueryAfterPublicPlan parameter input publicState plan) := by + unfold probingHashQueryAfterPublicPlan + apply (ordinaryMaterializedStableCouplesBetween_executeCandidate table plan.candidate?).bind + intro _ + cases plan.action with + | ordinary => + exact (ordinaryMaterializedStableCouples_splitHashQuery_ordinary table input).toBetween + | resolve coordinate => + exact ordinaryMaterializedStableCouplesBetween_resolvePublicKnownInput table parameter + publicState coordinate input + +theorem ordinaryMaterializedStableCouplesBetween_publicPlan_of_none + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (hcandidate : plan.candidate? = none) : + OrdinaryMaterializedStableCouplesBetween table + (probingHashQueryAfterPublicPlan parameter input publicState plan) + (probingHashQueryAfterPublicPlan parameter input publicState plan) := by + unfold probingHashQueryAfterPublicPlan + rw [show executeCandidate? plan.candidate? = pure () by simp [hcandidate]] + simp only [pure_bind] + cases plan.action with + | ordinary => + exact (ordinaryMaterializedStableCouples_splitHashQuery_ordinary table input).toBetween + | resolve coordinate => + exact ordinaryMaterializedStableCouplesBetween_resolvePublicKnownInput table parameter + publicState coordinate input + +theorem runDirectResolvedDetailedFromTable_peekPositionValues_eq_pure + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ∀ positions, + runDirectResolvedDetailedFromTable context fuel table + ((peekPositionValues positions).run cache) = + pure (.done ⟨context, fuel, + (purePeekPositionValues context.state positions, cache), table⟩) + | [] => by + simp [peekPositionValues, purePeekPositionValues, + runDirectResolvedDetailedFromTable] + | position :: remaining => by + rw [peekPositionValues, StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekCoordinate] + cases hvalue : truncateHash <$> context.state.values (.position position) with + | none => + simp [purePeekPositionValues, hvalue, runDirectResolvedDetailedFromTable] + | some value => + simp only [pure_bind] + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekPositionValues_eq_pure context fuel table cache + remaining] + cases htail : purePeekPositionValues context.state remaining <;> + simp [purePeekPositionValues, hvalue, htail, runDirectResolvedDetailedFromTable] + +set_option maxRecDepth 100000 in +theorem runDirectResolvedDetailedFromTable_peekTableInput_eq_pure + (parameter : PublicParameter) (coordinate : Coordinate) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runDirectResolvedDetailedFromTable context fuel table + ((peekTableInput parameter coordinate).run cache) = + pure (.done ⟨context, fuel, + (purePeekTableInput parameter context.state coordinate, cache), table⟩) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [peekTableInput, purePeekTableInput, runDirectResolvedDetailedFromTable] + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput.eq_2] + by_cases hzero : step.val = 0 + · rw [if_pos hzero] + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekCoordinate] + cases hvalue : truncateHash <$> + context.state.values (.chainStart lay tree leafIdx chainIdx) <;> + simp [purePeekTableInput, hzero, hvalue, + runDirectResolvedDetailedFromTable] + · rw [if_neg hzero] + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekPositionValues_eq_pure] + cases hvalues : purePeekPositionValues context.state + (Position.chain lay tree leafIdx chainIdx step).children <;> + simp [purePeekTableInput, hzero, hvalues, + runDirectResolvedDetailedFromTable] + | leaf lay tree leafIdx => + simp only [peekTableInput] + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekPositionValues_eq_pure] + cases hvalues : purePeekPositionValues context.state _ <;> + simp [purePeekTableInput, hvalues, runDirectResolvedDetailedFromTable] + | node lay tree level nodeIdx => + simp only [peekTableInput] + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekPositionValues_eq_pure] + cases hvalues : purePeekPositionValues context.state _ <;> + simp [purePeekTableInput, hvalues, runDirectResolvedDetailedFromTable] + | ftsLeaf index tree leafIdx => + simp only [peekTableInput] + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekPositionValues_eq_pure] + cases hvalues : purePeekPositionValues context.state _ <;> + simp [purePeekTableInput, hvalues, runDirectResolvedDetailedFromTable] + | ftsNode index tree level nodeIdx => + simp only [peekTableInput] + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekPositionValues_eq_pure] + cases hvalues : purePeekPositionValues context.state _ <;> + simp [purePeekTableInput, hvalues, runDirectResolvedDetailedFromTable] + | ftsRoots index => + simp only [peekTableInput] + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekPositionValues_eq_pure] + cases hvalues : purePeekPositionValues context.state _ <;> + simp [purePeekTableInput, hvalues, runDirectResolvedDetailedFromTable] + +set_option maxRecDepth 100000 in +theorem runDirectResolvedDetailedFromTable_resolveKnownInput_eq_public + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runDirectResolvedDetailedFromTable context fuel table + ((resolveKnownInput parameter coordinate input).run cache) = + runDirectResolvedDetailedFromTable context fuel table + ((resolvePublicKnownInput parameter context.state coordinate input).run cache) := by + unfold resolveKnownInput resolvePublicKnownInput + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_peekTableInput_eq_pure] + simp only [pure_bind] + cases hknown : purePeekTableInput parameter context.state coordinate with + | none => rfl + | some knownInput => + by_cases heq : knownInput = input <;> simp [heq] + +theorem purePeekPositionValues_eq_of_values_eq + {left right : LazyRevealProbe.State Coordinate} + (hvalues : left.values = right.values) : ∀ positions, + purePeekPositionValues left positions = purePeekPositionValues right positions + | [] => rfl + | position :: remaining => by + simp only [purePeekPositionValues] + rw [hvalues] + cases truncateHash <$> right.values (.position position) with + | none => rfl + | some value => rw [purePeekPositionValues_eq_of_values_eq hvalues remaining] + +theorem purePeekTableInput_eq_of_values_eq + (parameter : PublicParameter) + {left right : LazyRevealProbe.State Coordinate} + (hvalues : left.values = right.values) (coordinate : Coordinate) : + purePeekTableInput parameter left coordinate = + purePeekTableInput parameter right coordinate := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => rfl + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + simp only [purePeekTableInput] + by_cases hzero : step.val = 0 + · simp only [hzero, ↓reduceIte] + rw [hvalues] + · simp only [hzero, ↓reduceIte] + rw [purePeekPositionValues_eq_of_values_eq hvalues] + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp only [purePeekTableInput] + rw [purePeekPositionValues_eq_of_values_eq hvalues] + +theorem resolvePublicKnownInput_eq_of_values_eq + (parameter : PublicParameter) + {left right : LazyRevealProbe.State Coordinate} + (hvalues : left.values = right.values) + (coordinate : Coordinate) (input : HashInput) : + resolvePublicKnownInput parameter left coordinate input = + resolvePublicKnownInput parameter right coordinate input := by + unfold resolvePublicKnownInput + rw [purePeekTableInput_eq_of_values_eq parameter hvalues coordinate] + +theorem probingHashQueryAfterPublicPlan_eq_of_values_eq + (parameter : PublicParameter) (input : HashInput) + {left right : LazyRevealProbe.State Coordinate} + (hvalues : left.values = right.values) (plan : PlannedHashQuery) : + probingHashQueryAfterPublicPlan parameter input left plan = + probingHashQueryAfterPublicPlan parameter input right plan := by + unfold probingHashQueryAfterPublicPlan + apply bind_congr + intro _ + cases plan.action with + | ordinary => rfl + | resolve coordinate => + exact resolvePublicKnownInput_eq_of_values_eq parameter hvalues coordinate input + +set_option maxRecDepth 100000 in +theorem runDirectResolvedDetailedFromTable_afterPlan_eq_publicPlan + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runDirectResolvedDetailedFromTable context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) = + runDirectResolvedDetailedFromTable context fuel table + ((probingHashQueryAfterPublicPlan parameter input context.state plan).run cache) := by + unfold probingHashQueryAfterPlan probingHashQueryAfterPublicPlan executePlannedHashQuery + cases hcandidate : plan.candidate? with + | none => + simp only [executeCandidate?, pure_bind] + cases haction : plan.action with + | ordinary => rfl + | resolve coordinate => + exact runDirectResolvedDetailedFromTable_resolveKnownInput_eq_public parameter + coordinate input context fuel table cache + | some candidate => + simp only [executeCandidate?] + rw [StateT.run_bind, StateT.run_bind, runDirectResolvedDetailedFromTable_bind, + runDirectResolvedDetailedFromTable_bind] + simp only [probe, StateT.run_liftM, LazyRevealProbe.probeQuery, + runDirectResolvedDetailedFromTable_probe_query_bind] + cases fuel with + | zero => rfl + | succ remaining => + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + rw [runDirectResolvedDetailedFromTable_pure, pure_bind] + cases haction : plan.action with + | ordinary => rfl + | resolve coordinate => + exact runDirectResolvedDetailedFromTable_resolveKnownInput_eq_public parameter + coordinate input context remaining table cache + · simp only [hrevealed, ↓reduceIte] + let nextContext : DeferredContext := + { context with state := + context.state.addPending candidate.coordinate candidate.candidate } + rw [show + runDirectResolvedDetailedFromTable nextContext remaining table (pure ((), cache)) = + pure (.done ⟨nextContext, remaining, ((), cache), table⟩) by + exact runDirectResolvedDetailedFromTable_pure _ _ _ _] + simp only [pure_bind] + cases haction : plan.action with + | ordinary => rfl + | resolve coordinate => + have hbase := runDirectResolvedDetailedFromTable_resolveKnownInput_eq_public + parameter coordinate input nextContext remaining table cache + have hpublic := resolvePublicKnownInput_eq_of_values_eq parameter + (left := nextContext.state) (right := context.state) (by + rfl) coordinate input + rw [hpublic] at hbase + exact hbase + +theorem relTriple_runDirectResolvedDetailed_afterPlan_publicPlan + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hpositive : 0 < leftFuel) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQueryAfterPublicPlan parameter input left.state plan).run rightCache)) + (DirectDetailedOrdinaryStableRunEq table) := by + rw [runDirectResolvedDetailedFromTable_afterPlan_eq_publicPlan parameter input plan left + leftFuel table leftCache] + exact ordinaryMaterializedStableCouplesBetweenPositive_publicPlan table parameter input + left.state plan left right leftFuel rightFuel leftCache rightCache hpositive hcontext hfuel + hcache hrevealed hvalues hpublished hrightMaterialized + +theorem relTriple_runDirectResolvedDetailed_afterPlan_publicPlan_of_none + (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcandidate : plan.candidate? = none) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) : + RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQueryAfterPublicPlan parameter input left.state plan).run rightCache)) + (DirectDetailedOrdinaryStableRunEq table) := by + rw [runDirectResolvedDetailedFromTable_afterPlan_eq_publicPlan parameter input plan left + leftFuel table leftCache] + exact ordinaryMaterializedStableCouplesBetween_publicPlan_of_none table parameter input + left.state plan hcandidate left right leftFuel rightFuel leftCache rightCache hcontext hfuel + hcache hrevealed hvalues hpublished hrightMaterialized + +noncomputable def finishDirectDetailedPrivateOrdinalSelection + (observe : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (candidates : List Probe) : DirectDetailedResult α → + ProbComp (Option PrivateOrdinalSelection) + | .stopped _ => pure none + | .done result => observe result.context result.remaining result.value candidates + +theorem finishDirectPrivateOrdinalSelection_eq_detailed + (observe : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (candidates : List Probe) (result : DirectWitnessResult α) : + finishDirectPrivateOrdinalSelection observe candidates result = + finishDirectDetailedPrivateOrdinalSelection observe candidates result.erase := by + cases result <;> rfl + +theorem evalDist_runWitnessSelection_eq_detailed + (observe : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + evalDist + (runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectPrivateOrdinalSelection observe candidates) = + evalDist + (runDirectResolvedDetailedFromTable context fuel table computation >>= + finishDirectDetailedPrivateOrdinalSelection observe candidates) := by + have herase := map_erase_runDirectResolvedWitnessFromTable computation context fuel table + calc + _ = evalDist + ((DirectWitnessResult.erase <$> + runDirectResolvedWitnessFromTable context fuel table computation) >>= + finishDirectDetailedPrivateOrdinalSelection observe candidates) := by + rw [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro result _hresult + simp only [Function.comp_apply, pure_bind] + exact congrArg evalDist + (finishDirectPrivateOrdinalSelection_eq_detailed observe candidates result) + _ = _ := by rw [herase] + +def projectDirectDetailedClean + (result : DirectDetailedResult α) : Option (CleanRunResult α) := + projectResolvedRunResult result.toOption + +theorem map_projectDirectDetailedClean_run_eq_clean + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + projectDirectDetailedClean <$> + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table computation = + runCleanFromTable state fuel table computation := by + unfold projectDirectDetailedClean + rw [← Functor.map_map, map_toOption_runDirectResolvedDetailedFromTable, + map_projectResolvedRunResult_runDirect_eq_runClean] + +noncomputable def finishDirectDetailedMaterializedSelection + (target : Position) + (observe : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp (Option Probe)) + (candidates : List Probe) : + DirectDetailedResult (α × SplitHashCache) → ProbComp (Option Probe) + | .stopped _ => pure none + | .done result => + continueMaterializedPrivateOrdinalSelection target observe result.context.state result.remaining + result.value.1 result.value.2 candidates + +theorem finishDirectDetailedMaterializedSelection_eq_clean + (target : Position) + (observe : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp (Option Probe)) + (candidates : List Probe) + (result : DirectDetailedResult (α × SplitHashCache)) : + finishDirectDetailedMaterializedSelection target observe candidates result = + finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target observe) candidates + (projectDirectDetailedClean result) := by + cases result with + | stopped reason => rfl + | done result => + simp [finishDirectDetailedMaterializedSelection, + finishMaterializedPrivateOrdinalSelection, projectDirectDetailedClean, + DirectDetailedResult.toOption, projectResolvedRunResult] + +theorem evalDist_runDetailedMaterializedSelection_eq_clean + (target : Position) + (observe : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp (Option Probe)) + (candidates : List Probe) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) + (α × SplitHashCache)) : + evalDist + (runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table computation >>= + finishDirectDetailedMaterializedSelection target observe candidates) = + evalDist + (runCleanFromTable state fuel table computation >>= + finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target observe) candidates) := by + have hproject := map_projectDirectDetailedClean_run_eq_clean computation state fuel table + calc + _ = evalDist + ((projectDirectDetailedClean <$> + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + computation) >>= + finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target observe) candidates) := by + rw [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro result _hresult + simp only [Function.comp_apply, pure_bind] + exact congrArg evalDist + (finishDirectDetailedMaterializedSelection_eq_clean target observe candidates result) + _ = _ := by rw [hproject] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionEncoding.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionEncoding.lean new file mode 100644 index 00000000..4cf50f5c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionEncoding.lean @@ -0,0 +1,232 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionMaterialized + +/-! +# Encoding-side materialized selection coupling + +On a prefix whose earlier candidates guess neither distinguished root, the actual signer and the +target-aware comparison signer preserve the encoding cache quotient. The selected candidate has +the same distribution in both runs. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +theorem rootEncodingCacheCouples_splitHashQuery_avoids + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) + (havoid : RootInputAvoids parameter target leftRoot rightRoot input) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (splitHashQuery (.ordinary input)) := by + intro leftCache rightCache hcache state fuel table + exact relTriple_splitHashQuery_same_avoids parameter target leftRoot rightRoot input havoid + leftCache rightCache hcache state fuel table + +theorem rootEncodingCacheCouples_resolvePublicKnownInput_avoids + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (publicState : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) (input : HashInput) + (havoid : RootInputAvoids parameter target leftRoot rightRoot input) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (resolvePublicKnownInput parameter publicState coordinate input) := by + unfold resolvePublicKnownInput + cases hknown : purePeekTableInput parameter publicState coordinate with + | none => + exact rootEncodingCacheCouples_splitHashQuery_avoids parameter target leftRoot + rightRoot input havoid + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + apply (rootEncodingCacheCouples_revealCoordinateOutput parameter target leftRoot + rightRoot coordinate).bind + intro output + apply (rootEncodingCacheCouples_publishCoordinate parameter target leftRoot rightRoot + coordinate).bind + intro _ + apply (rootEncodingCacheCouples_modifyOrdinary_avoids parameter target leftRoot rightRoot + input havoid output).bind + intro _ + exact rootEncodingCacheCouples_pure parameter target leftRoot rightRoot output + · simp only [heq, ↓reduceIte] + exact rootEncodingCacheCouples_splitHashQuery_avoids parameter target leftRoot + rightRoot input havoid + +theorem rootEncodingCacheCouples_probingHashQueryAfterPublicPlan_avoids + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (havoid : RootInputAvoids parameter target leftRoot rightRoot input) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (probingHashQueryAfterPublicPlan parameter input publicState plan) := by + unfold probingHashQueryAfterPublicPlan + apply (rootEncodingCacheCouples_executeCandidate parameter target leftRoot rightRoot + plan.candidate?).bind + intro _ + cases plan.action with + | ordinary => + exact rootEncodingCacheCouples_splitHashQuery_avoids parameter target leftRoot + rightRoot input havoid + | resolve coordinate => + exact rootEncodingCacheCouples_resolvePublicKnownInput_avoids parameter target leftRoot + rightRoot publicState coordinate input havoid + +theorem evalDist_finishMaterializedSelection_eq_of_rootEncoding + (observeLeft observeRight : LazyRevealProbe.State Coordinate → Nat → α → + SplitHashCache → List Probe → ProbComp (Option Probe)) + (candidates : List Probe) + (left right : Option (CleanRunResult (α × SplitHashCache))) + (hrel : RootEncodingStoredCleanSameRel parameter target leftRoot rightRoot left right) + (hnext : ∀ leftResult rightResult, + RootEncodingStoredCleanSameRel parameter target leftRoot rightRoot + (some leftResult) (some rightResult) → + evalDist (observeLeft leftResult.state leftResult.remaining leftResult.value.1 + leftResult.value.2 candidates) = + evalDist (observeRight rightResult.state rightResult.remaining rightResult.value.1 + rightResult.value.2 candidates)) : + evalDist (finishMaterializedPrivateOrdinalSelection observeLeft candidates left) = + evalDist (finishMaterializedPrivateOrdinalSelection observeRight candidates right) := by + cases left with + | none => + cases right with + | none => rfl + | some rightResult => simp [RootEncodingStoredCleanSameRel] at hrel + | some leftResult => + cases right with + | none => simp [RootEncodingStoredCleanSameRel] at hrel + | some rightResult => exact hnext leftResult rightResult hrel + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem evalDist_materializedRootAvoidingOrdinalSelection_encoding + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target (truncateHash leftOutput) + (truncateHash rightOutput) leftCache rightCache) + (hstored : StoredLayerRoot state target (truncateHash leftOutput)) : + evalDist + (materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot target + (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret computation candidates + state fuel table leftCache) = + evalDist + (materializedComparisonRootAvoidingOrdinalSelection ordinal parameter publicRoot target + leftOutput rightOutput ftsSecret computation candidates state fuel table rightCache) := by + induction computation using OracleComp.inductionOn generalizing + candidates state fuel leftCache rightCache with + | pure value => + simp [materializedActualRootAvoidingOrdinalSelection, + materializedComparisonRootAvoidingOrdinalSelection, + materializedRootAvoidingOrdinalSelection] + | query_bind query next ih => + unfold materializedActualRootAvoidingOrdinalSelection + materializedComparisonRootAvoidingOrdinalSelection + rw [materializedRootAvoidingOrdinalSelection, OracleComp.construct_query_bind, + materializedRootAvoidingOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp [hselected] + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (((rootEncodingCacheCouples_splitUniformImpl parameter target + (truncateHash leftOutput) (truncateHash rightOutput) n).relates.toStored) + leftCache rightCache hcache state fuel table hstored) + intro leftResult rightResult hresult + apply evalDist_finishMaterializedSelection_eq_of_rootEncoding _ _ candidates _ _ + hresult + intro nextLeft nextRight hnextRel + rcases hnextRel with ⟨hclean, hnextStored⟩ + rcases hclean with ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + rw [← hstate, ← hremaining, ← hvalue] + unfold continueMaterializedPrivateOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ nextLeft.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact ih nextLeft.value.1 candidates nextLeft.state nextLeft.remaining + nextLeft.value.2 nextRight.value.2 hnextCache hnextStored + | inr input => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp [hactual] + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + by_cases hsafe : RootAwareCandidateAvoidsRoots target + (truncateHash leftOutput) (truncateHash rightOutput) candidate? + · have hsafeActual : RootAwareCandidateAvoidsRoots target + (truncateHash leftOutput) (truncateHash rightOutput) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + have hinput : RootInputAvoids parameter target + (truncateHash leftOutput) (truncateHash rightOutput) input := by + apply rootInputAvoids_of_rootAwareCandidateAvoidsRoots + simpa [rootAwareCandidateForPlan?_purePlan] using hsafeActual + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (((rootEncodingCacheCouples_probingHashQueryAfterPublicPlan_avoids parameter + target (truncateHash leftOutput) (truncateHash rightOutput) input + (materializedCanonicalContext table state).state plan hinput).relates.toStored) + leftCache rightCache hcache state fuel table hstored) + intro leftResult rightResult hresult + apply evalDist_finishMaterializedSelection_eq_of_rootEncoding _ _ + nextCandidates _ _ hresult + intro nextLeft nextRight hnextRel + rcases hnextRel with ⟨hclean, hnextStored⟩ + rcases hclean with ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + rw [← hstate, ← hremaining, ← hvalue] + unfold continueMaterializedPrivateOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ nextLeft.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact ih nextLeft.value.1 nextCandidates nextLeft.state nextLeft.remaining + nextLeft.value.2 nextRight.value.2 hnextCache hnextStored + · have hsafeActual : ¬RootAwareCandidateAvoidsRoots target + (truncateHash leftOutput) (truncateHash rightOutput) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp [hsafeActual] + | inr message => + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (rootEncodingCacheRelatesStored_maskedSign_targetComparison parameter publicRoot + target hroot (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret message + leftCache rightCache hcache state fuel table hstored) + intro leftResult rightResult hresult + apply evalDist_finishMaterializedSelection_eq_of_rootEncoding _ _ candidates _ _ + hresult + intro nextLeft nextRight hnextRel + rcases hnextRel with ⟨hclean, hnextStored⟩ + rcases hclean with ⟨hstate, hremaining, htable, hvalue, hnextCache⟩ + rw [← hstate, ← hremaining, ← hvalue] + unfold continueMaterializedPrivateOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ nextLeft.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact ih nextLeft.value.1 candidates nextLeft.state nextLeft.remaining + nextLeft.value.2 nextRight.value.2 hnextCache hnextStored + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionFamily.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionFamily.lean new file mode 100644 index 00000000..4532eafd --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionFamily.lean @@ -0,0 +1,279 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionWeaken + +/-! +# Root-indexed materialized selection family + +A family of deferred contexts and split caches that is covariant under the complete root swap +instantiates the generic two-root one-guess theorem. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +noncomputable def rootInstalledCache + (target : Position) (output : Digest → HashOutput) + (base : SplitHashCache) (root : Digest) : SplitHashCache := + replaceHiddenRootCache target (output root) base + +theorem rootInstalledCache_target + (target : Position) (output : Digest → HashOutput) + (base : SplitHashCache) (root : Digest) : + rootInstalledCache target output base root (.hidden (.position target)) = + some (output root) := by + simp [rootInstalledCache, replaceHiddenRootCache] + +theorem fullSwapRootCache_rootInstalledCache + (parameter : PublicParameter) (target : Position) + (output : Digest → HashOutput) (base : SplitHashCache) + (leftRoot rightRoot : Digest) + (hbase : swapCanonicalRootEncodingCache parameter target leftRoot rightRoot base = base) : + fullSwapRootCache parameter target leftRoot rightRoot (output rightRoot) + (rootInstalledCache target output base leftRoot) = + rootInstalledCache target output base rightRoot := by + funext key + cases key with + | ordinary input => + have hordinary := congrFun hbase (.ordinary input) + simpa [fullSwapRootCache, rootInstalledCache, replaceHiddenRootCache, + swapCanonicalRootEncodingCache] using hordinary + | hidden coordinate => + by_cases heq : coordinate = .position target + · subst coordinate + simp [fullSwapRootCache, rootInstalledCache, replaceHiddenRootCache] + · simp [fullSwapRootCache, rootInstalledCache, replaceHiddenRootCache, + swapCanonicalRootEncodingCache, heq] + +theorem swapCanonicalRootEncodingCache_eq_of_no_guesses + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (cache : SplitHashCache) + (hleft : NoEncodingRootGuessCached parameter target leftRoot cache) + (hright : NoEncodingRootGuessCached parameter target rightRoot cache) : + swapCanonicalRootEncodingCache parameter target leftRoot rightRoot cache = cache := by + funext key + cases key with + | hidden coordinate => rfl + | ordinary input => + change cache (.ordinary + (swapCanonicalRootEncodingInput parameter target leftRoot rightRoot input)) = + cache (.ordinary input) + cases hleftAddress : rootRetryAddress? parameter target leftRoot input with + | some address => + have hinput := rootRetryAddress?_eq_some_spec hleftAddress + have hleftGuess : EncodingInputGuessesRoot parameter target leftRoot input := by + rw [← hinput] + exact decodeEncodingLayerRootCandidate?_encodingRetryInput address.names leftRoot + address.counter.val + have hrightGuess : EncodingInputGuessesRoot parameter target rightRoot + (address.input parameter rightRoot) := + decodeEncodingLayerRootCandidate?_encodingRetryInput address.names rightRoot + address.counter.val + rw [show swapCanonicalRootEncodingInput parameter target leftRoot rightRoot input = + address.input parameter rightRoot by + unfold swapCanonicalRootEncodingInput + rw [hleftAddress], + hright _ hrightGuess, hleft _ hleftGuess] + | none => + cases hrightAddress : rootRetryAddress? parameter target rightRoot input with + | some address => + have hinput := rootRetryAddress?_eq_some_spec hrightAddress + have hrightGuess : EncodingInputGuessesRoot parameter target rightRoot input := by + rw [← hinput] + exact decodeEncodingLayerRootCandidate?_encodingRetryInput address.names rightRoot + address.counter.val + have hleftGuess : EncodingInputGuessesRoot parameter target leftRoot + (address.input parameter leftRoot) := + decodeEncodingLayerRootCandidate?_encodingRetryInput address.names leftRoot + address.counter.val + rw [show swapCanonicalRootEncodingInput parameter target leftRoot rightRoot input = + address.input parameter leftRoot by + unfold swapCanonicalRootEncodingInput + rw [hleftAddress, hrightAddress], + hleft _ hleftGuess, hright _ hrightGuess] + | none => + unfold swapCanonicalRootEncodingInput + rw [hleftAddress, hrightAddress] + +set_option maxRecDepth 100000 in +theorem evalDist_materializedActualRootAvoidingOrdinalSelection_family_swap + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (output : Digest → HashOutput) + (htruncate : ∀ root, truncateHash (output root) = root) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) + (hhidden : context.state.values (.position target) = none) + (hprivate : Coordinate.position target ∉ context.state.revealed) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : Digest → SplitHashCache) + (htargetCache : ∀ root, + cache root (.hidden (.position target)) = some (output root)) + (hcacheSwap : ∀ leftRoot rightRoot, + fullSwapRootCache parameter target leftRoot rightRoot (output rightRoot) + (cache leftRoot) = cache rightRoot) + (leftRoot rightRoot : Digest) : + let rootContext := fun root => + { context with values := context.values.install target (output root) } + evalDist + (materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot target + leftRoot rightRoot ftsSecret computation candidates + (materializedDeferredState (rootContext leftRoot)) fuel table (cache leftRoot)) = + evalDist + (materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot target + rightRoot leftRoot ftsSecret computation candidates + (materializedDeferredState (rootContext rightRoot)) fuel table (cache rightRoot)) := by + dsimp only + have hswap := evalDist_materializedRootAvoidingOrdinalSelection_fullSwap ordinal parameter + publicRoot target hroot (output leftRoot) (output rightRoot) ftsSecret computation candidates + context hhidden hprivate fuel table (cache leftRoot) (htargetCache leftRoot) + rw [htruncate leftRoot, htruncate rightRoot] at hswap + simpa only [hcacheSwap leftRoot rightRoot] using hswap + +set_option maxRecDepth 100000 in +theorem probEvent_uniformActualRoot_materializedSelectionFamilyMatches_le + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (output : Digest → HashOutput) + (htruncate : ∀ root, truncateHash (output root) = root) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) + (hhidden : context.state.values (.position target) = none) + (hprivate : Coordinate.position target ∉ context.state.revealed) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : Digest → SplitHashCache) + (htargetCache : ∀ root, + cache root (.hidden (.position target)) = some (output root)) + (hcacheSwap : ∀ leftRoot rightRoot, + fullSwapRootCache parameter target leftRoot rightRoot (output rightRoot) + (cache leftRoot) = cache rightRoot) : + let rootContext := fun root => + { context with values := context.values.install target (output root) } + Pr[fun result : Digest × Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← materializedActualRootAvoidingOrdinalSelection ordinal parameter + publicRoot target leftRoot rightRoot ftsSecret computation candidates + (materializedDeferredState (rootContext leftRoot)) fuel table (cache leftRoot) + pure (leftRoot, rightRoot, selection)] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + dsimp only + apply probEvent_uniformActualRoot_materializedActualSelectionMatches_le ordinal parameter + publicRoot target ftsSecret computation candidates + (fun root => materializedDeferredState + { context with values := context.values.install target (output root) }) + fuel table cache + intro leftRoot rightRoot + exact evalDist_materializedActualRootAvoidingOrdinalSelection_family_swap ordinal parameter + publicRoot target hroot output htruncate ftsSecret computation candidates context hhidden + hprivate fuel table cache htargetCache hcacheSwap leftRoot rightRoot + +set_option maxRecDepth 100000 in +theorem probEvent_uniformActualRoot_materializedSelectionFamilyMatches_le_mul + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (output : Digest → HashOutput) + (htruncate : ∀ root, truncateHash (output root) = root) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) + (hhidden : context.state.values (.position target) = none) + (hprivate : Coordinate.position target ∉ context.state.revealed) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : Digest → SplitHashCache) + (htargetCache : ∀ root, + cache root (.hidden (.position target)) = some (output root)) + (hcacheSwap : ∀ leftRoot rightRoot, + fullSwapRootCache parameter target leftRoot rightRoot (output rightRoot) + (cache leftRoot) = cache rightRoot) : + let rootContext := fun root => + { context with values := context.values.install target (output root) } + Pr[fun result : Digest × Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← materializedActualRootAvoidingOrdinalSelection ordinal parameter + publicRoot target leftRoot rightRoot ftsSecret computation candidates + (materializedDeferredState (rootContext leftRoot)) fuel table (cache leftRoot) + pure (leftRoot, rightRoot, selection)] ≤ + Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionAt target result.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← materializedActualRootAvoidingOrdinalSelection ordinal parameter + publicRoot target leftRoot leftRoot ftsSecret computation candidates + (materializedDeferredState (rootContext leftRoot)) fuel table (cache leftRoot) + pure (leftRoot, selection)] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + dsimp only + let run : Digest → Digest → ProbComp (Option Probe) := + fun leftRoot rightRoot => + materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot target leftRoot + rightRoot ftsSecret computation candidates + (materializedDeferredState + { context with values := context.values.install target (output leftRoot) }) + fuel table (cache leftRoot) + let reference : Digest → ProbComp (Option Probe) := + fun leftRoot => + materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot target leftRoot + leftRoot ftsSecret computation candidates + (materializedDeferredState + { context with values := context.values.install target (output leftRoot) }) + fuel table (cache leftRoot) + apply probEvent_uniformActualRoot_match_le_of_swap_of_comparison_mul target run reference + · intro leftRoot rightRoot + exact evalDist_materializedActualRootAvoidingOrdinalSelection_family_swap ordinal parameter + publicRoot target hroot output htruncate ftsSecret computation candidates context hhidden + hprivate fuel table cache htargetCache hcacheSwap leftRoot rightRoot + · intro leftRoot + exact probEvent_sampledComparisonRoot_materializedSelectionMatches_le_mul ordinal parameter + target leftRoot (maskedSign parameter publicRoot ftsSecret) computation candidates + (materializedDeferredState + { context with values := context.values.install target (output leftRoot) }) + fuel table (cache leftRoot) + +set_option maxRecDepth 100000 in +theorem probEvent_uniformActualRoot_materializedRootInstalledMatches_le_mul + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (output : Digest → HashOutput) + (htruncate : ∀ root, truncateHash (output root) = root) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) + (hhidden : context.state.values (.position target) = none) + (hprivate : Coordinate.position target ∉ context.state.revealed) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (baseCache : SplitHashCache) + (hbase : ∀ leftRoot rightRoot, + swapCanonicalRootEncodingCache parameter target leftRoot rightRoot baseCache = baseCache) : + let rootContext := fun root => + { context with values := context.values.install target (output root) } + Pr[fun result : Digest × Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← materializedActualRootAvoidingOrdinalSelection ordinal parameter + publicRoot target leftRoot rightRoot ftsSecret computation candidates + (materializedDeferredState (rootContext leftRoot)) fuel table + (rootInstalledCache target output baseCache leftRoot) + pure (leftRoot, rightRoot, selection)] ≤ + Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionAt target result.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← materializedActualRootAvoidingOrdinalSelection ordinal parameter + publicRoot target leftRoot leftRoot ftsSecret computation candidates + (materializedDeferredState (rootContext leftRoot)) fuel table + (rootInstalledCache target output baseCache leftRoot) + pure (leftRoot, selection)] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_uniformActualRoot_materializedSelectionFamilyMatches_le_mul ordinal parameter + publicRoot target hroot output htruncate ftsSecret computation candidates context hhidden + hprivate fuel table (rootInstalledCache target output baseCache) + · exact rootInstalledCache_target target output baseCache + · intro leftRoot rightRoot + exact fullSwapRootCache_rootInstalledCache parameter target output baseCache leftRoot rightRoot + (hbase leftRoot rightRoot) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionHash.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionHash.lean new file mode 100644 index 00000000..975672de --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionHash.lean @@ -0,0 +1,371 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionEncoding + +/-! +# Hidden-root planned hash coupling + +When the selected root is not one of a structural input's children, both materialized states +reconstruct exactly the same input. This module gives the exact lookup and resolver coupling for +that branch. The complementary child branch is handled by the recorded candidate miss. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem rootHiddenRelates_of_with_eq + (target : Position) (leftOutput rightOutput : HashOutput) + (left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hrel : RootHiddenRelatesWith target leftOutput rightOutput (· = ·) left right) : + RootHiddenRelates target leftOutput rightOutput left right := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + apply relTriple_post_mono + (hrel leftState rightState hstate fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => trivial + | some rightResult => exact False.elim hresult + | some leftResult => + cases rightResult with + | none => exact False.elim hresult + | some rightResult => + change RootHiddenStateRel target leftOutput rightOutput + leftResult.state rightResult.state ∧ + leftResult.remaining = rightResult.remaining ∧ + leftResult.table = rightResult.table ∧ + leftResult.value.1 = rightResult.value.1 ∧ + RootHiddenCacheRel target leftOutput rightOutput + leftResult.value.2 rightResult.value.2 at hresult ⊢ + exact hresult + +theorem rootHiddenRelatesWith_peekCoordinate_eq_of_ne + (target : Position) (leftOutput rightOutput : HashOutput) + (coordinate : Coordinate) (hne : coordinate ≠ .position target) : + RootHiddenRelatesWith target leftOutput rightOutput (· = ·) + (peekCoordinate coordinate) (peekCoordinate coordinate) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + rw [peekCoordinate_run_eq, peekCoordinate_run_eq, LazyRevealProbe.peekQuery, + runCleanFromTable_peek_query_bind, runCleanFromTable_peek_query_bind] + simp only [runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure + ⟨hstate, rfl, rfl, + congrArg (Option.map truncateHash) (hstate.other_values coordinate hne), hcache⟩ + +theorem rootHiddenRelatesWith_peekPositionValues_eq_of_not_mem + (target : Position) (leftOutput rightOutput : HashOutput) : ∀ positions, + target ∉ positions → + RootHiddenRelatesWith target leftOutput rightOutput (· = ·) + (peekPositionValues positions) (peekPositionValues positions) + | [], _ => by + simp only [peekPositionValues] + exact rootHiddenRelatesWith_pure target leftOutput rightOutput + (some ([] : List Digest)) (some []) rfl + | position :: remaining, hnot => by + simp only [peekPositionValues] + have hposition : position ≠ target := by + intro heq + apply hnot + simp [heq] + have hremaining : target ∉ remaining := by + intro hmem + exact hnot (List.mem_cons_of_mem position hmem) + apply (rootHiddenRelatesWith_peekCoordinate_eq_of_ne target leftOutput rightOutput + (.position position) (by simpa using hposition)).bind + intro leftValue rightValue hvalue + subst rightValue + cases leftValue with + | none => + exact rootHiddenRelatesWith_pure target leftOutput rightOutput + (none : Option (List Digest)) none rfl + | some value => + apply (rootHiddenRelatesWith_peekPositionValues_eq_of_not_mem target leftOutput + rightOutput remaining hremaining).bind + intro leftTail rightTail htail + subst rightTail + cases leftTail with + | none => + exact rootHiddenRelatesWith_pure target leftOutput rightOutput + (none : Option (List Digest)) none rfl + | some tail => + exact rootHiddenRelatesWith_pure target leftOutput rightOutput + (some (value :: tail)) (some (value :: tail)) rfl + +theorem rootHiddenRelatesWith_peekTableInput_position_eq_of_not_mem_children + (parameter : PublicParameter) + (target : Position) (leftOutput rightOutput : HashOutput) + (position : Position) (hnot : target ∉ position.children) : + RootHiddenRelatesWith target leftOutput rightOutput (· = ·) + (peekTableInput parameter (.position position)) + (peekTableInput parameter (.position position)) := by + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput.eq_2] + by_cases hzero : step.val = 0 + · rw [if_pos hzero] + apply (rootHiddenRelatesWith_peekCoordinate_eq_of_ne target leftOutput rightOutput + (.chainStart lay tree leafIdx chainIdx) (by simp)).bind + intro leftValue rightValue hvalue + subst rightValue + cases leftValue with + | none => + exact rootHiddenRelatesWith_pure target leftOutput rightOutput + (none : Option HashInput) none rfl + | some value => + exact rootHiddenRelatesWith_pure target leftOutput rightOutput + (some _) (some _) rfl + · rw [if_neg hzero] + apply (rootHiddenRelatesWith_peekPositionValues_eq_of_not_mem target leftOutput + rightOutput _ hnot).bind + intro leftValues rightValues hvalues + subst rightValues + cases leftValues with + | none => + exact rootHiddenRelatesWith_pure target leftOutput rightOutput + (none : Option HashInput) none rfl + | some values => + exact rootHiddenRelatesWith_pure target leftOutput rightOutput + (some _) (some _) rfl + | leaf lay tree leafIdx => + simp only [peekTableInput] + apply (rootHiddenRelatesWith_peekPositionValues_eq_of_not_mem target leftOutput + rightOutput _ hnot).bind + intro leftValues rightValues hvalues + subst rightValues + cases leftValues with + | none => + exact rootHiddenRelatesWith_pure target leftOutput rightOutput + (none : Option HashInput) none rfl + | some values => + exact rootHiddenRelatesWith_pure target leftOutput rightOutput + (some _) (some _) rfl + | node lay tree level nodeIdx => + simp only [peekTableInput] + apply (rootHiddenRelatesWith_peekPositionValues_eq_of_not_mem target leftOutput + rightOutput _ hnot).bind + intro leftValues rightValues hvalues + subst rightValues + cases leftValues with + | none => + exact rootHiddenRelatesWith_pure target leftOutput rightOutput + (none : Option HashInput) none rfl + | some values => + exact rootHiddenRelatesWith_pure target leftOutput rightOutput + (some _) (some _) rfl + | ftsLeaf index tree leafIdx => + simp only [peekTableInput] + apply (rootHiddenRelatesWith_peekPositionValues_eq_of_not_mem target leftOutput + rightOutput _ hnot).bind + intro leftValues rightValues hvalues + subst rightValues + cases leftValues with + | none => + exact rootHiddenRelatesWith_pure target leftOutput rightOutput + (none : Option HashInput) none rfl + | some values => + exact rootHiddenRelatesWith_pure target leftOutput rightOutput + (some _) (some _) rfl + | ftsNode index tree level nodeIdx => + simp only [peekTableInput] + apply (rootHiddenRelatesWith_peekPositionValues_eq_of_not_mem target leftOutput + rightOutput _ hnot).bind + intro leftValues rightValues hvalues + subst rightValues + cases leftValues with + | none => + exact rootHiddenRelatesWith_pure target leftOutput rightOutput + (none : Option HashInput) none rfl + | some values => + exact rootHiddenRelatesWith_pure target leftOutput rightOutput + (some _) (some _) rfl + | ftsRoots index => + simp only [peekTableInput] + apply (rootHiddenRelatesWith_peekPositionValues_eq_of_not_mem target leftOutput + rightOutput _ hnot).bind + intro leftValues rightValues hvalues + subst rightValues + cases leftValues with + | none => + exact rootHiddenRelatesWith_pure target leftOutput rightOutput + (none : Option HashInput) none rfl + | some values => + exact rootHiddenRelatesWith_pure target leftOutput rightOutput + (some _) (some _) rfl + +theorem rootHiddenRelates_modify_ordinary_pure + (target : Position) (leftOutput rightOutput : HashOutput) + (input : HashInput) (output : HashOutput) : + RootHiddenRelates target leftOutput rightOutput + ((do + modify (fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output)) + pure output) : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput) + ((do + modify (fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output)) + pure output) : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + simp only [StateT.run_bind, StateT.run_modify, StateT.run_pure, runCleanFromTable] + exact relTriple_pure_pure + ⟨hstate, rfl, rfl, rfl, hcache.update_same_ordinary input output⟩ + +theorem rootHiddenRelates_revealCoordinateOutput_of_ne + (target : Position) (leftOutput rightOutput : HashOutput) + (coordinate : Coordinate) (hne : coordinate ≠ .position target) : + RootHiddenRelates target leftOutput rightOutput + (revealCoordinateOutput coordinate) (revealCoordinateOutput coordinate) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + rw [revealCoordinateOutput_run_eq, revealCoordinateOutput_run_eq, + LazyRevealProbe.revealQuery, runCleanFromTable_reveal_query_bind, + runCleanFromTable_reveal_query_bind] + have hvalue := hstate.other_values coordinate hne + cases hleft : leftState.values coordinate with + | some output => + have hright : rightState.values coordinate = some output := by + rw [← hvalue] + exact hleft + simp only [hright, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, rfl, + hcache.update_same_hidden_of_ne coordinate output hne⟩ + | none => + have hright : rightState.values coordinate = none := by + rw [← hvalue] + exact hleft + simp only [hright] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + have hhit := hstate.hitAt_eq (.chainStart lay tree leafIdx chainIdx) output + by_cases hleftHit : leftState.hitAt (.chainStart lay tree leafIdx chainIdx) output + · have hrightHit := hhit.mp hleftHit + change leftState.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) at hleftHit + change rightState.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) at hrightHit + rw [if_pos hleftHit, if_pos hrightHit] + exact relTriple_pure_pure trivial + · have hrightHit : ¬rightState.hitAt + (.chainStart lay tree leafIdx chainIdx) output := + fun h => hleftHit (hhit.mpr h) + simp only [output, hleftHit, hrightHit, ↓reduceIte, + runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate.materialize_other + (.chainStart lay tree leafIdx chainIdx) output hne, + rfl, rfl, rfl, + hcache.update_same_hidden_of_ne + (.chainStart lay tree leafIdx chainIdx) output hne⟩ + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftSample rightSample hsample + subst rightSample + have hhit := hstate.hitAt_eq (.position position) leftSample + by_cases hleftHit : leftState.hitAt (.position position) leftSample + · have hrightHit := hhit.mp hleftHit + simp [hleftHit, hrightHit, RootHiddenCleanSameRel] + · have hrightHit : ¬rightState.hitAt (.position position) leftSample := + fun h => hleftHit (hhit.mpr h) + simp only [hleftHit, hrightHit, ↓reduceIte, + runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate.materialize_other + (.position position) leftSample hne, + rfl, rfl, rfl, + hcache.update_same_hidden_of_ne (.position position) leftSample hne⟩ + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem rootHiddenRelates_resolveKnownInput_of_not_mem_children + (parameter : PublicParameter) + (target : Position) (leftOutput rightOutput : HashOutput) + (position : Position) (hposition : position ≠ target) + (hnot : target ∉ position.children) (input : HashInput) : + RootHiddenRelates target leftOutput rightOutput + (resolveKnownInput parameter (.position position) input) + (resolveKnownInput parameter (.position position) input) := by + unfold resolveKnownInput + apply (rootHiddenRelates_of_with_eq target leftOutput rightOutput _ _ + (rootHiddenRelatesWith_peekTableInput_position_eq_of_not_mem_children parameter target + leftOutput rightOutput position hnot)).bind + intro leftKnown rightKnown hknown + subst rightKnown + cases leftKnown with + | none => + exact rootHiddenRelates_splitHashQuery_ordinary target leftOutput rightOutput input + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + apply (rootHiddenRelates_revealCoordinateOutput_of_ne target leftOutput rightOutput + (.position position) (by simpa using hposition)).bind + intro leftValue rightValue hvalue + subst rightValue + apply (rootHiddenRelates_publishCoordinate_of_ne target leftOutput rightOutput + (.position position) (by simpa using hposition)).bind + intro _ _ _ + exact rootHiddenRelates_modify_ordinary_pure target leftOutput rightOutput input leftValue + · simp only [heq, ↓reduceIte] + exact rootHiddenRelates_splitHashQuery_ordinary target leftOutput rightOutput input + +theorem rootHiddenRelates_executeCandidate + (target : Position) (leftOutput rightOutput : HashOutput) + (candidate? : Option Probe) : + RootHiddenRelates target leftOutput rightOutput + (executeCandidate? candidate?) (executeCandidate? candidate?) := by + cases candidate? with + | none => exact rootHiddenRelates_pure target leftOutput rightOutput () + | some candidate => exact rootHiddenRelates_probe target leftOutput rightOutput candidate + +theorem rootHiddenRelates_resolvePublicKnownInput_of_ne + (parameter : PublicParameter) + (target : Position) (leftOutput rightOutput : HashOutput) + (publicState : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) (hne : coordinate ≠ .position target) + (input : HashInput) : + RootHiddenRelates target leftOutput rightOutput + (resolvePublicKnownInput parameter publicState coordinate input) + (resolvePublicKnownInput parameter publicState coordinate input) := by + unfold resolvePublicKnownInput + cases hknown : purePeekTableInput parameter publicState coordinate with + | none => + exact rootHiddenRelates_splitHashQuery_ordinary target leftOutput rightOutput input + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + apply (rootHiddenRelates_revealCoordinateOutput_of_ne target leftOutput rightOutput + coordinate hne).bind + intro leftValue rightValue hvalue + subst rightValue + apply (rootHiddenRelates_publishCoordinate_of_ne target leftOutput rightOutput + coordinate hne).bind + intro _ _ _ + exact rootHiddenRelates_modify_ordinary_pure target leftOutput rightOutput input leftValue + · simp only [heq, ↓reduceIte] + exact rootHiddenRelates_splitHashQuery_ordinary target leftOutput rightOutput input + +theorem rootHiddenRelates_probingHashQueryAfterPublicPlan + (parameter : PublicParameter) + (target : Position) (leftOutput rightOutput : HashOutput) + (input : HashInput) (publicState : LazyRevealProbe.State Coordinate) + (plan : PlannedHashQuery) + (hsafe : plan.action ≠ .resolve (.position target)) : + RootHiddenRelates target leftOutput rightOutput + (probingHashQueryAfterPublicPlan parameter input publicState plan) + (probingHashQueryAfterPublicPlan parameter input publicState plan) := by + unfold probingHashQueryAfterPublicPlan + apply (rootHiddenRelates_executeCandidate target leftOutput rightOutput plan.candidate?).bind + intro _ _ _ + cases haction : plan.action with + | ordinary => + exact rootHiddenRelates_splitHashQuery_ordinary target leftOutput rightOutput input + | resolve coordinate => + have hne : coordinate ≠ .position target := by + intro heq + apply hsafe + rw [haction, heq] + exact rootHiddenRelates_resolvePublicKnownInput_of_ne parameter target leftOutput + rightOutput publicState coordinate hne input + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionHidden.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionHidden.lean new file mode 100644 index 00000000..0f91ca63 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionHidden.lean @@ -0,0 +1,482 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionHash + +/-! +# Hidden-state materialized selection coupling + +Canonical public views of two hidden-root-related states are equal. The materialized selection +prefix therefore chooses the same plan, while every safe public-plan execution and the complete +target-aware signer preserve the hidden-root quotient. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +theorem runCleanFromTable_publishOrdinaryInput + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (input : HashInput) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) (cache : SplitHashCache) : + runCleanFromTable state fuel table + ((publishOrdinaryInput coordinate input output).run cache) = + pure (some + { state := state.publish coordinate + remaining := fuel + value := (output, Function.update cache (.ordinary input) (some output)) + table := table }) := by + unfold publishOrdinaryInput + rw [StateT.run_bind, runCleanFromTable_bind, runCleanFromTable_publishCoordinate] + simp [StateT.run_modify, runCleanFromTable] + +theorem runCleanFromTable_revealPublishOrdinaryInput_of_value + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (input : HashInput) (state : LazyRevealProbe.State Coordinate) + (fuel : Nat) (cache : SplitHashCache) (output : HashOutput) + (hvalue : state.values coordinate = some output) : + runCleanFromTable state fuel table + ((revealPublishOrdinaryInput coordinate input).run cache) = + pure (some + { state := state.publish coordinate + remaining := fuel + value := (output, Function.update + (Function.update cache (.hidden coordinate) (some output)) + (.ordinary input) (some output)) + table := table }) := by + unfold revealPublishOrdinaryInput + rw [StateT.run_bind, runCleanFromTable_bind, revealCoordinateOutput_run_eq, + LazyRevealProbe.revealQuery, runCleanFromTable_reveal_query_bind, hvalue] + simp only [runCleanFromTable, OracleComp.construct_pure, pure_bind] + change runCleanFromTable state fuel table + ((publishOrdinaryInput coordinate input output).run + (Function.update cache (.hidden coordinate) (some output))) = _ + exact runCleanFromTable_publishOrdinaryInput table coordinate input output state fuel + (Function.update cache (.hidden coordinate) (some output)) + +set_option maxRecDepth 100000 in +theorem evalDist_targetPublicResolve_then_finish_eq + (parameter : PublicParameter) (target : Position) + (leftOutput rightOutput : HashOutput) + (publicState : LazyRevealProbe.State Coordinate) (input : HashInput) + (leftState rightState : LazyRevealProbe.State Coordinate) + (hstate : RootHiddenStateRel target leftOutput rightOutput leftState rightState) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache) + (leftObserve rightObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option Probe)) + (candidates : List Probe) + (hrecursive : ∀ leftResult rightResult, + RootHiddenCleanSameRel target leftOutput rightOutput + (some leftResult) (some rightResult) → + evalDist (continueMaterializedPrivateOrdinalSelection target leftObserve + leftResult.state leftResult.remaining leftResult.value.1 leftResult.value.2 candidates) = + evalDist (continueMaterializedPrivateOrdinalSelection target rightObserve + rightResult.state rightResult.remaining rightResult.value.1 rightResult.value.2 + candidates)) : + evalDist + (runCleanFromTable leftState fuel table + ((resolvePublicKnownInput parameter publicState (.position target) input).run + leftCache) >>= + finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target leftObserve) candidates) = + evalDist + (runCleanFromTable rightState fuel table + ((resolvePublicKnownInput parameter publicState (.position target) input).run + rightCache) >>= + finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target rightObserve) candidates) := by + unfold resolvePublicKnownInput + cases hknown : purePeekTableInput parameter publicState (.position target) with + | none => + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (rootHiddenRelates_splitHashQuery_ordinary target leftOutput rightOutput input + leftState rightState hstate fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => rfl + | some rightResult => simp [RootHiddenCleanSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootHiddenCleanSameRel] at hresult + | some rightResult => exact hrecursive leftResult rightResult hresult + | some knownInput => + by_cases heq : knownInput = input + · simp only [heq, ↓reduceIte] + change evalDist + (runCleanFromTable leftState fuel table + ((revealPublishOrdinaryInput (.position target) input).run leftCache) >>= + finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target leftObserve) candidates) = + evalDist + (runCleanFromTable rightState fuel table + ((revealPublishOrdinaryInput (.position target) input).run rightCache) >>= + finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target rightObserve) candidates) + rw [runCleanFromTable_revealPublishOrdinaryInput_of_value table (.position target) input + leftState fuel leftCache leftOutput hstate.left_target, + runCleanFromTable_revealPublishOrdinaryInput_of_value table (.position target) input + rightState fuel rightCache rightOutput hstate.right_target] + simp [finishMaterializedPrivateOrdinalSelection, + continueMaterializedPrivateOrdinalSelection, LazyRevealProbe.State.publish] + · simp only [heq, ↓reduceIte] + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (rootHiddenRelates_splitHashQuery_ordinary target leftOutput rightOutput input + leftState rightState hstate fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => rfl + | some rightResult => simp [RootHiddenCleanSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootHiddenCleanSameRel] at hresult + | some rightResult => exact hrecursive leftResult rightResult hresult + +set_option maxRecDepth 100000 in +theorem evalDist_targetPublicPlan_then_finish_eq + (parameter : PublicParameter) (target : Position) + (leftOutput rightOutput : HashOutput) + (publicState : LazyRevealProbe.State Coordinate) (input : HashInput) + (plan : PlannedHashQuery) (haction : plan.action = .resolve (.position target)) + (leftState rightState : LazyRevealProbe.State Coordinate) + (hstate : RootHiddenStateRel target leftOutput rightOutput leftState rightState) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache) + (leftObserve rightObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option Probe)) + (candidates : List Probe) + (hrecursive : ∀ leftResult rightResult, + RootHiddenCleanSameRel target leftOutput rightOutput + (some leftResult) (some rightResult) → + evalDist (continueMaterializedPrivateOrdinalSelection target leftObserve + leftResult.state leftResult.remaining leftResult.value.1 leftResult.value.2 candidates) = + evalDist (continueMaterializedPrivateOrdinalSelection target rightObserve + rightResult.state rightResult.remaining rightResult.value.1 rightResult.value.2 + candidates)) : + evalDist + (runCleanFromTable leftState fuel table + ((probingHashQueryAfterPublicPlan parameter input publicState plan).run leftCache) >>= + finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target leftObserve) candidates) = + evalDist + (runCleanFromTable rightState fuel table + ((probingHashQueryAfterPublicPlan parameter input publicState plan).run rightCache) >>= + finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target rightObserve) candidates) := by + unfold probingHashQueryAfterPublicPlan + rw [haction, StateT.run_bind, StateT.run_bind, + runCleanFromTable_bind, runCleanFromTable_bind] + simp only [bind_assoc] + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (rootHiddenRelates_executeCandidate target leftOutput rightOutput plan.candidate? + leftState rightState hstate fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => rfl + | some rightResult => simp [RootHiddenCleanSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootHiddenCleanSameRel] at hresult + | some rightResult => + rcases hresult with ⟨hnextState, hremaining, htable, hvalue, hnextCache⟩ + simp only + rw [← hremaining, ← htable] + exact evalDist_targetPublicResolve_then_finish_eq parameter target leftOutput + rightOutput publicState input leftResult.state rightResult.state hnextState + leftResult.remaining leftResult.table leftResult.value.2 rightResult.value.2 + hnextCache leftObserve rightObserve candidates hrecursive + +theorem evalDist_finishMaterializedSelection_eq_of_rootHidden + (target : Position) (leftOutput rightOutput : HashOutput) + (observeLeft observeRight : LazyRevealProbe.State Coordinate → Nat → α → + SplitHashCache → List Probe → ProbComp (Option Probe)) + (candidates : List Probe) + (left right : Option (CleanRunResult (α × SplitHashCache))) + (hrel : RootHiddenCleanSameRel target leftOutput rightOutput left right) + (hnext : ∀ leftResult rightResult, + RootHiddenCleanSameRel target leftOutput rightOutput + (some leftResult) (some rightResult) → + evalDist (observeLeft leftResult.state leftResult.remaining leftResult.value.1 + leftResult.value.2 candidates) = + evalDist (observeRight rightResult.state rightResult.remaining rightResult.value.1 + rightResult.value.2 candidates)) : + evalDist (finishMaterializedPrivateOrdinalSelection observeLeft candidates left) = + evalDist (finishMaterializedPrivateOrdinalSelection observeRight candidates right) := by + cases left with + | none => + cases right with + | none => rfl + | some rightResult => simp [RootHiddenCleanSameRel] at hrel + | some leftResult => + cases right with + | none => simp [RootHiddenCleanSameRel] at hrel + | some rightResult => exact hnext leftResult rightResult hrel + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem evalDist_materializedRootAvoidingOrdinalSelection_hidden + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) + (leftState rightState : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hstate : RootHiddenStateRel target leftOutput rightOutput leftState rightState) + (hcache : RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache) : + evalDist + (materializedComparisonRootAvoidingOrdinalSelection ordinal parameter publicRoot target + leftOutput rightOutput ftsSecret computation candidates leftState fuel table leftCache) = + evalDist + (materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot target + (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret computation candidates + rightState fuel table rightCache) := by + classical + induction computation using OracleComp.inductionOn generalizing + candidates leftState rightState fuel leftCache rightCache with + | pure value => + simp [materializedComparisonRootAvoidingOrdinalSelection, + materializedActualRootAvoidingOrdinalSelection, + materializedRootAvoidingOrdinalSelection] + | query_bind query next ih => + unfold materializedComparisonRootAvoidingOrdinalSelection + materializedActualRootAvoidingOrdinalSelection + rw [materializedRootAvoidingOrdinalSelection, OracleComp.construct_query_bind, + materializedRootAvoidingOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp [hselected] + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (rootHiddenRelates_splitUniformImpl target leftOutput rightOutput n + leftState rightState hstate fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + apply evalDist_finishMaterializedSelection_eq_of_rootHidden target leftOutput + rightOutput _ _ candidates _ _ hresult + intro nextLeft nextRight hnextRel + rcases hnextRel with ⟨hnextState, hremaining, htable, hvalue, hnextCache⟩ + rw [← hremaining, ← hvalue] + unfold continueMaterializedPrivateOrdinalSelection + have hreveal : nextLeft.state.revealed = nextRight.state.revealed := + hnextState.revealed + by_cases hrevealed : Coordinate.position target ∈ nextLeft.state.revealed + · have hrightRevealed : Coordinate.position target ∈ nextRight.state.revealed := by + rwa [← hreveal] + simp [hrevealed, hrightRevealed] + · have hrightRevealed : Coordinate.position target ∉ nextRight.state.revealed := by + intro hmem + exact hrevealed (by rwa [hreveal]) + simp only [hrevealed, hrightRevealed, ↓reduceIte] + exact ih nextLeft.value.1 candidates nextLeft.state nextRight.state + nextLeft.remaining nextLeft.value.2 nextRight.value.2 hnextState hnextCache + | inr input => + have hpublic := materializedCanonicalContext_state_eq_of_rootHidden hstate table + rw [← hpublic] + let publicContext := materializedCanonicalContext table leftState + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table leftState).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp [hactual] + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table leftState).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + by_cases hsafe : RootAwareCandidateAvoidsRoots target + (truncateHash leftOutput) (truncateHash rightOutput) candidate? + · have hsafeActual : RootAwareCandidateAvoidsRoots target + (truncateHash leftOutput) (truncateHash rightOutput) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table leftState).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + let leftObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining value nextCache laterCandidates => + materializedComparisonRootAvoidingOrdinalSelection ordinal parameter + publicRoot target leftOutput rightOutput ftsSecret (next value) + laterCandidates nextState remaining table nextCache + let rightObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining value nextCache laterCandidates => + materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot + target (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret + (next value) laterCandidates nextState remaining table nextCache + have hrecursive : ∀ nextLeft nextRight, + RootHiddenCleanSameRel target leftOutput rightOutput + (some nextLeft) (some nextRight) → + evalDist (continueMaterializedPrivateOrdinalSelection target leftObserve + nextLeft.state nextLeft.remaining nextLeft.value.1 nextLeft.value.2 + nextCandidates) = + evalDist (continueMaterializedPrivateOrdinalSelection target rightObserve + nextRight.state nextRight.remaining nextRight.value.1 nextRight.value.2 + nextCandidates) := by + intro nextLeft nextRight hnextRel + rcases hnextRel with + ⟨hnextState, hremaining, htable, hvalue, hnextCache⟩ + rw [← hremaining, ← hvalue] + unfold continueMaterializedPrivateOrdinalSelection + have hreveal : nextLeft.state.revealed = nextRight.state.revealed := + hnextState.revealed + by_cases hrevealed : Coordinate.position target ∈ nextLeft.state.revealed + · have hrightRevealed : + Coordinate.position target ∈ nextRight.state.revealed := by + rwa [← hreveal] + simp [hrevealed, hrightRevealed] + · have hrightRevealed : + Coordinate.position target ∉ nextRight.state.revealed := by + intro hmem + exact hrevealed (by rwa [hreveal]) + simp only [hrevealed, hrightRevealed, ↓reduceIte] + exact ih nextLeft.value.1 nextCandidates nextLeft.state nextRight.state + nextLeft.remaining nextLeft.value.2 nextRight.value.2 hnextState hnextCache + letI : Decidable + (plan.action = PlannedHashAction.resolve (.position target)) := + Classical.propDecidable _ + by_cases haction : plan.action = .resolve (.position target) + · exact evalDist_targetPublicPlan_then_finish_eq parameter target leftOutput + rightOutput (materializedCanonicalContext table leftState).state input plan + haction leftState rightState hstate fuel table leftCache rightCache hcache + leftObserve rightObserve nextCandidates hrecursive + · apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (rootHiddenRelates_probingHashQueryAfterPublicPlan parameter target + leftOutput rightOutput input + (materializedCanonicalContext table leftState).state plan haction + leftState rightState hstate fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + exact evalDist_finishMaterializedSelection_eq_of_rootHidden target leftOutput + rightOutput _ _ nextCandidates _ _ hresult hrecursive + · have hsafeActual : ¬RootAwareCandidateAvoidsRoots target + (truncateHash leftOutput) (truncateHash rightOutput) + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table leftState).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp [hsafeActual] + | inr message => + apply evalDist_bind_eq_of_relTriple_next _ _ _ _ _ + (rootHiddenRelates_maskedSignWithTargetComparison_actual parameter publicRoot + ftsSecret target hroot leftOutput rightOutput message leftState rightState hstate + fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + apply evalDist_finishMaterializedSelection_eq_of_rootHidden target leftOutput + rightOutput _ _ candidates _ _ hresult + intro nextLeft nextRight hnextRel + rcases hnextRel with ⟨hnextState, hremaining, htable, hvalue, hnextCache⟩ + rw [← hremaining, ← hvalue] + unfold continueMaterializedPrivateOrdinalSelection + have hreveal : nextLeft.state.revealed = nextRight.state.revealed := + hnextState.revealed + by_cases hrevealed : Coordinate.position target ∈ nextLeft.state.revealed + · have hrightRevealed : Coordinate.position target ∈ nextRight.state.revealed := by + rwa [← hreveal] + simp [hrevealed, hrightRevealed] + · have hrightRevealed : Coordinate.position target ∉ nextRight.state.revealed := by + intro hmem + exact hrevealed (by rwa [hreveal]) + simp only [hrevealed, hrightRevealed, ↓reduceIte] + exact ih nextLeft.value.1 candidates nextLeft.state nextRight.state + nextLeft.remaining nextLeft.value.2 nextRight.value.2 hnextState hnextCache + +theorem evalDist_materializedRootAvoidingOrdinalSelection_deferred + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) + (leftContext rightContext : DeferredContext) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcontext : RootDeferredContextRel target leftOutput rightOutput + leftContext rightContext) + (hcache : RootDeferredCacheRel parameter target leftOutput rightOutput + leftCache rightCache) : + evalDist + (materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot target + (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret computation candidates + (materializedDeferredState leftContext) fuel table leftCache) = + evalDist + (materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot target + (truncateHash rightOutput) (truncateHash leftOutput) ftsSecret computation candidates + (materializedDeferredState rightContext) fuel table rightCache) := by + obtain ⟨middleCache, hencoding, hhidden⟩ := hcache + have hmaterialized := hcontext.materialized + have hstored : StoredLayerRoot (materializedDeferredState leftContext) target + (truncateHash leftOutput) := + ⟨leftOutput, hmaterialized.state.left_target, rfl⟩ + calc + _ = evalDist + (materializedComparisonRootAvoidingOrdinalSelection ordinal parameter publicRoot target + leftOutput rightOutput ftsSecret computation candidates + (materializedDeferredState leftContext) fuel table middleCache) := + evalDist_materializedRootAvoidingOrdinalSelection_encoding ordinal parameter publicRoot + target hroot leftOutput rightOutput ftsSecret computation candidates + (materializedDeferredState leftContext) fuel table leftCache middleCache hencoding hstored + _ = evalDist + (materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot target + (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret computation candidates + (materializedDeferredState rightContext) fuel table rightCache) := + evalDist_materializedRootAvoidingOrdinalSelection_hidden ordinal parameter publicRoot + target hroot leftOutput rightOutput ftsSecret computation candidates + (materializedDeferredState leftContext) (materializedDeferredState rightContext) fuel table + middleCache rightCache hmaterialized.state hhidden + _ = _ := congrArg evalDist + (materializedRootAvoidingOrdinalSelection_swap_roots ordinal parameter target + (truncateHash leftOutput) (truncateHash rightOutput) + (maskedSign parameter publicRoot ftsSecret) computation candidates + (materializedDeferredState rightContext) fuel table rightCache) + +theorem evalDist_materializedRootAvoidingOrdinalSelection_fullSwap + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) + (hhidden : context.state.values (.position target) = none) + (hprivate : Coordinate.position target ∉ context.state.revealed) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) + (hcache : cache (.hidden (.position target)) = some leftOutput) : + let leftContext := + { context with values := context.values.install target leftOutput } + let rightContext := + { context with values := context.values.install target rightOutput } + evalDist + (materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot target + (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret computation candidates + (materializedDeferredState leftContext) fuel table cache) = + evalDist + (materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot target + (truncateHash rightOutput) (truncateHash leftOutput) ftsSecret computation candidates + (materializedDeferredState rightContext) fuel table + (fullSwapRootCache parameter target (truncateHash leftOutput) + (truncateHash rightOutput) rightOutput cache)) := by + dsimp only + exact evalDist_materializedRootAvoidingOrdinalSelection_deferred ordinal parameter publicRoot + target hroot leftOutput rightOutput ftsSecret computation candidates _ _ fuel table cache _ + (rootDeferredContextRel_install target leftOutput rightOutput context hhidden hprivate) + (rootDeferredCacheRel_fullSwapRootCache parameter target leftOutput rightOutput cache hcache) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionInitial.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionInitial.lean new file mode 100644 index 00000000..32aadee3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionInitial.lean @@ -0,0 +1,423 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionFamily + +/-! +# Root-neutral initial cache + +Public top-root construction touches only hidden split-cache keys. Its completed cache is therefore +neutral under every later layer-root encoding-key swap. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +set_option maxRecDepth 100000 +set_option maxHeartbeats 2000000 +set_option linter.constructorNameAsVariable false + +theorem ordinaryCachePreserving_maskedPublishedTreeRoot : + OrdinaryCachePreserving maskedPublishedTreeRoot := by + unfold maskedPublishedTreeRoot + exact (OrdinaryCachePreserving.of_splitCachePreserving + (splitCachePreserving_ensureTreeNode topLayer rootTree (layerHeight topLayer) 0)).bind fun _ => + ordinaryCachePreserving_revealPublishedCoordinate + (.position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, + by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0)) + +theorem preservesCoordinate_maskedTreeRoot_of_ne + (position : Position) (lay : Layer) (tree : TreeIndex) + (hne : position ≠ layerRootPosition lay tree) : + PreservesCoordinate (.position position) (maskedTreeRoot lay tree) := by + have hpos : 0 < layerHeight lay := by + unfold layerHeight + split <;> norm_num [maxLayerHeight] + have hlevel : layerHeight lay - 1 < maxLayerHeight := by + have hle := layerHeight_le lay + omega + have hcoordinate : Coordinate.position position ≠ + .position (.node lay tree ⟨layerHeight lay - 1, hlevel⟩ (leafOfNat 0)) := by + intro heq + apply hne + apply Coordinate.position.inj at heq + calc + position = .node lay tree ⟨layerHeight lay - 1, hlevel⟩ (leafOfNat 0) := heq + _ = layerRootPosition lay tree := by + simp [layerRootPosition, leafOfNat] + unfold maskedTreeRoot + rw [show layerHeight lay = (layerHeight lay - 1) + 1 by omega, maskedTreeNode] + exact (preservesCoordinate_ensureTreeNode (.position position) lay tree + (layerHeight lay - 1 + 1) 0).bind fun _ => by + rw [dif_pos hlevel] + exact preservesCoordinate_revealPosition_of_ne (.position position) + (.node lay tree ⟨layerHeight lay - 1, hlevel⟩ (leafOfNat 0)) hcoordinate + +theorem preservesCoordinate_maskedPublishedTreeRoot_of_ne + (position : Position) + (hne : position ≠ layerRootPosition topLayer rootTree) : + PreservesCoordinate (.position position) maskedPublishedTreeRoot := by + rw [maskedPublishedTreeRoot_eq] + exact (preservesCoordinate_maskedTreeRoot_of_ne position topLayer rootTree hne).bind fun _ => + (preservesCoordinate_publishCoordinate_of_ne (.position position) + (.position (layerRootPosition topLayer rootTree)) (by + intro heq + exact hne (Coordinate.position.inj heq))).bind fun _ => + preservesCoordinate_pure (.position position) _ + +theorem layerRootPosition_ne_top_of_parent + {target : Position} (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) : + target ≠ layerRootPosition topLayer rootTree := by + obtain ⟨parent, hparentOf⟩ := hparent + obtain ⟨lay, tree, hlay, htarget⟩ := + isShortLayerRoot_of_isLayerRoot_of_parent hroot hparentOf + subst target + intro heq + simp only [layerRootPosition, Position.node.injEq] at heq + exact hlay heq.1 + +theorem NoEncodingRootGuessCached.of_ordinaryCachePreserving + (parameter : PublicParameter) (target : Position) (root : Digest) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hpreserves : OrdinaryCachePreserving computation) + (state finalState : LazyRevealProbe.State Coordinate) + (initialCache finalCache : SplitHashCache) + (fuel remaining : Nat) (value : α) + (hinitial : NoEncodingRootGuessCached parameter target root initialCache) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel (computation.run initialCache))) : + NoEncodingRootGuessCached parameter target root finalCache := by + have hordinary := hpreserves state initialCache fuel finalState remaining value finalCache hresult + intro input hguess + change ordinaryQueryCache finalCache input = none + rw [hordinary] + exact hinitial input hguess + +theorem noEncodingRootGuessCached_empty + (parameter : PublicParameter) (target : Position) (root : Digest) : + NoEncodingRootGuessCached parameter target root emptySplitHashCache := by + intro input _hguess + rfl + +set_option maxRecDepth 100000 in +theorem mem_support_runRaw_done_of_mem_runCleanFromTable_some + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : CleanRunResult α) + (hresult : some result ∈ support (runCleanFromTable state fuel table computation)) : + LazyRevealProbe.RawResult.done result.state result.remaining result.value ∈ + support (LazyRevealProbe.runRaw state fuel computation) := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + simp [runCleanFromTable, LazyRevealProbe.runRaw] at hresult ⊢ + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + simp + | query_bind query next ih => + cases query with + | uniform n => + rw [runCleanFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hrest⟩ := hresult + rw [LazyRevealProbe.runRaw_uniform_query_bind, mem_support_bind_iff] + exact ⟨output, houtput, ih output state fuel hrest⟩ + | hashOutput => + rw [runCleanFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hrest⟩ := hresult + rw [LazyRevealProbe.runRaw_hashOutput_query_bind, mem_support_bind_iff] + exact ⟨output, houtput, ih output state fuel hrest⟩ + | ensure coordinate => + rw [runCleanFromTable_ensure_query_bind] at hresult + rw [LazyRevealProbe.runRaw_ensure_query_bind] + exact ih () (state.ensure coordinate) fuel hresult + | probe coordinate candidate => + rw [runCleanFromTable_probe_query_bind] at hresult + rw [LazyRevealProbe.runRaw_probe_query_bind] + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] at hresult ⊢ + exact ih () state remaining hresult + · simp only [hrevealed, ↓reduceIte] at hresult ⊢ + exact ih () (state.addPending coordinate candidate) remaining hresult + | peek coordinate => + rw [runCleanFromTable_peek_query_bind] at hresult + rw [LazyRevealProbe.runRaw_peek_query_bind] + exact ih (state.values coordinate) state fuel hresult + | publish coordinate => + rw [runCleanFromTable_publish_query_bind] at hresult + rw [LazyRevealProbe.runRaw_publish_query_bind] + exact ih () (state.publish coordinate) fuel hresult + | reveal coordinate => + rw [runCleanFromTable_reveal_query_bind] at hresult + rw [LazyRevealProbe.runRaw_reveal_query_bind] + cases hvalue : state.values coordinate with + | some output => + simp only [hvalue] at hresult ⊢ + exact ih output state fuel hresult + | none => + simp only [hvalue] at hresult ⊢ + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : state.hitAt (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] at hresult + · simp only [output, hhit, ↓reduceIte] at hresult + rw [mem_support_bind_iff] + refine ⟨output, ?_, ?_⟩ + · simp [LazyRevealProbe.sampleHashOutput] + · simp only [hhit, ↓reduceIte] + exact ih output + (state.materialize (.chainStart lay tree leafIdx chainIdx) output) fuel + hresult + | position position => + rw [mem_support_bind_iff] at hresult ⊢ + obtain ⟨output, houtput, hrest⟩ := hresult + refine ⟨output, houtput, ?_⟩ + by_cases hhit : state.hitAt (.position position) output + · simp [hhit] at hrest + · simp only [hhit, ↓reduceIte] at hrest ⊢ + exact ih output (state.materialize (.position position) output) fuel hrest + +attribute [local irreducible] maskedPublishedTreeRoot + +theorem noEncodingRootGuessCached_of_mem_runCleanFromTable_maskedPublishedTreeRoot + (parameter : PublicParameter) (target : Position) (root : Digest) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (result : CleanRunResult (Digest × SplitHashCache)) + (hresult : some result ∈ support + (runCleanFromTable state fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache))) : + NoEncodingRootGuessCached parameter target root result.value.2 := by + have hraw := mem_support_runRaw_done_of_mem_runCleanFromTable_some + (maskedPublishedTreeRoot.run emptySplitHashCache) state fuel table result hresult + exact NoEncodingRootGuessCached.of_ordinaryCachePreserving parameter target root + maskedPublishedTreeRoot ordinaryCachePreserving_maskedPublishedTreeRoot state result.state + emptySplitHashCache result.value.2 fuel result.remaining result.value.1 + (noEncodingRootGuessCached_empty parameter target root) hraw + +theorem swapCanonicalRootEncodingCache_of_mem_runCleanFromTable_maskedPublishedTreeRoot + (parameter : PublicParameter) (target : Position) (leftRoot rightRoot : Digest) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (result : CleanRunResult (Digest × SplitHashCache)) + (hresult : some result ∈ support + (runCleanFromTable state fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache))) : + swapCanonicalRootEncodingCache parameter target leftRoot rightRoot result.value.2 = + result.value.2 := + swapCanonicalRootEncodingCache_eq_of_no_guesses parameter target leftRoot rightRoot + result.value.2 + (noEncodingRootGuessCached_of_mem_runCleanFromTable_maskedPublishedTreeRoot parameter target + leftRoot state fuel table result hresult) + (noEncodingRootGuessCached_of_mem_runCleanFromTable_maskedPublishedTreeRoot parameter target + rightRoot state fuel table result hresult) + +theorem target_absent_of_mem_runCleanFromTable_maskedPublishedTreeRoot + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : CleanRunResult (Digest × SplitHashCache)) + (hresult : some result ∈ support + (runCleanFromTable (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) : + result.state.values (.position target) = none ∧ + Coordinate.position target ∉ result.state.revealed := by + have hraw := mem_support_runRaw_done_of_mem_runCleanFromTable_some + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table result hresult + have hne := layerRootPosition_ne_top_of_parent hroot hparent + have hsame := preservesCoordinate_maskedPublishedTreeRoot_of_ne target hne + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) emptySplitHashCache fuel + result.state result.remaining result.value.1 result.value.2 hraw + constructor + · rw [hsame.1] + rfl + · intro hrevealed + have : Coordinate.position target ∈ + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate).revealed := + hsame.2.mp hrevealed + simp [LazyRevealProbe.State.empty] at this + +noncomputable def materializedRootSelectionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (high : RootOutputHigh) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (leftRoot rightRoot : Digest) : ProbComp (Option Probe) := + let output := fun root => rootOutputOfParts root high + let context : DeferredContext := directDeferredContext rootResult.state + let rootContext := + { context with values := context.values.install target (output leftRoot) } + materializedActualRootAvoidingOrdinalSelection ordinal parameter rootResult.value.1 target + leftRoot rightRoot ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState rootContext) rootResult.remaining rootResult.table + (rootInstalledCache target output rootResult.value.2 leftRoot) + +set_option maxRecDepth 100000 in +theorem probEvent_uniformActualRoot_materializedSelectionAfterRootResult_le_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (high : RootOutputHigh) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) : + Pr[fun result : Digest × Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← materializedRootSelectionAfterRootResult ordinal adversary parameter + ftsSecret target high rootResult leftRoot rightRoot + pure (leftRoot, rightRoot, selection)] ≤ + Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionAt target result.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← materializedRootSelectionAfterRootResult ordinal adversary parameter + ftsSecret target high rootResult leftRoot leftRoot + pure (leftRoot, selection)] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let output := fun root => rootOutputOfParts root high + let context : DeferredContext := directDeferredContext rootResult.state + have habsent := target_absent_of_mem_runCleanFromTable_maskedPublishedTreeRoot target hroot + hparent fuel table rootResult hresult + unfold materializedRootSelectionAfterRootResult + apply probEvent_uniformActualRoot_materializedRootInstalledMatches_le_mul ordinal parameter + rootResult.value.1 target hroot output (fun root => by + exact truncateHash_rootOutputOfParts root high) + ftsSecret (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + context habsent.1 habsent.2 rootResult.remaining rootResult.table rootResult.value.2 + intro leftRoot rightRoot + exact swapCanonicalRootEncodingCache_of_mem_runCleanFromTable_maskedPublishedTreeRoot parameter + target leftRoot rightRoot (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel table rootResult hresult + +theorem probEvent_bind_le_bind_mul_of_forall + (first : ProbComp ι) (left : ι → ProbComp α) (right : ι → ProbComp β) + (event : α → Prop) (gate : β → Prop) (epsilon : ENNReal) + (hbound : ∀ index ∈ support first, + Pr[event | left index] ≤ Pr[gate | right index] * epsilon) : + Pr[event | first >>= left] ≤ Pr[gate | first >>= right] * epsilon := by + rw [probEvent_bind_eq_tsum, probEvent_bind_eq_tsum] + calc + _ ≤ ∑' index, Pr[= index | first] * + (Pr[gate | right index] * epsilon) := by + apply ENNReal.tsum_le_tsum + intro index + by_cases hindex : index ∈ support first + · gcongr + exact hbound index hindex + · rw [probOutput_eq_zero_of_not_mem_support hindex] + simp + _ = (∑' index, Pr[= index | first] * Pr[gate | right index]) * epsilon := by + simp_rw [← mul_assoc] + rw [ENNReal.tsum_mul_right] + +noncomputable def sampledHighMaterializedRootSelectionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp (Digest × Digest × Option Probe) := do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← materializedRootSelectionAfterRootResult ordinal adversary parameter + ftsSecret target high rootResult leftRoot rightRoot + pure (leftRoot, rightRoot, selection) + +noncomputable def sampledHighMaterializedRootSelectionProductionAfterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (rootResult : CleanRunResult (Digest × SplitHashCache)) : + ProbComp (Digest × Option Probe) := do + let high ← ($ᵗ RootOutputHigh : ProbComp RootOutputHigh) + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← materializedRootSelectionAfterRootResult ordinal adversary parameter + ftsSecret target high rootResult leftRoot leftRoot + pure (leftRoot, selection) + +set_option maxRecDepth 100000 in +theorem probEvent_sampledHigh_materializedSelectionAfterRootResult_le_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) : + Pr[fun result => materializedOrdinalSelectionMatches target result.1 result.2.2 | + sampledHighMaterializedRootSelectionAfterRootResult ordinal adversary parameter ftsSecret + target rootResult] ≤ + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + sampledHighMaterializedRootSelectionProductionAfterRootResult ordinal adversary parameter + ftsSecret target rootResult] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + unfold sampledHighMaterializedRootSelectionAfterRootResult + sampledHighMaterializedRootSelectionProductionAfterRootResult + apply probEvent_bind_le_bind_mul_of_forall + intro high _hhigh + exact probEvent_uniformActualRoot_materializedSelectionAfterRootResult_le_mul ordinal adversary + parameter ftsSecret target hroot hparent high fuel table rootResult hresult + +noncomputable def materializedRootOrdinalMatchExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (Digest × Digest × Option Probe) := do + let rootResult ← runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure (0, 0, none) + | some result => + sampledHighMaterializedRootSelectionAfterRootResult ordinal adversary parameter ftsSecret + target result + +noncomputable def materializedRootOrdinalProductionExperimentAfterTable + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + ProbComp (Digest × Option Probe) := do + let rootResult ← runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + match rootResult with + | none => pure (0, none) + | some result => + sampledHighMaterializedRootSelectionProductionAfterRootResult ordinal adversary parameter + ftsSecret target result + +set_option maxRecDepth 100000 in +theorem probEvent_materializedRootOrdinalMatchExperimentAfterTable_le_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + Pr[fun result => materializedOrdinalSelectionMatches target result.1 result.2.2 | + materializedRootOrdinalMatchExperimentAfterTable ordinal adversary parameter ftsSecret + target fuel table] ≤ + Pr[fun result => materializedOrdinalSelectionAt target result.2 | + materializedRootOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target fuel table] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + classical + unfold materializedRootOrdinalMatchExperimentAfterTable + materializedRootOrdinalProductionExperimentAfterTable + apply probEvent_bind_le_bind_mul_of_forall + intro rootResult hrootResult + cases rootResult with + | none => + rw [probEvent_pure, probEvent_pure] + simp [materializedOrdinalSelectionMatches, materializedOrdinalSelectionAt] + | some result => + exact probEvent_sampledHigh_materializedSelectionAfterRootResult_le_mul ordinal adversary + parameter ftsSecret target hroot hparent fuel table result hrootResult + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionLift.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionLift.lean new file mode 100644 index 00000000..4fecaf46 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionLift.lean @@ -0,0 +1,365 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionOutcome + +/-! +# Adaptive lift of delayed root selection + +The local uniform, hash and signing kernels are composed through an arbitrary outer computation. +Earlier distinguished-root candidates contradict the retained good prefix, while every clean +transition recurses with the canonical left context supplied by the common finisher. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_directRootSelection_materializedOutcome + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftOutput : HashOutput) (rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hcanonical : CanonicalMaterializedValues table left) + (hprefix : CandidatesAvoidRoots target (truncateHash leftOutput) rightRoot candidates) : + RelTriple + (directDetailedBoundaryPrivateOrdinalSelection ordinal parameter publicRoot ftsSecret + computation candidates left leftFuel table leftCache) + (materializedActualRootAvoidingOrdinalSelectionOutcome ordinal parameter publicRoot target + (truncateHash leftOutput) rightRoot ftsSecret computation candidates right.state rightFuel + table rightCache) + (RootSelectionBridgeRel target leftOutput rightRoot ordinal) := by + induction computation using OracleComp.inductionOn generalizing + candidates left right leftFuel rightFuel leftCache rightCache with + | pure value => + simp only [directDetailedBoundaryPrivateOrdinalSelection, OracleComp.construct_pure, + materializedActualRootAvoidingOrdinalSelectionOutcome, + materializedRootAvoidingOrdinalSelectionOutcome, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp only [selectedPrivateOrdinal?, hselected, ↓reduceDIte] + apply relTriple_pure_pure + intro hgood + right + simpa [MaterializedSelectionOutcome.Matches, + materializedOrdinalSelectionMatches] using hgood.1 + · simp only [selectedPrivateOrdinal?, hselected, ↓reduceDIte] + exact relTriple_pure_pure + (rootSelectionBridgeRel_none_left target leftOutput rightRoot ordinal _) + | query_bind query next ih => + rw [directDetailedBoundaryPrivateOrdinalSelection, OracleComp.construct_query_bind, + materializedActualRootAvoidingOrdinalSelectionOutcome, + materializedRootAvoidingOrdinalSelectionOutcome, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + apply relTriple_pure_pure + intro hgood + right + simpa [MaterializedSelectionOutcome.Matches, + materializedOrdinalSelectionMatches] using hgood.1 + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + change Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α at next + let leftObserve : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection) := + fun nextContext remaining value laterCandidates => + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter publicRoot + ftsSecret (next value.1) laterCandidates nextContext remaining table value.2 + let rightObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → ProbComp MaterializedSelectionOutcome := + fun nextState remaining output nextCache laterCandidates => + materializedActualRootAvoidingOrdinalSelectionOutcome ordinal parameter + publicRoot target (truncateHash leftOutput) rightRoot ftsSecret (next output) + laterCandidates nextState remaining table nextCache + apply relTriple_rootSelection_uniform_step target leftOutput rightRoot ordinal table + n leftObserve rightObserve candidates left right leftFuel rightFuel leftCache + rightCache hcontext hfuel hcache hrevealed hvalues hpublished hrightMaterialized + intro nextLeft nextRight hnext hnextCanonical + rw [← hnext.value_eq] + simpa [leftObserve, rightObserve] using + (ih nextLeft.value.1 candidates nextLeft.context nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 + hnext.context_le hnext.remaining_le hnext.cache_eq hnext.revealed_eq + hnext.values_le hnext.left_published hnext.right_materialized hnextCanonical + hprefix) + | inr input => + change HashOutput → OracleComp (OracleWorld + SigningSpec) α at next + have hrightValues : + (materializedCanonicalContext table right.state).state.values = + left.state.values := by + unfold materializedCanonicalContext + rw [← hrightMaterialized] + exact canonicalized_right_values_eq_of_finalizationContextLE hcontext + hrevealed hcanonical + have hplanEq : + purePlanProbingHashQuery parameter input + (materializedCanonicalContext table right.state).state = + purePlanProbingHashQuery parameter input left.state := + purePlanProbingHashQuery_eq_of_values_eq hrightValues parameter input + simp only + rw [hplanEq] + rw [← rootAwareCandidateForPlan?_purePlan parameter input left.state] + let plan := purePlanProbingHashQuery parameter input left.state + have hpublicExecutor : + probingHashQueryAfterPublicPlan parameter input + (materializedCanonicalContext table right.state).state plan = + probingHashQueryAfterPublicPlan parameter input left.state plan := + probingHashQueryAfterPublicPlan_eq_of_values_eq parameter input hrightValues plan + rw [hpublicExecutor] + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input left.state))).length := by + simpa [plan, candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + apply relTriple_pure_pure + intro hgood + right + simpa [MaterializedSelectionOutcome.Matches, + materializedOrdinalSelectionMatches] using hgood.1 + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input left.state))).length := by + simpa [plan, candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + by_cases hsafe : RootAwareCandidateAvoidsRoots target + (truncateHash leftOutput) rightRoot candidate? + · have hsafeActual : RootAwareCandidateAvoidsRoots target + (truncateHash leftOutput) rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input left.state)) := by + simpa [plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + have hnextPrefix : CandidatesAvoidRoots target + (truncateHash leftOutput) rightRoot nextCandidates := by + cases hcandidate : candidate? with + | none => simpa [nextCandidates, appendPlannedCandidate, hcandidate] + using hprefix + | some candidate => + simpa [nextCandidates, appendPlannedCandidate, hcandidate] using + (hprefix.append candidate (by + rw [← rootAwareCandidateAvoidsRoots_iff] + simpa [hcandidate] using hsafe)) + let leftObserve : DeferredContext → Nat → + (HashOutput × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection) := + fun nextContext remaining value laterCandidates => + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter publicRoot + ftsSecret (next value.1) laterCandidates nextContext remaining table + value.2 + let rightObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp MaterializedSelectionOutcome := + fun nextState remaining output nextCache laterCandidates => + materializedActualRootAvoidingOrdinalSelectionOutcome ordinal parameter + publicRoot target (truncateHash leftOutput) rightRoot ftsSecret + (next output) laterCandidates nextState remaining table nextCache + rw [hrightMaterialized] + change RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache) >>= + finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table leftObserve) + nextCandidates) + (runDirectResolvedDetailedFromTable (directDeferredContext right.state) + rightFuel table + ((probingHashQueryAfterPublicPlan parameter input left.state plan).run + rightCache) >>= + finishMaterializedSelectionOutcome target table rightObserve + nextCandidates) + (RootSelectionBridgeRel target leftOutput rightRoot ordinal) + have hbridge (hprobeFuel : plan.candidate? = none ∨ 0 < leftFuel) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache) >>= + finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table leftObserve) + nextCandidates) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQueryAfterPublicPlan parameter input left.state plan).run + rightCache) >>= + finishMaterializedSelectionOutcome target table rightObserve + nextCandidates) + (RootSelectionBridgeRel target leftOutput rightRoot ordinal) := by + apply relTriple_rootSelection_hash_step target leftOutput rightRoot ordinal + table parameter input plan leftObserve rightObserve nextCandidates left right + leftFuel rightFuel leftCache rightCache hprobeFuel hcontext hfuel hcache + hrevealed hvalues hpublished hrightMaterialized + intro nextLeft nextRight hnext hnextCanonical + rw [← hnext.value_eq] + exact ih nextLeft.value.1 nextCandidates nextLeft.context nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 + hnext.context_le hnext.remaining_le hnext.cache_eq hnext.revealed_eq + hnext.values_le hnext.left_published hnext.right_materialized + hnextCanonical hnextPrefix + rw [hrightMaterialized] at hbridge + cases hplanCandidate : plan.candidate? with + | none => + exact hbridge (Or.inl hplanCandidate) + | some plannedCandidate => + by_cases hpositive : 0 < leftFuel + · exact hbridge (Or.inr hpositive) + · have hzero : leftFuel = 0 := by omega + subst leftFuel + apply relTriple_of_evalDist_eq_left + (oa' := (pure none : ProbComp (Option PrivateOrdinalSelection))) + (by + unfold probingHashQueryAfterPlan executePlannedHashQuery + rw [StateT.run_bind] + rw [hplanCandidate] + simp only [executeCandidate?] + unfold probe + simp only [StateT.run_liftM] + unfold LazyRevealProbe.probeQuery + simp only [pure_bind, bind_assoc] + rw [runDirectResolvedWitnessFromTable_probe_query_bind] + simp [finishDirectPrivateOrdinalSelection]) + exact relTriple_pure_none_rootSelectionBridge target leftOutput rightRoot + ordinal _ + · have hsafeActual : ¬RootAwareCandidateAvoidsRoots target + (truncateHash leftOutput) rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input left.state)) := by + simpa [plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + cases hcandidate : candidate? with + | none => + exfalso + apply hsafe + simp [RootAwareCandidateAvoidsRoots, hcandidate] + | some candidate => + have hunsafe : ¬candidate.AvoidsRoots target + (truncateHash leftOutput) rightRoot := by + rw [← rootAwareCandidateAvoidsRoots_iff] + simpa [hcandidate] using hsafe + let leftRun : ProbComp (Option PrivateOrdinalSelection) := + runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache) >>= + finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (fun nextContext remaining value laterCandidates => + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter + publicRoot ftsSecret (next value.1) laterCandidates nextContext + remaining table value.2)) + nextCandidates + have hzeroBridge : RelTriple leftRun + (pure (.finished none) : ProbComp MaterializedSelectionOutcome) + (RootSelectionBridgeRel target leftOutput rightRoot ordinal) := by + apply relTriple_finished_none_of_no_good target leftOutput rightRoot + ordinal leftRun + intro output houtput hgood + cases output with + | none => exact hgood + | some selection => + have hbranchExtends : + PrivateOrdinalSelectionExtends nextCandidates + (some selection) := by + unfold leftRun at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + apply privateOrdinalSelectionExtends_of_mem_finish _ nextCandidates + result (output := some selection) (houtput := hfinish) + intro resolved nextOutput heq hnextOutput + subst result + apply privateOrdinalSelectionExtends_of_mem_canonicalize table _ + resolved.context resolved.remaining resolved.value nextCandidates + (output := nextOutput) (houtput := hnextOutput) + intro nextContext finalOutput hfinalOutput + exact privateOrdinalSelectionExtends_of_mem_direct ordinal parameter + publicRoot ftsSecret (next resolved.value.1) nextCandidates + nextContext resolved.remaining table resolved.value.2 finalOutput + hfinalOutput + apply not_goodForRoots_of_unsafe_prefix (candidate := candidate) + hgood hbranchExtends (by omega) + · simp [nextCandidates, appendPlannedCandidate, hcandidate] + · exact hunsafe + dsimp [leftRun, plan, nextCandidates] at hzeroBridge + unfold directDetailedBoundaryPrivateOrdinalSelection at hzeroBridge + exact hzeroBridge + | inr message => + change Option Signature → OracleComp (OracleWorld + SigningSpec) α at next + let leftObserve : DeferredContext → Nat → + (Option Signature × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection) := + fun nextContext remaining value laterCandidates => + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter publicRoot + ftsSecret (next value.1) laterCandidates nextContext remaining table value.2 + let rightObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → ProbComp MaterializedSelectionOutcome := + fun nextState remaining output nextCache laterCandidates => + materializedActualRootAvoidingOrdinalSelectionOutcome ordinal parameter publicRoot + target (truncateHash leftOutput) rightRoot ftsSecret (next output) + laterCandidates nextState remaining table nextCache + rw [hrightMaterialized] + change RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((maskedSign parameter publicRoot ftsSecret message).run leftCache) >>= + finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table leftObserve) candidates) + (runDirectResolvedDetailedFromTable (directDeferredContext right.state) rightFuel + table ((maskedSign parameter publicRoot ftsSecret message).run rightCache) >>= + finishMaterializedSelectionOutcome target table rightObserve candidates) + (RootSelectionBridgeRel target leftOutput rightRoot ordinal) + have hsign := relTriple_rootSelection_sign_step target leftOutput rightRoot ordinal + table parameter publicRoot ftsSecret message leftObserve rightObserve candidates left + right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed hvalues + hpublished hrightMaterialized (by + intro nextLeft nextRight hnext hnextCanonical + rw [← hnext.value_eq] + simpa [leftObserve, rightObserve] using + (ih nextLeft.value.1 candidates nextLeft.context nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 + hnext.context_le hnext.remaining_le hnext.cache_eq hnext.revealed_eq + hnext.values_le hnext.left_published hnext.right_materialized hnextCanonical + hprefix)) + rw [hrightMaterialized] at hsign + exact hsign + +theorem relTriple_directRootSelection_materializedShadow + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftOutput : HashOutput) (rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hpublished : PublishedValues context.state) + (hcanonical : CanonicalMaterializedValues table context) + (hprefix : CandidatesAvoidRoots target (truncateHash leftOutput) rightRoot candidates) : + RelTriple + (directDetailedBoundaryPrivateOrdinalSelection ordinal parameter publicRoot ftsSecret + computation candidates context fuel table cache) + (materializedActualRootAvoidingOrdinalSelectionOutcome ordinal parameter publicRoot target + (truncateHash leftOutput) rightRoot ftsSecret computation candidates + (materializedDeferredState context) fuel table cache) + (RootSelectionBridgeRel target leftOutput rightRoot ordinal) := by + let right := materializedDeferredContext context + have hcontext := finalizationContextLE_materializedDeferredContext hvalid hcompletable + apply relTriple_directRootSelection_materializedOutcome ordinal parameter publicRoot target + leftOutput rightRoot ftsSecret computation candidates context right fuel fuel table cache cache + hcontext le_rfl rfl + · rfl + · exact valuesLE_materializedDeferredState context + · exact hpublished + · rfl + · exact hcanonical + · exact hprefix + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionMaterialize.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionMaterialize.lean new file mode 100644 index 00000000..25b2aa60 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionMaterialize.lean @@ -0,0 +1,219 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryOrdinarySigner +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionSigner + +/-! +# Materialized shadow of a deferred boundary + +Only structural outputs already present in `DeferredContext.values` are copied into the shadow +state. No missing output is sampled. The shadow therefore gives the existing directional signer +coupling a fully materialized right context while preserving the completed value at every +coordinate. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +def materializedDeferredState (context : DeferredContext) : + LazyRevealProbe.State Coordinate := + { context.state with + values := fun coordinate => + match coordinate with + | .chainStart lay tree leafIdx chainIdx => + context.state.values (.chainStart lay tree leafIdx chainIdx) + | .position position => context.positionValue position } + +def materializedDeferredContext (context : DeferredContext) : DeferredContext := + directDeferredContext (materializedDeferredState context) + +@[simp] theorem materializedDeferredState_pending (context : DeferredContext) : + (materializedDeferredState context).pending = context.state.pending := rfl + +@[simp] theorem materializedDeferredState_revealed (context : DeferredContext) : + (materializedDeferredState context).revealed = context.state.revealed := rfl + +@[simp] theorem materializedDeferredState_ensured (context : DeferredContext) : + (materializedDeferredState context).ensured = context.state.ensured := rfl + +@[simp] theorem materializedDeferredState_chainStart + (context : DeferredContext) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + (materializedDeferredState context).values + (.chainStart lay tree leafIdx chainIdx) = + context.state.values (.chainStart lay tree leafIdx chainIdx) := rfl + +@[simp] theorem materializedDeferredState_position + (context : DeferredContext) (position : Position) : + (materializedDeferredState context).values (.position position) = + context.positionValue position := rfl + +theorem resolvedCompletionValue_materializedDeferredContext + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) : + resolvedCompletionValue table (materializedDeferredContext context) = + resolvedCompletionValue table context := by + funext coordinate + cases coordinate with + | chainStart lay tree leafIdx chainIdx => rfl + | position position => + change (match context.positionValue position with + | some output => some output + | none => context.positionValue position) = context.positionValue position + cases context.positionValue position <;> rfl + +theorem valuesLE_materializedDeferredState (context : DeferredContext) : + LazyRevealProbe.ValuesLE context.state (materializedDeferredState context) := by + intro coordinate output hvalue + cases coordinate with + | chainStart lay tree leafIdx chainIdx => exact hvalue + | position position => + simp only [materializedDeferredState_position] + simp [DeferredContext.positionValue, hvalue] + +theorem clean_of_deferredCompletion + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hcompletion : DeferredCompletion table context completion) : + ∀ coordinate output, + resolvedCompletionValue table context coordinate = some output → + ¬context.state.hitAt coordinate output := by + intro coordinate output hvalue hhit + have hcompletionValue := hcompletion.eq_resolvedCompletionValue coordinate output hvalue + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + exact hcompletion.2.2.1 coordinate (truncateHash output) hhit + (by rw [hcompletionValue]) + +theorem deferredCompletion_materializedDeferredContext + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hcompletion : DeferredCompletion table context completion) : + DeferredCompletion table (materializedDeferredContext context) completion := by + refine ⟨?_, ?_, ?_, hcompletion.2.2.2⟩ + · intro coordinate output hvalue + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + apply hcompletion.1 (.chainStart lay tree leafIdx chainIdx) output + exact hvalue + | position position => + have hresolved : resolvedCompletionValue table context (.position position) = + some output := by + simpa [materializedDeferredContext, directDeferredContext, + materializedDeferredState, resolvedCompletionValue] using hvalue + exact hcompletion.eq_resolvedCompletionValue (.position position) output hresolved + · intro position output hvalue + have hresolved : resolvedCompletionValue table context (.position position) = + some output := by + simpa [materializedDeferredContext, directDeferredContext, directDeferredValues, + materializedDeferredState, resolvedCompletionValue] using hvalue + exact hcompletion.eq_resolvedCompletionValue (.position position) output hresolved + · intro coordinate candidate hmember + exact hcompletion.2.2.1 coordinate candidate hmember + +theorem valid_materializedDeferredContext + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + (materializedDeferredContext context).Valid := by + obtain ⟨completion, hcompletion⟩ := hcompletable + refine ⟨?_, ?_⟩ + · intro position output hvalue + exact hvalue + · intro coordinate output hvalue + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + apply hvalid.2 (.chainStart lay tree leafIdx chainIdx) output + simpa [materializedDeferredContext, directDeferredContext, + materializedDeferredState] using hvalue + | position position => + apply clean_of_deferredCompletion hcompletion (.position position) output + simpa [materializedDeferredContext, directDeferredContext, + materializedDeferredState, resolvedCompletionValue] using hvalue + +theorem finalizationContextLE_materializedDeferredContext + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + FinalizationContextLE table context (materializedDeferredContext context) := by + obtain ⟨completion, hcompletion⟩ := hcompletable + have hclean := clean_of_deferredCompletion hcompletion + refine + { view := + { leftConsistent := hvalid.valuesConsistent + rightConsistent := + (valid_materializedDeferredContext hvalid ⟨completion, hcompletion⟩).valuesConsistent + leftStarts := ?_ + rightStarts := ?_ + valueEq := resolvedCompletionValue_materializedDeferredContext table context |>.symm + leftClean := hclean + rightClean := ?_ + pendingLE := ?_ } + leftValid := hvalid + rightValid := valid_materializedDeferredContext hvalid ⟨completion, hcompletion⟩ + rightCompletable := + ⟨completion, deferredCompletion_materializedDeferredContext hcompletion⟩ } + · intro index output hvalue + exact (hcompletion.1 index.coordinate output hvalue).symm.trans + (hcompletion.2.2.2 index) + · intro index output hvalue + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + have hleftValue : context.state.values (.chainStart lay tree leafIdx chainIdx) = + some output := by + simpa [materializedDeferredContext, directDeferredContext, + materializedDeferredState, OtsSecretIndex.coordinate] using hvalue + exact (hcompletion.1 (.chainStart lay tree leafIdx chainIdx) output hleftValue).symm.trans + (hcompletion.2.2.2 + (⟨lay, tree, leafIdx, chainIdx⟩ : OtsSecretIndex)) + · intro coordinate output hvalue + apply clean_of_deferredCompletion + (deferredCompletion_materializedDeferredContext hcompletion) coordinate output hvalue + · intro coordinate _hvalue candidate hcandidate + exact hcandidate + +theorem RootDeferredContextRel.materialized + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : DeferredContext} + (hrel : RootDeferredContextRel target leftOutput rightOutput left right) : + RootMaterializedContextRel target leftOutput rightOutput + (materializedDeferredContext left) (materializedDeferredContext right) := by + have hstate : RootHiddenStateRel target leftOutput rightOutput + (materializedDeferredState left) (materializedDeferredState right) := by + refine ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · simp [hrel.state] + · simp [hrel.state] + · simp [hrel.state] + · simpa using hrel.target_private + · simp [hrel.positionValue_target.1] + · simp [hrel.positionValue_target.2] + · intro coordinate hne + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simpa [materializedDeferredState] using congrArg + (fun state => state.values (.chainStart lay tree leafIdx chainIdx)) hrel.state + | position position => + have hposition : position ≠ target := by + intro heq + apply hne + rw [heq] + exact hrel.positionValue_other position hposition + refine ⟨hstate, ?_, ?_, ?_⟩ + · simp [materializedDeferredContext, directDeferredContext, + directDeferredValues, hrel.positionValue_target.1] + · simp [materializedDeferredContext, directDeferredContext, + directDeferredValues, hrel.positionValue_target.2] + · intro position hne + simp only [materializedDeferredContext, directDeferredContext, + directDeferredValues, materializedDeferredState_position] + exact hrel.positionValue_other position hne + +theorem RootHiddenStateRel.directContext + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : RootHiddenStateRel target leftOutput rightOutput left right) : + RootMaterializedContextRel target leftOutput rightOutput + (directDeferredContext left) (directDeferredContext right) := by + refine ⟨hrel, ?_, ?_, ?_⟩ + · simpa [directDeferredContext, directDeferredValues] using hrel.left_target + · simpa [directDeferredContext, directDeferredValues] using hrel.right_target + · intro position hne + apply hrel.other_values (.position position) + simpa using hne + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionMaterialized.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionMaterialized.lean new file mode 100644 index 00000000..065a2d07 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionMaterialized.lean @@ -0,0 +1,309 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionMaterialize + +/-! +# Materialized root-avoiding ordinal prefix + +The auxiliary prefix executes against the already materialized shadow but derives every planned +candidate from its canonical public view. Before the selected ordinal it stops if a candidate +guesses either distinguished root. On the surviving branch every direct query satisfies the cache +quotient's safe-input premise. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +noncomputable def materializedCanonicalContext + (table : OtsSecretIndex → HashOutput) + (state : LazyRevealProbe.State Coordinate) : DeferredContext := + canonicalizeMaterializedValues table (directDeferredContext state) + +theorem materializedCanonicalContext_state_eq_of_rootHidden + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : RootHiddenStateRel target leftOutput rightOutput left right) + (table : OtsSecretIndex → HashOutput) : + (materializedCanonicalContext table left).state = + (materializedCanonicalContext table right).state := by + exact (hrel.directContext.canonicalize table).state + +def RootSafePlannedHash + (target : Position) (leftRoot rightRoot : Digest) + (plan : PlannedHashQuery) (candidate? : Option Probe) : Prop := + RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? ∧ + plan.action ≠ .resolve (.position target) + +theorem rootSafePlannedHash_swap + (target : Position) (leftRoot rightRoot : Digest) + (plan : PlannedHashQuery) (candidate? : Option Probe) : + RootSafePlannedHash target leftRoot rightRoot plan candidate? ↔ + RootSafePlannedHash target rightRoot leftRoot plan candidate? := by + constructor + · rintro ⟨⟨hleft, hright⟩, haction⟩ + exact ⟨⟨hright, hleft⟩, haction⟩ + · rintro ⟨⟨hright, hleft⟩, haction⟩ + exact ⟨⟨hleft, hright⟩, haction⟩ + +theorem rootAwareCandidateAvoidsRoots_swap + (target : Position) (leftRoot rightRoot : Digest) (candidate? : Option Probe) : + RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? ↔ + RootAwareCandidateAvoidsRoots target rightRoot leftRoot candidate? := by + constructor + · intro h + exact ⟨h.2, h.1⟩ + · intro h + exact ⟨h.2, h.1⟩ + +noncomputable def purePeekPositionValues + (state : LazyRevealProbe.State Coordinate) : List Position → Option (List Digest) + | [] => some [] + | position :: remaining => + match truncateHash <$> state.values (.position position) with + | none => none + | some value => + match purePeekPositionValues state remaining with + | none => none + | some values => some (value :: values) + +noncomputable def purePeekTableInput + (parameter : PublicParameter) (state : LazyRevealProbe.State Coordinate) : + Coordinate → Option HashInput + | .chainStart _ _ _ _ => none + | .position position@(.chain lay tree leafIdx chainIdx step) => + if step.val = 0 then + match truncateHash <$> state.values (.chainStart lay tree leafIdx chainIdx) with + | none => none + | some value => some (tweakableHashInput parameter position.domain (digestBytes value)) + else + match purePeekPositionValues state position.children with + | none => none + | some values => some (tweakableHashInput parameter position.domain + (values.flatMap digestBytes)) + | .position position => + match purePeekPositionValues state position.children with + | none => none + | some values => some (tweakableHashInput parameter position.domain + (values.flatMap digestBytes)) + +noncomputable def resolvePublicKnownInput + (parameter : PublicParameter) (publicState : LazyRevealProbe.State Coordinate) + (coordinate : Coordinate) (input : HashInput) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput := + match purePeekTableInput parameter publicState coordinate with + | some knownInput => + if knownInput = input then do + let output ← revealCoordinateOutput coordinate + publishCoordinate coordinate + modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output) + pure output + else splitHashQuery (.ordinary input) + | none => splitHashQuery (.ordinary input) + +noncomputable def probingHashQueryAfterPublicPlan + (parameter : PublicParameter) (input : HashInput) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput := do + executeCandidate? plan.candidate? + match plan.action with + | .ordinary => splitHashQuery (.ordinary input) + | .resolve coordinate => resolvePublicKnownInput parameter publicState coordinate input + +noncomputable def finishMaterializedPrivateOrdinalSelection + (observe : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp (Option Probe)) + (candidates : List Probe) : + Option (CleanRunResult (α × SplitHashCache)) → ProbComp (Option Probe) + | none => pure none + | some result => + observe result.state result.remaining result.value.1 result.value.2 candidates + +noncomputable def continueMaterializedPrivateOrdinalSelection + (target : Position) + (observe : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp (Option Probe)) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (value : α) (cache : SplitHashCache) (candidates : List Probe) : + ProbComp (Option Probe) := + if Coordinate.position target ∈ state.revealed then pure none + else observe state fuel value cache candidates + +noncomputable def materializedRootAvoidingOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (signer : Message → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option Probe) := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + List Probe → LazyRevealProbe.State Coordinate → Nat → + (OtsSecretIndex → HashOutput) → SplitHashCache → ProbComp (Option Probe)) + (fun _value candidates state _fuel _table _cache => + if hselected : ordinal < candidates.length then + pure (some (candidates.get ⟨ordinal, hselected⟩)) + else pure none) + (fun query _next recursivelyRun candidates state fuel table cache => + if hselected : ordinal < candidates.length then + pure (some (candidates.get ⟨ordinal, hselected⟩)) + else + match query with + | .inl (.inl n) => + runCleanFromTable state fuel table ((splitUniformImpl n).run cache) >>= + finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache)) + candidates + | .inl (.inr input) => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + if hnextSelected : ordinal < nextCandidates.length then + pure (some (nextCandidates.get ⟨ordinal, hnextSelected⟩)) + else if RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? then + runCleanFromTable state fuel table + ((probingHashQueryAfterPublicPlan parameter input publicContext.state plan).run + cache) >>= + finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache)) + nextCandidates + else pure none + | .inr message => + runCleanFromTable state fuel table ((signer message).run cache) >>= + finishMaterializedPrivateOrdinalSelection + (continueMaterializedPrivateOrdinalSelection target + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache)) + candidates) + computation candidates state fuel table cache + +noncomputable def materializedActualRootAvoidingOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option Probe) := + materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot rightRoot + (maskedSign parameter publicRoot ftsSecret) computation candidates state fuel table cache + +noncomputable def materializedComparisonRootAvoidingOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftOutput rightOutput : HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp (Option Probe) := + materializedRootAvoidingOrdinalSelection ordinal parameter target + (truncateHash leftOutput) (truncateHash rightOutput) + (maskedSignWithTargetComparison parameter publicRoot target (truncateHash rightOutput) + ftsSecret) + computation candidates state fuel table cache + +set_option maxRecDepth 100000 in +theorem materializedRootAvoidingOrdinalSelection_swap_roots + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (signer : Message → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot rightRoot signer + computation candidates state fuel table cache = + materializedRootAvoidingOrdinalSelection ordinal parameter target rightRoot leftRoot signer + computation candidates state fuel table cache := by + induction computation using OracleComp.inductionOn generalizing + candidates state fuel cache with + | pure value => + simp [materializedRootAvoidingOrdinalSelection] + | query_bind query next ih => + rw [materializedRootAvoidingOrdinalSelection, OracleComp.construct_query_bind, + materializedRootAvoidingOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp [hselected] + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + apply bind_congr + intro result + cases result with + | none => rfl + | some result => + unfold finishMaterializedPrivateOrdinalSelection + unfold continueMaterializedPrivateOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ result.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact ih result.value.1 candidates result.state result.remaining + result.value.2 + | inr input => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp [hactual] + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + have hsafe := rootAwareCandidateAvoidsRoots_swap target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) + rw [propext hsafe] + by_cases hholds : RootAwareCandidateAvoidsRoots target rightRoot leftRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) + · simp only [hholds, ↓reduceIte] + apply bind_congr + intro result + cases result with + | none => rfl + | some result => + unfold finishMaterializedPrivateOrdinalSelection + unfold continueMaterializedPrivateOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ result.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact ih result.value.1 nextCandidates result.state result.remaining + result.value.2 + · simp [hholds] + | inr message => + apply bind_congr + intro result + cases result with + | none => rfl + | some result => + unfold finishMaterializedPrivateOrdinalSelection + unfold continueMaterializedPrivateOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ result.state.revealed + · simp [hrevealed] + · simp only [hrevealed, ↓reduceIte] + exact ih result.value.1 candidates result.state result.remaining result.value.2 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionOutcome.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionOutcome.lean new file mode 100644 index 00000000..12a83669 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionOutcome.lean @@ -0,0 +1,546 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionDeferred +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryOrdinaryAdaptive + +/-! +# Materialized selection outcome + +The materialized prefix retains stopped and non-completable executions as one explicit failure +marker. Clean executions return the selected candidate, if the fixed ordinal was reached. This is +the codomain used by the one-sided adaptive bridge. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +inductive MaterializedSelectionOutcome where + | failed + | finished (selection : Option Probe) +deriving DecidableEq + +def MaterializedSelectionOutcome.toOption : MaterializedSelectionOutcome → Option Probe + | .failed => none + | .finished selection => selection + +def MaterializedSelectionOutcome.isFailure : MaterializedSelectionOutcome → Prop + | .failed => True + | .finished _ => False + +def MaterializedSelectionOutcome.Matches + (target : Position) (root : Digest) : MaterializedSelectionOutcome → Prop + | .failed => False + | .finished selection => materializedOrdinalSelectionMatches target root selection + +def MaterializedOutcomeOptionRel + (target : Position) (root : Digest) : + MaterializedSelectionOutcome → Option Probe → Prop := + fun outcome selection => + outcome.Matches target root → + materializedOrdinalSelectionMatches target root selection + +def RootSelectionBridgeRel + (target : Position) (leftOutput : HashOutput) + (rightRoot : Digest) (ordinal : Nat) : + Option PrivateOrdinalSelection → MaterializedSelectionOutcome → Prop := + fun left right => + privateOrdinalSelectionGoodForRoots target leftOutput rightRoot ordinal left → + right.isFailure ∨ right.Matches target (truncateHash leftOutput) + +theorem rootSelectionBridgeRel_none_left + (target : Position) (leftOutput : HashOutput) + (rightRoot : Digest) (ordinal : Nat) + (right : MaterializedSelectionOutcome) : + RootSelectionBridgeRel target leftOutput rightRoot ordinal none right := by + intro hgood + exact False.elim hgood + +theorem rootSelectionBridgeRel_failed_right + (target : Position) (leftOutput : HashOutput) + (rightRoot : Digest) (ordinal : Nat) + (left : Option PrivateOrdinalSelection) : + RootSelectionBridgeRel target leftOutput rightRoot ordinal left .failed := by + intro _hgood + exact Or.inl trivial + +theorem relTriple_pure_none_rootSelectionBridge + (target : Position) (leftOutput : HashOutput) + (rightRoot : Digest) (ordinal : Nat) + (right : ProbComp MaterializedSelectionOutcome) : + RelTriple (pure none : ProbComp (Option PrivateOrdinalSelection)) right + (RootSelectionBridgeRel target leftOutput rightRoot ordinal) := by + have hbase := relTriple_true + (pure none : ProbComp (Option PrivateOrdinalSelection)) right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun value => value = none) (by + intro value hvalue + simpa using hvalue) + apply relTriple_post_mono hsupported + intro leftValue rightValue hrelation + rw [hrelation.2] + exact rootSelectionBridgeRel_none_left target leftOutput rightRoot ordinal rightValue + +theorem relTriple_any_failed_rootSelectionBridge + (target : Position) (leftOutput : HashOutput) + (rightRoot : Digest) (ordinal : Nat) + (left : ProbComp (Option PrivateOrdinalSelection)) : + RelTriple left (pure .failed : ProbComp MaterializedSelectionOutcome) + (RootSelectionBridgeRel target leftOutput rightRoot ordinal) := by + have hbase := relTriple_true left + (pure .failed : ProbComp MaterializedSelectionOutcome) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + apply relTriple_post_mono hsupported + intro leftValue rightValue hrelation + have hright : rightValue = .failed := by simpa using hrelation.2 + subst rightValue + exact rootSelectionBridgeRel_failed_right target leftOutput rightRoot ordinal leftValue + +theorem relTriple_finished_none_of_no_good + (target : Position) (leftOutput : HashOutput) + (rightRoot : Digest) (ordinal : Nat) + (left : ProbComp (Option PrivateOrdinalSelection)) + (hnotGood : ∀ output ∈ support left, + ¬privateOrdinalSelectionGoodForRoots target leftOutput rightRoot ordinal output) : + RelTriple left (pure (.finished none) : ProbComp MaterializedSelectionOutcome) + (RootSelectionBridgeRel target leftOutput rightRoot ordinal) := by + have hbase := relTriple_true left + (pure (.finished none) : ProbComp MaterializedSelectionOutcome) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun output => output ∈ support left) (fun output houtput => houtput) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro leftValue rightValue hrelation hgood + exact False.elim (hnotGood leftValue hrelation.1.2 hgood) + +theorem probEvent_goodSelection_le_failure_add_match + (target : Position) (leftOutput : HashOutput) + (rightRoot : Digest) (ordinal : Nat) + (left : ProbComp (Option PrivateOrdinalSelection)) + (right : ProbComp MaterializedSelectionOutcome) + (hrel : RelTriple left right + (RootSelectionBridgeRel target leftOutput rightRoot ordinal)) : + Pr[privateOrdinalSelectionGoodForRoots target leftOutput rightRoot ordinal | left] ≤ + Pr[MaterializedSelectionOutcome.isFailure | right] + + Pr[fun outcome => outcome.Matches target (truncateHash leftOutput) | right] := by + calc + _ ≤ Pr[fun outcome => outcome.isFailure ∨ + outcome.Matches target (truncateHash leftOutput) | right] := + probEvent_le_of_relTriple hrel (fun leftValue rightValue hrelation hgood => + hrelation hgood) + _ ≤ _ := probEvent_or_le _ _ _ + +theorem probEvent_outcome_match_le_option_match + (target : Position) (root : Digest) + (outcome : ProbComp MaterializedSelectionOutcome) + (selection : ProbComp (Option Probe)) + (hrel : RelTriple outcome selection (MaterializedOutcomeOptionRel target root)) : + Pr[fun result => result.Matches target root | outcome] ≤ + Pr[materializedOrdinalSelectionMatches target root | selection] := + probEvent_le_of_relTriple hrel (fun _ _ hrelation => hrelation) + +theorem relTriple_failed_any_option + (target : Position) (root : Digest) (right : ProbComp (Option Probe)) : + RelTriple (pure .failed : ProbComp MaterializedSelectionOutcome) right + (MaterializedOutcomeOptionRel target root) := by + have hbase := relTriple_true + (pure .failed : ProbComp MaterializedSelectionOutcome) right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun outcome => outcome = .failed) (by + intro outcome houtput + simpa using houtput) + apply relTriple_post_mono hsupported + intro outcome selection hrelation hmatch + rw [hrelation.2] at hmatch + exact False.elim hmatch + +noncomputable def guardPrivateOrdinalSelection + (target : Position) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) : + ProbComp (Option PrivateOrdinalSelection) := + if Coordinate.position target ∈ context.state.revealed then pure none + else observe context fuel value candidates + +noncomputable def finishMaterializedSelectionOutcome + (target : Position) (table : OtsSecretIndex → HashOutput) + (observe : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp MaterializedSelectionOutcome) + (candidates : List Probe) : + DirectDetailedResult (α × SplitHashCache) → ProbComp MaterializedSelectionOutcome := by + classical + exact fun result => match result with + | .stopped _ => pure .failed + | .done result => + if DeferredCompletable table (directDeferredContext result.context.state) then + if Coordinate.position target ∈ result.context.state.revealed then + pure .failed + else observe result.context.state result.remaining result.value.1 result.value.2 candidates + else pure .failed + +theorem relTriple_finishMaterializedOutcome_option + (target : Position) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (outcomeObserve : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp MaterializedSelectionOutcome) + (optionObserve : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp (Option Probe)) + (candidates : List Probe) + (result : DirectDetailedResult (α × SplitHashCache)) + (hrecursive : ∀ resolved : ResolvedRunResult (α × SplitHashCache), + DeferredCompletable table (directDeferredContext resolved.context.state) → + Coordinate.position target ∉ resolved.context.state.revealed → + RelTriple + (outcomeObserve resolved.context.state resolved.remaining resolved.value.1 + resolved.value.2 candidates) + (optionObserve resolved.context.state resolved.remaining resolved.value.1 + resolved.value.2 candidates) + (MaterializedOutcomeOptionRel target root)) : + RelTriple + (finishMaterializedSelectionOutcome target table outcomeObserve candidates result) + (finishDirectDetailedMaterializedSelection target optionObserve candidates result) + (MaterializedOutcomeOptionRel target root) := by + cases result with + | stopped reason => + apply relTriple_pure_pure + intro hmatch + exact False.elim hmatch + | done resolved => + unfold finishMaterializedSelectionOutcome finishDirectDetailedMaterializedSelection + by_cases hcompletable : + DeferredCompletable table (directDeferredContext resolved.context.state) + · simp only [hcompletable, ↓reduceIte] + by_cases hrevealed : Coordinate.position target ∈ resolved.context.state.revealed + · simp [continueMaterializedPrivateOrdinalSelection, hrevealed, + MaterializedOutcomeOptionRel, MaterializedSelectionOutcome.Matches] + · rw [if_neg hrevealed] + rw [show continueMaterializedPrivateOrdinalSelection target optionObserve + resolved.context.state resolved.remaining resolved.value.1 resolved.value.2 + candidates = optionObserve resolved.context.state resolved.remaining + resolved.value.1 resolved.value.2 candidates by + simp [continueMaterializedPrivateOrdinalSelection, hrevealed]] + exact hrecursive resolved hcompletable hrevealed + · simp only [hcompletable, ↓reduceIte] + by_cases hrevealed : Coordinate.position target ∈ resolved.context.state.revealed + · simp [continueMaterializedPrivateOrdinalSelection, hrevealed, + MaterializedOutcomeOptionRel, MaterializedSelectionOutcome.Matches] + · rw [show continueMaterializedPrivateOrdinalSelection target optionObserve + resolved.context.state resolved.remaining resolved.value.1 resolved.value.2 + candidates = optionObserve resolved.context.state resolved.remaining + resolved.value.1 resolved.value.2 candidates by + simp [continueMaterializedPrivateOrdinalSelection, hrevealed]] + exact relTriple_failed_any_option target root _ + +set_option maxRecDepth 100000 in +theorem relTriple_finishRootSelectionBridge + (target : Position) (leftOutput : HashOutput) (rightRoot : Digest) + (ordinal : Nat) (table : OtsSecretIndex → HashOutput) + (leftObserve : DeferredContext → Nat → (α × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (rightObserve : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp MaterializedSelectionOutcome) + (candidates : List Probe) + (leftResult rightResult : DirectDetailedResult (α × SplitHashCache)) + (hrelation : DirectDetailedOrdinaryStableRunEq table leftResult rightResult) + (hrecursive : ∀ originalLeft originalRight left right, + leftResult = .done originalLeft → rightResult = .done originalRight → + OrdinaryMaterializedRunEq table left right → + CanonicalMaterializedValues table left.context → + RelTriple + (leftObserve left.context left.remaining left.value candidates) + (rightObserve right.context.state right.remaining right.value.1 right.value.2 candidates) + (RootSelectionBridgeRel target leftOutput rightRoot ordinal)) : + RelTriple + (finishDirectDetailedPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table leftObserve) candidates leftResult) + (finishMaterializedSelectionOutcome target table rightObserve candidates rightResult) + (RootSelectionBridgeRel target leftOutput rightRoot ordinal) := by + cases leftResult with + | stopped leftReason => + exact relTriple_pure_none_rootSelectionBridge target leftOutput rightRoot ordinal _ + | done left => + cases rightResult with + | stopped rightReason => + exact relTriple_any_failed_rootSelectionBridge target leftOutput rightRoot ordinal _ + | done right => + rcases hrelation with hclean | hdoomed + · have hcanonical := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table left.context + have hleftCompletable : DeferredCompletable table canonical := + hcanonical.context_le.leftCompletable + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hrightCompletable : + DeferredCompletable table (directDeferredContext right.context.state) := by + rw [← hclean.right_materialized] + exact hclean.context_le.rightCompletable + unfold finishDirectDetailedPrivateOrdinalSelection + finishMaterializedSelectionOutcome + unfold canonicalizeDirectPrivateOrdinalSelection + simp only [canonical, hnotPrivate, ↓reduceIte, hclean.left_published, ↓reduceIte, + hleftCompletable, hrightCompletable] + have hrevealed : canonical.state.revealed = right.context.state.revealed := by + exact hcanonical.revealed_eq + by_cases htargetRevealed : Coordinate.position target ∈ canonical.state.revealed + · have hrightRevealed : + Coordinate.position target ∈ right.context.state.revealed := by + rw [← hrevealed] + exact htargetRevealed + simp only [hrightRevealed, ↓reduceIte] + exact relTriple_any_failed_rootSelectionBridge target leftOutput rightRoot ordinal _ + · have hrightRevealed : + Coordinate.position target ∉ right.context.state.revealed := by + intro hmem + exact htargetRevealed (by rwa [hrevealed]) + simp only [hrightRevealed, ↓reduceIte] + have hcanonicalValues : CanonicalMaterializedValues table canonical := + canonicalizeMaterializedValues_canonical table left.context + hclean.context_le.view.leftConsistent + exact hrecursive + left right { left with context := canonical } right rfl rfl hcanonical + hcanonicalValues + · unfold finishMaterializedSelectionOutcome + have hnotCompletable : + ¬DeferredCompletable table (directDeferredContext right.context.state) := by + rw [← hdoomed.2] + exact hdoomed.1.2.2.2 + simp only [hnotCompletable, ↓reduceIte] + exact relTriple_any_failed_rootSelectionBridge target leftOutput rightRoot ordinal _ + +set_option maxRecDepth 100000 in +theorem relTriple_rootSelection_uniform_step + (target : Position) (leftOutput : HashOutput) (rightRoot : Digest) + (ordinal : Nat) (table : OtsSecretIndex → HashOutput) (n : Nat) + (leftObserve : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (rightObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → ProbComp MaterializedSelectionOutcome) + (candidates : List Probe) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hrecursive : ∀ nextLeft nextRight, + OrdinaryMaterializedRunEq table nextLeft nextRight → + CanonicalMaterializedValues table nextLeft.context → + RelTriple + (leftObserve nextLeft.context nextLeft.remaining nextLeft.value candidates) + (rightObserve nextRight.context.state nextRight.remaining nextRight.value.1 + nextRight.value.2 candidates) + (RootSelectionBridgeRel target leftOutput rightRoot ordinal)) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((splitUniformImpl n).run leftCache) >>= + finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table leftObserve) candidates) + (runDirectResolvedDetailedFromTable right rightFuel table + ((splitUniformImpl n).run rightCache) >>= + finishMaterializedSelectionOutcome target table rightObserve candidates) + (RootSelectionBridgeRel target leftOutput rightRoot ordinal) := by + apply relTriple_of_evalDist_eq_left + (evalDist_runWitnessSelection_eq_detailed + (canonicalizeDirectPrivateOrdinalSelection table leftObserve) candidates left leftFuel table + ((splitUniformImpl n).run leftCache)) + apply relTriple_bind + ((ordinaryMaterializedStableCouples_splitUniformImpl table n).toBetween + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed hvalues + hpublished hrightMaterialized) + intro leftResult rightResult hrelation + exact relTriple_finishRootSelectionBridge target leftOutput rightRoot ordinal table leftObserve + rightObserve candidates leftResult rightResult hrelation + (fun originalLeft originalRight nextLeft nextRight _ _ hnext hcanonical => + hrecursive nextLeft nextRight hnext hcanonical) + +set_option maxRecDepth 100000 in +theorem relTriple_rootSelection_sign_step + (target : Position) (leftOutput : HashOutput) (rightRoot : Digest) + (ordinal : Nat) (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (publicRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (leftObserve : DeferredContext → Nat → + (Option Signature × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (rightObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → ProbComp MaterializedSelectionOutcome) + (candidates : List Probe) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hrecursive : ∀ nextLeft nextRight, + OrdinaryMaterializedRunEq table nextLeft nextRight → + CanonicalMaterializedValues table nextLeft.context → + RelTriple + (leftObserve nextLeft.context nextLeft.remaining nextLeft.value candidates) + (rightObserve nextRight.context.state nextRight.remaining nextRight.value.1 + nextRight.value.2 candidates) + (RootSelectionBridgeRel target leftOutput rightRoot ordinal)) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((maskedSign parameter publicRoot ftsSecret message).run leftCache) >>= + finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table leftObserve) candidates) + (runDirectResolvedDetailedFromTable right rightFuel table + ((maskedSign parameter publicRoot ftsSecret message).run rightCache) >>= + finishMaterializedSelectionOutcome target table rightObserve candidates) + (RootSelectionBridgeRel target leftOutput rightRoot ordinal) := by + apply relTriple_of_evalDist_eq_left + (evalDist_runWitnessSelection_eq_detailed + (canonicalizeDirectPrivateOrdinalSelection table leftObserve) candidates left leftFuel table + ((maskedSign parameter publicRoot ftsSecret message).run leftCache)) + apply relTriple_bind + ((ordinaryMaterializedStableCouples_maskedSign table parameter publicRoot ftsSecret message).toBetween + left right leftFuel rightFuel leftCache rightCache hcontext hfuel hcache hrevealed hvalues + hpublished hrightMaterialized) + intro leftResult rightResult hrelation + exact relTriple_finishRootSelectionBridge target leftOutput rightRoot ordinal table leftObserve + rightObserve candidates leftResult rightResult hrelation + (fun originalLeft originalRight nextLeft nextRight _ _ hnext hcanonical => + hrecursive nextLeft nextRight hnext hcanonical) + +set_option maxRecDepth 100000 in +theorem relTriple_rootSelection_hash_step + (target : Position) (leftOutput : HashOutput) (rightRoot : Digest) + (ordinal : Nat) (table : OtsSecretIndex → HashOutput) + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (leftObserve : DeferredContext → Nat → + (HashOutput × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (rightObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp MaterializedSelectionOutcome) + (candidates : List Probe) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) + (hprobeFuel : plan.candidate? = none ∨ 0 < leftFuel) + (hcontext : FinalizationContextLE table left right) + (hfuel : leftFuel ≤ rightFuel) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hrecursive : ∀ nextLeft nextRight, + OrdinaryMaterializedRunEq table nextLeft nextRight → + CanonicalMaterializedValues table nextLeft.context → + RelTriple + (leftObserve nextLeft.context nextLeft.remaining nextLeft.value candidates) + (rightObserve nextRight.context.state nextRight.remaining nextRight.value.1 + nextRight.value.2 candidates) + (RootSelectionBridgeRel target leftOutput rightRoot ordinal)) : + RelTriple + (runDirectResolvedWitnessFromTable left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache) >>= + finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table leftObserve) candidates) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQueryAfterPublicPlan parameter input left.state plan).run rightCache) >>= + finishMaterializedSelectionOutcome target table rightObserve candidates) + (RootSelectionBridgeRel target leftOutput rightRoot ordinal) := by + apply relTriple_of_evalDist_eq_left + (evalDist_runWitnessSelection_eq_detailed + (canonicalizeDirectPrivateOrdinalSelection table leftObserve) candidates left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache)) + have hstep : RelTriple + (runDirectResolvedDetailedFromTable left leftFuel table + ((probingHashQueryAfterPlan parameter input plan).run leftCache)) + (runDirectResolvedDetailedFromTable right rightFuel table + ((probingHashQueryAfterPublicPlan parameter input left.state plan).run rightCache)) + (DirectDetailedOrdinaryStableRunEq table) := by + rcases hprobeFuel with hnone | hpositive + · exact relTriple_runDirectResolvedDetailed_afterPlan_publicPlan_of_none table parameter input + plan left right leftFuel rightFuel leftCache rightCache hnone hcontext hfuel hcache + hrevealed hvalues hpublished hrightMaterialized + · exact relTriple_runDirectResolvedDetailed_afterPlan_publicPlan table parameter input plan + left right leftFuel rightFuel leftCache rightCache hpositive hcontext hfuel hcache + hrevealed hvalues hpublished hrightMaterialized + apply relTriple_bind hstep + intro leftResult rightResult hrelation + exact relTriple_finishRootSelectionBridge target leftOutput rightRoot ordinal table leftObserve + rightObserve candidates leftResult rightResult hrelation + (fun originalLeft originalRight nextLeft nextRight _ _ hnext hcanonical => + hrecursive nextLeft nextRight hnext hcanonical) + +noncomputable def materializedRootAvoidingOrdinalSelectionOutcome + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (signer : Message → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp MaterializedSelectionOutcome := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + List Probe → LazyRevealProbe.State Coordinate → Nat → + (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp MaterializedSelectionOutcome) + (fun _value candidates _state _fuel _table _cache => + if hselected : ordinal < candidates.length then + pure (.finished (some (candidates.get ⟨ordinal, hselected⟩))) + else pure (.finished none)) + (fun query _next recursivelyRun candidates state fuel table cache => + if hselected : ordinal < candidates.length then + pure (.finished (some (candidates.get ⟨ordinal, hselected⟩))) + else + match query with + | .inl (.inl n) => + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + ((splitUniformImpl n).run cache) >>= + finishMaterializedSelectionOutcome target table + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache) + candidates + | .inl (.inr input) => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + if hnextSelected : ordinal < nextCandidates.length then + pure (.finished (some (nextCandidates.get ⟨ordinal, hnextSelected⟩))) + else if RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? then + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + ((probingHashQueryAfterPublicPlan parameter input publicContext.state plan).run + cache) >>= + finishMaterializedSelectionOutcome target table + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache) + nextCandidates + else pure (.finished none) + | .inr message => + runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + ((signer message).run cache) >>= + finishMaterializedSelectionOutcome target table + (fun nextState remaining value nextCache laterCandidates => + recursivelyRun value laterCandidates nextState remaining table nextCache) + candidates) + computation candidates state fuel table cache + +noncomputable def materializedActualRootAvoidingOrdinalSelectionOutcome + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp MaterializedSelectionOutcome := + materializedRootAvoidingOrdinalSelectionOutcome ordinal parameter target leftRoot rightRoot + (maskedSign parameter publicRoot ftsSecret) computation candidates state fuel table cache + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionOutcomeProbability.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionOutcomeProbability.lean new file mode 100644 index 00000000..ffdc7369 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionOutcomeProbability.lean @@ -0,0 +1,191 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionLift + +/-! +# Failure-outcome projection + +Every selected result of the failure-retaining materialized prefix is also selected by the +exchangeable optional prefix. Stopped, published and non-completable paths impose no obligation. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_materializedOutcome_optionalSelection + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (signer : Message → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (matchRoot : Digest) : + RelTriple + (materializedRootAvoidingOrdinalSelectionOutcome ordinal parameter target leftRoot rightRoot + signer computation candidates state fuel table cache) + (materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot rightRoot signer + computation candidates state fuel table cache) + (MaterializedOutcomeOptionRel target matchRoot) := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + simp only [materializedRootAvoidingOrdinalSelectionOutcome, + materializedRootAvoidingOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure (fun hmatch => hmatch) + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure (fun hmatch => hmatch) + | query_bind query next ih => + rw [materializedRootAvoidingOrdinalSelectionOutcome, OracleComp.construct_query_bind, + materializedRootAvoidingOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure (fun hmatch => hmatch) + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + change Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α at next + let outcomeObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → ProbComp MaterializedSelectionOutcome := + fun nextState remaining output nextCache laterCandidates => + materializedRootAvoidingOrdinalSelectionOutcome ordinal parameter target + leftRoot rightRoot signer (next output) laterCandidates nextState remaining + table nextCache + let optionObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot + rightRoot signer (next output) laterCandidates nextState remaining table + nextCache + apply relTriple_of_evalDist_eq_right + (evalDist_runDetailedMaterializedSelection_eq_clean target optionObserve + candidates state fuel table ((splitUniformImpl n).run cache)) + apply relTriple_bind + (relTriple_refl + (runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + ((splitUniformImpl n).run cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishMaterializedOutcome_option target matchRoot table + outcomeObserve optionObserve candidates leftResult + intro resolved hcompletable hprivate + simpa [outcomeObserve, optionObserve] using + ih resolved.value.1 candidates resolved.context.state resolved.remaining + resolved.value.2 + | inr input => + change HashOutput → OracleComp (OracleWorld + SigningSpec) α at next + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + exact relTriple_pure_pure (fun hmatch => hmatch) + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + by_cases hsafe : RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? + · have hsafeActual : RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + let outcomeObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp MaterializedSelectionOutcome := + fun nextState remaining output nextCache laterCandidates => + materializedRootAvoidingOrdinalSelectionOutcome ordinal parameter target + leftRoot rightRoot signer (next output) laterCandidates nextState + remaining table nextCache + let optionObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot + rightRoot signer (next output) laterCandidates nextState remaining table + nextCache + apply relTriple_of_evalDist_eq_right + (evalDist_runDetailedMaterializedSelection_eq_clean target optionObserve + nextCandidates state fuel table + ((probingHashQueryAfterPublicPlan parameter input publicContext.state plan).run + cache)) + apply relTriple_bind + (relTriple_refl + (runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + ((probingHashQueryAfterPublicPlan parameter input publicContext.state plan).run + cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishMaterializedOutcome_option target matchRoot table + outcomeObserve optionObserve nextCandidates leftResult + intro resolved hcompletable hprivate + simpa [outcomeObserve, optionObserve] using + ih resolved.value.1 nextCandidates resolved.context.state + resolved.remaining resolved.value.2 + · have hsafeActual : ¬RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + exact relTriple_pure_pure (fun hmatch => hmatch) + | inr message => + change Option Signature → OracleComp (OracleWorld + SigningSpec) α at next + let outcomeObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → ProbComp MaterializedSelectionOutcome := + fun nextState remaining output nextCache laterCandidates => + materializedRootAvoidingOrdinalSelectionOutcome ordinal parameter target leftRoot + rightRoot signer (next output) laterCandidates nextState remaining table nextCache + let optionObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot rightRoot + signer (next output) laterCandidates nextState remaining table nextCache + apply relTriple_of_evalDist_eq_right + (evalDist_runDetailedMaterializedSelection_eq_clean target optionObserve candidates + state fuel table ((signer message).run cache)) + apply relTriple_bind + (relTriple_refl + (runDirectResolvedDetailedFromTable (directDeferredContext state) fuel table + ((signer message).run cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishMaterializedOutcome_option target matchRoot table outcomeObserve + optionObserve candidates leftResult + intro resolved hcompletable hprivate + simpa [outcomeObserve, optionObserve] using + ih resolved.value.1 candidates resolved.context.state resolved.remaining + resolved.value.2 + +theorem relTriple_materializedActualOutcome_optionalSelection + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + RelTriple + (materializedActualRootAvoidingOrdinalSelectionOutcome ordinal parameter publicRoot target + leftRoot rightRoot ftsSecret computation candidates state fuel table cache) + (materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot target leftRoot + rightRoot ftsSecret computation candidates state fuel table cache) + (MaterializedOutcomeOptionRel target leftRoot) := + relTriple_materializedOutcome_optionalSelection ordinal parameter target leftRoot rightRoot + (maskedSign parameter publicRoot ftsSecret) computation candidates state fuel table cache + leftRoot + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionProbability.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionProbability.lean new file mode 100644 index 00000000..295a269f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionProbability.lean @@ -0,0 +1,98 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionHidden + +/-! +# Comparison-root prefix probability + +An independent comparison root hits a list of at most `q` earlier candidates with probability at +most `q / 2^128`, even after gating on an arbitrary event from the candidate-producing run. A +small absorption lemma turns the resulting self-weighted exceptional branch into a factor two. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp ENNReal + +set_option maxRecDepth 100000 + +theorem probEvent_uniformDigest_mem_list_le (values : List Digest) : + Pr[fun root : Digest => root ∈ values | ($ᵗ Digest : ProbComp Digest)] ≤ + (values.length : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + induction values with + | nil => simp + | cons head tail ih => + calc + _ = Pr[fun root : Digest => root = head ∨ root ∈ tail | + ($ᵗ Digest : ProbComp Digest)] := by + apply OracleComp.probEvent_congr' (fun root _ => by simp [eq_comm]) rfl + _ ≤ Pr[fun root : Digest => root = head | ($ᵗ Digest : ProbComp Digest)] + + Pr[fun root : Digest => root ∈ tail | ($ᵗ Digest : ProbComp Digest)] := + probEvent_or_le _ _ _ + _ ≤ ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + (tail.length : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply add_le_add + · rw [probEvent_eq_eq_probOutput, probOutput_uniformSample] + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + · exact ih + _ = ((head :: tail).length : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [show (((head :: tail).length : Nat) : ℝ≥0∞) = + 1 + (tail.length : ℝ≥0∞) by simp [add_comm]] + rw [add_mul, one_mul] + +theorem probEvent_gate_and_uniformDigest_mem_list_le + (run : ProbComp α) (gate : α → Prop) (values : α → List Digest) (q : Nat) + (hlength : ∀ result ∈ support run, gate result → (values result).length ≤ q) : + Pr[fun result : α × Digest => + gate result.1 ∧ result.2 ∈ values result.1 | do + let result ← run + let root ← ($ᵗ Digest : ProbComp Digest) + pure (result, root)] ≤ + Pr[gate | run] * + ((q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) := by + apply SphincsSecurity.probEvent_bind_le_gated_mul + (firstComp := run) (gate := gate) + · intro result _hresult hgate + rw [show (do + let root ← ($ᵗ Digest : ProbComp Digest) + pure (result, root)) = + (fun root => (result, root)) <$> ($ᵗ Digest : ProbComp Digest) by + simp [map_eq_bind_pure_comp], probEvent_map] + simp [hgate] + · intro result hresult hgate + rw [show (do + let root ← ($ᵗ Digest : ProbComp Digest) + pure (result, root)) = + (fun root => (result, root)) <$> ($ᵗ Digest : ProbComp Digest) by + simp [map_eq_bind_pure_comp], probEvent_map] + change Pr[fun root : Digest => gate result ∧ root ∈ values result | + ($ᵗ Digest : ProbComp Digest)] ≤ _ + simp only [hgate, true_and] + calc + _ ≤ ((values result).length : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + probEvent_uniformDigest_mem_list_le (values result) + _ ≤ (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + gcongr + exact_mod_cast hlength result hresult hgate + +theorem le_two_mul_of_le_add_mul_inv_two + (probability epsilon : ℝ≥0∞) + (hprobability : probability ≤ 1) (hepsilon : epsilon ≠ ∞) + (hbound : probability ≤ epsilon + probability * (2 : ℝ≥0∞)⁻¹) : + probability ≤ 2 * epsilon := by + have hprobabilityFinite : probability ≠ ∞ := by + exact ne_top_of_le_ne_top (by norm_num) hprobability + have hhalfFinite : probability * (2 : ℝ≥0∞)⁻¹ ≠ ∞ := by finiteness + have hsumFinite : epsilon + probability * (2 : ℝ≥0∞)⁻¹ ≠ ∞ := by finiteness + have hrightFinite : (2 : ℝ≥0∞) * epsilon ≠ ∞ := by finiteness + have hreal : probability.toReal ≤ + epsilon.toReal + probability.toReal * (2 : ℝ)⁻¹ := by + have := (ENNReal.toReal_le_toReal hprobabilityFinite hsumFinite).mpr hbound + simpa [ENNReal.toReal_add hepsilon hhalfFinite, ENNReal.toReal_mul, + ENNReal.toReal_inv] using this + apply (ENNReal.toReal_le_toReal hprobabilityFinite hrightFinite).mp + rw [ENNReal.toReal_mul] + norm_num only [ENNReal.toReal_ofNat] + linarith + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionSigner.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionSigner.lean new file mode 100644 index 00000000..d10711ba --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionSigner.lean @@ -0,0 +1,78 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelection + +/-! +# Swapped-root signer continuations + +The concrete signer comparison is a two-stage coupling through the target-aware signer. This +module retains an arbitrary continuation after each stage, so the normalized ordinal prefix can +continue with its related canonical deferred contexts instead of projecting the signer state away. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem evalDist_bind_eq_of_relTriple_next + (left : ProbComp α) (right : ProbComp β) (relation : α → β → Prop) + (leftNext : α → ProbComp γ) (rightNext : β → ProbComp γ) + (hrel : RelTriple left right relation) + (hnext : ∀ leftValue rightValue, relation leftValue rightValue → + evalDist (leftNext leftValue) = evalDist (rightNext rightValue)) : + evalDist (left >>= leftNext) = evalDist (right >>= rightNext) := by + apply evalDist_eq_of_relTriple_eqRel + apply relTriple_bind hrel + intro leftValue rightValue hvalue + exact relTriple_eqRel_of_evalDist_eq (hnext leftValue rightValue hvalue) + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_swappedRoot_maskedSign_bind_eq + (parameter : PublicParameter) (publicRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (leftContext rightContext : DeferredContext) + (hcontext : RootMaterializedContextRel target leftOutput rightOutput + leftContext rightContext) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootDeferredCacheRel parameter target leftOutput rightOutput + leftCache rightCache) + (message : Message) + (leftObserve middleObserve rightObserve : + Option (CleanRunResult (Option Signature × SplitHashCache)) → ProbComp α) + (hleftMiddle : ∀ leftResult middleResult, + RootEncodingStoredCleanSameRel parameter target (truncateHash leftOutput) + (truncateHash rightOutput) leftResult middleResult → + evalDist (leftObserve leftResult) = evalDist (middleObserve middleResult)) + (hmiddleRight : ∀ middleResult rightResult, + RootHiddenCleanSameRel target leftOutput rightOutput middleResult rightResult → + evalDist (middleObserve middleResult) = evalDist (rightObserve rightResult)) : + evalDist + (runCleanFromTable leftContext.state fuel table + ((maskedSign parameter publicRoot ftsSecret message).run leftCache) >>= + leftObserve) = + evalDist + (runCleanFromTable rightContext.state fuel table + ((maskedSign parameter publicRoot ftsSecret message).run rightCache) >>= + rightObserve) := by + obtain ⟨middleCache, hencoding, hhidden⟩ := hcache + have hstored : StoredLayerRoot leftContext.state target (truncateHash leftOutput) := + ⟨leftOutput, hcontext.state.left_target, rfl⟩ + let middleRun := runCleanFromTable leftContext.state fuel table + ((maskedSignWithTargetComparison parameter publicRoot target (truncateHash rightOutput) + ftsSecret message).run middleCache) + have hab := rootEncodingCacheRelatesStored_maskedSign_targetComparison parameter publicRoot + target hroot (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret message + leftCache middleCache hencoding leftContext.state fuel table hstored + have hbc := rootHiddenRelates_maskedSignWithTargetComparison_actual parameter publicRoot + ftsSecret target hroot leftOutput rightOutput message leftContext.state rightContext.state + hcontext.state fuel table middleCache rightCache hhidden + calc + _ = evalDist (middleRun >>= middleObserve) := + evalDist_bind_eq_of_relTriple_next _ _ _ leftObserve middleObserve hab hleftMiddle + _ = _ := + evalDist_bind_eq_of_relTriple_next _ _ _ middleObserve rightObserve hbc hmiddleRight + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionWeaken.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionWeaken.lean new file mode 100644 index 00000000..849b9df1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionWeaken.lean @@ -0,0 +1,666 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSelectionOutcomeProbability + +/-! +# Comparison-root guard weakening + +Removing the comparison-root stop from the materialized optional prefix cannot destroy a selected +match. The resulting reference run depends on the actual root but not on the independently sampled +comparison root. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def MaterializedOptionMatchRel + (target : Position) (root : Digest) : Option Probe → Option Probe → Prop := + fun left right => + materializedOrdinalSelectionMatches target root left → + materializedOrdinalSelectionMatches target root right + +theorem relTriple_none_any_materializedOptionMatch + (target : Position) (root : Digest) (right : ProbComp (Option Probe)) : + RelTriple (pure none : ProbComp (Option Probe)) right + (MaterializedOptionMatchRel target root) := by + have hbase := relTriple_true (pure none : ProbComp (Option Probe)) right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun selection => selection = none) (by + intro selection hselection + simpa using hselection) + apply relTriple_post_mono hsupported + intro leftSelection rightSelection hrelation hmatch + rw [hrelation.2] at hmatch + exact False.elim hmatch + +theorem relTriple_finishMaterializedSelection_weaken + (target : Position) (matchRoot : Digest) + (leftObserve rightObserve : LazyRevealProbe.State Coordinate → Nat → α → + SplitHashCache → List Probe → ProbComp (Option Probe)) + (candidates : List Probe) (result : Option (CleanRunResult (α × SplitHashCache))) + (hnext : ∀ resolved : CleanRunResult (α × SplitHashCache), + RelTriple + (leftObserve resolved.state resolved.remaining resolved.value.1 resolved.value.2 candidates) + (rightObserve resolved.state resolved.remaining resolved.value.1 resolved.value.2 candidates) + (MaterializedOptionMatchRel target matchRoot)) : + RelTriple + (finishMaterializedPrivateOrdinalSelection leftObserve candidates result) + (finishMaterializedPrivateOrdinalSelection rightObserve candidates result) + (MaterializedOptionMatchRel target matchRoot) := by + cases result with + | none => exact relTriple_none_any_materializedOptionMatch target matchRoot _ + | some resolved => + unfold finishMaterializedPrivateOrdinalSelection + exact hnext resolved + +theorem rootAwareCandidateAvoidsRoots_actual + (target : Position) (leftRoot rightRoot : Digest) (candidate? : Option Probe) + (havoid : RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate?) : + RootAwareCandidateAvoidsRoots target leftRoot leftRoot candidate? := by + cases candidate? with + | none => simp [RootAwareCandidateAvoidsRoots] + | some candidate => + rw [rootAwareCandidateAvoidsRoots_iff] at havoid ⊢ + exact ⟨havoid.1, havoid.1⟩ + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_materializedRootAvoidingOrdinalSelection_weaken_comparison + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot matchRoot : Digest) + (signer : Message → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + RelTriple + (materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot rightRoot signer + computation candidates state fuel table cache) + (materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot leftRoot signer + computation candidates state fuel table cache) + (MaterializedOptionMatchRel target matchRoot) := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + simp only [materializedRootAvoidingOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure (fun hmatch => hmatch) + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure (fun hmatch => hmatch) + | query_bind query next ih => + rw [materializedRootAvoidingOrdinalSelection, OracleComp.construct_query_bind, + materializedRootAvoidingOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure (fun hmatch => hmatch) + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let leftObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot + rightRoot signer (next output) laterCandidates nextState remaining table + nextCache + let rightObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot + leftRoot signer (next output) laterCandidates nextState remaining table + nextCache + apply relTriple_bind + (relTriple_refl + (runCleanFromTable state fuel table ((splitUniformImpl n).run cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishMaterializedSelection_weaken target matchRoot + (continueMaterializedPrivateOrdinalSelection target leftObserve) + (continueMaterializedPrivateOrdinalSelection target rightObserve) + candidates leftResult + intro resolved + unfold continueMaterializedPrivateOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ resolved.state.revealed + · simp [hrevealed, MaterializedOptionMatchRel, + materializedOrdinalSelectionMatches] + · simpa [hrevealed, leftObserve, rightObserve] using + ih resolved.value.1 candidates resolved.state resolved.remaining + resolved.value.2 + | inr input => + let publicContext := materializedCanonicalContext table state + let plan := purePlanProbingHashQuery parameter input publicContext.state + let candidate? := rootAwareCandidateForPlan? parameter input plan + let nextCandidates := appendPlannedCandidate candidates candidate? + by_cases hnextSelected : ordinal < nextCandidates.length + · have hactual : ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + exact relTriple_pure_pure (fun hmatch => hmatch) + · have hactual : ¬ordinal < + (appendPlannedCandidate candidates + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state))).length := by + simpa [publicContext, plan, candidate?, nextCandidates] using hnextSelected + simp only [hactual, ↓reduceDIte] + by_cases hsafe : RootAwareCandidateAvoidsRoots target leftRoot rightRoot candidate? + · have hsafeActual : RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + have hleftSafe := rootAwareCandidateAvoidsRoots_actual target leftRoot rightRoot + candidate? hsafe + have hleftSafeActual : RootAwareCandidateAvoidsRoots target leftRoot leftRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hleftSafe + simp only [hsafeActual, hleftSafeActual, ↓reduceIte] + let leftObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot + rightRoot signer (next output) laterCandidates nextState remaining table + nextCache + let rightObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot + leftRoot signer (next output) laterCandidates nextState remaining table + nextCache + apply relTriple_bind + (relTriple_refl + (runCleanFromTable state fuel table + ((probingHashQueryAfterPublicPlan parameter input publicContext.state plan).run + cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishMaterializedSelection_weaken target matchRoot + (continueMaterializedPrivateOrdinalSelection target leftObserve) + (continueMaterializedPrivateOrdinalSelection target rightObserve) + nextCandidates leftResult + intro resolved + unfold continueMaterializedPrivateOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ resolved.state.revealed + · simp [hrevealed, MaterializedOptionMatchRel, + materializedOrdinalSelectionMatches] + · simpa [hrevealed, leftObserve, rightObserve] using + ih resolved.value.1 nextCandidates resolved.state resolved.remaining + resolved.value.2 + · have hsafeActual : ¬RootAwareCandidateAvoidsRoots target leftRoot rightRoot + (rootAwareCandidateForPlan? parameter input + (purePlanProbingHashQuery parameter input + (materializedCanonicalContext table state).state)) := by + simpa [publicContext, plan, candidate?] using hsafe + simp only [hsafeActual, ↓reduceIte] + exact relTriple_none_any_materializedOptionMatch target matchRoot _ + | inr message => + let leftObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot + rightRoot signer (next output) laterCandidates nextState remaining table nextCache + let rightObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → ProbComp (Option Probe) := + fun nextState remaining output nextCache laterCandidates => + materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot leftRoot + signer (next output) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_refl (runCleanFromTable state fuel table ((signer message).run cache))) + intro leftResult rightResult hresult + subst rightResult + apply relTriple_finishMaterializedSelection_weaken target matchRoot + (continueMaterializedPrivateOrdinalSelection target leftObserve) + (continueMaterializedPrivateOrdinalSelection target rightObserve) + candidates leftResult + intro resolved + unfold continueMaterializedPrivateOrdinalSelection + by_cases hrevealed : Coordinate.position target ∈ resolved.state.revealed + · simp [hrevealed, MaterializedOptionMatchRel, + materializedOrdinalSelectionMatches] + · simpa [hrevealed, leftObserve, rightObserve] using + ih resolved.value.1 candidates resolved.state resolved.remaining resolved.value.2 + +theorem probEvent_materializedRootAvoidingOrdinalSelection_match_le_actual_guard + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot matchRoot : Digest) + (signer : Message → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + Pr[materializedOrdinalSelectionMatches target matchRoot | + materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot rightRoot signer + computation candidates state fuel table cache] ≤ + Pr[materializedOrdinalSelectionMatches target matchRoot | + materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot leftRoot signer + computation candidates state fuel table cache] := + probEvent_le_of_relTriple + (relTriple_materializedRootAvoidingOrdinalSelection_weaken_comparison ordinal parameter target + leftRoot rightRoot matchRoot signer computation candidates state fuel table cache) + (fun _ _ hrelation => hrelation) + +def selectedProbeDigest : Option Probe → Digest + | none => 0 + | some candidate => candidate.candidate + +def materializedOrdinalSelectionAt + (target : Position) : Option Probe → Prop + | none => False + | some candidate => candidate.coordinate = .position target + +theorem materializedOrdinalSelectionMatches_root_eq_selectedProbeDigest + {target : Position} {root : Digest} {selection : Option Probe} + (hmatch : materializedOrdinalSelectionMatches target root selection) : + root = selectedProbeDigest selection := by + cases selection with + | none => exact False.elim hmatch + | some candidate => + unfold materializedOrdinalSelectionMatches at hmatch + subst candidate + rfl + +theorem materializedOrdinalSelectionAt_of_matches + {target : Position} {root : Digest} {selection : Option Probe} + (hmatch : materializedOrdinalSelectionMatches target root selection) : + materializedOrdinalSelectionAt target selection := by + cases selection with + | none => exact False.elim hmatch + | some candidate => + unfold materializedOrdinalSelectionMatches at hmatch + subst candidate + rfl + +set_option maxRecDepth 100000 in +theorem probEvent_sampledComparisonRoot_materializedSelectionMatches_le + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot : Digest) + (signer : Message → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2 | do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← materializedRootAvoidingOrdinalSelection ordinal parameter target + leftRoot rightRoot signer computation candidates state fuel table cache + pure (rightRoot, selection)] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let reference := materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot + leftRoot signer computation candidates state fuel table cache + calc + _ ≤ Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2 | do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← reference + pure (rightRoot, selection)] := by + apply probEvent_bind_le_bind_of_forall_le + intro rightRoot _hrightRoot + rw [show (do + let selection ← materializedRootAvoidingOrdinalSelection ordinal parameter target + leftRoot rightRoot signer computation candidates state fuel table cache + pure (rightRoot, selection)) = + (fun selection => (rightRoot, selection)) <$> + materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot rightRoot + signer computation candidates state fuel table cache by + simp [map_eq_bind_pure_comp], + show (do + let selection ← reference + pure (rightRoot, selection)) = + (fun selection => (rightRoot, selection)) <$> reference by + simp [map_eq_bind_pure_comp], probEvent_map, probEvent_map] + exact probEvent_materializedRootAvoidingOrdinalSelection_match_le_actual_guard ordinal + parameter target leftRoot rightRoot rightRoot signer computation candidates state fuel table + cache + _ ≤ Pr[fun result : Digest × Option Probe => + result.1 = selectedProbeDigest result.2 | do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← reference + pure (rightRoot, selection)] := by + apply probEvent_mono + intro result _hresult hmatch + exact materializedOrdinalSelectionMatches_root_eq_selectedProbeDigest hmatch + _ ≤ _ := by + apply probEvent_uniform_root_matches_distribution_independent_guess_le + (fun _rightRoot => reference) reference + · intro rightRoot + rfl + +set_option maxRecDepth 100000 in +theorem probEvent_sampledComparisonRoot_materializedSelectionMatches_le_mul + (ordinal : Nat) (parameter : PublicParameter) (target : Position) + (leftRoot : Digest) + (signer : Message → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature)) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2 | do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← materializedRootAvoidingOrdinalSelection ordinal parameter target + leftRoot rightRoot signer computation candidates state fuel table cache + pure (rightRoot, selection)] ≤ + Pr[materializedOrdinalSelectionAt target | + materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot leftRoot signer + computation candidates state fuel table cache] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let reference := materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot + leftRoot signer computation candidates state fuel table cache + calc + _ ≤ Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2 | do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← reference + pure (rightRoot, selection)] := by + apply probEvent_bind_le_bind_of_forall_le + intro rightRoot _hrightRoot + rw [show (do + let selection ← materializedRootAvoidingOrdinalSelection ordinal parameter target + leftRoot rightRoot signer computation candidates state fuel table cache + pure (rightRoot, selection)) = + (fun selection => (rightRoot, selection)) <$> + materializedRootAvoidingOrdinalSelection ordinal parameter target leftRoot rightRoot + signer computation candidates state fuel table cache by + simp [map_eq_bind_pure_comp], + show (do + let selection ← reference + pure (rightRoot, selection)) = + (fun selection => (rightRoot, selection)) <$> reference by + simp [map_eq_bind_pure_comp], probEvent_map, probEvent_map] + exact probEvent_materializedRootAvoidingOrdinalSelection_match_le_actual_guard ordinal + parameter target leftRoot rightRoot rightRoot signer computation candidates state fuel table + cache + _ ≤ Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionAt target result.2 ∧ + result.1 = selectedProbeDigest result.2 | do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← reference + pure (rightRoot, selection)] := by + apply probEvent_mono + intro result _hresult hmatch + exact ⟨materializedOrdinalSelectionAt_of_matches hmatch, + materializedOrdinalSelectionMatches_root_eq_selectedProbeDigest hmatch⟩ + _ ≤ _ := by + apply probEvent_uniform_root_matches_distribution_independent_guess_le_mul + (fun _rightRoot => reference) reference + intro rightRoot + rfl + +set_option maxRecDepth 100000 in +theorem probEvent_uniformActualRoot_match_le_of_swap_of_comparison + (target : Position) + (run : Digest → Digest → ProbComp (Option Probe)) + (reference : Digest → ProbComp (Option Probe)) + (hswap : ∀ leftRoot rightRoot, + evalDist (run leftRoot rightRoot) = evalDist (run rightRoot leftRoot)) + (hcomparison : ∀ leftRoot rightRoot, + Pr[materializedOrdinalSelectionMatches target rightRoot | run leftRoot rightRoot] ≤ + Pr[materializedOrdinalSelectionMatches target rightRoot | reference leftRoot]) : + Pr[fun result : Digest × Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← run leftRoot rightRoot + pure (leftRoot, rightRoot, selection)] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let sampled := ($ᵗ Digest : ProbComp Digest) + let actual : ProbComp (Digest × Digest × Option Probe) := do + let leftRoot ← sampled + let rightRoot ← sampled + let selection ← run leftRoot rightRoot + pure (leftRoot, rightRoot, selection) + let swapped : ProbComp (Digest × Digest × Option Probe) := do + let leftRoot ← sampled + let rightRoot ← sampled + let selection ← run rightRoot leftRoot + pure (leftRoot, rightRoot, selection) + let comparison : ProbComp (Digest × Digest × Option Probe) := do + let leftRoot ← sampled + let rightRoot ← sampled + let selection ← run leftRoot rightRoot + pure (rightRoot, leftRoot, selection) + let referenceComparison : ProbComp (Digest × Digest × Option Probe) := do + let leftRoot ← sampled + let rightRoot ← sampled + let selection ← reference leftRoot + pure (rightRoot, leftRoot, selection) + have hreplace : evalDist actual = evalDist swapped := by + unfold actual swapped + apply evalDist_bind_congr + intro leftRoot _hleftRoot + apply evalDist_bind_congr + intro rightRoot _hrightRoot + rw [evalDist_bind, evalDist_bind, hswap leftRoot rightRoot] + have hcommute : evalDist swapped = evalDist comparison := by + unfold swapped comparison + exact OracleComp.DeferredSampling.evalDist_bind_comm sampled sampled + (fun leftRoot rightRoot => do + let selection ← run rightRoot leftRoot + pure (leftRoot, rightRoot, selection)) + change Pr[fun result : Digest × Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2.2 | actual] ≤ _ + calc + _ = Pr[fun result : Digest × Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2.2 | comparison] := + OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) (hreplace.trans hcommute) + _ ≤ Pr[fun result : Digest × Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2.2 | + referenceComparison] := by + unfold comparison referenceComparison + apply probEvent_bind_le_bind_of_forall_le + intro leftRoot _hleftRoot + apply probEvent_bind_le_bind_of_forall_le + intro rightRoot _hrightRoot + rw [show (do + let selection ← run leftRoot rightRoot + pure (rightRoot, leftRoot, selection)) = + (fun selection => (rightRoot, leftRoot, selection)) <$> run leftRoot rightRoot by + simp [map_eq_bind_pure_comp], + show (do + let selection ← reference leftRoot + pure (rightRoot, leftRoot, selection)) = + (fun selection => (rightRoot, leftRoot, selection)) <$> reference leftRoot by + simp [map_eq_bind_pure_comp], probEvent_map, probEvent_map] + exact hcomparison leftRoot rightRoot + _ ≤ ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + unfold referenceComparison + apply probEvent_bind_le_of_forall_le + intro leftRoot _hleftRoot + let fixed : ProbComp (Digest × Option Probe) := do + let rightRoot ← sampled + let selection ← reference leftRoot + pure (rightRoot, selection) + have hfixed : Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2 | fixed] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ ≤ Pr[fun result : Digest × Option Probe => + result.1 = selectedProbeDigest result.2 | fixed] := by + apply probEvent_mono + intro result _hresult hmatch + exact materializedOrdinalSelectionMatches_root_eq_selectedProbeDigest hmatch + _ ≤ _ := by + unfold fixed + apply probEvent_uniform_root_matches_distribution_independent_guess_le + (fun _rightRoot => reference leftRoot) (reference leftRoot) + intro rightRoot + rfl + calc + _ = Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2 | fixed] := by + rw [show (do + let rightRoot ← sampled + let selection ← reference leftRoot + pure (rightRoot, leftRoot, selection)) = + (fun result : Digest × Option Probe => (result.1, leftRoot, result.2)) <$> + fixed by + simp [fixed, map_eq_bind_pure_comp], probEvent_map] + rfl + _ ≤ _ := hfixed + +set_option maxRecDepth 100000 in +theorem probEvent_uniformActualRoot_match_le_of_swap_of_comparison_mul + (target : Position) + (run : Digest → Digest → ProbComp (Option Probe)) + (reference : Digest → ProbComp (Option Probe)) + (hswap : ∀ leftRoot rightRoot, + evalDist (run leftRoot rightRoot) = evalDist (run rightRoot leftRoot)) + (hcomparison : ∀ leftRoot, + Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2 | do + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← run leftRoot rightRoot + pure (rightRoot, selection)] ≤ + Pr[materializedOrdinalSelectionAt target | reference leftRoot] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[fun result : Digest × Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← run leftRoot rightRoot + pure (leftRoot, rightRoot, selection)] ≤ + Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionAt target result.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← reference leftRoot + pure (leftRoot, selection)] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let sampled := ($ᵗ Digest : ProbComp Digest) + let actual : ProbComp (Digest × Digest × Option Probe) := do + let leftRoot ← sampled + let rightRoot ← sampled + let selection ← run leftRoot rightRoot + pure (leftRoot, rightRoot, selection) + let swapped : ProbComp (Digest × Digest × Option Probe) := do + let leftRoot ← sampled + let rightRoot ← sampled + let selection ← run rightRoot leftRoot + pure (leftRoot, rightRoot, selection) + let comparison : ProbComp (Digest × Digest × Option Probe) := do + let leftRoot ← sampled + let rightRoot ← sampled + let selection ← run leftRoot rightRoot + pure (rightRoot, leftRoot, selection) + let referenceRun : ProbComp (Digest × Option Probe) := do + let leftRoot ← sampled + let selection ← reference leftRoot + pure (leftRoot, selection) + have hreplace : evalDist actual = evalDist swapped := by + unfold actual swapped + apply evalDist_bind_congr + intro leftRoot _hleftRoot + apply evalDist_bind_congr + intro rightRoot _hrightRoot + rw [evalDist_bind, evalDist_bind, hswap leftRoot rightRoot] + have hcommute : evalDist swapped = evalDist comparison := by + unfold swapped comparison + exact OracleComp.DeferredSampling.evalDist_bind_comm sampled sampled + (fun leftRoot rightRoot => do + let selection ← run rightRoot leftRoot + pure (leftRoot, rightRoot, selection)) + change Pr[fun result : Digest × Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2.2 | actual] ≤ _ + calc + _ = Pr[fun result : Digest × Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2.2 | comparison] := + OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) (hreplace.trans hcommute) + _ = ∑' leftRoot, (evalDist sampled) leftRoot * + Pr[fun result : Digest × Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2.2 | do + let rightRoot ← sampled + let selection ← run leftRoot rightRoot + pure (rightRoot, leftRoot, selection)] := by + unfold comparison + rw [probEvent_bind_eq_tsum] + simp only [probOutput_def] + _ ≤ ∑' leftRoot, (evalDist sampled) leftRoot * + (Pr[materializedOrdinalSelectionAt target | reference leftRoot] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply ENNReal.tsum_le_tsum + intro leftRoot + rw [show ((do + let rightRoot ← sampled + let selection ← run leftRoot rightRoot + pure (rightRoot, leftRoot, selection)) : + ProbComp (Digest × Digest × Option Probe)) = + (fun result : Digest × Option Probe => (result.1, leftRoot, result.2)) <$> + ((do + let rightRoot ← sampled + let selection ← run leftRoot rightRoot + pure (rightRoot, selection)) : ProbComp (Digest × Option Probe)) by + simp [map_eq_bind_pure_comp], probEvent_map] + gcongr + exact hcomparison leftRoot + _ = (∑' leftRoot, (evalDist sampled) leftRoot * + Pr[materializedOrdinalSelectionAt target | reference leftRoot]) * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + simp_rw [← mul_assoc] + rw [ENNReal.tsum_mul_right] + _ = Pr[fun result : Digest × Option Probe => + materializedOrdinalSelectionAt target result.2 | referenceRun] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + unfold referenceRun + rw [probEvent_bind_eq_tsum] + apply congrArg (fun value => value * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) + apply tsum_congr + intro leftRoot + rw [show (do + let selection ← reference leftRoot + pure (leftRoot, selection)) = + (fun selection => (leftRoot, selection)) <$> reference leftRoot by + simp [map_eq_bind_pure_comp], probEvent_map] + rfl + +set_option maxRecDepth 100000 in +theorem probEvent_uniformActualRoot_materializedActualSelectionMatches_le + (ordinal : Nat) (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) + (state : Digest → LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : Digest → SplitHashCache) + (hswap : ∀ leftRoot rightRoot, + evalDist + (materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot target + leftRoot rightRoot ftsSecret computation candidates (state leftRoot) fuel table + (cache leftRoot)) = + evalDist + (materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot target + rightRoot leftRoot ftsSecret computation candidates (state rightRoot) fuel table + (cache rightRoot))) : + Pr[fun result : Digest × Digest × Option Probe => + materializedOrdinalSelectionMatches target result.1 result.2.2 | do + let leftRoot ← ($ᵗ Digest : ProbComp Digest) + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + let selection ← materializedActualRootAvoidingOrdinalSelection ordinal parameter + publicRoot target leftRoot rightRoot ftsSecret computation candidates (state leftRoot) fuel + table (cache leftRoot) + pure (leftRoot, rightRoot, selection)] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + let run : Digest → Digest → ProbComp (Option Probe) := + fun leftRoot rightRoot => + materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot target leftRoot + rightRoot ftsSecret computation candidates (state leftRoot) fuel table (cache leftRoot) + let reference : Digest → ProbComp (Option Probe) := + fun leftRoot => + materializedActualRootAvoidingOrdinalSelection ordinal parameter publicRoot target leftRoot + leftRoot ftsSecret computation candidates (state leftRoot) fuel table (cache leftRoot) + apply probEvent_uniformActualRoot_match_le_of_swap_of_comparison target run reference + · intro leftRoot rightRoot + exact hswap leftRoot rightRoot + · intro leftRoot rightRoot + exact probEvent_materializedRootAvoidingOrdinalSelection_match_le_actual_guard ordinal + parameter target leftRoot rightRoot rightRoot (maskedSign parameter publicRoot ftsSecret) + computation candidates (state leftRoot) fuel table (cache leftRoot) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSigner.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSigner.lean new file mode 100644 index 00000000..c7600c68 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSigner.lean @@ -0,0 +1,817 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootCache + +/-! +# Layer-root signer comparison + +Once a middle or bottom layer root has been materialized, recomputing that tree root returns the +same digest. A proof-only signer can therefore keep the concrete structural computation while +substituting an independent comparison root only in the upper encoding call. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def StoredLayerRoot + (state : LazyRevealProbe.State Coordinate) (position : Position) + (root : Digest) : Prop := + ∃ output, state.values (.position position) = some output ∧ truncateHash output = root + +theorem storedLayerRoot_mono + {state finalState : LazyRevealProbe.State Coordinate} + {position : Position} {root : Digest} + (hroot : StoredLayerRoot state position root) + (hle : LazyRevealProbe.ValuesLE state finalState) : + StoredLayerRoot finalState position root := by + obtain ⟨output, hvalue, hroot⟩ := hroot + exact ⟨output, hle _ _ hvalue, hroot⟩ + +theorem StoredLayerRoot.ensure + {state : LazyRevealProbe.State Coordinate} {position : Position} {root : Digest} + (hroot : StoredLayerRoot state position root) (coordinate : Coordinate) : + StoredLayerRoot (state.ensure coordinate) position root := + hroot + +theorem StoredLayerRoot.addPending + {state : LazyRevealProbe.State Coordinate} {position : Position} {root : Digest} + (hroot : StoredLayerRoot state position root) + (coordinate : Coordinate) (candidate : Digest) : + StoredLayerRoot (state.addPending coordinate candidate) position root := + hroot + +theorem StoredLayerRoot.publish + {state : LazyRevealProbe.State Coordinate} {position : Position} {root : Digest} + (hroot : StoredLayerRoot state position root) (coordinate : Coordinate) : + StoredLayerRoot (state.publish coordinate) position root := + hroot + +theorem StoredLayerRoot.materialize_of_ne + {state : LazyRevealProbe.State Coordinate} {position : Position} {root : Digest} + (hroot : StoredLayerRoot state position root) + (coordinate : Coordinate) (output : HashOutput) + (hne : coordinate ≠ .position position) : + StoredLayerRoot (state.materialize coordinate output) position root := by + obtain ⟨stored, hstored, hroot⟩ := hroot + refine ⟨stored, ?_, hroot⟩ + simpa [LazyRevealProbe.State.materialize, Function.update_of_ne hne.symm] using hstored + +set_option maxRecDepth 100000 in +theorem storedLayerRoot_of_mem_runCleanFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : CleanRunResult α) + (position : Position) (root : Digest) + (hroot : StoredLayerRoot state position root) + (hresult : some result ∈ support + (runCleanFromTable state fuel table computation)) : + StoredLayerRoot result.state position root := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + simp [runCleanFromTable] at hresult + subst result + exact hroot + | query_bind input next ih => + cases input with + | uniform n => + rw [runCleanFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output state fuel hroot hrest + | hashOutput => + rw [runCleanFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output state fuel hroot hrest + | ensure coordinate => + rw [runCleanFromTable_ensure_query_bind] at hresult + exact ih () (state.ensure coordinate) fuel (hroot.ensure coordinate) hresult + | probe coordinate candidate => + rw [runCleanFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · exact ih () state remaining hroot (by simpa [hrevealed] using hresult) + · exact ih () (state.addPending coordinate candidate) remaining + (hroot.addPending coordinate candidate) (by simpa [hrevealed] using hresult) + | peek coordinate => + rw [runCleanFromTable_peek_query_bind] at hresult + exact ih (state.values coordinate) state fuel hroot hresult + | publish coordinate => + rw [runCleanFromTable_publish_query_bind] at hresult + exact ih () (state.publish coordinate) fuel (hroot.publish coordinate) hresult + | reveal coordinate => + rw [runCleanFromTable_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + rw [hvalue] at hresult + exact ih output state fuel hroot hresult + | none => + have hne : coordinate ≠ .position position := by + intro heq + subst coordinate + obtain ⟨stored, hstored, _⟩ := hroot + rw [hvalue] at hstored + simp at hstored + rw [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only at hresult + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) + · rw [if_pos hhit] at hresult + simp at hresult + · rw [if_neg hhit] at hresult + exact ih (table index) + (state.materialize (.chainStart lay tree leafIdx chainIdx) (table index)) + fuel (hroot.materialize_of_ne _ _ hne) (by simpa [index] using hresult) + | position revealedPosition => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : state.hitAt (.position revealedPosition) output + · simp [hhit] at hrest + · exact ih output (state.materialize (.position revealedPosition) output) + fuel (hroot.materialize_of_ne _ _ hne) (by simpa [hhit] using hrest) + +def RootEncodingStoredCleanSameRel + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) : + Option (CleanRunResult (α × SplitHashCache)) → + Option (CleanRunResult (α × SplitHashCache)) → Prop + | some left, some right => + RootEncodingCleanSameRel parameter target leftRoot rightRoot (some left) (some right) ∧ + StoredLayerRoot left.state target leftRoot + | none, none => True + | _, _ => False + +def RootEncodingCacheRelatesStored + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftCache rightCache, + RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache → + ∀ state fuel table, StoredLayerRoot state target leftRoot → + RelTriple + (runCleanFromTable state fuel table (left.run leftCache)) + (runCleanFromTable state fuel table (right.run rightCache)) + (RootEncodingStoredCleanSameRel parameter target leftRoot rightRoot) + +theorem relTriple_rootEncoding_add_stored + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (leftCache rightCache : SplitHashCache) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hrelation : RelTriple + (runCleanFromTable state fuel table (left.run leftCache)) + (runCleanFromTable state fuel table (right.run rightCache)) + (RootEncodingCleanSameRel parameter target leftRoot rightRoot)) + (hstored : StoredLayerRoot state target leftRoot) : + RelTriple + (runCleanFromTable state fuel table (left.run leftCache)) + (runCleanFromTable state fuel table (right.run rightCache)) + (RootEncodingStoredCleanSameRel parameter target leftRoot rightRoot) := by + let leftRun := runCleanFromTable state fuel table (left.run leftCache) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hrelation + (fun result => result ∈ support leftRun) (fun result hresult => hresult) + apply relTriple_post_mono hsupported + intro leftResult rightResult hresult + rcases hresult with ⟨hrel, hleftSupport⟩ + cases leftResult with + | none => + cases rightResult with + | none => trivial + | some rightResult => simp [RootEncodingCleanSameRel] at hrel + | some leftResult => + cases rightResult with + | none => simp [RootEncodingCleanSameRel] at hrel + | some rightResult => + exact ⟨hrel, storedLayerRoot_of_mem_runCleanFromTable (left.run leftCache) + state fuel table leftResult target leftRoot hstored hleftSupport⟩ + +theorem RootEncodingCacheRelates.toStored + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} + {left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + (hrel : RootEncodingCacheRelates parameter target leftRoot rightRoot left right) : + RootEncodingCacheRelatesStored parameter target leftRoot rightRoot left right := by + intro leftCache rightCache hcache state fuel table hstored + exact relTriple_rootEncoding_add_stored parameter target leftRoot rightRoot left right + leftCache rightCache state fuel table + (hrel leftCache rightCache hcache state fuel table) hstored + +theorem RootEncodingCacheRelatesStored.bind + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {leftNext rightNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hfirst : RootEncodingCacheRelatesStored parameter target leftRoot rightRoot left right) + (hnext : ∀ leftValue rightValue, leftValue = rightValue → + RootEncodingCacheRelatesStored parameter target leftRoot rightRoot + (leftNext leftValue) (rightNext rightValue)) : + RootEncodingCacheRelatesStored parameter target leftRoot rightRoot + (left >>= leftNext) (right >>= rightNext) := by + intro leftCache rightCache hcache state fuel table hstored + rw [StateT.run_bind, StateT.run_bind, runCleanFromTable_bind, + runCleanFromTable_bind] + apply relTriple_bind (hfirst leftCache rightCache hcache state fuel table hstored) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [RootEncodingStoredCleanSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootEncodingStoredCleanSameRel] at hresult + | some rightResult => + rcases hresult with + ⟨⟨hstate, hremaining, htable, hvalue, hnextCache⟩, hnextStored⟩ + simp only + rw [← hstate, ← hremaining, ← htable, ← hvalue] + exact hnext leftResult.value.1 leftResult.value.1 rfl leftResult.value.2 + rightResult.value.2 hnextCache leftResult.state leftResult.remaining + leftResult.table hnextStored + +theorem rootEncodingCacheRelatesStored_sequenceFin + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) {n : Nat} + (left right : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, + RootEncodingCacheRelatesStored parameter target leftRoot rightRoot + (left index) (right index)) : + RootEncodingCacheRelatesStored parameter target leftRoot rightRoot + (sequenceFin left) (sequenceFin right) := by + induction n with + | zero => + simp only [sequenceFin] + exact ((rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + Fin.elim0).relates).toStored + | succ n ih => + rw [sequenceFin, sequenceFin] + exact (hcomponent 0).bind fun leftHead rightHead hhead => + (ih (fun index : Fin n => left index.succ) (fun index : Fin n => right index.succ) + (fun index => hcomponent index.succ)).bind fun leftTail rightTail htail => by + subst rightHead + subst rightTail + exact ((rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (Fin.cases leftHead leftTail : Fin (n + 1) → α)).relates).toStored + +set_option maxRecDepth 100000 in +theorem maskedTreeRoot_eq_of_stored_clean + (lay : Layer) (tree : TreeIndex) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : CleanRunResult (Digest × SplitHashCache)) (root : Digest) + (hroot : StoredLayerRoot state (layerRootPosition lay tree) root) + (hresult : some result ∈ support + (runCleanFromTable state fuel table ((maskedTreeRoot lay tree).run cache))) : + result.value.1 = root ∧ StoredLayerRoot result.state (layerRootPosition lay tree) root := by + have hpos : 0 < layerHeight lay := by + unfold layerHeight + split <;> norm_num [maxLayerHeight] + have hlevel : layerHeight lay - 1 < maxLayerHeight := by + have hle := layerHeight_le lay + omega + unfold maskedTreeRoot at hresult + rw [show layerHeight lay = (layerHeight lay - 1) + 1 by omega, + maskedTreeNode, StateT.run_bind, runCleanFromTable_bind, + mem_support_bind_iff] at hresult + obtain ⟨administrative, hadministrative, hreveal⟩ := hresult + cases administrative with + | none => simp at hreveal + | some administrative => + have hmiddleRoot := storedLayerRoot_of_mem_runCleanFromTable + ((ensureTreeNode lay tree (layerHeight lay - 1 + 1) 0).run cache) + state fuel table administrative (layerRootPosition lay tree) root hroot + hadministrative + simp only at hreveal + rw [dif_pos hlevel] at hreveal + obtain ⟨output, hstored, htruncate⟩ := hmiddleRoot + change some result ∈ support + (runCleanFromTable administrative.state administrative.remaining administrative.table + ((revealCoordinate (.position (layerRootPosition lay tree))).run + administrative.value.2)) at hreveal + rw [runCleanFromTable_revealCoordinate_of_value _ output _ _ _ _ hstored] at hreveal + simp at hreveal + subst result + exact ⟨htruncate, ⟨output, hstored, htruncate⟩⟩ + +theorem maskedLayerMessage_eq_of_stored_clean_of_eq + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay below : Layer) + (hcomputation : maskedLayerMessage parameter ftsSecret index lay = + maskedTreeRoot below (treeIndexAt index below)) + (hposition : layerMessagePosition index lay = + layerRootPosition below (treeIndexAt index below)) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : CleanRunResult (Digest × SplitHashCache)) (root : Digest) + (hroot : StoredLayerRoot state (layerMessagePosition index lay) root) + (hresult : some result ∈ support + (runCleanFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run cache))) : + result.value.1 = root ∧ + StoredLayerRoot result.state (layerMessagePosition index lay) root := by + rw [hcomputation] at hresult + rw [hposition] at hroot ⊢ + exact maskedTreeRoot_eq_of_stored_clean below (treeIndexAt index below) + state cache fuel table result root hroot hresult + +theorem layerMessage_root_witness_of_isLayerRoot + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (index : Index) (lay : Layer) + (htarget : layerMessagePosition index lay = target) : + ∃ below : Layer, + maskedLayerMessage parameter ftsSecret index lay = + maskedTreeRoot below (treeIndexAt index below) ∧ + layerMessagePosition index lay = + layerRootPosition below (treeIndexAt index below) := by + have hnotBottom : lay ≠ bottomLayer := by + intro hbottom + subst lay + obtain ⟨rootLay, rootTree, hrootPosition⟩ := hroot + rw [layerMessagePosition_bottom] at htarget + rw [← htarget] at hrootPosition + simp [layerRootPosition] at hrootPosition + fin_cases lay + · have hbelow : topLayer.val + 1 < numLayers := by + norm_num [topLayer, numLayers] + refine ⟨middleLayer, maskedLayerMessage_eq_of_lt' parameter ftsSecret index topLayer + middleLayer hbelow (Fin.ext (by norm_num [topLayer, middleLayer, numLayers])), ?_⟩ + change layerMessagePosition index topLayer = + layerRootPosition middleLayer (treeIndexAt index middleLayer) + simp [layerRootPosition] + · have hbelow : middleLayer.val + 1 < numLayers := by + norm_num [middleLayer, numLayers] + refine ⟨bottomLayer, maskedLayerMessage_eq_of_lt' parameter ftsSecret index middleLayer + bottomLayer hbelow (Fin.ext (by norm_num [middleLayer, bottomLayer, numLayers])), ?_⟩ + change layerMessagePosition index middleLayer = + layerRootPosition bottomLayer (treeIndexAt index bottomLayer) + simp [layerRootPosition] + · exact False.elim (hnotBottom rfl) + +theorem maskedLayerMessage_value_eq_of_stored_clean + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) (root : Digest) + (index : Index) (lay : Layer) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : CleanRunResult (Digest × SplitHashCache)) + (hstored : StoredLayerRoot state target root) + (htarget : layerMessagePosition index lay = target) + (hresult : some result ∈ support + (runCleanFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run cache))) : + result.value.1 = root := by + obtain ⟨below, hcomputation, hposition⟩ := + layerMessage_root_witness_of_isLayerRoot parameter ftsSecret target hroot index lay htarget + have hstoredMessage : StoredLayerRoot state (layerMessagePosition index lay) root := by + rw [htarget] + exact hstored + exact (maskedLayerMessage_eq_of_stored_clean_of_eq parameter ftsSecret index lay below + hcomputation hposition state cache fuel table result root hstoredMessage hresult).1 + +set_option maxRecDepth 100000 in +theorem maskedTreeRoot_eq_of_stored + (lay : Layer) (tree : TreeIndex) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) + (value : Digest) (output : HashOutput) + (hvalue : state.values (.position (layerRootPosition lay tree)) = some output) + (hresult : LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ + support (LazyRevealProbe.runRaw state fuel ((maskedTreeRoot lay tree).run cache))) : + value = truncateHash output := by + have hpos : 0 < layerHeight lay := by + unfold layerHeight + split <;> norm_num [maxLayerHeight] + have hlevel : layerHeight lay - 1 < maxLayerHeight := by + have hle := layerHeight_le lay + omega + unfold maskedTreeRoot at hresult + rw [show layerHeight lay = (layerHeight lay - 1) + 1 by omega, + maskedTreeNode, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hresult + obtain ⟨administrative, hadministrative, hreveal⟩ := hresult + cases administrative with + | stopped hit => simp at hreveal + | done middleState middleRemaining administrativeResult => + rcases administrativeResult with ⟨_, middleCache⟩ + have hpreserved := preservesCoordinate_ensureTreeNode + (.position (layerRootPosition lay tree)) lay tree (layerHeight lay - 1 + 1) 0 + state cache fuel middleState middleRemaining () middleCache hadministrative + have hmiddleValue : middleState.values (.position (layerRootPosition lay tree)) = + some output := hpreserved.1.trans hvalue + simp only at hreveal + rw [dif_pos hlevel] at hreveal + change LazyRevealProbe.RawResult.done finalState remaining (value, finalCache) ∈ support + (LazyRevealProbe.runRaw middleState middleRemaining + ((revealCoordinate (.position (layerRootPosition lay tree))).run middleCache)) at hreveal + rw [revealCoordinate_run, LazyRevealProbe.revealQuery, + LazyRevealProbe.runRaw_reveal_query_bind, hmiddleValue] at hreveal + simp [LazyRevealProbe.runRaw] at hreveal + exact hreveal.2.2.1 + +noncomputable def maskedSignLayerWithComparisonRoot + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) (comparisonRoot : Digest) : + StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) + (Option (Counter × (ChainIndex → Digit))) := do + let _ ← maskedLayerMessage parameter ftsSecret index lay + maskedOtsLayerAfterMessage parameter index lay comparisonRoot + +theorem not_encodingPositionNamesRoot_of_layerMessagePosition_ne + (target : Position) (index : Index) (lay : Layer) + (hne : layerMessagePosition index lay ≠ target) : + ¬EncodingPositionNamesRoot target + ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩ := by + rintro ⟨otherIndex, htree, hleaf, _hnotBottom, htarget⟩ + apply hne + rw [htarget] + exact (layerMessagePosition_eq_of_position_eq otherIndex index lay htree hleaf).symm + +theorem rootEncodingCacheCouples_maskedSignLayer_of_layerMessagePosition_ne + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) + (hne : layerMessagePosition index lay ≠ target) : + RootEncodingCacheCouples parameter target leftRoot rightRoot + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + apply (rootEncodingCacheCouples_maskedLayerMessage parameter target leftRoot rightRoot + ftsSecret index lay).bind + intro message + exact rootEncodingCacheCouples_maskedOtsLayerAfterMessage_of_not_positionNames parameter + target leftRoot rightRoot index lay message + (not_encodingPositionNamesRoot_of_layerMessagePosition_ne target index lay hne) + +theorem layer_ne_bottom_of_layerMessagePosition_isLayerRoot + {target : Position} {index : Index} {lay : Layer} + (htarget : layerMessagePosition index lay = target) + (hroot : IsLayerRoot target) : lay ≠ bottomLayer := by + intro hbottom + subst lay + obtain ⟨rootLay, rootTree, hrootPosition⟩ := hroot + rw [layerMessagePosition_bottom] at htarget + rw [← htarget] at hrootPosition + simp [layerRootPosition] at hrootPosition + +noncomputable def maskedSignLayerWithTargetComparison + (parameter : PublicParameter) (target : Position) (comparisonRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) + (Option (Counter × (ChainIndex → Digit))) := + if layerMessagePosition index lay = target then + maskedSignLayerWithComparisonRoot parameter ftsSecret index lay comparisonRoot + else + maskedSignLayer parameter ftsSecret index lay + +noncomputable def maskedSignLayersWithTargetComparison + (parameter : PublicParameter) (target : Position) (comparisonRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) : + StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) + (Layer → Option (Counter × (ChainIndex → Digit))) := + sequenceFin fun lay => + maskedSignLayerWithTargetComparison parameter target comparisonRoot ftsSecret index lay + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_maskedSignLayer_comparisonRoot_of_message + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) (hnotBottom : lay ≠ bottomLayer) + (leftRoot rightRoot : Digest) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter (layerMessagePosition index lay) + leftRoot rightRoot leftCache rightCache) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hmessageRoot : ∀ result, + some result ∈ support (runCleanFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run leftCache)) → + result.value.1 = leftRoot) : + RelTriple + (runCleanFromTable state fuel table + ((maskedSignLayer parameter ftsSecret index lay).run leftCache)) + (runCleanFromTable state fuel table + ((maskedSignLayerWithComparisonRoot parameter ftsSecret index lay rightRoot).run + rightCache)) + (RootEncodingCleanSameRel parameter (layerMessagePosition index lay) + leftRoot rightRoot) := by + unfold maskedSignLayer maskedSignLayerWithComparisonRoot + change RelTriple + (runCleanFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay >>= fun message => + maskedOtsLayerAfterMessage parameter index lay message).run leftCache)) + (runCleanFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay >>= fun _ => + maskedOtsLayerAfterMessage parameter index lay rightRoot).run rightCache)) _ + rw [StateT.run_bind, StateT.run_bind, runCleanFromTable_bind, + runCleanFromTable_bind] + let leftMessageRun := runCleanFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run leftCache) + have hmessages := rootEncodingCacheCouples_maskedLayerMessage parameter + (layerMessagePosition index lay) leftRoot rightRoot ftsSecret index lay + leftCache rightCache hcache state fuel table + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hmessages + (fun result => result ∈ support leftMessageRun) (fun result hresult => hresult) + apply relTriple_bind hsupported + intro leftResult rightResult hresult + rcases hresult with ⟨hrelation, hleftSupport⟩ + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [RootEncodingCleanSameRel] at hrelation + | some leftResult => + cases rightResult with + | none => simp [RootEncodingCleanSameRel] at hrelation + | some rightResult => + rcases hrelation with ⟨hstate, hremaining, htable, _hmessage, hnextCache⟩ + have hactual := hmessageRoot leftResult hleftSupport + simp only + rw [← hstate, ← hremaining, ← htable, hactual] + exact rootEncodingCacheRelates_maskedOtsLayerAfterMessage parameter index lay + hnotBottom leftRoot rightRoot leftResult.value.2 rightResult.value.2 hnextCache + leftResult.state leftResult.remaining leftResult.table + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem relTriple_maskedSignLayer_targetComparison + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) + (leftCache rightCache : SplitHashCache) + (hcache : RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hmessageRoot : layerMessagePosition index lay = target → ∀ result, + some result ∈ support (runCleanFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run leftCache)) → + result.value.1 = leftRoot) : + RelTriple + (runCleanFromTable state fuel table + ((maskedSignLayer parameter ftsSecret index lay).run leftCache)) + (runCleanFromTable state fuel table + ((maskedSignLayerWithTargetComparison parameter target rightRoot ftsSecret index lay).run + rightCache)) + (RootEncodingCleanSameRel parameter target leftRoot rightRoot) := by + by_cases htarget : layerMessagePosition index lay = target + · rw [maskedSignLayerWithTargetComparison, if_pos htarget] + rw [← htarget] at hcache ⊢ + exact relTriple_maskedSignLayer_comparisonRoot_of_message parameter ftsSecret index lay + (layer_ne_bottom_of_layerMessagePosition_isLayerRoot htarget hroot) leftRoot rightRoot + leftCache rightCache hcache state fuel table (hmessageRoot htarget) + · rw [maskedSignLayerWithTargetComparison, if_neg htarget] + exact (rootEncodingCacheCouples_maskedSignLayer_of_layerMessagePosition_ne parameter target + leftRoot rightRoot ftsSecret index lay htarget).relates leftCache rightCache hcache + state fuel table + +theorem rootEncodingCacheRelatesStored_maskedSignLayer_targetComparison + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) : + RootEncodingCacheRelatesStored parameter target leftRoot rightRoot + (maskedSignLayer parameter ftsSecret index lay) + (maskedSignLayerWithTargetComparison parameter target rightRoot ftsSecret index lay) := by + intro leftCache rightCache hcache state fuel table hstored + have hbase := relTriple_maskedSignLayer_targetComparison parameter target hroot leftRoot + rightRoot ftsSecret index lay leftCache rightCache hcache state fuel table + (fun htarget result hresult => + maskedLayerMessage_value_eq_of_stored_clean parameter ftsSecret target hroot leftRoot + index lay state leftCache fuel table result hstored htarget hresult) + exact relTriple_rootEncoding_add_stored parameter target leftRoot rightRoot + (maskedSignLayer parameter ftsSecret index lay) + (maskedSignLayerWithTargetComparison parameter target rightRoot ftsSecret index lay) + leftCache rightCache state fuel table hbase hstored + +theorem rootEncodingCacheRelates_maskedSignLayers_targetComparison + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) + (hmessageRoot : ∀ lay leftCache rightCache, + RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache → + ∀ state fuel table, layerMessagePosition index lay = target → ∀ result, + some result ∈ support (runCleanFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run leftCache)) → + result.value.1 = leftRoot) : + RootEncodingCacheRelates parameter target leftRoot rightRoot + (sequenceFin fun lay => maskedSignLayer parameter ftsSecret index lay) + (maskedSignLayersWithTargetComparison parameter target rightRoot ftsSecret index) := by + unfold maskedSignLayersWithTargetComparison + apply rootEncodingCacheRelates_sequenceFin + intro lay leftCache rightCache hcache state fuel table + exact relTriple_maskedSignLayer_targetComparison parameter target hroot leftRoot rightRoot + ftsSecret index lay leftCache rightCache hcache state fuel table + (fun htarget => hmessageRoot lay leftCache rightCache hcache state fuel table htarget) + +theorem rootEncodingCacheRelatesStored_maskedSignLayers_targetComparison + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) : + RootEncodingCacheRelatesStored parameter target leftRoot rightRoot + (sequenceFin fun lay => maskedSignLayer parameter ftsSecret index lay) + (maskedSignLayersWithTargetComparison parameter target rightRoot ftsSecret index) := by + unfold maskedSignLayersWithTargetComparison + apply rootEncodingCacheRelatesStored_sequenceFin + intro lay + exact rootEncodingCacheRelatesStored_maskedSignLayer_targetComparison parameter target hroot + leftRoot rightRoot ftsSecret index lay + +noncomputable def maskedSignAfterDigestWithTargetComparison + (parameter : PublicParameter) (target : Position) (comparisonRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) + (Option Signature) := do + let ftsPath ← simulateQ ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index)) + let layers ← + maskedSignLayersWithTargetComparison parameter target comparisonRoot ftsSecret index + match traverseOption layers with + | none => pure none + | some parts => + let revealed ← sequenceFin fun lay => revealLayerValues index lay (parts lay).2 + pure (some + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (revealed lay).1 + authPath := flattenPaths fun lay => (revealed lay).2 }) + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem rootEncodingCacheRelates_maskedSignAfterDigest_targetComparison + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (hmessageRoot : ∀ lay leftCache rightCache, + RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache → + ∀ state fuel table, layerMessagePosition index lay = target → ∀ result, + some result ∈ support (runCleanFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run leftCache)) → + result.value.1 = leftRoot) : + RootEncodingCacheRelates parameter target leftRoot rightRoot + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) + (maskedSignAfterDigestWithTargetComparison parameter target rightRoot ftsSecret + randomness index leaves) := by + unfold maskedSignAfterDigest maskedSignAfterDigestWithTargetComparison + apply (rootEncodingCacheCouples_ftsOpen parameter target leftRoot rightRoot index leaves + (ftsSecret index)).relates.bind + intro leftPath rightPath hpath + subst rightPath + apply (rootEncodingCacheRelates_maskedSignLayers_targetComparison parameter target hroot + leftRoot rightRoot ftsSecret index hmessageRoot).bind + intro leftLayers rightLayers hlayers + subst rightLayers + cases hparts : traverseOption leftLayers with + | none => + exact (rootEncodingCacheCouples_pure parameter target leftRoot rightRoot none).relates + | some parts => + apply (rootEncodingCacheCouples_sequenceFin parameter target leftRoot rightRoot + (fun lay => revealLayerValues index lay (parts lay).2) + (fun lay => rootEncodingCacheCouples_revealLayerValues parameter target leftRoot + rightRoot index lay (parts lay).2)).bind + intro revealed + let signature : Signature := + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := leftPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (revealed lay).1 + authPath := flattenPaths fun lay => (revealed lay).2 } + exact (rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (some signature)).relates + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem rootEncodingCacheRelatesStored_maskedSignAfterDigest_targetComparison + (parameter : PublicParameter) (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + RootEncodingCacheRelatesStored parameter target leftRoot rightRoot + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) + (maskedSignAfterDigestWithTargetComparison parameter target rightRoot ftsSecret + randomness index leaves) := by + unfold maskedSignAfterDigest maskedSignAfterDigestWithTargetComparison + apply ((rootEncodingCacheCouples_ftsOpen parameter target leftRoot rightRoot index leaves + (ftsSecret index)).relates.toStored).bind + intro leftPath rightPath hpath + subst rightPath + apply (rootEncodingCacheRelatesStored_maskedSignLayers_targetComparison parameter target hroot + leftRoot rightRoot ftsSecret index).bind + intro leftLayers rightLayers hlayers + subst rightLayers + cases hparts : traverseOption leftLayers with + | none => + exact ((rootEncodingCacheCouples_pure parameter target leftRoot rightRoot none).relates).toStored + | some parts => + apply ((rootEncodingCacheCouples_sequenceFin parameter target leftRoot rightRoot + (fun lay => revealLayerValues index lay (parts lay).2) + (fun lay => rootEncodingCacheCouples_revealLayerValues parameter target leftRoot + rightRoot index lay (parts lay).2)).relates.toStored).bind + intro leftRevealed rightRevealed hrevealed + subst rightRevealed + let signature : Signature := + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := leftPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (leftRevealed lay).1 + authPath := flattenPaths fun lay => (leftRevealed lay).2 } + exact ((rootEncodingCacheCouples_pure parameter target leftRoot rightRoot + (some signature)).relates).toStored + +noncomputable def maskedSignWithTargetComparison + (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (comparisonRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) + (Option Signature) := do + let secretKey : SecretKey := + ⟨parameter, publicRoot, fun _ _ _ _ => 0, ftsSecret⟩ + match ← simulateQ ordinaryRomImpl + (signDigestLoop digestAttemptLimit secretKey message) with + | none => pure none + | some (randomness, index, leaves) => + maskedSignAfterDigestWithTargetComparison parameter target comparisonRoot ftsSecret + randomness index leaves + +theorem rootEncodingCacheRelates_maskedSign_targetComparison + (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (hmessageRoot : ∀ index lay leftCache rightCache, + RootEncodingCacheRel parameter target leftRoot rightRoot leftCache rightCache → + ∀ state fuel table, layerMessagePosition index lay = target → ∀ result, + some result ∈ support (runCleanFromTable state fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run leftCache)) → + result.value.1 = leftRoot) : + RootEncodingCacheRelates parameter target leftRoot rightRoot + (maskedSign parameter publicRoot ftsSecret message) + (maskedSignWithTargetComparison parameter publicRoot target rightRoot ftsSecret message) := by + unfold maskedSign maskedSignWithTargetComparison + let secretKey : SecretKey := + ⟨parameter, publicRoot, fun _ _ _ _ => 0, ftsSecret⟩ + apply (rootEncodingCacheCouples_signDigestLoop target leftRoot rightRoot secretKey message + digestAttemptLimit).relates.bind + intro leftSelected rightSelected hselected + subst rightSelected + cases leftSelected with + | none => + exact (rootEncodingCacheCouples_pure parameter target leftRoot rightRoot none).relates + | some selected => + exact rootEncodingCacheRelates_maskedSignAfterDigest_targetComparison parameter target + hroot leftRoot rightRoot ftsSecret selected.1 selected.2.1 selected.2.2 + (hmessageRoot selected.2.1) + +theorem rootEncodingCacheRelatesStored_maskedSign_targetComparison + (parameter : PublicParameter) (publicRoot : Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftRoot rightRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + RootEncodingCacheRelatesStored parameter target leftRoot rightRoot + (maskedSign parameter publicRoot ftsSecret message) + (maskedSignWithTargetComparison parameter publicRoot target rightRoot ftsSecret message) := by + unfold maskedSign maskedSignWithTargetComparison + let secretKey : SecretKey := + ⟨parameter, publicRoot, fun _ _ _ _ => 0, ftsSecret⟩ + apply ((rootEncodingCacheCouples_signDigestLoop target leftRoot rightRoot secretKey message + digestAttemptLimit).relates.toStored).bind + intro leftSelected rightSelected hselected + subst rightSelected + cases leftSelected with + | none => + exact ((rootEncodingCacheCouples_pure parameter target leftRoot rightRoot none).relates).toStored + | some selected => + exact rootEncodingCacheRelatesStored_maskedSignAfterDigest_targetComparison parameter + target hroot leftRoot rightRoot ftsSecret selected.1 selected.2.1 selected.2.2 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootState.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootState.lean new file mode 100644 index 00000000..c61669f9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootState.lean @@ -0,0 +1,714 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSwapCache + +/-! +# Hidden layer-root state quotient + +Two delayed-root runs may store different full outputs at one unpublished structural position while +all public lazy-state bookkeeping remains equal. This quotient isolates that one cell and is the +state-side companion of `RootEncodingCacheRel`. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +structure RootHiddenStateRel + (target : Position) (leftOutput rightOutput : HashOutput) + (left right : LazyRevealProbe.State Coordinate) : Prop where + pending : left.pending = right.pending + revealed : left.revealed = right.revealed + ensured : left.ensured = right.ensured + target_private : Coordinate.position target ∉ left.revealed + left_target : left.values (.position target) = some leftOutput + right_target : right.values (.position target) = some rightOutput + other_values : ∀ coordinate, coordinate ≠ .position target → + left.values coordinate = right.values coordinate + +theorem RootHiddenStateRel.refl + (target : Position) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) + (hprivate : Coordinate.position target ∉ state.revealed) + (hvalue : state.values (.position target) = some output) : + RootHiddenStateRel target output output state state := + ⟨rfl, rfl, rfl, hprivate, hvalue, hvalue, fun _ _ => rfl⟩ + +theorem RootHiddenStateRel.symm + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : RootHiddenStateRel target leftOutput rightOutput left right) : + RootHiddenStateRel target rightOutput leftOutput right left := by + refine ⟨hrel.pending.symm, hrel.revealed.symm, hrel.ensured.symm, ?_, + hrel.right_target, hrel.left_target, ?_⟩ + · intro hmem + apply hrel.target_private + rw [hrel.revealed] + exact hmem + · intro coordinate hne + exact (hrel.other_values coordinate hne).symm + +theorem rootHiddenStateRel_materialize + (target : Position) (leftOutput rightOutput : HashOutput) + (state : LazyRevealProbe.State Coordinate) + (hprivate : Coordinate.position target ∉ state.revealed) : + RootHiddenStateRel target leftOutput rightOutput + (state.materialize (.position target) leftOutput) + (state.materialize (.position target) rightOutput) := by + refine ⟨rfl, rfl, rfl, hprivate, ?_, ?_, ?_⟩ + · simp [LazyRevealProbe.State.materialize] + · simp [LazyRevealProbe.State.materialize] + · intro coordinate hne + simp [LazyRevealProbe.State.materialize, Function.update_of_ne hne] + +theorem RootHiddenStateRel.values_isSome_eq + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : RootHiddenStateRel target leftOutput rightOutput left right) + (coordinate : Coordinate) : + (left.values coordinate).isSome = (right.values coordinate).isSome := by + by_cases heq : coordinate = .position target + · subst coordinate + rw [hrel.left_target, hrel.right_target] + rfl + · rw [hrel.other_values coordinate heq] + +theorem RootHiddenStateRel.hitAt_eq + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : RootHiddenStateRel target leftOutput rightOutput left right) + (coordinate : Coordinate) (output : HashOutput) : + left.hitAt coordinate output ↔ right.hitAt coordinate output := by + unfold LazyRevealProbe.State.hitAt LazyRevealProbe.State.pendingAt + rw [hrel.pending] + +theorem RootHiddenStateRel.ensure + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : RootHiddenStateRel target leftOutput rightOutput left right) + (coordinate : Coordinate) : + RootHiddenStateRel target leftOutput rightOutput + (left.ensure coordinate) (right.ensure coordinate) := by + refine ⟨hrel.pending, hrel.revealed, ?_, hrel.target_private, + hrel.left_target, hrel.right_target, hrel.other_values⟩ + simp [LazyRevealProbe.State.ensure, hrel.ensured] + +theorem RootHiddenStateRel.addPending + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : RootHiddenStateRel target leftOutput rightOutput left right) + (coordinate : Coordinate) (candidate : Digest) : + RootHiddenStateRel target leftOutput rightOutput + (left.addPending coordinate candidate) (right.addPending coordinate candidate) := by + refine ⟨?_, hrel.revealed, hrel.ensured, hrel.target_private, + hrel.left_target, hrel.right_target, hrel.other_values⟩ + simp [LazyRevealProbe.State.addPending, hrel.pending] + +theorem RootHiddenStateRel.clearPending + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : RootHiddenStateRel target leftOutput rightOutput left right) + (coordinate : Coordinate) : + RootHiddenStateRel target leftOutput rightOutput + (left.clearPending coordinate) (right.clearPending coordinate) := by + refine ⟨?_, hrel.revealed, hrel.ensured, hrel.target_private, + hrel.left_target, hrel.right_target, hrel.other_values⟩ + simp [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway, hrel.pending] + +theorem RootHiddenStateRel.publish_of_ne + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : RootHiddenStateRel target leftOutput rightOutput left right) + (coordinate : Coordinate) (hne : coordinate ≠ .position target) : + RootHiddenStateRel target leftOutput rightOutput + (left.publish coordinate) (right.publish coordinate) := by + refine ⟨hrel.pending, ?_, hrel.ensured, ?_, + hrel.left_target, hrel.right_target, hrel.other_values⟩ + · simp [LazyRevealProbe.State.publish, hrel.revealed] + · simp [LazyRevealProbe.State.publish, hrel.target_private, Ne.symm hne] + +theorem RootHiddenStateRel.materialize_other + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : RootHiddenStateRel target leftOutput rightOutput left right) + (coordinate : Coordinate) (output : HashOutput) + (hne : coordinate ≠ .position target) : + RootHiddenStateRel target leftOutput rightOutput + (left.materialize coordinate output) (right.materialize coordinate output) := by + refine ⟨?_, hrel.revealed, ?_, hrel.target_private, ?_, ?_, ?_⟩ + · simp [LazyRevealProbe.State.materialize, LazyRevealProbe.State.pendingAway, hrel.pending] + · simp [LazyRevealProbe.State.materialize, hrel.ensured] + · simpa [LazyRevealProbe.State.materialize, Function.update_of_ne hne.symm] + using hrel.left_target + · simpa [LazyRevealProbe.State.materialize, Function.update_of_ne hne.symm] + using hrel.right_target + · intro other hother + by_cases heq : other = coordinate + · subst other + simp [LazyRevealProbe.State.materialize] + · simp [LazyRevealProbe.State.materialize, Function.update_of_ne heq, + hrel.other_values other hother] + +theorem firstMissingInputCoordinatePlan_eq_of_rootHiddenStateRel + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : RootHiddenStateRel target leftOutput rightOutput left right) + (input : HashInput) : ∀ slot coordinates, + firstMissingInputCoordinatePlan left input slot coordinates = + firstMissingInputCoordinatePlan right input slot coordinates := by + intro slot coordinates + induction coordinates generalizing slot with + | nil => rfl + | cons coordinate remaining ih => + rw [firstMissingInputCoordinatePlan, firstMissingInputCoordinatePlan] + have hpresent := hrel.values_isSome_eq coordinate + cases hleft : left.values coordinate with + | none => + cases hright : right.values coordinate with + | none => rfl + | some rightValue => simp [hleft, hright] at hpresent + | some leftValue => + cases hright : right.values coordinate with + | none => simp [hleft, hright] at hpresent + | some rightValue => + exact ih (slot + 1) + +theorem leafInputProbePlan_eq_of_rootHiddenStateRel + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : RootHiddenStateRel target leftOutput rightOutput left right) + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + leafInputProbePlan left input candidate lay tree leafIdx = + leafInputProbePlan right input candidate lay tree leafIdx := by + unfold leafInputProbePlan + have hpresent := hrel.values_isSome_eq candidate.coordinate + cases hleft : left.values candidate.coordinate with + | none => + cases hright : right.values candidate.coordinate with + | none => rfl + | some rightValue => simp [hleft, hright] at hpresent + | some leftValue => + cases hright : right.values candidate.coordinate with + | none => simp [hleft, hright] at hpresent + | some rightValue => + exact firstMissingInputCoordinatePlan_eq_of_rootHiddenStateRel hrel input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + +theorem purePlanProbingHashQuery_eq_of_rootHiddenStateRel + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : RootHiddenStateRel target leftOutput rightOutput left right) + (parameter : PublicParameter) (input : HashInput) : + purePlanProbingHashQuery parameter input left = + purePlanProbingHashQuery parameter input right := by + unfold purePlanProbingHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases hposition : decodePosition? parameter input with + | none => rfl + | some position => + cases position with + | leaf lay tree leafIdx => + simp only + rw [leafInputProbePlan_eq_of_rootHiddenStateRel hrel] + | chain | node | ftsLeaf | ftsNode | ftsRoots => rfl + | none => + cases hposition : decodePosition? parameter input with + | none => rfl + | some position => + cases position with + | node lay tree level nodeIdx => + simp only + rw [firstMissingInputCoordinatePlan_eq_of_rootHiddenStateRel hrel] + | chain | leaf | ftsLeaf | ftsNode | ftsRoots => rfl + +theorem rootAwarePlannedCandidate?_eq_of_rootHiddenStateRel + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : LazyRevealProbe.State Coordinate} + (hrel : RootHiddenStateRel target leftOutput rightOutput left right) + (parameter : PublicParameter) (input : HashInput) : + rootAwarePlannedCandidate? parameter input left = + rootAwarePlannedCandidate? parameter input right := by + unfold rootAwarePlannedCandidate? + rw [purePlanProbingHashQuery_eq_of_rootHiddenStateRel hrel parameter input] + +theorem runCleanFromTable_pure_oracle + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (value : α) : + runCleanFromTable state fuel table + (pure value : OracleComp (LazyRevealProbe.World Coordinate) α) = + pure (some ⟨state, fuel, value, table⟩) := by + simp [runCleanFromTable] + +theorem runCleanFromTable_planFirstMissingInputCoordinate + (state : LazyRevealProbe.State Coordinate) (input : HashInput) : + ∀ slot coordinates fuel table cache, + runCleanFromTable state fuel table + ((planFirstMissingInputCoordinate input slot coordinates).run cache) = + pure (some ⟨state, fuel, + (firstMissingInputCoordinatePlan state input slot coordinates, cache), table⟩) := by + intro slot coordinates + induction coordinates generalizing slot with + | nil => + intro fuel table cache + simp [planFirstMissingInputCoordinate, firstMissingInputCoordinatePlan, runCleanFromTable] + | cons coordinate remaining ih => + intro fuel table cache + rw [planFirstMissingInputCoordinate, StateT.run_bind, runCleanFromTable_bind, + peekCoordinate_run_eq, LazyRevealProbe.peekQuery, runCleanFromTable_peek_query_bind] + rw [runCleanFromTable_pure_oracle] + simp only [pure_bind] + cases hvalue : state.values coordinate with + | none => simp [hvalue, firstMissingInputCoordinatePlan, runCleanFromTable] + | some output => + rw [show truncateHash <$> some output = some (truncateHash output) by rfl] + rw [ih (slot + 1) fuel table cache] + simp [hvalue, firstMissingInputCoordinatePlan] + +theorem runCleanFromTable_planLeafInputProbe + (state : LazyRevealProbe.State Coordinate) + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runCleanFromTable state fuel table + ((planLeafInputProbe input candidate lay tree leafIdx).run cache) = + pure (some ⟨state, fuel, + (leafInputProbePlan state input candidate lay tree leafIdx, cache), table⟩) := by + rw [planLeafInputProbe, StateT.run_bind, runCleanFromTable_bind, + peekCoordinate_run_eq, LazyRevealProbe.peekQuery, runCleanFromTable_peek_query_bind] + rw [runCleanFromTable_pure_oracle] + simp only [pure_bind] + cases hvalue : state.values candidate.coordinate with + | none => simp [hvalue, leafInputProbePlan, runCleanFromTable] + | some output => + rw [show truncateHash <$> some output = some (truncateHash output) by rfl] + rw [runCleanFromTable_planFirstMissingInputCoordinate state input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) fuel table cache] + simp [hvalue, leafInputProbePlan] + +theorem runCleanFromTable_planProbingHashQuery + (parameter : PublicParameter) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + runCleanFromTable state fuel table + ((planProbingHashQuery parameter input).run cache) = + pure (some ⟨state, fuel, + (purePlanProbingHashQuery parameter input state, cache), table⟩) := by + unfold planProbingHashQuery purePlanProbingHashQuery + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases hposition : decodePosition? parameter input with + | none => simp [runCleanFromTable] + | some position => + cases position with + | leaf lay tree leafIdx => + simp only [StateT.run_bind, runCleanFromTable_bind] + rw [runCleanFromTable_planLeafInputProbe] + simp [runCleanFromTable] + | chain | node | ftsLeaf | ftsNode | ftsRoots => + simp [runCleanFromTable] + | none => + cases hposition : decodePosition? parameter input with + | none => simp [runCleanFromTable] + | some position => + cases position with + | node lay tree level nodeIdx => + simp only [StateT.run_bind, runCleanFromTable_bind] + rw [runCleanFromTable_planFirstMissingInputCoordinate] + simp [runCleanFromTable] + | chain | leaf | ftsLeaf | ftsNode | ftsRoots => + simp [runCleanFromTable] + +structure RootHiddenCacheRel + (target : Position) (leftOutput rightOutput : HashOutput) + (left right : SplitHashCache) : Prop where + ordinary : ∀ input, left (.ordinary input) = right (.ordinary input) + left_target : left (.hidden (.position target)) = some leftOutput + right_target : right (.hidden (.position target)) = some rightOutput + other_hidden : ∀ coordinate, coordinate ≠ .position target → + left (.hidden coordinate) = right (.hidden coordinate) + +theorem RootHiddenCacheRel.symm + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : SplitHashCache} + (hrel : RootHiddenCacheRel target leftOutput rightOutput left right) : + RootHiddenCacheRel target rightOutput leftOutput right left := + ⟨fun input => (hrel.ordinary input).symm, hrel.right_target, hrel.left_target, + fun coordinate hne => (hrel.other_hidden coordinate hne).symm⟩ + +theorem RootHiddenCacheRel.update_same_ordinary + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : SplitHashCache} + (hrel : RootHiddenCacheRel target leftOutput rightOutput left right) + (input : HashInput) (output : HashOutput) : + RootHiddenCacheRel target leftOutput rightOutput + (Function.update left (.ordinary input) (some output)) + (Function.update right (.ordinary input) (some output)) := by + refine ⟨?_, ?_, ?_, ?_⟩ + · intro other + by_cases heq : SplitHashKey.ordinary other = .ordinary input + · simp [heq] + · simp [Function.update_of_ne heq, hrel.ordinary other] + · simp [hrel.left_target] + · simp [hrel.right_target] + · intro coordinate hne + simp [hrel.other_hidden coordinate hne] + +theorem RootHiddenCacheRel.update_same_hidden_of_ne + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : SplitHashCache} + (hrel : RootHiddenCacheRel target leftOutput rightOutput left right) + (coordinate : Coordinate) (output : HashOutput) + (hne : coordinate ≠ .position target) : + RootHiddenCacheRel target leftOutput rightOutput + (Function.update left (.hidden coordinate) (some output)) + (Function.update right (.hidden coordinate) (some output)) := by + refine ⟨?_, ?_, ?_, ?_⟩ + · intro input + simp [hrel.ordinary input] + · have hkey : SplitHashKey.hidden (.position target) ≠ .hidden coordinate := by + intro heq + exact hne (SplitHashKey.hidden.inj heq).symm + simp [Function.update_of_ne hkey, hrel.left_target] + · have hkey : SplitHashKey.hidden (.position target) ≠ .hidden coordinate := by + intro heq + exact hne (SplitHashKey.hidden.inj heq).symm + simp [Function.update_of_ne hkey, hrel.right_target] + · intro other hother + by_cases heq : SplitHashKey.hidden other = .hidden coordinate + · simp [heq] + · simp [Function.update_of_ne heq, hrel.other_hidden other hother] + +def replaceHiddenRootCache + (target : Position) (output : HashOutput) (cache : SplitHashCache) : SplitHashCache := + Function.update cache (.hidden (.position target)) (some output) + +theorem rootHiddenCacheRel_replace + (target : Position) (leftOutput rightOutput : HashOutput) + (cache : SplitHashCache) + (hleft : cache (.hidden (.position target)) = some leftOutput) : + RootHiddenCacheRel target leftOutput rightOutput cache + (replaceHiddenRootCache target rightOutput cache) := by + refine ⟨?_, hleft, ?_, ?_⟩ + · intro input + simp [replaceHiddenRootCache] + · simp [replaceHiddenRootCache] + · intro coordinate hne + have hkey : SplitHashKey.hidden coordinate ≠ .hidden (.position target) := by + intro heq + exact hne (SplitHashKey.hidden.inj heq) + simp [replaceHiddenRootCache, Function.update_of_ne hkey] + +theorem replaceHiddenRootCache_involutive + (target : Position) (leftOutput rightOutput : HashOutput) + (cache : SplitHashCache) + (hleft : cache (.hidden (.position target)) = some leftOutput) : + replaceHiddenRootCache target leftOutput + (replaceHiddenRootCache target rightOutput cache) = cache := by + funext key + by_cases heq : key = .hidden (.position target) + · subst key + simp [replaceHiddenRootCache, hleft] + · simp [replaceHiddenRootCache, Function.update_of_ne heq] + +def RootHiddenCleanSameRel + (target : Position) (leftOutput rightOutput : HashOutput) : + Option (CleanRunResult (α × SplitHashCache)) → + Option (CleanRunResult (α × SplitHashCache)) → Prop + | some left, some right => + RootHiddenStateRel target leftOutput rightOutput left.state right.state ∧ + left.remaining = right.remaining ∧ left.table = right.table ∧ + left.value.1 = right.value.1 ∧ + RootHiddenCacheRel target leftOutput rightOutput left.value.2 right.value.2 + | none, none => True + | _, _ => False + +def RootHiddenRelates + (target : Position) (leftOutput rightOutput : HashOutput) + (left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ leftState rightState, + RootHiddenStateRel target leftOutput rightOutput leftState rightState → + ∀ fuel table leftCache rightCache, + RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache → + RelTriple + (runCleanFromTable leftState fuel table (left.run leftCache)) + (runCleanFromTable rightState fuel table (right.run rightCache)) + (RootHiddenCleanSameRel target leftOutput rightOutput) + +theorem rootHiddenRelates_pure + (target : Position) (leftOutput rightOutput : HashOutput) (value : α) : + RootHiddenRelates target leftOutput rightOutput + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + simp only [StateT.run_pure, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, rfl, hcache⟩ + +theorem RootHiddenRelates.bind + {target : Position} {leftOutput rightOutput : HashOutput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {leftNext rightNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hfirst : RootHiddenRelates target leftOutput rightOutput left right) + (hnext : ∀ leftValue rightValue, leftValue = rightValue → + RootHiddenRelates target leftOutput rightOutput + (leftNext leftValue) (rightNext rightValue)) : + RootHiddenRelates target leftOutput rightOutput + (left >>= leftNext) (right >>= rightNext) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + rw [StateT.run_bind, StateT.run_bind, runCleanFromTable_bind, + runCleanFromTable_bind] + apply relTriple_bind + (hfirst leftState rightState hstate fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [RootHiddenCleanSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootHiddenCleanSameRel] at hresult + | some rightResult => + rcases hresult with ⟨hnextState, hremaining, htable, hvalue, hnextCache⟩ + simp only + rw [← hremaining, ← htable, ← hvalue] + exact hnext leftResult.value.1 leftResult.value.1 rfl + leftResult.state rightResult.state hnextState leftResult.remaining + leftResult.table leftResult.value.2 rightResult.value.2 hnextCache + +theorem rootHiddenRelates_planProbingHashQuery + (target : Position) (leftOutput rightOutput : HashOutput) + (parameter : PublicParameter) (input : HashInput) : + RootHiddenRelates target leftOutput rightOutput + (planProbingHashQuery parameter input) + (planProbingHashQuery parameter input) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + rw [runCleanFromTable_planProbingHashQuery, + runCleanFromTable_planProbingHashQuery] + apply relTriple_pure_pure + refine ⟨hstate, rfl, rfl, ?_, hcache⟩ + exact congrArg id + (purePlanProbingHashQuery_eq_of_rootHiddenStateRel hstate parameter input) + +theorem rootHiddenRelates_splitUniformImpl + (target : Position) (leftOutput rightOutput : HashOutput) (n : Nat) : + RootHiddenRelates target leftOutput rightOutput + (splitUniformImpl n) (splitUniformImpl n) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + unfold splitUniformImpl LazyRevealProbe.uniformQuery + rw [StateT.run_liftM, StateT.run_liftM, + runCleanFromTable_uniform_query_bind, runCleanFromTable_uniform_query_bind] + apply relTriple_bind + (relTriple_refl (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))) + intro leftValue rightValue hvalue + subst rightValue + simp only [runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, rfl, hcache⟩ + +theorem rootHiddenRelates_ensureCoordinate + (target : Position) (leftOutput rightOutput : HashOutput) + (coordinate : Coordinate) : + RootHiddenRelates target leftOutput rightOutput + (ensureCoordinate coordinate) (ensureCoordinate coordinate) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + rw [runCleanFromTable_ensureCoordinate, runCleanFromTable_ensureCoordinate] + exact relTriple_pure_pure ⟨hstate.ensure coordinate, rfl, rfl, rfl, hcache⟩ + +theorem rootHiddenRelates_probe + (target : Position) (leftOutput rightOutput : HashOutput) + (candidate : Probe) : + RootHiddenRelates target leftOutput rightOutput + (probe candidate) (probe candidate) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + unfold probe LazyRevealProbe.probeQuery + rw [StateT.run_liftM, StateT.run_liftM, + runCleanFromTable_probe_query_bind, runCleanFromTable_probe_query_bind] + cases fuel with + | zero => exact relTriple_pure_pure trivial + | succ remaining => + have hrevealed : candidate.coordinate ∈ leftState.revealed ↔ + candidate.coordinate ∈ rightState.revealed := by rw [hstate.revealed] + by_cases hleftRevealed : candidate.coordinate ∈ leftState.revealed + · have hrightRevealed := hrevealed.mp hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte, + runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, rfl, hcache⟩ + · have hrightRevealed : candidate.coordinate ∉ rightState.revealed := + fun hmem => hleftRevealed (hrevealed.mpr hmem) + simp only [hleftRevealed, hrightRevealed, ↓reduceIte, + runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate.addPending candidate.coordinate candidate.candidate, + rfl, rfl, rfl, hcache⟩ + +theorem rootHiddenRelates_splitHashQuery_ordinary + (target : Position) (leftOutput rightOutput : HashOutput) + (input : HashInput) : + RootHiddenRelates target leftOutput rightOutput + (splitHashQuery (.ordinary input)) (splitHashQuery (.ordinary input)) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + have hlookup := hcache.ordinary input + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + cases hleft : leftCache (.ordinary input) with + | some output => + have hright : rightCache (.ordinary input) = some output := by + rw [← hlookup] + exact hleft + simp only [hright, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, rfl, hcache⟩ + | none => + have hright : rightCache (.ordinary input) = none := by + rw [← hlookup] + exact hleft + simp only [hright] + unfold LazyRevealProbe.hashOutputQuery + rw [runCleanFromTable_hashOutput_query_bind, + runCleanFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftSample rightSample hsample + subst rightSample + simp only [runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, rfl, + hcache.update_same_ordinary input leftSample⟩ + +theorem rootHiddenRelates_revealCoordinate_of_ne + (target : Position) (leftOutput rightOutput : HashOutput) + (coordinate : Coordinate) (hne : coordinate ≠ .position target) : + RootHiddenRelates target leftOutput rightOutput + (revealCoordinate coordinate) (revealCoordinate coordinate) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + rw [revealCoordinate_run, revealCoordinate_run, LazyRevealProbe.revealQuery, + runCleanFromTable_reveal_query_bind, runCleanFromTable_reveal_query_bind] + have hvalue := hstate.other_values coordinate hne + cases hleft : leftState.values coordinate with + | some output => + have hright : rightState.values coordinate = some output := by + rw [← hvalue] + exact hleft + simp only [hright, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, rfl, + hcache.update_same_hidden_of_ne coordinate output hne⟩ + | none => + have hright : rightState.values coordinate = none := by + rw [← hvalue] + exact hleft + simp only [hright] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + have hhit := hstate.hitAt_eq (.chainStart lay tree leafIdx chainIdx) output + by_cases hleftHit : leftState.hitAt (.chainStart lay tree leafIdx chainIdx) output + · have hrightHit := hhit.mp hleftHit + change leftState.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) at hleftHit + change rightState.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) at hrightHit + rw [if_pos hleftHit, if_pos hrightHit] + exact relTriple_pure_pure trivial + · have hrightHit : ¬rightState.hitAt + (.chainStart lay tree leafIdx chainIdx) output := + fun h => hleftHit (hhit.mpr h) + simp only [output, hleftHit, hrightHit, ↓reduceIte, + runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate.materialize_other + (.chainStart lay tree leafIdx chainIdx) output hne, + rfl, rfl, rfl, + hcache.update_same_hidden_of_ne + (.chainStart lay tree leafIdx chainIdx) output hne⟩ + | position position => + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftSample rightSample hsample + subst rightSample + have hhit := hstate.hitAt_eq (.position position) leftSample + by_cases hleftHit : leftState.hitAt (.position position) leftSample + · have hrightHit := hhit.mp hleftHit + simp [hleftHit, hrightHit, RootHiddenCleanSameRel] + · have hrightHit : ¬rightState.hitAt (.position position) leftSample := + fun h => hleftHit (hhit.mpr h) + simp only [hleftHit, hrightHit, ↓reduceIte, + runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate.materialize_other + (.position position) leftSample hne, + rfl, rfl, rfl, + hcache.update_same_hidden_of_ne (.position position) leftSample hne⟩ + +theorem rootHiddenRelates_revealPosition_of_ne + (target : Position) (leftOutput rightOutput : HashOutput) + (position : Position) (hne : position ≠ target) : + RootHiddenRelates target leftOutput rightOutput + (revealPosition position) (revealPosition position) := by + exact rootHiddenRelates_revealCoordinate_of_ne target leftOutput rightOutput + (.position position) (by simpa using hne) + +theorem rootHiddenRelates_publishCoordinate_of_ne + (target : Position) (leftOutput rightOutput : HashOutput) + (coordinate : Coordinate) (hne : coordinate ≠ .position target) : + RootHiddenRelates target leftOutput rightOutput + (publishCoordinate coordinate) (publishCoordinate coordinate) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + rw [runCleanFromTable_publishCoordinate, runCleanFromTable_publishCoordinate] + exact relTriple_pure_pure ⟨hstate.publish_of_ne coordinate hne, rfl, rfl, rfl, hcache⟩ + +theorem rootHiddenRelates_revealPublishedCoordinate_of_ne + (target : Position) (leftOutput rightOutput : HashOutput) + (coordinate : Coordinate) (hne : coordinate ≠ .position target) : + RootHiddenRelates target leftOutput rightOutput + (revealPublishedCoordinate coordinate) (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + exact (rootHiddenRelates_revealCoordinate_of_ne target leftOutput rightOutput coordinate + hne).bind fun leftValue rightValue hvalue => + (rootHiddenRelates_publishCoordinate_of_ne target leftOutput rightOutput coordinate + hne).bind fun _ _ _ => by + subst rightValue + exact rootHiddenRelates_pure target leftOutput rightOutput leftValue + +theorem evalDist_cleanRunReturnedValue_eq_of_rootHidden + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + (hrelates : RootHiddenRelates target leftOutput rightOutput left right) + (leftState rightState : LazyRevealProbe.State Coordinate) + (hstate : RootHiddenStateRel target leftOutput rightOutput leftState rightState) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache) : + evalDist (cleanRunReturnedValue? <$> + runCleanFromTable leftState fuel table (left.run leftCache)) = + evalDist (cleanRunReturnedValue? <$> + runCleanFromTable rightState fuel table (right.run rightCache)) := by + have hrun := hrelates leftState rightState hstate fuel table leftCache rightCache hcache + have hprojected : RelTriple + (runCleanFromTable leftState fuel table (left.run leftCache)) + (runCleanFromTable rightState fuel table (right.run rightCache)) + (fun leftResult rightResult => + cleanRunReturnedValue? leftResult = cleanRunReturnedValue? rightResult) := by + apply relTriple_post_mono hrun + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => rfl + | some rightResult => simp [RootHiddenCleanSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootHiddenCleanSameRel] at hresult + | some rightResult => + simp only [RootHiddenCleanSameRel] at hresult + simp [cleanRunReturnedValue?, hresult.2.2.2.1] + have hmapped : RelTriple + (cleanRunReturnedValue? <$> + runCleanFromTable leftState fuel table (left.run leftCache)) + (cleanRunReturnedValue? <$> + runCleanFromTable rightState fuel table (right.run rightCache)) + (fun leftValue rightValue => leftValue = rightValue) := + relTriple_map hprojected + exact evalDist_eq_of_relTriple_eqRel hmapped + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootStateHash.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootStateHash.lean new file mode 100644 index 00000000..20800c8c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootStateHash.lean @@ -0,0 +1,328 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootStateSigner + +/-! +# Safe direct hash queries under swapped roots + +Structural input reconstruction may return different byte strings when one payload slot is the +hidden swapped root. The two runs nevertheless agree on whether every required value is present. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def OptionShapeRel : Option α → Option β → Prop + | none, none => True + | some _, some _ => True + | _, _ => False + +def RootHiddenCleanRelWith + (target : Position) (leftOutput rightOutput : HashOutput) + (valueRel : α → β → Prop) : + Option (CleanRunResult (α × SplitHashCache)) → + Option (CleanRunResult (β × SplitHashCache)) → Prop + | some left, some right => + RootHiddenStateRel target leftOutput rightOutput left.state right.state ∧ + left.remaining = right.remaining ∧ left.table = right.table ∧ + valueRel left.value.1 right.value.1 ∧ + RootHiddenCacheRel target leftOutput rightOutput left.value.2 right.value.2 + | none, none => True + | _, _ => False + +def RootHiddenRelatesWith + (target : Position) (leftOutput rightOutput : HashOutput) + (valueRel : α → β → Prop) + (left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β) : Prop := + ∀ leftState rightState, + RootHiddenStateRel target leftOutput rightOutput leftState rightState → + ∀ fuel table leftCache rightCache, + RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache → + RelTriple + (runCleanFromTable leftState fuel table (left.run leftCache)) + (runCleanFromTable rightState fuel table (right.run rightCache)) + (RootHiddenCleanRelWith target leftOutput rightOutput valueRel) + +theorem rootHiddenRelatesWith_pure + (target : Position) (leftOutput rightOutput : HashOutput) + (leftValue : α) (rightValue : β) (hvalue : R leftValue rightValue) : + RootHiddenRelatesWith target leftOutput rightOutput R + (pure leftValue) (pure rightValue) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + simp only [StateT.run_pure, runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, hvalue, hcache⟩ + +theorem rootHiddenRelatesWith_pure_optionShape + (target : Position) (leftOutput rightOutput : HashOutput) + (leftValue : Option α) (rightValue : Option β) + (hvalue : OptionShapeRel leftValue rightValue) : + RootHiddenRelatesWith target leftOutput rightOutput OptionShapeRel + (pure leftValue) (pure rightValue) := + rootHiddenRelatesWith_pure target leftOutput rightOutput leftValue rightValue hvalue + +theorem RootHiddenRelatesWith.bind + {target : Position} {leftOutput rightOutput : HashOutput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {right : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + {leftNext : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) γ} + {rightNext : β → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) δ} + (hfirst : RootHiddenRelatesWith target leftOutput rightOutput R left right) + (hnext : ∀ leftValue rightValue, R leftValue rightValue → + RootHiddenRelatesWith target leftOutput rightOutput S + (leftNext leftValue) (rightNext rightValue)) : + RootHiddenRelatesWith target leftOutput rightOutput S + (left >>= leftNext) (right >>= rightNext) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + rw [StateT.run_bind, StateT.run_bind, runCleanFromTable_bind, + runCleanFromTable_bind] + apply relTriple_bind + (hfirst leftState rightState hstate fuel table leftCache rightCache hcache) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [RootHiddenCleanRelWith] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootHiddenCleanRelWith] at hresult + | some rightResult => + rcases hresult with ⟨hnextState, hremaining, htable, hvalue, hnextCache⟩ + simp only + rw [← hremaining, ← htable] + exact hnext leftResult.value.1 rightResult.value.1 hvalue + leftResult.state rightResult.state hnextState leftResult.remaining leftResult.table + leftResult.value.2 rightResult.value.2 hnextCache + +theorem rootHiddenRelatesWith_peekCoordinate + (target : Position) (leftOutput rightOutput : HashOutput) + (coordinate : Coordinate) : + RootHiddenRelatesWith target leftOutput rightOutput OptionShapeRel + (peekCoordinate coordinate) (peekCoordinate coordinate) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + rw [peekCoordinate_run_eq, peekCoordinate_run_eq, LazyRevealProbe.peekQuery, + runCleanFromTable_peek_query_bind, runCleanFromTable_peek_query_bind] + simp only [runCleanFromTable, OracleComp.construct_pure] + refine relTriple_pure_pure ⟨hstate, rfl, rfl, ?_, hcache⟩ + have hpresent := hstate.values_isSome_eq coordinate + cases hleft : leftState.values coordinate <;> + cases hright : rightState.values coordinate <;> + simp [hleft, hright, OptionShapeRel] at hpresent ⊢ + +theorem rootHiddenRelatesWith_peekPositionValues + (target : Position) (leftOutput rightOutput : HashOutput) : ∀ positions, + RootHiddenRelatesWith target leftOutput rightOutput OptionShapeRel + (peekPositionValues positions) (peekPositionValues positions) + | [] => by + simp only [peekPositionValues] + exact rootHiddenRelatesWith_pure_optionShape target leftOutput rightOutput + (some []) (some []) trivial + | position :: remaining => by + simp only [peekPositionValues] + apply (rootHiddenRelatesWith_peekCoordinate target leftOutput rightOutput + (.position position)).bind + intro leftValue rightValue hvalue + cases leftValue with + | none => + cases rightValue with + | none => + simp only + exact rootHiddenRelatesWith_pure_optionShape target leftOutput rightOutput none none + trivial + | some rightValue => simp [OptionShapeRel] at hvalue + | some leftValue => + cases rightValue with + | none => simp [OptionShapeRel] at hvalue + | some rightValue => + apply (rootHiddenRelatesWith_peekPositionValues target leftOutput rightOutput + remaining).bind + intro leftTail rightTail htail + cases leftTail with + | none => + cases rightTail with + | none => + simp only + exact rootHiddenRelatesWith_pure_optionShape target leftOutput rightOutput + none none + trivial + | some rightTail => simp [OptionShapeRel] at htail + | some leftTail => + cases rightTail with + | none => simp [OptionShapeRel] at htail + | some rightTail => + simp only + exact rootHiddenRelatesWith_pure_optionShape target leftOutput rightOutput + (some (leftValue :: leftTail)) (some (rightValue :: rightTail)) trivial + +theorem rootHiddenRelatesWith_peekTableInput + (parameter : PublicParameter) + (target : Position) (leftOutput rightOutput : HashOutput) + (coordinate : Coordinate) : + RootHiddenRelatesWith target leftOutput rightOutput OptionShapeRel + (peekTableInput parameter coordinate) (peekTableInput parameter coordinate) := by + cases coordinate with + | chainStart => + exact rootHiddenRelatesWith_pure_optionShape target leftOutput rightOutput none none trivial + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput.eq_2] + by_cases hzero : step.val = 0 + · rw [if_pos hzero] + apply (rootHiddenRelatesWith_peekCoordinate target leftOutput rightOutput + (.chainStart lay tree leafIdx chainIdx)).bind + intro leftValue rightValue hvalue + cases leftValue with + | none => + cases rightValue with + | none => + simp only + exact rootHiddenRelatesWith_pure_optionShape target leftOutput rightOutput + none none trivial + | some rightValue => simp [OptionShapeRel] at hvalue + | some leftValue => + cases rightValue with + | none => simp [OptionShapeRel] at hvalue + | some rightValue => + simp only + exact rootHiddenRelatesWith_pure_optionShape target leftOutput rightOutput _ _ + trivial + · rw [if_neg hzero] + change RootHiddenRelatesWith target leftOutput rightOutput OptionShapeRel + (peekPositionValues (Position.chain lay tree leafIdx chainIdx step).children >>= + fun values => match values with + | none => pure none + | some values => pure (some (tweakableHashInput parameter + (Position.chain lay tree leafIdx chainIdx step).domain + (values.flatMap digestBytes)))) + (peekPositionValues (Position.chain lay tree leafIdx chainIdx step).children >>= + fun values => match values with + | none => pure none + | some values => pure (some (tweakableHashInput parameter + (Position.chain lay tree leafIdx chainIdx step).domain + (values.flatMap digestBytes)))) + apply (rootHiddenRelatesWith_peekPositionValues target leftOutput rightOutput + (Position.chain lay tree leafIdx chainIdx step).children).bind + intro leftValues rightValues hvalues + cases leftValues with + | none => + cases rightValues with + | none => + simp only + exact rootHiddenRelatesWith_pure_optionShape target leftOutput rightOutput + none none trivial + | some rightValues => simp [OptionShapeRel] at hvalues + | some leftValues => + cases rightValues with + | none => simp [OptionShapeRel] at hvalues + | some rightValues => + simp only + exact rootHiddenRelatesWith_pure_optionShape target leftOutput rightOutput _ _ + trivial + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp only [peekTableInput] + apply (rootHiddenRelatesWith_peekPositionValues target leftOutput rightOutput _).bind + intro leftValues rightValues hvalues + cases leftValues with + | none => + cases rightValues with + | none => + simp only + exact rootHiddenRelatesWith_pure_optionShape target leftOutput rightOutput + none none trivial + | some rightValues => simp [OptionShapeRel] at hvalues + | some leftValues => + cases rightValues with + | none => simp [OptionShapeRel] at hvalues + | some rightValues => + simp only + exact rootHiddenRelatesWith_pure_optionShape target leftOutput rightOutput _ _ + trivial + +theorem relTriple_rootHidden_resolveKnownInput_of_miss + (parameter : PublicParameter) + (target : Position) (leftOutput rightOutput : HashOutput) + (coordinate : Coordinate) (input : HashInput) + (leftState rightState : LazyRevealProbe.State Coordinate) + (hstate : RootHiddenStateRel target leftOutput rightOutput leftState rightState) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache) + (hleftMiss : ∀ result, + some result ∈ support (runCleanFromTable leftState fuel table + ((peekTableInput parameter coordinate).run leftCache)) → + result.value.1 ≠ some input) + (hrightMiss : ∀ result, + some result ∈ support (runCleanFromTable rightState fuel table + ((peekTableInput parameter coordinate).run rightCache)) → + result.value.1 ≠ some input) : + RelTriple + (runCleanFromTable leftState fuel table + ((resolveKnownInput parameter coordinate input).run leftCache)) + (runCleanFromTable rightState fuel table + ((resolveKnownInput parameter coordinate input).run rightCache)) + (RootHiddenCleanSameRel target leftOutput rightOutput) := by + unfold resolveKnownInput + rw [StateT.run_bind, StateT.run_bind, runCleanFromTable_bind, + runCleanFromTable_bind] + let leftRun := runCleanFromTable leftState fuel table + ((peekTableInput parameter coordinate).run leftCache) + let rightRun := runCleanFromTable rightState fuel table + ((peekTableInput parameter coordinate).run rightCache) + have hpeek := rootHiddenRelatesWith_peekTableInput parameter target leftOutput rightOutput + coordinate leftState rightState hstate fuel table leftCache rightCache hcache + have hleftSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hpeek + (fun result => result ∈ support leftRun) (fun result hresult => hresult) + have hbothSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupport + apply relTriple_bind hbothSupport + intro leftResult rightResult hresult + rcases hresult with ⟨⟨hrelation, hleftMem⟩, hrightMem⟩ + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [RootHiddenCleanRelWith] at hrelation + | some leftResult => + cases rightResult with + | none => simp [RootHiddenCleanRelWith] at hrelation + | some rightResult => + rcases hrelation with ⟨hnextState, hremaining, htable, hshape, hnextCache⟩ + simp only + rw [← hremaining, ← htable] + cases hleftKnown : leftResult.value.1 with + | none => + cases hrightKnown : rightResult.value.1 with + | none => + exact rootHiddenRelates_splitHashQuery_ordinary target leftOutput rightOutput + input leftResult.state rightResult.state hnextState leftResult.remaining + leftResult.table leftResult.value.2 rightResult.value.2 hnextCache + | some rightKnown => + simp [hleftKnown, hrightKnown, OptionShapeRel] at hshape + | some leftKnown => + cases hrightKnown : rightResult.value.1 with + | none => simp [hleftKnown, hrightKnown, OptionShapeRel] at hshape + | some rightKnown => + have hleftNe : leftKnown ≠ input := by + intro heq + apply hleftMiss leftResult hleftMem + rw [hleftKnown, heq] + have hrightNe : rightKnown ≠ input := by + intro heq + apply hrightMiss rightResult hrightMem + rw [hrightKnown, heq] + simp only + rw [if_neg hleftNe, if_neg hrightNe] + exact rootHiddenRelates_splitHashQuery_ordinary target leftOutput rightOutput + input leftResult.state rightResult.state hnextState leftResult.remaining + leftResult.table leftResult.value.2 rightResult.value.2 hnextCache + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootStateSigner.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootStateSigner.lean new file mode 100644 index 00000000..780bf4d1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootStateSigner.lean @@ -0,0 +1,675 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootState + +/-! +# Swapped-root signer state coupling + +The selected root reveal is the only primitive whose returned digest differs in the two hidden +states. Its dedicated relation feeds the comparison root to both post-message signer continuations. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem RootHiddenCacheRel.update_targets + {target : Position} {leftOutput rightOutput : HashOutput} + {left right : SplitHashCache} + (hrel : RootHiddenCacheRel target leftOutput rightOutput left right) : + RootHiddenCacheRel target leftOutput rightOutput + (Function.update left (.hidden (.position target)) (some leftOutput)) + (Function.update right (.hidden (.position target)) (some rightOutput)) := by + refine ⟨?_, ?_, ?_, ?_⟩ + · intro input + simp [hrel.ordinary input] + · simp + · simp + · intro coordinate hne + have hkey : SplitHashKey.hidden coordinate ≠ .hidden (.position target) := by + intro heq + exact hne (SplitHashKey.hidden.inj heq) + simp [Function.update_of_ne hkey, hrel.other_hidden coordinate hne] + +def RootHiddenTargetRevealRel + (target : Position) (leftOutput rightOutput : HashOutput) : + Option (CleanRunResult (Digest × SplitHashCache)) → + Option (CleanRunResult (Digest × SplitHashCache)) → Prop + | some left, some right => + RootHiddenStateRel target leftOutput rightOutput left.state right.state ∧ + left.remaining = right.remaining ∧ left.table = right.table ∧ + left.value.1 = truncateHash leftOutput ∧ + right.value.1 = truncateHash rightOutput ∧ + RootHiddenCacheRel target leftOutput rightOutput left.value.2 right.value.2 + | none, none => True + | _, _ => False + +theorem relTriple_rootHidden_revealPosition_target + (target : Position) (leftOutput rightOutput : HashOutput) + (leftState rightState : LazyRevealProbe.State Coordinate) + (hstate : RootHiddenStateRel target leftOutput rightOutput leftState rightState) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache) : + RelTriple + (runCleanFromTable leftState fuel table ((revealPosition target).run leftCache)) + (runCleanFromTable rightState fuel table ((revealPosition target).run rightCache)) + (RootHiddenTargetRevealRel target leftOutput rightOutput) := by + rw [revealPosition_run, revealPosition_run, LazyRevealProbe.revealQuery, + runCleanFromTable_reveal_query_bind, runCleanFromTable_reveal_query_bind, + hstate.left_target, hstate.right_target] + simp only [runCleanFromTable, OracleComp.construct_pure] + exact relTriple_pure_pure ⟨hstate, rfl, rfl, rfl, rfl, hcache.update_targets⟩ + +theorem rootHiddenRelates_sequenceFin + (target : Position) (leftOutput rightOutput : HashOutput) {n : Nat} + (left right : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, + RootHiddenRelates target leftOutput rightOutput (left index) (right index)) : + RootHiddenRelates target leftOutput rightOutput + (sequenceFin left) (sequenceFin right) := by + induction n with + | zero => + simp only [sequenceFin] + exact rootHiddenRelates_pure target leftOutput rightOutput Fin.elim0 + | succ n ih => + rw [sequenceFin, sequenceFin] + exact (hcomponent 0).bind fun leftHead rightHead hhead => + (ih (fun index : Fin n => left index.succ) (fun index : Fin n => right index.succ) + (fun index => hcomponent index.succ)).bind fun leftTail rightTail htail => by + subst rightHead + subst rightTail + exact rootHiddenRelates_pure target leftOutput rightOutput + (Fin.cases leftHead leftTail : Fin (n + 1) → α) + +theorem rootHiddenRelates_ensureFullChain + (target : Position) (leftOutput rightOutput : HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + RootHiddenRelates target leftOutput rightOutput + (ensureFullChain lay tree leafIdx chainIdx) + (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (rootHiddenRelates_sequenceFin target leftOutput rightOutput _ _ + (fun step => rootHiddenRelates_ensureCoordinate target leftOutput rightOutput + (.position (.chain lay tree leafIdx chainIdx step)))).bind fun _ _ _ => + rootHiddenRelates_pure target leftOutput rightOutput () + +theorem rootHiddenRelates_ensureOtsLeaf + (target : Position) (leftOutput rightOutput : HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + RootHiddenRelates target leftOutput rightOutput + (ensureOtsLeaf lay tree leafIdx) (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (rootHiddenRelates_sequenceFin target leftOutput rightOutput _ _ + (fun chainIdx => rootHiddenRelates_ensureFullChain target leftOutput rightOutput + lay tree leafIdx chainIdx)).bind fun _ _ _ => + rootHiddenRelates_ensureCoordinate target leftOutput rightOutput + (.position (.leaf lay tree leafIdx)) + +theorem rootHiddenRelates_ensureTreeNode + (target : Position) (leftOutput rightOutput : HashOutput) + (lay : Layer) (tree : TreeIndex) : ∀ level nodeIdx, + RootHiddenRelates target leftOutput rightOutput + (ensureTreeNode lay tree level nodeIdx) + (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => by + rw [ensureTreeNode] + exact rootHiddenRelates_ensureOtsLeaf target leftOutput rightOutput lay tree + (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (rootHiddenRelates_ensureTreeNode target leftOutput rightOutput lay tree level + (2 * nodeIdx)).bind fun _ _ _ => + (rootHiddenRelates_ensureTreeNode target leftOutput rightOutput lay tree level + (2 * nodeIdx + 1)).bind fun _ _ _ => by + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact rootHiddenRelates_ensureCoordinate target leftOutput rightOutput + (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact rootHiddenRelates_pure target leftOutput rightOutput () + +theorem rootHiddenRelates_ensureChainPrefix + (target : Position) (leftOutput rightOutput : HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) : + RootHiddenRelates target leftOutput rightOutput + (ensureChainPrefix lay tree leafIdx chainIdx digit) + (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (rootHiddenRelates_sequenceFin target leftOutput rightOutput _ _ + (fun step => by + by_cases hstep : step.val < digit.val + · rw [if_pos hstep] + exact rootHiddenRelates_ensureCoordinate target leftOutput rightOutput + (.position (.chain lay tree leafIdx chainIdx step)) + · rw [if_neg hstep] + exact rootHiddenRelates_pure target leftOutput rightOutput ())).bind fun _ _ _ => + rootHiddenRelates_pure target leftOutput rightOutput () + +theorem rootHiddenRelates_ensureTreePath + (target : Position) (leftOutput rightOutput : HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + RootHiddenRelates target leftOutput rightOutput + (ensureTreePath lay tree leafIdx) (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (rootHiddenRelates_sequenceFin target leftOutput rightOutput _ _ + (fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + exact rootHiddenRelates_ensureTreeNode target leftOutput rightOutput lay tree + level.val (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · rw [if_neg hlevel] + exact rootHiddenRelates_pure target leftOutput rightOutput ())).bind fun _ _ _ => + rootHiddenRelates_pure target leftOutput rightOutput () + +theorem rootHiddenRelates_simulateQ + {spec : OracleSpec ι} + (target : Position) (leftOutput rightOutput : HashOutput) + (leftImpl rightImpl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (himpl : ∀ query, + RootHiddenRelates target leftOutput rightOutput + (leftImpl query) (rightImpl query)) + (computation : OracleComp spec α) : + RootHiddenRelates target leftOutput rightOutput + (simulateQ leftImpl computation) (simulateQ rightImpl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + rw [simulateQ_pure, simulateQ_pure] + exact rootHiddenRelates_pure target leftOutput rightOutput value + | query_bind query next ih => + rw [simulateQ_query_bind, simulateQ_query_bind] + exact (himpl query).bind fun leftValue rightValue hvalue => by + subst rightValue + exact ih leftValue + +theorem rootHiddenRelates_ordinaryHashImpl + (target : Position) (leftOutput rightOutput : HashOutput) + (input : HashInput) : + RootHiddenRelates target leftOutput rightOutput + (ordinaryHashImpl input) (ordinaryHashImpl input) := + rootHiddenRelates_splitHashQuery_ordinary target leftOutput rightOutput input + +theorem rootHiddenRelates_maskedOtsSignFrom + (target : Position) (leftOutput rightOutput : HashOutput) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : ∀ attempts counter, + RootHiddenRelates target leftOutput rightOutput + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom] + exact rootHiddenRelates_pure target leftOutput rightOutput none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + apply (rootHiddenRelates_simulateQ target leftOutput rightOutput + ordinaryHashImpl ordinaryHashImpl + (rootHiddenRelates_ordinaryHashImpl target leftOutput rightOutput) + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter))).bind + intro leftEncoded rightEncoded hencoded + subst rightEncoded + cases leftEncoded with + | none => + exact rootHiddenRelates_maskedOtsSignFrom target leftOutput rightOutput parameter + lay tree leafIdx message attempts (counter + 1) + | some encoding => + exact (rootHiddenRelates_sequenceFin target leftOutput rightOutput _ _ + (fun chainIdx => rootHiddenRelates_ensureChainPrefix target leftOutput rightOutput + lay tree leafIdx chainIdx (encoding chainIdx))).bind fun _ _ _ => + rootHiddenRelates_pure target leftOutput rightOutput + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem rootHiddenRelates_maskedOtsSign + (target : Position) (leftOutput rightOutput : HashOutput) + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : + RootHiddenRelates target leftOutput rightOutput + (maskedOtsSign parameter lay tree leafIdx message) + (maskedOtsSign parameter lay tree leafIdx message) := + rootHiddenRelates_maskedOtsSignFrom target leftOutput rightOutput parameter lay tree leafIdx + message encodingAttemptLimit 0 + +theorem rootHiddenRelates_maskedOtsLayerAfterMessage + (target : Position) (leftOutput rightOutput : HashOutput) + (parameter : PublicParameter) (index : Index) (lay : Layer) (message : Digest) : + RootHiddenRelates target leftOutput rightOutput + (maskedOtsLayerAfterMessage parameter index lay message) + (maskedOtsLayerAfterMessage parameter index lay message) := by + unfold maskedOtsLayerAfterMessage + apply (rootHiddenRelates_maskedOtsSign target leftOutput rightOutput parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) message).bind + intro leftResult rightResult hresult + subst rightResult + cases leftResult with + | none => exact rootHiddenRelates_pure target leftOutput rightOutput none + | some part => + exact (rootHiddenRelates_ensureTreePath target leftOutput rightOutput lay + (treeIndexAt index lay) (leafIndexAt index lay)).bind fun _ _ _ => + rootHiddenRelates_pure target leftOutput rightOutput (some part) + +theorem maskedTreeRoot_eq_ensure_reveal (lay : Layer) (tree : TreeIndex) : + maskedTreeRoot lay tree = (do + ensureTreeNode lay tree (layerHeight lay) 0 + revealPosition (layerRootPosition lay tree)) := by + fin_cases lay <;> + simp [maskedTreeRoot, maskedTreeNode, layerRootPosition, layerHeight, + maxLayerHeight, leafOfNat] <;> congr 1 + +theorem relTriple_rootHidden_maskedTreeRoot_target + (lay : Layer) (tree : TreeIndex) + (leftOutput rightOutput : HashOutput) + (leftState rightState : LazyRevealProbe.State Coordinate) + (hstate : RootHiddenStateRel (layerRootPosition lay tree) leftOutput rightOutput + leftState rightState) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel (layerRootPosition lay tree) leftOutput rightOutput + leftCache rightCache) : + RelTriple + (runCleanFromTable leftState fuel table ((maskedTreeRoot lay tree).run leftCache)) + (runCleanFromTable rightState fuel table ((maskedTreeRoot lay tree).run rightCache)) + (RootHiddenTargetRevealRel (layerRootPosition lay tree) leftOutput rightOutput) := by + rw [maskedTreeRoot_eq_ensure_reveal, StateT.run_bind, StateT.run_bind, + runCleanFromTable_bind, runCleanFromTable_bind] + apply relTriple_bind + (rootHiddenRelates_ensureTreeNode (layerRootPosition lay tree) leftOutput rightOutput + lay tree (layerHeight lay) 0 leftState rightState hstate fuel table leftCache rightCache + hcache) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure trivial + | some rightResult => simp [RootHiddenCleanSameRel] at hresult + | some leftResult => + cases rightResult with + | none => simp [RootHiddenCleanSameRel] at hresult + | some rightResult => + rcases hresult with ⟨hnextState, hremaining, htable, _hvalue, hnextCache⟩ + simp only + rw [← hremaining, ← htable] + exact relTriple_rootHidden_revealPosition_target (layerRootPosition lay tree) + leftOutput rightOutput leftResult.state rightResult.state hnextState + leftResult.remaining leftResult.table leftResult.value.2 rightResult.value.2 + hnextCache + +theorem relTriple_rootHidden_maskedLayerMessage_target + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (index : Index) (lay : Layer) + (htarget : layerMessagePosition index lay = target) + (leftOutput rightOutput : HashOutput) + (leftState rightState : LazyRevealProbe.State Coordinate) + (hstate : RootHiddenStateRel target leftOutput rightOutput leftState rightState) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) + (hcache : RootHiddenCacheRel target leftOutput rightOutput leftCache rightCache) : + RelTriple + (runCleanFromTable leftState fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run leftCache)) + (runCleanFromTable rightState fuel table + ((maskedLayerMessage parameter ftsSecret index lay).run rightCache)) + (RootHiddenTargetRevealRel target leftOutput rightOutput) := by + obtain ⟨below, hcomputation, hposition⟩ := + layerMessage_root_witness_of_isLayerRoot parameter ftsSecret target hroot index lay htarget + have htargetRoot : target = layerRootPosition below (treeIndexAt index below) := + htarget.symm.trans hposition + rw [hcomputation] + rw [htargetRoot] at hstate hcache ⊢ + exact relTriple_rootHidden_maskedTreeRoot_target below (treeIndexAt index below) + leftOutput rightOutput leftState rightState hstate fuel table leftCache rightCache hcache + +theorem rootHiddenRelates_maskedSignLayer_comparison_actual + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (index : Index) (lay : Layer) + (htarget : layerMessagePosition index lay = target) + (leftOutput rightOutput : HashOutput) : + RootHiddenRelates target leftOutput rightOutput + (maskedSignLayerWithComparisonRoot parameter ftsSecret index lay + (truncateHash rightOutput)) + (maskedSignLayer parameter ftsSecret index lay) := by + intro leftState rightState hstate fuel table leftCache rightCache hcache + unfold maskedSignLayerWithComparisonRoot maskedSignLayer + rw [StateT.run_bind, StateT.run_bind, runCleanFromTable_bind, + runCleanFromTable_bind] + apply relTriple_bind + (relTriple_rootHidden_maskedLayerMessage_target parameter ftsSecret target hroot index lay + htarget leftOutput rightOutput leftState rightState hstate fuel table leftCache rightCache + hcache) + intro leftMessage rightMessage hmessage + cases leftMessage with + | none => + cases rightMessage with + | none => exact relTriple_pure_pure trivial + | some rightMessage => simp [RootHiddenTargetRevealRel] at hmessage + | some leftMessage => + cases rightMessage with + | none => simp [RootHiddenTargetRevealRel] at hmessage + | some rightMessage => + rcases hmessage with ⟨hnextState, hremaining, htable, _hleftMessage, + hrightMessage, hnextCache⟩ + simp only + rw [← hremaining, ← htable, hrightMessage] + exact rootHiddenRelates_maskedOtsLayerAfterMessage target leftOutput rightOutput + parameter index lay (truncateHash rightOutput) leftMessage.state rightMessage.state + hnextState leftMessage.remaining leftMessage.table leftMessage.value.2 + rightMessage.value.2 hnextCache + +theorem rootHiddenRelates_maskedTreeRoot_of_ne + (target : Position) (leftOutput rightOutput : HashOutput) + (lay : Layer) (tree : TreeIndex) + (hne : layerRootPosition lay tree ≠ target) : + RootHiddenRelates target leftOutput rightOutput + (maskedTreeRoot lay tree) (maskedTreeRoot lay tree) := by + rw [maskedTreeRoot_eq_ensure_reveal] + exact (rootHiddenRelates_ensureTreeNode target leftOutput rightOutput lay tree + (layerHeight lay) 0).bind fun _ _ _ => + rootHiddenRelates_revealPosition_of_ne target leftOutput rightOutput + (layerRootPosition lay tree) hne + +theorem rootHiddenRelates_maskedLayerMessage_of_ne + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (leftOutput rightOutput : HashOutput) + (index : Index) (lay : Layer) + (hne : layerMessagePosition index lay ≠ target) : + RootHiddenRelates target leftOutput rightOutput + (maskedLayerMessage parameter ftsSecret index lay) + (maskedLayerMessage parameter ftsSecret index lay) := by + fin_cases lay + · rw [maskedLayerMessage, dif_pos (by decide)] + apply rootHiddenRelates_maskedTreeRoot_of_ne + simpa [layerMessagePosition_top, layerRootPosition] + · rw [maskedLayerMessage, dif_pos (by decide)] + apply rootHiddenRelates_maskedTreeRoot_of_ne + simpa [layerMessagePosition_middle, layerRootPosition] + · rw [maskedLayerMessage, dif_neg (by decide)] + exact rootHiddenRelates_simulateQ target leftOutput rightOutput ordinaryHashImpl + ordinaryHashImpl (rootHiddenRelates_ordinaryHashImpl target leftOutput rightOutput) + (ftsKey parameter index (ftsSecret index)) + +theorem rootHiddenRelates_maskedSignLayer_of_ne + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (leftOutput rightOutput : HashOutput) + (index : Index) (lay : Layer) + (hne : layerMessagePosition index lay ≠ target) : + RootHiddenRelates target leftOutput rightOutput + (maskedSignLayer parameter ftsSecret index lay) + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + exact (rootHiddenRelates_maskedLayerMessage_of_ne parameter ftsSecret target leftOutput + rightOutput index lay hne).bind fun leftMessage rightMessage hmessage => by + subst rightMessage + exact rootHiddenRelates_maskedOtsLayerAfterMessage target leftOutput rightOutput + parameter index lay leftMessage + +theorem rootHiddenRelates_maskedSignLayerWithTargetComparison_actual + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (index : Index) (lay : Layer) : + RootHiddenRelates target leftOutput rightOutput + (maskedSignLayerWithTargetComparison parameter target (truncateHash rightOutput) + ftsSecret index lay) + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayerWithTargetComparison + by_cases htarget : layerMessagePosition index lay = target + · rw [if_pos htarget] + exact rootHiddenRelates_maskedSignLayer_comparison_actual parameter ftsSecret target hroot + index lay htarget leftOutput rightOutput + · rw [if_neg htarget] + exact rootHiddenRelates_maskedSignLayer_of_ne parameter ftsSecret target leftOutput + rightOutput index lay htarget + +theorem rootHiddenRelates_maskedSignLayersWithTargetComparison_actual + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) (index : Index) : + RootHiddenRelates target leftOutput rightOutput + (maskedSignLayersWithTargetComparison parameter target (truncateHash rightOutput) + ftsSecret index) + (sequenceFin fun lay => maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayersWithTargetComparison + exact rootHiddenRelates_sequenceFin target leftOutput rightOutput _ _ fun lay => + rootHiddenRelates_maskedSignLayerWithTargetComparison_actual parameter ftsSecret target + hroot leftOutput rightOutput index lay + +theorem chainValueCoordinate_ne_layerRoot + {target : Position} (hroot : IsLayerRoot target) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) : + chainValueCoordinate lay tree leafIdx chainIdx digit ≠ .position target := by + obtain ⟨rootLay, rootTree, rfl⟩ := hroot + unfold chainValueCoordinate + split <;> simp [layerRootPosition] + +theorem pathNode_ne_layerRoot + {target : Position} (hroot : IsLayerRoot target) + (lay : Layer) (tree : TreeIndex) (current : Nat) + (hcurrent : current < maxLayerHeight) (nodeIdx : LeafIndex) + (hlt : current + 1 < layerHeight lay) : + Position.node lay tree ⟨current, hcurrent⟩ nodeIdx ≠ target := by + obtain ⟨rootLay, rootTree, rfl⟩ := hroot + intro heq + simp only [layerRootPosition, Position.node.injEq] at heq + have hlay : lay = rootLay := heq.1 + subst rootLay + have hlevel := congrArg Fin.val heq.2.2.1 + simp only at hlevel + have hpos : 0 < layerHeight lay := by + unfold layerHeight + split <;> norm_num [maxLayerHeight] + have hmax : 0 < maxLayerHeight := by norm_num [maxLayerHeight] + omega + +theorem rootHiddenRelates_revealLayerValues + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + RootHiddenRelates target leftOutput rightOutput + (revealLayerValues index lay encoding) (revealLayerValues index lay encoding) := by + unfold revealLayerValues + apply (rootHiddenRelates_sequenceFin target leftOutput rightOutput _ _ fun chainIdx => + rootHiddenRelates_revealPublishedCoordinate_of_ne target leftOutput rightOutput + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + (encoding chainIdx)) + (chainValueCoordinate_ne_layerRoot hroot lay (treeIndexAt index lay) + (leafIndexAt index lay) chainIdx (encoding chainIdx))).bind + intro leftValues rightValues hvalues + subst rightValues + apply (rootHiddenRelates_sequenceFin target leftOutput rightOutput _ _ fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + cases hzero : level.val with + | zero => + exact rootHiddenRelates_revealPublishedCoordinate_of_ne target leftOutput rightOutput + (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) (by + obtain ⟨rootLay, rootTree, rfl⟩ := hroot + simp [layerRootPosition]) + | succ current => + rw [Nat.add_one] + simp only + by_cases hcurrent : current < maxLayerHeight + · rw [dif_pos hcurrent] + exact rootHiddenRelates_revealPublishedCoordinate_of_ne target leftOutput rightOutput + (.position (.node lay (treeIndexAt index lay) ⟨current, hcurrent⟩ + (leafOfNat (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + (by + intro heq + exact (pathNode_ne_layerRoot hroot lay (treeIndexAt index lay) current hcurrent _ + (by omega)) (Coordinate.position.inj heq)) + · rw [dif_neg hcurrent] + exact rootHiddenRelates_pure target leftOutput rightOutput 0 + · rw [if_neg hlevel] + exact rootHiddenRelates_pure target leftOutput rightOutput 0).bind + intro leftPath rightPath hpath + subst rightPath + exact rootHiddenRelates_pure target leftOutput rightOutput (leftValues, leftPath) + +theorem rootHiddenRelates_maskedSignAfterDigestWithTargetComparison_actual + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + RootHiddenRelates target leftOutput rightOutput + (maskedSignAfterDigestWithTargetComparison parameter target (truncateHash rightOutput) + ftsSecret randomness index leaves) + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigestWithTargetComparison maskedSignAfterDigest + apply (rootHiddenRelates_simulateQ target leftOutput rightOutput ordinaryHashImpl + ordinaryHashImpl (rootHiddenRelates_ordinaryHashImpl target leftOutput rightOutput) + (ftsOpen parameter index leaves (ftsSecret index))).bind + intro leftPath rightPath hpath + subst rightPath + apply (rootHiddenRelates_maskedSignLayersWithTargetComparison_actual parameter ftsSecret + target hroot leftOutput rightOutput index).bind + intro leftLayers rightLayers hlayers + subst rightLayers + cases hparts : traverseOption leftLayers with + | none => exact rootHiddenRelates_pure target leftOutput rightOutput none + | some parts => + apply (rootHiddenRelates_sequenceFin target leftOutput rightOutput _ _ fun lay => + rootHiddenRelates_revealLayerValues target hroot leftOutput rightOutput index lay + (parts lay).2).bind + intro leftRevealed rightRevealed hrevealed + subst rightRevealed + let signature : Signature := + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := leftPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (leftRevealed lay).1 + authPath := flattenPaths fun lay => (leftRevealed lay).2 } + exact rootHiddenRelates_pure target leftOutput rightOutput (some signature) + +theorem rootHiddenRelates_ordinaryRomImpl + (target : Position) (leftOutput rightOutput : HashOutput) + (query : OracleWorld.Domain) : + RootHiddenRelates target leftOutput rightOutput + (ordinaryRomImpl query) (ordinaryRomImpl query) := by + cases query with + | inl n => exact rootHiddenRelates_splitUniformImpl target leftOutput rightOutput n + | inr input => exact rootHiddenRelates_ordinaryHashImpl target leftOutput rightOutput input + +theorem rootHiddenRelates_maskedSignWithTargetComparison_actual + (parameter : PublicParameter) (publicRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) (message : Message) : + RootHiddenRelates target leftOutput rightOutput + (maskedSignWithTargetComparison parameter publicRoot target (truncateHash rightOutput) + ftsSecret message) + (maskedSign parameter publicRoot ftsSecret message) := by + unfold maskedSignWithTargetComparison maskedSign + let secretKey : SecretKey := + ⟨parameter, publicRoot, fun _ _ _ _ => 0, ftsSecret⟩ + apply (rootHiddenRelates_simulateQ target leftOutput rightOutput ordinaryRomImpl + ordinaryRomImpl (rootHiddenRelates_ordinaryRomImpl target leftOutput rightOutput) + (signDigestLoop digestAttemptLimit secretKey message)).bind + intro leftSelected rightSelected hselected + subst rightSelected + cases leftSelected with + | none => exact rootHiddenRelates_pure target leftOutput rightOutput none + | some selected => + exact rootHiddenRelates_maskedSignAfterDigestWithTargetComparison_actual parameter + ftsSecret target hroot leftOutput rightOutput selected.1 selected.2.1 selected.2.2 + +noncomputable def fullSwapRootCache + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (rightOutput : HashOutput) + (cache : SplitHashCache) : SplitHashCache := + replaceHiddenRootCache target rightOutput + (swapCanonicalRootEncodingCache parameter target leftRoot rightRoot cache) + +theorem rootHiddenCacheRel_fullSwapRootCache + (parameter : PublicParameter) (target : Position) + (leftOutput rightOutput : HashOutput) (cache : SplitHashCache) + (hleft : cache (.hidden (.position target)) = some leftOutput) : + RootHiddenCacheRel target leftOutput rightOutput + (swapCanonicalRootEncodingCache parameter target (truncateHash leftOutput) + (truncateHash rightOutput) cache) + (fullSwapRootCache parameter target (truncateHash leftOutput) + (truncateHash rightOutput) rightOutput cache) := by + apply rootHiddenCacheRel_replace + exact hleft + +theorem fullSwapRootCache_involutive + (parameter : PublicParameter) (target : Position) + (leftOutput rightOutput : HashOutput) (cache : SplitHashCache) + (hleft : cache (.hidden (.position target)) = some leftOutput) : + fullSwapRootCache parameter target (truncateHash rightOutput) + (truncateHash leftOutput) leftOutput + (fullSwapRootCache parameter target (truncateHash leftOutput) + (truncateHash rightOutput) rightOutput cache) = cache := by + funext key + cases key with + | ordinary input => + simp [fullSwapRootCache, replaceHiddenRootCache, + swapCanonicalRootEncodingCache, + swapCanonicalRootEncodingInput_involutive] + | hidden coordinate => + by_cases heq : coordinate = .position target + · subst coordinate + simp [fullSwapRootCache, replaceHiddenRootCache, hleft] + · have hkey : SplitHashKey.hidden coordinate ≠ .hidden (.position target) := by + intro h + exact heq (SplitHashKey.hidden.inj h) + simp [fullSwapRootCache, replaceHiddenRootCache, + swapCanonicalRootEncodingCache, Function.update_of_ne hkey] + +theorem evalDist_swappedRoot_maskedSign_eq + (parameter : PublicParameter) (publicRoot : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (target : Position) (hroot : IsLayerRoot target) + (leftOutput rightOutput : HashOutput) + (state : LazyRevealProbe.State Coordinate) + (hprivate : Coordinate.position target ∉ state.revealed) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) + (hhidden : cache (.hidden (.position target)) = some leftOutput) + (message : Message) : + evalDist (cleanRunReturnedValue? <$> + runCleanFromTable (state.materialize (.position target) leftOutput) fuel table + ((maskedSign parameter publicRoot ftsSecret message).run cache)) = + evalDist (cleanRunReturnedValue? <$> + runCleanFromTable (state.materialize (.position target) rightOutput) fuel table + ((maskedSign parameter publicRoot ftsSecret message).run + (fullSwapRootCache parameter target (truncateHash leftOutput) + (truncateHash rightOutput) rightOutput cache))) := by + let comparisonCache := swapCanonicalRootEncodingCache parameter target + (truncateHash leftOutput) (truncateHash rightOutput) cache + let rightCache := fullSwapRootCache parameter target + (truncateHash leftOutput) (truncateHash rightOutput) rightOutput cache + have hstored : StoredLayerRoot + (state.materialize (.position target) leftOutput) target (truncateHash leftOutput) := by + refine ⟨leftOutput, ?_, rfl⟩ + simp [LazyRevealProbe.State.materialize] + have hencoding := rootEncodingCacheRel_swapCanonical parameter target + (truncateHash leftOutput) (truncateHash rightOutput) cache + have hab := evalDist_cleanRunReturnedValue_eq_of_rootEncodingStored + (rootEncodingCacheRelatesStored_maskedSign_targetComparison parameter publicRoot target hroot + (truncateHash leftOutput) (truncateHash rightOutput) ftsSecret message) + cache comparisonCache hencoding + (state.materialize (.position target) leftOutput) fuel table hstored + have hstate := rootHiddenStateRel_materialize target leftOutput rightOutput state hprivate + have hcache : RootHiddenCacheRel target leftOutput rightOutput comparisonCache rightCache := by + exact rootHiddenCacheRel_fullSwapRootCache parameter target leftOutput rightOutput cache hhidden + have hbc := evalDist_cleanRunReturnedValue_eq_of_rootHidden + (rootHiddenRelates_maskedSignWithTargetComparison_actual parameter publicRoot ftsSecret + target hroot leftOutput rightOutput message) + (state.materialize (.position target) leftOutput) + (state.materialize (.position target) rightOutput) hstate fuel table + comparisonCache rightCache hcache + exact hab.trans hbc + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSwapCache.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSwapCache.lean new file mode 100644 index 00000000..77e87319 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootSwapCache.lean @@ -0,0 +1,252 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootFiber + +/-! +# Swapping delayed-root cache keys + +At the moment a hidden layer root is selected in hindsight, the existing cache may already contain +encoding inputs carrying an arbitrary comparison root. Swapping the two families of canonical retry +keys constructs the comparison cache directly, so the cache quotient needs no earlier-miss premise +for the comparison root. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +structure RootRetryAddress (target : Position) where + position : EncodingPosition + counter : Fin encodingAttemptLimit + names : EncodingPositionNamesRoot target position + +def RootRetryAddress.input + (parameter : PublicParameter) (root : Digest) + (address : RootRetryAddress target) : HashInput := + encodingRetryInput parameter address.position root address.counter.val + +theorem rootRetryAddress_unique + {parameter : PublicParameter} {target : Position} {root : Digest} + {left right : RootRetryAddress target} + (heq : left.input parameter root = right.input parameter root) : + left = right := by + rcases left with ⟨leftPosition, leftCounter, leftNames⟩ + rcases right with ⟨rightPosition, rightCounter, rightNames⟩ + change encodingRetryInput parameter leftPosition root leftCounter.val = + encodingRetryInput parameter rightPosition root rightCounter.val at heq + have hposition : leftPosition = rightPosition := by + exact atEncodingPosition_unique + (parameter := parameter) + (input := encodingRetryInput parameter leftPosition root leftCounter.val) + ⟨digestBytes root ++ counterBytes + (BitVec.ofNat counterBits leftCounter.val), rfl⟩ + ⟨digestBytes root ++ counterBytes + (BitVec.ofNat counterBits rightCounter.val), heq⟩ + subst rightPosition + have hcounter : leftCounter.val = rightCounter.val := + encodingRetryInput_injective_of_lt leftCounter.isLt rightCounter.isLt heq + have hcounterEq : leftCounter = rightCounter := Fin.ext hcounter + subst rightCounter + rfl + +noncomputable def rootRetryAddress? + (parameter : PublicParameter) (target : Position) + (root : Digest) (input : HashInput) : Option (RootRetryAddress target) := by + classical + exact if h : ∃ address : RootRetryAddress target, + address.input parameter root = input then + some (Classical.choose h) + else none + +theorem rootRetryAddress?_eq_some_of_input + (parameter : PublicParameter) (root : Digest) + (address : RootRetryAddress target) : + rootRetryAddress? parameter target root (address.input parameter root) = some address := by + classical + unfold rootRetryAddress? + let hexists : ∃ other : RootRetryAddress target, + other.input parameter root = address.input parameter root := ⟨address, rfl⟩ + rw [dif_pos hexists] + congr 1 + exact rootRetryAddress_unique (Classical.choose_spec hexists) + +theorem rootRetryAddress?_eq_some_spec + {parameter : PublicParameter} {target : Position} + {root : Digest} {input : HashInput} {address : RootRetryAddress target} + (haddress : rootRetryAddress? parameter target root input = some address) : + address.input parameter root = input := by + classical + unfold rootRetryAddress? at haddress + split at haddress + next hexists => + have heq : Classical.choose hexists = address := Option.some.inj haddress + rw [← heq] + exact Classical.choose_spec hexists + next hnone => simp at haddress + +theorem rootRetryAddress?_eq_none_of_not_names + {parameter : PublicParameter} {target : Position} + {root : Digest} {input : HashInput} + (hnot : ¬EncodingInputNamesRoot parameter target input) : + rootRetryAddress? parameter target root input = none := by + classical + unfold rootRetryAddress? + rw [dif_neg] + rintro ⟨address, hinput⟩ + apply hnot + rw [← hinput] + exact encodingRetryInput_namesRoot address.names root address.counter.val + +theorem rootRetryAddress?_eq_none_of_guess_ne + {parameter : PublicParameter} {target : Position} + {root guess : Digest} {input : HashInput} + (hguess : EncodingInputGuessesRoot parameter target guess input) + (hne : guess ≠ root) : + rootRetryAddress? parameter target root input = none := by + classical + unfold rootRetryAddress? + rw [dif_neg] + rintro ⟨address, hinput⟩ + apply hne + exact guess_eq_of_encodingRetryInput_eq address.names hinput.symm hguess + +noncomputable def swapCanonicalRootEncodingInput + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) : HashInput := + match rootRetryAddress? parameter target leftRoot input with + | some address => address.input parameter rightRoot + | none => + match rootRetryAddress? parameter target rightRoot input with + | some address => address.input parameter leftRoot + | none => input + +theorem swapCanonicalRootEncodingInput_left + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (address : RootRetryAddress target) : + swapCanonicalRootEncodingInput parameter target leftRoot rightRoot + (address.input parameter leftRoot) = + address.input parameter rightRoot := by + unfold swapCanonicalRootEncodingInput + rw [rootRetryAddress?_eq_some_of_input] + +theorem swapCanonicalRootEncodingInput_right + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (address : RootRetryAddress target) : + swapCanonicalRootEncodingInput parameter target leftRoot rightRoot + (address.input parameter rightRoot) = + address.input parameter leftRoot := by + by_cases heq : leftRoot = rightRoot + · subst rightRoot + exact swapCanonicalRootEncodingInput_left parameter target leftRoot leftRoot address + · unfold swapCanonicalRootEncodingInput + have hguess : EncodingInputGuessesRoot parameter target rightRoot + (address.input parameter rightRoot) := + decodeEncodingLayerRootCandidate?_encodingRetryInput address.names rightRoot + address.counter.val + rw [rootRetryAddress?_eq_none_of_guess_ne hguess (Ne.symm heq), + rootRetryAddress?_eq_some_of_input] + +theorem swapCanonicalRootEncodingInput_nonroot + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot : Digest} {input : HashInput} + (hnot : ¬EncodingInputNamesRoot parameter target input) : + swapCanonicalRootEncodingInput parameter target leftRoot rightRoot input = input := by + unfold swapCanonicalRootEncodingInput + rw [rootRetryAddress?_eq_none_of_not_names hnot, + rootRetryAddress?_eq_none_of_not_names hnot] + +theorem swapCanonicalRootEncodingInput_wrong + {parameter : PublicParameter} {target : Position} + {leftRoot rightRoot guess : Digest} {input : HashInput} + (hguess : EncodingInputGuessesRoot parameter target guess input) + (hleft : guess ≠ leftRoot) (hright : guess ≠ rightRoot) : + swapCanonicalRootEncodingInput parameter target leftRoot rightRoot input = input := by + unfold swapCanonicalRootEncodingInput + rw [rootRetryAddress?_eq_none_of_guess_ne hguess hleft, + rootRetryAddress?_eq_none_of_guess_ne hguess hright] + +theorem swapCanonicalRootEncodingInput_involutive + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (input : HashInput) : + swapCanonicalRootEncodingInput parameter target rightRoot leftRoot + (swapCanonicalRootEncodingInput parameter target leftRoot rightRoot input) = input := by + cases hleft : rootRetryAddress? parameter target leftRoot input with + | some address => + have hinput := rootRetryAddress?_eq_some_spec hleft + have hfirst : swapCanonicalRootEncodingInput parameter target leftRoot rightRoot input = + address.input parameter rightRoot := by + unfold swapCanonicalRootEncodingInput + rw [hleft] + rw [hfirst, + swapCanonicalRootEncodingInput_left parameter target rightRoot leftRoot address] + exact hinput + | none => + cases hright : rootRetryAddress? parameter target rightRoot input with + | some address => + have hinput := rootRetryAddress?_eq_some_spec hright + have hfirst : swapCanonicalRootEncodingInput parameter target leftRoot rightRoot input = + address.input parameter leftRoot := by + unfold swapCanonicalRootEncodingInput + rw [hleft, hright] + rw [hfirst, + swapCanonicalRootEncodingInput_right parameter target rightRoot leftRoot address] + exact hinput + | none => + unfold swapCanonicalRootEncodingInput + rw [hleft, hright, hright, hleft] + +noncomputable def swapCanonicalRootEncodingCache + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (cache : SplitHashCache) : SplitHashCache + | .ordinary input => + cache (.ordinary + (swapCanonicalRootEncodingInput parameter target leftRoot rightRoot input)) + | .hidden coordinate => cache (.hidden coordinate) + +theorem swapCanonicalRootEncodingCache_involutive + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (cache : SplitHashCache) : + swapCanonicalRootEncodingCache parameter target rightRoot leftRoot + (swapCanonicalRootEncodingCache parameter target leftRoot rightRoot cache) = cache := by + funext key + cases key with + | ordinary input => + simp [swapCanonicalRootEncodingCache, + swapCanonicalRootEncodingInput_involutive] + | hidden coordinate => rfl + +theorem rootEncodingCacheRel_swapCanonical + (parameter : PublicParameter) (target : Position) + (leftRoot rightRoot : Digest) (cache : SplitHashCache) : + RootEncodingCacheRel parameter target leftRoot rightRoot cache + (swapCanonicalRootEncodingCache parameter target leftRoot rightRoot cache) := by + refine ⟨?_, ?_, ?_, ?_⟩ + · intro input hnot + simp [swapCanonicalRootEncodingCache, + swapCanonicalRootEncodingInput_nonroot hnot] + · intro position counter hposition + let reduced : Counter := BitVec.ofNat counterBits counter + have hreduced : reduced.toNat < encodingAttemptLimit := by + change reduced.toNat < 2 ^ counterBits + exact reduced.isLt + let address : RootRetryAddress target := + ⟨position, ⟨reduced.toNat, hreduced⟩, hposition⟩ + have hmod : BitVec.ofNat counterBits reduced.toNat = reduced := by + rw [BitVec.ofNat_toNat, BitVec.setWidth_eq] + change cache (.ordinary (encodingRetryInput parameter position leftRoot counter)) = + cache (.ordinary (swapCanonicalRootEncodingInput parameter target leftRoot rightRoot + (encodingRetryInput parameter position rightRoot counter))) + have hleftInput : encodingRetryInput parameter position leftRoot counter = + address.input parameter leftRoot := by + unfold RootRetryAddress.input address encodingRetryInput + rw [hmod] + have hrightInput : encodingRetryInput parameter position rightRoot counter = + address.input parameter rightRoot := by + unfold RootRetryAddress.input address encodingRetryInput + rw [hmod] + rw [hleftInput, hrightInput, swapCanonicalRootEncodingInput_right] + · intro coordinate + rfl + · intro input guess hguess hleft hright + simp [swapCanonicalRootEncodingCache, + swapCanonicalRootEncodingInput_wrong hguess hleft hright] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalUnion.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalUnion.lean new file mode 100644 index 00000000..f07c3893 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalUnion.lean @@ -0,0 +1,105 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalInterpreter + +/-! +# Retained ordinal union + +The retained normalized witness trace reduces to one fixed-ordinal estimate. Candidate coverage, +the source query bound, the finite union and projection to the existing granular private Boolean +are discharged here. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option maxRecDepth 100000 in +theorem probEvent_retainedPrivateWitness_le_of_ordinals + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) (q : Nat) + (hbound : (retainedGameRestComputation adversary ⟨value.1, parameter⟩).IsQueryBoundP + IsOuterHash q) + (hcovered : PendingCoveredBy candidates context) + (hordinal : ∀ ordinal : Fin (candidates.length + q), + Pr[fun output => + boundedPrivateWitnessOrdinal? (candidates.length + q) output = some ordinal | + granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + Pr[fun output => output.1.isSome = true | + granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates] ≤ + ((candidates.length + q : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply probEvent_privateWitness_le_of_bounded_ordinals _ (candidates.length + q) + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + · intro output houtput hwitness + cases hvalue : output.1 with + | none => simp [hvalue] at hwitness + | some witness => + exact supported_retained_privateWitness_has_bounded_ordinal adversary parameter table + ftsSecret context fuel value candidates q hbound hcovered output houtput witness hvalue + · exact hordinal + +theorem probEvent_isSome_granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve_eq + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) : + Pr[fun output => output.1.isSome = true | + granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates] = + Pr[= true | granularDetailedRetainedRestPrivateObserve adversary parameter table ftsSecret + context fuel value] := by + calc + _ = Pr[fun output => output.1 = true | + erasePrivateWitnessPlanOutput <$> + granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates] := by + rw [probEvent_map] + exact OracleComp.probEvent_congr' (fun output _ => by + simp [erasePrivateWitnessPlanOutput]) rfl + _ = Pr[fun output => output.1 = true | + granularDetailedRetainedRestNormalizedPrivatePlanObserve adversary parameter table + ftsSecret context fuel value candidates] := + OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + (congrArg evalDist + (map_erase_granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary + parameter table ftsSecret context fuel value candidates)) + _ = Pr[= true | Prod.fst <$> + granularDetailedRetainedRestNormalizedPrivatePlanObserve adversary parameter table + ftsSecret context fuel value candidates] := by + rw [← probEvent_eq_eq_probOutput, probEvent_map] + rfl + _ = _ := OracleComp.probOutput_congr rfl + (evalDist_fst_granularDetailedRetainedRestNormalizedPrivatePlanObserve adversary parameter + table ftsSecret context fuel value candidates) + +theorem probEvent_granularDetailedRetainedRestPrivateObserve_le_of_ordinals + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) (q : Nat) + (hbound : (retainedGameRestComputation adversary ⟨value.1, parameter⟩).IsQueryBoundP + IsOuterHash q) + (hcovered : PendingCoveredBy candidates context) + (hordinal : ∀ ordinal : Fin (candidates.length + q), + Pr[fun output => + boundedPrivateWitnessOrdinal? (candidates.length + q) output = some ordinal | + granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates] ≤ + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + Pr[= true | granularDetailedRetainedRestPrivateObserve adversary parameter table ftsSecret + context fuel value] ≤ + ((candidates.length + q : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [← probEvent_isSome_granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve_eq + adversary parameter table ftsSecret context fuel value candidates] + exact probEvent_retainedPrivateWitness_le_of_ordinals adversary parameter table ftsSecret + context fuel value candidates q hbound hcovered hordinal + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessPlan.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessPlan.lean new file mode 100644 index 00000000..f92e092f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessPlan.lean @@ -0,0 +1,669 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitness + +/-! +# Planned private witnesses + +Private first-fire witnesses are threaded together with the chronological candidate list. Erasing +the witness recovers the existing Boolean plan observer exactly. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +abbrev PrivateWitnessPlanOutput := Option PrivateHitWitness × List Probe + +def erasePrivateWitnessPlanOutput + (output : PrivateWitnessPlanOutput) : Bool × List Probe := + (output.1.isSome, output.2) + +def PrivateWitnessCovered (output : PrivateWitnessPlanOutput) : Prop := + ∀ witness, output.1 = some witness → + candidateListHits witness.position output.2 witness.output + +noncomputable def privateHitWitnessOf + (context : DeferredContext) (hhit : PrivateStructuralHit context) : PrivateHitWitness := + ⟨hhit.choose, hhit.choose_spec.choose, context.state.revealed⟩ + +theorem privateHitWitnessOf_spec + (context : DeferredContext) (hhit : PrivateStructuralHit context) : + context.state.values (.position (privateHitWitnessOf context hhit).position) = none ∧ + context.values (privateHitWitnessOf context hhit).position = + some (privateHitWitnessOf context hhit).output ∧ + context.state.hitAt (.position (privateHitWitnessOf context hhit).position) + (privateHitWitnessOf context hhit).output := by + unfold privateHitWitnessOf + exact hhit.choose_spec.choose_spec + +theorem candidateListHits_privateHitWitnessOf + (context : DeferredContext) (candidates : List Probe) + (hcovered : PendingCoveredBy candidates context) + (hhit : PrivateStructuralHit context) : + candidateListHits (privateHitWitnessOf context hhit).position candidates + (privateHitWitnessOf context hhit).output := by + have hspec := privateHitWitnessOf_spec context hhit + have hpending : + (Coordinate.position (privateHitWitnessOf context hhit).position, + truncateHash (privateHitWitnessOf context hhit).output) ∈ context.state.pending := by + rw [← LazyRevealProbe.State.mem_pendingAt_iff] + exact hspec.2.2 + obtain ⟨candidate, hcandidate, hcoordinate, hdigest⟩ := hcovered _ hpending + exact candidateListHits_of_mem (privateHitWitnessOf context hhit).position + (privateHitWitnessOf context hhit).output candidate candidates hcandidate hcoordinate + hdigest + +noncomputable def finishDirectWitnessPlanObserve + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) : DirectWitnessResult α → + ProbComp PrivateWitnessPlanOutput + | .stoppedFuel => pure (none, candidates) + | .stoppedOrdinary => pure (none, candidates) + | .stoppedPrivate witness => pure (some witness, candidates) + | .done result => observe result.context result.remaining result.value candidates + +noncomputable def classifyDirectWitnessPlanObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) : + ProbComp PrivateWitnessPlanOutput := by + classical + exact if hhit : PrivateStructuralHit context then + pure (some (privateHitWitnessOf context hhit), candidates) + else if DeferredCompletable table context then + observe context fuel value candidates + else + pure (none, candidates) + +noncomputable def canonicalizeDirectWitnessPlanObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) : + ProbComp PrivateWitnessPlanOutput := by + classical + let canonical := canonicalizeMaterializedValues table context + exact if hhit : PrivateStructuralHit canonical then + pure (some (privateHitWitnessOf canonical hhit), candidates) + else if PublishedValues context.state then + classifyDirectWitnessPlanObserve table observe canonical fuel value candidates + else + pure (none, candidates) + +noncomputable def runDirectWitnessPlanObserve + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + ProbComp PrivateWitnessPlanOutput := + runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectWitnessPlanObserve observe candidates + +theorem map_erase_finishDirectWitnessPlanObserve + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (boolObserve : DeferredContext → Nat → α → List Probe → + ProbComp (Bool × List Probe)) + (candidates : List Probe) (result : DirectWitnessResult α) + (hproject : ∀ context fuel value candidates, + erasePrivateWitnessPlanOutput <$> observe context fuel value candidates = + boolObserve context fuel value candidates) : + erasePrivateWitnessPlanOutput <$> + finishDirectWitnessPlanObserve observe candidates result = + finishDirectDetailedPrivatePlanObserve boolObserve candidates result.erase := by + cases result with + | stoppedFuel => simp [finishDirectWitnessPlanObserve, + finishDirectDetailedPrivatePlanObserve, DirectWitnessResult.erase, + erasePrivateWitnessPlanOutput] + | stoppedOrdinary => simp [finishDirectWitnessPlanObserve, + finishDirectDetailedPrivatePlanObserve, DirectWitnessResult.erase, + erasePrivateWitnessPlanOutput] + | stoppedPrivate witness => simp [finishDirectWitnessPlanObserve, + finishDirectDetailedPrivatePlanObserve, DirectWitnessResult.erase, + erasePrivateWitnessPlanOutput] + | done result => exact hproject result.context result.remaining result.value candidates + +theorem map_erase_classifyDirectWitnessPlanObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (boolObserve : DeferredContext → Nat → α → List Probe → + ProbComp (Bool × List Probe)) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hproject : ∀ nextContext remaining nextValue nextCandidates, + erasePrivateWitnessPlanOutput <$> + observe nextContext remaining nextValue nextCandidates = + boolObserve nextContext remaining nextValue nextCandidates) : + erasePrivateWitnessPlanOutput <$> + classifyDirectWitnessPlanObserve table observe context fuel value candidates = + classifyDirectDetailedPrivatePlanObserve table boolObserve context fuel value + candidates := by + classical + unfold classifyDirectWitnessPlanObserve classifyDirectDetailedPrivatePlanObserve + by_cases hhit : PrivateStructuralHit context + · simp [hhit, erasePrivateWitnessPlanOutput] + · simp only [hhit, ↓reduceDIte, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table context + · simp only [hcompletable, ↓reduceIte] + exact hproject context fuel value candidates + · simp [hcompletable, erasePrivateWitnessPlanOutput] + +theorem map_erase_canonicalizeDirectWitnessPlanObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (boolObserve : DeferredContext → Nat → α → List Probe → + ProbComp (Bool × List Probe)) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hproject : ∀ nextContext remaining nextValue nextCandidates, + erasePrivateWitnessPlanOutput <$> + observe nextContext remaining nextValue nextCandidates = + boolObserve nextContext remaining nextValue nextCandidates) : + erasePrivateWitnessPlanOutput <$> + canonicalizeDirectWitnessPlanObserve table observe context fuel value candidates = + canonicalizeDirectDetailedPrivatePlanObserve table boolObserve context fuel value + candidates := by + classical + unfold canonicalizeDirectWitnessPlanObserve + canonicalizeDirectDetailedPrivatePlanObserve + let canonical := canonicalizeMaterializedValues table context + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit, erasePrivateWitnessPlanOutput] + · simp only [canonical, hhit, ↓reduceDIte, ↓reduceIte] + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + exact map_erase_classifyDirectWitnessPlanObserve table observe boolObserve canonical fuel + value candidates hproject + · simp [hpublished, erasePrivateWitnessPlanOutput] + +set_option maxRecDepth 100000 in +theorem map_erase_runDirectWitnessPlanObserve + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (boolObserve : DeferredContext → Nat → α → List Probe → + ProbComp (Bool × List Probe)) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hproject : ∀ nextContext remaining value nextCandidates, + erasePrivateWitnessPlanOutput <$> + observe nextContext remaining value nextCandidates = + boolObserve nextContext remaining value nextCandidates) : + erasePrivateWitnessPlanOutput <$> + runDirectWitnessPlanObserve observe candidates context fuel table computation = + runDirectDetailedPrivatePlanObserve boolObserve candidates context fuel table computation := by + unfold runDirectWitnessPlanObserve runDirectDetailedPrivatePlanObserve + rw [map_bind] + calc + _ = runDirectResolvedWitnessFromTable context fuel table computation >>= fun result => + finishDirectDetailedPrivatePlanObserve boolObserve candidates result.erase := by + apply bind_congr + intro result + exact map_erase_finishDirectWitnessPlanObserve observe boolObserve candidates result hproject + _ = DirectWitnessResult.erase <$> + runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectDetailedPrivatePlanObserve boolObserve candidates := by + simp [map_eq_bind_pure_comp, bind_assoc] + _ = _ := by rw [map_erase_runDirectResolvedWitnessFromTable] + +set_option maxRecDepth 100000 in +theorem privateWitnessCovered_of_mem_runDirectWitnessPlanObserve + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hcovered : PendingCoveredBy candidates context) + (hbound : computation.IsQueryBoundP (IsUncoveredProbe candidates) 0) + (hobserve : ∀ result : ResolvedRunResult α, + DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) → + PendingCoveredBy candidates result.context → + ∀ output ∈ support + (observe result.context result.remaining result.value candidates), + PrivateWitnessCovered output) + (output : PrivateWitnessPlanOutput) + (houtput : output ∈ support + (runDirectWitnessPlanObserve observe candidates context fuel table computation)) : + PrivateWitnessCovered output := by + unfold runDirectWitnessPlanObserve at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨result, hresult, hfinish⟩ := houtput + cases result with + | stoppedFuel => + simp [finishDirectWitnessPlanObserve] at hfinish + subst output + simp [PrivateWitnessCovered] + | stoppedOrdinary => + simp [finishDirectWitnessPlanObserve] at hfinish + subst output + simp [PrivateWitnessCovered] + | stoppedPrivate witness => + simp [finishDirectWitnessPlanObserve] at hfinish + subst output + intro found heq + simp only [Option.some.injEq] at heq + subst found + exact candidateListHits_of_stoppedPrivate_mem_runDirectResolvedWitnessFromTable + candidates computation context fuel table witness hcovered hbound hresult + | done result => + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) := by + rw [← map_erase_runDirectResolvedWitnessFromTable computation context fuel table, + support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + have hnextCovered := pendingCoveredBy_of_done_runDirectResolvedDetailedFromTable + candidates computation context fuel table result hcovered hbound hdetailed + exact hobserve result hdetailed hnextCovered output hfinish + +theorem privateWitnessCovered_of_mem_classifyDirectWitnessPlanObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hcovered : PendingCoveredBy candidates context) + (hobserve : ∀ output ∈ support (observe context fuel value candidates), + PrivateWitnessCovered output) + (output : PrivateWitnessPlanOutput) + (houtput : output ∈ support + (classifyDirectWitnessPlanObserve table observe context fuel value candidates)) : + PrivateWitnessCovered output := by + classical + unfold classifyDirectWitnessPlanObserve at houtput + by_cases hhit : PrivateStructuralHit context + · simp [hhit] at houtput + subst output + intro witness heq + simp only [Option.some.injEq] at heq + subst witness + exact candidateListHits_privateHitWitnessOf context candidates hcovered hhit + · simp only [hhit, ↓reduceDIte] at houtput + by_cases hcompletable : DeferredCompletable table context + · simp only [hcompletable, ↓reduceIte] at houtput + exact hobserve output houtput + · simp [hcompletable] at houtput + subst output + simp [PrivateWitnessCovered] + +theorem privateWitnessCovered_of_mem_canonicalizeDirectWitnessPlanObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hcovered : PendingCoveredBy candidates context) + (hobserve : ∀ output ∈ support + (observe (canonicalizeMaterializedValues table context) fuel value candidates), + PrivateWitnessCovered output) + (output : PrivateWitnessPlanOutput) + (houtput : output ∈ support + (canonicalizeDirectWitnessPlanObserve table observe context fuel value candidates)) : + PrivateWitnessCovered output := by + classical + let canonical := canonicalizeMaterializedValues table context + have hcanonicalCovered : PendingCoveredBy candidates canonical := + (pendingCoveredBy_canonicalize_iff table candidates context).2 hcovered + unfold canonicalizeDirectWitnessPlanObserve at houtput + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit] at houtput + subst output + intro witness heq + simp only [Option.some.injEq] at heq + subst witness + exact candidateListHits_privateHitWitnessOf canonical candidates hcanonicalCovered hhit + · simp only [canonical, hhit, ↓reduceDIte] at houtput + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] at houtput + exact privateWitnessCovered_of_mem_classifyDirectWitnessPlanObserve table observe canonical + fuel value candidates hcanonicalCovered hobserve output houtput + · simp [hpublished] at houtput + subst output + simp [PrivateWitnessCovered] + +noncomputable def directDetailedBoundaryNormalizedPrivateWitnessPlanObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp PrivateWitnessPlanOutput := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + (DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp PrivateWitnessPlanOutput) → + List Probe → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → + SplitHashCache → ProbComp PrivateWitnessPlanOutput) + (fun value observe candidates context fuel _table cache => + observe context fuel (value, cache) candidates) + (fun query _next recursivelyRun observe candidates context fuel table cache => + match query with + | .inl (.inl n) => + runDirectWitnessPlanObserve + (canonicalizeDirectWitnessPlanObserve table + (fun nextContext remaining value nextCandidates => + recursivelyRun value.1 observe nextCandidates nextContext remaining table + value.2)) + candidates context fuel table ((splitUniformImpl n).run cache) + | .inl (.inr input) => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + runDirectWitnessPlanObserve + (canonicalizeDirectWitnessPlanObserve table + (fun nextContext remaining value laterCandidates => + recursivelyRun value.1 observe laterCandidates nextContext remaining table + value.2)) + nextCandidates context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) + | .inr message => + runDirectWitnessPlanObserve + (canonicalizeDirectWitnessPlanObserve table + (fun nextContext remaining value nextCandidates => + recursivelyRun value.1 observe nextCandidates nextContext remaining table + value.2)) + candidates context fuel table + ((maskedSign parameter root ftsSecret message).run cache)) + computation observe candidates context fuel table cache + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem map_erase_directDetailedBoundaryNormalizedPrivateWitnessPlanObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp PrivateWitnessPlanOutput) + (boolObserve : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp (Bool × List Probe)) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hproject : ∀ nextContext remaining value nextCandidates, + erasePrivateWitnessPlanOutput <$> + observe nextContext remaining value nextCandidates = + boolObserve nextContext remaining value nextCandidates) : + erasePrivateWitnessPlanOutput <$> + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + computation observe candidates context fuel table cache = + directDetailedBoundaryNormalizedPrivatePlanObserve parameter root ftsSecret computation + boolObserve candidates context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_pure, + directDetailedBoundaryNormalizedPrivatePlanObserve, OracleComp.construct_pure] + exact hproject context fuel (value, cache) candidates + | query_bind query next ih => + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind, + directDetailedBoundaryNormalizedPrivatePlanObserve, + OracleComp.construct_query_bind] + apply map_erase_runDirectWitnessPlanObserve + intro nextContext remaining value nextCandidates + apply map_erase_canonicalizeDirectWitnessPlanObserve + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + | inr input => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind, + directDetailedBoundaryNormalizedPrivatePlanObserve, + OracleComp.construct_query_bind] + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + apply map_erase_runDirectWitnessPlanObserve + intro nextContext remaining value laterCandidates + apply map_erase_canonicalizeDirectWitnessPlanObserve + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + | inr message => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind, + directDetailedBoundaryNormalizedPrivatePlanObserve, + OracleComp.construct_query_bind] + apply map_erase_runDirectWitnessPlanObserve + intro nextContext remaining value nextCandidates + apply map_erase_canonicalizeDirectWitnessPlanObserve + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem privateWitnessCovered_of_mem_directDetailedBoundaryNormalizedPrivateWitnessPlanObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + List Probe → ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcovered : PendingCoveredBy candidates context) + (hobserve : ∀ nextContext remaining value nextCandidates output, + PendingCoveredBy nextCandidates nextContext → + output ∈ support (observe nextContext remaining value nextCandidates) → + PrivateWitnessCovered output) + (output : PrivateWitnessPlanOutput) + (houtput : output ∈ support + (directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + computation observe candidates context fuel table cache)) : + PrivateWitnessCovered output := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache output with + | pure value => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_pure] at houtput + exact hobserve context fuel (value, cache) candidates output hcovered houtput + | query_bind query next ih => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind] at houtput + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + have hprobeBound : ((splitUniformImpl n).run cache).IsQueryBoundP + (IsUncoveredProbe candidates) 0 := + OracleComp.IsQueryBoundP.of_imp (isUncoveredProbe_imp_isProbe candidates) + (splitUniformImpl_probeFree n cache) + apply privateWitnessCovered_of_mem_runDirectWitnessPlanObserve _ candidates + context fuel table ((splitUniformImpl n).run cache) hcovered hprobeBound + (output := output) (houtput := houtput) + intro result _hdetailed hresultCovered nextOutput hnextOutput + apply privateWitnessCovered_of_mem_canonicalizeDirectWitnessPlanObserve table _ + result.context result.remaining result.value candidates hresultCovered + (output := nextOutput) (houtput := hnextOutput) + intro finalOutput hfinalOutput + have hcanonicalCovered : PendingCoveredBy candidates + (canonicalizeMaterializedValues table result.context) := + (pendingCoveredBy_canonicalize_iff table candidates result.context).2 + hresultCovered + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hcanonicalCovered (output := finalOutput) hfinalOutput + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + have hplanMem : ∀ candidate, plan.candidate? = some candidate → + candidate ∈ nextCandidates := by + intro candidate hcandidate + have hrecorded := rootAwarePlannedCandidate?_eq_of_plan_some hcandidate + simp [nextCandidates, appendPlannedCandidate, hrecorded] + have hprobeBound := probingHashQueryAfterPlan_probeBound parameter input plan + nextCandidates hplanMem cache + have hnextCovered : PendingCoveredBy nextCandidates context := by + have hsublist : candidates.Sublist nextCandidates := by + unfold nextCandidates appendPlannedCandidate + cases rootAwarePlannedCandidate? parameter input context.state <;> simp + exact hcovered.mono_candidates hsublist + apply privateWitnessCovered_of_mem_runDirectWitnessPlanObserve _ nextCandidates + context fuel table ((probingHashQueryAfterPlan parameter input plan).run cache) + hnextCovered hprobeBound (output := output) (houtput := houtput) + intro result _hdetailed hresultCovered nextOutput hnextOutput + apply privateWitnessCovered_of_mem_canonicalizeDirectWitnessPlanObserve table _ + result.context result.remaining result.value nextCandidates hresultCovered + (output := nextOutput) (houtput := hnextOutput) + intro finalOutput hfinalOutput + have hcanonicalCovered : PendingCoveredBy nextCandidates + (canonicalizeMaterializedValues table result.context) := + (pendingCoveredBy_canonicalize_iff table nextCandidates result.context).2 + hresultCovered + exact ih result.value.1 nextCandidates + (canonicalizeMaterializedValues table result.context) result.remaining + result.value.2 hcanonicalCovered (output := finalOutput) hfinalOutput + | inr message => + have hprobeBound : ((maskedSign parameter root ftsSecret message).run cache).IsQueryBoundP + (IsUncoveredProbe candidates) 0 := + OracleComp.IsQueryBoundP.of_imp (isUncoveredProbe_imp_isProbe candidates) + (maskedSign_probeFree parameter root ftsSecret message cache) + apply privateWitnessCovered_of_mem_runDirectWitnessPlanObserve _ candidates context + fuel table ((maskedSign parameter root ftsSecret message).run cache) hcovered + hprobeBound (output := output) (houtput := houtput) + intro result _hdetailed hresultCovered nextOutput hnextOutput + apply privateWitnessCovered_of_mem_canonicalizeDirectWitnessPlanObserve table _ + result.context result.remaining result.value candidates hresultCovered + (output := nextOutput) (houtput := hnextOutput) + intro finalOutput hfinalOutput + have hcanonicalCovered : PendingCoveredBy candidates + (canonicalizeMaterializedValues table result.context) := + (pendingCoveredBy_canonicalize_iff table candidates result.context).2 hresultCovered + exact ih result.value.1 candidates + (canonicalizeMaterializedValues table result.context) result.remaining result.value.2 + hcanonicalCovered (output := finalOutput) hfinalOutput + +noncomputable def retainedResolvedFinalizationPrivateWitnessPlanObserve + (_table : OtsSecretIndex → HashOutput) (_root : Digest) + (context : DeferredContext) (_fuel : Nat) + (_value : RetainedRestResult × SplitHashCache) (candidates : List Probe) : + ProbComp PrivateWitnessPlanOutput := by + classical + exact if hhit : PrivateStructuralHit context then + pure (some (privateHitWitnessOf context hhit), candidates) + else + pure (none, candidates) + +theorem map_erase_retainedResolvedFinalizationPrivateWitnessPlanObserve + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) (candidates : List Probe) : + erasePrivateWitnessPlanOutput <$> + retainedResolvedFinalizationPrivateWitnessPlanObserve table root context fuel value + candidates = + retainedResolvedFinalizationPrivatePlanObserve table root context fuel value candidates := by + classical + unfold retainedResolvedFinalizationPrivateWitnessPlanObserve + retainedResolvedFinalizationPrivatePlanObserve + retainedResolvedFinalizationPrivateObserve classifyDirectPrivateObserve + by_cases hhit : PrivateStructuralHit context <;> + simp [hhit, erasePrivateWitnessPlanOutput] + +theorem privateWitnessCovered_of_mem_retainedResolvedFinalizationPrivateWitnessPlanObserve + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) (candidates : List Probe) + (hcovered : PendingCoveredBy candidates context) + (output : PrivateWitnessPlanOutput) + (houtput : output ∈ support + (retainedResolvedFinalizationPrivateWitnessPlanObserve table root context fuel value + candidates)) : + PrivateWitnessCovered output := by + classical + unfold retainedResolvedFinalizationPrivateWitnessPlanObserve at houtput + by_cases hhit : PrivateStructuralHit context + · simp [hhit] at houtput + subst output + intro witness heq + simp only [Option.some.injEq] at heq + subst witness + exact candidateListHits_privateHitWitnessOf context candidates hcovered hhit + · simp [hhit] at houtput + subst output + simp [PrivateWitnessCovered] + +noncomputable def granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) : + ProbComp PrivateWitnessPlanOutput := + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivateWitnessPlanObserve table value.1) + candidates context fuel table value.2 + +theorem map_erase_granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) : + erasePrivateWitnessPlanOutput <$> + granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates = + granularDetailedRetainedRestNormalizedPrivatePlanObserve adversary parameter table + ftsSecret context fuel value candidates := by + unfold granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve + granularDetailedRetainedRestNormalizedPrivatePlanObserve + apply map_erase_directDetailedBoundaryNormalizedPrivateWitnessPlanObserve + intro nextContext remaining nextValue nextCandidates + exact map_erase_retainedResolvedFinalizationPrivateWitnessPlanObserve table value.1 nextContext + remaining nextValue nextCandidates + +theorem privateWitnessCovered_of_mem_granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) + (hcovered : PendingCoveredBy candidates context) + (output : PrivateWitnessPlanOutput) + (houtput : output ∈ support + (granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates)) : + PrivateWitnessCovered output := by + unfold granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve at houtput + apply privateWitnessCovered_of_mem_directDetailedBoundaryNormalizedPrivateWitnessPlanObserve + parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationPrivateWitnessPlanObserve table value.1) + candidates context fuel table value.2 hcovered + (output := output) (houtput := houtput) + intro nextContext remaining nextValue nextCandidates nextOutput hnextCovered hnextOutput + exact privateWitnessCovered_of_mem_retainedResolvedFinalizationPrivateWitnessPlanObserve table + value.1 nextContext remaining nextValue nextCandidates hnextCovered nextOutput hnextOutput + +noncomputable def granularAllDirectBoundaryNormalizedPrivateWitnessPlan + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp PrivateWitnessPlanOutput := + runDirectWitnessPlanObserve + (granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret) + [] + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + +theorem map_erase_granularAllDirectBoundaryNormalizedPrivateWitnessPlan + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + erasePrivateWitnessPlanOutput <$> + granularAllDirectBoundaryNormalizedPrivateWitnessPlan adversary parameter table ftsSecret + fuel = + granularAllDirectBoundaryNormalizedPrivatePlan adversary parameter table ftsSecret fuel := by + unfold granularAllDirectBoundaryNormalizedPrivateWitnessPlan + granularAllDirectBoundaryNormalizedPrivatePlan + apply map_erase_runDirectWitnessPlanObserve + intro nextContext remaining value nextCandidates + exact map_erase_granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary + parameter table ftsSecret nextContext remaining value nextCandidates + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryProbability.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryProbability.lean new file mode 100644 index 00000000..450aa599 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryProbability.lean @@ -0,0 +1,174 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivate + +/-! +# Boundary failure probability composition + +The canonical deferred failure is the union of the ordinary direct failure and the first hit +against a privately retained structural value. This file keeps the final probability and security +composition separate from the two endpoint bounds. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_sampledCanonicalDeferredFinishIsNone_le_boundary_failed + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[= true | sampledCanonicalDeferredFinishIsNone adversary parameter ftsSecret fuel] ≤ + Pr[fun outcome => outcome.failed = true | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret fuel] := by + calc + _ = Pr[= true | + sampledAllDirectBoundaryFinishIsNone adversary parameter ftsSecret fuel] := + OracleComp.probOutput_congr rfl + (evalDist_sampledCanonicalDeferredFinishIsNone_eq_allDirect adversary parameter + ftsSecret fuel) + _ = Pr[= true | DirectBoundaryOutcome.failed <$> + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret fuel] := + OracleComp.probOutput_congr rfl + (evalDist_failed_sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret fuel).symm + _ = Pr[fun hit : Bool => hit = true | DirectBoundaryOutcome.failed <$> + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret fuel] := + (probEvent_eq_eq_probOutput _ true).symm + _ ≤ _ := by + rw [probEvent_map] + rfl + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_sampledCanonicalDeferredFinishIsNone_le_boundary_causes + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[= true | sampledCanonicalDeferredFinishIsNone adversary parameter ftsSecret fuel] ≤ + Pr[= .ordinaryFailure | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret fuel] + + Pr[= .privateStructuralFailure | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret fuel] := by + calc + _ = Pr[= true | + sampledAllDirectBoundaryFinishIsNone adversary parameter ftsSecret fuel] := + OracleComp.probOutput_congr rfl + (evalDist_sampledCanonicalDeferredFinishIsNone_eq_allDirect adversary parameter + ftsSecret fuel) + _ = Pr[= true | DirectBoundaryOutcome.failed <$> + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret fuel] := + OracleComp.probOutput_congr rfl + (evalDist_failed_sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret fuel).symm + _ = Pr[fun hit : Bool => hit = true | DirectBoundaryOutcome.failed <$> + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret fuel] := + (probEvent_eq_eq_probOutput _ true).symm + _ = Pr[fun outcome => outcome.failed = true | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret fuel] := by + rw [probEvent_map] + rfl + _ ≤ _ := probEvent_failed_le_ordinary_add_private + (sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret fuel) + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_sampledActualRetainedOtsHashTable_verifyProbe_le_boundary_causes + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + Pr[= .ordinaryFailure | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret fuel] + + Pr[= .privateStructuralFailure | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret fuel] := + (probEvent_sampledActualRetainedOtsHashTable_verifyProbe_le_canonicalDeferred adversary + parameter ftsSecret fuel).trans + (probEvent_sampledCanonicalDeferredFinishIsNone_le_boundary_causes adversary parameter + ftsSecret fuel) + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_sampledActualRetainedOtsHashTable_verifyProbe_le_boundary_failed + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + Pr[fun outcome => outcome.failed = true | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret fuel] := + (probEvent_sampledActualRetainedOtsHashTable_verifyProbe_le_canonicalDeferred adversary + parameter ftsSecret fuel).trans + (probEvent_sampledCanonicalDeferredFinishIsNone_le_boundary_failed adversary parameter + ftsSecret fuel) + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_sampledActualRetainedOtsHashTable_verifyProbe_le_two_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hordinary : + Pr[= .ordinaryFailure | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret q] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) + (hprivate : + Pr[= .privateStructuralFailure | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret q] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + ((2 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ ≤ Pr[= .ordinaryFailure | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret q] + + Pr[= .privateStructuralFailure | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret q] := + probEvent_sampledActualRetainedOtsHashTable_verifyProbe_le_boundary_causes adversary + parameter ftsSecret q + _ ≤ (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + add_le_add hordinary hprivate + _ = _ := by + push_cast + ring + +theorem security_of_sampledAllDirectBoundaryDetailedRetained_causes_le + (hordinary : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ securityBits → + ∀ parameter ∈ support sampleParameter, + ∀ ftsSecret ∈ support sampleFtsSecrets, + Pr[= .ordinaryFailure | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret q] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) + (hprivate : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ securityBits → + ∀ parameter ∈ support sampleParameter, + ∀ ftsSecret ∈ support sampleFtsSecrets, + Pr[= .privateStructuralFailure | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret q] ≤ + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + SphincsSecurityStatement := by + apply security_of_sampledWinningRetainedVerifyProbe_le_mul 2 (by omega) + intro q hqPos adversary hq hqMax parameter hparameter ftsSecret hfts + exact probEvent_sampledActualRetainedOtsHashTable_verifyProbe_le_two_mul adversary parameter + ftsSecret q + (hordinary q hqPos adversary hq hqMax parameter hparameter ftsSecret hfts) + (hprivate q hqPos adversary hq hqMax parameter hparameter ftsSecret hfts) + +theorem security_of_sampledAllDirectBoundaryDetailedRetained_failed_le_mul + (c : Nat) (hc : 2 * c + 1 ≤ 19) + (hfailed : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ securityBits → + ∀ parameter ∈ support sampleParameter, + ∀ ftsSecret ∈ support sampleFtsSecrets, + Pr[fun outcome => outcome.failed = true | + sampledAllDirectBoundaryDetailedRetainedOutcome adversary parameter ftsSecret q] ≤ + ((c * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + SphincsSecurityStatement := by + apply security_of_sampledWinningRetainedVerifyProbe_le_mul c hc + intro q hqPos adversary hq hqMax parameter hparameter ftsSecret hfts + exact (probEvent_sampledActualRetainedOtsHashTable_verifyProbe_le_boundary_failed adversary + parameter ftsSecret q).trans + (hfailed q hqPos adversary hq hqMax parameter hparameter ftsSecret hfts) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryWitnessCoverage.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryWitnessCoverage.lean new file mode 100644 index 00000000..2ea0629e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryWitnessCoverage.lean @@ -0,0 +1,156 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalPrivateEndpoint + +/-! +# Boundary witness coverage + +The materialized-stability coupling is consumed with one combined postcondition. A detailed +failure is covered either by a private witness on the deferred side or by the ordinary projection +of the detailed outcome. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def WitnessOrOrdinaryCovers + (source : PrivateWitnessPlanOutput) (outcome : DirectBoundaryOutcome) : Prop := + outcome.failed = true → source.1.isSome = true ∨ outcome.ordinary = true + +theorem witnessOrOrdinaryCovers_of_witness + (witness : PrivateHitWitness) (candidates : List Probe) + (outcome : DirectBoundaryOutcome) : + WitnessOrOrdinaryCovers (some witness, candidates) outcome := by + intro _ + exact Or.inl rfl + +theorem witnessOrOrdinaryCovers_ordinaryFailure + (source : PrivateWitnessPlanOutput) : + WitnessOrOrdinaryCovers source .ordinaryFailure := by + intro _ + exact Or.inr rfl + +theorem relTriple_any_ordinaryFailure_witnessOrOrdinaryCovers + (left : ProbComp PrivateWitnessPlanOutput) : + RelTriple (spec₁ := unifSpec) (spec₂ := unifSpec) left + (pure (.ordinaryFailure : DirectBoundaryOutcome)) + WitnessOrOrdinaryCovers := by + have hbase : RelTriple left + (pure .ordinaryFailure : ProbComp DirectBoundaryOutcome) (fun _ _ ↦ True) := + relTriple_true (spec₁ := unifSpec) (spec₂ := unifSpec) left + (pure .ordinaryFailure : ProbComp DirectBoundaryOutcome) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + apply relTriple_post_mono hsupported + intro source outcome hrelation + have houtcome : outcome = .ordinaryFailure := by + simpa using hrelation.2 + subst outcome + exact witnessOrOrdinaryCovers_ordinaryFailure source + +set_option maxRecDepth 100000 in +theorem relTriple_finishDirectWitnessPlan_detailed_of_materializedStable + (table : OtsSecretIndex → HashOutput) + (leftRun : ProbComp (DirectWitnessResult (α × SplitHashCache))) + (rightRun : ProbComp (DirectDetailedResult (α × SplitHashCache))) + (leftObserve : DeferredContext → Nat → (α × SplitHashCache) → List Probe → + ProbComp PrivateWitnessPlanOutput) + (rightObserve : DeferredContext → Nat → (α × SplitHashCache) → + ProbComp DirectBoundaryOutcome) + (candidates : List Probe) + (hstep : RelTriple leftRun rightRun + (DirectWitnessMaterializedStableRunEq table)) + (hclean : ∀ left right, + DirectWitnessResult.done left ∈ support leftRun → + DirectDetailedResult.done right ∈ support rightRun → + OrdinaryMaterializedRunEq table left right → + RelTriple + (leftObserve left.context left.remaining left.value candidates) + (rightObserve right.context right.remaining right.value) + WitnessOrOrdinaryCovers) + (hdoomed : ∀ (left : ProbComp PrivateWitnessPlanOutput) right, + DirectDetailedResult.done right ∈ support rightRun → + OrdinaryMaterializedDoomedRun table right → + RelTriple left (rightObserve right.context right.remaining right.value) + WitnessOrOrdinaryCovers) : + RelTriple + (leftRun >>= finishDirectWitnessPlanObserve leftObserve candidates) + (rightRun >>= finishDirectDetailedObserve rightObserve) + WitnessOrOrdinaryCovers := by + have hleftSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hstep + (fun result ↦ result ∈ support leftRun) (fun _ hresult ↦ hresult) + have hbothSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupport + apply relTriple_bind hbothSupport + intro left right hrelation + rcases hrelation with ⟨⟨hrelation, hleftMem⟩, hrightMem⟩ + cases left with + | stoppedFuel => + cases right with + | stopped reason => + cases reason with + | privateStructuralHit => contradiction + | ordinaryHit => + exact relTriple_any_ordinaryFailure_witnessOrOrdinaryCovers _ + | fuelExhausted => + exact relTriple_any_ordinaryFailure_witnessOrOrdinaryCovers _ + | done right => + exact hdoomed (pure (none, candidates)) right hrightMem hrelation + | stoppedOrdinary => + cases right with + | stopped reason => + cases reason with + | privateStructuralHit => contradiction + | ordinaryHit => + exact relTriple_any_ordinaryFailure_witnessOrOrdinaryCovers _ + | fuelExhausted => + exact relTriple_any_ordinaryFailure_witnessOrOrdinaryCovers _ + | done right => + exact hdoomed (pure (none, candidates)) right hrightMem hrelation + | stoppedPrivate witness => + have hbase := relTriple_true + (pure (some witness, candidates) : ProbComp PrivateWitnessPlanOutput) + (finishDirectDetailedObserve rightObserve right) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun source ↦ source = (some witness, candidates)) (by simp) + apply relTriple_post_mono hleft + intro source outcome hsource + rw [hsource.2] + exact witnessOrOrdinaryCovers_of_witness witness candidates outcome + | done left => + cases right with + | stopped reason => + cases reason with + | privateStructuralHit => contradiction + | ordinaryHit => + exact relTriple_any_ordinaryFailure_witnessOrOrdinaryCovers _ + | fuelExhausted => + exact relTriple_any_ordinaryFailure_witnessOrOrdinaryCovers _ + | done right => + rcases hrelation with hcleanRelation | hdoomedRelation + · exact hclean left right hleftMem hrightMem hcleanRelation + · exact hdoomed + (leftObserve left.context left.remaining left.value candidates) + right hrightMem hdoomedRelation + +theorem probEvent_failed_le_witness_add_ordinary_of_relTriple + (source : ProbComp PrivateWitnessPlanOutput) + (detailed : ProbComp DirectBoundaryOutcome) + (hrelation : RelTriple source detailed WitnessOrOrdinaryCovers) : + Pr[fun outcome ↦ outcome.failed = true | detailed] ≤ + Pr[fun output ↦ output.1.isSome = true | source] + + Pr[fun outcome ↦ outcome.ordinary = true | detailed] := by + apply probEvent_le_failure_add_residual_of_relTriple detailed source + (fun outcome output ↦ WitnessOrOrdinaryCovers output outcome) + (fun outcome ↦ outcome.failed = true) + (fun outcome ↦ outcome.ordinary = true) + (fun output ↦ output.1.isSome = true) + (relTriple_symm hrelation) + intro outcome output hcovers hfailed hnotOrdinary + rcases hcovers hfailed with hwitness | hordinary + · exact hwitness + · exact False.elim (hnotOrdinary hordinary) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryWitnessDomination.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryWitnessDomination.lean new file mode 100644 index 00000000..8422aca5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryWitnessDomination.lean @@ -0,0 +1,1525 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryWitnessEndpoint + +/-! +# Boundary failure witness domination + +The canonical execution retains both its boundary outcome and its first private witness. This is +the direction needed by the final reduction: a canonical failure is covered by that witness or by +an ordinary failure of the materialized execution. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +structure BoundaryWitnessPlanOutput where + outcome : DirectBoundaryOutcome + witnessPlan : PrivateWitnessPlanOutput + +def BoundaryWitnessCovers + (source : BoundaryWitnessPlanOutput) (materialized : DirectBoundaryOutcome) : Prop := + source.outcome.failed = true → + source.witnessPlan.1.isSome = true ∨ materialized.ordinary = true + +noncomputable def finishDirectBoundaryWitnessPlanObserve + (observe : DeferredContext → Nat → α → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (candidates : List Probe) : DirectWitnessResult α → + ProbComp BoundaryWitnessPlanOutput + | .stoppedFuel => pure ⟨.ordinaryFailure, none, candidates⟩ + | .stoppedOrdinary => pure ⟨.ordinaryFailure, none, candidates⟩ + | .stoppedPrivate witness => pure ⟨.privateStructuralFailure, some witness, candidates⟩ + | .done result => observe result.context result.remaining result.value candidates + +noncomputable def classifyDirectBoundaryWitnessPlanObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) : + ProbComp BoundaryWitnessPlanOutput := by + classical + exact if hhit : PrivateStructuralHit context then + pure ⟨.privateStructuralFailure, some (privateHitWitnessOf context hhit), candidates⟩ + else if DeferredCompletable table context then + observe context fuel value candidates + else + pure ⟨.ordinaryFailure, none, candidates⟩ + +noncomputable def canonicalizeDirectBoundaryWitnessPlanObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) : + ProbComp BoundaryWitnessPlanOutput := by + classical + let canonical := canonicalizeMaterializedValues table context + exact if hhit : PrivateStructuralHit canonical then + pure ⟨.privateStructuralFailure, some (privateHitWitnessOf canonical hhit), candidates⟩ + else if PublishedValues context.state then + classifyDirectBoundaryWitnessPlanObserve table observe canonical fuel value candidates + else + pure ⟨.ordinaryFailure, none, candidates⟩ + +noncomputable def runDirectBoundaryWitnessPlanObserve + (observe : DeferredContext → Nat → α → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + ProbComp BoundaryWitnessPlanOutput := + runDirectResolvedWitnessFromTable context fuel table computation >>= + finishDirectBoundaryWitnessPlanObserve observe candidates + +noncomputable def directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp BoundaryWitnessPlanOutput := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + (DeferredContext → Nat → (α × SplitHashCache) → List Probe → + ProbComp BoundaryWitnessPlanOutput) → + List Probe → DeferredContext → Nat → (OtsSecretIndex → HashOutput) → + SplitHashCache → ProbComp BoundaryWitnessPlanOutput) + (fun value observe candidates context fuel _table cache => + observe context fuel (value, cache) candidates) + (fun query _next recursivelyRun observe candidates context fuel table cache => + match query with + | .inl (.inl n) => + runDirectBoundaryWitnessPlanObserve + (canonicalizeDirectBoundaryWitnessPlanObserve table + (fun nextContext remaining value nextCandidates => + recursivelyRun value.1 observe nextCandidates nextContext remaining table + value.2)) + candidates context fuel table ((splitUniformImpl n).run cache) + | .inl (.inr input) => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + runDirectBoundaryWitnessPlanObserve + (canonicalizeDirectBoundaryWitnessPlanObserve table + (fun nextContext remaining value laterCandidates => + recursivelyRun value.1 observe laterCandidates nextContext remaining table + value.2)) + nextCandidates context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache) + | .inr message => + runDirectBoundaryWitnessPlanObserve + (canonicalizeDirectBoundaryWitnessPlanObserve table + (fun nextContext remaining value nextCandidates => + recursivelyRun value.1 observe nextCandidates nextContext remaining table + value.2)) + candidates context fuel table ((maskedSign parameter root ftsSecret message).run cache)) + computation observe candidates context fuel table cache + +noncomputable def retainedResolvedFinalizationBoundaryWitnessPlanObserve + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) (candidates : List Probe) : + ProbComp BoundaryWitnessPlanOutput := by + classical + exact if hhit : PrivateStructuralHit context then + pure ⟨.privateStructuralFailure, some (privateHitWitnessOf context hhit), candidates⟩ + else if DeferredCompletable table context then do + let failed ← resolvedFinalizationObserve table context fuel ((root, value.1), value.2) + pure ⟨DirectBoundaryOutcome.ofFailed failed, none, candidates⟩ + else + pure ⟨.ordinaryFailure, none, candidates⟩ + +noncomputable def granularDetailedRetainedRestNormalizedBoundaryWitnessPlanObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) : + ProbComp BoundaryWitnessPlanOutput := + directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationBoundaryWitnessPlanObserve table value.1) + candidates context fuel table value.2 + +noncomputable def granularAllCanonicalBoundaryWitnessPlan + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp BoundaryWitnessPlanOutput := + runDirectBoundaryWitnessPlanObserve + (canonicalizeDirectBoundaryWitnessPlanObserve table + (granularDetailedRetainedRestNormalizedBoundaryWitnessPlanObserve adversary parameter table + ftsSecret)) + [] emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + +noncomputable def granularAllCanonicalBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp DirectBoundaryOutcome := + runDirectDetailedObserve + (canonicalizeDirectDetailedObserve table + (granularDetailedRetainedRestObserve adversary parameter table ftsSecret)) + emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + +noncomputable def granularAllCanonicalBoundaryRetainedFinishIsNone + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := + runDirectResolvedObserve + (canonicalizeObserve table + (granularRetainedRestObserve adversary parameter table ftsSecret)) + emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + +theorem boundaryWitnessCovers_of_witness + (outcome : DirectBoundaryOutcome) (witness : PrivateHitWitness) + (candidates : List Probe) : + BoundaryWitnessCovers ⟨outcome, some witness, candidates⟩ outcome := by + intro _ + exact Or.inl rfl + +theorem relTriple_any_ordinaryFailure_boundaryWitnessCovers + (left : ProbComp BoundaryWitnessPlanOutput) : + RelTriple (spec₁ := unifSpec) (spec₂ := unifSpec) left + (pure (.ordinaryFailure : DirectBoundaryOutcome)) BoundaryWitnessCovers := by + have hbase : RelTriple left + (pure .ordinaryFailure : ProbComp DirectBoundaryOutcome) (fun _ _ ↦ True) := + relTriple_true _ _ + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + apply relTriple_post_mono hsupported + intro source outcome hrelation + have houtcome : outcome = .ordinaryFailure := by simpa using hrelation.2 + subst outcome + intro _ + exact Or.inr rfl + +set_option maxRecDepth 100000 in +theorem relTriple_retainedFinalizationBoundaryWitnessPlan_detailed + (table : OtsSecretIndex → HashOutput) (root : Digest) + (value : RetainedRestResult) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) (candidates : List Probe) + (hcontext : FinalizationContextLE table left right) : + RelTriple + (retainedResolvedFinalizationBoundaryWitnessPlanObserve table root left leftFuel + (value, leftCache) candidates) + (retainedResolvedFinalizationDetailedObserve table root right rightFuel + (value, rightCache)) + BoundaryWitnessCovers := by + have hleftNotPrivate := not_privateStructuralHit_of_deferredCompletable + hcontext.leftCompletable + have hrightNotPrivate := not_privateStructuralHit_of_deferredCompletable + hcontext.rightCompletable + unfold retainedResolvedFinalizationBoundaryWitnessPlanObserve + retainedResolvedFinalizationDetailedObserve classifyDirectObserve + simp only [hleftNotPrivate, hrightNotPrivate, ↓reduceDIte, hcontext.leftCompletable, + hcontext.rightCompletable, ↓reduceIte, map_eq_bind_pure_comp] + have hfinal := relTriple_finishResolvedRunIsNone_of_finalizationContextLE table left right + leftFuel rightFuel ((root, value), leftCache) ((root, value), rightCache) hcontext + apply relTriple_bind hfinal + intro leftFailed rightFailed himp + apply relTriple_pure_pure + intro hsource + right + cases leftFailed <;> cases rightFailed <;> + simp [BoolImp, DirectBoundaryOutcome.ofFailed, DirectBoundaryOutcome.failed, + DirectBoundaryOutcome.ordinary] at himp hsource ⊢ + +set_option maxRecDepth 100000 in +theorem evalDist_witnessPlan_retainedFinalizationBoundaryWitnessPlan + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) (candidates : List Probe) : + evalDist (BoundaryWitnessPlanOutput.witnessPlan <$> + retainedResolvedFinalizationBoundaryWitnessPlanObserve table root context fuel value + candidates) = + evalDist + (retainedResolvedFinalizationPrivateWitnessPlanObserve table root context fuel value + candidates) := by + classical + unfold retainedResolvedFinalizationBoundaryWitnessPlanObserve + retainedResolvedFinalizationPrivateWitnessPlanObserve + by_cases hhit : PrivateStructuralHit context + · simp [hhit] + · simp only [hhit, ↓reduceDIte, map_eq_bind_pure_comp] + by_cases hcompletable : DeferredCompletable table context + · simp only [hcompletable, ↓reduceIte] + simp only [bind_assoc, pure_bind, Function.comp_apply] + change evalDist + (resolvedFinalizationObserve table context fuel ((root, value.1), value.2) >>= + fun _ => pure (none, candidates)) = + evalDist (pure (none, candidates) : ProbComp PrivateWitnessPlanOutput) + exact OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolvedFinalizationObserve table context fuel ((root, value.1), value.2)) + (by simp [resolvedFinalizationObserve]) _ + · simp [hcompletable] + +theorem evalDist_witnessPlan_finishDirectBoundaryWitnessPlanObserve + (observe : DeferredContext → Nat → α → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (witnessObserve : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (result : DirectWitnessResult α) + (hproject : ∀ context fuel value nextCandidates, + evalDist (BoundaryWitnessPlanOutput.witnessPlan <$> + observe context fuel value nextCandidates) = + evalDist (witnessObserve context fuel value nextCandidates)) : + evalDist (BoundaryWitnessPlanOutput.witnessPlan <$> + finishDirectBoundaryWitnessPlanObserve observe candidates result) = + evalDist (finishDirectWitnessPlanObserve witnessObserve candidates result) := by + cases result with + | stoppedFuel => simp [finishDirectBoundaryWitnessPlanObserve, finishDirectWitnessPlanObserve] + | stoppedOrdinary => + simp [finishDirectBoundaryWitnessPlanObserve, finishDirectWitnessPlanObserve] + | stoppedPrivate witness => + simp [finishDirectBoundaryWitnessPlanObserve, finishDirectWitnessPlanObserve] + | done result => exact hproject result.context result.remaining result.value candidates + +theorem evalDist_witnessPlan_classifyDirectBoundaryWitnessPlanObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (witnessObserve : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hproject : ∀ nextContext remaining nextValue nextCandidates, + evalDist (BoundaryWitnessPlanOutput.witnessPlan <$> + observe nextContext remaining nextValue nextCandidates) = + evalDist (witnessObserve nextContext remaining nextValue nextCandidates)) : + evalDist (BoundaryWitnessPlanOutput.witnessPlan <$> + classifyDirectBoundaryWitnessPlanObserve table observe context fuel value candidates) = + evalDist + (classifyDirectWitnessPlanObserve table witnessObserve context fuel value candidates) := by + classical + unfold classifyDirectBoundaryWitnessPlanObserve classifyDirectWitnessPlanObserve + by_cases hhit : PrivateStructuralHit context + · simp [hhit] + · simp only [hhit, ↓reduceDIte] + by_cases hcompletable : DeferredCompletable table context + · simp only [hcompletable, ↓reduceIte] + exact hproject context fuel value candidates + · simp [hcompletable] + +theorem evalDist_witnessPlan_canonicalizeDirectBoundaryWitnessPlanObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (witnessObserve : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hproject : ∀ nextContext remaining nextValue nextCandidates, + evalDist (BoundaryWitnessPlanOutput.witnessPlan <$> + observe nextContext remaining nextValue nextCandidates) = + evalDist (witnessObserve nextContext remaining nextValue nextCandidates)) : + evalDist (BoundaryWitnessPlanOutput.witnessPlan <$> + canonicalizeDirectBoundaryWitnessPlanObserve table observe context fuel value candidates) = + evalDist + (canonicalizeDirectWitnessPlanObserve table witnessObserve context fuel value candidates) := by + classical + unfold canonicalizeDirectBoundaryWitnessPlanObserve canonicalizeDirectWitnessPlanObserve + let canonical := canonicalizeMaterializedValues table context + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit] + · simp only [canonical, hhit, ↓reduceDIte] + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + exact evalDist_witnessPlan_classifyDirectBoundaryWitnessPlanObserve table observe + witnessObserve canonical fuel value candidates hproject + · simp [hpublished] + +set_option maxRecDepth 100000 in +theorem evalDist_witnessPlan_runDirectBoundaryWitnessPlanObserve + (observe : DeferredContext → Nat → α → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (witnessObserve : DeferredContext → Nat → α → List Probe → + ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hproject : ∀ nextContext remaining value nextCandidates, + evalDist (BoundaryWitnessPlanOutput.witnessPlan <$> + observe nextContext remaining value nextCandidates) = + evalDist (witnessObserve nextContext remaining value nextCandidates)) : + evalDist (BoundaryWitnessPlanOutput.witnessPlan <$> + runDirectBoundaryWitnessPlanObserve observe candidates context fuel table computation) = + evalDist + (runDirectWitnessPlanObserve witnessObserve candidates context fuel table computation) := by + unfold runDirectBoundaryWitnessPlanObserve runDirectWitnessPlanObserve + rw [map_bind] + apply evalDist_bind_congr + intro result _hresult + exact evalDist_witnessPlan_finishDirectBoundaryWitnessPlanObserve observe witnessObserve + candidates result hproject + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_witnessPlan_directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (witnessObserve : DeferredContext → Nat → (α × SplitHashCache) → List Probe → + ProbComp PrivateWitnessPlanOutput) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hproject : ∀ nextContext remaining value nextCandidates, + evalDist (BoundaryWitnessPlanOutput.witnessPlan <$> + observe nextContext remaining value nextCandidates) = + evalDist (witnessObserve nextContext remaining value nextCandidates)) : + evalDist (BoundaryWitnessPlanOutput.witnessPlan <$> + directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve parameter root ftsSecret + computation observe candidates context fuel table cache) = + evalDist (directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + computation witnessObserve candidates context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve, + OracleComp.construct_pure, + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, OracleComp.construct_pure] + exact hproject context fuel (value, cache) candidates + | query_bind query next ih => + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve, + OracleComp.construct_query_bind, + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind] + apply evalDist_witnessPlan_runDirectBoundaryWitnessPlanObserve + intro nextContext remaining value nextCandidates + apply evalDist_witnessPlan_canonicalizeDirectBoundaryWitnessPlanObserve + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + | inr input => + rw [directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve, + OracleComp.construct_query_bind, + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind] + apply evalDist_witnessPlan_runDirectBoundaryWitnessPlanObserve + intro nextContext remaining value laterCandidates + apply evalDist_witnessPlan_canonicalizeDirectBoundaryWitnessPlanObserve + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + | inr message => + rw [directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve, + OracleComp.construct_query_bind, + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind] + apply evalDist_witnessPlan_runDirectBoundaryWitnessPlanObserve + intro nextContext remaining value nextCandidates + apply evalDist_witnessPlan_canonicalizeDirectBoundaryWitnessPlanObserve + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_witnessPlan_granularDetailedRetainedRestNormalizedBoundaryWitnessPlanObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) : + evalDist (BoundaryWitnessPlanOutput.witnessPlan <$> + granularDetailedRetainedRestNormalizedBoundaryWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates) = + evalDist + (granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates) := by + unfold granularDetailedRetainedRestNormalizedBoundaryWitnessPlanObserve + granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve + apply evalDist_witnessPlan_directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve + intro nextContext remaining nextValue nextCandidates + exact evalDist_witnessPlan_retainedFinalizationBoundaryWitnessPlan table value.1 nextContext + remaining nextValue nextCandidates + +set_option maxRecDepth 100000 in +theorem evalDist_witnessPlan_granularAllCanonicalBoundaryWitnessPlan + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (BoundaryWitnessPlanOutput.witnessPlan <$> + granularAllCanonicalBoundaryWitnessPlan adversary parameter table ftsSecret fuel) = + evalDist + (granularAllCanonicalPrivateWitnessPlan adversary parameter table ftsSecret fuel) := by + unfold granularAllCanonicalBoundaryWitnessPlan granularAllCanonicalPrivateWitnessPlan + apply evalDist_witnessPlan_runDirectBoundaryWitnessPlanObserve + intro context remaining value candidates + apply evalDist_witnessPlan_canonicalizeDirectBoundaryWitnessPlanObserve + intro nextContext nextRemaining nextValue nextCandidates + exact + evalDist_witnessPlan_granularDetailedRetainedRestNormalizedBoundaryWitnessPlanObserve + adversary parameter table ftsSecret nextContext nextRemaining nextValue nextCandidates + +theorem evalDist_outcome_finishDirectBoundaryWitnessPlanObserve + (observe : DeferredContext → Nat → α → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (detailedObserve : DeferredContext → Nat → α → ProbComp DirectBoundaryOutcome) + (candidates : List Probe) (result : DirectWitnessResult α) + (hproject : ∀ context fuel value nextCandidates, + evalDist (BoundaryWitnessPlanOutput.outcome <$> observe context fuel value nextCandidates) = + evalDist (detailedObserve context fuel value)) : + evalDist (BoundaryWitnessPlanOutput.outcome <$> + finishDirectBoundaryWitnessPlanObserve observe candidates result) = + evalDist (finishDirectDetailedObserve detailedObserve result.erase) := by + cases result with + | stoppedFuel => simp [finishDirectBoundaryWitnessPlanObserve, finishDirectDetailedObserve, + DirectWitnessResult.erase] + | stoppedOrdinary => simp [finishDirectBoundaryWitnessPlanObserve, finishDirectDetailedObserve, + DirectWitnessResult.erase] + | stoppedPrivate witness => + simp [finishDirectBoundaryWitnessPlanObserve, finishDirectDetailedObserve, + DirectWitnessResult.erase] + | done result => exact hproject result.context result.remaining result.value candidates + +theorem evalDist_outcome_classifyDirectBoundaryWitnessPlanObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (detailedObserve : DeferredContext → Nat → α → ProbComp DirectBoundaryOutcome) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hproject : ∀ nextContext remaining nextValue nextCandidates, + evalDist (BoundaryWitnessPlanOutput.outcome <$> + observe nextContext remaining nextValue nextCandidates) = + evalDist (detailedObserve nextContext remaining nextValue)) : + evalDist (BoundaryWitnessPlanOutput.outcome <$> + classifyDirectBoundaryWitnessPlanObserve table observe context fuel value candidates) = + evalDist (classifyDirectDetailedObserve table detailedObserve context fuel value) := by + classical + unfold classifyDirectBoundaryWitnessPlanObserve classifyDirectDetailedObserve + by_cases hhit : PrivateStructuralHit context + · simp [hhit] + · simp only [hhit, ↓reduceDIte] + by_cases hcompletable : DeferredCompletable table context + · simp only [hcompletable, ↓reduceIte] + exact hproject context fuel value candidates + · simp [hcompletable] + +theorem evalDist_outcome_canonicalizeDirectBoundaryWitnessPlanObserve + (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (detailedObserve : DeferredContext → Nat → α → ProbComp DirectBoundaryOutcome) + (context : DeferredContext) (fuel : Nat) (value : α) (candidates : List Probe) + (hproject : ∀ nextContext remaining nextValue nextCandidates, + evalDist (BoundaryWitnessPlanOutput.outcome <$> + observe nextContext remaining nextValue nextCandidates) = + evalDist (detailedObserve nextContext remaining nextValue)) : + evalDist (BoundaryWitnessPlanOutput.outcome <$> + canonicalizeDirectBoundaryWitnessPlanObserve table observe context fuel value candidates) = + evalDist (canonicalizeDirectDetailedObserve table detailedObserve context fuel value) := by + classical + unfold canonicalizeDirectBoundaryWitnessPlanObserve canonicalizeDirectDetailedObserve + let canonical := canonicalizeMaterializedValues table context + by_cases hhit : PrivateStructuralHit canonical + · simp [canonical, hhit] + · simp only [canonical, hhit, ↓reduceDIte] + by_cases hpublished : PublishedValues context.state + · simp only [hpublished, ↓reduceIte] + exact evalDist_outcome_classifyDirectBoundaryWitnessPlanObserve table observe + detailedObserve canonical fuel value candidates hproject + · simp [hpublished] + +set_option maxRecDepth 100000 in +theorem evalDist_outcome_runDirectBoundaryWitnessPlanObserve + (observe : DeferredContext → Nat → α → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (detailedObserve : DeferredContext → Nat → α → ProbComp DirectBoundaryOutcome) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hproject : ∀ nextContext remaining value nextCandidates, + evalDist (BoundaryWitnessPlanOutput.outcome <$> + observe nextContext remaining value nextCandidates) = + evalDist (detailedObserve nextContext remaining value)) : + evalDist (BoundaryWitnessPlanOutput.outcome <$> + runDirectBoundaryWitnessPlanObserve observe candidates context fuel table computation) = + evalDist (runDirectDetailedObserve detailedObserve context fuel table computation) := by + unfold runDirectBoundaryWitnessPlanObserve runDirectDetailedObserve + rw [map_bind] + calc + _ = evalDist + (runDirectResolvedWitnessFromTable context fuel table computation >>= fun result ↦ + finishDirectDetailedObserve detailedObserve result.erase) := by + apply evalDist_bind_congr + intro result _hresult + exact evalDist_outcome_finishDirectBoundaryWitnessPlanObserve observe detailedObserve + candidates result hproject + _ = _ := by + rw [← map_erase_runDirectResolvedWitnessFromTable computation context fuel table, + map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro result _hresult + rfl + +set_option maxRecDepth 100000 in +theorem evalDist_runDirectDetailedObserve_probingHashQuery_eq_afterPlan + (parameter : PublicParameter) (input : HashInput) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (observe : DeferredContext → Nat → (HashOutput × SplitHashCache) → + ProbComp DirectBoundaryOutcome) + (hfactor : probingHashQuery parameter input = (do + let plan ← planProbingHashQuery parameter input + probingHashQueryAfterPlan parameter input plan)) : + evalDist (runDirectDetailedObserve observe context fuel table + ((probingHashQuery parameter input).run cache)) = + evalDist (runDirectDetailedObserve observe context fuel table + ((probingHashQueryAfterPlan parameter input + (purePlanProbingHashQuery parameter input context.state)).run cache)) := by + rw [hfactor] + unfold runDirectDetailedObserve + rw [StateT.run_bind, runDirectResolvedDetailedFromTable_bind] + rw [runDirectResolvedDetailed_planProbingHashQuery parameter input context.state context fuel + table cache rfl] + simp only [pure_bind] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 1000000 in +theorem evalDist_outcome_directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (detailedObserve : DeferredContext → Nat → (α × SplitHashCache) → + ProbComp DirectBoundaryOutcome) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hproject : ∀ nextContext remaining value nextCandidates, + evalDist (BoundaryWitnessPlanOutput.outcome <$> + observe nextContext remaining value nextCandidates) = + evalDist (detailedObserve nextContext remaining value)) : + evalDist (BoundaryWitnessPlanOutput.outcome <$> + directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve parameter root ftsSecret + computation observe candidates context fuel table cache) = + evalDist (directDetailedBoundaryObserve + (maskedExpandedAdversaryImpl parameter root ftsSecret) computation detailedObserve + context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing candidates context fuel cache with + | pure value => + rw [directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve, + OracleComp.construct_pure, directDetailedBoundaryObserve, OracleComp.construct_pure] + exact hproject context fuel (value, cache) candidates + | query_bind query next ih => + rw [directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve, + OracleComp.construct_query_bind, directDetailedBoundaryObserve, + OracleComp.construct_query_bind] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + apply evalDist_outcome_runDirectBoundaryWitnessPlanObserve + intro nextContext remaining value nextCandidates + apply evalDist_outcome_canonicalizeDirectBoundaryWitnessPlanObserve + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + let nextDetailed : DeferredContext → Nat → + (HashOutput × SplitHashCache) → ProbComp DirectBoundaryOutcome := + canonicalizeDirectDetailedObserve table + (fun nextContext remaining value ↦ + directDetailedBoundaryObserve + (maskedExpandedAdversaryImpl parameter root ftsSecret) + (next value.1) detailedObserve nextContext remaining table value.2) + calc + _ = evalDist (runDirectDetailedObserve nextDetailed + context fuel table + ((probingHashQueryAfterPlan parameter input plan).run cache)) := by + apply evalDist_outcome_runDirectBoundaryWitnessPlanObserve + intro nextContext remaining value laterCandidates + apply evalDist_outcome_canonicalizeDirectBoundaryWitnessPlanObserve + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + _ = _ := by + symm + exact evalDist_runDirectDetailedObserve_probingHashQuery_eq_afterPlan + parameter input context fuel table cache nextDetailed (by + cases hprobe : decodeProbe? parameter input with + | some candidate => + cases hposition : decodePosition? parameter input with + | none => + exact probingHashQuery_eq_plan_then_afterPlan_of_probe_some_nonleaf + parameter input candidate hprobe (by + rintro ⟨lay, tree, leafIdx, heq⟩ + simp [hposition] at heq) + | some position => + cases position with + | leaf lay tree leafIdx => + exact probingHashQuery_eq_plan_then_afterPlan_leaf parameter input + candidate lay tree leafIdx hprobe hposition + | chain | node | ftsLeaf | ftsNode | ftsRoots => + exact probingHashQuery_eq_plan_then_afterPlan_of_probe_some_nonleaf + parameter input candidate hprobe (by + rintro ⟨lay, tree, leafIdx, heq⟩ + simp [hposition] at heq) + | none => + cases hposition : decodePosition? parameter input with + | none => + exact probingHashQuery_eq_plan_then_afterPlan_of_probe_none_nonnode + parameter input hprobe (by + rintro ⟨lay, tree, level, nodeIdx, heq⟩ + simp [hposition] at heq) + | some position => + cases position with + | node lay tree level nodeIdx => + exact probingHashQuery_eq_plan_then_afterPlan_node parameter input + lay tree level nodeIdx hprobe hposition + | chain | leaf | ftsLeaf | ftsNode | ftsRoots => + exact probingHashQuery_eq_plan_then_afterPlan_of_probe_none_nonnode + parameter input hprobe (by + rintro ⟨lay, tree, level, nodeIdx, heq⟩ + simp [hposition] at heq)) + | inr message => + apply evalDist_outcome_runDirectBoundaryWitnessPlanObserve + intro nextContext remaining value nextCandidates + apply evalDist_outcome_canonicalizeDirectBoundaryWitnessPlanObserve + intro finalContext finalRemaining finalValue finalCandidates + exact ih finalValue.1 finalCandidates finalContext finalRemaining finalValue.2 + +theorem evalDist_outcome_retainedFinalizationBoundaryWitnessPlan + (table : OtsSecretIndex → HashOutput) (root : Digest) + (context : DeferredContext) (fuel : Nat) + (value : RetainedRestResult × SplitHashCache) (candidates : List Probe) : + evalDist (BoundaryWitnessPlanOutput.outcome <$> + retainedResolvedFinalizationBoundaryWitnessPlanObserve table root context fuel value + candidates) = + evalDist (retainedResolvedFinalizationDetailedObserve table root context fuel value) := by + classical + unfold retainedResolvedFinalizationBoundaryWitnessPlanObserve + retainedResolvedFinalizationDetailedObserve classifyDirectObserve + by_cases hhit : PrivateStructuralHit context + · simp [hhit] + · simp only [hhit, ↓reduceDIte] + by_cases hcompletable : DeferredCompletable table context + · simp [hcompletable, Functor.map_map] + · simp [hcompletable] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_outcome_granularDetailedRetainedRestNormalizedBoundaryWitnessPlanObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) (candidates : List Probe) : + evalDist (BoundaryWitnessPlanOutput.outcome <$> + granularDetailedRetainedRestNormalizedBoundaryWitnessPlanObserve adversary parameter table + ftsSecret context fuel value candidates) = + evalDist (granularDetailedRetainedRestObserve adversary parameter table ftsSecret + context fuel value) := by + unfold granularDetailedRetainedRestNormalizedBoundaryWitnessPlanObserve + granularDetailedRetainedRestObserve + apply evalDist_outcome_directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve + intro nextContext remaining nextValue nextCandidates + exact evalDist_outcome_retainedFinalizationBoundaryWitnessPlan table value.1 nextContext + remaining nextValue nextCandidates + +set_option maxRecDepth 100000 in +theorem evalDist_outcome_granularAllCanonicalBoundaryWitnessPlan + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (BoundaryWitnessPlanOutput.outcome <$> + granularAllCanonicalBoundaryWitnessPlan adversary parameter table ftsSecret fuel) = + evalDist (granularAllCanonicalBoundaryDetailedRetainedOutcome adversary parameter table + ftsSecret fuel) := by + unfold granularAllCanonicalBoundaryWitnessPlan + granularAllCanonicalBoundaryDetailedRetainedOutcome + apply evalDist_outcome_runDirectBoundaryWitnessPlanObserve + intro context remaining value candidates + apply evalDist_outcome_canonicalizeDirectBoundaryWitnessPlanObserve + intro nextContext nextRemaining nextValue nextCandidates + exact + evalDist_outcome_granularDetailedRetainedRestNormalizedBoundaryWitnessPlanObserve + adversary parameter table ftsSecret nextContext nextRemaining nextValue nextCandidates + +set_option maxRecDepth 100000 in +theorem evalDist_failed_canonicalGranularRetainedRest + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) (value : Digest × SplitHashCache) + (hconsistent : context.ValuesConsistent) : + evalDist (DirectBoundaryOutcome.failed <$> + canonicalizeDirectDetailedObserve table + (granularDetailedRetainedRestObserve adversary parameter table ftsSecret) + context fuel value) = + evalDist (canonicalizeObserve table + (granularRetainedRestObserve adversary parameter table ftsSecret) + context fuel value) := by + apply evalDist_failed_canonicalizeDirectDetailedObserve + table + (granularDetailedRetainedRestObserve adversary parameter table ftsSecret) + (granularRetainedRestObserve adversary parameter table ftsSecret) + context fuel value hconsistent + exact evalDist_failed_granularDetailedRetainedRestObserve adversary parameter table ftsSecret + (canonicalizeMaterializedValues table context) fuel value + (canonicalizeMaterializedValues_valuesConsistent table context hconsistent) + (canonicalizeMaterializedValues_startTableAgrees table context) + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem evalDist_failed_granularAllCanonicalBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.failed <$> + granularAllCanonicalBoundaryDetailedRetainedOutcome adversary parameter table + ftsSecret fuel) = + evalDist (granularAllCanonicalBoundaryRetainedFinishIsNone adversary parameter table + ftsSecret fuel) := by + let initial : DeferredContext := emptyWitnessDeferredContext + unfold granularAllCanonicalBoundaryDetailedRetainedOutcome + granularAllCanonicalBoundaryRetainedFinishIsNone + apply evalDist_failed_runDirectDetailedObserve + (detailedObserve := canonicalizeDirectDetailedObserve table + (granularDetailedRetainedRestObserve adversary parameter table ftsSecret)) + (observe := canonicalizeObserve table + (granularRetainedRestObserve adversary parameter table ftsSecret)) + (context := initial) (fuel := fuel) (table := table) + (computation := maskedPublishedTreeRoot.run emptySplitHashCache) + intro result hresult + have hdirect : some result ∈ support (runDirectResolvedFromTable initial fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) := + mem_support_runDirectResolvedFromTable_of_done_detailed + (maskedPublishedTreeRoot.run emptySplitHashCache) initial fuel table result hresult + have hcore : result.table = table ∧ result.context.ValuesConsistent ∧ + StartTableAgrees result.context.state table := + resolvedCore_of_mem_runDirectResolvedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) initial fuel table result + DeferredContext.valid_empty.valuesConsistent (startTableAgrees_empty table) hdirect + exact evalDist_failed_canonicalGranularRetainedRest adversary parameter table + ftsSecret result.context result.remaining result.value hcore.2.1 + +noncomputable def sampledGranularAllCanonicalBoundaryWitnessPlan + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp BoundaryWitnessPlanOutput := do + let table ← sampleOtsHashTable + granularAllCanonicalBoundaryWitnessPlan adversary parameter table ftsSecret fuel + +noncomputable def sampledRootAwareMaterializedBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp DirectBoundaryOutcome := do + let table ← sampleOtsHashTable + rootAwareMaterializedBoundaryDetailedRetainedOutcome adversary parameter table ftsSecret fuel + +noncomputable def sampledGranularAllCanonicalBoundaryRetainedFinishIsNone + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := do + let table ← sampleOtsHashTable + granularAllCanonicalBoundaryRetainedFinishIsNone adversary parameter table ftsSecret fuel + +set_option maxRecDepth 100000 in +theorem evalDist_failed_granularAllCanonicalBoundaryWitnessPlan + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist ((fun output => output.outcome.failed) <$> + granularAllCanonicalBoundaryWitnessPlan adversary parameter table ftsSecret fuel) = + evalDist (granularAllCanonicalBoundaryRetainedFinishIsNone adversary parameter table + ftsSecret fuel) := by + calc + _ = evalDist (DirectBoundaryOutcome.failed <$> + (BoundaryWitnessPlanOutput.outcome <$> + granularAllCanonicalBoundaryWitnessPlan adversary parameter table ftsSecret fuel)) := by + rw [Functor.map_map] + _ = evalDist (DirectBoundaryOutcome.failed <$> + granularAllCanonicalBoundaryDetailedRetainedOutcome adversary parameter table + ftsSecret fuel) := by + simpa only [evalDist_map] using + congrArg (Functor.map DirectBoundaryOutcome.failed) + (evalDist_outcome_granularAllCanonicalBoundaryWitnessPlan adversary parameter table + ftsSecret fuel) + _ = _ := evalDist_failed_granularAllCanonicalBoundaryDetailedRetainedOutcome adversary + parameter table ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem evalDist_failed_sampledGranularAllCanonicalBoundaryWitnessPlan + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist ((fun output => output.outcome.failed) <$> + sampledGranularAllCanonicalBoundaryWitnessPlan adversary parameter ftsSecret fuel) = + evalDist (sampledGranularAllCanonicalBoundaryRetainedFinishIsNone adversary parameter + ftsSecret fuel) := by + unfold sampledGranularAllCanonicalBoundaryWitnessPlan + sampledGranularAllCanonicalBoundaryRetainedFinishIsNone + rw [map_bind] + apply evalDist_bind_congr + intro table _htable + exact evalDist_failed_granularAllCanonicalBoundaryWitnessPlan adversary parameter table + ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem evalDist_witnessPlan_sampledGranularAllCanonicalBoundaryWitnessPlan + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (BoundaryWitnessPlanOutput.witnessPlan <$> + sampledGranularAllCanonicalBoundaryWitnessPlan adversary parameter ftsSecret fuel) = + evalDist + (sampledGranularAllCanonicalPrivateWitnessPlan adversary parameter ftsSecret fuel) := by + unfold sampledGranularAllCanonicalBoundaryWitnessPlan + sampledGranularAllCanonicalPrivateWitnessPlan + rw [map_bind] + apply evalDist_bind_congr + intro table _htable + exact evalDist_witnessPlan_granularAllCanonicalBoundaryWitnessPlan adversary parameter table + ftsSecret fuel + +set_option maxRecDepth 100000 in +theorem relTriple_finishBoundaryWitnessPlan_detailed_of_materializedStable + (table : OtsSecretIndex → HashOutput) + (leftRun : ProbComp (DirectWitnessResult (α × SplitHashCache))) + (rightRun : ProbComp (DirectDetailedResult (α × SplitHashCache))) + (leftObserve : DeferredContext → Nat → (α × SplitHashCache) → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (rightObserve : DeferredContext → Nat → (α × SplitHashCache) → + ProbComp DirectBoundaryOutcome) + (candidates : List Probe) + (hstep : RelTriple leftRun rightRun (DirectWitnessMaterializedStableRunEq table)) + (hclean : ∀ left right, + DirectWitnessResult.done left ∈ support leftRun → + DirectDetailedResult.done right ∈ support rightRun → + OrdinaryMaterializedRunEq table left right → + RelTriple + (leftObserve left.context left.remaining left.value candidates) + (rightObserve right.context right.remaining right.value) + BoundaryWitnessCovers) + (hdoomed : ∀ (left : ProbComp BoundaryWitnessPlanOutput) right, + DirectDetailedResult.done right ∈ support rightRun → + OrdinaryMaterializedDoomedRun table right → + RelTriple left (rightObserve right.context right.remaining right.value) + BoundaryWitnessCovers) : + RelTriple + (leftRun >>= finishDirectBoundaryWitnessPlanObserve leftObserve candidates) + (rightRun >>= finishDirectDetailedObserve rightObserve) + BoundaryWitnessCovers := by + have hleftSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hstep + (fun result ↦ result ∈ support leftRun) (fun _ hresult ↦ hresult) + have hbothSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupport + apply relTriple_bind hbothSupport + intro left right hrelation + rcases hrelation with ⟨⟨hrelation, hleftMem⟩, hrightMem⟩ + cases left with + | stoppedFuel => + cases right with + | stopped reason => + cases reason with + | privateStructuralHit => contradiction + | ordinaryHit => simp [finishDirectBoundaryWitnessPlanObserve, + finishDirectDetailedObserve, BoundaryWitnessCovers] + | fuelExhausted => simp [finishDirectBoundaryWitnessPlanObserve, + finishDirectDetailedObserve, BoundaryWitnessCovers] + | done right => + exact hdoomed (pure ⟨.ordinaryFailure, none, candidates⟩) right hrightMem hrelation + | stoppedOrdinary => + cases right with + | stopped reason => + cases reason with + | privateStructuralHit => contradiction + | ordinaryHit => simp [finishDirectBoundaryWitnessPlanObserve, + finishDirectDetailedObserve, BoundaryWitnessCovers] + | fuelExhausted => simp [finishDirectBoundaryWitnessPlanObserve, + finishDirectDetailedObserve, BoundaryWitnessCovers] + | done right => + exact hdoomed (pure ⟨.ordinaryFailure, none, candidates⟩) right hrightMem hrelation + | stoppedPrivate witness => + have hbase := relTriple_true + (pure ⟨.privateStructuralFailure, some witness, candidates⟩ : + ProbComp BoundaryWitnessPlanOutput) + (finishDirectDetailedObserve rightObserve right) + have hleft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun source ↦ source = ⟨.privateStructuralFailure, some witness, candidates⟩) (by simp) + apply relTriple_post_mono hleft + intro source outcome hsource + rw [hsource.2] + intro _ + exact Or.inl rfl + | done left => + cases right with + | stopped reason => + cases reason with + | privateStructuralHit => contradiction + | ordinaryHit => exact relTriple_any_ordinaryFailure_boundaryWitnessCovers _ + | fuelExhausted => exact relTriple_any_ordinaryFailure_boundaryWitnessCovers _ + | done right => + rcases hrelation with hcleanRelation | hdoomedRelation + · exact hclean left right hleftMem hrightMem hcleanRelation + · exact hdoomed + (leftObserve left.context left.remaining left.value candidates) + right hrightMem hdoomedRelation + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_normalizedBoundaryWitness_rootAwareMaterializedDetailed + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (leftObserve : DeferredContext → Nat → (α × SplitHashCache) → List Probe → + ProbComp BoundaryWitnessPlanOutput) + (rightObserve : DeferredContext → Nat → (α × SplitHashCache) → + ProbComp DirectBoundaryOutcome) + (candidates : List Probe) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) (q bound : Nat) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + computation).IsQueryBoundP (fun query => query matches Sum.inr _) bound) + (hcontext : FinalizationContextLE table left right) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hcanonical : CanonicalMaterializedValues table left) + (hleftLower : bound ≤ leftFuel) (hleftUpper : leftFuel ≤ q) + (hrightLower : q + bound ≤ rightFuel) + (hterminal : ∀ value nextLeft nextRight nextLeftFuel nextRightFuel + nextLeftCache nextRightCache nextCandidates, + FinalizationContextLE table nextLeft nextRight → + nextLeftFuel ≤ nextRightFuel → + ordinaryQueryCache nextLeftCache = ordinaryQueryCache nextRightCache → + nextLeft.state.revealed = nextRight.state.revealed → + LazyRevealProbe.ValuesLE nextLeft.state nextRight.state → + PublishedValues nextLeft.state → + nextRight = directDeferredContext nextRight.state → + CanonicalMaterializedValues table nextLeft → + RelTriple + (leftObserve nextLeft nextLeftFuel (value, nextLeftCache) nextCandidates) + (rightObserve nextRight nextRightFuel (value, nextRightCache)) + BoundaryWitnessCovers) : + RelTriple + (directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve parameter root ftsSecret + computation leftObserve candidates left leftFuel table leftCache) + (rootAwareMaterializedDetailedBoundaryObserve parameter root ftsSecret computation + rightObserve right rightFuel table rightCache) + BoundaryWitnessCovers := by + induction computation using OracleComp.inductionOn generalizing + candidates left right leftFuel rightFuel leftCache rightCache bound with + | pure value => + simp only [directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve, + rootAwareMaterializedDetailedBoundaryObserve, OracleComp.construct_pure] + exact hterminal value left right leftFuel rightFuel leftCache rightCache candidates + hcontext (by omega) hcache hrevealed hvalues hpublished hrightMaterialized hcanonical + | query_bind query next ih => + rw [directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve, + OracleComp.construct_query_bind, rootAwareMaterializedDetailedBoundaryObserve, + OracleComp.construct_query_bind] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + simp only + let nextLeftObserve : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → List Probe → + ProbComp BoundaryWitnessPlanOutput := + fun nextContext remaining value nextCandidates => + directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve parameter root + ftsSecret (next value.1) leftObserve nextCandidates nextContext remaining + table value.2 + let nextRightObserve : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → ProbComp DirectBoundaryOutcome := + fun nextContext remaining value => + rootAwareMaterializedDetailedBoundaryObserve parameter root ftsSecret + (next value.1) rightObserve nextContext remaining table value.2 + apply relTriple_finishBoundaryWitnessPlan_detailed_of_materializedStable table + · exact (witnessMaterializedStableCouples_splitUniformImpl table n) + left right leftFuel rightFuel leftCache rightCache hcontext (by omega) hcache + hrevealed hvalues hpublished hrightMaterialized + · intro nextLeft nextRight hleftSupport hrightSupport hclean + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hleftCompletable := hcanonicalRun.context_le.leftCompletable + have hleftNotPrivate := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hrightNotPrivate := + not_privateStructuralHit_of_deferredCompletable + hcanonicalRun.context_le.rightCompletable + simp only [canonicalizeDirectBoundaryWitnessPlanObserve, hleftNotPrivate, + ↓reduceDIte, hclean.left_published, ↓reduceIte, + classifyDirectBoundaryWitnessPlanObserve, hleftCompletable, + classifyDirectDetailedObserve, hrightNotPrivate, + hcanonicalRun.context_le.rightCompletable] + rw [← hclean.value_eq] + have hleftFuelPreserved : leftFuel ≤ nextLeft.remaining := by + have := fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table nextLeft 0 + (splitUniformImpl_probeFree n leftCache) hleftSupport + omega + have hrightFuelPreserved : rightFuel ≤ nextRight.remaining := by + have := fuel_le_remaining_add_of_done_runDirectResolvedDetailedFromTable + ((splitUniformImpl n).run rightCache) right rightFuel table nextRight 0 + (splitUniformImpl_probeFree n rightCache) hrightSupport + omega + have hleftRemainingUpper : nextLeft.remaining ≤ leftFuel := + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table nextLeft (by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩) + exact ih nextLeft.value.1 candidates canonical nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 bound + (hbound.2 nextLeft.value.1) hcanonicalRun.context_le hcanonicalRun.cache_eq + hcanonicalRun.revealed_eq hcanonicalRun.values_le + hcanonicalRun.left_published hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table nextLeft.context + hclean.context_le.view.leftConsistent) + (by omega) (by omega) (by omega) + · intro leftRun nextRight _hrightSupport hdoomed + have hnotPrivate := not_privateStructuralHit_of_directDeferredContext + nextRight.context hdoomed.2 + have hnotCompletable : ¬DeferredCompletable table nextRight.context := + hdoomed.1.2.2.2 + simpa [classifyDirectDetailedObserve, hnotPrivate, hnotCompletable] using + (relTriple_any_ordinaryFailure_boundaryWitnessCovers leftRun) + | inr input => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + simp only + have hrightValues : + (materializedCanonicalContext table right.state).state.values = + left.state.values := by + unfold materializedCanonicalContext + rw [← hrightMaterialized] + exact canonicalized_right_values_eq_of_finalizationContextLE hcontext + hrevealed hcanonical + have hplanEq : + purePlanProbingHashQuery parameter input + (materializedCanonicalContext table right.state).state = + purePlanProbingHashQuery parameter input left.state := + purePlanProbingHashQuery_eq_of_values_eq hrightValues parameter input + rw [hplanEq] + let plan := purePlanProbingHashQuery parameter input left.state + have hpublicExecutor : + probingHashQueryAfterRootAwarePublicPlan parameter input + (materializedCanonicalContext table right.state).state plan = + probingHashQueryAfterRootAwarePublicPlan parameter input left.state plan := + probingHashQueryAfterRootAwarePublicPlan_eq_of_values_eq parameter input + hrightValues plan + rw [hpublicExecutor] + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input left.state) + let nextLeftObserve : DeferredContext → Nat → + (HashOutput × SplitHashCache) → List Probe → + ProbComp BoundaryWitnessPlanOutput := + fun nextContext remaining value laterCandidates => + directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve parameter root + ftsSecret (next value.1) leftObserve laterCandidates nextContext remaining + table value.2 + let nextRightObserve : DeferredContext → Nat → + (HashOutput × SplitHashCache) → ProbComp DirectBoundaryOutcome := + fun nextContext remaining value => + rootAwareMaterializedDetailedBoundaryObserve parameter root ftsSecret + (next value.1) rightObserve nextContext remaining table value.2 + have hboundPositive : 0 < bound := by + rcases hbound.1 with hnot | hpositive + · exact (hnot (by simp)).elim + · exact hpositive + apply relTriple_finishBoundaryWitnessPlan_detailed_of_materializedStable table + · exact relTriple_runDirectResolvedWitness_afterPlan_rootAwarePublic table parameter + input left.state plan left right leftFuel rightFuel leftCache rightCache rfl + (by omega) (by omega) hcontext hcache hrevealed hvalues hpublished + hrightMaterialized + · intro nextLeft nextRight hleftSupport hrightSupport hclean + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hleftCompletable := hcanonicalRun.context_le.leftCompletable + have hleftNotPrivate := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hrightNotPrivate := + not_privateStructuralHit_of_deferredCompletable + hcanonicalRun.context_le.rightCompletable + simp only [canonicalizeDirectBoundaryWitnessPlanObserve, hleftNotPrivate, + ↓reduceDIte, hclean.left_published, ↓reduceIte, + classifyDirectBoundaryWitnessPlanObserve, hleftCompletable, + classifyDirectDetailedObserve, hrightNotPrivate, + hcanonicalRun.context_le.rightCompletable] + rw [← hclean.value_eq] + have hleftSpent : leftFuel ≤ nextLeft.remaining + 1 := + fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterPlan parameter input plan).run leftCache) + left leftFuel table nextLeft 1 + (probingHashQueryAfterPlan_isProbeBound_one parameter input plan leftCache) + hleftSupport + have hrightSpent : rightFuel ≤ nextRight.remaining + 1 := + fuel_le_remaining_add_of_done_runDirectResolvedDetailedFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input left.state plan).run + rightCache) + right rightFuel table nextRight 1 + (probingHashQueryAfterRootAwarePublicPlan_isProbeBound_one parameter input + left.state plan rightCache) + hrightSupport + have htail : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (next nextLeft.value.1)).IsQueryBoundP + (fun query => query matches Sum.inr _) (bound - 1) := by + simpa [IsOuterHash] using hbound.2 nextLeft.value.1 + exact ih nextLeft.value.1 nextCandidates canonical nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 + (bound - 1) htail hcanonicalRun.context_le hcanonicalRun.cache_eq + hcanonicalRun.revealed_eq hcanonicalRun.values_le + hcanonicalRun.left_published hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table nextLeft.context + hclean.context_le.view.leftConsistent) + (by omega) + ((remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((probingHashQueryAfterPlan parameter input plan).run leftCache) + left leftFuel table nextLeft (by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterPlan parameter input plan).run leftCache) + left leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩)).trans hleftUpper) + (by omega) + · intro leftRun nextRight _hrightSupport hdoomed + have hnotPrivate := not_privateStructuralHit_of_directDeferredContext + nextRight.context hdoomed.2 + have hnotCompletable : ¬DeferredCompletable table nextRight.context := + hdoomed.1.2.2.2 + simpa [classifyDirectDetailedObserve, hnotPrivate, hnotCompletable] using + (relTriple_any_ordinaryFailure_boundaryWitnessCovers leftRun) + | inr message => + rw [simulateQ_expandedAdversaryImpl_query_bind_inr] at hbound + simp only + let nextLeftObserve : DeferredContext → Nat → + (Option Signature × SplitHashCache) → List Probe → + ProbComp BoundaryWitnessPlanOutput := + fun nextContext remaining value nextCandidates => + directDetailedBoundaryNormalizedBoundaryWitnessPlanObserve parameter root ftsSecret + (next value.1) leftObserve nextCandidates nextContext remaining table value.2 + let nextRightObserve : DeferredContext → Nat → + (Option Signature × SplitHashCache) → ProbComp DirectBoundaryOutcome := + fun nextContext remaining value => + rootAwareMaterializedDetailedBoundaryObserve parameter root ftsSecret + (next value.1) rightObserve nextContext remaining table value.2 + apply relTriple_finishBoundaryWitnessPlan_detailed_of_materializedStable table + · exact (witnessMaterializedStableCouples_maskedSign table parameter root ftsSecret + message) left right leftFuel rightFuel leftCache rightCache hcontext (by omega) + hcache hrevealed hvalues hpublished hrightMaterialized + · intro nextLeft nextRight hleftSupport hrightSupport hclean + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hleftCompletable := hcanonicalRun.context_le.leftCompletable + have hleftNotPrivate := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hrightNotPrivate := + not_privateStructuralHit_of_deferredCompletable + hcanonicalRun.context_le.rightCompletable + simp only [canonicalizeDirectBoundaryWitnessPlanObserve, hleftNotPrivate, + ↓reduceDIte, hclean.left_published, ↓reduceIte, + classifyDirectBoundaryWitnessPlanObserve, hleftCompletable, + classifyDirectDetailedObserve, hrightNotPrivate, + hcanonicalRun.context_le.rightCompletable] + rw [← hclean.value_eq] + have hleftPreserved : leftFuel ≤ nextLeft.remaining := by + have := fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table nextLeft 0 + (maskedSign_probeFree parameter root ftsSecret message leftCache) + hleftSupport + omega + have hrightPreserved : rightFuel ≤ nextRight.remaining := by + have := fuel_le_remaining_add_of_done_runDirectResolvedDetailedFromTable + ((maskedSign parameter root ftsSecret message).run rightCache) + right rightFuel table nextRight 0 + (maskedSign_probeFree parameter root ftsSecret message rightCache) + hrightSupport + omega + have hdetailed : DirectDetailedResult.done nextLeft ∈ support + (runDirectResolvedDetailedFromTable left leftFuel table + ((maskedSign parameter root ftsSecret message).run leftCache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩ + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table nextLeft hdetailed + have hraw := raw_done_of_mem_runDirectResolvedFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table nextLeft hdirect + have houtput : nextLeft.value.1 ∈ support + (scheme.sign + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey) message) := + maskedSign_done_output_mem_support parameter root table ftsSecret message + left.state nextLeft.context.state leftCache nextLeft.value.2 leftFuel + nextLeft.remaining nextLeft.value.1 hclean.context_le.view.leftStarts (by + simpa only [SigningSpec, maskedExpandedAdversaryImpl, maskedSigningImpl] + using hraw) + have htail := isQueryBoundP_of_bind hbound nextLeft.value.1 houtput + exact ih nextLeft.value.1 candidates canonical nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 bound + (htail.mono (by omega)) hcanonicalRun.context_le hcanonicalRun.cache_eq + hcanonicalRun.revealed_eq hcanonicalRun.values_le + hcanonicalRun.left_published hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table nextLeft.context + hclean.context_le.view.leftConsistent) + (by omega) + ((remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table nextLeft hdetailed).trans hleftUpper) + (by omega) + · intro leftRun nextRight _hrightSupport hdoomed + have hnotPrivate := not_privateStructuralHit_of_directDeferredContext + nextRight.context hdoomed.2 + have hnotCompletable : ¬DeferredCompletable table nextRight.context := + hdoomed.1.2.2.2 + simpa [classifyDirectDetailedObserve, hnotPrivate, hnotCompletable] using + (relTriple_any_ordinaryFailure_boundaryWitnessCovers leftRun) + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_granularBoundaryWitnessPlan_rootAwareMaterializedDetailedRetainedRest + (adversary : Adversary) (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (left right : DeferredContext) (leftFuel rightFuel q : Nat) + (leftCache rightCache : SplitHashCache) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hcontext : FinalizationContextLE table left right) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hcanonical : CanonicalMaterializedValues table left) + (hqLeft : q ≤ leftFuel) (hleftUpper : leftFuel ≤ q) + (hrightLower : q + q ≤ rightFuel) : + RelTriple + (granularDetailedRetainedRestNormalizedBoundaryWitnessPlanObserve adversary parameter table + ftsSecret left leftFuel (root, leftCache) []) + (rootAwareMaterializedDetailedRetainedRestObserve adversary parameter table ftsSecret + right rightFuel (root, rightCache)) + BoundaryWitnessCovers := by + unfold granularDetailedRetainedRestNormalizedBoundaryWitnessPlanObserve + rootAwareMaterializedDetailedRetainedRestObserve + apply relTriple_normalizedBoundaryWitness_rootAwareMaterializedDetailed parameter root ftsSecret + (retainedGameRestComputation adversary ⟨root, parameter⟩) + (retainedResolvedFinalizationBoundaryWitnessPlanObserve table root) + (retainedResolvedFinalizationDetailedObserve table root) [] left right leftFuel rightFuel + table leftCache rightCache q q hbound hcontext hcache hrevealed hvalues hpublished + hrightMaterialized hcanonical hqLeft hleftUpper hrightLower + intro value nextLeft nextRight nextLeftFuel nextRightFuel nextLeftCache nextRightCache + nextCandidates hnextContext _hnextFuel _hnextCache _hnextRevealed _hnextValues + _hnextPublished _hnextMaterialized _hnextCanonical + simpa only using + (relTriple_retainedFinalizationBoundaryWitnessPlan_detailed table root value nextLeft nextRight + nextLeftFuel nextRightFuel nextLeftCache nextRightCache nextCandidates hnextContext) + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_granularAllCanonicalBoundaryWitnessPlan_rootAwareMaterializedBoundary + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + RelTriple + (granularAllCanonicalBoundaryWitnessPlan adversary parameter table ftsSecret q) + (rootAwareMaterializedBoundaryDetailedRetainedOutcome adversary parameter table ftsSecret q) + BoundaryWitnessCovers := by + let initial : DeferredContext := emptyWitnessDeferredContext + let materializedInitial : DeferredContext := + directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + have hcontext : FinalizationContextLE table initial materializedInitial := + finalizationContextLE_empty table + have hstep := (witnessMaterializedStableCouples_maskedPublishedTreeRoot table) + initial materializedInitial q (2 * q) emptySplitHashCache emptySplitHashCache hcontext + (by omega) rfl rfl (fun _ _ hvalue => hvalue) publishedValues_empty rfl + unfold granularAllCanonicalBoundaryWitnessPlan + rootAwareMaterializedBoundaryDetailedRetainedOutcome runDirectBoundaryWitnessPlanObserve + runDirectDetailedObserve + apply relTriple_finishBoundaryWitnessPlan_detailed_of_materializedStable table + · simpa [initial, materializedInitial] using hstep + · intro leftResult rightResult hleftSupport hrightSupport hclean + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table leftResult.context + have hleftCompletable := hcanonicalRun.context_le.leftCompletable + have hleftNotPrivate := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hrightNotPrivate := + not_privateStructuralHit_of_deferredCompletable + hcanonicalRun.context_le.rightCompletable + simp only [canonicalizeDirectBoundaryWitnessPlanObserve, hleftNotPrivate, ↓reduceDIte, + hclean.left_published, ↓reduceIte, classifyDirectBoundaryWitnessPlanObserve, + hleftCompletable, classifyDirectDetailedObserve, hrightNotPrivate, + hcanonicalRun.context_le.rightCompletable] + have hleftFuelPreserved : q ≤ leftResult.remaining := by + have := fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) initial q table leftResult 0 + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) (by + simpa [initial] using hleftSupport) + omega + have hrightFuelPreserved : 2 * q ≤ rightResult.remaining := by + have := fuel_le_remaining_add_of_done_runDirectResolvedDetailedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) materializedInitial (2 * q) table + rightResult 0 (maskedPublishedTreeRoot_probeFree emptySplitHashCache) (by + simpa [materializedInitial] using hrightSupport) + omega + have hleftRemainingUpper : leftResult.remaining ≤ q := + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) initial q table leftResult (by + rw [← map_erase_runDirectResolvedWitnessFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) initial q table, support_map] + exact ⟨.done leftResult, by simpa [initial] using hleftSupport, rfl⟩) + change RelTriple + (granularDetailedRetainedRestNormalizedBoundaryWitnessPlanObserve adversary parameter table + ftsSecret canonical leftResult.remaining + (leftResult.value.1, leftResult.value.2) []) + (rootAwareMaterializedDetailedRetainedRestObserve adversary parameter table ftsSecret + rightResult.context rightResult.remaining + (rightResult.value.1, rightResult.value.2)) + BoundaryWitnessCovers + rw [← hclean.value_eq] + exact relTriple_granularBoundaryWitnessPlan_rootAwareMaterializedDetailedRetainedRest + adversary parameter leftResult.value.1 table ftsSecret canonical rightResult.context + leftResult.remaining rightResult.remaining q leftResult.value.2 rightResult.value.2 + (hbound leftResult.value.1) hcanonicalRun.context_le hcanonicalRun.cache_eq + hcanonicalRun.revealed_eq hcanonicalRun.values_le hcanonicalRun.left_published + hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table leftResult.context + hclean.context_le.view.leftConsistent) + hleftFuelPreserved hleftRemainingUpper (by omega) + · intro leftRun rightResult _hrightSupport hdoomed + have hnotPrivate := not_privateStructuralHit_of_directDeferredContext + rightResult.context hdoomed.2 + have hnotCompletable : ¬DeferredCompletable table rightResult.context := + hdoomed.1.2.2.2 + simpa [classifyDirectDetailedObserve, hnotPrivate, hnotCompletable] using + (relTriple_any_ordinaryFailure_boundaryWitnessCovers leftRun) + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_sampledGranularAllCanonicalBoundaryWitnessPlan_rootAwareMaterializedBoundary + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + RelTriple + (sampledGranularAllCanonicalBoundaryWitnessPlan adversary parameter ftsSecret q) + (sampledRootAwareMaterializedBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret q) + BoundaryWitnessCovers := by + unfold sampledGranularAllCanonicalBoundaryWitnessPlan + sampledRootAwareMaterializedBoundaryDetailedRetainedOutcome + apply relTriple_bind (relTriple_refl sampleOtsHashTable) + intro leftTable rightTable htable + subst rightTable + exact relTriple_granularAllCanonicalBoundaryWitnessPlan_rootAwareMaterializedBoundary + adversary parameter leftTable ftsSecret q (hbound leftTable) + +set_option linter.constructorNameAsVariable false in +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_sampledCanonicalBoundary_failed_le_witness_add_materializedOrdinary + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + Pr[fun output => output.outcome.failed = true | + sampledGranularAllCanonicalBoundaryWitnessPlan adversary parameter ftsSecret q] ≤ + Pr[fun output => output.witnessPlan.1.isSome = true | + sampledGranularAllCanonicalBoundaryWitnessPlan adversary parameter ftsSecret q] + + Pr[fun outcome => outcome.ordinary = true | + sampledRootAwareMaterializedBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret q] := by + let sourceRun := + sampledGranularAllCanonicalBoundaryWitnessPlan adversary parameter ftsSecret q + let materializedRun := + sampledRootAwareMaterializedBoundaryDetailedRetainedOutcome adversary parameter ftsSecret q + have hrel : RelTriple sourceRun materializedRun BoundaryWitnessCovers := + relTriple_sampledGranularAllCanonicalBoundaryWitnessPlan_rootAwareMaterializedBoundary + adversary parameter ftsSecret q hbound + change Pr[fun output => output.outcome.failed = true | sourceRun] ≤ + Pr[fun output => output.witnessPlan.1.isSome = true | sourceRun] + + Pr[fun outcome => outcome.ordinary = true | materializedRun] + calc + _ ≤ Pr[fun output => output.witnessPlan.1.isSome = true ∨ + (output.outcome.failed = true ∧ output.witnessPlan.1.isSome ≠ true) | sourceRun] := by + apply probEvent_mono + intro output _houtput hfailed + by_cases hwitness : output.witnessPlan.1.isSome = true + · exact Or.inl hwitness + · exact Or.inr ⟨hfailed, hwitness⟩ + _ ≤ Pr[fun output => output.witnessPlan.1.isSome = true | sourceRun] + + Pr[fun output => output.outcome.failed = true ∧ + output.witnessPlan.1.isSome ≠ true | sourceRun] := + probEvent_or_le _ _ _ + _ ≤ _ := add_le_add le_rfl (by + apply probEvent_le_of_relTriple hrel + intro source materialized hrelation hsource + rcases hrelation hsource.1 with hwitness | hordinary + · exact (hsource.2 hwitness).elim + · exact hordinary) + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_witness_sampledGranularAllCanonicalBoundaryWitnessPlan_eq + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun output => output.witnessPlan.1.isSome = true | + sampledGranularAllCanonicalBoundaryWitnessPlan adversary parameter ftsSecret fuel] = + Pr[fun output => output.1.isSome = true | + sampledGranularAllCanonicalPrivateWitnessPlan adversary parameter ftsSecret fuel] := by + calc + _ = Pr[fun output => output.1.isSome = true | + BoundaryWitnessPlanOutput.witnessPlan <$> + sampledGranularAllCanonicalBoundaryWitnessPlan adversary parameter ftsSecret fuel] := by + rw [probEvent_map] + rfl + _ = _ := OracleComp.probEvent_congr' (fun _ _ ↦ Iff.rfl) + (evalDist_witnessPlan_sampledGranularAllCanonicalBoundaryWitnessPlan adversary parameter + ftsSecret fuel) + + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryWitnessEndpoint.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryWitnessEndpoint.lean new file mode 100644 index 00000000..d314998f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryWitnessEndpoint.lean @@ -0,0 +1,210 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryWitnessLift + +/-! +# Retained boundary witness endpoint + +The adaptive witness lift is specialized to the retained game after the public root. Finalization +cannot create a private structural failure from the related completable contexts, so any remaining +failure there is ordinary. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +noncomputable def rootAwareMaterializedDetailedRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp DirectBoundaryOutcome := + rootAwareMaterializedDetailedBoundaryObserve parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationDetailedObserve table value.1) + context fuel table value.2 + +set_option maxRecDepth 100000 in +theorem relTriple_privateWitnessPlan_retainedFinalization_detailed + (table : OtsSecretIndex → HashOutput) (root : Digest) + (value : RetainedRestResult) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (leftCache rightCache : SplitHashCache) (candidates : List Probe) + (hcontext : FinalizationContextLE table left right) : + RelTriple + (retainedResolvedFinalizationPrivateWitnessPlanObserve table root left leftFuel + (value, leftCache) candidates) + (retainedResolvedFinalizationDetailedObserve table root right rightFuel + (value, rightCache)) + WitnessOrOrdinaryCovers := by + have hleftNotPrivate := not_privateStructuralHit_of_deferredCompletable + hcontext.leftCompletable + have hrightNotPrivate := not_privateStructuralHit_of_deferredCompletable + hcontext.rightCompletable + unfold retainedResolvedFinalizationPrivateWitnessPlanObserve + retainedResolvedFinalizationDetailedObserve classifyDirectObserve + simp only [hleftNotPrivate, hrightNotPrivate, ↓reduceDIte, hcontext.rightCompletable, + ↓reduceIte] + have hbase : RelTriple + (pure (none, candidates) : ProbComp PrivateWitnessPlanOutput) + (DirectBoundaryOutcome.ofFailed <$> + resolvedFinalizationObserve table right rightFuel ((root, value), rightCache)) + (fun _ _ ↦ True) := relTriple_true _ _ + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hbase + apply relTriple_post_mono hsupported + intro source outcome hrelation + rcases hrelation with ⟨_, houtcome⟩ + rw [support_map] at houtcome + rcases houtcome with ⟨failed, _hfailed, rfl⟩ + cases failed <;> simp [WitnessOrOrdinaryCovers, DirectBoundaryOutcome.ofFailed, + DirectBoundaryOutcome.failed, DirectBoundaryOutcome.ordinary] + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_granularPrivateWitnessPlan_rootAwareMaterializedDetailedRetainedRest + (adversary : Adversary) (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (left right : DeferredContext) (leftFuel rightFuel q : Nat) + (leftCache rightCache : SplitHashCache) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hcontext : FinalizationContextLE table left right) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hcanonical : CanonicalMaterializedValues table left) + (hqLeft : q ≤ leftFuel) (hleftUpper : leftFuel ≤ q) + (hrightLower : q + q ≤ rightFuel) : + RelTriple + (granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret left leftFuel (root, leftCache) []) + (rootAwareMaterializedDetailedRetainedRestObserve adversary parameter table ftsSecret + right rightFuel (root, rightCache)) + WitnessOrOrdinaryCovers := by + unfold granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve + rootAwareMaterializedDetailedRetainedRestObserve + apply relTriple_normalizedPrivateWitness_rootAwareMaterializedDetailed parameter root ftsSecret + (retainedGameRestComputation adversary ⟨root, parameter⟩) + (retainedResolvedFinalizationPrivateWitnessPlanObserve table root) + (retainedResolvedFinalizationDetailedObserve table root) [] left right leftFuel rightFuel + table leftCache rightCache q q hbound hcontext hcache hrevealed hvalues hpublished + hrightMaterialized hcanonical hqLeft hleftUpper hrightLower + intro value nextLeft nextRight nextLeftFuel nextRightFuel nextLeftCache nextRightCache + nextCandidates hnextContext _hnextFuel _hnextCache _hnextRevealed _hnextValues + _hnextPublished _hnextMaterialized _hnextCanonical + simpa only using + (relTriple_privateWitnessPlan_retainedFinalization_detailed table root value nextLeft nextRight + nextLeftFuel nextRightFuel nextLeftCache nextRightCache nextCandidates hnextContext) + +noncomputable def rootAwareMaterializedBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp DirectBoundaryOutcome := + runDirectDetailedObserve + (fun context remaining value => + classifyDirectDetailedObserve table + (rootAwareMaterializedDetailedRetainedRestObserve adversary parameter table ftsSecret) + context remaining value) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + (2 * fuel) table (maskedPublishedTreeRoot.run emptySplitHashCache) + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_granularAllCanonicalPrivateWitnessPlan_rootAwareMaterializedBoundary + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) : + RelTriple + (granularAllCanonicalPrivateWitnessPlan adversary parameter table ftsSecret q) + (rootAwareMaterializedBoundaryDetailedRetainedOutcome adversary parameter table ftsSecret q) + WitnessOrOrdinaryCovers := by + let initial : DeferredContext := emptyWitnessDeferredContext + let materializedInitial : DeferredContext := + directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + have hcontext : FinalizationContextLE table initial materializedInitial := + finalizationContextLE_empty table + have hstep := (witnessMaterializedStableCouples_maskedPublishedTreeRoot table) + initial materializedInitial q (2 * q) emptySplitHashCache emptySplitHashCache hcontext + (by omega) rfl rfl (fun _ _ hvalue => hvalue) publishedValues_empty rfl + unfold granularAllCanonicalPrivateWitnessPlan + rootAwareMaterializedBoundaryDetailedRetainedOutcome runDirectWitnessPlanObserve + runDirectDetailedObserve + apply relTriple_finishDirectWitnessPlan_detailed_of_materializedStable table + · simpa [initial, materializedInitial] using hstep + · intro leftResult rightResult hleftSupport hrightSupport hclean + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table leftResult.context + have hleftCompletable := hcanonicalRun.context_le.leftCompletable + have hleftNotPrivate := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hrightNotPrivate := + not_privateStructuralHit_of_deferredCompletable + hcanonicalRun.context_le.rightCompletable + simp only [canonicalizeDirectWitnessPlanObserve, hleftNotPrivate, ↓reduceDIte, + hclean.left_published, ↓reduceIte, classifyDirectWitnessPlanObserve, + hleftCompletable, classifyDirectDetailedObserve, hrightNotPrivate, + hcanonicalRun.context_le.rightCompletable] + have hleftFuelPreserved : q ≤ leftResult.remaining := by + have := fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) initial q table leftResult 0 + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) (by + simpa [initial] using hleftSupport) + omega + have hrightFuelPreserved : 2 * q ≤ rightResult.remaining := by + have := fuel_le_remaining_add_of_done_runDirectResolvedDetailedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) materializedInitial (2 * q) table + rightResult 0 (maskedPublishedTreeRoot_probeFree emptySplitHashCache) (by + simpa [materializedInitial] using hrightSupport) + omega + have hleftRemainingUpper : leftResult.remaining ≤ q := + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) initial q table leftResult (by + rw [← map_erase_runDirectResolvedWitnessFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) initial q table, support_map] + exact ⟨.done leftResult, by simpa [initial] using hleftSupport, rfl⟩) + change RelTriple + (granularDetailedRetainedRestNormalizedPrivateWitnessPlanObserve adversary parameter table + ftsSecret canonical leftResult.remaining + (leftResult.value.1, leftResult.value.2) []) + (rootAwareMaterializedDetailedRetainedRestObserve adversary parameter table ftsSecret + rightResult.context rightResult.remaining + (rightResult.value.1, rightResult.value.2)) + WitnessOrOrdinaryCovers + rw [← hclean.value_eq] + exact relTriple_granularPrivateWitnessPlan_rootAwareMaterializedDetailedRetainedRest + adversary parameter leftResult.value.1 table ftsSecret canonical rightResult.context + leftResult.remaining rightResult.remaining q leftResult.value.2 rightResult.value.2 + (hbound leftResult.value.1) hcanonicalRun.context_le hcanonicalRun.cache_eq + hcanonicalRun.revealed_eq hcanonicalRun.values_le hcanonicalRun.left_published + hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table leftResult.context + hclean.context_le.view.leftConsistent) + hleftFuelPreserved hleftRemainingUpper (by omega) + · intro leftRun rightResult _hrightSupport hdoomed + have hnotPrivate := not_privateStructuralHit_of_directDeferredContext + rightResult.context hdoomed.2 + have hnotCompletable : ¬DeferredCompletable table rightResult.context := + hdoomed.1.2.2.2 + simpa [classifyDirectDetailedObserve, hnotPrivate, hnotCompletable] using + (relTriple_any_ordinaryFailure_witnessOrOrdinaryCovers leftRun) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryWitnessLift.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryWitnessLift.lean new file mode 100644 index 00000000..89364a5f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryWitnessLift.lean @@ -0,0 +1,394 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryWitnessCoverage + +/-! +# Adaptive boundary witness lift + +The canonical witness interpreter is coupled to the root-aware materialized interpreter. A +detailed failure on the materialized side is retained either as the first private witness or as +an ordinary failure. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +noncomputable def rootAwareMaterializedDetailedBoundaryObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → + ProbComp DirectBoundaryOutcome) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ProbComp DirectBoundaryOutcome := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + (DeferredContext → Nat → (α × SplitHashCache) → ProbComp DirectBoundaryOutcome) → + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp DirectBoundaryOutcome) + (fun value observe context fuel _table cache => observe context fuel (value, cache)) + (fun query _next recursivelyRun observe context fuel table cache => + match query with + | .inl (.inl n) => + runDirectDetailedObserve + (fun nextContext remaining value => + classifyDirectDetailedObserve table + (fun finalContext finalRemaining finalValue => + recursivelyRun finalValue.1 observe finalContext finalRemaining table + finalValue.2) + nextContext remaining value) + context fuel table ((splitUniformImpl n).run cache) + | .inl (.inr input) => + let publicContext := materializedCanonicalContext table context.state + let plan := purePlanProbingHashQuery parameter input publicContext.state + runDirectDetailedObserve + (fun nextContext remaining value => + classifyDirectDetailedObserve table + (fun finalContext finalRemaining finalValue => + recursivelyRun finalValue.1 observe finalContext finalRemaining table + finalValue.2) + nextContext remaining value) + context fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state plan).run + cache) + | .inr message => + runDirectDetailedObserve + (fun nextContext remaining value => + classifyDirectDetailedObserve table + (fun finalContext finalRemaining finalValue => + recursivelyRun finalValue.1 observe finalContext finalRemaining table + finalValue.2) + nextContext remaining value) + context fuel table + ((maskedSign parameter root ftsSecret message).run cache)) + computation observe context fuel table cache + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_normalizedPrivateWitness_rootAwareMaterializedDetailed + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (leftObserve : DeferredContext → Nat → (α × SplitHashCache) → List Probe → + ProbComp PrivateWitnessPlanOutput) + (rightObserve : DeferredContext → Nat → (α × SplitHashCache) → + ProbComp DirectBoundaryOutcome) + (candidates : List Probe) + (left right : DeferredContext) (leftFuel rightFuel : Nat) + (table : OtsSecretIndex → HashOutput) + (leftCache rightCache : SplitHashCache) (q bound : Nat) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + computation).IsQueryBoundP (fun query => query matches Sum.inr _) bound) + (hcontext : FinalizationContextLE table left right) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) + (hvalues : LazyRevealProbe.ValuesLE left.state right.state) + (hpublished : PublishedValues left.state) + (hrightMaterialized : right = directDeferredContext right.state) + (hcanonical : CanonicalMaterializedValues table left) + (hleftLower : bound ≤ leftFuel) (hleftUpper : leftFuel ≤ q) + (hrightLower : q + bound ≤ rightFuel) + (hterminal : ∀ value nextLeft nextRight nextLeftFuel nextRightFuel + nextLeftCache nextRightCache nextCandidates, + FinalizationContextLE table nextLeft nextRight → + nextLeftFuel ≤ nextRightFuel → + ordinaryQueryCache nextLeftCache = ordinaryQueryCache nextRightCache → + nextLeft.state.revealed = nextRight.state.revealed → + LazyRevealProbe.ValuesLE nextLeft.state nextRight.state → + PublishedValues nextLeft.state → + nextRight = directDeferredContext nextRight.state → + CanonicalMaterializedValues table nextLeft → + RelTriple + (leftObserve nextLeft nextLeftFuel (value, nextLeftCache) nextCandidates) + (rightObserve nextRight nextRightFuel (value, nextRightCache)) + WitnessOrOrdinaryCovers) : + RelTriple + (directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + computation leftObserve candidates left leftFuel table leftCache) + (rootAwareMaterializedDetailedBoundaryObserve parameter root ftsSecret computation + rightObserve right rightFuel table rightCache) + WitnessOrOrdinaryCovers := by + induction computation using OracleComp.inductionOn generalizing + candidates left right leftFuel rightFuel leftCache rightCache bound with + | pure value => + simp only [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + rootAwareMaterializedDetailedBoundaryObserve, OracleComp.construct_pure] + exact hterminal value left right leftFuel rightFuel leftCache rightCache candidates + hcontext (by omega) hcache hrevealed hvalues hpublished hrightMaterialized hcanonical + | query_bind query next ih => + rw [directDetailedBoundaryNormalizedPrivateWitnessPlanObserve, + OracleComp.construct_query_bind, rootAwareMaterializedDetailedBoundaryObserve, + OracleComp.construct_query_bind] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + simp only + let nextLeftObserve : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → List Probe → + ProbComp PrivateWitnessPlanOutput := + fun nextContext remaining value nextCandidates => + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root + ftsSecret (next value.1) leftObserve nextCandidates nextContext remaining + table value.2 + let nextRightObserve : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → ProbComp DirectBoundaryOutcome := + fun nextContext remaining value => + rootAwareMaterializedDetailedBoundaryObserve parameter root ftsSecret + (next value.1) rightObserve nextContext remaining table value.2 + apply relTriple_finishDirectWitnessPlan_detailed_of_materializedStable table + · exact (witnessMaterializedStableCouples_splitUniformImpl table n) + left right leftFuel rightFuel leftCache rightCache hcontext (by omega) hcache + hrevealed hvalues hpublished hrightMaterialized + · intro nextLeft nextRight hleftSupport hrightSupport hclean + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hleftCompletable := hcanonicalRun.context_le.leftCompletable + have hleftNotPrivate := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hrightNotPrivate := + not_privateStructuralHit_of_deferredCompletable + hcanonicalRun.context_le.rightCompletable + simp only [canonicalizeDirectWitnessPlanObserve, hleftNotPrivate, + ↓reduceDIte, hclean.left_published, ↓reduceIte, + classifyDirectWitnessPlanObserve, hleftCompletable, + classifyDirectDetailedObserve, hrightNotPrivate, + hcanonicalRun.context_le.rightCompletable] + rw [← hclean.value_eq] + have hleftFuelPreserved : leftFuel ≤ nextLeft.remaining := by + have := fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table nextLeft 0 + (splitUniformImpl_probeFree n leftCache) hleftSupport + omega + have hrightFuelPreserved : rightFuel ≤ nextRight.remaining := by + have := fuel_le_remaining_add_of_done_runDirectResolvedDetailedFromTable + ((splitUniformImpl n).run rightCache) right rightFuel table nextRight 0 + (splitUniformImpl_probeFree n rightCache) hrightSupport + omega + have hleftRemainingUpper : nextLeft.remaining ≤ leftFuel := + remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table nextLeft (by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((splitUniformImpl n).run leftCache) left leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩) + exact ih nextLeft.value.1 candidates canonical nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 bound + (hbound.2 nextLeft.value.1) hcanonicalRun.context_le hcanonicalRun.cache_eq + hcanonicalRun.revealed_eq hcanonicalRun.values_le + hcanonicalRun.left_published hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table nextLeft.context + hclean.context_le.view.leftConsistent) + (by omega) (by omega) (by omega) + · intro leftRun nextRight _hrightSupport hdoomed + have hnotPrivate := not_privateStructuralHit_of_directDeferredContext + nextRight.context hdoomed.2 + have hnotCompletable : ¬DeferredCompletable table nextRight.context := + hdoomed.1.2.2.2 + simpa [classifyDirectDetailedObserve, hnotPrivate, hnotCompletable] using + (relTriple_any_ordinaryFailure_witnessOrOrdinaryCovers leftRun) + | inr input => + rw [simulateQ_expandedAdversaryImpl_query_bind_inl, + OracleComp.isQueryBoundP_query_bind_iff] at hbound + simp only + have hrightValues : + (materializedCanonicalContext table right.state).state.values = + left.state.values := by + unfold materializedCanonicalContext + rw [← hrightMaterialized] + exact canonicalized_right_values_eq_of_finalizationContextLE hcontext + hrevealed hcanonical + have hplanEq : + purePlanProbingHashQuery parameter input + (materializedCanonicalContext table right.state).state = + purePlanProbingHashQuery parameter input left.state := + purePlanProbingHashQuery_eq_of_values_eq hrightValues parameter input + rw [hplanEq] + let plan := purePlanProbingHashQuery parameter input left.state + have hpublicExecutor : + probingHashQueryAfterRootAwarePublicPlan parameter input + (materializedCanonicalContext table right.state).state plan = + probingHashQueryAfterRootAwarePublicPlan parameter input left.state plan := + probingHashQueryAfterRootAwarePublicPlan_eq_of_values_eq parameter input + hrightValues plan + rw [hpublicExecutor] + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input left.state) + let nextLeftObserve : DeferredContext → Nat → + (HashOutput × SplitHashCache) → List Probe → + ProbComp PrivateWitnessPlanOutput := + fun nextContext remaining value laterCandidates => + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root + ftsSecret (next value.1) leftObserve laterCandidates nextContext remaining + table value.2 + let nextRightObserve : DeferredContext → Nat → + (HashOutput × SplitHashCache) → ProbComp DirectBoundaryOutcome := + fun nextContext remaining value => + rootAwareMaterializedDetailedBoundaryObserve parameter root ftsSecret + (next value.1) rightObserve nextContext remaining table value.2 + have hboundPositive : 0 < bound := by + rcases hbound.1 with hnot | hpositive + · exact (hnot (by simp)).elim + · exact hpositive + apply relTriple_finishDirectWitnessPlan_detailed_of_materializedStable table + · exact relTriple_runDirectResolvedWitness_afterPlan_rootAwarePublic table parameter + input left.state plan left right leftFuel rightFuel leftCache rightCache rfl + (by omega) (by omega) hcontext hcache hrevealed hvalues hpublished + hrightMaterialized + · intro nextLeft nextRight hleftSupport hrightSupport hclean + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hleftCompletable := hcanonicalRun.context_le.leftCompletable + have hleftNotPrivate := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hrightNotPrivate := + not_privateStructuralHit_of_deferredCompletable + hcanonicalRun.context_le.rightCompletable + simp only [canonicalizeDirectWitnessPlanObserve, hleftNotPrivate, + ↓reduceDIte, hclean.left_published, ↓reduceIte, + classifyDirectWitnessPlanObserve, hleftCompletable, + classifyDirectDetailedObserve, hrightNotPrivate, + hcanonicalRun.context_le.rightCompletable] + rw [← hclean.value_eq] + have hleftSpent : leftFuel ≤ nextLeft.remaining + 1 := + fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterPlan parameter input plan).run leftCache) + left leftFuel table nextLeft 1 + (probingHashQueryAfterPlan_isProbeBound_one parameter input plan leftCache) + hleftSupport + have hrightSpent : rightFuel ≤ nextRight.remaining + 1 := + fuel_le_remaining_add_of_done_runDirectResolvedDetailedFromTable + ((probingHashQueryAfterRootAwarePublicPlan parameter input left.state plan).run + rightCache) + right rightFuel table nextRight 1 + (probingHashQueryAfterRootAwarePublicPlan_isProbeBound_one parameter input + left.state plan rightCache) + hrightSupport + have htail : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (next nextLeft.value.1)).IsQueryBoundP + (fun query => query matches Sum.inr _) (bound - 1) := by + simpa [IsOuterHash] using hbound.2 nextLeft.value.1 + exact ih nextLeft.value.1 nextCandidates canonical nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 + (bound - 1) htail hcanonicalRun.context_le hcanonicalRun.cache_eq + hcanonicalRun.revealed_eq hcanonicalRun.values_le + hcanonicalRun.left_published hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table nextLeft.context + hclean.context_le.view.leftConsistent) + (by omega) + ((remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((probingHashQueryAfterPlan parameter input plan).run leftCache) + left leftFuel table nextLeft (by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterPlan parameter input plan).run leftCache) + left leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩)).trans hleftUpper) + (by omega) + · intro leftRun nextRight _hrightSupport hdoomed + have hnotPrivate := not_privateStructuralHit_of_directDeferredContext + nextRight.context hdoomed.2 + have hnotCompletable : ¬DeferredCompletable table nextRight.context := + hdoomed.1.2.2.2 + simpa [classifyDirectDetailedObserve, hnotPrivate, hnotCompletable] using + (relTriple_any_ordinaryFailure_witnessOrOrdinaryCovers leftRun) + | inr message => + rw [simulateQ_expandedAdversaryImpl_query_bind_inr] at hbound + simp only + let nextLeftObserve : DeferredContext → Nat → + (Option Signature × SplitHashCache) → List Probe → + ProbComp PrivateWitnessPlanOutput := + fun nextContext remaining value nextCandidates => + directDetailedBoundaryNormalizedPrivateWitnessPlanObserve parameter root ftsSecret + (next value.1) leftObserve nextCandidates nextContext remaining table value.2 + let nextRightObserve : DeferredContext → Nat → + (Option Signature × SplitHashCache) → ProbComp DirectBoundaryOutcome := + fun nextContext remaining value => + rootAwareMaterializedDetailedBoundaryObserve parameter root ftsSecret + (next value.1) rightObserve nextContext remaining table value.2 + apply relTriple_finishDirectWitnessPlan_detailed_of_materializedStable table + · exact (witnessMaterializedStableCouples_maskedSign table parameter root ftsSecret + message) left right leftFuel rightFuel leftCache rightCache hcontext (by omega) + hcache hrevealed hvalues hpublished hrightMaterialized + · intro nextLeft nextRight hleftSupport hrightSupport hclean + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hleftCompletable := hcanonicalRun.context_le.leftCompletable + have hleftNotPrivate := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hrightNotPrivate := + not_privateStructuralHit_of_deferredCompletable + hcanonicalRun.context_le.rightCompletable + simp only [canonicalizeDirectWitnessPlanObserve, hleftNotPrivate, + ↓reduceDIte, hclean.left_published, ↓reduceIte, + classifyDirectWitnessPlanObserve, hleftCompletable, + classifyDirectDetailedObserve, hrightNotPrivate, + hcanonicalRun.context_le.rightCompletable] + rw [← hclean.value_eq] + have hleftPreserved : leftFuel ≤ nextLeft.remaining := by + have := fuel_le_remaining_add_of_done_runDirectResolvedWitnessFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table nextLeft 0 + (maskedSign_probeFree parameter root ftsSecret message leftCache) + hleftSupport + omega + have hrightPreserved : rightFuel ≤ nextRight.remaining := by + have := fuel_le_remaining_add_of_done_runDirectResolvedDetailedFromTable + ((maskedSign parameter root ftsSecret message).run rightCache) + right rightFuel table nextRight 0 + (maskedSign_probeFree parameter root ftsSecret message rightCache) + hrightSupport + omega + have hdetailed : DirectDetailedResult.done nextLeft ∈ support + (runDirectResolvedDetailedFromTable left leftFuel table + ((maskedSign parameter root ftsSecret message).run leftCache)) := by + rw [← map_erase_runDirectResolvedWitnessFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table, support_map] + exact ⟨.done nextLeft, hleftSupport, rfl⟩ + have hdirect := mem_support_runDirectResolvedFromTable_of_done_detailed + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table nextLeft hdetailed + have hraw := raw_done_of_mem_runDirectResolvedFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table nextLeft hdirect + have houtput : nextLeft.value.1 ∈ support + (scheme.sign + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey) message) := + maskedSign_done_output_mem_support parameter root table ftsSecret message + left.state nextLeft.context.state leftCache nextLeft.value.2 leftFuel + nextLeft.remaining nextLeft.value.1 hclean.context_le.view.leftStarts (by + simpa only [SigningSpec, maskedExpandedAdversaryImpl, maskedSigningImpl] + using hraw) + have htail := isQueryBoundP_of_bind hbound nextLeft.value.1 houtput + exact ih nextLeft.value.1 candidates canonical nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 bound + (htail.mono (by omega)) hcanonicalRun.context_le hcanonicalRun.cache_eq + hcanonicalRun.revealed_eq hcanonicalRun.values_le + hcanonicalRun.left_published hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table nextLeft.context + hclean.context_le.view.leftConsistent) + (by omega) + ((remaining_le_fuel_of_done_runDirectResolvedDetailedFromTable + ((maskedSign parameter root ftsSecret message).run leftCache) + left leftFuel table nextLeft hdetailed).trans hleftUpper) + (by omega) + · intro leftRun nextRight _hrightSupport hdoomed + have hnotPrivate := not_privateStructuralHit_of_directDeferredContext + nextRight.context hdoomed.2 + have hnotCompletable : ¬DeferredCompletable table nextRight.context := + hdoomed.1.2.2.2 + simpa [classifyDirectDetailedObserve, hnotPrivate, hnotCompletable] using + (relTriple_any_ordinaryFailure_witnessOrOrdinaryCovers leftRun) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryWitnessOrdinary.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryWitnessOrdinary.lean new file mode 100644 index 00000000..b9096014 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryWitnessOrdinary.lean @@ -0,0 +1,211 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryWitnessDomination + +/-! +# Root-aware materialized ordinary projection + +The detailed materialized comparison is projected exactly to the Boolean ordinary-failure +observer used by its remaining probability bound. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +noncomputable def rootAwareMaterializedDetailedBoundaryOrdinaryObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : ProbComp Bool := by + classical + exact OracleComp.construct + (C := fun _ : OracleComp (OracleWorld + SigningSpec) α => + (DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) → + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → SplitHashCache → + ProbComp Bool) + (fun value observe context fuel _table cache => observe context fuel (value, cache)) + (fun query _next recursivelyRun observe context fuel table cache => + match query with + | .inl (.inl n) => + runDirectDetailedOrdinaryObserve + (classifyDirectDetailedOrdinaryObserve table + (fun nextContext remaining value => + recursivelyRun value.1 observe nextContext remaining table value.2)) + context fuel table ((splitUniformImpl n).run cache) + | .inl (.inr input) => + let publicContext := materializedCanonicalContext table context.state + let plan := purePlanProbingHashQuery parameter input publicContext.state + runDirectDetailedOrdinaryObserve + (classifyDirectDetailedOrdinaryObserve table + (fun nextContext remaining value => + recursivelyRun value.1 observe nextContext remaining table value.2)) + context fuel table + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicContext.state plan).run + cache) + | .inr message => + runDirectDetailedOrdinaryObserve + (classifyDirectDetailedOrdinaryObserve table + (fun nextContext remaining value => + recursivelyRun value.1 observe nextContext remaining table value.2)) + context fuel table ((maskedSign parameter root ftsSecret message).run cache)) + computation observe context fuel table cache + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 1000000 in +theorem evalDist_ordinary_rootAwareMaterializedDetailedBoundaryObserve + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (detailedObserve : DeferredContext → Nat → (α × SplitHashCache) → + ProbComp DirectBoundaryOutcome) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hproject : ∀ nextContext remaining value, + evalDist (DirectBoundaryOutcome.ordinary <$> + detailedObserve nextContext remaining value) = + evalDist (observe nextContext remaining value)) : + evalDist (DirectBoundaryOutcome.ordinary <$> + rootAwareMaterializedDetailedBoundaryObserve parameter root ftsSecret computation + detailedObserve context fuel table cache) = + evalDist (rootAwareMaterializedDetailedBoundaryOrdinaryObserve parameter root ftsSecret + computation observe context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + rw [rootAwareMaterializedDetailedBoundaryObserve, OracleComp.construct_pure, + rootAwareMaterializedDetailedBoundaryOrdinaryObserve, OracleComp.construct_pure] + exact hproject context fuel (value, cache) + | query_bind query next ih => + rw [rootAwareMaterializedDetailedBoundaryObserve, OracleComp.construct_query_bind, + rootAwareMaterializedDetailedBoundaryOrdinaryObserve, OracleComp.construct_query_bind] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + apply evalDist_ordinary_runDirectDetailedObserve + intro result _hresult + apply evalDist_ordinary_classifyDirectDetailedObserve + exact ih result.value.1 result.context result.remaining result.value.2 + | inr input => + apply evalDist_ordinary_runDirectDetailedObserve + intro result _hresult + apply evalDist_ordinary_classifyDirectDetailedObserve + exact ih result.value.1 result.context result.remaining result.value.2 + | inr message => + apply evalDist_ordinary_runDirectDetailedObserve + intro result _hresult + apply evalDist_ordinary_classifyDirectDetailedObserve + exact ih result.value.1 result.context result.remaining result.value.2 + +noncomputable def rootAwareMaterializedDetailedRetainedRestOrdinaryObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : ProbComp Bool := + rootAwareMaterializedDetailedBoundaryOrdinaryObserve parameter value.1 ftsSecret + (retainedGameRestComputation adversary ⟨value.1, parameter⟩) + (retainedResolvedFinalizationOrdinaryObserve table value.1) + context fuel table value.2 + +set_option maxRecDepth 100000 in +theorem evalDist_ordinary_rootAwareMaterializedDetailedRetainedRestObserve + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : Digest × SplitHashCache) : + evalDist (DirectBoundaryOutcome.ordinary <$> + rootAwareMaterializedDetailedRetainedRestObserve adversary parameter table ftsSecret + context fuel value) = + evalDist (rootAwareMaterializedDetailedRetainedRestOrdinaryObserve adversary parameter table + ftsSecret context fuel value) := by + unfold rootAwareMaterializedDetailedRetainedRestObserve + rootAwareMaterializedDetailedRetainedRestOrdinaryObserve + apply evalDist_ordinary_rootAwareMaterializedDetailedBoundaryObserve + intro nextContext remaining nextValue + unfold retainedResolvedFinalizationDetailedObserve + retainedResolvedFinalizationOrdinaryObserve + exact evalDist_ordinary_classifyDirectObserve table (resolvedFinalizationObserve table) + nextContext remaining ((value.1, nextValue.1), nextValue.2) + +noncomputable def rootAwareMaterializedBoundaryDetailedRetainedOrdinary + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := + runDirectDetailedOrdinaryObserve + (classifyDirectDetailedOrdinaryObserve table + (rootAwareMaterializedDetailedRetainedRestOrdinaryObserve adversary parameter table + ftsSecret)) + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + (2 * fuel) table (maskedPublishedTreeRoot.run emptySplitHashCache) + +attribute [local irreducible] maskedPublishedTreeRoot in +set_option maxRecDepth 100000 in +theorem evalDist_ordinary_rootAwareMaterializedBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.ordinary <$> + rootAwareMaterializedBoundaryDetailedRetainedOutcome adversary parameter table + ftsSecret fuel) = + evalDist (rootAwareMaterializedBoundaryDetailedRetainedOrdinary adversary parameter table + ftsSecret fuel) := by + unfold rootAwareMaterializedBoundaryDetailedRetainedOutcome + rootAwareMaterializedBoundaryDetailedRetainedOrdinary + apply evalDist_ordinary_runDirectDetailedObserve + intro result _hresult + apply evalDist_ordinary_classifyDirectDetailedObserve + exact evalDist_ordinary_rootAwareMaterializedDetailedRetainedRestObserve adversary parameter + table ftsSecret result.context result.remaining result.value + +noncomputable def sampledRootAwareMaterializedBoundaryDetailedRetainedOrdinary + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + ProbComp Bool := do + let table ← sampleOtsHashTable + rootAwareMaterializedBoundaryDetailedRetainedOrdinary adversary parameter table ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem evalDist_ordinary_sampledRootAwareMaterializedBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + evalDist (DirectBoundaryOutcome.ordinary <$> + sampledRootAwareMaterializedBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret fuel) = + evalDist (sampledRootAwareMaterializedBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret fuel) := by + unfold sampledRootAwareMaterializedBoundaryDetailedRetainedOutcome + sampledRootAwareMaterializedBoundaryDetailedRetainedOrdinary + rw [map_bind] + apply evalDist_bind_congr + intro table _htable + exact evalDist_ordinary_rootAwareMaterializedBoundaryDetailedRetainedOutcome adversary + parameter table ftsSecret fuel + +set_option linter.constructorNameAsVariable false in +set_option maxRecDepth 100000 in +theorem probEvent_ordinary_sampledRootAwareMaterializedBoundaryDetailedRetainedOutcome + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun outcome => outcome.ordinary = true | + sampledRootAwareMaterializedBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret fuel] = + Pr[= true | + sampledRootAwareMaterializedBoundaryDetailedRetainedOrdinary adversary parameter + ftsSecret fuel] := by + calc + _ = Pr[= true | DirectBoundaryOutcome.ordinary <$> + sampledRootAwareMaterializedBoundaryDetailedRetainedOutcome adversary parameter + ftsSecret fuel] := by + rw [← probEvent_eq_eq_probOutput, probEvent_map] + rfl + _ = _ := OracleComp.probOutput_congr rfl + (evalDist_ordinary_sampledRootAwareMaterializedBoundaryDetailedRetainedOutcome adversary + parameter ftsSecret fuel) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedCleanTerminal.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedCleanTerminal.lean new file mode 100644 index 00000000..6bbded57 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedCleanTerminal.lean @@ -0,0 +1,56 @@ +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveEndpoint + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +def cleanDeferredContext (state : LazyRevealProbe.State Coordinate) : DeferredContext := + { state := state, values := emptyDeferredStructuralValues } + +noncomputable def finishCleanRunIsNone : + Option (CleanRunResult α) → ProbComp Bool := fun result => + Option.isNone <$> finishCleanRunFromTable result + +set_option maxRecDepth 100000 in +theorem evalDist_finishResolvedRunIsNone_eq_finishCleanRunIsNone + (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (state : LazyRevealProbe.State Coordinate) + (fuel : Nat) (value : α) + (hcontext : FinalizationContextEq table (some context) + (some (cleanDeferredContext state))) : + evalDist (finishResolvedRunIsNone + (some (ResolvedRunResult.mk context fuel value table))) = + evalDist (finishCleanRunIsNone + (some (CleanRunResult.mk state fuel value table))) := by + have hcleanCompletable : DeferredCompletable table (cleanDeferredContext state) := by + rcases hcontext.2.2.2 with ⟨completion, hcompletion⟩ + exact ⟨completion, (hcontext.1.deferredCompletion_iff completion).mp hcompletion⟩ + have hprojection := finishResolvedRun_empty_projects_to_clean state fuel value table + (by simpa [cleanDeferredContext] using hcleanCompletable) + change projectResolvedRunResult <$> + finishResolvedRun + (some (ResolvedRunResult.mk (cleanDeferredContext state) fuel value table)) = + finishCleanRunFromTable + (some (CleanRunResult.mk state fuel value table)) at hprojection + calc + _ = evalDist (finishResolvedRunIsNone + (some (ResolvedRunResult.mk (cleanDeferredContext state) fuel value table))) := + evalDist_finishResolvedRunIsNone_eq_of_finalizationContextEq table context + (cleanDeferredContext state) fuel value hcontext + _ = evalDist (Option.isNone <$> + (projectResolvedRunResult <$> + finishResolvedRun + (some (ResolvedRunResult.mk (cleanDeferredContext state) fuel value table)))) := by + unfold finishResolvedRunIsNone + apply congrArg evalDist + rw [Functor.map_map] + congr 1 + funext result + cases result <;> rfl + _ = evalDist (Option.isNone <$> + finishCleanRunFromTable + (some (CleanRunResult.mk state fuel value table))) := by + rw [hprojection] + _ = _ := rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedComputed.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedComputed.lean new file mode 100644 index 00000000..ef867866 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedComputed.lean @@ -0,0 +1,112 @@ +import SphincsSecurity.Proof.OtsProbeRootCacheTransport + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +inductive DeferredPositionComputed (context : DeferredContext) : Position → Prop where + | intro (position : Position) (hots : IsOtsPosition position) (hvalid : position.Valid) + (hknown : ∃ output, context.positionValue position = some output) + (hchildren : ∀ child ∈ position.children, DeferredPositionComputed context child) : + DeferredPositionComputed context position + +theorem DeferredPositionComputed.mono + {before after : DeferredContext} {position : Position} + (hcomputed : DeferredPositionComputed before position) + (hvalues : ∀ position output, before.positionValue position = some output → + after.positionValue position = some output) : + DeferredPositionComputed after position := by + induction hcomputed with + | intro position hots hvalid hknown hchildren ih => + obtain ⟨output, houtput⟩ := hknown + exact .intro position hots hvalid ⟨output, hvalues position output houtput⟩ ih + +theorem DeferredPositionComputed.of_positionValue_eq + {before after : DeferredContext} {position : Position} + (hcomputed : DeferredPositionComputed before position) + (hvalues : ∀ position, after.positionValue position = before.positionValue position) : + DeferredPositionComputed after position := + hcomputed.mono (fun position _ hvalue => (hvalues position).trans hvalue) + +theorem honestInput_eq_tableInput_of_children + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (completion : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (position : Position) (hots : IsOtsPosition position) (hvalid : position.Valid) + (hchildren : ∀ child ∈ position.children, + honestValue f parameter (tableOtsSecret completion) ftsSecret child = tableValue completion child) : + honestInput f parameter (tableOtsSecret completion) ftsSecret position = + tableInput parameter completion (.position position) := by + have hmap : childValues f parameter (tableOtsSecret completion) ftsSecret position = + position.children.map (tableValue completion) := List.map_congr_left hchildren + unfold honestInput + rw [honestPayload_eq_slots f parameter (tableOtsSecret completion) ftsSecret hvalid] + cases position with + | chain lay tree leafIdx chainIdx step => + simp only [tableInput, slots, tablePayload] + split_ifs <;> simp_all [tableOtsSecret] + | leaf lay tree leafIdx => + simpa only [slots, tableInput, tablePayload] using congrArg + (fun values : List Digest => tweakableHashInput parameter + (Position.leaf lay tree leafIdx).domain (values.flatMap digestBytes)) hmap + | node lay tree level nodeIdx => + simpa only [slots, tableInput, tablePayload] using congrArg + (fun values : List Digest => tweakableHashInput parameter + (Position.node lay tree level nodeIdx).domain (values.flatMap digestBytes)) hmap + | ftsLeaf | ftsNode | ftsRoots => contradiction + +set_option maxRecDepth 100000 in +theorem DeferredPositionComputed.settled_value + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {cache : QueryCache HashSpec} + (hcache : ChronologicalCacheAgrees parameter table context cache) + (completion : Coordinate → HashOutput) (hcompletion : DeferredCompletion table context completion) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + {position : Position} (hcomputed : DeferredPositionComputed context position) : + Settled parameter (tableOtsSecret completion) ftsSecret cache position ∧ + honestValue (fromCache cache) parameter (tableOtsSecret completion) ftsSecret position = + tableValue completion position := by + induction hcomputed with + | intro position hots hvalid hknown hchildren ih => + obtain ⟨output, houtput⟩ := hknown + have hinput := honestInput_eq_tableInput_of_children (fromCache cache) parameter completion + ftsSecret position hots hvalid (fun child hchild => (ih child hchild).2) + have hquery := hcache completion hcompletion position hots + simp only [ResolveInputAgrees, houtput] at hquery + have hanswer : fromCache cache (tableInput parameter completion (.position position)) = output := by + simp [fromCache, hquery] + constructor + · rw [settled_iff] + refine ⟨hvalid, ?_, fun child hchild => (ih child hchild).1⟩ + change cache (honestInput (fromCache cache) parameter (tableOtsSecret completion) ftsSecret position) ≠ none + rw [hinput, hquery] + simp + · rw [honestValue, hinput, hanswer, tableValue, hcompletion.eq_positionValue position output houtput] + +theorem DeferredPositionComputed.canonicalize + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} {position : Position} + (hcomputed : DeferredPositionComputed context position) (hconsistent : context.ValuesConsistent) : + DeferredPositionComputed (canonicalizeMaterializedValues table context) position := + hcomputed.of_positionValue_eq (canonicalizeMaterializedValues_positionValue table context hconsistent) + +set_option maxRecDepth 100000 in +theorem DeferredPositionComputed.refinedReserve_of_encoding_candidate + {secretKey : SecretKey} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {cache : QueryCache HashSpec} + (hcache : ChronologicalCacheAgrees secretKey.parameter table context cache) + (completion : Coordinate → HashOutput) (hcompletion : DeferredCompletion table context completion) + (hsecrets : secretKey.otsSecret = tableOtsSecret completion) + {input : HashInput} {candidate : Probe} {target : Position} + (hcandidate : EncodingLayerRootCandidateAt secretKey.parameter input candidate) + (hposition : candidate.coordinate = .position target) + (hcomputed : DeferredPositionComputed context target) : + (4 / 3 : ℝ≥0∞) ≤ otsOpeningRefinedQueryReserve secretKey cache input := by + have hsettled := (hcomputed.settled_value hcache completion hcompletion secretKey.ftsSecret).1 + rw [← hsecrets] at hsettled + obtain ⟨position, index, hat, htree, hleaf, _hnotBottom, rfl⟩ := hcandidate + have heq : layerMessagePosition index position.lay = target := Coordinate.position.inj hposition + subst target + exact otsOpeningRefinedQueryReserve_ge_four_thirds_of_encodingMessageSettled secretKey cache input position hat + ⟨index, htree, hleaf, hsettled⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedComputedCoupling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedComputedCoupling.lean new file mode 100644 index 00000000..d708d061 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedComputedCoupling.lean @@ -0,0 +1,159 @@ +import SphincsSecurity.Proof.OtsProbeResolvedComputedExecution + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxRecDepth 100000 in +theorem DeferredComputationsClosed.root_settled_value + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache cache : QueryCache HashSpec} + (hclosed : DeferredComputationsClosed context) + (hinvariant : ResolvedContextInvariant parameter table context ordinaryCache cache) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (lay : Layer) (tree : TreeIndex) (output : HashOutput) + (hvalue : context.positionValue (layerRootPosition lay tree) = some output) : + Settled parameter (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + ftsSecret cache (layerRootPosition lay tree) ∧ + honestValue (fromCache cache) parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + ftsSecret (layerRootPosition lay tree) = truncateHash output := by + obtain ⟨completion, hcompletion⟩ := hinvariant.2.2.2.1 + have hcomputed := hclosed (layerRootPosition lay tree) + (resolvableOtsPosition_layerRootPosition lay tree) ⟨output, hvalue⟩ + have hsettled := hcomputed.settled_value hinvariant.1 completion hcompletion ftsSecret + rw [hcompletion.tableOtsSecret_eq] at hsettled + simpa only [tableValue, hcompletion.eq_positionValue _ output hvalue] using hsettled + +set_option maxRecDepth 100000 in +theorem DeferredComputationsClosed.refinedReserve_of_encoding_candidate + {secretKey : SecretKey} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache actualCache : QueryCache HashSpec} + (hclosed : DeferredComputationsClosed context) + (hinvariant : ResolvedContextInvariant secretKey.parameter table context ordinaryCache actualCache) + (hsecrets : secretKey.otsSecret = fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + {input : HashInput} {candidate : Probe} {target : Position} {output : HashOutput} + (hcandidate : EncodingLayerRootCandidateAt secretKey.parameter input candidate) + (hposition : candidate.coordinate = .position target) + (hvalue : context.positionValue target = some output) : + (4 / 3 : ℝ≥0∞) ≤ otsOpeningRefinedQueryReserve secretKey actualCache input := by + obtain ⟨completion, hcompletion⟩ := hinvariant.2.2.2.1 + obtain ⟨position, hcoordinate, hroot⟩ := encodingLayerRootCandidateAt_isLayerRoot hcandidate + have heq : position = target := Coordinate.position.inj (hcoordinate.symm.trans hposition) + have hresolvable : ResolvableOtsPosition target := by + rw [← heq] + obtain ⟨lay, tree, rfl⟩ := hroot + exact resolvableOtsPosition_layerRootPosition lay tree + exact (hclosed target hresolvable ⟨output, hvalue⟩).refinedReserve_of_encoding_candidate hinvariant.1 + completion hcompletion (hsecrets.trans hcompletion.tableOtsSecret_eq.symm) hcandidate hposition + +set_option maxRecDepth 100000 in +theorem DeferredComputationsClosed.encoding_weightedCharge_le_refinedReserve + {secretKey : SecretKey} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache actualCache : QueryCache HashSpec} + (hclosed : DeferredComputationsClosed context) + (hinvariant : ResolvedContextInvariant secretKey.parameter table context ordinaryCache actualCache) + (hsecrets : secretKey.otsSecret = fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + {input : HashInput} {candidate : Probe} {target : Position} {output : HashOutput} + (hcandidate : EncodingLayerRootCandidateAt secretKey.parameter input candidate) + (hposition : candidate.coordinate = .position target) + (hvalue : context.positionValue target = some output) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (cache : SplitHashCache) (fuel : Nat) : + ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterRootAwarePublicPlan secretKey.parameter input publicState plan).run cache) context fuel + + (materializedCandidateCharge context.state (rootAwareCandidateForPlan? secretKey.parameter input plan) : ℝ≥0∞) * + (4 / 3) ≤ otsOpeningRefinedQueryReserve secretKey actualCache input := + (probingHashQueryAfterRootAwarePublicPlan_weightedCharge_le_four_thirds + secretKey.parameter input publicState plan cache context fuel).trans + (hclosed.refinedReserve_of_encoding_candidate hinvariant hsecrets hcandidate hposition hvalue) + +set_option maxRecDepth 100000 in +theorem relTriple_synchronizedCanonical_computed + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hcomputed : DeferredComputationsClosed context) : + RelTriple + (runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + computation context fuel table cache) + ((simulateQ (unloggedMappedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey)) computation).run concreteCache) + (fun left right => ReachableResolvedRunRel parameter table left right ∧ + ∀ result, left = some result → DeferredComputationsClosed result.context) := by + apply FtsProbeSimulation.relTriple_and_left_support + (relTriple_runSynchronizedResolved_reachable + (canonicalReachableResolvedImplCouples_chronologicalAdversaryImpl parameter root table ftsSecret) + computation context fuel cache concreteCache hinvariant hvisible hpublished) + intro left hleft result heq + subst left + exact hcomputed.of_mem_synchronizedCanonical parameter root table ftsSecret computation context fuel cache result + hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hleft + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 100000 in +theorem relTriple_synchronizedCanonical_computed_after_root + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (fuel : Nat) (rootResult : ResolvedRunResult (Digest × SplitHashCache)) + (hroot : some rootResult ∈ support + (runResolvedFromTable { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache))) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table rootResult.context + (ordinaryQueryCache rootResult.value.2) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table rootResult.context concreteCache) + (hpublished : PublishedValues rootResult.context.state) : + RelTriple + (runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + computation rootResult.context rootResult.remaining table rootResult.value.2) + ((simulateQ (unloggedMappedAdversaryImpl + (⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey)) computation).run concreteCache) + (fun left right => ReachableResolvedRunRel parameter table left right ∧ + ∀ result, left = some result → DeferredComputationsClosed result.context) := + relTriple_synchronizedCanonical_computed parameter root table ftsSecret computation rootResult.context + rootResult.remaining rootResult.value.2 concreteCache hinvariant hvisible hpublished + (deferredComputationsClosed_empty.of_mem_runResolved _ _ fuel table rootResult hroot) + +set_option maxRecDepth 100000 in +theorem encoding_weightedCharge_le_refinedReserve_of_computedSelection + {secretKey : SecretKey} {table : OtsSecretIndex → HashOutput} + {left : PrivateOrdinalSelection} {right : PermissivePrivateOrdinalSelection} + {ordinaryCache actualCache : QueryCache HashSpec} + (hclosed : DeferredComputationsClosed left.context) + (hinvariant : ResolvedContextInvariant secretKey.parameter table left.context ordinaryCache actualCache) + (hselection : CanonicalSelectionPreserved (some left) (some right)) + (hsecrets : secretKey.otsSecret = fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + {input : HashInput} {target : Position} {output : HashOutput} + (hcandidate : EncodingLayerRootCandidateAt secretKey.parameter input right.candidate) + (hposition : right.candidate.coordinate = .position target) + (hvalue : right.state.values (.position target) = some output) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (cache : SplitHashCache) (fuel : Nat) : + ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterRootAwarePublicPlan secretKey.parameter input publicState plan).run cache) + (directDeferredContext right.state) fuel + + (materializedCandidateCharge right.state (rootAwareCandidateForPlan? secretKey.parameter input plan) : ℝ≥0∞) * + (4 / 3) ≤ otsOpeningRefinedQueryReserve secretKey actualCache input := by + have hleftValue : left.context.positionValue target = some output := by + rw [← hselection.2.1.values] at hvalue + exact hvalue + exact (probingHashQueryAfterRootAwarePublicPlan_weightedCharge_le_four_thirds + secretKey.parameter input publicState plan cache (directDeferredContext right.state) fuel).trans + (hclosed.refinedReserve_of_encoding_candidate hinvariant hsecrets hcandidate hposition hleftValue) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedComputedExecution.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedComputedExecution.lean new file mode 100644 index 00000000..e45aa547 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedComputedExecution.lean @@ -0,0 +1,145 @@ +import SphincsSecurity.Proof.OtsProbeResolvedComputedInvariant + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +set_option maxRecDepth 100000 in +theorem DeferredComputationsClosed.of_mem_runResolved + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : ResolvedRunResult α) (hclosed : DeferredComputationsClosed context) + (hresult : some result ∈ support (runResolvedFromTable context fuel table computation)) : + DeferredComputationsClosed result.context := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runResolvedFromTable] at hresult + subst result + exact hclosed + | query_bind input next ih => + cases input with + | uniform n => + rw [runResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hclosed hrest + | hashOutput => + rw [runResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hclosed hrest + | ensure coordinate => + rw [runResolvedFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel + (hclosed.of_positionValue_eq (fun _ => rfl)) hresult + | probe coordinate candidate => + rw [runResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · exact ih () context remaining hclosed (by simpa [hrevealed] using hresult) + · exact ih () { context with state := context.state.addPending coordinate candidate } + remaining (hclosed.of_positionValue_eq (fun _ => rfl)) (by simpa [hrevealed] using hresult) + | peek coordinate => + rw [runResolvedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hclosed hresult + | publish coordinate => + rw [runResolvedFromTable_publish_query_bind] at hresult + exact ih () { context with state := context.state.publish coordinate } fuel + (hclosed.of_positionValue_eq (fun _ => rfl)) hresult + | reveal coordinate => + rw [runResolvedFromTable_reveal_query_bind] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + simp only [mem_support_bind_iff, support_pure, Set.mem_singleton_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hresolvedEq : resolveDeferredChainStart table index context = some resolved := by + simpa [index] using hresolved.symm + exact ih resolved.output (materializeResolvedChainStart context index resolved) fuel + (hclosed.of_positionValue_eq (congrFun + (materializeResolvedChainStart_positionValue_eq table index context resolved hresolvedEq))) + (by simpa [index, OtsSecretIndex.coordinate, materializeResolvedChainStart] using hrest) + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hresolvedClosed := hclosed.of_resolveReveal table position context resolved hresolved + have hstate := resolveDeferredReveal_preserves_state_values table position context resolved hresolved + have hvalue := resolveDeferredReveal_resolves table position context resolved hresolved + exact ih resolved.output (materializeResolvedPosition context position resolved) fuel + (hresolvedClosed.of_positionValue_eq (congrFun + (materializeResolvedPosition_positionValue_eq context position resolved hstate hvalue))) + (by simpa [materializeResolvedPosition] using hrest) + +set_option maxRecDepth 100000 in +theorem DeferredComputationsClosed.of_mem_canonicalChronologicalQuery + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult ((OracleWorld + SigningSpec).Range input × SplitHashCache)) + (hclosed : DeferredComputationsClosed context) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache)) : + DeferredComputationsClosed result.context := by + rw [canonicalChronologicalAdversaryImpl_eq_raw_then_canonicalize, mem_support_bind_iff] at hresult + obtain ⟨rawOption, hraw, hcanonical⟩ := hresult + cases rawOption with + | none => simp [canonicalizeResolvedRun] at hcanonical + | some raw => + have hrawClosed := hclosed.of_mem_runResolved _ context fuel table raw hraw + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table raw + hconsistent hstarts hraw + simp only [support_pure, Set.mem_singleton_iff, canonicalizeResolvedRun, Option.some.injEq] at hcanonical + subst result + exact hrawClosed.canonicalize hcore.2.1 + +set_option maxRecDepth 100000 in +theorem DeferredComputationsClosed.of_mem_synchronizedCanonical + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) + (hclosed : DeferredComputationsClosed context) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + computation context fuel table cache)) : + DeferredComputationsClosed result.context := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + by_cases hcompletable : DeferredCompletable table context + · rw [runSynchronizedResolved_pure _ value context fuel table cache hcompletable] at hresult + simp only [mem_support_pure_iff, Option.some.injEq] at hresult + subst result + exact hclosed + · rw [runSynchronizedResolved_pure_of_not_completable _ value context fuel table cache hcompletable] at hresult + simp at hresult + | query_bind input next ih => + rw [runSynchronizedResolved, OracleComp.construct_query_bind] at hresult + by_cases hcompletable : DeferredCompletable table context + · simp only [dif_pos hcompletable, mem_support_bind_iff] at hresult + obtain ⟨stepOption, hstep, htail⟩ := hresult + cases stepOption with + | none => simp at htail + | some step => + have hstepClosed := hclosed.of_mem_canonicalChronologicalQuery parameter root table ftsSecret + input context fuel cache step hconsistent hstarts hstep + have hcore := resolvedCore_of_mem_canonicalChronologicalAdversaryImpl parameter root table + ftsSecret input context fuel cache step hconsistent hstarts hstep + change some result ∈ support + (runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + (next step.value.1) step.context step.remaining step.table step.value.2) at htail + rw [hcore.1] at htail + exact ih step.value.1 step.context step.remaining step.value.2 hstepClosed + hcore.2.1 hcore.2.2 htail + · simp [hcompletable] at hresult + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedComputedInvariant.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedComputedInvariant.lean new file mode 100644 index 00000000..3ce7de74 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedComputedInvariant.lean @@ -0,0 +1,190 @@ +import SphincsSecurity.Proof.OtsProbeResolvedComputedResolver + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +def DeferredComputationsClosed (context : DeferredContext) : Prop := + ∀ position, ResolvableOtsPosition position → + (∃ output, context.positionValue position = some output) → DeferredPositionComputed context position + +theorem DeferredComputationsClosed.of_positionValue_eq + {before after : DeferredContext} (hclosed : DeferredComputationsClosed before) + (hvalues : ∀ position, after.positionValue position = before.positionValue position) : + DeferredComputationsClosed after := by + intro position hresolvable hknown + apply (hclosed position hresolvable ?_).of_positionValue_eq hvalues + simpa only [hvalues] using hknown + +theorem deferredComputationsClosed_empty : + DeferredComputationsClosed + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } := by + intro position _ hknown + simp [DeferredContext.positionValue, LazyRevealProbe.State.empty, emptyDeferredStructuralValues] at hknown + +theorem DeferredComputationsClosed.canonicalize + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hclosed : DeferredComputationsClosed context) (hconsistent : context.ValuesConsistent) : + DeferredComputationsClosed (canonicalizeMaterializedValues table context) := + hclosed.of_positionValue_eq (canonicalizeMaterializedValues_positionValue table context hconsistent) + +theorem DeferredComputationsClosed.of_resolvePositionValue + (position : Position) (context : DeferredContext) (result : DeferredResolution) + (hclosed : DeferredComputationsClosed context) + (hresult : some result ∈ support (resolveDeferredPositionValue position context)) + (hcomputed : ResolvableOtsPosition position → DeferredPositionComputed result.toDeferredContext position) : + DeferredComputationsClosed result.toDeferredContext := by + intro other hresolvable hknown + by_cases heq : other = position + · subst other + exact hcomputed hresolvable + · have hvalues : result.toDeferredContext.positionValue other = context.positionValue other := by + unfold DeferredContext.positionValue + rw [resolveDeferredPositionValue_preserves_state_values position context result hresult, + resolveDeferredPositionValue_preserves_other position other context result heq hresult] + exact (hclosed other hresolvable (by simpa only [hvalues] using hknown)).mono + (fun position' output hvalue => resolveDeferredPositionValue_preserves_positionValue + position position' context result output hvalue hresult) + +theorem DeferredComputationsClosed.of_resolveChainStart + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) (result : DeferredResolution) + (hclosed : DeferredComputationsClosed context) + (hresult : resolveDeferredChainStart table index context = some result) : + DeferredComputationsClosed result.toDeferredContext := + hclosed.of_positionValue_eq + (congrFun (resolveDeferredChainStart_positionValue_eq table index context result hresult)) + +set_option maxRecDepth 100000 in +theorem DeferredComputationsClosed.of_resolveChainPrefix + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps context result, + DeferredComputationsClosed context → + some result ∈ support + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) → + DeferredComputationsClosed result.toDeferredContext + | 0, _, context, result, hclosed, hresult => by + apply hclosed.of_resolveChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context result + simpa only [resolveDeferredChainPrefix, support_pure, Set.mem_singleton_iff] using hresult.symm + | steps + 1, hsteps, context, result, hclosed, hresult => by + have hcomputed := deferredPositionComputed_chainPrefix table lay tree leafIdx chainIdx + (steps + 1) hsteps context result hresult ⟨steps, by omega⟩ (by simp) + rw [resolveDeferredChainPrefix, mem_support_bind_iff] at hresult + obtain ⟨previousOption, hprevious, hrest⟩ := hresult + cases previousOption with + | none => simp at hrest + | some previous => + exact (hclosed.of_resolveChainPrefix table lay tree leafIdx chainIdx steps + (by omega) context previous hprevious).of_resolvePositionValue + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) previous.toDeferredContext result + (by simpa using hrest) (fun _ => hcomputed) + +set_option maxRecDepth 100000 in +theorem DeferredComputationsClosed.of_resolveChains + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ∀ chains context result, + DeferredComputationsClosed context → + some result ∈ support (resolveDeferredChains table lay tree leafIdx chains context) → + DeferredComputationsClosed result + | [], context, result, hclosed, hresult => by + simpa [resolveDeferredChains] using (show result = context from by simpa [resolveDeferredChains] using hresult) ▸ hclosed + | chainIdx :: remaining, context, result, hclosed, hresult => by + rw [resolveDeferredChains, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + exact (hclosed.of_resolveChainPrefix table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context resolved hresolved).of_resolveChains table lay tree leafIdx + remaining resolved.toDeferredContext result (by simpa using hrest) + +set_option maxRecDepth 100000 in +theorem DeferredComputationsClosed.of_resolveOtsLeaf + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (context : DeferredContext) (result : DeferredResolution) + (hclosed : DeferredComputationsClosed context) + (hresult : some result ∈ support (resolveDeferredOtsLeaf table lay tree leafIdx context)) : + DeferredComputationsClosed result.toDeferredContext := by + have hcomputed := deferredPositionComputed_otsLeaf table lay tree leafIdx context result hresult + rw [resolveDeferredOtsLeaf, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + exact (hclosed.of_resolveChains table lay tree leafIdx (List.ofFn fun chainIdx : ChainIndex => chainIdx) + context chains hchains).of_resolvePositionValue (.leaf lay tree leafIdx) chains result + (by simpa using hrest) (fun _ => hcomputed) + +set_option maxRecDepth 100000 in +theorem DeferredComputationsClosed.of_resolveTreeNode + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel, + 2 ^ level * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight → + ∀ context result, + DeferredComputationsClosed context → + some result ∈ support (resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) → + DeferredComputationsClosed result.toDeferredContext + | 0, nodeIdx, _, _, context, result, hclosed, hresult => by + exact hclosed.of_resolveOtsLeaf table lay tree (leafOfNat nodeIdx) context result hresult + | level + 1, nodeIdx, hlevel, hspan, context, result, hclosed, hresult => by + have hcomputed := deferredPositionComputed_treeNode table lay tree (level + 1) nodeIdx + hlevel hspan context result hresult + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨leftOption, hleft, hafterLeft⟩ := hresult + cases leftOption with + | none => simp at hafterLeft + | some left => + rw [mem_support_bind_iff] at hafterLeft + obtain ⟨rightOption, hright, hafterRight⟩ := hafterLeft + cases rightOption with + | none => simp at hafterRight + | some right => + have hleftSpan : 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith [pow_pos (by omega : 0 < (2 : Nat)) level] + have hrightSpan : 2 ^ level * (2 * nodeIdx + 1 + 1) ≤ 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith + have hleftClosed := hclosed.of_resolveTreeNode table lay tree level (2 * nodeIdx) + (by omega) hleftSpan context left hleft + have hrightClosed := hleftClosed.of_resolveTreeNode table lay tree level (2 * nodeIdx + 1) + (by omega) hrightSpan left.toDeferredContext right hright + exact hrightClosed.of_resolvePositionValue + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) right.toDeferredContext result + (by simpa using hafterRight) (fun _ => hcomputed) + +set_option maxRecDepth 100000 in +theorem DeferredComputationsClosed.of_resolvePosition + (table : OtsSecretIndex → HashOutput) (position : Position) + (hresolvable : ResolvableOtsPosition position) (context : DeferredContext) (result : DeferredResolution) + (hclosed : DeferredComputationsClosed context) + (hresult : some result ∈ support (resolveDeferredPosition table position context)) : + DeferredComputationsClosed result.toDeferredContext := by + cases position with + | chain lay tree leafIdx chainIdx step => + exact hclosed.of_resolveChainPrefix table lay tree leafIdx chainIdx (step.val + 1) + (by have := step.isLt; omega) context result hresult + | leaf lay tree leafIdx => + exact hclosed.of_resolveOtsLeaf table lay tree leafIdx context result hresult + | node lay tree level nodeIdx => + exact hclosed.of_resolveTreeNode table lay tree (level.val + 1) nodeIdx.val + (by have := level.isLt; omega) hresolvable context result hresult + | ftsLeaf | ftsNode | ftsRoots => contradiction + +set_option maxRecDepth 100000 in +theorem DeferredComputationsClosed.of_resolveReveal + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (result : DeferredResolution) + (hclosed : DeferredComputationsClosed context) + (hresult : some result ∈ support (resolveDeferredReveal table position context)) : + DeferredComputationsClosed result.toDeferredContext := by + classical + by_cases hresolvable : ResolvableOtsPosition position + · exact hclosed.of_resolvePosition table position hresolvable context result + (by simpa only [resolveDeferredReveal, if_pos hresolvable] using hresult) + · exact hclosed.of_resolvePositionValue position context result + (by simpa only [resolveDeferredReveal, if_neg hresolvable] using hresult) + (fun h => False.elim (hresolvable h)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedComputedResolver.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedComputedResolver.lean new file mode 100644 index 00000000..c008475b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedComputedResolver.lean @@ -0,0 +1,204 @@ +import SphincsSecurity.Proof.OtsProbeResolvedComputed + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +set_option maxRecDepth 100000 in +theorem deferredPositionComputed_chainPrefix + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps context result, + some result ∈ support + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) → + ∀ step : ChainStep, step.val < steps → + DeferredPositionComputed result.toDeferredContext (.chain lay tree leafIdx chainIdx step) + | 0, _, _, _, _, step, hstep => by omega + | steps + 1, hsteps, context, result, hresult, step, hstep => by + rw [resolveDeferredChainPrefix, mem_support_bind_iff] at hresult + obtain ⟨previousOption, hprevious, hrest⟩ := hresult + cases previousOption with + | none => simp at hrest + | some previous => + have hrest' : some result ∈ support + (resolveDeferredPositionValue (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + previous.toDeferredContext) := by simpa using hrest + have hpreserves := resolveDeferredPositionValue_preserves_positionValue + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + by_cases heq : step.val = steps + · have hstepEq : step = ⟨steps, by omega⟩ := Fin.ext heq + rw [hstepEq] + refine .intro _ (by trivial) (by trivial) + ⟨result.output, resolveDeferredPositionValue_resolves _ _ _ hrest'⟩ ?_ + intro child hchild + simp only [Position.children] at hchild + split_ifs at hchild with hpositive + · have hchildEq := List.mem_singleton.mp hchild + subst child + exact (deferredPositionComputed_chainPrefix table lay tree leafIdx chainIdx + steps (by omega) context previous hprevious ⟨steps - 1, by omega⟩ + (by change steps - 1 < steps; omega)).mono + (fun position output hvalue => hpreserves position previous.toDeferredContext result + output hvalue hrest') + · simp at hchild + · exact (deferredPositionComputed_chainPrefix table lay tree leafIdx chainIdx steps + (by omega) context previous hprevious step (by omega)).mono + (fun position output hvalue => hpreserves position previous.toDeferredContext result + output hvalue hrest') + +set_option maxRecDepth 100000 in +theorem deferredPositionComputed_chains + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + ∀ chains context result, + some result ∈ support (resolveDeferredChains table lay tree leafIdx chains context) → + ∀ chainIdx ∈ chains, ∀ step : ChainStep, + DeferredPositionComputed result (.chain lay tree leafIdx chainIdx step) + | [], _, _, _, _, hmem, _ => by simp at hmem + | chainIdx :: remaining, context, result, hresult, other, hmem, step => by + rw [resolveDeferredChains, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + rcases List.mem_cons.mp hmem with heq | hmem + · subst other + exact (deferredPositionComputed_chainPrefix table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context resolved hresolved step step.isLt).mono + (fun position output hvalue => resolveDeferredChains_preserves_positionValue table + lay tree leafIdx remaining resolved.toDeferredContext result position output hvalue + (by simpa using hrest)) + · exact deferredPositionComputed_chains table lay tree leafIdx remaining + resolved.toDeferredContext result (by simpa using hrest) other hmem step + +set_option maxRecDepth 100000 in +theorem deferredPositionComputed_otsLeaf + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support (resolveDeferredOtsLeaf table lay tree leafIdx context)) : + DeferredPositionComputed result.toDeferredContext (.leaf lay tree leafIdx) := by + have hknown := resolveDeferredOtsLeaf_resolves table lay tree leafIdx context result hresult + rw [resolveDeferredOtsLeaf, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + refine .intro _ (by trivial) (by trivial) ⟨result.output, hknown⟩ ?_ + intro child hchild + simp only [Position.children, List.mem_ofFn] at hchild + obtain ⟨chainIdx, rfl⟩ := hchild + exact (deferredPositionComputed_chains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) context chains hchains chainIdx + (by simp) Position.lastChainStep).mono + (fun position output hvalue => resolveDeferredPositionValue_preserves_positionValue + (.leaf lay tree leafIdx) position chains result output hvalue (by simpa using hrest)) + +theorem DeferredPositionComputed.treeNode_succ + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) + (hlevel : level + 1 ≤ maxLayerHeight) + (hspan : 2 ^ (level + 1) * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) + (context : DeferredContext) + (hknown : ∃ output, context.positionValue + (deferredTreePosition lay tree (level + 1) nodeIdx hlevel) = some output) + (hleft : DeferredPositionComputed context + (deferredTreePosition lay tree level (2 * nodeIdx) (by omega))) + (hright : DeferredPositionComputed context + (deferredTreePosition lay tree level (2 * nodeIdx + 1) (by omega))) : + DeferredPositionComputed context (deferredTreePosition lay tree (level + 1) nodeIdx hlevel) := by + have hpow : 1 ≤ 2 ^ level := Nat.one_le_pow _ _ (by omega) + have hnode : 2 * nodeIdx + 1 < 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith + have hidx : nodeIdx < 2 ^ maxLayerHeight := by omega + refine .intro _ (by trivial) ?_ hknown ?_ + · simpa [deferredTreePosition, Position.Valid, leafOfNat, Nat.mod_eq_of_lt hidx] using hnode + · intro child hchild + have hleftIdx : 2 * nodeIdx < 2 ^ maxLayerHeight := by omega + cases level with + | zero => + simp [deferredTreePosition, Position.children, leafOfNat, Nat.mod_eq_of_lt hidx, hnode] at hchild + rcases hchild with rfl | rfl + · simpa [deferredTreePosition, leafOfNat, Nat.mod_eq_of_lt hleftIdx] using hleft + · simpa [deferredTreePosition, leafOfNat, Nat.mod_eq_of_lt hnode] using hright + | succ level => + simp [deferredTreePosition, Position.children, leafOfNat, Nat.mod_eq_of_lt hidx, hnode] at hchild + rcases hchild with rfl | rfl + · simpa [deferredTreePosition, leafOfNat, Nat.mod_eq_of_lt hleftIdx] using hleft + · simpa [deferredTreePosition, leafOfNat, Nat.mod_eq_of_lt hnode] using hright + +set_option maxRecDepth 100000 in +theorem deferredPositionComputed_treeNode + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel, + 2 ^ level * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight → + ∀ context result, + some result ∈ support (resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) → + DeferredPositionComputed result.toDeferredContext + (deferredTreePosition lay tree level nodeIdx hlevel) + | 0, nodeIdx, _, _, context, result, hresult => by + exact deferredPositionComputed_otsLeaf table lay tree (leafOfNat nodeIdx) context result hresult + | level + 1, nodeIdx, hlevel, hspan, context, result, hresult => by + have hknown := resolveDeferredTreeNode_resolves table lay tree (level + 1) nodeIdx hlevel + context result hresult + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨leftOption, hleft, hafterLeft⟩ := hresult + cases leftOption with + | none => simp at hafterLeft + | some left => + rw [mem_support_bind_iff] at hafterLeft + obtain ⟨rightOption, hright, hafterRight⟩ := hafterLeft + cases rightOption with + | none => simp at hafterRight + | some right => + have hleftSpan : 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith [pow_pos (by omega : 0 < (2 : Nat)) level] + have hrightSpan : 2 ^ level * (2 * nodeIdx + 1 + 1) ≤ 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + nlinarith + have hleftComputed := deferredPositionComputed_treeNode table lay tree level + (2 * nodeIdx) (by omega) hleftSpan context left hleft + have hrightComputed := deferredPositionComputed_treeNode table lay tree level + (2 * nodeIdx + 1) (by omega) hrightSpan left.toDeferredContext right hright + have hleftInRight := hleftComputed.mono + (fun position output hvalue => resolveDeferredTreeNode_preserves_positionValue table + lay tree level (2 * nodeIdx + 1) (by omega) left.toDeferredContext right + position output hvalue hright) + have hpreserves := fun position output hvalue => + resolveDeferredPositionValue_preserves_positionValue + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) position + right.toDeferredContext result output hvalue (by simpa using hafterRight) + exact DeferredPositionComputed.treeNode_succ lay tree level nodeIdx hlevel hspan + result.toDeferredContext ⟨result.output, hknown⟩ + (hleftInRight.mono hpreserves) (hrightComputed.mono hpreserves) + +set_option maxRecDepth 100000 in +theorem deferredPositionComputed_resolvePosition + (table : OtsSecretIndex → HashOutput) (position : Position) + (hresolvable : ResolvableOtsPosition position) + (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support (resolveDeferredPosition table position context)) : + DeferredPositionComputed result.toDeferredContext position := by + cases position with + | chain lay tree leafIdx chainIdx step => + exact deferredPositionComputed_chainPrefix table lay tree leafIdx chainIdx + (step.val + 1) (by have := step.isLt; omega) context result hresult step (by omega) + | leaf lay tree leafIdx => + exact deferredPositionComputed_otsLeaf table lay tree leafIdx context result hresult + | node lay tree level nodeIdx => + simpa only [deferredTreePosition, leafOfNat_val] using + deferredPositionComputed_treeNode table lay tree (level.val + 1) nodeIdx.val + (by have := level.isLt; omega) hresolvable context result hresult + | ftsLeaf | ftsNode | ftsRoots => contradiction + +set_option maxRecDepth 100000 in +theorem deferredPositionComputed_resolveReveal + (table : OtsSecretIndex → HashOutput) (position : Position) + (hresolvable : ResolvableOtsPosition position) + (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support (resolveDeferredReveal table position context)) : + DeferredPositionComputed result.toDeferredContext position := + deferredPositionComputed_resolvePosition table position hresolvable context result + (by simpa only [resolveDeferredReveal, if_pos hresolvable] using hresult) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedDirect.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedDirect.lean new file mode 100644 index 00000000..9c4f8d07 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedDirect.lean @@ -0,0 +1,733 @@ +import SphincsSecurity.Proof.OtsProbeResolvedCleanTerminal + +/-! Direct structural sampling with resolved contexts, projecting exactly to the clean interpreter. -/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def directDeferredValues (state : LazyRevealProbe.State Coordinate) : + DeferredStructuralValues := fun position => state.values (.position position) + +def directDeferredContext (state : LazyRevealProbe.State Coordinate) : DeferredContext := + { state := state, values := directDeferredValues state } + +noncomputable def runDirectResolvedFromTable + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + ProbComp (Option (ResolvedRunResult α)) := + OracleComp.construct + (C := fun _ : OracleComp (LazyRevealProbe.World Coordinate) α => + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → + ProbComp (Option (ResolvedRunResult α))) + (fun value context remaining table => + pure (some ⟨context, remaining, value, table⟩)) + (fun input _next recursivelyRun context fuel table => + match input with + | .uniform n => do + let output ← liftM (unifSpec.query n) + recursivelyRun output context fuel table + | .hashOutput => do + let output ← LazyRevealProbe.sampleHashOutput + recursivelyRun output context fuel table + | .ensure coordinate => + recursivelyRun () + { context with state := context.state.ensure coordinate } fuel table + | .probe coordinate candidate => + match fuel with + | 0 => pure none + | remaining + 1 => + if coordinate ∈ context.state.revealed then + recursivelyRun () context remaining table + else + recursivelyRun () + { context with + state := context.state.addPending coordinate candidate } + remaining table + | .peek coordinate => + recursivelyRun (context.state.values coordinate) context fuel table + | .publish coordinate => + recursivelyRun () + { context with state := context.state.publish coordinate } fuel table + | .reveal coordinate => + match context.state.values coordinate with + | some output => recursivelyRun output context fuel table + | none => + match coordinate with + | .chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + if context.state.hitAt coordinate output then + pure none + else + recursivelyRun output + { state := context.state.materialize coordinate output + values := context.values } + fuel table + | .position position => do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure none + | some resolved => + recursivelyRun resolved.output + { state := context.state.materialize coordinate resolved.output + values := resolved.values } + fuel table) + computation context fuel table + +theorem runDirectResolvedFromTable_uniform_query_bind + (context : DeferredContext) (fuel n : Nat) + (table : OtsSecretIndex → HashOutput) + (next : Fin (n + 1) → OracleComp (LazyRevealProbe.World Coordinate) α) : + runDirectResolvedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.uniform n)) : + OracleComp (LazyRevealProbe.World Coordinate) (Fin (n + 1))) >>= next) = (do + let output ← liftM (unifSpec.query n) + runDirectResolvedFromTable context fuel table (next output)) := by + rfl + +theorem runDirectResolvedFromTable_hashOutput_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) : + runDirectResolvedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + .hashOutput) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = (do + let output ← LazyRevealProbe.sampleHashOutput + runDirectResolvedFromTable context fuel table (next output)) := by + rfl + +theorem runDirectResolvedFromTable_ensure_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) α) : + runDirectResolvedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.ensure coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runDirectResolvedFromTable + { context with state := context.state.ensure coordinate } + fuel table (next ()) := by + rfl + +theorem runDirectResolvedFromTable_probe_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (candidate : Digest) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) α) : + runDirectResolvedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.probe coordinate candidate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + match fuel with + | 0 => pure none + | remaining + 1 => + if coordinate ∈ context.state.revealed then + runDirectResolvedFromTable context remaining table (next ()) + else + runDirectResolvedFromTable + { context with + state := context.state.addPending coordinate candidate } + remaining table (next ()) := by + rfl + +theorem runDirectResolvedFromTable_peek_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Option HashOutput → + OracleComp (LazyRevealProbe.World Coordinate) α) : + runDirectResolvedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.peek coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) (Option HashOutput)) >>= next) = + runDirectResolvedFromTable context fuel table + (next (context.state.values coordinate)) := by + rfl + +theorem runDirectResolvedFromTable_publish_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) α) : + runDirectResolvedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.publish coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runDirectResolvedFromTable + { context with state := context.state.publish coordinate } + fuel table (next ()) := by + rfl + +theorem runDirectResolvedFromTable_reveal_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) : + runDirectResolvedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.reveal coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = (do + match context.state.values coordinate with + | some output => runDirectResolvedFromTable context fuel table (next output) + | none => + match coordinate with + | .chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + if context.state.hitAt coordinate output then + pure none + else + runDirectResolvedFromTable + { state := context.state.materialize coordinate output + values := context.values } + fuel table (next output) + | .position position => do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure none + | some resolved => + runDirectResolvedFromTable + { state := context.state.materialize coordinate resolved.output + values := resolved.values } + fuel table (next resolved.output)) := by + cases coordinate <;> rfl + +theorem directDeferredValues_ensure + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) : + directDeferredValues (state.ensure coordinate) = directDeferredValues state := rfl + +theorem directDeferredValues_addPending + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (candidate : Digest) : + directDeferredValues (state.addPending coordinate candidate) = + directDeferredValues state := rfl + +theorem directDeferredValues_publish + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) : + directDeferredValues (state.publish coordinate) = directDeferredValues state := rfl + +theorem directDeferredValues_materialize_chainStart + (state : LazyRevealProbe.State Coordinate) (index : OtsSecretIndex) + (output : HashOutput) : + directDeferredValues (state.materialize index.coordinate output) = + directDeferredValues state := by + funext position + simp [directDeferredValues, LazyRevealProbe.State.materialize, + OtsSecretIndex.coordinate] + +theorem directDeferredValues_materialize_position + (state : LazyRevealProbe.State Coordinate) (position : Position) + (output : HashOutput) : + directDeferredValues (state.materialize (.position position) output) = + (directDeferredValues state).install position output := by + funext other + by_cases heq : other = position + · subst other + simp [directDeferredValues, DeferredStructuralValues.install, + LazyRevealProbe.State.materialize] + · simp [directDeferredValues, DeferredStructuralValues.install, + LazyRevealProbe.State.materialize, heq] + +theorem resolveDeferredPositionValue_direct_values + (position : Position) (state : LazyRevealProbe.State Coordinate) + (result : DeferredResolution) + (hstate : state.values (.position position) = none) + (hresult : some result ∈ support + (resolveDeferredPositionValue position (directDeferredContext state))) : + result.values = (directDeferredValues state).install position result.output := by + have hprivate : (directDeferredContext state).values position = none := by + simpa [directDeferredContext, directDeferredValues] using hstate + rw [resolveDeferredPositionValue_fresh position (directDeferredContext state) + (by simpa [directDeferredContext] using hstate) hprivate, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hreturn⟩ := hresult + by_cases hhit : state.hitAt (.position position) output + · simp [directDeferredContext, hhit] at hreturn + · simp [directDeferredContext, hhit] at hreturn + subst result + rfl + +set_option maxRecDepth 100000 in +theorem direct_context_of_mem_runDirectResolvedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hresult : some result ∈ support + (runDirectResolvedFromTable (directDeferredContext state) fuel table computation)) : + result.context = directDeferredContext result.context.state := by + induction computation using OracleComp.inductionOn generalizing state fuel result with + | pure value => + simp [runDirectResolvedFromTable] at hresult + subst result + rfl + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output state fuel result hrest + | hashOutput => + rw [runDirectResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output state fuel result hrest + | ensure coordinate => + rw [runDirectResolvedFromTable_ensure_query_bind] at hresult + have hcontext : + { directDeferredContext state with state := state.ensure coordinate } = + directDeferredContext (state.ensure coordinate) := by + simp [directDeferredContext, directDeferredValues_ensure] + exact ih () (state.ensure coordinate) fuel result (hcontext ▸ hresult) + | probe coordinate candidate => + rw [runDirectResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · exact ih () state remaining result (by + simpa [directDeferredContext, hrevealed] using hresult) + · simp only [directDeferredContext, hrevealed, ↓reduceIte] at hresult + have hcontext : + { directDeferredContext state with + state := state.addPending coordinate candidate } = + directDeferredContext (state.addPending coordinate candidate) := by + simp [directDeferredContext, directDeferredValues_addPending] + exact ih () (state.addPending coordinate candidate) remaining result + (hcontext ▸ hresult) + | peek coordinate => + rw [runDirectResolvedFromTable_peek_query_bind] at hresult + exact ih (state.values coordinate) state fuel result hresult + | publish coordinate => + rw [runDirectResolvedFromTable_publish_query_bind] at hresult + exact ih () (state.publish coordinate) fuel result (by + simpa [directDeferredContext, directDeferredValues_publish] using hresult) + | reveal coordinate => + rw [runDirectResolvedFromTable_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + exact ih output state fuel result (by + simpa only [directDeferredContext, hvalue] using hresult) + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + let output := table index + by_cases hhit : state.hitAt index.coordinate output + · change state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) at hhit + simp only [directDeferredContext, hvalue, hhit, ↓reduceIte] at hresult + simp at hresult + · have hcontext : + { state := state.materialize index.coordinate output + values := directDeferredValues state } = + directDeferredContext (state.materialize index.coordinate output) := by + simp [directDeferredContext, + directDeferredValues_materialize_chainStart] + change ¬state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) at hhit + simp only [directDeferredContext, hvalue, hhit, ↓reduceIte] at hresult + exact ih output (state.materialize index.coordinate output) fuel result + (hcontext ▸ hresult) + | position position => + simp only [directDeferredContext] at hresult + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + simp only at hrest + have hvalues := resolveDeferredPositionValue_direct_values position state + resolved hvalue hresolved + have hcontext : + { state := state.materialize (.position position) resolved.output + values := resolved.values } = + directDeferredContext + (state.materialize (.position position) resolved.output) := by + rw [hvalues] + simp [directDeferredContext, + directDeferredValues_materialize_position] + exact ih resolved.output + (state.materialize (.position position) resolved.output) fuel result + (hcontext ▸ hrest) + +def ChainValuesMirrored (context : DeferredContext) : Prop := + ∀ lay tree leafIdx chainIdx step, + context.values (.chain lay tree leafIdx chainIdx step) = + context.state.values (.position (.chain lay tree leafIdx chainIdx step)) + +theorem chainValuesMirrored_directDeferredContext + (state : LazyRevealProbe.State Coordinate) : + ChainValuesMirrored (directDeferredContext state) := by + intro lay tree leafIdx chainIdx step + rfl + +theorem ChainValuesMirrored.resolve_materialize + {context : DeferredContext} (hmirror : ChainValuesMirrored context) + (position : Position) (resolved : DeferredResolution) + (hresolved : some resolved ∈ support + (resolveDeferredPositionValue position context)) : + ChainValuesMirrored + { state := context.state.materialize (.position position) resolved.output + values := resolved.values } := by + intro lay tree leafIdx chainIdx step + let chainPosition : Position := .chain lay tree leafIdx chainIdx step + by_cases heq : chainPosition = position + · subst position + rw [resolveDeferredPositionValue_installs chainPosition context resolved hresolved] + change some resolved.output = Function.update context.state.values + (.position chainPosition) (some resolved.output) (.position chainPosition) + simp [Function.update] + · rw [resolveDeferredPositionValue_preserves_other position chainPosition context resolved + heq hresolved, + hmirror lay tree leafIdx chainIdx step] + have hcoordinate : Coordinate.position chainPosition ≠ .position position := by + intro h + injection h with h + exact heq h + dsimp [chainPosition] at hcoordinate ⊢ + simp [LazyRevealProbe.State.materialize, Function.update, hcoordinate] + +set_option maxRecDepth 100000 in +theorem chainValuesMirrored_of_mem_runDirectResolvedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hmirror : ChainValuesMirrored context) + (hresult : some result ∈ support + (runDirectResolvedFromTable context fuel table computation)) : + ChainValuesMirrored result.context := by + induction computation using OracleComp.inductionOn generalizing context fuel result with + | pure value => + simp [runDirectResolvedFromTable] at hresult + subst result + exact hmirror + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel result hmirror hrest + | hashOutput => + rw [runDirectResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel result hmirror hrest + | ensure coordinate => + rw [runDirectResolvedFromTable_ensure_query_bind] at hresult + apply ih () { context with state := context.state.ensure coordinate } fuel result + · intro lay tree leafIdx chainIdx step + exact hmirror lay tree leafIdx chainIdx step + · exact hresult + | probe coordinate candidate => + rw [runDirectResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · exact ih () context remaining result hmirror (by + simpa [hrevealed] using hresult) + · apply ih () { context with + state := context.state.addPending coordinate candidate } remaining result + · intro lay tree leafIdx chainIdx step + exact hmirror lay tree leafIdx chainIdx step + · simpa [hrevealed] using hresult + | peek coordinate => + rw [runDirectResolvedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel result hmirror hresult + | publish coordinate => + rw [runDirectResolvedFromTable_publish_query_bind] at hresult + apply ih () { context with state := context.state.publish coordinate } fuel result + · intro lay tree leafIdx chainIdx step + exact hmirror lay tree leafIdx chainIdx step + · exact hresult + | reveal coordinate => + rw [runDirectResolvedFromTable_reveal_query_bind] at hresult + cases hvalue : context.state.values coordinate with + | some output => + exact ih output context fuel result hmirror (by simpa [hvalue] using hresult) + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + let output := table index + by_cases hhit : context.state.hitAt index.coordinate output + · change context.state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) at hhit + simp [hvalue, hhit] at hresult + · change ¬context.state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) at hhit + simp only [hvalue, hhit, ↓reduceIte] at hresult + apply ih output + { state := context.state.materialize index.coordinate output + values := context.values } + fuel result + · intro otherLay otherTree otherLeaf otherChain otherStep + simpa [LazyRevealProbe.State.materialize, index, + OtsSecretIndex.coordinate] using + hmirror otherLay otherTree otherLeaf otherChain otherStep + · simpa [index, output, OtsSecretIndex.coordinate] using hresult + | position position => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + simp only at hrest + exact ih resolved.output + { state := context.state.materialize (.position position) resolved.output + values := resolved.values } + fuel result (hmirror.resolve_materialize position resolved hresolved) hrest + +set_option maxRecDepth 100000 in +theorem raw_done_of_mem_runDirectResolvedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hresult : some result ∈ support + (runDirectResolvedFromTable context fuel table computation)) : + LazyRevealProbe.RawResult.done result.context.state result.remaining result.value ∈ + support (LazyRevealProbe.runRaw context.state fuel computation) := by + induction computation using OracleComp.inductionOn generalizing context fuel result with + | pure value => + simp [runDirectResolvedFromTable] at hresult + subst result + simp [LazyRevealProbe.runRaw] + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hrest⟩ := hresult + rw [LazyRevealProbe.runRaw_uniform_query_bind, mem_support_bind_iff] + exact ⟨output, houtput, ih output context fuel result hrest⟩ + | hashOutput => + rw [runDirectResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, houtput, hrest⟩ := hresult + rw [LazyRevealProbe.runRaw_hashOutput_query_bind, mem_support_bind_iff] + exact ⟨output, houtput, ih output context fuel result hrest⟩ + | ensure coordinate => + rw [runDirectResolvedFromTable_ensure_query_bind] at hresult + rw [LazyRevealProbe.runRaw_ensure_query_bind] + exact ih () { context with state := context.state.ensure coordinate } fuel result hresult + | probe coordinate candidate => + rw [runDirectResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + rw [LazyRevealProbe.runRaw_probe_query_bind] + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () context remaining result (by simpa [hrevealed] using hresult) + · simp only [hrevealed, ↓reduceIte] + exact ih () { context with + state := context.state.addPending coordinate candidate } remaining result + (by simpa [hrevealed] using hresult) + | peek coordinate => + rw [runDirectResolvedFromTable_peek_query_bind] at hresult + rw [LazyRevealProbe.runRaw_peek_query_bind] + exact ih (context.state.values coordinate) context fuel result hresult + | publish coordinate => + rw [runDirectResolvedFromTable_publish_query_bind] at hresult + rw [LazyRevealProbe.runRaw_publish_query_bind] + exact ih () { context with state := context.state.publish coordinate } fuel result hresult + | reveal coordinate => + rw [runDirectResolvedFromTable_reveal_query_bind] at hresult + rw [LazyRevealProbe.runRaw_reveal_query_bind] + cases hvalue : context.state.values coordinate with + | some output => + exact ih output context fuel result (by simpa [hvalue] using hresult) + | none => + simp only + rw [mem_support_bind_iff] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + let output := table index + by_cases hhit : context.state.hitAt index.coordinate output + · change context.state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) at hhit + simp [hvalue, hhit] at hresult + · change ¬context.state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) at hhit + simp only [hvalue, hhit, ↓reduceIte] at hresult + refine ⟨output, ?_, ?_⟩ + · simp [LazyRevealProbe.sampleHashOutput] + · simp only [index, output, hhit, ↓reduceIte] + exact ih output + { state := context.state.materialize index.coordinate output + values := context.values } + fuel result (by + simpa [index, output, OtsSecretIndex.coordinate] using hresult) + | position position => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + simp only at hrest + refine ⟨resolved.output, ?_, ?_⟩ + · simp [LazyRevealProbe.sampleHashOutput] + · have hnotHit := resolveDeferredPositionValue_not_hit position context + resolved hresolved + simp only [hnotHit, ↓reduceIte] + exact ih resolved.output + { state := context.state.materialize (.position position) resolved.output + values := resolved.values } + fuel result hrest + +theorem chainInvariant_of_mem_runDirectResolvedFromTable + (parameter : PublicParameter) (allowed : Coordinate → Prop) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) + (hpreserves : PreservesChainInvariant parameter allowed computation) + (hinvariant : ChainInvariant parameter allowed context.state cache) + (hresult : some result ∈ support + (runDirectResolvedFromTable context fuel table (computation.run cache))) : + ChainInvariant parameter allowed result.context.state result.value.2 := by + apply hpreserves context.state cache fuel result.context.state result.remaining + result.value.1 result.value.2 hinvariant + exact raw_done_of_mem_runDirectResolvedFromTable + (computation.run cache) context fuel table result hresult + +theorem chainValid_of_mem_runDirectResolvedFromTable + (allowed : Coordinate → Prop) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) + (hpreserves : PreservesChainValid allowed computation) + (hvalid : ChainState.ValidFor allowed context.state) + (hresult : some result ∈ support + (runDirectResolvedFromTable context fuel table (computation.run cache))) : + ChainState.ValidFor allowed result.context.state := by + apply hpreserves context.state cache fuel result.context.state result.remaining + result.value.1 result.value.2 hvalid + exact raw_done_of_mem_runDirectResolvedFromTable + (computation.run cache) context fuel table result hresult + +set_option maxRecDepth 100000 in +theorem map_projectResolvedRunResult_runDirect_eq_runClean + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + projectResolvedRunResult <$> + runDirectResolvedFromTable (directDeferredContext state) fuel table computation = + runCleanFromTable state fuel table computation := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => simp [runDirectResolvedFromTable, runCleanFromTable, + projectResolvedRunResult, directDeferredContext] + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectResolvedFromTable_uniform_query_bind, + runCleanFromTable_uniform_query_bind, map_bind] + apply bind_congr + intro output + exact ih output state fuel + | hashOutput => + rw [runDirectResolvedFromTable_hashOutput_query_bind, + runCleanFromTable_hashOutput_query_bind, map_bind] + apply bind_congr + intro output + exact ih output state fuel + | ensure coordinate => + rw [runDirectResolvedFromTable_ensure_query_bind, + runCleanFromTable_ensure_query_bind] + simpa [directDeferredContext, directDeferredValues_ensure] using + ih () (state.ensure coordinate) fuel + | probe coordinate candidate => + rw [runDirectResolvedFromTable_probe_query_bind, + runCleanFromTable_probe_query_bind] + cases fuel with + | zero => simp [projectResolvedRunResult] + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [directDeferredContext, hrevealed, ↓reduceIte] + exact ih () state remaining + · simp only [directDeferredContext, hrevealed, ↓reduceIte] + simpa [directDeferredContext, directDeferredValues_addPending] using + ih () (state.addPending coordinate candidate) remaining + | peek coordinate => + rw [runDirectResolvedFromTable_peek_query_bind, + runCleanFromTable_peek_query_bind] + exact ih (state.values coordinate) state fuel + | publish coordinate => + rw [runDirectResolvedFromTable_publish_query_bind, + runCleanFromTable_publish_query_bind] + simpa [directDeferredContext, directDeferredValues_publish] using + ih () (state.publish coordinate) fuel + | reveal coordinate => + rw [runDirectResolvedFromTable_reveal_query_bind, + runCleanFromTable_reveal_query_bind] + cases hvalue : state.values coordinate with + | some output => + simp only [directDeferredContext, hvalue] + exact ih output state fuel + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + let output := table index + by_cases hhit : state.hitAt index.coordinate output + · change state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) at hhit + simp [directDeferredContext, hvalue, hhit, + projectResolvedRunResult] + · change ¬state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) at hhit + simp only [directDeferredContext, hvalue, hhit, ↓reduceIte] + have hcontext : + { state := state.materialize index.coordinate output, + values := directDeferredValues state } = + directDeferredContext + (state.materialize index.coordinate output) := by + simp [directDeferredContext, + directDeferredValues_materialize_chainStart] + simpa [index, output] using + (hcontext ▸ ih output + (state.materialize index.coordinate output) fuel) + | position position => + have hstate : (directDeferredContext state).state = state := rfl + simp only [hstate, hvalue] + have hprivate : + (directDeferredContext state).values position = none := by + simpa [directDeferredContext, directDeferredValues] using hvalue + rw [resolveDeferredPositionValue_fresh position + (directDeferredContext state) hvalue hprivate] + · simp only [map_bind, bind_assoc] + apply bind_congr + intro output + by_cases hhit : state.hitAt (.position position) output + · simp [hstate, hhit, projectResolvedRunResult] + · simp only [hhit, ↓reduceIte, pure_bind, + directDeferredContext] + have hcontext : + { state := state.materialize (.position position) output, + values := (directDeferredValues state).install position output } = + directDeferredContext + (state.materialize (.position position) output) := by + simp [directDeferredContext, + directDeferredValues_materialize_position] + rw [hcontext] + exact ih output (state.materialize (.position position) output) fuel + +noncomputable def finishDirectRunIsNone : + Option (ResolvedRunResult α) → ProbComp Bool := fun result => + finishCleanRunIsNone (projectResolvedRunResult result) + +set_option maxRecDepth 100000 in +theorem evalDist_runDirectFinishIsNone_eq_runCleanFinishIsNone + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + evalDist (runDirectResolvedFromTable (directDeferredContext state) fuel table computation >>= + finishDirectRunIsNone) = + evalDist (runCleanFromTable state fuel table computation >>= finishCleanRunIsNone) := by + have hprojection := map_projectResolvedRunResult_runDirect_eq_runClean computation state + fuel table + unfold finishDirectRunIsNone + rw [← hprojection, map_eq_bind_pure_comp, bind_assoc] + rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedDirectPositionNeutral.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedDirectPositionNeutral.lean new file mode 100644 index 00000000..435b76b1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedDirectPositionNeutral.lean @@ -0,0 +1,895 @@ +import SphincsSecurity.Proof.OtsProbeResolvedDirectRecursive + +/-! Fixed-position resolution commutation for the direct interpreter. -/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +theorem evalDist_resolveDeferredPositionValue_then_runDirectResolvedObserve_eq_true_of_not_completable_auto + {observe : DeferredContext → Nat → α → ProbComp Bool} + (position : Position) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) [ObserverDooms table observe] + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure true + | some resolved => + runDirectResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (pure true : ProbComp Bool) := by + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun _ => pure true) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hresolvedNotCompletable : + ¬DeferredCompletable table resolved.toDeferredContext := by + intro hresolvedCompletable + obtain ⟨completion, hcompletion⟩ := hresolvedCompletable + have hback := + (deferredCompletion_resolveDeferredPositionValue_iff position resolved + hconsistent hresolved completion).mp hcompletion + exact hdoomed ⟨completion, hback.1⟩ + exact evalDist_runDirectResolvedObserve_eq_true_of_not_completable_auto + resolved.toDeferredContext fuel table computation + (hconsistent.of_resolveDeferredPositionValue position resolved hresolved) + (hstarts.of_state_values_eq + (resolveDeferredPositionValue_preserves_state_values position context resolved + hresolved)) + hresolvedNotCompletable + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolveDeferredPositionValue position context) (by + simp [resolveDeferredPositionValue, LazyRevealProbe.sampleHashOutput]) + (pure true) + +theorem evalDist_resolveDeferredPositionValue_after_materialized_reveal_runDirectResolvedObserve + (target revealed : Position) (context : DeferredContext) + (revealedResult : DeferredResolution) (table : OtsSecretIndex → HashOutput) + (fuel : Nat) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hrevealed : some revealedResult ∈ support + (resolveDeferredReveal table revealed context)) : + evalDist (resolveDeferredPositionValue target revealedResult.toDeferredContext >>= + fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runDirectResolvedObserve observe + { state := (context.state.clearPending (.position target)).materialize + (.position revealed) revealedResult.output + values := targetResult.values } + fuel table computation) = + evalDist (resolveDeferredPositionValue target + (materializeResolvedPosition context revealed revealedResult) >>= fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runDirectResolvedObserve observe targetResult.toDeferredContext fuel table + computation) := + evalDist_resolveDeferredPositionValue_after_materialized_reveal_observe + (fun nextContext => runDirectResolvedObserve observe nextContext fuel table computation) + target revealed context revealedResult table hvalid hcompletable hrevealed + +theorem evalDist_resolveDeferredPositionValue_after_materialized_chainStart_runDirectResolvedObserve + (target : Position) (index : OtsSecretIndex) (context : DeferredContext) + (revealedResult : DeferredResolution) (table : OtsSecretIndex → HashOutput) + (fuel : Nat) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hrevealed : resolveDeferredChainStart table index context = some revealedResult) : + evalDist (resolveDeferredPositionValue target revealedResult.toDeferredContext >>= + fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runDirectResolvedObserve observe + { state := (context.state.clearPending (.position target)).materialize + index.coordinate revealedResult.output + values := targetResult.values } + fuel table computation) = + evalDist (resolveDeferredPositionValue target + (materializeResolvedChainStart context index revealedResult) >>= fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runDirectResolvedObserve observe targetResult.toDeferredContext fuel table + computation) := + evalDist_resolveDeferredPositionValue_after_materialized_chainStart_observe + (fun nextContext => runDirectResolvedObserve observe nextContext fuel table computation) + target index context revealedResult table hvalid hcompletable hrevealed + +theorem evalDist_resolveDeferredPositionValue_after_materialized_positionValue_runDirectResolvedObserve + (target revealed : Position) (context : DeferredContext) + (revealedResult : DeferredResolution) (table : OtsSecretIndex → HashOutput) + (fuel : Nat) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hrevealed : some revealedResult ∈ support + (resolveDeferredPositionValue revealed context)) : + evalDist (resolveDeferredPositionValue target revealedResult.toDeferredContext >>= + fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runDirectResolvedObserve observe + { state := (context.state.clearPending (.position target)).materialize + (.position revealed) revealedResult.output + values := targetResult.values } + fuel table computation) = + evalDist (resolveDeferredPositionValue target + (materializeResolvedPosition context revealed revealedResult) >>= fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runDirectResolvedObserve observe targetResult.toDeferredContext fuel table + computation) := + evalDist_resolveDeferredPositionValue_after_materialized_positionValue_observe + (fun nextContext => runDirectResolvedObserve observe nextContext fuel table computation) + target revealed context revealedResult table hvalid hcompletable hrevealed + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_runDirectResolvedObserve + (position : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : Coordinate.position position ∈ context.state.ensured) + (hbase : ∀ nextContext remaining value, + nextContext.Valid → DeferredCompletable table nextContext → + Coordinate.position position ∈ nextContext.state.ensured → + evalDist (resolveDeferredPositionValue position nextContext >>= fun resolved => + match resolved with + | none => pure true + | some resolved => observe resolved.toDeferredContext remaining value) = + evalDist (observe nextContext remaining value)) + [ObserverDooms table observe] : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure true + | some resolved => + runDirectResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (runDirectResolvedObserve observe context fuel table computation) := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + unfold runDirectResolvedObserve + simp only [runDirectResolvedFromTable, pure_bind] + exact hbase context fuel value hvalid hcompletable hensured + | query_bind query next ih => + cases query with + | uniform n => + unfold runDirectResolvedObserve + simp only [runDirectResolvedFromTable_uniform_query_bind, bind_assoc] + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) >>= fun output => + match resolved with + | none => pure true + | some resolved => + runDirectResolvedFromTable resolved.toDeferredContext fuel table + (next output) >>= + finishObserve observe) := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro resolved + cases resolved with + | none => + exact (OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) + (by simp) (pure true)).symm + | some resolved => rfl + _ = evalDist ((liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) >>= fun output => + resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runDirectResolvedFromTable resolved.toDeferredContext fuel table + (next output) >>= + finishObserve observe) := + OracleComp.DeferredSampling.evalDist_bind_comm + (resolveDeferredPositionValue position context) + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) _ + _ = _ := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + exact ih output context fuel hvalid hcompletable hensured + | hashOutput => + unfold runDirectResolvedObserve + simp only [runDirectResolvedFromTable_hashOutput_query_bind, bind_assoc] + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + LazyRevealProbe.sampleHashOutput >>= fun output => + match resolved with + | none => pure true + | some resolved => + runDirectResolvedFromTable resolved.toDeferredContext fuel table + (next output) >>= + finishObserve observe) := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro resolved + cases resolved with + | none => + exact (OracleComp.DeferredSampling.evalDist_bind_const_neverFails + LazyRevealProbe.sampleHashOutput (by + simp [LazyRevealProbe.sampleHashOutput]) (pure true)).symm + | some resolved => rfl + _ = evalDist (LazyRevealProbe.sampleHashOutput >>= fun output => + resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runDirectResolvedFromTable resolved.toDeferredContext fuel table + (next output) >>= + finishObserve observe) := + OracleComp.DeferredSampling.evalDist_bind_comm + (resolveDeferredPositionValue position context) + LazyRevealProbe.sampleHashOutput _ + _ = _ := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + exact ih output context fuel hvalid hcompletable hensured + | ensure coordinate => + unfold runDirectResolvedObserve + simp_rw [runDirectResolvedFromTable_ensure_query_bind] + calc + _ = evalDist (resolveDeferredPositionValue position + { context with state := context.state.ensure coordinate } >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runDirectResolvedFromTable resolved.toDeferredContext fuel table (next ()) >>= + finishObserve observe) := by + rw [resolveDeferredPositionValue_ensure] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply congrArg evalDist + apply bind_congr + intro resolved + cases resolved <;> rfl + _ = _ := ih () { context with state := context.state.ensure coordinate } fuel + (hvalid.ensure coordinate) (hcompletable.ensure coordinate) (by + exact Finset.mem_insert.mpr (Or.inr hensured)) + | probe coordinate candidate => + unfold runDirectResolvedObserve + simp_rw [runDirectResolvedFromTable_probe_query_bind] + cases fuel with + | zero => + simp only [pure_bind] + have hnone : finishObserve observe + (none : Option (ResolvedRunResult α)) = pure true := by + simp [finishObserve] + simp_rw [hnone] + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun _ => + pure true) := by + apply congrArg evalDist + apply bind_congr + intro resolved + cases resolved <;> rfl + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolveDeferredPositionValue position context) (by + simp [resolveDeferredPositionValue, LazyRevealProbe.sampleHashOutput]) + (pure true) + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runDirectResolvedFromTable resolved.toDeferredContext remaining table + (next ()) >>= + finishObserve observe) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hstate := resolveDeferredPositionValue_state_eq_clearPending + position context resolved hresolved + simp [hstate, LazyRevealProbe.State.clearPending, hrevealed] + _ = _ := by + simpa [runDirectResolvedObserve, hrevealed] using + ih () context remaining hvalid hcompletable hensured + · by_cases heq : coordinate = .position position + · subst coordinate + let nextContext : DeferredContext := + { context with + state := context.state.addPending (.position position) candidate } + let continuation : Option DeferredResolution → ProbComp Bool + | none => pure true + | some resolved => + runDirectResolvedFromTable resolved.toDeferredContext remaining table + (next ()) >>= + finishObserve observe + calc + _ = evalDist (resolveDeferredPositionValue position context >>= + fun first => + match first with + | none => pure true + | some first => + resolveDeferredPositionValue position + { first.toDeferredContext with + state := first.state.addPending (.position position) + candidate } >>= + continuation) := by + apply evalDist_bind_congr + intro first hfirst + cases first with + | none => rfl + | some first => + let added : DeferredContext := + { first.toDeferredContext with + state := first.state.addPending (.position position) candidate } + have hfirstValid := + hvalid.of_resolveDeferredPositionValue position first hfirst + have hfirstCompletable := + hcompletable.of_resolveDeferredPositionValue hvalid position first + hfirst + have hfirstState := resolveDeferredPositionValue_state_eq_clearPending + position context first hfirst + have hnotRevealed : + Coordinate.position position ∉ first.state.revealed := by + simpa [hfirstState, LazyRevealProbe.State.clearPending] using + hrevealed + have haddedEnsured : + Coordinate.position position ∈ added.state.ensured := by + simpa [added, hfirstState, LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.addPending] using hensured + by_cases haddedCompletable : DeferredCompletable table added + · simpa [added, continuation, DeferredResolution.addPending, + hnotRevealed, runDirectResolvedObserve] using + (ih () added remaining + (hfirstValid.addPending_of_completable + (.position position) candidate haddedCompletable) + haddedCompletable haddedEnsured).symm + · have haddedConsistent : added.ValuesConsistent := + hfirstValid.valuesConsistent.addPending (.position position) + candidate + have hfirstStarts : StartTableAgrees first.state table := + startTableAgrees_of_deferredCompletable hfirstCompletable + have haddedStarts : StartTableAgrees added.state table := by + exact hfirstStarts + calc + _ = evalDist (pure true : ProbComp Bool) := by + simpa [added, hnotRevealed, runDirectResolvedObserve] using + evalDist_runDirectResolvedObserve_eq_true_of_not_completable_auto + (observe := observe) + added remaining table (next ()) haddedConsistent haddedStarts + haddedCompletable + _ = _ := by + symm + exact + evalDist_resolveDeferredPositionValue_then_runDirectResolvedObserve_eq_true_of_not_completable_auto + position added remaining table (next ()) haddedConsistent + haddedStarts haddedCompletable + _ = evalDist ((do + let first ← resolveDeferredPositionValue position context + match first with + | none => (pure none : ProbComp (Option DeferredResolution)) + | some first => + resolveDeferredPositionValue position + { first.toDeferredContext with + state := first.state.addPending (.position position) + candidate }) >>= continuation) := by + simp only [bind_assoc] + apply congrArg evalDist + apply bind_congr + intro first + cases first <;> rfl + _ = evalDist (resolveDeferredPositionValue position nextContext >>= + continuation) := by + dsimp only [nextContext] + exact congrArg evalDist (congrArg (fun resolver => resolver >>= continuation) + (resolveDeferredPositionValue_then_addPending_self_resolve position + context candidate)) + _ = _ := by + have hnextConsistent : nextContext.ValuesConsistent := + hvalid.valuesConsistent.addPending (.position position) candidate + have hstarts : StartTableAgrees context.state table := + startTableAgrees_of_deferredCompletable hcompletable + have hnextStarts : StartTableAgrees nextContext.state table := by + exact hstarts + have hnextEnsured : + Coordinate.position position ∈ nextContext.state.ensured := hensured + by_cases hnextCompletable : DeferredCompletable table nextContext + · simpa [nextContext, continuation, hrevealed, + runDirectResolvedObserve] using + ih () nextContext remaining + (hvalid.addPending_of_completable (.position position) candidate + hnextCompletable) + hnextCompletable hnextEnsured + · calc + _ = evalDist (pure true : ProbComp Bool) := + evalDist_resolveDeferredPositionValue_then_runDirectResolvedObserve_eq_true_of_not_completable_auto + position nextContext remaining table (next ()) hnextConsistent + hnextStarts hnextCompletable + _ = _ := by + symm + simpa [nextContext, hrevealed, runDirectResolvedObserve] using + evalDist_runDirectResolvedObserve_eq_true_of_not_completable_auto + (observe := observe) + nextContext remaining table (next ()) hnextConsistent hnextStarts + hnextCompletable + · let nextContext : DeferredContext := + { context with state := context.state.addPending coordinate candidate } + by_cases hnextCompletable : DeferredCompletable table nextContext + · calc + _ = evalDist (resolveDeferredPositionValue position nextContext >>= + fun resolved => + match resolved with + | none => pure true + | some resolved => + runDirectResolvedFromTable resolved.toDeferredContext remaining table + (next ()) >>= + finishObserve observe) := by + dsimp only [nextContext] + rw [resolveDeferredPositionValue_addPending_of_ne position context + coordinate candidate heq] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hstate := resolveDeferredPositionValue_state_eq_clearPending + position context resolved hresolved + have hnotRevealed : coordinate ∉ resolved.state.revealed := by + simpa [hstate, LazyRevealProbe.State.clearPending] using hrevealed + simp [DeferredResolution.addPending, hnotRevealed] + _ = _ := by + simpa [nextContext, hrevealed, runDirectResolvedObserve] using + ih () nextContext remaining + (hvalid.addPending_of_completable coordinate candidate + hnextCompletable) + hnextCompletable (by exact hensured) + · have hnextConsistent : nextContext.ValuesConsistent := + hvalid.valuesConsistent.addPending coordinate candidate + have hstarts : StartTableAgrees context.state table := + startTableAgrees_of_deferredCompletable hcompletable + have hnextStarts : StartTableAgrees nextContext.state table := by + exact hstarts + calc + _ = evalDist (resolveDeferredPositionValue position nextContext >>= + fun resolved => + match resolved with + | none => pure true + | some resolved => + runDirectResolvedFromTable resolved.toDeferredContext remaining table + (next ()) >>= + finishObserve observe) := by + dsimp only [nextContext] + rw [resolveDeferredPositionValue_addPending_of_ne position context + coordinate candidate heq] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hstate := resolveDeferredPositionValue_state_eq_clearPending + position context resolved hresolved + have hnotRevealed : coordinate ∉ resolved.state.revealed := by + simpa [hstate, LazyRevealProbe.State.clearPending] using hrevealed + simp [DeferredResolution.addPending, hnotRevealed] + _ = evalDist (pure true : ProbComp Bool) := by + calc + _ = evalDist (resolveDeferredPositionValue position nextContext >>= + fun _ => pure true) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hresolvedNotCompletable : + ¬DeferredCompletable table resolved.toDeferredContext := by + intro hresolvedCompletable + obtain ⟨completion, hcompletion⟩ := hresolvedCompletable + have hback := + (deferredCompletion_resolveDeferredPositionValue_iff position + resolved hnextConsistent hresolved completion).mp hcompletion + exact hnextCompletable ⟨completion, hback.1⟩ + exact + evalDist_runDirectResolvedObserve_eq_true_of_not_completable_auto + resolved.toDeferredContext remaining table (next ()) + (hnextConsistent.of_resolveDeferredPositionValue position + resolved hresolved) + (hnextStarts.of_state_values_eq + (resolveDeferredPositionValue_preserves_state_values position + nextContext resolved hresolved)) + hresolvedNotCompletable + _ = _ := + OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolveDeferredPositionValue position nextContext) (by + simp [resolveDeferredPositionValue, + LazyRevealProbe.sampleHashOutput]) + (pure true) + _ = _ := by + symm + simpa [nextContext, hrevealed, runDirectResolvedObserve] using + evalDist_runDirectResolvedObserve_eq_true_of_not_completable_auto + (observe := observe) + nextContext remaining table (next ()) hnextConsistent hnextStarts + hnextCompletable + | peek coordinate => + unfold runDirectResolvedObserve + simp_rw [runDirectResolvedFromTable_peek_query_bind] + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runDirectResolvedFromTable resolved.toDeferredContext fuel table + (next (context.state.values coordinate)) >>= + finishObserve observe) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hvalues := resolveDeferredPositionValue_preserves_state_values position + context resolved hresolved + simp [hvalues] + _ = _ := ih (context.state.values coordinate) context fuel hvalid hcompletable + hensured + | publish coordinate => + unfold runDirectResolvedObserve + simp_rw [runDirectResolvedFromTable_publish_query_bind] + calc + _ = evalDist (resolveDeferredPositionValue position + { context with state := context.state.publish coordinate } >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runDirectResolvedFromTable resolved.toDeferredContext fuel table (next ()) >>= + finishObserve observe) := by + rw [resolveDeferredPositionValue_publish] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply congrArg evalDist + apply bind_congr + intro resolved + cases resolved <;> rfl + _ = _ := ih () { context with state := context.state.publish coordinate } fuel + (hvalid.publish coordinate) (hcompletable.publish coordinate) hensured + | reveal coordinate => + unfold runDirectResolvedObserve + simp_rw [runDirectResolvedFromTable_reveal_query_bind] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hclean := hcompletable.not_hitAt_chainStart index + cases hstate : context.state.values index.coordinate with + | some output => + have houtput : output = table index := hstarts index output hstate + subst output + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runDirectResolvedObserve observe resolved.toDeferredContext fuel table + (next (table index))) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hvalues := resolveDeferredPositionValue_preserves_state_values + position context resolved hresolved + have hcached : resolved.state.values index.coordinate = + some (table index) := by simpa [hvalues] using hstate + simp only [show resolved.state.values + (.chainStart lay tree leafIdx chainIdx) = some (table index) by + simpa [index, OtsSecretIndex.coordinate] using hcached] + unfold runDirectResolvedObserve + rfl + _ = evalDist (runDirectResolvedObserve observe context fuel table + (next (table index))) := + ih (table index) context fuel hvalid hcompletable hensured + _ = _ := by + have hstate' : context.state.values + (.chainStart lay tree leafIdx chainIdx) = + some (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + simpa [index, OtsSecretIndex.coordinate] using hstate + unfold runDirectResolvedObserve + rw [hstate'] + | none => + let continuation : Option RevealedResolution → ProbComp Bool + | none => pure true + | some resolved => + runDirectResolvedObserve observe + { state := (context.state.clearPending (.position position)).materialize + index.coordinate resolved.output + values := resolved.context.values } + fuel table (next resolved.output) + calc + _ = evalDist (resolvePositionThenChainStart position table index context >>= + continuation) := by + unfold resolvePositionThenChainStart continuation + simp only [bind_assoc] + apply evalDist_bind_congr + intro positionResult hpositionResult + cases positionResult with + | none => rfl + | some positionResult => + have hpositionState := + resolveDeferredPositionValue_state_eq_clearPending position context + positionResult hpositionResult + have hpositionValues := + resolveDeferredPositionValue_preserves_state_values position context + positionResult hpositionResult + have hpositionStarts := hstarts.of_state_values_eq hpositionValues + have hpositionClean : + ¬positionResult.state.hitAt index.coordinate (table index) := by + rw [hpositionState] + exact (hitAt_clearPending_of_ne context.state (.position position) + index.coordinate (table index) (by cases index <;> simp + [OtsSecretIndex.coordinate])).not.mpr hclean + have hmissing : positionResult.state.values index.coordinate = none := by + simpa [hpositionValues] using hstate + simp only + rw [show positionResult.state.values + (.chainStart lay tree leafIdx chainIdx) = none by + simpa [index, OtsSecretIndex.coordinate] using hmissing] + simp only + rw [if_neg (show ¬positionResult.state.hitAt + (.chainStart lay tree leafIdx chainIdx) (table index) by + simpa [index, OtsSecretIndex.coordinate] using hpositionClean)] + rw [resolveDeferredChainStart_of_agrees table index + positionResult.toDeferredContext hpositionStarts hpositionClean] + simp only [pure_bind] + rw [hpositionState] + rfl + _ = evalDist (resolveChainStartThenPosition position table index context >>= + continuation) := + evalDist_bind_eq_of_evalDist_eq + (evalDist_resolvePosition_chainStart_comm position table index context + hcompletable) + continuation + _ = evalDist (match resolveDeferredChainStart table index context with + | none => pure true + | some revealedResult => + resolveDeferredPositionValue position + revealedResult.toDeferredContext >>= + fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runDirectResolvedObserve observe + { state := (context.state.clearPending + (.position position)).materialize + index.coordinate revealedResult.output + values := targetResult.values } + fuel table (next revealedResult.output)) := by + unfold resolveChainStartThenPosition continuation + cases resolveDeferredChainStart table index context with + | none => rfl + | some revealedResult => + simp only [bind_assoc] + apply congrArg evalDist + apply bind_congr + intro targetResult + cases targetResult <;> rfl + _ = evalDist (match resolveDeferredChainStart table index context with + | none => pure true + | some revealedResult => + runDirectResolvedObserve observe + (materializeResolvedChainStart context index revealedResult) + fuel table (next revealedResult.output)) := by + cases hrevealedResult : resolveDeferredChainStart table index context with + | none => rfl + | some revealedResult => + have htransport := + evalDist_resolveDeferredPositionValue_after_materialized_chainStart_runDirectResolvedObserve + position index context revealedResult table fuel + (next revealedResult.output) observe hvalid hcompletable + hrevealedResult + have hdeferredValues := + resolveDeferredChainStart_deferred_values_eq table index context + revealedResult hrevealedResult + have hrevealedCompletable := + hcompletable.of_resolveDeferredChainStart index revealedResult + hrevealedResult + have hstateValues := resolveDeferredChainStart_state_values_eq table index + context revealedResult hrevealedResult + have houtput := resolveDeferredChainStart_output_of_agrees table index + context revealedResult hstarts hrevealedResult + have hmaterializedValid : + (materializeResolvedChainStart context index revealedResult).Valid := by + rw [materializeResolvedChainStart, hdeferredValues] + exact hvalid.materialize_chainStart lay tree leafIdx chainIdx + revealedResult.output + have hmaterializedCompletable : DeferredCompletable table + (materializeResolvedChainStart context index revealedResult) := by + obtain ⟨completion, hcompletion⟩ := hrevealedCompletable + refine ⟨completion, ?_⟩ + exact (deferredCompletion_materializeResolvedChainStart_iff index + revealedResult hstarts houtput hstateValues hdeferredValues + (resolveDeferredChainStart_pending_eq table index context + revealedResult hrevealedResult)).2 hcompletion + have hmaterializedEnsured : Coordinate.position position ∈ + (materializeResolvedChainStart context index + revealedResult).state.ensured := by + change Coordinate.position position ∈ + insert index.coordinate context.state.ensured + exact Finset.mem_insert.mpr (Or.inr hensured) + exact htransport.trans + (ih revealedResult.output + (materializeResolvedChainStart context index revealedResult) fuel + hmaterializedValid hmaterializedCompletable + hmaterializedEnsured) + _ = _ := by + rw [resolveDeferredChainStart_of_agrees table index context hstarts hclean] + have hstate' : context.state.values + (.chainStart lay tree leafIdx chainIdx) = none := by + simpa [index, OtsSecretIndex.coordinate] using hstate + have hclean' : ¬context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + simpa [index, OtsSecretIndex.coordinate] using hclean + unfold runDirectResolvedObserve materializeResolvedChainStart + rw [hstate'] + simp only + rw [if_neg hclean'] + rfl + | position revealed => + cases hstate : context.state.values (.position revealed) with + | some output => + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runDirectResolvedObserve observe resolved.toDeferredContext fuel table + (next output)) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hvalues := resolveDeferredPositionValue_preserves_state_values + position context resolved hresolved + have hcached : resolved.state.values (.position revealed) = + some output := by simpa [hvalues] using hstate + simp only [hcached] + unfold runDirectResolvedObserve + rfl + _ = evalDist (runDirectResolvedObserve observe context fuel table + (next output)) := ih output context fuel hvalid hcompletable hensured + _ = _ := by rfl + | none => + let continuation : Option RevealedResolution → ProbComp Bool + | none => pure true + | some resolved => + runDirectResolvedObserve observe + { state := (context.state.clearPending (.position position)).materialize + (.position revealed) resolved.output + values := resolved.context.values } + fuel table (next resolved.output) + calc + _ = evalDist (resolvePositionValuesInOrder position revealed context >>= + continuation) := by + unfold resolvePositionValuesInOrder continuation + simp only [bind_assoc] + apply evalDist_bind_congr + intro positionResult hpositionResult + cases positionResult with + | none => rfl + | some positionResult => + have hpositionState := + resolveDeferredPositionValue_state_eq_clearPending position context + positionResult hpositionResult + have hpositionValues := + resolveDeferredPositionValue_preserves_state_values position context + positionResult hpositionResult + have hmissing : positionResult.state.values (.position revealed) = none := + by simpa [hpositionValues] using hstate + simp only [hmissing, bind_assoc] + apply evalDist_bind_congr + intro revealedResult _hrevealedResult + cases revealedResult with + | none => rfl + | some revealedResult => + simp only [pure_bind] + rw [hpositionState] + rfl + _ = evalDist (resolvePositionValuesSwapped position revealed context >>= + continuation) := by + apply evalDist_bind_eq_of_evalDist_eq + by_cases heq : position = revealed + · subst revealed + exact evalDist_resolvePositionValues_comm_self position context + · exact evalDist_resolvePositionValues_comm_of_ne position revealed + context heq + _ = evalDist (resolveDeferredPositionValue revealed context >>= + fun revealedResult => + match revealedResult with + | none => pure true + | some revealedResult => + resolveDeferredPositionValue position + revealedResult.toDeferredContext >>= + fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runDirectResolvedObserve observe + { state := (context.state.clearPending + (.position position)).materialize + (.position revealed) revealedResult.output + values := targetResult.values } + fuel table (next revealedResult.output)) := by + unfold resolvePositionValuesSwapped continuation + simp only [bind_assoc] + apply congrArg evalDist + apply bind_congr + intro revealedResult + cases revealedResult with + | none => rfl + | some revealedResult => + simp only [bind_assoc] + apply bind_congr + intro targetResult + cases targetResult <;> rfl + _ = evalDist (resolveDeferredPositionValue revealed context >>= + fun revealedResult => + match revealedResult with + | none => pure true + | some revealedResult => + runDirectResolvedObserve observe + (materializeResolvedPosition context revealed revealedResult) + fuel table (next revealedResult.output)) := by + apply evalDist_bind_congr + intro revealedResult hrevealedResult + cases revealedResult with + | none => rfl + | some revealedResult => + have htransport := + evalDist_resolveDeferredPositionValue_after_materialized_positionValue_runDirectResolvedObserve + position revealed context revealedResult table fuel + (next revealedResult.output) observe hvalid hcompletable + hrevealedResult + have hrevealedValid := hvalid.of_resolveDeferredPositionValue revealed + revealedResult hrevealedResult + have hstateValues := + resolveDeferredPositionValue_preserves_state_values revealed context + revealedResult hrevealedResult + have hpending := resolveDeferredPositionValue_pending revealed context + revealedResult hrevealedResult + have hresolved := resolveDeferredPositionValue_resolves revealed context + revealedResult hrevealedResult + have hmaterializedValid := hvalid.materializeResolvedPosition_of revealed + revealedResult hrevealedValid hstateValues hresolved + have hrevealedCompletable := + hcompletable.of_resolveDeferredPositionValue hvalid revealed + revealedResult hrevealedResult + have hmaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition context revealed revealedResult) := by + obtain ⟨completion, hcompletion⟩ := hrevealedCompletable + exact ⟨completion, + (deferredCompletion_materializeResolvedPosition_iff revealed + revealedResult hstateValues hpending hresolved).2 hcompletion⟩ + have hmaterializedEnsured : Coordinate.position position ∈ + (materializeResolvedPosition context revealed + revealedResult).state.ensured := by + change Coordinate.position position ∈ + insert (.position revealed) context.state.ensured + exact Finset.mem_insert.mpr (Or.inr hensured) + exact htransport.trans + (ih revealedResult.output + (materializeResolvedPosition context revealed revealedResult) fuel + hmaterializedValid hmaterializedCompletable + hmaterializedEnsured) + _ = _ := by + simp only [bind_assoc] + apply congrArg evalDist + apply bind_congr + intro revealedResult + cases revealedResult <;> rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedDirectRecursive.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedDirectRecursive.lean new file mode 100644 index 00000000..2d948317 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedDirectRecursive.lean @@ -0,0 +1,1956 @@ +import SphincsSecurity.Proof.OtsProbeResolvedDirect +import SphincsSecurity.Proof.OtsProbeResolvedPrivateObserver + +/-! Erasure of the recursive work performed by one structural reveal. -/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def DeferredAbsentOn (coordinates : List Coordinate) (context : DeferredContext) : Prop := + ∀ position : Position, Coordinate.position position ∈ coordinates → + context.state.values (.position position) = none → context.values position = none + +set_option maxRecDepth 100000 in +theorem finalizeResolvedCoordinates_projects_to_clean_of_absent + (coordinates : List Coordinate) (context : DeferredContext) + (table : OtsSecretIndex → HashOutput) + (hnodup : coordinates.Nodup) (habsent : DeferredAbsentOn coordinates context) : + (fun result => result.map fun finalContext => (finalContext.state, table)) <$> + finalizeResolvedCoordinates coordinates context table = + finalizeCleanFromTable coordinates context.state table := by + induction coordinates generalizing context with + | nil => simp [finalizeResolvedCoordinates, finalizeCleanFromTable] + | cons coordinate remaining ih => + obtain ⟨hnotMem, htailNodup⟩ := List.nodup_cons.mp hnodup + cases hstate : context.state.values coordinate with + | some output => + rw [finalizeResolvedCoordinates, finalizeCleanFromTable.eq_def] + simp only [hstate] + apply ih { context with state := context.state.clearPending coordinate } + htailNodup + intro position hmem hmissing + apply habsent position (List.mem_cons_of_mem coordinate hmem) + exact hmissing + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + have hstate' : context.state.values index.coordinate = none := by + simpa [index, OtsSecretIndex.coordinate] using hstate + rw [finalizeResolvedCoordinates, finalizeCleanFromTable.eq_def] + simp only [hstate] + rw [resolveDeferredChainStart_of_missing table index context hstate'] + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) (table index) + · simp [index, OtsSecretIndex.coordinate, hhit] + · simp only [index, OtsSecretIndex.coordinate, hhit, ↓reduceIte, + map_eq_bind_pure_comp, pure_bind] + rw [clearPending_complete_self] + simpa only [map_eq_bind_pure_comp] using ih + { state := context.state.complete (.chainStart lay tree leafIdx chainIdx) + (table index) + values := context.values } + htailNodup (by + intro position hmem hmissing + apply habsent position (List.mem_cons_of_mem _ hmem) + exact hmissing) + | position position => + have hvalue : context.values position = none := + habsent position (by simp) hstate + rw [finalizeResolvedCoordinates, finalizeCleanFromTable.eq_def] + simp only [hstate] + rw [resolveDeferredPositionValue_fresh position context hstate hvalue] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] + · simp only [hhit, ↓reduceIte, pure_bind] + rw [clearPending_complete_self] + simpa only [map_eq_bind_pure_comp] using ih + { state := context.state.complete (.position position) output + values := context.values.install position output } + htailNodup (by + intro other hmem hmissing + have hne : other ≠ position := by + intro heq + subst other + exact hnotMem hmem + have hmissingOriginal : + context.state.values (.position other) = none := by + simpa [LazyRevealProbe.State.complete, Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by + simpa using hne] using hmissing + simp [DeferredStructuralValues.install, hne, + habsent other (List.mem_cons_of_mem _ hmem) hmissingOriginal]) + +theorem directDeferredContext_absentOn + (coordinates : List Coordinate) (state : LazyRevealProbe.State Coordinate) : + DeferredAbsentOn coordinates (directDeferredContext state) := by + intro position _hmem hvalue + simpa [directDeferredContext, directDeferredValues] using hvalue + +theorem finishResolvedRun_direct_projects_to_clean + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (value : α) (table : OtsSecretIndex → HashOutput) + (hcompletable : DeferredCompletable table (directDeferredContext state)) : + projectResolvedRunResult <$> + finishResolvedRun + (some ⟨directDeferredContext state, fuel, value, table⟩) = + finishCleanRunFromTable (some ⟨state, fuel, value, table⟩) := by + simp only [finishResolvedRun, hcompletable, ↓reduceIte, finishCleanRunFromTable] + simp only [show (directDeferredContext state).state = state from rfl] + have hfinal := finalizeResolvedCoordinates_projects_to_clean_of_absent + state.coordinates.toList (directDeferredContext state) table state.coordinates.nodup_toList + (directDeferredContext_absentOn state.coordinates.toList state) + have hfinal' : + (fun result => result.map fun finalContext => (finalContext.state, table)) <$> + finalizeResolvedCoordinates state.coordinates.toList + (directDeferredContext state) table = + finalizeCleanFromTable state.coordinates.toList state table := by + rw [show (directDeferredContext state).state = state from rfl] at hfinal + exact hfinal + rw [← hfinal'] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro finalized + cases finalized <;> simp [projectResolvedRunResult] + +theorem evalDist_finishResolvedRunIsNone_eq_finishDirectRunIsNone + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (value : α) (table : OtsSecretIndex → HashOutput) + (hcompletable : DeferredCompletable table (directDeferredContext state)) : + evalDist (finishResolvedRunIsNone + (some ⟨directDeferredContext state, fuel, value, table⟩)) = + evalDist (finishDirectRunIsNone + (some ⟨directDeferredContext state, fuel, value, table⟩)) := by + have hprojection := finishResolvedRun_direct_projects_to_clean state fuel value table + hcompletable + unfold finishResolvedRunIsNone finishDirectRunIsNone finishCleanRunIsNone + simp only [projectResolvedRunResult] + rw [show (directDeferredContext state).state = state from rfl] + rw [← hprojection] + rw [Functor.map_map] + apply congrArg evalDist + apply congrArg (fun f : Option (ResolvedRunResult α) → Bool => + f <$> finishResolvedRun + (some ⟨directDeferredContext state, fuel, value, table⟩)) + funext result + cases result <;> rfl + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_runResolvedObserve_eq_of_synchronized + (table : OtsSecretIndex → HashOutput) (position : Position) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + (left right : DeferredContext) (fuel : Nat) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) + (hrevealed : left.state.revealed = right.state.revealed) : + evalDist (do + let resolved ← resolveDeferredPositionValue position left + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (do + let resolved ← resolveDeferredPositionValue position right + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) := by + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hresolved := relTriple_resolveDeferredPositionValue_of_finalizationViewEq table position + left right hview hleftValid hrightValid hleftCompletable + have hresolvedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolved + (fun result => result ∈ support (resolveDeferredPositionValue position left)) + (fun result hresult => hresult) + have hresolvedBoth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hresolvedLeft + apply evalDist_eq_of_relTriple_eqRel + apply relTriple_bind hresolvedBoth + intro leftResolved rightResolved hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResolved with + | none => + cases rightResolved with + | none => exact relTriple_pure_pure rfl + | some rightResolved => simp [FinalizationResolutionEq] at hrelation + | some leftResolved => + cases rightResolved with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResolved => + apply relTriple_eqRel_of_evalDist_eq + apply evalDist_runResolvedObserve_eq_of_finalizationSynchronized computation + · exact ⟨hrelation.2.1, hrelation.2.2.1, hrelation.2.2.2.1, + hrelation.2.2.2.2⟩ + · rw [resolveDeferredPositionValue_preserves_state_values position left leftResolved + hleftSupport, + resolveDeferredPositionValue_preserves_state_values position right rightResolved + hrightSupport] + exact hvalues + · rw [resolveDeferredPositionValue_state_eq_clearPending position left leftResolved + hleftSupport, + resolveDeferredPositionValue_state_eq_clearPending position right rightResolved + hrightSupport] + simpa [LazyRevealProbe.State.clearPending] using hrevealed + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_runResolvedObserve_any + (position : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) := by + let ensured : DeferredContext := + { context with state := context.state.ensure (.position position) } + have hensuredValid : ensured.Valid := hvalid.ensure (.position position) + have hensuredCompletable : DeferredCompletable table ensured := + hcompletable.ensure (.position position) + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hensuredStarts : StartTableAgrees ensured.state table := + hstarts.ensure (.position position) + have hview : FinalizationViewEq table context ensured := + finalizationViewEq_of_deferredCompletion_iff hvalid hensuredValid hstarts hensuredStarts rfl + hcompletable (fun _ => Iff.rfl) + have hcontext : FinalizationContextEq table (some context) (some ensured) := + ⟨hview, hvalid, hensuredValid, hcompletable⟩ + have hcontextSymm : FinalizationContextEq table (some ensured) (some context) := + ⟨hview.symm, hensuredValid, hvalid, hensuredCompletable⟩ + calc + _ = evalDist (do + let resolved ← resolveDeferredPositionValue position ensured + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) := + evalDist_resolveDeferredPositionValue_then_runResolvedObserve_eq_of_synchronized + table position computation context ensured fuel hcontext rfl rfl + _ = evalDist (runResolvedObserve observe ensured fuel table computation) := + evalDist_resolveDeferredPositionValue_then_runResolvedObserve_auto + (observe := observe) position computation ensured fuel table hensuredValid + hensuredCompletable (by simp [ensured, LazyRevealProbe.State.ensure]) + _ = _ := + evalDist_runResolvedObserve_eq_of_finalizationSynchronized computation ensured context + fuel table hcontextSymm rfl rfl + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_runResolvedObserve_any_at + (position : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + [ObserverDooms table observe] [ObserverSynchronized table observe] + (hneutral : ObserverPositionNeutralAt table position observe) : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) := by + let ensured : DeferredContext := + { context with state := context.state.ensure (.position position) } + have hensuredValid : ensured.Valid := hvalid.ensure (.position position) + have hensuredCompletable : DeferredCompletable table ensured := + hcompletable.ensure (.position position) + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hensuredStarts : StartTableAgrees ensured.state table := + hstarts.ensure (.position position) + have hview : FinalizationViewEq table context ensured := + finalizationViewEq_of_deferredCompletion_iff hvalid hensuredValid hstarts hensuredStarts rfl + hcompletable (fun _ => Iff.rfl) + have hcontext : FinalizationContextEq table (some context) (some ensured) := + ⟨hview, hvalid, hensuredValid, hcompletable⟩ + have hcontextSymm : FinalizationContextEq table (some ensured) (some context) := + ⟨hview.symm, hensuredValid, hvalid, hensuredCompletable⟩ + calc + _ = evalDist (do + let resolved ← resolveDeferredPositionValue position ensured + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) := + evalDist_resolveDeferredPositionValue_then_runResolvedObserve_eq_of_synchronized + table position computation context ensured fuel hcontext rfl rfl + _ = evalDist (runResolvedObserve observe ensured fuel table computation) := + evalDist_resolveDeferredPositionValue_then_runResolvedObserve_auto_at + (observe := observe) position computation ensured fuel table hensuredValid + hensuredCompletable (by simp [ensured, LazyRevealProbe.State.ensure]) hneutral + _ = _ := + evalDist_runResolvedObserve_eq_of_finalizationSynchronized computation ensured context + fuel table hcontextSymm rfl rfl + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredChainPrefix_then_runResolvedObserve_any + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe], + context.Valid → DeferredCompletable table context → + evalDist (do + let resolved ← resolveDeferredChainPrefix table lay tree leafIdx chainIdx + steps hsteps context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) + | 0, hsteps, context, fuel, computation, observe, _hdooms, _hsynchronized, + _hposition, hvalid, hcompletable => by + simp only [resolveDeferredChainPrefix, pure_bind] + exact evalDist_resolveDeferredChainStart_then_runResolvedObserve table + ⟨lay, tree, leafIdx, chainIdx⟩ context fuel computation hvalid hcompletable + | steps + 1, hsteps, context, fuel, computation, observe, _hdooms, _hsynchronized, + _hposition, hvalid, hcompletable => by + rw [resolveDeferredChainPrefix] + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps + (by omega) context >>= fun previous => + match previous with + | none => pure true + | some previous => + runResolvedObserve observe previous.toDeferredContext fuel table computation) := by + apply evalDist_bind_congr + intro previous hprevious + cases previous with + | none => rfl + | some previous => + let position : Position := + .chain lay tree leafIdx chainIdx ⟨steps, by omega⟩ + have hpreviousValid := hvalid.of_resolveDeferredChainPrefix table lay tree + leafIdx chainIdx steps (by omega) previous hprevious + have hpreviousCompletable := + hcompletable.of_resolveDeferredChainPrefix hvalid hprevious + exact evalDist_resolveDeferredPositionValue_then_runResolvedObserve_any + (observe := observe) position computation previous.toDeferredContext fuel table + hpreviousValid hpreviousCompletable + _ = _ := + evalDist_resolveDeferredChainPrefix_then_runResolvedObserve_any table lay tree + leafIdx chainIdx steps (by omega) context fuel computation hvalid hcompletable + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredChains_then_runResolvedObserve_any + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + ∀ (chains : List ChainIndex) (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe], + context.Valid → DeferredCompletable table context → + evalDist (do + let resolved ← resolveDeferredChains table lay tree leafIdx chains context + match resolved with + | none => pure true + | some resolved => runResolvedObserve observe resolved fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) + | [], context, fuel, computation, observe, _hdooms, _hsynchronized, _hposition, + _hvalid, _hcompletable => by + simp [resolveDeferredChains] + | chainIdx :: remaining, context, fuel, computation, observe, _hdooms, _hsynchronized, + _hposition, hvalid, hcompletable => by + rw [resolveDeferredChains] + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredChainPrefix table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hresolvedValid := hvalid.of_resolveDeferredChainPrefix table lay tree + leafIdx chainIdx (chainLength - 1) (by omega) resolved hresolved + have hresolvedCompletable := + hcompletable.of_resolveDeferredChainPrefix hvalid hresolved + exact evalDist_resolveDeferredChains_then_runResolvedObserve_any table lay tree + leafIdx remaining resolved.toDeferredContext fuel computation hresolvedValid + hresolvedCompletable + _ = _ := + evalDist_resolveDeferredChainPrefix_then_runResolvedObserve_any table lay tree + leafIdx chainIdx (chainLength - 1) (by omega) context fuel computation hvalid + hcompletable + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredOtsLeaf_then_runResolvedObserve_any + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (do + let resolved ← resolveDeferredOtsLeaf table lay tree leafIdx context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) := by + rw [resolveDeferredOtsLeaf] + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) context >>= fun chains => + match chains with + | none => pure true + | some chains => runResolvedObserve observe chains fuel table computation) := by + apply evalDist_bind_congr + intro chains hchains + cases chains with + | none => rfl + | some chains => + have hchainsValid := hvalid.of_resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) chains hchains + have hchainsCompletable := hcompletable.of_resolveDeferredChains hvalid hchains + exact evalDist_resolveDeferredPositionValue_then_runResolvedObserve_any + (observe := observe) (.leaf lay tree leafIdx) computation chains fuel table + hchainsValid hchainsCompletable + _ = _ := evalDist_resolveDeferredChains_then_runResolvedObserve_any table lay tree + leafIdx (List.ofFn fun chainIdx : ChainIndex => chainIdx) context fuel computation + hvalid hcompletable + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredTreeNode_then_runResolvedObserve_any + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe], + context.Valid → DeferredCompletable table context → + evalDist (do + let resolved ← resolveDeferredTreeNode table lay tree level nodeIdx hlevel context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) + | 0, nodeIdx, hlevel, context, fuel, computation, observe, _hdooms, _hsynchronized, + _hposition, hvalid, hcompletable => + evalDist_resolveDeferredOtsLeaf_then_runResolvedObserve_any table lay tree + (leafOfNat nodeIdx) context fuel computation hvalid hcompletable + | level + 1, nodeIdx, hlevel, context, fuel, computation, observe, _hdooms, + _hsynchronized, _hposition, hvalid, hcompletable => by + rw [resolveDeferredTreeNode] + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredTreeNode table lay tree level (2 * nodeIdx) + (by omega) context >>= fun leftResult => + match leftResult with + | none => pure true + | some leftResult => + runResolvedObserve observe leftResult.toDeferredContext fuel table computation) := by + apply evalDist_bind_congr + intro leftResult hleft + cases leftResult with + | none => rfl + | some leftResult => + have hleftValid := hvalid.of_resolveDeferredTreeNode table lay tree level + (2 * nodeIdx) (by omega) leftResult hleft + have hleftCompletable := + hcompletable.of_resolveDeferredTreeNode hvalid hleft + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredTreeNode table lay tree level + (2 * nodeIdx + 1) (by omega) leftResult.toDeferredContext >>= + fun rightResult => + match rightResult with + | none => pure true + | some rightResult => + runResolvedObserve observe rightResult.toDeferredContext fuel table + computation) := by + apply evalDist_bind_congr + intro rightResult hright + cases rightResult with + | none => rfl + | some rightResult => + have hrightValid := hleftValid.of_resolveDeferredTreeNode table lay tree + level (2 * nodeIdx + 1) (by omega) rightResult hright + have hrightCompletable := + hleftCompletable.of_resolveDeferredTreeNode hleftValid hright + exact evalDist_resolveDeferredPositionValue_then_runResolvedObserve_any + (observe := observe) + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) computation + rightResult.toDeferredContext fuel table hrightValid + hrightCompletable + _ = _ := + evalDist_resolveDeferredTreeNode_then_runResolvedObserve_any table lay tree + level (2 * nodeIdx + 1) (by omega) leftResult.toDeferredContext fuel + computation hleftValid hleftCompletable + _ = _ := + evalDist_resolveDeferredTreeNode_then_runResolvedObserve_any table lay tree level + (2 * nodeIdx) (by omega) context fuel computation hvalid hcompletable + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredReveal_then_runResolvedObserve_any + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (do + let resolved ← resolveDeferredReveal table position context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) := by + cases position with + | chain lay tree leafIdx chainIdx step => + have hsteps : step.val + 1 ≤ chainLength - 1 := by + have := step.isLt + omega + rw [resolveDeferredReveal, if_pos (by simp [ResolvableOtsPosition])] + exact evalDist_resolveDeferredChainPrefix_then_runResolvedObserve_any table lay tree + leafIdx chainIdx (step.val + 1) hsteps context fuel computation hvalid hcompletable + | leaf lay tree leafIdx => + rw [resolveDeferredReveal, if_pos (by simp [ResolvableOtsPosition])] + exact evalDist_resolveDeferredOtsLeaf_then_runResolvedObserve_any table lay tree + leafIdx context fuel computation hvalid hcompletable + | node lay tree level nodeIdx => + by_cases hresolvable : ResolvableOtsPosition (.node lay tree level nodeIdx) + · have hlevel : level.val + 1 ≤ maxLayerHeight := by + have := level.isLt + omega + rw [resolveDeferredReveal, if_pos hresolvable] + exact evalDist_resolveDeferredTreeNode_then_runResolvedObserve_any table lay tree + (level.val + 1) nodeIdx hlevel context fuel computation hvalid hcompletable + · rw [resolveDeferredReveal, if_neg hresolvable] + exact evalDist_resolveDeferredPositionValue_then_runResolvedObserve_any + (observe := observe) (.node lay tree level nodeIdx) computation context fuel table + hvalid hcompletable + | ftsLeaf index tree leafIdx => + rw [resolveDeferredReveal, if_neg (by simp [ResolvableOtsPosition])] + exact evalDist_resolveDeferredPositionValue_then_runResolvedObserve_any + (observe := observe) (.ftsLeaf index tree leafIdx) computation context fuel table + hvalid hcompletable + | ftsNode index tree level nodeIdx => + rw [resolveDeferredReveal, if_neg (by simp [ResolvableOtsPosition])] + exact evalDist_resolveDeferredPositionValue_then_runResolvedObserve_any + (observe := observe) (.ftsNode index tree level nodeIdx) computation context fuel table + hvalid hcompletable + | ftsRoots index => + rw [resolveDeferredReveal, if_neg (by simp [ResolvableOtsPosition])] + exact evalDist_resolveDeferredPositionValue_then_runResolvedObserve_any + (observe := observe) (.ftsRoots index) computation context fuel table hvalid + hcompletable + +set_option maxRecDepth 100000 in +theorem finalizationViewEq_materializeResolvedPositionValue + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (position : Position) (result : DeferredResolution) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) + (hcompletable : DeferredCompletable table + (materializeResolvedPosition context position result)) : + FinalizationViewEq table + (materializeResolvedPosition context position result) + result.toDeferredContext := by + have hresultValid := hvalid.of_resolveDeferredPositionValue position result hresult + have hstateValues := resolveDeferredPositionValue_preserves_state_values position context + result hresult + have hpending := resolveDeferredPositionValue_pending position context result hresult + have hresolved := resolveDeferredPositionValue_resolves position context result hresult + have hvalueEq : resolvedCompletionValue table + (materializeResolvedPosition context position result) = + resolvedCompletionValue table result.toDeferredContext := by + funext coordinate + cases coordinate with + | chainStart => rfl + | position other => + exact congrFun + (materializeResolvedPosition_positionValue_eq context position result hstateValues + hresolved) other + apply finalizationViewEq_of_deferredCompletion_iff + · exact hvalid.materializeResolvedPosition_of position result hresultValid hstateValues + hresolved + · exact hresultValid + · simpa [materializeResolvedPosition] using + hstarts.materialize_position position result.output + · exact hstarts.of_state_values_eq hstateValues + · exact hvalueEq + · exact hcompletable + · intro completion + exact deferredCompletion_materializeResolvedPosition_iff position result hstateValues + hpending hresolved + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_after_materialized_positionValue_observe + (observe : DeferredContext → ProbComp Bool) + (target revealed : Position) (context : DeferredContext) + (revealedResult : DeferredResolution) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hrevealed : some revealedResult ∈ support + (resolveDeferredPositionValue revealed context)) : + evalDist (resolveDeferredPositionValue target revealedResult.toDeferredContext >>= + fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + observe + { state := (context.state.clearPending (.position target)).materialize + (.position revealed) revealedResult.output + values := targetResult.values }) = + evalDist (resolveDeferredPositionValue target + (materializeResolvedPosition context revealed revealedResult) >>= fun targetResult => + match targetResult with + | none => pure true + | some targetResult => observe targetResult.toDeferredContext) := by + let materialized := materializeResolvedPosition context revealed revealedResult + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hrevealedValid := hvalid.of_resolveDeferredPositionValue revealed revealedResult + hrevealed + have hstateValues := resolveDeferredPositionValue_preserves_state_values revealed context + revealedResult hrevealed + have hpending := resolveDeferredPositionValue_pending revealed context revealedResult + hrevealed + have hresolved := resolveDeferredPositionValue_resolves revealed context revealedResult + hrevealed + have hmaterializedValid := hvalid.materializeResolvedPosition_of revealed revealedResult + hrevealedValid hstateValues hresolved + have hrevealedCompletable := + hcompletable.of_resolveDeferredPositionValue hvalid revealed revealedResult hrevealed + have hmaterializedCompletable : DeferredCompletable table materialized := by + obtain ⟨completion, hcompletion⟩ := hrevealedCompletable + exact ⟨completion, + (deferredCompletion_materializeResolvedPosition_iff revealed revealedResult hstateValues + hpending hresolved).2 hcompletion⟩ + have hview : FinalizationViewEq table materialized revealedResult.toDeferredContext := + finalizationViewEq_materializeResolvedPositionValue revealed revealedResult hvalid hstarts + hrevealed hmaterializedCompletable + have hbase := relTriple_resolveDeferredPositionValue_of_finalizationViewEq table target + revealedResult.toDeferredContext materialized hview.symm hrevealedValid + hmaterializedValid hrevealedCompletable + have hleft := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (resolveDeferredPositionValue target revealedResult.toDeferredContext)) + (fun result hresult => hresult) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply evalDist_eq_of_relTriple_eqRel + apply relTriple_bind hboth + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure rfl + | some rightResult => simp [FinalizationResolutionEq] at hrelation + | some leftResult => + cases rightResult with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResult => + simp only + have hvalues : leftResult.values = rightResult.values := + resolveDeferredPositionValue_values_eq_of_values_eq target + revealedResult.toDeferredContext materialized leftResult rightResult + hleftSupport hrightSupport (by rfl) hrelation.1 + have hrightState := resolveDeferredPositionValue_state_eq_clearPending target + materialized rightResult hrightSupport + have hstate : + (context.state.clearPending (.position target)).materialize + (.position revealed) revealedResult.output = rightResult.state := by + rw [hrightState] + exact clearPending_materialize_comm context.state (.position target) + (.position revealed) revealedResult.output + apply relTriple_eqRel_of_evalDist_eq + rw [hstate, hvalues] + +theorem evalDist_resolveDeferredPositionValue_after_materialized_positionValue_runResolvedObserve + (target revealed : Position) (context : DeferredContext) + (revealedResult : DeferredResolution) (table : OtsSecretIndex → HashOutput) + (fuel : Nat) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hrevealed : some revealedResult ∈ support + (resolveDeferredPositionValue revealed context)) : + evalDist (resolveDeferredPositionValue target revealedResult.toDeferredContext >>= + fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runResolvedObserve observe + { state := (context.state.clearPending (.position target)).materialize + (.position revealed) revealedResult.output + values := targetResult.values } + fuel table computation) = + evalDist (resolveDeferredPositionValue target + (materializeResolvedPosition context revealed revealedResult) >>= fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runResolvedObserve observe targetResult.toDeferredContext fuel table computation) := + evalDist_resolveDeferredPositionValue_after_materialized_positionValue_observe + (fun nextContext => runResolvedObserve observe nextContext fuel table computation) + target revealed context revealedResult table hvalid hcompletable hrevealed + +noncomputable def directPositionContinuationObserve + (table : OtsSecretIndex → HashOutput) (revealed : Position) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (_value : Unit) : ProbComp Bool := by + classical + exact if context.Valid ∧ DeferredCompletable table context then do + let resolved ← resolveDeferredPositionValue revealed context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe + (materializeResolvedPosition context revealed resolved) fuel table + (next resolved.output) + else pure true + +instance directPositionContinuationObserve_observerDooms + (table : OtsSecretIndex → HashOutput) (revealed : Position) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) + (observe : DeferredContext → Nat → α → ProbComp Bool) : + ObserverDooms table (directPositionContinuationObserve table revealed next observe) where + eq_true context fuel value _hconsistent _hstarts hdoomed := by + simp [directPositionContinuationObserve, hdoomed] + +set_option maxRecDepth 100000 in +instance directPositionContinuationObserve_observerSynchronized + (table : OtsSecretIndex → HashOutput) (revealed : Position) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) + (observe : DeferredContext → Nat → α → ProbComp Bool) + [ObserverDooms table observe] [ObserverSynchronized table observe] : + ObserverSynchronized table + (directPositionContinuationObserve table revealed next observe) where + eq_of_synchronized left right fuel value hcontext hvalues hrevealed := by + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hrightCompletable : DeferredCompletable table right := by + rcases hleftCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, (hview.deferredCompletion_iff completion).mp hcompletion⟩ + have hleftGuard : left.Valid ∧ DeferredCompletable table left := + ⟨hleftValid, hleftCompletable⟩ + have hrightGuard : right.Valid ∧ DeferredCompletable table right := + ⟨hrightValid, hrightCompletable⟩ + simp only [directPositionContinuationObserve, if_pos hleftGuard, + if_pos hrightGuard] + have hresolved := relTriple_resolveDeferredPositionValue_of_finalizationViewEq table + revealed left right hview hleftValid hrightValid hleftCompletable + have hresolvedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolved + (fun result => result ∈ support (resolveDeferredPositionValue revealed left)) + (fun result hresult => hresult) + have hresolvedBoth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hresolvedLeft + apply evalDist_eq_of_relTriple_eqRel + apply relTriple_bind hresolvedBoth + intro leftResolved rightResolved hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResolved with + | none => + cases rightResolved with + | none => exact relTriple_pure_pure rfl + | some rightResolved => simp [FinalizationResolutionEq] at hrelation + | some leftResolved => + cases rightResolved with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResolved => + have hleftRawCompletable := hrelation.2.2.2.2 + have hrightRawCompletable : + DeferredCompletable table rightResolved.toDeferredContext := by + rcases hleftRawCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, + (hrelation.2.1.deferredCompletion_iff completion).mp hcompletion⟩ + have hleftStateValues := resolveDeferredPositionValue_preserves_state_values + revealed left leftResolved hleftSupport + have hrightStateValues := resolveDeferredPositionValue_preserves_state_values + revealed right rightResolved hrightSupport + have hleftPending := resolveDeferredPositionValue_pending revealed left leftResolved + hleftSupport + have hrightPending := resolveDeferredPositionValue_pending revealed right rightResolved + hrightSupport + have hleftValue := resolveDeferredPositionValue_resolves revealed left leftResolved + hleftSupport + have hrightValue := resolveDeferredPositionValue_resolves revealed right rightResolved + hrightSupport + have hleftMaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition left revealed leftResolved) := by + rcases hleftRawCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, + (deferredCompletion_materializeResolvedPosition_iff revealed leftResolved + hleftStateValues hleftPending hleftValue).2 hcompletion⟩ + have hrightMaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition right revealed rightResolved) := by + rcases hrightRawCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, + (deferredCompletion_materializeResolvedPosition_iff revealed rightResolved + hrightStateValues hrightPending hrightValue).2 hcompletion⟩ + have hleftMaterializedView := + finalizationViewEq_materializeResolvedPositionValue revealed leftResolved + hleftValid hview.leftStarts hleftSupport hleftMaterializedCompletable + have hrightMaterializedView := + finalizationViewEq_materializeResolvedPositionValue revealed rightResolved + hrightValid hview.rightStarts hrightSupport hrightMaterializedCompletable + have hleftResultValid := hleftValid.of_resolveDeferredPositionValue revealed + leftResolved hleftSupport + have hrightResultValid := hrightValid.of_resolveDeferredPositionValue revealed + rightResolved hrightSupport + have hleftMaterializedValid := hleftValid.materializeResolvedPosition_of revealed + leftResolved hleftResultValid hleftStateValues hleftValue + have hrightMaterializedValid := hrightValid.materializeResolvedPosition_of revealed + rightResolved hrightResultValid hrightStateValues hrightValue + apply relTriple_eqRel_of_evalDist_eq + simpa only [hrelation.1] using + (evalDist_runResolvedObserve_eq_of_finalizationSynchronized + (next leftResolved.output) + (materializeResolvedPosition left revealed leftResolved) + (materializeResolvedPosition right revealed rightResolved) fuel table + ⟨hleftMaterializedView.trans + (hrelation.2.1.trans hrightMaterializedView.symm), + hleftMaterializedValid, hrightMaterializedValid, + hleftMaterializedCompletable⟩ + (by + change Function.update left.state.values (.position revealed) + (some leftResolved.output) = + Function.update right.state.values (.position revealed) + (some rightResolved.output) + rw [hrelation.1, hvalues]) + (by + simpa [materializeResolvedPosition, LazyRevealProbe.State.materialize] using + hrevealed)) + +set_option maxRecDepth 100000 in +instance directPositionContinuationObserve_observerPositionNeutral + (table : OtsSecretIndex → HashOutput) (revealed : Position) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) + (observe : DeferredContext → Nat → α → ProbComp Bool) + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] : + ObserverPositionNeutral table + (directPositionContinuationObserve table revealed next observe) where + eq_resolve target context fuel value hvalid hcompletable _hensured := by + let resolver : PrivateResolver := fun nextContext => + resolveDeferredPositionValue revealed nextContext + let continuation : Option RevealedResolution → ProbComp Bool + | none => pure true + | some resolved => + runResolvedObserve observe + { state := (context.state.clearPending (.position target)).materialize + (.position revealed) resolved.output + values := resolved.context.values } + fuel table (next resolved.output) + rw [directPositionContinuationObserve, if_pos ⟨hvalid, hcompletable⟩] + calc + _ = evalDist (resolvePositionThenResolver target resolver context >>= continuation) := by + unfold resolvePositionThenResolver resolver continuation + simp only [bind_assoc] + apply evalDist_bind_congr + intro targetResult htargetResult + cases targetResult with + | none => rfl + | some targetResult => + have htargetValid := hvalid.of_resolveDeferredPositionValue target targetResult + htargetResult + have htargetCompletable := hcompletable.of_resolveDeferredPositionValue hvalid + target targetResult htargetResult + have htargetGuard : targetResult.toDeferredContext.Valid ∧ + DeferredCompletable table targetResult.toDeferredContext := + ⟨htargetValid, htargetCompletable⟩ + simp only [directPositionContinuationObserve, if_pos htargetGuard] + simp only [bind_assoc] + apply evalDist_bind_congr + intro revealedResult _hrevealedResult + cases revealedResult with + | none => rfl + | some revealedResult => + have hstate := resolveDeferredPositionValue_state_eq_clearPending target context + targetResult htargetResult + simp only [materializeResolvedPosition, pure_bind] + rw [hstate] + _ = evalDist (resolveResolverThenPosition target resolver context >>= continuation) := + evalDist_bind_eq_of_evalDist_eq + (positionResolutionCommutes_value target revealed context) continuation + _ = evalDist (resolveDeferredPositionValue revealed context >>= fun revealedResult => + match revealedResult with + | none => pure true + | some revealedResult => + resolveDeferredPositionValue target revealedResult.toDeferredContext >>= + fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runResolvedObserve observe + { state := (context.state.clearPending + (.position target)).materialize + (.position revealed) revealedResult.output + values := targetResult.values } + fuel table (next revealedResult.output)) := by + unfold resolveResolverThenPosition resolver continuation + simp only [bind_assoc] + apply congrArg evalDist + apply bind_congr + intro revealedResult + cases revealedResult with + | none => rfl + | some revealedResult => + simp only [bind_assoc] + apply bind_congr + intro targetResult + cases targetResult <;> rfl + _ = evalDist (resolveDeferredPositionValue revealed context >>= fun revealedResult => + match revealedResult with + | none => pure true + | some revealedResult => + runResolvedObserve observe + (materializeResolvedPosition context revealed revealedResult) + fuel table (next revealedResult.output)) := by + apply evalDist_bind_congr + intro revealedResult hrevealedResult + cases revealedResult with + | none => rfl + | some revealedResult => + have htransport := + evalDist_resolveDeferredPositionValue_after_materialized_positionValue_runResolvedObserve + target revealed context revealedResult table fuel + (next revealedResult.output) observe hvalid hcompletable hrevealedResult + have hstateValues := resolveDeferredPositionValue_preserves_state_values revealed + context revealedResult hrevealedResult + have hpending := resolveDeferredPositionValue_pending revealed context + revealedResult hrevealedResult + have hresolved := resolveDeferredPositionValue_resolves revealed context + revealedResult hrevealedResult + have hrevealedValid := hvalid.of_resolveDeferredPositionValue revealed + revealedResult hrevealedResult + have hmaterializedValid := hvalid.materializeResolvedPosition_of revealed + revealedResult hrevealedValid hstateValues hresolved + have hrawCompletable := hcompletable.of_resolveDeferredPositionValue hvalid + revealed revealedResult hrevealedResult + have hmaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition context revealed revealedResult) := by + rcases hrawCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, + (deferredCompletion_materializeResolvedPosition_iff revealed revealedResult + hstateValues hpending hresolved).2 hcompletion⟩ + exact htransport.trans + (evalDist_resolveDeferredPositionValue_then_runResolvedObserve_any + (observe := observe) target (next revealedResult.output) + (materializeResolvedPosition context revealed revealedResult) fuel table + hmaterializedValid hmaterializedCompletable) + _ = _ := by + rfl + +theorem evalDist_resolveDeferredReveal_then_directPositionContinuationObserve + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (fuel : Nat) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (do + let resolved ← resolveDeferredReveal table position context + match resolved with + | none => pure true + | some resolved => + directPositionContinuationObserve table position next observe + resolved.toDeferredContext fuel ()) = + evalDist (directPositionContinuationObserve table position next observe + context fuel ()) := by + exact evalDist_resolveDeferredReveal_then_runResolvedObserve_any + (observe := directPositionContinuationObserve table position next observe) + table position context fuel (pure ()) hvalid hcompletable + +theorem privateStateAgrees_resolveDeferredReveal + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support (resolveDeferredReveal table position context)) : + PrivateStateAgrees result.toDeferredContext context := by + classical + unfold resolveDeferredReveal at hresult + by_cases hresolvable : ResolvableOtsPosition position + · simp only [hresolvable, if_pos] at hresult + cases position with + | chain lay tree leafIdx chainIdx step => + exact privateStateAgrees_resolveDeferredChainPrefix table lay tree leafIdx chainIdx + (step.val + 1) (by have := step.isLt; omega) context result hresult + | leaf lay tree leafIdx => + exact privateStateAgrees_resolveDeferredOtsLeaf table lay tree leafIdx context result + hresult + | node lay tree level nodeIdx => + exact privateStateAgrees_resolveDeferredTreeNode table lay tree (level.val + 1) nodeIdx + (by have := level.isLt; omega) context result hresult + | ftsLeaf index tree leafIdx => simp [ResolvableOtsPosition] at hresolvable + | ftsNode index tree level nodeIdx => simp [ResolvableOtsPosition] at hresolvable + | ftsRoots index => simp [ResolvableOtsPosition] at hresolvable + · simp only [hresolvable] at hresult + exact privateStateAgrees_resolveDeferredPositionValue position context result hresult + +set_option maxRecDepth 100000 in +theorem evalDist_materializedDeferredReveal_eq_directPositionContinuationObserve + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (resolved : DeferredResolution) (fuel : Nat) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hmissing : context.state.values (.position position) = none) + (hresolved : some resolved ∈ support + (resolveDeferredReveal table position context)) : + evalDist (runResolvedObserve observe + (materializeResolvedPosition context position resolved) fuel table + (next resolved.output)) = + evalDist (directPositionContinuationObserve table position next observe + resolved.toDeferredContext fuel ()) := by + have hrawValid := hvalid.of_resolveDeferredReveal table position resolved hresolved + have hrawCompletable := + hcompletable.of_resolveDeferredReveal hvalid position resolved hresolved + have hrawGuard : resolved.toDeferredContext.Valid ∧ + DeferredCompletable table resolved.toDeferredContext := + ⟨hrawValid, hrawCompletable⟩ + rw [directPositionContinuationObserve, if_pos hrawGuard] + have hprivate := privateStateAgrees_resolveDeferredReveal table position context resolved + hresolved + have hrawMissing : resolved.state.values (.position position) = none := by + rw [hprivate.1] + exact hmissing + have hrawValue : resolved.values position = some resolved.output := by + have hvalue := resolveDeferredReveal_resolves table position context resolved hresolved + simpa [DeferredContext.positionValue, hrawMissing] using hvalue + have hpendingSubset := resolveDeferredReveal_pendingAway_subset table position context + resolved hresolved + have hclear : resolved.state.clearPending (.position position) = resolved.state := by + cases hstate : resolved.state with + | mk pending values revealed ensured => + simp only [hstate] at hpendingSubset + simp only [LazyRevealProbe.State.clearPending] + congr 1 + apply Finset.filter_eq_self.2 + intro entry hentry + have horiginal := hpendingSubset hentry + exact (Finset.mem_filter.1 horiginal).2 + have hrawNotHit : ¬resolved.state.hitAt (.position position) resolved.output := by + rw [← hclear] + exact not_hitAt_clearPending_self resolved.state (.position position) resolved.output + rw [resolveDeferredPositionValue_of_deferred_value position resolved.toDeferredContext + resolved.output hrawMissing hrawValue, if_neg hrawNotHit] + simp only [pure_bind] + let repeated : DeferredResolution := + ⟨resolved.toDeferredContext, resolved.output⟩ + have hrepeated : some repeated ∈ support + (resolveDeferredPositionValue position resolved.toDeferredContext) := by + rw [resolveDeferredPositionValue_of_deferred_value position resolved.toDeferredContext + resolved.output hrawMissing hrawValue, if_neg hrawNotHit] + simp [repeated, hclear] + have hstateValues := resolveDeferredReveal_preserves_state_values table position context + resolved hresolved + have hrawPending := resolveDeferredPositionValue_pending position resolved.toDeferredContext + repeated hrepeated + have hrawPosition := resolveDeferredPositionValue_resolves position + resolved.toDeferredContext repeated hrepeated + have hmaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition context position resolved) := by + rcases hrawCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, + (deferredCompletion_materializeResolvedReveal_iff position resolved hvalid + (startTableAgrees_of_deferredCompletable hcompletable) hresolved).2 hcompletion⟩ + have hrepeatedCompletable : DeferredCompletable table repeated.toDeferredContext := by + exact hrawCompletable.of_resolveDeferredPositionValue hrawValid position repeated hrepeated + have hrepeatedMaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition resolved.toDeferredContext position repeated) := by + rcases hrepeatedCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, + (deferredCompletion_materializeResolvedPosition_iff + (context := resolved.toDeferredContext) position repeated rfl hrawPending + hrawPosition).2 hcompletion⟩ + have hleftView := finalizationViewEq_materializeResolvedReveal position resolved hvalid + (startTableAgrees_of_deferredCompletable hcompletable) hresolved hmaterializedCompletable + have hrightView := finalizationViewEq_materializeResolvedPositionValue position repeated + hrawValid (startTableAgrees_of_deferredCompletable hrawCompletable) hrepeated + hrepeatedMaterializedCompletable + have hleftMaterializedValid := hvalid.materializeResolvedPosition_of position resolved + hrawValid hstateValues (resolveDeferredReveal_resolves table position context resolved + hresolved) + have hrightMaterializedValid := hrawValid.materializeResolvedPosition_of position repeated + (hrawValid.of_resolveDeferredPositionValue position repeated hrepeated) rfl hrawPosition + apply evalDist_runResolvedObserve_eq_of_finalizationSynchronized + · exact ⟨hleftView.trans hrightView.symm, hleftMaterializedValid, + hrightMaterializedValid, hmaterializedCompletable⟩ + · change Function.update context.state.values (.position position) + (some resolved.output) = + Function.update resolved.state.values (.position position) (some repeated.output) + simp only [repeated] + rw [hstateValues] + · simpa [materializeResolvedPosition, LazyRevealProbe.State.materialize] using + hprivate.2.1.symm + +set_option maxRecDepth 100000 in +theorem evalDist_recursiveReveal_eq_directPositionValue + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (fuel : Nat) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hmissing : context.state.values (.position position) = none) : + evalDist (do + let resolved ← resolveDeferredReveal table position context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe + (materializeResolvedPosition context position resolved) fuel table + (next resolved.output)) = + evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe + (materializeResolvedPosition context position resolved) fuel table + (next resolved.output)) := by + calc + _ = evalDist (do + let resolved ← resolveDeferredReveal table position context + match resolved with + | none => pure true + | some resolved => + directPositionContinuationObserve table position next observe + resolved.toDeferredContext fuel ()) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + exact evalDist_materializedDeferredReveal_eq_directPositionContinuationObserve table + position context resolved fuel next hvalid hcompletable hmissing hresolved + _ = evalDist (directPositionContinuationObserve table position next observe + context fuel ()) := + evalDist_resolveDeferredReveal_then_directPositionContinuationObserve table position + context fuel next hvalid hcompletable + _ = _ := by + have hguard : context.Valid ∧ DeferredCompletable table context := + ⟨hvalid, hcompletable⟩ + simp only [directPositionContinuationObserve, if_pos hguard] + +theorem DeferredContext.ValuesConsistent.materializeResolvedPositionValue_of + {context : DeferredContext} (hconsistent : context.ValuesConsistent) + (position : Position) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) : + (materializeResolvedPosition context position result).ValuesConsistent := by + have hresultConsistent := hconsistent.of_resolveDeferredPositionValue position result hresult + have hstateValues := resolveDeferredPositionValue_preserves_state_values position context + result hresult + intro other output hvalue + by_cases heq : other = position + · subst other + have hsame : output = result.output := by + simpa [materializeResolvedPosition, LazyRevealProbe.State.materialize] using hvalue.symm + rw [hsame] + exact resolveDeferredPositionValue_installs position context result hresult + · apply hresultConsistent other output + rw [hstateValues] + simpa [materializeResolvedPosition, LazyRevealProbe.State.materialize, + Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by simpa using heq] + using hvalue + +theorem DeferredCompletion.of_materializedResolvedPositionValue + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hconsistent : context.ValuesConsistent) (position : Position) + (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) + (hcompletion : DeferredCompletion table + (_root_.SphincsSecurity.Concrete.OtsProbeSimulation.materializeResolvedPosition + context position result) completion) : + DeferredCompletion table context completion := by + have hstateValues := resolveDeferredPositionValue_preserves_state_values position context + result hresult + have hpending := resolveDeferredPositionValue_pending position context result hresult + have hresolved := resolveDeferredPositionValue_resolves position context result hresult + have hraw := hcompletion.of_materializeResolvedPosition position result hstateValues + (by rw [hpending]) hresolved + exact hraw.of_resolveDeferredPositionValue_of_valuesConsistent hconsistent position result hresult + +set_option maxRecDepth 100000 in +theorem resolvedCore_of_mem_runDirectResolvedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (runDirectResolvedFromTable context fuel table computation)) : + result.table = table ∧ result.context.ValuesConsistent ∧ + StartTableAgrees result.context.state table := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runDirectResolvedFromTable] at hresult + subst result + exact ⟨rfl, hconsistent, hstarts⟩ + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hconsistent hstarts hrest + | hashOutput => + rw [runDirectResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hconsistent hstarts hrest + | ensure coordinate => + rw [runDirectResolvedFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel + (hconsistent.ensure coordinate) (hstarts.ensure coordinate) hresult + | probe coordinate candidate => + rw [runDirectResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · exact ih () context remaining hconsistent hstarts + (by simpa [hrevealed] using hresult) + · exact ih () { context with state := context.state.addPending coordinate candidate } + remaining (hconsistent.addPending coordinate candidate) + (hstarts.addPending coordinate candidate) + (by simpa [hrevealed] using hresult) + | peek coordinate => + rw [runDirectResolvedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hconsistent hstarts hresult + | publish coordinate => + rw [runDirectResolvedFromTable_publish_query_bind] at hresult + exact ih () { context with state := context.state.publish coordinate } fuel + (hconsistent.publish coordinate) (hstarts.publish coordinate) hresult + | reveal coordinate => + rw [runDirectResolvedFromTable_reveal_query_bind] at hresult + cases hvalue : context.state.values coordinate with + | some output => + exact ih output context fuel hconsistent hstarts (by simpa [hvalue] using hresult) + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [hvalue] at hresult + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + let output := table index + by_cases hhit : context.state.hitAt index.coordinate output + · have hhit' : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + simpa [index, output, OtsSecretIndex.coordinate] using hhit + simp [hhit'] at hresult + · have hhit' : ¬context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + simpa [index, output, OtsSecretIndex.coordinate] using hhit + let nextContext : DeferredContext := + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + have hnextConsistent : nextContext.ValuesConsistent := by + intro position value hknown + apply hconsistent position value + simpa [nextContext, index, OtsSecretIndex.coordinate, + LazyRevealProbe.State.materialize] using hknown + have hnextStarts : StartTableAgrees + nextContext.state table := by + change StartTableAgrees + (context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output) table + simpa [index, OtsSecretIndex.coordinate] using hstarts.materialize_start index + exact ih output nextContext fuel hnextConsistent hnextStarts + (by simpa [nextContext, index, output, hvalue, hhit'] using hresult) + | position position => + simp only [hvalue] at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hmaterializedConsistent := + hconsistent.materializeResolvedPositionValue_of position resolved hresolved + have hmaterializedStarts : StartTableAgrees + (context.state.materialize (.position position) resolved.output) table := + hstarts.materialize_position position resolved.output + exact ih resolved.output + (materializeResolvedPosition context position resolved) fuel + hmaterializedConsistent (by + simpa [materializeResolvedPosition] using hmaterializedStarts) + (by simpa [hvalue, materializeResolvedPosition] using hrest) + +set_option maxRecDepth 100000 in +theorem DeferredCompletion.of_mem_runDirectResolvedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (completion : Coordinate → HashOutput) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (runDirectResolvedFromTable context fuel table computation)) + (hcompletion : DeferredCompletion table result.context completion) : + DeferredCompletion table context completion := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runDirectResolvedFromTable] at hresult + subst result + exact hcompletion + | query_bind input next ih => + cases input with + | uniform n => + rw [runDirectResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hconsistent hstarts hrest + | hashOutput => + rw [runDirectResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hconsistent hstarts hrest + | ensure coordinate => + rw [runDirectResolvedFromTable_ensure_query_bind] at hresult + have hcurrent := ih () { context with state := context.state.ensure coordinate } fuel + (hconsistent.ensure coordinate) (hstarts.ensure coordinate) hresult + exact hcurrent.of_coreEq ⟨rfl, rfl, rfl⟩ + | probe coordinate candidate => + rw [runDirectResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · exact ih () context remaining hconsistent hstarts + (by simpa [hrevealed] using hresult) + · have hcurrent := ih () + { context with state := context.state.addPending coordinate candidate } + remaining (hconsistent.addPending coordinate candidate) + (hstarts.addPending coordinate candidate) + (by simpa [hrevealed] using hresult) + exact hcurrent.of_addPending coordinate candidate + | peek coordinate => + rw [runDirectResolvedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hconsistent hstarts hresult + | publish coordinate => + rw [runDirectResolvedFromTable_publish_query_bind] at hresult + have hcurrent := ih () { context with state := context.state.publish coordinate } fuel + (hconsistent.publish coordinate) (hstarts.publish coordinate) hresult + exact hcurrent.of_coreEq ⟨rfl, rfl, rfl⟩ + | reveal coordinate => + rw [runDirectResolvedFromTable_reveal_query_bind] at hresult + cases hvalue : context.state.values coordinate with + | some output => + exact ih output context fuel hconsistent hstarts (by simpa [hvalue] using hresult) + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only [hvalue] at hresult + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + let output := table index + by_cases hhit : context.state.hitAt index.coordinate output + · have hhit' : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + simpa [index, output, OtsSecretIndex.coordinate] using hhit + simp [hhit'] at hresult + · have hhit' : ¬context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + simpa [index, output, OtsSecretIndex.coordinate] using hhit + let nextContext : DeferredContext := + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } + have hnextConsistent : nextContext.ValuesConsistent := by + intro position value hknown + apply hconsistent position value + simpa [nextContext, index, OtsSecretIndex.coordinate, + LazyRevealProbe.State.materialize] using hknown + have hnextStarts : StartTableAgrees nextContext.state table := by + change StartTableAgrees + (context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output) table + simpa [index, OtsSecretIndex.coordinate] using hstarts.materialize_start index + have hcurrent := ih output nextContext fuel hnextConsistent hnextStarts + (by simpa [nextContext, index, output, hhit'] using hresult) + let resolved : DeferredResolution := + ⟨{ state := context.state.clearPending index.coordinate + values := context.values }, output⟩ + have hresolvedEq : resolveDeferredChainStart table index context = + some resolved := by + simp [resolveDeferredChainStart, resolved, index, output, hvalue, hhit', + OtsSecretIndex.coordinate] + have hcurrent' : DeferredCompletion table + (materializeResolvedChainStart context index resolved) completion := by + simpa [nextContext, resolved, materializeResolvedChainStart, index, output, + OtsSecretIndex.coordinate] using hcurrent + exact hcurrent'.of_materializeResolvedChainStart' hstarts index resolved + hresolvedEq + | position position => + simp only [hvalue] at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hmaterializedConsistent := + hconsistent.materializeResolvedPositionValue_of position resolved hresolved + have hmaterializedStarts : StartTableAgrees + (context.state.materialize (.position position) resolved.output) table := + hstarts.materialize_position position resolved.output + have hcurrent := ih resolved.output + (_root_.SphincsSecurity.Concrete.OtsProbeSimulation.materializeResolvedPosition + context position resolved) fuel + hmaterializedConsistent (by + simpa only + [_root_.SphincsSecurity.Concrete.OtsProbeSimulation.materializeResolvedPosition] + using hmaterializedStarts) + (by + simpa only + [_root_.SphincsSecurity.Concrete.OtsProbeSimulation.materializeResolvedPosition] + using hrest) + exact hcurrent.of_materializedResolvedPositionValue hconsistent position + resolved hresolved + +theorem deferredCompletable_of_mem_runDirectResolvedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (runDirectResolvedFromTable context fuel table computation)) + (hfinal : DeferredCompletable table result.context) : + DeferredCompletable table context := by + obtain ⟨completion, hcompletion⟩ := hfinal + exact ⟨completion, hcompletion.of_mem_runDirectResolvedFromTable computation context fuel table + result completion hconsistent hstarts hresult⟩ + +theorem not_deferredCompletable_of_mem_runDirectResolvedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult α) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (runDirectResolvedFromTable context fuel table computation)) + (hdoomed : ¬DeferredCompletable table context) : + ¬DeferredCompletable table result.context := by + intro hfinal + exact hdoomed (deferredCompletable_of_mem_runDirectResolvedFromTable computation context fuel + table result hconsistent hstarts hresult hfinal) + +noncomputable def runDirectResolvedObserve + (observe : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : ProbComp Bool := + runDirectResolvedFromTable context fuel table computation >>= finishObserve observe + +theorem evalDist_runDirectResolvedObserve_eq_true_of_not_completable + (observe : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) + (hobserve : ∀ nextContext remaining value, + nextContext.ValuesConsistent → + StartTableAgrees nextContext.state table → + ¬DeferredCompletable table nextContext → + evalDist (observe nextContext remaining value) = + evalDist (pure true : ProbComp Bool)) : + evalDist (runDirectResolvedObserve observe context fuel table computation) = + evalDist (pure true : ProbComp Bool) := by + unfold runDirectResolvedObserve + calc + _ = evalDist (runDirectResolvedFromTable context fuel table computation >>= fun _ => + pure true) := by + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable computation context fuel + table result hconsistent hstarts hresult + have hstillDoomed := not_deferredCompletable_of_mem_runDirectResolvedFromTable + computation context fuel table result hconsistent hstarts hresult hdoomed + exact hobserve result.context result.remaining result.value hcore.2.1 hcore.2.2 + hstillDoomed + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (runDirectResolvedFromTable context fuel table computation) + (by simp [runDirectResolvedFromTable]) (pure true) + +theorem evalDist_runDirectResolvedObserve_eq_true_of_not_completable_auto + {observe : DeferredContext → Nat → α → ProbComp Bool} + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) [ObserverDooms table observe] + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) : + evalDist (runDirectResolvedObserve observe context fuel table computation) = + evalDist (pure true : ProbComp Bool) := + evalDist_runDirectResolvedObserve_eq_true_of_not_completable observe context fuel table + computation hconsistent hstarts hdoomed ObserverDooms.eq_true + +set_option maxRecDepth 100000 in +theorem evalDist_runResolvedObserve_eq_runDirectResolvedObserve + (observe : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (runResolvedObserve observe context fuel table computation) = + evalDist (runDirectResolvedObserve observe context fuel table computation) := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runResolvedObserve, runDirectResolvedObserve, runResolvedFromTable, + runDirectResolvedFromTable] + | query_bind input next ih => + unfold runResolvedObserve runDirectResolvedObserve + cases input with + | uniform n => + rw [runResolvedFromTable_uniform_query_bind, + runDirectResolvedFromTable_uniform_query_bind] + simp only [bind_assoc] + apply evalDist_bind_congr + intro output _houtput + exact ih output context fuel hvalid hcompletable + | hashOutput => + rw [runResolvedFromTable_hashOutput_query_bind, + runDirectResolvedFromTable_hashOutput_query_bind] + simp only [bind_assoc] + apply evalDist_bind_congr + intro output _houtput + exact ih output context fuel hvalid hcompletable + | ensure coordinate => + rw [runResolvedFromTable_ensure_query_bind, + runDirectResolvedFromTable_ensure_query_bind] + apply ih () + · exact hvalid.ensure coordinate + · exact (deferredCompletable_iff_of_coreEq + (left := { context with state := context.state.ensure coordinate }) + (right := context) ⟨rfl, rfl, rfl⟩).2 hcompletable + | probe coordinate candidate => + rw [runResolvedFromTable_probe_query_bind, + runDirectResolvedFromTable_probe_query_bind] + cases fuel with + | zero => rfl + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () context remaining hvalid hcompletable + · simp only [hrevealed, ↓reduceIte] + let nextContext : DeferredContext := + { context with state := context.state.addPending coordinate candidate } + by_cases hnextCompletable : DeferredCompletable table nextContext + · apply ih () nextContext remaining + · exact hvalid.addPending_of_completable coordinate candidate hnextCompletable + · exact hnextCompletable + · have hconsistent := hvalid.valuesConsistent.addPending coordinate candidate + have hstarts := (startTableAgrees_of_deferredCompletable hcompletable).addPending + coordinate candidate + exact (evalDist_runResolvedObserve_eq_true_of_not_completable_auto + (observe := observe) nextContext remaining table (next ()) hconsistent hstarts + hnextCompletable).trans + (evalDist_runDirectResolvedObserve_eq_true_of_not_completable_auto + (observe := observe) nextContext remaining table (next ()) hconsistent hstarts + hnextCompletable).symm + | peek coordinate => + rw [runResolvedFromTable_peek_query_bind, + runDirectResolvedFromTable_peek_query_bind] + exact ih (context.state.values coordinate) context fuel hvalid hcompletable + | publish coordinate => + rw [runResolvedFromTable_publish_query_bind, + runDirectResolvedFromTable_publish_query_bind] + apply ih () + · exact hvalid.publish coordinate + · exact (deferredCompletable_iff_of_coreEq + (left := { context with state := context.state.publish coordinate }) + (right := context) ⟨rfl, rfl, rfl⟩).2 hcompletable + | reveal coordinate => + rw [runResolvedFromTable_reveal_query_bind, + runDirectResolvedFromTable_reveal_query_bind] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hclean := hcompletable.not_hitAt_chainStart index + cases hstate : context.state.values index.coordinate with + | some output => + have houtput := hstarts index output hstate + subst output + let resolved : DeferredResolution := + ⟨{ state := context.state.clearPending index.coordinate + values := context.values }, table index⟩ + have hresolved : resolveDeferredChainStart table index context = + some resolved := by + simp [resolveDeferredChainStart, resolved, hstate, hclean] + simp only [pure_bind] + rw [show resolveDeferredChainStart table + ⟨lay, tree, leafIdx, chainIdx⟩ context = some resolved by + simpa [index] using hresolved] + have hnextValid : + (materializeResolvedChainStart context index resolved).Valid := by + rw [materializeResolvedChainStart] + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + exact hvalid.materialize_chainStart lay tree leafIdx chainIdx resolved.output + have hnextCompletable := hcompletable.materializeResolvedChainStart hstarts + index resolved hresolved + have hrawEq := finalizationContextEq_resolveDeferredChainStart_original table + index context resolved hvalid hcompletable hresolved + have hmatView := finalizationViewEq_materializeResolvedChainStart index resolved + hvalid hstarts hresolved hnextCompletable + have hstate' : context.state.values + (.chainStart lay tree leafIdx chainIdx) = + some (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + simpa [index, OtsSecretIndex.coordinate] using hstate + simp only [hstate'] + calc + _ = evalDist (runResolvedObserve observe + (materializeResolvedChainStart context index resolved) fuel table + (next (table index))) := by + rfl + _ = evalDist (runResolvedObserve observe context fuel table + (next (table index))) := by + apply evalDist_runResolvedObserve_eq_of_finalizationSynchronized + · exact ⟨hmatView.trans hrawEq.1, hnextValid, hvalid, hnextCompletable⟩ + · simp only [materializeResolvedChainStart, resolved, + LazyRevealProbe.State.materialize] + funext coordinate + by_cases heq : coordinate = index.coordinate + · subst coordinate + simpa using hstate.symm + · simp [Function.update_of_ne heq] + · rfl + _ = evalDist (runDirectResolvedObserve observe context fuel table + (next (table index))) := ih (table index) context fuel hvalid hcompletable + _ = _ := by + rfl + | none => + let resolved : DeferredResolution := + ⟨{ state := context.state.clearPending index.coordinate + values := context.values }, table index⟩ + have hresolved : resolveDeferredChainStart table index context = + some resolved := by + simp [resolveDeferredChainStart, resolved, hstate, hclean] + simp only [pure_bind] + rw [show resolveDeferredChainStart table + ⟨lay, tree, leafIdx, chainIdx⟩ context = some resolved by + simpa [index] using hresolved] + have hnextValid : + (materializeResolvedChainStart context index resolved).Valid := by + rw [materializeResolvedChainStart] + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + exact hvalid.materialize_chainStart lay tree leafIdx chainIdx resolved.output + have hnextCompletable := hcompletable.materializeResolvedChainStart hstarts + index resolved hresolved + have hstate' : context.state.values + (.chainStart lay tree leafIdx chainIdx) = none := by + simpa [index, OtsSecretIndex.coordinate] using hstate + have hclean' : ¬context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + simpa [index, OtsSecretIndex.coordinate] using hclean + simp only [hstate', hclean', ↓reduceIte] + simpa [runResolvedObserve, runDirectResolvedObserve, + materializeResolvedChainStart, resolved, index, OtsSecretIndex.coordinate] + using ih (table index) (materializeResolvedChainStart context index resolved) + fuel hnextValid hnextCompletable + | position position => + cases hstate : context.state.values (.position position) with + | some output => + calc + _ = evalDist (resolveDeferredReveal table position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe + (materializeResolvedPosition context position resolved) fuel table + (next resolved.output)) := by + rw [bind_assoc] + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved <;> rfl + _ = evalDist (resolveDeferredReveal table position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table + (next output)) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hstateValues := resolveDeferredReveal_preserves_state_values table + position context resolved hresolved + have hresolvedValue := resolveDeferredReveal_resolves table position + context resolved hresolved + have hsame : resolved.output = output := by + unfold DeferredContext.positionValue at hresolvedValue + rw [hstateValues, hstate] at hresolvedValue + exact Option.some.inj hresolvedValue.symm + have hrawValid := hvalid.of_resolveDeferredReveal table position resolved + hresolved + have hrawCompletable := hcompletable.of_resolveDeferredReveal hvalid + position resolved hresolved + have hnextValid := hvalid.materializeResolvedPosition_of position resolved + hrawValid hstateValues hresolvedValue + have hnextCompletable : DeferredCompletable table + (materializeResolvedPosition context position resolved) := by + obtain ⟨completion, hcompletion⟩ := hrawCompletable + exact ⟨completion, + (deferredCompletion_materializeResolvedReveal_iff position resolved + hvalid (startTableAgrees_of_deferredCompletable hcompletable) + hresolved).2 hcompletion⟩ + have hview := finalizationViewEq_materializeResolvedReveal position + resolved hvalid (startTableAgrees_of_deferredCompletable hcompletable) + hresolved hnextCompletable + simp only + rw [hsame] + apply evalDist_runResolvedObserve_eq_of_finalizationSynchronized + · exact ⟨hview, hnextValid, hrawValid, hnextCompletable⟩ + · simp only + [_root_.SphincsSecurity.Concrete.OtsProbeSimulation.materializeResolvedPosition, + LazyRevealProbe.State.materialize] + rw [hstateValues] + funext coordinate + by_cases heq : coordinate = .position position + · subst coordinate + simpa [hstate] using hsame + · simp [Function.update_of_ne heq] + · simpa only + [_root_.SphincsSecurity.Concrete.OtsProbeSimulation.materializeResolvedPosition, + LazyRevealProbe.State.materialize] using + (privateStateAgrees_resolveDeferredReveal table position context + resolved hresolved).2.1.symm + _ = evalDist (runResolvedObserve observe context fuel table (next output)) := + evalDist_resolveDeferredReveal_then_runResolvedObserve_any + (observe := observe) table position context fuel (next output) hvalid + hcompletable + _ = evalDist (runDirectResolvedObserve observe context fuel table + (next output)) := ih output context fuel hvalid hcompletable + _ = _ := by rfl + | none => + calc + _ = evalDist (resolveDeferredReveal table position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe + (materializeResolvedPosition context position resolved) fuel table + (next resolved.output)) := by + rw [bind_assoc] + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved <;> rfl + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe + (materializeResolvedPosition context position resolved) fuel table + (next resolved.output)) := + evalDist_recursiveReveal_eq_directPositionValue table position context fuel + next hvalid hcompletable hstate + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runDirectResolvedObserve observe + (materializeResolvedPosition context position resolved) fuel table + (next resolved.output)) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hrawValid := hvalid.of_resolveDeferredPositionValue position + resolved hresolved + have hstateValues := resolveDeferredPositionValue_preserves_state_values + position context resolved hresolved + have hpending := resolveDeferredPositionValue_pending position context + resolved hresolved + have hresolvedValue := resolveDeferredPositionValue_resolves position + context resolved hresolved + have hnextValid := hvalid.materializeResolvedPosition_of position resolved + hrawValid hstateValues hresolvedValue + have hrawCompletable := hcompletable.of_resolveDeferredPositionValue + hvalid position resolved hresolved + have hnextCompletable : DeferredCompletable table + (materializeResolvedPosition context position resolved) := by + obtain ⟨completion, hcompletion⟩ := hrawCompletable + exact ⟨completion, + (deferredCompletion_materializeResolvedPosition_iff position resolved + hstateValues hpending hresolvedValue).2 hcompletion⟩ + exact ih resolved.output + (materializeResolvedPosition context position resolved) fuel hnextValid + hnextCompletable + _ = _ := by + rw [bind_assoc] + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved <;> rfl + +noncomputable def resolvedFinalizationObserve + (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (fuel : Nat) (value : α) : ProbComp Bool := + finishResolvedRunIsNone (some ⟨context, fuel, value, table⟩) + +instance resolvedFinalizationObserve_observerDooms + (α : Type) (table : OtsSecretIndex → HashOutput) : + ObserverDooms table + (resolvedFinalizationObserve table : DeferredContext → Nat → α → ProbComp Bool) where + eq_true context fuel value hconsistent hstarts hdoomed := by + simpa [runResolvedFinishIsNone, runResolvedFromTable, + resolvedFinalizationObserve] using + (evalDist_runResolvedFinishIsNone_eq_true_of_not_completable context fuel table + (pure value) hconsistent hstarts hdoomed) + +instance resolvedFinalizationObserve_observerSynchronized + (α : Type) (table : OtsSecretIndex → HashOutput) : + ObserverSynchronized table + (resolvedFinalizationObserve table : DeferredContext → Nat → α → ProbComp Bool) where + eq_of_synchronized left right fuel value hcontext _hvalues _hrevealed := by + exact evalDist_finishResolvedRunIsNone_eq_of_finalizationContextEq table left right fuel + value hcontext + +instance resolvedFinalizationObserve_observerPositionNeutral + (α : Type) (table : OtsSecretIndex → HashOutput) : + ObserverPositionNeutral table + (resolvedFinalizationObserve table : DeferredContext → Nat → α → ProbComp Bool) where + eq_resolve position context fuel value hvalid hcompletable hensured := by + change evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure true + | some resolved => + runResolvedFinishIsNone resolved.toDeferredContext fuel table (pure value)) = + evalDist (runResolvedFinishIsNone context fuel table (pure value)) + exact evalDist_resolveDeferredPositionValue_then_runResolvedFinishIsNone position + (pure value) context fuel table hvalid hcompletable hensured + +theorem evalDist_runResolvedFinishIsNone_eq_runDirectResolvedFinalizationIsNone + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (runResolvedFinishIsNone context fuel table computation) = + evalDist (runDirectResolvedFromTable context fuel table computation >>= + finishObserve (resolvedFinalizationObserve table)) := by + calc + _ = evalDist (runResolvedObserve (resolvedFinalizationObserve table) context fuel table + computation) := by + unfold runResolvedFinishIsNone runResolvedObserve + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable computation context fuel table + result hvalid.valuesConsistent + (startTableAgrees_of_deferredCompletable hcompletable) hresult + rcases result with ⟨resultContext, remaining, value, resultTable⟩ + dsimp only at hcore + rw [hcore.1] + rfl + _ = _ := evalDist_runResolvedObserve_eq_runDirectResolvedObserve + (observe := resolvedFinalizationObserve table) context fuel table computation hvalid + hcompletable + +def RecursiveRevealEnsured (position : Position) (context : DeferredContext) : Prop := + match position with + | .chain lay tree leafIdx chainIdx step => + ∀ current : ChainStep, current.val < step.val + 1 → + Coordinate.position (.chain lay tree leafIdx chainIdx current) ∈ + context.state.ensured + | .leaf lay tree leafIdx => OtsLeafEnsured lay tree leafIdx context + | .node lay tree level nodeIdx => + TreeNodeEnsured lay tree (level.val + 1) nodeIdx context + | _ => True + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredReveal_then_runResolvedObserve_of_resolvable + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hresolvable : ResolvableOtsPosition position) + (hensured : RecursiveRevealEnsured position context) : + evalDist (do + let resolved ← resolveDeferredReveal table position context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) := by + cases position with + | chain lay tree leafIdx chainIdx step => + have hsteps : step.val + 1 ≤ chainLength - 1 := by + have := step.isLt + omega + rw [resolveDeferredReveal, if_pos hresolvable] + simp only [resolveDeferredPosition] + change evalDist (do + let resolved ← resolveDeferredChainPrefix table lay tree leafIdx chainIdx + (step.val + 1) hsteps context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = _ + exact evalDist_resolveDeferredChainPrefix_then_runResolvedObserve + (observe := observe) table lay tree leafIdx chainIdx (step.val + 1) + hsteps context fuel computation hvalid hcompletable hensured + | leaf lay tree leafIdx => + rw [resolveDeferredReveal, if_pos hresolvable] + exact evalDist_resolveDeferredOtsLeaf_then_runResolvedObserve + (observe := observe) table lay tree leafIdx context fuel computation hvalid + hcompletable hensured + | node lay tree level nodeIdx => + have hlevel : level.val + 1 ≤ maxLayerHeight := by + have := level.isLt + omega + rw [resolveDeferredReveal, if_pos hresolvable] + simp only [resolveDeferredPosition] + change evalDist (do + let resolved ← resolveDeferredTreeNode table lay tree (level.val + 1) nodeIdx + hlevel context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = _ + exact evalDist_resolveDeferredTreeNode_then_runResolvedObserve + (observe := observe) table lay tree (level.val + 1) nodeIdx + hlevel context fuel computation hvalid hcompletable hensured + | ftsLeaf index tree leafIdx => + simp [ResolvableOtsPosition] at hresolvable + | ftsNode index tree level nodeIdx => + simp [ResolvableOtsPosition] at hresolvable + | ftsRoots index => + simp [ResolvableOtsPosition] at hresolvable + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedDirectSynchronized.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedDirectSynchronized.lean new file mode 100644 index 00000000..d2880353 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedDirectSynchronized.lean @@ -0,0 +1,445 @@ +import SphincsSecurity.Proof.OtsProbeResolvedDirectPositionNeutral + +/-! Direct interpreter synchronization without a position-neutrality assumption. -/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem evalDist_runDirectResolvedObserve_eq_of_finalizationSynchronized + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (left right : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) + (hrevealed : left.state.revealed = right.state.revealed) : + evalDist (runDirectResolvedObserve observe left fuel table computation) = + evalDist (runDirectResolvedObserve observe right fuel table computation) := by + induction computation using OracleComp.inductionOn generalizing left right fuel with + | pure value => + unfold runDirectResolvedObserve + simp only [runDirectResolvedFromTable] + exact ObserverSynchronized.eq_of_synchronized left right fuel value hcontext + hvalues hrevealed + | query_bind query next ih => + cases query with + | uniform n => + unfold runDirectResolvedObserve + simp only [runDirectResolvedFromTable_uniform_query_bind, bind_assoc] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + exact ih output left right fuel hcontext hvalues hrevealed + | hashOutput => + unfold runDirectResolvedObserve + simp only [runDirectResolvedFromTable_hashOutput_query_bind, bind_assoc] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + exact ih output left right fuel hcontext hvalues hrevealed + | ensure coordinate => + unfold runDirectResolvedObserve + simp only [runDirectResolvedFromTable_ensure_query_bind] + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + apply ih () + · exact ⟨hview.ensure coordinate, hleftValid.ensure coordinate, + hrightValid.ensure coordinate, hleftCompletable.ensure coordinate⟩ + · exact hvalues + · exact hrevealed + | peek coordinate => + unfold runDirectResolvedObserve + simp only [runDirectResolvedFromTable_peek_query_bind] + rw [hvalues] + exact ih (right.state.values coordinate) left right fuel hcontext hvalues hrevealed + | publish coordinate => + unfold runDirectResolvedObserve + simp only [runDirectResolvedFromTable_publish_query_bind] + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + apply ih () + · exact ⟨hview.publish coordinate, hleftValid.publish coordinate, + hrightValid.publish coordinate, hleftCompletable.publish coordinate⟩ + · exact hvalues + · simpa [LazyRevealProbe.State.publish] using congrArg (insert coordinate) hrevealed + | probe coordinate candidate => + unfold runDirectResolvedObserve + simp only [runDirectResolvedFromTable_probe_query_bind] + cases fuel with + | zero => rfl + | succ remaining => + by_cases hleftRevealed : coordinate ∈ left.state.revealed + · have hrightRevealed : coordinate ∈ right.state.revealed := by + rw [← hrevealed] + exact hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + exact ih () left right remaining hcontext hvalues hrevealed + · have hrightRevealed : coordinate ∉ right.state.revealed := by + rwa [← hrevealed] + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + let left' : DeferredContext := + { left with state := left.state.addPending coordinate candidate } + let right' : DeferredContext := + { right with state := right.state.addPending coordinate candidate } + have hcompletableIff : DeferredCompletable table left' ↔ + DeferredCompletable table right' := by + exact deferredCompletable_addPending_iff_of_finalizationViewEq + hcontext.1 coordinate candidate + by_cases hleftCompletable : DeferredCompletable table left' + · have hrightCompletable : DeferredCompletable table right' := + hcompletableIff.mp hleftCompletable + apply ih () left' right' remaining + · exact ⟨hcontext.1.addPending_of_completable coordinate candidate + hleftCompletable hrightCompletable, + hcontext.2.1.addPending_of_completable coordinate candidate + hleftCompletable, + hcontext.2.2.1.addPending_of_completable coordinate candidate + hrightCompletable, + hleftCompletable⟩ + · exact hvalues + · exact hrevealed + · have hrightCompletable : ¬DeferredCompletable table right' := by + rwa [← hcompletableIff] + calc + _ = evalDist (pure true : ProbComp Bool) := + evalDist_runDirectResolvedObserve_eq_true_of_not_completable_auto (observe := observe) + left' remaining table (next ()) hcontext.2.1.1 hcontext.1.leftStarts + hleftCompletable + _ = evalDist (runDirectResolvedObserve observe right' remaining table + (next ())) := + (evalDist_runDirectResolvedObserve_eq_true_of_not_completable_auto (observe := observe) + right' remaining table (next ()) hcontext.2.2.1.1 hcontext.1.rightStarts + hrightCompletable).symm + | reveal coordinate => + unfold runDirectResolvedObserve + simp_rw [runDirectResolvedFromTable_reveal_query_bind] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + simp only [bind_assoc] + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hrightCompletable : DeferredCompletable table right := by + rcases hleftCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, (hview.deferredCompletion_iff completion).mp hcompletion⟩ + have hleftClean := hleftCompletable.not_hitAt_chainStart index + have hrightClean := hrightCompletable.not_hitAt_chainStart index + cases hleftState : left.state.values index.coordinate with + | some output => + have hrightState : right.state.values index.coordinate = some output := by + rw [← hvalues] + exact hleftState + have hleftState' : left.state.values + (.chainStart lay tree leafIdx chainIdx) = some output := by + simpa [index, OtsSecretIndex.coordinate] using hleftState + have hrightState' : right.state.values + (.chainStart lay tree leafIdx chainIdx) = some output := by + simpa [index, OtsSecretIndex.coordinate] using hrightState + rw [hleftState', hrightState'] + simpa only [runDirectResolvedObserve] using + ih output left right fuel + ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ hvalues hrevealed + | none => + have hrightState : right.state.values index.coordinate = none := by + rw [← hvalues] + exact hleftState + have hleftState' : left.state.values + (.chainStart lay tree leafIdx chainIdx) = none := by + simpa [index, OtsSecretIndex.coordinate] using hleftState + have hrightState' : right.state.values + (.chainStart lay tree leafIdx chainIdx) = none := by + simpa [index, OtsSecretIndex.coordinate] using hrightState + have hleftClean' : ¬left.state.hitAt + (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + simpa [index, OtsSecretIndex.coordinate] using hleftClean + have hrightClean' : ¬right.state.hitAt + (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + simpa [index, OtsSecretIndex.coordinate] using hrightClean + let leftResolved : DeferredResolution := + ⟨{ state := left.state.clearPending index.coordinate, + values := left.values }, table index⟩ + let rightResolved : DeferredResolution := + ⟨{ state := right.state.clearPending index.coordinate, + values := right.values }, table index⟩ + have hleftResult : + resolveDeferredChainStart table index left = some leftResolved := + resolveDeferredChainStart_of_agrees table index left hview.leftStarts + hleftClean + have hrightResult : + resolveDeferredChainStart table index right = some rightResolved := + resolveDeferredChainStart_of_agrees table index right hview.rightStarts + hrightClean + have hrawView := finalizationViewEq_resolveDeferredChainStart index + leftResolved rightResolved hview hleftValid hrightValid hleftCompletable + hleftResult hrightResult + have hleftRawValid := hleftValid.of_resolveDeferredChainStart table index + leftResolved hleftResult + have hrightRawValid := hrightValid.of_resolveDeferredChainStart table index + rightResolved hrightResult + have hleftMaterializedCompletable := + hleftCompletable.materializeResolvedChainStart hview.leftStarts index + leftResolved hleftResult + have hrightMaterializedCompletable := + hrightCompletable.materializeResolvedChainStart hview.rightStarts index + rightResolved hrightResult + have hleftMaterializedView := + finalizationViewEq_materializeResolvedChainStart index leftResolved + hleftValid hview.leftStarts hleftResult hleftMaterializedCompletable + have hrightMaterializedView := + finalizationViewEq_materializeResolvedChainStart index rightResolved + hrightValid hview.rightStarts hrightResult hrightMaterializedCompletable + have hleftMaterializedValid : + (materializeResolvedChainStart left index leftResolved).Valid := by + unfold materializeResolvedChainStart + rw [resolveDeferredChainStart_deferred_values_eq table index left + leftResolved hleftResult] + exact hleftValid.materialize_chainStart lay tree leafIdx chainIdx + leftResolved.output + have hrightMaterializedValid : + (materializeResolvedChainStart right index rightResolved).Valid := by + unfold materializeResolvedChainStart + rw [resolveDeferredChainStart_deferred_values_eq table index right + rightResolved hrightResult] + exact hrightValid.materialize_chainStart lay tree leafIdx chainIdx + rightResolved.output + have hnext := ih leftResolved.output + (materializeResolvedChainStart left index leftResolved) + (materializeResolvedChainStart right index rightResolved) fuel + ⟨hleftMaterializedView.trans + (hrawView.trans hrightMaterializedView.symm), + hleftMaterializedValid, hrightMaterializedValid, + hleftMaterializedCompletable⟩ + (by + change Function.update left.state.values index.coordinate + (some leftResolved.output) = + Function.update right.state.values index.coordinate + (some rightResolved.output) + rw [hvalues]) + (by + simpa [materializeResolvedChainStart, + LazyRevealProbe.State.materialize] using hrevealed) + rw [hleftState', hrightState', if_neg hleftClean', if_neg hrightClean'] + simpa only [runDirectResolvedObserve, index, OtsSecretIndex.coordinate, + leftResolved, + rightResolved, materializeResolvedChainStart] using hnext + | position position => + simp only [bind_assoc] + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + cases hleftState : left.state.values (.position position) with + | some output => + have hrightState : right.state.values (.position position) = some output := by + rw [← hvalues] + exact hleftState + simpa only [runDirectResolvedObserve, hleftState, hrightState] using + ih output left right fuel + ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ hvalues hrevealed + | none => + have hrightState : right.state.values (.position position) = none := by + rw [← hvalues] + exact hleftState + rw [hrightState] + simp only [bind_assoc] + have hresolved := relTriple_resolveDeferredPositionValue_of_finalizationViewEq + table position left right hview hleftValid hrightValid hleftCompletable + have hresolvedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolved + (fun result => result ∈ support + (resolveDeferredPositionValue position left)) + (fun result hresult => hresult) + have hresolvedBoth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support + hresolvedLeft + apply evalDist_eq_of_relTriple_eqRel + apply relTriple_bind hresolvedBoth + intro leftResolved rightResolved hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResolved with + | none => + cases rightResolved with + | none => simp [EqRel] + | some rightResolved => simp [FinalizationResolutionEq] at hrelation + | some leftResolved => + cases rightResolved with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResolved => + have hleftRawCompletable := hrelation.2.2.2.2 + have hleftStateValues := + resolveDeferredPositionValue_preserves_state_values position left + leftResolved hleftSupport + have hrightStateValues := + resolveDeferredPositionValue_preserves_state_values position right + rightResolved hrightSupport + have hleftPending := resolveDeferredPositionValue_pending position left + leftResolved hleftSupport + have hrightPending := resolveDeferredPositionValue_pending position right + rightResolved hrightSupport + have hleftResolvedValue := resolveDeferredPositionValue_resolves position + left leftResolved hleftSupport + have hrightResolvedValue := resolveDeferredPositionValue_resolves position + right rightResolved hrightSupport + have hleftMaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition left position leftResolved) := by + rcases hleftRawCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, + (deferredCompletion_materializeResolvedPosition_iff position + leftResolved hleftStateValues hleftPending hleftResolvedValue).2 + hcompletion⟩ + have hrightRawCompletable : + DeferredCompletable table rightResolved.toDeferredContext := by + rcases hrelation.2.2.2.2 with ⟨completion, hcompletion⟩ + exact ⟨completion, + (hrelation.2.1.deferredCompletion_iff completion).mp hcompletion⟩ + have hrightMaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition right position rightResolved) := by + rcases hrightRawCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, + (deferredCompletion_materializeResolvedPosition_iff position + rightResolved hrightStateValues hrightPending hrightResolvedValue).2 + hcompletion⟩ + have hleftMaterializedView := + finalizationViewEq_materializeResolvedPositionValue position leftResolved + hleftValid hview.leftStarts hleftSupport + hleftMaterializedCompletable + have hrightMaterializedView := + finalizationViewEq_materializeResolvedPositionValue position rightResolved + hrightValid hview.rightStarts hrightSupport + hrightMaterializedCompletable + have hleftResultValid := hleftValid.of_resolveDeferredPositionValue + position leftResolved hleftSupport + have hrightResultValid := hrightValid.of_resolveDeferredPositionValue + position rightResolved hrightSupport + have hleftMaterializedValid : + (materializeResolvedPosition left position leftResolved).Valid := + hleftValid.materializeResolvedPosition_of position leftResolved + hleftResultValid hleftStateValues hleftResolvedValue + have hrightMaterializedValid : + (materializeResolvedPosition right position rightResolved).Valid := + hrightValid.materializeResolvedPosition_of position rightResolved + hrightResultValid hrightStateValues hrightResolvedValue + have hnext := ih leftResolved.output + (materializeResolvedPosition left position leftResolved) + (materializeResolvedPosition right position rightResolved) fuel + ⟨hleftMaterializedView.trans + (hrelation.2.1.trans hrightMaterializedView.symm), + hleftMaterializedValid, hrightMaterializedValid, + hleftMaterializedCompletable⟩ + (by + change Function.update left.state.values (.position position) + (some leftResolved.output) = + Function.update right.state.values (.position position) + (some rightResolved.output) + rw [hrelation.1, hvalues]) + (by + simpa [materializeResolvedPosition, + LazyRevealProbe.State.materialize] using hrevealed) + apply relTriple_eqRel_of_evalDist_eq + simpa only [runDirectResolvedObserve, hleftState, hrightState, + materializeResolvedPosition, hrelation.1] using hnext + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_runDirectResolvedObserve_eq_of_synchronized + (table : OtsSecretIndex → HashOutput) (position : Position) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + (left right : DeferredContext) (fuel : Nat) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) + (hrevealed : left.state.revealed = right.state.revealed) : + evalDist (do + let resolved ← resolveDeferredPositionValue position left + match resolved with + | none => pure true + | some resolved => + runDirectResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (do + let resolved ← resolveDeferredPositionValue position right + match resolved with + | none => pure true + | some resolved => + runDirectResolvedObserve observe resolved.toDeferredContext fuel table computation) := by + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hresolved := relTriple_resolveDeferredPositionValue_of_finalizationViewEq table position + left right hview hleftValid hrightValid hleftCompletable + have hresolvedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolved + (fun result => result ∈ support (resolveDeferredPositionValue position left)) + (fun result hresult => hresult) + have hresolvedBoth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hresolvedLeft + apply evalDist_eq_of_relTriple_eqRel + apply relTriple_bind hresolvedBoth + intro leftResolved rightResolved hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResolved with + | none => + cases rightResolved with + | none => exact relTriple_pure_pure rfl + | some rightResolved => simp [FinalizationResolutionEq] at hrelation + | some leftResolved => + cases rightResolved with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResolved => + apply relTriple_eqRel_of_evalDist_eq + apply evalDist_runDirectResolvedObserve_eq_of_finalizationSynchronized computation + · exact ⟨hrelation.2.1, hrelation.2.2.1, hrelation.2.2.2.1, + hrelation.2.2.2.2⟩ + · rw [resolveDeferredPositionValue_preserves_state_values position left leftResolved + hleftSupport, + resolveDeferredPositionValue_preserves_state_values position right rightResolved + hrightSupport] + exact hvalues + · rw [resolveDeferredPositionValue_state_eq_clearPending position left leftResolved + hleftSupport, + resolveDeferredPositionValue_state_eq_clearPending position right rightResolved + hrightSupport] + simpa [LazyRevealProbe.State.clearPending] using hrevealed + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_runDirectResolvedObserve_any_at + (position : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + [ObserverDooms table observe] [ObserverSynchronized table observe] + (hneutral : ObserverPositionNeutralAt table position observe) : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure true + | some resolved => + runDirectResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (runDirectResolvedObserve observe context fuel table computation) := by + let ensured : DeferredContext := + { context with state := context.state.ensure (.position position) } + have hensuredValid : ensured.Valid := hvalid.ensure (.position position) + have hensuredCompletable : DeferredCompletable table ensured := + hcompletable.ensure (.position position) + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hensuredStarts : StartTableAgrees ensured.state table := + hstarts.ensure (.position position) + have hview : FinalizationViewEq table context ensured := + finalizationViewEq_of_deferredCompletion_iff hvalid hensuredValid hstarts hensuredStarts rfl + hcompletable (fun _ => Iff.rfl) + have hcontext : FinalizationContextEq table (some context) (some ensured) := + ⟨hview, hvalid, hensuredValid, hcompletable⟩ + have hcontextSymm : FinalizationContextEq table (some ensured) (some context) := + ⟨hview.symm, hensuredValid, hvalid, hensuredCompletable⟩ + calc + _ = evalDist (do + let resolved ← resolveDeferredPositionValue position ensured + match resolved with + | none => pure true + | some resolved => + runDirectResolvedObserve observe resolved.toDeferredContext fuel table computation) := + evalDist_resolveDeferredPositionValue_then_runDirectResolvedObserve_eq_of_synchronized + table position computation context ensured fuel hcontext rfl rfl + _ = evalDist (runDirectResolvedObserve observe ensured fuel table computation) := + evalDist_resolveDeferredPositionValue_then_runDirectResolvedObserve + (observe := observe) position computation ensured fuel table hensuredValid + hensuredCompletable (by simp [ensured, LazyRevealProbe.State.ensure]) hneutral + _ = _ := + evalDist_runDirectResolvedObserve_eq_of_finalizationSynchronized computation ensured context + fuel table hcontextSymm rfl rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedFinalization.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedFinalization.lean new file mode 100644 index 00000000..6f324ef2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedFinalization.lean @@ -0,0 +1,704 @@ +import SphincsSecurity.Proof.OtsProbeResolvedSchedule +import SphincsSecurity.Proof.OtsProbeChronologicalTerminal + +/-! +# Finalization equivalence for one-time layer resolution + +The materializing chronological signer and the private deferred scheduler expose the same values +and retain the same clean completion distribution. This file lifts that relation through the two +finite families that resolve a selected one-time layer. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def FinalizationContextValueEq (table : OtsSecretIndex → HashOutput) : + Option (DeferredContext × α) → Option (DeferredContext × α) → Prop + | none, none => True + | some left, some right => + left.2 = right.2 ∧ + FinalizationContextEq table (some left.1) (some right.1) + | _, _ => False + +def FinalizationRunContextValueEq (table : OtsSecretIndex → HashOutput) + (fuel : Nat) (initialOrdinaryCache : QueryCache HashSpec) : + Option (ResolvedRunResult (α × SplitHashCache)) → + Option (DeferredContext × α) → Prop + | none, none => True + | some left, some right => + left.value.1 = right.2 ∧ + FinalizationContextEq table (some left.context) (some right.1) ∧ + left.remaining = fuel ∧ left.table = table ∧ + ordinaryQueryCache left.value.2 = initialOrdinaryCache + | _, _ => False + +def FinalizationRunResolutionEq (table : OtsSecretIndex → HashOutput) + (fuel : Nat) (initialOrdinaryCache : QueryCache HashSpec) : + Option (ResolvedRunResult (Digest × SplitHashCache)) → + Option DeferredResolution → Prop + | none, none => True + | some left, some right => + left.value.1 = truncateHash right.output ∧ + FinalizationContextEq table (some left.context) (some right.toDeferredContext) ∧ + left.remaining = fuel ∧ left.table = table ∧ + ordinaryQueryCache left.value.2 = initialOrdinaryCache + | _, _ => False + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_revealPosition_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (position : Position) + (left right : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hview : FinalizationViewEq table left right) + (hleftValid : left.Valid) (hrightValid : right.Valid) + (hleftCompletable : DeferredCompletable table left) : + RelTriple + (runResolvedFromTable left fuel table ((revealPosition position).run cache)) + (resolveDeferredReveal table position right) + (FinalizationRunResolutionEq table fuel (ordinaryQueryCache cache)) := by + rw [runResolvedFromTable_revealPosition] + rw [← bind_pure (resolveDeferredReveal table position right)] + have hresolved := relTriple_resolveDeferredReveal_of_finalizationViewEq table position left + right hview hleftValid hrightValid hleftCompletable + have hresolvedSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolved + (fun result => result ∈ support (resolveDeferredReveal table position left)) + (fun result hresult => hresult) + apply relTriple_bind hresolvedSupport + intro leftResolved rightResolved hrelation + rcases hrelation with ⟨hrelation, hleftSupport⟩ + cases leftResolved with + | none => + cases rightResolved with + | none => exact relTriple_pure_pure trivial + | some rightResolved => simp [FinalizationResolutionEq] at hrelation + | some leftResolved => + cases rightResolved with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResolved => + have hmaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition left position leftResolved) := by + rcases hrelation.2.2.2.2 with ⟨completion, hcompletion⟩ + exact ⟨completion, + (deferredCompletion_materializeResolvedReveal_iff position leftResolved + hleftValid hview.leftStarts hleftSupport).mpr hcompletion⟩ + have hmaterializedView := finalizationViewEq_materializeResolvedReveal position + leftResolved hleftValid hview.leftStarts hleftSupport hmaterializedCompletable + have hresultValid := hleftValid.of_resolveDeferredReveal table position leftResolved + hleftSupport + have hstateValues := resolveDeferredReveal_preserves_state_values table position left + leftResolved hleftSupport + have hresolvedValue := resolveDeferredReveal_resolves table position left leftResolved + hleftSupport + have hmaterializedValid : + (materializeResolvedPosition left position leftResolved).Valid := + hleftValid.materializeResolvedPosition_of position leftResolved hresultValid + hstateValues hresolvedValue + apply relTriple_pure_pure + refine ⟨?_, ?_, rfl, rfl, ordinaryQueryCache_update_hidden cache + (.position position) leftResolved.output⟩ + · simpa using congrArg truncateHash hrelation.1 + · exact ⟨hmaterializedView.trans hrelation.2.1, hmaterializedValid, + hrelation.2.2.2.1, hmaterializedCompletable⟩ + +theorem relTriple_runResolvedFromTable_revealChainStart_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (left right : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hview : FinalizationViewEq table left right) + (hleftValid : left.Valid) (hrightValid : right.Valid) + (hleftCompletable : DeferredCompletable table left) : + RelTriple + (runResolvedFromTable left fuel table + ((revealChainStart index.lay index.tree index.leafIdx index.chainIdx).run cache)) + (pure (resolveDeferredChainStart table index right) : + ProbComp (Option DeferredResolution)) + (FinalizationRunResolutionEq table fuel (ordinaryQueryCache cache)) := by + rw [revealChainStart, runResolvedFromTable_revealCoordinate] + have hresolved := relTriple_resolveDeferredChainStart_of_finalizationViewEq table index left + right hview hleftValid hrightValid hleftCompletable + have hresolvedSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolved + (fun result => result ∈ support (pure (resolveDeferredChainStart table index left))) + (fun result hresult => hresult) + change RelTriple + ((pure (resolveDeferredChainStart table index left) : + ProbComp (Option DeferredResolution)) >>= fun resolved => + match resolved with + | none => pure none + | some resolved => pure (some ⟨ + materializeResolvedChainStart left index resolved, + fuel, + (truncateHash resolved.output, + Function.update cache (.hidden index.coordinate) (some resolved.output)), + table⟩)) + ((pure (resolveDeferredChainStart table index right) : + ProbComp (Option DeferredResolution)) >>= pure) + (FinalizationRunResolutionEq table fuel (ordinaryQueryCache cache)) + apply relTriple_bind hresolvedSupport + intro leftResolved rightResolved hrelation + rcases hrelation with ⟨hrelation, hleftSupport⟩ + cases leftResolved with + | none => + cases rightResolved with + | none => exact relTriple_pure_pure trivial + | some rightResolved => simp [FinalizationResolutionEq] at hrelation + | some leftResolved => + cases rightResolved with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResolved => + have hleftResult : resolveDeferredChainStart table index left = some leftResolved := by + simpa using hleftSupport.symm + have hmaterializedCompletable := hleftCompletable.materializeResolvedChainStart + hview.leftStarts index leftResolved hleftResult + have hmaterializedView := finalizationViewEq_materializeResolvedChainStart index + leftResolved hleftValid hview.leftStarts hleftResult hmaterializedCompletable + have hmaterializedValid : + (materializeResolvedChainStart left index leftResolved).Valid := by + unfold materializeResolvedChainStart + rw [resolveDeferredChainStart_deferred_values_eq table index left leftResolved + hleftResult] + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + exact hleftValid.materialize_chainStart lay tree leafIdx chainIdx leftResolved.output + apply relTriple_pure_pure + refine ⟨?_, ?_, rfl, rfl, ordinaryQueryCache_update_hidden cache index.coordinate + leftResolved.output⟩ + · simpa using congrArg truncateHash hrelation.1 + · exact ⟨hmaterializedView.trans hrelation.2.1, hmaterializedValid, + hrelation.2.2.2.1, hmaterializedCompletable⟩ + +theorem relTriple_runResolvedFromTable_revealPrivateChainValue_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) + (left right : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hview : FinalizationViewEq table left right) + (hleftValid : left.Valid) (hrightValid : right.Valid) + (hleftCompletable : DeferredCompletable table left) : + RelTriple + (runResolvedFromTable left fuel table + ((revealCoordinate (chainValueCoordinate lay tree leafIdx chainIdx digit)).run cache)) + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx digit.val + (by have := digit.isLt; omega) right) + (FinalizationRunResolutionEq table fuel (ordinaryQueryCache cache)) := by + by_cases hzero : digit.val = 0 + · simpa [chainValueCoordinate, hzero, revealChainStart, resolveDeferredChainPrefix] using + (relTriple_runResolvedFromTable_revealChainStart_of_finalizationViewEq table + ⟨lay, tree, leafIdx, chainIdx⟩ left right fuel cache hview hleftValid hrightValid + hleftCompletable) + · let step : ChainStep := ⟨digit.val - 1, by + have := digit.isLt + omega⟩ + have hstep : step.val + 1 = digit.val := by + simp only [step] + omega + simpa [chainValueCoordinate, hzero, revealPosition, step, resolveDeferredReveal, + ResolvableOtsPosition, resolveDeferredPosition, hstep] using + (relTriple_runResolvedFromTable_revealPosition_of_finalizationViewEq table + (.chain lay tree leafIdx chainIdx step) left right fuel cache hview hleftValid + hrightValid hleftCompletable) + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_revealPrivateChainFamily_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ {n : Nat} (family : Fin n → ChainIndex) + (digits : Fin n → Digit) (left right : DeferredContext) (fuel : Nat) + (cache : SplitHashCache), + FinalizationViewEq table left right → left.Valid → right.Valid → + DeferredCompletable table left → + RelTriple + (runResolvedFromTable left fuel table + ((sequenceFin fun position => revealCoordinate + (chainValueCoordinate lay tree leafIdx (family position) + (digits position))).run cache)) + (resolveDeferredSelectedChainFamily table lay tree leafIdx family digits right) + (FinalizationRunContextValueEq table fuel (ordinaryQueryCache cache)) + | 0, family, digits, left, right, fuel, cache, hview, hleftValid, hrightValid, + hleftCompletable => by + simp [sequenceFin, resolveDeferredSelectedChainFamily, runResolvedFromTable, + FinalizationRunContextValueEq, FinalizationContextEq, hview, hleftValid, + hrightValid, hleftCompletable] + | n + 1, family, digits, left, right, fuel, cache, hview, hleftValid, hrightValid, + hleftCompletable => by + rw [sequenceFin, StateT.run_bind, runResolvedFromTable_bind, + resolveDeferredSelectedChainFamily] + have hhead := + relTriple_runResolvedFromTable_revealPrivateChainValue_of_finalizationViewEq table lay + tree leafIdx (family 0) (digits 0) left right fuel cache hview hleftValid hrightValid + hleftCompletable + apply relTriple_bind hhead + intro leftHead rightHead hheadRelation + cases leftHead with + | none => + cases rightHead with + | none => exact relTriple_pure_pure trivial + | some rightHead => simp [FinalizationRunResolutionEq] at hheadRelation + | some leftHead => + cases rightHead with + | none => simp [FinalizationRunResolutionEq] at hheadRelation + | some rightHead => + simp only + rw [hheadRelation.2.2.1, hheadRelation.2.2.2.1] + rw [StateT.run_bind, runResolvedFromTable_bind] + have htail := + relTriple_runResolvedFromTable_revealPrivateChainFamily_of_finalizationViewEq + table lay tree leafIdx (fun position : Fin n => family position.succ) + (fun position : Fin n => digits position.succ) leftHead.context + rightHead.toDeferredContext + fuel leftHead.value.2 hheadRelation.2.1.1 hheadRelation.2.1.2.1 + hheadRelation.2.1.2.2.1 hheadRelation.2.1.2.2.2 + apply relTriple_bind htail + intro leftTail rightTail htailRelation + cases leftTail with + | none => + cases rightTail with + | none => exact relTriple_pure_pure trivial + | some rightTail => simp [FinalizationRunContextValueEq] at htailRelation + | some leftTail => + cases rightTail with + | none => simp [FinalizationRunContextValueEq] at htailRelation + | some rightTail => + apply relTriple_pure_pure + refine ⟨?_, htailRelation.2.1, htailRelation.2.2.1, + htailRelation.2.2.2.1, ?_⟩ + · funext position + refine Fin.cases ?_ (fun tailPosition => ?_) position + · exact hheadRelation.1 + · exact congrFun htailRelation.1 tailPosition + · exact htailRelation.2.2.2.2.trans hheadRelation.2.2.2.2 + +theorem relTriple_runResolvedFromTable_revealPrivateTreeNode_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) (hlevel : level ≤ maxLayerHeight) + (hspan : 2 ^ level * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) + (left right : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hview : FinalizationViewEq table left right) + (hleftValid : left.Valid) (hrightValid : right.Valid) + (hleftCompletable : DeferredCompletable table left) : + RelTriple + (runResolvedFromTable left fuel table + ((match level with + | 0 => revealPosition (.leaf lay tree (leafOfNat nodeIdx)) + | current + 1 => + if hcurrent : current < maxLayerHeight then + revealPosition (.node lay tree ⟨current, hcurrent⟩ (leafOfNat nodeIdx)) + else pure 0).run cache)) + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel right) + (FinalizationRunResolutionEq table fuel (ordinaryQueryCache cache)) := by + cases level with + | zero => + simpa [resolveDeferredReveal, ResolvableOtsPosition, resolveDeferredPosition, + resolveDeferredTreeNode] using + (relTriple_runResolvedFromTable_revealPosition_of_finalizationViewEq table + (.leaf lay tree (leafOfNat nodeIdx)) left right fuel cache hview hleftValid + hrightValid hleftCompletable) + | succ current => + have hcurrent : current < maxLayerHeight := by omega + have hnodeLt : nodeIdx < 2 ^ maxLayerHeight := by + have hpow : 0 < 2 ^ (current + 1) := pow_pos (by omega) _ + nlinarith + have hnodeVal : (leafOfNat nodeIdx).val = nodeIdx := by + simp [leafOfNat, Nat.mod_eq_of_lt hnodeLt] + have hresolvable : ResolvableOtsPosition + (.node lay tree ⟨current, hcurrent⟩ (leafOfNat nodeIdx)) := by + simp [ResolvableOtsPosition, hnodeVal] + exact hspan + simpa [hcurrent, resolveDeferredReveal, hresolvable, resolveDeferredPosition, + hnodeVal] using + (relTriple_runResolvedFromTable_revealPosition_of_finalizationViewEq table + (.node lay tree ⟨current, hcurrent⟩ (leafOfNat nodeIdx)) left right fuel cache + hview hleftValid hrightValid hleftCompletable) + +theorem relTriple_runResolvedFromTable_revealPrivateLayerPathNode_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (level : Fin maxLayerHeight) + (left right : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hview : FinalizationViewEq table left right) + (hleftValid : left.Valid) (hrightValid : right.Valid) + (hleftCompletable : DeferredCompletable table left) : + RelTriple + (runResolvedFromTable left fuel table + ((match level.val with + | 0 => revealPosition (.leaf lay tree + (leafOfNat (Nat.xor leafIdx.val 1))) + | current + 1 => + if hcurrent : current < maxLayerHeight then + revealPosition (.node lay tree ⟨current, hcurrent⟩ + (leafOfNat (Nat.xor (leafIdx.val / 2 ^ (current + 1)) 1))) + else pure 0).run cache)) + (resolveDeferredTreeNode table lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + (by have := level.isLt; omega) right) + (FinalizationRunResolutionEq table fuel (ordinaryQueryCache cache)) := by + have hcomputation : + (match level.val with + | 0 => revealPosition (.leaf lay tree + (leafOfNat (Nat.xor leafIdx.val 1))) + | current + 1 => + if hcurrent : current < maxLayerHeight then + revealPosition (.node lay tree ⟨current, hcurrent⟩ + (leafOfNat (Nat.xor (leafIdx.val / 2 ^ (current + 1)) 1))) + else pure 0) = + (match level.val with + | 0 => revealPosition (.leaf lay tree + (leafOfNat (Nat.xor (leafIdx.val / 2 ^ level.val) 1))) + | current + 1 => + if hcurrent : current < maxLayerHeight then + revealPosition (.node lay tree ⟨current, hcurrent⟩ + (leafOfNat (Nat.xor (leafIdx.val / 2 ^ level.val) 1))) + else pure 0) := by + cases hvalue : level.val <;> simp + rw [hcomputation] + exact + relTriple_runResolvedFromTable_revealPrivateTreeNode_of_finalizationViewEq table lay tree + level.val (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + (by have := level.isLt; omega) + (FtsProbeSimulation.sibling_node_bound maxLayerHeight leafIdx.val level.val + (by have := level.isLt; omega) leafIdx.isLt) + left right fuel cache hview hleftValid hrightValid hleftCompletable + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_revealPrivateLayerPathFamily_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ {n : Nat} (family : Fin n → Fin maxLayerHeight) + (left right : DeferredContext) (fuel : Nat) (cache : SplitHashCache), + FinalizationViewEq table left right → left.Valid → right.Valid → + DeferredCompletable table left → + RelTriple + (runResolvedFromTable left fuel table + ((sequenceFin fun position => + if (family position).val < layerHeight lay then + match (family position).val with + | 0 => revealPosition (.leaf lay tree + (leafOfNat (Nat.xor leafIdx.val 1))) + | current + 1 => + if hcurrent : current < maxLayerHeight then + revealPosition (.node lay tree ⟨current, hcurrent⟩ + (leafOfNat + (Nat.xor (leafIdx.val / 2 ^ (current + 1)) 1))) + else pure 0 + else pure 0).run cache)) + (resolveDeferredLayerPathFamily table lay tree leafIdx family right) + (FinalizationRunContextValueEq table fuel (ordinaryQueryCache cache)) + | 0, family, left, right, fuel, cache, hview, hleftValid, hrightValid, + hleftCompletable => by + simp [sequenceFin, resolveDeferredLayerPathFamily, runResolvedFromTable, + FinalizationRunContextValueEq, FinalizationContextEq, hview, hleftValid, + hrightValid, hleftCompletable] + | n + 1, family, left, right, fuel, cache, hview, hleftValid, hrightValid, + hleftCompletable => by + rw [sequenceFin, StateT.run_bind, runResolvedFromTable_bind, + resolveDeferredLayerPathFamily] + by_cases hinLayer : (family 0).val < layerHeight lay + · simp only [hinLayer, ↓reduceIte] + have hhead := + relTriple_runResolvedFromTable_revealPrivateLayerPathNode_of_finalizationViewEq + table lay tree leafIdx (family 0) left right fuel cache hview hleftValid + hrightValid hleftCompletable + apply relTriple_bind hhead + intro leftHead rightHead hheadRelation + cases leftHead with + | none => + cases rightHead with + | none => exact relTriple_pure_pure trivial + | some rightHead => simp [FinalizationRunResolutionEq] at hheadRelation + | some leftHead => + cases rightHead with + | none => simp [FinalizationRunResolutionEq] at hheadRelation + | some rightHead => + simp only + rw [hheadRelation.2.2.1, hheadRelation.2.2.2.1] + rw [StateT.run_bind, runResolvedFromTable_bind] + have htail := + relTriple_runResolvedFromTable_revealPrivateLayerPathFamily_of_finalizationViewEq + table lay tree leafIdx (fun position : Fin n => family position.succ) + leftHead.context rightHead.toDeferredContext fuel leftHead.value.2 + hheadRelation.2.1.1 hheadRelation.2.1.2.1 + hheadRelation.2.1.2.2.1 hheadRelation.2.1.2.2.2 + apply relTriple_bind htail + intro leftTail rightTail htailRelation + cases leftTail with + | none => + cases rightTail with + | none => exact relTriple_pure_pure trivial + | some rightTail => + simp [FinalizationRunContextValueEq] at htailRelation + | some leftTail => + cases rightTail with + | none => simp [FinalizationRunContextValueEq] at htailRelation + | some rightTail => + apply relTriple_pure_pure + refine ⟨?_, htailRelation.2.1, htailRelation.2.2.1, + htailRelation.2.2.2.1, ?_⟩ + · funext position + refine Fin.cases ?_ (fun tailPosition => ?_) position + · exact hheadRelation.1 + · exact congrFun htailRelation.1 tailPosition + · exact htailRelation.2.2.2.2.trans hheadRelation.2.2.2.2 + · rw [dif_neg hinLayer] + simp only [hinLayer, ↓reduceIte] + have hpure : + runResolvedFromTable left fuel table + ((pure 0 : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Digest).run cache) = + pure (some ⟨left, fuel, (0, cache), table⟩) := by + simp [StateT.run_pure, runResolvedFromTable] + rw [hpure] + simp only [pure_bind] + rw [StateT.run_bind, runResolvedFromTable_bind] + have htail := + relTriple_runResolvedFromTable_revealPrivateLayerPathFamily_of_finalizationViewEq + table lay tree leafIdx (fun position : Fin n => family position.succ) + left right fuel cache hview hleftValid hrightValid hleftCompletable + apply relTriple_bind htail + intro leftTail rightTail htailRelation + cases leftTail with + | none => + cases rightTail with + | none => exact relTriple_pure_pure trivial + | some rightTail => simp [FinalizationRunContextValueEq] at htailRelation + | some leftTail => + cases rightTail with + | none => simp [FinalizationRunContextValueEq] at htailRelation + | some rightTail => + apply relTriple_pure_pure + refine ⟨?_, htailRelation.2.1, htailRelation.2.2.1, + htailRelation.2.2.2.1, htailRelation.2.2.2.2⟩ + funext position + refine Fin.cases rfl (fun tailPosition => ?_) position + exact congrFun htailRelation.1 tailPosition + +theorem relTriple_runResolvedFromTable_revealPrivateLayerValues_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) (left right : DeferredContext) + (fuel : Nat) (cache : SplitHashCache) + (hview : FinalizationViewEq table left right) + (hleftValid : left.Valid) (hrightValid : right.Valid) + (hleftCompletable : DeferredCompletable table left) : + RelTriple + (runResolvedFromTable left fuel table + ((revealPrivateLayerValues index lay encoding).run cache)) + (resolveDeferredLayerValues table index lay encoding right) + (FinalizationRunContextValueEq table fuel (ordinaryQueryCache cache)) := by + rw [revealPrivateLayerValues, resolveDeferredLayerValues, + StateT.run_bind, runResolvedFromTable_bind] + have hchains := + relTriple_runResolvedFromTable_revealPrivateChainFamily_of_finalizationViewEq table lay + (treeIndexAt index lay) (leafIndexAt index lay) + (fun chainIdx : ChainIndex => chainIdx) encoding left right fuel cache hview + hleftValid hrightValid hleftCompletable + apply relTriple_bind hchains + intro leftChains rightChains hchainsRelation + cases leftChains with + | none => + cases rightChains with + | none => exact relTriple_pure_pure trivial + | some rightChains => simp [FinalizationRunContextValueEq] at hchainsRelation + | some leftChains => + cases rightChains with + | none => simp [FinalizationRunContextValueEq] at hchainsRelation + | some rightChains => + simp only + rw [hchainsRelation.2.2.1, hchainsRelation.2.2.2.1] + rw [StateT.run_bind, runResolvedFromTable_bind] + have hpath := + relTriple_runResolvedFromTable_revealPrivateLayerPathFamily_of_finalizationViewEq + table lay (treeIndexAt index lay) (leafIndexAt index lay) + (fun level : Fin maxLayerHeight => level) leftChains.context rightChains.1 + fuel leftChains.value.2 hchainsRelation.2.1.1 + hchainsRelation.2.1.2.1 hchainsRelation.2.1.2.2.1 + hchainsRelation.2.1.2.2.2 + apply relTriple_bind hpath + intro leftPath rightPath hpathRelation + cases leftPath with + | none => + cases rightPath with + | none => exact relTriple_pure_pure trivial + | some rightPath => simp [FinalizationRunContextValueEq] at hpathRelation + | some leftPath => + cases rightPath with + | none => simp [FinalizationRunContextValueEq] at hpathRelation + | some rightPath => + apply relTriple_pure_pure + exact ⟨by rw [hchainsRelation.1, hpathRelation.1], + hpathRelation.2.1, hpathRelation.2.2.1, + hpathRelation.2.2.2.1, + hpathRelation.2.2.2.2.trans hchainsRelation.2.2.2.2⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_resolveDeferredSelectedChainFamily_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ {n : Nat} (family : Fin n → ChainIndex) + (digits : Fin n → Digit) (left right : DeferredContext), + FinalizationViewEq table left right → left.Valid → right.Valid → + DeferredCompletable table left → + RelTriple + (resolveDeferredSelectedChainFamily table lay tree leafIdx family digits left) + (resolveDeferredSelectedChainFamily table lay tree leafIdx family digits right) + (FinalizationContextValueEq table) + | 0, family, digits, left, right, hview, hleftValid, hrightValid, + hleftCompletable => by + simp only [resolveDeferredSelectedChainFamily] + apply relTriple_pure_pure + exact ⟨rfl, hview, hleftValid, hrightValid, hleftCompletable⟩ + | n + 1, family, digits, left, right, hview, hleftValid, hrightValid, + hleftCompletable => by + rw [resolveDeferredSelectedChainFamily, resolveDeferredSelectedChainFamily] + apply relTriple_bind + (relTriple_resolveDeferredChainPrefix_of_finalizationViewEq table lay tree leafIdx + (family 0) (digits 0).val (by have := (digits 0).isLt; omega) left right hview + hleftValid hrightValid hleftCompletable) + intro leftHead rightHead hhead + cases leftHead with + | none => + cases rightHead with + | none => simp [FinalizationContextValueEq] + | some rightHead => simp [FinalizationResolutionEq] at hhead + | some leftHead => + cases rightHead with + | none => simp [FinalizationResolutionEq] at hhead + | some rightHead => + apply relTriple_bind + (relTriple_resolveDeferredSelectedChainFamily_of_finalizationViewEq table lay + tree leafIdx (fun index : Fin n => family index.succ) + (fun index : Fin n => digits index.succ) leftHead.toDeferredContext + rightHead.toDeferredContext hhead.2.1 hhead.2.2.1 hhead.2.2.2.1 + hhead.2.2.2.2) + intro leftTail rightTail htail + cases leftTail with + | none => + cases rightTail with + | none => simp [FinalizationContextValueEq] + | some rightTail => simp [FinalizationContextValueEq] at htail + | some leftTail => + cases rightTail with + | none => simp [FinalizationContextValueEq] at htail + | some rightTail => + apply relTriple_pure_pure + refine ⟨?_, htail.2⟩ + funext position + refine Fin.cases ?_ (fun tailPosition => ?_) position + · simpa using congrArg truncateHash hhead.1 + · exact congrFun htail.1 tailPosition + +set_option maxRecDepth 100000 in +theorem relTriple_resolveDeferredLayerPathFamily_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ {n : Nat} (family : Fin n → Fin maxLayerHeight) + (left right : DeferredContext), + FinalizationViewEq table left right → left.Valid → right.Valid → + DeferredCompletable table left → + RelTriple + (resolveDeferredLayerPathFamily table lay tree leafIdx family left) + (resolveDeferredLayerPathFamily table lay tree leafIdx family right) + (FinalizationContextValueEq table) + | 0, family, left, right, hview, hleftValid, hrightValid, hleftCompletable => by + simp only [resolveDeferredLayerPathFamily] + apply relTriple_pure_pure + exact ⟨rfl, hview, hleftValid, hrightValid, hleftCompletable⟩ + | n + 1, family, left, right, hview, hleftValid, hrightValid, + hleftCompletable => by + rw [resolveDeferredLayerPathFamily, resolveDeferredLayerPathFamily] + by_cases hinLayer : (family 0).val < layerHeight lay + · simp only [hinLayer, ↓reduceDIte] + apply relTriple_bind + (relTriple_resolveDeferredTreeNode_of_finalizationViewEq table lay tree + (family 0).val (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) left right hview hleftValid hrightValid + hleftCompletable) + intro leftHead rightHead hhead + cases leftHead with + | none => + cases rightHead with + | none => simp [FinalizationContextValueEq] + | some rightHead => simp [FinalizationResolutionEq] at hhead + | some leftHead => + cases rightHead with + | none => simp [FinalizationResolutionEq] at hhead + | some rightHead => + apply relTriple_bind + (relTriple_resolveDeferredLayerPathFamily_of_finalizationViewEq table lay tree + leafIdx (fun position : Fin n => family position.succ) + leftHead.toDeferredContext rightHead.toDeferredContext hhead.2.1 + hhead.2.2.1 hhead.2.2.2.1 hhead.2.2.2.2) + intro leftTail rightTail htail + cases leftTail with + | none => + cases rightTail with + | none => simp [FinalizationContextValueEq] + | some rightTail => simp [FinalizationContextValueEq] at htail + | some leftTail => + cases rightTail with + | none => simp [FinalizationContextValueEq] at htail + | some rightTail => + apply relTriple_pure_pure + refine ⟨?_, htail.2⟩ + funext position + refine Fin.cases ?_ (fun tailPosition => ?_) position + · simpa using congrArg truncateHash hhead.1 + · exact congrFun htail.1 tailPosition + · simp only [hinLayer, ↓reduceDIte] + apply relTriple_bind + (relTriple_resolveDeferredLayerPathFamily_of_finalizationViewEq table lay tree leafIdx + (fun position : Fin n => family position.succ) left right hview hleftValid + hrightValid hleftCompletable) + intro leftTail rightTail htail + cases leftTail with + | none => + cases rightTail with + | none => simp [FinalizationContextValueEq] + | some rightTail => simp [FinalizationContextValueEq] at htail + | some leftTail => + cases rightTail with + | none => simp [FinalizationContextValueEq] at htail + | some rightTail => + apply relTriple_pure_pure + refine ⟨?_, htail.2⟩ + funext position + refine Fin.cases rfl (fun tailPosition => ?_) position + exact congrFun htail.1 tailPosition + +theorem relTriple_resolveDeferredLayerValues_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) (left right : DeferredContext) + (hview : FinalizationViewEq table left right) + (hleftValid : left.Valid) (hrightValid : right.Valid) + (hleftCompletable : DeferredCompletable table left) : + RelTriple + (resolveDeferredLayerValues table index lay encoding left) + (resolveDeferredLayerValues table index lay encoding right) + (FinalizationContextValueEq table) := by + rw [resolveDeferredLayerValues, resolveDeferredLayerValues] + apply relTriple_bind + (relTriple_resolveDeferredSelectedChainFamily_of_finalizationViewEq table lay + (treeIndexAt index lay) (leafIndexAt index lay) + (fun chainIdx : ChainIndex => chainIdx) encoding left right hview hleftValid hrightValid + hleftCompletable) + intro leftChains rightChains hchains + cases leftChains with + | none => + cases rightChains with + | none => simp [FinalizationContextValueEq] + | some rightChains => simp [FinalizationContextValueEq] at hchains + | some leftChains => + cases rightChains with + | none => simp [FinalizationContextValueEq] at hchains + | some rightChains => + apply relTriple_bind + (relTriple_resolveDeferredLayerPathFamily_of_finalizationViewEq table lay + (treeIndexAt index lay) (leafIndexAt index lay) + (fun level : Fin maxLayerHeight => level) leftChains.1 rightChains.1 + hchains.2.1 hchains.2.2.1 hchains.2.2.2.1 hchains.2.2.2.2) + intro leftPath rightPath hpath + cases leftPath with + | none => + cases rightPath with + | none => simp [FinalizationContextValueEq] + | some rightPath => simp [FinalizationContextValueEq] at hpath + | some leftPath => + cases rightPath with + | none => simp [FinalizationContextValueEq] at hpath + | some rightPath => + apply relTriple_pure_pure + exact ⟨by rw [hchains.1, hpath.1], hpath.2⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateCommutation.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateCommutation.lean new file mode 100644 index 00000000..20084856 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateCommutation.lean @@ -0,0 +1,417 @@ +import SphincsSecurity.Proof.OtsProbeResolvedPrivateSampling + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +structure RevealedResolution where + context : DeferredContext + output : HashOutput + +noncomputable def resolvePositionValuesInOrder + (first second : Position) (context : DeferredContext) : + ProbComp (Option RevealedResolution) := do + let firstResolved ← resolveDeferredPositionValue first context + match firstResolved with + | none => pure none + | some firstResolved => do + let secondResolved ← + resolveDeferredPositionValue second firstResolved.toDeferredContext + match secondResolved with + | none => pure none + | some secondResolved => + pure (some ⟨secondResolved.toDeferredContext, secondResolved.output⟩) + +noncomputable def resolvePositionValuesSwapped + (first second : Position) (context : DeferredContext) : + ProbComp (Option RevealedResolution) := do + let secondResolved ← resolveDeferredPositionValue second context + match secondResolved with + | none => pure none + | some secondResolved => do + let firstResolved ← + resolveDeferredPositionValue first secondResolved.toDeferredContext + match firstResolved with + | none => pure none + | some firstResolved => + pure (some ⟨firstResolved.toDeferredContext, secondResolved.output⟩) + +theorem clearPending_comm_position + (state : LazyRevealProbe.State Coordinate) (first second : Position) : + (state.clearPending (.position first)).clearPending (.position second) = + (state.clearPending (.position second)).clearPending (.position first) := by + exact clearPending_comm state (.position first) (.position second) + +noncomputable def deferredPositionOutput (position : Position) + (context : DeferredContext) : ProbComp HashOutput := + match context.positionValue position with + | some output => pure output + | none => LazyRevealProbe.sampleHashOutput + +def completePrivatePosition (position : Position) (context : DeferredContext) + (output : HashOutput) : DeferredResolution := + ⟨{ state := context.state.clearPending (.position position) + values := context.values.install position output }, output⟩ + +noncomputable def resolvePrivatePositionWithOutput (position : Position) + (context : DeferredContext) (output : HashOutput) : + ProbComp (Option DeferredResolution) := + if context.state.hitAt (.position position) output then + pure none + else + pure (some (completePrivatePosition position context output)) + +theorem resolveDeferredPositionValue_eq_bind_output + (position : Position) (context : DeferredContext) : + resolveDeferredPositionValue position context = (do + let output ← deferredPositionOutput position context + resolvePrivatePositionWithOutput position context output) := by + unfold resolveDeferredPositionValue deferredPositionOutput + resolvePrivatePositionWithOutput completePrivatePosition + cases hstate : context.state.values (.position position) with + | some output => + simp [DeferredContext.positionValue, hstate] + | none => + cases hvalue : context.values position with + | some output => + have hupdate : context.values.install position output = context.values := by + unfold DeferredStructuralValues.install + conv_lhs => rw [← hvalue] + exact Function.update_eq_self _ _ + simp [DeferredContext.positionValue, hstate, hvalue, hupdate] + | none => + simp [DeferredContext.positionValue, hstate, hvalue] + +theorem deferredPositionOutput_completePrivatePosition_of_ne + (first second : Position) (context : DeferredContext) (output : HashOutput) + (hne : first ≠ second) : + deferredPositionOutput second + (completePrivatePosition first context output).toDeferredContext = + deferredPositionOutput second context := by + unfold deferredPositionOutput DeferredContext.positionValue completePrivatePosition + have hposition : second ≠ first := Ne.symm hne + simp [LazyRevealProbe.State.clearPending, DeferredStructuralValues.install, + Function.update_of_ne hposition] + +theorem hitAt_completePrivatePosition_of_ne + (first second : Position) (context : DeferredContext) (firstOutput secondOutput : HashOutput) + (hne : first ≠ second) : + (completePrivatePosition first context firstOutput).state.hitAt + (.position second) secondOutput = + context.state.hitAt (.position second) secondOutput := by + unfold completePrivatePosition + exact propext (hitAt_clearPending_of_ne context.state (.position first) (.position second) + secondOutput (by + intro heq + exact hne (Coordinate.position.inj heq).symm)) + +theorem completePrivatePosition_comm + (first second : Position) (context : DeferredContext) + (firstOutput secondOutput : HashOutput) (hne : first ≠ second) : + (completePrivatePosition second + (completePrivatePosition first context firstOutput).toDeferredContext + secondOutput).toDeferredContext = + (completePrivatePosition first + (completePrivatePosition second context secondOutput).toDeferredContext + firstOutput).toDeferredContext := by + unfold completePrivatePosition + change + ({ state := (context.state.clearPending (.position first)).clearPending (.position second) + values := (context.values.install first firstOutput).install second secondOutput } : + DeferredContext) = + ({ state := (context.state.clearPending (.position second)).clearPending (.position first) + values := (context.values.install second secondOutput).install first firstOutput } : + DeferredContext) + rw [clearPending_comm_position] + unfold DeferredStructuralValues.install + rw [Function.update_comm hne] + +theorem completePrivatePosition_resolved_eq + (position : Position) (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) : + completePrivatePosition position result.toDeferredContext result.output = result := by + have hstate := resolveDeferredPositionValue_state_eq_clearPending position context result + hresult + have hvalue := resolveDeferredPositionValue_installs position context result hresult + rcases result with ⟨⟨state, values⟩, output⟩ + simp only at hstate hvalue ⊢ + subst state + have hupdate : values.install position output = values := by + unfold DeferredStructuralValues.install + conv_lhs => rw [← hvalue] + exact Function.update_eq_self _ _ + unfold completePrivatePosition + rw [clearPending_idem, hupdate] + +theorem resolveDeferredPositionValue_of_resolved + (position : Position) (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) : + resolveDeferredPositionValue position result.toDeferredContext = pure (some result) := by + rw [resolveDeferredPositionValue_eq_bind_output] + have hknown := resolveDeferredPositionValue_resolves position context result hresult + have hclean : ¬result.state.hitAt (.position position) result.output := by + have hstate := resolveDeferredPositionValue_state_eq_clearPending position context result + hresult + rw [hstate] + exact not_hitAt_clearPending_self context.state (.position position) result.output + simp [deferredPositionOutput, hknown, resolvePrivatePositionWithOutput, hclean, + completePrivatePosition_resolved_eq position context result hresult] + +theorem evalDist_resolvePositionValues_comm_self + (position : Position) (context : DeferredContext) : + evalDist (resolvePositionValuesInOrder position position context) = + evalDist (resolvePositionValuesSwapped position position context) := by + unfold resolvePositionValuesInOrder resolvePositionValuesSwapped + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + simp only + rw [resolveDeferredPositionValue_of_resolved position context resolved hresolved] + rfl + +def DeferredResolution.clearPending (result : DeferredResolution) (coordinate : Coordinate) : + DeferredResolution := + ⟨{ result.toDeferredContext with state := result.state.clearPending coordinate }, + result.output⟩ + +theorem deferredPositionOutput_clearPending + (position : Position) (context : DeferredContext) (coordinate : Coordinate) : + deferredPositionOutput position + { context with state := context.state.clearPending coordinate } = + deferredPositionOutput position context := by + rfl + +theorem hitAt_clearPending_other_position + (position : Position) (context : DeferredContext) (coordinate : Coordinate) + (output : HashOutput) (hne : coordinate ≠ .position position) : + (context.state.clearPending coordinate).hitAt (.position position) output = + context.state.hitAt (.position position) output := by + exact propext (hitAt_clearPending_of_ne context.state coordinate (.position position) + output hne.symm) + +theorem completePrivatePosition_clearPending_comm + (position : Position) (context : DeferredContext) (coordinate : Coordinate) + (output : HashOutput) : + completePrivatePosition position + { context with state := context.state.clearPending coordinate } output = + (completePrivatePosition position context output).clearPending coordinate := by + unfold completePrivatePosition DeferredResolution.clearPending + rw [clearPending_comm] + +theorem resolveDeferredPositionValue_clearPending_of_ne + (position : Position) (context : DeferredContext) (coordinate : Coordinate) + (hne : coordinate ≠ .position position) : + resolveDeferredPositionValue position + { context with state := context.state.clearPending coordinate } = + (fun result => result.map fun resolved => resolved.clearPending coordinate) <$> + resolveDeferredPositionValue position context := by + rw [resolveDeferredPositionValue_eq_bind_output, + resolveDeferredPositionValue_eq_bind_output, deferredPositionOutput_clearPending] + rw [map_bind] + apply bind_congr + intro output + unfold resolvePrivatePositionWithOutput + have hhitEq := hitAt_clearPending_other_position position context coordinate output hne + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhitEq, hhit] + · simp [hhitEq, hhit, completePrivatePosition_clearPending_comm] + +noncomputable def resolvePositionThenChainStart + (position : Position) (table : OtsSecretIndex → HashOutput) + (index : OtsSecretIndex) (context : DeferredContext) : + ProbComp (Option RevealedResolution) := do + let positionResolved ← resolveDeferredPositionValue position context + match positionResolved with + | none => pure none + | some positionResolved => + match resolveDeferredChainStart table index positionResolved.toDeferredContext with + | none => pure none + | some chainResolved => + pure (some ⟨chainResolved.toDeferredContext, chainResolved.output⟩) + +noncomputable def resolveChainStartThenPosition + (position : Position) (table : OtsSecretIndex → HashOutput) + (index : OtsSecretIndex) (context : DeferredContext) : + ProbComp (Option RevealedResolution) := + match resolveDeferredChainStart table index context with + | none => pure none + | some chainResolved => do + let positionResolved ← + resolveDeferredPositionValue position chainResolved.toDeferredContext + match positionResolved with + | none => pure none + | some positionResolved => + pure (some ⟨positionResolved.toDeferredContext, chainResolved.output⟩) + +def clearResolutionForChainStart (index : OtsSecretIndex) (table : OtsSecretIndex → HashOutput) : + Option DeferredResolution → Option RevealedResolution + | none => none + | some resolved => + some ⟨(resolved.clearPending index.coordinate).toDeferredContext, table index⟩ + +def resolutionWithChainStartOutput (index : OtsSecretIndex) + (table : OtsSecretIndex → HashOutput) : + Option DeferredResolution → Option RevealedResolution + | none => none + | some resolved => some ⟨resolved.toDeferredContext, table index⟩ + +theorem evalDist_resolvePosition_chainStart_comm + (position : Position) (table : OtsSecretIndex → HashOutput) + (index : OtsSecretIndex) (context : DeferredContext) + (hcompletable : DeferredCompletable table context) : + evalDist (resolvePositionThenChainStart position table index context) = + evalDist (resolveChainStartThenPosition position table index context) := by + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hclean := hcompletable.not_hitAt_chainStart index + have hcoordinate : index.coordinate ≠ .position position := by + cases index + simp [OtsSecretIndex.coordinate] + have hchain := resolveDeferredChainStart_of_agrees table index context hstarts hclean + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + pure (clearResolutionForChainStart index table resolved)) := by + unfold resolvePositionThenChainStart + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hstate := resolveDeferredPositionValue_state_eq_clearPending position context + resolved hresolved + have hresolvedStarts : StartTableAgrees resolved.state table := + hstarts.of_state_values_eq + (resolveDeferredPositionValue_preserves_state_values position context resolved + hresolved) + have hresolvedClean : + ¬resolved.state.hitAt index.coordinate (table index) := by + rw [hstate] + exact (hitAt_clearPending_of_ne context.state (.position position) + index.coordinate (table index) hcoordinate).not.mpr hclean + simp only + rw [resolveDeferredChainStart_of_agrees table index resolved.toDeferredContext + hresolvedStarts hresolvedClean] + rfl + _ = evalDist (resolveDeferredPositionValue position + { context with state := context.state.clearPending index.coordinate } >>= + fun resolved => pure (resolutionWithChainStartOutput index table resolved)) := by + rw [resolveDeferredPositionValue_clearPending_of_ne position context index.coordinate + hcoordinate] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply congrArg evalDist + apply bind_congr + intro resolved + cases resolved <;> rfl + _ = _ := by + unfold resolveChainStartThenPosition + rw [hchain] + simp only + apply congrArg evalDist + apply bind_congr + intro resolved + cases resolved <;> rfl + +noncomputable def orderedPositionResolutionOutcome + (first second : Position) (context : DeferredContext) + (firstOutput secondOutput : HashOutput) : Option RevealedResolution := + if context.state.hitAt (.position first) firstOutput then + none + else if context.state.hitAt (.position second) secondOutput then + none + else + some ⟨(completePrivatePosition second + (completePrivatePosition first context firstOutput).toDeferredContext + secondOutput).toDeferredContext, secondOutput⟩ + +theorem resolvePositionValuesInOrder_eq_outputs + (first second : Position) (context : DeferredContext) (hne : first ≠ second) : + evalDist (resolvePositionValuesInOrder first second context) = evalDist (do + let firstOutput ← deferredPositionOutput first context + let secondOutput ← deferredPositionOutput second context + pure (orderedPositionResolutionOutcome first second context firstOutput secondOutput)) := by + unfold resolvePositionValuesInOrder + simp_rw [resolveDeferredPositionValue_eq_bind_output] + simp only [bind_assoc] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro firstOutput + unfold resolvePrivatePositionWithOutput + by_cases hfirstHit : context.state.hitAt (.position first) firstOutput + · simp only [hfirstHit, ↓reduceIte, pure_bind, orderedPositionResolutionOutcome] + exact (OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (deferredPositionOutput second context) (by + simp [deferredPositionOutput, LazyRevealProbe.sampleHashOutput]) (pure none)).symm + · simp only [hfirstHit, ↓reduceIte, pure_bind] + rw [deferredPositionOutput_completePrivatePosition_of_ne first second context firstOutput hne] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro secondOutput + have hsecondHitEq := hitAt_completePrivatePosition_of_ne first second context + firstOutput secondOutput hne + by_cases hsecondHit : context.state.hitAt (.position second) secondOutput + · simp [hsecondHitEq, hsecondHit, orderedPositionResolutionOutcome, hfirstHit] + · simp [hsecondHitEq, hsecondHit, orderedPositionResolutionOutcome, hfirstHit] + rfl + +theorem resolvePositionValuesSwapped_eq_outputs + (first second : Position) (context : DeferredContext) (hne : first ≠ second) : + evalDist (resolvePositionValuesSwapped first second context) = evalDist (do + let secondOutput ← deferredPositionOutput second context + let firstOutput ← deferredPositionOutput first context + pure (orderedPositionResolutionOutcome first second context firstOutput secondOutput)) := by + unfold resolvePositionValuesSwapped + simp_rw [resolveDeferredPositionValue_eq_bind_output] + simp only [bind_assoc] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro secondOutput + unfold resolvePrivatePositionWithOutput + by_cases hsecondHit : context.state.hitAt (.position second) secondOutput + · simp only [hsecondHit, ↓reduceIte, pure_bind, orderedPositionResolutionOutcome, + ite_self] + exact (OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (deferredPositionOutput first context) (by + simp [deferredPositionOutput, LazyRevealProbe.sampleHashOutput]) (pure none)).symm + · simp only [hsecondHit, ↓reduceIte, pure_bind] + rw [deferredPositionOutput_completePrivatePosition_of_ne second first context secondOutput + hne.symm] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro firstOutput + have hfirstHitEq := hitAt_completePrivatePosition_of_ne second first context + secondOutput firstOutput hne.symm + by_cases hfirstHit : context.state.hitAt (.position first) firstOutput + · simp [hfirstHitEq, hfirstHit, orderedPositionResolutionOutcome] + · have hfirstHitCompleted : + ¬(completePrivatePosition second context secondOutput).state.hitAt + (.position first) firstOutput := by + rw [hfirstHitEq] + exact hfirstHit + simp only [hfirstHitCompleted, ↓reduceIte, pure_bind] + unfold orderedPositionResolutionOutcome + rw [if_neg hfirstHit, if_neg hsecondHit] + simp only [completePrivatePosition_comm first second context firstOutput secondOutput hne] + rfl + +set_option maxRecDepth 100000 in +theorem evalDist_resolvePositionValues_comm_of_ne + (first second : Position) (context : DeferredContext) (hne : first ≠ second) : + evalDist (resolvePositionValuesInOrder first second context) = + evalDist (resolvePositionValuesSwapped first second context) := by + calc + _ = evalDist (do + let firstOutput ← deferredPositionOutput first context + let secondOutput ← deferredPositionOutput second context + pure (orderedPositionResolutionOutcome first second context firstOutput secondOutput)) := + resolvePositionValuesInOrder_eq_outputs first second context hne + _ = evalDist (do + let secondOutput ← deferredPositionOutput second context + let firstOutput ← deferredPositionOutput first context + pure (orderedPositionResolutionOutcome first second context firstOutput secondOutput)) := + OracleComp.DeferredSampling.evalDist_bind_comm + (deferredPositionOutput first context) (deferredPositionOutput second context) + (fun firstOutput secondOutput => + pure (orderedPositionResolutionOutcome first second context firstOutput secondOutput)) + _ = _ := (resolvePositionValuesSwapped_eq_outputs first second context hne).symm + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateInterpreter.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateInterpreter.lean new file mode 100644 index 00000000..16947c91 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateInterpreter.lean @@ -0,0 +1,882 @@ +import SphincsSecurity.Proof.OtsProbeResolvedPrivateRecursive + +/-! +# Private structural sample deferral through the resolved interpreter + +Resolving one ensured private structural position before an arbitrary probing computation leaves +the terminal completion-failure distribution unchanged. The reveal case uses recursive resolution +commutation while retaining every pending probe through the public materialization boundary. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem DeferredCompletable.of_resolveDeferredReveal + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hcompletable : DeferredCompletable table context) (hvalid : context.Valid) + (position : Position) (result : DeferredResolution) + (hresult : some result ∈ support (resolveDeferredReveal table position context)) : + DeferredCompletable table result.toDeferredContext := by + classical + by_cases hresolvable : ResolvableOtsPosition position + · exact hcompletable.of_resolveDeferredPosition hvalid (by + simpa [resolveDeferredReveal, hresolvable] using hresult) + · exact hcompletable.of_resolveDeferredPositionValue hvalid position result (by + simpa [resolveDeferredReveal, hresolvable] using hresult) + +theorem resolveDeferredPositionValue_values_eq_of_values_eq + (position : Position) (left right : DeferredContext) + (leftResult rightResult : DeferredResolution) + (hleft : some leftResult ∈ support (resolveDeferredPositionValue position left)) + (hright : some rightResult ∈ support (resolveDeferredPositionValue position right)) + (hvalues : left.values = right.values) + (houtput : leftResult.output = rightResult.output) : + leftResult.values = rightResult.values := by + funext other + by_cases heq : other = position + · subst other + rw [resolveDeferredPositionValue_installs position left leftResult hleft, + resolveDeferredPositionValue_installs position right rightResult hright, houtput] + · rw [resolveDeferredPositionValue_preserves_other position other left leftResult heq hleft, + resolveDeferredPositionValue_preserves_other position other right rightResult heq hright, + hvalues] + +theorem clearPending_materialize_comm + (state : LazyRevealProbe.State Coordinate) (cleared materialized : Coordinate) + (output : HashOutput) : + (state.clearPending cleared).materialize materialized output = + (state.materialize materialized output).clearPending cleared := by + rcases state with ⟨pending, values, revealed, ensured⟩ + simp [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.materialize, + LazyRevealProbe.State.pendingAway, and_comm] + exact Finset.filter_comm (fun x : Coordinate × Digest => ¬x.1 = cleared) + (fun x => ¬x.1 = materialized) pending + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_after_materialized_reveal + (target revealed : Position) (context : DeferredContext) + (revealedResult : DeferredResolution) (table : OtsSecretIndex → HashOutput) + (fuel : Nat) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hrevealed : some revealedResult ∈ support + (resolveDeferredReveal table revealed context)) : + evalDist (resolveDeferredPositionValue target revealedResult.toDeferredContext >>= + fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runResolvedFinishIsNone + { state := (context.state.clearPending (.position target)).materialize + (.position revealed) revealedResult.output + values := targetResult.values } + fuel table computation) = + evalDist (resolveDeferredPositionValue target + (materializeResolvedPosition context revealed revealedResult) >>= fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runResolvedFinishIsNone targetResult.toDeferredContext fuel table computation) := by + let materialized := materializeResolvedPosition context revealed revealedResult + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hrevealedValid := hvalid.of_resolveDeferredReveal table revealed revealedResult hrevealed + have hstateValues := resolveDeferredReveal_preserves_state_values table revealed context + revealedResult hrevealed + have hresolved := resolveDeferredReveal_resolves table revealed context revealedResult + hrevealed + have hmaterializedValid := hvalid.materializeResolvedPosition_of revealed revealedResult + hrevealedValid hstateValues hresolved + have hrevealedCompletable := hcompletable.of_resolveDeferredReveal hvalid revealed + revealedResult hrevealed + have hmaterializedCompletable : DeferredCompletable table materialized := by + obtain ⟨completion, hcompletion⟩ := hrevealedCompletable + refine ⟨completion, ?_⟩ + exact (deferredCompletion_materializeResolvedReveal_iff revealed revealedResult hvalid + hstarts hrevealed).2 hcompletion + have hview : FinalizationViewEq table materialized revealedResult.toDeferredContext := + finalizationViewEq_materializeResolvedReveal revealed revealedResult hvalid hstarts + hrevealed hmaterializedCompletable + have hbase := relTriple_resolveDeferredPositionValue_of_finalizationViewEq table target + revealedResult.toDeferredContext materialized hview.symm hrevealedValid + hmaterializedValid hrevealedCompletable + have hleft := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (resolveDeferredPositionValue target revealedResult.toDeferredContext)) + (fun result hresult => hresult) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply evalDist_eq_of_relTriple_eqRel + apply relTriple_bind hboth + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure rfl + | some rightResult => simp [FinalizationResolutionEq] at hrelation + | some leftResult => + cases rightResult with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResult => + simp only + have hvalues : leftResult.values = rightResult.values := + resolveDeferredPositionValue_values_eq_of_values_eq target + revealedResult.toDeferredContext materialized leftResult rightResult + hleftSupport hrightSupport (by rfl) hrelation.1 + have hrightState := resolveDeferredPositionValue_state_eq_clearPending target + materialized rightResult hrightSupport + have hstate : + (context.state.clearPending (.position target)).materialize + (.position revealed) revealedResult.output = rightResult.state := by + rw [hrightState] + exact clearPending_materialize_comm context.state (.position target) + (.position revealed) revealedResult.output + apply relTriple_eqRel_of_evalDist_eq + rw [hstate, hvalues] + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_after_materialized_chainStart + (target : Position) (index : OtsSecretIndex) (context : DeferredContext) + (revealedResult : DeferredResolution) (table : OtsSecretIndex → HashOutput) + (fuel : Nat) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hrevealed : resolveDeferredChainStart table index context = some revealedResult) : + evalDist (resolveDeferredPositionValue target revealedResult.toDeferredContext >>= + fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runResolvedFinishIsNone + { state := (context.state.clearPending (.position target)).materialize + index.coordinate revealedResult.output + values := targetResult.values } + fuel table computation) = + evalDist (resolveDeferredPositionValue target + (materializeResolvedChainStart context index revealedResult) >>= fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runResolvedFinishIsNone targetResult.toDeferredContext fuel table computation) := by + let materialized := materializeResolvedChainStart context index revealedResult + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hrevealedValid := hvalid.of_resolveDeferredChainStart table index revealedResult hrevealed + have hstateValues := resolveDeferredChainStart_state_values_eq table index context + revealedResult hrevealed + have hdeferredValues := resolveDeferredChainStart_deferred_values_eq table index context + revealedResult hrevealed + have hrevealedCompletable := hcompletable.of_resolveDeferredChainStart index revealedResult + hrevealed + have houtput := resolveDeferredChainStart_output_of_agrees table index context revealedResult + hstarts hrevealed + have hmaterializedValid : materialized.Valid := by + dsimp only [materialized] + rw [materializeResolvedChainStart, hdeferredValues] + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + exact hvalid.materialize_chainStart lay tree leafIdx chainIdx revealedResult.output + have hmaterializedCompletable : DeferredCompletable table materialized := by + obtain ⟨completion, hcompletion⟩ := hrevealedCompletable + refine ⟨completion, ?_⟩ + exact (deferredCompletion_materializeResolvedChainStart_iff index revealedResult hstarts + houtput hstateValues hdeferredValues + (resolveDeferredChainStart_pending_eq table index context revealedResult hrevealed)).2 + hcompletion + have hview : FinalizationViewEq table materialized revealedResult.toDeferredContext := + finalizationViewEq_materializeResolvedChainStart index revealedResult hvalid hstarts + hrevealed hmaterializedCompletable + have hbase := relTriple_resolveDeferredPositionValue_of_finalizationViewEq table target + revealedResult.toDeferredContext materialized hview.symm hrevealedValid + hmaterializedValid hrevealedCompletable + have hleft := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (resolveDeferredPositionValue target revealedResult.toDeferredContext)) + (fun result hresult => hresult) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply evalDist_eq_of_relTriple_eqRel + apply relTriple_bind hboth + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResult with + | none => + cases rightResult with + | none => exact relTriple_pure_pure rfl + | some rightResult => simp [FinalizationResolutionEq] at hrelation + | some leftResult => + cases rightResult with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResult => + simp only + have hvalues : leftResult.values = rightResult.values := + resolveDeferredPositionValue_values_eq_of_values_eq target + revealedResult.toDeferredContext materialized leftResult rightResult + hleftSupport hrightSupport (by rfl) hrelation.1 + have hrightState := resolveDeferredPositionValue_state_eq_clearPending target + materialized rightResult hrightSupport + have hstate : + (context.state.clearPending (.position target)).materialize + index.coordinate revealedResult.output = rightResult.state := by + rw [hrightState] + exact clearPending_materialize_comm context.state (.position target) + index.coordinate revealedResult.output + apply relTriple_eqRel_of_evalDist_eq + rw [hstate, hvalues] + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_runResolvedFinishIsNone + (position : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : Coordinate.position position ∈ context.state.ensured) : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure true + | some resolved => + runResolvedFinishIsNone resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedFinishIsNone context fuel table computation) := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + unfold runResolvedFinishIsNone + simp only [runResolvedFromTable, pure_bind] + exact evalDist_resolveDeferredPositionValue_then_finish_isNone position context table + fuel value hvalid hcompletable hensured + | query_bind query next ih => + cases query with + | uniform n => + unfold runResolvedFinishIsNone + simp only [runResolvedFromTable_uniform_query_bind, bind_assoc] + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) >>= fun output => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext fuel table + (next output) >>= + finishResolvedRunIsNone) := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro resolved + cases resolved with + | none => + exact (OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) + (by simp) (pure true)).symm + | some resolved => rfl + _ = evalDist ((liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) >>= fun output => + resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext fuel table + (next output) >>= + finishResolvedRunIsNone) := + OracleComp.DeferredSampling.evalDist_bind_comm + (resolveDeferredPositionValue position context) + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) _ + _ = _ := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + exact ih output context fuel hvalid hcompletable hensured + | hashOutput => + unfold runResolvedFinishIsNone + simp only [runResolvedFromTable_hashOutput_query_bind, bind_assoc] + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + LazyRevealProbe.sampleHashOutput >>= fun output => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext fuel table + (next output) >>= + finishResolvedRunIsNone) := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro resolved + cases resolved with + | none => + exact (OracleComp.DeferredSampling.evalDist_bind_const_neverFails + LazyRevealProbe.sampleHashOutput (by + simp [LazyRevealProbe.sampleHashOutput]) (pure true)).symm + | some resolved => rfl + _ = evalDist (LazyRevealProbe.sampleHashOutput >>= fun output => + resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext fuel table + (next output) >>= + finishResolvedRunIsNone) := + OracleComp.DeferredSampling.evalDist_bind_comm + (resolveDeferredPositionValue position context) + LazyRevealProbe.sampleHashOutput _ + _ = _ := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + exact ih output context fuel hvalid hcompletable hensured + | ensure coordinate => + unfold runResolvedFinishIsNone + simp_rw [runResolvedFromTable_ensure_query_bind] + calc + _ = evalDist (resolveDeferredPositionValue position + { context with state := context.state.ensure coordinate } >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext fuel table (next ()) >>= + finishResolvedRunIsNone) := by + rw [resolveDeferredPositionValue_ensure] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply congrArg evalDist + apply bind_congr + intro resolved + cases resolved <;> rfl + _ = _ := ih () { context with state := context.state.ensure coordinate } fuel + (hvalid.ensure coordinate) (hcompletable.ensure coordinate) (by + exact Finset.mem_insert.mpr (Or.inr hensured)) + | probe coordinate candidate => + unfold runResolvedFinishIsNone + simp_rw [runResolvedFromTable_probe_query_bind] + cases fuel with + | zero => + simp only [pure_bind] + have hnone : finishResolvedRunIsNone + (none : Option (ResolvedRunResult α)) = pure true := by + simp [finishResolvedRunIsNone, finishResolvedRun] + simp_rw [hnone] + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun _ => + pure true) := by + apply congrArg evalDist + apply bind_congr + intro resolved + cases resolved <;> rfl + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolveDeferredPositionValue position context) (by + simp [resolveDeferredPositionValue, LazyRevealProbe.sampleHashOutput]) + (pure true) + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext remaining table + (next ()) >>= + finishResolvedRunIsNone) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hstate := resolveDeferredPositionValue_state_eq_clearPending + position context resolved hresolved + simp [hstate, LazyRevealProbe.State.clearPending, hrevealed] + _ = _ := by + simpa [runResolvedFinishIsNone, hrevealed] using + ih () context remaining hvalid hcompletable hensured + · by_cases heq : coordinate = .position position + · subst coordinate + let nextContext : DeferredContext := + { context with + state := context.state.addPending (.position position) candidate } + let continuation : Option DeferredResolution → ProbComp Bool + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext remaining table + (next ()) >>= + finishResolvedRunIsNone + calc + _ = evalDist (resolveDeferredPositionValue position context >>= + fun first => + match first with + | none => pure true + | some first => + resolveDeferredPositionValue position + { first.toDeferredContext with + state := first.state.addPending (.position position) + candidate } >>= + continuation) := by + apply evalDist_bind_congr + intro first hfirst + cases first with + | none => rfl + | some first => + let added : DeferredContext := + { first.toDeferredContext with + state := first.state.addPending (.position position) candidate } + have hfirstValid := + hvalid.of_resolveDeferredPositionValue position first hfirst + have hfirstCompletable := + hcompletable.of_resolveDeferredPositionValue hvalid position first + hfirst + have hfirstState := resolveDeferredPositionValue_state_eq_clearPending + position context first hfirst + have hnotRevealed : + Coordinate.position position ∉ first.state.revealed := by + simpa [hfirstState, LazyRevealProbe.State.clearPending] using + hrevealed + have haddedEnsured : + Coordinate.position position ∈ added.state.ensured := by + simpa [added, hfirstState, LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.addPending] using hensured + by_cases haddedCompletable : DeferredCompletable table added + · simpa [added, continuation, DeferredResolution.addPending, + hnotRevealed, runResolvedFinishIsNone] using + (ih () added remaining + (hfirstValid.addPending_of_completable + (.position position) candidate haddedCompletable) + haddedCompletable haddedEnsured).symm + · have haddedConsistent : added.ValuesConsistent := + hfirstValid.valuesConsistent.addPending (.position position) + candidate + have hfirstStarts : StartTableAgrees first.state table := + startTableAgrees_of_deferredCompletable hfirstCompletable + have haddedStarts : StartTableAgrees added.state table := by + exact hfirstStarts + calc + _ = evalDist (pure true : ProbComp Bool) := by + simpa [added, hnotRevealed] using + evalDist_runResolvedFinishIsNone_eq_true_of_not_completable + added remaining table (next ()) haddedConsistent haddedStarts + haddedCompletable + _ = _ := by + symm + exact + evalDist_resolveDeferredPositionValue_then_run_eq_true_of_not_completable + position added remaining table (next ()) haddedConsistent + haddedStarts haddedCompletable + _ = evalDist ((do + let first ← resolveDeferredPositionValue position context + match first with + | none => (pure none : ProbComp (Option DeferredResolution)) + | some first => + resolveDeferredPositionValue position + { first.toDeferredContext with + state := first.state.addPending (.position position) + candidate }) >>= continuation) := by + simp only [bind_assoc] + apply congrArg evalDist + apply bind_congr + intro first + cases first <;> rfl + _ = evalDist (resolveDeferredPositionValue position nextContext >>= + continuation) := by + dsimp only [nextContext] + exact congrArg evalDist (congrArg (fun resolver => resolver >>= continuation) + (resolveDeferredPositionValue_then_addPending_self_resolve position + context candidate)) + _ = _ := by + have hnextConsistent : nextContext.ValuesConsistent := + hvalid.valuesConsistent.addPending (.position position) candidate + have hstarts : StartTableAgrees context.state table := + startTableAgrees_of_deferredCompletable hcompletable + have hnextStarts : StartTableAgrees nextContext.state table := by + exact hstarts + have hnextEnsured : + Coordinate.position position ∈ nextContext.state.ensured := hensured + by_cases hnextCompletable : DeferredCompletable table nextContext + · simpa [nextContext, continuation, hrevealed, + runResolvedFinishIsNone] using + ih () nextContext remaining + (hvalid.addPending_of_completable (.position position) candidate + hnextCompletable) + hnextCompletable hnextEnsured + · calc + _ = evalDist (pure true : ProbComp Bool) := + evalDist_resolveDeferredPositionValue_then_run_eq_true_of_not_completable + position nextContext remaining table (next ()) hnextConsistent + hnextStarts hnextCompletable + _ = _ := by + symm + simpa [nextContext, hrevealed] using + evalDist_runResolvedFinishIsNone_eq_true_of_not_completable + nextContext remaining table (next ()) hnextConsistent hnextStarts + hnextCompletable + · let nextContext : DeferredContext := + { context with state := context.state.addPending coordinate candidate } + by_cases hnextCompletable : DeferredCompletable table nextContext + · calc + _ = evalDist (resolveDeferredPositionValue position nextContext >>= + fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext remaining table + (next ()) >>= + finishResolvedRunIsNone) := by + dsimp only [nextContext] + rw [resolveDeferredPositionValue_addPending_of_ne position context + coordinate candidate heq] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hstate := resolveDeferredPositionValue_state_eq_clearPending + position context resolved hresolved + have hnotRevealed : coordinate ∉ resolved.state.revealed := by + simpa [hstate, LazyRevealProbe.State.clearPending] using hrevealed + simp [DeferredResolution.addPending, hnotRevealed] + _ = _ := by + simpa [nextContext, hrevealed, runResolvedFinishIsNone] using + ih () nextContext remaining + (hvalid.addPending_of_completable coordinate candidate + hnextCompletable) + hnextCompletable (by exact hensured) + · have hnextConsistent : nextContext.ValuesConsistent := + hvalid.valuesConsistent.addPending coordinate candidate + have hstarts : StartTableAgrees context.state table := + startTableAgrees_of_deferredCompletable hcompletable + have hnextStarts : StartTableAgrees nextContext.state table := by + exact hstarts + calc + _ = evalDist (resolveDeferredPositionValue position nextContext >>= + fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext remaining table + (next ()) >>= + finishResolvedRunIsNone) := by + dsimp only [nextContext] + rw [resolveDeferredPositionValue_addPending_of_ne position context + coordinate candidate heq] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hstate := resolveDeferredPositionValue_state_eq_clearPending + position context resolved hresolved + have hnotRevealed : coordinate ∉ resolved.state.revealed := by + simpa [hstate, LazyRevealProbe.State.clearPending] using hrevealed + simp [DeferredResolution.addPending, hnotRevealed] + _ = evalDist (pure true : ProbComp Bool) := by + calc + _ = evalDist (resolveDeferredPositionValue position nextContext >>= + fun _ => pure true) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hresolvedNotCompletable : + ¬DeferredCompletable table resolved.toDeferredContext := by + intro hresolvedCompletable + obtain ⟨completion, hcompletion⟩ := hresolvedCompletable + have hback := + (deferredCompletion_resolveDeferredPositionValue_iff position + resolved hnextConsistent hresolved completion).mp hcompletion + exact hnextCompletable ⟨completion, hback.1⟩ + exact + evalDist_runResolvedFinishIsNone_eq_true_of_not_completable + resolved.toDeferredContext remaining table (next ()) + (hnextConsistent.of_resolveDeferredPositionValue position + resolved hresolved) + (hnextStarts.of_state_values_eq + (resolveDeferredPositionValue_preserves_state_values position + nextContext resolved hresolved)) + hresolvedNotCompletable + _ = _ := + OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolveDeferredPositionValue position nextContext) (by + simp [resolveDeferredPositionValue, + LazyRevealProbe.sampleHashOutput]) + (pure true) + _ = _ := by + symm + simpa [nextContext, hrevealed] using + evalDist_runResolvedFinishIsNone_eq_true_of_not_completable + nextContext remaining table (next ()) hnextConsistent hnextStarts + hnextCompletable + | peek coordinate => + unfold runResolvedFinishIsNone + simp_rw [runResolvedFromTable_peek_query_bind] + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext fuel table + (next (context.state.values coordinate)) >>= + finishResolvedRunIsNone) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hvalues := resolveDeferredPositionValue_preserves_state_values position + context resolved hresolved + simp [hvalues] + _ = _ := ih (context.state.values coordinate) context fuel hvalid hcompletable + hensured + | publish coordinate => + unfold runResolvedFinishIsNone + simp_rw [runResolvedFromTable_publish_query_bind] + calc + _ = evalDist (resolveDeferredPositionValue position + { context with state := context.state.publish coordinate } >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext fuel table (next ()) >>= + finishResolvedRunIsNone) := by + rw [resolveDeferredPositionValue_publish] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply congrArg evalDist + apply bind_congr + intro resolved + cases resolved <;> rfl + _ = _ := ih () { context with state := context.state.publish coordinate } fuel + (hvalid.publish coordinate) (hcompletable.publish coordinate) hensured + | reveal coordinate => + unfold runResolvedFinishIsNone + simp_rw [runResolvedFromTable_reveal_query_bind] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + let continuation : Option RevealedResolution → ProbComp Bool + | none => pure true + | some resolved => + runResolvedFinishIsNone + { state := (context.state.clearPending (.position position)).materialize + index.coordinate resolved.output + values := resolved.context.values } + fuel table (next resolved.output) + simp only + calc + _ = evalDist (resolvePositionThenChainStart position table index context >>= + continuation) := by + unfold resolvePositionThenChainStart continuation + simp only [bind_assoc] + apply evalDist_bind_congr + intro positionResult hpositionResult + cases positionResult with + | none => rfl + | some positionResult => + have hstate := resolveDeferredPositionValue_state_eq_clearPending + position context positionResult hpositionResult + cases hrevealedResult : resolveDeferredChainStart table index + positionResult.toDeferredContext with + | none => + dsimp only [index] at hrevealedResult ⊢ + simp [hrevealedResult, finishResolvedRunIsNone, finishResolvedRun] + | some revealedResult => + dsimp only [index] at hrevealedResult ⊢ + simp only [hrevealedResult, pure_bind] + rw [hstate] + rfl + _ = evalDist (resolveChainStartThenPosition position table index context >>= + continuation) := + evalDist_bind_eq_of_evalDist_eq + (evalDist_resolvePosition_chainStart_comm position table index context + hcompletable) + continuation + _ = evalDist (match resolveDeferredChainStart table index context with + | none => pure true + | some revealedResult => + resolveDeferredPositionValue position + revealedResult.toDeferredContext >>= + fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runResolvedFinishIsNone + { state := (context.state.clearPending + (.position position)).materialize + index.coordinate revealedResult.output + values := targetResult.values } + fuel table (next revealedResult.output)) := by + unfold resolveChainStartThenPosition continuation + cases resolveDeferredChainStart table index context with + | none => rfl + | some revealedResult => + simp only [bind_assoc] + apply congrArg evalDist + apply bind_congr + intro targetResult + cases targetResult <;> rfl + _ = evalDist (match resolveDeferredChainStart table index context with + | none => pure true + | some revealedResult => + runResolvedFinishIsNone + (materializeResolvedChainStart context index revealedResult) + fuel table (next revealedResult.output)) := by + cases hrevealedResult : resolveDeferredChainStart table index context with + | none => rfl + | some revealedResult => + have htransport := + evalDist_resolveDeferredPositionValue_after_materialized_chainStart + position index context revealedResult table fuel + (next revealedResult.output) hvalid hcompletable hrevealedResult + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hdeferredValues := + resolveDeferredChainStart_deferred_values_eq table index context + revealedResult hrevealedResult + have hrevealedValid := hvalid.of_resolveDeferredChainStart table index + revealedResult hrevealedResult + have hrevealedCompletable := + hcompletable.of_resolveDeferredChainStart index revealedResult + hrevealedResult + have hstateValues := resolveDeferredChainStart_state_values_eq table index + context revealedResult hrevealedResult + have houtput := resolveDeferredChainStart_output_of_agrees table index + context revealedResult hstarts hrevealedResult + have hmaterializedValid : + (materializeResolvedChainStart context index revealedResult).Valid := by + rw [materializeResolvedChainStart, hdeferredValues] + exact hvalid.materialize_chainStart lay tree leafIdx chainIdx + revealedResult.output + have hmaterializedCompletable : DeferredCompletable table + (materializeResolvedChainStart context index revealedResult) := by + obtain ⟨completion, hcompletion⟩ := hrevealedCompletable + refine ⟨completion, ?_⟩ + exact (deferredCompletion_materializeResolvedChainStart_iff index + revealedResult hstarts houtput hstateValues hdeferredValues + (resolveDeferredChainStart_pending_eq table index context + revealedResult hrevealedResult)).2 hcompletion + have hmaterializedEnsured : Coordinate.position position ∈ + (materializeResolvedChainStart context index + revealedResult).state.ensured := by + change Coordinate.position position ∈ + insert index.coordinate context.state.ensured + exact Finset.mem_insert.mpr (Or.inr hensured) + exact htransport.trans + (ih revealedResult.output + (materializeResolvedChainStart context index revealedResult) fuel + hmaterializedValid hmaterializedCompletable + hmaterializedEnsured) + _ = _ := by + cases hrevealedResult : resolveDeferredChainStart table index context with + | none => + simp [finishResolvedRunIsNone, finishResolvedRun] + | some revealedResult => + simp only [pure_bind, materializeResolvedChainStart] + rfl + | position revealed => + let resolver : PrivateResolver := fun nextContext => + resolveDeferredReveal table revealed nextContext + let continuation : Option RevealedResolution → ProbComp Bool + | none => pure true + | some resolved => + runResolvedFinishIsNone + { state := (context.state.clearPending (.position position)).materialize + (.position revealed) resolved.output + values := resolved.context.values } + fuel table (next resolved.output) + simp only + calc + _ = evalDist (resolvePositionThenResolver position resolver context >>= + continuation) := by + unfold resolvePositionThenResolver resolver continuation + simp only [bind_assoc] + apply evalDist_bind_congr + intro positionResult hpositionResult + cases positionResult with + | none => rfl + | some positionResult => + simp only [bind_assoc] + apply evalDist_bind_congr + intro revealedResult _hrevealedResult + cases revealedResult with + | none => rfl + | some revealedResult => + have hstate := resolveDeferredPositionValue_state_eq_clearPending + position context positionResult hpositionResult + simp only + rw [hstate] + simp only [pure_bind] + rfl + _ = evalDist (resolveResolverThenPosition position resolver context >>= + continuation) := + evalDist_bind_eq_of_evalDist_eq + (positionResolutionCommutes_reveal position table revealed context hvalid + hcompletable) + continuation + _ = evalDist (resolveDeferredReveal table revealed context >>= + fun revealedResult => + match revealedResult with + | none => pure true + | some revealedResult => + resolveDeferredPositionValue position + revealedResult.toDeferredContext >>= + fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runResolvedFinishIsNone + { state := (context.state.clearPending + (.position position)).materialize + (.position revealed) revealedResult.output + values := targetResult.values } + fuel table (next revealedResult.output)) := by + unfold resolveResolverThenPosition resolver continuation + simp only [bind_assoc] + apply congrArg evalDist + apply bind_congr + intro revealedResult + cases revealedResult with + | none => rfl + | some revealedResult => + simp only [bind_assoc] + apply bind_congr + intro targetResult + cases targetResult <;> rfl + _ = evalDist (resolveDeferredReveal table revealed context >>= + fun revealedResult => + match revealedResult with + | none => pure true + | some revealedResult => + runResolvedFinishIsNone + (materializeResolvedPosition context revealed revealedResult) + fuel table (next revealedResult.output)) := by + apply evalDist_bind_congr + intro revealedResult hrevealedResult + cases revealedResult with + | none => rfl + | some revealedResult => + have htransport := + evalDist_resolveDeferredPositionValue_after_materialized_reveal + position revealed context revealedResult table fuel + (next revealedResult.output) hvalid hcompletable hrevealedResult + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hrevealedValid := hvalid.of_resolveDeferredReveal table revealed + revealedResult hrevealedResult + have hstateValues := resolveDeferredReveal_preserves_state_values table + revealed context revealedResult hrevealedResult + have hresolved := resolveDeferredReveal_resolves table revealed context + revealedResult hrevealedResult + have hmaterializedValid := + hvalid.materializeResolvedPosition_of revealed revealedResult + hrevealedValid hstateValues hresolved + have hrevealedCompletable := + hcompletable.of_resolveDeferredReveal hvalid revealed revealedResult + hrevealedResult + have hmaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition context revealed revealedResult) := by + obtain ⟨completion, hcompletion⟩ := hrevealedCompletable + refine ⟨completion, ?_⟩ + exact (deferredCompletion_materializeResolvedReveal_iff revealed + revealedResult hvalid hstarts hrevealedResult).2 hcompletion + have hmaterializedEnsured : Coordinate.position position ∈ + (materializeResolvedPosition context revealed + revealedResult).state.ensured := by + change Coordinate.position position ∈ + insert (.position revealed) context.state.ensured + exact Finset.mem_insert.mpr (Or.inr hensured) + exact htransport.trans + (ih revealedResult.output + (materializeResolvedPosition context revealed revealedResult) fuel + hmaterializedValid hmaterializedCompletable + hmaterializedEnsured) + _ = _ := by + simp only [materializeResolvedPosition, bind_assoc] + apply congrArg evalDist + apply bind_congr + intro revealedResult + cases revealedResult <;> rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateObserver.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateObserver.lean new file mode 100644 index 00000000..e26ac3ac --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateObserver.lean @@ -0,0 +1,2512 @@ +import SphincsSecurity.Proof.OtsProbeResolvedPrivateSchedule + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedSignLayer + +def canonicalizeDeferredResolution (table : OtsSecretIndex → HashOutput) + (result : DeferredResolution) : DeferredResolution := + { toDeferredContext := canonicalizeMaterializedValues table result.toDeferredContext + output := result.output } + +theorem publicMaterializedValues_eq_of_privateStateAgrees + (table : OtsSecretIndex → HashOutput) (left right : DeferredContext) + (hagrees : PrivateStateAgrees left right) + (hpublished : PublishedValues right.state) : + publicMaterializedValues table left = publicMaterializedValues table right := by + funext coordinate + unfold publicMaterializedValues + have hrevealed : left.state.revealed = right.state.revealed := hagrees.2.1 + by_cases hright : coordinate ∈ right.state.revealed + · have hleft : coordinate ∈ left.state.revealed := by rwa [hrevealed] + simp only [hleft, hright, ↓reduceIte] + cases coordinate with + | chainStart => rfl + | position position => + unfold resolvedCompletionValue DeferredContext.positionValue + have hvalue := hpublished (.position position) hright + cases hstate : right.state.values (.position position) with + | none => exact False.elim (hvalue hstate) + | some output => + have hleftState : left.state.values (.position position) = some output := by + rw [hagrees.1] + exact hstate + simp [hstate, hleftState] + · have hleft : coordinate ∉ left.state.revealed := by rwa [hrevealed] + simp [hleft, hright] + +theorem publicMaterializedValues_clearPending_values + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (coordinate : Coordinate) (values : DeferredStructuralValues) + (hpublished : PublishedValues context.state) : + publicMaterializedValues table + { state := context.state.clearPending coordinate, values := values } = + publicMaterializedValues table context := by + apply publicMaterializedValues_eq_of_privateStateAgrees table _ context + · exact ⟨rfl, rfl, rfl⟩ + · exact hpublished + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_canonicalize + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (hconsistent : context.ValuesConsistent) + (hpublished : PublishedValues context.state) : + evalDist ((Option.map (canonicalizeDeferredResolution table)) <$> + resolveDeferredPositionValue position context) = + evalDist (resolveDeferredPositionValue position + (canonicalizeMaterializedValues table context)) := by + apply congrArg evalDist + unfold resolveDeferredPositionValue canonicalizeDeferredResolution + simp only [map_eq_bind_pure_comp] + simp only [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt] + cases hstate : context.state.values (.position position) with + | none => + by_cases hrevealed : Coordinate.position position ∈ context.state.revealed + · exact False.elim ((hpublished (.position position) hrevealed) hstate) + · simp only [canonicalizeMaterializedValues, publicMaterializedValues, + hrevealed, ↓reduceIte] + cases hvalue : context.values position with + | none => + simp only [bind_assoc] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output + · have hmem : (Coordinate.position position, truncateHash output) ∈ + context.state.pending := by + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt] using hhit + simp [hmem] + · have hpublic := publicMaterializedValues_clearPending_values table context + (.position position) (context.values.install position output) hpublished + have hmem : (Coordinate.position position, truncateHash output) ∉ + context.state.pending := by + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt] using hhit + simp [hmem] + rw [hpublic] + rfl + | some output => + simp only + by_cases hhit : context.state.hitAt (.position position) output + · have hmem : (Coordinate.position position, truncateHash output) ∈ + context.state.pending := by + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt] using hhit + simp [hmem] + · have hpublic := publicMaterializedValues_clearPending_values table context + (.position position) context.values hpublished + have hmem : (Coordinate.position position, truncateHash output) ∉ + context.state.pending := by + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt] using hhit + simp [hmem] + rw [hpublic] + rfl + | some output => + have hvalue := hconsistent position output hstate + by_cases hrevealed : Coordinate.position position ∈ context.state.revealed + · simp only [hstate, canonicalizeMaterializedValues, publicMaterializedValues, + hrevealed, ↓reduceIte, resolvedCompletionValue, DeferredContext.positionValue] + by_cases hhit : context.state.hitAt (.position position) output + · have hmem : (Coordinate.position position, truncateHash output) ∈ + context.state.pending := by + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt] using hhit + simp [hmem] + · have hpublic := publicMaterializedValues_clearPending_values table context + (.position position) (context.values.install position output) hpublished + have hmem : (Coordinate.position position, truncateHash output) ∉ + context.state.pending := by + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt] using hhit + simp [hmem] + rw [hpublic] + rfl + · simp only [canonicalizeMaterializedValues, publicMaterializedValues, + hrevealed, ↓reduceIte, hvalue] + by_cases hhit : context.state.hitAt (.position position) output + · have hmem : (Coordinate.position position, truncateHash output) ∈ + context.state.pending := by + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt] using hhit + simp [hmem] + · have hpublic := publicMaterializedValues_clearPending_values table context + (.position position) (context.values.install position output) hpublished + have hmem : (Coordinate.position position, truncateHash output) ∉ + context.state.pending := by + simpa [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt] using hhit + simp [hmem, DeferredStructuralValues.install, hvalue] + unfold DeferredStructuralValues.install at hpublic + rw [hpublic] + rfl + +@[simp] noncomputable def finishObserve + (observe : DeferredContext → Nat → α → ProbComp Bool) : + Option (ResolvedRunResult α) → ProbComp Bool + | none => pure true + | some result => observe result.context result.remaining result.value + +noncomputable def runResolvedObserve + (observe : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : ProbComp Bool := + runResolvedFromTable context fuel table computation >>= finishObserve observe + +class ObserverDooms (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → ProbComp Bool) : Prop where + eq_true : ∀ context fuel value, + context.ValuesConsistent → + StartTableAgrees context.state table → + ¬DeferredCompletable table context → + evalDist (observe context fuel value) = evalDist (pure true : ProbComp Bool) + +class ObserverSynchronized (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → ProbComp Bool) : Prop where + eq_of_synchronized : ∀ left right fuel value, + FinalizationContextEq table (some left) (some right) → + left.state.values = right.state.values → + left.state.revealed = right.state.revealed → + evalDist (observe left fuel value) = evalDist (observe right fuel value) + +class ObserverPositionNeutral (table : OtsSecretIndex → HashOutput) + (observe : DeferredContext → Nat → α → ProbComp Bool) : Prop where + eq_resolve : ∀ position context fuel value, + context.Valid → DeferredCompletable table context → + Coordinate.position position ∈ context.state.ensured → + evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => observe resolved.toDeferredContext fuel value) = + evalDist (observe context fuel value) + +def ObserverPositionNeutralAt (table : OtsSecretIndex → HashOutput) + (position : Position) (observe : DeferredContext → Nat → α → ProbComp Bool) : Prop := + ∀ context fuel value, + context.Valid → DeferredCompletable table context → + Coordinate.position position ∈ context.state.ensured → + evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => observe resolved.toDeferredContext fuel value) = + evalDist (observe context fuel value) + +theorem ObserverPositionNeutral.at + (table : OtsSecretIndex → HashOutput) (position : Position) + (observe : DeferredContext → Nat → α → ProbComp Bool) + [ObserverPositionNeutral table observe] : + ObserverPositionNeutralAt table position observe := by + intro context fuel value hvalid hcompletable hensured + exact ObserverPositionNeutral.eq_resolve position context fuel value hvalid hcompletable hensured + +theorem evalDist_runResolvedObserve_eq_true_of_not_completable + (observe : DeferredContext → Nat → α → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) + (hobserve : ∀ nextContext remaining value, + nextContext.ValuesConsistent → + StartTableAgrees nextContext.state table → + ¬DeferredCompletable table nextContext → + evalDist (observe nextContext remaining value) = + evalDist (pure true : ProbComp Bool)) : + evalDist (runResolvedObserve observe context fuel table computation) = + evalDist (pure true : ProbComp Bool) := by + unfold runResolvedObserve + calc + _ = evalDist (runResolvedFromTable context fuel table computation >>= fun _ => + pure true) := by + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable computation context fuel + table result hconsistent hstarts hresult + have hstillDoomed := not_deferredCompletable_of_mem_runResolvedFromTable + computation context fuel table result hconsistent hstarts hresult hdoomed + exact hobserve result.context result.remaining result.value hcore.2.1 hcore.2.2 + hstillDoomed + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (runResolvedFromTable context fuel table computation) (by simp [runResolvedFromTable]) + (pure true) + +theorem evalDist_resolveDeferredPositionValue_then_runResolvedObserve_eq_true_of_not_completable + (position : Position) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) + (hobserve : ∀ nextContext remaining value, + nextContext.ValuesConsistent → + StartTableAgrees nextContext.state table → + ¬DeferredCompletable table nextContext → + evalDist (observe nextContext remaining value) = + evalDist (pure true : ProbComp Bool)) : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (pure true : ProbComp Bool) := by + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun _ => pure true) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hresolvedNotCompletable : + ¬DeferredCompletable table resolved.toDeferredContext := by + intro hresolvedCompletable + obtain ⟨completion, hcompletion⟩ := hresolvedCompletable + have hback := + (deferredCompletion_resolveDeferredPositionValue_iff position resolved + hconsistent hresolved completion).mp hcompletion + exact hdoomed ⟨completion, hback.1⟩ + exact evalDist_runResolvedObserve_eq_true_of_not_completable observe + resolved.toDeferredContext fuel table computation + (hconsistent.of_resolveDeferredPositionValue position resolved hresolved) + (hstarts.of_state_values_eq + (resolveDeferredPositionValue_preserves_state_values position context resolved + hresolved)) + hresolvedNotCompletable hobserve + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolveDeferredPositionValue position context) (by + simp [resolveDeferredPositionValue, LazyRevealProbe.sampleHashOutput]) + (pure true) + +theorem evalDist_runResolvedObserve_eq_true_of_not_completable_auto + {observe : DeferredContext → Nat → α → ProbComp Bool} + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + [ObserverDooms table observe] + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) : + evalDist (runResolvedObserve observe context fuel table computation) = + evalDist (pure true : ProbComp Bool) := + evalDist_runResolvedObserve_eq_true_of_not_completable observe context fuel table computation + hconsistent hstarts hdoomed ObserverDooms.eq_true + +theorem evalDist_resolveDeferredPositionValue_then_runResolvedObserve_eq_true_of_not_completable_auto + {observe : DeferredContext → Nat → α → ProbComp Bool} + (position : Position) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) [ObserverDooms table observe] + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (pure true : ProbComp Bool) := + evalDist_resolveDeferredPositionValue_then_runResolvedObserve_eq_true_of_not_completable + position context fuel table computation observe hconsistent hstarts hdoomed + ObserverDooms.eq_true + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_after_materialized_reveal_observe + (observe : DeferredContext → ProbComp Bool) + (target revealed : Position) (context : DeferredContext) + (revealedResult : DeferredResolution) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hrevealed : some revealedResult ∈ support + (resolveDeferredReveal table revealed context)) : + evalDist (resolveDeferredPositionValue target revealedResult.toDeferredContext >>= + fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + observe + { state := (context.state.clearPending (.position target)).materialize + (.position revealed) revealedResult.output + values := targetResult.values }) = + evalDist (resolveDeferredPositionValue target + (materializeResolvedPosition context revealed revealedResult) >>= fun targetResult => + match targetResult with + | none => pure true + | some targetResult => observe targetResult.toDeferredContext) := by + let materialized := materializeResolvedPosition context revealed revealedResult + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hrevealedValid := hvalid.of_resolveDeferredReveal table revealed revealedResult hrevealed + have hstateValues := resolveDeferredReveal_preserves_state_values table revealed context + revealedResult hrevealed + have hresolved := resolveDeferredReveal_resolves table revealed context revealedResult + hrevealed + have hmaterializedValid := hvalid.materializeResolvedPosition_of revealed revealedResult + hrevealedValid hstateValues hresolved + have hrevealedCompletable := hcompletable.of_resolveDeferredReveal hvalid revealed + revealedResult hrevealed + have hmaterializedCompletable : DeferredCompletable table materialized := by + obtain ⟨completion, hcompletion⟩ := hrevealedCompletable + refine ⟨completion, ?_⟩ + exact (deferredCompletion_materializeResolvedReveal_iff revealed revealedResult hvalid + hstarts hrevealed).2 hcompletion + have hview : FinalizationViewEq table materialized revealedResult.toDeferredContext := + finalizationViewEq_materializeResolvedReveal revealed revealedResult hvalid hstarts + hrevealed hmaterializedCompletable + have hbase := relTriple_resolveDeferredPositionValue_of_finalizationViewEq table target + revealedResult.toDeferredContext materialized hview.symm hrevealedValid + hmaterializedValid hrevealedCompletable + have hleft := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (resolveDeferredPositionValue target revealedResult.toDeferredContext)) + (fun result hresult => hresult) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply OracleComp.ProgramLogic.Relational.evalDist_eq_of_relTriple_eqRel + apply OracleComp.ProgramLogic.Relational.relTriple_bind hboth + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResult with + | none => + cases rightResult with + | none => exact OracleComp.ProgramLogic.Relational.relTriple_pure_pure rfl + | some rightResult => simp [FinalizationResolutionEq] at hrelation + | some leftResult => + cases rightResult with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResult => + simp only + have hvalues : leftResult.values = rightResult.values := + resolveDeferredPositionValue_values_eq_of_values_eq target + revealedResult.toDeferredContext materialized leftResult rightResult + hleftSupport hrightSupport (by rfl) hrelation.1 + have hrightState := resolveDeferredPositionValue_state_eq_clearPending target + materialized rightResult hrightSupport + have hstate : + (context.state.clearPending (.position target)).materialize + (.position revealed) revealedResult.output = rightResult.state := by + rw [hrightState] + exact clearPending_materialize_comm context.state (.position target) + (.position revealed) revealedResult.output + apply OracleComp.ProgramLogic.Relational.relTriple_eqRel_of_evalDist_eq + rw [hstate, hvalues] + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_after_materialized_chainStart_observe + (observe : DeferredContext → ProbComp Bool) + (target : Position) (index : OtsSecretIndex) (context : DeferredContext) + (revealedResult : DeferredResolution) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hrevealed : resolveDeferredChainStart table index context = some revealedResult) : + evalDist (resolveDeferredPositionValue target revealedResult.toDeferredContext >>= + fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + observe + { state := (context.state.clearPending (.position target)).materialize + index.coordinate revealedResult.output + values := targetResult.values }) = + evalDist (resolveDeferredPositionValue target + (materializeResolvedChainStart context index revealedResult) >>= fun targetResult => + match targetResult with + | none => pure true + | some targetResult => observe targetResult.toDeferredContext) := by + let materialized := materializeResolvedChainStart context index revealedResult + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hrevealedValid := hvalid.of_resolveDeferredChainStart table index revealedResult hrevealed + have hstateValues := resolveDeferredChainStart_state_values_eq table index context + revealedResult hrevealed + have hdeferredValues := resolveDeferredChainStart_deferred_values_eq table index context + revealedResult hrevealed + have hrevealedCompletable := hcompletable.of_resolveDeferredChainStart index revealedResult + hrevealed + have houtput := resolveDeferredChainStart_output_of_agrees table index context revealedResult + hstarts hrevealed + have hmaterializedValid : materialized.Valid := by + dsimp only [materialized] + rw [materializeResolvedChainStart, hdeferredValues] + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + exact hvalid.materialize_chainStart lay tree leafIdx chainIdx revealedResult.output + have hmaterializedCompletable : DeferredCompletable table materialized := by + obtain ⟨completion, hcompletion⟩ := hrevealedCompletable + refine ⟨completion, ?_⟩ + exact (deferredCompletion_materializeResolvedChainStart_iff index revealedResult hstarts + houtput hstateValues hdeferredValues + (resolveDeferredChainStart_pending_eq table index context revealedResult hrevealed)).2 + hcompletion + have hview : FinalizationViewEq table materialized revealedResult.toDeferredContext := + finalizationViewEq_materializeResolvedChainStart index revealedResult hvalid hstarts + hrevealed hmaterializedCompletable + have hbase := relTriple_resolveDeferredPositionValue_of_finalizationViewEq table target + revealedResult.toDeferredContext materialized hview.symm hrevealedValid + hmaterializedValid hrevealedCompletable + have hleft := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (resolveDeferredPositionValue target revealedResult.toDeferredContext)) + (fun result hresult => hresult) + have hboth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply OracleComp.ProgramLogic.Relational.evalDist_eq_of_relTriple_eqRel + apply OracleComp.ProgramLogic.Relational.relTriple_bind hboth + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResult with + | none => + cases rightResult with + | none => exact OracleComp.ProgramLogic.Relational.relTriple_pure_pure rfl + | some rightResult => simp [FinalizationResolutionEq] at hrelation + | some leftResult => + cases rightResult with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResult => + simp only + have hvalues : leftResult.values = rightResult.values := + resolveDeferredPositionValue_values_eq_of_values_eq target + revealedResult.toDeferredContext materialized leftResult rightResult + hleftSupport hrightSupport (by rfl) hrelation.1 + have hrightState := resolveDeferredPositionValue_state_eq_clearPending target + materialized rightResult hrightSupport + have hstate : + (context.state.clearPending (.position target)).materialize + index.coordinate revealedResult.output = rightResult.state := by + rw [hrightState] + exact clearPending_materialize_comm context.state (.position target) + index.coordinate revealedResult.output + apply OracleComp.ProgramLogic.Relational.relTriple_eqRel_of_evalDist_eq + rw [hstate, hvalues] + +theorem evalDist_resolveDeferredPositionValue_after_materialized_reveal_runResolvedObserve + (target revealed : Position) (context : DeferredContext) + (revealedResult : DeferredResolution) (table : OtsSecretIndex → HashOutput) + (fuel : Nat) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hrevealed : some revealedResult ∈ support + (resolveDeferredReveal table revealed context)) : + evalDist (resolveDeferredPositionValue target revealedResult.toDeferredContext >>= + fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runResolvedObserve observe + { state := (context.state.clearPending (.position target)).materialize + (.position revealed) revealedResult.output + values := targetResult.values } + fuel table computation) = + evalDist (resolveDeferredPositionValue target + (materializeResolvedPosition context revealed revealedResult) >>= fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runResolvedObserve observe targetResult.toDeferredContext fuel table computation) := + evalDist_resolveDeferredPositionValue_after_materialized_reveal_observe + (fun nextContext => runResolvedObserve observe nextContext fuel table computation) + target revealed context revealedResult table hvalid hcompletable hrevealed + +theorem evalDist_resolveDeferredPositionValue_after_materialized_chainStart_runResolvedObserve + (target : Position) (index : OtsSecretIndex) (context : DeferredContext) + (revealedResult : DeferredResolution) (table : OtsSecretIndex → HashOutput) + (fuel : Nat) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (observe : DeferredContext → Nat → α → ProbComp Bool) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hrevealed : resolveDeferredChainStart table index context = some revealedResult) : + evalDist (resolveDeferredPositionValue target revealedResult.toDeferredContext >>= + fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runResolvedObserve observe + { state := (context.state.clearPending (.position target)).materialize + index.coordinate revealedResult.output + values := targetResult.values } + fuel table computation) = + evalDist (resolveDeferredPositionValue target + (materializeResolvedChainStart context index revealedResult) >>= fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runResolvedObserve observe targetResult.toDeferredContext fuel table computation) := + evalDist_resolveDeferredPositionValue_after_materialized_chainStart_observe + (fun nextContext => runResolvedObserve observe nextContext fuel table computation) + target index context revealedResult table hvalid hcompletable hrevealed + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_runResolvedObserve + (position : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : Coordinate.position position ∈ context.state.ensured) + (hbase : ∀ nextContext remaining value, + nextContext.Valid → DeferredCompletable table nextContext → + Coordinate.position position ∈ nextContext.state.ensured → + evalDist (resolveDeferredPositionValue position nextContext >>= fun resolved => + match resolved with + | none => pure true + | some resolved => observe resolved.toDeferredContext remaining value) = + evalDist (observe nextContext remaining value)) + [ObserverDooms table observe] : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + unfold runResolvedObserve + simp only [runResolvedFromTable, pure_bind] + exact hbase context fuel value hvalid hcompletable hensured + | query_bind query next ih => + cases query with + | uniform n => + unfold runResolvedObserve + simp only [runResolvedFromTable_uniform_query_bind, bind_assoc] + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) >>= fun output => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext fuel table + (next output) >>= + finishObserve observe) := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro resolved + cases resolved with + | none => + exact (OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) + (by simp) (pure true)).symm + | some resolved => rfl + _ = evalDist ((liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) >>= fun output => + resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext fuel table + (next output) >>= + finishObserve observe) := + OracleComp.DeferredSampling.evalDist_bind_comm + (resolveDeferredPositionValue position context) + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) _ + _ = _ := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + exact ih output context fuel hvalid hcompletable hensured + | hashOutput => + unfold runResolvedObserve + simp only [runResolvedFromTable_hashOutput_query_bind, bind_assoc] + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + LazyRevealProbe.sampleHashOutput >>= fun output => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext fuel table + (next output) >>= + finishObserve observe) := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro resolved + cases resolved with + | none => + exact (OracleComp.DeferredSampling.evalDist_bind_const_neverFails + LazyRevealProbe.sampleHashOutput (by + simp [LazyRevealProbe.sampleHashOutput]) (pure true)).symm + | some resolved => rfl + _ = evalDist (LazyRevealProbe.sampleHashOutput >>= fun output => + resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext fuel table + (next output) >>= + finishObserve observe) := + OracleComp.DeferredSampling.evalDist_bind_comm + (resolveDeferredPositionValue position context) + LazyRevealProbe.sampleHashOutput _ + _ = _ := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + exact ih output context fuel hvalid hcompletable hensured + | ensure coordinate => + unfold runResolvedObserve + simp_rw [runResolvedFromTable_ensure_query_bind] + calc + _ = evalDist (resolveDeferredPositionValue position + { context with state := context.state.ensure coordinate } >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext fuel table (next ()) >>= + finishObserve observe) := by + rw [resolveDeferredPositionValue_ensure] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply congrArg evalDist + apply bind_congr + intro resolved + cases resolved <;> rfl + _ = _ := ih () { context with state := context.state.ensure coordinate } fuel + (hvalid.ensure coordinate) (hcompletable.ensure coordinate) (by + exact Finset.mem_insert.mpr (Or.inr hensured)) + | probe coordinate candidate => + unfold runResolvedObserve + simp_rw [runResolvedFromTable_probe_query_bind] + cases fuel with + | zero => + simp only [pure_bind] + have hnone : finishObserve observe + (none : Option (ResolvedRunResult α)) = pure true := by + simp [finishObserve] + simp_rw [hnone] + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun _ => + pure true) := by + apply congrArg evalDist + apply bind_congr + intro resolved + cases resolved <;> rfl + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolveDeferredPositionValue position context) (by + simp [resolveDeferredPositionValue, LazyRevealProbe.sampleHashOutput]) + (pure true) + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext remaining table + (next ()) >>= + finishObserve observe) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hstate := resolveDeferredPositionValue_state_eq_clearPending + position context resolved hresolved + simp [hstate, LazyRevealProbe.State.clearPending, hrevealed] + _ = _ := by + simpa [runResolvedObserve, hrevealed] using + ih () context remaining hvalid hcompletable hensured + · by_cases heq : coordinate = .position position + · subst coordinate + let nextContext : DeferredContext := + { context with + state := context.state.addPending (.position position) candidate } + let continuation : Option DeferredResolution → ProbComp Bool + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext remaining table + (next ()) >>= + finishObserve observe + calc + _ = evalDist (resolveDeferredPositionValue position context >>= + fun first => + match first with + | none => pure true + | some first => + resolveDeferredPositionValue position + { first.toDeferredContext with + state := first.state.addPending (.position position) + candidate } >>= + continuation) := by + apply evalDist_bind_congr + intro first hfirst + cases first with + | none => rfl + | some first => + let added : DeferredContext := + { first.toDeferredContext with + state := first.state.addPending (.position position) candidate } + have hfirstValid := + hvalid.of_resolveDeferredPositionValue position first hfirst + have hfirstCompletable := + hcompletable.of_resolveDeferredPositionValue hvalid position first + hfirst + have hfirstState := resolveDeferredPositionValue_state_eq_clearPending + position context first hfirst + have hnotRevealed : + Coordinate.position position ∉ first.state.revealed := by + simpa [hfirstState, LazyRevealProbe.State.clearPending] using + hrevealed + have haddedEnsured : + Coordinate.position position ∈ added.state.ensured := by + simpa [added, hfirstState, LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.addPending] using hensured + by_cases haddedCompletable : DeferredCompletable table added + · simpa [added, continuation, DeferredResolution.addPending, + hnotRevealed, runResolvedObserve] using + (ih () added remaining + (hfirstValid.addPending_of_completable + (.position position) candidate haddedCompletable) + haddedCompletable haddedEnsured).symm + · have haddedConsistent : added.ValuesConsistent := + hfirstValid.valuesConsistent.addPending (.position position) + candidate + have hfirstStarts : StartTableAgrees first.state table := + startTableAgrees_of_deferredCompletable hfirstCompletable + have haddedStarts : StartTableAgrees added.state table := by + exact hfirstStarts + calc + _ = evalDist (pure true : ProbComp Bool) := by + simpa [added, hnotRevealed, runResolvedObserve] using + evalDist_runResolvedObserve_eq_true_of_not_completable_auto + (observe := observe) + added remaining table (next ()) haddedConsistent haddedStarts + haddedCompletable + _ = _ := by + symm + exact + evalDist_resolveDeferredPositionValue_then_runResolvedObserve_eq_true_of_not_completable_auto + position added remaining table (next ()) haddedConsistent + haddedStarts haddedCompletable + _ = evalDist ((do + let first ← resolveDeferredPositionValue position context + match first with + | none => (pure none : ProbComp (Option DeferredResolution)) + | some first => + resolveDeferredPositionValue position + { first.toDeferredContext with + state := first.state.addPending (.position position) + candidate }) >>= continuation) := by + simp only [bind_assoc] + apply congrArg evalDist + apply bind_congr + intro first + cases first <;> rfl + _ = evalDist (resolveDeferredPositionValue position nextContext >>= + continuation) := by + dsimp only [nextContext] + exact congrArg evalDist (congrArg (fun resolver => resolver >>= continuation) + (resolveDeferredPositionValue_then_addPending_self_resolve position + context candidate)) + _ = _ := by + have hnextConsistent : nextContext.ValuesConsistent := + hvalid.valuesConsistent.addPending (.position position) candidate + have hstarts : StartTableAgrees context.state table := + startTableAgrees_of_deferredCompletable hcompletable + have hnextStarts : StartTableAgrees nextContext.state table := by + exact hstarts + have hnextEnsured : + Coordinate.position position ∈ nextContext.state.ensured := hensured + by_cases hnextCompletable : DeferredCompletable table nextContext + · simpa [nextContext, continuation, hrevealed, + runResolvedObserve] using + ih () nextContext remaining + (hvalid.addPending_of_completable (.position position) candidate + hnextCompletable) + hnextCompletable hnextEnsured + · calc + _ = evalDist (pure true : ProbComp Bool) := + evalDist_resolveDeferredPositionValue_then_runResolvedObserve_eq_true_of_not_completable_auto + position nextContext remaining table (next ()) hnextConsistent + hnextStarts hnextCompletable + _ = _ := by + symm + simpa [nextContext, hrevealed, runResolvedObserve] using + evalDist_runResolvedObserve_eq_true_of_not_completable_auto + (observe := observe) + nextContext remaining table (next ()) hnextConsistent hnextStarts + hnextCompletable + · let nextContext : DeferredContext := + { context with state := context.state.addPending coordinate candidate } + by_cases hnextCompletable : DeferredCompletable table nextContext + · calc + _ = evalDist (resolveDeferredPositionValue position nextContext >>= + fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext remaining table + (next ()) >>= + finishObserve observe) := by + dsimp only [nextContext] + rw [resolveDeferredPositionValue_addPending_of_ne position context + coordinate candidate heq] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hstate := resolveDeferredPositionValue_state_eq_clearPending + position context resolved hresolved + have hnotRevealed : coordinate ∉ resolved.state.revealed := by + simpa [hstate, LazyRevealProbe.State.clearPending] using hrevealed + simp [DeferredResolution.addPending, hnotRevealed] + _ = _ := by + simpa [nextContext, hrevealed, runResolvedObserve] using + ih () nextContext remaining + (hvalid.addPending_of_completable coordinate candidate + hnextCompletable) + hnextCompletable (by exact hensured) + · have hnextConsistent : nextContext.ValuesConsistent := + hvalid.valuesConsistent.addPending coordinate candidate + have hstarts : StartTableAgrees context.state table := + startTableAgrees_of_deferredCompletable hcompletable + have hnextStarts : StartTableAgrees nextContext.state table := by + exact hstarts + calc + _ = evalDist (resolveDeferredPositionValue position nextContext >>= + fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext remaining table + (next ()) >>= + finishObserve observe) := by + dsimp only [nextContext] + rw [resolveDeferredPositionValue_addPending_of_ne position context + coordinate candidate heq] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hstate := resolveDeferredPositionValue_state_eq_clearPending + position context resolved hresolved + have hnotRevealed : coordinate ∉ resolved.state.revealed := by + simpa [hstate, LazyRevealProbe.State.clearPending] using hrevealed + simp [DeferredResolution.addPending, hnotRevealed] + _ = evalDist (pure true : ProbComp Bool) := by + calc + _ = evalDist (resolveDeferredPositionValue position nextContext >>= + fun _ => pure true) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hresolvedNotCompletable : + ¬DeferredCompletable table resolved.toDeferredContext := by + intro hresolvedCompletable + obtain ⟨completion, hcompletion⟩ := hresolvedCompletable + have hback := + (deferredCompletion_resolveDeferredPositionValue_iff position + resolved hnextConsistent hresolved completion).mp hcompletion + exact hnextCompletable ⟨completion, hback.1⟩ + exact + evalDist_runResolvedObserve_eq_true_of_not_completable_auto + resolved.toDeferredContext remaining table (next ()) + (hnextConsistent.of_resolveDeferredPositionValue position + resolved hresolved) + (hnextStarts.of_state_values_eq + (resolveDeferredPositionValue_preserves_state_values position + nextContext resolved hresolved)) + hresolvedNotCompletable + _ = _ := + OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolveDeferredPositionValue position nextContext) (by + simp [resolveDeferredPositionValue, + LazyRevealProbe.sampleHashOutput]) + (pure true) + _ = _ := by + symm + simpa [nextContext, hrevealed, runResolvedObserve] using + evalDist_runResolvedObserve_eq_true_of_not_completable_auto + (observe := observe) + nextContext remaining table (next ()) hnextConsistent hnextStarts + hnextCompletable + | peek coordinate => + unfold runResolvedObserve + simp_rw [runResolvedFromTable_peek_query_bind] + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext fuel table + (next (context.state.values coordinate)) >>= + finishObserve observe) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hvalues := resolveDeferredPositionValue_preserves_state_values position + context resolved hresolved + simp [hvalues] + _ = _ := ih (context.state.values coordinate) context fuel hvalid hcompletable + hensured + | publish coordinate => + unfold runResolvedObserve + simp_rw [runResolvedFromTable_publish_query_bind] + calc + _ = evalDist (resolveDeferredPositionValue position + { context with state := context.state.publish coordinate } >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext fuel table (next ()) >>= + finishObserve observe) := by + rw [resolveDeferredPositionValue_publish] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply congrArg evalDist + apply bind_congr + intro resolved + cases resolved <;> rfl + _ = _ := ih () { context with state := context.state.publish coordinate } fuel + (hvalid.publish coordinate) (hcompletable.publish coordinate) hensured + | reveal coordinate => + unfold runResolvedObserve + simp_rw [runResolvedFromTable_reveal_query_bind] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + let continuation : Option RevealedResolution → ProbComp Bool + | none => pure true + | some resolved => + runResolvedObserve observe + { state := (context.state.clearPending (.position position)).materialize + index.coordinate resolved.output + values := resolved.context.values } + fuel table (next resolved.output) + simp only + calc + _ = evalDist (resolvePositionThenChainStart position table index context >>= + continuation) := by + unfold resolvePositionThenChainStart continuation + simp only [bind_assoc] + apply evalDist_bind_congr + intro positionResult hpositionResult + cases positionResult with + | none => rfl + | some positionResult => + have hstate := resolveDeferredPositionValue_state_eq_clearPending + position context positionResult hpositionResult + cases hrevealedResult : resolveDeferredChainStart table index + positionResult.toDeferredContext with + | none => + dsimp only [index] at hrevealedResult ⊢ + simp [hrevealedResult, finishObserve] + | some revealedResult => + dsimp only [index] at hrevealedResult ⊢ + simp only [hrevealedResult, pure_bind] + rw [hstate] + rfl + _ = evalDist (resolveChainStartThenPosition position table index context >>= + continuation) := + evalDist_bind_eq_of_evalDist_eq + (evalDist_resolvePosition_chainStart_comm position table index context + hcompletable) + continuation + _ = evalDist (match resolveDeferredChainStart table index context with + | none => pure true + | some revealedResult => + resolveDeferredPositionValue position + revealedResult.toDeferredContext >>= + fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runResolvedObserve observe + { state := (context.state.clearPending + (.position position)).materialize + index.coordinate revealedResult.output + values := targetResult.values } + fuel table (next revealedResult.output)) := by + unfold resolveChainStartThenPosition continuation + cases resolveDeferredChainStart table index context with + | none => rfl + | some revealedResult => + simp only [bind_assoc] + apply congrArg evalDist + apply bind_congr + intro targetResult + cases targetResult <;> rfl + _ = evalDist (match resolveDeferredChainStart table index context with + | none => pure true + | some revealedResult => + runResolvedObserve observe + (materializeResolvedChainStart context index revealedResult) + fuel table (next revealedResult.output)) := by + cases hrevealedResult : resolveDeferredChainStart table index context with + | none => rfl + | some revealedResult => + have htransport := + evalDist_resolveDeferredPositionValue_after_materialized_chainStart_runResolvedObserve + position index context revealedResult table fuel + (next revealedResult.output) observe hvalid hcompletable hrevealedResult + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hdeferredValues := + resolveDeferredChainStart_deferred_values_eq table index context + revealedResult hrevealedResult + have hrevealedValid := hvalid.of_resolveDeferredChainStart table index + revealedResult hrevealedResult + have hrevealedCompletable := + hcompletable.of_resolveDeferredChainStart index revealedResult + hrevealedResult + have hstateValues := resolveDeferredChainStart_state_values_eq table index + context revealedResult hrevealedResult + have houtput := resolveDeferredChainStart_output_of_agrees table index + context revealedResult hstarts hrevealedResult + have hmaterializedValid : + (materializeResolvedChainStart context index revealedResult).Valid := by + rw [materializeResolvedChainStart, hdeferredValues] + exact hvalid.materialize_chainStart lay tree leafIdx chainIdx + revealedResult.output + have hmaterializedCompletable : DeferredCompletable table + (materializeResolvedChainStart context index revealedResult) := by + obtain ⟨completion, hcompletion⟩ := hrevealedCompletable + refine ⟨completion, ?_⟩ + exact (deferredCompletion_materializeResolvedChainStart_iff index + revealedResult hstarts houtput hstateValues hdeferredValues + (resolveDeferredChainStart_pending_eq table index context + revealedResult hrevealedResult)).2 hcompletion + have hmaterializedEnsured : Coordinate.position position ∈ + (materializeResolvedChainStart context index + revealedResult).state.ensured := by + change Coordinate.position position ∈ + insert index.coordinate context.state.ensured + exact Finset.mem_insert.mpr (Or.inr hensured) + exact htransport.trans + (ih revealedResult.output + (materializeResolvedChainStart context index revealedResult) fuel + hmaterializedValid hmaterializedCompletable + hmaterializedEnsured) + _ = _ := by + cases hrevealedResult : resolveDeferredChainStart table index context with + | none => + simp [finishObserve] + | some revealedResult => + simp only [pure_bind, materializeResolvedChainStart] + rfl + | position revealed => + let resolver : PrivateResolver := fun nextContext => + resolveDeferredReveal table revealed nextContext + let continuation : Option RevealedResolution → ProbComp Bool + | none => pure true + | some resolved => + runResolvedObserve observe + { state := (context.state.clearPending (.position position)).materialize + (.position revealed) resolved.output + values := resolved.context.values } + fuel table (next resolved.output) + simp only + calc + _ = evalDist (resolvePositionThenResolver position resolver context >>= + continuation) := by + unfold resolvePositionThenResolver resolver continuation + simp only [bind_assoc] + apply evalDist_bind_congr + intro positionResult hpositionResult + cases positionResult with + | none => rfl + | some positionResult => + simp only [bind_assoc] + apply evalDist_bind_congr + intro revealedResult _hrevealedResult + cases revealedResult with + | none => rfl + | some revealedResult => + have hstate := resolveDeferredPositionValue_state_eq_clearPending + position context positionResult hpositionResult + simp only + rw [hstate] + simp only [pure_bind] + rfl + _ = evalDist (resolveResolverThenPosition position resolver context >>= + continuation) := + evalDist_bind_eq_of_evalDist_eq + (positionResolutionCommutes_reveal position table revealed context hvalid + hcompletable) + continuation + _ = evalDist (resolveDeferredReveal table revealed context >>= + fun revealedResult => + match revealedResult with + | none => pure true + | some revealedResult => + resolveDeferredPositionValue position + revealedResult.toDeferredContext >>= + fun targetResult => + match targetResult with + | none => pure true + | some targetResult => + runResolvedObserve observe + { state := (context.state.clearPending + (.position position)).materialize + (.position revealed) revealedResult.output + values := targetResult.values } + fuel table (next revealedResult.output)) := by + unfold resolveResolverThenPosition resolver continuation + simp only [bind_assoc] + apply congrArg evalDist + apply bind_congr + intro revealedResult + cases revealedResult with + | none => rfl + | some revealedResult => + simp only [bind_assoc] + apply bind_congr + intro targetResult + cases targetResult <;> rfl + _ = evalDist (resolveDeferredReveal table revealed context >>= + fun revealedResult => + match revealedResult with + | none => pure true + | some revealedResult => + runResolvedObserve observe + (materializeResolvedPosition context revealed revealedResult) + fuel table (next revealedResult.output)) := by + apply evalDist_bind_congr + intro revealedResult hrevealedResult + cases revealedResult with + | none => rfl + | some revealedResult => + have htransport := + evalDist_resolveDeferredPositionValue_after_materialized_reveal_runResolvedObserve + position revealed context revealedResult table fuel + (next revealedResult.output) observe hvalid hcompletable hrevealedResult + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hrevealedValid := hvalid.of_resolveDeferredReveal table revealed + revealedResult hrevealedResult + have hstateValues := resolveDeferredReveal_preserves_state_values table + revealed context revealedResult hrevealedResult + have hresolved := resolveDeferredReveal_resolves table revealed context + revealedResult hrevealedResult + have hmaterializedValid := + hvalid.materializeResolvedPosition_of revealed revealedResult + hrevealedValid hstateValues hresolved + have hrevealedCompletable := + hcompletable.of_resolveDeferredReveal hvalid revealed revealedResult + hrevealedResult + have hmaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition context revealed revealedResult) := by + obtain ⟨completion, hcompletion⟩ := hrevealedCompletable + refine ⟨completion, ?_⟩ + exact (deferredCompletion_materializeResolvedReveal_iff revealed + revealedResult hvalid hstarts hrevealedResult).2 hcompletion + have hmaterializedEnsured : Coordinate.position position ∈ + (materializeResolvedPosition context revealed + revealedResult).state.ensured := by + change Coordinate.position position ∈ + insert (.position revealed) context.state.ensured + exact Finset.mem_insert.mpr (Or.inr hensured) + exact htransport.trans + (ih revealedResult.output + (materializeResolvedPosition context revealed revealedResult) fuel + hmaterializedValid hmaterializedCompletable + hmaterializedEnsured) + _ = _ := by + simp only [materializeResolvedPosition, bind_assoc] + apply congrArg evalDist + apply bind_congr + intro revealedResult + cases revealedResult <;> rfl + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_runResolvedObserve_auto + (position : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : Coordinate.position position ∈ context.state.ensured) + [ObserverDooms table observe] [ObserverPositionNeutral table observe] : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) := by + apply evalDist_resolveDeferredPositionValue_then_runResolvedObserve position computation + context fuel table hvalid hcompletable hensured + intro nextContext remaining value hnextValid hnextCompletable hnextEnsured + exact ObserverPositionNeutral.eq_resolve (table := table) (observe := observe) position + nextContext remaining value hnextValid hnextCompletable hnextEnsured + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_runResolvedObserve_auto_at + (position : Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : Coordinate.position position ∈ context.state.ensured) + [ObserverDooms table observe] + (hneutral : ObserverPositionNeutralAt table position observe) : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) := by + apply evalDist_resolveDeferredPositionValue_then_runResolvedObserve position computation + context fuel table hvalid hcompletable hensured + exact hneutral + +theorem evalDist_runResolvedObserve_eq_of_finalizationSynchronized + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (left right : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) + (hrevealed : left.state.revealed = right.state.revealed) : + evalDist (runResolvedObserve observe left fuel table computation) = + evalDist (runResolvedObserve observe right fuel table computation) := by + induction computation using OracleComp.inductionOn generalizing left right fuel with + | pure value => + unfold runResolvedObserve + simp only [runResolvedFromTable, pure_bind] + exact ObserverSynchronized.eq_of_synchronized left right fuel value hcontext + hvalues hrevealed + | query_bind query next ih => + cases query with + | uniform n => + unfold runResolvedObserve + simp only [runResolvedFromTable_uniform_query_bind, bind_assoc] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + exact ih output left right fuel hcontext hvalues hrevealed + | hashOutput => + unfold runResolvedObserve + simp only [runResolvedFromTable_hashOutput_query_bind, bind_assoc] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + exact ih output left right fuel hcontext hvalues hrevealed + | ensure coordinate => + unfold runResolvedObserve + simp only [runResolvedFromTable_ensure_query_bind] + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + apply ih () + · exact ⟨hview.ensure coordinate, hleftValid.ensure coordinate, + hrightValid.ensure coordinate, hleftCompletable.ensure coordinate⟩ + · exact hvalues + · exact hrevealed + | peek coordinate => + unfold runResolvedObserve + simp only [runResolvedFromTable_peek_query_bind] + rw [hvalues] + exact ih (right.state.values coordinate) left right fuel hcontext hvalues hrevealed + | publish coordinate => + unfold runResolvedObserve + simp only [runResolvedFromTable_publish_query_bind] + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + apply ih () + · exact ⟨hview.publish coordinate, hleftValid.publish coordinate, + hrightValid.publish coordinate, hleftCompletable.publish coordinate⟩ + · exact hvalues + · simpa [LazyRevealProbe.State.publish] using congrArg (insert coordinate) hrevealed + | probe coordinate candidate => + unfold runResolvedObserve + simp only [runResolvedFromTable_probe_query_bind] + cases fuel with + | zero => rfl + | succ remaining => + by_cases hleftRevealed : coordinate ∈ left.state.revealed + · have hrightRevealed : coordinate ∈ right.state.revealed := by + rw [← hrevealed] + exact hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + exact ih () left right remaining hcontext hvalues hrevealed + · have hrightRevealed : coordinate ∉ right.state.revealed := by + rwa [← hrevealed] + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + let left' : DeferredContext := + { left with state := left.state.addPending coordinate candidate } + let right' : DeferredContext := + { right with state := right.state.addPending coordinate candidate } + have hcompletableIff : DeferredCompletable table left' ↔ + DeferredCompletable table right' := by + exact deferredCompletable_addPending_iff_of_finalizationViewEq + hcontext.1 coordinate candidate + by_cases hleftCompletable : DeferredCompletable table left' + · have hrightCompletable : DeferredCompletable table right' := + hcompletableIff.mp hleftCompletable + apply ih () left' right' remaining + · exact ⟨hcontext.1.addPending_of_completable coordinate candidate + hleftCompletable hrightCompletable, + hcontext.2.1.addPending_of_completable coordinate candidate + hleftCompletable, + hcontext.2.2.1.addPending_of_completable coordinate candidate + hrightCompletable, + hleftCompletable⟩ + · exact hvalues + · exact hrevealed + · have hrightCompletable : ¬DeferredCompletable table right' := by + rwa [← hcompletableIff] + calc + _ = evalDist (pure true : ProbComp Bool) := + evalDist_runResolvedObserve_eq_true_of_not_completable_auto (observe := observe) + left' remaining table (next ()) hcontext.2.1.1 hcontext.1.leftStarts + hleftCompletable + _ = evalDist (runResolvedObserve observe right' remaining table + (next ())) := + (evalDist_runResolvedObserve_eq_true_of_not_completable_auto (observe := observe) + right' remaining table (next ()) hcontext.2.2.1.1 hcontext.1.rightStarts + hrightCompletable).symm + | reveal coordinate => + unfold runResolvedObserve + simp_rw [runResolvedFromTable_reveal_query_bind] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + simp only [bind_assoc] + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hresolved := relTriple_resolveDeferredChainStart_of_finalizationViewEq + table index left right hview hleftValid hrightValid hleftCompletable + have hresolvedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolved + (fun result => result ∈ support + (pure (resolveDeferredChainStart table index left) : + ProbComp (Option DeferredResolution))) + (fun result hresult => hresult) + have hresolvedBoth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support + hresolvedLeft + apply evalDist_eq_of_relTriple_eqRel + apply relTriple_bind hresolvedBoth + intro leftResolved rightResolved hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResolved with + | none => + cases rightResolved with + | none => simp [EqRel] + | some rightResolved => simp [FinalizationResolutionEq] at hrelation + | some leftResolved => + cases rightResolved with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResolved => + have hleftResult : + resolveDeferredChainStart table index left = some leftResolved := by + simpa using hleftSupport.symm + have hrightResult : + resolveDeferredChainStart table index right = some rightResolved := by + simpa using hrightSupport.symm + have hleftMaterializedCompletable := + hleftCompletable.materializeResolvedChainStart hview.leftStarts index + leftResolved hleftResult + have hrightCompletable : DeferredCompletable table right := by + rcases hleftCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, + (hview.deferredCompletion_iff completion).mp hcompletion⟩ + have hrightMaterializedCompletable := + hrightCompletable.materializeResolvedChainStart hview.rightStarts index + rightResolved hrightResult + have hleftMaterializedView := + finalizationViewEq_materializeResolvedChainStart index leftResolved + hleftValid hview.leftStarts hleftResult + hleftMaterializedCompletable + have hrightMaterializedView := + finalizationViewEq_materializeResolvedChainStart index rightResolved + hrightValid hview.rightStarts hrightResult + hrightMaterializedCompletable + have hleftMaterializedValid : + (materializeResolvedChainStart left index leftResolved).Valid := by + unfold materializeResolvedChainStart + rw [resolveDeferredChainStart_deferred_values_eq table index left + leftResolved hleftResult] + exact hleftValid.materialize_chainStart lay tree leafIdx chainIdx + leftResolved.output + have hrightMaterializedValid : + (materializeResolvedChainStart right index rightResolved).Valid := by + unfold materializeResolvedChainStart + rw [resolveDeferredChainStart_deferred_values_eq table index right + rightResolved hrightResult] + exact hrightValid.materialize_chainStart lay tree leafIdx chainIdx + rightResolved.output + have hnext := ih leftResolved.output + (materializeResolvedChainStart left index leftResolved) + (materializeResolvedChainStart right index rightResolved) fuel + ⟨hleftMaterializedView.trans + (hrelation.2.1.trans hrightMaterializedView.symm), + hleftMaterializedValid, hrightMaterializedValid, + hleftMaterializedCompletable⟩ + (by + change Function.update left.state.values index.coordinate + (some leftResolved.output) = + Function.update right.state.values index.coordinate + (some rightResolved.output) + rw [hrelation.1, hvalues]) + (by + simpa [materializeResolvedChainStart, + LazyRevealProbe.State.materialize] using hrevealed) + apply relTriple_eqRel_of_evalDist_eq + simpa only [runResolvedObserve, materializeResolvedChainStart, + index, OtsSecretIndex.coordinate, hrelation.1] using hnext + | position position => + simp only [bind_assoc] + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hresolved := relTriple_resolveDeferredReveal_of_finalizationViewEq table + position left right hview hleftValid hrightValid hleftCompletable + have hresolvedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolved + (fun result => result ∈ support + (resolveDeferredReveal table position left)) + (fun result hresult => hresult) + have hresolvedBoth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support + hresolvedLeft + apply evalDist_eq_of_relTriple_eqRel + apply relTriple_bind hresolvedBoth + intro leftResolved rightResolved hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResolved with + | none => + cases rightResolved with + | none => simp [EqRel] + | some rightResolved => simp [FinalizationResolutionEq] at hrelation + | some leftResolved => + cases rightResolved with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResolved => + have hleftMaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition left position leftResolved) := by + rcases hrelation.2.2.2.2 with ⟨completion, hcompletion⟩ + exact ⟨completion, + (deferredCompletion_materializeResolvedReveal_iff position + leftResolved hleftValid hview.leftStarts hleftSupport).mpr + hcompletion⟩ + have hrightRawCompletable : + DeferredCompletable table rightResolved.toDeferredContext := by + rcases hrelation.2.2.2.2 with ⟨completion, hcompletion⟩ + exact ⟨completion, + (hrelation.2.1.deferredCompletion_iff completion).mp hcompletion⟩ + have hrightMaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition right position rightResolved) := by + rcases hrightRawCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, + (deferredCompletion_materializeResolvedReveal_iff position + rightResolved hrightValid hview.rightStarts hrightSupport).mpr + hcompletion⟩ + have hleftMaterializedView := + finalizationViewEq_materializeResolvedReveal position leftResolved + hleftValid hview.leftStarts hleftSupport + hleftMaterializedCompletable + have hrightMaterializedView := + finalizationViewEq_materializeResolvedReveal position rightResolved + hrightValid hview.rightStarts hrightSupport + hrightMaterializedCompletable + have hleftResultValid := hleftValid.of_resolveDeferredReveal table + position leftResolved hleftSupport + have hrightResultValid := hrightValid.of_resolveDeferredReveal table + position rightResolved hrightSupport + have hleftStateValues := + resolveDeferredReveal_preserves_state_values table position left + leftResolved hleftSupport + have hrightStateValues := + resolveDeferredReveal_preserves_state_values table position right + rightResolved hrightSupport + have hleftResolvedValue := resolveDeferredReveal_resolves table position + left leftResolved hleftSupport + have hrightResolvedValue := resolveDeferredReveal_resolves table position + right rightResolved hrightSupport + have hleftMaterializedValid : + (materializeResolvedPosition left position leftResolved).Valid := + hleftValid.materializeResolvedPosition_of position leftResolved + hleftResultValid hleftStateValues hleftResolvedValue + have hrightMaterializedValid : + (materializeResolvedPosition right position rightResolved).Valid := + hrightValid.materializeResolvedPosition_of position rightResolved + hrightResultValid hrightStateValues hrightResolvedValue + have hnext := ih leftResolved.output + (materializeResolvedPosition left position leftResolved) + (materializeResolvedPosition right position rightResolved) fuel + ⟨hleftMaterializedView.trans + (hrelation.2.1.trans hrightMaterializedView.symm), + hleftMaterializedValid, hrightMaterializedValid, + hleftMaterializedCompletable⟩ + (by + change Function.update left.state.values (.position position) + (some leftResolved.output) = + Function.update right.state.values (.position position) + (some rightResolved.output) + rw [hrelation.1, hvalues]) + (by + simpa [materializeResolvedPosition, + LazyRevealProbe.State.materialize] using hrevealed) + apply relTriple_eqRel_of_evalDist_eq + simpa only [runResolvedObserve, materializeResolvedPosition, + hrelation.1] using hnext + +theorem evalDist_resolveDeferredChainStart_then_runResolvedObserve + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (match resolveDeferredChainStart table index context with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) := by + let result : DeferredResolution := + ⟨{ state := context.state.clearPending index.coordinate, values := context.values }, + table index⟩ + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hclean := hcompletable.not_hitAt_chainStart index + have hresult : resolveDeferredChainStart table index context = some result := by + cases hstate : context.state.values index.coordinate with + | some output => + have houtput := hstarts index output hstate + simp [resolveDeferredChainStart, hstate, houtput, hclean, result] + | none => simp [resolveDeferredChainStart, hstate, hclean, result] + rw [hresult] + exact evalDist_runResolvedObserve_eq_of_finalizationSynchronized computation + result.toDeferredContext context fuel table + (finalizationContextEq_resolveDeferredChainStart_original table index context result + hvalid hcompletable hresult) + (resolveDeferredChainStart_state_values_eq table index context result hresult) + (by + rw [resolveDeferredChainStart_state_eq_clearPending table index context result hresult] + rfl) + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredChainPrefix_then_runResolvedObserve + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe], + context.Valid → DeferredCompletable table context → + (∀ step : ChainStep, step.val < steps → + Coordinate.position (.chain lay tree leafIdx chainIdx step) ∈ + context.state.ensured) → + evalDist (do + let resolved ← resolveDeferredChainPrefix table lay tree leafIdx chainIdx + steps hsteps context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) + | 0, hsteps, context, fuel, computation, observe, _hdooms, _hsynchronized, + _hposition, hvalid, hcompletable, _hensured => by + simp only [resolveDeferredChainPrefix, pure_bind] + exact evalDist_resolveDeferredChainStart_then_runResolvedObserve table + ⟨lay, tree, leafIdx, chainIdx⟩ context fuel computation hvalid hcompletable + | steps + 1, hsteps, context, fuel, computation, observe, _hdooms, _hsynchronized, + _hposition, hvalid, hcompletable, hensured => by + rw [resolveDeferredChainPrefix] + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps + (by omega) context >>= fun previous => + match previous with + | none => pure true + | some previous => + runResolvedObserve observe previous.toDeferredContext fuel table computation) := by + apply evalDist_bind_congr + intro previous hprevious + cases previous with + | none => rfl + | some previous => + let position : Position := + .chain lay tree leafIdx chainIdx ⟨steps, by omega⟩ + have hpreviousValid := hvalid.of_resolveDeferredChainPrefix table lay tree + leafIdx chainIdx steps (by omega) previous hprevious + have hpreviousCompletable := + hcompletable.of_resolveDeferredChainPrefix hvalid hprevious + have hprivate := privateStateAgrees_resolveDeferredChainPrefix table lay tree + leafIdx chainIdx steps (by omega) context previous hprevious + have hpositionEnsured : Coordinate.position position ∈ + previous.state.ensured := by + rw [hprivate.2.2] + exact hensured ⟨steps, by omega⟩ (by simp) + exact evalDist_resolveDeferredPositionValue_then_runResolvedObserve_auto + (observe := observe) + position computation previous.toDeferredContext fuel table hpreviousValid + hpreviousCompletable hpositionEnsured + _ = _ := + evalDist_resolveDeferredChainPrefix_then_runResolvedObserve table lay tree + leafIdx chainIdx steps (by omega) context fuel computation hvalid hcompletable + (fun step hstep => hensured step (by omega)) +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredChains_then_runResolvedObserve + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + ∀ (chains : List ChainIndex) (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe], + context.Valid → DeferredCompletable table context → + (∀ chainIdx ∈ chains, FullChainEnsured lay tree leafIdx chainIdx context) → + evalDist (do + let resolved ← resolveDeferredChains table lay tree leafIdx chains context + match resolved with + | none => pure true + | some resolved => runResolvedObserve observe resolved fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) + | [], context, fuel, computation, observe, _hdooms, _hsynchronized, _hposition, + _hvalid, _hcompletable, _hensured => by + simp [resolveDeferredChains] + | chainIdx :: remaining, context, fuel, computation, observe, _hdooms, _hsynchronized, + _hposition, hvalid, hcompletable, hensured => by + rw [resolveDeferredChains] + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredChainPrefix table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hresolvedValid := hvalid.of_resolveDeferredChainPrefix table lay tree + leafIdx chainIdx (chainLength - 1) (by omega) resolved hresolved + have hresolvedCompletable := + hcompletable.of_resolveDeferredChainPrefix hvalid hresolved + have hprivate := privateStateAgrees_resolveDeferredChainPrefix table lay tree + leafIdx chainIdx (chainLength - 1) (by omega) context resolved hresolved + apply evalDist_resolveDeferredChains_then_runResolvedObserve table lay tree + leafIdx remaining resolved.toDeferredContext fuel computation hresolvedValid + hresolvedCompletable + intro other hother step + rw [hprivate.2.2] + exact hensured other (by simp [hother]) step + _ = _ := + evalDist_resolveDeferredChainPrefix_then_runResolvedObserve table lay tree + leafIdx chainIdx (chainLength - 1) (by omega) context fuel computation hvalid + hcompletable (fun step _ => hensured chainIdx (by simp) step) + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredOtsLeaf_then_runResolvedObserve + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : OtsLeafEnsured lay tree leafIdx context) : + evalDist (do + let resolved ← resolveDeferredOtsLeaf table lay tree leafIdx context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) := by + rw [resolveDeferredOtsLeaf] + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) context >>= fun chains => + match chains with + | none => pure true + | some chains => runResolvedObserve observe chains fuel table computation) := by + apply evalDist_bind_congr + intro chains hchains + cases chains with + | none => rfl + | some chains => + have hchainsValid := hvalid.of_resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) chains hchains + have hchainsCompletable := hcompletable.of_resolveDeferredChains hvalid hchains + have hprivate := privateStateAgrees_resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) context chains hchains + have hleafEnsured : Coordinate.position (.leaf lay tree leafIdx) ∈ + chains.state.ensured := by + rw [hprivate.2.2] + exact hensured.2 + exact evalDist_resolveDeferredPositionValue_then_runResolvedObserve_auto + (observe := observe) + (.leaf lay tree leafIdx) computation chains fuel table hchainsValid + hchainsCompletable hleafEnsured + _ = _ := evalDist_resolveDeferredChains_then_runResolvedObserve table lay tree + leafIdx (List.ofFn fun chainIdx : ChainIndex => chainIdx) context fuel computation + hvalid hcompletable (by + intro chainIdx _hmem + exact hensured.1 chainIdx) + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredTreeNode_then_runResolvedObserve + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe], + context.Valid → DeferredCompletable table context → + TreeNodeEnsured lay tree level nodeIdx context → + evalDist (do + let resolved ← resolveDeferredTreeNode table lay tree level nodeIdx hlevel context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve observe resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) + | 0, nodeIdx, hlevel, context, fuel, computation, observe, _hdooms, _hsynchronized, + _hposition, hvalid, hcompletable, hensured => + evalDist_resolveDeferredOtsLeaf_then_runResolvedObserve table lay tree + (leafOfNat nodeIdx) context fuel computation hvalid hcompletable hensured + | level + 1, nodeIdx, hlevel, context, fuel, computation, observe, _hdooms, + _hsynchronized, _hposition, hvalid, hcompletable, hensured => by + rw [resolveDeferredTreeNode] + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredTreeNode table lay tree level (2 * nodeIdx) + (by omega) context >>= fun leftResult => + match leftResult with + | none => pure true + | some leftResult => + runResolvedObserve observe leftResult.toDeferredContext fuel table computation) := by + apply evalDist_bind_congr + intro leftResult hleft + cases leftResult with + | none => rfl + | some leftResult => + have hleftValid := hvalid.of_resolveDeferredTreeNode table lay tree level + (2 * nodeIdx) (by omega) leftResult hleft + have hleftCompletable := + hcompletable.of_resolveDeferredTreeNode hvalid hleft + have hleftPrivate := privateStateAgrees_resolveDeferredTreeNode table lay tree + level (2 * nodeIdx) (by omega) context leftResult hleft + have hrightEnsured : TreeNodeEnsured lay tree level (2 * nodeIdx + 1) + leftResult.toDeferredContext := by + exact (treeNodeEnsured_congr_ensured lay tree level (2 * nodeIdx + 1) + context leftResult.toDeferredContext hleftPrivate.2.2.symm).mp + hensured.2.1 + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredTreeNode table lay tree level + (2 * nodeIdx + 1) (by omega) leftResult.toDeferredContext >>= + fun rightResult => + match rightResult with + | none => pure true + | some rightResult => + runResolvedObserve observe rightResult.toDeferredContext fuel table + computation) := by + apply evalDist_bind_congr + intro rightResult hright + cases rightResult with + | none => rfl + | some rightResult => + have hrightValid := hleftValid.of_resolveDeferredTreeNode table lay tree + level (2 * nodeIdx + 1) (by omega) rightResult hright + have hrightCompletable := + hleftCompletable.of_resolveDeferredTreeNode hleftValid hright + have hrightPrivate := privateStateAgrees_resolveDeferredTreeNode table lay + tree level (2 * nodeIdx + 1) (by omega) + leftResult.toDeferredContext rightResult hright + obtain ⟨hnodeLevel, hnodeBase⟩ := hensured.2.2 + have hnodeEnsured : Coordinate.position + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) ∈ + rightResult.state.ensured := by + rw [hrightPrivate.2.2, hleftPrivate.2.2] + simpa using hnodeBase + exact + evalDist_resolveDeferredPositionValue_then_runResolvedObserve_auto + (observe := observe) + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) computation + rightResult.toDeferredContext fuel table hrightValid + hrightCompletable hnodeEnsured + _ = _ := + evalDist_resolveDeferredTreeNode_then_runResolvedObserve table lay tree + level (2 * nodeIdx + 1) (by omega) leftResult.toDeferredContext fuel + computation hleftValid hleftCompletable hrightEnsured + _ = _ := + evalDist_resolveDeferredTreeNode_then_runResolvedObserve table lay tree level + (2 * nodeIdx) (by omega) context fuel computation hvalid hcompletable hensured.1 + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredSelectedChainFamily_then_runResolvedObserve + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + ∀ {n : Nat} (family : Fin n → ChainIndex) (digits : Fin n → Digit) + (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe], + context.Valid → DeferredCompletable table context → + (∀ index (step : ChainStep), step.val < (digits index).val → + Coordinate.position (.chain lay tree leafIdx (family index) step) ∈ + context.state.ensured) → + evalDist (do + let resolved ← resolveDeferredSelectedChainFamily table lay tree leafIdx + family digits context + match resolved with + | none => pure true + | some (finalContext, _) => + runResolvedObserve observe finalContext fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) + | 0, family, digits, context, fuel, computation, observe, _hdooms, _hsynchronized, + _hposition, _hvalid, _hcompletable, _hensured => by + simp [resolveDeferredSelectedChainFamily] + | n + 1, family, digits, context, fuel, computation, observe, _hdooms, + _hsynchronized, _hposition, hvalid, hcompletable, hensured => by + rw [resolveDeferredSelectedChainFamily] + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredChainPrefix table lay tree leafIdx (family 0) + (digits 0).val (by have := (digits 0).isLt; omega) context >>= + fun headOption => + match headOption with + | none => pure true + | some head => + runResolvedObserve observe head.toDeferredContext fuel table computation) := by + apply evalDist_bind_congr + intro headOption hhead + cases headOption with + | none => rfl + | some head => + have hheadValid := hvalid.of_resolveDeferredChainPrefix table lay tree leafIdx + (family 0) (digits 0).val (by have := (digits 0).isLt; omega) head hhead + have hheadCompletable := + hcompletable.of_resolveDeferredChainPrefix hvalid hhead + have hprivate := privateStateAgrees_resolveDeferredChainPrefix table lay tree + leafIdx (family 0) (digits 0).val + (by have := (digits 0).isLt; omega) context head hhead + have htail := + evalDist_resolveDeferredSelectedChainFamily_then_runResolvedObserve + (observe := observe) + table lay tree leafIdx (fun index : Fin n => family index.succ) + (fun index : Fin n => digits index.succ) head.toDeferredContext fuel + computation hheadValid hheadCompletable (by + intro index step hstep + rw [hprivate.2.2] + exact hensured index.succ step hstep) + calc + _ = evalDist (do + let tail ← resolveDeferredSelectedChainFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) + (fun index : Fin n => digits index.succ) head.toDeferredContext + match tail with + | none => pure true + | some (finalContext, _) => + runResolvedObserve observe finalContext fuel table computation) := by + apply congrArg evalDist + simp only [bind_assoc] + apply bind_congr + intro tailOption + cases tailOption <;> simp + _ = _ := htail + _ = _ := + evalDist_resolveDeferredChainPrefix_then_runResolvedObserve table lay tree + leafIdx (family 0) (digits 0).val + (by have := (digits 0).isLt; omega) context fuel computation hvalid + hcompletable (fun step hstep => hensured 0 step hstep) + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredLayerPathFamily_then_runResolvedObserve + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + ∀ {n : Nat} (family : Fin n → Fin maxLayerHeight) + (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe], + context.Valid → DeferredCompletable table context → + (∀ index, (family index).val < layerHeight lay → + TreeNodeEnsured lay tree (family index).val + (Nat.xor (leafIdx.val / 2 ^ (family index).val) 1) context) → + evalDist (do + let resolved ← resolveDeferredLayerPathFamily table lay tree leafIdx family context + match resolved with + | none => pure true + | some (finalContext, _) => + runResolvedObserve observe finalContext fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) + | 0, family, context, fuel, computation, observe, _hdooms, _hsynchronized, _hposition, + _hvalid, _hcompletable, _hensured => by + simp [resolveDeferredLayerPathFamily] + | n + 1, family, context, fuel, computation, observe, _hdooms, _hsynchronized, + _hposition, hvalid, hcompletable, hensured => by + rw [resolveDeferredLayerPathFamily] + by_cases hinLayer : (family 0).val < layerHeight lay + · simp only [hinLayer, ↓reduceDIte, bind_assoc] + calc + _ = evalDist (resolveDeferredTreeNode table lay tree (family 0).val + (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) context >>= fun headOption => + match headOption with + | none => pure true + | some head => + runResolvedObserve observe head.toDeferredContext fuel table computation) := by + apply evalDist_bind_congr + intro headOption hhead + cases headOption with + | none => rfl + | some head => + have hheadValid := hvalid.of_resolveDeferredTreeNode table lay tree + (family 0).val (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) head hhead + have hheadCompletable := hcompletable.of_resolveDeferredTreeNode hvalid hhead + have hprivate := privateStateAgrees_resolveDeferredTreeNode table lay tree + (family 0).val (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) context head hhead + have htail := + evalDist_resolveDeferredLayerPathFamily_then_runResolvedObserve + (observe := observe) + table lay tree leafIdx (fun index : Fin n => family index.succ) + head.toDeferredContext fuel computation hheadValid hheadCompletable (by + intro index hindex + apply (treeNodeEnsured_congr_ensured lay tree + (family index.succ).val + (Nat.xor (leafIdx.val / 2 ^ (family index.succ).val) 1) + context head.toDeferredContext hprivate.2.2.symm).mp + exact hensured index.succ hindex) + calc + _ = evalDist (do + let tail ← resolveDeferredLayerPathFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) head.toDeferredContext + match tail with + | none => pure true + | some (finalContext, _) => + runResolvedObserve observe finalContext fuel table computation) := by + apply congrArg evalDist + simp only [bind_assoc] + apply bind_congr + intro tailOption + cases tailOption <;> simp + _ = _ := htail + _ = _ := evalDist_resolveDeferredTreeNode_then_runResolvedObserve table lay tree + (family 0).val (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) context fuel computation hvalid + hcompletable (hensured 0 hinLayer) + · simp only [hinLayer, ↓reduceDIte, bind_assoc] + calc + _ = evalDist (do + let tail ← resolveDeferredLayerPathFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) context + match tail with + | none => pure true + | some (finalContext, _) => + runResolvedObserve observe finalContext fuel table computation) := by + apply congrArg evalDist + apply bind_congr + intro tailOption + cases tailOption <;> simp + _ = _ := + evalDist_resolveDeferredLayerPathFamily_then_runResolvedObserve table lay tree + leafIdx (fun index : Fin n => family index.succ) context fuel computation hvalid + hcompletable (fun index hindex => hensured index.succ hindex) + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredLayerValues_then_runResolvedObserve + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : LayerValuesEnsured index lay encoding context) : + evalDist (do + let resolved ← resolveDeferredLayerValues table index lay encoding context + match resolved with + | none => pure true + | some (finalContext, _) => + runResolvedObserve observe finalContext fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) := by + let chainFamily : ChainIndex → ChainIndex := fun chainIdx => chainIdx + let pathFamily : Fin maxLayerHeight → Fin maxLayerHeight := fun level => level + change evalDist (do + let resolved ← resolveDeferredLayerValues table index lay encoding context + match resolved with + | none => pure true + | some (finalContext, _) => + runResolvedObserve observe finalContext fuel table computation) = _ + rw [resolveDeferredLayerValues] + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredSelectedChainFamily table lay (treeIndexAt index lay) + (leafIndexAt index lay) chainFamily encoding context >>= + fun chainsOption => + match chainsOption with + | none => pure true + | some (afterChains, _) => + runResolvedObserve observe afterChains fuel table computation) := by + apply evalDist_bind_congr + intro chainsOption hchains + cases chainsOption with + | none => rfl + | some chains => + rcases chains with ⟨afterChains, chainValues⟩ + have hchainsValid := hvalid.of_resolveDeferredSelectedChainFamily table lay + (treeIndexAt index lay) (leafIndexAt index lay) + chainFamily encoding afterChains chainValues hchains + have hchainsCompletable := + hcompletable.of_resolveDeferredSelectedChainFamily hvalid + chainFamily encoding afterChains chainValues hchains + have hprivate := privateStateAgrees_resolveDeferredSelectedChainFamily table lay + (treeIndexAt index lay) (leafIndexAt index lay) + chainFamily encoding context afterChains chainValues + hchains + have hpath := evalDist_resolveDeferredLayerPathFamily_then_runResolvedObserve + (observe := observe) + table lay (treeIndexAt index lay) (leafIndexAt index lay) + pathFamily afterChains fuel computation + hchainsValid hchainsCompletable (by + intro level hlevel + apply (treeNodeEnsured_congr_ensured lay (treeIndexAt index lay) level.val + (Nat.xor ((leafIndexAt index lay).val / 2 ^ level.val) 1) + context afterChains hprivate.2.2.symm).mp + exact hensured.2 level hlevel) + calc + _ = evalDist (do + let path ← resolveDeferredLayerPathFamily table lay (treeIndexAt index lay) + (leafIndexAt index lay) (fun level : Fin maxLayerHeight => level) afterChains + match path with + | none => pure true + | some (finalContext, _) => + runResolvedObserve observe finalContext fuel table computation) := by + apply congrArg evalDist + simp only [bind_assoc] + apply bind_congr + intro pathOption + cases pathOption <;> simp + _ = evalDist (runResolvedObserve observe afterChains fuel table computation) := by + apply Eq.trans _ hpath + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro resolved + cases resolved with + | none => rfl + | some resolved => + rcases resolved with ⟨finalContext, values⟩ + rfl + _ = _ := rfl + _ = evalDist (runResolvedObserve observe context fuel table computation) := by + let hbase := + evalDist_resolveDeferredSelectedChainFamily_then_runResolvedObserve + (observe := observe) table lay + (treeIndexAt index lay) (leafIndexAt index lay) chainFamily encoding context fuel + computation hvalid hcompletable hensured.1 + apply Eq.trans _ hbase + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro resolved + cases resolved with + | none => rfl + | some resolved => + rcases resolved with ⟨finalContext, values⟩ + rfl + +theorem evalDist_resolveSelectedLayerValuesList_then_runResolvedObserve + (table : OtsSecretIndex → HashOutput) (index : Index) + (selected : Layer → Option DeferredLayerEncoding) + (fuel : Nat) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + {observe : DeferredContext → Nat → α → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] : + ∀ (layers : List Layer) (context : DeferredContext), + context.Valid → DeferredCompletable table context → + (∀ lay, lay ∈ layers → ∀ counter encoding, + selected lay = some (counter, encoding) → + LayerValuesEnsured index lay encoding context) → + evalDist (do + let resolved ← resolveSelectedLayerValuesList table index selected layers context + match resolved with + | none => pure true + | some finalContext => + runResolvedObserve observe finalContext fuel table computation) = + evalDist (runResolvedObserve observe context fuel table computation) + | [], context, hvalid, hcompletable, hensured => by + simp [resolveSelectedLayerValuesList] + | lay :: layers, context, hvalid, hcompletable, hensured => by + rw [resolveSelectedLayerValuesList] + cases hselection : selected lay with + | none => + exact evalDist_resolveSelectedLayerValuesList_then_runResolvedObserve table index + selected fuel computation layers context hvalid hcompletable + (fun other hother counter encoding hselected => + hensured other (List.mem_cons_of_mem lay hother) counter encoding hselected) + | some selection => + rcases selection with ⟨counter, encoding⟩ + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredLayerValues table index lay encoding context >>= fun + resolved => + match resolved with + | none => pure true + | some (afterLayer, _) => + runResolvedObserve observe afterLayer fuel table computation) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + rcases resolved with ⟨afterLayer, values⟩ + have hafterValid := hvalid.of_resolveDeferredLayerValues table index lay + encoding afterLayer values hresolved + have hafterCompletable := hcompletable.of_resolveDeferredLayerValues hvalid + hresolved + have hagrees := privateStateAgrees_resolveDeferredLayerValues table index lay + encoding context afterLayer values hresolved + exact evalDist_resolveSelectedLayerValuesList_then_runResolvedObserve + table index selected fuel computation layers afterLayer hafterValid + hafterCompletable + (fun other hother otherCounter otherEncoding hselected => + (hensured other (List.mem_cons_of_mem lay hother) otherCounter + otherEncoding hselected).of_privateStateAgrees hagrees) + _ = _ := + evalDist_resolveDeferredLayerValues_then_runResolvedObserve table index lay + encoding context fuel computation hvalid hcompletable + (hensured lay (by simp) counter encoding hselection) + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredLayerSchedule_publish_observe_eq_selectedList + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) (index : Index) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + {observe : DeferredContext → Nat → + (Option Signature × SplitHashCache) → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] : + ∀ (layers : List Layer) (result : ResolvedRunResult DeferredLayerStore), + result.table = table → + (∀ lay, lay ∉ layers → + (result.value.resolved lay).isSome = + (result.value.selected lay).isSome) → + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + (layers.map DeferredLayerOperation.resolve) (some result) >>= + publishDeferredChronologicalSignature ftsSecret randomness index leaves ftsPath >>= + finishObserve observe) = + evalDist (do + let resolved ← resolveSelectedLayerValuesList table index + result.value.selected layers result.context + match resolved with + | none => pure true + | some finalContext => + runResolvedObserve observe finalContext result.remaining table + ((publishSelectedChronologicalSignature ftsSecret randomness index leaves + ftsPath result.value.selected).run result.value.cache)) + | [], result, htable, hagrees => by + have hpresence : ResolutionPresenceAgrees result.value := by + intro lay + exact hagrees lay (by simp) + simp only [List.map_nil, runDeferredLayerSchedule, pure_bind, + resolveSelectedLayerValuesList] + rw [publishDeferredChronologicalSignature_eq_selected ftsSecret randomness index leaves + ftsPath result hpresence] + simp only [publishSelectedDeferredSignature] + unfold runResolvedObserve + rw [htable] + | lay :: layers, result, htable, hagrees => by + simp only [List.map_cons, runDeferredLayerSchedule, runDeferredLayerOperation] + rw [resolveDeferredLayer] + cases hselection : result.value.selected lay with + | none => + simp only [pure_bind, resolveSelectedLayerValuesList, hselection] + have hrecursive := + evalDist_resolveDeferredLayerSchedule_publish_observe_eq_selectedList + (observe := observe) parameter + table index ftsSecret randomness leaves ftsPath layers + { context := result.context + remaining := result.remaining + value := + { result.value with + resolved := Function.update result.value.resolved lay none } + table := table } + rfl (by + intro observed hnotMem + by_cases heq : observed = lay + · subst observed + simp [Function.update, hselection] + · simpa [Function.update, heq] using + hagrees observed (by simp [heq, hnotMem])) + simpa only [bind_assoc] using hrecursive + | some selection => + rcases selection with ⟨counter, encoding⟩ + simp only [bind_assoc, resolveSelectedLayerValuesList, hselection] + apply evalDist_bind_congr + intro resolvedOption hresolved + cases resolvedOption with + | none => + simp [publishDeferredChronologicalSignature, finishObserve] + | some resolved => + rcases resolved with ⟨afterLayer, values⟩ + simpa only [pure_bind, bind_assoc] using + (evalDist_resolveDeferredLayerSchedule_publish_observe_eq_selectedList + (observe := observe) parameter + table index ftsSecret randomness leaves ftsPath layers + { context := afterLayer + remaining := result.remaining + value := + { result.value with + resolved := Function.update result.value.resolved lay + (some (counter, values.1, values.2)) } + table := table } + rfl (by + intro observed hnotMem + by_cases heq : observed = lay + · subst observed + simp [Function.update, hselection] + · simpa [Function.update, heq] using + hagrees observed (by simp [heq, hnotMem]))) + +set_option maxHeartbeats 10000000 in +set_option maxRecDepth 100000 in +theorem evalDist_runDeferredLayersAndPublish_observe_eq_selectionOnly + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + {observe : DeferredContext → Nat → + (Option Signature × SplitHashCache) → ProbComp Bool} + [ObserverDooms table observe] [ObserverSynchronized table observe] + [ObserverPositionNeutral table observe] + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (runDeferredLayersAndPublish parameter table ftsSecret randomness index leaves + ftsPath deferredLayerSchedule context fuel cache >>= finishObserve observe) = + evalDist (runSelectionOnlyLayersAndPublish parameter table ftsSecret randomness index + leaves ftsPath context fuel cache >>= finishObserve observe) := by + unfold runDeferredLayersAndPublish runSelectionOnlyLayersAndPublish + rw [deferredLayerSchedule_eq_append, runDeferredLayerSchedule_append] + simp only [bind_assoc] + apply evalDist_bind_congr + intro selectedOption hselected + cases selectedOption with + | none => + simp [publishDeferredChronologicalSignature, publishSelectedDeferredSignature, + finishObserve] + | some selected => + have hinvariants : + selected.table = table ∧ selected.context.Valid ∧ + DeferredCompletable table selected.context ∧ + ∀ lay counter encoding, + selected.value.selected lay = some (counter, encoding) → + LayerValuesEnsured index lay encoding selected.context := + selectedLayersEnsured_of_mem_deferredLayerSelections parameter table ftsSecret index + context fuel cache selected hvalid hcompletable hselected + have hschedule := + evalDist_resolveDeferredLayerSchedule_publish_observe_eq_selectedList + (observe := observe) parameter table + index ftsSecret randomness leaves ftsPath [topLayer, middleLayer, bottomLayer] + selected hinvariants.1 (by + intro lay hnotMem + fin_cases lay <;> + simp [topLayer, middleLayer, bottomLayer, numLayers] at hnotMem) + simp only [deferredLayerResolutions, publishSelectedDeferredSignature] + rw [← bind_assoc] + rw [hschedule] + rw [hinvariants.1] + exact evalDist_resolveSelectedLayerValuesList_then_runResolvedObserve + (observe := observe) table index + selected.value.selected selected.remaining + ((publishSelectedChronologicalSignature ftsSecret randomness index leaves ftsPath + selected.value.selected).run selected.value.cache) + [topLayer, middleLayer, bottomLayer] selected.context hinvariants.2.1 + hinvariants.2.2.1 (by + intro lay hlay counter encoding hselection + exact hinvariants.2.2.2 lay counter encoding hselection) + +theorem evalDist_runDeferredChronologicalLayersAndPublish_observe_eq_deferred + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (observe : DeferredContext → Nat → + (Option Signature × SplitHashCache) → ProbComp Bool) : + evalDist (runDeferredChronologicalLayersAndPublish parameter table ftsSecret randomness + index leaves ftsPath context fuel cache >>= finishObserve observe) = + evalDist (runDeferredLayersAndPublish parameter table ftsSecret randomness index leaves + ftsPath deferredLayerSchedule context fuel cache >>= finishObserve observe) := by + rw [evalDist_bind, evalDist_bind, + evalDist_runDeferredChronologicalLayersAndPublish_eq_deferred parameter table ftsSecret + randomness index leaves ftsPath context fuel cache] + +theorem publishedValues_resolveDeferredPositionValue_iff + (position : Position) (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support (resolveDeferredPositionValue position context)) : + PublishedValues result.state ↔ PublishedValues context.state := by + rw [resolveDeferredPositionValue_state_eq_clearPending position context result hresult] + rfl + +noncomputable def canonicalContinuationObserve + (table : OtsSecretIndex → HashOutput) + (next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β) + (context : DeferredContext) (fuel : Nat) (value : α × SplitHashCache) : ProbComp Bool := by + classical + exact if PublishedValues context.state then + runResolvedFinishIsNone (canonicalizeMaterializedValues table context) fuel table + ((next value.1).run value.2) + else + pure true + +instance canonicalContinuationObserve_observerDooms + (table : OtsSecretIndex → HashOutput) + (next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β) : + ObserverDooms table (canonicalContinuationObserve table next) where + eq_true context fuel value hconsistent hstarts hdoomed := by + unfold canonicalContinuationObserve + split + next _ => + have hcanonicalDoomed := + doomedResolvedContext_canonicalizeMaterializedValues + (table := table) (context := context) ⟨hconsistent, hstarts, hdoomed⟩ + simpa [runResolvedFinishIsNone] using + evalDist_runResolvedFinishIsNone_eq_true_of_not_completable + (canonicalizeMaterializedValues table context) fuel table + ((next value.1).run value.2) hcanonicalDoomed.1 hcanonicalDoomed.2.1 + hcanonicalDoomed.2.2 + next _ => rfl + +instance canonicalContinuationObserve_observerSynchronized + (table : OtsSecretIndex → HashOutput) + (next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β) : + ObserverSynchronized table (canonicalContinuationObserve table next) where + eq_of_synchronized left right fuel value hcontext hvalues hrevealed := by + have hpublishedIff : PublishedValues left.state ↔ PublishedValues right.state := by + simp only [PublishedValues] + constructor + · intro hpublished coordinate hrightRevealed + have hleftRevealed : coordinate ∈ left.state.revealed := by + rwa [hrevealed] + rw [← hvalues] + exact hpublished coordinate hleftRevealed + · intro hpublished coordinate hleftRevealed + have hrightRevealed : coordinate ∈ right.state.revealed := by + rwa [← hrevealed] + rw [hvalues] + exact hpublished coordinate hrightRevealed + unfold canonicalContinuationObserve + split + next hleftPublished => + have hrightPublished := hpublishedIff.mp hleftPublished + simp only [hrightPublished, ↓reduceIte] + have hcanonical := canonicalizedFinalizationContextEq hcontext hrevealed + apply evalDist_runResolvedFinishIsNone_eq_of_finalizationSynchronized + · exact hcanonical.1 + · exact hcanonical.2 + · exact hrevealed + next hleftNotPublished => + have hrightNotPublished : ¬PublishedValues right.state := by + rwa [← hpublishedIff] + simp [hrightNotPublished] + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_canonicalContinuationObserve + (position : Position) + (table : OtsSecretIndex → HashOutput) + (next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β) + (context : DeferredContext) (fuel : Nat) (value : α × SplitHashCache) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : Coordinate.position position ∈ context.state.ensured) : + evalDist (resolveDeferredPositionValue position context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + canonicalContinuationObserve table next resolved.toDeferredContext fuel value) = + evalDist (canonicalContinuationObserve table next context fuel value) := by + by_cases hpublished : PublishedValues context.state + · let finish : Option DeferredResolution → ProbComp Bool + | none => pure true + | some resolved => + runResolvedFinishIsNone resolved.toDeferredContext fuel table + ((next value.1).run value.2) + have hclean : ∀ coordinate output, + resolvedCompletionValue table context coordinate = some output → + ¬context.state.hitAt coordinate output := by + obtain ⟨completion, hcompletion⟩ := hcompletable + intro coordinate output hvalue hhit + have houtput := hcompletion.eq_resolvedCompletionValue coordinate output hvalue + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + exact hcompletion.2.2.1 coordinate (truncateHash output) hhit (by rw [houtput]) + have hcanonicalValid : + (canonicalizeMaterializedValues table context).Valid := + canonicalizeMaterializedValues_valid table context hvalid hclean + have hcanonicalCompletable : + DeferredCompletable table (canonicalizeMaterializedValues table context) := by + obtain ⟨completion, hcompletion⟩ := hcompletable + exact ⟨completion, hcompletion.to_canonicalizedMaterializedValues⟩ + have hcanonicalEnsured : Coordinate.position position ∈ + (canonicalizeMaterializedValues table context).state.ensured := by + exact hensured + calc + _ = evalDist (((Option.map (canonicalizeDeferredResolution table)) <$> + resolveDeferredPositionValue position context) >>= finish) := by + simp only [map_eq_bind_pure_comp, bind_assoc] + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hresolvedPublished : PublishedValues resolved.state := + (publishedValues_resolveDeferredPositionValue_iff position context resolved + hresolved).2 hpublished + simp [canonicalContinuationObserve, hresolvedPublished, finish, + canonicalizeDeferredResolution] + _ = evalDist (resolveDeferredPositionValue position + (canonicalizeMaterializedValues table context) >>= finish) := + evalDist_bind_eq_of_evalDist_eq + (evalDist_resolveDeferredPositionValue_canonicalize table position context + hvalid.valuesConsistent hpublished) + finish + _ = evalDist (runResolvedFinishIsNone + (canonicalizeMaterializedValues table context) fuel table + ((next value.1).run value.2)) := by + exact evalDist_resolveDeferredPositionValue_then_runResolvedFinishIsNone position + ((next value.1).run value.2) (canonicalizeMaterializedValues table context) + fuel table hcanonicalValid hcanonicalCompletable hcanonicalEnsured + _ = _ := by + simp [canonicalContinuationObserve, hpublished] + · calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun _ => + pure true) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hresolvedNotPublished : ¬PublishedValues resolved.state := by + intro hresolvedPublished + exact hpublished + ((publishedValues_resolveDeferredPositionValue_iff position context resolved + hresolved).1 hresolvedPublished) + simp [canonicalContinuationObserve, hresolvedNotPublished] + _ = evalDist (pure true : ProbComp Bool) := + OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolveDeferredPositionValue position context) + (by simp [resolveDeferredPositionValue, LazyRevealProbe.sampleHashOutput]) + (pure true) + _ = _ := by + simp [canonicalContinuationObserve, hpublished] + +instance canonicalContinuationObserve_observerPositionNeutral + (table : OtsSecretIndex → HashOutput) + (next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β) : + ObserverPositionNeutral table (canonicalContinuationObserve table next) where + eq_resolve position context fuel value hvalid hcompletable hensured := + evalDist_resolveDeferredPositionValue_then_canonicalContinuationObserve position table + next context fuel value hvalid hcompletable hensured + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_runCanonicalContinuationObserve + (position : Position) + (computation : OracleComp (LazyRevealProbe.World Coordinate) (α × SplitHashCache)) + (table : OtsSecretIndex → HashOutput) + (next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β) + (context : DeferredContext) (fuel : Nat) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : Coordinate.position position ∈ context.state.ensured) : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure true + | some resolved => + runResolvedObserve (canonicalContinuationObserve table next) + resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedObserve (canonicalContinuationObserve table next) + context fuel table computation) := by + apply evalDist_resolveDeferredPositionValue_then_runResolvedObserve position computation + (observe := canonicalContinuationObserve table next) context fuel table hvalid hcompletable + hensured + intro nextContext remaining value hnextValid hnextCompletable hnextEnsured + exact evalDist_resolveDeferredPositionValue_then_canonicalContinuationObserve position table + next nextContext remaining value hnextValid hnextCompletable hnextEnsured + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateRecursive.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateRecursive.lean new file mode 100644 index 00000000..7a6d1159 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateRecursive.lean @@ -0,0 +1,638 @@ +import SphincsSecurity.Proof.OtsProbeResolvedPrivateCommutation + +/-! +# Private structural samples through recursive resolution + +Private position resolution commutes through the recursive structural resolvers while retaining +the resolver's observable output and exact failure behavior. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +noncomputable def resolvePositionThenChainPrefix + (target : Position) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (steps : Nat) (hsteps : steps ≤ chainLength - 1) (context : DeferredContext) : + ProbComp (Option RevealedResolution) := do + let targetResolved ← resolveDeferredPositionValue target context + match targetResolved with + | none => pure none + | some targetResolved => do + let prefixResolved ← resolveDeferredChainPrefix table lay tree leafIdx chainIdx + steps hsteps targetResolved.toDeferredContext + match prefixResolved with + | none => pure none + | some prefixResolved => + pure (some ⟨prefixResolved.toDeferredContext, prefixResolved.output⟩) + +noncomputable def resolveChainPrefixThenPosition + (target : Position) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (steps : Nat) (hsteps : steps ≤ chainLength - 1) (context : DeferredContext) : + ProbComp (Option RevealedResolution) := do + let prefixResolved ← resolveDeferredChainPrefix table lay tree leafIdx chainIdx + steps hsteps context + match prefixResolved with + | none => pure none + | some prefixResolved => do + let targetResolved ← + resolveDeferredPositionValue target prefixResolved.toDeferredContext + match targetResolved with + | none => pure none + | some targetResolved => + pure (some ⟨targetResolved.toDeferredContext, prefixResolved.output⟩) + +theorem evalDist_bind_eq_of_evalDist_eq + {oa ob : ProbComp α} (h : evalDist oa = evalDist ob) (next : α → ProbComp β) : + evalDist (oa >>= next) = evalDist (ob >>= next) := by + rw [evalDist_bind, evalDist_bind, h] + +noncomputable def resolveAfterRevealedPosition (position : Position) : + Option RevealedResolution → ProbComp (Option RevealedResolution) + | none => pure none + | some previous => do + let resolved ← resolveDeferredPositionValue position previous.context + match resolved with + | none => pure none + | some resolved => pure (some ⟨resolved.toDeferredContext, resolved.output⟩) + +set_option maxRecDepth 100000 in +theorem evalDist_resolvePosition_chainPrefix_comm + (target : Position) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps context, + context.Valid → DeferredCompletable table context → + evalDist (resolvePositionThenChainPrefix target table lay tree leafIdx chainIdx + steps hsteps context) = + evalDist (resolveChainPrefixThenPosition target table lay tree leafIdx chainIdx + steps hsteps context) + | 0, hsteps, context, _hvalid, hcompletable => by + change evalDist (resolvePositionThenChainStart target table + ⟨lay, tree, leafIdx, chainIdx⟩ context) = + evalDist (resolveChainStartThenPosition target table + ⟨lay, tree, leafIdx, chainIdx⟩ context) + exact evalDist_resolvePosition_chainStart_comm target table + ⟨lay, tree, leafIdx, chainIdx⟩ context hcompletable + | steps + 1, hsteps, context, hvalid, hcompletable => by + let current : Position := + .chain lay tree leafIdx chainIdx ⟨steps, by omega⟩ + calc + _ = evalDist (resolvePositionThenChainPrefix target table lay tree leafIdx chainIdx + steps (by omega) context >>= resolveAfterRevealedPosition current) := by + unfold resolvePositionThenChainPrefix + simp only [bind_assoc] + apply evalDist_bind_congr + intro targetResolved _htargetResolved + cases targetResolved with + | none => simp [resolveAfterRevealedPosition] + | some targetResolved => + simp only [resolveDeferredChainPrefix, bind_assoc] + apply evalDist_bind_congr + intro previous _hprevious + cases previous <;> rfl + _ = evalDist (resolveChainPrefixThenPosition target table lay tree leafIdx chainIdx + steps (by omega) context >>= resolveAfterRevealedPosition current) := + evalDist_bind_eq_of_evalDist_eq + (evalDist_resolvePosition_chainPrefix_comm target table lay tree leafIdx chainIdx + steps (by omega) context hvalid hcompletable) + (resolveAfterRevealedPosition current) + _ = evalDist (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps + (by omega) context >>= fun previous => + match previous with + | none => pure none + | some previous => + resolvePositionValuesInOrder target current previous.toDeferredContext) := by + unfold resolveChainPrefixThenPosition + simp only [bind_assoc] + apply evalDist_bind_congr + intro previous _hprevious + cases previous with + | none => rfl + | some previous => + unfold resolveAfterRevealedPosition resolvePositionValuesInOrder + simp only [bind_assoc] + apply evalDist_bind_congr + intro targetResolved _htargetResolved + cases targetResolved <;> rfl + _ = evalDist (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps + (by omega) context >>= fun previous => + match previous with + | none => pure none + | some previous => + resolvePositionValuesSwapped target current previous.toDeferredContext) := by + apply evalDist_bind_congr + intro previous _hprevious + cases previous with + | none => rfl + | some previous => + by_cases heq : target = current + · simpa [heq] using + (evalDist_resolvePositionValues_comm_self current + previous.toDeferredContext) + · exact evalDist_resolvePositionValues_comm_of_ne target current + previous.toDeferredContext heq + _ = _ := by + unfold resolveChainPrefixThenPosition + simp only [resolveDeferredChainPrefix, bind_assoc] + apply evalDist_bind_congr + intro previous _hprevious + cases previous with + | none => rfl + | some previous => + unfold resolvePositionValuesSwapped + apply evalDist_bind_congr + intro currentResolved _hcurrentResolved + cases currentResolved <;> rfl + +noncomputable def resolvePositionThenChains + (target : Position) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chains : List ChainIndex) (context : DeferredContext) : + ProbComp (Option DeferredContext) := do + let targetResolved ← resolveDeferredPositionValue target context + match targetResolved with + | none => pure none + | some targetResolved => + resolveDeferredChains table lay tree leafIdx chains targetResolved.toDeferredContext + +noncomputable def resolveChainsThenPosition + (target : Position) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chains : List ChainIndex) (context : DeferredContext) : + ProbComp (Option DeferredContext) := do + let chainsResolved ← resolveDeferredChains table lay tree leafIdx chains context + match chainsResolved with + | none => pure none + | some chainsResolved => do + let targetResolved ← resolveDeferredPositionValue target chainsResolved + pure (targetResolved.map DeferredResolution.toDeferredContext) + +noncomputable def continueChainsAfterRevealed + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chains : List ChainIndex) : + Option RevealedResolution → ProbComp (Option DeferredContext) + | none => pure none + | some resolved => + resolveDeferredChains table lay tree leafIdx chains resolved.context + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_resolvePosition_chains_comm + (target : Position) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ∀ chains context, + context.Valid → DeferredCompletable table context → + evalDist (resolvePositionThenChains target table lay tree leafIdx chains context) = + evalDist (resolveChainsThenPosition target table lay tree leafIdx chains context) + | [], context, _hvalid, _hcompletable => by + unfold resolvePositionThenChains resolveChainsThenPosition + simp only [resolveDeferredChains, pure_bind] + apply evalDist_bind_congr + intro targetResolved _htargetResolved + cases targetResolved <;> rfl + | chainIdx :: remaining, context, hvalid, hcompletable => by + calc + _ = evalDist (resolvePositionThenChainPrefix target table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context >>= + continueChainsAfterRevealed table lay tree leafIdx remaining) := by + unfold resolvePositionThenChains resolvePositionThenChainPrefix + continueChainsAfterRevealed + simp only [resolveDeferredChains, bind_assoc] + apply evalDist_bind_congr + intro targetResolved _htargetResolved + cases targetResolved with + | none => rfl + | some targetResolved => + simp only + rw [bind_assoc] + apply evalDist_bind_congr + intro prefixResolved _hprefixResolved + cases prefixResolved <;> rfl + _ = evalDist (resolveChainPrefixThenPosition target table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context >>= + continueChainsAfterRevealed table lay tree leafIdx remaining) := + evalDist_bind_eq_of_evalDist_eq + (evalDist_resolvePosition_chainPrefix_comm target table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context hvalid hcompletable) + (continueChainsAfterRevealed table lay tree leafIdx remaining) + _ = evalDist (resolveDeferredChainPrefix table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context >>= fun prefixResolved => + match prefixResolved with + | none => pure none + | some prefixResolved => + resolvePositionThenChains target table lay tree leafIdx remaining + prefixResolved.toDeferredContext) := by + unfold resolveChainPrefixThenPosition continueChainsAfterRevealed + simp only [bind_assoc] + apply evalDist_bind_congr + intro prefixResolved _hprefixResolved + cases prefixResolved with + | none => rfl + | some prefixResolved => + simp only + unfold resolvePositionThenChains + simp only [bind_assoc] + apply evalDist_bind_congr + intro targetResolved _htargetResolved + cases targetResolved <;> rfl + _ = evalDist (resolveDeferredChainPrefix table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context >>= fun prefixResolved => + match prefixResolved with + | none => pure none + | some prefixResolved => + resolveChainsThenPosition target table lay tree leafIdx remaining + prefixResolved.toDeferredContext) := by + apply evalDist_bind_congr + intro prefixResolved hprefixResolved + cases prefixResolved with + | none => rfl + | some prefixResolved => + exact evalDist_resolvePosition_chains_comm target table lay tree leafIdx remaining + prefixResolved.toDeferredContext + (hvalid.of_resolveDeferredChainPrefix table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) prefixResolved hprefixResolved) + (hcompletable.of_resolveDeferredChainPrefix hvalid hprefixResolved) + _ = _ := by + unfold resolveChainsThenPosition + simp only [resolveDeferredChains, bind_assoc] + apply evalDist_bind_congr + intro prefixResolved _hprefixResolved + cases prefixResolved <;> rfl + +noncomputable def resolveRevealedPositionAfterContext (position : Position) : + Option DeferredContext → ProbComp (Option RevealedResolution) + | none => pure none + | some context => do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure none + | some resolved => pure (some ⟨resolved.toDeferredContext, resolved.output⟩) + +noncomputable def resolvePositionThenOtsLeaf + (target : Position) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (context : DeferredContext) : ProbComp (Option RevealedResolution) := do + let targetResolved ← resolveDeferredPositionValue target context + match targetResolved with + | none => pure none + | some targetResolved => do + let leafResolved ← + resolveDeferredOtsLeaf table lay tree leafIdx targetResolved.toDeferredContext + match leafResolved with + | none => pure none + | some leafResolved => + pure (some ⟨leafResolved.toDeferredContext, leafResolved.output⟩) + +noncomputable def resolveOtsLeafThenPosition + (target : Position) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (context : DeferredContext) : ProbComp (Option RevealedResolution) := do + let leafResolved ← resolveDeferredOtsLeaf table lay tree leafIdx context + match leafResolved with + | none => pure none + | some leafResolved => do + let targetResolved ← + resolveDeferredPositionValue target leafResolved.toDeferredContext + match targetResolved with + | none => pure none + | some targetResolved => + pure (some ⟨targetResolved.toDeferredContext, leafResolved.output⟩) + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem evalDist_resolvePosition_otsLeaf_comm + (target : Position) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (context : DeferredContext) (hvalid : context.Valid) + (hcompletable : DeferredCompletable table context) : + evalDist (resolvePositionThenOtsLeaf target table lay tree leafIdx context) = + evalDist (resolveOtsLeafThenPosition target table lay tree leafIdx context) := by + let chains := List.ofFn fun chainIdx : ChainIndex => chainIdx + let leaf : Position := .leaf lay tree leafIdx + calc + _ = evalDist (resolvePositionThenChains target table lay tree leafIdx chains context >>= + resolveRevealedPositionAfterContext leaf) := by + unfold resolvePositionThenOtsLeaf resolvePositionThenChains + resolveRevealedPositionAfterContext + simp only [resolveDeferredOtsLeaf, bind_assoc] + apply evalDist_bind_congr + intro targetResolved _htargetResolved + cases targetResolved with + | none => rfl + | some targetResolved => + simp only + dsimp only [chains, leaf] + apply evalDist_bind_congr + intro chainsResolved _hchainsResolved + cases chainsResolved <;> rfl + _ = evalDist (resolveChainsThenPosition target table lay tree leafIdx chains context >>= + resolveRevealedPositionAfterContext leaf) := + evalDist_bind_eq_of_evalDist_eq + (evalDist_resolvePosition_chains_comm target table lay tree leafIdx chains context + hvalid hcompletable) + (resolveRevealedPositionAfterContext leaf) + _ = evalDist (resolveDeferredChains table lay tree leafIdx chains context >>= + fun chainsResolved => + match chainsResolved with + | none => pure none + | some chainsResolved => + resolvePositionValuesInOrder target leaf chainsResolved) := by + unfold resolveChainsThenPosition resolveRevealedPositionAfterContext + simp only [bind_assoc] + apply evalDist_bind_congr + intro chainsResolved _hchainsResolved + cases chainsResolved with + | none => rfl + | some chainsResolved => + simp only + rw [bind_assoc] + apply evalDist_bind_congr + intro targetResolved _htargetResolved + cases targetResolved <;> rfl + _ = evalDist (resolveDeferredChains table lay tree leafIdx chains context >>= + fun chainsResolved => + match chainsResolved with + | none => pure none + | some chainsResolved => + resolvePositionValuesSwapped target leaf chainsResolved) := by + apply evalDist_bind_congr + intro chainsResolved _hchainsResolved + cases chainsResolved with + | none => rfl + | some chainsResolved => + by_cases heq : target = leaf + · simpa [heq] using + (evalDist_resolvePositionValues_comm_self leaf chainsResolved) + · exact evalDist_resolvePositionValues_comm_of_ne target leaf chainsResolved heq + _ = _ := by + unfold resolveOtsLeafThenPosition resolvePositionValuesSwapped + simp only [resolveDeferredOtsLeaf, bind_assoc] + apply evalDist_bind_congr + intro chainsResolved _hchainsResolved + cases chainsResolved with + | none => rfl + | some chainsResolved => + apply evalDist_bind_congr + intro leafResolved _hleafResolved + cases leafResolved <;> rfl + +abbrev PrivateResolver := DeferredContext → ProbComp (Option DeferredResolution) + +noncomputable def composePrivateResolvers + (first second : PrivateResolver) : PrivateResolver := fun context => do + let firstResolved ← first context + match firstResolved with + | none => pure none + | some firstResolved => second firstResolved.toDeferredContext + +noncomputable def resolvePositionThenResolver + (target : Position) (resolver : PrivateResolver) (context : DeferredContext) : + ProbComp (Option RevealedResolution) := do + let targetResolved ← resolveDeferredPositionValue target context + match targetResolved with + | none => pure none + | some targetResolved => do + let resolved ← resolver targetResolved.toDeferredContext + match resolved with + | none => pure none + | some resolved => pure (some ⟨resolved.toDeferredContext, resolved.output⟩) + +noncomputable def resolveResolverThenPosition + (target : Position) (resolver : PrivateResolver) (context : DeferredContext) : + ProbComp (Option RevealedResolution) := do + let resolved ← resolver context + match resolved with + | none => pure none + | some resolved => do + let targetResolved ← resolveDeferredPositionValue target resolved.toDeferredContext + match targetResolved with + | none => pure none + | some targetResolved => + pure (some ⟨targetResolved.toDeferredContext, resolved.output⟩) + +def PositionResolutionCommutes + (target : Position) (resolver : PrivateResolver) (context : DeferredContext) : Prop := + evalDist (resolvePositionThenResolver target resolver context) = + evalDist (resolveResolverThenPosition target resolver context) + +noncomputable def continueResolverAfterRevealed (resolver : PrivateResolver) : + Option RevealedResolution → ProbComp (Option RevealedResolution) + | none => pure none + | some previous => do + let resolved ← resolver previous.context + match resolved with + | none => pure none + | some resolved => pure (some ⟨resolved.toDeferredContext, resolved.output⟩) + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem positionResolutionCommutes_compose + (target : Position) (first second : PrivateResolver) (context : DeferredContext) + (hfirst : PositionResolutionCommutes target first context) + (hsecond : ∀ firstResolved, + some firstResolved ∈ support (first context) → + PositionResolutionCommutes target second firstResolved.toDeferredContext) : + PositionResolutionCommutes target (composePrivateResolvers first second) context := by + unfold PositionResolutionCommutes + calc + _ = evalDist (resolvePositionThenResolver target first context >>= + continueResolverAfterRevealed second) := by + unfold resolvePositionThenResolver composePrivateResolvers + continueResolverAfterRevealed + simp only [bind_assoc] + apply evalDist_bind_congr + intro targetResolved _htargetResolved + cases targetResolved with + | none => rfl + | some targetResolved => + simp only + rw [bind_assoc] + apply evalDist_bind_congr + intro firstResolved _hfirstResolved + cases firstResolved <;> rfl + _ = evalDist (resolveResolverThenPosition target first context >>= + continueResolverAfterRevealed second) := + evalDist_bind_eq_of_evalDist_eq hfirst (continueResolverAfterRevealed second) + _ = evalDist (first context >>= fun firstResolved => + match firstResolved with + | none => pure none + | some firstResolved => + resolvePositionThenResolver target second firstResolved.toDeferredContext) := by + unfold resolveResolverThenPosition continueResolverAfterRevealed + simp only [bind_assoc] + apply evalDist_bind_congr + intro firstResolved _hfirstResolved + cases firstResolved with + | none => rfl + | some firstResolved => + simp only + rw [bind_assoc] + apply evalDist_bind_congr + intro targetResolved _htargetResolved + cases targetResolved <;> rfl + _ = evalDist (first context >>= fun firstResolved => + match firstResolved with + | none => pure none + | some firstResolved => + resolveResolverThenPosition target second firstResolved.toDeferredContext) := by + apply evalDist_bind_congr + intro firstResolved hfirstResolved + cases firstResolved with + | none => rfl + | some firstResolved => exact hsecond firstResolved hfirstResolved + _ = _ := by + unfold resolveResolverThenPosition composePrivateResolvers + simp only [bind_assoc] + apply evalDist_bind_congr + intro firstResolved _hfirstResolved + cases firstResolved with + | none => rfl + | some firstResolved => + apply evalDist_bind_congr + intro secondResolved _hsecondResolved + cases secondResolved <;> rfl + +theorem positionResolutionCommutes_value + (target position : Position) (context : DeferredContext) : + PositionResolutionCommutes target + (fun context => resolveDeferredPositionValue position context) context := by + change evalDist (resolvePositionValuesInOrder target position context) = + evalDist (resolvePositionValuesSwapped target position context) + by_cases heq : target = position + · simpa [heq] using evalDist_resolvePositionValues_comm_self position context + · exact evalDist_resolvePositionValues_comm_of_ne target position context heq + +theorem positionResolutionCommutes_chainPrefix + (target : Position) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (steps : Nat) (hsteps : steps ≤ chainLength - 1) (context : DeferredContext) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + PositionResolutionCommutes target + (fun context => resolveDeferredChainPrefix table lay tree leafIdx chainIdx + steps hsteps context) context := by + change evalDist (resolvePositionThenChainPrefix target table lay tree leafIdx chainIdx + steps hsteps context) = + evalDist (resolveChainPrefixThenPosition target table lay tree leafIdx chainIdx + steps hsteps context) + exact evalDist_resolvePosition_chainPrefix_comm target table lay tree leafIdx chainIdx + steps hsteps context hvalid hcompletable + +theorem positionResolutionCommutes_otsLeaf + (target : Position) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (context : DeferredContext) (hvalid : context.Valid) + (hcompletable : DeferredCompletable table context) : + PositionResolutionCommutes target + (fun context => resolveDeferredOtsLeaf table lay tree leafIdx context) context := by + change evalDist (resolvePositionThenOtsLeaf target table lay tree leafIdx context) = + evalDist (resolveOtsLeafThenPosition target table lay tree leafIdx context) + exact evalDist_resolvePosition_otsLeaf_comm target table lay tree leafIdx context hvalid + hcompletable + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem positionResolutionCommutes_treeNode + (target : Position) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel context, + context.Valid → DeferredCompletable table context → + PositionResolutionCommutes target + (fun context => resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) + context + | 0, nodeIdx, hlevel, context, hvalid, hcompletable => by + simpa only [resolveDeferredTreeNode] using + positionResolutionCommutes_otsLeaf target table lay tree (leafOfNat nodeIdx) + context hvalid hcompletable + | level + 1, nodeIdx, hlevel, context, hvalid, hcompletable => by + let left : PrivateResolver := fun context => + resolveDeferredTreeNode table lay tree level (2 * nodeIdx) (by omega) context + let right : PrivateResolver := fun context => + resolveDeferredTreeNode table lay tree level (2 * nodeIdx + 1) (by omega) context + let node : PrivateResolver := fun context => + resolveDeferredPositionValue + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) context + have hleft : PositionResolutionCommutes target left context := + positionResolutionCommutes_treeNode target table lay tree level (2 * nodeIdx) + (by omega) context hvalid hcompletable + have hrest : ∀ leftResolved, + some leftResolved ∈ support (left context) → + PositionResolutionCommutes target (composePrivateResolvers right node) + leftResolved.toDeferredContext := by + intro leftResolved hleftResolved + have hleftValid : leftResolved.toDeferredContext.Valid := + hvalid.of_resolveDeferredTreeNode table lay tree level (2 * nodeIdx) + (by omega) leftResolved hleftResolved + have hleftCompletable : DeferredCompletable table leftResolved.toDeferredContext := + hcompletable.of_resolveDeferredTreeNode hvalid hleftResolved + have hright : PositionResolutionCommutes target right + leftResolved.toDeferredContext := + positionResolutionCommutes_treeNode target table lay tree level + (2 * nodeIdx + 1) (by omega) leftResolved.toDeferredContext hleftValid + hleftCompletable + apply positionResolutionCommutes_compose target right node + leftResolved.toDeferredContext hright + intro rightResolved _hrightResolved + exact positionResolutionCommutes_value target + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) + rightResolved.toDeferredContext + have hresolver : + (fun nextContext => + resolveDeferredTreeNode table lay tree (level + 1) nodeIdx hlevel nextContext) = + composePrivateResolvers left (composePrivateResolvers right node) := by + funext nextContext + unfold left right node composePrivateResolvers + rw [resolveDeferredTreeNode] + apply bind_congr + intro leftResolved + cases leftResolved with + | none => rfl + | some leftResolved => + apply bind_congr + intro rightResolved + cases rightResolved <;> rfl + have hcomposed := positionResolutionCommutes_compose target left + (composePrivateResolvers right node) context hleft hrest + rw [hresolver] + exact hcomposed + +theorem positionResolutionCommutes_position + (target : Position) (table : OtsSecretIndex → HashOutput) + (position : Position) (context : DeferredContext) (hvalid : context.Valid) + (hcompletable : DeferredCompletable table context) : + PositionResolutionCommutes target + (fun context => resolveDeferredPosition table position context) context := by + cases position with + | chain lay tree leafIdx chainIdx step => + exact positionResolutionCommutes_chainPrefix target table lay tree leafIdx chainIdx + (step.val + 1) (by have := step.isLt; omega) context hvalid hcompletable + | leaf lay tree leafIdx => + exact positionResolutionCommutes_otsLeaf target table lay tree leafIdx context hvalid + hcompletable + | node lay tree level nodeIdx => + exact positionResolutionCommutes_treeNode target table lay tree (level.val + 1) nodeIdx + (by have := level.isLt; omega) context hvalid hcompletable + | ftsLeaf index tree leafIdx => + exact positionResolutionCommutes_value target (.ftsLeaf index tree leafIdx) context + | ftsNode index tree level nodeIdx => + exact positionResolutionCommutes_value target (.ftsNode index tree level nodeIdx) context + | ftsRoots index => + exact positionResolutionCommutes_value target (.ftsRoots index) context + +theorem positionResolutionCommutes_reveal + (target : Position) (table : OtsSecretIndex → HashOutput) + (position : Position) (context : DeferredContext) (hvalid : context.Valid) + (hcompletable : DeferredCompletable table context) : + PositionResolutionCommutes target + (fun context => resolveDeferredReveal table position context) context := by + classical + unfold resolveDeferredReveal + by_cases hresolvable : ResolvableOtsPosition position + · simp only [hresolvable, if_pos] + exact positionResolutionCommutes_position target table position context hvalid hcompletable + · simp only [hresolvable] + exact positionResolutionCommutes_value target position context + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateRetainedCommutation.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateRetainedCommutation.lean new file mode 100644 index 00000000..83147700 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateRetainedCommutation.lean @@ -0,0 +1,184 @@ +import SphincsSecurity.Proof.OtsProbeResolvedPrivateRecursive +import SphincsSecurity.Proof.MarginalCoupling + +/-! +# Retained private-position commutation + +The ordinary commutation lemmas expose only the common state after both resolvers have run. This +module retains the state immediately before the delayed target resolution as well. That retained +state is the left side needed by the event-specific lazy/eager coupling. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +noncomputable def resolveResolverThenPositionRetained + (target : Position) (resolver : PrivateResolver) (context : DeferredContext) : + ProbComp (Option (DeferredResolution × Option RevealedResolution)) := do + let resolved ← resolver context + match resolved with + | none => pure none + | some resolved => do + let targetResolved ← resolveDeferredPositionValue target resolved.toDeferredContext + pure (some (resolved, targetResolved.map fun targetResolved => + ⟨targetResolved.toDeferredContext, resolved.output⟩)) + +def retainedPositionResolutionBefore : + Option (DeferredResolution × Option RevealedResolution) → Option DeferredResolution := + Option.map Prod.fst + +def retainedPositionResolutionAfter : + Option (DeferredResolution × Option RevealedResolution) → Option RevealedResolution + | none => none + | some pair => pair.2 + +def RetainedPositionResolutionRel + (target : Position) : Option DeferredResolution → Option RevealedResolution → Prop + | none, after => after = none + | some before, after => + ∃ targetResolved, + targetResolved ∈ support + (resolveDeferredPositionValue target before.toDeferredContext) ∧ + after = targetResolved.map fun targetResolved => + ⟨targetResolved.toDeferredContext, before.output⟩ + +theorem evalDist_map_before_resolveResolverThenPositionRetained + (target : Position) (resolver : PrivateResolver) (context : DeferredContext) : + evalDist (retainedPositionResolutionBefore <$> + resolveResolverThenPositionRetained target resolver context) = + evalDist (resolver context) := by + unfold resolveResolverThenPositionRetained retainedPositionResolutionBefore + simp only [map_eq_bind_pure_comp, bind_assoc] + calc + _ = evalDist (resolver context >>= fun resolved => pure resolved) := by + apply evalDist_bind_congr + intro resolved _hresolved + cases resolved with + | none => rfl + | some resolved => + calc + _ = evalDist (resolveDeferredPositionValue target resolved.toDeferredContext >>= + fun _ => pure (some resolved)) := by + simp only + rw [bind_assoc] + apply evalDist_bind_congr + intro targetResolved _htargetResolved + cases targetResolved <;> rfl + _ = evalDist (pure (some resolved) : ProbComp (Option DeferredResolution)) := + OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolveDeferredPositionValue target resolved.toDeferredContext) + (by simp [resolveDeferredPositionValue, LazyRevealProbe.sampleHashOutput]) + (pure (some resolved)) + _ = _ := by rw [bind_pure] + +theorem map_snd_resolveResolverThenPositionRetained + (target : Position) (resolver : PrivateResolver) (context : DeferredContext) : + retainedPositionResolutionAfter <$> + resolveResolverThenPositionRetained target resolver context = + resolveResolverThenPosition target resolver context := by + unfold resolveResolverThenPositionRetained resolveResolverThenPosition + retainedPositionResolutionAfter + simp only [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro resolved + cases resolved with + | none => rfl + | some resolved => + simp only + rw [bind_assoc] + apply bind_congr + intro targetResolved + cases targetResolved <;> rfl + +theorem retainedPositionResolutionRel_of_mem + (target : Position) (resolver : PrivateResolver) (context : DeferredContext) + (pair : Option (DeferredResolution × Option RevealedResolution)) + (hpair : pair ∈ support + (resolveResolverThenPositionRetained target resolver context)) : + RetainedPositionResolutionRel target (retainedPositionResolutionBefore pair) + (retainedPositionResolutionAfter pair) := by + unfold resolveResolverThenPositionRetained at hpair + rw [mem_support_bind_iff] at hpair + obtain ⟨resolved, hresolved, hpair⟩ := hpair + cases resolved with + | none => + simp only [support_pure, Set.mem_singleton_iff] at hpair + subst pair + rfl + | some resolved => + rw [mem_support_bind_iff] at hpair + obtain ⟨targetResolved, htargetResolved, hpair⟩ := hpair + simp only [support_pure, Set.mem_singleton_iff] at hpair + subst pair + exact ⟨targetResolved, htargetResolved, rfl⟩ + +theorem relTriple_retainedPositionResolution + (target : Position) (resolver : PrivateResolver) (context : DeferredContext) : + RelTriple + (retainedPositionResolutionBefore <$> + resolveResolverThenPositionRetained target resolver context) + (retainedPositionResolutionAfter <$> + resolveResolverThenPositionRetained target resolver context) + (RetainedPositionResolutionRel target) := by + let shared := resolveResolverThenPositionRetained target resolver context + have hbase := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + (relTriple_refl shared) (fun pair => pair ∈ support shared) (fun _ hpair => hpair) + have hsemantic : RelTriple shared shared + (fun left right => RetainedPositionResolutionRel target + (retainedPositionResolutionBefore left) (retainedPositionResolutionAfter right)) := by + apply relTriple_post_mono hbase + intro left right hrelation + obtain ⟨heq, hleft⟩ := hrelation + subst right + exact retainedPositionResolutionRel_of_mem target resolver context left hleft + exact relTriple_map hsemantic + +theorem relTriple_resolverThenPosition_resolvePositionThenResolver_retained + (target : Position) (resolver : PrivateResolver) (context : DeferredContext) + (hcommutes : PositionResolutionCommutes target resolver context) : + RelTriple + (resolver context) + (resolvePositionThenResolver target resolver context) + (RetainedPositionResolutionRel target) := by + apply relTriple_of_evalDist_eq_left + (evalDist_map_before_resolveResolverThenPositionRetained target resolver context).symm + apply relTriple_of_evalDist_eq_right + (ob := retainedPositionResolutionAfter <$> + resolveResolverThenPositionRetained target resolver context) + (ob' := resolvePositionThenResolver target resolver context) + · calc + evalDist (retainedPositionResolutionAfter <$> + resolveResolverThenPositionRetained target resolver context) = + evalDist (resolveResolverThenPosition target resolver context) := by + rw [map_snd_resolveResolverThenPositionRetained] + _ = evalDist (resolvePositionThenResolver target resolver context) := hcommutes.symm + · exact relTriple_retainedPositionResolution target resolver context + +theorem relTriple_resolveDeferredPosition_targetFirst_retained + (target position : Position) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (hvalid : context.Valid) + (hcompletable : DeferredCompletable table context) : + RelTriple + (resolveDeferredPosition table position context) + (resolvePositionThenResolver target + (fun nextContext => resolveDeferredPosition table position nextContext) context) + (RetainedPositionResolutionRel target) := by + apply relTriple_resolverThenPosition_resolvePositionThenResolver_retained + exact positionResolutionCommutes_position target table position context hvalid hcompletable + +theorem relTriple_resolveDeferredReveal_targetFirst_retained + (target position : Position) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (hvalid : context.Valid) + (hcompletable : DeferredCompletable table context) : + RelTriple + (resolveDeferredReveal table position context) + (resolvePositionThenResolver target + (fun nextContext => resolveDeferredReveal table position nextContext) context) + (RetainedPositionResolutionRel target) := by + apply relTriple_resolverThenPosition_resolvePositionThenResolver_retained + exact positionResolutionCommutes_reveal target table position context hvalid hcompletable + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateSampling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateSampling.lean new file mode 100644 index 00000000..2ea4a9e4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateSampling.lean @@ -0,0 +1,433 @@ +import SphincsSecurity.Proof.OtsProbeResolvedAdaptiveSigner + +/-! +# Private structural sample deferral + +Private structural samples are moved to their first observable use. The base case below proves +that resolving one ensured position before a completed run is neutral when the run returns +immediately. Later lemmas lift the same invariant through queries and recursive resolution. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem finishResolvedRunIsNone_some_eq_finalize + (result : ResolvedRunResult α) + (hcompletable : DeferredCompletable result.table result.context) : + finishResolvedRunIsNone (some result) = + Option.isNone <$> + finalizeResolvedCoordinates result.context.state.coordinates.toList + result.context result.table := by + simp only [finishResolvedRunIsNone, finishResolvedRun, hcompletable, ↓reduceIte, + map_bind] + apply bind_congr + intro finalized + cases finalized <;> rfl + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_finish_isNone + (position : Position) (context : DeferredContext) + (table : OtsSecretIndex → HashOutput) (fuel : Nat) (value : α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : Coordinate.position position ∈ context.state.ensured) : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure true + | some resolved => + finishResolvedRunIsNone + (some ⟨resolved.toDeferredContext, fuel, value, table⟩)) = + evalDist (finishResolvedRunIsNone + (some ⟨context, fuel, value, table⟩)) := by + let coordinates := context.state.coordinates.toList + have hmem : Coordinate.position position ∈ coordinates := by + simp only [coordinates, Finset.mem_toList, LazyRevealProbe.State.coordinates, + Finset.mem_union] + exact Or.inl hensured + have hbase := evalDist_resolveDeferredPositionValue_then_finalize position coordinates + context table hmem (fun output hvalue => + ⟨hvalid.1 position output hvalue, + hvalid.2 (.position position) output hvalue⟩) + calc + _ = evalDist (Option.isNone <$> (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => (pure none : ProbComp (Option DeferredContext)) + | some resolved => + finalizeResolvedCoordinates coordinates resolved.toDeferredContext table)) := by + rw [map_bind] + apply evalDist_bind_congr + intro resolved hsupport + cases resolved with + | none => rfl + | some resolved => + have hresolvedCompletable := hcompletable.of_resolveDeferredPositionValue hvalid + position resolved hsupport + let result : ResolvedRunResult α := + ⟨resolved.toDeferredContext, fuel, value, table⟩ + have hfinish := finishResolvedRunIsNone_some_eq_finalize result + hresolvedCompletable + simp only + rw [hfinish] + have hstate := resolveDeferredPositionValue_state_eq_clearPending position context + resolved hsupport + have hcoordinates : resolved.state.coordinates = context.state.coordinates := by + rw [hstate] + exact coordinates_clearPending_of_mem_ensured context.state (.position position) + hensured + congr 3 + exact congrArg Finset.toList hcoordinates + _ = evalDist (Option.isNone <$> + finalizeResolvedCoordinates coordinates context table) := by + rw [evalDist_map, evalDist_map] + exact congrArg (Functor.map Option.isNone) hbase + _ = _ := by + rw [finishResolvedRunIsNone_some_eq_finalize _ hcompletable] + +noncomputable def runResolvedFinishIsNone + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : ProbComp Bool := + runResolvedFromTable context fuel table computation >>= finishResolvedRunIsNone + +def DeferredResolution.ensure (result : DeferredResolution) (coordinate : Coordinate) : + DeferredResolution := + ⟨{ result.toDeferredContext with state := result.state.ensure coordinate }, result.output⟩ + +def DeferredResolution.publish (result : DeferredResolution) (coordinate : Coordinate) : + DeferredResolution := + ⟨{ result.toDeferredContext with state := result.state.publish coordinate }, result.output⟩ + +def DeferredResolution.addPending (result : DeferredResolution) (coordinate : Coordinate) + (candidate : Digest) : DeferredResolution := + ⟨{ result.toDeferredContext with + state := result.state.addPending coordinate candidate }, result.output⟩ + +@[simp] theorem values_ensure + (state : LazyRevealProbe.State Coordinate) (ensured coordinate : Coordinate) : + (state.ensure ensured).values coordinate = state.values coordinate := rfl + +@[simp] theorem hitAt_ensure + (state : LazyRevealProbe.State Coordinate) (ensured coordinate : Coordinate) + (output : HashOutput) : + (state.ensure ensured).hitAt coordinate output = state.hitAt coordinate output := rfl + +@[simp] theorem values_publish + (state : LazyRevealProbe.State Coordinate) (published coordinate : Coordinate) : + (state.publish published).values coordinate = state.values coordinate := rfl + +@[simp] theorem hitAt_publish + (state : LazyRevealProbe.State Coordinate) (published coordinate : Coordinate) + (output : HashOutput) : + (state.publish published).hitAt coordinate output = state.hitAt coordinate output := rfl + +@[simp] theorem values_addPending + (state : LazyRevealProbe.State Coordinate) (added coordinate : Coordinate) + (candidate : Digest) : + (state.addPending added candidate).values coordinate = state.values coordinate := rfl + +theorem hitAt_addPending_of_ne + (state : LazyRevealProbe.State Coordinate) (added coordinate : Coordinate) + (candidate : Digest) (output : HashOutput) (hne : added ≠ coordinate) : + (state.addPending added candidate).hitAt coordinate output = + state.hitAt coordinate output := by + have hne' : coordinate ≠ added := Ne.symm hne + simp [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, + LazyRevealProbe.State.addPending, hne'] + +theorem resolveDeferredPositionValue_ensure + (position : Position) (context : DeferredContext) (coordinate : Coordinate) : + resolveDeferredPositionValue position + { context with state := context.state.ensure coordinate } = + (fun result => result.map fun resolved => resolved.ensure coordinate) <$> + resolveDeferredPositionValue position context := by + unfold resolveDeferredPositionValue + cases hstate : context.state.values (.position position) with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hstate, hhit] + · simp [hstate, hhit, DeferredResolution.ensure, clearPending_ensure_comm] + | none => + cases hvalue : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hstate, hhit] + · simp [hstate, hhit, DeferredResolution.ensure, + clearPending_ensure_comm] + | none => + simp only [values_ensure, hstate] + rw [map_bind] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] + · simp [hhit, DeferredResolution.ensure, clearPending_ensure_comm] + +theorem resolveDeferredPositionValue_publish + (position : Position) (context : DeferredContext) (coordinate : Coordinate) : + resolveDeferredPositionValue position + { context with state := context.state.publish coordinate } = + (fun result => result.map fun resolved => resolved.publish coordinate) <$> + resolveDeferredPositionValue position context := by + unfold resolveDeferredPositionValue + cases hstate : context.state.values (.position position) with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hstate, hhit] + · simp [hstate, hhit, DeferredResolution.publish, clearPending_publish_comm] + | none => + cases hvalue : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hstate, hhit] + · simp [hstate, hhit, DeferredResolution.publish, clearPending_publish_comm] + | none => + simp only [values_publish, hstate] + rw [map_bind] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] + · simp [hhit, DeferredResolution.publish, clearPending_publish_comm] + +theorem resolveDeferredPositionValue_addPending_of_ne + (position : Position) (context : DeferredContext) (coordinate : Coordinate) + (candidate : Digest) (hne : coordinate ≠ .position position) : + resolveDeferredPositionValue position + { context with state := context.state.addPending coordinate candidate } = + (fun result => result.map fun resolved => resolved.addPending coordinate candidate) <$> + resolveDeferredPositionValue position context := by + unfold resolveDeferredPositionValue + cases hstate : context.state.values (.position position) with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hstate, hhit, hitAt_addPending_of_ne _ _ _ _ _ hne] + · simp [hstate, hhit, hitAt_addPending_of_ne _ _ _ _ _ hne, + DeferredResolution.addPending, clearPending_addPending_comm_of_ne _ _ _ _ hne] + | none => + cases hvalue : context.values position with + | some output => + by_cases hhit : context.state.hitAt (.position position) output + · simp [hstate, hhit, hitAt_addPending_of_ne _ _ _ _ _ hne] + · simp [hstate, hhit, hitAt_addPending_of_ne _ _ _ _ _ hne, + DeferredResolution.addPending, clearPending_addPending_comm_of_ne _ _ _ _ hne] + | none => + simp only [values_addPending, hstate] + rw [map_bind] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit, hitAt_addPending_of_ne _ _ _ _ _ hne] + · simp [hhit, hitAt_addPending_of_ne _ _ _ _ _ hne, + DeferredResolution.addPending, clearPending_addPending_comm_of_ne _ _ _ _ hne] + +theorem DeferredContext.Valid.addPending_of_completable + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hvalid : context.Valid) (coordinate : Coordinate) (candidate : Digest) + (hcompletable : DeferredCompletable table + { context with state := context.state.addPending coordinate candidate }) : + ({ context with state := context.state.addPending coordinate candidate } : + DeferredContext).Valid := by + obtain ⟨completion, hcompletion⟩ := hcompletable + constructor + · exact hvalid.1 + · intro other output hvalue hhit + have hvalueOriginal : context.state.values other = some output := hvalue + have hcompletionValue : completion other = output := + hcompletion.1 other output hvalueOriginal + have hmember : (other, truncateHash output) ∈ + (context.state.addPending coordinate candidate).pending := + (LazyRevealProbe.State.mem_pendingAt_iff + (context.state.addPending coordinate candidate) other (truncateHash output)).1 hhit + exact hcompletion.2.2.1 other (truncateHash output) hmember (by + rw [hcompletionValue]) + +theorem startTableAgrees_of_deferredCompletable + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hcompletable : DeferredCompletable table context) : + StartTableAgrees context.state table := by + obtain ⟨completion, hcompletion⟩ := hcompletable + intro index output hvalue + exact (hcompletion.1 index.coordinate output hvalue).symm.trans + (hcompletion.2.2.2 index) + +theorem evalDist_runResolvedFinishIsNone_eq_true_of_not_completable + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) : + evalDist (runResolvedFromTable context fuel table computation >>= + finishResolvedRunIsNone) = evalDist (pure true : ProbComp Bool) := by + calc + _ = evalDist (runResolvedFromTable context fuel table computation >>= fun _ => + pure true) := by + apply evalDist_bind_congr + intro result hresult + cases result with + | none => simp [finishResolvedRunIsNone, finishResolvedRun] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable computation context fuel + table result hconsistent hstarts hresult + have hstillDoomed := not_deferredCompletable_of_mem_runResolvedFromTable + computation context fuel table result hconsistent hstarts hresult hdoomed + simp [finishResolvedRunIsNone, finishResolvedRun, hcore.1, hstillDoomed] + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (runResolvedFromTable context fuel table computation) (by simp [runResolvedFromTable]) + (pure true) + +theorem clearPending_addPending_clearPending_self + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (candidate : Digest) : + ((state.clearPending coordinate).addPending coordinate candidate).clearPending coordinate = + (state.addPending coordinate candidate).clearPending coordinate := by + rcases state with ⟨pending, values, revealed, ensured⟩ + simp only [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.addPending] + congr 1 + apply Finset.ext + intro entry + by_cases haway : entry.1 ≠ coordinate + · have hpair : entry ≠ (coordinate, candidate) := by + intro heq + subst entry + exact haway rfl + simp [LazyRevealProbe.State.pendingAway, haway, hpair] + · simp [LazyRevealProbe.State.pendingAway, haway] + +theorem resolveDeferredPositionValue_then_addPending_self_resolve + (position : Position) (context : DeferredContext) (candidate : Digest) : + (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => (pure none : ProbComp (Option DeferredResolution)) + | some resolved => + resolveDeferredPositionValue position + { resolved.toDeferredContext with + state := resolved.state.addPending (.position position) candidate }) = + resolveDeferredPositionValue position + { context with + state := context.state.addPending (.position position) candidate } := by + unfold resolveDeferredPositionValue + cases hstate : context.state.values (.position position) with + | some output => + by_cases holdHit : context.state.hitAt (.position position) output + · have hnewHit : + (context.state.addPending (.position position) candidate).hitAt + (.position position) output := + (hitAt_addPending_self_iff context.state (.position position) candidate output).2 + (Or.inl holdHit) + simp [hstate, holdHit, hnewHit] + · by_cases hcandidate : truncateHash output = candidate + · have hnewHit : + (context.state.addPending (.position position) candidate).hitAt + (.position position) output := + (hitAt_addPending_self_iff context.state (.position position) candidate output).2 + (Or.inr hcandidate) + simp [hstate, holdHit, hnewHit, hitAt_addPending_self_iff, hcandidate] + · have hnewHit : + ¬(context.state.addPending (.position position) candidate).hitAt + (.position position) output := by + rw [hitAt_addPending_self_iff] + exact not_or_intro holdHit hcandidate + simp [hstate, holdHit, hnewHit, hitAt_addPending_self_iff, hcandidate, + clearPending_addPending_clearPending_self, + DeferredStructuralValues.install, not_hitAt_clearPending_self] + | none => + cases hvalue : context.values position with + | some output => + by_cases holdHit : context.state.hitAt (.position position) output + · have hnewHit : + (context.state.addPending (.position position) candidate).hitAt + (.position position) output := + (hitAt_addPending_self_iff context.state (.position position) candidate output).2 + (Or.inl holdHit) + simp [hstate, holdHit, hnewHit] + · by_cases hcandidate : truncateHash output = candidate + · have hnewHit : + (context.state.addPending (.position position) candidate).hitAt + (.position position) output := + (hitAt_addPending_self_iff context.state (.position position) candidate output).2 + (Or.inr hcandidate) + simp [hstate, hvalue, holdHit, hnewHit, hitAt_addPending_self_iff, + hcandidate] + · have hnewHit : + ¬(context.state.addPending (.position position) candidate).hitAt + (.position position) output := by + rw [hitAt_addPending_self_iff] + exact not_or_intro holdHit hcandidate + simp [hstate, hvalue, holdHit, hnewHit, hitAt_addPending_self_iff, + hcandidate, clearPending_addPending_clearPending_self, + not_hitAt_clearPending_self] + | none => + simp only [values_addPending, hstate, bind_assoc] + apply bind_congr + intro output + by_cases holdHit : context.state.hitAt (.position position) output + · have hnewHit : + (context.state.addPending (.position position) candidate).hitAt + (.position position) output := + (hitAt_addPending_self_iff context.state (.position position) candidate output).2 + (Or.inl holdHit) + simp [holdHit, hnewHit] + · by_cases hcandidate : truncateHash output = candidate + · have hnewHit : + (context.state.addPending (.position position) candidate).hitAt + (.position position) output := + (hitAt_addPending_self_iff context.state (.position position) candidate output).2 + (Or.inr hcandidate) + simp [hstate, holdHit, hnewHit, hitAt_addPending_self_iff, + hcandidate, DeferredStructuralValues.install, + not_hitAt_clearPending_self] + · have hnewHit : + ¬(context.state.addPending (.position position) candidate).hitAt + (.position position) output := by + rw [hitAt_addPending_self_iff] + exact not_or_intro holdHit hcandidate + simp [hstate, holdHit, hnewHit, hitAt_addPending_self_iff, hcandidate, + clearPending_addPending_clearPending_self, + DeferredStructuralValues.install, not_hitAt_clearPending_self] + +theorem evalDist_resolveDeferredPositionValue_then_run_eq_true_of_not_completable + (position : Position) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => pure true + | some resolved => + runResolvedFromTable resolved.toDeferredContext fuel table computation >>= + finishResolvedRunIsNone) = evalDist (pure true : ProbComp Bool) := by + calc + _ = evalDist (resolveDeferredPositionValue position context >>= fun _ => pure true) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hresolvedNotCompletable : + ¬DeferredCompletable table resolved.toDeferredContext := by + intro hresolvedCompletable + obtain ⟨completion, hcompletion⟩ := hresolvedCompletable + have hback := + (deferredCompletion_resolveDeferredPositionValue_iff position resolved + hconsistent hresolved completion).mp hcompletion + exact hdoomed ⟨completion, hback.1⟩ + exact evalDist_runResolvedFinishIsNone_eq_true_of_not_completable + resolved.toDeferredContext fuel table computation + (hconsistent.of_resolveDeferredPositionValue position resolved hresolved) + (hstarts.of_state_values_eq + (resolveDeferredPositionValue_preserves_state_values position context resolved + hresolved)) + hresolvedNotCompletable + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolveDeferredPositionValue position context) (by + simp [resolveDeferredPositionValue, LazyRevealProbe.sampleHashOutput]) + (pure true) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateSchedule.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateSchedule.lean new file mode 100644 index 00000000..b49b6fc5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateSchedule.lean @@ -0,0 +1,1118 @@ +import SphincsSecurity.Proof.OtsProbeResolvedPrivateSelection + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp + +attribute [local irreducible] maskedSignLayer + +def selectedChronologicalPartsOfStore (store : DeferredLayerStore) : + Layer → Option ChronologicalLayerPart := fun lay => + match store.selected lay with + | none => none + | some (counter, encoding) => + some + { counter := counter + encoding := encoding + chainValue := fun _ => 0 + authPath := fun _ => 0 } + +noncomputable def publishSelectedChronologicalSignature + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (selected : Layer → Option DeferredLayerEncoding) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature) := + match traverseOption selected with + | none => pure none + | some parts => do + let published ← sequenceFin fun lay => + revealLayerValues index lay (parts lay).2 + pure (some + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (published lay).1 + authPath := flattenPaths fun lay => (published lay).2 }) + +theorem publishChronologicalSignature_eq_selected + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (layers : Layer → Option ChronologicalLayerPart) : + publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers = + publishSelectedChronologicalSignature ftsSecret randomness index leaves ftsPath + (fun lay => (layers lay).map fun part => (part.counter, part.encoding)) := by + unfold publishChronologicalSignature publishSelectedChronologicalSignature + rw [traverseOption_map] + cases hparts : traverseOption layers with + | none => rfl + | some parts => rfl + +def ResolutionPresenceAgrees (store : DeferredLayerStore) : Prop := + ∀ lay, (store.resolved lay).isSome = (store.selected lay).isSome + +theorem chronologicalPartsOfStore_selection_eq + (store : DeferredLayerStore) (hagrees : ResolutionPresenceAgrees store) : + (fun lay => (chronologicalPartsOfStore store lay).map fun part => + (part.counter, part.encoding)) = store.selected := by + funext lay + unfold chronologicalPartsOfStore + cases hselected : store.selected lay with + | none => simp + | some selected => + cases hresolved : store.resolved lay with + | none => + have := hagrees lay + simp [hselected, hresolved] at this + | some resolved => + rcases selected with ⟨counter, encoding⟩ + rcases resolved with ⟨resolvedCounter, chainValue, authPath⟩ + simp + +theorem publishChronologicalSignature_store_eq_selected + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (store : DeferredLayerStore) (hagrees : ResolutionPresenceAgrees store) : + publishChronologicalSignature ftsSecret randomness index leaves ftsPath + (chronologicalPartsOfStore store) = + publishSelectedChronologicalSignature ftsSecret randomness index leaves ftsPath + store.selected := by + rw [publishChronologicalSignature_eq_selected, + chronologicalPartsOfStore_selection_eq store hagrees] + +noncomputable def publishSelectedDeferredSignature + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) : + Option (ResolvedRunResult DeferredLayerStore) → + ProbComp (Option (ResolvedRunResult (Option Signature × SplitHashCache))) + | none => pure none + | some result => + runResolvedFromTable result.context result.remaining result.table + ((publishSelectedChronologicalSignature ftsSecret randomness index leaves ftsPath + result.value.selected).run result.value.cache) + +theorem publishDeferredChronologicalSignature_eq_selected + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (result : ResolvedRunResult DeferredLayerStore) + (hagrees : ResolutionPresenceAgrees result.value) : + publishDeferredChronologicalSignature ftsSecret randomness index leaves ftsPath + (some result) = + publishSelectedDeferredSignature ftsSecret randomness index leaves ftsPath + (some result) := by + unfold publishDeferredChronologicalSignature publishSelectedDeferredSignature + simp only + rw [publishChronologicalSignature_store_eq_selected ftsSecret randomness index leaves + ftsPath result.value hagrees] + +theorem valid_completable_of_mem_runResolvedFromTable_of_finalizationMaterializedCouples + (table : OtsSecretIndex → HashOutput) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcouples : FinalizationMaterializedCouples table computation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult (α × SplitHashCache)) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table (computation.run cache))) : + result.context.Valid ∧ DeferredCompletable table result.context := by + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hview := finalizationViewEq_of_deferredCompletion_iff hvalid hvalid hstarts hstarts + rfl hcompletable (fun _ => Iff.rfl) + have hrelation := hcouples context context fuel cache cache + ⟨hview, hvalid, hvalid, hcompletable⟩ rfl rfl + obtain ⟨rightResult, _hright, hresultRelation⟩ := + exists_right_of_relTriple_of_mem_support hrelation hresult + cases rightResult with + | none => simp [FinalizationMaterializedRunEq] at hresultRelation + | some rightResult => + rcases hresultRelation with + ⟨_value, hcontexts, _fuel, _leftTable, _rightTable, _cache, _revealed⟩ + exact ⟨hcontexts.2.1, hcontexts.2.2.2⟩ + +theorem LayerValuesEnsured.of_privateStateAgrees + {index : Index} {lay : Layer} {encoding : ChainIndex → Digit} + {left right : DeferredContext} + (hensured : LayerValuesEnsured index lay encoding right) + (hagrees : PrivateStateAgrees left right) : + LayerValuesEnsured index lay encoding left := by + rcases hagrees with ⟨_values, _revealed, hstateEnsured⟩ + constructor + · simpa [hstateEnsured] using hensured.1 + · intro level hlevel + apply (treeNodeEnsured_congr_ensured lay (treeIndexAt index lay) level.val + (Nat.xor ((leafIndexAt index lay).val / 2 ^ level.val) 1) + right left hstateEnsured.symm).mp + exact hensured.2 level hlevel + +theorem LayerValuesEnsured.mono + {index : Index} {lay : Layer} {encoding : ChainIndex → Digit} + {left right : DeferredContext} + (hensured : LayerValuesEnsured index lay encoding left) + (hle : LazyRevealProbe.EnsuredLE left.state right.state) : + LayerValuesEnsured index lay encoding right := by + refine ⟨fun chainIdx step hstep => hle (hensured.1 chainIdx step hstep), ?_⟩ + intro level hlevel + exact (hensured.2 level hlevel).mono hle + +theorem DeferredCompletable.of_resolveDeferredLayerValues + {table : OtsSecretIndex → HashOutput} {index : Index} {lay : Layer} + {encoding : ChainIndex → Digit} {context finalContext : DeferredContext} + {values : (ChainIndex → Digest) × (Fin maxLayerHeight → Digest)} + (hcompletable : DeferredCompletable table context) (hvalid : context.Valid) + (hresult : some (finalContext, values) ∈ support + (resolveDeferredLayerValues table index lay encoding context)) : + DeferredCompletable table finalContext := by + rw [resolveDeferredLayerValues, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + rcases chains with ⟨afterChains, chainValues⟩ + rw [mem_support_bind_iff] at hrest + obtain ⟨pathOption, hpath, hreturn⟩ := hrest + cases pathOption with + | none => simp at hreturn + | some path => + rcases path with ⟨afterPath, pathValues⟩ + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hreturn' : finalContext = afterPath := by + exact congrArg (fun result => result.1) (Option.some.inj hreturn) + rw [hreturn'] + have hchainsCompletable := + hcompletable.of_resolveDeferredSelectedChainFamily hvalid + (fun chainIdx : ChainIndex => chainIdx) encoding afterChains chainValues hchains + have hchainsValid := hvalid.of_resolveDeferredSelectedChainFamily table lay + (treeIndexAt index lay) (leafIndexAt index lay) + (fun chainIdx : ChainIndex => chainIdx) encoding afterChains chainValues hchains + exact hchainsCompletable.of_resolveDeferredLayerPathFamily hchainsValid + (fun level : Fin maxLayerHeight => level) afterPath pathValues hpath + +noncomputable def resolveSelectedLayerValuesList + (table : OtsSecretIndex → HashOutput) (index : Index) + (selected : Layer → Option DeferredLayerEncoding) : + List Layer → DeferredContext → ProbComp (Option DeferredContext) + | [], context => pure (some context) + | lay :: layers, context => + match selected lay with + | none => resolveSelectedLayerValuesList table index selected layers context + | some (_, encoding) => do + let resolved ← resolveDeferredLayerValues table index lay encoding context + match resolved with + | none => pure none + | some (afterLayer, _) => + resolveSelectedLayerValuesList table index selected layers afterLayer + +theorem evalDist_resolveSelectedLayerValuesList_then_runResolvedFinishIsNone + (table : OtsSecretIndex → HashOutput) (index : Index) + (selected : Layer → Option DeferredLayerEncoding) + (fuel : Nat) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + ∀ (layers : List Layer) (context : DeferredContext), + context.Valid → DeferredCompletable table context → + (∀ lay, lay ∈ layers → ∀ counter encoding, + selected lay = some (counter, encoding) → + LayerValuesEnsured index lay encoding context) → + evalDist (do + let resolved ← resolveSelectedLayerValuesList table index selected layers context + match resolved with + | none => pure true + | some finalContext => + runResolvedFinishIsNone finalContext fuel table computation) = + evalDist (runResolvedFinishIsNone context fuel table computation) + | [], context, hvalid, hcompletable, hensured => by + simp [resolveSelectedLayerValuesList] + | lay :: layers, context, hvalid, hcompletable, hensured => by + rw [resolveSelectedLayerValuesList] + cases hselection : selected lay with + | none => + exact evalDist_resolveSelectedLayerValuesList_then_runResolvedFinishIsNone table index + selected fuel computation layers context hvalid hcompletable + (fun other hother counter encoding hselected => + hensured other (List.mem_cons_of_mem lay hother) counter encoding hselected) + | some selection => + rcases selection with ⟨counter, encoding⟩ + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredLayerValues table index lay encoding context >>= fun + resolved => + match resolved with + | none => pure true + | some (afterLayer, _) => + runResolvedFinishIsNone afterLayer fuel table computation) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + rcases resolved with ⟨afterLayer, values⟩ + have hafterValid := hvalid.of_resolveDeferredLayerValues table index lay + encoding afterLayer values hresolved + have hafterCompletable := hcompletable.of_resolveDeferredLayerValues hvalid + hresolved + have hagrees := privateStateAgrees_resolveDeferredLayerValues table index lay + encoding context afterLayer values hresolved + exact evalDist_resolveSelectedLayerValuesList_then_runResolvedFinishIsNone + table index selected fuel computation layers afterLayer hafterValid + hafterCompletable + (fun other hother otherCounter otherEncoding hselected => + (hensured other (List.mem_cons_of_mem lay hother) otherCounter + otherEncoding hselected).of_privateStateAgrees hagrees) + _ = _ := + evalDist_resolveDeferredLayerValues_then_runResolvedFinishIsNone table index lay + encoding context fuel computation hvalid hcompletable + (hensured lay (by simp) counter encoding hselection) + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredLayerSchedule_publish_finish_eq_selectedList + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) (index : Index) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) : + ∀ (layers : List Layer) (result : ResolvedRunResult DeferredLayerStore), + result.table = table → + (∀ lay, lay ∉ layers → + (result.value.resolved lay).isSome = + (result.value.selected lay).isSome) → + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + (layers.map DeferredLayerOperation.resolve) (some result) >>= + publishDeferredChronologicalSignature ftsSecret randomness index leaves ftsPath >>= + finishResolvedRunIsNone) = + evalDist (do + let resolved ← resolveSelectedLayerValuesList table index + result.value.selected layers result.context + match resolved with + | none => pure true + | some finalContext => + runResolvedFinishIsNone finalContext result.remaining table + ((publishSelectedChronologicalSignature ftsSecret randomness index leaves + ftsPath result.value.selected).run result.value.cache)) + | [], result, htable, hagrees => by + have hpresence : ResolutionPresenceAgrees result.value := by + intro lay + exact hagrees lay (by simp) + simp only [List.map_nil, runDeferredLayerSchedule, pure_bind, + resolveSelectedLayerValuesList] + rw [publishDeferredChronologicalSignature_eq_selected ftsSecret randomness index leaves + ftsPath result hpresence] + simp only [publishSelectedDeferredSignature] + unfold runResolvedFinishIsNone + rw [htable] + | lay :: layers, result, htable, hagrees => by + simp only [List.map_cons, runDeferredLayerSchedule, runDeferredLayerOperation] + rw [resolveDeferredLayer] + cases hselection : result.value.selected lay with + | none => + simp only [pure_bind, resolveSelectedLayerValuesList, hselection] + have hrecursive := + evalDist_resolveDeferredLayerSchedule_publish_finish_eq_selectedList parameter + table index ftsSecret randomness leaves ftsPath layers + { context := result.context + remaining := result.remaining + value := + { result.value with + resolved := Function.update result.value.resolved lay none } + table := table } + rfl (by + intro observed hnotMem + by_cases heq : observed = lay + · subst observed + simp [Function.update, hselection] + · simpa [Function.update, heq] using + hagrees observed (by simp [heq, hnotMem])) + simpa only [bind_assoc] using hrecursive + | some selection => + rcases selection with ⟨counter, encoding⟩ + simp only [bind_assoc, resolveSelectedLayerValuesList, hselection] + apply evalDist_bind_congr + intro resolvedOption hresolved + cases resolvedOption with + | none => + simp [publishDeferredChronologicalSignature, finishResolvedRunIsNone, + finishResolvedRun] + | some resolved => + rcases resolved with ⟨afterLayer, values⟩ + simpa only [pure_bind, bind_assoc] using + (evalDist_resolveDeferredLayerSchedule_publish_finish_eq_selectedList parameter + table index ftsSecret randomness leaves ftsPath layers + { context := afterLayer + remaining := result.remaining + value := + { result.value with + resolved := Function.update result.value.resolved lay + (some (counter, values.1, values.2)) } + table := table } + rfl (by + intro observed hnotMem + by_cases heq : observed = lay + · subst observed + simp [Function.update, hselection] + · simpa [Function.update, heq] using + hagrees observed (by simp [heq, hnotMem]))) + +theorem ensuredLE_of_mem_selectDeferredLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (input output : ResolvedRunResult DeferredLayerStore) + (houtput : some output ∈ support + (selectDeferredLayer parameter table ftsSecret index lay input)) : + LazyRevealProbe.EnsuredLE input.context.state output.context.state := by + unfold selectDeferredLayer at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨selectedOption, hselected, hreturn⟩ := houtput + cases selectedOption with + | none => simp at hreturn + | some selected => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have houtputEq := Option.some.inj hreturn + subst output + exact ensuredLE_of_mem_runResolvedFromTable + ((maskedSignLayer parameter ftsSecret index lay).run input.value.cache) + input.context input.remaining table selected hselected + +theorem selected_eq_of_mem_selectDeferredLayer_of_ne + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay observed : Layer) (hne : observed ≠ lay) + (input output : ResolvedRunResult DeferredLayerStore) + (houtput : some output ∈ support + (selectDeferredLayer parameter table ftsSecret index lay input)) : + output.value.selected observed = input.value.selected observed := by + unfold selectDeferredLayer at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨selectedOption, _hselected, hreturn⟩ := houtput + cases selectedOption with + | none => simp at hreturn + | some selected => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have houtputEq := Option.some.inj hreturn + subst output + simp [Function.update, hne] + +set_option maxHeartbeats 800000 in +theorem selectedLayersEnsured_of_mem_deferredLayerSelections + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (output : ResolvedRunResult DeferredLayerStore) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (houtput : some output ∈ support + (runDeferredLayerSchedule parameter table ftsSecret index deferredLayerSelections + (some ⟨context, fuel, emptyDeferredLayerStore cache, table⟩))) : + output.table = table ∧ output.context.Valid ∧ + DeferredCompletable table output.context ∧ + ∀ lay counter encoding, + output.value.selected lay = some (counter, encoding) → + LayerValuesEnsured index lay encoding output.context := by + simp only [deferredLayerSelections, List.map_cons, List.map_nil, + runDeferredLayerSchedule, runDeferredLayerOperation, mem_support_bind_iff] at houtput + obtain ⟨topOption, htop, hafterTop⟩ := houtput + cases topOption with + | none => simp at hafterTop + | some topResult => + obtain ⟨middleOption, hmiddle, hafterMiddle⟩ := hafterTop + cases middleOption with + | none => simp at hafterMiddle + | some middleResult => + obtain ⟨bottomOption, hbottom, hreturn⟩ := hafterMiddle + cases bottomOption with + | none => simp at hreturn + | some bottomResult => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have houtputEq := Option.some.inj hreturn + rw [houtputEq] + have htopInv := valid_pendingCovered_of_mem_selectDeferredLayer parameter table + ftsSecret index topLayer context.state.coordinates.toList + ⟨context, fuel, emptyDeferredLayerStore cache, table⟩ topResult hvalid + (pendingCovered_coordinates_toList context) htop + have htopCompletable := deferredCompletable_of_mem_selectDeferredLayer parameter + table ftsSecret index topLayer + ⟨context, fuel, emptyDeferredLayerStore cache, table⟩ topResult hvalid + hcompletable htop + have hmiddleInv := valid_pendingCovered_of_mem_selectDeferredLayer parameter table + ftsSecret index middleLayer context.state.coordinates.toList topResult + middleResult htopInv.2.1 htopInv.2.2 hmiddle + have hmiddleCompletable := deferredCompletable_of_mem_selectDeferredLayer parameter + table ftsSecret index middleLayer topResult middleResult htopInv.2.1 + htopCompletable hmiddle + have hbottomInv := valid_pendingCovered_of_mem_selectDeferredLayer parameter table + ftsSecret index bottomLayer context.state.coordinates.toList middleResult + bottomResult hmiddleInv.2.1 hmiddleInv.2.2 hbottom + have hbottomCompletable := deferredCompletable_of_mem_selectDeferredLayer parameter + table ftsSecret index bottomLayer middleResult bottomResult hmiddleInv.2.1 + hmiddleCompletable hbottom + refine ⟨hbottomInv.1, hbottomInv.2.1, hbottomCompletable, ?_⟩ + intro lay counter encoding hselected + fin_cases lay + · have htopSelected : topResult.value.selected topLayer = + some (counter, encoding) := by + rw [← selected_eq_of_mem_selectDeferredLayer_of_ne parameter table ftsSecret + index middleLayer topLayer (by decide) topResult middleResult hmiddle, + ← selected_eq_of_mem_selectDeferredLayer_of_ne parameter table ftsSecret + index bottomLayer topLayer (by decide) middleResult bottomResult hbottom] + exact hselected + have htopEnsured := selectedLayerValuesEnsured_of_mem_selectDeferredLayer + parameter table ftsSecret index topLayer + ⟨context, fuel, emptyDeferredLayerStore cache, table⟩ topResult + counter encoding htop htopSelected + exact (htopEnsured.mono + (ensuredLE_of_mem_selectDeferredLayer parameter table ftsSecret index + middleLayer topResult middleResult hmiddle)).mono + (ensuredLE_of_mem_selectDeferredLayer parameter table ftsSecret index + bottomLayer middleResult bottomResult hbottom) + · have hmiddleSelected : middleResult.value.selected middleLayer = + some (counter, encoding) := by + rw [← selected_eq_of_mem_selectDeferredLayer_of_ne parameter table ftsSecret + index bottomLayer middleLayer (by decide) middleResult bottomResult hbottom] + exact hselected + have hmiddleEnsured := selectedLayerValuesEnsured_of_mem_selectDeferredLayer + parameter table ftsSecret index middleLayer topResult middleResult + counter encoding hmiddle hmiddleSelected + exact hmiddleEnsured.mono + (ensuredLE_of_mem_selectDeferredLayer parameter table ftsSecret index + bottomLayer middleResult bottomResult hbottom) + · have hbottomSelected : bottomResult.value.selected bottomLayer = + some (counter, encoding) := by + simpa [bottomLayer, numLayers] using hselected + exact selectedLayerValuesEnsured_of_mem_selectDeferredLayer + parameter table ftsSecret index bottomLayer middleResult bottomResult + counter encoding hbottom hbottomSelected + +noncomputable def runSelectionOnlyLayersAndPublish + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + ProbComp (Option (ResolvedRunResult (Option Signature × SplitHashCache))) := + runDeferredLayerSchedule parameter table ftsSecret index deferredLayerSelections + (some ⟨context, fuel, emptyDeferredLayerStore cache, table⟩) >>= + publishSelectedDeferredSignature ftsSecret randomness index leaves ftsPath + +set_option maxRecDepth 100000 in +theorem evalDist_runDeferredLayersAndPublish_finish_eq_selectionOnly + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (runDeferredLayersAndPublish parameter table ftsSecret randomness index leaves + ftsPath deferredLayerSchedule context fuel cache >>= finishResolvedRunIsNone) = + evalDist (runSelectionOnlyLayersAndPublish parameter table ftsSecret randomness index + leaves ftsPath context fuel cache >>= finishResolvedRunIsNone) := by + unfold runDeferredLayersAndPublish runSelectionOnlyLayersAndPublish + rw [deferredLayerSchedule_eq_append, runDeferredLayerSchedule_append] + simp only [bind_assoc] + apply evalDist_bind_congr + intro selectedOption hselected + cases selectedOption with + | none => + simp [publishDeferredChronologicalSignature, publishSelectedDeferredSignature, + finishResolvedRunIsNone, finishResolvedRun] + | some selected => + have hinvariants := selectedLayersEnsured_of_mem_deferredLayerSelections parameter table + ftsSecret index context fuel cache selected hvalid hcompletable hselected + have hschedule := + evalDist_resolveDeferredLayerSchedule_publish_finish_eq_selectedList parameter table + index ftsSecret randomness leaves ftsPath [topLayer, middleLayer, bottomLayer] + selected hinvariants.1 (by + intro lay hnotMem + fin_cases lay <;> + simp [topLayer, middleLayer, bottomLayer, numLayers] at hnotMem) + simp only [deferredLayerResolutions, publishSelectedDeferredSignature] + rw [← bind_assoc] + rw [hschedule] + rw [hinvariants.1] + exact evalDist_resolveSelectedLayerValuesList_then_runResolvedFinishIsNone table index + selected.value.selected selected.remaining + ((publishSelectedChronologicalSignature ftsSecret randomness index leaves ftsPath + selected.value.selected).run selected.value.cache) + [topLayer, middleLayer, bottomLayer] selected.context hinvariants.2.1 + hinvariants.2.2.1 (by + intro lay hlay counter encoding hselection + exact hinvariants.2.2.2 lay counter encoding hselection) + +noncomputable def runSelectionOnlySignAfterDigest + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + ProbComp (Option (ResolvedRunResult (Option Signature × SplitHashCache))) := do + let ftsPath ← runResolvedFromTable context fuel table + ((simulateQ ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index))).run cache) + match ftsPath with + | none => pure none + | some ftsPath => + runSelectionOnlyLayersAndPublish parameter table ftsSecret randomness index leaves + ftsPath.value.1 ftsPath.context ftsPath.remaining ftsPath.value.2 + +set_option maxRecDepth 100000 in +theorem evalDist_runDeferredChronologicalSignAfterDigest_finish_eq_selectionOnly + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (runDeferredChronologicalSignAfterDigest parameter table ftsSecret randomness + index leaves context fuel cache >>= finishResolvedRunIsNone) = + evalDist (runSelectionOnlySignAfterDigest parameter table ftsSecret randomness index + leaves context fuel cache >>= finishResolvedRunIsNone) := by + unfold runDeferredChronologicalSignAfterDigest runSelectionOnlySignAfterDigest + simp only [bind_assoc] + apply evalDist_bind_congr + intro ftsOption hfts + cases ftsOption with + | none => simp [finishResolvedRunIsNone, finishResolvedRun] + | some ftsResult => + have hftsInvariants := + valid_completable_of_mem_runResolvedFromTable_of_finalizationMaterializedCouples table + (simulateQ ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index))) + (finalizationMaterializedCouples_simulateQ ordinaryHashImpl + (finalizationMaterializedCouples_ordinaryHashImpl table) + (ftsOpen parameter index leaves (ftsSecret index))) + context fuel cache ftsResult hvalid hcompletable hfts + calc + _ = evalDist (runDeferredLayersAndPublish parameter table ftsSecret randomness index + leaves ftsResult.value.1 deferredLayerSchedule ftsResult.context + ftsResult.remaining ftsResult.value.2 >>= finishResolvedRunIsNone) := + evalDist_runDeferredChronologicalLayersAndPublish_finish_eq_deferred parameter table + ftsSecret randomness index leaves ftsResult.value.1 ftsResult.context + ftsResult.remaining ftsResult.value.2 + _ = _ := evalDist_runDeferredLayersAndPublish_finish_eq_selectionOnly parameter table + ftsSecret randomness index leaves ftsResult.value.1 ftsResult.context + ftsResult.remaining ftsResult.value.2 hftsInvariants.1 hftsInvariants.2 + +noncomputable def continueResolvedRunIsNone + (next : σ → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : + Option (ResolvedRunResult (σ × SplitHashCache)) → ProbComp Bool + | none => pure true + | some result => + runResolvedFinishIsNone result.context result.remaining result.table + ((next result.value.1).run result.value.2) + +theorem evalDist_runResolvedFromTable_then_continue + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) σ) + (next : σ → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : + evalDist (runResolvedFromTable context fuel table (computation.run cache) >>= + continueResolvedRunIsNone next) = + evalDist (runResolvedFinishIsNone context fuel table + ((computation >>= next).run cache)) := by + unfold runResolvedFinishIsNone + rw [StateT.run_bind, runResolvedFromTable_bind, bind_assoc] + apply evalDist_bind_congr + intro resultOption _hresult + cases resultOption with + | none => simp [continueResolvedRunIsNone, finishResolvedRunIsNone, finishResolvedRun] + | some result => rfl + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredLayerSchedule_continue_eq_selectedList + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) (index : Index) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (next : Option Signature → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : + ∀ (layers : List Layer) (result : ResolvedRunResult DeferredLayerStore), + result.table = table → + (∀ lay, lay ∉ layers → + (result.value.resolved lay).isSome = + (result.value.selected lay).isSome) → + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + (layers.map DeferredLayerOperation.resolve) (some result) >>= + publishDeferredChronologicalSignature ftsSecret randomness index leaves ftsPath >>= + continueResolvedRunIsNone next) = + evalDist (do + let resolved ← resolveSelectedLayerValuesList table index + result.value.selected layers result.context + match resolved with + | none => pure true + | some finalContext => + runResolvedFinishIsNone finalContext result.remaining table + ((publishSelectedChronologicalSignature ftsSecret randomness index leaves + ftsPath result.value.selected >>= next).run result.value.cache)) + | [], result, htable, hagrees => by + have hpresence : ResolutionPresenceAgrees result.value := by + intro lay + exact hagrees lay (by simp) + simp only [List.map_nil, runDeferredLayerSchedule, pure_bind, + resolveSelectedLayerValuesList] + rw [publishDeferredChronologicalSignature_eq_selected ftsSecret randomness index leaves + ftsPath result hpresence] + simp only [publishSelectedDeferredSignature] + rw [htable] + exact evalDist_runResolvedFromTable_then_continue result.context result.remaining table + result.value.cache + (publishSelectedChronologicalSignature ftsSecret randomness index leaves ftsPath + result.value.selected) next + | lay :: layers, result, htable, hagrees => by + simp only [List.map_cons, runDeferredLayerSchedule, runDeferredLayerOperation] + rw [resolveDeferredLayer] + cases hselection : result.value.selected lay with + | none => + simp only [pure_bind, resolveSelectedLayerValuesList, hselection] + have hrecursive := + evalDist_resolveDeferredLayerSchedule_continue_eq_selectedList parameter table index + ftsSecret randomness leaves ftsPath next layers + { context := result.context + remaining := result.remaining + value := + { result.value with + resolved := Function.update result.value.resolved lay none } + table := table } + rfl (by + intro observed hnotMem + by_cases heq : observed = lay + · subst observed + simp [Function.update, hselection] + · simpa [Function.update, heq] using + hagrees observed (by simp [heq, hnotMem])) + simpa only [bind_assoc] using hrecursive + | some selection => + rcases selection with ⟨counter, encoding⟩ + simp only [bind_assoc, resolveSelectedLayerValuesList, hselection] + apply evalDist_bind_congr + intro resolvedOption hresolved + cases resolvedOption with + | none => + simp [publishDeferredChronologicalSignature, continueResolvedRunIsNone, + runResolvedFinishIsNone] + | some resolved => + rcases resolved with ⟨afterLayer, values⟩ + simpa only [pure_bind, bind_assoc] using + (evalDist_resolveDeferredLayerSchedule_continue_eq_selectedList parameter table + index ftsSecret randomness leaves ftsPath next layers + { context := afterLayer + remaining := result.remaining + value := + { result.value with + resolved := Function.update result.value.resolved lay + (some (counter, values.1, values.2)) } + table := table } + rfl (by + intro observed hnotMem + by_cases heq : observed = lay + · subst observed + simp [Function.update, hselection] + · simpa [Function.update, heq] using + hagrees observed (by simp [heq, hnotMem]))) + +set_option maxRecDepth 100000 in +theorem evalDist_runDeferredLayersAndPublish_continue_eq_selectionOnly + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (next : Option Signature → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (runDeferredLayersAndPublish parameter table ftsSecret randomness index leaves + ftsPath deferredLayerSchedule context fuel cache >>= + continueResolvedRunIsNone next) = + evalDist (runSelectionOnlyLayersAndPublish parameter table ftsSecret randomness index + leaves ftsPath context fuel cache >>= continueResolvedRunIsNone next) := by + unfold runDeferredLayersAndPublish runSelectionOnlyLayersAndPublish + rw [deferredLayerSchedule_eq_append, runDeferredLayerSchedule_append] + simp only [bind_assoc] + apply evalDist_bind_congr + intro selectedOption hselected + cases selectedOption with + | none => + rw [runDeferredLayerSchedule_none] + simp only [pure_bind] + rw [publishDeferredChronologicalSignature.eq_def, publishSelectedDeferredSignature] + | some selected => + have hinvariants := selectedLayersEnsured_of_mem_deferredLayerSelections parameter table + ftsSecret index context fuel cache selected hvalid hcompletable hselected + have hschedule := + evalDist_resolveDeferredLayerSchedule_continue_eq_selectedList parameter table index + ftsSecret randomness leaves ftsPath next [topLayer, middleLayer, bottomLayer] + selected hinvariants.1 (by + intro lay hnotMem + fin_cases lay <;> + simp [topLayer, middleLayer, bottomLayer, numLayers] at hnotMem) + simp only [deferredLayerResolutions] + rw [← bind_assoc, hschedule] + simp only [publishSelectedDeferredSignature] + rw [evalDist_runResolvedFromTable_then_continue selected.context selected.remaining + selected.table selected.value.cache + (publishSelectedChronologicalSignature ftsSecret randomness index leaves ftsPath + selected.value.selected) next, hinvariants.1] + exact evalDist_resolveSelectedLayerValuesList_then_runResolvedFinishIsNone table index + selected.value.selected selected.remaining + ((publishSelectedChronologicalSignature ftsSecret randomness index leaves ftsPath + selected.value.selected >>= next).run selected.value.cache) + [topLayer, middleLayer, bottomLayer] selected.context hinvariants.2.1 + hinvariants.2.2.1 (by + intro lay hlay counter encoding hselection + exact hinvariants.2.2.2 lay counter encoding hselection) + +theorem evalDist_runDeferredChronologicalLayersAndPublish_continue_eq_selectionOnly + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (next : Option Signature → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (runDeferredChronologicalLayersAndPublish parameter table ftsSecret randomness + index leaves ftsPath context fuel cache >>= continueResolvedRunIsNone next) = + evalDist (runSelectionOnlyLayersAndPublish parameter table ftsSecret randomness index + leaves ftsPath context fuel cache >>= continueResolvedRunIsNone next) := by + calc + _ = evalDist (runDeferredLayersAndPublish parameter table ftsSecret randomness index leaves + ftsPath deferredLayerSchedule context fuel cache >>= + continueResolvedRunIsNone next) := by + rw [evalDist_bind, evalDist_bind, + evalDist_runDeferredChronologicalLayersAndPublish_eq_deferred parameter table ftsSecret + randomness index leaves ftsPath context fuel cache] + _ = _ := evalDist_runDeferredLayersAndPublish_continue_eq_selectionOnly parameter table + ftsSecret randomness index leaves ftsPath context fuel cache next hvalid hcompletable + +set_option maxRecDepth 100000 in +theorem evalDist_runDeferredChronologicalSignAfterDigest_continue_eq_selectionOnly + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (next : Option Signature → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (runDeferredChronologicalSignAfterDigest parameter table ftsSecret randomness + index leaves context fuel cache >>= continueResolvedRunIsNone next) = + evalDist (runSelectionOnlySignAfterDigest parameter table ftsSecret randomness index + leaves context fuel cache >>= continueResolvedRunIsNone next) := by + unfold runDeferredChronologicalSignAfterDigest runSelectionOnlySignAfterDigest + simp only [bind_assoc] + apply evalDist_bind_congr + intro ftsOption hfts + cases ftsOption with + | none => simp [continueResolvedRunIsNone] + | some ftsResult => + have hftsInvariants := + valid_completable_of_mem_runResolvedFromTable_of_finalizationMaterializedCouples table + (simulateQ ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index))) + (finalizationMaterializedCouples_simulateQ ordinaryHashImpl + (finalizationMaterializedCouples_ordinaryHashImpl table) + (ftsOpen parameter index leaves (ftsSecret index))) + context fuel cache ftsResult hvalid hcompletable hfts + exact + evalDist_runDeferredChronologicalLayersAndPublish_continue_eq_selectionOnly parameter + table ftsSecret randomness index leaves ftsResult.value.1 ftsResult.context + ftsResult.remaining ftsResult.value.2 next hftsInvariants.1 hftsInvariants.2 + +noncomputable def runSelectionOnlySign + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + ProbComp (Option (ResolvedRunResult (Option Signature × SplitHashCache))) := do + let secretKey : SecretKey := + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ + let selected ← runResolvedFromTable context fuel table + ((simulateQ ordinaryRomImpl + (signDigestLoop digestAttemptLimit secretKey message)).run cache) + match selected with + | none => pure none + | some selected => + match selected.value.1 with + | none => pure (some ⟨selected.context, selected.remaining, + (none, selected.value.2), table⟩) + | some (randomness, index, leaves) => + runSelectionOnlySignAfterDigest parameter table ftsSecret randomness index leaves + selected.context selected.remaining selected.value.2 + +set_option maxRecDepth 100000 in +theorem evalDist_runDeferredChronologicalSign_continue_eq_selectionOnly + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (next : Option Signature → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (runDeferredChronologicalSign parameter root table ftsSecret message context fuel + cache >>= continueResolvedRunIsNone next) = + evalDist (runSelectionOnlySign parameter root table ftsSecret message context fuel cache >>= + continueResolvedRunIsNone next) := by + unfold runDeferredChronologicalSign runSelectionOnlySign + simp only [bind_assoc] + apply evalDist_bind_congr + intro selectedOption hselected + cases selectedOption with + | none => simp [continueResolvedRunIsNone] + | some selected => + cases hvalue : selected.value.1 with + | none => simp [hvalue, continueResolvedRunIsNone] + | some digestResult => + rcases digestResult with ⟨randomness, index, leaves⟩ + simp only [hvalue] + let secretKey : SecretKey := + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ + have hselectedInvariants := + valid_completable_of_mem_runResolvedFromTable_of_finalizationMaterializedCouples table + (simulateQ ordinaryRomImpl + (signDigestLoop digestAttemptLimit secretKey message)) + (finalizationMaterializedCouples_simulateQ ordinaryRomImpl + (finalizationMaterializedCouples_ordinaryRomImpl table) + (signDigestLoop digestAttemptLimit secretKey message)) + context fuel cache selected hvalid hcompletable (by + simpa only [secretKey] using hselected) + exact evalDist_runDeferredChronologicalSignAfterDigest_continue_eq_selectionOnly + parameter table ftsSecret randomness index leaves selected.context + selected.remaining selected.value.2 next hselectedInvariants.1 + hselectedInvariants.2 + +noncomputable def maskedSelectionOnlyLayersAndPublish + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature) := do + let layers ← sequenceFin fun lay : Layer => + maskedSignLayer parameter ftsSecret index lay + publishSelectedChronologicalSignature ftsSecret randomness index leaves ftsPath layers + +noncomputable def maskedScheduledSelectionOnlyLayersAndPublish + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature) := do + let top ← maskedSignLayer parameter ftsSecret index topLayer + let middle ← maskedSignLayer parameter ftsSecret index middleLayer + let bottom ← maskedSignLayer parameter ftsSecret index bottomLayer + let selected := Function.update + (Function.update + (Function.update (fun _ : Layer => none) topLayer top) + middleLayer middle) + bottomLayer bottom + publishSelectedChronologicalSignature ftsSecret randomness index leaves ftsPath selected + +set_option maxRecDepth 100000 in +theorem evalDist_runSelectionOnlyLayersAndPublish_eq_sequence + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + evalDist (runSelectionOnlyLayersAndPublish parameter table ftsSecret randomness index + leaves ftsPath context fuel cache) = + evalDist (runResolvedFromTable context fuel table + ((maskedScheduledSelectionOnlyLayersAndPublish parameter ftsSecret randomness index + leaves ftsPath).run cache)) := by + unfold runSelectionOnlyLayersAndPublish maskedScheduledSelectionOnlyLayersAndPublish + simp only [deferredLayerSelections, List.map_cons, List.map_nil, + runDeferredLayerSchedule, runDeferredLayerOperation, selectDeferredLayer, + bind_assoc, StateT.run_bind, runResolvedFromTable_bind] + apply evalDist_bind_congr + intro topOption htop + cases topOption with + | none => simp [publishSelectedDeferredSignature] + | some topResult => + have htopCore := resolvedCore_of_mem_runResolvedFromTable + ((maskedSignLayer parameter ftsSecret index topLayer).run + (emptyDeferredLayerStore cache).cache) + context fuel table topResult hconsistent hstarts htop + simp only [pure_bind] + rw [htopCore.1] + simp only [bind_assoc] + apply evalDist_bind_congr + intro middleOption hmiddle + cases middleOption with + | none => simp [publishSelectedDeferredSignature] + | some middleResult => + have hmiddleCore := resolvedCore_of_mem_runResolvedFromTable + ((maskedSignLayer parameter ftsSecret index middleLayer).run topResult.value.2) + topResult.context topResult.remaining table middleResult htopCore.2.1 + htopCore.2.2 (by simpa using hmiddle) + simp only [pure_bind] + rw [hmiddleCore.1] + simp only [bind_assoc] + apply evalDist_bind_congr + intro bottomOption hbottom + cases bottomOption with + | none => simp [publishSelectedDeferredSignature] + | some bottomResult => + have hbottomCore := resolvedCore_of_mem_runResolvedFromTable + ((maskedSignLayer parameter ftsSecret index bottomLayer).run middleResult.value.2) + middleResult.context middleResult.remaining table bottomResult + hmiddleCore.2.1 hmiddleCore.2.2 (by simpa using hbottom) + simp only [pure_bind, publishSelectedDeferredSignature] + rw [hbottomCore.1] + congr 2 + +theorem maskedScheduledSelectionOnlyLayersAndPublish_eq + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) : + maskedScheduledSelectionOnlyLayersAndPublish parameter ftsSecret randomness index leaves + ftsPath = + maskedSelectionOnlyLayersAndPublish parameter ftsSecret randomness index leaves + ftsPath := by + unfold maskedScheduledSelectionOnlyLayersAndPublish maskedSelectionOnlyLayersAndPublish + simp only [sequenceFin, numLayers, topLayer, middleLayer, bottomLayer, bind_assoc, + pure_bind] + apply bind_congr + intro top + apply bind_congr + intro middle + apply bind_congr + intro bottom + congr 1 + funext lay + fin_cases lay <;> + simp [Function.update, numLayers] + all_goals rfl + +set_option maxRecDepth 100000 in +theorem evalDist_runSelectionOnlyLayersAndPublish_eq_resolved + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + evalDist (runSelectionOnlyLayersAndPublish parameter table ftsSecret randomness index + leaves ftsPath context fuel cache) = + evalDist (runResolvedFromTable context fuel table + ((maskedSelectionOnlyLayersAndPublish parameter ftsSecret randomness index leaves + ftsPath).run cache)) := by + calc + _ = evalDist (runResolvedFromTable context fuel table + ((maskedScheduledSelectionOnlyLayersAndPublish parameter ftsSecret randomness index + leaves ftsPath).run cache)) := + evalDist_runSelectionOnlyLayersAndPublish_eq_sequence parameter table ftsSecret + randomness index leaves ftsPath context fuel cache hconsistent hstarts + _ = _ := by + rw [maskedScheduledSelectionOnlyLayersAndPublish_eq] + +theorem maskedSignAfterDigest_eq_selectionOnly + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + maskedSignAfterDigest parameter ftsSecret randomness index leaves = (do + let ftsPath ← simulateQ ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index)) + maskedSelectionOnlyLayersAndPublish parameter ftsSecret randomness index leaves + ftsPath) := by + unfold maskedSignAfterDigest maskedSelectionOnlyLayersAndPublish + publishSelectedChronologicalSignature + rfl + +set_option maxRecDepth 100000 in +theorem evalDist_runSelectionOnlySignAfterDigest_eq_resolved + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + evalDist (runSelectionOnlySignAfterDigest parameter table ftsSecret randomness index leaves + context fuel cache) = + evalDist (runResolvedFromTable context fuel table + ((maskedSignAfterDigest parameter ftsSecret randomness index leaves).run cache)) := by + rw [maskedSignAfterDigest_eq_selectionOnly] + unfold runSelectionOnlySignAfterDigest + rw [StateT.run_bind, runResolvedFromTable_bind] + apply evalDist_bind_congr + intro ftsOption hfts + cases ftsOption with + | none => rfl + | some ftsResult => + have hftsCore := resolvedCore_of_mem_runResolvedFromTable + ((simulateQ ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index))).run cache) + context fuel table ftsResult hconsistent hstarts hfts + simp only + rw [hftsCore.1] + exact evalDist_runSelectionOnlyLayersAndPublish_eq_resolved parameter table ftsSecret + randomness index leaves ftsResult.value.1 ftsResult.context ftsResult.remaining + ftsResult.value.2 hftsCore.2.1 hftsCore.2.2 + +set_option maxRecDepth 100000 in +theorem evalDist_runSelectionOnlySign_eq_resolved + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + evalDist (runSelectionOnlySign parameter root table ftsSecret message context fuel cache) = + evalDist (runResolvedFromTable context fuel table + ((maskedSign parameter root ftsSecret message).run cache)) := by + unfold runSelectionOnlySign maskedSign + rw [StateT.run_bind, runResolvedFromTable_bind] + apply evalDist_bind_congr + intro selectedOption hselected + cases selectedOption with + | none => rfl + | some selected => + have hselectedCore := resolvedCore_of_mem_runResolvedFromTable + ((simulateQ ordinaryRomImpl + (signDigestLoop digestAttemptLimit + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ message)).run cache) + context fuel table selected hconsistent hstarts hselected + cases hvalue : selected.value.1 with + | none => + simp only [hvalue] + simp [runResolvedFromTable, hselectedCore.1] + | some digestResult => + rcases digestResult with ⟨randomness, selectedIndex, leaves⟩ + simp only [hvalue] + rw [hselectedCore.1] + exact evalDist_runSelectionOnlySignAfterDigest_eq_resolved parameter table ftsSecret + randomness selectedIndex leaves selected.context selected.remaining + selected.value.2 hselectedCore.2.1 hselectedCore.2.2 + +set_option maxRecDepth 100000 in +theorem evalDist_runDeferredChronologicalSign_continue_eq_maskedSign + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (next : Option Signature → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (runDeferredChronologicalSign parameter root table ftsSecret message context fuel + cache >>= continueResolvedRunIsNone next) = + evalDist (runResolvedFinishIsNone context fuel table + ((maskedSign parameter root ftsSecret message >>= next).run cache)) := by + calc + _ = evalDist (runSelectionOnlySign parameter root table ftsSecret message context fuel cache >>= + continueResolvedRunIsNone next) := + evalDist_runDeferredChronologicalSign_continue_eq_selectionOnly parameter root table + ftsSecret message context fuel cache next hvalid hcompletable + _ = evalDist (runResolvedFromTable context fuel table + ((maskedSign parameter root ftsSecret message).run cache) >>= + continueResolvedRunIsNone next) := by + rw [evalDist_bind, evalDist_bind, + evalDist_runSelectionOnlySign_eq_resolved parameter root table ftsSecret message context + fuel cache hvalid.valuesConsistent + (startTableAgrees_of_deferredCompletable hcompletable)] + _ = _ := evalDist_runResolvedFromTable_then_continue context fuel table cache + (maskedSign parameter root ftsSecret message) next + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateSelection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateSelection.lean new file mode 100644 index 00000000..ee938247 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateSelection.lean @@ -0,0 +1,1625 @@ +import SphincsSecurity.Proof.OtsProbeResolvedPrivateInterpreter + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +set_option maxRecDepth 100000 in +theorem evalDist_finishResolvedRunIsNone_eq_of_finalizationContextEq + (table : OtsSecretIndex → HashOutput) (left right : DeferredContext) + (fuel : Nat) (value : α) + (hcontext : FinalizationContextEq table (some left) (some right)) : + evalDist (finishResolvedRunIsNone + (some (ResolvedRunResult.mk left fuel value table))) = + evalDist (finishResolvedRunIsNone + (some (ResolvedRunResult.mk right fuel value table))) := by + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hrightCompletable : DeferredCompletable table right := by + rcases hleftCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, (hview.deferredCompletion_iff completion).mp hcompletion⟩ + rw [finishResolvedRunIsNone_some_eq_finalize _ hleftCompletable, + finishResolvedRunIsNone_some_eq_finalize _ hrightCompletable] + exact evalDist_map_isNone_finalizeResolvedCoordinates_congr_covered table + left.state.coordinates.toList right.state.coordinates.toList left right hview + left.state.coordinates.nodup_toList right.state.coordinates.nodup_toList + (pendingCovered_coordinates_toList left) (pendingCovered_coordinates_toList right) + +set_option maxRecDepth 100000 in +theorem evalDist_runResolvedFinishIsNone_eq_of_finalizationSynchronized + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (left right : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hvalues : left.state.values = right.state.values) + (hrevealed : left.state.revealed = right.state.revealed) : + evalDist (runResolvedFinishIsNone left fuel table computation) = + evalDist (runResolvedFinishIsNone right fuel table computation) := by + induction computation using OracleComp.inductionOn generalizing left right fuel with + | pure value => + unfold runResolvedFinishIsNone + simp only [runResolvedFromTable, pure_bind] + exact evalDist_finishResolvedRunIsNone_eq_of_finalizationContextEq table left right + fuel value hcontext + | query_bind query next ih => + cases query with + | uniform n => + unfold runResolvedFinishIsNone + simp only [runResolvedFromTable_uniform_query_bind, bind_assoc] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + exact ih output left right fuel hcontext hvalues hrevealed + | hashOutput => + unfold runResolvedFinishIsNone + simp only [runResolvedFromTable_hashOutput_query_bind, bind_assoc] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + exact ih output left right fuel hcontext hvalues hrevealed + | ensure coordinate => + unfold runResolvedFinishIsNone + simp only [runResolvedFromTable_ensure_query_bind] + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + apply ih () + · exact ⟨hview.ensure coordinate, hleftValid.ensure coordinate, + hrightValid.ensure coordinate, hleftCompletable.ensure coordinate⟩ + · exact hvalues + · exact hrevealed + | peek coordinate => + unfold runResolvedFinishIsNone + simp only [runResolvedFromTable_peek_query_bind] + rw [hvalues] + exact ih (right.state.values coordinate) left right fuel hcontext hvalues hrevealed + | publish coordinate => + unfold runResolvedFinishIsNone + simp only [runResolvedFromTable_publish_query_bind] + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + apply ih () + · exact ⟨hview.publish coordinate, hleftValid.publish coordinate, + hrightValid.publish coordinate, hleftCompletable.publish coordinate⟩ + · exact hvalues + · simpa [LazyRevealProbe.State.publish] using congrArg (insert coordinate) hrevealed + | probe coordinate candidate => + unfold runResolvedFinishIsNone + simp only [runResolvedFromTable_probe_query_bind] + cases fuel with + | zero => rfl + | succ remaining => + by_cases hleftRevealed : coordinate ∈ left.state.revealed + · have hrightRevealed : coordinate ∈ right.state.revealed := by + rw [← hrevealed] + exact hleftRevealed + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + exact ih () left right remaining hcontext hvalues hrevealed + · have hrightRevealed : coordinate ∉ right.state.revealed := by + rwa [← hrevealed] + simp only [hleftRevealed, hrightRevealed, ↓reduceIte] + let left' : DeferredContext := + { left with state := left.state.addPending coordinate candidate } + let right' : DeferredContext := + { right with state := right.state.addPending coordinate candidate } + have hcompletableIff : DeferredCompletable table left' ↔ + DeferredCompletable table right' := by + exact deferredCompletable_addPending_iff_of_finalizationViewEq + hcontext.1 coordinate candidate + by_cases hleftCompletable : DeferredCompletable table left' + · have hrightCompletable : DeferredCompletable table right' := + hcompletableIff.mp hleftCompletable + apply ih () left' right' remaining + · exact ⟨hcontext.1.addPending_of_completable coordinate candidate + hleftCompletable hrightCompletable, + hcontext.2.1.addPending_of_completable coordinate candidate + hleftCompletable, + hcontext.2.2.1.addPending_of_completable coordinate candidate + hrightCompletable, + hleftCompletable⟩ + · exact hvalues + · exact hrevealed + · have hrightCompletable : ¬DeferredCompletable table right' := by + rwa [← hcompletableIff] + calc + _ = evalDist (pure true : ProbComp Bool) := + evalDist_runResolvedFinishIsNone_eq_true_of_not_completable + left' remaining table (next ()) hcontext.2.1.1 hcontext.1.leftStarts + hleftCompletable + _ = evalDist (runResolvedFinishIsNone right' remaining table + (next ())) := + (evalDist_runResolvedFinishIsNone_eq_true_of_not_completable + right' remaining table (next ()) hcontext.2.2.1.1 hcontext.1.rightStarts + hrightCompletable).symm + | reveal coordinate => + unfold runResolvedFinishIsNone + simp_rw [runResolvedFromTable_reveal_query_bind] + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + simp only [bind_assoc] + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hresolved := relTriple_resolveDeferredChainStart_of_finalizationViewEq + table index left right hview hleftValid hrightValid hleftCompletable + have hresolvedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolved + (fun result => result ∈ support + (pure (resolveDeferredChainStart table index left) : + ProbComp (Option DeferredResolution))) + (fun result hresult => hresult) + have hresolvedBoth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support + hresolvedLeft + apply evalDist_eq_of_relTriple_eqRel + apply relTriple_bind hresolvedBoth + intro leftResolved rightResolved hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResolved with + | none => + cases rightResolved with + | none => simp [EqRel, finishResolvedRunIsNone, finishResolvedRun] + | some rightResolved => simp [FinalizationResolutionEq] at hrelation + | some leftResolved => + cases rightResolved with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResolved => + have hleftResult : + resolveDeferredChainStart table index left = some leftResolved := by + simpa using hleftSupport.symm + have hrightResult : + resolveDeferredChainStart table index right = some rightResolved := by + simpa using hrightSupport.symm + have hleftMaterializedCompletable := + hleftCompletable.materializeResolvedChainStart hview.leftStarts index + leftResolved hleftResult + have hrightCompletable : DeferredCompletable table right := by + rcases hleftCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, + (hview.deferredCompletion_iff completion).mp hcompletion⟩ + have hrightMaterializedCompletable := + hrightCompletable.materializeResolvedChainStart hview.rightStarts index + rightResolved hrightResult + have hleftMaterializedView := + finalizationViewEq_materializeResolvedChainStart index leftResolved + hleftValid hview.leftStarts hleftResult + hleftMaterializedCompletable + have hrightMaterializedView := + finalizationViewEq_materializeResolvedChainStart index rightResolved + hrightValid hview.rightStarts hrightResult + hrightMaterializedCompletable + have hleftMaterializedValid : + (materializeResolvedChainStart left index leftResolved).Valid := by + unfold materializeResolvedChainStart + rw [resolveDeferredChainStart_deferred_values_eq table index left + leftResolved hleftResult] + exact hleftValid.materialize_chainStart lay tree leafIdx chainIdx + leftResolved.output + have hrightMaterializedValid : + (materializeResolvedChainStart right index rightResolved).Valid := by + unfold materializeResolvedChainStart + rw [resolveDeferredChainStart_deferred_values_eq table index right + rightResolved hrightResult] + exact hrightValid.materialize_chainStart lay tree leafIdx chainIdx + rightResolved.output + have hnext := ih leftResolved.output + (materializeResolvedChainStart left index leftResolved) + (materializeResolvedChainStart right index rightResolved) fuel + ⟨hleftMaterializedView.trans + (hrelation.2.1.trans hrightMaterializedView.symm), + hleftMaterializedValid, hrightMaterializedValid, + hleftMaterializedCompletable⟩ + (by + change Function.update left.state.values index.coordinate + (some leftResolved.output) = + Function.update right.state.values index.coordinate + (some rightResolved.output) + rw [hrelation.1, hvalues]) + (by + simpa [materializeResolvedChainStart, + LazyRevealProbe.State.materialize] using hrevealed) + apply relTriple_eqRel_of_evalDist_eq + simpa only [runResolvedFinishIsNone, materializeResolvedChainStart, + index, OtsSecretIndex.coordinate, hrelation.1] using hnext + | position position => + simp only [bind_assoc] + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hresolved := relTriple_resolveDeferredReveal_of_finalizationViewEq table + position left right hview hleftValid hrightValid hleftCompletable + have hresolvedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolved + (fun result => result ∈ support + (resolveDeferredReveal table position left)) + (fun result hresult => hresult) + have hresolvedBoth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support + hresolvedLeft + apply evalDist_eq_of_relTriple_eqRel + apply relTriple_bind hresolvedBoth + intro leftResolved rightResolved hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResolved with + | none => + cases rightResolved with + | none => simp [EqRel, finishResolvedRunIsNone, finishResolvedRun] + | some rightResolved => simp [FinalizationResolutionEq] at hrelation + | some leftResolved => + cases rightResolved with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResolved => + have hleftMaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition left position leftResolved) := by + rcases hrelation.2.2.2.2 with ⟨completion, hcompletion⟩ + exact ⟨completion, + (deferredCompletion_materializeResolvedReveal_iff position + leftResolved hleftValid hview.leftStarts hleftSupport).mpr + hcompletion⟩ + have hrightRawCompletable : + DeferredCompletable table rightResolved.toDeferredContext := by + rcases hrelation.2.2.2.2 with ⟨completion, hcompletion⟩ + exact ⟨completion, + (hrelation.2.1.deferredCompletion_iff completion).mp hcompletion⟩ + have hrightMaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition right position rightResolved) := by + rcases hrightRawCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, + (deferredCompletion_materializeResolvedReveal_iff position + rightResolved hrightValid hview.rightStarts hrightSupport).mpr + hcompletion⟩ + have hleftMaterializedView := + finalizationViewEq_materializeResolvedReveal position leftResolved + hleftValid hview.leftStarts hleftSupport + hleftMaterializedCompletable + have hrightMaterializedView := + finalizationViewEq_materializeResolvedReveal position rightResolved + hrightValid hview.rightStarts hrightSupport + hrightMaterializedCompletable + have hleftResultValid := hleftValid.of_resolveDeferredReveal table + position leftResolved hleftSupport + have hrightResultValid := hrightValid.of_resolveDeferredReveal table + position rightResolved hrightSupport + have hleftStateValues := + resolveDeferredReveal_preserves_state_values table position left + leftResolved hleftSupport + have hrightStateValues := + resolveDeferredReveal_preserves_state_values table position right + rightResolved hrightSupport + have hleftResolvedValue := resolveDeferredReveal_resolves table position + left leftResolved hleftSupport + have hrightResolvedValue := resolveDeferredReveal_resolves table position + right rightResolved hrightSupport + have hleftMaterializedValid : + (materializeResolvedPosition left position leftResolved).Valid := + hleftValid.materializeResolvedPosition_of position leftResolved + hleftResultValid hleftStateValues hleftResolvedValue + have hrightMaterializedValid : + (materializeResolvedPosition right position rightResolved).Valid := + hrightValid.materializeResolvedPosition_of position rightResolved + hrightResultValid hrightStateValues hrightResolvedValue + have hnext := ih leftResolved.output + (materializeResolvedPosition left position leftResolved) + (materializeResolvedPosition right position rightResolved) fuel + ⟨hleftMaterializedView.trans + (hrelation.2.1.trans hrightMaterializedView.symm), + hleftMaterializedValid, hrightMaterializedValid, + hleftMaterializedCompletable⟩ + (by + change Function.update left.state.values (.position position) + (some leftResolved.output) = + Function.update right.state.values (.position position) + (some rightResolved.output) + rw [hrelation.1, hvalues]) + (by + simpa [materializeResolvedPosition, + LazyRevealProbe.State.materialize] using hrevealed) + apply relTriple_eqRel_of_evalDist_eq + simpa only [runResolvedFinishIsNone, materializeResolvedPosition, + hrelation.1] using hnext + +theorem finalizationContextEq_resolveDeferredChainStart_original + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) (result : DeferredResolution) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hresult : resolveDeferredChainStart table index context = some result) : + FinalizationContextEq table (some result.toDeferredContext) (some context) := by + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hstateValues := resolveDeferredChainStart_state_values_eq table index context result + hresult + have hpositionValues := resolveDeferredChainStart_positionValue_eq table index context result + hresult + have hresultValid := hvalid.of_resolveDeferredChainStart table index result hresult + have hresultCompletable := hcompletable.of_resolveDeferredChainStart index result hresult + refine ⟨finalizationViewEq_of_deferredCompletion_iff hresultValid hvalid + (hstarts.of_state_values_eq hstateValues) hstarts ?_ hresultCompletable ?_, + hresultValid, hvalid, hresultCompletable⟩ + · funext coordinate + cases coordinate with + | chainStart => rfl + | position position => + exact congrFun hpositionValues position + · intro completion + exact deferredCompletion_resolveDeferredChainStart_iff index result hstarts hresult + completion + +theorem evalDist_resolveDeferredChainStart_then_runResolvedFinishIsNone + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (match resolveDeferredChainStart table index context with + | none => pure true + | some resolved => + runResolvedFinishIsNone resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedFinishIsNone context fuel table computation) := by + let result : DeferredResolution := + ⟨{ state := context.state.clearPending index.coordinate, values := context.values }, + table index⟩ + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hclean := hcompletable.not_hitAt_chainStart index + have hresult : resolveDeferredChainStart table index context = some result := by + cases hstate : context.state.values index.coordinate with + | some output => + have houtput := hstarts index output hstate + simp [resolveDeferredChainStart, hstate, houtput, hclean, result] + | none => simp [resolveDeferredChainStart, hstate, hclean, result] + rw [hresult] + exact evalDist_runResolvedFinishIsNone_eq_of_finalizationSynchronized computation + result.toDeferredContext context fuel table + (finalizationContextEq_resolveDeferredChainStart_original table index context result + hvalid hcompletable hresult) + (resolveDeferredChainStart_state_values_eq table index context result hresult) + (by + rw [resolveDeferredChainStart_state_eq_clearPending table index context result hresult] + rfl) + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredChainPrefix_then_runResolvedFinishIsNone + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α), + context.Valid → DeferredCompletable table context → + (∀ step : ChainStep, step.val < steps → + Coordinate.position (.chain lay tree leafIdx chainIdx step) ∈ + context.state.ensured) → + evalDist (do + let resolved ← resolveDeferredChainPrefix table lay tree leafIdx chainIdx + steps hsteps context + match resolved with + | none => pure true + | some resolved => + runResolvedFinishIsNone resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedFinishIsNone context fuel table computation) + | 0, hsteps, context, fuel, computation, hvalid, hcompletable, _hensured => by + simp only [resolveDeferredChainPrefix, pure_bind] + exact evalDist_resolveDeferredChainStart_then_runResolvedFinishIsNone table + ⟨lay, tree, leafIdx, chainIdx⟩ context fuel computation hvalid hcompletable + | steps + 1, hsteps, context, fuel, computation, hvalid, hcompletable, hensured => by + rw [resolveDeferredChainPrefix] + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps + (by omega) context >>= fun previous => + match previous with + | none => pure true + | some previous => + runResolvedFinishIsNone previous.toDeferredContext fuel table computation) := by + apply evalDist_bind_congr + intro previous hprevious + cases previous with + | none => rfl + | some previous => + let position : Position := + .chain lay tree leafIdx chainIdx ⟨steps, by omega⟩ + have hpreviousValid := hvalid.of_resolveDeferredChainPrefix table lay tree + leafIdx chainIdx steps (by omega) previous hprevious + have hpreviousCompletable := + hcompletable.of_resolveDeferredChainPrefix hvalid hprevious + have hprivate := privateStateAgrees_resolveDeferredChainPrefix table lay tree + leafIdx chainIdx steps (by omega) context previous hprevious + have hpositionEnsured : Coordinate.position position ∈ + previous.state.ensured := by + rw [hprivate.2.2] + exact hensured ⟨steps, by omega⟩ (by simp) + exact evalDist_resolveDeferredPositionValue_then_runResolvedFinishIsNone + position computation previous.toDeferredContext fuel table hpreviousValid + hpreviousCompletable hpositionEnsured + _ = _ := + evalDist_resolveDeferredChainPrefix_then_runResolvedFinishIsNone table lay tree + leafIdx chainIdx steps (by omega) context fuel computation hvalid hcompletable + (fun step hstep => hensured step (by omega)) + +def FullChainEnsured (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (context : DeferredContext) : Prop := + ∀ step : ChainStep, + Coordinate.position (.chain lay tree leafIdx chainIdx step) ∈ context.state.ensured + +def OtsLeafEnsured (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (context : DeferredContext) : Prop := + (∀ chainIdx : ChainIndex, FullChainEnsured lay tree leafIdx chainIdx context) ∧ + Coordinate.position (.leaf lay tree leafIdx) ∈ context.state.ensured + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredChains_then_runResolvedFinishIsNone + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + ∀ (chains : List ChainIndex) (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α), + context.Valid → DeferredCompletable table context → + (∀ chainIdx ∈ chains, FullChainEnsured lay tree leafIdx chainIdx context) → + evalDist (do + let resolved ← resolveDeferredChains table lay tree leafIdx chains context + match resolved with + | none => pure true + | some resolved => runResolvedFinishIsNone resolved fuel table computation) = + evalDist (runResolvedFinishIsNone context fuel table computation) + | [], context, fuel, computation, _hvalid, _hcompletable, _hensured => by + simp [resolveDeferredChains] + | chainIdx :: remaining, context, fuel, computation, hvalid, hcompletable, + hensured => by + rw [resolveDeferredChains] + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredChainPrefix table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context >>= fun resolved => + match resolved with + | none => pure true + | some resolved => + runResolvedFinishIsNone resolved.toDeferredContext fuel table computation) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => rfl + | some resolved => + have hresolvedValid := hvalid.of_resolveDeferredChainPrefix table lay tree + leafIdx chainIdx (chainLength - 1) (by omega) resolved hresolved + have hresolvedCompletable := + hcompletable.of_resolveDeferredChainPrefix hvalid hresolved + have hprivate := privateStateAgrees_resolveDeferredChainPrefix table lay tree + leafIdx chainIdx (chainLength - 1) (by omega) context resolved hresolved + apply evalDist_resolveDeferredChains_then_runResolvedFinishIsNone table lay tree + leafIdx remaining resolved.toDeferredContext fuel computation hresolvedValid + hresolvedCompletable + intro other hother step + rw [hprivate.2.2] + exact hensured other (by simp [hother]) step + _ = _ := + evalDist_resolveDeferredChainPrefix_then_runResolvedFinishIsNone table lay tree + leafIdx chainIdx (chainLength - 1) (by omega) context fuel computation hvalid + hcompletable (fun step _ => hensured chainIdx (by simp) step) + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredOtsLeaf_then_runResolvedFinishIsNone + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : OtsLeafEnsured lay tree leafIdx context) : + evalDist (do + let resolved ← resolveDeferredOtsLeaf table lay tree leafIdx context + match resolved with + | none => pure true + | some resolved => + runResolvedFinishIsNone resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedFinishIsNone context fuel table computation) := by + rw [resolveDeferredOtsLeaf] + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) context >>= fun chains => + match chains with + | none => pure true + | some chains => runResolvedFinishIsNone chains fuel table computation) := by + apply evalDist_bind_congr + intro chains hchains + cases chains with + | none => rfl + | some chains => + have hchainsValid := hvalid.of_resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) chains hchains + have hchainsCompletable := hcompletable.of_resolveDeferredChains hvalid hchains + have hprivate := privateStateAgrees_resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) context chains hchains + have hleafEnsured : Coordinate.position (.leaf lay tree leafIdx) ∈ + chains.state.ensured := by + rw [hprivate.2.2] + exact hensured.2 + exact evalDist_resolveDeferredPositionValue_then_runResolvedFinishIsNone + (.leaf lay tree leafIdx) computation chains fuel table hchainsValid + hchainsCompletable hleafEnsured + _ = _ := evalDist_resolveDeferredChains_then_runResolvedFinishIsNone table lay tree + leafIdx (List.ofFn fun chainIdx : ChainIndex => chainIdx) context fuel computation + hvalid hcompletable (by + intro chainIdx _hmem + exact hensured.1 chainIdx) + +def TreeNodeEnsured (lay : Layer) (tree : TreeIndex) : + Nat → Nat → DeferredContext → Prop + | 0, nodeIdx, context => OtsLeafEnsured lay tree (leafOfNat nodeIdx) context + | level + 1, nodeIdx, context => + TreeNodeEnsured lay tree level (2 * nodeIdx) context ∧ + TreeNodeEnsured lay tree level (2 * nodeIdx + 1) context ∧ + ∃ hlevel : level < maxLayerHeight, + Coordinate.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx)) ∈ + context.state.ensured + +theorem treeNodeEnsured_congr_ensured + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) + (left right : DeferredContext) + (hensured : left.state.ensured = right.state.ensured) : + TreeNodeEnsured lay tree level nodeIdx left ↔ + TreeNodeEnsured lay tree level nodeIdx right := by + induction level generalizing nodeIdx with + | zero => simp [TreeNodeEnsured, OtsLeafEnsured, FullChainEnsured, hensured] + | succ level ih => + simp only [TreeNodeEnsured] + rw [ih (2 * nodeIdx), ih (2 * nodeIdx + 1)] + simp [hensured] + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredTreeNode_then_runResolvedFinishIsNone + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α), + context.Valid → DeferredCompletable table context → + TreeNodeEnsured lay tree level nodeIdx context → + evalDist (do + let resolved ← resolveDeferredTreeNode table lay tree level nodeIdx hlevel context + match resolved with + | none => pure true + | some resolved => + runResolvedFinishIsNone resolved.toDeferredContext fuel table computation) = + evalDist (runResolvedFinishIsNone context fuel table computation) + | 0, nodeIdx, hlevel, context, fuel, computation, hvalid, hcompletable, hensured => + evalDist_resolveDeferredOtsLeaf_then_runResolvedFinishIsNone table lay tree + (leafOfNat nodeIdx) context fuel computation hvalid hcompletable hensured + | level + 1, nodeIdx, hlevel, context, fuel, computation, hvalid, hcompletable, + hensured => by + rw [resolveDeferredTreeNode] + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredTreeNode table lay tree level (2 * nodeIdx) + (by omega) context >>= fun leftResult => + match leftResult with + | none => pure true + | some leftResult => + runResolvedFinishIsNone leftResult.toDeferredContext fuel table computation) := by + apply evalDist_bind_congr + intro leftResult hleft + cases leftResult with + | none => rfl + | some leftResult => + have hleftValid := hvalid.of_resolveDeferredTreeNode table lay tree level + (2 * nodeIdx) (by omega) leftResult hleft + have hleftCompletable := + hcompletable.of_resolveDeferredTreeNode hvalid hleft + have hleftPrivate := privateStateAgrees_resolveDeferredTreeNode table lay tree + level (2 * nodeIdx) (by omega) context leftResult hleft + have hrightEnsured : TreeNodeEnsured lay tree level (2 * nodeIdx + 1) + leftResult.toDeferredContext := by + exact (treeNodeEnsured_congr_ensured lay tree level (2 * nodeIdx + 1) + context leftResult.toDeferredContext hleftPrivate.2.2.symm).mp + hensured.2.1 + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredTreeNode table lay tree level + (2 * nodeIdx + 1) (by omega) leftResult.toDeferredContext >>= + fun rightResult => + match rightResult with + | none => pure true + | some rightResult => + runResolvedFinishIsNone rightResult.toDeferredContext fuel table + computation) := by + apply evalDist_bind_congr + intro rightResult hright + cases rightResult with + | none => rfl + | some rightResult => + have hrightValid := hleftValid.of_resolveDeferredTreeNode table lay tree + level (2 * nodeIdx + 1) (by omega) rightResult hright + have hrightCompletable := + hleftCompletable.of_resolveDeferredTreeNode hleftValid hright + have hrightPrivate := privateStateAgrees_resolveDeferredTreeNode table lay + tree level (2 * nodeIdx + 1) (by omega) + leftResult.toDeferredContext rightResult hright + obtain ⟨hnodeLevel, hnodeBase⟩ := hensured.2.2 + have hnodeEnsured : Coordinate.position + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) ∈ + rightResult.state.ensured := by + rw [hrightPrivate.2.2, hleftPrivate.2.2] + simpa using hnodeBase + exact + evalDist_resolveDeferredPositionValue_then_runResolvedFinishIsNone + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) computation + rightResult.toDeferredContext fuel table hrightValid + hrightCompletable hnodeEnsured + _ = _ := + evalDist_resolveDeferredTreeNode_then_runResolvedFinishIsNone table lay tree + level (2 * nodeIdx + 1) (by omega) leftResult.toDeferredContext fuel + computation hleftValid hleftCompletable hrightEnsured + _ = _ := + evalDist_resolveDeferredTreeNode_then_runResolvedFinishIsNone table lay tree level + (2 * nodeIdx) (by omega) context fuel computation hvalid hcompletable hensured.1 + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredSelectedChainFamily_then_runResolvedFinishIsNone + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + ∀ {n : Nat} (family : Fin n → ChainIndex) (digits : Fin n → Digit) + (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α), + context.Valid → DeferredCompletable table context → + (∀ index (step : ChainStep), step.val < (digits index).val → + Coordinate.position (.chain lay tree leafIdx (family index) step) ∈ + context.state.ensured) → + evalDist (do + let resolved ← resolveDeferredSelectedChainFamily table lay tree leafIdx + family digits context + match resolved with + | none => pure true + | some (finalContext, _) => + runResolvedFinishIsNone finalContext fuel table computation) = + evalDist (runResolvedFinishIsNone context fuel table computation) + | 0, family, digits, context, fuel, computation, _hvalid, _hcompletable, + _hensured => by + simp [resolveDeferredSelectedChainFamily] + | n + 1, family, digits, context, fuel, computation, hvalid, hcompletable, + hensured => by + rw [resolveDeferredSelectedChainFamily] + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredChainPrefix table lay tree leafIdx (family 0) + (digits 0).val (by have := (digits 0).isLt; omega) context >>= + fun headOption => + match headOption with + | none => pure true + | some head => + runResolvedFinishIsNone head.toDeferredContext fuel table computation) := by + apply evalDist_bind_congr + intro headOption hhead + cases headOption with + | none => rfl + | some head => + have hheadValid := hvalid.of_resolveDeferredChainPrefix table lay tree leafIdx + (family 0) (digits 0).val (by have := (digits 0).isLt; omega) head hhead + have hheadCompletable := + hcompletable.of_resolveDeferredChainPrefix hvalid hhead + have hprivate := privateStateAgrees_resolveDeferredChainPrefix table lay tree + leafIdx (family 0) (digits 0).val + (by have := (digits 0).isLt; omega) context head hhead + have htail := + evalDist_resolveDeferredSelectedChainFamily_then_runResolvedFinishIsNone + table lay tree leafIdx (fun index : Fin n => family index.succ) + (fun index : Fin n => digits index.succ) head.toDeferredContext fuel + computation hheadValid hheadCompletable (by + intro index step hstep + rw [hprivate.2.2] + exact hensured index.succ step hstep) + calc + _ = evalDist (do + let tail ← resolveDeferredSelectedChainFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) + (fun index : Fin n => digits index.succ) head.toDeferredContext + match tail with + | none => pure true + | some (finalContext, _) => + runResolvedFinishIsNone finalContext fuel table computation) := by + apply congrArg evalDist + simp only [bind_assoc] + apply bind_congr + intro tailOption + cases tailOption <;> simp + _ = _ := htail + _ = _ := + evalDist_resolveDeferredChainPrefix_then_runResolvedFinishIsNone table lay tree + leafIdx (family 0) (digits 0).val + (by have := (digits 0).isLt; omega) context fuel computation hvalid + hcompletable (fun step hstep => hensured 0 step hstep) + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredLayerPathFamily_then_runResolvedFinishIsNone + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + ∀ {n : Nat} (family : Fin n → Fin maxLayerHeight) + (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α), + context.Valid → DeferredCompletable table context → + (∀ index, (family index).val < layerHeight lay → + TreeNodeEnsured lay tree (family index).val + (Nat.xor (leafIdx.val / 2 ^ (family index).val) 1) context) → + evalDist (do + let resolved ← resolveDeferredLayerPathFamily table lay tree leafIdx family context + match resolved with + | none => pure true + | some (finalContext, _) => + runResolvedFinishIsNone finalContext fuel table computation) = + evalDist (runResolvedFinishIsNone context fuel table computation) + | 0, family, context, fuel, computation, _hvalid, _hcompletable, _hensured => by + simp [resolveDeferredLayerPathFamily] + | n + 1, family, context, fuel, computation, hvalid, hcompletable, hensured => by + rw [resolveDeferredLayerPathFamily] + by_cases hinLayer : (family 0).val < layerHeight lay + · simp only [hinLayer, ↓reduceDIte, bind_assoc] + calc + _ = evalDist (resolveDeferredTreeNode table lay tree (family 0).val + (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) context >>= fun headOption => + match headOption with + | none => pure true + | some head => + runResolvedFinishIsNone head.toDeferredContext fuel table computation) := by + apply evalDist_bind_congr + intro headOption hhead + cases headOption with + | none => rfl + | some head => + have hheadValid := hvalid.of_resolveDeferredTreeNode table lay tree + (family 0).val (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) head hhead + have hheadCompletable := hcompletable.of_resolveDeferredTreeNode hvalid hhead + have hprivate := privateStateAgrees_resolveDeferredTreeNode table lay tree + (family 0).val (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) context head hhead + have htail := + evalDist_resolveDeferredLayerPathFamily_then_runResolvedFinishIsNone + table lay tree leafIdx (fun index : Fin n => family index.succ) + head.toDeferredContext fuel computation hheadValid hheadCompletable (by + intro index hindex + apply (treeNodeEnsured_congr_ensured lay tree + (family index.succ).val + (Nat.xor (leafIdx.val / 2 ^ (family index.succ).val) 1) + context head.toDeferredContext hprivate.2.2.symm).mp + exact hensured index.succ hindex) + calc + _ = evalDist (do + let tail ← resolveDeferredLayerPathFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) head.toDeferredContext + match tail with + | none => pure true + | some (finalContext, _) => + runResolvedFinishIsNone finalContext fuel table computation) := by + apply congrArg evalDist + simp only [bind_assoc] + apply bind_congr + intro tailOption + cases tailOption <;> simp + _ = _ := htail + _ = _ := evalDist_resolveDeferredTreeNode_then_runResolvedFinishIsNone table lay tree + (family 0).val (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) context fuel computation hvalid + hcompletable (hensured 0 hinLayer) + · simp only [hinLayer, ↓reduceDIte, bind_assoc] + calc + _ = evalDist (do + let tail ← resolveDeferredLayerPathFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) context + match tail with + | none => pure true + | some (finalContext, _) => + runResolvedFinishIsNone finalContext fuel table computation) := by + apply congrArg evalDist + apply bind_congr + intro tailOption + cases tailOption <;> simp + _ = _ := + evalDist_resolveDeferredLayerPathFamily_then_runResolvedFinishIsNone table lay tree + leafIdx (fun index : Fin n => family index.succ) context fuel computation hvalid + hcompletable (fun index hindex => hensured index.succ hindex) + +theorem DeferredCompletable.of_resolveDeferredSelectedChainFamily + {table : OtsSecretIndex → HashOutput} {lay : Layer} {tree : TreeIndex} + {leafIdx : LeafIndex} {context : DeferredContext} + (hcompletable : DeferredCompletable table context) (hvalid : context.Valid) : + ∀ {n : Nat} (family : Fin n → ChainIndex) (digits : Fin n → Digit) + (finalContext : DeferredContext) (values : Fin n → Digest), + some (finalContext, values) ∈ support + (resolveDeferredSelectedChainFamily table lay tree leafIdx family digits context) → + DeferredCompletable table finalContext + | 0, family, digits, finalContext, values, hresult => by + simp [resolveDeferredSelectedChainFamily] at hresult + rw [hresult.1] + exact hcompletable + | n + 1, family, digits, finalContext, values, hresult => by + rw [resolveDeferredSelectedChainFamily, mem_support_bind_iff] at hresult + obtain ⟨headOption, hhead, hrest⟩ := hresult + cases headOption with + | none => simp at hrest + | some head => + rw [mem_support_bind_iff] at hrest + obtain ⟨tailOption, htail, hreturn⟩ := hrest + cases tailOption with + | none => simp at hreturn + | some tail => + rcases tail with ⟨tailContext, tailValues⟩ + have hreturn' : finalContext = tailContext ∧ + values = Fin.cases (truncateHash head.output) tailValues := by + simpa using hreturn + rw [hreturn'.1] + have hheadCompletable := hcompletable.of_resolveDeferredChainPrefix hvalid hhead + have hheadValid := hvalid.of_resolveDeferredChainPrefix table lay tree leafIdx + (family 0) (digits 0).val (by have := (digits 0).isLt; omega) head hhead + exact hheadCompletable.of_resolveDeferredSelectedChainFamily hheadValid + (fun index : Fin n => family index.succ) + (fun index : Fin n => digits index.succ) tailContext tailValues htail + +theorem DeferredCompletable.of_resolveDeferredLayerPathFamily + {table : OtsSecretIndex → HashOutput} {lay : Layer} {tree : TreeIndex} + {leafIdx : LeafIndex} {context : DeferredContext} + (hcompletable : DeferredCompletable table context) (hvalid : context.Valid) : + ∀ {n : Nat} (family : Fin n → Fin maxLayerHeight) + (finalContext : DeferredContext) (values : Fin n → Digest), + some (finalContext, values) ∈ support + (resolveDeferredLayerPathFamily table lay tree leafIdx family context) → + DeferredCompletable table finalContext + | 0, family, finalContext, values, hresult => by + simp [resolveDeferredLayerPathFamily] at hresult + rw [hresult.1] + exact hcompletable + | n + 1, family, finalContext, values, hresult => by + rw [resolveDeferredLayerPathFamily] at hresult + by_cases hinLayer : (family 0).val < layerHeight lay + · simp only [hinLayer, ↓reduceDIte, mem_support_bind_iff] at hresult + obtain ⟨headOption, hhead, hrest⟩ := hresult + cases headOption with + | none => simp at hrest + | some head => + rw [mem_support_bind_iff] at hrest + obtain ⟨tailOption, htail, hreturn⟩ := hrest + cases tailOption with + | none => simp at hreturn + | some tail => + rcases tail with ⟨tailContext, tailValues⟩ + have hreturn' : finalContext = tailContext ∧ + values = Fin.cases (truncateHash head.output) tailValues := by + simpa using hreturn + rw [hreturn'.1] + have hheadCompletable := hcompletable.of_resolveDeferredTreeNode hvalid hhead + have hheadValid := hvalid.of_resolveDeferredTreeNode table lay tree + (family 0).val (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) head hhead + exact hheadCompletable.of_resolveDeferredLayerPathFamily hheadValid + (fun index : Fin n => family index.succ) tailContext tailValues htail + · simp only [hinLayer, ↓reduceDIte, mem_support_bind_iff] at hresult + obtain ⟨tailOption, htail, hreturn⟩ := hresult + cases tailOption with + | none => simp at hreturn + | some tail => + rcases tail with ⟨tailContext, tailValues⟩ + have hreturn' : finalContext = tailContext ∧ + values = Fin.cases 0 tailValues := by + simpa using hreturn + rw [hreturn'.1] + exact hcompletable.of_resolveDeferredLayerPathFamily hvalid + (fun index : Fin n => family index.succ) tailContext tailValues htail + +def LayerValuesEnsured (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) + (context : DeferredContext) : Prop := + (∀ chainIdx (step : ChainStep), step.val < (encoding chainIdx).val → + Coordinate.position + (.chain lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx step) ∈ + context.state.ensured) ∧ + ∀ level : Fin maxLayerHeight, level.val < layerHeight lay → + TreeNodeEnsured lay (treeIndexAt index lay) level.val + (Nat.xor ((leafIndexAt index lay).val / 2 ^ level.val) 1) context + +noncomputable def runResolvedPairFinishIsNone + (run : ProbComp (Option (DeferredContext × β))) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : ProbComp Bool := do + let resolved ← run + match resolved with + | none => pure true + | some (finalContext, _) => + runResolvedFinishIsNone finalContext fuel table computation + +theorem evalDist_runResolvedPair_selectedChainFamily + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) {n : Nat} (family : Fin n → ChainIndex) + (digits : Fin n → Digit) (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : ∀ index (step : ChainStep), step.val < (digits index).val → + Coordinate.position (.chain lay tree leafIdx (family index) step) ∈ + context.state.ensured) : + evalDist (runResolvedPairFinishIsNone + (resolveDeferredSelectedChainFamily table lay tree leafIdx family digits context) + fuel table computation) = + evalDist (runResolvedFinishIsNone context fuel table computation) := by + unfold runResolvedPairFinishIsNone + let hbase := + evalDist_resolveDeferredSelectedChainFamily_then_runResolvedFinishIsNone table lay tree + leafIdx family digits context fuel computation hvalid hcompletable hensured + apply Eq.trans _ hbase + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro resolved + cases resolved with + | none => rfl + | some resolved => + rcases resolved with ⟨finalContext, values⟩ + rfl + +theorem evalDist_runResolvedPair_layerPathFamily + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) {n : Nat} (family : Fin n → Fin maxLayerHeight) + (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : ∀ index, (family index).val < layerHeight lay → + TreeNodeEnsured lay tree (family index).val + (Nat.xor (leafIdx.val / 2 ^ (family index).val) 1) context) : + evalDist (runResolvedPairFinishIsNone + (resolveDeferredLayerPathFamily table lay tree leafIdx family context) + fuel table computation) = + evalDist (runResolvedFinishIsNone context fuel table computation) := by + unfold runResolvedPairFinishIsNone + let hbase := evalDist_resolveDeferredLayerPathFamily_then_runResolvedFinishIsNone table lay + tree leafIdx family context fuel computation hvalid hcompletable hensured + apply Eq.trans _ hbase + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro resolved + cases resolved with + | none => rfl + | some resolved => + rcases resolved with ⟨finalContext, values⟩ + rfl + +set_option maxRecDepth 100000 in +theorem ensuredLE_of_mem_runResolvedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : ResolvedRunResult α) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table computation)) : + LazyRevealProbe.EnsuredLE context.state result.context.state := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runResolvedFromTable] at hresult + subst result + exact LazyRevealProbe.EnsuredLE.refl context.state + | query_bind query next ih => + cases query with + | uniform n => + rw [runResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hrest + | hashOutput => + rw [runResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hrest + | ensure coordinate => + rw [runResolvedFromTable_ensure_query_bind] at hresult + exact (LazyRevealProbe.ensuredLE_ensure context.state coordinate).trans + (ih () { context with state := context.state.ensure coordinate } fuel hresult) + | probe coordinate candidate => + rw [runResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · exact ih () context remaining (by simpa [hrevealed] using hresult) + · exact (LazyRevealProbe.ensuredLE_addPending context.state coordinate + candidate).trans + (ih () { context with state := context.state.addPending coordinate candidate } + remaining (by simpa [hrevealed] using hresult)) + | peek coordinate => + rw [runResolvedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hresult + | publish coordinate => + rw [runResolvedFromTable_publish_query_bind] at hresult + exact (LazyRevealProbe.ensuredLE_publish context.state coordinate).trans + (ih () { context with state := context.state.publish coordinate } fuel hresult) + | reveal coordinate => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + rw [runResolvedFromTable_reveal_query_bind, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, _hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + exact (LazyRevealProbe.ensuredLE_materialize context.state + (.chainStart lay tree leafIdx chainIdx) resolved.output).trans + (ih resolved.output + { state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) resolved.output + values := resolved.values } + fuel hrest) + | position position => + rw [runResolvedFromTable_reveal_query_bind, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, _hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + exact (LazyRevealProbe.ensuredLE_materialize context.state + (.position position) resolved.output).trans + (ih resolved.output + { state := context.state.materialize (.position position) + resolved.output + values := resolved.values } + fuel hrest) + +structure ResolvedEnsuresCoordinate (coordinate : Coordinate) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop where + of_run : ∀ table context fuel cache result, + some result ∈ support + (runResolvedFromTable context fuel table (computation.run cache)) → + coordinate ∈ result.context.state.ensured + +theorem ResolvedEnsuresCoordinate.bind_preserved + {coordinate : Coordinate} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : ResolvedEnsuresCoordinate coordinate left) : + ResolvedEnsuresCoordinate coordinate (left >>= next) := by + constructor + intro table context fuel cache result hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨middleOption, hmiddle, hrest⟩ := hresult + cases middleOption with + | none => simp at hrest + | some middle => + have hcoordinate := hleft.of_run table context fuel cache middle hmiddle + exact (ensuredLE_of_mem_runResolvedFromTable + ((next middle.value.1).run middle.value.2) middle.context middle.remaining + middle.table result hrest) hcoordinate + +theorem ResolvedEnsuresCoordinate.bind_right + {coordinate : Coordinate} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hnext : ∀ value, ResolvedEnsuresCoordinate coordinate (next value)) : + ResolvedEnsuresCoordinate coordinate (left >>= next) := by + constructor + intro table context fuel cache result hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨middleOption, _hmiddle, hrest⟩ := hresult + cases middleOption with + | none => simp at hrest + | some middle => + exact (hnext middle.value.1).of_run middle.table middle.context middle.remaining + middle.value.2 result hrest + +theorem resolvedEnsuresCoordinate_ensureCoordinate (coordinate : Coordinate) : + ResolvedEnsuresCoordinate coordinate (ensureCoordinate coordinate) := by + constructor + intro table context fuel cache result hresult + unfold ensureCoordinate at hresult + rw [StateT.run_liftM, LazyRevealProbe.ensureQuery, + runResolvedFromTable_ensure_query_bind] at hresult + simp [runResolvedFromTable] at hresult + subst result + simp [LazyRevealProbe.State.ensure] + +theorem ResolvedEnsuresCoordinate.sequenceFin_component {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (index : Fin n) + (hensures : ResolvedEnsuresCoordinate coordinate (computation index)) : + ResolvedEnsuresCoordinate coordinate (sequenceFin computation) := by + induction n with + | zero => exact index.elim0 + | succ n ih => + rw [sequenceFin] + cases index using Fin.cases with + | zero => exact hensures.bind_preserved + | succ index => + apply ResolvedEnsuresCoordinate.bind_right + intro head + exact (ih (fun current : Fin n => computation current.succ) index + hensures).bind_preserved + +theorem resolvedEnsuresCoordinate_ensureChainPrefix + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (digit : Digit) (step : ChainStep) (hstep : step.val < digit.val) : + ResolvedEnsuresCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + apply ResolvedEnsuresCoordinate.bind_preserved + apply ResolvedEnsuresCoordinate.sequenceFin_component + (fun current : ChainStep => + if current.val < digit.val then + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx current)) + else pure ()) step + rw [if_pos hstep] + exact resolvedEnsuresCoordinate_ensureCoordinate _ + +theorem resolvedEnsuresCoordinate_ensureFullChain + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (step : ChainStep) : + ResolvedEnsuresCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (ResolvedEnsuresCoordinate.sequenceFin_component + (fun current : ChainStep => + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx current))) step + (resolvedEnsuresCoordinate_ensureCoordinate _)).bind_preserved + +theorem resolvedEnsuresCoordinate_ensureOtsLeaf_chain + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (step : ChainStep) : + ResolvedEnsuresCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (ResolvedEnsuresCoordinate.sequenceFin_component + (fun current : ChainIndex => ensureFullChain lay tree leafIdx current) chainIdx + (resolvedEnsuresCoordinate_ensureFullChain lay tree leafIdx chainIdx step)).bind_preserved + +theorem resolvedEnsuresCoordinate_ensureOtsLeaf_leaf + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ResolvedEnsuresCoordinate (.position (.leaf lay tree leafIdx)) + (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + apply ResolvedEnsuresCoordinate.bind_right + intro values + exact resolvedEnsuresCoordinate_ensureCoordinate _ + +theorem TreeNodeEnsured.mono + {lay : Layer} {tree : TreeIndex} {level nodeIdx : Nat} + {left right : DeferredContext} + (htree : TreeNodeEnsured lay tree level nodeIdx left) + (hle : LazyRevealProbe.EnsuredLE left.state right.state) : + TreeNodeEnsured lay tree level nodeIdx right := by + induction level generalizing nodeIdx with + | zero => + refine ⟨?_, ?_⟩ + · intro chainIdx step + exact hle (htree.1 chainIdx step) + · exact hle htree.2 + | succ level ih => + refine ⟨ih htree.1, ih htree.2.1, ?_⟩ + obtain ⟨hlevel, hcoordinate⟩ := htree.2.2 + exact ⟨hlevel, hle hcoordinate⟩ + +structure ResolvedEnsuresTreeNode (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop where + of_run : ∀ table context fuel cache result, + some result ∈ support + (runResolvedFromTable context fuel table (computation.run cache)) → + TreeNodeEnsured lay tree level nodeIdx result.context + +theorem ResolvedEnsuresTreeNode.bind_preserved + {lay : Layer} {tree : TreeIndex} {level nodeIdx : Nat} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : ResolvedEnsuresTreeNode lay tree level nodeIdx left) : + ResolvedEnsuresTreeNode lay tree level nodeIdx (left >>= next) := by + constructor + intro table context fuel cache result hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨middleOption, hmiddle, hrest⟩ := hresult + cases middleOption with + | none => simp at hrest + | some middle => + exact (hleft.of_run table context fuel cache middle hmiddle).mono + (ensuredLE_of_mem_runResolvedFromTable ((next middle.value.1).run middle.value.2) + middle.context middle.remaining middle.table result hrest) + +theorem ResolvedEnsuresTreeNode.bind_right + {lay : Layer} {tree : TreeIndex} {level nodeIdx : Nat} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hnext : ∀ value, ResolvedEnsuresTreeNode lay tree level nodeIdx (next value)) : + ResolvedEnsuresTreeNode lay tree level nodeIdx (left >>= next) := by + constructor + intro table context fuel cache result hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨middleOption, _hmiddle, hrest⟩ := hresult + cases middleOption with + | none => simp at hrest + | some middle => + exact (hnext middle.value.1).of_run middle.table middle.context middle.remaining + middle.value.2 result hrest + +theorem ResolvedEnsuresTreeNode.sequenceFin_component {n : Nat} + {lay : Layer} {tree : TreeIndex} {level nodeIdx : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (index : Fin n) + (hensures : ResolvedEnsuresTreeNode lay tree level nodeIdx (computation index)) : + ResolvedEnsuresTreeNode lay tree level nodeIdx (sequenceFin computation) := by + induction n with + | zero => exact index.elim0 + | succ n ih => + rw [sequenceFin] + cases index using Fin.cases with + | zero => exact hensures.bind_preserved + | succ index => + apply ResolvedEnsuresTreeNode.bind_right + intro head + exact (ih (fun current : Fin n => computation current.succ) index + hensures).bind_preserved + +attribute [local irreducible] ensureFullChain ensureOtsLeaf + +theorem resolvedEnsuresTreeNode_ensureOtsLeaf + (lay : Layer) (tree : TreeIndex) (nodeIdx : Nat) : + ResolvedEnsuresTreeNode lay tree 0 nodeIdx + (ensureOtsLeaf lay tree (leafOfNat nodeIdx)) := by + constructor + intro table context fuel cache result hresult + refine ⟨?_, ?_⟩ + · intro chainIdx step + exact (resolvedEnsuresCoordinate_ensureOtsLeaf_chain lay tree (leafOfNat nodeIdx) + chainIdx step).of_run table context fuel cache result hresult + · exact (resolvedEnsuresCoordinate_ensureOtsLeaf_leaf lay tree (leafOfNat nodeIdx)).of_run + table context fuel cache result hresult + +theorem resolvedEnsuresTreeNode_ensureTreeNode + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) + (hlevel : level ≤ maxLayerHeight) : + ResolvedEnsuresTreeNode lay tree level nodeIdx + (ensureTreeNode lay tree level nodeIdx) := by + induction level generalizing nodeIdx with + | zero => + simpa only [ensureTreeNode] using + (resolvedEnsuresTreeNode_ensureOtsLeaf lay tree nodeIdx) + | succ level ih => + rw [ensureTreeNode] + have hleft : ResolvedEnsuresTreeNode lay tree level (2 * nodeIdx) + (do + ensureTreeNode lay tree level (2 * nodeIdx) + ensureTreeNode lay tree level (2 * nodeIdx + 1) + if h : level < maxLayerHeight then + ensureCoordinate (.position (.node lay tree ⟨level, h⟩ (leafOfNat nodeIdx))) + else pure ()) := by + apply ResolvedEnsuresTreeNode.bind_preserved + exact ih (2 * nodeIdx) (by omega) + have hright : ResolvedEnsuresTreeNode lay tree level (2 * nodeIdx + 1) + (do + ensureTreeNode lay tree level (2 * nodeIdx) + ensureTreeNode lay tree level (2 * nodeIdx + 1) + if h : level < maxLayerHeight then + ensureCoordinate (.position (.node lay tree ⟨level, h⟩ (leafOfNat nodeIdx))) + else pure ()) := by + apply ResolvedEnsuresTreeNode.bind_right + intro leftValue + apply ResolvedEnsuresTreeNode.bind_preserved + exact ih (2 * nodeIdx + 1) (by omega) + have hnode : ResolvedEnsuresCoordinate + (.position (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx))) + (do + ensureTreeNode lay tree level (2 * nodeIdx) + ensureTreeNode lay tree level (2 * nodeIdx + 1) + if h : level < maxLayerHeight then + ensureCoordinate (.position (.node lay tree ⟨level, h⟩ (leafOfNat nodeIdx))) + else pure ()) := by + apply ResolvedEnsuresCoordinate.bind_right + intro leftValue + apply ResolvedEnsuresCoordinate.bind_right + intro rightValue + rw [dif_pos (by omega)] + exact resolvedEnsuresCoordinate_ensureCoordinate _ + constructor + intro table context fuel cache result hresult + refine ⟨hleft.of_run table context fuel cache result hresult, + hright.of_run table context fuel cache result hresult, ?_⟩ + exact ⟨by omega, hnode.of_run table context fuel cache result hresult⟩ + +theorem resolvedEnsuresTreeNode_ensureTreePath + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (level : Fin maxLayerHeight) (hinLayer : level.val < layerHeight lay) : + ResolvedEnsuresTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + apply ResolvedEnsuresTreeNode.bind_preserved + apply ResolvedEnsuresTreeNode.sequenceFin_component + (fun current : Fin maxLayerHeight => + if current.val < layerHeight lay then + ensureTreeNode lay tree current.val + (Nat.xor (leafIdx.val / 2 ^ current.val) 1) + else pure ()) level + rw [if_pos hinLayer] + exact resolvedEnsuresTreeNode_ensureTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) (by omega) + +set_option maxRecDepth 100000 in +theorem chainPrefixEnsured_of_mem_runResolved_maskedOtsSignFrom + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult + (Option (Counter × (ChainIndex → Digit)) × SplitHashCache)) + (selectedCounter : Counter) (encoding : ChainIndex → Digit), + some result ∈ support (runResolvedFromTable context fuel table + ((maskedOtsSignFrom parameter lay tree leafIdx message attempts counter).run cache)) → + result.value.1 = some (selectedCounter, encoding) → + ∀ chainIdx (step : ChainStep), step.val < (encoding chainIdx).val → + Coordinate.position (.chain lay tree leafIdx chainIdx step) ∈ + result.context.state.ensured + | 0, counter, table, context, fuel, cache, result, selectedCounter, encoding, + hresult, hvalue => by + simp [maskedOtsSignFrom, runResolvedFromTable] at hresult + subst result + simp at hvalue + | attempts + 1, counter, table, context, fuel, cache, result, selectedCounter, + encoding, hresult, hvalue => by + rw [maskedOtsSignFrom, StateT.run_bind, runResolvedFromTable_bind, + mem_support_bind_iff] at hresult + obtain ⟨encodedOption, _hencoded, hrest⟩ := hresult + cases encodedOption with + | none => simp at hrest + | some encodedResult => + rcases encodedResult with + ⟨encodedContext, encodedRemaining, ⟨encoded, encodedCache⟩, encodedTable⟩ + simp only at hrest + cases encoded with + | none => + exact chainPrefixEnsured_of_mem_runResolved_maskedOtsSignFrom parameter lay tree + leafIdx message attempts (counter + 1) encodedTable encodedContext + encodedRemaining encodedCache result + selectedCounter encoding hrest hvalue + | some selectedEncoding => + rw [StateT.run_bind, runResolvedFromTable_bind, + mem_support_bind_iff] at hrest + obtain ⟨ensureOption, hensure, hfinish⟩ := hrest + cases ensureOption with + | none => simp at hfinish + | some ensureResult => + simp [runResolvedFromTable] at hfinish + subst result + simp only [Option.some.injEq, Prod.mk.injEq] at hvalue + rcases hvalue with ⟨_hcounter, hencoding⟩ + subst encoding + intro chainIdx step hstep + exact (ResolvedEnsuresCoordinate.sequenceFin_component + (fun current : ChainIndex => + ensureChainPrefix lay tree leafIdx current (selectedEncoding current)) + chainIdx (resolvedEnsuresCoordinate_ensureChainPrefix lay tree leafIdx + chainIdx (selectedEncoding chainIdx) step hstep)).of_run + encodedTable encodedContext encodedRemaining encodedCache ensureResult + hensure + +theorem chainPrefixEnsured_of_mem_runResolved_maskedOtsSign + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult + (Option (Counter × (ChainIndex → Digit)) × SplitHashCache)) + (selectedCounter : Counter) (encoding : ChainIndex → Digit) + (hresult : some result ∈ support (runResolvedFromTable context fuel table + ((maskedOtsSign parameter lay tree leafIdx message).run cache))) + (hvalue : result.value.1 = some (selectedCounter, encoding)) : + ∀ chainIdx (step : ChainStep), step.val < (encoding chainIdx).val → + Coordinate.position (.chain lay tree leafIdx chainIdx step) ∈ + result.context.state.ensured := by + exact chainPrefixEnsured_of_mem_runResolved_maskedOtsSignFrom parameter lay tree leafIdx + message encodingAttemptLimit 0 table context fuel cache result selectedCounter encoding + hresult hvalue + +set_option maxRecDepth 100000 in +theorem layerValuesEnsured_of_mem_runResolved_maskedSignLayer + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult + (Option (Counter × (ChainIndex → Digit)) × SplitHashCache)) + (counter : Counter) (encoding : ChainIndex → Digit) + (hresult : some result ∈ support (runResolvedFromTable context fuel table + ((maskedSignLayer parameter ftsSecret index lay).run cache))) + (hvalue : result.value.1 = some (counter, encoding)) : + LayerValuesEnsured index lay encoding result.context := by + unfold maskedSignLayer at hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨messageOption, _hmessage, hrest⟩ := hresult + cases messageOption with + | none => simp at hrest + | some messageResult => + rcases messageResult with + ⟨messageContext, messageRemaining, ⟨message, messageCache⟩, messageTable⟩ + simp only at hrest + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hrest + obtain ⟨otsOption, hots, hafterOts⟩ := hrest + cases otsOption with + | none => simp at hafterOts + | some otsResult => + rcases otsResult with + ⟨otsContext, otsRemaining, ⟨selected, otsCache⟩, otsTable⟩ + simp only at hafterOts + cases selected with + | none => + simp [runResolvedFromTable] at hafterOts + subst result + simp at hvalue + | some selected => + rcases selected with ⟨selectedCounter, selectedEncoding⟩ + rw [StateT.run_bind, runResolvedFromTable_bind, + mem_support_bind_iff] at hafterOts + obtain ⟨pathOption, hpath, hfinish⟩ := hafterOts + cases pathOption with + | none => simp at hfinish + | some pathResult => + simp [runResolvedFromTable] at hfinish + subst result + simp only [Option.some.injEq, Prod.mk.injEq] at hvalue + rcases hvalue with ⟨_hcounter, hencoding⟩ + subst encoding + have hchainBefore := + chainPrefixEnsured_of_mem_runResolved_maskedOtsSign parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) message + messageTable messageContext messageRemaining messageCache + ⟨otsContext, otsRemaining, + (some (selectedCounter, selectedEncoding), otsCache), otsTable⟩ + selectedCounter selectedEncoding hots rfl + have hpathMono := ensuredLE_of_mem_runResolvedFromTable + ((ensureTreePath lay (treeIndexAt index lay) + (leafIndexAt index lay)).run otsCache) otsContext otsRemaining otsTable + pathResult hpath + refine ⟨?_, ?_⟩ + · intro chainIdx step hstep + exact hpathMono (hchainBefore chainIdx step hstep) + · intro level hlevel + exact (resolvedEnsuresTreeNode_ensureTreePath lay + (treeIndexAt index lay) (leafIndexAt index lay) level hlevel).of_run + otsTable otsContext otsRemaining otsCache + pathResult hpath + +theorem deferredCompletable_of_mem_runResolved_maskedSignLayer + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (index : Index) (lay : Layer) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult + (Option (Counter × (ChainIndex → Digit)) × SplitHashCache)) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hresult : some result ∈ support (runResolvedFromTable context fuel table + ((maskedSignLayer parameter ftsSecret index lay).run cache))) : + DeferredCompletable table result.context := by + have hstarts := startTableAgrees_of_deferredCompletable hcompletable + have hview := finalizationViewEq_of_deferredCompletion_iff hvalid hvalid hstarts hstarts + rfl hcompletable (fun _ => Iff.rfl) + have hrelation := finalizationMaterializedCouples_maskedSignLayer table parameter ftsSecret + index lay context context fuel cache cache + ⟨hview, hvalid, hvalid, hcompletable⟩ rfl rfl + obtain ⟨rightResult, _hright, hresultRelation⟩ := + exists_right_of_relTriple_of_mem_support hrelation hresult + cases rightResult with + | none => simp [FinalizationMaterializedRunEq] at hresultRelation + | some rightResult => + rcases hresultRelation with + ⟨_hvalue, hcontexts, _hfuel, _hleftTable, _hrightTable, _hcache, _hrevealed⟩ + exact hcontexts.2.2.2 + +theorem selectedLayerValuesEnsured_of_mem_selectDeferredLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (input output : ResolvedRunResult DeferredLayerStore) + (counter : Counter) (encoding : ChainIndex → Digit) + (houtput : some output ∈ support + (selectDeferredLayer parameter table ftsSecret index lay input)) + (hselected : output.value.selected lay = some (counter, encoding)) : + LayerValuesEnsured index lay encoding output.context := by + unfold selectDeferredLayer at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨selectedOption, hrun, hreturn⟩ := houtput + cases selectedOption with + | none => simp at hreturn + | some selected => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have houtputEq := Option.some.inj hreturn + subst output + have hvalue : selected.value.1 = some (counter, encoding) := by + simpa using hselected + exact layerValuesEnsured_of_mem_runResolved_maskedSignLayer parameter ftsSecret index lay + table input.context input.remaining input.value.cache selected counter encoding hrun hvalue + +theorem deferredCompletable_of_mem_selectDeferredLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (input output : ResolvedRunResult DeferredLayerStore) + (hvalid : input.context.Valid) + (hcompletable : DeferredCompletable table input.context) + (houtput : some output ∈ support + (selectDeferredLayer parameter table ftsSecret index lay input)) : + DeferredCompletable table output.context := by + unfold selectDeferredLayer at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨selectedOption, hrun, hreturn⟩ := houtput + cases selectedOption with + | none => simp at hreturn + | some selected => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have houtputEq := Option.some.inj hreturn + subst output + exact deferredCompletable_of_mem_runResolved_maskedSignLayer parameter ftsSecret index lay + table input.context input.remaining input.value.cache selected hvalid hcompletable hrun + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredLayerValues_then_runResolvedFinishIsNone + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) (context : DeferredContext) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (hensured : LayerValuesEnsured index lay encoding context) : + evalDist (do + let resolved ← resolveDeferredLayerValues table index lay encoding context + match resolved with + | none => pure true + | some (finalContext, _) => + runResolvedFinishIsNone finalContext fuel table computation) = + evalDist (runResolvedFinishIsNone context fuel table computation) := by + let chainFamily : ChainIndex → ChainIndex := fun chainIdx => chainIdx + let pathFamily : Fin maxLayerHeight → Fin maxLayerHeight := fun level => level + change evalDist (do + let resolved ← resolveDeferredLayerValues table index lay encoding context + match resolved with + | none => pure true + | some (finalContext, _) => + runResolvedFinishIsNone finalContext fuel table computation) = _ + rw [resolveDeferredLayerValues] + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredSelectedChainFamily table lay (treeIndexAt index lay) + (leafIndexAt index lay) chainFamily encoding context >>= + fun chainsOption => + match chainsOption with + | none => pure true + | some (afterChains, _) => + runResolvedFinishIsNone afterChains fuel table computation) := by + apply evalDist_bind_congr + intro chainsOption hchains + cases chainsOption with + | none => rfl + | some chains => + rcases chains with ⟨afterChains, chainValues⟩ + have hchainsValid := hvalid.of_resolveDeferredSelectedChainFamily table lay + (treeIndexAt index lay) (leafIndexAt index lay) + chainFamily encoding afterChains chainValues hchains + have hchainsCompletable := + hcompletable.of_resolveDeferredSelectedChainFamily hvalid + chainFamily encoding afterChains chainValues hchains + have hprivate := privateStateAgrees_resolveDeferredSelectedChainFamily table lay + (treeIndexAt index lay) (leafIndexAt index lay) + chainFamily encoding context afterChains chainValues + hchains + have hpath := evalDist_resolveDeferredLayerPathFamily_then_runResolvedFinishIsNone + table lay (treeIndexAt index lay) (leafIndexAt index lay) + pathFamily afterChains fuel computation + hchainsValid hchainsCompletable (by + intro level hlevel + apply (treeNodeEnsured_congr_ensured lay (treeIndexAt index lay) level.val + (Nat.xor ((leafIndexAt index lay).val / 2 ^ level.val) 1) + context afterChains hprivate.2.2.symm).mp + exact hensured.2 level hlevel) + calc + _ = evalDist (do + let path ← resolveDeferredLayerPathFamily table lay (treeIndexAt index lay) + (leafIndexAt index lay) (fun level : Fin maxLayerHeight => level) afterChains + match path with + | none => pure true + | some (finalContext, _) => + runResolvedFinishIsNone finalContext fuel table computation) := by + apply congrArg evalDist + simp only [bind_assoc] + apply bind_congr + intro pathOption + cases pathOption <;> simp + _ = evalDist (runResolvedFinishIsNone afterChains fuel table computation) := by + apply Eq.trans _ hpath + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro resolved + cases resolved with + | none => rfl + | some resolved => + rcases resolved with ⟨finalContext, values⟩ + rfl + _ = _ := rfl + _ = evalDist (runResolvedFinishIsNone context fuel table computation) := by + let hbase := + evalDist_resolveDeferredSelectedChainFamily_then_runResolvedFinishIsNone table lay + (treeIndexAt index lay) (leafIndexAt index lay) chainFamily encoding context fuel + computation hvalid hcompletable hensured.1 + apply Eq.trans _ hbase + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro resolved + cases resolved with + | none => rfl + | some resolved => + rcases resolved with ⟨finalContext, values⟩ + rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateSigner.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateSigner.lean new file mode 100644 index 00000000..83f176d2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateSigner.lean @@ -0,0 +1,138 @@ +import SphincsSecurity.Proof.OtsProbeResolvedPrivateObserver + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp + +attribute [local irreducible] maskedSignLayer + +theorem evalDist_runDeferredChronologicalLayersAndPublish_canonicalObserve_eq_selectionOnly + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (next : Option Signature → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (runDeferredChronologicalLayersAndPublish parameter table ftsSecret randomness + index leaves ftsPath context fuel cache >>= + finishObserve (canonicalContinuationObserve table next)) = + evalDist (runSelectionOnlyLayersAndPublish parameter table ftsSecret randomness index + leaves ftsPath context fuel cache >>= + finishObserve (canonicalContinuationObserve table next)) := by + calc + _ = evalDist (runDeferredLayersAndPublish parameter table ftsSecret randomness index leaves + ftsPath deferredLayerSchedule context fuel cache >>= + finishObserve (canonicalContinuationObserve table next)) := + evalDist_runDeferredChronologicalLayersAndPublish_observe_eq_deferred parameter table + ftsSecret randomness index leaves ftsPath context fuel cache + (canonicalContinuationObserve table next) + _ = _ := evalDist_runDeferredLayersAndPublish_observe_eq_selectionOnly parameter table + ftsSecret randomness index leaves ftsPath context fuel cache hvalid hcompletable + +set_option maxRecDepth 100000 in +theorem evalDist_runDeferredChronologicalSignAfterDigest_canonicalObserve_eq_selectionOnly + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (next : Option Signature → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (runDeferredChronologicalSignAfterDigest parameter table ftsSecret randomness + index leaves context fuel cache >>= + finishObserve (canonicalContinuationObserve table next)) = + evalDist (runSelectionOnlySignAfterDigest parameter table ftsSecret randomness index + leaves context fuel cache >>= + finishObserve (canonicalContinuationObserve table next)) := by + unfold runDeferredChronologicalSignAfterDigest runSelectionOnlySignAfterDigest + simp only [bind_assoc] + apply evalDist_bind_congr + intro ftsOption hfts + cases ftsOption with + | none => simp [finishObserve] + | some ftsResult => + have hftsInvariants := + valid_completable_of_mem_runResolvedFromTable_of_finalizationMaterializedCouples table + (simulateQ ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index))) + (finalizationMaterializedCouples_simulateQ ordinaryHashImpl + (finalizationMaterializedCouples_ordinaryHashImpl table) + (ftsOpen parameter index leaves (ftsSecret index))) + context fuel cache ftsResult hvalid hcompletable hfts + exact + evalDist_runDeferredChronologicalLayersAndPublish_canonicalObserve_eq_selectionOnly + parameter table ftsSecret randomness index leaves ftsResult.value.1 ftsResult.context + ftsResult.remaining ftsResult.value.2 next hftsInvariants.1 hftsInvariants.2 + +set_option maxRecDepth 100000 in +theorem evalDist_runDeferredChronologicalSign_canonicalObserve_eq_selectionOnly + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (next : Option Signature → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (runDeferredChronologicalSign parameter root table ftsSecret message context fuel + cache >>= finishObserve (canonicalContinuationObserve table next)) = + evalDist (runSelectionOnlySign parameter root table ftsSecret message context fuel cache >>= + finishObserve (canonicalContinuationObserve table next)) := by + unfold runDeferredChronologicalSign runSelectionOnlySign + simp only [bind_assoc] + apply evalDist_bind_congr + intro selectedOption hselected + cases selectedOption with + | none => simp [finishObserve] + | some selected => + cases hvalue : selected.value.1 with + | none => simp [hvalue, finishObserve] + | some digestResult => + rcases digestResult with ⟨randomness, selectedIndex, leaves⟩ + simp only [hvalue] + let secretKey : SecretKey := + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ + have hselectedInvariants := + valid_completable_of_mem_runResolvedFromTable_of_finalizationMaterializedCouples table + (simulateQ ordinaryRomImpl + (signDigestLoop digestAttemptLimit secretKey message)) + (finalizationMaterializedCouples_simulateQ ordinaryRomImpl + (finalizationMaterializedCouples_ordinaryRomImpl table) + (signDigestLoop digestAttemptLimit secretKey message)) + context fuel cache selected hvalid hcompletable (by + simpa only [secretKey] using hselected) + exact + evalDist_runDeferredChronologicalSignAfterDigest_canonicalObserve_eq_selectionOnly + parameter table ftsSecret randomness selectedIndex leaves selected.context + selected.remaining selected.value.2 next hselectedInvariants.1 + hselectedInvariants.2 + +set_option maxRecDepth 100000 in +theorem evalDist_runDeferredChronologicalSign_canonicalObserve_eq_maskedSign + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (next : Option Signature → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) : + evalDist (runDeferredChronologicalSign parameter root table ftsSecret message context fuel + cache >>= finishObserve (canonicalContinuationObserve table next)) = + evalDist (runResolvedObserve (canonicalContinuationObserve table next) context fuel table + ((maskedSign parameter root ftsSecret message).run cache)) := by + calc + _ = evalDist (runSelectionOnlySign parameter root table ftsSecret message context fuel cache >>= + finishObserve (canonicalContinuationObserve table next)) := + evalDist_runDeferredChronologicalSign_canonicalObserve_eq_selectionOnly parameter root + table ftsSecret message context fuel cache next hvalid hcompletable + _ = evalDist (runResolvedFromTable context fuel table + ((maskedSign parameter root ftsSecret message).run cache) >>= + finishObserve (canonicalContinuationObserve table next)) := by + rw [evalDist_bind, evalDist_bind, + evalDist_runSelectionOnlySign_eq_resolved parameter root table ftsSecret message context + fuel cache hvalid.valuesConsistent + (startTableAgrees_of_deferredCompletable hcompletable)] + _ = _ := rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedSampling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedSampling.lean new file mode 100644 index 00000000..daef0257 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedSampling.lean @@ -0,0 +1,20142 @@ +import SphincsSecurity.Proof.OtsProbeRunSampling + +/-! +# Dynamically resolved one-time structural values + +Structural answers drawn before their proof-world reveal live in a separate partial table. The +lazy state therefore continues to hide them from `peek`, while a later reveal or finalization can +check every intervening probe against the already drawn answer. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +abbrev DeferredStructuralValues := Position → Option HashOutput + +def emptyDeferredStructuralValues : DeferredStructuralValues := fun _ => none + +def DeferredStructuralValues.install (values : DeferredStructuralValues) + (position : Position) (output : HashOutput) : DeferredStructuralValues := + Function.update values position (some output) + +structure DeferredContext where + state : LazyRevealProbe.State Coordinate + values : DeferredStructuralValues + +def positionOtsLayer? : Position → Option Layer + | .chain lay _ _ _ _ => some lay + | .leaf lay _ _ => some lay + | .node lay _ _ _ => some lay + | .ftsLeaf _ _ _ => none + | .ftsNode _ _ _ _ => none + | .ftsRoots _ => none + +def coordinateOtsLayer? : Coordinate → Option Layer + | .chainStart lay _ _ _ => some lay + | .position p => positionOtsLayer? p + +def DeferredContext.Valid (context : DeferredContext) : Prop := + (∀ position output, + context.state.values (.position position) = some output → + context.values position = some output) ∧ + ∀ coordinate output, + context.state.values coordinate = some output → + ¬context.state.hitAt coordinate output + +def DeferredContext.ValuesConsistent (context : DeferredContext) : Prop := + ∀ position output, + context.state.values (.position position) = some output → + context.values position = some output + +theorem DeferredContext.Valid.valuesConsistent {context : DeferredContext} + (hvalid : context.Valid) : context.ValuesConsistent := + hvalid.1 + +theorem DeferredContext.ValuesConsistent.of_state_values_eq + {left right : DeferredContext} (hconsistent : left.ValuesConsistent) + (hstate : right.state.values = left.state.values) + (hvalues : right.values = left.values) : right.ValuesConsistent := by + intro position output hvalue + rw [hvalues] + apply hconsistent position output + rw [← hstate] + exact hvalue + +theorem DeferredContext.ValuesConsistent.ensure + {context : DeferredContext} (hconsistent : context.ValuesConsistent) + (coordinate : Coordinate) : + ({ context with state := context.state.ensure coordinate } : DeferredContext).ValuesConsistent := + hconsistent + +theorem DeferredContext.ValuesConsistent.addPending + {context : DeferredContext} (hconsistent : context.ValuesConsistent) + (coordinate : Coordinate) (candidate : Digest) : + ({ context with state := context.state.addPending coordinate candidate } : + DeferredContext).ValuesConsistent := + hconsistent + +theorem DeferredContext.ValuesConsistent.publish + {context : DeferredContext} (hconsistent : context.ValuesConsistent) + (coordinate : Coordinate) : + ({ context with state := context.state.publish coordinate } : DeferredContext).ValuesConsistent := + hconsistent + +def DeferredContext.positionValue (context : DeferredContext) + (position : Position) : Option HashOutput := + match context.state.values (.position position) with + | some output => some output + | none => context.values position + +structure DeferredResolution extends DeferredContext where + output : HashOutput + +noncomputable def resolveDeferredPositionValue (position : Position) + (context : DeferredContext) : ProbComp (Option DeferredResolution) := + let coordinate := Coordinate.position position + match context.state.values coordinate with + | some output => + if context.state.hitAt coordinate output then + pure none + else + pure (some (DeferredResolution.mk + { state := context.state.clearPending coordinate, + values := context.values.install position output } + output)) + | none => + match context.values position with + | some output => + if context.state.hitAt coordinate output then + pure none + else + pure (some (DeferredResolution.mk + { state := context.state.clearPending coordinate, + values := context.values } + output)) + | none => do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt coordinate output then + pure none + else + pure (some (DeferredResolution.mk + { state := context.state.clearPending coordinate, + values := context.values.install position output } + output)) + +theorem resolveDeferredPositionValue_state_eq_clearPending + (position : Position) (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) : + result.state = context.state.clearPending (.position position) := by + unfold resolveDeferredPositionValue at hresult + simp only at hresult + cases hstate : context.state.values (.position position) with + | some output => + rw [hstate] at hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + rfl + | none => + rw [hstate] at hresult + cases hvalue : context.values position with + | some output => + rw [hvalue] at hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + rfl + | none => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hreturn⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hreturn + · simp [hhit] at hreturn + subst result + rfl + +theorem resolveDeferredPositionValue_of_state_value + (position : Position) (context : DeferredContext) (output : HashOutput) + (hvalue : context.state.values (.position position) = some output) : + resolveDeferredPositionValue position context = + if context.state.hitAt (.position position) output then + pure none + else + pure (some (DeferredResolution.mk + { state := context.state.clearPending (.position position), + values := context.values.install position output } + output)) := by + simp [resolveDeferredPositionValue, hvalue] + +theorem resolveDeferredPositionValue_of_deferred_value + (position : Position) (context : DeferredContext) (output : HashOutput) + (hstate : context.state.values (.position position) = none) + (hvalue : context.values position = some output) : + resolveDeferredPositionValue position context = + if context.state.hitAt (.position position) output then + pure none + else + pure (some (DeferredResolution.mk + { state := context.state.clearPending (.position position), + values := context.values } + output)) := by + simp [resolveDeferredPositionValue, hstate, hvalue] + +theorem resolveDeferredPositionValue_fresh + (position : Position) (context : DeferredContext) + (hstate : context.state.values (.position position) = none) + (hvalue : context.values position = none) : + resolveDeferredPositionValue position context = (do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt (.position position) output then + pure none + else + pure (some (DeferredResolution.mk + { state := context.state.clearPending (.position position), + values := context.values.install position output } + output))) := by + simp [resolveDeferredPositionValue, hstate, hvalue] + +theorem resolveDeferredPositionValue_preserves_state_values + (position : Position) (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) : + result.state.values = context.state.values := by + unfold resolveDeferredPositionValue at hresult + simp only at hresult + cases hstate : context.state.values (.position position) with + | some output => + rw [hstate] at hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + rfl + | none => + rw [hstate] at hresult + cases hvalue : context.values position with + | some output => + rw [hvalue] at hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + rfl + | none => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hreturn⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hreturn + · simp [hhit] at hreturn + subst result + rfl + +theorem resolveDeferredPositionValue_pending + (position : Position) (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) : + result.state.pending = context.state.pendingAway (.position position) := by + unfold resolveDeferredPositionValue at hresult + simp only at hresult + cases hstate : context.state.values (.position position) with + | some output => + rw [hstate] at hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + rfl + | none => + rw [hstate] at hresult + cases hvalue : context.values position with + | some output => + rw [hvalue] at hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + rfl + | none => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hreturn⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hreturn + · simp [hhit] at hreturn + subst result + rfl + +theorem resolveDeferredPositionValue_not_hit + (position : Position) (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) : + ¬context.state.hitAt (.position position) result.output := by + unfold resolveDeferredPositionValue at hresult + simp only at hresult + cases hstate : context.state.values (.position position) with + | some output => + rw [hstate] at hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + exact hhit + | none => + rw [hstate] at hresult + cases hvalue : context.values position with + | some output => + rw [hvalue] at hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + exact hhit + | none => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hreturn⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hreturn + · simp [hhit] at hreturn + subst result + exact hhit + +theorem resolveDeferredPositionValue_installs + (position : Position) (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) : + result.values position = some result.output := by + unfold resolveDeferredPositionValue at hresult + simp only at hresult + cases hstate : context.state.values (.position position) with + | some output => + rw [hstate] at hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + simp [DeferredStructuralValues.install] + | none => + rw [hstate] at hresult + cases hvalue : context.values position with + | some output => + rw [hvalue] at hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + exact hvalue + | none => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hreturn⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hreturn + · simp [hhit] at hreturn + subst result + simp [DeferredStructuralValues.install] + +theorem resolveDeferredPositionValue_preserves_other + (position other : Position) (context : DeferredContext) (result : DeferredResolution) + (hne : other ≠ position) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) : + result.values other = context.values other := by + unfold resolveDeferredPositionValue at hresult + simp only at hresult + cases hstate : context.state.values (.position position) with + | some output => + rw [hstate] at hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + simp [DeferredStructuralValues.install, hne] + | none => + rw [hstate] at hresult + cases hvalue : context.values position with + | some output => + rw [hvalue] at hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + rfl + | none => + rw [hvalue, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hreturn⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hreturn + · simp [hhit] at hreturn + subst result + simp [DeferredStructuralValues.install, hne] + +theorem resolveDeferredPositionValue_resolves + (position : Position) (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) : + result.toDeferredContext.positionValue position = some result.output := by + have hstateValues := resolveDeferredPositionValue_preserves_state_values + position context result hresult + cases hstate : context.state.values (.position position) with + | some output => + unfold resolveDeferredPositionValue at hresult + simp only [hstate] at hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + simp [DeferredContext.positionValue, hstate] + | none => + unfold DeferredContext.positionValue + rw [hstateValues, hstate] + exact resolveDeferredPositionValue_installs position context result hresult + +theorem resolveDeferredPositionValue_preserves_positionValue + (position other : Position) (context : DeferredContext) (result : DeferredResolution) + (output : HashOutput) + (hknown : context.positionValue other = some output) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) : + result.toDeferredContext.positionValue other = some output := by + by_cases heq : other = position + · subst other + have hresolved := resolveDeferredPositionValue_resolves position context result hresult + cases hstate : context.state.values (.position position) with + | some cached => + have houtput : output = cached := by + simpa [DeferredContext.positionValue, hstate] using hknown.symm + unfold resolveDeferredPositionValue at hresult + simp only [hstate] at hresult + by_cases hhit : context.state.hitAt (.position position) cached + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + simpa [houtput] + | none => + cases hvalue : context.values position with + | some cached => + have houtput : output = cached := by + simpa [DeferredContext.positionValue, hstate, hvalue] using hknown.symm + unfold resolveDeferredPositionValue at hresult + simp only [hstate, hvalue] at hresult + by_cases hhit : context.state.hitAt (.position position) cached + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + simpa [houtput] + | none => simp [DeferredContext.positionValue, hstate, hvalue] at hknown + · have hstateValues := resolveDeferredPositionValue_preserves_state_values + position context result hresult + have hdeferred := resolveDeferredPositionValue_preserves_other + position other context result heq hresult + unfold DeferredContext.positionValue at hknown ⊢ + rw [hstateValues] + cases hstate : context.state.values (.position other) with + | some cached => simpa [hstate] using hknown + | none => simpa [hstate, hdeferred] using hknown + +def ResolveQueryRel (input : HashInput) (cache : QueryCache HashSpec) : + Option DeferredResolution → HashOutput × QueryCache HashSpec → Prop + | none, _ => True + | some resolved, (output, finalCache) => + resolved.output = output ∧ finalCache = cache.cacheQuery input output + +theorem relTriple_resolveDeferredPositionValue_freshQuery + (position : Position) (context : DeferredContext) (input : HashInput) + (cache : QueryCache HashSpec) + (hstate : context.state.values (.position position) = none) + (hvalue : context.values position = none) (hcache : cache input = none) : + RelTriple + (resolveDeferredPositionValue position context) + ((randomOracle (spec := HashSpec) input).run cache) + (ResolveQueryRel input cache) := by + rw [resolveDeferredPositionValue_fresh position context hstate hvalue, + QueryImpl.withCaching_run_none uniformSampleImpl hcache] + unfold LazyRevealProbe.sampleHashOutput uniformSampleImpl + simp only [map_eq_bind_pure_comp] + apply relTriple_bind (relTriple_refl ($ᵗ HashOutput : ProbComp HashOutput)) + intro leftOutput rightOutput heq + subst rightOutput + by_cases hhit : context.state.hitAt (.position position) leftOutput + · simp [hhit, ResolveQueryRel] + · simp [hhit, ResolveQueryRel] + +theorem relTriple_resolveDeferredPositionValue_cachedQuery + (position : Position) (context : DeferredContext) (input : HashInput) + (cache : QueryCache HashSpec) (output : HashOutput) + (hknown : context.positionValue position = some output) + (hcache : cache input = some output) : + RelTriple + (resolveDeferredPositionValue position context) + ((randomOracle (spec := HashSpec) input).run cache) + (ResolveQueryRel input cache) := by + rw [QueryImpl.withCaching_run_some uniformSampleImpl hcache] + cases hstate : context.state.values (.position position) with + | some cached => + have hcached : cached = output := by + simpa [DeferredContext.positionValue, hstate] using hknown + subst cached + rw [resolveDeferredPositionValue_of_state_value position context output hstate] + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit, ResolveQueryRel] + · have hcacheQuery : cache.cacheQuery input output = cache := by + apply QueryCache.ext + intro query + by_cases hquery : query = input + · subst query + simp [QueryCache.cacheQuery_self, hcache] + · simp [QueryCache.cacheQuery_of_ne cache output hquery] + simp [hhit, ResolveQueryRel, hcacheQuery] + | none => + cases hvalue : context.values position with + | some cached => + have hcached : cached = output := by + simpa [DeferredContext.positionValue, hstate, hvalue] using hknown + subst cached + rw [resolveDeferredPositionValue_of_deferred_value position context output hstate hvalue] + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit, ResolveQueryRel] + · have hcacheQuery : cache.cacheQuery input output = cache := by + apply QueryCache.ext + intro query + by_cases hquery : query = input + · subst query + simp [QueryCache.cacheQuery_self, hcache] + · simp [QueryCache.cacheQuery_of_ne cache output hquery] + simp [hhit, ResolveQueryRel, hcacheQuery] + | none => simp [DeferredContext.positionValue, hstate, hvalue] at hknown + +def ResolveInputAgrees (position : Position) (context : DeferredContext) + (input : HashInput) (cache : QueryCache HashSpec) : Prop := + match context.positionValue position with + | none => cache input = none + | some output => cache input = some output + +theorem relTriple_resolveDeferredPositionValue_of_inputAgrees + (position : Position) (context : DeferredContext) (input : HashInput) + (cache : QueryCache HashSpec) + (hagrees : ResolveInputAgrees position context input cache) : + RelTriple + (resolveDeferredPositionValue position context) + ((randomOracle (spec := HashSpec) input).run cache) + (ResolveQueryRel input cache) := by + unfold ResolveInputAgrees at hagrees + cases hstate : context.state.values (.position position) with + | some output => + have hknown : context.positionValue position = some output := by + simp [DeferredContext.positionValue, hstate] + rw [hknown] at hagrees + exact relTriple_resolveDeferredPositionValue_cachedQuery position context input cache + output hknown hagrees + | none => + cases hvalue : context.values position with + | some output => + have hknown : context.positionValue position = some output := by + simp [DeferredContext.positionValue, hstate, hvalue] + rw [hknown] at hagrees + exact relTriple_resolveDeferredPositionValue_cachedQuery position context input cache + output hknown hagrees + | none => + have hmissing : context.positionValue position = none := by + simp [DeferredContext.positionValue, hstate, hvalue] + rw [hmissing] at hagrees + exact relTriple_resolveDeferredPositionValue_freshQuery position context input cache + hstate hvalue hagrees + +noncomputable def resolveDeferredChainStart (table : OtsSecretIndex → HashOutput) + (index : OtsSecretIndex) (context : DeferredContext) : + Option DeferredResolution := + let coordinate := index.coordinate + let output := table index + match context.state.values coordinate with + | some cached => + if context.state.hitAt coordinate cached then + none + else + some (DeferredResolution.mk + { state := context.state.clearPending coordinate, + values := context.values } + cached) + | none => + if context.state.hitAt coordinate output then + none + else + some (DeferredResolution.mk + { state := context.state.clearPending coordinate, + values := context.values } + output) + +theorem resolveDeferredChainStart_state_eq_clearPending + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + result.state = context.state.clearPending index.coordinate := by + unfold resolveDeferredChainStart at hresult + cases hstate : context.state.values index.coordinate with + | some output => + by_cases hhit : context.state.hitAt index.coordinate output + · simp [hstate, hhit] at hresult + · simp [hstate, hhit] at hresult + subst result + rfl + | none => + by_cases hhit : context.state.hitAt index.coordinate (table index) + · simp [hstate, hhit] at hresult + · simp [hstate, hhit] at hresult + subst result + rfl + +def PrivateStateAgrees (left right : DeferredContext) : Prop := + left.state.values = right.state.values ∧ + left.state.revealed = right.state.revealed ∧ + left.state.ensured = right.state.ensured + +theorem privateStateAgrees_resolveDeferredPositionValue + (position : Position) (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) : + PrivateStateAgrees result.toDeferredContext context := by + rw [PrivateStateAgrees, + resolveDeferredPositionValue_state_eq_clearPending position context result hresult] + exact ⟨rfl, rfl, rfl⟩ + +theorem privateStateAgrees_resolveDeferredChainStart + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + PrivateStateAgrees result.toDeferredContext context := by + rw [PrivateStateAgrees, + resolveDeferredChainStart_state_eq_clearPending table index context result hresult] + exact ⟨rfl, rfl, rfl⟩ + +theorem resolveDeferredChainStart_of_agrees + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) (hagrees : StartTableAgrees context.state table) + (hclean : ¬context.state.hitAt index.coordinate (table index)) : + resolveDeferredChainStart table index context = + some (DeferredResolution.mk + { state := context.state.clearPending index.coordinate + values := context.values } + (table index)) := by + unfold resolveDeferredChainStart + cases hvalue : context.state.values index.coordinate with + | none => simp [hvalue, hclean] + | some output => + have hout : output = table index := hagrees index output hvalue + subst output + simp [hvalue, hclean] + +theorem resolveDeferredChainStart_preserves_positionValue + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) (result : DeferredResolution) (position : Position) + (output : HashOutput) (hknown : context.positionValue position = some output) + (hresult : resolveDeferredChainStart table index context = some result) : + result.toDeferredContext.positionValue position = some output := by + unfold resolveDeferredChainStart at hresult + dsimp only at hresult + cases hvalue : context.state.values index.coordinate with + | some cached => + rw [hvalue] at hresult + by_cases hhit : context.state.hitAt index.coordinate cached + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + simpa [DeferredContext.positionValue, LazyRevealProbe.State.clearPending] using hknown + | none => + rw [hvalue] at hresult + by_cases hhit : context.state.hitAt index.coordinate (table index) + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + simpa [DeferredContext.positionValue, LazyRevealProbe.State.clearPending] using hknown + +theorem resolveDeferredChainStart_output_of_agrees + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) (result : DeferredResolution) + (hagrees : StartTableAgrees context.state table) + (hresult : resolveDeferredChainStart table index context = some result) : + result.output = table index := by + unfold resolveDeferredChainStart at hresult + dsimp only at hresult + cases hvalue : context.state.values index.coordinate with + | some output => + have hout := hagrees index output hvalue + rw [hvalue] at hresult + by_cases hhit : context.state.hitAt index.coordinate output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + exact hout + | none => + rw [hvalue] at hresult + by_cases hhit : context.state.hitAt index.coordinate (table index) + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + rfl + +def ResolveChainRel + (invariant : DeferredResolution → QueryCache HashSpec → Prop) : + Option DeferredResolution → Digest × QueryCache HashSpec → Prop + | none, _ => True + | some resolved, (value, cache) => + value = truncateHash resolved.output ∧ invariant resolved cache + +theorem relTriple_resolveDeferredChainStart + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) (cache : QueryCache HashSpec) + (invariant : DeferredResolution → QueryCache HashSpec → Prop) + (hagrees : StartTableAgrees context.state table) + (hpreserves : ∀ result, + resolveDeferredChainStart table index context = some result → + invariant result cache) : + RelTriple + (pure (resolveDeferredChainStart table index context) : + ProbComp (Option DeferredResolution)) + (pure (truncateHash (table index), cache) : ProbComp (Digest × QueryCache HashSpec)) + (ResolveChainRel invariant) := by + apply relTriple_pure_pure + cases hresult : resolveDeferredChainStart table index context with + | none => trivial + | some result => + exact ⟨congrArg truncateHash + (resolveDeferredChainStart_output_of_agrees table index context result hagrees hresult) |>.symm, + hpreserves result hresult⟩ + +noncomputable def resolveDeferredChainPrefix + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + (steps : Nat) → steps ≤ chainLength - 1 → DeferredContext → + ProbComp (Option DeferredResolution) + | 0, _, context => pure (resolveDeferredChainStart table + ⟨lay, tree, leafIdx, chainIdx⟩ context) + | steps + 1, hsteps, context => do + let previous ← resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps + (by omega) context + match previous with + | none => pure none + | some previous => + resolveDeferredPositionValue + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) previous.toDeferredContext + +theorem resolveDeferredChainPrefix_preserves_state_values + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps context result, + some result ∈ support + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) → + result.state.values = context.state.values + | 0, hsteps, context, result, hresult => by + simp only [resolveDeferredChainPrefix, support_pure, Set.mem_singleton_iff] at hresult + unfold resolveDeferredChainStart at hresult + simp only [OtsSecretIndex.coordinate] at hresult + cases hvalue : context.state.values + (.chainStart lay tree leafIdx chainIdx) with + | none => + simp only [hvalue] at hresult + split at hresult <;> simp_all [LazyRevealProbe.State.clearPending] + | some output => + simp only [hvalue] at hresult + split at hresult <;> simp_all [LazyRevealProbe.State.clearPending] + | steps + 1, hsteps, context, result, hresult => by + rw [resolveDeferredChainPrefix, mem_support_bind_iff] at hresult + obtain ⟨previous, hprevious, hrest⟩ := hresult + cases previous with + | none => simp at hrest + | some previous => + have hpreviousValues := + resolveDeferredChainPrefix_preserves_state_values table lay tree leafIdx chainIdx + steps (by omega) context previous hprevious + have hrestValues := resolveDeferredPositionValue_preserves_state_values + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + previous.toDeferredContext result (by simpa using hrest) + exact hrestValues.trans hpreviousValues + +theorem privateStateAgrees_resolveDeferredChainPrefix + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps context result, + some result ∈ support + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) → + PrivateStateAgrees result.toDeferredContext context + | 0, hsteps, context, result, hresult => by + simp only [resolveDeferredChainPrefix, support_pure, Set.mem_singleton_iff] at hresult + exact privateStateAgrees_resolveDeferredChainStart table + ⟨lay, tree, leafIdx, chainIdx⟩ context result hresult.symm + | steps + 1, hsteps, context, result, hresult => by + rw [resolveDeferredChainPrefix, mem_support_bind_iff] at hresult + obtain ⟨previous, hprevious, hrest⟩ := hresult + cases previous with + | none => simp at hrest + | some previous => + exact ⟨ + (privateStateAgrees_resolveDeferredPositionValue + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + previous.toDeferredContext result (by simpa using hrest)).1.trans + (privateStateAgrees_resolveDeferredChainPrefix table lay tree leafIdx chainIdx + steps (by omega) context previous hprevious).1, + (privateStateAgrees_resolveDeferredPositionValue + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + previous.toDeferredContext result (by simpa using hrest)).2.1.trans + (privateStateAgrees_resolveDeferredChainPrefix table lay tree leafIdx chainIdx + steps (by omega) context previous hprevious).2.1, + (privateStateAgrees_resolveDeferredPositionValue + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + previous.toDeferredContext result (by simpa using hrest)).2.2.trans + (privateStateAgrees_resolveDeferredChainPrefix table lay tree leafIdx chainIdx + steps (by omega) context previous hprevious).2.2⟩ + +theorem resolveDeferredChainPrefix_installs_last + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (steps : Nat) + (hsteps : steps + 1 ≤ chainLength - 1) (context : DeferredContext) + (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx (steps + 1) + hsteps context)) : + result.values (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) = + some result.output := by + rw [resolveDeferredChainPrefix, mem_support_bind_iff] at hresult + obtain ⟨previous, _hprevious, hrest⟩ := hresult + cases previous with + | none => simp at hrest + | some previous => + exact resolveDeferredPositionValue_installs + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + previous.toDeferredContext result (by simpa using hrest) + +theorem resolveDeferredChainPrefix_resolves_last + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (steps : Nat) + (hsteps : steps + 1 ≤ chainLength - 1) (context : DeferredContext) + (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx (steps + 1) + hsteps context)) : + result.toDeferredContext.positionValue + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) = some result.output := by + rw [resolveDeferredChainPrefix, mem_support_bind_iff] at hresult + obtain ⟨previousOption, _hprevious, hrest⟩ := hresult + cases previousOption with + | none => simp at hrest + | some previous => + exact resolveDeferredPositionValue_resolves + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + previous.toDeferredContext result (by simpa using hrest) + +def DeferredChainPrefixAvailable (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (steps : Nat) + (context : DeferredContext) : Prop := + ∀ step : ChainStep, step.val < steps → ∃ output, + context.positionValue (.chain lay tree leafIdx chainIdx step) = some output + +theorem deferredChainPrefixAvailable_of_resolve + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps context result, + some result ∈ support + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) → + DeferredChainPrefixAvailable lay tree leafIdx chainIdx steps result.toDeferredContext + | 0, hsteps, context, result, hresult => by + intro step hlt + omega + | steps + 1, hsteps, context, result, hresult => by + rw [resolveDeferredChainPrefix, mem_support_bind_iff] at hresult + obtain ⟨previousOption, hprevious, hrest⟩ := hresult + cases previousOption with + | none => simp at hrest + | some previous => + have hpreviousAvailable := deferredChainPrefixAvailable_of_resolve + table lay tree leafIdx chainIdx steps (by omega) context previous hprevious + have hrest' : some result ∈ support + (resolveDeferredPositionValue + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + previous.toDeferredContext) := by + simpa using hrest + intro step hlt + by_cases heq : step.val = steps + · have hstep : step = ⟨steps, by omega⟩ := Fin.ext heq + refine ⟨result.output, ?_⟩ + simpa [hstep] using resolveDeferredPositionValue_resolves + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + previous.toDeferredContext result hrest' + · have hbefore : step.val < steps := by omega + obtain ⟨output, houtput⟩ := hpreviousAvailable step hbefore + refine ⟨output, ?_⟩ + exact resolveDeferredPositionValue_preserves_positionValue + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + (.chain lay tree leafIdx chainIdx step) previous.toDeferredContext result output + houtput hrest' + +theorem resolveDeferredChainPrefix_preserves_positionValue + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps context result position output, + context.positionValue position = some output → + some result ∈ support + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) → + result.toDeferredContext.positionValue position = some output + | 0, hsteps, context, result, position, output, hknown, hresult => by + simp only [resolveDeferredChainPrefix, support_pure, Set.mem_singleton_iff] at hresult + exact resolveDeferredChainStart_preserves_positionValue table + ⟨lay, tree, leafIdx, chainIdx⟩ context result position output hknown hresult.symm + | steps + 1, hsteps, context, result, position, output, hknown, hresult => by + rw [resolveDeferredChainPrefix, mem_support_bind_iff] at hresult + obtain ⟨previousOption, hprevious, hrest⟩ := hresult + cases previousOption with + | none => simp at hrest + | some previous => + have hmiddle := resolveDeferredChainPrefix_preserves_positionValue + table lay tree leafIdx chainIdx steps (by omega) context previous position output + hknown hprevious + exact resolveDeferredPositionValue_preserves_positionValue + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) position + previous.toDeferredContext result output hmiddle (by simpa using hrest) + +theorem relTriple_resolveDeferredChainPrefix + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (context : DeferredContext) (cache : QueryCache HashSpec) + (invariant : Nat → DeferredResolution → QueryCache HashSpec → Prop) + (hagrees : StartTableAgrees context.state table) + (hstartPreserves : ∀ result, + resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context = some result → + invariant 0 result cache) + (hinput : ∀ steps (hsteps : steps < chainLength - 1) previous middleCache, + invariant steps previous middleCache → + ResolveInputAgrees (.chain lay tree leafIdx chainIdx ⟨steps, hsteps⟩) + previous.toDeferredContext + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx ⟨steps, hsteps⟩) + (digestBytes (truncateHash previous.output))) middleCache) + (hqueryPreserves : ∀ steps (hsteps : steps < chainLength - 1) previous middleCache + result output finalCache, + invariant steps previous middleCache → + some result ∈ support + (resolveDeferredPositionValue + (.chain lay tree leafIdx chainIdx ⟨steps, hsteps⟩) previous.toDeferredContext) → + ResolveQueryRel + (tweakableHashInput parameter (.chain lay tree leafIdx chainIdx ⟨steps, hsteps⟩) + (digestBytes (truncateHash previous.output))) middleCache + (some result) (output, finalCache) → + invariant (steps + 1) result finalCache) : + ∀ steps hsteps, + RelTriple + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (chainWalk parameter lay tree leafIdx chainIdx 0 steps + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)))).run cache) + (ResolveChainRel (invariant steps)) + | 0, hsteps => by + simpa [resolveDeferredChainPrefix, chainWalk] using + relTriple_resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ + context cache (invariant 0) hagrees hstartPreserves + | steps + 1, hsteps => by + rw [resolveDeferredChainPrefix, chainWalk, simulateQ_bind, StateT.run_bind] + apply relTriple_bind + (relTriple_resolveDeferredChainPrefix parameter table lay tree leafIdx chainIdx context + cache invariant hagrees hstartPreserves hinput hqueryPreserves steps (by omega)) + intro previous rightResult hprefix + cases previous with + | none => + have hbase := relTriple_true + (pure (none : Option DeferredResolution) : ProbComp (Option DeferredResolution)) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (if hstep : 0 + steps < chainLength - 1 then + tweakableHash parameter + (.chain lay tree leafIdx chainIdx ⟨0 + steps, hstep⟩) + (digestBytes rightResult.1) + else pure 0)).run rightResult.2) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = none) (by + intro result hresult + simpa using hresult) + exact relTriple_post_mono hsupported (by + intro leftResult _ hrelation + rw [hrelation.2] + trivial) + | some previous => + rcases rightResult with ⟨previousValue, middleCache⟩ + rcases hprefix with ⟨hvalue, hinvariant⟩ + subst previousValue + rw [dif_pos (show 0 + steps < chainLength - 1 by omega)] + let step : ChainStep := ⟨steps, by omega⟩ + have hposition : (⟨0 + steps, by omega⟩ : ChainStep) = step := by + apply Fin.ext + simp [step] + rw [hposition] + unfold tweakableHash oracleHash + rw [simulateQ_bind, StateT.run_bind] + simp only [simulateQ_pure, StateT.run_pure] + let input := tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx step) (digestBytes (truncateHash previous.output)) + have hagreesInput : ResolveInputAgrees + (.chain lay tree leafIdx chainIdx step) previous.toDeferredContext input middleCache := + hinput steps (by omega) previous middleCache hinvariant + have hquery := relTriple_resolveDeferredPositionValue_of_inputAgrees + (.chain lay tree leafIdx chainIdx step) previous.toDeferredContext input middleCache + hagreesInput + have hbound : RelTriple + (resolveDeferredPositionValue (.chain lay tree leafIdx chainIdx step) + previous.toDeferredContext >>= fun resolved => pure resolved) + ((randomOracle input).run middleCache >>= fun result => + pure (truncateHash result.1, result.2)) + (ResolveChainRel (invariant (steps + 1))) := by + have hquerySupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hquery + (fun resolved => resolved ∈ support + (resolveDeferredPositionValue + (.chain lay tree leafIdx chainIdx step) previous.toDeferredContext)) + (fun resolved hresolved => hresolved) + apply relTriple_bind hquerySupported + intro resolved queryResult hrelationSupported + rcases hrelationSupported with ⟨hrelation, hresolvedSupport⟩ + apply relTriple_pure_pure + cases resolved with + | none => trivial + | some resolved => + rcases queryResult with ⟨queryOutput, finalCache⟩ + refine ⟨?_, hqueryPreserves steps (by omega) previous middleCache resolved + queryOutput finalCache hinvariant hresolvedSupport hrelation⟩ + exact congrArg truncateHash hrelation.1 |>.symm + simpa [step, input] using hbound + +noncomputable def resolveDeferredChains + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : List ChainIndex → DeferredContext → + ProbComp (Option DeferredContext) + | [], context => pure (some context) + | chainIdx :: remaining, context => do + let resolved ← resolveDeferredChainPrefix table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context + match resolved with + | none => pure none + | some resolved => + resolveDeferredChains table lay tree leafIdx remaining resolved.toDeferredContext + +theorem resolveDeferredChains_preserves_positionValue + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + ∀ chains context result position output, + context.positionValue position = some output → + some result ∈ support (resolveDeferredChains table lay tree leafIdx chains context) → + result.positionValue position = some output + | [], context, result, position, output, hknown, hresult => by + simp [resolveDeferredChains] at hresult + subst result + exact hknown + | chainIdx :: remaining, context, result, position, output, hknown, hresult => by + rw [resolveDeferredChains, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hmiddle := resolveDeferredChainPrefix_preserves_positionValue + table lay tree leafIdx chainIdx (chainLength - 1) (by omega) context resolved + position output hknown hresolved + exact resolveDeferredChains_preserves_positionValue table lay tree leafIdx remaining + resolved.toDeferredContext result position output hmiddle (by simpa using hrest) + +def DeferredChainsAvailable (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chains : List ChainIndex) (context : DeferredContext) : Prop := + ∀ chainIdx, chainIdx ∈ chains → + DeferredChainPrefixAvailable lay tree leafIdx chainIdx (chainLength - 1) context + +theorem deferredChainsAvailable_of_resolve + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + ∀ chains context result, + some result ∈ support (resolveDeferredChains table lay tree leafIdx chains context) → + DeferredChainsAvailable lay tree leafIdx chains result + | [], context, result, hresult => by + intro chainIdx hmem + simp at hmem + | chainIdx :: remaining, context, result, hresult => by + rw [resolveDeferredChains, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hhead := deferredChainPrefixAvailable_of_resolve table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context resolved hresolved + have htail := deferredChainsAvailable_of_resolve table lay tree leafIdx remaining + resolved.toDeferredContext result (by simpa using hrest) + intro other hmem + simp only [List.mem_cons] at hmem + rcases hmem with heq | hmem + · subst other + intro step hstep + obtain ⟨output, houtput⟩ := hhead step hstep + refine ⟨output, ?_⟩ + exact resolveDeferredChains_preserves_positionValue table lay tree leafIdx remaining + resolved.toDeferredContext result + (.chain lay tree leafIdx chainIdx step) output houtput (by simpa using hrest) + · exact htail other hmem + +noncomputable def resolveDeferredOtsLeaf + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (context : DeferredContext) : + ProbComp (Option DeferredResolution) := do + let chains ← resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) context + match chains with + | none => pure none + | some chains => + resolveDeferredPositionValue (.leaf lay tree leafIdx) chains + +theorem resolveDeferredOtsLeaf_preserves_positionValue + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (context : DeferredContext) (result : DeferredResolution) + (position : Position) (output : HashOutput) + (hknown : context.positionValue position = some output) + (hresult : some result ∈ support + (resolveDeferredOtsLeaf table lay tree leafIdx context)) : + result.toDeferredContext.positionValue position = some output := by + rw [resolveDeferredOtsLeaf, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + have hmiddle := resolveDeferredChains_preserves_positionValue table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) context chains position output + hknown hchains + exact resolveDeferredPositionValue_preserves_positionValue + (.leaf lay tree leafIdx) position chains result output hmiddle (by simpa using hrest) + +theorem resolveDeferredOtsLeaf_resolves + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredOtsLeaf table lay tree leafIdx context)) : + result.toDeferredContext.positionValue (.leaf lay tree leafIdx) = some result.output := by + rw [resolveDeferredOtsLeaf, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, _hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + exact resolveDeferredPositionValue_resolves (.leaf lay tree leafIdx) chains result + (by simpa using hrest) + +def DeferredOtsLeafChildrenAvailable (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (context : DeferredContext) : Prop := + ∀ chainIdx : ChainIndex, ∃ output, + context.positionValue + (.chain lay tree leafIdx chainIdx Position.lastChainStep) = some output + +theorem deferredOtsLeafChildrenAvailable_of_resolve + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredOtsLeaf table lay tree leafIdx context)) : + DeferredOtsLeafChildrenAvailable lay tree leafIdx result.toDeferredContext := by + rw [resolveDeferredOtsLeaf, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + have havailable := deferredChainsAvailable_of_resolve table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) context chains hchains + intro chainIdx + have hmem : chainIdx ∈ List.ofFn (fun chainIdx : ChainIndex => chainIdx) := by + simp only [List.mem_ofFn] + exact ⟨chainIdx, rfl⟩ + obtain ⟨output, houtput⟩ := havailable chainIdx hmem Position.lastChainStep (by + simp [Position.lastChainStep, chainLength, winternitzBits]) + refine ⟨output, ?_⟩ + exact resolveDeferredPositionValue_preserves_positionValue (.leaf lay tree leafIdx) + (.chain lay tree leafIdx chainIdx Position.lastChainStep) chains result output houtput + (by simpa using hrest) + +noncomputable def resolveDeferredTreeNode + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + (level nodeIdx : Nat) → level ≤ maxLayerHeight → DeferredContext → + ProbComp (Option DeferredResolution) + | 0, nodeIdx, _, context => + resolveDeferredOtsLeaf table lay tree (leafOfNat nodeIdx) context + | level + 1, nodeIdx, hlevel, context => do + let left ← resolveDeferredTreeNode table lay tree level (2 * nodeIdx) (by omega) context + match left with + | none => pure none + | some left => do + let right ← resolveDeferredTreeNode table lay tree level (2 * nodeIdx + 1) + (by omega) left.toDeferredContext + match right with + | none => pure none + | some right => + resolveDeferredPositionValue + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) + right.toDeferredContext + +def deferredTreePosition (lay : Layer) (tree : TreeIndex) : + (level nodeIdx : Nat) → level ≤ maxLayerHeight → Position + | 0, nodeIdx, _ => .leaf lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx, hlevel => + .node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx) + +theorem resolveDeferredTreeNode_preserves_positionValue + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel context result position output, + context.positionValue position = some output → + some result ∈ support + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) → + result.toDeferredContext.positionValue position = some output + | 0, nodeIdx, hlevel, context, result, position, output, hknown, hresult => + resolveDeferredOtsLeaf_preserves_positionValue table lay tree (leafOfNat nodeIdx) + context result position output hknown hresult + | level + 1, nodeIdx, hlevel, context, result, position, output, hknown, hresult => by + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨leftOption, hleft, hafterLeft⟩ := hresult + cases leftOption with + | none => simp at hafterLeft + | some left => + rw [mem_support_bind_iff] at hafterLeft + obtain ⟨rightOption, hright, hafterRight⟩ := hafterLeft + cases rightOption with + | none => simp at hafterRight + | some right => + have hleftKnown := resolveDeferredTreeNode_preserves_positionValue table lay tree + level (2 * nodeIdx) (by omega) context left position output hknown hleft + have hrightKnown := resolveDeferredTreeNode_preserves_positionValue table lay tree + level (2 * nodeIdx + 1) (by omega) left.toDeferredContext right position output + hleftKnown hright + exact resolveDeferredPositionValue_preserves_positionValue + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) position + right.toDeferredContext result output hrightKnown (by simpa using hafterRight) + +theorem resolveDeferredTreeNode_resolves + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel context result, + some result ∈ support + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) → + result.toDeferredContext.positionValue + (deferredTreePosition lay tree level nodeIdx hlevel) = some result.output + | 0, nodeIdx, hlevel, context, result, hresult => + resolveDeferredOtsLeaf_resolves table lay tree (leafOfNat nodeIdx) context result hresult + | level + 1, nodeIdx, hlevel, context, result, hresult => by + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨leftOption, _hleft, hafterLeft⟩ := hresult + cases leftOption with + | none => simp at hafterLeft + | some left => + rw [mem_support_bind_iff] at hafterLeft + obtain ⟨rightOption, _hright, hafterRight⟩ := hafterLeft + cases rightOption with + | none => simp at hafterRight + | some right => + simpa [deferredTreePosition] using resolveDeferredPositionValue_resolves + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) + right.toDeferredContext result (by simpa using hafterRight) + +theorem resolveDeferredTreeNode_children_available + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) (hlevel : level + 1 ≤ maxLayerHeight) + (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredTreeNode table lay tree (level + 1) nodeIdx hlevel context)) : + (∃ output, result.toDeferredContext.positionValue + (deferredTreePosition lay tree level (2 * nodeIdx) (by omega)) = some output) ∧ + (∃ output, result.toDeferredContext.positionValue + (deferredTreePosition lay tree level (2 * nodeIdx + 1) (by omega)) = some output) := by + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨leftOption, hleft, hafterLeft⟩ := hresult + cases leftOption with + | none => simp at hafterLeft + | some left => + rw [mem_support_bind_iff] at hafterLeft + obtain ⟨rightOption, hright, hafterRight⟩ := hafterLeft + cases rightOption with + | none => simp at hafterRight + | some right => + have hleftValue := resolveDeferredTreeNode_resolves table lay tree level + (2 * nodeIdx) (by omega) context left hleft + have hleftInRight := resolveDeferredTreeNode_preserves_positionValue table lay tree level + (2 * nodeIdx + 1) (by omega) left.toDeferredContext right + (deferredTreePosition lay tree level (2 * nodeIdx) (by omega)) left.output + hleftValue hright + have hrightValue := resolveDeferredTreeNode_resolves table lay tree level + (2 * nodeIdx + 1) (by omega) left.toDeferredContext right hright + have hfinalLeft := resolveDeferredPositionValue_preserves_positionValue + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) + (deferredTreePosition lay tree level (2 * nodeIdx) (by omega)) + right.toDeferredContext result left.output hleftInRight (by simpa using hafterRight) + have hfinalRight := resolveDeferredPositionValue_preserves_positionValue + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) + (deferredTreePosition lay tree level (2 * nodeIdx + 1) (by omega)) + right.toDeferredContext result right.output hrightValue (by simpa using hafterRight) + exact ⟨⟨left.output, hfinalLeft⟩, ⟨right.output, hfinalRight⟩⟩ + +noncomputable def resolveDeferredPosition + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) : ProbComp (Option DeferredResolution) := + match position with + | .chain lay tree leafIdx chainIdx step => + resolveDeferredChainPrefix table lay tree leafIdx chainIdx (step.val + 1) + (by have := step.isLt; omega) context + | .leaf lay tree leafIdx => resolveDeferredOtsLeaf table lay tree leafIdx context + | .node lay tree level nodeIdx => + resolveDeferredTreeNode table lay tree (level.val + 1) nodeIdx + (by have := level.isLt; omega) context + | position => resolveDeferredPositionValue position context + +def ResolvableOtsPosition : Position → Prop + | .chain _ _ _ _ _ => True + | .leaf _ _ _ => True + | .node _ _ level nodeIdx => + 2 ^ (level.val + 1) * (nodeIdx.val + 1) ≤ 2 ^ maxLayerHeight + | _ => False + +noncomputable def resolveDeferredReveal + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) : ProbComp (Option DeferredResolution) := by + classical + exact if ResolvableOtsPosition position then + resolveDeferredPosition table position context + else + resolveDeferredPositionValue position context + +theorem resolveDeferredPosition_preserves_positionValue + (table : OtsSecretIndex → HashOutput) (target : Position) + (context : DeferredContext) (result : DeferredResolution) + (position : Position) (output : HashOutput) + (hknown : context.positionValue position = some output) + (hresult : some result ∈ support + (resolveDeferredPosition table target context)) : + result.toDeferredContext.positionValue position = some output := by + cases target with + | chain lay tree leafIdx chainIdx step => + exact resolveDeferredChainPrefix_preserves_positionValue table lay tree leafIdx chainIdx + (step.val + 1) (by have := step.isLt; omega) context result position output hknown hresult + | leaf lay tree leafIdx => + exact resolveDeferredOtsLeaf_preserves_positionValue table lay tree leafIdx context result + position output hknown hresult + | node lay tree level nodeIdx => + exact resolveDeferredTreeNode_preserves_positionValue table lay tree (level.val + 1) + nodeIdx (by have := level.isLt; omega) context result position output hknown hresult + | ftsLeaf index tree leafIdx => + exact resolveDeferredPositionValue_preserves_positionValue (.ftsLeaf index tree leafIdx) + position context result output hknown hresult + | ftsNode index tree level nodeIdx => + exact resolveDeferredPositionValue_preserves_positionValue (.ftsNode index tree level nodeIdx) + position context result output hknown hresult + | ftsRoots index => + exact resolveDeferredPositionValue_preserves_positionValue (.ftsRoots index) + position context result output hknown hresult + +theorem resolveDeferredPosition_resolves + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPosition table position context)) : + result.toDeferredContext.positionValue position = some result.output := by + cases position with + | chain lay tree leafIdx chainIdx step => + simpa using resolveDeferredChainPrefix_resolves_last table lay tree leafIdx chainIdx + step.val (by have := step.isLt; omega) context result hresult + | leaf lay tree leafIdx => + exact resolveDeferredOtsLeaf_resolves table lay tree leafIdx context result hresult + | node lay tree level nodeIdx => + have hleaf : leafOfNat nodeIdx.val = nodeIdx := leafOfNat_val nodeIdx + simpa [deferredTreePosition, hleaf] using resolveDeferredTreeNode_resolves table lay tree + (level.val + 1) nodeIdx (by have := level.isLt; omega) context result hresult + | ftsLeaf index tree leafIdx => + exact resolveDeferredPositionValue_resolves (.ftsLeaf index tree leafIdx) context result hresult + | ftsNode index tree level nodeIdx => + exact resolveDeferredPositionValue_resolves (.ftsNode index tree level nodeIdx) context result + hresult + | ftsRoots index => + exact resolveDeferredPositionValue_resolves (.ftsRoots index) context result hresult + +structure ResolvedRunResult (alpha : Type) where + context : DeferredContext + remaining : Nat + value : alpha + table : OtsSecretIndex → HashOutput + +noncomputable def runResolvedFromTable + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) : + ProbComp (Option (ResolvedRunResult alpha)) := + OracleComp.construct + (C := fun _ : OracleComp (LazyRevealProbe.World Coordinate) alpha => + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → + ProbComp (Option (ResolvedRunResult alpha))) + (fun value context remaining table => + pure (some ⟨context, remaining, value, table⟩)) + (fun input _next recursivelyRun context fuel table => + match input with + | .uniform n => do + let output ← liftM (unifSpec.query n) + recursivelyRun output context fuel table + | .hashOutput => do + let output ← LazyRevealProbe.sampleHashOutput + recursivelyRun output context fuel table + | .ensure coordinate => + recursivelyRun () + { context with state := context.state.ensure coordinate } fuel table + | .probe coordinate candidate => + match fuel with + | 0 => pure none + | remaining + 1 => + if coordinate ∈ context.state.revealed then + recursivelyRun () context remaining table + else + recursivelyRun () + { context with state := context.state.addPending coordinate candidate } + remaining table + | .peek coordinate => + recursivelyRun (context.state.values coordinate) context fuel table + | .publish coordinate => + recursivelyRun () + { context with state := context.state.publish coordinate } fuel table + | .reveal coordinate => do + let resolved ← match coordinate with + | .chainStart lay tree leafIdx chainIdx => + pure (resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context) + | .position position => resolveDeferredReveal table position context + match resolved with + | none => pure none + | some resolved => + recursivelyRun resolved.output + { state := context.state.materialize coordinate resolved.output + values := resolved.values } + fuel table) + computation context fuel table + +theorem runResolvedFromTable_uniform_query_bind + (context : DeferredContext) (fuel n : Nat) + (table : OtsSecretIndex → HashOutput) + (next : Fin (n + 1) → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runResolvedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) (.uniform n)) : + OracleComp (LazyRevealProbe.World Coordinate) (Fin (n + 1))) >>= next) = (do + let output ← liftM (unifSpec.query n) + runResolvedFromTable context fuel table (next output)) := by + rw [runResolvedFromTable, OracleComp.construct_query_bind] + rfl + +theorem runResolvedFromTable_hashOutput_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runResolvedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) .hashOutput) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = (do + let output ← LazyRevealProbe.sampleHashOutput + runResolvedFromTable context fuel table (next output)) := by + rw [runResolvedFromTable, OracleComp.construct_query_bind] + rfl + +theorem runResolvedFromTable_ensure_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runResolvedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.ensure coordinate)) : OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runResolvedFromTable + { context with state := context.state.ensure coordinate } fuel table (next ()) := by + rw [runResolvedFromTable, OracleComp.construct_query_bind] + rfl + +theorem runResolvedFromTable_probe_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) (candidate : Digest) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runResolvedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.probe coordinate candidate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + match fuel with + | 0 => pure none + | remaining + 1 => + if coordinate ∈ context.state.revealed then + runResolvedFromTable context remaining table (next ()) + else + runResolvedFromTable + { context with state := context.state.addPending coordinate candidate } + remaining table (next ()) := by + rw [runResolvedFromTable, OracleComp.construct_query_bind] + rfl + +theorem runResolvedFromTable_peek_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Option HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runResolvedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.peek coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) (Option HashOutput)) >>= next) = + runResolvedFromTable context fuel table + (next (context.state.values coordinate)) := by + rw [runResolvedFromTable, OracleComp.construct_query_bind] + rfl + +theorem runResolvedFromTable_publish_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runResolvedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.publish coordinate)) : OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runResolvedFromTable + { context with state := context.state.publish coordinate } fuel table (next ()) := by + rw [runResolvedFromTable, OracleComp.construct_query_bind] + rfl + +theorem runResolvedFromTable_reveal_query_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runResolvedFromTable context fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.reveal coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = (do + let resolved ← match coordinate with + | .chainStart lay tree leafIdx chainIdx => + pure (resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context) + | .position position => resolveDeferredReveal table position context + match resolved with + | none => pure none + | some resolved => + runResolvedFromTable + { state := context.state.materialize coordinate resolved.output + values := resolved.values } + fuel table (next resolved.output)) := by + cases coordinate <;> rw [runResolvedFromTable, OracleComp.construct_query_bind] <;> rfl + +theorem runResolvedFromTable_bind + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (left : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (next : alpha → OracleComp (LazyRevealProbe.World Coordinate) beta) : + runResolvedFromTable context fuel table (left >>= next) = + runResolvedFromTable context fuel table left >>= fun result => + match result with + | none => pure none + | some result => + runResolvedFromTable result.context result.remaining result.table + (next result.value) := by + induction left using OracleComp.inductionOn generalizing context fuel with + | pure value => simp [runResolvedFromTable] + | query_bind input continuation ih => + cases input with + | uniform n => + rw [bind_assoc, runResolvedFromTable_uniform_query_bind, + runResolvedFromTable_uniform_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output context fuel + | hashOutput => + rw [bind_assoc, runResolvedFromTable_hashOutput_query_bind, + runResolvedFromTable_hashOutput_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output context fuel + | ensure coordinate => + rw [bind_assoc, runResolvedFromTable_ensure_query_bind, + runResolvedFromTable_ensure_query_bind] + exact ih () { context with state := context.state.ensure coordinate } fuel + | probe coordinate candidate => + rw [bind_assoc, runResolvedFromTable_probe_query_bind, + runResolvedFromTable_probe_query_bind] + cases fuel with + | zero => simp + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () context remaining + · simp only [hrevealed, ↓reduceIte] + exact ih () + { context with state := context.state.addPending coordinate candidate } + remaining + | peek coordinate => + rw [bind_assoc, runResolvedFromTable_peek_query_bind, + runResolvedFromTable_peek_query_bind] + exact ih (context.state.values coordinate) context fuel + | publish coordinate => + rw [bind_assoc, runResolvedFromTable_publish_query_bind, + runResolvedFromTable_publish_query_bind] + exact ih () { context with state := context.state.publish coordinate } fuel + | reveal coordinate => + rw [bind_assoc, runResolvedFromTable_reveal_query_bind, + runResolvedFromTable_reveal_query_bind] + cases coordinate <;> simp only [bind_assoc] + all_goals + apply bind_congr + intro resolved + cases resolved with + | none => simp + | some resolved => + exact ih resolved.output + { state := context.state.materialize _ resolved.output + values := resolved.values } + fuel + +theorem runResolvedFromTable_revealCoordinate + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (cache : SplitHashCache) : + runResolvedFromTable context fuel table + ((revealCoordinate coordinate).run cache) = (do + let resolved ← match coordinate with + | .chainStart lay tree leafIdx chainIdx => + pure (resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context) + | .position position => resolveDeferredReveal table position context + match resolved with + | none => pure none + | some resolved => + pure (some ⟨ + { state := context.state.materialize coordinate resolved.output + values := resolved.values }, + fuel, + (truncateHash resolved.output, + Function.update cache (.hidden coordinate) (some resolved.output)), + table⟩)) := by + rw [revealCoordinate_run, LazyRevealProbe.revealQuery, + runResolvedFromTable_reveal_query_bind] + cases coordinate <;> simp [runResolvedFromTable] + +theorem value_ne_none_of_mem_runResolvedFromTable_revealCoordinate + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (cache : SplitHashCache) (result : ResolvedRunResult (Digest × SplitHashCache)) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table ((revealCoordinate coordinate).run cache))) : + result.context.state.values coordinate ≠ none := by + rw [runResolvedFromTable_revealCoordinate] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + cases hresolve : resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context with + | none => simp [hresolve] at hresult + | some resolved => + simp [hresolve] at hresult + subst result + simp [LazyRevealProbe.State.materialize] + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, _hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + simp at hrest + subst result + simp [LazyRevealProbe.State.materialize] + +theorem runResolvedFromTable_revealCoordinateOutput + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (cache : SplitHashCache) : + runResolvedFromTable context fuel table + ((revealCoordinateOutput coordinate).run cache) = (do + let resolved ← match coordinate with + | .chainStart lay tree leafIdx chainIdx => + pure (resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context) + | .position position => resolveDeferredReveal table position context + match resolved with + | none => pure none + | some resolved => + pure (some ⟨ + { state := context.state.materialize coordinate resolved.output + values := resolved.values }, + fuel, + (resolved.output, + Function.update cache (.hidden coordinate) (some resolved.output)), + table⟩)) := by + rw [revealCoordinateOutput_run, LazyRevealProbe.revealQuery, + runResolvedFromTable_reveal_query_bind] + cases coordinate <;> simp [runResolvedFromTable] + +theorem value_of_mem_runResolvedFromTable_revealCoordinateOutput + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (cache : SplitHashCache) (result : ResolvedRunResult (HashOutput × SplitHashCache)) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table + ((revealCoordinateOutput coordinate).run cache))) : + result.context.state.values coordinate = some result.value.1 := by + rw [runResolvedFromTable_revealCoordinateOutput] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + cases hresolve : resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context with + | none => simp [hresolve] at hresult + | some resolved => + simp [hresolve] at hresult + subst result + simp [LazyRevealProbe.State.materialize] + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, _hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + simp at hrest + subst result + simp [LazyRevealProbe.State.materialize] + +theorem runResolvedFromTable_revealPosition + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (position : Position) + (cache : SplitHashCache) : + runResolvedFromTable context fuel table + ((revealPosition position).run cache) = (do + let resolved ← resolveDeferredReveal table position context + match resolved with + | none => pure none + | some resolved => + pure (some ⟨ + { state := context.state.materialize (.position position) resolved.output + values := resolved.values }, + fuel, + (truncateHash resolved.output, + Function.update cache (.hidden (.position position)) (some resolved.output)), + table⟩)) := by + rw [revealPosition, runResolvedFromTable_revealCoordinate] + +theorem runResolvedFromTable_revealChainStart_of_agrees + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (cache : SplitHashCache) (hagrees : StartTableAgrees context.state table) + (hclean : ¬context.state.hitAt index.coordinate (table index)) : + runResolvedFromTable context fuel table + ((revealChainStart index.lay index.tree index.leafIdx index.chainIdx).run cache) = + pure (some ⟨ + { state := context.state.materialize index.coordinate (table index) + values := context.values }, + fuel, + (truncateHash (table index), + Function.update cache (.hidden index.coordinate) (some (table index))), + table⟩) := by + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + rw [revealChainStart, runResolvedFromTable_revealCoordinate] + simp only [OtsSecretIndex.coordinate] at hagrees hclean ⊢ + rw [resolveDeferredChainStart_of_agrees table ⟨lay, tree, leafIdx, chainIdx⟩ + context hagrees hclean] + simp [OtsSecretIndex.coordinate] + +def ResolvedAdministrative + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (value : alpha) : Prop := + ∀ context cache fuel table, ∃ finalContext, + runResolvedFromTable context fuel table (computation.run cache) = + pure (some ⟨finalContext, fuel, (value, cache), table⟩) ∧ + finalContext.state.pending = context.state.pending ∧ + finalContext.state.values = context.state.values ∧ + finalContext.values = context.values + +def ResolvedPreservesPublished + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ context cache fuel table result, + PublishedValues context.state → + some result ∈ support + (runResolvedFromTable context fuel table (computation.run cache)) → + PublishedValues result.context.state + +theorem PublishedValues.materialize + {state : LazyRevealProbe.State Coordinate} (hpublished : PublishedValues state) + (coordinate : Coordinate) (output : HashOutput) : + PublishedValues (state.materialize coordinate output) := by + intro other hrevealed + by_cases heq : other = coordinate + · subst other + simp [LazyRevealProbe.State.materialize] + · simpa [LazyRevealProbe.State.materialize, heq] using + hpublished other hrevealed + +theorem ResolvedPreservesPublished.pure (value : alpha) : + ResolvedPreservesPublished + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro context cache fuel table result hpublished hresult + simp [runResolvedFromTable] at hresult + subst result + exact hpublished + +theorem ResolvedPreservesPublished.bind + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : ResolvedPreservesPublished left) + (hnext : ∀ value, ResolvedPreservesPublished (next value)) : + ResolvedPreservesPublished (left >>= next) := by + intro context cache fuel table result hpublished hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨middle, hmiddle, hrest⟩ := hresult + cases middle with + | none => simp at hrest + | some middle => + exact hnext middle.value.1 middle.context middle.value.2 middle.remaining middle.table result + (hleft context cache fuel table middle hpublished hmiddle) hrest + +theorem resolvedPreservesPublished_ensureCoordinate (coordinate : Coordinate) : + ResolvedPreservesPublished (ensureCoordinate coordinate) := by + intro context cache fuel table result hpublished hresult + unfold ensureCoordinate at hresult + rw [StateT.run_liftM, LazyRevealProbe.ensureQuery, + runResolvedFromTable_ensure_query_bind] at hresult + simp [runResolvedFromTable] at hresult + subst result + simpa [PublishedValues, LazyRevealProbe.State.ensure] using hpublished + +theorem resolvedPreservesPublished_sequenceFin {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hcomponent : ∀ index, ResolvedPreservesPublished (computation index)) : + ResolvedPreservesPublished (sequenceFin computation) := by + induction n with + | zero => simpa [sequenceFin] using ResolvedPreservesPublished.pure Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomponent 0).bind fun _ => + (ih (fun index : Fin n => computation index.succ) + (fun index => hcomponent index.succ)).bind fun _ => + ResolvedPreservesPublished.pure _ + +theorem resolvedAdministrative_pure (value : alpha) : + ResolvedAdministrative + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + value := by + intro context cache fuel table + exact ⟨context, by simp [runResolvedFromTable]⟩ + +theorem ResolvedAdministrative.bind + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + {leftValue : alpha} {value : beta} + (hleft : ResolvedAdministrative left leftValue) + (hnext : ResolvedAdministrative (next leftValue) value) : + ResolvedAdministrative (left >>= next) value := by + intro context cache fuel table + obtain ⟨middleContext, hleftRun, hleftPending, hleftValues, hleftDeferred⟩ := + hleft context cache fuel table + obtain ⟨finalContext, hnextRun, hnextPending, hnextValues, hnextDeferred⟩ := + hnext middleContext cache fuel table + refine ⟨finalContext, ?_, hnextPending.trans hleftPending, + hnextValues.trans hleftValues, hnextDeferred.trans hleftDeferred⟩ + rw [StateT.run_bind, runResolvedFromTable_bind, hleftRun] + simpa using hnextRun + +theorem ResolvedAdministrative.run + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {value : alpha} (hadministrative : ResolvedAdministrative computation value) + (context : DeferredContext) (cache : SplitHashCache) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + ∃ finalContext, + runResolvedFromTable context fuel table (computation.run cache) = + pure (some ⟨finalContext, fuel, (value, cache), table⟩) ∧ + finalContext.state.pending = context.state.pending ∧ + finalContext.state.values = context.state.values ∧ + finalContext.values = context.values := + hadministrative context cache fuel table + +theorem resolvedAdministrative_ensureCoordinate (coordinate : Coordinate) : + ResolvedAdministrative (ensureCoordinate coordinate) () := by + intro context cache fuel table + refine ⟨{ context with state := context.state.ensure coordinate }, ?_, rfl, rfl, rfl⟩ + unfold ensureCoordinate + rw [StateT.run_liftM, LazyRevealProbe.ensureQuery, + runResolvedFromTable_ensure_query_bind] + simp [runResolvedFromTable] + +theorem resolvedAdministrative_publishCoordinate (coordinate : Coordinate) : + ResolvedAdministrative (publishCoordinate coordinate) () := by + intro context cache fuel table + refine ⟨{ context with state := context.state.publish coordinate }, ?_, rfl, rfl, rfl⟩ + unfold publishCoordinate + rw [StateT.run_liftM, LazyRevealProbe.publishQuery, + runResolvedFromTable_publish_query_bind] + simp [runResolvedFromTable] + +theorem resolvedAdministrative_sequenceFin {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (value : Fin n → alpha) + (hcomponent : ∀ index, ResolvedAdministrative (computation index) (value index)) : + ResolvedAdministrative (sequenceFin computation) value := by + induction n with + | zero => + have hvalue : value = Fin.elim0 := Subsingleton.elim _ _ + subst value + simpa [sequenceFin] using + (resolvedAdministrative_pure (value := Fin.elim0) : + ResolvedAdministrative (pure Fin.elim0) Fin.elim0) + | succ n ih => + rw [sequenceFin] + have htail := ih (fun index : Fin n => computation index.succ) + (fun index : Fin n => value index.succ) (fun index => hcomponent index.succ) + let assembled : Fin (n + 1) → alpha := + Fin.cases (value 0) (fun index : Fin n => value index.succ) + have hpure : ResolvedAdministrative + (pure assembled : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Fin (n + 1) → alpha)) + assembled := resolvedAdministrative_pure assembled + have hrest : ResolvedAdministrative + (sequenceFin (fun index : Fin n => computation index.succ) >>= fun tail => + pure (Fin.cases (value 0) tail)) assembled := by + exact htail.bind hpure + have hhead : ResolvedAdministrative + (computation 0 >>= fun head => + sequenceFin (fun index : Fin n => computation index.succ) >>= fun tail => + pure (Fin.cases head tail)) assembled := by + exact (hcomponent 0).bind hrest + have hassembled : assembled = value := by + funext index + cases index using Fin.cases <;> rfl + simpa only [hassembled] using hhead + +theorem resolvedAdministrative_ensureFullChain + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ResolvedAdministrative (ensureFullChain lay tree leafIdx chainIdx) () := by + unfold ensureFullChain + apply ResolvedAdministrative.bind + (resolvedAdministrative_sequenceFin + (fun step : ChainStep => + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step))) + (fun _ => ()) + (fun step => resolvedAdministrative_ensureCoordinate + (.position (.chain lay tree leafIdx chainIdx step)))) + exact resolvedAdministrative_pure () + +theorem resolvedPreservesPublished_ensureFullChain + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ResolvedPreservesPublished (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (resolvedPreservesPublished_sequenceFin + (fun step : ChainStep => + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step))) + (fun step => resolvedPreservesPublished_ensureCoordinate + (.position (.chain lay tree leafIdx chainIdx step)))).bind fun _ => + ResolvedPreservesPublished.pure () + +theorem resolvedAdministrative_ensureChainPrefix + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (digit : Digit) : + ResolvedAdministrative (ensureChainPrefix lay tree leafIdx chainIdx digit) () := by + unfold ensureChainPrefix + apply ResolvedAdministrative.bind + (resolvedAdministrative_sequenceFin + (fun step : ChainStep => + if step.val < digit.val then + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + else pure ()) + (fun _ => ()) (fun step => by + by_cases hstep : step.val < digit.val + · rw [if_pos hstep] + exact resolvedAdministrative_ensureCoordinate + (.position (.chain lay tree leafIdx chainIdx step)) + · rw [if_neg hstep] + exact resolvedAdministrative_pure ())) + exact resolvedAdministrative_pure () + +theorem resolvedPreservesPublished_ensureChainPrefix + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (digit : Digit) : + ResolvedPreservesPublished (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (resolvedPreservesPublished_sequenceFin + (fun step : ChainStep => + if step.val < digit.val then + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + else pure ()) + (fun step => by + by_cases hstep : step.val < digit.val + · rw [if_pos hstep] + exact resolvedPreservesPublished_ensureCoordinate _ + · rw [if_neg hstep] + exact ResolvedPreservesPublished.pure ())).bind fun _ => + ResolvedPreservesPublished.pure () + +theorem resolvedAdministrative_ensureOtsLeaf + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ResolvedAdministrative (ensureOtsLeaf lay tree leafIdx) () := by + unfold ensureOtsLeaf + have hchains := resolvedAdministrative_sequenceFin + (fun chainIdx : ChainIndex => ensureFullChain lay tree leafIdx chainIdx) + (fun _ => ()) (fun chainIdx => + resolvedAdministrative_ensureFullChain lay tree leafIdx chainIdx) + exact hchains.bind + (resolvedAdministrative_ensureCoordinate (.position (.leaf lay tree leafIdx))) + +theorem resolvedPreservesPublished_ensureOtsLeaf + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ResolvedPreservesPublished (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (resolvedPreservesPublished_sequenceFin + (fun chainIdx : ChainIndex => ensureFullChain lay tree leafIdx chainIdx) + (fun chainIdx => resolvedPreservesPublished_ensureFullChain lay tree leafIdx chainIdx)).bind + fun _ => resolvedPreservesPublished_ensureCoordinate (.position (.leaf lay tree leafIdx)) + +theorem resolvedAdministrative_ensureTreeNode (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, ResolvedAdministrative (ensureTreeNode lay tree level nodeIdx) () + | 0, nodeIdx => resolvedAdministrative_ensureOtsLeaf lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + apply ResolvedAdministrative.bind + (resolvedAdministrative_ensureTreeNode lay tree level (2 * nodeIdx)) + apply ResolvedAdministrative.bind + (resolvedAdministrative_ensureTreeNode lay tree level (2 * nodeIdx + 1)) + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact resolvedAdministrative_ensureCoordinate + (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact resolvedAdministrative_pure () + +theorem resolvedPreservesPublished_ensureTreeNode (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, ResolvedPreservesPublished (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => resolvedPreservesPublished_ensureOtsLeaf lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (resolvedPreservesPublished_ensureTreeNode lay tree level (2 * nodeIdx)).bind + fun _ => (resolvedPreservesPublished_ensureTreeNode lay tree level + (2 * nodeIdx + 1)).bind fun _ => by + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact resolvedPreservesPublished_ensureCoordinate _ + · rw [dif_neg hlevel] + exact ResolvedPreservesPublished.pure () + +theorem resolvedAdministrative_ensureTreePath + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ResolvedAdministrative (ensureTreePath lay tree leafIdx) () := by + unfold ensureTreePath + apply ResolvedAdministrative.bind + (resolvedAdministrative_sequenceFin + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + ensureTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + else pure ()) + (fun _ => ()) (fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + exact resolvedAdministrative_ensureTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · rw [if_neg hlevel] + exact resolvedAdministrative_pure ())) + exact resolvedAdministrative_pure () + +theorem resolvedPreservesPublished_ensureTreePath + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ResolvedPreservesPublished (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (resolvedPreservesPublished_sequenceFin + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + ensureTreeNode lay tree level.val (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + else pure ()) + (fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + exact resolvedPreservesPublished_ensureTreeNode lay tree level.val _ + · rw [if_neg hlevel] + exact ResolvedPreservesPublished.pure ())).bind fun _ => + ResolvedPreservesPublished.pure () + +theorem runResolvedFromTable_maskedChainValue_zero + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) (hdigit : digit.val = 0) + (context : DeferredContext) (cache : SplitHashCache) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (hagrees : StartTableAgrees context.state table) + (hclean : ¬context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) (table ⟨lay, tree, leafIdx, chainIdx⟩)) : + ∃ reservedContext : DeferredContext, + runResolvedFromTable context fuel table + ((maskedChainValue lay tree leafIdx chainIdx digit).run cache) = + pure (some ⟨ + { state := reservedContext.state.materialize + (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) + values := reservedContext.values }, + fuel, + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + Function.update cache (.hidden (.chainStart lay tree leafIdx chainIdx)) + (some (table ⟨lay, tree, leafIdx, chainIdx⟩))), + table⟩) := by + obtain ⟨reservedContext, hreserve, hpending, hstateValues, _hdeferred⟩ := + (resolvedAdministrative_ensureChainPrefix lay tree leafIdx chainIdx digit).run + context cache fuel table + have hreservedAgrees : StartTableAgrees reservedContext.state table := by + intro index output hvalue + apply hagrees index output + rw [← hstateValues] + exact hvalue + have hreservedClean : ¬reservedContext.state.hitAt + (.chainStart lay tree leafIdx chainIdx) (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + unfold LazyRevealProbe.State.hitAt LazyRevealProbe.State.pendingAt at hclean ⊢ + rw [hpending] + exact hclean + refine ⟨reservedContext, ?_⟩ + unfold maskedChainValue + rw [StateT.run_bind, runResolvedFromTable_bind, hreserve] + simp only [pure_bind] + rw [dif_pos hdigit] + exact runResolvedFromTable_revealChainStart_of_agrees reservedContext fuel table + ⟨lay, tree, leafIdx, chainIdx⟩ cache hreservedAgrees hreservedClean + +theorem runResolvedFromTable_maskedChainValue_positive + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) (hdigit : digit.val ≠ 0) + (context : DeferredContext) (cache : SplitHashCache) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : + let step : ChainStep := ⟨digit.val - 1, by + have := digit.isLt + omega⟩ + ∃ reservedContext : DeferredContext, + runResolvedFromTable context fuel table + ((maskedChainValue lay tree leafIdx chainIdx digit).run cache) = (do + let resolved ← resolveDeferredPosition table + (.chain lay tree leafIdx chainIdx step) reservedContext + match resolved with + | none => pure none + | some resolved => + pure (some ⟨ + { state := reservedContext.state.materialize + (.position (.chain lay tree leafIdx chainIdx step)) resolved.output + values := resolved.values }, + fuel, + (truncateHash resolved.output, + Function.update cache + (.hidden (.position (.chain lay tree leafIdx chainIdx step))) + (some resolved.output)), + table⟩)) := by + dsimp only + obtain ⟨reservedContext, hreserve, _hpending, _hstateValues, _hdeferred⟩ := + (resolvedAdministrative_ensureChainPrefix lay tree leafIdx chainIdx digit).run + context cache fuel table + refine ⟨reservedContext, ?_⟩ + unfold maskedChainValue + rw [StateT.run_bind, runResolvedFromTable_bind, hreserve] + simp only [pure_bind] + rw [dif_neg hdigit] + simpa [resolveDeferredReveal, ResolvableOtsPosition] using + runResolvedFromTable_revealPosition reservedContext fuel table + (.chain lay tree leafIdx chainIdx ⟨digit.val - 1, by + have := digit.isLt + omega⟩) cache + +noncomputable def finalizeResolvedCoordinates + (coordinates : List Coordinate) (context : DeferredContext) + (table : OtsSecretIndex → HashOutput) : + ProbComp (Option DeferredContext) := + match coordinates with + | [] => pure (some context) + | coordinate :: remaining => + match context.state.values coordinate with + | some _ => + finalizeResolvedCoordinates remaining + { context with state := context.state.clearPending coordinate } table + | none => do + let resolved ← match coordinate with + | .chainStart lay tree leafIdx chainIdx => + pure (resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context) + | .position position => resolveDeferredPositionValue position context + match resolved with + | none => pure none + | some resolved => + finalizeResolvedCoordinates remaining + { state := resolved.state.complete coordinate resolved.output + values := resolved.values } + table + +@[simp] theorem clearPending_complete_self + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (output : HashOutput) : + (state.clearPending coordinate).complete coordinate output = + state.complete coordinate output := by + rcases state with ⟨pending, values, revealed, ensured⟩ + simp [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.complete, + LazyRevealProbe.State.pendingAway] + +theorem finalizeResolvedCoordinates_cons_of_state_value + (coordinate : Coordinate) (remaining : List Coordinate) + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) + (output : HashOutput) (hvalue : context.state.values coordinate = some output) : + finalizeResolvedCoordinates (coordinate :: remaining) context table = + finalizeResolvedCoordinates remaining + { context with state := context.state.clearPending coordinate } table := by + rw [finalizeResolvedCoordinates] + simp [hvalue] + +theorem finalizeResolvedCoordinates_cons_position_of_deferred_value + (position : Position) (remaining : List Coordinate) + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) + (output : HashOutput) + (hstate : context.state.values (.position position) = none) + (hvalue : context.values position = some output) : + finalizeResolvedCoordinates (.position position :: remaining) context table = + if context.state.hitAt (.position position) output then + (pure none : ProbComp (Option DeferredContext)) + else finalizeResolvedCoordinates remaining + { state := context.state.complete (.position position) output + values := context.values } + table := by + rw [finalizeResolvedCoordinates] + simp only [hstate] + rw [resolveDeferredPositionValue_of_deferred_value position context output hstate hvalue] + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] + · simp only [hhit, ↓reduceIte, pure_bind] + rw [clearPending_complete_self] + +theorem finalizeResolvedCoordinates_cons_position_fresh + (position : Position) (remaining : List Coordinate) + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) + (hstate : context.state.values (.position position) = none) + (hvalue : context.values position = none) : + finalizeResolvedCoordinates (.position position :: remaining) context table = (do + let output ← LazyRevealProbe.sampleHashOutput + (if context.state.hitAt (.position position) output then + (pure none : ProbComp (Option DeferredContext)) + else finalizeResolvedCoordinates remaining + ({ state := context.state.complete (.position position) output + values := context.values.install position output } : DeferredContext) + table)) := by + rw [finalizeResolvedCoordinates] + simp only [hstate] + rw [resolveDeferredPositionValue_fresh position context hstate hvalue] + simp only [bind_assoc] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] + · simp only [hhit, ↓reduceIte, pure_bind] + rw [clearPending_complete_self] + +theorem resolveDeferredChainStart_of_missing + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) + (hmissing : context.state.values index.coordinate = none) : + resolveDeferredChainStart table index context = + if context.state.hitAt index.coordinate (table index) then none + else some ⟨ + { state := context.state.clearPending index.coordinate + values := context.values }, + table index⟩ := by + simp [resolveDeferredChainStart, hmissing] + +noncomputable def resolvedCompletionOutput (coordinate : Coordinate) + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) : ProbComp HashOutput := + match coordinate with + | .chainStart lay tree leafIdx chainIdx => pure (table ⟨lay, tree, leafIdx, chainIdx⟩) + | .position position => + match context.values position with + | some output => pure output + | none => LazyRevealProbe.sampleHashOutput + +def DeferredContext.completeResolved (context : DeferredContext) + (coordinate : Coordinate) (output : HashOutput) : DeferredContext := + match coordinate with + | .chainStart _ _ _ _ => + { context with state := context.state.complete coordinate output } + | .position position => + { state := context.state.complete coordinate output + values := context.values.install position output } + +theorem resolvedCompletionOutput_neverFails + (coordinate : Coordinate) (context : DeferredContext) + (table : OtsSecretIndex → HashOutput) : + Pr[⊥ | resolvedCompletionOutput coordinate context table] = 0 := by + cases coordinate with + | chainStart => simp [resolvedCompletionOutput] + | position position => + cases context.values position <;> + simp [resolvedCompletionOutput, LazyRevealProbe.sampleHashOutput] + +theorem finalizeResolvedCoordinates_cons_of_missing + (coordinate : Coordinate) (remaining : List Coordinate) + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) + (hmissing : context.state.values coordinate = none) : + finalizeResolvedCoordinates (coordinate :: remaining) context table = (do + let output ← resolvedCompletionOutput coordinate context table + (if context.state.hitAt coordinate output then + (pure none : ProbComp (Option DeferredContext)) + else finalizeResolvedCoordinates remaining + (context.completeResolved coordinate output) table)) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + have hmissing' : context.state.values index.coordinate = none := by + simpa [index, OtsSecretIndex.coordinate] using hmissing + rw [finalizeResolvedCoordinates] + simp only [hmissing] + rw [resolveDeferredChainStart_of_missing table index context hmissing'] + by_cases hhit : context.state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) + · simp [resolvedCompletionOutput, DeferredContext.completeResolved, index, + OtsSecretIndex.coordinate, hhit] + · simp [resolvedCompletionOutput, DeferredContext.completeResolved, index, + OtsSecretIndex.coordinate, hhit] + | position position => + cases hvalue : context.values position with + | some output => + rw [finalizeResolvedCoordinates_cons_position_of_deferred_value position remaining + context table output hmissing hvalue] + have hinstall : context.values.install position output = context.values := by + funext other + by_cases heq : other = position + · subst other + simp [DeferredStructuralValues.install, hvalue] + · simp [DeferredStructuralValues.install, heq] + simp [resolvedCompletionOutput, DeferredContext.completeResolved, hvalue, hinstall] + | none => + rw [finalizeResolvedCoordinates_cons_position_fresh position remaining context table + hmissing hvalue] + simp [resolvedCompletionOutput, DeferredContext.completeResolved, hvalue] + +theorem resolvedCompletionOutput_completeResolved_of_ne + (left right : Coordinate) (context : DeferredContext) + (table : OtsSecretIndex → HashOutput) (output : HashOutput) (hne : right ≠ left) : + resolvedCompletionOutput right (context.completeResolved left output) table = + resolvedCompletionOutput right context table := by + cases left with + | chainStart => cases right <;> rfl + | position left => + cases right with + | chainStart => rfl + | position right => + have hposition : right ≠ left := by + intro heq + subst right + exact hne rfl + simp [resolvedCompletionOutput, DeferredContext.completeResolved, + DeferredStructuralValues.install, hposition] + +theorem DeferredContext.completeResolved_comm + (context : DeferredContext) (left right : Coordinate) + (leftOutput rightOutput : HashOutput) (hne : left ≠ right) : + (context.completeResolved left leftOutput).completeResolved right rightOutput = + (context.completeResolved right rightOutput).completeResolved left leftOutput := by + have hstate := complete_comm context.state left right leftOutput rightOutput hne + cases left with + | chainStart => + cases right with + | chainStart => + simp [DeferredContext.completeResolved, hstate] + | position right => + simp [DeferredContext.completeResolved, hstate] + | position left => + cases right with + | chainStart => + simp [DeferredContext.completeResolved, hstate] + | position right => + have hposition : left ≠ right := by + intro heq + subst right + exact hne rfl + rcases context with ⟨state, values⟩ + simp only [DeferredContext.completeResolved] + rw [complete_comm state (.position left) (.position right) + leftOutput rightOutput hne] + congr 1 + exact Function.update_comm hposition (some leftOutput) (some rightOutput) values + +set_option maxRecDepth 100000 in +theorem evalDist_finalizeResolvedCoordinates_two_missing + (left right : Coordinate) (remaining : List Coordinate) + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) + (hne : left ≠ right) (hleft : context.state.values left = none) + (hright : context.state.values right = none) : + evalDist (finalizeResolvedCoordinates (left :: right :: remaining) context table) = + evalDist (do + let leftOutput ← resolvedCompletionOutput left context table + let rightOutput ← resolvedCompletionOutput right context table + (if context.state.hitAt left leftOutput then + (pure none : ProbComp (Option DeferredContext)) + else if context.state.hitAt right rightOutput then + pure none + else finalizeResolvedCoordinates remaining + (((context.completeResolved left leftOutput).completeResolved right rightOutput) : + DeferredContext) table)) := by + rw [finalizeResolvedCoordinates_cons_of_missing left (right :: remaining) context table hleft] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro leftOutput + by_cases hleftHit : context.state.hitAt left leftOutput + · rw [if_pos hleftHit] + simp only [hleftHit, ↓reduceIte] + exact OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (resolvedCompletionOutput right context table) + (resolvedCompletionOutput_neverFails right context table) (pure none) |>.symm + · rw [if_neg hleftHit] + simp only [hleftHit, ↓reduceIte] + have hrightValue : (context.completeResolved left leftOutput).state.values right = none := by + cases left <;> simp only [DeferredContext.completeResolved] <;> + rw [values_complete_of_ne context.state _ right leftOutput (Ne.symm hne), hright] + rw [finalizeResolvedCoordinates_cons_of_missing right remaining + (context.completeResolved left leftOutput) table hrightValue] + rw [resolvedCompletionOutput_completeResolved_of_ne left right context table leftOutput + (Ne.symm hne)] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro rightOutput + have hcompleteState : + (context.completeResolved left leftOutput).state = + context.state.complete left leftOutput := by + cases left <;> rfl + have hrightHit : + (context.completeResolved left leftOutput).state.hitAt right rightOutput ↔ + context.state.hitAt right rightOutput := by + rw [hcompleteState] + exact hitAt_complete_of_ne context.state left right leftOutput rightOutput (Ne.symm hne) + by_cases hhit : context.state.hitAt right rightOutput + · rw [if_pos (hrightHit.mpr hhit), if_pos hhit] + · rw [if_neg (mt hrightHit.mp hhit), if_neg hhit] + +set_option maxRecDepth 100000 in +theorem evalDist_finalizeResolvedCoordinates_swap_of_both_missing + (left right : Coordinate) (remaining : List Coordinate) + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) + (hne : left ≠ right) (hleft : context.state.values left = none) + (hright : context.state.values right = none) : + evalDist (finalizeResolvedCoordinates (left :: right :: remaining) context table) = + evalDist (finalizeResolvedCoordinates (right :: left :: remaining) context table) := by + rw [evalDist_finalizeResolvedCoordinates_two_missing left right remaining context table hne + hleft hright, + evalDist_finalizeResolvedCoordinates_two_missing right left remaining context table hne.symm + hright hleft] + rw [OracleComp.DeferredSampling.evalDist_bind_comm + (resolvedCompletionOutput left context table) + (resolvedCompletionOutput right context table)] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro rightOutput + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro leftOutput + by_cases hleftHit : context.state.hitAt left leftOutput + · simp [hleftHit] + · by_cases hrightHit : context.state.hitAt right rightOutput + · simp [hleftHit, hrightHit] + · simp only [hleftHit, hrightHit, ↓reduceIte] + rw [DeferredContext.completeResolved_comm context left right leftOutput rightOutput hne] + +theorem clearPending_completeResolved_comm + (context : DeferredContext) (left right : Coordinate) (output : HashOutput) : + ({ context with state := context.state.clearPending left }).completeResolved right output = + { context.completeResolved right output with + state := (context.completeResolved right output).state.clearPending left } := by + cases right <;> simp only [DeferredContext.completeResolved] <;> + rw [clearPending_complete_comm] + +set_option maxRecDepth 100000 in +theorem evalDist_finalizeResolvedCoordinates_swap_of_some_none + (left right : Coordinate) (remaining : List Coordinate) + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) + (leftOutput : HashOutput) (hne : left ≠ right) + (hleft : context.state.values left = some leftOutput) + (hright : context.state.values right = none) : + evalDist (finalizeResolvedCoordinates (left :: right :: remaining) context table) = + evalDist (finalizeResolvedCoordinates (right :: left :: remaining) context table) := by + rw [finalizeResolvedCoordinates_cons_of_state_value left (right :: remaining) context table + leftOutput hleft] + have hrightClear : + (context.state.clearPending left).values right = none := by + simpa only [values_clearPending] using hright + rw [finalizeResolvedCoordinates_cons_of_missing right remaining + { context with state := context.state.clearPending left } table hrightClear] + rw [finalizeResolvedCoordinates_cons_of_missing right (left :: remaining) context table hright] + have hcompletionOutput : resolvedCompletionOutput right + { context with state := context.state.clearPending left } table = + resolvedCompletionOutput right context table := by + cases right <;> rfl + rw [hcompletionOutput] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro rightOutput + have hrightHit : (context.state.clearPending left).hitAt right rightOutput ↔ + context.state.hitAt right rightOutput := + hitAt_clearPending_of_ne context.state left right rightOutput hne.symm + by_cases hhit : context.state.hitAt right rightOutput + · rw [if_pos (hrightHit.mpr hhit), if_pos hhit] + · rw [if_neg (mt hrightHit.mp hhit), if_neg hhit] + have hleftCompleted : + (context.completeResolved right rightOutput).state.values left = some leftOutput := by + have hstate : (context.completeResolved right rightOutput).state = + context.state.complete right rightOutput := by + cases right <;> rfl + rw [hstate, values_complete_of_ne context.state right left rightOutput hne, hleft] + rw [finalizeResolvedCoordinates_cons_of_state_value left remaining + (context.completeResolved right rightOutput) table leftOutput hleftCompleted] + rw [clearPending_completeResolved_comm context left right rightOutput] + +set_option maxRecDepth 100000 in +theorem evalDist_finalizeResolvedCoordinates_swap + (left right : Coordinate) (remaining : List Coordinate) + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) + (hne : left ≠ right) : + evalDist (finalizeResolvedCoordinates (left :: right :: remaining) context table) = + evalDist (finalizeResolvedCoordinates (right :: left :: remaining) context table) := by + cases hleft : context.state.values left with + | some leftOutput => + cases hright : context.state.values right with + | some rightOutput => + rw [finalizeResolvedCoordinates_cons_of_state_value left (right :: remaining) + context table leftOutput hleft, + finalizeResolvedCoordinates_cons_of_state_value right (left :: remaining) + context table rightOutput hright] + have hrightClear : (context.state.clearPending left).values right = + some rightOutput := by simpa only [values_clearPending] using hright + have hleftClear : (context.state.clearPending right).values left = + some leftOutput := by simpa only [values_clearPending] using hleft + rw [finalizeResolvedCoordinates_cons_of_state_value right remaining + { context with state := context.state.clearPending left } table rightOutput hrightClear, + finalizeResolvedCoordinates_cons_of_state_value left remaining + { context with state := context.state.clearPending right } table leftOutput hleftClear] + rw [clearPending_comm] + | none => + exact evalDist_finalizeResolvedCoordinates_swap_of_some_none left right remaining + context table leftOutput hne hleft hright + | none => + cases hright : context.state.values right with + | some rightOutput => + exact (evalDist_finalizeResolvedCoordinates_swap_of_some_none right left remaining + context table rightOutput hne.symm hright hleft).symm + | none => + exact evalDist_finalizeResolvedCoordinates_swap_of_both_missing left right remaining + context table hne hleft hright + +set_option maxRecDepth 100000 in +theorem evalDist_finalizeResolvedCoordinates_perm + {left right : List Coordinate} (hperm : left.Perm right) + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) : + evalDist (finalizeResolvedCoordinates left context table) = + evalDist (finalizeResolvedCoordinates right context table) := by + induction hperm generalizing context with + | nil => rfl + | cons coordinate hperm ih => + cases hvalue : context.state.values coordinate with + | some output => + rw [finalizeResolvedCoordinates_cons_of_state_value coordinate _ context table output + hvalue, + finalizeResolvedCoordinates_cons_of_state_value coordinate _ context table output + hvalue] + exact ih { context with state := context.state.clearPending coordinate } + | none => + rw [finalizeResolvedCoordinates_cons_of_missing coordinate _ context table hvalue, + finalizeResolvedCoordinates_cons_of_missing coordinate _ context table hvalue] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + by_cases hhit : context.state.hitAt coordinate output + · rw [if_pos hhit, if_pos hhit] + · rw [if_neg hhit, if_neg hhit] + exact ih (context.completeResolved coordinate output) + | swap left right remaining => + by_cases heq : left = right + · subst right + rfl + · exact (evalDist_finalizeResolvedCoordinates_swap left right remaining context table + heq).symm + | trans _ _ ihLeft ihRight => exact (ihLeft context).trans (ihRight context) + +theorem evalDist_finalizeResolvedCoordinates_move_to_front + (coordinate : Coordinate) (coordinates : List Coordinate) + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) + (hmem : coordinate ∈ coordinates) : + evalDist (finalizeResolvedCoordinates coordinates context table) = + evalDist (finalizeResolvedCoordinates + (coordinate :: coordinates.erase coordinate) context table) := + evalDist_finalizeResolvedCoordinates_perm (List.perm_cons_erase hmem) context table + +def DeferredContext.presamplePosition (context : DeferredContext) + (position : Position) (output : HashOutput) : DeferredContext := + { state := context.state.clearPending (.position position) + values := context.values.install position output } + +theorem clearPending_ensure_comm + (state : LazyRevealProbe.State Coordinate) (cleared ensured : Coordinate) : + (state.clearPending cleared).ensure ensured = + (state.ensure ensured).clearPending cleared := by + rfl + +theorem clearPending_publish_comm + (state : LazyRevealProbe.State Coordinate) (cleared published : Coordinate) : + (state.clearPending cleared).publish published = + (state.publish published).clearPending cleared := by + rfl + +theorem clearPending_addPending_comm_of_ne + (state : LazyRevealProbe.State Coordinate) (cleared added : Coordinate) + (candidate : Digest) (hne : added ≠ cleared) : + (state.clearPending cleared).addPending added candidate = + (state.addPending added candidate).clearPending cleared := by + rcases state with ⟨pending, values, revealed, ensured⟩ + simp [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.addPending, + LazyRevealProbe.State.pendingAway] + apply Finset.ext + intro entry + by_cases hpair : entry = (added, candidate) + · subst entry + simp [hne] + · simp [hpair] + +theorem presamplePosition_ensure + (context : DeferredContext) (position : Position) (output : HashOutput) + (coordinate : Coordinate) : + { context.presamplePosition position output with + state := (context.presamplePosition position output).state.ensure coordinate } = + ({ context with state := context.state.ensure coordinate } : + DeferredContext).presamplePosition position output := by + simp [DeferredContext.presamplePosition, clearPending_ensure_comm] + +theorem presamplePosition_publish + (context : DeferredContext) (position : Position) (output : HashOutput) + (coordinate : Coordinate) : + { context.presamplePosition position output with + state := (context.presamplePosition position output).state.publish coordinate } = + ({ context with state := context.state.publish coordinate } : + DeferredContext).presamplePosition position output := by + simp [DeferredContext.presamplePosition, clearPending_publish_comm] + +theorem presamplePosition_addPending_of_ne + (context : DeferredContext) (position : Position) (output : HashOutput) + (coordinate : Coordinate) (candidate : Digest) + (hne : coordinate ≠ .position position) : + { context.presamplePosition position output with + state := (context.presamplePosition position output).state.addPending + coordinate candidate } = + ({ context with state := context.state.addPending coordinate candidate } : + DeferredContext).presamplePosition position output := by + simp [DeferredContext.presamplePosition, + clearPending_addPending_comm_of_ne _ _ _ _ hne] + +theorem coordinates_clearPending_of_mem_ensured + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (hensured : coordinate ∈ state.ensured) : + (state.clearPending coordinate).coordinates = state.coordinates := by + rcases state with ⟨pending, values, revealed, ensured⟩ + simp only [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.coordinates] + apply Finset.ext + intro other + simp only [Finset.mem_union, Finset.mem_image, LazyRevealProbe.State.pendingAway, + Finset.mem_filter] + constructor + · intro hmem + rcases hmem with hmem | ⟨entry, ⟨hentry, _hne⟩, heq⟩ + · exact Or.inl hmem + · exact Or.inr ⟨entry, hentry, heq⟩ + · intro hmem + rcases hmem with hmem | ⟨entry, hentry, heq⟩ + · exact Or.inl hmem + · by_cases hsame : entry.1 = coordinate + · have hother : other = coordinate := heq ▸ hsame + exact Or.inl (hother.symm ▸ hensured) + · exact Or.inr ⟨entry, ⟨hentry, hsame⟩, heq⟩ + +theorem not_hitAt_clearPending_self + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (output : HashOutput) : + ¬(state.clearPending coordinate).hitAt coordinate output := by + simp [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, + LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway] + +theorem clearPending_eq_self_of_not_mem_coordinates + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (hnotMem : coordinate ∉ state.coordinates) : + state.clearPending coordinate = state := by + rcases state with ⟨pending, values, revealed, ensured⟩ + simp only [LazyRevealProbe.State.clearPending] + congr 1 + apply Finset.filter_eq_self.2 + intro entry hentry + simp only [ne_eq] + intro heq + apply hnotMem + apply Finset.mem_union_right + apply Finset.mem_image.2 + exact ⟨entry, hentry, heq⟩ + +theorem not_hitAt_of_not_mem_coordinates + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (output : HashOutput) (hnotMem : coordinate ∉ state.coordinates) : + ¬state.hitAt coordinate output := by + have hclear := clearPending_eq_self_of_not_mem_coordinates state coordinate hnotMem + simpa only [hclear] using not_hitAt_clearPending_self state coordinate output + +theorem DeferredContext.Valid.clearPending + {context : DeferredContext} (hvalid : context.Valid) + (coordinate : Coordinate) : + ({ context with state := context.state.clearPending coordinate } : + DeferredContext).Valid := by + constructor + · intro position output hvalue + exact hvalid.1 position output hvalue + · intro other output hvalue + by_cases heq : other = coordinate + · subst other + exact not_hitAt_clearPending_self context.state coordinate output + · exact (hitAt_clearPending_of_ne context.state coordinate other output heq).not.mpr + (hvalid.2 other output hvalue) + +theorem DeferredContext.Valid.clearPending_install + {context : DeferredContext} (hvalid : context.Valid) + (position : Position) (output : HashOutput) + (hcompatible : ∀ existing, + context.state.values (.position position) = some existing → existing = output) : + ({ state := context.state.clearPending (.position position) + values := context.values.install position output } : DeferredContext).Valid := by + constructor + · intro other otherOutput hvalue + by_cases heq : other = position + · subst other + have hsame : otherOutput = output := hcompatible otherOutput hvalue + subst otherOutput + simp [DeferredStructuralValues.install] + · simpa [DeferredStructuralValues.install, heq] using + hvalid.1 other otherOutput hvalue + · intro coordinate candidate hvalue + by_cases heq : coordinate = .position position + · subst coordinate + exact not_hitAt_clearPending_self context.state (.position position) candidate + · exact (hitAt_clearPending_of_ne context.state (.position position) + coordinate candidate heq).not.mpr (hvalid.2 coordinate candidate hvalue) + +set_option maxRecDepth 100000 in +theorem evalDist_finalizeResolvedCoordinates_defer_position + (position : Position) (coordinates : List Coordinate) + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) + (hmem : Coordinate.position position ∈ coordinates) + (hstate : context.state.values (.position position) = none) + (hvalue : context.values position = none) : + evalDist (finalizeResolvedCoordinates coordinates context table) = + evalDist (do + let output ← LazyRevealProbe.sampleHashOutput + (if context.state.hitAt (.position position) output then + (pure none : ProbComp (Option DeferredContext)) + else finalizeResolvedCoordinates coordinates + (context.presamplePosition position output) table)) := by + calc + _ = evalDist (finalizeResolvedCoordinates + (.position position :: coordinates.erase (.position position)) context table) := + evalDist_finalizeResolvedCoordinates_move_to_front (.position position) coordinates + context table hmem + _ = evalDist (do + let output ← LazyRevealProbe.sampleHashOutput + (if context.state.hitAt (.position position) output then + (pure none : ProbComp (Option DeferredContext)) + else finalizeResolvedCoordinates (coordinates.erase (.position position)) + ({ state := context.state.complete (.position position) output + values := context.values.install position output } : DeferredContext) + table)) := congrArg evalDist + (finalizeResolvedCoordinates_cons_position_fresh position + (coordinates.erase (.position position)) context table hstate hvalue) + _ = _ := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + have hpresampledState : + (context.presamplePosition position output).state.values + (.position position) = none := by + exact hstate + have hpresampledValue : + (context.presamplePosition position output).values position = some output := by + simp [DeferredContext.presamplePosition, DeferredStructuralValues.install] + have hhead := finalizeResolvedCoordinates_cons_position_of_deferred_value position + (coordinates.erase (.position position)) (context.presamplePosition position output) + table output hpresampledState hpresampledValue + have hclean : ¬(context.presamplePosition position output).state.hitAt + (.position position) output := + not_hitAt_clearPending_self context.state (.position position) output + have hmove := evalDist_finalizeResolvedCoordinates_move_to_front + (.position position) coordinates (context.presamplePosition position output) table hmem + rw [hhead, if_neg hclean] at hmove + have hcompleted : + ({ state := (context.presamplePosition position output).state.complete + (.position position) output + values := (context.presamplePosition position output).values } : + DeferredContext) = + ({ state := context.state.complete (.position position) output + values := context.values.install position output } : DeferredContext) := by + simp [DeferredContext.presamplePosition] + rw [hcompleted] at hmove + exact hmove.symm + +theorem hitAt_addPending_self_iff + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (candidate : Digest) (output : HashOutput) : + (state.addPending coordinate candidate).hitAt coordinate output ↔ + state.hitAt coordinate output ∨ truncateHash output = candidate := by + simp [LazyRevealProbe.State.hitAt, LazyRevealProbe.State.pendingAt, + LazyRevealProbe.State.addPending, or_comm] + +@[simp] theorem clearPending_addPending_complete_self + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (candidate : Digest) (output : HashOutput) : + ((state.clearPending coordinate).addPending coordinate candidate).complete + coordinate output = + ((state.addPending coordinate candidate).clearPending coordinate).complete + coordinate output := by + rcases state with ⟨pending, values, revealed, ensured⟩ + simp [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.addPending, + LazyRevealProbe.State.complete, LazyRevealProbe.State.pendingAway] + apply Finset.ext + intro entry + by_cases haway : entry.1 ≠ coordinate + · have hpair : entry ≠ (coordinate, candidate) := by + intro heq + subst entry + exact haway rfl + simp [haway, hpair] + · simp [haway] + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_probe_self_finalize_fresh + (position : Position) (candidate : Digest) (coordinates : List Coordinate) + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) + (hmem : Coordinate.position position ∈ coordinates) + (hstate : context.state.values (.position position) = none) + (hvalue : context.values position = none) : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => (pure none : ProbComp (Option DeferredContext)) + | some resolved => + finalizeResolvedCoordinates coordinates + { resolved.toDeferredContext with + state := resolved.state.addPending (.position position) candidate } + table) = + evalDist (finalizeResolvedCoordinates coordinates + { context with state := context.state.addPending (.position position) candidate } + table) := by + rw [resolveDeferredPositionValue_fresh position context hstate hvalue] + simp only [bind_assoc] + rw [evalDist_finalizeResolvedCoordinates_defer_position position coordinates + { context with state := context.state.addPending (.position position) candidate } + table hmem] + · apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + by_cases holdHit : context.state.hitAt (.position position) output + · rw [if_pos holdHit] + have hnewHit : + (context.state.addPending (.position position) candidate).hitAt + (.position position) output := + (hitAt_addPending_self_iff context.state (.position position) candidate output).2 + (Or.inl holdHit) + rw [if_pos hnewHit] + simp + · rw [if_neg holdHit] + by_cases hcandidate : truncateHash output = candidate + · have hnewHit : + (context.state.addPending (.position position) candidate).hitAt + (.position position) output := + (hitAt_addPending_self_iff context.state (.position position) candidate output).2 + (Or.inr hcandidate) + rw [if_pos hnewHit] + let leftContext : DeferredContext := + { state := + (context.presamplePosition position output).state.addPending + (.position position) candidate + values := (context.presamplePosition position output).values } + have hleftState : leftContext.state.values (.position position) = none := hstate + have hleftValue : leftContext.values position = some output := by + simp [leftContext, DeferredContext.presamplePosition, + DeferredStructuralValues.install] + have hleftHit : leftContext.state.hitAt (.position position) output := by + rw [hitAt_addPending_self_iff] + exact Or.inr hcandidate + have hleftMove := evalDist_finalizeResolvedCoordinates_move_to_front + (.position position) coordinates leftContext table hmem + rw [finalizeResolvedCoordinates_cons_position_of_deferred_value position + (coordinates.erase (.position position)) leftContext table output hleftState + hleftValue, if_pos hleftHit] at hleftMove + change evalDist (finalizeResolvedCoordinates coordinates leftContext table) = + evalDist (pure none) + exact hleftMove + · have hnewHit : + ¬(context.state.addPending (.position position) candidate).hitAt + (.position position) output := by + rw [hitAt_addPending_self_iff] + exact not_or_intro holdHit hcandidate + rw [if_neg hnewHit] + let leftContext : DeferredContext := + { state := + (context.presamplePosition position output).state.addPending + (.position position) candidate + values := (context.presamplePosition position output).values } + let rightContext : DeferredContext := + ({ context with + state := context.state.addPending (.position position) candidate } : + DeferredContext).presamplePosition position output + change evalDist (finalizeResolvedCoordinates coordinates leftContext table) = + evalDist (finalizeResolvedCoordinates coordinates rightContext table) + have hleftState : leftContext.state.values (.position position) = none := hstate + have hrightState : rightContext.state.values (.position position) = none := hstate + have hleftValue : leftContext.values position = some output := by + simp [leftContext, DeferredContext.presamplePosition, + DeferredStructuralValues.install] + have hrightValue : rightContext.values position = some output := by + simp [rightContext, DeferredContext.presamplePosition, + DeferredStructuralValues.install] + have hleftClean : ¬leftContext.state.hitAt (.position position) output := by + rw [hitAt_addPending_self_iff] + exact not_or_intro + (not_hitAt_clearPending_self context.state (.position position) output) + hcandidate + have hrightClean : ¬rightContext.state.hitAt (.position position) output := by + exact not_hitAt_clearPending_self + (context.state.addPending (.position position) candidate) + (.position position) output + have hleftMove := evalDist_finalizeResolvedCoordinates_move_to_front + (.position position) coordinates leftContext table hmem + have hrightMove := evalDist_finalizeResolvedCoordinates_move_to_front + (.position position) coordinates rightContext table hmem + rw [finalizeResolvedCoordinates_cons_position_of_deferred_value position + (coordinates.erase (.position position)) leftContext table output hleftState + hleftValue, if_neg hleftClean] at hleftMove + rw [finalizeResolvedCoordinates_cons_position_of_deferred_value position + (coordinates.erase (.position position)) rightContext table output hrightState + hrightValue, if_neg hrightClean] at hrightMove + rw [hleftMove, hrightMove] + congr 3 + simp [leftContext, rightContext, DeferredContext.presamplePosition, + DeferredStructuralValues.install] + · exact hstate + · exact hvalue + +theorem evalDist_resolveDeferredPositionValue_fresh_then_finalize + (position : Position) (coordinates : List Coordinate) + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) + (hmem : Coordinate.position position ∈ coordinates) + (hstate : context.state.values (.position position) = none) + (hvalue : context.values position = none) : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + (match resolved with + | none => (pure none : ProbComp (Option DeferredContext)) + | some resolved => finalizeResolvedCoordinates coordinates + (resolved.toDeferredContext) table)) = + evalDist (finalizeResolvedCoordinates coordinates context table) := by + rw [resolveDeferredPositionValue_fresh position context hstate hvalue] + simp only [bind_assoc] + rw [evalDist_finalizeResolvedCoordinates_defer_position position coordinates context table + hmem hstate hvalue] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] + · simp [hhit, DeferredContext.presamplePosition] + +@[simp] theorem clearPending_idem + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) : + (state.clearPending coordinate).clearPending coordinate = + state.clearPending coordinate := by + rcases state with ⟨pending, values, revealed, ensured⟩ + simp [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway] + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredPositionValue_then_finalize + (position : Position) (coordinates : List Coordinate) + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) + (hmem : Coordinate.position position ∈ coordinates) + (hmaterialized : ∀ output, + context.state.values (.position position) = some output → + context.values position = some output ∧ + ¬context.state.hitAt (.position position) output) : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + (match resolved with + | none => (pure none : ProbComp (Option DeferredContext)) + | some resolved => finalizeResolvedCoordinates coordinates + resolved.toDeferredContext table)) = + evalDist (finalizeResolvedCoordinates coordinates context table) := by + cases hstate : context.state.values (.position position) with + | some output => + obtain ⟨hvalue, hclean⟩ := hmaterialized output hstate + rw [resolveDeferredPositionValue_of_state_value position context output hstate, + if_neg hclean] + simp only [pure_bind] + have hinstall : context.values.install position output = context.values := by + funext other + by_cases heq : other = position + · subst other + simp [DeferredStructuralValues.install, hvalue] + · simp [DeferredStructuralValues.install, heq] + have hclearedValue : + (context.state.clearPending (.position position)).values + (.position position) = some output := by + exact hstate + calc + evalDist (finalizeResolvedCoordinates coordinates + { state := context.state.clearPending (.position position) + values := context.values.install position output } table) = + evalDist (finalizeResolvedCoordinates + (.position position :: coordinates.erase (.position position)) + { state := context.state.clearPending (.position position) + values := context.values.install position output } table) := + (evalDist_finalizeResolvedCoordinates_move_to_front + (.position position) coordinates + { state := context.state.clearPending (.position position) + values := context.values.install position output } + table hmem) + _ = evalDist (finalizeResolvedCoordinates + (coordinates.erase (.position position)) + { state := context.state.clearPending (.position position) + values := context.values } table) := by + rw [finalizeResolvedCoordinates_cons_of_state_value + (.position position) (coordinates.erase (.position position)) + { state := context.state.clearPending (.position position) + values := context.values.install position output } + table output hclearedValue] + simp [hinstall] + _ = evalDist (finalizeResolvedCoordinates + (.position position :: coordinates.erase (.position position)) + context table) := by + rw [finalizeResolvedCoordinates_cons_of_state_value + (.position position) (coordinates.erase (.position position)) + context table output hstate] + _ = evalDist (finalizeResolvedCoordinates coordinates context table) := + evalDist_finalizeResolvedCoordinates_move_to_front + (.position position) coordinates context table hmem |>.symm + | none => + cases hvalue : context.values position with + | none => + exact evalDist_resolveDeferredPositionValue_fresh_then_finalize position coordinates + context table hmem hstate hvalue + | some output => + rw [resolveDeferredPositionValue_of_deferred_value position context output hstate + hvalue] + by_cases hhit : context.state.hitAt (.position position) output + · rw [if_pos hhit] + simp only [pure_bind] + have hmove := evalDist_finalizeResolvedCoordinates_move_to_front + (.position position) coordinates context table hmem + rw [finalizeResolvedCoordinates_cons_position_of_deferred_value position + (coordinates.erase (.position position)) context table output hstate hvalue, + if_pos hhit] at hmove + simpa using hmove.symm + · rw [if_neg hhit] + simp only [pure_bind] + have hclearedState : + (context.state.clearPending (.position position)).values + (.position position) = none := hstate + have hclearedValue : context.values position = some output := hvalue + have hclearedClean : + ¬(context.state.clearPending (.position position)).hitAt + (.position position) output := + not_hitAt_clearPending_self context.state (.position position) output + calc + evalDist (finalizeResolvedCoordinates coordinates + { state := context.state.clearPending (.position position) + values := context.values } table) = + evalDist (finalizeResolvedCoordinates + (.position position :: coordinates.erase (.position position)) + { state := context.state.clearPending (.position position) + values := context.values } table) := + (evalDist_finalizeResolvedCoordinates_move_to_front + (.position position) coordinates + { state := context.state.clearPending (.position position) + values := context.values } + table hmem) + _ = evalDist (finalizeResolvedCoordinates + (coordinates.erase (.position position)) + { state := context.state.complete (.position position) output + values := context.values } table) := by + rw [finalizeResolvedCoordinates_cons_position_of_deferred_value position + (coordinates.erase (.position position)) + { state := context.state.clearPending (.position position) + values := context.values } + table output hclearedState hclearedValue, + if_neg hclearedClean, clearPending_complete_self] + _ = evalDist (finalizeResolvedCoordinates + (.position position :: coordinates.erase (.position position)) + context table) := by + rw [finalizeResolvedCoordinates_cons_position_of_deferred_value position + (coordinates.erase (.position position)) context table output hstate hvalue, + if_neg hhit] + _ = evalDist (finalizeResolvedCoordinates coordinates context table) := + evalDist_finalizeResolvedCoordinates_move_to_front + (.position position) coordinates context table hmem |>.symm + +theorem DeferredContext.Valid.of_resolveDeferredPositionValue + {context : DeferredContext} (hvalid : context.Valid) + (position : Position) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) : + result.toDeferredContext.Valid := by + cases hstate : context.state.values (.position position) with + | some output => + have hclean := hvalid.2 (.position position) output hstate + rw [resolveDeferredPositionValue_of_state_value position context output hstate, + if_neg hclean] at hresult + simp only [support_pure, Set.mem_singleton_iff, Option.some.injEq] at hresult + subst result + apply hvalid.clearPending_install position output + intro existing hexisting + rw [hstate] at hexisting + exact Option.some.inj hexisting.symm + | none => + cases hvalue : context.values position with + | some output => + rw [resolveDeferredPositionValue_of_deferred_value position context output hstate + hvalue] at hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + exact hvalid.clearPending (.position position) + | none => + rw [resolveDeferredPositionValue_fresh position context hstate hvalue, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hreturn⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hreturn + · simp [hhit] at hreturn + subst result + apply hvalid.clearPending_install position output + intro existing hexisting + rw [hstate] at hexisting + contradiction + +theorem DeferredContext.ValuesConsistent.of_resolveDeferredPositionValue + {context : DeferredContext} (hconsistent : context.ValuesConsistent) + (position : Position) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) : + result.toDeferredContext.ValuesConsistent := by + intro other output hvalue + have hstateValues := resolveDeferredPositionValue_preserves_state_values + position context result hresult + have horiginal : context.state.values (.position other) = some output := by + rw [← hstateValues] + exact hvalue + by_cases heq : other = position + · subst other + have hresolved := resolveDeferredPositionValue_resolves position context result hresult + unfold DeferredContext.positionValue at hresolved + rw [hvalue] at hresolved + have hsame : output = result.output := Option.some.inj hresolved + rw [hsame] + exact resolveDeferredPositionValue_installs position context result hresult + · rw [resolveDeferredPositionValue_preserves_other position other context result heq hresult] + exact hconsistent other output horiginal + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredChainStart_then_finalize + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (coordinates : List Coordinate) (context : DeferredContext) + (hmem : Coordinate.chainStart lay tree leafIdx chainIdx ∈ coordinates) + (hvalid : context.Valid) : + evalDist (do + let resolved := resolveDeferredChainStart table + ⟨lay, tree, leafIdx, chainIdx⟩ context + (match resolved with + | none => (pure none : ProbComp (Option DeferredContext)) + | some resolved => finalizeResolvedCoordinates coordinates + resolved.toDeferredContext table)) = + evalDist (finalizeResolvedCoordinates coordinates context table) := by + let coordinate := Coordinate.chainStart lay tree leafIdx chainIdx + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + have hcoordinate : index.coordinate = coordinate := rfl + cases hstate : context.state.values coordinate with + | some output => + have hclean := hvalid.2 coordinate output hstate + have hresolve : resolveDeferredChainStart table index context = some + ⟨{ state := context.state.clearPending coordinate, + values := context.values }, output⟩ := by + simp [resolveDeferredChainStart, hcoordinate, hstate, hclean] + change evalDist (match resolveDeferredChainStart table index context with + | none => (pure none : ProbComp (Option DeferredContext)) + | some resolved => finalizeResolvedCoordinates coordinates + resolved.toDeferredContext table) = _ + rw [hresolve] + calc + evalDist (finalizeResolvedCoordinates coordinates + { state := context.state.clearPending coordinate + values := context.values } table) = + evalDist (finalizeResolvedCoordinates + (coordinate :: coordinates.erase coordinate) + { state := context.state.clearPending coordinate + values := context.values } table) := + evalDist_finalizeResolvedCoordinates_move_to_front coordinate coordinates + { state := context.state.clearPending coordinate + values := context.values } table hmem + _ = evalDist (finalizeResolvedCoordinates + (coordinates.erase coordinate) + { state := context.state.clearPending coordinate + values := context.values } table) := by + rw [finalizeResolvedCoordinates_cons_of_state_value coordinate + (coordinates.erase coordinate) + { state := context.state.clearPending coordinate + values := context.values } table output] + · simp + · exact hstate + _ = evalDist (finalizeResolvedCoordinates + (coordinate :: coordinates.erase coordinate) context table) := by + rw [finalizeResolvedCoordinates_cons_of_state_value coordinate + (coordinates.erase coordinate) context table output hstate] + _ = evalDist (finalizeResolvedCoordinates coordinates context table) := + (evalDist_finalizeResolvedCoordinates_move_to_front coordinate coordinates + context table hmem).symm + | none => + have hstate' : context.state.values index.coordinate = none := by + simpa [hcoordinate] using hstate + change evalDist (match resolveDeferredChainStart table index context with + | none => (pure none : ProbComp (Option DeferredContext)) + | some resolved => finalizeResolvedCoordinates coordinates + resolved.toDeferredContext table) = _ + rw [resolveDeferredChainStart_of_missing table index context hstate'] + rw [hcoordinate] + by_cases hhit : context.state.hitAt coordinate (table index) + · rw [if_pos hhit] + simp only + have hstateConcrete : context.state.values + (.chainStart lay tree leafIdx chainIdx) = none := by + simpa [coordinate] using hstate + have hhitConcrete : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + simpa [coordinate, index] using hhit + have hmove := evalDist_finalizeResolvedCoordinates_move_to_front + coordinate coordinates context table hmem + simp only [coordinate] at hmove + rw [finalizeResolvedCoordinates] at hmove + simp only [hstateConcrete] at hmove + rw [resolveDeferredChainStart_of_missing table + ⟨lay, tree, leafIdx, chainIdx⟩ context hstateConcrete] at hmove + simp only [pure_bind] at hmove + simp only [OtsSecretIndex.coordinate] at hmove + rw [if_pos hhitConcrete] at hmove + simpa using hmove.symm + · rw [if_neg hhit] + simp only + have hclearedState : + (context.state.clearPending coordinate).values coordinate = none := + hstate + have hclearedClean : + ¬(context.state.clearPending coordinate).hitAt coordinate (table index) := + not_hitAt_clearPending_self context.state coordinate (table index) + have hhitConcrete : ¬context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + simpa [coordinate, index] using hhit + have hclearedCleanConcrete : + ¬(context.state.clearPending (.chainStart lay tree leafIdx chainIdx)).hitAt + (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + exact not_hitAt_clearPending_self context.state + (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) + calc + evalDist (finalizeResolvedCoordinates coordinates + { state := context.state.clearPending coordinate + values := context.values } table) = + evalDist (finalizeResolvedCoordinates + (coordinate :: coordinates.erase coordinate) + { state := context.state.clearPending coordinate + values := context.values } table) := + evalDist_finalizeResolvedCoordinates_move_to_front coordinate coordinates + { state := context.state.clearPending coordinate + values := context.values } table hmem + _ = evalDist (finalizeResolvedCoordinates + (coordinates.erase coordinate) + { state := context.state.complete coordinate (table index) + values := context.values } table) := by + rw [finalizeResolvedCoordinates_cons_of_missing coordinate + (coordinates.erase coordinate) + { state := context.state.clearPending coordinate + values := context.values } table hclearedState] + simp [coordinate, index, resolvedCompletionOutput, hclearedCleanConcrete, + DeferredContext.completeResolved, clearPending_complete_self] + _ = evalDist (finalizeResolvedCoordinates + (coordinate :: coordinates.erase coordinate) context table) := by + rw [finalizeResolvedCoordinates_cons_of_missing coordinate + (coordinates.erase coordinate) context table hstate] + simp [coordinate, index, resolvedCompletionOutput, hhitConcrete, + DeferredContext.completeResolved] + _ = evalDist (finalizeResolvedCoordinates coordinates context table) := + (evalDist_finalizeResolvedCoordinates_move_to_front coordinate coordinates + context table hmem).symm + +theorem DeferredContext.Valid.of_resolveDeferredChainStart + {context : DeferredContext} (hvalid : context.Valid) + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + result.toDeferredContext.Valid := by + unfold resolveDeferredChainStart at hresult + cases hstate : context.state.values index.coordinate with + | some output => + simp only [hstate] at hresult + by_cases hhit : context.state.hitAt index.coordinate output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + exact hvalid.clearPending index.coordinate + | none => + simp only [hstate] at hresult + by_cases hhit : context.state.hitAt index.coordinate (table index) + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + exact hvalid.clearPending index.coordinate + +theorem DeferredContext.ValuesConsistent.of_resolveDeferredChainStart + {context : DeferredContext} (hconsistent : context.ValuesConsistent) + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + result.toDeferredContext.ValuesConsistent := by + unfold resolveDeferredChainStart at hresult + cases hstate : context.state.values index.coordinate with + | some output => + simp only [hstate] at hresult + by_cases hhit : context.state.hitAt index.coordinate output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + exact hconsistent + | none => + simp only [hstate] at hresult + by_cases hhit : context.state.hitAt index.coordinate (table index) + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + exact hconsistent + +theorem DeferredContext.ValuesConsistent.of_resolveDeferredChainPrefix + {context : DeferredContext} (hconsistent : context.ValuesConsistent) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps result, + some result ∈ support + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) → + result.toDeferredContext.ValuesConsistent + | 0, hsteps, result, hresult => by + simp only [resolveDeferredChainPrefix, support_pure, Set.mem_singleton_iff] at hresult + exact hconsistent.of_resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ + result hresult.symm + | steps + 1, hsteps, result, hresult => by + rw [resolveDeferredChainPrefix, mem_support_bind_iff] at hresult + obtain ⟨previousOption, hprevious, hrest⟩ := hresult + cases previousOption with + | none => simp at hrest + | some previous => + have hmiddle := hconsistent.of_resolveDeferredChainPrefix table lay tree leafIdx + chainIdx steps (by omega) previous hprevious + exact hmiddle.of_resolveDeferredPositionValue + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) result (by simpa using hrest) + +theorem DeferredContext.ValuesConsistent.of_resolveDeferredChains + {context : DeferredContext} (hconsistent : context.ValuesConsistent) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ chains result, + some result ∈ support + (resolveDeferredChains table lay tree leafIdx chains context) → + result.ValuesConsistent + | [], result, hresult => by + simp [resolveDeferredChains] at hresult + subst result + exact hconsistent + | chainIdx :: remaining, result, hresult => by + rw [resolveDeferredChains, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hmiddle := hconsistent.of_resolveDeferredChainPrefix table lay tree leafIdx + chainIdx (chainLength - 1) (by omega) resolved hresolved + exact hmiddle.of_resolveDeferredChains table lay tree leafIdx remaining result + (by simpa using hrest) + +theorem DeferredContext.ValuesConsistent.of_resolveDeferredOtsLeaf + {context : DeferredContext} (hconsistent : context.ValuesConsistent) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredOtsLeaf table lay tree leafIdx context)) : + result.toDeferredContext.ValuesConsistent := by + rw [resolveDeferredOtsLeaf, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + have hmiddle := hconsistent.of_resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) chains hchains + exact hmiddle.of_resolveDeferredPositionValue (.leaf lay tree leafIdx) result + (by simpa using hrest) + +theorem DeferredContext.ValuesConsistent.of_resolveDeferredTreeNode + {context : DeferredContext} (hconsistent : context.ValuesConsistent) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel result, + some result ∈ support + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) → + result.toDeferredContext.ValuesConsistent + | 0, nodeIdx, hlevel, result, hresult => + hconsistent.of_resolveDeferredOtsLeaf table lay tree (leafOfNat nodeIdx) result hresult + | level + 1, nodeIdx, hlevel, result, hresult => by + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨leftOption, hleft, hafterLeft⟩ := hresult + cases leftOption with + | none => simp at hafterLeft + | some left => + rw [mem_support_bind_iff] at hafterLeft + obtain ⟨rightOption, hright, hafterRight⟩ := hafterLeft + cases rightOption with + | none => simp at hafterRight + | some right => + have hleftConsistent := hconsistent.of_resolveDeferredTreeNode table lay tree level + (2 * nodeIdx) (by omega) left hleft + have hrightConsistent := hleftConsistent.of_resolveDeferredTreeNode table lay tree + level (2 * nodeIdx + 1) (by omega) right hright + exact hrightConsistent.of_resolveDeferredPositionValue + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) result + (by simpa using hafterRight) + +theorem DeferredContext.ValuesConsistent.of_resolveDeferredPosition + {context : DeferredContext} (hconsistent : context.ValuesConsistent) + (table : OtsSecretIndex → HashOutput) (position : Position) + (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPosition table position context)) : + result.toDeferredContext.ValuesConsistent := by + cases position with + | chain lay tree leafIdx chainIdx step => + exact hconsistent.of_resolveDeferredChainPrefix table lay tree leafIdx chainIdx + (step.val + 1) (by have := step.isLt; omega) result hresult + | leaf lay tree leafIdx => + exact hconsistent.of_resolveDeferredOtsLeaf table lay tree leafIdx result hresult + | node lay tree level nodeIdx => + exact hconsistent.of_resolveDeferredTreeNode table lay tree (level.val + 1) nodeIdx + (by have := level.isLt; omega) result hresult + | ftsLeaf index tree leafIdx => + exact hconsistent.of_resolveDeferredPositionValue (.ftsLeaf index tree leafIdx) result + hresult + | ftsNode index tree level nodeIdx => + exact hconsistent.of_resolveDeferredPositionValue (.ftsNode index tree level nodeIdx) result + hresult + | ftsRoots index => + exact hconsistent.of_resolveDeferredPositionValue (.ftsRoots index) result hresult +theorem DeferredContext.Valid.of_resolveDeferredChainPrefix + {context : DeferredContext} (hvalid : context.Valid) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps result, + some result ∈ support + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) → + result.toDeferredContext.Valid + | 0, hsteps, result, hresult => by + simp only [resolveDeferredChainPrefix, support_pure, Set.mem_singleton_iff] at hresult + exact hvalid.of_resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ + result hresult.symm + | steps + 1, hsteps, result, hresult => by + rw [resolveDeferredChainPrefix, mem_support_bind_iff] at hresult + obtain ⟨previousOption, hprevious, hrest⟩ := hresult + cases previousOption with + | none => simp at hrest + | some previous => + have hmiddle := hvalid.of_resolveDeferredChainPrefix table lay tree leafIdx chainIdx + steps (by omega) previous hprevious + exact hmiddle.of_resolveDeferredPositionValue + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) result (by simpa using hrest) + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredChainPrefix_then_finalize + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (coordinates : List Coordinate) (context : DeferredContext) + (hvalid : context.Valid) + (hstart : Coordinate.chainStart lay tree leafIdx chainIdx ∈ coordinates) + (hpositions : ∀ step : ChainStep, step.val < chainLength - 1 → + Coordinate.position (.chain lay tree leafIdx chainIdx step) ∈ coordinates) : + ∀ steps hsteps, + evalDist (do + let resolved ← resolveDeferredChainPrefix table lay tree leafIdx chainIdx + steps hsteps context + (match resolved with + | none => (pure none : ProbComp (Option DeferredContext)) + | some resolved => finalizeResolvedCoordinates coordinates + resolved.toDeferredContext table)) = + evalDist (finalizeResolvedCoordinates coordinates context table) + | 0, hsteps => by + simpa [resolveDeferredChainPrefix] using + evalDist_resolveDeferredChainStart_then_finalize table lay tree leafIdx chainIdx + coordinates context hstart hvalid + | steps + 1, hsteps => by + rw [resolveDeferredChainPrefix] + simp only [bind_assoc] + calc + _ = + evalDist + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps (by omega) context + >>= fun previousOption => + match previousOption with + | none => pure none + | some previous => finalizeResolvedCoordinates coordinates + previous.toDeferredContext table) := by + apply evalDist_bind_congr + intro previousOption hprevious + cases previousOption with + | none => rfl + | some previous => + have hmiddle := hvalid.of_resolveDeferredChainPrefix table lay tree leafIdx + chainIdx steps (by omega) previous hprevious + exact evalDist_resolveDeferredPositionValue_then_finalize + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + coordinates previous.toDeferredContext table + (hpositions ⟨steps, by omega⟩ (by omega)) + (fun output hvalue => ⟨hmiddle.1 _ output hvalue, + hmiddle.2 _ output hvalue⟩) + _ = evalDist (finalizeResolvedCoordinates coordinates context table) := + evalDist_resolveDeferredChainPrefix_then_finalize table lay tree leafIdx chainIdx + coordinates context hvalid hstart hpositions steps (by omega) + +theorem DeferredContext.Valid.of_resolveDeferredChains + {context : DeferredContext} (hvalid : context.Valid) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ chains result, + some result ∈ support + (resolveDeferredChains table lay tree leafIdx chains context) → + result.Valid + | [], result, hresult => by + simp [resolveDeferredChains] at hresult + subst result + exact hvalid + | chainIdx :: remaining, result, hresult => by + rw [resolveDeferredChains, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hmiddle := hvalid.of_resolveDeferredChainPrefix table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) resolved hresolved + exact hmiddle.of_resolveDeferredChains table lay tree leafIdx remaining result + (by simpa using hrest) + +theorem DeferredContext.Valid.of_resolveDeferredOtsLeaf + {context : DeferredContext} (hvalid : context.Valid) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredOtsLeaf table lay tree leafIdx context)) : + result.toDeferredContext.Valid := by + rw [resolveDeferredOtsLeaf, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + have hmiddle := hvalid.of_resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) chains hchains + exact hmiddle.of_resolveDeferredPositionValue (.leaf lay tree leafIdx) result + (by simpa using hrest) + +theorem DeferredContext.Valid.of_resolveDeferredTreeNode + {context : DeferredContext} (hvalid : context.Valid) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel result, + some result ∈ support + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) → + result.toDeferredContext.Valid + | 0, nodeIdx, hlevel, result, hresult => + hvalid.of_resolveDeferredOtsLeaf table lay tree (leafOfNat nodeIdx) result hresult + | level + 1, nodeIdx, hlevel, result, hresult => by + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨leftOption, hleft, hafterLeft⟩ := hresult + cases leftOption with + | none => simp at hafterLeft + | some left => + rw [mem_support_bind_iff] at hafterLeft + obtain ⟨rightOption, hright, hafterRight⟩ := hafterLeft + cases rightOption with + | none => simp at hafterRight + | some right => + have hleftValid := hvalid.of_resolveDeferredTreeNode table lay tree level + (2 * nodeIdx) (by omega) left hleft + have hrightValid := hleftValid.of_resolveDeferredTreeNode table lay tree level + (2 * nodeIdx + 1) (by omega) right hright + exact hrightValid.of_resolveDeferredPositionValue + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) result + (by simpa using hafterRight) + +theorem DeferredContext.Valid.of_resolveDeferredPosition + {context : DeferredContext} (hvalid : context.Valid) + (table : OtsSecretIndex → HashOutput) (position : Position) + (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPosition table position context)) : + result.toDeferredContext.Valid := by + cases position with + | chain lay tree leafIdx chainIdx step => + exact hvalid.of_resolveDeferredChainPrefix table lay tree leafIdx chainIdx + (step.val + 1) (by have := step.isLt; omega) result hresult + | leaf lay tree leafIdx => + exact hvalid.of_resolveDeferredOtsLeaf table lay tree leafIdx result hresult + | node lay tree level nodeIdx => + exact hvalid.of_resolveDeferredTreeNode table lay tree (level.val + 1) nodeIdx + (by have := level.isLt; omega) result hresult + | ftsLeaf index tree leafIdx => + exact hvalid.of_resolveDeferredPositionValue (.ftsLeaf index tree leafIdx) result hresult + | ftsNode index tree level nodeIdx => + exact hvalid.of_resolveDeferredPositionValue (.ftsNode index tree level nodeIdx) result + hresult + | ftsRoots index => + exact hvalid.of_resolveDeferredPositionValue (.ftsRoots index) result hresult + +theorem resolveDeferredChains_preserves_state_values + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ chains context result, + some result ∈ support + (resolveDeferredChains table lay tree leafIdx chains context) → + result.state.values = context.state.values + | [], context, result, hresult => by + simp [resolveDeferredChains] at hresult + subst result + rfl + | chainIdx :: remaining, context, result, hresult => by + rw [resolveDeferredChains, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + exact (resolveDeferredChains_preserves_state_values table lay tree leafIdx remaining + resolved.toDeferredContext result (by simpa using hrest)).trans + (resolveDeferredChainPrefix_preserves_state_values table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context resolved hresolved) + +theorem resolveDeferredOtsLeaf_preserves_state_values + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredOtsLeaf table lay tree leafIdx context)) : + result.state.values = context.state.values := by + rw [resolveDeferredOtsLeaf, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + exact (resolveDeferredPositionValue_preserves_state_values (.leaf lay tree leafIdx) + chains result (by simpa using hrest)).trans + (resolveDeferredChains_preserves_state_values table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) context chains hchains) + +theorem resolveDeferredTreeNode_preserves_state_values + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel context result, + some result ∈ support + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) → + result.state.values = context.state.values + | 0, nodeIdx, hlevel, context, result, hresult => + resolveDeferredOtsLeaf_preserves_state_values table lay tree (leafOfNat nodeIdx) + context result hresult + | level + 1, nodeIdx, hlevel, context, result, hresult => by + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨leftOption, hleft, hafterLeft⟩ := hresult + cases leftOption with + | none => simp at hafterLeft + | some left => + rw [mem_support_bind_iff] at hafterLeft + obtain ⟨rightOption, hright, hafterRight⟩ := hafterLeft + cases rightOption with + | none => simp at hafterRight + | some right => + exact (resolveDeferredPositionValue_preserves_state_values + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) + right.toDeferredContext result (by simpa using hafterRight)).trans + ((resolveDeferredTreeNode_preserves_state_values table lay tree level + (2 * nodeIdx + 1) (by omega) left.toDeferredContext right hright).trans + (resolveDeferredTreeNode_preserves_state_values table lay tree level + (2 * nodeIdx) (by omega) context left hleft)) + +theorem privateStateAgrees_resolveDeferredChains + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ chains context result, + some result ∈ support + (resolveDeferredChains table lay tree leafIdx chains context) → + PrivateStateAgrees result context + | [], context, result, hresult => by + simp [resolveDeferredChains] at hresult + subst result + exact ⟨rfl, rfl, rfl⟩ + | chainIdx :: remaining, context, result, hresult => by + rw [resolveDeferredChains, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hhead := privateStateAgrees_resolveDeferredChainPrefix table lay tree leafIdx + chainIdx (chainLength - 1) (by omega) context resolved hresolved + have htail := privateStateAgrees_resolveDeferredChains table lay tree leafIdx remaining + resolved.toDeferredContext result (by simpa using hrest) + exact ⟨htail.1.trans hhead.1, htail.2.1.trans hhead.2.1, + htail.2.2.trans hhead.2.2⟩ + +theorem privateStateAgrees_resolveDeferredOtsLeaf + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredOtsLeaf table lay tree leafIdx context)) : + PrivateStateAgrees result.toDeferredContext context := by + rw [resolveDeferredOtsLeaf, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + have hhead := privateStateAgrees_resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) context chains hchains + have htail := privateStateAgrees_resolveDeferredPositionValue + (.leaf lay tree leafIdx) chains result (by simpa using hrest) + exact ⟨htail.1.trans hhead.1, htail.2.1.trans hhead.2.1, + htail.2.2.trans hhead.2.2⟩ + +theorem privateStateAgrees_resolveDeferredTreeNode + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel context result, + some result ∈ support + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) → + PrivateStateAgrees result.toDeferredContext context + | 0, nodeIdx, hlevel, context, result, hresult => + privateStateAgrees_resolveDeferredOtsLeaf table lay tree (leafOfNat nodeIdx) + context result hresult + | level + 1, nodeIdx, hlevel, context, result, hresult => by + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨leftOption, hleft, hafterLeft⟩ := hresult + cases leftOption with + | none => simp at hafterLeft + | some left => + rw [mem_support_bind_iff] at hafterLeft + obtain ⟨rightOption, hright, hafterRight⟩ := hafterLeft + cases rightOption with + | none => simp at hafterRight + | some right => + have hleftState := privateStateAgrees_resolveDeferredTreeNode table lay tree level + (2 * nodeIdx) (by omega) context left hleft + have hrightState := privateStateAgrees_resolveDeferredTreeNode table lay tree level + (2 * nodeIdx + 1) (by omega) left.toDeferredContext right hright + have hnodeState := privateStateAgrees_resolveDeferredPositionValue + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) + right.toDeferredContext result (by simpa using hafterRight) + exact ⟨hnodeState.1.trans (hrightState.1.trans hleftState.1), + hnodeState.2.1.trans (hrightState.2.1.trans hleftState.2.1), + hnodeState.2.2.trans (hrightState.2.2.trans hleftState.2.2)⟩ + +theorem resolveDeferredPosition_preserves_state_values + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPosition table position context)) : + result.state.values = context.state.values := by + cases position with + | chain lay tree leafIdx chainIdx step => + exact resolveDeferredChainPrefix_preserves_state_values table lay tree leafIdx chainIdx + (step.val + 1) (by have := step.isLt; omega) context result hresult + | leaf lay tree leafIdx => + exact resolveDeferredOtsLeaf_preserves_state_values table lay tree leafIdx context result + hresult + | node lay tree level nodeIdx => + exact resolveDeferredTreeNode_preserves_state_values table lay tree (level.val + 1) + nodeIdx (by have := level.isLt; omega) context result hresult + | ftsLeaf index tree leafIdx => + exact resolveDeferredPositionValue_preserves_state_values (.ftsLeaf index tree leafIdx) + context result hresult + | ftsNode index tree level nodeIdx => + exact resolveDeferredPositionValue_preserves_state_values (.ftsNode index tree level nodeIdx) + context result hresult + | ftsRoots index => + exact resolveDeferredPositionValue_preserves_state_values (.ftsRoots index) context result + hresult + +theorem resolveDeferredChainPrefix_pending_subset + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps context result, + some result ∈ support + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) → + result.state.pending ⊆ context.state.pending + | 0, hsteps, context, result, hresult => by + simp only [resolveDeferredChainPrefix, support_pure, Set.mem_singleton_iff] at hresult + unfold resolveDeferredChainStart at hresult + cases hstate : context.state.values (.chainStart lay tree leafIdx chainIdx) with + | none => + simp only [OtsSecretIndex.coordinate, hstate] at hresult + split at hresult <;> simp_all [LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway] + | some output => + simp only [OtsSecretIndex.coordinate, hstate] at hresult + split at hresult <;> simp_all [LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway] + | steps + 1, hsteps, context, result, hresult => by + rw [resolveDeferredChainPrefix, mem_support_bind_iff] at hresult + obtain ⟨previousOption, hprevious, hrest⟩ := hresult + cases previousOption with + | none => simp at hrest + | some previous => + have hprefix := resolveDeferredChainPrefix_pending_subset table lay tree leafIdx + chainIdx steps (by omega) context previous hprevious + have hstep := resolveDeferredPositionValue_pending + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + previous.toDeferredContext result (by simpa using hrest) + intro entry hentry + apply hprefix + rw [hstep] at hentry + exact (Finset.mem_filter.1 hentry).1 + +theorem resolveDeferredChains_pending_subset + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ chains context result, + some result ∈ support (resolveDeferredChains table lay tree leafIdx chains context) → + result.state.pending ⊆ context.state.pending + | [], context, result, hresult => by + simp [resolveDeferredChains] at hresult + subst result + exact Finset.Subset.rfl + | chainIdx :: remaining, context, result, hresult => by + rw [resolveDeferredChains, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + exact (resolveDeferredChains_pending_subset table lay tree leafIdx remaining + resolved.toDeferredContext result (by simpa using hrest)).trans + (resolveDeferredChainPrefix_pending_subset table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context resolved hresolved) + +theorem resolveDeferredOtsLeaf_pending_subset + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredOtsLeaf table lay tree leafIdx context)) : + result.state.pending ⊆ context.state.pending := by + rw [resolveDeferredOtsLeaf, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + have hleaf := resolveDeferredPositionValue_pending (.leaf lay tree leafIdx) chains result + (by simpa using hrest) + intro entry hentry + apply resolveDeferredChains_pending_subset table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) context chains hchains + rw [hleaf] at hentry + exact (Finset.mem_filter.1 hentry).1 + +theorem resolveDeferredTreeNode_pending_subset + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel context result, + some result ∈ support + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) → + result.state.pending ⊆ context.state.pending + | 0, nodeIdx, hlevel, context, result, hresult => + resolveDeferredOtsLeaf_pending_subset table lay tree (leafOfNat nodeIdx) context result + hresult + | level + 1, nodeIdx, hlevel, context, result, hresult => by + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨leftOption, hleft, hafterLeft⟩ := hresult + cases leftOption with + | none => simp at hafterLeft + | some left => + rw [mem_support_bind_iff] at hafterLeft + obtain ⟨rightOption, hright, hafterRight⟩ := hafterLeft + cases rightOption with + | none => simp at hafterRight + | some right => + have hnode := resolveDeferredPositionValue_pending + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) + right.toDeferredContext result (by simpa using hafterRight) + intro entry hentry + apply (resolveDeferredTreeNode_pending_subset table lay tree level + (2 * nodeIdx) (by omega) context left hleft) + apply (resolveDeferredTreeNode_pending_subset table lay tree level + (2 * nodeIdx + 1) (by omega) left.toDeferredContext right hright) + rw [hnode] at hentry + exact (Finset.mem_filter.1 hentry).1 + +theorem resolveDeferredPosition_pending_subset + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPosition table position context)) : + result.state.pending ⊆ context.state.pending := by + cases position with + | chain lay tree leafIdx chainIdx step => + exact resolveDeferredChainPrefix_pending_subset table lay tree leafIdx chainIdx + (step.val + 1) (by have := step.isLt; omega) context result hresult + | leaf lay tree leafIdx => + exact resolveDeferredOtsLeaf_pending_subset table lay tree leafIdx context result hresult + | node lay tree level nodeIdx => + exact resolveDeferredTreeNode_pending_subset table lay tree (level.val + 1) nodeIdx + (by have := level.isLt; omega) context result hresult + | ftsLeaf index tree leafIdx => + have hdirect : some result ∈ support + (resolveDeferredPositionValue (.ftsLeaf index tree leafIdx) context) := by + simpa [resolveDeferredPosition] using hresult + rw [resolveDeferredPositionValue_pending (.ftsLeaf index tree leafIdx) context result + hdirect] + exact Finset.filter_subset _ _ + | ftsNode index tree level nodeIdx => + have hdirect : some result ∈ support + (resolveDeferredPositionValue (.ftsNode index tree level nodeIdx) context) := by + simpa [resolveDeferredPosition] using hresult + rw [resolveDeferredPositionValue_pending (.ftsNode index tree level nodeIdx) context result + hdirect] + exact Finset.filter_subset _ _ + | ftsRoots index => + have hdirect : some result ∈ support + (resolveDeferredPositionValue (.ftsRoots index) context) := by + simpa [resolveDeferredPosition] using hresult + rw [resolveDeferredPositionValue_pending (.ftsRoots index) context result hdirect] + exact Finset.filter_subset _ _ + +theorem resolveDeferredPosition_pendingAway_subset + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPosition table position context)) : + result.state.pending ⊆ context.state.pendingAway (.position position) := by + cases position with + | chain lay tree leafIdx chainIdx step => + rw [resolveDeferredPosition, resolveDeferredChainPrefix, mem_support_bind_iff] at hresult + obtain ⟨previousOption, hprevious, hrest⟩ := hresult + cases previousOption with + | none => simp at hrest + | some previous => + have hstep := resolveDeferredPositionValue_pending + (.chain lay tree leafIdx chainIdx step) previous.toDeferredContext result + (by simpa using hrest) + intro entry hentry + rw [hstep] at hentry + have hparts := Finset.mem_filter.1 hentry + exact Finset.mem_filter.2 ⟨ + resolveDeferredChainPrefix_pending_subset table lay tree leafIdx chainIdx step.val + (by have := step.isLt; omega) context previous hprevious hparts.1, + hparts.2⟩ + | leaf lay tree leafIdx => + rw [resolveDeferredPosition, resolveDeferredOtsLeaf, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + have hleaf := resolveDeferredPositionValue_pending (.leaf lay tree leafIdx) chains + result (by simpa using hrest) + intro entry hentry + rw [hleaf] at hentry + have hparts := Finset.mem_filter.1 hentry + exact Finset.mem_filter.2 ⟨ + resolveDeferredChains_pending_subset table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) context chains hchains hparts.1, + hparts.2⟩ + | node lay tree level nodeIdx => + rw [resolveDeferredPosition, resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨leftOption, hleft, hafterLeft⟩ := hresult + cases leftOption with + | none => simp at hafterLeft + | some left => + rw [mem_support_bind_iff] at hafterLeft + obtain ⟨rightOption, hright, hafterRight⟩ := hafterLeft + cases rightOption with + | none => simp at hafterRight + | some right => + have hnode := resolveDeferredPositionValue_pending (.node lay tree level nodeIdx) + right.toDeferredContext result (by simpa [leafOfNat_val] using hafterRight) + intro entry hentry + rw [hnode] at hentry + have hparts := Finset.mem_filter.1 hentry + apply Finset.mem_filter.2 + refine ⟨?_, hparts.2⟩ + apply resolveDeferredTreeNode_pending_subset table lay tree level.val + (2 * nodeIdx.val) (by have := level.isLt; omega) context left hleft + apply resolveDeferredTreeNode_pending_subset table lay tree level.val + (2 * nodeIdx.val + 1) (by have := level.isLt; omega) left.toDeferredContext + right hright + exact hparts.1 + | ftsLeaf index tree leafIdx => + have hdirect : some result ∈ support + (resolveDeferredPositionValue (.ftsLeaf index tree leafIdx) context) := by + simpa [resolveDeferredPosition] using hresult + rw [resolveDeferredPositionValue_pending (.ftsLeaf index tree leafIdx) context result + hdirect] + | ftsNode index tree level nodeIdx => + have hdirect : some result ∈ support + (resolveDeferredPositionValue (.ftsNode index tree level nodeIdx) context) := by + simpa [resolveDeferredPosition] using hresult + rw [resolveDeferredPositionValue_pending (.ftsNode index tree level nodeIdx) context result + hdirect] + | ftsRoots index => + have hdirect : some result ∈ support + (resolveDeferredPositionValue (.ftsRoots index) context) := by + simpa [resolveDeferredPosition] using hresult + rw [resolveDeferredPositionValue_pending (.ftsRoots index) context result hdirect] + +theorem resolveDeferredReveal_preserves_state_values + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredReveal table position context)) : + result.state.values = context.state.values := by + classical + by_cases hresolvable : ResolvableOtsPosition position + · apply resolveDeferredPosition_preserves_state_values table position context result + simpa [resolveDeferredReveal, hresolvable] using hresult + · apply resolveDeferredPositionValue_preserves_state_values position context result + simpa [resolveDeferredReveal, hresolvable] using hresult + +theorem resolveDeferredReveal_pendingAway_subset + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredReveal table position context)) : + result.state.pending ⊆ context.state.pendingAway (.position position) := by + classical + by_cases hresolvable : ResolvableOtsPosition position + · apply resolveDeferredPosition_pendingAway_subset table position context result + simpa [resolveDeferredReveal, hresolvable] using hresult + · have hdirect : some result ∈ support + (resolveDeferredPositionValue position context) := by + simpa [resolveDeferredReveal, hresolvable] using hresult + rw [resolveDeferredPositionValue_pending position context result hdirect] + +theorem resolveDeferredReveal_resolves + (table : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredReveal table position context)) : + result.toDeferredContext.positionValue position = some result.output := by + classical + by_cases hresolvable : ResolvableOtsPosition position + · apply resolveDeferredPosition_resolves table position context result + simpa [resolveDeferredReveal, hresolvable] using hresult + · apply resolveDeferredPositionValue_resolves position context result + simpa [resolveDeferredReveal, hresolvable] using hresult + +theorem DeferredContext.Valid.of_resolveDeferredReveal + {context : DeferredContext} (hvalid : context.Valid) + (table : OtsSecretIndex → HashOutput) (position : Position) + (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredReveal table position context)) : + result.toDeferredContext.Valid := by + classical + by_cases hresolvable : ResolvableOtsPosition position + · apply hvalid.of_resolveDeferredPosition table position result + simpa [resolveDeferredReveal, hresolvable] using hresult + · apply hvalid.of_resolveDeferredPositionValue position result + simpa [resolveDeferredReveal, hresolvable] using hresult + +theorem DeferredContext.ValuesConsistent.of_resolveDeferredReveal + {context : DeferredContext} (hconsistent : context.ValuesConsistent) + (table : OtsSecretIndex → HashOutput) (position : Position) + (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredReveal table position context)) : + result.toDeferredContext.ValuesConsistent := by + classical + by_cases hresolvable : ResolvableOtsPosition position + · apply hconsistent.of_resolveDeferredPosition table position result + simpa [resolveDeferredReveal, hresolvable] using hresult + · apply hconsistent.of_resolveDeferredPositionValue position result + simpa [resolveDeferredReveal, hresolvable] using hresult + +theorem DeferredContext.Valid.materialize_position + {context : DeferredContext} (hvalid : context.Valid) + (position : Position) (output : HashOutput) + (hvalue : context.values position = some output) : + ({ state := context.state.materialize (.position position) output + values := context.values } : DeferredContext).Valid := by + constructor + · intro other candidate hstate + by_cases heq : other = position + · subst other + have hsame : some output = some candidate := by + simpa [LazyRevealProbe.State.materialize] using hstate + have hcandidate : output = candidate := Option.some.inj hsame + subst candidate + exact hvalue + · have horiginal : context.state.values (.position other) = some candidate := by + simpa [LazyRevealProbe.State.materialize, Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by + simpa using heq] using hstate + exact hvalid.1 other candidate horiginal + · intro coordinate candidate hstate + by_cases heq : coordinate = .position position + · subst coordinate + change ¬(context.state.clearPending (.position position)).hitAt + (.position position) candidate + exact not_hitAt_clearPending_self context.state (.position position) candidate + · have horiginal : context.state.values coordinate = some candidate := by + simpa [LazyRevealProbe.State.materialize, Function.update_of_ne heq] using hstate + change ¬(context.state.clearPending (.position position)).hitAt coordinate candidate + exact (hitAt_clearPending_of_ne context.state (.position position) coordinate candidate + heq).not.mpr (hvalid.2 coordinate candidate horiginal) + +theorem DeferredContext.Valid.materialize_resolved_position + {context : DeferredContext} (hvalid : context.Valid) + (table : OtsSecretIndex → HashOutput) (position : Position) + (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPosition table position context)) : + ({ state := result.state.materialize (.position position) result.output + values := result.values } : DeferredContext).Valid := by + have hresolved := resolveDeferredPosition_resolves table position context result hresult + have hresultValid := hvalid.of_resolveDeferredPosition table position result hresult + have hprivate : result.values position = some result.output := by + unfold DeferredContext.positionValue at hresolved + cases hstate : result.state.values (.position position) with + | none => simpa [hstate] using hresolved + | some output => + have hsame : output = result.output := by + simpa [hstate] using hresolved + simpa [hsame] using hresultValid.1 position output hstate + exact hresultValid.materialize_position position result.output hprivate + +theorem DeferredContext.Valid.materialize_resolved_position_from_context + {context : DeferredContext} (hvalid : context.Valid) + (table : OtsSecretIndex → HashOutput) (position : Position) + (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPosition table position context)) : + ({ state := context.state.materialize (.position position) result.output + values := result.values } : DeferredContext).Valid := by + have hstateValues := resolveDeferredPosition_preserves_state_values table position context + result hresult + have hresultValid := hvalid.of_resolveDeferredPosition table position result hresult + have htemporary : + ({ state := context.state, values := result.values } : DeferredContext).Valid := by + constructor + · intro other output hvalue + apply hresultValid.1 other output + rw [hstateValues] + exact hvalue + · exact hvalid.2 + have hprivate : result.values position = some result.output := by + have hresolved := resolveDeferredPosition_resolves table position context result hresult + unfold DeferredContext.positionValue at hresolved + rw [hstateValues] at hresolved + cases hstate : context.state.values (.position position) with + | none => simpa [hstate] using hresolved + | some output => + have hsame : output = result.output := by + simpa [hstate] using hresolved + simpa [hsame] using hresultValid.1 position output (by + rw [hstateValues] + exact hstate) + exact htemporary.materialize_position position result.output hprivate + +theorem DeferredContext.valid_empty : + ({ state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } : DeferredContext).Valid := by + constructor + · intro position output hvalue + simp [LazyRevealProbe.State.empty] at hvalue + · intro coordinate output hvalue + simp [LazyRevealProbe.State.empty] at hvalue + +theorem DeferredContext.Valid.ensure + {context : DeferredContext} (hvalid : context.Valid) (coordinate : Coordinate) : + ({ context with state := context.state.ensure coordinate } : DeferredContext).Valid := by + constructor + · exact hvalid.1 + · intro other output hvalue + change ¬context.state.hitAt other output + exact hvalid.2 other output hvalue + +theorem DeferredContext.Valid.publish + {context : DeferredContext} (hvalid : context.Valid) (coordinate : Coordinate) : + ({ context with state := context.state.publish coordinate } : DeferredContext).Valid := by + constructor + · exact hvalid.1 + · intro other output hvalue + change ¬context.state.hitAt other output + exact hvalid.2 other output hvalue + +theorem DeferredContext.Valid.materialize_chainStart + {context : DeferredContext} (hvalid : context.Valid) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (output : HashOutput) : + ({ state := context.state.materialize + (.chainStart lay tree leafIdx chainIdx) output + values := context.values } : DeferredContext).Valid := by + let coordinate := Coordinate.chainStart lay tree leafIdx chainIdx + constructor + · intro position candidate hstate + have horiginal : context.state.values (.position position) = some candidate := by + simpa [coordinate, LazyRevealProbe.State.materialize] using hstate + exact hvalid.1 position candidate horiginal + · intro other candidate hstate + by_cases heq : other = coordinate + · subst other + change ¬(context.state.clearPending coordinate).hitAt coordinate candidate + exact not_hitAt_clearPending_self context.state coordinate candidate + · have horiginal : context.state.values other = some candidate := by + simpa [coordinate, LazyRevealProbe.State.materialize, + Function.update_of_ne heq] using hstate + change ¬(context.state.clearPending coordinate).hitAt other candidate + exact (hitAt_clearPending_of_ne context.state coordinate other candidate heq).not.mpr + (hvalid.2 other candidate horiginal) + +theorem DeferredContext.Valid.materialize_resolved_chainStart + {context : DeferredContext} (hvalid : context.Valid) + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + ({ state := result.state.materialize index.coordinate result.output + values := result.values } : DeferredContext).Valid := by + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + have hresultValid := hvalid.of_resolveDeferredChainStart table + ⟨lay, tree, leafIdx, chainIdx⟩ result hresult + exact hresultValid.materialize_chainStart lay tree leafIdx chainIdx result.output + +def projectDeferredState : Option DeferredContext → + Option (LazyRevealProbe.State Coordinate) := + Option.map DeferredContext.state + +set_option maxRecDepth 100000 in +theorem evalDist_map_finalizeResolvedCoordinates_congr_values + (coordinates : List Coordinate) (state : LazyRevealProbe.State Coordinate) + (left right : DeferredStructuralValues) (table : OtsSecretIndex → HashOutput) + (hagrees : ∀ position : Position, Coordinate.position position ∈ coordinates → + left position = right position) : + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates ⟨state, left⟩ table) = + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates ⟨state, right⟩ table) := by + induction coordinates generalizing state left right with + | nil => simp [finalizeResolvedCoordinates, projectDeferredState] + | cons coordinate remaining ih => + cases hstate : state.values coordinate with + | some output => + rw [finalizeResolvedCoordinates_cons_of_state_value coordinate remaining + ⟨state, left⟩ table output hstate, + finalizeResolvedCoordinates_cons_of_state_value coordinate remaining + ⟨state, right⟩ table output hstate] + exact ih (state.clearPending coordinate) left right (by + intro position hmem + exact hagrees position (List.mem_cons_of_mem coordinate hmem)) + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + have hstate' : state.values index.coordinate = none := by + simpa [index, OtsSecretIndex.coordinate] using hstate + rw [finalizeResolvedCoordinates, finalizeResolvedCoordinates] + simp only [hstate] + rw [resolveDeferredChainStart_of_missing table index ⟨state, left⟩ hstate', + resolveDeferredChainStart_of_missing table index ⟨state, right⟩ hstate'] + simp only [map_eq_bind_pure_comp, pure_bind] + simp only [index, OtsSecretIndex.coordinate] + by_cases hhit : state.hitAt index.coordinate (table index) + · have hhit' : state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) := by + simpa [index, OtsSecretIndex.coordinate] using hhit + rw [if_pos hhit', if_pos hhit'] + · simp only [index, OtsSecretIndex.coordinate] at hhit + rw [if_neg hhit, if_neg hhit] + simp only + rw [clearPending_complete_self] + exact ih (state.complete (.chainStart lay tree leafIdx chainIdx) (table index)) + left right (by + intro position hmem + exact hagrees position (List.mem_cons_of_mem _ hmem)) + | position position => + have hprivate : left position = right position := + hagrees position (by simp) + cases hleft : left position with + | some output => + have hright : right position = some output := by + rw [← hprivate] + exact hleft + rw [finalizeResolvedCoordinates_cons_position_of_deferred_value position + remaining ⟨state, left⟩ table output hstate hleft, + finalizeResolvedCoordinates_cons_position_of_deferred_value position + remaining ⟨state, right⟩ table output hstate hright] + by_cases hhit : state.hitAt (.position position) output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + exact ih (state.complete (.position position) output) left right (by + intro other hmem + exact hagrees other (List.mem_cons_of_mem _ hmem)) + | none => + have hright : right position = none := by + rw [← hprivate] + exact hleft + rw [finalizeResolvedCoordinates_cons_position_fresh position remaining + ⟨state, left⟩ table hstate hleft, + finalizeResolvedCoordinates_cons_position_fresh position remaining + ⟨state, right⟩ table hstate hright] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + by_cases hhit : state.hitAt (.position position) output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + apply ih (state.complete (.position position) output) + (left.install position output) (right.install position output) + intro other hmem + by_cases heq : other = position + · subst other + simp [DeferredStructuralValues.install] + · simp [DeferredStructuralValues.install, heq, + hagrees other (List.mem_cons_of_mem _ hmem)] + +theorem evalDist_map_finalizeResolvedCoordinates_install_of_not_mem + (coordinates : List Coordinate) (state : LazyRevealProbe.State Coordinate) + (values : DeferredStructuralValues) (table : OtsSecretIndex → HashOutput) + (position : Position) (output : HashOutput) + (hnotMem : Coordinate.position position ∉ coordinates) : + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates + ⟨state, values.install position output⟩ table) = + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates ⟨state, values⟩ table) := by + apply evalDist_map_finalizeResolvedCoordinates_congr_values + intro other hmem + have hne : other ≠ position := by + intro heq + subst other + exact hnotMem hmem + simp [DeferredStructuralValues.install, hne] + +set_option maxRecDepth 100000 in +theorem evalDist_map_resolveDeferredPositionValue_then_finalize_of_not_mem + (position : Position) (coordinates : List Coordinate) + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) + (hnotMem : Coordinate.position position ∉ coordinates) + (hstate : context.state.values (.position position) = none) + (hclear : context.state.clearPending (.position position) = context.state) : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some resolved => projectDeferredState <$> + finalizeResolvedCoordinates coordinates resolved.toDeferredContext table) = + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := by + have hclean : ∀ output, + ¬context.state.hitAt (.position position) output := by + intro output + rw [← hclear] + exact not_hitAt_clearPending_self context.state (.position position) output + cases hvalue : context.values position with + | some output => + rw [resolveDeferredPositionValue_of_deferred_value position context output hstate hvalue, + if_neg (hclean output)] + simp only [pure_bind, hclear] + | none => + rw [resolveDeferredPositionValue_fresh position context hstate hvalue] + simp only [bind_assoc] + have hpointwise : ∀ output, + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates + ⟨context.state, context.values.install position output⟩ table) = + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := by + intro output + exact evalDist_map_finalizeResolvedCoordinates_install_of_not_mem coordinates + context.state context.values table position output hnotMem + calc + _ = evalDist (LazyRevealProbe.sampleHashOutput >>= fun output => + projectDeferredState <$> + finalizeResolvedCoordinates coordinates + ⟨context.state, context.values.install position output⟩ table) := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + simp [hclean output, hclear] + _ = evalDist (LazyRevealProbe.sampleHashOutput >>= fun _ => + projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + exact hpointwise + _ = _ := OracleComp.DeferredSampling.evalDist_bind_const_neverFails + LazyRevealProbe.sampleHashOutput (by + simp [LazyRevealProbe.sampleHashOutput]) + (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) + +theorem evalDist_map_resolveDeferredChainStart_then_finalize_of_not_mem + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (coordinates : List Coordinate) (context : DeferredContext) + (hstate : context.state.values index.coordinate = none) + (hclear : context.state.clearPending index.coordinate = context.state) : + evalDist (do + let resolved := resolveDeferredChainStart table index context + match resolved with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some resolved => projectDeferredState <$> + finalizeResolvedCoordinates coordinates resolved.toDeferredContext table) = + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := by + have hclean : ¬context.state.hitAt index.coordinate (table index) := by + rw [← hclear] + exact not_hitAt_clearPending_self context.state index.coordinate (table index) + rw [resolveDeferredChainStart_of_missing table index context hstate, if_neg hclean] + simp [hclear] + +def PendingCovered (coordinates : List Coordinate) (context : DeferredContext) : Prop := + ∀ entry, entry ∈ context.state.pending → entry.1 ∈ coordinates + +theorem pendingCovered_coordinates_toList (context : DeferredContext) : + PendingCovered context.state.coordinates.toList context := by + intro entry hentry + simp only [Finset.mem_toList, LazyRevealProbe.State.coordinates] + exact Finset.mem_union_right _ (Finset.mem_image_of_mem _ hentry) + +theorem PendingCovered.clearPending + {coordinates : List Coordinate} {context : DeferredContext} + (hcovered : PendingCovered coordinates context) (coordinate : Coordinate) : + PendingCovered coordinates + { context with state := context.state.clearPending coordinate } := by + intro entry hentry + apply hcovered entry + simp [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway] at hentry + exact hentry.1 + +theorem clearPending_eq_self_of_pendingCovered_not_mem + (coordinates : List Coordinate) (context : DeferredContext) + (hcovered : PendingCovered coordinates context) + (coordinate : Coordinate) (hnotMem : coordinate ∉ coordinates) : + context.state.clearPending coordinate = context.state := by + rcases context with ⟨state, values⟩ + rcases state with ⟨pending, stateValues, revealed, ensured⟩ + simp only [LazyRevealProbe.State.clearPending] + congr 1 + apply Finset.filter_eq_self.2 + intro entry hentry + simp only [ne_eq] + intro heq + exact hnotMem (heq ▸ hcovered entry hentry) + +theorem PendingCovered.of_resolveDeferredPositionValue + {coordinates : List Coordinate} {context : DeferredContext} + (hcovered : PendingCovered coordinates context) + (position : Position) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) : + PendingCovered coordinates result.toDeferredContext := by + cases hstate : context.state.values (.position position) with + | some output => + rw [resolveDeferredPositionValue_of_state_value position context output hstate] at hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + exact hcovered.clearPending (.position position) + | none => + cases hvalue : context.values position with + | some output => + rw [resolveDeferredPositionValue_of_deferred_value position context output hstate + hvalue] at hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + exact hcovered.clearPending (.position position) + | none => + rw [resolveDeferredPositionValue_fresh position context hstate hvalue, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hreturn⟩ := hresult + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] at hreturn + · simp [hhit] at hreturn + subst result + exact hcovered.clearPending (.position position) + +theorem PendingCovered.of_resolveDeferredChainStart + {coordinates : List Coordinate} {context : DeferredContext} + (hcovered : PendingCovered coordinates context) + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + PendingCovered coordinates result.toDeferredContext := by + unfold resolveDeferredChainStart at hresult + cases hstate : context.state.values index.coordinate with + | some output => + simp only [hstate] at hresult + by_cases hhit : context.state.hitAt index.coordinate output + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + exact hcovered.clearPending index.coordinate + | none => + simp only [hstate] at hresult + by_cases hhit : context.state.hitAt index.coordinate (table index) + · simp [hhit] at hresult + · simp [hhit] at hresult + subst result + exact hcovered.clearPending index.coordinate + +theorem PendingCovered.of_resolveDeferredChainPrefix + {coordinates : List Coordinate} {context : DeferredContext} + (hcovered : PendingCovered coordinates context) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : ∀ steps hsteps result, + some result ∈ support + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) → + PendingCovered coordinates result.toDeferredContext + | 0, hsteps, result, hresult => by + simp only [resolveDeferredChainPrefix, support_pure, Set.mem_singleton_iff] at hresult + exact hcovered.of_resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ + result hresult.symm + | steps + 1, hsteps, result, hresult => by + rw [resolveDeferredChainPrefix, mem_support_bind_iff] at hresult + obtain ⟨previousOption, hprevious, hrest⟩ := hresult + cases previousOption with + | none => simp at hrest + | some previous => + have hmiddle := hcovered.of_resolveDeferredChainPrefix table lay tree leafIdx chainIdx + steps (by omega) previous hprevious + exact hmiddle.of_resolveDeferredPositionValue + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) result (by simpa using hrest) + +theorem PendingCovered.of_resolveDeferredChains + {coordinates : List Coordinate} {context : DeferredContext} + (hcovered : PendingCovered coordinates context) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ chains result, + some result ∈ support + (resolveDeferredChains table lay tree leafIdx chains context) → + PendingCovered coordinates result + | [], result, hresult => by + simp [resolveDeferredChains] at hresult + subst result + exact hcovered + | chainIdx :: remaining, result, hresult => by + rw [resolveDeferredChains, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hmiddle := hcovered.of_resolveDeferredChainPrefix table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) resolved hresolved + exact hmiddle.of_resolveDeferredChains table lay tree leafIdx remaining result + (by simpa using hrest) + +theorem PendingCovered.of_resolveDeferredOtsLeaf + {coordinates : List Coordinate} {context : DeferredContext} + (hcovered : PendingCovered coordinates context) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredOtsLeaf table lay tree leafIdx context)) : + PendingCovered coordinates result.toDeferredContext := by + rw [resolveDeferredOtsLeaf, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + have hmiddle := hcovered.of_resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) chains hchains + exact hmiddle.of_resolveDeferredPositionValue (.leaf lay tree leafIdx) result + (by simpa using hrest) + +theorem PendingCovered.of_resolveDeferredTreeNode + {coordinates : List Coordinate} {context : DeferredContext} + (hcovered : PendingCovered coordinates context) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel result, + some result ∈ support + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) → + PendingCovered coordinates result.toDeferredContext + | 0, nodeIdx, hlevel, result, hresult => + hcovered.of_resolveDeferredOtsLeaf table lay tree (leafOfNat nodeIdx) result hresult + | level + 1, nodeIdx, hlevel, result, hresult => by + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨leftOption, hleft, hafterLeft⟩ := hresult + cases leftOption with + | none => simp at hafterLeft + | some left => + rw [mem_support_bind_iff] at hafterLeft + obtain ⟨rightOption, hright, hafterRight⟩ := hafterLeft + cases rightOption with + | none => simp at hafterRight + | some right => + have hleftCovered := hcovered.of_resolveDeferredTreeNode table lay tree level + (2 * nodeIdx) (by omega) left hleft + have hrightCovered := hleftCovered.of_resolveDeferredTreeNode table lay tree level + (2 * nodeIdx + 1) (by omega) right hright + exact hrightCovered.of_resolveDeferredPositionValue + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) result + (by simpa using hafterRight) + +theorem PendingCovered.of_resolveDeferredPosition + {coordinates : List Coordinate} {context : DeferredContext} + (hcovered : PendingCovered coordinates context) + (table : OtsSecretIndex → HashOutput) (position : Position) + (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPosition table position context)) : + PendingCovered coordinates result.toDeferredContext := by + cases position with + | chain lay tree leafIdx chainIdx step => + exact hcovered.of_resolveDeferredChainPrefix table lay tree leafIdx chainIdx + (step.val + 1) (by have := step.isLt; omega) result hresult + | leaf lay tree leafIdx => + exact hcovered.of_resolveDeferredOtsLeaf table lay tree leafIdx result hresult + | node lay tree level nodeIdx => + exact hcovered.of_resolveDeferredTreeNode table lay tree (level.val + 1) nodeIdx + (by have := level.isLt; omega) result hresult + | ftsLeaf index tree leafIdx => + exact hcovered.of_resolveDeferredPositionValue (.ftsLeaf index tree leafIdx) result hresult + | ftsNode index tree level nodeIdx => + exact hcovered.of_resolveDeferredPositionValue (.ftsNode index tree level nodeIdx) result + hresult + | ftsRoots index => + exact hcovered.of_resolveDeferredPositionValue (.ftsRoots index) result hresult + +set_option maxRecDepth 100000 in +theorem evalDist_map_resolveDeferredPositionValue_then_finalize + (position : Position) (coordinates : List Coordinate) + (context : DeferredContext) (table : OtsSecretIndex → HashOutput) + (hvalid : context.Valid) (hcovered : PendingCovered coordinates context) : + evalDist (do + let resolved ← resolveDeferredPositionValue position context + match resolved with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some resolved => projectDeferredState <$> + finalizeResolvedCoordinates coordinates resolved.toDeferredContext table) = + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := by + by_cases hmem : Coordinate.position position ∈ coordinates + · have hbase := evalDist_resolveDeferredPositionValue_then_finalize position coordinates + context table hmem (fun output hvalue => + ⟨hvalid.1 position output hvalue, hvalid.2 (.position position) output hvalue⟩) + calc + _ = evalDist (projectDeferredState <$> (do + let resolved ← resolveDeferredPositionValue position context + (match resolved with + | none => (pure none : ProbComp (Option DeferredContext)) + | some resolved => finalizeResolvedCoordinates coordinates + resolved.toDeferredContext table))) := by + simp only [evalDist_bind, evalDist_map, map_bind] + congr 1 + funext resolved + cases resolved <;> simp [projectDeferredState] + _ = evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := by + rw [evalDist_map, evalDist_map, hbase] + · have hclear := clearPending_eq_self_of_pendingCovered_not_mem coordinates context + hcovered (.position position) hmem + cases hstate : context.state.values (.position position) with + | none => + exact evalDist_map_resolveDeferredPositionValue_then_finalize_of_not_mem position + coordinates context table hmem hstate hclear + | some output => + have hprivate := hvalid.1 position output hstate + have hclean := hvalid.2 (.position position) output hstate + rw [resolveDeferredPositionValue_of_state_value position context output hstate, + if_neg hclean] + simp only [pure_bind, hclear] + have hinstall : context.values.install position output = context.values := by + funext other + by_cases heq : other = position + · subst other + simp [DeferredStructuralValues.install, hprivate] + · simp [DeferredStructuralValues.install, heq] + simp [hinstall] + +set_option maxRecDepth 100000 in +theorem evalDist_map_resolveDeferredChainStart_then_finalize + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (coordinates : List Coordinate) (context : DeferredContext) + (hvalid : context.Valid) (hcovered : PendingCovered coordinates context) : + evalDist (match resolveDeferredChainStart table index context with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some resolved => projectDeferredState <$> + finalizeResolvedCoordinates coordinates resolved.toDeferredContext table) = + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := by + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + let coordinate := Coordinate.chainStart lay tree leafIdx chainIdx + by_cases hmem : coordinate ∈ coordinates + · have hbase := evalDist_resolveDeferredChainStart_then_finalize table lay tree leafIdx + chainIdx coordinates context hmem hvalid + calc + _ = evalDist (projectDeferredState <$> (match + resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context with + | none => (pure none : ProbComp (Option DeferredContext)) + | some resolved => finalizeResolvedCoordinates coordinates + resolved.toDeferredContext table)) := by + cases resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context <;> + simp [projectDeferredState] + _ = evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := by + rw [evalDist_map, evalDist_map, hbase] + · have hclear := clearPending_eq_self_of_pendingCovered_not_mem coordinates context + hcovered coordinate hmem + cases hstate : context.state.values coordinate with + | none => + exact evalDist_map_resolveDeferredChainStart_then_finalize_of_not_mem table + ⟨lay, tree, leafIdx, chainIdx⟩ coordinates context + (by simpa [coordinate, OtsSecretIndex.coordinate] using hstate) + (by simpa [coordinate, OtsSecretIndex.coordinate] using hclear) + | some output => + have hclean := hvalid.2 coordinate output hstate + unfold resolveDeferredChainStart + simp [coordinate, OtsSecretIndex.coordinate, hstate, hclean, hclear] + +set_option maxRecDepth 100000 in +theorem evalDist_map_resolveDeferredChainPrefix_then_finalize + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (coordinates : List Coordinate) (context : DeferredContext) + (hvalid : context.Valid) (hcovered : PendingCovered coordinates context) : + ∀ steps hsteps, + evalDist (do + let resolved ← resolveDeferredChainPrefix table lay tree leafIdx chainIdx + steps hsteps context + match resolved with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some resolved => projectDeferredState <$> + finalizeResolvedCoordinates coordinates resolved.toDeferredContext table) = + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) + | 0, hsteps => by + simpa [resolveDeferredChainPrefix] using + evalDist_map_resolveDeferredChainStart_then_finalize table + ⟨lay, tree, leafIdx, chainIdx⟩ coordinates context hvalid hcovered + | steps + 1, hsteps => by + rw [resolveDeferredChainPrefix] + simp only [bind_assoc] + calc + _ = evalDist + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps (by omega) context + >>= fun previousOption => + match previousOption with + | none => pure none + | some previous => projectDeferredState <$> + finalizeResolvedCoordinates coordinates previous.toDeferredContext table) := by + apply evalDist_bind_congr + intro previousOption hprevious + cases previousOption with + | none => rfl + | some previous => + have hmiddleValid := hvalid.of_resolveDeferredChainPrefix table lay tree leafIdx + chainIdx steps (by omega) previous hprevious + have hmiddleCovered := hcovered.of_resolveDeferredChainPrefix table lay tree leafIdx + chainIdx steps (by omega) previous hprevious + exact evalDist_map_resolveDeferredPositionValue_then_finalize + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + coordinates previous.toDeferredContext table hmiddleValid hmiddleCovered + _ = evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := + evalDist_map_resolveDeferredChainPrefix_then_finalize table lay tree leafIdx chainIdx + coordinates context hvalid hcovered steps (by omega) + +set_option maxRecDepth 100000 in +theorem evalDist_map_resolveDeferredChains_then_finalize + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (coordinates : List Coordinate) : + ∀ chains context, + context.Valid → PendingCovered coordinates context → + evalDist (do + let resolved ← resolveDeferredChains table lay tree leafIdx chains context + match resolved with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some resolved => projectDeferredState <$> + finalizeResolvedCoordinates coordinates resolved table) = + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) + | [], context, hvalid, hcovered => by + simp [resolveDeferredChains] + | chainIdx :: remaining, context, hvalid, hcovered => by + rw [resolveDeferredChains] + simp only [bind_assoc] + calc + _ = evalDist + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context >>= fun resolvedOption => + match resolvedOption with + | none => pure none + | some resolved => projectDeferredState <$> + finalizeResolvedCoordinates coordinates resolved.toDeferredContext table) := by + apply evalDist_bind_congr + intro resolvedOption hresolved + cases resolvedOption with + | none => rfl + | some resolved => + have hmiddleValid := hvalid.of_resolveDeferredChainPrefix table lay tree leafIdx + chainIdx (chainLength - 1) (by omega) resolved hresolved + have hmiddleCovered := hcovered.of_resolveDeferredChainPrefix table lay tree leafIdx + chainIdx (chainLength - 1) (by omega) resolved hresolved + exact evalDist_map_resolveDeferredChains_then_finalize table lay tree leafIdx + coordinates remaining resolved.toDeferredContext hmiddleValid hmiddleCovered + _ = evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := + evalDist_map_resolveDeferredChainPrefix_then_finalize table lay tree leafIdx chainIdx + coordinates context hvalid hcovered (chainLength - 1) (by omega) + +set_option maxRecDepth 100000 in +theorem evalDist_map_resolveDeferredOtsLeaf_then_finalize + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (coordinates : List Coordinate) (context : DeferredContext) + (hvalid : context.Valid) (hcovered : PendingCovered coordinates context) : + evalDist (do + let resolved ← resolveDeferredOtsLeaf table lay tree leafIdx context + match resolved with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some resolved => projectDeferredState <$> + finalizeResolvedCoordinates coordinates resolved.toDeferredContext table) = + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := by + rw [resolveDeferredOtsLeaf] + simp only [bind_assoc] + calc + _ = evalDist + (resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) context >>= fun chainsOption => + match chainsOption with + | none => pure none + | some chains => projectDeferredState <$> + finalizeResolvedCoordinates coordinates chains table) := by + apply evalDist_bind_congr + intro chainsOption hchains + cases chainsOption with + | none => rfl + | some chains => + have hmiddleValid := hvalid.of_resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) chains hchains + have hmiddleCovered := hcovered.of_resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) chains hchains + exact evalDist_map_resolveDeferredPositionValue_then_finalize + (.leaf lay tree leafIdx) coordinates chains table hmiddleValid hmiddleCovered + _ = evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := + evalDist_map_resolveDeferredChains_then_finalize table lay tree leafIdx coordinates + (List.ofFn fun chainIdx : ChainIndex => chainIdx) context hvalid hcovered + +set_option maxRecDepth 100000 in +theorem evalDist_map_resolveDeferredTreeNode_then_finalize + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (coordinates : List Coordinate) : ∀ level nodeIdx hlevel context, + context.Valid → PendingCovered coordinates context → + evalDist (do + let resolved ← resolveDeferredTreeNode table lay tree level nodeIdx hlevel context + match resolved with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some resolved => projectDeferredState <$> + finalizeResolvedCoordinates coordinates resolved.toDeferredContext table) = + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) + | 0, nodeIdx, hlevel, context, hvalid, hcovered => by + simpa [resolveDeferredTreeNode] using + evalDist_map_resolveDeferredOtsLeaf_then_finalize table lay tree (leafOfNat nodeIdx) + coordinates context hvalid hcovered + | level + 1, nodeIdx, hlevel, context, hvalid, hcovered => by + rw [resolveDeferredTreeNode] + simp only [bind_assoc] + calc + _ = evalDist + (resolveDeferredTreeNode table lay tree level (2 * nodeIdx) (by omega) context + >>= fun leftOption => + match leftOption with + | none => pure none + | some left => projectDeferredState <$> + finalizeResolvedCoordinates coordinates left.toDeferredContext table) := by + apply evalDist_bind_congr + intro leftOption hleft + cases leftOption with + | none => rfl + | some left => + simp only [bind_assoc] + have hleftValid := hvalid.of_resolveDeferredTreeNode table lay tree level + (2 * nodeIdx) (by omega) left hleft + have hleftCovered := hcovered.of_resolveDeferredTreeNode table lay tree level + (2 * nodeIdx) (by omega) left hleft + calc + _ = evalDist + (resolveDeferredTreeNode table lay tree level (2 * nodeIdx + 1) + (by omega) left.toDeferredContext >>= fun rightOption => + match rightOption with + | none => pure none + | some right => projectDeferredState <$> + finalizeResolvedCoordinates coordinates right.toDeferredContext table) := by + apply evalDist_bind_congr + intro rightOption hright + cases rightOption with + | none => rfl + | some right => + have hrightValid := hleftValid.of_resolveDeferredTreeNode table lay tree + level (2 * nodeIdx + 1) (by omega) right hright + have hrightCovered := hleftCovered.of_resolveDeferredTreeNode table lay tree + level (2 * nodeIdx + 1) (by omega) right hright + exact evalDist_map_resolveDeferredPositionValue_then_finalize + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) + coordinates right.toDeferredContext table hrightValid hrightCovered + _ = evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates left.toDeferredContext table) := + evalDist_map_resolveDeferredTreeNode_then_finalize table lay tree coordinates + level (2 * nodeIdx + 1) (by omega) left.toDeferredContext hleftValid + hleftCovered + _ = evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := + evalDist_map_resolveDeferredTreeNode_then_finalize table lay tree coordinates + level (2 * nodeIdx) (by omega) context hvalid hcovered + +set_option maxRecDepth 100000 in +theorem evalDist_map_resolveDeferredPosition_then_finalize + (table : OtsSecretIndex → HashOutput) (position : Position) + (coordinates : List Coordinate) (context : DeferredContext) + (hvalid : context.Valid) (hcovered : PendingCovered coordinates context) : + evalDist (do + let resolved ← resolveDeferredPosition table position context + match resolved with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some resolved => projectDeferredState <$> + finalizeResolvedCoordinates coordinates resolved.toDeferredContext table) = + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := by + cases position with + | chain lay tree leafIdx chainIdx step => + exact evalDist_map_resolveDeferredChainPrefix_then_finalize table lay tree leafIdx chainIdx + coordinates context hvalid hcovered (step.val + 1) (by have := step.isLt; omega) + | leaf lay tree leafIdx => + exact evalDist_map_resolveDeferredOtsLeaf_then_finalize table lay tree leafIdx coordinates + context hvalid hcovered + | node lay tree level nodeIdx => + exact evalDist_map_resolveDeferredTreeNode_then_finalize table lay tree coordinates + (level.val + 1) nodeIdx (by have := level.isLt; omega) context hvalid hcovered + | ftsLeaf index tree leafIdx => + exact evalDist_map_resolveDeferredPositionValue_then_finalize + (.ftsLeaf index tree leafIdx) coordinates context table hvalid hcovered + | ftsNode index tree level nodeIdx => + exact evalDist_map_resolveDeferredPositionValue_then_finalize + (.ftsNode index tree level nodeIdx) coordinates context table hvalid hcovered + | ftsRoots index => + exact evalDist_map_resolveDeferredPositionValue_then_finalize + (.ftsRoots index) coordinates context table hvalid hcovered + +set_option maxRecDepth 100000 in +theorem evalDist_map_resolveDeferredReveal_then_finalize + (table : OtsSecretIndex → HashOutput) (position : Position) + (coordinates : List Coordinate) (context : DeferredContext) + (hvalid : context.Valid) (hcovered : PendingCovered coordinates context) : + evalDist (do + let resolved ← resolveDeferredReveal table position context + match resolved with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some resolved => projectDeferredState <$> + finalizeResolvedCoordinates coordinates resolved.toDeferredContext table) = + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := by + by_cases hresolvable : ResolvableOtsPosition position + · simpa [resolveDeferredReveal, hresolvable] using + evalDist_map_resolveDeferredPosition_then_finalize table position coordinates context + hvalid hcovered + · simpa [resolveDeferredReveal, hresolvable] using + evalDist_map_resolveDeferredPositionValue_then_finalize position coordinates context table + hvalid hcovered + +def DeferredCompletion (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (completion : Coordinate → HashOutput) : Prop := + (∀ coordinate output, context.state.values coordinate = some output → + completion coordinate = output) ∧ + (∀ position output, context.values position = some output → + completion (.position position) = output) ∧ + (∀ coordinate candidate, (coordinate, candidate) ∈ context.state.pending → + truncateHash (completion coordinate) ≠ candidate) ∧ + ∀ index, completion index.coordinate = table index + +def DeferredContext.CoreEq (left right : DeferredContext) : Prop := + left.state.pending = right.state.pending ∧ + left.state.values = right.state.values ∧ + left.values = right.values + +theorem DeferredContext.CoreEq.symm {left right : DeferredContext} + (heq : left.CoreEq right) : right.CoreEq left := + ⟨heq.1.symm, heq.2.1.symm, heq.2.2.symm⟩ + +theorem DeferredContext.CoreEq.positionValue_eq {left right : DeferredContext} + (heq : left.CoreEq right) : left.positionValue = right.positionValue := by + funext position + unfold DeferredContext.positionValue + rw [heq.2.1, heq.2.2] + +theorem DeferredContext.CoreEq.hitAt_iff {left right : DeferredContext} + (heq : left.CoreEq right) (coordinate : Coordinate) (output : HashOutput) : + left.state.hitAt coordinate output ↔ right.state.hitAt coordinate output := by + unfold LazyRevealProbe.State.hitAt LazyRevealProbe.State.pendingAt + rw [heq.1] + +theorem DeferredContext.Valid.of_coreEq {left right : DeferredContext} + (hvalid : left.Valid) (heq : left.CoreEq right) : right.Valid := by + constructor + · intro position output hvalue + rw [← heq.2.2] + apply hvalid.1 position output + rw [heq.2.1] + exact hvalue + · intro coordinate output hvalue + rw [← heq.hitAt_iff coordinate output] + apply hvalid.2 coordinate output + rw [heq.2.1] + exact hvalue + +theorem StartTableAgrees.of_coreEq + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hagrees : StartTableAgrees left.state table) (heq : left.CoreEq right) : + StartTableAgrees right.state table := by + intro index output hvalue + apply hagrees index output + rw [heq.2.1] + exact hvalue + +theorem StartTableAgrees.of_state_values_eq + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hagrees : StartTableAgrees left.state table) + (hvalues : right.state.values = left.state.values) : + StartTableAgrees right.state table := by + intro index output hvalue + apply hagrees index output + rw [← hvalues] + exact hvalue + +theorem DeferredCompletion.of_coreEq + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + {completion : Coordinate → HashOutput} (heq : left.CoreEq right) + (hcompletion : DeferredCompletion table left completion) : + DeferredCompletion table right completion := by + refine ⟨?_, ?_, ?_, hcompletion.2.2.2⟩ + · intro coordinate output hvalue + apply hcompletion.1 coordinate output + rw [heq.2.1] + exact hvalue + · intro position output hvalue + apply hcompletion.2.1 position output + rw [heq.2.2] + exact hvalue + · intro coordinate candidate hmember + apply hcompletion.2.2.1 coordinate candidate + rw [heq.1] + exact hmember + +theorem DeferredCompletion.of_addPending + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} (coordinate : Coordinate) + (candidate : Digest) + (hcompletion : DeferredCompletion table + { context with state := context.state.addPending coordinate candidate } completion) : + DeferredCompletion table context completion := by + refine ⟨hcompletion.1, hcompletion.2.1, ?_, hcompletion.2.2.2⟩ + intro other otherCandidate hmember + apply hcompletion.2.2.1 other otherCandidate + simp only [LazyRevealProbe.State.addPending, Finset.mem_insert] + exact Or.inr hmember + +theorem DeferredCompletion.eq_positionValue + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hcompletion : DeferredCompletion table context completion) + (position : Position) (output : HashOutput) + (hvalue : context.positionValue position = some output) : + completion (.position position) = output := by + unfold DeferredContext.positionValue at hvalue + cases hstate : context.state.values (.position position) with + | some cached => + have hcached : cached = output := by simpa [hstate] using hvalue + exact (hcompletion.1 (.position position) cached hstate).trans hcached + | none => + exact hcompletion.2.1 position output (by simpa [hstate] using hvalue) + +def materializeResolvedPosition (context : DeferredContext) (position : Position) + (result : DeferredResolution) : DeferredContext := + { state := context.state.materialize (.position position) result.output + values := result.values } + +theorem materializeResolvedPosition_positionValue_eq + (context : DeferredContext) (position : Position) (result : DeferredResolution) + (hstateValues : result.state.values = context.state.values) + (hresolved : result.toDeferredContext.positionValue position = some result.output) : + (materializeResolvedPosition context position result).positionValue = + result.toDeferredContext.positionValue := by + funext other + by_cases heq : other = position + · subst other + rw [hresolved] + simp [materializeResolvedPosition, DeferredContext.positionValue, + LazyRevealProbe.State.materialize] + · unfold DeferredContext.positionValue + rw [hstateValues] + simp [materializeResolvedPosition, LazyRevealProbe.State.materialize, + Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by simpa using heq] + +theorem DeferredContext.ValuesConsistent.materializeResolvedPosition_of + {context : DeferredContext} (hconsistent : context.ValuesConsistent) + (table : OtsSecretIndex → HashOutput) (position : Position) + (result : DeferredResolution) + (hresult : some result ∈ support (resolveDeferredReveal table position context)) : + (materializeResolvedPosition context position result).ValuesConsistent := by + have hresultConsistent := hconsistent.of_resolveDeferredReveal table position result hresult + have hstateValues := resolveDeferredReveal_preserves_state_values table position context result + hresult + intro other output hvalue + by_cases heq : other = position + · subst other + have hsame : output = result.output := by + simpa [materializeResolvedPosition, LazyRevealProbe.State.materialize] using hvalue.symm + rw [hsame] + change result.values position = some result.output + have hresolved := resolveDeferredReveal_resolves table position context result hresult + unfold DeferredContext.positionValue at hresolved + cases hstate : result.state.values (.position position) with + | none => simpa [hstate] using hresolved + | some cached => + have hprivate := hresultConsistent position cached hstate + have hcached : cached = result.output := by simpa [hstate] using hresolved + simpa [hcached] using hprivate + · apply hresultConsistent other output + rw [hstateValues] + simpa [materializeResolvedPosition, LazyRevealProbe.State.materialize, + Function.update_of_ne, + show Coordinate.position other ≠ Coordinate.position position by simpa using heq] + using hvalue + +theorem DeferredCompletion.of_materializeResolvedPosition + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} (position : Position) + (result : DeferredResolution) + (hstateValues : result.state.values = context.state.values) + (hpending : result.state.pending ⊆ + context.state.pendingAway (.position position)) + (hresolved : result.toDeferredContext.positionValue position = some result.output) + (hcompletion : DeferredCompletion table + (materializeResolvedPosition context position result) completion) : + DeferredCompletion table result.toDeferredContext completion := by + refine ⟨?_, hcompletion.2.1, ?_, hcompletion.2.2.2⟩ + · intro coordinate output hvalue + rw [hstateValues] at hvalue + by_cases heq : coordinate = .position position + · subst coordinate + have hresultValue : result.state.values (.position position) = some output := by + rw [hstateValues] + exact hvalue + unfold DeferredContext.positionValue at hresolved + rw [hresultValue] at hresolved + have hsame : output = result.output := Option.some.inj hresolved + apply hcompletion.1 (.position position) output + simp [materializeResolvedPosition, LazyRevealProbe.State.materialize, hsame] + · apply hcompletion.1 coordinate output + simpa [materializeResolvedPosition, LazyRevealProbe.State.materialize, + Function.update_of_ne heq] using hvalue + · intro coordinate candidate hmember + apply hcompletion.2.2.1 coordinate candidate + have haway := hpending hmember + simpa [materializeResolvedPosition, LazyRevealProbe.State.materialize] using haway + +theorem DeferredCompletion.of_resolveDeferredPositionValue_of_valuesConsistent + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hconsistent : context.ValuesConsistent) (position : Position) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) + (hcompletion : DeferredCompletion table result.toDeferredContext completion) : + DeferredCompletion table context completion := by + have hstateValues := resolveDeferredPositionValue_preserves_state_values + position context result hresult + have hresolved := resolveDeferredPositionValue_resolves position context result hresult + have hnotHit := resolveDeferredPositionValue_not_hit position context result hresult + have hpending := resolveDeferredPositionValue_pending position context result hresult + refine ⟨?_, ?_, ?_, hcompletion.2.2.2⟩ + · intro coordinate output hvalue + apply hcompletion.1 coordinate output + rw [hstateValues] + exact hvalue + · intro other output hvalue + have hknown : context.positionValue other = some output := by + unfold DeferredContext.positionValue + cases hstate : context.state.values (.position other) with + | some cached => + have hsame := hconsistent other cached hstate + have : cached = output := by + rw [hsame] at hvalue + exact Option.some.inj hvalue + simp [this] + | none => simp [hvalue] + exact hcompletion.eq_positionValue other output + (resolveDeferredPositionValue_preserves_positionValue position other context result + output hknown hresult) + · intro coordinate candidate hmember + by_cases heq : coordinate = .position position + · subst coordinate + have hcompletionValue := hcompletion.eq_positionValue position result.output hresolved + intro hequal + apply hnotHit + unfold LazyRevealProbe.State.hitAt LazyRevealProbe.State.pendingAt + rw [hcompletionValue] at hequal + simpa [hequal] using hmember + · apply hcompletion.2.2.1 coordinate candidate + rw [hpending] + simpa [LazyRevealProbe.State.pendingAway, heq] using hmember + +theorem DeferredCompletion.of_resolveDeferredPositionValue + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hvalid : context.Valid) (position : Position) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) + (hcompletion : DeferredCompletion table result.toDeferredContext completion) : + DeferredCompletion table context completion := + hcompletion.of_resolveDeferredPositionValue_of_valuesConsistent hvalid.valuesConsistent + position result hresult + +theorem DeferredCompletion.of_resolveDeferredChainStart + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hagrees : StartTableAgrees context.state table) (index : OtsSecretIndex) + (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) + (hcompletion : DeferredCompletion table result.toDeferredContext completion) : + DeferredCompletion table context completion := by + unfold resolveDeferredChainStart at hresult + cases hstate : context.state.values index.coordinate with + | some cached => + have hcached := hagrees index cached hstate + subst cached + by_cases hhit : context.state.hitAt index.coordinate (table index) + · simp [hstate, hhit] at hresult + · simp [hstate, hhit] at hresult + subst result + refine ⟨hcompletion.1, hcompletion.2.1, ?_, hcompletion.2.2.2⟩ + intro coordinate candidate hmember + by_cases heq : coordinate = index.coordinate + · subst coordinate + intro hequal + apply hhit + unfold LazyRevealProbe.State.hitAt LazyRevealProbe.State.pendingAt + rw [hcompletion.2.2.2 index] at hequal + simpa [hequal] using hmember + · apply hcompletion.2.2.1 coordinate candidate + simpa [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway, + heq] using hmember + | none => + by_cases hhit : context.state.hitAt index.coordinate (table index) + · simp [hstate, hhit] at hresult + · simp [hstate, hhit] at hresult + subst result + refine ⟨hcompletion.1, hcompletion.2.1, ?_, hcompletion.2.2.2⟩ + intro coordinate candidate hmember + by_cases heq : coordinate = index.coordinate + · subst coordinate + intro hequal + apply hhit + unfold LazyRevealProbe.State.hitAt LazyRevealProbe.State.pendingAt + rw [hcompletion.2.2.2 index] at hequal + simpa [hequal] using hmember + · apply hcompletion.2.2.1 coordinate candidate + simpa [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway, + heq] using hmember + +theorem DeferredCompletion.of_resolveDeferredChainPrefix + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps result, + some result ∈ support + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) → + DeferredCompletion table result.toDeferredContext completion → + DeferredCompletion table context completion + | 0, hsteps, result, hresult, hcompletion => by + simp only [resolveDeferredChainPrefix, support_pure, Set.mem_singleton_iff] at hresult + exact hcompletion.of_resolveDeferredChainStart hstarts ⟨lay, tree, leafIdx, chainIdx⟩ + result hresult.symm + | steps + 1, hsteps, result, hresult, hcompletion => by + rw [resolveDeferredChainPrefix, mem_support_bind_iff] at hresult + obtain ⟨previousOption, hprevious, hrest⟩ := hresult + cases previousOption with + | none => simp at hrest + | some previous => + have hpreviousConsistent := hconsistent.of_resolveDeferredChainPrefix table lay tree + leafIdx chainIdx steps (by omega) previous hprevious + have hbeforeLast := hcompletion.of_resolveDeferredPositionValue_of_valuesConsistent + hpreviousConsistent (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) result + (by simpa using hrest) + exact hbeforeLast.of_resolveDeferredChainPrefix hconsistent hstarts lay tree leafIdx + chainIdx steps (by omega) previous hprevious + +theorem DeferredCompletion.of_resolveDeferredChains + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : ∀ chains result, + some result ∈ support + (resolveDeferredChains table lay tree leafIdx chains context) → + DeferredCompletion table result completion → + DeferredCompletion table context completion + | [], result, hresult, hcompletion => by + simp [resolveDeferredChains] at hresult + subst result + exact hcompletion + | chainIdx :: remaining, result, hresult, hcompletion => by + rw [resolveDeferredChains, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hresolvedConsistent := hconsistent.of_resolveDeferredChainPrefix table lay tree + leafIdx chainIdx (chainLength - 1) (by omega) resolved hresolved + have hstateValues := resolveDeferredChainPrefix_preserves_state_values table lay tree + leafIdx chainIdx (chainLength - 1) (by omega) context resolved hresolved + have hresolvedStarts := hstarts.of_state_values_eq hstateValues + have hbeforeTail := hcompletion.of_resolveDeferredChains hresolvedConsistent + hresolvedStarts lay tree leafIdx remaining result (by simpa using hrest) + exact hbeforeTail.of_resolveDeferredChainPrefix hconsistent hstarts lay tree leafIdx + chainIdx (chainLength - 1) (by omega) resolved hresolved + +theorem DeferredCompletion.of_resolveDeferredOtsLeaf + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredOtsLeaf table lay tree leafIdx context)) + (hcompletion : DeferredCompletion table result.toDeferredContext completion) : + DeferredCompletion table context completion := by + rw [resolveDeferredOtsLeaf, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + have hchainsConsistent := hconsistent.of_resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) chains hchains + have hbeforeLeaf := hcompletion.of_resolveDeferredPositionValue_of_valuesConsistent + hchainsConsistent (.leaf lay tree leafIdx) result (by simpa using hrest) + exact hbeforeLeaf.of_resolveDeferredChains hconsistent hstarts lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) chains hchains + +theorem DeferredCompletion.of_resolveDeferredTreeNode + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel result, + some result ∈ support + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) → + DeferredCompletion table result.toDeferredContext completion → + DeferredCompletion table context completion + | 0, nodeIdx, hlevel, result, hresult, hcompletion => + hcompletion.of_resolveDeferredOtsLeaf hconsistent hstarts lay tree (leafOfNat nodeIdx) + result hresult + | level + 1, nodeIdx, hlevel, result, hresult, hcompletion => by + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨leftOption, hleft, hafterLeft⟩ := hresult + cases leftOption with + | none => simp at hafterLeft + | some left => + rw [mem_support_bind_iff] at hafterLeft + obtain ⟨rightOption, hright, hafterRight⟩ := hafterLeft + cases rightOption with + | none => simp at hafterRight + | some right => + have hleftConsistent := hconsistent.of_resolveDeferredTreeNode table lay tree level + (2 * nodeIdx) (by omega) left hleft + have hleftState := resolveDeferredTreeNode_preserves_state_values table lay tree level + (2 * nodeIdx) (by omega) context left hleft + have hleftStarts := hstarts.of_state_values_eq hleftState + have hrightConsistent := hleftConsistent.of_resolveDeferredTreeNode table lay tree + level (2 * nodeIdx + 1) (by omega) right hright + have hrightState := resolveDeferredTreeNode_preserves_state_values table lay tree + level (2 * nodeIdx + 1) (by omega) left.toDeferredContext right hright + have hrightStarts := hleftStarts.of_state_values_eq hrightState + have hbeforeNode := + hcompletion.of_resolveDeferredPositionValue_of_valuesConsistent + hrightConsistent (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) + result (by simpa using hafterRight) + have hbeforeRight := hbeforeNode.of_resolveDeferredTreeNode hleftConsistent + hleftStarts lay tree level (2 * nodeIdx + 1) (by omega) right hright + exact hbeforeRight.of_resolveDeferredTreeNode hconsistent hstarts lay tree level + (2 * nodeIdx) (by omega) left hleft + +theorem DeferredCompletion.of_resolveDeferredPosition + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) (position : Position) + (result : DeferredResolution) + (hresult : some result ∈ support (resolveDeferredPosition table position context)) + (hcompletion : DeferredCompletion table result.toDeferredContext completion) : + DeferredCompletion table context completion := by + cases position with + | chain lay tree leafIdx chainIdx step => + exact hcompletion.of_resolveDeferredChainPrefix hconsistent hstarts lay tree leafIdx chainIdx + (step.val + 1) (by have := step.isLt; omega) result hresult + | leaf lay tree leafIdx => + exact hcompletion.of_resolveDeferredOtsLeaf hconsistent hstarts lay tree leafIdx result + hresult + | node lay tree level nodeIdx => + exact hcompletion.of_resolveDeferredTreeNode hconsistent hstarts lay tree + (level.val + 1) nodeIdx (by have := level.isLt; omega) result hresult + | ftsLeaf index tree leafIdx => + exact hcompletion.of_resolveDeferredPositionValue_of_valuesConsistent hconsistent + (.ftsLeaf index tree leafIdx) result hresult + | ftsNode index tree level nodeIdx => + exact hcompletion.of_resolveDeferredPositionValue_of_valuesConsistent hconsistent + (.ftsNode index tree level nodeIdx) result hresult + | ftsRoots index => + exact hcompletion.of_resolveDeferredPositionValue_of_valuesConsistent hconsistent + (.ftsRoots index) result hresult + +theorem DeferredCompletion.of_resolveDeferredReveal + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) (position : Position) + (result : DeferredResolution) + (hresult : some result ∈ support (resolveDeferredReveal table position context)) + (hcompletion : DeferredCompletion table result.toDeferredContext completion) : + DeferredCompletion table context completion := by + classical + by_cases hresolvable : ResolvableOtsPosition position + · apply hcompletion.of_resolveDeferredPosition hconsistent hstarts position result + simpa [resolveDeferredReveal, hresolvable] using hresult + · apply hcompletion.of_resolveDeferredPositionValue_of_valuesConsistent hconsistent + position result + simpa [resolveDeferredReveal, hresolvable] using hresult + +theorem resolveDeferredChainStart_positionValue_eq + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + result.toDeferredContext.positionValue = context.positionValue := by + unfold resolveDeferredChainStart at hresult + cases hstate : context.state.values index.coordinate with + | some output => + by_cases hhit : context.state.hitAt index.coordinate output + · simp [hstate, hhit] at hresult + · simp [hstate, hhit] at hresult + subst result + rfl + | none => + by_cases hhit : context.state.hitAt index.coordinate (table index) + · simp [hstate, hhit] at hresult + · simp [hstate, hhit] at hresult + subst result + rfl + +theorem resolveDeferredChainStart_state_values_eq + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + result.state.values = context.state.values := by + unfold resolveDeferredChainStart at hresult + cases hstate : context.state.values index.coordinate with + | some output => + by_cases hhit : context.state.hitAt index.coordinate output + · simp [hstate, hhit] at hresult + · simp [hstate, hhit] at hresult + subst result + rfl + | none => + by_cases hhit : context.state.hitAt index.coordinate (table index) + · simp [hstate, hhit] at hresult + · simp [hstate, hhit] at hresult + subst result + rfl + +theorem resolveDeferredChainStart_deferred_values_eq + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + result.values = context.values := by + unfold resolveDeferredChainStart at hresult + cases hstate : context.state.values index.coordinate with + | some output => + by_cases hhit : context.state.hitAt index.coordinate output + · simp [hstate, hhit] at hresult + · simp [hstate, hhit] at hresult + subst result + rfl + | none => + by_cases hhit : context.state.hitAt index.coordinate (table index) + · simp [hstate, hhit] at hresult + · simp [hstate, hhit] at hresult + subst result + rfl + +theorem resolveDeferredChainStart_pending_eq + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + result.state.pending = context.state.pendingAway index.coordinate := by + unfold resolveDeferredChainStart at hresult + cases hstate : context.state.values index.coordinate with + | some output => + by_cases hhit : context.state.hitAt index.coordinate output + · simp [hstate, hhit] at hresult + · simp [hstate, hhit] at hresult + subst result + rfl + + | none => + by_cases hhit : context.state.hitAt index.coordinate (table index) + · simp [hstate, hhit] at hresult + · simp [hstate, hhit] at hresult + subst result + rfl + +def materializeResolvedChainStart (context : DeferredContext) (index : OtsSecretIndex) + (result : DeferredResolution) : DeferredContext := + { state := context.state.materialize index.coordinate result.output + values := result.values } + +theorem materializeResolvedChainStart_positionValue_eq + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (context : DeferredContext) (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + (materializeResolvedChainStart context index result).positionValue = + context.positionValue := by + funext position + unfold DeferredContext.positionValue + change (match (context.state.materialize index.coordinate result.output).values + (.position position) with + | some output => some output + | none => result.values position) = _ + rw [resolveDeferredChainStart_deferred_values_eq table index context result hresult] + simp [LazyRevealProbe.State.materialize, OtsSecretIndex.coordinate] + +theorem DeferredContext.ValuesConsistent.materializeResolvedChainStart_of + {context : DeferredContext} (hconsistent : context.ValuesConsistent) + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + (materializeResolvedChainStart context index result).ValuesConsistent := by + intro position output hvalue + change result.values position = some output + rw [resolveDeferredChainStart_deferred_values_eq table index context result hresult] + apply hconsistent position output + simpa [materializeResolvedChainStart, LazyRevealProbe.State.materialize, + OtsSecretIndex.coordinate] using hvalue + +theorem DeferredCompletion.of_materializeResolvedChainStart + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hagrees : StartTableAgrees context.state table) (index : OtsSecretIndex) + (hcompletable : ∃ baseCompletion, DeferredCompletion table context baseCompletion) + (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) + (hcompletion : DeferredCompletion table + (materializeResolvedChainStart context index result) completion) : + DeferredCompletion table context completion := by + have houtput := resolveDeferredChainStart_output_of_agrees table index context result hagrees + hresult + have hdeferred := resolveDeferredChainStart_deferred_values_eq table index context result + hresult + refine ⟨?_, ?_, ?_, hcompletion.2.2.2⟩ + · intro coordinate output hvalue + by_cases heq : coordinate = index.coordinate + · subst coordinate + have htable := hagrees index output hvalue + apply hcompletion.1 index.coordinate output + simp [materializeResolvedChainStart, LazyRevealProbe.State.materialize, houtput, + htable] + · apply hcompletion.1 coordinate output + simpa [materializeResolvedChainStart, LazyRevealProbe.State.materialize, + Function.update_of_ne heq] using hvalue + · intro position output hvalue + apply hcompletion.2.1 position output + simpa [materializeResolvedChainStart, hdeferred] using hvalue + · intro coordinate candidate hmember + by_cases heq : coordinate = index.coordinate + · subst coordinate + obtain ⟨baseCompletion, hbaseCompletion⟩ := hcompletable + have havoid := hbaseCompletion.2.2.1 index.coordinate candidate hmember + rw [hbaseCompletion.2.2.2 index] at havoid + rw [hcompletion.2.2.2 index] + exact havoid + · apply hcompletion.2.2.1 coordinate candidate + have haway : (coordinate, candidate) ∈ context.state.pendingAway index.coordinate := + Finset.mem_filter.2 ⟨hmember, heq⟩ + simpa [materializeResolvedChainStart, LazyRevealProbe.State.materialize] using haway + +theorem resolveDeferredChainStart_not_hit + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hagrees : StartTableAgrees context.state table) (index : OtsSecretIndex) + (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + ¬context.state.hitAt index.coordinate (table index) := by + unfold resolveDeferredChainStart at hresult + cases hvalue : context.state.values index.coordinate with + | none => + by_cases hhit : context.state.hitAt index.coordinate (table index) + · simp [hvalue, hhit] at hresult + · exact hhit + | some output => + have houtput := hagrees index output hvalue + subst output + by_cases hhit : context.state.hitAt index.coordinate (table index) + · simp [hvalue, hhit] at hresult + · exact hhit + +theorem DeferredCompletion.of_materializeResolvedChainStart' + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hagrees : StartTableAgrees context.state table) (index : OtsSecretIndex) + (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) + (hcompletion : DeferredCompletion table + (materializeResolvedChainStart context index result) completion) : + DeferredCompletion table context completion := by + have houtput := resolveDeferredChainStart_output_of_agrees table index context result hagrees + hresult + have hdeferred := resolveDeferredChainStart_deferred_values_eq table index context result + hresult + have hnotHit := resolveDeferredChainStart_not_hit hagrees index result hresult + refine ⟨?_, ?_, ?_, hcompletion.2.2.2⟩ + · intro coordinate output hvalue + by_cases heq : coordinate = index.coordinate + · subst coordinate + have htable := hagrees index output hvalue + apply hcompletion.1 index.coordinate output + simp [materializeResolvedChainStart, LazyRevealProbe.State.materialize, houtput, + htable] + · apply hcompletion.1 coordinate output + simpa [materializeResolvedChainStart, LazyRevealProbe.State.materialize, + Function.update_of_ne heq] using hvalue + · intro position output hvalue + apply hcompletion.2.1 position output + simpa [materializeResolvedChainStart, hdeferred] using hvalue + · intro coordinate candidate hmember + by_cases heq : coordinate = index.coordinate + · subst coordinate + intro hequal + apply hnotHit + unfold LazyRevealProbe.State.hitAt LazyRevealProbe.State.pendingAt + rw [hcompletion.2.2.2 index] at hequal + simpa [hequal] using hmember + · apply hcompletion.2.2.1 coordinate candidate + have haway : (coordinate, candidate) ∈ context.state.pendingAway index.coordinate := + Finset.mem_filter.2 ⟨hmember, heq⟩ + simpa [materializeResolvedChainStart, LazyRevealProbe.State.materialize] using haway + +set_option maxRecDepth 100000 in +theorem DeferredCompletion.of_mem_runResolvedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult alpha) + (completion : Coordinate → HashOutput) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table computation)) + (hcompletion : DeferredCompletion table result.context completion) : + DeferredCompletion table context completion := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runResolvedFromTable] at hresult + subst result + exact hcompletion + | query_bind input next ih => + cases input with + | uniform n => + rw [runResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hconsistent hstarts hrest + | hashOutput => + rw [runResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hconsistent hstarts hrest + | ensure coordinate => + rw [runResolvedFromTable_ensure_query_bind] at hresult + have hcurrent := ih () { context with state := context.state.ensure coordinate } fuel + (hconsistent.ensure coordinate) (hstarts.ensure coordinate) hresult + exact hcurrent.of_coreEq ⟨rfl, rfl, rfl⟩ + | probe coordinate candidate => + rw [runResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · exact ih () context remaining hconsistent hstarts + (by simpa [hrevealed] using hresult) + · have hcurrent := ih () + { context with state := context.state.addPending coordinate candidate } + remaining (hconsistent.addPending coordinate candidate) + (hstarts.addPending coordinate candidate) + (by simpa [hrevealed] using hresult) + exact hcurrent.of_addPending coordinate candidate + | peek coordinate => + rw [runResolvedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hconsistent hstarts hresult + | publish coordinate => + rw [runResolvedFromTable_publish_query_bind] at hresult + have hcurrent := ih () { context with state := context.state.publish coordinate } fuel + (hconsistent.publish coordinate) (hstarts.publish coordinate) hresult + exact hcurrent.of_coreEq ⟨rfl, rfl, rfl⟩ + | reveal coordinate => + rw [runResolvedFromTable_reveal_query_bind] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + simp only [mem_support_bind_iff, support_pure, Set.mem_singleton_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hresolvedEq : resolveDeferredChainStart table index context = + some resolved := by simpa [index] using hresolved.symm + have hmaterializedConsistent := + hconsistent.materializeResolvedChainStart_of table index resolved hresolvedEq + have houtput := resolveDeferredChainStart_output_of_agrees table index context + resolved hstarts hresolvedEq + have hmaterializedStarts : StartTableAgrees + (context.state.materialize index.coordinate resolved.output) table := by + rw [houtput] + exact hstarts.materialize_start index + have hcurrent := ih resolved.output + (materializeResolvedChainStart context index resolved) fuel + hmaterializedConsistent (by + simpa [materializeResolvedChainStart] using hmaterializedStarts) + (by simpa [index, OtsSecretIndex.coordinate, materializeResolvedChainStart] + using hrest) + exact hcurrent.of_materializeResolvedChainStart' hstarts index resolved + hresolvedEq + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hmaterializedConsistent := + hconsistent.materializeResolvedPosition_of table position resolved hresolved + have hmaterializedStarts : StartTableAgrees + (context.state.materialize (.position position) resolved.output) table := + hstarts.materialize_position position resolved.output + have hcurrent := ih resolved.output + (materializeResolvedPosition context position resolved) fuel + hmaterializedConsistent (by + simpa [materializeResolvedPosition] using hmaterializedStarts) + (by simpa [materializeResolvedPosition] using hrest) + have hstateValues := resolveDeferredReveal_preserves_state_values table position + context resolved hresolved + have hpending := resolveDeferredReveal_pendingAway_subset table position context + resolved hresolved + have hresolvedValue := resolveDeferredReveal_resolves table position context + resolved hresolved + have hbeforeMaterialize := hcurrent.of_materializeResolvedPosition position + resolved hstateValues hpending hresolvedValue + exact hbeforeMaterialize.of_resolveDeferredReveal + hconsistent hstarts position resolved hresolved + +theorem deferredCompletable_of_mem_runResolvedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult alpha) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table computation)) + (hfinal : ∃ completion, DeferredCompletion table result.context completion) : + ∃ completion, DeferredCompletion table context completion := by + obtain ⟨completion, hcompletion⟩ := hfinal + exact ⟨completion, hcompletion.of_mem_runResolvedFromTable computation context fuel table + result completion hconsistent hstarts hresult⟩ + +set_option maxRecDepth 100000 in +theorem resolvedCore_of_mem_runResolvedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult alpha) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table computation)) : + result.table = table ∧ result.context.ValuesConsistent ∧ + StartTableAgrees result.context.state table := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runResolvedFromTable] at hresult + subst result + exact ⟨rfl, hconsistent, hstarts⟩ + | query_bind input next ih => + cases input with + | uniform n => + rw [runResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hconsistent hstarts hrest + | hashOutput => + rw [runResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel hconsistent hstarts hrest + | ensure coordinate => + rw [runResolvedFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel + (hconsistent.ensure coordinate) (hstarts.ensure coordinate) hresult + | probe coordinate candidate => + rw [runResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ context.state.revealed + · exact ih () context remaining hconsistent hstarts + (by simpa [hrevealed] using hresult) + · exact ih () { context with state := context.state.addPending coordinate candidate } + remaining (hconsistent.addPending coordinate candidate) + (hstarts.addPending coordinate candidate) + (by simpa [hrevealed] using hresult) + | peek coordinate => + rw [runResolvedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hconsistent hstarts hresult + | publish coordinate => + rw [runResolvedFromTable_publish_query_bind] at hresult + exact ih () { context with state := context.state.publish coordinate } fuel + (hconsistent.publish coordinate) (hstarts.publish coordinate) hresult + | reveal coordinate => + rw [runResolvedFromTable_reveal_query_bind] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + simp only [mem_support_bind_iff, support_pure, Set.mem_singleton_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hresolvedEq : resolveDeferredChainStart table index context = + some resolved := by simpa [index] using hresolved.symm + have hmaterializedConsistent := + hconsistent.materializeResolvedChainStart_of table index resolved hresolvedEq + have houtput := resolveDeferredChainStart_output_of_agrees table index context + resolved hstarts hresolvedEq + have hmaterializedStarts : StartTableAgrees + (context.state.materialize index.coordinate resolved.output) table := by + rw [houtput] + exact hstarts.materialize_start index + exact ih resolved.output (materializeResolvedChainStart context index resolved) + fuel hmaterializedConsistent (by + simpa [materializeResolvedChainStart] using hmaterializedStarts) + (by simpa [index, OtsSecretIndex.coordinate, materializeResolvedChainStart] + using hrest) + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hmaterializedConsistent := + hconsistent.materializeResolvedPosition_of table position resolved hresolved + have hmaterializedStarts : StartTableAgrees + (context.state.materialize (.position position) resolved.output) table := + hstarts.materialize_position position resolved.output + exact ih resolved.output (materializeResolvedPosition context position resolved) + fuel hmaterializedConsistent (by + simpa [materializeResolvedPosition] using hmaterializedStarts) + (by simpa [materializeResolvedPosition] using hrest) + +set_option maxRecDepth 100000 in +theorem valid_pendingCovered_of_mem_runResolvedFromTable_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult alpha) + (coordinates : List Coordinate) + (hbound : computation.IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) 0) + (hvalid : context.Valid) (hcovered : PendingCovered coordinates context) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table computation)) : + result.context.Valid ∧ PendingCovered coordinates result.context := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runResolvedFromTable] at hresult + subst result + exact ⟨hvalid, hcovered⟩ + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases input with + | uniform n => + rw [runResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + hvalid hcovered hrest + | hashOutput => + rw [runResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output context fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 output) + hvalid hcovered hrest + | ensure coordinate => + rw [runResolvedFromTable_ensure_query_bind] at hresult + have hnextCovered : PendingCovered coordinates + { context with state := context.state.ensure coordinate } := by + intro entry hentry + exact hcovered entry hentry + exact ih () { context with state := context.state.ensure coordinate } fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) + (hvalid.ensure coordinate) hnextCovered hresult + | probe coordinate candidate => + simp [LazyRevealProbe.IsProbe] at hbound + | peek coordinate => + rw [runResolvedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel + (by simpa [LazyRevealProbe.IsProbe] using + hbound.2 (context.state.values coordinate)) + hvalid hcovered hresult + | publish coordinate => + rw [runResolvedFromTable_publish_query_bind] at hresult + have hnextCovered : PendingCovered coordinates + { context with state := context.state.publish coordinate } := by + intro entry hentry + exact hcovered entry hentry + exact ih () { context with state := context.state.publish coordinate } fuel + (by simpa [LazyRevealProbe.IsProbe] using hbound.2 ()) + (hvalid.publish coordinate) hnextCovered hresult + | reveal coordinate => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + rw [runResolvedFromTable_reveal_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + have hresolvedEq : resolveDeferredChainStart table index context = + some resolved := by + simpa [index] using hresolved.symm + have hdeferred := resolveDeferredChainStart_deferred_values_eq table index + context resolved hresolvedEq + have hnextValid : + (materializeResolvedChainStart context index resolved).Valid := by + rw [materializeResolvedChainStart, hdeferred] + exact hvalid.materialize_chainStart lay tree leafIdx chainIdx resolved.output + have hnextCovered : PendingCovered coordinates + (materializeResolvedChainStart context index resolved) := by + intro entry hentry + apply hcovered entry + have haway : entry ∈ context.state.pendingAway index.coordinate := by + simpa [materializeResolvedChainStart, + LazyRevealProbe.State.materialize] using hentry + exact (Finset.mem_filter.1 haway).1 + exact ih resolved.output (materializeResolvedChainStart context index resolved) + fuel (by simpa [LazyRevealProbe.IsProbe] using hbound.2 resolved.output) + hnextValid hnextCovered + (by simpa [materializeResolvedChainStart, index, + OtsSecretIndex.coordinate] using hrest) + | position position => + rw [runResolvedFromTable_reveal_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hresolvedValid := + hvalid.of_resolveDeferredReveal table position resolved hresolved + have hstateValues := resolveDeferredReveal_preserves_state_values table + position context resolved hresolved + have hresolvedValue := resolveDeferredReveal_resolves table position context + resolved hresolved + have htemporary : + ({ state := context.state, values := resolved.values } : + DeferredContext).Valid := by + constructor + · intro other output hvalue + apply hresolvedValid.1 other output + rw [hstateValues] + exact hvalue + · exact hvalid.2 + have hprivate : resolved.values position = some resolved.output := by + unfold DeferredContext.positionValue at hresolvedValue + rw [hstateValues] at hresolvedValue + cases hstate : context.state.values (.position position) with + | none => simpa [hstate] using hresolvedValue + | some output => + have hsame : output = resolved.output := by + simpa [hstate] using hresolvedValue + simpa [hsame] using hresolvedValid.1 position output (by + rw [hstateValues] + exact hstate) + have hnextValid : + (materializeResolvedPosition context position resolved).Valid := by + exact htemporary.materialize_position position resolved.output hprivate + have hnextCovered : PendingCovered coordinates + (materializeResolvedPosition context position resolved) := by + intro entry hentry + apply hcovered entry + have haway : entry ∈ + context.state.pendingAway (.position position) := by + simpa [materializeResolvedPosition, + LazyRevealProbe.State.materialize] using hentry + exact (Finset.mem_filter.1 haway).1 + exact ih resolved.output (materializeResolvedPosition context position resolved) + fuel (by simpa [LazyRevealProbe.IsProbe] using hbound.2 resolved.output) + hnextValid hnextCovered + (by simpa [materializeResolvedPosition] using hrest) + +def ChronologicalCacheAgrees (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (cache : QueryCache HashSpec) : Prop := + ∀ completion, DeferredCompletion table context completion → + ∀ position, IsOtsPosition position → + ResolveInputAgrees position context + (tableInput parameter completion (.position position)) cache + +theorem chronologicalCacheAgrees_empty (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) : + ChronologicalCacheAgrees parameter table + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + (∅ : QueryCache HashSpec) := by + intro completion hcompletion position hots + simp [ResolveInputAgrees, DeferredContext.positionValue, + LazyRevealProbe.State.empty, emptyDeferredStructuralValues] + +theorem ChronologicalCacheAgrees.of_resolveDeferredChainStart + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {cache : QueryCache HashSpec} + (hcache : ChronologicalCacheAgrees parameter table context cache) + (hagrees : StartTableAgrees context.state table) (index : OtsSecretIndex) + (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + ChronologicalCacheAgrees parameter table result.toDeferredContext cache := by + intro completion hcompletion position hots + have horiginal := hcompletion.of_resolveDeferredChainStart hagrees index result hresult + have hknown := hcache completion horiginal position hots + have hvalues := congrFun + (resolveDeferredChainStart_positionValue_eq table index context result hresult) position + unfold ResolveInputAgrees at hknown ⊢ + rw [hvalues] + exact hknown + +theorem ChronologicalCacheAgrees.of_resolveDeferredPositionValue + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {cache : QueryCache HashSpec} + (hagrees : ChronologicalCacheAgrees parameter table context cache) + (hvalid : context.Valid) (position : Position) (input : HashInput) + (hcanonical : ∀ completion, DeferredCompletion table context completion → + input = tableInput parameter completion (.position position)) + (result : DeferredResolution) (output : HashOutput) + (finalCache : QueryCache HashSpec) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) + (hquery : ResolveQueryRel input cache (some result) (output, finalCache)) : + ChronologicalCacheAgrees parameter table result.toDeferredContext finalCache := by + rcases hquery with ⟨houtput, rfl⟩ + subst output + intro completion hcompletion other hots + have hcompletionOriginal := hcompletion.of_resolveDeferredPositionValue + hvalid position result hresult + have hinput := hcanonical completion hcompletionOriginal + by_cases heq : other = position + · subst other + have hresolved := resolveDeferredPositionValue_resolves position context result hresult + unfold ResolveInputAgrees + rw [hresolved, ← hinput] + simp + · have hknown := hagrees completion hcompletionOriginal other hots + have hpreserved : result.toDeferredContext.positionValue other = + context.positionValue other := by + unfold DeferredContext.positionValue + rw [resolveDeferredPositionValue_preserves_state_values position context result hresult, + resolveDeferredPositionValue_preserves_other position other context result heq hresult] + have hinputNe : tableInput parameter completion (.position other) ≠ input := by + intro hequal + have hdomains := (tweakableHashInput_injective parameter + position.domain_inRange other.domain_inRange (by + simpa [tableInput] using hinput.symm.trans hequal.symm)).1 + exact heq (Position.domain_injective hdomains).symm + unfold ResolveInputAgrees at hknown ⊢ + rw [hpreserved] + cases hvalue : context.positionValue other with + | none => + rw [hvalue] at hknown + simp only at hknown ⊢ + rw [QueryCache.cacheQuery_of_ne cache result.output hinputNe] + exact hknown + | some output => + rw [hvalue] at hknown + simp only at hknown ⊢ + rw [QueryCache.cacheQuery_of_ne cache result.output hinputNe] + exact hknown + +def DeferredCompletable (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) : Prop := + ∃ completion, DeferredCompletion table context completion + +theorem not_deferredCompletable_of_mem_runResolvedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : ResolvedRunResult alpha) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (runResolvedFromTable context fuel table computation)) + (hdoomed : ¬DeferredCompletable table context) : + ¬DeferredCompletable table result.context := by + intro hfinal + exact hdoomed (deferredCompletable_of_mem_runResolvedFromTable computation context fuel table + result hconsistent hstarts hresult hfinal) + +theorem deferredCompletable_iff_of_coreEq + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (heq : left.CoreEq right) : + DeferredCompletable table left ↔ DeferredCompletable table right := by + constructor + · rintro ⟨completion, hcompletion⟩ + exact ⟨completion, hcompletion.of_coreEq heq⟩ + · rintro ⟨completion, hcompletion⟩ + exact ⟨completion, hcompletion.of_coreEq heq.symm⟩ + +theorem DeferredCompletable.materializeResolvedChainStart + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hcompletable : DeferredCompletable table context) + (hagrees : StartTableAgrees context.state table) (index : OtsSecretIndex) + (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + DeferredCompletable table (materializeResolvedChainStart context index result) := by + obtain ⟨completion, hcompletion⟩ := hcompletable + have houtput := resolveDeferredChainStart_output_of_agrees table index context result hagrees + hresult + have hdeferred := resolveDeferredChainStart_deferred_values_eq table index context result + hresult + refine ⟨completion, ?_, ?_, ?_, hcompletion.2.2.2⟩ + · intro coordinate output hvalue + change (context.state.materialize index.coordinate result.output).values coordinate = + some output at hvalue + by_cases heq : coordinate = index.coordinate + · subst coordinate + have hsame : output = result.output := by + simpa [LazyRevealProbe.State.materialize] using hvalue.symm + rw [hsame, houtput, hcompletion.2.2.2 index] + · apply hcompletion.1 coordinate output + simpa [LazyRevealProbe.State.materialize, + Function.update_of_ne heq] using hvalue + · intro position output hvalue + change result.values position = some output at hvalue + apply hcompletion.2.1 position output + simpa [hdeferred] using hvalue + · intro coordinate candidate hmember + apply hcompletion.2.2.1 coordinate candidate + change (coordinate, candidate) ∈ context.state.pendingAway index.coordinate at hmember + have haway : (coordinate, candidate) ∈ context.state.pendingAway index.coordinate := by + exact hmember + exact (Finset.mem_filter.1 haway).1 + +theorem DeferredCompletable.not_hitAt_chainStart + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hcompletable : DeferredCompletable table context) (index : OtsSecretIndex) : + ¬context.state.hitAt index.coordinate (table index) := by + obtain ⟨completion, hcompletion⟩ := hcompletable + intro hhit + unfold LazyRevealProbe.State.hitAt LazyRevealProbe.State.pendingAt at hhit + obtain ⟨entry, hentry, heq⟩ := Finset.mem_image.1 hhit + have hparts := Finset.mem_filter.1 hentry + have havoid := hcompletion.2.2.1 entry.1 entry.2 hparts.1 + have hcoordinate : entry.1 = index.coordinate := hparts.2 + rw [hcoordinate, hcompletion.2.2.2 index, heq] at havoid + exact havoid rfl + +theorem DeferredCompletable.of_resolveDeferredChainStart + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hcompletable : DeferredCompletable table context) (index : OtsSecretIndex) + (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + DeferredCompletable table result.toDeferredContext := by + obtain ⟨completion, hcompletion⟩ := hcompletable + refine ⟨completion, ?_, ?_, ?_, hcompletion.2.2.2⟩ + · intro coordinate output hvalue + apply hcompletion.1 coordinate output + rw [← resolveDeferredChainStart_state_values_eq table index context result hresult] + exact hvalue + · intro position output hvalue + apply hcompletion.2.1 position output + rw [← resolveDeferredChainStart_deferred_values_eq table index context result hresult] + exact hvalue + · intro coordinate candidate hmember + have hpending := resolveDeferredChainStart_pending_eq table index context result hresult + have hmemberAway : (coordinate, candidate) ∈ + context.state.pendingAway index.coordinate := by + rw [← hpending] + exact hmember + have hparts : (coordinate, candidate) ∈ context.state.pending ∧ + coordinate ≠ index.coordinate := by + simpa [LazyRevealProbe.State.pendingAway] using hmemberAway + apply hcompletion.2.2.1 coordinate candidate + exact hparts.1 + +theorem DeferredCompletable.of_resolveDeferredPositionValue + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hcompletable : DeferredCompletable table context) (hvalid : context.Valid) + (position : Position) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) : + DeferredCompletable table result.toDeferredContext := by + obtain ⟨completion, hcompletion⟩ := hcompletable + let updated := Function.update completion (.position position) result.output + have hstateValues := resolveDeferredPositionValue_preserves_state_values + position context result hresult + have hpending := resolveDeferredPositionValue_pending position context result hresult + have hresultValid := hvalid.of_resolveDeferredPositionValue position result hresult + refine ⟨updated, ?_, ?_, ?_, ?_⟩ + · intro coordinate output hvalue + by_cases heq : coordinate = .position position + · subst coordinate + have hprivate := hresultValid.1 position output hvalue + have hinstalled := resolveDeferredPositionValue_installs position context result hresult + have hsame : output = result.output := by + rw [hinstalled] at hprivate + exact Option.some.inj hprivate.symm + simp [updated, hsame] + · simp [updated, Function.update_of_ne heq] + apply hcompletion.1 coordinate output + rw [← hstateValues] + exact hvalue + · intro other output hvalue + by_cases heq : other = position + · subst other + have hinstalled := resolveDeferredPositionValue_installs position context result hresult + have hsame : output = result.output := by + rw [hinstalled] at hvalue + exact Option.some.inj hvalue.symm + simp [updated, hsame] + · have horiginal := resolveDeferredPositionValue_preserves_other + position other context result heq hresult + simp [updated, show Coordinate.position other ≠ Coordinate.position position by + simpa using heq] + apply hcompletion.2.1 other output + rw [← horiginal] + exact hvalue + · intro coordinate candidate hmember + have hmemberAway : (coordinate, candidate) ∈ + context.state.pendingAway (.position position) := by + rw [← hpending] + exact hmember + have hparts : (coordinate, candidate) ∈ context.state.pending ∧ + coordinate ≠ .position position := by + simpa [LazyRevealProbe.State.pendingAway] using hmemberAway + have hne := hparts.2 + simpa [updated, Function.update_of_ne hne] using + hcompletion.2.2.1 coordinate candidate hparts.1 + · intro index + simpa [updated, show index.coordinate ≠ Coordinate.position position by + cases index + simp [OtsSecretIndex.coordinate]] using hcompletion.2.2.2 index + +theorem deferredCompletable_empty (table : OtsSecretIndex → HashOutput) : + DeferredCompletable table + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } := by + let completion : Coordinate → HashOutput + | .chainStart lay tree leafIdx chainIdx => table ⟨lay, tree, leafIdx, chainIdx⟩ + | .position _ => 0 + refine ⟨completion, ?_, ?_, ?_, ?_⟩ + · intro coordinate output hvalue + simp [LazyRevealProbe.State.empty] at hvalue + · intro position output hvalue + simp [emptyDeferredStructuralValues] at hvalue + · intro coordinate candidate hmember + simp [LazyRevealProbe.State.empty] at hmember + · intro index + cases index + rfl + +theorem DeferredCompletable.of_resolveDeferredChainPrefix + {table : OtsSecretIndex → HashOutput} {lay : Layer} {tree : TreeIndex} + {leafIdx : LeafIndex} {chainIdx : ChainIndex} : + ∀ {steps hsteps context result}, + DeferredCompletable table context → context.Valid → + some result ∈ support + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) → + DeferredCompletable table result.toDeferredContext + | 0, hsteps, context, result, hcompletable, _hvalid, hresult => by + simp only [resolveDeferredChainPrefix, support_pure, Set.mem_singleton_iff] at hresult + exact hcompletable.of_resolveDeferredChainStart + ⟨lay, tree, leafIdx, chainIdx⟩ result hresult.symm + | steps + 1, hsteps, context, result, hcompletable, hvalid, hresult => by + rw [resolveDeferredChainPrefix, mem_support_bind_iff] at hresult + obtain ⟨previousOption, hprevious, hrest⟩ := hresult + cases previousOption with + | none => simp at hrest + | some previous => + have hmiddleCompletable := DeferredCompletable.of_resolveDeferredChainPrefix + hcompletable hvalid hprevious + have hmiddleValid := hvalid.of_resolveDeferredChainPrefix table lay tree leafIdx + chainIdx steps (by omega) previous hprevious + exact hmiddleCompletable.of_resolveDeferredPositionValue hmiddleValid + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) result (by simpa using hrest) + +theorem DeferredCompletable.of_resolveDeferredChains + {table : OtsSecretIndex → HashOutput} {lay : Layer} {tree : TreeIndex} + {leafIdx : LeafIndex} : + ∀ {chains context result}, + DeferredCompletable table context → context.Valid → + some result ∈ support (resolveDeferredChains table lay tree leafIdx chains context) → + DeferredCompletable table result + | [], context, result, hcompletable, _hvalid, hresult => by + simp [resolveDeferredChains] at hresult + subst result + exact hcompletable + | chainIdx :: remaining, context, result, hcompletable, hvalid, hresult => by + rw [resolveDeferredChains, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + have hmiddleCompletable := hcompletable.of_resolveDeferredChainPrefix hvalid hresolved + have hmiddleValid := hvalid.of_resolveDeferredChainPrefix table lay tree leafIdx + chainIdx (chainLength - 1) (by omega) resolved hresolved + exact hmiddleCompletable.of_resolveDeferredChains hmiddleValid (by simpa using hrest) + +theorem DeferredCompletable.of_resolveDeferredOtsLeaf + {table : OtsSecretIndex → HashOutput} {lay : Layer} {tree : TreeIndex} + {leafIdx : LeafIndex} {context : DeferredContext} {result : DeferredResolution} + (hcompletable : DeferredCompletable table context) (hvalid : context.Valid) + (hresult : some result ∈ support + (resolveDeferredOtsLeaf table lay tree leafIdx context)) : + DeferredCompletable table result.toDeferredContext := by + rw [resolveDeferredOtsLeaf, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + have hmiddleCompletable := hcompletable.of_resolveDeferredChains hvalid hchains + have hmiddleValid := hvalid.of_resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) chains hchains + exact hmiddleCompletable.of_resolveDeferredPositionValue hmiddleValid + (.leaf lay tree leafIdx) result (by simpa using hrest) + +theorem DeferredCompletable.of_resolveDeferredTreeNode + {table : OtsSecretIndex → HashOutput} {lay : Layer} {tree : TreeIndex} : + ∀ {level nodeIdx hlevel context result}, + DeferredCompletable table context → context.Valid → + some result ∈ support + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) → + DeferredCompletable table result.toDeferredContext + | 0, nodeIdx, hlevel, context, result, hcompletable, hvalid, hresult => + hcompletable.of_resolveDeferredOtsLeaf hvalid hresult + | level + 1, nodeIdx, hlevel, context, result, hcompletable, hvalid, hresult => by + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨leftOption, hleft, hafterLeft⟩ := hresult + cases leftOption with + | none => simp at hafterLeft + | some left => + rw [mem_support_bind_iff] at hafterLeft + obtain ⟨rightOption, hright, hafterRight⟩ := hafterLeft + cases rightOption with + | none => simp at hafterRight + | some right => + have hleftCompletable := hcompletable.of_resolveDeferredTreeNode hvalid hleft + have hleftValid := hvalid.of_resolveDeferredTreeNode table lay tree level + (2 * nodeIdx) (by omega) left hleft + have hrightCompletable := hleftCompletable.of_resolveDeferredTreeNode + hleftValid hright + have hrightValid := hleftValid.of_resolveDeferredTreeNode table lay tree level + (2 * nodeIdx + 1) (by omega) right hright + exact hrightCompletable.of_resolveDeferredPositionValue hrightValid + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) result + (by simpa using hafterRight) + +theorem DeferredCompletable.of_resolveDeferredPosition + {table : OtsSecretIndex → HashOutput} {position : Position} + {context : DeferredContext} {result : DeferredResolution} + (hcompletable : DeferredCompletable table context) (hvalid : context.Valid) + (hresult : some result ∈ support (resolveDeferredPosition table position context)) : + DeferredCompletable table result.toDeferredContext := by + cases position with + | chain lay tree leafIdx chainIdx step => + exact hcompletable.of_resolveDeferredChainPrefix hvalid hresult + | leaf lay tree leafIdx => exact hcompletable.of_resolveDeferredOtsLeaf hvalid hresult + | node lay tree level nodeIdx => exact hcompletable.of_resolveDeferredTreeNode hvalid hresult + | ftsLeaf index tree leafIdx => + exact hcompletable.of_resolveDeferredPositionValue hvalid (.ftsLeaf index tree leafIdx) + result hresult + | ftsNode index tree level nodeIdx => + exact hcompletable.of_resolveDeferredPositionValue hvalid + (.ftsNode index tree level nodeIdx) result hresult + | ftsRoots index => + exact hcompletable.of_resolveDeferredPositionValue hvalid (.ftsRoots index) result hresult + +def FixedResolvedInput (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (input : HashInput) (output : HashOutput) : Prop := + ∃ position : Position, + IsOtsPosition position ∧ + context.positionValue position = some output ∧ + ∀ completion, DeferredCompletion table context completion → + input = tableInput parameter completion (.position position) + +def ResolvedCachePartition (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (ordinaryCache concreteCache : QueryCache HashSpec) : Prop := + (∀ input output, ordinaryCache input = some output → + concreteCache input = some output) ∧ + ∀ input output, concreteCache input = some output → + ordinaryCache input = some output ∨ + FixedResolvedInput parameter table context input output + +def CompletionOrdinaryInput (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (input : HashInput) : Prop := + ∀ completion, DeferredCompletion table context completion → + ∀ position, IsOtsPosition position → + input ≠ tableInput parameter completion (.position position) + +theorem completionOrdinaryInput_of_stable + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {input : HashInput} + (hstable : StableOrdinaryInput parameter input) : + CompletionOrdinaryInput parameter table context input := by + intro completion hcompletion position hots heq + have hdecoded : decodePosition? parameter input = some position := by + rw [heq] + exact (decodePosition?_eq_some_iff parameter _ position).2 + ⟨tablePayload completion position, rfl⟩ + exact hstable.2 position hdecoded hots + +theorem completionOrdinaryInput_of_pending_decodedProbe + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {input : HashInput} {candidate : Probe} + (hdecode : decodeProbe? parameter input = some candidate) + (hpending : (candidate.coordinate, candidate.candidate) ∈ context.state.pending) : + CompletionOrdinaryInput parameter table context input := by + intro completion hcompletion position hots heq + have hmatches := (decodeProbe?_eq_some_iff parameter input candidate).1 hdecode + cases position with + | chain lay tree leafIdx chainIdx step => + have hcanonical : + (chainInputProbe completion lay tree leafIdx chainIdx step).MatchesInput parameter + input := by + rw [heq] + exact chainInputProbe_matchesInput parameter completion lay tree leafIdx chainIdx step + have hcandidates := Probe.matchesInput_unique parameter input hmatches hcanonical + subst candidate + have havoids := hcompletion.2.2.1 + (chainInputSource lay tree leafIdx chainIdx step) + (truncateHash (completion (chainInputSource lay tree leafIdx chainIdx step))) (by + simpa [chainInputProbe] using hpending) + exact havoids rfl + | leaf lay tree leafIdx => + have hcanonicalDecode : decodeProbe? parameter + (tableInput parameter completion (.position (.leaf lay tree leafIdx))) = + some candidate := by + simpa [heq] using hdecode + have hcandidates := decodeProbe?_tableInput_leaf_eq parameter completion lay tree leafIdx + candidate hcanonicalDecode + subst candidate + have hzero : 0 < (Position.leaf lay tree leafIdx).children.length := by + simp [Position.children, numChains] + have hslot := slotDigest_tableInput_leaf_getElem parameter completion lay tree leafIdx 0 + hzero + rw [leaf_children_getElem_zero lay tree leafIdx hzero] at hslot + have havoids := hcompletion.2.2.1 + (.position (.chain lay tree leafIdx + ⟨0, by norm_num [numChains]⟩ Position.lastChainStep)) + (slotDigest 0 + (tableInput parameter completion (.position (.leaf lay tree leafIdx)))) (by + simpa using hpending) + exact havoids hslot.symm + | node lay tree level nodeIdx => + have hnone : decodeProbe? parameter + (tableInput parameter completion (.position (.node lay tree level nodeIdx))) = none := by + simpa [tableInput, Position.domain] using + (decodeProbe?_tweakableHashInput_of_not_chain_leaf parameter + (.node lay tree (level.val + 1) nodeIdx.val) + (tablePayload completion (.node lay tree level nodeIdx)) + (Position.domain_inRange (.node lay tree level nodeIdx)) + (by simp) (by simp)) + rw [heq] at hdecode + exact (by simp [hdecode] at hnone) + | ftsLeaf | ftsNode | ftsRoots => simp [IsOtsPosition] at hots + +theorem completionOrdinaryInput_of_pending_leaf_child + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {input : HashInput} + {lay : Layer} {tree : TreeIndex} {leafIdx : LeafIndex} + {prior remaining : List Position} {child : Position} + (hposition : decodePosition? parameter input = some (.leaf lay tree leafIdx)) + (hchildren : (Position.leaf lay tree leafIdx).children = + prior ++ child :: remaining) + (hpending : (.position child, slotDigest prior.length input) ∈ context.state.pending) : + CompletionOrdinaryInput parameter table context input := by + intro completion hcompletion other _hots heq + have hdecodeOther : decodePosition? parameter input = some other := by + rw [heq] + exact (decodePosition?_eq_some_iff parameter _ other).2 + ⟨tablePayload completion other, rfl⟩ + have hother : other = .leaf lay tree leafIdx := by + rw [hposition] at hdecodeOther + exact Option.some.inj hdecodeOther.symm + subst other + have hslotLt : prior.length < (Position.leaf lay tree leafIdx).children.length := by + simp [hchildren] + have hslot := slotDigest_tableInput_leaf_getElem parameter completion lay tree leafIdx + prior.length hslotLt + have hchild : (Position.leaf lay tree leafIdx).children[prior.length] = child := by + simp [hchildren] + rw [hchild] at hslot + have havoids := hcompletion.2.2.1 (.position child) (slotDigest prior.length input) hpending + apply havoids + rw [heq] + exact hslot.symm + +theorem completionOrdinaryInput_of_pending_node_child + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {input : HashInput} + {lay : Layer} {tree : TreeIndex} {level : Fin maxLayerHeight} + {nodeIdx : LeafIndex} {prior remaining : List Position} {child : Position} + (hposition : decodePosition? parameter input = some (.node lay tree level nodeIdx)) + (hchildren : (Position.node lay tree level nodeIdx).children = + prior ++ child :: remaining) + (hpending : (.position child, slotDigest prior.length input) ∈ context.state.pending) : + CompletionOrdinaryInput parameter table context input := by + intro completion hcompletion other _hots heq + have hdecodeOther : decodePosition? parameter input = some other := by + rw [heq] + exact (decodePosition?_eq_some_iff parameter _ other).2 + ⟨tablePayload completion other, rfl⟩ + have hother : other = .node lay tree level nodeIdx := by + rw [hposition] at hdecodeOther + exact Option.some.inj hdecodeOther.symm + subst other + have hslotLt : prior.length < (Position.node lay tree level nodeIdx).children.length := by + simp [hchildren] + have hslot := slotDigest_tableInput_node_getElem parameter completion lay tree level nodeIdx + prior.length hslotLt + have hchild : (Position.node lay tree level nodeIdx).children[prior.length] = child := by + simp [hchildren] + rw [hchild] at hslot + have havoids := hcompletion.2.2.1 (.position child) (slotDigest prior.length input) hpending + apply havoids + rw [heq] + exact hslot.symm + +theorem completionOrdinaryInput_of_decodeProbe_none_chain + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {input : HashInput} + {lay : Layer} {tree : TreeIndex} {leafIdx : LeafIndex} + {chainIdx : ChainIndex} {step : ChainStep} + (hprobe : decodeProbe? parameter input = none) + (hposition : decodePosition? parameter input = + some (.chain lay tree leafIdx chainIdx step)) : + CompletionOrdinaryInput parameter table context input := by + intro completion _hcompletion other _hots heq + have hdecodeOther : decodePosition? parameter input = some other := by + rw [heq] + exact (decodePosition?_eq_some_iff parameter _ other).2 + ⟨tablePayload completion other, rfl⟩ + have hother : other = .chain lay tree leafIdx chainIdx step := by + rw [hposition] at hdecodeOther + exact Option.some.inj hdecodeOther.symm + subst other + have hmatches := chainInputProbe_matchesInput parameter completion lay tree leafIdx chainIdx step + apply ((decodeProbe?_eq_none_iff parameter input).1 hprobe + (chainInputProbe completion lay tree leafIdx chainIdx step)) + simpa [heq] using hmatches + +set_option maxRecDepth 100000 in +theorem completionOrdinaryInput_of_decodeProbe_none_leaf + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {input : HashInput} + {lay : Layer} {tree : TreeIndex} {leafIdx : LeafIndex} + (hprobe : decodeProbe? parameter input = none) + (hposition : decodePosition? parameter input = some (.leaf lay tree leafIdx)) : + CompletionOrdinaryInput parameter table context input := by + intro completion _hcompletion other _hots heq + have hdecodeOther : decodePosition? parameter input = some other := by + rw [heq] + exact (decodePosition?_eq_some_iff parameter _ other).2 + ⟨tablePayload completion other, rfl⟩ + have hother : other = .leaf lay tree leafIdx := by + rw [hposition] at hdecodeOther + exact Option.some.inj hdecodeOther.symm + subst other + let candidate : Probe := + ⟨.position (.chain lay tree leafIdx ⟨0, by norm_num [numChains]⟩ + Position.lastChainStep), slotDigest 0 input⟩ + apply ((decodeProbe?_eq_none_iff parameter input).1 hprobe candidate) + simp only [candidate, Probe.MatchesInput] + rw [dif_neg (by simp [Position.lastChainStep, chainLength, winternitzBits])] + exact ⟨trivial, tablePayload completion (.leaf lay tree leafIdx), + (by simpa [tableInput, Position.domain] using heq), trivial⟩ + +theorem ChronologicalCacheAgrees.of_coreEq + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left right : DeferredContext} {cache : QueryCache HashSpec} + (hagrees : ChronologicalCacheAgrees parameter table left cache) + (heq : left.CoreEq right) : + ChronologicalCacheAgrees parameter table right cache := by + intro completion hcompletion position hots + have hknown := hagrees completion (hcompletion.of_coreEq heq.symm) position hots + unfold ResolveInputAgrees at hknown ⊢ + rw [← heq.positionValue_eq] + exact hknown + +theorem FixedResolvedInput.of_coreEq + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left right : DeferredContext} {input : HashInput} {output : HashOutput} + (hfixed : FixedResolvedInput parameter table left input output) + (heq : left.CoreEq right) : + FixedResolvedInput parameter table right input output := by + rcases hfixed with ⟨position, hots, hvalue, hinput⟩ + refine ⟨position, hots, ?_, ?_⟩ + · rw [← heq.positionValue_eq] + exact hvalue + · intro completion hcompletion + exact hinput completion (hcompletion.of_coreEq heq.symm) + +theorem ResolvedCachePartition.of_coreEq + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left right : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hpartition : ResolvedCachePartition parameter table left ordinaryCache concreteCache) + (heq : left.CoreEq right) : + ResolvedCachePartition parameter table right ordinaryCache concreteCache := by + refine ⟨hpartition.1, ?_⟩ + intro input output hcached + rcases hpartition.2 input output hcached with hordinary | hfixed + · exact Or.inl hordinary + · exact Or.inr (hfixed.of_coreEq heq) + +theorem resolvedCachePartition_empty (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) : + ResolvedCachePartition parameter table + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + (∅ : QueryCache HashSpec) ∅ := by + constructor + · intro input output hcached + simp at hcached + · intro input output hcached + simp at hcached + +theorem ResolvedCachePartition.eq_of_stable + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hpartition : ResolvedCachePartition parameter table context ordinaryCache concreteCache) + (hcompletable : DeferredCompletable table context) + (input : HashInput) (hstable : StableOrdinaryInput parameter input) : + ordinaryCache input = concreteCache input := by + cases hordinary : ordinaryCache input with + | some output => + exact (hpartition.1 input output hordinary).symm + | none => + cases hconcrete : concreteCache input with + | none => rfl + | some output => + rcases hpartition.2 input output hconcrete with hcached | + ⟨position, hots, _hvalue, hinput⟩ + · simp [hordinary] at hcached + · obtain ⟨completion, hcompletion⟩ := hcompletable + have hdecoded : decodePosition? parameter input = some position := by + rw [hinput completion hcompletion] + exact (decodePosition?_eq_some_iff parameter _ position).2 + ⟨tablePayload completion position, rfl⟩ + exact (hstable.2 position hdecoded hots).elim + +theorem ResolvedCachePartition.eq_of_completionOrdinary + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hpartition : ResolvedCachePartition parameter table context ordinaryCache concreteCache) + (hcompletable : DeferredCompletable table context) + (input : HashInput) + (hordinary : CompletionOrdinaryInput parameter table context input) : + ordinaryCache input = concreteCache input := by + cases hordinaryCache : ordinaryCache input with + | some output => exact (hpartition.1 input output hordinaryCache).symm + | none => + cases hconcrete : concreteCache input with + | none => rfl + | some output => + rcases hpartition.2 input output hconcrete with hcached | + ⟨position, hots, _hvalue, hinput⟩ + · simp [hordinaryCache] at hcached + · obtain ⟨completion, hcompletion⟩ := hcompletable + exact (hordinary completion hcompletion position hots + (hinput completion hcompletion)).elim + +theorem FixedResolvedInput.of_resolveDeferredPositionValue + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {input : HashInput} {output : HashOutput} + (hfixed : FixedResolvedInput parameter table context input output) + (hvalid : context.Valid) (target : Position) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue target context)) : + FixedResolvedInput parameter table result.toDeferredContext input output := by + rcases hfixed with ⟨position, hots, hvalue, hinput⟩ + refine ⟨position, hots, + resolveDeferredPositionValue_preserves_positionValue target position context result output + hvalue hresult, ?_⟩ + intro completion hcompletion + exact hinput completion + (hcompletion.of_resolveDeferredPositionValue hvalid target result hresult) + +theorem FixedResolvedInput.of_resolveDeferredChainStart + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {input : HashInput} {output : HashOutput} + (hfixed : FixedResolvedInput parameter table context input output) + (hagrees : StartTableAgrees context.state table) (index : OtsSecretIndex) + (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + FixedResolvedInput parameter table result.toDeferredContext input output := by + rcases hfixed with ⟨position, hots, hvalue, hinput⟩ + refine ⟨position, hots, + resolveDeferredChainStart_preserves_positionValue table index context result position output + hvalue hresult, ?_⟩ + intro completion hcompletion + exact hinput completion + (hcompletion.of_resolveDeferredChainStart hagrees index result hresult) + +theorem FixedResolvedInput.of_materializeResolvedPosition + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {input : HashInput} {output : HashOutput} + (position : Position) (result : DeferredResolution) + (hfixed : FixedResolvedInput parameter table result.toDeferredContext input output) + (hstateValues : result.state.values = context.state.values) + (hpending : result.state.pending ⊆ + context.state.pendingAway (.position position)) + (hresolved : result.toDeferredContext.positionValue position = some result.output) : + FixedResolvedInput parameter table + (materializeResolvedPosition context position result) input output := by + rcases hfixed with ⟨fixedPosition, hots, hvalue, hinput⟩ + refine ⟨fixedPosition, hots, ?_, ?_⟩ + · rw [materializeResolvedPosition_positionValue_eq context position result hstateValues + hresolved] + exact hvalue + · intro completion hcompletion + exact hinput completion + (hcompletion.of_materializeResolvedPosition position result hstateValues hpending hresolved) + +theorem FixedResolvedInput.of_materializeResolvedChainStart + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {input : HashInput} {output : HashOutput} + (hfixed : FixedResolvedInput parameter table context input output) + (hagrees : StartTableAgrees context.state table) + (hcompletable : DeferredCompletable table context) (index : OtsSecretIndex) + (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + FixedResolvedInput parameter table + (materializeResolvedChainStart context index result) input output := by + rcases hfixed with ⟨position, hots, hvalue, hinput⟩ + refine ⟨position, hots, ?_, ?_⟩ + · rw [materializeResolvedChainStart_positionValue_eq table index context result hresult] + exact hvalue + · intro completion hcompletion + exact hinput completion + (hcompletion.of_materializeResolvedChainStart hagrees index hcompletable result hresult) + +theorem ResolvedCachePartition.of_materializeResolvedChainStart + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hpartition : ResolvedCachePartition parameter table context ordinaryCache concreteCache) + (hagrees : StartTableAgrees context.state table) + (hcompletable : DeferredCompletable table context) (index : OtsSecretIndex) + (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + ResolvedCachePartition parameter table + (materializeResolvedChainStart context index result) ordinaryCache concreteCache := by + refine ⟨hpartition.1, ?_⟩ + intro input output hcached + rcases hpartition.2 input output hcached with hordinary | hfixed + · exact Or.inl hordinary + · exact Or.inr (hfixed.of_materializeResolvedChainStart hagrees hcompletable index result + hresult) + +theorem ResolvedCachePartition.of_resolveDeferredChainStart + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hpartition : ResolvedCachePartition parameter table context ordinaryCache concreteCache) + (hagrees : StartTableAgrees context.state table) (index : OtsSecretIndex) + (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + ResolvedCachePartition parameter table result.toDeferredContext ordinaryCache concreteCache := by + refine ⟨hpartition.1, ?_⟩ + intro input output hcached + rcases hpartition.2 input output hcached with hordinary | hfixed + · exact Or.inl hordinary + · exact Or.inr (hfixed.of_resolveDeferredChainStart hagrees index result hresult) + +theorem fixedResolvedInput_of_resolveDeferredPositionValue + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} (position : Position) (input : HashInput) + (hots : IsOtsPosition position) + (hcanonical : ∀ completion, DeferredCompletion table context completion → + input = tableInput parameter completion (.position position)) + (hvalid : context.Valid) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) : + FixedResolvedInput parameter table result.toDeferredContext input result.output := by + refine ⟨position, hots, + resolveDeferredPositionValue_resolves position context result hresult, ?_⟩ + intro completion hcompletion + exact hcanonical completion + (hcompletion.of_resolveDeferredPositionValue hvalid position result hresult) + +theorem ResolvedCachePartition.of_resolveDeferredPositionValue + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hpartition : ResolvedCachePartition parameter table context ordinaryCache concreteCache) + (hcache : ChronologicalCacheAgrees parameter table context concreteCache) + (hvalid : context.Valid) (hcompletable : DeferredCompletable table context) + (position : Position) (input : HashInput) + (hots : IsOtsPosition position) + (hcanonical : ∀ completion, DeferredCompletion table context completion → + input = tableInput parameter completion (.position position)) + (result : DeferredResolution) (output : HashOutput) + (finalCache : QueryCache HashSpec) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) + (hquery : ResolveQueryRel input concreteCache (some result) (output, finalCache)) : + ResolvedCachePartition parameter table result.toDeferredContext ordinaryCache finalCache := by + rcases hquery with ⟨houtput, rfl⟩ + subst output + have hnewFixed := fixedResolvedInput_of_resolveDeferredPositionValue position input hots + hcanonical hvalid result hresult + constructor + · intro other cached hordinary + have hc_cached := hpartition.1 other cached hordinary + by_cases heq : other = input + · subst other + obtain ⟨completion, hcompletion⟩ := hcompletable + have hagrees := hcache completion hcompletion position hots + rw [← hcanonical completion hcompletion] at hagrees + unfold ResolveInputAgrees at hagrees + cases hvalue : context.positionValue position with + | none => + rw [hvalue] at hagrees + rw [hc_cached] at hagrees + simp at hagrees + | some known => + rw [hvalue] at hagrees + have hknownCached : known = cached := Option.some.inj (hagrees.symm.trans hc_cached) + have hpreserved := resolveDeferredPositionValue_preserves_positionValue position + position context result known hvalue hresult + have hresolved := resolveDeferredPositionValue_resolves position context result hresult + have hresultOutput : result.output = known := + Option.some.inj (hresolved.symm.trans hpreserved) + simpa [QueryCache.cacheQuery_self, hresultOutput, hknownCached] + · simpa [QueryCache.cacheQuery_of_ne concreteCache result.output heq] using hc_cached + · intro other cached hfinal + by_cases heq : other = input + · subst other + have hcached : cached = result.output := by + simpa [QueryCache.cacheQuery_self] using hfinal.symm + subst cached + exact Or.inr hnewFixed + · have hold : concreteCache other = some cached := by + simpa [QueryCache.cacheQuery_of_ne concreteCache result.output heq] using hfinal + rcases hpartition.2 other cached hold with hordinary | hfixed + · exact Or.inl hordinary + · exact Or.inr (hfixed.of_resolveDeferredPositionValue hvalid position result hresult) + +def ResolvedContextInvariant (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (ordinaryCache concreteCache : QueryCache HashSpec) : Prop := + ChronologicalCacheAgrees parameter table context concreteCache ∧ + context.Valid ∧ + StartTableAgrees context.state table ∧ + DeferredCompletable table context ∧ + ResolvedCachePartition parameter table context ordinaryCache concreteCache + +theorem ResolvedContextInvariant.of_coreEq + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left right : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hinvariant : ResolvedContextInvariant parameter table left ordinaryCache concreteCache) + (heq : left.CoreEq right) : + ResolvedContextInvariant parameter table right ordinaryCache concreteCache := by + rcases hinvariant with ⟨hcache, hvalid, hstarts, hcompletable, hpartition⟩ + exact ⟨hcache.of_coreEq heq, hvalid.of_coreEq heq, hstarts.of_coreEq heq, + (deferredCompletable_iff_of_coreEq heq).mp hcompletable, + hpartition.of_coreEq heq⟩ + +theorem ResolvedContextInvariant.addPending_of_completable + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hinvariant : ResolvedContextInvariant parameter table context ordinaryCache concreteCache) + (coordinate : Coordinate) (candidate : Digest) + (hcompletable : DeferredCompletable table + { context with state := context.state.addPending coordinate candidate }) : + ResolvedContextInvariant parameter table + { context with state := context.state.addPending coordinate candidate } + ordinaryCache concreteCache := by + rcases hinvariant with ⟨hcache, hvalid, hstarts, _, hpartition⟩ + obtain ⟨completion, hcompletion⟩ := hcompletable + refine ⟨?_, ?_, hstarts.addPending coordinate candidate, ⟨completion, hcompletion⟩, ?_⟩ + · intro otherCompletion hotherCompletion position hots + have horiginal := hotherCompletion.of_addPending coordinate candidate + have hknown := hcache otherCompletion horiginal position hots + unfold ResolveInputAgrees at hknown ⊢ + simpa [DeferredContext.positionValue, LazyRevealProbe.State.addPending] using + hknown + · refine ⟨hvalid.valuesConsistent.addPending coordinate candidate, ?_⟩ + intro other output hvalue + have hvalueOriginal : context.state.values other = some output := by + simpa [LazyRevealProbe.State.addPending] using hvalue + have hcompletionValue : completion other = output := + hcompletion.1 other output hvalueOriginal + intro hhit + unfold LazyRevealProbe.State.hitAt LazyRevealProbe.State.pendingAt at hhit + rw [Finset.mem_image] at hhit + obtain ⟨⟨hitCoordinate, hitCandidate⟩, hentry, hcandidate⟩ := hhit + simp only [Finset.mem_filter, LazyRevealProbe.State.addPending, + Finset.mem_insert] at hentry + rcases hentry with ⟨hnew | hold, hcoordinate⟩ + · cases hnew + have havoids := hcompletion.2.2.1 coordinate candidate (by + simp [LazyRevealProbe.State.addPending]) + apply havoids + rw [hcoordinate, hcompletionValue] + exact hcandidate.symm + · apply hvalid.2 other output hvalueOriginal + unfold LazyRevealProbe.State.hitAt LazyRevealProbe.State.pendingAt + rw [Finset.mem_image] + exact ⟨(hitCoordinate, hitCandidate), by + simp only [Finset.mem_filter] + exact ⟨hold, hcoordinate⟩, hcandidate⟩ + · refine ⟨hpartition.1, ?_⟩ + intro input output hcached + rcases hpartition.2 input output hcached with hordinary | hfixed + · exact Or.inl hordinary + · rcases hfixed with ⟨position, hots, hvalue, hinput⟩ + exact Or.inr ⟨position, hots, by + simpa [DeferredContext.positionValue, LazyRevealProbe.State.addPending] using hvalue, + fun otherCompletion hotherCompletion => + hinput otherCompletion + (hotherCompletion.of_addPending coordinate candidate)⟩ + +theorem ResolvedAdministrative.run_preserves_invariant + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {value : alpha} (hadministrative : ResolvedAdministrative computation value) + (context : DeferredContext) (cache : SplitHashCache) (fuel : Nat) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) : + ∃ finalContext, + runResolvedFromTable context fuel table (computation.run cache) = + pure (some ⟨finalContext, fuel, (value, cache), table⟩) ∧ + ResolvedContextInvariant parameter table finalContext + (ordinaryQueryCache cache) concreteCache := by + obtain ⟨finalContext, hrun, hpending, hvalues, hprivate⟩ := + hadministrative.run context cache fuel table + have hcore : context.CoreEq finalContext := + ⟨hpending.symm, hvalues.symm, hprivate.symm⟩ + exact ⟨finalContext, hrun, hinvariant.of_coreEq hcore⟩ + +theorem ResolvedContextInvariant.materialize_resolvedChainStart + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hinvariant : ResolvedContextInvariant parameter table context ordinaryCache concreteCache) + (index : OtsSecretIndex) (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + ResolvedContextInvariant parameter table + (materializeResolvedChainStart context index result) ordinaryCache concreteCache := by + rcases hinvariant with ⟨hcache, hvalid, hstarts, hcompletable, hpartition⟩ + have houtput := resolveDeferredChainStart_output_of_agrees table index context result hstarts + hresult + refine ⟨?_, ?_, ?_, hcompletable.materializeResolvedChainStart hstarts index result hresult, + hpartition.of_materializeResolvedChainStart hstarts hcompletable index result hresult⟩ + · intro completion hcompletion position hots + have horiginal := hcompletion.of_materializeResolvedChainStart hstarts index hcompletable + result hresult + have hcurrent := hcache completion horiginal position hots + unfold ResolveInputAgrees at hcurrent ⊢ + rw [materializeResolvedChainStart_positionValue_eq table index context result hresult] + exact hcurrent + · rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + have hdeferred := resolveDeferredChainStart_deferred_values_eq table + ⟨lay, tree, leafIdx, chainIdx⟩ context result hresult + unfold materializeResolvedChainStart + rw [hdeferred] + exact hvalid.materialize_chainStart lay tree leafIdx chainIdx result.output + · unfold materializeResolvedChainStart + rw [houtput] + exact hstarts.materialize_start index + +theorem ResolvedContextInvariant.materialize_chainStart + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hinvariant : ResolvedContextInvariant parameter table context ordinaryCache concreteCache) + (index : OtsSecretIndex) : + ResolvedContextInvariant parameter table + { state := context.state.materialize index.coordinate (table index) + values := context.values } + ordinaryCache concreteCache := by + have hclean := hinvariant.2.2.2.1.not_hitAt_chainStart index + cases hvalue : context.state.values index.coordinate with + | some output => + have houtput := hinvariant.2.2.1 index output hvalue + let result : DeferredResolution := + ⟨{ state := context.state.clearPending index.coordinate, values := context.values }, + table index⟩ + have hresult : resolveDeferredChainStart table index context = some result := by + simp [resolveDeferredChainStart, hvalue, houtput, hclean, result] + have hresolved := hinvariant.materialize_resolvedChainStart index result hresult + simpa [materializeResolvedChainStart, result] using hresolved + | none => + let result : DeferredResolution := + ⟨{ state := context.state.clearPending index.coordinate, values := context.values }, + table index⟩ + have hresult : resolveDeferredChainStart table index context = some result := by + simp [resolveDeferredChainStart, hvalue, hclean, result] + have hresolved := hinvariant.materialize_resolvedChainStart index result hresult + simpa [materializeResolvedChainStart, result] using hresolved + +theorem ChronologicalCacheAgrees.of_materializeResolvedPosition + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {cache : QueryCache HashSpec} + (position : Position) (result : DeferredResolution) + (hagrees : ChronologicalCacheAgrees parameter table result.toDeferredContext cache) + (hstateValues : result.state.values = context.state.values) + (hpending : result.state.pending ⊆ + context.state.pendingAway (.position position)) + (hresolved : result.toDeferredContext.positionValue position = some result.output) : + ChronologicalCacheAgrees parameter table + (materializeResolvedPosition context position result) cache := by + intro completion hcompletion other hots + have hcompletionResult := hcompletion.of_materializeResolvedPosition position result + hstateValues hpending hresolved + have hcurrent := hagrees completion hcompletionResult other hots + unfold ResolveInputAgrees at hcurrent ⊢ + rw [materializeResolvedPosition_positionValue_eq context position result hstateValues + hresolved] + exact hcurrent + +theorem ResolvedCachePartition.of_materializeResolvedPosition + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (position : Position) (result : DeferredResolution) + (hpartition : ResolvedCachePartition parameter table result.toDeferredContext + ordinaryCache concreteCache) + (hstateValues : result.state.values = context.state.values) + (hpending : result.state.pending ⊆ + context.state.pendingAway (.position position)) + (hresolved : result.toDeferredContext.positionValue position = some result.output) : + ResolvedCachePartition parameter table + (materializeResolvedPosition context position result) ordinaryCache concreteCache := by + refine ⟨hpartition.1, ?_⟩ + intro input output hcached + rcases hpartition.2 input output hcached with hordinary | hfixed + · exact Or.inl hordinary + · exact Or.inr (hfixed.of_materializeResolvedPosition position result hstateValues + hpending hresolved) + +theorem DeferredContext.Valid.materializeResolvedPosition_of + {context : DeferredContext} (hvalid : context.Valid) (position : Position) + (result : DeferredResolution) (hresultValid : result.toDeferredContext.Valid) + (hstateValues : result.state.values = context.state.values) + (hresolved : result.toDeferredContext.positionValue position = some result.output) : + (materializeResolvedPosition context position result).Valid := by + have htemporary : + ({ state := context.state, values := result.values } : DeferredContext).Valid := by + constructor + · intro other output hvalue + apply hresultValid.1 other output + rw [hstateValues] + exact hvalue + · exact hvalid.2 + have hprivate : result.values position = some result.output := by + unfold DeferredContext.positionValue at hresolved + rw [hstateValues] at hresolved + cases hstate : context.state.values (.position position) with + | none => simpa [hstate] using hresolved + | some output => + have hsame : output = result.output := by simpa [hstate] using hresolved + simpa [hsame] using hresultValid.1 position output (by + rw [hstateValues] + exact hstate) + exact htemporary.materialize_position position result.output hprivate + +theorem ResolvedContextInvariant.materialize_resolvedReveal + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hinitial : ResolvedContextInvariant parameter table context ordinaryCache concreteCache) + (position : Position) (result : DeferredResolution) + (hresult : some result ∈ support (resolveDeferredReveal table position context)) + {finalCache : QueryCache HashSpec} + (hresultInvariant : ResolvedContextInvariant parameter table result.toDeferredContext + ordinaryCache finalCache) + (hcompletable : DeferredCompletable table + (materializeResolvedPosition context position result)) : + ResolvedContextInvariant parameter table + (materializeResolvedPosition context position result) ordinaryCache finalCache := by + rcases hinitial with ⟨_initialCache, hvalid, hstarts, _initialCompletable, + _initialPartition⟩ + rcases hresultInvariant with ⟨hcache, hresultValid, _resultStarts, + _resultCompletable, hpartition⟩ + have hstateValues := resolveDeferredReveal_preserves_state_values table position context result + hresult + have hpending := resolveDeferredReveal_pendingAway_subset table position context result hresult + have hresolved := resolveDeferredReveal_resolves table position context result hresult + exact ⟨ + hcache.of_materializeResolvedPosition position result hstateValues hpending hresolved, + hvalid.materializeResolvedPosition_of position result hresultValid hstateValues hresolved, + by simpa [materializeResolvedPosition] using + hstarts.materialize_position position result.output, + hcompletable, + hpartition.of_materializeResolvedPosition position result hstateValues hpending hresolved⟩ + +theorem ChronologicalCacheAgrees.of_stable_cacheQuery + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {cache : QueryCache HashSpec} + (hagrees : ChronologicalCacheAgrees parameter table context cache) + (input : HashInput) (output : HashOutput) + (hstable : StableOrdinaryInput parameter input) : + ChronologicalCacheAgrees parameter table context (cache.cacheQuery input output) := by + intro completion hcompletion position hots + have hcurrent := hagrees completion hcompletion position hots + have hdecoded : decodePosition? parameter + (tableInput parameter completion (.position position)) = some position := + (decodePosition?_eq_some_iff parameter _ position).2 + ⟨tablePayload completion position, rfl⟩ + have hne : tableInput parameter completion (.position position) ≠ input := by + intro heq + rw [heq] at hdecoded + exact hstable.2 position hdecoded hots + unfold ResolveInputAgrees at hcurrent ⊢ + cases hvalue : context.positionValue position <;> rw [hvalue] at hcurrent + · change cache.cacheQuery input output + (tableInput parameter completion (.position position)) = none + rw [QueryCache.cacheQuery_of_ne cache output hne] + simpa only using hcurrent + · change cache.cacheQuery input output + (tableInput parameter completion (.position position)) = some _ + rw [QueryCache.cacheQuery_of_ne cache output hne] + simpa only using hcurrent + +theorem ChronologicalCacheAgrees.of_completionOrdinary_cacheQuery + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {cache : QueryCache HashSpec} + (hagrees : ChronologicalCacheAgrees parameter table context cache) + (input : HashInput) (output : HashOutput) + (hordinary : CompletionOrdinaryInput parameter table context input) : + ChronologicalCacheAgrees parameter table context (cache.cacheQuery input output) := by + intro completion hcompletion position hots + have hcurrent := hagrees completion hcompletion position hots + have hne := (hordinary completion hcompletion position hots).symm + unfold ResolveInputAgrees at hcurrent ⊢ + cases hvalue : context.positionValue position <;> rw [hvalue] at hcurrent + · change cache.cacheQuery input output + (tableInput parameter completion (.position position)) = none + rw [QueryCache.cacheQuery_of_ne cache output hne] + simpa only using hcurrent + · change cache.cacheQuery input output + (tableInput parameter completion (.position position)) = some _ + rw [QueryCache.cacheQuery_of_ne cache output hne] + simpa only using hcurrent + +theorem ResolvedCachePartition.cacheQuery + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hpartition : ResolvedCachePartition parameter table context ordinaryCache concreteCache) + (input : HashInput) (output : HashOutput) : + ResolvedCachePartition parameter table context + (ordinaryCache.cacheQuery input output) (concreteCache.cacheQuery input output) := by + constructor + · intro other cached hordinary + by_cases heq : other = input + · subst other + have hcached : cached = output := by + simpa [QueryCache.cacheQuery_self] using hordinary.symm + subst cached + simp [QueryCache.cacheQuery_self] + · have hold : ordinaryCache other = some cached := by + simpa [QueryCache.cacheQuery_of_ne ordinaryCache output heq] using hordinary + have hconcrete := hpartition.1 other cached hold + simpa [QueryCache.cacheQuery_of_ne concreteCache output heq] using hconcrete + · intro other cached hconcrete + by_cases heq : other = input + · subst other + have hcached : cached = output := by + simpa [QueryCache.cacheQuery_self] using hconcrete.symm + subst cached + exact Or.inl (by simp [QueryCache.cacheQuery_self]) + · have hold : concreteCache other = some cached := by + simpa [QueryCache.cacheQuery_of_ne concreteCache output heq] using hconcrete + rcases hpartition.2 other cached hold with hordinary | hfixed + · exact Or.inl (by + simpa [QueryCache.cacheQuery_of_ne ordinaryCache output heq] using hordinary) + · exact Or.inr hfixed + +theorem ResolvedCachePartition.cacheLeft_of_concrete + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hpartition : ResolvedCachePartition parameter table context ordinaryCache concreteCache) + (input : HashInput) (output : HashOutput) + (hconcrete : concreteCache input = some output) : + ResolvedCachePartition parameter table context + (ordinaryCache.cacheQuery input output) concreteCache := by + constructor + · intro other cached hordinary + by_cases heq : other = input + · subst other + have hcached : cached = output := by + simpa [QueryCache.cacheQuery_self] using hordinary.symm + simpa [hcached] using hconcrete + · have hold : ordinaryCache other = some cached := by + simpa [QueryCache.cacheQuery_of_ne ordinaryCache output heq] using hordinary + exact hpartition.1 other cached hold + · intro other cached hcached + rcases hpartition.2 other cached hcached with hordinary | hfixed + · by_cases heq : other = input + · subst other + have hvalue : cached = output := by + rw [hconcrete] at hcached + exact Option.some.inj hcached.symm + exact Or.inl (by simp [hvalue, QueryCache.cacheQuery_self]) + · exact Or.inl (by + simpa [QueryCache.cacheQuery_of_ne ordinaryCache output heq] using hordinary) + · exact Or.inr hfixed + +theorem ResolvedContextInvariant.cacheLeft_of_concrete + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hinvariant : ResolvedContextInvariant parameter table context ordinaryCache concreteCache) + (input : HashInput) (output : HashOutput) + (hconcrete : concreteCache input = some output) : + ResolvedContextInvariant parameter table context + (ordinaryCache.cacheQuery input output) concreteCache := by + exact ⟨hinvariant.1, hinvariant.2.1, hinvariant.2.2.1, hinvariant.2.2.2.1, + hinvariant.2.2.2.2.cacheLeft_of_concrete input output hconcrete⟩ + +theorem ResolvedContextInvariant.concreteCache_eq_of_positionValue + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hinvariant : ResolvedContextInvariant parameter table context ordinaryCache concreteCache) + (position : Position) (hots : IsOtsPosition position) + (output : HashOutput) (hvalue : context.positionValue position = some output) + (input : HashInput) + (hcanonical : ∀ completion, DeferredCompletion table context completion → + input = tableInput parameter completion (.position position)) : + concreteCache input = some output := by + obtain ⟨completion, hcompletion⟩ := hinvariant.2.2.2.1 + have hknown := hinvariant.1 completion hcompletion position hots + unfold ResolveInputAgrees at hknown + rw [hvalue] at hknown + rw [hcanonical completion hcompletion] + exact hknown + +noncomputable def publishOrdinaryInput + (coordinate : Coordinate) (input : HashInput) (output : HashOutput) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput := do + publishCoordinate coordinate + modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output) + pure output + +theorem ResolvedContextInvariant.of_stable_cacheQuery + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hinvariant : ResolvedContextInvariant parameter table context ordinaryCache concreteCache) + (input : HashInput) (output : HashOutput) + (hstable : StableOrdinaryInput parameter input) : + ResolvedContextInvariant parameter table context + (ordinaryCache.cacheQuery input output) (concreteCache.cacheQuery input output) := by + rcases hinvariant with ⟨hcache, hvalid, hstarts, hcompletable, hpartition⟩ + exact ⟨hcache.of_stable_cacheQuery input output hstable, hvalid, hstarts, hcompletable, + hpartition.cacheQuery input output⟩ + +theorem ResolvedContextInvariant.of_completionOrdinary_cacheQuery + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache concreteCache : QueryCache HashSpec} + (hinvariant : ResolvedContextInvariant parameter table context ordinaryCache concreteCache) + (input : HashInput) (output : HashOutput) + (hordinary : CompletionOrdinaryInput parameter table context input) : + ResolvedContextInvariant parameter table context + (ordinaryCache.cacheQuery input output) (concreteCache.cacheQuery input output) := by + exact ⟨hinvariant.1.of_completionOrdinary_cacheQuery input output hordinary, + hinvariant.2.1, hinvariant.2.2.1, hinvariant.2.2.2.1, + hinvariant.2.2.2.2.cacheQuery input output⟩ + +def ResolvePositionRel (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ordinaryCache : QueryCache HashSpec) + (position : Position) : + Option DeferredResolution → Digest × QueryCache HashSpec → Prop + | none, _ => True + | some resolved, (value, cache) => + value = truncateHash resolved.output ∧ + ResolvedContextInvariant parameter table resolved.toDeferredContext ordinaryCache cache ∧ + resolved.toDeferredContext.positionValue position = some resolved.output + +theorem relTriple_resolveDeferredPositionValue_chronological + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (position : Position) (context : DeferredContext) + (ordinaryCache cache : QueryCache HashSpec) + (input : HashInput) + (hinvariant : ResolvedContextInvariant parameter table context ordinaryCache cache) + (hots : IsOtsPosition position) + (hcanonical : ∀ completion, DeferredCompletion table context completion → + input = tableInput parameter completion (.position position)) : + RelTriple + (resolveDeferredPositionValue position context) + ((randomOracle input).run cache >>= fun result => + pure (truncateHash result.1, result.2)) + (ResolvePositionRel parameter table ordinaryCache position) := by + rcases hinvariant with ⟨hcache, hvalid, hstarts, hcompletable, hpartition⟩ + obtain ⟨completion, hcompletion⟩ := hcompletable + have hcompletableOriginal : DeferredCompletable table context := ⟨completion, hcompletion⟩ + have hagrees := hcache completion hcompletion position hots + rw [← hcanonical completion hcompletion] at hagrees + have hquery := relTriple_resolveDeferredPositionValue_of_inputAgrees + position context input cache hagrees + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hquery + (fun resolved => resolved ∈ support (resolveDeferredPositionValue position context)) + (fun resolved hresolved => hresolved) + have hbound : RelTriple + (resolveDeferredPositionValue position context >>= fun resolved => pure resolved) + ((randomOracle input).run cache >>= fun result => + pure (truncateHash result.1, result.2)) + (ResolvePositionRel parameter table ordinaryCache position) := by + apply relTriple_bind hsupported + intro resolved queryResult hrelation + rcases hrelation with ⟨hqueryRel, hresultSupport⟩ + apply relTriple_pure_pure + cases resolved with + | none => trivial + | some resolved => + rcases queryResult with ⟨output, finalCache⟩ + refine ⟨congrArg truncateHash hqueryRel.1 |>.symm, ⟨ + hcache.of_resolveDeferredPositionValue hvalid position input hcanonical + resolved output finalCache hresultSupport hqueryRel, + hvalid.of_resolveDeferredPositionValue position resolved hresultSupport, + ?_, + hcompletableOriginal.of_resolveDeferredPositionValue hvalid position resolved + hresultSupport, + hpartition.of_resolveDeferredPositionValue hcache hvalid hcompletableOriginal + position input hots hcanonical resolved output finalCache hresultSupport hqueryRel⟩, + resolveDeferredPositionValue_resolves position context resolved hresultSupport⟩ + intro index cached hvalue + apply hstarts index cached + rw [← resolveDeferredPositionValue_preserves_state_values position context resolved + hresultSupport] + exact hvalue + simpa using hbound + +def ResolvedChainInvariant (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (ordinaryCache : QueryCache HashSpec) (steps : Nat) + (resolved : DeferredResolution) (cache : QueryCache HashSpec) : Prop := + ResolvedContextInvariant parameter table resolved.toDeferredContext ordinaryCache cache ∧ + ((steps = 0 ∧ resolved.output = table ⟨lay, tree, leafIdx, chainIdx⟩) ∨ + ∃ previous : ChainStep, steps = previous.val + 1 ∧ + resolved.toDeferredContext.positionValue + (.chain lay tree leafIdx chainIdx previous) = some resolved.output) + +theorem chainInput_eq_tableInput_of_completion + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (steps : Nat) (hsteps : steps < chainLength - 1) (output : HashOutput) + (context : DeferredContext) (completion : Coordinate → HashOutput) + (hcompletion : DeferredCompletion table context completion) + (htip : (steps = 0 ∧ output = table ⟨lay, tree, leafIdx, chainIdx⟩) ∨ + ∃ previous : ChainStep, steps = previous.val + 1 ∧ + context.positionValue (.chain lay tree leafIdx chainIdx previous) = some output) : + tweakableHashInput parameter (.chain lay tree leafIdx chainIdx ⟨steps, hsteps⟩) + (digestBytes (truncateHash output)) = + tableInput parameter completion + (.position (.chain lay tree leafIdx chainIdx ⟨steps, hsteps⟩)) := by + rcases htip with ⟨hzero, houtput⟩ | ⟨source, hsource, hvalue⟩ + · subst steps + rw [houtput] + have hstart := hcompletion.2.2.2 ⟨lay, tree, leafIdx, chainIdx⟩ + change completion (.chainStart lay tree leafIdx chainIdx) = + table ⟨lay, tree, leafIdx, chainIdx⟩ at hstart + simpa [tableInput, tablePayload, Position.domain] using + congrArg (fun value => tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx ⟨0, hsteps⟩) + (digestBytes (truncateHash value))) hstart.symm + · have hpositive : 0 < steps := by omega + have hnonzero : steps ≠ 0 := Nat.ne_of_gt hpositive + have hsourceValue := hcompletion.eq_positionValue + (.chain lay tree leafIdx chainIdx source) output hvalue + have hsourceEq : (⟨steps - 1, by omega⟩ : ChainStep) = source := by + apply Fin.ext + change steps - 1 = source.val + omega + simp [tableInput, tablePayload, Position.children, hpositive, hsourceEq, + hnonzero, tableValue, hsourceValue, Position.domain] + +set_option maxRecDepth 100000 in +theorem relTriple_resolveDeferredChainPrefix_chronological + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (context : DeferredContext) (ordinaryCache cache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context ordinaryCache cache) : + ∀ steps hsteps, + RelTriple + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (chainWalk parameter lay tree leafIdx chainIdx 0 steps + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)))).run cache) + (ResolveChainRel + (ResolvedChainInvariant parameter table lay tree leafIdx chainIdx ordinaryCache + steps)) := by + rcases hinvariant with ⟨hcache, hvalid, hstarts, hcompletable, hpartition⟩ + apply relTriple_resolveDeferredChainPrefix parameter table lay tree leafIdx chainIdx + context cache (ResolvedChainInvariant parameter table lay tree leafIdx chainIdx ordinaryCache) + hstarts + · intro result hresult + refine ⟨⟨hcache.of_resolveDeferredChainStart hstarts + ⟨lay, tree, leafIdx, chainIdx⟩ result hresult, + hvalid.of_resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ result hresult, + ?_, hcompletable.of_resolveDeferredChainStart + ⟨lay, tree, leafIdx, chainIdx⟩ result hresult, + hpartition.of_resolveDeferredChainStart hstarts ⟨lay, tree, leafIdx, chainIdx⟩ + result hresult⟩, Or.inl ⟨rfl, ?_⟩⟩ + · intro index output hvalue + apply hstarts index output + rw [← resolveDeferredChainStart_state_values_eq table + ⟨lay, tree, leafIdx, chainIdx⟩ context result hresult] + exact hvalue + · exact resolveDeferredChainStart_output_of_agrees table + ⟨lay, tree, leafIdx, chainIdx⟩ context result hstarts hresult + · intro steps hsteps previous middleCache hinvariant + rcases hinvariant with + ⟨⟨hpreviousCache, hpreviousValid, hpreviousStarts, hpreviousCompletable, + _hpreviousPartition⟩, htip⟩ + obtain ⟨completion, hcompletion⟩ := hpreviousCompletable + have hcanonical := chainInput_eq_tableInput_of_completion parameter table lay tree leafIdx + chainIdx steps hsteps previous.output previous.toDeferredContext completion hcompletion htip + have hknown := hpreviousCache completion hcompletion + (.chain lay tree leafIdx chainIdx ⟨steps, hsteps⟩) (by simp [IsOtsPosition]) + rw [← hcanonical] at hknown + exact hknown + · intro steps hsteps previous middleCache result output finalCache hinvariant + hresultSupport hquery + rcases hinvariant with + ⟨⟨hpreviousCache, hpreviousValid, hpreviousStarts, hpreviousCompletable, + hpreviousPartition⟩, htip⟩ + let position : Position := .chain lay tree leafIdx chainIdx ⟨steps, hsteps⟩ + let input := tweakableHashInput parameter position.domain + (digestBytes (truncateHash previous.output)) + have hcanonical : ∀ completion, + DeferredCompletion table previous.toDeferredContext completion → + input = tableInput parameter completion (.position position) := by + intro completion hcompletion + simpa [input, position, Position.domain] using + chainInput_eq_tableInput_of_completion parameter table lay tree leafIdx chainIdx + steps hsteps previous.output previous.toDeferredContext completion hcompletion htip + have hquery' : ResolveQueryRel input middleCache (some result) (output, finalCache) := by + simpa [input, position, Position.domain] using hquery + refine ⟨⟨hpreviousCache.of_resolveDeferredPositionValue hpreviousValid position input + hcanonical result output finalCache hresultSupport hquery', + hpreviousValid.of_resolveDeferredPositionValue position result hresultSupport, + ?_, hpreviousCompletable.of_resolveDeferredPositionValue hpreviousValid position result + hresultSupport, + hpreviousPartition.of_resolveDeferredPositionValue hpreviousCache hpreviousValid + hpreviousCompletable position input (by simp [position, IsOtsPosition]) hcanonical + result output finalCache hresultSupport hquery'⟩, Or.inr ⟨⟨steps, hsteps⟩, rfl, ?_⟩⟩ + · intro index cached hvalue + apply hpreviousStarts index cached + rw [← resolveDeferredPositionValue_preserves_state_values position + previous.toDeferredContext result hresultSupport] + exact hvalue + · exact resolveDeferredPositionValue_resolves position previous.toDeferredContext result + hresultSupport + +noncomputable def resolveDeferredSelectedChainFamily + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ {n : Nat}, (Fin n → ChainIndex) → + (Fin n → Digit) → DeferredContext → + ProbComp (Option (DeferredContext × (Fin n → Digest))) + | 0, _, _, context => pure (some (context, fun index => Fin.elim0 index)) + | n + 1, family, digits, context => do + let head ← resolveDeferredChainPrefix table lay tree leafIdx (family 0) + (digits 0).val (by have := (digits 0).isLt; omega) context + match head with + | none => pure none + | some head => do + let tail ← resolveDeferredSelectedChainFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) + (fun index : Fin n => digits index.succ) head.toDeferredContext + match tail with + | none => pure none + | some (finalContext, tailValues) => + pure (some (finalContext, + Fin.cases (truncateHash head.output) tailValues)) + +theorem privateStateAgrees_resolveDeferredSelectedChainFamily + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ {n : Nat} (family : Fin n → ChainIndex) + (digits : Fin n → Digit) (context finalContext : DeferredContext) + (values : Fin n → Digest), + some (finalContext, values) ∈ support + (resolveDeferredSelectedChainFamily table lay tree leafIdx family digits context) → + PrivateStateAgrees finalContext context + | 0, family, digits, context, finalContext, values, hresult => by + simp [resolveDeferredSelectedChainFamily] at hresult + rw [hresult.1] + exact ⟨rfl, rfl, rfl⟩ + | n + 1, family, digits, context, finalContext, values, hresult => by + rw [resolveDeferredSelectedChainFamily, mem_support_bind_iff] at hresult + obtain ⟨headOption, hhead, hrest⟩ := hresult + cases headOption with + | none => simp at hrest + | some head => + rw [mem_support_bind_iff] at hrest + obtain ⟨tailOption, htail, hreturn⟩ := hrest + cases tailOption with + | none => simp at hreturn + | some tail => + rcases tail with ⟨tailContext, tailValues⟩ + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hcontext : finalContext = tailContext := + congrArg Prod.fst (Option.some.inj hreturn) + rw [hcontext] + have hheadState := privateStateAgrees_resolveDeferredChainPrefix table lay tree + leafIdx (family 0) (digits 0).val (by have := (digits 0).isLt; omega) + context head hhead + have htailState := privateStateAgrees_resolveDeferredSelectedChainFamily table lay + tree leafIdx (fun index : Fin n => family index.succ) + (fun index : Fin n => digits index.succ) head.toDeferredContext tailContext + tailValues htail + exact ⟨htailState.1.trans hheadState.1, + htailState.2.1.trans hheadState.2.1, + htailState.2.2.trans hheadState.2.2⟩ + +theorem DeferredContext.Valid.of_resolveDeferredSelectedChainFamily + {context : DeferredContext} (hvalid : context.Valid) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ {n : Nat} (family : Fin n → ChainIndex) + (digits : Fin n → Digit) (finalContext : DeferredContext) + (values : Fin n → Digest), + some (finalContext, values) ∈ support + (resolveDeferredSelectedChainFamily table lay tree leafIdx family digits context) → + finalContext.Valid + | 0, family, digits, finalContext, values, hresult => by + simp [resolveDeferredSelectedChainFamily] at hresult + rw [hresult.1] + exact hvalid + | n + 1, family, digits, finalContext, values, hresult => by + rw [resolveDeferredSelectedChainFamily, mem_support_bind_iff] at hresult + obtain ⟨headOption, hhead, hrest⟩ := hresult + cases headOption with + | none => simp at hrest + | some head => + rw [mem_support_bind_iff] at hrest + obtain ⟨tailOption, htail, hreturn⟩ := hrest + cases tailOption with + | none => simp at hreturn + | some tail => + rcases tail with ⟨tailContext, tailValues⟩ + have hreturn' : finalContext = tailContext ∧ + values = Fin.cases (truncateHash head.output) tailValues := by + simpa using hreturn + have hcontext : finalContext = tailContext := hreturn'.1 + rw [hcontext] + have hheadValid := hvalid.of_resolveDeferredChainPrefix table lay tree leafIdx + (family 0) (digits 0).val (by have := (digits 0).isLt; omega) head hhead + exact hheadValid.of_resolveDeferredSelectedChainFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) + (fun index : Fin n => digits index.succ) tailContext tailValues htail + +theorem PendingCovered.of_resolveDeferredSelectedChainFamily + {coordinates : List Coordinate} {context : DeferredContext} + (hcovered : PendingCovered coordinates context) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ {n : Nat} (family : Fin n → ChainIndex) + (digits : Fin n → Digit) (finalContext : DeferredContext) + (values : Fin n → Digest), + some (finalContext, values) ∈ support + (resolveDeferredSelectedChainFamily table lay tree leafIdx family digits context) → + PendingCovered coordinates finalContext + | 0, family, digits, finalContext, values, hresult => by + simp [resolveDeferredSelectedChainFamily] at hresult + rw [hresult.1] + exact hcovered + | n + 1, family, digits, finalContext, values, hresult => by + rw [resolveDeferredSelectedChainFamily, mem_support_bind_iff] at hresult + obtain ⟨headOption, hhead, hrest⟩ := hresult + cases headOption with + | none => simp at hrest + | some head => + rw [mem_support_bind_iff] at hrest + obtain ⟨tailOption, htail, hreturn⟩ := hrest + cases tailOption with + | none => simp at hreturn + | some tail => + rcases tail with ⟨tailContext, tailValues⟩ + have hreturn' : finalContext = tailContext ∧ + values = Fin.cases (truncateHash head.output) tailValues := by + simpa using hreturn + have hcontext : finalContext = tailContext := hreturn'.1 + rw [hcontext] + have hheadCovered := hcovered.of_resolveDeferredChainPrefix table lay tree leafIdx + (family 0) (digits 0).val (by have := (digits 0).isLt; omega) head hhead + exact hheadCovered.of_resolveDeferredSelectedChainFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) + (fun index : Fin n => digits index.succ) tailContext tailValues htail + +set_option maxRecDepth 100000 in +theorem evalDist_map_resolveDeferredSelectedChainFamily_then_finalize + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (coordinates : List Coordinate) : + ∀ {n : Nat} (family : Fin n → ChainIndex) (digits : Fin n → Digit) + (context : DeferredContext), + context.Valid → PendingCovered coordinates context → + evalDist (do + let resolved ← resolveDeferredSelectedChainFamily table lay tree leafIdx + family digits context + match resolved with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some (finalContext, _) => projectDeferredState <$> + finalizeResolvedCoordinates coordinates finalContext table) = + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) + | 0, family, digits, context, hvalid, hcovered => by + simp [resolveDeferredSelectedChainFamily] + | n + 1, family, digits, context, hvalid, hcovered => by + rw [resolveDeferredSelectedChainFamily] + simp only [bind_assoc] + calc + _ = evalDist + (resolveDeferredChainPrefix table lay tree leafIdx (family 0) + (digits 0).val (by have := (digits 0).isLt; omega) context >>= + fun headOption => + match headOption with + | none => pure none + | some head => projectDeferredState <$> + finalizeResolvedCoordinates coordinates head.toDeferredContext table) := by + apply evalDist_bind_congr + intro headOption hhead + cases headOption with + | none => rfl + | some head => + have hmiddleValid := hvalid.of_resolveDeferredChainPrefix table lay tree leafIdx + (family 0) (digits 0).val (by have := (digits 0).isLt; omega) head hhead + have hmiddleCovered := hcovered.of_resolveDeferredChainPrefix table lay tree leafIdx + (family 0) (digits 0).val (by have := (digits 0).isLt; omega) head hhead + simp only + calc + _ = evalDist (do + let tail ← resolveDeferredSelectedChainFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) + (fun index : Fin n => digits index.succ) head.toDeferredContext + match tail with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some (finalContext, _) => projectDeferredState <$> + finalizeResolvedCoordinates coordinates finalContext table) := by + apply congrArg evalDist + simp only [bind_assoc] + apply bind_congr + intro tailOption + cases tailOption <;> simp + _ = _ := + evalDist_map_resolveDeferredSelectedChainFamily_then_finalize table lay tree + leafIdx coordinates (fun index : Fin n => family index.succ) + (fun index : Fin n => digits index.succ) head.toDeferredContext hmiddleValid + hmiddleCovered + _ = evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := + evalDist_map_resolveDeferredChainPrefix_then_finalize table lay tree leafIdx + (family 0) coordinates context hvalid hcovered (digits 0).val + (by have := (digits 0).isLt; omega) + +def ResolveDeferredValueFamilyRel (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ordinaryCache : QueryCache HashSpec) : + Option (DeferredContext × (Fin n → Digest)) → + (Fin n → Digest) × QueryCache HashSpec → Prop + | none, _ => True + | some (context, values), (concreteValues, cache) => + values = concreteValues ∧ + ResolvedContextInvariant parameter table context ordinaryCache cache + +set_option maxRecDepth 100000 in +theorem relTriple_resolveDeferredSelectedChainFamily_chronological + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ∀ {n : Nat} (family : Fin n → ChainIndex) (digits : Fin n → Digit) + (context : DeferredContext) (ordinaryCache cache : QueryCache HashSpec), + ResolvedContextInvariant parameter table context ordinaryCache cache → + RelTriple + (resolveDeferredSelectedChainFamily table lay tree leafIdx family digits context) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (sequenceFin fun index => + chainWalk parameter lay tree leafIdx (family index) 0 (digits index).val + (truncateHash (table ⟨lay, tree, leafIdx, family index⟩)))).run cache) + (ResolveDeferredValueFamilyRel parameter table ordinaryCache) + | 0, family, digits, context, ordinaryCache, cache, hinvariant => by + simp [resolveDeferredSelectedChainFamily, sequenceFin, + ResolveDeferredValueFamilyRel, hinvariant] + | n + 1, family, digits, context, ordinaryCache, cache, hinvariant => by + rw [resolveDeferredSelectedChainFamily, sequenceFin, simulateQ_bind, + StateT.run_bind] + have hhead := relTriple_resolveDeferredChainPrefix_chronological parameter table lay tree + leafIdx (family 0) context ordinaryCache cache hinvariant (digits 0).val + (by have := (digits 0).isLt; omega) + apply relTriple_bind hhead + intro headOption headResult hheadRelation + cases headOption with + | none => + rcases headResult with ⟨headValue, headCache⟩ + simp only + let right : ProbComp ((Fin (n + 1) → Digest) × QueryCache HashSpec) := + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (do + let tail ← sequenceFin fun index : Fin n => + chainWalk parameter lay tree leafIdx (family index.succ) 0 + (digits index.succ).val + (truncateHash (table ⟨lay, tree, leafIdx, family index.succ⟩)) + pure (Fin.cases headValue tail))).run headCache) + have hbase := relTriple_true + (pure (none : Option (DeferredContext × (Fin (n + 1) → Digest))) : + ProbComp (Option (DeferredContext × (Fin (n + 1) → Digest)))) right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = none) (by + intro result hresult + simpa using hresult) + apply relTriple_post_mono hsupported + intro leftResult _ hrelation + rw [hrelation.2] + trivial + | some head => + rcases headResult with ⟨headValue, headCache⟩ + rcases hheadRelation with ⟨hheadValue, hheadInvariant⟩ + have htail := relTriple_resolveDeferredSelectedChainFamily_chronological + parameter table lay tree leafIdx + (fun index : Fin n => family index.succ) + (fun index : Fin n => digits index.succ) head.toDeferredContext ordinaryCache + headCache hheadInvariant.1 + have hbound : RelTriple + (resolveDeferredSelectedChainFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) + (fun index : Fin n => digits index.succ) head.toDeferredContext >>= + fun tailOption => + match tailOption with + | none => pure none + | some (finalContext, tailValues) => + pure (some (finalContext, + Fin.cases (truncateHash head.output) tailValues))) + (((simulateQ (randomOracle : QueryImpl HashSpec _) + (sequenceFin fun index : Fin n => + chainWalk parameter lay tree leafIdx (family index.succ) 0 + (digits index.succ).val + (truncateHash + (table ⟨lay, tree, leafIdx, family index.succ⟩)))).run + headCache) >>= fun tail => + pure (Fin.cases headValue tail.1, tail.2)) + (ResolveDeferredValueFamilyRel parameter table ordinaryCache) := by + apply relTriple_bind htail + intro tailOption tailResult htailRelation + cases tailOption with + | none => + apply relTriple_pure_pure + trivial + | some tail => + rcases tail with ⟨finalContext, tailValues⟩ + rcases tailResult with ⟨concreteTailValues, finalCache⟩ + rcases htailRelation with ⟨htailValues, hfinalInvariant⟩ + apply relTriple_pure_pure + refine ⟨?_, hfinalInvariant⟩ + funext index + refine Fin.cases hheadValue.symm (fun tailIndex => ?_) index + exact congrFun htailValues tailIndex + simpa [simulateQ_bind, StateT.run_bind, simulateQ_pure, + StateT.run_pure] using hbound + +noncomputable def resolveDeferredLayerPathFamily + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ {n : Nat}, (Fin n → Fin maxLayerHeight) → + DeferredContext → ProbComp (Option (DeferredContext × (Fin n → Digest))) + | 0, _, context => pure (some (context, fun index => Fin.elim0 index)) + | n + 1, family, context => + if hinLayer : (family 0).val < layerHeight lay then do + let head ← resolveDeferredTreeNode table lay tree (family 0).val + (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) (by + have := (family 0).isLt + omega) context + match head with + | none => pure none + | some head => do + let tail ← resolveDeferredLayerPathFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) head.toDeferredContext + match tail with + | none => pure none + | some (finalContext, tailValues) => + pure (some (finalContext, + Fin.cases (truncateHash head.output) tailValues)) + else do + let tail ← resolveDeferredLayerPathFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) context + match tail with + | none => pure none + | some (finalContext, tailValues) => + pure (some (finalContext, Fin.cases 0 tailValues)) + +theorem privateStateAgrees_resolveDeferredLayerPathFamily + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ {n : Nat} (family : Fin n → Fin maxLayerHeight) + (context finalContext : DeferredContext) (values : Fin n → Digest), + some (finalContext, values) ∈ support + (resolveDeferredLayerPathFamily table lay tree leafIdx family context) → + PrivateStateAgrees finalContext context + | 0, family, context, finalContext, values, hresult => by + simp [resolveDeferredLayerPathFamily] at hresult + rw [hresult.1] + exact ⟨rfl, rfl, rfl⟩ + | n + 1, family, context, finalContext, values, hresult => by + rw [resolveDeferredLayerPathFamily] at hresult + by_cases hinLayer : (family 0).val < layerHeight lay + · simp only [hinLayer, ↓reduceDIte, mem_support_bind_iff] at hresult + obtain ⟨headOption, hhead, hrest⟩ := hresult + cases headOption with + | none => simp at hrest + | some head => + rw [mem_support_bind_iff] at hrest + obtain ⟨tailOption, htail, hreturn⟩ := hrest + cases tailOption with + | none => simp at hreturn + | some tail => + rcases tail with ⟨tailContext, tailValues⟩ + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hcontext : finalContext = tailContext := + congrArg Prod.fst (Option.some.inj hreturn) + rw [hcontext] + have hheadState := privateStateAgrees_resolveDeferredTreeNode table lay tree + (family 0).val (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) context head hhead + have htailState := privateStateAgrees_resolveDeferredLayerPathFamily table lay tree + leafIdx (fun index : Fin n => family index.succ) head.toDeferredContext + tailContext tailValues htail + exact ⟨htailState.1.trans hheadState.1, + htailState.2.1.trans hheadState.2.1, + htailState.2.2.trans hheadState.2.2⟩ + · simp only [hinLayer, ↓reduceDIte, mem_support_bind_iff] at hresult + obtain ⟨tailOption, htail, hreturn⟩ := hresult + cases tailOption with + | none => simp at hreturn + | some tail => + rcases tail with ⟨tailContext, tailValues⟩ + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hcontext : finalContext = tailContext := + congrArg Prod.fst (Option.some.inj hreturn) + rw [hcontext] + exact privateStateAgrees_resolveDeferredLayerPathFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) context tailContext tailValues htail + +theorem DeferredContext.Valid.of_resolveDeferredLayerPathFamily + {context : DeferredContext} (hvalid : context.Valid) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ {n : Nat} (family : Fin n → Fin maxLayerHeight) + (finalContext : DeferredContext) (values : Fin n → Digest), + some (finalContext, values) ∈ support + (resolveDeferredLayerPathFamily table lay tree leafIdx family context) → + finalContext.Valid + | 0, family, finalContext, values, hresult => by + simp [resolveDeferredLayerPathFamily] at hresult + rw [hresult.1] + exact hvalid + | n + 1, family, finalContext, values, hresult => by + rw [resolveDeferredLayerPathFamily] at hresult + by_cases hinLayer : (family 0).val < layerHeight lay + · simp only [hinLayer, ↓reduceDIte, mem_support_bind_iff] at hresult + obtain ⟨headOption, hhead, hrest⟩ := hresult + cases headOption with + | none => simp at hrest + | some head => + rw [mem_support_bind_iff] at hrest + obtain ⟨tailOption, htail, hreturn⟩ := hrest + cases tailOption with + | none => simp at hreturn + | some tail => + rcases tail with ⟨tailContext, tailValues⟩ + have hreturn' : finalContext = tailContext ∧ + values = Fin.cases (truncateHash head.output) tailValues := by + simpa using hreturn + rw [hreturn'.1] + have hheadValid := hvalid.of_resolveDeferredTreeNode table lay tree + (family 0).val (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) head hhead + exact hheadValid.of_resolveDeferredLayerPathFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) tailContext tailValues htail + · simp only [hinLayer, ↓reduceDIte, mem_support_bind_iff] at hresult + obtain ⟨tailOption, htail, hreturn⟩ := hresult + cases tailOption with + | none => simp at hreturn + | some tail => + rcases tail with ⟨tailContext, tailValues⟩ + have hreturn' : finalContext = tailContext ∧ + values = Fin.cases 0 tailValues := by + simpa using hreturn + rw [hreturn'.1] + exact hvalid.of_resolveDeferredLayerPathFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) tailContext tailValues htail + +theorem PendingCovered.of_resolveDeferredLayerPathFamily + {coordinates : List Coordinate} {context : DeferredContext} + (hcovered : PendingCovered coordinates context) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ {n : Nat} (family : Fin n → Fin maxLayerHeight) + (finalContext : DeferredContext) (values : Fin n → Digest), + some (finalContext, values) ∈ support + (resolveDeferredLayerPathFamily table lay tree leafIdx family context) → + PendingCovered coordinates finalContext + | 0, family, finalContext, values, hresult => by + simp [resolveDeferredLayerPathFamily] at hresult + rw [hresult.1] + exact hcovered + | n + 1, family, finalContext, values, hresult => by + rw [resolveDeferredLayerPathFamily] at hresult + by_cases hinLayer : (family 0).val < layerHeight lay + · simp only [hinLayer, ↓reduceDIte, mem_support_bind_iff] at hresult + obtain ⟨headOption, hhead, hrest⟩ := hresult + cases headOption with + | none => simp at hrest + | some head => + rw [mem_support_bind_iff] at hrest + obtain ⟨tailOption, htail, hreturn⟩ := hrest + cases tailOption with + | none => simp at hreturn + | some tail => + rcases tail with ⟨tailContext, tailValues⟩ + have hreturn' : finalContext = tailContext ∧ + values = Fin.cases (truncateHash head.output) tailValues := by + simpa using hreturn + rw [hreturn'.1] + have hheadCovered := hcovered.of_resolveDeferredTreeNode table lay tree + (family 0).val (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) head hhead + exact hheadCovered.of_resolveDeferredLayerPathFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) tailContext tailValues htail + · simp only [hinLayer, ↓reduceDIte, mem_support_bind_iff] at hresult + obtain ⟨tailOption, htail, hreturn⟩ := hresult + cases tailOption with + | none => simp at hreturn + | some tail => + rcases tail with ⟨tailContext, tailValues⟩ + have hreturn' : finalContext = tailContext ∧ + values = Fin.cases 0 tailValues := by + simpa using hreturn + rw [hreturn'.1] + exact hcovered.of_resolveDeferredLayerPathFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) tailContext tailValues htail + +set_option maxRecDepth 100000 in +theorem evalDist_map_resolveDeferredLayerPathFamily_then_finalize + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (coordinates : List Coordinate) : + ∀ {n : Nat} (family : Fin n → Fin maxLayerHeight) (context : DeferredContext), + context.Valid → PendingCovered coordinates context → + evalDist (do + let resolved ← + resolveDeferredLayerPathFamily table lay tree leafIdx family context + match resolved with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some (finalContext, _) => projectDeferredState <$> + finalizeResolvedCoordinates coordinates finalContext table) = + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) + | 0, family, context, hvalid, hcovered => by + simp [resolveDeferredLayerPathFamily] + | n + 1, family, context, hvalid, hcovered => by + rw [resolveDeferredLayerPathFamily] + by_cases hinLayer : (family 0).val < layerHeight lay + · simp only [hinLayer, ↓reduceDIte, bind_assoc] + calc + _ = evalDist + (resolveDeferredTreeNode table lay tree (family 0).val + (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) context >>= fun headOption => + match headOption with + | none => pure none + | some head => projectDeferredState <$> + finalizeResolvedCoordinates coordinates head.toDeferredContext table) := by + apply evalDist_bind_congr + intro headOption hhead + cases headOption with + | none => rfl + | some head => + have hmiddleValid := hvalid.of_resolveDeferredTreeNode table lay tree + (family 0).val (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) head hhead + have hmiddleCovered := hcovered.of_resolveDeferredTreeNode table lay tree + (family 0).val (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) head hhead + simp only + calc + _ = evalDist (do + let tail ← resolveDeferredLayerPathFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) head.toDeferredContext + match tail with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some (finalContext, _) => projectDeferredState <$> + finalizeResolvedCoordinates coordinates finalContext table) := by + apply congrArg evalDist + simp only [bind_assoc] + apply bind_congr + intro tailOption + cases tailOption <;> simp + _ = _ := + evalDist_map_resolveDeferredLayerPathFamily_then_finalize table lay tree + leafIdx coordinates (fun index : Fin n => family index.succ) + head.toDeferredContext hmiddleValid hmiddleCovered + _ = evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := + evalDist_map_resolveDeferredTreeNode_then_finalize table lay tree coordinates + (family 0).val (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) context hvalid hcovered + · simp only [hinLayer, ↓reduceDIte, bind_assoc] + calc + _ = evalDist (do + let tail ← resolveDeferredLayerPathFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) context + match tail with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some (finalContext, _) => projectDeferredState <$> + finalizeResolvedCoordinates coordinates finalContext table) := by + apply congrArg evalDist + apply bind_congr + intro tailOption + cases tailOption <;> simp + _ = _ := evalDist_map_resolveDeferredLayerPathFamily_then_finalize table lay tree + leafIdx coordinates (fun index : Fin n => family index.succ) context hvalid hcovered + +theorem ResolvedChainInvariant.fullChain + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {lay : Layer} {tree : TreeIndex} {leafIdx : LeafIndex} {chainIdx : ChainIndex} + {ordinaryCache : QueryCache HashSpec} {resolved : DeferredResolution} + {cache : QueryCache HashSpec} + (hinvariant : ResolvedChainInvariant parameter table lay tree leafIdx chainIdx + ordinaryCache (chainLength - 1) resolved cache) : + ResolvedContextInvariant parameter table resolved.toDeferredContext ordinaryCache cache ∧ + resolved.toDeferredContext.positionValue + (.chain lay tree leafIdx chainIdx Position.lastChainStep) = some resolved.output := by + rcases hinvariant with ⟨hcontext, htip⟩ + refine ⟨hcontext, ?_⟩ + rcases htip with ⟨hzero, _houtput⟩ | ⟨previous, hprevious, hvalue⟩ + · norm_num [chainLength, winternitzBits] at hzero + · have heq : previous = Position.lastChainStep := by + apply Fin.ext + change previous.val = chainLength - 2 + omega + simpa [heq] using hvalue + +def ResolveChainFamilyRel (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (ordinaryCache : QueryCache HashSpec) + {n : Nat} (family : Fin n → ChainIndex) : + Option DeferredContext → (Fin n → Digest) × QueryCache HashSpec → Prop + | none, _ => True + | some context, (values, cache) => + ResolvedContextInvariant parameter table context ordinaryCache cache ∧ + ∀ index, ∃ output, + context.positionValue + (.chain lay tree leafIdx (family index) Position.lastChainStep) = some output ∧ + values index = truncateHash output + +set_option maxRecDepth 100000 in +theorem relTriple_resolveDeferredChainFamily_chronological + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ∀ {n : Nat} (family : Fin n → ChainIndex) + (context : DeferredContext) (ordinaryCache cache : QueryCache HashSpec), + ResolvedContextInvariant parameter table context ordinaryCache cache → + RelTriple + (resolveDeferredChains table lay tree leafIdx (List.ofFn family) context) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (sequenceFin fun index => + chainWalk parameter lay tree leafIdx (family index) 0 (chainLength - 1) + (truncateHash (table ⟨lay, tree, leafIdx, family index⟩)))).run cache) + (ResolveChainFamilyRel parameter table lay tree leafIdx ordinaryCache family) + | 0, family, context, ordinaryCache, cache, hinvariant => by + simp [resolveDeferredChains, sequenceFin, ResolveChainFamilyRel, hinvariant] + | n + 1, family, context, ordinaryCache, cache, hinvariant => by + rw [List.ofFn_succ, resolveDeferredChains, sequenceFin, simulateQ_bind, + StateT.run_bind] + have hhead := relTriple_resolveDeferredChainPrefix_chronological parameter table lay tree + leafIdx (family 0) context ordinaryCache cache hinvariant (chainLength - 1) (by omega) + apply relTriple_bind hhead + intro headOption headResult hheadRelation + cases headOption with + | none => + rcases headResult with ⟨headValue, headCache⟩ + simp only + let right : ProbComp ((Fin (n + 1) → Digest) × QueryCache HashSpec) := + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (do + let tail ← sequenceFin fun index : Fin n => + chainWalk parameter lay tree leafIdx (family index.succ) 0 + (chainLength - 1) + (truncateHash (table ⟨lay, tree, leafIdx, family index.succ⟩)) + pure (Fin.cases headValue tail))).run headCache) + have hbase := relTriple_true + (pure (none : Option DeferredContext) : ProbComp (Option DeferredContext)) right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = none) (by + intro result hresult + simpa using hresult) + apply relTriple_post_mono hsupported + intro leftResult _ hrelation + rw [hrelation.2] + trivial + | some head => + rcases headResult with ⟨headValue, headCache⟩ + rcases hheadRelation with ⟨hheadValue, hheadInvariant⟩ + have hheadFull := hheadInvariant.fullChain + have htail := relTriple_resolveDeferredChainFamily_chronological parameter table lay tree + leafIdx (fun index : Fin n => family index.succ) head.toDeferredContext ordinaryCache + headCache hheadFull.1 + have htailSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support htail + (fun result => result ∈ support + (resolveDeferredChains table lay tree leafIdx + (List.ofFn fun index : Fin n => family index.succ) head.toDeferredContext)) + (fun result hresult => hresult) + have hbound : RelTriple + (resolveDeferredChains table lay tree leafIdx + (List.ofFn fun index : Fin n => family index.succ) head.toDeferredContext >>= + fun result => pure result) + (((simulateQ (randomOracle : QueryImpl HashSpec _) + (sequenceFin fun index : Fin n => + chainWalk parameter lay tree leafIdx (family index.succ) 0 + (chainLength - 1) + (truncateHash (table ⟨lay, tree, leafIdx, family index.succ⟩)))).run + headCache) >>= fun tail => + pure (Fin.cases headValue tail.1, tail.2)) + (ResolveChainFamilyRel parameter table lay tree leafIdx ordinaryCache family) := by + apply relTriple_bind htailSupported + intro tailOption tailResult htailRelation + rcases htailRelation with ⟨htailRel, htailSupport⟩ + apply relTriple_pure_pure + cases tailOption with + | none => trivial + | some finalContext => + rcases tailResult with ⟨tailValues, finalCache⟩ + rcases htailRel with ⟨hfinalInvariant, htailValues⟩ + refine ⟨hfinalInvariant, ?_⟩ + intro index + refine Fin.cases ?_ (fun tailIndex => ?_) index + · refine ⟨head.output, ?_, ?_⟩ + · exact resolveDeferredChains_preserves_positionValue table lay tree leafIdx + (List.ofFn fun index : Fin n => family index.succ) head.toDeferredContext + finalContext + (.chain lay tree leafIdx (family 0) Position.lastChainStep) head.output + hheadFull.2 htailSupport + · simpa using hheadValue + · obtain ⟨output, hposition, hvalue⟩ := htailValues tailIndex + exact ⟨output, hposition, hvalue⟩ + simpa [simulateQ_bind, StateT.run_bind, simulateQ_pure, StateT.run_pure] using hbound + +theorem relTriple_resolveDeferredChains_chronological + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (context : DeferredContext) (ordinaryCache cache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context ordinaryCache cache) : + RelTriple + (resolveDeferredChains table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) context) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (oneTimePublicKey parameter lay tree leafIdx + (fun chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)))).run cache) + (ResolveChainFamilyRel parameter table lay tree leafIdx ordinaryCache + (fun chainIdx : ChainIndex => chainIdx)) := by + simpa [oneTimePublicKey] using + relTriple_resolveDeferredChainFamily_chronological parameter table lay tree leafIdx + (fun chainIdx : ChainIndex => chainIdx) context ordinaryCache cache hinvariant + +theorem leafInput_eq_tableInput_of_completion + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (context : DeferredContext) (endpoints : ChainIndex → Digest) + (hvalues : ∀ chainIdx, ∃ output, + context.positionValue + (.chain lay tree leafIdx chainIdx Position.lastChainStep) = some output ∧ + endpoints chainIdx = truncateHash output) + (completion : Coordinate → HashOutput) + (hcompletion : DeferredCompletion table context completion) : + tweakableHashInput parameter (.leaf lay tree leafIdx) (leafPayload endpoints) = + tableInput parameter completion (.position (.leaf lay tree leafIdx)) := by + have hendpoints : endpoints = fun chainIdx => + tableValue completion (.chain lay tree leafIdx chainIdx Position.lastChainStep) := by + funext chainIdx + obtain ⟨output, hposition, houtput⟩ := hvalues chainIdx + rw [houtput, tableValue, hcompletion.eq_positionValue + (.chain lay tree leafIdx chainIdx Position.lastChainStep) output hposition] + rw [hendpoints] + simp [tableInput, tablePayload, leafPayload, Position.children, Function.comp_def, + Position.domain] + +set_option maxRecDepth 100000 in +theorem relTriple_resolveDeferredOtsLeaf_chronological + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (context : DeferredContext) (ordinaryCache cache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context ordinaryCache cache) : + RelTriple + (resolveDeferredOtsLeaf table lay tree leafIdx context) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (do + let endpoints ← oneTimePublicKey parameter lay tree leafIdx + (fun chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + leafHash parameter lay tree leafIdx endpoints)).run cache) + (ResolvePositionRel parameter table ordinaryCache (.leaf lay tree leafIdx)) := by + rw [resolveDeferredOtsLeaf, simulateQ_bind, StateT.run_bind] + have hchains := relTriple_resolveDeferredChains_chronological parameter table lay tree leafIdx + context ordinaryCache cache hinvariant + apply relTriple_bind hchains + intro chainsOption endpointsResult hchainsRelation + cases chainsOption with + | none => + simp only + have hbase := relTriple_true + (pure (none : Option DeferredResolution) : ProbComp (Option DeferredResolution)) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (leafHash parameter lay tree leafIdx endpointsResult.1)).run endpointsResult.2) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = none) (by + intro result hresult + simpa using hresult) + apply relTriple_post_mono hsupported + intro leftResult _ hrelation + rw [hrelation.2] + trivial + | some chains => + rcases endpointsResult with ⟨endpoints, middleCache⟩ + rcases hchainsRelation with ⟨hmiddleInvariant, hvalues⟩ + let input := tweakableHashInput parameter (.leaf lay tree leafIdx) (leafPayload endpoints) + have hcanonical : ∀ completion, DeferredCompletion table chains completion → + input = tableInput parameter completion (.position (.leaf lay tree leafIdx)) := by + intro completion hcompletion + exact leafInput_eq_tableInput_of_completion parameter table lay tree leafIdx chains + endpoints hvalues completion hcompletion + have hquery := relTriple_resolveDeferredPositionValue_chronological parameter table + (.leaf lay tree leafIdx) chains ordinaryCache middleCache input hmiddleInvariant + (by trivial) hcanonical + simpa [leafHash, tweakableHash, oracleHash, input, simulateQ_bind, StateT.run_bind, + simulateQ_pure, StateT.run_pure] using hquery + +set_option maxRecDepth 100000 in +theorem nodeInput_eq_tableInput_of_completion + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) + (hlevel : level < maxLayerHeight) + (hspan : 2 ^ (level + 1) * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) + (context : DeferredContext) (leftValue rightValue : Digest) + (leftOutput rightOutput : HashOutput) + (hleft : context.positionValue + (deferredTreePosition lay tree level (2 * nodeIdx) (by omega)) = some leftOutput) + (hright : context.positionValue + (deferredTreePosition lay tree level (2 * nodeIdx + 1) (by omega)) = some rightOutput) + (hleftValue : leftValue = truncateHash leftOutput) + (hrightValue : rightValue = truncateHash rightOutput) + (completion : Coordinate → HashOutput) + (hcompletion : DeferredCompletion table context completion) : + tweakableHashInput parameter (.node lay tree (level + 1) nodeIdx) + (nodePayload leftValue rightValue) = + tableInput parameter completion + (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) := by + have hnode : nodeIdx < 2 ^ maxLayerHeight := by + have hpow : 0 < 2 ^ (level + 1) := pow_pos (by omega) _ + nlinarith + have hpowTwo : 2 ≤ 2 ^ (level + 1) := by + simpa using Nat.pow_le_pow_right (n := 2) (by omega) (show 1 ≤ level + 1 by omega) + have hleftIndex : 2 * nodeIdx < 2 ^ maxLayerHeight := by nlinarith + have hrightIndex : 2 * nodeIdx + 1 < 2 ^ maxLayerHeight := by nlinarith + have hleftCompletion := hcompletion.eq_positionValue + (deferredTreePosition lay tree level (2 * nodeIdx) (by omega)) leftOutput hleft + have hrightCompletion := hcompletion.eq_positionValue + (deferredTreePosition lay tree level (2 * nodeIdx + 1) (by omega)) rightOutput hright + rw [hleftValue, hrightValue] + cases level with + | zero => + simp only [deferredTreePosition] at hleftCompletion hrightCompletion + have hleftLeaf : leafOfNat (2 * nodeIdx) = ⟨2 * nodeIdx, hleftIndex⟩ := by + apply Fin.ext + simp [leafOfNat, Nat.mod_eq_of_lt hleftIndex] + have hrightLeaf : leafOfNat (2 * nodeIdx + 1) = ⟨2 * nodeIdx + 1, hrightIndex⟩ := by + apply Fin.ext + simp [leafOfNat, Nat.mod_eq_of_lt hrightIndex] + rw [hleftLeaf] at hleftCompletion + rw [hrightLeaf] at hrightCompletion + simp only [tableInput, tablePayload, Position.domain] + rw [Position.children, dif_pos (by + simpa [leafOfNat, Nat.mod_eq_of_lt hnode] using hrightIndex), + dif_neg (show ¬0 < (⟨0, hlevel⟩ : Fin maxLayerHeight).val by simp)] + simp [nodePayload, tableValue, hleftCompletion, hrightCompletion, leafOfNat, + Nat.mod_eq_of_lt hnode] + | succ previous => + simp only [deferredTreePosition] at hleftCompletion hrightCompletion + have hleftLeaf : leafOfNat (2 * nodeIdx) = ⟨2 * nodeIdx, hleftIndex⟩ := by + apply Fin.ext + simp [leafOfNat, Nat.mod_eq_of_lt hleftIndex] + have hrightLeaf : leafOfNat (2 * nodeIdx + 1) = ⟨2 * nodeIdx + 1, hrightIndex⟩ := by + apply Fin.ext + simp [leafOfNat, Nat.mod_eq_of_lt hrightIndex] + rw [hleftLeaf] at hleftCompletion + rw [hrightLeaf] at hrightCompletion + simp only [tableInput, tablePayload, Position.domain] + rw [Position.children, dif_pos (by + simpa [leafOfNat, Nat.mod_eq_of_lt hnode] using hrightIndex), + dif_pos (show 0 < (⟨previous + 1, hlevel⟩ : Fin maxLayerHeight).val by simp)] + simp [nodePayload, tableValue, hleftCompletion, hrightCompletion, leafOfNat, + Nat.mod_eq_of_lt hnode] + +set_option maxRecDepth 100000 in +set_option linter.unusedVariables false in +theorem relTriple_resolveDeferredTreeNode_chronological + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) : + ∀ (level nodeIdx : Nat) (hlevel : level ≤ maxLayerHeight) + (hspan : 2 ^ level * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) + (context : DeferredContext) (ordinaryCache cache : QueryCache HashSpec), + ResolvedContextInvariant parameter table context ordinaryCache cache → + RelTriple + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay tree + (fun leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + level nodeIdx)).run cache) + (ResolvePositionRel parameter table ordinaryCache + (deferredTreePosition lay tree level nodeIdx hlevel)) + | 0, nodeIdx, hlevel, _hspan, context, ordinaryCache, cache, hinvariant => by + rw [treeNode_zero_eq] + simpa [resolveDeferredTreeNode, deferredTreePosition] using + relTriple_resolveDeferredOtsLeaf_chronological parameter table lay tree + (leafOfNat nodeIdx) context ordinaryCache cache hinvariant + | level + 1, nodeIdx, hlevel, hspan, context, ordinaryCache, cache, hinvariant => by + have hlevelSmall : level < maxLayerHeight := by omega + have hleftSpan : 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + calc + 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ level * (2 * (nodeIdx + 1)) := by + exact Nat.mul_le_mul_left _ (by omega) + _ = 2 ^ level * 2 * (nodeIdx + 1) := by ring + _ ≤ 2 ^ maxLayerHeight := hspan + have hrightSpan : 2 ^ level * (2 * nodeIdx + 1 + 1) ≤ 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + have heq : 2 ^ level * (2 * nodeIdx + 1 + 1) = + 2 ^ level * 2 * (nodeIdx + 1) := by ring + rw [heq] + exact hspan + rw [resolveDeferredTreeNode, treeNode_succ_eq, simulateQ_bind, StateT.run_bind] + have hleft := relTriple_resolveDeferredTreeNode_chronological parameter table lay tree level + (2 * nodeIdx) (by omega) hleftSpan context ordinaryCache cache hinvariant + apply relTriple_bind hleft + intro leftOption leftResult hleftRelation + cases leftOption with + | none => + rcases leftResult with ⟨leftValue, leftCache⟩ + simp only + let right : ProbComp (Digest × QueryCache HashSpec) := + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (do + let rightValue ← treeNode parameter lay tree + (fun leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + level (2 * nodeIdx + 1) + tweakableHash parameter (.node lay tree (level + 1) nodeIdx) + (nodePayload leftValue rightValue))).run leftCache) + have hbase := relTriple_true + (pure (none : Option DeferredResolution) : ProbComp (Option DeferredResolution)) right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = none) (by + intro result hresult + simpa using hresult) + apply relTriple_post_mono hsupported + intro leftResult _ hrelation + rw [hrelation.2] + trivial + | some left => + rcases leftResult with ⟨leftValue, leftCache⟩ + rcases hleftRelation with ⟨hleftValue, hleftInvariant, hleftPosition⟩ + rw [simulateQ_bind, StateT.run_bind] + have hright := relTriple_resolveDeferredTreeNode_chronological parameter table lay tree + level (2 * nodeIdx + 1) (by omega) hrightSpan left.toDeferredContext ordinaryCache + leftCache hleftInvariant + have hrightSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hright + (fun result => result ∈ support + (resolveDeferredTreeNode table lay tree level (2 * nodeIdx + 1) (by omega) + left.toDeferredContext)) + (fun result hresult => hresult) + apply relTriple_bind hrightSupported + intro rightOption rightResult hrightRelation + rcases hrightRelation with ⟨hrightRel, hrightSupport⟩ + cases rightOption with + | none => + rcases rightResult with ⟨rightValue, rightCache⟩ + simp only + let right : ProbComp (Digest × QueryCache HashSpec) := + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (tweakableHash parameter (.node lay tree (level + 1) nodeIdx) + (nodePayload leftValue rightValue))).run rightCache) + have hbase := relTriple_true + (pure (none : Option DeferredResolution) : ProbComp (Option DeferredResolution)) + right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = none) (by + intro result hresult + simpa using hresult) + apply relTriple_post_mono hsupported + intro leftResult _ hrelation + rw [hrelation.2] + trivial + | some right => + rcases rightResult with ⟨rightValue, rightCache⟩ + rcases hrightRel with ⟨hrightValue, hrightInvariant, hrightPosition⟩ + have hleftAtRight := resolveDeferredTreeNode_preserves_positionValue table lay tree + level (2 * nodeIdx + 1) (by omega) left.toDeferredContext right + (deferredTreePosition lay tree level (2 * nodeIdx) (by omega)) left.output + hleftPosition hrightSupport + let position : Position := + .node lay tree ⟨level, hlevelSmall⟩ (leafOfNat nodeIdx) + let input := tweakableHashInput parameter (.node lay tree (level + 1) nodeIdx) + (nodePayload leftValue rightValue) + have hcanonical : ∀ completion, + DeferredCompletion table right.toDeferredContext completion → + input = tableInput parameter completion (.position position) := by + intro completion hcompletion + exact nodeInput_eq_tableInput_of_completion parameter table lay tree level nodeIdx + hlevelSmall hspan right.toDeferredContext leftValue rightValue left.output + right.output hleftAtRight hrightPosition hleftValue hrightValue completion + hcompletion + have hquery := relTriple_resolveDeferredPositionValue_chronological parameter table + position right.toDeferredContext ordinaryCache rightCache input hrightInvariant + (by simp [position, IsOtsPosition]) hcanonical + simpa [deferredTreePosition, position, input, tweakableHash, oracleHash, + simulateQ_bind, StateT.run_bind, simulateQ_pure, StateT.run_pure] using hquery + +set_option maxRecDepth 100000 in +theorem relTriple_resolveDeferredLayerPathFamily_chronological + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ∀ {n : Nat} (family : Fin n → Fin maxLayerHeight) + (context : DeferredContext) (ordinaryCache cache : QueryCache HashSpec), + ResolvedContextInvariant parameter table context ordinaryCache cache → + RelTriple + (resolveDeferredLayerPathFamily table lay tree leafIdx family context) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (sequenceFin fun index => + if (family index).val < layerHeight lay then + treeNode parameter lay tree + (fun sibling chainIdx => + truncateHash (table ⟨lay, tree, sibling, chainIdx⟩)) + (family index).val + (Nat.xor (leafIdx.val / 2 ^ (family index).val) 1) + else pure 0)).run cache) + (ResolveDeferredValueFamilyRel parameter table ordinaryCache) + | 0, family, context, ordinaryCache, cache, hinvariant => by + simp [resolveDeferredLayerPathFamily, sequenceFin, + ResolveDeferredValueFamilyRel, hinvariant] + | n + 1, family, context, ordinaryCache, cache, hinvariant => by + rw [resolveDeferredLayerPathFamily, sequenceFin] + by_cases hinLayer : (family 0).val < layerHeight lay + · simp only [hinLayer, ↓reduceDIte, simulateQ_bind, StateT.run_bind] + have hspan := FtsProbeSimulation.sibling_node_bound maxLayerHeight leafIdx.val + (family 0).val (by omega) leafIdx.isLt + have hhead := relTriple_resolveDeferredTreeNode_chronological parameter table lay tree + (family 0).val (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) hspan context ordinaryCache cache hinvariant + apply relTriple_bind hhead + intro headOption headResult hheadRelation + cases headOption with + | none => + rcases headResult with ⟨headValue, headCache⟩ + simp only + let right : ProbComp ((Fin (n + 1) → Digest) × QueryCache HashSpec) := + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (do + let tail ← sequenceFin fun index : Fin n => + if (family index.succ).val < layerHeight lay then + treeNode parameter lay tree + (fun sibling chainIdx => truncateHash + (table ⟨lay, tree, sibling, chainIdx⟩)) + (family index.succ).val + (Nat.xor (leafIdx.val / 2 ^ (family index.succ).val) 1) + else pure 0 + pure (Fin.cases headValue tail))).run headCache) + have hbase := relTriple_true + (pure (none : Option (DeferredContext × (Fin (n + 1) → Digest))) : + ProbComp (Option (DeferredContext × (Fin (n + 1) → Digest)))) right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = none) (by + intro result hresult + simpa using hresult) + have hfinal := relTriple_post_mono + (R' := ResolveDeferredValueFamilyRel parameter table ordinaryCache) + hsupported (by + intro leftResult _ hrelation + rw [hrelation.2] + trivial) + simpa [right, simulateQ_bind, StateT.run_bind, simulateQ_pure, + StateT.run_pure] using hfinal + | some head => + rcases headResult with ⟨headValue, headCache⟩ + rcases hheadRelation with ⟨hheadValue, hheadInvariant, _hheadPosition⟩ + have htail := relTriple_resolveDeferredLayerPathFamily_chronological + parameter table lay tree leafIdx (fun index : Fin n => family index.succ) + head.toDeferredContext ordinaryCache headCache hheadInvariant + have hbound : RelTriple + (resolveDeferredLayerPathFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) head.toDeferredContext >>= + fun tailOption => + match tailOption with + | none => pure none + | some (finalContext, tailValues) => + pure (some (finalContext, + Fin.cases (truncateHash head.output) tailValues))) + (((simulateQ (randomOracle : QueryImpl HashSpec _) + (sequenceFin fun index : Fin n => + if (family index.succ).val < layerHeight lay then + treeNode parameter lay tree + (fun sibling chainIdx => truncateHash + (table ⟨lay, tree, sibling, chainIdx⟩)) + (family index.succ).val + (Nat.xor (leafIdx.val / 2 ^ (family index.succ).val) 1) + else pure 0)).run headCache) >>= fun tail => + pure (Fin.cases headValue tail.1, tail.2)) + (ResolveDeferredValueFamilyRel parameter table ordinaryCache) := by + apply relTriple_bind htail + intro tailOption tailResult htailRelation + cases tailOption with + | none => + apply relTriple_pure_pure + trivial + | some tail => + rcases tail with ⟨finalContext, tailValues⟩ + rcases tailResult with ⟨concreteTailValues, finalCache⟩ + rcases htailRelation with ⟨htailValues, hfinalInvariant⟩ + apply relTriple_pure_pure + refine ⟨?_, hfinalInvariant⟩ + funext index + refine Fin.cases hheadValue.symm (fun tailIndex => ?_) index + exact congrFun htailValues tailIndex + simpa [simulateQ_bind, StateT.run_bind, simulateQ_pure, + StateT.run_pure] using hbound + · simp only [hinLayer, ↓reduceDIte] + have htail := relTriple_resolveDeferredLayerPathFamily_chronological + parameter table lay tree leafIdx (fun index : Fin n => family index.succ) + context ordinaryCache cache hinvariant + have hbound : RelTriple + (resolveDeferredLayerPathFamily table lay tree leafIdx + (fun index : Fin n => family index.succ) context >>= fun tailOption => + match tailOption with + | none => pure none + | some (finalContext, tailValues) => + pure (some (finalContext, Fin.cases 0 tailValues))) + (((simulateQ (randomOracle : QueryImpl HashSpec _) + (sequenceFin fun index : Fin n => + if (family index.succ).val < layerHeight lay then + treeNode parameter lay tree + (fun sibling chainIdx => truncateHash + (table ⟨lay, tree, sibling, chainIdx⟩)) + (family index.succ).val + (Nat.xor (leafIdx.val / 2 ^ (family index.succ).val) 1) + else pure 0)).run cache) >>= fun tail => + pure (Fin.cases 0 tail.1, tail.2)) + (ResolveDeferredValueFamilyRel parameter table ordinaryCache) := by + apply relTriple_bind htail + intro tailOption tailResult htailRelation + cases tailOption with + | none => + apply relTriple_pure_pure + trivial + | some tail => + rcases tail with ⟨finalContext, tailValues⟩ + rcases tailResult with ⟨concreteTailValues, finalCache⟩ + rcases htailRelation with ⟨htailValues, hfinalInvariant⟩ + apply relTriple_pure_pure + refine ⟨?_, hfinalInvariant⟩ + funext index + refine Fin.cases rfl (fun tailIndex => ?_) index + exact congrFun htailValues tailIndex + simpa [simulateQ_bind, StateT.run_bind, simulateQ_pure, + StateT.run_pure] using hbound + + +noncomputable def resolveDeferredLayerValues + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) (context : DeferredContext) : + ProbComp (Option (DeferredContext × + ((ChainIndex → Digest) × (Fin maxLayerHeight → Digest)))) := do + let chains ← resolveDeferredSelectedChainFamily table lay (treeIndexAt index lay) + (leafIndexAt index lay) (fun chainIdx : ChainIndex => chainIdx) encoding context + match chains with + | none => pure none + | some (afterChains, values) => do + let path ← resolveDeferredLayerPathFamily table lay (treeIndexAt index lay) + (leafIndexAt index lay) (fun level : Fin maxLayerHeight => level) afterChains + match path with + | none => pure none + | some (finalContext, pathValues) => + pure (some (finalContext, (values, pathValues))) + +theorem resolveDeferredChainPrefix_preserves_other_layer_value + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps context result other, + positionOtsLayer? other ≠ some lay → + some result ∈ support + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) → + result.values other = context.values other + | 0, hsteps, context, result, other, hother, hresult => by + simp only [resolveDeferredChainPrefix, support_pure, Set.mem_singleton_iff] at hresult + exact congrFun (resolveDeferredChainStart_deferred_values_eq table + ⟨lay, tree, leafIdx, chainIdx⟩ context result hresult.symm) other + | steps + 1, hsteps, context, result, other, hother, hresult => by + rw [resolveDeferredChainPrefix, mem_support_bind_iff] at hresult + obtain ⟨previousOption, hprevious, hrest⟩ := hresult + cases previousOption with + | none => simp at hrest + | some previous => + have hmiddle := resolveDeferredChainPrefix_preserves_other_layer_value table lay tree + leafIdx chainIdx steps (by omega) context previous other hother hprevious + have hne : other ≠ .chain lay tree leafIdx chainIdx ⟨steps, by omega⟩ := by + intro heq + subst other + exact hother (by simp [positionOtsLayer?]) + exact (resolveDeferredPositionValue_preserves_other + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) other + previous.toDeferredContext result hne (by simpa using hrest)).trans hmiddle + +theorem resolveDeferredChains_preserves_other_layer_value + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + ∀ chains context result other, + positionOtsLayer? other ≠ some lay → + some result ∈ support (resolveDeferredChains table lay tree leafIdx chains context) → + result.values other = context.values other + | [], context, result, other, hother, hresult => by + simp [resolveDeferredChains] at hresult + subst result + rfl + | chainIdx :: remaining, context, result, other, hother, hresult => by + rw [resolveDeferredChains, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + exact (resolveDeferredChains_preserves_other_layer_value table lay tree leafIdx + remaining resolved.toDeferredContext result other hother (by simpa using hrest)).trans + (resolveDeferredChainPrefix_preserves_other_layer_value table lay tree leafIdx + chainIdx (chainLength - 1) (by omega) context resolved other hother hresolved) + +theorem resolveDeferredOtsLeaf_preserves_other_layer_value + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (context : DeferredContext) (result : DeferredResolution) + (other : Position) (hother : positionOtsLayer? other ≠ some lay) + (hresult : some result ∈ support + (resolveDeferredOtsLeaf table lay tree leafIdx context)) : + result.values other = context.values other := by + rw [resolveDeferredOtsLeaf, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + have hmiddle := resolveDeferredChains_preserves_other_layer_value table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) context chains other hother hchains + have hne : other ≠ .leaf lay tree leafIdx := by + intro heq + subst other + exact hother (by simp [positionOtsLayer?]) + exact (resolveDeferredPositionValue_preserves_other (.leaf lay tree leafIdx) other chains + result hne (by simpa using hrest)).trans hmiddle + +theorem resolveDeferredTreeNode_preserves_other_layer_value + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel context result other, + positionOtsLayer? other ≠ some lay → + some result ∈ support + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) → + result.values other = context.values other + | 0, nodeIdx, hlevel, context, result, other, hother, hresult => + resolveDeferredOtsLeaf_preserves_other_layer_value table lay tree (leafOfNat nodeIdx) + context result other hother hresult + | level + 1, nodeIdx, hlevel, context, result, other, hother, hresult => by + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨leftOption, hleft, hafterLeft⟩ := hresult + cases leftOption with + | none => simp at hafterLeft + | some left => + rw [mem_support_bind_iff] at hafterLeft + obtain ⟨rightOption, hright, hafterRight⟩ := hafterLeft + cases rightOption with + | none => simp at hafterRight + | some right => + have hleftValue := resolveDeferredTreeNode_preserves_other_layer_value table lay + tree level (2 * nodeIdx) (by omega) context left other hother hleft + have hrightValue := resolveDeferredTreeNode_preserves_other_layer_value table lay + tree level (2 * nodeIdx + 1) (by omega) left.toDeferredContext right other + hother hright + have hne : other ≠ .node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx) := by + intro heq + subst other + exact hother (by simp [positionOtsLayer?]) + exact (resolveDeferredPositionValue_preserves_other + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) other + right.toDeferredContext result hne (by simpa using hafterRight)).trans + (hrightValue.trans hleftValue) + +theorem resolveDeferredSelectedChainFamily_preserves_other_layer_value + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + ∀ {n : Nat} (family : Fin n → ChainIndex) (digits : Fin n → Digit) + (context finalContext : DeferredContext) (values : Fin n → Digest) (other : Position), + positionOtsLayer? other ≠ some lay → + some (finalContext, values) ∈ support + (resolveDeferredSelectedChainFamily table lay tree leafIdx family digits context) → + finalContext.values other = context.values other + | 0, family, digits, context, finalContext, values, other, hother, hresult => by + simp [resolveDeferredSelectedChainFamily] at hresult + rw [hresult.1] + | n + 1, family, digits, context, finalContext, values, other, hother, hresult => by + rw [resolveDeferredSelectedChainFamily, mem_support_bind_iff] at hresult + obtain ⟨headOption, hhead, hrest⟩ := hresult + cases headOption with + | none => simp at hrest + | some head => + rw [mem_support_bind_iff] at hrest + obtain ⟨tailOption, htail, hreturn⟩ := hrest + cases tailOption with + | none => simp at hreturn + | some tail => + rcases tail with ⟨tailContext, tailValues⟩ + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hcontext : finalContext = tailContext := + congrArg Prod.fst (Option.some.inj hreturn) + rw [hcontext] + exact (resolveDeferredSelectedChainFamily_preserves_other_layer_value table lay + tree leafIdx (fun index : Fin n => family index.succ) + (fun index : Fin n => digits index.succ) head.toDeferredContext tailContext + tailValues other hother htail).trans + (resolveDeferredChainPrefix_preserves_other_layer_value table lay tree leafIdx + (family 0) (digits 0).val (by have := (digits 0).isLt; omega) context head + other hother hhead) + +theorem resolveDeferredLayerPathFamily_preserves_other_layer_value + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + ∀ {n : Nat} (family : Fin n → Fin maxLayerHeight) + (context finalContext : DeferredContext) (values : Fin n → Digest) (other : Position), + positionOtsLayer? other ≠ some lay → + some (finalContext, values) ∈ support + (resolveDeferredLayerPathFamily table lay tree leafIdx family context) → + finalContext.values other = context.values other + | 0, family, context, finalContext, values, other, hother, hresult => by + simp [resolveDeferredLayerPathFamily] at hresult + rw [hresult.1] + | n + 1, family, context, finalContext, values, other, hother, hresult => by + rw [resolveDeferredLayerPathFamily] at hresult + by_cases hinLayer : (family 0).val < layerHeight lay + · simp only [hinLayer, ↓reduceDIte, mem_support_bind_iff] at hresult + obtain ⟨headOption, hhead, hrest⟩ := hresult + cases headOption with + | none => simp at hrest + | some head => + rw [mem_support_bind_iff] at hrest + obtain ⟨tailOption, htail, hreturn⟩ := hrest + cases tailOption with + | none => simp at hreturn + | some tail => + rcases tail with ⟨tailContext, tailValues⟩ + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hcontext : finalContext = tailContext := + congrArg Prod.fst (Option.some.inj hreturn) + rw [hcontext] + exact (resolveDeferredLayerPathFamily_preserves_other_layer_value table lay tree + leafIdx (fun index : Fin n => family index.succ) head.toDeferredContext + tailContext tailValues other hother htail).trans + (resolveDeferredTreeNode_preserves_other_layer_value table lay tree + (family 0).val (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) context head other hother hhead) + · simp only [hinLayer, ↓reduceDIte, mem_support_bind_iff] at hresult + obtain ⟨tailOption, htail, hreturn⟩ := hresult + cases tailOption with + | none => simp at hreturn + | some tail => + rcases tail with ⟨tailContext, tailValues⟩ + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hcontext : finalContext = tailContext := + congrArg Prod.fst (Option.some.inj hreturn) + rw [hcontext] + exact resolveDeferredLayerPathFamily_preserves_other_layer_value table lay tree + leafIdx (fun index : Fin n => family index.succ) context tailContext tailValues + other hother htail + +theorem resolveDeferredLayerValues_preserves_other_layer_value + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) (context finalContext : DeferredContext) + (values : (ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) + (other : Position) (hother : positionOtsLayer? other ≠ some lay) + (hresult : some (finalContext, values) ∈ support + (resolveDeferredLayerValues table index lay encoding context)) : + finalContext.values other = context.values other := by + rw [resolveDeferredLayerValues, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + rcases chains with ⟨afterChains, chainValues⟩ + rw [mem_support_bind_iff] at hrest + obtain ⟨pathOption, hpath, hreturn⟩ := hrest + cases pathOption with + | none => simp at hreturn + | some path => + rcases path with ⟨afterPath, pathValues⟩ + have hcontext : finalContext = afterPath := + congrArg Prod.fst (Option.some.inj hreturn) + rw [hcontext] + exact (resolveDeferredLayerPathFamily_preserves_other_layer_value table lay + (treeIndexAt index lay) (leafIndexAt index lay) + (fun level : Fin maxLayerHeight => level) afterChains afterPath pathValues other + hother hpath).trans + (resolveDeferredSelectedChainFamily_preserves_other_layer_value table lay + (treeIndexAt index lay) (leafIndexAt index lay) + (fun chainIdx : ChainIndex => chainIdx) encoding context afterChains chainValues + other hother hchains) + +theorem resolveDeferredChainPrefix_preserves_other_layer_pendingAt + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps context result other, + coordinateOtsLayer? other ≠ some lay → + some result ∈ support + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps context) → + result.state.pendingAt other = context.state.pendingAt other + | 0, hsteps, context, result, other, hother, hresult => by + simp only [resolveDeferredChainPrefix, support_pure, Set.mem_singleton_iff] at hresult + have hstate := resolveDeferredChainStart_state_eq_clearPending table + ⟨lay, tree, leafIdx, chainIdx⟩ context result hresult.symm + rw [hstate] + apply pendingAt_clearPending_of_ne + intro heq + subst other + exact hother (by simp [coordinateOtsLayer?, OtsSecretIndex.coordinate]) + | steps + 1, hsteps, context, result, other, hother, hresult => by + rw [resolveDeferredChainPrefix, mem_support_bind_iff] at hresult + obtain ⟨previousOption, hprevious, hrest⟩ := hresult + cases previousOption with + | none => simp at hrest + | some previous => + have hmiddle := resolveDeferredChainPrefix_preserves_other_layer_pendingAt table lay + tree leafIdx chainIdx steps (by omega) context previous other hother hprevious + have hrest' : some result ∈ support (resolveDeferredPositionValue + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + previous.toDeferredContext) := by + simpa using hrest + rw [resolveDeferredPositionValue_state_eq_clearPending + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + previous.toDeferredContext result hrest'] + exact (pendingAt_clearPending_of_ne previous.state + (.position (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩)) other (by + intro heq + subst other + exact hother (by simp [coordinateOtsLayer?, positionOtsLayer?]))).trans hmiddle + +theorem resolveDeferredChains_preserves_other_layer_pendingAt + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + ∀ chains context result other, + coordinateOtsLayer? other ≠ some lay → + some result ∈ support (resolveDeferredChains table lay tree leafIdx chains context) → + result.state.pendingAt other = context.state.pendingAt other + | [], context, result, other, hother, hresult => by + simp [resolveDeferredChains] at hresult + subst result + rfl + | chainIdx :: remaining, context, result, other, hother, hresult => by + rw [resolveDeferredChains, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hrest⟩ := hresult + cases resolvedOption with + | none => simp at hrest + | some resolved => + exact (resolveDeferredChains_preserves_other_layer_pendingAt table lay tree leafIdx + remaining resolved.toDeferredContext result other hother (by simpa using hrest)).trans + (resolveDeferredChainPrefix_preserves_other_layer_pendingAt table lay tree leafIdx + chainIdx (chainLength - 1) (by omega) context resolved other hother hresolved) + +theorem resolveDeferredOtsLeaf_preserves_other_layer_pendingAt + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (context : DeferredContext) (result : DeferredResolution) + (other : Coordinate) (hother : coordinateOtsLayer? other ≠ some lay) + (hresult : some result ∈ support + (resolveDeferredOtsLeaf table lay tree leafIdx context)) : + result.state.pendingAt other = context.state.pendingAt other := by + rw [resolveDeferredOtsLeaf, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + have hmiddle := resolveDeferredChains_preserves_other_layer_pendingAt table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) context chains other hother hchains + have hrest' : some result ∈ support + (resolveDeferredPositionValue (.leaf lay tree leafIdx) chains) := by + simpa using hrest + rw [resolveDeferredPositionValue_state_eq_clearPending (.leaf lay tree leafIdx) chains + result hrest'] + exact (pendingAt_clearPending_of_ne chains.state (.position (.leaf lay tree leafIdx)) + other (by + intro heq + subst other + exact hother (by simp [coordinateOtsLayer?, positionOtsLayer?]))).trans hmiddle + +theorem resolveDeferredTreeNode_preserves_other_layer_pendingAt + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel context result other, + coordinateOtsLayer? other ≠ some lay → + some result ∈ support + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel context) → + result.state.pendingAt other = context.state.pendingAt other + | 0, nodeIdx, hlevel, context, result, other, hother, hresult => + resolveDeferredOtsLeaf_preserves_other_layer_pendingAt table lay tree (leafOfNat nodeIdx) + context result other hother hresult + | level + 1, nodeIdx, hlevel, context, result, other, hother, hresult => by + rw [resolveDeferredTreeNode, mem_support_bind_iff] at hresult + obtain ⟨leftOption, hleft, hafterLeft⟩ := hresult + cases leftOption with + | none => simp at hafterLeft + | some left => + rw [mem_support_bind_iff] at hafterLeft + obtain ⟨rightOption, hright, hafterRight⟩ := hafterLeft + cases rightOption with + | none => simp at hafterRight + | some right => + have hleftPending := resolveDeferredTreeNode_preserves_other_layer_pendingAt table + lay tree level (2 * nodeIdx) (by omega) context left other hother hleft + have hrightPending := resolveDeferredTreeNode_preserves_other_layer_pendingAt table + lay tree level (2 * nodeIdx + 1) (by omega) left.toDeferredContext right other + hother hright + have hrest' : some result ∈ support (resolveDeferredPositionValue + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) + right.toDeferredContext) := by + simpa using hafterRight + rw [resolveDeferredPositionValue_state_eq_clearPending + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) + right.toDeferredContext result hrest'] + exact (pendingAt_clearPending_of_ne right.state + (.position (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx))) other (by + intro heq + subst other + exact hother (by simp [coordinateOtsLayer?, positionOtsLayer?]))).trans + (hrightPending.trans hleftPending) + +theorem resolveDeferredSelectedChainFamily_preserves_other_layer_pendingAt + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + ∀ {n : Nat} (family : Fin n → ChainIndex) (digits : Fin n → Digit) + (context finalContext : DeferredContext) (values : Fin n → Digest) + (other : Coordinate), + coordinateOtsLayer? other ≠ some lay → + some (finalContext, values) ∈ support + (resolveDeferredSelectedChainFamily table lay tree leafIdx family digits context) → + finalContext.state.pendingAt other = context.state.pendingAt other + | 0, family, digits, context, finalContext, values, other, hother, hresult => by + simp [resolveDeferredSelectedChainFamily] at hresult + rw [hresult.1] + | n + 1, family, digits, context, finalContext, values, other, hother, hresult => by + rw [resolveDeferredSelectedChainFamily, mem_support_bind_iff] at hresult + obtain ⟨headOption, hhead, hrest⟩ := hresult + cases headOption with + | none => simp at hrest + | some head => + rw [mem_support_bind_iff] at hrest + obtain ⟨tailOption, htail, hreturn⟩ := hrest + cases tailOption with + | none => simp at hreturn + | some tail => + rcases tail with ⟨tailContext, tailValues⟩ + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hcontext : finalContext = tailContext := + congrArg Prod.fst (Option.some.inj hreturn) + rw [hcontext] + exact (resolveDeferredSelectedChainFamily_preserves_other_layer_pendingAt table lay + tree leafIdx (fun index : Fin n => family index.succ) + (fun index : Fin n => digits index.succ) head.toDeferredContext tailContext + tailValues other hother htail).trans + (resolveDeferredChainPrefix_preserves_other_layer_pendingAt table lay tree + leafIdx (family 0) (digits 0).val (by have := (digits 0).isLt; omega) + context head other hother hhead) + +theorem resolveDeferredLayerPathFamily_preserves_other_layer_pendingAt + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + ∀ {n : Nat} (family : Fin n → Fin maxLayerHeight) + (context finalContext : DeferredContext) (values : Fin n → Digest) + (other : Coordinate), + coordinateOtsLayer? other ≠ some lay → + some (finalContext, values) ∈ support + (resolveDeferredLayerPathFamily table lay tree leafIdx family context) → + finalContext.state.pendingAt other = context.state.pendingAt other + | 0, family, context, finalContext, values, other, hother, hresult => by + simp [resolveDeferredLayerPathFamily] at hresult + rw [hresult.1] + | n + 1, family, context, finalContext, values, other, hother, hresult => by + rw [resolveDeferredLayerPathFamily] at hresult + by_cases hinLayer : (family 0).val < layerHeight lay + · simp only [hinLayer, ↓reduceDIte, mem_support_bind_iff] at hresult + obtain ⟨headOption, hhead, hrest⟩ := hresult + cases headOption with + | none => simp at hrest + | some head => + rw [mem_support_bind_iff] at hrest + obtain ⟨tailOption, htail, hreturn⟩ := hrest + cases tailOption with + | none => simp at hreturn + | some tail => + rcases tail with ⟨tailContext, tailValues⟩ + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hcontext : finalContext = tailContext := + congrArg Prod.fst (Option.some.inj hreturn) + rw [hcontext] + exact (resolveDeferredLayerPathFamily_preserves_other_layer_pendingAt table lay + tree leafIdx (fun index : Fin n => family index.succ) head.toDeferredContext + tailContext tailValues other hother htail).trans + (resolveDeferredTreeNode_preserves_other_layer_pendingAt table lay tree + (family 0).val (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) context head other hother hhead) + · simp only [hinLayer, ↓reduceDIte, mem_support_bind_iff] at hresult + obtain ⟨tailOption, htail, hreturn⟩ := hresult + cases tailOption with + | none => simp at hreturn + | some tail => + rcases tail with ⟨tailContext, tailValues⟩ + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hcontext : finalContext = tailContext := + congrArg Prod.fst (Option.some.inj hreturn) + rw [hcontext] + exact resolveDeferredLayerPathFamily_preserves_other_layer_pendingAt table lay tree + leafIdx (fun index : Fin n => family index.succ) context tailContext tailValues + other hother htail + +theorem resolveDeferredLayerValues_preserves_other_layer_pendingAt + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) (context finalContext : DeferredContext) + (values : (ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) + (other : Coordinate) (hother : coordinateOtsLayer? other ≠ some lay) + (hresult : some (finalContext, values) ∈ support + (resolveDeferredLayerValues table index lay encoding context)) : + finalContext.state.pendingAt other = context.state.pendingAt other := by + rw [resolveDeferredLayerValues, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + rcases chains with ⟨afterChains, chainValues⟩ + rw [mem_support_bind_iff] at hrest + obtain ⟨pathOption, hpath, hreturn⟩ := hrest + cases pathOption with + | none => simp at hreturn + | some path => + rcases path with ⟨afterPath, pathValues⟩ + have hcontext : finalContext = afterPath := + congrArg Prod.fst (Option.some.inj hreturn) + rw [hcontext] + exact (resolveDeferredLayerPathFamily_preserves_other_layer_pendingAt table lay + (treeIndexAt index lay) (leafIndexAt index lay) + (fun level : Fin maxLayerHeight => level) afterChains afterPath pathValues other + hother hpath).trans + (resolveDeferredSelectedChainFamily_preserves_other_layer_pendingAt table lay + (treeIndexAt index lay) (leafIndexAt index lay) + (fun chainIdx : ChainIndex => chainIdx) encoding context afterChains chainValues + other hother hchains) + +def LayerViewEq (lay : Layer) (left right : DeferredContext) : Prop := + left.state.values = right.state.values ∧ + left.state.revealed = right.state.revealed ∧ + left.state.ensured = right.state.ensured ∧ + (∀ position, positionOtsLayer? position = some lay → + left.values position = right.values position) ∧ + ∀ coordinate, coordinateOtsLayer? coordinate = some lay → + left.state.pendingAt coordinate = right.state.pendingAt coordinate + +theorem LayerViewEq.refl (lay : Layer) (context : DeferredContext) : + LayerViewEq lay context context := by + exact ⟨rfl, rfl, rfl, fun _ _ => rfl, fun _ _ => rfl⟩ + +theorem LayerViewEq.symm {lay : Layer} {left right : DeferredContext} + (heq : LayerViewEq lay left right) : LayerViewEq lay right left := by + exact ⟨heq.1.symm, heq.2.1.symm, heq.2.2.1.symm, + fun position hposition => (heq.2.2.2.1 position hposition).symm, + fun coordinate hcoordinate => (heq.2.2.2.2 coordinate hcoordinate).symm⟩ + +theorem LayerViewEq.trans {lay : Layer} {left middle right : DeferredContext} + (hleft : LayerViewEq lay left middle) (hright : LayerViewEq lay middle right) : + LayerViewEq lay left right := by + exact ⟨hleft.1.trans hright.1, hleft.2.1.trans hright.2.1, + hleft.2.2.1.trans hright.2.2.1, + fun position hposition => + (hleft.2.2.2.1 position hposition).trans + (hright.2.2.2.1 position hposition), + fun coordinate hcoordinate => + (hleft.2.2.2.2 coordinate hcoordinate).trans + (hright.2.2.2.2 coordinate hcoordinate)⟩ + +theorem LayerViewEq.hitAt_iff {lay : Layer} {left right : DeferredContext} + (heq : LayerViewEq lay left right) (coordinate : Coordinate) + (hcoordinate : coordinateOtsLayer? coordinate = some lay) (output : HashOutput) : + left.state.hitAt coordinate output ↔ right.state.hitAt coordinate output := by + unfold LazyRevealProbe.State.hitAt + rw [heq.2.2.2.2 coordinate hcoordinate] + +theorem LayerViewEq.positionValue_eq {lay : Layer} {left right : DeferredContext} + (heq : LayerViewEq lay left right) (position : Position) + (hposition : positionOtsLayer? position = some lay) : + left.positionValue position = right.positionValue position := by + unfold DeferredContext.positionValue + rw [heq.1] + cases right.state.values (.position position) + · exact heq.2.2.2.1 position hposition + · rfl + +theorem LayerViewEq.clearPending {lay : Layer} {left right : DeferredContext} + (heq : LayerViewEq lay left right) (coordinate : Coordinate) + (hcoordinate : coordinateOtsLayer? coordinate = some lay) : + LayerViewEq lay + { left with state := left.state.clearPending coordinate } + { right with state := right.state.clearPending coordinate } := by + refine ⟨heq.1, heq.2.1, heq.2.2.1, heq.2.2.2.1, ?_⟩ + intro other hother + by_cases hsame : other = coordinate + · subst other + ext candidate + simp [LazyRevealProbe.State.pendingAt, LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway] + · rw [pendingAt_clearPending_of_ne left.state coordinate other hsame, + pendingAt_clearPending_of_ne right.state coordinate other hsame] + exact heq.2.2.2.2 other hother + +theorem LayerViewEq.install {lay : Layer} {left right : DeferredContext} + (heq : LayerViewEq lay left right) (position : Position) + (hposition : positionOtsLayer? position = some lay) (output : HashOutput) : + LayerViewEq lay + { left with values := left.values.install position output } + { right with values := right.values.install position output } := by + refine ⟨heq.1, heq.2.1, heq.2.2.1, ?_, heq.2.2.2.2⟩ + intro other hother + by_cases hsame : other = position + · subst other + simp [DeferredStructuralValues.install] + · simpa [DeferredStructuralValues.install, hsame] using + heq.2.2.2.1 other hother + +theorem LayerViewEq.ensure {lay : Layer} {left right : DeferredContext} + (heq : LayerViewEq lay left right) (coordinate : Coordinate) : + LayerViewEq lay + { left with state := left.state.ensure coordinate } + { right with state := right.state.ensure coordinate } := by + refine ⟨heq.1, heq.2.1, ?_, heq.2.2.2.1, heq.2.2.2.2⟩ + simpa [LazyRevealProbe.State.ensure] using congrArg (insert coordinate) heq.2.2.1 + +theorem LayerViewEq.publish {lay : Layer} {left right : DeferredContext} + (heq : LayerViewEq lay left right) (coordinate : Coordinate) : + LayerViewEq lay + { left with state := left.state.publish coordinate } + { right with state := right.state.publish coordinate } := by + refine ⟨heq.1, ?_, heq.2.2.1, heq.2.2.2.1, heq.2.2.2.2⟩ + simpa [LazyRevealProbe.State.publish] using congrArg (insert coordinate) heq.2.1 + +theorem LayerViewEq.materialize {lay : Layer} {left right : DeferredContext} + (heq : LayerViewEq lay left right) (coordinate : Coordinate) + (hcoordinate : coordinateOtsLayer? coordinate = some lay) (output : HashOutput) : + LayerViewEq lay + { left with state := left.state.materialize coordinate output } + { right with state := right.state.materialize coordinate output } := by + have hclear := heq.clearPending coordinate hcoordinate + refine ⟨?_, heq.2.1, ?_, heq.2.2.2.1, hclear.2.2.2.2⟩ + · simpa [LazyRevealProbe.State.materialize] using + congrArg (fun values => Function.update values coordinate (some output)) heq.1 + · simpa [LazyRevealProbe.State.materialize] using + congrArg (insert coordinate) heq.2.2.1 + +def LayerResolutionEq (lay : Layer) : + Option DeferredResolution → Option DeferredResolution → Prop + | none, none => True + | some left, some right => + left.output = right.output ∧ LayerViewEq lay left.toDeferredContext right.toDeferredContext + | _, _ => False + +theorem relTriple_resolveDeferredPositionValue_of_layerViewEq + (lay : Layer) (position : Position) + (hposition : positionOtsLayer? position = some lay) + (left right : DeferredContext) (heq : LayerViewEq lay left right) : + RelTriple + (resolveDeferredPositionValue position left) + (resolveDeferredPositionValue position right) + (LayerResolutionEq lay) := by + have hcoordinate : coordinateOtsLayer? (.position position) = some lay := by + simpa [coordinateOtsLayer?] using hposition + have hstate := congrFun heq.1 (.position position) + unfold resolveDeferredPositionValue + dsimp only + cases hleftState : left.state.values (.position position) with + | some output => + have hrightState : right.state.values (.position position) = some output := by + rw [← hstate] + exact hleftState + simp only [hrightState] + have hhit := heq.hitAt_iff (.position position) hcoordinate output + by_cases hleftHit : left.state.hitAt (.position position) output + · rw [if_pos hleftHit, if_pos (hhit.mp hleftHit)] + exact relTriple_pure_pure trivial + · rw [if_neg hleftHit, if_neg (fun hrightHit => hleftHit (hhit.mpr hrightHit))] + apply relTriple_pure_pure + exact ⟨rfl, + (heq.clearPending (.position position) hcoordinate).install position hposition output⟩ + | none => + have hrightState : right.state.values (.position position) = none := by + rw [← hstate] + exact hleftState + simp only [hrightState] + have hvalue := heq.2.2.2.1 position hposition + cases hleftValue : left.values position with + | some output => + have hrightValue : right.values position = some output := by + rw [← hvalue] + exact hleftValue + simp only [hrightValue] + have hhit := heq.hitAt_iff (.position position) hcoordinate output + by_cases hleftHit : left.state.hitAt (.position position) output + · rw [if_pos hleftHit, if_pos (hhit.mp hleftHit)] + exact relTriple_pure_pure trivial + · rw [if_neg hleftHit, + if_neg (fun hrightHit => hleftHit (hhit.mpr hrightHit))] + apply relTriple_pure_pure + exact ⟨rfl, heq.clearPending (.position position) hcoordinate⟩ + | none => + have hrightValue : right.values position = none := by + rw [← hvalue] + exact hleftValue + simp only [hrightValue] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + have hhit := heq.hitAt_iff (.position position) hcoordinate leftOutput + by_cases hleftHit : left.state.hitAt (.position position) leftOutput + · rw [if_pos hleftHit, if_pos (hhit.mp hleftHit)] + exact relTriple_pure_pure trivial + · rw [if_neg hleftHit, + if_neg (fun hrightHit => hleftHit (hhit.mpr hrightHit))] + apply relTriple_pure_pure + exact ⟨rfl, + (heq.clearPending (.position position) hcoordinate).install position hposition + leftOutput⟩ + +theorem relTriple_resolveDeferredChainStart_of_layerViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (left right : DeferredContext) (heq : LayerViewEq lay left right) : + RelTriple + (pure (resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ left) : + ProbComp (Option DeferredResolution)) + (pure (resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ right) : + ProbComp (Option DeferredResolution)) + (LayerResolutionEq lay) := by + apply relTriple_pure_pure + have hcoordinate : coordinateOtsLayer? (.chainStart lay tree leafIdx chainIdx) = some lay := by + simp [coordinateOtsLayer?] + have hstate := congrFun heq.1 (.chainStart lay tree leafIdx chainIdx) + unfold resolveDeferredChainStart + dsimp only [OtsSecretIndex.coordinate] + cases hleftState : left.state.values (.chainStart lay tree leafIdx chainIdx) with + | some output => + have hrightState : + right.state.values (.chainStart lay tree leafIdx chainIdx) = some output := by + rw [← hstate] + exact hleftState + simp only [hrightState] + have hhit := heq.hitAt_iff (.chainStart lay tree leafIdx chainIdx) hcoordinate output + by_cases hleftHit : left.state.hitAt (.chainStart lay tree leafIdx chainIdx) output + · rw [if_pos hleftHit, if_pos (hhit.mp hleftHit)] + trivial + · rw [if_neg hleftHit, if_neg (fun hrightHit => hleftHit (hhit.mpr hrightHit))] + exact ⟨rfl, heq.clearPending (.chainStart lay tree leafIdx chainIdx) hcoordinate⟩ + | none => + have hrightState : + right.state.values (.chainStart lay tree leafIdx chainIdx) = none := by + rw [← hstate] + exact hleftState + simp only [hrightState] + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + have hhit := heq.hitAt_iff (.chainStart lay tree leafIdx chainIdx) hcoordinate output + by_cases hleftHit : left.state.hitAt (.chainStart lay tree leafIdx chainIdx) output + · rw [if_pos hleftHit, if_pos (hhit.mp hleftHit)] + trivial + · rw [if_neg hleftHit, if_neg (fun hrightHit => hleftHit (hhit.mpr hrightHit))] + exact ⟨rfl, heq.clearPending (.chainStart lay tree leafIdx chainIdx) hcoordinate⟩ + +theorem relTriple_resolveDeferredChainPrefix_of_layerViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps left right, + LayerViewEq lay left right → + RelTriple + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps left) + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps right) + (LayerResolutionEq lay) + | 0, hsteps, left, right, heq => by + simp only [resolveDeferredChainPrefix] + exact relTriple_resolveDeferredChainStart_of_layerViewEq table lay tree leafIdx chainIdx + left right heq + | steps + 1, hsteps, left, right, heq => by + rw [resolveDeferredChainPrefix, resolveDeferredChainPrefix] + apply relTriple_bind + (relTriple_resolveDeferredChainPrefix_of_layerViewEq table lay tree leafIdx chainIdx + steps (by omega) left right heq) + intro leftPrevious rightPrevious hprevious + cases leftPrevious with + | none => + cases rightPrevious <;> simp [LayerResolutionEq] at hprevious ⊢ + | some leftPrevious => + cases rightPrevious with + | none => simp [LayerResolutionEq] at hprevious + | some rightPrevious => + exact relTriple_resolveDeferredPositionValue_of_layerViewEq lay + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + (by simp [positionOtsLayer?]) leftPrevious.toDeferredContext + rightPrevious.toDeferredContext hprevious.2 + +def LayerContextOptionEq (lay : Layer) : + Option DeferredContext → Option DeferredContext → Prop + | none, none => True + | some left, some right => LayerViewEq lay left right + | _, _ => False + +theorem relTriple_resolveDeferredChains_of_layerViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ chains left right, + LayerViewEq lay left right → + RelTriple + (resolveDeferredChains table lay tree leafIdx chains left) + (resolveDeferredChains table lay tree leafIdx chains right) + (LayerContextOptionEq lay) + | [], left, right, heq => by + simp only [resolveDeferredChains] + exact relTriple_pure_pure heq + | chainIdx :: remaining, left, right, heq => by + rw [resolveDeferredChains, resolveDeferredChains] + apply relTriple_bind + (relTriple_resolveDeferredChainPrefix_of_layerViewEq table lay tree leafIdx chainIdx + (chainLength - 1) (by omega) left right heq) + intro leftResolved rightResolved hresolved + cases leftResolved with + | none => + cases rightResolved with + | none => + simpa [LayerContextOptionEq] using + (relTriple_pure_pure (R := LayerContextOptionEq lay) trivial) + | some rightResolved => simp [LayerResolutionEq] at hresolved + | some leftResolved => + cases rightResolved with + | none => simp [LayerResolutionEq] at hresolved + | some rightResolved => + exact relTriple_resolveDeferredChains_of_layerViewEq table lay tree leafIdx + remaining leftResolved.toDeferredContext rightResolved.toDeferredContext + hresolved.2 + +theorem relTriple_resolveDeferredOtsLeaf_of_layerViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (left right : DeferredContext) + (heq : LayerViewEq lay left right) : + RelTriple + (resolveDeferredOtsLeaf table lay tree leafIdx left) + (resolveDeferredOtsLeaf table lay tree leafIdx right) + (LayerResolutionEq lay) := by + rw [resolveDeferredOtsLeaf, resolveDeferredOtsLeaf] + apply relTriple_bind + (relTriple_resolveDeferredChains_of_layerViewEq table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) left right heq) + intro leftChains rightChains hchains + cases leftChains with + | none => + cases rightChains with + | none => + simpa [LayerResolutionEq] using + (relTriple_pure_pure (R := LayerResolutionEq lay) trivial) + | some rightChains => simp [LayerContextOptionEq] at hchains + | some leftChains => + cases rightChains with + | none => simp [LayerContextOptionEq] at hchains + | some rightChains => + exact relTriple_resolveDeferredPositionValue_of_layerViewEq lay + (.leaf lay tree leafIdx) (by simp [positionOtsLayer?]) leftChains rightChains hchains + +theorem relTriple_resolveDeferredTreeNode_of_layerViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel left right, + LayerViewEq lay left right → + RelTriple + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel left) + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel right) + (LayerResolutionEq lay) + | 0, nodeIdx, hlevel, left, right, heq => + relTriple_resolveDeferredOtsLeaf_of_layerViewEq table lay tree (leafOfNat nodeIdx) + left right heq + | level + 1, nodeIdx, hlevel, left, right, heq => by + rw [resolveDeferredTreeNode, resolveDeferredTreeNode] + apply relTriple_bind + (relTriple_resolveDeferredTreeNode_of_layerViewEq table lay tree level + (2 * nodeIdx) (by omega) left right heq) + intro leftNode rightNode hleftNode + cases leftNode with + | none => + cases rightNode <;> simp [LayerResolutionEq] at hleftNode ⊢ + | some leftNode => + cases rightNode with + | none => simp [LayerResolutionEq] at hleftNode + | some rightNode => + apply relTriple_bind + (relTriple_resolveDeferredTreeNode_of_layerViewEq table lay tree level + (2 * nodeIdx + 1) (by omega) leftNode.toDeferredContext + rightNode.toDeferredContext hleftNode.2) + intro leftSibling rightSibling hsibling + cases leftSibling with + | none => + cases rightSibling <;> simp [LayerResolutionEq] at hsibling ⊢ + | some leftSibling => + cases rightSibling with + | none => simp [LayerResolutionEq] at hsibling + | some rightSibling => + exact relTriple_resolveDeferredPositionValue_of_layerViewEq lay + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) + (by simp [positionOtsLayer?]) leftSibling.toDeferredContext + rightSibling.toDeferredContext hsibling.2 + +theorem relTriple_resolveDeferredPosition_of_layerViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (position : Position) + (hposition : positionOtsLayer? position = some lay) + (left right : DeferredContext) (heq : LayerViewEq lay left right) : + RelTriple + (resolveDeferredPosition table position left) + (resolveDeferredPosition table position right) + (LayerResolutionEq lay) := by + cases position with + | chain selectedLay tree leafIdx chainIdx step => + have hlay : selectedLay = lay := Option.some.inj hposition + subst selectedLay + exact relTriple_resolveDeferredChainPrefix_of_layerViewEq table lay tree leafIdx chainIdx + (step.val + 1) (by have := step.isLt; omega) left right heq + | leaf selectedLay tree leafIdx => + have hlay : selectedLay = lay := Option.some.inj hposition + subst selectedLay + exact relTriple_resolveDeferredOtsLeaf_of_layerViewEq table lay tree leafIdx left right heq + | node selectedLay tree level nodeIdx => + have hlay : selectedLay = lay := Option.some.inj hposition + subst selectedLay + exact relTriple_resolveDeferredTreeNode_of_layerViewEq table lay tree + (level.val + 1) nodeIdx (by have := level.isLt; omega) left right heq + | ftsLeaf index tree leafIdx => simp [positionOtsLayer?] at hposition + | ftsNode index tree level nodeIdx => simp [positionOtsLayer?] at hposition + | ftsRoots index => simp [positionOtsLayer?] at hposition + +theorem relTriple_resolveDeferredReveal_of_layerViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (position : Position) + (hposition : positionOtsLayer? position = some lay) + (left right : DeferredContext) (heq : LayerViewEq lay left right) : + RelTriple + (resolveDeferredReveal table position left) + (resolveDeferredReveal table position right) + (LayerResolutionEq lay) := by + classical + unfold resolveDeferredReveal + by_cases hresolvable : ResolvableOtsPosition position + · rw [if_pos hresolvable, if_pos hresolvable] + exact relTriple_resolveDeferredPosition_of_layerViewEq table lay position hposition + left right heq + · rw [if_neg hresolvable, if_neg hresolvable] + exact relTriple_resolveDeferredPositionValue_of_layerViewEq lay position hposition + left right heq + +def LayerRunEq (lay : Layer) : + Option (ResolvedRunResult alpha) → Option (ResolvedRunResult alpha) → Prop + | none, none => True + | some left, some right => + LayerViewEq lay left.context right.context ∧ + left.remaining = right.remaining ∧ left.value = right.value ∧ left.table = right.table + | _, _ => False + +def LayerViewCouples (lay : Layer) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ left right fuel table cache, + LayerViewEq lay left right → + RelTriple + (runResolvedFromTable left fuel table (computation.run cache)) + (runResolvedFromTable right fuel table (computation.run cache)) + (LayerRunEq lay) + +theorem layerViewCouples_pure (lay : Layer) (value : alpha) : + LayerViewCouples lay + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro left right fuel table cache heq + simp only [StateT.run_pure] + simp [runResolvedFromTable, LayerRunEq, heq] + +theorem LayerViewCouples.bind {lay : Layer} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : LayerViewCouples lay left) + (hnext : ∀ value, LayerViewCouples lay (next value)) : + LayerViewCouples lay (left >>= next) := by + intro leftContext rightContext fuel table cache heq + rw [StateT.run_bind, runResolvedFromTable_bind, runResolvedFromTable_bind] + apply relTriple_bind (hleft leftContext rightContext fuel table cache heq) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => + simpa [LayerRunEq] using + (relTriple_pure_pure (R := LayerRunEq lay) trivial) + | some rightResult => simp [LayerRunEq] at hresult + | some leftResult => + cases rightResult with + | none => simp [LayerRunEq] at hresult + | some rightResult => + rcases leftResult with ⟨leftContext, leftFuel, leftValue, leftTable⟩ + rcases rightResult with ⟨rightContext, rightFuel, rightValue, rightTable⟩ + simp only [LayerRunEq] at hresult + rcases hresult with ⟨hcontext, rfl, hvalue, rfl⟩ + subst rightValue + exact hnext leftValue.1 leftContext rightContext leftFuel leftTable leftValue.2 hcontext + +theorem layerViewCouples_ensureCoordinate (lay : Layer) (coordinate : Coordinate) : + LayerViewCouples lay (ensureCoordinate coordinate) := by + intro left right fuel table cache heq + unfold ensureCoordinate + rw [StateT.run_liftM, LazyRevealProbe.ensureQuery, + runResolvedFromTable_ensure_query_bind, runResolvedFromTable_ensure_query_bind] + simp only [runResolvedFromTable] + apply relTriple_pure_pure + exact ⟨heq.ensure coordinate, rfl, rfl, rfl⟩ + +theorem layerViewCouples_sequenceFin {lay : Layer} {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hcomponent : ∀ position, LayerViewCouples lay (computation position)) : + LayerViewCouples lay (sequenceFin computation) := by + induction n with + | zero => + simpa [sequenceFin] using + (layerViewCouples_pure lay Fin.elim0 : + LayerViewCouples lay + (pure Fin.elim0 : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Fin 0 → alpha))) + | succ n ih => + rw [sequenceFin] + apply (hcomponent 0).bind + intro head + apply (ih (fun position : Fin n => computation position.succ) + (fun position => hcomponent position.succ)).bind + intro tail + exact layerViewCouples_pure lay + (Fin.cases head tail : Fin (n + 1) → alpha) + +theorem layerViewCouples_ensureFullChain (observedLay lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + LayerViewCouples observedLay (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + apply (layerViewCouples_sequenceFin + (fun step : ChainStep => + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step))) + (fun step => layerViewCouples_ensureCoordinate observedLay + (.position (.chain lay tree leafIdx chainIdx step)))).bind + intro _ + exact layerViewCouples_pure observedLay () + +theorem layerViewCouples_ensureOtsLeaf (observedLay lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) : + LayerViewCouples observedLay (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + apply (layerViewCouples_sequenceFin + (fun chainIdx : ChainIndex => ensureFullChain lay tree leafIdx chainIdx) + (fun chainIdx => layerViewCouples_ensureFullChain observedLay lay tree leafIdx chainIdx)).bind + intro _ + exact layerViewCouples_ensureCoordinate observedLay (.position (.leaf lay tree leafIdx)) + +theorem layerViewCouples_ensureTreeNode (observedLay lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, LayerViewCouples observedLay (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => layerViewCouples_ensureOtsLeaf observedLay lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + apply (layerViewCouples_ensureTreeNode observedLay lay tree level (2 * nodeIdx)).bind + intro _ + apply (layerViewCouples_ensureTreeNode observedLay lay tree level + (2 * nodeIdx + 1)).bind + intro _ + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact layerViewCouples_ensureCoordinate observedLay + (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact layerViewCouples_pure observedLay () + +theorem layerViewCouples_revealPosition (table : OtsSecretIndex → HashOutput) + (lay : Layer) (position : Position) (hposition : positionOtsLayer? position = some lay) : + ∀ left right fuel cache, + LayerViewEq lay left right → + RelTriple + (runResolvedFromTable left fuel table ((revealPosition position).run cache)) + (runResolvedFromTable right fuel table ((revealPosition position).run cache)) + (LayerRunEq lay) := by + intro left right fuel cache heq + rw [runResolvedFromTable_revealPosition, runResolvedFromTable_revealPosition] + apply relTriple_bind + (relTriple_resolveDeferredReveal_of_layerViewEq table lay position hposition left right heq) + intro leftResolved rightResolved hresolved + cases leftResolved with + | none => + cases rightResolved with + | none => + simpa [LayerRunEq] using + (relTriple_pure_pure (R := LayerRunEq lay) trivial) + | some rightResolved => simp [LayerResolutionEq] at hresolved + | some leftResolved => + cases rightResolved with + | none => simp [LayerResolutionEq] at hresolved + | some rightResolved => + apply relTriple_pure_pure + refine ⟨?_, rfl, ?_, rfl⟩ + · rw [← hresolved.1] + have hstate := heq.materialize (.position position) + (by simpa [coordinateOtsLayer?] using hposition) leftResolved.output + exact ⟨hstate.1, hstate.2.1, hstate.2.2.1, + hresolved.2.2.2.2.1, hstate.2.2.2.2⟩ + · rw [hresolved.1] + +theorem layerViewCouples_maskedTreeNode (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) : + ∀ left right fuel cache, + LayerViewEq lay left right → + RelTriple + (runResolvedFromTable left fuel table ((maskedTreeNode lay tree level nodeIdx).run cache)) + (runResolvedFromTable right fuel table ((maskedTreeNode lay tree level nodeIdx).run cache)) + (LayerRunEq lay) := by + intro left right fuel cache heq + unfold maskedTreeNode + rw [StateT.run_bind, runResolvedFromTable_bind, runResolvedFromTable_bind] + apply relTriple_bind + (layerViewCouples_ensureTreeNode lay lay tree level nodeIdx left right fuel table cache heq) + intro leftEnsured rightEnsured hensured + cases leftEnsured with + | none => + cases rightEnsured with + | none => + simpa [LayerRunEq] using + (relTriple_pure_pure (R := LayerRunEq lay) trivial) + | some rightEnsured => simp [LayerRunEq] at hensured + | some leftEnsured => + cases rightEnsured with + | none => simp [LayerRunEq] at hensured + | some rightEnsured => + rcases leftEnsured with ⟨leftContext, leftFuel, leftValue, leftTable⟩ + rcases rightEnsured with ⟨rightContext, rightFuel, rightValue, rightTable⟩ + simp only [LayerRunEq] at hensured + rcases hensured with ⟨hcontext, rfl, hvalue, rfl⟩ + subst rightValue + cases level with + | zero => + exact layerViewCouples_revealPosition leftTable lay + (.leaf lay tree (leafOfNat nodeIdx)) (by simp [positionOtsLayer?]) + leftContext rightContext leftFuel leftValue.2 hcontext + | succ current => + by_cases hlevel : current < maxLayerHeight + · simp only [hlevel, ↓reduceDIte] + exact layerViewCouples_revealPosition leftTable lay + (.node lay tree ⟨current, hlevel⟩ (leafOfNat nodeIdx)) + (by simp [positionOtsLayer?]) leftContext rightContext leftFuel leftValue.2 + hcontext + · simp [hlevel, runResolvedFromTable, LayerRunEq, hcontext] + +theorem layerViewCouples_maskedTreeRoot (lay : Layer) (tree : TreeIndex) : + LayerViewCouples lay (maskedTreeRoot lay tree) := by + intro left right fuel table cache heq + unfold maskedTreeRoot + exact layerViewCouples_maskedTreeNode table lay tree (layerHeight lay) 0 + left right fuel cache heq + +theorem layerViewCouples_ensureChainPrefix (observedLay lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + LayerViewCouples observedLay (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + apply (layerViewCouples_sequenceFin + (fun step : ChainStep => + if step.val < digit.val then + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + else pure ()) + (fun step => by + by_cases hstep : step.val < digit.val + · rw [if_pos hstep] + exact layerViewCouples_ensureCoordinate observedLay + (.position (.chain lay tree leafIdx chainIdx step)) + · rw [if_neg hstep] + exact layerViewCouples_pure observedLay ())).bind + intro _ + exact layerViewCouples_pure observedLay () + +theorem layerViewCouples_ensureTreePath (observedLay lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) : + LayerViewCouples observedLay (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + apply (layerViewCouples_sequenceFin + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + ensureTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + else pure ()) + (fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + exact layerViewCouples_ensureTreeNode observedLay lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · rw [if_neg hlevel] + exact layerViewCouples_pure observedLay ())).bind + intro _ + exact layerViewCouples_pure observedLay () + +theorem layerViewCouples_splitHashQuery_ordinary (lay : Layer) (input : HashInput) : + LayerViewCouples lay (splitHashQuery (.ordinary input)) := by + intro left right fuel table cache heq + rw [splitHashQuery_run_eq] + cases hlookup : cache (.ordinary input) with + | some output => + simp only + simp [runResolvedFromTable, LayerRunEq, heq] + | none => + simp only + rw [LazyRevealProbe.hashOutputQuery, + runResolvedFromTable_hashOutput_query_bind, + runResolvedFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp [runResolvedFromTable, LayerRunEq, heq] + +theorem layerViewCouples_ordinaryHashImpl (lay : Layer) (input : HashInput) : + LayerViewCouples lay (ordinaryHashImpl input) := by + exact layerViewCouples_splitHashQuery_ordinary lay input + +theorem layerViewCouples_simulateQ {spec : OracleSpec ι} + (lay : Layer) + (impl : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))) + (hquery : ∀ query, LayerViewCouples lay (impl query)) + (computation : OracleComp spec alpha) : + LayerViewCouples lay (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp only [simulateQ_pure] + exact layerViewCouples_pure lay value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (hquery query).bind fun output => ih output + +theorem layerViewCouples_maskedOtsSignFrom (observedLay lay : Layer) + (parameter : PublicParameter) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) : ∀ attempts counter, + LayerViewCouples observedLay + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom] + exact layerViewCouples_pure observedLay none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + have hencoded := layerViewCouples_simulateQ observedLay ordinaryHashImpl + (layerViewCouples_ordinaryHashImpl observedLay) + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter)) + apply hencoded.bind + intro encoded + cases encoded with + | none => + exact layerViewCouples_maskedOtsSignFrom observedLay lay parameter tree leafIdx + message attempts (counter + 1) + | some encoding => + apply (layerViewCouples_sequenceFin + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx + (encoding chainIdx)) + (fun chainIdx => layerViewCouples_ensureChainPrefix observedLay lay tree leafIdx + chainIdx (encoding chainIdx))).bind + intro _ + exact layerViewCouples_pure observedLay + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem layerViewCouples_maskedOtsSign (observedLay lay : Layer) + (parameter : PublicParameter) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) : + LayerViewCouples observedLay + (maskedOtsSign parameter lay tree leafIdx message) := by + exact layerViewCouples_maskedOtsSignFrom observedLay lay parameter tree leafIdx message + encodingAttemptLimit 0 + +theorem layerViewCouples_maskedLayerMessage_of_below + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (hbelow : lay.val + 1 < numLayers) : + LayerViewCouples ⟨lay.val + 1, hbelow⟩ + (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + rw [dif_pos hbelow] + exact layerViewCouples_maskedTreeRoot ⟨lay.val + 1, hbelow⟩ + (treeIndexAt index ⟨lay.val + 1, hbelow⟩) + +theorem layerViewCouples_maskedLayerMessage_of_not_below + (observedLay : Layer) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (hbelow : ¬lay.val + 1 < numLayers) : + LayerViewCouples observedLay + (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + rw [dif_neg hbelow] + exact layerViewCouples_simulateQ observedLay ordinaryHashImpl + (layerViewCouples_ordinaryHashImpl observedLay) + (ftsKey parameter index (ftsSecret index)) + +theorem layerViewCouples_maskedSignLayer_of_below + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (hbelow : lay.val + 1 < numLayers) : + LayerViewCouples ⟨lay.val + 1, hbelow⟩ + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + apply (layerViewCouples_maskedLayerMessage_of_below parameter ftsSecret index lay + hbelow).bind + intro message + apply (layerViewCouples_maskedOtsSign ⟨lay.val + 1, hbelow⟩ lay parameter + (treeIndexAt index lay) (leafIndexAt index lay) message).bind + intro selected + cases selected with + | none => exact layerViewCouples_pure ⟨lay.val + 1, hbelow⟩ none + | some selected => + apply (layerViewCouples_ensureTreePath ⟨lay.val + 1, hbelow⟩ lay + (treeIndexAt index lay) (leafIndexAt index lay)).bind + intro _ + exact layerViewCouples_pure ⟨lay.val + 1, hbelow⟩ (some selected) + +theorem layerViewCouples_maskedSignLayer_of_not_below + (observedLay : Layer) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (hbelow : ¬lay.val + 1 < numLayers) : + LayerViewCouples observedLay (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + apply (layerViewCouples_maskedLayerMessage_of_not_below observedLay parameter ftsSecret + index lay hbelow).bind + intro message + apply (layerViewCouples_maskedOtsSign observedLay lay parameter + (treeIndexAt index lay) (leafIndexAt index lay) message).bind + intro selected + cases selected with + | none => exact layerViewCouples_pure observedLay none + | some selected => + apply (layerViewCouples_ensureTreePath observedLay lay + (treeIndexAt index lay) (leafIndexAt index lay)).bind + intro _ + exact layerViewCouples_pure observedLay (some selected) + +def ResolverLayerViewEq (lay : Layer) (left right : DeferredContext) : Prop := + (∀ coordinate, coordinateOtsLayer? coordinate = some lay → + left.state.values coordinate = right.state.values coordinate) ∧ + (∀ position, positionOtsLayer? position = some lay → + left.values position = right.values position) ∧ + ∀ coordinate, coordinateOtsLayer? coordinate = some lay → + left.state.pendingAt coordinate = right.state.pendingAt coordinate + +theorem ResolverLayerViewEq.refl (lay : Layer) (context : DeferredContext) : + ResolverLayerViewEq lay context context := by + exact ⟨fun _ _ => rfl, fun _ _ => rfl, fun _ _ => rfl⟩ + +theorem ResolverLayerViewEq.symm {lay : Layer} {left right : DeferredContext} + (heq : ResolverLayerViewEq lay left right) : + ResolverLayerViewEq lay right left := by + exact ⟨fun coordinate hcoordinate => (heq.1 coordinate hcoordinate).symm, + fun position hposition => (heq.2.1 position hposition).symm, + fun coordinate hcoordinate => (heq.2.2 coordinate hcoordinate).symm⟩ + +theorem ResolverLayerViewEq.trans {lay : Layer} {left middle right : DeferredContext} + (hleft : ResolverLayerViewEq lay left middle) + (hright : ResolverLayerViewEq lay middle right) : + ResolverLayerViewEq lay left right := by + exact ⟨fun coordinate hcoordinate => + (hleft.1 coordinate hcoordinate).trans (hright.1 coordinate hcoordinate), + fun position hposition => + (hleft.2.1 position hposition).trans (hright.2.1 position hposition), + fun coordinate hcoordinate => + (hleft.2.2 coordinate hcoordinate).trans (hright.2.2 coordinate hcoordinate)⟩ + +theorem LayerViewEq.toResolverLayerViewEq {lay : Layer} {left right : DeferredContext} + (heq : LayerViewEq lay left right) : ResolverLayerViewEq lay left right := by + exact ⟨fun coordinate _ => congrFun heq.1 coordinate, + heq.2.2.2.1, heq.2.2.2.2⟩ + +theorem ResolverLayerViewEq.hitAt_iff {lay : Layer} {left right : DeferredContext} + (heq : ResolverLayerViewEq lay left right) (coordinate : Coordinate) + (hcoordinate : coordinateOtsLayer? coordinate = some lay) (output : HashOutput) : + left.state.hitAt coordinate output ↔ right.state.hitAt coordinate output := by + unfold LazyRevealProbe.State.hitAt + rw [heq.2.2 coordinate hcoordinate] + +theorem ResolverLayerViewEq.positionValue_eq + {lay : Layer} {left right : DeferredContext} + (heq : ResolverLayerViewEq lay left right) (position : Position) + (hposition : positionOtsLayer? position = some lay) : + left.positionValue position = right.positionValue position := by + unfold DeferredContext.positionValue + have hcoordinate : coordinateOtsLayer? (.position position) = some lay := by + simpa [coordinateOtsLayer?] using hposition + rw [heq.1 (.position position) hcoordinate] + cases right.state.values (.position position) + · exact heq.2.1 position hposition + · rfl + +theorem ResolverLayerViewEq.clearPending + {lay : Layer} {left right : DeferredContext} + (heq : ResolverLayerViewEq lay left right) (coordinate : Coordinate) + (hcoordinate : coordinateOtsLayer? coordinate = some lay) : + ResolverLayerViewEq lay + { left with state := left.state.clearPending coordinate } + { right with state := right.state.clearPending coordinate } := by + refine ⟨heq.1, heq.2.1, ?_⟩ + intro other hother + by_cases hsame : other = coordinate + · subst other + ext candidate + simp [LazyRevealProbe.State.pendingAt, LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway] + · rw [pendingAt_clearPending_of_ne left.state coordinate other hsame, + pendingAt_clearPending_of_ne right.state coordinate other hsame] + exact heq.2.2 other hother + +theorem ResolverLayerViewEq.install + {lay : Layer} {left right : DeferredContext} + (heq : ResolverLayerViewEq lay left right) (position : Position) + (hposition : positionOtsLayer? position = some lay) (output : HashOutput) : + ResolverLayerViewEq lay + { left with values := left.values.install position output } + { right with values := right.values.install position output } := by + refine ⟨heq.1, ?_, heq.2.2⟩ + intro other hother + by_cases hsame : other = position + · subst other + simp [DeferredStructuralValues.install] + · simpa [DeferredStructuralValues.install, hsame] using + heq.2.1 other hother + +def ResolverLayerResolutionEq (lay : Layer) : + Option DeferredResolution → Option DeferredResolution → Prop + | none, none => True + | some left, some right => + left.output = right.output ∧ + ResolverLayerViewEq lay left.toDeferredContext right.toDeferredContext + | _, _ => False + +theorem relTriple_resolveDeferredPositionValue_of_resolverLayerViewEq + (lay : Layer) (position : Position) + (hposition : positionOtsLayer? position = some lay) + (left right : DeferredContext) (heq : ResolverLayerViewEq lay left right) : + RelTriple + (resolveDeferredPositionValue position left) + (resolveDeferredPositionValue position right) + (ResolverLayerResolutionEq lay) := by + have hcoordinate : coordinateOtsLayer? (.position position) = some lay := by + simpa [coordinateOtsLayer?] using hposition + have hstate := heq.1 (.position position) hcoordinate + unfold resolveDeferredPositionValue + dsimp only + cases hleftState : left.state.values (.position position) with + | some output => + have hrightState : right.state.values (.position position) = some output := by + rw [← hstate] + exact hleftState + simp only [hrightState] + have hhit := heq.hitAt_iff (.position position) hcoordinate output + by_cases hleftHit : left.state.hitAt (.position position) output + · rw [if_pos hleftHit, if_pos (hhit.mp hleftHit)] + exact relTriple_pure_pure trivial + · rw [if_neg hleftHit, if_neg (fun hrightHit => hleftHit (hhit.mpr hrightHit))] + apply relTriple_pure_pure + exact ⟨rfl, + (heq.clearPending (.position position) hcoordinate).install position hposition output⟩ + | none => + have hrightState : right.state.values (.position position) = none := by + rw [← hstate] + exact hleftState + simp only [hrightState] + have hvalue := heq.2.1 position hposition + cases hleftValue : left.values position with + | some output => + have hrightValue : right.values position = some output := by + rw [← hvalue] + exact hleftValue + simp only [hrightValue] + have hhit := heq.hitAt_iff (.position position) hcoordinate output + by_cases hleftHit : left.state.hitAt (.position position) output + · rw [if_pos hleftHit, if_pos (hhit.mp hleftHit)] + exact relTriple_pure_pure trivial + · rw [if_neg hleftHit, + if_neg (fun hrightHit => hleftHit (hhit.mpr hrightHit))] + apply relTriple_pure_pure + exact ⟨rfl, heq.clearPending (.position position) hcoordinate⟩ + | none => + have hrightValue : right.values position = none := by + rw [← hvalue] + exact hleftValue + simp only [hrightValue] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + have hhit := heq.hitAt_iff (.position position) hcoordinate leftOutput + by_cases hleftHit : left.state.hitAt (.position position) leftOutput + · rw [if_pos hleftHit, if_pos (hhit.mp hleftHit)] + exact relTriple_pure_pure trivial + · rw [if_neg hleftHit, + if_neg (fun hrightHit => hleftHit (hhit.mpr hrightHit))] + apply relTriple_pure_pure + exact ⟨rfl, + (heq.clearPending (.position position) hcoordinate).install position hposition + leftOutput⟩ + +theorem relTriple_resolveDeferredChainStart_of_resolverLayerViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (left right : DeferredContext) (heq : ResolverLayerViewEq lay left right) : + RelTriple + (pure (resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ left) : + ProbComp (Option DeferredResolution)) + (pure (resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ right) : + ProbComp (Option DeferredResolution)) + (ResolverLayerResolutionEq lay) := by + apply relTriple_pure_pure + have hcoordinate : coordinateOtsLayer? (.chainStart lay tree leafIdx chainIdx) = some lay := by + simp [coordinateOtsLayer?] + have hstate := heq.1 (.chainStart lay tree leafIdx chainIdx) hcoordinate + unfold resolveDeferredChainStart + dsimp only [OtsSecretIndex.coordinate] + cases hleftState : left.state.values (.chainStart lay tree leafIdx chainIdx) with + | some output => + have hrightState : + right.state.values (.chainStart lay tree leafIdx chainIdx) = some output := by + rw [← hstate] + exact hleftState + simp only [hrightState] + have hhit := heq.hitAt_iff (.chainStart lay tree leafIdx chainIdx) hcoordinate output + by_cases hleftHit : left.state.hitAt (.chainStart lay tree leafIdx chainIdx) output + · rw [if_pos hleftHit, if_pos (hhit.mp hleftHit)] + trivial + · rw [if_neg hleftHit, if_neg (fun hrightHit => hleftHit (hhit.mpr hrightHit))] + exact ⟨rfl, heq.clearPending (.chainStart lay tree leafIdx chainIdx) hcoordinate⟩ + | none => + have hrightState : + right.state.values (.chainStart lay tree leafIdx chainIdx) = none := by + rw [← hstate] + exact hleftState + simp only [hrightState] + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + have hhit := heq.hitAt_iff (.chainStart lay tree leafIdx chainIdx) hcoordinate output + by_cases hleftHit : left.state.hitAt (.chainStart lay tree leafIdx chainIdx) output + · rw [if_pos hleftHit, if_pos (hhit.mp hleftHit)] + trivial + · rw [if_neg hleftHit, if_neg (fun hrightHit => hleftHit (hhit.mpr hrightHit))] + exact ⟨rfl, heq.clearPending (.chainStart lay tree leafIdx chainIdx) hcoordinate⟩ + +theorem relTriple_resolveDeferredChainPrefix_of_resolverLayerViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps left right, + ResolverLayerViewEq lay left right → + RelTriple + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps left) + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps right) + (ResolverLayerResolutionEq lay) + | 0, hsteps, left, right, heq => by + simp only [resolveDeferredChainPrefix] + exact relTriple_resolveDeferredChainStart_of_resolverLayerViewEq table lay tree leafIdx + chainIdx left right heq + | steps + 1, hsteps, left, right, heq => by + rw [resolveDeferredChainPrefix, resolveDeferredChainPrefix] + apply relTriple_bind + (relTriple_resolveDeferredChainPrefix_of_resolverLayerViewEq table lay tree leafIdx + chainIdx steps (by omega) left right heq) + intro leftPrevious rightPrevious hprevious + cases leftPrevious with + | none => + cases rightPrevious <;> simp [ResolverLayerResolutionEq] at hprevious ⊢ + | some leftPrevious => + cases rightPrevious with + | none => simp [ResolverLayerResolutionEq] at hprevious + | some rightPrevious => + exact relTriple_resolveDeferredPositionValue_of_resolverLayerViewEq lay + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + (by simp [positionOtsLayer?]) leftPrevious.toDeferredContext + rightPrevious.toDeferredContext hprevious.2 + +def ResolverLayerContextOptionEq (lay : Layer) : + Option DeferredContext → Option DeferredContext → Prop + | none, none => True + | some left, some right => ResolverLayerViewEq lay left right + | _, _ => False + +theorem relTriple_resolveDeferredChains_of_resolverLayerViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ chains left right, + ResolverLayerViewEq lay left right → + RelTriple + (resolveDeferredChains table lay tree leafIdx chains left) + (resolveDeferredChains table lay tree leafIdx chains right) + (ResolverLayerContextOptionEq lay) + | [], left, right, heq => by + simp only [resolveDeferredChains] + exact relTriple_pure_pure heq + | chainIdx :: remaining, left, right, heq => by + rw [resolveDeferredChains, resolveDeferredChains] + apply relTriple_bind + (relTriple_resolveDeferredChainPrefix_of_resolverLayerViewEq table lay tree leafIdx + chainIdx (chainLength - 1) (by omega) left right heq) + intro leftResolved rightResolved hresolved + cases leftResolved with + | none => + cases rightResolved with + | none => + simpa [ResolverLayerContextOptionEq] using + (relTriple_pure_pure (R := ResolverLayerContextOptionEq lay) trivial) + | some rightResolved => simp [ResolverLayerResolutionEq] at hresolved + | some leftResolved => + cases rightResolved with + | none => simp [ResolverLayerResolutionEq] at hresolved + | some rightResolved => + exact relTriple_resolveDeferredChains_of_resolverLayerViewEq table lay tree + leafIdx remaining leftResolved.toDeferredContext + rightResolved.toDeferredContext hresolved.2 + +theorem relTriple_resolveDeferredOtsLeaf_of_resolverLayerViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (left right : DeferredContext) + (heq : ResolverLayerViewEq lay left right) : + RelTriple + (resolveDeferredOtsLeaf table lay tree leafIdx left) + (resolveDeferredOtsLeaf table lay tree leafIdx right) + (ResolverLayerResolutionEq lay) := by + rw [resolveDeferredOtsLeaf, resolveDeferredOtsLeaf] + apply relTriple_bind + (relTriple_resolveDeferredChains_of_resolverLayerViewEq table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) left right heq) + intro leftChains rightChains hchains + cases leftChains with + | none => + cases rightChains with + | none => + simpa [ResolverLayerResolutionEq] using + (relTriple_pure_pure (R := ResolverLayerResolutionEq lay) trivial) + | some rightChains => simp [ResolverLayerContextOptionEq] at hchains + | some leftChains => + cases rightChains with + | none => simp [ResolverLayerContextOptionEq] at hchains + | some rightChains => + exact relTriple_resolveDeferredPositionValue_of_resolverLayerViewEq lay + (.leaf lay tree leafIdx) (by simp [positionOtsLayer?]) leftChains rightChains hchains + +theorem relTriple_resolveDeferredTreeNode_of_resolverLayerViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel left right, + ResolverLayerViewEq lay left right → + RelTriple + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel left) + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel right) + (ResolverLayerResolutionEq lay) + | 0, nodeIdx, hlevel, left, right, heq => + relTriple_resolveDeferredOtsLeaf_of_resolverLayerViewEq table lay tree + (leafOfNat nodeIdx) left right heq + | level + 1, nodeIdx, hlevel, left, right, heq => by + rw [resolveDeferredTreeNode, resolveDeferredTreeNode] + apply relTriple_bind + (relTriple_resolveDeferredTreeNode_of_resolverLayerViewEq table lay tree level + (2 * nodeIdx) (by omega) left right heq) + intro leftNode rightNode hleftNode + cases leftNode with + | none => + cases rightNode <;> simp [ResolverLayerResolutionEq] at hleftNode ⊢ + | some leftNode => + cases rightNode with + | none => simp [ResolverLayerResolutionEq] at hleftNode + | some rightNode => + apply relTriple_bind + (relTriple_resolveDeferredTreeNode_of_resolverLayerViewEq table lay tree level + (2 * nodeIdx + 1) (by omega) leftNode.toDeferredContext + rightNode.toDeferredContext hleftNode.2) + intro leftSibling rightSibling hsibling + cases leftSibling with + | none => + cases rightSibling <;> simp [ResolverLayerResolutionEq] at hsibling ⊢ + | some leftSibling => + cases rightSibling with + | none => simp [ResolverLayerResolutionEq] at hsibling + | some rightSibling => + exact relTriple_resolveDeferredPositionValue_of_resolverLayerViewEq lay + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) + (by simp [positionOtsLayer?]) leftSibling.toDeferredContext + rightSibling.toDeferredContext hsibling.2 + +theorem relTriple_resolveDeferredPosition_of_resolverLayerViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (position : Position) + (hposition : positionOtsLayer? position = some lay) + (left right : DeferredContext) (heq : ResolverLayerViewEq lay left right) : + RelTriple + (resolveDeferredPosition table position left) + (resolveDeferredPosition table position right) + (ResolverLayerResolutionEq lay) := by + cases position with + | chain selectedLay tree leafIdx chainIdx step => + have hlay : selectedLay = lay := Option.some.inj hposition + subst selectedLay + exact relTriple_resolveDeferredChainPrefix_of_resolverLayerViewEq table lay tree leafIdx + chainIdx (step.val + 1) (by have := step.isLt; omega) left right heq + | leaf selectedLay tree leafIdx => + have hlay : selectedLay = lay := Option.some.inj hposition + subst selectedLay + exact relTriple_resolveDeferredOtsLeaf_of_resolverLayerViewEq table lay tree leafIdx + left right heq + | node selectedLay tree level nodeIdx => + have hlay : selectedLay = lay := Option.some.inj hposition + subst selectedLay + exact relTriple_resolveDeferredTreeNode_of_resolverLayerViewEq table lay tree + (level.val + 1) nodeIdx (by have := level.isLt; omega) left right heq + | ftsLeaf index tree leafIdx => simp [positionOtsLayer?] at hposition + | ftsNode index tree level nodeIdx => simp [positionOtsLayer?] at hposition + | ftsRoots index => simp [positionOtsLayer?] at hposition + +theorem relTriple_resolveDeferredReveal_of_resolverLayerViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (position : Position) + (hposition : positionOtsLayer? position = some lay) + (left right : DeferredContext) (heq : ResolverLayerViewEq lay left right) : + RelTriple + (resolveDeferredReveal table position left) + (resolveDeferredReveal table position right) + (ResolverLayerResolutionEq lay) := by + classical + unfold resolveDeferredReveal + by_cases hresolvable : ResolvableOtsPosition position + · rw [if_pos hresolvable, if_pos hresolvable] + exact relTriple_resolveDeferredPosition_of_resolverLayerViewEq table lay position hposition + left right heq + · rw [if_neg hresolvable, if_neg hresolvable] + exact relTriple_resolveDeferredPositionValue_of_resolverLayerViewEq lay position hposition + left right heq + +def ResolverLayerContextValueEq (lay : Layer) : + Option (DeferredContext × alpha) → Option (DeferredContext × alpha) → Prop + | none, none => True + | some left, some right => + left.2 = right.2 ∧ ResolverLayerViewEq lay left.1 right.1 + | _, _ => False + +theorem relTriple_resolveDeferredSelectedChainFamily_of_resolverLayerViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ {n : Nat} (family : Fin n → ChainIndex) + (digits : Fin n → Digit) (left right : DeferredContext), + ResolverLayerViewEq lay left right → + RelTriple + (resolveDeferredSelectedChainFamily table lay tree leafIdx family digits left) + (resolveDeferredSelectedChainFamily table lay tree leafIdx family digits right) + (ResolverLayerContextValueEq lay) + | 0, family, digits, left, right, heq => by + simp only [resolveDeferredSelectedChainFamily] + apply relTriple_pure_pure + exact ⟨rfl, heq⟩ + | n + 1, family, digits, left, right, heq => by + rw [resolveDeferredSelectedChainFamily, resolveDeferredSelectedChainFamily] + apply relTriple_bind + (relTriple_resolveDeferredChainPrefix_of_resolverLayerViewEq table lay tree leafIdx + (family 0) (digits 0).val (by have := (digits 0).isLt; omega) left right heq) + intro leftHead rightHead hhead + cases leftHead with + | none => + cases rightHead with + | none => + simpa [ResolverLayerContextValueEq] using + (relTriple_pure_pure (R := ResolverLayerContextValueEq lay) trivial) + | some rightHead => simp [ResolverLayerResolutionEq] at hhead + | some leftHead => + cases rightHead with + | none => simp [ResolverLayerResolutionEq] at hhead + | some rightHead => + apply relTriple_bind + (relTriple_resolveDeferredSelectedChainFamily_of_resolverLayerViewEq table lay + tree leafIdx (fun index : Fin n => family index.succ) + (fun index : Fin n => digits index.succ) leftHead.toDeferredContext + rightHead.toDeferredContext hhead.2) + intro leftTail rightTail htail + cases leftTail with + | none => + cases rightTail with + | none => + simpa [ResolverLayerContextValueEq] using + (relTriple_pure_pure (R := ResolverLayerContextValueEq lay) trivial) + | some rightTail => simp [ResolverLayerContextValueEq] at htail + | some leftTail => + cases rightTail with + | none => simp [ResolverLayerContextValueEq] at htail + | some rightTail => + apply relTriple_pure_pure + refine ⟨?_, htail.2⟩ + funext position + refine Fin.cases ?_ (fun tailPosition => ?_) position + · simpa using congrArg truncateHash hhead.1 + · exact congrFun htail.1 tailPosition + +theorem relTriple_resolveDeferredLayerPathFamily_of_resolverLayerViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ {n : Nat} (family : Fin n → Fin maxLayerHeight) + (left right : DeferredContext), + ResolverLayerViewEq lay left right → + RelTriple + (resolveDeferredLayerPathFamily table lay tree leafIdx family left) + (resolveDeferredLayerPathFamily table lay tree leafIdx family right) + (ResolverLayerContextValueEq lay) + | 0, family, left, right, heq => by + simp only [resolveDeferredLayerPathFamily] + apply relTriple_pure_pure + exact ⟨rfl, heq⟩ + | n + 1, family, left, right, heq => by + rw [resolveDeferredLayerPathFamily, resolveDeferredLayerPathFamily] + by_cases hinLayer : (family 0).val < layerHeight lay + · simp only [hinLayer, ↓reduceDIte] + apply relTriple_bind + (relTriple_resolveDeferredTreeNode_of_resolverLayerViewEq table lay tree + (family 0).val (Nat.xor (leafIdx.val / 2 ^ (family 0).val) 1) + (by have := (family 0).isLt; omega) left right heq) + intro leftHead rightHead hhead + cases leftHead with + | none => + cases rightHead with + | none => + simpa [ResolverLayerContextValueEq] using + (relTriple_pure_pure (R := ResolverLayerContextValueEq lay) trivial) + | some rightHead => simp [ResolverLayerResolutionEq] at hhead + | some leftHead => + cases rightHead with + | none => simp [ResolverLayerResolutionEq] at hhead + | some rightHead => + apply relTriple_bind + (relTriple_resolveDeferredLayerPathFamily_of_resolverLayerViewEq table lay tree + leafIdx (fun position : Fin n => family position.succ) + leftHead.toDeferredContext rightHead.toDeferredContext hhead.2) + intro leftTail rightTail htail + cases leftTail with + | none => + cases rightTail with + | none => + simpa [ResolverLayerContextValueEq] using + (relTriple_pure_pure (R := ResolverLayerContextValueEq lay) trivial) + | some rightTail => simp [ResolverLayerContextValueEq] at htail + | some leftTail => + cases rightTail with + | none => simp [ResolverLayerContextValueEq] at htail + | some rightTail => + apply relTriple_pure_pure + refine ⟨?_, htail.2⟩ + funext position + refine Fin.cases ?_ (fun tailPosition => ?_) position + · simpa using congrArg truncateHash hhead.1 + · exact congrFun htail.1 tailPosition + · simp only [hinLayer, ↓reduceDIte] + apply relTriple_bind + (relTriple_resolveDeferredLayerPathFamily_of_resolverLayerViewEq table lay tree leafIdx + (fun position : Fin n => family position.succ) left right heq) + intro leftTail rightTail htail + cases leftTail with + | none => + cases rightTail with + | none => + simpa [ResolverLayerContextValueEq] using + (relTriple_pure_pure (R := ResolverLayerContextValueEq lay) trivial) + | some rightTail => simp [ResolverLayerContextValueEq] at htail + | some leftTail => + cases rightTail with + | none => simp [ResolverLayerContextValueEq] at htail + | some rightTail => + apply relTriple_pure_pure + refine ⟨?_, htail.2⟩ + funext position + refine Fin.cases rfl (fun tailPosition => ?_) position + exact congrFun htail.1 tailPosition + +theorem relTriple_resolveDeferredLayerValues_of_resolverLayerViewEq + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) (left right : DeferredContext) + (heq : ResolverLayerViewEq lay left right) : + RelTriple + (resolveDeferredLayerValues table index lay encoding left) + (resolveDeferredLayerValues table index lay encoding right) + (ResolverLayerContextValueEq lay) := by + rw [resolveDeferredLayerValues, resolveDeferredLayerValues] + apply relTriple_bind + (relTriple_resolveDeferredSelectedChainFamily_of_resolverLayerViewEq table lay + (treeIndexAt index lay) (leafIndexAt index lay) + (fun chainIdx : ChainIndex => chainIdx) encoding left right heq) + intro leftChains rightChains hchains + cases leftChains with + | none => + cases rightChains with + | none => + simpa [ResolverLayerContextValueEq] using + (relTriple_pure_pure (R := ResolverLayerContextValueEq lay) trivial) + | some rightChains => simp [ResolverLayerContextValueEq] at hchains + | some leftChains => + cases rightChains with + | none => simp [ResolverLayerContextValueEq] at hchains + | some rightChains => + apply relTriple_bind + (relTriple_resolveDeferredLayerPathFamily_of_resolverLayerViewEq table lay + (treeIndexAt index lay) (leafIndexAt index lay) + (fun level : Fin maxLayerHeight => level) leftChains.1 rightChains.1 hchains.2) + intro leftPath rightPath hpath + cases leftPath with + | none => + cases rightPath with + | none => + simpa [ResolverLayerContextValueEq] using + (relTriple_pure_pure (R := ResolverLayerContextValueEq lay) trivial) + | some rightPath => simp [ResolverLayerContextValueEq] at hpath + | some leftPath => + cases rightPath with + | none => simp [ResolverLayerContextValueEq] at hpath + | some rightPath => + apply relTriple_pure_pure + exact ⟨by rw [hchains.1, hpath.1], hpath.2⟩ + +theorem resolveDeferredPosition_preserves_other_layer_value + (table : OtsSecretIndex → HashOutput) (resolvedLay : Layer) + (position : Position) (hposition : positionOtsLayer? position = some resolvedLay) + (context : DeferredContext) (result : DeferredResolution) (other : Position) + (hother : positionOtsLayer? other ≠ some resolvedLay) + (hresult : some result ∈ support (resolveDeferredPosition table position context)) : + result.values other = context.values other := by + cases position with + | chain lay tree leafIdx chainIdx step => + have hlay : lay = resolvedLay := Option.some.inj hposition + subst lay + exact resolveDeferredChainPrefix_preserves_other_layer_value table resolvedLay tree + leafIdx chainIdx (step.val + 1) (by have := step.isLt; omega) context result other + hother (by simpa [resolveDeferredPosition] using hresult) + | leaf lay tree leafIdx => + have hlay : lay = resolvedLay := Option.some.inj hposition + subst lay + exact resolveDeferredOtsLeaf_preserves_other_layer_value table resolvedLay tree leafIdx + context result other hother (by simpa [resolveDeferredPosition] using hresult) + | node lay tree level nodeIdx => + have hlay : lay = resolvedLay := Option.some.inj hposition + subst lay + exact resolveDeferredTreeNode_preserves_other_layer_value table resolvedLay tree + (level.val + 1) nodeIdx (by have := level.isLt; omega) context result other hother + (by simpa [resolveDeferredPosition] using hresult) + | ftsLeaf index tree leafIdx => simp [positionOtsLayer?] at hposition + | ftsNode index tree level nodeIdx => simp [positionOtsLayer?] at hposition + | ftsRoots index => simp [positionOtsLayer?] at hposition + +theorem resolveDeferredReveal_preserves_other_layer_value + (table : OtsSecretIndex → HashOutput) (resolvedLay : Layer) + (position : Position) (hposition : positionOtsLayer? position = some resolvedLay) + (context : DeferredContext) (result : DeferredResolution) (other : Position) + (hother : positionOtsLayer? other ≠ some resolvedLay) + (hresult : some result ∈ support (resolveDeferredReveal table position context)) : + result.values other = context.values other := by + classical + by_cases hresolvable : ResolvableOtsPosition position + · exact resolveDeferredPosition_preserves_other_layer_value table resolvedLay position + hposition context result other hother + (by simpa [resolveDeferredReveal, hresolvable] using hresult) + · have hdirect : some result ∈ support (resolveDeferredPositionValue position context) := by + simpa [resolveDeferredReveal, hresolvable] using hresult + apply resolveDeferredPositionValue_preserves_other position other context result + · intro heq + subst other + exact hother hposition + · exact hdirect + +def ResolverLayerViewPreserving (lay : Layer) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ context fuel table cache result, + some result ∈ support + (runResolvedFromTable context fuel table (computation.run cache)) → + ResolverLayerViewEq lay result.context context + +theorem resolverLayerViewPreserving_pure (lay : Layer) (value : alpha) : + ResolverLayerViewPreserving lay + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro context fuel table cache result hresult + simp [runResolvedFromTable] at hresult + subst result + exact ResolverLayerViewEq.refl lay context + +theorem ResolverLayerViewPreserving.bind {lay : Layer} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : ResolverLayerViewPreserving lay left) + (hnext : ∀ value, ResolverLayerViewPreserving lay (next value)) : + ResolverLayerViewPreserving lay (left >>= next) := by + intro context fuel table cache result hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨middleOption, hmiddle, hrest⟩ := hresult + cases middleOption with + | none => simp at hrest + | some middle => + exact (hnext middle.value.1 middle.context middle.remaining middle.table middle.value.2 + result hrest).trans (hleft context fuel table cache middle hmiddle) + +theorem resolverLayerViewPreserving_ensureCoordinate + (lay : Layer) (coordinate : Coordinate) : + ResolverLayerViewPreserving lay (ensureCoordinate coordinate) := by + intro context fuel table cache result hresult + unfold ensureCoordinate at hresult + rw [StateT.run_liftM, LazyRevealProbe.ensureQuery, + runResolvedFromTable_ensure_query_bind] at hresult + simp [runResolvedFromTable] at hresult + subst result + exact ResolverLayerViewEq.refl lay context + +theorem resolverLayerViewPreserving_splitHashQuery_ordinary + (lay : Layer) (input : HashInput) : + ResolverLayerViewPreserving lay (splitHashQuery (.ordinary input)) := by + intro context fuel table cache result hresult + rw [splitHashQuery_run_eq] at hresult + cases hlookup : cache (.ordinary input) with + | some output => + simp only [hlookup] at hresult + simp [runResolvedFromTable] at hresult + subst result + exact ResolverLayerViewEq.refl lay context + | none => + simp only [hlookup] at hresult + rw [LazyRevealProbe.hashOutputQuery, runResolvedFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hreturn⟩ := hresult + simp [runResolvedFromTable] at hreturn + subst result + exact ResolverLayerViewEq.refl lay context + +theorem resolverLayerViewPreserving_ordinaryHashImpl (lay : Layer) (input : HashInput) : + ResolverLayerViewPreserving lay (ordinaryHashImpl input) := + resolverLayerViewPreserving_splitHashQuery_ordinary lay input + +theorem resolverLayerViewPreserving_sequenceFin {lay : Layer} {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hcomponent : ∀ position, ResolverLayerViewPreserving lay (computation position)) : + ResolverLayerViewPreserving lay (sequenceFin computation) := by + induction n with + | zero => + simpa [sequenceFin] using + (resolverLayerViewPreserving_pure lay Fin.elim0 : + ResolverLayerViewPreserving lay + (pure Fin.elim0 : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Fin 0 → alpha))) + | succ n ih => + rw [sequenceFin] + exact (hcomponent 0).bind fun _ => + (ih (fun position : Fin n => computation position.succ) + (fun position => hcomponent position.succ)).bind fun _ => + resolverLayerViewPreserving_pure lay _ + +theorem resolverLayerViewPreserving_simulateQ {spec : OracleSpec ι} + (lay : Layer) + (impl : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))) + (hquery : ∀ query, ResolverLayerViewPreserving lay (impl query)) + (computation : OracleComp spec alpha) : + ResolverLayerViewPreserving lay (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp only [simulateQ_pure] + exact resolverLayerViewPreserving_pure lay value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (hquery query).bind fun output => ih output + +theorem resolverLayerViewPreserving_revealPosition_of_ne + (preservedLay revealedLay : Layer) (hne : preservedLay ≠ revealedLay) + (position : Position) (hposition : positionOtsLayer? position = some revealedLay) : + ResolverLayerViewPreserving preservedLay (revealPosition position) := by + intro context fuel table cache result hresult + rw [runResolvedFromTable_revealPosition, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hreturn⟩ := hresult + cases resolvedOption with + | none => simp at hreturn + | some resolved => + simp [runResolvedFromTable] at hreturn + subst result + refine ⟨?_, ?_, ?_⟩ + · intro coordinate hcoordinate + have hcoordinateNe : coordinate ≠ .position position := by + intro heq + subst coordinate + have hcoordinate' : positionOtsLayer? position = some preservedLay := by + simpa [coordinateOtsLayer?] using hcoordinate + have hlayers : revealedLay = preservedLay := by + apply Option.some.inj + rw [← hposition, ← hcoordinate'] + exact hne hlayers.symm + simp [LazyRevealProbe.State.materialize, Function.update_of_ne hcoordinateNe] + · intro other hother + apply resolveDeferredReveal_preserves_other_layer_value table revealedLay position + hposition context resolved other + · intro hlayer + have : preservedLay = revealedLay := by + apply Option.some.inj + rw [← hother, hlayer] + exact hne this + · exact hresolved + · intro coordinate hcoordinate + have hcoordinateNe : coordinate ≠ .position position := by + intro heq + subst coordinate + have hcoordinate' : positionOtsLayer? position = some preservedLay := by + simpa [coordinateOtsLayer?] using hcoordinate + have hlayers : revealedLay = preservedLay := by + apply Option.some.inj + rw [← hposition, ← hcoordinate'] + exact hne hlayers.symm + change (context.state.clearPending (.position position)).pendingAt coordinate = + context.state.pendingAt coordinate + exact pendingAt_clearPending_of_ne context.state (.position position) coordinate + hcoordinateNe + +theorem resolverLayerViewPreserving_ensureFullChain + (preservedLay lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) : + ResolverLayerViewPreserving preservedLay (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (resolverLayerViewPreserving_sequenceFin + (fun step : ChainStep => + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step))) + (fun step => resolverLayerViewPreserving_ensureCoordinate preservedLay + (.position (.chain lay tree leafIdx chainIdx step)))).bind fun _ => + resolverLayerViewPreserving_pure preservedLay () + +theorem resolverLayerViewPreserving_ensureOtsLeaf + (preservedLay lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ResolverLayerViewPreserving preservedLay (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (resolverLayerViewPreserving_sequenceFin + (fun chainIdx : ChainIndex => ensureFullChain lay tree leafIdx chainIdx) + (fun chainIdx => resolverLayerViewPreserving_ensureFullChain preservedLay lay tree leafIdx + chainIdx)).bind fun _ => + resolverLayerViewPreserving_ensureCoordinate preservedLay + (.position (.leaf lay tree leafIdx)) + +theorem resolverLayerViewPreserving_ensureTreeNode + (preservedLay lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, + ResolverLayerViewPreserving preservedLay (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => + resolverLayerViewPreserving_ensureOtsLeaf preservedLay lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (resolverLayerViewPreserving_ensureTreeNode preservedLay lay tree level + (2 * nodeIdx)).bind fun _ => + (resolverLayerViewPreserving_ensureTreeNode preservedLay lay tree level + (2 * nodeIdx + 1)).bind fun _ => by + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact resolverLayerViewPreserving_ensureCoordinate preservedLay + (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact resolverLayerViewPreserving_pure preservedLay () + +theorem resolverLayerViewPreserving_maskedTreeNode_of_ne + (preservedLay lay : Layer) (hne : preservedLay ≠ lay) + (tree : TreeIndex) (level nodeIdx : Nat) : + ResolverLayerViewPreserving preservedLay (maskedTreeNode lay tree level nodeIdx) := by + unfold maskedTreeNode + apply (resolverLayerViewPreserving_ensureTreeNode preservedLay lay tree level nodeIdx).bind + intro _ + cases level with + | zero => + exact resolverLayerViewPreserving_revealPosition_of_ne preservedLay lay hne + (.leaf lay tree (leafOfNat nodeIdx)) (by simp [positionOtsLayer?]) + | succ current => + by_cases hlevel : current < maxLayerHeight + · simp only [hlevel, ↓reduceDIte] + exact resolverLayerViewPreserving_revealPosition_of_ne preservedLay lay hne + (.node lay tree ⟨current, hlevel⟩ (leafOfNat nodeIdx)) + (by simp [positionOtsLayer?]) + · simp [hlevel] + exact resolverLayerViewPreserving_pure preservedLay 0 + +theorem resolverLayerViewPreserving_maskedTreeRoot_of_ne + (preservedLay lay : Layer) (hne : preservedLay ≠ lay) (tree : TreeIndex) : + ResolverLayerViewPreserving preservedLay (maskedTreeRoot lay tree) := by + unfold maskedTreeRoot + exact resolverLayerViewPreserving_maskedTreeNode_of_ne preservedLay lay hne tree + (layerHeight lay) 0 + +theorem resolverLayerViewPreserving_ensureChainPrefix + (preservedLay lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) : + ResolverLayerViewPreserving preservedLay + (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (resolverLayerViewPreserving_sequenceFin + (fun step : ChainStep => + if step.val < digit.val then + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + else pure ()) + (fun step => by + by_cases hstep : step.val < digit.val + · rw [if_pos hstep] + exact resolverLayerViewPreserving_ensureCoordinate preservedLay + (.position (.chain lay tree leafIdx chainIdx step)) + · rw [if_neg hstep] + exact resolverLayerViewPreserving_pure preservedLay ())).bind fun _ => + resolverLayerViewPreserving_pure preservedLay () + +theorem resolverLayerViewPreserving_ensureTreePath + (preservedLay lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ResolverLayerViewPreserving preservedLay (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (resolverLayerViewPreserving_sequenceFin + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + ensureTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + else pure ()) + (fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + exact resolverLayerViewPreserving_ensureTreeNode preservedLay lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · rw [if_neg hlevel] + exact resolverLayerViewPreserving_pure preservedLay ())).bind fun _ => + resolverLayerViewPreserving_pure preservedLay () + +theorem resolverLayerViewPreserving_maskedOtsSignFrom + (preservedLay lay : Layer) (parameter : PublicParameter) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : ∀ attempts counter, + ResolverLayerViewPreserving preservedLay + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom] + exact resolverLayerViewPreserving_pure preservedLay none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + have hencoded := resolverLayerViewPreserving_simulateQ preservedLay ordinaryHashImpl + (resolverLayerViewPreserving_ordinaryHashImpl preservedLay) + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter)) + apply hencoded.bind + intro encoded + cases encoded with + | none => + exact resolverLayerViewPreserving_maskedOtsSignFrom preservedLay lay parameter tree + leafIdx message attempts (counter + 1) + | some encoding => + apply (resolverLayerViewPreserving_sequenceFin + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx + (encoding chainIdx)) + (fun chainIdx => resolverLayerViewPreserving_ensureChainPrefix preservedLay lay tree + leafIdx chainIdx (encoding chainIdx))).bind + intro _ + exact resolverLayerViewPreserving_pure preservedLay + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem resolverLayerViewPreserving_maskedOtsSign + (preservedLay lay : Layer) (parameter : PublicParameter) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : + ResolverLayerViewPreserving preservedLay + (maskedOtsSign parameter lay tree leafIdx message) := by + exact resolverLayerViewPreserving_maskedOtsSignFrom preservedLay lay parameter tree leafIdx + message encodingAttemptLimit 0 + +theorem resolverLayerViewPreserving_maskedLayerMessage_of_below + (preservedLay : Layer) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (hbelow : lay.val + 1 < numLayers) + (hne : preservedLay ≠ ⟨lay.val + 1, hbelow⟩) : + ResolverLayerViewPreserving preservedLay + (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + rw [dif_pos hbelow] + exact resolverLayerViewPreserving_maskedTreeRoot_of_ne preservedLay + ⟨lay.val + 1, hbelow⟩ hne (treeIndexAt index ⟨lay.val + 1, hbelow⟩) + +theorem resolverLayerViewPreserving_maskedLayerMessage_of_not_below + (preservedLay : Layer) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (hbelow : ¬lay.val + 1 < numLayers) : + ResolverLayerViewPreserving preservedLay + (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + rw [dif_neg hbelow] + exact resolverLayerViewPreserving_simulateQ preservedLay ordinaryHashImpl + (resolverLayerViewPreserving_ordinaryHashImpl preservedLay) + (ftsKey parameter index (ftsSecret index)) + +theorem resolverLayerViewPreserving_maskedSignLayer_of_below + (preservedLay : Layer) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (hbelow : lay.val + 1 < numLayers) + (hne : preservedLay ≠ ⟨lay.val + 1, hbelow⟩) : + ResolverLayerViewPreserving preservedLay + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + apply (resolverLayerViewPreserving_maskedLayerMessage_of_below preservedLay parameter + ftsSecret index lay hbelow hne).bind + intro message + apply (resolverLayerViewPreserving_maskedOtsSign preservedLay lay parameter + (treeIndexAt index lay) (leafIndexAt index lay) message).bind + intro selected + cases selected with + | none => exact resolverLayerViewPreserving_pure preservedLay none + | some selected => + apply (resolverLayerViewPreserving_ensureTreePath preservedLay lay + (treeIndexAt index lay) (leafIndexAt index lay)).bind + intro _ + exact resolverLayerViewPreserving_pure preservedLay (some selected) + +theorem resolverLayerViewPreserving_maskedSignLayer_of_not_below + (preservedLay : Layer) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (hbelow : ¬lay.val + 1 < numLayers) : + ResolverLayerViewPreserving preservedLay + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + apply (resolverLayerViewPreserving_maskedLayerMessage_of_not_below preservedLay parameter + ftsSecret index lay hbelow).bind + intro message + apply (resolverLayerViewPreserving_maskedOtsSign preservedLay lay parameter + (treeIndexAt index lay) (leafIndexAt index lay) message).bind + intro selected + cases selected with + | none => exact resolverLayerViewPreserving_pure preservedLay none + | some selected => + apply (resolverLayerViewPreserving_ensureTreePath preservedLay lay + (treeIndexAt index lay) (leafIndexAt index lay)).bind + intro _ + exact resolverLayerViewPreserving_pure preservedLay (some selected) + +theorem resolverLayerViewPreserving_maskedSignLayer_of_lt + (preservedLay lay : Layer) (hlt : preservedLay.val < lay.val) + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) : + ResolverLayerViewPreserving preservedLay + (maskedSignLayer parameter ftsSecret index lay) := by + by_cases hbelow : lay.val + 1 < numLayers + · apply resolverLayerViewPreserving_maskedSignLayer_of_below preservedLay parameter + ftsSecret index lay hbelow + intro heq + have hval := congrArg Fin.val heq + simp only at hval + omega + · exact resolverLayerViewPreserving_maskedSignLayer_of_not_below preservedLay parameter + ftsSecret index lay hbelow + +abbrev DeferredLayerValues := + (ChainIndex → Digest) × (Fin maxLayerHeight → Digest) + +abbrev DeferredLayerSelection := + Option (Counter × (ChainIndex → Digit)) × SplitHashCache + +structure IndependentLayerScheduleResult where + resolution : DeferredContext × DeferredLayerValues + selection : ResolvedRunResult DeferredLayerSelection + +noncomputable def independentResolveThenSelectLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (encoding : ChainIndex → Digit) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + ProbComp (Option IndependentLayerScheduleResult) := do + let resolution ← resolveDeferredLayerValues table index resolvedLay encoding context + match resolution with + | none => pure none + | some resolution => do + let selection ← runResolvedFromTable context fuel table + ((maskedSignLayer parameter ftsSecret index selectedLay).run cache) + match selection with + | none => pure none + | some selection => pure (some ⟨resolution, selection⟩) + +noncomputable def independentSelectThenResolveLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (encoding : ChainIndex → Digit) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + ProbComp (Option IndependentLayerScheduleResult) := do + let selection ← runResolvedFromTable context fuel table + ((maskedSignLayer parameter ftsSecret index selectedLay).run cache) + match selection with + | none => pure none + | some selection => do + let resolution ← resolveDeferredLayerValues table index resolvedLay encoding context + match resolution with + | none => pure none + | some resolution => pure (some ⟨resolution, selection⟩) + +theorem evalDist_independentResolveThenSelectLayer_eq_selectThenResolve + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (encoding : ChainIndex → Digit) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + evalDist (independentResolveThenSelectLayer parameter table ftsSecret index resolvedLay + selectedLay encoding context fuel cache) = + evalDist (independentSelectThenResolveLayer parameter table ftsSecret index resolvedLay + selectedLay encoding context fuel cache) := by + let resolution := resolveDeferredLayerValues table index resolvedLay encoding context + let selection := runResolvedFromTable context fuel table + ((maskedSignLayer parameter ftsSecret index selectedLay).run cache) + let combine := fun + (resolved : Option (DeferredContext × DeferredLayerValues)) + (selected : Option (ResolvedRunResult DeferredLayerSelection)) => + match resolved, selected with + | some resolved, some selected => + (some ⟨resolved, selected⟩ : Option IndependentLayerScheduleResult) + | _, _ => none + have hresolveFirst : + evalDist (independentResolveThenSelectLayer parameter table ftsSecret index resolvedLay + selectedLay encoding context fuel cache) = + evalDist (resolution >>= fun resolved => + selection >>= fun selected => pure (combine resolved selected)) := by + unfold independentResolveThenSelectLayer + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro resolved + cases resolved with + | none => + simpa [combine] using + (OracleComp.DeferredSampling.evalDist_bind_const_neverFails selection + (by simp) (pure none)).symm + | some resolved => + apply congrArg evalDist + apply bind_congr + intro selected + cases selected <;> rfl + have hselectFirst : + evalDist (independentSelectThenResolveLayer parameter table ftsSecret index resolvedLay + selectedLay encoding context fuel cache) = + evalDist (selection >>= fun selected => + resolution >>= fun resolved => pure (combine resolved selected)) := by + unfold independentSelectThenResolveLayer + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro selected + cases selected with + | none => + simpa [combine] using + (OracleComp.DeferredSampling.evalDist_bind_const_neverFails resolution + (by simp) (pure none)).symm + | some selected => + apply congrArg evalDist + apply bind_congr + intro resolved + cases resolved <;> rfl + calc + _ = evalDist (resolution >>= fun resolved => + selection >>= fun selected => pure (combine resolved selected)) := hresolveFirst + _ = evalDist (selection >>= fun selected => + resolution >>= fun resolved => pure (combine resolved selected)) := + OracleComp.DeferredSampling.evalDist_bind_comm resolution selection + (fun resolved selected => pure (combine resolved selected)) + _ = _ := hselectFirst.symm + +noncomputable def resolveThenSelectLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (encoding : ChainIndex → Digit) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + ProbComp (Option (ResolvedRunResult + (DeferredLayerValues × DeferredLayerSelection))) := do + let resolution ← resolveDeferredLayerValues table index resolvedLay encoding context + match resolution with + | none => pure none + | some (resolvedContext, values) => do + let selection ← runResolvedFromTable resolvedContext fuel table + ((maskedSignLayer parameter ftsSecret index selectedLay).run cache) + match selection with + | none => pure none + | some selection => pure (some ⟨selection.context, selection.remaining, + (values, selection.value), selection.table⟩) + +noncomputable def selectThenResolveLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (encoding : ChainIndex → Digit) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + ProbComp (Option (ResolvedRunResult + (DeferredLayerValues × DeferredLayerSelection))) := do + let selection ← runResolvedFromTable context fuel table + ((maskedSignLayer parameter ftsSecret index selectedLay).run cache) + match selection with + | none => pure none + | some selection => do + let resolution ← resolveDeferredLayerValues table index resolvedLay encoding + selection.context + match resolution with + | none => pure none + | some (resolvedContext, values) => pure (some ⟨resolvedContext, + selection.remaining, (values, selection.value), selection.table⟩) + +def otsDeferredValues (context : DeferredContext) (lay : Layer) + (position : Position) : Option HashOutput := + if positionOtsLayer? position = some lay then context.values position else none + +def otsPendingAt (context : DeferredContext) (lay : Layer) + (coordinate : Coordinate) : Finset Digest := + if coordinateOtsLayer? coordinate = some lay then + context.state.pendingAt coordinate + else ∅ + +theorem LayerViewEq.otsDeferredValues_eq {lay : Layer} + {left right : DeferredContext} (heq : LayerViewEq lay left right) : + otsDeferredValues left lay = otsDeferredValues right lay := by + funext position + unfold otsDeferredValues + by_cases hposition : positionOtsLayer? position = some lay + · rw [if_pos hposition, if_pos hposition] + exact heq.2.2.2.1 position hposition + · rw [if_neg hposition, if_neg hposition] + +theorem LayerViewEq.otsPendingAt_eq {lay : Layer} + {left right : DeferredContext} (heq : LayerViewEq lay left right) : + otsPendingAt left lay = otsPendingAt right lay := by + funext coordinate + unfold otsPendingAt + by_cases hcoordinate : coordinateOtsLayer? coordinate = some lay + · rw [if_pos hcoordinate, if_pos hcoordinate] + exact heq.2.2.2.2 coordinate hcoordinate + · rw [if_neg hcoordinate, if_neg hcoordinate] + +theorem ResolverLayerViewEq.otsDeferredValues_eq {lay : Layer} + {left right : DeferredContext} (heq : ResolverLayerViewEq lay left right) : + otsDeferredValues left lay = otsDeferredValues right lay := by + funext position + unfold otsDeferredValues + by_cases hposition : positionOtsLayer? position = some lay + · rw [if_pos hposition, if_pos hposition] + exact heq.2.1 position hposition + · rw [if_neg hposition, if_neg hposition] + +theorem ResolverLayerViewEq.otsPendingAt_eq {lay : Layer} + {left right : DeferredContext} (heq : ResolverLayerViewEq lay left right) : + otsPendingAt left lay = otsPendingAt right lay := by + funext coordinate + unfold otsPendingAt + by_cases hcoordinate : coordinateOtsLayer? coordinate = some lay + · rw [if_pos hcoordinate, if_pos hcoordinate] + exact heq.2.2 coordinate hcoordinate + · rw [if_neg hcoordinate, if_neg hcoordinate] + +structure OtsContextView where + values : Coordinate → Option HashOutput + revealed : Finset Coordinate + ensured : Finset Coordinate + deferredValues : Layer → Position → Option HashOutput + pendingAt : Layer → Coordinate → Finset Digest + +theorem OtsContextView.ext {left right : OtsContextView} + (hvalues : left.values = right.values) + (hrevealed : left.revealed = right.revealed) + (hensured : left.ensured = right.ensured) + (hdeferred : left.deferredValues = right.deferredValues) + (hpending : left.pendingAt = right.pendingAt) : left = right := by + cases left + cases right + simp_all + +def otsContextView (context : DeferredContext) : OtsContextView where + values := context.state.values + revealed := context.state.revealed + ensured := context.state.ensured + deferredValues := otsDeferredValues context + pendingAt := otsPendingAt context + +def independentLayerContextView (resolvedLay observedLay : Layer) + (base : DeferredContext) (result : IndependentLayerScheduleResult) : OtsContextView where + values := result.selection.context.state.values + revealed := result.selection.context.state.revealed + ensured := result.selection.context.state.ensured + deferredValues := fun lay => + if lay = resolvedLay then otsDeferredValues result.resolution.1 lay + else if lay = observedLay then otsDeferredValues result.selection.context lay + else otsDeferredValues base lay + pendingAt := fun lay => + if lay = resolvedLay then otsPendingAt result.resolution.1 lay + else if lay = observedLay then otsPendingAt result.selection.context lay + else otsPendingAt base lay + +structure LayerScheduleView where + context : OtsContextView + remaining : Nat + resolution : DeferredLayerValues + selection : DeferredLayerSelection + table : OtsSecretIndex → HashOutput + +theorem LayerScheduleView.ext {left right : LayerScheduleView} + (hcontext : left.context = right.context) + (hremaining : left.remaining = right.remaining) + (hresolution : left.resolution = right.resolution) + (hselection : left.selection = right.selection) + (htable : left.table = right.table) : left = right := by + cases left + cases right + simp_all + +def resolvedLayerScheduleView : + Option (ResolvedRunResult (DeferredLayerValues × DeferredLayerSelection)) → + Option LayerScheduleView + | none => none + | some result => some ⟨otsContextView result.context, result.remaining, + result.value.1, result.value.2, result.table⟩ + +def independentLayerScheduleView (resolvedLay observedLay : Layer) + (base : DeferredContext) : + Option IndependentLayerScheduleResult → Option LayerScheduleView + | none => none + | some result => some ⟨independentLayerContextView resolvedLay observedLay base result, + result.selection.remaining, result.resolution.2, result.selection.value, + result.selection.table⟩ + +theorem privateStateAgrees_resolveDeferredLayerValues + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) (context finalContext : DeferredContext) + (values : (ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) + (hresult : some (finalContext, values) ∈ support + (resolveDeferredLayerValues table index lay encoding context)) : + PrivateStateAgrees finalContext context := by + rw [resolveDeferredLayerValues, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + rcases chains with ⟨afterChains, chainValues⟩ + rw [mem_support_bind_iff] at hrest + obtain ⟨pathOption, hpath, hreturn⟩ := hrest + cases pathOption with + | none => simp at hreturn + | some path => + rcases path with ⟨afterPath, pathValues⟩ + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have hcontext : finalContext = afterPath := + congrArg Prod.fst (Option.some.inj hreturn) + rw [hcontext] + have hchainState := privateStateAgrees_resolveDeferredSelectedChainFamily table lay + (treeIndexAt index lay) (leafIndexAt index lay) + (fun chainIdx : ChainIndex => chainIdx) encoding context afterChains chainValues hchains + have hpathState := privateStateAgrees_resolveDeferredLayerPathFamily table lay + (treeIndexAt index lay) (leafIndexAt index lay) + (fun level : Fin maxLayerHeight => level) afterChains afterPath pathValues hpath + exact ⟨hpathState.1.trans hchainState.1, + hpathState.2.1.trans hchainState.2.1, + hpathState.2.2.trans hchainState.2.2⟩ + +theorem layerViewEq_resolveDeferredLayerValues_of_ne + (table : OtsSecretIndex → HashOutput) (index : Index) + (resolvedLay observedLay : Layer) (hne : observedLay ≠ resolvedLay) + (encoding : ChainIndex → Digit) (context finalContext : DeferredContext) + (values : (ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) + (hresult : some (finalContext, values) ∈ support + (resolveDeferredLayerValues table index resolvedLay encoding context)) : + LayerViewEq observedLay finalContext context := by + have hprivate := privateStateAgrees_resolveDeferredLayerValues table index resolvedLay + encoding context finalContext values hresult + refine ⟨hprivate.1, hprivate.2.1, hprivate.2.2, ?_, ?_⟩ + · intro position hposition + apply resolveDeferredLayerValues_preserves_other_layer_value table index resolvedLay + encoding context finalContext values position + · intro heq + rw [hposition] at heq + exact hne (Option.some.inj heq) + · exact hresult + · intro coordinate hcoordinate + apply resolveDeferredLayerValues_preserves_other_layer_pendingAt table index resolvedLay + encoding context finalContext values coordinate + · intro heq + rw [hcoordinate] at heq + exact hne (Option.some.inj heq) + · exact hresult + +theorem relTriple_resolveThenSelectLayer_independent_of_below + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (encoding : ChainIndex → Digit) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hbelow : selectedLay.val + 1 < numLayers) + (hne : resolvedLay ≠ ⟨selectedLay.val + 1, hbelow⟩) : + RelTriple + (resolveThenSelectLayer parameter table ftsSecret index resolvedLay selectedLay encoding + context fuel cache) + (independentResolveThenSelectLayer parameter table ftsSecret index resolvedLay selectedLay + encoding context fuel cache) + (fun actual independent => resolvedLayerScheduleView actual = + independentLayerScheduleView resolvedLay ⟨selectedLay.val + 1, hbelow⟩ context + independent) := by + unfold resolveThenSelectLayer independentResolveThenSelectLayer + let resolution := resolveDeferredLayerValues table index resolvedLay encoding context + have hresolution := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + (relTriple_refl resolution) + (fun result => result ∈ support resolution) (fun result hresult => hresult) + apply relTriple_bind hresolution + intro leftResolution rightResolution hresolutionRelation + rcases hresolutionRelation with ⟨hresolutionEq, hresolutionSupport⟩ + subst rightResolution + cases leftResolution with + | none => + simpa [resolvedLayerScheduleView, independentLayerScheduleView] using + (relTriple_pure_pure (R := fun actual independent => + resolvedLayerScheduleView actual = independentLayerScheduleView resolvedLay + ⟨selectedLay.val + 1, hbelow⟩ context independent) rfl) + | some resolution => + rcases resolution with ⟨resolvedContext, resolvedValues⟩ + have hview : LayerViewEq ⟨selectedLay.val + 1, hbelow⟩ resolvedContext context := + layerViewEq_resolveDeferredLayerValues_of_ne table index resolvedLay + ⟨selectedLay.val + 1, hbelow⟩ (Ne.symm hne) encoding context resolvedContext + resolvedValues hresolutionSupport + have hselection := layerViewCouples_maskedSignLayer_of_below parameter ftsSecret index + selectedLay hbelow resolvedContext context fuel table cache hview + have hselectionSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hselection + (fun result => result ∈ support + (runResolvedFromTable resolvedContext fuel table + ((maskedSignLayer parameter ftsSecret index selectedLay).run cache))) + (fun result hresult => hresult) + apply relTriple_bind hselectionSupport + intro leftSelection rightSelection hselectionRelation + rcases hselectionRelation with ⟨hselectionEq, hleftSupport⟩ + cases leftSelection with + | none => + cases rightSelection with + | none => exact relTriple_pure_pure rfl + | some rightSelection => simp [LayerRunEq] at hselectionEq + | some leftSelection => + cases rightSelection with + | none => simp [LayerRunEq] at hselectionEq + | some rightSelection => + rcases hselectionEq with ⟨hcontext, hremaining, hvalue, htable⟩ + apply relTriple_pure_pure + apply congrArg some + apply LayerScheduleView.ext + · apply OtsContextView.ext + · change leftSelection.context.state.values = + rightSelection.context.state.values + exact hcontext.1 + · change leftSelection.context.state.revealed = + rightSelection.context.state.revealed + exact hcontext.2.1 + · change leftSelection.context.state.ensured = + rightSelection.context.state.ensured + exact hcontext.2.2.1 + · change otsDeferredValues leftSelection.context = fun lay => + if lay = resolvedLay then otsDeferredValues resolvedContext lay + else if lay = ⟨selectedLay.val + 1, hbelow⟩ then + otsDeferredValues rightSelection.context lay + else otsDeferredValues context lay + funext lay + by_cases hresolved : lay = resolvedLay + · subst lay + rw [if_pos rfl] + exact (resolverLayerViewPreserving_maskedSignLayer_of_below resolvedLay + parameter ftsSecret index selectedLay hbelow hne resolvedContext fuel table + cache leftSelection hleftSupport).otsDeferredValues_eq + · by_cases hobserved : lay = ⟨selectedLay.val + 1, hbelow⟩ + · subst lay + rw [if_neg hresolved, if_pos rfl] + exact hcontext.otsDeferredValues_eq + · rw [if_neg hresolved, if_neg hobserved] + exact ((resolverLayerViewPreserving_maskedSignLayer_of_below lay parameter + ftsSecret index selectedLay hbelow hobserved resolvedContext fuel table cache + leftSelection hleftSupport).otsDeferredValues_eq).trans + (layerViewEq_resolveDeferredLayerValues_of_ne table index resolvedLay lay + hresolved encoding context resolvedContext resolvedValues + hresolutionSupport).otsDeferredValues_eq + · change otsPendingAt leftSelection.context = fun lay => + if lay = resolvedLay then otsPendingAt resolvedContext lay + else if lay = ⟨selectedLay.val + 1, hbelow⟩ then + otsPendingAt rightSelection.context lay + else otsPendingAt context lay + funext lay + by_cases hresolved : lay = resolvedLay + · subst lay + rw [if_pos rfl] + exact (resolverLayerViewPreserving_maskedSignLayer_of_below resolvedLay + parameter ftsSecret index selectedLay hbelow hne resolvedContext fuel table + cache leftSelection hleftSupport).otsPendingAt_eq + · by_cases hobserved : lay = ⟨selectedLay.val + 1, hbelow⟩ + · subst lay + rw [if_neg hresolved, if_pos rfl] + exact hcontext.otsPendingAt_eq + · rw [if_neg hresolved, if_neg hobserved] + exact ((resolverLayerViewPreserving_maskedSignLayer_of_below lay parameter + ftsSecret index selectedLay hbelow hobserved resolvedContext fuel table cache + leftSelection hleftSupport).otsPendingAt_eq).trans + (layerViewEq_resolveDeferredLayerValues_of_ne table index resolvedLay lay + hresolved encoding context resolvedContext resolvedValues + hresolutionSupport).otsPendingAt_eq + · exact hremaining + · rfl + · exact hvalue + · exact htable + +theorem relTriple_resolveThenSelectLayer_independent_of_not_below + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (encoding : ChainIndex → Digit) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hbelow : ¬selectedLay.val + 1 < numLayers) (hne : resolvedLay ≠ selectedLay) : + RelTriple + (resolveThenSelectLayer parameter table ftsSecret index resolvedLay selectedLay encoding + context fuel cache) + (independentResolveThenSelectLayer parameter table ftsSecret index resolvedLay selectedLay + encoding context fuel cache) + (fun actual independent => resolvedLayerScheduleView actual = + independentLayerScheduleView resolvedLay selectedLay context independent) := by + unfold resolveThenSelectLayer independentResolveThenSelectLayer + let resolution := resolveDeferredLayerValues table index resolvedLay encoding context + have hresolution := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + (relTriple_refl resolution) + (fun result => result ∈ support resolution) (fun result hresult => hresult) + apply relTriple_bind hresolution + intro leftResolution rightResolution hresolutionRelation + rcases hresolutionRelation with ⟨hresolutionEq, hresolutionSupport⟩ + subst rightResolution + cases leftResolution with + | none => + simpa [resolvedLayerScheduleView, independentLayerScheduleView] using + (relTriple_pure_pure (R := fun actual independent => + resolvedLayerScheduleView actual = independentLayerScheduleView resolvedLay + selectedLay context independent) rfl) + | some resolution => + rcases resolution with ⟨resolvedContext, resolvedValues⟩ + have hview : LayerViewEq selectedLay resolvedContext context := + layerViewEq_resolveDeferredLayerValues_of_ne table index resolvedLay selectedLay + (Ne.symm hne) encoding context resolvedContext resolvedValues hresolutionSupport + have hselection := layerViewCouples_maskedSignLayer_of_not_below selectedLay parameter + ftsSecret index selectedLay hbelow resolvedContext context fuel table cache hview + have hselectionSupport := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hselection + (fun result => result ∈ support + (runResolvedFromTable resolvedContext fuel table + ((maskedSignLayer parameter ftsSecret index selectedLay).run cache))) + (fun result hresult => hresult) + apply relTriple_bind hselectionSupport + intro leftSelection rightSelection hselectionRelation + rcases hselectionRelation with ⟨hselectionEq, hleftSupport⟩ + cases leftSelection with + | none => + cases rightSelection with + | none => exact relTriple_pure_pure rfl + | some rightSelection => simp [LayerRunEq] at hselectionEq + | some leftSelection => + cases rightSelection with + | none => simp [LayerRunEq] at hselectionEq + | some rightSelection => + rcases hselectionEq with ⟨hcontext, hremaining, hvalue, htable⟩ + apply relTriple_pure_pure + apply congrArg some + apply LayerScheduleView.ext + · apply OtsContextView.ext + · change leftSelection.context.state.values = + rightSelection.context.state.values + exact hcontext.1 + · change leftSelection.context.state.revealed = + rightSelection.context.state.revealed + exact hcontext.2.1 + · change leftSelection.context.state.ensured = + rightSelection.context.state.ensured + exact hcontext.2.2.1 + · change otsDeferredValues leftSelection.context = fun lay => + if lay = resolvedLay then otsDeferredValues resolvedContext lay + else if lay = selectedLay then otsDeferredValues rightSelection.context lay + else otsDeferredValues context lay + funext lay + by_cases hresolved : lay = resolvedLay + · subst lay + rw [if_pos rfl] + exact (resolverLayerViewPreserving_maskedSignLayer_of_not_below resolvedLay + parameter ftsSecret index selectedLay hbelow resolvedContext fuel table cache + leftSelection hleftSupport).otsDeferredValues_eq + · by_cases hobserved : lay = selectedLay + · subst lay + rw [if_neg hresolved, if_pos rfl] + exact hcontext.otsDeferredValues_eq + · rw [if_neg hresolved, if_neg hobserved] + exact ((resolverLayerViewPreserving_maskedSignLayer_of_not_below lay + parameter ftsSecret index selectedLay hbelow resolvedContext fuel table cache + leftSelection hleftSupport).otsDeferredValues_eq).trans + (layerViewEq_resolveDeferredLayerValues_of_ne table index resolvedLay lay + hresolved encoding context resolvedContext resolvedValues + hresolutionSupport).otsDeferredValues_eq + · change otsPendingAt leftSelection.context = fun lay => + if lay = resolvedLay then otsPendingAt resolvedContext lay + else if lay = selectedLay then otsPendingAt rightSelection.context lay + else otsPendingAt context lay + funext lay + by_cases hresolved : lay = resolvedLay + · subst lay + rw [if_pos rfl] + exact (resolverLayerViewPreserving_maskedSignLayer_of_not_below resolvedLay + parameter ftsSecret index selectedLay hbelow resolvedContext fuel table cache + leftSelection hleftSupport).otsPendingAt_eq + · by_cases hobserved : lay = selectedLay + · subst lay + rw [if_neg hresolved, if_pos rfl] + exact hcontext.otsPendingAt_eq + · rw [if_neg hresolved, if_neg hobserved] + exact ((resolverLayerViewPreserving_maskedSignLayer_of_not_below lay + parameter ftsSecret index selectedLay hbelow resolvedContext fuel table cache + leftSelection hleftSupport).otsPendingAt_eq).trans + (layerViewEq_resolveDeferredLayerValues_of_ne table index resolvedLay lay + hresolved encoding context resolvedContext resolvedValues + hresolutionSupport).otsPendingAt_eq + · exact hremaining + · rfl + · exact hvalue + · exact htable + +noncomputable def selectionObservedLayer (lay : Layer) : Layer := + if hbelow : lay.val + 1 < numLayers then ⟨lay.val + 1, hbelow⟩ else lay + +theorem relTriple_resolveThenSelectLayer_independent_of_lt + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (hlt : resolvedLay.val < selectedLay.val) + (encoding : ChainIndex → Digit) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) : + RelTriple + (resolveThenSelectLayer parameter table ftsSecret index resolvedLay selectedLay encoding + context fuel cache) + (independentResolveThenSelectLayer parameter table ftsSecret index resolvedLay selectedLay + encoding context fuel cache) + (fun actual independent => resolvedLayerScheduleView actual = + independentLayerScheduleView resolvedLay (selectionObservedLayer selectedLay) context + independent) := by + by_cases hbelow : selectedLay.val + 1 < numLayers + · have hne : resolvedLay ≠ ⟨selectedLay.val + 1, hbelow⟩ := by + intro heq + have hval := congrArg Fin.val heq + simp only at hval + omega + simpa [selectionObservedLayer, hbelow] using + relTriple_resolveThenSelectLayer_independent_of_below parameter table ftsSecret index + resolvedLay selectedLay encoding context fuel cache hbelow hne + · have hne : resolvedLay ≠ selectedLay := by + intro heq + subst selectedLay + omega + simpa [selectionObservedLayer, hbelow] using + relTriple_resolveThenSelectLayer_independent_of_not_below parameter table ftsSecret index + resolvedLay selectedLay encoding context fuel cache hbelow hne + +theorem resolverLayerViewPreserving_maskedSignLayer_of_ne_observed + (preservedLay lay : Layer) (hne : preservedLay ≠ selectionObservedLayer lay) + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) : + ResolverLayerViewPreserving preservedLay + (maskedSignLayer parameter ftsSecret index lay) := by + by_cases hbelow : lay.val + 1 < numLayers + · apply resolverLayerViewPreserving_maskedSignLayer_of_below preservedLay parameter + ftsSecret index lay hbelow + simpa [selectionObservedLayer, hbelow] using hne + · exact resolverLayerViewPreserving_maskedSignLayer_of_not_below preservedLay parameter + ftsSecret index lay hbelow + +theorem relTriple_selectThenResolveLayer_independent_of_lt + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (hlt : resolvedLay.val < selectedLay.val) + (encoding : ChainIndex → Digit) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) : + RelTriple + (selectThenResolveLayer parameter table ftsSecret index resolvedLay selectedLay encoding + context fuel cache) + (independentSelectThenResolveLayer parameter table ftsSecret index resolvedLay selectedLay + encoding context fuel cache) + (fun actual independent => resolvedLayerScheduleView actual = + independentLayerScheduleView resolvedLay (selectionObservedLayer selectedLay) context + independent) := by + have hneObserved : resolvedLay ≠ selectionObservedLayer selectedLay := by + by_cases hbelow : selectedLay.val + 1 < numLayers + · simp only [selectionObservedLayer, dif_pos hbelow] + intro heq + have hval := congrArg Fin.val heq + simp only at hval + omega + · simp only [selectionObservedLayer, dif_neg hbelow] + intro heq + subst selectedLay + omega + unfold selectThenResolveLayer independentSelectThenResolveLayer + let selection := runResolvedFromTable context fuel table + ((maskedSignLayer parameter ftsSecret index selectedLay).run cache) + have hselection := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + (relTriple_refl selection) + (fun result => result ∈ support selection) (fun result hresult => hresult) + apply relTriple_bind hselection + intro leftSelection rightSelection hselectionRelation + rcases hselectionRelation with ⟨hselectionEq, hselectionSupport⟩ + subst rightSelection + cases leftSelection with + | none => + simpa [resolvedLayerScheduleView, independentLayerScheduleView] using + (relTriple_pure_pure (R := fun actual independent => + resolvedLayerScheduleView actual = independentLayerScheduleView resolvedLay + (selectionObservedLayer selectedLay) context independent) rfl) + | some selectionResult => + have hresolverView : ResolverLayerViewEq resolvedLay selectionResult.context context := + resolverLayerViewPreserving_maskedSignLayer_of_ne_observed resolvedLay selectedLay + hneObserved parameter ftsSecret index context fuel table cache selectionResult + hselectionSupport + let resolution := resolveDeferredLayerValues table index resolvedLay encoding + selectionResult.context + have hresolutionBase := relTriple_resolveDeferredLayerValues_of_resolverLayerViewEq table + index resolvedLay encoding selectionResult.context context hresolverView + have hresolution := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolutionBase + (fun result => result ∈ support resolution) (fun result hresult => hresult) + apply relTriple_bind hresolution + intro leftResolution rightResolution hresolutionRelation + rcases hresolutionRelation with ⟨hresolutionEq, hresolutionSupport⟩ + cases leftResolution with + | none => + cases rightResolution with + | none => exact relTriple_pure_pure rfl + | some rightResolution => simp [ResolverLayerContextValueEq] at hresolutionEq + | some leftResolution => + cases rightResolution with + | none => simp [ResolverLayerContextValueEq] at hresolutionEq + | some rightResolution => + rcases hresolutionEq with ⟨hvalues, hresolvedView⟩ + apply relTriple_pure_pure + apply congrArg some + apply LayerScheduleView.ext + · apply OtsContextView.ext + · change leftResolution.1.state.values = selectionResult.context.state.values + exact (privateStateAgrees_resolveDeferredLayerValues table index resolvedLay + encoding selectionResult.context leftResolution.1 leftResolution.2 + hresolutionSupport).1 + · change leftResolution.1.state.revealed = + selectionResult.context.state.revealed + exact (privateStateAgrees_resolveDeferredLayerValues table index resolvedLay + encoding selectionResult.context leftResolution.1 leftResolution.2 + hresolutionSupport).2.1 + · change leftResolution.1.state.ensured = + selectionResult.context.state.ensured + exact (privateStateAgrees_resolveDeferredLayerValues table index resolvedLay + encoding selectionResult.context leftResolution.1 leftResolution.2 + hresolutionSupport).2.2 + · change otsDeferredValues leftResolution.1 = fun lay => + if lay = resolvedLay then otsDeferredValues rightResolution.1 lay + else if lay = selectionObservedLayer selectedLay then + otsDeferredValues selectionResult.context lay + else otsDeferredValues context lay + funext lay + by_cases hresolved : lay = resolvedLay + · subst lay + rw [if_pos rfl] + exact hresolvedView.otsDeferredValues_eq + · have hresolutionOther := layerViewEq_resolveDeferredLayerValues_of_ne + table index resolvedLay lay hresolved encoding selectionResult.context + leftResolution.1 leftResolution.2 hresolutionSupport + by_cases hobserved : lay = selectionObservedLayer selectedLay + · rw [if_neg hresolved, if_pos hobserved] + exact hresolutionOther.otsDeferredValues_eq + · rw [if_neg hresolved, if_neg hobserved] + exact hresolutionOther.otsDeferredValues_eq.trans + ((resolverLayerViewPreserving_maskedSignLayer_of_ne_observed lay + selectedLay hobserved parameter ftsSecret index context fuel table cache + selectionResult hselectionSupport).otsDeferredValues_eq) + · change otsPendingAt leftResolution.1 = fun lay => + if lay = resolvedLay then otsPendingAt rightResolution.1 lay + else if lay = selectionObservedLayer selectedLay then + otsPendingAt selectionResult.context lay + else otsPendingAt context lay + funext lay + by_cases hresolved : lay = resolvedLay + · subst lay + rw [if_pos rfl] + exact hresolvedView.otsPendingAt_eq + · have hresolutionOther := layerViewEq_resolveDeferredLayerValues_of_ne + table index resolvedLay lay hresolved encoding selectionResult.context + leftResolution.1 leftResolution.2 hresolutionSupport + by_cases hobserved : lay = selectionObservedLayer selectedLay + · rw [if_neg hresolved, if_pos hobserved] + exact hresolutionOther.otsPendingAt_eq + · rw [if_neg hresolved, if_neg hobserved] + exact hresolutionOther.otsPendingAt_eq.trans + ((resolverLayerViewPreserving_maskedSignLayer_of_ne_observed lay + selectedLay hobserved parameter ftsSecret index context fuel table cache + selectionResult hselectionSupport).otsPendingAt_eq) + · rfl + · exact hvalues + · rfl + · rfl + +theorem evalDist_resolveThenSelectLayer_view_eq_selectThenResolveLayer_of_lt + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (hlt : resolvedLay.val < selectedLay.val) + (encoding : ChainIndex → Digit) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) : + evalDist (resolvedLayerScheduleView <$> + resolveThenSelectLayer parameter table ftsSecret index resolvedLay selectedLay encoding + context fuel cache) = + evalDist (resolvedLayerScheduleView <$> + selectThenResolveLayer parameter table ftsSecret index resolvedLay selectedLay encoding + context fuel cache) := by + have hresolveFirst := evalDist_map_eq_of_relTriple + (relTriple_resolveThenSelectLayer_independent_of_lt parameter table ftsSecret index + resolvedLay selectedLay hlt encoding context fuel cache) + have hselectFirst := evalDist_map_eq_of_relTriple + (relTriple_selectThenResolveLayer_independent_of_lt parameter table ftsSecret index + resolvedLay selectedLay hlt encoding context fuel cache) + calc + _ = evalDist (independentLayerScheduleView resolvedLay + (selectionObservedLayer selectedLay) context <$> + independentResolveThenSelectLayer parameter table ftsSecret index resolvedLay selectedLay + encoding context fuel cache) := hresolveFirst + _ = evalDist (independentLayerScheduleView resolvedLay + (selectionObservedLayer selectedLay) context <$> + independentSelectThenResolveLayer parameter table ftsSecret index resolvedLay selectedLay + encoding context fuel cache) := by + rw [evalDist_map, evalDist_map, + evalDist_independentResolveThenSelectLayer_eq_selectThenResolve] + _ = _ := hselectFirst.symm + +def NonOtsViewEq (left right : DeferredContext) : Prop := + (∀ position, positionOtsLayer? position = none → + left.values position = right.values position) ∧ + ∀ coordinate, coordinateOtsLayer? coordinate = none → + left.state.pendingAt coordinate = right.state.pendingAt coordinate + +theorem NonOtsViewEq.refl (context : DeferredContext) : + NonOtsViewEq context context := by + exact ⟨fun _ _ => rfl, fun _ _ => rfl⟩ + +theorem NonOtsViewEq.trans {left middle right : DeferredContext} + (hleft : NonOtsViewEq left middle) (hright : NonOtsViewEq middle right) : + NonOtsViewEq left right := by + exact ⟨fun position hposition => + (hleft.1 position hposition).trans (hright.1 position hposition), + fun coordinate hcoordinate => + (hleft.2 coordinate hcoordinate).trans (hright.2 coordinate hcoordinate)⟩ + +def NonOtsViewPreserving + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) : Prop := + ∀ context fuel table cache result, + some result ∈ support + (runResolvedFromTable context fuel table (computation.run cache)) → + NonOtsViewEq result.context context + +theorem nonOtsViewPreserving_pure (value : alpha) : + NonOtsViewPreserving + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) := by + intro context fuel table cache result hresult + simp [runResolvedFromTable] at hresult + subst result + exact NonOtsViewEq.refl context + +theorem NonOtsViewPreserving.bind + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + (hleft : NonOtsViewPreserving left) + (hnext : ∀ value, NonOtsViewPreserving (next value)) : + NonOtsViewPreserving (left >>= next) := by + intro context fuel table cache result hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨middleOption, hmiddle, hrest⟩ := hresult + cases middleOption with + | none => simp at hrest + | some middle => + exact (hnext middle.value.1 middle.context middle.remaining middle.table middle.value.2 + result hrest).trans (hleft context fuel table cache middle hmiddle) + +theorem nonOtsViewPreserving_of_resolvedAdministrative + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {value : alpha} (hadministrative : ResolvedAdministrative computation value) : + NonOtsViewPreserving computation := by + intro context fuel table cache result hresult + obtain ⟨finalContext, hrun, hpending, _, hdeferred⟩ := + hadministrative context cache fuel table + rw [hrun] at hresult + simp only [support_pure, Set.mem_singleton_iff] at hresult + have hresultEq := Option.some.inj hresult + subst result + refine ⟨?_, ?_⟩ + · intro position _ + exact congrFun hdeferred position + · intro coordinate _ + change finalContext.state.pendingAt coordinate = context.state.pendingAt coordinate + simp only [LazyRevealProbe.State.pendingAt, hpending] + +theorem nonOtsViewPreserving_splitHashQuery_ordinary (input : HashInput) : + NonOtsViewPreserving (splitHashQuery (.ordinary input)) := by + intro context fuel table cache result hresult + rw [splitHashQuery_run_eq] at hresult + cases hlookup : cache (.ordinary input) with + | some output => + simp only [hlookup] at hresult + simp [runResolvedFromTable] at hresult + subst result + exact NonOtsViewEq.refl context + | none => + simp only [hlookup] at hresult + rw [LazyRevealProbe.hashOutputQuery, runResolvedFromTable_hashOutput_query_bind, + mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hreturn⟩ := hresult + simp [runResolvedFromTable] at hreturn + subst result + exact NonOtsViewEq.refl context + +theorem nonOtsViewPreserving_ordinaryHashImpl (input : HashInput) : + NonOtsViewPreserving (ordinaryHashImpl input) := + nonOtsViewPreserving_splitHashQuery_ordinary input + +theorem nonOtsViewPreserving_sequenceFin {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (hcomponent : ∀ position, NonOtsViewPreserving (computation position)) : + NonOtsViewPreserving (sequenceFin computation) := by + induction n with + | zero => + simpa [sequenceFin] using + (nonOtsViewPreserving_pure Fin.elim0 : + NonOtsViewPreserving + (pure Fin.elim0 : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Fin 0 → alpha))) + | succ n ih => + rw [sequenceFin] + exact (hcomponent 0).bind fun _ => + (ih (fun position : Fin n => computation position.succ) + (fun position => hcomponent position.succ)).bind fun _ => + nonOtsViewPreserving_pure _ + +theorem nonOtsViewPreserving_simulateQ {spec : OracleSpec ι} + (impl : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))) + (hquery : ∀ query, NonOtsViewPreserving (impl query)) + (computation : OracleComp spec alpha) : + NonOtsViewPreserving (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp only [simulateQ_pure] + exact nonOtsViewPreserving_pure value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (hquery query).bind fun output => ih output + +theorem nonOtsViewPreserving_revealPosition + (revealedLay : Layer) (position : Position) + (hposition : positionOtsLayer? position = some revealedLay) : + NonOtsViewPreserving (revealPosition position) := by + intro context fuel table cache result hresult + rw [runResolvedFromTable_revealPosition, mem_support_bind_iff] at hresult + obtain ⟨resolvedOption, hresolved, hreturn⟩ := hresult + cases resolvedOption with + | none => simp at hreturn + | some resolved => + simp [runResolvedFromTable] at hreturn + subst result + refine ⟨?_, ?_⟩ + · intro other hother + apply resolveDeferredReveal_preserves_other_layer_value table revealedLay position + hposition context resolved other + · intro hlayer + rw [hother] at hlayer + simp at hlayer + · exact hresolved + · intro coordinate hcoordinate + have hcoordinateNe : coordinate ≠ .position position := by + intro heq + subst coordinate + have hnone : positionOtsLayer? position = none := by + simpa [coordinateOtsLayer?] using hcoordinate + rw [hposition] at hnone + simp at hnone + change (context.state.clearPending (.position position)).pendingAt coordinate = + context.state.pendingAt coordinate + exact pendingAt_clearPending_of_ne context.state (.position position) coordinate + hcoordinateNe + +theorem nonOtsViewPreserving_maskedTreeNode + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) : + NonOtsViewPreserving (maskedTreeNode lay tree level nodeIdx) := by + unfold maskedTreeNode + apply (nonOtsViewPreserving_of_resolvedAdministrative + (resolvedAdministrative_ensureTreeNode lay tree level nodeIdx)).bind + intro _ + cases level with + | zero => + exact nonOtsViewPreserving_revealPosition lay + (.leaf lay tree (leafOfNat nodeIdx)) (by simp [positionOtsLayer?]) + | succ current => + by_cases hlevel : current < maxLayerHeight + · simp only [hlevel, ↓reduceDIte] + exact nonOtsViewPreserving_revealPosition lay + (.node lay tree ⟨current, hlevel⟩ (leafOfNat nodeIdx)) + (by simp [positionOtsLayer?]) + · simp [hlevel] + exact nonOtsViewPreserving_pure 0 + +theorem nonOtsViewPreserving_maskedTreeRoot + (lay : Layer) (tree : TreeIndex) : + NonOtsViewPreserving (maskedTreeRoot lay tree) := by + unfold maskedTreeRoot + exact nonOtsViewPreserving_maskedTreeNode lay tree (layerHeight lay) 0 + +theorem nonOtsViewPreserving_maskedOtsSignFrom + (lay : Layer) (parameter : PublicParameter) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : ∀ attempts counter, + NonOtsViewPreserving + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom] + exact nonOtsViewPreserving_pure none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + have hencoded := nonOtsViewPreserving_simulateQ ordinaryHashImpl + nonOtsViewPreserving_ordinaryHashImpl + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) + apply hencoded.bind + intro encoded + cases encoded with + | none => + exact nonOtsViewPreserving_maskedOtsSignFrom lay parameter tree leafIdx message + attempts (counter + 1) + | some encoding => + apply (nonOtsViewPreserving_sequenceFin + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx (encoding chainIdx)) + (fun chainIdx => nonOtsViewPreserving_of_resolvedAdministrative + (resolvedAdministrative_ensureChainPrefix lay tree leafIdx chainIdx + (encoding chainIdx)))).bind + intro _ + exact nonOtsViewPreserving_pure + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem nonOtsViewPreserving_maskedOtsSign + (lay : Layer) (parameter : PublicParameter) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : + NonOtsViewPreserving (maskedOtsSign parameter lay tree leafIdx message) := + nonOtsViewPreserving_maskedOtsSignFrom lay parameter tree leafIdx message + encodingAttemptLimit 0 + +theorem nonOtsViewPreserving_maskedLayerMessage + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + NonOtsViewPreserving (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + split + · exact nonOtsViewPreserving_maskedTreeRoot _ _ + · exact nonOtsViewPreserving_simulateQ ordinaryHashImpl + nonOtsViewPreserving_ordinaryHashImpl (ftsKey parameter index (ftsSecret index)) + +theorem nonOtsViewPreserving_maskedSignLayer + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + NonOtsViewPreserving (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + apply (nonOtsViewPreserving_maskedLayerMessage parameter ftsSecret index lay).bind + intro message + apply (nonOtsViewPreserving_maskedOtsSign lay parameter (treeIndexAt index lay) + (leafIndexAt index lay) message).bind + intro selected + cases selected with + | none => exact nonOtsViewPreserving_pure none + | some selected => + apply (nonOtsViewPreserving_of_resolvedAdministrative + (resolvedAdministrative_ensureTreePath lay (treeIndexAt index lay) + (leafIndexAt index lay))).bind + intro _ + exact nonOtsViewPreserving_pure (some selected) + +theorem nonOtsViewEq_resolveDeferredLayerValues + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) (context finalContext : DeferredContext) + (values : DeferredLayerValues) + (hresult : some (finalContext, values) ∈ support + (resolveDeferredLayerValues table index lay encoding context)) : + NonOtsViewEq finalContext context := by + refine ⟨?_, ?_⟩ + · intro position hposition + apply resolveDeferredLayerValues_preserves_other_layer_value table index lay encoding + context finalContext values position + · intro hlayer + rw [hposition] at hlayer + simp at hlayer + · exact hresult + · intro coordinate hcoordinate + apply resolveDeferredLayerValues_preserves_other_layer_pendingAt table index lay encoding + context finalContext values coordinate + · intro hlayer + rw [hcoordinate] at hlayer + simp at hlayer + · exact hresult + +theorem nonOtsViewEq_of_mem_resolveThenSelectLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (encoding : ChainIndex → Digit) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult (DeferredLayerValues × DeferredLayerSelection)) + (hresult : some result ∈ support + (resolveThenSelectLayer parameter table ftsSecret index resolvedLay selectedLay encoding + context fuel cache)) : + NonOtsViewEq result.context context := by + unfold resolveThenSelectLayer at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨resolutionOption, hresolution, hrest⟩ := hresult + cases resolutionOption with + | none => simp at hrest + | some resolution => + rcases resolution with ⟨resolvedContext, resolvedValues⟩ + rw [mem_support_bind_iff] at hrest + obtain ⟨selectionOption, hselection, hfinish⟩ := hrest + cases selectionOption with + | none => simp at hfinish + | some selection => + simp only [support_pure, Set.mem_singleton_iff] at hfinish + have hresultEq := Option.some.inj hfinish + subst result + exact (nonOtsViewPreserving_maskedSignLayer parameter ftsSecret index selectedLay + resolvedContext fuel table cache selection hselection).trans + (nonOtsViewEq_resolveDeferredLayerValues table index resolvedLay encoding context + resolvedContext resolvedValues hresolution) + +theorem nonOtsViewEq_of_mem_selectThenResolveLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (encoding : ChainIndex → Digit) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult (DeferredLayerValues × DeferredLayerSelection)) + (hresult : some result ∈ support + (selectThenResolveLayer parameter table ftsSecret index resolvedLay selectedLay encoding + context fuel cache)) : + NonOtsViewEq result.context context := by + unfold selectThenResolveLayer at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨selectionOption, hselection, hrest⟩ := hresult + cases selectionOption with + | none => simp at hrest + | some selection => + rw [mem_support_bind_iff] at hrest + obtain ⟨resolutionOption, hresolution, hfinish⟩ := hrest + cases resolutionOption with + | none => simp at hfinish + | some resolution => + rcases resolution with ⟨resolvedContext, resolvedValues⟩ + simp only [support_pure, Set.mem_singleton_iff] at hfinish + have hresultEq := Option.some.inj hfinish + subst result + exact (nonOtsViewEq_resolveDeferredLayerValues table index resolvedLay encoding + selection.context resolvedContext resolvedValues hresolution).trans + (nonOtsViewPreserving_maskedSignLayer parameter ftsSecret index selectedLay + context fuel table cache selection hselection) + +def nonOtsDeferredValues (context : DeferredContext) + (position : Position) : Option HashOutput := + if positionOtsLayer? position = none then context.values position else none + +def nonOtsPendingAt (context : DeferredContext) + (coordinate : Coordinate) : Finset Digest := + if coordinateOtsLayer? coordinate = none then context.state.pendingAt coordinate else ∅ + +theorem NonOtsViewEq.nonOtsDeferredValues_eq {left right : DeferredContext} + (heq : NonOtsViewEq left right) : + nonOtsDeferredValues left = nonOtsDeferredValues right := by + funext position + by_cases hposition : positionOtsLayer? position = none + · simp [nonOtsDeferredValues, hposition, heq.1 position hposition] + · simp [nonOtsDeferredValues, hposition] + +theorem NonOtsViewEq.nonOtsPendingAt_eq {left right : DeferredContext} + (heq : NonOtsViewEq left right) : + nonOtsPendingAt left = nonOtsPendingAt right := by + funext coordinate + by_cases hcoordinate : coordinateOtsLayer? coordinate = none + · simp [nonOtsPendingAt, hcoordinate, heq.2 coordinate hcoordinate] + · simp [nonOtsPendingAt, hcoordinate] + +structure CompleteOtsContextView where + ots : OtsContextView + nonOtsDeferredValues : Position → Option HashOutput + nonOtsPendingAt : Coordinate → Finset Digest + +theorem CompleteOtsContextView.ext {left right : CompleteOtsContextView} + (hots : left.ots = right.ots) + (hdeferred : left.nonOtsDeferredValues = right.nonOtsDeferredValues) + (hpending : left.nonOtsPendingAt = right.nonOtsPendingAt) : left = right := by + cases left + cases right + simp_all + +def completeOtsContextView (context : DeferredContext) : CompleteOtsContextView where + ots := otsContextView context + nonOtsDeferredValues := nonOtsDeferredValues context + nonOtsPendingAt := nonOtsPendingAt context + +theorem LazyRevealProbe.State.mem_pendingAt_iff + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (candidate : Digest) : + candidate ∈ state.pendingAt coordinate ↔ (coordinate, candidate) ∈ state.pending := by + simp [LazyRevealProbe.State.pendingAt] + +theorem completeOtsContextView_injective : Function.Injective completeOtsContextView := by + intro left right heq + have hots := congrArg CompleteOtsContextView.ots heq + have hnonDeferred := congrArg CompleteOtsContextView.nonOtsDeferredValues heq + have hnonPending := congrArg CompleteOtsContextView.nonOtsPendingAt heq + have hstateValues := congrArg OtsContextView.values hots + have hrevealed := congrArg OtsContextView.revealed hots + have hensured := congrArg OtsContextView.ensured hots + have hdeferredFibers := congrArg OtsContextView.deferredValues hots + have hpendingFibers := congrArg OtsContextView.pendingAt hots + have hdeferred : left.values = right.values := by + funext position + cases hposition : positionOtsLayer? position with + | none => + have hvalue := congrFun hnonDeferred position + simpa [completeOtsContextView, nonOtsDeferredValues, hposition] using hvalue + | some lay => + have hvalue := congrFun (congrFun hdeferredFibers lay) position + simpa [completeOtsContextView, otsContextView, otsDeferredValues, hposition] using hvalue + have hpendingAt : left.state.pendingAt = right.state.pendingAt := by + funext coordinate + cases hcoordinate : coordinateOtsLayer? coordinate with + | none => + have hvalue := congrFun hnonPending coordinate + simpa [completeOtsContextView, nonOtsPendingAt, hcoordinate] using hvalue + | some lay => + have hvalue := congrFun (congrFun hpendingFibers lay) coordinate + simpa [completeOtsContextView, otsContextView, otsPendingAt, hcoordinate] using hvalue + have hpending : left.state.pending = right.state.pending := by + ext entry + rcases entry with ⟨coordinate, candidate⟩ + rw [← LazyRevealProbe.State.mem_pendingAt_iff, + ← LazyRevealProbe.State.mem_pendingAt_iff, hpendingAt] + change left.state.values = right.state.values at hstateValues + change left.state.revealed = right.state.revealed at hrevealed + change left.state.ensured = right.state.ensured at hensured + rcases left with ⟨⟨leftPending, leftStateValues, leftRevealed, leftEnsured⟩, + leftDeferred⟩ + rcases right with ⟨⟨rightPending, rightStateValues, rightRevealed, rightEnsured⟩, + rightDeferred⟩ + simp only at hpending hstateValues hrevealed hensured hdeferred + subst rightPending + subst rightStateValues + subst rightRevealed + subst rightEnsured + subst rightDeferred + rfl + +def independentCompleteOtsContextView (resolvedLay observedLay : Layer) + (base : DeferredContext) (result : IndependentLayerScheduleResult) : + CompleteOtsContextView where + ots := independentLayerContextView resolvedLay observedLay base result + nonOtsDeferredValues := nonOtsDeferredValues base + nonOtsPendingAt := nonOtsPendingAt base + +structure CompleteLayerScheduleView where + context : CompleteOtsContextView + remaining : Nat + resolution : DeferredLayerValues + selection : DeferredLayerSelection + table : OtsSecretIndex → HashOutput + +theorem CompleteLayerScheduleView.ext {left right : CompleteLayerScheduleView} + (hcontext : left.context = right.context) + (hremaining : left.remaining = right.remaining) + (hresolution : left.resolution = right.resolution) + (hselection : left.selection = right.selection) + (htable : left.table = right.table) : left = right := by + cases left + cases right + simp_all + +def completeResolvedLayerScheduleView : + Option (ResolvedRunResult (DeferredLayerValues × DeferredLayerSelection)) → + Option CompleteLayerScheduleView + | none => none + | some result => some ⟨completeOtsContextView result.context, result.remaining, + result.value.1, result.value.2, result.table⟩ + +def completeIndependentLayerScheduleView (resolvedLay observedLay : Layer) + (base : DeferredContext) : + Option IndependentLayerScheduleResult → Option CompleteLayerScheduleView + | none => none + | some result => some ⟨independentCompleteOtsContextView resolvedLay observedLay base result, + result.selection.remaining, result.resolution.2, result.selection.value, + result.selection.table⟩ + +theorem relTriple_resolveThenSelectLayer_complete_independent_of_lt + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (hlt : resolvedLay.val < selectedLay.val) + (encoding : ChainIndex → Digit) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) : + RelTriple + (resolveThenSelectLayer parameter table ftsSecret index resolvedLay selectedLay encoding + context fuel cache) + (independentResolveThenSelectLayer parameter table ftsSecret index resolvedLay selectedLay + encoding context fuel cache) + (fun actual independent => completeResolvedLayerScheduleView actual = + completeIndependentLayerScheduleView resolvedLay (selectionObservedLayer selectedLay) + context independent) := by + let actualRun := resolveThenSelectLayer parameter table ftsSecret index resolvedLay selectedLay + encoding context fuel cache + have hbase := relTriple_resolveThenSelectLayer_independent_of_lt parameter table ftsSecret index + resolvedLay selectedLay hlt encoding context fuel cache + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support actualRun) (fun result hresult => hresult) + apply relTriple_post_mono hsupported + intro actual independent hrelation + rcases hrelation with ⟨hots, hsupport⟩ + cases actual with + | none => + cases independent with + | none => rfl + | some independent => simp [resolvedLayerScheduleView, + independentLayerScheduleView] at hots + | some actual => + cases independent with + | none => simp [resolvedLayerScheduleView, independentLayerScheduleView] at hots + | some independent => + have hots' := Option.some.inj hots + apply congrArg some + apply CompleteLayerScheduleView.ext + · apply CompleteOtsContextView.ext + · exact congrArg LayerScheduleView.context hots' + · change nonOtsDeferredValues actual.context = nonOtsDeferredValues context + have hnon := nonOtsViewEq_of_mem_resolveThenSelectLayer parameter table ftsSecret + index resolvedLay selectedLay encoding context fuel cache actual hsupport + exact hnon.nonOtsDeferredValues_eq + · change nonOtsPendingAt actual.context = nonOtsPendingAt context + have hnon := nonOtsViewEq_of_mem_resolveThenSelectLayer parameter table ftsSecret + index resolvedLay selectedLay encoding context fuel cache actual hsupport + exact hnon.nonOtsPendingAt_eq + · exact congrArg LayerScheduleView.remaining hots' + · exact congrArg LayerScheduleView.resolution hots' + · exact congrArg LayerScheduleView.selection hots' + · exact congrArg LayerScheduleView.table hots' + +theorem relTriple_selectThenResolveLayer_complete_independent_of_lt + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (hlt : resolvedLay.val < selectedLay.val) + (encoding : ChainIndex → Digit) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) : + RelTriple + (selectThenResolveLayer parameter table ftsSecret index resolvedLay selectedLay encoding + context fuel cache) + (independentSelectThenResolveLayer parameter table ftsSecret index resolvedLay selectedLay + encoding context fuel cache) + (fun actual independent => completeResolvedLayerScheduleView actual = + completeIndependentLayerScheduleView resolvedLay (selectionObservedLayer selectedLay) + context independent) := by + let actualRun := selectThenResolveLayer parameter table ftsSecret index resolvedLay selectedLay + encoding context fuel cache + have hbase := relTriple_selectThenResolveLayer_independent_of_lt parameter table ftsSecret index + resolvedLay selectedLay hlt encoding context fuel cache + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support actualRun) (fun result hresult => hresult) + apply relTriple_post_mono hsupported + intro actual independent hrelation + rcases hrelation with ⟨hots, hsupport⟩ + cases actual with + | none => + cases independent with + | none => rfl + | some independent => simp [resolvedLayerScheduleView, + independentLayerScheduleView] at hots + | some actual => + cases independent with + | none => simp [resolvedLayerScheduleView, independentLayerScheduleView] at hots + | some independent => + have hots' := Option.some.inj hots + apply congrArg some + apply CompleteLayerScheduleView.ext + · apply CompleteOtsContextView.ext + · exact congrArg LayerScheduleView.context hots' + · change nonOtsDeferredValues actual.context = nonOtsDeferredValues context + have hnon := nonOtsViewEq_of_mem_selectThenResolveLayer parameter table ftsSecret + index resolvedLay selectedLay encoding context fuel cache actual hsupport + exact hnon.nonOtsDeferredValues_eq + · change nonOtsPendingAt actual.context = nonOtsPendingAt context + have hnon := nonOtsViewEq_of_mem_selectThenResolveLayer parameter table ftsSecret + index resolvedLay selectedLay encoding context fuel cache actual hsupport + exact hnon.nonOtsPendingAt_eq + · exact congrArg LayerScheduleView.remaining hots' + · exact congrArg LayerScheduleView.resolution hots' + · exact congrArg LayerScheduleView.selection hots' + · exact congrArg LayerScheduleView.table hots' + +theorem evalDist_resolveThenSelectLayer_complete_view_eq_selectThenResolveLayer_of_lt + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (hlt : resolvedLay.val < selectedLay.val) + (encoding : ChainIndex → Digit) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) : + evalDist (completeResolvedLayerScheduleView <$> + resolveThenSelectLayer parameter table ftsSecret index resolvedLay selectedLay encoding + context fuel cache) = + evalDist (completeResolvedLayerScheduleView <$> + selectThenResolveLayer parameter table ftsSecret index resolvedLay selectedLay encoding + context fuel cache) := by + have hresolveFirst := evalDist_map_eq_of_relTriple + (relTriple_resolveThenSelectLayer_complete_independent_of_lt parameter table ftsSecret index + resolvedLay selectedLay hlt encoding context fuel cache) + have hselectFirst := evalDist_map_eq_of_relTriple + (relTriple_selectThenResolveLayer_complete_independent_of_lt parameter table ftsSecret index + resolvedLay selectedLay hlt encoding context fuel cache) + calc + _ = evalDist (completeIndependentLayerScheduleView resolvedLay + (selectionObservedLayer selectedLay) context <$> + independentResolveThenSelectLayer parameter table ftsSecret index resolvedLay selectedLay + encoding context fuel cache) := hresolveFirst + _ = evalDist (completeIndependentLayerScheduleView resolvedLay + (selectionObservedLayer selectedLay) context <$> + independentSelectThenResolveLayer parameter table ftsSecret index resolvedLay selectedLay + encoding context fuel cache) := by + rw [evalDist_map, evalDist_map, + evalDist_independentResolveThenSelectLayer_eq_selectThenResolve] + _ = _ := hselectFirst.symm + +local instance deferredContextNonempty : Nonempty DeferredContext := + ⟨{ state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate), + values := emptyDeferredStructuralValues }⟩ + +noncomputable def CompleteOtsContextView.toContext + (view : CompleteOtsContextView) : DeferredContext := + Function.invFun completeOtsContextView view + +@[simp] theorem CompleteOtsContextView.toContext_complete + (context : DeferredContext) : + (completeOtsContextView context).toContext = context := + Function.leftInverse_invFun completeOtsContextView_injective context + +noncomputable def completeLayerScheduleViewResult : + Option CompleteLayerScheduleView → + Option (ResolvedRunResult (DeferredLayerValues × DeferredLayerSelection)) + | none => none + | some view => some ⟨view.context.toContext, view.remaining, + (view.resolution, view.selection), view.table⟩ + +@[simp] theorem completeLayerScheduleViewResult_resolved + (input : Option + (ResolvedRunResult (DeferredLayerValues × DeferredLayerSelection))) : + completeLayerScheduleViewResult (completeResolvedLayerScheduleView input) = input := by + cases input with + | none => rfl + | some result => + cases result + simp [completeLayerScheduleViewResult, completeResolvedLayerScheduleView] + +theorem completeLayerScheduleView_roundtrip + (run : ProbComp + (Option (ResolvedRunResult (DeferredLayerValues × DeferredLayerSelection)))) : + completeLayerScheduleViewResult <$> (completeResolvedLayerScheduleView <$> run) = run := by + rw [Functor.map_map] + have hfunction : + completeLayerScheduleViewResult ∘ completeResolvedLayerScheduleView = id := by + funext input + exact completeLayerScheduleViewResult_resolved input + change ((completeLayerScheduleViewResult ∘ completeResolvedLayerScheduleView) <$> run) = run + rw [hfunction, id_map] + +theorem evalDist_resolveThenSelectLayer_eq_selectThenResolveLayer_of_lt + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (hlt : resolvedLay.val < selectedLay.val) + (encoding : ChainIndex → Digit) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) : + evalDist + (resolveThenSelectLayer parameter table ftsSecret index resolvedLay selectedLay encoding + context fuel cache) = + evalDist + (selectThenResolveLayer parameter table ftsSecret index resolvedLay selectedLay encoding + context fuel cache) := by + let left := resolveThenSelectLayer parameter table ftsSecret index resolvedLay selectedLay + encoding context fuel cache + let right := selectThenResolveLayer parameter table ftsSecret index resolvedLay selectedLay + encoding context fuel cache + have hview := + evalDist_resolveThenSelectLayer_complete_view_eq_selectThenResolveLayer_of_lt parameter table + ftsSecret index resolvedLay selectedLay hlt encoding context fuel cache + change evalDist (completeResolvedLayerScheduleView <$> left) = + evalDist (completeResolvedLayerScheduleView <$> right) at hview + calc + evalDist left = completeLayerScheduleViewResult <$> + evalDist (completeResolvedLayerScheduleView <$> left) := by + rw [← evalDist_map, completeLayerScheduleView_roundtrip] + _ = completeLayerScheduleViewResult <$> + evalDist (completeResolvedLayerScheduleView <$> right) := by rw [hview] + _ = evalDist right := by + rw [← evalDist_map, completeLayerScheduleView_roundtrip] +theorem DeferredContext.Valid.of_resolveDeferredLayerValues + {context : DeferredContext} (hvalid : context.Valid) + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) (finalContext : DeferredContext) + (values : (ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) + (hresult : some (finalContext, values) ∈ support + (resolveDeferredLayerValues table index lay encoding context)) : + finalContext.Valid := by + rw [resolveDeferredLayerValues, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + rcases chains with ⟨afterChains, chainValues⟩ + rw [mem_support_bind_iff] at hrest + obtain ⟨pathOption, hpath, hreturn⟩ := hrest + cases pathOption with + | none => simp at hreturn + | some path => + rcases path with ⟨afterPath, pathValues⟩ + have hcontext : finalContext = afterPath := + congrArg Prod.fst (Option.some.inj hreturn) + rw [hcontext] + have hchainsValid := hvalid.of_resolveDeferredSelectedChainFamily table lay + (treeIndexAt index lay) (leafIndexAt index lay) + (fun chainIdx : ChainIndex => chainIdx) encoding afterChains chainValues hchains + exact hchainsValid.of_resolveDeferredLayerPathFamily table lay + (treeIndexAt index lay) (leafIndexAt index lay) + (fun level : Fin maxLayerHeight => level) afterPath pathValues hpath + +theorem PendingCovered.of_resolveDeferredLayerValues + {coordinates : List Coordinate} {context : DeferredContext} + (hcovered : PendingCovered coordinates context) + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) (finalContext : DeferredContext) + (values : (ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) + (hresult : some (finalContext, values) ∈ support + (resolveDeferredLayerValues table index lay encoding context)) : + PendingCovered coordinates finalContext := by + rw [resolveDeferredLayerValues, mem_support_bind_iff] at hresult + obtain ⟨chainsOption, hchains, hrest⟩ := hresult + cases chainsOption with + | none => simp at hrest + | some chains => + rcases chains with ⟨afterChains, chainValues⟩ + rw [mem_support_bind_iff] at hrest + obtain ⟨pathOption, hpath, hreturn⟩ := hrest + cases pathOption with + | none => simp at hreturn + | some path => + rcases path with ⟨afterPath, pathValues⟩ + have hcontext : finalContext = afterPath := + congrArg Prod.fst (Option.some.inj hreturn) + rw [hcontext] + have hchainsCovered := hcovered.of_resolveDeferredSelectedChainFamily table lay + (treeIndexAt index lay) (leafIndexAt index lay) + (fun chainIdx : ChainIndex => chainIdx) encoding afterChains chainValues hchains + exact hchainsCovered.of_resolveDeferredLayerPathFamily table lay + (treeIndexAt index lay) (leafIndexAt index lay) + (fun level : Fin maxLayerHeight => level) afterPath pathValues hpath + +theorem PublishedValues.of_resolveDeferredLayerValues + {context : DeferredContext} (hpublished : PublishedValues context.state) + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) (finalContext : DeferredContext) + (values : (ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) + (hresult : some (finalContext, values) ∈ support + (resolveDeferredLayerValues table index lay encoding context)) : + PublishedValues finalContext.state := by + have hagrees := privateStateAgrees_resolveDeferredLayerValues table index lay encoding + context finalContext values hresult + intro coordinate hrevealed + rw [hagrees.1] + apply hpublished coordinate + rw [← hagrees.2.1] + exact hrevealed + +set_option maxRecDepth 100000 in +theorem evalDist_map_resolveDeferredLayerValues_then_finalize + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) (coordinates : List Coordinate) + (context : DeferredContext) (hvalid : context.Valid) + (hcovered : PendingCovered coordinates context) : + evalDist (do + let resolved ← resolveDeferredLayerValues table index lay encoding context + match resolved with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some (finalContext, _) => projectDeferredState <$> + finalizeResolvedCoordinates coordinates finalContext table) = + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := by + unfold resolveDeferredLayerValues + simp only [bind_assoc] + calc + _ = evalDist + (resolveDeferredSelectedChainFamily table lay (treeIndexAt index lay) + (leafIndexAt index lay) (fun chainIdx : ChainIndex => chainIdx) encoding context >>= + fun chainsOption => + match chainsOption with + | none => pure none + | some (afterChains, _) => projectDeferredState <$> + finalizeResolvedCoordinates coordinates afterChains table) := by + apply evalDist_bind_congr + intro chainsOption hchains + cases chainsOption with + | none => rfl + | some chains => + rcases chains with ⟨afterChains, chainValues⟩ + have hmiddleValid := hvalid.of_resolveDeferredSelectedChainFamily table lay + (treeIndexAt index lay) (leafIndexAt index lay) + (fun chainIdx : ChainIndex => chainIdx) encoding afterChains chainValues hchains + have hmiddleCovered := hcovered.of_resolveDeferredSelectedChainFamily table lay + (treeIndexAt index lay) (leafIndexAt index lay) + (fun chainIdx : ChainIndex => chainIdx) encoding afterChains chainValues hchains + simp only + calc + _ = evalDist (do + let path ← resolveDeferredLayerPathFamily table lay (treeIndexAt index lay) + (leafIndexAt index lay) (fun level : Fin maxLayerHeight => level) afterChains + match path with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some (finalContext, _) => projectDeferredState <$> + finalizeResolvedCoordinates coordinates finalContext table) := by + apply congrArg evalDist + simp only [bind_assoc] + apply bind_congr + intro pathOption + cases pathOption <;> simp + _ = _ := by + convert + evalDist_map_resolveDeferredLayerPathFamily_then_finalize table lay + (treeIndexAt index lay) (leafIndexAt index lay) coordinates + (fun level : Fin maxLayerHeight => level) afterChains hmiddleValid + hmiddleCovered using 1 + apply congrArg evalDist + apply bind_congr + intro pathOption + cases pathOption <;> rfl + _ = evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates context table) := by + convert + evalDist_map_resolveDeferredSelectedChainFamily_then_finalize table lay + (treeIndexAt index lay) (leafIndexAt index lay) coordinates + (fun chainIdx : ChainIndex => chainIdx) encoding context hvalid hcovered using 1 + apply congrArg evalDist + apply bind_congr + intro chainsOption + cases chainsOption <;> rfl + +noncomputable def resolveDeferredLayerValuesFamily + (table : OtsSecretIndex → HashOutput) (index : Index) : + ∀ {n : Nat}, (Fin n → Layer) → + ((position : Fin n) → ChainIndex → Digit) → DeferredContext → + ProbComp (Option (DeferredContext × + (Fin n → (ChainIndex → Digest) × (Fin maxLayerHeight → Digest)))) + | 0, _, _, context => pure (some (context, fun position => Fin.elim0 position)) + | n + 1, layers, encodings, context => do + let head ← resolveDeferredLayerValues table index (layers 0) (encodings 0) context + match head with + | none => pure none + | some (headContext, headValues) => do + let tail ← resolveDeferredLayerValuesFamily table index + (fun position : Fin n => layers position.succ) + (fun position : Fin n => encodings position.succ) headContext + match tail with + | none => pure none + | some (finalContext, tailValues) => + pure (some (finalContext, Fin.cases headValues tailValues)) + +noncomputable def finalizeProjectedResolvedCoordinates + (coordinates : List Coordinate) (context : DeferredContext) + (table : OtsSecretIndex → HashOutput) : + ProbComp (Option (LazyRevealProbe.State Coordinate)) := + projectDeferredState <$> finalizeResolvedCoordinates coordinates context table + +set_option maxRecDepth 100000 in +theorem evalDist_map_resolveDeferredLayerValuesFamily_then_finalize + (table : OtsSecretIndex → HashOutput) (index : Index) + (coordinates : List Coordinate) : + ∀ {n : Nat} (layers : Fin n → Layer) + (encodings : (position : Fin n) → ChainIndex → Digit) + (context : DeferredContext), + context.Valid → PendingCovered coordinates context → + evalDist (do + let resolved ← + resolveDeferredLayerValuesFamily table index layers encodings context + match resolved with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some (finalContext, _) => + finalizeProjectedResolvedCoordinates coordinates finalContext table) = + evalDist (finalizeProjectedResolvedCoordinates coordinates context table) + | 0, layers, encodings, context, hvalid, hcovered => by + simp [resolveDeferredLayerValuesFamily] + | n + 1, layers, encodings, context, hvalid, hcovered => by + rw [resolveDeferredLayerValuesFamily] + simp only [bind_assoc] + calc + _ = evalDist + (resolveDeferredLayerValues table index (layers 0) (encodings 0) context >>= + fun headOption => + match headOption with + | none => pure none + | some (headContext, _) => + finalizeProjectedResolvedCoordinates coordinates headContext table) := by + apply evalDist_bind_congr + intro headOption hhead + cases headOption with + | none => rfl + | some head => + rcases head with ⟨headContext, headValues⟩ + have hheadValid := hvalid.of_resolveDeferredLayerValues table index + (layers 0) (encodings 0) headContext headValues hhead + have hheadCovered := hcovered.of_resolveDeferredLayerValues table index + (layers 0) (encodings 0) headContext headValues hhead + calc + _ = evalDist (do + let tail ← resolveDeferredLayerValuesFamily table index + (fun position : Fin n => layers position.succ) + (fun position : Fin n => encodings position.succ) headContext + match tail with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some (finalContext, _) => + finalizeProjectedResolvedCoordinates coordinates finalContext table) := by + apply congrArg evalDist + simp only [bind_assoc] + apply bind_congr + intro tailOption + cases tailOption <;> rfl + _ = _ := + evalDist_map_resolveDeferredLayerValuesFamily_then_finalize table index + coordinates (fun position : Fin n => layers position.succ) + (fun position : Fin n => encodings position.succ) headContext hheadValid + hheadCovered + _ = _ := evalDist_map_resolveDeferredLayerValues_then_finalize table index + (layers 0) (encodings 0) coordinates context hvalid hcovered + +noncomputable def resolveDeferredOptionalLayerValuesFamily + (table : OtsSecretIndex → HashOutput) (index : Index) : + ∀ {n : Nat}, (Fin n → Layer) → + (Fin n → Option (ChainIndex → Digit)) → DeferredContext → + ProbComp (Option (DeferredContext × + (Fin n → Option + ((ChainIndex → Digest) × (Fin maxLayerHeight → Digest))))) + | 0, _, _, context => pure (some (context, fun position => Fin.elim0 position)) + | n + 1, layers, encodings, context => + match encodings 0 with + | none => do + let tail ← resolveDeferredOptionalLayerValuesFamily table index + (fun position : Fin n => layers position.succ) + (fun position : Fin n => encodings position.succ) context + match tail with + | none => pure none + | some (finalContext, tailValues) => + pure (some (finalContext, Fin.cases none tailValues)) + | some encoding => do + let head ← resolveDeferredLayerValues table index (layers 0) encoding context + match head with + | none => pure none + | some (headContext, headValues) => do + let tail ← resolveDeferredOptionalLayerValuesFamily table index + (fun position : Fin n => layers position.succ) + (fun position : Fin n => encodings position.succ) headContext + match tail with + | none => pure none + | some (finalContext, tailValues) => + pure (some (finalContext, Fin.cases (some headValues) tailValues)) + +set_option maxRecDepth 100000 in +theorem evalDist_map_resolveDeferredOptionalLayerValuesFamily_then_finalize + (table : OtsSecretIndex → HashOutput) (index : Index) + (coordinates : List Coordinate) : + ∀ {n : Nat} (layers : Fin n → Layer) + (encodings : Fin n → Option (ChainIndex → Digit)) + (context : DeferredContext), + context.Valid → PendingCovered coordinates context → + evalDist (do + let resolved ← + resolveDeferredOptionalLayerValuesFamily table index layers encodings context + match resolved with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some (finalContext, _) => + finalizeProjectedResolvedCoordinates coordinates finalContext table) = + evalDist (finalizeProjectedResolvedCoordinates coordinates context table) + | 0, layers, encodings, context, hvalid, hcovered => by + simp [resolveDeferredOptionalLayerValuesFamily] + | n + 1, layers, encodings, context, hvalid, hcovered => by + rw [resolveDeferredOptionalLayerValuesFamily] + cases hencoding : encodings 0 with + | none => + simp only [bind_assoc] + calc + _ = evalDist (do + let tail ← resolveDeferredOptionalLayerValuesFamily table index + (fun position : Fin n => layers position.succ) + (fun position : Fin n => encodings position.succ) context + match tail with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some (finalContext, _) => + finalizeProjectedResolvedCoordinates coordinates finalContext table) := by + apply congrArg evalDist + apply bind_congr + intro tailOption + cases tailOption <;> rfl + _ = _ := + evalDist_map_resolveDeferredOptionalLayerValuesFamily_then_finalize table index + coordinates (fun position : Fin n => layers position.succ) + (fun position : Fin n => encodings position.succ) context hvalid hcovered + | some encoding => + simp only [bind_assoc] + calc + _ = evalDist + (resolveDeferredLayerValues table index (layers 0) encoding context >>= + fun headOption => + match headOption with + | none => pure none + | some (headContext, _) => + finalizeProjectedResolvedCoordinates coordinates headContext table) := by + apply evalDist_bind_congr + intro headOption hhead + cases headOption with + | none => rfl + | some head => + rcases head with ⟨headContext, headValues⟩ + have hheadValid := hvalid.of_resolveDeferredLayerValues table index + (layers 0) encoding headContext headValues hhead + have hheadCovered := hcovered.of_resolveDeferredLayerValues table index + (layers 0) encoding headContext headValues hhead + calc + _ = evalDist (do + let tail ← resolveDeferredOptionalLayerValuesFamily table index + (fun position : Fin n => layers position.succ) + (fun position : Fin n => encodings position.succ) headContext + match tail with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some (finalContext, _) => + finalizeProjectedResolvedCoordinates coordinates finalContext + table) := by + apply congrArg evalDist + simp only [bind_assoc] + apply bind_congr + intro tailOption + cases tailOption <;> rfl + _ = _ := + evalDist_map_resolveDeferredOptionalLayerValuesFamily_then_finalize table + index coordinates (fun position : Fin n => layers position.succ) + (fun position : Fin n => encodings position.succ) headContext hheadValid + hheadCovered + _ = _ := evalDist_map_resolveDeferredLayerValues_then_finalize table index + (layers 0) encoding coordinates context hvalid hcovered + +noncomputable def resolveDeferredSelectedLayerResults + (table : OtsSecretIndex → HashOutput) (index : Index) + {n : Nat} (layers : Fin n → Layer) + (selected : Fin n → Option (Counter × (ChainIndex → Digit))) + (context : DeferredContext) : + ProbComp (Option (DeferredContext × (Fin n → Option LayerPart))) := do + let resolved ← resolveDeferredOptionalLayerValuesFamily table index layers + (fun position => (selected position).map Prod.snd) context + match resolved with + | none => pure none + | some (finalContext, values) => + pure (some (finalContext, fun position => + match selected position, values position with + | some part, some layerValues => + some (part.1, layerValues.1, layerValues.2) + | _, _ => none)) + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredSelectedLayerResults_then_finalize + (table : OtsSecretIndex → HashOutput) (index : Index) + {n : Nat} (layers : Fin n → Layer) + (selected : Fin n → Option (Counter × (ChainIndex → Digit))) + (coordinates : List Coordinate) (context : DeferredContext) + (hvalid : context.Valid) (hcovered : PendingCovered coordinates context) : + evalDist (do + let resolved ← + resolveDeferredSelectedLayerResults table index layers selected context + match resolved with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some (finalContext, _) => + finalizeProjectedResolvedCoordinates coordinates finalContext table) = + evalDist (finalizeProjectedResolvedCoordinates coordinates context table) := by + unfold resolveDeferredSelectedLayerResults + simp only [bind_assoc] + calc + _ = evalDist (do + let resolved ← resolveDeferredOptionalLayerValuesFamily table index layers + (fun position => (selected position).map Prod.snd) context + match resolved with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some (finalContext, _) => + finalizeProjectedResolvedCoordinates coordinates finalContext table) := by + apply congrArg evalDist + apply bind_congr + intro resolved + cases resolved <;> rfl + _ = _ := evalDist_map_resolveDeferredOptionalLayerValuesFamily_then_finalize table index + coordinates layers (fun position => (selected position).map Prod.snd) context hvalid hcovered + +noncomputable def scheduleResolvedSelectedLayerResult + (index : Index) {n : Nat} (layers : Fin n → Layer) : + Option (ResolvedRunResult + ((Fin n → Option (Counter × (ChainIndex → Digit))) × SplitHashCache)) → + ProbComp (Option (ResolvedRunResult + ((Fin n → Option LayerPart) × SplitHashCache))) + | none => pure none + | some result => do + let resolved ← resolveDeferredSelectedLayerResults result.table index layers + result.value.1 result.context + match resolved with + | none => pure none + | some (finalContext, values) => + pure (some ⟨finalContext, result.remaining, (values, result.value.2), result.table⟩) + +set_option maxRecDepth 100000 in +theorem evalDist_scheduleResolvedSelectedLayerResult_then_finalize + (index : Index) {n : Nat} (layers : Fin n → Layer) + (result : ResolvedRunResult + ((Fin n → Option (Counter × (ChainIndex → Digit))) × SplitHashCache)) + (coordinates : List Coordinate) (hvalid : result.context.Valid) + (hcovered : PendingCovered coordinates result.context) : + evalDist (do + let scheduled ← scheduleResolvedSelectedLayerResult index layers (some result) + match scheduled with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some scheduled => + finalizeProjectedResolvedCoordinates coordinates scheduled.context scheduled.table) = + evalDist (finalizeProjectedResolvedCoordinates coordinates result.context result.table) := by + unfold scheduleResolvedSelectedLayerResult + simp only [bind_assoc] + calc + _ = evalDist (do + let resolved ← resolveDeferredSelectedLayerResults result.table index layers + result.value.1 result.context + match resolved with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some (finalContext, _) => + finalizeProjectedResolvedCoordinates coordinates finalContext result.table) := by + apply congrArg evalDist + apply bind_congr + intro resolved + cases resolved <;> rfl + _ = _ := evalDist_resolveDeferredSelectedLayerResults_then_finalize result.table index layers + result.value.1 coordinates result.context hvalid hcovered + +noncomputable def runDeferredResolvedLayers + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + {n : Nat} (layers : Fin n → Layer) (context : DeferredContext) + (fuel : Nat) (cache : SplitHashCache) : + ProbComp (Option (ResolvedRunResult + ((Fin n → Option LayerPart) × SplitHashCache))) := + runResolvedFromTable context fuel table + ((sequenceFin fun position => + maskedSignLayer parameter ftsSecret index (layers position)).run cache) >>= + scheduleResolvedSelectedLayerResult index layers + +set_option maxRecDepth 100000 in +theorem evalDist_runDeferredResolvedLayers_then_finalize + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + {n : Nat} (layers : Fin n → Layer) (context : DeferredContext) + (fuel : Nat) (cache : SplitHashCache) (coordinates : List Coordinate) + (hvalid : context.Valid) (hcovered : PendingCovered coordinates context) : + evalDist (do + let scheduled ← runDeferredResolvedLayers parameter table ftsSecret index layers + context fuel cache + match scheduled with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some scheduled => + finalizeProjectedResolvedCoordinates coordinates scheduled.context scheduled.table) = + evalDist (do + let selected ← runResolvedFromTable context fuel table + ((sequenceFin fun position => + maskedSignLayer parameter ftsSecret index (layers position)).run cache) + match selected with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some selected => + finalizeProjectedResolvedCoordinates coordinates selected.context selected.table) := by + unfold runDeferredResolvedLayers + simp only [bind_assoc] + apply evalDist_bind_congr + intro selected hselected + cases selected with + | none => simp [scheduleResolvedSelectedLayerResult] + | some result => + have hprobeFree : ProbeFree (sequenceFin fun position => + maskedSignLayer parameter ftsSecret index (layers position)) := + sequenceFin_probeFree _ fun position => + maskedSignLayer_probeFree parameter ftsSecret index (layers position) + have hinvariants := valid_pendingCovered_of_mem_runResolvedFromTable_of_probeFree + ((sequenceFin fun position => + maskedSignLayer parameter ftsSecret index (layers position)).run cache) + context fuel table result coordinates (hprobeFree cache) hvalid hcovered hselected + exact evalDist_scheduleResolvedSelectedLayerResult_then_finalize index layers result + coordinates hinvariants.1 hinvariants.2 + +def ResolveLayerValuesRel (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ordinaryCache : QueryCache HashSpec) : + Option (DeferredContext × + ((ChainIndex → Digest) × (Fin maxLayerHeight → Digest))) → + ((ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) × + QueryCache HashSpec → Prop + | none, _ => True + | some (context, values), (concreteValues, cache) => + values = concreteValues ∧ + ResolvedContextInvariant parameter table context ordinaryCache cache + +noncomputable def resolvedPositionComputation + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) : + Position → OracleComp HashSpec Digest + | .chain lay tree leafIdx chainIdx step => + chainWalk parameter lay tree leafIdx chainIdx 0 (step.val + 1) + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + | .leaf lay tree leafIdx => do + let endpoints ← oneTimePublicKey parameter lay tree leafIdx + (fun chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + leafHash parameter lay tree leafIdx endpoints + | .node lay tree level nodeIdx => + treeNode parameter lay tree + (fun leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + (level.val + 1) nodeIdx.val + | _ => pure 0 + +def VisibleResolvedComputationsCached (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (cache : QueryCache HashSpec) : Prop := + ∀ position output, ResolvableOtsPosition position → + context.state.values (.position position) = some output → + CachedRun cache (fromCache cache) + (resolvedPositionComputation parameter table position) ∧ + evalWithAnswerFn (fromCache cache) + (resolvedPositionComputation parameter table position) = truncateHash output + +theorem VisibleResolvedComputationsCached.mono + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {initial final : QueryCache HashSpec} + (hclosed : VisibleResolvedComputationsCached parameter table context initial) + (hle : initial ≤ final) : + VisibleResolvedComputationsCached parameter table context final := by + intro position output hresolvable hvalue + obtain ⟨hcached, heval⟩ := hclosed position output hresolvable hvalue + have hcachedFinal := + (hcached.changeAnswerFn (agreesWithFn_fromCache initial) + (agreesWithFn_fromCache_of_le hle)).mono hle + refine ⟨hcachedFinal, ?_⟩ + calc + evalWithAnswerFn (fromCache final) + (resolvedPositionComputation parameter table position) = + evalWithAnswerFn (fromCache initial) + (resolvedPositionComputation parameter table position) := + hcached.eval_eq (agreesWithFn_fromCache initial) + (agreesWithFn_fromCache_of_le hle) |>.symm + _ = truncateHash output := heval + +theorem VisibleResolvedComputationsCached.of_state_values_eq + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left right : DeferredContext} {cache : QueryCache HashSpec} + (hclosed : VisibleResolvedComputationsCached parameter table left cache) + (hvalues : right.state.values = left.state.values) : + VisibleResolvedComputationsCached parameter table right cache := by + intro position output hresolvable hvalue + apply hclosed position output hresolvable + rw [← hvalues] + exact hvalue + +theorem VisibleResolvedComputationsCached.of_position_values_eq + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left right : DeferredContext} {cache : QueryCache HashSpec} + (hclosed : VisibleResolvedComputationsCached parameter table left cache) + (hvalues : ∀ position, + right.state.values (.position position) = left.state.values (.position position)) : + VisibleResolvedComputationsCached parameter table right cache := by + intro position output hresolvable hvalue + apply hclosed position output hresolvable + rw [← hvalues] + exact hvalue + +theorem visibleResolvedComputationsCached_empty + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (values : DeferredStructuralValues) (cache : QueryCache HashSpec) : + VisibleResolvedComputationsCached parameter table + { state := LazyRevealProbe.State.empty, values := values } cache := by + intro position output hresolvable hvalue + simp [LazyRevealProbe.State.empty] at hvalue + +theorem TableInputAvailable.changeTable + {left right : Coordinate → HashOutput} + {state : LazyRevealProbe.State Coordinate} {coordinate : Coordinate} + (havailable : TableInputAvailable left state coordinate) + (hagrees : ∀ other output, state.values other = some output → right other = output) : + TableInputAvailable right state coordinate := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => simp [TableInputAvailable] at havailable + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + by_cases hzero : step.val = 0 + · have hvalue : state.values (.chainStart lay tree leafIdx chainIdx) = + some (left (.chainStart lay tree leafIdx chainIdx)) := by + simpa [TableInputAvailable, hzero] using havailable + simpa [TableInputAvailable, hzero, hagrees _ _ hvalue] using hvalue + · have havailable' : ∀ child, + child ∈ (Position.chain lay tree leafIdx chainIdx step).children → + state.values (.position child) = some (left (.position child)) := by + simpa [TableInputAvailable, hzero] using havailable + simp only [TableInputAvailable, if_neg hzero] + intro child hchild + have hvalue := havailable' child hchild + simpa [hagrees _ _ hvalue] using hvalue + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + intro child hchild + have hvalue := havailable child hchild + simpa [hagrees _ _ hvalue] using hvalue + +theorem tableInput_eq_of_available + (parameter : PublicParameter) (left right : Coordinate → HashOutput) + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (hleft : TableInputAvailable left state coordinate) + (hright : TableInputAvailable right state coordinate) : + tableInput parameter left coordinate = tableInput parameter right coordinate := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => simp [TableInputAvailable] at hleft + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + by_cases hzero : step.val = 0 + · have hleftValue : state.values (.chainStart lay tree leafIdx chainIdx) = + some (left (.chainStart lay tree leafIdx chainIdx)) := by + simpa [TableInputAvailable, hzero] using hleft + have hrightValue : state.values (.chainStart lay tree leafIdx chainIdx) = + some (right (.chainStart lay tree leafIdx chainIdx)) := by + simpa [TableInputAvailable, hzero] using hright + have heq := Option.some.inj (hleftValue.symm.trans hrightValue) + simp [tableInput, tablePayload, hzero, heq] + · have hchildren : ∀ child, + child ∈ (Position.chain lay tree leafIdx chainIdx step).children → + left (.position child) = right (.position child) := by + have hleft' : ∀ child, + child ∈ (Position.chain lay tree leafIdx chainIdx step).children → + state.values (.position child) = some (left (.position child)) := by + simpa [TableInputAvailable, hzero] using hleft + have hright' : ∀ child, + child ∈ (Position.chain lay tree leafIdx chainIdx step).children → + state.values (.position child) = some (right (.position child)) := by + simpa [TableInputAvailable, hzero] using hright + intro child hchild + have hl := hleft' child hchild + have hr := hright' child hchild + exact Option.some.inj (hl.symm.trans hr) + have hmap : + (Position.chain lay tree leafIdx chainIdx step).children.map + (tableValue left) = + (Position.chain lay tree leafIdx chainIdx step).children.map + (tableValue right) := by + apply List.map_congr_left + intro child hchild + simp only [tableValue, hchildren child hchild] + simp [tableInput, tablePayload, hzero, hmap] + | leaf lay tree leafIdx => + have hchildren : ∀ child, + child ∈ (Position.leaf lay tree leafIdx).children → + left (.position child) = right (.position child) := by + intro child hchild + exact Option.some.inj ((hleft child hchild).symm.trans (hright child hchild)) + have hmap : + (Position.leaf lay tree leafIdx).children.map (tableValue left) = + (Position.leaf lay tree leafIdx).children.map (tableValue right) := by + apply List.map_congr_left + intro child hchild + simp only [tableValue, hchildren child hchild] + simp [tableInput, tablePayload, hmap] + | node lay tree level nodeIdx => + have hchildren : ∀ child, + child ∈ (Position.node lay tree level nodeIdx).children → + left (.position child) = right (.position child) := by + intro child hchild + exact Option.some.inj ((hleft child hchild).symm.trans (hright child hchild)) + have hmap : + (Position.node lay tree level nodeIdx).children.map (tableValue left) = + (Position.node lay tree level nodeIdx).children.map (tableValue right) := by + apply List.map_congr_left + intro child hchild + simp only [tableValue, hchildren child hchild] + simp [tableInput, tablePayload, hmap] + | ftsLeaf index tree leafIdx => + have hchildren : ∀ child, + child ∈ (Position.ftsLeaf index tree leafIdx).children → + left (.position child) = right (.position child) := by + intro child hchild + exact Option.some.inj ((hleft child hchild).symm.trans (hright child hchild)) + have hmap : + (Position.ftsLeaf index tree leafIdx).children.map (tableValue left) = + (Position.ftsLeaf index tree leafIdx).children.map (tableValue right) := by + apply List.map_congr_left + intro child hchild + simp only [tableValue, hchildren child hchild] + simp [tableInput, tablePayload, hmap] + | ftsNode index tree level nodeIdx => + have hchildren : ∀ child, + child ∈ (Position.ftsNode index tree level nodeIdx).children → + left (.position child) = right (.position child) := by + intro child hchild + exact Option.some.inj ((hleft child hchild).symm.trans (hright child hchild)) + have hmap : + (Position.ftsNode index tree level nodeIdx).children.map (tableValue left) = + (Position.ftsNode index tree level nodeIdx).children.map (tableValue right) := by + apply List.map_congr_left + intro child hchild + simp only [tableValue, hchildren child hchild] + simp [tableInput, tablePayload, hmap] + | ftsRoots index => + have hchildren : ∀ child, + child ∈ (Position.ftsRoots index).children → + left (.position child) = right (.position child) := by + intro child hchild + exact Option.some.inj ((hleft child hchild).symm.trans (hright child hchild)) + have hmap : + (Position.ftsRoots index).children.map (tableValue left) = + (Position.ftsRoots index).children.map (tableValue right) := by + apply List.map_congr_left + intro child hchild + simp only [tableValue, hchildren child hchild] + simp [tableInput, tablePayload, hmap] + +theorem resolvedChainComputation_run_eq_finalQuery_of_available + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (completion : Coordinate → HashOutput) (context : DeferredContext) + (cache : QueryCache HashSpec) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (step : ChainStep) + (input : HashInput) + (hcompletion : DeferredCompletion table context completion) + (havailable : TableInputAvailable completion context.state + (.position (.chain lay tree leafIdx chainIdx step))) + (hclosed : VisibleResolvedComputationsCached parameter table context cache) + (hinput : input = tableInput parameter completion + (.position (.chain lay tree leafIdx chainIdx step))) : + (simulateQ (randomOracle : QueryImpl HashSpec _) + (resolvedPositionComputation parameter table + (.chain lay tree leafIdx chainIdx step))).run cache = + ((randomOracle input).run cache >>= fun result => + pure (truncateHash result.1, result.2)) := by + by_cases hzero : step.val = 0 + · have hstep : step = ⟨0, by norm_num [chainLength, winternitzBits]⟩ := Fin.ext hzero + have hstart : truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩) = + truncateHash (completion (.chainStart lay tree leafIdx chainIdx)) := by + simpa [OtsSecretIndex.coordinate] using congrArg truncateHash + (hcompletion.2.2.2 ⟨lay, tree, leafIdx, chainIdx⟩).symm + have hquery : tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx step) + (digestBytes (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩))) = input := by + rw [hinput, tableInput, tablePayload, if_pos hzero, Position.domain, hstart] + have hquery' : tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx + ⟨0, by norm_num [chainLength, winternitzBits]⟩) + (digestBytes (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩))) = input := by + simpa only [hstep] using hquery + rw [resolvedPositionComputation, hstep] + simp only [chainWalk, Nat.zero_add, pure_bind] + rw [dif_pos (show 0 < chainLength - 1 by norm_num [chainLength, winternitzBits])] + simp only [tweakableHash, simulateQ_bind, StateT.run_bind, + simulateQ_pure, StateT.run_pure] + rw [hquery'] + have horacle : simulateQ (randomOracle : QueryImpl HashSpec _) + (oracleHash input) = randomOracle input := by + simpa only [oracleHash, HasQuery.instOfMonadLift_query, simulateQ_spec_query] + rw [horacle] + · have hpositive : 0 < step.val := Nat.pos_of_ne_zero hzero + let previous : ChainStep := ⟨step.val - 1, by omega⟩ + have hpreviousMem : Position.chain lay tree leafIdx chainIdx previous ∈ + (Position.chain lay tree leafIdx chainIdx step).children := by + simp [Position.children, hpositive, previous] + have havailable' : ∀ child, + child ∈ (Position.chain lay tree leafIdx chainIdx step).children → + context.state.values (.position child) = some (completion (.position child)) := by + simpa [TableInputAvailable, hzero] using havailable + have hpreviousState := havailable' + (.chain lay tree leafIdx chainIdx previous) hpreviousMem + have hprevious := hclosed (.chain lay tree leafIdx chainIdx previous) + (completion (.position (.chain lay tree leafIdx chainIdx previous))) + (by simp [ResolvableOtsPosition]) hpreviousState + have hprefixEq : step.val = previous.val + 1 := by + simp [previous] + omega + have hprefixComputation : + resolvedPositionComputation parameter table + (.chain lay tree leafIdx chainIdx previous) = + chainWalk parameter lay tree leafIdx chainIdx 0 step.val + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) := by + simp [resolvedPositionComputation, hprefixEq] + have hprefixRun := simulateQ_randomOracle_run_eq_pure_of_cachedRun + (agreesWithFn_fromCache cache) hprevious.1 + rw [hprefixComputation] at hprefixRun + have hpreviousValue : evalWithAnswerFn (fromCache cache) + (chainWalk parameter lay tree leafIdx chainIdx 0 step.val + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩))) = + truncateHash (completion (.position + (.chain lay tree leafIdx chainIdx previous))) := by + rw [← hprefixComputation] + exact hprevious.2 + have hquery : tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx step) + (digestBytes (truncateHash (completion (.position + (.chain lay tree leafIdx chainIdx previous))))) = input := by + rw [hinput, tableInput, tablePayload, if_neg hzero, Position.domain] + simp [Position.children, hpositive, previous, tableValue] + rw [resolvedPositionComputation, + show step.val + 1 = step.val + 1 by rfl, + chainWalk_add parameter lay tree leafIdx chainIdx 0 step.val 1] + rw [simulateQ_bind, StateT.run_bind, hprefixRun] + simp only [pure_bind] + rw [hpreviousValue] + rw [chainWalk] + rw [chainWalk] + simp only [Nat.zero_add, Nat.add_zero, pure_bind] + rw [dif_pos (show step.val < chainLength - 1 by have := step.isLt; omega)] + simp only [tweakableHash, simulateQ_bind, StateT.run_bind, + simulateQ_pure, StateT.run_pure] + have hquery' : tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx + ⟨step.val, by have := step.isLt; omega⟩) + (digestBytes (truncateHash (completion (.position + (.chain lay tree leafIdx chainIdx previous))))) = input := by + simpa only [Fin.eta] using hquery + rw [hquery'] + have horacle : simulateQ (randomOracle : QueryImpl HashSpec _) + (oracleHash input) = randomOracle input := by + simpa only [oracleHash, HasQuery.instOfMonadLift_query, simulateQ_spec_query] + rw [horacle] + +theorem resolvedLeafComputation_run_eq_finalQuery_of_available + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (completion : Coordinate → HashOutput) (context : DeferredContext) + (cache : QueryCache HashSpec) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (input : HashInput) + (hcompletion : DeferredCompletion table context completion) + (havailable : TableInputAvailable completion context.state + (.position (.leaf lay tree leafIdx))) + (hclosed : VisibleResolvedComputationsCached parameter table context cache) + (hinput : input = tableInput parameter completion + (.position (.leaf lay tree leafIdx))) : + (simulateQ (randomOracle : QueryImpl HashSpec _) + (resolvedPositionComputation parameter table (.leaf lay tree leafIdx))).run cache = + ((randomOracle input).run cache >>= fun result => + pure (truncateHash result.1, result.2)) := by + let endpointPosition := fun chainIdx : ChainIndex => + Position.chain lay tree leafIdx chainIdx Position.lastChainStep + have havailable' : ∀ chainIdx, + context.state.values (.position (endpointPosition chainIdx)) = + some (completion (.position (endpointPosition chainIdx))) := by + intro chainIdx + apply havailable (endpointPosition chainIdx) + simp [endpointPosition, Position.children] + have hcomponent : ∀ chainIdx, + CachedRun cache (fromCache cache) + (chainWalk parameter lay tree leafIdx chainIdx 0 (chainLength - 1) + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩))) ∧ + evalWithAnswerFn (fromCache cache) + (chainWalk parameter lay tree leafIdx chainIdx 0 (chainLength - 1) + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩))) = + truncateHash (completion (.position (endpointPosition chainIdx))) := by + intro chainIdx + have hendpoint := hclosed (endpointPosition chainIdx) + (completion (.position (endpointPosition chainIdx))) + (by simp [endpointPosition, ResolvableOtsPosition]) (havailable' chainIdx) + simpa [endpointPosition, resolvedPositionComputation, Position.lastChainStep, + chainLength, winternitzBits] using hendpoint + have hpublicCached : CachedRun cache (fromCache cache) + (oneTimePublicKey parameter lay tree leafIdx + (fun chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩))) := by + unfold oneTimePublicKey + exact CachedRun.sequenceFin _ fun chainIdx => (hcomponent chainIdx).1 + have hpublicRun := simulateQ_randomOracle_run_eq_pure_of_cachedRun + (agreesWithFn_fromCache cache) hpublicCached + have hpublicValue : evalWithAnswerFn (fromCache cache) + (oneTimePublicKey parameter lay tree leafIdx + (fun chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩))) = + fun chainIdx => truncateHash (completion (.position (endpointPosition chainIdx))) := by + rw [eval_oneTimePublicKey] + funext chainIdx + exact (hcomponent chainIdx).2 + have hquery : tweakableHashInput parameter (.leaf lay tree leafIdx) + (leafPayload fun chainIdx => + truncateHash (completion (.position (endpointPosition chainIdx)))) = input := by + have hleafInput := leafInput_eq_tableInput_of_completion parameter table lay tree leafIdx + context + (fun chainIdx => truncateHash (completion (.position (endpointPosition chainIdx)))) + (fun chainIdx => by + refine ⟨completion (.position (endpointPosition chainIdx)), ?_, rfl⟩ + unfold DeferredContext.positionValue + rw [havailable' chainIdx]) + completion hcompletion + exact hleafInput.trans hinput.symm + rw [resolvedPositionComputation, simulateQ_bind, StateT.run_bind, hpublicRun] + simp only [pure_bind] + rw [hpublicValue] + simp only [leafHash, tweakableHash, simulateQ_bind, StateT.run_bind, + simulateQ_pure, StateT.run_pure] + rw [hquery] + have horacle : simulateQ (randomOracle : QueryImpl HashSpec _) + (oracleHash input) = randomOracle input := by + simpa only [oracleHash, HasQuery.instOfMonadLift_query, simulateQ_spec_query] + rw [horacle] + +theorem resolvedPositionComputation_deferredTreePosition + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) + (hlevel : level ≤ maxLayerHeight) (hnode : nodeIdx < 2 ^ maxLayerHeight) : + resolvedPositionComputation parameter table + (deferredTreePosition lay tree level nodeIdx hlevel) = + treeNode parameter lay tree + (fun leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) level nodeIdx := by + cases level with + | zero => simp [deferredTreePosition, resolvedPositionComputation, treeNode_zero_eq] + | succ current => + simp [deferredTreePosition, resolvedPositionComputation, leafOfNat, + Nat.mod_eq_of_lt hnode] + +theorem resolvableOtsPosition_deferredTreePosition + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) + (hlevel : level ≤ maxLayerHeight) + (hspan : 2 ^ level * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) : + ResolvableOtsPosition (deferredTreePosition lay tree level nodeIdx hlevel) := by + have hnode : nodeIdx < 2 ^ maxLayerHeight := by + have hpow : 0 < 2 ^ level := pow_pos (by omega) _ + nlinarith + cases level with + | zero => simp [deferredTreePosition, ResolvableOtsPosition] + | succ current => + simpa [deferredTreePosition, ResolvableOtsPosition, leafOfNat, + Nat.mod_eq_of_lt hnode] using hspan + +set_option maxRecDepth 100000 in +theorem resolvedNodeComputation_run_eq_finalQuery_of_available + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (completion : Coordinate → HashOutput) (context : DeferredContext) + (cache : QueryCache HashSpec) (lay : Layer) (tree : TreeIndex) + (level : Fin maxLayerHeight) (nodeIdx : LeafIndex) (input : HashInput) + (hcompletion : DeferredCompletion table context completion) + (hresolvable : ResolvableOtsPosition (.node lay tree level nodeIdx)) + (havailable : TableInputAvailable completion context.state + (.position (.node lay tree level nodeIdx))) + (hclosed : VisibleResolvedComputationsCached parameter table context cache) + (hinput : input = tableInput parameter completion + (.position (.node lay tree level nodeIdx))) : + (simulateQ (randomOracle : QueryImpl HashSpec _) + (resolvedPositionComputation parameter table + (.node lay tree level nodeIdx))).run cache = + ((randomOracle input).run cache >>= fun result => + pure (truncateHash result.1, result.2)) := by + let leftPosition := deferredTreePosition lay tree level.val (2 * nodeIdx.val) + (by have := level.isLt; omega) + let rightPosition := deferredTreePosition lay tree level.val (2 * nodeIdx.val + 1) + (by have := level.isLt; omega) + have hspan : 2 ^ (level.val + 1) * (nodeIdx.val + 1) ≤ 2 ^ maxLayerHeight := by + simpa [ResolvableOtsPosition] using hresolvable + have hleftSpan : 2 ^ level.val * (2 * nodeIdx.val + 1) ≤ 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + calc + 2 ^ level.val * (2 * nodeIdx.val + 1) ≤ + 2 ^ level.val * (2 * (nodeIdx.val + 1)) := by + exact Nat.mul_le_mul_left _ (by omega) + _ = 2 ^ level.val * 2 * (nodeIdx.val + 1) := by ring + _ ≤ 2 ^ maxLayerHeight := hspan + have hrightSpan : 2 ^ level.val * (2 * nodeIdx.val + 1 + 1) ≤ + 2 ^ maxLayerHeight := by + rw [pow_succ] at hspan + calc + 2 ^ level.val * (2 * nodeIdx.val + 1 + 1) = + 2 ^ level.val * 2 * (nodeIdx.val + 1) := by ring + _ ≤ 2 ^ maxLayerHeight := hspan + have hleftNode : 2 * nodeIdx.val < 2 ^ maxLayerHeight := by + have hpow : 0 < 2 ^ level.val := pow_pos (by omega) _ + nlinarith + have hrightNode : 2 * nodeIdx.val + 1 < 2 ^ maxLayerHeight := by + have hpow : 0 < 2 ^ level.val := pow_pos (by omega) _ + nlinarith + have hchildren : (Position.node lay tree level nodeIdx).children = + [leftPosition, rightPosition] := by + dsimp [leftPosition, rightPosition] + by_cases hzero : level.val = 0 + · have hlevelEq : level = ⟨0, by have := level.isLt; omega⟩ := Fin.ext hzero + rw [hlevelEq] + simp [Position.children, deferredTreePosition, hrightNode, leafOfNat, + Nat.mod_eq_of_lt hleftNode, Nat.mod_eq_of_lt hrightNode] + · obtain ⟨current, hcurrent⟩ := Nat.exists_eq_succ_of_ne_zero hzero + have hlevelEq : level = ⟨current + 1, by have := level.isLt; omega⟩ := Fin.ext hcurrent + rw [hlevelEq] + simp [Position.children, deferredTreePosition, hrightNode, leafOfNat, + Nat.mod_eq_of_lt hleftNode, Nat.mod_eq_of_lt hrightNode] + have hleftState : context.state.values (.position leftPosition) = + some (completion (.position leftPosition)) := by + apply havailable leftPosition + rw [hchildren] + simp + have hrightState : context.state.values (.position rightPosition) = + some (completion (.position rightPosition)) := by + apply havailable rightPosition + rw [hchildren] + simp + have hleftResolvable : ResolvableOtsPosition leftPosition := by + exact resolvableOtsPosition_deferredTreePosition lay tree level.val + (2 * nodeIdx.val) (by have := level.isLt; omega) hleftSpan + have hrightResolvable : ResolvableOtsPosition rightPosition := by + exact resolvableOtsPosition_deferredTreePosition lay tree level.val + (2 * nodeIdx.val + 1) (by have := level.isLt; omega) hrightSpan + have hleft := hclosed leftPosition (completion (.position leftPosition)) + hleftResolvable hleftState + have hright := hclosed rightPosition (completion (.position rightPosition)) + hrightResolvable hrightState + have hleftComputation := resolvedPositionComputation_deferredTreePosition parameter table + lay tree level.val (2 * nodeIdx.val) (by have := level.isLt; omega) hleftNode + have hrightComputation := resolvedPositionComputation_deferredTreePosition parameter table + lay tree level.val (2 * nodeIdx.val + 1) (by have := level.isLt; omega) hrightNode + have hleftCached : CachedRun cache (fromCache cache) + (treeNode parameter lay tree + (fun leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + level.val (2 * nodeIdx.val)) := by + rw [← hleftComputation] + exact hleft.1 + have hrightCached : CachedRun cache (fromCache cache) + (treeNode parameter lay tree + (fun leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + level.val (2 * nodeIdx.val + 1)) := by + rw [← hrightComputation] + exact hright.1 + have hleftRun := simulateQ_randomOracle_run_eq_pure_of_cachedRun + (agreesWithFn_fromCache cache) hleftCached + have hrightRun := simulateQ_randomOracle_run_eq_pure_of_cachedRun + (agreesWithFn_fromCache cache) hrightCached + have hleftValue : evalWithAnswerFn (fromCache cache) + (treeNode parameter lay tree + (fun leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + level.val (2 * nodeIdx.val)) = + truncateHash (completion (.position leftPosition)) := by + rw [← hleftComputation] + exact hleft.2 + have hrightValue : evalWithAnswerFn (fromCache cache) + (treeNode parameter lay tree + (fun leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + level.val (2 * nodeIdx.val + 1)) = + truncateHash (completion (.position rightPosition)) := by + rw [← hrightComputation] + exact hright.2 + have hleftPositionValue : context.positionValue leftPosition = + some (completion (.position leftPosition)) := by + unfold DeferredContext.positionValue + rw [hleftState] + have hrightPositionValue : context.positionValue rightPosition = + some (completion (.position rightPosition)) := by + unfold DeferredContext.positionValue + rw [hrightState] + have hquery : tweakableHashInput parameter + (.node lay tree (level.val + 1) nodeIdx.val) + (nodePayload (truncateHash (completion (.position leftPosition))) + (truncateHash (completion (.position rightPosition)))) = input := by + have hnodeInput := nodeInput_eq_tableInput_of_completion parameter table lay tree + level.val nodeIdx.val level.isLt hspan context + (truncateHash (completion (.position leftPosition))) + (truncateHash (completion (.position rightPosition))) + (completion (.position leftPosition)) (completion (.position rightPosition)) + (by simpa [leftPosition] using hleftPositionValue) + (by simpa [rightPosition] using hrightPositionValue) + rfl rfl completion hcompletion + have htarget : Position.node lay tree ⟨level.val, level.isLt⟩ + (leafOfNat nodeIdx.val) = Position.node lay tree level nodeIdx := by + simp [leafOfNat_val] + rw [htarget] at hnodeInput + exact hnodeInput.trans hinput.symm + rw [resolvedPositionComputation, treeNode_succ_eq, simulateQ_bind, StateT.run_bind, + hleftRun] + simp only [pure_bind] + rw [simulateQ_bind, StateT.run_bind, hrightRun] + simp only [pure_bind] + rw [hleftValue, hrightValue] + simp only [tweakableHash, simulateQ_bind, StateT.run_bind, + simulateQ_pure, StateT.run_pure] + rw [hquery] + have horacle : simulateQ (randomOracle : QueryImpl HashSpec _) + (oracleHash input) = randomOracle input := by + simpa only [oracleHash, HasQuery.instOfMonadLift_query, simulateQ_spec_query] + rw [horacle] + +theorem resolvedPositionComputation_run_eq_finalQuery_of_available + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (completion : Coordinate → HashOutput) (context : DeferredContext) + (cache : QueryCache HashSpec) (position : Position) (input : HashInput) + (hcompletion : DeferredCompletion table context completion) + (hresolvable : ResolvableOtsPosition position) + (havailable : TableInputAvailable completion context.state (.position position)) + (hclosed : VisibleResolvedComputationsCached parameter table context cache) + (hinput : input = tableInput parameter completion (.position position)) : + (simulateQ (randomOracle : QueryImpl HashSpec _) + (resolvedPositionComputation parameter table position)).run cache = + ((randomOracle input).run cache >>= fun result => + pure (truncateHash result.1, result.2)) := by + cases position with + | chain lay tree leafIdx chainIdx step => + exact resolvedChainComputation_run_eq_finalQuery_of_available parameter table completion + context cache lay tree leafIdx chainIdx step input hcompletion havailable hclosed hinput + | leaf lay tree leafIdx => + exact resolvedLeafComputation_run_eq_finalQuery_of_available parameter table completion + context cache lay tree leafIdx input hcompletion havailable hclosed hinput + | node lay tree level nodeIdx => + exact resolvedNodeComputation_run_eq_finalQuery_of_available parameter table completion + context cache lay tree level nodeIdx input hcompletion hresolvable havailable hclosed hinput + | ftsLeaf index tree leafIdx => simp [ResolvableOtsPosition] at hresolvable + | ftsNode index tree level nodeIdx => simp [ResolvableOtsPosition] at hresolvable + | ftsRoots index => simp [ResolvableOtsPosition] at hresolvable + +noncomputable def resolvedRevealComputation + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (position : Position) (input : HashInput) : OracleComp HashSpec Digest := by + classical + exact if ResolvableOtsPosition position then + resolvedPositionComputation parameter table position + else + do + let output ← oracleHash input + pure (truncateHash output) + +theorem resolvedRevealComputation_run_eq_finalQuery_of_available + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (completion : Coordinate → HashOutput) (context : DeferredContext) + (cache : QueryCache HashSpec) (position : Position) (input : HashInput) + (hcompletion : DeferredCompletion table context completion) + (havailable : TableInputAvailable completion context.state (.position position)) + (hclosed : VisibleResolvedComputationsCached parameter table context cache) + (hinput : input = tableInput parameter completion (.position position)) : + (simulateQ (randomOracle : QueryImpl HashSpec _) + (resolvedRevealComputation parameter table position input)).run cache = + ((randomOracle input).run cache >>= fun result => + pure (truncateHash result.1, result.2)) := by + classical + by_cases hresolvable : ResolvableOtsPosition position + · simpa [resolvedRevealComputation, hresolvable] using + resolvedPositionComputation_run_eq_finalQuery_of_available parameter table completion + context cache position input hcompletion hresolvable havailable hclosed hinput + · simp only [resolvedRevealComputation, hresolvable, ↓reduceIte, oracleHash, + simulateQ_bind, HasQuery.instOfMonadLift_query, simulateQ_spec_query, simulateQ_pure, + StateT.run_bind, StateT.run_pure] + +set_option maxRecDepth 100000 in +theorem relTriple_resolveDeferredPosition_chronological + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (position : Position) (context : DeferredContext) + (ordinaryCache cache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context ordinaryCache cache) + (hresolvable : ResolvableOtsPosition position) : + RelTriple + (resolveDeferredPosition table position context) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (resolvedPositionComputation parameter table position)).run cache) + (ResolvePositionRel parameter table ordinaryCache position) := by + cases position with + | chain lay tree leafIdx chainIdx step => + have hchain := relTriple_resolveDeferredChainPrefix_chronological parameter table lay tree + leafIdx chainIdx context ordinaryCache cache hinvariant (step.val + 1) + (by have := step.isLt; omega) + apply relTriple_post_mono hchain + intro leftResult rightResult hrelation + cases leftResult with + | none => trivial + | some resolved => + rcases rightResult with ⟨value, finalCache⟩ + rcases hrelation with ⟨hvalue, hcontext, htip⟩ + refine ⟨hvalue, hcontext, ?_⟩ + rcases htip with ⟨hzero, _⟩ | ⟨previous, hprevious, hposition⟩ + · have : 0 < step.val + 1 := by omega + omega + · have heq : previous = step := by + apply Fin.ext + omega + simpa [heq] using hposition + | leaf lay tree leafIdx => + simpa [resolveDeferredPosition, resolvedPositionComputation] using + relTriple_resolveDeferredOtsLeaf_chronological parameter table lay tree leafIdx + context ordinaryCache cache hinvariant + | node lay tree level nodeIdx => + have hnode := relTriple_resolveDeferredTreeNode_chronological parameter table lay tree + (level.val + 1) nodeIdx.val (by have := level.isLt; omega) hresolvable context + ordinaryCache cache hinvariant + simpa [resolveDeferredPosition, resolvedPositionComputation, deferredTreePosition, + leafOfNat_val] using hnode + | ftsLeaf index tree leafIdx => simp [ResolvableOtsPosition] at hresolvable + | ftsNode index tree level nodeIdx => simp [ResolvableOtsPosition] at hresolvable + | ftsRoots index => simp [ResolvableOtsPosition] at hresolvable + +set_option maxRecDepth 100000 in +theorem relTriple_resolveDeferredReveal_chronological + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (position : Position) (input : HashInput) + (context : DeferredContext) (ordinaryCache cache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context ordinaryCache cache) + (hots : IsOtsPosition position) + (hcanonical : ∀ completion, DeferredCompletion table context completion → + input = tableInput parameter completion (.position position)) : + RelTriple + (resolveDeferredReveal table position context) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (resolvedRevealComputation parameter table position input)).run cache) + (ResolvePositionRel parameter table ordinaryCache position) := by + classical + by_cases hresolvable : ResolvableOtsPosition position + · simpa [resolveDeferredReveal, resolvedRevealComputation, hresolvable] using + relTriple_resolveDeferredPosition_chronological parameter table position context + ordinaryCache cache hinvariant hresolvable + · have hdirect := relTriple_resolveDeferredPositionValue_chronological parameter table + position context ordinaryCache cache input hinvariant hots hcanonical + simpa [resolveDeferredReveal, resolvedRevealComputation, hresolvable, oracleHash, + simulateQ_bind, StateT.run_bind, simulateQ_pure, StateT.run_pure] using hdirect + +def ResolvedOrdinaryRunRel (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) : + Option (ResolvedRunResult (alpha × SplitHashCache)) → + alpha × QueryCache HashSpec → Prop + | none, _ => True + | some result, (value, concreteCache) => + result.table = table ∧ result.value.1 = value ∧ + ResolvedContextInvariant parameter table result.context + (ordinaryQueryCache result.value.2) concreteCache + +def DoomedResolvedContext (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) : Prop := + context.ValuesConsistent ∧ StartTableAgrees context.state table ∧ + ¬DeferredCompletable table context + +def ResolvedRunRel (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) : + Option (ResolvedRunResult (alpha × SplitHashCache)) → + alpha × QueryCache HashSpec → Prop + | none, _ => True + | some result, (value, concreteCache) => + (result.table = table ∧ result.value.1 = value ∧ + ResolvedContextInvariant parameter table result.context + (ordinaryQueryCache result.value.2) concreteCache) ∨ + (result.table = table ∧ DoomedResolvedContext table result.context) + +theorem relTriple_runResolvedFromTable_publishOrdinaryInput + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (coordinate : Coordinate) (input : HashInput) (output : HashOutput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hconcrete : concreteCache input = some output) : + RelTriple + (runResolvedFromTable context fuel table + ((publishOrdinaryInput coordinate input output).run cache)) + (pure (output, concreteCache) : ProbComp (HashOutput × QueryCache HashSpec)) + (ResolvedRunRel parameter table) := by + obtain ⟨publishedContext, hpublish, hpublishedInvariant⟩ := + (resolvedAdministrative_publishCoordinate coordinate).run_preserves_invariant + context cache fuel concreteCache hinvariant + unfold publishOrdinaryInput + rw [StateT.run_bind, runResolvedFromTable_bind, hpublish] + simp only [StateT.run_pure, runResolvedFromTable] + apply relTriple_pure_pure + refine Or.inl ⟨rfl, rfl, ?_⟩ + rw [ordinaryQueryCache_update] + exact hpublishedInvariant.cacheLeft_of_concrete input output hconcrete + +theorem relTriple_runResolvedFromTable_splitHashQuery_completionOrdinary + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (context : DeferredContext) + (hordinary : CompletionOrdinaryInput parameter table context input) + (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) : + RelTriple + (runResolvedFromTable context fuel table + ((splitHashQuery (.ordinary input)).run cache)) + ((randomOracle input).run concreteCache) + (ResolvedOrdinaryRunRel parameter table) := by + have hcacheEq := hinvariant.2.2.2.2.eq_of_completionOrdinary + hinvariant.2.2.2.1 input hordinary + rw [splitHashQuery_run_eq] + cases hlookup : cache (.ordinary input) with + | some output => + have hordinaryCached : ordinaryQueryCache cache input = some output := hlookup + have hconcrete : concreteCache input = some output := by + rw [← hcacheEq] + exact hordinaryCached + rw [QueryImpl.withCaching_run_some uniformSampleImpl hconcrete] + simp [runResolvedFromTable, ResolvedOrdinaryRunRel] + exact hinvariant + | none => + have hordinaryCached : ordinaryQueryCache cache input = none := hlookup + have hconcrete : concreteCache input = none := by + rw [← hcacheEq] + exact hordinaryCached + rw [QueryImpl.withCaching_run_none uniformSampleImpl hconcrete, + LazyRevealProbe.hashOutputQuery, + runResolvedFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + apply relTriple_pure_pure + refine ⟨rfl, rfl, ?_⟩ + rw [ordinaryQueryCache_update] + exact hinvariant.of_completionOrdinary_cacheQuery input leftOutput hordinary + +theorem relTriple_runResolvedFromTable_splitHashQuery_stable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (hstable : StableOrdinaryInput parameter input) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) : + RelTriple + (runResolvedFromTable context fuel table + ((splitHashQuery (.ordinary input)).run cache)) + ((randomOracle input).run concreteCache) + (ResolvedOrdinaryRunRel parameter table) := by + exact relTriple_runResolvedFromTable_splitHashQuery_completionOrdinary parameter table input + context (completionOrdinaryInput_of_stable hstable) fuel cache concreteCache hinvariant + +def ResolvedStructuralRunRel (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) : + Option (ResolvedRunResult (Digest × SplitHashCache)) → + Digest × QueryCache HashSpec → Prop + | none, _ => True + | some result, (value, concreteCache) => + result.table = table ∧ result.value.1 = value ∧ + (ResolvedContextInvariant parameter table result.context + (ordinaryQueryCache result.value.2) concreteCache ∨ + DoomedResolvedContext table result.context) + +theorem ResolvedOrdinaryRunRel.to_resolvedRunRel + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left : Option (ResolvedRunResult (alpha × SplitHashCache))} + {right : alpha × QueryCache HashSpec} + (hrelation : ResolvedOrdinaryRunRel parameter table left right) : + ResolvedRunRel parameter table left right := by + cases left with + | none => trivial + | some result => exact Or.inl hrelation + +theorem ResolvedStructuralRunRel.to_resolvedRunRel + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left : Option (ResolvedRunResult (Digest × SplitHashCache))} + {right : Digest × QueryCache HashSpec} + (hrelation : ResolvedStructuralRunRel parameter table left right) : + ResolvedRunRel parameter table left right := by + cases left with + | none => trivial + | some result => + rcases hrelation with ⟨htable, hvalue, hinvariant | hdoomed⟩ + · exact Or.inl ⟨htable, hvalue, hinvariant⟩ + · exact Or.inr ⟨htable, hdoomed⟩ + +theorem relTriple_runResolvedFromTable_of_doomed + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (right : ProbComp (alpha × QueryCache HashSpec)) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hdoomed : DoomedResolvedContext table context) : + RelTriple + (runResolvedFromTable context fuel table (computation.run cache)) + right (ResolvedRunRel parameter table) := by + have hbase := relTriple_true + (runResolvedFromTable context fuel table (computation.run cache)) right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (runResolvedFromTable context fuel table (computation.run cache))) + (fun result hresult => hresult) + apply relTriple_post_mono hsupported + intro leftResult _ hrelation + rcases hrelation with ⟨_true, hsupport⟩ + cases leftResult with + | none => trivial + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable (computation.run cache) context fuel + table result hdoomed.1 hdoomed.2.1 hsupport + have hstillDoomed := not_deferredCompletable_of_mem_runResolvedFromTable + (computation.run cache) context fuel table result hdoomed.1 hdoomed.2.1 hsupport + hdoomed.2.2 + exact Or.inr ⟨hcore.1, hcore.2.1, hcore.2.2, hstillDoomed⟩ + +theorem relTriple_runResolvedFromTable_bind_clean_or_doomed + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta) + (right : ProbComp (alpha × QueryCache HashSpec)) + (rightNext : alpha → QueryCache HashSpec → + ProbComp (beta × QueryCache HashSpec)) + (hleft : RelTriple + (runResolvedFromTable context fuel table (left.run cache)) + right (ResolvedRunRel parameter table)) + (hnext : ∀ (result : ResolvedRunResult (alpha × SplitHashCache)) + (value : alpha) (concreteCache : QueryCache HashSpec), + result.table = table → result.value.1 = value → + ResolvedContextInvariant parameter table result.context + (ordinaryQueryCache result.value.2) concreteCache → + RelTriple + (runResolvedFromTable result.context result.remaining result.table + ((next result.value.1).run result.value.2)) + (rightNext value concreteCache) + (ResolvedRunRel parameter table)) : + RelTriple + (runResolvedFromTable context fuel table ((left >>= next).run cache)) + (right >>= fun result => rightNext result.1 result.2) + (ResolvedRunRel parameter table) := by + rw [StateT.run_bind, runResolvedFromTable_bind] + apply relTriple_bind hleft + intro leftResult rightResult hrelation + cases leftResult with + | none => + have hbase := relTriple_true + (pure (none : Option (ResolvedRunResult (beta × SplitHashCache))) : + ProbComp (Option (ResolvedRunResult (beta × SplitHashCache)))) + (rightNext rightResult.1 rightResult.2) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun finalLeft => finalLeft = none) (by + intro finalLeft hsupport + simpa using hsupport) + apply relTriple_post_mono hsupported + intro finalLeft _ hfinal + rw [hfinal.2] + trivial + | some result => + rcases hrelation with hclean | hdoomed + · exact hnext result rightResult.1 rightResult.2 hclean.1 hclean.2.1 hclean.2.2 + · simpa [hdoomed.1] using + (relTriple_runResolvedFromTable_of_doomed parameter table + (next result.value.1) (rightNext rightResult.1 rightResult.2) result.context + result.remaining result.value.2 hdoomed.2) + +def ResolvedCouples (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (right : StateT (QueryCache HashSpec) ProbComp alpha) : Prop := + ∀ context fuel cache concreteCache, + ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache → + RelTriple + (runResolvedFromTable context fuel table (left.run cache)) + (right.run concreteCache) + (ResolvedRunRel parameter table) + +theorem resolvedCouples_pure (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (value : alpha) : + ResolvedCouples parameter table + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (pure value : StateT (QueryCache HashSpec) ProbComp alpha) := by + intro context fuel cache concreteCache hinvariant + simp only [runResolvedFromTable] + apply relTriple_pure_pure + exact Or.inl ⟨rfl, rfl, hinvariant⟩ + +theorem resolvedCouples_of_administrative + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {value : alpha} (hadministrative : ResolvedAdministrative computation value) : + ResolvedCouples parameter table computation + (pure value : StateT (QueryCache HashSpec) ProbComp alpha) := by + intro context fuel cache concreteCache hinvariant + obtain ⟨finalContext, hrun, hfinalInvariant⟩ := + hadministrative.run_preserves_invariant context cache fuel concreteCache hinvariant + rw [hrun] + simp only [StateT.run_pure] + apply relTriple_pure_pure + exact Or.inl ⟨rfl, rfl, hfinalInvariant⟩ + +theorem resolvedCouples_probe + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (candidate : Probe) : + ResolvedCouples parameter table (probe candidate) + (pure () : StateT (QueryCache HashSpec) ProbComp Unit) := by + intro context fuel cache concreteCache hinvariant + unfold probe + rw [StateT.run_liftM, LazyRevealProbe.probeQuery, + runResolvedFromTable_probe_query_bind] + cases fuel with + | zero => + simp only [StateT.run_pure] + apply relTriple_pure_pure + trivial + | succ remaining => + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte, StateT.run_pure, runResolvedFromTable] + apply relTriple_pure_pure + exact Or.inl ⟨rfl, rfl, hinvariant⟩ + · simp only [hrevealed, ↓reduceIte, StateT.run_pure, runResolvedFromTable] + by_cases hcompletable : DeferredCompletable table + { context with state := + (context.state.addPending candidate.coordinate candidate.candidate) } + · apply relTriple_pure_pure + exact Or.inl ⟨rfl, rfl, + hinvariant.addPending_of_completable candidate.coordinate candidate.candidate + hcompletable⟩ + · apply relTriple_pure_pure + exact Or.inr ⟨rfl, hinvariant.2.1.valuesConsistent.addPending + candidate.coordinate candidate.candidate, + hinvariant.2.2.1.addPending candidate.coordinate candidate.candidate, + hcompletable⟩ + +theorem resolvedCouples_splitUniform + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) (n : Nat) : + ResolvedCouples parameter table (splitUniformImpl n) (unifFwdImpl HashSpec n) := by + intro context fuel cache concreteCache hinvariant + unfold splitUniformImpl LazyRevealProbe.uniformQuery + rw [StateT.run_liftM, runResolvedFromTable_uniform_query_bind] + rw [show (unifFwdImpl HashSpec n).run concreteCache = + (fun output => (output, concreteCache)) <$> + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) by + simpa using unifFwdImpl.simulateQ_run + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) concreteCache] + simp only [map_eq_bind_pure_comp] + apply relTriple_bind (relTriple_refl + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))) + intro left right heq + subst right + simp only [runResolvedFromTable] + apply relTriple_pure_pure + exact Or.inl ⟨rfl, rfl, hinvariant⟩ + +theorem ResolvedCouples.bind + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {right : StateT (QueryCache HashSpec) ProbComp alpha} + {leftNext : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + {rightNext : alpha → StateT (QueryCache HashSpec) ProbComp beta} + (hleft : ResolvedCouples parameter table left right) + (hnext : ∀ value, ResolvedCouples parameter table (leftNext value) (rightNext value)) : + ResolvedCouples parameter table (left >>= leftNext) (right >>= rightNext) := by + intro context fuel cache concreteCache hinvariant + rw [StateT.run_bind] + apply relTriple_runResolvedFromTable_bind_clean_or_doomed parameter table context fuel cache + left leftNext (right.run concreteCache) (fun value cache => (rightNext value).run cache) + (hleft context fuel cache concreteCache hinvariant) + intro result value finalCache htable hvalue hresultInvariant + subst value + simpa [htable] using + (hnext result.value.1 result.context result.remaining result.value.2 finalCache + hresultInvariant) + +theorem resolvedCouples_sequenceFin + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} {n : Nat} + (left : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (right : Fin n → StateT (QueryCache HashSpec) ProbComp alpha) + (hcomponent : ∀ index, ResolvedCouples parameter table (left index) (right index)) : + ResolvedCouples parameter table (sequenceFin left) (sequenceFin right) := by + induction n with + | zero => + simpa [sequenceFin] using + (resolvedCouples_pure parameter table Fin.elim0 : + ResolvedCouples parameter table + (pure Fin.elim0 : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Fin 0 → alpha)) + (pure Fin.elim0 : StateT (QueryCache HashSpec) ProbComp (Fin 0 → alpha))) + | succ n ih => + rw [sequenceFin, sequenceFin] + apply (hcomponent 0).bind + intro head + apply (ih (fun index : Fin n => left index.succ) + (fun index : Fin n => right index.succ) + (fun index => hcomponent index.succ)).bind + intro tail + let assembled : Fin (n + 1) → alpha := Fin.cases head tail + exact resolvedCouples_pure parameter table assembled + +theorem resolvedCouples_simulateQ + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {spec : OracleSpec ι} + (left : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))) + (right : QueryImpl spec (StateT (QueryCache HashSpec) ProbComp)) + (hquery : ∀ query, ResolvedCouples parameter table (left query) (right query)) + (computation : OracleComp spec alpha) : + ResolvedCouples parameter table (simulateQ left computation) + (simulateQ right computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp only [simulateQ_pure] + exact resolvedCouples_pure parameter table value + | query_bind query next ih => + rw [simulateQ_query_bind, simulateQ_query_bind] + exact (hquery query).bind fun output => ih output + +def ReachableResolvedRunRel (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) : + Option (ResolvedRunResult (alpha × SplitHashCache)) → + alpha × QueryCache HashSpec → Prop + | none, _ => True + | some result, (value, concreteCache) => + (result.table = table ∧ result.value.1 = value ∧ + ResolvedContextInvariant parameter table result.context + (ordinaryQueryCache result.value.2) concreteCache ∧ + VisibleResolvedComputationsCached parameter table result.context concreteCache ∧ + PublishedValues result.context.state) ∨ + (result.table = table ∧ DoomedResolvedContext table result.context) + +theorem ReachableResolvedRunRel.to_resolvedRunRel + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left : Option (ResolvedRunResult (alpha × SplitHashCache))} + {right : alpha × QueryCache HashSpec} + (hrelation : ReachableResolvedRunRel parameter table left right) : + ResolvedRunRel parameter table left right := by + cases left with + | none => trivial + | some result => + rcases hrelation with hclean | hdoomed + · exact Or.inl ⟨hclean.1, hclean.2.1, hclean.2.2.1⟩ + · exact Or.inr hdoomed + +def ReachableResolvedCouples (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (right : StateT (QueryCache HashSpec) ProbComp alpha) : Prop := + ∀ context fuel cache concreteCache, + ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache → + VisibleResolvedComputationsCached parameter table context concreteCache → + PublishedValues context.state → + RelTriple + (runResolvedFromTable context fuel table (left.run cache)) + (right.run concreteCache) + (ReachableResolvedRunRel parameter table) + +theorem reachableResolvedCouples_pure (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (value : alpha) : + ReachableResolvedCouples parameter table + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (pure value : StateT (QueryCache HashSpec) ProbComp alpha) := by + intro context fuel cache concreteCache hinvariant hclosed hpublished + simp only [runResolvedFromTable] + apply relTriple_pure_pure + exact Or.inl ⟨rfl, rfl, hinvariant, hclosed, hpublished⟩ + +theorem reachableResolvedCouples_of_administrative + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {value : alpha} (hadministrative : ResolvedAdministrative computation value) + (hpreserves : ResolvedPreservesPublished computation) : + ReachableResolvedCouples parameter table computation + (pure value : StateT (QueryCache HashSpec) ProbComp alpha) := by + intro context fuel cache concreteCache hinvariant hclosed hpublished + obtain ⟨finalContext, hrun, hpending, hvalues, hprivate⟩ := + hadministrative.run context cache fuel table + have hcore : context.CoreEq finalContext := + ⟨hpending.symm, hvalues.symm, hprivate.symm⟩ + rw [hrun] + simp only [StateT.run_pure] + apply relTriple_pure_pure + refine Or.inl ⟨rfl, rfl, hinvariant.of_coreEq hcore, + hclosed.of_state_values_eq hvalues, ?_⟩ + apply hpreserves context cache fuel table + { context := finalContext, remaining := fuel, value := (value, cache), table := table } + hpublished + rw [hrun] + simp + +theorem reachableResolvedCouples_probe + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (candidate : Probe) : + ReachableResolvedCouples parameter table (probe candidate) + (pure () : StateT (QueryCache HashSpec) ProbComp Unit) := by + intro context fuel cache concreteCache hinvariant hclosed hpublished + unfold probe + rw [StateT.run_liftM, LazyRevealProbe.probeQuery, + runResolvedFromTable_probe_query_bind] + cases fuel with + | zero => + simp only [StateT.run_pure] + apply relTriple_pure_pure + trivial + | succ remaining => + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte, StateT.run_pure, runResolvedFromTable] + apply relTriple_pure_pure + exact Or.inl ⟨rfl, rfl, hinvariant, hclosed, hpublished⟩ + · simp only [hrevealed, ↓reduceIte, StateT.run_pure, runResolvedFromTable] + by_cases hcompletable : DeferredCompletable table + { context with state := + context.state.addPending candidate.coordinate candidate.candidate } + · apply relTriple_pure_pure + exact Or.inl ⟨rfl, rfl, + hinvariant.addPending_of_completable candidate.coordinate candidate.candidate + hcompletable, + hclosed.of_state_values_eq rfl, by + simpa [PublishedValues, LazyRevealProbe.State.addPending] using hpublished⟩ + · apply relTriple_pure_pure + exact Or.inr ⟨rfl, hinvariant.2.1.valuesConsistent.addPending + candidate.coordinate candidate.candidate, + hinvariant.2.2.1.addPending candidate.coordinate candidate.candidate, + hcompletable⟩ + +theorem relTriple_runResolvedFromTable_publishCoordinate_reachable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (coordinate : Coordinate) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hvalue : context.state.values coordinate ≠ none) : + RelTriple + (runResolvedFromTable context fuel table ((publishCoordinate coordinate).run cache)) + (pure ((), concreteCache) : ProbComp (Unit × QueryCache HashSpec)) + (ReachableResolvedRunRel parameter table) := by + unfold publishCoordinate + rw [StateT.run_liftM, LazyRevealProbe.publishQuery, + runResolvedFromTable_publish_query_bind] + simp only [runResolvedFromTable] + apply relTriple_pure_pure + refine Or.inl ⟨rfl, rfl, hinvariant, hclosed.of_state_values_eq rfl, ?_⟩ + intro other hrevealed + simp only [LazyRevealProbe.State.publish, Finset.mem_insert] at hrevealed + rcases hrevealed with heq | hrevealed + · subst other + exact hvalue + · exact hpublished other hrevealed + +theorem reachableResolvedCouples_splitUniform + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) (n : Nat) : + ReachableResolvedCouples parameter table (splitUniformImpl n) + (unifFwdImpl HashSpec n) := by + intro context fuel cache concreteCache hinvariant hclosed hpublished + unfold splitUniformImpl LazyRevealProbe.uniformQuery + rw [StateT.run_liftM, runResolvedFromTable_uniform_query_bind] + rw [show (unifFwdImpl HashSpec n).run concreteCache = + (fun output => (output, concreteCache)) <$> + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) by + simpa using unifFwdImpl.simulateQ_run + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) concreteCache] + simp only [map_eq_bind_pure_comp] + apply relTriple_bind (relTriple_refl + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))) + intro left right heq + subst right + simp only [runResolvedFromTable] + apply relTriple_pure_pure + exact Or.inl ⟨rfl, rfl, hinvariant, hclosed, hpublished⟩ + +theorem relTriple_runResolvedFromTable_of_doomed_reachable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (right : ProbComp (alpha × QueryCache HashSpec)) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hdoomed : DoomedResolvedContext table context) : + RelTriple + (runResolvedFromTable context fuel table (computation.run cache)) + right (ReachableResolvedRunRel parameter table) := by + have hbase := relTriple_true + (runResolvedFromTable context fuel table (computation.run cache)) right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (runResolvedFromTable context fuel table (computation.run cache))) + (fun result hresult => hresult) + apply relTriple_post_mono hsupported + intro leftResult _ hrelation + rcases hrelation with ⟨_true, hsupport⟩ + cases leftResult with + | none => trivial + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable (computation.run cache) context fuel + table result hdoomed.1 hdoomed.2.1 hsupport + have hstillDoomed := not_deferredCompletable_of_mem_runResolvedFromTable + (computation.run cache) context fuel table result hdoomed.1 hdoomed.2.1 hsupport + hdoomed.2.2 + exact Or.inr ⟨hcore.1, hcore.2.1, hcore.2.2, hstillDoomed⟩ + +theorem ReachableResolvedCouples.bind + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {right : StateT (QueryCache HashSpec) ProbComp alpha} + {leftNext : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + {rightNext : alpha → StateT (QueryCache HashSpec) ProbComp beta} + (hleft : ReachableResolvedCouples parameter table left right) + (hnext : ∀ value, + ReachableResolvedCouples parameter table (leftNext value) (rightNext value)) : + ReachableResolvedCouples parameter table (left >>= leftNext) (right >>= rightNext) := by + intro context fuel cache concreteCache hinvariant hclosed hpublished + rw [StateT.run_bind, StateT.run_bind, runResolvedFromTable_bind] + apply relTriple_bind (hleft context fuel cache concreteCache hinvariant hclosed hpublished) + intro leftResult rightResult hrelation + cases leftResult with + | none => + have hbase := relTriple_true + (pure (none : Option (ResolvedRunResult (beta × SplitHashCache))) : + ProbComp (Option (ResolvedRunResult (beta × SplitHashCache)))) + ((rightNext rightResult.1).run rightResult.2) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun finalLeft => finalLeft = none) (by + intro finalLeft hsupport + simpa using hsupport) + apply relTriple_post_mono hsupported + intro finalLeft _ hfinal + rw [hfinal.2] + trivial + | some result => + rcases hrelation with hclean | hdoomed + · rcases rightResult with ⟨rightValue, rightCache⟩ + have hvalue : result.value.1 = rightValue := hclean.2.1 + subst rightValue + simpa [hclean.1] using + (hnext result.value.1 result.context result.remaining result.value.2 rightCache + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2) + · simpa [hdoomed.1] using + (relTriple_runResolvedFromTable_of_doomed_reachable parameter table + (leftNext result.value.1) ((rightNext rightResult.1).run rightResult.2) + result.context result.remaining result.value.2 hdoomed.2) + +theorem ReachableResolvedCouples.publishAfter + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {right : StateT (QueryCache HashSpec) ProbComp alpha} + (hleft : ReachableResolvedCouples parameter table left right) + (coordinate : Coordinate) + (hmaterialized : ∀ context fuel cache result, + some result ∈ support + (runResolvedFromTable context fuel table (left.run cache)) → + result.context.state.values coordinate ≠ none) : + ReachableResolvedCouples parameter table + (left >>= fun value => publishCoordinate coordinate >>= fun _ => pure value) right := by + intro context fuel cache concreteCache hinvariant hclosed hpublished + rw [StateT.run_bind, runResolvedFromTable_bind] + have hbase := hleft context fuel cache concreteCache hinvariant hclosed hpublished + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (runResolvedFromTable context fuel table (left.run cache))) + (fun result hresult => hresult) + rw [show right.run concreteCache = right.run concreteCache >>= fun result => pure result by simp] + apply relTriple_bind hsupported + intro leftResult rightResult hrelation + rcases hrelation with ⟨hrelation, hleftSupport⟩ + cases leftResult with + | none => + apply relTriple_pure_pure + trivial + | some result => + rcases hrelation with hclean | hdoomed + · have hpublish := relTriple_runResolvedFromTable_publishCoordinate_reachable + parameter table coordinate result.context result.remaining result.value.2 rightResult.2 + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 + (hmaterialized context fuel cache result hleftSupport) + simp only + rw [hclean.1, StateT.run_bind, runResolvedFromTable_bind] + rw [show (pure rightResult : ProbComp (alpha × QueryCache HashSpec)) = + (pure ((), rightResult.2) >>= fun _ => pure rightResult) by simp] + have hpublishSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hpublish + apply relTriple_bind hpublishSupported + intro publishedResult publishedRight hpublishedRelation + rcases hpublishedRelation with ⟨hpublishedRelation, hrightSupport⟩ + have hpublishedRight : publishedRight = ((), rightResult.2) := by + simpa using hrightSupport + subst publishedRight + cases publishedResult with + | none => + apply relTriple_pure_pure + trivial + | some publishedResult => + rcases hpublishedRelation with hpublishedClean | hpublishedDoomed + · simp only [runResolvedFromTable] + apply relTriple_pure_pure + exact Or.inl ⟨hpublishedClean.1, hclean.2.1, hpublishedClean.2.2.1, + hpublishedClean.2.2.2.1, hpublishedClean.2.2.2.2⟩ + · simp only [runResolvedFromTable] + apply relTriple_pure_pure + exact Or.inr hpublishedDoomed + · simpa [hdoomed.1] using + (relTriple_runResolvedFromTable_of_doomed_reachable parameter table + (publishCoordinate coordinate >>= fun _ => pure result.value.1) + (pure rightResult) result.context result.remaining result.value.2 hdoomed.2) + +theorem reachableResolvedCouples_sequenceFin + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} {n : Nat} + (left : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (right : Fin n → StateT (QueryCache HashSpec) ProbComp alpha) + (hcomponent : ∀ index, + ReachableResolvedCouples parameter table (left index) (right index)) : + ReachableResolvedCouples parameter table (sequenceFin left) (sequenceFin right) := by + induction n with + | zero => + simpa [sequenceFin] using + (reachableResolvedCouples_pure parameter table Fin.elim0 : + ReachableResolvedCouples parameter table + (pure Fin.elim0 : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Fin 0 → alpha)) + (pure Fin.elim0 : StateT (QueryCache HashSpec) ProbComp (Fin 0 → alpha))) + | succ n ih => + rw [sequenceFin, sequenceFin] + apply (hcomponent 0).bind + intro head + apply (ih (fun index : Fin n => left index.succ) + (fun index : Fin n => right index.succ) + (fun index => hcomponent index.succ)).bind + intro tail + let assembled : Fin (n + 1) → alpha := Fin.cases head tail + exact reachableResolvedCouples_pure parameter table assembled + +theorem reachableResolvedCouples_simulateQ + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {spec : OracleSpec ι} + (left : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))) + (right : QueryImpl spec (StateT (QueryCache HashSpec) ProbComp)) + (hquery : ∀ query, + ReachableResolvedCouples parameter table (left query) (right query)) + (computation : OracleComp spec alpha) : + ReachableResolvedCouples parameter table (simulateQ left computation) + (simulateQ right computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp only [simulateQ_pure] + exact reachableResolvedCouples_pure parameter table value + | query_bind query next ih => + rw [simulateQ_query_bind, simulateQ_query_bind] + exact (hquery query).bind fun output => ih output + +theorem relTriple_runResolvedFromTable_splitHashQuery_completionOrdinary_reachable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (context : DeferredContext) + (hordinary : CompletionOrdinaryInput parameter table context input) + (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) : + RelTriple + (runResolvedFromTable context fuel table + ((splitHashQuery (.ordinary input)).run cache)) + ((randomOracle input).run concreteCache) + (ReachableResolvedRunRel parameter table) := by + have hcacheEq := hinvariant.2.2.2.2.eq_of_completionOrdinary + hinvariant.2.2.2.1 input hordinary + rw [splitHashQuery_run_eq] + cases hlookup : cache (.ordinary input) with + | some output => + have hordinaryCached : ordinaryQueryCache cache input = some output := hlookup + have hconcrete : concreteCache input = some output := by + rw [← hcacheEq] + exact hordinaryCached + rw [QueryImpl.withCaching_run_some uniformSampleImpl hconcrete] + simp [runResolvedFromTable, ReachableResolvedRunRel] + exact Or.inl ⟨hinvariant, hclosed, hpublished⟩ + | none => + have hordinaryCached : ordinaryQueryCache cache input = none := hlookup + have hconcrete : concreteCache input = none := by + rw [← hcacheEq] + exact hordinaryCached + rw [QueryImpl.withCaching_run_none uniformSampleImpl hconcrete, + LazyRevealProbe.hashOutputQuery, + runResolvedFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + apply relTriple_pure_pure + refine Or.inl ⟨rfl, rfl, ?_, ?_⟩ + · rw [ordinaryQueryCache_update] + exact hinvariant.of_completionOrdinary_cacheQuery input leftOutput hordinary + · exact ⟨hclosed.mono (le_cacheQuery hconcrete), hpublished⟩ + +theorem reachableResolvedCouples_splitHashQuery_stable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (hstable : StableOrdinaryInput parameter input) : + ReachableResolvedCouples parameter table (splitHashQuery (.ordinary input)) + (randomOracle input) := by + intro context fuel cache concreteCache hinvariant hclosed hpublished + exact relTriple_runResolvedFromTable_splitHashQuery_completionOrdinary_reachable parameter + table input context (completionOrdinaryInput_of_stable hstable) fuel cache concreteCache + hinvariant hclosed hpublished + +theorem reachableResolvedCouples_probingHashQuery_of_stable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (hstable : StableOrdinaryInput parameter input) : + ReachableResolvedCouples parameter table (probingHashQuery parameter input) + (randomOracle input) := by + rw [probingHashQuery_eq_splitHashQuery_of_stable parameter input hstable] + exact reachableResolvedCouples_splitHashQuery_stable parameter table input hstable + +theorem reachableResolvedCouples_verifierHashQuery_of_stable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (hstable : StableOrdinaryInput parameter input) : + ReachableResolvedCouples parameter table (verifierHashQuery parameter input) + (randomOracle input) := by + rw [verifierHashQuery_eq_splitHashQuery_of_stable parameter input hstable] + exact reachableResolvedCouples_splitHashQuery_stable parameter table input hstable + +theorem reachableResolvedCouples_revealChainStart + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : OtsSecretIndex) : + ReachableResolvedCouples parameter table + (revealChainStart index.lay index.tree index.leafIdx index.chainIdx) + (pure (truncateHash (table index)) : StateT (QueryCache HashSpec) ProbComp Digest) := by + intro context fuel cache concreteCache hinvariant hclosed hpublished + have hclean := hinvariant.2.2.2.1.not_hitAt_chainStart index + rw [runResolvedFromTable_revealChainStart_of_agrees context fuel table index cache + hinvariant.2.2.1 hclean] + apply relTriple_pure_pure + refine Or.inl ⟨rfl, rfl, ?_, ?_, ?_⟩ + · rw [ordinaryQueryCache_update_hidden] + exact hinvariant.materialize_chainStart index + · apply hclosed.of_position_values_eq + intro position + have hne : index.coordinate ≠ .position position := by + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + simp [OtsSecretIndex.coordinate] + simp only [LazyRevealProbe.State.materialize] + rw [Function.update_of_ne (Ne.symm hne)] + · exact hpublished.materialize index.coordinate (table index) + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_revealResolvablePosition_reachable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (position : Position) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hresolvable : ResolvableOtsPosition position) : + RelTriple + (runResolvedFromTable context fuel table ((revealPosition position).run cache)) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (resolvedPositionComputation parameter table position)).run concreteCache) + (ReachableResolvedRunRel parameter table) := by + rw [runResolvedFromTable_revealPosition] + have hresolve := relTriple_resolveDeferredPosition_chronological parameter table position + context (ordinaryQueryCache cache) concreteCache hinvariant hresolvable + have hsupportedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolve + (fun resolved => resolved ∈ support (resolveDeferredPosition table position context)) + (fun resolved hresolved => hresolved) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hsupportedLeft + have hbound : RelTriple + (resolveDeferredPosition table position context >>= fun resolved => + match resolved with + | none => pure none + | some resolved => + pure (some ⟨materializeResolvedPosition context position resolved, fuel, + (truncateHash resolved.output, + Function.update cache (.hidden (.position position)) (some resolved.output)), + table⟩)) + (((simulateQ (randomOracle : QueryImpl HashSpec _) + (resolvedPositionComputation parameter table position)).run concreteCache) >>= + fun result => pure result) + (ReachableResolvedRunRel parameter table) := by + apply relTriple_bind hsupported + intro resolved rightResult hrelation + rcases hrelation with ⟨⟨hresolvedRel, hresultSupport⟩, hrightSupport⟩ + cases resolved with + | none => + apply relTriple_pure_pure + trivial + | some resolved => + apply relTriple_pure_pure + rcases rightResult with ⟨value, finalCache⟩ + rcases hresolvedRel with ⟨hvalue, hresultInvariant, _hposition⟩ + have hreplay := replay_of_mem_support + (resolvedPositionComputation parameter table position) concreteCache value finalCache + hrightSupport (fromCache finalCache) (agreesWithFn_fromCache finalCache) + have hclosedFinal := hclosed.mono hreplay.1 + have hvisible : VisibleResolvedComputationsCached parameter table + (materializeResolvedPosition context position resolved) finalCache := by + intro other output hotherResolvable hvisibleValue + by_cases heq : other = position + · subst other + have houtput : output = resolved.output := by + have houtput' : resolved.output = output := by + simpa [materializeResolvedPosition, LazyRevealProbe.State.materialize] using + hvisibleValue + exact houtput'.symm + subst output + exact ⟨hreplay.2.2, hreplay.2.1.trans hvalue⟩ + · apply hclosedFinal other output hotherResolvable + simpa [materializeResolvedPosition, LazyRevealProbe.State.materialize, heq] using + hvisibleValue + simp only [ReachableResolvedRunRel] + rw [ordinaryQueryCache_update_hidden] + by_cases hcompletable : DeferredCompletable table + (materializeResolvedPosition context position resolved) + · have hfinalInvariant := hinvariant.materialize_resolvedReveal position resolved + (by simpa [resolveDeferredReveal, hresolvable] using hresultSupport) + hresultInvariant hcompletable + exact Or.inl (by + simpa [hvalue] using And.intro hfinalInvariant + (And.intro hvisible (by + simpa [materializeResolvedPosition] using + hpublished.materialize (.position position) resolved.output))) + · have hfinalDoomed : DoomedResolvedContext table + (materializeResolvedPosition context position resolved) := ⟨ + hinvariant.2.1.valuesConsistent.materializeResolvedPosition_of table position + resolved (by simpa [resolveDeferredReveal, hresolvable] using hresultSupport), + by simpa [materializeResolvedPosition] using + hinvariant.2.2.1.materialize_position position resolved.output, + hcompletable⟩ + exact Or.inr (by simpa using hfinalDoomed) + simpa [resolveDeferredReveal, hresolvable, materializeResolvedPosition] using hbound + +theorem reachableResolvedCouples_revealResolvablePosition + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (position : Position) (hresolvable : ResolvableOtsPosition position) : + ReachableResolvedCouples parameter table (revealPosition position) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (resolvedPositionComputation parameter table position)) := by + intro context fuel cache concreteCache hinvariant hclosed hpublished + exact relTriple_runResolvedFromTable_revealResolvablePosition_reachable parameter table + position context fuel cache concreteCache hinvariant hclosed hpublished hresolvable + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_revealPosition_chronological + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (position : Position) (input : HashInput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hots : IsOtsPosition position) + (hcanonical : ∀ completion, DeferredCompletion table context completion → + input = tableInput parameter completion (.position position)) : + RelTriple + (runResolvedFromTable context fuel table ((revealPosition position).run cache)) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (resolvedRevealComputation parameter table position input)).run concreteCache) + (ResolvedStructuralRunRel parameter table) := by + rw [runResolvedFromTable_revealPosition] + have hresolve := relTriple_resolveDeferredReveal_chronological parameter table position input + context (ordinaryQueryCache cache) concreteCache hinvariant hots hcanonical + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolve + (fun resolved => resolved ∈ support (resolveDeferredReveal table position context)) + (fun resolved hresolved => hresolved) + have hbound : RelTriple + (resolveDeferredReveal table position context >>= fun resolved => + match resolved with + | none => pure none + | some resolved => + pure (some ⟨materializeResolvedPosition context position resolved, fuel, + (truncateHash resolved.output, + Function.update cache (.hidden (.position position)) (some resolved.output)), + table⟩)) + (((simulateQ (randomOracle : QueryImpl HashSpec _) + (resolvedRevealComputation parameter table position input)).run concreteCache) >>= + fun result => pure result) + (ResolvedStructuralRunRel parameter table) := by + apply relTriple_bind hsupported + intro resolved rightResult hrelation + rcases hrelation with ⟨hresolvedRel, hresultSupport⟩ + cases resolved with + | none => + apply relTriple_pure_pure + trivial + | some resolved => + apply relTriple_pure_pure + rcases rightResult with ⟨value, finalCache⟩ + rcases hresolvedRel with ⟨hvalue, hresultInvariant, _hposition⟩ + refine ⟨rfl, hvalue.symm, ?_⟩ + rw [ordinaryQueryCache_update_hidden] + by_cases hcompletable : DeferredCompletable table + (materializeResolvedPosition context position resolved) + · exact Or.inl (hinvariant.materialize_resolvedReveal position resolved + hresultSupport hresultInvariant hcompletable) + · exact Or.inr ⟨ + hinvariant.2.1.valuesConsistent.materializeResolvedPosition_of table position + resolved hresultSupport, + by simpa [materializeResolvedPosition] using + hinvariant.2.2.1.materialize_position position resolved.output, + hcompletable⟩ + simpa [materializeResolvedPosition] using hbound + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_revealResolvablePosition_chronological + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (position : Position) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hresolvable : ResolvableOtsPosition position) : + RelTriple + (runResolvedFromTable context fuel table ((revealPosition position).run cache)) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (resolvedPositionComputation parameter table position)).run concreteCache) + (ResolvedStructuralRunRel parameter table) := by + rw [runResolvedFromTable_revealPosition] + have hresolve := relTriple_resolveDeferredPosition_chronological parameter table position + context (ordinaryQueryCache cache) concreteCache hinvariant hresolvable + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolve + (fun resolved => resolved ∈ support (resolveDeferredPosition table position context)) + (fun resolved hresolved => hresolved) + have hbound : RelTriple + (resolveDeferredPosition table position context >>= fun resolved => + match resolved with + | none => pure none + | some resolved => + pure (some ⟨materializeResolvedPosition context position resolved, fuel, + (truncateHash resolved.output, + Function.update cache (.hidden (.position position)) (some resolved.output)), + table⟩)) + (((simulateQ (randomOracle : QueryImpl HashSpec _) + (resolvedPositionComputation parameter table position)).run concreteCache) >>= + fun result => pure result) + (ResolvedStructuralRunRel parameter table) := by + apply relTriple_bind hsupported + intro resolved rightResult hrelation + rcases hrelation with ⟨hresolvedRel, hresultSupport⟩ + cases resolved with + | none => + apply relTriple_pure_pure + trivial + | some resolved => + apply relTriple_pure_pure + rcases rightResult with ⟨value, finalCache⟩ + rcases hresolvedRel with ⟨hvalue, hresultInvariant, _hposition⟩ + refine ⟨rfl, hvalue.symm, ?_⟩ + rw [ordinaryQueryCache_update_hidden] + by_cases hcompletable : DeferredCompletable table + (materializeResolvedPosition context position resolved) + · exact Or.inl (hinvariant.materialize_resolvedReveal position resolved + (by simpa [resolveDeferredReveal, hresolvable] using hresultSupport) + hresultInvariant hcompletable) + · have hreveal : some resolved ∈ support + (resolveDeferredReveal table position context) := by + simpa [resolveDeferredReveal, hresolvable] using hresultSupport + exact Or.inr ⟨ + hinvariant.2.1.valuesConsistent.materializeResolvedPosition_of table position + resolved hreveal, + by simpa [materializeResolvedPosition] using + hinvariant.2.2.1.materialize_position position resolved.output, + hcompletable⟩ + simpa [resolveDeferredReveal, hresolvable, materializeResolvedPosition] using hbound + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_revealResolvablePositionOutput_chronological + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (completion : Coordinate → HashOutput) (position : Position) (input : HashInput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hcompletion : DeferredCompletion table context completion) + (hots : IsOtsPosition position) + (hresolvable : ResolvableOtsPosition position) + (havailable : TableInputAvailable completion context.state (.position position)) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hinput : input = tableInput parameter completion (.position position)) : + RelTriple + (runResolvedFromTable context fuel table + ((revealCoordinateOutput (.position position)).run cache)) + ((randomOracle input).run concreteCache) + (ReachableResolvedRunRel parameter table) := by + rw [runResolvedFromTable_revealCoordinateOutput] + have hresolve := relTriple_resolveDeferredPosition_chronological parameter table position + context (ordinaryQueryCache cache) concreteCache hinvariant hresolvable + have hrun := resolvedPositionComputation_run_eq_finalQuery_of_available parameter table + completion context concreteCache position input hcompletion hresolvable havailable hclosed + hinput + rw [hrun] at hresolve + have hsupportedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolve + (fun resolved => resolved ∈ support (resolveDeferredPosition table position context)) + (fun resolved hresolved => hresolved) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hsupportedLeft + let recover : Digest × QueryCache HashSpec → HashOutput × QueryCache HashSpec := + fun result => ((result.2 input).getD 0, result.2) + have hcore : RelTriple + (resolveDeferredPosition table position context >>= fun resolved => + match resolved with + | none => pure none + | some resolved => + pure (some ⟨materializeResolvedPosition context position resolved, fuel, + (resolved.output, + Function.update cache (.hidden (.position position)) (some resolved.output)), + table⟩)) + (((randomOracle input).run concreteCache >>= fun result => + pure (truncateHash result.1, result.2)) >>= fun result => pure result) + (fun left right => ReachableResolvedRunRel parameter table left (recover right)) := by + apply relTriple_bind hsupported + intro resolved queryResult hrelation + rcases hrelation with ⟨⟨hresolvedRel, hresultSupport⟩, hrightSupport⟩ + cases resolved with + | none => + apply relTriple_pure_pure + trivial + | some resolved => + apply relTriple_pure_pure + rcases queryResult with ⟨value, finalCache⟩ + rcases hresolvedRel with ⟨_hvalue, hresultInvariant, hposition⟩ + have hpositionSupport : (value, finalCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (resolvedPositionComputation parameter table position)).run concreteCache) := by + rw [hrun] + exact hrightSupport + have hreplay := replay_of_mem_support + (resolvedPositionComputation parameter table position) concreteCache value finalCache + hpositionSupport (fromCache finalCache) (agreesWithFn_fromCache finalCache) + have hclosedFinal := hclosed.mono hreplay.1 + have hvisible : VisibleResolvedComputationsCached parameter table + (materializeResolvedPosition context position resolved) finalCache := by + intro other output hotherResolvable hvisibleValue + by_cases heq : other = position + · subst other + have houtput : output = resolved.output := by + have houtput' : resolved.output = output := by + simpa [materializeResolvedPosition, LazyRevealProbe.State.materialize] using + hvisibleValue + exact houtput'.symm + subst output + exact ⟨hreplay.2.2, hreplay.2.1.trans _hvalue⟩ + · apply hclosedFinal other output hotherResolvable + simpa [materializeResolvedPosition, LazyRevealProbe.State.materialize, heq] using + hvisibleValue + by_cases hcompletable : DeferredCompletable table + (materializeResolvedPosition context position resolved) + · have hcanonical : ∀ otherCompletion, + DeferredCompletion table resolved.toDeferredContext otherCompletion → + input = tableInput parameter otherCompletion (.position position) := by + intro otherCompletion hotherCompletion + have horiginal := hotherCompletion.of_resolveDeferredPosition + hinvariant.2.1.valuesConsistent hinvariant.2.2.1 position resolved hresultSupport + have hotherAvailable := havailable.changeTable horiginal.1 + exact hinput.trans (tableInput_eq_of_available parameter completion otherCompletion + context.state (.position position) havailable hotherAvailable) + have hcached : finalCache input = some resolved.output := + hresultInvariant.concreteCache_eq_of_positionValue position hots resolved.output + hposition input hcanonical + refine Or.inl ⟨rfl, ?_, ?_, hvisible, ?_⟩ + · simp [hcached] + · rw [ordinaryQueryCache_update_hidden] + exact hinvariant.materialize_resolvedReveal position resolved + (by simpa [resolveDeferredReveal, hresolvable] using hresultSupport) + hresultInvariant hcompletable + · simpa [materializeResolvedPosition] using + hpublished.materialize (.position position) resolved.output + · refine Or.inr ⟨rfl, ?_⟩ + exact ⟨ + hinvariant.2.1.valuesConsistent.materializeResolvedPosition_of table position + resolved (by simpa [resolveDeferredReveal, hresolvable] using hresultSupport), + by simpa [materializeResolvedPosition] using + hinvariant.2.2.1.materialize_position position resolved.output, + hcompletable⟩ + have hmapped := relTriple_map + (R := ReachableResolvedRunRel parameter table) (f := id) (g := recover) hcore + have hrecover : recover <$> (((randomOracle input).run concreteCache >>= fun result => + pure (truncateHash result.1, result.2)) >>= fun result => pure result) = + (randomOracle input).run concreteCache := by + cases hcache : concreteCache input with + | none => + rw [QueryImpl.withCaching_run_none uniformSampleImpl hcache] + simp [recover, QueryCache.cacheQuery_self] + | some output => + rw [QueryImpl.withCaching_run_some uniformSampleImpl hcache] + simp [recover, hcache] + rw [hrecover] at hmapped + simpa [resolveDeferredReveal, hresolvable, materializeResolvedPosition] using hmapped + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_revealPositionOutput_chronological + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (completion : Coordinate → HashOutput) (position : Position) (input : HashInput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hcompletion : DeferredCompletion table context completion) + (hots : IsOtsPosition position) + (havailable : TableInputAvailable completion context.state (.position position)) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hinput : input = tableInput parameter completion (.position position)) : + RelTriple + (runResolvedFromTable context fuel table + ((revealCoordinateOutput (.position position)).run cache)) + ((randomOracle input).run concreteCache) + (ReachableResolvedRunRel parameter table) := by + classical + by_cases hresolvable : ResolvableOtsPosition position + · exact relTriple_runResolvedFromTable_revealResolvablePositionOutput_chronological + parameter table completion position input context fuel cache concreteCache hinvariant + hcompletion hots hresolvable havailable hclosed hpublished hinput + · rw [runResolvedFromTable_revealCoordinateOutput] + have hcanonical : ∀ otherCompletion, DeferredCompletion table context otherCompletion → + input = tableInput parameter otherCompletion (.position position) := by + intro otherCompletion hotherCompletion + have hotherAvailable := havailable.changeTable hotherCompletion.1 + exact hinput.trans (tableInput_eq_of_available parameter completion otherCompletion + context.state (.position position) havailable hotherAvailable) + have hresolve := relTriple_resolveDeferredReveal_chronological parameter table position input + context (ordinaryQueryCache cache) concreteCache hinvariant hots hcanonical + have hrun := resolvedRevealComputation_run_eq_finalQuery_of_available parameter table + completion context concreteCache position input hcompletion havailable hclosed hinput + rw [hrun] at hresolve + have hsupportedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolve + (fun resolved => resolved ∈ support (resolveDeferredReveal table position context)) + (fun resolved hresolved => hresolved) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hsupportedLeft + let recover : Digest × QueryCache HashSpec → HashOutput × QueryCache HashSpec := + fun result => ((result.2 input).getD 0, result.2) + have hcore : RelTriple + (resolveDeferredReveal table position context >>= fun resolved => + match resolved with + | none => pure none + | some resolved => + pure (some ⟨materializeResolvedPosition context position resolved, fuel, + (resolved.output, + Function.update cache (.hidden (.position position)) (some resolved.output)), + table⟩)) + (((randomOracle input).run concreteCache >>= fun result => + pure (truncateHash result.1, result.2)) >>= fun result => pure result) + (fun left right => ReachableResolvedRunRel parameter table left (recover right)) := by + apply relTriple_bind hsupported + intro resolved queryResult hrelation + rcases hrelation with ⟨⟨hresolvedRel, hresultSupport⟩, hrightSupport⟩ + cases resolved with + | none => + apply relTriple_pure_pure + trivial + | some resolved => + apply relTriple_pure_pure + rcases queryResult with ⟨value, finalCache⟩ + rcases hresolvedRel with ⟨_hvalue, hresultInvariant, hposition⟩ + have hpositionSupport : (value, finalCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (resolvedRevealComputation parameter table position input)).run concreteCache) := by + rw [hrun] + exact hrightSupport + have hreplay := replay_of_mem_support + (resolvedRevealComputation parameter table position input) concreteCache value finalCache + hpositionSupport (fromCache finalCache) (agreesWithFn_fromCache finalCache) + have hclosedFinal := hclosed.mono hreplay.1 + have hvisible : VisibleResolvedComputationsCached parameter table + (materializeResolvedPosition context position resolved) finalCache := by + intro other output hotherResolvable hvisibleValue + by_cases heq : other = position + · subst other + exact (hresolvable hotherResolvable).elim + · apply hclosedFinal other output hotherResolvable + simpa [materializeResolvedPosition, LazyRevealProbe.State.materialize, heq] using + hvisibleValue + by_cases hcompletable : DeferredCompletable table + (materializeResolvedPosition context position resolved) + · have hcanonicalAfter : ∀ otherCompletion, + DeferredCompletion table resolved.toDeferredContext otherCompletion → + input = tableInput parameter otherCompletion (.position position) := by + intro otherCompletion hotherCompletion + have horiginal := hotherCompletion.of_resolveDeferredReveal + hinvariant.2.1.valuesConsistent hinvariant.2.2.1 position resolved hresultSupport + have hotherAvailable := havailable.changeTable horiginal.1 + exact hinput.trans (tableInput_eq_of_available parameter completion otherCompletion + context.state (.position position) havailable hotherAvailable) + have hcached : finalCache input = some resolved.output := + hresultInvariant.concreteCache_eq_of_positionValue position hots resolved.output + hposition input hcanonicalAfter + refine Or.inl ⟨rfl, ?_, ?_, hvisible, ?_⟩ + · simp [hcached] + · rw [ordinaryQueryCache_update_hidden] + exact hinvariant.materialize_resolvedReveal position resolved hresultSupport + hresultInvariant hcompletable + · simpa [materializeResolvedPosition] using + hpublished.materialize (.position position) resolved.output + · refine Or.inr ⟨rfl, ?_⟩ + exact ⟨ + hinvariant.2.1.valuesConsistent.materializeResolvedPosition_of table position + resolved hresultSupport, + by simpa [materializeResolvedPosition] using + hinvariant.2.2.1.materialize_position position resolved.output, + hcompletable⟩ + have hmapped := relTriple_map + (R := ReachableResolvedRunRel parameter table) (f := id) (g := recover) hcore + have hrecover : recover <$> (((randomOracle input).run concreteCache >>= fun result => + pure (truncateHash result.1, result.2)) >>= fun result => pure result) = + (randomOracle input).run concreteCache := by + cases hcache : concreteCache input with + | none => + rw [QueryImpl.withCaching_run_none uniformSampleImpl hcache] + simp [recover, QueryCache.cacheQuery_self] + | some output => + rw [QueryImpl.withCaching_run_some uniformSampleImpl hcache] + simp [recover, hcache] + rw [hrecover] at hmapped + simpa [materializeResolvedPosition] using hmapped + +theorem relTriple_runResolvedFromTable_revealChainStart_chronological + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : OtsSecretIndex) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) : + RelTriple + (runResolvedFromTable context fuel table + ((revealChainStart index.lay index.tree index.leafIdx index.chainIdx).run cache)) + (pure (truncateHash (table index), concreteCache) : + ProbComp (Digest × QueryCache HashSpec)) + (ResolvedStructuralRunRel parameter table) := by + have hclean := hinvariant.2.2.2.1.not_hitAt_chainStart index + rw [runResolvedFromTable_revealChainStart_of_agrees context fuel table index cache + hinvariant.2.2.1 hclean] + apply relTriple_pure_pure + refine ⟨rfl, rfl, Or.inl ?_⟩ + rw [ordinaryQueryCache_update_hidden] + exact hinvariant.materialize_chainStart index + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_maskedChainValue_chronological + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) : + RelTriple + (runResolvedFromTable context fuel table + ((maskedChainValue lay tree leafIdx chainIdx digit).run cache)) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (chainWalk parameter lay tree leafIdx chainIdx 0 digit.val + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)))).run concreteCache) + (ResolvedStructuralRunRel parameter table) := by + obtain ⟨reservedContext, hreserve, hreservedInvariant⟩ := + (resolvedAdministrative_ensureChainPrefix lay tree leafIdx chainIdx digit).run_preserves_invariant + context cache fuel concreteCache hinvariant + unfold maskedChainValue + rw [StateT.run_bind, runResolvedFromTable_bind, hreserve] + simp only [pure_bind] + by_cases hzero : digit.val = 0 + · rw [dif_pos hzero] + have hstart := relTriple_runResolvedFromTable_revealChainStart_chronological + parameter table ⟨lay, tree, leafIdx, chainIdx⟩ reservedContext fuel cache concreteCache + hreservedInvariant + simpa [hzero, chainWalk] using hstart + · rw [dif_neg hzero] + let step : ChainStep := ⟨digit.val - 1, by + have := digit.isLt + omega⟩ + have hposition := + relTriple_runResolvedFromTable_revealResolvablePosition_chronological parameter table + (.chain lay tree leafIdx chainIdx step) reservedContext fuel cache concreteCache + hreservedInvariant (by simp [ResolvableOtsPosition]) + have hpositive : 0 < digit.val := Nat.pos_of_ne_zero hzero + have hsteps : step.val + 1 = digit.val := by + simp [step] + omega + simpa [resolvedPositionComputation, step, hsteps] using hposition + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_maskedTreeNode_chronological + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) + (hlevel : level ≤ maxLayerHeight) + (hspan : 2 ^ level * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) : + RelTriple + (runResolvedFromTable context fuel table + ((maskedTreeNode lay tree level nodeIdx).run cache)) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay tree + (fun leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + level nodeIdx)).run concreteCache) + (ResolvedStructuralRunRel parameter table) := by + obtain ⟨reservedContext, hreserve, hreservedInvariant⟩ := + (resolvedAdministrative_ensureTreeNode lay tree level nodeIdx).run_preserves_invariant + context cache fuel concreteCache hinvariant + unfold maskedTreeNode + rw [StateT.run_bind, runResolvedFromTable_bind, hreserve] + simp only [pure_bind] + cases level with + | zero => + have hposition := + relTriple_runResolvedFromTable_revealResolvablePosition_chronological parameter table + (.leaf lay tree (leafOfNat nodeIdx)) reservedContext fuel cache concreteCache + hreservedInvariant (by simp [ResolvableOtsPosition]) + rw [treeNode_zero_eq] + simpa [resolvedPositionComputation] using hposition + | succ current => + have hcurrent : current < maxLayerHeight := by omega + simp only [hcurrent, ↓reduceDIte] + have hnodeLt : nodeIdx < 2 ^ maxLayerHeight := by + have hpow : 0 < 2 ^ (current + 1) := pow_pos (by omega) _ + nlinarith + have hnodeVal : (leafOfNat nodeIdx).val = nodeIdx := by + simp [leafOfNat, Nat.mod_eq_of_lt hnodeLt] + have hresolvable : ResolvableOtsPosition + (.node lay tree ⟨current, hcurrent⟩ (leafOfNat nodeIdx)) := by + simp [ResolvableOtsPosition, hnodeVal] + exact hspan + have hposition := + relTriple_runResolvedFromTable_revealResolvablePosition_chronological parameter table + (.node lay tree ⟨current, hcurrent⟩ (leafOfNat nodeIdx)) reservedContext fuel cache + concreteCache hreservedInvariant hresolvable + simpa [resolvedPositionComputation, hnodeVal] using hposition + +theorem relTriple_runResolvedFromTable_splitHashQuery_clean_or_doomed + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (hstable : StableOrdinaryInput parameter input) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) : + RelTriple + (runResolvedFromTable context fuel table + ((splitHashQuery (.ordinary input)).run cache)) + ((randomOracle input).run concreteCache) + (ResolvedRunRel parameter table) := by + apply relTriple_post_mono + (relTriple_runResolvedFromTable_splitHashQuery_stable parameter table input hstable + context fuel cache concreteCache hinvariant) + intro leftResult rightResult hrelation + exact hrelation.to_resolvedRunRel + +theorem relTriple_runResolvedFromTable_maskedChainValue_clean_or_doomed + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) : + RelTriple + (runResolvedFromTable context fuel table + ((maskedChainValue lay tree leafIdx chainIdx digit).run cache)) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (chainWalk parameter lay tree leafIdx chainIdx 0 digit.val + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)))).run concreteCache) + (ResolvedRunRel parameter table) := by + apply relTriple_post_mono + (relTriple_runResolvedFromTable_maskedChainValue_chronological parameter table lay tree + leafIdx chainIdx digit context fuel cache concreteCache hinvariant) + intro leftResult rightResult hrelation + exact hrelation.to_resolvedRunRel + +theorem relTriple_runResolvedFromTable_maskedTreeNode_clean_or_doomed + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) + (hlevel : level ≤ maxLayerHeight) + (hspan : 2 ^ level * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) : + RelTriple + (runResolvedFromTable context fuel table + ((maskedTreeNode lay tree level nodeIdx).run cache)) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay tree + (fun leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + level nodeIdx)).run concreteCache) + (ResolvedRunRel parameter table) := by + apply relTriple_post_mono + (relTriple_runResolvedFromTable_maskedTreeNode_chronological parameter table lay tree level + nodeIdx hlevel hspan context fuel cache concreteCache hinvariant) + intro leftResult rightResult hrelation + exact hrelation.to_resolvedRunRel + +theorem resolvedCouples_splitHashQuery + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (hstable : StableOrdinaryInput parameter input) : + ResolvedCouples parameter table (splitHashQuery (.ordinary input)) + (randomOracle input) := by + intro context fuel cache concreteCache hinvariant + exact relTriple_runResolvedFromTable_splitHashQuery_clean_or_doomed parameter table input + hstable context fuel cache concreteCache hinvariant + +theorem resolvedCouples_probingHashQuery_of_stable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (hstable : StableOrdinaryInput parameter input) : + ResolvedCouples parameter table (probingHashQuery parameter input) + (randomOracle input) := by + rw [probingHashQuery_eq_splitHashQuery_of_stable parameter input hstable] + exact resolvedCouples_splitHashQuery parameter table input hstable + +theorem resolvedCouples_verifierHashQuery_of_stable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (hstable : StableOrdinaryInput parameter input) : + ResolvedCouples parameter table (verifierHashQuery parameter input) + (randomOracle input) := by + rw [verifierHashQuery_eq_splitHashQuery_of_stable parameter input hstable] + exact resolvedCouples_splitHashQuery parameter table input hstable + +theorem runResolvedFromTable_peekCoordinate_of_value + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) (coordinate : Coordinate) (output : HashOutput) + (hvalue : context.state.values coordinate = some output) : + runResolvedFromTable context fuel table ((peekCoordinate coordinate).run cache) = + pure (some ⟨context, fuel, (some (truncateHash output), cache), table⟩) := by + unfold peekCoordinate + rw [StateT.run_bind, runResolvedFromTable_bind, StateT.run_liftM, + LazyRevealProbe.peekQuery, + runResolvedFromTable_peek_query_bind] + simp [hvalue, runResolvedFromTable] + +theorem runResolvedFromTable_peekCoordinate_of_none + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) (coordinate : Coordinate) + (hvalue : context.state.values coordinate = none) : + runResolvedFromTable context fuel table ((peekCoordinate coordinate).run cache) = + pure (some ⟨context, fuel, (none, cache), table⟩) := by + unfold peekCoordinate + rw [StateT.run_bind, runResolvedFromTable_bind, StateT.run_liftM, + LazyRevealProbe.peekQuery, + runResolvedFromTable_peek_query_bind] + simp [hvalue, runResolvedFromTable] + +theorem runResolvedFromTable_probeFirstMissingInputCoordinate_of_values + (values : Coordinate → HashOutput) (input : HashInput) + (context : DeferredContext) (cache : SplitHashCache) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) : ∀ (slot : Nat) (coordinates : List Coordinate), + (∀ coordinate, coordinate ∈ coordinates → + context.state.values coordinate = some (values coordinate)) → + runResolvedFromTable context fuel table + ((probeFirstMissingInputCoordinate input slot coordinates).run cache) = + pure (some ⟨context, fuel, ((), cache), table⟩) + | _, [], _ => by simp [probeFirstMissingInputCoordinate, runResolvedFromTable] + | slot, coordinate :: remaining, hvalues => by + rw [probeFirstMissingInputCoordinate, StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekCoordinate_of_value context fuel table cache coordinate + (values coordinate) (hvalues coordinate (by simp))] + simp only [pure_bind] + exact runResolvedFromTable_probeFirstMissingInputCoordinate_of_values values input context + cache fuel table (slot + 1) remaining + (fun other hother => hvalues other (by simp [hother])) + +set_option maxRecDepth 10000 in +theorem runResolvedFromTable_probeFirstMissingInputCoordinate_of_prefix_values_of_missing + (values : Coordinate → HashOutput) (input : HashInput) + (context : DeferredContext) (cache : SplitHashCache) + (fuel slot : Nat) (prior remaining : List Coordinate) (coordinate : Coordinate) + (table : OtsSecretIndex → HashOutput) + (hvalues : ∀ other, other ∈ prior → + context.state.values other = some (values other)) + (hmissing : context.state.values coordinate = none) + (hnotRevealed : coordinate ∉ context.state.revealed) : + runResolvedFromTable context (fuel + 1) table + ((probeFirstMissingInputCoordinate input slot + (prior ++ coordinate :: remaining)).run cache) = + pure (some ⟨ + { context with state := (context.state.addPending coordinate + (slotDigest (slot + prior.length) input)) }, + fuel, ((), cache), table⟩) := by + induction prior generalizing slot with + | nil => + rw [List.nil_append, probeFirstMissingInputCoordinate, StateT.run_bind, + runResolvedFromTable_bind, + runResolvedFromTable_peekCoordinate_of_none context (fuel + 1) table cache coordinate + hmissing, + pure_bind] + change runResolvedFromTable context (fuel + 1) table + (LazyRevealProbe.probeQuery coordinate (slotDigest slot input) >>= fun result => + pure (result, cache)) = _ + rw [LazyRevealProbe.probeQuery, runResolvedFromTable_probe_query_bind, + show fuel + 1 = Nat.succ fuel by omega] + simp [hnotRevealed, runResolvedFromTable] + | cons head tail ih => + rw [List.cons_append, probeFirstMissingInputCoordinate, StateT.run_bind, + runResolvedFromTable_bind, + runResolvedFromTable_peekCoordinate_of_value context (fuel + 1) table cache head + (values head) (hvalues head (by simp))] + simp only [pure_bind] + have htailValues : ∀ other, other ∈ tail → + context.state.values other = some (values other) := by + intro other hother + exact hvalues other (by simp [hother]) + rw [ih (slot + 1) htailValues] + congr 4 + simp [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] + +set_option maxRecDepth 10000 in +theorem runResolvedFromTable_probeFirstMissingInputCoordinate_zero_of_prefix_values_of_missing + (values : Coordinate → HashOutput) (input : HashInput) + (context : DeferredContext) (cache : SplitHashCache) + (slot : Nat) (prior remaining : List Coordinate) (coordinate : Coordinate) + (table : OtsSecretIndex → HashOutput) + (hvalues : ∀ other, other ∈ prior → + context.state.values other = some (values other)) + (hmissing : context.state.values coordinate = none) : + runResolvedFromTable context 0 table + ((probeFirstMissingInputCoordinate input slot + (prior ++ coordinate :: remaining)).run cache) = pure none := by + induction prior generalizing slot with + | nil => + rw [List.nil_append, probeFirstMissingInputCoordinate, StateT.run_bind, + runResolvedFromTable_bind, + runResolvedFromTable_peekCoordinate_of_none context 0 table cache coordinate hmissing, + pure_bind] + change runResolvedFromTable context 0 table + (LazyRevealProbe.probeQuery coordinate (slotDigest slot input) >>= fun result => + pure (result, cache)) = _ + rw [LazyRevealProbe.probeQuery, runResolvedFromTable_probe_query_bind] + | cons head tail ih => + rw [List.cons_append, probeFirstMissingInputCoordinate, StateT.run_bind, + runResolvedFromTable_bind, + runResolvedFromTable_peekCoordinate_of_value context 0 table cache head + (values head) (hvalues head (by simp))] + simp only [pure_bind] + exact ih (slot + 1) (fun other hother => hvalues other (by simp [hother])) + +theorem runResolvedFromTable_peekPositionValues_of_values + (completion : Coordinate → HashOutput) (context : DeferredContext) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : + ∀ positions : List Position, + (∀ position, position ∈ positions → + context.state.values (.position position) = some (completion (.position position))) → + runResolvedFromTable context fuel table ((peekPositionValues positions).run cache) = + pure (some ⟨context, fuel, + (some (positions.map (tableValue completion)), cache), table⟩) + | [], _ => by simp [peekPositionValues, runResolvedFromTable] + | position :: remaining, hvalues => by + rw [peekPositionValues, StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekCoordinate_of_value context fuel table cache + (.position position) (completion (.position position)) + (hvalues position (by simp))] + simp only [pure_bind] + rw [StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekPositionValues_of_values completion context fuel table cache + remaining (fun other hother => hvalues other (by simp [hother]))] + simp [runResolvedFromTable, tableValue] + +theorem runResolvedFromTable_peekPositionValues_of_prefix_values_of_missing + (completion : Coordinate → HashOutput) (context : DeferredContext) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (prior remaining : List Position) (position : Position) + (hvalues : ∀ other, other ∈ prior → + context.state.values (.position other) = some (completion (.position other))) + (hmissing : context.state.values (.position position) = none) : + runResolvedFromTable context fuel table + ((peekPositionValues (prior ++ position :: remaining)).run cache) = + pure (some ⟨context, fuel, (none, cache), table⟩) := by + induction prior with + | nil => + rw [List.nil_append, peekPositionValues, StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekCoordinate_of_none context fuel table cache + (.position position) hmissing] + simp [runResolvedFromTable] + | cons head tail ih => + rw [List.cons_append, peekPositionValues, StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekCoordinate_of_value context fuel table cache (.position head) + (completion (.position head)) (hvalues head (by simp))] + simp only [pure_bind] + rw [StateT.run_bind, runResolvedFromTable_bind, + ih (fun other hother => hvalues other (by simp [hother]))] + simp [runResolvedFromTable] + +theorem runResolvedFromTable_peekTableInput_of_available + (parameter : PublicParameter) (completion : Coordinate → HashOutput) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) (coordinate : Coordinate) + (havailable : TableInputAvailable completion context.state coordinate) : + runResolvedFromTable context fuel table + ((peekTableInput parameter coordinate).run cache) = + pure (some ⟨context, fuel, + (some (tableInput parameter completion coordinate), cache), table⟩) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [TableInputAvailable] at havailable + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput.eq_2] + by_cases hzero : step.val = 0 + · rw [if_pos hzero, StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekCoordinate_of_value context fuel table cache + (.chainStart lay tree leafIdx chainIdx) + (completion (.chainStart lay tree leafIdx chainIdx)) + (by simpa [TableInputAvailable, hzero] using havailable)] + simp [runResolvedFromTable, tableInput, tablePayload, hzero] + · rw [if_neg hzero, StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekPositionValues_of_values completion context fuel table + cache _ (by simpa [TableInputAvailable, hzero] using havailable)] + simp [runResolvedFromTable, tableInput, tablePayload, hzero] + | leaf lay tree leafIdx => + rw [peekTableInput.eq_3 parameter (.leaf lay tree leafIdx) (by simp), + StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekPositionValues_of_values completion context fuel table cache + _ havailable] + simp [runResolvedFromTable, tableInput, tablePayload] + | node lay tree level nodeIdx => + rw [peekTableInput.eq_3 parameter (.node lay tree level nodeIdx) (by simp), + StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekPositionValues_of_values completion context fuel table cache + _ havailable] + simp [runResolvedFromTable, tableInput, tablePayload] + | ftsLeaf index tree leafIdx => + rw [peekTableInput.eq_3 parameter (.ftsLeaf index tree leafIdx) (by simp), + StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekPositionValues_of_values completion context fuel table cache + _ havailable] + simp [runResolvedFromTable, tableInput, tablePayload] + | ftsNode index tree level nodeIdx => + rw [peekTableInput.eq_3 parameter (.ftsNode index tree level nodeIdx) (by simp), + StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekPositionValues_of_values completion context fuel table cache + _ havailable] + simp [runResolvedFromTable, tableInput, tablePayload] + | ftsRoots index => + rw [peekTableInput.eq_3 parameter (.ftsRoots index) (by simp), + StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekPositionValues_of_values completion context fuel table cache + _ havailable] + simp [runResolvedFromTable, tableInput, tablePayload] + +theorem runResolvedFromTable_peekTableInput_of_unavailable + (parameter : PublicParameter) (completion : Coordinate → HashOutput) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) (coordinate : Coordinate) + (hcompletion : DeferredCompletion table context completion) + (hots : ∀ position, coordinate = .position position → IsOtsPosition position) + (hunavailable : ¬TableInputAvailable completion context.state coordinate) : + runResolvedFromTable context fuel table + ((peekTableInput parameter coordinate).run cache) = + pure (some ⟨context, fuel, (none, cache), table⟩) := by + have htable : ∀ coordinate output, + context.state.values coordinate = some output → output = completion coordinate := by + intro other output hvalue + exact (hcompletion.1 other output hvalue).symm + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [peekTableInput, runResolvedFromTable] + | position position => + cases position with + | chain lay tree leafIdx chainIdx step => + rw [peekTableInput.eq_2] + by_cases hzero : step.val = 0 + · rw [if_pos hzero, StateT.run_bind, runResolvedFromTable_bind] + have hnone : context.state.values (.chainStart lay tree leafIdx chainIdx) = none := by + cases hvalue : context.state.values (.chainStart lay tree leafIdx chainIdx) with + | none => rfl + | some output => + have hsame := htable (.chainStart lay tree leafIdx chainIdx) output hvalue + exfalso + apply hunavailable + simpa [TableInputAvailable, hzero, hsame] using hvalue + rw [runResolvedFromTable_peekCoordinate_of_none context fuel table cache _ hnone] + simp [runResolvedFromTable] + · rw [if_neg hzero, StateT.run_bind, runResolvedFromTable_bind] + rcases positionValues_or_first_missing completion context.state + (Position.chain lay tree leafIdx chainIdx step).children + (fun other output hvalue => + htable (.position other) output hvalue) with havailable | + ⟨prior, child, remaining, hchildren, hvalues, hmissing⟩ + · exact (hunavailable (by simpa [TableInputAvailable, hzero] using havailable)).elim + · rw [hchildren, + runResolvedFromTable_peekPositionValues_of_prefix_values_of_missing completion + context fuel table cache prior remaining child hvalues hmissing] + simp [runResolvedFromTable] + | leaf lay tree leafIdx => + rw [peekTableInput.eq_3 parameter (.leaf lay tree leafIdx) (by simp), + StateT.run_bind, runResolvedFromTable_bind] + rcases positionValues_or_first_missing completion context.state + (Position.leaf lay tree leafIdx).children (fun other output hvalue => + htable (.position other) output hvalue) with havailable | + ⟨prior, child, remaining, hchildren, hvalues, hmissing⟩ + · exact (hunavailable havailable).elim + · rw [hchildren, + runResolvedFromTable_peekPositionValues_of_prefix_values_of_missing completion + context fuel table cache prior remaining child hvalues hmissing] + simp [runResolvedFromTable] + | node lay tree level nodeIdx => + rw [peekTableInput.eq_3 parameter (.node lay tree level nodeIdx) (by simp), + StateT.run_bind, runResolvedFromTable_bind] + rcases positionValues_or_first_missing completion context.state + (Position.node lay tree level nodeIdx).children (fun other output hvalue => + htable (.position other) output hvalue) with havailable | + ⟨prior, child, remaining, hchildren, hvalues, hmissing⟩ + · exact (hunavailable havailable).elim + · rw [hchildren, + runResolvedFromTable_peekPositionValues_of_prefix_values_of_missing completion + context fuel table cache prior remaining child hvalues hmissing] + simp [runResolvedFromTable] + | ftsLeaf index tree leafIdx => simpa [IsOtsPosition] using hots _ rfl + | ftsNode index tree level nodeIdx => simpa [IsOtsPosition] using hots _ rfl + | ftsRoots index => simpa [IsOtsPosition] using hots _ rfl + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_resolveKnownInput_completionCanonical + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (completion : Coordinate → HashOutput) (position : Position) (input : HashInput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hcompletion : DeferredCompletion table context completion) + (hots : IsOtsPosition position) + (hresolvable : ResolvableOtsPosition position) + (havailable : TableInputAvailable completion context.state (.position position)) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hinput : input = tableInput parameter completion (.position position)) : + RelTriple + (runResolvedFromTable context fuel table + ((resolveKnownInput parameter (.position position) input).run cache)) + ((randomOracle input).run concreteCache) + (ResolvedRunRel parameter table) := by + unfold resolveKnownInput + rw [StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekTableInput_of_available parameter completion context fuel table + cache (.position position) havailable] + simp only [pure_bind] + rw [if_pos hinput.symm] + change RelTriple + (runResolvedFromTable context fuel table + ((revealCoordinateOutput (.position position) >>= fun output => + publishOrdinaryInput (.position position) input output).run cache)) + ((randomOracle input).run concreteCache) + (ResolvedRunRel parameter table) + rw [StateT.run_bind, runResolvedFromTable_bind] + have hreveal := + relTriple_runResolvedFromTable_revealResolvablePositionOutput_chronological parameter table + completion position input context fuel cache concreteCache hinvariant hcompletion hots + hresolvable havailable hclosed hpublished hinput + have hsupportedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hreveal + (fun result => result ∈ support + (runResolvedFromTable context fuel table + ((revealCoordinateOutput (.position position)).run cache))) + (fun result hresult => hresult) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hsupportedLeft + rw [show (randomOracle input).run concreteCache = + ((randomOracle input).run concreteCache >>= fun result => pure result) by simp] + apply relTriple_bind hsupported + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResult with + | none => + apply relTriple_pure_pure + trivial + | some result => + rcases hrelation with hclean | hdoomed + · have hcached : rightResult.2 input = some rightResult.1 := + randomOracle_run_output_cached input concreteCache rightResult.2 rightResult.1 + hrightSupport + simpa [hclean.1, hclean.2.1] using + (relTriple_runResolvedFromTable_publishOrdinaryInput parameter table + (.position position) input rightResult.1 result.context result.remaining + result.value.2 rightResult.2 hclean.2.2.1 hcached) + · simpa [hdoomed.1] using + (relTriple_runResolvedFromTable_of_doomed parameter table + (publishOrdinaryInput (.position position) input result.value.1) + (pure rightResult) result.context result.remaining result.value.2 hdoomed.2) + +theorem relTriple_runResolvedFromTable_resolveKnownInput_completionOrdinary + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (coordinate : Coordinate) (input : HashInput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hots : ∀ position, coordinate = .position position → IsOtsPosition position) + (hordinary : CompletionOrdinaryInput parameter table context input) : + RelTriple + (runResolvedFromTable context fuel table + ((resolveKnownInput parameter coordinate input).run cache)) + ((randomOracle input).run concreteCache) + (ResolvedOrdinaryRunRel parameter table) := by + obtain ⟨completion, hcompletion⟩ := hinvariant.2.2.2.1 + unfold resolveKnownInput + rw [StateT.run_bind, runResolvedFromTable_bind] + by_cases havailable : TableInputAvailable completion context.state coordinate + · rw [runResolvedFromTable_peekTableInput_of_available parameter completion context fuel table + cache coordinate havailable] + simp only [pure_bind] + have hne : tableInput parameter completion coordinate ≠ input := by + intro heq + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [TableInputAvailable] at havailable + | position position => + exact hordinary completion hcompletion position (hots position rfl) heq.symm + rw [if_neg hne] + exact relTriple_runResolvedFromTable_splitHashQuery_completionOrdinary parameter table input + context hordinary fuel cache concreteCache hinvariant + · rw [runResolvedFromTable_peekTableInput_of_unavailable parameter completion context fuel table + cache coordinate hcompletion hots havailable] + simp only [pure_bind] + exact relTriple_runResolvedFromTable_splitHashQuery_completionOrdinary parameter table input + context hordinary fuel cache concreteCache hinvariant + +theorem relTriple_runResolvedFromTable_publishOrdinaryInput_reachable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (coordinate : Coordinate) (input : HashInput) (output : HashOutput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hvalue : context.state.values coordinate ≠ none) + (hconcrete : concreteCache input = some output) : + RelTriple + (runResolvedFromTable context fuel table + ((publishOrdinaryInput coordinate input output).run cache)) + (pure (output, concreteCache) : ProbComp (HashOutput × QueryCache HashSpec)) + (ReachableResolvedRunRel parameter table) := by + unfold publishOrdinaryInput publishCoordinate + rw [StateT.run_bind, runResolvedFromTable_bind, StateT.run_liftM, + LazyRevealProbe.publishQuery, runResolvedFromTable_publish_query_bind] + simp only [runResolvedFromTable, pure_bind] + apply relTriple_pure_pure + refine Or.inl ⟨rfl, rfl, ?_, hclosed.of_state_values_eq rfl, ?_⟩ + · rw [ordinaryQueryCache_update] + exact hinvariant.cacheLeft_of_concrete input output hconcrete + · intro other hrevealed + simp only [LazyRevealProbe.State.publish, Finset.mem_insert] at hrevealed + rcases hrevealed with heq | hrevealed + · subst other + exact hvalue + · exact hpublished other hrevealed + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_resolveKnownInput_completionCanonical_reachable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (completion : Coordinate → HashOutput) (position : Position) (input : HashInput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hcompletion : DeferredCompletion table context completion) + (hots : IsOtsPosition position) + (hresolvable : ResolvableOtsPosition position) + (havailable : TableInputAvailable completion context.state (.position position)) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hinput : input = tableInput parameter completion (.position position)) : + RelTriple + (runResolvedFromTable context fuel table + ((resolveKnownInput parameter (.position position) input).run cache)) + ((randomOracle input).run concreteCache) + (ReachableResolvedRunRel parameter table) := by + unfold resolveKnownInput + rw [StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekTableInput_of_available parameter completion context fuel table + cache (.position position) havailable] + simp only [pure_bind] + rw [if_pos hinput.symm] + change RelTriple + (runResolvedFromTable context fuel table + ((revealCoordinateOutput (.position position) >>= fun output => + publishOrdinaryInput (.position position) input output).run cache)) + ((randomOracle input).run concreteCache) + (ReachableResolvedRunRel parameter table) + rw [StateT.run_bind, runResolvedFromTable_bind] + have hreveal := + relTriple_runResolvedFromTable_revealResolvablePositionOutput_chronological parameter table + completion position input context fuel cache concreteCache hinvariant hcompletion hots + hresolvable havailable hclosed hpublished hinput + have hsupportedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hreveal + (fun result => result ∈ support + (runResolvedFromTable context fuel table + ((revealCoordinateOutput (.position position)).run cache))) + (fun result hresult => hresult) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hsupportedLeft + rw [show (randomOracle input).run concreteCache = + ((randomOracle input).run concreteCache >>= fun result => pure result) by simp] + apply relTriple_bind hsupported + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResult with + | none => + apply relTriple_pure_pure + trivial + | some result => + rcases hrelation with hclean | hdoomed + · have hcached : rightResult.2 input = some rightResult.1 := + randomOracle_run_output_cached input concreteCache rightResult.2 rightResult.1 + hrightSupport + simpa [hclean.1, hclean.2.1] using + (relTriple_runResolvedFromTable_publishOrdinaryInput_reachable parameter table + (.position position) input rightResult.1 result.context result.remaining + result.value.2 rightResult.2 hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 + (by + rw [value_of_mem_runResolvedFromTable_revealCoordinateOutput context fuel table + (.position position) cache result hleftSupport] + simp) + hcached) + · simpa [hdoomed.1] using + (relTriple_runResolvedFromTable_of_doomed_reachable parameter table + (publishOrdinaryInput (.position position) input result.value.1) + (pure rightResult) result.context result.remaining result.value.2 hdoomed.2) + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_resolveKnownInput_completionCanonicalAny_reachable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (completion : Coordinate → HashOutput) (position : Position) (input : HashInput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hcompletion : DeferredCompletion table context completion) + (hots : IsOtsPosition position) + (havailable : TableInputAvailable completion context.state (.position position)) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hinput : input = tableInput parameter completion (.position position)) : + RelTriple + (runResolvedFromTable context fuel table + ((resolveKnownInput parameter (.position position) input).run cache)) + ((randomOracle input).run concreteCache) + (ReachableResolvedRunRel parameter table) := by + classical + by_cases hresolvable : ResolvableOtsPosition position + · exact relTriple_runResolvedFromTable_resolveKnownInput_completionCanonical_reachable + parameter table completion position input context fuel cache concreteCache hinvariant + hcompletion hots hresolvable havailable hclosed hpublished hinput + · unfold resolveKnownInput + rw [StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_peekTableInput_of_available parameter completion context fuel table + cache (.position position) havailable] + simp only [pure_bind] + rw [if_pos hinput.symm] + change RelTriple + (runResolvedFromTable context fuel table + ((revealCoordinateOutput (.position position) >>= fun output => + publishOrdinaryInput (.position position) input output).run cache)) + ((randomOracle input).run concreteCache) + (ReachableResolvedRunRel parameter table) + rw [StateT.run_bind, runResolvedFromTable_bind] + have hreveal := + relTriple_runResolvedFromTable_revealPositionOutput_chronological parameter table + completion position input context fuel cache concreteCache hinvariant hcompletion hots + havailable hclosed hpublished hinput + have hsupportedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hreveal + (fun result => result ∈ support + (runResolvedFromTable context fuel table + ((revealCoordinateOutput (.position position)).run cache))) + (fun result hresult => hresult) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hsupportedLeft + rw [show (randomOracle input).run concreteCache = + ((randomOracle input).run concreteCache >>= fun result => pure result) by simp] + apply relTriple_bind hsupported + intro leftResult rightResult hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResult with + | none => + apply relTriple_pure_pure + trivial + | some result => + rcases hrelation with hclean | hdoomed + · have hcached : rightResult.2 input = some rightResult.1 := + randomOracle_run_output_cached input concreteCache rightResult.2 rightResult.1 + hrightSupport + simpa [hclean.1, hclean.2.1] using + (relTriple_runResolvedFromTable_publishOrdinaryInput_reachable parameter table + (.position position) input rightResult.1 result.context result.remaining + result.value.2 rightResult.2 hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 + (by + rw [value_of_mem_runResolvedFromTable_revealCoordinateOutput context fuel table + (.position position) cache result hleftSupport] + simp) + hcached) + · simpa [hdoomed.1] using + (relTriple_runResolvedFromTable_of_doomed_reachable parameter table + (publishOrdinaryInput (.position position) input result.value.1) + (pure rightResult) result.context result.remaining result.value.2 hdoomed.2) + +theorem relTriple_runResolvedFromTable_resolveKnownInput_completionOrdinary_reachable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (coordinate : Coordinate) (input : HashInput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hots : ∀ position, coordinate = .position position → IsOtsPosition position) + (hordinary : CompletionOrdinaryInput parameter table context input) : + RelTriple + (runResolvedFromTable context fuel table + ((resolveKnownInput parameter coordinate input).run cache)) + ((randomOracle input).run concreteCache) + (ReachableResolvedRunRel parameter table) := by + obtain ⟨completion, hcompletion⟩ := hinvariant.2.2.2.1 + unfold resolveKnownInput + rw [StateT.run_bind, runResolvedFromTable_bind] + by_cases havailable : TableInputAvailable completion context.state coordinate + · rw [runResolvedFromTable_peekTableInput_of_available parameter completion context fuel table + cache coordinate havailable] + simp only [pure_bind] + have hne : tableInput parameter completion coordinate ≠ input := by + intro heq + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [TableInputAvailable] at havailable + | position position => + exact hordinary completion hcompletion position (hots position rfl) heq.symm + rw [if_neg hne] + exact relTriple_runResolvedFromTable_splitHashQuery_completionOrdinary_reachable parameter + table input context hordinary fuel cache concreteCache hinvariant hclosed hpublished + · rw [runResolvedFromTable_peekTableInput_of_unavailable parameter completion context fuel table + cache coordinate hcompletion hots havailable] + simp only [pure_bind] + exact relTriple_runResolvedFromTable_splitHashQuery_completionOrdinary_reachable parameter + table input context hordinary fuel cache concreteCache hinvariant hclosed hpublished + +theorem completionOrdinaryInput_of_available_decoded_ne + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {completion : Coordinate → HashOutput} + {position : Position} {input : HashInput} + (hdecode : decodePosition? parameter input = some position) + (havailable : TableInputAvailable completion context.state (.position position)) + (hne : tableInput parameter completion (.position position) ≠ input) : + CompletionOrdinaryInput parameter table context input := by + intro otherCompletion hotherCompletion otherPosition _hots heq + have hdecodeOther : decodePosition? parameter input = some otherPosition := by + rw [heq] + exact (decodePosition?_eq_some_iff parameter _ otherPosition).2 + ⟨tablePayload otherCompletion otherPosition, rfl⟩ + have hposition : otherPosition = position := by + rw [hdecode] at hdecodeOther + exact Option.some.inj hdecodeOther.symm + subst otherPosition + have hotherAvailable := havailable.changeTable hotherCompletion.1 + have htable := tableInput_eq_of_available parameter completion otherCompletion context.state + (.position position) havailable hotherAvailable + exact hne (htable.trans heq.symm) + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_resolveKnownInput_availableDecoded_reachable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (position : Position) (input : HashInput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hots : IsOtsPosition position) + (hresolvable : ResolvableOtsPosition position) + (hdecode : decodePosition? parameter input = some position) + (completion : Coordinate → HashOutput) + (hcompletion : DeferredCompletion table context completion) + (havailable : TableInputAvailable completion context.state (.position position)) : + RelTriple + (runResolvedFromTable context fuel table + ((resolveKnownInput parameter (.position position) input).run cache)) + ((randomOracle input).run concreteCache) + (ReachableResolvedRunRel parameter table) := by + by_cases hinput : tableInput parameter completion (.position position) = input + · exact relTriple_runResolvedFromTable_resolveKnownInput_completionCanonical_reachable + parameter table completion position input context fuel cache concreteCache hinvariant + hcompletion hots hresolvable havailable hclosed hpublished hinput.symm + · exact relTriple_runResolvedFromTable_resolveKnownInput_completionOrdinary_reachable + parameter table (.position position) input context fuel cache concreteCache hinvariant hclosed + hpublished (fun other heq => by cases heq; exact hots) + (completionOrdinaryInput_of_available_decoded_ne hdecode havailable hinput) + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_resolveKnownInput_availableDecodedAny_reachable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (position : Position) (input : HashInput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hots : IsOtsPosition position) + (hdecode : decodePosition? parameter input = some position) + (completion : Coordinate → HashOutput) + (hcompletion : DeferredCompletion table context completion) + (havailable : TableInputAvailable completion context.state (.position position)) : + RelTriple + (runResolvedFromTable context fuel table + ((resolveKnownInput parameter (.position position) input).run cache)) + ((randomOracle input).run concreteCache) + (ReachableResolvedRunRel parameter table) := by + by_cases hinput : tableInput parameter completion (.position position) = input + · exact relTriple_runResolvedFromTable_resolveKnownInput_completionCanonicalAny_reachable + parameter table completion position input context fuel cache concreteCache hinvariant + hcompletion hots havailable hclosed hpublished hinput.symm + · exact relTriple_runResolvedFromTable_resolveKnownInput_completionOrdinary_reachable + parameter table (.position position) input context fuel cache concreteCache hinvariant hclosed + hpublished (fun other heq => by cases heq; exact hots) + (completionOrdinaryInput_of_available_decoded_ne hdecode havailable hinput) + +theorem tableInputAvailable_chain_of_probe_revealed + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {completion : Coordinate → HashOutput} + {input : HashInput} {candidate : Probe} + {lay : Layer} {tree : TreeIndex} {leafIdx : LeafIndex} + {chainIdx : ChainIndex} {step : ChainStep} + (hcompletion : DeferredCompletion table context completion) + (hpublished : PublishedValues context.state) + (hmatches : candidate.MatchesInput parameter input) + (houtput : candidate.outputCoordinate = + .position (.chain lay tree leafIdx chainIdx step)) + (hrevealed : candidate.coordinate ∈ context.state.revealed) : + TableInputAvailable completion context.state + (.position (.chain lay tree leafIdx chainIdx step)) := by + obtain ⟨sourceOutput, hsourceValue⟩ := + Option.ne_none_iff_exists'.mp (hpublished candidate.coordinate hrevealed) + have hsourceTable := hcompletion.1 candidate.coordinate sourceOutput hsourceValue + rw [← houtput] + rcases candidate with ⟨coordinate, candidateDigest⟩ + cases coordinate with + | chainStart sourceLay sourceTree sourceLeaf sourceChain => + rcases hmatches with ⟨_sourceStep, _hzero, _hinput⟩ + simp [Probe.outputCoordinate, TableInputAvailable, hsourceTable, hsourceValue] + | position source => + cases source with + | chain sourceLay sourceTree sourceLeaf sourceChain sourceStep => + simp only [Probe.MatchesInput] at hmatches + by_cases hnext : sourceStep.val + 1 < chainLength - 1 + · rw [dif_pos hnext] at hmatches + rcases hmatches with ⟨_nextStep, _hnextValue, _hinput⟩ + simp [Probe.outputCoordinate, hnext, TableInputAvailable, Position.children, + hsourceTable, hsourceValue] + · simp [Probe.outputCoordinate, hnext] at houtput + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp [Probe.MatchesInput] at hmatches + +set_option maxRecDepth 100000 in +theorem decodeProbe?_leaf_eq + (parameter : PublicParameter) (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (hprobe : decodeProbe? parameter input = some candidate) + (hposition : decodePosition? parameter input = some (.leaf lay tree leafIdx)) : + candidate = + ⟨.position (.chain lay tree leafIdx ⟨0, by norm_num [numChains]⟩ + Position.lastChainStep), slotDigest 0 input⟩ := by + apply Probe.matchesInput_unique parameter input + · exact (decodeProbe?_eq_some_iff parameter input candidate).1 hprobe + · simp only [Probe.MatchesInput] + rw [dif_neg (by simp [Position.lastChainStep, chainLength, winternitzBits])] + obtain ⟨payload, hinput⟩ := + (decodePosition?_eq_some_iff parameter input (.leaf lay tree leafIdx)).1 hposition + exact ⟨trivial, payload, hinput, trivial⟩ + +theorem exists_decodePosition?_of_decodeProbe? + (parameter : PublicParameter) (input : HashInput) (candidate : Probe) + (hprobe : decodeProbe? parameter input = some candidate) : + ∃ position : Position, + decodePosition? parameter input = some position ∧ + candidate.outputCoordinate = .position position := by + have hmatches := (decodeProbe?_eq_some_iff parameter input candidate).1 hprobe + rcases candidate with ⟨coordinate, candidateDigest⟩ + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + rcases hmatches with ⟨step, hstep, hinput⟩ + have hzero : step = ⟨0, by norm_num [chainLength, winternitzBits]⟩ := Fin.ext hstep + subst step + refine ⟨.chain lay tree leafIdx chainIdx + ⟨0, by norm_num [chainLength, winternitzBits]⟩, ?_, rfl⟩ + exact (decodePosition?_eq_some_iff parameter _ _).2 ⟨digestBytes candidateDigest, hinput⟩ + | position source => + cases source with + | chain lay tree leafIdx chainIdx step => + simp only [Probe.MatchesInput] at hmatches + by_cases hnext : step.val + 1 < chainLength - 1 + · rw [dif_pos hnext] at hmatches + rcases hmatches with ⟨nextStep, hnextStep, hinput⟩ + have hstepEq : nextStep = ⟨step.val + 1, hnext⟩ := Fin.ext hnextStep + subst nextStep + refine ⟨.chain lay tree leafIdx chainIdx ⟨step.val + 1, hnext⟩, ?_, ?_⟩ + · exact (decodePosition?_eq_some_iff parameter _ _).2 + ⟨digestBytes candidateDigest, hinput⟩ + · simp [Probe.outputCoordinate, hnext] + · rw [dif_neg hnext] at hmatches + rcases hmatches with ⟨_hchain, payload, hinput, _hslot⟩ + refine ⟨.leaf lay tree leafIdx, ?_, ?_⟩ + · exact (decodePosition?_eq_some_iff parameter _ _).2 ⟨payload, hinput⟩ + · simp [Probe.outputCoordinate, hnext] + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp [Probe.MatchesInput] at hmatches + +theorem decodePosition?_chain_or_leaf_of_decodeProbe? + (parameter : PublicParameter) (input : HashInput) (candidate : Probe) + (hprobe : decodeProbe? parameter input = some candidate) : + (∃ lay tree leafIdx chainIdx step, + decodePosition? parameter input = some (.chain lay tree leafIdx chainIdx step)) ∨ + ∃ lay tree leafIdx, + decodePosition? parameter input = some (.leaf lay tree leafIdx) := by + have hmatches := (decodeProbe?_eq_some_iff parameter input candidate).1 hprobe + rcases candidate with ⟨coordinate, candidateDigest⟩ + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + rcases hmatches with ⟨step, _hstep, hinput⟩ + exact Or.inl ⟨lay, tree, leafIdx, chainIdx, step, + (decodePosition?_eq_some_iff parameter _ _).2 ⟨digestBytes candidateDigest, hinput⟩⟩ + | position source => + cases source with + | chain lay tree leafIdx chainIdx step => + simp only [Probe.MatchesInput] at hmatches + by_cases hnext : step.val + 1 < chainLength - 1 + · rw [dif_pos hnext] at hmatches + rcases hmatches with ⟨nextStep, _hnextStep, hinput⟩ + exact Or.inl ⟨lay, tree, leafIdx, chainIdx, nextStep, + (decodePosition?_eq_some_iff parameter _ _).2 + ⟨digestBytes candidateDigest, hinput⟩⟩ + · rw [dif_neg hnext] at hmatches + rcases hmatches with ⟨_hchain, payload, hinput, _hslot⟩ + exact Or.inr ⟨lay, tree, leafIdx, + (decodePosition?_eq_some_iff parameter _ _).2 ⟨payload, hinput⟩⟩ + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp [Probe.MatchesInput] at hmatches + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_probingHashQuery_chain_reachable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (step : ChainStep) + (hprobe : decodeProbe? parameter input = some candidate) + (hposition : decodePosition? parameter input = + some (.chain lay tree leafIdx chainIdx step)) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) : + RelTriple + (runResolvedFromTable context fuel table + ((probingHashQuery parameter input).run cache)) + ((randomOracle input).run concreteCache) + (ReachableResolvedRunRel parameter table) := by + have hmatches := (decodeProbe?_eq_some_iff parameter input candidate).1 hprobe + have houtput := decodeProbe?_outputCoordinate_eq_position parameter input candidate + (.chain lay tree leafIdx chainIdx step) hprobe hposition + unfold probingHashQuery + rw [hprobe, hposition] + simp only + rw [houtput, StateT.run_bind, runResolvedFromTable_bind] + unfold probe + rw [StateT.run_liftM, LazyRevealProbe.probeQuery, + runResolvedFromTable_probe_query_bind] + cases fuel with + | zero => + have hbase := relTriple_true + (pure (none : Option (ResolvedRunResult (HashOutput × SplitHashCache))) : + ProbComp (Option (ResolvedRunResult (HashOutput × SplitHashCache)))) + ((randomOracle input).run concreteCache) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = none) (by + intro result hresult + simpa using hresult) + apply relTriple_post_mono hsupported + intro leftResult _ hrelation + rw [hrelation.2] + trivial + | succ remaining => + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + obtain ⟨completion, hcompletion⟩ := hinvariant.2.2.2.1 + have havailable := tableInputAvailable_chain_of_probe_revealed hcompletion hpublished + hmatches houtput hrevealed + exact relTriple_runResolvedFromTable_resolveKnownInput_availableDecoded_reachable + parameter table (.chain lay tree leafIdx chainIdx step) input context remaining cache + concreteCache hinvariant hclosed hpublished (by simp [IsOtsPosition]) + (by simp [ResolvableOtsPosition]) hposition completion hcompletion havailable + · simp only [hrevealed, ↓reduceIte] + let probeContext : DeferredContext := + { context with state := + context.state.addPending candidate.coordinate candidate.candidate } + by_cases hcompletable : DeferredCompletable table probeContext + · have hprobeInvariant := hinvariant.addPending_of_completable + candidate.coordinate candidate.candidate hcompletable + have hprobeClosed : VisibleResolvedComputationsCached parameter table probeContext + concreteCache := hclosed.of_state_values_eq rfl + have hprobePublished : PublishedValues probeContext.state := by + simpa [probeContext, PublishedValues, LazyRevealProbe.State.addPending] using hpublished + have hpending : (candidate.coordinate, candidate.candidate) ∈ + probeContext.state.pending := by + simp [probeContext, LazyRevealProbe.State.addPending] + have hordinary := completionOrdinaryInput_of_pending_decodedProbe (table := table) + hprobe hpending + exact relTriple_runResolvedFromTable_resolveKnownInput_completionOrdinary_reachable + parameter table (.position (.chain lay tree leafIdx chainIdx step)) input + probeContext remaining cache concreteCache hprobeInvariant hprobeClosed hprobePublished + (fun position heq => by cases heq; simp [IsOtsPosition]) hordinary + · have hdoomed : DoomedResolvedContext table probeContext := ⟨ + hinvariant.2.1.valuesConsistent.addPending candidate.coordinate candidate.candidate, + hinvariant.2.2.1.addPending candidate.coordinate candidate.candidate, + hcompletable⟩ + exact relTriple_runResolvedFromTable_of_doomed_reachable parameter table + (resolveKnownInput parameter (.position (.chain lay tree leafIdx chainIdx step)) input) + ((randomOracle input).run concreteCache) probeContext remaining cache hdoomed + +set_option maxHeartbeats 800000 in +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_probingHashQuery_leaf_reachable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (hprobe : decodeProbe? parameter input = some candidate) + (hposition : decodePosition? parameter input = some (.leaf lay tree leafIdx)) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) : + RelTriple + (runResolvedFromTable context fuel table + ((probingHashQuery parameter input).run cache)) + ((randomOracle input).run concreteCache) + (ReachableResolvedRunRel parameter table) := by + have hcandidate := decodeProbe?_leaf_eq parameter input candidate lay tree leafIdx hprobe hposition + let source : Coordinate := candidate.coordinate + have houtput := decodeProbe?_outputCoordinate_eq_position parameter input candidate + (.leaf lay tree leafIdx) hprobe hposition + unfold probingHashQuery + rw [hprobe, hposition] + simp only + rw [StateT.run_bind, runResolvedFromTable_bind] + unfold prepareLeafInputProbe + rw [StateT.run_bind, runResolvedFromTable_bind] + cases hsourceValue : context.state.values source with + | none => + rw [runResolvedFromTable_peekCoordinate_of_none context fuel table cache source hsourceValue] + simp only [pure_bind] + rw [houtput] + unfold probe + rw [StateT.run_liftM, LazyRevealProbe.probeQuery, + runResolvedFromTable_probe_query_bind] + cases fuel with + | zero => + have hbase := relTriple_true + (pure (none : Option (ResolvedRunResult (HashOutput × SplitHashCache))) : + ProbComp (Option (ResolvedRunResult (HashOutput × SplitHashCache)))) + ((randomOracle input).run concreteCache) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = none) (by + intro result hresult + simpa using hresult) + apply relTriple_post_mono hsupported + intro leftResult _ hrelation + rw [hrelation.2] + trivial + | succ remaining => + have hnotRevealed : source ∉ context.state.revealed := by + intro hrevealed + exact (hpublished source hrevealed) hsourceValue + rw [show remaining + 1 = Nat.succ remaining by omega] + simp only + rw [if_neg (by simpa [source] using hnotRevealed)] + simp only [runResolvedFromTable, pure_bind] + let probeContext : DeferredContext := + { context with state := (context.state.addPending candidate.coordinate + candidate.candidate) } + by_cases hcompletable : DeferredCompletable table probeContext + · have hprobeInvariant := hinvariant.addPending_of_completable candidate.coordinate + candidate.candidate hcompletable + have hprobeClosed : VisibleResolvedComputationsCached parameter table probeContext + concreteCache := hclosed.of_state_values_eq rfl + have hprobePublished : PublishedValues probeContext.state := by + simpa [probeContext, PublishedValues, LazyRevealProbe.State.addPending] using + hpublished + have hpending : (candidate.coordinate, candidate.candidate) ∈ + probeContext.state.pending := by + simp [probeContext, LazyRevealProbe.State.addPending] + have hordinary := completionOrdinaryInput_of_pending_decodedProbe (table := table) + hprobe hpending + exact relTriple_runResolvedFromTable_resolveKnownInput_completionOrdinary_reachable + parameter table (.position (.leaf lay tree leafIdx)) input probeContext remaining + cache concreteCache hprobeInvariant hprobeClosed hprobePublished + (fun position heq => by cases heq; simp [IsOtsPosition]) hordinary + · have hdoomed : DoomedResolvedContext table probeContext := ⟨ + hinvariant.2.1.valuesConsistent.addPending candidate.coordinate candidate.candidate, + hinvariant.2.2.1.addPending candidate.coordinate candidate.candidate, hcompletable⟩ + exact relTriple_runResolvedFromTable_of_doomed_reachable parameter table + (resolveKnownInput parameter (.position (.leaf lay tree leafIdx)) input) + ((randomOracle input).run concreteCache) probeContext remaining cache hdoomed + | some sourceOutput => + rw [runResolvedFromTable_peekCoordinate_of_value context fuel table cache source sourceOutput + hsourceValue] + simp only [pure_bind] + rw [houtput] + obtain ⟨completion, hcompletion⟩ := hinvariant.2.2.2.1 + rcases positionValues_or_first_missing completion context.state + (Position.leaf lay tree leafIdx).children + (fun other output hvalue => (hcompletion.1 (.position other) output hvalue).symm) with + havailable | ⟨prior, child, remaining, hchildren, hvalues, hmissing⟩ + · let coordinates := (Position.leaf lay tree leafIdx).children.map Coordinate.position + have hcoordinateValues : ∀ coordinate, coordinate ∈ coordinates → + context.state.values coordinate = some (completion coordinate) := by + intro coordinate hcoordinate + obtain ⟨position, hpositionMem, rfl⟩ := List.mem_map.1 hcoordinate + exact havailable position hpositionMem + rw [runResolvedFromTable_probeFirstMissingInputCoordinate_of_values completion input + context cache fuel table 0 coordinates hcoordinateValues] + simp only [pure_bind] + exact relTriple_runResolvedFromTable_resolveKnownInput_availableDecoded_reachable + parameter table (.leaf lay tree leafIdx) input context fuel cache concreteCache hinvariant + hclosed hpublished (by simp [IsOtsPosition]) (by simp [ResolvableOtsPosition]) + hposition completion hcompletion havailable + · let priorCoordinates := prior.map Coordinate.position + let remainingCoordinates := remaining.map Coordinate.position + have hcoordinates : (Position.leaf lay tree leafIdx).children.map Coordinate.position = + priorCoordinates ++ .position child :: remainingCoordinates := by + simp [hchildren, priorCoordinates, remainingCoordinates] + have hcoordinateValues : ∀ coordinate, coordinate ∈ priorCoordinates → + context.state.values coordinate = some (completion coordinate) := by + intro coordinate hcoordinate + obtain ⟨position, hpositionMem, rfl⟩ := List.mem_map.1 hcoordinate + exact hvalues position hpositionMem + have hnotRevealed : .position child ∉ context.state.revealed := by + intro hrevealed + exact (hpublished (.position child) hrevealed) hmissing + rw [hcoordinates] + cases fuel with + | zero => + rw [runResolvedFromTable_probeFirstMissingInputCoordinate_zero_of_prefix_values_of_missing + completion input context cache 0 priorCoordinates remainingCoordinates + (.position child) table hcoordinateValues hmissing] + have hbase := relTriple_true + (pure (none : Option (ResolvedRunResult (HashOutput × SplitHashCache))) : + ProbComp (Option (ResolvedRunResult (HashOutput × SplitHashCache)))) + ((randomOracle input).run concreteCache) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = none) (by + intro result hresult + simpa using hresult) + apply relTriple_post_mono hsupported + intro leftResult _ hrelation + rw [hrelation.2] + trivial + | succ remainingFuel => + rw [runResolvedFromTable_probeFirstMissingInputCoordinate_of_prefix_values_of_missing + completion input context cache remainingFuel 0 priorCoordinates + remainingCoordinates (.position child) table hcoordinateValues hmissing + hnotRevealed] + simp only [pure_bind] + let probeContext : DeferredContext := + { context with state := (context.state.addPending (.position child) + (slotDigest prior.length input)) } + have hlength : priorCoordinates.length = prior.length := by simp [priorCoordinates] + simp only [Nat.zero_add, hlength] + by_cases hcompletable : DeferredCompletable table probeContext + · have hprobeInvariant := hinvariant.addPending_of_completable (.position child) + (slotDigest prior.length input) hcompletable + have hprobeClosed : VisibleResolvedComputationsCached parameter table probeContext + concreteCache := hclosed.of_state_values_eq rfl + have hprobePublished : PublishedValues probeContext.state := by + simpa [probeContext, PublishedValues, LazyRevealProbe.State.addPending] using + hpublished + have hpending : (.position child, slotDigest prior.length input) ∈ + probeContext.state.pending := by + simp [probeContext, LazyRevealProbe.State.addPending] + have hordinary := completionOrdinaryInput_of_pending_leaf_child (table := table) + hposition hchildren hpending + exact relTriple_runResolvedFromTable_resolveKnownInput_completionOrdinary_reachable + parameter table (.position (.leaf lay tree leafIdx)) input probeContext + remainingFuel cache concreteCache hprobeInvariant hprobeClosed hprobePublished + (fun position heq => by cases heq; simp [IsOtsPosition]) hordinary + · have hdoomed : DoomedResolvedContext table probeContext := ⟨ + hinvariant.2.1.valuesConsistent.addPending (.position child) + (slotDigest prior.length input), + hinvariant.2.2.1.addPending (.position child) (slotDigest prior.length input), + hcompletable⟩ + exact relTriple_runResolvedFromTable_of_doomed_reachable parameter table + (resolveKnownInput parameter (.position (.leaf lay tree leafIdx)) input) + ((randomOracle input).run concreteCache) probeContext remainingFuel cache hdoomed + +set_option maxHeartbeats 800000 in +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_probingHashQuery_node_reachable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (lay : Layer) (tree : TreeIndex) + (level : Fin maxLayerHeight) (nodeIdx : LeafIndex) + (hprobe : decodeProbe? parameter input = none) + (hposition : decodePosition? parameter input = some (.node lay tree level nodeIdx)) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) : + RelTriple + (runResolvedFromTable context fuel table + ((probingHashQuery parameter input).run cache)) + ((randomOracle input).run concreteCache) + (ReachableResolvedRunRel parameter table) := by + unfold probingHashQuery + rw [hprobe, hposition] + simp only + rw [StateT.run_bind, runResolvedFromTable_bind] + obtain ⟨completion, hcompletion⟩ := hinvariant.2.2.2.1 + rcases positionValues_or_first_missing completion context.state + (Position.node lay tree level nodeIdx).children + (fun other output hvalue => (hcompletion.1 (.position other) output hvalue).symm) with + havailable | ⟨prior, child, remaining, hchildren, hvalues, hmissing⟩ + · let coordinates := (Position.node lay tree level nodeIdx).children.map Coordinate.position + have hcoordinateValues : ∀ coordinate, coordinate ∈ coordinates → + context.state.values coordinate = some (completion coordinate) := by + intro coordinate hcoordinate + obtain ⟨position, hpositionMem, rfl⟩ := List.mem_map.1 hcoordinate + exact havailable position hpositionMem + rw [runResolvedFromTable_probeFirstMissingInputCoordinate_of_values completion input + context cache fuel table 0 coordinates hcoordinateValues] + simp only [pure_bind] + exact relTriple_runResolvedFromTable_resolveKnownInput_availableDecodedAny_reachable + parameter table (.node lay tree level nodeIdx) input context fuel cache concreteCache + hinvariant hclosed hpublished (by simp [IsOtsPosition]) hposition completion hcompletion + havailable + · let priorCoordinates := prior.map Coordinate.position + let remainingCoordinates := remaining.map Coordinate.position + have hcoordinates : (Position.node lay tree level nodeIdx).children.map Coordinate.position = + priorCoordinates ++ .position child :: remainingCoordinates := by + simp [hchildren, priorCoordinates, remainingCoordinates] + have hcoordinateValues : ∀ coordinate, coordinate ∈ priorCoordinates → + context.state.values coordinate = some (completion coordinate) := by + intro coordinate hcoordinate + obtain ⟨position, hpositionMem, rfl⟩ := List.mem_map.1 hcoordinate + exact hvalues position hpositionMem + have hnotRevealed : .position child ∉ context.state.revealed := by + intro hrevealed + exact (hpublished (.position child) hrevealed) hmissing + rw [hcoordinates] + cases fuel with + | zero => + rw [runResolvedFromTable_probeFirstMissingInputCoordinate_zero_of_prefix_values_of_missing + completion input context cache 0 priorCoordinates remainingCoordinates + (.position child) table hcoordinateValues hmissing] + have hbase := relTriple_true + (pure (none : Option (ResolvedRunResult (HashOutput × SplitHashCache))) : + ProbComp (Option (ResolvedRunResult (HashOutput × SplitHashCache)))) + ((randomOracle input).run concreteCache) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = none) (by + intro result hresult + simpa using hresult) + apply relTriple_post_mono hsupported + intro leftResult _ hrelation + rw [hrelation.2] + trivial + | succ remainingFuel => + rw [runResolvedFromTable_probeFirstMissingInputCoordinate_of_prefix_values_of_missing + completion input context cache remainingFuel 0 priorCoordinates + remainingCoordinates (.position child) table hcoordinateValues hmissing + hnotRevealed] + simp only [pure_bind] + let probeContext : DeferredContext := + { context with state := (context.state.addPending (.position child) + (slotDigest prior.length input)) } + have hlength : priorCoordinates.length = prior.length := by simp [priorCoordinates] + simp only [Nat.zero_add, hlength] + by_cases hcompletable : DeferredCompletable table probeContext + · have hprobeInvariant := hinvariant.addPending_of_completable (.position child) + (slotDigest prior.length input) hcompletable + have hprobeClosed : VisibleResolvedComputationsCached parameter table probeContext + concreteCache := hclosed.of_state_values_eq rfl + have hprobePublished : PublishedValues probeContext.state := by + simpa [probeContext, PublishedValues, LazyRevealProbe.State.addPending] using + hpublished + have hpending : (.position child, slotDigest prior.length input) ∈ + probeContext.state.pending := by + simp [probeContext, LazyRevealProbe.State.addPending] + have hordinary := completionOrdinaryInput_of_pending_node_child (table := table) + hposition hchildren hpending + exact relTriple_runResolvedFromTable_resolveKnownInput_completionOrdinary_reachable + parameter table (.position (.node lay tree level nodeIdx)) input probeContext + remainingFuel cache concreteCache hprobeInvariant hprobeClosed hprobePublished + (fun position heq => by cases heq; simp [IsOtsPosition]) hordinary + · have hdoomed : DoomedResolvedContext table probeContext := ⟨ + hinvariant.2.1.valuesConsistent.addPending (.position child) + (slotDigest prior.length input), + hinvariant.2.2.1.addPending (.position child) (slotDigest prior.length input), + hcompletable⟩ + exact relTriple_runResolvedFromTable_of_doomed_reachable parameter table + (resolveKnownInput parameter (.position (.node lay tree level nodeIdx)) input) + ((randomOracle input).run concreteCache) probeContext remainingFuel cache hdoomed + +set_option maxRecDepth 100000 in +theorem reachableResolvedCouples_probingHashQuery + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) : + ReachableResolvedCouples parameter table (probingHashQuery parameter input) + (randomOracle input) := by + intro context fuel cache concreteCache hinvariant hclosed hpublished + cases hprobe : decodeProbe? parameter input with + | some candidate => + rcases decodePosition?_chain_or_leaf_of_decodeProbe? parameter input candidate hprobe with + ⟨lay, tree, leafIdx, chainIdx, step, hposition⟩ | + ⟨lay, tree, leafIdx, hposition⟩ + · exact relTriple_runResolvedFromTable_probingHashQuery_chain_reachable parameter table + input candidate lay tree leafIdx chainIdx step hprobe hposition context fuel cache + concreteCache hinvariant hclosed hpublished + · exact relTriple_runResolvedFromTable_probingHashQuery_leaf_reachable parameter table + input candidate lay tree leafIdx hprobe hposition context fuel cache concreteCache + hinvariant hclosed hpublished + | none => + cases hposition : decodePosition? parameter input with + | none => + have hstable : StableOrdinaryInput parameter input := ⟨hprobe, by + intro position hdecode _hots + rw [hposition] at hdecode + simp at hdecode⟩ + exact reachableResolvedCouples_probingHashQuery_of_stable parameter table input hstable + context fuel cache concreteCache hinvariant hclosed hpublished + | some position => + cases position with + | chain lay tree leafIdx chainIdx step => + have hordinary := completionOrdinaryInput_of_decodeProbe_none_chain + (table := table) (context := context) hprobe hposition + unfold probingHashQuery + rw [hprobe, hposition] + exact relTriple_runResolvedFromTable_resolveKnownInput_completionOrdinary_reachable + parameter table (.position (.chain lay tree leafIdx chainIdx step)) input + context fuel cache concreteCache hinvariant hclosed hpublished + (fun other heq => by cases heq; simp [IsOtsPosition]) hordinary + | leaf lay tree leafIdx => + have hordinary := completionOrdinaryInput_of_decodeProbe_none_leaf + (table := table) (context := context) hprobe hposition + unfold probingHashQuery + rw [hprobe, hposition] + exact relTriple_runResolvedFromTable_resolveKnownInput_completionOrdinary_reachable + parameter table (.position (.leaf lay tree leafIdx)) input context fuel cache + concreteCache hinvariant hclosed hpublished + (fun other heq => by cases heq; simp [IsOtsPosition]) hordinary + | node lay tree level nodeIdx => + exact relTriple_runResolvedFromTable_probingHashQuery_node_reachable parameter table + input lay tree level nodeIdx hprobe hposition context fuel cache concreteCache + hinvariant hclosed hpublished + | ftsLeaf index tree leafIdx => + have hstable : StableOrdinaryInput parameter input := ⟨hprobe, by + intro other hdecode hots + rw [hposition] at hdecode + have heq : other = .ftsLeaf index tree leafIdx := Option.some.inj hdecode.symm + subst other + simpa [IsOtsPosition] using hots⟩ + exact reachableResolvedCouples_probingHashQuery_of_stable parameter table input + hstable context fuel cache concreteCache hinvariant hclosed hpublished + | ftsNode index tree level nodeIdx => + have hstable : StableOrdinaryInput parameter input := ⟨hprobe, by + intro other hdecode hots + rw [hposition] at hdecode + have heq : other = .ftsNode index tree level nodeIdx := + Option.some.inj hdecode.symm + subst other + simpa [IsOtsPosition] using hots⟩ + exact reachableResolvedCouples_probingHashQuery_of_stable parameter table input + hstable context fuel cache concreteCache hinvariant hclosed hpublished + | ftsRoots index => + have hstable : StableOrdinaryInput parameter input := ⟨hprobe, by + intro other hdecode hots + rw [hposition] at hdecode + have heq : other = .ftsRoots index := Option.some.inj hdecode.symm + subst other + simpa [IsOtsPosition] using hots⟩ + exact reachableResolvedCouples_probingHashQuery_of_stable parameter table input + hstable context fuel cache concreteCache hinvariant hclosed hpublished + +theorem resolvedCouples_revealChainStart + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : OtsSecretIndex) : + ResolvedCouples parameter table + (revealChainStart index.lay index.tree index.leafIdx index.chainIdx) + (pure (truncateHash (table index)) : StateT (QueryCache HashSpec) ProbComp Digest) := by + intro context fuel cache concreteCache hinvariant + apply relTriple_post_mono + (relTriple_runResolvedFromTable_revealChainStart_chronological parameter table index context + fuel cache concreteCache hinvariant) + intro leftResult rightResult hrelation + exact hrelation.to_resolvedRunRel + +theorem resolvedCouples_revealResolvablePosition + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (position : Position) (hresolvable : ResolvableOtsPosition position) : + ResolvedCouples parameter table (revealPosition position) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (resolvedPositionComputation parameter table position)) := by + intro context fuel cache concreteCache hinvariant + apply relTriple_post_mono + (relTriple_runResolvedFromTable_revealResolvablePosition_chronological parameter table + position context fuel cache concreteCache hinvariant hresolvable) + intro leftResult rightResult hrelation + exact hrelation.to_resolvedRunRel + +theorem resolvedCouples_revealPublishedChainValue + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) : + ResolvedCouples parameter table + (revealPublishedCoordinate + (chainValueCoordinate lay tree leafIdx chainIdx digit)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (chainWalk parameter lay tree leafIdx chainIdx 0 digit.val + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)))) := by + unfold revealPublishedCoordinate chainValueCoordinate + split + · have hbase := (resolvedCouples_revealChainStart parameter table + ⟨lay, tree, leafIdx, chainIdx⟩).bind fun value => + (resolvedCouples_of_administrative + (resolvedAdministrative_publishCoordinate + (.chainStart lay tree leafIdx chainIdx))).bind fun _ => + resolvedCouples_pure parameter table value + simpa [revealChainStart, chainWalk, ‹digit.val = 0›] using hbase + · let step : ChainStep := ⟨digit.val - 1, by + have := digit.isLt + omega⟩ + have hwalk : resolvedPositionComputation parameter table + (.chain lay tree leafIdx chainIdx step) = + chainWalk parameter lay tree leafIdx chainIdx 0 digit.val + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) := by + simp [resolvedPositionComputation, step] + have hpos : 0 < digit.val := Nat.pos_of_ne_zero ‹digit.val ≠ 0› + congr 1 + omega + rw [← hwalk] + have hbase := (resolvedCouples_revealResolvablePosition parameter table + (.chain lay tree leafIdx chainIdx step) (by simp [ResolvableOtsPosition])).bind fun value => + (resolvedCouples_of_administrative + (resolvedAdministrative_publishCoordinate + (.position (.chain lay tree leafIdx chainIdx step)))).bind fun _ => + resolvedCouples_pure parameter table value + simpa [revealPosition, step] using hbase + +theorem resolvedCouples_revealPublishedTreeNode + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) + (hlevel : level ≤ maxLayerHeight) + (hspan : 2 ^ level * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) : + ResolvedCouples parameter table + (match level with + | 0 => revealPublishedCoordinate (.position (.leaf lay tree (leafOfNat nodeIdx))) + | current + 1 => + if hcurrent : current < maxLayerHeight then + revealPublishedCoordinate (.position + (.node lay tree ⟨current, hcurrent⟩ (leafOfNat nodeIdx))) + else pure 0) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay tree + (fun leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + level nodeIdx)) := by + cases level with + | zero => + have hbase := (resolvedCouples_revealResolvablePosition parameter table + (.leaf lay tree (leafOfNat nodeIdx)) (by simp [ResolvableOtsPosition])).bind fun value => + (resolvedCouples_of_administrative + (resolvedAdministrative_publishCoordinate + (.position (.leaf lay tree (leafOfNat nodeIdx))))).bind fun _ => + resolvedCouples_pure parameter table value + simpa [revealPublishedCoordinate, revealPosition, resolvedPositionComputation, + treeNode_zero_eq] using hbase + | succ current => + have hcurrent : current < maxLayerHeight := by omega + simp only [hcurrent, ↓reduceDIte] + have hnodeLt : nodeIdx < 2 ^ maxLayerHeight := by + have hpow : 0 < 2 ^ (current + 1) := pow_pos (by omega) _ + nlinarith + have hnodeVal : (leafOfNat nodeIdx).val = nodeIdx := by + simp [leafOfNat, Nat.mod_eq_of_lt hnodeLt] + have hresolvable : ResolvableOtsPosition + (.node lay tree ⟨current, hcurrent⟩ (leafOfNat nodeIdx)) := by + simp [ResolvableOtsPosition, hnodeVal] + exact hspan + have hbase := (resolvedCouples_revealResolvablePosition parameter table + (.node lay tree ⟨current, hcurrent⟩ (leafOfNat nodeIdx)) hresolvable).bind fun value => + (resolvedCouples_of_administrative + (resolvedAdministrative_publishCoordinate + (.position (.node lay tree ⟨current, hcurrent⟩ + (leafOfNat nodeIdx))))).bind fun _ => + resolvedCouples_pure parameter table value + simpa [revealPublishedCoordinate, revealPosition, resolvedPositionComputation, + hnodeVal] using hbase + +theorem resolvedCouples_revealLayerPathNode + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (lay : Layer) (level : Fin maxLayerHeight) : + ResolvedCouples parameter table + (if level.val < layerHeight lay then + match level.val with + | 0 => revealPublishedCoordinate (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | current + 1 => + if hcurrent : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hcurrent⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0 + else pure 0) + (if level.val < layerHeight lay then + simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay (treeIndexAt index lay) + (fun sibling chainIdx => + truncateHash (table ⟨lay, treeIndexAt index lay, sibling, chainIdx⟩)) + level.val + (Nat.xor ((leafIndexAt index lay).val / 2 ^ level.val) 1)) + else pure 0) := by + by_cases hinLayer : level.val < layerHeight lay + · rw [if_pos hinLayer, if_pos hinLayer] + cases hvalue : level.val with + | zero => + simpa [hvalue] using + resolvedCouples_revealPublishedTreeNode parameter table lay + (treeIndexAt index lay) 0 + (Nat.xor (leafIndexAt index lay).val 1) (by omega) + (by + simpa using (FtsProbeSimulation.sibling_node_bound maxLayerHeight + (leafIndexAt index lay).val 0 (by omega) (leafIndexAt index lay).isLt)) + | succ current => + have hcurrent : current < maxLayerHeight := by + have := level.isLt + omega + simpa [hvalue, hcurrent] using + resolvedCouples_revealPublishedTreeNode parameter table lay + (treeIndexAt index lay) (current + 1) + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1) + (by omega) + (FtsProbeSimulation.sibling_node_bound maxLayerHeight + (leafIndexAt index lay).val (current + 1) (by omega) + (leafIndexAt index lay).isLt) + · rw [if_neg hinLayer, if_neg hinLayer] + exact resolvedCouples_pure parameter table 0 + +set_option maxHeartbeats 400000 in +theorem resolvedCouples_revealLayerValues + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + ResolvedCouples parameter table (revealLayerValues index lay encoding) + (do + let tree := treeIndexAt index lay + let leafIdx := leafIndexAt index lay + let values ← sequenceFin fun chainIdx => + simulateQ (randomOracle : QueryImpl HashSpec _) + (chainWalk parameter lay tree leafIdx chainIdx 0 (encoding chainIdx).val + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩))) + let path ← sequenceFin fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay tree + (fun sibling chainIdx => + truncateHash (table ⟨lay, tree, sibling, chainIdx⟩)) + level.val (Nat.xor (leafIdx.val / 2 ^ level.val) 1)) + else + pure 0 + pure (values, path)) := by + unfold revealLayerValues + apply (resolvedCouples_sequenceFin _ _ fun chainIdx => + resolvedCouples_revealPublishedChainValue parameter table lay (treeIndexAt index lay) + (leafIndexAt index lay) chainIdx (encoding chainIdx)).bind + intro values + apply (resolvedCouples_sequenceFin _ _ fun level => + resolvedCouples_revealLayerPathNode parameter table index lay level).bind + intro path + exact resolvedCouples_pure parameter table (values, path) + +noncomputable def resolvedLayerValuesComputation + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + OracleComp HashSpec ((ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) := do + let chainValues ← sequenceFin fun chainIdx => + chainWalk parameter lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx 0 + (encoding chainIdx).val + (truncateHash (table ⟨lay, treeIndexAt index lay, leafIndexAt index lay, chainIdx⟩)) + let pathValues ← sequenceFin fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + treeNode parameter lay (treeIndexAt index lay) + (fun sibling chainIdx => + truncateHash (table ⟨lay, treeIndexAt index lay, sibling, chainIdx⟩)) + level.val (Nat.xor ((leafIndexAt index lay).val / 2 ^ level.val) 1) + else pure 0 + pure (chainValues, pathValues) + +noncomputable def resolvedRevealLayerValues + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + StateT (QueryCache HashSpec) ProbComp + ((ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) := do + let tree := treeIndexAt index lay + let leafIdx := leafIndexAt index lay + let values ← sequenceFin fun chainIdx => + simulateQ (randomOracle : QueryImpl HashSpec _) + (chainWalk parameter lay tree leafIdx chainIdx 0 (encoding chainIdx).val + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩))) + let path ← sequenceFin fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay tree + (fun sibling chainIdx => + truncateHash (table ⟨lay, tree, sibling, chainIdx⟩)) + level.val (Nat.xor (leafIdx.val / 2 ^ level.val) 1)) + else + pure 0 + pure (values, path) + +theorem resolvedRevealLayerValues_eq_simulateQ + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + resolvedRevealLayerValues parameter table index lay encoding = + simulateQ (randomOracle : QueryImpl HashSpec _) + (resolvedLayerValuesComputation parameter table index lay encoding) := by + unfold resolvedRevealLayerValues resolvedLayerValuesComputation + rw [simulateQ_bind, FtsProbeSimulation.simulateQ_randomOracle_sequenceFin] + apply bind_congr + intro chainValues + rw [simulateQ_bind, FtsProbeSimulation.simulateQ_randomOracle_sequenceFin] + have hpathComponent : + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay (treeIndexAt index lay) + (fun sibling chainIdx => + truncateHash (table ⟨lay, treeIndexAt index lay, sibling, chainIdx⟩)) + level.val (Nat.xor ((leafIndexAt index lay).val / 2 ^ level.val) 1)) + else pure 0) = + (fun level : Fin maxLayerHeight => + simulateQ (randomOracle : QueryImpl HashSpec _) + (if level.val < layerHeight lay then + treeNode parameter lay (treeIndexAt index lay) + (fun sibling chainIdx => + truncateHash (table ⟨lay, treeIndexAt index lay, sibling, chainIdx⟩)) + level.val (Nat.xor ((leafIndexAt index lay).val / 2 ^ level.val) 1) + else pure 0)) := by + funext level + split <;> rfl + rw [hpathComponent] + apply bind_congr + intro pathValues + rw [simulateQ_pure] + +theorem resolvedRevealLayerValues_cache_mono + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) + (cache finalCache : QueryCache HashSpec) + (values : (ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) + (hresult : (values, finalCache) ∈ support + ((resolvedRevealLayerValues parameter table index lay encoding).run cache)) : + cache ≤ finalCache := by + rw [resolvedRevealLayerValues_eq_simulateQ] at hresult + exact (replay_of_mem_support (resolvedLayerValuesComputation parameter table index lay encoding) + cache values finalCache hresult + (fromCache finalCache) (agreesWithFn_fromCache finalCache)).1 + +theorem resolvedRevealLayerValues_replay_of_mem_support + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) + (cache finalCache : QueryCache HashSpec) + (values : (ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) + (hresult : (values, finalCache) ∈ support + ((resolvedRevealLayerValues parameter table index lay encoding).run cache)) : + (resolvedRevealLayerValues parameter table index lay encoding).run finalCache = + pure (values, finalCache) := by + rw [resolvedRevealLayerValues_eq_simulateQ] at hresult ⊢ + obtain ⟨_, heval, hcached⟩ := replay_of_mem_support + (resolvedLayerValuesComputation parameter table index lay encoding) + cache values finalCache hresult (fromCache finalCache) (agreesWithFn_fromCache finalCache) + rw [simulateQ_randomOracle_run_eq_pure_of_cachedRun + (agreesWithFn_fromCache finalCache) hcached, heval] + +theorem resolvedRevealLayerValues_replay_of_mem_support_of_le + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) + (cache observedCache finalCache : QueryCache HashSpec) + (values : (ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) + (hresult : (values, observedCache) ∈ support + ((resolvedRevealLayerValues parameter table index lay encoding).run cache)) + (hle : observedCache ≤ finalCache) : + (resolvedRevealLayerValues parameter table index lay encoding).run finalCache = + pure (values, finalCache) := by + rw [resolvedRevealLayerValues_eq_simulateQ] at hresult ⊢ + have hreplayed := replay_of_mem_support_of_le + (resolvedLayerValuesComputation parameter table index lay encoding) + cache values observedCache finalCache hresult hle (fromCache finalCache) + (agreesWithFn_fromCache finalCache) + rw [simulateQ_randomOracle_run_eq_pure_of_cachedRun + (agreesWithFn_fromCache finalCache) hreplayed.2, hreplayed.1] + +set_option maxRecDepth 100000 in +theorem relTriple_resolveDeferredLayerValues_chronological + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) + (context : DeferredContext) (ordinaryCache cache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context ordinaryCache cache) : + RelTriple + (resolveDeferredLayerValues table index lay encoding context) + ((resolvedRevealLayerValues parameter table index lay encoding).run cache) + (ResolveLayerValuesRel parameter table ordinaryCache) := by + unfold resolveDeferredLayerValues resolvedRevealLayerValues + dsimp only + rw [← FtsProbeSimulation.simulateQ_randomOracle_sequenceFin] + have hpathComponent : + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay (treeIndexAt index lay) + (fun sibling chainIdx => truncateHash + (table ⟨lay, treeIndexAt index lay, sibling, chainIdx⟩)) + level.val + (Nat.xor ((leafIndexAt index lay).val / 2 ^ level.val) 1)) + else pure 0) = + (fun level : Fin maxLayerHeight => + simulateQ (randomOracle : QueryImpl HashSpec _) + (if level.val < layerHeight lay then + treeNode parameter lay (treeIndexAt index lay) + (fun sibling chainIdx => truncateHash + (table ⟨lay, treeIndexAt index lay, sibling, chainIdx⟩)) + level.val + (Nat.xor ((leafIndexAt index lay).val / 2 ^ level.val) 1) + else pure 0)) := by + funext level + split <;> rfl + rw [hpathComponent, ← FtsProbeSimulation.simulateQ_randomOracle_sequenceFin] + simp only [StateT.run_bind, StateT.run_pure] + have hchains := relTriple_resolveDeferredSelectedChainFamily_chronological + parameter table lay (treeIndexAt index lay) (leafIndexAt index lay) + (fun chainIdx : ChainIndex => chainIdx) encoding context ordinaryCache cache hinvariant + apply relTriple_bind hchains + intro chainsOption chainsResult hchainsRelation + cases chainsOption with + | none => + rcases chainsResult with ⟨values, chainsCache⟩ + simp only + let right : ProbComp + (((ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) × + QueryCache HashSpec) := do + let path ← (simulateQ (randomOracle : QueryImpl HashSpec _) + (sequenceFin fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + treeNode parameter lay (treeIndexAt index lay) + (fun sibling chainIdx => truncateHash + (table ⟨lay, treeIndexAt index lay, sibling, chainIdx⟩)) + level.val + (Nat.xor ((leafIndexAt index lay).val / 2 ^ level.val) 1) + else pure 0)).run chainsCache + pure ((values, path.1), path.2) + have hbase := relTriple_true + (pure (none : Option (DeferredContext × + ((ChainIndex → Digest) × (Fin maxLayerHeight → Digest)))) : + ProbComp (Option (DeferredContext × + ((ChainIndex → Digest) × (Fin maxLayerHeight → Digest))))) right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = none) (by + intro result hresult + simpa using hresult) + have hfinal := relTriple_post_mono + (R' := ResolveLayerValuesRel parameter table ordinaryCache) hsupported (by + intro leftResult _ hrelation + rw [hrelation.2] + trivial) + simpa [right, simulateQ_bind, StateT.run_bind, simulateQ_pure, + StateT.run_pure] using hfinal + | some chains => + rcases chains with ⟨afterChains, values⟩ + rcases chainsResult with ⟨concreteValues, chainsCache⟩ + rcases hchainsRelation with ⟨hvalues, hchainsInvariant⟩ + have hpath := relTriple_resolveDeferredLayerPathFamily_chronological + parameter table lay (treeIndexAt index lay) (leafIndexAt index lay) + (fun level : Fin maxLayerHeight => level) afterChains ordinaryCache chainsCache + hchainsInvariant + have hbound : RelTriple + (resolveDeferredLayerPathFamily table lay (treeIndexAt index lay) + (leafIndexAt index lay) (fun level : Fin maxLayerHeight => level) + afterChains >>= fun pathOption => + match pathOption with + | none => pure none + | some (finalContext, pathValues) => + pure (some (finalContext, (values, pathValues)))) + (((simulateQ (randomOracle : QueryImpl HashSpec _) + (sequenceFin fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + treeNode parameter lay (treeIndexAt index lay) + (fun sibling chainIdx => truncateHash + (table ⟨lay, treeIndexAt index lay, sibling, chainIdx⟩)) + level.val + (Nat.xor ((leafIndexAt index lay).val / 2 ^ level.val) 1) + else pure 0)).run chainsCache) >>= fun path => + pure ((concreteValues, path.1), path.2)) + (ResolveLayerValuesRel parameter table ordinaryCache) := by + apply relTriple_bind hpath + intro pathOption pathResult hpathRelation + cases pathOption with + | none => + apply relTriple_pure_pure + trivial + | some path => + rcases path with ⟨finalContext, pathValues⟩ + rcases pathResult with ⟨concretePathValues, finalCache⟩ + rcases hpathRelation with ⟨hpathValues, hfinalInvariant⟩ + apply relTriple_pure_pure + exact ⟨by rw [hvalues, hpathValues], hfinalInvariant⟩ + simpa [simulateQ_bind, StateT.run_bind, simulateQ_pure, + StateT.run_pure] using hbound + + +theorem resolvedCouples_resolvedRevealLayerValues + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + ResolvedCouples parameter table (revealLayerValues index lay encoding) + (resolvedRevealLayerValues parameter table index lay encoding) := by + unfold resolvedRevealLayerValues + exact resolvedCouples_revealLayerValues parameter table index lay encoding + +theorem resolvedCouples_oracleHash + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (hstable : StableOrdinaryInput parameter input) : + ResolvedCouples parameter table + (simulateQ ordinaryHashImpl (oracleHash input)) + (simulateQ (randomOracle : QueryImpl HashSpec _) (oracleHash input)) := by + simpa only [oracleHash, HasQuery.instOfMonadLift_query, simulateQ_spec_query, + ordinaryHashImpl] using + resolvedCouples_splitHashQuery parameter table input hstable + +theorem resolvedCouples_tweakableHash + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (domain : HashDomain) (payload : HashInput) + (hstable : StableOrdinaryInput parameter + (tweakableHashInput parameter domain payload)) : + ResolvedCouples parameter table + (simulateQ ordinaryHashImpl (tweakableHash parameter domain payload)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (tweakableHash parameter domain payload)) := by + unfold tweakableHash + rw [simulateQ_bind, simulateQ_bind] + exact (resolvedCouples_oracleHash parameter table + (tweakableHashInput parameter domain payload) hstable).bind fun output => + resolvedCouples_pure parameter table (truncateHash output) + +theorem resolvedCouples_ftsLeafHash + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (tree : FtsTree) (leafIdx : FtsLeaf) (secret : Digest) : + ResolvedCouples parameter table + (simulateQ ordinaryHashImpl (ftsLeafHash parameter index tree leafIdx secret)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsLeafHash parameter index tree leafIdx secret)) := by + unfold ftsLeafHash + exact resolvedCouples_tweakableHash parameter table (.ftsLeaf index tree leafIdx) _ + (stableOrdinaryInput_tweakableHashInput parameter (.ftsLeaf index tree leafIdx) _ + (by trivial) (by simp) (by simp) (by simp)) + +theorem simulateQ_ordinaryHashImpl_sequenceFin {n : Nat} + (computation : Fin n → OracleComp HashSpec alpha) : + simulateQ ordinaryHashImpl (sequenceFin computation) = + sequenceFin fun position => simulateQ ordinaryHashImpl (computation position) := by + induction n with + | zero => simp [sequenceFin] + | succ n ih => + simp only [sequenceFin, simulateQ_bind, simulateQ_pure, ih] + +theorem resolvedCouples_ftsNode + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (tree : FtsTree) (secret : FtsLeaf → Digest) : + ∀ level nodeIdx, level ≤ ftsTreeHeight → + 2 ^ level * (nodeIdx + 1) ≤ 2 ^ ftsTreeHeight → + ResolvedCouples parameter table + (simulateQ ordinaryHashImpl + (ftsNode parameter index tree secret level nodeIdx)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsNode parameter index tree secret level nodeIdx)) + | 0, nodeIdx, hlevel, hspan => by + rw [ftsNode_zero_eq] + exact resolvedCouples_ftsLeafHash parameter table index tree _ _ + | level + 1, nodeIdx, hlevel, hspan => by + rw [ftsNode_succ_eq] + simp only [simulateQ_bind] + have hleftSpan : 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ ftsTreeHeight := by + rw [pow_succ] at hspan + calc + 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ level * (2 * (nodeIdx + 1)) := + Nat.mul_le_mul_left _ (by omega) + _ = 2 ^ level * 2 * (nodeIdx + 1) := by ring + _ ≤ 2 ^ ftsTreeHeight := hspan + have hrightSpan : 2 ^ level * (2 * nodeIdx + 1 + 1) ≤ 2 ^ ftsTreeHeight := by + rw [pow_succ] at hspan + calc + 2 ^ level * (2 * nodeIdx + 1 + 1) = 2 ^ level * 2 * (nodeIdx + 1) := by + ring + _ ≤ 2 ^ ftsTreeHeight := hspan + have hinRange : (HashDomain.ftsNode index tree (level + 1) nodeIdx).InRange := by + show level + 1 < 2 ^ 32 ∧ nodeIdx < 2 ^ 32 + constructor + · have : ftsTreeHeight < 2 ^ 32 := by norm_num [ftsTreeHeight] + omega + · have hnode : nodeIdx < 2 ^ ftsTreeHeight := by + have hpow : 0 < 2 ^ (level + 1) := Nat.two_pow_pos _ + nlinarith + have : 2 ^ ftsTreeHeight ≤ 2 ^ 32 := Nat.pow_le_pow_right (by omega) (by + norm_num [ftsTreeHeight]) + omega + exact (resolvedCouples_ftsNode parameter table index tree secret level (2 * nodeIdx) + (by omega) hleftSpan).bind fun left => + (resolvedCouples_ftsNode parameter table index tree secret level (2 * nodeIdx + 1) + (by omega) hrightSpan).bind fun right => + resolvedCouples_tweakableHash parameter table + (.ftsNode index tree (level + 1) nodeIdx) (nodePayload left right) + (stableOrdinaryInput_tweakableHashInput parameter + (.ftsNode index tree (level + 1) nodeIdx) _ hinRange + (by simp) (by simp) (by simp)) + +theorem resolvedCouples_ftsKey + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (secret : FtsTree → FtsLeaf → Digest) : + ResolvedCouples parameter table + (simulateQ ordinaryHashImpl (ftsKey parameter index secret)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsKey parameter index secret)) := by + unfold ftsKey + rw [simulateQ_bind, simulateQ_bind, simulateQ_ordinaryHashImpl_sequenceFin, + FtsProbeSimulation.simulateQ_randomOracle_sequenceFin] + exact (resolvedCouples_sequenceFin + (fun tree => simulateQ ordinaryHashImpl + (ftsNode parameter index tree (secret tree) ftsTreeHeight 0)) + (fun tree => simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsNode parameter index tree (secret tree) ftsTreeHeight 0)) + (fun tree => resolvedCouples_ftsNode parameter table index tree (secret tree) + ftsTreeHeight 0 le_rfl (by simp))).bind fun roots => + resolvedCouples_tweakableHash parameter table (.ftsRoots index) + (ftsRootsPayload roots) + (stableOrdinaryInput_tweakableHashInput parameter (.ftsRoots index) _ + (by trivial) (by simp) (by simp) (by simp)) + +theorem resolvedCouples_ftsOpen + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (leaves : DigestTree → FtsLeaf) + (secret : FtsTree → FtsLeaf → Digest) : + ResolvedCouples parameter table + (simulateQ ordinaryHashImpl (ftsOpen parameter index leaves secret)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsOpen parameter index leaves secret)) := by + unfold ftsOpen + rw [simulateQ_ordinaryHashImpl_sequenceFin, + FtsProbeSimulation.simulateQ_randomOracle_sequenceFin] + exact resolvedCouples_sequenceFin _ _ fun tree => by + rw [simulateQ_ordinaryHashImpl_sequenceFin, + FtsProbeSimulation.simulateQ_randomOracle_sequenceFin] + exact resolvedCouples_sequenceFin _ _ fun level => + resolvedCouples_ftsNode parameter table index tree (secret tree) level.val + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1) + (Nat.le_of_lt level.isLt) + (FtsProbeSimulation.ftsOpen_node_bound (leaves (ftsIndexOf tree)) level) + +theorem resolvedCouples_encode + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (counter : Counter) : + ResolvedCouples parameter table + (simulateQ ordinaryHashImpl (encode parameter lay tree leafIdx message counter)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (encode parameter lay tree leafIdx message counter)) := by + unfold encode + rw [simulateQ_bind, simulateQ_bind] + exact (resolvedCouples_tweakableHash parameter table (.encoding lay tree leafIdx) _ + (stableOrdinaryInput_tweakableHashInput parameter (.encoding lay tree leafIdx) _ + (by trivial) (by simp) (by simp) (by simp))).bind fun digest => + resolvedCouples_pure parameter table (TargetSum.decodeDigest digest) + +theorem resolvedCouples_messageDigest + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (root : Digest) (message : Message) (randomness : Randomness) : + ResolvedCouples parameter table + (simulateQ ordinaryHashImpl (messageDigest parameter root message randomness)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (messageDigest parameter root message randomness)) := by + unfold messageDigest + rw [simulateQ_bind, simulateQ_bind] + exact (resolvedCouples_oracleHash parameter table + (tweakableHashInput parameter .message + (messageDigestPayload root message randomness)) + (stableOrdinaryInput_tweakableHashInput parameter .message _ + (by trivial) (by simp) (by simp) (by simp))).bind fun output => + resolvedCouples_pure parameter table (truncateMessageDigest output) + +theorem resolvedCouples_signAttempt + (table : OtsSecretIndex → HashOutput) (secretKey : SecretKey) + (message : Message) (randomness : Randomness) : + ResolvedCouples secretKey.parameter table + (simulateQ ordinaryHashImpl (signAttempt secretKey message randomness)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (signAttempt secretKey message randomness)) := by + unfold signAttempt + simp only [simulateQ_bind] + exact (resolvedCouples_messageDigest secretKey.parameter table secretKey.root message + randomness).bind fun digest => by + split <;> exact resolvedCouples_pure secretKey.parameter table _ + +theorem resolvedCouples_signDigestLoop + (table : OtsSecretIndex → HashOutput) (secretKey : SecretKey) + (message : Message) : ∀ attempts, + ResolvedCouples secretKey.parameter table + (simulateQ ordinaryRomImpl (signDigestLoop attempts secretKey message)) + (simulateQ romImpl (signDigestLoop attempts secretKey message)) + | 0 => by + rw [signDigestLoop, simulateQ_pure, simulateQ_pure] + exact resolvedCouples_pure secretKey.parameter table none + | attempts + 1 => by + rw [signDigestLoop, simulateQ_bind, simulateQ_bind] + have hrandomness : ResolvedCouples secretKey.parameter table + (simulateQ ordinaryRomImpl (liftM sampleRandomness)) + (simulateQ romImpl (liftM sampleRandomness)) := by + rw [ordinaryRomImpl, romImpl, QueryImpl.simulateQ_add_liftM_left, + QueryImpl.simulateQ_add_liftM_left] + exact resolvedCouples_simulateQ splitUniformImpl (unifFwdImpl HashSpec) + (resolvedCouples_splitUniform secretKey.parameter table) sampleRandomness + exact hrandomness.bind fun randomness => by + rw [simulateQ_bind, simulateQ_bind] + have hattempt : ResolvedCouples secretKey.parameter table + (simulateQ ordinaryRomImpl + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))))) + (simulateQ romImpl + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))))) := by + rw [ordinaryRomImpl, romImpl, QueryImpl.simulateQ_add_liftM_right, + QueryImpl.simulateQ_add_liftM_right] + exact resolvedCouples_signAttempt table secretKey message randomness + exact hattempt.bind fun attempt => by + cases attempt with + | none => exact resolvedCouples_signDigestLoop table secretKey message attempts + | some selected => exact resolvedCouples_pure secretKey.parameter table _ + +noncomputable def resolvedOtsSelectFrom + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : Nat → Nat → + StateT (QueryCache HashSpec) ProbComp + (Option (Counter × (ChainIndex → Digit))) + | 0, _ => pure none + | attempts + 1, counter => do + let encoded ← simulateQ (randomOracle : QueryImpl HashSpec _) + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter)) + match encoded with + | some encoding => pure (some (BitVec.ofNat counterBits counter, encoding)) + | none => + resolvedOtsSelectFrom parameter lay tree leafIdx message attempts (counter + 1) + +noncomputable def resolvedOtsSelect + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : + StateT (QueryCache HashSpec) ProbComp + (Option (Counter × (ChainIndex → Digit))) := + resolvedOtsSelectFrom parameter lay tree leafIdx message encodingAttemptLimit 0 + +theorem resolvedOtsSelectFrom_then_values_eq_otsSignFrom + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter, + (do + match ← resolvedOtsSelectFrom parameter lay tree leafIdx message attempts counter with + | none => pure none + | some (selectedCounter, encoding) => do + let values ← sequenceFin fun chainIdx => + simulateQ (randomOracle : QueryImpl HashSpec _) + (chainWalk parameter lay tree leafIdx chainIdx 0 (encoding chainIdx).val + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩))) + pure (some (selectedCounter, values))) = + simulateQ (randomOracle : QueryImpl HashSpec _) + (otsSignFrom parameter lay tree leafIdx + (fun chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + message attempts counter) + | 0, counter => by + simp [resolvedOtsSelectFrom, otsSignFrom] + | attempts + 1, counter => by + rw [resolvedOtsSelectFrom, otsSignFrom, simulateQ_bind] + rw [bind_assoc] + apply bind_congr + intro encoded + cases encoded with + | none => + exact resolvedOtsSelectFrom_then_values_eq_otsSignFrom parameter table lay tree + leafIdx message attempts (counter + 1) + | some encoding => + simp only [pure_bind, simulateQ_bind, simulateQ_pure] + rw [FtsProbeSimulation.simulateQ_randomOracle_sequenceFin] + +theorem resolvedOtsSelect_then_values_eq_otsSign + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + (do + match ← resolvedOtsSelect parameter lay tree leafIdx message with + | none => pure none + | some (counter, encoding) => do + let values ← sequenceFin fun chainIdx => + simulateQ (randomOracle : QueryImpl HashSpec _) + (chainWalk parameter lay tree leafIdx chainIdx 0 (encoding chainIdx).val + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩))) + pure (some (counter, values))) = + simulateQ (randomOracle : QueryImpl HashSpec _) + (otsSign parameter lay tree leafIdx + (fun chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) message) := by + exact resolvedOtsSelectFrom_then_values_eq_otsSignFrom parameter table lay tree leafIdx + message encodingAttemptLimit 0 + +theorem resolvedCouples_maskedOtsSignFrom + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter, + ResolvedCouples parameter table + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + (resolvedOtsSelectFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom, resolvedOtsSelectFrom] + exact resolvedCouples_pure parameter table none + | attempts + 1, counter => by + rw [maskedOtsSignFrom, resolvedOtsSelectFrom] + exact (resolvedCouples_encode parameter table lay tree leafIdx message + (BitVec.ofNat counterBits counter)).bind fun encoded => by + cases encoded with + | none => + exact resolvedCouples_maskedOtsSignFrom parameter table lay tree leafIdx message + attempts (counter + 1) + | some encoding => + have hreserve := resolvedAdministrative_sequenceFin + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx + (encoding chainIdx)) + (fun _ => ()) + (fun chainIdx => resolvedAdministrative_ensureChainPrefix lay tree leafIdx + chainIdx (encoding chainIdx)) + exact (resolvedCouples_of_administrative hreserve).bind fun _ => + resolvedCouples_pure parameter table + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem resolvedCouples_maskedOtsSign + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ResolvedCouples parameter table + (maskedOtsSign parameter lay tree leafIdx message) + (resolvedOtsSelect parameter lay tree leafIdx message) := by + exact resolvedCouples_maskedOtsSignFrom parameter table lay tree leafIdx message + encodingAttemptLimit 0 + +theorem resolvedCouples_maskedChainValue + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) : + ResolvedCouples parameter table (maskedChainValue lay tree leafIdx chainIdx digit) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (chainWalk parameter lay tree leafIdx chainIdx 0 digit.val + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)))) := by + intro context fuel cache concreteCache hinvariant + exact relTriple_runResolvedFromTable_maskedChainValue_clean_or_doomed parameter table lay tree + leafIdx chainIdx digit context fuel cache concreteCache hinvariant + +theorem resolvedCouples_maskedTreeNode + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) + (hlevel : level ≤ maxLayerHeight) + (hspan : 2 ^ level * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) : + ResolvedCouples parameter table (maskedTreeNode lay tree level nodeIdx) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay tree + (fun leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + level nodeIdx)) := by + intro context fuel cache concreteCache hinvariant + exact relTriple_runResolvedFromTable_maskedTreeNode_clean_or_doomed parameter table lay tree + level nodeIdx hlevel hspan context fuel cache concreteCache hinvariant + +theorem resolvedCouples_maskedTreeRoot + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) : + ResolvedCouples parameter table (maskedTreeRoot lay tree) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay tree + (fun leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + (layerHeight lay) 0)) := by + unfold maskedTreeRoot + apply resolvedCouples_maskedTreeNode parameter table lay tree (layerHeight lay) 0 + (layerHeight_le lay) + simpa using Nat.pow_le_pow_right (n := 2) (by omega) (layerHeight_le lay) + +noncomputable def resolvedLayerMessage + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : StateT (QueryCache HashSpec) ProbComp Digest := + if hbelow : lay.val + 1 < numLayers then + let below : Layer := ⟨lay.val + 1, hbelow⟩ + simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter below (treeIndexAt index below) + (fun leafIdx chainIdx => + truncateHash (table ⟨below, treeIndexAt index below, leafIdx, chainIdx⟩)) + (layerHeight below) 0) + else + simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsKey parameter index (ftsSecret index)) + +theorem resolvedLayerMessage_eq_layerMessage + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + resolvedLayerMessage parameter table ftsSecret index lay = + simulateQ (randomOracle : QueryImpl HashSpec _) + (layerMessage + (⟨parameter, root, + fun selectedLay selectedTree selectedLeaf selectedChain => + truncateHash + (table ⟨selectedLay, selectedTree, selectedLeaf, selectedChain⟩), + ftsSecret⟩ : SecretKey) + index lay) := by + unfold resolvedLayerMessage layerMessage treeRoot + split <;> rfl + +noncomputable def resolvedSelectedLayerValues + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (lay : Layer) (message : Digest) : + StateT (QueryCache HashSpec) ProbComp + (Option (Counter × (ChainIndex → Digest))) := do + let tree := treeIndexAt index lay + let leafIdx := leafIndexAt index lay + match ← resolvedOtsSelect parameter lay tree leafIdx message with + | none => pure none + | some (counter, encoding) => do + let values ← sequenceFin fun chainIdx => + simulateQ (randomOracle : QueryImpl HashSpec _) + (chainWalk parameter lay tree leafIdx chainIdx 0 (encoding chainIdx).val + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩))) + pure (some (counter, values)) + +noncomputable def resolvedFinishLayerValues + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (lay : Layer) : + Option (Counter × (ChainIndex → Digest)) → + StateT (QueryCache HashSpec) ProbComp + (Option (Counter × (ChainIndex → Digest) × (Fin maxLayerHeight → Digest))) + | none => pure none + | some (counter, values) => do + let path ← sequenceFin fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay (treeIndexAt index lay) + (fun sibling chainIdx => + truncateHash + (table ⟨lay, treeIndexAt index lay, sibling, chainIdx⟩)) + level.val + (Nat.xor ((leafIndexAt index lay).val / 2 ^ level.val) 1)) + else pure 0 + pure (some (counter, values, path)) + +noncomputable def resolvedImmediateSignLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : StateT (QueryCache HashSpec) ProbComp + (Option (Counter × (ChainIndex → Digest) × (Fin maxLayerHeight → Digest))) := do + let message ← resolvedLayerMessage parameter table ftsSecret index lay + let selectedValues ← resolvedSelectedLayerValues parameter table index lay message + resolvedFinishLayerValues parameter table index lay selectedValues + +theorem resolvedImmediateSignLayer_eq_signLayer + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + resolvedImmediateSignLayer parameter table ftsSecret index lay = + simulateQ (randomOracle : QueryImpl HashSpec _) + (signLayer + (⟨parameter, root, + fun selectedLay selectedTree selectedLeaf selectedChain => + truncateHash + (table ⟨selectedLay, selectedTree, selectedLeaf, selectedChain⟩), + ftsSecret⟩ : SecretKey) + index lay) := by + unfold resolvedImmediateSignLayer signLayer + rw [resolvedLayerMessage_eq_layerMessage parameter root table ftsSecret index lay, + simulateQ_bind] + apply bind_congr + intro message + rw [simulateQ_bind] + unfold resolvedSelectedLayerValues + rw [resolvedOtsSelect_then_values_eq_otsSign parameter table lay + (treeIndexAt index lay) (leafIndexAt index lay) message] + apply bind_congr + intro selected + cases selected with + | none => simp [resolvedFinishLayerValues] + | some part => + rcases part with ⟨counter, values⟩ + unfold resolvedFinishLayerValues + simp only [simulateQ_bind, simulateQ_pure] + rw [treePath, FtsProbeSimulation.simulateQ_randomOracle_sequenceFin] + have hcomponent : + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay (treeIndexAt index lay) + (fun sibling chainIdx => truncateHash + (table ⟨lay, treeIndexAt index lay, sibling, chainIdx⟩)) + level.val + (Nat.xor ((leafIndexAt index lay).val / 2 ^ level.val) 1)) + else pure 0) = + (fun level : Fin maxLayerHeight => + simulateQ (randomOracle : QueryImpl HashSpec _) + (if level.val < layerHeight lay then + treeNode parameter lay (treeIndexAt index lay) + (fun sibling chainIdx => truncateHash + (table ⟨lay, treeIndexAt index lay, sibling, chainIdx⟩)) + level.val + (Nat.xor ((leafIndexAt index lay).val / 2 ^ level.val) 1) + else pure 0)) := by + funext level + split <;> rfl + rw [hcomponent] + +noncomputable def resolvedImmediateSignAfterDigest + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + StateT (QueryCache HashSpec) ProbComp (Option Signature) := do + let ftsPath ← simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsOpen parameter index leaves (ftsSecret index)) + let layers ← sequenceFin fun lay => + resolvedImmediateSignLayer parameter table ftsSecret index lay + match traverseOption layers with + | none => pure none + | some parts => + pure (some + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (parts lay).2.1 + authPath := flattenPaths fun lay => (parts lay).2.2 }) + +noncomputable def concreteSignAfterDigestFromTable + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + StateT (QueryCache HashSpec) ProbComp (Option Signature) := do + let secretKey : SecretKey := + ⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ + let ftsPath ← simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsOpen parameter index leaves (ftsSecret index)) + let layers ← sequenceFin fun lay => + simulateQ (randomOracle : QueryImpl HashSpec _) + (signLayer secretKey index lay) + match traverseOption layers with + | none => pure none + | some parts => + pure (some + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (parts lay).2.1 + authPath := flattenPaths fun lay => (parts lay).2.2 }) + +theorem resolvedImmediateSignAfterDigest_eq_concrete + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + resolvedImmediateSignAfterDigest parameter table ftsSecret randomness index leaves = + concreteSignAfterDigestFromTable parameter root table ftsSecret randomness index leaves := by + unfold resolvedImmediateSignAfterDigest concreteSignAfterDigestFromTable + have hlayers : + (fun lay => resolvedImmediateSignLayer parameter table ftsSecret index lay) = + (fun lay => simulateQ (randomOracle : QueryImpl HashSpec _) + (signLayer + (⟨parameter, root, + fun selectedLay selectedTree selectedLeaf selectedChain => + truncateHash + (table ⟨selectedLay, selectedTree, selectedLeaf, selectedChain⟩), + ftsSecret⟩ : SecretKey) + index lay)) := by + funext lay + exact resolvedImmediateSignLayer_eq_signLayer parameter root table ftsSecret index lay + rw [hlayers] + +theorem concreteSignAfterDigestFromTable_eq_signAfterDigest + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + concreteSignAfterDigestFromTable parameter root table ftsSecret randomness index leaves = + simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + randomness index leaves) := by + unfold concreteSignAfterDigestFromTable signAfterDigest + rw [simulateQ_bind] + apply bind_congr + intro ftsPath + rw [simulateQ_bind, FtsProbeSimulation.simulateQ_randomOracle_sequenceFin] + apply bind_congr + intro layers + cases traverseOption layers <;> rfl + +noncomputable def resolvedImmediateSign + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + StateT (QueryCache HashSpec) ProbComp (Option Signature) := do + let secretKey : SecretKey := + ⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ + match ← simulateQ romImpl (signDigestLoop digestAttemptLimit secretKey message) with + | none => pure none + | some (randomness, index, leaves) => + resolvedImmediateSignAfterDigest parameter table ftsSecret randomness index leaves + +theorem resolvedImmediateSign_eq_concrete + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + resolvedImmediateSign parameter root table ftsSecret message = + simulateQ romImpl + (scheme.sign + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + message) := by + let secretKey : SecretKey := + ⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ + unfold resolvedImmediateSign + rw [show (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) = secretKey from rfl] + change (do + match ← simulateQ romImpl (signDigestLoop digestAttemptLimit secretKey message) with + | none => pure none + | some (randomness, index, leaves) => + resolvedImmediateSignAfterDigest parameter table ftsSecret randomness index leaves) = + simulateQ romImpl (sign secretKey message) + rw [sign_eq_digestLoop_afterDigest, simulateQ_bind] + apply bind_congr + intro selected + cases selected with + | none => rfl + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + rw [romImpl, QueryImpl.simulateQ_add_liftM_right] + rw [← concreteSignAfterDigestFromTable_eq_signAfterDigest parameter root table ftsSecret + randomness index leaves] + exact resolvedImmediateSignAfterDigest_eq_concrete parameter root table ftsSecret + randomness index leaves + +theorem resolvedCouples_maskedLayerMessage + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + ResolvedCouples parameter table (maskedLayerMessage parameter ftsSecret index lay) + (resolvedLayerMessage parameter table ftsSecret index lay) := by + unfold maskedLayerMessage resolvedLayerMessage + split + · exact resolvedCouples_maskedTreeRoot parameter table _ _ + · exact resolvedCouples_ftsKey parameter table index (ftsSecret index) + +noncomputable def resolvedSignLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : StateT (QueryCache HashSpec) ProbComp + (Option (Counter × (ChainIndex → Digit))) := do + let tree := treeIndexAt index lay + let leafIdx := leafIndexAt index lay + let message ← resolvedLayerMessage parameter table ftsSecret index lay + match ← resolvedOtsSelect parameter lay tree leafIdx message with + | none => pure none + | some part => pure (some part) + +theorem resolvedImmediateSignLayer_eq_resolvedSignLayer_then_reveal + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + resolvedImmediateSignLayer parameter table ftsSecret index lay = (do + match ← resolvedSignLayer parameter table ftsSecret index lay with + | none => pure none + | some (counter, encoding) => do + let revealed ← resolvedRevealLayerValues parameter table index lay encoding + pure (some (counter, revealed.1, revealed.2))) := by + unfold resolvedImmediateSignLayer resolvedSignLayer resolvedSelectedLayerValues + resolvedFinishLayerValues resolvedRevealLayerValues + simp only [bind_assoc] + apply bind_congr + intro message + apply bind_congr + intro selected + cases selected with + | none => rfl + | some part => + rcases part with ⟨counter, encoding⟩ + simp only [pure_bind, bind_assoc] + +noncomputable def scheduleResolvedLayerResult + (index : Index) (lay : Layer) : + Option (ResolvedRunResult + (Option (Counter × (ChainIndex → Digit)) × SplitHashCache)) → + ProbComp (Option (ResolvedRunResult + (Option (Counter × (ChainIndex → Digest) × + (Fin maxLayerHeight → Digest)) × SplitHashCache))) := by + classical + intro input + cases input with + | none => exact pure none + | some result => + exact if DeferredCompletable result.table result.context then + match result.value.1 with + | none => pure (some ⟨result.context, result.remaining, + (none, result.value.2), result.table⟩) + | some (counter, encoding) => do + let resolved ← resolveDeferredLayerValues result.table index lay encoding + result.context + match resolved with + | none => pure none + | some (finalContext, values) => + pure (some ⟨finalContext, result.remaining, + (some (counter, values.1, values.2), result.value.2), result.table⟩) + else + pure (some ⟨result.context, result.remaining, + (none, result.value.2), result.table⟩) + +set_option maxRecDepth 100000 in +theorem evalDist_scheduleResolvedLayerResult_then_finalize + (index : Index) (lay : Layer) + (result : ResolvedRunResult + (Option (Counter × (ChainIndex → Digit)) × SplitHashCache)) + (coordinates : List Coordinate) (hvalid : result.context.Valid) + (hcovered : PendingCovered coordinates result.context) : + evalDist (do + let scheduled ← scheduleResolvedLayerResult index lay (some result) + match scheduled with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some scheduled => projectDeferredState <$> + finalizeResolvedCoordinates coordinates scheduled.context scheduled.table) = + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates result.context result.table) := by + classical + by_cases hcompletable : DeferredCompletable result.table result.context + · cases hselected : result.value.1 with + | none => + simp [scheduleResolvedLayerResult, hcompletable, hselected] + | some selected => + rcases selected with ⟨counter, encoding⟩ + rw [scheduleResolvedLayerResult] + simp only [hcompletable, if_pos, hselected, bind_assoc] + calc + _ = evalDist (do + let resolved ← resolveDeferredLayerValues result.table index lay encoding + result.context + match resolved with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some (finalContext, _) => projectDeferredState <$> + finalizeResolvedCoordinates coordinates finalContext result.table) := by + apply congrArg evalDist + apply bind_congr + intro resolved + cases resolved with + | none => rfl + | some resolved => + rcases resolved with ⟨finalContext, values⟩ + simp + _ = _ := evalDist_map_resolveDeferredLayerValues_then_finalize result.table index lay + encoding coordinates result.context hvalid hcovered + · simp [scheduleResolvedLayerResult, hcompletable] + +theorem evalDist_map_scheduleResolvedLayerResult_then_finalize + (index : Index) (lay : Layer) + (result : ResolvedRunResult + (Option (Counter × (ChainIndex → Digit)) × SplitHashCache)) + (coordinates : List Coordinate) (hvalid : result.context.Valid) + (hcovered : PendingCovered coordinates result.context) + (project : Option (LazyRevealProbe.State Coordinate) → alpha) : + evalDist (project <$> (do + let scheduled ← scheduleResolvedLayerResult index lay (some result) + match scheduled with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some scheduled => projectDeferredState <$> + finalizeResolvedCoordinates coordinates scheduled.context scheduled.table)) = + evalDist (project <$> (projectDeferredState <$> + finalizeResolvedCoordinates coordinates result.context result.table)) := by + rw [evalDist_map, evalDist_map, + evalDist_scheduleResolvedLayerResult_then_finalize index lay result coordinates hvalid + hcovered] + +theorem evalDist_scheduleResolvedLayerResult_then_finalize_isNone + (index : Index) (lay : Layer) + (result : ResolvedRunResult + (Option (Counter × (ChainIndex → Digit)) × SplitHashCache)) + (coordinates : List Coordinate) (hvalid : result.context.Valid) + (hcovered : PendingCovered coordinates result.context) : + evalDist (Option.isNone <$> (do + let scheduled ← scheduleResolvedLayerResult index lay (some result) + match scheduled with + | none => (pure none : ProbComp + (Option (LazyRevealProbe.State Coordinate))) + | some scheduled => projectDeferredState <$> + finalizeResolvedCoordinates coordinates scheduled.context scheduled.table)) = + evalDist (Option.isNone <$> (projectDeferredState <$> + finalizeResolvedCoordinates coordinates result.context result.table)) := + evalDist_map_scheduleResolvedLayerResult_then_finalize index lay result coordinates hvalid + hcovered Option.isNone + +theorem resolvedCouples_maskedSignLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + ResolvedCouples parameter table (maskedSignLayer parameter ftsSecret index lay) + (resolvedSignLayer parameter table ftsSecret index lay) := by + unfold maskedSignLayer resolvedSignLayer + apply (resolvedCouples_maskedLayerMessage parameter table ftsSecret index lay).bind + intro message + apply (resolvedCouples_maskedOtsSign parameter table lay (treeIndexAt index lay) + (leafIndexAt index lay) message).bind + intro selected + cases selected with + | none => exact resolvedCouples_pure parameter table none + | some part => + exact (resolvedCouples_of_administrative + (resolvedAdministrative_ensureTreePath lay (treeIndexAt index lay) + (leafIndexAt index lay))).bind fun _ => + resolvedCouples_pure parameter table (some part) + +noncomputable def resolvedSignAfterDigest + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + StateT (QueryCache HashSpec) ProbComp (Option Signature) := do + let ftsPath ← simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsOpen parameter index leaves (ftsSecret index)) + let layers ← sequenceFin fun lay => + resolvedSignLayer parameter table ftsSecret index lay + match traverseOption layers with + | none => pure none + | some parts => do + let revealed ← sequenceFin fun lay => + resolvedRevealLayerValues parameter table index lay (parts lay).2 + pure (some + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (revealed lay).1 + authPath := flattenPaths fun lay => (revealed lay).2 }) + +set_option maxHeartbeats 400000 in +theorem resolvedCouples_maskedSignAfterDigest + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + ResolvedCouples parameter table + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) + (resolvedSignAfterDigest parameter table ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest resolvedSignAfterDigest + apply (resolvedCouples_ftsOpen parameter table index leaves (ftsSecret index)).bind + intro ftsPath + apply (resolvedCouples_sequenceFin _ _ fun lay => + resolvedCouples_maskedSignLayer parameter table ftsSecret index lay).bind + intro layers + cases hparts : traverseOption layers with + | none => exact resolvedCouples_pure parameter table none + | some parts => + apply (resolvedCouples_sequenceFin _ _ fun lay => + resolvedCouples_resolvedRevealLayerValues parameter table index lay + (parts lay).2).bind + intro revealed + let signature : Signature := + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (revealed lay).1 + authPath := flattenPaths fun lay => (revealed lay).2 } + exact resolvedCouples_pure parameter table (some signature) + +noncomputable def resolvedSign + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + StateT (QueryCache HashSpec) ProbComp (Option Signature) := do + let secretKey : SecretKey := + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ + match ← simulateQ romImpl + (signDigestLoop digestAttemptLimit secretKey message) with + | none => pure none + | some (randomness, index, leaves) => + resolvedSignAfterDigest parameter table ftsSecret randomness index leaves + +set_option maxHeartbeats 400000 in +theorem resolvedCouples_maskedSign + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + ResolvedCouples parameter table (maskedSign parameter root ftsSecret message) + (resolvedSign parameter root table ftsSecret message) := by + unfold maskedSign resolvedSign + let secretKey : SecretKey := + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ + apply (resolvedCouples_signDigestLoop table secretKey message digestAttemptLimit).bind + intro selected + cases selected with + | none => exact resolvedCouples_pure parameter table none + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + exact resolvedCouples_maskedSignAfterDigest parameter table ftsSecret randomness index + leaves + +theorem reachableResolvedCouples_oracleHash + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : HashInput) (hstable : StableOrdinaryInput parameter input) : + ReachableResolvedCouples parameter table + (simulateQ ordinaryHashImpl (oracleHash input)) + (simulateQ (randomOracle : QueryImpl HashSpec _) (oracleHash input)) := by + simpa only [oracleHash, HasQuery.instOfMonadLift_query, simulateQ_spec_query, + ordinaryHashImpl] using + reachableResolvedCouples_splitHashQuery_stable parameter table input hstable + +theorem reachableResolvedCouples_tweakableHash + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (domain : HashDomain) (payload : HashInput) + (hstable : StableOrdinaryInput parameter + (tweakableHashInput parameter domain payload)) : + ReachableResolvedCouples parameter table + (simulateQ ordinaryHashImpl (tweakableHash parameter domain payload)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (tweakableHash parameter domain payload)) := by + unfold tweakableHash + rw [simulateQ_bind, simulateQ_bind] + exact (reachableResolvedCouples_oracleHash parameter table + (tweakableHashInput parameter domain payload) hstable).bind fun output => + reachableResolvedCouples_pure parameter table (truncateHash output) + +theorem reachableResolvedCouples_ftsLeafHash + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (tree : FtsTree) (leafIdx : FtsLeaf) (secret : Digest) : + ReachableResolvedCouples parameter table + (simulateQ ordinaryHashImpl (ftsLeafHash parameter index tree leafIdx secret)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsLeafHash parameter index tree leafIdx secret)) := by + unfold ftsLeafHash + exact reachableResolvedCouples_tweakableHash parameter table (.ftsLeaf index tree leafIdx) _ + (stableOrdinaryInput_tweakableHashInput parameter (.ftsLeaf index tree leafIdx) _ + (by trivial) (by simp) (by simp) (by simp)) + +theorem reachableResolvedCouples_ftsNode + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (tree : FtsTree) (secret : FtsLeaf → Digest) : + ∀ level nodeIdx, level ≤ ftsTreeHeight → + 2 ^ level * (nodeIdx + 1) ≤ 2 ^ ftsTreeHeight → + ReachableResolvedCouples parameter table + (simulateQ ordinaryHashImpl + (ftsNode parameter index tree secret level nodeIdx)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsNode parameter index tree secret level nodeIdx)) + | 0, nodeIdx, hlevel, hspan => by + rw [ftsNode_zero_eq] + exact reachableResolvedCouples_ftsLeafHash parameter table index tree _ _ + | level + 1, nodeIdx, hlevel, hspan => by + rw [ftsNode_succ_eq] + simp only [simulateQ_bind] + have hleftSpan : 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ ftsTreeHeight := by + rw [pow_succ] at hspan + calc + 2 ^ level * (2 * nodeIdx + 1) ≤ 2 ^ level * (2 * (nodeIdx + 1)) := + Nat.mul_le_mul_left _ (by omega) + _ = 2 ^ level * 2 * (nodeIdx + 1) := by ring + _ ≤ 2 ^ ftsTreeHeight := hspan + have hrightSpan : 2 ^ level * (2 * nodeIdx + 1 + 1) ≤ 2 ^ ftsTreeHeight := by + rw [pow_succ] at hspan + calc + 2 ^ level * (2 * nodeIdx + 1 + 1) = 2 ^ level * 2 * (nodeIdx + 1) := by + ring + _ ≤ 2 ^ ftsTreeHeight := hspan + have hinRange : (HashDomain.ftsNode index tree (level + 1) nodeIdx).InRange := by + show level + 1 < 2 ^ 32 ∧ nodeIdx < 2 ^ 32 + constructor + · have : ftsTreeHeight < 2 ^ 32 := by norm_num [ftsTreeHeight] + omega + · have hnode : nodeIdx < 2 ^ ftsTreeHeight := by + have hpow : 0 < 2 ^ (level + 1) := Nat.two_pow_pos _ + nlinarith + have : 2 ^ ftsTreeHeight ≤ 2 ^ 32 := Nat.pow_le_pow_right (by omega) (by + norm_num [ftsTreeHeight]) + omega + exact (reachableResolvedCouples_ftsNode parameter table index tree secret level + (2 * nodeIdx) (by omega) hleftSpan).bind fun left => + (reachableResolvedCouples_ftsNode parameter table index tree secret level + (2 * nodeIdx + 1) (by omega) hrightSpan).bind fun right => + reachableResolvedCouples_tweakableHash parameter table + (.ftsNode index tree (level + 1) nodeIdx) (nodePayload left right) + (stableOrdinaryInput_tweakableHashInput parameter + (.ftsNode index tree (level + 1) nodeIdx) _ hinRange + (by simp) (by simp) (by simp)) + +theorem reachableResolvedCouples_ftsKey + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (secret : FtsTree → FtsLeaf → Digest) : + ReachableResolvedCouples parameter table + (simulateQ ordinaryHashImpl (ftsKey parameter index secret)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsKey parameter index secret)) := by + unfold ftsKey + rw [simulateQ_bind, simulateQ_bind, simulateQ_ordinaryHashImpl_sequenceFin, + FtsProbeSimulation.simulateQ_randomOracle_sequenceFin] + exact (reachableResolvedCouples_sequenceFin + (fun tree => simulateQ ordinaryHashImpl + (ftsNode parameter index tree (secret tree) ftsTreeHeight 0)) + (fun tree => simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsNode parameter index tree (secret tree) ftsTreeHeight 0)) + (fun tree => reachableResolvedCouples_ftsNode parameter table index tree (secret tree) + ftsTreeHeight 0 le_rfl (by simp))).bind fun roots => + reachableResolvedCouples_tweakableHash parameter table (.ftsRoots index) + (ftsRootsPayload roots) + (stableOrdinaryInput_tweakableHashInput parameter (.ftsRoots index) _ + (by trivial) (by simp) (by simp) (by simp)) + +theorem reachableResolvedCouples_ftsOpen + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (leaves : DigestTree → FtsLeaf) + (secret : FtsTree → FtsLeaf → Digest) : + ReachableResolvedCouples parameter table + (simulateQ ordinaryHashImpl (ftsOpen parameter index leaves secret)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsOpen parameter index leaves secret)) := by + unfold ftsOpen + rw [simulateQ_ordinaryHashImpl_sequenceFin, + FtsProbeSimulation.simulateQ_randomOracle_sequenceFin] + exact reachableResolvedCouples_sequenceFin _ _ fun tree => by + rw [simulateQ_ordinaryHashImpl_sequenceFin, + FtsProbeSimulation.simulateQ_randomOracle_sequenceFin] + exact reachableResolvedCouples_sequenceFin _ _ fun level => + reachableResolvedCouples_ftsNode parameter table index tree (secret tree) level.val + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1) + (Nat.le_of_lt level.isLt) + (FtsProbeSimulation.ftsOpen_node_bound (leaves (ftsIndexOf tree)) level) + +theorem reachableResolvedCouples_encode + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (counter : Counter) : + ReachableResolvedCouples parameter table + (simulateQ ordinaryHashImpl (encode parameter lay tree leafIdx message counter)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (encode parameter lay tree leafIdx message counter)) := by + unfold encode + rw [simulateQ_bind, simulateQ_bind] + exact (reachableResolvedCouples_tweakableHash parameter table (.encoding lay tree leafIdx) _ + (stableOrdinaryInput_tweakableHashInput parameter (.encoding lay tree leafIdx) _ + (by trivial) (by simp) (by simp) (by simp))).bind fun digest => + reachableResolvedCouples_pure parameter table (TargetSum.decodeDigest digest) + +theorem reachableResolvedCouples_messageDigest + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (root : Digest) (message : Message) (randomness : Randomness) : + ReachableResolvedCouples parameter table + (simulateQ ordinaryHashImpl (messageDigest parameter root message randomness)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (messageDigest parameter root message randomness)) := by + unfold messageDigest + rw [simulateQ_bind, simulateQ_bind] + exact (reachableResolvedCouples_oracleHash parameter table + (tweakableHashInput parameter .message + (messageDigestPayload root message randomness)) + (stableOrdinaryInput_tweakableHashInput parameter .message _ + (by trivial) (by simp) (by simp) (by simp))).bind fun output => + reachableResolvedCouples_pure parameter table (truncateMessageDigest output) + +theorem reachableResolvedCouples_signAttempt + (table : OtsSecretIndex → HashOutput) (secretKey : SecretKey) + (message : Message) (randomness : Randomness) : + ReachableResolvedCouples secretKey.parameter table + (simulateQ ordinaryHashImpl (signAttempt secretKey message randomness)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (signAttempt secretKey message randomness)) := by + unfold signAttempt + simp only [simulateQ_bind] + exact (reachableResolvedCouples_messageDigest secretKey.parameter table secretKey.root message + randomness).bind fun digest => by + split <;> exact reachableResolvedCouples_pure secretKey.parameter table _ + +theorem reachableResolvedCouples_signDigestLoop + (table : OtsSecretIndex → HashOutput) (secretKey : SecretKey) + (message : Message) : ∀ attempts, + ReachableResolvedCouples secretKey.parameter table + (simulateQ ordinaryRomImpl (signDigestLoop attempts secretKey message)) + (simulateQ romImpl (signDigestLoop attempts secretKey message)) + | 0 => by + rw [signDigestLoop, simulateQ_pure, simulateQ_pure] + exact reachableResolvedCouples_pure secretKey.parameter table none + | attempts + 1 => by + rw [signDigestLoop, simulateQ_bind, simulateQ_bind] + have hrandomness : ReachableResolvedCouples secretKey.parameter table + (simulateQ ordinaryRomImpl (liftM sampleRandomness)) + (simulateQ romImpl (liftM sampleRandomness)) := by + rw [ordinaryRomImpl, romImpl, QueryImpl.simulateQ_add_liftM_left, + QueryImpl.simulateQ_add_liftM_left] + exact reachableResolvedCouples_simulateQ splitUniformImpl (unifFwdImpl HashSpec) + (reachableResolvedCouples_splitUniform secretKey.parameter table) sampleRandomness + exact hrandomness.bind fun randomness => by + rw [simulateQ_bind, simulateQ_bind] + have hattempt : ReachableResolvedCouples secretKey.parameter table + (simulateQ ordinaryRomImpl + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))))) + (simulateQ romImpl + (liftM (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))))) := by + rw [ordinaryRomImpl, romImpl, QueryImpl.simulateQ_add_liftM_right, + QueryImpl.simulateQ_add_liftM_right] + exact reachableResolvedCouples_signAttempt table secretKey message randomness + exact hattempt.bind fun attempt => by + cases attempt with + | none => exact reachableResolvedCouples_signDigestLoop table secretKey message attempts + | some selected => exact reachableResolvedCouples_pure secretKey.parameter table _ + +theorem signDigestLoop_eq_of_parameter_root + (left right : SecretKey) (hparameter : left.parameter = right.parameter) + (hroot : left.root = right.root) (message : Message) : ∀ attempts, + signDigestLoop attempts left message = signDigestLoop attempts right message + | 0 => by rw [signDigestLoop, signDigestLoop] + | attempts + 1 => by + rw [signDigestLoop, signDigestLoop] + apply bind_congr + intro randomness + have hattempt : + (signAttempt left message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))) = + signAttempt right message randomness := by + unfold signAttempt + rw [hparameter, hroot] + rw [hattempt] + apply bind_congr + intro attempt + cases attempt with + | none => exact signDigestLoop_eq_of_parameter_root left right hparameter hroot message attempts + | some selected => rfl + +theorem reachableResolvedCouples_maskedOtsSignFrom + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter, + ReachableResolvedCouples parameter table + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + (resolvedOtsSelectFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom, resolvedOtsSelectFrom] + exact reachableResolvedCouples_pure parameter table none + | attempts + 1, counter => by + rw [maskedOtsSignFrom, resolvedOtsSelectFrom] + exact (reachableResolvedCouples_encode parameter table lay tree leafIdx message + (BitVec.ofNat counterBits counter)).bind fun encoded => by + cases encoded with + | none => + exact reachableResolvedCouples_maskedOtsSignFrom parameter table lay tree leafIdx + message attempts (counter + 1) + | some encoding => + have hreserve := resolvedAdministrative_sequenceFin + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx + (encoding chainIdx)) + (fun _ => ()) + (fun chainIdx => resolvedAdministrative_ensureChainPrefix lay tree leafIdx + chainIdx (encoding chainIdx)) + have hreservePublished := resolvedPreservesPublished_sequenceFin + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx (encoding chainIdx)) + (fun chainIdx => resolvedPreservesPublished_ensureChainPrefix lay tree leafIdx + chainIdx (encoding chainIdx)) + exact (reachableResolvedCouples_of_administrative hreserve + hreservePublished).bind fun _ => + reachableResolvedCouples_pure parameter table + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem reachableResolvedCouples_maskedOtsSign + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ReachableResolvedCouples parameter table + (maskedOtsSign parameter lay tree leafIdx message) + (resolvedOtsSelect parameter lay tree leafIdx message) := by + exact reachableResolvedCouples_maskedOtsSignFrom parameter table lay tree leafIdx message + encodingAttemptLimit 0 + +theorem reachableResolvedCouples_revealPublishedChainValue + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) : + ReachableResolvedCouples parameter table + (revealPublishedCoordinate + (chainValueCoordinate lay tree leafIdx chainIdx digit)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (chainWalk parameter lay tree leafIdx chainIdx 0 digit.val + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)))) := by + unfold revealPublishedCoordinate chainValueCoordinate + split + · have hbase := (reachableResolvedCouples_revealChainStart parameter table + ⟨lay, tree, leafIdx, chainIdx⟩).publishAfter + (.chainStart lay tree leafIdx chainIdx) (by + intro context fuel cache result hresult + exact value_ne_none_of_mem_runResolvedFromTable_revealCoordinate context fuel table + (.chainStart lay tree leafIdx chainIdx) cache result (by + simpa [revealChainStart] using hresult)) + simpa [revealChainStart, chainWalk, ‹digit.val = 0›] using hbase + · let step : ChainStep := ⟨digit.val - 1, by + have := digit.isLt + omega⟩ + have hwalk : resolvedPositionComputation parameter table + (.chain lay tree leafIdx chainIdx step) = + chainWalk parameter lay tree leafIdx chainIdx 0 digit.val + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) := by + simp [resolvedPositionComputation, step] + have hpos : 0 < digit.val := Nat.pos_of_ne_zero ‹digit.val ≠ 0› + congr 1 + omega + rw [← hwalk] + have hbase := (reachableResolvedCouples_revealResolvablePosition parameter table + (.chain lay tree leafIdx chainIdx step) (by simp [ResolvableOtsPosition])).publishAfter + (.position (.chain lay tree leafIdx chainIdx step)) (by + intro context fuel cache result hresult + exact value_ne_none_of_mem_runResolvedFromTable_revealCoordinate context fuel table + (.position (.chain lay tree leafIdx chainIdx step)) cache result (by + simpa [revealPosition] using hresult)) + simpa [revealPosition, step] using hbase + +theorem reachableResolvedCouples_revealPublishedTreeNode + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) + (hlevel : level ≤ maxLayerHeight) + (hspan : 2 ^ level * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) : + ReachableResolvedCouples parameter table + (match level with + | 0 => revealPublishedCoordinate (.position (.leaf lay tree (leafOfNat nodeIdx))) + | current + 1 => + if hcurrent : current < maxLayerHeight then + revealPublishedCoordinate (.position + (.node lay tree ⟨current, hcurrent⟩ (leafOfNat nodeIdx))) + else pure 0) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay tree + (fun leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + level nodeIdx)) := by + cases level with + | zero => + have hbase := (reachableResolvedCouples_revealResolvablePosition parameter table + (.leaf lay tree (leafOfNat nodeIdx)) (by simp [ResolvableOtsPosition])).publishAfter + (.position (.leaf lay tree (leafOfNat nodeIdx))) (by + intro context fuel cache result hresult + exact value_ne_none_of_mem_runResolvedFromTable_revealCoordinate context fuel table + (.position (.leaf lay tree (leafOfNat nodeIdx))) cache result (by + simpa [revealPosition] using hresult)) + simpa [revealPublishedCoordinate, revealPosition, resolvedPositionComputation, + treeNode_zero_eq] using hbase + | succ current => + have hcurrent : current < maxLayerHeight := by omega + simp only [hcurrent, ↓reduceDIte] + have hnodeLt : nodeIdx < 2 ^ maxLayerHeight := by + have hpow : 0 < 2 ^ (current + 1) := pow_pos (by omega) _ + nlinarith + have hnodeVal : (leafOfNat nodeIdx).val = nodeIdx := by + simp [leafOfNat, Nat.mod_eq_of_lt hnodeLt] + have hresolvable : ResolvableOtsPosition + (.node lay tree ⟨current, hcurrent⟩ (leafOfNat nodeIdx)) := by + simp [ResolvableOtsPosition, hnodeVal] + exact hspan + have hbase := (reachableResolvedCouples_revealResolvablePosition parameter table + (.node lay tree ⟨current, hcurrent⟩ (leafOfNat nodeIdx)) hresolvable).publishAfter + (.position (.node lay tree ⟨current, hcurrent⟩ (leafOfNat nodeIdx))) (by + intro context fuel cache result hresult + exact value_ne_none_of_mem_runResolvedFromTable_revealCoordinate context fuel table + (.position (.node lay tree ⟨current, hcurrent⟩ (leafOfNat nodeIdx))) cache result + (by simpa [revealPosition] using hresult)) + simpa [revealPublishedCoordinate, revealPosition, resolvedPositionComputation, + hnodeVal] using hbase + +theorem reachableResolvedCouples_revealLayerPathNode + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (lay : Layer) (level : Fin maxLayerHeight) : + ReachableResolvedCouples parameter table + (if level.val < layerHeight lay then + match level.val with + | 0 => revealPublishedCoordinate (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | current + 1 => + if hcurrent : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hcurrent⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0 + else pure 0) + (if level.val < layerHeight lay then + simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay (treeIndexAt index lay) + (fun sibling chainIdx => + truncateHash (table ⟨lay, treeIndexAt index lay, sibling, chainIdx⟩)) + level.val + (Nat.xor ((leafIndexAt index lay).val / 2 ^ level.val) 1)) + else pure 0) := by + by_cases hinLayer : level.val < layerHeight lay + · rw [if_pos hinLayer, if_pos hinLayer] + cases hvalue : level.val with + | zero => + simpa [hvalue] using + reachableResolvedCouples_revealPublishedTreeNode parameter table lay + (treeIndexAt index lay) 0 + (Nat.xor (leafIndexAt index lay).val 1) (by omega) + (by + simpa using (FtsProbeSimulation.sibling_node_bound maxLayerHeight + (leafIndexAt index lay).val 0 (by omega) (leafIndexAt index lay).isLt)) + | succ current => + have hcurrent : current < maxLayerHeight := by + have := level.isLt + omega + simpa [hvalue, hcurrent] using + reachableResolvedCouples_revealPublishedTreeNode parameter table lay + (treeIndexAt index lay) (current + 1) + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1) + (by omega) + (FtsProbeSimulation.sibling_node_bound maxLayerHeight + (leafIndexAt index lay).val (current + 1) (by omega) + (leafIndexAt index lay).isLt) + · rw [if_neg hinLayer, if_neg hinLayer] + exact reachableResolvedCouples_pure parameter table 0 + +set_option maxHeartbeats 400000 in +theorem reachableResolvedCouples_revealLayerValues + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + ReachableResolvedCouples parameter table (revealLayerValues index lay encoding) + (do + let tree := treeIndexAt index lay + let leafIdx := leafIndexAt index lay + let values ← sequenceFin fun chainIdx => + simulateQ (randomOracle : QueryImpl HashSpec _) + (chainWalk parameter lay tree leafIdx chainIdx 0 (encoding chainIdx).val + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩))) + let path ← sequenceFin fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay tree + (fun sibling chainIdx => + truncateHash (table ⟨lay, tree, sibling, chainIdx⟩)) + level.val (Nat.xor (leafIdx.val / 2 ^ level.val) 1)) + else + pure 0 + pure (values, path)) := by + unfold revealLayerValues + apply (reachableResolvedCouples_sequenceFin _ _ fun chainIdx => + reachableResolvedCouples_revealPublishedChainValue parameter table lay + (treeIndexAt index lay) (leafIndexAt index lay) chainIdx (encoding chainIdx)).bind + intro values + apply (reachableResolvedCouples_sequenceFin _ _ fun level => + reachableResolvedCouples_revealLayerPathNode parameter table index lay level).bind + intro path + exact reachableResolvedCouples_pure parameter table (values, path) + +theorem reachableResolvedCouples_resolvedRevealLayerValues + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + ReachableResolvedCouples parameter table (revealLayerValues index lay encoding) + (resolvedRevealLayerValues parameter table index lay encoding) := by + unfold resolvedRevealLayerValues + exact reachableResolvedCouples_revealLayerValues parameter table index lay encoding + +noncomputable def revealPrivateLayerValues (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) + ((ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) := do + let tree := treeIndexAt index lay + let leafIdx := leafIndexAt index lay + let values ← sequenceFin fun chainIdx => + revealCoordinate (chainValueCoordinate lay tree leafIdx chainIdx (encoding chainIdx)) + let path ← sequenceFin fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + match level.val with + | 0 => revealPosition (.leaf lay tree + (leafOfNat (Nat.xor leafIdx.val 1))) + | current + 1 => + if hlevel : current < maxLayerHeight then + revealPosition (.node lay tree ⟨current, hlevel⟩ + (leafOfNat (Nat.xor (leafIdx.val / 2 ^ (current + 1)) 1))) + else pure 0 + else pure 0 + pure (values, path) + +theorem reachableResolvedCouples_revealPrivateChainValue + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) : + ReachableResolvedCouples parameter table + (revealCoordinate (chainValueCoordinate lay tree leafIdx chainIdx digit)) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (chainWalk parameter lay tree leafIdx chainIdx 0 digit.val + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)))) := by + unfold chainValueCoordinate + split + · simpa [revealChainStart, chainWalk, ‹digit.val = 0›] using + reachableResolvedCouples_revealChainStart parameter table + ⟨lay, tree, leafIdx, chainIdx⟩ + · let step : ChainStep := ⟨digit.val - 1, by + have := digit.isLt + omega⟩ + have hwalk : resolvedPositionComputation parameter table + (.chain lay tree leafIdx chainIdx step) = + chainWalk parameter lay tree leafIdx chainIdx 0 digit.val + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) := by + simp [resolvedPositionComputation, step] + have hpos : 0 < digit.val := Nat.pos_of_ne_zero ‹digit.val ≠ 0› + congr 1 + omega + rw [← hwalk] + simpa [revealPosition, step] using + reachableResolvedCouples_revealResolvablePosition parameter table + (.chain lay tree leafIdx chainIdx step) (by simp [ResolvableOtsPosition]) + +theorem reachableResolvedCouples_revealPrivateTreeNode + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) + (hlevel : level ≤ maxLayerHeight) + (hspan : 2 ^ level * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) : + ReachableResolvedCouples parameter table + (match level with + | 0 => revealPosition (.leaf lay tree (leafOfNat nodeIdx)) + | current + 1 => + if hcurrent : current < maxLayerHeight then + revealPosition (.node lay tree ⟨current, hcurrent⟩ (leafOfNat nodeIdx)) + else pure 0) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay tree + (fun leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + level nodeIdx)) := by + cases level with + | zero => + simpa [revealPosition, resolvedPositionComputation, treeNode_zero_eq] using + reachableResolvedCouples_revealResolvablePosition parameter table + (.leaf lay tree (leafOfNat nodeIdx)) (by simp [ResolvableOtsPosition]) + | succ current => + have hcurrent : current < maxLayerHeight := by omega + simp only [hcurrent, ↓reduceDIte] + have hnodeLt : nodeIdx < 2 ^ maxLayerHeight := by + have hpow : 0 < 2 ^ (current + 1) := pow_pos (by omega) _ + nlinarith + have hnodeVal : (leafOfNat nodeIdx).val = nodeIdx := by + simp [leafOfNat, Nat.mod_eq_of_lt hnodeLt] + have hresolvable : ResolvableOtsPosition + (.node lay tree ⟨current, hcurrent⟩ (leafOfNat nodeIdx)) := by + simp [ResolvableOtsPosition, hnodeVal] + exact hspan + simpa [revealPosition, resolvedPositionComputation, hnodeVal] using + reachableResolvedCouples_revealResolvablePosition parameter table + (.node lay tree ⟨current, hcurrent⟩ (leafOfNat nodeIdx)) hresolvable + +theorem reachableResolvedCouples_revealPrivateLayerPathNode + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (lay : Layer) (level : Fin maxLayerHeight) : + ReachableResolvedCouples parameter table + (if level.val < layerHeight lay then + match level.val with + | 0 => revealPosition (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1))) + | current + 1 => + if hcurrent : current < maxLayerHeight then + revealPosition (.node lay (treeIndexAt index lay) + ⟨current, hcurrent⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1))) + else pure 0 + else pure 0) + (if level.val < layerHeight lay then + simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay (treeIndexAt index lay) + (fun sibling chainIdx => + truncateHash (table ⟨lay, treeIndexAt index lay, sibling, chainIdx⟩)) + level.val + (Nat.xor ((leafIndexAt index lay).val / 2 ^ level.val) 1)) + else pure 0) := by + by_cases hinLayer : level.val < layerHeight lay + · rw [if_pos hinLayer, if_pos hinLayer] + cases hvalue : level.val with + | zero => + simpa [hvalue] using + reachableResolvedCouples_revealPrivateTreeNode parameter table lay + (treeIndexAt index lay) 0 + (Nat.xor (leafIndexAt index lay).val 1) (by omega) + (by + simpa using (FtsProbeSimulation.sibling_node_bound maxLayerHeight + (leafIndexAt index lay).val 0 (by omega) (leafIndexAt index lay).isLt)) + | succ current => + have hcurrent : current < maxLayerHeight := by + have := level.isLt + omega + simpa [hvalue, hcurrent] using + reachableResolvedCouples_revealPrivateTreeNode parameter table lay + (treeIndexAt index lay) (current + 1) + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1) + (by omega) + (FtsProbeSimulation.sibling_node_bound maxLayerHeight + (leafIndexAt index lay).val (current + 1) (by omega) + (leafIndexAt index lay).isLt) + · rw [if_neg hinLayer, if_neg hinLayer] + exact reachableResolvedCouples_pure parameter table 0 + +set_option maxHeartbeats 400000 in +theorem reachableResolvedCouples_revealPrivateLayerValues + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + ReachableResolvedCouples parameter table + (revealPrivateLayerValues index lay encoding) + (resolvedRevealLayerValues parameter table index lay encoding) := by + unfold revealPrivateLayerValues resolvedRevealLayerValues + apply (reachableResolvedCouples_sequenceFin _ _ fun chainIdx => + reachableResolvedCouples_revealPrivateChainValue parameter table lay + (treeIndexAt index lay) (leafIndexAt index lay) chainIdx (encoding chainIdx)).bind + intro values + apply (reachableResolvedCouples_sequenceFin _ _ fun level => + reachableResolvedCouples_revealPrivateLayerPathNode parameter table index lay level).bind + intro path + exact reachableResolvedCouples_pure parameter table (values, path) + +structure ChronologicalLayerPart where + counter : Counter + encoding : ChainIndex → Digit + chainValue : ChainIndex → Digest + authPath : Fin maxLayerHeight → Digest + +def ChronologicalLayerPart.toLayerPart (part : ChronologicalLayerPart) : LayerPart := + (part.counter, part.chainValue, part.authPath) + +noncomputable def maskedChronologicalSignLayer + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) + (Option ChronologicalLayerPart) := do + match ← maskedSignLayer parameter ftsSecret index lay with + | none => pure none + | some (counter, encoding) => do + let values ← revealPrivateLayerValues index lay encoding + pure (some ⟨counter, encoding, values.1, values.2⟩) + +noncomputable def resolvedChronologicalSignLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : StateT (QueryCache HashSpec) ProbComp + (Option ChronologicalLayerPart) := do + match ← resolvedSignLayer parameter table ftsSecret index lay with + | none => pure none + | some (counter, encoding) => do + let values ← resolvedRevealLayerValues parameter table index lay encoding + pure (some ⟨counter, encoding, values.1, values.2⟩) + +theorem resolvedChronologicalSignLayer_projects_to_immediate + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + (do + let result ← resolvedChronologicalSignLayer parameter table ftsSecret index lay + pure (result.map ChronologicalLayerPart.toLayerPart)) = + resolvedImmediateSignLayer parameter table ftsSecret index lay := by + rw [resolvedImmediateSignLayer_eq_resolvedSignLayer_then_reveal] + unfold resolvedChronologicalSignLayer + simp only [bind_assoc] + apply bind_congr + intro selected + cases selected with + | none => rfl + | some selected => + rcases selected with ⟨counter, encoding⟩ + simp [ChronologicalLayerPart.toLayerPart] + +theorem resolvedChronologicalSignLayer_cache_mono + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (cache finalCache : QueryCache HashSpec) + (result : Option ChronologicalLayerPart) + (hresult : (result, finalCache) ∈ support + ((resolvedChronologicalSignLayer parameter table ftsSecret index lay).run cache)) : + cache ≤ finalCache := by + have hmapped : (result.map ChronologicalLayerPart.toLayerPart, finalCache) ∈ support + ((do + let selected ← resolvedChronologicalSignLayer parameter table ftsSecret index lay + pure (selected.map ChronologicalLayerPart.toLayerPart)).run cache) := by + rw [StateT.run_bind, mem_support_bind_iff] + exact ⟨(result, finalCache), hresult, by simp⟩ + rw [resolvedChronologicalSignLayer_projects_to_immediate parameter table ftsSecret index lay, + resolvedImmediateSignLayer_eq_signLayer parameter 0 table ftsSecret index lay] at hmapped + exact FtsProbeSimulation.simulateQ_randomOracle_cache_le _ cache finalCache _ hmapped + +theorem resolvedChronologicalSignLayer_reveal_support + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (cache finalCache : QueryCache HashSpec) + (part : ChronologicalLayerPart) + (hresult : (some part, finalCache) ∈ support + ((resolvedChronologicalSignLayer parameter table ftsSecret index lay).run cache)) : + ∃ selectedCache, + ((part.chainValue, part.authPath), finalCache) ∈ support + ((resolvedRevealLayerValues parameter table index lay part.encoding).run selectedCache) := by + unfold resolvedChronologicalSignLayer at hresult + rw [StateT.run_bind, mem_support_bind_iff] at hresult + obtain ⟨⟨selected, selectedCache⟩, hselected, hrest⟩ := hresult + cases selected with + | none => simp at hrest + | some selected => + rcases selected with ⟨counter, encoding⟩ + simp only [StateT.run_bind, mem_support_bind_iff] at hrest + obtain ⟨⟨values, revealCache⟩, hvalues, hfinish⟩ := hrest + simp only [StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq, Option.some.injEq] at hfinish + rcases hfinish with ⟨rfl, rfl, rfl, rfl, rfl⟩ + exact ⟨selectedCache, hvalues⟩ + +theorem queryCache_sequenceFin_cache_mono {n : Nat} + (computation : Fin n → StateT (QueryCache HashSpec) ProbComp alpha) + (hcomponent : ∀ position initial final value, + (value, final) ∈ support ((computation position).run initial) → initial ≤ final) + (initial final : QueryCache HashSpec) (values : Fin n → alpha) + (hresult : (values, final) ∈ support ((sequenceFin computation).run initial)) : + initial ≤ final := by + induction n generalizing initial final with + | zero => + simp [sequenceFin] at hresult + exact hresult.2 ▸ le_rfl + | succ n ih => + rw [sequenceFin, StateT.run_bind, mem_support_bind_iff] at hresult + obtain ⟨⟨head, headCache⟩, hhead, hrest⟩ := hresult + rw [StateT.run_bind, mem_support_bind_iff] at hrest + obtain ⟨⟨tail, tailCache⟩, htail, hfinish⟩ := hrest + simp only [StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq] at hfinish + rcases hfinish with ⟨rfl, rfl⟩ + exact (hcomponent 0 initial headCache head hhead).trans + (ih (fun position => computation position.succ) + (fun position => hcomponent position.succ) headCache final tail htail) + +theorem queryCache_sequenceFin_component_support {n : Nat} + (computation : Fin n → StateT (QueryCache HashSpec) ProbComp alpha) + (hcomponent : ∀ position initial final value, + (value, final) ∈ support ((computation position).run initial) → initial ≤ final) + (initial final : QueryCache HashSpec) (values : Fin n → alpha) + (hresult : (values, final) ∈ support ((sequenceFin computation).run initial)) + (position : Fin n) : + ∃ componentInitial componentFinal componentValue, + (componentValue, componentFinal) ∈ support + ((computation position).run componentInitial) ∧ + values position = componentValue ∧ componentFinal ≤ final := by + induction n generalizing initial final with + | zero => exact position.elim0 + | succ n ih => + rw [sequenceFin, StateT.run_bind, mem_support_bind_iff] at hresult + obtain ⟨⟨head, headCache⟩, hhead, hrest⟩ := hresult + rw [StateT.run_bind, mem_support_bind_iff] at hrest + obtain ⟨⟨tail, tailCache⟩, htail, hfinish⟩ := hrest + simp only [StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq] at hfinish + rcases hfinish with ⟨rfl, rfl⟩ + cases position using Fin.cases with + | zero => + exact ⟨initial, headCache, head, hhead, rfl, + queryCache_sequenceFin_cache_mono + (fun tailPosition => computation tailPosition.succ) + (fun tailPosition => hcomponent tailPosition.succ) + headCache final tail htail⟩ + | succ tailPosition => + exact ih (fun position => computation position.succ) + (fun position => hcomponent position.succ) headCache final tail htail tailPosition + +theorem queryCache_sequenceFin_run_of_run_eq_pure {n : Nat} + (computation : Fin n → StateT (QueryCache HashSpec) ProbComp alpha) + (values : Fin n → alpha) (cache : QueryCache HashSpec) + (hrun : ∀ position, (computation position).run cache = pure (values position, cache)) : + (sequenceFin computation).run cache = pure (values, cache) := by + induction n with + | zero => + rw [sequenceFin, StateT.run_pure] + congr 2 + funext position + exact position.elim0 + | succ n ih => + rw [sequenceFin, StateT.run_bind, hrun 0, pure_bind, + StateT.run_bind, + ih (fun position => computation position.succ) + (fun position => values position.succ) + (fun position => hrun position.succ), + pure_bind, StateT.run_pure] + congr 2 + funext position + cases position using Fin.cases <;> rfl + +theorem sequenceFin_bind_pure_map {m : Type → Type} [Monad m] [LawfulMonad m] + {n : Nat} (computation : Fin n → m alpha) (transform : alpha → beta) : + (do + let values ← sequenceFin computation + pure (fun position => transform (values position))) = + sequenceFin (fun position => do + let value ← computation position + pure (transform value)) := by + induction n with + | zero => + simp only [sequenceFin, pure_bind] + congr + funext position + exact position.elim0 + | succ n ih => + rw [sequenceFin, sequenceFin] + simp only [bind_assoc, pure_bind] + apply bind_congr + intro head + rw [← ih (fun position => computation position.succ)] + simp only [bind_assoc, pure_bind] + apply bind_congr + intro tail + congr + funext position + cases position using Fin.cases <;> rfl + +theorem traverseOption_map {n : Nat} (family : Fin n → Option alpha) + (transform : alpha → beta) : + traverseOption (fun position => (family position).map transform) = + (traverseOption family).map + (fun values position => transform (values position)) := by + induction n with + | zero => + simp only [traverseOption, Option.map_some] + congr + funext position + exact position.elim0 + | succ n ih => + rw [traverseOption, traverseOption] + cases hhead : family 0 with + | none => simp + | some head => + cases htail : traverseOption (fun position : Fin n => family position.succ) with + | none => + have htailMap := ih (fun position : Fin n => family position.succ) + rw [htail] at htailMap + simp only [Option.map_none] at htailMap + simp [htailMap] + | some tail => + have htailMap := ih (fun position : Fin n => family position.succ) + rw [htail] at htailMap + simp only [Option.map_some] at htailMap + rw [htailMap] + simp only [Option.map_some] + congr + funext position + cases position using Fin.cases <;> rfl + +theorem resolvedChronologicalLayers_replay_of_mem_support + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (cache finalCache : QueryCache HashSpec) + (layers : Layer → Option ChronologicalLayerPart) + (parts : Layer → ChronologicalLayerPart) + (hresult : (layers, finalCache) ∈ support + ((sequenceFin fun lay => + resolvedChronologicalSignLayer parameter table ftsSecret index lay).run cache)) + (hparts : traverseOption layers = some parts) : + (sequenceFin fun lay => + resolvedRevealLayerValues parameter table index lay (parts lay).encoding).run finalCache = + pure ((fun lay => ((parts lay).chainValue, (parts lay).authPath)), finalCache) := by + have hrun : ∀ lay, + (resolvedRevealLayerValues parameter table index lay (parts lay).encoding).run finalCache = + pure (((parts lay).chainValue, (parts lay).authPath), finalCache) := by + intro lay + obtain ⟨componentInitial, componentFinal, componentValue, hcomponent, hvalue, hle⟩ := + queryCache_sequenceFin_component_support + (fun position => + resolvedChronologicalSignLayer parameter table ftsSecret index position) + (fun position initial final value hvalue => + resolvedChronologicalSignLayer_cache_mono parameter table ftsSecret index position + initial final value hvalue) + cache finalCache layers hresult lay + have hlayer : layers lay = some (parts lay) := + traverseOption_eq_some_apply layers parts hparts lay + have hcomponentValue : componentValue = some (parts lay) := hvalue.symm.trans hlayer + rw [hcomponentValue] at hcomponent + obtain ⟨selectedCache, hreveal⟩ := + resolvedChronologicalSignLayer_reveal_support parameter table ftsSecret index lay + componentInitial componentFinal (parts lay) hcomponent + exact resolvedRevealLayerValues_replay_of_mem_support_of_le parameter table index lay + (parts lay).encoding selectedCache componentFinal finalCache + ((parts lay).chainValue, (parts lay).authPath) hreveal hle + exact queryCache_sequenceFin_run_of_run_eq_pure _ _ finalCache hrun + +theorem reachableResolvedCouples_maskedChainValue + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) : + ReachableResolvedCouples parameter table (maskedChainValue lay tree leafIdx chainIdx digit) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (chainWalk parameter lay tree leafIdx chainIdx 0 digit.val + (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)))) := by + unfold maskedChainValue + by_cases hzero : digit.val = 0 + · rw [dif_pos hzero] + have hbase := (reachableResolvedCouples_of_administrative + (resolvedAdministrative_ensureChainPrefix lay tree leafIdx chainIdx digit) + (resolvedPreservesPublished_ensureChainPrefix lay tree leafIdx chainIdx digit)).bind fun _ => + reachableResolvedCouples_revealChainStart parameter table + ⟨lay, tree, leafIdx, chainIdx⟩ + simpa [hzero, chainWalk] using hbase + · rw [dif_neg hzero] + let step : ChainStep := ⟨digit.val - 1, by + have := digit.isLt + omega⟩ + have hsteps : step.val + 1 = digit.val := by + simp [step] + omega + have hbase := (reachableResolvedCouples_of_administrative + (resolvedAdministrative_ensureChainPrefix lay tree leafIdx chainIdx digit) + (resolvedPreservesPublished_ensureChainPrefix lay tree leafIdx chainIdx digit)).bind fun _ => + reachableResolvedCouples_revealResolvablePosition parameter table + (.chain lay tree leafIdx chainIdx step) (by simp [ResolvableOtsPosition]) + simpa [resolvedPositionComputation, step, hsteps] using hbase + +theorem reachableResolvedCouples_maskedTreeNode + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) + (hlevel : level ≤ maxLayerHeight) + (hspan : 2 ^ level * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight) : + ReachableResolvedCouples parameter table (maskedTreeNode lay tree level nodeIdx) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay tree + (fun leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + level nodeIdx)) := by + unfold maskedTreeNode + cases level with + | zero => + have hbase := (reachableResolvedCouples_of_administrative + (resolvedAdministrative_ensureTreeNode lay tree 0 nodeIdx) + (resolvedPreservesPublished_ensureTreeNode lay tree 0 nodeIdx)).bind fun _ => + reachableResolvedCouples_revealResolvablePosition parameter table + (.leaf lay tree (leafOfNat nodeIdx)) (by simp [ResolvableOtsPosition]) + simpa [resolvedPositionComputation, treeNode_zero_eq] using hbase + | succ current => + have hcurrent : current < maxLayerHeight := by omega + simp only [hcurrent, ↓reduceDIte] + have hnodeLt : nodeIdx < 2 ^ maxLayerHeight := by + have hpow : 0 < 2 ^ (current + 1) := pow_pos (by omega) _ + nlinarith + have hnodeVal : (leafOfNat nodeIdx).val = nodeIdx := by + simp [leafOfNat, Nat.mod_eq_of_lt hnodeLt] + have hresolvable : ResolvableOtsPosition + (.node lay tree ⟨current, hcurrent⟩ (leafOfNat nodeIdx)) := by + simp [ResolvableOtsPosition, hnodeVal] + exact hspan + have hbase := (reachableResolvedCouples_of_administrative + (resolvedAdministrative_ensureTreeNode lay tree (current + 1) nodeIdx) + (resolvedPreservesPublished_ensureTreeNode lay tree (current + 1) nodeIdx)).bind fun _ => + reachableResolvedCouples_revealResolvablePosition parameter table + (.node lay tree ⟨current, hcurrent⟩ (leafOfNat nodeIdx)) hresolvable + simpa [resolvedPositionComputation, hnodeVal] using hbase + +theorem reachableResolvedCouples_maskedTreeRoot + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (lay : Layer) (tree : TreeIndex) : + ReachableResolvedCouples parameter table (maskedTreeRoot lay tree) + (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter lay tree + (fun leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + (layerHeight lay) 0)) := by + unfold maskedTreeRoot + apply reachableResolvedCouples_maskedTreeNode parameter table lay tree (layerHeight lay) 0 + (layerHeight_le lay) + simpa using Nat.pow_le_pow_right (n := 2) (by omega) (layerHeight_le lay) + +theorem reachableResolvedCouples_maskedLayerMessage + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + ReachableResolvedCouples parameter table (maskedLayerMessage parameter ftsSecret index lay) + (resolvedLayerMessage parameter table ftsSecret index lay) := by + unfold maskedLayerMessage resolvedLayerMessage + split + · exact reachableResolvedCouples_maskedTreeRoot parameter table _ _ + · exact reachableResolvedCouples_ftsKey parameter table index (ftsSecret index) + +theorem reachableResolvedCouples_maskedSignLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + ReachableResolvedCouples parameter table (maskedSignLayer parameter ftsSecret index lay) + (resolvedSignLayer parameter table ftsSecret index lay) := by + unfold maskedSignLayer resolvedSignLayer + apply (reachableResolvedCouples_maskedLayerMessage parameter table ftsSecret index lay).bind + intro message + apply (reachableResolvedCouples_maskedOtsSign parameter table lay (treeIndexAt index lay) + (leafIndexAt index lay) message).bind + intro selected + cases selected with + | none => exact reachableResolvedCouples_pure parameter table none + | some part => + exact (reachableResolvedCouples_of_administrative + (resolvedAdministrative_ensureTreePath lay (treeIndexAt index lay) + (leafIndexAt index lay)) + (resolvedPreservesPublished_ensureTreePath lay (treeIndexAt index lay) + (leafIndexAt index lay))).bind fun _ => + reachableResolvedCouples_pure parameter table (some part) + +theorem reachableResolvedCouples_maskedChronologicalSignLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + ReachableResolvedCouples parameter table + (maskedChronologicalSignLayer parameter ftsSecret index lay) + (resolvedChronologicalSignLayer parameter table ftsSecret index lay) := by + unfold maskedChronologicalSignLayer resolvedChronologicalSignLayer + apply (reachableResolvedCouples_maskedSignLayer parameter table ftsSecret index lay).bind + intro selected + cases selected with + | none => exact reachableResolvedCouples_pure parameter table none + | some selected => + rcases selected with ⟨counter, encoding⟩ + apply (reachableResolvedCouples_revealPrivateLayerValues parameter table index lay + encoding).bind + intro values + exact reachableResolvedCouples_pure parameter table + (some (ChronologicalLayerPart.mk counter encoding values.1 values.2)) + +noncomputable def maskedPrivateImmediateSignLayer + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option LayerPart) := do + let result ← maskedChronologicalSignLayer parameter ftsSecret index lay + pure (result.map ChronologicalLayerPart.toLayerPart) + +theorem reachableResolvedCouples_maskedPrivateImmediateSignLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + ReachableResolvedCouples parameter table + (maskedPrivateImmediateSignLayer parameter ftsSecret index lay) + (resolvedImmediateSignLayer parameter table ftsSecret index lay) := by + unfold maskedPrivateImmediateSignLayer + rw [← resolvedChronologicalSignLayer_projects_to_immediate parameter table ftsSecret + index lay] + apply (reachableResolvedCouples_maskedChronologicalSignLayer parameter table ftsSecret index + lay).bind + intro result + exact reachableResolvedCouples_pure parameter table + (result.map ChronologicalLayerPart.toLayerPart) + +noncomputable def maskedPrivateImmediateSignAfterDigest + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature) := do + let ftsPath ← simulateQ ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index)) + let layers ← sequenceFin fun lay => + maskedPrivateImmediateSignLayer parameter ftsSecret index lay + match traverseOption layers with + | none => pure none + | some parts => + pure (some + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (parts lay).2.1 + authPath := flattenPaths fun lay => (parts lay).2.2 }) + +set_option maxHeartbeats 400000 in +theorem reachableResolvedCouples_maskedPrivateImmediateSignAfterDigest + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + ReachableResolvedCouples parameter table + (maskedPrivateImmediateSignAfterDigest parameter ftsSecret randomness index leaves) + (resolvedImmediateSignAfterDigest parameter table ftsSecret randomness index leaves) := by + unfold maskedPrivateImmediateSignAfterDigest resolvedImmediateSignAfterDigest + apply (reachableResolvedCouples_ftsOpen parameter table index leaves (ftsSecret index)).bind + intro ftsPath + apply (reachableResolvedCouples_sequenceFin _ _ fun lay => + reachableResolvedCouples_maskedPrivateImmediateSignLayer parameter table ftsSecret index + lay).bind + intro layers + cases hparts : traverseOption layers with + | none => exact reachableResolvedCouples_pure parameter table none + | some parts => + exact reachableResolvedCouples_pure parameter table (some (show Signature from + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (parts lay).2.1 + authPath := flattenPaths fun lay => (parts lay).2.2 })) + +theorem reachableResolvedCouples_maskedPrivateImmediateSignAfterDigest_concrete + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + ReachableResolvedCouples parameter table + (maskedPrivateImmediateSignAfterDigest parameter ftsSecret randomness index leaves) + (concreteSignAfterDigestFromTable parameter root table ftsSecret randomness index + leaves) := by + rw [← resolvedImmediateSignAfterDigest_eq_concrete parameter root table ftsSecret randomness + index leaves] + exact reachableResolvedCouples_maskedPrivateImmediateSignAfterDigest parameter table ftsSecret + randomness index leaves + +noncomputable def publishChronologicalSignature + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (layers : Layer → Option ChronologicalLayerPart) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature) := + match traverseOption layers with + | none => pure none + | some parts => do + let published ← sequenceFin fun lay => + revealLayerValues index lay (parts lay).encoding + pure (some + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).counter + chainValue := fun lay => (published lay).1 + authPath := flattenPaths fun lay => (published lay).2 }) + +noncomputable def maskedChronologicalSignLayers + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) + (Layer → Option ChronologicalLayerPart) := + sequenceFin fun lay => maskedChronologicalSignLayer parameter ftsSecret index lay + +noncomputable def maskedPublishedChronologicalSignAfterDigest + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature) := do + let ftsPath ← simulateQ ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index)) + let layers ← maskedChronologicalSignLayers parameter ftsSecret index + publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers + +theorem maskedPublishedChronologicalSignAfterDigest_eq + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves = + (do + let ftsPath ← simulateQ ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index)) + let layers ← maskedChronologicalSignLayers parameter ftsSecret index + publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers) := by + rfl + +noncomputable def resolvedPublishedChronologicalSignAfterDigest + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + StateT (QueryCache HashSpec) ProbComp (Option Signature) := do + let ftsPath ← simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsOpen parameter index leaves (ftsSecret index)) + let layers ← sequenceFin fun lay => + resolvedChronologicalSignLayer parameter table ftsSecret index lay + match traverseOption layers with + | none => pure none + | some parts => do + let published ← sequenceFin fun lay => + resolvedRevealLayerValues parameter table index lay (parts lay).encoding + pure (some + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).counter + chainValue := fun lay => (published lay).1 + authPath := flattenPaths fun lay => (published lay).2 }) + +noncomputable def resolvedProjectedChronologicalSignAfterDigest + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + StateT (QueryCache HashSpec) ProbComp (Option Signature) := do + let ftsPath ← simulateQ (randomOracle : QueryImpl HashSpec _) + (ftsOpen parameter index leaves (ftsSecret index)) + let layers ← do + let chronological ← sequenceFin fun lay => + resolvedChronologicalSignLayer parameter table ftsSecret index lay + pure (fun lay => (chronological lay).map ChronologicalLayerPart.toLayerPart) + match traverseOption layers with + | none => pure none + | some parts => + pure (some + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (parts lay).2.1 + authPath := flattenPaths fun lay => (parts lay).2.2 }) + +theorem resolvedProjectedChronologicalSignAfterDigest_eq_immediate + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + resolvedProjectedChronologicalSignAfterDigest parameter table ftsSecret randomness index + leaves = + resolvedImmediateSignAfterDigest parameter table ftsSecret randomness index leaves := by + unfold resolvedProjectedChronologicalSignAfterDigest resolvedImmediateSignAfterDigest + apply bind_congr + intro ftsPath + rw [← bind_assoc] + rw [sequenceFin_bind_pure_map + (fun lay => resolvedChronologicalSignLayer parameter table ftsSecret index lay) + (fun result => result.map ChronologicalLayerPart.toLayerPart)] + have hlayers : + (fun lay => do + let result ← resolvedChronologicalSignLayer parameter table ftsSecret index lay + pure (result.map ChronologicalLayerPart.toLayerPart)) = + (fun lay => resolvedImmediateSignLayer parameter table ftsSecret index lay) := by + funext lay + exact resolvedChronologicalSignLayer_projects_to_immediate parameter table ftsSecret index lay + rw [hlayers] + rfl + +theorem evalDist_resolvedPublishedChronologicalSignAfterDigest_eq_projected + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (cache : QueryCache HashSpec) : + 𝒟[(resolvedPublishedChronologicalSignAfterDigest parameter table ftsSecret randomness index + leaves).run cache] = + 𝒟[(resolvedProjectedChronologicalSignAfterDigest parameter table ftsSecret randomness index + leaves).run cache] := by + unfold resolvedPublishedChronologicalSignAfterDigest + resolvedProjectedChronologicalSignAfterDigest + simp only [StateT.run_bind, pure_bind] + apply evalDist_bind_congr + intro ftsResult hftsResult + rcases ftsResult with ⟨ftsPath, afterFtsCache⟩ + apply evalDist_bind_congr + intro layerResult hlayerResult + rcases layerResult with ⟨layers, finalCache⟩ + cases hparts : traverseOption layers with + | none => + rw [traverseOption_map layers ChronologicalLayerPart.toLayerPart, hparts] + rfl + | some parts => + rw [traverseOption_map layers ChronologicalLayerPart.toLayerPart, hparts] + simp only [Option.map_some] + rw [StateT.run_bind] + rw [resolvedChronologicalLayers_replay_of_mem_support parameter table ftsSecret index + afterFtsCache finalCache layers parts hlayerResult hparts] + rfl + +theorem evalDist_resolvedPublishedChronologicalSignAfterDigest_eq_immediate + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (cache : QueryCache HashSpec) : + 𝒟[(resolvedPublishedChronologicalSignAfterDigest parameter table ftsSecret randomness index + leaves).run cache] = + 𝒟[(resolvedImmediateSignAfterDigest parameter table ftsSecret randomness index leaves).run + cache] := by + rw [evalDist_resolvedPublishedChronologicalSignAfterDigest_eq_projected parameter table + ftsSecret randomness index leaves cache, + resolvedProjectedChronologicalSignAfterDigest_eq_immediate parameter table ftsSecret + randomness index leaves] + +set_option maxHeartbeats 400000 in +theorem reachableResolvedCouples_maskedPublishedChronologicalSignAfterDigest + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + ReachableResolvedCouples parameter table + (maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves) + (resolvedPublishedChronologicalSignAfterDigest parameter table ftsSecret randomness index + leaves) := by + unfold maskedPublishedChronologicalSignAfterDigest + maskedChronologicalSignLayers publishChronologicalSignature + resolvedPublishedChronologicalSignAfterDigest + apply (reachableResolvedCouples_ftsOpen parameter table index leaves (ftsSecret index)).bind + intro ftsPath + apply (reachableResolvedCouples_sequenceFin _ _ fun lay => + reachableResolvedCouples_maskedChronologicalSignLayer parameter table ftsSecret index + lay).bind + intro layers + cases hparts : traverseOption layers with + | none => exact reachableResolvedCouples_pure parameter table none + | some parts => + apply (reachableResolvedCouples_sequenceFin _ _ fun lay => + reachableResolvedCouples_resolvedRevealLayerValues parameter table index lay + (parts lay).encoding).bind + intro published + exact reachableResolvedCouples_pure parameter table (some (show Signature from + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).counter + chainValue := fun lay => (published lay).1 + authPath := flattenPaths fun lay => (published lay).2 })) + +theorem reachableResolvedCouples_maskedPublishedChronologicalSignAfterDigest_immediate + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + ReachableResolvedCouples parameter table + (maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves) + (resolvedImmediateSignAfterDigest parameter table ftsSecret randomness index leaves) := by + intro context fuel cache concreteCache hinvariant hclosed hpublished + apply relTriple_of_evalDist_eq_right + (evalDist_resolvedPublishedChronologicalSignAfterDigest_eq_immediate parameter table + ftsSecret randomness index leaves concreteCache) + exact reachableResolvedCouples_maskedPublishedChronologicalSignAfterDigest parameter table + ftsSecret randomness index leaves context fuel cache concreteCache hinvariant hclosed + hpublished + +theorem reachableResolvedCouples_maskedPublishedChronologicalSignAfterDigest_concrete + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + ReachableResolvedCouples parameter table + (maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves) + (concreteSignAfterDigestFromTable parameter root table ftsSecret randomness index + leaves) := by + rw [← resolvedImmediateSignAfterDigest_eq_concrete parameter root table ftsSecret randomness + index leaves] + exact reachableResolvedCouples_maskedPublishedChronologicalSignAfterDigest_immediate parameter + table ftsSecret randomness index leaves + +noncomputable def maskedPublishedChronologicalSign + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature) := do + let secretKey : SecretKey := + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ + match ← simulateQ ordinaryRomImpl + (signDigestLoop digestAttemptLimit secretKey message) with + | none => pure none + | some (randomness, index, leaves) => + maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves + +theorem revealPrivateLayerValues_probeFree (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + ProbeFree (revealPrivateLayerValues index lay encoding) := by + unfold revealPrivateLayerValues + apply (sequenceFin_probeFree _ fun chainIdx => + revealCoordinate_probeFree + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + (encoding chainIdx))).bind + intro values + apply (sequenceFin_probeFree _ fun level => by + by_cases hinLayer : level.val < layerHeight lay + · simp only [hinLayer, if_pos] + cases hvalue : level.val with + | zero => exact revealPosition_probeFree _ + | succ current => + by_cases hcurrent : current < maxLayerHeight + · simp only [hcurrent, dite_true] + exact revealPosition_probeFree _ + · simp only [hcurrent, dite_false] + exact ProbeFree.pure 0 + · simp only [hinLayer, if_false] + exact ProbeFree.pure 0).bind + intro path + exact ProbeFree.pure (values, path) + +theorem maskedChronologicalSignLayer_probeFree + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : ProbeFree + (maskedChronologicalSignLayer parameter ftsSecret index lay) := by + unfold maskedChronologicalSignLayer + exact (maskedSignLayer_probeFree parameter ftsSecret index lay).bind fun selected => by + cases selected with + | none => exact ProbeFree.pure none + | some selected => + rcases selected with ⟨counter, encoding⟩ + exact (revealPrivateLayerValues_probeFree index lay encoding).bind fun values => + ProbeFree.pure (some (show ChronologicalLayerPart from + ⟨counter, encoding, values.1, values.2⟩)) + +theorem maskedChronologicalSignLayers_probeFree + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) : + ProbeFree (maskedChronologicalSignLayers parameter ftsSecret index) := by + unfold maskedChronologicalSignLayers + exact sequenceFin_probeFree _ fun lay => + maskedChronologicalSignLayer_probeFree parameter ftsSecret index lay + +theorem publishChronologicalSignature_probeFree + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (layers : Layer → Option ChronologicalLayerPart) : + ProbeFree (alpha := Option Signature) + (publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers) := by + unfold publishChronologicalSignature + cases hparts : traverseOption layers with + | none => exact ProbeFree.pure none + | some parts => + have hpublished : ProbeFree (sequenceFin fun lay => + revealLayerValues index lay (parts lay).encoding) := + sequenceFin_probeFree _ fun lay => + revealLayerValues_probeFree index lay (parts lay).encoding + apply hpublished.bind + intro published + exact ProbeFree.pure (some (show Signature from + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).counter + chainValue := fun lay => (published lay).1 + authPath := flattenPaths fun lay => (published lay).2 })) + +set_option maxHeartbeats 2000000 in +theorem maskedPublishedChronologicalSignAfterDigest_probeFree + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + ProbeFree (alpha := Option Signature) + (maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves) := by + intro cache + rw [maskedPublishedChronologicalSignAfterDigest_eq, StateT.run_bind] + apply OracleComp.isQueryBoundP_bind (n := 0) (m := 0) + (simulateQ_ordinaryHashImpl_probeFree + (ftsOpen parameter index leaves (ftsSecret index)) cache) + intro ftsResult _ + rcases ftsResult with ⟨ftsPath, afterFtsCache⟩ + rw [StateT.run_bind] + apply OracleComp.isQueryBoundP_bind (n := 0) (m := 0) + (maskedChronologicalSignLayers_probeFree parameter ftsSecret index afterFtsCache) + intro layerResult _ + rcases layerResult with ⟨layers, afterLayersCache⟩ + exact publishChronologicalSignature_probeFree ftsSecret randomness index leaves ftsPath layers + afterLayersCache + +set_option maxHeartbeats 400000 in +theorem maskedPublishedChronologicalSign_probeFree + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + ProbeFree (alpha := Option Signature) + (maskedPublishedChronologicalSign parameter root ftsSecret message) := by + unfold maskedPublishedChronologicalSign + exact (simulateQ_ordinaryRomImpl_probeFree + (signDigestLoop digestAttemptLimit + (⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ : SecretKey) message)).bind + fun selected => by + cases selected with + | none => exact ProbeFree.pure none + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + exact maskedPublishedChronologicalSignAfterDigest_probeFree parameter ftsSecret + randomness index leaves + +set_option maxHeartbeats 400000 in +theorem reachableResolvedCouples_maskedPublishedChronologicalSign + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + ReachableResolvedCouples parameter table + (maskedPublishedChronologicalSign parameter root ftsSecret message) + (resolvedImmediateSign parameter root table ftsSecret message) := by + let maskedSecretKey : SecretKey := + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ + let concreteSecretKey : SecretKey := + ⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ + unfold maskedPublishedChronologicalSign resolvedImmediateSign + change ReachableResolvedCouples parameter table + (do + match ← simulateQ ordinaryRomImpl + (signDigestLoop digestAttemptLimit maskedSecretKey message) with + | none => pure none + | some (randomness, index, leaves) => + maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves) + (do + match ← simulateQ romImpl + (signDigestLoop digestAttemptLimit concreteSecretKey message) with + | none => pure none + | some (randomness, index, leaves) => + resolvedImmediateSignAfterDigest parameter table ftsSecret randomness index leaves) + rw [← signDigestLoop_eq_of_parameter_root maskedSecretKey concreteSecretKey rfl rfl message + digestAttemptLimit] + apply (reachableResolvedCouples_signDigestLoop table maskedSecretKey message + digestAttemptLimit).bind + intro selected + cases selected with + | none => exact reachableResolvedCouples_pure parameter table none + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + exact reachableResolvedCouples_maskedPublishedChronologicalSignAfterDigest_immediate + parameter table ftsSecret randomness index leaves + +theorem reachableResolvedCouples_maskedPublishedChronologicalSign_concrete + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + ReachableResolvedCouples parameter table + (maskedPublishedChronologicalSign parameter root ftsSecret message) + (simulateQ romImpl + (scheme.sign + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + message)) := by + rw [← resolvedImmediateSign_eq_concrete parameter root table ftsSecret message] + exact reachableResolvedCouples_maskedPublishedChronologicalSign parameter root table ftsSecret + message + +noncomputable def maskedChronologicalSigningImpl + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + QueryImpl SigningSpec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate))) := + fun message => maskedPublishedChronologicalSign parameter root ftsSecret message + +noncomputable def maskedChronologicalExpandedAdversaryImpl + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + QueryImpl (OracleWorld + SigningSpec) + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate))) := + probingRomImpl parameter + maskedChronologicalSigningImpl parameter root ftsSecret + +theorem maskedChronologicalExpandedAdversaryImpl_step_isProbeBound + (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (cache : SplitHashCache) : + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) + (if IsOuterHash input then 1 else 0) := by + cases input with + | inl worldInput => + cases worldInput with + | inl n => + simpa [maskedChronologicalExpandedAdversaryImpl, probingRomImpl, IsOuterHash] using + splitUniformImpl_probeFree n cache + | inr hashInput => + simpa [maskedChronologicalExpandedAdversaryImpl, probingRomImpl, probingHashImpl, + IsOuterHash] using probingHashQuery_run_isProbeBound parameter hashInput cache + | inr message => + simpa [maskedChronologicalExpandedAdversaryImpl, maskedChronologicalSigningImpl, + IsOuterHash] using + maskedPublishedChronologicalSign_probeFree parameter root ftsSecret message cache + +theorem reachableResolvedCouples_maskedChronologicalExpandedAdversaryImpl + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (query) : + ReachableResolvedCouples parameter table + (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret query) + (unloggedMappedAdversaryImpl + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey) + query) := by + cases query with + | inl oracleQuery => + cases oracleQuery with + | inl n => exact reachableResolvedCouples_splitUniform parameter table n + | inr input => exact reachableResolvedCouples_probingHashQuery parameter table input + | inr message => + exact reachableResolvedCouples_maskedPublishedChronologicalSign_concrete parameter root + table ftsSecret message + +theorem reachableResolvedCouples_chronologicalAdversaryPrefix + (adversary : Adversary) (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ReachableResolvedCouples parameter table + (simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩))) + (simulateQ + (unloggedMappedAdversaryImpl + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey)) + (signingTraceComputation (adversary.main ⟨root, parameter⟩))) := by + exact reachableResolvedCouples_simulateQ + (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (unloggedMappedAdversaryImpl + (⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ : SecretKey)) + (reachableResolvedCouples_maskedChronologicalExpandedAdversaryImpl parameter root table + ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) + +set_option maxRecDepth 100000 in +theorem relTriple_scheduleResolvedSignLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) : + RelTriple + (runResolvedFromTable context fuel table + ((maskedSignLayer parameter ftsSecret index lay).run cache) >>= + scheduleResolvedLayerResult index lay) + ((resolvedImmediateSignLayer parameter table ftsSecret index lay).run concreteCache) + (ReachableResolvedRunRel parameter table) := by + rw [resolvedImmediateSignLayer_eq_resolvedSignLayer_then_reveal, + StateT.run_bind] + have hselected := reachableResolvedCouples_maskedSignLayer parameter table ftsSecret index lay + context fuel cache concreteCache hinvariant hclosed hpublished + apply relTriple_bind hselected + intro leftResult rightResult hrelation + rcases rightResult with ⟨selected, selectedCache⟩ + simp only at hrelation ⊢ + cases leftResult with + | none => + cases selected with + | none => + simp [scheduleResolvedLayerResult] + trivial + | some selectedPart => + rcases selectedPart with ⟨counter, encoding⟩ + have hbase := relTriple_true (scheduleResolvedLayerResult index lay none) + ((do + let revealed ← resolvedRevealLayerValues parameter table index lay encoding + pure (some (counter, revealed.1, revealed.2))).run selectedCache) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = none) (by + intro result hresult + simpa [scheduleResolvedLayerResult] using hresult) + apply relTriple_post_mono hsupported + intro result _ hresult + rw [hresult.2] + trivial + | some result => + rcases hrelation with hclean | hdoomed + · rcases hclean with ⟨htable, hvalue, hresultInvariant, hresultClosed, + hresultPublished⟩ + have hcompletable : DeferredCompletable result.table result.context := by + rw [htable] + exact hresultInvariant.2.2.2.1 + have hcompletableTable : DeferredCompletable table result.context := + hresultInvariant.2.2.2.1 + cases selected with + | none => + have hselectedNone : result.value.1 = none := hvalue + simp [scheduleResolvedLayerResult, hcompletable, hselectedNone] + exact Or.inl ⟨htable, rfl, hresultInvariant, hresultClosed, hresultPublished⟩ + | some selectedPart => + rcases selectedPart with ⟨counter, encoding⟩ + have hselectedSome : result.value.1 = some (counter, encoding) := hvalue + rw [show scheduleResolvedLayerResult index lay (some result) = + (do + let resolved ← resolveDeferredLayerValues table index lay encoding + result.context + match resolved with + | none => pure none + | some (finalContext, values) => + pure (some ⟨finalContext, result.remaining, + (some (counter, values.1, values.2), result.value.2), table⟩)) by + simp [scheduleResolvedLayerResult, hcompletableTable, hselectedSome, htable]] + have hresolved := relTriple_resolveDeferredLayerValues_chronological parameter table + index lay encoding result.context (ordinaryQueryCache result.value.2) + selectedCache hresultInvariant + have hresolvedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolved + (fun resolved => resolved ∈ support + (resolveDeferredLayerValues table index lay encoding result.context)) + (fun resolved hresolved => hresolved) + have hresolvedBoth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hresolvedLeft + apply relTriple_bind hresolvedBoth + intro resolved revealResult hresolvedRelation + rcases revealResult with ⟨concreteValues, finalCache⟩ + rcases hresolvedRelation with + ⟨⟨hresolvedRelation, hleftSupport⟩, hrightSupport⟩ + cases resolved with + | none => + apply relTriple_pure_pure + trivial + | some resolved => + rcases resolved with ⟨finalContext, resolvedValues⟩ + rcases hresolvedRelation with ⟨hvalues, hfinalInvariant⟩ + have hprivate := privateStateAgrees_resolveDeferredLayerValues table index lay + encoding result.context finalContext resolvedValues hleftSupport + have hcacheLe := resolvedRevealLayerValues_cache_mono parameter table index lay + encoding selectedCache finalCache concreteValues hrightSupport + apply relTriple_pure_pure + refine Or.inl ⟨rfl, ?_, hfinalInvariant, + (hresultClosed.of_state_values_eq hprivate.1).mono hcacheLe, + hresultPublished.of_resolveDeferredLayerValues table index lay encoding + finalContext resolvedValues hleftSupport⟩ + rw [hvalues] + · have hnotCompletable : ¬DeferredCompletable result.table result.context := + by + rw [hdoomed.1] + exact hdoomed.2.2.2 + cases selected with + | none => + simp [scheduleResolvedLayerResult, hnotCompletable] + exact Or.inr hdoomed + | some selectedPart => + rcases selectedPart with ⟨counter, encoding⟩ + have hbase := relTriple_true + (scheduleResolvedLayerResult index lay (some result)) + ((do + let revealed ← resolvedRevealLayerValues parameter table index lay encoding + pure (some (counter, revealed.1, revealed.2))).run selectedCache) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun output => output = some ⟨result.context, result.remaining, + (none, result.value.2), result.table⟩) (by + intro output houtput + simpa [scheduleResolvedLayerResult, hnotCompletable] using houtput) + apply relTriple_post_mono hsupported + intro output _ houtput + rw [houtput.2] + exact Or.inr hdoomed + +noncomputable def runScheduledResolvedLayers + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) : + ∀ {n : Nat}, (Fin n → Layer) → DeferredContext → Nat → SplitHashCache → + ProbComp (Option (ResolvedRunResult + ((Fin n → Option LayerPart) × SplitHashCache))) + | 0, _, context, fuel, cache => + pure (some ⟨context, fuel, (Fin.elim0, cache), table⟩) + | n + 1, layers, context, fuel, cache => + @ite (ProbComp (Option (ResolvedRunResult + ((Fin (n + 1) → Option LayerPart) × SplitHashCache)))) + (DeferredCompletable table context) (Classical.propDecidable _) (do + let headResult ← + runResolvedFromTable context fuel table + ((maskedSignLayer parameter ftsSecret index (layers 0)).run cache) >>= + scheduleResolvedLayerResult index (layers 0) + match headResult with + | none => pure none + | some headResult => do + let tailResult ← runScheduledResolvedLayers parameter table ftsSecret index + (fun position : Fin n => layers position.succ) headResult.context + headResult.remaining headResult.value.2 + match tailResult with + | none => pure none + | some tailResult => + pure (some ⟨tailResult.context, tailResult.remaining, + (Fin.cases headResult.value.1 tailResult.value.1, + tailResult.value.2), tailResult.table⟩) + ) (pure (some ⟨context, fuel, (fun _ => none, cache), table⟩)) + +theorem runScheduledResolvedLayers_of_not_deferredCompletable + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + {n : Nat} (layers : Fin n → Layer) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) (hnotCompletable : ¬DeferredCompletable table context) : + runScheduledResolvedLayers parameter table ftsSecret index layers context fuel cache = + pure (some ⟨context, fuel, (fun _ => none, cache), table⟩) := by + cases n with + | zero => + simp only [runScheduledResolvedLayers] + congr + funext position + exact Fin.elim0 position + | succ n => + rw [runScheduledResolvedLayers] + simp [hnotCompletable] + +set_option maxRecDepth 100000 in +theorem relTriple_runScheduledResolvedLayers + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + {n : Nat} (layers : Fin n → Layer) (context : DeferredContext) (fuel : Nat) + (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context + (ordinaryQueryCache cache) concreteCache) + (hclosed : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) : + RelTriple + (runScheduledResolvedLayers parameter table ftsSecret index layers context fuel cache) + ((sequenceFin fun position => + resolvedImmediateSignLayer parameter table ftsSecret index (layers position)).run + concreteCache) + (ReachableResolvedRunRel parameter table) := by + induction n generalizing context fuel cache concreteCache with + | zero => + simp [runScheduledResolvedLayers, sequenceFin] + exact Or.inl ⟨rfl, rfl, hinvariant, hclosed, hpublished⟩ + | succ n ih => + have hcompletable : DeferredCompletable table context := hinvariant.2.2.2.1 + rw [runScheduledResolvedLayers, if_pos hcompletable, sequenceFin, StateT.run_bind] + have hhead := relTriple_scheduleResolvedSignLayer parameter table ftsSecret index + (layers 0) context fuel cache concreteCache hinvariant hclosed hpublished + apply relTriple_bind hhead + intro leftHead rightHead hheadRelation + cases leftHead with + | none => + have hbase := relTriple_true + (pure (none : Option (ResolvedRunResult + ((Fin (n + 1) → Option LayerPart) × SplitHashCache))) : + ProbComp (Option (ResolvedRunResult + ((Fin (n + 1) → Option LayerPart) × SplitHashCache)))) + ((do + let tail ← sequenceFin fun position : Fin n => + resolvedImmediateSignLayer parameter table ftsSecret index + (layers position.succ) + pure (Fin.cases rightHead.1 tail : Fin (n + 1) → Option LayerPart)).run + rightHead.2) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = none) (by simp) + apply relTriple_post_mono hsupported + intro result _ hresult + rw [hresult.2] + trivial + | some headResult => + rcases hheadRelation with hclean | hdoomed + · rcases hclean with ⟨htable, hvalue, hheadInvariant, hheadClosed, + hheadPublished⟩ + have htail := ih (fun position : Fin n => layers position.succ) + headResult.context headResult.remaining headResult.value.2 rightHead.2 + hheadInvariant hheadClosed hheadPublished + apply relTriple_bind htail + intro leftTail rightTail htailRelation + cases leftTail with + | none => + apply relTriple_pure_pure + trivial + | some tailResult => + rcases htailRelation with htailClean | htailDoomed + · apply relTriple_pure_pure + exact Or.inl ⟨htailClean.1, by + rw [htailClean.2.1, hvalue], htailClean.2.2.1, + htailClean.2.2.2.1, htailClean.2.2.2.2⟩ + · apply relTriple_pure_pure + exact Or.inr htailDoomed + · have hnotCompletable : ¬DeferredCompletable table headResult.context := by + exact hdoomed.2.2.2 + simp only + rw [runScheduledResolvedLayers_of_not_deferredCompletable parameter table ftsSecret + index (fun position : Fin n => layers position.succ) headResult.context + headResult.remaining headResult.value.2 hnotCompletable] + have hbase := relTriple_true + (pure (some ⟨headResult.context, headResult.remaining, + (Fin.cases headResult.value.1 (fun _ => none), headResult.value.2), table⟩) : + ProbComp (Option (ResolvedRunResult + ((Fin (n + 1) → Option LayerPart) × SplitHashCache)))) + ((do + let tail ← sequenceFin fun position : Fin n => + resolvedImmediateSignLayer parameter table ftsSecret index + (layers position.succ) + pure (Fin.cases rightHead.1 tail : Fin (n + 1) → Option LayerPart)).run + rightHead.2) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = some ⟨headResult.context, headResult.remaining, + (Fin.cases headResult.value.1 (fun _ => none), headResult.value.2), table⟩) + (by simp) + apply relTriple_post_mono hsupported + intro leftResult _ htailSupport + rw [htailSupport.2] + exact Or.inr ⟨rfl, hdoomed.2⟩ + +set_option maxHeartbeats 400000 in +theorem reachableResolvedCouples_maskedSignAfterDigest + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + ReachableResolvedCouples parameter table + (maskedSignAfterDigest parameter ftsSecret randomness index leaves) + (resolvedSignAfterDigest parameter table ftsSecret randomness index leaves) := by + unfold maskedSignAfterDigest resolvedSignAfterDigest + apply (reachableResolvedCouples_ftsOpen parameter table index leaves (ftsSecret index)).bind + intro ftsPath + apply (reachableResolvedCouples_sequenceFin _ _ fun lay => + reachableResolvedCouples_maskedSignLayer parameter table ftsSecret index lay).bind + intro layers + cases hparts : traverseOption layers with + | none => exact reachableResolvedCouples_pure parameter table none + | some parts => + apply (reachableResolvedCouples_sequenceFin _ _ fun lay => + reachableResolvedCouples_resolvedRevealLayerValues parameter table index lay + (parts lay).2).bind + intro revealed + let signature : Signature := + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (revealed lay).1 + authPath := flattenPaths fun lay => (revealed lay).2 } + exact reachableResolvedCouples_pure parameter table (some signature) + +set_option maxHeartbeats 400000 in +theorem reachableResolvedCouples_maskedSign + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + ReachableResolvedCouples parameter table (maskedSign parameter root ftsSecret message) + (resolvedSign parameter root table ftsSecret message) := by + unfold maskedSign resolvedSign + let secretKey : SecretKey := + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ + apply (reachableResolvedCouples_signDigestLoop table secretKey message digestAttemptLimit).bind + intro selected + cases selected with + | none => exact reachableResolvedCouples_pure parameter table none + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + exact reachableResolvedCouples_maskedSignAfterDigest parameter table ftsSecret randomness + index leaves + +noncomputable def resolvedSigningImpl + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + QueryImpl SigningSpec (StateT (QueryCache HashSpec) ProbComp) := + fun message => resolvedSign parameter root table ftsSecret message + +noncomputable def resolvedExpandedAdversaryImpl + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + QueryImpl (OracleWorld + SigningSpec) + (StateT (QueryCache HashSpec) ProbComp) := + romImpl + resolvedSigningImpl parameter root table ftsSecret + +theorem reachableResolvedCouples_maskedExpandedAdversaryImpl + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (query) : + ReachableResolvedCouples parameter table + (maskedExpandedAdversaryImpl parameter root ftsSecret query) + (resolvedExpandedAdversaryImpl parameter root table ftsSecret query) := by + cases query with + | inl oracleQuery => + cases oracleQuery with + | inl n => + exact reachableResolvedCouples_splitUniform parameter table n + | inr input => + exact reachableResolvedCouples_probingHashQuery parameter table input + | inr message => + exact reachableResolvedCouples_maskedSign parameter root table ftsSecret message + +theorem reachableResolvedCouples_adversaryPrefix + (adversary : Adversary) (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ReachableResolvedCouples parameter table + (simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩))) + (simulateQ (resolvedExpandedAdversaryImpl parameter root table ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩))) := by + exact reachableResolvedCouples_simulateQ + (maskedExpandedAdversaryImpl parameter root ftsSecret) + (resolvedExpandedAdversaryImpl parameter root table ftsSecret) + (reachableResolvedCouples_maskedExpandedAdversaryImpl parameter root table ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) + +noncomputable def maskedPublishedTreeRoot : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Digest := do + ensureTreeNode topLayer rootTree (layerHeight topLayer) 0 + revealPublishedCoordinate (.position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0)) + +theorem maskedPublishedTreeRoot_eq : + maskedPublishedTreeRoot = (do + let root ← maskedTreeRoot topLayer rootTree + publishCoordinate (.position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, + by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0)) + pure root) := by + unfold maskedPublishedTreeRoot maskedTreeRoot maskedTreeNode revealPublishedCoordinate + simp [revealPosition, layerHeight, topLayer, maxLayerHeight, leafOfNat] + all_goals rfl + +noncomputable def maskedRetainedPrefixAfterFtsSecrets + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) + (Digest × (Forgery × QueryLog SigningSpec)) := do + let root ← maskedPublishedTreeRoot + let forgeryLog ← + simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) + pure (root, forgeryLog) + +noncomputable def resolvedRetainedPrefixAfterFtsSecrets + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + StateT (QueryCache HashSpec) ProbComp + (Digest × (Forgery × QueryLog SigningSpec)) := do + let root ← simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter topLayer rootTree + (fun leafIdx chainIdx => + truncateHash (table ⟨topLayer, rootTree, leafIdx, chainIdx⟩)) + (layerHeight topLayer) 0) + let forgeryLog ← + simulateQ (resolvedExpandedAdversaryImpl parameter root table ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) + pure (root, forgeryLog) + +set_option maxRecDepth 100000 in +theorem reachableResolvedCouples_maskedPublishedTreeRoot + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) : + ReachableResolvedCouples parameter table + maskedPublishedTreeRoot + (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter topLayer rootTree + (fun leafIdx chainIdx => + truncateHash (table ⟨topLayer, rootTree, leafIdx, chainIdx⟩)) + (layerHeight topLayer) 0)) := by + unfold maskedPublishedTreeRoot + change ReachableResolvedCouples parameter table + (ensureTreeNode topLayer rootTree (layerHeight topLayer) 0 >>= fun _ => + revealPublishedCoordinate (.position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, + by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0))) + (pure () >>= fun _ => simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter topLayer rootTree + (fun leafIdx chainIdx => + truncateHash (table ⟨topLayer, rootTree, leafIdx, chainIdx⟩)) + (layerHeight topLayer) 0)) + apply (reachableResolvedCouples_of_administrative + (resolvedAdministrative_ensureTreeNode topLayer rootTree (layerHeight topLayer) 0) + (resolvedPreservesPublished_ensureTreeNode topLayer rootTree + (layerHeight topLayer) 0)).bind + intro _ + convert reachableResolvedCouples_revealPublishedTreeNode parameter table topLayer rootTree + (layerHeight topLayer) 0 (layerHeight_le topLayer) (by norm_num [layerHeight, topLayer]) using 1 + all_goals simp [layerHeight, topLayer, maxLayerHeight, leafOfNat, revealPublishedCoordinate] + all_goals rfl + +noncomputable def maskedChronologicalRetainedPrefixAfterFtsSecrets + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) + (Digest × (Forgery × QueryLog SigningSpec)) := do + let root ← maskedPublishedTreeRoot + let forgeryLog ← + simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) + pure (root, forgeryLog) + +noncomputable def concreteRetainedPrefixAfterFtsSecrets + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + StateT (QueryCache HashSpec) ProbComp + (Digest × (Forgery × QueryLog SigningSpec)) := do + let root ← simulateQ (randomOracle : QueryImpl HashSpec _) + (treeNode parameter topLayer rootTree + (fun leafIdx chainIdx => + truncateHash (table ⟨topLayer, rootTree, leafIdx, chainIdx⟩)) + (layerHeight topLayer) 0) + let secretKey : SecretKey := + ⟨parameter, root, + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ftsSecret⟩ + let forgeryLog ← + simulateQ (unloggedMappedAdversaryImpl secretKey) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) + pure (root, forgeryLog) + +set_option maxRecDepth 100000 in +theorem reachableResolvedCouples_chronologicalRetainedPrefixAfterFtsSecrets + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ReachableResolvedCouples parameter table + (maskedChronologicalRetainedPrefixAfterFtsSecrets adversary parameter ftsSecret) + (concreteRetainedPrefixAfterFtsSecrets adversary parameter table ftsSecret) := by + unfold maskedChronologicalRetainedPrefixAfterFtsSecrets + concreteRetainedPrefixAfterFtsSecrets + apply (reachableResolvedCouples_maskedPublishedTreeRoot parameter table).bind + intro root + apply (reachableResolvedCouples_chronologicalAdversaryPrefix adversary parameter root table + ftsSecret).bind + intro forgeryLog + exact reachableResolvedCouples_pure parameter table (root, forgeryLog) + +set_option maxRecDepth 100000 in +theorem reachableResolvedCouples_retainedPrefixAfterFtsSecrets + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ReachableResolvedCouples parameter table + (maskedRetainedPrefixAfterFtsSecrets adversary parameter ftsSecret) + (resolvedRetainedPrefixAfterFtsSecrets adversary parameter table ftsSecret) := by + unfold maskedRetainedPrefixAfterFtsSecrets resolvedRetainedPrefixAfterFtsSecrets + apply (reachableResolvedCouples_maskedPublishedTreeRoot parameter table).bind + intro root + apply (reachableResolvedCouples_adversaryPrefix adversary parameter root table ftsSecret).bind + intro forgeryLog + exact reachableResolvedCouples_pure parameter table (root, forgeryLog) + +theorem reachableResolvedCouples_probingRomImpl + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (query) : + ReachableResolvedCouples parameter table (probingRomImpl parameter query) + (romImpl query) := by + cases query with + | inl n => exact reachableResolvedCouples_splitUniform parameter table n + | inr input => exact reachableResolvedCouples_probingHashQuery parameter table input + +theorem reachableResolvedCouples_probingRom + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (computation : OracleComp OracleWorld alpha) : + ReachableResolvedCouples parameter table + (simulateQ (probingRomImpl parameter) computation) + (simulateQ romImpl computation) := + reachableResolvedCouples_simulateQ (probingRomImpl parameter) romImpl + (reachableResolvedCouples_probingRomImpl parameter table) computation + +noncomputable def maskedChronologicalRetainedGameAfterFtsSecrets + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) RetainedGameResult := do + let (root, forgery, log) ← + maskedChronologicalRetainedPrefixAfterFtsSecrets adversary parameter ftsSecret + let verified ← simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature) + pure (root, ((forgery, log), verified)) + +noncomputable def concreteRetainedGameAfterFtsSecrets + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + StateT (QueryCache HashSpec) ProbComp RetainedGameResult := do + let (root, forgery, log) ← + concreteRetainedPrefixAfterFtsSecrets adversary parameter table ftsSecret + let verified ← simulateQ romImpl + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature) + pure (root, ((forgery, log), verified)) + +theorem reachableResolvedCouples_chronologicalRetainedGameAfterFtsSecrets + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ReachableResolvedCouples parameter table + (maskedChronologicalRetainedGameAfterFtsSecrets adversary parameter ftsSecret) + (concreteRetainedGameAfterFtsSecrets adversary parameter table ftsSecret) := by + unfold maskedChronologicalRetainedGameAfterFtsSecrets + concreteRetainedGameAfterFtsSecrets + apply (reachableResolvedCouples_chronologicalRetainedPrefixAfterFtsSecrets adversary parameter + table ftsSecret).bind + intro result + rcases result with ⟨root, forgery, log⟩ + apply (reachableResolvedCouples_probingRom parameter table + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).bind + intro verified + exact reachableResolvedCouples_pure parameter table (root, ((forgery, log), verified)) + +theorem concreteRetainedGameAfterFtsSecrets_run_eq_actual + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + (concreteRetainedGameAfterFtsSecrets adversary parameter table ftsSecret).run ∅ = + actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table) := by + unfold actualRetainedGameAfterTable + simp_rw [simulateQ_unloggedMapped_retainedGameRestComputation] + unfold concreteRetainedGameAfterFtsSecrets concreteRetainedPrefixAfterFtsSecrets treeRoot + rw [show tableOtsSecret (extendStartTable table) = + fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩) from rfl] + simp only [StateT.run_bind, StateT.run_pure, bind_assoc, pure_bind] + +noncomputable def maskedResolvedRetainedGameAfterFtsSecrets + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) RetainedGameResult := do + let (root, forgery, log) ← + maskedRetainedPrefixAfterFtsSecrets adversary parameter ftsSecret + let verified ← simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature) + pure (root, ((forgery, log), verified)) + +noncomputable def resolvedRetainedGameAfterFtsSecrets + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + StateT (QueryCache HashSpec) ProbComp RetainedGameResult := do + let (root, forgery, log) ← + resolvedRetainedPrefixAfterFtsSecrets adversary parameter table ftsSecret + let verified ← simulateQ romImpl + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature) + pure (root, ((forgery, log), verified)) + +theorem reachableResolvedCouples_retainedGameAfterFtsSecrets + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ReachableResolvedCouples parameter table + (maskedResolvedRetainedGameAfterFtsSecrets adversary parameter ftsSecret) + (resolvedRetainedGameAfterFtsSecrets adversary parameter table ftsSecret) := by + unfold maskedResolvedRetainedGameAfterFtsSecrets resolvedRetainedGameAfterFtsSecrets + apply (reachableResolvedCouples_retainedPrefixAfterFtsSecrets adversary parameter table + ftsSecret).bind + intro result + rcases result with ⟨root, forgery, log⟩ + apply (reachableResolvedCouples_probingRom parameter table + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).bind + intro verified + exact reachableResolvedCouples_pure parameter table (root, ((forgery, log), verified)) + +theorem resolvedContextInvariant_empty + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) : + ResolvedContextInvariant parameter table + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + (∅ : QueryCache HashSpec) ∅ := + ⟨chronologicalCacheAgrees_empty parameter table, DeferredContext.valid_empty, + startTableAgrees_empty table, deferredCompletable_empty table, + resolvedCachePartition_empty parameter table⟩ + +theorem publishedValues_empty : + PublishedValues (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) := by + simp [PublishedValues, LazyRevealProbe.State.empty] + +theorem relTriple_runResolvedFromTable_maskedChronologicalRetainedGame + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + RelTriple + (runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table + ((maskedChronologicalRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache)) + (actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table)) + (ReachableResolvedRunRel parameter table) := by + rw [← concreteRetainedGameAfterFtsSecrets_run_eq_actual adversary parameter table ftsSecret] + have hempty : ordinaryQueryCache emptySplitHashCache = (∅ : QueryCache HashSpec) := by + rfl + apply reachableResolvedCouples_chronologicalRetainedGameAfterFtsSecrets adversary parameter + table ftsSecret + · rw [hempty] + exact resolvedContextInvariant_empty parameter table + · exact visibleResolvedComputationsCached_empty parameter table + emptyDeferredStructuralValues ∅ + · exact publishedValues_empty + +theorem relTriple_runResolvedFromTable_maskedResolvedRetainedGame + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + RelTriple + (runResolvedFromTable + { state := (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + values := emptyDeferredStructuralValues } + fuel table + ((maskedResolvedRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run + emptySplitHashCache)) + ((resolvedRetainedGameAfterFtsSecrets adversary parameter table ftsSecret).run ∅) + (ReachableResolvedRunRel parameter table) := by + have hempty : ordinaryQueryCache emptySplitHashCache = (∅ : QueryCache HashSpec) := by + rfl + apply reachableResolvedCouples_retainedGameAfterFtsSecrets adversary parameter table ftsSecret + · rw [hempty] + exact resolvedContextInvariant_empty parameter table + · exact visibleResolvedComputationsCached_empty parameter table + emptyDeferredStructuralValues ∅ + · exact publishedValues_empty + +theorem maskedChronologicalRetainedGameRest_run_isProbeBound + (adversary : Adversary) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash q) (cache : SplitHashCache) : + ((do + let (forgery, log) ← + simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) + let verified ← simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature) + pure ((forgery, log), verified)).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) q := by + let adversaryPrefix := signingTraceComputation + (adversary.main (⟨root, parameter⟩ : PublicKey)) + let finish : (Forgery × QueryLog SigningSpec) → + OracleComp (OracleWorld + SigningSpec) RetainedRestResult := fun result => do + let verified ← liftOracleWorldLeft + (scheme.verify ⟨root, parameter⟩ result.1.message result.1.signature) + pure (result, verified) + have hsource : (adversaryPrefix >>= finish).IsQueryBoundP IsOuterHash q := by + simpa [adversaryPrefix, finish, retainedGameRestComputation] using hbound + have hmixed := isQueryBoundP_simulateQ_run_StateT_then_of_steps + (leftImpl := maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + (rightImpl := maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) + hsource + (maskedChronologicalExpandedAdversaryImpl_step_isProbeBound parameter root ftsSecret) + (maskedChronologicalExpandedAdversaryImpl_step_isProbeBound parameter root ftsSecret) cache + simpa [adversaryPrefix, finish, maskedChronologicalExpandedAdversaryImpl, simulateQ_bind, + simulateQ_liftOracleWorldLeft, StateT.run_bind] using hmixed + +theorem maskedResolvedRetainedGameRest_run_isProbeBound + (adversary : Adversary) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash q) (cache : SplitHashCache) : + ((do + let (forgery, log) ← + simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) + let verified ← simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature) + pure ((forgery, log), verified)).run cache).IsQueryBoundP + (LazyRevealProbe.IsProbe (Coordinate := Coordinate)) q := by + let adversaryPrefix := signingTraceComputation + (adversary.main (⟨root, parameter⟩ : PublicKey)) + let finish : (Forgery × QueryLog SigningSpec) → + OracleComp (OracleWorld + SigningSpec) RetainedRestResult := fun result => do + let verified ← liftOracleWorldLeft + (scheme.verify ⟨root, parameter⟩ result.1.message result.1.signature) + pure (result, verified) + have hsource : (adversaryPrefix >>= finish).IsQueryBoundP IsOuterHash q := by + simpa [adversaryPrefix, finish, retainedGameRestComputation] using hbound + have hmixed := isQueryBoundP_simulateQ_run_StateT_then_of_steps + (leftImpl := maskedExpandedAdversaryImpl parameter root ftsSecret) + (rightImpl := maskedExpandedAdversaryImpl parameter root ftsSecret) + hsource + (maskedExpandedAdversaryImpl_step_isProbeBound parameter root ftsSecret) + (maskedExpandedAdversaryImpl_step_isProbeBound parameter root ftsSecret) cache + simpa [adversaryPrefix, finish, maskedExpandedAdversaryImpl, simulateQ_bind, + simulateQ_liftOracleWorldLeft, StateT.run_bind] using hmixed + +def DeferredFreshOn (coordinates : List Coordinate) (context : DeferredContext) : Prop := + ∀ position : Position, Coordinate.position position ∈ coordinates → + context.values position = none + +theorem finalizeResolvedCoordinates_projects_to_clean + (coordinates : List Coordinate) (context : DeferredContext) + (table : OtsSecretIndex → HashOutput) + (hnodup : coordinates.Nodup) (hfresh : DeferredFreshOn coordinates context) : + (fun result => result.map fun finalContext => (finalContext.state, table)) <$> + finalizeResolvedCoordinates coordinates context table = + finalizeCleanFromTable coordinates context.state table := by + induction coordinates generalizing context with + | nil => simp [finalizeResolvedCoordinates, finalizeCleanFromTable] + | cons coordinate remaining ih => + obtain ⟨hnotMem, htailNodup⟩ := List.nodup_cons.mp hnodup + cases hstate : context.state.values coordinate with + | some output => + rw [finalizeResolvedCoordinates, finalizeCleanFromTable.eq_def] + simp only [hstate] + apply ih { context with state := context.state.clearPending coordinate } + htailNodup + intro position hmem + exact hfresh position (List.mem_cons_of_mem coordinate hmem) + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + have hstate' : context.state.values index.coordinate = none := by + simpa [index, OtsSecretIndex.coordinate] using hstate + rw [finalizeResolvedCoordinates, finalizeCleanFromTable.eq_def] + simp only [hstate] + rw [resolveDeferredChainStart_of_missing table index context hstate'] + by_cases hhit : context.state.hitAt + (.chainStart lay tree leafIdx chainIdx) (table index) + · simp [index, OtsSecretIndex.coordinate, hhit] + · simp only [index, OtsSecretIndex.coordinate, hhit, ↓reduceIte, + map_eq_bind_pure_comp, pure_bind] + rw [clearPending_complete_self] + simpa only [map_eq_bind_pure_comp] using ih + { state := context.state.complete (.chainStart lay tree leafIdx chainIdx) + (table index) + values := context.values } + htailNodup (by + intro position hmem + exact hfresh position (List.mem_cons_of_mem _ hmem)) + | position position => + have hvalue : context.values position = none := + hfresh position (by simp) + rw [finalizeResolvedCoordinates, finalizeCleanFromTable.eq_def] + simp only [hstate] + rw [resolveDeferredPositionValue_fresh position context hstate hvalue] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro output + by_cases hhit : context.state.hitAt (.position position) output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + simp only [pure_bind] + rw [clearPending_complete_self] + simpa only [map_eq_bind_pure_comp] using ih + { state := context.state.complete (.position position) output + values := context.values.install position output } + htailNodup (by + intro other hmem + have hne : other ≠ position := by + intro heq + subst other + exact hnotMem hmem + simp [DeferredStructuralValues.install, hne, + hfresh other (List.mem_cons_of_mem _ hmem)]) + +theorem finalizeResolvedCoordinates_empty_projects_to_clean + (coordinates : List Coordinate) (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (hnodup : coordinates.Nodup) : + (fun result => result.map fun finalContext => (finalContext.state, table)) <$> + finalizeResolvedCoordinates coordinates + { state := state, values := emptyDeferredStructuralValues } table = + finalizeCleanFromTable coordinates state table := by + apply finalizeResolvedCoordinates_projects_to_clean coordinates + { state := state, values := emptyDeferredStructuralValues } table hnodup + intro position hmem + rfl + +theorem finalizeResolvedCoordinates_empty_finset_projects_to_clean + (coordinates : Finset Coordinate) (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) : + (fun result => result.map fun finalContext => (finalContext.state, table)) <$> + finalizeResolvedCoordinates coordinates.toList + { state := state, values := emptyDeferredStructuralValues } table = + finalizeCleanFromTable coordinates.toList state table := + finalizeResolvedCoordinates_empty_projects_to_clean coordinates.toList state table + coordinates.nodup_toList + +noncomputable def finishResolvedRun : + Option (ResolvedRunResult alpha) → ProbComp (Option (ResolvedRunResult alpha)) := by + classical + intro input + cases input with + | none => exact pure none + | some result => + exact if DeferredCompletable result.table result.context then do + let finalized ← finalizeResolvedCoordinates result.context.state.coordinates.toList + result.context result.table + match finalized with + | none => pure none + | some context => pure (some ⟨context, result.remaining, result.value, result.table⟩) + else pure none + +theorem finishResolvedRun_of_not_deferredCompletable + (result : ResolvedRunResult alpha) + (hdoomed : ¬DeferredCompletable result.table result.context) : + finishResolvedRun (some result) = pure none := by + simp [finishResolvedRun, hdoomed] + +def projectResolvedRunResult : + Option (ResolvedRunResult alpha) → Option (CleanRunResult alpha) + | none => none + | some result => some ⟨result.context.state, result.remaining, result.value, result.table⟩ + +theorem finishResolvedRun_empty_projects_to_clean + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (value : alpha) (table : OtsSecretIndex → HashOutput) + (hcompletable : DeferredCompletable table + { state := state, values := emptyDeferredStructuralValues }) : + projectResolvedRunResult <$> + finishResolvedRun (some ⟨ + { state := state, values := emptyDeferredStructuralValues }, + fuel, value, table⟩) = + finishCleanRunFromTable (some ⟨state, fuel, value, table⟩) := by + simp only [finishResolvedRun, hcompletable, ↓reduceIte, finishCleanRunFromTable] + rw [← finalizeResolvedCoordinates_empty_finset_projects_to_clean + state.coordinates state table] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro finalized + cases finalized <;> simp [projectResolvedRunResult] + +theorem DeferredCompletion.not_probeHits_of_pending + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {completion : Coordinate → HashOutput} + (hcompletion : DeferredCompletion table context completion) + (f : QueryImpl HashSpec Id) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (probe : Probe) (input : HashInput) + (hmatches : probe.MatchesInput parameter input) + (hpending : (probe.coordinate, probe.candidate) ∈ context.state.pending) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter completion (.position position)) = + completion (.position position)) : + ¬probe.Hits f parameter (tableOtsSecret completion) ftsSecret := by + intro hhits + have hchain := probe.isChainCoordinate_of_matchesInput hmatches + have htarget := probe.target_eq_truncate_table_of_chain f parameter completion ftsSecret + hchain hrealizes + have havoids := hcompletion.2.2.1 probe.coordinate probe.candidate hpending + apply havoids + rw [← htarget] + exact hhits.symm + +theorem DeferredCompletion.not_probeHits_tableAnswer_of_pending + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {completion : Coordinate → HashOutput} + (hcompletion : DeferredCompletion table context completion) + (fallback : QueryImpl HashSpec Id) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (probe : Probe) (input : HashInput) + (hmatches : probe.MatchesInput parameter input) + (hpending : (probe.coordinate, probe.candidate) ∈ context.state.pending) : + ¬probe.Hits (tableAnswer parameter completion fallback) parameter + (tableOtsSecret completion) ftsSecret := by + apply hcompletion.not_probeHits_of_pending + (tableAnswer parameter completion fallback) ftsSecret probe input hmatches hpending + exact tableAnswer_realizes_otsPositions parameter completion fallback + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedSchedule.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedSchedule.lean new file mode 100644 index 00000000..2f3966d3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedSchedule.lean @@ -0,0 +1,2644 @@ +import SphincsSecurity.Proof.OtsProbeResolvedSampling + +/-! +# Concrete one-time layer scheduling + +The chronological signer resolves a selected layer before selecting the next one. The ordinary +signer selects all three layers first. This file permutes those operations without changing their +joint distribution. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp +open OracleComp.ProgramLogic.Relational + +abbrev DeferredLayerEncoding := Counter × (ChainIndex → Digit) + +structure DeferredLayerStore where + selected : Layer → Option DeferredLayerEncoding + resolved : Layer → Option LayerPart + cache : SplitHashCache + +def emptyDeferredLayerStore (cache : SplitHashCache) : DeferredLayerStore := + { selected := fun _ => none + resolved := fun _ => none + cache := cache } + +def projectDeferredLayerStore + (result : ResolvedRunResult DeferredLayerStore) : + ResolvedRunResult ((Layer → Option LayerPart) × SplitHashCache) := + { result with value := (result.value.resolved, result.value.cache) } + +theorem DeferredCompletion.materializeResolvedPosition + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} (position : Position) + (result : DeferredResolution) + (hstateValues : result.state.values = context.state.values) + (hpending : result.state.pending = + context.state.pendingAway (.position position)) + (hresolved : result.toDeferredContext.positionValue position = some result.output) + (hcompletion : DeferredCompletion table result.toDeferredContext completion) : + DeferredCompletion table + (materializeResolvedPosition context position result) completion := by + refine ⟨?_, hcompletion.2.1, ?_, hcompletion.2.2.2⟩ + · intro coordinate output hvalue + by_cases heq : coordinate = .position position + · subst coordinate + change (context.state.materialize (.position position) result.output).values + (.position position) = some output at hvalue + have hsame : result.output = output := by + exact Option.some.inj (by simpa [LazyRevealProbe.State.materialize] using hvalue) + rw [← hsame] + exact hcompletion.eq_positionValue position result.output hresolved + · apply hcompletion.1 coordinate output + rw [hstateValues] + change (context.state.materialize (.position position) result.output).values + coordinate = some output at hvalue + simpa [LazyRevealProbe.State.materialize, Function.update_of_ne heq] using hvalue + · intro coordinate candidate hmember + apply hcompletion.2.2.1 coordinate candidate + rw [hpending] + change (coordinate, candidate) ∈ + (context.state.materialize (.position position) result.output).pending at hmember + simpa [LazyRevealProbe.State.materialize] using hmember + +theorem deferredCompletion_materializeResolvedPosition_iff + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} (position : Position) + (result : DeferredResolution) + (hstateValues : result.state.values = context.state.values) + (hpending : result.state.pending = + context.state.pendingAway (.position position)) + (hresolved : result.toDeferredContext.positionValue position = some result.output) : + DeferredCompletion table + (materializeResolvedPosition context position result) completion ↔ + DeferredCompletion table result.toDeferredContext completion := by + constructor + · exact fun hcompletion => hcompletion.of_materializeResolvedPosition position result + hstateValues (by rw [hpending]) hresolved + · exact fun hcompletion => hcompletion.materializeResolvedPosition position result + hstateValues hpending hresolved + +theorem deferredCompletion_materializeResolvedChainStart_iff + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} (index : OtsSecretIndex) + (result : DeferredResolution) + (hstarts : StartTableAgrees context.state table) + (houtput : result.output = table index) + (hstateValues : result.state.values = context.state.values) + (hdeferredValues : result.values = context.values) + (hpending : result.state.pending = context.state.pendingAway index.coordinate) : + DeferredCompletion table + (materializeResolvedChainStart context index result) completion ↔ + DeferredCompletion table result.toDeferredContext completion := by + constructor + · intro hcompletion + refine ⟨?_, ?_, ?_, hcompletion.2.2.2⟩ + · intro coordinate output hvalue + rw [hstateValues] at hvalue + by_cases heq : coordinate = index.coordinate + · subst coordinate + have hcompletionTable := hcompletion.2.2.2 index + have hsame : output = table index := hstarts index output hvalue + rw [hsame] + exact hcompletionTable + · apply hcompletion.1 coordinate output + simpa [materializeResolvedChainStart, LazyRevealProbe.State.materialize, + Function.update_of_ne heq] using hvalue + · intro position output hvalue + apply hcompletion.2.1 position output + simpa [materializeResolvedChainStart, hdeferredValues] using hvalue + · intro coordinate candidate hmember + apply hcompletion.2.2.1 coordinate candidate + rw [hpending] at hmember + simpa [materializeResolvedChainStart, LazyRevealProbe.State.materialize] using hmember + · intro hcompletion + refine ⟨?_, ?_, ?_, hcompletion.2.2.2⟩ + · intro coordinate output hvalue + by_cases heq : coordinate = index.coordinate + · subst coordinate + have hsame : output = result.output := by + change (context.state.materialize index.coordinate result.output).values + index.coordinate = some output at hvalue + exact (Option.some.inj (by + simpa [LazyRevealProbe.State.materialize] using hvalue)).symm + rw [hsame, houtput] + exact hcompletion.2.2.2 index + · apply hcompletion.1 coordinate output + rw [hstateValues] + change (context.state.materialize index.coordinate result.output).values coordinate = + some output at hvalue + simpa [LazyRevealProbe.State.materialize, Function.update_of_ne heq] using hvalue + · intro position output hvalue + apply hcompletion.2.1 position output + simpa [materializeResolvedChainStart, hdeferredValues] using hvalue + · intro coordinate candidate hmember + apply hcompletion.2.2.1 coordinate candidate + rw [hpending] + change (coordinate, candidate) ∈ + (context.state.materialize index.coordinate result.output).pending at hmember + simpa [LazyRevealProbe.State.materialize] using hmember + +theorem deferredCompletion_materializeResolvedReveal_iff + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} (position : Position) + (result : DeferredResolution) (hvalid : context.Valid) + (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (resolveDeferredReveal table position context)) : + DeferredCompletion table + (materializeResolvedPosition context position result) completion ↔ + DeferredCompletion table result.toDeferredContext completion := by + have hstateValues := resolveDeferredReveal_preserves_state_values table position context result + hresult + have hpending := resolveDeferredReveal_pendingAway_subset table position context result hresult + have hresolved := resolveDeferredReveal_resolves table position context result hresult + constructor + · exact fun hcompletion => hcompletion.of_materializeResolvedPosition position result + hstateValues hpending hresolved + · intro hcompletion + have hbase := hcompletion.of_resolveDeferredReveal hvalid.valuesConsistent hstarts position + result hresult + refine ⟨?_, hcompletion.2.1, ?_, hcompletion.2.2.2⟩ + · intro coordinate output hvalue + by_cases heq : coordinate = .position position + · subst coordinate + change (context.state.materialize (.position position) result.output).values + (.position position) = some output at hvalue + have hsame : output = result.output := by + exact (Option.some.inj (by + simpa [LazyRevealProbe.State.materialize] using hvalue)).symm + rw [hsame] + exact hcompletion.eq_positionValue position result.output hresolved + · apply hbase.1 coordinate output + change (context.state.materialize (.position position) result.output).values + coordinate = some output at hvalue + simpa [LazyRevealProbe.State.materialize, Function.update_of_ne heq] using hvalue + · intro coordinate candidate hmember + apply hbase.2.2.1 coordinate candidate + change (coordinate, candidate) ∈ + (context.state.materialize (.position position) result.output).pending at hmember + have haway : (coordinate, candidate) ∈ + context.state.pendingAway (.position position) := by + simpa [LazyRevealProbe.State.materialize] using hmember + exact (Finset.mem_filter.1 haway).1 + +def resolvedCompletionValue (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) : Coordinate → Option HashOutput + | .chainStart lay tree leafIdx chainIdx => some (table ⟨lay, tree, leafIdx, chainIdx⟩) + | .position position => context.positionValue position + +theorem DeferredCompletion.eq_resolvedCompletionValue + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + {completion : Coordinate → HashOutput} + (hcompletion : DeferredCompletion table context completion) + (coordinate : Coordinate) (output : HashOutput) + (hvalue : resolvedCompletionValue table context coordinate = some output) : + completion coordinate = output := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + have houtput : output = table ⟨lay, tree, leafIdx, chainIdx⟩ := by + simpa [resolvedCompletionValue] using hvalue.symm + rw [houtput] + exact hcompletion.2.2.2 ⟨lay, tree, leafIdx, chainIdx⟩ + | position position => + exact hcompletion.eq_positionValue position output + (by simpa [resolvedCompletionValue] using hvalue) + +noncomputable def completionOutputOfDigest (digest : Digest) : HashOutput := + (splitHashOutputEquiv digestBits (by decide)).symm (digest, 0) + +@[simp] theorem truncateHash_completionOutputOfDigest (digest : Digest) : + truncateHash (completionOutputOfDigest digest) = digest := by + change (splitHashOutput digestBits + ((splitHashOutputEquiv digestBits (by decide)).symm (digest, 0))).1 = digest + rw [show splitHashOutput digestBits = splitHashOutputEquiv digestBits (by decide) from rfl, + Equiv.apply_symm_apply] + +set_option maxRecDepth 100000 in +theorem pendingAt_eq_of_deferredCompletion_iff_of_value_none + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hleftCompletable : DeferredCompletable table left) + (hcompletion : ∀ completion, + DeferredCompletion table left completion ↔ + DeferredCompletion table right completion) + (coordinate : Coordinate) + (hleftValue : resolvedCompletionValue table left coordinate = none) + (hrightValue : resolvedCompletionValue table right coordinate = none) : + left.state.pendingAt coordinate = right.state.pendingAt coordinate := by + rcases hleftCompletable with ⟨base, hbaseLeft⟩ + have hbaseRight := (hcompletion base).mp hbaseLeft + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp [resolvedCompletionValue] at hleftValue + | position position => + have hleftState : left.state.values (.position position) = none := by + unfold resolvedCompletionValue DeferredContext.positionValue at hleftValue + cases hstate : left.state.values (.position position) with + | none => rfl + | some output => simp [hstate] at hleftValue + have hleftDeferred : left.values position = none := by + unfold resolvedCompletionValue DeferredContext.positionValue at hleftValue + simpa [hleftState] using hleftValue + have hrightState : right.state.values (.position position) = none := by + unfold resolvedCompletionValue DeferredContext.positionValue at hrightValue + cases hstate : right.state.values (.position position) with + | none => rfl + | some output => simp [hstate] at hrightValue + have hrightDeferred : right.values position = none := by + unfold resolvedCompletionValue DeferredContext.positionValue at hrightValue + simpa [hrightState] using hrightValue + apply Finset.ext + intro candidate + rw [LazyRevealProbe.State.mem_pendingAt_iff, + LazyRevealProbe.State.mem_pendingAt_iff] + constructor + · intro hleftPending + by_contra hrightPending + let output := completionOutputOfDigest candidate + let updated := Function.update base (.position position) output + have hupdatedRight : DeferredCompletion table right updated := by + refine ⟨?_, ?_, ?_, ?_⟩ + · intro other otherOutput hvalue + have hne : other ≠ .position position := by + intro heq + subst other + rw [hrightState] at hvalue + contradiction + simpa [updated, Function.update_of_ne hne] using + hbaseRight.1 other otherOutput hvalue + · intro other otherOutput hvalue + by_cases heq : other = position + · subst other + rw [hrightDeferred] at hvalue + contradiction + have hcoordinate : Coordinate.position other ≠ Coordinate.position position := by + simpa using heq + simpa [updated, Function.update_of_ne hcoordinate] using + hbaseRight.2.1 other otherOutput hvalue + · intro other otherCandidate hpending + by_cases heq : other = .position position + · subst other + have hcandidate : otherCandidate ≠ candidate := by + intro hsame + subst otherCandidate + exact hrightPending hpending + simpa [updated, output] using hcandidate.symm + simpa [updated, Function.update_of_ne heq] using + hbaseRight.2.2.1 other otherCandidate hpending + · intro index + have hne : index.coordinate ≠ .position position := by + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + simp [OtsSecretIndex.coordinate] + simpa [updated, Function.update_of_ne hne] using hbaseRight.2.2.2 index + have hupdatedLeft := (hcompletion updated).mpr hupdatedRight + have havoids := hupdatedLeft.2.2.1 (.position position) candidate hleftPending + exact havoids (by simp [updated, output]) + · intro hrightPending + by_contra hleftPending + let output := completionOutputOfDigest candidate + let updated := Function.update base (.position position) output + have hupdatedLeft : DeferredCompletion table left updated := by + refine ⟨?_, ?_, ?_, ?_⟩ + · intro other otherOutput hvalue + have hne : other ≠ .position position := by + intro heq + subst other + rw [hleftState] at hvalue + contradiction + simpa [updated, Function.update_of_ne hne] using + hbaseLeft.1 other otherOutput hvalue + · intro other otherOutput hvalue + by_cases heq : other = position + · subst other + rw [hleftDeferred] at hvalue + contradiction + have hcoordinate : Coordinate.position other ≠ Coordinate.position position := by + simpa using heq + simpa [updated, Function.update_of_ne hcoordinate] using + hbaseLeft.2.1 other otherOutput hvalue + · intro other otherCandidate hpending + by_cases heq : other = .position position + · subst other + have hcandidate : otherCandidate ≠ candidate := by + intro hsame + subst otherCandidate + exact hleftPending hpending + simpa [updated, output] using hcandidate.symm + simpa [updated, Function.update_of_ne heq] using + hbaseLeft.2.2.1 other otherCandidate hpending + · intro index + have hne : index.coordinate ≠ .position position := by + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + simp [OtsSecretIndex.coordinate] + simpa [updated, Function.update_of_ne hne] using hbaseLeft.2.2.2 index + have hupdatedRight := (hcompletion updated).mp hupdatedLeft + have havoids := hupdatedRight.2.2.1 (.position position) candidate hrightPending + exact havoids (by simp [updated, output]) + +structure FinalizationViewEq (table : OtsSecretIndex → HashOutput) + (left right : DeferredContext) : Prop where + leftConsistent : left.ValuesConsistent + rightConsistent : right.ValuesConsistent + leftStarts : StartTableAgrees left.state table + rightStarts : StartTableAgrees right.state table + valueEq : resolvedCompletionValue table left = resolvedCompletionValue table right + leftClean : ∀ coordinate output, + resolvedCompletionValue table left coordinate = some output → + ¬left.state.hitAt coordinate output + rightClean : ∀ coordinate output, + resolvedCompletionValue table right coordinate = some output → + ¬right.state.hitAt coordinate output + pendingEq : ∀ coordinate, + resolvedCompletionValue table left coordinate = none → + left.state.pendingAt coordinate = right.state.pendingAt coordinate + +theorem FinalizationViewEq.refl (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (hvalid : context.Valid) + (hstarts : StartTableAgrees context.state table) + (hclean : ∀ coordinate output, + resolvedCompletionValue table context coordinate = some output → + ¬context.state.hitAt coordinate output) : + FinalizationViewEq table context context := by + exact ⟨hvalid.valuesConsistent, hvalid.valuesConsistent, hstarts, hstarts, rfl, + hclean, hclean, fun _ _ => rfl⟩ + +theorem FinalizationViewEq.symm + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewEq table left right) : + FinalizationViewEq table right left := by + refine ⟨hview.rightConsistent, hview.leftConsistent, hview.rightStarts, + hview.leftStarts, hview.valueEq.symm, hview.rightClean, hview.leftClean, ?_⟩ + intro coordinate hvalue + have hleftValue : resolvedCompletionValue table left coordinate = none := by + rw [hview.valueEq] + exact hvalue + exact (hview.pendingEq coordinate hleftValue).symm + +theorem FinalizationViewEq.trans + {table : OtsSecretIndex → HashOutput} {left middle right : DeferredContext} + (hleft : FinalizationViewEq table left middle) + (hright : FinalizationViewEq table middle right) : + FinalizationViewEq table left right := by + refine ⟨hleft.leftConsistent, hright.rightConsistent, hleft.leftStarts, + hright.rightStarts, hleft.valueEq.trans hright.valueEq, hleft.leftClean, + hright.rightClean, ?_⟩ + intro coordinate hvalue + have hmiddleValue : resolvedCompletionValue table middle coordinate = none := by + rw [← hleft.valueEq] + exact hvalue + exact (hleft.pendingEq coordinate hvalue).trans + (hright.pendingEq coordinate hmiddleValue) + +theorem FinalizationViewEq.deferredCompletion_iff + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewEq table left right) + (completion : Coordinate → HashOutput) : + DeferredCompletion table left completion ↔ + DeferredCompletion table right completion := by + have transfer : ∀ {source target : DeferredContext}, + FinalizationViewEq table source target → + DeferredCompletion table source completion → + DeferredCompletion table target completion := by + intro source target hsemantic hcompletion + refine ⟨?_, ?_, ?_, hcompletion.2.2.2⟩ + · intro coordinate output hvalue + have htargetValue : resolvedCompletionValue table target coordinate = some output := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + have houtput := hsemantic.rightStarts + ⟨lay, tree, leafIdx, chainIdx⟩ output hvalue + simp [resolvedCompletionValue, houtput] + | position position => + simp [resolvedCompletionValue, DeferredContext.positionValue, hvalue] + have hsourceValue : resolvedCompletionValue table source coordinate = some output := by + rw [hsemantic.valueEq] + exact htargetValue + exact hcompletion.eq_resolvedCompletionValue coordinate output hsourceValue + · intro position output hvalue + have htargetValue : resolvedCompletionValue table target (.position position) = + some output := by + unfold resolvedCompletionValue DeferredContext.positionValue + cases hstate : target.state.values (.position position) with + | some cached => + have hsame := hsemantic.rightConsistent position cached hstate + rw [hsame] at hvalue + have hcached : cached = output := Option.some.inj hvalue + simp [hstate, hcached] + | none => simpa [hstate] using hvalue + have hsourceValue : resolvedCompletionValue table source (.position position) = + some output := by + rw [hsemantic.valueEq] + exact htargetValue + exact hcompletion.eq_resolvedCompletionValue (.position position) output hsourceValue + · intro coordinate candidate hmember + cases hvalue : resolvedCompletionValue table target coordinate with + | some output => + have hcompletionOutput : completion coordinate = output := by + have hsourceValue : resolvedCompletionValue table source coordinate = some output := by + rw [hsemantic.valueEq] + exact hvalue + exact hcompletion.eq_resolvedCompletionValue coordinate output hsourceValue + intro hhit + apply hsemantic.rightClean coordinate output hvalue + unfold LazyRevealProbe.State.hitAt + rw [LazyRevealProbe.State.mem_pendingAt_iff] + have hcandidate : candidate = truncateHash output := by + rw [← hhit, hcompletionOutput] + simpa [hcandidate] using hmember + | none => + have hsourceValue : resolvedCompletionValue table source coordinate = none := by + rw [hsemantic.valueEq] + exact hvalue + have htargetPending : candidate ∈ target.state.pendingAt coordinate := + (LazyRevealProbe.State.mem_pendingAt_iff target.state coordinate candidate).2 hmember + have hsourcePending : candidate ∈ source.state.pendingAt coordinate := by + rw [hsemantic.pendingEq coordinate hsourceValue] + exact htargetPending + exact hcompletion.2.2.1 coordinate candidate + ((LazyRevealProbe.State.mem_pendingAt_iff source.state coordinate candidate).1 + hsourcePending) + constructor + · exact transfer hview + · exact transfer hview.symm + +theorem deferredCompletion_resolveDeferredPositionValue_iff + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (position : Position) (result : DeferredResolution) + (hconsistent : context.ValuesConsistent) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) + (completion : Coordinate → HashOutput) : + DeferredCompletion table result.toDeferredContext completion ↔ + DeferredCompletion table context completion ∧ + completion (.position position) = result.output := by + constructor + · intro hcompletion + exact ⟨hcompletion.of_resolveDeferredPositionValue_of_valuesConsistent + hconsistent position result hresult, + hcompletion.eq_positionValue position result.output + (resolveDeferredPositionValue_resolves position context result hresult)⟩ + · rintro ⟨hcompletion, htarget⟩ + have hstateValues := resolveDeferredPositionValue_preserves_state_values + position context result hresult + have hpending := resolveDeferredPositionValue_pending position context result hresult + have hinstalled := resolveDeferredPositionValue_installs position context result hresult + refine ⟨?_, ?_, ?_, hcompletion.2.2.2⟩ + · intro coordinate output hvalue + apply hcompletion.1 coordinate output + rw [← hstateValues] + exact hvalue + · intro other output hvalue + by_cases heq : other = position + · subst other + have houtput : output = result.output := by + rw [hinstalled] at hvalue + exact Option.some.inj hvalue.symm + rw [houtput] + exact htarget + · apply hcompletion.2.1 other output + rw [← resolveDeferredPositionValue_preserves_other position other context result heq + hresult] + exact hvalue + · intro coordinate candidate hmember + apply hcompletion.2.2.1 coordinate candidate + have haway : (coordinate, candidate) ∈ + context.state.pendingAway (.position position) := by + rw [← hpending] + exact hmember + exact (Finset.mem_filter.1 haway).1 + +theorem resolveDeferredPositionValue_positionValue_eq_update + (position : Position) (context : DeferredContext) (result : DeferredResolution) + (hresult : some result ∈ support + (resolveDeferredPositionValue position context)) : + result.toDeferredContext.positionValue = + Function.update context.positionValue position (some result.output) := by + funext other + by_cases heq : other = position + · subst other + rw [resolveDeferredPositionValue_resolves position context result hresult] + simp + · have hstateValues := resolveDeferredPositionValue_preserves_state_values + position context result hresult + have hdeferred := resolveDeferredPositionValue_preserves_other + position other context result heq hresult + unfold DeferredContext.positionValue + rw [hstateValues] + cases hstate : context.state.values (.position other) with + | some output => simp [hstate, Function.update_of_ne heq] + | none => simp [hstate, hdeferred, Function.update_of_ne heq] + +set_option maxRecDepth 100000 in +theorem finalizationViewEq_of_deferredCompletion_iff + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hleftValid : left.Valid) (hrightValid : right.Valid) + (hleftStarts : StartTableAgrees left.state table) + (hrightStarts : StartTableAgrees right.state table) + (hvalueEq : resolvedCompletionValue table left = + resolvedCompletionValue table right) + (hleftCompletable : DeferredCompletable table left) + (hcompletion : ∀ completion, + DeferredCompletion table left completion ↔ + DeferredCompletion table right completion) : + FinalizationViewEq table left right := by + rcases hleftCompletable with ⟨completion, hcompletionLeft⟩ + have hcompletionRight := (hcompletion completion).mp hcompletionLeft + refine ⟨hleftValid.valuesConsistent, hrightValid.valuesConsistent, + hleftStarts, hrightStarts, hvalueEq, ?_, ?_, ?_⟩ + · intro coordinate output hvalue hhit + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + apply hcompletionLeft.2.2.1 coordinate (truncateHash output) hhit + rw [hcompletionLeft.eq_resolvedCompletionValue coordinate output hvalue] + · intro coordinate output hvalue hhit + unfold LazyRevealProbe.State.hitAt at hhit + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit + apply hcompletionRight.2.2.1 coordinate (truncateHash output) hhit + rw [hcompletionRight.eq_resolvedCompletionValue coordinate output hvalue] + · intro coordinate hvalue + apply pendingAt_eq_of_deferredCompletion_iff_of_value_none + ⟨completion, hcompletionLeft⟩ hcompletion coordinate hvalue + rw [← hvalueEq] + exact hvalue + +theorem finalizationViewEq_resolveDeferredPositionValue + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (position : Position) (leftResult rightResult : DeferredResolution) + (hview : FinalizationViewEq table left right) + (hleftValid : left.Valid) (hrightValid : right.Valid) + (hleftCompletable : DeferredCompletable table left) + (hleftResult : some leftResult ∈ support + (resolveDeferredPositionValue position left)) + (hrightResult : some rightResult ∈ support + (resolveDeferredPositionValue position right)) + (houtput : leftResult.output = rightResult.output) : + FinalizationViewEq table leftResult.toDeferredContext + rightResult.toDeferredContext := by + have hleftResultValid := hleftValid.of_resolveDeferredPositionValue + position leftResult hleftResult + have hrightResultValid := hrightValid.of_resolveDeferredPositionValue + position rightResult hrightResult + have hleftStateValues := resolveDeferredPositionValue_preserves_state_values + position left leftResult hleftResult + have hrightStateValues := resolveDeferredPositionValue_preserves_state_values + position right rightResult hrightResult + have hleftPositionValues := + resolveDeferredPositionValue_positionValue_eq_update position left leftResult hleftResult + have hrightPositionValues := + resolveDeferredPositionValue_positionValue_eq_update position right rightResult hrightResult + have hvalueEq : resolvedCompletionValue table leftResult.toDeferredContext = + resolvedCompletionValue table rightResult.toDeferredContext := by + funext coordinate + cases coordinate with + | chainStart => rfl + | position other => + change leftResult.toDeferredContext.positionValue other = + rightResult.toDeferredContext.positionValue other + rw [hleftPositionValues, hrightPositionValues] + by_cases heq : other = position + · subst other + simp [houtput] + · simp only [Function.update_of_ne heq] + exact congrFun hview.valueEq (.position other) + have hcompletion : ∀ completion, + DeferredCompletion table leftResult.toDeferredContext completion ↔ + DeferredCompletion table rightResult.toDeferredContext completion := by + intro completion + rw [deferredCompletion_resolveDeferredPositionValue_iff position leftResult + hview.leftConsistent hleftResult completion, + deferredCompletion_resolveDeferredPositionValue_iff position rightResult + hview.rightConsistent hrightResult completion, + ← houtput, hview.deferredCompletion_iff completion] + apply finalizationViewEq_of_deferredCompletion_iff + · exact hleftResultValid + · exact hrightResultValid + · exact hview.leftStarts.of_state_values_eq hleftStateValues + · exact hview.rightStarts.of_state_values_eq hrightStateValues + · exact hvalueEq + · exact hleftCompletable.of_resolveDeferredPositionValue hleftValid position leftResult + hleftResult + · exact hcompletion + +def FinalizationResolutionEq (table : OtsSecretIndex → HashOutput) : + Option DeferredResolution → Option DeferredResolution → Prop + | none, none => True + | some left, some right => + left.output = right.output ∧ + FinalizationViewEq table left.toDeferredContext right.toDeferredContext ∧ + left.toDeferredContext.Valid ∧ right.toDeferredContext.Valid ∧ + DeferredCompletable table left.toDeferredContext + | _, _ => False + +theorem deferredCompletion_resolveDeferredChainStart_iff + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (index : OtsSecretIndex) (result : DeferredResolution) + (hstarts : StartTableAgrees context.state table) + (hresult : resolveDeferredChainStart table index context = some result) + (completion : Coordinate → HashOutput) : + DeferredCompletion table result.toDeferredContext completion ↔ + DeferredCompletion table context completion := by + constructor + · intro hcompletion + exact hcompletion.of_resolveDeferredChainStart hstarts index result hresult + · intro hcompletion + have hstateValues := resolveDeferredChainStart_state_values_eq table index context result hresult + have hdeferredValues := + resolveDeferredChainStart_deferred_values_eq table index context result hresult + have hpending := resolveDeferredChainStart_pending_eq table index context result hresult + refine ⟨?_, ?_, ?_, hcompletion.2.2.2⟩ + · intro coordinate output hvalue + apply hcompletion.1 coordinate output + rw [← hstateValues] + exact hvalue + · intro position output hvalue + apply hcompletion.2.1 position output + rw [← hdeferredValues] + exact hvalue + · intro coordinate candidate hmember + apply hcompletion.2.2.1 coordinate candidate + rw [hpending] at hmember + exact (Finset.mem_filter.1 hmember).1 + +theorem finalizationViewEq_resolveDeferredChainStart + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (index : OtsSecretIndex) (leftResult rightResult : DeferredResolution) + (hview : FinalizationViewEq table left right) + (hleftValid : left.Valid) (hrightValid : right.Valid) + (hleftCompletable : DeferredCompletable table left) + (hleftResult : resolveDeferredChainStart table index left = some leftResult) + (hrightResult : resolveDeferredChainStart table index right = some rightResult) : + FinalizationViewEq table leftResult.toDeferredContext + rightResult.toDeferredContext := by + have hleftStateValues := resolveDeferredChainStart_state_values_eq table index left leftResult + hleftResult + have hrightStateValues := resolveDeferredChainStart_state_values_eq table index right rightResult + hrightResult + have hleftPositionValues := resolveDeferredChainStart_positionValue_eq table index left + leftResult hleftResult + have hrightPositionValues := resolveDeferredChainStart_positionValue_eq table index right + rightResult hrightResult + have hvalueEq : resolvedCompletionValue table leftResult.toDeferredContext = + resolvedCompletionValue table rightResult.toDeferredContext := by + funext coordinate + cases coordinate with + | chainStart => rfl + | position position => + change leftResult.toDeferredContext.positionValue position = + rightResult.toDeferredContext.positionValue position + rw [hleftPositionValues, hrightPositionValues] + exact congrFun hview.valueEq (.position position) + have hcompletion : ∀ completion, + DeferredCompletion table leftResult.toDeferredContext completion ↔ + DeferredCompletion table rightResult.toDeferredContext completion := by + intro completion + rw [deferredCompletion_resolveDeferredChainStart_iff index leftResult + hview.leftStarts hleftResult completion, + deferredCompletion_resolveDeferredChainStart_iff index rightResult + hview.rightStarts hrightResult completion, + hview.deferredCompletion_iff completion] + apply finalizationViewEq_of_deferredCompletion_iff + · exact hleftValid.of_resolveDeferredChainStart table index leftResult hleftResult + · exact hrightValid.of_resolveDeferredChainStart table index rightResult hrightResult + · exact hview.leftStarts.of_state_values_eq hleftStateValues + · exact hview.rightStarts.of_state_values_eq hrightStateValues + · exact hvalueEq + · exact hleftCompletable.of_resolveDeferredChainStart index leftResult hleftResult + · exact hcompletion + +theorem relTriple_resolveDeferredChainStart_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (left right : DeferredContext) (hview : FinalizationViewEq table left right) + (hleftValid : left.Valid) (hrightValid : right.Valid) + (hleftCompletable : DeferredCompletable table left) : + RelTriple + (pure (resolveDeferredChainStart table index left) : + ProbComp (Option DeferredResolution)) + (pure (resolveDeferredChainStart table index right) : + ProbComp (Option DeferredResolution)) + (FinalizationResolutionEq table) := by + have hrightCompletable : DeferredCompletable table right := by + rcases hleftCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, (hview.deferredCompletion_iff completion).mp hcompletion⟩ + have hleftClean := hleftCompletable.not_hitAt_chainStart index + have hrightClean := hrightCompletable.not_hitAt_chainStart index + let leftResult : DeferredResolution := + ⟨{ state := left.state.clearPending index.coordinate, values := left.values }, table index⟩ + let rightResult : DeferredResolution := + ⟨{ state := right.state.clearPending index.coordinate, values := right.values }, table index⟩ + have hleftResult : resolveDeferredChainStart table index left = some leftResult := by + cases hstate : left.state.values index.coordinate with + | some output => + have houtput := hview.leftStarts index output hstate + simp [resolveDeferredChainStart, hstate, houtput, hleftClean, leftResult] + | none => simp [resolveDeferredChainStart, hstate, hleftClean, leftResult] + have hrightResult : resolveDeferredChainStart table index right = some rightResult := by + cases hstate : right.state.values index.coordinate with + | some output => + have houtput := hview.rightStarts index output hstate + simp [resolveDeferredChainStart, hstate, houtput, hrightClean, rightResult] + | none => simp [resolveDeferredChainStart, hstate, hrightClean, rightResult] + rw [hleftResult, hrightResult] + apply relTriple_pure_pure + exact ⟨rfl, finalizationViewEq_resolveDeferredChainStart index leftResult rightResult hview + hleftValid hrightValid hleftCompletable hleftResult hrightResult, + hleftValid.of_resolveDeferredChainStart table index leftResult hleftResult, + hrightValid.of_resolveDeferredChainStart table index rightResult hrightResult, + hleftCompletable.of_resolveDeferredChainStart index leftResult hleftResult⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_resolveDeferredPositionValue_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (position : Position) + (left right : DeferredContext) (hview : FinalizationViewEq table left right) + (hleftValid : left.Valid) (hrightValid : right.Valid) + (hleftCompletable : DeferredCompletable table left) : + RelTriple + (resolveDeferredPositionValue position left) + (resolveDeferredPositionValue position right) + (FinalizationResolutionEq table) := by + have hpositionValue : left.positionValue position = right.positionValue position := by + exact congrFun hview.valueEq (.position position) + have relate (leftResult rightResult : DeferredResolution) + (hleftResult : some leftResult ∈ support + (resolveDeferredPositionValue position left)) + (hrightResult : some rightResult ∈ support + (resolveDeferredPositionValue position right)) + (houtput : leftResult.output = rightResult.output) : + FinalizationResolutionEq table (some leftResult) (some rightResult) := by + exact ⟨houtput, + finalizationViewEq_resolveDeferredPositionValue position leftResult rightResult hview + hleftValid hrightValid hleftCompletable hleftResult hrightResult houtput, + hleftValid.of_resolveDeferredPositionValue position leftResult hleftResult, + hrightValid.of_resolveDeferredPositionValue position rightResult hrightResult, + hleftCompletable.of_resolveDeferredPositionValue hleftValid position leftResult + hleftResult⟩ + cases hleftState : left.state.values (.position position) with + | some output => + have hleftValue : left.positionValue position = some output := by + simp [DeferredContext.positionValue, hleftState] + have hrightValue : right.positionValue position = some output := by + rw [← hpositionValue] + exact hleftValue + have hleftClean : ¬left.state.hitAt (.position position) output := + hview.leftClean (.position position) output hleftValue + rw [resolveDeferredPositionValue_of_state_value position left output hleftState, + if_neg hleftClean] + cases hrightState : right.state.values (.position position) with + | some rightOutput => + have hrightOutput : rightOutput = output := by + simpa [DeferredContext.positionValue, hrightState] using hrightValue + subst rightOutput + have hrightClean : ¬right.state.hitAt (.position position) output := + hview.rightClean (.position position) output hrightValue + rw [resolveDeferredPositionValue_of_state_value position right output hrightState, + if_neg hrightClean] + apply relTriple_pure_pure + apply relate <;> + simp [resolveDeferredPositionValue, hleftState, hrightState, hleftClean, + hrightClean] + | none => + cases hrightDeferred : right.values position with + | some rightOutput => + have hrightOutput : rightOutput = output := by + simpa [DeferredContext.positionValue, hrightState, hrightDeferred] using + hrightValue + subst rightOutput + have hrightClean : ¬right.state.hitAt (.position position) output := + hview.rightClean (.position position) output hrightValue + rw [resolveDeferredPositionValue_of_deferred_value position right output + hrightState hrightDeferred, if_neg hrightClean] + apply relTriple_pure_pure + apply relate <;> + simp [resolveDeferredPositionValue, hleftState, hrightState, hrightDeferred, + hleftClean, hrightClean] + | none => + simp [DeferredContext.positionValue, hrightState, hrightDeferred] at hrightValue + | none => + cases hleftDeferred : left.values position with + | some output => + have hleftValue : left.positionValue position = some output := by + simp [DeferredContext.positionValue, hleftState, hleftDeferred] + have hrightValue : right.positionValue position = some output := by + rw [← hpositionValue] + exact hleftValue + have hleftClean : ¬left.state.hitAt (.position position) output := + hview.leftClean (.position position) output hleftValue + rw [resolveDeferredPositionValue_of_deferred_value position left output hleftState + hleftDeferred, if_neg hleftClean] + cases hrightState : right.state.values (.position position) with + | some rightOutput => + have hrightOutput : rightOutput = output := by + simpa [DeferredContext.positionValue, hrightState] using hrightValue + subst rightOutput + have hrightClean : ¬right.state.hitAt (.position position) output := + hview.rightClean (.position position) output hrightValue + rw [resolveDeferredPositionValue_of_state_value position right output hrightState, + if_neg hrightClean] + apply relTriple_pure_pure + apply relate <;> + simp [resolveDeferredPositionValue, hleftState, hleftDeferred, hrightState, + hleftClean, hrightClean] + | none => + cases hrightDeferred : right.values position with + | some rightOutput => + have hrightOutput : rightOutput = output := by + simpa [DeferredContext.positionValue, hrightState, hrightDeferred] using + hrightValue + subst rightOutput + have hrightClean : ¬right.state.hitAt (.position position) output := + hview.rightClean (.position position) output hrightValue + rw [resolveDeferredPositionValue_of_deferred_value position right output + hrightState hrightDeferred, if_neg hrightClean] + apply relTriple_pure_pure + apply relate <;> + simp [resolveDeferredPositionValue, hleftState, hleftDeferred, hrightState, + hrightDeferred, hleftClean, hrightClean] + | none => + simp [DeferredContext.positionValue, hrightState, hrightDeferred] at hrightValue + | none => + have hleftValue : left.positionValue position = none := by + simp [DeferredContext.positionValue, hleftState, hleftDeferred] + have hrightValue : right.positionValue position = none := by + rw [← hpositionValue] + exact hleftValue + have hrightState : right.state.values (.position position) = none := by + cases hstate : right.state.values (.position position) with + | none => rfl + | some output => simp [DeferredContext.positionValue, hstate] at hrightValue + have hrightDeferred : right.values position = none := by + simpa [DeferredContext.positionValue, hrightState] using hrightValue + rw [resolveDeferredPositionValue_fresh position left hleftState hleftDeferred, + resolveDeferredPositionValue_fresh position right hrightState hrightDeferred] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + have hpending := hview.pendingEq (.position position) hleftValue + have hhit : left.state.hitAt (.position position) leftOutput ↔ + right.state.hitAt (.position position) leftOutput := by + unfold LazyRevealProbe.State.hitAt + rw [hpending] + by_cases hleftHit : left.state.hitAt (.position position) leftOutput + · rw [if_pos hleftHit, if_pos (hhit.mp hleftHit)] + exact relTriple_pure_pure trivial + · have hrightHit : ¬right.state.hitAt (.position position) leftOutput := + mt hhit.mpr hleftHit + rw [if_neg hleftHit, if_neg hrightHit] + apply relTriple_pure_pure + apply relate + · rw [resolveDeferredPositionValue_fresh position left hleftState hleftDeferred, + mem_support_bind_iff] + exact ⟨leftOutput, by simp [LazyRevealProbe.sampleHashOutput], by simp [hleftHit]⟩ + · rw [resolveDeferredPositionValue_fresh position right hrightState hrightDeferred, + mem_support_bind_iff] + exact ⟨leftOutput, by simp [LazyRevealProbe.sampleHashOutput], by simp [hrightHit]⟩ + · rfl + +set_option maxRecDepth 100000 in +theorem relTriple_resolveDeferredChainPrefix_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ∀ steps hsteps left right, + FinalizationViewEq table left right → left.Valid → right.Valid → + DeferredCompletable table left → + RelTriple + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps left) + (resolveDeferredChainPrefix table lay tree leafIdx chainIdx steps hsteps right) + (FinalizationResolutionEq table) + | 0, hsteps, left, right, hview, hleftValid, hrightValid, hleftCompletable => by + simp only [resolveDeferredChainPrefix] + exact relTriple_resolveDeferredChainStart_of_finalizationViewEq table + ⟨lay, tree, leafIdx, chainIdx⟩ left right hview hleftValid hrightValid + hleftCompletable + | steps + 1, hsteps, left, right, hview, hleftValid, hrightValid, + hleftCompletable => by + rw [resolveDeferredChainPrefix, resolveDeferredChainPrefix] + apply relTriple_bind + (relTriple_resolveDeferredChainPrefix_of_finalizationViewEq table lay tree leafIdx + chainIdx steps (by omega) left right hview hleftValid hrightValid hleftCompletable) + intro leftPrevious rightPrevious hprevious + cases leftPrevious with + | none => + cases rightPrevious <;> simp [FinalizationResolutionEq] at hprevious ⊢ + | some leftPrevious => + cases rightPrevious with + | none => simp [FinalizationResolutionEq] at hprevious + | some rightPrevious => + exact relTriple_resolveDeferredPositionValue_of_finalizationViewEq table + (.chain lay tree leafIdx chainIdx ⟨steps, by omega⟩) + leftPrevious.toDeferredContext rightPrevious.toDeferredContext hprevious.2.1 + hprevious.2.2.1 hprevious.2.2.2.1 hprevious.2.2.2.2 + +def FinalizationContextEq (table : OtsSecretIndex → HashOutput) : + Option DeferredContext → Option DeferredContext → Prop + | none, none => True + | some left, some right => + FinalizationViewEq table left right ∧ left.Valid ∧ right.Valid ∧ + DeferredCompletable table left + | _, _ => False + +set_option maxRecDepth 100000 in +theorem relTriple_resolveDeferredChains_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : ∀ chains left right, + FinalizationViewEq table left right → left.Valid → right.Valid → + DeferredCompletable table left → + RelTriple + (resolveDeferredChains table lay tree leafIdx chains left) + (resolveDeferredChains table lay tree leafIdx chains right) + (FinalizationContextEq table) + | [], left, right, hview, hleftValid, hrightValid, hleftCompletable => by + simp only [resolveDeferredChains] + exact relTriple_pure_pure ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + | chainIdx :: remaining, left, right, hview, hleftValid, hrightValid, + hleftCompletable => by + rw [resolveDeferredChains, resolveDeferredChains] + apply relTriple_bind + (relTriple_resolveDeferredChainPrefix_of_finalizationViewEq table lay tree leafIdx + chainIdx (chainLength - 1) (by omega) left right hview hleftValid hrightValid + hleftCompletable) + intro leftResolved rightResolved hresolved + cases leftResolved with + | none => + cases rightResolved with + | none => exact relTriple_pure_pure trivial + | some rightResolved => simp [FinalizationResolutionEq] at hresolved + | some leftResolved => + cases rightResolved with + | none => simp [FinalizationResolutionEq] at hresolved + | some rightResolved => + exact relTriple_resolveDeferredChains_of_finalizationViewEq table lay tree leafIdx + remaining leftResolved.toDeferredContext rightResolved.toDeferredContext + hresolved.2.1 hresolved.2.2.1 hresolved.2.2.2.1 hresolved.2.2.2.2 + +set_option maxRecDepth 100000 in +theorem relTriple_resolveDeferredOtsLeaf_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (left right : DeferredContext) + (hview : FinalizationViewEq table left right) + (hleftValid : left.Valid) (hrightValid : right.Valid) + (hleftCompletable : DeferredCompletable table left) : + RelTriple + (resolveDeferredOtsLeaf table lay tree leafIdx left) + (resolveDeferredOtsLeaf table lay tree leafIdx right) + (FinalizationResolutionEq table) := by + rw [resolveDeferredOtsLeaf, resolveDeferredOtsLeaf] + apply relTriple_bind + (relTriple_resolveDeferredChains_of_finalizationViewEq table lay tree leafIdx + (List.ofFn fun chainIdx : ChainIndex => chainIdx) left right hview hleftValid + hrightValid hleftCompletable) + intro leftChains rightChains hchains + cases leftChains with + | none => + cases rightChains with + | none => exact relTriple_pure_pure trivial + | some rightChains => simp [FinalizationContextEq] at hchains + | some leftChains => + cases rightChains with + | none => simp [FinalizationContextEq] at hchains + | some rightChains => + exact relTriple_resolveDeferredPositionValue_of_finalizationViewEq table + (.leaf lay tree leafIdx) leftChains rightChains hchains.1 hchains.2.1 + hchains.2.2.1 hchains.2.2.2 + +set_option maxRecDepth 100000 in +theorem relTriple_resolveDeferredTreeNode_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx hlevel left right, + FinalizationViewEq table left right → left.Valid → right.Valid → + DeferredCompletable table left → + RelTriple + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel left) + (resolveDeferredTreeNode table lay tree level nodeIdx hlevel right) + (FinalizationResolutionEq table) + | 0, nodeIdx, hlevel, left, right, hview, hleftValid, hrightValid, + hleftCompletable => + relTriple_resolveDeferredOtsLeaf_of_finalizationViewEq table lay tree + (leafOfNat nodeIdx) left right hview hleftValid hrightValid hleftCompletable + | level + 1, nodeIdx, hlevel, left, right, hview, hleftValid, hrightValid, + hleftCompletable => by + rw [resolveDeferredTreeNode, resolveDeferredTreeNode] + apply relTriple_bind + (relTriple_resolveDeferredTreeNode_of_finalizationViewEq table lay tree level + (2 * nodeIdx) (by omega) left right hview hleftValid hrightValid hleftCompletable) + intro leftNode rightNode hleftNode + cases leftNode with + | none => + cases rightNode <;> simp [FinalizationResolutionEq] at hleftNode ⊢ + | some leftNode => + cases rightNode with + | none => simp [FinalizationResolutionEq] at hleftNode + | some rightNode => + apply relTriple_bind + (relTriple_resolveDeferredTreeNode_of_finalizationViewEq table lay tree level + (2 * nodeIdx + 1) (by omega) leftNode.toDeferredContext + rightNode.toDeferredContext hleftNode.2.1 hleftNode.2.2.1 + hleftNode.2.2.2.1 hleftNode.2.2.2.2) + intro leftSibling rightSibling hsibling + cases leftSibling with + | none => + cases rightSibling <;> simp [FinalizationResolutionEq] at hsibling ⊢ + | some leftSibling => + cases rightSibling with + | none => simp [FinalizationResolutionEq] at hsibling + | some rightSibling => + exact relTriple_resolveDeferredPositionValue_of_finalizationViewEq table + (.node lay tree ⟨level, by omega⟩ (leafOfNat nodeIdx)) + leftSibling.toDeferredContext rightSibling.toDeferredContext + hsibling.2.1 hsibling.2.2.1 hsibling.2.2.2.1 + hsibling.2.2.2.2 + +set_option maxRecDepth 100000 in +theorem relTriple_resolveDeferredPosition_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (position : Position) + (left right : DeferredContext) (hview : FinalizationViewEq table left right) + (hleftValid : left.Valid) (hrightValid : right.Valid) + (hleftCompletable : DeferredCompletable table left) : + RelTriple + (resolveDeferredPosition table position left) + (resolveDeferredPosition table position right) + (FinalizationResolutionEq table) := by + cases position with + | chain lay tree leafIdx chainIdx step => + exact relTriple_resolveDeferredChainPrefix_of_finalizationViewEq table lay tree leafIdx + chainIdx (step.val + 1) (by have := step.isLt; omega) left right hview hleftValid + hrightValid hleftCompletable + | leaf lay tree leafIdx => + exact relTriple_resolveDeferredOtsLeaf_of_finalizationViewEq table lay tree leafIdx + left right hview hleftValid hrightValid hleftCompletable + | node lay tree level nodeIdx => + exact relTriple_resolveDeferredTreeNode_of_finalizationViewEq table lay tree + (level.val + 1) nodeIdx (by have := level.isLt; omega) left right hview hleftValid + hrightValid hleftCompletable + | ftsLeaf index tree leafIdx => + exact relTriple_resolveDeferredPositionValue_of_finalizationViewEq table + (.ftsLeaf index tree leafIdx) left right hview hleftValid hrightValid hleftCompletable + | ftsNode index tree level nodeIdx => + exact relTriple_resolveDeferredPositionValue_of_finalizationViewEq table + (.ftsNode index tree level nodeIdx) left right hview hleftValid hrightValid + hleftCompletable + | ftsRoots index => + exact relTriple_resolveDeferredPositionValue_of_finalizationViewEq table + (.ftsRoots index) left right hview hleftValid hrightValid hleftCompletable + +theorem relTriple_resolveDeferredReveal_of_finalizationViewEq + (table : OtsSecretIndex → HashOutput) (position : Position) + (left right : DeferredContext) (hview : FinalizationViewEq table left right) + (hleftValid : left.Valid) (hrightValid : right.Valid) + (hleftCompletable : DeferredCompletable table left) : + RelTriple + (resolveDeferredReveal table position left) + (resolveDeferredReveal table position right) + (FinalizationResolutionEq table) := by + classical + unfold resolveDeferredReveal + by_cases hresolvable : ResolvableOtsPosition position + · rw [if_pos hresolvable, if_pos hresolvable] + exact relTriple_resolveDeferredPosition_of_finalizationViewEq table position left right + hview hleftValid hrightValid hleftCompletable + · rw [if_neg hresolvable, if_neg hresolvable] + exact relTriple_resolveDeferredPositionValue_of_finalizationViewEq table position left right + hview hleftValid hrightValid hleftCompletable + +theorem finalizeResolvedCoordinates_cons_chainStart_of_clean + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) + (remaining : List Coordinate) (context : DeferredContext) + (hstarts : StartTableAgrees context.state table) + (hclean : ¬context.state.hitAt index.coordinate (table index)) : + finalizeResolvedCoordinates (index.coordinate :: remaining) context table = + finalizeResolvedCoordinates remaining + (context.completeResolved index.coordinate (table index)) table := by + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + simp only [OtsSecretIndex.coordinate] at hclean ⊢ + cases hstate : context.state.values (.chainStart lay tree leafIdx chainIdx) with + | some output => + have houtput := hstarts ⟨lay, tree, leafIdx, chainIdx⟩ output hstate + subst output + rw [finalizeResolvedCoordinates_cons_of_state_value + (.chainStart lay tree leafIdx chainIdx) remaining context table + (table ⟨lay, tree, leafIdx, chainIdx⟩) hstate] + congr 1 + rcases context with ⟨state, values⟩ + simp only [DeferredContext.completeResolved] + congr 1 + rcases state with ⟨pending, stateValues, revealed, ensured⟩ + simp only [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.complete, + LazyRevealProbe.State.pendingAway] at hstate ⊢ + congr 1 + funext coordinate + by_cases heq : coordinate = .chainStart lay tree leafIdx chainIdx + · subst coordinate + simpa using hstate + · simp [Function.update_of_ne heq] + | none => + rw [finalizeResolvedCoordinates] + simp only [hstate] + rw [resolveDeferredChainStart_of_missing table ⟨lay, tree, leafIdx, chainIdx⟩ context + hstate] + simp [OtsSecretIndex.coordinate, hclean, DeferredContext.completeResolved, + clearPending_complete_self] + +theorem finalizeResolvedCoordinates_cons_position_of_known_clean + (table : OtsSecretIndex → HashOutput) (position : Position) + (remaining : List Coordinate) (context : DeferredContext) + (hconsistent : context.ValuesConsistent) (output : HashOutput) + (hvalue : context.positionValue position = some output) + (hclean : ¬context.state.hitAt (.position position) output) : + finalizeResolvedCoordinates (.position position :: remaining) context table = + finalizeResolvedCoordinates remaining + (context.completeResolved (.position position) output) table := by + cases hstate : context.state.values (.position position) with + | some cached => + have hcached : cached = output := by + unfold DeferredContext.positionValue at hvalue + rw [hstate] at hvalue + exact Option.some.inj hvalue + subst cached + have hdeferred := hconsistent position output hstate + rw [finalizeResolvedCoordinates_cons_of_state_value (.position position) remaining + context table output hstate] + congr 1 + rcases context with ⟨state, values⟩ + change values position = some output at hdeferred + simp only [DeferredContext.completeResolved] + congr 1 + · rcases state with ⟨pending, stateValues, revealed, ensured⟩ + simp only [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.complete, + LazyRevealProbe.State.pendingAway] at hstate ⊢ + congr 1 + funext coordinate + by_cases heq : coordinate = Coordinate.position position + · subst coordinate + simpa using hstate + · simp [Function.update_of_ne heq] + · funext other + by_cases heq : other = position + · subst other + simp [DeferredStructuralValues.install, hdeferred] + · simp [DeferredStructuralValues.install, heq] + | none => + have hdeferred : context.values position = some output := by + unfold DeferredContext.positionValue at hvalue + simpa [hstate] using hvalue + rw [finalizeResolvedCoordinates_cons_position_of_deferred_value position remaining + context table output hstate hdeferred, if_neg hclean] + congr 1 + rcases context with ⟨state, values⟩ + change values position = some output at hdeferred + simp only [DeferredContext.completeResolved] + congr 1 + funext other + by_cases heq : other = position + · subst other + simp [DeferredStructuralValues.install, hdeferred] + · simp [DeferredStructuralValues.install, heq] + +theorem finalizeResolvedCoordinates_cons_position_of_unknown + (table : OtsSecretIndex → HashOutput) (position : Position) + (remaining : List Coordinate) (context : DeferredContext) + (hvalue : context.positionValue position = none) : + finalizeResolvedCoordinates (.position position :: remaining) context table = (do + let output ← LazyRevealProbe.sampleHashOutput + if context.state.hitAt (.position position) output then + pure none + else (finalizeResolvedCoordinates remaining + (context.completeResolved (.position position) output) table)) := by + have hstate : context.state.values (.position position) = none := by + unfold DeferredContext.positionValue at hvalue + cases hstate : context.state.values (.position position) with + | none => rfl + | some output => simp [hstate] at hvalue + have hdeferred : context.values position = none := by + unfold DeferredContext.positionValue at hvalue + simpa [hstate] using hvalue + rw [finalizeResolvedCoordinates_cons_position_fresh position remaining context table hstate + hdeferred] + rfl + +@[simp] theorem resolvedCompletionValue_completeResolved_position_self + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (position : Position) (output : HashOutput) : + resolvedCompletionValue table + (context.completeResolved (.position position) output) (.position position) = + some output := by + simp [resolvedCompletionValue, DeferredContext.positionValue, + DeferredContext.completeResolved, LazyRevealProbe.State.complete, + DeferredStructuralValues.install] + +@[simp] theorem resolvedCompletionValue_completeResolved_start_self + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (index : OtsSecretIndex) : + resolvedCompletionValue table + (context.completeResolved index.coordinate (table index)) index.coordinate = + some (table index) := by + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + rfl + +theorem not_hitAt_complete_self + (state : LazyRevealProbe.State Coordinate) (coordinate : Coordinate) + (output : HashOutput) : + ¬(state.complete coordinate output).hitAt coordinate output := by + unfold LazyRevealProbe.State.hitAt LazyRevealProbe.State.pendingAt + simp [LazyRevealProbe.State.complete, LazyRevealProbe.State.pendingAway] + +theorem resolvedCompletionValue_completeResolved_of_ne + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (coordinate other : Coordinate) (output : HashOutput) (hne : other ≠ coordinate) : + resolvedCompletionValue table (context.completeResolved coordinate output) other = + resolvedCompletionValue table context other := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + cases other with + | chainStart => rfl + | position position => + simp [resolvedCompletionValue, DeferredContext.positionValue, + DeferredContext.completeResolved, values_complete_of_ne, hne] + | position position => + cases other with + | chainStart => rfl + | position other => + have hposition : other ≠ position := by + intro heq + subst other + exact hne rfl + simp [resolvedCompletionValue, DeferredContext.positionValue, + DeferredContext.completeResolved, DeferredStructuralValues.install, + values_complete_of_ne, hne, hposition] + +theorem DeferredContext.ValuesConsistent.completeResolved + {context : DeferredContext} (hconsistent : context.ValuesConsistent) + (coordinate : Coordinate) (output : HashOutput) : + (context.completeResolved coordinate output).ValuesConsistent := by + intro position cached hvalue + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + apply hconsistent position cached + have hne : Coordinate.position position ≠ + Coordinate.chainStart lay tree leafIdx chainIdx := by simp + simpa only [DeferredContext.completeResolved, + values_complete_of_ne context.state + (.chainStart lay tree leafIdx chainIdx) (.position position) output hne] using hvalue + | position completed => + by_cases heq : position = completed + · subst position + have hcached : cached = output := by + simpa [DeferredContext.completeResolved, LazyRevealProbe.State.complete] using + hvalue.symm + subst cached + simp [DeferredContext.completeResolved, DeferredStructuralValues.install] + · have hcoordinate : Coordinate.position position ≠ Coordinate.position completed := by + simpa using heq + have horiginal : context.state.values (.position position) = some cached := by + simpa [DeferredContext.completeResolved, LazyRevealProbe.State.complete, + Function.update_of_ne hcoordinate] using hvalue + simpa [DeferredContext.completeResolved, DeferredStructuralValues.install, heq] using + hconsistent position cached horiginal + +set_option maxRecDepth 100000 in +theorem FinalizationViewEq.completeStart + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewEq table left right) + (index : OtsSecretIndex) : + FinalizationViewEq table + (left.completeResolved index.coordinate (table index)) + (right.completeResolved index.coordinate (table index)) := by + have hleftState : (left.completeResolved index.coordinate (table index)).state = + left.state.complete index.coordinate (table index) := by + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + rfl + have hrightState : (right.completeResolved index.coordinate (table index)).state = + right.state.complete index.coordinate (table index) := by + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + rfl + refine ⟨hview.leftConsistent.completeResolved index.coordinate (table index), + hview.rightConsistent.completeResolved index.coordinate (table index), + ?_, ?_, ?_, ?_, ?_, ?_⟩ + · rw [hleftState] + exact hview.leftStarts.complete_start index + · rw [hrightState] + exact hview.rightStarts.complete_start index + · funext other + by_cases heq : other = index.coordinate + · subst other + simp + · rw [resolvedCompletionValue_completeResolved_of_ne table left index.coordinate other + (table index) heq, + resolvedCompletionValue_completeResolved_of_ne table right index.coordinate other + (table index) heq, + hview.valueEq] + · intro other otherOutput hvalue + by_cases heq : other = index.coordinate + · subst other + have houtput : otherOutput = table index := by + simpa using hvalue.symm + subst otherOutput + rw [hleftState] + exact not_hitAt_complete_self left.state index.coordinate (table index) + · have horiginal : resolvedCompletionValue table left other = some otherOutput := by + rw [← resolvedCompletionValue_completeResolved_of_ne table left index.coordinate other + (table index) heq] + exact hvalue + have hclean := hview.leftClean other otherOutput horiginal + rw [hleftState] + exact (hitAt_complete_of_ne left.state index.coordinate other (table index) otherOutput + heq).not.mpr hclean + · intro other otherOutput hvalue + by_cases heq : other = index.coordinate + · subst other + have houtput : otherOutput = table index := by + simpa using hvalue.symm + subst otherOutput + rw [hrightState] + exact not_hitAt_complete_self right.state index.coordinate (table index) + · have horiginal : resolvedCompletionValue table right other = some otherOutput := by + rw [← resolvedCompletionValue_completeResolved_of_ne table right index.coordinate other + (table index) heq] + exact hvalue + have hclean := hview.rightClean other otherOutput horiginal + rw [hrightState] + exact (hitAt_complete_of_ne right.state index.coordinate other (table index) otherOutput + heq).not.mpr hclean + · intro other hvalue + have hne : other ≠ index.coordinate := by + intro heq + subst other + simp at hvalue + have horiginal : resolvedCompletionValue table left other = none := by + rw [← resolvedCompletionValue_completeResolved_of_ne table left index.coordinate other + (table index) hne] + exact hvalue + have hpending := hview.pendingEq other horiginal + rw [hleftState, hrightState] + rw [pendingAt_complete_of_ne left.state index.coordinate other (table index) hne, + pendingAt_complete_of_ne right.state index.coordinate other (table index) hne, + hpending] + +set_option maxRecDepth 100000 in +theorem FinalizationViewEq.completePosition + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewEq table left right) + (position : Position) (output : HashOutput) : + FinalizationViewEq table + (left.completeResolved (.position position) output) + (right.completeResolved (.position position) output) := by + have hleftState : (left.completeResolved (.position position) output).state = + left.state.complete (.position position) output := rfl + have hrightState : (right.completeResolved (.position position) output).state = + right.state.complete (.position position) output := rfl + refine ⟨hview.leftConsistent.completeResolved (.position position) output, + hview.rightConsistent.completeResolved (.position position) output, + hview.leftStarts.complete_position position output, + hview.rightStarts.complete_position position output, ?_, ?_, ?_, ?_⟩ + · funext other + by_cases heq : other = .position position + · subst other + simp + · rw [resolvedCompletionValue_completeResolved_of_ne table left (.position position) + other output heq, + resolvedCompletionValue_completeResolved_of_ne table right (.position position) + other output heq, + hview.valueEq] + · intro other otherOutput hvalue + by_cases heq : other = .position position + · subst other + have houtput : otherOutput = output := by simpa using hvalue.symm + subst otherOutput + rw [hleftState] + exact not_hitAt_complete_self left.state (.position position) output + · have horiginal : resolvedCompletionValue table left other = some otherOutput := by + rw [← resolvedCompletionValue_completeResolved_of_ne table left (.position position) + other output heq] + exact hvalue + have hclean := hview.leftClean other otherOutput horiginal + rw [hleftState] + exact (hitAt_complete_of_ne left.state (.position position) other output otherOutput + heq).not.mpr hclean + · intro other otherOutput hvalue + by_cases heq : other = .position position + · subst other + have houtput : otherOutput = output := by simpa using hvalue.symm + subst otherOutput + rw [hrightState] + exact not_hitAt_complete_self right.state (.position position) output + · have horiginal : resolvedCompletionValue table right other = some otherOutput := by + rw [← resolvedCompletionValue_completeResolved_of_ne table right (.position position) + other output heq] + exact hvalue + have hclean := hview.rightClean other otherOutput horiginal + rw [hrightState] + exact (hitAt_complete_of_ne right.state (.position position) other output otherOutput + heq).not.mpr hclean + · intro other hvalue + have hne : other ≠ .position position := by + intro heq + subst other + simp at hvalue + have horiginal : resolvedCompletionValue table left other = none := by + rw [← resolvedCompletionValue_completeResolved_of_ne table left (.position position) + other output hne] + exact hvalue + have hpending := hview.pendingEq other horiginal + rw [hleftState, hrightState] + rw [pendingAt_complete_of_ne left.state (.position position) other output hne, + pendingAt_complete_of_ne right.state (.position position) other output hne, + hpending] + +set_option maxRecDepth 100000 in +theorem evalDist_map_isNone_finalizeResolvedCoordinates_congr + (table : OtsSecretIndex → HashOutput) (coordinates : List Coordinate) + (left right : DeferredContext) (hview : FinalizationViewEq table left right) : + evalDist (Option.isNone <$> finalizeResolvedCoordinates coordinates left table) = + evalDist (Option.isNone <$> finalizeResolvedCoordinates coordinates right table) := by + induction coordinates generalizing left right with + | nil => simp [finalizeResolvedCoordinates] + | cons coordinate remaining ih => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + have hleftClean : ¬left.state.hitAt index.coordinate (table index) := + hview.leftClean index.coordinate (table index) (by + simp [index, resolvedCompletionValue, OtsSecretIndex.coordinate]) + have hrightClean : ¬right.state.hitAt index.coordinate (table index) := + hview.rightClean index.coordinate (table index) (by + simp [index, resolvedCompletionValue, OtsSecretIndex.coordinate]) + change evalDist (Option.isNone <$> + finalizeResolvedCoordinates (index.coordinate :: remaining) left table) = + evalDist (Option.isNone <$> + finalizeResolvedCoordinates (index.coordinate :: remaining) right table) + rw [finalizeResolvedCoordinates_cons_chainStart_of_clean table index remaining left + hview.leftStarts hleftClean, + finalizeResolvedCoordinates_cons_chainStart_of_clean table index remaining right + hview.rightStarts hrightClean] + exact ih (left.completeResolved index.coordinate (table index)) + (right.completeResolved index.coordinate (table index)) + (hview.completeStart index) + | position position => + cases hvalue : resolvedCompletionValue table left (.position position) with + | some output => + have hrightValue : + resolvedCompletionValue table right (.position position) = some output := by + rw [← hview.valueEq] + exact hvalue + have hleftClean := hview.leftClean (.position position) output hvalue + have hrightClean := hview.rightClean (.position position) output hrightValue + rw [finalizeResolvedCoordinates_cons_position_of_known_clean table position + remaining left hview.leftConsistent output + (by simpa [resolvedCompletionValue] using hvalue) hleftClean, + finalizeResolvedCoordinates_cons_position_of_known_clean table position + remaining right hview.rightConsistent output + (by simpa [resolvedCompletionValue] using hrightValue) hrightClean] + exact ih (left.completeResolved (.position position) output) + (right.completeResolved (.position position) output) + (hview.completePosition position output) + | none => + have hrightValue : + resolvedCompletionValue table right (.position position) = none := by + rw [← hview.valueEq] + exact hvalue + rw [finalizeResolvedCoordinates_cons_position_of_unknown table position remaining + left (by simpa [resolvedCompletionValue] using hvalue), + finalizeResolvedCoordinates_cons_position_of_unknown table position remaining + right (by simpa [resolvedCompletionValue] using hrightValue)] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + have hpending := hview.pendingEq (.position position) hvalue + have hhit : left.state.hitAt (.position position) output ↔ + right.state.hitAt (.position position) output := by + unfold LazyRevealProbe.State.hitAt + rw [hpending] + by_cases hleftHit : left.state.hitAt (.position position) output + · rw [if_pos hleftHit, if_pos (hhit.mp hleftHit)] + · rw [if_neg hleftHit, if_neg (mt hhit.mpr hleftHit)] + exact ih (left.completeResolved (.position position) output) + (right.completeResolved (.position position) output) + (hview.completePosition position output) + +set_option maxRecDepth 100000 in +theorem finalizationViewEq_materializeResolvedReveal + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (position : Position) (result : DeferredResolution) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (resolveDeferredReveal table position context)) + (hcompletable : DeferredCompletable table + (materializeResolvedPosition context position result)) : + FinalizationViewEq table + (materializeResolvedPosition context position result) + result.toDeferredContext := by + have hresultValid := hvalid.of_resolveDeferredReveal table position result hresult + have hstateValues := resolveDeferredReveal_preserves_state_values table position context result + hresult + have hresolved := resolveDeferredReveal_resolves table position context result hresult + have hvalueEq : resolvedCompletionValue table + (materializeResolvedPosition context position result) = + resolvedCompletionValue table result.toDeferredContext := by + funext coordinate + cases coordinate with + | chainStart => rfl + | position other => + exact congrFun + (materializeResolvedPosition_positionValue_eq context position result hstateValues + hresolved) other + apply finalizationViewEq_of_deferredCompletion_iff + · exact hvalid.materializeResolvedPosition_of position result hresultValid hstateValues + hresolved + · exact hresultValid + · simpa [materializeResolvedPosition] using + hstarts.materialize_position position result.output + · exact hstarts.of_state_values_eq hstateValues + · exact hvalueEq + · exact hcompletable + · intro completion + exact deferredCompletion_materializeResolvedReveal_iff position result hvalid hstarts hresult + +theorem finalizationViewEq_materializeResolvedChainStart + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (index : OtsSecretIndex) (result : DeferredResolution) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hresult : resolveDeferredChainStart table index context = some result) + (hcompletable : DeferredCompletable table + (materializeResolvedChainStart context index result)) : + FinalizationViewEq table + (materializeResolvedChainStart context index result) + result.toDeferredContext := by + have hresultValid := hvalid.of_resolveDeferredChainStart table index result hresult + have hstateValues := resolveDeferredChainStart_state_values_eq table index context result hresult + have hdeferredValues := + resolveDeferredChainStart_deferred_values_eq table index context result hresult + have hpending := resolveDeferredChainStart_pending_eq table index context result hresult + have houtput := resolveDeferredChainStart_output_of_agrees table index context result hstarts + hresult + have hleftValid : (materializeResolvedChainStart context index result).Valid := by + rw [materializeResolvedChainStart, hdeferredValues] + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + exact hvalid.materialize_chainStart lay tree leafIdx chainIdx result.output + have hvalueEq : resolvedCompletionValue table + (materializeResolvedChainStart context index result) = + resolvedCompletionValue table result.toDeferredContext := by + funext coordinate + cases coordinate with + | chainStart => rfl + | position position => + change (materializeResolvedChainStart context index result).positionValue position = + result.toDeferredContext.positionValue position + rw [materializeResolvedChainStart_positionValue_eq table index context result hresult, + resolveDeferredChainStart_positionValue_eq table index context result hresult] + apply finalizationViewEq_of_deferredCompletion_iff + · exact hleftValid + · exact hresultValid + · simpa [materializeResolvedChainStart, houtput] using + hstarts.materialize_start index + · exact hstarts.of_state_values_eq hstateValues + · exact hvalueEq + · exact hcompletable + · intro completion + exact deferredCompletion_materializeResolvedChainStart_iff index result hstarts houtput + hstateValues hdeferredValues hpending + +theorem evalDist_map_isNone_finalizeResolvedCoordinates_materializeResolvedReveal + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (position : Position) (result : DeferredResolution) + (coordinates : List Coordinate) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (resolveDeferredReveal table position context)) + (hcompletable : DeferredCompletable table + (materializeResolvedPosition context position result)) : + evalDist (Option.isNone <$> finalizeResolvedCoordinates coordinates + (materializeResolvedPosition context position result) table) = + evalDist (Option.isNone <$> finalizeResolvedCoordinates coordinates + result.toDeferredContext table) := + evalDist_map_isNone_finalizeResolvedCoordinates_congr table coordinates + (materializeResolvedPosition context position result) result.toDeferredContext + (finalizationViewEq_materializeResolvedReveal position result hvalid hstarts hresult + hcompletable) + +set_option maxRecDepth 100000 in +theorem evalDist_map_isNone_finalizeResolvedCoordinates_completeResolved_of_not_mem + (table : OtsSecretIndex → HashOutput) (coordinates : List Coordinate) + (context : DeferredContext) (coordinate : Coordinate) (output : HashOutput) + (hnotMem : coordinate ∉ coordinates) : + evalDist (Option.isNone <$> finalizeResolvedCoordinates coordinates + (context.completeResolved coordinate output) table) = + evalDist (Option.isNone <$> finalizeResolvedCoordinates coordinates context table) := by + induction coordinates generalizing context with + | nil => simp [finalizeResolvedCoordinates] + | cons head remaining ih => + have hne : head ≠ coordinate := by + intro heq + subst head + exact hnotMem (by simp) + have htail : coordinate ∉ remaining := by + intro hmem + exact hnotMem (List.mem_cons_of_mem head hmem) + have hstateComplete : + (context.completeResolved coordinate output).state.values head = + context.state.values head := by + have hstate : (context.completeResolved coordinate output).state = + context.state.complete coordinate output := by cases coordinate <;> rfl + rw [hstate, values_complete_of_ne context.state coordinate head output hne] + cases hstate : context.state.values head with + | some headOutput => + have hstateLeft : + (context.completeResolved coordinate output).state.values head = + some headOutput := by rw [hstateComplete, hstate] + rw [finalizeResolvedCoordinates_cons_of_state_value head remaining + (context.completeResolved coordinate output) table headOutput hstateLeft, + finalizeResolvedCoordinates_cons_of_state_value head remaining context table + headOutput hstate] + have hcommute := clearPending_completeResolved_comm context head coordinate output + rw [← hcommute] + exact ih { context with state := context.state.clearPending head } htail + | none => + have hstateLeft : + (context.completeResolved coordinate output).state.values head = none := by + rw [hstateComplete, hstate] + rw [finalizeResolvedCoordinates_cons_of_missing head remaining + (context.completeResolved coordinate output) table hstateLeft, + finalizeResolvedCoordinates_cons_of_missing head remaining context table hstate] + rw [resolvedCompletionOutput_completeResolved_of_ne coordinate head context table output + hne] + simp only [map_eq_bind_pure_comp, bind_assoc] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro headOutput + have hleftState : (context.completeResolved coordinate output).state = + context.state.complete coordinate output := by cases coordinate <;> rfl + have hhit : + (context.completeResolved coordinate output).state.hitAt head headOutput ↔ + context.state.hitAt head headOutput := by + rw [hleftState] + exact hitAt_complete_of_ne context.state coordinate head output headOutput hne + by_cases hheadHit : context.state.hitAt head headOutput + · rw [if_pos (hhit.mpr hheadHit), if_pos hheadHit] + · rw [if_neg (mt hhit.mp hheadHit), if_neg hheadHit] + rw [DeferredContext.completeResolved_comm context coordinate head output headOutput + hne.symm] + exact ih (context.completeResolved head headOutput) htail + +set_option maxRecDepth 100000 in +theorem evalDist_map_isNone_finalizeResolvedCoordinates_cons_irrelevant + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (coordinates : List Coordinate) (context : DeferredContext) + (hnotMem : coordinate ∉ coordinates) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hclean : ∀ output, resolvedCompletionValue table context coordinate = some output → + ¬context.state.hitAt coordinate output) + (hunknown : resolvedCompletionValue table context coordinate = none → + context.state.pendingAt coordinate = ∅) : + evalDist (Option.isNone <$> finalizeResolvedCoordinates + (coordinate :: coordinates) context table) = + evalDist (Option.isNone <$> finalizeResolvedCoordinates coordinates context table) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + have hcoordinate : index.coordinate = + Coordinate.chainStart lay tree leafIdx chainIdx := rfl + have hmiss : ¬context.state.hitAt index.coordinate (table index) := + hclean (table index) (by simp [index, resolvedCompletionValue]) + change evalDist (Option.isNone <$> finalizeResolvedCoordinates + (index.coordinate :: coordinates) context table) = _ + rw [finalizeResolvedCoordinates_cons_chainStart_of_clean table index coordinates context + hstarts hmiss] + exact evalDist_map_isNone_finalizeResolvedCoordinates_completeResolved_of_not_mem + table coordinates context index.coordinate (table index) (by simpa [hcoordinate] using hnotMem) + | position position => + cases hvalue : resolvedCompletionValue table context (.position position) with + | some output => + have hmiss := hclean output hvalue + rw [finalizeResolvedCoordinates_cons_position_of_known_clean table position coordinates + context hconsistent output (by simpa [resolvedCompletionValue] using hvalue) hmiss] + exact evalDist_map_isNone_finalizeResolvedCoordinates_completeResolved_of_not_mem + table coordinates context (.position position) output hnotMem + | none => + have hpending := hunknown hvalue + rw [finalizeResolvedCoordinates_cons_position_of_unknown table position coordinates + context (by simpa [resolvedCompletionValue] using hvalue)] + simp only [map_eq_bind_pure_comp, bind_assoc] + calc + evalDist (LazyRevealProbe.sampleHashOutput >>= fun output => + (if context.state.hitAt (.position position) output then pure none + else finalizeResolvedCoordinates coordinates + (context.completeResolved (.position position) output) table) >>= + fun result => pure result.isNone) = + evalDist (LazyRevealProbe.sampleHashOutput >>= fun _ => + Option.isNone <$> finalizeResolvedCoordinates coordinates context table) := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + have hmiss : ¬context.state.hitAt (.position position) output := by + unfold LazyRevealProbe.State.hitAt + rw [hpending] + simp + rw [if_neg hmiss] + exact evalDist_map_isNone_finalizeResolvedCoordinates_completeResolved_of_not_mem + table coordinates context (.position position) output hnotMem + _ = evalDist (Option.isNone <$> + finalizeResolvedCoordinates coordinates context table) := + OracleComp.DeferredSampling.evalDist_bind_const_neverFails + LazyRevealProbe.sampleHashOutput (by simp [LazyRevealProbe.sampleHashOutput]) + (Option.isNone <$> finalizeResolvedCoordinates coordinates context table) + +set_option maxRecDepth 100000 in +theorem evalDist_map_isNone_finalizeResolvedCoordinates_append_irrelevant + (table : OtsSecretIndex → HashOutput) (extra coordinates : List Coordinate) + (context : DeferredContext) (hextraNodup : extra.Nodup) + (hdisjoint : ∀ coordinate, coordinate ∈ extra → coordinate ∉ coordinates) + (hcovered : PendingCovered coordinates context) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hclean : ∀ coordinate output, + resolvedCompletionValue table context coordinate = some output → + ¬context.state.hitAt coordinate output) : + evalDist (Option.isNone <$> finalizeResolvedCoordinates + (extra ++ coordinates) context table) = + evalDist (Option.isNone <$> finalizeResolvedCoordinates coordinates context table) := by + induction extra with + | nil => rfl + | cons coordinate remaining ih => + obtain ⟨hnotRemaining, hremainingNodup⟩ := List.nodup_cons.mp hextraNodup + have hnotCoordinates := hdisjoint coordinate (by simp) + have hnotAppend : coordinate ∉ remaining ++ coordinates := by + simp [hnotRemaining, hnotCoordinates] + have hunknown : resolvedCompletionValue table context coordinate = none → + context.state.pendingAt coordinate = ∅ := by + intro _hvalue + apply Finset.not_nonempty_iff_eq_empty.mp + rintro ⟨candidate, hcandidate⟩ + have hentry : (coordinate, candidate) ∈ context.state.pending := + (LazyRevealProbe.State.mem_pendingAt_iff context.state coordinate candidate).mp + hcandidate + exact hnotCoordinates (hcovered (coordinate, candidate) hentry) + calc + evalDist (Option.isNone <$> finalizeResolvedCoordinates + ((coordinate :: remaining) ++ coordinates) context table) = + evalDist (Option.isNone <$> finalizeResolvedCoordinates + (remaining ++ coordinates) context table) := + evalDist_map_isNone_finalizeResolvedCoordinates_cons_irrelevant table coordinate + (remaining ++ coordinates) context hnotAppend hconsistent hstarts + (hclean coordinate) hunknown + _ = evalDist (Option.isNone <$> + finalizeResolvedCoordinates coordinates context table) := + ih hremainingNodup (fun other hmem => + hdisjoint other (List.mem_cons_of_mem coordinate hmem)) + +set_option maxRecDepth 100000 in +theorem evalDist_map_isNone_finalizeResolvedCoordinates_congr_covered + (table : OtsSecretIndex → HashOutput) + (leftCoordinates rightCoordinates : List Coordinate) + (left right : DeferredContext) (hview : FinalizationViewEq table left right) + (hleftNodup : leftCoordinates.Nodup) (hrightNodup : rightCoordinates.Nodup) + (hleftCovered : PendingCovered leftCoordinates left) + (hrightCovered : PendingCovered rightCoordinates right) : + evalDist (Option.isNone <$> + finalizeResolvedCoordinates leftCoordinates left table) = + evalDist (Option.isNone <$> + finalizeResolvedCoordinates rightCoordinates right table) := by + classical + let leftBase := leftCoordinates.toFinset.toList + let rightBase := rightCoordinates.toFinset.toList + let leftExtra := (rightCoordinates.toFinset \ leftCoordinates.toFinset).toList + let rightExtra := (leftCoordinates.toFinset \ rightCoordinates.toFinset).toList + have hleftBasePerm : leftBase.Perm leftCoordinates := by + simpa [leftBase] using List.toFinset_toList hleftNodup + have hrightBasePerm : rightBase.Perm rightCoordinates := by + simpa [rightBase] using List.toFinset_toList hrightNodup + have hleftBaseCovered : PendingCovered leftBase left := by + intro entry hentry + have hmem := hleftCovered entry hentry + simpa [leftBase] using hmem + have hrightBaseCovered : PendingCovered rightBase right := by + intro entry hentry + have hmem := hrightCovered entry hentry + simpa [rightBase] using hmem + have hleftDisjoint : leftExtra.Disjoint leftBase := by + rw [List.disjoint_left] + intro coordinate hleftExtra hleftBase + simp only [leftExtra, Finset.mem_toList, Finset.mem_sdiff] at hleftExtra + simp only [leftBase, Finset.mem_toList, List.mem_toFinset] at hleftBase + exact hleftExtra.2 (by simpa using hleftBase) + have hrightDisjoint : rightExtra.Disjoint rightBase := by + rw [List.disjoint_left] + intro coordinate hrightExtra hrightBase + simp only [rightExtra, Finset.mem_toList, Finset.mem_sdiff] at hrightExtra + simp only [rightBase, Finset.mem_toList, List.mem_toFinset] at hrightBase + exact hrightExtra.2 (by simpa using hrightBase) + have hleftAugNodup : (leftExtra ++ leftBase).Nodup := + List.Nodup.append (Finset.nodup_toList _) (Finset.nodup_toList _) hleftDisjoint + have hrightAugNodup : (rightExtra ++ rightBase).Nodup := + List.Nodup.append (Finset.nodup_toList _) (Finset.nodup_toList _) hrightDisjoint + have haugPerm : (leftExtra ++ leftBase).Perm (rightExtra ++ rightBase) := by + apply List.perm_of_nodup_nodup_toFinset_eq hleftAugNodup hrightAugNodup + ext coordinate + simp only [List.toFinset_append, leftExtra, rightExtra, leftBase, rightBase, + Finset.toList_toFinset, Finset.mem_union, Finset.mem_sdiff, List.mem_toFinset] + by_cases hleft : coordinate ∈ leftCoordinates <;> + by_cases hright : coordinate ∈ rightCoordinates <;> simp [hleft, hright] + have hleftPermDist : + evalDist (Option.isNone <$> + finalizeResolvedCoordinates leftBase left table) = + evalDist (Option.isNone <$> + finalizeResolvedCoordinates leftCoordinates left table) := by + rw [evalDist_map, evalDist_map, + evalDist_finalizeResolvedCoordinates_perm hleftBasePerm left table] + have hrightPermDist : + evalDist (Option.isNone <$> + finalizeResolvedCoordinates rightBase right table) = + evalDist (Option.isNone <$> + finalizeResolvedCoordinates rightCoordinates right table) := by + rw [evalDist_map, evalDist_map, + evalDist_finalizeResolvedCoordinates_perm hrightBasePerm right table] + have hleftAug := evalDist_map_isNone_finalizeResolvedCoordinates_append_irrelevant + table leftExtra leftBase left (Finset.nodup_toList _) + (by + intro coordinate hleftExtra + simp only [leftExtra, Finset.mem_toList, Finset.mem_sdiff] at hleftExtra + simp only [leftBase, Finset.mem_toList, List.mem_toFinset] + simpa using hleftExtra.2) + hleftBaseCovered hview.leftConsistent hview.leftStarts hview.leftClean + have hrightAug := evalDist_map_isNone_finalizeResolvedCoordinates_append_irrelevant + table rightExtra rightBase right (Finset.nodup_toList _) + (by + intro coordinate hrightExtra + simp only [rightExtra, Finset.mem_toList, Finset.mem_sdiff] at hrightExtra + simp only [rightBase, Finset.mem_toList, List.mem_toFinset] + simpa using hrightExtra.2) + hrightBaseCovered hview.rightConsistent hview.rightStarts hview.rightClean + have hsameAug := evalDist_map_isNone_finalizeResolvedCoordinates_congr table + (leftExtra ++ leftBase) left right hview + have hpermAug : + evalDist (Option.isNone <$> finalizeResolvedCoordinates + (leftExtra ++ leftBase) right table) = + evalDist (Option.isNone <$> finalizeResolvedCoordinates + (rightExtra ++ rightBase) right table) := by + rw [evalDist_map, evalDist_map, + evalDist_finalizeResolvedCoordinates_perm haugPerm right table] + exact hleftPermDist.symm.trans (hleftAug.symm.trans + (hsameAug.trans (hpermAug.trans (hrightAug.trans hrightPermDist)))) + +theorem evalDist_map_isNone_finalizeResolvedCoordinates_materializeResolvedReveal_dynamic + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (position : Position) (result : DeferredResolution) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support + (resolveDeferredReveal table position context)) + (hcompletable : DeferredCompletable table + (materializeResolvedPosition context position result)) : + evalDist (Option.isNone <$> finalizeResolvedCoordinates + (materializeResolvedPosition context position result).state.coordinates.toList + (materializeResolvedPosition context position result) table) = + evalDist (Option.isNone <$> finalizeResolvedCoordinates + result.state.coordinates.toList result.toDeferredContext table) := by + apply evalDist_map_isNone_finalizeResolvedCoordinates_congr_covered table + (materializeResolvedPosition context position result).state.coordinates.toList + result.state.coordinates.toList + (materializeResolvedPosition context position result) result.toDeferredContext + (finalizationViewEq_materializeResolvedReveal position result hvalid hstarts hresult + hcompletable) + · exact Finset.nodup_toList _ + · exact Finset.nodup_toList _ + · exact pendingCovered_coordinates_toList _ + · exact pendingCovered_coordinates_toList _ + +noncomputable def selectDeferredLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (result : ResolvedRunResult DeferredLayerStore) : + ProbComp (Option (ResolvedRunResult DeferredLayerStore)) := do + let selected ← runResolvedFromTable result.context result.remaining table + ((maskedSignLayer parameter ftsSecret index lay).run result.value.cache) + match selected with + | none => pure none + | some selected => pure (some ⟨selected.context, selected.remaining, + { selected := Function.update result.value.selected lay selected.value.1 + resolved := result.value.resolved + cache := selected.value.2 }, table⟩) + +noncomputable def resolveDeferredLayer + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (result : ResolvedRunResult DeferredLayerStore) : + ProbComp (Option (ResolvedRunResult DeferredLayerStore)) := + match result.value.selected lay with + | none => pure (some ⟨result.context, result.remaining, + { result.value with resolved := Function.update result.value.resolved lay none }, + table⟩) + | some (counter, encoding) => do + let resolved ← resolveDeferredLayerValues table index lay encoding result.context + match resolved with + | none => pure none + | some (context, values) => + let part : LayerPart := (counter, values.1, values.2) + pure (some ⟨context, result.remaining, + { result.value with + resolved := Function.update result.value.resolved lay (some part) }, table⟩) + +def mapResolvedLayerSchedule + (table : OtsSecretIndex → HashOutput) + (resolvedLay selectedLay : Layer) (counter : Counter) + (store : DeferredLayerStore) : + Option (ResolvedRunResult (DeferredLayerValues × DeferredLayerSelection)) → + Option (ResolvedRunResult DeferredLayerStore) + | none => none + | some result => some ⟨result.context, result.remaining, + { selected := Function.update store.selected selectedLay result.value.2.1 + resolved := Function.update store.resolved resolvedLay + (some (counter, result.value.1.1, result.value.1.2)) + cache := result.value.2.2 }, table⟩ + +theorem evalDist_resolveDeferredLayer_then_selectDeferredLayer_eq + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (hlt : resolvedLay.val < selectedLay.val) + (result : ResolvedRunResult DeferredLayerStore) : + evalDist (resolveDeferredLayer table index resolvedLay result >>= fun resolved => + match resolved with + | none => pure none + | some resolved => selectDeferredLayer parameter table ftsSecret index selectedLay resolved) = + evalDist (selectDeferredLayer parameter table ftsSecret index selectedLay result >>= + fun selected => + match selected with + | none => pure none + | some selected => resolveDeferredLayer table index resolvedLay selected) := by + classical + have hne : selectedLay ≠ resolvedLay := by + intro heq + subst selectedLay + omega + have hne' : resolvedLay ≠ selectedLay := Ne.symm hne + cases hselected : result.value.selected resolvedLay with + | none => + rw [resolveDeferredLayer] + simp only [hselected, pure_bind] + unfold selectDeferredLayer + simp only [bind_assoc] + apply congrArg evalDist + apply bind_congr + intro selectedOption + cases selectedOption with + | none => rfl + | some selected => + simp only [pure_bind] + rw [resolveDeferredLayer] + simp [Function.update, hne', hselected] + | some selected => + rcases selected with ⟨counter, encoding⟩ + have hleft : + (resolveDeferredLayer table index resolvedLay result >>= fun resolved => + match resolved with + | none => pure none + | some resolved => + selectDeferredLayer parameter table ftsSecret index selectedLay resolved) = + (mapResolvedLayerSchedule table resolvedLay selectedLay counter result.value <$> + resolveThenSelectLayer parameter table ftsSecret index resolvedLay selectedLay + encoding result.context result.remaining result.value.cache) := by + unfold resolveDeferredLayer resolveThenSelectLayer selectDeferredLayer + simp only [hselected, map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro resolvedOption + cases resolvedOption with + | none => simp [mapResolvedLayerSchedule] + | some resolved => + rcases resolved with ⟨resolvedContext, values⟩ + simp only [pure_bind] + rw [bind_assoc] + apply bind_congr + intro selectedOption + cases selectedOption <;> rfl + have hright : + (selectDeferredLayer parameter table ftsSecret index selectedLay result >>= + fun selected => + match selected with + | none => pure none + | some selected => resolveDeferredLayer table index resolvedLay selected) = + (mapResolvedLayerSchedule table resolvedLay selectedLay counter result.value <$> + selectThenResolveLayer parameter table ftsSecret index resolvedLay selectedLay + encoding result.context result.remaining result.value.cache) := by + unfold selectDeferredLayer selectThenResolveLayer + simp only [map_eq_bind_pure_comp, bind_assoc] + apply bind_congr + intro selectedOption + cases selectedOption with + | none => simp [mapResolvedLayerSchedule] + | some selected => + simp only [pure_bind] + rw [resolveDeferredLayer] + simp [Function.update, hne', hselected] + apply bind_congr + intro resolvedOption + cases resolvedOption <;> rfl + rw [hleft, hright] + rw [evalDist_map, evalDist_map, + evalDist_resolveThenSelectLayer_eq_selectThenResolveLayer_of_lt parameter table + ftsSecret index resolvedLay selectedLay hlt encoding result.context result.remaining + result.value.cache] + +inductive DeferredLayerOperation where + | select (lay : Layer) + | resolve (lay : Layer) + +noncomputable def runDeferredLayerOperation + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (operation : DeferredLayerOperation) : + Option (ResolvedRunResult DeferredLayerStore) → + ProbComp (Option (ResolvedRunResult DeferredLayerStore)) + | none => pure none + | some result => + match operation with + | .select lay => selectDeferredLayer parameter table ftsSecret index lay result + | .resolve lay => resolveDeferredLayer table index lay result + +noncomputable def runDeferredLayerSchedule + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) : + List DeferredLayerOperation → Option (ResolvedRunResult DeferredLayerStore) → + ProbComp (Option (ResolvedRunResult DeferredLayerStore)) + | [], input => pure input + | operation :: remaining, input => do + let result ← runDeferredLayerOperation parameter table ftsSecret index operation input + runDeferredLayerSchedule parameter table ftsSecret index remaining result + +@[simp] theorem runDeferredLayerSchedule_none + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) : + ∀ operations : List DeferredLayerOperation, + runDeferredLayerSchedule parameter table ftsSecret index operations none = pure none + | [] => rfl + | _ :: operations => by + simp [runDeferredLayerSchedule, runDeferredLayerOperation, + runDeferredLayerSchedule_none parameter table ftsSecret index operations] + +theorem evalDist_runDeferredLayerSchedule_adjacent + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (hlt : resolvedLay.val < selectedLay.val) + (remaining : List DeferredLayerOperation) + (input : Option (ResolvedRunResult DeferredLayerStore)) : + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + (.resolve resolvedLay :: .select selectedLay :: remaining) input) = + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + (.select selectedLay :: .resolve resolvedLay :: remaining) input) := by + cases input with + | none => simp [runDeferredLayerSchedule, runDeferredLayerOperation] + | some result => + simp only [runDeferredLayerSchedule, runDeferredLayerOperation] + simp only [← bind_assoc] + have hswap := evalDist_resolveDeferredLayer_then_selectDeferredLayer_eq parameter table + ftsSecret index resolvedLay selectedLay hlt result + rw [evalDist_bind, evalDist_bind] at hswap + rw [evalDist_bind, evalDist_bind, hswap] + rw [evalDist_bind] + rw [evalDist_bind] + +theorem evalDist_runDeferredLayerSchedule_swap + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (resolvedLay selectedLay : Layer) (hlt : resolvedLay.val < selectedLay.val) + (before remaining : List DeferredLayerOperation) + (input : Option (ResolvedRunResult DeferredLayerStore)) : + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + (before ++ .resolve resolvedLay :: .select selectedLay :: remaining) input) = + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + (before ++ .select selectedLay :: .resolve resolvedLay :: remaining) input) := by + induction before generalizing input with + | nil => + simpa using evalDist_runDeferredLayerSchedule_adjacent parameter table ftsSecret index + resolvedLay selectedLay hlt remaining input + | cons operation before ih => + simp only [List.cons_append, runDeferredLayerSchedule] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro result + exact ih result + +theorem runDeferredLayerSchedule_append + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (before after : List DeferredLayerOperation) + (input : Option (ResolvedRunResult DeferredLayerStore)) : + runDeferredLayerSchedule parameter table ftsSecret index (before ++ after) input = + (runDeferredLayerSchedule parameter table ftsSecret index before input >>= fun result => + runDeferredLayerSchedule parameter table ftsSecret index after result) := by + induction before generalizing input with + | nil => simp [runDeferredLayerSchedule] + | cons operation before ih => + simp only [List.cons_append, runDeferredLayerSchedule, bind_assoc] + apply bind_congr + intro result + exact ih result + +def chronologicalLayerSchedule : List DeferredLayerOperation := + [.select topLayer, .resolve topLayer, + .select middleLayer, .resolve middleLayer, + .select bottomLayer, .resolve bottomLayer] + +def deferredLayerSchedule : List DeferredLayerOperation := + [.select topLayer, .select middleLayer, .select bottomLayer, + .resolve topLayer, .resolve middleLayer, .resolve bottomLayer] + +def deferredLayerSelections : List DeferredLayerOperation := + [topLayer, middleLayer, bottomLayer].map DeferredLayerOperation.select + +def deferredLayerResolutions : List DeferredLayerOperation := + [topLayer, middleLayer, bottomLayer].map DeferredLayerOperation.resolve + +theorem deferredLayerSchedule_eq_append : + deferredLayerSchedule = deferredLayerSelections ++ deferredLayerResolutions := by + simp [deferredLayerSchedule, deferredLayerSelections, deferredLayerResolutions] + +theorem evalDist_chronologicalLayerSchedule_eq_deferred + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (input : Option (ResolvedRunResult DeferredLayerStore)) : + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + chronologicalLayerSchedule input) = + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + deferredLayerSchedule input) := by + have h01 : topLayer.val < middleLayer.val := by decide + have h12 : middleLayer.val < bottomLayer.val := by decide + have h02 : topLayer.val < bottomLayer.val := by decide + calc + _ = evalDist (runDeferredLayerSchedule parameter table ftsSecret index + [.select topLayer, .select middleLayer, .resolve topLayer, + .resolve middleLayer, .select bottomLayer, .resolve bottomLayer] input) := by + simpa [chronologicalLayerSchedule] using + evalDist_runDeferredLayerSchedule_swap parameter table ftsSecret index topLayer + middleLayer h01 [.select topLayer] + [.resolve middleLayer, .select bottomLayer, .resolve bottomLayer] input + _ = evalDist (runDeferredLayerSchedule parameter table ftsSecret index + [.select topLayer, .select middleLayer, .resolve topLayer, + .select bottomLayer, .resolve middleLayer, .resolve bottomLayer] input) := by + simpa using + evalDist_runDeferredLayerSchedule_swap parameter table ftsSecret index middleLayer + bottomLayer h12 [.select topLayer, .select middleLayer, .resolve topLayer] + [.resolve bottomLayer] input + _ = evalDist (runDeferredLayerSchedule parameter table ftsSecret index + deferredLayerSchedule input) := by + simpa [deferredLayerSchedule] using + evalDist_runDeferredLayerSchedule_swap parameter table ftsSecret index topLayer + bottomLayer h02 [.select topLayer, .select middleLayer] + [.resolve middleLayer, .resolve bottomLayer] input + +theorem evalDist_chronologicalLayerSchedule_bind_eq_deferred + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (input : Option (ResolvedRunResult DeferredLayerStore)) + (next : Option (ResolvedRunResult DeferredLayerStore) → ProbComp α) : + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + chronologicalLayerSchedule input >>= next) = + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + deferredLayerSchedule input >>= next) := by + rw [evalDist_bind, evalDist_bind, + evalDist_chronologicalLayerSchedule_eq_deferred parameter table ftsSecret index input] + +noncomputable def finalizeDeferredLayerSchedule + (coordinates : List Coordinate) : + Option (ResolvedRunResult DeferredLayerStore) → + ProbComp (Option (LazyRevealProbe.State Coordinate)) + | none => pure none + | some result => projectDeferredState <$> + finalizeResolvedCoordinates coordinates result.context result.table + +set_option maxRecDepth 100000 in +theorem evalDist_resolveDeferredLayerSchedule_then_finalize + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (coordinates : List Coordinate) : + ∀ (layers : List Layer) (result : ResolvedRunResult DeferredLayerStore), + result.table = table → result.context.Valid → + PendingCovered coordinates result.context → + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + (layers.map DeferredLayerOperation.resolve) (some result) >>= + finalizeDeferredLayerSchedule coordinates) = + evalDist (projectDeferredState <$> + finalizeResolvedCoordinates coordinates result.context result.table) + | [], result, htable, hvalid, hcovered => by + simp [runDeferredLayerSchedule, finalizeDeferredLayerSchedule] + | lay :: layers, result, htable, hvalid, hcovered => by + subst table + simp only [List.map_cons, runDeferredLayerSchedule, runDeferredLayerOperation] + rw [resolveDeferredLayer] + cases hselected : result.value.selected lay with + | none => + simp only [pure_bind] + exact evalDist_resolveDeferredLayerSchedule_then_finalize parameter result.table ftsSecret + index coordinates layers + { result with + value := + { result.value with + resolved := Function.update result.value.resolved lay none } } + rfl hvalid hcovered + | some selected => + rcases selected with ⟨counter, encoding⟩ + simp only [bind_assoc] + calc + _ = evalDist (resolveDeferredLayerValues result.table index lay encoding result.context >>= + fun resolved => + match resolved with + | none => pure none + | some (finalContext, _) => projectDeferredState <$> + finalizeResolvedCoordinates coordinates finalContext result.table) := by + apply evalDist_bind_congr + intro resolved hresolved + cases resolved with + | none => + simp [finalizeDeferredLayerSchedule] + | some resolved => + rcases resolved with ⟨finalContext, values⟩ + simp only [pure_bind] + have hfinalValid := hvalid.of_resolveDeferredLayerValues result.table index lay + encoding finalContext values hresolved + have hfinalCovered := hcovered.of_resolveDeferredLayerValues result.table index lay + encoding finalContext values hresolved + simpa only using + (evalDist_resolveDeferredLayerSchedule_then_finalize parameter result.table + ftsSecret index coordinates layers + { context := finalContext + remaining := result.remaining + value := + { result.value with + resolved := Function.update result.value.resolved lay + (some (counter, values.1, values.2)) } + table := result.table } + rfl hfinalValid hfinalCovered) + _ = _ := evalDist_map_resolveDeferredLayerValues_then_finalize result.table index lay + encoding coordinates result.context hvalid hcovered + +theorem valid_pendingCovered_of_mem_selectDeferredLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (coordinates : List Coordinate) + (result output : ResolvedRunResult DeferredLayerStore) + (hvalid : result.context.Valid) (hcovered : PendingCovered coordinates result.context) + (houtput : some output ∈ support + (selectDeferredLayer parameter table ftsSecret index lay result)) : + output.table = table ∧ output.context.Valid ∧ + PendingCovered coordinates output.context := by + unfold selectDeferredLayer at houtput + rw [mem_support_bind_iff] at houtput + obtain ⟨selectedOption, hselected, hreturn⟩ := houtput + cases selectedOption with + | none => simp at hreturn + | some selected => + simp only [support_pure, Set.mem_singleton_iff] at hreturn + have houtputEq := Option.some.inj hreturn + subst output + have hinvariants := valid_pendingCovered_of_mem_runResolvedFromTable_of_probeFree + ((maskedSignLayer parameter ftsSecret index lay).run result.value.cache) + result.context result.remaining table selected coordinates + (maskedSignLayer_probeFree parameter ftsSecret index lay result.value.cache) + hvalid hcovered hselected + exact ⟨rfl, hinvariants⟩ + +theorem valid_pendingCovered_of_mem_runDeferredLayerSelections + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (coordinates : List Coordinate) : + ∀ (layers : List Layer) (result output : ResolvedRunResult DeferredLayerStore), + result.table = table → result.context.Valid → + PendingCovered coordinates result.context → + some output ∈ support + (runDeferredLayerSchedule parameter table ftsSecret index + (layers.map DeferredLayerOperation.select) (some result)) → + output.table = table ∧ output.context.Valid ∧ + PendingCovered coordinates output.context + | [], result, output, htable, hvalid, hcovered, houtput => by + simp [runDeferredLayerSchedule] at houtput + subst output + exact ⟨htable, hvalid, hcovered⟩ + | lay :: layers, result, output, htable, hvalid, hcovered, houtput => by + simp only [List.map_cons, runDeferredLayerSchedule, runDeferredLayerOperation, + mem_support_bind_iff] at houtput + obtain ⟨selectedOption, hselected, htail⟩ := houtput + cases selectedOption with + | none => simp at htail + | some selected => + have hinvariants := valid_pendingCovered_of_mem_selectDeferredLayer parameter table + ftsSecret index lay coordinates result selected hvalid hcovered hselected + exact valid_pendingCovered_of_mem_runDeferredLayerSelections parameter table ftsSecret + index coordinates layers selected output hinvariants.1 hinvariants.2.1 + hinvariants.2.2 htail + +set_option maxRecDepth 100000 in +theorem evalDist_selectThenResolveDeferredLayerSchedule_then_finalize + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (coordinates : List Coordinate) (layers : List Layer) + (result : ResolvedRunResult DeferredLayerStore) + (htable : result.table = table) (hvalid : result.context.Valid) + (hcovered : PendingCovered coordinates result.context) : + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + ((layers.map DeferredLayerOperation.select) ++ + layers.map DeferredLayerOperation.resolve) (some result) >>= + finalizeDeferredLayerSchedule coordinates) = + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + (layers.map DeferredLayerOperation.select) (some result) >>= + finalizeDeferredLayerSchedule coordinates) := by + rw [runDeferredLayerSchedule_append, bind_assoc] + apply evalDist_bind_congr + intro selectedOption hselected + cases selectedOption with + | none => simp [finalizeDeferredLayerSchedule] + | some selected => + have hinvariants : selected.table = table ∧ selected.context.Valid ∧ + PendingCovered coordinates selected.context := + valid_pendingCovered_of_mem_runDeferredLayerSelections parameter table ftsSecret index + coordinates layers result selected htable hvalid hcovered hselected + exact evalDist_resolveDeferredLayerSchedule_then_finalize parameter table ftsSecret index + coordinates layers selected hinvariants.1 + hinvariants.2.1 hinvariants.2.2 + +set_option maxRecDepth 100000 in +theorem evalDist_deferredLayerSchedule_then_finalize_eq_selections + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (coordinates : List Coordinate) (result : ResolvedRunResult DeferredLayerStore) + (htable : result.table = table) (hvalid : result.context.Valid) + (hcovered : PendingCovered coordinates result.context) : + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + deferredLayerSchedule (some result) >>= finalizeDeferredLayerSchedule coordinates) = + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + deferredLayerSelections (some result) >>= finalizeDeferredLayerSchedule coordinates) := by + rw [deferredLayerSchedule_eq_append] + exact evalDist_selectThenResolveDeferredLayerSchedule_then_finalize parameter table ftsSecret + index coordinates [topLayer, middleLayer, bottomLayer] result htable hvalid hcovered + +noncomputable def runResolvedSequenceFin + {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) : + ProbComp (Option (ResolvedRunResult ((Fin n → α) × SplitHashCache))) := + match n with + | 0 => pure (some ⟨context, fuel, (Fin.elim0, cache), table⟩) + | n + 1 => do + let head ← runResolvedFromTable context fuel table ((computation 0).run cache) + match head with + | none => pure none + | some head => do + let tail ← runResolvedSequenceFin + (fun position : Fin n => computation position.succ) + head.context head.remaining table head.value.2 + match tail with + | none => pure none + | some tail => pure (some ⟨tail.context, tail.remaining, + (Fin.cases head.value.1 tail.value.1, tail.value.2), table⟩) + +set_option maxRecDepth 100000 in +theorem evalDist_runResolvedSequenceFin_eq + {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + evalDist (runResolvedSequenceFin computation context fuel table cache) = + evalDist (runResolvedFromTable context fuel table + ((sequenceFin computation).run cache)) := by + induction n generalizing context fuel cache with + | zero => simp [runResolvedSequenceFin, sequenceFin, runResolvedFromTable] + | succ n ih => + rw [runResolvedSequenceFin, sequenceFin, StateT.run_bind, + runResolvedFromTable_bind] + apply evalDist_bind_congr + intro headOption hhead + cases headOption with + | none => simp + | some head => + have hcore := resolvedCore_of_mem_runResolvedFromTable + ((computation 0).run cache) context fuel table head hconsistent hstarts hhead + simp only + rw [hcore.1, StateT.run_bind, runResolvedFromTable_bind] + simp only [StateT.run_pure] + rw [evalDist_bind, ih (fun position : Fin n => computation position.succ) + head.context head.remaining head.value.2 hcore.2.1 hcore.2.2, ← evalDist_bind] + apply evalDist_bind_congr + intro tailOption htail + cases tailOption with + | none => simp + | some tail => + have htailCore := resolvedCore_of_mem_runResolvedFromTable + ((sequenceFin fun position : Fin n => computation position.succ).run + head.value.2) + head.context head.remaining table tail hcore.2.1 hcore.2.2 htail + simp [runResolvedFromTable, htailCore.1] + +noncomputable def finalizeResolvedRunState + (coordinates : List Coordinate) : + Option (ResolvedRunResult α) → + ProbComp (Option (LazyRevealProbe.State Coordinate)) + | none => pure none + | some result => projectDeferredState <$> + finalizeResolvedCoordinates coordinates result.context result.table + +noncomputable def finalizeResolvedRunStateFromTable + (coordinates : List Coordinate) (table : OtsSecretIndex → HashOutput) : + Option (ResolvedRunResult α) → + ProbComp (Option (LazyRevealProbe.State Coordinate)) + | none => pure none + | some result => projectDeferredState <$> + finalizeResolvedCoordinates coordinates result.context table + +noncomputable def runResolvedLayerList + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) : + List Layer → DeferredContext → Nat → SplitHashCache → + ProbComp (Option (ResolvedRunResult SplitHashCache)) + | [], context, fuel, cache => pure (some ⟨context, fuel, cache, table⟩) + | lay :: layers, context, fuel, cache => do + let selected ← runResolvedFromTable context fuel table + ((maskedSignLayer parameter ftsSecret index lay).run cache) + match selected with + | none => pure none + | some selected => + runResolvedLayerList parameter table ftsSecret index layers selected.context + selected.remaining selected.value.2 + +set_option maxRecDepth 100000 in +theorem evalDist_runDeferredLayerSelections_then_finalize_eq_list + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (coordinates : List Coordinate) : + ∀ (layers : List Layer) (result : ResolvedRunResult DeferredLayerStore), + result.table = table → + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + (layers.map DeferredLayerOperation.select) (some result) >>= + finalizeDeferredLayerSchedule coordinates) = + evalDist (runResolvedLayerList parameter table ftsSecret index layers + result.context result.remaining result.value.cache >>= + finalizeResolvedRunStateFromTable coordinates table) + | [], result, htable => by + simp only [List.map_nil, runDeferredLayerSchedule, pure_bind, + finalizeDeferredLayerSchedule, runResolvedLayerList, + finalizeResolvedRunStateFromTable] + rw [htable] + | lay :: layers, result, _htable => by + simp only [List.map_cons, runDeferredLayerSchedule, runDeferredLayerOperation, + selectDeferredLayer, runResolvedLayerList, bind_assoc] + apply evalDist_bind_congr + intro selectedOption _hselected + cases selectedOption with + | none => simp [finalizeDeferredLayerSchedule, finalizeResolvedRunStateFromTable] + | some selected => + simp only [pure_bind] + exact evalDist_runDeferredLayerSelections_then_finalize_eq_list parameter table + ftsSecret index coordinates layers + { context := selected.context + remaining := selected.remaining + value := + { selected := Function.update result.value.selected lay selected.value.1 + resolved := result.value.resolved + cache := selected.value.2 } + table := table } rfl + +noncomputable def runResolvedSequenceFinDiscard + {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) : + ProbComp (Option (ResolvedRunResult SplitHashCache)) := + match n with + | 0 => pure (some ⟨context, fuel, cache, table⟩) + | n + 1 => do + let head ← runResolvedFromTable context fuel table ((computation 0).run cache) + match head with + | none => pure none + | some head => + runResolvedSequenceFinDiscard + (fun position : Fin n => computation position.succ) + head.context head.remaining table head.value.2 + +set_option maxRecDepth 100000 in +theorem evalDist_runResolvedSequenceFin_then_finalize_eq_discard + {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (cache : SplitHashCache) (coordinates : List Coordinate) : + evalDist (runResolvedSequenceFin computation context fuel table cache >>= + finalizeResolvedRunStateFromTable coordinates table) = + evalDist (runResolvedSequenceFinDiscard computation context fuel table cache >>= + finalizeResolvedRunStateFromTable coordinates table) := by + induction n generalizing context fuel cache with + | zero => simp [runResolvedSequenceFin, runResolvedSequenceFinDiscard, + finalizeResolvedRunStateFromTable] + | succ n ih => + simp only [runResolvedSequenceFin, runResolvedSequenceFinDiscard, bind_assoc] + apply evalDist_bind_congr + intro headOption _hhead + cases headOption with + | none => simp [finalizeResolvedRunStateFromTable] + | some head => + calc + _ = evalDist (runResolvedSequenceFin + (fun position : Fin n => computation position.succ) + head.context head.remaining table head.value.2 >>= + finalizeResolvedRunStateFromTable coordinates table) := by + simp only [bind_assoc] + apply evalDist_bind_congr + intro tailOption _htail + cases tailOption <;> + simp [finalizeResolvedRunStateFromTable] + _ = _ := ih (fun position : Fin n => computation position.succ) + head.context head.remaining head.value.2 + +set_option maxRecDepth 100000 in +theorem runResolvedSequenceFinDiscard_layers_eq_list + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + runResolvedSequenceFinDiscard + (fun lay : Layer => maskedSignLayer parameter ftsSecret index lay) + context fuel table cache = + runResolvedLayerList parameter table ftsSecret index + [topLayer, middleLayer, bottomLayer] context fuel cache := by + simp [runResolvedSequenceFinDiscard, runResolvedLayerList, numLayers, + topLayer, middleLayer, bottomLayer] + apply bind_congr + intro topOption + cases topOption with + | none => rfl + | some top => + apply bind_congr + intro middleOption + cases middleOption with + | none => rfl + | some middle => + apply bind_congr + intro bottomOption + cases bottomOption <;> rfl + +set_option maxRecDepth 100000 in +theorem evalDist_deferredLayerSelections_then_finalize_eq_sequenceFin + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (coordinates : List Coordinate) (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + deferredLayerSelections + (some ⟨context, fuel, emptyDeferredLayerStore cache, table⟩) >>= + finalizeDeferredLayerSchedule coordinates) = + evalDist (runResolvedFromTable context fuel table + ((sequenceFin fun lay : Layer => + maskedSignLayer parameter ftsSecret index lay).run cache) >>= + finalizeResolvedRunStateFromTable coordinates table) := by + calc + _ = evalDist (runResolvedLayerList parameter table ftsSecret index + [topLayer, middleLayer, bottomLayer] context fuel cache >>= + finalizeResolvedRunStateFromTable coordinates table) := + evalDist_runDeferredLayerSelections_then_finalize_eq_list parameter table ftsSecret + index coordinates [topLayer, middleLayer, bottomLayer] + ⟨context, fuel, emptyDeferredLayerStore cache, table⟩ rfl + _ = evalDist (runResolvedSequenceFinDiscard + (fun lay : Layer => maskedSignLayer parameter ftsSecret index lay) + context fuel table cache >>= finalizeResolvedRunStateFromTable coordinates table) := by + rw [runResolvedSequenceFinDiscard_layers_eq_list] + _ = evalDist (runResolvedSequenceFin + (fun lay : Layer => maskedSignLayer parameter ftsSecret index lay) + context fuel table cache >>= finalizeResolvedRunStateFromTable coordinates table) := + (evalDist_runResolvedSequenceFin_then_finalize_eq_discard + (fun lay : Layer => maskedSignLayer parameter ftsSecret index lay) + context fuel table cache coordinates).symm + _ = _ := by + rw [evalDist_bind, + evalDist_runResolvedSequenceFin_eq + (fun lay : Layer => maskedSignLayer parameter ftsSecret index lay) + context fuel table cache hconsistent hstarts, ← evalDist_bind] + +set_option maxRecDepth 100000 in +theorem evalDist_chronologicalLayerSchedule_then_finalize_eq_sequenceFin + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (coordinates : List Coordinate) (hvalid : context.Valid) + (hcovered : PendingCovered coordinates context) + (hstarts : StartTableAgrees context.state table) : + evalDist (runDeferredLayerSchedule parameter table ftsSecret index + chronologicalLayerSchedule + (some ⟨context, fuel, emptyDeferredLayerStore cache, table⟩) >>= + finalizeDeferredLayerSchedule coordinates) = + evalDist (runResolvedFromTable context fuel table + ((sequenceFin fun lay : Layer => + maskedSignLayer parameter ftsSecret index lay).run cache) >>= + finalizeResolvedRunStateFromTable coordinates table) := by + calc + _ = evalDist (runDeferredLayerSchedule parameter table ftsSecret index + deferredLayerSchedule + (some ⟨context, fuel, emptyDeferredLayerStore cache, table⟩) >>= + finalizeDeferredLayerSchedule coordinates) := + evalDist_chronologicalLayerSchedule_bind_eq_deferred parameter table ftsSecret index + (some ⟨context, fuel, emptyDeferredLayerStore cache, table⟩) + (finalizeDeferredLayerSchedule coordinates) + _ = evalDist (runDeferredLayerSchedule parameter table ftsSecret index + deferredLayerSelections + (some ⟨context, fuel, emptyDeferredLayerStore cache, table⟩) >>= + finalizeDeferredLayerSchedule coordinates) := + evalDist_deferredLayerSchedule_then_finalize_eq_selections parameter table ftsSecret + index coordinates ⟨context, fuel, emptyDeferredLayerStore cache, table⟩ rfl hvalid + hcovered + _ = _ := evalDist_deferredLayerSelections_then_finalize_eq_sequenceFin parameter table + ftsSecret index context fuel cache coordinates hvalid.valuesConsistent hstarts + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedSelectionFinalization.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedSelectionFinalization.lean new file mode 100644 index 00000000..761d0390 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedSelectionFinalization.lean @@ -0,0 +1,868 @@ +import SphincsSecurity.Proof.OtsProbeResolvedFinalization + +/-! +# Finalization equivalence through one-time layer selection + +Layer selection may materialize the lower layer root before selecting a counter. This file lifts +the finalization view through those materializing computations while retaining exact public outputs +and ordinary-cache behavior. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +def FinalizationMaterializedRunEq (table : OtsSecretIndex → HashOutput) : + Option (ResolvedRunResult (α × SplitHashCache)) → + Option (ResolvedRunResult (α × SplitHashCache)) → Prop + | none, none => True + | some left, some right => + left.value.1 = right.value.1 ∧ + FinalizationContextEq table (some left.context) (some right.context) ∧ + left.remaining = right.remaining ∧ + left.table = table ∧ right.table = table ∧ + ordinaryQueryCache left.value.2 = ordinaryQueryCache right.value.2 ∧ + left.context.state.revealed = right.context.state.revealed + | _, _ => False + +def FinalizationMaterializedCouples (table : OtsSecretIndex → HashOutput) + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ left right fuel leftCache rightCache, + FinalizationContextEq table (some left) (some right) → + ordinaryQueryCache leftCache = ordinaryQueryCache rightCache → + left.state.revealed = right.state.revealed → + RelTriple + (runResolvedFromTable left fuel table (computation.run leftCache)) + (runResolvedFromTable right fuel table (computation.run rightCache)) + (FinalizationMaterializedRunEq table) + +theorem finalizationMaterializedCouples_pure + (table : OtsSecretIndex → HashOutput) (value : α) : + FinalizationMaterializedCouples table + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) := by + intro left right fuel leftCache rightCache hcontext hcache hrevealed + simp [StateT.run_pure, runResolvedFromTable, FinalizationMaterializedRunEq, + hcontext, hcache, hrevealed] + +theorem FinalizationMaterializedCouples.bind + {table : OtsSecretIndex → HashOutput} + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : FinalizationMaterializedCouples table left) + (hnext : ∀ value, FinalizationMaterializedCouples table (next value)) : + FinalizationMaterializedCouples table (left >>= next) := by + intro leftContext rightContext fuel leftCache rightCache hcontext hcache hrevealed + rw [StateT.run_bind, StateT.run_bind, runResolvedFromTable_bind, + runResolvedFromTable_bind] + apply relTriple_bind + (hleft leftContext rightContext fuel leftCache rightCache hcontext hcache hrevealed) + intro leftResult rightResult hresult + cases leftResult with + | none => + cases rightResult with + | none => simp [FinalizationMaterializedRunEq] + | some rightResult => simp [FinalizationMaterializedRunEq] at hresult + | some leftResult => + cases rightResult with + | none => simp [FinalizationMaterializedRunEq] at hresult + | some rightResult => + rcases leftResult with ⟨leftContext, leftFuel, leftValue, leftTable⟩ + rcases rightResult with ⟨rightContext, rightFuel, rightValue, rightTable⟩ + rcases leftValue with ⟨leftOutput, leftCache⟩ + rcases rightValue with ⟨rightOutput, rightCache⟩ + simp only [FinalizationMaterializedRunEq] at hresult + rcases hresult with + ⟨houtput, hcontext, hfuel, hleftTable, hrightTable, hcache, hrevealed⟩ + subst rightOutput + subst rightFuel + subst leftTable + subst rightTable + exact hnext leftOutput leftContext rightContext leftFuel leftCache + rightCache hcontext hcache hrevealed + +theorem FinalizationViewEq.ensure + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewEq table left right) (coordinate : Coordinate) : + FinalizationViewEq table + { left with state := left.state.ensure coordinate } + { right with state := right.state.ensure coordinate } := by + refine ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · change left.ValuesConsistent + exact hview.leftConsistent + · change right.ValuesConsistent + exact hview.rightConsistent + · change StartTableAgrees left.state table + exact hview.leftStarts + · change StartTableAgrees right.state table + exact hview.rightStarts + · change resolvedCompletionValue table left = resolvedCompletionValue table right + exact hview.valueEq + · intro other output hvalue + change ¬left.state.hitAt other output + apply hview.leftClean other output + change resolvedCompletionValue table left other = some output at hvalue + exact hvalue + · intro other output hvalue + change ¬right.state.hitAt other output + apply hview.rightClean other output + change resolvedCompletionValue table right other = some output at hvalue + exact hvalue + · intro other hvalue + change left.state.pendingAt other = right.state.pendingAt other + apply hview.pendingEq other + change resolvedCompletionValue table left other = none at hvalue + exact hvalue + +theorem DeferredCompletable.ensure + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hcompletable : DeferredCompletable table context) (coordinate : Coordinate) : + DeferredCompletable table + { context with state := context.state.ensure coordinate } := by + rcases hcompletable with ⟨completion, hcompletion⟩ + rcases hcompletion with ⟨hstate, hprivate, hpending, htable⟩ + exact ⟨completion, ⟨hstate, hprivate, hpending, htable⟩⟩ + +theorem finalizationMaterializedCouples_ensureCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + FinalizationMaterializedCouples table (ensureCoordinate coordinate) := by + intro left right fuel leftCache rightCache hcontext hcache hrevealed + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + unfold ensureCoordinate + simp only [StateT.run_liftM, LazyRevealProbe.ensureQuery, runResolvedFromTable] + apply relTriple_pure_pure + exact ⟨rfl, + ⟨hview.ensure coordinate, hleftValid.ensure coordinate, + hrightValid.ensure coordinate, hleftCompletable.ensure coordinate⟩, + rfl, rfl, rfl, hcache, hrevealed⟩ + +theorem finalizationMaterializedCouples_sequenceFin + {table : OtsSecretIndex → HashOutput} {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ position, + FinalizationMaterializedCouples table (computation position)) : + FinalizationMaterializedCouples table (sequenceFin computation) := by + induction n with + | zero => + simpa [sequenceFin] using + (finalizationMaterializedCouples_pure table Fin.elim0 : + FinalizationMaterializedCouples table + (pure Fin.elim0 : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Fin 0 → α))) + | succ n ih => + rw [sequenceFin] + apply (hcomponent 0).bind + intro head + apply (ih (fun position : Fin n => computation position.succ) + (fun position => hcomponent position.succ)).bind + intro tail + exact finalizationMaterializedCouples_pure table + (Fin.cases head tail : Fin (n + 1) → α) + +theorem finalizationMaterializedCouples_splitHashQuery_ordinary + (table : OtsSecretIndex → HashOutput) (input : HashInput) : + FinalizationMaterializedCouples table + (splitHashQuery (.ordinary input)) := by + intro left right fuel leftCache rightCache hcontext hcache hrevealed + rw [splitHashQuery_run_eq, splitHashQuery_run_eq] + have hcacheAt : leftCache (.ordinary input) = rightCache (.ordinary input) := + congrFun hcache input + cases hlookup : leftCache (.ordinary input) with + | some output => + have hright : rightCache (.ordinary input) = some output := by + rw [← hcacheAt] + exact hlookup + simp only [hright] + simp [runResolvedFromTable, FinalizationMaterializedRunEq, hcontext, hcache, hrevealed] + | none => + have hright : rightCache (.ordinary input) = none := by + rw [← hcacheAt] + exact hlookup + simp only [hright] + rw [LazyRevealProbe.hashOutputQuery, + runResolvedFromTable_hashOutput_query_bind, + runResolvedFromTable_hashOutput_query_bind] + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput houtput + subst rightOutput + simp only [runResolvedFromTable] + apply relTriple_pure_pure + refine ⟨rfl, hcontext, rfl, rfl, rfl, ?_, hrevealed⟩ + rw [ordinaryQueryCache_update, ordinaryQueryCache_update, hcache] + +theorem finalizationMaterializedCouples_ordinaryHashImpl + (table : OtsSecretIndex → HashOutput) (input : HashInput) : + FinalizationMaterializedCouples table (ordinaryHashImpl input) := + finalizationMaterializedCouples_splitHashQuery_ordinary table input + +theorem finalizationMaterializedCouples_simulateQ + {table : OtsSecretIndex → HashOutput} {spec : OracleSpec ι} + (impl : QueryImpl spec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)))) + (hquery : ∀ query, FinalizationMaterializedCouples table (impl query)) + (computation : OracleComp spec α) : + FinalizationMaterializedCouples table (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => + simp only [simulateQ_pure] + exact finalizationMaterializedCouples_pure table value + | query_bind query next ih => + rw [simulateQ_query_bind] + exact (hquery query).bind fun output => ih output + +set_option maxRecDepth 100000 in +theorem finalizationMaterializedCouples_revealPosition + (table : OtsSecretIndex → HashOutput) (position : Position) : + FinalizationMaterializedCouples table (revealPosition position) := by + intro left right fuel leftCache rightCache hcontext hcache hrevealed + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + rw [runResolvedFromTable_revealPosition, runResolvedFromTable_revealPosition] + have hresolved := relTriple_resolveDeferredReveal_of_finalizationViewEq table position left + right hview hleftValid hrightValid hleftCompletable + have hresolvedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolved + (fun result => result ∈ support (resolveDeferredReveal table position left)) + (fun result hresult => hresult) + have hresolvedBoth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hresolvedLeft + apply relTriple_bind hresolvedBoth + intro leftResolved rightResolved hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResolved with + | none => + cases rightResolved with + | none => simp [FinalizationMaterializedRunEq] + | some rightResolved => simp [FinalizationResolutionEq] at hrelation + | some leftResolved => + cases rightResolved with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResolved => + have hleftMaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition left position leftResolved) := by + rcases hrelation.2.2.2.2 with ⟨completion, hcompletion⟩ + exact ⟨completion, + (deferredCompletion_materializeResolvedReveal_iff position leftResolved + hleftValid hview.leftStarts hleftSupport).mpr hcompletion⟩ + have hrightRawCompletable : + DeferredCompletable table rightResolved.toDeferredContext := by + rcases hrelation.2.2.2.2 with ⟨completion, hcompletion⟩ + exact ⟨completion, + (hrelation.2.1.deferredCompletion_iff completion).mp hcompletion⟩ + have hrightMaterializedCompletable : DeferredCompletable table + (materializeResolvedPosition right position rightResolved) := by + rcases hrightRawCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, + (deferredCompletion_materializeResolvedReveal_iff position rightResolved + hrightValid hview.rightStarts hrightSupport).mpr hcompletion⟩ + have hleftMaterializedView := finalizationViewEq_materializeResolvedReveal position + leftResolved hleftValid hview.leftStarts hleftSupport + hleftMaterializedCompletable + have hrightMaterializedView := finalizationViewEq_materializeResolvedReveal position + rightResolved hrightValid hview.rightStarts hrightSupport + hrightMaterializedCompletable + have hleftResultValid := hleftValid.of_resolveDeferredReveal table position + leftResolved hleftSupport + have hrightResultValid := hrightValid.of_resolveDeferredReveal table position + rightResolved hrightSupport + have hleftStateValues := resolveDeferredReveal_preserves_state_values table position + left leftResolved hleftSupport + have hrightStateValues := resolveDeferredReveal_preserves_state_values table position + right rightResolved hrightSupport + have hleftResolvedValue := resolveDeferredReveal_resolves table position left + leftResolved hleftSupport + have hrightResolvedValue := resolveDeferredReveal_resolves table position right + rightResolved hrightSupport + have hleftMaterializedValid : + (materializeResolvedPosition left position leftResolved).Valid := + hleftValid.materializeResolvedPosition_of position leftResolved hleftResultValid + hleftStateValues hleftResolvedValue + have hrightMaterializedValid : + (materializeResolvedPosition right position rightResolved).Valid := + hrightValid.materializeResolvedPosition_of position rightResolved hrightResultValid + hrightStateValues hrightResolvedValue + apply relTriple_pure_pure + refine ⟨?_, ?_, rfl, rfl, rfl, ?_, ?_⟩ + · simpa using congrArg truncateHash hrelation.1 + · exact ⟨hleftMaterializedView.trans + (hrelation.2.1.trans hrightMaterializedView.symm), + hleftMaterializedValid, hrightMaterializedValid, + hleftMaterializedCompletable⟩ + · rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, + hcache] + · simpa [materializeResolvedPosition, LazyRevealProbe.State.materialize] + using hrevealed + +theorem finalizationMaterializedCouples_ensureFullChain + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + FinalizationMaterializedCouples table + (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + apply (finalizationMaterializedCouples_sequenceFin + (fun step : ChainStep => + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step))) + (fun step => finalizationMaterializedCouples_ensureCoordinate table + (.position (.chain lay tree leafIdx chainIdx step)))).bind + intro _ + exact finalizationMaterializedCouples_pure table () + +theorem finalizationMaterializedCouples_ensureOtsLeaf + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + FinalizationMaterializedCouples table (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + apply (finalizationMaterializedCouples_sequenceFin + (fun chainIdx : ChainIndex => ensureFullChain lay tree leafIdx chainIdx) + (fun chainIdx => finalizationMaterializedCouples_ensureFullChain table lay tree leafIdx + chainIdx)).bind + intro _ + exact finalizationMaterializedCouples_ensureCoordinate table + (.position (.leaf lay tree leafIdx)) + +theorem finalizationMaterializedCouples_ensureTreeNode + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, + FinalizationMaterializedCouples table (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => + finalizationMaterializedCouples_ensureOtsLeaf table lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + apply (finalizationMaterializedCouples_ensureTreeNode table lay tree level + (2 * nodeIdx)).bind + intro _ + apply (finalizationMaterializedCouples_ensureTreeNode table lay tree level + (2 * nodeIdx + 1)).bind + intro _ + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact finalizationMaterializedCouples_ensureCoordinate table + (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact finalizationMaterializedCouples_pure table () + +theorem finalizationMaterializedCouples_maskedTreeNode + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) : + FinalizationMaterializedCouples table (maskedTreeNode lay tree level nodeIdx) := by + unfold maskedTreeNode + apply (finalizationMaterializedCouples_ensureTreeNode table lay tree level nodeIdx).bind + intro _ + cases level with + | zero => + exact finalizationMaterializedCouples_revealPosition table + (.leaf lay tree (leafOfNat nodeIdx)) + | succ current => + by_cases hlevel : current < maxLayerHeight + · simp only [hlevel, ↓reduceDIte] + exact finalizationMaterializedCouples_revealPosition table + (.node lay tree ⟨current, hlevel⟩ (leafOfNat nodeIdx)) + · simp only [hlevel, ↓reduceDIte] + exact finalizationMaterializedCouples_pure table 0 + +theorem finalizationMaterializedCouples_maskedTreeRoot + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + FinalizationMaterializedCouples table (maskedTreeRoot lay tree) := by + unfold maskedTreeRoot + exact finalizationMaterializedCouples_maskedTreeNode table lay tree (layerHeight lay) 0 + +theorem finalizationMaterializedCouples_ensureChainPrefix + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + FinalizationMaterializedCouples table + (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + apply (finalizationMaterializedCouples_sequenceFin + (fun step : ChainStep => + if step.val < digit.val then + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + else pure ()) + (fun step => by + by_cases hstep : step.val < digit.val + · rw [if_pos hstep] + exact finalizationMaterializedCouples_ensureCoordinate table + (.position (.chain lay tree leafIdx chainIdx step)) + · rw [if_neg hstep] + exact finalizationMaterializedCouples_pure table ())).bind + intro _ + exact finalizationMaterializedCouples_pure table () + +theorem finalizationMaterializedCouples_ensureTreePath + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + FinalizationMaterializedCouples table (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + apply (finalizationMaterializedCouples_sequenceFin + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + ensureTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + else pure ()) + (fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + exact finalizationMaterializedCouples_ensureTreeNode table lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · rw [if_neg hlevel] + exact finalizationMaterializedCouples_pure table ())).bind + intro _ + exact finalizationMaterializedCouples_pure table () + +theorem finalizationMaterializedCouples_maskedOtsSignFrom + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter, + FinalizationMaterializedCouples table + (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => by + rw [maskedOtsSignFrom] + exact finalizationMaterializedCouples_pure table none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + have hencoded := finalizationMaterializedCouples_simulateQ ordinaryHashImpl + (finalizationMaterializedCouples_ordinaryHashImpl table) + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter)) + apply hencoded.bind + intro encoded + cases encoded with + | none => + exact finalizationMaterializedCouples_maskedOtsSignFrom table parameter lay tree + leafIdx message attempts (counter + 1) + | some encoding => + apply (finalizationMaterializedCouples_sequenceFin + (fun chainIdx => ensureChainPrefix lay tree leafIdx chainIdx + (encoding chainIdx)) + (fun chainIdx => finalizationMaterializedCouples_ensureChainPrefix table lay tree + leafIdx chainIdx (encoding chainIdx))).bind + intro _ + exact finalizationMaterializedCouples_pure table + (some (BitVec.ofNat counterBits counter, encoding)) + +theorem finalizationMaterializedCouples_maskedOtsSign + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + FinalizationMaterializedCouples table + (maskedOtsSign parameter lay tree leafIdx message) := + finalizationMaterializedCouples_maskedOtsSignFrom table parameter lay tree leafIdx message + encodingAttemptLimit 0 + +theorem finalizationMaterializedCouples_maskedLayerMessage + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + FinalizationMaterializedCouples table + (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + by_cases hbelow : lay.val + 1 < numLayers + · rw [dif_pos hbelow] + exact finalizationMaterializedCouples_maskedTreeRoot table ⟨lay.val + 1, hbelow⟩ + (treeIndexAt index ⟨lay.val + 1, hbelow⟩) + · rw [dif_neg hbelow] + exact finalizationMaterializedCouples_simulateQ ordinaryHashImpl + (finalizationMaterializedCouples_ordinaryHashImpl table) + (ftsKey parameter index (ftsSecret index)) + +theorem finalizationMaterializedCouples_maskedSignLayer + (table : OtsSecretIndex → HashOutput) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + FinalizationMaterializedCouples table + (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + apply (finalizationMaterializedCouples_maskedLayerMessage table parameter ftsSecret index + lay).bind + intro message + apply (finalizationMaterializedCouples_maskedOtsSign table parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) message).bind + intro selected + cases selected with + | none => exact finalizationMaterializedCouples_pure table none + | some selected => + apply (finalizationMaterializedCouples_ensureTreePath table lay + (treeIndexAt index lay) (leafIndexAt index lay)).bind + intro _ + exact finalizationMaterializedCouples_pure table (some selected) + +noncomputable def privateChronologicalSignLayer + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (context : DeferredContext) (fuel : Nat) + (store : DeferredLayerStore) : + ProbComp (Option (ResolvedRunResult DeferredLayerStore)) := do + let selected ← runResolvedFromTable context fuel table + ((maskedSignLayer parameter ftsSecret index lay).run store.cache) + match selected with + | none => pure none + | some selected => + match selected.value.1 with + | none => pure (some ⟨selected.context, selected.remaining, + { selected := Function.update store.selected lay none + resolved := Function.update store.resolved lay none + cache := selected.value.2 }, table⟩) + | some (counter, encoding) => do + let resolved ← resolveDeferredLayerValues table index lay encoding + selected.context + match resolved with + | none => pure none + | some (finalContext, values) => + pure (some ⟨finalContext, selected.remaining, + { selected := Function.update store.selected lay + (some (counter, encoding)) + resolved := Function.update store.resolved lay + (some (counter, values.1, values.2)) + cache := selected.value.2 }, table⟩) + +def FinalizationChronologicalLayerEq + (table : OtsSecretIndex → HashOutput) (lay : Layer) + (initialStore : DeferredLayerStore) : + Option (ResolvedRunResult (Option ChronologicalLayerPart × SplitHashCache)) → + Option (ResolvedRunResult DeferredLayerStore) → Prop + | none, none => True + | some left, some right => + FinalizationContextEq table (some left.context) (some right.context) ∧ + left.remaining = right.remaining ∧ left.table = table ∧ right.table = table ∧ + right.value.selected = Function.update initialStore.selected lay + (left.value.1.map fun part => (part.counter, part.encoding)) ∧ + right.value.resolved = Function.update initialStore.resolved lay + (left.value.1.map ChronologicalLayerPart.toLayerPart) ∧ + ordinaryQueryCache left.value.2 = ordinaryQueryCache right.value.cache ∧ + left.context.state.revealed = right.context.state.revealed + | _, _ => False + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_maskedChronologicalSignLayer_finalization + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (left right : DeferredContext) (fuel : Nat) + (leftCache : SplitHashCache) (store : DeferredLayerStore) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache store.cache) + (hrevealed : left.state.revealed = right.state.revealed) : + RelTriple + (runResolvedFromTable left fuel table + ((maskedChronologicalSignLayer parameter ftsSecret index lay).run leftCache)) + (privateChronologicalSignLayer parameter table ftsSecret index lay right fuel store) + (FinalizationChronologicalLayerEq table lay store) := by + rw [maskedChronologicalSignLayer, StateT.run_bind, runResolvedFromTable_bind] + unfold privateChronologicalSignLayer + have hselected := finalizationMaterializedCouples_maskedSignLayer table parameter ftsSecret + index lay left right fuel leftCache store.cache hcontext hcache hrevealed + apply relTriple_bind hselected + intro leftSelected rightSelected hselectedRelation + cases leftSelected with + | none => + cases rightSelected with + | none => simp [FinalizationChronologicalLayerEq] + | some rightSelected => simp [FinalizationMaterializedRunEq] at hselectedRelation + | some leftSelected => + cases rightSelected with + | none => simp [FinalizationMaterializedRunEq] at hselectedRelation + | some rightSelected => + rcases hselectedRelation with + ⟨hselection, hselectedContext, hremaining, hleftTable, hrightTable, + hselectedCache, hselectedRevealed⟩ + simp only + rw [← hselection] + cases selected : leftSelected.value.1 with + | none => + simp only + apply relTriple_pure_pure + simp [FinalizationChronologicalLayerEq, hselectedContext, hremaining, + hleftTable, hselectedCache, hselectedRevealed] + | some selectedPart => + rcases selectedPart with ⟨counter, encoding⟩ + simp only + rw [hremaining, hleftTable] + rw [StateT.run_bind, runResolvedFromTable_bind] + have hvaluesBase := + relTriple_runResolvedFromTable_revealPrivateLayerValues_of_finalizationViewEq + table index lay encoding leftSelected.context rightSelected.context + rightSelected.remaining leftSelected.value.2 hselectedContext.1 + hselectedContext.2.1 hselectedContext.2.2.1 hselectedContext.2.2.2 + have hvaluesLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support + hvaluesBase + (fun result => result ∈ support + (runResolvedFromTable leftSelected.context rightSelected.remaining table + ((revealPrivateLayerValues index lay encoding).run + leftSelected.value.2))) + (fun result hresult => hresult) + have hvalues := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hvaluesLeft + apply relTriple_bind hvalues + intro leftValues rightValues hvaluesRelation + rcases hvaluesRelation with + ⟨⟨hvaluesRelation, hleftValuesSupport⟩, hrightValuesSupport⟩ + cases leftValues with + | none => + cases rightValues with + | none => simp [FinalizationChronologicalLayerEq] + | some rightValues => + simp [FinalizationRunContextValueEq] at hvaluesRelation + | some leftValues => + cases rightValues with + | none => simp [FinalizationRunContextValueEq] at hvaluesRelation + | some rightValues => + apply relTriple_pure_pure + refine ⟨hvaluesRelation.2.1, hvaluesRelation.2.2.1, + hvaluesRelation.2.2.2.1, rfl, ?_, ?_, ?_, ?_⟩ + · funext selectedLay + by_cases heq : selectedLay = lay + · subst selectedLay + simp + · simp [Function.update_of_ne heq] + · funext resolvedLay + by_cases heq : resolvedLay = lay + · subst resolvedLay + simp [ChronologicalLayerPart.toLayerPart, + hvaluesRelation.1] + · simp [Function.update_of_ne heq] + · exact hvaluesRelation.2.2.2.2.trans hselectedCache + · have hleftValuesRevealed := + revealed_eq_of_mem_runResolvedFromTable_of_noPublish + ((revealPrivateLayerValues index lay encoding).run + leftSelected.value.2) + leftSelected.context rightSelected.remaining table leftValues + (noPublish_revealPrivateLayerValues index lay encoding + leftSelected.value.2) + hleftValuesSupport + have hrightValuesRevealed := + (privateStateAgrees_resolveDeferredLayerValues table index lay encoding + rightSelected.context rightValues.1 rightValues.2 + hrightValuesSupport).2.1 + exact hleftValuesRevealed.trans + (hselectedRevealed.trans hrightValuesRevealed.symm) + +theorem privateChronologicalSignLayer_eq_schedule + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) (context : DeferredContext) (fuel : Nat) + (store : DeferredLayerStore) : + privateChronologicalSignLayer parameter table ftsSecret index lay context fuel store = + runDeferredLayerSchedule parameter table ftsSecret index + [.select lay, .resolve lay] (some ⟨context, fuel, store, table⟩) := by + unfold privateChronologicalSignLayer + simp only [runDeferredLayerSchedule, runDeferredLayerOperation, selectDeferredLayer, + bind_assoc] + apply bind_congr + intro selectedOption + cases selectedOption with + | none => rfl + | some selected => + simp only [pure_bind] + cases hselected : selected.value.1 with + | none => simp [resolveDeferredLayer] + | some selectedPart => + rcases selectedPart with ⟨counter, encoding⟩ + simp only [resolveDeferredLayer, Function.update_self, bind_assoc] + apply bind_congr + intro resolvedOption + cases resolvedOption <;> rfl + +def chronologicalSelectedAfter : ∀ {n : Nat}, (Fin n → Layer) → + (Fin n → Option ChronologicalLayerPart) → + (Layer → Option DeferredLayerEncoding) → + Layer → Option DeferredLayerEncoding + | 0, _, _, selected => selected + | n + 1, family, parts, selected => + chronologicalSelectedAfter + (fun position : Fin n => family position.succ) + (fun position : Fin n => parts position.succ) + (Function.update selected (family 0) + ((parts 0).map fun part => (part.counter, part.encoding))) + +def chronologicalResolvedAfter : ∀ {n : Nat}, (Fin n → Layer) → + (Fin n → Option ChronologicalLayerPart) → + (Layer → Option LayerPart) → Layer → Option LayerPart + | 0, _, _, resolved => resolved + | n + 1, family, parts, resolved => + chronologicalResolvedAfter + (fun position : Fin n => family position.succ) + (fun position : Fin n => parts position.succ) + (Function.update resolved (family 0) + ((parts 0).map ChronologicalLayerPart.toLayerPart)) + +noncomputable def privateChronologicalLayerFamily + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) : + ∀ {n : Nat}, (Fin n → Layer) → + Option (ResolvedRunResult DeferredLayerStore) → + ProbComp (Option (ResolvedRunResult DeferredLayerStore)) + | 0, _, input => pure input + | n + 1, family, input => + match input with + | none => pure none + | some result => do + let head ← privateChronologicalSignLayer parameter table ftsSecret index + (family 0) result.context result.remaining result.value + privateChronologicalLayerFamily parameter table ftsSecret index + (fun position : Fin n => family position.succ) head + +def FinalizationChronologicalFamilyEq + (table : OtsSecretIndex → HashOutput) (family : Fin n → Layer) + (initialStore : DeferredLayerStore) : + Option (ResolvedRunResult ((Fin n → Option ChronologicalLayerPart) × + SplitHashCache)) → Option (ResolvedRunResult DeferredLayerStore) → Prop + | none, none => True + | some left, some right => + FinalizationContextEq table (some left.context) (some right.context) ∧ + left.remaining = right.remaining ∧ left.table = table ∧ right.table = table ∧ + right.value.selected = + chronologicalSelectedAfter family left.value.1 initialStore.selected ∧ + right.value.resolved = + chronologicalResolvedAfter family left.value.1 initialStore.resolved ∧ + ordinaryQueryCache left.value.2 = ordinaryQueryCache right.value.cache ∧ + left.context.state.revealed = right.context.state.revealed + | _, _ => False + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedSequenceFin_maskedChronologicalLayerFamily_finalization + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) : + ∀ {n : Nat} (family : Fin n → Layer) (left right : DeferredContext) + (fuel : Nat) (leftCache : SplitHashCache) (store : DeferredLayerStore), + FinalizationContextEq table (some left) (some right) → + ordinaryQueryCache leftCache = ordinaryQueryCache store.cache → + left.state.revealed = right.state.revealed → + RelTriple + (runResolvedSequenceFin + (fun position => maskedChronologicalSignLayer parameter ftsSecret index + (family position)) left fuel table leftCache) + (privateChronologicalLayerFamily parameter table ftsSecret index family + (some ⟨right, fuel, store, table⟩)) + (FinalizationChronologicalFamilyEq table family store) + | 0, family, left, right, fuel, leftCache, store, hcontext, hcache, hrevealed => by + simp [runResolvedSequenceFin, privateChronologicalLayerFamily, + FinalizationChronologicalFamilyEq, chronologicalSelectedAfter, + chronologicalResolvedAfter, hcontext, hcache, hrevealed] + | n + 1, family, left, right, fuel, leftCache, store, hcontext, hcache, hrevealed => by + rw [runResolvedSequenceFin, privateChronologicalLayerFamily] + have hhead := + relTriple_runResolvedFromTable_maskedChronologicalSignLayer_finalization parameter table + ftsSecret index (family 0) left right fuel leftCache store hcontext hcache hrevealed + apply relTriple_bind hhead + intro leftHead rightHead hheadRelation + cases leftHead with + | none => + cases rightHead with + | none => + simp only + have hnone : + privateChronologicalLayerFamily parameter table ftsSecret index + (fun position : Fin n => family position.succ) none = pure none := by + cases n <;> rfl + rw [hnone] + apply relTriple_pure_pure + simp [FinalizationChronologicalFamilyEq] + | some rightHead => simp [FinalizationChronologicalLayerEq] at hheadRelation + | some leftHead => + cases rightHead with + | none => simp [FinalizationChronologicalLayerEq] at hheadRelation + | some rightHead => + rcases leftHead with + ⟨leftContext, leftRemaining, ⟨leftPart, leftCache⟩, leftTable⟩ + rcases rightHead with + ⟨rightContext, rightRemaining, rightStore, rightTable⟩ + simp only [FinalizationChronologicalLayerEq] at hheadRelation + rcases hheadRelation with + ⟨hcontext, hremaining, hleftTable, hrightTable, hselected, + hresolved, hcache, hrevealed⟩ + subst leftRemaining + subst leftTable + subst rightTable + simp only + have htail := + relTriple_runResolvedSequenceFin_maskedChronologicalLayerFamily_finalization + parameter table ftsSecret index + (fun position : Fin n => family position.succ) leftContext + rightContext rightRemaining leftCache rightStore hcontext hcache hrevealed + rw [← bind_pure + (privateChronologicalLayerFamily parameter table ftsSecret index + (fun position : Fin n => family position.succ) + (some ⟨rightContext, rightRemaining, rightStore, table⟩))] + apply relTriple_bind htail + intro leftTail rightTail htailRelation + cases leftTail with + | none => + cases rightTail with + | none => simp [FinalizationChronologicalFamilyEq] + | some rightTail => + simp [FinalizationChronologicalFamilyEq] at htailRelation + | some leftTail => + cases rightTail with + | none => simp [FinalizationChronologicalFamilyEq] at htailRelation + | some rightTail => + apply relTriple_pure_pure + refine ⟨htailRelation.1, htailRelation.2.1, + rfl, htailRelation.2.2.2.1, ?_, ?_, + htailRelation.2.2.2.2.2.2.1, + htailRelation.2.2.2.2.2.2.2⟩ + · simpa [chronologicalSelectedAfter, hselected] using + htailRelation.2.2.2.2.1 + · simpa [chronologicalResolvedAfter, hresolved] using + htailRelation.2.2.2.2.2.1 + +def chronologicalFamilySchedule : ∀ {n : Nat}, + (Fin n → Layer) → List DeferredLayerOperation + | 0, _ => [] + | n + 1, family => + [.select (family 0), .resolve (family 0)] ++ + chronologicalFamilySchedule (fun position : Fin n => family position.succ) + +theorem privateChronologicalLayerFamily_eq_schedule + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) : + ∀ {n : Nat} (family : Fin n → Layer) + (input : Option (ResolvedRunResult DeferredLayerStore)), + privateChronologicalLayerFamily parameter table ftsSecret index family input = + runDeferredLayerSchedule parameter table ftsSecret index + (chronologicalFamilySchedule family) input + | 0, family, input => by + simp [privateChronologicalLayerFamily, chronologicalFamilySchedule, + runDeferredLayerSchedule] + | n + 1, family, input => by + cases input with + | none => + simp [privateChronologicalLayerFamily, chronologicalFamilySchedule, + runDeferredLayerSchedule_none] + | some result => + rw [privateChronologicalLayerFamily, chronologicalFamilySchedule, + runDeferredLayerSchedule_append, + privateChronologicalSignLayer_eq_schedule] + apply bind_congr + intro head + exact privateChronologicalLayerFamily_eq_schedule parameter table ftsSecret index + (fun position : Fin n => family position.succ) head + +theorem chronologicalFamilySchedule_layers : + chronologicalFamilySchedule (fun lay : Layer => lay) = chronologicalLayerSchedule := by + rfl + +theorem relTriple_runResolvedSequenceFin_maskedChronologicalSignLayers_schedule_finalization + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (left right : DeferredContext) (fuel : Nat) (leftCache : SplitHashCache) + (store : DeferredLayerStore) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache store.cache) + (hrevealed : left.state.revealed = right.state.revealed) : + RelTriple + (runResolvedSequenceFin + (fun lay : Layer => maskedChronologicalSignLayer parameter ftsSecret index lay) + left fuel table leftCache) + (runDeferredLayerSchedule parameter table ftsSecret index chronologicalLayerSchedule + (some ⟨right, fuel, store, table⟩)) + (FinalizationChronologicalFamilyEq table (fun lay : Layer => lay) store) := by + rw [← chronologicalFamilySchedule_layers, + ← privateChronologicalLayerFamily_eq_schedule parameter table ftsSecret index] + exact relTriple_runResolvedSequenceFin_maskedChronologicalLayerFamily_finalization + parameter table ftsSecret index (fun lay : Layer => lay) left right fuel leftCache store + hcontext hcache hrevealed + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedSignerFinalization.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedSignerFinalization.lean new file mode 100644 index 00000000..04c4488a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedSignerFinalization.lean @@ -0,0 +1,700 @@ +import SphincsSecurity.Proof.OtsProbeResolvedSelectionFinalization + +/-! +# Finalization equivalence for the chronological signer + +This file carries the layer-schedule coupling through the delayed publication pass and the complete +signer. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +theorem FinalizationViewEq.publish + {table : OtsSecretIndex → HashOutput} {left right : DeferredContext} + (hview : FinalizationViewEq table left right) (coordinate : Coordinate) : + FinalizationViewEq table + { left with state := left.state.publish coordinate } + { right with state := right.state.publish coordinate } := by + refine ⟨hview.leftConsistent.publish coordinate, + hview.rightConsistent.publish coordinate, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · exact hview.leftStarts + · exact hview.rightStarts + · exact hview.valueEq + · exact hview.leftClean + · exact hview.rightClean + · exact hview.pendingEq + +theorem DeferredCompletable.publish + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} + (hcompletable : DeferredCompletable table context) (coordinate : Coordinate) : + DeferredCompletable table + { context with state := context.state.publish coordinate } := by + rcases hcompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, hcompletion⟩ + +theorem finalizationMaterializedCouples_publishCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + FinalizationMaterializedCouples table (publishCoordinate coordinate) := by + intro left right fuel leftCache rightCache hcontext hcache hrevealed + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + unfold publishCoordinate + rw [StateT.run_liftM, StateT.run_liftM, + LazyRevealProbe.publishQuery, + runResolvedFromTable_publish_query_bind, + runResolvedFromTable_publish_query_bind] + apply relTriple_pure_pure + exact ⟨rfl, + ⟨hview.publish coordinate, hleftValid.publish coordinate, + hrightValid.publish coordinate, hleftCompletable.publish coordinate⟩, + rfl, rfl, rfl, hcache, by + simpa [LazyRevealProbe.State.publish] using congrArg (insert coordinate) hrevealed⟩ + +theorem finalizationMaterializedCouples_splitUniformImpl + (table : OtsSecretIndex → HashOutput) (n : Nat) : + FinalizationMaterializedCouples table (splitUniformImpl n) := by + intro left right fuel leftCache rightCache hcontext hcache hrevealed + unfold splitUniformImpl + rw [StateT.run_liftM, StateT.run_liftM, LazyRevealProbe.uniformQuery, + runResolvedFromTable_uniform_query_bind, + runResolvedFromTable_uniform_query_bind] + apply relTriple_bind (relTriple_refl + (liftM (unifSpec.query n) : ProbComp (Fin (n + 1)))) + intro leftOutput rightOutput houtput + subst rightOutput + apply relTriple_pure_pure + exact ⟨rfl, hcontext, rfl, rfl, rfl, hcache, hrevealed⟩ + +theorem finalizationMaterializedCouples_ordinaryRomImpl + (table : OtsSecretIndex → HashOutput) (query : OracleWorld.Domain) : + FinalizationMaterializedCouples table (ordinaryRomImpl query) := by + cases query with + | inl n => exact finalizationMaterializedCouples_splitUniformImpl table n + | inr input => exact finalizationMaterializedCouples_ordinaryHashImpl table input + +set_option maxRecDepth 100000 in +theorem finalizationMaterializedCouples_revealChainStart + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) : + FinalizationMaterializedCouples table + (revealChainStart index.lay index.tree index.leafIdx index.chainIdx) := by + intro left right fuel leftCache rightCache hcontext hcache hrevealed + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + rw [revealChainStart, runResolvedFromTable_revealCoordinate, + runResolvedFromTable_revealCoordinate] + have hresolved := relTriple_resolveDeferredChainStart_of_finalizationViewEq table index left + right hview hleftValid hrightValid hleftCompletable + have hresolvedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolved + (fun result => result ∈ support + (pure (resolveDeferredChainStart table index left) : + ProbComp (Option DeferredResolution))) + (fun result hresult => hresult) + have hresolvedBoth := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hresolvedLeft + apply relTriple_bind hresolvedBoth + intro leftResolved rightResolved hrelation + rcases hrelation with ⟨⟨hrelation, hleftSupport⟩, hrightSupport⟩ + cases leftResolved with + | none => + cases rightResolved with + | none => simp [FinalizationMaterializedRunEq] + | some rightResolved => simp [FinalizationResolutionEq] at hrelation + | some leftResolved => + cases rightResolved with + | none => simp [FinalizationResolutionEq] at hrelation + | some rightResolved => + have hleftResult : + resolveDeferredChainStart table index left = some leftResolved := by + simpa using hleftSupport.symm + have hrightResult : + resolveDeferredChainStart table index right = some rightResolved := by + simpa using hrightSupport.symm + have hleftMaterializedCompletable := + hleftCompletable.materializeResolvedChainStart hview.leftStarts index leftResolved + hleftResult + have hrightCompletable : DeferredCompletable table right := by + rcases hleftCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, (hview.deferredCompletion_iff completion).mp hcompletion⟩ + have hrightMaterializedCompletable := + hrightCompletable.materializeResolvedChainStart hview.rightStarts index + rightResolved hrightResult + have hleftMaterializedView := + finalizationViewEq_materializeResolvedChainStart index leftResolved hleftValid + hview.leftStarts hleftResult hleftMaterializedCompletable + have hrightMaterializedView := + finalizationViewEq_materializeResolvedChainStart index rightResolved hrightValid + hview.rightStarts hrightResult hrightMaterializedCompletable + have hleftMaterializedValid : + (materializeResolvedChainStart left index leftResolved).Valid := by + unfold materializeResolvedChainStart + rw [resolveDeferredChainStart_deferred_values_eq table index left leftResolved + hleftResult] + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + exact hleftValid.materialize_chainStart lay tree leafIdx chainIdx leftResolved.output + have hrightMaterializedValid : + (materializeResolvedChainStart right index rightResolved).Valid := by + unfold materializeResolvedChainStart + rw [resolveDeferredChainStart_deferred_values_eq table index right rightResolved + hrightResult] + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + exact hrightValid.materialize_chainStart lay tree leafIdx chainIdx + rightResolved.output + apply relTriple_pure_pure + refine ⟨?_, ?_, rfl, rfl, rfl, ?_, ?_⟩ + · simpa using congrArg truncateHash hrelation.1 + · exact ⟨hleftMaterializedView.trans + (hrelation.2.1.trans hrightMaterializedView.symm), + hleftMaterializedValid, hrightMaterializedValid, + hleftMaterializedCompletable⟩ + · rw [ordinaryQueryCache_update_hidden, ordinaryQueryCache_update_hidden, + hcache] + · simpa [materializeResolvedChainStart, LazyRevealProbe.State.materialize] + using hrevealed + +theorem finalizationMaterializedCouples_revealCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + FinalizationMaterializedCouples table (revealCoordinate coordinate) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact finalizationMaterializedCouples_revealChainStart table + ⟨lay, tree, leafIdx, chainIdx⟩ + | position position => + exact finalizationMaterializedCouples_revealPosition table position + +theorem finalizationMaterializedCouples_revealPublishedCoordinate + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) : + FinalizationMaterializedCouples table (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + exact (finalizationMaterializedCouples_revealCoordinate table coordinate).bind fun value => + (finalizationMaterializedCouples_publishCoordinate table coordinate).bind fun _ => + finalizationMaterializedCouples_pure table value + +set_option maxRecDepth 100000 in +theorem finalizationMaterializedCouples_revealLayerValues + (table : OtsSecretIndex → HashOutput) (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + FinalizationMaterializedCouples table (revealLayerValues index lay encoding) := by + unfold revealLayerValues + apply (finalizationMaterializedCouples_sequenceFin + (fun chainIdx : ChainIndex => + revealPublishedCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx))) + (fun chainIdx => finalizationMaterializedCouples_revealPublishedCoordinate table + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (encoding chainIdx)))).bind + intro values + apply (finalizationMaterializedCouples_sequenceFin + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + match level.val with + | 0 => revealPublishedCoordinate (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | current + 1 => + if hcurrent : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hcurrent⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0 + else pure 0) + (fun level => by + by_cases hinLayer : level.val < layerHeight lay + · rw [if_pos hinLayer] + cases hvalue : level.val with + | zero => + exact finalizationMaterializedCouples_revealPublishedCoordinate table + (.position (.leaf lay (treeIndexAt index lay) + (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | succ current => + have hcurrent : current < maxLayerHeight := by + have := level.isLt + omega + simp only + rw [dif_pos hcurrent] + exact finalizationMaterializedCouples_revealPublishedCoordinate table + (.position (.node lay (treeIndexAt index lay) ⟨current, hcurrent⟩ + (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + · rw [if_neg hinLayer] + exact finalizationMaterializedCouples_pure table 0)).bind + intro path + exact finalizationMaterializedCouples_pure table (values, path) + +set_option maxRecDepth 100000 in +theorem finalizationMaterializedCouples_publishChronologicalSignature + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (layers : Layer → Option ChronologicalLayerPart) : + FinalizationMaterializedCouples table + (publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers) := by + unfold publishChronologicalSignature + cases hparts : traverseOption layers with + | none => exact finalizationMaterializedCouples_pure table none + | some parts => + apply (finalizationMaterializedCouples_sequenceFin + (fun lay : Layer => revealLayerValues index lay (parts lay).encoding) + (fun lay => finalizationMaterializedCouples_revealLayerValues table index lay + (parts lay).encoding)).bind + intro published + let signature : Signature := + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).counter + chainValue := fun lay => (published lay).1 + authPath := flattenPaths fun lay => (published lay).2 } + exact finalizationMaterializedCouples_pure table (some signature) + +def chronologicalPartsOfStore (store : DeferredLayerStore) : + Layer → Option ChronologicalLayerPart := fun lay => + match store.selected lay, store.resolved lay with + | some (counter, encoding), some (_, chainValue, authPath) => + some ⟨counter, encoding, chainValue, authPath⟩ + | _, _ => none + +theorem chronologicalSelectedAfter_layers_empty + (parts : Layer → Option ChronologicalLayerPart) (cache : SplitHashCache) : + chronologicalSelectedAfter (fun lay : Layer => lay) parts + (emptyDeferredLayerStore cache).selected = + fun lay => (parts lay).map fun part => (part.counter, part.encoding) := by + funext lay + fin_cases lay <;> rfl + +theorem chronologicalResolvedAfter_layers_empty + (parts : Layer → Option ChronologicalLayerPart) (cache : SplitHashCache) : + chronologicalResolvedAfter (fun lay : Layer => lay) parts + (emptyDeferredLayerStore cache).resolved = + fun lay => (parts lay).map ChronologicalLayerPart.toLayerPart := by + funext lay + fin_cases lay <;> rfl + +theorem chronologicalPartsOfStore_eq + (store : DeferredLayerStore) (parts : Layer → Option ChronologicalLayerPart) + (hselected : store.selected = + fun lay => (parts lay).map fun part => (part.counter, part.encoding)) + (hresolved : store.resolved = + fun lay => (parts lay).map ChronologicalLayerPart.toLayerPart) : + chronologicalPartsOfStore store = parts := by + funext lay + rw [chronologicalPartsOfStore, hselected, hresolved] + cases hpart : parts lay with + | none => simp [hpart] + | some part => + rcases part with ⟨counter, encoding, chainValue, authPath⟩ + simp [hpart, ChronologicalLayerPart.toLayerPart] + +noncomputable def publishDeferredChronologicalSignature + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) : + Option (ResolvedRunResult DeferredLayerStore) → + ProbComp (Option (ResolvedRunResult (Option Signature × SplitHashCache))) + | none => pure none + | some result => + runResolvedFromTable result.context result.remaining result.table + ((publishChronologicalSignature ftsSecret randomness index leaves ftsPath + (chronologicalPartsOfStore result.value)).run result.value.cache) + +noncomputable def runResolvedChronologicalLayersAndPublish + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + ProbComp (Option (ResolvedRunResult (Option Signature × SplitHashCache))) := do + let layers ← runResolvedSequenceFin + (fun lay : Layer => maskedChronologicalSignLayer parameter ftsSecret index lay) + context fuel table cache + match layers with + | none => pure none + | some layers => + runResolvedFromTable layers.context layers.remaining layers.table + ((publishChronologicalSignature ftsSecret randomness index leaves ftsPath + layers.value.1).run layers.value.2) + +noncomputable def runDeferredChronologicalLayersAndPublish + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + ProbComp (Option (ResolvedRunResult (Option Signature × SplitHashCache))) := + runDeferredLayerSchedule parameter table ftsSecret index chronologicalLayerSchedule + (some ⟨context, fuel, emptyDeferredLayerStore cache, table⟩) >>= + publishDeferredChronologicalSignature ftsSecret randomness index leaves ftsPath + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedChronologicalLayersAndPublish_finalization + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (left right : DeferredContext) (fuel : Nat) (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) : + RelTriple + (runResolvedChronologicalLayersAndPublish parameter table ftsSecret randomness index + leaves ftsPath left fuel leftCache) + (runDeferredChronologicalLayersAndPublish parameter table ftsSecret randomness index + leaves ftsPath right fuel rightCache) + (FinalizationMaterializedRunEq table) := by + unfold runResolvedChronologicalLayersAndPublish + runDeferredChronologicalLayersAndPublish + have hlayers := + relTriple_runResolvedSequenceFin_maskedChronologicalSignLayers_schedule_finalization + parameter table ftsSecret index left right fuel leftCache + (emptyDeferredLayerStore rightCache) hcontext hcache hrevealed + apply relTriple_bind hlayers + intro leftLayers rightLayers hlayersRelation + cases leftLayers with + | none => + cases rightLayers with + | none => simp [publishDeferredChronologicalSignature, + FinalizationMaterializedRunEq] + | some rightLayers => + simp [FinalizationChronologicalFamilyEq] at hlayersRelation + | some leftLayers => + cases rightLayers with + | none => simp [FinalizationChronologicalFamilyEq] at hlayersRelation + | some rightLayers => + rcases leftLayers with + ⟨leftContext, leftRemaining, ⟨leftParts, leftCache⟩, leftTable⟩ + rcases rightLayers with + ⟨rightContext, rightRemaining, rightStore, rightTable⟩ + simp only [FinalizationChronologicalFamilyEq] at hlayersRelation + rcases hlayersRelation with + ⟨hcontext, hremaining, hleftTable, hrightTable, hselected, hresolved, + hcache, hrevealed⟩ + subst leftRemaining + subst leftTable + subst rightTable + simp only [publishDeferredChronologicalSignature] + have hselected' : rightStore.selected = + fun lay => (leftParts lay).map fun part => + (part.counter, part.encoding) := by + rw [hselected, chronologicalSelectedAfter_layers_empty] + have hresolved' : rightStore.resolved = + fun lay => (leftParts lay).map ChronologicalLayerPart.toLayerPart := by + rw [hresolved, chronologicalResolvedAfter_layers_empty] + have hparts := chronologicalPartsOfStore_eq rightStore leftParts + hselected' hresolved' + rw [hparts] + exact finalizationMaterializedCouples_publishChronologicalSignature table ftsSecret + randomness index leaves ftsPath leftParts leftContext rightContext rightRemaining + leftCache rightStore.cache hcontext hcache hrevealed + +set_option maxHeartbeats 400000 in +theorem evalDist_runResolvedChronologicalLayersAndPublish_eq + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) : + evalDist (runResolvedChronologicalLayersAndPublish parameter table ftsSecret randomness + index leaves ftsPath context fuel cache) = + evalDist (runResolvedFromTable context fuel table + ((do + let layers ← maskedChronologicalSignLayers parameter ftsSecret index + publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers).run + cache)) := by + unfold runResolvedChronologicalLayersAndPublish maskedChronologicalSignLayers + rw [StateT.run_bind, runResolvedFromTable_bind, evalDist_bind, evalDist_bind, + evalDist_runResolvedSequenceFin_eq + (fun lay : Layer => maskedChronologicalSignLayer parameter ftsSecret index lay) + context fuel table cache hconsistent hstarts] + apply bind_congr + intro result + cases result <;> rfl + +noncomputable def runDeferredLayersAndPublish + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (schedule : List DeferredLayerOperation) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + ProbComp (Option (ResolvedRunResult (Option Signature × SplitHashCache))) := + runDeferredLayerSchedule parameter table ftsSecret index schedule + (some ⟨context, fuel, emptyDeferredLayerStore cache, table⟩) >>= + publishDeferredChronologicalSignature ftsSecret randomness index leaves ftsPath + +theorem evalDist_runDeferredChronologicalLayersAndPublish_eq_deferred + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + evalDist (runDeferredChronologicalLayersAndPublish parameter table ftsSecret randomness + index leaves ftsPath context fuel cache) = + evalDist (runDeferredLayersAndPublish parameter table ftsSecret randomness index leaves + ftsPath deferredLayerSchedule context fuel cache) := by + unfold runDeferredChronologicalLayersAndPublish runDeferredLayersAndPublish + exact evalDist_chronologicalLayerSchedule_bind_eq_deferred parameter table ftsSecret index + (some ⟨context, fuel, emptyDeferredLayerStore cache, table⟩) + (publishDeferredChronologicalSignature ftsSecret randomness index leaves ftsPath) + +noncomputable def finishResolvedRunIsNone + (input : Option (ResolvedRunResult α)) : ProbComp Bool := + Option.isNone <$> finishResolvedRun input + +set_option maxRecDepth 100000 in +theorem evalDist_finishResolvedRunIsNone_eq_of_finalizationMaterializedRunEq + (table : OtsSecretIndex → HashOutput) + (left right : Option (ResolvedRunResult (α × SplitHashCache))) + (hrelation : FinalizationMaterializedRunEq table left right) : + evalDist (finishResolvedRunIsNone left) = + evalDist (finishResolvedRunIsNone right) := by + cases left with + | none => + cases right with + | none => rfl + | some right => simp [FinalizationMaterializedRunEq] at hrelation + | some left => + cases right with + | none => simp [FinalizationMaterializedRunEq] at hrelation + | some right => + rcases hrelation with + ⟨hvalue, hcontext, hremaining, hleftTable, hrightTable, hcache, _hrevealed⟩ + rcases hcontext with ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ + have hrightCompletable : DeferredCompletable table right.context := by + rcases hleftCompletable with ⟨completion, hcompletion⟩ + exact ⟨completion, (hview.deferredCompletion_iff completion).mp hcompletion⟩ + simp only [finishResolvedRunIsNone, finishResolvedRun, hleftTable, hrightTable, + hleftCompletable, hrightCompletable, ↓reduceIte, map_bind] + have hfinalize := evalDist_map_isNone_finalizeResolvedCoordinates_congr_covered table + left.context.state.coordinates.toList right.context.state.coordinates.toList + left.context right.context hview (Finset.nodup_toList _) + (Finset.nodup_toList _) (pendingCovered_coordinates_toList left.context) + (pendingCovered_coordinates_toList right.context) + have hleftFinish : + evalDist (do + let finalized ← finalizeResolvedCoordinates + left.context.state.coordinates.toList left.context table + Option.isNone <$> match finalized with + | none => pure none + | some context => pure (some + (ResolvedRunResult.mk context left.remaining left.value table))) = + evalDist (Option.isNone <$> + finalizeResolvedCoordinates left.context.state.coordinates.toList + left.context table) := by + rw [map_eq_bind_pure_comp] + apply evalDist_bind_congr + intro finalized _ + cases finalized <;> simp + have hrightFinish : + evalDist (do + let finalized ← finalizeResolvedCoordinates + right.context.state.coordinates.toList right.context table + Option.isNone <$> match finalized with + | none => pure none + | some context => pure (some + (ResolvedRunResult.mk context right.remaining right.value table))) = + evalDist (Option.isNone <$> + finalizeResolvedCoordinates right.context.state.coordinates.toList + right.context table) := by + rw [map_eq_bind_pure_comp] + apply evalDist_bind_congr + intro finalized _ + cases finalized <;> simp + exact hleftFinish.trans (hfinalize.trans hrightFinish.symm) + +theorem relTriple_finishResolvedRunIsNone_of_finalizationMaterializedRunEq + (table : OtsSecretIndex → HashOutput) + (left right : Option (ResolvedRunResult (α × SplitHashCache))) + (hrelation : FinalizationMaterializedRunEq table left right) : + RelTriple (finishResolvedRunIsNone left) (finishResolvedRunIsNone right) (EqRel Bool) := + relTriple_eqRel_of_evalDist_eq + (evalDist_finishResolvedRunIsNone_eq_of_finalizationMaterializedRunEq table left right + hrelation) + +theorem evalDist_runResolvedChronologicalLayersAndPublish_finish_eq_deferred + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (left right : DeferredContext) (fuel : Nat) (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) : + evalDist (runResolvedChronologicalLayersAndPublish parameter table ftsSecret randomness + index leaves ftsPath left fuel leftCache >>= finishResolvedRunIsNone) = + evalDist (runDeferredChronologicalLayersAndPublish parameter table ftsSecret randomness + index leaves ftsPath right fuel rightCache >>= finishResolvedRunIsNone) := by + apply evalDist_eq_of_relTriple_eqRel + apply relTriple_bind + (relTriple_runResolvedChronologicalLayersAndPublish_finalization parameter table ftsSecret + randomness index leaves ftsPath left right fuel leftCache rightCache hcontext hcache hrevealed) + intro leftResult rightResult hrelation + exact relTriple_finishResolvedRunIsNone_of_finalizationMaterializedRunEq table leftResult + rightResult hrelation + +theorem evalDist_runDeferredChronologicalLayersAndPublish_finish_eq_deferred + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + evalDist (runDeferredChronologicalLayersAndPublish parameter table ftsSecret randomness + index leaves ftsPath context fuel cache >>= finishResolvedRunIsNone) = + evalDist (runDeferredLayersAndPublish parameter table ftsSecret randomness index leaves + ftsPath deferredLayerSchedule context fuel cache >>= finishResolvedRunIsNone) := by + rw [evalDist_bind, evalDist_bind, + evalDist_runDeferredChronologicalLayersAndPublish_eq_deferred parameter table ftsSecret + randomness index leaves ftsPath context fuel cache] + +noncomputable def runDeferredChronologicalSignAfterDigest + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + ProbComp (Option (ResolvedRunResult (Option Signature × SplitHashCache))) := do + let ftsPath ← runResolvedFromTable context fuel table + ((simulateQ ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index))).run cache) + match ftsPath with + | none => pure none + | some ftsPath => + runDeferredChronologicalLayersAndPublish parameter table ftsSecret randomness index + leaves ftsPath.value.1 ftsPath.context ftsPath.remaining ftsPath.value.2 + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_maskedPublishedChronologicalSignAfterDigest_finalization + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (left right : DeferredContext) (fuel : Nat) (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) : + RelTriple + (runResolvedFromTable left fuel table + ((maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index + leaves).run leftCache)) + (runDeferredChronologicalSignAfterDigest parameter table ftsSecret randomness index leaves + right fuel rightCache) + (FinalizationMaterializedRunEq table) := by + rw [maskedPublishedChronologicalSignAfterDigest_eq, StateT.run_bind, + runResolvedFromTable_bind] + unfold runDeferredChronologicalSignAfterDigest + have hfts := finalizationMaterializedCouples_simulateQ ordinaryHashImpl + (finalizationMaterializedCouples_ordinaryHashImpl table) + (ftsOpen parameter index leaves (ftsSecret index)) + left right fuel leftCache rightCache hcontext hcache hrevealed + apply relTriple_bind hfts + intro leftFts rightFts hftsRelation + cases leftFts with + | none => + cases rightFts with + | none => simp [FinalizationMaterializedRunEq] + | some rightFts => simp [FinalizationMaterializedRunEq] at hftsRelation + | some leftFts => + cases rightFts with + | none => simp [FinalizationMaterializedRunEq] at hftsRelation + | some rightFts => + rcases leftFts with + ⟨leftContext, leftRemaining, ⟨leftFtsPath, leftCache⟩, leftTable⟩ + rcases rightFts with + ⟨rightContext, rightRemaining, ⟨rightFtsPath, rightCache⟩, rightTable⟩ + rcases hftsRelation with + ⟨hftsPath, hcontext, hremaining, hleftTable, hrightTable, hcache, hrevealed⟩ + simp only at hftsPath hcontext hremaining hleftTable hrightTable hcache hrevealed + subst rightFtsPath + subst leftRemaining + subst leftTable + subst rightTable + simp only + have hlayers := + relTriple_runResolvedChronologicalLayersAndPublish_finalization parameter table + ftsSecret randomness index leaves leftFtsPath leftContext rightContext + rightRemaining leftCache rightCache hcontext hcache hrevealed + apply relTriple_of_evalDist_eq_left _ hlayers + exact (evalDist_runResolvedChronologicalLayersAndPublish_eq parameter table ftsSecret + randomness index leaves leftFtsPath leftContext rightRemaining leftCache + hcontext.2.1.1 hcontext.1.leftStarts).symm + +noncomputable def runDeferredChronologicalSign + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + ProbComp (Option (ResolvedRunResult (Option Signature × SplitHashCache))) := do + let secretKey : SecretKey := + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ + let selected ← runResolvedFromTable context fuel table + ((simulateQ ordinaryRomImpl + (signDigestLoop digestAttemptLimit secretKey message)).run cache) + match selected with + | none => pure none + | some selected => + match selected.value.1 with + | none => pure (some ⟨selected.context, selected.remaining, + (none, selected.value.2), table⟩) + | some (randomness, index, leaves) => + runDeferredChronologicalSignAfterDigest parameter table ftsSecret randomness index + leaves selected.context selected.remaining selected.value.2 + +set_option maxRecDepth 100000 in +theorem relTriple_runResolvedFromTable_maskedPublishedChronologicalSign_finalization + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (left right : DeferredContext) (fuel : Nat) (leftCache rightCache : SplitHashCache) + (hcontext : FinalizationContextEq table (some left) (some right)) + (hcache : ordinaryQueryCache leftCache = ordinaryQueryCache rightCache) + (hrevealed : left.state.revealed = right.state.revealed) : + RelTriple + (runResolvedFromTable left fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run leftCache)) + (runDeferredChronologicalSign parameter root table ftsSecret message right fuel rightCache) + (FinalizationMaterializedRunEq table) := by + unfold maskedPublishedChronologicalSign runDeferredChronologicalSign + let secretKey : SecretKey := + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ + rw [StateT.run_bind, runResolvedFromTable_bind] + have hselected := finalizationMaterializedCouples_simulateQ ordinaryRomImpl + (finalizationMaterializedCouples_ordinaryRomImpl table) + (signDigestLoop digestAttemptLimit secretKey message) + left right fuel leftCache rightCache hcontext hcache hrevealed + apply relTriple_bind hselected + intro leftSelected rightSelected hselectedRelation + cases leftSelected with + | none => + cases rightSelected with + | none => simp [FinalizationMaterializedRunEq] + | some rightSelected => + simp [FinalizationMaterializedRunEq] at hselectedRelation + | some leftSelected => + cases rightSelected with + | none => simp [FinalizationMaterializedRunEq] at hselectedRelation + | some rightSelected => + rcases leftSelected with + ⟨leftContext, leftRemaining, ⟨leftValue, leftCache⟩, leftTable⟩ + rcases rightSelected with + ⟨rightContext, rightRemaining, ⟨rightValue, rightCache⟩, rightTable⟩ + simp only [FinalizationMaterializedRunEq] at hselectedRelation + rcases hselectedRelation with + ⟨hvalue, hcontext, hremaining, hleftTable, hrightTable, hcache, hrevealed⟩ + subst rightValue + subst leftRemaining + subst leftTable + subst rightTable + simp only + cases leftValue with + | none => + apply relTriple_pure_pure + exact ⟨rfl, hcontext, rfl, rfl, rfl, hcache, hrevealed⟩ + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + exact + relTriple_runResolvedFromTable_maskedPublishedChronologicalSignAfterDigest_finalization + parameter table ftsSecret randomness index leaves leftContext rightContext + rightRemaining leftCache rightCache hcontext hcache hrevealed + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRetained.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRetained.lean new file mode 100644 index 00000000..388c26b1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRetained.lean @@ -0,0 +1,504 @@ +import SphincsSecurity.Proof.FtsProbeSampling +import SphincsSecurity.Proof.OtsProbeRealization + +/-! +# Retained one-time probe game + +The retained game keeps exactly the root, forgery, signing log, verifier result and final cache. +Its ordinary projection is the existing signing-trace game, so the one-time terminal witnesses can +be transported without retaining the much larger proof-only view trace. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +noncomputable def actualRetainedGameAfterTable (adversary : Adversary) + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : Coordinate → HashOutput) : + ProbComp (RetainedGameResult × QueryCache HashSpec) := do + let otsSecret := tableOtsSecret table + let (root, rootCache) ← + (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅ + let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + let (result, finalCache) ← + (simulateQ (unloggedMappedAdversaryImpl secretKey) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).run rootCache + pure ((root, result), finalCache) + +theorem simulateQ_unloggedMapped_signingTraceComputation_run + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (initialCache : QueryCache HashSpec) : + (simulateQ (unloggedMappedAdversaryImpl secretKey) + (signingTraceComputation computation)).run initialCache = + (((simulateQ (mappedAdversaryImpl secretKey) computation).run).run initialCache) := by + change (simulateQ (unloggedMappedAdversaryImpl secretKey) + (Concrete.FtsProbeSimulation.signingTraceComputation computation)).run initialCache = _ + exact Concrete.FtsProbeSimulation.simulateQ_unloggedMapped_signingTraceComputation_run + secretKey computation initialCache + +theorem simulateQ_unloggedMapped_liftOracleWorldLeft + (secretKey : SecretKey) (computation : OracleComp OracleWorld alpha) : + simulateQ (unloggedMappedAdversaryImpl secretKey) + (liftOracleWorldLeft computation) = + simulateQ romImpl computation := by + change simulateQ (unloggedMappedAdversaryImpl secretKey) + (Concrete.FtsProbeSimulation.liftOracleWorldLeft computation) = _ + exact Concrete.FtsProbeSimulation.simulateQ_unloggedMapped_liftOracleWorldLeft + secretKey computation + +theorem simulateQ_unloggedMapped_retainedGameRestComputation + (adversary : Adversary) (secretKey : SecretKey) (publicKey : PublicKey) : + simulateQ (unloggedMappedAdversaryImpl secretKey) + (retainedGameRestComputation adversary publicKey) = (do + let (forgery, log) ← + simulateQ (unloggedMappedAdversaryImpl secretKey) + (signingTraceComputation (adversary.main publicKey)) + let verified ← simulateQ romImpl + (scheme.verify publicKey forgery.message forgery.signature) + pure ((forgery, log), verified)) := by + unfold retainedGameRestComputation + rw [simulateQ_bind] + apply bind_congr + intro result + rcases result with ⟨forgery, log⟩ + rw [simulateQ_bind, simulateQ_unloggedMapped_liftOracleWorldLeft] + simp + +abbrev RetainedLogResult := + (Forgery × Bool) × (QueryCache HashSpec × QueryLog SigningSpec) + +def retainedRestLogProjection : + (RetainedRestResult × QueryCache HashSpec) → RetainedLogResult + | (((forgery, log), verified), cache) => + ((forgery, decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log forgery) && verified), (cache, log)) + +def signingRestLogProjection : + ((Forgery × Bool) × (QueryCache HashSpec × SigningCacheTrace)) → RetainedLogResult + | ((forgery, verdict), (cache, trace)) => + ((forgery, verdict), (cache, trace.toSigningLog)) + +theorem retainedGameRest_signing_projection + (adversary : Adversary) (publicKey : PublicKey) (secretKey : SecretKey) + (initialCache : QueryCache HashSpec) : + retainedRestLogProjection <$> + (simulateQ (unloggedMappedAdversaryImpl secretKey) + (retainedGameRestComputation adversary publicKey)).run initialCache = + signingRestLogProjection <$> + gameRestWithSigningTrace adversary publicKey secretKey initialCache := by + let traceRun := (simulateQ (cacheTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run (initialCache, []) + let retainedRun := (simulateQ (unloggedMappedAdversaryImpl secretKey) + (signingTraceComputation (adversary.main publicKey))).run initialCache + let prefixProjection : + (Forgery × QueryLog SigningSpec) × QueryCache HashSpec → + Forgery × (QueryCache HashSpec × QueryLog SigningSpec) := + fun result => (result.1.1, (result.2, result.1.2)) + let traceProjection : + Forgery × (QueryCache HashSpec × SigningCacheTrace) → + Forgery × (QueryCache HashSpec × QueryLog SigningSpec) := + fun result => (result.1, (result.2.1, result.2.2.toSigningLog)) + let finish : Forgery × (QueryCache HashSpec × QueryLog SigningSpec) → + ProbComp RetainedLogResult := fun result => do + let (verified, finalCache) ← + (simulateQ romImpl + (scheme.verify publicKey result.1.message result.1.signature)).run result.2.1 + pure ((result.1, decide (SigningTranscript.Valid result.2.2 ∧ + ¬SigningTranscript.Contains result.2.2 result.1) && verified), + (finalCache, result.2.2)) + have hprefix : traceProjection <$> traceRun = prefixProjection <$> retainedRun := by + rw [show traceProjection = Prod.map id + (fun state : QueryCache HashSpec × SigningCacheTrace => + (state.1, state.2.toSigningLog)) from rfl] + rw [show prefixProjection = fun result : + (Forgery × QueryLog SigningSpec) × QueryCache HashSpec => + (result.1.1, (result.2, result.1.2)) from rfl] + rw [show traceRun = (simulateQ (cacheTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run (initialCache, []) from rfl] + rw [cacheTracedMappedAdversaryImpl_log_projection_eq_mapped] + rw [show retainedRun = (simulateQ (unloggedMappedAdversaryImpl secretKey) + (signingTraceComputation (adversary.main publicKey))).run initialCache from rfl] + rw [simulateQ_unloggedMapped_signingTraceComputation_run] + rw [simulateQ_unloggedMapped_retainedGameRestComputation adversary secretKey publicKey] + calc + retainedRestLogProjection <$> + (do + let result ← retainedRun + let (verified, finalCache) ← + (simulateQ romImpl + (scheme.verify publicKey result.1.1.message result.1.1.signature)).run result.2 + pure ((result.1, verified), finalCache)) = + (prefixProjection <$> retainedRun) >>= finish := by + simp [retainedRestLogProjection, prefixProjection, retainedRun, finish, + bind_map_left, map_bind] + _ = (traceProjection <$> traceRun) >>= finish := by rw [hprefix] + _ = signingRestLogProjection <$> + gameRestWithSigningTrace adversary publicKey secretKey initialCache := by + simp [gameRestWithSigningTrace, traceRun, traceProjection, finish, + signingRestLogProjection, bind_map_left, map_bind] + +abbrev RetainedGameLogResult := + (Digest × Forgery × Bool) × (QueryCache HashSpec × QueryLog SigningSpec) + +def retainedGameLogProjection : + (RetainedGameResult × QueryCache HashSpec) → RetainedGameLogResult + | ((root, ((forgery, log), verified)), cache) => + ((root, forgery, decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log forgery) && verified), (cache, log)) + +def signingGameLogProjection : + ((Digest × Forgery × Bool) × (QueryCache HashSpec × SigningCacheTrace)) → + RetainedGameLogResult + | ((root, forgery, verdict), (cache, trace)) => + ((root, forgery, verdict), (cache, trace.toSigningLog)) + +def viewedGameLogProjection : + ((Digest × Forgery × Bool) × ViewedFullTraceState) → RetainedGameLogResult + | ((root, forgery, verdict), state) => + ((root, forgery, verdict), (state.cache, state.trace.signing.toSigningLog)) + +theorem actualRetainedGameAfterTable_signing_projection + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : Coordinate → HashOutput) : + retainedGameLogProjection <$> + actualRetainedGameAfterTable adversary parameter ftsSecret table = + signingGameLogProjection <$> + gameAfterSecretsWithSigningTrace adversary parameter (tableOtsSecret table) + ftsSecret := by + let rootComputation : OracleComp HashSpec Digest := + treeRoot parameter topLayer rootTree (tableOtsSecret table topLayer rootTree) + have hroot : simulateQ romImpl + (liftM rootComputation : OracleComp OracleWorld Digest) = + simulateQ (randomOracle : QueryImpl HashSpec _) rootComputation := by + change simulateQ (unifFwdImpl HashSpec + randomOracle) + (liftM rootComputation : OracleComp OracleWorld Digest) = _ + exact QueryImpl.simulateQ_add_liftM_right _ _ _ + unfold actualRetainedGameAfterTable gameAfterSecretsWithSigningTrace + rw [show treeRoot parameter topLayer rootTree + (tableOtsSecret table topLayer rootTree) = rootComputation from rfl, hroot] + simp only [map_bind] + apply bind_congr + intro rootResult + let secretKey : SecretKey := + ⟨parameter, rootResult.1, tableOtsSecret table, ftsSecret⟩ + have hrest := congrArg + (Functor.map fun result : RetainedLogResult => + ((rootResult.1, result.1.1, result.1.2), result.2)) + (retainedGameRest_signing_projection adversary + (⟨rootResult.1, parameter⟩ : PublicKey) secretKey rootResult.2) + simpa [retainedGameLogProjection, signingGameLogProjection, + retainedRestLogProjection, signingRestLogProjection, secretKey, + Functor.map_map, map_bind, bind_map_left] using hrest + +theorem gameAfterSecretsWithViewTrace_actualRetained_projection + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : Coordinate → HashOutput) : + viewedGameLogProjection <$> + gameAfterSecretsWithViewTrace adversary parameter (tableOtsSecret table) ftsSecret = + retainedGameLogProjection <$> + actualRetainedGameAfterTable adversary parameter ftsSecret table := by + rw [show viewedGameLogProjection = + Concrete.FtsProbeSimulation.viewedGameLogProjection from rfl] + rw [Concrete.FtsProbeSimulation.gameAfterSecretsWithViewTrace_log_projection] + exact (actualRetainedGameAfterTable_signing_projection adversary parameter + ftsSecret table).symm + +def RetainedWitnessFor (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (event : QueryImpl HashSpec Id → QueryCache HashSpec → SecretKey → + QueryLog SigningSpec → Forgery → Index → (DigestTree → FtsLeaf) → Prop) + (result : RetainedGameResult × QueryCache HashSpec) : Prop := + let root := result.1.1 + let forgery := result.1.2.1.1 + let log := result.1.2.1.2 + ∃ (f : QueryImpl HashSpec Id) (digest : MessageDigest), + result.2.AgreesWithFn f + ∧ SigningTranscript.Valid log + ∧ ¬SigningTranscript.Contains log forgery + ∧ evalWithAnswerFn f + (messageDigest parameter root forgery.message forgery.signature.randomness) = digest + ∧ Admissible digest + ∧ event f result.2 ⟨parameter, root, tableOtsSecret table, ftsSecret⟩ + log forgery (digestIndex digest) (digestLeaves digest) + +def RetainedLogWitnessFor (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (event : QueryImpl HashSpec Id → QueryCache HashSpec → SecretKey → + QueryLog SigningSpec → Forgery → Index → (DigestTree → FtsLeaf) → Prop) + (result : RetainedGameLogResult) : Prop := + let root := result.1.1 + let forgery := result.1.2.1 + let cache := result.2.1 + let log := result.2.2 + ∃ (f : QueryImpl HashSpec Id) (digest : MessageDigest), + cache.AgreesWithFn f + ∧ SigningTranscript.Valid log + ∧ ¬SigningTranscript.Contains log forgery + ∧ evalWithAnswerFn f + (messageDigest parameter root forgery.message forgery.signature.randomness) = digest + ∧ Admissible digest + ∧ event f cache ⟨parameter, root, tableOtsSecret table, ftsSecret⟩ + log forgery (digestIndex digest) (digestLeaves digest) + +def WinningRetainedWitnessFor (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (event : QueryImpl HashSpec Id → QueryCache HashSpec → SecretKey → + QueryLog SigningSpec → Forgery → Index → (DigestTree → FtsLeaf) → Prop) + (result : RetainedGameResult × QueryCache HashSpec) : Prop := + let root := result.1.1 + let forgery := result.1.2.1.1 + let log := result.1.2.1.2 + result.1.2.2 = true ∧ + ∃ (f : QueryImpl HashSpec Id) (digest : MessageDigest), + result.2.AgreesWithFn f + ∧ SigningTranscript.Valid log + ∧ ¬SigningTranscript.Contains log forgery + ∧ evalWithAnswerFn f + (messageDigest parameter root forgery.message forgery.signature.randomness) = digest + ∧ Admissible digest + ∧ evalWithAnswerFn f + (verify ⟨root, parameter⟩ forgery.message forgery.signature) = true + ∧ event f result.2 ⟨parameter, root, tableOtsSecret table, ftsSecret⟩ + log forgery (digestIndex digest) (digestLeaves digest) + +def WinningRetainedLogWitnessFor (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (event : QueryImpl HashSpec Id → QueryCache HashSpec → SecretKey → + QueryLog SigningSpec → Forgery → Index → (DigestTree → FtsLeaf) → Prop) + (result : RetainedGameLogResult) : Prop := + let root := result.1.1 + let forgery := result.1.2.1 + let cache := result.2.1 + let log := result.2.2 + result.1.2.2 = true ∧ + ∃ (f : QueryImpl HashSpec Id) (digest : MessageDigest), + cache.AgreesWithFn f + ∧ SigningTranscript.Valid log + ∧ ¬SigningTranscript.Contains log forgery + ∧ evalWithAnswerFn f + (messageDigest parameter root forgery.message forgery.signature.randomness) = digest + ∧ Admissible digest + ∧ evalWithAnswerFn f + (verify ⟨root, parameter⟩ forgery.message forgery.signature) = true + ∧ event f cache ⟨parameter, root, tableOtsSecret table, ftsSecret⟩ + log forgery (digestIndex digest) (digestLeaves digest) + +theorem viewedWitness_iff_logProjection + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (event : QueryImpl HashSpec Id → QueryCache HashSpec → SecretKey → + QueryLog SigningSpec → Forgery → Index → (DigestTree → FtsLeaf) → Prop) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : + ViewedTerminalWitnessFor parameter (tableOtsSecret table) ftsSecret event result ↔ + RetainedLogWitnessFor parameter table ftsSecret event + (viewedGameLogProjection result) := by + rfl + +theorem viewedWinningWitness_iff_logProjection + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (event : QueryImpl HashSpec Id → QueryCache HashSpec → SecretKey → + QueryLog SigningSpec → Forgery → Index → (DigestTree → FtsLeaf) → Prop) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : + (result.1.2.2 = true ∧ + ViewedWinningTerminalWitnessFor parameter (tableOtsSecret table) ftsSecret event result) ↔ + WinningRetainedLogWitnessFor parameter table ftsSecret event + (viewedGameLogProjection result) := by + rfl + +theorem logProjection_witness_imp_retained + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (event : QueryImpl HashSpec Id → QueryCache HashSpec → SecretKey → + QueryLog SigningSpec → Forgery → Index → (DigestTree → FtsLeaf) → Prop) + (result : RetainedGameResult × QueryCache HashSpec) + (hwitness : RetainedLogWitnessFor parameter table ftsSecret event + (retainedGameLogProjection result)) : + RetainedWitnessFor parameter table ftsSecret event result := by + rcases result with ⟨⟨root, ⟨⟨forgery, log⟩, verified⟩⟩, cache⟩ + exact hwitness + +theorem logProjection_winningWitness_imp_retained + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (event : QueryImpl HashSpec Id → QueryCache HashSpec → SecretKey → + QueryLog SigningSpec → Forgery → Index → (DigestTree → FtsLeaf) → Prop) + (result : RetainedGameResult × QueryCache HashSpec) + (hwitness : WinningRetainedLogWitnessFor parameter table ftsSecret event + (retainedGameLogProjection result)) : + WinningRetainedWitnessFor parameter table ftsSecret event result := by + rcases result with ⟨⟨root, ⟨⟨forgery, log⟩, verified⟩⟩, cache⟩ + have hverified : verified = true := by + cases verified <;> + simp_all [WinningRetainedLogWitnessFor, retainedGameLogProjection] + exact ⟨hverified, hwitness.2⟩ + +theorem probEvent_viewedWitness_le_actualRetained + (adversary : Adversary) (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (event : QueryImpl HashSpec Id → QueryCache HashSpec → SecretKey → + QueryLog SigningSpec → Forgery → Index → (DigestTree → FtsLeaf) → Prop) : + Pr[ViewedTerminalWitnessFor parameter (tableOtsSecret table) ftsSecret event | + gameAfterSecretsWithViewTrace adversary parameter (tableOtsSecret table) ftsSecret] ≤ + Pr[RetainedWitnessFor parameter table ftsSecret event | + actualRetainedGameAfterTable adversary parameter ftsSecret table] := by + calc + Pr[ViewedTerminalWitnessFor parameter (tableOtsSecret table) ftsSecret event | + gameAfterSecretsWithViewTrace adversary parameter (tableOtsSecret table) ftsSecret] = + Pr[RetainedLogWitnessFor parameter table ftsSecret event | + viewedGameLogProjection <$> + gameAfterSecretsWithViewTrace adversary parameter (tableOtsSecret table) + ftsSecret] := by + rw [probEvent_map] + apply OracleComp.probEvent_congr' + · intro result _ + exact viewedWitness_iff_logProjection parameter table ftsSecret event result + · rfl + _ = Pr[RetainedLogWitnessFor parameter table ftsSecret event | + retainedGameLogProjection <$> + actualRetainedGameAfterTable adversary parameter ftsSecret table] := by + apply OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + exact congrArg evalDist + (gameAfterSecretsWithViewTrace_actualRetained_projection adversary parameter + ftsSecret table) + _ ≤ Pr[RetainedWitnessFor parameter table ftsSecret event | + actualRetainedGameAfterTable adversary parameter ftsSecret table] := by + rw [probEvent_map] + exact probEvent_mono fun result _ hwitness => + logProjection_witness_imp_retained parameter table ftsSecret event result hwitness + +theorem probEvent_viewedWinningWitness_le_actualRetained + (adversary : Adversary) (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (event : QueryImpl HashSpec Id → QueryCache HashSpec → SecretKey → + QueryLog SigningSpec → Forgery → Index → (DigestTree → FtsLeaf) → Prop) : + Pr[fun result => result.1.2.2 = true ∧ + ViewedWinningTerminalWitnessFor parameter (tableOtsSecret table) ftsSecret event result | + gameAfterSecretsWithViewTrace adversary parameter (tableOtsSecret table) ftsSecret] ≤ + Pr[WinningRetainedWitnessFor parameter table ftsSecret event | + actualRetainedGameAfterTable adversary parameter ftsSecret table] := by + calc + _ = Pr[WinningRetainedLogWitnessFor parameter table ftsSecret event | + viewedGameLogProjection <$> + gameAfterSecretsWithViewTrace adversary parameter (tableOtsSecret table) + ftsSecret] := by + rw [probEvent_map] + apply OracleComp.probEvent_congr' + · intro result _ + exact viewedWinningWitness_iff_logProjection parameter table ftsSecret event result + · rfl + _ = Pr[WinningRetainedLogWitnessFor parameter table ftsSecret event | + retainedGameLogProjection <$> + actualRetainedGameAfterTable adversary parameter ftsSecret table] := by + apply OracleComp.probEvent_congr' (fun _ _ => Iff.rfl) + exact congrArg evalDist + (gameAfterSecretsWithViewTrace_actualRetained_projection adversary parameter + ftsSecret table) + _ ≤ Pr[WinningRetainedWitnessFor parameter table ftsSecret event | + actualRetainedGameAfterTable adversary parameter ftsSecret table] := by + rw [probEvent_map] + exact probEvent_mono fun result _ hwitness => + logProjection_winningWitness_imp_retained parameter table ftsSecret event result hwitness + +def RetainedFreshLayerOpeningWitness (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := + RetainedWitnessFor parameter table ftsSecret + fun f cache secretKey log forgery index leaves => + SettledForgedFreshLayerOpening f cache secretKey log index leaves forgery.signature + +def RetainedBackwardChainOpeningWitness (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := + RetainedWitnessFor parameter table ftsSecret + fun f cache secretKey log forgery index leaves => + SettledForgedBackwardChainOpening f cache secretKey log index leaves forgery.signature + +def WinningRetainedFreshLayerOpeningWitness (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := + WinningRetainedWitnessFor parameter table ftsSecret + fun f cache secretKey log forgery index leaves => + ¬Bad parameter (tableOtsSecret table) ftsSecret cache ∧ + SettledForgedFreshLayerOpening f cache secretKey log index leaves forgery.signature + +def WinningRetainedBackwardChainOpeningWitness (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := + WinningRetainedWitnessFor parameter table ftsSecret + fun f cache secretKey log forgery index leaves => + ¬Bad parameter (tableOtsSecret table) ftsSecret cache ∧ + SettledForgedBackwardChainOpening f cache secretKey log index leaves forgery.signature + +theorem probEvent_cleanFresh_le_actualRetained + (adversary : Adversary) (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[cleanFreshEvent parameter (tableOtsSecret table) ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter (tableOtsSecret table) ftsSecret] ≤ + Pr[WinningRetainedFreshLayerOpeningWitness parameter table ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret table] := by + calc + _ ≤ Pr[fun result => result.1.2.2 = true ∧ + ViewedWinningTerminalWitnessFor parameter (tableOtsSecret table) ftsSecret + (fun f cache secretKey log forgery index leaves => + ¬Bad parameter (tableOtsSecret table) ftsSecret cache ∧ + SettledForgedFreshLayerOpening f cache secretKey log index leaves + forgery.signature) + result | + gameAfterSecretsWithViewTrace adversary parameter (tableOtsSecret table) + ftsSecret] := by + apply probEvent_mono + intro _ _ hevent + rcases hevent with ⟨⟨hbad, hverdict⟩, f, digest, hf, hvalid, hnotContains, + hdigest, hadmissible, heval, hfresh⟩ + exact ⟨hverdict, f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, + heval, hbad, hfresh⟩ + _ ≤ _ := probEvent_viewedWinningWitness_le_actualRetained adversary parameter table ftsSecret + (fun f cache secretKey log forgery index leaves => + ¬Bad parameter (tableOtsSecret table) ftsSecret cache ∧ + SettledForgedFreshLayerOpening f cache secretKey log index leaves forgery.signature) + +theorem probEvent_cleanBackward_le_actualRetained + (adversary : Adversary) (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[cleanBackwardEvent parameter (tableOtsSecret table) ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter (tableOtsSecret table) ftsSecret] ≤ + Pr[WinningRetainedBackwardChainOpeningWitness parameter table ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret table] := by + calc + _ ≤ Pr[fun result => result.1.2.2 = true ∧ + ViewedWinningTerminalWitnessFor parameter (tableOtsSecret table) ftsSecret + (fun f cache secretKey log forgery index leaves => + ¬Bad parameter (tableOtsSecret table) ftsSecret cache ∧ + SettledForgedBackwardChainOpening f cache secretKey log index leaves + forgery.signature) + result | + gameAfterSecretsWithViewTrace adversary parameter (tableOtsSecret table) + ftsSecret] := by + apply probEvent_mono + intro _ _ hevent + rcases hevent with ⟨⟨hbad, hverdict⟩, f, digest, hf, hvalid, hnotContains, + hdigest, hadmissible, heval, hbackward⟩ + exact ⟨hverdict, f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, + heval, hbad, hbackward⟩ + _ ≤ _ := probEvent_viewedWinningWitness_le_actualRetained adversary parameter table ftsSecret + (fun f cache secretKey log forgery index leaves => + ¬Bad parameter (tableOtsSecret table) ftsSecret cache ∧ + SettledForgedBackwardChainOpening f cache secretKey log index leaves + forgery.signature) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRetainedGuessCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRetainedGuessCharge.lean new file mode 100644 index 00000000..dd3814d9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRetainedGuessCharge.lean @@ -0,0 +1,95 @@ +import SphincsSecurity.Proof.OtsProbeRiskAccumulation + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +theorem resolvedContextFailureRisk_of_no_pending + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hvalid : context.Valid) (hstarts : StartTableAgrees context.state table) + (hcovered : PendingCoveredBy [] context) : + resolvedContextFailureRisk table context = 0 := by + have hcoordinates : PendingCovered [] context := by + intro entry hentry + obtain ⟨candidate, hcandidate, _⟩ := hcovered entry hentry + simp at hcandidate + have hcard := hcovered.card_le + rw [resolvedContextFailureRisk_eq_finalize_coordinates table context [] hvalid hstarts hcoordinates + (by simp) (by simpa using lt_of_le_of_lt hcard (Fintype.card_pos : 0 < Fintype.card Digest))] + simp [finalizeResolvedCoordinates] + +noncomputable def canonicalRetainedGuessCharge + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : ℝ≥0∞ := + ∑' root, Pr[= root | runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)] * + match root with + | none => 0 + | some root => expectedCanonicalQueryCharge parameter root.value.1 ftsSecret + (canonicalGuessCharge parameter table) + (retainedGameRestComputation adversary ⟨root.value.1, parameter⟩) + root.context root.remaining root.table root.value.2 + +theorem probEvent_canonicalRetainedTrace_none_le_guessCharge + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun result => result.1 = none | canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel] ≤ + canonicalRetainedGuessCharge adversary parameter table ftsSecret fuel := by + unfold canonicalRetainedQueryTrace canonicalRetainedGuessCharge + rw [probEvent_bind_eq_tsum] + apply ENNReal.tsum_le_tsum + intro option + by_cases hroot : option ∈ support (runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)) + · cases option with + | none => exact False.elim (none_not_mem_resolved_maskedPublishedTreeRoot table fuel hroot) + | some root => + dsimp only + apply mul_le_mul_right + have hcore := resolvedCore_of_mem_runResolvedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table root (by intro coordinate output hvalue; simp [LazyRevealProbe.State.empty] at hvalue) + (by intro index output hvalue; simp [LazyRevealProbe.State.empty] at hvalue) hroot + have hcomplete := deferredCompletable_of_mem_resolved_maskedPublishedTreeRoot parameter table fuel root hroot + rw [hcore.1] at hcomplete + have hcovered := pendingCoveredBy_of_mem_runResolvedFromTable [] _ _ fuel table root pendingCoveredBy_empty + (OracleComp.IsQueryBoundP.of_imp (isUncoveredProbe_imp_isProbe []) + (maskedPublishedTreeRoot_probeFree emptySplitHashCache)) hroot + have hzero := resolvedContextFailureRisk_of_no_pending table root.context + (valid_of_resolvedCore_completable table root.context hcore.2.1 hcore.2.2 hcomplete) hcore.2.2 hcovered + have hprojection := probEvent_bind_pure_comp + (runCanonicalQueryTrace parameter root.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨root.value.1, parameter⟩) + root.context root.remaining root.table root.value.2) + (fun rest => (rest.1.map (retainedResultWithRoot root.value.1), rest.2)) + (fun result => result.1 = none) + have hbound := probEvent_canonicalTrace_none_le_initial_add_guessCharge parameter root.value.1 table ftsSecret + (retainedGameRestComputation adversary ⟨root.value.1, parameter⟩) + root.context root.remaining root.value.2 hcore.2.1 hcore.2.2 + rw [hzero, zero_add] at hbound + rw [hcore.1] + calc + _ = Pr[fun result => result.1 = none | runCanonicalQueryTrace parameter root.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨root.value.1, parameter⟩) + root.context root.remaining table root.value.2] := by + simpa only [Function.comp_def, Option.map_eq_none_iff, hcore.1] using hprojection + _ ≤ _ := hbound + · rw [probOutput_eq_zero_of_not_mem_support hroot, zero_mul, zero_mul] + +theorem probEvent_retainedVerifyProbe_le_guessCharge + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table)] ≤ + canonicalRetainedGuessCharge adversary parameter table ftsSecret fuel := by + apply (probEvent_retainedVerifyProbe_le_rejectionRisk adversary parameter table ftsSecret fuel).trans + rw [← probEvent_canonicalRetainedTrace_none_eq_rejectionRisk] + exact probEvent_canonicalRetainedTrace_none_le_guessCharge adversary parameter table ftsSecret fuel + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRetainedPrehitProjection.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRetainedPrehitProjection.lean new file mode 100644 index 00000000..c891a8e6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRetainedPrehitProjection.lean @@ -0,0 +1,83 @@ +import SphincsSecurity.Proof.OtsProbeRetainedPrehitTrace + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open SphincsSecurity.Concrete.TightEncoding + +set_option backward.isDefEq.respectTransparency false + +theorem encodingPrehitViewedAdversaryImpl_cacheFlag_projection + (accountingKey secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (state : ViewedFullTraceState × Bool) : + (fun result => ((result.1, result.2.1.cache), result.2.2)) <$> + (simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run state = + runEncodingPrehitMonitor accountingKey (simulateQ (expandedAdversaryImpl secretKey) computation) state.1.cache state.2 := by + calc + _ = (fun result : α × ((QueryCache HashSpec × Bool) × QueryLog SigningSpec) => + ((result.1, result.2.1.1), result.2.1.2)) <$> + (Prod.map id encodingPrehitViewedLogState <$> + (simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run state) := by + rw [Functor.map_map] + rfl + _ = runEncodingPrehitMonitor accountingKey (Prod.fst <$> + (simulateQ (forwardOracles + signingOracle scheme secretKey) computation).run) state.1.cache state.2 := by + rw [encodingPrehitViewedAdversaryImpl_log_projection, runEncodingPrehitMonitor_map, Functor.map_map] + _ = _ := by + rw [forwardOracles_add_signingOracle_eq_withTraceAppend, QueryImpl.fst_map_run_withTraceAppend] + +theorem runPrehitQueryTrace_monitor_projection + (accountingKey secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (state : ViewedFullTraceState × Bool) : + (fun result => ((result.1.1, result.1.2.1.cache), result.1.2.2)) <$> + runPrehitQueryTrace accountingKey secretKey computation state = + runEncodingPrehitMonitor accountingKey (simulateQ (expandedAdversaryImpl secretKey) computation) state.1.cache state.2 := by + rw [← encodingPrehitViewedAdversaryImpl_cacheFlag_projection accountingKey secretKey computation state, + ← runPrehitQueryTrace_projection, Functor.map_map] + +def retainedRestVerdict (result : RetainedRestResult) : Bool := + decide (SigningTranscript.Valid result.1.2 ∧ ¬SigningTranscript.Contains result.1.2 result.1.1) && result.2 + +def retainedPrehitVerdictProjection + (result : (RetainedGameResult × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) : + (Bool × QueryCache HashSpec) × Bool := + ((retainedRestVerdict result.1.1.2, result.1.2.1.cache), result.1.2.2) + +theorem prehitRetainedQueryTrace_monitor_projection + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + retainedPrehitVerdictProjection <$> prehitRetainedQueryTrace adversary parameter table ftsSecret = + runEncodingPrehitMonitor (primitiveAccountingKey parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) ∅ false := by + unfold prehitRetainedQueryTrace gameAfterSecrets + rw [runEncodingPrehitMonitor_bind, map_bind] + apply bind_congr + intro root + simp only [map_bind, map_pure, retainedPrehitVerdictProjection] + rw [gameRest_eq_map_retained, runEncodingPrehitMonitor_map, + ← runPrehitQueryTrace_monitor_projection _ _ _ (⟨root.1.2, ⟨[], [], []⟩, [], none⟩, root.2), Functor.map_map] + rfl + +theorem probEvent_prehitRetainedQueryTrace_jointBad_le_queryCharge + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + let otsSecret := fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩) + let accountingKey := primitiveAccountingKey parameter otsSecret ftsSecret + Pr[fun result => result.1.2.2 = true ∨ + SphincsSecurity.Bad parameter otsSecret ftsSecret result.1.2.1.cache ∨ + EncodingBad result.1.2.1.cache accountingKey | + prehitRetainedQueryTrace adversary parameter table ftsSecret] ≤ + expectedQueryCharge (refinedStructuralEncodingQueryCharge accountingKey) (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + dsimp only + have hbound := probEvent_prehit_or_bad_or_encodingBad_le_queryCharge + (primitiveAccountingKey parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) + rw [← prehitRetainedQueryTrace_monitor_projection, probEvent_map] at hbound + exact hbound + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRetainedPrehitTrace.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRetainedPrehitTrace.lean new file mode 100644 index 00000000..7820ded5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRetainedPrehitTrace.lean @@ -0,0 +1,160 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalTraceSupport +import SphincsSecurity.Proof.OtsProbeQueryTraceReserve + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +theorem runPrehitQueryTrace_cache_projection + (accountingKey secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (state : ViewedFullTraceState × Bool) : + (fun result => (result.1.1, result.1.2.1.cache)) <$> runPrehitQueryTrace accountingKey secretKey computation state = + (simulateQ (unloggedMappedAdversaryImpl secretKey) computation).run state.1.cache := by + rw [← encodingPrehitViewedAdversaryImpl_cache_projection accountingKey secretKey computation state, + ← runPrehitQueryTrace_projection, Functor.map_map] + +noncomputable def prehitRetainedQueryTrace + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ProbComp ((RetainedGameResult × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) := do + let otsSecret := fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩) + let accountingKey := primitiveAccountingKey parameter otsSecret ftsSecret + let root ← TightEncoding.runEncodingPrehitMonitor accountingKey + (liftM (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : OracleComp HashSpec Digest) : + OracleComp OracleWorld Digest) ∅ false + let rest ← runPrehitQueryTrace accountingKey ⟨parameter, root.1.1, otsSecret, ftsSecret⟩ + (retainedGameRestComputation adversary ⟨root.1.1, parameter⟩) + (⟨root.1.2, ⟨[], [], []⟩, [], none⟩, root.2) + pure (((root.1.1, rest.1.1), rest.1.2), rest.2) + +theorem prehitRetainedQueryTrace_cache_projection + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + (fun result => (result.1.1, result.1.2.1.cache)) <$> prehitRetainedQueryTrace adversary parameter table ftsSecret = + actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table) := by + let otsSecret := fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩) + let accountingKey := primitiveAccountingKey parameter otsSecret ftsSecret + have hroot := TightEncoding.runEncodingPrehitMonitor_project accountingKey + (liftM (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : OracleComp HashSpec Digest) : + OracleComp OracleWorld Digest) ∅ false + rw [simulateQ_romImpl_liftM] at hroot + unfold prehitRetainedQueryTrace actualRetainedGameAfterTable + change _ = ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅ >>= fun root => do + let result ← (simulateQ (unloggedMappedAdversaryImpl ⟨parameter, root.1, otsSecret, ftsSecret⟩) + (retainedGameRestComputation adversary ⟨root.1, parameter⟩)).run root.2 + pure ((root.1, result.1), result.2)) + rw [← hroot, bind_map_left, map_bind] + apply bind_congr + intro root + simp only [map_bind, map_pure] + have hrest := runPrehitQueryTrace_cache_projection accountingKey ⟨parameter, root.1.1, otsSecret, ftsSecret⟩ + (retainedGameRestComputation adversary ⟨root.1.1, parameter⟩) (⟨root.1.2, ⟨[], [], []⟩, [], none⟩, root.2) + rw [← hrest, bind_map_left] + +theorem CanonicalQueryTraceRel.retainedRoot + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} (root : Digest) + {left : Option (ResolvedRunResult (RetainedRestResult × SplitHashCache)) × List CanonicalQuerySelection} + {right : (RetainedRestResult × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot} + (hrelation : CanonicalQueryTraceRel parameter table left right) : + CanonicalQueryTraceRel parameter table (left.1.map (retainedResultWithRoot root), left.2) + (((root, right.1.1), right.1.2), right.2) := by + refine ⟨?_, hrelation.2⟩ + rcases left with ⟨result, history⟩ + cases result with + | none => trivial + | some result => + exact ⟨hrelation.1.1, congrArg (root, ·) hrelation.1.2.1, hrelation.1.2.2⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_canonicalRetainedQueryTrace_prehit + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + RelTriple (canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel) + (prehitRetainedQueryTrace adversary parameter table ftsSecret) (CanonicalQueryTraceRel parameter table) := by + classical + let otsSecret := fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩) + let accountingKey := primitiveAccountingKey parameter otsSecret ftsSecret + have hroot := reachableResolvedCouples_maskedPublishedTreeRoot parameter table + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel emptySplitHashCache ∅ (resolvedContextInvariant_empty parameter table) + (visibleResolvedComputationsCached_empty parameter table emptyDeferredStructuralValues ∅) publishedValues_empty + have hsupported := FtsProbeSimulation.relTriple_and_left_support hroot + (fun left => ∀ result, left = some result → DeferredComputationsClosed result.context) (by + intro left hleft result heq + subst left + exact deferredComputationsClosed_empty.of_mem_runResolved _ _ fuel table result hleft) + have hprojection := TightEncoding.runEncodingPrehitMonitor_project accountingKey + (liftM (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : OracleComp HashSpec Digest) : + OracleComp OracleWorld Digest) ∅ false + rw [simulateQ_romImpl_liftM] at hprojection + have hmonitor := relTriple_of_evalDist_map_eq_general + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅) + (TightEncoding.runEncodingPrehitMonitor accountingKey + (liftM (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : OracleComp HashSpec Digest) : + OracleComp OracleWorld Digest) ∅ false) + id Prod.fst (by simpa only [id_map] using congrArg evalDist hprojection.symm) + unfold canonicalRetainedQueryTrace prehitRetainedQueryTrace + apply relTriple_bind (relTriple_trans_exists hsupported hmonitor) + rintro leftRoot rightRoot ⟨actualRoot, hrelation, heq⟩ + have hbase : ReachableResolvedRunRel parameter table leftRoot rightRoot.1 := heq ▸ hrelation.1 + cases leftRoot with + | none => exact relTriple_empty_canonicalTrace_any parameter table _ + | some result => + have hcomputed := hrelation.2 result rfl + dsimp only + rcases hbase with hclean | hdoomed + · rw [hclean.1, ← hclean.2.1] + have htrace := relTriple_canonicalQueryTrace_prehitQueryTrace parameter result.value.1 table ftsSecret accountingKey + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) result.context result.remaining result.value.2 + (⟨rightRoot.1.2, ⟨[], [], []⟩, [], none⟩, rightRoot.2) + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 hcomputed + have hmap := relTriple_map + (f := fun rest : Option (ResolvedRunResult (RetainedRestResult × SplitHashCache)) × List CanonicalQuerySelection => + (rest.1.map (retainedResultWithRoot result.value.1), rest.2)) + (g := fun rest : (RetainedRestResult × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot => + (((result.value.1, rest.1.1), rest.1.2), rest.2)) + (relTriple_post_mono htrace fun left right hrel => hrel.retainedRoot result.value.1) + simpa only [map_eq_bind_pure_comp, Function.comp_def] using hmap + · rw [runCanonicalQueryTrace_of_not_completable parameter result.value.1 ftsSecret _ + result.context result.remaining result.table result.value.2 (by rw [hdoomed.1]; exact hdoomed.2.2.2)] + simp only [pure_bind, Option.map_none] + exact relTriple_empty_canonicalTrace_any parameter table _ + +theorem relTriple_canonicalRetainedQueryTrace_prehit_witness + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + RelTriple (canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel) + (prehitRetainedQueryTrace adversary parameter table ftsSecret) + (fun left right => CanonicalQueryTraceRel parameter table left right ∧ + (WinningRetainedVerifyProbeWitness parameter (extendStartTable table) ftsSecret + (right.1.1, right.1.2.1.cache) → left.1 = none)) := by + have hbase := relTriple_canonicalRetainedQueryTrace_prehit adversary parameter table ftsSecret fuel + have hleft := FtsProbeSimulation.relTriple_and_left_support hbase + (fun left => left ∈ support (canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel)) + (fun _ hsupport => hsupport) + have hboth := FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_post_mono hboth + intro left right hrelation + refine ⟨hrelation.1.1, ?_⟩ + intro hwitness + have hactual : (right.1.1, right.1.2.1.cache) ∈ support + (actualRetainedGameAfterTable adversary parameter ftsSecret (extendStartTable table)) := by + rw [← prehitRetainedQueryTrace_cache_projection, support_map] + exact ⟨right, hrelation.2, rfl⟩ + rcases left with ⟨result, history⟩ + cases result with + | none => rfl + | some result => + have hterminal := hrelation.1.1.1 + have hreachable : ReachableResolvedRunRel parameter table (some result) (right.1.1, right.1.2.1.cache) := + Or.inl ⟨hterminal.1, hterminal.2.1, hterminal.2.2.1, hterminal.2.2.2.1, hterminal.2.2.2.2.1⟩ + exact False.elim (not_winningRetainedVerifyProbe_of_canonicalRetainedTrace_relation adversary parameter table ftsSecret fuel + result history right.1.1 right.1.2.1.cache hrelation.1.2 hactual hreachable hwitness) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRiskAccumulation.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRiskAccumulation.lean new file mode 100644 index 00000000..979be435 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRiskAccumulation.lean @@ -0,0 +1,214 @@ +import SphincsSecurity.Proof.OtsProbeFreshGuessRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option backward.isDefEq.respectTransparency false + +noncomputable def canonicalGuessCharge (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) + (_cache : SplitHashCache) : ℝ≥0∞ := + if 0 < fuel ∧ context.state.pending.card + 1 < Fintype.card Digest then + match input with + | .inl (.inr input) => candidateFailureAllowance table context + (purePlanProbingHashQuery parameter input context.state).candidate? + | _ => 0 + else 1 + +theorem probEvent_canonicalQuery_finished_le_guessCharge + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + Pr[fun verdict => verdict = true | + canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache >>= + finishResolvedRunIsNone] ≤ + resolvedContextFailureRisk table context + canonicalGuessCharge parameter table input context fuel cache := by + classical + by_cases hsafe : 0 < fuel ∧ context.state.pending.card + 1 < Fintype.card Digest + · unfold canonicalGuessCharge + rw [if_pos hsafe] + by_cases hhash : ∃ hashInput, input = .inl (.inr hashInput) + · obtain ⟨hashInput, rfl⟩ := hhash + obtain ⟨remaining, rfl⟩ := Nat.exists_eq_succ_of_ne_zero (Nat.ne_zero_of_lt hsafe.1) + exact probEvent_canonicalHashQuery_finished_le_initial_add_allowance parameter root table ftsSecret + hashInput context remaining cache hconsistent hstarts hsafe.2 + · have hcount : outerHashQueryCount input = 0 := by + cases input with + | inl query => cases query <;> simp_all [outerHashQueryCount] + | inr message => rfl + have hzero : (match input with + | .inl (.inr hashInput) => candidateFailureAllowance table context + (purePlanProbingHashQuery parameter hashInput context.state).candidate? + | _ => (0 : ℝ≥0∞)) = 0 := by + cases input with + | inl query => cases query <;> simp_all + | inr message => rfl + rw [hzero, add_zero] + have hbound := maskedChronologicalExpandedAdversaryImpl_probeBound parameter root ftsSecret input cache + rw [hcount] at hbound + have hdist := (evalDist_canonicalQuery_finished_eq_raw parameter root table ftsSecret input + context fuel cache hconsistent hstarts).trans + (evalDist_runResolvedFinishIsNone_probeFree_of_core _ context fuel table () hbound hconsistent hstarts (by omega)) + have hprob := congrArg (fun distribution : SPMF Bool => distribution true) hdist + change Pr[= true | _] = Pr[= true | _] at hprob + rw [← probEvent_eq_eq_probOutput, ← probEvent_eq_eq_probOutput, + finishResolvedRunIsNone_metadata_eq context table fuel 0 () ()] at hprob + exact le_of_eq hprob + · unfold canonicalGuessCharge + rw [if_neg hsafe] + exact probEvent_le_one.trans (le_add_of_nonneg_left bot_le) + +noncomputable def resolvedOutcomeFailureRisk : Option (ResolvedRunResult α) → ℝ≥0∞ + | none => 1 + | some result => resolvedContextFailureRisk result.table result.context + +theorem probEvent_finished_eq_expected_outcomeRisk + (computation : ProbComp (Option (ResolvedRunResult α))) : + Pr[fun verdict => verdict = true | computation >>= finishResolvedRunIsNone] = + ∑' option, Pr[= option | computation] * resolvedOutcomeFailureRisk option := by + rw [probEvent_bind_eq_tsum] + apply tsum_congr + intro option + cases option with + | none => simp [finishResolvedRunIsNone, finishResolvedRun, resolvedOutcomeFailureRisk] + | some result => + rw [finishResolvedRunIsNone_metadata_eq result.context result.table result.remaining 0 result.value ()] + rfl + +noncomputable def expectedCanonicalTerminalRisk + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) : ℝ≥0∞ := + ∑' result, Pr[= result | runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache] * + resolvedOutcomeFailureRisk result.1 + +theorem expectedCanonicalTerminalRisk_query_bind + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcomplete : DeferredCompletable table context) : + expectedCanonicalTerminalRisk parameter root ftsSecret (OracleSpec.query input >>= next) context fuel table cache = + ∑' option, Pr[= option | canonicalChronologicalAdversaryImpl parameter root table ftsSecret + input context fuel table cache] * + match option with + | none => 1 + | some result => expectedCanonicalTerminalRisk parameter root ftsSecret (next result.value.1) + result.context result.remaining result.table result.value.2 := by + rw [expectedCanonicalTerminalRisk, runCanonicalQueryTrace_query_bind, if_pos hcomplete, tsum_probOutput_bind_mul] + apply tsum_congr + intro option + cases option with + | none => simp [resolvedOutcomeFailureRisk] + | some result => + simp only [tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + rfl + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 800000 in +theorem expectedCanonicalTerminalRisk_le_initial_add_guessCharge + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + expectedCanonicalTerminalRisk parameter root ftsSecret computation context fuel table cache ≤ + resolvedContextFailureRisk table context + expectedCanonicalQueryCharge parameter root ftsSecret + (canonicalGuessCharge parameter table) computation context fuel table cache := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + by_cases hcomplete : DeferredCompletable table context + · simp [expectedCanonicalTerminalRisk, runCanonicalQueryTrace, expectedCanonicalQueryCharge, + resolvedOutcomeFailureRisk, hcomplete] + · simp [expectedCanonicalTerminalRisk, runCanonicalQueryTrace, expectedCanonicalQueryCharge, + resolvedOutcomeFailureRisk, hcomplete, resolvedContextFailureRisk_of_not_completable table context hcomplete] + | query_bind input next ih => + by_cases hcomplete : DeferredCompletable table context + · rw [expectedCanonicalTerminalRisk_query_bind parameter root ftsSecret input next context fuel table cache hcomplete] + let queryRun := canonicalChronologicalAdversaryImpl parameter root table ftsSecret input context fuel table cache + let tailCharge := fun option : Option (ResolvedRunResult ((OracleWorld + SigningSpec).Range input × SplitHashCache)) => + match option with + | none => (0 : ℝ≥0∞) + | some result => expectedCanonicalQueryCharge parameter root ftsSecret (canonicalGuessCharge parameter table) + (next result.value.1) result.context result.remaining result.table result.value.2 + have hstep := probEvent_canonicalQuery_finished_le_guessCharge parameter root table ftsSecret input + context fuel cache hconsistent hstarts + rw [probEvent_finished_eq_expected_outcomeRisk] at hstep + calc + _ ≤ ∑' option, Pr[= option | queryRun] * (resolvedOutcomeFailureRisk option + tailCharge option) := by + apply ENNReal.tsum_le_tsum + intro option + by_cases hoption : option ∈ support queryRun + · cases option with + | none => simp [queryRun, resolvedOutcomeFailureRisk, tailCharge] + | some result => + have hcore := resolvedCore_of_mem_canonicalChronologicalAdversaryImpl parameter root table ftsSecret + input context fuel cache result hconsistent hstarts hoption + simp only [resolvedOutcomeFailureRisk, tailCharge, hcore.1] + exact mul_le_mul' le_rfl (ih result.value.1 result.context result.remaining result.value.2 + hcore.2.1 hcore.2.2) + · have hzero := probOutput_eq_zero_of_not_mem_support hoption + change Pr[= option | queryRun] * _ ≤ _ + simp only [hzero, zero_mul, le_refl] + _ = (∑' option, Pr[= option | queryRun] * resolvedOutcomeFailureRisk option) + + ∑' option, Pr[= option | queryRun] * tailCharge option := by + simp_rw [mul_add] + rw [ENNReal.tsum_add] + _ ≤ (resolvedContextFailureRisk table context + canonicalGuessCharge parameter table input context fuel cache) + + ∑' option, Pr[= option | queryRun] * tailCharge option := add_le_add hstep le_rfl + _ = _ := by + rw [expectedCanonicalQueryCharge_query_bind, if_pos hcomplete] + exact add_assoc _ _ _ + · rw [expectedCanonicalTerminalRisk, runCanonicalQueryTrace_of_not_completable parameter root ftsSecret _ + context fuel table cache hcomplete, tsum_probOutput_pure_mul, + expectedCanonicalQueryCharge_eq_zero_of_not_completable parameter root ftsSecret _ _ + context fuel table cache hcomplete, + resolvedContextFailureRisk_of_not_completable table context hcomplete] + simp only [resolvedOutcomeFailureRisk, add_zero, le_refl] + +theorem probEvent_canonicalTrace_none_le_initial_add_guessCharge + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + Pr[fun result => result.1 = none | + runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache] ≤ + resolvedContextFailureRisk table context + expectedCanonicalQueryCharge parameter root ftsSecret + (canonicalGuessCharge parameter table) computation context fuel table cache := by + apply le_trans ?_ (expectedCanonicalTerminalRisk_le_initial_add_guessCharge parameter root table ftsSecret + computation context fuel cache hconsistent hstarts) + rw [probEvent_eq_tsum_ite, expectedCanonicalTerminalRisk] + apply ENNReal.tsum_le_tsum + intro result + cases result.1 <;> simp [resolvedOutcomeFailureRisk] + +attribute [local irreducible] maskedPublishedTreeRoot + +theorem canonicalGuessCharge_of_coupled_retainedTrace + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (left : Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)) × List CanonicalQuerySelection) + (right : (RetainedGameResult × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hleft : left ∈ support (canonicalRetainedQueryTrace adversary parameter table ftsSecret (q + 1))) + (hright : right ∈ support (prehitRetainedQueryTrace adversary parameter table ftsSecret)) + (hrelation : CanonicalQueryTraceRel parameter table left right) + (ordinal : Nat) (entry : CanonicalQuerySelection) (hentry : left.2[ordinal]? = some entry) : + canonicalGuessCharge parameter table entry.input entry.context entry.fuel entry.cache = + match entry.input with + | .inl (.inr input) => candidateFailureAllowance table entry.context + (purePlanProbingHashQuery parameter input entry.context.state).candidate? + | _ => 0 := by + have hfuel := positive_fuel_of_coupled_canonicalRetainedTrace adversary q hq parameter hparameter table ftsSecret hfts + left right hleft hright hrelation entry (List.mem_iff_getElem?.mpr ⟨ordinal, hentry⟩) + have hcard := pending_card_le_of_coupled_canonicalRetainedTrace adversary q hq parameter hparameter table ftsSecret + hfts (q + 1) left right hleft hright hrelation ordinal entry hentry + have hspace : 2 ^ 126 + 1 < Fintype.card Digest := by norm_num [digestBits] + unfold canonicalGuessCharge + rw [if_pos ⟨hfuel, by omega⟩] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootBudget.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootBudget.lean new file mode 100644 index 00000000..1b567b22 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootBudget.lean @@ -0,0 +1,98 @@ +import SphincsSecurity.Proof.OtsProbeDelayedRoot125 + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +theorem le_mul_of_le_add_self_mul + (probability epsilon fraction multiplier : ℝ≥0∞) + (hprobability : probability ≤ 1) (hepsilon : epsilon ≠ ∞) + (hfraction : fraction ≠ ∞) (hmultiplier : multiplier ≠ ∞) + (hcoefficient : fraction * multiplier + 1 ≤ multiplier) + (hbound : probability ≤ epsilon + probability * fraction) : + probability ≤ multiplier * epsilon := by + have hp : probability ≠ ∞ := ne_top_of_le_ne_top (by norm_num) hprobability + have hb := (ENNReal.toReal_le_toReal hp (by finiteness)).mpr hbound + have hc := (ENNReal.toReal_le_toReal (by finiteness) hmultiplier).mpr hcoefficient + rw [ENNReal.toReal_add hepsilon (by finiteness), ENNReal.toReal_mul] at hb + rw [ENNReal.toReal_add (by finiteness) (by norm_num), ENNReal.toReal_mul, + ENNReal.toReal_one] at hc + have hscaled := mul_le_mul_of_nonneg_right hb multiplier.toReal_nonneg + have hcancel := mul_le_mul_of_nonneg_left hc probability.toReal_nonneg + apply (ENNReal.toReal_le_toReal hp (by finiteness)).mp + rw [ENNReal.toReal_mul] + nlinarith + +theorem probEvent_delayedRootFiber_le_mul_common + (run : ProbComp PrivateWitnessSnapshotOutput) + (common : ProbComp (Option PermissivePrivateOrdinalSelection)) + (ordinal q : Nat) (target : Position) (multiplier : ℝ≥0∞) + (hordinal : ordinal < q) (hmultiplier : multiplier ≠ ∞) + (hbudget : ((q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) * multiplier + 1 ≤ + multiplier) + (hgood : + Pr[fun result : PrivateWitnessSnapshotOutput × Digest => + DelayedRootGoodForComparisonAt result.1 ordinal target result.2 | do + let source ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (source, rightRoot)] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + common] * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + Pr[fun source => WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal source ∧ + delayedSnapshotLayerRootPosition? ordinal source = some target | run] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + common] * (multiplier * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) := by + let probability := Pr[fun source => + WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal source ∧ + delayedSnapshotLayerRootPosition? ordinal source = some target | run] + let weight := Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | common] + let epsilon := ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + have hsplit := probEvent_delayedRootFiber_le_goodComparison_add_weightedException + run ordinal target + have hcoefficient : ((ordinal : ℝ≥0∞) * epsilon) * multiplier + 1 ≤ multiplier := by + apply le_trans _ hbudget + gcongr + have hweightFinite : weight ≠ ∞ := ne_top_of_le_ne_top (by norm_num) probEvent_le_one + have hepsilonFinite : epsilon ≠ ∞ := by dsimp [epsilon]; norm_num [digestBits] + have hbound : probability ≤ multiplier * (weight * epsilon) := by + apply le_mul_of_le_add_self_mul probability (weight * epsilon) + ((ordinal : ℝ≥0∞) * epsilon) multiplier probEvent_le_one + (by finiteness) (by finiteness) hmultiplier hcoefficient + exact hsplit.trans (add_le_add hgood le_rfl) + exact hbound.trans_eq (by dsimp [weight, epsilon]; ac_rfl) + +theorem rootBudget_four_thirds {q : Nat} (hq : q ≤ 2 ^ 126) : + ((q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) * (4 / 3 : ℝ≥0∞) + 1 ≤ + (4 / 3 : ℝ≥0∞) := by + calc + _ ≤ (((2 ^ 126 : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) * + (4 / 3 : ℝ≥0∞) + 1 := by gcongr + _ ≤ _ := by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_natCast, + ENNReal.toReal_div, ENNReal.toReal_ofNat, ENNReal.toReal_one] + norm_num [digestBits] + + +theorem probEvent_canonical_delayedRootFiber_le_four_thirds_common + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) (target : Position) + (hordinal : ordinal < q) (hq : q ≤ 2 ^ 126) : + Pr[fun source => WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal source ∧ + delayedSnapshotLayerRootPosition? ordinal source = some target | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret q table] * ((4 / 3) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) := by + apply probEvent_delayedRootFiber_le_mul_common _ _ ordinal q target (4 / 3) + hordinal (by finiteness) (rootBudget_four_thirds hq) + exact probEvent_delayedGoodComparison_le_common_mul_allTargets ordinal adversary parameter + table ftsSecret q target + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootCache.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootCache.lean new file mode 100644 index 00000000..ea94f39e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootCache.lean @@ -0,0 +1,149 @@ +import SphincsSecurity.Proof.OtsProbeEncodingPrehitViewed + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +def RootValuesCached (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (cache : QueryCache HashSpec) : Prop := + ∀ lay tree output, context.positionValue (layerRootPosition lay tree) = some output → + CachedRun cache (fromCache cache) + (treeRoot parameter lay tree (fun leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩))) ∧ + evalWithAnswerFn (fromCache cache) + (treeRoot parameter lay tree (fun leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩))) = + truncateHash output + +theorem resolvedPositionComputation_layerRootPosition (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) : + resolvedPositionComputation parameter table (layerRootPosition lay tree) = + treeRoot parameter lay tree (fun leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) := by + have hheight : 0 < layerHeight lay := by + unfold layerHeight + split <;> norm_num [maxLayerHeight] + simp [resolvedPositionComputation, layerRootPosition, treeRoot, Nat.sub_add_cancel hheight] + +theorem resolvableOtsPosition_layerRootPosition (lay : Layer) (tree : TreeIndex) : + ResolvableOtsPosition (layerRootPosition lay tree) := by + have hheight : 0 < layerHeight lay := by + unfold layerHeight + split <;> norm_num [maxLayerHeight] + simp only [layerRootPosition, ResolvableOtsPosition, Fin.val_zero, zero_add, mul_one, + Nat.sub_add_cancel hheight] + exact Nat.pow_le_pow_right (by omega) (layerHeight_le lay) + +theorem VisibleResolvedComputationsCached.root_value_cached + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {cache : QueryCache HashSpec} + (hclosed : VisibleResolvedComputationsCached parameter table context cache) + (lay : Layer) (tree : TreeIndex) (output : HashOutput) + (hvalue : context.state.values (.position (layerRootPosition lay tree)) = some output) : + CachedRun cache (fromCache cache) + (treeRoot parameter lay tree (fun leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩))) ∧ + evalWithAnswerFn (fromCache cache) + (treeRoot parameter lay tree (fun leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩))) = + truncateHash output := by + simpa only [resolvedPositionComputation_layerRootPosition] using + hclosed (layerRootPosition lay tree) output (resolvableOtsPosition_layerRootPosition lay tree) hvalue + +theorem RootValuesCached.mono + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {initialCache finalCache : QueryCache HashSpec} + (hclosed : RootValuesCached parameter table context initialCache) (hle : initialCache ≤ finalCache) : + RootValuesCached parameter table context finalCache := by + intro lay tree output hvalue + obtain ⟨hcached, houtput⟩ := hclosed lay tree output hvalue + refine ⟨(hcached.changeAnswerFn (agreesWithFn_fromCache initialCache) + (agreesWithFn_fromCache_of_le hle)).mono hle, ?_⟩ + exact (hcached.eval_eq (agreesWithFn_fromCache initialCache) + (agreesWithFn_fromCache_of_le hle)).symm.trans houtput + +theorem RootValuesCached.canonicalize + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {cache : QueryCache HashSpec} + (hclosed : RootValuesCached parameter table context cache) (hconsistent : context.ValuesConsistent) : + RootValuesCached parameter table (canonicalizeMaterializedValues table context) cache := by + intro lay tree output hvalue + rw [canonicalizeMaterializedValues_positionValue table context hconsistent] at hvalue + exact hclosed lay tree output hvalue + +theorem RootValuesCached.of_materialized_or_previous + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {before after : DeferredContext} {initialCache finalCache : QueryCache HashSpec} + (hbefore : RootValuesCached parameter table before initialCache) (hle : initialCache ≤ finalCache) + (hvisible : VisibleResolvedComputationsCached parameter table after finalCache) + (hvalues : ∀ lay tree output, after.positionValue (layerRootPosition lay tree) = some output → + before.positionValue (layerRootPosition lay tree) = some output ∨ + after.state.values (.position (layerRootPosition lay tree)) = some output) : + RootValuesCached parameter table after finalCache := by + intro lay tree output hvalue + rcases hvalues lay tree output hvalue with hold | hnew + · exact hbefore.mono hle lay tree output hold + · exact hvisible.root_value_cached lay tree output hnew + +theorem RootValuesCached.settled_value + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {cache : QueryCache HashSpec} + (hclosed : RootValuesCached parameter table context cache) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (position : Position) + (hroot : IsLayerRoot position) (output : HashOutput) + (hvalue : context.positionValue position = some output) : + Settled parameter (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + ftsSecret cache position ∧ + honestValue (fromCache cache) parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret position = + truncateHash output := by + obtain ⟨lay, tree, rfl⟩ := hroot + obtain ⟨hcached, houtput⟩ := hclosed lay tree output hvalue + constructor + · exact settled_treeRoot_of_cachedRun (ftsSecret := ftsSecret) (agreesWithFn_fromCache cache) lay tree hcached + · have hheight : 0 < layerHeight lay := by + unfold layerHeight + split <;> norm_num [maxLayerHeight] + simpa only [layerRootPosition, honestValue_node, honestNode, treeRoot, + Fin.val_zero, Nat.sub_add_cancel hheight] using houtput + +set_option maxRecDepth 100000 in +theorem RootValuesCached.refinedReserve_of_encoding_candidate + {secretKey : SecretKey} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {cache : QueryCache HashSpec} + (hclosed : RootValuesCached secretKey.parameter table context cache) + (hsecrets : secretKey.otsSecret = fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + {input : HashInput} {candidate : Probe} {target : Position} {output : HashOutput} + (hcandidate : EncodingLayerRootCandidateAt secretKey.parameter input candidate) + (hposition : candidate.coordinate = .position target) + (hvalue : context.positionValue target = some output) : + (4 / 3 : ℝ≥0∞) ≤ otsOpeningRefinedQueryReserve secretKey cache input := by + obtain ⟨rootPosition, hcoordinate, hroot⟩ := encodingLayerRootCandidateAt_isLayerRoot hcandidate + have heq : rootPosition = target := Coordinate.position.inj (hcoordinate.symm.trans hposition) + subst rootPosition + have hsettled := (hclosed.settled_value secretKey.ftsSecret target hroot output hvalue).1 + rw [← hsecrets] at hsettled + obtain ⟨position, index, hat, htree, hleaf, _hnotBottom, rfl⟩ := hcandidate + have heq : layerMessagePosition index position.lay = target := Coordinate.position.inj hposition + subst target + exact otsOpeningRefinedQueryReserve_ge_four_thirds_of_encodingMessageSettled secretKey cache input position hat + ⟨index, htree, hleaf, hsettled⟩ + +set_option maxRecDepth 100000 in +theorem RootValuesCached.encoding_weightedCharge_le_refinedReserve + {secretKey : SecretKey} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {actualCache : QueryCache HashSpec} + (hclosed : RootValuesCached secretKey.parameter table context actualCache) + (hsecrets : secretKey.otsSecret = fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + {input : HashInput} {candidate : Probe} {target : Position} {output : HashOutput} + (hcandidate : EncodingLayerRootCandidateAt secretKey.parameter input candidate) + (hposition : candidate.coordinate = .position target) + (hvalue : context.positionValue target = some output) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (cache : SplitHashCache) (fuel : Nat) : + ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterRootAwarePublicPlan secretKey.parameter input publicState plan).run cache) context fuel + + (materializedCandidateCharge context.state (rootAwareCandidateForPlan? secretKey.parameter input plan) : ℝ≥0∞) * + (4 / 3) ≤ otsOpeningRefinedQueryReserve secretKey actualCache input := + (probingHashQueryAfterRootAwarePublicPlan_weightedCharge_le_four_thirds + secretKey.parameter input publicState plan cache context fuel).trans + (hclosed.refinedReserve_of_encoding_candidate hsecrets hcandidate hposition hvalue) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootCacheTransport.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootCacheTransport.lean new file mode 100644 index 00000000..cee92730 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootCacheTransport.lean @@ -0,0 +1,110 @@ +import SphincsSecurity.Proof.OtsProbeRootCache +import SphincsSecurity.Proof.OtsProbeSelectionHistory + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +set_option maxRecDepth 100000 in +theorem positionValue_old_or_materialized_of_done_direct + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : ResolvedRunResult α) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) + (position : Position) (output : HashOutput) + (hvalue : result.context.positionValue position = some output) : + context.positionValue position = some output ∨ result.context.state.values (.position position) = some output := by + have hdetailed : DirectDetailedResult.done result ∈ support + (runDirectResolvedDetailedFromTable context fuel table computation) := by + rw [← map_erase_runDirectResolvedWitnessFromTable computation context fuel table, support_map] + exact ⟨DirectWitnessResult.done result, hresult, rfl⟩ + cases hfinalState : result.context.state.values (.position position) with + | some finalOutput => + right + simpa only [DeferredContext.positionValue, hfinalState] using hvalue + | none => + left + have hfinalPrivate : result.context.values position = some output := by + simpa only [DeferredContext.positionValue, hfinalState] using hvalue + cases hstate : context.state.values (.position position) with + | some initialOutput => + have hpreserved := valuesLE_of_done_runDirectResolvedDetailedFromTable + computation context fuel table result hdetailed (.position position) initialOutput hstate + rw [hfinalState] at hpreserved + contradiction + | none => + cases hprivate : context.values position with + | none => + have hmissing := auxiliaryPositionValue_none_of_done_runDirectResolvedWitnessFromTable + position computation context fuel table result hstate hprivate hresult hfinalState + rw [hfinalPrivate] at hmissing + contradiction + | some initialOutput => + have hpreserved := privateValuesLE_of_done_runDirectResolvedDetailedFromTable + computation context fuel table result hdetailed position initialOutput hprivate + have heq : initialOutput = output := Option.some.inj (hpreserved.symm.trans hfinalPrivate) + simp only [DeferredContext.positionValue, hstate, hprivate, heq] + +theorem RootValuesCached.of_done_direct + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {initialCache finalCache : QueryCache HashSpec} + (hclosed : RootValuesCached parameter table context initialCache) (hle : initialCache ≤ finalCache) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel : Nat) + (result : ResolvedRunResult α) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) + (hvisible : VisibleResolvedComputationsCached parameter table result.context finalCache) : + RootValuesCached parameter table result.context finalCache := + hclosed.of_materialized_or_previous hle hvisible + (fun lay tree output hvalue => positionValue_old_or_materialized_of_done_direct + computation context fuel table result hresult (layerRootPosition lay tree) output hvalue) + +theorem RootValuesCached.of_done_direct_canonicalized + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {initialCache finalCache : QueryCache HashSpec} + (hclosed : RootValuesCached parameter table context initialCache) (hle : initialCache ≤ finalCache) + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel : Nat) + (result : ResolvedRunResult α) + (hresult : DirectWitnessResult.done result ∈ support + (runDirectResolvedWitnessFromTable context fuel table computation)) + (hvisible : VisibleResolvedComputationsCached parameter table result.context finalCache) + (hconsistent : result.context.ValuesConsistent) : + RootValuesCached parameter table (canonicalizeMaterializedValues table result.context) finalCache := + (hclosed.of_done_direct hle computation fuel result hresult hvisible).canonicalize hconsistent + +theorem RootValuesCached.of_positionValue_eq + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left right : DeferredContext} {cache : QueryCache HashSpec} + (hclosed : RootValuesCached parameter table left cache) + (hvalues : ∀ position, right.positionValue position = left.positionValue position) : + RootValuesCached parameter table right cache := by + intro lay tree output hvalue + exact hclosed lay tree output ((hvalues _).symm.trans hvalue) + +theorem RootValuesCached.materialized_shadow + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {cache : QueryCache HashSpec} + (hclosed : RootValuesCached parameter table context cache) : + RootValuesCached parameter table (materializedDeferredContext context) cache := by + apply hclosed.of_positionValue_eq + intro position + cases hstate : context.state.values (.position position) <;> + cases hprivate : context.values position <;> + simp [materializedDeferredContext, directDeferredContext, directDeferredValues, + materializedDeferredState, DeferredContext.positionValue, hstate, hprivate] + +theorem RootValuesCached.of_canonicalSelectionPreserved + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left : PrivateOrdinalSelection} {right : PermissivePrivateOrdinalSelection} + {cache : QueryCache HashSpec} + (hclosed : RootValuesCached parameter table left.context cache) + (hrelation : CanonicalSelectionPreserved (some left) (some right)) : + RootValuesCached parameter table (directDeferredContext right.state) cache := by + apply hclosed.materialized_shadow.of_positionValue_eq + intro position + simp only [materializedDeferredContext, directDeferredContext, directDeferredValues, + DeferredContext.positionValue] + rw [← hrelation.2.1.values] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootCoupling125.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootCoupling125.lean new file mode 100644 index 00000000..ad269e16 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootCoupling125.lean @@ -0,0 +1,679 @@ +import SphincsSecurity.Proof.OtsProbeDelayedRoot125 + +namespace SphincsSecurity.Concrete.OtsProbeSimulation.Range125 + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option linter.constructorNameAsVariable false + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_indicator_observed_directDelayed_afterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (rightRoot : Digest) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, rootResult.value.1, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary + ⟨rootResult.value.1, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) + (hroot : IsLayerRoot target) : + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining table rootResult.value.2) + (directDelayedSelectedRootIndicator ordinal parameter rootResult.value.1 ftsSecret table + target rightRoot + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state)) q + rootResult.value.2) + SuccessfulObservedIndicatorRel := by + have hpending : rootResult.state.pending = ∅ := + pending_eq_empty_of_mem_runCleanFromTable_maskedPublishedTreeRoot (2 * q) table rootResult + hresult + have htable : rootResult.table = table ∧ StartTableAgrees rootResult.state table := + startTableAgrees_of_mem_runCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table + (startTableAgrees_empty table) rootResult hresult + have hraw := mem_support_runRaw_done_of_mem_runCleanFromTable_some + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table rootResult + hresult + have hpublished : PublishedValues rootResult.state := + preservesPublishedValues_maskedPublishedTreeRoot + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) emptySplitHashCache (2 * q) + rootResult.state rootResult.remaining rootResult.value.1 rootResult.value.2 + publishedValues_empty hraw + have hchainValid : ChainState.ValidFor (fun _ ↦ True) rootResult.state := + preservesChainValid_maskedPublishedTreeRoot_true + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) emptySplitHashCache (2 * q) + rootResult.state rootResult.remaining rootResult.value.1 rootResult.value.2 + (by simp [ChainState.ValidFor, LazyRevealProbe.State.empty]) hraw + let right := directDeferredContext rootResult.state + have hvalid : right.Valid := by + constructor + · intro position output hvalue + simpa [right, directDeferredContext, directDeferredValues] using hvalue + · intro coordinate output _hvalue hhit + simp [right, directDeferredContext, LazyRevealProbe.State.hitAt, + LazyRevealProbe.State.pendingAt, hpending] at hhit + have hprivate : ¬PrivateStructuralHit right := by + rintro ⟨position, output, _hhidden, _hvalue, hhit⟩ + simp [right, directDeferredContext, LazyRevealProbe.State.hitAt, + LazyRevealProbe.State.pendingAt, hpending] at hhit + have hstart : ¬MissingChainStartHit table right := by + rintro ⟨index, _hvalue, hhit⟩ + simp [right, directDeferredContext, LazyRevealProbe.State.hitAt, + LazyRevealProbe.State.pendingAt, hpending] at hhit + have hcard : right.state.pending.card < Fintype.card Digest := by + simp [right, directDeferredContext, hpending] + have hcompletable : DeferredCompletable table right := + deferredCompletable_of_valid_of_no_boundary_hit table right hvalid htable.2 hprivate hstart + hcard + have hclean : ∀ coordinate output, + resolvedCompletionValue table right coordinate = some output → + ¬right.state.hitAt coordinate output := by + intro coordinate output _hvalue + simp [right, directDeferredContext, LazyRevealProbe.State.hitAt, + LazyRevealProbe.State.pendingAt, hpending] + have hbase : FinalizationContextLE table right right := + { view := FinalizationViewLE.refl table right hvalid htable.2 hclean + leftValid := hvalid + rightValid := hvalid + rightCompletable := hcompletable } + let left := canonicalizeMaterializedValues table right + have hcontext : FinalizationContextLE table left right := hbase.canonicalize_left + have hvalues : LazyRevealProbe.ValuesLE left.state right.state := + valuesLE_canonicalizeMaterializedValues_left table right htable.2 hpublished + have hremaining : rootResult.remaining = 2 * q := by + let observed : ObservedCleanRunResult (Digest × SplitHashCache) := + ⟨rootResult.state, rootResult.remaining, rootResult.value, rootResult.table, []⟩ + have hobserved : some observed ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + rw [← map_attachCleanProbeObservations_runCleanFromTable_of_probeFree + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty (2 * q) + table (maskedPublishedTreeRoot_probeFree emptySplitHashCache), support_map] + exact ⟨some rootResult, hresult, rfl⟩ + simpa [observed] using + (remaining_eq_fuel_of_mem_observed_of_probeFree + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty (2 * q) + table observed + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) hobserved) + have hcapacity : 2 * q < Fintype.card Digest := by + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + norm_num [securityBits, digestBits] at hq ⊢ + omega + have hbudget : rootResult.remaining + right.state.pending.card < Fintype.card Digest := by + rw [hremaining] + change 2 * q + rootResult.state.pending.card < Fintype.card Digest + rw [hpending] + simpa using hcapacity + have hrel := relTriple_indicator_observed_directDelayed ordinal parameter rootResult.value.1 + rightRoot ftsSecret table target hroot + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] [] left right q + rootResult.remaining rootResult.value.2 rootResult.value.2 q q hbound hcontext rfl rfl + hvalues hpublished.to_canonicalizedMaterializedValues rfl hchainValid + (canonicalizeMaterializedValues_canonical table right hvalid.valuesConsistent) + (by simp [SnapshotsObservedAt]) (by simp [SnapshotsBefore]) + (by simp [CleanProbeObservationsTrackedBy]) + (by simp [CleanProbeObservationsCoverPending, right, directDeferredContext, hpending]) + (by simp) (by simp) (by simp) + (by simp [PendingCoveredBy, left, canonicalizeMaterializedValues, right, directDeferredContext, + hpending]) le_rfl le_rfl (by omega) hbudget + dsimp [left, right] at hrel + simpa [directDeferredContext] using hrel + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_indicator_observed_eagerDirectDelayed_afterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (rightRoot : Digest) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, rootResult.value.1, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary + ⟨rootResult.value.1, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) + (hroot : IsLayerRoot target) : + RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> + observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining table rootResult.value.2) + (eagerDirectDelayedSelectedRootIndicator ordinal parameter rootResult.value.1 ftsSecret table + target rightRoot + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state)) q + rootResult.value.2) + SuccessfulObservedIndicatorRel := by + have hdelayed := relTriple_indicator_observed_directDelayed_afterRootResult ordinal adversary + parameter table ftsSecret q target rightRoot rootResult hresult hbound hq hroot + have hinvariants := directDeferredContext_invariants_afterRootResult table (2 * q) rootResult + hresult + have hcanonical := valid_completable_canonicalizeMaterializedValues table + (directDeferredContext rootResult.state) hinvariants.1 hinvariants.2.1 + apply relTriple_of_evalDist_eq_right _ hdelayed + exact (evalDist_eagerDirectDelayedSelectedRootIndicator_eq + (α := RetainedRestResult) ordinal parameter rootResult.value.1 ftsSecret table target rightRoot + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state)) q + rootResult.value.2 (by simp) (by simp) (by simp) hcanonical.1 hcanonical.2).symm + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_indicator_afterRootResult_of_eagerProxy + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, rootResult.value.1, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary + ⟨rootResult.value.1, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) + (hroot : IsLayerRoot target) + (hproxy : ∀ rightRoot, + RelTriple + (eagerDirectDelayedSelectedRootIndicator ordinal parameter rootResult.value.1 ftsSecret + table target rightRoot + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state)) q + rootResult.value.2) + (fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> + resolvedEagerObservedRootComparisonAtRoot adversary parameter ftsSecret target + rootResult) + SuccessfulObservedIndicatorRel) : + RelTriple + (successfulObservedRootComparisonIndicator table ordinal target <$> (do + let observed ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining table rootResult.value.2 + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (retainObservedRoot rootResult.value.1 observed, rightRoot))) + (successfulObservedRootComparisonIndicator table ordinal target <$> + resolvedEagerObservedRootComparisonAfterRootResult adversary parameter ftsSecret target + rootResult) + SuccessfulObservedIndicatorRel := by + apply relTriple_indicator_afterRootResult_of_fixedComparisonRoot ordinal adversary parameter + table ftsSecret target rootResult + intro rightRoot + have hleft := relTriple_indicator_observed_eagerDirectDelayed_afterRootResult ordinal adversary + parameter table ftsSecret q target rightRoot rootResult hresult hbound hq hroot + let observed := observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + rootResult.state rootResult.remaining table rootResult.value.2 + have hretain : RelTriple + (fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> observed) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun result ↦ (result, rightRoot)) <$> observed) + SuccessfulObservedIndicatorRel := by + apply relTriple_map + apply relTriple_post_mono (relTriple_refl observed) + intro left right heq hgood + subst right + change successfulObservedRootComparisonIndicator table ordinal target + (retainObservedRoot rootResult.value.1 left, rightRoot) = true at hgood + change successfulObservedRootComparisonIndicator table ordinal target + (left, rightRoot) = true + rw [successfulObservedRootComparisonIndicator_eq_true_iff] at hgood ⊢ + exact successfulDoomedFirstRootGoodForComparisonAt_of_retainObservedRoot table ordinal target + rootResult.value.1 rightRoot left hgood + have hfirst := SphincsSecurity.relTriple_trans_exists hretain hleft + have hsecond := SphincsSecurity.relTriple_trans_exists hfirst (hproxy rightRoot) + apply relTriple_post_mono hsecond + intro observed resolved hrelation + obtain ⟨proxy, hchain, heager⟩ := hrelation + obtain ⟨middle, hretained, hnormalized⟩ := hchain + exact fun htrue ↦ heager (hnormalized (hretained htrue)) + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_observedRootComparison_le_production_mul_of_eagerProxy + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) + (hproxy : ∀ (rootResult : CleanRunResult (Digest × SplitHashCache)), + some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache)) → + ∀ rightRoot, + RelTriple + (eagerDirectDelayedSelectedRootIndicator ordinal parameter rootResult.value.1 ftsSecret + table target rightRoot + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state)) q + rootResult.value.2) + (fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> + resolvedEagerObservedRootComparisonAtRoot adversary parameter ftsSecret target + rootResult) + SuccessfulObservedIndicatorRel) : + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] ≤ + Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target (2 * q) table] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_observedRootComparison_le_production_mul_of_afterRootResult ordinal adversary + parameter table ftsSecret q target hroot hparent hfuel + intro rootResult hresult + exact relTriple_indicator_afterRootResult_of_eagerProxy ordinal adversary parameter table + ftsSecret q target rootResult hresult (hbound rootResult.value.1) hq hroot + (hproxy rootResult hresult) + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem relTriple_eagerProxy_resolvedObservedAtRoot_afterRootResult + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (rightRoot : Digest) + (rootResult : CleanRunResult (Digest × SplitHashCache)) + (hresult : some rootResult ∈ support + (runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hbound : + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, rootResult.value.1, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary + ⟨rootResult.value.1, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) + (hroot : IsLayerRoot target) : + RelTriple + (eagerDirectDelayedSelectedRootIndicator ordinal parameter rootResult.value.1 ftsSecret table + target rightRoot + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state)) q + rootResult.value.2) + (fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> + resolvedEagerObservedRootComparisonAtRoot adversary parameter ftsSecret target rootResult) + SuccessfulObservedIndicatorRel := by + have hinitial := directDeferredContext_invariants_afterRootResult table (2 * q) rootResult hresult + have hrootRaw := mem_support_runRaw_done_of_mem_runCleanFromTable_some + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table rootResult hresult + have hrootPublished : PublishedValues rootResult.state := + preservesPublishedValues_maskedPublishedTreeRoot + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) emptySplitHashCache (2 * q) + rootResult.state rootResult.remaining rootResult.value.1 rootResult.value.2 + publishedValues_empty hrootRaw + have htable : rootResult.table = table ∧ StartTableAgrees rootResult.state table := + startTableAgrees_of_mem_runCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) (2 * q) table + (startTableAgrees_empty table) rootResult hresult + have hrootChainValid : ChainState.ValidFor (fun _ ↦ True) rootResult.state := + preservesChainValid_maskedPublishedTreeRoot_true + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) emptySplitHashCache (2 * q) + rootResult.state rootResult.remaining rootResult.value.1 rootResult.value.2 + (by simp [ChainState.ValidFor, LazyRevealProbe.State.empty]) hrootRaw + have hrootPending : rootResult.state.pending = ∅ := + pending_eq_empty_of_mem_runCleanFromTable_maskedPublishedTreeRoot (2 * q) table rootResult + hresult + have hremaining : rootResult.remaining = 2 * q := by + let observed : ObservedCleanRunResult (Digest × SplitHashCache) := + ⟨rootResult.state, rootResult.remaining, rootResult.value, rootResult.table, []⟩ + have hobserved : some observed ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + rw [← map_attachCleanProbeObservations_runCleanFromTable_of_probeFree + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty (2 * q) + table (maskedPublishedTreeRoot_probeFree emptySplitHashCache), support_map] + exact ⟨some rootResult, hresult, rfl⟩ + simpa [observed] using + (remaining_eq_fuel_of_mem_observed_of_probeFree + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty (2 * q) + table observed (maskedPublishedTreeRoot_probeFree emptySplitHashCache) hobserved) + have hcapacity : 2 * q < Fintype.card Digest := by + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + norm_num [securityBits, digestBits] at hq ⊢ + omega + unfold eagerDirectDelayedSelectedRootIndicator + simp only [List.length_nil, Nat.not_lt_zero, ↓reduceIte] + unfold resolvedEagerObservedRootComparisonAtRoot + simp only [map_eq_bind_pure_comp, bind_assoc] + have hresolve := relTriple_resolveDeferredPositionValue_canonical_afterRootResult table (2 * q) + target rootResult hresult + have hleft := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hresolve + (fun resolved ↦ resolved ∈ support + (resolveDeferredPositionValue target + (canonicalizeMaterializedValues table (directDeferredContext rootResult.state)))) + (fun _ hsupport ↦ hsupport) + have hboth := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + apply relTriple_bind hboth + intro left right hrelation + rcases hrelation with ⟨⟨hresolution, hleftSupport⟩, hrightSupport⟩ + cases left with + | none => + cases right with + | none => exact relTriple_pure_pure (fun hfalse ↦ (Bool.false_ne_true hfalse).elim) + | some right => simp [FinalizationResolutionEq] at hresolution + | some left => + cases right with + | none => simp [FinalizationResolutionEq] at hresolution + | some right => + simp only + let initial := canonicalizeMaterializedValues table + (directDeferredContext rootResult.state) + have hinitialCanonical := valid_completable_canonicalizeMaterializedValues table + (directDeferredContext rootResult.state) hinitial.1 hinitial.2.1 + have hleftValid : left.toDeferredContext.Valid := + hinitialCanonical.1.of_resolveDeferredPositionValue target left hleftSupport + have hleftCompletable : DeferredCompletable table left.toDeferredContext := + hinitialCanonical.2.of_resolveDeferredPositionValue hinitialCanonical.1 target left + hleftSupport + have hleftCanonical := left_resolution_canonical_afterRootResult table (2 * q) target + rootResult hresult left hleftSupport + have hleftState := resolveDeferredPositionValue_state_eq_clearPending target initial left + hleftSupport + have hinitialPublished : PublishedValues initial.state := by + apply PublishedValues.to_canonicalizedMaterializedValues + (context := directDeferredContext rootResult.state) + simpa [directDeferredContext] using hrootPublished + have hleftPublished : PublishedValues left.state := by + rw [hleftState] + intro coordinate hrevealed + have hnonempty := hinitialPublished coordinate (by + simpa [LazyRevealProbe.State.clearPending] using hrevealed) + simpa [LazyRevealProbe.State.clearPending] using hnonempty + have hleftChainValid : ChainState.ValidFor (fun _ ↦ True) left.state := by + intro coordinate hcoordinate + constructor + · intro hsome + by_contra hhidden + rw [hleftCanonical] at hsome + simp [publicMaterializedValues, hhidden] at hsome + · exact ⟨hleftPublished coordinate, fun _ ↦ trivial⟩ + have hleftPrivate : left.toDeferredContext.values target = some left.output := + resolveDeferredPositionValue_installs target initial left hleftSupport + have hleftPending : left.state.pending = ∅ := by + rw [resolveDeferredPositionValue_pending target initial left hleftSupport] + simp [initial, canonicalizeMaterializedValues, directDeferredContext, hrootPending, + LazyRevealProbe.State.pendingAway] + have hshadow := relTriple_directDelayed_observed_shadow ordinal parameter + rootResult.value.1 rightRoot ftsSecret table target left.output hroot + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + left.toDeferredContext q (2 * q) q q rootResult.value.2 hbound hleftValid + hleftCompletable hleftPublished hleftCanonical hleftChainValid hleftPrivate + (by simp [SnapshotsObservedAt]) (by simp [SnapshotsBefore]) + (by simp [CleanProbeObservationsTrackedBy]) + (by simp [CleanProbeObservationsCoverPending, hleftPending]) (by simp) + (by simp [PendingCoveredBy, hleftPending]) (by simp) le_rfl le_rfl (by omega) + (by simpa [hleftPending] using hcapacity) + have hcanonicalized := canonicalized_resolutions_afterRootResult table target + rootResult.state left right hleftSupport hrightSupport hresolution + let leftCanonical := canonicalizeMaterializedValues table left.toDeferredContext + let rightCanonical := canonicalizeMaterializedValues table right.toDeferredContext + have hleftCanonicalEq : leftCanonical = left.toDeferredContext := by + exact canonicalizeMaterializedValues_eq_of_canonical table left.toDeferredContext + hleftCanonical + have hrightState := resolveDeferredPositionValue_state_eq_clearPending target + (directDeferredContext rootResult.state) right hrightSupport + have hrightStarts : StartTableAgrees right.state table := by + rw [hrightState] + intro index output hvalue + apply htable.2 index output + simpa [directDeferredContext, LazyRevealProbe.State.clearPending] using hvalue + have hrightChainValid : ChainState.ValidFor (fun _ ↦ True) right.state := by + rw [hrightState] + intro coordinate hcoordinate + simpa [directDeferredContext, LazyRevealProbe.State.clearPending] using + hrootChainValid coordinate hcoordinate + have hrightMaterialized : materializedDeferredState rightCanonical = + materializedDeferredState right.toDeferredContext := by + exact ScratchLocal.materializedDeferredState_canonicalize_eq table + right.toDeferredContext hrightStarts hrightChainValid + hresolution.2.2.2.1.valuesConsistent + have hstateEq : CompletionSafeStateEq table + (materializedDeferredState left.toDeferredContext) + (materializedDeferredState right.toDeferredContext) := by + have hsafe := hcanonicalized.2.2.2 + rw [canonicalizeMaterializedValues_eq_of_canonical table left.toDeferredContext + hleftCanonical, + ScratchLocal.materializedDeferredState_canonicalize_eq table + right.toDeferredContext hrightStarts hrightChainValid + hresolution.2.2.2.1.valuesConsistent] at hsafe + exact hsafe + let leftObserved := observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState left.toDeferredContext) (2 * q) table rootResult.value.2 + let rightObserved := observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState right.toDeferredContext) (2 * q) table rootResult.value.2 + have hstateBridge : RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> leftObserved) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> rightObserved) + (EqRel Bool) := by + apply relTriple_indicator_observedMaterializedBoundary_completionSafeEq ordinal + parameter rootResult.value.1 rightRoot ftsSecret table target + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState left.toDeferredContext) + (materializedDeferredState right.toDeferredContext) (2 * q) rootResult.value.2 + hstateEq + intro index output hvalue + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + apply hresolution.2.1.leftStarts ⟨lay, tree, leafIdx, chainIdx⟩ output + simpa [materializedDeferredState, OtsSecretIndex.coordinate] using hvalue + have hstateImp : RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> leftObserved) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> rightObserved) + SuccessfulObservedIndicatorRel := by + apply relTriple_post_mono hstateBridge + intro leftValue rightValue heq htrue + rw [← heq] + exact htrue + change RelTriple _ + (fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> + observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState right.toDeferredContext) rootResult.remaining + rootResult.table + (replaceHiddenRootCache target right.output rootResult.value.2)) + SuccessfulObservedIndicatorRel + rw [hremaining, htable.1] + have hfirst := SphincsSecurity.relTriple_trans_exists hshadow hstateImp + let installedObserved := observedMaterializedBoundary parameter rootResult.value.1 + ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] + (materializedDeferredState right.toDeferredContext) (2 * q) table + (replaceHiddenRootCache target right.output rootResult.value.2) + have hordinary : ordinaryQueryCache rootResult.value.2 = + ordinaryQueryCache + (replaceHiddenRootCache target right.output rootResult.value.2) := by + simpa [replaceHiddenRootCache] using + (ordinaryQueryCache_update_hidden rootResult.value.2 (.position target) right.output).symm + have hcacheBase := relTriple_observedMaterializedBoundary_ordinaryCache parameter + rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) [] [] + (materializedDeferredState right.toDeferredContext) (2 * q) table rootResult.value.2 + (replaceHiddenRootCache target right.output rootResult.value.2) hordinary + have hcacheBridge : RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> rightObserved) + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> installedObserved) + SuccessfulObservedIndicatorRel := by + apply relTriple_map + apply relTriple_post_mono hcacheBase + intro leftResult rightResult hrelation hleftGood + cases leftResult with + | none => + cases rightResult with + | none => exact hleftGood + | some rightResult => simp [ObservedOrdinaryCacheRel] at hrelation + | some leftResult => + cases rightResult with + | none => simp [ObservedOrdinaryCacheRel] at hrelation + | some rightResult => + rcases hrelation with + ⟨hstate, hremaining, htable, hvalue, _hcache, suffix, + hleftObservations, hrightObservations⟩ + change successfulObservedRootComparisonIndicator table ordinal target + (some leftResult, rightRoot) = true at hleftGood + rw [successfulObservedRootComparisonIndicator_eq_true_iff] at hleftGood + change successfulObservedRootComparisonIndicator table ordinal target + (some rightResult, rightRoot) = true + rw [successfulObservedRootComparisonIndicator_eq_true_iff] + have hobservations : leftResult.observations = rightResult.observations := by + rw [hleftObservations, hrightObservations] + rcases hleftGood with + ⟨⟨⟨hfinish, hfirstRoot⟩, hposition⟩, hcomparison⟩ + have hrightFinish := exists_finishObservedCleanRunFromTable_of_state_table_eq + leftResult rightResult hstate htable hfinish + have hrightPosition : + observedFirstLayerRootPosition? ordinal (some rightResult) = some target := by + rw [← observedFirstLayerRootPosition?_eq_of_observations_eq ordinal + leftResult rightResult hobservations] + exact hposition + obtain ⟨_selected, _hselected, hfirst, _hroot⟩ := hfirstRoot + have hrightFirst := firstExistingHiddenHitAt_of_observations_eq leftResult + rightResult ordinal hobservations hfirst + have hrightFirstRoot : + ObservedCleanRunOption.FirstExistingHiddenRootHitAt ordinal + (some rightResult) := + firstExistingHiddenRootHitAt_of_first_of_position rightResult ordinal target + hrightFirst hrightPosition + have hrightComparison : CandidatesAvoidRoot target rightRoot + (observedPrefixProbes ordinal (some rightResult)) := by + rw [← observedPrefixProbes_eq_of_observations_eq ordinal leftResult + rightResult hobservations] + exact hcomparison + exact ⟨⟨⟨hrightFinish, hrightFirstRoot⟩, + hrightPosition⟩, hrightComparison⟩ + have hsecond := SphincsSecurity.relTriple_trans_exists hfirst hcacheBridge + have hretain : RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> installedObserved) + (fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> + installedObserved) + (EqRel Bool) := by + apply relTriple_map + apply relTriple_post_mono (relTriple_refl installedObserved) + intro leftResult rightResult heq + subst rightResult + apply Bool.eq_iff_iff.mpr + simp only [Function.comp_apply] + unfold fixedComparisonRootIndicator + rw [successfulObservedRootComparisonIndicator_eq_true_iff, + successfulObservedRootComparisonIndicator_eq_true_iff] + change + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt table ordinal + target rightRoot leftResult ↔ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt table ordinal + target rightRoot (retainObservedRoot rootResult.value.1 leftResult) + exact (successfulDoomedFirstRootGoodForComparisonAt_retainObservedRoot_iff table + ordinal target rootResult.value.1 rightRoot leftResult).symm + have hretainImp : RelTriple + ((successfulObservedRootComparisonIndicator table ordinal target ∘ + fun observed ↦ (observed, rightRoot)) <$> installedObserved) + (fixedComparisonRootIndicator table ordinal target rootResult.value.1 rightRoot <$> + installedObserved) + SuccessfulObservedIndicatorRel := by + apply relTriple_post_mono hretain + intro leftValue rightValue heq htrue + rwa [← heq] + have hfinal := SphincsSecurity.relTriple_trans_exists hsecond hretainImp + apply relTriple_post_mono hfinal + intro source retained hrelation + obtain ⟨installed, htoInstalled, hretainResult⟩ := hrelation + obtain ⟨rightState, htoRightState, hcacheResult⟩ := htoInstalled + obtain ⟨leftState, hshadowResult, hstateResult⟩ := htoRightState + exact fun htrue ↦ + hretainResult (hcacheResult (hstateResult (hshadowResult htrue))) + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_observedRootComparison_le_production_mul + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] ≤ + Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target (2 * q) table] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_observedRootComparison_le_production_mul_of_eagerProxy ordinal adversary + parameter table ftsSecret q target hroot hparent hfuel hbound hq + intro rootResult hresult rightRoot + exact relTriple_eagerProxy_resolvedObservedAtRoot_afterRootResult ordinal adversary parameter + table ftsSecret q target rightRoot rootResult hresult (hbound rootResult.value.1) hq hroot + +end SphincsSecurity.Concrete.OtsProbeSimulation.Range125 diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootMaterializationChronological.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootMaterializationChronological.lean new file mode 100644 index 00000000..19464950 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootMaterializationChronological.lean @@ -0,0 +1,114 @@ +import SphincsSecurity.Proof.OtsProbeRootMaterializationSigner + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem rootMaterializationPreserving_chronologicalQuery + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : (OracleWorld + SigningSpec).Domain) : + RootMaterializationPreserving (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret input) := by + cases input with + | inl query => + cases query with + | inl n => exact rootMaterializationPreserving_splitUniformImpl n + | inr input => exact rootMaterializationPreserving_probingHashQuery parameter input + | inr message => exact rootMaterializationPreserving_chronologicalSign parameter root ftsSecret message + +theorem rootMaterializationPreserving_chronologicalRun + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + RootMaterializationPreserving (simulateQ (maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret) computation) := + rootMaterializationPreserving_simulateQ _ (rootMaterializationPreserving_chronologicalQuery parameter root ftsSecret) computation + +theorem rootMaterializationPreserving_maskedPublishedTreeRoot : + RootMaterializationPreserving maskedPublishedTreeRoot := by + rw [maskedPublishedTreeRoot_eq] + apply (rootMaterializationPreserving_maskedTreeRoot topLayer rootTree).bind + intro value + exact (rootMaterializationPreserving_publishCoordinate _).bind (fun _ => .pure value) + +theorem rootMaterializationPreserving_chronologicalRetainedGame + (adversary : Adversary) (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + RootMaterializationPreserving (maskedChronologicalRetainedGameAfterFtsSecrets adversary parameter ftsSecret) := by + unfold maskedChronologicalRetainedGameAfterFtsSecrets + have hprefix : RootMaterializationPreserving (maskedChronologicalRetainedPrefixAfterFtsSecrets adversary parameter ftsSecret) := + rootMaterializationPreserving_maskedPublishedTreeRoot.bind (fun root => + (rootMaterializationPreserving_chronologicalRun parameter root ftsSecret _).bind (fun _ => .pure _)) + apply hprefix.bind + rintro ⟨root, forgery, log⟩ + apply (rootMaterializationPreserving_simulateQ (probingRomImpl parameter) ?_ _).bind + · intro _ + exact .pure _ + · intro input + cases input with + | inl n => exact rootMaterializationPreserving_splitUniformImpl n + | inr input => exact rootMaterializationPreserving_probingHashQuery parameter input + +theorem layerRootsMaterialized_ensuredInitialContext (targets : Finset Position) : + LayerRootsMaterialized (ensuredInitialContext targets) := by + intro target _ hknown + exact False.elim (hknown rfl) + +attribute [local irreducible] maskedChronologicalRetainedGameAfterFtsSecrets maskedPublishedTreeRoot + +theorem layerRootsMaterialized_chronologicalRetainedGame_from_initial + (adversary : Adversary) (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (targets : Finset Position) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (RetainedGameResult × SplitHashCache)) + (hresult : some result ∈ support (runResolvedFromTable (ensuredInitialContext targets) fuel table + ((maskedChronologicalRetainedGameAfterFtsSecrets adversary parameter ftsSecret).run cache))) : + LayerRootsMaterialized result.context := by + have hpreserves := rootMaterializationPreserving_chronologicalRetainedGame adversary parameter ftsSecret + exact hpreserves (ensuredInitialContext targets) fuel table cache result + (layerRootsMaterialized_ensuredInitialContext targets) (ensuredInitialContext_computed targets) hresult + +theorem layerRootsMaterialized_runNativeQueryTrace + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (trace : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) + (hmat : LayerRootsMaterialized context) (hclosed : DeferredComputationsClosed context) + (htrace : trace ∈ support (runNativeQueryTrace parameter root ftsSecret computation context fuel table cache)) : + (∀ result, trace.1 = some result → LayerRootsMaterialized result.context) ∧ + ∀ selection ∈ trace.2, LayerRootsMaterialized selection.context := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache trace with + | pure value => + simp only [runNativeQueryTrace, OracleComp.construct_pure] at htrace + split_ifs at htrace <;> simp only [mem_support_pure_iff] at htrace <;> subst trace + · exact ⟨fun result heq => Option.some.inj heq ▸ hmat, fun _ hmem => False.elim (List.not_mem_nil hmem)⟩ + · simp + | query_bind input next ih => + rw [runNativeQueryTrace_query_bind] at htrace + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete, mem_support_bind_iff] at htrace + obtain ⟨middle, hmiddle, htail⟩ := htrace + cases middle with + | none => + simp only [pure_bind, mem_support_pure_iff] at htail + subst trace + exact ⟨by simp, by simpa using hmat⟩ + | some middle => + simp only [mem_support_bind_iff] at htail + obtain ⟨tail, htail, hreturn⟩ := htail + simp only [mem_support_pure_iff] at hreturn + subst trace + have hmiddleMat := rootMaterializationPreserving_chronologicalQuery parameter root ftsSecret input + context fuel table cache middle hmat hclosed hmiddle + have hmiddleClosed := hclosed.of_mem_runResolved _ context fuel table middle hmiddle + have htailMat := ih middle.value.1 middle.context middle.remaining middle.table middle.value.2 tail + hmiddleMat hmiddleClosed htail + refine ⟨htailMat.1, ?_⟩ + intro selection hmem + rcases List.mem_cons.mp hmem with rfl | hmem + · exact hmat + · exact htailMat.2 selection hmem + · rw [if_neg hcomplete] at htrace + simp only [mem_support_pure_iff] at htrace + subst trace + simp + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootMaterializationExecution.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootMaterializationExecution.lean new file mode 100644 index 00000000..95258dc2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootMaterializationExecution.lean @@ -0,0 +1,187 @@ +import SphincsSecurity.Proof.OtsProbeMaterializedRootCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +def RootMaterializationPreserving + (computation : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ context fuel table cache result, + LayerRootsMaterialized context → DeferredComputationsClosed context → + some result ∈ support (runResolvedFromTable context fuel table (computation.run cache)) → + LayerRootsMaterialized result.context + +theorem RootMaterializationPreserving.pure (value : α) : + RootMaterializationPreserving (pure value) := by + intro context fuel table cache result hmat _ hresult + simp [runResolvedFromTable] at hresult + subst result + exact hmat + +theorem RootMaterializationPreserving.bind + {left : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α} + {next : α → StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hleft : RootMaterializationPreserving left) (hnext : ∀ value, RootMaterializationPreserving (next value)) : + RootMaterializationPreserving (left >>= next) := by + intro context fuel table cache result hmat hclosed hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨middle, hmiddle, hrest⟩ := hresult + cases middle with + | none => simp at hrest + | some middle => + exact hnext middle.value.1 middle.context middle.remaining middle.table middle.value.2 result + (hleft context fuel table cache middle hmat hclosed hmiddle) + (hclosed.of_mem_runResolved _ context fuel table middle hmiddle) hrest + +theorem RootMaterializationPreserving.of_administrative + {computation : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α} {value : α} + (h : ResolvedAdministrative computation value) : RootMaterializationPreserving computation := by + intro context fuel table cache result hmat _ hresult + obtain ⟨finalContext, hrun, _, hstate, hvalues⟩ := h context cache fuel table + rw [hrun] at hresult + simp only [mem_support_pure_iff, Option.some.injEq] at hresult + subst result + exact hmat.of_values_eq hstate hvalues + +theorem rootMaterializationPreserving_ensureCoordinate (coordinate : Coordinate) : + RootMaterializationPreserving (ensureCoordinate coordinate) := + .of_administrative (resolvedAdministrative_ensureCoordinate coordinate) + +theorem rootMaterializationPreserving_publishCoordinate (coordinate : Coordinate) : + RootMaterializationPreserving (publishCoordinate coordinate) := + .of_administrative (resolvedAdministrative_publishCoordinate coordinate) + +theorem rootMaterializationPreserving_modify (f : SplitHashCache → SplitHashCache) : + RootMaterializationPreserving (modify f) := by + intro context fuel table cache result hmat _ hresult + simp [StateT.run_modify, runResolvedFromTable] at hresult + subst result + exact hmat + +theorem rootMaterializationPreserving_splitHashQuery (input : SplitHashKey) : + RootMaterializationPreserving (splitHashQuery input) := by + intro context fuel table cache result hmat _ hresult + rw [splitHashQuery_run_eq] at hresult + cases hlookup : cache input with + | some output => + simp [hlookup, runResolvedFromTable] at hresult + subst result + exact hmat + | none => + simp only [hlookup] at hresult + rw [LazyRevealProbe.hashOutputQuery, runResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _, hreturn⟩ := hresult + simp [runResolvedFromTable] at hreturn + subst result + exact hmat + +theorem rootMaterializationPreserving_peekCoordinate (coordinate : Coordinate) : + RootMaterializationPreserving (peekCoordinate coordinate) := by + intro context fuel table cache result hmat _ hresult + rw [runResolvedFromTable_peekCoordinate] at hresult + simp only [mem_support_pure_iff, Option.some.injEq] at hresult + subst result + exact hmat + +theorem rootMaterializationPreserving_probe (candidate : Probe) : + RootMaterializationPreserving (probe candidate) := by + intro context fuel table cache result hmat _ hresult + unfold probe at hresult + rw [StateT.run_liftM, LazyRevealProbe.probeQuery, runResolvedFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + split_ifs at hresult <;> simp [runResolvedFromTable] at hresult <;> subst result <;> exact hmat + +theorem LayerRootsMaterialized.materialize_chainStart + {context : DeferredContext} (hmat : LayerRootsMaterialized context) + (table : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) (result : DeferredResolution) + (hresult : resolveDeferredChainStart table index context = some result) : + LayerRootsMaterialized (materializeResolvedChainStart context index result) := by + intro target hroot haux + change result.values target ≠ none at haux + rw [resolveDeferredChainStart_deferred_values_eq table index context result hresult] at haux + have hbefore := hmat target hroot haux + simpa [materializeResolvedChainStart, LazyRevealProbe.State.materialize, OtsSecretIndex.coordinate] using hbefore + +theorem rootMaterializationPreserving_revealCoordinateOutput_bounded (coordinate : Coordinate) + (hbounded : ∀ position, coordinate = .position position → LayerBoundedPosition position) : + RootMaterializationPreserving (revealCoordinateOutput coordinate) := by + intro context fuel table cache result hmat _ hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + rw [runResolvedFromTable_revealCoordinateOutput] at hresult + simp only [pure_bind] at hresult + cases hresolved : resolveDeferredChainStart table ⟨lay, tree, leafIdx, chainIdx⟩ context with + | none => simp [hresolved] at hresult + | some resolved => + simp only [hresolved, mem_support_pure_iff, Option.some.injEq] at hresult + subst result + exact hmat.materialize_chainStart table ⟨lay, tree, leafIdx, chainIdx⟩ resolved hresolved + | position position => + rw [runResolvedFromTable_revealCoordinateOutput, mem_support_bind_iff] at hresult + obtain ⟨resolved, hresolved, hreturn⟩ := hresult + cases resolved with + | none => simp at hreturn + | some resolved => + simp only [mem_support_pure_iff, Option.some.injEq] at hreturn + subst result + exact hmat.of_resolveReveal_bounded table position resolved (hbounded position rfl) hresolved + +theorem rootMaterializationPreserving_revealCoordinate_bounded (coordinate : Coordinate) + (hbounded : ∀ position, coordinate = .position position → LayerBoundedPosition position) : + RootMaterializationPreserving (revealCoordinate coordinate) := + (rootMaterializationPreserving_revealCoordinateOutput_bounded coordinate hbounded).bind (fun _ => .pure _) + +theorem rootMaterializationPreserving_revealPosition (position : Position) (hbounded : LayerBoundedPosition position) : + RootMaterializationPreserving (revealPosition position) := + rootMaterializationPreserving_revealCoordinate_bounded (.position position) + (fun _ heq => Coordinate.position.inj heq ▸ hbounded) + +theorem rootMaterializationPreserving_sequenceFin {n : Nat} + (computation : Fin n → StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ i, RootMaterializationPreserving (computation i)) : + RootMaterializationPreserving (sequenceFin computation) := by + induction n with + | zero => simpa [sequenceFin] using (RootMaterializationPreserving.pure (α := Fin 0 → α) Fin.elim0) + | succ n ih => + rw [sequenceFin] + exact (hcomponent 0).bind (fun _ => (ih _ (fun i => hcomponent i.succ)).bind (fun _ => .pure _)) + +theorem rootMaterializationPreserving_splitUniformImpl (n : Nat) : + RootMaterializationPreserving (splitUniformImpl n) := by + intro context fuel table cache result hmat _ hresult + change some result ∈ support (runResolvedFromTable context fuel table + (LazyRevealProbe.uniformQuery n >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.uniformQuery, runResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _, hreturn⟩ := hresult + simp [runResolvedFromTable] at hreturn + subst result + exact hmat + +theorem rootMaterializationPreserving_simulateQ {spec : OracleSpec ι} + (impl : QueryImpl spec (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (himpl : ∀ input, RootMaterializationPreserving (impl input)) (computation : OracleComp spec α) : + RootMaterializationPreserving (simulateQ impl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => exact .pure value + | query_bind query next ih => + rw [simulateQ_bind, simulateQ_spec_query] + exact (himpl query).bind ih + +theorem rootMaterializationPreserving_ordinaryHash (computation : OracleComp HashSpec α) : + RootMaterializationPreserving (simulateQ ordinaryHashImpl computation) := + rootMaterializationPreserving_simulateQ _ (fun input => rootMaterializationPreserving_splitHashQuery (.ordinary input)) computation + +theorem rootMaterializationPreserving_ordinaryRom (computation : OracleComp OracleWorld α) : + RootMaterializationPreserving (simulateQ ordinaryRomImpl computation) := by + apply rootMaterializationPreserving_simulateQ _ _ computation + intro input + cases input with + | inl n => exact rootMaterializationPreserving_splitUniformImpl n + | inr input => exact rootMaterializationPreserving_splitHashQuery (.ordinary input) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootMaterializationHash.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootMaterializationHash.lean new file mode 100644 index 00000000..36317581 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootMaterializationHash.lean @@ -0,0 +1,108 @@ +import SphincsSecurity.Proof.OtsProbeRootMaterializationExecution + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem LayerRootsMaterialized.of_mem_revealCoordinateOutput_peek + (parameter : PublicParameter) (coordinate : Coordinate) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (HashOutput × SplitHashCache)) + (hmat : LayerRootsMaterialized context) (hclosed : DeferredComputationsClosed context) + (hpeek : purePeekTableInput parameter context.state coordinate ≠ none) + (hresult : some result ∈ support (runResolvedFromTable context fuel table ((revealCoordinateOutput coordinate).run cache))) : + LayerRootsMaterialized result.context := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => exact False.elim (hpeek rfl) + | position position => + rw [runResolvedFromTable_revealCoordinateOutput, mem_support_bind_iff] at hresult + obtain ⟨resolved, hresolved, hreturn⟩ := hresult + cases resolved with + | none => simp at hreturn + | some resolved => + simp only [mem_support_pure_iff, Option.some.injEq] at hreturn + subst result + exact hmat.of_resolveReveal_peek parameter table position context resolved hclosed hpeek hresolved + +theorem rootMaterializationPreserving_resolveKnownInput + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) : + RootMaterializationPreserving (resolveKnownInput parameter coordinate input) := by + intro context fuel table cache result hmat hclosed hresult + rw [runResolvedFromTable_resolveKnownInput_eq_public] at hresult + unfold resolvePublicKnownInput at hresult + cases hpeek : purePeekTableInput parameter context.state coordinate with + | none => + simp only [hpeek] at hresult + exact rootMaterializationPreserving_splitHashQuery (.ordinary input) context fuel table cache result hmat hclosed hresult + | some knownInput => + simp only [hpeek] at hresult + split_ifs at hresult with hmatch + · rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨middle, hmiddle, hrest⟩ := hresult + cases middle with + | none => simp at hrest + | some middle => + have hmiddleMat := hmat.of_mem_revealCoordinateOutput_peek parameter coordinate context fuel table cache middle hclosed + (by rw [hpeek]; simp) hmiddle + have htail := (rootMaterializationPreserving_publishCoordinate coordinate).bind (fun _ => + (rootMaterializationPreserving_modify (fun cache => Function.update cache (.ordinary input) (some middle.value.1))).bind + (fun _ => RootMaterializationPreserving.pure middle.value.1)) + exact htail middle.context middle.remaining middle.table middle.value.2 result hmiddleMat + (hclosed.of_mem_runResolved _ context fuel table middle hmiddle) hrest + · exact rootMaterializationPreserving_splitHashQuery (.ordinary input) context fuel table cache result hmat hclosed hresult + +theorem rootMaterializationPreserving_probeFirstMissingInputCoordinate + (input : HashInput) (slot : Nat) (coordinates : List Coordinate) : + RootMaterializationPreserving (probeFirstMissingInputCoordinate input slot coordinates) := by + induction coordinates generalizing slot with + | nil => exact .pure _ + | cons coordinate remaining ih => + unfold probeFirstMissingInputCoordinate + apply (rootMaterializationPreserving_peekCoordinate coordinate).bind + intro output + cases output with + | none => exact rootMaterializationPreserving_probe _ + | some output => exact ih (slot + 1) + +theorem rootMaterializationPreserving_prepareLeafInputProbe + (input : HashInput) (candidate : Probe) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + RootMaterializationPreserving (prepareLeafInputProbe input candidate lay tree leafIdx) := by + unfold prepareLeafInputProbe + apply (rootMaterializationPreserving_peekCoordinate candidate.coordinate).bind + intro output + cases output with + | none => exact rootMaterializationPreserving_probe candidate + | some output => exact rootMaterializationPreserving_probeFirstMissingInputCoordinate input 0 _ + +theorem rootMaterializationPreserving_probingHashQuery (parameter : PublicParameter) (input : HashInput) : + RootMaterializationPreserving (probingHashQuery parameter input) := by + unfold probingHashQuery + cases decodeProbe? parameter input with + | some candidate => + cases decodePosition? parameter input with + | none => + exact (rootMaterializationPreserving_probe candidate).bind + (fun _ => rootMaterializationPreserving_resolveKnownInput parameter candidate.outputCoordinate input) + | some position => + cases position with + | leaf lay tree leafIdx => + exact (rootMaterializationPreserving_prepareLeafInputProbe input candidate lay tree leafIdx).bind + (fun _ => rootMaterializationPreserving_resolveKnownInput parameter candidate.outputCoordinate input) + | chain | node | ftsLeaf | ftsNode | ftsRoots => + exact (rootMaterializationPreserving_probe candidate).bind + (fun _ => rootMaterializationPreserving_resolveKnownInput parameter candidate.outputCoordinate input) + | none => + cases decodePosition? parameter input with + | none => exact rootMaterializationPreserving_splitHashQuery _ + | some position => + cases position with + | chain | leaf => exact rootMaterializationPreserving_resolveKnownInput parameter _ input + | node lay tree level nodeIdx => + exact (rootMaterializationPreserving_probeFirstMissingInputCoordinate input 0 _).bind + (fun _ => rootMaterializationPreserving_resolveKnownInput parameter _ input) + | ftsLeaf | ftsNode | ftsRoots => exact rootMaterializationPreserving_splitHashQuery _ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootMaterializationSigner.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootMaterializationSigner.lean new file mode 100644 index 00000000..e5678d4f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootMaterializationSigner.lean @@ -0,0 +1,180 @@ +import SphincsSecurity.Proof.OtsProbeRootMaterializationHash + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem rootMaterializationPreserving_maskedTreeNode + (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) (hbounded : level ≤ layerHeight lay) : + RootMaterializationPreserving (maskedTreeNode lay tree level nodeIdx) := by + unfold maskedTreeNode + apply (RootMaterializationPreserving.of_administrative (resolvedAdministrative_ensureTreeNode lay tree level nodeIdx)).bind + intro _ + cases level with + | zero => exact rootMaterializationPreserving_revealPosition _ trivial + | succ current => + rw [Nat.add_one] + simp only + split_ifs + · exact rootMaterializationPreserving_revealPosition _ hbounded + · exact .pure _ + +theorem rootMaterializationPreserving_maskedTreeRoot (lay : Layer) (tree : TreeIndex) : + RootMaterializationPreserving (maskedTreeRoot lay tree) := + rootMaterializationPreserving_maskedTreeNode lay tree (layerHeight lay) 0 le_rfl + +theorem layerBoundedPosition_of_chainValueCoordinate + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) + (position : Position) (hposition : chainValueCoordinate lay tree leafIdx chainIdx digit = .position position) : + LayerBoundedPosition position := by + unfold chainValueCoordinate at hposition + split_ifs at hposition + have heq := Coordinate.position.inj hposition + subst position + trivial + +theorem rootMaterializationPreserving_revealPublishedCoordinate_bounded + (coordinate : Coordinate) (hbounded : ∀ position, coordinate = .position position → LayerBoundedPosition position) : + RootMaterializationPreserving (revealPublishedCoordinate coordinate) := + (rootMaterializationPreserving_revealCoordinate_bounded coordinate hbounded).bind fun value => + (rootMaterializationPreserving_publishCoordinate coordinate).bind fun _ => .pure value + +theorem rootMaterializationPreserving_layerValues + (reveal : Coordinate → StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) Digest) + (hreveal : ∀ coordinate, (∀ position, coordinate = .position position → LayerBoundedPosition position) → + RootMaterializationPreserving (reveal coordinate)) + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + RootMaterializationPreserving (do + let values ← sequenceFin fun chainIdx => reveal + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx (encoding chainIdx)) + let path ← sequenceFin fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + match level.val with + | 0 => reveal (.position (.leaf lay (treeIndexAt index lay) (leafOfNat (Nat.xor (leafIndexAt index lay).val 1)))) + | current + 1 => + if hcurrent : current < maxLayerHeight then + reveal (.position (.node lay (treeIndexAt index lay) ⟨current, hcurrent⟩ + (leafOfNat (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0 + else pure 0 + pure (values, path)) := by + apply (rootMaterializationPreserving_sequenceFin _ (fun chainIdx => hreveal _ + (layerBoundedPosition_of_chainValueCoordinate lay _ _ chainIdx (encoding chainIdx)))).bind + intro values + apply (rootMaterializationPreserving_sequenceFin _ (fun level => ?_)).bind + · intro path + exact .pure (values, path) + · by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + cases hzero : level.val with + | zero => + apply hreveal + intro position hposition + cases Coordinate.position.inj hposition + trivial + | succ current => + rw [Nat.add_one] + simp only + split_ifs + · apply hreveal + intro position hposition + cases Coordinate.position.inj hposition + change current + 1 ≤ layerHeight lay + omega + · exact .pure _ + · rw [if_neg hlevel] + exact .pure _ + +theorem rootMaterializationPreserving_revealPrivateLayerValues + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + RootMaterializationPreserving (revealPrivateLayerValues index lay encoding) := + rootMaterializationPreserving_layerValues revealCoordinate rootMaterializationPreserving_revealCoordinate_bounded index lay encoding + +theorem rootMaterializationPreserving_revealLayerValues + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + RootMaterializationPreserving (revealLayerValues index lay encoding) := + rootMaterializationPreserving_layerValues revealPublishedCoordinate rootMaterializationPreserving_revealPublishedCoordinate_bounded index lay encoding + +theorem rootMaterializationPreserving_maskedLayerMessage (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + RootMaterializationPreserving (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + split_ifs + · exact rootMaterializationPreserving_maskedTreeRoot _ _ + · exact rootMaterializationPreserving_ordinaryHash _ + +theorem rootMaterializationPreserving_maskedOtsSignFrom (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + ∀ attempts counter, RootMaterializationPreserving (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, counter => .pure none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + apply (rootMaterializationPreserving_ordinaryHash _).bind + intro encoded + cases encoded with + | none => exact rootMaterializationPreserving_maskedOtsSignFrom parameter lay tree leafIdx message attempts (counter + 1) + | some encoding => + exact (rootMaterializationPreserving_sequenceFin _ (fun chainIdx => + RootMaterializationPreserving.of_administrative (resolvedAdministrative_ensureChainPrefix lay tree leafIdx chainIdx (encoding chainIdx)))).bind + (fun _ => .pure _) + +theorem rootMaterializationPreserving_maskedSignLayer (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + RootMaterializationPreserving (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + apply (rootMaterializationPreserving_maskedLayerMessage parameter ftsSecret index lay).bind + intro message + apply (rootMaterializationPreserving_maskedOtsSignFrom parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message encodingAttemptLimit 0).bind + intro selected + cases selected with + | none => exact .pure none + | some selected => + exact (RootMaterializationPreserving.of_administrative (resolvedAdministrative_ensureTreePath lay (treeIndexAt index lay) (leafIndexAt index lay))).bind + (fun _ => .pure (some selected)) + +theorem rootMaterializationPreserving_chronologicalSignLayer (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + RootMaterializationPreserving (maskedChronologicalSignLayer parameter ftsSecret index lay) := by + unfold maskedChronologicalSignLayer + apply (rootMaterializationPreserving_maskedSignLayer parameter ftsSecret index lay).bind + intro selected + cases selected with + | none => exact .pure none + | some selected => exact (rootMaterializationPreserving_revealPrivateLayerValues index lay selected.2).bind (fun _ => .pure _) + +theorem rootMaterializationPreserving_publishChronologicalSignature + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) (layers : Layer → Option ChronologicalLayerPart) : + RootMaterializationPreserving (publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers) := by + unfold publishChronologicalSignature + cases traverseOption layers with + | none => exact .pure none + | some parts => exact (rootMaterializationPreserving_sequenceFin _ + (fun lay => rootMaterializationPreserving_revealLayerValues index lay (parts lay).encoding)).bind (fun _ => .pure _) + +theorem rootMaterializationPreserving_chronologicalSignAfterDigest (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + RootMaterializationPreserving (maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves) := by + unfold maskedPublishedChronologicalSignAfterDigest maskedChronologicalSignLayers + exact (rootMaterializationPreserving_ordinaryHash _).bind fun ftsPath => + (rootMaterializationPreserving_sequenceFin _ (fun lay => rootMaterializationPreserving_chronologicalSignLayer parameter ftsSecret index lay)).bind + (fun layers => rootMaterializationPreserving_publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers) + +theorem rootMaterializationPreserving_chronologicalSign (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + RootMaterializationPreserving (maskedPublishedChronologicalSign parameter root ftsSecret message) := by + unfold maskedPublishedChronologicalSign + apply (rootMaterializationPreserving_ordinaryRom _).bind + intro selected + cases selected with + | none => exact .pure none + | some selected => + exact rootMaterializationPreserving_chronologicalSignAfterDigest parameter ftsSecret selected.1 selected.2.1 selected.2.2 + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootQueryReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootQueryReserve.lean new file mode 100644 index 00000000..6d34a81e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootQueryReserve.lean @@ -0,0 +1,121 @@ +import SphincsSecurity.Proof.OtsProbeOrdinaryCharge +import SphincsSecurity.Proof.OtsOpeningQueryReserve + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +theorem ftsOpeningQueryReserve_eq_zero_of_atEncodingPosition + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) + (position : EncodingPosition) (hat : AtEncodingPosition secretKey.parameter input position) : + ftsOpeningQueryReserve secretKey cache input = 0 := by + classical + have hnone : ¬ ∃ probe : FtsSecretProbe, probe.input secretKey.parameter = input := by + rintro ⟨probe, hinput⟩ + apply hat.not_atPosition (.ftsLeaf probe.index probe.tree probe.leafIdx) + rw [← hinput] + exact ⟨digestBytes probe.candidate, rfl⟩ + simp only [ftsOpeningQueryReserve, FtsProbeSimulation.ftsHashQueryCharge, if_neg hnone, zero_mul] + +theorem otsOpeningQueryReserve_atEncodingPosition + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) + (position : EncodingPosition) (hat : AtEncodingPosition secretKey.parameter input position) : + otsOpeningQueryReserve secretKey cache input = + if cache input = none then + if HasEncodingTarget cache secretKey position then 2 + else if EncodingMessageSettledAt cache secretKey position then 1 else 0 + else 3 := by + classical + rw [otsOpeningQueryReserve, + ftsOpeningQueryReserve_eq_zero_of_atEncodingPosition secretKey cache input position hat, tsub_zero] + have hexists : ∃ candidate : EncodingPosition, AtEncodingPosition secretKey.parameter input candidate := + ⟨position, hat⟩ + have hselected : Classical.choose hexists = position := + atEncodingPosition_unique (Classical.choose_spec hexists) hat + unfold residualPrimitiveQueryCharge TightEncoding.refinedStructuralEncodingQueryCharge + by_cases hfresh : cache input = none + · simp only [hfresh, if_true, hexists, ↓reduceDIte, hselected, TightEncoding.encodingStageIncrement] + split_ifs <;> norm_num + · exact (ENNReal.eq_sub_of_add_eq' (by norm_num) + (show (2 : ℝ≥0∞) + 1 = 3 by norm_num)).symm + · exact (ENNReal.eq_sub_of_add_eq' (by norm_num) + (show (1 : ℝ≥0∞) + 2 = 3 by norm_num)).symm + · simp [hfresh] + +theorem otsOpeningQueryReserve_ge_two_of_encodingTarget + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) + (position : EncodingPosition) (hat : AtEncodingPosition secretKey.parameter input position) + (htarget : HasEncodingTarget cache secretKey position) : + 2 ≤ otsOpeningQueryReserve secretKey cache input := by + rw [otsOpeningQueryReserve_atEncodingPosition secretKey cache input position hat] + by_cases hfresh : cache input = none <;> simp [hfresh, htarget] + norm_num + +namespace OtsProbeSimulation + +theorem probingHashQueryAfterRootAwarePublicPlan_weightedCharge_le_four_thirds + (parameter : PublicParameter) (input : HashInput) (publicState : LazyRevealProbe.State Coordinate) + (plan : PlannedHashQuery) (cache : SplitHashCache) (context : DeferredContext) (fuel : Nat) : + ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) context fuel + + (materializedCandidateCharge context.state (rootAwareCandidateForPlan? parameter input plan) : ℝ≥0∞) * + (4 / 3) ≤ 4 / 3 := by + have hfactor : (1 : ℝ≥0∞) ≤ 4 / 3 := by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + norm_num + calc + _ ≤ (ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterRootAwarePublicPlan parameter input publicState plan).run cache) context fuel + + (materializedCandidateCharge context.state (rootAwareCandidateForPlan? parameter input plan) : ℝ≥0∞)) * + (4 / 3) := by + rw [add_mul] + exact add_le_add (by simpa only [mul_one] using mul_le_mul' le_rfl hfactor) le_rfl + _ ≤ _ := mul_le_of_le_one_left (by positivity) + (probingHashQueryAfterRootAwarePublicPlan_ordinaryCharge_add_materialized_le_one + parameter input publicState plan cache context fuel) + +theorem probingHashQueryAfterRootAwarePublicPlan_weightedCharge_le_reserve_of_encodingTarget + (secretKey : SecretKey) (actualCache : QueryCache HashSpec) (input : HashInput) + (position : EncodingPosition) (hat : AtEncodingPosition secretKey.parameter input position) + (htarget : HasEncodingTarget actualCache secretKey position) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (cache : SplitHashCache) (context : DeferredContext) (fuel : Nat) : + ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterRootAwarePublicPlan secretKey.parameter input publicState plan).run cache) context fuel + + (materializedCandidateCharge context.state (rootAwareCandidateForPlan? secretKey.parameter input plan) : ℝ≥0∞) * + (4 / 3) ≤ otsOpeningQueryReserve secretKey actualCache input := + (probingHashQueryAfterRootAwarePublicPlan_weightedCharge_le_four_thirds + secretKey.parameter input publicState plan cache context fuel).trans + ((by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + norm_num : (4 / 3 : ℝ≥0∞) ≤ 2).trans + (otsOpeningQueryReserve_ge_two_of_encodingTarget secretKey actualCache input position hat htarget)) + +theorem probingHashQueryAfterRootAwarePublicPlan_weightedCharge_le_reserve_after_sign + (secretKey : SecretKey) (message : Message) + (beforeCache afterCache actualCache : QueryCache HashSpec) (result : Option Signature) + (hrun : (result, afterCache) ∈ support + ((simulateQ romImpl (sign secretKey message)).run beforeCache)) + (hcache : afterCache ≤ actualCache) + (position : EncodingPosition) (payload : HashInput) + (hbefore : beforeCache (tweakableHashInput secretKey.parameter position.domain payload) = none) + (hafter : afterCache (tweakableHashInput secretKey.parameter position.domain payload) ≠ none) + (hvalid : TargetSum.ValidDigest (truncateHash (fromCache afterCache + (tweakableHashInput secretKey.parameter position.domain payload)))) + (input : HashInput) (hat : AtEncodingPosition secretKey.parameter input position) + (publicState : LazyRevealProbe.State Coordinate) (plan : PlannedHashQuery) + (cache : SplitHashCache) (context : DeferredContext) (fuel : Nat) : + ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterRootAwarePublicPlan secretKey.parameter input publicState plan).run cache) context fuel + + (materializedCandidateCharge context.state (rootAwareCandidateForPlan? secretKey.parameter input plan) : ℝ≥0∞) * + (4 / 3) ≤ otsOpeningQueryReserve secretKey actualCache input := by + apply probingHashQueryAfterRootAwarePublicPlan_weightedCharge_le_reserve_of_encodingTarget + secretKey actualCache input position hat + exact (hasEncodingTarget_of_sign_transition secretKey message beforeCache afterCache result + hrun position payload hbefore hafter hvalid).mono hcache + +end OtsProbeSimulation + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootRisk125.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootRisk125.lean new file mode 100644 index 00000000..98bede11 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootRisk125.lean @@ -0,0 +1,199 @@ +import SphincsSecurity.Proof.OtsProbeRootCoupling125 + +namespace SphincsSecurity.Concrete.OtsProbeSimulation.Range125 + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option linter.constructorNameAsVariable false + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_successfulDoomedFirstRootFiber_le_eight_sevenths_mul_production + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (hordinal : ordinal < q) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[fun observed => + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target (2 * q) table] * + ((8 / 7) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + let run := observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table + let probability := Pr[fun observed => + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed | run] + let weight := Pr[fun result ↦ materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target (2 * q) table] + let epsilon := ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + have hgood : + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest ↦ + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] ≤ weight * epsilon := by + exact probEvent_observedRootComparison_le_production_mul ordinal adversary parameter table + ftsSecret q target hroot hparent hfuel hbound (hq.trans (by norm_num)) + have hsplit : probability ≤ + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest => + ObservedCleanRunOption.SuccessfulFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] + + probability * + ((ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + exact probEvent_successfulDoomedFirstRootFiber_le_goodComparison_add_weightedException + table run ordinal target + have hfraction : + (ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ ≤ + (8 : ENNReal)⁻¹ := + ordinal_mul_inv_digest_le_inv_eight ordinal q hordinal hq + have habsorb : probability ≤ (8 / 7) * (weight * epsilon) := by + apply le_eight_sevenths_mul_of_le_add_mul_inv_eight probability (weight * epsilon) + · exact probEvent_le_one + · apply ne_top_of_le_ne_top (by norm_num : (1 : ENNReal) ≠ ∞) + calc + weight * epsilon ≤ 1 * 1 := by + apply mul_le_mul probEvent_le_one + · simp [epsilon, digestBits] + · exact bot_le + · exact bot_le + _ = 1 := one_mul 1 + · have hweighted : probability * ((ordinal : ENNReal) * epsilon) ≤ + probability * (8 : ENNReal)⁻¹ := mul_le_mul' le_rfl hfraction + exact hsplit.trans (add_le_add hgood hweighted) + change probability ≤ weight * ((8 / 7) * epsilon) + calc + probability ≤ (8 / 7) * (weight * epsilon) := habsorb + _ = weight * ((8 / 7) * epsilon) := by ac_rfl + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_successfulDoomedFirstRootFiber_le_commonDetailedFiber + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (target : Position) (hroot : IsLayerRoot target) + (hparent : ∃ parent, Position.parentOf target = some parent) + (hordinal : ordinal < q) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[fun observed => + ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget + table ordinal target observed | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun selection => + permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection = some target | + permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret + (2 * q) table] * + ((8 / 7) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + calc + _ ≤ Pr[fun result => materializedOrdinalSelectionAt target result.2 | + materializedRootAwareOrdinalProductionExperimentAfterTable ordinal adversary parameter + ftsSecret target (2 * q) table] * + ((8 / 7) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := + probEvent_successfulDoomedFirstRootFiber_le_eight_sevenths_mul_production ordinal adversary parameter + table ftsSecret q target hroot hparent hordinal hfuel hbound hq + _ ≤ _ := by + gcongr + exact probEvent_materializedRootAwareProduction_le_commonDetailedFiber ordinal adversary + parameter ftsSecret target hroot hparent (2 * q) table + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_successfulDoomedFirstRoot_le_commonDetailed + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (hordinal : ordinal < q) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + (8 / 7) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_le_of_common_position_fibers + (leftPosition := observedFirstLayerRootPosition? ordinal) + (common := permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret (2 * q) table) + (commonPosition := permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?) + · intro observed hevent hnone + exact not_successfulDoomedFirstRoot_of_position_eq_none hnone hevent + · intro target + by_cases hexists : ∃ observed ∈ support + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table), + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal observed ∧ + observedFirstLayerRootPosition? ordinal observed = some target + · have hstructure := + root_and_parent_of_existing_successfulDoomedFirstRootFiber hexists + simpa [ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget] using + probEvent_successfulDoomedFirstRootFiber_le_commonDetailedFiber ordinal adversary + parameter table ftsSecret q target hstructure.1 hstructure.2 hordinal hfuel hbound hq + · simp only [not_exists, not_and] at hexists + have hzero : Pr[fun observed => + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt + table ordinal observed ∧ + observedFirstLayerRootPosition? ordinal observed = some target | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] = + 0 := by + apply probEvent_eq_zero + intro observed hsupport hevent + exact hexists observed hsupport hevent.1 hevent.2 + rw [hzero] + exact zero_le + +set_option maxHeartbeats 8000000 in +set_option maxRecDepth 1000000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_firstRoot_le + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (hordinal : ordinal < q) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenRootHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + (8 / 7) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_sampledDiagnostic_successfulDoomed_firstExistingHiddenRootHitAt_le_of_forall + intro table + exact probEvent_successfulDoomedFirstRoot_le_commonDetailed ordinal adversary parameter table + ftsSecret q hordinal hfuel (hbound table) hq + +end SphincsSecurity.Concrete.OtsProbeSimulation.Range125 diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootSelectionMass125.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootSelectionMass125.lean new file mode 100644 index 00000000..51e4b309 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootSelectionMass125.lean @@ -0,0 +1,135 @@ +import SphincsSecurity.Proof.OtsProbeJointBound125 + +namespace SphincsSecurity.Concrete.OtsProbeSimulation.Range125 + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot +set_option linter.constructorNameAsVariable false + +/-- Keep the selected-position mass when summing the disjoint target fibers. -/ +theorem probEvent_le_common_selected_mass + (left : ProbComp α) (event : α → Prop) (leftPosition : α → Option Position) + (common : ProbComp β) (commonPosition : β → Option Position) (epsilon : ENNReal) + (hnone : ∀ value, event value → leftPosition value ≠ none) + (hfiber : ∀ target, + Pr[fun value => event value ∧ leftPosition value = some target | left] ≤ + Pr[fun value => commonPosition value = some target | common] * epsilon) : + Pr[event | left] ≤ + Pr[fun value => (commonPosition value).isSome = true | common] * epsilon := by + rw [probEvent_eq_tsum_classify_fibers left event leftPosition] + calc + _ ≤ ∑' target : Option Position, + Pr[fun value => (commonPosition value).isSome = true ∧ + commonPosition value = target | common] * epsilon := by + apply ENNReal.tsum_le_tsum + intro target + cases target with + | none => + have hzero : Pr[fun value => event value ∧ leftPosition value = none | left] = 0 := by + apply probEvent_eq_zero + intro value _hvalue hevent + exact hnone value hevent.1 hevent.2 + rw [hzero] + exact zero_le + | some target => + have heq : Pr[fun value => (commonPosition value).isSome = true ∧ + commonPosition value = some target | common] = + Pr[fun value => commonPosition value = some target | common] := by + apply OracleComp.probEvent_congr' + · intro value _ + constructor + · exact And.right + · intro htarget + exact ⟨by simp [htarget], htarget⟩ + · rfl + rw [heq] + exact hfiber target + _ = _ := by + rw [ENNReal.tsum_mul_right, ← probEvent_eq_tsum_classify_fibers] + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_successfulDoomedFirstRoot_le_selected_mass + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) (hordinal : ordinal < q) + (hfuel : 2 * q < Fintype.card Digest) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun selection => + (permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection).isSome = true | + permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret + (2 * q) table] * ((8 / 7) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply probEvent_le_common_selected_mass + (leftPosition := observedFirstLayerRootPosition? ordinal) + (common := permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret (2 * q) table) + (commonPosition := permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?) + · intro observed hevent hnone + exact not_successfulDoomedFirstRoot_of_position_eq_none hnone hevent + · intro target + by_cases hexists : ∃ observed ∈ support + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table), + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal observed ∧ + observedFirstLayerRootPosition? ordinal observed = some target + · have hstructure := + root_and_parent_of_existing_successfulDoomedFirstRootFiber hexists + simpa [ObservedCleanRunOption.SuccessfulFirstRootHitAtTarget] using + probEvent_successfulDoomedFirstRootFiber_le_commonDetailedFiber ordinal adversary + parameter table ftsSecret q target hstructure.1 hstructure.2 hordinal hfuel hbound hq + · simp only [not_exists, not_and] at hexists + have hzero : Pr[fun observed => + ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt + table ordinal observed ∧ + observedFirstLayerRootPosition? ordinal observed = some target | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] = + 0 := by + apply probEvent_eq_zero + intro observed hsupport hevent + exact hexists observed hsupport hevent.1 hevent.2 + rw [hzero] + exact zero_le + + +set_option maxHeartbeats 2000000 in +set_option maxRecDepth 100000 in +theorem probEvent_granularAllCanonical_delayedOrdinal_le_selected_mass + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hordinal : ordinal < q) (hq : q ≤ 2 ^ 125) : + Pr[WitnessFirstUsesDelayedLayerRootSnapshotOrdinal ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q] ≤ + Pr[fun selection => + (permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition? selection).isSome = true | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret q table] * ((8 / 7) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply probEvent_le_common_selected_mass + (leftPosition := delayedSnapshotLayerRootPosition? ordinal) + (common := delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret q table) + (commonPosition := permissivePrivateOrdinalSelectionUnrevealedLayerRootPosition?) + · intro output hdelayed + obtain ⟨target, htarget⟩ := + delayedSnapshotLayerRootPosition?_eq_some_of_delayed hdelayed + rw [htarget] + simp + · intro target + exact probEvent_delayedRootFiber_le_eight_sevenths_mul_common + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q) + (delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret q table) + ordinal q target hordinal hq (probEvent_delayedGoodComparison_le_common_mul_allTargets ordinal adversary parameter + table ftsSecret q target) + + +end SphincsSecurity.Concrete.OtsProbeSimulation.Range125 diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootSourceTrace.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootSourceTrace.lean new file mode 100644 index 00000000..55c4a3dd --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRootSourceTrace.lean @@ -0,0 +1,182 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootSource +import SphincsSecurity.Proof.OtsProbeQueryTraceReserve + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +def PrehitQuerySnapshot.EncodingSourceSettledTo (accountingKey : SecretKey) + (before after : PrehitQuerySnapshot) : Prop := + ∀ (input : HashInput) (candidate : Probe) (target : Position), + before.input = .inl (.inr input) → + EncodingLayerRootCandidateAt accountingKey.parameter input candidate → + candidate.coordinate = .position target → after.state.2 = false → + Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret after.state.1.cache target → + candidate.candidate = honestValue (fromCache after.state.1.cache) + accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret target → + Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret before.state.1.cache target + +set_option maxRecDepth 100000 in +theorem prehitQueryTrace_pairwise_encodingSourceSettled + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) + (result : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hrun : result ∈ support (runPrehitQueryTrace accountingKey secretKey computation state)) : + result.2.Pairwise (PrehitQuerySnapshot.EncodingSourceSettledTo accountingKey) := by + induction computation using OracleComp.inductionOn generalizing state result with + | pure value => + simp only [runPrehitQueryTrace, OracleComp.construct_pure, mem_support_pure_iff] at hrun + subst result + exact List.Pairwise.nil + | query_bind query next ih => + rw [runPrehitQueryTrace_query_bind, mem_support_bind_iff] at hrun + obtain ⟨step, hstep, hrun⟩ := hrun + rw [mem_support_bind_iff] at hrun + obtain ⟨tail, htail, hresult⟩ := hrun + simp only [mem_support_pure_iff] at hresult + subst result + apply List.Pairwise.cons ?_ (ih step.1 step.2 tail htail) + intro entry hentry input candidate target hinput hcandidate hposition hfalse hsettled hmatch + change query = .inl (.inr input) at hinput + subst query + obtain ⟨ordinal, cut, _hcutInput, hcut⟩ := queryCut_support_of_mem_prehitQueryTrace + accountingKey secretKey (next step.1) step.2 tail htail entry hentry + let segment : OracleComp (OracleWorld + SigningSpec) (OuterQueryCut α) := + (OracleWorld + SigningSpec).query (.inl (.inr input)) >>= fun answer => outerQueryCutAt (next answer) ordinal + have hprefix : (cut, entry.state) ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) segment).run state) := by + dsimp only [segment] + rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, mem_support_bind_iff] + exact ⟨step, hstep, hcut⟩ + have hprefixFalse : (cut, (entry.state.1, false)) ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) segment).run (state.1, state.2)) := by + simpa only [← hfalse] using hprefix + have hinitial := encodingPrehitViewedAdversaryImpl_initial_false_of_mem_support accountingKey secretKey + segment state.1 entry.state.1 state.2 cut hprefixFalse + rw [hinitial] at hprefixFalse + exact hcandidate.settled_of_prehitFree_viewed_matching_query secretKey hposition hsettled hmatch + (fun answer => outerQueryCutAt (next answer) ordinal) cut hprefixFalse + +def UnsettledSourceEncodingRootMatch (accountingKey : SecretKey) (history : List PrehitQuerySnapshot) : Prop := + ∃ (i j : Fin history.length), i.val < j.val ∧ + ∃ (input : HashInput) (candidate : Probe) (target : Position), + (history.get i).input = .inl (.inr input) ∧ + EncodingLayerRootCandidateAt accountingKey.parameter input candidate ∧ + candidate.coordinate = .position target ∧ + Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret (history.get j).state.1.cache target ∧ + candidate.candidate = honestValue (fromCache (history.get j).state.1.cache) + accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret target ∧ + ¬Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret (history.get i).state.1.cache target + +theorem prehitQueryTrace_hit_of_unsettledSourceEncodingRootMatch + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) + (result : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hrun : result ∈ support (runPrehitQueryTrace accountingKey secretKey computation state)) + (hmatch : UnsettledSourceEncodingRootMatch accountingKey result.2) : result.1.2.2 = true := by + by_cases hhit : result.1.2.2 = true + · exact hhit + have hfalse := Bool.eq_false_iff.mpr hhit + obtain ⟨i, j, hij, input, candidate, target, hinput, hcandidate, hposition, hsettled, hmatch, hreserve⟩ := hmatch + have hpairs := prehitQueryTrace_pairwise_encodingSourceSettled accountingKey secretKey computation state result hrun + have hpair := hpairs.rel_get_of_lt hij + have hentryFalse := prehitQueryTrace_entry_false_of_final_false accountingKey secretKey computation state result + hrun hfalse (result.2.get j) (List.get_mem _ _) + exact False.elim (hreserve + (hpair input candidate target hinput hcandidate hposition hentryFalse hsettled hmatch)) + +theorem probEvent_unsettledSourceEncodingRootMatch_le_prehit + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) : + Pr[fun result => UnsettledSourceEncodingRootMatch accountingKey result.2 | + runPrehitQueryTrace accountingKey secretKey computation state] ≤ + Pr[fun result => result.2.2 = true | + (simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run state] := by + rw [← runPrehitQueryTrace_projection, probEvent_map] + exact probEvent_mono fun result hresult hmatch => + prehitQueryTrace_hit_of_unsettledSourceEncodingRootMatch accountingKey secretKey computation state result hresult hmatch + +set_option maxRecDepth 100000 in +theorem prehitQueryTrace_encodingSourceSettled_at_final + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) + (result : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hrun : result ∈ support (runPrehitQueryTrace accountingKey secretKey computation state)) + (entry : PrehitQuerySnapshot) (hentry : entry ∈ result.2) + (input : HashInput) (candidate : Probe) (target : Position) + (hinput : entry.input = .inl (.inr input)) + (hcandidate : EncodingLayerRootCandidateAt accountingKey.parameter input candidate) + (hposition : candidate.coordinate = .position target) (hfinal : result.1.2.2 = false) + (hsettled : Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret result.1.2.1.cache target) + (hmatch : candidate.candidate = honestValue (fromCache result.1.2.1.cache) + accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret target) : + Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret entry.state.1.cache target := by + induction computation using OracleComp.inductionOn generalizing state result with + | pure value => + simp only [runPrehitQueryTrace, OracleComp.construct_pure, mem_support_pure_iff] at hrun + subst result + simp at hentry + | query_bind query next ih => + have hproject := mem_support_prehitRun_of_trace accountingKey secretKey _ state result hrun + rw [runPrehitQueryTrace_query_bind, mem_support_bind_iff] at hrun + obtain ⟨step, hstep, hrun⟩ := hrun + rw [mem_support_bind_iff] at hrun + obtain ⟨tail, htail, hresult⟩ := hrun + simp only [mem_support_pure_iff] at hresult + subst result + rcases List.mem_cons.mp hentry with heq | htailEntry + · subst entry + change query = .inl (.inr input) at hinput + subst query + have hrunFalse : (tail.1.1, (tail.1.2.1, false)) ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next)).run (state.1, state.2)) := by + dsimp only at hfinal + simpa only [← hfinal] using hproject + have hinitial := encodingPrehitViewedAdversaryImpl_initial_false_of_mem_support accountingKey secretKey + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next) + state.1 tail.1.2.1 state.2 tail.1.1 hrunFalse + rw [hinitial] at hrunFalse + exact hcandidate.settled_of_prehitFree_viewed_matching_query secretKey hposition hsettled hmatch + next tail.1.1 hrunFalse + · exact ih step.1 step.2 tail htail htailEntry hfinal hsettled hmatch + +def UnsettledSourceFinalEncodingRootMatch (accountingKey : SecretKey) + (result : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) : Prop := + ∃ entry ∈ result.2, ∃ (input : HashInput) (candidate : Probe) (target : Position), + entry.input = .inl (.inr input) ∧ + EncodingLayerRootCandidateAt accountingKey.parameter input candidate ∧ + candidate.coordinate = .position target ∧ + Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret result.1.2.1.cache target ∧ + candidate.candidate = honestValue (fromCache result.1.2.1.cache) + accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret target ∧ + ¬Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret entry.state.1.cache target + +theorem prehitQueryTrace_hit_of_unsettledSourceFinalEncodingRootMatch + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) + (result : (α × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hrun : result ∈ support (runPrehitQueryTrace accountingKey secretKey computation state)) + (hmatch : UnsettledSourceFinalEncodingRootMatch accountingKey result) : result.1.2.2 = true := by + by_cases hhit : result.1.2.2 = true + · exact hhit + obtain ⟨entry, hentry, input, candidate, target, hinput, hcandidate, hposition, hsettled, hmatch, hreserve⟩ := hmatch + exact False.elim (hreserve (prehitQueryTrace_encodingSourceSettled_at_final accountingKey secretKey + computation state result hrun entry hentry input candidate target hinput hcandidate hposition + (Bool.eq_false_iff.mpr hhit) hsettled hmatch)) + +theorem probEvent_unsettledSourceTraceRootMatch_le_prehit + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × Bool) : + Pr[fun result => UnsettledSourceEncodingRootMatch accountingKey result.2 ∨ UnsettledSourceFinalEncodingRootMatch accountingKey result | + runPrehitQueryTrace accountingKey secretKey computation state] ≤ + Pr[fun result => result.2.2 = true | + (simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) computation).run state] := by + rw [← runPrehitQueryTrace_projection, probEvent_map] + apply probEvent_mono + intro result hresult hmatch + rcases hmatch with hpairs | hfinal + · exact prehitQueryTrace_hit_of_unsettledSourceEncodingRootMatch accountingKey secretKey computation state result hresult hpairs + · exact prehitQueryTrace_hit_of_unsettledSourceFinalEncodingRootMatch accountingKey secretKey computation state result hresult hfinal + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeRunSampling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRunSampling.lean new file mode 100644 index 00000000..eca216c9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeRunSampling.lean @@ -0,0 +1,2585 @@ +import SphincsSecurity.Proof.OtsProbeCompletionSampling + +/-! +# Finite-table deferral through one-time probing runs + +The clean eager interpreter reads missing chain starts from one finite table. All uniform draws and +all ordinary or structural random-oracle outputs remain lazy. Its result retains the hidden state, +probe fuel and table needed by finalization. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +noncomputable local instance runSampleableOtsHashTable : + SampleableType (OtsSecretIndex → HashOutput) := + SampleableType.ofFintype (OtsSecretIndex → HashOutput) + +noncomputable def sampleOtsHashTable : + ProbComp (OtsSecretIndex → HashOutput) := + $ᵗ (OtsSecretIndex → HashOutput) + +theorem probFailure_sampleOtsHashTable : Pr[⊥ | sampleOtsHashTable] = 0 := by + rw [sampleOtsHashTable] + exact probFailure_uniformSample _ + +theorem evalDist_sampleOtsHashTable_bind_const (result : ProbComp alpha) : + 𝒟[sampleOtsHashTable >>= fun _ => result] = 𝒟[result] := by + exact OracleComp.DeferredSampling.evalDist_bind_const_neverFails + sampleOtsHashTable (by rw [sampleOtsHashTable]; simp) result + +structure CleanRunResult (alpha : Type) where + state : LazyRevealProbe.State Coordinate + remaining : Nat + value : alpha + table : OtsSecretIndex → HashOutput + +noncomputable def runCleanFromTable + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) : + ProbComp (Option (CleanRunResult alpha)) := + OracleComp.construct + (C := fun _ : OracleComp (LazyRevealProbe.World Coordinate) alpha => + LazyRevealProbe.State Coordinate → Nat → (OtsSecretIndex → HashOutput) → + ProbComp (Option (CleanRunResult alpha))) + (fun value state remaining table => pure (some ⟨state, remaining, value, table⟩)) + (fun input _next recursivelyRun state fuel table => + match input with + | .uniform n => do + let output ← liftM (unifSpec.query n) + recursivelyRun output state fuel table + | .hashOutput => do + let output ← LazyRevealProbe.sampleHashOutput + recursivelyRun output state fuel table + | .ensure coordinate => + recursivelyRun () (state.ensure coordinate) fuel table + | .probe coordinate candidate => + match fuel with + | 0 => pure none + | remaining + 1 => + if coordinate ∈ state.revealed then + recursivelyRun () state remaining table + else + recursivelyRun () (state.addPending coordinate candidate) remaining table + | .peek coordinate => + recursivelyRun (state.values coordinate) state fuel table + | .publish coordinate => + recursivelyRun () (state.publish coordinate) fuel table + | .reveal coordinate => + match state.values coordinate with + | some output => recursivelyRun output state fuel table + | none => + match coordinate with + | .chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + if state.hitAt coordinate output then + pure none + else + recursivelyRun output (state.materialize coordinate output) fuel table + | .position _ => do + let output ← LazyRevealProbe.sampleHashOutput + if state.hitAt coordinate output then + pure none + else + recursivelyRun output (state.materialize coordinate output) fuel table) + computation state fuel table + +noncomputable def runRawCleanWithCompletionTable + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) : + ProbComp (Option (CleanRunResult alpha)) := do + let result ← LazyRevealProbe.runRaw state fuel computation + match result with + | .stopped _ => pure none + | .done finalState remaining value => do + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + pure (some ⟨finalState, remaining, value, + completedStartTable finalState base⟩) + +theorem runCleanFromTable_uniform_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel n : Nat) + (table : OtsSecretIndex → HashOutput) + (next : Fin (n + 1) → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runCleanFromTable state fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) (.uniform n)) : + OracleComp (LazyRevealProbe.World Coordinate) (Fin (n + 1))) >>= next) = (do + let output ← liftM (unifSpec.query n) + runCleanFromTable state fuel table (next output)) := by + rw [runCleanFromTable, OracleComp.construct_query_bind] + rfl + +theorem runCleanFromTable_hashOutput_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runCleanFromTable state fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) .hashOutput) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = (do + let output ← LazyRevealProbe.sampleHashOutput + runCleanFromTable state fuel table (next output)) := by + rw [runCleanFromTable, OracleComp.construct_query_bind] + rfl + +theorem runCleanFromTable_ensure_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runCleanFromTable state fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.ensure coordinate)) : OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runCleanFromTable (state.ensure coordinate) fuel table (next ()) := by + rw [runCleanFromTable, OracleComp.construct_query_bind] + rfl + +theorem runCleanFromTable_probe_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) (candidate : Digest) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runCleanFromTable state fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.probe coordinate candidate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + match fuel with + | 0 => pure none + | remaining + 1 => + if coordinate ∈ state.revealed then + runCleanFromTable state remaining table (next ()) + else + runCleanFromTable (state.addPending coordinate candidate) remaining table (next ()) := by + rw [runCleanFromTable, OracleComp.construct_query_bind] + rfl + +theorem runCleanFromTable_peek_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Option HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runCleanFromTable state fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.peek coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) (Option HashOutput)) >>= next) = + runCleanFromTable state fuel table (next (state.values coordinate)) := by + rw [runCleanFromTable, OracleComp.construct_query_bind] + rfl + +theorem runCleanFromTable_publish_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runCleanFromTable state fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.publish coordinate)) : OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runCleanFromTable (state.publish coordinate) fuel table (next ()) := by + rw [runCleanFromTable, OracleComp.construct_query_bind] + rfl + +theorem runCleanFromTable_reveal_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (coordinate : Coordinate) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runCleanFromTable state fuel table + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.reveal coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = + (match state.values coordinate with + | some output => runCleanFromTable state fuel table (next output) + | none => + match coordinate with + | .chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + if state.hitAt coordinate output then + pure none + else + runCleanFromTable (state.materialize coordinate output) fuel table (next output) + | .position _ => do + let output ← LazyRevealProbe.sampleHashOutput + if state.hitAt coordinate output then + pure none + else + runCleanFromTable (state.materialize coordinate output) fuel table + (next output)) := by + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + rw [runCleanFromTable, OracleComp.construct_query_bind] + rfl + | position position => + rw [runCleanFromTable, OracleComp.construct_query_bind] + rfl + +theorem runRawCleanWithCompletionTable_uniform_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel n : Nat) + (next : Fin (n + 1) → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runRawCleanWithCompletionTable state fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) (.uniform n)) : + OracleComp (LazyRevealProbe.World Coordinate) (Fin (n + 1))) >>= next) = (do + let output ← liftM (unifSpec.query n) + runRawCleanWithCompletionTable state fuel (next output)) := by + unfold runRawCleanWithCompletionTable + rw [LazyRevealProbe.runRaw_uniform_query_bind, bind_assoc] + +theorem runRawCleanWithCompletionTable_hashOutput_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runRawCleanWithCompletionTable state fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) .hashOutput) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = (do + let output ← LazyRevealProbe.sampleHashOutput + runRawCleanWithCompletionTable state fuel (next output)) := by + unfold runRawCleanWithCompletionTable + rw [LazyRevealProbe.runRaw_hashOutput_query_bind, bind_assoc] + +theorem runRawCleanWithCompletionTable_ensure_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runRawCleanWithCompletionTable state fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.ensure coordinate)) : OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runRawCleanWithCompletionTable (state.ensure coordinate) fuel (next ()) := by + unfold runRawCleanWithCompletionTable + rw [LazyRevealProbe.runRaw_ensure_query_bind] + +theorem runRawCleanWithCompletionTable_probe_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) (coordinate : Coordinate) + (candidate : Digest) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runRawCleanWithCompletionTable state fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.probe coordinate candidate)) : + OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + match fuel with + | 0 => pure none + | remaining + 1 => + if coordinate ∈ state.revealed then + runRawCleanWithCompletionTable state remaining (next ()) + else + runRawCleanWithCompletionTable (state.addPending coordinate candidate) + remaining (next ()) := by + unfold runRawCleanWithCompletionTable + rw [LazyRevealProbe.runRaw_probe_query_bind] + cases fuel with + | zero => rfl + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed <;> simp [hrevealed] + +theorem runRawCleanWithCompletionTable_peek_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) (coordinate : Coordinate) + (next : Option HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runRawCleanWithCompletionTable state fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.peek coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) (Option HashOutput)) >>= next) = + runRawCleanWithCompletionTable state fuel (next (state.values coordinate)) := by + unfold runRawCleanWithCompletionTable + rw [LazyRevealProbe.runRaw_peek_query_bind] + +theorem runRawCleanWithCompletionTable_publish_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) (coordinate : Coordinate) + (next : Unit → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runRawCleanWithCompletionTable state fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.publish coordinate)) : OracleComp (LazyRevealProbe.World Coordinate) Unit) >>= next) = + runRawCleanWithCompletionTable (state.publish coordinate) fuel (next ()) := by + unfold runRawCleanWithCompletionTable + rw [LazyRevealProbe.runRaw_publish_query_bind] + +theorem runRawCleanWithCompletionTable_reveal_query_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) (coordinate : Coordinate) + (next : HashOutput → OracleComp (LazyRevealProbe.World Coordinate) alpha) : + runRawCleanWithCompletionTable state fuel + ((liftM (OracleSpec.query (spec := LazyRevealProbe.World Coordinate) + (.reveal coordinate)) : + OracleComp (LazyRevealProbe.World Coordinate) HashOutput) >>= next) = + (match state.values coordinate with + | some output => runRawCleanWithCompletionTable state fuel (next output) + | none => do + let output ← LazyRevealProbe.sampleHashOutput + if state.hitAt coordinate output then + pure none + else + runRawCleanWithCompletionTable (state.materialize coordinate output) + fuel (next output)) := by + unfold runRawCleanWithCompletionTable + rw [LazyRevealProbe.runRaw_reveal_query_bind] + cases hvalue : state.values coordinate with + | some output => rfl + | none => + simp only [bind_assoc] + apply bind_congr + intro output + by_cases hhit : state.hitAt coordinate output <;> simp [hhit] + +set_option maxRecDepth 100000 in +theorem evalDist_runCleanFromTable_eq_lazy + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) : + 𝒟[do + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + runCleanFromTable state fuel (completedStartTable state base) computation] = + 𝒟[runRawCleanWithCompletionTable state fuel computation] := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + simp [runCleanFromTable, runRawCleanWithCompletionTable, LazyRevealProbe.runRaw] + | query_bind input next ih => + cases input with + | uniform n => + simp_rw [runCleanFromTable_uniform_query_bind] + rw [runRawCleanWithCompletionTable_uniform_query_bind] + calc + _ = 𝒟[(liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) >>= + fun output => + ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) >>= fun base => + runCleanFromTable state fuel (completedStartTable state base) + (next output)] := + OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + _ = _ := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + exact ih output state fuel + | hashOutput => + simp_rw [runCleanFromTable_hashOutput_query_bind] + rw [runRawCleanWithCompletionTable_hashOutput_query_bind] + calc + _ = 𝒟[LazyRevealProbe.sampleHashOutput >>= fun output => + ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) >>= fun base => + runCleanFromTable state fuel (completedStartTable state base) + (next output)] := + OracleComp.DeferredSampling.evalDist_bind_comm _ _ _ + _ = _ := by + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + exact ih output state fuel + | ensure coordinate => + simp_rw [runCleanFromTable_ensure_query_bind] + rw [runRawCleanWithCompletionTable_ensure_query_bind] + simpa using ih () (state.ensure coordinate) fuel + | probe coordinate candidate => + simp_rw [runCleanFromTable_probe_query_bind] + rw [runRawCleanWithCompletionTable_probe_query_bind] + cases fuel with + | zero => + exact OracleComp.DeferredSampling.evalDist_bind_const_neverFails + ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + (by simp) (pure none) + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () state remaining + · simp only [hrevealed, ↓reduceIte] + simpa using ih () (state.addPending coordinate candidate) remaining + | peek coordinate => + simp_rw [runCleanFromTable_peek_query_bind] + rw [runRawCleanWithCompletionTable_peek_query_bind] + exact ih (state.values coordinate) state fuel + | publish coordinate => + simp_rw [runCleanFromTable_publish_query_bind] + rw [runRawCleanWithCompletionTable_publish_query_bind] + simpa using ih () (state.publish coordinate) fuel + | reveal coordinate => + simp_rw [runCleanFromTable_reveal_query_bind] + rw [runRawCleanWithCompletionTable_reveal_query_bind] + cases hvalue : state.values coordinate with + | some output => + exact ih output state fuel + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + calc + _ = 𝒟[do + let output ← LazyRevealProbe.sampleHashOutput + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + if state.hitAt index.coordinate output then + pure none + else + runCleanFromTable (state.materialize index.coordinate output) fuel + (completedStartTable + (state.materialize index.coordinate output) base) + (next output)] := by + simpa [index, OtsSecretIndex.coordinate, runCleanFromTable, hvalue, + completedStartTable, LazyRevealProbe.State.materialize] using + evalDist_materialize_missing_start_clean_cont + state index hvalue (fun nextState table => + runCleanFromTable nextState fuel table (next (table index))) + _ = _ := by + simp only [index, OtsSecretIndex.coordinate] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + by_cases hhit : state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp only [hhit, ↓reduceIte] + exact OracleComp.DeferredSampling.evalDist_bind_const_neverFails + ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + (by simp) (pure none) + · simp only [hhit, ↓reduceIte] + exact ih output (state.materialize + (.chainStart lay tree leafIdx chainIdx) output) fuel + | position position => + let coordinate : Coordinate := .position position + let tableSample := ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + let outputSample := LazyRevealProbe.sampleHashOutput + calc + _ = 𝒟[tableSample >>= fun base => outputSample >>= fun output => + if state.hitAt coordinate output then + pure none + else + runCleanFromTable (state.materialize coordinate output) fuel + (completedStartTable state base) (next output)] := by + apply congrArg evalDist + simp [runCleanFromTable, coordinate, tableSample, outputSample] + _ = 𝒟[outputSample >>= fun output => tableSample >>= fun base => + if state.hitAt coordinate output then + pure none + else + runCleanFromTable (state.materialize coordinate output) fuel + (completedStartTable state base) (next output)] := + OracleComp.DeferredSampling.evalDist_bind_comm tableSample outputSample _ + _ = _ := by + simp only [coordinate] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + by_cases hhit : state.hitAt (.position position) output + · simp only [hhit, ↓reduceIte] + exact OracleComp.DeferredSampling.evalDist_bind_const_neverFails + tableSample (by simp [tableSample]) (pure none) + · simp only [hhit, ↓reduceIte] + have hleft : + (tableSample >>= fun base => + runCleanFromTable + (state.materialize (.position position) output) fuel + (completedStartTable state base) (next output)) = + (tableSample >>= fun base => + runCleanFromTable + (state.materialize (.position position) output) fuel + (completedStartTable + (state.materialize (.position position) output) base) + (next output)) := by + apply bind_congr + intro base + rw [completedStartTable_materialize_position] + rw [congrArg evalDist hleft] + exact ih output (state.materialize (.position position) output) fuel + +theorem runCleanFromTable_bind + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) + (left : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (next : alpha → OracleComp (LazyRevealProbe.World Coordinate) beta) : + runCleanFromTable state fuel table (left >>= next) = + runCleanFromTable state fuel table left >>= fun result => + match result with + | none => pure none + | some result => + runCleanFromTable result.state result.remaining result.table + (next result.value) := by + induction left using OracleComp.inductionOn generalizing state fuel with + | pure value => simp [runCleanFromTable] + | query_bind input continuation ih => + cases input with + | uniform n => + rw [bind_assoc, runCleanFromTable_uniform_query_bind, + runCleanFromTable_uniform_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output state fuel + | hashOutput => + rw [bind_assoc, runCleanFromTable_hashOutput_query_bind, + runCleanFromTable_hashOutput_query_bind] + simp only [bind_assoc] + apply bind_congr + intro output + exact ih output state fuel + | ensure coordinate => + rw [bind_assoc, runCleanFromTable_ensure_query_bind, + runCleanFromTable_ensure_query_bind] + exact ih () (state.ensure coordinate) fuel + | probe coordinate candidate => + rw [bind_assoc, runCleanFromTable_probe_query_bind, + runCleanFromTable_probe_query_bind] + cases fuel with + | zero => simp + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] + exact ih () state remaining + · simp only [hrevealed, ↓reduceIte] + exact ih () (state.addPending coordinate candidate) remaining + | peek coordinate => + rw [bind_assoc, runCleanFromTable_peek_query_bind, + runCleanFromTable_peek_query_bind] + exact ih (state.values coordinate) state fuel + | publish coordinate => + rw [bind_assoc, runCleanFromTable_publish_query_bind, + runCleanFromTable_publish_query_bind] + exact ih () (state.publish coordinate) fuel + | reveal coordinate => + rw [bind_assoc, runCleanFromTable_reveal_query_bind, + runCleanFromTable_reveal_query_bind] + cases hvalue : state.values coordinate with + | some output => exact ih output state fuel + | none => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : state.hitAt + (.chainStart lay tree leafIdx chainIdx) output + · simp [output, hhit] + · simp only [output, hhit, ↓reduceIte] + exact ih output + (state.materialize (.chainStart lay tree leafIdx chainIdx) output) fuel + | position position => + simp only [bind_assoc] + apply bind_congr + intro output + by_cases hhit : state.hitAt (.position position) output + · simp [hhit] + · simp only [hhit, ↓reduceIte] + exact ih output (state.materialize (.position position) output) fuel + +def projectCleanOrdinary : + Option (CleanRunResult (alpha × SplitHashCache)) → + Option (alpha × QueryCache HashSpec) + | none => none + | some result => some (result.value.1, ordinaryQueryCache result.value.2) + +def CleanOrdinaryStepRel : + Option (CleanRunResult (alpha × SplitHashCache)) → + (alpha × QueryCache HashSpec) → Prop := + fun cleanResult ordinaryResult => cleanResult = none ∨ + projectCleanOrdinary cleanResult = some ordinaryResult + +theorem relTriple_runCleanFromTable_StateT_bind + (left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta) + (ordinaryLeft : StateT (QueryCache HashSpec) ProbComp alpha) + (ordinaryNext : alpha → StateT (QueryCache HashSpec) ProbComp beta) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (ordinaryCache : QueryCache HashSpec) + (hleft : RelTriple + (runCleanFromTable state fuel table (left.run cache)) + (ordinaryLeft.run ordinaryCache) CleanOrdinaryStepRel) + (hnext : ∀ result ordinaryResult, + projectCleanOrdinary (some result) = some ordinaryResult → + RelTriple + (runCleanFromTable result.state result.remaining result.table + ((next result.value.1).run result.value.2)) + ((ordinaryNext ordinaryResult.1).run ordinaryResult.2) + CleanOrdinaryStepRel) : + RelTriple + (runCleanFromTable state fuel table ((left >>= next).run cache)) + ((ordinaryLeft >>= ordinaryNext).run ordinaryCache) + CleanOrdinaryStepRel := by + rw [StateT.run_bind, StateT.run_bind, runCleanFromTable_bind] + apply relTriple_bind hleft + intro leftResult rightResult hrelation + rcases hrelation with hstopped | hproject + · subst leftResult + have hbase := relTriple_true + (pure none : ProbComp (Option (CleanRunResult (beta × SplitHashCache)))) + ((ordinaryNext rightResult.1).run rightResult.2) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result = none) (by + intro result hresult + simpa using hresult) + exact relTriple_post_mono hsupported fun _ _ h => Or.inl h.2 + · cases leftResult with + | none => simp [projectCleanOrdinary] at hproject + | some result => exact hnext result rightResult hproject + +def StartTableAgrees (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) : Prop := + ∀ index output, state.values index.coordinate = some output → output = table index + +theorem startTableAgrees_empty (table : OtsSecretIndex → HashOutput) : + StartTableAgrees (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) table := by + intro index output hvalue + simp [LazyRevealProbe.State.empty] at hvalue + +theorem StartTableAgrees.lookup + {state : LazyRevealProbe.State Coordinate} + {table : OtsSecretIndex → HashOutput} (hagrees : StartTableAgrees state table) + (index : OtsSecretIndex) : + state.values index.coordinate = none ∨ + state.values index.coordinate = some (table index) := by + cases hvalue : state.values index.coordinate with + | none => exact Or.inl rfl + | some output => exact Or.inr (congrArg some (hagrees index output hvalue)) + +theorem StartTableAgrees.ensure + {state : LazyRevealProbe.State Coordinate} + {table : OtsSecretIndex → HashOutput} (hagrees : StartTableAgrees state table) + (coordinate : Coordinate) : StartTableAgrees (state.ensure coordinate) table := by + exact hagrees + +theorem StartTableAgrees.addPending + {state : LazyRevealProbe.State Coordinate} + {table : OtsSecretIndex → HashOutput} (hagrees : StartTableAgrees state table) + (coordinate : Coordinate) (candidate : Digest) : + StartTableAgrees (state.addPending coordinate candidate) table := by + exact hagrees + +theorem StartTableAgrees.publish + {state : LazyRevealProbe.State Coordinate} + {table : OtsSecretIndex → HashOutput} (hagrees : StartTableAgrees state table) + (coordinate : Coordinate) : StartTableAgrees (state.publish coordinate) table := by + exact hagrees + +theorem StartTableAgrees.materialize_start + {state : LazyRevealProbe.State Coordinate} + {table : OtsSecretIndex → HashOutput} (hagrees : StartTableAgrees state table) + (index : OtsSecretIndex) : + StartTableAgrees (state.materialize index.coordinate (table index)) table := by + intro other output hvalue + by_cases heq : other = index + · subst other + simpa [LazyRevealProbe.State.materialize] using hvalue.symm + · have hcoordinate : other.coordinate ≠ index.coordinate := + fun h => heq (OtsSecretIndex.coordinate_injective h) + apply hagrees other output + simpa [LazyRevealProbe.State.materialize, hcoordinate] using hvalue + +theorem StartTableAgrees.materialize_position + {state : LazyRevealProbe.State Coordinate} + {table : OtsSecretIndex → HashOutput} (hagrees : StartTableAgrees state table) + (position : Position) (output : HashOutput) : + StartTableAgrees (state.materialize (.position position) output) table := by + intro index cached hvalue + apply hagrees index cached + simpa [LazyRevealProbe.State.materialize, OtsSecretIndex.coordinate] using hvalue + +theorem StartTableAgrees.complete_start + {state : LazyRevealProbe.State Coordinate} + {table : OtsSecretIndex → HashOutput} (hagrees : StartTableAgrees state table) + (index : OtsSecretIndex) : + StartTableAgrees (state.complete index.coordinate (table index)) table := by + intro other output hvalue + by_cases heq : other = index + · subst other + simpa [LazyRevealProbe.State.complete] using hvalue.symm + · have hcoordinate : other.coordinate ≠ index.coordinate := + fun h => heq (OtsSecretIndex.coordinate_injective h) + apply hagrees other output + simpa [LazyRevealProbe.State.complete, hcoordinate] using hvalue + +theorem StartTableAgrees.complete_position + {state : LazyRevealProbe.State Coordinate} + {table : OtsSecretIndex → HashOutput} (hagrees : StartTableAgrees state table) + (position : Position) (output : HashOutput) : + StartTableAgrees (state.complete (.position position) output) table := by + intro index cached hvalue + apply hagrees index cached + simpa [LazyRevealProbe.State.complete, OtsSecretIndex.coordinate] using hvalue + +theorem StartTableAgrees.clearPending + {state : LazyRevealProbe.State Coordinate} + {table : OtsSecretIndex → HashOutput} (hagrees : StartTableAgrees state table) + (coordinate : Coordinate) : StartTableAgrees (state.clearPending coordinate) table := by + exact hagrees + +theorem startTableAgrees_of_mem_runCleanFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (hagrees : StartTableAgrees state table) + (result : CleanRunResult alpha) + (hresult : some result ∈ support + (runCleanFromTable state fuel table computation)) : + result.table = table ∧ StartTableAgrees result.state table := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + simp [runCleanFromTable] at hresult + subst result + exact ⟨rfl, hagrees⟩ + | query_bind input next ih => + cases input with + | uniform n => + rw [runCleanFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output state fuel hagrees hrest + | hashOutput => + rw [runCleanFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + exact ih output state fuel hagrees hrest + | ensure coordinate => + rw [runCleanFromTable_ensure_query_bind] at hresult + exact ih () (state.ensure coordinate) fuel (hagrees.ensure coordinate) hresult + | probe coordinate candidate => + rw [runCleanFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · exact ih () state remaining hagrees (by simpa [hrevealed] using hresult) + · exact ih () (state.addPending coordinate candidate) remaining + (hagrees.addPending coordinate candidate) (by simpa [hrevealed] using hresult) + | peek coordinate => + rw [runCleanFromTable_peek_query_bind] at hresult + exact ih (state.values coordinate) state fuel hagrees hresult + | publish coordinate => + rw [runCleanFromTable_publish_query_bind] at hresult + exact ih () (state.publish coordinate) fuel (hagrees.publish coordinate) hresult + | reveal coordinate => + rw [runCleanFromTable_reveal_query_bind] at hresult + cases hvalue : state.values coordinate with + | some output => + rw [hvalue] at hresult + exact ih output state fuel hagrees hresult + | none => + rw [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + simp only at hresult + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + by_cases hhit : state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) + · rw [if_pos hhit] at hresult + simp at hresult + · rw [if_neg hhit] at hresult + exact ih (table index) + (state.materialize (.chainStart lay tree leafIdx chainIdx) (table index)) + fuel (by simpa [index, OtsSecretIndex.coordinate] using + hagrees.materialize_start index) (by simpa [index] using hresult) + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : state.hitAt (.position position) output + · simp [hhit] at hrest + · exact ih output (state.materialize (.position position) output) fuel + (hagrees.materialize_position position output) + (by simpa [hhit] using hrest) + +theorem projectCleanOrdinary_splitHashQuery + (input : HashInput) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + projectCleanOrdinary <$> + runCleanFromTable state fuel table ((splitHashQuery (.ordinary input)).run cache) = + some <$> + (randomOracle (spec := HashSpec) input).run (ordinaryQueryCache cache) := by + rw [splitHashQuery_run_eq] + cases hlookup : cache (.ordinary input) with + | some output => + simp only + have hordinary : ordinaryQueryCache cache input = some output := hlookup + rw [QueryImpl.withCaching_run_some uniformSampleImpl hordinary] + simp [runCleanFromTable, projectCleanOrdinary] + | none => + simp only + have hordinary : ordinaryQueryCache cache input = none := hlookup + rw [QueryImpl.withCaching_run_none uniformSampleImpl hordinary] + rw [LazyRevealProbe.hashOutputQuery, runCleanFromTable_hashOutput_query_bind] + simp only [map_bind, Functor.map_map] + change (LazyRevealProbe.sampleHashOutput >>= fun output => + projectCleanOrdinary <$> + runCleanFromTable state fuel table + (pure (output, + Function.update cache (.ordinary input) (some output)))) = + (fun output => some + (output, (ordinaryQueryCache cache).cacheQuery input output)) <$> + LazyRevealProbe.sampleHashOutput + rw [map_eq_bind_pure_comp] + apply bind_congr + intro output + simp [runCleanFromTable, projectCleanOrdinary, ordinaryQueryCache_update] + +theorem runCleanFromTable_pure_StateT + (value : alpha) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + runCleanFromTable state fuel table + ((pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha).run cache) = + pure (some ⟨state, fuel, (value, cache), table⟩) := by + simp [runCleanFromTable] + +theorem runCleanFromTable_ensureCoordinate + (coordinate : Coordinate) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + runCleanFromTable state fuel table ((ensureCoordinate coordinate).run cache) = + pure (some ⟨state.ensure coordinate, fuel, ((), cache), table⟩) := by + unfold ensureCoordinate + rw [StateT.run_liftM, LazyRevealProbe.ensureQuery, + runCleanFromTable_ensure_query_bind] + simp [runCleanFromTable] + +theorem runCleanFromTable_publishCoordinate + (coordinate : Coordinate) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + runCleanFromTable state fuel table ((publishCoordinate coordinate).run cache) = + pure (some ⟨state.publish coordinate, fuel, ((), cache), table⟩) := by + unfold publishCoordinate + rw [StateT.run_liftM, LazyRevealProbe.publishQuery, + runCleanFromTable_publish_query_bind] + simp [runCleanFromTable] + +def CleanAdministrative + (computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (value : alpha) : Prop := + ∀ state cache fuel table, ∃ finalState, + runCleanFromTable state fuel table (computation.run cache) = + pure (some ⟨finalState, fuel, (value, cache), table⟩) + +theorem cleanAdministrative_pure (value : alpha) : + CleanAdministrative + (pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + value := by + intro state cache fuel table + exact ⟨state, runCleanFromTable_pure_StateT value state cache fuel table⟩ + +theorem CleanAdministrative.bind + {left : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {next : alpha → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) beta} + {leftValue : alpha} {value : beta} + (hleft : CleanAdministrative left leftValue) + (hnext : CleanAdministrative (next leftValue) value) : + CleanAdministrative (left >>= next) value := by + intro state cache fuel table + obtain ⟨middleState, hleftRun⟩ := hleft state cache fuel table + obtain ⟨finalState, hnextRun⟩ := hnext middleState cache fuel table + refine ⟨finalState, ?_⟩ + rw [StateT.run_bind, runCleanFromTable_bind, hleftRun] + simpa using hnextRun + +theorem cleanAdministrative_ensureCoordinate (coordinate : Coordinate) : + CleanAdministrative (ensureCoordinate coordinate) () := by + intro state cache fuel table + exact ⟨state.ensure coordinate, + runCleanFromTable_ensureCoordinate coordinate state cache fuel table⟩ + +theorem cleanAdministrative_publishCoordinate (coordinate : Coordinate) : + CleanAdministrative (publishCoordinate coordinate) () := by + intro state cache fuel table + exact ⟨state.publish coordinate, + runCleanFromTable_publishCoordinate coordinate state cache fuel table⟩ + +theorem cleanAdministrative_sequenceFin {n : Nat} + (computation : Fin n → StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha) + (value : Fin n → alpha) + (hcomponent : ∀ index, CleanAdministrative (computation index) (value index)) : + CleanAdministrative (sequenceFin computation) value := by + induction n with + | zero => + have hvalue : value = Fin.elim0 := Subsingleton.elim _ _ + subst value + simpa [sequenceFin] using + (cleanAdministrative_pure (value := Fin.elim0) : + CleanAdministrative (pure Fin.elim0) Fin.elim0) + | succ n ih => + rw [sequenceFin] + have htail := ih (fun index : Fin n => computation index.succ) + (fun index : Fin n => value index.succ) (fun index => hcomponent index.succ) + let assembled : Fin (n + 1) → alpha := + Fin.cases (value 0) (fun index : Fin n => value index.succ) + have hpure : CleanAdministrative + (pure assembled : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Fin (n + 1) → alpha)) + assembled := cleanAdministrative_pure assembled + have hrest : CleanAdministrative + (sequenceFin (fun index : Fin n => computation index.succ) >>= fun tail => + pure (Fin.cases (value 0) tail)) assembled := by + exact htail.bind hpure + have hhead : CleanAdministrative + (computation 0 >>= fun head => + sequenceFin (fun index : Fin n => computation index.succ) >>= fun tail => + pure (Fin.cases head tail)) assembled := by + exact (hcomponent 0).bind hrest + have hassembled : assembled = value := by + funext index + cases index using Fin.cases <;> rfl + simpa only [hassembled] using hhead + +theorem cleanAdministrative_ensureFullChain + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + CleanAdministrative (ensureFullChain lay tree leafIdx chainIdx) () := by + unfold ensureFullChain + apply CleanAdministrative.bind + (cleanAdministrative_sequenceFin + (fun step : ChainStep => + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step))) + (fun _ => ()) + (fun step => cleanAdministrative_ensureCoordinate + (.position (.chain lay tree leafIdx chainIdx step)))) + exact cleanAdministrative_pure () + +theorem cleanAdministrative_ensureChainPrefix + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (digit : Digit) : + CleanAdministrative (ensureChainPrefix lay tree leafIdx chainIdx digit) () := by + unfold ensureChainPrefix + apply CleanAdministrative.bind + (cleanAdministrative_sequenceFin + (fun step : ChainStep => + if step.val < digit.val then + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + else pure ()) + (fun _ => ()) (fun step => by + by_cases hstep : step.val < digit.val + · rw [if_pos hstep] + exact cleanAdministrative_ensureCoordinate + (.position (.chain lay tree leafIdx chainIdx step)) + · rw [if_neg hstep] + exact cleanAdministrative_pure ())) + exact cleanAdministrative_pure () + +theorem cleanAdministrative_ensureOtsLeaf + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + CleanAdministrative (ensureOtsLeaf lay tree leafIdx) () := by + unfold ensureOtsLeaf + have hchains := cleanAdministrative_sequenceFin + (fun chainIdx : ChainIndex => ensureFullChain lay tree leafIdx chainIdx) + (fun _ => ()) (fun chainIdx => + cleanAdministrative_ensureFullChain lay tree leafIdx chainIdx) + exact hchains.bind + (cleanAdministrative_ensureCoordinate (.position (.leaf lay tree leafIdx))) + +theorem cleanAdministrative_ensureTreeNode (lay : Layer) (tree : TreeIndex) : + ∀ level nodeIdx, CleanAdministrative (ensureTreeNode lay tree level nodeIdx) () + | 0, nodeIdx => cleanAdministrative_ensureOtsLeaf lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + apply CleanAdministrative.bind + (cleanAdministrative_ensureTreeNode lay tree level (2 * nodeIdx)) + apply CleanAdministrative.bind + (cleanAdministrative_ensureTreeNode lay tree level (2 * nodeIdx + 1)) + by_cases hlevel : level < maxLayerHeight + · rw [dif_pos hlevel] + exact cleanAdministrative_ensureCoordinate + (.position (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + · rw [dif_neg hlevel] + exact cleanAdministrative_pure () + +theorem cleanAdministrative_ensureTreePath + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + CleanAdministrative (ensureTreePath lay tree leafIdx) () := by + unfold ensureTreePath + apply CleanAdministrative.bind + (cleanAdministrative_sequenceFin + (fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + ensureTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + else pure ()) + (fun _ => ()) (fun level => by + by_cases hlevel : level.val < layerHeight lay + · rw [if_pos hlevel] + exact cleanAdministrative_ensureTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + · rw [if_neg hlevel] + exact cleanAdministrative_pure ())) + exact cleanAdministrative_pure () + +theorem CleanAdministrative.project + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {value : alpha} (hadministrative : CleanAdministrative computation value) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + projectCleanOrdinary <$> + runCleanFromTable state fuel table (computation.run cache) = + pure (some (value, ordinaryQueryCache cache)) := by + obtain ⟨finalState, hrun⟩ := hadministrative state cache fuel table + rw [hrun] + simp [projectCleanOrdinary] + +theorem CleanAdministrative.run_agrees + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {value : alpha} (hadministrative : CleanAdministrative computation value) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hagrees : StartTableAgrees state table) : + ∃ finalState, + runCleanFromTable state fuel table (computation.run cache) = + pure (some ⟨finalState, fuel, (value, cache), table⟩) ∧ + StartTableAgrees finalState table := by + obtain ⟨finalState, hrun⟩ := hadministrative state cache fuel table + refine ⟨finalState, hrun, ?_⟩ + have hmem : some ⟨finalState, fuel, (value, cache), table⟩ ∈ support + (runCleanFromTable state fuel table (computation.run cache)) := by + rw [hrun] + simp + exact (startTableAgrees_of_mem_runCleanFromTable + (computation.run cache) state fuel table hagrees + ⟨finalState, fuel, (value, cache), table⟩ hmem).2 + +theorem CleanAdministrative.relTriple + {computation : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) alpha} + {value : alpha} [Inhabited alpha] + (hadministrative : CleanAdministrative computation value) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + RelTriple + (runCleanFromTable state fuel table (computation.run cache)) + (pure (value, ordinaryQueryCache cache) : + ProbComp (alpha × QueryCache HashSpec)) + fun cleanResult ordinaryResult => + projectCleanOrdinary cleanResult = some ordinaryResult := by + exact SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_of_project_eq_some_exact + projectCleanOrdinary (default, ∅) + (runCleanFromTable state fuel table (computation.run cache)) + (pure (value, ordinaryQueryCache cache) : ProbComp (alpha × QueryCache HashSpec)) + (hadministrative.project state cache fuel table) + +theorem projectCleanOrdinary_ensureCoordinate + (coordinate : Coordinate) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + projectCleanOrdinary <$> + runCleanFromTable state fuel table ((ensureCoordinate coordinate).run cache) = + pure (some ((), ordinaryQueryCache cache)) := by + rw [runCleanFromTable_ensureCoordinate] + simp [projectCleanOrdinary] + +theorem relTriple_runCleanFromTable_ensureCoordinate + (coordinate : Coordinate) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + RelTriple + (runCleanFromTable state fuel table ((ensureCoordinate coordinate).run cache)) + (pure ((), ordinaryQueryCache cache) : + ProbComp (Unit × QueryCache HashSpec)) + fun cleanResult ordinaryResult => + projectCleanOrdinary cleanResult = some ordinaryResult := by + exact SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_of_project_eq_some_exact + projectCleanOrdinary ((), ∅) + (runCleanFromTable state fuel table ((ensureCoordinate coordinate).run cache)) + (pure ((), ordinaryQueryCache cache) : ProbComp (Unit × QueryCache HashSpec)) + (projectCleanOrdinary_ensureCoordinate coordinate state cache fuel table) + +theorem runCleanFromTable_revealCoordinate_of_value + (coordinate : Coordinate) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalue : state.values coordinate = some output) : + runCleanFromTable state fuel table ((revealCoordinate coordinate).run cache) = + pure (some ⟨state, fuel, + (truncateHash output, + Function.update cache (.hidden coordinate) (some output)), table⟩) := by + rw [revealCoordinate_run, LazyRevealProbe.revealQuery, + runCleanFromTable_reveal_query_bind, hvalue] + simp [runCleanFromTable] + +theorem projectCleanOrdinary_revealCoordinate_of_value + (coordinate : Coordinate) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalue : state.values coordinate = some output) : + projectCleanOrdinary <$> + runCleanFromTable state fuel table ((revealCoordinate coordinate).run cache) = + pure (some (truncateHash output, ordinaryQueryCache cache)) := by + rw [runCleanFromTable_revealCoordinate_of_value coordinate output state cache fuel table + hvalue] + simp [projectCleanOrdinary, ordinaryQueryCache_update_hidden] + +theorem relTriple_runCleanFromTable_revealCoordinate_of_value + (coordinate : Coordinate) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalue : state.values coordinate = some output) : + RelTriple + (runCleanFromTable state fuel table ((revealCoordinate coordinate).run cache)) + (pure (truncateHash output, ordinaryQueryCache cache) : + ProbComp (Digest × QueryCache HashSpec)) + fun cleanResult ordinaryResult => + projectCleanOrdinary cleanResult = some ordinaryResult := by + exact SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_of_project_eq_some_exact + projectCleanOrdinary (0, ∅) + (runCleanFromTable state fuel table ((revealCoordinate coordinate).run cache)) + (pure (truncateHash output, ordinaryQueryCache cache) : + ProbComp (Digest × QueryCache HashSpec)) + (projectCleanOrdinary_revealCoordinate_of_value coordinate output state cache fuel table + hvalue) + +theorem runCleanFromTable_revealPublishedCoordinate_of_value + (coordinate : Coordinate) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalue : state.values coordinate = some output) : + runCleanFromTable state fuel table + ((revealPublishedCoordinate coordinate).run cache) = + pure (some ⟨state.publish coordinate, fuel, + (truncateHash output, + Function.update cache (.hidden coordinate) (some output)), table⟩) := by + unfold revealPublishedCoordinate + rw [StateT.run_bind, runCleanFromTable_bind, + runCleanFromTable_revealCoordinate_of_value coordinate output state cache fuel table hvalue] + simp only [pure_bind] + rw [StateT.run_bind, runCleanFromTable_bind, + runCleanFromTable_publishCoordinate] + simp [runCleanFromTable] + +theorem projectCleanOrdinary_revealPublishedCoordinate_of_value + (coordinate : Coordinate) (output : HashOutput) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hvalue : state.values coordinate = some output) : + projectCleanOrdinary <$> + runCleanFromTable state fuel table + ((revealPublishedCoordinate coordinate).run cache) = + pure (some (truncateHash output, ordinaryQueryCache cache)) := by + rw [runCleanFromTable_revealPublishedCoordinate_of_value coordinate output state cache fuel + table hvalue] + simp [projectCleanOrdinary, ordinaryQueryCache_update_hidden] + +set_option maxRecDepth 10000 in +theorem projectCleanOrdinary_simulateQ_ordinaryHashImpl + (computation : OracleComp HashSpec alpha) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + projectCleanOrdinary <$> + runCleanFromTable state fuel table + ((simulateQ ordinaryHashImpl computation).run cache) = + some <$> + (simulateQ (randomOracle : QueryImpl HashSpec _) computation).run + (ordinaryQueryCache cache) := by + induction computation using OracleComp.inductionOn generalizing state cache fuel with + | pure value => + simp [runCleanFromTable, projectCleanOrdinary] + | query_bind input next ih => + simp only [simulateQ_bind, simulateQ_query, OracleQuery.cont_query, id_map, + OracleQuery.input_query, StateT.run_bind, runCleanFromTable_bind] + rw [show ordinaryHashImpl input = splitHashQuery (.ordinary input) by rfl] + rw [splitHashQuery_run_eq] + cases hlookup : cache (.ordinary input) with + | some output => + simp only + have hordinary : ordinaryQueryCache cache input = some output := hlookup + rw [QueryImpl.withCaching_run_some uniformSampleImpl hordinary] + simp only [runCleanFromTable, pure_bind] + exact ih output state cache fuel + | none => + simp only + have hordinary : ordinaryQueryCache cache input = none := hlookup + rw [QueryImpl.withCaching_run_none uniformSampleImpl hordinary] + rw [LazyRevealProbe.hashOutputQuery, runCleanFromTable_hashOutput_query_bind] + simp only [map_bind, bind_assoc] + change (LazyRevealProbe.sampleHashOutput >>= fun output => + projectCleanOrdinary <$> + runCleanFromTable state fuel table + ((simulateQ ordinaryHashImpl (next output)).run + (Function.update cache (.ordinary input) (some output)))) = + (LazyRevealProbe.sampleHashOutput >>= fun output => + some <$> + (simulateQ (randomOracle : QueryImpl HashSpec _) (next output)).run + ((ordinaryQueryCache cache).cacheQuery input output)) + apply bind_congr + intro output + rw [← ordinaryQueryCache_update] + exact ih output state (Function.update cache (.ordinary input) (some output)) fuel + +theorem relTriple_runCleanFromTable_simulateQ_ordinaryHashImpl + [Inhabited alpha] (computation : OracleComp HashSpec alpha) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + RelTriple + (runCleanFromTable state fuel table + ((simulateQ ordinaryHashImpl computation).run cache)) + ((simulateQ (randomOracle : QueryImpl HashSpec _) computation).run + (ordinaryQueryCache cache)) + fun cleanResult ordinaryResult => + projectCleanOrdinary cleanResult = some ordinaryResult := by + exact SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_of_project_eq_some_exact + projectCleanOrdinary (default, ∅) + (runCleanFromTable state fuel table + ((simulateQ ordinaryHashImpl computation).run cache)) + ((simulateQ (randomOracle : QueryImpl HashSpec _) computation).run + (ordinaryQueryCache cache)) + (projectCleanOrdinary_simulateQ_ordinaryHashImpl computation state cache fuel table) + +theorem projectCleanOrdinary_revealChainStart + (index : OtsSecretIndex) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hagrees : state.values index.coordinate = none ∨ + state.values index.coordinate = some (table index)) + (hclean : ¬state.hitAt index.coordinate (table index)) : + projectCleanOrdinary <$> + runCleanFromTable state fuel table + ((revealChainStart index.lay index.tree index.leafIdx index.chainIdx).run cache) = + pure (some (truncateHash (table index), ordinaryQueryCache cache)) := by + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + simp only [OtsSecretIndex.coordinate] at hagrees hclean ⊢ + rw [revealChainStart, revealCoordinate_run, LazyRevealProbe.revealQuery, + runCleanFromTable_reveal_query_bind] + rcases hagrees with hmissing | hvalue + · rw [hmissing] + simp [hclean, runCleanFromTable, projectCleanOrdinary, + ordinaryQueryCache_update_hidden] + · rw [hvalue] + simp [runCleanFromTable, projectCleanOrdinary, ordinaryQueryCache_update_hidden] + +theorem relTriple_runCleanFromTable_revealChainStart + (index : OtsSecretIndex) (state : LazyRevealProbe.State Coordinate) + (cache : SplitHashCache) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hagrees : state.values index.coordinate = none ∨ + state.values index.coordinate = some (table index)) : + RelTriple + (runCleanFromTable state fuel table + ((revealChainStart index.lay index.tree index.leafIdx index.chainIdx).run cache)) + (pure (truncateHash (table index), ordinaryQueryCache cache) : + ProbComp (Digest × QueryCache HashSpec)) + CleanOrdinaryStepRel := by + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + simp only [OtsSecretIndex.coordinate] at hagrees ⊢ + rw [revealChainStart, revealCoordinate_run, LazyRevealProbe.revealQuery, + runCleanFromTable_reveal_query_bind] + rcases hagrees with hmissing | hvalue + · rw [hmissing] + by_cases hhit : state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) + · simp [hhit, CleanOrdinaryStepRel] + · simp [hhit, runCleanFromTable, CleanOrdinaryStepRel, projectCleanOrdinary, + ordinaryQueryCache_update_hidden] + · rw [hvalue] + simp [runCleanFromTable, CleanOrdinaryStepRel, projectCleanOrdinary, + ordinaryQueryCache_update_hidden] + +theorem relTriple_runCleanFromTable_maskedChainValue_zero + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) (hdigit : digit.val = 0) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hagrees : StartTableAgrees state table) : + RelTriple + (runCleanFromTable state fuel table + ((maskedChainValue lay tree leafIdx chainIdx digit).run cache)) + (pure (truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), + ordinaryQueryCache cache) : ProbComp (Digest × QueryCache HashSpec)) + CleanOrdinaryStepRel := by + obtain ⟨reservedState, hreserve, hreservedAgrees⟩ := + (cleanAdministrative_ensureChainPrefix lay tree leafIdx chainIdx digit).run_agrees + state cache fuel table hagrees + unfold maskedChainValue + rw [StateT.run_bind, runCleanFromTable_bind, hreserve] + simp only [pure_bind] + rw [dif_pos hdigit] + exact relTriple_runCleanFromTable_revealChainStart + ⟨lay, tree, leafIdx, chainIdx⟩ reservedState cache fuel table + (hreservedAgrees.lookup ⟨lay, tree, leafIdx, chainIdx⟩) + +theorem relTriple_runCleanFromTable_revealChainStart_then_ordinary + [Inhabited alpha] (index : OtsSecretIndex) + (next : Digest → OracleComp HashSpec alpha) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) + (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hagrees : StartTableAgrees state table) : + RelTriple + (runCleanFromTable state fuel table + (((revealChainStart index.lay index.tree index.leafIdx index.chainIdx) >>= fun value => + simulateQ ordinaryHashImpl (next value)).run cache)) + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (next (truncateHash (table index)))).run (ordinaryQueryCache cache)) + CleanOrdinaryStepRel := by + let maskedNext := fun value : Digest => simulateQ ordinaryHashImpl (next value) + let ordinaryNext := fun value : Digest => + simulateQ (randomOracle : QueryImpl HashSpec _) (next value) + have hleft := relTriple_runCleanFromTable_revealChainStart index state cache fuel table + (hagrees.lookup index) + have hbind := relTriple_runCleanFromTable_StateT_bind + (revealChainStart index.lay index.tree index.leafIdx index.chainIdx) + maskedNext (pure (truncateHash (table index))) ordinaryNext state fuel table cache + (ordinaryQueryCache cache) hleft + (fun result ordinaryResult hproject => by + rcases result with ⟨finalState, remaining, ⟨value, finalCache⟩, finalTable⟩ + have hresult : (value, ordinaryQueryCache finalCache) = ordinaryResult := + Option.some.inj hproject + subst ordinaryResult + apply relTriple_post_mono + (relTriple_runCleanFromTable_simulateQ_ordinaryHashImpl (next value) + finalState finalCache remaining finalTable) + exact fun _ _ h => Or.inr h) + simpa [maskedNext, ordinaryNext] using hbind + +noncomputable def finishCleanRunFromTable : + Option (CleanRunResult alpha) → ProbComp (Option (CleanRunResult alpha)) + | none => pure none + | some result => do + let finalized ← finalizeCleanFromTable result.state.coordinates.toList + result.state result.table + match finalized with + | none => pure none + | some (finalState, finalTable) => + pure (some ⟨finalState, result.remaining, result.value, finalTable⟩) + +theorem startTableAgrees_of_mem_finalizeCleanFromTable + (coordinates : List Coordinate) (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (hagrees : StartTableAgrees state table) + (finalState : LazyRevealProbe.State Coordinate) + (finalTable : OtsSecretIndex → HashOutput) + (hresult : some (finalState, finalTable) ∈ support + (finalizeCleanFromTable coordinates state table)) : + finalTable = table ∧ StartTableAgrees finalState table := by + induction coordinates generalizing state with + | nil => + simp [finalizeCleanFromTable] at hresult + obtain ⟨rfl, rfl⟩ := hresult + exact ⟨rfl, hagrees⟩ + | cons coordinate remaining ih => + cases hvalue : state.values coordinate with + | some output => + rw [finalizeCleanFromTable.eq_def] at hresult + simp only at hresult + rw [hvalue] at hresult + exact ih (state.clearPending coordinate) (hagrees.clearPending coordinate) hresult + | none => + rw [finalizeCleanFromTable.eq_def] at hresult + simp only at hresult + rw [hvalue] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + let index : OtsSecretIndex := ⟨lay, tree, leafIdx, chainIdx⟩ + simp only at hresult + by_cases hhit : state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) + · rw [if_pos hhit] at hresult + simp at hresult + · rw [if_neg hhit] at hresult + exact ih + (state.complete (.chainStart lay tree leafIdx chainIdx) (table index)) + (by simpa [index, OtsSecretIndex.coordinate] using + hagrees.complete_start index) + (by simpa [index] using hresult) + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hrest⟩ := hresult + by_cases hhit : state.hitAt (.position position) output + · simp [hhit] at hrest + · exact ih (state.complete (.position position) output) + (hagrees.complete_position position output) (by simpa [hhit] using hrest) + +theorem startTableAgrees_of_mem_finishCleanRunFromTable + (result finalResult : CleanRunResult alpha) + (hagrees : StartTableAgrees result.state result.table) + (hresult : some finalResult ∈ support + (finishCleanRunFromTable (some result))) : + finalResult.table = result.table ∧ StartTableAgrees finalResult.state result.table := by + unfold finishCleanRunFromTable at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨finalized, hfinalized, hreturn⟩ := hresult + cases finalized with + | none => simp at hreturn + | some value => + rcases value with ⟨finalState, finalTable⟩ + simp only [support_pure, Set.mem_singleton_iff, Option.some.injEq] at hreturn + obtain ⟨rfl, rfl, rfl, rfl⟩ := hreturn + exact startTableAgrees_of_mem_finalizeCleanFromTable result.state.coordinates.toList + result.state result.table hagrees finalState finalTable hfinalized + +theorem startTableAgrees_of_mem_runThenFinalizeCleanFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (hagrees : StartTableAgrees state table) + (finalResult : CleanRunResult alpha) + (hresult : some finalResult ∈ support (do + let result ← runCleanFromTable state fuel table computation + finishCleanRunFromTable result)) : + finalResult.table = table ∧ StartTableAgrees finalResult.state table := by + rw [mem_support_bind_iff] at hresult + obtain ⟨result, hrun, hfinish⟩ := hresult + cases result with + | none => simp [finishCleanRunFromTable] at hfinish + | some runResult => + obtain ⟨rfl, hrunAgrees⟩ := startTableAgrees_of_mem_runCleanFromTable + computation state fuel table hagrees runResult hrun + exact startTableAgrees_of_mem_finishCleanRunFromTable runResult finalResult + hrunAgrees hfinish + +theorem pendingAt_clearPending_of_ne + (state : LazyRevealProbe.State Coordinate) (left right : Coordinate) + (hne : right ≠ left) : + (state.clearPending left).pendingAt right = state.pendingAt right := by + ext candidate + simp [LazyRevealProbe.State.pendingAt, LazyRevealProbe.State.clearPending, + LazyRevealProbe.State.pendingAway, hne] + +theorem pendingAt_complete_of_ne + (state : LazyRevealProbe.State Coordinate) (left right : Coordinate) + (output : HashOutput) (hne : right ≠ left) : + (state.complete left output).pendingAt right = state.pendingAt right := by + exact pendingAt_clearPending_of_ne state left right hne + +theorem hitAt_clearPending_of_ne + (state : LazyRevealProbe.State Coordinate) (left right : Coordinate) + (output : HashOutput) (hne : right ≠ left) : + (state.clearPending left).hitAt right output ↔ state.hitAt right output := by + unfold LazyRevealProbe.State.hitAt + rw [pendingAt_clearPending_of_ne state left right hne] + +theorem hitAt_complete_of_ne + (state : LazyRevealProbe.State Coordinate) (left right : Coordinate) + (leftOutput rightOutput : HashOutput) (hne : right ≠ left) : + (state.complete left leftOutput).hitAt right rightOutput ↔ + state.hitAt right rightOutput := by + unfold LazyRevealProbe.State.hitAt + rw [pendingAt_complete_of_ne state left right leftOutput hne] + +@[simp] theorem values_clearPending + (state : LazyRevealProbe.State Coordinate) (left right : Coordinate) : + (state.clearPending left).values right = state.values right := rfl + +theorem values_complete_of_ne + (state : LazyRevealProbe.State Coordinate) (left right : Coordinate) + (output : HashOutput) (hne : right ≠ left) : + (state.complete left output).values right = state.values right := by + simp [LazyRevealProbe.State.complete, Function.update, hne] + +theorem clearPending_comm + (state : LazyRevealProbe.State Coordinate) (left right : Coordinate) : + (state.clearPending left).clearPending right = + (state.clearPending right).clearPending left := by + rcases state with ⟨pending, values, revealed, ensured⟩ + simp [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.pendingAway, and_comm] + exact Finset.filter_comm (fun x : Coordinate × Digest => ¬ x.1 = left) + (fun x => ¬ x.1 = right) pending + +theorem clearPending_complete_comm + (state : LazyRevealProbe.State Coordinate) (left right : Coordinate) + (output : HashOutput) : + (state.clearPending left).complete right output = + (state.complete right output).clearPending left := by + rcases state with ⟨pending, values, revealed, ensured⟩ + simp [LazyRevealProbe.State.clearPending, LazyRevealProbe.State.complete, + LazyRevealProbe.State.pendingAway, and_comm] + exact Finset.filter_comm (fun x : Coordinate × Digest => ¬ x.1 = left) + (fun x => ¬ x.1 = right) pending + +theorem complete_comm + (state : LazyRevealProbe.State Coordinate) (left right : Coordinate) + (leftOutput rightOutput : HashOutput) (hne : left ≠ right) : + (state.complete left leftOutput).complete right rightOutput = + (state.complete right rightOutput).complete left leftOutput := by + rcases state with ⟨pending, values, revealed, ensured⟩ + simp [LazyRevealProbe.State.complete, LazyRevealProbe.State.pendingAway, + Function.update_comm hne, and_comm] + exact Finset.filter_comm (fun x : Coordinate × Digest => ¬ x.1 = left) + (fun x => ¬ x.1 = right) pending + +set_option maxRecDepth 100000 in +theorem evalDist_finalizeCleanFromTable_swap_of_some_none + (left right : Coordinate) (remaining : List Coordinate) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (leftOutput : HashOutput) + (hne : left ≠ right) (hleft : state.values left = some leftOutput) + (hright : state.values right = none) : + 𝒟[finalizeCleanFromTable (left :: right :: remaining) state table] = + 𝒟[finalizeCleanFromTable (right :: left :: remaining) state table] := by + have hrightClear : (state.clearPending left).values right = none := by + simpa only [values_clearPending] using hright + cases right with + | chainStart lay tree leafIdx chainIdx => + let right : Coordinate := .chainStart lay tree leafIdx chainIdx + let output := table ⟨lay, tree, leafIdx, chainIdx⟩ + have hrightNe : right ≠ left := hne.symm + have hhitClear : (state.clearPending left).hitAt right output ↔ + state.hitAt right output := + hitAt_clearPending_of_ne state left right output hrightNe + have hleftComplete : (state.complete right output).values left = + some leftOutput := by + rw [values_complete_of_ne state right left output hne, hleft] + simp only [finalizeCleanFromTable, hleft, hrightClear, hright] + by_cases hhit : state.hitAt right output + · rw [if_pos (hhitClear.mpr hhit), if_pos hhit] + · rw [if_neg (mt hhitClear.mp hhit), if_neg hhit, hleftComplete, + clearPending_complete_comm] + + | position position => + let right : Coordinate := .position position + have hrightNe : right ≠ left := hne.symm + simp only [finalizeCleanFromTable, hleft, hrightClear, hright] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + have hhitClear : (state.clearPending left).hitAt right output ↔ + state.hitAt right output := + hitAt_clearPending_of_ne state left right output hrightNe + have hleftComplete : (state.complete right output).values left = + some leftOutput := by + rw [values_complete_of_ne state right left output hne, hleft] + by_cases hhit : state.hitAt right output + · rw [if_pos (hhitClear.mpr hhit), if_pos hhit] + · rw [if_neg (mt hhitClear.mp hhit), if_neg hhit, hleftComplete, + clearPending_complete_comm] + +noncomputable def completionOutputFromTable + (coordinate : Coordinate) (table : OtsSecretIndex → HashOutput) : + ProbComp HashOutput := + match coordinate with + | .chainStart lay tree leafIdx chainIdx => pure (table ⟨lay, tree, leafIdx, chainIdx⟩) + | .position _ => LazyRevealProbe.sampleHashOutput + +theorem completionOutputFromTable_neverFails + (coordinate : Coordinate) (table : OtsSecretIndex → HashOutput) : + Pr[⊥ | completionOutputFromTable coordinate table] = 0 := by + cases coordinate <;> simp [completionOutputFromTable, LazyRevealProbe.sampleHashOutput] + +theorem finalizeCleanFromTable_cons_of_none + (coordinate : Coordinate) (remaining : List Coordinate) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) + (hvalue : state.values coordinate = none) : + finalizeCleanFromTable (coordinate :: remaining) state table = (do + let output ← completionOutputFromTable coordinate table + if state.hitAt coordinate output then + pure none + else + finalizeCleanFromTable remaining (state.complete coordinate output) table) := by + cases coordinate <;> simp [finalizeCleanFromTable, completionOutputFromTable, hvalue] + +theorem finalizeCleanFromTable_cons_of_some + (coordinate : Coordinate) (remaining : List Coordinate) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (output : HashOutput) + (hvalue : state.values coordinate = some output) : + finalizeCleanFromTable (coordinate :: remaining) state table = + finalizeCleanFromTable remaining (state.clearPending coordinate) table := by + rw [finalizeCleanFromTable.eq_def] + simp only + rw [hvalue] + +set_option maxRecDepth 100000 in +theorem evalDist_finalizeCleanFromTable_two_none + (left right : Coordinate) (remaining : List Coordinate) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (hne : left ≠ right) + (hleft : state.values left = none) (hright : state.values right = none) : + 𝒟[finalizeCleanFromTable (left :: right :: remaining) state table] = + 𝒟[do + let leftOutput ← completionOutputFromTable left table + let rightOutput ← completionOutputFromTable right table + if state.hitAt left leftOutput then + pure none + else if state.hitAt right rightOutput then + pure none + else + finalizeCleanFromTable remaining + ((state.complete left leftOutput).complete right rightOutput) table] := by + rw [finalizeCleanFromTable_cons_of_none left (right :: remaining) state table hleft] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro leftOutput + by_cases hleftHit : state.hitAt left leftOutput + · rw [if_pos hleftHit] + simp only [hleftHit, ↓reduceIte] + exact (OracleComp.DeferredSampling.evalDist_bind_const_neverFails + (completionOutputFromTable right table) + (completionOutputFromTable_neverFails right table) (pure none)).symm + · rw [if_neg hleftHit] + simp only [hleftHit, ↓reduceIte] + have hrightValue : (state.complete left leftOutput).values right = none := by + rw [values_complete_of_ne state left right leftOutput hne.symm, hright] + rw [finalizeCleanFromTable_cons_of_none right remaining + (state.complete left leftOutput) table hrightValue] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro rightOutput + have hrightHit : (state.complete left leftOutput).hitAt right rightOutput ↔ + state.hitAt right rightOutput := + hitAt_complete_of_ne state left right leftOutput rightOutput hne.symm + by_cases hhit : state.hitAt right rightOutput + · rw [if_pos (hrightHit.mpr hhit), if_pos hhit] + · rw [if_neg (mt hrightHit.mp hhit), if_neg hhit] + +set_option maxRecDepth 100000 in +theorem evalDist_finalizeCleanFromTable_swap + (left right : Coordinate) (remaining : List Coordinate) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (hne : left ≠ right) : + 𝒟[finalizeCleanFromTable (left :: right :: remaining) state table] = + 𝒟[finalizeCleanFromTable (right :: left :: remaining) state table] := by + cases hleft : state.values left with + | some leftOutput => + cases hright : state.values right with + | some rightOutput => + simp [finalizeCleanFromTable, hleft, hright, clearPending_comm] + | none => + exact evalDist_finalizeCleanFromTable_swap_of_some_none left right remaining state + table leftOutput hne hleft hright + | none => + cases hright : state.values right with + | some rightOutput => + exact (evalDist_finalizeCleanFromTable_swap_of_some_none right left remaining state + table rightOutput hne.symm hright hleft).symm + | none => + rw [evalDist_finalizeCleanFromTable_two_none left right remaining state table hne + hleft hright, + evalDist_finalizeCleanFromTable_two_none right left remaining state table hne.symm + hright hleft] + rw [OracleComp.DeferredSampling.evalDist_bind_comm + (completionOutputFromTable left table) (completionOutputFromTable right table)] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro rightOutput + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro leftOutput + by_cases hleftHit : state.hitAt left leftOutput + · simp [hleftHit] + · by_cases hrightHit : state.hitAt right rightOutput + · simp [hleftHit, hrightHit] + · simp only [hleftHit, hrightHit, ↓reduceIte] + rw [complete_comm state left right leftOutput rightOutput hne] + +set_option maxRecDepth 100000 in +theorem evalDist_finalizeCleanFromTable_perm + {left right : List Coordinate} (hperm : left.Perm right) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) : + 𝒟[finalizeCleanFromTable left state table] = + 𝒟[finalizeCleanFromTable right state table] := by + induction hperm generalizing state with + | nil => rfl + | cons coordinate hperm ih => + cases hvalue : state.values coordinate with + | some output => + rw [finalizeCleanFromTable_cons_of_some coordinate _ state table output hvalue, + finalizeCleanFromTable_cons_of_some coordinate _ state table output hvalue] + exact ih (state.clearPending coordinate) + | none => + rw [finalizeCleanFromTable_cons_of_none coordinate _ state table hvalue, + finalizeCleanFromTable_cons_of_none coordinate _ state table hvalue] + apply OracleComp.DeferredSampling.evalDist_bind_congr_left + intro output + by_cases hhit : state.hitAt coordinate output + · rw [if_pos hhit, if_pos hhit] + · rw [if_neg hhit, if_neg hhit] + exact ih (state.complete coordinate output) + | swap left right remaining => + by_cases heq : left = right + · subst right + rfl + · exact (evalDist_finalizeCleanFromTable_swap left right remaining state table heq).symm + | trans _ _ ihLeft ihRight => exact ihLeft state |>.trans (ihRight state) + +theorem evalDist_finalizeCleanFromTable_move_to_front + (coordinate : Coordinate) (coordinates : List Coordinate) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (hmem : coordinate ∈ coordinates) : + 𝒟[finalizeCleanFromTable coordinates state table] = + 𝒟[finalizeCleanFromTable (coordinate :: coordinates.erase coordinate) state table] := + evalDist_finalizeCleanFromTable_perm (List.perm_cons_erase hmem) state table + +theorem evalDist_finalizeCleanFromTable_finset_move_to_front + (coordinate : Coordinate) (coordinates : Finset Coordinate) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (hmem : coordinate ∈ coordinates) : + 𝒟[finalizeCleanFromTable coordinates.toList state table] = + 𝒟[finalizeCleanFromTable + (coordinate :: coordinates.toList.erase coordinate) state table] := by + apply evalDist_finalizeCleanFromTable_move_to_front + simpa using hmem + +theorem evalDist_finalizeCleanFromTable_expose_missing + (coordinate : Coordinate) (coordinates : List Coordinate) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (hmem : coordinate ∈ coordinates) + (hmissing : state.values coordinate = none) : + 𝒟[finalizeCleanFromTable coordinates state table] = + 𝒟[do + let output ← completionOutputFromTable coordinate table + if state.hitAt coordinate output then + pure none + else + finalizeCleanFromTable (coordinates.erase coordinate) + (state.complete coordinate output) table] := by + calc + _ = 𝒟[finalizeCleanFromTable + (coordinate :: coordinates.erase coordinate) state table] := + evalDist_finalizeCleanFromTable_move_to_front coordinate coordinates state table hmem + _ = _ := congrArg evalDist + (finalizeCleanFromTable_cons_of_none coordinate (coordinates.erase coordinate) + state table hmissing) + +theorem evalDist_finalizeCleanFromTable_finset_expose_missing + (coordinate : Coordinate) (coordinates : Finset Coordinate) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (hmem : coordinate ∈ coordinates) + (hmissing : state.values coordinate = none) : + 𝒟[finalizeCleanFromTable coordinates.toList state table] = + 𝒟[do + let output ← completionOutputFromTable coordinate table + if state.hitAt coordinate output then + pure none + else + finalizeCleanFromTable (coordinates.toList.erase coordinate) + (state.complete coordinate output) table] := by + apply evalDist_finalizeCleanFromTable_expose_missing + · simpa using hmem + · exact hmissing + +theorem values_eq_of_mem_finalizeCleanFromTable_of_not_mem + (coordinate : Coordinate) (coordinates : List Coordinate) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (output : HashOutput) + (hnotMem : coordinate ∉ coordinates) + (hvalue : state.values coordinate = some output) + (finalState : LazyRevealProbe.State Coordinate) + (finalTable : OtsSecretIndex → HashOutput) + (hresult : some (finalState, finalTable) ∈ support + (finalizeCleanFromTable coordinates state table)) : + finalState.values coordinate = some output := by + induction coordinates generalizing state with + | nil => + simp [finalizeCleanFromTable] at hresult + obtain ⟨rfl, rfl⟩ := hresult + exact hvalue + | cons head remaining ih => + have hne : coordinate ≠ head := by + intro heq + apply hnotMem + simp [heq] + have hnotTail : coordinate ∉ remaining := by + exact fun hmem => hnotMem (List.mem_cons_of_mem head hmem) + cases hhead : state.values head with + | some headOutput => + rw [finalizeCleanFromTable.eq_def] at hresult + simp only at hresult + rw [hhead] at hresult + exact ih (state.clearPending head) hnotTail hvalue hresult + | none => + rw [finalizeCleanFromTable.eq_def] at hresult + simp only at hresult + rw [hhead] at hresult + simp only at hresult + cases head with + | chainStart lay tree leafIdx chainIdx => + simp only at hresult + by_cases hhit : state.hitAt (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩) + · simp [hhit] at hresult + · rw [if_neg hhit] at hresult + apply ih + (state.complete (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩)) hnotTail + _ hresult + rw [values_complete_of_ne state + (.chainStart lay tree leafIdx chainIdx) coordinate _ hne, hvalue] + | position position => + simp only at hresult + rw [mem_support_bind_iff] at hresult + obtain ⟨headOutput, _, hrest⟩ := hresult + by_cases hhit : state.hitAt (.position position) headOutput + · simp [hhit] at hrest + · apply ih (state.complete (.position position) headOutput) hnotTail + _ (by simpa [hhit] using hrest) + rw [values_complete_of_ne state (.position position) coordinate _ hne, + hvalue] + +def FinalizePositionRel (coordinate : Coordinate) : + Option (LazyRevealProbe.State Coordinate × (OtsSecretIndex → HashOutput)) → + HashOutput → Prop + | none, _ => True + | some (state, _), output => state.values coordinate = some output + +set_option maxRecDepth 100000 in +theorem relTriple_finalizeCleanFromTable_position_missing + (position : Position) (coordinates : List Coordinate) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) + (hmem : Coordinate.position position ∈ coordinates) + (hnodup : coordinates.Nodup) + (hmissing : state.values (.position position) = none) : + RelTriple + (finalizeCleanFromTable coordinates state table) + LazyRevealProbe.sampleHashOutput + (FinalizePositionRel (.position position)) := by + let coordinate : Coordinate := .position position + have hexpose := evalDist_finalizeCleanFromTable_expose_missing coordinate coordinates state + table (by simpa [coordinate] using hmem) (by simpa [coordinate] using hmissing) + apply relTriple_of_evalDist_eq_left hexpose + have hbind : RelTriple + (LazyRevealProbe.sampleHashOutput >>= fun output => + if state.hitAt coordinate output then + pure none + else + finalizeCleanFromTable (coordinates.erase coordinate) + (state.complete coordinate output) table) + (LazyRevealProbe.sampleHashOutput >>= fun output => pure output) + (FinalizePositionRel coordinate) := by + apply relTriple_bind (relTriple_refl LazyRevealProbe.sampleHashOutput) + intro leftOutput rightOutput heq + subst rightOutput + by_cases hhit : state.hitAt coordinate leftOutput + · simp only [hhit, ↓reduceIte] + exact relTriple_pure_pure (by simp [FinalizePositionRel]) + · simp only [hhit, ↓reduceIte] + have hbase := relTriple_true + (finalizeCleanFromTable (coordinates.erase coordinate) + (state.complete coordinate leftOutput) table) + (pure leftOutput : ProbComp HashOutput) + have hnotMem : coordinate ∉ coordinates.erase coordinate := by + have hpermuted : (coordinate :: coordinates.erase coordinate).Nodup := + (List.perm_cons_erase (by simpa [coordinate] using hmem)).nodup_iff.mp hnodup + exact (List.nodup_cons.mp hpermuted).1 + have hsupportedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => FinalizePositionRel coordinate result leftOutput) + (by + intro result hresult + cases result with + | none => trivial + | some value => + rcases value with ⟨finalState, finalTable⟩ + exact values_eq_of_mem_finalizeCleanFromTable_of_not_mem coordinate + (coordinates.erase coordinate) (state.complete coordinate leftOutput) + table leftOutput hnotMem (by + simp [LazyRevealProbe.State.complete]) finalState finalTable hresult) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hsupportedLeft + exact relTriple_post_mono hsupported fun leftResult rightResult hrelation => by + have hright : rightResult = leftOutput := by + simpa using hrelation.2 + rw [hright] + exact hrelation.1.2 + simpa [coordinate, completionOutputFromTable] using hbind + +theorem relTriple_finalizeCleanFromTable_state_position_missing + (position : Position) (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) + (hmem : Coordinate.position position ∈ state.coordinates) + (hmissing : state.values (.position position) = none) : + RelTriple + (finalizeCleanFromTable state.coordinates.toList state table) + LazyRevealProbe.sampleHashOutput + (FinalizePositionRel (.position position)) := by + apply relTriple_finalizeCleanFromTable_position_missing position state.coordinates.toList + state table + · simpa using hmem + · exact Finset.nodup_toList state.coordinates + · exact hmissing + +theorem relTriple_finalizeCleanFromTable_of_value + (coordinate : Coordinate) (coordinates : List Coordinate) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (output : HashOutput) + (hmem : coordinate ∈ coordinates) (hnodup : coordinates.Nodup) + (hvalue : state.values coordinate = some output) : + RelTriple + (finalizeCleanFromTable coordinates state table) + (pure output : ProbComp HashOutput) + (FinalizePositionRel coordinate) := by + have heval : 𝒟[finalizeCleanFromTable coordinates state table] = + 𝒟[finalizeCleanFromTable (coordinates.erase coordinate) + (state.clearPending coordinate) table] := by + calc + _ = 𝒟[finalizeCleanFromTable (coordinate :: coordinates.erase coordinate) + state table] := + evalDist_finalizeCleanFromTable_move_to_front coordinate coordinates state table hmem + _ = _ := congrArg evalDist + (finalizeCleanFromTable_cons_of_some coordinate (coordinates.erase coordinate) + state table output hvalue) + apply relTriple_of_evalDist_eq_left heval + have hnotMem : coordinate ∉ coordinates.erase coordinate := by + have hpermuted : (coordinate :: coordinates.erase coordinate).Nodup := + (List.perm_cons_erase hmem).nodup_iff.mp hnodup + exact (List.nodup_cons.mp hpermuted).1 + have hbase := relTriple_true + (finalizeCleanFromTable (coordinates.erase coordinate) + (state.clearPending coordinate) table) + (pure output : ProbComp HashOutput) + have hsupportedLeft := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => FinalizePositionRel coordinate result output) + (by + intro result hresult + cases result with + | none => trivial + | some value => + rcases value with ⟨finalState, finalTable⟩ + exact values_eq_of_mem_finalizeCleanFromTable_of_not_mem coordinate + (coordinates.erase coordinate) (state.clearPending coordinate) table output + hnotMem hvalue finalState finalTable hresult) + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hsupportedLeft + exact relTriple_post_mono hsupported fun leftResult rightResult hrelation => by + have hright : rightResult = output := by + simpa using hrelation.2 + rw [hright] + exact hrelation.1.2 + +theorem relTriple_finalizeCleanFromTable_state_of_value + (coordinate : Coordinate) (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (output : HashOutput) + (hmem : coordinate ∈ state.coordinates) + (hvalue : state.values coordinate = some output) : + RelTriple + (finalizeCleanFromTable state.coordinates.toList state table) + (pure output : ProbComp HashOutput) + (FinalizePositionRel coordinate) := by + apply relTriple_finalizeCleanFromTable_of_value coordinate state.coordinates.toList state + table output + · simpa using hmem + · exact Finset.nodup_toList state.coordinates + · exact hvalue + +def FinalizeQueryRel (coordinate : Coordinate) (input : HashInput) + (cache : QueryCache HashSpec) : + Option (LazyRevealProbe.State Coordinate × (OtsSecretIndex → HashOutput)) → + HashOutput × QueryCache HashSpec → Prop + | none, _ => True + | some (state, _), (output, finalCache) => + state.values coordinate = some output ∧ + finalCache = cache.cacheQuery input output + +theorem relTriple_finalizeCleanFromTable_position_freshQuery + (position : Position) (coordinates : List Coordinate) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (input : HashInput) + (cache : QueryCache HashSpec) + (hmem : Coordinate.position position ∈ coordinates) + (hnodup : coordinates.Nodup) + (hmissing : state.values (.position position) = none) + (hcache : cache input = none) : + RelTriple + (finalizeCleanFromTable coordinates state table) + ((randomOracle (spec := HashSpec) input).run cache) + (FinalizeQueryRel (.position position) input cache) := by + have hposition := relTriple_finalizeCleanFromTable_position_missing position coordinates + state table hmem hnodup hmissing + have hmapped : RelTriple + (id <$> finalizeCleanFromTable coordinates state table) + ((fun output => (output, cache.cacheQuery input output)) <$> + LazyRevealProbe.sampleHashOutput) + (FinalizeQueryRel (.position position) input cache) := by + apply relTriple_map + apply relTriple_post_mono hposition + intro leftResult rightOutput hrelation + cases leftResult with + | none => trivial + | some value => + rcases value with ⟨finalState, finalTable⟩ + exact ⟨hrelation, rfl⟩ + rw [QueryImpl.withCaching_run_none uniformSampleImpl hcache] + unfold LazyRevealProbe.sampleHashOutput at hmapped + unfold uniformSampleImpl + simpa using hmapped + +theorem relTriple_finalizeCleanFromTable_position_cachedQuery + (position : Position) (coordinates : List Coordinate) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (input : HashInput) + (cache : QueryCache HashSpec) (output : HashOutput) + (hmem : Coordinate.position position ∈ coordinates) + (hnodup : coordinates.Nodup) + (hvalue : state.values (.position position) = some output) + (hcache : cache input = some output) : + RelTriple + (finalizeCleanFromTable coordinates state table) + ((randomOracle (spec := HashSpec) input).run cache) + (FinalizeQueryRel (.position position) input cache) := by + have hposition := relTriple_finalizeCleanFromTable_of_value (.position position) coordinates + state table output hmem hnodup hvalue + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hposition + have hmapped : RelTriple + (id <$> finalizeCleanFromTable coordinates state table) + ((fun result => (result, cache)) <$> (pure output : ProbComp HashOutput)) + (FinalizeQueryRel (.position position) input cache) := by + apply relTriple_map + apply relTriple_post_mono hsupported + intro leftResult rightOutput hrelation + cases leftResult with + | none => trivial + | some value => + rcases value with ⟨finalState, finalTable⟩ + have hright : rightOutput = output := by + simpa using hrelation.2 + subst rightOutput + have hfinalValue : + finalState.values (.position position) = some output := by + simpa [FinalizePositionRel] using hrelation.1 + have hcacheQuery : cache = cache.cacheQuery input output := by + apply QueryCache.ext + intro query + by_cases hquery : query = input + · subst query + simpa [QueryCache.cacheQuery_self] using hcache + · simp [QueryCache.cacheQuery_of_ne cache output hquery] + exact ⟨hfinalValue, hcacheQuery⟩ + rw [QueryImpl.withCaching_run_some uniformSampleImpl hcache] + simpa using hmapped + +theorem relTriple_finalizeCleanFromTable_position_freshQuery_bind + (position : Position) (coordinates : List Coordinate) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (input : HashInput) + (cache : QueryCache HashSpec) + (leftNext : Option + (LazyRevealProbe.State Coordinate × (OtsSecretIndex → HashOutput)) → ProbComp alpha) + (rightNext : HashOutput × QueryCache HashSpec → ProbComp beta) + (relation : alpha → beta → Prop) + (hmem : Coordinate.position position ∈ coordinates) + (hmissing : state.values (.position position) = none) + (hcache : cache input = none) + (hnext : ∀ output, + RelTriple + ((if state.hitAt (.position position) output then + pure none + else + finalizeCleanFromTable + (coordinates.erase (.position position)) + (state.complete (.position position) output) table) >>= leftNext) + (rightNext (output, cache.cacheQuery input output)) relation) : + RelTriple + (finalizeCleanFromTable coordinates state table >>= leftNext) + (((randomOracle (spec := HashSpec) input).run cache) >>= rightNext) + relation := by + have hexpose := evalDist_finalizeCleanFromTable_expose_missing + (.position position) coordinates state table hmem hmissing + have hleft : + 𝒟[finalizeCleanFromTable coordinates state table >>= leftNext] = + 𝒟[(LazyRevealProbe.sampleHashOutput >>= fun output => + if state.hitAt (.position position) output then + pure none + else + finalizeCleanFromTable + (coordinates.erase (.position position)) + (state.complete (.position position) output) table) >>= leftNext] := by + rw [evalDist_bind, hexpose, ← evalDist_bind] + simp [completionOutputFromTable] + apply relTriple_of_evalDist_eq_left hleft + rw [QueryImpl.withCaching_run_none uniformSampleImpl hcache] + unfold uniformSampleImpl LazyRevealProbe.sampleHashOutput + simp only [map_eq_bind_pure_comp, bind_assoc] + apply relTriple_bind (relTriple_refl ($ᵗ HashOutput : ProbComp HashOutput)) + intro leftOutput rightOutput heq + subst rightOutput + exact hnext leftOutput + +theorem relTriple_finalizeCleanFromTable_position_cachedQuery_bind + (position : Position) (coordinates : List Coordinate) + (state : LazyRevealProbe.State Coordinate) + (table : OtsSecretIndex → HashOutput) (input : HashInput) + (cache : QueryCache HashSpec) (output : HashOutput) + (leftNext : Option + (LazyRevealProbe.State Coordinate × (OtsSecretIndex → HashOutput)) → ProbComp alpha) + (rightNext : HashOutput × QueryCache HashSpec → ProbComp beta) + (relation : alpha → beta → Prop) + (hmem : Coordinate.position position ∈ coordinates) + (hvalue : state.values (.position position) = some output) + (hcache : cache input = some output) + (hnext : RelTriple + (finalizeCleanFromTable (coordinates.erase (.position position)) + (state.clearPending (.position position)) table >>= leftNext) + (rightNext (output, cache)) relation) : + RelTriple + (finalizeCleanFromTable coordinates state table >>= leftNext) + (((randomOracle (spec := HashSpec) input).run cache) >>= rightNext) + relation := by + have hleft : + 𝒟[finalizeCleanFromTable coordinates state table >>= leftNext] = + 𝒟[finalizeCleanFromTable (coordinates.erase (.position position)) + (state.clearPending (.position position)) table >>= leftNext] := by + rw [evalDist_bind] + calc + _ = 𝒟[finalizeCleanFromTable + (.position position :: coordinates.erase (.position position)) state table] >>= + fun result => 𝒟[leftNext result] := by + rw [evalDist_finalizeCleanFromTable_move_to_front (.position position) + coordinates state table hmem] + _ = _ := by + rw [finalizeCleanFromTable_cons_of_some (.position position) + (coordinates.erase (.position position)) state table output hvalue] + rw [← evalDist_bind] + apply relTriple_of_evalDist_eq_left hleft + rw [QueryImpl.withCaching_run_some uniformSampleImpl hcache] + simpa using hnext + +def StructuralScheduleWP (computation : OracleComp HashSpec alpha) + (post : alpha → List Coordinate → LazyRevealProbe.State Coordinate → + QueryCache HashSpec → Prop) + (coordinates : List Coordinate) (state : LazyRevealProbe.State Coordinate) + (cache : QueryCache HashSpec) : Prop := + OracleComp.construct + (C := fun _ : OracleComp HashSpec alpha => + List Coordinate → LazyRevealProbe.State Coordinate → QueryCache HashSpec → Prop) + post + (fun input _next recursivelyScheduled coordinates state cache => + ∃ position : Position, + (Coordinate.position position ∈ coordinates ∧ + state.values (.position position) = none ∧ + cache input = none ∧ + ∀ output, ¬state.hitAt (.position position) output → + recursivelyScheduled output + (coordinates.erase (.position position)) + (state.complete (.position position) output) + (cache.cacheQuery input output)) ∨ + (∃ output : HashOutput, + Coordinate.position position ∈ coordinates ∧ + state.values (.position position) = some output ∧ + cache input = some output ∧ + recursivelyScheduled output + (coordinates.erase (.position position)) + (state.clearPending (.position position)) cache)) + computation coordinates state cache + +abbrev StructuralSchedule (computation : OracleComp HashSpec alpha) + (coordinates : List Coordinate) (state : LazyRevealProbe.State Coordinate) + (cache : QueryCache HashSpec) : Prop := + StructuralScheduleWP computation (fun _ _ _ _ => True) coordinates state cache + +@[simp] theorem structuralScheduleWP_pure + (value : alpha) + (post : alpha → List Coordinate → LazyRevealProbe.State Coordinate → + QueryCache HashSpec → Prop) + (coordinates : List Coordinate) (state : LazyRevealProbe.State Coordinate) + (cache : QueryCache HashSpec) : + StructuralScheduleWP (pure value) post coordinates state cache = + post value coordinates state cache := by + rfl + +theorem structuralScheduleWP_query_bind_iff + (input : HashInput) (next : HashOutput → OracleComp HashSpec alpha) + (post : alpha → List Coordinate → LazyRevealProbe.State Coordinate → + QueryCache HashSpec → Prop) + (coordinates : List Coordinate) (state : LazyRevealProbe.State Coordinate) + (cache : QueryCache HashSpec) : + StructuralScheduleWP + ((liftM (HashSpec.query input) : OracleComp HashSpec HashOutput) >>= next) + post coordinates state cache ↔ + ∃ position : Position, + (Coordinate.position position ∈ coordinates ∧ + state.values (.position position) = none ∧ + cache input = none ∧ + ∀ output, ¬state.hitAt (.position position) output → + StructuralScheduleWP (next output) post + (coordinates.erase (.position position)) + (state.complete (.position position) output) + (cache.cacheQuery input output)) ∨ + (∃ output : HashOutput, + Coordinate.position position ∈ coordinates ∧ + state.values (.position position) = some output ∧ + cache input = some output ∧ + StructuralScheduleWP (next output) post + (coordinates.erase (.position position)) + (state.clearPending (.position position)) cache) := by + rfl + +theorem structuralScheduleWP_query_bind_fresh + (input : HashInput) (next : HashOutput → OracleComp HashSpec alpha) + (post : alpha → List Coordinate → LazyRevealProbe.State Coordinate → + QueryCache HashSpec → Prop) + (position : Position) (coordinates : List Coordinate) + (state : LazyRevealProbe.State Coordinate) (cache : QueryCache HashSpec) + (hmem : Coordinate.position position ∈ coordinates) + (hmissing : state.values (.position position) = none) + (hcache : cache input = none) + (htail : ∀ output, ¬state.hitAt (.position position) output → + StructuralScheduleWP (next output) post + (coordinates.erase (.position position)) + (state.complete (.position position) output) + (cache.cacheQuery input output)) : + StructuralScheduleWP + ((liftM (HashSpec.query input) : OracleComp HashSpec HashOutput) >>= next) + post coordinates state cache := by + exact (structuralScheduleWP_query_bind_iff input next post coordinates state cache).2 + ⟨position, Or.inl ⟨hmem, hmissing, hcache, htail⟩⟩ + +theorem structuralScheduleWP_query_bind_cached + (input : HashInput) (next : HashOutput → OracleComp HashSpec alpha) + (post : alpha → List Coordinate → LazyRevealProbe.State Coordinate → + QueryCache HashSpec → Prop) + (position : Position) (coordinates : List Coordinate) + (state : LazyRevealProbe.State Coordinate) (cache : QueryCache HashSpec) + (output : HashOutput) + (hmem : Coordinate.position position ∈ coordinates) + (hvalue : state.values (.position position) = some output) + (hcache : cache input = some output) + (htail : StructuralScheduleWP (next output) post + (coordinates.erase (.position position)) + (state.clearPending (.position position)) cache) : + StructuralScheduleWP + ((liftM (HashSpec.query input) : OracleComp HashSpec HashOutput) >>= next) + post coordinates state cache := by + exact (structuralScheduleWP_query_bind_iff input next post coordinates state cache).2 + ⟨position, Or.inr ⟨output, hmem, hvalue, hcache, htail⟩⟩ + +theorem structuralScheduleWP_tweakableHash_fresh + (parameter : PublicParameter) (domain : HashDomain) (payload : HashInput) + (post : Digest → List Coordinate → LazyRevealProbe.State Coordinate → + QueryCache HashSpec → Prop) + (position : Position) (coordinates : List Coordinate) + (state : LazyRevealProbe.State Coordinate) (cache : QueryCache HashSpec) + (hmem : Coordinate.position position ∈ coordinates) + (hmissing : state.values (.position position) = none) + (hcache : cache (tweakableHashInput parameter domain payload) = none) + (htail : ∀ output, ¬state.hitAt (.position position) output → + post (truncateHash output) (coordinates.erase (.position position)) + (state.complete (.position position) output) + (cache.cacheQuery (tweakableHashInput parameter domain payload) output)) : + StructuralScheduleWP (tweakableHash parameter domain payload) post + coordinates state cache := by + unfold tweakableHash oracleHash + apply structuralScheduleWP_query_bind_fresh _ _ post position coordinates state cache + hmem hmissing hcache + intro output hhit + simpa using htail output hhit + +theorem structuralScheduleWP_tweakableHash_cached + (parameter : PublicParameter) (domain : HashDomain) (payload : HashInput) + (post : Digest → List Coordinate → LazyRevealProbe.State Coordinate → + QueryCache HashSpec → Prop) + (position : Position) (coordinates : List Coordinate) + (state : LazyRevealProbe.State Coordinate) (cache : QueryCache HashSpec) + (output : HashOutput) + (hmem : Coordinate.position position ∈ coordinates) + (hvalue : state.values (.position position) = some output) + (hcache : cache (tweakableHashInput parameter domain payload) = some output) + (htail : post (truncateHash output) (coordinates.erase (.position position)) + (state.clearPending (.position position)) cache) : + StructuralScheduleWP (tweakableHash parameter domain payload) post + coordinates state cache := by + unfold tweakableHash oracleHash + apply structuralScheduleWP_query_bind_cached _ _ post position coordinates state cache + output hmem hvalue hcache + simpa using htail + +theorem structuralScheduleWP_bind + (left : OracleComp HashSpec alpha) (next : alpha → OracleComp HashSpec beta) + (post : beta → List Coordinate → LazyRevealProbe.State Coordinate → + QueryCache HashSpec → Prop) + (coordinates : List Coordinate) (state : LazyRevealProbe.State Coordinate) + (cache : QueryCache HashSpec) : + StructuralScheduleWP (left >>= next) post coordinates state cache ↔ + StructuralScheduleWP left + (fun value => StructuralScheduleWP (next value) post) + coordinates state cache := by + induction left using OracleComp.inductionOn generalizing coordinates state cache with + | pure value => rfl + | query_bind input continuation ih => + simp only [StructuralScheduleWP, OracleComp.construct_query_bind] + constructor <;> intro hschedule + · obtain ⟨position, hfresh | hcached⟩ := hschedule + · refine ⟨position, Or.inl ⟨hfresh.1, hfresh.2.1, hfresh.2.2.1, ?_⟩⟩ + intro output hhit + exact (ih output _ _ _).mp (hfresh.2.2.2 output hhit) + · obtain ⟨output, hmem, hvalue, hcache, htail⟩ := hcached + exact ⟨position, Or.inr ⟨output, hmem, hvalue, hcache, + (ih output _ _ _).mp htail⟩⟩ + · obtain ⟨position, hfresh | hcached⟩ := hschedule + · refine ⟨position, Or.inl ⟨hfresh.1, hfresh.2.1, hfresh.2.2.1, ?_⟩⟩ + intro output hhit + exact (ih output _ _ _).mpr (hfresh.2.2.2 output hhit) + · obtain ⟨output, hmem, hvalue, hcache, htail⟩ := hcached + exact ⟨position, Or.inr ⟨output, hmem, hvalue, hcache, + (ih output _ _ _).mpr htail⟩⟩ + +theorem relTriple_finalizeCleanFromTable_simulateQ_of_structuralScheduleWP + (computation : OracleComp HashSpec alpha) + (post : alpha → List Coordinate → LazyRevealProbe.State Coordinate → + QueryCache HashSpec → Prop) + (table : OtsSecretIndex → HashOutput) + (leftNext : Option + (LazyRevealProbe.State Coordinate × (OtsSecretIndex → HashOutput)) → ProbComp gamma) + (rightNext : alpha × QueryCache HashSpec → ProbComp beta) + (relation : gamma → beta → Prop) + (hstopped : ∀ right : ProbComp beta, + RelTriple (leftNext none) right relation) + (hdone : ∀ value coordinates state cache, + post value coordinates state cache → + RelTriple + (finalizeCleanFromTable coordinates state table >>= leftNext) + (rightNext (value, cache)) relation) : + ∀ coordinates state cache, + StructuralScheduleWP computation post coordinates state cache → + RelTriple + (finalizeCleanFromTable coordinates state table >>= leftNext) + (((simulateQ (randomOracle : QueryImpl HashSpec _) computation).run cache) >>= + rightNext) + relation := by + induction computation using OracleComp.inductionOn with + | pure value => + intro coordinates state cache hschedule + simpa [StructuralScheduleWP] using hdone value coordinates state cache hschedule + | query_bind input next ih => + intro coordinates state cache hschedule + simp only [StructuralScheduleWP, OracleComp.construct_query_bind] at hschedule + obtain ⟨position, hfresh | hcached⟩ := hschedule + · rcases hfresh with ⟨hmem, hmissing, hcache, htail⟩ + rw [simulateQ_query_bind, StateT.run_bind, bind_assoc] + apply relTriple_finalizeCleanFromTable_position_freshQuery_bind position coordinates + state table input cache leftNext + (fun result => + ((simulateQ (randomOracle : QueryImpl HashSpec _) (next result.1)).run result.2) >>= + rightNext) + relation hmem hmissing hcache + intro output + by_cases hhit : state.hitAt (.position position) output + · simp only [hhit, ↓reduceIte, pure_bind] + exact hstopped _ + · simp only [hhit, ↓reduceIte] + exact ih output (coordinates.erase (.position position)) + (state.complete (.position position) output) + (cache.cacheQuery input output) (htail output hhit) + · obtain ⟨output, hmem, hvalue, hcache, htail⟩ := hcached + rw [simulateQ_query_bind, StateT.run_bind, bind_assoc] + apply relTriple_finalizeCleanFromTable_position_cachedQuery_bind position coordinates + state table input cache output leftNext + (fun result => + ((simulateQ (randomOracle : QueryImpl HashSpec _) (next result.1)).run result.2) >>= + rightNext) + relation hmem hvalue hcache + exact ih output (coordinates.erase (.position position)) + (state.clearPending (.position position)) cache htail + +theorem relTriple_finalizeCleanFromTable_simulateQ_of_structuralSchedule + (computation : OracleComp HashSpec alpha) + (table : OtsSecretIndex → HashOutput) + (leftNext : Option + (LazyRevealProbe.State Coordinate × (OtsSecretIndex → HashOutput)) → ProbComp gamma) + (rightNext : alpha × QueryCache HashSpec → ProbComp beta) + (relation : gamma → beta → Prop) + (hstopped : ∀ right : ProbComp beta, + RelTriple (leftNext none) right relation) + (hdone : ∀ value coordinates state cache, + RelTriple + (finalizeCleanFromTable coordinates state table >>= leftNext) + (rightNext (value, cache)) relation) : + ∀ coordinates state cache, + StructuralSchedule computation coordinates state cache → + RelTriple + (finalizeCleanFromTable coordinates state table >>= leftNext) + (((simulateQ (randomOracle : QueryImpl HashSpec _) computation).run cache) >>= + rightNext) + relation := by + exact relTriple_finalizeCleanFromTable_simulateQ_of_structuralScheduleWP computation + (fun _ _ _ _ => True) table leftNext rightNext relation hstopped + (fun value coordinates state cache _ => hdone value coordinates state cache) + +noncomputable def detailedExperimentCleanWithCompletionTable + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) : + ProbComp (Option (CleanRunResult alpha)) := do + let result ← LazyRevealProbe.detailedExperiment state fuel computation + match result with + | .stopped _ => pure none + | .done hit finalState remaining value => + if hit then + pure none + else + (fun base => some ⟨finalState, remaining, value, + completedStartTable finalState base⟩) <$> sampleOtsHashTable + +set_option maxRecDepth 100000 in +theorem evalDist_runThenFinalizeCleanFromTable_eq_detailed + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) : + 𝒟[do + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + let result ← runCleanFromTable state fuel (completedStartTable state base) computation + finishCleanRunFromTable result] = + 𝒟[detailedExperimentCleanWithCompletionTable state fuel computation] := by + have hrun := evalDist_runCleanFromTable_eq_lazy computation state fuel + calc + _ = 𝒟[(do + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + runCleanFromTable state fuel (completedStartTable state base) computation) >>= + finishCleanRunFromTable] := by + apply congrArg evalDist + rw [bind_assoc] + _ = 𝒟[runRawCleanWithCompletionTable state fuel computation >>= + finishCleanRunFromTable] := by + rw [evalDist_bind, hrun, ← evalDist_bind] + _ = _ := by + unfold runRawCleanWithCompletionTable detailedExperimentCleanWithCompletionTable + LazyRevealProbe.detailedExperiment + rw [bind_assoc, bind_assoc] + rw [evalDist_bind, evalDist_bind] + apply congrArg + funext raw + cases raw with + | stopped hit => simp [finishCleanRunFromTable, LazyRevealProbe.RawResult.finishDetailed] + | done rawState remaining value => + simp only [LazyRevealProbe.RawResult.finishDetailed, bind_assoc] + have hfinalize := evalDist_finalizeCleanFromTable_eq_lazy + rawState.coordinates.toList rawState + let finish : Option + (LazyRevealProbe.State Coordinate × (OtsSecretIndex → HashOutput)) → + ProbComp (Option (CleanRunResult alpha)) := fun finalized => + match finalized with + | none => pure none + | some (finalState, finalTable) => + pure (some (CleanRunResult.mk finalState remaining value finalTable)) + calc + _ = 𝒟[(do + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + finalizeCleanFromTable rawState.coordinates.toList rawState + (completedStartTable rawState base)) >>= finish] := by + apply congrArg evalDist + simp [finishCleanRunFromTable, finish, bind_assoc] + _ = 𝒟[finalizeCleanWithCompletionTable rawState.coordinates.toList rawState >>= + finish] := by + rw [evalDist_bind, hfinalize, ← evalDist_bind] + _ = _ := by + apply congrArg evalDist + unfold finalizeCleanWithCompletionTable LazyRevealProbe.finalizeDetailed + rw [bind_assoc] + apply bind_congr + intro finalized + rcases finalized with ⟨hit, finalState⟩ + by_cases hhit : hit + · simp [hhit, finish, sampleOtsHashTable] + · simp [hhit, finish, sampleOtsHashTable] + +set_option maxRecDepth 100000 in +theorem evalDist_map_isNone_detailedExperimentClean_eq_hit_of_not_stopped_false + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (hnotStopped : LazyRevealProbe.RawResult.stopped false ∉ support + (LazyRevealProbe.runRaw state fuel computation)) : + 𝒟[Option.isNone <$> detailedExperimentCleanWithCompletionTable state fuel computation] = + 𝒟[LazyRevealProbe.DetailedResult.hit <$> + LazyRevealProbe.detailedExperiment state fuel computation] := by + unfold detailedExperimentCleanWithCompletionTable + rw [map_bind, map_eq_bind_pure_comp] + apply evalDist_bind_congr + intro result hresult + cases result with + | stopped hit => + cases hit with + | false => + exact (LazyRevealProbe.stopped_false_not_mem_support_detailedExperiment_of_runRaw + state fuel computation hnotStopped hresult).elim + | true => simp [LazyRevealProbe.DetailedResult.hit] + | done hit finalState remaining value => + cases hit with + | false => + simp only [Bool.false_eq_true, ↓reduceIte, Functor.map_map, Function.comp_apply, + Option.isNone_some, LazyRevealProbe.DetailedResult.hit] + apply evalDist_ext + intro output + rw [probOutput_map_const] + have hmass : Pr[⊥ | sampleOtsHashTable] = 0 := by + rw [sampleOtsHashTable] + exact probFailure_uniformSample _ + rw [hmass] + simp + | true => simp [LazyRevealProbe.DetailedResult.hit] + +set_option maxRecDepth 100000 in +theorem evalDist_map_isNone_detailedExperimentClean_eq_hit + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe fuel) : + 𝒟[Option.isNone <$> detailedExperimentCleanWithCompletionTable state fuel computation] = + 𝒟[LazyRevealProbe.DetailedResult.hit <$> + LazyRevealProbe.detailedExperiment state fuel computation] := + evalDist_map_isNone_detailedExperimentClean_eq_hit_of_not_stopped_false computation state fuel + (LazyRevealProbe.stopped_false_not_mem_support_runRaw state fuel computation hbound) + +theorem probEvent_detailedExperimentClean_none_eq_hit_of_not_stopped_false + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (hnotStopped : LazyRevealProbe.RawResult.stopped false ∉ support + (LazyRevealProbe.runRaw state fuel computation)) : + Pr[= none | detailedExperimentCleanWithCompletionTable state fuel computation] = + Pr[= true | LazyRevealProbe.experiment state fuel computation] := by + calc + _ = Pr[= true | + Option.isNone <$> detailedExperimentCleanWithCompletionTable state fuel computation] := by + have hmap := _root_.probEvent_map + (mx := detailedExperimentCleanWithCompletionTable state fuel computation) + (f := Option.isNone) (q := fun hit : Bool => hit = true) + simpa [Function.comp_def] using hmap.symm + _ = Pr[= true | LazyRevealProbe.DetailedResult.hit <$> + LazyRevealProbe.detailedExperiment state fuel computation] := by + exact OracleComp.probOutput_congr rfl + (evalDist_map_isNone_detailedExperimentClean_eq_hit_of_not_stopped_false computation state + fuel hnotStopped) + _ = _ := by + exact OracleComp.probOutput_congr (x := true) (y := true) rfl + (LazyRevealProbe.evalDist_detailedExperiment_hit_eq_experiment_of_not_stopped_false + state fuel computation hnotStopped) + +theorem probEvent_detailedExperimentClean_none_eq_hit + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe fuel) : + Pr[= none | detailedExperimentCleanWithCompletionTable state fuel computation] = + Pr[= true | LazyRevealProbe.experiment state fuel computation] := by + calc + _ = Pr[= true | + Option.isNone <$> detailedExperimentCleanWithCompletionTable state fuel computation] := by + have hmap := _root_.probEvent_map + (mx := detailedExperimentCleanWithCompletionTable state fuel computation) + (f := Option.isNone) (q := fun hit : Bool => hit = true) + simpa [Function.comp_def] using hmap.symm + _ = Pr[= true | LazyRevealProbe.DetailedResult.hit <$> + LazyRevealProbe.detailedExperiment state fuel computation] := by + exact OracleComp.probOutput_congr rfl + (evalDist_map_isNone_detailedExperimentClean_eq_hit computation state fuel hbound) + _ = _ := by + rw [LazyRevealProbe.detailedExperiment_hit_eq_experiment state fuel computation hbound] + +noncomputable def sampledRunThenFinalizeClean + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) : + ProbComp (Option (CleanRunResult alpha)) := do + let base ← ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)) + let result ← runCleanFromTable state fuel (completedStartTable state base) computation + finishCleanRunFromTable result + +theorem probEvent_sampledRunThenFinalizeClean_empty_none_le + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (fuel : Nat) (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe fuel) : + Pr[= none | sampledRunThenFinalizeClean + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel computation] ≤ + (fuel : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ = Pr[= none | detailedExperimentCleanWithCompletionTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel computation] := + OracleComp.probOutput_congr rfl + (by + unfold sampledRunThenFinalizeClean + exact evalDist_runThenFinalizeCleanFromTable_eq_detailed computation + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel) + _ = Pr[= true | LazyRevealProbe.experiment + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel computation] := + probEvent_detailedExperimentClean_none_eq_hit computation + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel hbound + _ ≤ _ := by + rw [← probEvent_eq_eq_probOutput] + exact LazyRevealProbe.experiment_empty_probability_le fuel computation + +theorem probEvent_sampledRunThenFinalizeClean_empty_none_le_of_not_stopped_false + (computation : OracleComp (LazyRevealProbe.World Coordinate) alpha) + (fuel : Nat) + (hnotStopped : LazyRevealProbe.RawResult.stopped false ∉ support + (LazyRevealProbe.runRaw + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel computation)) : + Pr[= none | sampledRunThenFinalizeClean + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel computation] ≤ + (fuel : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ = Pr[= none | detailedExperimentCleanWithCompletionTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel computation] := + OracleComp.probOutput_congr rfl + (by + unfold sampledRunThenFinalizeClean + exact evalDist_runThenFinalizeCleanFromTable_eq_detailed computation + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel) + _ = Pr[= true | LazyRevealProbe.experiment + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel computation] := + probEvent_detailedExperimentClean_none_eq_hit_of_not_stopped_false computation + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel hnotStopped + _ ≤ _ := by + rw [← probEvent_eq_eq_probOutput] + exact LazyRevealProbe.experiment_empty_probability_le fuel computation + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeSampledGuessRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSampledGuessRisk.lean new file mode 100644 index 00000000..6edf4c6a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSampledGuessRisk.lean @@ -0,0 +1,139 @@ +import SphincsSecurity.Proof.OtsProbeRetainedGuessCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option backward.isDefEq.respectTransparency false + +noncomputable def structuralCandidateFailureAllowance (context : DeferredContext) : Option Probe → ℝ≥0∞ + | none => 0 + | some candidate => + if candidate.coordinate ∈ context.state.revealed ∨ + (candidate.coordinate, candidate.candidate) ∈ context.state.pending then 0 + else match candidate.coordinate with + | .chainStart _ _ _ _ => 0 + | .position position => match context.positionValue position with + | none => 0 + | some output => if truncateHash output = candidate.candidate then 1 else 0 + +theorem expected_candidateFailureAllowance_chainStart_of_missing + (context : DeferredContext) (index : OtsSecretIndex) (digest : Digest) + (hmissing : context.state.values index.coordinate = none) : + (∑' base, Pr[= base | sampleOtsHashTable] * + candidateFailureAllowance (completedStartTable context.state base) context (some ⟨index.coordinate, digest⟩)) ≤ + (unmaterializedCandidateCharge (materializedDeferredState context) (some ⟨index.coordinate, digest⟩) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + classical + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + dsimp only [OtsSecretIndex.coordinate] at hmissing ⊢ + by_cases hrevealed : Coordinate.chainStart lay tree leafIdx chainIdx ∈ context.state.revealed + · simp [candidateFailureAllowance, unmaterializedCandidateCharge, materializedDeferredState, hrevealed] + · by_cases hduplicate : (Coordinate.chainStart lay tree leafIdx chainIdx, digest) ∈ context.state.pending + · simp [candidateFailureAllowance, unmaterializedCandidateCharge, materializedDeferredState, + LazyRevealProbe.pendingProbeCharge, hrevealed, hduplicate, hmissing] + · simp only [candidateFailureAllowance, hrevealed, hduplicate, or_self, ↓reduceIte, + resolvedCompletionValue, completedStartTable, OtsSecretIndex.coordinate, hmissing, Option.getD_none, + unmaterializedCandidateCharge, materializedDeferredState, LazyRevealProbe.pendingProbeCharge, + ne_eq, not_true_eq_false, Nat.cast_one, one_mul] + simpa only [probEvent_eq_tsum_ite, mul_ite, mul_one, mul_zero] using + probEvent_sampleOtsHashTable_cell_truncate_eq ⟨lay, tree, leafIdx, chainIdx⟩ digest + +theorem candidateFailureAllowance_position_eq + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) (position : Position) (digest : Digest) : + candidateFailureAllowance table context (some ⟨.position position, digest⟩) = + (unmaterializedCandidateCharge (materializedDeferredState context) (some ⟨.position position, digest⟩) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + structuralCandidateFailureAllowance context (some ⟨.position position, digest⟩) := by + classical + by_cases hrevealed : Coordinate.position position ∈ context.state.revealed + · simp [candidateFailureAllowance, unmaterializedCandidateCharge, materializedDeferredState, + structuralCandidateFailureAllowance, hrevealed] + · by_cases hduplicate : (Coordinate.position position, digest) ∈ context.state.pending + · simp [candidateFailureAllowance, unmaterializedCandidateCharge, materializedDeferredState, + structuralCandidateFailureAllowance, LazyRevealProbe.pendingProbeCharge, hrevealed, hduplicate] + · cases hvalue : context.positionValue position <;> + simp [candidateFailureAllowance, resolvedCompletionValue, unmaterializedCandidateCharge, + materializedDeferredState, structuralCandidateFailureAllowance, LazyRevealProbe.pendingProbeCharge, + hrevealed, hduplicate, hvalue] + +theorem expected_candidateFailureAllowance_le_ordinary_add_structural + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) (candidate : Option Probe) + (hcanonical : CanonicalMaterializedValues table context) : + (∑' base, Pr[= base | sampleOtsHashTable] * + candidateFailureAllowance (completedStartTable context.state base) context candidate) ≤ + (unmaterializedCandidateCharge (materializedDeferredState context) candidate : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + structuralCandidateFailureAllowance context candidate := by + classical + cases candidate with + | none => simp [candidateFailureAllowance, unmaterializedCandidateCharge, structuralCandidateFailureAllowance] + | some candidate => + rcases candidate with ⟨coordinate, digest⟩ + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + by_cases hrevealed : Coordinate.chainStart lay tree leafIdx chainIdx ∈ context.state.revealed + · simp [candidateFailureAllowance, unmaterializedCandidateCharge, materializedDeferredState, + structuralCandidateFailureAllowance, hrevealed] + · have hmissing : context.state.values (.chainStart lay tree leafIdx chainIdx) = none := by + rw [hcanonical] + simp [publicMaterializedValues, hrevealed] + simpa [structuralCandidateFailureAllowance, OtsSecretIndex.coordinate] using + expected_candidateFailureAllowance_chainStart_of_missing context ⟨lay, tree, leafIdx, chainIdx⟩ digest hmissing + | position position => + simp_rw [candidateFailureAllowance_position_eq] + rw [ENNReal.tsum_mul_right, tsum_probOutput_eq_one' (by simp), one_mul] + +theorem executeCandidate_ordinaryCharge_eq_of_positive_fuel + (candidate : Option Probe) (cache : SplitHashCache) (context : DeferredContext) (fuel : Nat) : + ordinaryContinuationCharge (fun _ _ _ => 0) ((executeCandidate? candidate).run cache) context (fuel + 1) = + (unmaterializedCandidateCharge context.state candidate : ℝ≥0∞) := by + cases candidate with + | none => simp [executeCandidate?, ordinaryContinuationCharge, unmaterializedCandidateCharge] + | some candidate => + change ordinaryContinuationCharge (fun _ _ _ => 0) + (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate >>= fun _ => pure ((), cache)) + context (fuel + 1) = _ + rw [LazyRevealProbe.probeQuery, ordinaryContinuationCharge_query_bind, ordinaryChargeStep.eq_def] + by_cases hrevealed : candidate.coordinate ∈ context.state.revealed <;> + simp [hrevealed, ordinaryContinuationCharge, unmaterializedCandidateCharge] + +theorem expected_canonicalHashQuery_finished_le_ordinary_add_structural + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (input : HashInput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hcanonical : CanonicalMaterializedValues table context) + (hcard : context.state.pending.card + 1 < Fintype.card Digest) : + (∑' base, Pr[= base | sampleOtsHashTable] * Pr[fun verdict => verdict = true | + canonicalChronologicalAdversaryImpl parameter root (completedStartTable context.state base) ftsSecret + (.inl (.inr input)) context (fuel + 1) (completedStartTable context.state base) cache >>= + finishResolvedRunIsNone]) ≤ + (∑' base, Pr[= base | sampleOtsHashTable] * + resolvedContextFailureRisk (completedStartTable context.state base) context) + + ordinaryContinuationCharge (fun _ _ _ => 0) + ((probingHashQueryAfterPublicPlan parameter input context.state + (purePlanProbingHashQuery parameter input context.state)).run cache) + (materializedDeferredContext context) (fuel + 1) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + structuralCandidateFailureAllowance context (purePlanProbingHashQuery parameter input context.state).candidate? := by + rw [probingHashQueryAfterPublicPlan_ordinaryCharge_eq_executeCandidate, + executeCandidate_ordinaryCharge_eq_of_positive_fuel] + calc + _ ≤ ∑' base, Pr[= base | sampleOtsHashTable] * + (resolvedContextFailureRisk (completedStartTable context.state base) context + + candidateFailureAllowance (completedStartTable context.state base) context + (purePlanProbingHashQuery parameter input context.state).candidate?) := by + apply ENNReal.tsum_le_tsum + intro base + exact mul_le_mul_right (probEvent_canonicalHashQuery_finished_le_initial_add_allowance + parameter root (completedStartTable context.state base) ftsSecret input context fuel cache hconsistent + (startTableAgrees_completedStartTable context.state base) hcard) _ + _ = _ + ∑' base, Pr[= base | sampleOtsHashTable] * + candidateFailureAllowance (completedStartTable context.state base) context + (purePlanProbingHashQuery parameter input context.state).candidate? := by + simp_rw [mul_add] + rw [ENNReal.tsum_add] + _ ≤ _ := by + rw [add_assoc] + exact add_le_add le_rfl + (expected_candidateFailureAllowance_le_ordinary_add_structural table context _ hcanonical) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeSampledJointRootRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSampledJointRootRisk.lean new file mode 100644 index 00000000..93e90a9b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSampledJointRootRisk.lean @@ -0,0 +1,78 @@ +import SphincsSecurity.Proof.OtsProbeInitializedJointRootRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem uniformTable_gameRefinedReserve_le_sampledSecrets + (adversary : Adversary) (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + (∑' table, Pr[= table | sampleOtsHashTable] * + expectedQueryCharge (otsOpeningRefinedQueryReserve + (primitiveAccountingKey parameter (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret)) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) ∅) ≤ + ∑' otsSecret, Pr[= otsSecret | sampleOtsSecrets] * + expectedQueryCharge (otsOpeningRefinedQueryReserve (primitiveAccountingKey parameter otsSecret ftsSecret)) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ := by + have hbound := expected_cost_le_of_relTriple relTriple_uniformOtsHashTable_sampleOtsSecrets + (fun table => expectedQueryCharge (otsOpeningRefinedQueryReserve + (primitiveAccountingKey parameter (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret)) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) ∅) + (fun otsSecret => expectedQueryCharge (otsOpeningRefinedQueryReserve (primitiveAccountingKey parameter otsSecret ftsSecret)) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅) + (fun _ => 0) (by + intro table otsSecret hsecrets + rw [← hsecrets, add_zero] + exact le_rfl) + simpa only [sampleOtsHashTable, mul_zero, tsum_zero, add_zero] using hbound + +noncomputable def sampledInitializedChargedRootRisk + (targets roots : Finset Position) (adversary : Adversary) (fuel q : Nat) : ENNReal := + ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * initializedChargedRootRisk targets roots adversary parameter ftsSecret fuel q + +theorem sampledInitializedNativeDirectRisk_add_chargedRootRisk_le_refinedReserve + (targets roots : Finset Position) (hsubset : roots ⊆ targets) + (hroot : ∀ target ∈ roots, IsLayerRoot target) (hne : ∀ target ∈ roots, target ≠ layerRootPosition topLayer rootTree) + (adversary : Adversary) (fuel q : Nat) (hq : q ≤ 2 ^ 126) : + sampledInitializedNativeDirectRisk targets adversary fuel q + + sampledInitializedChargedRootRisk targets roots adversary fuel q ≤ + sampledQueryCharge otsOpeningRefinedQueryReserve adversary * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + calc + _ = ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + (initializedNativeDirectRisk targets adversary parameter ftsSecret fuel q + + initializedChargedRootRisk targets roots adversary parameter ftsSecret fuel q) := by + simp only [sampledInitializedNativeDirectRisk, sampledInitializedChargedRootRisk, mul_add, ENNReal.tsum_add] + _ ≤ ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + ((∑' otsSecret, Pr[= otsSecret | sampleOtsSecrets] * + expectedQueryCharge (otsOpeningRefinedQueryReserve (primitiveAccountingKey parameter otsSecret ftsSecret)) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + apply ENNReal.tsum_le_tsum + intro parameter + apply mul_le_mul' le_rfl + apply ENNReal.tsum_le_tsum + intro ftsSecret + apply mul_le_mul' le_rfl + exact (initializedNativeDirectRisk_add_chargedRootRisk_le_gameReserve targets roots hsubset hroot hne + adversary parameter ftsSecret fuel q hq).trans + (mul_le_mul' (uniformTable_gameRefinedReserve_le_sampledSecrets adversary parameter ftsSecret) le_rfl) + _ = _ := by + unfold sampledQueryCharge + simp only [sampleSecrets, tsum_probOutput_bind_mul, tsum_probOutput_pure_mul, primitiveAccountingKey] + simp only [← ENNReal.tsum_mul_left, ← ENNReal.tsum_mul_right, mul_assoc] + apply tsum_congr + intro parameter + rw [ENNReal.tsum_comm] + apply tsum_congr + intro otsSecret + apply tsum_congr + intro ftsSecret + ring + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeSampling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSampling.lean new file mode 100644 index 00000000..37957781 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSampling.lean @@ -0,0 +1,263 @@ +import SphincsSecurity.Proof.OtsProbeTerminal +import VCVio.OracleComp.QueryTracking.RandomOracle.EagerTable + +/-! +# One-time secret sampler transport + +The lazy probe game samples full hash outputs at opaque chain-start coordinates. Truncating an +independent uniform table of those outputs gives exactly the concrete curried one-time secret +sampler. This finite coordinate type contains no structural `Position` and therefore does not +invoke its expensive `Fintype` enumeration. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec +open OracleComp.ProgramLogic.Relational + +structure OtsSecretIndex where + lay : Layer + tree : TreeIndex + leafIdx : LeafIndex + chainIdx : ChainIndex +deriving Fintype, DecidableEq + +def OtsSecretIndex.coordinate (index : OtsSecretIndex) : Coordinate := + .chainStart index.lay index.tree index.leafIdx index.chainIdx + +theorem OtsSecretIndex.coordinate_injective : + Function.Injective OtsSecretIndex.coordinate := by + intro left right heq + cases left + cases right + simpa [OtsSecretIndex.coordinate] using heq + +def otsSecretTableEquiv : + (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) ≃ + (OtsSecretIndex → Digest) where + toFun secret index := secret index.lay index.tree index.leafIdx index.chainIdx + invFun table lay tree leafIdx chainIdx := table ⟨lay, tree, leafIdx, chainIdx⟩ + left_inv secret := by rfl + right_inv table := by + funext index + cases index + rfl + +def piProdEquiv (D A B : Type) : (D → A × B) ≃ (D → A) × (D → B) where + toFun table := (fun index => (table index).1, fun index => (table index).2) + invFun tables index := (tables.1 index, tables.2 index) + left_inv table := by rfl + right_inv tables := by rfl + +noncomputable def splitOtsSecretTableEquiv : + (OtsSecretIndex → HashOutput) ≃ + (OtsSecretIndex → Digest) × + (OtsSecretIndex → BitVec (hashOutputBits - digestBits)) := + (Equiv.piCongrRight fun _ => splitHashOutputEquiv digestBits (by decide)).trans + (piProdEquiv OtsSecretIndex Digest (BitVec (hashOutputBits - digestBits))) + +theorem splitOtsSecretTableEquiv_fst (table : OtsSecretIndex → HashOutput) : + (splitOtsSecretTableEquiv table).1 = fun index => truncateHash (table index) := by + rfl + +theorem tableOtsSecret_eq_otsSecretTable + (table : Coordinate → HashOutput) : + tableOtsSecret table = otsSecretTableEquiv.symm + (fun index => truncateHash (table index.coordinate)) := by + rfl + +set_option maxRecDepth 10000 in +theorem relTriple_sampleHashOutput_sampleDigest : + RelTriple LazyRevealProbe.sampleHashOutput ($ᵗ Digest : ProbComp Digest) + fun output digest => truncateHash output = digest := by + let split := splitHashOutputEquiv digestBits (by decide) + let pairSample := + ($ᵗ (Digest × BitVec (hashOutputBits - digestBits)) : + ProbComp (Digest × BitVec (hashOutputBits - digestBits))) + have hpair : RelTriple pairSample pairSample fun left right => + truncateHash (split.symm left) = right.1 := by + apply relTriple_post_mono (relTriple_refl pairSample) + intro left right heq + subst right + change (split (split.symm left)).1 = left.1 + rw [split.apply_symm_apply] + have hmapped : + RelTriple (split.symm <$> pairSample) (Prod.fst <$> pairSample) + (fun output digest => truncateHash output = digest) := + relTriple_map + (R := fun output digest => truncateHash output = digest) hpair + have hleft : + 𝒟[split.symm <$> pairSample] = 𝒟[LazyRevealProbe.sampleHashOutput] := by + rw [LazyRevealProbe.sampleHashOutput] + exact evalDist_map_bijective_uniform_cross _ split.symm split.symm.bijective + have hright : + 𝒟[Prod.fst <$> pairSample] = 𝒟[($ᵗ Digest : ProbComp Digest)] := + evalDist_map_fst_uniformSample_prod + exact relTriple_of_evalDist_eq_right hright + (relTriple_of_evalDist_eq_left hleft.symm hmapped) + +noncomputable local instance sampleableOtsSecretTable : + SampleableType (OtsSecretIndex → Digest) := + SampleableType.ofFintype (OtsSecretIndex → Digest) + +noncomputable local instance sampleableOtsHashTable : + SampleableType (OtsSecretIndex → HashOutput) := + SampleableType.ofFintype (OtsSecretIndex → HashOutput) + +noncomputable local instance sampleableOtsHighTable : + SampleableType (OtsSecretIndex → BitVec (hashOutputBits - digestBits)) := + SampleableType.ofFintype + (OtsSecretIndex → BitVec (hashOutputBits - digestBits)) + +noncomputable local instance sampleableSplitOtsTable : + SampleableType + ((OtsSecretIndex → Digest) × + (OtsSecretIndex → BitVec (hashOutputBits - digestBits))) := + SampleableType.ofFintype _ + +noncomputable local instance sampleableOtsSecrets : + SampleableType (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) := + otsSecretsSampleableType + +attribute [local semireducible] sampleOtsSecrets + +theorem evalDist_sampleOtsSecrets_uncurry : + 𝒟[otsSecretTableEquiv <$> sampleOtsSecrets] = + 𝒟[($ᵗ (OtsSecretIndex → Digest) : ProbComp (OtsSecretIndex → Digest))] := by + rw [show sampleOtsSecrets = + ($ᵗ (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) : + ProbComp (Layer → TreeIndex → LeafIndex → ChainIndex → Digest)) by rfl] + exact evalDist_map_bijective_uniform_cross _ otsSecretTableEquiv + otsSecretTableEquiv.bijective + +set_option maxRecDepth 10000 in +theorem evalDist_lazyOtsSecrets_eq_sampled + (computation : OracleComp (OtsSecretIndex →ₒ Digest) alpha) : + 𝒟[(simulateQ + (randomOracle : QueryImpl (OtsSecretIndex →ₒ Digest) + (StateT (QueryCache (OtsSecretIndex →ₒ Digest)) ProbComp)) + computation).run' (∅ : QueryCache (OtsSecretIndex →ₒ Digest))] = + 𝒟[do + let secret ← sampleOtsSecrets + pure (evalWithAnswerFn + (QueryImpl.ofFn (spec := OtsSecretIndex →ₒ Digest) + (otsSecretTableEquiv secret)) computation)] := by + let evaluate := fun table : OtsSecretIndex → Digest => + evalWithAnswerFn (QueryImpl.ofFn (spec := OtsSecretIndex →ₒ Digest) table) + computation + calc + _ = 𝒟[evaluate <$> + ($ᵗ (OtsSecretIndex → Digest) : ProbComp (OtsSecretIndex → Digest))] := by + simpa [evaluate, bind_pure_comp] using + (OracleComp.evalDist_simulateQ_randomOracle_run'_empty_eq_uniformTable computation) + _ = 𝒟[evaluate <$> (otsSecretTableEquiv <$> sampleOtsSecrets)] := by + rw [evalDist_map, evalDist_map] + exact congrArg (Functor.map evaluate) evalDist_sampleOtsSecrets_uncurry.symm + _ = _ := by + simp [evaluate, Functor.map_map] + +set_option maxRecDepth 10000 in +theorem evalDist_uniformOtsHashTable_truncate : + 𝒟[(fun table : OtsSecretIndex → HashOutput => + otsSecretTableEquiv.symm (fun index => truncateHash (table index))) <$> + ($ᵗ (OtsSecretIndex → HashOutput) : ProbComp (OtsSecretIndex → HashOutput))] = + 𝒟[sampleOtsSecrets] := by + let split := splitOtsSecretTableEquiv + have hsplit : + 𝒟[split <$> ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput))] = + 𝒟[($ᵗ ((OtsSecretIndex → Digest) × + (OtsSecretIndex → BitVec (hashOutputBits - digestBits))) : + ProbComp ((OtsSecretIndex → Digest) × + (OtsSecretIndex → BitVec (hashOutputBits - digestBits))))] := + evalDist_map_bijective_uniform_cross _ split split.bijective + have hfst : + 𝒟[Prod.fst <$> ($ᵗ ((OtsSecretIndex → Digest) × + (OtsSecretIndex → BitVec (hashOutputBits - digestBits))) : + ProbComp ((OtsSecretIndex → Digest) × + (OtsSecretIndex → BitVec (hashOutputBits - digestBits))))] = + 𝒟[($ᵗ (OtsSecretIndex → Digest) : ProbComp (OtsSecretIndex → Digest))] := + evalDist_map_fst_uniformSample_prod + have hcurried : + 𝒟[otsSecretTableEquiv.symm <$> + ($ᵗ (OtsSecretIndex → Digest) : ProbComp (OtsSecretIndex → Digest))] = + 𝒟[($ᵗ (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) : + ProbComp (Layer → TreeIndex → LeafIndex → ChainIndex → Digest))] := + evalDist_map_bijective_uniform_cross _ otsSecretTableEquiv.symm + otsSecretTableEquiv.symm.bijective + have hmapper : + (fun table : OtsSecretIndex → HashOutput => + otsSecretTableEquiv.symm (fun index => truncateHash (table index))) = + (fun table : OtsSecretIndex → HashOutput => + otsSecretTableEquiv.symm (Prod.fst (split table))) := by + funext table + rw [splitOtsSecretTableEquiv_fst] + have hcomputation : + (fun table : OtsSecretIndex → HashOutput => + otsSecretTableEquiv.symm (fun index => truncateHash (table index))) <$> + ($ᵗ (OtsSecretIndex → HashOutput) : ProbComp (OtsSecretIndex → HashOutput)) = + otsSecretTableEquiv.symm <$> (Prod.fst <$> (split <$> + ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput)))) := by + simp only [Functor.map_map] + rw [hmapper] + calc + _ = 𝒟[otsSecretTableEquiv.symm <$> (Prod.fst <$> (split <$> + ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput))))] := congrArg evalDist hcomputation + _ = 𝒟[otsSecretTableEquiv.symm <$> (Prod.fst <$> + ($ᵗ ((OtsSecretIndex → Digest) × + (OtsSecretIndex → BitVec (hashOutputBits - digestBits))) : + ProbComp ((OtsSecretIndex → Digest) × + (OtsSecretIndex → BitVec (hashOutputBits - digestBits)))))] := by + rw [evalDist_map, evalDist_map, hsplit, ← evalDist_map, ← evalDist_map] + _ = 𝒟[otsSecretTableEquiv.symm <$> + ($ᵗ (OtsSecretIndex → Digest) : ProbComp (OtsSecretIndex → Digest))] := by + rw [evalDist_map, hfst, ← evalDist_map] + _ = 𝒟[($ᵗ (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) : + ProbComp (Layer → TreeIndex → LeafIndex → ChainIndex → Digest))] := hcurried + _ = 𝒟[sampleOtsSecrets] := by rfl + +set_option maxRecDepth 30000 in +theorem relTriple_uniformOtsHashTable_sampleOtsSecrets : + RelTriple + (($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput))) + sampleOtsSecrets + fun table secret => + otsSecretTableEquiv.symm + (fun index => truncateHash (table index)) = secret := by + let truncateTable := fun table : OtsSecretIndex → HashOutput => + otsSecretTableEquiv.symm (fun index => truncateHash (table index)) + have hself : RelTriple + (($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput))) + (($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput))) + fun left right => left = right := + relTriple_refl _ + have hmapped : RelTriple + (($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput))) + (truncateTable <$> + ($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput))) + fun table secret => truncateTable table = secret := by + have htruncate : RelTriple + (($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput))) + (($ᵗ (OtsSecretIndex → HashOutput) : + ProbComp (OtsSecretIndex → HashOutput))) + fun left right => truncateTable left = truncateTable right := by + apply relTriple_post_mono hself + intro left right heq + rw [heq] + simpa [truncateTable] using + (relTriple_map + (R := fun table secret => truncateTable table = secret) + (f := id) (g := truncateTable) htruncate) + exact relTriple_of_evalDist_eq_right + (by simpa [truncateTable] using evalDist_uniformOtsHashTable_truncate) + hmapped + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeSelectedRootPrehit.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSelectedRootPrehit.lean new file mode 100644 index 00000000..988f3591 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSelectedRootPrehit.lean @@ -0,0 +1,163 @@ +import SphincsSecurity.Proof.OtsProbeQueryCutPrehit + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +set_option maxRecDepth 100000 in +theorem relTriple_canonicalQuerySelection_prehitCut + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (accountingKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (state : ViewedFullTraceState × Bool) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) state.1.cache) + (hvisible : VisibleResolvedComputationsCached parameter table context state.1.cache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + RelTriple (canonicalQuerySelection parameter root ftsSecret computation ordinal context fuel table cache) + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) + (outerQueryCutAt computation ordinal)).run state) + (fun selection result => + CanonicalQuerySelectionRel parameter table selection (actualSelectionOfPrehitCut result) ∧ + result ∈ support ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) + (outerQueryCutAt computation ordinal)).run state)) := by + classical + dsimp only + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + have hcanonical := relTriple_canonicalQuerySelection_actualQuerySelection parameter root table ftsSecret + computation ordinal context fuel cache state.1.cache hinvariant hvisible hpublished hcomputed + have hmonitor := relTriple_of_evalDist_map_eq_with_support_general + (actualQuerySelection secretKey computation ordinal state.1.cache) + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) + (outerQueryCutAt computation ordinal)).run state) + id actualSelectionOfPrehitCut (by + rw [id_map, actualSelectionOfPrehitCut_projection]) + apply relTriple_post_mono (relTriple_trans_exists hcanonical hmonitor) + rintro selection result ⟨actual, hrelation, hproject, _hactual, hsupport⟩ + exact ⟨hproject ▸ hrelation, hsupport⟩ + +set_option maxRecDepth 100000 in +theorem CanonicalQuerySelectionRel.cut_root_settled_value + {accountingKey : SecretKey} {table : OtsSecretIndex → HashOutput} + {selection : CanonicalQuerySelection} {cut : OuterQueryCut α} {state : ViewedFullTraceState × Bool} + (hrelation : CanonicalQuerySelectionRel accountingKey.parameter table (some selection) + (actualSelectionOfPrehitCut (cut, state))) + (hsecrets : accountingKey.otsSecret = fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + (lay : Layer) (tree : TreeIndex) (output : HashOutput) + (hvalue : selection.context.positionValue (layerRootPosition lay tree) = some output) : + Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret state.1.cache + (layerRootPosition lay tree) ∧ + honestValue (fromCache state.1.cache) accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret + (layerRootPosition lay tree) = truncateHash output := by + cases cut with + | done value => exact False.elim hrelation + | query input next => + obtain ⟨_hinput, _htable, hinvariant, _hvisible, _hpublished, hcomputed⟩ := hrelation + rw [hsecrets] + exact hcomputed.root_settled_value hinvariant accountingKey.ftsSecret lay tree output hvalue + +set_option maxRecDepth 100000 in +theorem EncodingLayerRootCandidateAt.ne_stored_root_of_prehitFree_queryCut + {accountingKey : SecretKey} (secretKey : SecretKey) {table : OtsSecretIndex → HashOutput} + {initialState finalState : ViewedFullTraceState} {selection : CanonicalQuerySelection} + {previous : HashInput} {candidate : Probe} {lay : Layer} {tree : TreeIndex} {output : HashOutput} + (hcandidate : EncodingLayerRootCandidateAt accountingKey.parameter previous candidate) + (hposition : candidate.coordinate = .position (layerRootPosition lay tree)) + (hcached : initialState.cache previous ≠ none) + (hbefore : ¬Settled accountingKey.parameter accountingKey.otsSecret accountingKey.ftsSecret + initialState.cache (layerRootPosition lay tree)) + (hsecrets : accountingKey.otsSecret = fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + (hvalue : selection.context.positionValue (layerRootPosition lay tree) = some output) + (computation : OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) (cut : OuterQueryCut α) + (hrelation : CanonicalQuerySelectionRel accountingKey.parameter table (some selection) + (actualSelectionOfPrehitCut (cut, (finalState, false)))) + (hrun : (cut, (finalState, false)) ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) + (outerQueryCutAt computation ordinal)).run (initialState, false))) : + candidate.candidate ≠ truncateHash output := by + have hroot := hrelation.cut_root_settled_value hsecrets lay tree output hvalue + have hne := hcandidate.ne_honestValue_of_prehitFree_viewed_continuation secretKey + hposition hcached hbefore hroot.1 (outerQueryCutAt computation ordinal) cut hrun + simpa only [hroot.2] using hne + +set_option maxRecDepth 100000 in +theorem EncodingLayerRootCandidateAt.refinedReserve_of_prehitFree_matching_queryCut + {accountingKey : SecretKey} (secretKey : SecretKey) {table : OtsSecretIndex → HashOutput} + {initialState finalState : ViewedFullTraceState} {selection : CanonicalQuerySelection} + {input : HashInput} {candidate : Probe} {lay : Layer} {tree : TreeIndex} {output : HashOutput} + (hcandidate : EncodingLayerRootCandidateAt accountingKey.parameter input candidate) + (hposition : candidate.coordinate = .position (layerRootPosition lay tree)) + (hsecrets : accountingKey.otsSecret = fun lay tree leafIdx chainIdx => + truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + (hvalue : selection.context.positionValue (layerRootPosition lay tree) = some output) + (hmatch : candidate.candidate = truncateHash output) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) (cut : OuterQueryCut α) + (hrelation : CanonicalQuerySelectionRel accountingKey.parameter table (some selection) + (actualSelectionOfPrehitCut (cut, (finalState, false)))) + (hrun : (cut, (finalState, false)) ∈ support + ((simulateQ (encodingPrehitViewedAdversaryImpl accountingKey secretKey) + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= fun answer => + outerQueryCutAt (next answer) ordinal)).run (initialState, false))) : + (4 / 3 : ℝ≥0∞) ≤ otsOpeningRefinedQueryReserve accountingKey initialState.cache input := by + have hroot := hrelation.cut_root_settled_value hsecrets lay tree output hvalue + exact hcandidate.refinedReserve_of_prehitFree_viewed_matching_query secretKey hposition hroot.1 + (hmatch.trans hroot.2.symm) (fun answer => outerQueryCutAt (next answer) ordinal) cut hrun + + +def SelectedLayerRootMatch (lay : Layer) (tree : TreeIndex) (candidate : Digest) : + Option CanonicalQuerySelection → Prop + | none => False + | some selection => ∃ output, + selection.context.positionValue (layerRootPosition lay tree) = some output ∧ truncateHash output = candidate + +set_option maxRecDepth 100000 in +theorem probEvent_selectedRootMatch_le_prehit_of_insufficientReserve + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (input : HashInput) (candidate : Probe) (lay : Layer) (tree : TreeIndex) + (hcandidate : EncodingLayerRootCandidateAt parameter input candidate) + (hposition : candidate.coordinate = .position (layerRootPosition lay tree)) + (next : HashOutput → OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (state : ViewedFullTraceState) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) state.cache) + (hvisible : VisibleResolvedComputationsCached parameter table context state.cache) + (hpublished : PublishedValues context.state) (hcomputed : DeferredComputationsClosed context) : + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + otsOpeningRefinedQueryReserve secretKey state.cache input < (4 / 3 : ℝ≥0∞) → + Pr[SelectedLayerRootMatch lay tree candidate.candidate | + canonicalQuerySelection parameter root ftsSecret + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next) + (ordinal + 1) context fuel table cache] ≤ + Pr[fun result => result.2.2 = true | + (simulateQ (encodingPrehitViewedAdversaryImpl secretKey secretKey) + (outerQueryCutAt + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next) + (ordinal + 1))).run (state, false)] := by + let secretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + dsimp only + intro hreserve + have hcoupling := relTriple_canonicalQuerySelection_prehitCut parameter root table ftsSecret secretKey + ((OracleWorld + SigningSpec).query (.inl (.inr input)) >>= next) + (ordinal + 1) context fuel cache (state, false) hinvariant hvisible hpublished hcomputed + apply probEvent_le_of_relTriple hcoupling + rintro selection ⟨cut, finalState, hit⟩ hrelation hmatch + cases hit with + | true => rfl + | false => + cases selection with + | none => exact False.elim hmatch + | some selection => + obtain ⟨output, hvalue, hmatch⟩ := hmatch + have hallowance := hcandidate.refinedReserve_of_prehitFree_matching_queryCut secretKey + (accountingKey := secretKey) hposition rfl hvalue hmatch.symm next ordinal cut + hrelation.1 hrelation.2 + exact False.elim ((not_le_of_gt hreserve) hallowance) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeSelectionHistory.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSelectionHistory.lean new file mode 100644 index 00000000..0ae86e6b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSelectionHistory.lean @@ -0,0 +1,175 @@ +import SphincsSecurity.Proof.OtsProbeSelectionTransport125 +import SphincsSecurity.Proof.OtsProbeJointCostCoupling +import SphincsSecurity.Proof.OtsProbeSuccessfulHiddenCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +def FreshExistingHiddenSelection (ordinal : Nat) : Option PermissivePrivateOrdinalSelection → Prop + | none => False + | some selection => + (cleanProbeObservation selection.state selection.candidate.coordinate + selection.candidate.candidate).ExistingHiddenHit ∧ + selection.candidate ∉ selection.candidates.take ordinal + +theorem PrivateOrdinalSelection.GoodForActualRoot.candidate_not_mem_prefix + {selection : PrivateOrdinalSelection} {target : Position} {output : HashOutput} {ordinal : Nat} + (hgood : selection.GoodForActualRoot target output ordinal) : + selection.candidate ∉ selection.candidates.take ordinal := by + intro hmem + exact hgood.2.2.2.2 selection.candidate hmem hgood.1 + +theorem canonicalSelectionPreserved_goodForActualRoot + {left : PrivateOrdinalSelection} {right : Option PermissivePrivateOrdinalSelection} + {target : Position} {output : HashOutput} {ordinal : Nat} + (hrel : CanonicalSelectionPreserved (some left) right) + (hgood : left.GoodForActualRoot target output ordinal) : + FreshExistingHiddenSelection ordinal right := by + cases right with + | none => exact False.elim hrel + | some right => + have hcandidate : right.candidate = ⟨.position target, truncateHash output⟩ := + hrel.1.symm.trans hgood.1 + have hhidden : Coordinate.position target ∉ right.state.revealed := by + rw [← hrel.2.1.revealed] + exact hgood.2.2.1 + have hvalue : right.state.values (.position target) = some output := by + rw [← hrel.2.1.values] + simp only [materializedDeferredState, DeferredContext.positionValue, + hgood.2.1, hgood.2.2.2.1] + refine ⟨?_, ?_⟩ + · simp only [hcandidate] + exact ⟨by simpa [cleanProbeObservation] using hhidden, output, hvalue, rfl⟩ + · rw [← hrel.2.2, ← hrel.1] + exact hgood.candidate_not_mem_prefix + +theorem freshExistingHiddenSelection_materializedCharge_eq_one + {selection : PermissivePrivateOrdinalSelection} {ordinal : Nat} + (hfresh : FreshExistingHiddenSelection ordinal (some selection)) + (hcovered : ∀ coordinate candidate, (coordinate, candidate) ∈ selection.state.pending → + (⟨coordinate, candidate⟩ : Probe) ∈ selection.candidates.take ordinal) : + materializedCandidateCharge selection.state (some selection.candidate) = 1 := by + apply materializedCandidateCharge_eq_one_of_existingHiddenHit selection.state selection.candidate hfresh.1 + intro hpending + exact hfresh.2 (hcovered _ _ hpending) + +theorem probEvent_canonical_actualRoot_le_delayed_freshHiddenSelection + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun source => ∃ selection target output, source = some selection ∧ + selection.GoodForActualRoot target output ordinal | + granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret fuel] ≤ + Pr[FreshExistingHiddenSelection ordinal | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret fuel table] := by + apply probEvent_le_of_relTriple + (relTriple_granularAllCanonicalPrivateOrdinalSelection_preserved ordinal adversary parameter table ftsSecret fuel) + intro left right hrel hevent + obtain ⟨selection, target, output, rfl, hgood⟩ := hevent + exact canonicalSelectionPreserved_goodForActualRoot hrel hgood + +theorem probEvent_canonical_snapshot_hit_le_delayed_freshHiddenSelection + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret fuel] ≤ + Pr[FreshExistingHiddenSelection ordinal | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret fuel table] := by + apply le_trans _ (probEvent_canonical_actualRoot_le_delayed_freshHiddenSelection + ordinal adversary parameter table ftsSecret fuel) + apply probEvent_le_of_relTriple + (relTriple_granularAllCanonicalSnapshot_privateOrdinalSelection_supported ordinal adversary + parameter table ftsSecret fuel) + intro source selection hrelation hhit + obtain ⟨selected, target, output, _hordinal, hselected, hgood⟩ := + selectedPrivateSnapshotOrdinal?_goodForActualRoot hhit + exact ⟨privateOrdinalSelectionOfSnapshot selected, target, output, + hrelation.1.symm.trans hselected, hgood⟩ + +theorem probEvent_sampledSuccessfulFirstHit_le_delayed_freshHiddenSelection126 + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenHitAt ordinal | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + ∑' table, Pr[= table | sampleOtsHashTable] * + Pr[FreshExistingHiddenSelection ordinal | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret q table] := by + apply (Range125.probEvent_sampledSuccessfulFirstHit_le_selectedSnapshot + adversary parameter ftsSecret q ordinal hbound hq).trans + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot + rw [probEvent_bind_eq_tsum] + apply ENNReal.tsum_le_tsum + intro table + exact mul_le_mul' le_rfl + (probEvent_canonical_snapshot_hit_le_delayed_freshHiddenSelection + ordinal adversary parameter table ftsSecret q) + +noncomputable def sampledFreshHiddenRisk (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) : ℝ≥0∞ := + ∑ ordinal : Fin q, ∑' table, Pr[= table | sampleOtsHashTable] * + Pr[FreshExistingHiddenSelection ordinal.val | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal.val adversary parameter ftsSecret q table] + +theorem probEvent_sampledDiagnostic_successfulHidden_le_freshHiddenRisk126 + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[ObservedMaterializedDiagnostic.SuccessfulHiddenHit | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + sampledFreshHiddenRisk adversary parameter ftsSecret q := by + apply (probEvent_sampledDiagnostic_successfulHidden_le_sum_firstHits126 + adversary parameter ftsSecret q hbound hq).trans + apply Finset.sum_le_sum + intro ordinal _ + exact (probEvent_sampledDiagnostic_successfulHidden_firstHit_le_raw + adversary parameter ftsSecret (2 * q) ordinal.val).trans + (probEvent_sampledSuccessfulFirstHit_le_delayed_freshHiddenSelection126 + adversary parameter ftsSecret q ordinal.val hbound hq) + +theorem probEvent_sampledActualRetained_verifyProbe_le_charge_add_freshHiddenRisk126 + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + materializedRetainedCharge adversary parameter ftsSecret (2 * q) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + sampledFreshHiddenRisk adversary parameter ftsSecret q := + (probEvent_sampledActualRetained_verifyProbe_le_charge_add_successfulHiddenHit126 + adversary parameter ftsSecret q hbound hq).trans + (add_le_add le_rfl + (probEvent_sampledDiagnostic_successfulHidden_le_freshHiddenRisk126 + adversary parameter ftsSecret q hbound hq)) + +theorem probEvent_sampledActualRetained_verifyProbe_le_charge_add_freshHiddenRisk126_of_hashQueryBound + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + materializedRetainedCharge adversary parameter ftsSecret (2 * q) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + sampledFreshHiddenRisk adversary parameter ftsSecret q := + probEvent_sampledActualRetained_verifyProbe_le_charge_add_freshHiddenRisk126 adversary parameter ftsSecret q + (fun table root => isQueryBoundP_expandedRetained_all_tables_roots + adversary q hq parameter hparameter table ftsSecret hfts root) hqMax + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeSelectionPending.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSelectionPending.lean new file mode 100644 index 00000000..07ee0644 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSelectionPending.lean @@ -0,0 +1,240 @@ +import SphincsSecurity.Proof.OtsProbeSelectionHistory + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxRecDepth 100000 + +theorem pendingCoveredBy_of_mem_runPermissiveFromTable + (candidates : List Probe) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (result : CleanRunResult α) + (hcovered : PendingCoveredBy candidates (directDeferredContext state)) + (hbound : computation.IsQueryBoundP (IsUncoveredProbe candidates) 0) + (hresult : some result ∈ support (runPermissiveFromTable state fuel table computation)) : + PendingCoveredBy candidates (directDeferredContext result.state) := by + induction computation using OracleComp.inductionOn generalizing state fuel with + | pure value => + simp [runPermissiveFromTable] at hresult + rcases hresult with ⟨rfl, rfl, rfl, rfl⟩ + exact hcovered + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + cases input with + | uniform n => + rw [runPermissiveFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output state fuel hcovered (hbound.2 output) htail + | hashOutput => + rw [runPermissiveFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output state fuel hcovered (hbound.2 output) htail + | ensure coordinate => + rw [runPermissiveFromTable_ensure_query_bind] at hresult + exact ih () (state.ensure coordinate) fuel hcovered (hbound.2 ()) hresult + | probe coordinate digest => + have hmem : (⟨coordinate, digest⟩ : Probe) ∈ candidates := by + simpa [IsUncoveredProbe] using hbound.1 + have htail : (next ()).IsQueryBoundP (IsUncoveredProbe candidates) 0 := by + simpa [IsUncoveredProbe] using hbound.2 () + rw [runPermissiveFromTable_probe_query_bind] at hresult + cases fuel with + | zero => simp at hresult + | succ remaining => + by_cases hrevealed : coordinate ∈ state.revealed + · simp only [hrevealed, ↓reduceIte] at hresult + exact ih () state remaining hcovered htail hresult + · simp only [hrevealed, ↓reduceIte] at hresult + exact ih () (state.addPending coordinate digest) remaining + (hcovered.addPending_of_mem ⟨coordinate, digest⟩ hmem) htail hresult + | peek coordinate => + rw [runPermissiveFromTable_peek_query_bind] at hresult + exact ih (state.values coordinate) state fuel hcovered (hbound.2 _) hresult + | publish coordinate => + rw [runPermissiveFromTable_publish_query_bind] at hresult + exact ih () (state.publish coordinate) fuel hcovered (hbound.2 ()) hresult + | reveal coordinate => + rw [runPermissiveFromTable_reveal_query_bind] at hresult + cases hstate : state.values coordinate with + | some output => + simp only [hstate] at hresult + exact ih output state fuel hcovered (hbound.2 output) hresult + | none => + simp only [hstate] at hresult + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact ih _ (state.materialize (.chainStart lay tree leafIdx chainIdx) + (table ⟨lay, tree, leafIdx, chainIdx⟩)) fuel + (hcovered.clearPending _) (hbound.2 _) hresult + | position position => + rw [mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output (state.materialize (.position position) output) fuel + (hcovered.clearPending _) (hbound.2 output) htail + +theorem probingHashQueryAfterPublicPlan_uncoveredProbeBound + (parameter : PublicParameter) (input : HashInput) (publicState : LazyRevealProbe.State Coordinate) + (plan : PlannedHashQuery) (candidates : List Probe) + (hplanned : ∀ candidate, plan.candidate? = some candidate → candidate ∈ candidates) + (cache : SplitHashCache) : + ((probingHashQueryAfterPublicPlan parameter input publicState plan).run cache).IsQueryBoundP + (IsUncoveredProbe candidates) 0 := by + unfold probingHashQueryAfterPublicPlan + rw [StateT.run_bind] + apply OracleComp.isQueryBoundP_bind (n := 0) (m := 0) + · cases hopt : plan.candidate? with + | none => simp [executeCandidate?] + | some candidate => + have hmem := hplanned candidate hopt + change (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate).IsQueryBoundP + (IsUncoveredProbe candidates) 0 + unfold LazyRevealProbe.probeQuery + rw [OracleComp.isQueryBoundP_query_iff] + simp [IsUncoveredProbe, hmem] + · intro result _hresult + exact OracleComp.IsQueryBoundP.of_imp (isUncoveredProbe_imp_isProbe candidates) + (probingHashQueryPublicAction_probeFree parameter input publicState plan.action result.2) + +theorem pendingCoveredBy_of_mem_delayedPermissiveDetailedOrdinalSelection + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (state : LazyRevealProbe.State Coordinate) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hcovered : PendingCoveredBy candidates (directDeferredContext state)) + (hlength : candidates.length ≤ ordinal) (selection : PermissivePrivateOrdinalSelection) + (hselection : some selection ∈ support + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates state fuel table cache)) : + PendingCoveredBy (selection.candidates.take ordinal) (directDeferredContext selection.state) := by + induction computation using OracleComp.inductionOn generalizing candidates state fuel cache with + | pure value => + rw [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_pure] at hselection + have hnotSelected : ¬ordinal < candidates.length := by omega + simp [hnotSelected] at hselection + | query_bind query next ih => + rw [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_query_bind] at hselection + have hnotSelected : ¬ordinal < candidates.length := by omega + simp only [hnotSelected, ↓reduceDIte] at hselection + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + rw [mem_support_bind_iff] at hselection + obtain ⟨result, hresult, hfinish⟩ := hselection + cases result with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] at hfinish + | some result => + have hnextCovered := pendingCoveredBy_of_mem_runPermissiveFromTable + candidates ((splitUniformImpl n).run cache) state fuel table result hcovered + (OracleComp.IsQueryBoundP.of_imp (isUncoveredProbe_imp_isProbe candidates) + (splitUniformImpl_probeFree n cache)) hresult + exact ih result.value.1 candidates result.state result.remaining result.value.2 + hnextCovered hlength hfinish + | inr input => + let nextCandidates := permissiveRootAwareCandidates parameter input table state candidates + by_cases hselected : ordinal < nextCandidates.length + · have hactual : ordinal < (permissiveRootAwareCandidates parameter input table state candidates).length := hselected + simp only [hactual, ↓reduceDIte, mem_support_pure_iff, Option.some.injEq] at hselection + subst selection + change PendingCoveredBy (nextCandidates.take ordinal) (directDeferredContext state) + cases hcandidate : rootAwareCandidateForPlan? parameter input + (permissiveRootAwarePlan parameter input table state) with + | none => + have hnextEq : nextCandidates = candidates := by + simp [nextCandidates, permissiveRootAwareCandidates, appendPlannedCandidate, hcandidate] + rw [hnextEq] at hselected + omega + | some candidate => + have hlengthEq : candidates.length = ordinal := by + have hnextLength : nextCandidates.length = candidates.length + 1 := by + simp [nextCandidates, permissiveRootAwareCandidates, appendPlannedCandidate, hcandidate] + omega + have htake : nextCandidates.take ordinal = candidates := by + simp [nextCandidates, permissiveRootAwareCandidates, appendPlannedCandidate, hcandidate, hlengthEq] + rwa [htake] + · have hactual : ¬ordinal < (permissiveRootAwareCandidates parameter input table state candidates).length := hselected + simp only [hactual, ↓reduceDIte] at hselection + rw [mem_support_bind_iff] at hselection + obtain ⟨result, hresult, hfinish⟩ := hselection + cases result with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] at hfinish + | some result => + have hnextCoveredAtStart : PendingCoveredBy nextCandidates (directDeferredContext state) := by + apply hcovered.mono_candidates + unfold nextCandidates permissiveRootAwareCandidates appendPlannedCandidate + cases rootAwareCandidateForPlan? parameter input + (permissiveRootAwarePlan parameter input table state) <;> simp + have hplanMem : ∀ candidate, + (permissiveRootAwarePlan parameter input table state).candidate? = some candidate → + candidate ∈ nextCandidates := by + intro candidate hcandidate + simp [nextCandidates, permissiveRootAwareCandidates, rootAwareCandidateForPlan?, + hcandidate, appendPlannedCandidate] + have hprobeBound := probingHashQueryAfterPublicPlan_uncoveredProbeBound + parameter input (materializedCanonicalContext table state).state + (permissiveRootAwarePlan parameter input table state) nextCandidates hplanMem cache + have hnextCovered := pendingCoveredBy_of_mem_runPermissiveFromTable + nextCandidates (delayedPermissivePublicAction parameter input table state cache) + state fuel table result hnextCoveredAtStart hprobeBound hresult + exact ih result.value.1 nextCandidates result.state result.remaining result.value.2 + hnextCovered (by omega) hfinish + | inr message => + rw [mem_support_bind_iff] at hselection + obtain ⟨result, hresult, hfinish⟩ := hselection + cases result with + | none => simp [finishPermissiveDetailedPrivateOrdinalSelection] at hfinish + | some result => + have hnextCovered := pendingCoveredBy_of_mem_runPermissiveFromTable + candidates ((maskedSign parameter root ftsSecret message).run cache) state fuel table result hcovered + (OracleComp.IsQueryBoundP.of_imp (isUncoveredProbe_imp_isProbe candidates) + (maskedSign_probeFree parameter root ftsSecret message cache)) hresult + exact ih result.value.1 candidates result.state result.remaining result.value.2 + hnextCovered hlength hfinish + +theorem pendingCoveredBy_of_mem_delayedSelectionExperiment + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (selection : PermissivePrivateOrdinalSelection) + (hselection : some selection ∈ support + (delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret fuel table)) : + PendingCoveredBy (selection.candidates.take ordinal) (directDeferredContext selection.state) := by + unfold delayedPermissiveDetailedSelectionExperimentAfterTable at hselection + rw [mem_support_bind_iff] at hselection + obtain ⟨result, hresult, hselection⟩ := hselection + cases result with + | none => simp at hselection + | some result => + have hpending := pending_eq_empty_of_mem_runCleanFromTable_maskedPublishedTreeRoot fuel table result hresult + have hcovered : PendingCoveredBy [] (directDeferredContext result.state) := by + intro entry hentry + change entry ∈ result.state.pending at hentry + simp [hpending] at hentry + exact pendingCoveredBy_of_mem_delayedPermissiveDetailedOrdinalSelection ordinal parameter result.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) [] result.state result.remaining + result.table result.value.2 hcovered (Nat.zero_le _) selection hselection + +theorem freshHiddenSelection_charges_of_mem_delayedSelectionExperiment + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (selection : PermissivePrivateOrdinalSelection) + (hselection : some selection ∈ support + (delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret fuel table)) + (hfresh : FreshExistingHiddenSelection ordinal (some selection)) : + unmaterializedCandidateCharge selection.state (some selection.candidate) = 0 ∧ + materializedCandidateCharge selection.state (some selection.candidate) = 1 := by + refine ⟨unmaterializedCandidateCharge_eq_zero_of_existingHiddenHit selection.state selection.candidate hfresh.1, ?_⟩ + apply freshExistingHiddenSelection_materializedCharge_eq_one hfresh + intro coordinate candidate hpending + have hcovered := pendingCoveredBy_of_mem_delayedSelectionExperiment ordinal adversary parameter ftsSecret + fuel table selection hselection + obtain ⟨probe, hprobe, hcoordinate, hdigest⟩ := hcovered (coordinate, candidate) hpending + have heq : probe = ⟨coordinate, candidate⟩ := by + cases probe + simp_all + rwa [heq] at hprobe + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeSelectionSchedule125.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSelectionSchedule125.lean new file mode 100644 index 00000000..28c981a1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSelectionSchedule125.lean @@ -0,0 +1,222 @@ +import SphincsSecurity.Proof.OtsProbePermissiveFuel125 + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxRecDepth 100000 in +theorem relTriple_delayed_rootAware_permissiveSelection + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (left right : LazyRevealProbe.State Coordinate) + (leftFuel rightFuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hstate : PermissiveStateRel left right) + (hleftFuel : ordinal < candidates.length + leftFuel) + (hrightFuel : ordinal < candidates.length + rightFuel) : + RelTriple + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates left leftFuel table cache) + (permissiveDetailedRootAwareOrdinalSelection ordinal parameter root ftsSecret computation + candidates right rightFuel table cache) + PermissiveDetailedSelectionRel := by + induction computation using OracleComp.inductionOn generalizing + candidates left right leftFuel rightFuel cache with + | pure value => + simp only [delayedPermissiveDetailedOrdinalSelection, + permissiveDetailedRootAwareOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure ⟨rfl, rfl, hstate⟩ + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure trivial + | query_bind query next ih => + rw [delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_query_bind, + permissiveDetailedRootAwareOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure ⟨rfl, rfl, hstate⟩ + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + apply relTriple_bind + (relTriple_runPermissive_probeFree_of_stateRel + ((splitUniformImpl n).run cache) left right leftFuel rightFuel table hstate + (splitUniformImpl_probeFree n cache)) + intro leftResult rightResult hresult + cases leftResult with + | none => exact False.elim hresult + | some leftResult => + cases rightResult with + | none => exact False.elim hresult + | some rightResult => + rcases hresult with ⟨hstate, hleft, hright, hvalue, _htable⟩ + simp only [finishPermissiveDetailedPrivateOrdinalSelection, ← hvalue] + exact ih leftResult.value.1 candidates leftResult.state rightResult.state + leftResult.remaining rightResult.remaining leftResult.value.2 hstate + (by omega) (by omega) + | inr input => + let nextCandidates := permissiveRootAwareCandidates parameter input table left + candidates + have hnext : permissiveRootAwareCandidates parameter input table right candidates = + nextCandidates := + (permissiveRootAwareCandidates_eq_of_stateRel parameter input table candidates + hstate).symm + dsimp only + rw [hnext] + by_cases hnextSelected : ordinal < nextCandidates.length + · simp only [nextCandidates, hnextSelected, ↓reduceDIte] + exact relTriple_pure_pure ⟨rfl, rfl, hstate⟩ + · simp only [nextCandidates, hnextSelected, ↓reduceDIte] + apply relTriple_bind + (relTriple_delayed_rootAware_permissivePublicAction parameter input left right + leftFuel rightFuel table cache hstate (by omega) (by omega)) + intro leftResult rightResult hresult + cases leftResult with + | none => exact False.elim hresult + | some leftResult => + cases rightResult with + | none => exact False.elim hresult + | some rightResult => + rcases hresult with ⟨hstate, hleft, hright, hvalue, _htable⟩ + have hlength : nextCandidates.length = candidates.length + + (rootAwareCandidateForPlan? parameter input + (permissiveRootAwarePlan parameter input table left)).isSome.toNat := + appendPlannedCandidate_length candidates _ + simp only [finishPermissiveDetailedPrivateOrdinalSelection, ← hvalue] + exact ih leftResult.value.1 nextCandidates leftResult.state + rightResult.state leftResult.remaining rightResult.remaining + leftResult.value.2 hstate (by omega) (by omega) + | inr message => + apply relTriple_bind + (relTriple_runPermissive_probeFree_of_stateRel + ((maskedSign parameter root ftsSecret message).run cache) left right leftFuel + rightFuel table hstate (maskedSign_probeFree parameter root ftsSecret message cache)) + intro leftResult rightResult hresult + cases leftResult with + | none => exact False.elim hresult + | some leftResult => + cases rightResult with + | none => exact False.elim hresult + | some rightResult => + rcases hresult with ⟨hstate, hleft, hright, hvalue, _htable⟩ + simp only [finishPermissiveDetailedPrivateOrdinalSelection, ← hvalue] + exact ih leftResult.value.1 candidates leftResult.state rightResult.state + leftResult.remaining rightResult.remaining leftResult.value.2 hstate + (by omega) (by omega) + +def InitialSelectionFuelRel (leftFuel rightFuel : Nat) : + Option (CleanRunResult α) → Option (CleanRunResult α) → Prop + | none, none => True + | some left, some right => PermissiveCleanFuelRel leftFuel rightFuel (some left) (some right) + | _, _ => False + +set_option maxRecDepth 100000 in +theorem relTriple_rootAwareProductionInitialRun_fuel + (leftFuel rightFuel : Nat) (table : OtsSecretIndex → HashOutput) : + RelTriple (rootAwareProductionInitialRun leftFuel table) + (rootAwareProductionInitialRun rightFuel table) + (InitialSelectionFuelRel leftFuel rightFuel) := by + let computation := maskedPublishedTreeRoot.run emptySplitHashCache + have hfree := maskedPublishedTreeRoot_probeFree emptySplitHashCache + have hbase := relTriple_runObservedCleanFromTable_fuel_of_isQueryBoundP computation [] + LazyRevealProbe.State.empty leftFuel rightFuel 0 table hfree (by omega) (by omega) + have hleft := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty leftFuel table computation)) + (fun result hresult => hresult) + have hboth := SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleft + have hproject : RelTriple + (runObservedCleanFromTable [] LazyRevealProbe.State.empty leftFuel table computation) + (runObservedCleanFromTable [] LazyRevealProbe.State.empty rightFuel table computation) + (fun left right => InitialSelectionFuelRel leftFuel rightFuel + (projectObservedCleanRun left) (projectObservedCleanRun right)) := by + apply relTriple_post_mono hboth + intro left right hresult + obtain ⟨⟨hrel, hleft⟩, hright⟩ := hresult + cases left with + | none => + cases right with + | none => trivial + | some right => exact False.elim hrel + | some left => + cases right with + | none => exact False.elim hrel + | some right => + have hleftFuel := remaining_eq_fuel_of_mem_observed_of_probeFree computation [] + LazyRevealProbe.State.empty leftFuel table left hfree hleft + have hrightFuel := remaining_eq_fuel_of_mem_observed_of_probeFree computation [] + LazyRevealProbe.State.empty rightFuel table right hfree hright + exact ⟨⟨congrArg LazyRevealProbe.State.values hrel.1, + congrArg LazyRevealProbe.State.revealed hrel.1⟩, + hleftFuel, hrightFuel, hrel.2.2.1, hrel.2.1⟩ + have hmapped := relTriple_map (f := projectObservedCleanRun) (g := projectObservedCleanRun) + hproject + rw [map_projectObservedCleanRun_runObservedCleanFromTable, + map_projectObservedCleanRun_runObservedCleanFromTable] at hmapped + exact hmapped + +set_option maxRecDepth 100000 in +theorem relTriple_delayed_rootAware_commonSelection + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (leftFuel rightFuel : Nat) (table : OtsSecretIndex → HashOutput) + (hleftFuel : ordinal < leftFuel) (hrightFuel : ordinal < rightFuel) : + RelTriple + (delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret leftFuel table) + (permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret rightFuel table) + PermissiveDetailedSelectionRel := by + unfold delayedPermissiveDetailedSelectionExperimentAfterTable + permissiveDetailedSelectionExperimentAfterTable + apply relTriple_bind (relTriple_rootAwareProductionInitialRun_fuel leftFuel rightFuel table) + intro left right hresult + cases left with + | none => + cases right with + | none => exact relTriple_pure_pure trivial + | some right => exact False.elim hresult + | some left => + cases right with + | none => exact False.elim hresult + | some right => + rcases hresult with ⟨hstate, hleft, hright, hvalue, htable⟩ + simp only [delayedPermissiveDetailedSelectionAfterRootResult, + permissiveDetailedSelectionAfterRootResult, ← hvalue, ← htable] + exact relTriple_delayed_rootAware_permissiveSelection ordinal parameter left.value.1 + ftsSecret (retainedGameRestComputation adversary ⟨left.value.1, parameter⟩) [] + left.state right.state left.remaining right.remaining left.table left.value.2 hstate + (by simpa [hleft]) (by simpa [hright]) + +theorem probEvent_delayedCommon_nonRoot_le_rootAwareCommon + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (leftFuel rightFuel : Nat) (table : OtsSecretIndex → HashOutput) + (hleftFuel : ordinal < leftFuel) (hrightFuel : ordinal < rightFuel) : + Pr[PermissiveSelectionNonRoot | + delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret leftFuel table] ≤ + Pr[PermissiveSelectionNonRoot | + permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret rightFuel table] := by + apply probEvent_le_of_relTriple + (relTriple_delayed_rootAware_commonSelection ordinal adversary parameter ftsSecret + leftFuel rightFuel table hleftFuel hrightFuel) + intro left right hrelation hnonRoot + cases left with + | none => exact False.elim hnonRoot + | some left => + cases right with + | none => exact False.elim hrelation + | some right => + change ¬right.candidate.IsLayerRoot + rw [← hrelation.1] + exact hnonRoot + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeSelectionTransport125.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSelectionTransport125.lean new file mode 100644 index 00000000..b9aedd5d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSelectionTransport125.lean @@ -0,0 +1,479 @@ +import SphincsSecurity.Proof.OtsProbeNonRootSelectionMass125 + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +/-- A successful canonical selection preserves its candidate, history, and materialized shadow. -/ +def CanonicalSelectionPreserved : + Option PrivateOrdinalSelection → Option PermissivePrivateOrdinalSelection → Prop + | none, _ => True + | some _, none => False + | some left, some right => left.candidate = right.candidate ∧ + PermissiveStateRel (materializedDeferredState left.context) right.state ∧ + left.candidates = right.candidates + +theorem relTriple_none_any_selectionPreserved + (right : ProbComp (Option PermissivePrivateOrdinalSelection)) : + RelTriple (pure none : ProbComp (Option PrivateOrdinalSelection)) right + CanonicalSelectionPreserved := by + have hbase := relTriple_true (pure none : ProbComp (Option PrivateOrdinalSelection)) right + have hsupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hbase + (fun value => value = none) (by intro value hvalue; simpa using hvalue) + apply relTriple_post_mono hsupported + intro left right hrelation + rw [hrelation.2] + trivial + +theorem relTriple_selectionPreserved_trans + {left : ProbComp (Option PrivateOrdinalSelection)} + {middle right : ProbComp (Option PermissivePrivateOrdinalSelection)} + (hleft : RelTriple left middle CanonicalSelectionPreserved) + (hright : RelTriple middle right PermissiveDetailedSelectionRel) : + RelTriple left right CanonicalSelectionPreserved := by + apply relTriple_post_mono (SphincsSecurity.relTriple_trans_exists hleft hright) + intro leftSelection rightSelection hrelation + obtain ⟨middleSelection, hfirst, hsecond⟩ := hrelation + cases leftSelection with + | none => trivial + | some leftSelected => + cases middleSelection with + | none => exact False.elim hfirst + | some middleSelected => + cases rightSelection with + | none => exact False.elim hsecond + | some rightSelected => + exact ⟨hfirst.1.trans hsecond.1, + ⟨hfirst.2.1.values.trans hsecond.2.2.values, + hfirst.2.1.revealed.trans hsecond.2.2.revealed⟩, + hfirst.2.2.trans hsecond.2.1⟩ + +set_option maxRecDepth 100000 in +theorem relTriple_finishDirect_selectionPreserved + (table : OtsSecretIndex → HashOutput) + (leftObserve : DeferredContext → Nat → (α × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection)) + (rightObserve : LazyRevealProbe.State Coordinate → Nat → α → SplitHashCache → + List Probe → ProbComp (Option PermissivePrivateOrdinalSelection)) + (leftCandidates rightCandidates : List Probe) + (left : DirectWitnessResult (α × SplitHashCache)) + (right : Option (CleanRunResult (α × SplitHashCache))) + (hrelation : DirectWitnessPermissiveRunRel table left right) + (hrecursive : ∀ leftResult rightResult, + left = .done leftResult → right = some rightResult → + leftResult.value = rightResult.value → + leftResult.remaining = rightResult.remaining → + (materializedDeferredState + (canonicalizeMaterializedValues table leftResult.context)).values = + rightResult.state.values → + (canonicalizeMaterializedValues table leftResult.context).state.revealed = + rightResult.state.revealed → + (canonicalizeMaterializedValues table leftResult.context).Valid → + DeferredCompletable table (canonicalizeMaterializedValues table leftResult.context) → + ChainState.ValidFor (fun _ ↦ True) + (canonicalizeMaterializedValues table leftResult.context).state → + CanonicalMaterializedValues table + (canonicalizeMaterializedValues table leftResult.context) → + PublishedValues + (canonicalizeMaterializedValues table leftResult.context).state → + RelTriple + (leftObserve (canonicalizeMaterializedValues table leftResult.context) + leftResult.remaining leftResult.value leftCandidates) + (rightObserve rightResult.state rightResult.remaining rightResult.value.1 + rightResult.value.2 rightCandidates) + (CanonicalSelectionPreserved)) : + RelTriple + (finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table leftObserve) leftCandidates left) + (finishPermissiveDetailedPrivateOrdinalSelection rightObserve rightCandidates right) + (CanonicalSelectionPreserved) := by + cases left with + | stoppedFuel => + exact relTriple_none_any_selectionPreserved _ + | stoppedOrdinary => + exact relTriple_none_any_selectionPreserved _ + | stoppedPrivate witness => + exact relTriple_none_any_selectionPreserved _ + | done leftResult => + rcases hrelation with hreject | ⟨rightResult, hright, hvalue, hremaining, + _hleftTable, _hrightTable, hrevealed, hmaterialized, hchainValid, hcontext⟩ + · rcases hreject with hprivate | hpublished | hcompletable + · rw [show finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table leftObserve) leftCandidates + (.done leftResult) = pure none by + simp [finishDirectPrivateOrdinalSelection, + canonicalizeDirectPrivateOrdinalSelection, hprivate]] + exact relTriple_none_any_selectionPreserved _ + · rw [show finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table leftObserve) leftCandidates + (.done leftResult) = pure none by + simp [finishDirectPrivateOrdinalSelection, + canonicalizeDirectPrivateOrdinalSelection, hpublished]] + exact relTriple_none_any_selectionPreserved _ + · rw [show finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table leftObserve) leftCandidates + (.done leftResult) = pure none by + simp [finishDirectPrivateOrdinalSelection, + canonicalizeDirectPrivateOrdinalSelection, hcompletable]] + exact relTriple_none_any_selectionPreserved _ + · subst right + let canonical := canonicalizeMaterializedValues table leftResult.context + unfold finishDirectPrivateOrdinalSelection + finishPermissiveDetailedPrivateOrdinalSelection + canonicalizeDirectPrivateOrdinalSelection + by_cases hprivate : PrivateStructuralHit canonical + · simp only [canonical, hprivate, ↓reduceIte] + exact relTriple_none_any_selectionPreserved _ + · simp only [canonical, hprivate, ↓reduceIte] + by_cases hpublished : PublishedValues leftResult.context.state + · simp only [hpublished, ↓reduceIte] + by_cases hcompletable : DeferredCompletable table + (canonicalizeMaterializedValues table leftResult.context) + · simp only [hcompletable, ↓reduceIte] + have hcanonicalMaterialized : + (materializedDeferredState canonical).values = rightResult.state.values := by + rw [ScratchLocal.materializedDeferredState_canonicalize_eq table leftResult.context + hcontext.1.leftStarts hchainValid hcontext.2.1.valuesConsistent] + exact hmaterialized + have hcanonicalRevealed : + canonical.state.revealed = rightResult.state.revealed := by + simpa [canonical, canonicalizeMaterializedValues_revealed] using hrevealed + have hcanonicalValid : canonical.Valid := + canonicalizeMaterializedValues_valid table leftResult.context hcontext.2.1 + hcontext.1.leftClean + have hcanonicalChainValid : ChainState.ValidFor (fun _ ↦ True) canonical.state := + hchainValid.canonicalizeMaterializedValues table hcontext.1.leftStarts + have hcanonicalCanonical : CanonicalMaterializedValues table canonical := + canonicalizeMaterializedValues_canonical table leftResult.context + hcontext.2.1.valuesConsistent + have hcanonicalPublished : PublishedValues canonical.state := + hpublished.to_canonicalizedMaterializedValues + simpa [hvalue, hremaining] using + hrecursive leftResult rightResult rfl rfl hvalue hremaining + hcanonicalMaterialized hcanonicalRevealed hcanonicalValid hcompletable + hcanonicalChainValid hcanonicalCanonical hcanonicalPublished + · simp only [hcompletable, ↓reduceIte] + exact relTriple_none_any_selectionPreserved _ + · simp only [hpublished, ↓reduceIte] + exact relTriple_none_any_selectionPreserved _ + +set_option maxRecDepth 100000 in +theorem relTriple_directBoundary_selectionPreserved + (ordinal : Nat) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (candidates : List Probe) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hvalid : context.Valid) + (hcompletable : DeferredCompletable table context) + (hchainValid : ChainState.ValidFor (fun _ ↦ True) context.state) + (hcanonical : CanonicalMaterializedValues table context) + (hpublished : PublishedValues context.state) + (hhash : DelayedHashActionCouples table parameter) : + RelTriple + (directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret computation + candidates context fuel table cache) + (delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret computation + candidates (materializedDeferredState context) fuel table cache) + (CanonicalSelectionPreserved) := by + induction computation using OracleComp.inductionOn generalizing + candidates context fuel cache with + | pure value => + simp only [directDetailedBoundaryPrivateOrdinalSelection, + delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_pure] + by_cases hselected : ordinal < candidates.length + · simp only [selectedPrivateOrdinal?, hselected, ↓reduceDIte] + exact relTriple_pure_pure ⟨rfl, ⟨rfl, rfl⟩, rfl⟩ + · simp only [selectedPrivateOrdinal?, hselected, ↓reduceDIte] + exact relTriple_pure_pure trivial + | query_bind query next ih => + rw [directDetailedBoundaryPrivateOrdinalSelection, OracleComp.construct_query_bind, + delayedPermissiveDetailedOrdinalSelection, OracleComp.construct_query_bind] + by_cases hselected : ordinal < candidates.length + · simp only [hselected, ↓reduceDIte] + exact relTriple_pure_pure ⟨rfl, ⟨rfl, rfl⟩, rfl⟩ + · simp only [hselected, ↓reduceDIte] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + let leftObserve : DeferredContext → Nat → + (Fin (n + 1) × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection) := + fun nextContext remaining value laterCandidates => + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret + (next value.1) laterCandidates nextContext remaining table value.2 + let rightObserve : LazyRevealProbe.State Coordinate → Nat → Fin (n + 1) → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_runDirectResolvedWitness_runPermissiveFromTable + (splitUniformImpl n) context fuel table cache hvalid hcompletable hchainValid + (preservesChainValid_splitUniformImpl (fun _ ↦ True) n) + (directWitnessFinalizationMaterializedCouples_splitUniformImpl table n)) + intro leftResult rightResult hresult + apply relTriple_finishDirect_selectionPreserved table leftObserve rightObserve candidates candidates leftResult + rightResult hresult + intro nextLeft nextRight _hleft _hright hvalue hremaining hvalues hrevealed + hnextValid hnextCompletable hnextChainValid hnextCanonical hnextPublished + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hbase := ih nextLeft.value.1 candidates canonical nextLeft.remaining + nextLeft.value.2 hnextValid hnextCompletable hnextChainValid + hnextCanonical hnextPublished + have hstate : PermissiveStateRel (materializedDeferredState canonical) + nextRight.state := ⟨hvalues, hrevealed⟩ + have htransport := + relTriple_delayedPermissiveDetailedOrdinalSelection_of_stateRel ordinal + parameter root ftsSecret (next nextLeft.value.1) candidates candidates + (materializedDeferredState canonical) nextRight.state nextLeft.remaining table + nextLeft.value.2 rfl hstate + simpa only [leftObserve, rightObserve, canonical, ← hvalue, ← hremaining] using + relTriple_selectionPreserved_trans + hbase htransport + | inr input => + let plan := purePlanProbingHashQuery parameter input context.state + let nextCandidates := appendPlannedCandidate candidates + (rootAwarePlannedCandidate? parameter input context.state) + have hrightCandidates : + permissiveRootAwareCandidates parameter input table + (materializedDeferredState context) candidates = nextCandidates := by + exact permissiveRootAwareCandidates_materializedDeferredState_eq parameter input + table context candidates hvalid hcompletable hcanonical + by_cases hnextSelected : ordinal < nextCandidates.length + · have hrightSelected : ordinal < + (permissiveRootAwareCandidates parameter input table + (materializedDeferredState context) candidates).length := by + rwa [hrightCandidates] + simp only [nextCandidates, hnextSelected, hrightSelected, ↓reduceDIte] + have hcandidate : + nextCandidates.get ⟨ordinal, hnextSelected⟩ = + (permissiveRootAwareCandidates parameter input table + (materializedDeferredState context) candidates).get + ⟨ordinal, hrightSelected⟩ := by + rw [List.get_eq_getElem, List.get_eq_getElem] + simp only [hrightCandidates] + apply relTriple_pure_pure + exact ⟨hcandidate, ⟨rfl, rfl⟩, hrightCandidates.symm⟩ + · have hrightSelected : ¬ordinal < + (permissiveRootAwareCandidates parameter input table + (materializedDeferredState context) candidates).length := by + rwa [hrightCandidates] + simp only [nextCandidates, hnextSelected, hrightSelected, ↓reduceDIte] + let leftObserve : DeferredContext → Nat → + (HashOutput × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection) := + fun nextContext remaining value laterCandidates => + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root + ftsSecret (next value.1) laterCandidates nextContext remaining table value.2 + let rightObserve : LazyRevealProbe.State Coordinate → Nat → HashOutput → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_bind (hhash input context fuel cache hvalid hcompletable + hchainValid hcanonical hpublished) + intro leftResult rightResult hresult + apply relTriple_finishDirect_selectionPreserved + table leftObserve rightObserve nextCandidates + (permissiveRootAwareCandidates parameter input table + (materializedDeferredState context) candidates) + leftResult rightResult hresult + intro nextLeft nextRight _hleft _hright hvalue hremaining hvalues hrevealed + hnextValid hnextCompletable hnextChainValid hnextCanonical hnextPublished + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hbase := ih nextLeft.value.1 nextCandidates canonical nextLeft.remaining + nextLeft.value.2 hnextValid hnextCompletable hnextChainValid + hnextCanonical hnextPublished + have hstate : PermissiveStateRel (materializedDeferredState canonical) + nextRight.state := ⟨hvalues, hrevealed⟩ + have htransport := + relTriple_delayedPermissiveDetailedOrdinalSelection_of_stateRel ordinal + parameter root ftsSecret (next nextLeft.value.1) nextCandidates + (permissiveRootAwareCandidates parameter input table + (materializedDeferredState context) candidates) + (materializedDeferredState canonical) nextRight.state nextLeft.remaining + table nextLeft.value.2 hrightCandidates.symm hstate + simpa only [leftObserve, rightObserve, canonical, ← hvalue, ← hremaining] using + relTriple_selectionPreserved_trans + hbase htransport + | inr message => + let leftObserve : DeferredContext → Nat → + (Option Signature × SplitHashCache) → List Probe → + ProbComp (Option PrivateOrdinalSelection) := + fun nextContext remaining value laterCandidates => + directDetailedBoundaryPrivateOrdinalSelection ordinal parameter root ftsSecret + (next value.1) laterCandidates nextContext remaining table value.2 + let rightObserve : LazyRevealProbe.State Coordinate → Nat → Option Signature → + SplitHashCache → List Probe → + ProbComp (Option PermissivePrivateOrdinalSelection) := + fun nextState remaining output nextCache laterCandidates => + delayedPermissiveDetailedOrdinalSelection ordinal parameter root ftsSecret + (next output) laterCandidates nextState remaining table nextCache + apply relTriple_bind + (relTriple_runDirectResolvedWitness_runPermissiveFromTable + (maskedSign parameter root ftsSecret message) context fuel table cache hvalid + hcompletable hchainValid + (preservesChainValid_maskedSign_true parameter root ftsSecret message) + (directWitnessFinalizationMaterializedCouples_maskedSign table parameter root + ftsSecret message)) + intro leftResult rightResult hresult + apply relTriple_finishDirect_selectionPreserved table leftObserve rightObserve candidates candidates leftResult + rightResult hresult + intro nextLeft nextRight _hleft _hright hvalue hremaining hvalues hrevealed + hnextValid hnextCompletable hnextChainValid hnextCanonical hnextPublished + let canonical := canonicalizeMaterializedValues table nextLeft.context + have hbase := ih nextLeft.value.1 candidates canonical nextLeft.remaining + nextLeft.value.2 hnextValid hnextCompletable hnextChainValid + hnextCanonical hnextPublished + have hstate : PermissiveStateRel (materializedDeferredState canonical) + nextRight.state := ⟨hvalues, hrevealed⟩ + have htransport := + relTriple_delayedPermissiveDetailedOrdinalSelection_of_stateRel ordinal parameter + root ftsSecret (next nextLeft.value.1) candidates candidates + (materializedDeferredState canonical) nextRight.state nextLeft.remaining table + nextLeft.value.2 rfl hstate + simpa only [leftObserve, rightObserve, canonical, ← hvalue, ← hremaining] using + relTriple_selectionPreserved_trans + hbase htransport + +set_option maxRecDepth 100000 in +theorem relTriple_finishGranularPrivateOrdinalSelection_preserved + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (leftResult : DirectWitnessResult (Digest × SplitHashCache)) + (rightResult : Option (CleanRunResult (Digest × SplitHashCache))) + (hresult : DirectWitnessPermissiveRunRel table leftResult rightResult) : + RelTriple + (finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (granularPrivateOrdinalSelectionObserve ordinal adversary parameter table ftsSecret)) [] + leftResult) + (finishDelayedPermissiveDetailedSelection ordinal adversary parameter table ftsSecret + rightResult) + (CanonicalSelectionPreserved) := by + unfold finishDelayedPermissiveDetailedSelection + apply relTriple_finishDirect_selectionPreserved table + (granularPrivateOrdinalSelectionObserve ordinal adversary parameter table ftsSecret) + (delayedPermissiveDetailedSelectionObserve ordinal adversary parameter table ftsSecret) + [] [] leftResult rightResult hresult + intro left right _hleft _hright hvalue hremaining hvalues hrevealed hvalid hcompletable + hchainValid hcanonical hpublished + have hbase := relTriple_directBoundary_selectionPreserved ordinal + parameter left.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨left.value.1, parameter⟩) [] + (canonicalizeMaterializedValues table left.context) left.remaining table left.value.2 + hvalid hcompletable hchainValid hcanonical hpublished (delayedHashActionCouples table parameter) + have hstate : PermissiveStateRel + (materializedDeferredState (canonicalizeMaterializedValues table left.context)) right.state := + ⟨hvalues, hrevealed⟩ + have htransport := + relTriple_delayedPermissiveDetailedOrdinalSelection_of_stateRel ordinal parameter left.value.1 + ftsSecret (retainedGameRestComputation adversary ⟨left.value.1, parameter⟩) [] [] + (materializedDeferredState (canonicalizeMaterializedValues table left.context)) right.state + left.remaining table left.value.2 rfl hstate + simpa only [granularPrivateOrdinalSelectionObserve, delayedPermissiveDetailedSelectionObserve, + ← hvalue, ← hremaining] using + relTriple_selectionPreserved_trans hbase htransport + +set_option maxRecDepth 100000 in +theorem relTriple_granularAllCanonicalPrivateOrdinalSelection_preserved + (ordinal : Nat) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (fuel : Nat) : + RelTriple + (granularAllCanonicalPrivateOrdinalSelection ordinal adversary parameter table ftsSecret fuel) + (delayedPermissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter + ftsSecret fuel table) + (CanonicalSelectionPreserved) := by + rw [granularAllCanonicalPrivateOrdinalSelection_eq_bind_finish] + unfold delayedPermissiveDetailedSelectionExperimentAfterTable rootAwareProductionInitialRun + have hempty : materializedDeferredState emptyWitnessDeferredContext = + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) := by + unfold materializedDeferredState emptyWitnessDeferredContext LazyRevealProbe.State.empty + rw [LazyRevealProbe.State.mk.injEq] + refine ⟨rfl, ?_, rfl, rfl⟩ + funext coordinate + cases coordinate <;> rfl + have hinitial : RelTriple + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache)) + (runCleanFromTable (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)) + (DirectWitnessPermissiveRunRel table) := by + rw [← hempty] + exact relTriple_runDirectResolvedWitness_runCleanFromTable maskedPublishedTreeRoot + emptyWitnessDeferredContext fuel table emptySplitHashCache DeferredContext.valid_empty + (deferredCompletable_empty table) + (by simp [ChainState.ValidFor, emptyWitnessDeferredContext, + LazyRevealProbe.State.empty]) + preservesChainValid_maskedPublishedTreeRoot_true + (directWitnessFinalizationMaterializedCouples_maskedPublishedTreeRoot table) + refine relTriple_bind + (R := DirectWitnessPermissiveRunRel table) + hinitial ?_ + intro leftResult rightResult hresult + have hfixed := relTriple_finishGranularPrivateOrdinalSelection_preserved ordinal adversary + parameter table ftsSecret leftResult rightResult hresult + cases leftResult with + | stoppedFuel => + exact relTriple_none_any_selectionPreserved _ + | stoppedOrdinary => + exact relTriple_none_any_selectionPreserved _ + | stoppedPrivate witness => + exact relTriple_none_any_selectionPreserved _ + | done leftResult => + rcases hresult with hreject | ⟨cleanResult, hright, hvalue, hremaining, + hleftTable, hrightTable, hrevealed, hmaterialized, hchainValid, hcontext⟩ + · rcases hreject with hprivate | hpublished | hcompletable + · rw [show finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (granularPrivateOrdinalSelectionObserve ordinal adversary parameter table + ftsSecret)) [] (.done leftResult) = pure none by + simp [finishDirectPrivateOrdinalSelection, + canonicalizeDirectPrivateOrdinalSelection, hprivate]] + exact relTriple_none_any_selectionPreserved _ + · rw [show finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (granularPrivateOrdinalSelectionObserve ordinal adversary parameter table + ftsSecret)) [] (.done leftResult) = pure none by + simp [finishDirectPrivateOrdinalSelection, + canonicalizeDirectPrivateOrdinalSelection, hpublished]] + exact relTriple_none_any_selectionPreserved _ + · rw [show finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (granularPrivateOrdinalSelectionObserve ordinal adversary parameter table + ftsSecret)) [] (.done leftResult) = pure none by + simp [finishDirectPrivateOrdinalSelection, + canonicalizeDirectPrivateOrdinalSelection, hcompletable]] + exact relTriple_none_any_selectionPreserved _ + · subst rightResult + change RelTriple + (finishDirectPrivateOrdinalSelection + (canonicalizeDirectPrivateOrdinalSelection table + (granularPrivateOrdinalSelectionObserve ordinal adversary parameter table + ftsSecret)) [] (.done leftResult)) + (delayedPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret cleanResult) + (CanonicalSelectionPreserved) + rw [show delayedPermissiveDetailedSelectionAfterRootResult ordinal adversary parameter + ftsSecret cleanResult = + finishDelayedPermissiveDetailedSelection ordinal adversary parameter table ftsSecret + (some cleanResult) by + simp only [delayedPermissiveDetailedSelectionAfterRootResult, + finishDelayedPermissiveDetailedSelection, + finishPermissiveDetailedPrivateOrdinalSelection, + delayedPermissiveDetailedSelectionObserve] + rw [hrightTable]] + exact hfixed + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeSettledNativeValue.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSettledNativeValue.lean new file mode 100644 index 00000000..a001258d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSettledNativeValue.lean @@ -0,0 +1,80 @@ +import SphincsSecurity.Proof.OtsProbeNativeRootQueryCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem IsOtsPosition.child {position child : Position} + (hots : IsOtsPosition position) (hchild : child ∈ position.children) : IsOtsPosition child := by + cases position with + | chain lay tree leafIdx chainIdx step => + simp only [Position.children] at hchild + split_ifs at hchild <;> simp_all [IsOtsPosition] + | leaf lay tree leafIdx => + simp only [Position.children, List.mem_ofFn] at hchild + obtain ⟨chainIdx, rfl⟩ := hchild + trivial + | node lay tree level nodeIdx => + simp only [Position.children] at hchild + split_ifs at hchild <;> simp_all [IsOtsPosition] + all_goals rcases hchild with rfl | rfl <;> trivial + | ftsLeaf | ftsNode | ftsRoots => contradiction + +theorem ChronologicalCacheAgrees.computed_value_of_settled + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {cache : QueryCache HashSpec} + (hcache : ChronologicalCacheAgrees parameter table context cache) + (completion : Coordinate → HashOutput) (hcompletion : DeferredCompletion table context completion) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (position : Position) (hots : IsOtsPosition position) + (hsettled : Settled parameter (tableOtsSecret completion) ftsSecret cache position) : + DeferredPositionComputed context position ∧ + honestValue (fromCache cache) parameter (tableOtsSecret completion) ftsSecret position = + tableValue completion position := by + have hchildren : ∀ child ∈ position.children, + DeferredPositionComputed context child ∧ + honestValue (fromCache cache) parameter (tableOtsSecret completion) ftsSecret child = tableValue completion child := by + intro child hchild + exact hcache.computed_value_of_settled completion hcompletion ftsSecret child (hots.child hchild) + (hsettled.children child hchild) + have hinput := honestInput_eq_tableInput_of_children (fromCache cache) parameter completion ftsSecret + position hots hsettled.valid (fun child hchild => (hchildren child hchild).2) + have hquery := hcache completion hcompletion position hots + have hcached := hsettled.cached + change cache (honestInput (fromCache cache) parameter (tableOtsSecret completion) ftsSecret position) ≠ none at hcached + rw [hinput] at hcached + cases hvalue : context.positionValue position with + | none => + simp only [ResolveInputAgrees, hvalue] at hquery + exact False.elim (hcached hquery) + | some output => + simp only [ResolveInputAgrees, hvalue] at hquery + refine ⟨.intro position hots hsettled.valid ⟨output, hvalue⟩ (fun child hchild => (hchildren child hchild).1), ?_⟩ + rw [honestValue, hinput, tableValue, hcompletion.eq_positionValue position output hvalue] + simp [fromCache, hquery] +termination_by position.depth +decreasing_by exact Position.depth_lt_of_mem_children (by assumption) + +theorem ResolvedContextInvariant.positionValue_of_settled + {secretKey : SecretKey} {table : OtsSecretIndex → HashOutput} + {context : DeferredContext} {ordinaryCache cache : QueryCache HashSpec} + (hinvariant : ResolvedContextInvariant secretKey.parameter table context ordinaryCache cache) + (hsecrets : secretKey.otsSecret = fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) + {position : Position} (hots : IsOtsPosition position) + (hsettled : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position) : + ∃ output, context.positionValue position = some output ∧ + honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret secretKey.ftsSecret position = truncateHash output := by + obtain ⟨completion, hcompletion⟩ := hinvariant.2.2.2.1 + have hkey : secretKey.otsSecret = tableOtsSecret completion := hsecrets.trans hcompletion.tableOtsSecret_eq.symm + rw [hkey] at hsettled + have hcomputed := hinvariant.1.computed_value_of_settled completion hcompletion secretKey.ftsSecret position hots hsettled + cases hcomputed.1 with + | intro _ _ _ hknown _ => + obtain ⟨output, houtput⟩ := hknown + refine ⟨output, houtput, ?_⟩ + rw [hkey, hcomputed.2, tableValue, hcompletion.eq_positionValue position output houtput] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeSigningChainFailureCoupling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSigningChainFailureCoupling.lean new file mode 100644 index 00000000..410b12b0 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSigningChainFailureCoupling.lean @@ -0,0 +1,216 @@ +import SphincsSecurity.Proof.OtsProbeSigningChainPublication +import SphincsSecurity.Proof.OtsProbeSigningFailureCoupling + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +def SigningChainFailureRunRel (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (left : Option (ResolvedRunResult (α × SplitHashCache))) (right : α × QueryCache HashSpec) : Prop := + ReachableResolvedRunRel parameter table left right ∧ + ∀ result, left = some result → DeferredCompletable table result.context → + MaterializedChainsPublished result.context ∨ CachedOtsEncodingFailure right.2 + +theorem relTriple_signAfterDigest_chainFailure + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) (hstarts : MaterializedChainsPublished context) : + RelTriple + (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves).run cache)) + ((concreteSignAfterDigestFromTable parameter root table ftsSecret randomness index leaves).run concreteCache) + (SigningChainFailureRunRel parameter table) := by + have hbase := reachableResolvedCouples_maskedPublishedChronologicalSignAfterDigest_concrete + parameter root table ftsSecret randomness index leaves context fuel cache concreteCache hinvariant hvisible hpublished + have hleft := FtsProbeSimulation.relTriple_and_left_support hbase + (fun left => left ∈ support (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves).run cache))) + (fun _ h => h) + apply relTriple_post_mono (FtsProbeSimulation.relTriple_and_right_support hleft) + intro left right hrel + refine ⟨hrel.1.1, ?_⟩ + intro result heq hcomplete + subst left + by_cases hsuccess : result.value.1 ≠ none + · exact Or.inl (materializedChainsPublished_of_mem_successful_signAfterDigest parameter ftsSecret randomness index leaves + context fuel table cache result hstarts hrel.1.2 hsuccess) + · have hfailed : result.value.1 = none := not_not.mp hsuccess + have hvalue : result.value.1 = right.1 := by + rcases hrel.1.1 with hclean | hdoomed + · exact hclean.2.1 + · exact False.elim (hdoomed.2.2.2 hcomplete) + right + apply cachedOtsEncodingFailure_of_mem_signAfterDigest_none parameter root table ftsSecret randomness index leaves + concreteCache right.2 + have hright : right = (none, right.2) := Prod.ext (hvalue.symm.trans hfailed) rfl + rw [← hright] + exact hrel.2 + +theorem relTriple_chainFailure_of_doomed + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (computation : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) + (right : ProbComp (α × QueryCache HashSpec)) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hdoomed : DoomedResolvedContext table context) : + RelTriple (runResolvedFromTable context fuel table (computation.run cache)) right + (SigningChainFailureRunRel parameter table) := by + have hbase := relTriple_runResolvedFromTable_of_doomed_reachable parameter table computation right context fuel cache hdoomed + have hsupported := FtsProbeSimulation.relTriple_and_left_support hbase + (fun left => left ∈ support (runResolvedFromTable context fuel table (computation.run cache))) (fun _ h => h) + apply relTriple_post_mono hsupported + intro left right hrel + refine ⟨hrel.1, ?_⟩ + intro result heq hcomplete + subst left + exact False.elim (not_deferredCompletable_of_mem_runResolvedFromTable (computation.run cache) + context fuel table result hdoomed.1 hdoomed.2.1 hrel.2 hdoomed.2.2 hcomplete) + +theorem relTriple_chainFailure_pure + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) (value : α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) (hstarts : MaterializedChainsPublished context) : + RelTriple + (runResolvedFromTable context fuel table ((pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α).run cache)) + (pure (value, concreteCache) : ProbComp _) (SigningChainFailureRunRel parameter table) := by + simp only [StateT.run_pure, runResolvedFromTable] + apply relTriple_pure_pure + refine ⟨Or.inl ⟨rfl, rfl, hinvariant, hvisible, hpublished⟩, ?_⟩ + intro result heq _ + cases heq + exact Or.inl hstarts + +theorem relTriple_chainFailure_bind_publicPrefix + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (left : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) + (right : StateT (QueryCache HashSpec) ProbComp α) + (leftNext : α → StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) β) + (rightNext : α → StateT (QueryCache HashSpec) ProbComp β) + (hprefix : ReachableResolvedCouples parameter table left right) + (hnext : ∀ value context fuel cache concreteCache, + ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache → + VisibleResolvedComputationsCached parameter table context concreteCache → PublishedValues context.state → + MaterializedChainsPublished context → + RelTriple (runResolvedFromTable context fuel table ((leftNext value).run cache)) + ((rightNext value).run concreteCache) (SigningChainFailureRunRel parameter table)) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hstarts : ∀ result, some result ∈ support (runResolvedFromTable context fuel table (left.run cache)) → + MaterializedChainsPublished result.context) : + RelTriple (runResolvedFromTable context fuel table ((left >>= leftNext).run cache)) + ((right >>= rightNext).run concreteCache) (SigningChainFailureRunRel parameter table) := by + rw [StateT.run_bind, StateT.run_bind, runResolvedFromTable_bind] + have hbase := hprefix context fuel cache concreteCache hinvariant hvisible hpublished + have hsupported := FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support (runResolvedFromTable context fuel table (left.run cache))) (fun _ h => h) + apply relTriple_bind hsupported + intro leftResult rightResult hrel + cases leftResult with + | none => + have hbase := relTriple_true + (pure (none : Option (ResolvedRunResult (β × SplitHashCache))) : ProbComp _) + ((rightNext rightResult.1).run rightResult.2) + have hsupported := FtsProbeSimulation.relTriple_and_left_support hbase + (fun finalLeft => finalLeft = none) (by intro finalLeft h; simpa using h) + apply relTriple_post_mono hsupported + intro finalLeft finalRight hfinal + rw [hfinal.2] + exact ⟨True.intro, by intro result h; cases h⟩ + | some result => + rcases hrel.1 with hclean | hdoomed + · rcases rightResult with ⟨rightValue, rightCache⟩ + have hvalue : result.value.1 = rightValue := hclean.2.1 + subst rightValue + simpa only [hclean.1] using hnext result.value.1 result.context result.remaining result.value.2 rightCache + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 (hstarts result hrel.2) + · simpa only [hdoomed.1] using relTriple_chainFailure_of_doomed parameter table + (leftNext result.value.1) ((rightNext rightResult.1).run rightResult.2) + result.context result.remaining result.value.2 hdoomed.2 + +theorem relTriple_sign_chainFailure + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) (hstarts : MaterializedChainsPublished context) : + RelTriple + (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache)) + ((resolvedImmediateSign parameter root table ftsSecret message).run concreteCache) + (SigningChainFailureRunRel parameter table) := by + let maskedSecretKey : SecretKey := ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ + let concreteSecretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + unfold maskedPublishedChronologicalSign resolvedImmediateSign + change RelTriple + (runResolvedFromTable context fuel table ((do + match ← simulateQ ordinaryRomImpl (signDigestLoop digestAttemptLimit maskedSecretKey message) with + | none => pure none + | some (randomness, index, leaves) => + maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves).run cache)) + ((do + match ← simulateQ romImpl (signDigestLoop digestAttemptLimit concreteSecretKey message) with + | none => pure none + | some (randomness, index, leaves) => + resolvedImmediateSignAfterDigest parameter table ftsSecret randomness index leaves).run concreteCache) + (SigningChainFailureRunRel parameter table) + rw [← signDigestLoop_eq_of_parameter_root maskedSecretKey concreteSecretKey rfl rfl message digestAttemptLimit] + apply relTriple_chainFailure_bind_publicPrefix parameter table _ _ _ _ + (reachableResolvedCouples_signDigestLoop table maskedSecretKey message digestAttemptLimit) _ + context fuel cache concreteCache hinvariant hvisible hpublished + · intro result hresult coordinate hchain hknown + have hpreserved := resolvedPreservesCoordinate_simulateQ_ordinaryRomImpl coordinate _ + context fuel table cache result hresult + exact hpreserved.2.mpr (hstarts coordinate hchain (by rwa [hpreserved.1] at hknown)) + · intro selected current remaining currentCache actualCache hcurrent hvisible hpublished hstarts + cases selected with + | none => + exact relTriple_chainFailure_pure parameter table none current remaining currentCache actualCache + hcurrent hvisible hpublished hstarts + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + dsimp only + rw [resolvedImmediateSignAfterDigest_eq_concrete parameter root table ftsSecret randomness index leaves] + exact relTriple_signAfterDigest_chainFailure parameter root table ftsSecret randomness index leaves + current remaining currentCache actualCache hcurrent hvisible hpublished hstarts + +theorem relTriple_sign_chainFailure_concrete + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) (hstarts : MaterializedChainsPublished context) : + RelTriple + (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache)) + ((simulateQ romImpl (scheme.sign + ⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + message)).run concreteCache) + (SigningChainFailureRunRel parameter table) := by + rw [← resolvedImmediateSign_eq_concrete] + exact relTriple_sign_chainFailure parameter root table ftsSecret message context fuel cache concreteCache + hinvariant hvisible hpublished hstarts + +theorem SigningChainFailureRunRel.materializedChainsPublished_of_no_exhaustion + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {result : ResolvedRunResult (α × SplitHashCache)} {right : α × QueryCache HashSpec} + (hrel : SigningChainFailureRunRel parameter table (some result) right) + (hcomplete : DeferredCompletable table result.context) + (hnoExhaustion : ¬AnyEncodingInputsExhausted right.2) : MaterializedChainsPublished result.context := by + rcases hrel.2 result rfl hcomplete with hpublic | hfailed + · exact hpublic + · exact False.elim (hnoExhaustion (anyEncodingInputsExhausted_of_cachedOtsEncodingFailure right.2 hfailed)) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeSigningChainPublication.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSigningChainPublication.lean new file mode 100644 index 00000000..29d0ba85 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSigningChainPublication.lean @@ -0,0 +1,121 @@ +import SphincsSecurity.Proof.OtsProbeSigningChainValues + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec + +attribute [local irreducible] maskedSignLayer +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 1000 + +theorem materializedChainsPublished_of_signLayers_and_publish + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (layerResult : ResolvedRunResult ((Layer → Option ChronologicalLayerPart) × SplitHashCache)) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (hpublic : MaterializedChainsPublished context) + (hlayers : some layerResult ∈ support (runResolvedFromTable context fuel table + ((maskedChronologicalSignLayers parameter ftsSecret index).run cache))) + (hresult : some result ∈ support (runResolvedFromTable layerResult.context layerResult.remaining layerResult.table + ((publishChronologicalSignature ftsSecret randomness index leaves ftsPath layerResult.value.1).run layerResult.value.2))) + (hsuccess : result.value.1 ≠ none) : MaterializedChainsPublished result.context := by + classical + cases hparts : traverseOption layerResult.value.1 with + | none => + simp [publishChronologicalSignature, hparts, runResolvedFromTable] at hresult + subst result + exact False.elim (hsuccess rfl) + | some parts => + rw [publishChronologicalSignature, hparts, StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨publishedOption, hpublished, hreturn⟩ := hresult + cases publishedOption with + | none => simp at hreturn + | some published => + simp [runResolvedFromTable] at hreturn + subst result + intro coordinate hchain hvalue + by_cases hselected : ∃ lay chainIdx, coordinate = + chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx ((parts lay).encoding chainIdx) + · obtain ⟨lay, chainIdx, heq⟩ := hselected + rw [heq] + exact resolvedPublishes_sequenceFin _ _ lay + (resolvedPublishes_revealLayerValues index lay (parts lay).encoding chainIdx) + layerResult.context layerResult.remaining layerResult.table layerResult.value.2 published hpublished + · have hother : ∀ lay chainIdx, coordinate ≠ + chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx ((parts lay).encoding chainIdx) := by + intro lay chainIdx heq + exact hselected ⟨lay, chainIdx, heq⟩ + have hafter := resolvedPreservesCoordinate_sequenceFin coordinate _ + (fun lay => resolvedPreservesChain_revealLayerValues coordinate hchain index lay (parts lay).encoding (hother lay)) + layerResult.context layerResult.remaining layerResult.table layerResult.value.2 published hpublished + have hbefore := resolvedPreservesChain_maskedChronologicalSignLayers coordinate hchain parameter ftsSecret index + context fuel table cache layerResult hlayers (by + intro lay + rw [traverseOption_eq_some_apply layerResult.value.1 parts hparts lay] + exact hother lay) + have hinitial : context.state.values coordinate ≠ none := by + rwa [hafter.1, hbefore] at hvalue + exact hafter.2.mpr ((revealed_subset_of_mem_runResolvedFromTable _ context fuel table layerResult hlayers) + (hpublic coordinate hchain hinitial)) + +theorem materializedChainsPublished_of_mem_successful_signAfterDigest + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (hpublic : MaterializedChainsPublished context) + (hresult : some result ∈ support (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves).run cache))) + (hsuccess : result.value.1 ≠ none) : MaterializedChainsPublished result.context := by + rw [maskedPublishedChronologicalSignAfterDigest_eq, StateT.run_bind, runResolvedFromTable_bind, + mem_support_bind_iff] at hresult + obtain ⟨pathOption, hpath, hrest⟩ := hresult + cases pathOption with + | none => simp at hrest + | some path => + have hpathPublic : MaterializedChainsPublished path.context := by + intro coordinate hchain hvalue + have hpreserved := resolvedPreservesCoordinate_simulateQ_ordinaryHashImpl coordinate _ + context fuel table cache path hpath + exact hpreserved.2.mpr (hpublic coordinate hchain (by rwa [hpreserved.1] at hvalue)) + dsimp only at hrest + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hrest + obtain ⟨layerOption, hlayers, hpublish⟩ := hrest + cases layerOption with + | none => simp at hpublish + | some layers => + exact materializedChainsPublished_of_signLayers_and_publish parameter ftsSecret randomness index leaves + path.value.1 path.context path.remaining path.table path.value.2 layers result hpathPublic hlayers hpublish hsuccess + +theorem materializedChainsPublished_of_mem_successful_sign + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (hpublic : MaterializedChainsPublished context) + (hresult : some result ∈ support (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache))) + (hsuccess : result.value.1 ≠ none) : MaterializedChainsPublished result.context := by + rw [maskedPublishedChronologicalSign, StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨digestOption, hdigest, hrest⟩ := hresult + cases digestOption with + | none => simp at hrest + | some digest => + cases hselected : digest.value.1 with + | none => + simp [hselected, runResolvedFromTable] at hrest + subst result + exact False.elim (hsuccess rfl) + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + have hdigestPublic : MaterializedChainsPublished digest.context := by + intro coordinate hchain hvalue + have hpreserved := resolvedPreservesCoordinate_simulateQ_ordinaryRomImpl coordinate _ + context fuel table cache digest hdigest + exact hpreserved.2.mpr (hpublic coordinate hchain (by rwa [hpreserved.1] at hvalue)) + apply materializedChainsPublished_of_mem_successful_signAfterDigest parameter ftsSecret randomness index leaves + digest.context digest.remaining digest.table digest.value.2 result hdigestPublic _ hsuccess + simpa only [hselected] using hrest + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeSigningChainValues.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSigningChainValues.lean new file mode 100644 index 00000000..8592c473 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSigningChainValues.lean @@ -0,0 +1,142 @@ +import SphincsSecurity.Proof.OtsProbeNativeChainMaterialization + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec + +attribute [local irreducible] maskedSignLayer +set_option backward.isDefEq.respectTransparency false + +theorem resolvedPreservesChain_maskedTreeNode + (coordinate : Coordinate) (hchain : IsChainCoordinate coordinate) (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) : + ResolvedPreservesCoordinate coordinate (maskedTreeNode lay tree level nodeIdx) := by + cases level with + | zero => + rw [maskedTreeNode] + exact (resolvedPreservesCoordinate_ensureTreeNode coordinate lay tree 0 nodeIdx).bind fun _ => + resolvedPreservesCoordinate_revealCoordinate_of_ne coordinate _ (by intro heq; subst coordinate; exact hchain) + | succ current => + rw [maskedTreeNode] + exact (resolvedPreservesCoordinate_ensureTreeNode coordinate lay tree (current + 1) nodeIdx).bind fun _ => by + split + · exact resolvedPreservesCoordinate_revealCoordinate_of_ne coordinate _ (by intro heq; subst coordinate; exact hchain) + · exact resolvedPreservesCoordinate_pure coordinate 0 + +theorem resolvedPreservesChain_maskedLayerMessage + (coordinate : Coordinate) (hchain : IsChainCoordinate coordinate) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + ResolvedPreservesCoordinate coordinate (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + split + · exact resolvedPreservesChain_maskedTreeNode coordinate hchain _ _ _ _ + · exact resolvedPreservesCoordinate_simulateQ_ordinaryHashImpl coordinate _ + +theorem resolvedPreservesChain_maskedSignLayer + (coordinate : Coordinate) (hchain : IsChainCoordinate coordinate) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + ResolvedPreservesCoordinate coordinate (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + exact (resolvedPreservesChain_maskedLayerMessage coordinate hchain parameter ftsSecret index lay).bind fun message => + (resolvedPreservesCoordinate_maskedOtsSignFrom coordinate parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message encodingAttemptLimit 0).bind fun selected => + match selected with + | none => resolvedPreservesCoordinate_pure coordinate none + | some _ => + (resolvedPreservesCoordinate_ensureTreePath coordinate lay (treeIndexAt index lay) + (leafIndexAt index lay)).bind fun _ => resolvedPreservesCoordinate_pure coordinate _ + +theorem resolvedPreservesChain_revealPrivateLayerValues + (coordinate : Coordinate) (hchain : IsChainCoordinate coordinate) (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) + (hother : ∀ chainIdx, coordinate ≠ + chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx (encoding chainIdx)) : + ResolvedPreservesCoordinate coordinate (revealPrivateLayerValues index lay encoding) := by + unfold revealPrivateLayerValues + exact (resolvedPreservesCoordinate_sequenceFin coordinate _ fun chainIdx => + resolvedPreservesCoordinate_revealCoordinate_of_ne coordinate _ (hother chainIdx)).bind fun _ => + (resolvedPreservesCoordinate_sequenceFin coordinate _ fun level => by + by_cases hinLayer : level.val < layerHeight lay + · simp only [hinLayer, if_pos] + cases hlevelValue : level.val with + | zero => + exact resolvedPreservesCoordinate_revealCoordinate_of_ne coordinate _ (by intro heq; subst coordinate; exact hchain) + | succ current => + by_cases hcurrent : current < maxLayerHeight + · simp only [hcurrent, dite_true] + exact resolvedPreservesCoordinate_revealCoordinate_of_ne coordinate _ (by intro heq; subst coordinate; exact hchain) + · simp only [hcurrent, dite_false] + exact resolvedPreservesCoordinate_pure coordinate 0 + · simp only [hinLayer, if_false] + exact resolvedPreservesCoordinate_pure coordinate 0).bind fun _ => + resolvedPreservesCoordinate_pure coordinate _ + +def ChainOutsideLayerPart (coordinate : Coordinate) (index : Index) (lay : Layer) : + Option ChronologicalLayerPart → Prop + | none => True + | some part => ∀ chainIdx, coordinate ≠ + chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx (part.encoding chainIdx) + +theorem resolvedPreservesChain_maskedChronologicalSignLayer + (coordinate : Coordinate) (hchain : IsChainCoordinate coordinate) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + ResolvedPreservesCoordinateWhen coordinate (maskedChronologicalSignLayer parameter ftsSecret index lay) + (ChainOutsideLayerPart coordinate index lay) := by + intro context fuel table cache result hresult houtside + rw [maskedChronologicalSignLayer, StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨selectedOption, hselected, hrest⟩ := hresult + cases selectedOption with + | none => simp at hrest + | some selected => + have hbefore := (resolvedPreservesChain_maskedSignLayer coordinate hchain parameter ftsSecret index lay + context fuel table cache selected hselected).1 + cases hvalue : selected.value.1 with + | none => + simp [hvalue, runResolvedFromTable] at hrest + subst result + exact hbefore + | some chosen => + rcases chosen with ⟨counter, encoding⟩ + simp only [hvalue] at hrest + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hrest + obtain ⟨revealedOption, hreveal, hreturn⟩ := hrest + cases revealedOption with + | none => simp at hreturn + | some revealed => + simp [runResolvedFromTable] at hreturn + subst result + have hafter := resolvedPreservesChain_revealPrivateLayerValues coordinate hchain index lay encoding houtside + selected.context selected.remaining selected.table selected.value.2 revealed hreveal + exact hafter.1.trans hbefore + +theorem resolvedPreservesChain_maskedChronologicalSignLayers + (coordinate : Coordinate) (hchain : IsChainCoordinate coordinate) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) : + ResolvedPreservesCoordinateWhen coordinate (maskedChronologicalSignLayers parameter ftsSecret index) + (fun layers => ∀ lay, ChainOutsideLayerPart coordinate index lay (layers lay)) := + resolvedPreservesCoordinateWhen_sequenceFin coordinate _ _ fun lay => + resolvedPreservesChain_maskedChronologicalSignLayer coordinate hchain parameter ftsSecret index lay + +theorem resolvedPreservesChain_revealLayerValues + (coordinate : Coordinate) (hchain : IsChainCoordinate coordinate) (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) + (hother : ∀ chainIdx, coordinate ≠ + chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx (encoding chainIdx)) : + ResolvedPreservesCoordinate coordinate (revealLayerValues index lay encoding) := by + unfold revealLayerValues + exact (resolvedPreservesCoordinate_sequenceFin coordinate _ fun chainIdx => + resolvedPreservesCoordinate_revealPublishedCoordinate_of_ne coordinate _ (hother chainIdx)).bind fun _ => + (resolvedPreservesCoordinate_sequenceFin coordinate _ fun level => by + by_cases hinLayer : level.val < layerHeight lay + · simp only [hinLayer, if_pos] + cases hlevelValue : level.val with + | zero => + exact resolvedPreservesCoordinate_revealPublishedCoordinate_of_ne coordinate _ (by intro heq; subst coordinate; exact hchain) + | succ current => + by_cases hcurrent : current < maxLayerHeight + · simp only [hcurrent, dite_true] + exact resolvedPreservesCoordinate_revealPublishedCoordinate_of_ne coordinate _ (by intro heq; subst coordinate; exact hchain) + · simp only [hcurrent, dite_false] + exact resolvedPreservesCoordinate_pure coordinate 0 + · simp only [hinLayer, if_false] + exact resolvedPreservesCoordinate_pure coordinate 0).bind fun _ => + resolvedPreservesCoordinate_pure coordinate _ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeSigningFailureCoupling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSigningFailureCoupling.lean new file mode 100644 index 00000000..b6d7f03a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSigningFailureCoupling.lean @@ -0,0 +1,305 @@ +import SphincsSecurity.Proof.OtsProbeSigningStartValues +import SphincsSecurity.Proof.EncodingSigningFailure + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec OracleComp.ProgramLogic.Relational + +set_option backward.isDefEq.respectTransparency false + +def SigningStartFailureRunRel (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (left : Option (ResolvedRunResult (α × SplitHashCache))) (right : α × QueryCache HashSpec) : Prop := + ReachableResolvedRunRel parameter table left right ∧ + ∀ result, left = some result → DeferredCompletable table result.context → + MaterializedStartsPublished result.context ∨ CachedOtsEncodingFailure right.2 + +theorem cachedOtsEncodingFailure_of_mem_signAfterDigest_none + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (cache finalCache : QueryCache HashSpec) + (hresult : (none, finalCache) ∈ support + ((concreteSignAfterDigestFromTable parameter root table ftsSecret randomness index leaves).run cache)) : + CachedOtsEncodingFailure finalCache := by + rw [concreteSignAfterDigestFromTable_eq_signAfterDigest] at hresult + obtain ⟨_hle, f, hagrees, hfailed, hcached⟩ := exists_answerFn_replay_of_mem_support _ _ _ _ hresult + exact cachedOtsEncodingFailure_of_signAfterDigest_none f finalCache _ randomness index leaves hagrees hcached hfailed + +theorem relTriple_signAfterDigest_startFailure + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) (hstarts : MaterializedStartsPublished context) : + RelTriple + (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves).run cache)) + ((concreteSignAfterDigestFromTable parameter root table ftsSecret randomness index leaves).run concreteCache) + (SigningStartFailureRunRel parameter table) := by + have hbase := reachableResolvedCouples_maskedPublishedChronologicalSignAfterDigest_concrete + parameter root table ftsSecret randomness index leaves context fuel cache concreteCache hinvariant hvisible hpublished + have hleft := FtsProbeSimulation.relTriple_and_left_support hbase + (fun left => left ∈ support (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves).run cache))) + (fun _ h => h) + apply relTriple_post_mono (FtsProbeSimulation.relTriple_and_right_support hleft) + intro left right hrel + refine ⟨hrel.1.1, ?_⟩ + intro result heq hcomplete + subst left + by_cases hsuccess : result.value.1 ≠ none + · exact Or.inl (materializedStartsPublished_of_mem_successful_signAfterDigest parameter ftsSecret randomness index leaves + context fuel table cache result hstarts hrel.1.2 hsuccess) + · have hfailed : result.value.1 = none := not_not.mp hsuccess + have hvalue : result.value.1 = right.1 := by + rcases hrel.1.1 with hclean | hdoomed + · exact hclean.2.1 + · exact False.elim (hdoomed.2.2.2 hcomplete) + right + apply cachedOtsEncodingFailure_of_mem_signAfterDigest_none parameter root table ftsSecret randomness index leaves + concreteCache right.2 + have hright : right = (none, right.2) := Prod.ext (hvalue.symm.trans hfailed) rfl + rw [← hright] + exact hrel.2 + +theorem relTriple_startFailure_of_doomed + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (computation : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) + (right : ProbComp (α × QueryCache HashSpec)) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hdoomed : DoomedResolvedContext table context) : + RelTriple (runResolvedFromTable context fuel table (computation.run cache)) right + (SigningStartFailureRunRel parameter table) := by + have hbase := relTriple_runResolvedFromTable_of_doomed_reachable parameter table computation right context fuel cache hdoomed + have hsupported := FtsProbeSimulation.relTriple_and_left_support hbase + (fun left => left ∈ support (runResolvedFromTable context fuel table (computation.run cache))) (fun _ h => h) + apply relTriple_post_mono hsupported + intro left right hrel + refine ⟨hrel.1, ?_⟩ + intro result heq hcomplete + subst left + exact False.elim (not_deferredCompletable_of_mem_runResolvedFromTable (computation.run cache) + context fuel table result hdoomed.1 hdoomed.2.1 hrel.2 hdoomed.2.2 hcomplete) + +theorem relTriple_startFailure_pure + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) (value : α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) (hstarts : MaterializedStartsPublished context) : + RelTriple + (runResolvedFromTable context fuel table ((pure value : StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) α).run cache)) + (pure (value, concreteCache) : ProbComp _) (SigningStartFailureRunRel parameter table) := by + simp only [StateT.run_pure, runResolvedFromTable] + apply relTriple_pure_pure + refine ⟨Or.inl ⟨rfl, rfl, hinvariant, hvisible, hpublished⟩, ?_⟩ + intro result heq _ + cases heq + exact Or.inl hstarts + +theorem relTriple_startFailure_bind_publicPrefix + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (left : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) + (right : StateT (QueryCache HashSpec) ProbComp α) + (leftNext : α → StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) β) + (rightNext : α → StateT (QueryCache HashSpec) ProbComp β) + (hprefix : ReachableResolvedCouples parameter table left right) + (hnext : ∀ value context fuel cache concreteCache, + ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache → + VisibleResolvedComputationsCached parameter table context concreteCache → PublishedValues context.state → + MaterializedStartsPublished context → + RelTriple (runResolvedFromTable context fuel table ((leftNext value).run cache)) + ((rightNext value).run concreteCache) (SigningStartFailureRunRel parameter table)) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) + (hstarts : ∀ result, some result ∈ support (runResolvedFromTable context fuel table (left.run cache)) → + MaterializedStartsPublished result.context) : + RelTriple (runResolvedFromTable context fuel table ((left >>= leftNext).run cache)) + ((right >>= rightNext).run concreteCache) (SigningStartFailureRunRel parameter table) := by + rw [StateT.run_bind, StateT.run_bind, runResolvedFromTable_bind] + have hbase := hprefix context fuel cache concreteCache hinvariant hvisible hpublished + have hsupported := FtsProbeSimulation.relTriple_and_left_support hbase + (fun result => result ∈ support (runResolvedFromTable context fuel table (left.run cache))) (fun _ h => h) + apply relTriple_bind hsupported + intro leftResult rightResult hrel + cases leftResult with + | none => + have hbase := relTriple_true + (pure (none : Option (ResolvedRunResult (β × SplitHashCache))) : ProbComp _) + ((rightNext rightResult.1).run rightResult.2) + have hsupported := FtsProbeSimulation.relTriple_and_left_support hbase + (fun finalLeft => finalLeft = none) (by intro finalLeft h; simpa using h) + apply relTriple_post_mono hsupported + intro finalLeft finalRight hfinal + rw [hfinal.2] + exact ⟨True.intro, by intro result h; cases h⟩ + | some result => + rcases hrel.1 with hclean | hdoomed + · rcases rightResult with ⟨rightValue, rightCache⟩ + have hvalue : result.value.1 = rightValue := hclean.2.1 + subst rightValue + simpa only [hclean.1] using hnext result.value.1 result.context result.remaining result.value.2 rightCache + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 (hstarts result hrel.2) + · simpa only [hdoomed.1] using relTriple_startFailure_of_doomed parameter table + (leftNext result.value.1) ((rightNext rightResult.1).run rightResult.2) + result.context result.remaining result.value.2 hdoomed.2 + +theorem relTriple_sign_startFailure + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) (hstarts : MaterializedStartsPublished context) : + RelTriple + (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache)) + ((resolvedImmediateSign parameter root table ftsSecret message).run concreteCache) + (SigningStartFailureRunRel parameter table) := by + let maskedSecretKey : SecretKey := ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ + let concreteSecretKey : SecretKey := ⟨parameter, root, + fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + unfold maskedPublishedChronologicalSign resolvedImmediateSign + change RelTriple + (runResolvedFromTable context fuel table ((do + match ← simulateQ ordinaryRomImpl (signDigestLoop digestAttemptLimit maskedSecretKey message) with + | none => pure none + | some (randomness, index, leaves) => + maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves).run cache)) + ((do + match ← simulateQ romImpl (signDigestLoop digestAttemptLimit concreteSecretKey message) with + | none => pure none + | some (randomness, index, leaves) => + resolvedImmediateSignAfterDigest parameter table ftsSecret randomness index leaves).run concreteCache) + (SigningStartFailureRunRel parameter table) + rw [← signDigestLoop_eq_of_parameter_root maskedSecretKey concreteSecretKey rfl rfl message digestAttemptLimit] + apply relTriple_startFailure_bind_publicPrefix parameter table _ _ _ _ + (reachableResolvedCouples_signDigestLoop table maskedSecretKey message digestAttemptLimit) _ + context fuel cache concreteCache hinvariant hvisible hpublished + · intro result hresult start hknown + have hpreserved := resolvedPreservesCoordinate_simulateQ_ordinaryRomImpl start.coordinate _ + context fuel table cache result hresult + exact hpreserved.2.mpr (hstarts start (by rwa [hpreserved.1] at hknown)) + · intro selected current remaining currentCache actualCache hcurrent hvisible hpublished hstarts + cases selected with + | none => + exact relTriple_startFailure_pure parameter table none current remaining currentCache actualCache + hcurrent hvisible hpublished hstarts + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + dsimp only + rw [resolvedImmediateSignAfterDigest_eq_concrete parameter root table ftsSecret randomness index leaves] + exact relTriple_signAfterDigest_startFailure parameter root table ftsSecret randomness index leaves + current remaining currentCache actualCache hcurrent hvisible hpublished hstarts + +theorem relTriple_sign_startFailure_concrete + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) (hstarts : MaterializedStartsPublished context) : + RelTriple + (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache)) + ((simulateQ romImpl (scheme.sign + ⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + message)).run concreteCache) + (SigningStartFailureRunRel parameter table) := by + rw [← resolvedImmediateSign_eq_concrete] + exact relTriple_sign_startFailure parameter root table ftsSecret message context fuel cache concreteCache + hinvariant hvisible hpublished hstarts + +def LiveSigningStartErasure (table : OtsSecretIndex → HashOutput) : + Option (ResolvedRunResult (α × SplitHashCache)) → Prop + | none => False + | some result => DeferredCompletable table result.context ∧ + ∃ start : OtsSecretIndex, result.context.state.values start.coordinate ≠ none ∧ + (canonicalizeMaterializedValues table result.context).state.values start.coordinate = none + +theorem SigningStartFailureRunRel.encoding_failure_of_erasure + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {left : Option (ResolvedRunResult (α × SplitHashCache))} {right : α × QueryCache HashSpec} + (hrel : SigningStartFailureRunRel parameter table left right) (herasure : LiveSigningStartErasure table left) : + CachedOtsEncodingFailure right.2 := by + cases left with + | none => exact False.elim herasure + | some result => + obtain ⟨hcomplete, start, hknown, herased⟩ := herasure + rcases hrel.2 result rfl hcomplete with hpublic | hfailed + · have hrevealed := hpublic start hknown + change (if start.coordinate ∈ result.context.state.revealed then some (table start) else none) = none at herased + simp [hrevealed] at herased + · exact hfailed + +theorem probEvent_liveSigningStartErasure_le_cachedFailure + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) (hstarts : MaterializedStartsPublished context) : + Pr[LiveSigningStartErasure table | runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache)] ≤ + Pr[fun result => CachedOtsEncodingFailure result.2 | + (simulateQ romImpl (scheme.sign + ⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + message)).run concreteCache] := by + apply probEvent_le_of_relTriple (relTriple_sign_startFailure_concrete parameter root table ftsSecret message + context fuel cache concreteCache hinvariant hvisible hpublished hstarts) + intro left right hrel herasure + exact hrel.encoding_failure_of_erasure herasure + +theorem SigningStartFailureRunRel.materializedStartsPublished_of_no_exhaustion + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {result : ResolvedRunResult (α × SplitHashCache)} {right : α × QueryCache HashSpec} + (hrel : SigningStartFailureRunRel parameter table (some result) right) + (hcomplete : DeferredCompletable table result.context) + (hnoExhaustion : ¬AnyEncodingInputsExhausted right.2) : MaterializedStartsPublished result.context := by + rcases hrel.2 result rfl hcomplete with hpublic | hfailed + · exact hpublic + · exact False.elim (hnoExhaustion (anyEncodingInputsExhausted_of_cachedOtsEncodingFailure right.2 hfailed)) + +theorem SigningStartFailureRunRel.start_values_preserved_of_no_exhaustion + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {result : ResolvedRunResult (α × SplitHashCache)} {right : α × QueryCache HashSpec} + (hrel : SigningStartFailureRunRel parameter table (some result) right) + (hcomplete : DeferredCompletable table result.context) + (hnoExhaustion : ¬AnyEncodingInputsExhausted right.2) (start : OtsSecretIndex) : + (canonicalizeMaterializedValues table result.context).state.values start.coordinate = + result.context.state.values start.coordinate := by + have hpublic := hrel.materializedStartsPublished_of_no_exhaustion hcomplete hnoExhaustion + rcases hrel.1 with hclean | hdoomed + · exact canonicalize_start_values_eq_of_materializedStartsPublished table result.context hpublic + hclean.2.2.2.2 hclean.2.2.1.2.2.1 start + · exact False.elim (hdoomed.2.2.2 hcomplete) + +theorem SigningStartFailureRunRel.completedStartTable_preserved_of_no_exhaustion + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {result : ResolvedRunResult (α × SplitHashCache)} {right : α × QueryCache HashSpec} + (hrel : SigningStartFailureRunRel parameter table (some result) right) + (hcomplete : DeferredCompletable table result.context) + (hnoExhaustion : ¬AnyEncodingInputsExhausted right.2) (base : OtsSecretIndex → HashOutput) : + completedStartTable (canonicalizeMaterializedValues table result.context).state base = + completedStartTable result.context.state base := by + funext start + unfold completedStartTable + rw [hrel.start_values_preserved_of_no_exhaustion hcomplete hnoExhaustion start] + +theorem SigningStartFailureRunRel.historyHit_preserved_of_no_exhaustion + {parameter : PublicParameter} {table : OtsSecretIndex → HashOutput} + {result : ResolvedRunResult (α × SplitHashCache)} {right : α × QueryCache HashSpec} + (hrel : SigningStartFailureRunRel parameter table (some result) right) + (hcomplete : DeferredCompletable table result.context) + (hnoExhaustion : ¬AnyEncodingInputsExhausted right.2) (history : List Probe) (base : OtsSecretIndex → HashOutput) : + ChainStartHistoryHit (canonicalizeMaterializedValues table result.context) history base = + ChainStartHistoryHit result.context history base := + chainStartHistoryHit_eq_of_start_values_eq result.context (canonicalizeMaterializedValues table result.context) + history base (hrel.start_values_preserved_of_no_exhaustion hcomplete hnoExhaustion) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeSigningStartValues.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSigningStartValues.lean new file mode 100644 index 00000000..f5c6eba8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSigningStartValues.lean @@ -0,0 +1,769 @@ +import SphincsSecurity.Proof.OtsProbePublicHashValues +import SphincsSecurity.Proof.OtsProbeStartHistorySupport +import SphincsSecurity.Proof.OtsProbeHistoryAdaptiveInterpreter + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local irreducible] maskedSignLayer +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 1000 + +theorem resolvedPreservesCoordinate_sequenceFin (coordinate : Coordinate) {n : Nat} + (computation : Fin n → StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) + (hcomponent : ∀ index, ResolvedPreservesCoordinate coordinate (computation index)) : + ResolvedPreservesCoordinate coordinate (sequenceFin computation) := by + induction n with + | zero => simpa [sequenceFin] using resolvedPreservesCoordinate_pure coordinate Fin.elim0 + | succ n ih => + rw [sequenceFin] + exact (hcomponent 0).bind fun _ => + (ih (fun index : Fin n => computation index.succ) (fun index => hcomponent index.succ)).bind + fun _ => resolvedPreservesCoordinate_pure coordinate _ + +theorem resolvedPreservesCoordinate_simulateQ_ordinaryHashImpl (coordinate : Coordinate) + (computation : OracleComp HashSpec α) : + ResolvedPreservesCoordinate coordinate (simulateQ ordinaryHashImpl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => exact resolvedPreservesCoordinate_pure coordinate value + | query_bind input next ih => + rw [simulateQ_query_bind] + exact (resolvedPreservesCoordinate_splitHashQuery coordinate (.ordinary input)).bind ih + +theorem resolvedPreservesCoordinate_revealCoordinate_of_ne + (coordinate revealed : Coordinate) (hne : coordinate ≠ revealed) : + ResolvedPreservesCoordinate coordinate (revealCoordinate revealed) := by + unfold revealCoordinate + exact (resolvedPreservesCoordinate_revealCoordinateOutput_of_ne coordinate revealed hne).bind fun _ => + resolvedPreservesCoordinate_pure coordinate _ + +theorem resolvedPreservesCoordinate_ensureFullChain + (coordinate : Coordinate) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + ResolvedPreservesCoordinate coordinate (ensureFullChain lay tree leafIdx chainIdx) := by + unfold ensureFullChain + exact (resolvedPreservesCoordinate_sequenceFin coordinate _ fun _ => + resolvedPreservesCoordinate_ensure coordinate _).bind fun _ => resolvedPreservesCoordinate_pure coordinate () + +theorem resolvedPreservesCoordinate_ensureOtsLeaf + (coordinate : Coordinate) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ResolvedPreservesCoordinate coordinate (ensureOtsLeaf lay tree leafIdx) := by + unfold ensureOtsLeaf + exact (resolvedPreservesCoordinate_sequenceFin coordinate _ fun chainIdx => + resolvedPreservesCoordinate_ensureFullChain coordinate lay tree leafIdx chainIdx).bind fun _ => + resolvedPreservesCoordinate_ensure coordinate _ + +theorem resolvedPreservesCoordinate_ensureTreeNode + (coordinate : Coordinate) (lay : Layer) (tree : TreeIndex) : ∀ level nodeIdx, + ResolvedPreservesCoordinate coordinate (ensureTreeNode lay tree level nodeIdx) + | 0, nodeIdx => by + rw [ensureTreeNode] + exact resolvedPreservesCoordinate_ensureOtsLeaf coordinate lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => by + rw [ensureTreeNode] + exact (resolvedPreservesCoordinate_ensureTreeNode coordinate lay tree level (2 * nodeIdx)).bind fun _ => + (resolvedPreservesCoordinate_ensureTreeNode coordinate lay tree level (2 * nodeIdx + 1)).bind fun _ => by + split + · exact resolvedPreservesCoordinate_ensure coordinate _ + · exact resolvedPreservesCoordinate_pure coordinate () + +theorem resolvedPreservesStart_maskedTreeNode + (start : OtsSecretIndex) (lay : Layer) (tree : TreeIndex) (level nodeIdx : Nat) : + ResolvedPreservesCoordinate start.coordinate (maskedTreeNode lay tree level nodeIdx) := by + cases level with + | zero => + rw [maskedTreeNode] + exact (resolvedPreservesCoordinate_ensureTreeNode start.coordinate lay tree 0 nodeIdx).bind fun _ => + resolvedPreservesCoordinate_revealCoordinate_of_ne start.coordinate _ (by simp [OtsSecretIndex.coordinate]) + | succ current => + rw [maskedTreeNode] + exact (resolvedPreservesCoordinate_ensureTreeNode start.coordinate lay tree (current + 1) nodeIdx).bind fun _ => by + split + · exact resolvedPreservesCoordinate_revealCoordinate_of_ne start.coordinate _ (by simp [OtsSecretIndex.coordinate]) + · exact resolvedPreservesCoordinate_pure start.coordinate 0 + +theorem resolvedPreservesStart_maskedLayerMessage + (start : OtsSecretIndex) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + ResolvedPreservesCoordinate start.coordinate (maskedLayerMessage parameter ftsSecret index lay) := by + unfold maskedLayerMessage + split + · exact resolvedPreservesStart_maskedTreeNode start _ _ _ _ + · exact resolvedPreservesCoordinate_simulateQ_ordinaryHashImpl start.coordinate _ + +theorem resolvedPreservesCoordinate_ensureChainPrefix + (coordinate : Coordinate) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) : + ResolvedPreservesCoordinate coordinate (ensureChainPrefix lay tree leafIdx chainIdx digit) := by + unfold ensureChainPrefix + exact (resolvedPreservesCoordinate_sequenceFin coordinate _ fun _ => by + split + · exact resolvedPreservesCoordinate_ensure coordinate _ + · exact resolvedPreservesCoordinate_pure coordinate ()).bind fun _ => resolvedPreservesCoordinate_pure coordinate () + +theorem resolvedPreservesCoordinate_maskedOtsSignFrom + (coordinate : Coordinate) (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (message : Digest) : ∀ attempts counter, + ResolvedPreservesCoordinate coordinate (maskedOtsSignFrom parameter lay tree leafIdx message attempts counter) + | 0, _ => resolvedPreservesCoordinate_pure coordinate none + | attempts + 1, counter => by + rw [maskedOtsSignFrom] + exact (resolvedPreservesCoordinate_simulateQ_ordinaryHashImpl coordinate _).bind fun encoded => + match encoded with + | none => resolvedPreservesCoordinate_maskedOtsSignFrom coordinate parameter lay tree leafIdx message + attempts (counter + 1) + | some encoding => + (resolvedPreservesCoordinate_sequenceFin coordinate _ fun chainIdx => + resolvedPreservesCoordinate_ensureChainPrefix coordinate lay tree leafIdx chainIdx (encoding chainIdx)).bind + fun _ => resolvedPreservesCoordinate_pure coordinate _ + +theorem resolvedPreservesCoordinate_ensureTreePath + (coordinate : Coordinate) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + ResolvedPreservesCoordinate coordinate (ensureTreePath lay tree leafIdx) := by + unfold ensureTreePath + exact (resolvedPreservesCoordinate_sequenceFin coordinate _ fun _ => by + split + · exact resolvedPreservesCoordinate_ensureTreeNode coordinate lay tree _ _ + · exact resolvedPreservesCoordinate_pure coordinate ()).bind fun _ => resolvedPreservesCoordinate_pure coordinate () + +theorem resolvedPreservesStart_maskedSignLayer + (start : OtsSecretIndex) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + ResolvedPreservesCoordinate start.coordinate (maskedSignLayer parameter ftsSecret index lay) := by + unfold maskedSignLayer + exact (resolvedPreservesStart_maskedLayerMessage start parameter ftsSecret index lay).bind fun message => + (resolvedPreservesCoordinate_maskedOtsSignFrom start.coordinate parameter lay (treeIndexAt index lay) + (leafIndexAt index lay) message encodingAttemptLimit 0).bind fun selected => + match selected with + | none => resolvedPreservesCoordinate_pure start.coordinate none + | some _ => + (resolvedPreservesCoordinate_ensureTreePath start.coordinate lay (treeIndexAt index lay) + (leafIndexAt index lay)).bind fun _ => resolvedPreservesCoordinate_pure start.coordinate _ + +theorem resolvedPreservesStart_revealPrivateLayerValues + (start : OtsSecretIndex) (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) + (hother : ∀ chainIdx, start.coordinate ≠ + chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx (encoding chainIdx)) : + ResolvedPreservesCoordinate start.coordinate (revealPrivateLayerValues index lay encoding) := by + unfold revealPrivateLayerValues + exact (resolvedPreservesCoordinate_sequenceFin start.coordinate _ fun chainIdx => + resolvedPreservesCoordinate_revealCoordinate_of_ne start.coordinate _ (hother chainIdx)).bind fun _ => + (resolvedPreservesCoordinate_sequenceFin start.coordinate _ fun level => by + by_cases hinLayer : level.val < layerHeight lay + · simp only [hinLayer, if_pos] + cases hlevelValue : level.val with + | zero => + exact resolvedPreservesCoordinate_revealCoordinate_of_ne start.coordinate _ (by simp [OtsSecretIndex.coordinate]) + | succ current => + by_cases hcurrent : current < maxLayerHeight + · simp only [hcurrent, dite_true] + exact resolvedPreservesCoordinate_revealCoordinate_of_ne start.coordinate _ (by simp [OtsSecretIndex.coordinate]) + · simp only [hcurrent, dite_false] + exact resolvedPreservesCoordinate_pure start.coordinate 0 + · simp only [hinLayer, if_false] + exact resolvedPreservesCoordinate_pure start.coordinate 0).bind fun _ => + resolvedPreservesCoordinate_pure start.coordinate _ + +def ResolvedPreservesCoordinateWhen (coordinate : Coordinate) + (computation : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) + (condition : α → Prop) : Prop := + ∀ context fuel table cache result, + some result ∈ support (runResolvedFromTable context fuel table (computation.run cache)) → + condition result.value.1 → result.context.state.values coordinate = context.state.values coordinate + +theorem resolvedPreservesCoordinateWhen_sequenceFin (coordinate : Coordinate) {n : Nat} + (computation : Fin n → StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) + (condition : Fin n → α → Prop) + (hcomponent : ∀ index, ResolvedPreservesCoordinateWhen coordinate (computation index) (condition index)) : + ResolvedPreservesCoordinateWhen coordinate (sequenceFin computation) (fun values => ∀ index, condition index (values index)) := by + induction n with + | zero => + intro context fuel table cache result hresult _ + simp [sequenceFin, runResolvedFromTable] at hresult + subst result + rfl + | succ n ih => + intro context fuel table cache result hresult hcondition + rw [sequenceFin, StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨headOption, hhead, hrest⟩ := hresult + cases headOption with + | none => simp at hrest + | some head => + dsimp only at hrest + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hrest + obtain ⟨tailOption, htail, hreturn⟩ := hrest + cases tailOption with + | none => simp at hreturn + | some tail => + simp [runResolvedFromTable] at hreturn + subst result + have hheadPreserved := hcomponent 0 context fuel table cache head hhead (hcondition 0) + have htailPreserved := ih (fun index : Fin n => computation index.succ) + (fun index value => condition index.succ value) (fun index => hcomponent index.succ) + head.context head.remaining head.table head.value.2 tail htail (fun index => hcondition index.succ) + exact htailPreserved.trans hheadPreserved + +def StartOutsideLayerPart (start : OtsSecretIndex) (index : Index) (lay : Layer) : + Option ChronologicalLayerPart → Prop + | none => True + | some part => ∀ chainIdx, start.coordinate ≠ + chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx (part.encoding chainIdx) + +theorem resolvedPreservesStart_maskedChronologicalSignLayer + (start : OtsSecretIndex) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + ResolvedPreservesCoordinateWhen start.coordinate (maskedChronologicalSignLayer parameter ftsSecret index lay) + (StartOutsideLayerPart start index lay) := by + intro context fuel table cache result hresult houtside + rw [maskedChronologicalSignLayer, StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨selectedOption, hselected, hrest⟩ := hresult + cases selectedOption with + | none => simp at hrest + | some selected => + have hbefore := (resolvedPreservesStart_maskedSignLayer start parameter ftsSecret index lay + context fuel table cache selected hselected).1 + cases hvalue : selected.value.1 with + | none => + simp [hvalue, runResolvedFromTable] at hrest + subst result + exact hbefore + | some chosen => + rcases chosen with ⟨counter, encoding⟩ + simp only [hvalue] at hrest + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hrest + obtain ⟨revealedOption, hreveal, hreturn⟩ := hrest + cases revealedOption with + | none => simp at hreturn + | some revealed => + simp [runResolvedFromTable] at hreturn + subst result + have hafter := resolvedPreservesStart_revealPrivateLayerValues start index lay encoding houtside + selected.context selected.remaining selected.table selected.value.2 revealed hreveal + exact hafter.1.trans hbefore + +theorem resolvedPreservesStart_maskedChronologicalSignLayers + (start : OtsSecretIndex) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) : + ResolvedPreservesCoordinateWhen start.coordinate (maskedChronologicalSignLayers parameter ftsSecret index) + (fun layers => ∀ lay, StartOutsideLayerPart start index lay (layers lay)) := + resolvedPreservesCoordinateWhen_sequenceFin start.coordinate _ _ fun lay => + resolvedPreservesStart_maskedChronologicalSignLayer start parameter ftsSecret index lay + +def ResolvedPublishes (coordinate : Coordinate) + (computation : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) : Prop := + ∀ context fuel table cache result, + some result ∈ support (runResolvedFromTable context fuel table (computation.run cache)) → + coordinate ∈ result.context.state.revealed + +theorem ResolvedPublishes.bind_left + {coordinate : Coordinate} + {left : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α} + (next : α → StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) β) + (hleft : ResolvedPublishes coordinate left) : ResolvedPublishes coordinate (left >>= next) := by + intro context fuel table cache result hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨option, hleftSupport, hrest⟩ := hresult + cases option with + | none => simp at hrest + | some middle => + exact (revealed_subset_of_mem_runResolvedFromTable _ middle.context middle.remaining middle.table result hrest) + (hleft context fuel table cache middle hleftSupport) + +theorem ResolvedPublishes.bind_right + {coordinate : Coordinate} + (left : StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) + {next : α → StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) β} + (hnext : ∀ value, ResolvedPublishes coordinate (next value)) : ResolvedPublishes coordinate (left >>= next) := by + intro context fuel table cache result hresult + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨option, _hleft, hrest⟩ := hresult + cases option with + | none => simp at hrest + | some middle => + exact hnext middle.value.1 middle.context middle.remaining middle.table middle.value.2 result hrest + +theorem resolvedPublishes_publishCoordinate (coordinate : Coordinate) : + ResolvedPublishes coordinate (publishCoordinate coordinate) := by + intro context fuel table cache result hresult + change some result ∈ support (runResolvedFromTable context fuel table + (LazyRevealProbe.publishQuery coordinate >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.publishQuery, runResolvedFromTable_publish_query_bind] at hresult + simp [runResolvedFromTable] at hresult + subst result + simp [LazyRevealProbe.State.publish] + +theorem resolvedPublishes_revealPublishedCoordinate (coordinate : Coordinate) : + ResolvedPublishes coordinate (revealPublishedCoordinate coordinate) := by + unfold revealPublishedCoordinate + exact ResolvedPublishes.bind_right _ fun _ => (resolvedPublishes_publishCoordinate coordinate).bind_left _ + +theorem resolvedPublishes_sequenceFin (coordinate : Coordinate) {n : Nat} + (computation : Fin n → StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)) α) + (index : Fin n) (hcomponent : ResolvedPublishes coordinate (computation index)) : + ResolvedPublishes coordinate (sequenceFin computation) := by + induction n with + | zero => exact index.elim0 + | succ n ih => + rw [sequenceFin] + cases index using Fin.cases with + | zero => exact hcomponent.bind_left _ + | succ index => + exact ResolvedPublishes.bind_right _ fun _ => + (ih (fun index : Fin n => computation index.succ) index hcomponent).bind_left _ + +theorem resolvedPublishes_revealLayerValues (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) (chainIdx : ChainIndex) : + ResolvedPublishes + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx (encoding chainIdx)) + (revealLayerValues index lay encoding) := by + unfold revealLayerValues + exact (resolvedPublishes_sequenceFin _ _ chainIdx (resolvedPublishes_revealPublishedCoordinate _)).bind_left _ + +theorem resolvedPreservesCoordinate_revealPublishedCoordinate_of_ne + (coordinate published : Coordinate) (hne : coordinate ≠ published) : + ResolvedPreservesCoordinate coordinate (revealPublishedCoordinate published) := by + unfold revealPublishedCoordinate + exact (resolvedPreservesCoordinate_revealCoordinate_of_ne coordinate published hne).bind fun _ => + (resolvedPreservesCoordinate_publish_of_ne coordinate published hne).bind fun _ => + resolvedPreservesCoordinate_pure coordinate _ + +theorem resolvedPreservesStart_revealLayerValues + (start : OtsSecretIndex) (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) + (hother : ∀ chainIdx, start.coordinate ≠ + chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx (encoding chainIdx)) : + ResolvedPreservesCoordinate start.coordinate (revealLayerValues index lay encoding) := by + unfold revealLayerValues + exact (resolvedPreservesCoordinate_sequenceFin start.coordinate _ fun chainIdx => + resolvedPreservesCoordinate_revealPublishedCoordinate_of_ne start.coordinate _ (hother chainIdx)).bind fun _ => + (resolvedPreservesCoordinate_sequenceFin start.coordinate _ fun level => by + by_cases hinLayer : level.val < layerHeight lay + · simp only [hinLayer, if_pos] + cases hlevelValue : level.val with + | zero => + exact resolvedPreservesCoordinate_revealPublishedCoordinate_of_ne start.coordinate _ (by simp [OtsSecretIndex.coordinate]) + | succ current => + by_cases hcurrent : current < maxLayerHeight + · simp only [hcurrent, dite_true] + exact resolvedPreservesCoordinate_revealPublishedCoordinate_of_ne start.coordinate _ (by simp [OtsSecretIndex.coordinate]) + · simp only [hcurrent, dite_false] + exact resolvedPreservesCoordinate_pure start.coordinate 0 + · simp only [hinLayer, if_false] + exact resolvedPreservesCoordinate_pure start.coordinate 0).bind fun _ => + resolvedPreservesCoordinate_pure start.coordinate _ + +def MaterializedStartsPublished (context : DeferredContext) : Prop := + ∀ start : OtsSecretIndex, context.state.values start.coordinate ≠ none → start.coordinate ∈ context.state.revealed + +theorem materializedStartsPublished_of_canonical + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hcanonical : CanonicalMaterializedValues table context) : MaterializedStartsPublished context := by + intro start hvalue + obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hvalue + exact MaterializedValuesPublished.of_canonical hcanonical start.coordinate output houtput + +theorem materializedStartsPublished_of_signLayers_and_publish + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (ftsPath : FtsTree → Fin ftsTreeHeight → Digest) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (layerResult : ResolvedRunResult ((Layer → Option ChronologicalLayerPart) × SplitHashCache)) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (hpublic : MaterializedStartsPublished context) + (hlayers : some layerResult ∈ support (runResolvedFromTable context fuel table + ((maskedChronologicalSignLayers parameter ftsSecret index).run cache))) + (hresult : some result ∈ support (runResolvedFromTable layerResult.context layerResult.remaining layerResult.table + ((publishChronologicalSignature ftsSecret randomness index leaves ftsPath layerResult.value.1).run layerResult.value.2))) + (hsuccess : result.value.1 ≠ none) : MaterializedStartsPublished result.context := by + classical + cases hparts : traverseOption layerResult.value.1 with + | none => + simp [publishChronologicalSignature, hparts, runResolvedFromTable] at hresult + subst result + exact False.elim (hsuccess rfl) + | some parts => + rw [publishChronologicalSignature, hparts, StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨publishedOption, hpublished, hreturn⟩ := hresult + cases publishedOption with + | none => simp at hreturn + | some published => + simp [runResolvedFromTable] at hreturn + subst result + intro start hvalue + by_cases hselected : ∃ lay chainIdx, start.coordinate = + chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx ((parts lay).encoding chainIdx) + · obtain ⟨lay, chainIdx, heq⟩ := hselected + rw [heq] + exact resolvedPublishes_sequenceFin _ _ lay + (resolvedPublishes_revealLayerValues index lay (parts lay).encoding chainIdx) + layerResult.context layerResult.remaining layerResult.table layerResult.value.2 published hpublished + · have hother : ∀ lay chainIdx, start.coordinate ≠ + chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx ((parts lay).encoding chainIdx) := by + intro lay chainIdx heq + exact hselected ⟨lay, chainIdx, heq⟩ + have hafter := resolvedPreservesCoordinate_sequenceFin start.coordinate _ + (fun lay => resolvedPreservesStart_revealLayerValues start index lay (parts lay).encoding (hother lay)) + layerResult.context layerResult.remaining layerResult.table layerResult.value.2 published hpublished + have hbefore := resolvedPreservesStart_maskedChronologicalSignLayers start parameter ftsSecret index + context fuel table cache layerResult hlayers (by + intro lay + rw [traverseOption_eq_some_apply layerResult.value.1 parts hparts lay] + exact hother lay) + have hinitial : context.state.values start.coordinate ≠ none := by + rwa [hafter.1, hbefore] at hvalue + exact hafter.2.mpr ((revealed_subset_of_mem_runResolvedFromTable _ context fuel table layerResult hlayers) + (hpublic start hinitial)) + +theorem materializedStartsPublished_of_mem_successful_signAfterDigest + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (hpublic : MaterializedStartsPublished context) + (hresult : some result ∈ support (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves).run cache))) + (hsuccess : result.value.1 ≠ none) : MaterializedStartsPublished result.context := by + rw [maskedPublishedChronologicalSignAfterDigest_eq, StateT.run_bind, runResolvedFromTable_bind, + mem_support_bind_iff] at hresult + obtain ⟨pathOption, hpath, hrest⟩ := hresult + cases pathOption with + | none => simp at hrest + | some path => + have hpathPublic : MaterializedStartsPublished path.context := by + intro start hvalue + have hpreserved := resolvedPreservesCoordinate_simulateQ_ordinaryHashImpl start.coordinate _ + context fuel table cache path hpath + exact hpreserved.2.mpr (hpublic start (by rwa [hpreserved.1] at hvalue)) + dsimp only at hrest + rw [StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hrest + obtain ⟨layerOption, hlayers, hpublish⟩ := hrest + cases layerOption with + | none => simp at hpublish + | some layers => + exact materializedStartsPublished_of_signLayers_and_publish parameter ftsSecret randomness index leaves + path.value.1 path.context path.remaining path.table path.value.2 layers result hpathPublic hlayers hpublish hsuccess + +theorem resolvedPreservesCoordinate_splitUniformImpl (coordinate : Coordinate) (n : Nat) : + ResolvedPreservesCoordinate coordinate (splitUniformImpl n) := by + intro context fuel table cache result hresult + change some result ∈ support (runResolvedFromTable context fuel table + (LazyRevealProbe.uniformQuery n >>= fun output => pure (output, cache))) at hresult + rw [LazyRevealProbe.uniformQuery, runResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, hreturn⟩ := hresult + simp [runResolvedFromTable] at hreturn + subst result + exact ⟨rfl, Iff.rfl⟩ + +theorem resolvedPreservesCoordinate_simulateQ_ordinaryRomImpl (coordinate : Coordinate) + (computation : OracleComp OracleWorld α) : + ResolvedPreservesCoordinate coordinate (simulateQ ordinaryRomImpl computation) := by + induction computation using OracleComp.inductionOn with + | pure value => exact resolvedPreservesCoordinate_pure coordinate value + | query_bind input next ih => + rw [simulateQ_query_bind] + apply ResolvedPreservesCoordinate.bind ?_ ih + cases input with + | inl n => exact resolvedPreservesCoordinate_splitUniformImpl coordinate n + | inr input => exact resolvedPreservesCoordinate_splitHashQuery coordinate (.ordinary input) + +theorem materializedStartsPublished_of_mem_successful_sign + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (hpublic : MaterializedStartsPublished context) + (hresult : some result ∈ support (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache))) + (hsuccess : result.value.1 ≠ none) : MaterializedStartsPublished result.context := by + rw [maskedPublishedChronologicalSign, StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨digestOption, hdigest, hrest⟩ := hresult + cases digestOption with + | none => simp at hrest + | some digest => + cases hselected : digest.value.1 with + | none => + simp [hselected, runResolvedFromTable] at hrest + subst result + exact False.elim (hsuccess rfl) + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + have hdigestPublic : MaterializedStartsPublished digest.context := by + intro start hvalue + have hpreserved := resolvedPreservesCoordinate_simulateQ_ordinaryRomImpl start.coordinate _ + context fuel table cache digest hdigest + exact hpreserved.2.mpr (hpublic start (by rwa [hpreserved.1] at hvalue)) + apply materializedStartsPublished_of_mem_successful_signAfterDigest parameter ftsSecret randomness index leaves + digest.context digest.remaining digest.table digest.value.2 result hdigestPublic _ hsuccess + simpa only [hselected] using hrest + +theorem canonicalize_known_start_eq_of_materializedStartsPublished + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hpublic : MaterializedStartsPublished context) (hstarts : StartTableAgrees context.state table) + (start : OtsSecretIndex) (hknown : context.state.values start.coordinate ≠ none) : + (canonicalizeMaterializedValues table context).state.values start.coordinate = context.state.values start.coordinate := by + obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hknown + have hrevealed := hpublic start (by rw [houtput]; simp) + have hagree := hstarts start output houtput + change (if start.coordinate ∈ context.state.revealed then some (table start) else none) = + context.state.values start.coordinate + simp only [hrevealed, if_pos, houtput, hagree] + +theorem successful_sign_canonicalization_preserves_known_starts + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (hcanonical : CanonicalMaterializedValues table context) (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache))) + (hsuccess : result.value.1 ≠ none) (start : OtsSecretIndex) + (hknown : result.context.state.values start.coordinate ≠ none) : + (canonicalizeMaterializedValues table result.context).state.values start.coordinate = result.context.state.values start.coordinate := by + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table result hconsistent hstarts hresult + exact canonicalize_known_start_eq_of_materializedStartsPublished table result.context + (materializedStartsPublished_of_mem_successful_sign parameter root ftsSecret message context fuel table cache + result (materializedStartsPublished_of_canonical table context hcanonical) hresult hsuccess) + hcore.2.2 start hknown + +theorem resolvedPreservesPublishedValues_revealPrivateLayerValues + (index : Index) (lay : Layer) (encoding : ChainIndex → Digit) : + ResolvedPreservesPublished (revealPrivateLayerValues index lay encoding) := by + unfold revealPrivateLayerValues + exact (resolvedPreservesPublished_sequenceFin _ fun chainIdx => + resolvedPreservesPublishedValues_revealCoordinate + (chainValueCoordinate lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx + (encoding chainIdx))).bind fun _ => + (resolvedPreservesPublished_sequenceFin _ fun level => by + split + · cases hlevelValue : level.val with + | zero => exact resolvedPreservesPublishedValues_revealCoordinate _ + | succ current => + rw [show current + 1 = Nat.succ current by omega] + change ResolvedPreservesPublished + (if hlevel : current < maxLayerHeight then + revealCoordinate (.position (.node lay (treeIndexAt index lay) + ⟨current, hlevel⟩ (leafOfNat + (Nat.xor ((leafIndexAt index lay).val / 2 ^ (current + 1)) 1)))) + else pure 0) + by_cases hlevel : current < maxLayerHeight + · rw [dif_pos hlevel] + exact resolvedPreservesPublishedValues_revealCoordinate _ + · rw [dif_neg hlevel] + exact ResolvedPreservesPublished.pure 0 + · exact ResolvedPreservesPublished.pure 0).bind fun _ => + ResolvedPreservesPublished.pure _ + +theorem resolvedPreservesPublishedValues_maskedChronologicalSignLayer + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) (lay : Layer) : + ResolvedPreservesPublished (maskedChronologicalSignLayer parameter ftsSecret index lay) := by + unfold maskedChronologicalSignLayer + exact (resolvedPreservesPublishedValues_maskedSignLayer parameter ftsSecret index lay).bind fun selected => + match selected with + | none => .pure none + | some (_, encoding) => + (resolvedPreservesPublishedValues_revealPrivateLayerValues index lay encoding).bind fun _ => .pure _ + +theorem resolvedPreservesPublishedValues_maskedPublishedChronologicalSignAfterDigest + (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + ResolvedPreservesPublished (maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves) := by + rw [maskedPublishedChronologicalSignAfterDigest_eq] + exact (resolvedPreservesPublishedValues_simulateQ_ordinaryHashImpl _).bind fun ftsPath => + (resolvedPreservesPublished_sequenceFin _ fun lay => + resolvedPreservesPublishedValues_maskedChronologicalSignLayer parameter ftsSecret index lay).bind fun layers => + resolvedPreservesPublishedValues_publishChronologicalSignature ftsSecret randomness index leaves ftsPath layers + +theorem resolvedPreservesPublishedValues_maskedPublishedChronologicalSign + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + ResolvedPreservesPublished (maskedPublishedChronologicalSign parameter root ftsSecret message) := by + unfold maskedPublishedChronologicalSign + exact (ResolvedPreservesPublished.of_preservesCoordinate fun coordinate => + resolvedPreservesCoordinate_simulateQ_ordinaryRomImpl coordinate _).bind fun selected => + match selected with + | none => .pure none + | some (randomness, index, leaves) => + resolvedPreservesPublishedValues_maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves + +theorem canonicalize_start_values_eq_of_materializedStartsPublished + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hpublic : MaterializedStartsPublished context) (hpublished : PublishedValues context.state) + (hstarts : StartTableAgrees context.state table) (start : OtsSecretIndex) : + (canonicalizeMaterializedValues table context).state.values start.coordinate = context.state.values start.coordinate := by + by_cases hknown : context.state.values start.coordinate ≠ none + · exact canonicalize_known_start_eq_of_materializedStartsPublished table context hpublic hstarts start hknown + · have hmissing : context.state.values start.coordinate = none := not_not.mp hknown + have hnot : start.coordinate ∉ context.state.revealed := fun h => hpublished start.coordinate h hmissing + change (if start.coordinate ∈ context.state.revealed then some (table start) else none) = + context.state.values start.coordinate + simp [hnot, hmissing] + +theorem successful_sign_canonicalization_preserves_start_values + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (hcanonical : CanonicalMaterializedValues table context) (hconsistent : context.ValuesConsistent) + (hpublished : PublishedValues context.state) (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache))) + (hsuccess : result.value.1 ≠ none) (start : OtsSecretIndex) : + (canonicalizeMaterializedValues table result.context).state.values start.coordinate = result.context.state.values start.coordinate := by + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table result hconsistent hstarts hresult + exact canonicalize_start_values_eq_of_materializedStartsPublished table result.context + (materializedStartsPublished_of_mem_successful_sign parameter root ftsSecret message context fuel table cache + result (materializedStartsPublished_of_canonical table context hcanonical) hresult hsuccess) + (resolvedPreservesPublishedValues_maskedPublishedChronologicalSign parameter root ftsSecret message + context cache fuel table result hpublished hresult) hcore.2.2 start + +theorem successful_sign_canonicalization_completedStartTable + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (hcanonical : CanonicalMaterializedValues table context) (hconsistent : context.ValuesConsistent) + (hpublished : PublishedValues context.state) (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache))) + (hsuccess : result.value.1 ≠ none) (base : OtsSecretIndex → HashOutput) : + completedStartTable (canonicalizeMaterializedValues table result.context).state base = + completedStartTable result.context.state base := by + funext start + unfold completedStartTable + rw [successful_sign_canonicalization_preserves_start_values parameter root ftsSecret message context fuel table cache + result hcanonical hconsistent hpublished hstarts hresult hsuccess start] + +theorem successful_sign_canonicalization_historyHit + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (hcanonical : CanonicalMaterializedValues table context) (hconsistent : context.ValuesConsistent) + (hpublished : PublishedValues context.state) (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache))) + (hsuccess : result.value.1 ≠ none) (history : List Probe) (base : OtsSecretIndex → HashOutput) : + ChainStartHistoryHit (canonicalizeMaterializedValues table result.context) history base = + ChainStartHistoryHit result.context history base := by + apply propext + unfold ChainStartHistoryHit + apply exists_congr + rintro ⟨coordinate, digest⟩ + cases coordinate with + | position position => simp [ChainStartEntryHit] + | chainStart lay tree leafIdx chainIdx => + have heq := successful_sign_canonicalization_preserves_start_values parameter root ftsSecret message context fuel + table cache result hcanonical hconsistent hpublished hstarts hresult hsuccess ⟨lay, tree, leafIdx, chainIdx⟩ + change (canonicalizeMaterializedValues table result.context).state.values (.chainStart lay tree leafIdx chainIdx) = + result.context.state.values (.chainStart lay tree leafIdx chainIdx) at heq + rw [heq] + +theorem signing_start_erasure_requires_failed_reply + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (hcanonical : CanonicalMaterializedValues table context) (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache))) + (start : OtsSecretIndex) (hknown : result.context.state.values start.coordinate ≠ none) + (herased : (canonicalizeMaterializedValues table result.context).state.values start.coordinate = none) : + result.value.1 = none := by + by_contra hsuccess + rw [successful_sign_canonicalization_preserves_known_starts parameter root ftsSecret message context fuel table cache + result hcanonical hconsistent hstarts hresult hsuccess start hknown] at herased + exact hknown herased + +theorem signing_start_erasure_requires_failed_afterDigest + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (Option Signature × SplitHashCache)) + (hpublic : MaterializedStartsPublished context) + (hresult : some result ∈ support (runResolvedFromTable context fuel table + ((maskedPublishedChronologicalSign parameter root ftsSecret message).run cache))) + (start : OtsSecretIndex) (hknown : result.context.state.values start.coordinate ≠ none) + (herased : (canonicalizeMaterializedValues table result.context).state.values start.coordinate = none) : + ∃ (digest : ResolvedRunResult (Option (Randomness × Index × (DigestTree → FtsLeaf)) × SplitHashCache)) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf), + some digest ∈ support (runResolvedFromTable context fuel table + ((simulateQ ordinaryRomImpl (signDigestLoop digestAttemptLimit + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ message)).run cache)) ∧ + digest.value.1 = some (randomness, index, leaves) ∧ + some result ∈ support (runResolvedFromTable digest.context digest.remaining digest.table + ((maskedPublishedChronologicalSignAfterDigest parameter ftsSecret randomness index leaves).run digest.value.2)) ∧ + result.value.1 = none := by + have hnotPublic : ¬MaterializedStartsPublished result.context := by + intro h + have hrevealed := h start hknown + change (if start.coordinate ∈ result.context.state.revealed then some (table start) else none) = none at herased + simp [hrevealed] at herased + have hfailed : result.value.1 = none := by + by_contra hsuccess + exact hnotPublic (materializedStartsPublished_of_mem_successful_sign parameter root ftsSecret message + context fuel table cache result hpublic hresult hsuccess) + rw [maskedPublishedChronologicalSign, StateT.run_bind, runResolvedFromTable_bind, mem_support_bind_iff] at hresult + obtain ⟨digestOption, hdigest, hrest⟩ := hresult + cases digestOption with + | none => simp at hrest + | some digest => + cases hselected : digest.value.1 with + | none => + simp [hselected, runResolvedFromTable] at hrest + subst result + apply False.elim + apply hnotPublic + intro other hvalue + have hpreserved := resolvedPreservesCoordinate_simulateQ_ordinaryRomImpl other.coordinate _ + context fuel table cache digest hdigest + exact hpreserved.2.mpr (hpublic other (by rwa [hpreserved.1] at hvalue)) + | some selected => + rcases selected with ⟨randomness, index, leaves⟩ + exact ⟨digest, randomness, index, leaves, hdigest, hselected, + by simpa only [hselected] using hrest, hfailed⟩ + +theorem canonicalize_completedStartTable_independent + (context : DeferredContext) (left right : OtsSecretIndex → HashOutput) + (hpublished : PublishedValues context.state) : + canonicalizeMaterializedValues (completedStartTable context.state left) context = + canonicalizeMaterializedValues (completedStartTable context.state right) context := by + have hvalues : publicMaterializedValues (completedStartTable context.state left) context = + publicMaterializedValues (completedStartTable context.state right) context := by + funext coordinate + unfold publicMaterializedValues + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, if_pos] + cases coordinate with + | position position => rfl + | chainStart lay tree leafIdx chainIdx => + obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp (hpublished _ hrevealed) + simp [resolvedCompletionValue, completedStartTable, OtsSecretIndex.coordinate, houtput] + · simp [hrevealed] + unfold canonicalizeMaterializedValues + rw [hvalues] + +theorem completeResolvedHistory_canonicalize + (context : DeferredContext) (fuel : Nat) (history : List Probe) (value : α) + (reference : OtsSecretIndex → HashOutput) + (hpublic : MaterializedStartsPublished context) (hpublished : PublishedValues context.state) : + (completeResolvedHistory context fuel history value >>= fun result => + pure (match result with + | none => none + | some result => some { result with context := canonicalizeMaterializedValues result.table result.context })) = + completeResolvedHistory (canonicalizeMaterializedValues (completedStartTable context.state reference) context) + fuel history value := by + let after := canonicalizeMaterializedValues (completedStartTable context.state reference) context + have hvalues : ∀ start : OtsSecretIndex, after.state.values start.coordinate = context.state.values start.coordinate := + canonicalize_start_values_eq_of_materializedStartsPublished _ context hpublic hpublished + (startTableAgrees_completedStartTable context.state reference) + have hhistory : ∀ base, ChainStartHistoryHit after history base = ChainStartHistoryHit context history base := + fun base => chainStartHistoryHit_eq_of_start_values_eq context after history base hvalues + have htable : ∀ base, completedStartTable after.state base = completedStartTable context.state base := by + intro base + funext start + unfold completedStartTable + rw [hvalues] + unfold completeResolvedHistory + rw [bind_assoc] + congr 1 + funext base + rw [hhistory base] + split_ifs + · simp only [pure_bind] + · simp only [pure_bind] + rw [canonicalize_completedStartTable_independent context base reference hpublished, htable base] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeSimulation.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSimulation.lean new file mode 100644 index 00000000..77eda91a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSimulation.lean @@ -0,0 +1,1251 @@ +import SphincsSecurity.Proof.LazyRevealProbe +import SphincsSecurity.Proof.SecretProbeTerminal + +/-! +# Opaque one-time chain values + +The lazy one-time simulation gives a separate opaque cell to every chain start and every structural +oracle answer. An ordinary chain query probes the value at its starting digit. A leaf query probes +chain zero's endpoint, which is the only endpoint needed by the fresh-opening extraction; a backward +opening always starts strictly before the endpoint and is therefore caught by a chain query. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +inductive Coordinate where + | chainStart (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) + | position (position : Position) +deriving DecidableEq + +structure Probe where + coordinate : Coordinate + candidate : Digest +deriving DecidableEq + +noncomputable def Probe.target (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (probe : Probe) : Digest := + match probe.coordinate with + | .chainStart lay tree leafIdx chainIdx => otsSecret lay tree leafIdx chainIdx + | .position position => honestValue f parameter otsSecret ftsSecret position + +def Probe.Hits (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (probe : Probe) : Prop := + probe.candidate = probe.target f parameter otsSecret ftsSecret + +def Probe.SourceSettled (cache : QueryCache HashSpec) (secretKey : SecretKey) + (probe : Probe) : Prop := + match probe.coordinate with + | .chainStart _ _ _ _ => True + | .position position => + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position + +theorem Probe.target_eq_of_sourceSettled + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {f g : QueryImpl HashSpec Id} {probe : Probe} + (hf : cache.AgreesWithFn f) (hg : cache.AgreesWithFn g) + (hsettled : probe.SourceSettled cache secretKey) : + probe.target f secretKey.parameter secretKey.otsSecret secretKey.ftsSecret = + probe.target g secretKey.parameter secretKey.otsSecret secretKey.ftsSecret := by + cases probe with + | mk coordinate candidate => + cases coordinate with + | chainStart => rfl + | position position => + simp only [Probe.SourceSettled] at hsettled + simp only [Probe.target] + rw [honestValue_eq_of_settled hf hsettled, + honestValue_eq_of_settled hg hsettled] + +noncomputable def toProbe (probe : OtsValueProbe) : Probe := + if hzero : probe.digit.val = 0 then + ⟨.chainStart probe.lay probe.tree probe.leafIdx probe.chainIdx, probe.candidate⟩ + else + let step : ChainStep := ⟨probe.digit.val - 1, by + have := probe.digit.isLt + simp only [chainLength, winternitzBits] at this ⊢ + omega⟩ + ⟨.position (.chain probe.lay probe.tree probe.leafIdx probe.chainIdx step), + probe.candidate⟩ + +@[simp] theorem toProbe_candidate (probe : OtsValueProbe) : + (toProbe probe).candidate = probe.candidate := by + unfold toProbe + split <;> rfl + +theorem toProbe_target + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (probe : OtsValueProbe) : + (toProbe probe).target f parameter otsSecret ftsSecret = + probe.target f parameter otsSecret := by + unfold toProbe + split_ifs with hzero + · simp only [Probe.target] + exact (probe.target_zero hzero).symm + · simp only [Probe.target] + let step : ChainStep := ⟨probe.digit.val - 1, by + have := probe.digit.isLt + simp only [chainLength, winternitzBits] at this ⊢ + omega⟩ + have hdigit : probe.digit.val = step.val + 1 := by + simp only [step] + omega + exact (probe.target_succ hdigit).symm + +theorem toProbe_hits + {f : QueryImpl HashSpec Id} {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} {probe : OtsValueProbe} + (hhit : probe.Hits f parameter otsSecret) : + (toProbe probe).Hits f parameter otsSecret ftsSecret := by + rw [Probe.Hits, toProbe_target] + simpa only [toProbe_candidate, OtsValueProbe.Hits] using hhit + +theorem toProbe_sourceSettled_of_layerRootSettled + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {probe : OtsValueProbe} + (hleaf : probe.leafIdx.val < 2 ^ layerHeight probe.lay) + (hroot : LayerRootSettled cache secretKey probe.lay probe.tree) : + (toProbe probe).SourceSettled cache secretKey := by + have hleaf := (settled_tree_path_of_settled_root probe.lay probe.tree probe.leafIdx + hleaf hroot).1 + unfold toProbe + split_ifs with hzero + · trivial + · simp only [Probe.SourceSettled] + apply settled_chain_of_settled_leaf probe.lay probe.tree probe.leafIdx hleaf probe.chainIdx + (probe.digit.val - 1) + +def Probe.MatchesInput (parameter : PublicParameter) (probe : Probe) + (input : HashInput) : Prop := + match probe.coordinate with + | .chainStart lay tree leafIdx chainIdx => + ∃ step : ChainStep, step.val = 0 ∧ + input = tweakableHashInput parameter (.chain lay tree leafIdx chainIdx step) + (digestBytes probe.candidate) + | .position (.chain lay tree leafIdx chainIdx step) => + if _hnext : step.val + 1 < chainLength - 1 then + ∃ nextStep : ChainStep, nextStep.val = step.val + 1 ∧ + input = tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx nextStep) (digestBytes probe.candidate) + else + chainIdx.val = 0 ∧ ∃ payload : HashInput, + input = tweakableHashInput parameter (.leaf lay tree leafIdx) payload ∧ + slotDigest 0 input = probe.candidate + | .position _ => False + +noncomputable def Probe.outputCoordinate (probe : Probe) : Coordinate := + match probe.coordinate with + | .chainStart lay tree leafIdx chainIdx => + .position (.chain lay tree leafIdx chainIdx + ⟨0, by norm_num [chainLength, winternitzBits]⟩) + | .position (.chain lay tree leafIdx chainIdx step) => + if hnext : step.val + 1 < chainLength - 1 then + .position (.chain lay tree leafIdx chainIdx ⟨step.val + 1, hnext⟩) + else + .position (.leaf lay tree leafIdx) + | .position position => .position position + +theorem Probe.target_ftsSecret_irrel_of_matchesInput + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (left right : Index → FtsTree → FtsLeaf → Digest) + (probe : Probe) (input : HashInput) (hmatch : probe.MatchesInput parameter input) : + probe.target f parameter otsSecret left = + probe.target f parameter otsSecret right := by + cases probe with + | mk coordinate candidate => + cases coordinate with + | chainStart => rfl + | position position => + cases position <;> simp only [Probe.MatchesInput] at hmatch + case chain => rfl + +theorem toProbe_matchesInput + (parameter : PublicParameter) (probe : OtsValueProbe) (input : HashInput) + (hmatch : probe.MatchesInput parameter input) : + (toProbe probe).MatchesInput parameter input := by + rcases hmatch with hchain | hleaf + · obtain ⟨step, hdigit, hinput⟩ := hchain + by_cases hzero : probe.digit.val = 0 + · have hto : toProbe probe = + ⟨.chainStart probe.lay probe.tree probe.leafIdx probe.chainIdx, + probe.candidate⟩ := by + unfold toProbe + rw [dif_pos hzero] + rw [hto] + simp only [Probe.MatchesInput] + exact ⟨step, hdigit.symm.trans hzero, hinput⟩ + · + let previous : ChainStep := ⟨probe.digit.val - 1, by + have := probe.digit.isLt + simp only [chainLength, winternitzBits] at this ⊢ + omega⟩ + have hto : toProbe probe = + ⟨.position (.chain probe.lay probe.tree probe.leafIdx probe.chainIdx previous), + probe.candidate⟩ := by + unfold toProbe + rw [dif_neg hzero] + have hnext : previous.val + 1 < chainLength - 1 := by + simp only [previous] + have := step.isLt + omega + rw [hto] + simp only [Probe.MatchesInput] + rw [dif_pos hnext] + exact ⟨step, by simp only [previous]; omega, hinput⟩ + · obtain ⟨hdigit, hchain, payload, hinput, hslot⟩ := hleaf + have hnonzero : probe.digit.val ≠ 0 := by + simp only [chainLength, winternitzBits] at hdigit + omega + let previous : ChainStep := ⟨probe.digit.val - 1, by + have := probe.digit.isLt + simp only [chainLength, winternitzBits] at this ⊢ + omega⟩ + have hto : toProbe probe = + ⟨.position (.chain probe.lay probe.tree probe.leafIdx probe.chainIdx previous), + probe.candidate⟩ := by + unfold toProbe + rw [dif_neg hnonzero] + have hlast : ¬previous.val + 1 < chainLength - 1 := by + simp only [previous] + omega + rw [hto] + simp only [Probe.MatchesInput] + rw [dif_neg hlast] + exact ⟨hchain, payload, hinput, hslot⟩ + +theorem FreshLayerOpening.exists_matching_probe + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} + (hfresh : FreshLayerOpening f cache secretKey signingLog) : + ∃ (probe : Probe) (input : HashInput), + probe.Hits f secretKey.parameter secretKey.otsSecret (fun _ _ _ => 0) ∧ + probe.MatchesInput secretKey.parameter input ∧ cache input ≠ none := by + obtain ⟨valueProbe, input, hhit, hunsigned, hmatch, hcached⟩ := + hfresh.exists_hit_probe_cached + exact ⟨toProbe valueProbe, input, toProbe_hits hhit, + toProbe_matchesInput secretKey.parameter valueProbe input hmatch, hcached⟩ + +theorem BackwardChainOpening.exists_matching_probe + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} + (hbackward : BackwardChainOpening f cache secretKey signingLog) : + ∃ (probe : Probe) (input : HashInput), + probe.Hits f secretKey.parameter secretKey.otsSecret (fun _ _ _ => 0) ∧ + probe.MatchesInput secretKey.parameter input ∧ cache input ≠ none := by + obtain ⟨valueProbe, signedDigit, input, hhit, hlt, hmatch, hcached⟩ := + hbackward.exists_hit_probe_cached + exact ⟨toProbe valueProbe, input, toProbe_hits hhit, + toProbe_matchesInput secretKey.parameter valueProbe input hmatch, hcached⟩ + +theorem cleanFreshEvent_exists_matching_probe + {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {result : (Digest × Forgery × Bool) × ViewedFullTraceState} + (hevent : cleanFreshEvent parameter otsSecret ftsSecret result) : + ∃ (f : QueryImpl HashSpec Id) (probe : Probe) (input : HashInput), + result.2.cache.AgreesWithFn f ∧ + probe.Hits f parameter otsSecret ftsSecret ∧ + probe.MatchesInput parameter input ∧ result.2.cache input ≠ none := by + obtain ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hfresh⟩ := + hevent.2.toViewed + obtain ⟨probe, input, hhit, hmatch, hcached⟩ := + SphincsSecurity.Concrete.OtsProbeSimulation.FreshLayerOpening.exists_matching_probe + hfresh.toForged.toFreshLayerOpening + refine ⟨f, probe, input, hf, ?_, hmatch, hcached⟩ + rw [Probe.Hits] at hhit ⊢ + rw [← probe.target_ftsSecret_irrel_of_matchesInput f parameter otsSecret + (fun _ _ _ => 0) ftsSecret input hmatch] + exact hhit + +theorem cleanBackwardEvent_exists_matching_probe + {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {result : (Digest × Forgery × Bool) × ViewedFullTraceState} + (hevent : cleanBackwardEvent parameter otsSecret ftsSecret result) : + ∃ (f : QueryImpl HashSpec Id) (probe : Probe) (input : HashInput), + result.2.cache.AgreesWithFn f ∧ + probe.Hits f parameter otsSecret ftsSecret ∧ + probe.MatchesInput parameter input ∧ result.2.cache input ≠ none := by + obtain ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hbackward⟩ := + hevent.2.toViewed + obtain ⟨probe, input, hhit, hmatch, hcached⟩ := + SphincsSecurity.Concrete.OtsProbeSimulation.BackwardChainOpening.exists_matching_probe + hbackward.toForged.toBackwardChainOpening + refine ⟨f, probe, input, hf, ?_, hmatch, hcached⟩ + rw [Probe.Hits] at hhit ⊢ + rw [← probe.target_ftsSecret_irrel_of_matchesInput f parameter otsSecret + (fun _ _ _ => 0) ftsSecret input hmatch] + exact hhit + +theorem chainProbeInput_eq_iff (parameter : PublicParameter) + (leftLay rightLay : Layer) (leftTree rightTree : TreeIndex) + (leftLeaf rightLeaf : LeafIndex) (leftChain rightChain : ChainIndex) + (leftStep rightStep : ChainStep) (leftCandidate rightCandidate : Digest) : + tweakableHashInput parameter + (.chain leftLay leftTree leftLeaf leftChain leftStep) (digestBytes leftCandidate) = + tweakableHashInput parameter + (.chain rightLay rightTree rightLeaf rightChain rightStep) (digestBytes rightCandidate) ↔ + leftLay = rightLay ∧ leftTree = rightTree ∧ leftLeaf = rightLeaf ∧ + leftChain = rightChain ∧ leftStep = rightStep ∧ leftCandidate = rightCandidate := by + constructor + · intro heq + have hparts := tweakableHashInput_injective parameter (by trivial) (by trivial) heq + simp only [HashDomain.chain.injEq] at hparts + exact ⟨hparts.1.1, hparts.1.2.1, hparts.1.2.2.1, hparts.1.2.2.2.1, + hparts.1.2.2.2.2, digestBytes_injective hparts.2⟩ + · rintro ⟨rfl, rfl, rfl, rfl, rfl, rfl⟩ + rfl + +theorem chainProbeInput_ne_leafInput (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (step : ChainStep) (candidate : Digest) + (leafLay : Layer) (leafTree : TreeIndex) (leaf : LeafIndex) (payload : HashInput) : + tweakableHashInput parameter (.chain lay tree leafIdx chainIdx step) + (digestBytes candidate) ≠ + tweakableHashInput parameter (.leaf leafLay leafTree leaf) payload := by + intro heq + have hdomain := (tweakableHashInput_injective parameter (by trivial) (by trivial) heq).1 + simp at hdomain + +theorem leafInput_domain_eq (parameter : PublicParameter) + (leftLay rightLay : Layer) (leftTree rightTree : TreeIndex) + (leftLeaf rightLeaf : LeafIndex) (leftPayload rightPayload : HashInput) + (heq : tweakableHashInput parameter (.leaf leftLay leftTree leftLeaf) leftPayload = + tweakableHashInput parameter (.leaf rightLay rightTree rightLeaf) rightPayload) : + leftLay = rightLay ∧ leftTree = rightTree ∧ leftLeaf = rightLeaf := by + have hdomain := (tweakableHashInput_injective parameter (by trivial) (by trivial) heq).1 + simpa only [HashDomain.leaf.injEq] using hdomain + +theorem Probe.matchesInput_unique (parameter : PublicParameter) (input : HashInput) + {left right : Probe} (hleft : left.MatchesInput parameter input) + (hright : right.MatchesInput parameter input) : left = right := by + rcases left with ⟨leftCoordinate, leftCandidate⟩ + rcases right with ⟨rightCoordinate, rightCandidate⟩ + cases leftCoordinate with + | chainStart leftLay leftTree leftLeaf leftChain => + obtain ⟨leftStep, hleftZero, hleftInput⟩ := hleft + cases rightCoordinate with + | chainStart rightLay rightTree rightLeaf rightChain => + obtain ⟨rightStep, hrightZero, hrightInput⟩ := hright + have hparts := (chainProbeInput_eq_iff parameter leftLay rightLay leftTree rightTree + leftLeaf rightLeaf leftChain rightChain leftStep rightStep leftCandidate + rightCandidate).1 (hleftInput.symm.trans hrightInput) + rcases hparts with ⟨rfl, rfl, rfl, rfl, hstep, rfl⟩ + rfl + | position rightPosition => + cases rightPosition with + | chain rightLay rightTree rightLeaf rightChain rightStep => + simp only [Probe.MatchesInput] at hright + by_cases hrightNext : rightStep.val + 1 < chainLength - 1 + · rw [dif_pos hrightNext] at hright + obtain ⟨nextStep, hnext, hrightInput⟩ := hright + have hparts := (chainProbeInput_eq_iff parameter leftLay rightLay leftTree + rightTree leftLeaf rightLeaf leftChain rightChain leftStep nextStep + leftCandidate rightCandidate).1 (hleftInput.symm.trans hrightInput) + rcases hparts with ⟨hlay, htree, hleaf, hchain, hstep, hcandidate⟩ + have hstepVal := congrArg Fin.val hstep + omega + · rw [dif_neg hrightNext] at hright + obtain ⟨hchain, payload, hrightInput, hslot⟩ := hright + exact (chainProbeInput_ne_leafInput parameter leftLay leftTree leftLeaf leftChain + leftStep leftCandidate rightLay rightTree rightLeaf payload + (hleftInput.symm.trans hrightInput)).elim + | leaf | node | ftsLeaf | ftsNode | ftsRoots => simp [Probe.MatchesInput] at hright + | position leftPosition => + cases leftPosition with + | chain leftLay leftTree leftLeaf leftChain leftStep => + simp only [Probe.MatchesInput] at hleft + cases rightCoordinate with + | chainStart rightLay rightTree rightLeaf rightChain => + obtain ⟨rightStartStep, hrightZero, hrightInput⟩ := hright + by_cases hleftNext : leftStep.val + 1 < chainLength - 1 + · rw [dif_pos hleftNext] at hleft + obtain ⟨leftNextStep, hnext, hleftInput⟩ := hleft + have hparts := (chainProbeInput_eq_iff parameter leftLay rightLay leftTree + rightTree leftLeaf rightLeaf leftChain rightChain leftNextStep rightStartStep + leftCandidate rightCandidate).1 (hleftInput.symm.trans hrightInput) + rcases hparts with ⟨hlay, htree, hleaf, hchain, hstep, hcandidate⟩ + have hstepVal := congrArg Fin.val hstep + omega + · rw [dif_neg hleftNext] at hleft + obtain ⟨hchain, payload, hleftInput, hslot⟩ := hleft + exact (chainProbeInput_ne_leafInput parameter rightLay rightTree rightLeaf + rightChain rightStartStep rightCandidate leftLay leftTree leftLeaf payload + (hrightInput.symm.trans hleftInput)).elim + | position rightPosition => + cases rightPosition with + | chain rightLay rightTree rightLeaf rightChain rightStep => + simp only [Probe.MatchesInput] at hright + by_cases hleftNext : leftStep.val + 1 < chainLength - 1 + · by_cases hrightNext : rightStep.val + 1 < chainLength - 1 + · rw [dif_pos hleftNext] at hleft + rw [dif_pos hrightNext] at hright + obtain ⟨leftNext, hleftNextValue, hleftInput⟩ := hleft + obtain ⟨rightNext, hrightNextValue, hrightInput⟩ := hright + have hparts := (chainProbeInput_eq_iff parameter leftLay rightLay leftTree + rightTree leftLeaf rightLeaf leftChain rightChain leftNext rightNext + leftCandidate rightCandidate).1 (hleftInput.symm.trans hrightInput) + rcases hparts with ⟨hlay, htree, hleaf, hchain, hnextStep, hcandidate⟩ + have hnextValue := congrArg Fin.val hnextStep + have hstep : leftStep = rightStep := Fin.ext (by omega) + cases hlay + cases htree + cases hleaf + cases hchain + cases hstep + cases hcandidate + rfl + · rw [dif_pos hleftNext] at hleft + rw [dif_neg hrightNext] at hright + obtain ⟨leftNext, hleftNextValue, hleftInput⟩ := hleft + obtain ⟨hchain, payload, hrightInput, hslot⟩ := hright + exact (chainProbeInput_ne_leafInput parameter leftLay leftTree leftLeaf + leftChain leftNext leftCandidate rightLay rightTree rightLeaf payload + (hleftInput.symm.trans hrightInput)).elim + · by_cases hrightNext : rightStep.val + 1 < chainLength - 1 + · rw [dif_neg hleftNext] at hleft + rw [dif_pos hrightNext] at hright + obtain ⟨hchain, payload, hleftInput, hslot⟩ := hleft + obtain ⟨rightNext, hrightNextValue, hrightInput⟩ := hright + exact (chainProbeInput_ne_leafInput parameter rightLay rightTree rightLeaf + rightChain rightNext rightCandidate leftLay leftTree leftLeaf payload + (hrightInput.symm.trans hleftInput)).elim + · rw [dif_neg hleftNext] at hleft + rw [dif_neg hrightNext] at hright + obtain ⟨hleftChain, leftPayload, hleftInput, hleftSlot⟩ := hleft + obtain ⟨hrightChain, rightPayload, hrightInput, hrightSlot⟩ := hright + have hparts := leafInput_domain_eq parameter leftLay rightLay leftTree + rightTree leftLeaf rightLeaf leftPayload rightPayload + (hleftInput.symm.trans hrightInput) + rcases hparts with ⟨hlay, htree, hleaf⟩ + have hchain : leftChain = rightChain := + Fin.ext (hleftChain.trans hrightChain.symm) + have hstep : leftStep = rightStep := by + apply Fin.ext + have hleftLt := leftStep.isLt + have hrightLt := rightStep.isLt + omega + have hcandidate : leftCandidate = rightCandidate := + hleftSlot.symm.trans hrightSlot + cases hlay + cases htree + cases hleaf + cases hchain + cases hstep + cases hcandidate + rfl + | leaf | node | ftsLeaf | ftsNode | ftsRoots => + simp [Probe.MatchesInput] at hright + | leaf | node | ftsLeaf | ftsNode | ftsRoots => simp [Probe.MatchesInput] at hleft + +noncomputable def decodeProbe? (parameter : PublicParameter) (input : HashInput) : + Option Probe := by + classical + exact if hexists : ∃ probe : Probe, probe.MatchesInput parameter input then + some hexists.choose + else none + +theorem decodeProbe?_eq_none_iff (parameter : PublicParameter) (input : HashInput) : + decodeProbe? parameter input = none ↔ + ∀ probe : Probe, ¬probe.MatchesInput parameter input := by + classical + constructor + · intro hdecode probe hmatch + have hexists : ∃ candidate : Probe, candidate.MatchesInput parameter input := + ⟨probe, hmatch⟩ + unfold decodeProbe? at hdecode + rw [dif_pos hexists] at hdecode + simp at hdecode + · intro hnone + unfold decodeProbe? + rw [dif_neg] + rintro ⟨probe, hmatch⟩ + exact hnone probe hmatch + +theorem decodeProbe?_eq_some_iff (parameter : PublicParameter) (input : HashInput) + (probe : Probe) : + decodeProbe? parameter input = some probe ↔ probe.MatchesInput parameter input := by + classical + unfold decodeProbe? + split_ifs with hexists + · constructor + · intro heq + have hchosen : hexists.choose = probe := by simpa using heq + simpa [← hchosen] using hexists.choose_spec + · intro hmatch + have hchosen : hexists.choose = probe := + Probe.matchesInput_unique parameter input hexists.choose_spec hmatch + simp [hchosen] + · constructor + · simp + · intro hmatch + exact (hexists ⟨probe, hmatch⟩).elim + +noncomputable def decodePosition? (parameter : PublicParameter) (input : HashInput) : + Option Position := by + classical + exact if hexists : ∃ position : Position, AtPosition parameter input position then + some hexists.choose + else none + +theorem decodePosition?_eq_some_iff (parameter : PublicParameter) (input : HashInput) + (position : Position) : + decodePosition? parameter input = some position ↔ + AtPosition parameter input position := by + classical + unfold decodePosition? + split_ifs with hexists + · constructor + · intro heq + have hchosen : hexists.choose = position := by simpa using heq + simpa [← hchosen] using hexists.choose_spec + · intro hposition + have hchosen : hexists.choose = position := + atPosition_unique parameter hexists.choose_spec hposition + simp [hchosen] + · constructor + · simp + · intro hposition + exact (hexists ⟨position, hposition⟩).elim + +inductive SplitHashKey where + | ordinary (input : HashInput) + | hidden (coordinate : Coordinate) +deriving DecidableEq + +abbrev SplitHashCache := SplitHashKey → Option HashOutput + +def emptySplitHashCache : SplitHashCache := fun _ => none + +noncomputable def tableValue (table : Coordinate → HashOutput) + (position : Position) : Digest := + truncateHash (table (.position position)) + +def IsOtsPosition : Position → Prop + | .chain _ _ _ _ _ => True + | .leaf _ _ _ => True + | .node _ _ _ _ => True + | _ => False + +noncomputable def tableOtsSecret (table : Coordinate → HashOutput) : + Layer → TreeIndex → LeafIndex → ChainIndex → Digest := + fun lay tree leafIdx chainIdx => + truncateHash (table (.chainStart lay tree leafIdx chainIdx)) + +noncomputable def tablePayload (table : Coordinate → HashOutput) : + Position → HashInput + | position@(.chain lay tree leafIdx chainIdx step) => + if step.val = 0 then + digestBytes (truncateHash (table (.chainStart lay tree leafIdx chainIdx))) + else + (position.children.map (tableValue table)).flatMap digestBytes + | position => (position.children.map (tableValue table)).flatMap digestBytes + +noncomputable def tableInput (parameter : PublicParameter) + (table : Coordinate → HashOutput) : Coordinate → HashInput + | .chainStart _ _ _ _ => [] + | .position position => + tweakableHashInput parameter position.domain (tablePayload table position) + +noncomputable def tableAnswerDecoded (parameter : PublicParameter) + (table : Coordinate → HashOutput) (fallback : QueryImpl HashSpec Id) + (input : HashInput) : Option Position → HashOutput + | some position@(.chain _ _ _ _ _) => + if input = tableInput parameter table (.position position) then + table (.position position) + else fallback input + | some position@(.leaf _ _ _) => + if input = tableInput parameter table (.position position) then + table (.position position) + else fallback input + | some position@(.node _ _ _ _) => + if input = tableInput parameter table (.position position) then + table (.position position) + else fallback input + | _ => fallback input + +noncomputable def tableAnswer (parameter : PublicParameter) + (table : Coordinate → HashOutput) (fallback : QueryImpl HashSpec Id) : + QueryImpl HashSpec Id := + fun input => tableAnswerDecoded parameter table fallback input + (decodePosition? parameter input) + +noncomputable def completedSplitHashCache (table : Coordinate → HashOutput) + (ensured : Finset Coordinate) (cache : SplitHashCache) : SplitHashCache + | .ordinary input => cache (.ordinary input) + | .hidden coordinate => + match cache (.hidden coordinate) with + | some output => some output + | none => if coordinate ∈ ensured then some (table coordinate) else none + +noncomputable def mergeDecodedPosition (parameter : PublicParameter) + (table : Coordinate → HashOutput) (ensured : Finset Coordinate) + (cache : SplitHashCache) (input : HashInput) : Option Position → Option HashOutput + | some position@(.chain _ _ _ _ _) => + if input = tableInput parameter table (.position position) then + completedSplitHashCache table ensured cache (.hidden (.position position)) + else cache (.ordinary input) + | some position@(.leaf _ _ _) => + if input = tableInput parameter table (.position position) then + completedSplitHashCache table ensured cache (.hidden (.position position)) + else cache (.ordinary input) + | some position@(.node _ _ _ _) => + if input = tableInput parameter table (.position position) then + completedSplitHashCache table ensured cache (.hidden (.position position)) + else cache (.ordinary input) + | _ => cache (.ordinary input) + +noncomputable def mergedCache (parameter : PublicParameter) + (table : Coordinate → HashOutput) (ensured : Finset Coordinate) + (cache : SplitHashCache) : QueryCache HashSpec := + fun input => mergeDecodedPosition parameter table ensured cache input + (decodePosition? parameter input) + +noncomputable def splitHashQuery (key : SplitHashKey) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput := do + let cache ← get + match cache key with + | some output => pure output + | none => + let output ← liftM (LazyRevealProbe.hashOutputQuery (Coordinate := Coordinate)) + set (Function.update cache key (some output)) + pure output + +noncomputable def ordinaryHashImpl : + QueryImpl HashSpec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate))) := + fun input => splitHashQuery (.ordinary input) + +noncomputable def splitUniformImpl : + QueryImpl unifSpec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate))) := + fun n => liftM (LazyRevealProbe.uniformQuery (Coordinate := Coordinate) n) + +noncomputable def ordinaryRomImpl : + QueryImpl OracleWorld + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate))) := + splitUniformImpl + ordinaryHashImpl + +noncomputable def ensureCoordinate (coordinate : Coordinate) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit := + liftM (LazyRevealProbe.ensureQuery coordinate) + +noncomputable def revealCoordinateOutput (coordinate : Coordinate) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput := do + let output ← liftM (LazyRevealProbe.revealQuery coordinate) + modify fun cache : SplitHashCache => + Function.update cache (.hidden coordinate) (some output) + pure output + +noncomputable def revealCoordinate (coordinate : Coordinate) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Digest := do + let output ← revealCoordinateOutput coordinate + pure (truncateHash output) + +noncomputable def publishCoordinate (coordinate : Coordinate) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit := + liftM (LazyRevealProbe.publishQuery coordinate) + +noncomputable def revealPosition (position : Position) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Digest := + revealCoordinate (.position position) + +noncomputable def revealChainStart (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Digest := + revealCoordinate (.chainStart lay tree leafIdx chainIdx) + +theorem revealCoordinate_run (coordinate : Coordinate) (cache : SplitHashCache) : + (revealCoordinate coordinate).run cache = (do + let output ← LazyRevealProbe.revealQuery coordinate + pure (truncateHash output, + Function.update cache (.hidden coordinate) (some output))) := by + simp [revealCoordinate, revealCoordinateOutput, StateT.run_modify] + +theorem revealPosition_run (position : Position) (cache : SplitHashCache) : + (revealPosition position).run cache = (do + let output ← LazyRevealProbe.revealQuery (.position position) + pure (truncateHash output, + Function.update cache (.hidden (.position position)) (some output))) := by + rw [revealPosition, revealCoordinate_run] + +noncomputable def peekCoordinate (coordinate : Coordinate) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Digest) := do + let output ← liftM (LazyRevealProbe.peekQuery coordinate) + pure (truncateHash <$> output) + +noncomputable def peekPositionValues : List Position → + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option (List Digest)) + | [] => pure (some []) + | position :: remaining => do + match ← peekCoordinate (.position position) with + | none => pure none + | some value => + match ← peekPositionValues remaining with + | none => pure none + | some values => pure (some (value :: values)) + +noncomputable def peekTableInput (parameter : PublicParameter) : Coordinate → + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option HashInput) + | .chainStart _ _ _ _ => pure none + | .position position@(.chain lay tree leafIdx chainIdx step) => do + if step.val = 0 then + match ← peekCoordinate (.chainStart lay tree leafIdx chainIdx) with + | none => pure none + | some value => + pure (some (tweakableHashInput parameter position.domain (digestBytes value))) + else + match ← peekPositionValues position.children with + | none => pure none + | some values => + pure (some (tweakableHashInput parameter position.domain + (values.flatMap digestBytes))) + | .position position => do + match ← peekPositionValues position.children with + | none => pure none + | some values => + pure (some (tweakableHashInput parameter position.domain + (values.flatMap digestBytes))) + +noncomputable def ensureFullChain (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit := do + let _ ← sequenceFin fun step : ChainStep => + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + pure () + +noncomputable def ensureChainPrefix (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit := do + let _ ← sequenceFin fun step : ChainStep => + if step.val < digit.val then + ensureCoordinate (.position (.chain lay tree leafIdx chainIdx step)) + else + pure () + pure () + +noncomputable def ensureOtsLeaf (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit := do + let _ ← sequenceFin fun chainIdx : ChainIndex => + ensureFullChain lay tree leafIdx chainIdx + ensureCoordinate (.position (.leaf lay tree leafIdx)) + +noncomputable def ensureTreeNode (lay : Layer) (tree : TreeIndex) : + Nat → Nat → + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit + | 0, nodeIdx => ensureOtsLeaf lay tree (leafOfNat nodeIdx) + | level + 1, nodeIdx => do + ensureTreeNode lay tree level (2 * nodeIdx) + ensureTreeNode lay tree level (2 * nodeIdx + 1) + if hlevel : level < maxLayerHeight then + ensureCoordinate (.position + (.node lay tree ⟨level, hlevel⟩ (leafOfNat nodeIdx))) + else + pure () + +noncomputable def maskedTreeNode (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Digest := do + ensureTreeNode lay tree level nodeIdx + match level with + | 0 => revealPosition (.leaf lay tree (leafOfNat nodeIdx)) + | current + 1 => + if hlevel : current < maxLayerHeight then + revealPosition (.node lay tree ⟨current, hlevel⟩ (leafOfNat nodeIdx)) + else + pure 0 + +noncomputable def maskedTreeRoot (lay : Layer) (tree : TreeIndex) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Digest := + maskedTreeNode lay tree (layerHeight lay) 0 + +noncomputable def maskedTreePath (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) + (Fin maxLayerHeight → Digest) := + sequenceFin fun level => + if level.val < layerHeight lay then + maskedTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + else + pure 0 + +noncomputable def ensureTreePath (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit := do + let _ ← sequenceFin fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + ensureTreeNode lay tree level.val + (Nat.xor (leafIdx.val / 2 ^ level.val) 1) + else + pure () + pure () + +noncomputable def maskedChainValue (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Digest := do + ensureChainPrefix lay tree leafIdx chainIdx digit + if hzero : digit.val = 0 then + revealChainStart lay tree leafIdx chainIdx + else + let step : ChainStep := ⟨digit.val - 1, by + have := digit.isLt + omega⟩ + revealPosition (.chain lay tree leafIdx chainIdx step) + +noncomputable def maskedOtsSignFrom (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + Nat → Nat → + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) + (Option (Counter × (ChainIndex → Digit))) + | 0, _ => pure none + | attempts + 1, counter => do + let encoded ← simulateQ ordinaryHashImpl + (encode parameter lay tree leafIdx message + (BitVec.ofNat counterBits counter)) + match encoded with + | some encoding => do + let _ ← sequenceFin fun chainIdx => + ensureChainPrefix lay tree leafIdx chainIdx (encoding chainIdx) + pure (some (BitVec.ofNat counterBits counter, encoding)) + | none => + maskedOtsSignFrom parameter lay tree leafIdx message attempts (counter + 1) + +noncomputable def maskedOtsSign (parameter : PublicParameter) (lay : Layer) + (tree : TreeIndex) (leafIdx : LeafIndex) (message : Digest) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) + (Option (Counter × (ChainIndex → Digit))) := + maskedOtsSignFrom parameter lay tree leafIdx message encodingAttemptLimit 0 + +noncomputable def maskedLayerMessage (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Digest := + if hbelow : lay.val + 1 < numLayers then + let below : Layer := ⟨lay.val + 1, hbelow⟩ + maskedTreeRoot below (treeIndexAt index below) + else + simulateQ ordinaryHashImpl (ftsKey parameter index (ftsSecret index)) + +noncomputable def maskedSignLayer (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (index : Index) + (lay : Layer) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) + (Option (Counter × (ChainIndex → Digit))) := do + let tree := treeIndexAt index lay + let leafIdx := leafIndexAt index lay + let message ← maskedLayerMessage parameter ftsSecret index lay + match ← maskedOtsSign parameter lay tree leafIdx message with + | none => pure none + | some (counter, encoding) => do + ensureTreePath lay tree leafIdx + pure (some (counter, encoding)) + +noncomputable def chainValueCoordinate (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (digit : Digit) : Coordinate := + if hzero : digit.val = 0 then + .chainStart lay tree leafIdx chainIdx + else + .position (.chain lay tree leafIdx chainIdx ⟨digit.val - 1, by + have := digit.isLt + omega⟩) + +@[simp] theorem toProbe_coordinate (probe : OtsValueProbe) : + (toProbe probe).coordinate = + chainValueCoordinate probe.lay probe.tree probe.leafIdx probe.chainIdx probe.digit := by + unfold toProbe chainValueCoordinate + split_ifs <;> rfl + +theorem chainValueCoordinate_injective + {leftLay rightLay : Layer} {leftTree rightTree : TreeIndex} + {leftLeaf rightLeaf : LeafIndex} {leftChain rightChain : ChainIndex} + {leftDigit rightDigit : Digit} + (heq : chainValueCoordinate leftLay leftTree leftLeaf leftChain leftDigit = + chainValueCoordinate rightLay rightTree rightLeaf rightChain rightDigit) : + leftLay = rightLay ∧ leftTree = rightTree ∧ leftLeaf = rightLeaf ∧ + leftChain = rightChain ∧ leftDigit = rightDigit := by + by_cases hleft : leftDigit.val = 0 + · by_cases hright : rightDigit.val = 0 + · simp only [chainValueCoordinate, hleft, hright, ↓reduceDIte, + Coordinate.chainStart.injEq] at heq + exact ⟨heq.1, heq.2.1, heq.2.2.1, heq.2.2.2, + Fin.ext (hleft.trans hright.symm)⟩ + · simp [chainValueCoordinate, hleft, hright] at heq + · by_cases hright : rightDigit.val = 0 + · simp [chainValueCoordinate, hleft, hright] at heq + · simp only [chainValueCoordinate, hleft, hright, ↓reduceDIte, + Coordinate.position.injEq, Position.chain.injEq] at heq + refine ⟨heq.1, heq.2.1, heq.2.2.1, heq.2.2.2.1, Fin.ext ?_⟩ + have hleftLt := leftDigit.isLt + have hrightLt := rightDigit.isLt + have hleftPos : 0 < leftDigit.val := Nat.pos_of_ne_zero hleft + have hrightPos : 0 < rightDigit.val := Nat.pos_of_ne_zero hright + have hsub : leftDigit.val - 1 = rightDigit.val - 1 := by + simpa using congrArg Fin.val heq.2.2.2.2 + omega + +noncomputable def revealPublishedCoordinate (coordinate : Coordinate) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Digest := do + let value ← revealCoordinate coordinate + publishCoordinate coordinate + pure value + +noncomputable def revealLayerValues (index : Index) (lay : Layer) + (encoding : ChainIndex → Digit) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) + ((ChainIndex → Digest) × (Fin maxLayerHeight → Digest)) := do + let tree := treeIndexAt index lay + let leafIdx := leafIndexAt index lay + let values ← sequenceFin fun chainIdx => + revealPublishedCoordinate + (chainValueCoordinate lay tree leafIdx chainIdx (encoding chainIdx)) + let path ← sequenceFin fun level : Fin maxLayerHeight => + if level.val < layerHeight lay then + match level.val with + | 0 => revealPublishedCoordinate (.position (.leaf lay tree + (leafOfNat (Nat.xor leafIdx.val 1)))) + | current + 1 => + if hlevel : current < maxLayerHeight then + revealPublishedCoordinate (.position (.node lay tree ⟨current, hlevel⟩ + (leafOfNat (Nat.xor (leafIdx.val / 2 ^ (current + 1)) 1)))) + else pure 0 + else pure 0 + pure (values, path) + +noncomputable def maskedSignAfterDigest (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (randomness : Randomness) (index : Index) (leaves : DigestTree → FtsLeaf) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature) := do + let ftsPath ← simulateQ ordinaryHashImpl + (ftsOpen parameter index leaves (ftsSecret index)) + let layers ← sequenceFin fun lay => + maskedSignLayer parameter ftsSecret index lay + match traverseOption layers with + | none => pure none + | some parts => + let revealed ← sequenceFin fun lay => revealLayerValues index lay (parts lay).2 + pure (some + { randomness := randomness + ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (revealed lay).1 + authPath := flattenPaths fun lay => (revealed lay).2 }) + +noncomputable def maskedSign (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (message : Message) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (Option Signature) := do + let secretKey : SecretKey := + ⟨parameter, root, fun _ _ _ _ => 0, ftsSecret⟩ + match ← simulateQ ordinaryRomImpl + (signDigestLoop digestAttemptLimit secretKey message) with + | none => pure none + | some (randomness, index, leaves) => + maskedSignAfterDigest parameter ftsSecret randomness index leaves + +noncomputable def probe (candidate : Probe) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit := + liftM (LazyRevealProbe.probeQuery candidate.coordinate candidate.candidate) + +noncomputable def probeFirstMissingInputCoordinate (input : HashInput) : + Nat → List Coordinate → + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit + | _, [] => pure () + | slot, coordinate :: remaining => do + match ← peekCoordinate coordinate with + | none => probe ⟨coordinate, slotDigest slot input⟩ + | some _ => probeFirstMissingInputCoordinate input (slot + 1) remaining + +noncomputable def resolveKnownInput (parameter : PublicParameter) + (coordinate : Coordinate) (input : HashInput) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput := do + match ← peekTableInput parameter coordinate with + | some knownInput => + if knownInput = input then + let output ← revealCoordinateOutput coordinate + publishCoordinate coordinate + modify fun cache : SplitHashCache => + Function.update cache (.ordinary input) (some output) + pure output + else + splitHashQuery (.ordinary input) + | none => splitHashQuery (.ordinary input) + +noncomputable def prepareLeafInputProbe (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit := do + match ← peekCoordinate candidate.coordinate with + | none => probe candidate + | some _ => + probeFirstMissingInputCoordinate input 0 + ((Position.leaf lay tree leafIdx).children.map Coordinate.position) + +noncomputable def probingHashQuery (parameter : PublicParameter) (input : HashInput) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput := + match decodeProbe? parameter input with + | some candidate => + match decodePosition? parameter input with + | some (.leaf lay tree leafIdx) => do + prepareLeafInputProbe input candidate lay tree leafIdx + resolveKnownInput parameter candidate.outputCoordinate input + | _ => do + probe candidate + resolveKnownInput parameter candidate.outputCoordinate input + | none => + match decodePosition? parameter input with + | some position@(.chain _ _ _ _ _) => + resolveKnownInput parameter (.position position) input + | some position@(.leaf _ _ _) => + resolveKnownInput parameter (.position position) input + | some position@(.node _ _ _ _) => do + probeFirstMissingInputCoordinate input 0 (position.children.map .position) + resolveKnownInput parameter (.position position) input + | _ => splitHashQuery (.ordinary input) + +noncomputable def probingHashImpl (parameter : PublicParameter) : + QueryImpl HashSpec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate))) := + fun input => probingHashQuery parameter input + +noncomputable def probingRomImpl (parameter : PublicParameter) : + QueryImpl OracleWorld + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate))) := + splitUniformImpl + probingHashImpl parameter + +noncomputable def revealPositionValues : List Position → + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) (List Digest) + | [] => pure [] + | position :: remaining => do + let value ← revealPosition position + let values ← revealPositionValues remaining + pure (value :: values) + +noncomputable def revealTableInputChildren : Coordinate → + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Unit + | .chainStart _ _ _ _ => pure () + | .position position@(.chain lay tree leafIdx chainIdx step) => do + if step.val = 0 then + let _ ← revealChainStart lay tree leafIdx chainIdx + pure () + else + let _ ← revealPositionValues position.children + pure () + | .position position => do + let _ ← revealPositionValues position.children + pure () + +noncomputable def resolveVerifierInput (parameter : PublicParameter) + (coordinate : Coordinate) (input : HashInput) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput := do + let cache ← get + match cache (.ordinary input) with + | some output => pure output + | none => + revealTableInputChildren coordinate + resolveKnownInput parameter coordinate input + +noncomputable def verifierHashQuery (parameter : PublicParameter) (input : HashInput) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) HashOutput := do + match decodeProbe? parameter input with + | some candidate => do + probe candidate + resolveVerifierInput parameter candidate.outputCoordinate input + | none => + match decodePosition? parameter input with + | some position@(.chain _ _ _ _ _) => + resolveVerifierInput parameter (.position position) input + | some position@(.leaf _ _ _) => + resolveVerifierInput parameter (.position position) input + | some position@(.node _ _ _ _) => + resolveVerifierInput parameter (.position position) input + | _ => splitHashQuery (.ordinary input) + +noncomputable def verifierHashImpl (parameter : PublicParameter) : + QueryImpl HashSpec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate))) := + fun input => verifierHashQuery parameter input + +noncomputable def verifierRomImpl (parameter : PublicParameter) : + QueryImpl OracleWorld + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate))) := + splitUniformImpl + verifierHashImpl parameter + +noncomputable def maskedSigningImpl (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + QueryImpl SigningSpec + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate))) := + fun message => maskedSign parameter root ftsSecret message + +noncomputable def maskedExpandedAdversaryImpl (parameter : PublicParameter) + (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + QueryImpl (OracleWorld + SigningSpec) + (StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate))) := + probingRomImpl parameter + maskedSigningImpl parameter root ftsSecret + +abbrev RetainedRestResult := (Forgery × QueryLog SigningSpec) × Bool + +abbrev RetainedGameResult := Digest × RetainedRestResult + +def signingTraceComputation + (computation : OracleComp (OracleWorld + SigningSpec) alpha) : + OracleComp (OracleWorld + SigningSpec) (alpha × QueryLog SigningSpec) := + OracleComp.construct + (C := fun _ => OracleComp (OracleWorld + SigningSpec) + (alpha × QueryLog SigningSpec)) + (fun value => pure (value, [])) + (fun input _next recursivelyTrace => do + let output ← liftM ((OracleWorld + SigningSpec).query input) + let result ← recursivelyTrace output + pure (result.1, signingLogFragment input output ++ result.2)) + computation + +theorem simulateQ_withTraceAppend_run_eq_signingTraceComputation + {m : Type → Type} [Monad m] [LawfulMonad m] + (handler : QueryImpl (OracleWorld + SigningSpec) m) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) : + (simulateQ (QueryImpl.withTraceAppend handler signingLogFragment) + computation).run = + simulateQ handler (signingTraceComputation computation) := by + induction computation using OracleComp.inductionOn with + | pure value => simp [signingTraceComputation] + | query_bind input next ih => simp [signingTraceComputation, ih] + +noncomputable def liftOracleWorldLeft + (computation : OracleComp OracleWorld alpha) : + OracleComp (OracleWorld + SigningSpec) alpha := by + letI directLift : MonadLift (OracleQuery OracleWorld) + (OracleQuery (OracleWorld + SigningSpec)) := + (OracleQuery.subSpec_add_left + (spec₁ := OracleWorld) (spec₂ := SigningSpec)).toMonadLift + exact liftM computation + +theorem simulateQ_liftOracleWorldLeft + {m : Type → Type} [Monad m] [LawfulMonad m] + (left : QueryImpl OracleWorld m) (right : QueryImpl SigningSpec m) + (computation : OracleComp OracleWorld alpha) : + simulateQ (left + right) (liftOracleWorldLeft computation) = + simulateQ left computation := by + unfold liftOracleWorldLeft + exact QueryImpl.simulateQ_add_liftM_left left right computation + +noncomputable def retainedGameRestComputation (adversary : Adversary) + (publicKey : PublicKey) : + OracleComp (OracleWorld + SigningSpec) RetainedRestResult := do + let (forgery, log) ← signingTraceComputation (adversary.main publicKey) + let verified ← liftOracleWorldLeft + (scheme.verify publicKey forgery.message forgery.signature) + pure ((forgery, log), verified) + +theorem simulateQ_maskedExpanded_retainedGameRestComputation + (adversary : Adversary) (parameter : PublicParameter) (root : Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (retainedGameRestComputation adversary ⟨root, parameter⟩) = (do + let (forgery, log) ← + simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) + let verified ← simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature) + pure ((forgery, log), verified)) := by + unfold retainedGameRestComputation + rw [simulateQ_bind] + apply bind_congr + intro result + rcases result with ⟨forgery, log⟩ + rw [simulateQ_bind] + change (do + let verified ← simulateQ + (probingRomImpl parameter + maskedSigningImpl parameter root ftsSecret) + (liftOracleWorldLeft + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)) + pure ((forgery, log), verified)) = _ + rw [simulateQ_liftOracleWorldLeft] + +noncomputable def maskedRetainedGameAfterFtsSecrets (adversary : Adversary) + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) RetainedGameResult := do + let root ← maskedTreeRoot topLayer rootTree + publishCoordinate (.position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0)) + let (forgery, log) ← + simulateQ (maskedExpandedAdversaryImpl parameter root ftsSecret) + (signingTraceComputation (adversary.main ⟨root, parameter⟩)) + let verified ← simulateQ (verifierRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature) + pure (root, ((forgery, log), verified)) + +noncomputable def maskedGameAfterFtsSecrets (adversary : Adversary) + (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + StateT SplitHashCache + (OracleComp (LazyRevealProbe.World Coordinate)) Bool := do + let root ← maskedTreeRoot topLayer rootTree + publishCoordinate (.position (.node topLayer rootTree + ⟨layerHeight topLayer - 1, by norm_num [layerHeight, topLayer, maxLayerHeight]⟩ 0)) + let (forgery, log) ← + (simulateQ (QueryImpl.withTraceAppend + (maskedExpandedAdversaryImpl parameter root ftsSecret) signingLogFragment) + (adversary.main ⟨root, parameter⟩)).run + let verified ← simulateQ (verifierRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature) + pure (decide (SigningTranscript.Valid log ∧ + ¬SigningTranscript.Contains log forgery) && verified) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartAdaptiveRate.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartAdaptiveRate.lean new file mode 100644 index 00000000..b3800c04 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartAdaptiveRate.lean @@ -0,0 +1,146 @@ +import SphincsSecurity.Proof.OtsProbeStartHistoryRate +import SphincsSecurity.Proof.OtsProbeHistoryLiveRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 1000 + +theorem expected_completeHistoryResolvedPrefix_unresolvedStart_le_rate + (entry : HistoryResolvedPrefix α) (candidate : DeferredContext → α → Option Probe) + (budget : Nat) (hlength : entry.history.length ≤ budget) (hspace : budget < Fintype.card Digest) : + (∑' result, Pr[= result | completeHistoryResolvedPrefix (some entry)] * historyUnresolvedStartAllowance candidate result) ≤ + (∑' result, Pr[= result | completeHistoryResolvedPrefix (some entry)] * historyUnresolvedStartCharge candidate result) * + privateHistoryGuessRate budget := by + unfold historyUnresolvedStartAllowance historyUnresolvedStartCharge + rw [expected_completeHistoryResolvedPrefix_function entry (fun table context value => + unresolvedStartCandidateAllowance table context (candidate context value)), + expected_completeHistoryResolvedPrefix_view_cost entry (fun context value => + unresolvedStartCandidateCharge context (candidate context value))] + cases hcandidate : candidate entry.context entry.value with + | none => simp [unresolvedStartCandidateAllowance, unresolvedStartCandidateCharge] + | some probe => + rcases probe with ⟨coordinate, digest⟩ + cases coordinate with + | position position => simp [unresolvedStartCandidateAllowance, unresolvedStartCandidateCharge] + | chainStart lay tree leafIdx chainIdx => + by_cases hmissing : entry.context.state.values (.chainStart lay tree leafIdx chainIdx) = none + · simp only [unresolvedStartCandidateAllowance, unresolvedStartCandidateCharge, if_pos hmissing] + have hlocal := expected_history_guarded_chainStart_allowance_le_rate entry.context entry.history budget hlength hspace + ⟨lay, tree, leafIdx, chainIdx⟩ digest hmissing + simpa only [OtsSecretIndex.coordinate, ite_not, mul_assoc, mul_comm, mul_left_comm] using hlocal + · simp [unresolvedStartCandidateAllowance, unresolvedStartCandidateCharge, hmissing] + +theorem expected_live_historyCompletion_unresolvedStart_le_rate + (entry : HistoryResolvedPrefix α) (candidate : DeferredContext → α → Option Probe) + (hconsistent : entry.context.ValuesConsistent) (hcovered : PendingCoveredBy entry.history entry.context) + (budget : Nat) (hlength : entry.history.length ≤ budget) (hspace : budget < Fintype.card Digest) : + (∑' result, Pr[= result | completeHistoryResolvedPrefix (some entry)] * historyUnresolvedStartAllowance candidate (retainCompletableResult result)) ≤ + (∑' result, Pr[= result | completeHistoryResolvedPrefix (some entry)] * historyUnresolvedStartCharge candidate (retainCompletableResult result)) * + privateHistoryGuessRate budget := by + have hcard := (hcovered.card_le.trans hlength).trans_lt hspace + rw [expected_live_historyCompletion_eq_context_guard entry (historyUnresolvedStartAllowance candidate) rfl hconsistent hcovered hcard, + expected_live_historyCompletion_eq_context_guard entry (historyUnresolvedStartCharge candidate) rfl hconsistent hcovered hcard] + split_ifs + · exact expected_completeHistoryResolvedPrefix_unresolvedStart_le_rate entry candidate budget hlength hspace + · simp + +theorem expected_live_historyAdaptive_unresolvedStart_le_rate + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound budget : Nat) (history : List Probe) + (candidate : DeferredContext → α → Option Probe) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ budget) (hspace : budget < Fintype.card Digest) : + (∑' result, Pr[= result | runResolvedHistoryAdaptive computation context fuel history] * historyUnresolvedStartAllowance candidate (retainCompletableResult result)) ≤ + (∑' result, Pr[= result | runResolvedHistoryAdaptive computation context fuel history] * historyUnresolvedStartCharge candidate (retainCompletableResult result)) * + privateHistoryGuessRate budget := by + simp only [runResolvedHistoryAdaptive_eq_prefix_complete, tsum_probOutput_bind_mul] + rw [← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro option + by_cases hsupport : option ∈ support (runResolvedHistoryPrefix computation context fuel history) + · cases option with + | none => simp [completeHistoryResolvedPrefix, retainCompletableResult, historyUnresolvedStartAllowance, historyUnresolvedStartCharge] + | some entry => + have hinvariant := historyPrefix_invariant_of_mem computation context fuel bound history entry hcovered hbound hsupport + have hvalues := valuesConsistent_of_mem_historyPrefix computation context fuel history entry hconsistent hsupport + have hlocal := expected_live_historyCompletion_unresolvedStart_le_rate entry candidate hvalues hinvariant.1 budget (hinvariant.2.trans hbudget) hspace + simpa only [mul_assoc] using mul_le_mul' le_rfl hlocal + · simp [probOutput_eq_zero_of_not_mem_support hsupport] + +theorem evalDist_live_sampledHistoryFilteredRun_eq_adaptive_rate + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound budget : Nat) (history : List Probe) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ budget) (hspace : budget < Fintype.card Digest) : + evalDist (sampledHistoryFilteredRun computation context fuel history >>= fun result => pure (retainCompletableResult result)) = + evalDist (runResolvedHistoryAdaptive computation context fuel history >>= fun result => pure (retainCompletableResult result)) := by + have heq := evalDist_history_filtered_runResolved_eq_adaptive_observe computation context fuel bound history + (fun result => pure (retainCompletableResult result)) (by + intro result _hvalues _hstarts hdoomed + simp only [retainCompletableResult, if_neg hdoomed]) hconsistent hcovered (((Nat.add_le_add_right hcovered.card_le bound).trans hbudget).trans_lt hspace) hbound + simpa only [sampledHistoryFilteredRun] using heq + +theorem expected_live_sampledHistoryFilteredRun_eq_adaptive_rate + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound budget : Nat) (history : List Probe) + (cost : Option (ResolvedRunResult α) → ℝ≥0∞) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ budget) (hspace : budget < Fintype.card Digest) : + (∑' result, Pr[= result | sampledHistoryFilteredRun computation context fuel history] * cost (retainCompletableResult result)) = + ∑' result, Pr[= result | runResolvedHistoryAdaptive computation context fuel history] * cost (retainCompletableResult result) := by + have hdist := evalDist_live_sampledHistoryFilteredRun_eq_adaptive_rate computation context fuel bound budget history + hconsistent hcovered hbound hbudget hspace + calc + _ = ∑' result, Pr[= result | sampledHistoryFilteredRun computation context fuel history >>= + fun result => pure (retainCompletableResult result)] * cost result := by + simp only [tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + _ = ∑' result, Pr[= result | runResolvedHistoryAdaptive computation context fuel history >>= + fun result => pure (retainCompletableResult result)] * cost result := by + apply tsum_congr + intro result + simp only [probOutput_def, hdist] + _ = _ := by simp only [tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + +theorem expected_live_sampledHistoryFilteredRun_unresolvedStart_le_rate + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound budget : Nat) (history : List Probe) + (candidate : DeferredContext → α → Option Probe) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ budget) (hspace : budget < Fintype.card Digest) : + (∑' result, Pr[= result | sampledHistoryFilteredRun computation context fuel history] * + historyUnresolvedStartAllowance candidate (retainCompletableResult result)) ≤ + (∑' result, Pr[= result | sampledHistoryFilteredRun computation context fuel history] * + historyUnresolvedStartCharge candidate (retainCompletableResult result)) * + privateHistoryGuessRate budget := by + rw [expected_live_sampledHistoryFilteredRun_eq_adaptive_rate computation context fuel bound budget history + (historyUnresolvedStartAllowance candidate) hconsistent hcovered hbound hbudget hspace, + expected_live_sampledHistoryFilteredRun_eq_adaptive_rate computation context fuel bound budget history + (historyUnresolvedStartCharge candidate) hconsistent hcovered hbound hbudget hspace] + exact expected_live_historyAdaptive_unresolvedStart_le_rate computation context fuel bound budget history candidate + hconsistent hcovered hbound hbudget hspace + +theorem probEvent_live_unresolvedStart_hit_le_native_charge_rate + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel bound budget : Nat) (history : List Probe) + (candidate : DeferredContext → α → Option Probe) + (hconsistent : context.ValuesConsistent) (hcovered : PendingCoveredBy history context) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe bound) + (hbudget : history.length + bound ≤ budget) (hspace : budget < Fintype.card Digest) : + Pr[LiveUnresolvedStartHit candidate | sampledHistoryFilteredRun computation context fuel history] ≤ + (∑' result, Pr[= result | sampledHistoryFilteredRun computation context fuel history] * + historyUnresolvedStartCharge candidate (retainCompletableResult result)) * + privateHistoryGuessRate budget := by + rw [probEvent_liveUnresolvedStartHit_eq_expected] + exact expected_live_sampledHistoryFilteredRun_unresolvedStart_le_rate computation context fuel bound budget history candidate + hconsistent hcovered hbound hbudget hspace + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartAllowance.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartAllowance.lean new file mode 100644 index 00000000..e622271a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartAllowance.lean @@ -0,0 +1,99 @@ +import SphincsSecurity.Proof.OtsProbeNativeMissingStructuralCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def startProbeInputAllowance (table : OtsSecretIndex → HashOutput) (context : DeferredContext) : + LazyRevealProbe.Query Coordinate → ENNReal + | .probe coordinate digest => unresolvedStartCandidateAllowance table context (some ⟨coordinate, digest⟩) + | _ => 0 + +theorem startProbeInputAllowance_of_not_probe (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (input : LazyRevealProbe.Query Coordinate) (hprobe : ¬LazyRevealProbe.IsProbe input) : + startProbeInputAllowance table context input = 0 := by + cases input <;> simp_all [startProbeInputAllowance, LazyRevealProbe.IsProbe] + +noncomputable def liveStartProbeAllowance (computation : OracleComp (LazyRevealProbe.World Coordinate) α) : + DeferredContext → Nat → (OtsSecretIndex → HashOutput) → ENNReal := + OracleComp.construct (fun _ _ _ _ => 0) + (fun input _ next context fuel table => + if DeferredCompletable table context then + startProbeInputAllowance table context input + + ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => next result.value result.context result.remaining result.table + else 0) computation + +theorem liveStartProbeAllowance_query_bind + (input : LazyRevealProbe.Query Coordinate) + (next : (LazyRevealProbe.World Coordinate).Range input → OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + liveStartProbeAllowance ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= next) context fuel table = + (if DeferredCompletable table context then + startProbeInputAllowance table context input + + ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => liveStartProbeAllowance (next result.value) result.context result.remaining result.table + else 0) := rfl + +noncomputable def expectedLiveStartCutAllowance + (computation : OracleComp (LazyRevealProbe.World Coordinate) (PrivateValueCut α)) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : ENNReal := + ∑' result, Pr[= result | runResolvedFromTable context fuel table computation] * + historyUnresolvedStartAllowance nativeCutCandidate (retainCompletableResult result) + +theorem expectedLiveStartCutAllowance_eq_hitProbability + (computation : OracleComp (LazyRevealProbe.World Coordinate) (PrivateValueCut α)) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedLiveStartCutAllowance computation context fuel table = + Pr[LiveUnresolvedStartHit nativeCutCandidate | runResolvedFromTable context fuel table computation] := + (probEvent_liveUnresolvedStartHit_eq_expected _ _).symm + +theorem expectedLiveStartCutAllowance_pure + (value : PrivateValueCut α) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedLiveStartCutAllowance (pure value) context fuel table = + if DeferredCompletable table context then unresolvedStartCandidateAllowance table context (nativeCutCandidate context value) else 0 := by + by_cases hcomplete : DeferredCompletable table context <;> + simp [expectedLiveStartCutAllowance, runResolvedFromTable, historyUnresolvedStartAllowance, retainCompletableResult, hcomplete] + +theorem expectedLiveStartCutAllowance_bind + (computation : OracleComp (LazyRevealProbe.World Coordinate) β) + (next : β → OracleComp (LazyRevealProbe.World Coordinate) (PrivateValueCut α)) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + expectedLiveStartCutAllowance (computation >>= next) context fuel table = + ∑' result, Pr[= result | runResolvedFromTable context fuel table computation] * + match result with + | none => 0 + | some result => expectedLiveStartCutAllowance (next result.value) result.context result.remaining result.table := by + unfold expectedLiveStartCutAllowance + rw [runResolvedFromTable_bind, tsum_probOutput_bind_mul] + apply tsum_congr + intro result + cases result with + | none => simp [historyUnresolvedStartAllowance, retainCompletableResult] + | some result => rfl + +theorem expectedLiveStartCutAllowance_eq_zero_of_not_completable + (computation : OracleComp (LazyRevealProbe.World Coordinate) (PrivateValueCut α)) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hdoomed : ¬DeferredCompletable table context) : + expectedLiveStartCutAllowance computation context fuel table = 0 := by + apply ENNReal.tsum_eq_zero.mpr + intro result + by_cases hresult : result ∈ support (runResolvedFromTable context fuel table computation) + · cases result with + | none => simp [historyUnresolvedStartAllowance, retainCompletableResult] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable computation context fuel table result hconsistent hstarts hresult + have hstill := not_deferredCompletable_of_mem_runResolvedFromTable computation context fuel table result hconsistent hstarts hresult hdoomed + simp [historyUnresolvedStartAllowance, retainCompletableResult, hcore.1, hstill] + · simp [probOutput_eq_zero_of_not_mem_support hresult] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartAllowanceComposition.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartAllowanceComposition.lean new file mode 100644 index 00000000..428a5e25 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartAllowanceComposition.lean @@ -0,0 +1,64 @@ +import SphincsSecurity.Proof.OtsProbeStartAllowanceCounting + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem liveStartProbeAllowance_eq_zero_of_not_completable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hcomplete : ¬DeferredCompletable table context) : + liveStartProbeAllowance computation context fuel table = 0 := by + induction computation using OracleComp.inductionOn with + | pure value => rfl + | query_bind input next _ => rw [liveStartProbeAllowance_query_bind, if_neg hcomplete] + +noncomputable def startContinuationAllowance + (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) : Option (ResolvedRunResult α) → ENNReal + | none => 0 + | some result => liveStartProbeAllowance (next result.value) result.context result.remaining result.table + +theorem liveStartProbeAllowance_bind + (left : OracleComp (LazyRevealProbe.World Coordinate) α) (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + liveStartProbeAllowance (left >>= next) context fuel table = + liveStartProbeAllowance left context fuel table + + ∑' result, Pr[= result | runResolvedFromTable context fuel table left] * startContinuationAllowance next result := by + induction left using OracleComp.inductionOn generalizing context fuel table with + | pure value => simp [liveStartProbeAllowance, runResolvedFromTable, startContinuationAllowance] + | query_bind input continuation ih => + by_cases hcomplete : DeferredCompletable table context + · rw [bind_assoc, liveStartProbeAllowance_query_bind, liveStartProbeAllowance_query_bind, + if_pos hcomplete, if_pos hcomplete, runResolvedFromTable_bind, tsum_probOutput_bind_mul, add_assoc, ← ENNReal.tsum_add] + congr 1 + apply tsum_congr + intro result + by_cases hresult : result ∈ support (runResolvedFromTable context fuel table (liftM (OracleSpec.query input))) + · cases result with + | none => simp [startContinuationAllowance] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable (liftM (OracleSpec.query input)) context fuel table result hconsistent hstarts hresult + dsimp only + rw [ih result.value result.context result.remaining result.table hcore.2.1 (hcore.1 ▸ hcore.2.2), mul_add, ← ENNReal.tsum_mul_left] + · simp [probOutput_eq_zero_of_not_mem_support hresult] + · rw [liveStartProbeAllowance_eq_zero_of_not_completable _ context fuel table hcomplete, + liveStartProbeAllowance_eq_zero_of_not_completable _ context fuel table hcomplete, zero_add] + symm + apply ENNReal.tsum_eq_zero.mpr + intro result + by_cases hresult : result ∈ support (runResolvedFromTable context fuel table + ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= continuation)) + · cases result with + | none => simp [startContinuationAllowance] + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable _ context fuel table result hconsistent hstarts hresult + have hdoomed := not_deferredCompletable_of_mem_runResolvedFromTable _ context fuel table result hconsistent hstarts hresult hcomplete + simp only [startContinuationAllowance, hcore.1, + liveStartProbeAllowance_eq_zero_of_not_completable _ _ _ _ hdoomed, mul_zero] + · simp [probOutput_eq_zero_of_not_mem_support hresult] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartAllowanceCounting.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartAllowanceCounting.lean new file mode 100644 index 00000000..3471e656 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartAllowanceCounting.lean @@ -0,0 +1,99 @@ +import SphincsSecurity.Proof.OtsProbeStartAllowance + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem sum_expectedLiveStartProbeCutAllowance_eq + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (q : Nat) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe q) : + (∑ ordinal ∈ Finset.range q, expectedLiveStartCutAllowance (nativeProbeCutAt computation ordinal) context fuel table) = + liveStartProbeAllowance computation context fuel table := by + induction computation using OracleComp.inductionOn generalizing q context fuel table with + | pure value => + simp [nativeProbeCutAt, expectedLiveStartCutAllowance_pure, nativeCutCandidate, unresolvedStartCandidateAllowance, liveStartProbeAllowance] + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [liveStartProbeAllowance_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete] + have htail (n : Nat) (hnext : ∀ reply, (next reply).IsQueryBoundP LazyRevealProbe.IsProbe n) : + (∑ ordinal ∈ Finset.range n, expectedLiveStartCutAllowance + ((liftM (OracleSpec.query input) : OracleComp (LazyRevealProbe.World Coordinate) _) >>= + fun output => nativeProbeCutAt (next output) ordinal) context fuel table) = + ∑' result, Pr[= result | runResolvedFromTable context fuel table (liftM (OracleSpec.query input))] * + match result with + | none => 0 + | some result => liveStartProbeAllowance (next result.value) result.context result.remaining result.table := by + simp only [expectedLiveStartCutAllowance_bind] + rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + apply tsum_congr + intro result + by_cases hresult : result ∈ support (runResolvedFromTable context fuel table (liftM (OracleSpec.query input))) + · cases result with + | none => simp + | some result => + have hcore := resolvedCore_of_mem_runResolvedFromTable (liftM (OracleSpec.query input)) context fuel table result hconsistent hstarts hresult + simp only [← Finset.mul_sum] + rw [ih result.value n result.context result.remaining result.table hcore.2.1 (hcore.1 ▸ hcore.2.2) (hnext result.value)] + · simp [probOutput_eq_zero_of_not_mem_support hresult] + by_cases hprobe : LazyRevealProbe.IsProbe input + · cases q with + | zero => simp [hprobe] at hbound + | succ q => + rw [Finset.sum_range_succ'] + simp only [nativeProbeCutAt_query_bind, if_pos hprobe, expectedLiveStartCutAllowance_pure, if_pos hcomplete] + have hweight : unresolvedStartCandidateAllowance table context (nativeCutCandidate context (.query input next)) = + startProbeInputAllowance table context input := by + cases input <;> simp [nativeCutCandidate, startProbeInputAllowance, unresolvedStartCandidateAllowance] + rw [hweight] + exact (congrArg (fun value => value + startProbeInputAllowance table context input) + (htail q (fun reply => by simpa only [if_pos hprobe, Nat.add_sub_cancel] using hbound.2 reply))).trans (add_comm _ _) + · simp only [nativeProbeCutAt_query_bind, if_neg hprobe, + startProbeInputAllowance_of_not_probe table context input hprobe, zero_add] + exact htail q (fun reply => by simpa only [if_neg hprobe] using hbound.2 reply) + · rw [if_neg hcomplete] + simp only [expectedLiveStartCutAllowance_eq_zero_of_not_completable _ context fuel table hconsistent hstarts hcomplete, + Finset.sum_const_zero] + +theorem sum_nativeProbeCut_startHits_eq_liveAllowance + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (q : Nat) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe q) : + (∑ ordinal ∈ Finset.range q, Pr[LiveUnresolvedStartHit nativeCutCandidate | + runResolvedFromTable context fuel table (nativeProbeCutAt computation ordinal)]) = + liveStartProbeAllowance computation context fuel table := by + simp_rw [← expectedLiveStartCutAllowance_eq_hitProbability] + exact sum_expectedLiveStartProbeCutAllowance_eq computation q context fuel table hconsistent hstarts hbound + +theorem sum_sampledEnsuredNativeProbeCut_startHits_eq_liveAllowance + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel q : Nat) + (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe q) : + (∑ ordinal ∈ Finset.range q, + Pr[LiveUnresolvedStartHit nativeCutCandidate | sampledEnsuredNativeProbeCut targets computation fuel ordinal]) = + ∑' table, Pr[= table | sampleOtsHashTable] * liveStartProbeAllowance computation (ensuredInitialContext targets) fuel table := by + simp only [sampledEnsuredNativeProbeCut, probEvent_bind_eq_tsum] + rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + simp only [← Finset.mul_sum] + apply tsum_congr + intro table + rw [sum_nativeProbeCut_startHits_eq_liveAllowance computation q (ensuredInitialContext targets) fuel table + (ensuredInitialContext_valid targets).valuesConsistent + (startTableAgrees_of_deferredCompletable (ensuredInitialContext_completable targets table)) hbound] + +theorem sampledEnsuredLiveStartAllowance_le_chainStartCharge + (targets : Finset Position) (computation : OracleComp (LazyRevealProbe.World Coordinate) α) (fuel q : Nat) + (hq : q ≤ 2 ^ 126) (hbound : computation.IsQueryBoundP LazyRevealProbe.IsProbe q) : + (∑' table, Pr[= table | sampleOtsHashTable] * liveStartProbeAllowance computation (ensuredInitialContext targets) fuel table) ≤ + (∑' table, Pr[= table | sampleOtsHashTable] * expectedLiveResolvedQueryCharge chainStartProbeQueryCharge computation + (ensuredInitialContext targets) fuel table) * ((4 / 3 : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + rw [← sum_sampledEnsuredNativeProbeCut_startHits_eq_liveAllowance targets computation fuel q hbound] + exact sum_sampledEnsuredNativeProbeCut_unresolvedStart_le_expectedChainStartCharge targets computation fuel q hq + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartAllowanceHash.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartAllowanceHash.lean new file mode 100644 index 00000000..7fa7a1a1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartAllowanceHash.lean @@ -0,0 +1,104 @@ +import SphincsSecurity.Proof.OtsProbeStartAllowanceComposition + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +theorem liveStartProbeAllowance_eq_zero_of_probeFree + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hfree : computation.IsQueryBoundP LazyRevealProbe.IsProbe 0) : + liveStartProbeAllowance computation context fuel table = 0 := by + induction computation using OracleComp.inductionOn generalizing context fuel table with + | pure value => rfl + | query_bind input next ih => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hfree + have hinput : ¬LazyRevealProbe.IsProbe input := by simpa using hfree.1 + have hnext : ∀ reply, (next reply).IsQueryBoundP LazyRevealProbe.IsProbe 0 := by + intro reply + simpa using hfree.2 reply + have hweight : startProbeInputAllowance table context input = 0 := by + cases input <;> simp_all [LazyRevealProbe.IsProbe, startProbeInputAllowance] + rw [liveStartProbeAllowance_query_bind] + by_cases hcomplete : DeferredCompletable table context + · rw [if_pos hcomplete, hweight, zero_add] + apply ENNReal.tsum_eq_zero.mpr + intro result + cases result with + | none => simp + | some result => + dsimp only + rw [ih result.value result.context result.remaining result.table (hnext result.value), mul_zero] + · rw [if_neg hcomplete] + +theorem liveStartProbeAllowance_bind_of_tail_probeFree + (left : OracleComp (LazyRevealProbe.World Coordinate) α) + (next : α → OracleComp (LazyRevealProbe.World Coordinate) β) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hfree : ∀ value, (next value).IsQueryBoundP LazyRevealProbe.IsProbe 0) : + liveStartProbeAllowance (left >>= next) context fuel table = + liveStartProbeAllowance left context fuel table := by + rw [liveStartProbeAllowance_bind left next context fuel table hconsistent hstarts] + suffices hzero : (∑' result, Pr[= result | runResolvedFromTable context fuel table left] * + startContinuationAllowance next result) = 0 by rw [hzero, add_zero] + apply ENNReal.tsum_eq_zero.mpr + intro result + cases result with + | none => simp [startContinuationAllowance] + | some result => + rw [startContinuationAllowance, liveStartProbeAllowance_eq_zero_of_probeFree + (next result.value) result.context result.remaining result.table (hfree result.value), mul_zero] + +theorem startAllowance_executeCandidate + (candidate : Option Probe) (cache : SplitHashCache) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) : + liveStartProbeAllowance ((executeCandidate? candidate).run cache) context fuel table = + if DeferredCompletable table context then unresolvedStartCandidateAllowance table context candidate else 0 := by + cases candidate with + | none => simp [executeCandidate?, liveStartProbeAllowance, unresolvedStartCandidateAllowance] + | some candidate => + simp [executeCandidate?, probe, LazyRevealProbe.probeQuery, liveStartProbeAllowance, + unresolvedStartCandidateAllowance, startProbeInputAllowance, map_eq_bind_pure_comp] + split_ifs + · calc + _ = startProbeInputAllowance table context (.probe candidate.coordinate candidate.candidate) + 0 := by + congr 1 + apply ENNReal.tsum_eq_zero.mpr + intro result + cases result <;> simp + _ = _ := add_zero _ + · rfl + +theorem startAllowance_probingHashQueryAfterPlan + (parameter : PublicParameter) (input : HashInput) (plan : PlannedHashQuery) + (cache : SplitHashCache) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + liveStartProbeAllowance ((probingHashQueryAfterPlan parameter input plan).run cache) context fuel table = + if DeferredCompletable table context then unresolvedStartCandidateAllowance table context plan.candidate? else 0 := by + unfold probingHashQueryAfterPlan executePlannedHashQuery + rw [StateT.run_bind, liveStartProbeAllowance_bind_of_tail_probeFree _ _ context fuel table hconsistent hstarts] + · exact startAllowance_executeCandidate plan.candidate? cache context fuel table + · intro result + cases plan.action with + | ordinary => exact splitHashQuery_probeFree _ result.2 + | resolve coordinate => exact resolveKnownInput_probeFree parameter coordinate input result.2 + +theorem startAllowance_probingHashQuery + (parameter : PublicParameter) (input : HashInput) + (cache : SplitHashCache) (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + liveStartProbeAllowance ((probingHashQuery parameter input).run cache) context fuel table = + if DeferredCompletable table context then unresolvedStartCandidateAllowance table context + (purePlanProbingHashQuery parameter input context.state).candidate? else 0 := by + rw [probingHashQuery_eq_plan_then_afterPlan, StateT.run_bind, + liveStartProbeAllowance_bind _ _ context fuel table hconsistent hstarts, + liveStartProbeAllowance_eq_zero_of_probeFree _ context fuel table (planProbingHashQuery_probeFree parameter input cache), + zero_add, runResolved_planProbingHashQuery parameter input context.state context fuel table cache rfl, + tsum_probOutput_pure_mul] + exact startAllowance_probingHashQueryAfterPlan parameter input _ cache context fuel table hconsistent hstarts + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartCandidateMiss.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartCandidateMiss.lean new file mode 100644 index 00000000..e64ce6e5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartCandidateMiss.lean @@ -0,0 +1,101 @@ +import SphincsSecurity.Proof.OtsProbeStartHistoryRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option backward.isDefEq.respectTransparency false + +theorem afterCandidateContext_valuesConsistent (context : DeferredContext) (candidate : Option Probe) + (hconsistent : context.ValuesConsistent) : (afterCandidateContext context candidate).ValuesConsistent := by + cases candidate with + | none => exact hconsistent + | some candidate => + unfold afterCandidateContext + dsimp only + split_ifs + · exact hconsistent + · exact hconsistent.addPending candidate.coordinate candidate.candidate + +theorem afterCandidateContext_startTableAgrees (table : OtsSecretIndex → HashOutput) + (context : DeferredContext) (candidate : Option Probe) (hstarts : StartTableAgrees context.state table) : + StartTableAgrees (afterCandidateContext context candidate).state table := by + cases candidate with + | none => exact hstarts + | some candidate => + unfold afterCandidateContext + dsimp only + split_ifs + · exact hstarts + · exact hstarts.addPending candidate.coordinate candidate.candidate + +theorem deferredCompletable_afterCandidate_of_mem_probingHashQuery + (parameter : PublicParameter) (input : HashInput) (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (result : ResolvedRunResult (HashOutput × SplitHashCache)) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support (runResolvedFromTable context (fuel + 1) table + ((probingHashQuery parameter input).run cache))) + (hcomplete : DeferredCompletable table result.context) : + DeferredCompletable table + (afterCandidateContext context (purePlanProbingHashQuery parameter input context.state).candidate?) := by + rw [runResolved_probingHashQuery_eq_afterPlan] at hresult + unfold probingHashQueryAfterPlan executePlannedHashQuery at hresult + rw [StateT.run_bind, runResolvedFromTable_bind, runResolvedFromTable_executeCandidate_positive, pure_bind] at hresult + exact deferredCompletable_of_mem_runResolvedFromTable _ _ _ table result + (afterCandidateContext_valuesConsistent context _ hconsistent) + (afterCandidateContext_startTableAgrees table context _ hstarts) hresult hcomplete + +theorem deferredCompletable_afterCandidate_of_mem_canonicalHashQuery + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (input : HashInput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult (HashOutput × SplitHashCache)) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support (canonicalChronologicalAdversaryImpl parameter root table ftsSecret + (.inl (.inr input)) context (fuel + 1) table cache)) + (hcomplete : DeferredCompletable result.table result.context) : + DeferredCompletable table + (afterCandidateContext context (purePlanProbingHashQuery parameter input context.state).candidate?) := by + rw [canonicalChronologicalAdversaryImpl_eq_raw_then_canonicalize, mem_support_bind_iff] at hresult + obtain ⟨rawOption, hraw, hcanonical⟩ := hresult + cases rawOption with + | none => simp [canonicalizeResolvedRun] at hcanonical + | some raw => + simp only [canonicalizeResolvedRun, mem_support_pure_iff, Option.some.injEq] at hcanonical + subst result + change some raw ∈ support (runResolvedFromTable context (fuel + 1) table + ((probingHashQuery parameter input).run cache)) at hraw + have hcore := resolvedCore_of_mem_runResolvedFromTable ((probingHashQuery parameter input).run cache) + context (fuel + 1) table raw hconsistent hstarts hraw + change DeferredCompletable raw.table (canonicalizeMaterializedValues table raw.context) at hcomplete + rw [hcore.1] at hcomplete + obtain ⟨completion, hcompletion⟩ := hcomplete + exact deferredCompletable_afterCandidate_of_mem_probingHashQuery parameter input context fuel table cache raw + hconsistent hstarts hraw ⟨completion, hcompletion.of_canonicalizeMaterializedValues hcore.2.1 hcore.2.2⟩ + +theorem canonicalHashQuery_complete_candidate_misses_chainStart + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (input : HashInput) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult (HashOutput × SplitHashCache)) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hresult : some result ∈ support (canonicalChronologicalAdversaryImpl parameter root table ftsSecret + (.inl (.inr input)) context (fuel + 1) table cache)) + (hcomplete : DeferredCompletable result.table result.context) + (index : OtsSecretIndex) (digest : Digest) + (hcandidate : (purePlanProbingHashQuery parameter input context.state).candidate? = some ⟨index.coordinate, digest⟩) + (hhidden : index.coordinate ∉ context.state.revealed) : truncateHash (table index) ≠ digest := by + have hafter := deferredCompletable_afterCandidate_of_mem_canonicalHashQuery parameter root table ftsSecret input + context fuel cache result hconsistent hstarts hresult hcomplete + rw [hcandidate, afterCandidateContext, if_neg hhidden] at hafter + intro hhit + apply hafter.not_pendingResolvedHit + refine ⟨index.coordinate, table index, ?_, ?_⟩ + · cases index + rfl + · unfold LazyRevealProbe.State.hitAt + rw [LazyRevealProbe.State.mem_pendingAt_iff] + simp [LazyRevealProbe.State.addPending, hhit] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartErasureBound.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartErasureBound.lean new file mode 100644 index 00000000..c6dd188f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartErasureBound.lean @@ -0,0 +1,114 @@ +import SphincsSecurity.Proof.OtsProbeStartErasureTrace + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 4000 + +noncomputable def canonicalStartErasureAfterRoot + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) : + ProbComp (Option (ResolvedRunResult (α × SplitHashCache)) × Bool) := do + let root ← runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache) + match root with + | none => pure (none, false) + | some root => + runCanonicalStartErasureTrace parameter root.value.1 table ftsSecret (continuation root.value.1) + root.context root.remaining root.value.2 false + +noncomputable def concreteAfterRootComputation + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) : OracleComp OracleWorld α := do + let root ← liftM (treeRoot parameter topLayer rootTree + (fun leafIdx chainIdx => truncateHash (table ⟨topLayer, rootTree, leafIdx, chainIdx⟩)) : OracleComp HashSpec Digest) + simulateQ (expandedAdversaryImpl + ⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩) + (continuation root) + +theorem simulateQ_unloggedMapped_eq_expanded (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + simulateQ (unloggedMappedAdversaryImpl secretKey) computation = + simulateQ romImpl (simulateQ (expandedAdversaryImpl secretKey) computation) := by + have hhandler : unloggedMappedAdversaryImpl secretKey = romImpl ∘ₛ expandedAdversaryImpl secretKey := by + funext input + exact unloggedMappedAdversaryImpl_eq_simulateQ_expanded secretKey input + rw [hhandler, QueryImpl.simulateQ_compose] + +theorem relTriple_canonicalStartErasureAfterRoot + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) : + RelTriple (canonicalStartErasureAfterRoot parameter table ftsSecret fuel continuation) + ((simulateQ romImpl (concreteAfterRootComputation parameter table ftsSecret continuation)).run ∅) + (StartErasureTraceRel parameter table) := by + have hroot := reachableResolvedCouples_maskedPublishedTreeRoot parameter table + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel emptySplitHashCache ∅ (resolvedContextInvariant_empty parameter table) + (visibleResolvedComputationsCached_empty parameter table emptyDeferredStructuralValues ∅) publishedValues_empty + have hsupported := FtsProbeSimulation.relTriple_and_left_support hroot + (fun left => ∀ result, left = some result → CanonicalMaterializedValues table result.context) (by + intro left hleft result heq + subst left + exact canonicalMaterializedValues_of_mem_maskedPublishedTreeRoot parameter table fuel result hleft) + rw [canonicalStartErasureAfterRoot, concreteAfterRootComputation, simulateQ_bind, StateT.run_bind, + simulateQ_romImpl_liftM] + apply relTriple_bind hsupported + intro left right hrel + rw [← simulateQ_unloggedMapped_eq_expanded] + cases left with + | none => + exact relTriple_stoppedStartErasureTrace parameter right.1 table ftsSecret (continuation right.1) right.2 false (by simp) + | some result => + have hcanonical := hrel.2 result rfl + rcases hrel.1 with hclean | hdoomed + · rcases right with ⟨root, actualCache⟩ + have hvalue : result.value.1 = root := hclean.2.1 + subst root + exact relTriple_runCanonicalStartErasureTrace parameter result.value.1 table ftsSecret (continuation result.value.1) + result.context result.remaining result.value.2 actualCache false hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 + hcanonical (by simp) + · dsimp only + rw [runCanonicalStartErasureTrace_of_not_completable parameter result.value.1 table ftsSecret + (continuation result.value.1) result.context result.remaining result.value.2 false hdoomed.2.2.2] + exact relTriple_stoppedStartErasureTrace parameter right.1 table ftsSecret (continuation right.1) right.2 false (by simp) + +theorem probEvent_canonicalStartErasureAfterRoot_le_inv216 + (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (continuation : Digest → OracleComp (OracleWorld + SigningSpec) α) : + Pr[fun result => result.2 = true | canonicalStartErasureAfterRoot parameter table ftsSecret fuel continuation] ≤ + ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + apply (probEvent_le_of_relTriple (relTriple_canonicalStartErasureAfterRoot parameter table ftsSecret fuel continuation) + (p := fun result => result.2 = true) (q := fun result => AnyEncodingInputsExhausted result.2) ?_).trans + (probEvent_anyEncodingInputsExhausted_le_inv216 (concreteAfterRootComputation parameter table ftsSecret continuation)) + intro left right hrel hflag + exact hrel.2.2 hflag + +noncomputable def sampledCanonicalStartErasureTrace (adversary : Adversary) (fuel : Nat) : + ProbComp (Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)) × Bool) := do + let parameter ← sampleParameter + let table ← sampleOtsHashTable + let ftsSecret ← sampleFtsSecrets + canonicalStartErasureAfterRoot parameter table ftsSecret fuel fun root => + (fun rest => (root, rest)) <$> retainedGameRestComputation adversary ⟨root, parameter⟩ + +theorem probEvent_sampledCanonicalStartErasureTrace_le_inv216 (adversary : Adversary) (fuel : Nat) : + Pr[fun result => result.2 = true | sampledCanonicalStartErasureTrace adversary fuel] ≤ + ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + unfold sampledCanonicalStartErasureTrace + apply probEvent_bind_le_of_forall_le + intro parameter _ + apply probEvent_bind_le_of_forall_le + intro table _ + apply probEvent_bind_le_of_forall_le + intro ftsSecret _ + exact probEvent_canonicalStartErasureAfterRoot_le_inv216 parameter table ftsSecret fuel _ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartErasureTrace.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartErasureTrace.lean new file mode 100644 index 00000000..d0a2084f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartErasureTrace.lean @@ -0,0 +1,262 @@ +import SphincsSecurity.Proof.OtsProbeSigningFailureCoupling +import SphincsSecurity.Proof.OtsProbeCanonicalVerifierTrace + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec OracleComp.ProgramLogic.Relational + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def canonicalStartErasureStep + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (query : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + ProbComp (Option (ResolvedRunResult ((OracleWorld + SigningSpec).Range query × SplitHashCache)) × Bool) := do + let result ← runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret query).run cache) + pure (canonicalizeResolvedRun table result, decide (LiveSigningStartErasure table result)) + +def StartErasureTraceRel (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (left : Option (ResolvedRunResult (α × SplitHashCache)) × Bool) (right : α × QueryCache HashSpec) : Prop := + ReachableResolvedRunRel parameter table left.1 right ∧ CanonicalResolvedRun table left.1 ∧ + (left.2 = true → AnyEncodingInputsExhausted right.2) + +theorem relTriple_rawQuery_startFailure + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (query : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) (hcanonical : CanonicalMaterializedValues table context) : + RelTriple + (runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret query).run cache)) + ((unloggedMappedAdversaryImpl + ⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + query).run concreteCache) + (SigningStartFailureRunRel parameter table) := by + cases query with + | inr message => + exact relTriple_sign_startFailure_concrete parameter root table ftsSecret message context fuel cache concreteCache + hinvariant hvisible hpublished (materializedStartsPublished_of_canonical table context hcanonical) + | inl query => + have hbase := reachableResolvedCouples_probingRomImpl parameter table query context fuel cache concreteCache + hinvariant hvisible hpublished + have hsupported := FtsProbeSimulation.relTriple_and_left_support hbase + (fun left => left ∈ support (runResolvedFromTable context fuel table ((probingRomImpl parameter query).run cache))) + (fun _ h => h) + apply relTriple_post_mono hsupported + intro left right hrel + refine ⟨hrel.1, ?_⟩ + intro result heq _ + subst left + exact Or.inl (materializedStartsPublished_of_canonical table result.context + (canonicalMaterializedValues_of_mem_probingRomImpl parameter query context fuel table cache result + hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hcanonical hpublished hrel.2)) + +theorem relTriple_canonicalStartErasureStep + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (query : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) (hcanonical : CanonicalMaterializedValues table context) : + RelTriple (canonicalStartErasureStep parameter root table ftsSecret query context fuel cache) + ((unloggedMappedAdversaryImpl + ⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + query).run concreteCache) + (StartErasureTraceRel parameter table) := by + have hbase := relTriple_rawQuery_startFailure parameter root table ftsSecret query context fuel cache concreteCache + hinvariant hvisible hpublished hcanonical + have hsupported := FtsProbeSimulation.relTriple_and_left_support hbase + (fun left => left ∈ support (runResolvedFromTable context fuel table + ((maskedChronologicalExpandedAdversaryImpl parameter root ftsSecret query).run cache))) (fun _ h => h) + unfold canonicalStartErasureStep + rw [show (unloggedMappedAdversaryImpl + ⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + query).run concreteCache = (unloggedMappedAdversaryImpl + ⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩ + query).run concreteCache >>= fun result => pure result by simp] + apply relTriple_bind hsupported + intro left right hrel + apply relTriple_pure_pure + refine ⟨hrel.1.1.canonicalizeResolvedRun, ?_, ?_⟩ + · apply canonicalResolvedRun_canonicalize table left + intro result heq + subst left + exact (resolvedCore_of_mem_runResolvedFromTable _ context fuel table result + hinvariant.2.1.valuesConsistent hinvariant.2.2.1 hrel.2).2.1 + · intro hflag + exact anyEncodingInputsExhausted_of_cachedOtsEncodingFailure right.2 + (hrel.1.encoding_failure_of_erasure (of_decide_eq_true hflag)) + +noncomputable def runCanonicalStartErasureTrace + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) : + DeferredContext → Nat → SplitHashCache → Bool → + ProbComp (Option (ResolvedRunResult (α × SplitHashCache)) × Bool) := + OracleComp.construct + (fun value context fuel cache flagged => + if DeferredCompletable table context then pure (some ⟨context, fuel, (value, cache), table⟩, flagged) + else pure (none, flagged)) + (fun query _next recur context fuel cache flagged => + if DeferredCompletable table context then do + let step ← canonicalStartErasureStep parameter root table ftsSecret query context fuel cache + let flagged := flagged || step.2 + match step.1 with + | none => pure (none, flagged) + | some result => recur result.value.1 result.context result.remaining result.value.2 flagged + else pure (none, flagged)) computation + +theorem runCanonicalStartErasureTrace_of_not_completable + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (flagged : Bool) + (hnot : ¬DeferredCompletable table context) : + runCanonicalStartErasureTrace parameter root table ftsSecret computation context fuel cache flagged = + pure (none, flagged) := by + induction computation using OracleComp.inductionOn with + | pure value => simp only [runCanonicalStartErasureTrace, OracleComp.construct_pure, if_neg hnot] + | query_bind query next ih => + simp only [runCanonicalStartErasureTrace, OracleComp.construct_query_bind, if_neg hnot] + +theorem relTriple_stoppedStartErasureTrace + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) (cache : QueryCache HashSpec) (flagged : Bool) + (hflag : flagged = true → AnyEncodingInputsExhausted cache) : + RelTriple (pure (none, flagged) : ProbComp (Option (ResolvedRunResult (α × SplitHashCache)) × Bool)) + ((simulateQ (unloggedMappedAdversaryImpl + ⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩) + computation).run cache) (StartErasureTraceRel parameter table) := by + have hbase := relTriple_true (pure (none, flagged) : ProbComp (Option (ResolvedRunResult (α × SplitHashCache)) × Bool)) + ((simulateQ (unloggedMappedAdversaryImpl + ⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩) + computation).run cache) + have hleft := FtsProbeSimulation.relTriple_and_left_support hbase + (fun left => left = (none, flagged)) (by intro left h; simpa using h) + apply relTriple_post_mono (FtsProbeSimulation.relTriple_and_right_support hleft) + intro left right hrel + rw [hrel.1.2] + refine ⟨True.intro, True.intro, ?_⟩ + intro htrue + exact (hflag htrue).mono (FtsProbeSimulation.simulateQ_unloggedMappedAdversaryImpl_cache_le _ computation + cache right.2 right.1 hrel.2) + +theorem relTriple_runCanonicalStartErasureTrace + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) (flagged : Bool) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) (hcanonical : CanonicalMaterializedValues table context) + (hflag : flagged = true → AnyEncodingInputsExhausted concreteCache) : + RelTriple (runCanonicalStartErasureTrace parameter root table ftsSecret computation context fuel cache flagged) + ((simulateQ (unloggedMappedAdversaryImpl + ⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩) + computation).run concreteCache) (StartErasureTraceRel parameter table) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache concreteCache flagged with + | pure value => + simp only [runCanonicalStartErasureTrace, OracleComp.construct_pure, if_pos hinvariant.2.2.2.1, + simulateQ_pure, StateT.run_pure] + exact relTriple_pure_pure ⟨Or.inl ⟨rfl, rfl, hinvariant, hvisible, hpublished⟩, hcanonical, hflag⟩ + | query_bind query next ih => + rw [runCanonicalStartErasureTrace, OracleComp.construct_query_bind, simulateQ_query_bind, StateT.run_bind] + simp only [if_pos hinvariant.2.2.2.1] + have hstep := relTriple_canonicalStartErasureStep parameter root table ftsSecret query context fuel cache concreteCache + hinvariant hvisible hpublished hcanonical + apply relTriple_bind (FtsProbeSimulation.relTriple_and_right_support hstep) + rintro ⟨stepOption, stepFlag⟩ right hrel + have hnextFlag : (flagged || stepFlag) = true → AnyEncodingInputsExhausted right.2 := by + intro htrue + rcases Bool.or_eq_true_iff.mp htrue with hprevious | hnew + · exact (hflag hprevious).mono (unloggedMappedAdversaryImpl_cache_le _ query concreteCache right hrel.2) + · exact hrel.1.2.2 hnew + cases stepOption with + | none => + exact relTriple_stoppedStartErasureTrace parameter root table ftsSecret (next right.1) right.2 + (flagged || stepFlag) hnextFlag + | some result => + have hnextCanonical : CanonicalMaterializedValues table result.context := hrel.1.2.1 + rcases hrel.1.1 with hclean | hdoomed + · rcases right with ⟨rightValue, rightCache⟩ + have hvalue : result.value.1 = rightValue := hclean.2.1 + subst rightValue + exact ih result.value.1 result.context result.remaining result.value.2 rightCache (flagged || stepFlag) + hclean.2.2.1 hclean.2.2.2.1 hclean.2.2.2.2 hnextCanonical hnextFlag + · change RelTriple + (runCanonicalStartErasureTrace parameter root table ftsSecret (next result.value.1) + result.context result.remaining result.value.2 (flagged || stepFlag)) _ _ + rw [runCanonicalStartErasureTrace_of_not_completable parameter root table ftsSecret (next result.value.1) + result.context result.remaining result.value.2 (flagged || stepFlag) hdoomed.2.2.2] + exact relTriple_stoppedStartErasureTrace parameter root table ftsSecret (next right.1) right.2 + (flagged || stepFlag) hnextFlag + +theorem probEvent_canonicalStartErasureTrace_le_exhaustion + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (concreteCache : QueryCache HashSpec) + (hinvariant : ResolvedContextInvariant parameter table context (ordinaryQueryCache cache) concreteCache) + (hvisible : VisibleResolvedComputationsCached parameter table context concreteCache) + (hpublished : PublishedValues context.state) (hcanonical : CanonicalMaterializedValues table context) : + Pr[fun result => result.2 = true | + runCanonicalStartErasureTrace parameter root table ftsSecret computation context fuel cache false] ≤ + Pr[fun result => AnyEncodingInputsExhausted result.2 | + (simulateQ (unloggedMappedAdversaryImpl + ⟨parameter, root, fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩), ftsSecret⟩) + computation).run concreteCache] := by + apply probEvent_le_of_relTriple (relTriple_runCanonicalStartErasureTrace parameter root table ftsSecret computation + context fuel cache concreteCache false hinvariant hvisible hpublished hcanonical (by simp)) + intro left right hrel hflag + exact hrel.2.2 hflag + +theorem canonicalStartErasureStep_projection + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (query : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) : + Prod.fst <$> canonicalStartErasureStep parameter root table ftsSecret query context fuel cache = + canonicalChronologicalAdversaryImpl parameter root table ftsSecret query context fuel table cache := by + rw [canonicalChronologicalAdversaryImpl_eq_raw_then_canonicalize] + simp only [canonicalStartErasureStep, map_bind, map_pure] + +theorem runCanonicalStartErasureTrace_projection + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (flagged : Bool) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) : + evalDist (Prod.fst <$> runCanonicalStartErasureTrace parameter root table ftsSecret computation context fuel cache flagged) = + evalDist (runSynchronizedResolved (canonicalChronologicalAdversaryImpl parameter root table ftsSecret) + computation context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache flagged with + | pure value => + simp only [runCanonicalStartErasureTrace, runSynchronizedResolved, OracleComp.construct_pure] + split_ifs <;> simp + | query_bind query next ih => + rw [runCanonicalStartErasureTrace, OracleComp.construct_query_bind, runSynchronizedResolved, + OracleComp.construct_query_bind] + by_cases hcomplete : DeferredCompletable table context + · simp only [if_pos hcomplete, dif_pos hcomplete, map_bind] + rw [← canonicalStartErasureStep_projection, bind_map_left] + apply evalDist_bind_congr + rintro ⟨stepOption, stepFlag⟩ hstep + have hproject : stepOption ∈ support + (canonicalChronologicalAdversaryImpl parameter root table ftsSecret query context fuel table cache) := by + rw [← canonicalStartErasureStep_projection, support_map] + exact ⟨(stepOption, stepFlag), hstep, rfl⟩ + cases stepOption with + | none => simp + | some result => + have hcore := resolvedCore_of_mem_canonicalChronologicalAdversaryImpl parameter root table ftsSecret query + context fuel cache result hconsistent hstarts hproject + dsimp only + rw [hcore.1] + exact ih result.value.1 result.context result.remaining result.value.2 (flagged || stepFlag) hcore.2.1 hcore.2.2 + · simp [hcomplete] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartHistoryRate.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartHistoryRate.lean new file mode 100644 index 00000000..62206da4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartHistoryRate.lean @@ -0,0 +1,64 @@ +import SphincsSecurity.Proof.OtsProbeStartHistoryRisk +import SphincsSecurity.Proof.OtsProbePrivateHistoryRate + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable +set_option backward.isDefEq.respectTransparency false + +theorem privateHistoryGuessRate_mul_survival (budget : Nat) (hbudget : budget < Fintype.card Digest) : + privateHistoryGuessRate budget * (1 - (budget : ENNReal) * (Fintype.card Digest : ENNReal)⁻¹) = + (Fintype.card Digest : ENNReal)⁻¹ := by + have hnonzero : ((Fintype.card Digest - budget : Nat) : ENNReal) ≠ 0 := by + exact_mod_cast Nat.sub_ne_zero_of_lt hbudget + have hspace : (Fintype.card Digest : ENNReal) ≠ 0 := by + exact_mod_cast (show Fintype.card Digest ≠ 0 from Fintype.card_ne_zero) + have hsurvival : 1 - (budget : ENNReal) * (Fintype.card Digest : ENNReal)⁻¹ = + ((Fintype.card Digest - budget : Nat) : ENNReal) * (Fintype.card Digest : ENNReal)⁻¹ := by + rw [ENNReal.natCast_sub, ENNReal.sub_mul (fun _ _ => ENNReal.inv_ne_top.mpr hspace), + ENNReal.mul_inv_cancel hspace (by simp)] + rw [hsurvival, privateHistoryGuessRate, ← mul_assoc, ENNReal.inv_mul_cancel hnonzero (by simp), one_mul] + +theorem probEvent_no_chainStartHistoryHit_ge_survival + (context : DeferredContext) (history : List Probe) (budget : Nat) (hlength : history.length ≤ budget) : + 1 - (budget : ENNReal) * (Fintype.card Digest : ENNReal)⁻¹ ≤ + Pr[fun base => ¬ChainStartHistoryHit context history base | sampleOtsHashTable] := by + have hbad : Pr[fun base => ¬¬ChainStartHistoryHit context history base | sampleOtsHashTable] ≤ + (budget : ENNReal) * (Fintype.card Digest : ENNReal)⁻¹ := by + simp only [not_not] + apply (probEvent_chainStartHistoryHit_le context history).trans + simpa only [show Fintype.card Digest = 2 ^ digestBits by simp] using + mul_le_mul' (Nat.cast_le.mpr hlength) (le_refl (Fintype.card Digest : ENNReal)⁻¹) + exact probEvent_one_sub_le_of_compl_le (by simp : Pr[⊥ | sampleOtsHashTable] = 0) hbad + +theorem expected_history_guarded_chainStart_allowance_le_rate + (context : DeferredContext) (history : List Probe) (budget : Nat) + (hlength : history.length ≤ budget) (hbudget : budget < Fintype.card Digest) + (index : OtsSecretIndex) (digest : Digest) (hmissing : context.state.values index.coordinate = none) : + (∑' base, Pr[= base | sampleOtsHashTable] * + if ¬ChainStartHistoryHit context history base then + candidateFailureAllowance (completedStartTable context.state base) context (some ⟨index.coordinate, digest⟩) + else 0) ≤ + (unmaterializedCandidateCharge (materializedDeferredState context) (some ⟨index.coordinate, digest⟩) : ENNReal) * + privateHistoryGuessRate budget * + Pr[fun base => ¬ChainStartHistoryHit context history base | sampleOtsHashTable] := by + let charge : ENNReal := unmaterializedCandidateCharge (materializedDeferredState context) (some ⟨index.coordinate, digest⟩) + calc + _ ≤ ∑' base, Pr[= base | sampleOtsHashTable] * + candidateFailureAllowance (completedStartTable context.state base) context (some ⟨index.coordinate, digest⟩) := by + apply ENNReal.tsum_le_tsum + intro base + apply mul_le_mul' le_rfl + split_ifs <;> first | exact le_rfl | exact bot_le + _ ≤ charge * (Fintype.card Digest : ENNReal)⁻¹ := by + simpa only [show Fintype.card Digest = 2 ^ digestBits by simp] using + expected_candidateFailureAllowance_chainStart_of_missing context index digest hmissing + _ = charge * privateHistoryGuessRate budget * + (1 - (budget : ENNReal) * (Fintype.card Digest : ENNReal)⁻¹) := by + rw [mul_assoc, privateHistoryGuessRate_mul_survival budget hbudget] + _ ≤ _ := mul_le_mul' le_rfl (probEvent_no_chainStartHistoryHit_ge_survival context history budget hlength) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartHistoryRisk.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartHistoryRisk.lean new file mode 100644 index 00000000..faaa0f2f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartHistoryRisk.lean @@ -0,0 +1,123 @@ +import SphincsSecurity.Proof.OtsProbeStartTableInvariance + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 100000 + +def ChainStartHistoryHit (context : DeferredContext) (history : List Probe) + (base : OtsSecretIndex → HashOutput) : Prop := + ∃ candidate ∈ history, context.state.values candidate.coordinate = none ∧ + ChainStartEntryHit base (candidate.coordinate, candidate.candidate) + +theorem probEvent_chainStartHistoryHit_le (context : DeferredContext) (history : List Probe) : + Pr[ChainStartHistoryHit context history | sampleOtsHashTable] ≤ + (history.length : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + classical + calc + _ = Pr[fun base => ∃ candidate ∈ history.toFinset, + context.state.values candidate.coordinate = none ∧ + ChainStartEntryHit base (candidate.coordinate, candidate.candidate) | sampleOtsHashTable] := by + unfold ChainStartHistoryHit + simp only [List.mem_toFinset] + _ ≤ ∑ candidate ∈ history.toFinset, Pr[fun base => + context.state.values candidate.coordinate = none ∧ + ChainStartEntryHit base (candidate.coordinate, candidate.candidate) | sampleOtsHashTable] := + probEvent_exists_finset_le_sum history.toFinset sampleOtsHashTable _ + _ ≤ ∑ _candidate ∈ history.toFinset, ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply Finset.sum_le_sum + intro candidate _hcandidate + apply le_trans (probEvent_mono (fun _ _ hhit => hhit.2)) + rcases candidate with ⟨coordinate, digest⟩ + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + exact probEvent_sampleOtsHashTable_cell_truncate_eq ⟨lay, tree, leafIdx, chainIdx⟩ digest + | position position => simp [ChainStartEntryHit] + _ = (history.toFinset.card : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [Finset.sum_const, nsmul_eq_mul] + _ ≤ _ := mul_le_mul_left (Nat.cast_le.mpr (List.toFinset_card_le history)) _ + +theorem probEvent_no_chainStartHistoryHit_ge_three_quarters + (context : DeferredContext) (history : List Probe) (hlength : history.length ≤ 2 ^ 126) : + (3 / 4 : ℝ≥0∞) ≤ Pr[fun base => ¬ChainStartHistoryHit context history base | sampleOtsHashTable] := by + have hquarter : Pr[ChainStartHistoryHit context history | sampleOtsHashTable] ≤ (1 / 4 : ℝ≥0∞) := by + apply (probEvent_chainStartHistoryHit_le context history).trans + calc + _ ≤ ((2 ^ 126 : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + mul_le_mul_left (Nat.cast_le.mpr hlength) _ + _ = _ := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + norm_num [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_div, digestBits] + have hdouble : Pr[fun base => ¬¬ChainStartHistoryHit context history base | sampleOtsHashTable] ≤ + (1 / 4 : ℝ≥0∞) := by simpa only [not_not] using hquarter + have hgood := probEvent_one_sub_le_of_compl_le (by simp : Pr[⊥ | sampleOtsHashTable] = 0) hdouble + have hsum : (1 : ℝ≥0∞) ≤ + Pr[fun base => ¬ChainStartHistoryHit context history base | sampleOtsHashTable] + 1 / 4 := + tsub_le_iff_right.mp hgood + have hreal := (ENNReal.toReal_le_toReal (by finiteness) + (ENNReal.add_ne_top.mpr ⟨probEvent_ne_top, by finiteness⟩)).mpr hsum + apply (ENNReal.toReal_le_toReal (by finiteness) probEvent_ne_top).mp + rw [ENNReal.toReal_add probEvent_ne_top (by finiteness)] at hreal + norm_num [ENNReal.toReal_div] at hreal ⊢ + linarith + +theorem no_missingChainStartHit_of_history_clean + (context : DeferredContext) (history : List Probe) (base : OtsSecretIndex → HashOutput) + (hcovered : PendingCoveredBy history context) (hclean : ¬ChainStartHistoryHit context history base) : + ¬MissingChainStartHit (completedStartTable context.state base) context := by + rintro ⟨index, hmissing, hhit⟩ + have hlookup : completedStartTable context.state base index = base index := by + simp [completedStartTable, hmissing] + have hpending : (index.coordinate, truncateHash (base index)) ∈ context.state.pending := by + rw [← LazyRevealProbe.State.mem_pendingAt_iff] + simpa only [hlookup, LazyRevealProbe.State.hitAt] using hhit + obtain ⟨candidate, hcandidate, hcoordinate, hdigest⟩ := hcovered _ hpending + apply hclean + refine ⟨candidate, hcandidate, by rwa [hcoordinate], ?_⟩ + rw [hcoordinate, hdigest] + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + rfl + +theorem evalDist_resolveDeferredReveal_eq_of_history_clean + (left right : OtsSecretIndex → HashOutput) (position : Position) + (context : DeferredContext) (history : List Probe) (hcovered : PendingCoveredBy history context) + (hleft : ¬ChainStartHistoryHit context history left) (hright : ¬ChainStartHistoryHit context history right) : + evalDist (resolveDeferredReveal (completedStartTable context.state left) position context) = + evalDist (resolveDeferredReveal (completedStartTable context.state right) position context) := + evalDist_resolveDeferredReveal_eq_of_no_missingChainStartHit _ _ position context + (no_missingChainStartHit_of_history_clean context history left hcovered hleft) + (no_missingChainStartHit_of_history_clean context history right hcovered hright) + +theorem expected_history_guarded_chainStart_allowance_le_four_thirds + (context : DeferredContext) (history : List Probe) (hlength : history.length ≤ 2 ^ 126) + (index : OtsSecretIndex) (digest : Digest) (hmissing : context.state.values index.coordinate = none) : + (∑' base, Pr[= base | sampleOtsHashTable] * + if ¬ChainStartHistoryHit context history base then + candidateFailureAllowance (completedStartTable context.state base) context (some ⟨index.coordinate, digest⟩) + else 0) ≤ + ((unmaterializedCandidateCharge (materializedDeferredState context) (some ⟨index.coordinate, digest⟩) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) * (4 / 3) * + Pr[fun base => ¬ChainStartHistoryHit context history base | sampleOtsHashTable] := by + let charge : ℝ≥0∞ := + (unmaterializedCandidateCharge (materializedDeferredState context) (some ⟨index.coordinate, digest⟩) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + calc + _ ≤ ∑' base, Pr[= base | sampleOtsHashTable] * + candidateFailureAllowance (completedStartTable context.state base) context (some ⟨index.coordinate, digest⟩) := by + apply ENNReal.tsum_le_tsum + intro base + apply mul_le_mul_right + split_ifs <;> first | exact le_rfl | exact bot_le + _ ≤ charge := expected_candidateFailureAllowance_chainStart_of_missing context index digest hmissing + _ = charge * (4 / 3) * (3 / 4) := by + have hfactor : (4 / 3 : ℝ≥0∞) * (3 / 4) = 1 := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + norm_num [ENNReal.toReal_mul, ENNReal.toReal_div] + rw [mul_assoc, hfactor, mul_one] + _ ≤ _ := mul_le_mul_right (probEvent_no_chainStartHistoryHit_ge_three_quarters context history hlength) _ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartHistorySampling.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartHistorySampling.lean new file mode 100644 index 00000000..dc088e67 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartHistorySampling.lean @@ -0,0 +1,103 @@ +import SphincsSecurity.Proof.OtsProbeStartHistoryTrace + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] sampleOtsHashTable +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 100000 + +def ChainStartHistoryOutputHit (history : List Probe) (index : OtsSecretIndex) (output : HashOutput) : Prop := + ∃ candidate ∈ history, candidate.coordinate = index.coordinate ∧ truncateHash output = candidate.candidate + +theorem chainStartEntryHit_update_iff + (base : OtsSecretIndex → HashOutput) (index : OtsSecretIndex) (output : HashOutput) + (coordinate : Coordinate) (digest : Digest) : + ChainStartEntryHit (Function.update base index output) (coordinate, digest) ↔ + (coordinate = index.coordinate ∧ truncateHash output = digest) ∨ + (coordinate ≠ index.coordinate ∧ ChainStartEntryHit base (coordinate, digest)) := by + classical + cases coordinate with + | position position => simp [ChainStartEntryHit, OtsSecretIndex.coordinate] + | chainStart lay tree leafIdx chainIdx => + by_cases heq : (⟨lay, tree, leafIdx, chainIdx⟩ : OtsSecretIndex) = index + · have hcoordinate : Coordinate.chainStart lay tree leafIdx chainIdx = index.coordinate := + congrArg OtsSecretIndex.coordinate heq + simp [ChainStartEntryHit, heq, hcoordinate] + · have hcoordinate : Coordinate.chainStart lay tree leafIdx chainIdx ≠ index.coordinate := + fun h => heq (OtsSecretIndex.coordinate_injective h) + simp [ChainStartEntryHit, heq, hcoordinate] + +theorem chainStartHistoryHit_update_iff + (context : DeferredContext) (history : List Probe) (base : OtsSecretIndex → HashOutput) + (index : OtsSecretIndex) (output : HashOutput) (hmissing : context.state.values index.coordinate = none) : + ChainStartHistoryHit context history (Function.update base index output) ↔ + ChainStartHistoryOutputHit history index output ∨ + ChainStartHistoryHit { context with state := context.state.materialize index.coordinate output } history base := by + classical + constructor + · rintro ⟨candidate, hcandidate, hvalue, hhit⟩ + rcases (chainStartEntryHit_update_iff base index output candidate.coordinate candidate.candidate).mp hhit with hsame | hother + · exact Or.inl ⟨candidate, hcandidate, hsame⟩ + · refine Or.inr ⟨candidate, hcandidate, ?_, hother.2⟩ + simpa only [LazyRevealProbe.State.materialize, Function.update_of_ne hother.1] using hvalue + · rintro (hhit | hhit) + · obtain ⟨candidate, hcandidate, hcoordinate, hdigest⟩ := hhit + refine ⟨candidate, hcandidate, by rwa [hcoordinate], ?_⟩ + exact (chainStartEntryHit_update_iff base index output candidate.coordinate candidate.candidate).mpr + (Or.inl ⟨hcoordinate, hdigest⟩) + · obtain ⟨candidate, hcandidate, hvalue, hhit⟩ := hhit + have hother : candidate.coordinate ≠ index.coordinate := by + intro heq + simp [LazyRevealProbe.State.materialize, heq] at hvalue + refine ⟨candidate, hcandidate, ?_, ?_⟩ + · simpa only [LazyRevealProbe.State.materialize, Function.update_of_ne hother] using hvalue + · exact (chainStartEntryHit_update_iff base index output candidate.coordinate candidate.candidate).mpr + (Or.inr ⟨hother, hhit⟩) + +theorem evalDist_history_filtered_completionTable_read + (context : DeferredContext) (history : List Probe) (index : OtsSecretIndex) + (hmissing : context.state.values index.coordinate = none) + (failure : ProbComp α) (next : (OtsSecretIndex → HashOutput) → HashOutput → ProbComp α) : + evalDist (do + let base ← sampleOtsHashTable + if ChainStartHistoryHit context history base then failure + else next (completedStartTable context.state base) (base index)) = + evalDist (do + let output ← LazyRevealProbe.sampleHashOutput + if ChainStartHistoryOutputHit history index output then failure + else do + let base ← sampleOtsHashTable + let after := { context with state := context.state.materialize index.coordinate output } + if ChainStartHistoryHit after history base then failure + else next (completedStartTable after.state base) output) := by + let cont : (OtsSecretIndex → HashOutput) → HashOutput → ProbComp α := fun base output => + if ChainStartHistoryHit context history base then failure else next (completedStartTable context.state base) output + have hcell := evalDist_completionTable_bind_cell_extract index cont + have hcell' : evalDist (do + let base ← sampleOtsHashTable + cont base (base index)) = evalDist (do + let output ← LazyRevealProbe.sampleHashOutput + let base ← sampleOtsHashTable + cont (Function.update base index output) output) := by + simpa only [sampleOtsHashTable, LazyRevealProbe.sampleHashOutput] using hcell + change evalDist (do let base ← sampleOtsHashTable; cont base (base index)) = _ + rw [hcell'] + apply evalDist_bind_congr + intro output _houtput + by_cases hhit : ChainStartHistoryOutputHit history index output + · simp only [cont, chainStartHistoryHit_update_iff context history _ index output hmissing, hhit, true_or, ↓reduceIte] + exact evalDist_sampleOtsHashTable_bind_const failure + · simp only [if_neg hhit] + apply evalDist_bind_congr + intro base _hbase + have htable : completedStartTable context.state (Function.update base index output) = + completedStartTable (context.state.materialize index.coordinate output) base := by + rw [completedStartTable_update_base_of_missing context.state base index output hmissing, + completedStartTable_materialize_coordinate] + simp only [cont, chainStartHistoryHit_update_iff context history base index output hmissing, + hhit, false_or, htable] + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartHistorySupport.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartHistorySupport.lean new file mode 100644 index 00000000..acf59733 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartHistorySupport.lean @@ -0,0 +1,124 @@ +import SphincsSecurity.Proof.OtsProbeStartCandidateMiss + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +set_option maxRecDepth 100000 in +theorem revealed_subset_of_mem_runResolvedFromTable + (computation : OracleComp (LazyRevealProbe.World Coordinate) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) + (result : ResolvedRunResult α) + (hresult : some result ∈ support (runResolvedFromTable context fuel table computation)) : + context.state.revealed ⊆ result.context.state.revealed := by + induction computation using OracleComp.inductionOn generalizing context fuel with + | pure value => + simp [runResolvedFromTable] at hresult + subst result + exact Finset.Subset.rfl + | query_bind input next ih => + cases input with + | uniform n => + rw [runResolvedFromTable_uniform_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel htail + | hashOutput => + rw [runResolvedFromTable_hashOutput_query_bind, mem_support_bind_iff] at hresult + obtain ⟨output, _houtput, htail⟩ := hresult + exact ih output context fuel htail + | ensure coordinate => + rw [runResolvedFromTable_ensure_query_bind] at hresult + exact ih () { context with state := context.state.ensure coordinate } fuel hresult + | probe coordinate digest => + cases fuel with + | zero => simp [runResolvedFromTable_probe_query_bind] at hresult + | succ remaining => + rw [runResolvedFromTable_probe_query_bind] at hresult + by_cases hrevealed : coordinate ∈ context.state.revealed + · exact ih () context remaining (by simpa only [hrevealed, ↓reduceIte] using hresult) + · exact ih () { context with state := context.state.addPending coordinate digest } remaining + (by simpa only [hrevealed, ↓reduceIte] using hresult) + | peek coordinate => + rw [runResolvedFromTable_peek_query_bind] at hresult + exact ih (context.state.values coordinate) context fuel hresult + | publish coordinate => + rw [runResolvedFromTable_publish_query_bind] at hresult + exact (Finset.subset_insert coordinate context.state.revealed).trans + (ih () { context with state := context.state.publish coordinate } fuel hresult) + | reveal coordinate => + rw [runResolvedFromTable_reveal_query_bind] at hresult + cases coordinate <;> rw [mem_support_bind_iff] at hresult + all_goals + obtain ⟨option, _hresolve, htail⟩ := hresult + cases option with + | none => simp at htail + | some resolved => + have hmono := ih resolved.output _ fuel htail + exact hmono + +theorem revealed_subset_of_mem_canonicalChronologicalQuery + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (result : ResolvedRunResult ((OracleWorld + SigningSpec).Range input × SplitHashCache)) + (hresult : some result ∈ support (canonicalChronologicalAdversaryImpl parameter root table ftsSecret + input context fuel table cache)) : context.state.revealed ⊆ result.context.state.revealed := by + rw [canonicalChronologicalAdversaryImpl_eq_raw_then_canonicalize, mem_support_bind_iff] at hresult + obtain ⟨rawOption, hraw, hcanonical⟩ := hresult + cases rawOption with + | none => simp [canonicalizeResolvedRun] at hcanonical + | some raw => + simp only [canonicalizeResolvedRun, mem_support_pure_iff, Option.some.injEq] at hcanonical + subst result + exact revealed_subset_of_mem_runResolvedFromTable _ context fuel table raw hraw + +def UnrevealedChainStartHistoryMisses (table : OtsSecretIndex → HashOutput) + (state : LazyRevealProbe.State Coordinate) (history : List Probe) : Prop := + ∀ candidate ∈ history, candidate.coordinate ∉ state.revealed → + ¬ChainStartEntryHit table (candidate.coordinate, candidate.candidate) + +theorem UnrevealedChainStartHistoryMisses.mono_revealed + {table : OtsSecretIndex → HashOutput} {before after : LazyRevealProbe.State Coordinate} {history : List Probe} + (hmiss : UnrevealedChainStartHistoryMisses table before history) (hrevealed : before.revealed ⊆ after.revealed) : + UnrevealedChainStartHistoryMisses table after history := by + intro candidate hcandidate hhidden + exact hmiss candidate hcandidate (fun hmem => hhidden (hrevealed hmem)) + +theorem unrevealedChainStartHistoryMisses_append_canonicalQuery + (parameter : PublicParameter) (root : Digest) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (input : (OracleWorld + SigningSpec).Domain) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) (prior : List Probe) + (result : ResolvedRunResult ((OracleWorld + SigningSpec).Range input × SplitHashCache)) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hprior : UnrevealedChainStartHistoryMisses table context.state prior) + (hresult : some result ∈ support (canonicalChronologicalAdversaryImpl parameter root table ftsSecret + input context (fuel + 1) table cache)) + (hcomplete : DeferredCompletable result.table result.context) : + UnrevealedChainStartHistoryMisses table result.context.state + (prior ++ canonicalQueryCandidates parameter input context) := by + have hsubset := revealed_subset_of_mem_canonicalChronologicalQuery parameter root table ftsSecret input + context (fuel + 1) cache result hresult + intro candidate hcandidate hhidden + rcases List.mem_append.mp hcandidate with hpriorCandidate | hcurrent + · exact hprior.mono_revealed hsubset candidate hpriorCandidate hhidden + · have hhiddenBefore : candidate.coordinate ∉ context.state.revealed := fun hmem => hhidden (hsubset hmem) + cases input with + | inl query => + cases query with + | inl n => simp [canonicalQueryCandidates] at hcurrent + | inr input => + have hplan : (purePlanProbingHashQuery parameter input context.state).candidate? = some candidate := by + simpa only [canonicalQueryCandidates, Option.mem_toList] using hcurrent + rcases candidate with ⟨coordinate, digest⟩ + cases coordinate with + | position position => simp [ChainStartEntryHit] + | chainStart lay tree leafIdx chainIdx => + exact canonicalHashQuery_complete_candidate_misses_chainStart parameter root table ftsSecret input + context fuel cache result hconsistent hstarts hresult hcomplete + ⟨lay, tree, leafIdx, chainIdx⟩ digest hplan hhiddenBefore + | inr message => simp [canonicalQueryCandidates] at hcurrent + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartHistoryTrace.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartHistoryTrace.lean new file mode 100644 index 00000000..e4734477 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartHistoryTrace.lean @@ -0,0 +1,190 @@ +import SphincsSecurity.Proof.OtsProbeStartHistorySupport + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot +set_option backward.isDefEq.respectTransparency false + +set_option maxRecDepth 100000 in +theorem canonical_startHistory_of_mem_canonicalQueryTrace + (parameter : PublicParameter) (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (context : DeferredContext) (fuel : Nat) (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) (hstarts : StartTableAgrees context.state table) + (hcanonical : CanonicalMaterializedValues table context) (prior : List Probe) + (hprior : UnrevealedChainStartHistoryMisses table context.state prior) + (result : Option (ResolvedRunResult (α × SplitHashCache)) × List CanonicalQuerySelection) + (hrun : result ∈ support (runCanonicalQueryTrace parameter root ftsSecret computation context fuel table cache)) + (hpositive : ∀ entry ∈ result.2, 0 < entry.fuel) : + ∀ ordinal entry, result.2[ordinal]? = some entry → CanonicalMaterializedValues table entry.context ∧ + UnrevealedChainStartHistoryMisses table entry.context.state + (prior ++ canonicalTraceCandidates parameter (result.2.take ordinal)) := by + induction computation using OracleComp.inductionOn generalizing context fuel table cache prior result with + | pure value => + simp only [runCanonicalQueryTrace, OracleComp.construct_pure] at hrun + split_ifs at hrun <;> simp only [mem_support_pure_iff] at hrun <;> subst result <;> simp + | query_bind input next ih => + rw [runCanonicalQueryTrace_query_bind] at hrun + split_ifs at hrun with hcomplete + · rw [mem_support_bind_iff] at hrun + obtain ⟨stepOption, hstep, hrun⟩ := hrun + cases stepOption with + | none => + simp only [pure_bind, mem_support_pure_iff] at hrun + subst result + intro ordinal entry hentry + cases ordinal with + | zero => + simp only [List.getElem?_cons_zero, Option.some.injEq] at hentry + subst entry + simpa [canonicalTraceCandidates] using And.intro hcanonical hprior + | succ ordinal => simp at hentry + | some step => + rw [mem_support_bind_iff] at hrun + obtain ⟨tail, htail, hpure⟩ := hrun + simp only [mem_support_pure_iff] at hpure + subst result + intro ordinal entry hentry + cases ordinal with + | zero => + simp only [List.getElem?_cons_zero, Option.some.injEq] at hentry + subst entry + simpa [canonicalTraceCandidates] using And.intro hcanonical hprior + | succ ordinal => + simp only [List.getElem?_cons_succ] at hentry + have hstepComplete : DeferredCompletable step.table step.context := by + by_contra hnot + rw [runCanonicalQueryTrace_of_not_completable parameter root ftsSecret _ step.context + step.remaining step.table step.value.2 hnot, mem_support_pure_iff] at htail + subst tail + simp at hentry + have hfuel : 0 < fuel := hpositive ⟨input, context, fuel, table, cache⟩ (by simp) + cases fuel with + | zero => omega + | succ remaining => + have hcore := resolvedCore_of_mem_canonicalChronologicalAdversaryImpl parameter root table ftsSecret + input context (remaining + 1) cache step hconsistent hstarts hstep + have hnextCanonical := canonicalMaterializedValues_of_mem_canonicalChronologicalQuery + parameter root ftsSecret input context (remaining + 1) table cache step hconsistent hstarts hstep + have hnextPrior := unrevealedChainStartHistoryMisses_append_canonicalQuery parameter root table ftsSecret + input context remaining cache prior step hconsistent hstarts hprior hstep hstepComplete + have htailPositive : ∀ selected ∈ tail.2, 0 < selected.fuel := by + intro selected hselected + exact hpositive selected (List.mem_cons_of_mem _ hselected) + rw [hcore.1] at htail + have htailHistory := ih step.value.1 step.context step.remaining table step.value.2 + hcore.2.1 hcore.2.2 hnextCanonical (prior ++ canonicalQueryCandidates parameter input context) + hnextPrior tail htail htailPositive ordinal entry hentry + simpa [canonicalTraceCandidates, List.append_assoc] using htailHistory + · simp only [mem_support_pure_iff] at hrun + subst result + simp + +theorem canonical_startHistory_of_mem_canonicalRetainedQueryTrace + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (result : Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)) × List CanonicalQuerySelection) + (hrun : result ∈ support (canonicalRetainedQueryTrace adversary parameter table ftsSecret fuel)) + (hpositive : ∀ entry ∈ result.2, 0 < entry.fuel) : + ∀ ordinal entry, result.2[ordinal]? = some entry → CanonicalMaterializedValues table entry.context ∧ + UnrevealedChainStartHistoryMisses table entry.context.state + (canonicalTraceCandidates parameter (result.2.take ordinal)) := by + rw [canonicalRetainedQueryTrace, mem_support_bind_iff] at hrun + obtain ⟨rootOption, hroot, hrun⟩ := hrun + cases rootOption with + | none => + simp only [mem_support_pure_iff] at hrun + subst result + simp + | some root => + rw [mem_support_bind_iff] at hrun + obtain ⟨rest, hrest, hpure⟩ := hrun + simp only [mem_support_pure_iff] at hpure + subst result + have hcore := resolvedCore_of_mem_runResolvedFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table root (by intro coordinate output hvalue; simp [LazyRevealProbe.State.empty] at hvalue) + (by intro index output hvalue; simp [LazyRevealProbe.State.empty] at hvalue) hroot + have hcanonical := canonicalMaterializedValues_of_mem_maskedPublishedTreeRoot parameter table fuel root hroot + rw [hcore.1] at hrest + have hhistory := canonical_startHistory_of_mem_canonicalQueryTrace parameter root.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨root.value.1, parameter⟩) + root.context root.remaining table root.value.2 hcore.2.1 hcore.2.2 hcanonical [] + (by simp [UnrevealedChainStartHistoryMisses]) rest hrest hpositive + simpa only [List.nil_append] using hhistory + +theorem UnrevealedChainStartHistoryMisses.not_historyHit_of_canonical + {table : OtsSecretIndex → HashOutput} {context : DeferredContext} {history : List Probe} + (hmiss : UnrevealedChainStartHistoryMisses table context.state history) + (hcanonical : CanonicalMaterializedValues table context) : ¬ChainStartHistoryHit context history table := by + rintro ⟨candidate, hcandidate, hmissing, hhit⟩ + rcases candidate with ⟨coordinate, digest⟩ + cases coordinate with + | position position => simp [ChainStartEntryHit] at hhit + | chainStart lay tree leafIdx chainIdx => + apply hmiss ⟨.chainStart lay tree leafIdx chainIdx, digest⟩ hcandidate _ hhit + intro hrevealed + rw [hcanonical] at hmissing + simp [publicMaterializedValues, hrevealed, resolvedCompletionValue] at hmissing + +theorem no_chainStartHistoryHit_of_coupled_canonicalRetainedTrace + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (left : Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)) × List CanonicalQuerySelection) + (right : (RetainedGameResult × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hleft : left ∈ support (canonicalRetainedQueryTrace adversary parameter table ftsSecret (q + 1))) + (hright : right ∈ support (prehitRetainedQueryTrace adversary parameter table ftsSecret)) + (hrelation : CanonicalQueryTraceRel parameter table left right) + (ordinal : Nat) (entry : CanonicalQuerySelection) (hentry : left.2[ordinal]? = some entry) : + ¬ChainStartHistoryHit entry.context (canonicalTraceCandidates parameter (left.2.take ordinal)) table := by + have hpositive := positive_fuel_of_coupled_canonicalRetainedTrace adversary q hq parameter hparameter table ftsSecret + hfts left right hleft hright hrelation + have hhistory := canonical_startHistory_of_mem_canonicalRetainedQueryTrace adversary parameter table ftsSecret + (q + 1) left hleft hpositive ordinal entry hentry + exact hhistory.2.not_historyHit_of_canonical hhistory.1 + +theorem completedStartTable_self_of_canonical + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hcanonical : CanonicalMaterializedValues table context) : completedStartTable context.state table = table := by + funext index + unfold completedStartTable + rw [hcanonical] + rcases index with ⟨lay, tree, leafIdx, chainIdx⟩ + simp only [publicMaterializedValues, OtsSecretIndex.coordinate, resolvedCompletionValue] + split_ifs <;> rfl + +theorem evalDist_resolveDeferredReveal_eq_recompletion_of_historyMisses + (table base : OtsSecretIndex → HashOutput) (position : Position) (context : DeferredContext) + (history : List Probe) (hcovered : PendingCoveredBy history context) + (hcanonical : CanonicalMaterializedValues table context) + (hmiss : UnrevealedChainStartHistoryMisses table context.state history) + (hbase : ¬ChainStartHistoryHit context history base) : + evalDist (resolveDeferredReveal table position context) = + evalDist (resolveDeferredReveal (completedStartTable context.state base) position context) := by + have heq := evalDist_resolveDeferredReveal_eq_of_history_clean table base position context history hcovered + (hmiss.not_historyHit_of_canonical hcanonical) hbase + rwa [completedStartTable_self_of_canonical table context hcanonical] at heq + +theorem probEvent_no_chainStartHistoryHit_coupled_prefix_ge_three_quarters + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) + (left : Option (ResolvedRunResult (RetainedGameResult × SplitHashCache)) × List CanonicalQuerySelection) + (right : (RetainedGameResult × (ViewedFullTraceState × Bool)) × List PrehitQuerySnapshot) + (hright : right ∈ support (prehitRetainedQueryTrace adversary parameter table ftsSecret)) + (hrelation : CanonicalQueryTraceRel parameter table left right) + (ordinal : Nat) (context : DeferredContext) : + (3 / 4 : ℝ≥0∞) ≤ Pr[fun base => + ¬ChainStartHistoryHit context (canonicalTraceCandidates parameter (left.2.take ordinal)) base | sampleOtsHashTable] := by + apply probEvent_no_chainStartHistoryHit_ge_three_quarters + exact (canonicalTraceCandidates_length_le_hashCount parameter _).trans + ((canonicalTraceHashCount_take_le _ _).trans (hrelation.hashCount_le.trans + ((prehitRetainedTraceHashCount_le adversary q hq parameter hparameter table ftsSecret hfts right hright).trans hqMax))) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartTableInvariance.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartTableInvariance.lean new file mode 100644 index 00000000..9631b1af --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStartTableInvariance.lean @@ -0,0 +1,136 @@ +import SphincsSecurity.Proof.OtsProbeGuardedTraceRisk + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +set_option backward.isDefEq.respectTransparency false + +theorem no_missingChainStartHit_of_values_eq_pending_subset + (table : OtsSecretIndex → HashOutput) (before after : DeferredContext) + (hvalues : after.state.values = before.state.values) + (hpending : after.state.pending ⊆ before.state.pending) + (hclean : ¬MissingChainStartHit table before) : ¬MissingChainStartHit table after := by + rintro ⟨index, hmissing, hhit⟩ + apply hclean + refine ⟨index, by rwa [hvalues] at hmissing, ?_⟩ + unfold LazyRevealProbe.State.hitAt at hhit ⊢ + rw [LazyRevealProbe.State.mem_pendingAt_iff] at hhit ⊢ + exact hpending hhit + +theorem resolveDeferredChainPrefix_positive_eq_of_no_missingChainStartHit + (left right : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (steps : Nat) + (hsteps : steps + 1 ≤ chainLength - 1) (context : DeferredContext) + (hleft : ¬MissingChainStartHit left context) (hright : ¬MissingChainStartHit right context) : + resolveDeferredChainPrefix left lay tree leafIdx chainIdx (steps + 1) hsteps context = + resolveDeferredChainPrefix right lay tree leafIdx chainIdx (steps + 1) hsteps context := by + induction steps with + | zero => + cases hstate : context.state.values (.chainStart lay tree leafIdx chainIdx) with + | none => + have hl : ¬context.state.hitAt (.chainStart lay tree leafIdx chainIdx) (left ⟨lay, tree, leafIdx, chainIdx⟩) := + fun hhit => hleft ⟨⟨lay, tree, leafIdx, chainIdx⟩, hstate, hhit⟩ + have hr : ¬context.state.hitAt (.chainStart lay tree leafIdx chainIdx) (right ⟨lay, tree, leafIdx, chainIdx⟩) := + fun hhit => hright ⟨⟨lay, tree, leafIdx, chainIdx⟩, hstate, hhit⟩ + simp [resolveDeferredChainPrefix, resolveDeferredChainStart, OtsSecretIndex.coordinate, hstate, hl, hr] + | some output => + by_cases hhit : context.state.hitAt (.chainStart lay tree leafIdx chainIdx) output <;> + simp [resolveDeferredChainPrefix, resolveDeferredChainStart, OtsSecretIndex.coordinate, hstate, hhit] + | succ steps ih => + rw [resolveDeferredChainPrefix, ih (by omega)] + rfl + +theorem evalDist_resolveDeferredChains_eq_of_no_missingChainStartHit + (left right : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chains : List ChainIndex) (context : DeferredContext) + (hleft : ¬MissingChainStartHit left context) (hright : ¬MissingChainStartHit right context) : + evalDist (resolveDeferredChains left lay tree leafIdx chains context) = + evalDist (resolveDeferredChains right lay tree leafIdx chains context) := by + induction chains generalizing context with + | nil => rfl + | cons chainIdx remaining ih => + have hprefix := resolveDeferredChainPrefix_positive_eq_of_no_missingChainStartHit left right lay tree leafIdx chainIdx + (chainLength - 2) (by norm_num [chainLength, winternitzBits]) context hleft hright + have hlength : chainLength - 2 + 1 = chainLength - 1 := by norm_num [chainLength, winternitzBits] + simp only [hlength] at hprefix + rw [resolveDeferredChains, resolveDeferredChains, hprefix] + apply evalDist_bind_congr + intro option hoption + cases option with + | none => rfl + | some result => + have hvalues := resolveDeferredChainPrefix_preserves_state_values right lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context result hoption + have hpending := resolveDeferredChainPrefix_pending_subset right lay tree leafIdx chainIdx + (chainLength - 1) (by omega) context result hoption + exact ih result.toDeferredContext + (no_missingChainStartHit_of_values_eq_pending_subset left context _ hvalues hpending hleft) + (no_missingChainStartHit_of_values_eq_pending_subset right context _ hvalues hpending hright) + +theorem evalDist_resolveDeferredOtsLeaf_eq_of_no_missingChainStartHit + (left right : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (context : DeferredContext) + (hleft : ¬MissingChainStartHit left context) (hright : ¬MissingChainStartHit right context) : + evalDist (resolveDeferredOtsLeaf left lay tree leafIdx context) = + evalDist (resolveDeferredOtsLeaf right lay tree leafIdx context) := by + unfold resolveDeferredOtsLeaf + rw [evalDist_bind, evalDist_bind, + evalDist_resolveDeferredChains_eq_of_no_missingChainStartHit left right lay tree leafIdx _ context hleft hright] + +theorem evalDist_resolveDeferredTreeNode_eq_of_no_missingChainStartHit + (left right : OtsSecretIndex → HashOutput) (lay : Layer) (tree : TreeIndex) + (level nodeIdx : Nat) (hlevel : level ≤ maxLayerHeight) (context : DeferredContext) + (hleft : ¬MissingChainStartHit left context) (hright : ¬MissingChainStartHit right context) : + evalDist (resolveDeferredTreeNode left lay tree level nodeIdx hlevel context) = + evalDist (resolveDeferredTreeNode right lay tree level nodeIdx hlevel context) := by + induction level generalizing nodeIdx context with + | zero => + exact evalDist_resolveDeferredOtsLeaf_eq_of_no_missingChainStartHit left right lay tree + (leafOfNat nodeIdx) context hleft hright + | succ level ih => + simp only [resolveDeferredTreeNode] + rw [evalDist_bind, ih (2 * nodeIdx) (by omega) context hleft hright, ← evalDist_bind] + apply evalDist_bind_congr + intro option hoption + cases option with + | none => rfl + | some result => + have hvalues := resolveDeferredTreeNode_preserves_state_values right lay tree level (2 * nodeIdx) + (by omega) context result hoption + have hpending := resolveDeferredTreeNode_pending_subset right lay tree level (2 * nodeIdx) + (by omega) context result hoption + have hl := no_missingChainStartHit_of_values_eq_pending_subset left context result.toDeferredContext + hvalues hpending hleft + have hr := no_missingChainStartHit_of_values_eq_pending_subset right context result.toDeferredContext + hvalues hpending hright + dsimp only + rw [evalDist_bind, evalDist_bind, ih (2 * nodeIdx + 1) (by omega) result.toDeferredContext hl hr] + +theorem evalDist_resolveDeferredPosition_eq_of_no_missingChainStartHit + (left right : OtsSecretIndex → HashOutput) (position : Position) (context : DeferredContext) + (hleft : ¬MissingChainStartHit left context) (hright : ¬MissingChainStartHit right context) : + evalDist (resolveDeferredPosition left position context) = + evalDist (resolveDeferredPosition right position context) := by + cases position with + | chain lay tree leafIdx chainIdx step => + exact congrArg evalDist (resolveDeferredChainPrefix_positive_eq_of_no_missingChainStartHit left right + lay tree leafIdx chainIdx step.val (by have := step.isLt; omega) context hleft hright) + | leaf lay tree leafIdx => + exact evalDist_resolveDeferredOtsLeaf_eq_of_no_missingChainStartHit left right lay tree leafIdx context hleft hright + | node lay tree level nodeIdx => + exact evalDist_resolveDeferredTreeNode_eq_of_no_missingChainStartHit left right lay tree + (level.val + 1) nodeIdx (by have := level.isLt; omega) context hleft hright + | ftsLeaf | ftsNode | ftsRoots => rfl + +theorem evalDist_resolveDeferredReveal_eq_of_no_missingChainStartHit + (left right : OtsSecretIndex → HashOutput) (position : Position) (context : DeferredContext) + (hleft : ¬MissingChainStartHit left context) (hright : ¬MissingChainStartHit right context) : + evalDist (resolveDeferredReveal left position context) = + evalDist (resolveDeferredReveal right position context) := by + unfold resolveDeferredReveal + split_ifs + · exact evalDist_resolveDeferredPosition_eq_of_no_missingChainStartHit left right position context hleft hright + · rfl + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeStepCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStepCharge.lean new file mode 100644 index 00000000..398fc919 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStepCharge.lean @@ -0,0 +1,60 @@ +import SphincsSecurity.Proof.OtsOpeningQueryReserve + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +theorem Probe.MatchesInput.atOtsPosition {parameter : PublicParameter} {input : HashInput} + {candidate : Probe} (hmatch : candidate.MatchesInput parameter input) : + ∃ position : Position, IsOtsPosition position ∧ AtPosition parameter input position := by + rcases candidate with ⟨coordinate, value⟩ + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + obtain ⟨step, _, hinput⟩ := hmatch + exact ⟨.chain lay tree leafIdx chainIdx step, trivial, digestBytes value, hinput⟩ + | position position => + cases position <;> simp only [Probe.MatchesInput] at hmatch + case chain lay tree leafIdx chainIdx step => + split_ifs at hmatch with hnext + · obtain ⟨nextStep, _, hinput⟩ := hmatch + exact ⟨.chain lay tree leafIdx chainIdx nextStep, trivial, digestBytes value, hinput⟩ + · obtain ⟨_, payload, hinput, _⟩ := hmatch + exact ⟨.leaf lay tree leafIdx, trivial, payload, hinput⟩ + +theorem probingHashQuery_eq_split_of_not_atOtsPosition (parameter : PublicParameter) (input : HashInput) + (hnot : ¬ ∃ position : Position, IsOtsPosition position ∧ AtPosition parameter input position) : + probingHashQuery parameter input = splitHashQuery (.ordinary input) := by + have hprobe : decodeProbe? parameter input = none := by + apply (decodeProbe?_eq_none_iff parameter input).mpr + intro candidate hmatch + exact hnot hmatch.atOtsPosition + rw [probingHashQuery, hprobe] + cases hposition : decodePosition? parameter input with + | none => rfl + | some position => + have hat := (decodePosition?_eq_some_iff parameter input position).mp hposition + cases position with + | chain lay tree leafIdx chainIdx step => exact (hnot ⟨.chain lay tree leafIdx chainIdx step, trivial, hat⟩).elim + | leaf lay tree leafIdx => exact (hnot ⟨.leaf lay tree leafIdx, trivial, hat⟩).elim + | node lay tree level nodeIdx => exact (hnot ⟨.node lay tree level nodeIdx, trivial, hat⟩).elim + | ftsLeaf => rfl + | ftsNode => rfl + | ftsRoots => rfl + +theorem probingHashQuery_expectedCharge_le_queryReserve (secretKey : SecretKey) + (actualCache : QueryCache HashSpec) (input : HashInput) + (state : LazyRevealProbe.State Coordinate) (cache : SplitHashCache) (fuel : Nat) : + LazyRevealProbe.expectedProbeCharge ((probingHashQuery secretKey.parameter input).run cache) state fuel ≤ + otsOpeningQueryReserve secretKey actualCache input := by + classical + by_cases hots : ∃ position : Position, IsOtsPosition position ∧ AtPosition secretKey.parameter input position + · obtain ⟨position, hposition, hat⟩ := hots + have hcost := LazyRevealProbe.expectedProbeCharge_le_queryBound _ state fuel 1 + (probingHashQuery_run_isProbeBound secretKey.parameter input cache) + rw [Nat.cast_one] at hcost + exact hcost.trans (otsOpeningQueryReserve_ge_one_of_atOtsPosition secretKey actualCache input position hat hposition) + · rw [probingHashQuery_eq_split_of_not_atOtsPosition secretKey.parameter input hots] + rw [LazyRevealProbe.expectedProbeCharge_eq_zero_of_probeFree _ state fuel (splitHashQuery_probeFree _ cache)] + exact bot_le + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeStopped125.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStopped125.lean new file mode 100644 index 00000000..27a248e5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeStopped125.lean @@ -0,0 +1,442 @@ +import SphincsSecurity.Proof.OtsProbeRootRisk125 + +namespace SphincsSecurity.Concrete.OtsProbeSimulation.Range125 + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option linter.constructorNameAsVariable false + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_afterPublishedRoot_firstStopped + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) + (left right : ResolvedRunResult (Digest × SplitHashCache)) + (hleftSupport : DirectWitnessResult.done left ∈ support + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext q table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hrightSupport : some (observedResolvedResult [] right) ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hclean : OrdinaryMaterializedRunEq table left right) : + RelTriple + (canonicalizeDirectWitnessSnapshotObserve table + (retainedSnapshotObserve adversary parameter table ftsSecret) + left.context left.remaining left.value []) + (observedMaterializedBoundary parameter right.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨right.value.1, parameter⟩) + [] right.context.state right.remaining table right.value.2) + (SnapshotObservedFirstStoppedRel table) := by + have hcanonicalRun := hclean.canonicalize_left + let canonical := canonicalizeMaterializedValues table left.context + have hleftCompletable : DeferredCompletable table canonical := + hcanonicalRun.context_le.leftCompletable + have hnotPrivate : ¬PrivateStructuralHit canonical := + not_privateStructuralHit_of_deferredCompletable hleftCompletable + have hleftFuelPreserved : q ≤ left.remaining := + fuel_le_remaining_of_doneWitness_maskedPublishedTreeRoot table q left hleftSupport + have hrightFuelPreserved : 2 * q ≤ right.remaining := + fuel_le_remaining_of_mem_observed_maskedPublishedTreeRoot table (2 * q) right hrightSupport + have hleftRemainingUpper : left.remaining ≤ q := + remaining_le_fuel_of_doneWitness_maskedPublishedTreeRoot table q left hleftSupport + have hinitialTracked : CleanProbeObservationsTrackedBy [] + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) := by + simp [CleanProbeObservationsTrackedBy] + have hinitialCovered : CleanProbeObservationsCoverPending [] + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) := by + simp [CleanProbeObservationsCoverPending, LazyRevealProbe.State.empty] + have hrightTracked : CleanProbeObservationsTrackedBy [] right.context.state := by + simpa [observedResolvedResult] using + (cleanProbeObservationsTrackedBy_of_mem_runObservedCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty + (2 * q) table hinitialTracked (observedResolvedResult [] right) hrightSupport) + have hrightCovered : CleanProbeObservationsCoverPending [] right.context.state := by + simpa [observedResolvedResult] using + (cleanProbeObservationsCoverPending_of_mem_runObservedCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty + (2 * q) table hinitialCovered (observedResolvedResult [] right) hrightSupport) + have hcapacity : 2 * q < Fintype.card Digest := by + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + norm_num [securityBits, digestBits] at hq ⊢ + omega + have hbudget : right.remaining + right.context.state.pending.card < + Fintype.card Digest := by + have hremaining := remaining_add_pending_card_le_of_mem_runObservedCleanFromTable + (maskedPublishedTreeRoot.run emptySplitHashCache) [] LazyRevealProbe.State.empty + (2 * q) table (observedResolvedResult [] right) hrightSupport + simp only [observedResolvedResult] at hremaining + exact hremaining.trans_lt (by simpa [LazyRevealProbe.State.empty] using hcapacity) + unfold canonicalizeDirectWitnessSnapshotObserve classifyDirectWitnessSnapshotObserve + simp only [canonical, hnotPrivate, ↓reduceDIte, hclean.left_published, ↓reduceIte, + hleftCompletable] + rw [← hclean.value_eq] + simpa [retainedSnapshotObserve, + granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve] using + (relTriple_directSnapshotBoundary_observedMaterialized_firstStopped parameter left.value.1 + ftsSecret (retainedGameRestComputation adversary ⟨left.value.1, parameter⟩) + [] [] canonical right.context left.remaining right.remaining table + left.value.2 right.value.2 q q (hbound left.value.1) + hcanonicalRun.context_le hcanonicalRun.cache_eq hcanonicalRun.revealed_eq + hcanonicalRun.values_le hcanonicalRun.left_published hcanonicalRun.right_materialized + (canonicalizeMaterializedValues_canonical table left.context + hclean.context_le.view.leftConsistent) + (by simp [SnapshotsObservedAt]) (SnapshotsBefore.nil canonical) + hrightTracked hrightCovered (by simp) + (by omega) (by omega) (by omega) hbudget) + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_finishAfterPublishedRoot_firstStopped + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) + (leftResult : DirectWitnessResult (Digest × SplitHashCache)) + (rightResult : Option (ObservedCleanRunResult (Digest × SplitHashCache))) + (hstep : WitnessObservedFirstStoppedStepRel table [] leftResult rightResult) + (hleftSupport : leftResult ∈ support + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext q table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (hrightSupport : rightResult ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache))) : + RelTriple + (finishDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table + (retainedSnapshotObserve adversary parameter table ftsSecret)) [] leftResult) + (match rightResult with + | none => pure none + | some rootResult => do + let restResult ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table rootResult.value.2 + match restResult with + | none => pure none + | some restResult => pure (some + { restResult with + value := ((rootResult.value.1, restResult.value.1), restResult.value.2) })) + (SnapshotObservedFirstStoppedRel table) := by + have hfinish := relTriple_finishWitnessObservedFirstStoppedStep (α := Digest) + (β := RetainedRestResult) parameter id ftsSecret + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩) + (retainedSnapshotObserve adversary parameter table ftsSecret) [] [] table leftResult + rightResult hstep (by + intro nextLeft nextRight hleftEq hrightEq hclean + have hleftDone : DirectWitnessResult.done nextLeft ∈ support + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext q table + (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + rw [← hleftEq] + exact hleftSupport + have hrightDone : some (observedResolvedResult [] nextRight) ∈ support + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache)) := by + rw [← hrightEq] + exact hrightSupport + exact relTriple_afterPublishedRoot_firstStopped adversary parameter ftsSecret q table hbound + hq nextLeft nextRight hleftDone hrightDone hclean) + cases rightResult with + | none => + have hretained := relTriple_post_mono hfinish + (fun source observed hrelation => hrelation.retainRoot 0) + have hmapped := relTriple_map (f := id) (g := retainObservedRoot 0) hretained + rw [id_map] at hmapped + rw [map_retainObservedRoot_eq, pure_bind] at hmapped + exact hmapped + | some rootResult => + have hretained := relTriple_post_mono hfinish + (fun source observed hrelation => hrelation.retainRoot rootResult.value.1) + have hmapped := relTriple_map (f := id) + (g := retainObservedRoot rootResult.value.1) hretained + rw [id_map] at hmapped + rw [map_retainObservedRoot_eq] at hmapped + exact hmapped + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_granularAllSnapshot_observedMaterializedRetained_firstStopped + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + RelTriple + (granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q) + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table) + (SnapshotObservedFirstStoppedRel table) := by + let initial : DeferredContext := emptyWitnessDeferredContext + have hcontext : FinalizationContextLE table initial + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) := + finalizationContextLE_empty table + have hbase := (witnessMaterializedStableCouples_maskedPublishedTreeRoot table) + initial (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + q (2 * q) emptySplitHashCache emptySplitHashCache hcontext (by omega) rfl rfl + (fun _ _ hvalue => hvalue) publishedValues_empty rfl + have hcapacity : 2 * q < Fintype.card Digest := by + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + norm_num [securityBits, digestBits] at hq ⊢ + omega + have hlocal := relTriple_runDirectResolvedWitness_observed_firstStopped_of_probeFree table + (maskedPublishedTreeRoot.run emptySplitHashCache) + (maskedPublishedTreeRoot.run emptySplitHashCache) [] initial + (directDeferredContext + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate)) + q (2 * q) hbase (maskedPublishedTreeRoot_probeFree emptySplitHashCache) + (maskedPublishedTreeRoot_probeFree emptySplitHashCache) hcontext.leftValid + hcontext.leftCompletable rfl (by simp [CleanProbeObservationsTrackedBy]) + (by simp [CleanProbeObservationsCoverPending, directDeferredContext, + LazyRevealProbe.State.empty]) (by simp) + (by simpa [directDeferredContext, LazyRevealProbe.State.empty] using hcapacity) + have hleftSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_left_support hlocal + (fun result => result ∈ support + (runDirectResolvedWitnessFromTable initial q table + (maskedPublishedTreeRoot.run emptySplitHashCache))) + (fun result hresult => hresult) + have hbothSupported := + SphincsSecurity.Concrete.FtsProbeSimulation.relTriple_and_right_support hleftSupported + unfold granularAllCanonicalPrivateWitnessSnapshot + observedMaterializedRetainedRunFromTable runDirectWitnessSnapshotObserve + change RelTriple + (runDirectResolvedWitnessFromTable emptyWitnessDeferredContext q table + (maskedPublishedTreeRoot.run emptySplitHashCache) >>= + finishDirectWitnessSnapshotObserve + (canonicalizeDirectWitnessSnapshotObserve table + (granularDetailedRetainedRestNormalizedPrivateWitnessSnapshotObserve adversary parameter + table ftsSecret)) []) + (runObservedCleanFromTable [] LazyRevealProbe.State.empty (2 * q) table + (maskedPublishedTreeRoot.run emptySplitHashCache) >>= fun rootResult => + match rootResult with + | none => pure none + | some rootResult => do + let restResult ← observedMaterializedBoundary parameter rootResult.value.1 ftsSecret + (retainedGameRestComputation adversary ⟨rootResult.value.1, parameter⟩) + rootResult.observations rootResult.state rootResult.remaining table rootResult.value.2 + match restResult with + | none => pure none + | some restResult => pure (some + { restResult with + value := ((rootResult.value.1, restResult.value.1), restResult.value.2) })) + (SnapshotObservedFirstStoppedRel table) + apply relTriple_bind hbothSupported + intro leftResult rightResult hstep + rcases hstep with ⟨⟨hstep, hleftSupport⟩, hrightSupport⟩ + exact relTriple_finishAfterPublishedRoot_firstStopped adversary parameter ftsSecret q table + hbound hq leftResult rightResult hstep (by simpa [initial] using hleftSupport) hrightSupport + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem relTriple_sampledGranularAllCanonical_observedMaterializedRetained_firstStopped + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + RelTriple + (sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q) + (sampleOtsHashTable >>= fun table => + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table) + (fun source observed => ∃ table, SnapshotObservedFirstStoppedRel table source observed) := by + unfold sampledGranularAllCanonicalPrivateWitnessSnapshot + apply relTriple_bind (relTriple_refl sampleOtsHashTable) + intro leftTable rightTable htable + subst rightTable + apply relTriple_post_mono + (relTriple_granularAllSnapshot_observedMaterializedRetained_firstStopped adversary parameter + ftsSecret q leftTable (hbound leftTable) hq) + intro source observed hrelation + exact ⟨leftTable, hrelation⟩ + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledSuccessfulFirstHit_le_selectedSnapshot_add_chainStartAt + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenHitAt ordinal | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] + + Pr[fun observed => (match observed with + | none => False + | some result => FirstExistingHiddenChainStartHitAt result.observations ordinal) | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] := by + let source := sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q + let observed := do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table + apply probEvent_le_failure_add_residual_of_relTriple observed source + (fun observed source => ∃ table, SnapshotObservedFirstStoppedRel table source observed) + (ObservedCleanRunOption.SuccessfulFirstExistingHiddenHitAt ordinal) + (fun observed => match observed with + | none => False + | some result => FirstExistingHiddenChainStartHitAt result.observations ordinal) + (fun source => SelectedPrivateSnapshotHitAt source ordinal) + (relTriple_symm + (relTriple_sampledGranularAllCanonical_observedMaterializedRetained_firstStopped adversary + parameter ftsSecret q hbound hq)) + intro right left hrelation hevent hnotChain + obtain ⟨table, hrelation⟩ := hrelation + cases right with + | none => simp [ObservedCleanRunOption.SuccessfulFirstExistingHiddenHitAt] at hevent + | some result => + obtain ⟨⟨finalResult, hfinish⟩, hfirst⟩ := hevent + rcases hrelation.selected_or_chain_of_successful_firstHit finalResult hfinish ordinal hfirst + with hselected | hchain + · exact hselected + · exact (hnotChain hchain).elim + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledSuccessfulFirstHit_le_selectedSnapshot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenHitAt ordinal | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := by + calc + _ ≤ Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] + + Pr[fun observed => (match observed with + | none => False + | some result => FirstExistingHiddenChainStartHitAt result.observations ordinal) | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] := by + exact probEvent_sampledSuccessfulFirstHit_le_selectedSnapshot_add_chainStartAt adversary + parameter ftsSecret q ordinal hbound hq + _ = _ := by + have hzero := probEvent_sampled_firstExistingHiddenChainStartHitAt_eq_zero adversary + parameter ftsSecret (2 * q) ordinal + change Pr[fun observed => (match observed with + | none => False + | some result => FirstExistingHiddenChainStartHitAt result.observations ordinal) | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] = 0 + at hzero + rw [hzero] + simp + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_observedMaterialized_successfulDoomed_firstNonRoot_le_selectedNonRoot + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (table : OtsSecretIndex → HashOutput) + (hbound : ∀ root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt table ordinal | + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret (2 * q) table] ≤ + Pr[fun source => SelectedPrivateSnapshotNonRootHitAt source ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q] := by + let source := granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q + let observed := observedMaterializedRetainedRunFromTable adversary parameter ftsSecret + (2 * q) table + calc + _ ≤ Pr[fun source => SelectedPrivateSnapshotNonRootHitAt source ordinal | source] + + Pr[ObservedMaterializedOutput.FirstExistingHiddenChainStartHitAt ordinal | observed] := by + apply probEvent_le_failure_add_residual_of_relTriple observed source + (fun observed source => SnapshotObservedFirstStoppedRel table source observed) + (ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt table ordinal) + (ObservedMaterializedOutput.FirstExistingHiddenChainStartHitAt ordinal) + (fun source => SelectedPrivateSnapshotNonRootHitAt source ordinal) + (relTriple_symm + (relTriple_granularAllSnapshot_observedMaterializedRetained_firstStopped adversary + parameter ftsSecret q table hbound hq)) + intro right left hrelation hevent hnotChain + cases right with + | none => + simp [ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt] at hevent + | some result => + obtain ⟨⟨finalResult, hfinish⟩, selected, hselected, hfirst, + hnonRoot⟩ := hevent + exact hrelation.selectedNonRoot_of_successful_firstNonRoot finalResult hfinish ordinal + selected hselected hfirst hnonRoot hnotChain + _ = _ := by + rw [probEvent_firstExistingHiddenChainStartHitAt_eq_zero adversary parameter ftsSecret + (2 * q) ordinal table] + simp [source] + +set_option maxHeartbeats 4000000 in +set_option maxRecDepth 100000 in +theorem probEvent_sampledDiagnostic_successfulDoomed_firstNonRoot_le + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : + SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[fun outcome => outcome.SuccessfulDoomed ∧ + outcome.FirstExistingHiddenNonRootHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_sampledDiagnostic_successfulDoomed_firstExistingHiddenNonRootHitAt_le_of_forall + intro table + calc + _ ≤ Pr[fun source => SelectedPrivateSnapshotNonRootHitAt source ordinal | + granularAllCanonicalPrivateWitnessSnapshot adversary parameter table ftsSecret q] := + probEvent_observedMaterialized_successfulDoomed_firstNonRoot_le_selectedNonRoot adversary + parameter ftsSecret q ordinal table (hbound table) hq + _ ≤ _ := probEvent_granularAllCanonical_selectedNonRoot_le ordinal adversary parameter + table ftsSecret q + +end SphincsSecurity.Concrete.OtsProbeSimulation.Range125 diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeSuccessfulHiddenCharge.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSuccessfulHiddenCharge.lean new file mode 100644 index 00000000..b57fb080 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSuccessfulHiddenCharge.lean @@ -0,0 +1,162 @@ +import SphincsSecurity.Proof.OtsProbeSuccessfulHiddenOrdinals + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local irreducible] sampledObservedMaterializedDiagnostic observedMaterializedRetainedRunFromTable + +set_option maxRecDepth 100000 + +theorem successful_data_of_mem_finishDiagnostic + (table : OtsSecretIndex → HashOutput) (before : Option (ObservedCleanRunResult α)) + (outcome : ObservedMaterializedDiagnostic α) + (houtcome : outcome ∈ support (finishObservedMaterializedDiagnostic table before)) + (hsuccess : outcome.final.isSome = true) : + ∃ result final, before = some result ∧ outcome.before = some result ∧ + some final ∈ support (finishObservedCleanRunFromTable (some result)) := by + classical + cases before with + | none => + have heq : outcome = ⟨none, none, false⟩ := by simpa [finishObservedMaterializedDiagnostic] using houtcome + subst outcome + simp at hsuccess + | some before => + unfold finishObservedMaterializedDiagnostic at houtcome + rw [mem_support_bind_iff] at houtcome + obtain ⟨final, hfinal, hreturn⟩ := houtcome + simp only [mem_support_pure_iff] at hreturn + subst outcome + cases final with + | none => simp at hsuccess + | some final => exact ⟨before, final, rfl, rfl, hfinal⟩ + +theorem probEvent_finishDiagnostic_successfulHidden_firstRoot_le + (table : OtsSecretIndex → HashOutput) + (run : ProbComp (Option (ObservedCleanRunResult α))) (ordinal : Nat) : + Pr[fun outcome => outcome.SuccessfulHiddenHit ∧ outcome.FirstExistingHiddenRootHitAt ordinal | + run >>= finishObservedMaterializedDiagnostic table] ≤ + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenRootHitAt table ordinal | run] := by + apply probEvent_bind_le_probEvent + intro result _hresult hnot + apply probEvent_eq_zero + intro outcome houtcome hevent + obtain ⟨before, final, hresult, hbefore, hfinal⟩ := + successful_data_of_mem_finishDiagnostic table result outcome houtcome hevent.1.1 + subst result + obtain ⟨rootResult, selected, hrootBefore, hselected, hfirst, hroot⟩ := hevent.2 + have heq : rootResult = before := Option.some.inj (hrootBefore.symm.trans hbefore) + subst rootResult + exact hnot ⟨⟨final, hfinal⟩, selected, hselected, hfirst, hroot⟩ + +theorem probEvent_finishDiagnostic_successfulHidden_firstNonRoot_le + (table : OtsSecretIndex → HashOutput) + (run : ProbComp (Option (ObservedCleanRunResult α))) (ordinal : Nat) : + Pr[fun outcome => outcome.SuccessfulHiddenHit ∧ outcome.FirstExistingHiddenNonRootHitAt ordinal | + run >>= finishObservedMaterializedDiagnostic table] ≤ + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenNonRootHitAt table ordinal | run] := by + apply probEvent_bind_le_probEvent + intro result _hresult hnot + apply probEvent_eq_zero + intro outcome houtcome hevent + obtain ⟨before, final, hresult, hbefore, hfinal⟩ := + successful_data_of_mem_finishDiagnostic table result outcome houtcome hevent.1.1 + subst result + obtain ⟨rootResult, selected, hrootBefore, hselected, hfirst, hroot⟩ := hevent.2 + have heq : rootResult = before := Option.some.inj (hrootBefore.symm.trans hbefore) + subst rootResult + exact hnot ⟨⟨final, hfinal⟩, selected, hselected, hfirst, hroot⟩ + +theorem firstExistingHiddenHitAt_root_or_nonRoot + (outcome : ObservedMaterializedDiagnostic α) (ordinal : Nat) + (hfirst : outcome.FirstExistingHiddenHitAt ordinal) : + outcome.FirstExistingHiddenRootHitAt ordinal ∨ outcome.FirstExistingHiddenNonRootHitAt ordinal := by + obtain ⟨result, hbefore, hfirst⟩ := hfirst + have hfirstData := hfirst + obtain ⟨selected, hselected, _, _⟩ := hfirstData + by_cases hroot : (result.observations.get selected).toProbe.IsLayerRoot + · exact Or.inl ⟨result, selected, hbefore, hselected, hfirst, hroot⟩ + · exact Or.inr ⟨result, selected, hbefore, hselected, hfirst, hroot⟩ + +theorem probEvent_sampledDiagnostic_successfulHidden_firstHit_le_selectedCharge126 + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) (hordinal : ordinal < q) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[fun outcome => outcome.SuccessfulHiddenHit ∧ outcome.FirstExistingHiddenHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + (∑' table, Pr[= table | sampleOtsHashTable] * hiddenSelectionCharge + (permissiveDetailedSelectionExperimentAfterTable ordinal adversary parameter ftsSecret (2 * q) table)) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + have hfuel : 2 * q < Fintype.card Digest := by norm_num [digestBits] at hq ⊢; omega + apply (probEvent_mono (q := fun outcome => + (outcome.SuccessfulHiddenHit ∧ outcome.FirstExistingHiddenRootHitAt ordinal) ∨ + (outcome.SuccessfulHiddenHit ∧ outcome.FirstExistingHiddenNonRootHitAt ordinal)) ?_).trans + · apply (probEvent_or_le _ _ _).trans + unfold sampledObservedMaterializedDiagnostic + simp only [probEvent_bind_eq_tsum sampleOtsHashTable, ← ENNReal.tsum_add, ← mul_add] + rw [← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro table + rw [mul_assoc] + apply mul_le_mul' le_rfl + exact (add_le_add (probEvent_finishDiagnostic_successfulHidden_firstRoot_le table _ ordinal) + (probEvent_finishDiagnostic_successfulHidden_firstNonRoot_le table _ ordinal)).trans + (probEvent_diagnosticOrdinal_pair_le_selectedCharge126 ordinal adversary parameter table ftsSecret q + hordinal hfuel (hbound table) hq) + · intro outcome _hevent hevent + rcases firstExistingHiddenHitAt_root_or_nonRoot outcome ordinal hevent.2 with hroot | hnonRoot + · exact Or.inl ⟨hevent.1, hroot⟩ + · exact Or.inr ⟨hevent.1, hnonRoot⟩ + +theorem probEvent_sampledDiagnostic_successfulHidden_le_selectionCharge126 + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[ObservedMaterializedDiagnostic.SuccessfulHiddenHit | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + sampledHiddenSelectionCharge adversary parameter ftsSecret q * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply (probEvent_sampledDiagnostic_successfulHidden_le_sum_firstHits126 adversary parameter ftsSecret q hbound hq).trans + rw [sampledHiddenSelectionCharge, Finset.sum_mul] + exact Finset.sum_le_sum fun ordinal _ => + probEvent_sampledDiagnostic_successfulHidden_firstHit_le_selectedCharge126 adversary parameter ftsSecret q + ordinal.val ordinal.isLt hbound hq + +theorem probEvent_sampledActualRetained_verifyProbe_le_twoCharges126 + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + (materializedRetainedCharge adversary parameter ftsSecret (2 * q) + + sampledHiddenSelectionCharge adversary parameter ftsSecret q) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply (probEvent_sampledActualRetained_verifyProbe_le_charge_add_successfulHiddenHit126 adversary parameter ftsSecret q hbound hq).trans + rw [add_mul] + exact add_le_add le_rfl (probEvent_sampledDiagnostic_successfulHidden_le_selectionCharge126 adversary parameter ftsSecret q hbound hq) + +theorem probEvent_sampledActualRetained_verifyProbe_le_twoCharges126_of_hashQueryBound + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + (materializedRetainedCharge adversary parameter ftsSecret (2 * q) + + sampledHiddenSelectionCharge adversary parameter ftsSecret q) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + probEvent_sampledActualRetained_verifyProbe_le_twoCharges126 adversary parameter ftsSecret q + (fun table root => isQueryBoundP_expandedRetained_all_tables_roots adversary q hq parameter hparameter table ftsSecret hfts root) hqMax + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeSuccessfulHiddenOrdinals.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSuccessfulHiddenOrdinals.lean new file mode 100644 index 00000000..45646d87 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeSuccessfulHiddenOrdinals.lean @@ -0,0 +1,134 @@ +import SphincsSecurity.Proof.OtsProbeJointHiddenFailure + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local irreducible] sampledObservedMaterializedDiagnostic + sampledGranularAllCanonicalPrivateWitnessSnapshot observedMaterializedRetainedRunFromTable + +set_option maxRecDepth 100000 + +theorem probEvent_finishDiagnostic_successfulHidden_firstHit_le + (table : OtsSecretIndex → HashOutput) + (run : ProbComp (Option (ObservedCleanRunResult α))) (ordinal : Nat) : + Pr[fun outcome => outcome.SuccessfulHiddenHit ∧ outcome.FirstExistingHiddenHitAt ordinal | + run >>= finishObservedMaterializedDiagnostic table] ≤ + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenHitAt ordinal | run] := by + classical + apply probEvent_bind_le_probEvent + intro before _hbefore hnot + apply probEvent_eq_zero + intro outcome houtcome hevent + cases before with + | none => + have heq : outcome = ⟨none, none, false⟩ := by simpa [finishObservedMaterializedDiagnostic] using houtcome + subst outcome + simp [ObservedMaterializedDiagnostic.SuccessfulHiddenHit] at hevent + | some before => + unfold finishObservedMaterializedDiagnostic at houtcome + rw [mem_support_bind_iff] at houtcome + obtain ⟨final, hfinal, hreturn⟩ := houtcome + simp only [mem_support_pure_iff] at hreturn + subst outcome + obtain ⟨⟨hsome, _⟩, firstResult, hfirstBefore, hfirst⟩ := hevent + have heq : firstResult = before := (Option.some.inj hfirstBefore).symm + subst firstResult + cases final with + | none => simp at hsome + | some final => exact hnot ⟨⟨final, hfinal⟩, hfirst⟩ + +theorem probEvent_sampledDiagnostic_successfulHidden_firstHit_le_raw + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel ordinal : Nat) : + Pr[fun outcome => outcome.SuccessfulHiddenHit ∧ outcome.FirstExistingHiddenHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret fuel] ≤ + Pr[ObservedCleanRunOption.SuccessfulFirstExistingHiddenHitAt ordinal | do + let table ← sampleOtsHashTable + observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table] := by + unfold sampledObservedMaterializedDiagnostic + rw [probEvent_bind_eq_tsum (mx := sampleOtsHashTable), probEvent_bind_eq_tsum (mx := sampleOtsHashTable)] + exact ENNReal.tsum_le_tsum fun table => mul_le_mul' le_rfl + (probEvent_finishDiagnostic_successfulHidden_firstHit_le table + (observedMaterializedRetainedRunFromTable adversary parameter ftsSecret fuel table) ordinal) + +theorem probEvent_sampledDiagnostic_successfulHidden_firstHit_le_selectedSnapshot126 + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q ordinal : Nat) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[fun outcome => outcome.SuccessfulHiddenHit ∧ outcome.FirstExistingHiddenHitAt ordinal | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := + (probEvent_sampledDiagnostic_successfulHidden_firstHit_le_raw adversary parameter ftsSecret (2 * q) ordinal).trans + (Range125.probEvent_sampledSuccessfulFirstHit_le_selectedSnapshot adversary parameter ftsSecret q ordinal hbound hq) + +theorem probEvent_sampledDiagnostic_successfulHidden_le_sum_firstHits126 + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[ObservedMaterializedDiagnostic.SuccessfulHiddenHit | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + ∑ ordinal : Fin q, Pr[fun outcome => outcome.SuccessfulHiddenHit ∧ outcome.FirstExistingHiddenHitAt ordinal.val | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] := by + classical + let run := sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q) + have hcover : ∀ outcome ∈ support run, outcome.SuccessfulHiddenHit → + ∃ ordinal : Fin q, outcome.SuccessfulHiddenHit ∧ outcome.FirstExistingHiddenHitAt ordinal.val := by + intro outcome houtcome hsuccess + obtain ⟨before, hbefore, hhit⟩ := hsuccess.2 + obtain ⟨selected, hselected, _⟩ := firstExistingHiddenHitOrdinal?_eq_some_of_hasExistingHiddenHit before hhit + have hfirst : outcome.FirstExistingHiddenHitAt selected.val := + ⟨before, hbefore, firstExistingHiddenHitAt_of_firstExistingHiddenHitOrdinal?_eq_some hselected⟩ + have hlt : selected.val < q := by + by_contra hnot + have hzero : Pr[fun result => result.SuccessfulHiddenHit ∧ result.FirstExistingHiddenHitAt selected.val | run] = 0 := by + apply le_antisymm _ zero_le + exact (probEvent_sampledDiagnostic_successfulHidden_firstHit_le_selectedSnapshot126 + adversary parameter ftsSecret q selected.val hbound hq).trans_eq + (probEvent_selectedPrivateSnapshotHitAt_eq_zero_of_q_le_ordinal + adversary parameter ftsSecret q selected.val hbound (by omega)) + exact (probEvent_ne_zero_iff.mpr ⟨outcome, houtcome, hsuccess, hfirst⟩) hzero + exact ⟨⟨selected.val, hlt⟩, hsuccess, hfirst⟩ + calc + _ ≤ Pr[fun outcome => ∃ ordinal ∈ (Finset.univ : Finset (Fin q)), + outcome.SuccessfulHiddenHit ∧ outcome.FirstExistingHiddenHitAt ordinal.val | run] := by + apply probEvent_mono + intro outcome houtcome hsuccess + obtain ⟨ordinal, hordinal⟩ := hcover outcome houtcome hsuccess + exact ⟨ordinal, Finset.mem_univ _, hordinal⟩ + _ ≤ ∑ ordinal : Fin q, Pr[fun outcome => outcome.SuccessfulHiddenHit ∧ + outcome.FirstExistingHiddenHitAt ordinal.val | run] := + probEvent_exists_finset_le_sum Finset.univ run fun (ordinal : Fin q) outcome => + outcome.SuccessfulHiddenHit ∧ outcome.FirstExistingHiddenHitAt ordinal.val + + +theorem probEvent_sampledDiagnostic_successfulHidden_le_sum_selectedSnapshots126 + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 126) : + Pr[ObservedMaterializedDiagnostic.SuccessfulHiddenHit | + sampledObservedMaterializedDiagnostic adversary parameter ftsSecret (2 * q)] ≤ + ∑ ordinal : Fin q, Pr[fun source => SelectedPrivateSnapshotHitAt source ordinal.val | + sampledGranularAllCanonicalPrivateWitnessSnapshot adversary parameter ftsSecret q] := by + exact (probEvent_sampledDiagnostic_successfulHidden_le_sum_firstHits126 adversary parameter ftsSecret q hbound hq).trans + (Finset.sum_le_sum fun ordinal _ => + probEvent_sampledDiagnostic_successfulHidden_firstHit_le_selectedSnapshot126 + adversary parameter ftsSecret q ordinal.val hbound hq) + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeTerminal.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeTerminal.lean new file mode 100644 index 00000000..3a8b96ca --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeTerminal.lean @@ -0,0 +1,184 @@ +import SphincsSecurity.Proof.OtsProbeOrigin + +/-! +# Winning one-time probe witnesses + +The fresh and backward terminal events both expose an uncovered correct probe whose exact input +belongs to the successful verifier's query trace under the retained answer function. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal + +def WinningRetainedVerifyProbeWitness (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := + WinningRetainedWitnessFor parameter table ftsSecret + fun f cache secretKey log forgery _ _ => + ¬Bad parameter (tableOtsSecret table) ftsSecret cache ∧ + VerifyProbeWitness f cache secretKey log forgery.message forgery.signature + +theorem actualRetainedGameAfterTable_verify_support + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (table : Coordinate → HashOutput) + (result : RetainedGameResult × QueryCache HashSpec) + (hresult : result ∈ support + (actualRetainedGameAfterTable adversary parameter ftsSecret table)) + (hverified : result.1.2.2 = true) : + ∃ adversaryCache : QueryCache HashSpec, + (true, result.2) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (verify ⟨result.1.1, parameter⟩ result.1.2.1.1.message + result.1.2.1.1.signature)).run adversaryCache) := by + rw [actualRetainedGameAfterTable, mem_support_bind_iff] at hresult + obtain ⟨⟨root, rootCache⟩, _, hrest⟩ := hresult + rw [mem_support_bind_iff] at hrest + obtain ⟨⟨restResult, finalCache⟩, hrest, hfinish⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hfinish + rcases hfinish with ⟨hresultValue, hresultCache⟩ + rw [simulateQ_unloggedMapped_retainedGameRestComputation, + StateT.run_bind, mem_support_bind_iff] at hrest + obtain ⟨⟨⟨forgery, log⟩, adversaryCache⟩, _, hverify⟩ := hrest + rw [StateT.run_bind, mem_support_bind_iff] at hverify + obtain ⟨⟨verified, verifyCache⟩, hverify, hreturn⟩ := hverify + simp only [StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq] at hreturn + rcases hreturn with ⟨hrestResult, hfinalCache⟩ + subst restResult + subst finalCache + simp only at hverified + subst verified + refine ⟨adversaryCache, ?_⟩ + simpa only [scheme, simulateQ_romImpl_liftM] using hverify + +def ExecutedVerifyProbeWitness (f : QueryImpl HashSpec Id) + (cache : QueryCache HashSpec) (secretKey : SecretKey) + (signingLog : QueryLog SigningSpec) (forgery : Forgery) : Prop := + VerifyProbeWitness f cache secretKey signingLog forgery.message forgery.signature ∧ + CachedRun cache f + (verify ⟨secretKey.root, secretKey.parameter⟩ forgery.message forgery.signature) + +def WinningRetainedExecutedVerifyProbeWitness (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := + WinningRetainedWitnessFor parameter table ftsSecret + fun f cache secretKey log forgery _ _ => + ¬Bad parameter (tableOtsSecret table) ftsSecret cache ∧ + ExecutedVerifyProbeWitness f cache secretKey log forgery + +theorem winningRetainedVerifyProbe_imp_executed + (adversary : Adversary) (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : RetainedGameResult × QueryCache HashSpec) + (hresult : result ∈ support + (actualRetainedGameAfterTable adversary parameter ftsSecret table)) + (hwitness : WinningRetainedVerifyProbeWitness parameter table ftsSecret result) : + WinningRetainedExecutedVerifyProbeWitness parameter table ftsSecret result := by + rcases hwitness with ⟨hverdict, f, digest, hf, hvalid, hnotContains, hdigest, + hadmissible, heval, hbad, hprobe⟩ + obtain ⟨adversaryCache, hverify⟩ := actualRetainedGameAfterTable_verify_support adversary + parameter ftsSecret table result hresult hverdict + have hrun : CachedRun result.2 f + (verify ⟨result.1.1, parameter⟩ result.1.2.1.1.message + result.1.2.1.1.signature) := + (replay_of_mem_support + (verify ⟨result.1.1, parameter⟩ result.1.2.1.1.message + result.1.2.1.1.signature) + adversaryCache true result.2 hverify f hf).2.2 + exact ⟨hverdict, f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, heval, + hbad, hprobe, hrun⟩ + +theorem probEvent_winningRetainedVerifyProbe_le_executed + (adversary : Adversary) (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[WinningRetainedVerifyProbeWitness parameter table ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret table] ≤ + Pr[WinningRetainedExecutedVerifyProbeWitness parameter table ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret table] := + probEvent_mono fun result hresult hwitness => + winningRetainedVerifyProbe_imp_executed adversary parameter table ftsSecret result hresult + hwitness + +def RawCachesVerifierTrace (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (root : Digest) (forgery : Forgery) (cache : SplitHashCache) : Prop := + ∀ input, input ∈ queriedInputs f + (verify ⟨root, parameter⟩ forgery.message forgery.signature) → + cache (.ordinary input) ≠ none + +theorem ChainInvariant.not_finalized_false_of_verifyProbe + {f : QueryImpl HashSpec Id} {parameter : PublicParameter} + {table : Coordinate → HashOutput} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {targetCache : QueryCache HashSpec} + {rawState completedState : LazyRevealProbe.State Coordinate} + {rawCache : SplitHashCache} {root : Digest} {forgery : Forgery} + {signingLog : QueryLog SigningSpec} + (hinvariant : ChainInvariant parameter + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) signingLog) + rawState rawCache) + (hcompletedTable : ∀ coordinate output, + completedState.values coordinate = some output → output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hfinalize : (false, completedState) ∈ support + (LazyRevealProbe.finalizeDetailed rawState)) + (hqueries : RawCachesVerifierTrace f parameter root forgery rawCache) + (hprobe : VerifyProbeWitness f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + signingLog forgery.message forgery.signature) : False := by + obtain ⟨lay, digest, layerMessage, codeword, chainIdx, hdigit, probe, input, + hinput, hdigest, hadmissible, hencode, hverifierMessage, hhits, hmatches, hquery, + _, hnotCovered, _hsourceSettled⟩ := hprobe + exact hinvariant.not_finalized_false_of_uncovered_probe probe input hhits hmatches + (hqueries input hquery) hnotCovered (hcompletedTable probe.coordinate) hrealizes hfinalize + +theorem winningRetainedFresh_imp_verifyProbe + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : RetainedGameResult × QueryCache HashSpec) + (hwitness : WinningRetainedFreshLayerOpeningWitness parameter table ftsSecret result) : + WinningRetainedVerifyProbeWitness parameter table ftsSecret result := by + rcases hwitness with ⟨hverdict, f, digest, hf, hvalid, hnotContains, hdigest, + hadmissible, heval, hbad, hfresh⟩ + exact ⟨hverdict, f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, heval, + hbad, SettledForgedFreshLayerOpening.toVerifyProbeWitness hdigest hadmissible hfresh⟩ + +theorem winningRetainedBackward_imp_verifyProbe + (parameter : PublicParameter) (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : RetainedGameResult × QueryCache HashSpec) + (hwitness : WinningRetainedBackwardChainOpeningWitness parameter table ftsSecret result) : + WinningRetainedVerifyProbeWitness parameter table ftsSecret result := by + rcases hwitness with ⟨hverdict, f, digest, hf, hvalid, hnotContains, hdigest, + hadmissible, heval, hbad, hbackward⟩ + exact ⟨hverdict, f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, heval, + hbad, SettledForgedBackwardChainOpening.toVerifyProbeWitness hdigest hadmissible hbackward⟩ + +theorem probEvent_winningRetainedFresh_le_verifyProbe + (adversary : Adversary) (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[WinningRetainedFreshLayerOpeningWitness parameter table ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret table] ≤ + Pr[WinningRetainedVerifyProbeWitness parameter table ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret table] := + probEvent_mono fun result _ => winningRetainedFresh_imp_verifyProbe + parameter table ftsSecret result + +theorem probEvent_winningRetainedBackward_le_verifyProbe + (adversary : Adversary) (parameter : PublicParameter) + (table : Coordinate → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[WinningRetainedBackwardChainOpeningWitness parameter table ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret table] ≤ + Pr[WinningRetainedVerifyProbeWitness parameter table ftsSecret | + actualRetainedGameAfterTable adversary parameter ftsSecret table] := + probEvent_mono fun result _ => winningRetainedBackward_imp_verifyProbe + parameter table ftsSecret result + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeTrace.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeTrace.lean new file mode 100644 index 00000000..9c84048b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeTrace.lean @@ -0,0 +1,418 @@ +import SphincsSecurity.Proof.OtsProbeSampling + +/-! +# Retained verifier trace alignment + +The digest and few-time recovery prefix of verification uses only stable hash domains. This module +first packages that replay fact, then connects the three concrete one-time verifier layers to the +ordinary entries produced by the probing handler. +-/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +theorem queriesStable_ftsFold + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (index : Index) (tree : FtsTree) (leafIdx : FtsLeaf) + (path : Fin ftsTreeHeight → Digest) : + ∀ levels value, levels ≤ ftsTreeHeight → + QueriesStable parameter f + (ftsFold parameter index tree leafIdx path levels value) + | 0, value, _ => QueriesStable.pure parameter f value + | levels + 1, value, hlevels => by + rw [ftsFold_succ_eq] + exact (queriesStable_ftsFold f parameter index tree leafIdx path levels value + (by omega)).bind <| by + split <;> split <;> + exact queriesStable_tweakableHash f parameter + (.ftsNode index tree (levels + 1) (leafIdx.val / 2 ^ (levels + 1))) _ + (by + show levels + 1 < 2 ^ 32 ∧ leafIdx.val / 2 ^ (levels + 1) < 2 ^ 32 + constructor + · have hheight : ftsTreeHeight < 2 ^ 32 := by + norm_num [ftsTreeHeight] + omega + · have hleaf : leafIdx.val < 2 ^ 32 := by + exact lt_of_lt_of_le leafIdx.isLt (by norm_num [ftsTreeHeight]) + have hdiv := Nat.div_le_self leafIdx.val (2 ^ (levels + 1)) + omega) + (by simp) (by simp) (by simp) + +theorem queriesStable_ftsRecover + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (index : Index) (leaves : DigestTree → FtsLeaf) + (secrets : FtsTree → Digest) (paths : FtsTree → Fin ftsTreeHeight → Digest) : + QueriesStable parameter f + (ftsRecover parameter index leaves secrets paths) := by + unfold ftsRecover + apply (QueriesStable.sequenceFin _ fun tree => ?_).bind + · exact queriesStable_tweakableHash f parameter (.ftsRoots index) _ (by trivial) + (by simp) (by simp) (by simp) + · exact (queriesStable_ftsLeafHash f parameter index tree + (leaves (ftsIndexOf tree)) (secrets tree)).bind + (queriesStable_ftsFold f parameter index tree (leaves (ftsIndexOf tree)) + (paths tree) ftsTreeHeight _ le_rfl) + +theorem simulateQ_probingRom_scheme_verify + (parameter : PublicParameter) (publicKey : PublicKey) + (message : Message) (signature : Signature) : + simulateQ (probingRomImpl parameter) + (scheme.verify publicKey message signature) = + simulateQ (probingHashImpl parameter) + (verify publicKey message signature) := by + rw [show scheme.verify publicKey message signature = + liftM (verify publicKey message signature : OracleComp HashSpec Bool) by rfl] + exact QueryImpl.simulateQ_add_liftM_right _ _ _ + +theorem simulateQ_verifierRom_scheme_verify + (parameter : PublicParameter) (publicKey : PublicKey) + (message : Message) (signature : Signature) : + simulateQ (verifierRomImpl parameter) + (scheme.verify publicKey message signature) = + simulateQ (verifierHashImpl parameter) + (verify publicKey message signature) := by + rw [show scheme.verify publicKey message signature = + liftM (verify publicKey message signature : OracleComp HashSpec Bool) by rfl] + exact QueryImpl.simulateQ_add_liftM_right _ _ _ + +theorem replay_of_mem_runRaw_verifierRom_scheme_verify + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (publicKey : PublicKey) (message : Message) (signature : Signature) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (verified : Bool) + (hf : (ordinaryQueryCache finalCache).AgreesWithFn f) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (verified, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((simulateQ (verifierRomImpl parameter) + (scheme.verify publicKey message signature)).run cache))) : + evalWithAnswerFn f (verify publicKey message signature) = verified ∧ + CachedRun (ordinaryQueryCache finalCache) f + (verify publicKey message signature) := by + rw [simulateQ_verifierRom_scheme_verify] at hresult + exact replay_of_mem_runRaw_verifierHashImpl f parameter + (verify publicKey message signature) state finalState cache finalCache fuel remaining verified + hf hresult + +theorem rawCachesVerifierTrace_of_mem_runRaw_verifierRom + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (publicKey : PublicKey) (message : Message) (signature : Signature) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (verified : Bool) + (hf : (ordinaryQueryCache finalCache).AgreesWithFn f) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (verified, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((simulateQ (verifierRomImpl parameter) + (scheme.verify publicKey message signature)).run cache))) : + ∀ input, input ∈ queriedInputs f (verify publicKey message signature) → + finalCache (.ordinary input) ≠ none := by + exact (replay_of_mem_runRaw_verifierRom_scheme_verify f parameter publicKey message signature + state finalState cache finalCache fuel remaining verified hf hresult).2 + +set_option maxRecDepth 10000 in +theorem cached_bottom_probe_of_mem_runRaw_verify + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (root : Digest) (message : Message) (signature : Signature) + (digest : MessageDigest) (codeword : Encoding) (chainIdx : ChainIndex) + (hdigit : (codeword chainIdx).val < chainLength - 1) + (hdigest : evalWithAnswerFn f + (messageDigest parameter root message signature.randomness) = digest) + (hadmissible : Admissible digest) + (hencode : evalWithAnswerFn f + (encode parameter bottomLayer (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (evalWithAnswerFn f + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + signature.ftsSecret signature.ftsPath)) + (signature.counter bottomLayer)) = some codeword) + (state finalState : LazyRevealProbe.State Coordinate) + (cache finalCache : SplitHashCache) (fuel remaining : Nat) (verified : Bool) + (hf : StableCacheAgreesWithFn parameter finalCache f) + (hresult : LazyRevealProbe.RawResult.done finalState remaining + (verified, finalCache) ∈ support + (LazyRevealProbe.runRaw state fuel + ((simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ message signature)).run cache))) : + finalCache (.ordinary (tweakableHashInput parameter + (.chain bottomLayer (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) chainIdx + ⟨(codeword chainIdx).val, hdigit⟩) + (digestBytes (signature.chainValue bottomLayer chainIdx)))) ≠ none := by + rw [simulateQ_probingRom_scheme_verify, verify_eq, simulateQ_bind, + StateT.run_bind, LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hresult + obtain ⟨digestRaw, hdigestRaw, hafterDigest⟩ := hresult + cases digestRaw with + | stopped hit => simp at hafterDigest + | done digestState digestRemaining digestResult => + rcases digestResult with ⟨sampledDigest, digestCache⟩ + have hfDigest : StableCacheAgreesWithFn parameter digestCache f := + StableCacheAgreesWithFn.of_run + (fun input hstable => + (ordinaryEntryPreservingImpl_probingHashImpl parameter input hstable).simulateQ _) + digestState finalState digestCache finalCache digestRemaining remaining verified hf + hafterDigest + have hdigestEval := (replay_of_mem_runRaw_probingHashImpl_of_stable f parameter + (messageDigest parameter root message signature.randomness) state digestState cache + digestCache fuel digestRemaining sampledDigest hfDigest + (queriesStable_messageDigest f parameter root message signature.randomness) + hdigestRaw).1 + rw [hdigest] at hdigestEval + subst sampledDigest + simp only [hadmissible, not_true_eq_false, ↓reduceIte] at hafterDigest + rw [simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterDigest + obtain ⟨ftsRaw, hftsRaw, hafterFts⟩ := hafterDigest + cases ftsRaw with + | stopped hit => simp at hafterFts + | done ftsState ftsRemaining ftsResult => + rcases ftsResult with ⟨ftsPublicKey, ftsCache⟩ + have hfFts : StableCacheAgreesWithFn parameter ftsCache f := + StableCacheAgreesWithFn.of_run + (fun input hstable => + (ordinaryEntryPreservingImpl_probingHashImpl parameter input hstable).simulateQ _) + ftsState finalState ftsCache finalCache ftsRemaining remaining verified hf hafterFts + have hftsEval := (replay_of_mem_runRaw_probingHashImpl_of_stable f parameter + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + signature.ftsSecret signature.ftsPath) + digestState ftsState digestCache ftsCache digestRemaining ftsRemaining ftsPublicKey + hfFts (queriesStable_ftsRecover f parameter (digestIndex digest) + (digestLeaves digest) signature.ftsSecret signature.ftsPath) hftsRaw).1 + subst ftsPublicKey + simp only at hafterFts + rw [simulateQ_bind, StateT.run_bind, LazyRevealProbe.runRaw_bind, + mem_support_bind_iff] at hafterFts + obtain ⟨layersRaw, hlayersRaw, hafterLayers⟩ := hafterFts + cases layersRaw with + | stopped hit => simp at hafterLayers + | done layersState layersRemaining layersResult => + rcases layersResult with ⟨verifiedRoot, layersCache⟩ + have hfLayers : StableCacheAgreesWithFn parameter layersCache f := + StableCacheAgreesWithFn.of_run + (fun input hstable => + (ordinaryEntryPreservingImpl_probingHashImpl parameter input + hstable).simulateQ _) + layersState finalState layersCache finalCache layersRemaining remaining + verified hf hafterLayers + rw [show numLayers = bottomLayer.val + 1 by rfl, verifyLayers_succ_eq, + dif_pos bottomLayer.isLt, simulateQ_bind, StateT.run_bind, + LazyRevealProbe.runRaw_bind, mem_support_bind_iff] at hlayersRaw + obtain ⟨otsRaw, hotsRaw, hafterOts⟩ := hlayersRaw + cases otsRaw with + | stopped hit => simp at hafterOts + | done otsState otsRemaining otsResult => + rcases otsResult with ⟨leafResult, otsCache⟩ + have hfOts : StableCacheAgreesWithFn parameter otsCache f := + StableCacheAgreesWithFn.of_run + (fun input hstable => + (ordinaryEntryPreservingImpl_probingHashImpl parameter input + hstable).simulateQ _) + otsState layersState otsCache layersCache otsRemaining layersRemaining + verifiedRoot hfLayers hafterOts + have hcached := cached_forged_chain_query_of_mem_runRaw_otsLeaf f parameter + bottomLayer (treeIndexAt (digestIndex digest) bottomLayer) + (leafIndexAt (digestIndex digest) bottomLayer) + (evalWithAnswerFn f + (ftsRecover parameter (digestIndex digest) (digestLeaves digest) + signature.ftsSecret signature.ftsPath)) + (signature.counter bottomLayer) (signature.chainValue bottomLayer) + codeword hencode chainIdx hdigit ftsState otsState ftsCache otsCache + ftsRemaining otsRemaining leafResult hfOts hotsRaw + have hcachedLayers := + (preservesOrdinaryPresenceImpl_probingHashImpl parameter _).simulateQ _ + otsState otsCache otsRemaining layersState layersRemaining verifiedRoot + layersCache hcached hafterOts + exact (preservesOrdinaryPresenceImpl_probingHashImpl parameter _).simulateQ _ + layersState layersCache layersRemaining finalState remaining verified + finalCache hcachedLayers hafterLayers + +theorem VerifierLayerMessage.bottom_message + {f : QueryImpl HashSpec Id} {parameter : PublicParameter} {index : Index} + {leaves : DigestTree → FtsLeaf} {signature : Signature} {message : Digest} + (hmessage : VerifierLayerMessage f parameter index leaves signature bottomLayer message) : + message = evalWithAnswerFn f + (ftsRecover parameter index leaves signature.ftsSecret signature.ftsPath) := by + simp only [VerifierLayerMessage] at hmessage + obtain ⟨bottomLeaf, hbottom, middleLeaf, hmiddle, hposition⟩ := hmessage + rcases hposition with hbottomPosition | hrest + · exact hbottomPosition.2 + · rcases hrest with hmiddlePosition | htopPosition + · have : bottomLayer ≠ middleLayer := by + intro heq + have hval := congrArg Fin.val heq + norm_num [bottomLayer, middleLayer, numLayers] at hval + exact (this hmiddlePosition.1).elim + · have : bottomLayer ≠ topLayer := by + intro heq + have hval := congrArg Fin.val heq + norm_num [bottomLayer, topLayer, numLayers] at hval + exact (this htopPosition.1).elim + +theorem VerifierLayerMessage.middle_data + {f : QueryImpl HashSpec Id} {parameter : PublicParameter} {index : Index} + {leaves : DigestTree → FtsLeaf} {signature : Signature} {message : Digest} + (hmessage : VerifierLayerMessage f parameter index leaves signature middleLayer message) : + ∃ bottomLeaf, + evalWithAnswerFn f + (otsLeaf parameter bottomLayer (treeIndexAt index bottomLayer) + (leafIndexAt index bottomLayer) + (evalWithAnswerFn f + (ftsRecover parameter index leaves signature.ftsSecret signature.ftsPath)) + (signature.counter bottomLayer) (signature.chainValue bottomLayer)) = + some bottomLeaf + ∧ message = foldValue f parameter bottomLayer (treeIndexAt index bottomLayer) + (leafIndexAt index bottomLayer) (signaturePath signature bottomLayer) bottomLeaf + (layerHeight bottomLayer) := by + simp only [VerifierLayerMessage] at hmessage + obtain ⟨bottomLeaf, hbottom, middleLeaf, hmiddle, hposition⟩ := hmessage + refine ⟨bottomLeaf, hbottom, ?_⟩ + rcases hposition with hbottomPosition | hrest + · have : middleLayer ≠ bottomLayer := by + intro heq + have hval := congrArg Fin.val heq + norm_num [middleLayer, bottomLayer, numLayers] at hval + exact (this hbottomPosition.1).elim + · rcases hrest with hmiddlePosition | htopPosition + · exact hmiddlePosition.2 + · have : middleLayer ≠ topLayer := by + intro heq + have hval := congrArg Fin.val heq + norm_num [middleLayer, topLayer, numLayers] at hval + exact (this htopPosition.1).elim + +theorem VerifierLayerMessage.top_data + {f : QueryImpl HashSpec Id} {parameter : PublicParameter} {index : Index} + {leaves : DigestTree → FtsLeaf} {signature : Signature} {message : Digest} + (hmessage : VerifierLayerMessage f parameter index leaves signature topLayer message) : + ∃ bottomLeaf middleLeaf, + evalWithAnswerFn f + (otsLeaf parameter bottomLayer (treeIndexAt index bottomLayer) + (leafIndexAt index bottomLayer) + (evalWithAnswerFn f + (ftsRecover parameter index leaves signature.ftsSecret signature.ftsPath)) + (signature.counter bottomLayer) (signature.chainValue bottomLayer)) = + some bottomLeaf + ∧ evalWithAnswerFn f + (otsLeaf parameter middleLayer (treeIndexAt index middleLayer) + (leafIndexAt index middleLayer) + (foldValue f parameter bottomLayer (treeIndexAt index bottomLayer) + (leafIndexAt index bottomLayer) (signaturePath signature bottomLayer) + bottomLeaf (layerHeight bottomLayer)) + (signature.counter middleLayer) (signature.chainValue middleLayer)) = + some middleLeaf + ∧ message = foldValue f parameter middleLayer (treeIndexAt index middleLayer) + (leafIndexAt index middleLayer) (signaturePath signature middleLayer) middleLeaf + (layerHeight middleLayer) := by + simp only [VerifierLayerMessage] at hmessage + obtain ⟨bottomLeaf, hbottom, middleLeaf, hmiddle, hposition⟩ := hmessage + refine ⟨bottomLeaf, middleLeaf, hbottom, hmiddle, ?_⟩ + rcases hposition with hbottomPosition | hrest + · have : topLayer ≠ bottomLayer := by + intro heq + have hval := congrArg Fin.val heq + norm_num [topLayer, bottomLayer, numLayers] at hval + exact (this hbottomPosition.1).elim + · rcases hrest with hmiddlePosition | htopPosition + · have : topLayer ≠ middleLayer := by + intro heq + have hval := congrArg Fin.val heq + norm_num [topLayer, middleLayer, numLayers] at hval + exact (this hmiddlePosition.1).elim + · exact htopPosition.2 + +theorem VerifyProbeWitness.at_bottom_or_middle_or_top + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {signingLog : QueryLog SigningSpec} + {forgedMessage : Message} {signature : Signature} + (hprobe : VerifyProbeWitness f cache secretKey signingLog forgedMessage signature) : + VerifyProbeWitnessAt f cache secretKey signingLog forgedMessage signature bottomLayer + ∨ VerifyProbeWitnessAt f cache secretKey signingLog forgedMessage signature middleLayer + ∨ VerifyProbeWitnessAt f cache secretKey signingLog forgedMessage signature topLayer := by + obtain ⟨lay, hprobe⟩ := hprobe + fin_cases lay + · exact Or.inr (Or.inr hprobe) + · exact Or.inr (Or.inl hprobe) + · exact Or.inl hprobe + +theorem ChainInvariant.not_finalized_false_of_bottom_verifyProbe + {f : QueryImpl HashSpec Id} {parameter : PublicParameter} + {table : Coordinate → HashOutput} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {targetCache : QueryCache HashSpec} + {initialState rawState completedState : LazyRevealProbe.State Coordinate} + {initialCache rawCache : SplitHashCache} {root : Digest} {forgery : Forgery} + {signingLog : QueryLog SigningSpec} {fuel remaining : Nat} {verified : Bool} + (hinvariant : ChainInvariant parameter + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) signingLog) + rawState rawCache) + (hf : StableCacheAgreesWithFn parameter rawCache f) + (hcompletedTable : ∀ coordinate output, + completedState.values coordinate = some output → output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hfinalize : (false, completedState) ∈ support + (LazyRevealProbe.finalizeDetailed rawState)) + (hverify : LazyRevealProbe.RawResult.done rawState remaining + (verified, rawCache) ∈ support + (LazyRevealProbe.runRaw initialState fuel + ((simulateQ (probingRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).run + initialCache))) + (hprobe : VerifyProbeWitnessAt f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + signingLog forgery.message forgery.signature bottomLayer) : False := by + obtain ⟨digest, layerMessage, codeword, chainIdx, hdigit, probe, input, hinput, + hdigest, hadmissible, hencode, hverifierMessage, hhits, hmatches, hquery, + htargetCached, hnotCovered, _hsourceSettled⟩ := hprobe + have hlayerMessage := VerifierLayerMessage.bottom_message hverifierMessage + rw [hlayerMessage] at hencode + have hcached := cached_bottom_probe_of_mem_runRaw_verify f parameter root forgery.message + forgery.signature digest codeword chainIdx hdigit hdigest hadmissible hencode + initialState rawState initialCache rawCache fuel remaining verified hf hverify + have hcachedInput : rawCache (.ordinary input) ≠ none := by + rw [hinput] + exact hcached + exact hinvariant.not_finalized_false_of_uncovered_probe probe input hhits hmatches + hcachedInput hnotCovered (hcompletedTable probe.coordinate) hrealizes hfinalize + +theorem ChainInvariant.not_finalized_false_of_verifyProbe_of_cachedBefore + {f : QueryImpl HashSpec Id} {parameter : PublicParameter} + {table : Coordinate → HashOutput} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {targetCache : QueryCache HashSpec} + {initialState rawState completedState : LazyRevealProbe.State Coordinate} + {initialCache rawCache : SplitHashCache} {root : Digest} {forgery : Forgery} + {signingLog : QueryLog SigningSpec} {fuel remaining : Nat} {verified : Bool} + (hinvariant : ChainInvariant parameter + (CoveredChainCoordinate f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) signingLog) + initialState initialCache) + (hcompletedTable : ∀ coordinate output, + completedState.values coordinate = some output → output = table coordinate) + (hrealizes : ∀ position : Position, IsOtsPosition position → + f (tableInput parameter table (.position position)) = table (.position position)) + (hfinalize : (false, completedState) ∈ support + (LazyRevealProbe.finalizeDetailed rawState)) + (hverify : LazyRevealProbe.RawResult.done rawState remaining + (verified, rawCache) ∈ support + (LazyRevealProbe.runRaw initialState fuel + ((simulateQ (verifierRomImpl parameter) + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).run + initialCache))) + (hqueriesBefore : ∀ input, + input ∈ queriedInputs f + (verify ⟨root, parameter⟩ forgery.message forgery.signature) → + initialCache (.ordinary input) ≠ none) + (hprobe : VerifyProbeWitness f targetCache + (⟨parameter, root, tableOtsSecret table, ftsSecret⟩ : SecretKey) + signingLog forgery.message forgery.signature) : False := by + obtain ⟨lay, digest, layerMessage, codeword, chainIdx, hdigit, probe, input, + hinput, hdigest, hadmissible, hencode, hverifierMessage, hhits, hmatches, hquery, + _, hnotCovered, _hsourceSettled⟩ := hprobe + exact hinvariant.not_finalized_false_of_uncovered_probe_through probe input hhits hmatches + (hqueriesBefore input hquery) hnotCovered (hcompletedTable probe.coordinate) hrealizes + hverify hfinalize + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeVerifierBoundary.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeVerifierBoundary.lean new file mode 100644 index 00000000..6bdcdf90 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeVerifierBoundary.lean @@ -0,0 +1,266 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalHiddenFreshSigner + +/-! Verifier hash calls publish every materialized value, so inserting canonicalization between them preserves the execution distribution. -/ + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +theorem preservesCoordinateMaterializedPublished_revealPublishedCoordinate_any + (coordinate other : Coordinate) : + PreservesCoordinateMaterializedPublished coordinate (revealPublishedCoordinate other) := by + by_cases heq : coordinate = other + · subst other + have h := (preservesCoordinateMaterializedPublished_revealOutput_publish coordinate).bind + (fun output => (preservesCoordinate_pure coordinate (truncateHash output)).to_materializedPublished) + simpa only [revealPublishedCoordinate, revealCoordinate, bind_assoc, pure_bind] using h + · unfold revealPublishedCoordinate + exact ((preservesCoordinate_revealCoordinate_of_ne coordinate other heq).bind fun value => + (preservesCoordinate_publishCoordinate_of_ne coordinate other heq).bind fun _ => + preservesCoordinate_pure coordinate value).to_materializedPublished + +theorem preservesCoordinateMaterializedPublished_maskedPublishedTreeRoot + (coordinate : Coordinate) : + PreservesCoordinateMaterializedPublished coordinate maskedPublishedTreeRoot := by + unfold maskedPublishedTreeRoot + exact (preservesCoordinate_ensureTreeNode coordinate topLayer rootTree + (layerHeight topLayer) 0).to_materializedPublished.bind fun _ => + preservesCoordinateMaterializedPublished_revealPublishedCoordinate_any coordinate _ + +theorem CanonicalMaterializedValues.canonicalize_eq + (hcanonical : CanonicalMaterializedValues table context) : + canonicalizeMaterializedValues table context = context := by + unfold canonicalizeMaterializedValues + rw [← hcanonical] + +theorem CanonicalMaterializedValues.materializedPublished + (hcanonical : CanonicalMaterializedValues table context) (coordinate : Coordinate) : + CoordinateMaterializedPublished coordinate context.state := by + intro hvalue + by_contra hhidden + exact hvalue (by rw [congrFun hcanonical coordinate]; simp [publicMaterializedValues, hhidden]) + +theorem canonicalMaterializedValues_of_published + (table : OtsSecretIndex → HashOutput) (context : DeferredContext) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) + (hmaterialized : ∀ coordinate, CoordinateMaterializedPublished coordinate context.state) : + CanonicalMaterializedValues table context := by + funext coordinate + unfold publicMaterializedValues + by_cases hrevealed : coordinate ∈ context.state.revealed + · simp only [hrevealed, ↓reduceIte] + cases hvalue : context.state.values coordinate with + | none => exact False.elim (hpublished coordinate hrevealed hvalue) + | some output => + cases coordinate with + | chainStart lay tree leafIdx chainIdx => + have htable := hstarts ⟨lay, tree, leafIdx, chainIdx⟩ output hvalue + simpa [resolvedCompletionValue] using congrArg some htable + | position position => simp [resolvedCompletionValue, DeferredContext.positionValue, hvalue] + · simp only [hrevealed, ↓reduceIte] + by_contra hvalue + exact hrevealed (hmaterialized coordinate hvalue) + +theorem preservesCoordinate_probeFirstMissingInputCoordinate + (coordinate : Coordinate) (input : HashInput) : ∀ slot coordinates, + PreservesCoordinate coordinate (probeFirstMissingInputCoordinate input slot coordinates) + | _, [] => preservesCoordinate_pure coordinate () + | slot, other :: remaining => by + rw [probeFirstMissingInputCoordinate] + exact ((rawReadOnly_peekCoordinate other).preservesCoordinate coordinate).bind fun value => + match value with + | none => preservesCoordinate_probe coordinate ⟨other, slotDigest slot input⟩ + | some _ => preservesCoordinate_probeFirstMissingInputCoordinate coordinate input + (slot + 1) remaining + +theorem preservesCoordinate_prepareLeafInputProbe + (coordinate : Coordinate) (input : HashInput) (candidate : Probe) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) : + PreservesCoordinate coordinate (prepareLeafInputProbe input candidate lay tree leafIdx) := by + unfold prepareLeafInputProbe + exact ((rawReadOnly_peekCoordinate candidate.coordinate).preservesCoordinate coordinate).bind + fun value => match value with + | none => preservesCoordinate_probe coordinate candidate + | some _ => preservesCoordinate_probeFirstMissingInputCoordinate coordinate input 0 _ + +theorem preservesCoordinateMaterializedPublished_resolveKnownInput_any + (parameter : PublicParameter) (coordinate other : Coordinate) (input : HashInput) : + PreservesCoordinateMaterializedPublished coordinate (resolveKnownInput parameter other input) := by + by_cases heq : coordinate = other + · subst other + exact preservesCoordinateMaterializedPublished_resolveKnownInput parameter coordinate input + · exact (preservesCoordinate_resolveKnownInput_of_ne parameter coordinate other input heq).to_materializedPublished + +theorem preservesCoordinateMaterializedPublished_probingHashQuery + (parameter : PublicParameter) (coordinate : Coordinate) (input : HashInput) : + PreservesCoordinateMaterializedPublished coordinate (probingHashQuery parameter input) := by + unfold probingHashQuery + cases decodeProbe? parameter input with + | some candidate => + cases decodePosition? parameter input with + | some position => + cases position with + | leaf lay tree leafIdx => + exact (preservesCoordinate_prepareLeafInputProbe coordinate input candidate lay tree + leafIdx).to_materializedPublished.bind fun _ => + preservesCoordinateMaterializedPublished_resolveKnownInput_any parameter coordinate _ input + | chain | node | ftsLeaf | ftsNode | ftsRoots => + exact (preservesCoordinate_probe coordinate candidate).to_materializedPublished.bind + fun _ => preservesCoordinateMaterializedPublished_resolveKnownInput_any parameter coordinate _ input + | none => + exact (preservesCoordinate_probe coordinate candidate).to_materializedPublished.bind + fun _ => preservesCoordinateMaterializedPublished_resolveKnownInput_any parameter coordinate _ input + | none => + cases decodePosition? parameter input with + | none => exact (preservesCoordinate_splitHashQuery coordinate (.ordinary input)).to_materializedPublished + | some position => + cases position with + | chain | leaf => exact preservesCoordinateMaterializedPublished_resolveKnownInput_any parameter coordinate _ input + | node lay tree level nodeIdx => + exact (preservesCoordinate_probeFirstMissingInputCoordinate coordinate input 0 + ((Position.node lay tree level nodeIdx).children.map Coordinate.position)).to_materializedPublished.bind + fun _ => preservesCoordinateMaterializedPublished_resolveKnownInput_any parameter coordinate _ input + | ftsLeaf | ftsNode | ftsRoots => + exact (preservesCoordinate_splitHashQuery coordinate (.ordinary input)).to_materializedPublished + +theorem preservesCoordinateMaterializedPublished_probingRomImpl + (parameter : PublicParameter) (coordinate : Coordinate) (query : OracleWorld.Domain) : + PreservesCoordinateMaterializedPublished coordinate (probingRomImpl parameter query) := by + cases query with + | inl n => + change PreservesCoordinateMaterializedPublished coordinate (splitUniformImpl n) + have h := preservesCoordinate_simulateQ_splitUniformImpl coordinate (liftM (unifSpec.query n) : ProbComp (Fin (n + 1))) + simpa [splitUniformImpl] using h.to_materializedPublished + | inr input => exact preservesCoordinateMaterializedPublished_probingHashQuery parameter coordinate input + +theorem evalDist_directBoundaryObserve_eq_flat_of_public + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (hpub : PreservesPublishedValuesImpl impl) + (hmat : ∀ query coordinate, PreservesCoordinateMaterializedPublished coordinate (impl query)) + (computation : OracleComp spec α) + (observe : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + (context : DeferredContext) (fuel : Nat) + (table : OtsSecretIndex → HashOutput) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) + (hcanonical : CanonicalMaterializedValues table context) : + evalDist (directBoundaryObserve impl computation observe context fuel table cache) = + evalDist (runDirectResolvedObserve observe context fuel table + ((simulateQ impl computation).run cache)) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + simp [directBoundaryObserve, runDirectResolvedObserve, runDirectResolvedFromTable] + | query_bind query next ih => + rw [directBoundaryObserve, OracleComp.construct_query_bind, simulateQ_query_bind, + StateT.run_bind] + unfold runDirectResolvedObserve + rw [runDirectResolvedFromTable_bind_general, bind_assoc] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => simp + | some result => + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable + ((impl query).run cache) context fuel table result hconsistent hstarts hresult + have hraw := raw_done_of_mem_runDirectResolvedFromTable + ((impl query).run cache) context fuel table result hresult + have hnextPub := hpub query context.state cache fuel result.context.state + result.remaining result.value.1 result.value.2 hpublished hraw + have hnextMat : ∀ coordinate, + CoordinateMaterializedPublished coordinate result.context.state := by + intro coordinate + exact hmat query coordinate context.state cache fuel result.context.state + result.remaining result.value.1 result.value.2 + (hcanonical.materializedPublished coordinate) hraw + have hnextCanonical := canonicalMaterializedValues_of_published table result.context + hcore.2.2 hnextPub hnextMat + simp only [finishObserve, canonicalizeObserve, hnextPub, ↓reduceIte, + hnextCanonical.canonicalize_eq, hcore.1] + exact ih result.value.1 result.context result.remaining result.value.2 + hcore.2.1 hcore.2.2 hnextPub hnextCanonical + +theorem evalDist_directBoundaryObserve_eq_of_canonical + (impl : QueryImpl spec + (StateT SplitHashCache (OracleComp (LazyRevealProbe.World Coordinate)))) + (computation : OracleComp spec α) + (left right : DeferredContext → Nat → (α × SplitHashCache) → ProbComp Bool) + (heq : ∀ context fuel value, + context.ValuesConsistent → StartTableAgrees context.state table → + PublishedValues context.state → CanonicalMaterializedValues table context → + evalDist (left context fuel value) = evalDist (right context fuel value)) + (context : DeferredContext) (fuel : Nat) (cache : SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) + (hcanonical : CanonicalMaterializedValues table context) : + evalDist (directBoundaryObserve impl computation left context fuel table cache) = + evalDist (directBoundaryObserve impl computation right context fuel table cache) := by + induction computation using OracleComp.inductionOn generalizing context fuel cache with + | pure value => + rw [directBoundaryObserve, OracleComp.construct_pure, + directBoundaryObserve, OracleComp.construct_pure] + exact heq context fuel (value, cache) hconsistent hstarts hpublished hcanonical + | query_bind query next ih => + rw [directBoundaryObserve, OracleComp.construct_query_bind, + directBoundaryObserve, OracleComp.construct_query_bind] + apply evalDist_bind_congr + intro result hresult + cases result with + | none => rfl + | some result => + have hcore := resolvedCore_of_mem_runDirectResolvedFromTable + ((impl query).run cache) context fuel table result hconsistent hstarts hresult + unfold finishObserve canonicalizeObserve + by_cases hnextPub : PublishedValues result.context.state + · simp only [hnextPub, ↓reduceIte] + exact ih result.value.1 (canonicalizeMaterializedValues table result.context) + result.remaining result.value.2 + (canonicalizeMaterializedValues_valuesConsistent table result.context hcore.2.1) + (canonicalizeMaterializedValues_startTableAgrees table result.context) + hnextPub.to_canonicalizedMaterializedValues + (canonicalizeMaterializedValues_canonical table result.context hcore.2.1) + · simp [hnextPub] + +theorem evalDist_granularVerifierFinishObserve_eq_direct + (parameter : PublicParameter) (root : Digest) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) + (value : (Forgery × QueryLog SigningSpec) × SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) + (hcanonical : CanonicalMaterializedValues table context) : + evalDist (granularVerifierFinishObserve parameter root table ftsSecret context fuel value) = + evalDist (directVerifierFinishObserve table parameter root context fuel value) := by + rw [granularVerifierFinishObserve_eq_body, directVerifierFinishObserve_eq_body] + exact evalDist_directBoundaryObserve_eq_flat_of_public (probingRomImpl parameter) + (preservesPublishedValuesImpl_probingRomImpl parameter) + (fun query coordinate => preservesCoordinateMaterializedPublished_probingRomImpl parameter coordinate query) + _ _ context fuel table value.2 hconsistent hstarts hpublished hcanonical + +theorem evalDist_granularRetainedRestObserve_eq_allDirect + (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (context : DeferredContext) (fuel : Nat) (value : Digest × SplitHashCache) + (hconsistent : context.ValuesConsistent) + (hstarts : StartTableAgrees context.state table) + (hpublished : PublishedValues context.state) + (hcanonical : CanonicalMaterializedValues table context) : + evalDist (granularRetainedRestObserve adversary parameter table ftsSecret context fuel value) = + evalDist (allDirectRetainedRestObserve adversary parameter table ftsSecret context fuel value) := by + unfold granularRetainedRestObserve retainedGameRestComputation + rw [directBoundaryObserve_bind] + change evalDist (directBoundaryObserve _ _ + (granularVerifierFinishObserve parameter value.1 table ftsSecret) context fuel table value.2) = _ + exact evalDist_directBoundaryObserve_eq_of_canonical _ _ _ _ + (fun nextContext remaining nextValue hc hs hp hk => + evalDist_granularVerifierFinishObserve_eq_direct parameter value.1 table ftsSecret + nextContext remaining nextValue hc hs hp hk) + context fuel value.2 hconsistent hstarts hpublished hcanonical + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OtsProbeWeightedReserve.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeWeightedReserve.lean new file mode 100644 index 00000000..42b9a195 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeWeightedReserve.lean @@ -0,0 +1,255 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalWeightedCharge + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec ENNReal +open OracleComp.ProgramLogic.Relational + +attribute [local irreducible] maskedPublishedTreeRoot + +noncomputable def canonicalChargeAfterTable + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : ℝ≥0∞ := + ∑' result, Pr[= result | runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)] * + match result with + | none => 0 + | some result => expectedCanonicalQueryCharge parameter result.value.1 ftsSecret + charge + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining table result.value.2 + +set_option maxRecDepth 100000 in +theorem canonicalChargeAfterTable_le_gameReserve + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (adversary : Adversary) (parameter : PublicParameter) (table : OtsSecretIndex → HashOutput) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) + (hcharge : ∀ input context remaining cache, + charge input context remaining cache ≤ canonicalOtsOuterCharge parameter input context remaining cache) : + canonicalChargeAfterTable charge adversary parameter table ftsSecret fuel ≤ + expectedQueryCharge (otsOpeningRefinedQueryReserve + (primitiveAccountingKey parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret)) + (gameAfterSecrets adversary parameter + (fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩)) ftsSecret) ∅ := by + let otsSecret := fun lay tree leafIdx chainIdx => truncateHash (table ⟨lay, tree, leafIdx, chainIdx⟩) + let accountingKey := primitiveAccountingKey parameter otsSecret ftsSecret + let actualCost := fun result : Digest × QueryCache HashSpec => + expectedQueryCharge (otsOpeningRefinedQueryReserve accountingKey) + (gameRest scheme adversary ⟨result.1, parameter⟩ ⟨parameter, result.1, otsSecret, ftsSecret⟩) result.2 + have hroot := reachableResolvedCouples_maskedPublishedTreeRoot parameter table + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel emptySplitHashCache ∅ (resolvedContextInvariant_empty parameter table) + (visibleResolvedComputationsCached_empty parameter table emptyDeferredStructuralValues ∅) publishedValues_empty + have hsupported := FtsProbeSimulation.relTriple_and_left_support hroot + (fun left => ∀ result, left = some result → DeferredComputationsClosed result.context) (by + intro left hleft result heq + subst left + exact deferredComputationsClosed_empty.of_mem_runResolved _ _ fuel table result hleft) + have hcost : canonicalChargeAfterTable charge adversary parameter table ftsSecret fuel ≤ + ∑' result, Pr[= result | (simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅] * actualCost result := by + have hbound := expected_cost_le_of_relTriple hsupported + (fun left => match left with + | none => 0 + | some result => expectedCanonicalQueryCharge parameter result.value.1 ftsSecret + charge + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining table result.value.2) + actualCost (fun _ => 0) (by + intro left right hrelation + simp only [add_zero] + cases left with + | none => exact bot_le + | some result => + dsimp only + rcases hrelation.1 with hclean | hdoomed + · have hcomputed := hrelation.2 result rfl + have hlocal := (expectedCanonicalQueryCharge_mono parameter result.value.1 ftsSecret charge + (canonicalOtsOuterCharge parameter) hcharge + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining table result.value.2).trans + (expectedCanonicalOtsCharge_le_actualReserve parameter result.value.1 table ftsSecret + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining result.value.2 right.2 hclean.2.2.1 + hclean.2.2.2.1 hclean.2.2.2.2 hcomputed) + have hreserve : otsOpeningRefinedQueryReserve + (⟨parameter, result.value.1, otsSecret, ftsSecret⟩ : SecretKey) = + otsOpeningRefinedQueryReserve accountingKey := + otsOpeningRefinedQueryReserve_set_root accountingKey result.value.1 + rw [hreserve, expectedQueryCharge_retained_eq_gameRest] at hlocal + simpa only [actualCost, ← hclean.2.1] using hlocal + · rw [expectedCanonicalQueryCharge_eq_zero_of_not_completable parameter result.value.1 ftsSecret + charge + (retainedGameRestComputation adversary ⟨result.value.1, parameter⟩) + result.context result.remaining table result.value.2 hdoomed.2.2.2] + exact bot_le) + simpa only [canonicalChargeAfterTable, treeRoot, otsSecret, mul_zero, tsum_zero, add_zero] using hbound + apply hcost.trans + change _ ≤ expectedQueryCharge (otsOpeningRefinedQueryReserve accountingKey) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ + rw [gameAfterSecrets, expectedQueryCharge_bind, simulateQ_romImpl_liftM] + exact le_add_self + +noncomputable def sampledCanonicalCharge + (charge : PublicParameter → (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (adversary : Adversary) (fuel : Nat) : ENNReal := + ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' table, Pr[= table | sampleOtsHashTable] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + canonicalChargeAfterTable (charge parameter) adversary parameter table ftsSecret fuel + +theorem sampledCanonicalCharge_le_refinedReserve + (charge : PublicParameter → (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (adversary : Adversary) (fuel : Nat) + (hcharge : ∀ parameter input context remaining cache, + charge parameter input context remaining cache ≤ canonicalOtsOuterCharge parameter input context remaining cache) : + sampledCanonicalCharge charge adversary fuel ≤ sampledQueryCharge otsOpeningRefinedQueryReserve adversary := by + unfold sampledCanonicalCharge sampledQueryCharge + simp only [sampleSecrets, tsum_probOutput_bind_mul, tsum_probOutput_pure_mul] + apply ENNReal.tsum_le_tsum + intro parameter + apply mul_le_mul' le_rfl + have hcoupled := expected_cost_le_of_relTriple relTriple_uniformOtsHashTable_sampleOtsSecrets + (fun table => ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + canonicalChargeAfterTable (charge parameter) adversary parameter table ftsSecret fuel) + (fun otsSecret => ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + expectedQueryCharge (otsOpeningRefinedQueryReserve (primitiveAccountingKey parameter otsSecret ftsSecret)) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅) + (fun _ => 0) (by + intro table otsSecret hsecrets + simp only [add_zero] + rw [← hsecrets] + apply ENNReal.tsum_le_tsum + intro ftsSecret + exact mul_le_mul' le_rfl (canonicalChargeAfterTable_le_gameReserve (charge parameter) + adversary parameter table ftsSecret fuel (hcharge parameter))) + simpa only [sampleOtsHashTable, mul_zero, tsum_zero, add_zero] using hcoupled + +noncomputable def sampledCanonicalWeightedCharge (adversary : Adversary) (fuel : Nat) : ENNReal := + sampledCanonicalCharge canonicalWeightedOuterCharge adversary fuel + +theorem sampledCanonicalWeightedCharge_le_refinedReserve (adversary : Adversary) (fuel : Nat) : + sampledCanonicalWeightedCharge adversary fuel ≤ sampledQueryCharge otsOpeningRefinedQueryReserve adversary := + sampledCanonicalCharge_le_refinedReserve canonicalWeightedOuterCharge adversary fuel canonicalWeightedOuterCharge_le_ots + +theorem sampledCanonicalComponentCharge_le_refinedReserve (adversary : Adversary) (fuel : Nat) : + sampledCanonicalCharge canonicalComponentOuterCharge adversary fuel ≤ sampledQueryCharge otsOpeningRefinedQueryReserve adversary := by + apply sampledCanonicalCharge_le_refinedReserve + intro parameter input context remaining cache + exact (canonicalComponentOuterCharge_le_weighted parameter input context remaining cache).trans + (canonicalWeightedOuterCharge_le_ots parameter input context remaining cache) + +theorem sampledCanonicalCharge_add + (left right : PublicParameter → (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (adversary : Adversary) (fuel : Nat) : + sampledCanonicalCharge (fun parameter input context fuel cache => left parameter input context fuel cache + + right parameter input context fuel cache) adversary fuel = + sampledCanonicalCharge left adversary fuel + sampledCanonicalCharge right adversary fuel := by + simp only [sampledCanonicalCharge, canonicalChargeAfterTable] + rw [← ENNReal.tsum_add] + apply tsum_congr + intro parameter + rw [← mul_add, ← ENNReal.tsum_add] + congr 1 + apply tsum_congr + intro table + rw [← mul_add, ← ENNReal.tsum_add] + congr 1 + apply tsum_congr + intro ftsSecret + rw [← mul_add, ← ENNReal.tsum_add] + congr 1 + apply tsum_congr + intro option + cases option with + | none => simp + | some result => + dsimp only + rw [expectedCanonicalQueryCharge_add, mul_add] + +theorem sampledCanonicalCharge_mul + (charge : PublicParameter → (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (factor : ENNReal) (adversary : Adversary) (fuel : Nat) : + sampledCanonicalCharge (fun parameter input context fuel cache => charge parameter input context fuel cache * factor) adversary fuel = + sampledCanonicalCharge charge adversary fuel * factor := by + simp only [sampledCanonicalCharge, canonicalChargeAfterTable] + rw [← ENNReal.tsum_mul_right] + apply tsum_congr + intro parameter + rw [mul_assoc, ← ENNReal.tsum_mul_right] + congr 1 + apply tsum_congr + intro table + rw [mul_assoc, ← ENNReal.tsum_mul_right] + congr 1 + apply tsum_congr + intro ftsSecret + rw [mul_assoc, ← ENNReal.tsum_mul_right] + congr 1 + apply tsum_congr + intro option + cases option with + | none => simp + | some result => + dsimp only + rw [expectedCanonicalQueryCharge_mul, mul_assoc] + +theorem sampledCanonical_components_le_refinedReserve (adversary : Adversary) (fuel : Nat) : + sampledCanonicalCharge unresolvedStartOuterCharge adversary fuel * (4 / 3) + + sampledCanonicalCharge unresolvedPositionOuterCharge adversary fuel + + sampledCanonicalCharge materializedOuterCandidateCharge adversary fuel * (4 / 3) ≤ + sampledQueryCharge otsOpeningRefinedQueryReserve adversary := by + have hbound := sampledCanonicalComponentCharge_le_refinedReserve adversary fuel + change sampledCanonicalCharge (fun parameter input context remaining cache => + unresolvedStartOuterCharge parameter input context remaining cache * (4 / 3) + + unresolvedPositionOuterCharge parameter input context remaining cache + + materializedOuterCandidateCharge parameter input context remaining cache * (4 / 3)) adversary fuel ≤ _ at hbound + rw [sampledCanonicalCharge_add, sampledCanonicalCharge_add, sampledCanonicalCharge_mul, sampledCanonicalCharge_mul] at hbound + exact hbound + +theorem sampledCanonicalAccumulatedCharge_retained_eq + (charge : (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (adversary : Adversary) (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + sampledCanonicalAccumulatedCharge parameter ftsSecret fuel + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩) charge = + ∑' table, Pr[= table | sampleOtsHashTable] * canonicalChargeAfterTable charge adversary parameter table ftsSecret fuel := by + unfold sampledCanonicalAccumulatedCharge canonicalChargeAfterTable + apply tsum_congr + intro table + congr 1 + apply tsum_congr + intro option + by_cases hsupport : option ∈ support (runResolvedFromTable + { state := LazyRevealProbe.State.empty, values := emptyDeferredStructuralValues } + fuel table (maskedPublishedTreeRoot.run emptySplitHashCache)) + · cases option with + | none => rfl + | some result => + dsimp only + rw [(resolvedCore_of_mem_runResolved_maskedPublishedTreeRoot parameter table fuel result hsupport).1] + · simp [probOutput_eq_zero_of_not_mem_support hsupport] + +theorem sampledCanonicalCharge_eq_accumulated + (charge : PublicParameter → (OracleWorld + SigningSpec).Domain → DeferredContext → Nat → SplitHashCache → ENNReal) + (adversary : Adversary) (fuel : Nat) : + sampledCanonicalCharge charge adversary fuel = + ∑' parameter, Pr[= parameter | sampleParameter] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + sampledCanonicalAccumulatedCharge parameter ftsSecret fuel + (fun root => retainedGameRestComputation adversary ⟨root, parameter⟩) (charge parameter) := by + simp only [sampledCanonicalCharge, sampledCanonicalAccumulatedCharge_retained_eq] + apply tsum_congr + intro parameter + congr 1 + simp_rw [← ENNReal.tsum_mul_left] + rw [ENNReal.tsum_comm] + apply tsum_congr + intro ftsSecret + apply tsum_congr + intro table + ring + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OuterHashQueryCut.lean b/formal/sphincs/SphincsSecurity/Proof/OuterHashQueryCut.lean new file mode 100644 index 00000000..3f1013ab --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OuterHashQueryCut.lean @@ -0,0 +1,68 @@ +import SphincsSecurity.Proof.OuterQueryCut + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +attribute [local instance] Classical.propDecidable +set_option backward.isDefEq.respectTransparency false + +noncomputable def outerHashQueryCutAt (computation : OracleComp (OracleWorld + SigningSpec) α) : + Nat → OracleComp (OracleWorld + SigningSpec) (OuterQueryCut α) := + OracleComp.construct (fun value _ => pure (.done value)) + (fun input next recursivelyCut ordinal => + if IsOuterHash input then + match ordinal with + | 0 => pure (.query input next) + | ordinal + 1 => (liftM (OracleSpec.query input) : OracleComp (OracleWorld + SigningSpec) _) >>= fun output => recursivelyCut output ordinal + else (liftM (OracleSpec.query input) : OracleComp (OracleWorld + SigningSpec) _) >>= fun output => recursivelyCut output ordinal) computation + +theorem outerHashQueryCutAt_query_bind + (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) : + outerHashQueryCutAt ((liftM (OracleSpec.query input) : OracleComp (OracleWorld + SigningSpec) _) >>= next) ordinal = + (if IsOuterHash input then + match ordinal with + | 0 => pure (.query input next) + | ordinal + 1 => (liftM (OracleSpec.query input) : OracleComp (OracleWorld + SigningSpec) _) >>= fun output => outerHashQueryCutAt (next output) ordinal + else (liftM (OracleSpec.query input) : OracleComp (OracleWorld + SigningSpec) _) >>= fun output => outerHashQueryCutAt (next output) ordinal) := by + rfl + +theorem outerHashQueryCutAt_resume (computation : OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) : + outerHashQueryCutAt computation ordinal >>= OuterQueryCut.resume = computation := by + induction computation using OracleComp.inductionOn generalizing ordinal with + | pure value => rfl + | query_bind input next ih => + rw [outerHashQueryCutAt_query_bind] + split_ifs + · cases ordinal with + | zero => rfl + | succ ordinal => + rw [bind_assoc] + exact bind_congr fun output => ih output ordinal + · rw [bind_assoc] + exact bind_congr fun output => ih output ordinal + +theorem outerHashQueryCutAt_hashBound (computation : OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) : + (outerHashQueryCutAt computation ordinal).IsQueryBoundP IsOuterHash ordinal := by + induction computation using OracleComp.inductionOn generalizing ordinal with + | pure value => simp [outerHashQueryCutAt] + | query_bind input next ih => + rw [outerHashQueryCutAt_query_bind] + by_cases hhash : IsOuterHash input + · rw [if_pos hhash] + cases ordinal with + | zero => simp + | succ ordinal => + rw [OracleComp.isQueryBoundP_query_bind_iff] + exact ⟨Or.inr (by omega), fun output => by simpa only [if_pos hhash, Nat.add_sub_cancel] using ih output ordinal⟩ + · rw [if_neg hhash, OracleComp.isQueryBoundP_query_bind_iff] + exact ⟨Or.inl hhash, fun output => by simpa only [if_neg hhash] using ih output ordinal⟩ + +noncomputable def hashCutCandidate (parameter : PublicParameter) (context : DeferredContext) + (result : OuterQueryCut α × SplitHashCache) : Option Probe := + match result.1.input? with + | some (.inl (.inr input)) => (purePlanProbingHashQuery parameter input context.state).candidate? + | _ => none + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/OuterQueryCut.lean b/formal/sphincs/SphincsSecurity/Proof/OuterQueryCut.lean new file mode 100644 index 00000000..029d8886 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OuterQueryCut.lean @@ -0,0 +1,77 @@ +import SphincsSecurity.Proof.OtsProbeCanonicalSelectionCoupling + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open OracleComp OracleSpec + +inductive OuterQueryCut (α : Type) where + | done (value : α) + | query (input : (OracleWorld + SigningSpec).Domain) + (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) + +def OuterQueryCut.resume : OuterQueryCut α → OracleComp (OracleWorld + SigningSpec) α + | .done value => pure value + | .query input next => OracleSpec.query input >>= next + +def OuterQueryCut.input? : OuterQueryCut α → Option (OracleWorld + SigningSpec).Domain + | .done _ => none + | .query input _ => some input + +noncomputable def outerQueryCutAt (computation : OracleComp (OracleWorld + SigningSpec) α) : + Nat → OracleComp (OracleWorld + SigningSpec) (OuterQueryCut α) := + OracleComp.construct (fun value _ => pure (.done value)) + (fun input next recursivelyCut ordinal => + match ordinal with + | 0 => pure (.query input next) + | ordinal + 1 => OracleSpec.query input >>= fun output => recursivelyCut output ordinal) computation + +theorem outerQueryCutAt_resume (computation : OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) : + outerQueryCutAt computation ordinal >>= OuterQueryCut.resume = computation := by + induction computation using OracleComp.inductionOn generalizing ordinal with + | pure value => rfl + | query_bind input next ih => + cases ordinal with + | zero => rfl + | succ ordinal => + change (((liftM (OracleSpec.query input) : OracleComp (OracleWorld + SigningSpec) _) >>= + fun output => outerQueryCutAt (next output) ordinal) >>= + OuterQueryCut.resume) = _ + rw [bind_assoc] + exact bind_congr fun output => ih output ordinal + +theorem actualQuerySelection_eq_cut_projection + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) α) + (ordinal : Nat) (cache : QueryCache HashSpec) : + actualQuerySelection secretKey computation ordinal cache = + (fun result : OuterQueryCut α × QueryCache HashSpec => + result.1.input?.map (fun input => (⟨input, result.2⟩ : ActualQuerySelection))) <$> + (simulateQ (unloggedMappedAdversaryImpl secretKey) (outerQueryCutAt computation ordinal)).run cache := by + induction computation using OracleComp.inductionOn generalizing ordinal cache with + | pure value => simp [actualQuerySelection, outerQueryCutAt, OuterQueryCut.input?] + | query_bind input next ih => + cases ordinal with + | zero => simp [actualQuerySelection, outerQueryCutAt, OuterQueryCut.input?] + | succ ordinal => + change ((unloggedMappedAdversaryImpl secretKey input).run cache >>= fun result => + actualQuerySelection secretKey (next result.1) ordinal result.2) = _ + rw [outerQueryCutAt, OracleComp.construct_query_bind] + simp only [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, map_bind] + exact bind_congr fun result => ih result.1 ordinal result.2 + +theorem mem_support_run_cut_resume_iff + (impl : QueryImpl (OracleWorld + SigningSpec) (StateT σ ProbComp)) + (computation : OracleComp (OracleWorld + SigningSpec) α) (ordinal : Nat) + (initialState : σ) (result : α × σ) : + result ∈ support ((simulateQ impl computation).run initialState) ↔ + ∃ cut : OuterQueryCut α, ∃ middleState : σ, + (cut, middleState) ∈ support ((simulateQ impl (outerQueryCutAt computation ordinal)).run initialState) ∧ + result ∈ support ((simulateQ impl cut.resume).run middleState) := by + conv_lhs => rw [← outerQueryCutAt_resume computation ordinal] + rw [simulateQ_bind, StateT.run_bind, mem_support_bind_iff] + constructor + · rintro ⟨⟨cut, state⟩, hprefix, hsuffix⟩ + exact ⟨cut, state, hprefix, hsuffix⟩ + · rintro ⟨cut, state, hprefix, hsuffix⟩ + exact ⟨(cut, state), hprefix, hsuffix⟩ + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/Position.lean b/formal/sphincs/SphincsSecurity/Proof/Position.lean new file mode 100644 index 00000000..fba0805d --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Position.lean @@ -0,0 +1,311 @@ +import SphincsSecurity.Proof.Bytes +import Mathlib.Tactic.DeriveFintype + +/-! +# The positions of the honest key + +Six of the eight hash domains name a structural position: a chain step, a one-time leaf, a node of a +layer's tree, a few-time leaf, a node of a few-time tree, and the hash of a forest's roots. Each has +one honest payload, built from the honest values at the positions below it, and the tweak determines +which position it is. The message digest and the encoding are the two that name none: their payload +is not a function of the key, and no honest value is defined at them. + +`Position` is that index set, made finite by keeping the level and index fields inside the widths the +instance uses rather than in `Nat`. It over-approximates: a node above a short layer's root is a +position here and has no honest meaning, which costs nothing since every statement about positions is +either an inclusion or a count. What matters is that `parentOf` and `children` agree, since the +accounting charges a position's settling to its parent, and that no position has two parents. +-/ + +namespace SphincsSecurity + +open OracleComp + +/-- A structural position of the honest key. A `node` at `level` is the node of actual level +`level + 1`, the leaves being the `leaf` positions; likewise for `ftsNode`. -/ +inductive Position where + | chain (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (chainIdx : ChainIndex) + (step : ChainStep) + | leaf (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + | node (lay : Layer) (tree : TreeIndex) (level : Fin maxLayerHeight) (nodeIdx : LeafIndex) + | ftsLeaf (index : Index) (tree : FtsTree) (leafIdx : FtsLeaf) + | ftsNode (index : Index) (tree : FtsTree) (level : Fin ftsTreeHeight) (nodeIdx : FtsLeaf) + | ftsRoots (index : Index) + deriving DecidableEq, Fintype + +namespace Position + +/-- The hash domain a position is hashed at. -/ +def domain : Position → HashDomain + | .chain lay tree leafIdx chainIdx step => HashDomain.chain lay tree leafIdx chainIdx step + | .leaf lay tree leafIdx => HashDomain.leaf lay tree leafIdx + | .node lay tree level nodeIdx => HashDomain.node lay tree (level.val + 1) nodeIdx.val + | .ftsLeaf index tree leafIdx => HashDomain.ftsLeaf index tree leafIdx + | .ftsNode index tree level nodeIdx => HashDomain.ftsNode index tree (level.val + 1) nodeIdx.val + | .ftsRoots index => HashDomain.ftsRoots index + +theorem domain_inRange (p : Position) : p.domain.InRange := by + cases p with + | node lay tree level nodeIdx => + have hlevel := level.isLt + have hnode := nodeIdx.isLt + simp only [maxLayerHeight] at hlevel hnode + show level.val + 1 < 2 ^ 32 ∧ nodeIdx.val < 2 ^ 32 + exact ⟨by omega, by omega⟩ + | ftsNode index tree level nodeIdx => + have hlevel := level.isLt + have hnode := nodeIdx.isLt + simp only [ftsTreeHeight] at hlevel hnode + show level.val + 1 < 2 ^ 32 ∧ nodeIdx.val < 2 ^ 32 + exact ⟨by omega, by omega⟩ + | chain => exact (trivial : True) + | leaf => exact (trivial : True) + | ftsLeaf => exact (trivial : True) + | ftsRoots => exact (trivial : True) + +theorem domain_injective {p q : Position} (h : p.domain = q.domain) : p = q := by + cases p <;> cases q <;> simp only [domain] at h <;> simp_all [Fin.ext_iff] + +/-- The position whose payload the value at this one enters, if there is one. A layer's root feeds +the message the layer above signs, and a forest's root hash feeds the message the bottom layer signs, +neither of which is a position. -/ +def parentOf : Position → Option Position + | .chain lay tree leafIdx chainIdx step => + if h : step.val + 1 < chainLength - 1 then + some (.chain lay tree leafIdx chainIdx ⟨step.val + 1, h⟩) + else some (.leaf lay tree leafIdx) + | .leaf lay tree leafIdx => + some (.node lay tree ⟨0, by decide⟩ ⟨leafIdx.val / 2, by have := leafIdx.isLt; omega⟩) + | .node lay tree level nodeIdx => + if h : level.val + 1 < maxLayerHeight then + some (.node lay tree ⟨level.val + 1, h⟩ + ⟨nodeIdx.val / 2, by have := nodeIdx.isLt; omega⟩) + else none + | .ftsLeaf index tree leafIdx => + some (.ftsNode index tree ⟨0, by decide⟩ ⟨leafIdx.val / 2, by have := leafIdx.isLt; omega⟩) + | .ftsNode index tree level nodeIdx => + if h : level.val + 1 < ftsTreeHeight then + some (.ftsNode index tree ⟨level.val + 1, h⟩ + ⟨nodeIdx.val / 2, by have := nodeIdx.isLt; omega⟩) + else if nodeIdx.val = 0 then some (.ftsRoots index) else none + | .ftsRoots _ => none + +/-- The last chain step, the one whose answer is the chain's endpoint. -/ +def lastChainStep : ChainStep := ⟨chainLength - 2, by decide⟩ + +/-- The positions whose values the payload at this one is built from. -/ +def children : Position → List Position + | .chain lay tree leafIdx chainIdx step => + if h : 0 < step.val then [.chain lay tree leafIdx chainIdx ⟨step.val - 1, by omega⟩] else [] + | .leaf lay tree leafIdx => + List.ofFn fun chainIdx : ChainIndex => .chain lay tree leafIdx chainIdx lastChainStep + | .node lay tree level nodeIdx => + if hidx : 2 * nodeIdx.val + 1 < 2 ^ maxLayerHeight then + if hlevel : 0 < level.val then + [.node lay tree ⟨level.val - 1, by omega⟩ ⟨2 * nodeIdx.val, by omega⟩, + .node lay tree ⟨level.val - 1, by omega⟩ ⟨2 * nodeIdx.val + 1, by omega⟩] + else + [.leaf lay tree ⟨2 * nodeIdx.val, by omega⟩, + .leaf lay tree ⟨2 * nodeIdx.val + 1, by omega⟩] + else [] + | .ftsLeaf _ _ _ => [] + | .ftsNode index tree level nodeIdx => + if hidx : 2 * nodeIdx.val + 1 < 2 ^ ftsTreeHeight then + if hlevel : 0 < level.val then + [.ftsNode index tree ⟨level.val - 1, by omega⟩ ⟨2 * nodeIdx.val, by omega⟩, + .ftsNode index tree ⟨level.val - 1, by omega⟩ ⟨2 * nodeIdx.val + 1, by omega⟩] + else + [.ftsLeaf index tree ⟨2 * nodeIdx.val, by omega⟩, + .ftsLeaf index tree ⟨2 * nodeIdx.val + 1, by omega⟩] + else [] + | .ftsRoots index => + List.ofFn fun tree : FtsTree => + .ftsNode index tree ⟨ftsTreeHeight - 1, by decide⟩ ⟨0, by positivity⟩ + +/-- The widest payload of the instance is a one-time leaf's `v = 42` chain endpoints. -/ +theorem children_length_le (p : Position) : p.children.length ≤ numChains := by + cases p <;> simp only [children] <;> (try split_ifs) <;> simp [numChains, ftsTrees] + +/-! ### Children and parent agree + +No position has two parents, which is what keeps the accounting's charge on a position's settling +from being paid twice, and every child of a position is charged there. -/ + +private theorem chainLength_eq : chainLength = 8 := rfl + +private theorem two_pow_maxLayerHeight : (2 : Nat) ^ maxLayerHeight = 4096 := by + norm_num [maxLayerHeight] + +private theorem two_pow_ftsTreeHeight : (2 : Nat) ^ ftsTreeHeight = 1024 := by + norm_num [ftsTreeHeight] + +theorem mem_children_iff {c d : Position} : c ∈ d.children ↔ parentOf c = some d := by + have hchain := chainLength_eq + have hmax := two_pow_maxLayerHeight + have hfts := two_pow_ftsTreeHeight + constructor + · intro hmem + cases d with + | chain lay tree leafIdx chainIdx step => + have hlt := step.isLt + simp only [children] at hmem + split_ifs at hmem with hstep + · rw [List.mem_singleton] at hmem + subst hmem + rw [parentOf, dif_pos (show step.val - 1 + 1 < chainLength - 1 by omega)] + simp only [Option.some.injEq, chain.injEq, Fin.ext_iff, true_and] + omega + · simp at hmem + | leaf lay tree leafIdx => + simp only [children, List.mem_ofFn] at hmem + obtain ⟨chainIdx, hmem⟩ := hmem + subst hmem + rw [parentOf, dif_neg (show ¬ (lastChainStep.val + 1 < chainLength - 1) by + simp only [lastChainStep]; omega)] + | node lay tree level nodeIdx => + have hlt := level.isLt + have hidxlt := nodeIdx.isLt + simp only [children] at hmem + split_ifs at hmem with hidx hlevel + · rcases List.mem_pair.mp hmem with h | h <;> subst h <;> + rw [parentOf, dif_pos (show level.val - 1 + 1 < maxLayerHeight by omega)] <;> + simp only [Option.some.injEq, node.injEq, Fin.ext_iff, true_and] <;> omega + · rcases List.mem_pair.mp hmem with h | h <;> subst h <;> rw [parentOf] <;> + simp only [Option.some.injEq, node.injEq, Fin.ext_iff, true_and] <;> omega + · simp at hmem + | ftsLeaf => simp [children] at hmem + | ftsNode index tree level nodeIdx => + have hlt := level.isLt + have hidxlt := nodeIdx.isLt + simp only [children] at hmem + split_ifs at hmem with hidx hlevel + · rcases List.mem_pair.mp hmem with h | h <;> subst h <;> + rw [parentOf, dif_pos (show level.val - 1 + 1 < ftsTreeHeight by omega)] <;> + simp only [Option.some.injEq, ftsNode.injEq, Fin.ext_iff, true_and] <;> omega + · rcases List.mem_pair.mp hmem with h | h <;> subst h <;> rw [parentOf] <;> + simp only [Option.some.injEq, ftsNode.injEq, Fin.ext_iff, true_and] <;> omega + · simp at hmem + | ftsRoots index => + simp only [children, List.mem_ofFn] at hmem + obtain ⟨tree, hmem⟩ := hmem + subst hmem + rw [parentOf, dif_neg (show ¬ (ftsTreeHeight - 1 + 1 < ftsTreeHeight) by + simp only [ftsTreeHeight]; omega), if_pos rfl] + · intro hparent + cases c with + | chain lay tree leafIdx chainIdx step => + have hlt := step.isLt + rw [parentOf] at hparent + split_ifs at hparent with hstep + · rw [Option.some.injEq] at hparent + subst hparent + rw [children, dif_pos (show 0 < step.val + 1 by omega), List.mem_singleton] + simp only [chain.injEq, Fin.ext_iff, true_and] + omega + · rw [Option.some.injEq] at hparent + subst hparent + simp only [children, List.mem_ofFn] + refine ⟨chainIdx, ?_⟩ + simp only [chain.injEq, Fin.ext_iff, lastChainStep, true_and] + omega + | leaf lay tree leafIdx => + have hlt := leafIdx.isLt + rw [parentOf, Option.some.injEq] at hparent + subst hparent + rw [children, dif_pos (show 2 * (leafIdx.val / 2) + 1 < 2 ^ maxLayerHeight by omega), + dif_neg (by simp)] + refine List.mem_pair.mpr ?_ + by_cases heven : leafIdx.val % 2 = 0 + · exact Or.inl (by simp only [leaf.injEq, Fin.ext_iff, true_and]; omega) + · exact Or.inr (by simp only [leaf.injEq, Fin.ext_iff, true_and]; omega) + | node lay tree level nodeIdx => + have hlt := nodeIdx.isLt + rw [parentOf] at hparent + split_ifs at hparent with hlevel + · rw [Option.some.injEq] at hparent + subst hparent + rw [children, dif_pos (show 2 * (nodeIdx.val / 2) + 1 < 2 ^ maxLayerHeight by omega), + dif_pos (show 0 < level.val + 1 by omega)] + refine List.mem_pair.mpr ?_ + by_cases heven : nodeIdx.val % 2 = 0 + · exact Or.inl (by simp only [node.injEq, Fin.ext_iff, true_and]; omega) + · exact Or.inr (by simp only [node.injEq, Fin.ext_iff, true_and]; omega) + | ftsLeaf index tree leafIdx => + have hlt := leafIdx.isLt + rw [parentOf, Option.some.injEq] at hparent + subst hparent + rw [children, dif_pos (show 2 * (leafIdx.val / 2) + 1 < 2 ^ ftsTreeHeight by omega), + dif_neg (by simp)] + refine List.mem_pair.mpr ?_ + by_cases heven : leafIdx.val % 2 = 0 + · exact Or.inl (by simp only [ftsLeaf.injEq, Fin.ext_iff, true_and]; omega) + · exact Or.inr (by simp only [ftsLeaf.injEq, Fin.ext_iff, true_and]; omega) + | ftsNode index tree level nodeIdx => + have hlt := nodeIdx.isLt + have hlevellt := level.isLt + rw [parentOf] at hparent + split_ifs at hparent with hlevel hzero + · rw [Option.some.injEq] at hparent + subst hparent + rw [children, dif_pos (show 2 * (nodeIdx.val / 2) + 1 < 2 ^ ftsTreeHeight by omega), + dif_pos (show 0 < level.val + 1 by omega)] + refine List.mem_pair.mpr ?_ + by_cases heven : nodeIdx.val % 2 = 0 + · exact Or.inl (by simp only [ftsNode.injEq, Fin.ext_iff, true_and]; omega) + · exact Or.inr (by simp only [ftsNode.injEq, Fin.ext_iff, true_and]; omega) + · rw [Option.some.injEq] at hparent + subst hparent + simp only [children, List.mem_ofFn] + refine ⟨tree, ?_⟩ + simp only [ftsNode.injEq, Fin.ext_iff, true_and] + simp only [ftsTreeHeight] at hlevel hlevellt ⊢ + omega + | ftsRoots => simp [parentOf] at hparent + +/-- A measure the payload recursion descends: a position's children are strictly below it. -/ +def depth : Position → Nat + | .chain _ _ _ _ step => step.val + | .leaf _ _ _ => chainLength + | .node _ _ level _ => chainLength + 1 + level.val + | .ftsLeaf _ _ _ => 0 + | .ftsNode _ _ level _ => 1 + level.val + | .ftsRoots _ => 1 + ftsTreeHeight + +theorem depth_lt_of_mem_children {c d : Position} (hmem : c ∈ d.children) : + c.depth < d.depth := by + cases d with + | chain lay tree leafIdx chainIdx step => + rw [children] at hmem + split at hmem + · rw [List.mem_singleton] at hmem + subst hmem + simp only [depth] + omega + · simp at hmem + | leaf => + simp only [children, List.mem_ofFn] at hmem + obtain ⟨chainIdx, hmem⟩ := hmem + subst hmem + simp [depth, lastChainStep, chainLength, winternitzBits] + | node lay tree level nodeIdx => + rw [children] at hmem + split at hmem + · split at hmem <;> rcases List.mem_pair.mp hmem with h | h <;> subst h <;> + simp only [depth] <;> omega + · simp at hmem + | ftsLeaf => simp [children] at hmem + | ftsNode index tree level nodeIdx => + rw [children] at hmem + split at hmem + · split at hmem <;> rcases List.mem_pair.mp hmem with h | h <;> subst h <;> + simp only [depth] <;> omega + · simp at hmem + | ftsRoots => + simp only [children, List.mem_ofFn] at hmem + obtain ⟨tree, hmem⟩ := hmem + subst hmem + simp [depth, ftsTreeHeight] + +end Position + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Queried.lean b/formal/sphincs/SphincsSecurity/Proof/Queried.lean new file mode 100644 index 00000000..70b08060 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Queried.lean @@ -0,0 +1,187 @@ +import SphincsSecurity.Proof.Support +import SphincsSecurity.Proof.ExtractFts +import SphincsSecurity.Proof.ExtractOts + +/-! +# Queries made by verification + +The deterministic extraction identifies a particular hash call inside a chain or fold. These lemmas +locate that call in the answer-function execution log used by the support bridge. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +variable (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + +theorem sequenceFin_component_query_mem {alpha : Type} {n : Nat} + (computation : Fin n → OracleComp HashSpec alpha) (index : Fin n) {input : HashInput} + (hinput : input ∈ queriedInputs f (computation index)) : + input ∈ queriedInputs f (sequenceFin computation) := by + induction n with + | zero => exact index.elim0 + | succ n ih => + cases index using Fin.cases with + | zero => + rw [sequenceFin] + exact queriedInputs_mono_bind_left f (computation 0) _ hinput + | succ index => + rw [sequenceFin] + apply queriedInputs_mono_bind_right f (computation 0) + apply queriedInputs_mono_bind_left + exact ih (fun index : Fin n => computation index.succ) index hinput + +theorem chainWalk_query_mem (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (start steps : Nat) (value : Digest) (offset : Nat) + (hoffset : offset < steps) (hrange : start + offset < chainLength - 1) : + tweakableHashInput parameter (.chain lay tree leafIdx chainIdx ⟨start + offset, hrange⟩) + (digestBytes (walkValue f parameter lay tree leafIdx chainIdx start value offset)) + ∈ queriedInputs f (chainWalk parameter lay tree leafIdx chainIdx start steps value) := by + induction steps generalizing offset with + | zero => omega + | succ steps ih => + rw [chainWalk] + split_ifs with hstep + · rw [queriedInputs_bind] + rcases Nat.lt_succ_iff_lt_or_eq.mp hoffset with hlt | heq + · exact List.mem_append_left _ (ih offset hlt hrange) + · subst offset + apply List.mem_append_right _ + simp only [walkValue, queriedInputs_tweakableHash, List.mem_singleton] + · rw [queriedInputs_bind] + apply List.mem_append_left + simp only [chainLength, winternitzBits] at hstep hrange + exact ih offset (by omega) hrange + +theorem leafHash_query_mem (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (endpoints : ChainIndex → Digest) : + tweakableHashInput parameter (.leaf lay tree leafIdx) (leafPayload endpoints) + ∈ queriedInputs f (leafHash parameter lay tree leafIdx endpoints) := by + simp [leafHash] + +theorem otsLeaf_leaf_query_mem (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (counter : Counter) (values : ChainIndex → Digest) (codeword : Encoding) + (hencode : evalWithAnswerFn f (encode parameter lay tree leafIdx message counter) + = some codeword) : + tweakableHashInput parameter (.leaf lay tree leafIdx) + (leafPayload fun chainIdx => walkValue f parameter lay tree leafIdx chainIdx + (codeword chainIdx).val (values chainIdx) (chainLength - 1 - (codeword chainIdx).val)) + ∈ queriedInputs f (otsLeaf parameter lay tree leafIdx message counter values) := by + simp only [otsLeaf] + apply queriedInputs_mono_bind_right + rw [hencode] + apply queriedInputs_mono_bind_right + apply queriedInputs_mono_bind_left + simpa only [evalWithAnswerFn_sequenceFin, recoverChain, walkValue] using + leafHash_query_mem f parameter lay tree leafIdx + (fun chainIdx => evalWithAnswerFn f + (recoverChain parameter lay tree leafIdx chainIdx (codeword chainIdx) (values chainIdx))) + +theorem otsLeaf_chain_query_mem (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (message : Digest) (counter : Counter) (values : ChainIndex → Digest) (codeword : Encoding) + (hencode : evalWithAnswerFn f (encode parameter lay tree leafIdx message counter) + = some codeword) (chainIdx : ChainIndex) (offset : Nat) + (hoffset : offset < chainLength - 1 - (codeword chainIdx).val) + (hrange : (codeword chainIdx).val + offset < chainLength - 1) : + tweakableHashInput parameter + (.chain lay tree leafIdx chainIdx ⟨(codeword chainIdx).val + offset, hrange⟩) + (digestBytes (walkValue f parameter lay tree leafIdx chainIdx (codeword chainIdx).val + (values chainIdx) offset)) + ∈ queriedInputs f (otsLeaf parameter lay tree leafIdx message counter values) := by + simp only [otsLeaf] + apply queriedInputs_mono_bind_right + rw [hencode] + apply queriedInputs_mono_bind_left + apply sequenceFin_component_query_mem f _ chainIdx + exact chainWalk_query_mem f parameter lay tree leafIdx chainIdx (codeword chainIdx).val + (chainLength - 1 - (codeword chainIdx).val) (values chainIdx) offset hoffset hrange + +theorem ftsLeafHash_query_mem (index : Index) (tree : FtsTree) (leafIdx : FtsLeaf) + (secret : Digest) : + tweakableHashInput parameter (.ftsLeaf index tree leafIdx) (digestBytes secret) + ∈ queriedInputs f (ftsLeafHash parameter index tree leafIdx secret) := by + simp [ftsLeafHash] + +theorem treeFold_query_mem (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (path : Nat → Digest) (value : Digest) (levels offset : Nat) (hoffset : offset < levels) : + tweakableHashInput parameter + (.node lay tree (offset + 1) (leafIdx.val / 2 ^ (offset + 1))) + (foldPayload f parameter lay tree leafIdx path value offset) + ∈ queriedInputs f (treeFold parameter lay tree leafIdx path levels value) := by + induction levels generalizing offset with + | zero => omega + | succ levels ih => + rw [treeFold_succ_eq, queriedInputs_bind] + rcases Nat.lt_succ_iff_lt_or_eq.mp hoffset with hlt | heq + · exact List.mem_append_left _ (ih offset hlt) + · subst offset + apply List.mem_append_right _ + simp only [foldValue, foldPayload] + cases leafIdx.val.testBit levels <;> simp + +theorem ftsFold_query_mem (index : Index) (tree : FtsTree) (leafIdx : FtsLeaf) + (path : Fin ftsTreeHeight → Digest) (value : Digest) (levels offset : Nat) + (hlevels : levels ≤ ftsTreeHeight) (hoffset : offset < levels) : + tweakableHashInput parameter + (.ftsNode index tree (offset + 1) (leafIdx.val / 2 ^ (offset + 1))) + (ftsFoldPayload f parameter index tree leafIdx path value offset) + ∈ queriedInputs f (ftsFold parameter index tree leafIdx path levels value) := by + induction levels generalizing offset with + | zero => omega + | succ levels ih => + rw [ftsFold_succ_eq, queriedInputs_bind] + rcases Nat.lt_succ_iff_lt_or_eq.mp hoffset with hlt | heq + · exact List.mem_append_left _ (ih offset (by omega) hlt) + · subst offset + have hlevel : levels < ftsTreeHeight := by omega + apply List.mem_append_right _ + simp only [ftsFoldValue, ftsFoldPayload, ftsSibling, dif_pos hlevel] + cases leafIdx.val.testBit levels <;> simp + +theorem ftsRecover_leaf_query_mem (index : Index) (leaves : DigestTree → FtsLeaf) + (secrets : FtsTree → Digest) (paths : FtsTree → Fin ftsTreeHeight → Digest) + (tree : FtsTree) : + tweakableHashInput parameter (.ftsLeaf index tree (leaves (ftsIndexOf tree))) + (digestBytes (secrets tree)) + ∈ queriedInputs f (ftsRecover parameter index leaves secrets paths) := by + simp only [ftsRecover] + apply queriedInputs_mono_bind_left + apply sequenceFin_component_query_mem f _ tree + apply queriedInputs_mono_bind_left + exact ftsLeafHash_query_mem f parameter index tree (leaves (ftsIndexOf tree)) (secrets tree) + +theorem ftsRecover_fold_query_mem (index : Index) (leaves : DigestTree → FtsLeaf) + (secrets : FtsTree → Digest) (paths : FtsTree → Fin ftsTreeHeight → Digest) + (tree : FtsTree) (offset : Nat) (hoffset : offset < ftsTreeHeight) : + tweakableHashInput parameter + (.ftsNode index tree (offset + 1) + ((leaves (ftsIndexOf tree)).val / 2 ^ (offset + 1))) + (ftsFoldPayload f parameter index tree (leaves (ftsIndexOf tree)) (paths tree) + (truncateHash (f (tweakableHashInput parameter + (.ftsLeaf index tree (leaves (ftsIndexOf tree))) (digestBytes (secrets tree))))) offset) + ∈ queriedInputs f (ftsRecover parameter index leaves secrets paths) := by + simp only [ftsRecover] + apply queriedInputs_mono_bind_left + apply sequenceFin_component_query_mem f _ tree + apply queriedInputs_mono_bind_right + simpa only [ftsLeafHash, eval_tweakableHash] using + ftsFold_query_mem f parameter index tree (leaves (ftsIndexOf tree)) (paths tree) + (truncateHash (f (tweakableHashInput parameter + (.ftsLeaf index tree (leaves (ftsIndexOf tree))) (digestBytes (secrets tree))))) + ftsTreeHeight offset (le_refl _) hoffset + +theorem ftsRecover_roots_query_mem (index : Index) (leaves : DigestTree → FtsLeaf) + (secrets : FtsTree → Digest) (paths : FtsTree → Fin ftsTreeHeight → Digest) : + tweakableHashInput parameter (.ftsRoots index) + (ftsRootsPayload fun tree => evalWithAnswerFn f + (ftsFold parameter index tree (leaves (ftsIndexOf tree)) (paths tree) ftsTreeHeight + (evalWithAnswerFn f + (ftsLeafHash parameter index tree (leaves (ftsIndexOf tree)) (secrets tree))))) + ∈ queriedInputs f (ftsRecover parameter index leaves secrets paths) := by + simp only [ftsRecover] + apply queriedInputs_mono_bind_right + simp only [evalWithAnswerFn_sequenceFin, evalWithAnswerFn_bind, queriedInputs_tweakableHash, + List.mem_singleton] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/QueryBound.lean b/formal/sphincs/SphincsSecurity/Proof/QueryBound.lean new file mode 100644 index 00000000..fdce9c17 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/QueryBound.lean @@ -0,0 +1,214 @@ +import SphincsSecurity.Proof.Guess + +/-! +# Charging one query at a time + +The tool every strategy's bound instantiates: if an event needs some oracle answer to satisfy a +predicate fixed at its input, and one fresh answer satisfies it with probability at most `eps`, then +a computation making at most `q` hash queries produces such an answer with probability at most +`q * eps`. + +The cache is what the statement talks about, since it is the random oracle's own state: a hit is an +entry whose answer satisfies the predicate at its input. A repeated query cannot add a hit, so +counting every query rather than every distinct one only weakens the bound. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +/-- A bound on a bind bounds each continuation. VCVio composes bounds, `n` then `m` giving `n + m`; +what the reduction needs is the other direction, to bound what runs after key generation by what +bounds the whole game. -/ +theorem isQueryBoundP_of_bind {α β : Type} {oa : OracleComp OracleWorld α} + {k : α → OracleComp OracleWorld β} {q : Nat} + (h : IsQueryBoundP (oa >>= k) (· matches Sum.inr _) q) : + ∀ x ∈ support oa, IsQueryBoundP (k x) (· matches Sum.inr _) q := by + induction oa using OracleComp.inductionOn generalizing q with + | pure x => + intro x' hx' + simp only [support_pure, Set.mem_singleton_iff] at hx' + subst hx' + simpa using h + | query_bind t mx ih => + intro x hx + rw [bind_assoc, isQueryBoundP_query_bind_iff] at h + obtain ⟨u, hu⟩ := (mem_support_bind_iff _ _ _).mp hx + exact (ih u (h.2 u) x hu.2).mono (by split_ifs <;> omega) + +/-- A query bound on a bind bounds its left-hand computation. -/ +theorem IsQueryBoundP.of_bind_left {ι : Type} {spec : OracleSpec ι} + {α β : Type} {oa : OracleComp spec α} {ob : α → OracleComp spec β} + {p : ι → Prop} [DecidablePred p] {n : Nat} + (h : IsQueryBoundP (oa >>= ob) p n) : IsQueryBoundP oa p n := by + induction oa using OracleComp.inductionOn generalizing n with + | pure _ => trivial + | query_bind input continuation ih => + rw [bind_assoc, isQueryBoundP_query_bind_iff] at h + rw [isQueryBoundP_query_bind_iff] + exact ⟨h.1, fun output => ih output (h.2 output)⟩ + +/-- A predicate query bound controls the matching entries of every logging trace. -/ +theorem queryLog_countQ_le_of_mem_support_run_simulateQ + {ι : Type} {spec : OracleSpec.{0, 0} ι} + [spec.DecidableEq] [IsUniformSpec spec] {α : Type} + {oa : OracleComp spec α} {p : ι → Prop} [DecidablePred p] {n : Nat} + (hbound : IsQueryBoundP oa p n) + {z : α × QueryLog spec} + (hz : z ∈ support ((simulateQ loggingOracle oa).run)) : + z.2.countQ p ≤ n := by + induction oa using OracleComp.inductionOn generalizing n z with + | pure x => + simp only [simulateQ_pure] at hz + subst hz + simp [QueryLog.countQ] + | query_bind t mx ih => + rw [isQueryBoundP_query_bind_iff] at hbound + obtain ⟨hcan, hrest⟩ := hbound + rw [run_simulateQ_loggingOracle_query_bind, support_bind] at hz + simp only [Set.mem_iUnion, support_map] at hz + obtain ⟨u, _, z', hz', rfl⟩ := hz + have htail := ih u (hrest u) hz' + by_cases ht : p t + · have hn : 0 < n := by simpa [ht] using hcan + simp only [ht, if_true] at htail + change z'.2.countQ p ≤ n - 1 at htail + rw [QueryLog.countQ] at htail + simp only [QueryLog.countQ, QueryLog.getQ_cons, ht, if_true, List.length_cons] + omega + · simpa [QueryLog.countQ, QueryLog.getQ_cons, ht] using htail + +/-- The cache holds an answer satisfying `P` at its input. -/ +def CacheHit (P : HashInput → HashOutput → Prop) (cache : QueryCache HashSpec) : Prop := + ∃ input answer, cache input = some answer ∧ P input answer + +/-- Caching a fresh answer adds a hit exactly when that answer is one. The freshness matters: an +answer written over an existing entry could remove a hit instead, and the run only ever caches what +it did not find. -/ +theorem cacheHit_cacheQuery_iff (P : HashInput → HashOutput → Prop) + (cache : QueryCache HashSpec) (input : HashInput) (answer : HashOutput) + (huncached : cache input = none) : + CacheHit P (cache.cacheQuery input answer) ↔ P input answer ∨ CacheHit P cache := by + classical + constructor + · rintro ⟨input', answer', hlookup, hP⟩ + by_cases hsame : input' = input + · subst hsame + rw [QueryCache.cacheQuery_self] at hlookup + have hanswer := Option.some.inj hlookup + subst hanswer + exact Or.inl hP + · exact Or.inr ⟨input', answer', by rwa [QueryCache.cacheQuery_of_ne _ _ hsame] at hlookup, hP⟩ + · rintro (hP | ⟨input', answer', hlookup, hP'⟩) + · exact ⟨input, answer, QueryCache.cacheQuery_self _ _ _, hP⟩ + · have hsame : input' ≠ input := by + intro heq + rw [heq, huncached] at hlookup + simp at hlookup + exact ⟨input', answer', by rwa [QueryCache.cacheQuery_of_ne _ _ hsame], hP'⟩ + +/-- Split a bind on an exceptional set: outside it every branch is bounded, inside it anything can +happen, so the whole bind costs the exception plus the bound. -/ +theorem probEvent_bind_le_add_of_forall_le {α β : Type} {mx : ProbComp α} {f : α → ProbComp β} + {E : β → Prop} {bad : α → Prop} {c : ℝ≥0∞} (h : ∀ x, ¬ bad x → Pr[E | f x] ≤ c) : + Pr[E | mx >>= f] ≤ Pr[bad | mx] + c := by + classical + rw [probEvent_bind_eq_tsum, probEvent_eq_tsum_ite] + calc ∑' x, Pr[= x | mx] * Pr[E | f x] + ≤ ∑' x, (Pr[= x | mx] * (if bad x then 1 else 0) + Pr[= x | mx] * c) := by + refine ENNReal.tsum_le_tsum fun x => ?_ + by_cases hbad : bad x + · simp only [hbad, if_true] + exact le_add_right (mul_le_mul' le_rfl probEvent_le_one) + · simp only [hbad, if_false] + exact le_add_left (mul_le_mul' le_rfl (h x hbad)) + _ = (∑' x, Pr[= x | mx] * (if bad x then 1 else 0)) + ∑' x, Pr[= x | mx] * c := + ENNReal.tsum_add + _ ≤ (∑' x, if bad x then Pr[= x | mx] else 0) + c := by + refine add_le_add (ENNReal.tsum_le_tsum fun x => ?_) ?_ + · by_cases hbad : bad x <;> simp [hbad] + · rw [ENNReal.tsum_mul_right] + exact mul_le_of_le_one_left zero_le tsum_probOutput_le_one + +theorem probEvent_cacheHit_le {P : HashInput → HashOutput → Prop} {ε : ℝ≥0∞} + (hstep : ∀ input, Pr[fun answer => P input answer | ($ᵗ HashOutput : ProbComp HashOutput)] ≤ ε) + {α : Type} (oa : OracleComp OracleWorld α) : + ∀ (q : Nat), oa.IsQueryBoundP (· matches Sum.inr _) q → + ∀ (cache : QueryCache HashSpec), ¬ CacheHit P cache → + Pr[fun result => CacheHit P result.2 | (simulateQ romImpl oa).run cache] ≤ q * ε := by + classical + induction oa using OracleComp.inductionOn with + | pure x => + intro q _ cache hclean + simp [hclean] + | query_bind t k ih => + intro q hq cache hclean + rw [isQueryBoundP_query_bind_iff] at hq + obtain ⟨hcan, hcont⟩ := hq + rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind] + cases t with + | inl i => + simp only [Bool.false_eq_true, if_false] at hcont + have hrun : ((romImpl (Sum.inl i)).run cache + >>= fun p => (simulateQ romImpl (k p.1)).run p.2) + = (liftM (unifSpec.query i) : ProbComp _) + >>= fun u => (simulateQ romImpl (k u)).run cache := by + simp [romImpl, unifFwdImpl, QueryImpl.liftTarget, HasQuery.toQueryImpl, + StateT.run_monadLift, map_eq_bind_pure_comp, bind_assoc] + rw [hrun] + exact probEvent_bind_le_of_forall_le fun u _ => ih u q (hcont u) cache hclean + | inr input => + simp only [if_true] at hcont + have hq1 : 0 < q := by simpa using hcan + obtain ⟨q', rfl⟩ : ∃ q', q = q' + 1 := ⟨q - 1, by omega⟩ + simp only [Nat.add_sub_cancel] at hcont + have hshrink : (q' : ℝ≥0∞) * ε + ε = ((q' + 1 : Nat) : ℝ≥0∞) * ε := by + push_cast + ring + by_cases hcached : cache input = none + · have hrun : ((romImpl (Sum.inr input)).run cache + >>= fun p => (simulateQ romImpl (k p.1)).run p.2) + = ($ᵗ HashOutput : ProbComp HashOutput) >>= fun answer => + (simulateQ romImpl (k answer)).run (cache.cacheQuery input answer) := by + have hro : (romImpl (Sum.inr input)).run cache + = ((uniformSampleImpl.withCaching : QueryImpl HashSpec _) input).run cache := rfl + rw [hro, QueryImpl.withCaching_run_none _ hcached] + simp [map_eq_bind_pure_comp, bind_assoc, uniformSampleImpl] + rw [hrun] + refine le_trans (probEvent_bind_le_add_of_forall_le + (bad := fun answer => P input answer) (c := (q' : ℝ≥0∞) * ε) ?_) ?_ + · intro answer hanswer + refine ih answer q' (hcont answer) _ ?_ + rw [cacheHit_cacheQuery_iff P cache input answer hcached] + exact fun hhit => hhit.elim hanswer hclean + · calc Pr[fun answer => P input answer | ($ᵗ HashOutput : ProbComp HashOutput)] + + (q' : ℝ≥0∞) * ε + ≤ ε + (q' : ℝ≥0∞) * ε := add_le_add (hstep input) le_rfl + _ = ((q' + 1 : Nat) : ℝ≥0∞) * ε := by rw [add_comm]; exact hshrink + · obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hcached + have hrun : ((romImpl (Sum.inr input)).run cache + >>= fun p => (simulateQ romImpl (k p.1)).run p.2) + = (simulateQ romImpl (k answer)).run cache := by + have hro : (romImpl (Sum.inr input)).run cache + = ((uniformSampleImpl.withCaching : QueryImpl HashSpec _) input).run cache := rfl + rw [hro, QueryImpl.withCaching_run_some _ hanswer] + simp + rw [hrun] + refine le_trans (ih answer q' (hcont answer) cache hclean) ?_ + exact mul_le_mul_left (by exact_mod_cast Nat.le_succ q') ε + +/-- **The union bound, at the digest length.** A computation making at most `q` hash queries lands +an answer on its target with probability at most `q * 2^-n`, whatever target each input is assigned. +Every strategy the specification accounts for is an instance: domain separation fixes which position +a query bears on, so the target is a function of the input alone. -/ +theorem probEvent_cacheHit_target_le {α : Type} (target : HashInput → Digest) + (oa : OracleComp OracleWorld α) (q : Nat) + (hq : oa.IsQueryBoundP (· matches Sum.inr _) q) (cache : QueryCache HashSpec) + (hclean : ¬ CacheHit (fun input answer => truncateHash answer = target input) cache) : + Pr[fun result => CacheHit (fun input answer => truncateHash answer = target input) result.2 + | (simulateQ romImpl oa).run cache] ≤ q * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + refine probEvent_cacheHit_le (fun input => ?_) oa q hq cache hclean + rw [← probOutput_map] + exact probOutput_truncateHash_le (target input) + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Replay.lean b/formal/sphincs/SphincsSecurity/Proof/Replay.lean new file mode 100644 index 00000000..edd26ccd --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Replay.lean @@ -0,0 +1,198 @@ +import SphincsSecurity.Proof.ForgeryClassify + +/-! +# Replay and message-digest collisions + +If one signing entry has the forgery's complete admissible digest, a fully honest opening is the +returned signature unless the two distinct message-digest inputs have the same answer. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +def MessageDigestCollision (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) + (signingLog : QueryLog SigningSpec) (forgery : Forgery) : Prop := + ∃ (entry : (request : SignRequest) × SigningSpec.Range request) (signature : Signature), + entry ∈ signingLog + ∧ entry.2 = some signature + ∧ SuccessfulSignRun f cache secretKey entry.1 signature + ∧ CachedRun cache f (messageDigest secretKey.parameter secretKey.root forgery.message + forgery.signature.randomness) + ∧ tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root entry.1 signature.randomness) + ≠ tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root forgery.message forgery.signature.randomness) + ∧ evalWithAnswerFn f + (messageDigest secretKey.parameter secretKey.root entry.1 signature.randomness) + = evalWithAnswerFn f (messageDigest secretKey.parameter secretKey.root forgery.message + forgery.signature.randomness) + +def ProperFewTimeLeak (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (index : Index) + (leaves : DigestTree → FtsLeaf) : Prop := + FewTimeLeak f cache secretKey signingLog index leaves + ∧ ∀ (entry : (request : SignRequest) × SigningSpec.Range request) (signature : Signature), + entry ∈ signingLog → entry.2 = some signature → + SuccessfulSignRun f cache secretKey entry.1 signature → + ¬ HonestFtsSignAt f cache secretKey entry.1 signature index leaves + +theorem messageDigestPayload_injective (root : Digest) {leftMessage rightMessage : Message} + {leftRandomness rightRandomness : Randomness} + (h : messageDigestPayload root leftMessage leftRandomness + = messageDigestPayload root rightMessage rightRandomness) : + leftMessage = rightMessage ∧ leftRandomness = rightRandomness := by + simp only [messageDigestPayload] at h + obtain ⟨hrandomness, hrest⟩ := List.append_inj h (by simp [randomnessBytes, bytesLE_length]) + have hrandomness' := List.append_cancel_right hrandomness + exact ⟨bytesLE_injective hrest, bytesLE_injective hrandomness'⟩ + +theorem fullyHonest_layers_exact_or_obstacle (f : QueryImpl HashSpec Id) + (cache : QueryCache HashSpec) (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) + (forgery : Forgery) (index : Index) (leaves : DigestTree → FtsLeaf) + (hfull : FullyHonestOpening f cache secretKey index leaves forgery.signature) + (entry : (request : SignRequest) × SigningSpec.Range request) (signature : Signature) + (hentry : entry ∈ signingLog) (hresponse : entry.2 = some signature) + (hrun : SuccessfulSignRun f cache secretKey entry.1 signature) + (hsignedFts : HonestFtsSignAt f cache secretKey entry.1 signature index leaves) : + (∀ lay, + signature.counter lay = forgery.signature.counter lay + ∧ signature.chainValue lay = forgery.signature.chainValue lay + ∧ ∀ level, level < layerHeight lay → + signaturePath signature lay level = signaturePath forgery.signature lay level) + ∨ ForgedLayerObstacle f cache secretKey signingLog index leaves forgery.signature := by + by_cases hobstacle : ForgedLayerObstacle f cache secretKey signingLog index leaves + forgery.signature + · exact Or.inr hobstacle + · left + intro lay + obtain ⟨hsignedMessage, hsignedOpening⟩ := + hrun.honest_layer_at_of_digest hsignedFts.1 lay + have hsignedEncoding := hrun.signed_encode_cached_of_digest hsignedFts.1 lay + rcases honestLayerOpening_compare f secretKey.parameter secretKey.otsSecret lay + (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f (layerMessage secretKey index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay)) (signature.counter lay) + (forgery.signature.counter lay) (signature.chainValue lay) + (forgery.signature.chainValue lay) (signaturePath signature lay) + (signaturePath forgery.signature lay) hsignedOpening (hfull.1 lay).1 with + hexact | hencoding | hearlier + · exact ⟨hexact.2.1, hexact.2.2.1, hexact.2.2.2⟩ + · exact (hobstacle ⟨lay, evalWithAnswerFn f (layerMessage secretKey index lay), + hfull.2.2.2 lay, (hfull.1 lay).1, (hfull.1 lay).2, + Or.inr ⟨entry, signature, index, leaves, hentry, hresponse, hrun, hsignedFts.1, + rfl, rfl, hsignedMessage, hsignedOpening, hsignedEncoding, Or.inl hencoding⟩⟩).elim + · exact (hobstacle ⟨lay, evalWithAnswerFn f (layerMessage secretKey index lay), + hfull.2.2.2 lay, (hfull.1 lay).1, (hfull.1 lay).2, + Or.inr ⟨entry, signature, index, leaves, hentry, hresponse, hrun, hsignedFts.1, + rfl, rfl, hsignedMessage, hsignedOpening, hsignedEncoding, Or.inr hearlier⟩⟩).elim + +theorem fullyHonest_replay_or_digestCollision (f : QueryImpl HashSpec Id) + (cache : QueryCache HashSpec) (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) + (forgery : Forgery) (forgedDigest : MessageDigest) (index : Index) + (leaves : DigestTree → FtsLeaf) + (hforgedDigest : evalWithAnswerFn f (messageDigest secretKey.parameter secretKey.root + forgery.message forgery.signature.randomness) = forgedDigest) + (hforgedRun : CachedRun cache f (messageDigest secretKey.parameter secretKey.root + forgery.message forgery.signature.randomness)) + (hindex : index = digestIndex forgedDigest) (hleaves : leaves = digestLeaves forgedDigest) + (hfull : FullyHonestOpening f cache secretKey index leaves forgery.signature) + (entry : (request : SignRequest) × SigningSpec.Range request) (signature : Signature) + (hentry : entry ∈ signingLog) (hresponse : entry.2 = some signature) + (hrun : SuccessfulSignRun f cache secretKey entry.1 signature) + (hsignedFts : HonestFtsSignAt f cache secretKey entry.1 signature index leaves) : + SigningTranscript.Contains signingLog forgery + ∨ MessageDigestCollision f cache secretKey signingLog forgery + ∨ ForgedLayerObstacle f cache secretKey signingLog index leaves forgery.signature := by + obtain ⟨_, signedDigest, hsignedDigest, _, hsignedIndex, hsignedLeaves, _⟩ := + hsignedFts.1.extract + have hdigest : signedDigest = forgedDigest := by + apply messageDigest_eq_of_index_leaves_eq + · rw [← hsignedIndex, hindex] + · rw [← hsignedLeaves, hleaves] + let signedInput := tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root entry.1 signature.randomness) + let forgedInput := tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root forgery.message forgery.signature.randomness) + by_cases hinput : signedInput = forgedInput + · have hpayload := (tweakableHashInput_injective secretKey.parameter (by trivial) (by trivial) + hinput).2 + obtain ⟨hmessage, hrandomness⟩ := messageDigestPayload_injective secretKey.root hpayload + by_cases hobstacle : ForgedLayerObstacle f cache secretKey signingLog index leaves + forgery.signature + · exact Or.inr (Or.inr hobstacle) + have hlayers := (fullyHonest_layers_exact_or_obstacle f cache secretKey signingLog forgery + index leaves hfull entry signature hentry hresponse hrun hsignedFts).resolve_right hobstacle + have hftsSecret : signature.ftsSecret = forgery.signature.ftsSecret := by + funext tree + rw [congrFun hsignedFts.2.1 tree, (hfull.2.1 tree).1] + have hftsPath : signature.ftsPath = forgery.signature.ftsPath := by + funext tree level + rw [congrFun (congrFun hsignedFts.2.2 tree) level] + exact (hfull.2.1 tree).2 level.val level.isLt |>.symm + have hcounter : signature.counter = forgery.signature.counter := by + funext lay + exact (hlayers lay).1 + have hchainValue : signature.chainValue = forgery.signature.chainValue := by + funext lay + exact (hlayers lay).2.1 + have hauthPath : signature.authPath = forgery.signature.authPath := by + funext position + obtain ⟨lay, level, hlevel, hposition⟩ := authPath_exhausted position + have hpath := (hlayers lay).2.2 level.val hlevel + have hsum : heightAbove lay + level.val < totalHeight := by + rw [hposition] + exact position.isLt + simp only [signaturePath, dif_pos hsum] at hpath + have hfin : (⟨heightAbove lay + level.val, hsum⟩ : PathIndex) = position := + Fin.ext hposition + simpa only [hfin] using hpath + have hsignature : signature = forgery.signature := by + change Signature.mk signature.randomness signature.ftsSecret signature.ftsPath + signature.counter signature.chainValue signature.authPath = + Signature.mk forgery.signature.randomness forgery.signature.ftsSecret + forgery.signature.ftsPath forgery.signature.counter forgery.signature.chainValue + forgery.signature.authPath + rw [Signature.mk.injEq] + exact ⟨hrandomness, hftsSecret, hftsPath, hcounter, hchainValue, hauthPath⟩ + left + exact ⟨entry, hentry, hmessage, hresponse.trans (congrArg some hsignature)⟩ + · right + left + exact ⟨entry, signature, hentry, hresponse, hrun, hforgedRun, hinput, + hsignedDigest.trans (hdigest.trans hforgedDigest.symm)⟩ + +theorem fullyHonest_leak_classify (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (forgery : Forgery) + (forgedDigest : MessageDigest) (index : Index) (leaves : DigestTree → FtsLeaf) + (hforgedDigest : evalWithAnswerFn f (messageDigest secretKey.parameter secretKey.root + forgery.message forgery.signature.randomness) = forgedDigest) + (hforgedRun : CachedRun cache f (messageDigest secretKey.parameter secretKey.root + forgery.message forgery.signature.randomness)) + (hindex : index = digestIndex forgedDigest) (hleaves : leaves = digestLeaves forgedDigest) + (hfull : FullyHonestOpening f cache secretKey index leaves forgery.signature) + (hnotContains : ¬ SigningTranscript.Contains signingLog forgery) + (hleak : FewTimeLeak f cache secretKey signingLog index leaves) : + MessageDigestCollision f cache secretKey signingLog forgery + ∨ ForgedLayerObstacle f cache secretKey signingLog index leaves forgery.signature + ∨ ProperFewTimeLeak f cache secretKey signingLog index leaves := by + by_cases hfullEntry : ∃ (entry : (request : SignRequest) × SigningSpec.Range request) + (signature : Signature), + entry ∈ signingLog ∧ entry.2 = some signature + ∧ SuccessfulSignRun f cache secretKey entry.1 signature + ∧ HonestFtsSignAt f cache secretKey entry.1 signature index leaves + · obtain ⟨entry, signature, hentry, hresponse, hrun, hsignedFts⟩ := hfullEntry + rcases fullyHonest_replay_or_digestCollision f cache secretKey signingLog forgery + forgedDigest index leaves hforgedDigest hforgedRun hindex hleaves hfull entry signature hentry + hresponse hrun hsignedFts with hreplay | hcollision | hobstacle + · exact (hnotContains hreplay).elim + · exact Or.inl hcollision + · exact Or.inr (Or.inl hobstacle) + · right + right + refine ⟨hleak, ?_⟩ + intro entry signature hentry hresponse hrun hsignedFts + exact hfullEntry ⟨entry, signature, hentry, hresponse, hrun, hsignedFts⟩ + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/ReplayWorld.lean b/formal/sphincs/SphincsSecurity/Proof/ReplayWorld.lean new file mode 100644 index 00000000..7dfa02b0 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/ReplayWorld.lean @@ -0,0 +1,142 @@ +import SphincsSecurity.Proof.Execution + +/-! +# Replaying the full oracle world + +Once a final random-oracle cache fixes an answer function, the same execution can be replayed with +those hash answers deterministic while uniform-sampling queries remain probabilistic. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +noncomputable def replayRomImpl (f : QueryImpl HashSpec Id) : + QueryImpl OracleWorld (StateT (QueryCache HashSpec) ProbComp) := + unifFwdImpl HashSpec + (f.liftTarget ProbComp).withCaching + +noncomputable def replayHashImpl (f : QueryImpl HashSpec Id) : + QueryImpl HashSpec (StateT (QueryCache HashSpec) ProbComp) := + (f.liftTarget ProbComp).withCaching + +theorem simulateQ_replayRom_cache_le {alpha : Type} (f : QueryImpl HashSpec Id) + (oa : OracleComp OracleWorld alpha) (cache : QueryCache HashSpec) + (z : alpha × QueryCache HashSpec) + (hmem : z ∈ support ((simulateQ (replayRomImpl f) oa).run cache)) : cache ≤ z.2 := by + apply OracleComp.simulateQ_run_preservesInv (replayRomImpl f) (cache ≤ ·) _ + oa cache le_rfl z hmem + intro input current hle result hresult + cases input with + | inl sample => + change result ∈ support (((unifFwdImpl HashSpec) sample).run current) at hresult + have hrun := unifFwdImpl.simulateQ_run + (hashSpec := HashSpec) (liftM (unifSpec.query sample) : ProbComp _) current + simp only [simulateQ_spec_query] at hrun + rw [hrun, support_map] at hresult + obtain ⟨value, _, heq⟩ := hresult + rw [← (Prod.mk.inj heq).2] + exact hle + | inr hashInput => + change result ∈ support + ((((f.liftTarget ProbComp).withCaching : QueryImpl HashSpec _) hashInput).run current) + at hresult + exact hle.trans (QueryImpl.withCaching_cache_le _ hashInput current result hresult) + +theorem replayRom_of_mem_support {alpha : Type} (oa : OracleComp OracleWorld alpha) + (cache : QueryCache HashSpec) (a : alpha) (finalCache : QueryCache HashSpec) + (hmem : (a, finalCache) ∈ support ((simulateQ romImpl oa).run cache)) + (f : QueryImpl HashSpec Id) (hf : finalCache.AgreesWithFn f) : + (a, finalCache) ∈ support ((simulateQ (replayRomImpl f) oa).run cache) := by + induction oa using OracleComp.inductionOn generalizing cache a finalCache with + | pure value => + simpa only [simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff] using hmem + | query_bind input next ih => + simp only [simulateQ_query_bind, StateT.run_bind, mem_support_bind_iff] at hmem ⊢ + obtain ⟨⟨answer, middleCache⟩, hquery, hrest⟩ := hmem + refine ⟨⟨answer, middleCache⟩, ?_, ih answer middleCache a finalCache hrest hf⟩ + cases input with + | inl sample => + change (answer, middleCache) ∈ support (((unifFwdImpl HashSpec) sample).run cache) + at hquery ⊢ + exact hquery + | inr hashInput => + change HashOutput at answer + change (answer, middleCache) ∈ support + (((randomOracle : QueryImpl HashSpec _) hashInput).run cache) at hquery + have hmiddleLe : middleCache ≤ finalCache := + simulateQ_romImpl_cache_le (next answer) middleCache _ hrest + change (answer, middleCache) ∈ support + ((((f.liftTarget ProbComp).withCaching : QueryImpl HashSpec _) hashInput).run cache) + cases hcache : cache hashInput with + | some old => + rw [QueryImpl.withCaching_run_some uniformSampleImpl hcache, support_pure, + Set.mem_singleton_iff] at hquery + obtain ⟨rfl, rfl⟩ := hquery + rw [QueryImpl.withCaching_run_some _ hcache, support_pure, Set.mem_singleton_iff] + | none => + rw [QueryImpl.withCaching_run_none uniformSampleImpl hcache, support_map] at hquery + obtain ⟨sampled, _, heq⟩ := hquery + obtain ⟨rfl, rfl⟩ := heq + have hfanswer : f hashInput = answer := + hf (hmiddleLe (QueryCache.cacheQuery_self cache hashInput answer)) + rw [QueryImpl.withCaching_run_none _ hcache, support_map] + refine ⟨f hashInput, ?_, ?_⟩ + · change f hashInput ∈ support (pure (f hashInput) : ProbComp HashOutput) + exact Set.mem_singleton _ + · rw [hfanswer] + +theorem replayHash_mem_randomOracle {alpha : Type} (f : QueryImpl HashSpec Id) + (oa : OracleComp HashSpec alpha) (cache : QueryCache HashSpec) + (a : alpha) (finalCache : QueryCache HashSpec) + (hmem : (a, finalCache) ∈ support + ((simulateQ (replayHashImpl f) oa).run cache)) : + (a, finalCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) oa).run cache) := by + induction oa using OracleComp.inductionOn generalizing cache a finalCache with + | pure value => + simpa only [simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff] using hmem + | query_bind input next ih => + simp only [simulateQ_query_bind, StateT.run_bind, mem_support_bind_iff] at hmem ⊢ + obtain ⟨⟨answer, middleCache⟩, hquery, hrest⟩ := hmem + refine ⟨⟨answer, middleCache⟩, ?_, ih answer middleCache a finalCache hrest⟩ + change (answer, middleCache) ∈ support + ((((f.liftTarget ProbComp).withCaching : QueryImpl HashSpec _) input).run cache) + at hquery + change (answer, middleCache) ∈ support + (((randomOracle : QueryImpl HashSpec _) input).run cache) + cases hcache : cache input with + | some old => + rw [QueryImpl.withCaching_run_some _ hcache, support_pure, + Set.mem_singleton_iff] at hquery + obtain ⟨rfl, rfl⟩ := hquery + rw [QueryImpl.withCaching_run_some uniformSampleImpl hcache, support_pure, + Set.mem_singleton_iff] + | none => + rw [QueryImpl.withCaching_run_none _ hcache, support_map] at hquery + obtain ⟨sampled, hsampled, heq⟩ := hquery + have hsampledEq : sampled = f input := by + change sampled ∈ support (pure (f input) : ProbComp HashOutput) at hsampled + simpa using hsampled + subst sampled + obtain ⟨rfl, rfl⟩ := heq + rw [QueryImpl.withCaching_run_none uniformSampleImpl hcache, support_map] + exact ⟨f input, by simp [uniformSampleImpl], rfl⟩ + +theorem replayHash_of_mem_support {alpha : Type} (f : QueryImpl HashSpec Id) + (oa : OracleComp HashSpec alpha) (cache : QueryCache HashSpec) + (a : alpha) (finalCache : QueryCache HashSpec) + (hmem : (a, finalCache) ∈ support + ((simulateQ (replayHashImpl f) oa).run cache)) + (hf : finalCache.AgreesWithFn f) : + cache ≤ finalCache ∧ evalWithAnswerFn f oa = a ∧ CachedRun finalCache f oa := by + have hrandom := replayHash_mem_randomOracle f oa cache a finalCache hmem + obtain ⟨hle, heval, hqueries⟩ := replay_of_mem_support oa cache a finalCache hrandom f hf + exact ⟨hle, heval, hqueries⟩ + +theorem simulateQ_replayRom_liftM {alpha : Type} (f : QueryImpl HashSpec Id) + (oa : OracleComp HashSpec alpha) : + simulateQ (replayRomImpl f) (liftM oa : OracleComp OracleWorld alpha) + = simulateQ (replayHashImpl f) oa := + QueryImpl.simulateQ_add_liftM_right _ _ oa + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/RetainedCollisionCache.lean b/formal/sphincs/SphincsSecurity/Proof/RetainedCollisionCache.lean new file mode 100644 index 00000000..99fb373f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/RetainedCollisionCache.lean @@ -0,0 +1,134 @@ +import SphincsSecurity.Proof.Descent + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +noncomputable def retainHonestCache (secretKey : SecretKey) + (cache : QueryCache HashSpec) (inputs : Set HashInput) : QueryCache HashSpec := + open Classical in + fun input => if input ∈ inputs ∨ ∃ position, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position ∧ + input = cachedInput secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position + then cache input else none + +theorem retainHonestCache_le (secretKey : SecretKey) + (cache : QueryCache HashSpec) (inputs : Set HashInput) : + retainHonestCache secretKey cache inputs ≤ cache := by + intro input answer hcached + unfold retainHonestCache at hcached + split_ifs at hcached + exact hcached + +theorem retainHonestCache_agreesWithFn (secretKey : SecretKey) + (cache : QueryCache HashSpec) (inputs : Set HashInput) + (f : QueryImpl HashSpec Id) (hf : cache.AgreesWithFn f) : + (retainHonestCache secretKey cache inputs).AgreesWithFn f := + fun _ _ hcached => hf (retainHonestCache_le secretKey cache inputs hcached) + +theorem settled_retainHonestCache (secretKey : SecretKey) + (cache : QueryCache HashSpec) (inputs : Set HashInput) (position : Position) + (hsettled : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position) : + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (retainHonestCache secretKey cache inputs) position := by + have hf := retainHonestCache_agreesWithFn secretKey cache inputs (fromCache cache) + (agreesWithFn_fromCache cache) + suffices ∀ n p, p.depth < n → + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache p → + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (retainHonestCache secretKey cache inputs) p from + this (position.depth + 1) position (by omega) hsettled + intro n + induction n with + | zero => intro p hdepth; omega + | succ n ih => + intro p hdepth hp + apply settled_of_honestInput_cached hf hp.valid + · change retainHonestCache secretKey cache inputs + (cachedInput secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache p) ≠ none + have hkeep : ∃ position, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position ∧ + cachedInput secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache p = + cachedInput secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position := + ⟨p, hp, rfl⟩ + simpa only [retainHonestCache, hkeep, or_true, if_true] using hp.cached + · intro child hchild + apply ih child _ (hp.children child hchild) + have := Position.depth_lt_of_mem_children hchild + omega + +theorem cachedRun_retainHonestCache (secretKey : SecretKey) + (cache : QueryCache HashSpec) (inputs : Set HashInput) + (f : QueryImpl HashSpec Id) (computation : OracleComp HashSpec α) + (hrun : CachedRun cache f computation) + (hinputs : ∀ input ∈ queriedInputs f computation, input ∈ inputs) : + CachedRun (retainHonestCache secretKey cache inputs) f computation := by + intro input hinput + simpa only [retainHonestCache, hinputs input hinput, true_or, if_true] using hrun input hinput + +def BadOnInputs (secretKey : SecretKey) (cache : QueryCache HashSpec) + (inputs : Set HashInput) : Prop := + ∃ position input ax ay, + input ∈ inputs ∧ + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position ∧ + AtPosition secretKey.parameter input position ∧ + input ≠ cachedInput secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position ∧ + cache input = some ax ∧ + cache (cachedInput secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position) = some ay ∧ + truncateHash ax = truncateHash ay + +theorem BadOnInputs.bad {secretKey : SecretKey} {cache : QueryCache HashSpec} + {inputs : Set HashInput} (hbad : BadOnInputs secretKey cache inputs) : + Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache := by + obtain ⟨position, input, ax, ay, _, hsettled, hat, hne, hx, hy, heq⟩ := hbad + exact ⟨position, hsettled, input, ax, ay, hat, hne, hx, hy, heq⟩ + +theorem BadOnInputs.mono_inputs {secretKey : SecretKey} {cache : QueryCache HashSpec} + {inputs more : Set HashInput} (hsub : inputs ⊆ more) + (hbad : BadOnInputs secretKey cache inputs) : BadOnInputs secretKey cache more := by + obtain ⟨position, input, ax, ay, hinput, hrest⟩ := hbad + exact ⟨position, input, ax, ay, hsub hinput, hrest⟩ + +theorem bad_retainHonestCache_iff (secretKey : SecretKey) + (cache : QueryCache HashSpec) (inputs : Set HashInput) : + Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (retainHonestCache secretKey cache inputs) ↔ BadOnInputs secretKey cache inputs := by + classical + let restricted := retainHonestCache secretKey cache inputs + have hle : restricted ≤ cache := retainHonestCache_le secretKey cache inputs + constructor + · rintro ⟨position, hsettled, input, ax, ay, hat, hne, hx, hy, heq⟩ + have hpinned := cachedInput_eq_of_settled hle hsettled + have hne' : input ≠ cachedInput secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position := by + rwa [hpinned] + have hinput : input ∈ inputs := by + by_contra hnot + have hkeep : ∃ other, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache other ∧ + input = cachedInput secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache other := by + by_contra hnone + simp only [retainHonestCache, hnot, hnone, or_self, if_false] at hx + simp at hx + obtain ⟨other, _, hother⟩ := hkeep + have hatOther : AtPosition secretKey.parameter input other := by + rw [hother] + exact atPosition_cachedInput secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache other + have hpositions := atPosition_unique secretKey.parameter hat hatOther + exact hne' (hother.trans (congrArg _ hpositions.symm)) + exact ⟨position, input, ax, ay, hinput, hsettled.mono hle, hat, hne', hle hx, + by rw [hpinned]; exact hle hy, heq⟩ + · rintro ⟨position, input, ax, ay, hinput, hsettled, hat, hne, hx, hy, heq⟩ + have hsettled' := settled_retainHonestCache secretKey cache inputs position hsettled + have hpinned := cachedInput_eq_of_settled hle hsettled' + refine ⟨position, hsettled', input, ax, ay, hat, ?_, ?_, ?_, heq⟩ + · rwa [← hpinned] + · simpa only [retainHonestCache, hinput, true_or, if_true] using hx + · rw [← hpinned] + have hkeep : ∃ other, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache other ∧ + cachedInput secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position = + cachedInput secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache other := + ⟨position, hsettled, rfl⟩ + simpa only [retainHonestCache, hkeep, or_true, if_true] using hy + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/RetainedForgeryClassify.lean b/formal/sphincs/SphincsSecurity/Proof/RetainedForgeryClassify.lean new file mode 100644 index 00000000..8f2c32e1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/RetainedForgeryClassify.lean @@ -0,0 +1,206 @@ +import SphincsSecurity.Proof.RetainedCollisionCache +import SphincsSecurity.Proof.ForgeryClassify + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +theorem LayerFrame.mono_cache + {f : QueryImpl HashSpec Id} {cache cache' : QueryCache HashSpec} + {parameter : PublicParameter} {index : Index} {signature : Signature} + {lay : Layer} {message target leafValue : Digest} + (hle : cache ≤ cache') + (hframe : LayerFrame f cache parameter index signature lay message target leafValue) : + LayerFrame f cache' parameter index signature lay message target leafValue := + ⟨hframe.1, hframe.2.1, hframe.2.2.1.mono hle, + hframe.2.2.2.1.mono hle, hframe.2.2.2.2.mono hle⟩ + +theorem accepted_forgery_classify_retained (f : QueryImpl HashSpec Id) (cache retained : QueryCache HashSpec) + (secretKey : SecretKey) (signingLog : QueryLog SigningSpec) (index : Index) + (signature : Signature) (leaves : DigestTree → FtsLeaf) (ftsPublicKey root : Digest) + (hf : cache.AgreesWithFn f) (hle : retained ≤ cache) + (hpreserved : ∀ position, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position → + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret retained position) + (hftsPublicKey : evalWithAnswerFn f + (ftsRecover secretKey.parameter index leaves signature.ftsSecret signature.ftsPath) + = ftsPublicKey) + (htop : HypertreeTopOpening f retained secretKey.parameter secretKey.otsSecret index signature + ftsPublicKey root) + (htopSettled : LayerRootSettled cache secretKey topLayer + (treeIndexAt index topLayer)) + (hftsRun : CachedRun retained f + (ftsRecover secretKey.parameter index leaves signature.ftsSecret signature.ftsPath)) : + Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret retained + ∨ SettledForgedLayerObstacle f cache secretKey signingLog index leaves signature + ∨ SettledFullyHonestOpening f cache secretKey index leaves signature := by + obtain ⟨bottomLeaf, hbottomSmall, middleLeaf, hmiddleSmall, htopOpening, htopRunSmall⟩ := htop + have hbottom := LayerFrame.mono_cache hle hbottomSmall + have hmiddle := LayerFrame.mono_cache hle hmiddleSmall + have htopRun := htopRunSmall.mono hle + have hfSmall : retained.AgreesWithFn f := fun _ _ hcached => hf (hle hcached) + let middleMessage := foldValue f secretKey.parameter bottomLayer + (treeIndexAt index bottomLayer) (leafIndexAt index bottomLayer) + (signaturePath signature bottomLayer) bottomLeaf (layerHeight bottomLayer) + let topMessage := foldValue f secretKey.parameter middleLayer + (treeIndexAt index middleLayer) (leafIndexAt index middleLayer) + (signaturePath signature middleLayer) middleLeaf (layerHeight middleLayer) + have hverifierBottom : VerifierLayerMessage f secretKey.parameter index leaves signature + bottomLayer ftsPublicKey := by + simp only [VerifierLayerMessage, hftsPublicKey] + exact ⟨bottomLeaf, hbottom.1, middleLeaf, hmiddle.1, Or.inl ⟨trivial, trivial⟩⟩ + have hverifierMiddle : VerifierLayerMessage f secretKey.parameter index leaves signature + middleLayer middleMessage := by + simp only [VerifierLayerMessage, hftsPublicKey] + exact ⟨bottomLeaf, hbottom.1, middleLeaf, hmiddle.1, + Or.inr (Or.inl ⟨trivial, rfl⟩)⟩ + have hverifierTop : VerifierLayerMessage f secretKey.parameter index leaves signature + topLayer topMessage := by + simp only [VerifierLayerMessage, hftsPublicKey] + exact ⟨bottomLeaf, hbottom.1, middleLeaf, hmiddle.1, + Or.inr (Or.inr ⟨trivial, rfl⟩)⟩ + by_cases hsignedTop : SignedLayerAt f cache secretKey signingLog topLayer + (treeIndexAt index topLayer) (leafIndexAt index topLayer) + · rcases hsignedTop.exact_or_failure topMessage (signature.counter topLayer) + (signature.chainValue topLayer) (signaturePath signature topLayer) htopOpening with + ⟨_, _, signedTopIndex, _, _, _, _, _, htopTree, htopLeaf, htopMessage, _⟩ | hfailure + · have hmiddleRoot := exact_top_message_eq_middle_root f secretKey signedTopIndex index + topMessage htopTree htopLeaf htopMessage + have htopEval : evalWithAnswerFn f (layerMessage secretKey index topLayer) = topMessage := by + rw [← htopMessage] + congr 1 + exact (layerMessage_eq_of_position_eq secretKey signedTopIndex index topLayer htopTree + htopLeaf).symm + have hmiddleSettled := hsignedTop.settles_middle hf + rcases layer_extract_from_settled_root_or_bad (ftsSecret := secretKey.ftsSecret) hfSmall middleLayer + (treeIndexAt index middleLayer) (leafIndexAt index middleLayer) + (leafIndexAt_lt index middleLayer) middleMessage (signature.counter middleLayer) + (signature.chainValue middleLayer) (signaturePath signature middleLayer) middleLeaf + hmiddle.1 (by simpa only [topMessage] using hmiddleRoot) + hmiddleSmall.2.2.1 hmiddleSmall.2.2.2.1 (hpreserved _ hmiddleSettled) with hbad | hmiddleOpening + · exact Or.inl hbad + · by_cases hsignedMiddle : SignedLayerAt f cache secretKey signingLog middleLayer + (treeIndexAt index middleLayer) (leafIndexAt index middleLayer) + · rcases hsignedMiddle.exact_or_failure middleMessage (signature.counter middleLayer) + (signature.chainValue middleLayer) (signaturePath signature middleLayer) + hmiddleOpening with + ⟨_, _, signedMiddleIndex, _, _, _, _, _, hmiddleTree, hmiddleLeaf, hmiddleMessage, _⟩ | + hfailure + · have hbottomRoot := exact_middle_message_eq_bottom_root f secretKey signedMiddleIndex index + middleMessage hmiddleTree hmiddleLeaf hmiddleMessage + have hmiddleEval : evalWithAnswerFn f (layerMessage secretKey index middleLayer) + = middleMessage := by + rw [← hmiddleMessage] + congr 1 + exact (layerMessage_eq_of_position_eq secretKey signedMiddleIndex index middleLayer + hmiddleTree hmiddleLeaf).symm + have hbottomSettled := hsignedMiddle.settles_bottom hf + rcases layer_extract_from_settled_root_or_bad (ftsSecret := secretKey.ftsSecret) hfSmall + bottomLayer (treeIndexAt index bottomLayer) (leafIndexAt index bottomLayer) + (leafIndexAt_lt index bottomLayer) ftsPublicKey (signature.counter bottomLayer) + (signature.chainValue bottomLayer) (signaturePath signature bottomLayer) bottomLeaf + hbottom.1 (by simpa only [middleMessage] using hbottomRoot) + hbottomSmall.2.2.1 hbottomSmall.2.2.2.1 (hpreserved _ hbottomSettled) with hbad | hbottomOpening + · exact Or.inl hbad + · by_cases hsignedBottom : SignedLayerAt f cache secretKey signingLog bottomLayer + (treeIndexAt index bottomLayer) (leafIndexAt index bottomLayer) + · rcases hsignedBottom.exact_or_failure ftsPublicKey (signature.counter bottomLayer) + (signature.chainValue bottomLayer) (signaturePath signature bottomLayer) + hbottomOpening with + ⟨_, _, signedBottomIndex, _, _, _, _, _, hbottomTree, hbottomLeaf, + hbottomMessage, _⟩ | hfailure + · have hftsKey := exact_bottom_message_eq_fts_key f secretKey signedBottomIndex index + ftsPublicKey hbottomTree hbottomLeaf hbottomMessage + have hbottomEval : evalWithAnswerFn f (layerMessage secretKey index bottomLayer) + = ftsPublicKey := by + rw [← hbottomMessage] + congr 1 + exact (layerMessage_eq_of_position_eq secretKey signedBottomIndex index + bottomLayer hbottomTree hbottomLeaf).symm + have hftsSettled := hsignedBottom.settles_fts hf + rcases ftsRecover_extract_from_settled_roots_or_bad hfSmall index leaves + signature.ftsSecret signature.ftsPath (hftsPublicKey.trans hftsKey) hftsRun + (hpreserved _ hftsSettled) with hbad | hhonest + · exact Or.inl hbad + · right + right + have htopOpening' : HonestLayerOpening f secretKey.parameter + secretKey.otsSecret topLayer (treeIndexAt index topLayer) + (leafIndexAt index topLayer) + (evalWithAnswerFn f (layerMessage secretKey index topLayer)) + (signature.counter topLayer) (signature.chainValue topLayer) + (signaturePath signature topLayer) := by + rw [htopEval] + exact htopOpening + have hmiddleOpening' : HonestLayerOpening f secretKey.parameter + secretKey.otsSecret middleLayer (treeIndexAt index middleLayer) + (leafIndexAt index middleLayer) + (evalWithAnswerFn f (layerMessage secretKey index middleLayer)) + (signature.counter middleLayer) (signature.chainValue middleLayer) + (signaturePath signature middleLayer) := by + rw [hmiddleEval] + exact hmiddleOpening + have hbottomOpening' : HonestLayerOpening f secretKey.parameter + secretKey.otsSecret bottomLayer (treeIndexAt index bottomLayer) + (leafIndexAt index bottomLayer) + (evalWithAnswerFn f (layerMessage secretKey index bottomLayer)) + (signature.counter bottomLayer) (signature.chainValue bottomLayer) + (signaturePath signature bottomLayer) := by + rw [hbottomEval] + exact hbottomOpening + have htopRun' : CachedRun cache f (otsLeaf secretKey.parameter topLayer + (treeIndexAt index topLayer) (leafIndexAt index topLayer) + (evalWithAnswerFn f (layerMessage secretKey index topLayer)) + (signature.counter topLayer) (signature.chainValue topLayer)) := by + rw [htopEval] + exact htopRun + have hmiddleRun' : CachedRun cache f (otsLeaf secretKey.parameter middleLayer + (treeIndexAt index middleLayer) (leafIndexAt index middleLayer) + (evalWithAnswerFn f (layerMessage secretKey index middleLayer)) + (signature.counter middleLayer) (signature.chainValue middleLayer)) := by + rw [hmiddleEval] + exact hmiddle.2.2.1 + have hbottomRun' : CachedRun cache f (otsLeaf secretKey.parameter bottomLayer + (treeIndexAt index bottomLayer) (leafIndexAt index bottomLayer) + (evalWithAnswerFn f (layerMessage secretKey index bottomLayer)) + (signature.counter bottomLayer) (signature.chainValue bottomLayer)) := by + rw [hbottomEval] + exact hbottom.2.2.1 + refine ⟨⟨?_, hhonest, hftsRun.mono hle, ?_⟩, ?_⟩ + · intro lay + fin_cases lay + · exact ⟨by simpa only [topLayer] using htopOpening', by + simpa only [topLayer] using htopRun'⟩ + · exact ⟨by simpa only [middleLayer] using hmiddleOpening', by + simpa only [middleLayer] using hmiddleRun'⟩ + · exact ⟨by simpa only [bottomLayer, numLayers] using hbottomOpening', by + simpa only [bottomLayer, numLayers] using hbottomRun'⟩ + · intro lay + fin_cases lay + · rw [show (⟨0, by decide⟩ : Layer) = topLayer by rfl, htopEval] + exact hverifierTop + · rw [show (⟨1, by decide⟩ : Layer) = middleLayer by rfl, hmiddleEval] + exact hverifierMiddle + · rw [show (⟨2, by decide⟩ : Layer) = bottomLayer by rfl, hbottomEval] + exact hverifierBottom + · intro lay + fin_cases lay + · simpa only [topLayer] using htopSettled + · unfold LayerRootSettled + simpa only [middleLayer] using hmiddleSettled + · unfold LayerRootSettled + simpa only [bottomLayer, numLayers] using hbottomSettled + · exact Or.inr (Or.inl ⟨bottomLayer, ftsPublicKey, hbottomSettled, + hverifierBottom, hbottomOpening, hbottom.2.2.1, Or.inr hfailure⟩) + · exact Or.inr (Or.inl ⟨bottomLayer, ftsPublicKey, hbottomSettled, + hverifierBottom, hbottomOpening, hbottom.2.2.1, Or.inl hsignedBottom⟩) + · exact Or.inr (Or.inl ⟨middleLayer, middleMessage, hmiddleSettled, + hverifierMiddle, hmiddleOpening, hmiddle.2.2.1, Or.inr hfailure⟩) + · exact Or.inr (Or.inl ⟨middleLayer, middleMessage, hmiddleSettled, + hverifierMiddle, hmiddleOpening, hmiddle.2.2.1, Or.inl hsignedMiddle⟩) + · exact Or.inr (Or.inl ⟨topLayer, topMessage, htopSettled, hverifierTop, htopOpening, + htopRun, Or.inr hfailure⟩) + · exact Or.inr (Or.inl ⟨topLayer, topMessage, htopSettled, hverifierTop, htopOpening, + htopRun, Or.inl hsignedTop⟩) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/RomQueryCharge.lean b/formal/sphincs/SphincsSecurity/Proof/RomQueryCharge.lean new file mode 100644 index 00000000..f2f74c44 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/RomQueryCharge.lean @@ -0,0 +1,192 @@ +import SphincsSecurity.Proof.CacheSize +import SphincsSecurity.Proof.Charge + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +def hashQueryCharge (charge : QueryCache HashSpec → HashInput → ℝ≥0∞) + (cache : QueryCache HashSpec) : OracleWorld.Domain → ℝ≥0∞ := + Sum.elim (fun _ => 0) (charge cache) + +noncomputable def expectedQueryCharge {α : Type} + (charge : QueryCache HashSpec → HashInput → ℝ≥0∞) + (computation : OracleComp OracleWorld α) : QueryCache HashSpec → ℝ≥0∞ := + OracleComp.construct (fun _ _ => 0) + (fun query _ next cache => + hashQueryCharge charge cache query + + ∑' result, Pr[= result | (romImpl query).run cache] * next result.1 result.2) + computation + +@[simp] theorem expectedQueryCharge_pure {α : Type} + (charge : QueryCache HashSpec → HashInput → ℝ≥0∞) + (value : α) (cache : QueryCache HashSpec) : + expectedQueryCharge charge (pure value) cache = 0 := rfl + +theorem expectedQueryCharge_query_bind {α : Type} + (charge : QueryCache HashSpec → HashInput → ℝ≥0∞) + (query : OracleWorld.Domain) + (next : OracleWorld.Range query → OracleComp OracleWorld α) + (cache : QueryCache HashSpec) : + expectedQueryCharge charge (OracleSpec.query query >>= next) cache = + hashQueryCharge charge cache query + + ∑' result, Pr[= result | (romImpl query).run cache] * + expectedQueryCharge charge (next result.1) result.2 := by + cases query <;> rfl + +theorem romImpl_query_mass (query : OracleWorld.Domain) (cache : QueryCache HashSpec) : + (∑' result, Pr[= result | (romImpl query).run cache]) = 1 := by + cases query with + | inl input => + simp [romImpl, unifFwdImpl, QueryImpl.liftTarget, HasQuery.toQueryImpl, + StateT.run_monadLift] + | inr input => + change (∑' result, Pr[= result | (randomOracle input).run cache]) = 1 + by_cases hfresh : cache input = none + · rw [randomOracle, QueryImpl.withCaching_run_none _ hfresh] + simp [uniformSampleImpl] + · obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hfresh + rw [randomOracle, QueryImpl.withCaching_run_some _ hanswer] + simp + +theorem finite_of_mem_support_romImpl {query : OracleWorld.Domain} + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {result : OracleWorld.Range query × QueryCache HashSpec} + (hresult : result ∈ support ((romImpl query).run cache)) : Finite result.2 := by + cases query with + | inl input => + apply Finite.of_enncard_le (q := {input | cache input ≠ none}.ncard) + rw [romImpl_uniform_query_enncard_eq input cache result hresult, + hfinite.cachedInputs_ncard_toENNReal_eq_enncard] + | inr input => + apply Finite.of_enncard_le (q := {input | cache input ≠ none}.ncard + 1) + push_cast + rw [hfinite.cachedInputs_ncard_toENNReal_eq_enncard] + exact romImpl_hash_query_enncard_le input cache result hresult + +theorem expectedQueryCharge_add {α : Type} + (first second : QueryCache HashSpec → HashInput → ℝ≥0∞) + (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) : + expectedQueryCharge (fun cache input => first cache input + second cache input) + computation cache = + expectedQueryCharge first computation cache + expectedQueryCharge second computation cache := by + induction computation using OracleComp.inductionOn generalizing cache with + | pure value => simp + | query_bind query next ih => + simp only [expectedQueryCharge_query_bind, ih, mul_add, ENNReal.tsum_add] + cases query <;> simp only [hashQueryCharge, Sum.elim_inl, Sum.elim_inr] <;> ac_rfl + + +theorem expected_potential_simulateQ_le_queryCharge {α : Type} + (potential : QueryCache HashSpec → ℝ≥0∞) + (charge : QueryCache HashSpec → HashInput → ℝ≥0∞) + (hstep : ∀ (query : OracleWorld.Domain) (cache : QueryCache HashSpec), Finite cache → + (∑' result, Pr[= result | (romImpl query).run cache] * potential result.2) ≤ + potential cache + hashQueryCharge charge cache query) + (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) + (hfinite : Finite cache) : + (∑' result, Pr[= result | (simulateQ romImpl computation).run cache] * potential result.2) ≤ + potential cache + expectedQueryCharge charge computation cache := by + induction computation using OracleComp.inductionOn generalizing cache with + | pure value => simp [simulateQ_pure] + | query_bind query next ih => + rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, tsum_probOutput_bind_mul, + expectedQueryCharge_query_bind] + calc + _ ≤ ∑' result, Pr[= result | (romImpl query).run cache] * + (potential result.2 + expectedQueryCharge charge (next result.1) result.2) := by + apply ENNReal.tsum_le_tsum + intro result + by_cases hresult : result ∈ support ((romImpl query).run cache) + · exact mul_le_mul' le_rfl + (ih result.1 result.2 (finite_of_mem_support_romImpl hfinite hresult)) + · rw [probOutput_eq_zero_of_not_mem_support hresult, zero_mul, zero_mul] + _ = (∑' result, Pr[= result | (romImpl query).run cache] * potential result.2) + + ∑' result, Pr[= result | (romImpl query).run cache] * + expectedQueryCharge charge (next result.1) result.2 := by + simp_rw [mul_add, ENNReal.tsum_add] + _ ≤ (potential cache + + hashQueryCharge charge cache query) + + ∑' result, Pr[= result | (romImpl query).run cache] * + expectedQueryCharge charge (next result.1) result.2 := + add_le_add (hstep query cache hfinite) le_rfl + _ = _ := by rw [add_assoc] + +theorem expectedQueryCharge_le_queryBound {α : Type} + (charge : QueryCache HashSpec → HashInput → ℝ≥0∞) (cap : ℝ≥0∞) + (hcharge : ∀ cache input, charge cache input ≤ cap) + (computation : OracleComp OracleWorld α) : + ∀ q : Nat, computation.IsQueryBoundP (· matches Sum.inr _) q → + ∀ cache : QueryCache HashSpec, expectedQueryCharge charge computation cache ≤ cap * q := by + induction computation using OracleComp.inductionOn with + | pure value => intros; simp + | query_bind query next ih => + intro q hq cache + rw [isQueryBoundP_query_bind_iff] at hq + obtain ⟨hcan, hcont⟩ := hq + rw [expectedQueryCharge_query_bind] + cases query with + | inl input => + simp only [Bool.false_eq_true, if_false] at hcont + simp only [hashQueryCharge, Sum.elim_inl, zero_add] + calc + _ ≤ ∑' result, Pr[= result | (romImpl (.inl input)).run cache] * (cap * q) := + ENNReal.tsum_le_tsum fun result => mul_le_mul' le_rfl + (ih result.1 q (hcont result.1) result.2) + _ = _ := by rw [ENNReal.tsum_mul_right, romImpl_query_mass, one_mul] + | inr input => + simp only [hashQueryCharge, Sum.elim_inr] + simp only [if_true] at hcont + have hqPositive : 0 < q := by simpa using hcan + obtain ⟨remaining, rfl⟩ : ∃ remaining, q = remaining + 1 := + ⟨q - 1, by omega⟩ + simp only [Nat.add_sub_cancel] at hcont + calc + _ ≤ cap + ∑' result, + Pr[= result | (romImpl (.inr input)).run cache] * (cap * remaining) := + add_le_add (hcharge cache input) (ENNReal.tsum_le_tsum fun result => + mul_le_mul' le_rfl (ih result.1 remaining (hcont result.1) result.2)) + _ = cap + cap * remaining := by + rw [ENNReal.tsum_mul_right, romImpl_query_mass, one_mul] + _ = _ := by push_cast; ring + + +theorem expectedQueryCharge_mul {α : Type} + (charge : QueryCache HashSpec → HashInput → ℝ≥0∞) (factor : ℝ≥0∞) + (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) : + expectedQueryCharge (fun cache input => charge cache input * factor) computation cache = + expectedQueryCharge charge computation cache * factor := by + induction computation using OracleComp.inductionOn generalizing cache with + | pure value => simp + | query_bind query next ih => + simp only [expectedQueryCharge_query_bind, ih] + simp_rw [← mul_assoc, ENNReal.tsum_mul_right] + cases query <;> simp only [hashQueryCharge, Sum.elim_inl, Sum.elim_inr] <;> ring + +theorem expected_potential_romImpl_le_charge + (potential : QueryCache HashSpec → ℝ≥0∞) + (charge : QueryCache HashSpec → HashInput → ℝ≥0∞) + (hfresh : ∀ cache : QueryCache HashSpec, Finite cache → ∀ input : HashInput, + cache input = none → + (∑' answer : HashOutput, Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + potential (cache.cacheQuery input answer)) ≤ potential cache + charge cache input) + (query : OracleWorld.Domain) (cache : QueryCache HashSpec) (hfinite : Finite cache) : + (∑' result, Pr[= result | (romImpl query).run cache] * potential result.2) ≤ + potential cache + hashQueryCharge charge cache query := by + cases query with + | inl input => + simp [romImpl, unifFwdImpl, QueryImpl.liftTarget, HasQuery.toQueryImpl, + StateT.run_monadLift, tsum_probOutput_map_mul, hashQueryCharge] + rw [← mul_assoc, ENNReal.mul_inv_cancel (by positivity) (by finiteness), one_mul] + | inr input => + change (∑' result, Pr[= result | (randomOracle input).run cache] * potential result.2) ≤ + potential cache + charge cache input + by_cases huncached : cache input = none + · rw [randomOracle, QueryImpl.withCaching_run_none _ huncached, + tsum_probOutput_map_mul] + exact hfresh cache hfinite input huncached + · obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp huncached + rw [randomOracle, QueryImpl.withCaching_run_some _ hanswer] + simp + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/RomQueryChargeBind.lean b/formal/sphincs/SphincsSecurity/Proof/RomQueryChargeBind.lean new file mode 100644 index 00000000..32eaaf81 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/RomQueryChargeBind.lean @@ -0,0 +1,27 @@ +import SphincsSecurity.Proof.RomQueryCharge +import SphincsSecurity.Proof.AdaptiveRevealProbeCharge + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +theorem expectedQueryCharge_bind + (charge : QueryCache HashSpec → HashInput → ℝ≥0∞) + (computation : OracleComp OracleWorld α) (next : α → OracleComp OracleWorld β) + (cache : QueryCache HashSpec) : + expectedQueryCharge charge (computation >>= next) cache = + expectedQueryCharge charge computation cache + + ∑' result, Pr[= result | (simulateQ romImpl computation).run cache] * + expectedQueryCharge charge (next result.1) result.2 := by + induction computation using OracleComp.inductionOn generalizing cache with + | pure value => + simp only [pure_bind, expectedQueryCharge_pure, simulateQ_pure, StateT.run_pure, + tsum_probOutput_pure_mul, zero_add] + | query_bind query continuation ih => + rw [bind_assoc, expectedQueryCharge_query_bind, expectedQueryCharge_query_bind, + simulateQ_query_bind, StateT.run_bind, tsum_probOutput_bind_mul] + simp_rw [ih, mul_add, ENNReal.tsum_add, ← ENNReal.tsum_mul_left] + rw [add_assoc] + rfl + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/RootCache.lean b/formal/sphincs/SphincsSecurity/Proof/RootCache.lean new file mode 100644 index 00000000..bee13d6c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/RootCache.lean @@ -0,0 +1,343 @@ +import SphincsSecurity.Proof.Position +import SphincsSecurity.Proof.StatementLemmas +import SphincsSecurity.Proof.Support + +/-! +# The key-generation cache contains no message query + +Key generation evaluates only structural hashes. Consequently its cache, which starts empty, cannot +already contain a message-digest input when the adversary begins. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +/-- Every query on the selected execution path is the honest query at a structural position. -/ +def QueriesAtPositions {alpha : Type} (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (oa : OracleComp HashSpec alpha) : Prop := + ∀ input, input ∈ queriedInputs f oa → + ∃ p : Position, ∃ payload : HashInput, + input = tweakableHashInput parameter p.domain payload + +theorem QueriesAtPositions.pure {alpha : Type} (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (value : alpha) : + QueriesAtPositions parameter f (pure value) := by + simp [QueriesAtPositions] + +theorem QueriesAtPositions.bind {alpha beta : Type} {parameter : PublicParameter} + {f : QueryImpl HashSpec Id} {oa : OracleComp HashSpec alpha} + {next : alpha → OracleComp HashSpec beta} + (hleft : QueriesAtPositions parameter f oa) + (hright : QueriesAtPositions parameter f (next (evalWithAnswerFn f oa))) : + QueriesAtPositions parameter f (oa >>= next) := by + intro input hinput + rw [queriedInputs_bind] at hinput + rcases List.mem_append.mp hinput with hinput | hinput + · exact hleft input hinput + · exact hright input hinput + +theorem QueriesAtPositions.tweakableHash (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (p : Position) (payload : HashInput) : + QueriesAtPositions parameter f + (Concrete.tweakableHash parameter p.domain payload) := by + intro input hinput + simp only [queriedInputs_tweakableHash, List.mem_singleton] at hinput + subst input + exact ⟨p, payload, rfl⟩ + +theorem encodingInput_ne_positionInput (parameter : PublicParameter) + (encodingLay : Layer) (encodingTree : TreeIndex) + (encodingLeaf : LeafIndex) (encodingPayload : HashInput) + (position : Position) (payload : HashInput) : + tweakableHashInput parameter + (.encoding encodingLay encodingTree encodingLeaf) encodingPayload ≠ + tweakableHashInput parameter position.domain payload := by + intro heq + have hdomain := (tweakableHashInput_injective parameter (by trivial) + position.domain_inRange heq).1 + cases position <;> simp [Position.domain] at hdomain + +namespace Concrete + +theorem queriesAtPositions_sequenceFin {alpha : Type} {n : Nat} + (parameter : PublicParameter) (f : QueryImpl HashSpec Id) + (computation : Fin n → OracleComp HashSpec alpha) + (hcomputation : ∀ index, QueriesAtPositions parameter f (computation index)) : + QueriesAtPositions parameter f (sequenceFin computation) := by + induction n with + | zero => exact QueriesAtPositions.pure parameter f _ + | succ n ih => + rw [sequenceFin] + apply QueriesAtPositions.bind (hcomputation 0) + apply QueriesAtPositions.bind + · exact ih (fun index : Fin n => computation index.succ) + (fun index => hcomputation index.succ) + · exact QueriesAtPositions.pure parameter f _ + +theorem queriesAtPositions_chainWalk (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (start steps : Nat) (value : Digest) : + QueriesAtPositions parameter f + (chainWalk parameter lay tree leafIdx chainIdx start steps value) := by + induction steps with + | zero => exact QueriesAtPositions.pure parameter f value + | succ steps ih => + rw [chainWalk] + apply QueriesAtPositions.bind ih + split_ifs with hstep + · exact QueriesAtPositions.tweakableHash parameter f + (.chain lay tree leafIdx chainIdx ⟨start + steps, hstep⟩) _ + · exact QueriesAtPositions.pure parameter f _ + +theorem queriesAtPositions_oneTimePublicKey (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (secret : ChainIndex → Digest) : + QueriesAtPositions parameter f + (oneTimePublicKey parameter lay tree leafIdx secret) := by + apply queriesAtPositions_sequenceFin + intro chainIdx + exact queriesAtPositions_chainWalk parameter f lay tree leafIdx chainIdx 0 + (chainLength - 1) (secret chainIdx) + +def RootTreeRange (level nodeIdx : Nat) : Prop := + 2 ^ level * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight + +private theorem RootTreeRange.index_lt {level nodeIdx : Nat} + (h : RootTreeRange level nodeIdx) : nodeIdx < 2 ^ maxLayerHeight := by + have hpow : 1 ≤ 2 ^ level := one_le_pow₀ (by omega) + simp only [RootTreeRange] at h + nlinarith + +private theorem RootTreeRange.left {level nodeIdx : Nat} + (h : RootTreeRange (level + 1) nodeIdx) : RootTreeRange level (2 * nodeIdx) := by + simp only [RootTreeRange, pow_succ] at h ⊢ + nlinarith [Nat.zero_le (2 ^ level), Nat.zero_le nodeIdx] + +private theorem RootTreeRange.right {level nodeIdx : Nat} + (h : RootTreeRange (level + 1) nodeIdx) : RootTreeRange level (2 * nodeIdx + 1) := by + simp only [RootTreeRange, pow_succ] at h ⊢ + nlinarith [Nat.zero_le (2 ^ level), Nat.zero_le nodeIdx] + +theorem queriesAtPositions_treeNode (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) (level nodeIdx : Nat) + (hlevel : level ≤ maxLayerHeight) (hrange : RootTreeRange level nodeIdx) : + QueriesAtPositions parameter f (treeNode parameter lay tree secret level nodeIdx) := by + induction level generalizing nodeIdx with + | zero => + rw [treeNode_zero_eq] + apply QueriesAtPositions.bind + · exact queriesAtPositions_oneTimePublicKey parameter f lay tree (leafOfNat nodeIdx) + (secret (leafOfNat nodeIdx)) + · exact QueriesAtPositions.tweakableHash parameter f + (.leaf lay tree (leafOfNat nodeIdx)) _ + | succ level ih => + rw [treeNode_succ_eq] + apply QueriesAtPositions.bind + · exact ih (2 * nodeIdx) (by omega) (RootTreeRange.left hrange) + apply QueriesAtPositions.bind + · exact ih (2 * nodeIdx + 1) (by omega) (RootTreeRange.right hrange) + · exact QueriesAtPositions.tweakableHash parameter f + (.node lay tree ⟨level, by omega⟩ ⟨nodeIdx, hrange.index_lt⟩) _ + +theorem queriesAtPositions_treeRoot (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) : + QueriesAtPositions parameter f (treeRoot parameter lay tree secret) := by + apply queriesAtPositions_treeNode parameter f lay tree secret (layerHeight lay) 0 + · exact layerHeight_le lay + · simp only [RootTreeRange, zero_add, mul_one] + exact pow_le_pow_right' (by omega) (layerHeight_le lay) + +theorem messageInput_not_mem_queriedInputs_treeRoot (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) (payload : HashInput) : + tweakableHashInput parameter .message payload ∉ + queriedInputs f (treeRoot parameter lay tree secret) := by + intro hmem + obtain ⟨p, structuralPayload, heq⟩ := + queriesAtPositions_treeRoot parameter f lay tree secret _ hmem + have hdomain := (tweakableHashInput_injective parameter + (show HashDomain.message.InRange from trivial) p.domain_inRange heq).1 + cases p <;> simp [Position.domain] at hdomain + +theorem encodingInput_not_mem_queriedInputs_treeRoot (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) (encodingLay : Layer) + (encodingTree : TreeIndex) (encodingLeaf : LeafIndex) (payload : HashInput) : + tweakableHashInput parameter (.encoding encodingLay encodingTree encodingLeaf) payload ∉ + queriedInputs f (treeRoot parameter lay tree secret) := by + intro hmem + obtain ⟨p, structuralPayload, heq⟩ := + queriesAtPositions_treeRoot parameter f lay tree secret _ hmem + have hdomain := (tweakableHashInput_injective parameter + (show (HashDomain.encoding encodingLay encodingTree encodingLeaf).InRange from trivial) + p.domain_inRange heq).1 + cases p <;> simp [Position.domain] at hdomain + +theorem treeRoot_cache_message_none (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (secret : LeafIndex → ChainIndex → Digest) + (root : Digest) (rootCache : QueryCache HashSpec) + (hroot : (root, rootCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter lay tree secret)).run ∅)) + (payload : HashInput) : + rootCache (tweakableHashInput parameter .message payload) = none := by + obtain ⟨f, hf⟩ := QueryCache.exists_agreesWithFn (spec := HashSpec) rootCache + apply cache_eq_none_of_not_mem_queriedInputs + (treeRoot parameter lay tree secret) ∅ root rootCache hroot f hf + · simp + · exact messageInput_not_mem_queriedInputs_treeRoot parameter f lay tree secret payload + +theorem treeRoot_cache_encoding_none (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (secret : LeafIndex → ChainIndex → Digest) + (root : Digest) (rootCache : QueryCache HashSpec) + (hroot : (root, rootCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter lay tree secret)).run ∅)) + (encodingLay : Layer) (encodingTree : TreeIndex) (encodingLeaf : LeafIndex) + (payload : HashInput) : + rootCache + (tweakableHashInput parameter (.encoding encodingLay encodingTree encodingLeaf) payload) = + none := by + obtain ⟨f, hf⟩ := QueryCache.exists_agreesWithFn (spec := HashSpec) rootCache + apply cache_eq_none_of_not_mem_queriedInputs + (treeRoot parameter lay tree secret) ∅ root rootCache hroot f hf + · simp + · exact encodingInput_not_mem_queriedInputs_treeRoot parameter f lay tree secret + encodingLay encodingTree encodingLeaf payload + +def AvoidsFtsLeafQueries {alpha : Type} (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (oa : OracleComp HashSpec alpha) : Prop := + ∀ index tree leafIdx payload, + tweakableHashInput parameter (.ftsLeaf index tree leafIdx) payload ∉ queriedInputs f oa + +theorem AvoidsFtsLeafQueries.pure {alpha : Type} (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (value : alpha) : + AvoidsFtsLeafQueries parameter f (pure value) := by + simp [AvoidsFtsLeafQueries] + +theorem AvoidsFtsLeafQueries.bind {alpha beta : Type} {parameter : PublicParameter} + {f : QueryImpl HashSpec Id} {oa : OracleComp HashSpec alpha} + {next : alpha → OracleComp HashSpec beta} + (hleft : AvoidsFtsLeafQueries parameter f oa) + (hright : AvoidsFtsLeafQueries parameter f (next (evalWithAnswerFn f oa))) : + AvoidsFtsLeafQueries parameter f (oa >>= next) := by + intro index tree leafIdx payload hinput + rw [queriedInputs_bind] at hinput + rcases List.mem_append.mp hinput with hinput | hinput + · exact hleft index tree leafIdx payload hinput + · exact hright index tree leafIdx payload hinput + +theorem AvoidsFtsLeafQueries.tweakableHash (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (domain : HashDomain) (payload : HashInput) + (hinRange : domain.InRange) + (hdomain : ∀ index tree leafIdx, domain ≠ .ftsLeaf index tree leafIdx) : + AvoidsFtsLeafQueries parameter f (Concrete.tweakableHash parameter domain payload) := by + intro index tree leafIdx candidate hinput + simp only [queriedInputs_tweakableHash, List.mem_singleton] at hinput + apply hdomain index tree leafIdx + exact (tweakableHashInput_injective parameter hinRange (by trivial) hinput.symm).1 + +theorem avoidsFtsLeafQueries_sequenceFin {alpha : Type} {n : Nat} + (parameter : PublicParameter) (f : QueryImpl HashSpec Id) + (computation : Fin n → OracleComp HashSpec alpha) + (hcomputation : ∀ index, AvoidsFtsLeafQueries parameter f (computation index)) : + AvoidsFtsLeafQueries parameter f (sequenceFin computation) := by + induction n with + | zero => exact AvoidsFtsLeafQueries.pure parameter f _ + | succ n ih => + rw [sequenceFin] + apply AvoidsFtsLeafQueries.bind (hcomputation 0) + apply AvoidsFtsLeafQueries.bind + · exact ih (fun index : Fin n => computation index.succ) + (fun index => hcomputation index.succ) + · exact AvoidsFtsLeafQueries.pure parameter f _ + +theorem avoidsFtsLeafQueries_chainWalk (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (chainIdx : ChainIndex) (start steps : Nat) (value : Digest) : + AvoidsFtsLeafQueries parameter f + (chainWalk parameter lay tree leafIdx chainIdx start steps value) := by + induction steps with + | zero => exact AvoidsFtsLeafQueries.pure parameter f value + | succ steps ih => + rw [chainWalk] + apply AvoidsFtsLeafQueries.bind ih + split_ifs with hstep + · apply AvoidsFtsLeafQueries.tweakableHash + · trivial + intro _ _ _ hdomain + exact HashDomain.noConfusion hdomain + · exact AvoidsFtsLeafQueries.pure parameter f _ + +theorem avoidsFtsLeafQueries_oneTimePublicKey (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (secret : ChainIndex → Digest) : + AvoidsFtsLeafQueries parameter f + (oneTimePublicKey parameter lay tree leafIdx secret) := by + apply avoidsFtsLeafQueries_sequenceFin + intro chainIdx + exact avoidsFtsLeafQueries_chainWalk parameter f lay tree leafIdx chainIdx 0 + (chainLength - 1) (secret chainIdx) + +theorem avoidsFtsLeafQueries_treeNode (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) (level nodeIdx : Nat) + (hlevel : level ≤ maxLayerHeight) (hrange : RootTreeRange level nodeIdx) : + AvoidsFtsLeafQueries parameter f (treeNode parameter lay tree secret level nodeIdx) := by + induction level generalizing nodeIdx with + | zero => + rw [treeNode_zero_eq] + apply AvoidsFtsLeafQueries.bind + · exact avoidsFtsLeafQueries_oneTimePublicKey parameter f lay tree (leafOfNat nodeIdx) + (secret (leafOfNat nodeIdx)) + · apply AvoidsFtsLeafQueries.tweakableHash + · trivial + intro _ _ _ hdomain + exact HashDomain.noConfusion hdomain + | succ level ih => + rw [treeNode_succ_eq] + apply AvoidsFtsLeafQueries.bind + · exact ih (2 * nodeIdx) (by omega) (RootTreeRange.left hrange) + apply AvoidsFtsLeafQueries.bind + · exact ih (2 * nodeIdx + 1) (by omega) (RootTreeRange.right hrange) + · apply AvoidsFtsLeafQueries.tweakableHash + · simp only [HashDomain.InRange] + constructor + · norm_num [maxLayerHeight] at hlevel ⊢ + omega + · have hnode := hrange.index_lt + norm_num [maxLayerHeight] at hnode ⊢ + omega + intro _ _ _ hdomain + exact HashDomain.noConfusion hdomain + +theorem avoidsFtsLeafQueries_treeRoot (parameter : PublicParameter) + (f : QueryImpl HashSpec Id) (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) : + AvoidsFtsLeafQueries parameter f (treeRoot parameter lay tree secret) := by + apply avoidsFtsLeafQueries_treeNode parameter f lay tree secret (layerHeight lay) 0 + · exact layerHeight_le lay + · simp only [RootTreeRange, zero_add, mul_one] + exact pow_le_pow_right' (by omega) (layerHeight_le lay) + +theorem treeRoot_cache_ftsLeaf_none (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (secret : LeafIndex → ChainIndex → Digest) + (root : Digest) (rootCache : QueryCache HashSpec) + (hroot : (root, rootCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter lay tree secret)).run ∅)) + (index : Index) (ftsTree : FtsTree) (leafIdx : FtsLeaf) (payload : HashInput) : + rootCache (tweakableHashInput parameter (.ftsLeaf index ftsTree leafIdx) payload) = none := by + obtain ⟨f, hf⟩ := QueryCache.exists_agreesWithFn (spec := HashSpec) rootCache + apply cache_eq_none_of_not_mem_queriedInputs + (treeRoot parameter lay tree secret) ∅ root rootCache hroot f hf + · simp + · exact avoidsFtsLeafQueries_treeRoot parameter f lay tree secret + index ftsTree leafIdx payload + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Sampling.lean b/formal/sphincs/SphincsSecurity/Proof/Sampling.lean new file mode 100644 index 00000000..77a46f89 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Sampling.lean @@ -0,0 +1,333 @@ +import SphincsSecurity.Proof.Guess +import VCVio.OracleComp.Constructions.SampleableType +import VCVio.OracleComp.QueryTracking.RandomOracle.EagerTable + +/-! +# Marginals of the sampled secret tables + +The statement samples whole finite function tables uniformly. Every fixed coordinate is therefore +a uniform digest, without expanding the sampler's function-type `Fintype` instance. +-/ + +namespace SphincsSecurity + +open OracleComp ENNReal + +noncomputable local instance {R : Type} [Fintype R] [Nonempty R] : SampleableType R := + SampleableType.ofFintype R + +theorem evalDist_uniform_function_bind_cell_extract {D R β : Type} + [Fintype D] [DecidableEq D] [Fintype R] [DecidableEq R] [Nonempty R] + (index : D) (cont : (D → R) → R → ProbComp β) : + 𝒟[do + let table ← ($ᵗ (D → R) : ProbComp (D → R)) + cont table (table index)] = + 𝒟[do + let value ← ($ᵗ R : ProbComp R) + let table ← ($ᵗ (D → R) : ProbComp (D → R)) + cont (Function.update table index value) value] := by + classical + have hleft : + (do + let table ← ($ᵗ (D → R) : ProbComp (D → R)) + cont table (table index)) = + ((do + let table ← ($ᵗ (D → R) : ProbComp (D → R)) + pure (table, table index)) >>= fun pair => cont pair.1 pair.2) := by + simp + have hright : + (do + let value ← ($ᵗ R : ProbComp R) + let table ← ($ᵗ (D → R) : ProbComp (D → R)) + cont (Function.update table index value) value) = + ((do + let value ← ($ᵗ R : ProbComp R) + let table ← ($ᵗ (D → R) : ProbComp (D → R)) + pure (Function.update table index value, value)) >>= + fun pair => cont pair.1 pair.2) := by + simp + rw [hleft, hright] + have hpureEq : ∀ (table : D → R) (value : R), + (Function.update table index value, value) = + ((fun table' : D → R => (table', table' index)) + (Function.update table index value)) := fun _ _ => by simp + have hcore : + 𝒟[do + let value ← ($ᵗ R : ProbComp R) + let table ← ($ᵗ (D → R) : ProbComp (D → R)) + pure (Function.update table index value, value)] = + 𝒟[do + let table ← ($ᵗ (D → R) : ProbComp (D → R)) + pure (table, table index)] := by + have hrw : + (do + let value ← ($ᵗ R : ProbComp R) + let table ← ($ᵗ (D → R) : ProbComp (D → R)) + pure (Function.update table index value, value)) = + (do + let value ← ($ᵗ R : ProbComp R) + let table ← ($ᵗ (D → R) : ProbComp (D → R)) + pure ((fun table' : D → R => (table', table' index)) + (Function.update table index value))) := + bind_congr fun value => bind_congr fun table => by rw [hpureEq table value] + rw [hrw] + exact OracleComp.evalDist_uniformSample_bind_update_map (R := R) index + (fun table' => (table', table' index)) + refine evalDist_ext fun output => ?_ + rw [probOutput_bind_eq_tsum, probOutput_bind_eq_tsum] + refine tsum_congr fun pair => ?_ + rw [show Pr[= pair | (do + let table ← ($ᵗ (D → R) : ProbComp (D → R)) + pure (table, table index))] = + Pr[= pair | (do + let value ← ($ᵗ R : ProbComp R) + let table ← ($ᵗ (D → R) : ProbComp (D → R)) + pure (Function.update table index value, value))] from + probOutput_congr rfl hcore.symm] + +theorem evalDist_uniform_function_bind_cell_extract3 {I J K R β : Type} + [Fintype I] [DecidableEq I] [Nonempty I] + [Fintype J] [DecidableEq J] [Nonempty J] + [Fintype K] [DecidableEq K] [Nonempty K] + [Fintype R] [DecidableEq R] [Nonempty R] + (i : I) (j : J) (k : K) (cont : (I → J → K → R) → R → ProbComp β) : + 𝒟[do + let table ← ($ᵗ (I → J → K → R) : ProbComp (I → J → K → R)) + cont table (table i j k)] = + 𝒟[do + let value ← ($ᵗ R : ProbComp R) + let rowK ← ($ᵗ (K → R) : ProbComp (K → R)) + let rowJ ← ($ᵗ (J → K → R) : ProbComp (J → K → R)) + let table ← ($ᵗ (I → J → K → R) : ProbComp (I → J → K → R)) + cont (Function.update table i + (Function.update rowJ j (Function.update rowK k value))) value] := by + calc + 𝒟[do + let table ← ($ᵗ (I → J → K → R) : ProbComp (I → J → K → R)) + cont table (table i j k)] = + 𝒟[do + let rowJ ← ($ᵗ (J → K → R) : ProbComp (J → K → R)) + let table ← ($ᵗ (I → J → K → R) : ProbComp (I → J → K → R)) + cont (Function.update table i rowJ) (rowJ j k)] := + evalDist_uniform_function_bind_cell_extract i + (fun table rowJ => cont table (rowJ j k)) + _ = 𝒟[do + let rowK ← ($ᵗ (K → R) : ProbComp (K → R)) + let rowJ ← ($ᵗ (J → K → R) : ProbComp (J → K → R)) + let table ← ($ᵗ (I → J → K → R) : ProbComp (I → J → K → R)) + cont (Function.update table i (Function.update rowJ j rowK)) (rowK k)] := + evalDist_uniform_function_bind_cell_extract j (fun rowJ rowK => do + let table ← ($ᵗ (I → J → K → R) : ProbComp (I → J → K → R)) + cont (Function.update table i rowJ) (rowK k)) + _ = 𝒟[do + let value ← ($ᵗ R : ProbComp R) + let rowK ← ($ᵗ (K → R) : ProbComp (K → R)) + let rowJ ← ($ᵗ (J → K → R) : ProbComp (J → K → R)) + let table ← ($ᵗ (I → J → K → R) : ProbComp (I → J → K → R)) + cont (Function.update table i + (Function.update rowJ j (Function.update rowK k value))) value] := + evalDist_uniform_function_bind_cell_extract k (fun rowK value => do + let rowJ ← ($ᵗ (J → K → R) : ProbComp (J → K → R)) + let table ← ($ᵗ (I → J → K → R) : ProbComp (I → J → K → R)) + cont (Function.update table i (Function.update rowJ j rowK)) value) + +theorem evalDist_uniform_function_bind_cell_extract4 {I J K L R β : Type} + [Fintype I] [DecidableEq I] [Nonempty I] + [Fintype J] [DecidableEq J] [Nonempty J] + [Fintype K] [DecidableEq K] [Nonempty K] + [Fintype L] [DecidableEq L] [Nonempty L] + [Fintype R] [DecidableEq R] [Nonempty R] + (i : I) (j : J) (k : K) (l : L) + (cont : (I → J → K → L → R) → R → ProbComp β) : + 𝒟[do + let table ← ($ᵗ (I → J → K → L → R) : ProbComp (I → J → K → L → R)) + cont table (table i j k l)] = + 𝒟[do + let value ← ($ᵗ R : ProbComp R) + let rowL ← ($ᵗ (L → R) : ProbComp (L → R)) + let rowK ← ($ᵗ (K → L → R) : ProbComp (K → L → R)) + let rowJ ← ($ᵗ (J → K → L → R) : ProbComp (J → K → L → R)) + let table ← ($ᵗ (I → J → K → L → R) : ProbComp (I → J → K → L → R)) + cont (Function.update table i (Function.update rowJ j + (Function.update rowK k (Function.update rowL l value)))) value] := by + calc + 𝒟[do + let table ← ($ᵗ (I → J → K → L → R) : ProbComp (I → J → K → L → R)) + cont table (table i j k l)] = + 𝒟[do + let rowJ ← ($ᵗ (J → K → L → R) : ProbComp (J → K → L → R)) + let table ← ($ᵗ (I → J → K → L → R) : ProbComp (I → J → K → L → R)) + cont (Function.update table i rowJ) (rowJ j k l)] := + evalDist_uniform_function_bind_cell_extract i + (fun table rowJ => cont table (rowJ j k l)) + _ = 𝒟[do + let rowK ← ($ᵗ (K → L → R) : ProbComp (K → L → R)) + let rowJ ← ($ᵗ (J → K → L → R) : ProbComp (J → K → L → R)) + let table ← ($ᵗ (I → J → K → L → R) : ProbComp (I → J → K → L → R)) + cont (Function.update table i (Function.update rowJ j rowK)) (rowK k l)] := + evalDist_uniform_function_bind_cell_extract j (fun rowJ rowK => do + let table ← ($ᵗ (I → J → K → L → R) : ProbComp (I → J → K → L → R)) + cont (Function.update table i rowJ) (rowK k l)) + _ = 𝒟[do + let rowL ← ($ᵗ (L → R) : ProbComp (L → R)) + let rowK ← ($ᵗ (K → L → R) : ProbComp (K → L → R)) + let rowJ ← ($ᵗ (J → K → L → R) : ProbComp (J → K → L → R)) + let table ← ($ᵗ (I → J → K → L → R) : ProbComp (I → J → K → L → R)) + cont (Function.update table i + (Function.update rowJ j (Function.update rowK k rowL))) (rowL l)] := + evalDist_uniform_function_bind_cell_extract k (fun rowK rowL => do + let rowJ ← ($ᵗ (J → K → L → R) : ProbComp (J → K → L → R)) + let table ← ($ᵗ (I → J → K → L → R) : ProbComp (I → J → K → L → R)) + cont (Function.update table i (Function.update rowJ j rowK)) (rowL l)) + _ = 𝒟[do + let value ← ($ᵗ R : ProbComp R) + let rowL ← ($ᵗ (L → R) : ProbComp (L → R)) + let rowK ← ($ᵗ (K → L → R) : ProbComp (K → L → R)) + let rowJ ← ($ᵗ (J → K → L → R) : ProbComp (J → K → L → R)) + let table ← ($ᵗ (I → J → K → L → R) : ProbComp (I → J → K → L → R)) + cont (Function.update table i (Function.update rowJ j + (Function.update rowK k (Function.update rowL l value)))) value] := + evalDist_uniform_function_bind_cell_extract l (fun rowL value => do + let rowK ← ($ᵗ (K → L → R) : ProbComp (K → L → R)) + let rowJ ← ($ᵗ (J → K → L → R) : ProbComp (J → K → L → R)) + let table ← ($ᵗ (I → J → K → L → R) : ProbComp (I → J → K → L → R)) + cont (Function.update table i + (Function.update rowJ j (Function.update rowK k rowL))) value) + +theorem evalDist_uniform_function_eval {I R : Type} [Fintype I] [DecidableEq I] [Nonempty I] + [Fintype R] [DecidableEq R] [Nonempty R] (index : I) : + 𝒟[(fun table : I → R => table index) <$> ($ᵗ (I → R) : ProbComp (I → R))] = + 𝒟[($ᵗ R : ProbComp R)] := by + let embed : Unit → I := fun _ => index + have hembed : Function.Injective embed := by + intro left right _ + cases left + cases right + rfl + let evaluate : (Unit → R) → R := fun table => table () + have hevaluate : Function.Bijective evaluate := by + constructor + · intro left right heq + funext input + cases input + exact heq + · intro value + exact ⟨fun _ => value, rfl⟩ + have hrestrict : + 𝒟[(fun table : I → R => table ∘ embed) <$> ($ᵗ (I → R) : ProbComp (I → R))] = + 𝒟[($ᵗ (Unit → R) : ProbComp (Unit → R))] := by + simpa only [bind_pure_comp] using + evalDist_uniformSample_map_comp_injective (R := R) hembed + have hmarginal : 𝒟[evaluate <$> ((fun table : I → R => table ∘ embed) <$> + ($ᵗ (I → R) : ProbComp (I → R)))] = 𝒟[($ᵗ R : ProbComp R)] := by + rw [evalDist_map, hrestrict, ← evalDist_map] + exact evalDist_map_bijective_uniform_cross + (α := Unit → R) (β := R) evaluate hevaluate + simpa [map_eq_bind_pure_comp, bind_assoc, evaluate, embed] using hmarginal + +theorem uniform_function_coordinate_probability {I R : Type} + [Fintype I] [DecidableEq I] [Nonempty I] [Fintype R] [DecidableEq R] [Nonempty R] + (index : I) (target : R) : + Pr[fun table : I → R => table index = target | ($ᵗ (I → R) : ProbComp (I → R))] = + ((Fintype.card R : Nat) : ℝ≥0∞)⁻¹ := by + calc + Pr[fun table : I → R => table index = target | ($ᵗ (I → R) : ProbComp (I → R))] = + Pr[fun value : R => value = target | + (fun table : I → R => table index) <$> ($ᵗ (I → R) : ProbComp (I → R))] := by + rw [probEvent_map] + rfl + _ = Pr[fun value : R => value = target | ($ᵗ R : ProbComp R)] := + probEvent_congr' (fun _ _ => Iff.rfl) (evalDist_uniform_function_eval index) + _ = ((Fintype.card R : Nat) : ℝ≥0∞)⁻¹ := by + simp only [probEvent_eq_eq_probOutput, probOutput_uniformSample] + +theorem evalDist_uniform_function_eval3 {I J K R : Type} + [Fintype I] [DecidableEq I] [Nonempty I] + [Fintype J] [DecidableEq J] [Nonempty J] + [Fintype K] [DecidableEq K] [Nonempty K] + [Fintype R] [DecidableEq R] [Nonempty R] (i : I) (j : J) (k : K) : + 𝒟[(fun table : I → J → K → R => table i j k) <$> + ($ᵗ (I → J → K → R) : ProbComp (I → J → K → R))] = + 𝒟[($ᵗ R : ProbComp R)] := by + have h1 := evalDist_uniform_function_eval (R := J → K → R) i + have h2 := evalDist_uniform_function_eval (R := K → R) j + have h3 := evalDist_uniform_function_eval (R := R) k + have htail : 𝒟[(fun tail : K → R => tail k) <$> + ((fun slice : J → K → R => slice j) <$> ($ᵗ (J → K → R) : ProbComp (J → K → R)))] = + 𝒟[($ᵗ R : ProbComp R)] := by + rw [evalDist_map, h2, ← evalDist_map] + exact h3 + have htail' : 𝒟[(fun slice : J → K → R => slice j k) <$> + ($ᵗ (J → K → R) : ProbComp (J → K → R))] = 𝒟[($ᵗ R : ProbComp R)] := by + simpa [map_eq_bind_pure_comp, bind_assoc] using htail + have hnested : 𝒟[(fun slice : J → K → R => slice j k) <$> + ((fun table : I → J → K → R => table i) <$> + ($ᵗ (I → J → K → R) : ProbComp (I → J → K → R)))] = 𝒟[($ᵗ R : ProbComp R)] := by + rw [evalDist_map, h1, ← evalDist_map] + exact htail' + simpa [map_eq_bind_pure_comp, bind_assoc] using hnested + +theorem uniform_function_coordinate3_probability {I J K R : Type} + [Fintype I] [DecidableEq I] [Nonempty I] + [Fintype J] [DecidableEq J] [Nonempty J] + [Fintype K] [DecidableEq K] [Nonempty K] + [Fintype R] [DecidableEq R] [Nonempty R] + (i : I) (j : J) (k : K) (target : R) : + Pr[fun table : I → J → K → R => table i j k = target | + ($ᵗ (I → J → K → R) : ProbComp (I → J → K → R))] = + ((Fintype.card R : Nat) : ℝ≥0∞)⁻¹ := by + calc + Pr[fun table : I → J → K → R => table i j k = target | + ($ᵗ (I → J → K → R) : ProbComp (I → J → K → R))] = + Pr[fun value : R => value = target | + (fun table : I → J → K → R => table i j k) <$> + ($ᵗ (I → J → K → R) : ProbComp (I → J → K → R))] := by + rw [probEvent_map] + rfl + _ = Pr[fun value : R => value = target | ($ᵗ R : ProbComp R)] := + probEvent_congr' (fun _ _ => Iff.rfl) (evalDist_uniform_function_eval3 i j k) + _ = ((Fintype.card R : Nat) : ℝ≥0∞)⁻¹ := by + simp only [probEvent_eq_eq_probOutput, probOutput_uniformSample] + +theorem evalDist_uniform_function_eval4 {I J K L R : Type} + [Fintype I] [DecidableEq I] [Nonempty I] + [Fintype J] [DecidableEq J] [Nonempty J] + [Fintype K] [DecidableEq K] [Nonempty K] + [Fintype L] [DecidableEq L] [Nonempty L] + [Fintype R] [DecidableEq R] [Nonempty R] (i : I) (j : J) (k : K) (l : L) : + 𝒟[(fun table : I → J → K → L → R => table i j k l) <$> + ($ᵗ (I → J → K → L → R) : ProbComp (I → J → K → L → R))] = + 𝒟[($ᵗ R : ProbComp R)] := by + have h1 := evalDist_uniform_function_eval (R := J → K → L → R) i + have h2 := evalDist_uniform_function_eval3 (I := J) (J := K) (K := L) (R := R) j k l + have hnested : 𝒟[(fun slice : J → K → L → R => slice j k l) <$> + ((fun table : I → J → K → L → R => table i) <$> + ($ᵗ (I → J → K → L → R) : ProbComp (I → J → K → L → R)))] = 𝒟[($ᵗ R : ProbComp R)] := by + rw [evalDist_map, h1, ← evalDist_map] + exact h2 + simpa [map_eq_bind_pure_comp, bind_assoc] using hnested + +theorem uniform_function_coordinate4_probability {I J K L R : Type} + [Fintype I] [DecidableEq I] [Nonempty I] + [Fintype J] [DecidableEq J] [Nonempty J] + [Fintype K] [DecidableEq K] [Nonempty K] + [Fintype L] [DecidableEq L] [Nonempty L] + [Fintype R] [DecidableEq R] [Nonempty R] + (i : I) (j : J) (k : K) (l : L) (target : R) : + Pr[fun table : I → J → K → L → R => table i j k l = target | + ($ᵗ (I → J → K → L → R) : ProbComp (I → J → K → L → R))] = + ((Fintype.card R : Nat) : ℝ≥0∞)⁻¹ := by + calc + Pr[fun table : I → J → K → L → R => table i j k l = target | + ($ᵗ (I → J → K → L → R) : ProbComp (I → J → K → L → R))] = + Pr[fun value : R => value = target | + (fun table : I → J → K → L → R => table i j k l) <$> + ($ᵗ (I → J → K → L → R) : ProbComp (I → J → K → L → R))] := by + rw [probEvent_map] + rfl + _ = Pr[fun value : R => value = target | ($ᵗ R : ProbComp R)] := + probEvent_congr' (fun _ _ => Iff.rfl) (evalDist_uniform_function_eval4 i j k l) + _ = ((Fintype.card R : Nat) : ℝ≥0∞)⁻¹ := by + simp only [probEvent_eq_eq_probOutput, probOutput_uniformSample] + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/SecretProbe.lean b/formal/sphincs/SphincsSecurity/Proof/SecretProbe.lean new file mode 100644 index 00000000..49b69999 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SecretProbe.lean @@ -0,0 +1,251 @@ +import SphincsSecurity.Proof.Sampling +import SphincsSecurity.Proof.Honest +import SphincsSecurity.Proof.Slot + +/-! +# Adaptive probes into a sampled secret table + +A hash input names one structural coordinate and carries one candidate value. Up to the first +correct candidate, an adaptive strategy sees only misses. Its coordinate and candidate at every +such step are therefore fixed by the all-miss history, so a table with per-cell mass at most +`epsilon` is hit with probability at most `q * epsilon`. There is no union over table coordinates. +-/ + +namespace SphincsSecurity + +open OracleComp ENNReal + +variable {D R : Type} [DecidableEq R] + +/-- Run at most `q` adaptive coordinate-and-value probes against one fixed table. -/ +noncomputable def readTableMany (table : D → R) : Nat → (List Bool → D × R) → Bool + | 0, _ => false + | q + 1, strategy => + let probe := strategy [] + let hit := decide (table probe.1 = probe.2) + hit || readTableMany table q (fun history => strategy (hit :: history)) + +/-- Before the first hit, the strategy follows its all-miss path. -/ +theorem readTableMany_true_iff (table : D → R) (q : Nat) + (strategy : List Bool → D × R) : + readTableMany table q strategy = true ↔ + ∃ j < q, + let probe := strategy (List.replicate j false) + table probe.1 = probe.2 := by + induction q generalizing strategy with + | zero => simp [readTableMany] + | succ q ih => + rw [readTableMany] + simp only [Bool.or_eq_true, decide_eq_true_eq] + constructor + · rintro (h | h) + · exact ⟨0, Nat.succ_pos q, by simpa using h⟩ + · by_cases hhead : table (strategy []).1 = (strategy []).2 + · exact ⟨0, Nat.succ_pos q, by simpa using hhead⟩ + · rw [decide_eq_false (by simpa using hhead)] at h + obtain ⟨j, hj, hprobe⟩ := + (ih (fun history => strategy (false :: history))).1 h + exact ⟨j + 1, Nat.succ_lt_succ hj, by + simpa [List.replicate_succ] using hprobe⟩ + · rintro ⟨j, hj, hprobe⟩ + cases j with + | zero => left; simpa using hprobe + | succ j => + by_cases hhead : table (strategy []).1 = (strategy []).2 + · exact Or.inl hhead + · refine Or.inr ?_ + rw [decide_eq_false (by simpa using hhead)] + exact (ih (fun history => strategy (false :: history))).2 + ⟨j, Nat.lt_of_succ_lt_succ hj, by + simpa [List.replicate_succ] using hprobe⟩ + +/-- Sample one table and probe it adaptively. -/ +noncomputable def hiddenTableReadMany (tables : ProbComp (D → R)) (q : Nat) + (strategy : List Bool → D × R) : ProbComp Bool := + tables >>= fun table => pure (readTableMany table q strategy) + +/-- Adaptive table-cell first-fire bound. Each probe pays only for its chosen cell. -/ +theorem probEvent_hiddenTableReadMany_le {tables : ProbComp (D → R)} {ε : ℝ≥0∞} + (hε : ∀ coordinate candidate, + Pr[fun table : D → R => table coordinate = candidate | tables] ≤ ε) + (q : Nat) (strategy : List Bool → D × R) : + Pr[fun hit : Bool => hit = true | hiddenTableReadMany tables q strategy] ≤ + (q : ℝ≥0∞) * ε := by + rw [hiddenTableReadMany, probEvent_bind_eq_tsum] + have hstep : ∀ table : D → R, + Pr[= table | tables] * + Pr[fun hit : Bool => hit = true | + (pure (readTableMany table q strategy) : ProbComp Bool)] ≤ + ∑ j ∈ Finset.range q, + let probe := strategy (List.replicate j false) + if table probe.1 = probe.2 then Pr[= table | tables] else 0 := by + intro table + by_cases hhit : readTableMany table q strategy = true + · rw [probEvent_pure] + simp only [hhit, if_true, mul_one] + obtain ⟨j, hj, hprobe⟩ := (readTableMany_true_iff table q strategy).1 hhit + calc + Pr[= table | tables] = + (let probe := strategy (List.replicate j false) + if table probe.1 = probe.2 then Pr[= table | tables] else 0) := by + simp only + rw [if_pos hprobe] + _ ≤ ∑ j ∈ Finset.range q, + let probe := strategy (List.replicate j false) + if table probe.1 = probe.2 then Pr[= table | tables] else 0 := + Finset.single_le_sum + (f := fun j => + let probe := strategy (List.replicate j false) + if table probe.1 = probe.2 then Pr[= table | tables] else 0) + (fun _ _ => by positivity) (Finset.mem_range.2 hj) + · rw [probEvent_pure, if_neg hhit, mul_zero] + exact zero_le + refine le_trans (ENNReal.tsum_le_tsum hstep) ?_ + rw [Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)] + calc + ∑ j ∈ Finset.range q, ∑' table : D → R, + (let probe := strategy (List.replicate j false) + if table probe.1 = probe.2 then Pr[= table | tables] else 0) ≤ + ∑ j ∈ Finset.range q, ε := by + refine Finset.sum_le_sum fun j _ => ?_ + let probe := strategy (List.replicate j false) + rw [show (∑' table : D → R, + if table probe.1 = probe.2 then Pr[= table | tables] else 0) = + Pr[fun table : D → R => table probe.1 = probe.2 | tables] by + rw [probEvent_eq_tsum_ite]] + exact hε probe.1 probe.2 + _ = (q : ℝ≥0∞) * ε := by + rw [Finset.sum_const, Finset.card_range, nsmul_eq_mul] + +structure TableCoordinate3 (I J K : Type) where + first : I + second : J + third : K + +noncomputable def uncurriedTable3 {I J K R : Type} (table : I → J → K → R) : + TableCoordinate3 I J K → R := + fun coordinate => table coordinate.first coordinate.second coordinate.third + +noncomputable local instance {T : Type} [Fintype T] [Nonempty T] : SampleableType T := + SampleableType.ofFintype T + +/-- Uniform curried function tables have the required per-cell marginal. -/ +theorem probEvent_uniformCurriedTable3ReadMany_le {I J K R : Type} + [Fintype I] [DecidableEq I] [Nonempty I] + [Fintype J] [DecidableEq J] [Nonempty J] + [Fintype K] [DecidableEq K] [Nonempty K] + [Fintype R] [DecidableEq R] [Nonempty R] + (q : Nat) (strategy : List Bool → TableCoordinate3 I J K × R) : + Pr[fun hit : Bool => hit = true | + hiddenTableReadMany + (uncurriedTable3 <$> ($ᵗ (I → J → K → R) : ProbComp (I → J → K → R))) + q strategy] ≤ + (q : ℝ≥0∞) * ((Fintype.card R : Nat) : ℝ≥0∞)⁻¹ := by + apply probEvent_hiddenTableReadMany_le + intro coordinate candidate + rw [probEvent_map] + exact le_of_eq (uniform_function_coordinate3_probability coordinate.first coordinate.second + coordinate.third candidate) + +namespace Concrete + +structure FtsSecretProbe where + index : Index + tree : FtsTree + leafIdx : FtsLeaf + candidate : Digest +deriving DecidableEq + +def FtsSecretProbe.coordinate (probe : FtsSecretProbe) : + TableCoordinate3 Index FtsTree FtsLeaf := + ⟨probe.index, probe.tree, probe.leafIdx⟩ + +def FtsSecretProbe.input (parameter : PublicParameter) (probe : FtsSecretProbe) : HashInput := + tweakableHashInput parameter (.ftsLeaf probe.index probe.tree probe.leafIdx) + (digestBytes probe.candidate) + +def FtsSecretProbe.Hits + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (probe : FtsSecretProbe) : Prop := + ftsSecret probe.index probe.tree probe.leafIdx = probe.candidate + +theorem FtsSecretProbe.input_injective (parameter : PublicParameter) : + Function.Injective (FtsSecretProbe.input parameter) := by + intro left right heq + have hparts := tweakableHashInput_injective parameter (by trivial) (by trivial) heq + have hdomain : left.index = right.index ∧ left.tree = right.tree ∧ + left.leafIdx = right.leafIdx := by + simpa only [HashDomain.ftsLeaf.injEq] using hparts.1 + have hcandidate : left.candidate = right.candidate := digestBytes_injective hparts.2 + cases left + cases right + simp only [FtsSecretProbe.mk.injEq] at hdomain hcandidate ⊢ + exact ⟨hdomain.1, hdomain.2.1, hdomain.2.2, hcandidate⟩ + +theorem FtsSecretProbe.input_eq_honestInput_iff + (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (probe : FtsSecretProbe) : + probe.input parameter = + honestInput f parameter otsSecret ftsSecret + (.ftsLeaf probe.index probe.tree probe.leafIdx) ↔ + probe.Hits ftsSecret := by + constructor + · intro heq + have hpayload := + (tweakableHashInput_injective parameter (by trivial) (by trivial) heq).2 + exact (digestBytes_injective hpayload).symm + · intro hhit + simp only [FtsSecretProbe.input, honestInput, honestPayload, Position.domain] + rw [hhit] + +structure OtsValueProbe where + lay : Layer + tree : TreeIndex + leafIdx : LeafIndex + chainIdx : ChainIndex + digit : Digit + candidate : Digest +deriving DecidableEq + +def OtsValueProbe.target (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (probe : OtsValueProbe) : Digest := + honestChain f parameter probe.lay probe.tree probe.leafIdx probe.chainIdx + (otsSecret probe.lay probe.tree probe.leafIdx probe.chainIdx) probe.digit.val + +def OtsValueProbe.Hits (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (probe : OtsValueProbe) : Prop := + probe.candidate = probe.target f parameter otsSecret + +def OtsValueProbe.MatchesInput (parameter : PublicParameter) + (probe : OtsValueProbe) (input : HashInput) : Prop := + (∃ step : ChainStep, + probe.digit.val = step.val ∧ + input = tweakableHashInput parameter + (.chain probe.lay probe.tree probe.leafIdx probe.chainIdx step) + (digestBytes probe.candidate)) ∨ + (probe.digit.val = chainLength - 1 ∧ probe.chainIdx.val = 0 ∧ + ∃ payload : HashInput, + input = tweakableHashInput parameter + (.leaf probe.lay probe.tree probe.leafIdx) payload ∧ + slotDigest 0 input = probe.candidate) + +theorem OtsValueProbe.target_zero {f : QueryImpl HashSpec Id} {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {probe : OtsValueProbe} (hzero : probe.digit.val = 0) : + probe.target f parameter otsSecret = + otsSecret probe.lay probe.tree probe.leafIdx probe.chainIdx := by + simp only [OtsValueProbe.target, hzero, honestChain_zero] + +theorem OtsValueProbe.target_succ {f : QueryImpl HashSpec Id} {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {probe : OtsValueProbe} {step : ChainStep} (hdigit : probe.digit.val = step.val + 1) : + probe.target f parameter otsSecret = + honestValue f parameter otsSecret (fun _ _ _ => 0) + (.chain probe.lay probe.tree probe.leafIdx probe.chainIdx step) := by + rw [OtsValueProbe.target, honestValue_chain, hdigit] + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/SecretProbeTerminal.lean b/formal/sphincs/SphincsSecurity/Proof/SecretProbeTerminal.lean new file mode 100644 index 00000000..766f69de --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SecretProbeTerminal.lean @@ -0,0 +1,232 @@ +import SphincsSecurity.Proof.SecretProbe +import SphincsSecurity.Proof.TerminalSampling + +/-! +# Few-time terminal witnesses expose an exact secret probe + +The uncovered-secret terminal branch already retains the exact few-time leaf-hash input used by +verification. This module packages that input as one coordinate-and-candidate probe into the sampled +few-time table. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +theorem UncoveredFtsSecret.exists_hit_probe + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {index : Index} {leaves : DigestTree → FtsLeaf} + {secrets : FtsTree → Digest} + (huncovered : UncoveredFtsSecret f cache secretKey signingLog index leaves secrets) : + ∃ probe : FtsSecretProbe, + probe.Hits secretKey.ftsSecret + ∧ cache (probe.input secretKey.parameter) ≠ none + ∧ ¬ SignedFtsLeaf f cache secretKey signingLog probe.index probe.tree probe.leafIdx := by + obtain ⟨tree, hnotSigned, hsecret, hcached⟩ := huncovered + let probe : FtsSecretProbe := + ⟨index, tree, leaves (ftsIndexOf tree), secrets tree⟩ + exact ⟨probe, hsecret.symm, hcached, hnotSigned⟩ + +theorem ViewedUncoveredFtsSecretWitness.exists_hit_probe + {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {result : (Digest × Forgery × Bool) × ViewedFullTraceState} + (hwitness : ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result) : + ∃ probe : FtsSecretProbe, + probe.Hits ftsSecret ∧ result.2.cache (probe.input parameter) ≠ none := by + obtain ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, huncovered⟩ := hwitness + obtain ⟨probe, hhit, hcached, _⟩ := huncovered.exists_hit_probe + exact ⟨probe, hhit, hcached⟩ + +theorem cleanUncoveredEvent_exists_hit_probe + {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {result : (Digest × Forgery × Bool) × ViewedFullTraceState} + (hevent : cleanUncoveredEvent parameter otsSecret ftsSecret result) : + ∃ probe : FtsSecretProbe, + probe.Hits ftsSecret ∧ result.2.cache (probe.input parameter) ≠ none := + hevent.2.exists_hit_probe + +theorem FreshLayerOpening.exists_hit_probe + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} + (hfresh : FreshLayerOpening f cache secretKey signingLog) : + ∃ probe : OtsValueProbe, + probe.Hits f secretKey.parameter secretKey.otsSecret + ∧ ¬ SignedLayerAt f cache secretKey signingLog probe.lay probe.tree probe.leafIdx := by + obtain ⟨lay, tree, leafIdx, message, counter, values, path, hopening, hcached, + hnotSigned⟩ := hfresh + obtain ⟨codeword, hencode, hvalues, hpath⟩ := hopening + let chainIdx : ChainIndex := ⟨0, by decide⟩ + let probe : OtsValueProbe := + ⟨lay, tree, leafIdx, chainIdx, codeword chainIdx, values chainIdx⟩ + exact ⟨probe, hvalues chainIdx, hnotSigned⟩ + +theorem BackwardChainOpening.exists_hit_probe + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} + (hbackward : BackwardChainOpening f cache secretKey signingLog) : + ∃ (probe : OtsValueProbe) (signedDigit : Digit), + probe.Hits f secretKey.parameter secretKey.otsSecret + ∧ probe.digit.val < signedDigit.val := by + obtain ⟨lay, tree, leafIdx, forgedMessage, forgedCounter, forgedValues, forgedPath, + entry, signature, index, leaves, signedCodeword, forgedCodeword, hforgedOpening, + hforgedRun, hentry, hresponse, hsignRun, hdigest, htree, hleaf, hmessage, + hsignedOpening, hsignedCached, hsigned, hforged, chainIdx, hlt⟩ := hbackward + obtain ⟨openingCodeword, hopeningEncode, hforgedValues, _⟩ := hforgedOpening + have hcodeword : openingCodeword = forgedCodeword := + Option.some.inj (hopeningEncode.symm.trans hforged) + let probe : OtsValueProbe := + ⟨lay, tree, leafIdx, chainIdx, forgedCodeword chainIdx, forgedValues chainIdx⟩ + refine ⟨probe, signedCodeword chainIdx, ?_, hlt⟩ + simpa only [OtsValueProbe.Hits, OtsValueProbe.target, probe, hcodeword] using + hforgedValues chainIdx + +theorem slotDigest_leafPayload_zero (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (endpoints : ChainIndex → Digest) (chainIdx : ChainIndex) (hzero : chainIdx.val = 0) : + slotDigest 0 (tweakableHashInput parameter (.leaf lay tree leafIdx) + (leafPayload endpoints)) = endpoints chainIdx := by + unfold leafPayload + rw [slotDigest_flatMap parameter (.leaf lay tree leafIdx) (List.ofFn endpoints) 0 + (by norm_num [numChains])] + simp only [List.getElem_ofFn] + congr 1 + exact Fin.ext (by simpa using hzero.symm) + +theorem FreshLayerOpening.exists_hit_probe_cached + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} + (hfresh : FreshLayerOpening f cache secretKey signingLog) : + ∃ (probe : OtsValueProbe) (input : HashInput), + probe.Hits f secretKey.parameter secretKey.otsSecret ∧ + ¬ SignedLayerAt f cache secretKey signingLog probe.lay probe.tree probe.leafIdx ∧ + probe.MatchesInput secretKey.parameter input ∧ cache input ≠ none := by + obtain ⟨lay, tree, leafIdx, message, counter, values, path, hopening, hcached, + hnotSigned⟩ := hfresh + obtain ⟨codeword, hencode, hvalues, hpath⟩ := hopening + let chainIdx : ChainIndex := ⟨0, by decide⟩ + let probe : OtsValueProbe := + ⟨lay, tree, leafIdx, chainIdx, codeword chainIdx, values chainIdx⟩ + have hhit : probe.Hits f secretKey.parameter secretKey.otsSecret := hvalues chainIdx + by_cases hdigit : (codeword chainIdx).val < chainLength - 1 + · let step : ChainStep := ⟨(codeword chainIdx).val, hdigit⟩ + let input := tweakableHashInput secretKey.parameter + (.chain lay tree leafIdx chainIdx step) (digestBytes (values chainIdx)) + have hquery : input ∈ queriedInputs f + (otsLeaf secretKey.parameter lay tree leafIdx message counter values) := by + simpa only [input, step, Nat.add_zero, walkValue, chainWalk, + evalWithAnswerFn_pure] using + otsLeaf_chain_query_mem f secretKey.parameter lay tree leafIdx message counter values + codeword hencode chainIdx 0 (by omega) hdigit + refine ⟨probe, input, hhit, hnotSigned, Or.inl ⟨step, rfl, rfl⟩, hcached input hquery⟩ + · have hdigitLast : (codeword chainIdx).val = chainLength - 1 := by + have := (codeword chainIdx).isLt + omega + let endpoints := fun otherChain : ChainIndex => + walkValue f secretKey.parameter lay tree leafIdx otherChain + (codeword otherChain).val (values otherChain) + (chainLength - 1 - (codeword otherChain).val) + let input := tweakableHashInput secretKey.parameter (.leaf lay tree leafIdx) + (leafPayload endpoints) + have hquery : input ∈ queriedInputs f + (otsLeaf secretKey.parameter lay tree leafIdx message counter values) := by + exact otsLeaf_leaf_query_mem f secretKey.parameter lay tree leafIdx message counter values + codeword hencode + have hslot : slotDigest 0 input = probe.candidate := by + rw [show slotDigest 0 input = endpoints chainIdx from + slotDigest_leafPayload_zero secretKey.parameter lay tree leafIdx endpoints chainIdx rfl] + simp only [endpoints, probe, chainIdx, hdigitLast, Nat.sub_self, walkValue, chainWalk, + evalWithAnswerFn_pure] + refine ⟨probe, input, hhit, hnotSigned, Or.inr ⟨hdigitLast, rfl, ?_⟩, + hcached input hquery⟩ + exact ⟨leafPayload endpoints, rfl, hslot⟩ + +theorem BackwardChainOpening.exists_hit_probe_cached + {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} + (hbackward : BackwardChainOpening f cache secretKey signingLog) : + ∃ (probe : OtsValueProbe) (signedDigit : Digit) (input : HashInput), + probe.Hits f secretKey.parameter secretKey.otsSecret ∧ + probe.digit.val < signedDigit.val ∧ + probe.MatchesInput secretKey.parameter input ∧ cache input ≠ none := by + obtain ⟨lay, tree, leafIdx, forgedMessage, forgedCounter, forgedValues, forgedPath, + entry, signature, index, leaves, signedCodeword, forgedCodeword, hforgedOpening, + hforgedRun, hentry, hresponse, hsignRun, hdigest, htree, hleaf, hmessage, + hsignedOpening, hsignedCached, hsigned, hforged, chainIdx, hlt⟩ := hbackward + obtain ⟨openingCodeword, hopeningEncode, hforgedValues, hpath⟩ := hforgedOpening + have hcodeword : openingCodeword = forgedCodeword := + Option.some.inj (hopeningEncode.symm.trans hforged) + let probe : OtsValueProbe := + ⟨lay, tree, leafIdx, chainIdx, forgedCodeword chainIdx, forgedValues chainIdx⟩ + have hhit : probe.Hits f secretKey.parameter secretKey.otsSecret := by + simpa only [OtsValueProbe.Hits, OtsValueProbe.target, probe, hcodeword] using + hforgedValues chainIdx + have hdigit : (forgedCodeword chainIdx).val < chainLength - 1 := by + have hsignedLt := (signedCodeword chainIdx).isLt + omega + have hdigitOpening : (openingCodeword chainIdx).val < chainLength - 1 := by + rw [hcodeword] + exact hdigit + let step : ChainStep := ⟨(openingCodeword chainIdx).val, hdigitOpening⟩ + let input := tweakableHashInput secretKey.parameter + (.chain lay tree leafIdx chainIdx step) (digestBytes (forgedValues chainIdx)) + have hquery : input ∈ queriedInputs f + (otsLeaf secretKey.parameter lay tree leafIdx forgedMessage forgedCounter forgedValues) := by + simpa only [input, step, Nat.add_zero, walkValue, chainWalk, + evalWithAnswerFn_pure] using + otsLeaf_chain_query_mem f secretKey.parameter lay tree leafIdx forgedMessage forgedCounter + forgedValues openingCodeword hopeningEncode chainIdx 0 (by omega) hdigitOpening + exact ⟨probe, signedCodeword chainIdx, input, hhit, hlt, + Or.inl ⟨step, by simp [probe, step, hcodeword], rfl⟩, hforgedRun input hquery⟩ + +theorem ViewedFreshLayerOpeningWitness.exists_hit_probe + {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {result : (Digest × Forgery × Bool) × ViewedFullTraceState} + (hwitness : ViewedFreshLayerOpeningWitness parameter otsSecret ftsSecret result) : + ∃ (f : QueryImpl HashSpec Id) (probe : OtsValueProbe), + result.2.cache.AgreesWithFn f ∧ probe.Hits f parameter otsSecret := by + obtain ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hfresh⟩ := hwitness + obtain ⟨probe, hhit, _⟩ := hfresh.toForged.toFreshLayerOpening.exists_hit_probe + exact ⟨f, probe, hf, hhit⟩ + +theorem ViewedBackwardChainOpeningWitness.exists_hit_probe + {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {result : (Digest × Forgery × Bool) × ViewedFullTraceState} + (hwitness : ViewedBackwardChainOpeningWitness parameter otsSecret ftsSecret result) : + ∃ (f : QueryImpl HashSpec Id) (probe : OtsValueProbe) (signedDigit : Digit), + result.2.cache.AgreesWithFn f ∧ probe.Hits f parameter otsSecret + ∧ probe.digit.val < signedDigit.val := by + obtain ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hbackward⟩ := hwitness + obtain ⟨probe, signedDigit, hhit, hlt⟩ := + hbackward.toForged.toBackwardChainOpening.exists_hit_probe + exact ⟨f, probe, signedDigit, hf, hhit, hlt⟩ + +theorem cleanFreshEvent_exists_hit_probe + {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {result : (Digest × Forgery × Bool) × ViewedFullTraceState} + (hevent : cleanFreshEvent parameter otsSecret ftsSecret result) : + ∃ (f : QueryImpl HashSpec Id) (probe : OtsValueProbe), + result.2.cache.AgreesWithFn f ∧ probe.Hits f parameter otsSecret := + ViewedFreshLayerOpeningWitness.exists_hit_probe hevent.2.toViewed + +theorem cleanBackwardEvent_exists_hit_probe + {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {result : (Digest × Forgery × Bool) × ViewedFullTraceState} + (hevent : cleanBackwardEvent parameter otsSecret ftsSecret result) : + ∃ (f : QueryImpl HashSpec Id) (probe : OtsValueProbe) (signedDigit : Digit), + result.2.cache.AgreesWithFn f ∧ probe.Hits f parameter otsSecret + ∧ probe.digit.val < signedDigit.val := + ViewedBackwardChainOpeningWitness.exists_hit_probe hevent.2.toViewed + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/Secrets.lean b/formal/sphincs/SphincsSecurity/Proof/Secrets.lean new file mode 100644 index 00000000..7340de29 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Secrets.lean @@ -0,0 +1,95 @@ +import SphincsSecurity.Proof.Game + +/-! +# Splitting the game at the secrets + +The honest structure is a function of the sampled secrets and of the oracle's answers, so a bound +that mentions it has to be stated after the secrets are fixed and before any hash query is made. +Key generation samples them and then builds layer `0`'s tree, so the split is inside key generation +rather than after it: what follows the split makes every hash query the experiment makes, and the +accounting therefore starts from the empty cache, at potential `0`, and with nothing to prove about +what key generation leaves behind. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +namespace Concrete + +/-- The game from the sampled secrets on: build the root, then run the adversary against the signer +and verify what it returns. -/ +noncomputable def gameAfterSecrets (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : OracleComp OracleWorld Bool := do + let root ← liftM + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : OracleComp HashSpec Digest) + gameRest scheme adversary ⟨root, parameter⟩ ⟨parameter, root, otsSecret, ftsSecret⟩ + +attribute [local semireducible] keygen + +theorem gameCore_eq_secrets (adversary : Adversary) : + gameCore scheme adversary = (do + let parameter ← liftM sampleParameter + let otsSecret ← liftM sampleOtsSecrets + let ftsSecret ← liftM sampleFtsSecrets + gameAfterSecrets adversary parameter otsSecret ftsSecret) := by + rw [gameCore_eq] + simp only [scheme, keygen, gameAfterSecrets, bind_assoc, pure_bind] + +/-- Lifting a sampling into the game's oracles changes nothing about where it lands. -/ +theorem mem_support_liftM_of_mem_support {α : Type} {oa : ProbComp α} {x : α} + (hmem : x ∈ support oa) : x ∈ support (liftM oa : OracleComp OracleWorld α) := by + rwa [← liftComp_eq_liftM, support_liftComp] + +/-- A lifted sampling passes through the semantics untouched: it samples, and the cache it hands on +is the one it was given. -/ +theorem simulateQ_romImpl_liftM_bind_run' {α β : Type} (oa : ProbComp α) + (k : α → OracleComp OracleWorld β) (cache : QueryCache HashSpec) : + (simulateQ romImpl ((liftM oa : OracleComp OracleWorld α) >>= k)).run' cache + = oa >>= fun x => (simulateQ romImpl (k x)).run' cache := by + rw [simulateQ_bind, StateT.run'_eq, StateT.run_bind, + show simulateQ romImpl (liftM oa : OracleComp OracleWorld α) + = simulateQ (unifFwdImpl HashSpec) oa from QueryImpl.simulateQ_add_liftM_left _ _ oa, + unifFwdImpl.simulateQ_run] + simp [map_eq_bind_pure_comp, bind_assoc, StateT.run'_eq] + +/-- **The reduction's frame.** A bound on the game after the secrets are sampled, uniform in them, +is a bound on the advantage. -/ +theorem forgeAdvantage_le_secrets (adversary : Adversary) (c : ℝ≥0∞) + (h : ∀ parameter ∈ support sampleParameter, ∀ otsSecret ∈ support sampleOtsSecrets, + ∀ ftsSecret ∈ support sampleFtsSecrets, + Pr[= true | (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run' ∅] ≤ c) : + forgeAdvantage scheme adversary ≤ c := by + rw [forgeAdvantage, gameCore_eq_secrets, simulateQ_romImpl_liftM_bind_run', + ← probEvent_eq_eq_probOutput] + refine probEvent_bind_le_of_forall_le fun parameter hparameter => ?_ + rw [probEvent_eq_eq_probOutput, simulateQ_romImpl_liftM_bind_run', ← probEvent_eq_eq_probOutput] + refine probEvent_bind_le_of_forall_le fun otsSecret hots => ?_ + rw [probEvent_eq_eq_probOutput, simulateQ_romImpl_liftM_bind_run', ← probEvent_eq_eq_probOutput] + refine probEvent_bind_le_of_forall_le fun ftsSecret hfts => ?_ + rw [probEvent_eq_eq_probOutput] + exact h parameter hparameter otsSecret hots ftsSecret hfts + +/-- The query bound survives the split: what bounds the whole experiment bounds what follows the +secrets. -/ +theorem isQueryBoundP_gameAfterSecrets (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) {parameter : PublicParameter} + (hparameter : parameter ∈ support sampleParameter) + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + (hots : otsSecret ∈ support sampleOtsSecrets) + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + (gameAfterSecrets adversary parameter otsSecret ftsSecret).IsQueryBoundP + (· matches Sum.inr _) q := by + rw [HasHashQueryBound, gameCore_eq_secrets] at hq + exact isQueryBoundP_of_bind + (isQueryBoundP_of_bind + (isQueryBoundP_of_bind hq parameter (mem_support_liftM_of_mem_support hparameter)) + otsSecret (mem_support_liftM_of_mem_support hots)) + ftsSecret (mem_support_liftM_of_mem_support hfts) + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Security125Completion.lean b/formal/sphincs/SphincsSecurity/Proof/Security125Completion.lean new file mode 100644 index 00000000..2980c57e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Security125Completion.lean @@ -0,0 +1,80 @@ +import SphincsSecurity.Proof.OtsProbeDiagnosticJoint125 +import SphincsSecurity.Proof.Security125Endpoint + +namespace SphincsSecurity.Concrete.OtsProbeSimulation.Range125 + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] maskedPublishedTreeRoot + +set_option maxRecDepth 100000 in +theorem probEvent_jointBoundary_failed_le_twenty_three_sevenths_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[fun output => output.outcome.failed = true | + sampledGranularAllCanonicalBoundaryWitnessSnapshot adversary parameter ftsSecret q] ≤ + ((23 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + have hfuel : 2 * q < Fintype.card Digest := by + rw [show Fintype.card Digest = 2 ^ digestBits by simp] + norm_num [digestBits] at hq ⊢ + omega + apply (probEvent_sampledJointSnapshot_failed_le_diagnostic_add_residual adversary parameter + ftsSecret q hbound).trans + calc + _ ≤ ((15 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ + + ((8 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + add_le_add + (probEvent_sampledDiagnostic_bad_le_fifteen_sevenths_mul adversary parameter + ftsSecret q hfuel hbound hq) + (probEvent_jointResidual_le_eight_sevenths_mul adversary parameter ftsSecret q hbound hq) + _ = _ := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul, ENNReal.toReal_div, ENNReal.toReal_natCast, + ENNReal.toReal_inv, ENNReal.toReal_ofNat] + ring + +set_option maxRecDepth 100000 in +theorem probEvent_sampledActualRetained_verifyProbe_le_twenty_three_sevenths_mul + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ table root, + (simulateQ + (SphincsSecurity.expandedAdversaryImpl + (⟨parameter, root, tableOtsSecret (extendStartTable table), ftsSecret⟩ : SecretKey)) + (retainedGameRestComputation adversary ⟨root, parameter⟩)).IsQueryBoundP + (fun query => query matches Sum.inr _) q) + (hq : q ≤ 2 ^ 125) : + Pr[fun result => WinningRetainedVerifyProbeWitness parameter + (extendStartTable result.1) ftsSecret result.2 | + sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + ((23 / 7 : ENNReal) * q) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := + (probEvent_sampledActualRetained_verifyProbe_le_jointBoundaryFailed adversary parameter + ftsSecret q).trans + (probEvent_jointBoundary_failed_le_twenty_three_sevenths_mul adversary parameter + ftsSecret q hbound hq) + +set_option maxRecDepth 100000 in +theorem security125_of_completed_joint_boundary : HasClassicalSecurityBits Concrete.scheme 125 := by + apply security125_of_sampledVerifyProbe_le_seven_mul_inv129 + intro q _hqPos adversary hq hqMax parameter hparameter ftsSecret hfts + have hbound := probEvent_sampledActualRetained_verifyProbe_le_twenty_three_sevenths_mul + adversary parameter ftsSecret q + (fun table root => isQueryBoundP_expandedRetained_all_tables_roots adversary q hq + parameter hparameter table ftsSecret hfts root) hqMax + apply hbound.trans + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + simp only [ENNReal.toReal_mul, ENNReal.toReal_div, ENNReal.toReal_natCast, + ENNReal.toReal_inv, ENNReal.toReal_ofNat, Nat.cast_mul, Nat.cast_ofNat] + norm_num [digestBits] + have hnonnegative : (0 : ℝ) ≤ (q : ℝ) := Nat.cast_nonneg q + linarith + +end SphincsSecurity.Concrete.OtsProbeSimulation.Range125 diff --git a/formal/sphincs/SphincsSecurity/Proof/Security125Endpoint.lean b/formal/sphincs/SphincsSecurity/Proof/Security125Endpoint.lean new file mode 100644 index 00000000..e514207b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Security125Endpoint.lean @@ -0,0 +1,94 @@ +import SphincsSecurity.Proof.JointTerminalSampling +import SphincsSecurity.Proof.MessageCollision125 +import SphincsSecurity.Proof.FtsProbeSampling + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem forgeAdvantage_le_opening_add_concrete125 + (adversary : Adversary) (q : Nat) (hqPos : 1 ≤ q) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 125) : + forgeAdvantage scheme adversary ≤ + Pr[SampledViewedEvent cleanOtsOpeningEvent | sampledViewedGame adversary] + + ((4 * q : Nat) : ℝ≥0∞) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹ + + ((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 131 : Nat) : ℝ≥0∞)⁻¹ + + (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ := by + have hmessage := Range125.probEvent_sampled_cleanMessage_le adversary q hqPos hq + (hqMax.trans (by norm_num)) + have huncovered := FtsProbeSimulation.probEvent_sampledViewedGame_cleanUncovered_le + adversary q hq + change Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary] ≤ + (q : ℝ≥0∞) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹ at huncovered + refine (forgeAdvantage_le_joint_reserved_add_sampled_remaining adversary q hqPos hq hqMax).trans ?_ + calc + _ ≤ ((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹ + + ((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 131 : Nat) : ℝ≥0∞)⁻¹ + + (Pr[SampledViewedEvent cleanOtsOpeningEvent | sampledViewedGame adversary] + + ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ + + (q : ℝ≥0∞) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹)) := + add_le_add le_rfl (add_le_add le_rfl (add_le_add hmessage huncovered)) + _ = _ := by push_cast; ring + +theorem concrete125_budget (q : Nat) : + ((7 * q : Nat) : ℝ≥0∞) * ((2 ^ 129 : Nat) : ℝ≥0∞)⁻¹ + + ((4 * q : Nat) : ℝ≥0∞) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹ + + ((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 131 : Nat) : ℝ≥0∞)⁻¹ + + (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ ≤ + (q : ℝ≥0∞) / ((2 ^ 125 : Nat) : ℝ≥0∞) := by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + repeat rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul, ENNReal.toReal_div, ENNReal.toReal_inv, ENNReal.toReal_natCast, Nat.cast_mul, + Nat.cast_ofNat] + norm_num + have hq : (0 : ℝ) ≤ (q : ℝ) := Nat.cast_nonneg q + linarith + +/-- Assembly only: the sampled one-time opening estimate remains an explicit premise. -/ +theorem security125_of_sampledOpening_le_seven_mul_inv129 + (hopening : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ 125 → + Pr[SampledViewedEvent cleanOtsOpeningEvent | sampledViewedGame adversary] ≤ + ((7 * q : Nat) : ℝ≥0∞) * ((2 ^ 129 : Nat) : ℝ≥0∞)⁻¹) : + HasClassicalSecurityBits scheme 125 := by + intro q hqPos adversary hq + by_cases hqMax : q ≤ 2 ^ 125 + · refine (forgeAdvantage_le_opening_add_concrete125 adversary q hqPos hq hqMax).trans ?_ + calc + _ ≤ ((7 * q : Nat) : ℝ≥0∞) * ((2 ^ 129 : Nat) : ℝ≥0∞)⁻¹ + + ((4 * q : Nat) : ℝ≥0∞) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹ + + ((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 131 : Nat) : ℝ≥0∞)⁻¹ + + (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ := + add_le_add (add_le_add (add_le_add (hopening q hqPos adversary hq hqMax) le_rfl) + le_rfl) le_rfl + _ ≤ _ := concrete125_budget q + · apply probOutput_le_one.trans + rw [div_eq_mul_inv] + have hcast : ((2 ^ 125 : Nat) : ℝ≥0∞) ≤ (q : ℝ≥0∞) := by + exact_mod_cast (show 2 ^ 125 ≤ q by omega) + calc + (1 : ℝ≥0∞) = ((2 ^ 125 : Nat) : ℝ≥0∞) * + ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹ := by + rw [ENNReal.mul_inv_cancel] + · norm_num + · finiteness + _ ≤ _ := mul_le_mul' hcast le_rfl + +/-- The remaining opening bound can be supplied through the existing retained-verifier coupling. -/ +theorem security125_of_sampledVerifyProbe_le_seven_mul_inv129 + (hprobe : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ 125 → + ∀ parameter ∈ support sampleParameter, + ∀ ftsSecret ∈ support sampleFtsSecrets, + Pr[fun result => OtsProbeSimulation.WinningRetainedVerifyProbeWitness parameter + (OtsProbeSimulation.extendStartTable result.1) ftsSecret result.2 | + OtsProbeSimulation.sampledActualRetainedOtsHashTable adversary parameter ftsSecret] ≤ + ((7 * q : Nat) : ℝ≥0∞) * ((2 ^ 129 : Nat) : ℝ≥0∞)⁻¹) : + HasClassicalSecurityBits scheme 125 := by + apply security125_of_sampledOpening_le_seven_mul_inv129 + intro q hqPos adversary hq hqMax + apply OtsProbeSimulation.probEvent_sampledViewedGame_cleanOtsOpening_le_of_sampled + intro parameter hparameter ftsSecret hfts + exact hprobe q hqPos adversary hq hqMax parameter hparameter ftsSecret hfts + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/Security126Completion.lean b/formal/sphincs/SphincsSecurity/Proof/Security126Completion.lean new file mode 100644 index 00000000..1650649a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Security126Completion.lean @@ -0,0 +1,76 @@ +import SphincsSecurity.Proof.OtsProbeNativeRetainedProjection +import SphincsSecurity.Proof.OtsProbePrehitOpeningProjection + +namespace SphincsSecurity.Concrete.OtsProbeSimulation + +open _root_.OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable +attribute [local irreducible] instFintypePosition +set_option backward.isDefEq.respectTransparency false + +theorem probEvent_prehitFreeRetainedVerifyProbe_le_nativeTerminalFailure + (targets : Finset Position) (adversary : Adversary) (parameter : PublicParameter) + (table : OtsSecretIndex → HashOutput) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (fuel : Nat) : + Pr[prehitFreeRetainedVerifyProbeEvent parameter table ftsSecret | + prehitRetainedQueryTrace adversary parameter table ftsSecret] ≤ + Pr[fun verdict => verdict = true | nativeTerminalFailureAfterRoot targets adversary parameter table ftsSecret fuel] := by + apply le_trans _ (probEvent_winningRetainedVerifyProbe_le_nativeTerminalFailure targets adversary parameter table ftsSecret fuel) + rw [← prehitRetainedQueryTrace_cache_projection, probEvent_map] + exact probEvent_mono (fun _ _ hevent => hevent.2) + +theorem sampledPrehitFreeRetainedVerifyProbeRisk_le_nativeTerminalFailure + (adversary : Adversary) (fuel : Nat) : + sampledPrehitFreeRetainedVerifyProbeRisk adversary ≤ + Pr[fun verdict => verdict = true | sampledNativeTerminalFailure adversary fuel] := by + simp only [sampledPrehitFreeRetainedVerifyProbeRisk, sampledNativeTerminalFailure, probEvent_bind_eq_tsum] + apply ENNReal.tsum_le_tsum + intro parameter + apply mul_le_mul' le_rfl + calc + _ ≤ ∑' table, Pr[= table | sampleOtsHashTable] * + ∑' ftsSecret, Pr[= ftsSecret | sampleFtsSecrets] * + Pr[fun verdict => verdict = true | nativeTerminalFailureAfterRoot Finset.univ adversary parameter table ftsSecret fuel] := by + apply ENNReal.tsum_le_tsum + intro table + apply mul_le_mul' le_rfl + apply ENNReal.tsum_le_tsum + intro ftsSecret + exact mul_le_mul' le_rfl (probEvent_prehitFreeRetainedVerifyProbe_le_nativeTerminalFailure + Finset.univ adversary parameter table ftsSecret fuel) + _ = _ := by + simp_rw [← ENNReal.tsum_mul_left] + rw [ENNReal.tsum_comm] + apply tsum_congr + intro ftsSecret + apply tsum_congr + intro table + exact mul_left_comm _ _ _ + +theorem probEvent_sampled_prehitFree_residual_le_nativeTerminalFailure + (adversary : Adversary) (fuel : Nat) : + Pr[prehitFreeResidualOtsOpeningEvent | sampledEncodingPrehitViewedGame adversary] ≤ + Pr[fun verdict => verdict = true | sampledNativeTerminalFailure adversary fuel] := + (probEvent_sampled_prehitFree_residual_le_retainedVerifyProbe adversary).trans + (sampledPrehitFreeRetainedVerifyProbeRisk_le_nativeTerminalFailure adversary fuel) + +theorem probEvent_sampled_prehitFree_residual_le_refinedReserve_add_erasure + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + Pr[prehitFreeResidualOtsOpeningEvent | sampledEncodingPrehitViewedGame adversary] ≤ + sampledQueryCharge otsOpeningRefinedQueryReserve adversary * (Fintype.card Digest : ENNReal)⁻¹ + + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + have hbound := probEvent_sampledNativeTerminalFailure_add_rootMatch_le_refinedReserve + ∅ (by simp) (by simp) adversary q hq hqMax + have hfailure := probEvent_sampled_prehitFree_residual_le_nativeTerminalFailure adversary (q + 1) + apply hfailure.trans + apply (show Pr[fun verdict => verdict = true | sampledNativeTerminalFailure adversary (q + 1)] ≤ + Pr[fun verdict => verdict = true | sampledNativeTerminalFailure adversary (q + 1)] + + sampledNativeFinalRootMatchRisk Finset.univ ∅ adversary (q + 1) from le_add_of_nonneg_right zero_le).trans + simpa only [show Fintype.card Digest = 2 ^ digestBits by simp] using hbound + +theorem security126_of_completed_native_boundary : HasClassicalSecurityBits scheme 126 := by + apply security126_of_sampled_prehitFree_otsOpening_le_refinedQueryReserve_add_query_erasure + intro q _hqPos adversary hq hqMax + exact probEvent_sampled_prehitFree_residual_le_refinedReserve_add_erasure adversary q hq hqMax + +end SphincsSecurity.Concrete.OtsProbeSimulation diff --git a/formal/sphincs/SphincsSecurity/Proof/Security126Endpoint.lean b/formal/sphincs/SphincsSecurity/Proof/Security126Endpoint.lean new file mode 100644 index 00000000..d89f9ee6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Security126Endpoint.lean @@ -0,0 +1,98 @@ +import SphincsSecurity.Proof.JointPrimitiveQueryBudget +import SphincsSecurity.Proof.FewTime126Bound +import SphincsSecurity.Proof.MessageCollision125 + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem concrete126_budget (q : Nat) : + ((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹ + + ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ + + ((27 * q : Nat) : ℝ≥0∞) * ((2 ^ 133 : Nat) : ℝ≥0∞)⁻¹) ≤ + (q : ℝ≥0∞) / ((2 ^ 126 : Nat) : ℝ≥0∞) := by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + repeat rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul, ENNReal.toReal_div, ENNReal.toReal_inv, ENNReal.toReal_natCast, + Nat.cast_mul, Nat.cast_ofNat] + norm_num + have hq : (0 : ℝ) ≤ (q : ℝ) := Nat.cast_nonneg q + linarith + +theorem forgeAdvantage_le_sampled_jointPrimitive_add_remaining126 + (adversary : Adversary) (q : Nat) (hqPos : 1 ≤ q) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + forgeAdvantage scheme adversary ≤ + Pr[SampledViewedEvent jointPrimitiveEvent | sampledViewedGame adversary] + + ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ + + ((27 * q : Nat) : ℝ≥0∞) * ((2 ^ 133 : Nat) : ℝ≥0∞)⁻¹) := by + let remaining := (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ + + ((27 * q : Nat) : ℝ≥0∞) * ((2 ^ 133 : Nat) : ℝ≥0∞)⁻¹ + let risk := fun secrets : SampledSecrets => + Pr[jointPrimitiveEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret secrets.ftsSecret] + rw [forgeAdvantage_eq_sampledGame, sampledGame] + calc + _ ≤ remaining + ∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets] * risk secrets := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_const_add_weighted (oa := sampleSecrets) + (run := fun secrets => (simulateQ romImpl + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret)).run' ∅) + (event := fun verdict => verdict = true) (cost := remaining) risk + intro secrets hsecrets + obtain ⟨hparameter, hots, hfts⟩ := secrets.support_components hsecrets + rw [probEvent_eq_eq_probOutput] + have hforest := probEvent_gameAfterSecretsWithViewTrace_honest_leak_le_twenty_seven_mul_inv133 + adversary q hqPos hq hqMax secrets.parameter hparameter secrets.otsSecret hots + secrets.ftsSecret hfts + have hmessage : Pr[cleanMessageEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret secrets.ftsSecret] ≤ + (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ := by + apply le_trans (probEvent_mono fun _ _ event => event.2) + exact Range125.probEvent_gameAfterSecretsWithViewTrace_messageCollision_le_inv + adversary q hqPos hq hqMax secrets.parameter hparameter secrets.otsSecret hots + secrets.ftsSecret hfts + exact (probEvent_win_le_jointPrimitive_add_message_add_forest adversary secrets.parameter + secrets.otsSecret secrets.ftsSecret).trans + ((add_le_add le_rfl (add_le_add hmessage hforest)).trans_eq (add_comm _ _)) + _ = _ := by + rw [probEvent_sampledViewedGame_eq_weighted] + exact add_comm _ _ + +/-- Conditional assembly: the joint primitive bound is still required. -/ +theorem security126_of_sampled_jointPrimitive_le_three_mul + (hprimitive : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ 126 → + Pr[SampledViewedEvent jointPrimitiveEvent | sampledViewedGame adversary] ≤ + ((3 * q : Nat) : ℝ≥0∞) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹) : + HasClassicalSecurityBits scheme 126 := by + intro q hqPos adversary hq + by_cases hqMax : q ≤ 2 ^ 126 + · exact (forgeAdvantage_le_sampled_jointPrimitive_add_remaining126 adversary q hqPos hq hqMax).trans + ((add_le_add (hprimitive q hqPos adversary hq hqMax) le_rfl).trans (concrete126_budget q)) + · apply probOutput_le_one.trans + rw [div_eq_mul_inv] + have hcast : ((2 ^ 126 : Nat) : ℝ≥0∞) ≤ (q : ℝ≥0∞) := by + exact_mod_cast (show 2 ^ 126 ≤ q by omega) + calc + (1 : ℝ≥0∞) = ((2 ^ 126 : Nat) : ℝ≥0∞) * ((2 ^ 126 : Nat) : ℝ≥0∞)⁻¹ := by + rw [ENNReal.mul_inv_cancel] + · norm_num + · finiteness + _ ≤ _ := mul_le_mul' hcast le_rfl + + +/-- The residual estimate is an explicit remaining premise. -/ +theorem security126_of_sampled_residual_le_queryCharge + (hresidual : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ 126 → + Pr[SampledViewedEvent residualPrimitiveEvent | sampledViewedGame adversary] ≤ + sampledQueryCharge residualPrimitiveQueryCharge adversary * + (Fintype.card Digest : ℝ≥0∞)⁻¹) : + HasClassicalSecurityBits scheme 126 := by + apply security126_of_sampled_jointPrimitive_le_three_mul + intro q hqPos adversary hq hqMax + exact probEvent_sampled_jointPrimitive_le_three_mul_of_residual adversary q hq + (hresidual q hqPos adversary hq hqMax) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/Security126RefinedEndpoint.lean b/formal/sphincs/SphincsSecurity/Proof/Security126RefinedEndpoint.lean new file mode 100644 index 00000000..e4dd8a05 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Security126RefinedEndpoint.lean @@ -0,0 +1,155 @@ +import SphincsSecurity.Proof.Security126Endpoint + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem concrete126_ten_thirds_budget (q : Nat) : + ((10 / 3 : ℝ≥0∞) * q) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹ + + ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ + + ((19 * q : Nat) : ℝ≥0∞) * ((2 ^ 133 : Nat) : ℝ≥0∞)⁻¹) ≤ + (q : ℝ≥0∞) / ((2 ^ 126 : Nat) : ℝ≥0∞) := by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + repeat rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul, ENNReal.toReal_div, ENNReal.toReal_inv, ENNReal.toReal_natCast, + Nat.cast_mul, Nat.cast_ofNat, ENNReal.toReal_ofNat] + norm_num + have hq : (0 : ℝ) ≤ (q : ℝ) := Nat.cast_nonneg q + linarith + +theorem forgeAdvantage_le_sampled_jointPrimitive_add_refined_remaining126 + (adversary : Adversary) (q : Nat) (hqPos : 1 ≤ q) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + forgeAdvantage scheme adversary ≤ + Pr[SampledViewedEvent jointPrimitiveEvent | sampledViewedGame adversary] + + ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ + + ((19 * q : Nat) : ℝ≥0∞) * ((2 ^ 133 : Nat) : ℝ≥0∞)⁻¹) := by + let remaining := (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ + + ((19 * q : Nat) : ℝ≥0∞) * ((2 ^ 133 : Nat) : ℝ≥0∞)⁻¹ + let risk := fun secrets : SampledSecrets => + Pr[jointPrimitiveEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret secrets.ftsSecret] + rw [forgeAdvantage_eq_sampledGame, sampledGame] + calc + _ ≤ remaining + ∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets] * risk secrets := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_const_add_weighted (oa := sampleSecrets) + (run := fun secrets => (simulateQ romImpl + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret)).run' ∅) + (event := fun verdict => verdict = true) (cost := remaining) risk + intro secrets hsecrets + obtain ⟨hparameter, hots, hfts⟩ := secrets.support_components hsecrets + rw [probEvent_eq_eq_probOutput] + have hforest := probEvent_gameAfterSecretsWithViewTrace_honest_leak_le_nineteen_mul_inv133 + adversary q hq hqMax secrets.parameter hparameter secrets.otsSecret hots + secrets.ftsSecret hfts + have hmessage : Pr[cleanMessageEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret secrets.ftsSecret] ≤ + (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ := by + apply le_trans (probEvent_mono fun _ _ event => event.2) + exact Range125.probEvent_gameAfterSecretsWithViewTrace_messageCollision_le_inv + adversary q hqPos hq hqMax secrets.parameter hparameter secrets.otsSecret hots + secrets.ftsSecret hfts + exact (probEvent_win_le_jointPrimitive_add_message_add_forest adversary secrets.parameter + secrets.otsSecret secrets.ftsSecret).trans + ((add_le_add le_rfl (add_le_add hmessage hforest)).trans_eq (add_comm _ _)) + _ = _ := by + rw [probEvent_sampledViewedGame_eq_weighted] + exact add_comm _ _ + +/-- Conditional assembly: the joint primitive bound is still required. -/ +theorem security126_of_sampled_jointPrimitive_le_ten_thirds_mul + (hprimitive : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ 126 → + Pr[SampledViewedEvent jointPrimitiveEvent | sampledViewedGame adversary] ≤ + ((10 / 3 : ℝ≥0∞) * q) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹) : + HasClassicalSecurityBits scheme 126 := by + intro q hqPos adversary hq + by_cases hqMax : q ≤ 2 ^ 126 + · exact (forgeAdvantage_le_sampled_jointPrimitive_add_refined_remaining126 adversary q hqPos hq hqMax).trans + ((add_le_add (hprimitive q hqPos adversary hq hqMax) le_rfl).trans (concrete126_ten_thirds_budget q)) + · apply probOutput_le_one.trans + rw [div_eq_mul_inv] + have hcast : ((2 ^ 126 : Nat) : ℝ≥0∞) ≤ (q : ℝ≥0∞) := by + exact_mod_cast (show 2 ^ 126 ≤ q by omega) + calc + (1 : ℝ≥0∞) = ((2 ^ 126 : Nat) : ℝ≥0∞) * ((2 ^ 126 : Nat) : ℝ≥0∞)⁻¹ := by + rw [ENNReal.mul_inv_cancel] + · norm_num + · finiteness + _ ≤ _ := mul_le_mul' hcast le_rfl + + +theorem concrete126_ten_thirds_budget_add_erasure (q : Nat) (hq : 1 ≤ q) : + (((10 / 3 : ℝ≥0∞) * q) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹ + ((2 ^ 216 : Nat) : ℝ≥0∞)⁻¹) + + ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ + + ((19 * q : Nat) : ℝ≥0∞) * ((2 ^ 133 : Nat) : ℝ≥0∞)⁻¹) ≤ + (q : ℝ≥0∞) / ((2 ^ 126 : Nat) : ℝ≥0∞) := by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + repeat rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul, ENNReal.toReal_div, ENNReal.toReal_inv, ENNReal.toReal_natCast, + Nat.cast_mul, Nat.cast_ofNat, ENNReal.toReal_ofNat] + norm_num + have hqReal : (1 : ℝ) ≤ (q : ℝ) := by exact_mod_cast hq + linarith + +/-- Conditional assembly allowing the globally bounded erasure event. The joint primitive bound remains a premise. -/ +theorem security126_of_sampled_jointPrimitive_le_ten_thirds_mul_add_erasure + (hprimitive : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ 126 → + Pr[SampledViewedEvent jointPrimitiveEvent | sampledViewedGame adversary] ≤ + ((10 / 3 : ℝ≥0∞) * q) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹ + ((2 ^ 216 : Nat) : ℝ≥0∞)⁻¹) : + HasClassicalSecurityBits scheme 126 := by + intro q hqPos adversary hq + by_cases hqMax : q ≤ 2 ^ 126 + · exact (forgeAdvantage_le_sampled_jointPrimitive_add_refined_remaining126 adversary q hqPos hq hqMax).trans + ((add_le_add (hprimitive q hqPos adversary hq hqMax) le_rfl).trans (concrete126_ten_thirds_budget_add_erasure q hqPos)) + · apply probOutput_le_one.trans + rw [div_eq_mul_inv] + have hcast : ((2 ^ 126 : Nat) : ℝ≥0∞) ≤ (q : ℝ≥0∞) := by + exact_mod_cast (show 2 ^ 126 ≤ q by omega) + calc + (1 : ℝ≥0∞) = ((2 ^ 126 : Nat) : ℝ≥0∞) * ((2 ^ 126 : Nat) : ℝ≥0∞)⁻¹ := by + rw [ENNReal.mul_inv_cancel] + · norm_num + · finiteness + _ ≤ _ := mul_le_mul' hcast le_rfl + +theorem concrete126_ten_thirds_budget_add_query_erasure (q : Nat) : + (((10 / 3 : ℝ≥0∞) * q) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹ + + (q : ℝ≥0∞) * ((2 ^ 216 : Nat) : ℝ≥0∞)⁻¹) + + ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ + + ((19 * q : Nat) : ℝ≥0∞) * ((2 ^ 133 : Nat) : ℝ≥0∞)⁻¹) ≤ + (q : ℝ≥0∞) / ((2 ^ 126 : Nat) : ℝ≥0∞) := by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + repeat rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul, ENNReal.toReal_div, ENNReal.toReal_inv, ENNReal.toReal_natCast, + Nat.cast_mul, Nat.cast_ofNat, ENNReal.toReal_ofNat] + norm_num + have hqReal : (0 : ℝ) ≤ (q : ℝ) := Nat.cast_nonneg q + linarith + +/-- Conditional assembly with an erasure allowance for each hash-query cut. -/ +theorem security126_of_sampled_jointPrimitive_le_ten_thirds_mul_add_query_erasure + (hprimitive : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ 126 → + Pr[SampledViewedEvent jointPrimitiveEvent | sampledViewedGame adversary] ≤ + ((10 / 3 : ℝ≥0∞) * q) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹ + + (q : ℝ≥0∞) * ((2 ^ 216 : Nat) : ℝ≥0∞)⁻¹) : + HasClassicalSecurityBits scheme 126 := by + intro q hqPos adversary hq + by_cases hqMax : q ≤ 2 ^ 126 + · exact (forgeAdvantage_le_sampled_jointPrimitive_add_refined_remaining126 adversary q hqPos hq hqMax).trans + ((add_le_add (hprimitive q hqPos adversary hq hqMax) le_rfl).trans (concrete126_ten_thirds_budget_add_query_erasure q)) + · apply probOutput_le_one.trans + rw [div_eq_mul_inv] + have hcast : ((2 ^ 126 : Nat) : ℝ≥0∞) ≤ (q : ℝ≥0∞) := by + exact_mod_cast (show 2 ^ 126 ≤ q by omega) + calc + (1 : ℝ≥0∞) = ((2 ^ 126 : Nat) : ℝ≥0∞) * ((2 ^ 126 : Nat) : ℝ≥0∞)⁻¹ := by + rw [ENNReal.mul_inv_cancel] + · norm_num + · finiteness + _ ≤ _ := mul_le_mul' hcast le_rfl + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/SecurityOccupancyEndpoint.lean b/formal/sphincs/SphincsSecurity/Proof/SecurityOccupancyEndpoint.lean new file mode 100644 index 00000000..9e8042ed --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SecurityOccupancyEndpoint.lean @@ -0,0 +1,59 @@ +import SphincsSecurity.Proof.FewTimeOccupancyCount +import SphincsSecurity.Proof.JointNativeQueryCharge + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem forgeAdvantage_le_sampled_jointPrimitive_add_occupancy_remaining + (adversary : Adversary) (q : Nat) (hqPos : 1 ≤ q) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + forgeAdvantage scheme adversary ≤ + Pr[SampledViewedEvent jointPrimitiveEvent | sampledViewedGame adversary] + + ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ + + ((23 * q : Nat) : ℝ≥0∞) * ((2 ^ 134 : Nat) : ℝ≥0∞)⁻¹) := by + let remaining := (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ + + ((23 * q : Nat) : ℝ≥0∞) * ((2 ^ 134 : Nat) : ℝ≥0∞)⁻¹ + let risk := fun secrets : SampledSecrets => + Pr[jointPrimitiveEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret secrets.ftsSecret] + rw [forgeAdvantage_eq_sampledGame, sampledGame] + calc + _ ≤ remaining + ∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets] * risk secrets := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_const_add_weighted (oa := sampleSecrets) + (run := fun secrets => (simulateQ romImpl + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret)).run' ∅) + (event := fun verdict => verdict = true) (cost := remaining) risk + intro secrets hsecrets + obtain ⟨hparameter, hots, hfts⟩ := secrets.support_components hsecrets + rw [probEvent_eq_eq_probOutput] + have hforest := probEvent_gameAfterSecretsWithViewTrace_honest_leak_le_twenty_three_mul_inv134 + adversary q hq hqMax secrets.parameter hparameter secrets.otsSecret hots + secrets.ftsSecret hfts + have hmessage : Pr[cleanMessageEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret secrets.ftsSecret] ≤ + (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ := by + apply le_trans (probEvent_mono fun _ _ event => event.2) + exact Range125.probEvent_gameAfterSecretsWithViewTrace_messageCollision_le_inv + adversary q hqPos hq hqMax secrets.parameter hparameter secrets.otsSecret hots + secrets.ftsSecret hfts + exact (probEvent_win_le_jointPrimitive_add_message_add_forest adversary secrets.parameter + secrets.otsSecret secrets.ftsSecret).trans + ((add_le_add le_rfl (add_le_add hmessage hforest)).trans_eq (add_comm _ _)) + _ = _ := by + rw [probEvent_sampledViewedGame_eq_weighted] + exact add_comm _ _ + +theorem forgeAdvantage_le_nativeQueryCharge_add_occupancy_remaining + (adversary : Adversary) (q : Nat) (hqPos : 1 ≤ q) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + forgeAdvantage scheme adversary ≤ + (sampledQueryCharge jointNativeQueryCharge adversary * (Fintype.card Digest : ENNReal)⁻¹ + + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹) + + ((q : ENNReal) * ((2 ^ 139 : Nat) : ENNReal)⁻¹ + + ((23 * q : Nat) : ENNReal) * ((2 ^ 134 : Nat) : ENNReal)⁻¹) := + (forgeAdvantage_le_sampled_jointPrimitive_add_occupancy_remaining adversary q hqPos hq hqMax).trans + (add_le_add (probEvent_sampled_jointPrimitive_le_nativeQueryCharge_add_erasure adversary q hq hqMax) le_rfl) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/SecurityQueryRateEndpoint.lean b/formal/sphincs/SphincsSecurity/Proof/SecurityQueryRateEndpoint.lean new file mode 100644 index 00000000..58729261 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SecurityQueryRateEndpoint.lean @@ -0,0 +1,38 @@ +import SphincsSecurity.Proof.OtsProbeNativeRateBound +import SphincsSecurity.Proof.SecurityOccupancyEndpoint + +namespace SphincsSecurity.Concrete + +open _root_.OracleComp OracleSpec ENNReal + +theorem probEvent_sampled_jointPrimitive_le_queryRate_add_erasure + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + Pr[SampledViewedEvent jointPrimitiveEvent | sampledViewedGame adversary] ≤ + sampledQueryCharge (fun secretKey cache input => + TightEncoding.refinedStructuralEncodingQueryCharge secretKey cache input + ftsOpeningQueryReserve secretKey cache input) + adversary * (Fintype.card Digest : ENNReal)⁻¹ + + (sampledQueryCharge (fun secretKey _ input => OtsProbeSimulation.otsHashInputCharge secretKey.parameter input) adversary * + OtsProbeSimulation.privateHistoryGuessRate q + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹) := by + have hfts := FtsProbeSimulation.probEvent_sampledViewedGame_cleanUncovered_le_queryCharge126 adversary q hq hqMax + rw [← sampled_ftsOpeningQueryReserve_eq] at hfts + apply (probEvent_sampled_jointPrimitive_le_prehit_charge_add_openings adversary).trans + apply (add_le_add le_rfl (add_le_add + (OtsProbeSimulation.probEvent_sampled_prehitFree_residual_le_actualOtsCount_rate_add_erasure adversary q hq hqMax) hfts)).trans_eq + rw [sampledQueryCharge_add] + ring + +theorem forgeAdvantage_le_queryRate_add_occupancy_remaining + (adversary : Adversary) (q : Nat) (hqPos : 1 ≤ q) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + forgeAdvantage scheme adversary ≤ + (sampledQueryCharge (fun secretKey cache input => + TightEncoding.refinedStructuralEncodingQueryCharge secretKey cache input + ftsOpeningQueryReserve secretKey cache input) + adversary * (Fintype.card Digest : ENNReal)⁻¹ + + (sampledQueryCharge (fun secretKey _ input => OtsProbeSimulation.otsHashInputCharge secretKey.parameter input) adversary * + OtsProbeSimulation.privateHistoryGuessRate q + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹)) + + ((q : ENNReal) * ((2 ^ 139 : Nat) : ENNReal)⁻¹ + + ((23 * q : Nat) : ENNReal) * ((2 ^ 134 : Nat) : ENNReal)⁻¹) := + (forgeAdvantage_le_sampled_jointPrimitive_add_occupancy_remaining adversary q hqPos hq hqMax).trans + (add_le_add (probEvent_sampled_jointPrimitive_le_queryRate_add_erasure adversary q hq hqMax) le_rfl) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/SecuritySettledCollisionEndpoint.lean b/formal/sphincs/SphincsSecurity/Proof/SecuritySettledCollisionEndpoint.lean new file mode 100644 index 00000000..2675b3a7 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SecuritySettledCollisionEndpoint.lean @@ -0,0 +1,18 @@ +import SphincsSecurity.Proof.SettledCollisionViewedGame +import SphincsSecurity.Proof.SecurityVerifierPrimitiveEndpoint + +namespace SphincsSecurity.Concrete.SettledCollision + +open OracleComp OracleSpec ENNReal + +theorem forgeAdvantage_le_settled_charge_add_remaining_primitive (adversary : Adversary) + (q : Nat) (hqPos : 1 ≤ q) (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + forgeAdvantage scheme adversary ≤ + (sampledQueryCharge queryCharge adversary * (Fintype.card Digest : ℝ≥0∞)⁻¹ + + Pr[SampledMonitorEvent remainingPrimitiveEvent | sampledViewedMonitorGame adversary]) + + ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ + + ((23 * q : Nat) : ℝ≥0∞) * ((2 ^ 134 : Nat) : ℝ≥0∞)⁻¹) := + (forgeAdvantage_le_sampled_verifierPrimitive_add_occupancy_remaining adversary q hqPos hq hqMax).trans + (add_le_add (probEvent_sampled_verifierPrimitive_le_charge_add_remaining adversary) le_rfl) + +end SphincsSecurity.Concrete.SettledCollision diff --git a/formal/sphincs/SphincsSecurity/Proof/SecurityVerifierPrimitiveEndpoint.lean b/formal/sphincs/SphincsSecurity/Proof/SecurityVerifierPrimitiveEndpoint.lean new file mode 100644 index 00000000..608bc2a6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SecurityVerifierPrimitiveEndpoint.lean @@ -0,0 +1,59 @@ +import SphincsSecurity.Proof.VerifierPrimitiveTerminal +import SphincsSecurity.Proof.SecurityOccupancyEndpoint + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem forgeAdvantage_le_sampled_verifierPrimitive_add_occupancy_remaining + (adversary : Adversary) (q : Nat) (hqPos : 1 ≤ q) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + forgeAdvantage scheme adversary ≤ + Pr[SampledViewedEvent verifierPrimitiveEvent | sampledViewedGame adversary] + + ((q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ + + ((23 * q : Nat) : ℝ≥0∞) * ((2 ^ 134 : Nat) : ℝ≥0∞)⁻¹) := by + let remaining := (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ + + ((23 * q : Nat) : ℝ≥0∞) * ((2 ^ 134 : Nat) : ℝ≥0∞)⁻¹ + let risk := fun secrets : SampledSecrets => + Pr[verifierPrimitiveEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret secrets.ftsSecret] + rw [forgeAdvantage_eq_sampledGame, sampledGame] + calc + _ ≤ remaining + ∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets] * risk secrets := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_const_add_weighted (oa := sampleSecrets) + (run := fun secrets => (simulateQ romImpl + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret)).run' ∅) + (event := fun verdict => verdict = true) (cost := remaining) risk + intro secrets hsecrets + obtain ⟨hparameter, hots, hfts⟩ := secrets.support_components hsecrets + rw [probEvent_eq_eq_probOutput] + have hforest := probEvent_gameAfterSecretsWithViewTrace_honest_leak_le_twenty_three_mul_inv134 + adversary q hq hqMax secrets.parameter hparameter secrets.otsSecret hots + secrets.ftsSecret hfts + have hmessage : Pr[ViewedMessageDigestCollisionWitness secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret secrets.ftsSecret] ≤ + (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ := by + exact Range125.probEvent_gameAfterSecretsWithViewTrace_messageCollision_le_inv + adversary q hqPos hq hqMax secrets.parameter hparameter secrets.otsSecret hots + secrets.ftsSecret hfts + exact (probEvent_win_le_verifierPrimitive_add_message_add_forest adversary secrets.parameter + secrets.otsSecret secrets.ftsSecret).trans + ((add_le_add le_rfl (add_le_add hmessage hforest)).trans_eq (add_comm _ _)) + _ = _ := by + rw [probEvent_sampledViewedGame_eq_weighted] + exact add_comm _ _ + +theorem probEvent_sampled_verifierPrimitive_le_nativeQueryCharge_add_erasure + (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 126) : + Pr[SampledViewedEvent verifierPrimitiveEvent | sampledViewedGame adversary] ≤ + sampledQueryCharge jointNativeQueryCharge adversary * (Fintype.card Digest : ENNReal)⁻¹ + + (q : ENNReal) * ((2 ^ 216 : Nat) : ENNReal)⁻¹ := by + apply (probEvent_mono (q := SampledViewedEvent jointPrimitiveEvent) ?_).trans + (probEvent_sampled_jointPrimitive_le_nativeQueryCharge_add_erasure adversary q hq hqMax) + intro result _ hevent + exact verifierPrimitiveEvent_implies_jointPrimitiveEvent result.secrets.parameter + result.secrets.otsSecret result.secrets.ftsSecret result.result hevent + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/Settled.lean b/formal/sphincs/SphincsSecurity/Proof/Settled.lean new file mode 100644 index 00000000..d655f825 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Settled.lean @@ -0,0 +1,164 @@ +import SphincsSecurity.Proof.Honest + +/-! +# Positions the cache has settled + +A position is *settled* by a cache when every position below it is and the honest input there is +cached. The point of the notion is `honestInput_eq_of_settled`: at a settled position the honest +input is a function of the cache alone, the same for every answer function the cache agrees with. It +is what lets the accounting speak of "the honest input at this domain" without knowing the rest of +the run, and what the extraction's honest values are matched against. + +Settling is monotone, and the input it pins never moves again. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +/-- The answer function a cache induces: its own answers, and `0` where it says nothing. -/ +def fromCache (cache : QueryCache HashSpec) : QueryImpl HashSpec Id := + fun input => (cache input).getD 0 + +theorem agreesWithFn_fromCache (cache : QueryCache HashSpec) : + cache.AgreesWithFn (fromCache cache) := by + intro input answer hcached + simp [fromCache, hcached] + +theorem agreesWithFn_fromCache_of_le {cache cache' : QueryCache HashSpec} (hle : cache ≤ cache') : + cache.AgreesWithFn (fromCache cache') := fun _ _ hcached => by + simp [fromCache, hle hcached] + +variable (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + +/-- The honest input at a position, as the cache pins it. -/ +noncomputable def cachedInput (cache : QueryCache HashSpec) (p : Position) : HashInput := + honestInput (fromCache cache) parameter otsSecret ftsSecret p + +/-- Every position below this one is settled, and the honest input here is cached. -/ +def Settled (cache : QueryCache HashSpec) (p : Position) : Prop := + p.Valid ∧ cache (cachedInput parameter otsSecret ftsSecret cache p) ≠ none + ∧ ∀ c ∈ p.children, Settled cache c +termination_by p.depth +decreasing_by exact Position.depth_lt_of_mem_children (by assumption) + +theorem settled_iff (cache : QueryCache HashSpec) (p : Position) : + Settled parameter otsSecret ftsSecret cache p + ↔ p.Valid ∧ cache (cachedInput parameter otsSecret ftsSecret cache p) ≠ none + ∧ ∀ c ∈ p.children, Settled parameter otsSecret ftsSecret cache c := by + rw [Settled] + +variable {parameter} {otsSecret} {ftsSecret} + +theorem Settled.valid {cache : QueryCache HashSpec} {p : Position} + (h : Settled parameter otsSecret ftsSecret cache p) : p.Valid := + ((settled_iff parameter otsSecret ftsSecret cache p).mp h).1 + +theorem Settled.cached {cache : QueryCache HashSpec} {p : Position} + (h : Settled parameter otsSecret ftsSecret cache p) : + cache (cachedInput parameter otsSecret ftsSecret cache p) ≠ none := + ((settled_iff parameter otsSecret ftsSecret cache p).mp h).2.1 + +theorem Settled.children {cache : QueryCache HashSpec} {p : Position} + (h : Settled parameter otsSecret ftsSecret cache p) : + ∀ c ∈ p.children, Settled parameter otsSecret ftsSecret cache c := + ((settled_iff parameter otsSecret ftsSecret cache p).mp h).2.2 + +/-- **A settled position is pinned.** At a settled position every answer function the cache agrees +with gives the same honest input, and the same honest value. -/ +private theorem honestInput_eq_of_settled_aux {cache : QueryCache HashSpec} + {f : QueryImpl HashSpec Id} (hf : cache.AgreesWithFn f) : + ∀ (n : Nat) (p : Position), p.depth < n → Settled parameter otsSecret ftsSecret cache p → + honestInput f parameter otsSecret ftsSecret p + = cachedInput parameter otsSecret ftsSecret cache p + ∧ honestValue f parameter otsSecret ftsSecret p + = honestValue (fromCache cache) parameter otsSecret ftsSecret p := by + intro n + induction n with + | zero => intro p hdepth; omega + | succ n ih => + intro p hdepth hsettled + have hchildren : ∀ c ∈ p.children, + honestValue f parameter otsSecret ftsSecret c + = honestValue (fromCache cache) parameter otsSecret ftsSecret c := fun c hc => + (ih c (by have := Position.depth_lt_of_mem_children hc; omega) + (hsettled.children c hc)).2 + have hinput := honestInput_congr f (fromCache cache) parameter otsSecret ftsSecret + hsettled.valid hchildren + refine ⟨hinput, ?_⟩ + obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hsettled.cached + rw [honestValue, honestValue, hinput] + change truncateHash (f (cachedInput parameter otsSecret ftsSecret cache p)) + = truncateHash (fromCache cache (cachedInput parameter otsSecret ftsSecret cache p)) + rw [hf hanswer, show fromCache cache (cachedInput parameter otsSecret ftsSecret cache p) + = answer from by simp [fromCache, hanswer]] + +theorem honestInput_eq_cachedInput {cache : QueryCache HashSpec} {f : QueryImpl HashSpec Id} + (hf : cache.AgreesWithFn f) {p : Position} + (hsettled : Settled parameter otsSecret ftsSecret cache p) : + honestInput f parameter otsSecret ftsSecret p + = cachedInput parameter otsSecret ftsSecret cache p := + (honestInput_eq_of_settled_aux hf (p.depth + 1) p (by omega) hsettled).1 + +theorem honestValue_eq_of_settled {cache : QueryCache HashSpec} {f : QueryImpl HashSpec Id} + (hf : cache.AgreesWithFn f) {p : Position} + (hsettled : Settled parameter otsSecret ftsSecret cache p) : + honestValue f parameter otsSecret ftsSecret p + = honestValue (fromCache cache) parameter otsSecret ftsSecret p := + (honestInput_eq_of_settled_aux hf (p.depth + 1) p (by omega) hsettled).2 + +/-- A valid position settles once its children are settled and its honest input is cached. -/ +theorem settled_of_honestInput_cached {cache : QueryCache HashSpec} + {f : QueryImpl HashSpec Id} (hf : cache.AgreesWithFn f) {p : Position} + (hvalid : p.Valid) + (hcached : cache (honestInput f parameter otsSecret ftsSecret p) ≠ none) + (hchildren : ∀ c ∈ p.children, Settled parameter otsSecret ftsSecret cache c) : + Settled parameter otsSecret ftsSecret cache p := by + have hvalues : ∀ c ∈ p.children, + honestValue f parameter otsSecret ftsSecret c + = honestValue (fromCache cache) parameter otsSecret ftsSecret c := fun c hc => + honestValue_eq_of_settled hf (hchildren c hc) + have hinput := honestInput_congr f (fromCache cache) parameter otsSecret ftsSecret hvalid hvalues + rw [settled_iff] + refine ⟨hvalid, ?_, hchildren⟩ + change cache (honestInput (fromCache cache) parameter otsSecret ftsSecret p) ≠ none + rwa [← hinput] + +/-- **Settling is monotone, and what it pins does not move.** -/ +private theorem settled_mono_aux {cache cache' : QueryCache HashSpec} (hle : cache ≤ cache') : + ∀ (n : Nat) (p : Position), p.depth < n → Settled parameter otsSecret ftsSecret cache p → + Settled parameter otsSecret ftsSecret cache' p + ∧ cachedInput parameter otsSecret ftsSecret cache' p + = cachedInput parameter otsSecret ftsSecret cache p := by + intro n + induction n with + | zero => intro p hdepth; omega + | succ n ih => + intro p hdepth hsettled + have hpinned : cachedInput parameter otsSecret ftsSecret cache' p + = cachedInput parameter otsSecret ftsSecret cache p := + honestInput_eq_cachedInput (agreesWithFn_fromCache_of_le hle) hsettled + refine ⟨?_, hpinned⟩ + rw [settled_iff] + refine ⟨hsettled.valid, ?_, fun c hc => + (ih c (by have := Position.depth_lt_of_mem_children hc; omega) + (hsettled.children c hc)).1⟩ + rw [hpinned] + obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hsettled.cached + rw [hle hanswer] + simp + +theorem Settled.mono {cache cache' : QueryCache HashSpec} (hle : cache ≤ cache') {p : Position} + (h : Settled parameter otsSecret ftsSecret cache p) : + Settled parameter otsSecret ftsSecret cache' p := + (settled_mono_aux hle (p.depth + 1) p (by omega) h).1 + +theorem cachedInput_eq_of_settled {cache cache' : QueryCache HashSpec} (hle : cache ≤ cache') + {p : Position} (h : Settled parameter otsSecret ftsSecret cache p) : + cachedInput parameter otsSecret ftsSecret cache' p + = cachedInput parameter otsSecret ftsSecret cache p := + (settled_mono_aux hle (p.depth + 1) p (by omega) h).2 + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/SettledCollisionComposition.lean b/formal/sphincs/SphincsSecurity/Proof/SettledCollisionComposition.lean new file mode 100644 index 00000000..d7cf7e04 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SettledCollisionComposition.lean @@ -0,0 +1,67 @@ +import SphincsSecurity.Proof.SettledCollisionMonitor + +namespace SphincsSecurity.Concrete.SettledCollision + +open OracleComp OracleSpec + +theorem runMonitor_pure (secretKey : SecretKey) (value : α) + (cache : QueryCache HashSpec) (history : History) : + runMonitor secretKey (pure value) cache history = pure ((value, cache), history) := rfl + +theorem runMonitor_bind (secretKey : SecretKey) + (computation : OracleComp OracleWorld α) (next : α → OracleComp OracleWorld β) + (cache : QueryCache HashSpec) (history : History) : + runMonitor secretKey (computation >>= next) cache history = (do + let result ← runMonitor secretKey computation cache history + runMonitor secretKey (next result.1.1) result.1.2 result.2) := by + induction computation using OracleComp.inductionOn generalizing cache history with + | pure value => simp [runMonitor] + | query_bind query continuation ih => + simp only [bind_assoc, runMonitor, OracleComp.construct_query_bind] + exact bind_congr fun result => ih result.1 result.2 _ + +theorem runMonitor_map (secretKey : SecretKey) + (f : α → β) (computation : OracleComp OracleWorld α) + (cache : QueryCache HashSpec) (history : History) : + runMonitor secretKey (f <$> computation) cache history = + (fun result => ((f result.1.1, result.1.2), result.2)) <$> + runMonitor secretKey computation cache history := by + rw [map_eq_bind_pure_comp, runMonitor_bind] + rfl + +theorem runMonitor_query (secretKey : SecretKey) + (query : OracleWorld.Domain) (cache : QueryCache HashSpec) (history : History) : + runMonitor secretKey (OracleWorld.query query) cache history = + (fun result => (result, advance secretKey cache history query result.1)) <$> + (romImpl query).run cache := by + rw [← bind_pure (liftM (OracleWorld.query query) : OracleComp OracleWorld _)] + rw [runMonitor, OracleComp.construct_query_bind] + rfl + +noncomputable def monitorImpl (secretKey : SecretKey) : + QueryImpl OracleWorld (StateT (QueryCache HashSpec × History) ProbComp) := + fun query state => + (fun result => (result.1.1, (result.1.2, result.2))) <$> + runMonitor secretKey (OracleWorld.query query) state.1 state.2 + +theorem simulateQ_monitorImpl_run (secretKey : SecretKey) + (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) (history : History) : + (simulateQ (monitorImpl secretKey) computation).run (cache, history) = + (fun result => (result.1.1, (result.1.2, result.2))) <$> + runMonitor secretKey computation cache history := by + induction computation using OracleComp.inductionOn generalizing cache history with + | pure value => simp [runMonitor] + | query_bind query next ih => + rw [simulateQ_bind, StateT.run_bind, simulateQ_spec_query, runMonitor_bind] + simp only [monitorImpl, StateT.run, bind_map_left, map_bind] + exact bind_congr fun result => ih result.1.1 result.1.2 result.2 + +theorem runMonitor_eq_simulateQ (secretKey : SecretKey) + (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) (history : History) : + runMonitor secretKey computation cache history = + (fun result => ((result.1, result.2.1), result.2.2)) <$> + (simulateQ (monitorImpl secretKey) computation).run (cache, history) := by + rw [simulateQ_monitorImpl_run] + simp + +end SphincsSecurity.Concrete.SettledCollision diff --git a/formal/sphincs/SphincsSecurity/Proof/SettledCollisionGame.lean b/formal/sphincs/SphincsSecurity/Proof/SettledCollisionGame.lean new file mode 100644 index 00000000..7647e712 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SettledCollisionGame.lean @@ -0,0 +1,135 @@ +import SphincsSecurity.Proof.SettledCollisionSupport +import SphincsSecurity.Proof.JointPrimitiveQueryBudget +import SphincsSecurity.Proof.VerifierStructuralCollision + +namespace SphincsSecurity.Concrete.SettledCollision + +open OracleComp OracleSpec ENNReal + +structure GameResult where + secrets : SampledSecrets + verdict : Bool + cache : QueryCache HashSpec + history : History + +noncomputable def sampledMonitorGame (adversary : Adversary) : ProbComp GameResult := do + let secrets ← sampleSecrets + (fun result => ⟨secrets, result.1.1, result.1.2, result.2⟩) <$> + runMonitor (primitiveAccountingKey secrets.parameter secrets.otsSecret secrets.ftsSecret) + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret) ∅ initialHistory + +def WinningUnsettledCollision (result : GameResult) : Prop := + result.verdict = true ∧ BadOnInputs + (primitiveAccountingKey result.secrets.parameter result.secrets.otsSecret result.secrets.ftsSecret) + result.cache ↑result.history.unsettled + +theorem sampledMonitorGame_verdict_projection (adversary : Adversary) : + GameResult.verdict <$> sampledMonitorGame adversary = sampledGame adversary := by + unfold sampledMonitorGame sampledGame + rw [map_bind] + apply bind_congr + intro secrets + rw [Functor.map_map, StateT.run'_eq] + rw [← runMonitor_project + (primitiveAccountingKey secrets.parameter secrets.otsSecret secrets.ftsSecret) + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret) ∅ initialHistory, + Functor.map_map] + +theorem probEvent_sampledMonitorGame_hit_le_queryCharge (adversary : Adversary) : + Pr[fun result => result.history.hit = true | sampledMonitorGame adversary] ≤ + sampledQueryCharge queryCharge adversary * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + unfold sampledMonitorGame sampledQueryCharge + rw [probEvent_bind_eq_tsum, ← ENNReal.tsum_mul_right] + apply ENNReal.tsum_le_tsum + intro secrets + rw [mul_assoc] + apply mul_le_mul' le_rfl + rw [probEvent_map] + exact probEvent_runMonitor_hit_le_queryCharge + (primitiveAccountingKey secrets.parameter secrets.otsSecret secrets.ftsSecret) + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret) ∅ + +theorem sampled_queryCharge_le_queryBound (adversary : Adversary) (q : Nat) + (hq : HasHashQueryBound scheme adversary q) : sampledQueryCharge queryCharge adversary ≤ q := by + unfold sampledQueryCharge + calc + _ ≤ ∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets] * (q : ℝ≥0∞) := by + apply ENNReal.tsum_le_tsum + intro secrets + by_cases hsecrets : secrets ∈ support sampleSecrets + · obtain ⟨hparameter, hots, hfts⟩ := secrets.support_components hsecrets + apply mul_le_mul' le_rfl + simpa only [one_mul] using expectedQueryCharge_le_queryBound _ 1 + (queryCharge_le_one (primitiveAccountingKey secrets.parameter secrets.otsSecret secrets.ftsSecret)) + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret) q + (isQueryBoundP_gameAfterSecrets adversary q hq hparameter hots hfts) ∅ + · rw [probOutput_eq_zero_of_not_mem_support hsecrets, zero_mul, zero_mul] + _ ≤ _ := by + rw [ENNReal.tsum_mul_right] + exact mul_le_of_le_one_left (by positivity) tsum_probOutput_le_one + +theorem probEvent_sampledMonitorGame_hit_le_queryBound (adversary : Adversary) + (q : Nat) (hq : HasHashQueryBound scheme adversary q) : + Pr[fun result => result.history.hit = true | sampledMonitorGame adversary] ≤ + (q : ℝ≥0∞) * ((2 ^ 128 : Nat) : ℝ≥0∞)⁻¹ := by + apply (probEvent_sampledMonitorGame_hit_le_queryCharge adversary).trans + simpa [digestBits] using mul_le_mul' + (sampled_queryCharge_le_queryBound adversary q hq) (le_refl (Fintype.card Digest : ℝ≥0∞)⁻¹) + +theorem probEvent_verifierStructuralCollision_le_charge_add_unsettled + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[ViewedVerifierStructuralCollision parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + expectedQueryCharge (queryCharge (primitiveAccountingKey parameter otsSecret ftsSecret)) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ * (Fintype.card Digest : ℝ≥0∞)⁻¹ + + Pr[fun result => result.1.1 = true ∧ + BadOnInputs (primitiveAccountingKey parameter otsSecret ftsSecret) result.1.2 ↑result.2.unsettled | + runMonitor (primitiveAccountingKey parameter otsSecret ftsSecret) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ initialHistory] := by + let sk := primitiveAccountingKey parameter otsSecret ftsSecret + calc + _ ≤ Pr[fun result => result.1.2.2 = true ∧ BadOnInputs sk result.2.cache Set.univ | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + apply probEvent_mono + intro result _ hcollision + refine ⟨hcollision.1, ?_⟩ + obtain ⟨position, hsettled, input, ax, ay, hat, hne, hx, hy, heq⟩ := hcollision.bad + exact ⟨position, input, ax, ay, Set.mem_univ _, hsettled, hat, hne, hx, hy, heq⟩ + _ = Pr[fun result => result.1 = true ∧ BadOnInputs sk result.2 Set.univ | + (simulateQ romImpl (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅] := by + rw [← gameAfterSecretsWithViewTrace_verdictCache_projection, probEvent_map] + rfl + _ ≤ _ := by + simpa only [Set.univ_inter] using probEvent_badOnInputs_le_charge_add_unsettled sk + (gameAfterSecrets adversary parameter otsSecret ftsSecret) (fun result => result.1 = true) + (fun _ => Set.univ) + +theorem probEvent_sampled_verifierStructuralCollision_le_charge_add_unsettled + (adversary : Adversary) : + Pr[SampledViewedEvent ViewedVerifierStructuralCollision | sampledViewedGame adversary] ≤ + sampledQueryCharge queryCharge adversary * (Fintype.card Digest : ℝ≥0∞)⁻¹ + + Pr[WinningUnsettledCollision | sampledMonitorGame adversary] := by + rw [probEvent_sampledViewedGame_eq_weighted] + unfold sampledMonitorGame + rw [probEvent_bind_eq_tsum] + simp_rw [probEvent_map] + calc + _ ≤ ∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets] * + (expectedQueryCharge (queryCharge (primitiveAccountingKey secrets.parameter secrets.otsSecret secrets.ftsSecret)) + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret) ∅ * + (Fintype.card Digest : ℝ≥0∞)⁻¹ + + Pr[fun result => result.1.1 = true ∧ + BadOnInputs (primitiveAccountingKey secrets.parameter secrets.otsSecret secrets.ftsSecret) + result.1.2 ↑result.2.unsettled | + runMonitor (primitiveAccountingKey secrets.parameter secrets.otsSecret secrets.ftsSecret) + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret) ∅ initialHistory]) := + ENNReal.tsum_le_tsum fun secrets => mul_le_mul' le_rfl + (probEvent_verifierStructuralCollision_le_charge_add_unsettled adversary secrets.parameter + secrets.otsSecret secrets.ftsSecret) + _ = _ := by + simp_rw [mul_add, ← mul_assoc, ENNReal.tsum_add, ENNReal.tsum_mul_right] + rfl + +end SphincsSecurity.Concrete.SettledCollision diff --git a/formal/sphincs/SphincsSecurity/Proof/SettledCollisionMonitor.lean b/formal/sphincs/SphincsSecurity/Proof/SettledCollisionMonitor.lean new file mode 100644 index 00000000..9c7b4a4e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SettledCollisionMonitor.lean @@ -0,0 +1,127 @@ +import SphincsSecurity.Proof.SettledCollisionQuery + +namespace SphincsSecurity.Concrete.SettledCollision + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +structure History where + unsettled : Finset HashInput + hit : Bool + +def initialHistory : History := ⟨∅, false⟩ + +noncomputable def queryHit (secretKey : SecretKey) (cache : QueryCache HashSpec) : + (query : OracleWorld.Domain) → OracleWorld.Range query → Bool + | .inl _, _ => false + | .inr input, answer => decide (Collision secretKey cache input answer) + +noncomputable def advance (secretKey : SecretKey) (cache : QueryCache HashSpec) + (history : History) (query : OracleWorld.Domain) (answer : OracleWorld.Range query) : History where + unsettled := match query with + | .inl _ => history.unsettled + | .inr input => if cache input = none ∧ ¬ SettledInput secretKey cache input + then insert input history.unsettled else history.unsettled + hit := history.hit || queryHit secretKey cache query answer + +noncomputable def runMonitor (secretKey : SecretKey) + (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) (history : History) : + ProbComp ((α × QueryCache HashSpec) × History) := + OracleComp.construct + (C := fun _ => QueryCache HashSpec → History → ProbComp ((α × QueryCache HashSpec) × History)) + (fun value cache history => pure ((value, cache), history)) + (fun query _ next cache history => do + let result ← (romImpl query).run cache + next result.1 result.2 (advance secretKey cache history query result.1)) + computation cache history + +def hitPotential (history : History) : ℝ≥0∞ := if history.hit then 1 else 0 + +theorem runMonitor_project (secretKey : SecretKey) + (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) (history : History) : + Prod.fst <$> runMonitor secretKey computation cache history = + (simulateQ romImpl computation).run cache := by + induction computation using OracleComp.inductionOn generalizing cache history with + | pure value => simp [runMonitor, simulateQ_pure] + | query_bind query next ih => + rw [runMonitor, OracleComp.construct_query_bind, map_bind, + simulateQ_bind, simulateQ_spec_query, StateT.run_bind] + exact bind_congr fun result => ih result.1 result.2 _ + +theorem expected_advance_hit_le (secretKey : SecretKey) (query : OracleWorld.Domain) + (cache : QueryCache HashSpec) (history : History) : + (∑' result, Pr[= result | (romImpl query).run cache] * + hitPotential (advance secretKey cache history query result.1)) ≤ + hitPotential history + hashQueryCharge (fun cache input => + queryCharge secretKey cache input * (Fintype.card Digest : ℝ≥0∞)⁻¹) cache query := by + by_cases hhit : history.hit = true + · simp only [hitPotential, advance, hhit, Bool.true_or, ↓reduceIte, mul_one, + romImpl_query_mass] + exact le_self_add + · cases query with + | inl input => simp [hitPotential, advance, queryHit, hhit] + | inr input => + change (∑' result, Pr[= result | (randomOracle input).run cache] * + hitPotential (advance secretKey cache history (.inr input) result.1)) ≤ _ + by_cases hfresh : cache input = none + · rw [randomOracle, QueryImpl.withCaching_run_none _ hfresh, tsum_probOutput_map_mul] + simp only [hitPotential, advance, queryHit, Bool.or_eq_true, hhit, Bool.false_eq_true, false_or, + decide_eq_true_eq, ↓reduceIte, zero_add, hashQueryCharge, Sum.elim_inr] + simpa only [mul_ite, mul_one, mul_zero, probEvent_eq_tsum_ite, + uniformSampleImpl, probOutput_uniformSample] using + probEvent_collision_le_charge secretKey cache input + · obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hfresh + rw [randomOracle, QueryImpl.withCaching_run_some _ hanswer] + simp [hitPotential, advance, queryHit, Collision, hfresh, hhit] + +theorem expected_runMonitor_hit_le (secretKey : SecretKey) + (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) (history : History) : + (∑' result, Pr[= result | runMonitor secretKey computation cache history] * + hitPotential result.2) ≤ hitPotential history + + expectedQueryCharge (queryCharge secretKey) computation cache * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + rw [← expectedQueryCharge_mul] + let charge := fun cache input => queryCharge secretKey cache input * (Fintype.card Digest : ℝ≥0∞)⁻¹ + change _ ≤ _ + expectedQueryCharge charge computation cache + induction computation using OracleComp.inductionOn generalizing cache history with + | pure value => + simp only [runMonitor, OracleComp.construct_pure, tsum_probOutput_pure_mul, + expectedQueryCharge_pure, add_zero, le_refl] + | query_bind query next ih => + rw [runMonitor, OracleComp.construct_query_bind, tsum_probOutput_bind_mul, + expectedQueryCharge_query_bind] + calc + _ ≤ ∑' result, Pr[= result | (romImpl query).run cache] * + (hitPotential (advance secretKey cache history query result.1) + + expectedQueryCharge charge (next result.1) result.2) := + ENNReal.tsum_le_tsum fun result => mul_le_mul' le_rfl (ih result.1 result.2 _) + _ = (∑' result, Pr[= result | (romImpl query).run cache] * + hitPotential (advance secretKey cache history query result.1)) + + ∑' result, Pr[= result | (romImpl query).run cache] * + expectedQueryCharge charge (next result.1) result.2 := by + simp_rw [mul_add, ENNReal.tsum_add] + _ ≤ (hitPotential history + hashQueryCharge charge cache query) + + ∑' result, Pr[= result | (romImpl query).run cache] * + expectedQueryCharge charge (next result.1) result.2 := + add_le_add (expected_advance_hit_le secretKey query cache history) le_rfl + _ = _ := by rw [add_assoc] + +theorem probEvent_runMonitor_hit_le_queryCharge (secretKey : SecretKey) + (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) : + Pr[fun result => result.2.hit = true | runMonitor secretKey computation cache initialHistory] ≤ + expectedQueryCharge (queryCharge secretKey) computation cache * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + simpa only [hitPotential, initialHistory, Bool.false_eq_true, ↓reduceIte, zero_add, + mul_ite, mul_one, mul_zero, ← probEvent_eq_tsum_ite] using + expected_runMonitor_hit_le secretKey computation cache initialHistory + +theorem probEvent_runMonitor_hit_le_queryBound (secretKey : SecretKey) + (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) + (q : Nat) (hq : computation.IsQueryBoundP (· matches Sum.inr _) q) : + Pr[fun result => result.2.hit = true | runMonitor secretKey computation cache initialHistory] ≤ + (q : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + apply (probEvent_runMonitor_hit_le_queryCharge secretKey computation cache).trans + apply mul_le_mul' _ le_rfl + simpa only [one_mul] using expectedQueryCharge_le_queryBound (queryCharge secretKey) 1 + (queryCharge_le_one secretKey) computation q hq cache + +end SphincsSecurity.Concrete.SettledCollision diff --git a/formal/sphincs/SphincsSecurity/Proof/SettledCollisionQuery.lean b/formal/sphincs/SphincsSecurity/Proof/SettledCollisionQuery.lean new file mode 100644 index 00000000..3ada8ebb --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SettledCollisionQuery.lean @@ -0,0 +1,76 @@ +import SphincsSecurity.Proof.RetainedCollisionCache +import SphincsSecurity.Proof.Guess +import SphincsSecurity.Proof.RomQueryCharge + +namespace SphincsSecurity.Concrete.SettledCollision + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +def SettledInput (secretKey : SecretKey) (cache : QueryCache HashSpec) + (input : HashInput) : Prop := + ∃ position, AtPosition secretKey.parameter input position ∧ + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position + +def Collision (secretKey : SecretKey) (cache : QueryCache HashSpec) + (input : HashInput) (answer : HashOutput) : Prop := + cache input = none ∧ ∃ position, + AtPosition secretKey.parameter input position ∧ + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position ∧ + truncateHash answer = + honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret secretKey.ftsSecret position + +noncomputable def queryCharge (secretKey : SecretKey) (cache : QueryCache HashSpec) + (input : HashInput) : ℝ≥0∞ := + if cache input = none ∧ SettledInput secretKey cache input then 1 else 0 + +theorem queryCharge_le_one (secretKey : SecretKey) (cache : QueryCache HashSpec) + (input : HashInput) : queryCharge secretKey cache input ≤ 1 := by + unfold queryCharge + split_ifs <;> simp + +theorem probEvent_collision_le_charge (secretKey : SecretKey) (cache : QueryCache HashSpec) + (input : HashInput) : + Pr[Collision secretKey cache input | ($ᵗ HashOutput : ProbComp HashOutput)] ≤ + queryCharge secretKey cache input * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + by_cases heligible : cache input = none ∧ SettledInput secretKey cache input + · obtain ⟨hfresh, position, hat, hsettled⟩ := heligible + rw [queryCharge, if_pos ⟨hfresh, position, hat, hsettled⟩, one_mul] + calc + _ ≤ Pr[fun answer => truncateHash answer = + honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret secretKey.ftsSecret position | + ($ᵗ HashOutput : ProbComp HashOutput)] := by + apply probEvent_mono + rintro answer _ ⟨_, other, hother, _, hvalue⟩ + rwa [atPosition_unique secretKey.parameter hother hat] at hvalue + _ ≤ _ := by + rw [← probOutput_map] + simpa using probOutput_truncateHash_le + (honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret secretKey.ftsSecret position) + · have hempty : ∀ answer, ¬ Collision secretKey cache input answer := by + rintro answer ⟨hfresh, position, hat, hsettled, _⟩ + exact heligible ⟨hfresh, position, hat, hsettled⟩ + simp [queryCharge, heligible, probEvent_eq_tsum_ite, hempty] + +theorem collision_bad_cacheQuery {secretKey : SecretKey} {cache : QueryCache HashSpec} + {input : HashInput} {answer : HashOutput} + (hcollision : Collision secretKey cache input answer) : + BadOnInputs secretKey (cache.cacheQuery input answer) {input} := by + obtain ⟨hfresh, position, hat, hsettled, hvalue⟩ := hcollision + have hle := le_cacheQuery (answer := answer) hfresh + have hpinned := cachedInput_eq_of_settled hle hsettled + have hne : input ≠ cachedInput secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position := by + intro heq + exact hsettled.cached (heq ▸ hfresh) + obtain ⟨honestAnswer, hhonest⟩ := Option.ne_none_iff_exists'.mp hsettled.cached + refine ⟨position, input, answer, honestAnswer, rfl, hsettled.mono hle, hat, ?_, + QueryCache.cacheQuery_self _ _ _, ?_, ?_⟩ + · rwa [hpinned] + · rw [hpinned] + exact hle hhonest + · change truncateHash answer = truncateHash + (fromCache cache (cachedInput secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position)) at hvalue + simpa only [fromCache, hhonest, Option.getD_some] using hvalue + +end SphincsSecurity.Concrete.SettledCollision diff --git a/formal/sphincs/SphincsSecurity/Proof/SettledCollisionSupport.lean b/formal/sphincs/SphincsSecurity/Proof/SettledCollisionSupport.lean new file mode 100644 index 00000000..29ca13a8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SettledCollisionSupport.lean @@ -0,0 +1,146 @@ +import SphincsSecurity.Proof.SettledCollisionMonitor + +namespace SphincsSecurity.Concrete.SettledCollision + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +def HistoryInvariant (secretKey : SecretKey) (cache : QueryCache HashSpec) + (history : History) : Prop := + history.hit = false → ∀ input answer, input ∉ history.unsettled → cache input = some answer → + ∃ position, AtPosition secretKey.parameter input position ∧ + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position ∧ + truncateHash answer ≠ + honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret secretKey.ftsSecret position + +theorem historyInvariant_initial (secretKey : SecretKey) : + HistoryInvariant secretKey ∅ initialHistory := by + intro _ input answer _ hcached + simp at hcached + +theorem historyInvariant_fresh (secretKey : SecretKey) (cache : QueryCache HashSpec) + (history : History) (input : HashInput) (answer : HashOutput) + (hinvariant : HistoryInvariant secretKey cache history) (hfresh : cache input = none) : + HistoryInvariant secretKey (cache.cacheQuery input answer) + (advance secretKey cache history (.inr input) answer) := by + intro hfalse other otherAnswer hnot hcached + have hflags : history.hit = false ∧ ¬ Collision secretKey cache input answer := by + simpa only [advance, queryHit, Bool.or_eq_false_iff, decide_eq_false_iff_not] using hfalse + have hle := le_cacheQuery (answer := answer) hfresh + have hnotOld : other ∉ history.unsettled := by + intro hmem + apply hnot + simp only [advance] + split_ifs + · exact Finset.mem_insert_of_mem hmem + · exact hmem + by_cases heq : other = input + · subst other + have hsettledInput : SettledInput secretKey cache input := by + by_contra hnone + simp [advance, hfresh, hnone] at hnot + obtain ⟨position, hat, hsettled⟩ := hsettledInput + have hanswer : otherAnswer = answer := by + simpa only [QueryCache.cacheQuery_self, Option.some.injEq] using hcached.symm + subst otherAnswer + refine ⟨position, hat, hsettled.mono hle, ?_⟩ + rw [honestValue_eq_of_settled (agreesWithFn_fromCache_of_le hle) hsettled] + intro hvalue + exact hflags.2 ⟨hfresh, position, hat, hsettled, hvalue⟩ + · have hcachedOld : cache other = some otherAnswer := by + rwa [QueryCache.cacheQuery_of_ne _ _ heq] at hcached + obtain ⟨position, hat, hsettled, hne⟩ := hinvariant hflags.1 other otherAnswer hnotOld hcachedOld + refine ⟨position, hat, hsettled.mono hle, ?_⟩ + rwa [honestValue_eq_of_settled (agreesWithFn_fromCache_of_le hle) hsettled] + +theorem historyInvariant_advance (secretKey : SecretKey) (cache : QueryCache HashSpec) + (history : History) (query : OracleWorld.Domain) + (result : OracleWorld.Range query × QueryCache HashSpec) + (hinvariant : HistoryInvariant secretKey cache history) + (hresult : result ∈ support ((romImpl query).run cache)) : + HistoryInvariant secretKey result.2 (advance secretKey cache history query result.1) := by + cases query with + | inl input => + change unifSpec.Range input × QueryCache HashSpec at result + have hquery : (romImpl (.inl input)).run cache = + (fun answer => (answer, cache)) <$> (liftM (unifSpec.query input) : ProbComp _) := rfl + rw [hquery] at hresult + change result ∈ support ((fun answer : Fin (input + 1) => (answer, cache)) <$> + (liftM (unifSpec.query input) : ProbComp (Fin (input + 1)))) at hresult + rw [support_map] at hresult + obtain ⟨answer, _, rfl⟩ := hresult + simpa only [advance, queryHit, Bool.or_false] using hinvariant + | inr input => + change HashOutput × QueryCache HashSpec at result + change result ∈ support ((randomOracle input).run cache) at hresult + by_cases hfresh : cache input = none + · rw [randomOracle, QueryImpl.withCaching_run_none _ hfresh, support_map] at hresult + obtain ⟨answer, _, rfl⟩ := hresult + exact historyInvariant_fresh secretKey cache history input answer hinvariant hfresh + · obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hfresh + rw [randomOracle, QueryImpl.withCaching_run_some _ hanswer, + support_pure, Set.mem_singleton_iff] at hresult + subst result + simpa only [advance, queryHit, Collision, hfresh, false_and, decide_false, + Bool.or_false, if_false] using hinvariant + +theorem historyInvariant_runMonitor (secretKey : SecretKey) + (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) (history : History) + (hinvariant : HistoryInvariant secretKey cache history) + (result : (α × QueryCache HashSpec) × History) + (hresult : result ∈ support (runMonitor secretKey computation cache history)) : + HistoryInvariant secretKey result.1.2 result.2 := by + induction computation using OracleComp.inductionOn generalizing cache history with + | pure value => + simp only [runMonitor, OracleComp.construct_pure, support_pure, Set.mem_singleton_iff] at hresult + subst result + exact hinvariant + | query_bind query next ih => + rw [runMonitor, OracleComp.construct_query_bind, mem_support_bind_iff] at hresult + obtain ⟨response, hresponse, hresult⟩ := hresult + exact ih response.1 response.2 _ + (historyInvariant_advance secretKey cache history query response hinvariant hresponse) hresult + +theorem badOnInputs_implies_hit_or_unsettled {secretKey : SecretKey} + {cache : QueryCache HashSpec} {history : History} {inputs : Set HashInput} + (hinvariant : HistoryInvariant secretKey cache history) + (hbad : BadOnInputs secretKey cache inputs) : + history.hit = true ∨ BadOnInputs secretKey cache (inputs ∩ ↑history.unsettled) := by + by_cases hhit : history.hit = true + · exact Or.inl hhit + · right + obtain ⟨position, input, ax, ay, hinput, hsettled, hat, hne, hx, hy, hvalue⟩ := hbad + refine ⟨position, input, ax, ay, ⟨hinput, ?_⟩, hsettled, hat, hne, hx, hy, hvalue⟩ + by_contra hnot + obtain ⟨other, hother, _, havoid⟩ := hinvariant (Bool.eq_false_iff.mpr hhit) input ax hnot hx + rw [atPosition_unique secretKey.parameter hother hat] at havoid + apply havoid + change truncateHash ax = truncateHash + (fromCache cache (cachedInput secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position)) + simpa only [fromCache, hy, Option.getD_some] using hvalue + +theorem probEvent_badOnInputs_le_charge_add_unsettled (secretKey : SecretKey) + (computation : OracleComp OracleWorld α) + (guard : α × QueryCache HashSpec → Prop) + (inputs : α × QueryCache HashSpec → Set HashInput) : + Pr[fun result => guard result ∧ BadOnInputs secretKey result.2 (inputs result) | + (simulateQ romImpl computation).run ∅] ≤ + expectedQueryCharge (queryCharge secretKey) computation ∅ * (Fintype.card Digest : ℝ≥0∞)⁻¹ + + Pr[fun result => guard result.1 ∧ BadOnInputs secretKey result.1.2 + (inputs result.1 ∩ ↑result.2.unsettled) | runMonitor secretKey computation ∅ initialHistory] := by + rw [← runMonitor_project secretKey computation ∅ initialHistory, probEvent_map] + calc + _ ≤ Pr[fun result => result.2.hit = true ∨ (guard result.1 ∧ BadOnInputs secretKey result.1.2 + (inputs result.1 ∩ ↑result.2.unsettled)) | runMonitor secretKey computation ∅ initialHistory] := by + apply probEvent_mono + rintro result hresult ⟨hguard, hbad⟩ + rcases badOnInputs_implies_hit_or_unsettled + (historyInvariant_runMonitor secretKey computation ∅ initialHistory + (historyInvariant_initial secretKey) result hresult) hbad with hhit | hunsettled + · exact Or.inl hhit + · exact Or.inr ⟨hguard, hunsettled⟩ + _ ≤ _ := (probEvent_or_le _ _ _).trans + (add_le_add (probEvent_runMonitor_hit_le_queryCharge secretKey computation ∅) le_rfl) + +end SphincsSecurity.Concrete.SettledCollision diff --git a/formal/sphincs/SphincsSecurity/Proof/SettledCollisionViewedGame.lean b/formal/sphincs/SphincsSecurity/Proof/SettledCollisionViewedGame.lean new file mode 100644 index 00000000..e6537862 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SettledCollisionViewedGame.lean @@ -0,0 +1,96 @@ +import SphincsSecurity.Proof.SettledCollisionViewedTerminal + +namespace SphincsSecurity.Concrete.SettledCollision + +open OracleComp OracleSpec ENNReal + +structure SampledViewedMonitorResult where + secrets : SampledSecrets + result : ViewedResult + +noncomputable def sampledViewedMonitorGame (adversary : Adversary) : ProbComp SampledViewedMonitorResult := do + let secrets ← sampleSecrets + (fun result => ⟨secrets, result⟩) <$> + gameAfterSecretsWithView adversary secrets.parameter secrets.otsSecret secrets.ftsSecret + +def SampledViewedMonitorResult.erase (result : SampledViewedMonitorResult) : SampledViewedResult := + ⟨result.secrets, eraseHistory result.result⟩ + +def SampledViewedMonitorResult.monitor (result : SampledViewedMonitorResult) : GameResult := + ⟨result.secrets, result.result.1.2.2, result.result.2.1.cache, result.result.2.2⟩ + +def SampledMonitorEvent + (event : PublicParameter → + (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) → + (Index → FtsTree → FtsLeaf → Digest) → ViewedResult → Prop) + (result : SampledViewedMonitorResult) : Prop := + event result.secrets.parameter result.secrets.otsSecret result.secrets.ftsSecret result.result + +theorem sampledViewedMonitorGame_erase (adversary : Adversary) : + SampledViewedMonitorResult.erase <$> sampledViewedMonitorGame adversary = sampledViewedGame adversary := by + unfold sampledViewedMonitorGame sampledViewedGame + rw [map_bind] + apply bind_congr + intro secrets + rw [Functor.map_map, ← gameAfterSecretsWithView_projection] + simp only [bind_pure_comp, Functor.map_map] + rfl + +theorem sampledViewedMonitorGame_monitor (adversary : Adversary) : + SampledViewedMonitorResult.monitor <$> sampledViewedMonitorGame adversary = sampledMonitorGame adversary := by + unfold sampledViewedMonitorGame sampledMonitorGame + rw [map_bind] + apply bind_congr + intro secrets + rw [Functor.map_map, ← gameAfterSecretsWithView_monitor_projection, Functor.map_map] + rfl + +theorem probEvent_sampledViewedMonitorGame_hit_le_queryCharge (adversary : Adversary) : + Pr[fun result => result.result.2.2.hit = true | sampledViewedMonitorGame adversary] ≤ + sampledQueryCharge queryCharge adversary * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + have hbound := probEvent_sampledMonitorGame_hit_le_queryCharge adversary + rw [← sampledViewedMonitorGame_monitor, probEvent_map] at hbound + exact hbound + +theorem probEvent_sampledMonitorEvent_eq_weighted (adversary : Adversary) + (event : PublicParameter → + (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) → + (Index → FtsTree → FtsLeaf → Digest) → ViewedResult → Prop) : + Pr[SampledMonitorEvent event | sampledViewedMonitorGame adversary] = + ∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets] * + Pr[event secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithView adversary secrets.parameter secrets.otsSecret secrets.ftsSecret] := by + unfold sampledViewedMonitorGame + rw [probEvent_bind_eq_tsum] + simp only [probEvent_map] + rfl + +theorem probEvent_sampled_verifierPrimitive_le_charge_add_remaining (adversary : Adversary) : + Pr[SampledViewedEvent verifierPrimitiveEvent | sampledViewedGame adversary] ≤ + sampledQueryCharge queryCharge adversary * (Fintype.card Digest : ℝ≥0∞)⁻¹ + + Pr[SampledMonitorEvent remainingPrimitiveEvent | sampledViewedMonitorGame adversary] := by + rw [← sampledViewedMonitorGame_erase, probEvent_map] + calc + _ ≤ Pr[fun result => result.result.2.2.hit = true ∨ + SampledMonitorEvent remainingPrimitiveEvent result | sampledViewedMonitorGame adversary] := by + apply probEvent_mono + intro result hresult hevent + rw [sampledViewedMonitorGame, mem_support_bind_iff] at hresult + obtain ⟨secrets, _, hresult⟩ := hresult + rw [support_map] at hresult + obtain ⟨viewed, hviewed, rfl⟩ := hresult + exact verifierPrimitiveEvent_implies_hit_or_remaining adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret viewed hviewed hevent + _ ≤ _ := (probEvent_or_le _ _ _).trans + (add_le_add (probEvent_sampledViewedMonitorGame_hit_le_queryCharge adversary) le_rfl) + +theorem probEvent_sampled_remaining_le_verifierPrimitive (adversary : Adversary) : + Pr[SampledMonitorEvent remainingPrimitiveEvent | sampledViewedMonitorGame adversary] ≤ + Pr[SampledViewedEvent verifierPrimitiveEvent | sampledViewedGame adversary] := by + rw [← sampledViewedMonitorGame_erase, probEvent_map] + apply probEvent_mono + intro result _ hevent + exact remainingPrimitiveEvent_implies_verifierPrimitiveEvent result.secrets.parameter + result.secrets.otsSecret result.secrets.ftsSecret result.result hevent + +end SphincsSecurity.Concrete.SettledCollision diff --git a/formal/sphincs/SphincsSecurity/Proof/SettledCollisionViewedProjection.lean b/formal/sphincs/SphincsSecurity/Proof/SettledCollisionViewedProjection.lean new file mode 100644 index 00000000..d36ff8f4 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SettledCollisionViewedProjection.lean @@ -0,0 +1,184 @@ +import SphincsSecurity.Proof.SettledCollisionViewedTrace + +namespace SphincsSecurity.Concrete.SettledCollision + +open OracleComp OracleSpec + +noncomputable def loggedAdversaryImpl (accountingKey secretKey : SecretKey) : + QueryImpl (OracleWorld + SigningSpec) + (StateT ((QueryCache HashSpec × History) × QueryLog SigningSpec) ProbComp) := + fun input state => do + let result ← (((monitorImpl accountingKey).writerTMapBase + (forwardOracles + signingOracle scheme secretKey) input).run).run state.1 + pure (result.1.1, (result.2, state.2 ++ result.1.2)) + +theorem loggedAdversaryImpl_query (accountingKey secretKey : SecretKey) + (input : (OracleWorld + SigningSpec).Domain) + (cache : QueryCache HashSpec) (history : History) (log : QueryLog SigningSpec) : + (loggedAdversaryImpl accountingKey secretKey input).run ((cache, history), log) = + (fun result => (result.1.1.1, ((result.1.2, result.2), log ++ result.1.1.2))) <$> + runMonitor accountingKey + (((forwardOracles + signingOracle scheme secretKey) input).run) cache history := by + change (((monitorImpl accountingKey).writerTMapBase + (forwardOracles + signingOracle scheme secretKey) input).run).run (cache, history) >>= _ = _ + rw [QueryImpl.writerTMapBase, WriterT.run_mk, simulateQ_monitorImpl_run] + simp + +theorem loggedAdversaryImpl_run (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (cache : QueryCache HashSpec) (history : History) (log : QueryLog SigningSpec) : + (simulateQ (loggedAdversaryImpl accountingKey secretKey) computation).run ((cache, history), log) = + (fun result => (result.1.1.1, ((result.1.2, result.2), log ++ result.1.1.2))) <$> + runMonitor accountingKey + ((simulateQ (forwardOracles + signingOracle scheme secretKey) computation).run) cache history := by + rw [runMonitor_eq_simulateQ, Functor.map_map, + QueryImpl.simulateQ_writerTMapBase_run] + induction computation using OracleComp.inductionOn generalizing cache history log with + | pure value => simp + | query_bind input next ih => + simp only [simulateQ_bind, simulateQ_spec_query, WriterT.run_bind', + StateT.run_bind, StateT.run_map, map_bind, Functor.map_map] + simp only [loggedAdversaryImpl, StateT.run, bind_assoc, pure_bind] + apply bind_congr + intro result + simpa [List.append_assoc, StateT.run] using ih result.1.1 result.2.1 result.2.2 (log ++ result.1.2) + +def viewedLogState (state : ViewedFullTraceState × History) : + (QueryCache HashSpec × History) × QueryLog SigningSpec := + ((state.1.cache, state.2), state.1.trace.signing.toSigningLog) + +theorem viewedAdversaryImpl_query_log_projection + (accountingKey secretKey : SecretKey) (input : (OracleWorld + SigningSpec).Domain) + (state : ViewedFullTraceState × History) : + Prod.map id viewedLogState <$> + (viewedAdversaryImpl accountingKey secretKey input).run state = + (loggedAdversaryImpl accountingKey secretKey input).run + (viewedLogState state) := by + change _ = (loggedAdversaryImpl accountingKey secretKey input).run + ((state.1.cache, state.2), state.1.trace.signing.toSigningLog) + rw [loggedAdversaryImpl_query] + cases input with + | inl query => + have hquery : (((forwardOracles + signingOracle scheme secretKey) (.inl query)).run) = + (fun output => (output, ([] : QueryLog SigningSpec))) <$> + (liftM (OracleWorld.query query) : OracleComp OracleWorld _) := rfl + rw [hquery] + erw [runMonitor_map] + cases query <;> + simp [viewedAdversaryImpl, viewedLogState, + fullAdversaryTraceUpdate, signingCacheTraceUpdate, StateT.run, Prod.map] + | inr request => + have hquery : (((forwardOracles + signingOracle scheme secretKey) (.inr request)).run) = + (fun output => (output, ([⟨request, output⟩] : QueryLog SigningSpec))) <$> + sign secretKey request := by + change (QueryImpl.withLogging (spec := SigningSpec) (fun request => scheme.sign secretKey request) request).run = _ + rw [QueryImpl.run_withLogging_apply] + rfl + have hsign := runMonitor_map accountingKey Prod.fst + (signWithView secretKey request) state.1.cache state.2 + rw [signWithView_fst] at hsign + rw [hquery] + erw [runMonitor_map] + rw [hsign] + simp [viewedAdversaryImpl, viewedLogState, + fullAdversaryTraceUpdate, signingCacheTraceUpdate, SigningCacheTrace.toSigningLog, + StateT.run, Prod.map] + +theorem viewedAdversaryImpl_log_projection + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × History) : + Prod.map id viewedLogState <$> + (simulateQ (viewedAdversaryImpl accountingKey secretKey) computation).run state = + (fun result => (result.1.1.1, + ((result.1.2, result.2), state.1.trace.signing.toSigningLog ++ result.1.1.2))) <$> + runMonitor accountingKey + ((simulateQ (forwardOracles + signingOracle scheme secretKey) computation).run) state.1.cache state.2 := by + rw [← loggedAdversaryImpl_run] + apply OracleComp.map_run_simulateQ_eq_of_query_map_eq + (viewedAdversaryImpl accountingKey secretKey) + (loggedAdversaryImpl accountingKey secretKey) viewedLogState + exact viewedAdversaryImpl_query_log_projection accountingKey secretKey + +theorem viewedAdversaryImpl_support_monitor + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × History) + (result : α × (ViewedFullTraceState × History)) + (hresult : result ∈ support + ((simulateQ (viewedAdversaryImpl accountingKey secretKey) computation).run state)) : + ∃ log : QueryLog SigningSpec, + (((result.1, log), result.2.1.cache), result.2.2) ∈ support + (runMonitor accountingKey + ((simulateQ (forwardOracles + signingOracle scheme secretKey) computation).run) state.1.cache state.2) ∧ + state.1.trace.signing.toSigningLog ++ log = result.2.1.trace.signing.toSigningLog := by + have hproject : Prod.map id viewedLogState result ∈ support + ((fun result => (result.1.1.1, + ((result.1.2, result.2), state.1.trace.signing.toSigningLog ++ result.1.1.2))) <$> + runMonitor accountingKey + ((simulateQ (forwardOracles + signingOracle scheme secretKey) computation).run) state.1.cache state.2) := by + rw [← viewedAdversaryImpl_log_projection, support_map] + exact ⟨result, hresult, rfl⟩ + rw [support_map] at hproject + obtain ⟨⟨⟨⟨value, log⟩, cache⟩, history⟩, hrun, heq⟩ := hproject + simp only [Prod.map, id_eq, viewedLogState, Prod.mk.injEq] at heq + obtain ⟨rfl, ⟨rfl, rfl⟩, hlog⟩ := heq + exact ⟨log, hrun, hlog⟩ + +theorem runMonitor_verifyWithView_fst (accountingKey : SecretKey) + (publicKey : PublicKey) (message : Message) (signature : Signature) + (cache : QueryCache HashSpec) (history : History) : + runMonitor accountingKey (scheme.verify publicKey message signature) cache history = + (fun result => ((result.1.1.1, result.1.2), result.2)) <$> + runMonitor accountingKey + (liftM (verifyWithView publicKey message signature) : OracleComp OracleWorld (Bool × FewTimeView)) + cache history := by + have heq : scheme.verify publicKey message signature = + Prod.fst <$> (liftM (verifyWithView publicKey message signature) : + OracleComp OracleWorld (Bool × FewTimeView)) := by + rw [← liftM_map, verifyWithView_fst] + rfl + rw [heq, runMonitor_map] + +theorem gameRestWithView_monitor_projection (adversary : Adversary) + (accountingKey : SecretKey) (publicKey : PublicKey) (secretKey : SecretKey) + (initialCache : QueryCache HashSpec) (history : History) : + (fun result => ((result.1.2, result.2.1.cache), result.2.2)) <$> + gameRestWithView adversary accountingKey publicKey secretKey initialCache history = + runMonitor accountingKey (gameRest scheme adversary publicKey secretKey) initialCache history := by + let finish : Forgery × ((QueryCache HashSpec × History) × QueryLog SigningSpec) → + ProbComp ((Bool × QueryCache HashSpec) × History) := fun result => do + let verified ← runMonitor accountingKey + (scheme.verify publicKey result.1.message result.1.signature) result.2.1.1 result.2.1.2 + pure ((decide (SigningTranscript.Valid result.2.2 ∧ + ¬ SigningTranscript.Contains result.2.2 result.1) && verified.1.1, verified.1.2), verified.2) + let state : ViewedFullTraceState × History := (⟨initialCache, ⟨[], [], []⟩, [], none⟩, history) + calc + _ = (Prod.map id viewedLogState <$> + (simulateQ (viewedAdversaryImpl accountingKey secretKey) + (adversary.main publicKey)).run state) >>= finish := by + simp [gameRestWithView, state, finish, viewedLogState, + runMonitor_verifyWithView_fst, map_bind, bind_map_left, Prod.map] + rfl + _ = _ := by + rw [viewedAdversaryImpl_log_projection] + rw [gameRest, runMonitor_bind] + simp only [runMonitor_bind, runMonitor_pure] + simp [finish, state, SigningCacheTrace.toSigningLog, bind_map_left] + +theorem gameAfterSecretsWithView_monitor_projection (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + (fun result => ((result.1.2.2, result.2.1.cache), result.2.2)) <$> + gameAfterSecretsWithView adversary parameter otsSecret ftsSecret = + runMonitor (primitiveAccountingKey parameter otsSecret ftsSecret) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ initialHistory := by + rw [gameAfterSecretsWithView, gameAfterSecrets, runMonitor_bind] + simp only [map_bind] + apply bind_congr + intro result + rw [← gameRestWithView_monitor_projection adversary + (primitiveAccountingKey parameter otsSecret ftsSecret) ⟨result.1.1, parameter⟩ + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ result.1.2 result.2] + simp + +end SphincsSecurity.Concrete.SettledCollision diff --git a/formal/sphincs/SphincsSecurity/Proof/SettledCollisionViewedTerminal.lean b/formal/sphincs/SphincsSecurity/Proof/SettledCollisionViewedTerminal.lean new file mode 100644 index 00000000..2637fab5 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SettledCollisionViewedTerminal.lean @@ -0,0 +1,116 @@ +import SphincsSecurity.Proof.SettledCollisionViewedProjection +import SphincsSecurity.Proof.VerifierPrimitiveTerminal + +namespace SphincsSecurity.Concrete.SettledCollision + +open OracleComp OracleSpec ENNReal + +abbrev ViewedResult := (Digest × Forgery × Bool) × (ViewedFullTraceState × History) + +def eraseHistory (result : ViewedResult) : (Digest × Forgery × Bool) × ViewedFullTraceState := + (result.1, result.2.1) + +def UnsettledVerifierCollision (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (result : ViewedResult) : Prop := + result.1.2.2 = true ∧ + evalWithAnswerFn (fromCache result.2.1.cache) + (verify ⟨result.1.1, parameter⟩ result.1.2.1.message result.1.2.1.signature) = true ∧ + CachedRun result.2.1.cache (fromCache result.2.1.cache) + (verify ⟨result.1.1, parameter⟩ result.1.2.1.message result.1.2.1.signature) ∧ + BadOnInputs ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ result.2.1.cache + ({input | input ∈ queriedInputs (fromCache result.2.1.cache) + (verify ⟨result.1.1, parameter⟩ result.1.2.1.message result.1.2.1.signature)} ∩ + ↑result.2.2.unsettled) + +theorem UnsettledVerifierCollision.structuralCollision {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} {result : ViewedResult} + (hevent : UnsettledVerifierCollision parameter otsSecret ftsSecret result) : + ViewedVerifierStructuralCollision parameter otsSecret ftsSecret (eraseHistory result) := by + rw [viewedVerifierStructuralCollision_iff_fromCache] + obtain ⟨hwin, heval, hrun, hbad⟩ := hevent + exact ⟨hwin, heval, hrun, hbad.mono_inputs Set.inter_subset_left⟩ + +theorem historyInvariant_gameAfterSecretsWithView (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (result : ViewedResult) + (hresult : result ∈ support (gameAfterSecretsWithView adversary parameter otsSecret ftsSecret)) : + HistoryInvariant (primitiveAccountingKey parameter otsSecret ftsSecret) result.2.1.cache result.2.2 := by + have hproject : ((result.1.2.2, result.2.1.cache), result.2.2) ∈ support + (runMonitor (primitiveAccountingKey parameter otsSecret ftsSecret) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ initialHistory) := by + rw [← gameAfterSecretsWithView_monitor_projection, support_map] + exact ⟨result, hresult, rfl⟩ + exact historyInvariant_runMonitor _ _ ∅ initialHistory (historyInvariant_initial _) _ hproject + +theorem structuralCollision_implies_hit_or_unsettled (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (result : ViewedResult) + (hresult : result ∈ support (gameAfterSecretsWithView adversary parameter otsSecret ftsSecret)) + (hcollision : ViewedVerifierStructuralCollision parameter otsSecret ftsSecret (eraseHistory result)) : + result.2.2.hit = true ∨ UnsettledVerifierCollision parameter otsSecret ftsSecret result := by + rw [viewedVerifierStructuralCollision_iff_fromCache] at hcollision + obtain ⟨hwin, heval, hrun, hbad⟩ := hcollision + have hinvariant : HistoryInvariant ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.1.cache result.2.2 := + historyInvariant_gameAfterSecretsWithView adversary parameter otsSecret ftsSecret result hresult + rcases badOnInputs_implies_hit_or_unsettled hinvariant hbad with hhit | hunsettled + · exact Or.inl hhit + · exact Or.inr ⟨hwin, heval, hrun, hunsettled⟩ + +def remainingPrimitiveEvent (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (result : ViewedResult) : Prop := + result.2.2.hit = false ∧ result.1.2.2 = true ∧ + (UnsettledVerifierCollision parameter otsSecret ftsSecret result ∨ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret (eraseHistory result) ∨ + ViewedWinningFreshLayerOpeningWitness parameter otsSecret ftsSecret (eraseHistory result) ∨ + ViewedWinningBackwardChainOpeningWitness parameter otsSecret ftsSecret (eraseHistory result) ∨ + ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret (eraseHistory result)) + +theorem remainingPrimitiveEvent_implies_verifierPrimitiveEvent + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (result : ViewedResult) + (hevent : remainingPrimitiveEvent parameter otsSecret ftsSecret result) : + verifierPrimitiveEvent parameter otsSecret ftsSecret (eraseHistory result) := by + obtain ⟨_, hwin, hcollision | hrest⟩ := hevent + · exact ⟨hwin, Or.inl hcollision.structuralCollision⟩ + · exact ⟨hwin, Or.inr hrest⟩ + +theorem verifierPrimitiveEvent_implies_hit_or_remaining (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (result : ViewedResult) + (hresult : result ∈ support (gameAfterSecretsWithView adversary parameter otsSecret ftsSecret)) + (hevent : verifierPrimitiveEvent parameter otsSecret ftsSecret (eraseHistory result)) : + result.2.2.hit = true ∨ remainingPrimitiveEvent parameter otsSecret ftsSecret result := by + by_cases hhit : result.2.2.hit = true + · exact Or.inl hhit + have hfalse := Bool.eq_false_iff.mpr hhit + obtain ⟨hwin, hcollision | hrest⟩ := hevent + · rcases structuralCollision_implies_hit_or_unsettled adversary parameter otsSecret ftsSecret + result hresult hcollision with hhit | hunsettled + · exact Or.inl hhit + · exact Or.inr ⟨hfalse, hwin, Or.inl hunsettled⟩ + · exact Or.inr ⟨hfalse, hwin, Or.inr hrest⟩ + +theorem probEvent_verifierPrimitive_le_hit_add_remaining (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[verifierPrimitiveEvent parameter otsSecret ftsSecret | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + Pr[fun result => result.2.2.hit = true | gameAfterSecretsWithView adversary parameter otsSecret ftsSecret] + + Pr[remainingPrimitiveEvent parameter otsSecret ftsSecret | + gameAfterSecretsWithView adversary parameter otsSecret ftsSecret] := by + rw [← gameAfterSecretsWithView_projection, probEvent_map] + apply le_trans _ (probEvent_or_le _ _ _) + apply probEvent_mono + intro result hresult hevent + exact verifierPrimitiveEvent_implies_hit_or_remaining adversary parameter otsSecret ftsSecret result hresult hevent + +end SphincsSecurity.Concrete.SettledCollision diff --git a/formal/sphincs/SphincsSecurity/Proof/SettledCollisionViewedTrace.lean b/formal/sphincs/SphincsSecurity/Proof/SettledCollisionViewedTrace.lean new file mode 100644 index 00000000..d4f5707e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SettledCollisionViewedTrace.lean @@ -0,0 +1,129 @@ +import SphincsSecurity.Proof.SettledCollisionComposition +import SphincsSecurity.Proof.SettledCollisionGame + +namespace SphincsSecurity.Concrete.SettledCollision + +open OracleComp OracleSpec + +noncomputable def viewedAdversaryImpl (accountingKey secretKey : SecretKey) : + QueryImpl (OracleWorld + SigningSpec) (StateT (ViewedFullTraceState × History) ProbComp) := by + intro input + cases input with + | inl query => + exact fun state => do + let result ← runMonitor accountingKey (OracleWorld.query query) state.1.cache state.2 + let trace := fullAdversaryTraceUpdate (.inl query) state.1.cache result.1.1 result.1.2 state.1.trace + pure (result.1.1, (⟨result.1.2, trace, state.1.views, state.1.targetView⟩, result.2)) + | inr request => + exact fun state => do + let result ← runMonitor accountingKey (signWithView secretKey request) state.1.cache state.2 + let trace := fullAdversaryTraceUpdate (.inr request) state.1.cache result.1.1.1 result.1.2 state.1.trace + pure (result.1.1.1, (⟨result.1.2, trace, state.1.views ++ [result.1.1.2], state.1.targetView⟩, result.2)) + +theorem viewedAdversaryImpl_query_projection + (accountingKey secretKey : SecretKey) (input : (OracleWorld + SigningSpec).Domain) + (state : ViewedFullTraceState × History) : + (fun result => (result.1, result.2.1)) <$> + (viewedAdversaryImpl accountingKey secretKey input).run state = + (viewedFullTracedMappedAdversaryImpl secretKey input).run state.1 := by + cases input with + | inl query => + have hp := runMonitor_project accountingKey + (liftM (OracleWorld.query query) : OracleComp OracleWorld _) state.1.cache state.2 + rw [simulateQ_spec_query] at hp + change Prod.fst <$> runMonitor accountingKey + (liftM (OracleWorld.query query) : OracleComp OracleWorld _) state.1.cache state.2 = + romImpl query state.1.cache at hp + have h := congrArg (fun run => + (fun result => (result.1, (⟨result.2, + fullAdversaryTraceUpdate (.inl query) state.1.cache result.1 result.2 state.1.trace, + state.1.views, state.1.targetView⟩ : ViewedFullTraceState))) <$> run) hp + cases query <;> + simpa [viewedAdversaryImpl, viewedFullTracedMappedAdversaryImpl, StateT.run] using h + | inr request => + have hp := runMonitor_project accountingKey + (signWithView secretKey request) state.1.cache state.2 + change Prod.fst <$> runMonitor accountingKey + (signWithView secretKey request) state.1.cache state.2 = + simulateQ romImpl (signWithView secretKey request) state.1.cache at hp + simpa [viewedAdversaryImpl, viewedFullTracedMappedAdversaryImpl, + StateT.run] using congrArg (fun run => + (fun result => (result.1.1, (⟨result.2, + fullAdversaryTraceUpdate (.inr request) state.1.cache result.1.1 result.2 state.1.trace, + state.1.views ++ [result.1.2], state.1.targetView⟩ : ViewedFullTraceState))) <$> run) hp + +theorem viewedAdversaryImpl_projection + (accountingKey secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) (state : ViewedFullTraceState × History) : + Prod.map id Prod.fst <$> + (simulateQ (viewedAdversaryImpl accountingKey secretKey) computation).run state = + (simulateQ (viewedFullTracedMappedAdversaryImpl secretKey) computation).run state.1 := by + apply OracleComp.map_run_simulateQ_eq_of_query_map_eq + (viewedAdversaryImpl accountingKey secretKey) + (viewedFullTracedMappedAdversaryImpl secretKey) Prod.fst + exact viewedAdversaryImpl_query_projection accountingKey secretKey + +noncomputable def gameRestWithView (adversary : Adversary) + (accountingKey : SecretKey) (publicKey : PublicKey) (secretKey : SecretKey) + (initialCache : QueryCache HashSpec) (history : History) : + ProbComp ((Forgery × Bool) × (ViewedFullTraceState × History)) := do + let (forgery, state) ← + (simulateQ (viewedAdversaryImpl accountingKey secretKey) + (adversary.main publicKey)).run (⟨initialCache, ⟨[], [], []⟩, [], none⟩, history) + let result ← runMonitor accountingKey + (liftM (verifyWithView publicKey forgery.message forgery.signature) : + OracleComp OracleWorld (Bool × FewTimeView)) state.1.cache state.2 + let log := state.1.trace.signing.toSigningLog + let verdict := decide (SigningTranscript.Valid log ∧ ¬ SigningTranscript.Contains log forgery) && result.1.1.1 + pure ((forgery, verdict), (⟨result.1.2, state.1.trace, state.1.views, some result.1.1.2⟩, result.2)) + +theorem gameRestWithView_projection (adversary : Adversary) + (accountingKey : SecretKey) (publicKey : PublicKey) (secretKey : SecretKey) + (initialCache : QueryCache HashSpec) (history : History) : + (fun result => (result.1, result.2.1)) <$> + gameRestWithView adversary accountingKey publicKey secretKey initialCache history = + gameRestWithViewTrace adversary publicKey secretKey initialCache := by + rw [gameRestWithView, gameRestWithViewTrace, + ← viewedAdversaryImpl_projection accountingKey secretKey + (adversary.main publicKey) (⟨initialCache, ⟨[], [], []⟩, [], none⟩, history)] + simp only [map_bind, bind_map_left, Prod.map, id_eq] + apply bind_congr + intro result + rw [← runMonitor_project accountingKey + (liftM (verifyWithView publicKey result.1.message result.1.signature) : + OracleComp OracleWorld (Bool × FewTimeView)) result.2.1.cache result.2.2] + simp + +noncomputable def gameAfterSecretsWithView (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ProbComp ((Digest × Forgery × Bool) × (ViewedFullTraceState × History)) := do + let accountingKey := primitiveAccountingKey parameter otsSecret ftsSecret + let rootResult ← runMonitor accountingKey + (liftM (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : + OracleComp HashSpec Digest) : OracleComp OracleWorld Digest) ∅ initialHistory + let result ← gameRestWithView adversary accountingKey ⟨rootResult.1.1, parameter⟩ + ⟨parameter, rootResult.1.1, otsSecret, ftsSecret⟩ rootResult.1.2 rootResult.2 + pure ((rootResult.1.1, result.1.1, result.1.2), result.2) + +theorem gameAfterSecretsWithView_projection (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + (fun result => (result.1, result.2.1)) <$> + gameAfterSecretsWithView adversary parameter otsSecret ftsSecret = + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret := by + rw [gameAfterSecretsWithView, gameAfterSecretsWithViewTrace, + ← runMonitor_project (primitiveAccountingKey parameter otsSecret ftsSecret) + (liftM (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : + OracleComp HashSpec Digest) : OracleComp OracleWorld Digest) ∅ initialHistory] + simp only [map_bind, bind_map_left] + apply bind_congr + intro result + rw [← gameRestWithView_projection adversary + (primitiveAccountingKey parameter otsSecret ftsSecret) ⟨result.1.1, parameter⟩ + ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ result.1.2 result.2] + simp + +end SphincsSecurity.Concrete.SettledCollision diff --git a/formal/sphincs/SphincsSecurity/Proof/SettledPath.lean b/formal/sphincs/SphincsSecurity/Proof/SettledPath.lean new file mode 100644 index 00000000..7c7b3617 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SettledPath.lean @@ -0,0 +1,248 @@ +import SphincsSecurity.Proof.Cached + +/-! +# Settled authentication paths + +A settled tree root recursively settles every node, leaf and chain below it. These lemmas select +the positions used by one authentication path. +-/ + +namespace SphincsSecurity.Concrete + +open OracleSpec + +variable {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {cache : QueryCache HashSpec} + +private theorem settled_chain_step_of_succ (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (chainIdx : ChainIndex) (position : Nat) + (hposition : position + 1 < chainLength - 1) + (hsettled : Settled parameter otsSecret ftsSecret cache + (.chain lay tree leafIdx chainIdx ⟨position + 1, hposition⟩)) : + Settled parameter otsSecret ftsSecret cache + (.chain lay tree leafIdx chainIdx ⟨position, by omega⟩) := by + apply hsettled.children + rw [Position.mem_children_iff, Position.parentOf, dif_pos (by omega)] + +theorem settled_chain_of_settled_leaf (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) + (hleaf : Settled parameter otsSecret ftsSecret cache (.leaf lay tree leafIdx)) + (chainIdx : ChainIndex) (position : Nat) (hposition : position < chainLength - 1) : + Settled parameter otsSecret ftsSecret cache + (.chain lay tree leafIdx chainIdx ⟨position, hposition⟩) := by + have hlast : Settled parameter otsSecret ftsSecret cache + (.chain lay tree leafIdx chainIdx Position.lastChainStep) := by + apply hleaf.children + simp only [Position.children, List.mem_ofFn] + exact ⟨chainIdx, rfl⟩ + have hdown : ∀ offset (hoffset : offset ≤ chainLength - 2), + Settled parameter otsSecret ftsSecret cache + (.chain lay tree leafIdx chainIdx ⟨chainLength - 2 - offset, by omega⟩) := by + intro offset + induction offset with + | zero => + intro _ + simpa only [Nat.sub_zero, Position.lastChainStep] using hlast + | succ offset ih => + intro hoffset + have hprev : offset ≤ chainLength - 2 := by omega + have hpos : chainLength - 2 - (offset + 1) + 1 = chainLength - 2 - offset := by omega + have hlt : chainLength - 2 - (offset + 1) + 1 < chainLength - 1 := by omega + have := settled_chain_step_of_succ lay tree leafIdx chainIdx + (chainLength - 2 - (offset + 1)) hlt (by simpa only [hpos] using ih hprev) + exact this + have hoffset : chainLength - 2 - position ≤ chainLength - 2 := Nat.sub_le _ _ + convert hdown (chainLength - 2 - position) hoffset using 1 + all_goals simp only [Position.chain.injEq, Fin.ext_iff, true_and] + omega + +private theorem settled_tree_node_of_succ (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (level : Nat) (hlevel : level + 1 < maxLayerHeight) + (hsettled : Settled parameter otsSecret ftsSecret cache + (.node lay tree ⟨level + 1, hlevel⟩ + ⟨leafIdx.val / 2 ^ (level + 2), lt_of_le_of_lt (Nat.div_le_self _ _) leafIdx.isLt⟩)) : + Settled parameter otsSecret ftsSecret cache + (.node lay tree ⟨level, by omega⟩ + ⟨leafIdx.val / 2 ^ (level + 1), lt_of_le_of_lt (Nat.div_le_self _ _) leafIdx.isLt⟩) := by + apply hsettled.children + rw [Position.mem_children_iff, Position.parentOf, dif_pos (by omega)] + simp only [Option.some.injEq, Position.node.injEq, Fin.ext_iff, true_and] + rw [show level + 2 = (level + 1) + 1 by omega, div_pow_succ, div_pow_succ] + rw [← div_pow_succ] + +private theorem settled_leaf_of_settled_node_zero (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) + (hsettled : Settled parameter otsSecret ftsSecret cache + (.node lay tree ⟨0, by decide⟩ + ⟨leafIdx.val / 2, lt_of_le_of_lt (Nat.div_le_self _ _) leafIdx.isLt⟩)) : + Settled parameter otsSecret ftsSecret cache (.leaf lay tree leafIdx) := by + apply hsettled.children + rw [Position.mem_children_iff, Position.parentOf] + +theorem settled_tree_path_of_settled_root (lay : Layer) (tree : TreeIndex) + (leafIdx : LeafIndex) (hleafIdx : leafIdx.val < 2 ^ layerHeight lay) + (hroot : Settled parameter otsSecret ftsSecret cache + (.node lay tree ⟨layerHeight lay - 1, by + have hpos : 0 < layerHeight lay := by unfold layerHeight; split <;> norm_num [maxLayerHeight] + have hle := layerHeight_le lay + omega⟩ ⟨0, by positivity⟩)) : + Settled parameter otsSecret ftsSecret cache (.leaf lay tree leafIdx) + ∧ ∀ level (hlevel : level < layerHeight lay), + Settled parameter otsSecret ftsSecret cache + (.node lay tree ⟨level, lt_of_lt_of_le hlevel (layerHeight_le lay)⟩ + ⟨leafIdx.val / 2 ^ (level + 1), + lt_of_le_of_lt (Nat.div_le_self _ _) leafIdx.isLt⟩) := by + have hpos : 0 < layerHeight lay := by + unfold layerHeight + split <;> norm_num [maxLayerHeight] + have hheight := layerHeight_le lay + have hroot' : Settled parameter otsSecret ftsSecret cache + (.node lay tree ⟨layerHeight lay - 1, by omega⟩ + ⟨leafIdx.val / 2 ^ layerHeight lay, + lt_of_le_of_lt (Nat.div_le_self _ _) leafIdx.isLt⟩) := by + convert hroot using 1 + all_goals simp only [Position.node.injEq, Fin.ext_iff, true_and] + exact Nat.div_eq_of_lt hleafIdx + have hdown : ∀ offset (hoffset : offset ≤ layerHeight lay - 1), + Settled parameter otsSecret ftsSecret cache + (.node lay tree ⟨layerHeight lay - 1 - offset, by omega⟩ + ⟨leafIdx.val / 2 ^ (layerHeight lay - offset), + lt_of_le_of_lt (Nat.div_le_self _ _) leafIdx.isLt⟩) := by + intro offset + induction offset with + | zero => + intro _ + simpa only [Nat.sub_zero] using hroot' + | succ offset ih => + intro hoffset + have hprev : offset ≤ layerHeight lay - 1 := by omega + have hlevel : layerHeight lay - 1 - (offset + 1) + 1 < maxLayerHeight := by + have hle := layerHeight_le lay + omega + have hlevelEq : layerHeight lay - 1 - offset + = layerHeight lay - 1 - (offset + 1) + 1 := by omega + have := settled_tree_node_of_succ lay tree leafIdx + (layerHeight lay - 1 - (offset + 1)) hlevel (by + convert ih hprev using 1 + simp only [Position.node.injEq, Fin.ext_iff, true_and] + refine ⟨hlevelEq.symm, ?_⟩ + rw [show layerHeight lay - 1 - (offset + 1) + 2 + = layerHeight lay - offset by omega]) + convert this using 1 + simp only [Position.node.injEq, Fin.ext_iff, true_and] + rw [show layerHeight lay - 1 - (offset + 1) + 1 + = layerHeight lay - (offset + 1) by omega] + have hzero : Settled parameter otsSecret ftsSecret cache + (.node lay tree ⟨0, by decide⟩ + ⟨leafIdx.val / 2, lt_of_le_of_lt (Nat.div_le_self _ _) leafIdx.isLt⟩) := by + have := hdown (layerHeight lay - 1) (le_refl _) + convert this using 1 + simp only [Position.node.injEq, Fin.ext_iff, true_and] + refine ⟨by omega, ?_⟩ + rw [show layerHeight lay - (layerHeight lay - 1) = 1 by omega, pow_one] + refine ⟨settled_leaf_of_settled_node_zero lay tree leafIdx hzero, ?_⟩ + intro level hlevel + have hoffset : layerHeight lay - 1 - level ≤ layerHeight lay - 1 := Nat.sub_le _ _ + have := hdown (layerHeight lay - 1 - level) hoffset + convert this using 1 + simp only [Position.node.injEq, Fin.ext_iff, true_and] + refine ⟨by omega, ?_⟩ + rw [show layerHeight lay - (layerHeight lay - 1 - level) = level + 1 by omega] + +private theorem settled_fts_node_of_succ (index : Index) (tree : FtsTree) + (leafIdx : FtsLeaf) (level : Nat) (hlevel : level + 1 < ftsTreeHeight) + (hsettled : Settled parameter otsSecret ftsSecret cache + (.ftsNode index tree ⟨level + 1, hlevel⟩ + ⟨leafIdx.val / 2 ^ (level + 2), lt_of_le_of_lt (Nat.div_le_self _ _) leafIdx.isLt⟩)) : + Settled parameter otsSecret ftsSecret cache + (.ftsNode index tree ⟨level, by omega⟩ + ⟨leafIdx.val / 2 ^ (level + 1), lt_of_le_of_lt (Nat.div_le_self _ _) leafIdx.isLt⟩) := by + apply hsettled.children + rw [Position.mem_children_iff, Position.parentOf, dif_pos (by omega)] + simp only [Option.some.injEq, Position.ftsNode.injEq, Fin.ext_iff, true_and] + rw [show level + 2 = (level + 1) + 1 by omega, div_pow_succ, div_pow_succ] + rw [← div_pow_succ] + +private theorem settled_fts_leaf_of_settled_node_zero (index : Index) (tree : FtsTree) + (leafIdx : FtsLeaf) + (hsettled : Settled parameter otsSecret ftsSecret cache + (.ftsNode index tree ⟨0, by decide⟩ + ⟨leafIdx.val / 2, lt_of_le_of_lt (Nat.div_le_self _ _) leafIdx.isLt⟩)) : + Settled parameter otsSecret ftsSecret cache (.ftsLeaf index tree leafIdx) := by + apply hsettled.children + rw [Position.mem_children_iff, Position.parentOf] + +theorem settled_fts_path_of_settled_roots (index : Index) + (leaves : DigestTree → FtsLeaf) + (hroots : Settled parameter otsSecret ftsSecret cache (.ftsRoots index)) : + (∀ tree, Settled parameter otsSecret ftsSecret cache + (.ftsLeaf index tree (leaves (ftsIndexOf tree)))) + ∧ ∀ tree level (hlevel : level < ftsTreeHeight), + Settled parameter otsSecret ftsSecret cache + (.ftsNode index tree ⟨level, hlevel⟩ + ⟨(leaves (ftsIndexOf tree)).val / 2 ^ (level + 1), + lt_of_le_of_lt (Nat.div_le_self _ _) (leaves (ftsIndexOf tree)).isLt⟩) := by + have htreeRoot : ∀ tree, Settled parameter otsSecret ftsSecret cache + (.ftsNode index tree ⟨ftsTreeHeight - 1, by decide⟩ ⟨0, by positivity⟩) := by + intro tree + apply hroots.children + simp only [Position.children, List.mem_ofFn] + exact ⟨tree, rfl⟩ + have hdown : ∀ tree offset (hoffset : offset ≤ ftsTreeHeight - 1), + Settled parameter otsSecret ftsSecret cache + (.ftsNode index tree ⟨ftsTreeHeight - 1 - offset, by simp only [ftsTreeHeight]; omega⟩ + ⟨(leaves (ftsIndexOf tree)).val / 2 ^ (ftsTreeHeight - offset), + lt_of_le_of_lt (Nat.div_le_self _ _) (leaves (ftsIndexOf tree)).isLt⟩) := by + intro tree offset + induction offset with + | zero => + intro _ + have hleaf := (leaves (ftsIndexOf tree)).isLt + have hzero : (leaves (ftsIndexOf tree)).val / 2 ^ ftsTreeHeight = 0 := + Nat.div_eq_of_lt hleaf + convert htreeRoot tree using 1 + simp only [Nat.sub_zero, Position.ftsNode.injEq, Fin.ext_iff, true_and] + exact hzero + | succ offset ih => + intro hoffset + have hprev : offset ≤ ftsTreeHeight - 1 := by omega + have hlevel : ftsTreeHeight - 1 - (offset + 1) + 1 < ftsTreeHeight := by omega + have hprevious : Settled parameter otsSecret ftsSecret cache + (.ftsNode index tree ⟨ftsTreeHeight - 1 - (offset + 1) + 1, hlevel⟩ + ⟨(leaves (ftsIndexOf tree)).val / + 2 ^ (ftsTreeHeight - 1 - (offset + 1) + 2), + lt_of_le_of_lt (Nat.div_le_self _ _) (leaves (ftsIndexOf tree)).isLt⟩) := by + convert ih hprev using 1 + simp only [Position.ftsNode.injEq, Fin.ext_iff, true_and] + refine ⟨by omega, ?_⟩ + rw [show ftsTreeHeight - 1 - (offset + 1) + 2 + = ftsTreeHeight - offset by omega] + have hnext := settled_fts_node_of_succ index tree (leaves (ftsIndexOf tree)) + (ftsTreeHeight - 1 - (offset + 1)) hlevel hprevious + convert hnext using 1 + simp only [Position.ftsNode.injEq, Fin.ext_iff, true_and] + rw [show ftsTreeHeight - 1 - (offset + 1) + 1 + = ftsTreeHeight - (offset + 1) by omega] + have hzero : ∀ tree, Settled parameter otsSecret ftsSecret cache + (.ftsNode index tree ⟨0, by decide⟩ + ⟨(leaves (ftsIndexOf tree)).val / 2, + lt_of_le_of_lt (Nat.div_le_self _ _) (leaves (ftsIndexOf tree)).isLt⟩) := by + intro tree + have h := hdown tree (ftsTreeHeight - 1) (le_refl _) + convert h using 1 + simp only [Position.ftsNode.injEq, Fin.ext_iff, true_and] + refine ⟨by omega, ?_⟩ + rw [show ftsTreeHeight - (ftsTreeHeight - 1) = 1 by norm_num [ftsTreeHeight], pow_one] + refine ⟨fun tree => settled_fts_leaf_of_settled_node_zero index tree + (leaves (ftsIndexOf tree)) (hzero tree), ?_⟩ + intro tree level hlevel + have hoffset : ftsTreeHeight - 1 - level ≤ ftsTreeHeight - 1 := Nat.sub_le _ _ + have h := hdown tree (ftsTreeHeight - 1 - level) hoffset + convert h using 1 + simp only [Position.ftsNode.injEq, Fin.ext_iff, true_and] + refine ⟨by omega, ?_⟩ + rw [show ftsTreeHeight - (ftsTreeHeight - 1 - level) = level + 1 by omega] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/SignSupport.lean b/formal/sphincs/SphincsSecurity/Proof/SignSupport.lean new file mode 100644 index 00000000..dd5d881f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SignSupport.lean @@ -0,0 +1,702 @@ +import SphincsSecurity.Proof.SigningReplay + +/-! +# Successful signer executions + +A successful signer invocation exposes its chosen index and leaf vector, its honest few-time +opening, and one successful honest one-time signing computation at every layer. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +abbrev LayerPart := + Counter × (ChainIndex → Digest) × (Fin maxLayerHeight → Digest) + +theorem otsSignFrom_some (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) (secret : ChainIndex → Digest) + (message : Digest) (attempts counter : Nat) (resultCounter : Counter) + (values : ChainIndex → Digest) + (hsign : evalWithAnswerFn f + (otsSignFrom parameter lay tree leafIdx secret message attempts counter) + = some (resultCounter, values)) : + ∃ codeword : Encoding, + evalWithAnswerFn f (encode parameter lay tree leafIdx message resultCounter) + = some codeword + ∧ ∀ chainIdx, values chainIdx = + honestChain f parameter lay tree leafIdx chainIdx (secret chainIdx) + (codeword chainIdx).val := by + induction attempts generalizing counter with + | zero => simp [otsSignFrom] at hsign + | succ attempts ih => + rw [otsSignFrom, evalWithAnswerFn_bind] at hsign + cases hencode : evalWithAnswerFn f + (encode parameter lay tree leafIdx message (BitVec.ofNat counterBits counter)) with + | none => + simp only [hencode] at hsign + exact ih (counter + 1) hsign + | some codeword => + simp only [hencode, evalWithAnswerFn_bind, evalWithAnswerFn_sequenceFin, + evalWithAnswerFn_pure, Option.some.injEq, Prod.mk.injEq] at hsign + obtain ⟨hcounter, hvalues⟩ := hsign + subst resultCounter + refine ⟨codeword, hencode, ?_⟩ + intro chainIdx + rw [← congrFun hvalues chainIdx] + rfl + +def SuccessfulLayerRun (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (index : Index) (lay : Layer) (part : LayerPart) : Prop := + ∃ codeword : Encoding, + evalWithAnswerFn f + (encode secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f (layerMessage secretKey index lay)) part.1) + = some codeword + ∧ (∀ chainIdx, part.2.1 chainIdx = + honestChain f secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + chainIdx (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay) chainIdx) + (codeword chainIdx).val) + ∧ (∀ level, part.2.2 level = if level.val < layerHeight lay then + honestNode f secretKey.parameter lay (treeIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay)) level.val + (Nat.xor ((leafIndexAt index lay).val / 2 ^ level.val) 1) + else 0) + ∧ evalWithAnswerFn f + (otsSign secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay))) = some (part.1, part.2.1) + ∧ CachedRun cache f (layerMessage secretKey index lay) + ∧ CachedRun cache f + (otsSign secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay))) + ∧ CachedRun cache f + (treePath secretKey.parameter lay (treeIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay)) (leafIndexAt index lay)) + +theorem successfulLayerRun_of_eval (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (index : Index) (lay : Layer) (part : LayerPart) + (heval : evalWithAnswerFn f (signLayer secretKey index lay) = some part) + (hrun : CachedRun cache f (signLayer secretKey index lay)) : + SuccessfulLayerRun f cache secretKey index lay part := by + rw [signLayer, evalWithAnswerFn_bind] at heval + rw [evalWithAnswerFn_bind] at heval + rw [signLayer] at hrun + have hmessageRun : CachedRun cache f (layerMessage secretKey index lay) := hrun.bind_left + have hrestRun := hrun.bind_right + cases hots : evalWithAnswerFn f + (otsSign secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay))) with + | none => + simp only [hots, evalWithAnswerFn_pure] at heval + cases heval + | some signed => + obtain ⟨counter, values⟩ := signed + have hotsRun := hrestRun.bind_left + have hafterOts := hrestRun.bind_right + rw [hots] at hafterOts + have hpathRun := hafterOts.bind_left + simp only [hots, evalWithAnswerFn_bind, evalWithAnswerFn_pure, Option.some.injEq] at heval + have hcounter : counter = part.1 := congrArg Prod.fst heval + have hvalues : values = part.2.1 := congrArg (fun value => value.2.1) heval + have hpath : evalWithAnswerFn f + (treePath secretKey.parameter lay (treeIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay)) (leafIndexAt index lay)) + = part.2.2 := congrArg (fun value => value.2.2) heval + obtain ⟨codeword, hencode, hchains⟩ := otsSignFrom_some f secretKey.parameter lay + (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay)) encodingAttemptLimit 0 counter + values (by simpa only [otsSign] using hots) + refine ⟨codeword, ?_, ?_, ?_, ?_, hmessageRun, hotsRun, hpathRun⟩ + · rwa [← hcounter] + · intro chainIdx + rw [← hvalues] + exact hchains chainIdx + · intro level + rw [← hpath] + simp only [treePath, evalWithAnswerFn_sequenceFin] + split <;> rfl + · simpa only [hcounter, hvalues] using hots + +theorem traverseOption_eq_some_apply {alpha : Type} {n : Nat} + (family : Fin n → Option alpha) (values : Fin n → alpha) + (h : traverseOption family = some values) (index : Fin n) : + family index = some (values index) := by + induction n with + | zero => exact index.elim0 + | succ n ih => + cases hhead : family 0 with + | none => simp [traverseOption, hhead] at h + | some head => + cases htail : traverseOption (fun index : Fin n => family index.succ) with + | none => simp [traverseOption, hhead, htail] at h + | some tail => + have hvalues : Fin.cases head tail = values := by + simpa [traverseOption, hhead, htail] using h + cases index using Fin.cases with + | zero => + have := congrFun hvalues 0 + simpa [hhead] using congrArg some this + | succ index => + have hfamily := ih (fun index : Fin n => family index.succ) tail htail index + have hvalue := congrFun hvalues index.succ + rw [← hvalue] + exact hfamily + +def SuccessfulDigestRun (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (message : Message) (randomness : Randomness) (index : Index) + (leaves : DigestTree → FtsLeaf) : Prop := + randomness ∈ support sampleRandomness + ∧ evalWithAnswerFn f (signAttempt secretKey message randomness) = some (index, leaves) + ∧ CachedRun cache f (signAttempt secretKey message randomness) + +theorem SuccessfulDigestRun.extract {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {message : Message} {randomness : Randomness} {index : Index} + {leaves : DigestTree → FtsLeaf} + (hrun : SuccessfulDigestRun f cache secretKey message randomness index leaves) : + randomness ∈ support sampleRandomness + ∧ ∃ digest : MessageDigest, + evalWithAnswerFn f + (messageDigest secretKey.parameter secretKey.root message randomness) = digest + ∧ Admissible digest + ∧ index = digestIndex digest + ∧ leaves = digestLeaves digest + ∧ CachedRun cache f + (messageDigest secretKey.parameter secretKey.root message randomness) := by + refine ⟨hrun.1, ?_⟩ + have heval := hrun.2.1 + simp only [signAttempt, evalWithAnswerFn_bind] at heval + let digest := evalWithAnswerFn f + (messageDigest secretKey.parameter secretKey.root message randomness) + by_cases hadmissible : Admissible digest + · simp only [show Admissible (evalWithAnswerFn f + (messageDigest secretKey.parameter secretKey.root message randomness)) from hadmissible, + if_true, evalWithAnswerFn_pure] at heval + have hresult : (digestIndex digest, digestLeaves digest) = (index, leaves) := + Option.some.inj heval + have hfields := Prod.mk.inj hresult + refine ⟨digest, rfl, hadmissible, hfields.1.symm, hfields.2.symm, ?_⟩ + exact hrun.2.2.bind_left + · simp only [show ¬ Admissible (evalWithAnswerFn f + (messageDigest secretKey.parameter secretKey.root message randomness)) from hadmissible, + if_false, evalWithAnswerFn_pure] at heval + simp at heval + +theorem successfulDigestLoop_of_mem_support (f : QueryImpl HashSpec Id) + (secretKey : SecretKey) (message : Message) (attempts : Nat) (randomness : Randomness) + (index : Index) (leaves : DigestTree → FtsLeaf) + (beforeCache afterCache finalCache : QueryCache HashSpec) + (hmem : (some (randomness, index, leaves), afterCache) ∈ support + ((simulateQ (replayRomImpl f) (signDigestLoop attempts secretKey message)).run beforeCache)) + (hleFinal : afterCache ≤ finalCache) (hf : finalCache.AgreesWithFn f) : + SuccessfulDigestRun f finalCache secretKey message randomness index leaves := by + induction attempts generalizing beforeCache afterCache randomness index leaves with + | zero => + simp only [signDigestLoop, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff, Prod.mk.injEq] at hmem + cases hmem.1 + | succ attempts ih => + rw [signDigestLoop, simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hmem + obtain ⟨⟨sampledRandomness, sampleCache⟩, hsample, hrest⟩ := hmem + have hsample' : (sampledRandomness, sampleCache) ∈ support + ((simulateQ (unifFwdImpl HashSpec) sampleRandomness).run beforeCache) := by + simpa only [replayRomImpl, QueryImpl.simulateQ_add_liftM_left] using hsample + rw [unifFwdImpl.simulateQ_run, support_map] at hsample' + obtain ⟨sampledRandomness', hsampled, heq⟩ := hsample' + obtain ⟨rfl, rfl⟩ := heq + rw [simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hrest + obtain ⟨⟨attempt, attemptCache⟩, hattempt, hfinish⟩ := hrest + cases attempt with + | none => + exact ih (randomness := randomness) (index := index) (leaves := leaves) + (beforeCache := attemptCache) (afterCache := afterCache) hfinish hleFinal + | some selected => + obtain ⟨selectedIndex, selectedLeaves⟩ := selected + simp only [simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq, Option.some.injEq] at hfinish + obtain ⟨hresult, hcache⟩ := hfinish + obtain ⟨rfl, rfl, rfl⟩ := hresult + have hleAttempt : attemptCache ≤ finalCache := by + rw [← hcache] + exact hleFinal + have hattempt' : (some (index, leaves), attemptCache) ∈ support + ((simulateQ (replayHashImpl f) + (signAttempt secretKey message randomness)).run beforeCache) := by + simpa only [simulateQ_replayRom_liftM] using hattempt + have hfAttempt : attemptCache.AgreesWithFn f := + fun _ _ hcached => hf (hleAttempt hcached) + obtain ⟨_, heval, hcached⟩ := replayHash_of_mem_support f + (signAttempt secretKey message randomness) beforeCache (some (index, leaves)) + attemptCache hattempt' hfAttempt + exact ⟨hsampled, heval, hcached.mono hleAttempt⟩ + +def SuccessfulSignRun (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (message : Message) (signature : Signature) : Prop := + ∃ (index : Index) (leaves : DigestTree → FtsLeaf) (parts : Layer → LayerPart), + SuccessfulDigestRun f cache secretKey message signature.randomness index leaves + ∧ signature.ftsSecret = + (fun tree => secretKey.ftsSecret index tree (leaves (ftsIndexOf tree))) + ∧ signature.ftsPath = + evalWithAnswerFn f (ftsOpen secretKey.parameter index leaves (secretKey.ftsSecret index)) + ∧ signature.counter = (fun lay => (parts lay).1) + ∧ signature.chainValue = (fun lay => (parts lay).2.1) + ∧ signature.authPath = flattenPaths (fun lay => (parts lay).2.2) + ∧ CachedRun cache f + (ftsOpen secretKey.parameter index leaves (secretKey.ftsSecret index)) + ∧ (∀ lay, evalWithAnswerFn f (signLayer secretKey index lay) = some (parts lay)) + ∧ ∀ lay, CachedRun cache f (signLayer secretKey index lay) + +theorem successfulSignRun_of_mem_support (f : QueryImpl HashSpec Id) + (secretKey : SecretKey) (message : Message) (signature : Signature) + (beforeCache afterCache finalCache : QueryCache HashSpec) + (hmem : (some signature, afterCache) ∈ support + ((simulateQ (replayRomImpl f) (sign secretKey message)).run beforeCache)) + (hleFinal : afterCache ≤ finalCache) (hf : finalCache.AgreesWithFn f) : + SuccessfulSignRun f finalCache secretKey message signature := by + rw [sign_eq, simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hmem + obtain ⟨⟨loopResult, loopCache⟩, hloop, hrest⟩ := hmem + cases loopResult with + | none => + simp only [simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq] at hrest + cases hrest.1 + | some data => + obtain ⟨randomness, index, leaves⟩ := data + rw [simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hrest + obtain ⟨⟨ftsPath, ftsCache⟩, hfts, hlayersRest⟩ := hrest + rw [simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hlayersRest + obtain ⟨⟨layers, layersCache⟩, hlayers, hfinal⟩ := hlayersRest + cases hparts : traverseOption layers with + | none => + simp only [hparts, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff, Prod.mk.injEq] at hfinal + cases hfinal.1 + | some parts => + simp only [hparts, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff, Prod.mk.injEq, Option.some.injEq] at hfinal + obtain ⟨hsignature, hcache⟩ := hfinal + subst signature + subst afterCache + have hfts' : (ftsPath, ftsCache) ∈ support + ((simulateQ (replayHashImpl f) + (ftsOpen secretKey.parameter index leaves (secretKey.ftsSecret index))).run + loopCache) := by + simpa only [simulateQ_replayRom_liftM] using hfts + have hlayers' : (layers, layersCache) ∈ support + ((simulateQ (replayHashImpl f) + (sequenceFin (fun lay => signLayer secretKey index lay))).run ftsCache) := by + simpa only [simulateQ_replayRom_liftM] using hlayers + have hftsLe : ftsCache ≤ layersCache := + simulateQ_replayRom_cache_le f + (liftM (sequenceFin (fun lay => signLayer secretKey index lay)) : + OracleComp OracleWorld (Layer → + Option (Counter × (ChainIndex → Digest) × (Fin maxLayerHeight → Digest)))) + ftsCache _ hlayers + have hfLayers : layersCache.AgreesWithFn f := + fun _ _ hcached => hf (hleFinal hcached) + have hfFts : ftsCache.AgreesWithFn f := + fun _ _ hcached => hfLayers (hftsLe hcached) + obtain ⟨_, hftsEval, hftsCached⟩ := + replayHash_of_mem_support f + (ftsOpen secretKey.parameter index leaves (secretKey.ftsSecret index)) + loopCache ftsPath ftsCache hfts' hfFts + obtain ⟨_, hlayersEval, hlayersCached⟩ := + replayHash_of_mem_support f + (sequenceFin (fun lay => signLayer secretKey index lay)) + ftsCache layers layersCache hlayers' hfLayers + have hpartsAt : ∀ lay, layers lay = some (parts lay) := by + intro lay + exact traverseOption_eq_some_apply layers parts hparts lay + have hftsStartLe : loopCache ≤ ftsCache := + simulateQ_replayRom_cache_le f + (liftM (ftsOpen secretKey.parameter index leaves (secretKey.ftsSecret index)) : + OracleComp OracleWorld (FtsTree → Fin ftsTreeHeight → Digest)) + loopCache _ hfts + have hloopFinal : loopCache ≤ finalCache := hftsStartLe.trans (hftsLe.trans hleFinal) + have hdigest := successfulDigestLoop_of_mem_support f secretKey message + digestAttemptLimit randomness index leaves beforeCache loopCache finalCache hloop + hloopFinal hf + refine ⟨index, leaves, parts, hdigest, rfl, ?_, rfl, rfl, rfl, ?_, ?_, ?_⟩ + · rw [← hftsEval] + · exact (hftsCached.mono hftsLe).mono hleFinal + · intro lay + rw [← hpartsAt lay, ← hlayersEval] + exact (congrFun + (evalWithAnswerFn_sequenceFin f (fun lay => signLayer secretKey index lay)) lay).symm + · intro lay + exact (hlayersCached.sequenceFin_component + (fun lay => signLayer secretKey index lay) lay).mono hleFinal + +theorem successfulSignRun_of_signing_entry (f : QueryImpl HashSpec Id) + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (initialCache : QueryCache HashSpec) (value : alpha) (signingLog : QueryLog SigningSpec) + (adversaryCache finalCache : QueryCache HashSpec) + (hmem : ((value, signingLog), adversaryCache) ∈ support + ((simulateQ romImpl + ((simulateQ (forwardOracles + signingOracle scheme secretKey) + computation).run)).run initialCache)) + (hle : adversaryCache ≤ finalCache) (hf : finalCache.AgreesWithFn f) + (entry : (request : SignRequest) × SigningSpec.Range request) (signature : Signature) + (hresponse : entry.2 = some signature) (hentry : entry ∈ signingLog) : + SuccessfulSignRun f finalCache secretKey entry.1 signature := by + obtain ⟨beforeCache, afterCache, hsign, hafter⟩ := signing_entry_of_mem_support f + secretKey computation initialCache value signingLog adversaryCache finalCache hmem hle hf + entry hentry + have hsign' : (some signature, afterCache) ∈ support + ((simulateQ (replayRomImpl f) (scheme.sign secretKey entry.1)).run beforeCache) := by + rwa [← hresponse] + exact successfulSignRun_of_mem_support f secretKey entry.1 signature beforeCache afterCache + finalCache (by simpa only [scheme] using hsign') hafter hf + +theorem SuccessfulSignRun.layer {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {message : Message} {signature : Signature} + (hrun : SuccessfulSignRun f cache secretKey message signature) (lay : Layer) : + ∃ (index : Index) (parts : Layer → LayerPart), + signature.counter = (fun lay => (parts lay).1) + ∧ signature.chainValue = (fun lay => (parts lay).2.1) + ∧ signature.authPath = flattenPaths (fun lay => (parts lay).2.2) + ∧ SuccessfulLayerRun f cache secretKey index lay (parts lay) := by + obtain ⟨index, leaves, parts, _, _, _, hcounter, hvalues, hpath, _, heval, hcached⟩ := hrun + exact ⟨index, parts, hcounter, hvalues, hpath, + successfulLayerRun_of_eval f cache secretKey index lay (parts lay) (heval lay) (hcached lay)⟩ + +theorem SuccessfulSignRun.indexed {f : QueryImpl HashSpec Id} {cache : QueryCache HashSpec} + {secretKey : SecretKey} {message : Message} {signature : Signature} + (hrun : SuccessfulSignRun f cache secretKey message signature) : + ∃ (index : Index) (leaves : DigestTree → FtsLeaf) (parts : Layer → LayerPart), + SuccessfulDigestRun f cache secretKey message signature.randomness index leaves + ∧ signature.ftsSecret = + (fun tree => secretKey.ftsSecret index tree (leaves (ftsIndexOf tree))) + ∧ signature.ftsPath = evalWithAnswerFn f + (ftsOpen secretKey.parameter index leaves (secretKey.ftsSecret index)) + ∧ signature.counter = (fun lay => (parts lay).1) + ∧ signature.chainValue = (fun lay => (parts lay).2.1) + ∧ signature.authPath = flattenPaths (fun lay => (parts lay).2.2) + ∧ CachedRun cache f + (ftsOpen secretKey.parameter index leaves (secretKey.ftsSecret index)) + ∧ ∀ lay, SuccessfulLayerRun f cache secretKey index lay (parts lay) := by + obtain ⟨index, leaves, parts, hdigest, hsecret, hpath, hcounter, hvalues, hauth, hfts, heval, + hcached⟩ := hrun + exact ⟨index, leaves, parts, hdigest, hsecret, hpath, hcounter, hvalues, hauth, hfts, + fun lay => successfulLayerRun_of_eval f cache secretKey index lay (parts lay) + (heval lay) (hcached lay)⟩ + +theorem SuccessfulLayerRun.message_cached {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {index : Index} {lay : Layer} + {part : LayerPart} (hrun : SuccessfulLayerRun f cache secretKey index lay part) : + CachedRun cache f (layerMessage secretKey index lay) := by + obtain ⟨_, _, _, _, _, hmessage, _, _⟩ := hrun + exact hmessage + +theorem SuccessfulLayerRun.otsSign_eval_cached {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {index : Index} {lay : Layer} + {part : LayerPart} (hrun : SuccessfulLayerRun f cache secretKey index lay part) : + evalWithAnswerFn f + (otsSign secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay))) = some (part.1, part.2.1) + ∧ CachedRun cache f + (otsSign secretKey.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) + (secretKey.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) + (evalWithAnswerFn f (layerMessage secretKey index lay))) := by + obtain ⟨_, _, _, _, heval, _, hcached, _⟩ := hrun + exact ⟨heval, hcached⟩ + +theorem SuccessfulSignRun.honest_openings {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} (hrun : SuccessfulSignRun f cache secretKey message signature) : + ∃ index, ∀ lay, HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay + (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f (layerMessage secretKey index lay)) (signature.counter lay) + (signature.chainValue lay) (signaturePath signature lay) := by + obtain ⟨index, _, parts, _, _, _, hcounter, hvalues, hauth, _, hlayers⟩ := hrun.indexed + refine ⟨index, fun lay => ?_⟩ + obtain ⟨codeword, hencode, hchains, hpath, _, _, _, _⟩ := hlayers lay + refine ⟨codeword, ?_, ?_, ?_⟩ + · simpa only [congrFun hcounter lay] using hencode + · intro chainIdx + rw [congrFun hvalues lay] + exact hchains chainIdx + · intro level hlevel + let levelFin : Fin maxLayerHeight := + ⟨level, lt_of_lt_of_le hlevel (layerHeight_le lay)⟩ + rw [show level = levelFin.val from rfl] + rw [signaturePath_flattenPaths signature (fun lay => (parts lay).2.2) hauth lay levelFin + hlevel] + have hlevelFin : levelFin.val < layerHeight lay := hlevel + simpa only [if_pos hlevelFin] using hpath levelFin + +theorem SuccessfulSignRun.honest_layer_at {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} (hrun : SuccessfulSignRun f cache secretKey message signature) + (lay : Layer) : + ∃ index, + CachedRun cache f (layerMessage secretKey index lay) + ∧ HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay + (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f (layerMessage secretKey index lay)) (signature.counter lay) + (signature.chainValue lay) (signaturePath signature lay) := by + obtain ⟨index, _, parts, _, _, _, hcounter, hvalues, hauth, _, hlayers⟩ := hrun.indexed + obtain ⟨codeword, hencode, hchains, hpath, _, hmessage, _, _⟩ := hlayers lay + refine ⟨index, hmessage, codeword, ?_, ?_, ?_⟩ + · simpa only [congrFun hcounter lay] using hencode + · intro chainIdx + rw [congrFun hvalues lay] + exact hchains chainIdx + · intro level hlevel + let levelFin : Fin maxLayerHeight := + ⟨level, lt_of_lt_of_le hlevel (layerHeight_le lay)⟩ + rw [show level = levelFin.val from rfl] + rw [signaturePath_flattenPaths signature (fun lay => (parts lay).2.2) hauth lay levelFin + hlevel] + have hlevelFin : levelFin.val < layerHeight lay := hlevel + simpa only [if_pos hlevelFin] using hpath levelFin + +theorem SuccessfulSignRun.honest_layer_at_of_digest {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} (hrun : SuccessfulSignRun f cache secretKey message signature) + {index : Index} {leaves : DigestTree → FtsLeaf} + (hdigest : SuccessfulDigestRun f cache secretKey message signature.randomness index leaves) + (lay : Layer) : + CachedRun cache f (layerMessage secretKey index lay) + ∧ HonestLayerOpening f secretKey.parameter secretKey.otsSecret lay + (treeIndexAt index lay) (leafIndexAt index lay) + (evalWithAnswerFn f (layerMessage secretKey index lay)) (signature.counter lay) + (signature.chainValue lay) (signaturePath signature lay) := by + obtain ⟨runIndex, runLeaves, parts, hrunDigest, _, _, hcounter, hvalues, hauth, _, hlayers⟩ := + hrun.indexed + obtain ⟨_, digest, hrunEval, _, hrunIndex, _, _⟩ := hrunDigest.extract + obtain ⟨_, digest', hdigestEval, _, hdigestIndex, _, _⟩ := hdigest.extract + have hdigests : digest = digest' := by rw [← hrunEval, ← hdigestEval] + have hindex : runIndex = index := by rw [hrunIndex, hdigestIndex, hdigests] + obtain ⟨codeword, hencode, hchains, hpath, _, hmessage, _, _⟩ := hlayers lay + refine ⟨?_, codeword, ?_, ?_, ?_⟩ + · simpa only [hindex] using hmessage + · simpa only [hindex, congrFun hcounter lay] using hencode + · intro chainIdx + rw [congrFun hvalues lay] + simpa only [hindex] using hchains chainIdx + · intro level hlevel + let levelFin : Fin maxLayerHeight := + ⟨level, lt_of_lt_of_le hlevel (layerHeight_le lay)⟩ + rw [show level = levelFin.val from rfl] + rw [signaturePath_flattenPaths signature (fun lay => (parts lay).2.2) hauth lay levelFin + hlevel] + have hlevelFin : levelFin.val < layerHeight lay := hlevel + simpa only [hindex, if_pos hlevelFin] using hpath levelFin + +theorem SuccessfulSignRun.signature_part_of_digest {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} (hrun : SuccessfulSignRun f cache secretKey message signature) + {index : Index} {leaves : DigestTree → FtsLeaf} + (hdigest : SuccessfulDigestRun f cache secretKey message signature.randomness index leaves) + (lay : Layer) : + ∃ part : LayerPart, + evalWithAnswerFn f (signLayer secretKey index lay) = some part + ∧ signature.counter lay = part.1 + ∧ signature.chainValue lay = part.2.1 := by + obtain ⟨runIndex, _, parts, hrunDigest, _, _, hcounter, hvalues, _, _, heval, _⟩ := hrun + obtain ⟨_, digest, hrunEval, _, hrunIndex, _, _⟩ := hrunDigest.extract + obtain ⟨_, digest', hdigestEval, _, hdigestIndex, _, _⟩ := hdigest.extract + have hdigests : digest = digest' := by rw [← hrunEval, ← hdigestEval] + have hindex : runIndex = index := by rw [hrunIndex, hdigestIndex, hdigests] + refine ⟨parts lay, ?_, congrFun hcounter lay, congrFun hvalues lay⟩ + simpa only [hindex] using heval lay + +theorem SuccessfulSignRun.layerRun_of_digest {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} (hrun : SuccessfulSignRun f cache secretKey message signature) + {index : Index} {leaves : DigestTree → FtsLeaf} + (hdigest : SuccessfulDigestRun f cache secretKey message signature.randomness index leaves) + (lay : Layer) : + ∃ part : LayerPart, signature.counter lay = part.1 + ∧ signature.chainValue lay = part.2.1 + ∧ SuccessfulLayerRun f cache secretKey index lay part := by + obtain ⟨runIndex, _, parts, hrunDigest, _, _, hcounter, hvalues, _, _, hlayers⟩ := hrun.indexed + obtain ⟨_, digest, hrunEval, _, hrunIndex, _, _⟩ := hrunDigest.extract + obtain ⟨_, digest', hdigestEval, _, hdigestIndex, _, _⟩ := hdigest.extract + have hdigests : digest = digest' := by rw [← hrunEval, ← hdigestEval] + have hindex : runIndex = index := by rw [hrunIndex, hdigestIndex, hdigests] + refine ⟨parts lay, congrFun hcounter lay, congrFun hvalues lay, ?_⟩ + simpa only [hindex] using hlayers lay + +theorem SuccessfulSignRun.signLayer_cached_of_digest {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} (hrun : SuccessfulSignRun f cache secretKey message signature) + {index : Index} {leaves : DigestTree → FtsLeaf} + (hdigest : SuccessfulDigestRun f cache secretKey message signature.randomness index leaves) + (lay : Layer) : CachedRun cache f (signLayer secretKey index lay) := by + obtain ⟨runIndex, _, _, hrunDigest, _, _, _, _, _, _, _, hcached⟩ := hrun + obtain ⟨_, digest, hrunEval, _, hrunIndex, _, _⟩ := hrunDigest.extract + obtain ⟨_, digest', hdigestEval, _, hdigestIndex, _, _⟩ := hdigest.extract + have hdigests : digest = digest' := by rw [← hrunEval, ← hdigestEval] + have hindex : runIndex = index := by rw [hrunIndex, hdigestIndex, hdigests] + simpa only [hindex] using hcached lay + +theorem SuccessfulSignRun.honest_fts_opening {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} (hrun : SuccessfulSignRun f cache secretKey message signature) : + ∃ (index : Index) (leaves : DigestTree → FtsLeaf), + signature.ftsSecret = + (fun tree => secretKey.ftsSecret index tree (leaves (ftsIndexOf tree))) + ∧ signature.ftsPath = fun tree level => + honestFtsNode f secretKey.parameter index tree (secretKey.ftsSecret index tree) + level.val (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1) := by + obtain ⟨index, leaves, _, _, hsecret, hpath, _, _, _, _, _⟩ := hrun.indexed + refine ⟨index, leaves, hsecret, hpath.trans ?_⟩ + funext tree level + simp only [ftsOpen, evalWithAnswerFn_sequenceFin] + rfl + +def HonestFtsSignAt (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec) + (secretKey : SecretKey) (message : Message) (signature : Signature) (index : Index) + (leaves : DigestTree → FtsLeaf) : Prop := + SuccessfulDigestRun f cache secretKey message signature.randomness index leaves + ∧ signature.ftsSecret = + (fun tree => secretKey.ftsSecret index tree (leaves (ftsIndexOf tree))) + ∧ signature.ftsPath = fun tree level => + honestFtsNode f secretKey.parameter index tree (secretKey.ftsSecret index tree) + level.val (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1) + +theorem SuccessfulSignRun.honest_fts_at {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} (hrun : SuccessfulSignRun f cache secretKey message signature) : + ∃ index leaves, HonestFtsSignAt f cache secretKey message signature index leaves := by + obtain ⟨index, leaves, _, hdigest, hsecret, hpath, _, _, _, _, _⟩ := hrun.indexed + refine ⟨index, leaves, hdigest, hsecret, hpath.trans ?_⟩ + funext tree level + simp only [ftsOpen, evalWithAnswerFn_sequenceFin] + rfl + +theorem SuccessfulSignRun.middle_root_settled {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} (hf : cache.AgreesWithFn f) + (hrun : SuccessfulSignRun f cache secretKey message signature) : + ∃ index, Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (.node middleLayer (treeIndexAt index middleLayer) + ⟨layerHeight middleLayer - 1, by decide⟩ ⟨0, by positivity⟩) := by + obtain ⟨index, _, _, _, _, _, _, _, _, _, hlayer⟩ := hrun.indexed + have hcached := (hlayer topLayer).message_cached + rw [layerMessage_of_lt secretKey index topLayer (by decide)] at hcached + refine ⟨index, ?_⟩ + simpa only [show (⟨topLayer.val + 1, by decide⟩ : Layer) = middleLayer from rfl] using + settled_treeRoot_of_cachedRun (ftsSecret := secretKey.ftsSecret) hf middleLayer + (treeIndexAt index middleLayer) hcached + +theorem SuccessfulSignRun.bottom_root_settled {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} (hf : cache.AgreesWithFn f) + (hrun : SuccessfulSignRun f cache secretKey message signature) : + ∃ index, Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (.node bottomLayer (treeIndexAt index bottomLayer) + ⟨layerHeight bottomLayer - 1, by decide⟩ ⟨0, by positivity⟩) := by + obtain ⟨index, _, _, _, _, _, _, _, _, _, hlayer⟩ := hrun.indexed + have hcached := (hlayer middleLayer).message_cached + rw [layerMessage_of_lt secretKey index middleLayer (by decide)] at hcached + refine ⟨index, ?_⟩ + simpa only [show (⟨middleLayer.val + 1, by decide⟩ : Layer) = bottomLayer from rfl] using + settled_treeRoot_of_cachedRun (ftsSecret := secretKey.ftsSecret) hf bottomLayer + (treeIndexAt index bottomLayer) hcached + +theorem SuccessfulSignRun.fts_roots_settled {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} {message : Message} + {signature : Signature} (hf : cache.AgreesWithFn f) + (hrun : SuccessfulSignRun f cache secretKey message signature) : + ∃ index, Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + (.ftsRoots index) := by + obtain ⟨index, _, _, _, _, _, _, _, _, _, hlayer⟩ := hrun.indexed + have hcached := (hlayer bottomLayer).message_cached + rw [layerMessage_bottomLayer secretKey index] at hcached + exact ⟨index, settled_ftsRoots_of_cachedRun (otsSecret := secretKey.otsSecret) hf index hcached⟩ + +theorem index_eq_of_bottom_position_eq {left right : Index} + (htree : treeIndexAt left bottomLayer = treeIndexAt right bottomLayer) + (hleaf : leafIndexAt left bottomLayer = leafIndexAt right bottomLayer) : left = right := by + apply Fin.ext + have htreeVal := congrArg Fin.val htree + have hleafVal := congrArg Fin.val hleaf + have habove : heightAbove bottomLayer = 19 := by decide + have hheight : layerHeight bottomLayer = 7 := by decide + have hleftTree : (treeIndexAt left bottomLayer).val = left.val / 128 := by + rw [treeIndexAt_val, habove] + norm_num [totalHeight] + have hrightTree : (treeIndexAt right bottomLayer).val = right.val / 128 := by + rw [treeIndexAt_val, habove] + norm_num [totalHeight] + have hleftLeaf : (leafIndexAt left bottomLayer).val = left.val % 128 := by + rw [leafIndexAt_bottomLayer, hheight] + norm_num + have hrightLeaf : (leafIndexAt right bottomLayer).val = right.val % 128 := by + rw [leafIndexAt_bottomLayer, hheight] + norm_num + rw [hleftTree, hrightTree] at htreeVal + rw [hleftLeaf, hrightLeaf] at hleafVal + omega + +theorem layerMessage_eq_of_position_eq (secretKey : SecretKey) (left right : Index) + (lay : Layer) (htree : treeIndexAt left lay = treeIndexAt right lay) + (hleaf : leafIndexAt left lay = leafIndexAt right lay) : + layerMessage (m := OracleComp HashSpec) secretKey left lay = + layerMessage secretKey right lay := by + have hlayer : lay = topLayer ∨ lay = middleLayer ∨ lay = bottomLayer := by + fin_cases lay + · exact Or.inl (Fin.ext rfl) + · exact Or.inr (Or.inl (Fin.ext rfl)) + · exact Or.inr (Or.inr (Fin.ext rfl)) + rcases hlayer with rfl | rfl | rfl + · have hnext : treeIndexAt left middleLayer = treeIndexAt right middleLayer := by + apply Fin.ext + rw [layers_link_top left, layers_link_top right] + rw [congrArg Fin.val htree, congrArg Fin.val hleaf] + rw [layerMessage_of_lt secretKey left topLayer (by decide), + layerMessage_of_lt secretKey right topLayer (by decide)] + simp only [show (⟨topLayer.val + 1, by decide⟩ : Layer) = middleLayer from rfl, hnext] + · have hnext : treeIndexAt left bottomLayer = treeIndexAt right bottomLayer := by + apply Fin.ext + rw [layers_link_middle left, layers_link_middle right] + rw [congrArg Fin.val htree, congrArg Fin.val hleaf] + rw [layerMessage_of_lt secretKey left middleLayer (by decide), + layerMessage_of_lt secretKey right middleLayer (by decide)] + simp only [show (⟨middleLayer.val + 1, by decide⟩ : Layer) = bottomLayer from rfl, hnext] + · have hindex := index_eq_of_bottom_position_eq htree hleaf + subst right + rfl + +theorem signLayer_eq_of_position_eq (secretKey : SecretKey) (left right : Index) + (lay : Layer) (htree : treeIndexAt left lay = treeIndexAt right lay) + (hleaf : leafIndexAt left lay = leafIndexAt right lay) : + signLayer (m := OracleComp HashSpec) secretKey left lay = + signLayer secretKey right lay := by + simp only [signLayer] + rw [htree, hleaf, + layerMessage_eq_of_position_eq secretKey left right lay htree hleaf] + +theorem successfulSignRun_layer_ots_eq_of_position_eq {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {leftMessage rightMessage : Message} {leftSignature rightSignature : Signature} + (left : SuccessfulSignRun f cache secretKey leftMessage leftSignature) + (right : SuccessfulSignRun f cache secretKey rightMessage rightSignature) + {leftIndex rightIndex : Index} + {leftLeaves rightLeaves : DigestTree → FtsLeaf} + (leftDigest : SuccessfulDigestRun f cache secretKey leftMessage leftSignature.randomness + leftIndex leftLeaves) + (rightDigest : SuccessfulDigestRun f cache secretKey rightMessage rightSignature.randomness + rightIndex rightLeaves) + (lay : Layer) (htree : treeIndexAt leftIndex lay = treeIndexAt rightIndex lay) + (hleaf : leafIndexAt leftIndex lay = leafIndexAt rightIndex lay) : + leftSignature.counter lay = rightSignature.counter lay + ∧ leftSignature.chainValue lay = rightSignature.chainValue lay := by + obtain ⟨leftPart, hleftEval, hleftCounter, hleftValues⟩ := + left.signature_part_of_digest leftDigest lay + obtain ⟨rightPart, hrightEval, hrightCounter, hrightValues⟩ := + right.signature_part_of_digest rightDigest lay + have hpart : leftPart = rightPart := by + rw [signLayer_eq_of_position_eq secretKey leftIndex rightIndex lay htree hleaf] at hleftEval + exact Option.some.inj (hleftEval.symm.trans hrightEval) + subst rightPart + exact ⟨hleftCounter.trans hrightCounter.symm, hleftValues.trans hrightValues.symm⟩ + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/SignerDigestSource.lean b/formal/sphincs/SphincsSecurity/Proof/SignerDigestSource.lean new file mode 100644 index 00000000..52a8e985 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SignerDigestSource.lean @@ -0,0 +1,155 @@ +import SphincsSecurity.Proof.NoMessage +import SphincsSecurity.Proof.SignSupport + +/-! +# Message inputs inserted by a signer + +The signer's only message-domain hash calls are the attempts in its digest loop. Once one attempt is +admissible the rest of signing avoids that domain entirely. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +@[simp] theorem queriedInputs_signAttempt (f : QueryImpl HashSpec Id) + (secretKey : SecretKey) (message : Message) (randomness : Randomness) : + queriedInputs f (signAttempt secretKey message randomness) = + [tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)] := by + rw [signAttempt, queriedInputs_bind] + change queriedInputs f + (liftM (HashSpec.query (tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness))) >>= + fun answer => pure (truncateMessageDigest answer)) ++ _ = _ + rw [queriedInputs_query_bind, queriedInputs_pure] + split <;> simp + +theorem signAttempt_cache_other_none (secretKey : SecretKey) (message : Message) + (randomness : Randomness) (beforeCache afterCache : QueryCache HashSpec) + (attempt : Option (Index × (DigestTree → FtsLeaf))) + (hmem : (attempt, afterCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAttempt secretKey message randomness)).run beforeCache)) + (target : HashInput) (hbefore : beforeCache target = none) + (hne : target ≠ tweakableHashInput secretKey.parameter .message + (messageDigestPayload secretKey.root message randomness)) : + afterCache target = none := by + obtain ⟨f, hf⟩ := QueryCache.exists_agreesWithFn (spec := HashSpec) afterCache + apply cache_eq_none_of_not_mem_queriedInputs + (signAttempt secretKey message randomness) beforeCache attempt afterCache hmem f hf target hbefore + simp [hne] + +theorem signAfterDigest_cache_message_none (secretKey : SecretKey) + (randomness : Randomness) (index : Index) + (leaves : DigestTree → FtsLeaf) (beforeCache afterCache : QueryCache HashSpec) + (result : Option Signature) + (hmem : (result, afterCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest secretKey randomness index leaves)).run beforeCache)) + (payload : HashInput) (hbefore : beforeCache + (tweakableHashInput secretKey.parameter .message payload) = none) : + afterCache (tweakableHashInput secretKey.parameter .message payload) = none := by + obtain ⟨answerFn, hagree⟩ := QueryCache.exists_agreesWithFn (spec := HashSpec) afterCache + apply cache_eq_none_of_not_mem_queriedInputs + (signAfterDigest secretKey randomness index leaves) beforeCache result afterCache + hmem answerFn hagree _ hbefore + exact avoidsMessage_signAfterDigest answerFn secretKey randomness index leaves payload + +theorem signDigestLoop_message_source (attempts : Nat) (secretKey : SecretKey) + (message : Message) (beforeCache afterCache : QueryCache HashSpec) + (result : Option (Randomness × Index × (DigestTree → FtsLeaf))) + (hmem : (result, afterCache) ∈ support + ((simulateQ romImpl (signDigestLoop attempts secretKey message)).run beforeCache)) + (targetPayload : HashInput) + (hbefore : beforeCache + (tweakableHashInput secretKey.parameter .message targetPayload) = none) + (hafter : afterCache + (tweakableHashInput secretKey.parameter .message targetPayload) ≠ none) : + ∃ (attemptIndex : Nat) (randomness : Randomness), + attemptIndex < attempts + ∧ randomness ∈ support sampleRandomness + ∧ targetPayload = messageDigestPayload secretKey.root message randomness := by + induction attempts generalizing beforeCache afterCache result with + | zero => + simp only [signDigestLoop, simulateQ_pure, StateT.run_pure, support_pure, + Set.mem_singleton_iff, Prod.mk.injEq] at hmem + obtain ⟨rfl, rfl⟩ := hmem + exact (hafter hbefore).elim + | succ attempts ih => + rw [signDigestLoop, simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hmem + obtain ⟨⟨randomness, sampleCache⟩, hsample, hrest⟩ := hmem + have hsampleRun : (randomness, sampleCache) ∈ support + ((simulateQ (unifFwdImpl HashSpec) sampleRandomness).run beforeCache) := by + simpa only [romImpl, QueryImpl.simulateQ_add_liftM_left] using hsample + rw [unifFwdImpl.simulateQ_run, support_map] at hsampleRun + obtain ⟨sampledRandomness, hrandomness, heq⟩ := hsampleRun + obtain ⟨rfl, rfl⟩ := heq + rw [simulateQ_bind, StateT.run_bind, mem_support_bind_iff] at hrest + obtain ⟨⟨attempt, attemptCache⟩, hattempt, hfinish⟩ := hrest + have hattempt' : (attempt, attemptCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAttempt secretKey message randomness)).run beforeCache) := by + simpa only [simulateQ_romImpl_liftM] using hattempt + by_cases heqInput : targetPayload = + messageDigestPayload secretKey.root message randomness + · exact ⟨0, randomness, by omega, hrandomness, heqInput⟩ + have hattemptNone : attemptCache + (tweakableHashInput secretKey.parameter .message targetPayload) = none := by + apply signAttempt_cache_other_none secretKey message randomness beforeCache attemptCache + attempt hattempt' _ hbefore + intro hinput + have hpayload := (tweakableHashInput_injective secretKey.parameter (by trivial) + (by trivial) hinput).2 + exact heqInput hpayload + cases attempt with + | none => + obtain ⟨attemptIndex, sourceRandomness, hindex, hsampled, hpayload⟩ := + ih attemptCache afterCache result hfinish hattemptNone hafter + exact ⟨attemptIndex + 1, sourceRandomness, by omega, hsampled, hpayload⟩ + | some selected => + simp only [simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq] at hfinish + obtain ⟨rfl, rfl⟩ := hfinish + exact (hafter hattemptNone).elim + +theorem sign_message_source (secretKey : SecretKey) (message : Message) + (beforeCache afterCache : QueryCache HashSpec) (result : Option Signature) + (hmem : (result, afterCache) ∈ support + ((simulateQ romImpl (sign secretKey message)).run beforeCache)) + (targetPayload : HashInput) + (hbefore : beforeCache + (tweakableHashInput secretKey.parameter .message targetPayload) = none) + (hafter : afterCache + (tweakableHashInput secretKey.parameter .message targetPayload) ≠ none) : + ∃ (attemptIndex : Nat) (randomness : Randomness), + attemptIndex < digestAttemptLimit + ∧ randomness ∈ support sampleRandomness + ∧ targetPayload = messageDigestPayload secretKey.root message randomness := by + rw [sign_eq_digestLoop_afterDigest, simulateQ_bind, StateT.run_bind, + mem_support_bind_iff] at hmem + obtain ⟨⟨loopResult, loopCache⟩, hloop, hrest⟩ := hmem + by_cases hloopHit : loopCache + (tweakableHashInput secretKey.parameter .message targetPayload) ≠ none + · exact signDigestLoop_message_source digestAttemptLimit secretKey message + beforeCache loopCache loopResult hloop targetPayload hbefore hloopHit + have hloopNone : loopCache + (tweakableHashInput secretKey.parameter .message targetPayload) = none := + not_ne_iff.mp hloopHit + cases loopResult with + | none => + simp only [simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq] at hrest + obtain ⟨rfl, rfl⟩ := hrest + exact (hafter hloopNone).elim + | some data => + rcases data with ⟨randomness, index, leaves⟩ + have hrest' : (result, afterCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (signAfterDigest secretKey randomness index leaves)).run loopCache) := by + simpa only [simulateQ_romImpl_liftM] using hrest + have hnone := signAfterDigest_cache_message_none secretKey randomness index leaves + loopCache afterCache result hrest' targetPayload hloopNone + exact (hafter hnone).elim + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/SigningReplay.lean b/formal/sphincs/SphincsSecurity/Proof/SigningReplay.lean new file mode 100644 index 00000000..14048d06 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SigningReplay.lean @@ -0,0 +1,120 @@ +import SphincsSecurity.Proof.ReplayWorld + +/-! +# Replaying signing-log entries + +Every entry in the adversary's signing log comes with the cache interval in which that invocation +of the signer ran. Replaying fixes hash answers but leaves the signer's uniform choices sampled. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +noncomputable def replayMappedAdversaryImpl (f : QueryImpl HashSpec Id) + (secretKey : SecretKey) : + QueryImpl (OracleWorld + SigningSpec) + (WriterT (QueryLog SigningSpec) (StateT (QueryCache HashSpec) ProbComp)) := + (replayRomImpl f).writerTMapBase + (forwardOracles + signingOracle Concrete.scheme secretKey) + +theorem replayMappedAdversary_cache_le (f : QueryImpl HashSpec Id) + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (initialCache : QueryCache HashSpec) + (result : (alpha × QueryLog SigningSpec) × QueryCache HashSpec) + (hmem : result ∈ support + (((simulateQ (replayMappedAdversaryImpl f secretKey) computation).run).run + initialCache)) : + initialCache ≤ result.2 := by + apply simulateQ_replayRom_cache_le f + ((simulateQ (forwardOracles + signingOracle Concrete.scheme secretKey) computation).run) + initialCache result + rw [QueryImpl.simulateQ_writerTMapBase_run] + exact hmem + +theorem replayMappedAdversary_signing_entry + (f : QueryImpl HashSpec Id) (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (initialCache : QueryCache HashSpec) + (result : (alpha × QueryLog SigningSpec) × QueryCache HashSpec) + (hmem : result ∈ support + (((simulateQ (replayMappedAdversaryImpl f secretKey) computation).run).run + initialCache)) : + ∀ entry ∈ result.1.2, ∃ beforeCache afterCache, + (entry.2, afterCache) ∈ support + ((simulateQ (replayRomImpl f) (Concrete.scheme.sign secretKey entry.1)).run beforeCache) + ∧ afterCache ≤ result.2 := by + induction computation using OracleComp.inductionOn generalizing initialCache result with + | pure value => + simp only [simulateQ_pure, WriterT.run_pure', StateT.run_pure, + support_pure, Set.mem_singleton_iff] at hmem + subst result + intro entry hentry + simp at hentry + | query_bind input next ih => + rw [simulateQ_bind, WriterT.run_bind', StateT.run_bind, mem_support_bind_iff] at hmem + obtain ⟨⟨⟨output, queryLog⟩, middleCache⟩, hquery, hrestMapped⟩ := hmem + rw [StateT.run_map, support_map] at hrestMapped + obtain ⟨⟨⟨value, restLog⟩, finalCache⟩, hrest, heq⟩ := hrestMapped + cases heq + intro entry hentry + change entry ∈ queryLog ++ restLog at hentry + rw [List.mem_append] at hentry + rcases hentry with hcurrent | hlater + · cases input with + | inl worldInput => + simp only [simulateQ_spec_query, replayMappedAdversaryImpl, + QueryImpl.writerTMapBase, QueryImpl.add_apply_inl, forwardOracles, + WriterT.run_mk] at hquery + erw [WriterT.run_liftM] at hquery + rw [simulateQ_map, StateT.run_map, support_map] at hquery + obtain ⟨⟨worldOutput, worldCache⟩, _, heq⟩ := hquery + cases heq + simp at hcurrent + | inr signingRequest => + simp only [simulateQ_spec_query, replayMappedAdversaryImpl, + QueryImpl.writerTMapBase, QueryImpl.add_apply_inr, signingOracle] at hquery + rw [WriterT.run_mk] at hquery + erw [QueryImpl.run_withLogging_apply] at hquery + erw [simulateQ_bind] at hquery + rw [StateT.run_bind, mem_support_bind_iff] at hquery + obtain ⟨⟨signOutput, signCache⟩, hsign, hpure⟩ := hquery + cases hpure + simp only [List.mem_singleton] at hcurrent + subst entry + have hsignFinal : signCache ≤ finalCache := + replayMappedAdversary_cache_le f secretKey (next signOutput) signCache + ((value, restLog), finalCache) hrest + exact ⟨initialCache, signCache, by simpa only [Concrete.scheme] using hsign, hsignFinal⟩ + · exact ih output middleCache ((value, restLog), finalCache) hrest entry hlater + +theorem signing_entry_of_mem_support (f : QueryImpl HashSpec Id) + (secretKey : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) alpha) + (initialCache : QueryCache HashSpec) (value : alpha) (signingLog : QueryLog SigningSpec) + (adversaryCache finalCache : QueryCache HashSpec) + (hmem : ((value, signingLog), adversaryCache) ∈ support + ((simulateQ romImpl + ((simulateQ (forwardOracles + signingOracle Concrete.scheme secretKey) + computation).run)).run initialCache)) + (hle : adversaryCache ≤ finalCache) (hf : finalCache.AgreesWithFn f) + (entry : (request : SignRequest) × SigningSpec.Range request) + (hentry : entry ∈ signingLog) : + ∃ beforeCache afterCache, + (entry.2, afterCache) ∈ support + ((simulateQ (replayRomImpl f) (Concrete.scheme.sign secretKey entry.1)).run beforeCache) + ∧ afterCache ≤ finalCache := by + have hfAdversary : adversaryCache.AgreesWithFn f := fun _ _ hcached => hf (hle hcached) + have hreplay := replayRom_of_mem_support + ((simulateQ (forwardOracles + signingOracle Concrete.scheme secretKey) computation).run) + initialCache (value, signingLog) adversaryCache hmem f hfAdversary + have hmapped : ((value, signingLog), adversaryCache) ∈ support + (((simulateQ (replayMappedAdversaryImpl f secretKey) computation).run).run + initialCache) := by + rw [replayMappedAdversaryImpl, ← QueryImpl.simulateQ_writerTMapBase_run] + exact hreplay + obtain ⟨beforeCache, afterCache, hsign, hafter⟩ := + replayMappedAdversary_signing_entry f secretKey computation initialCache + ((value, signingLog), adversaryCache) hmapped entry hentry + exact ⟨beforeCache, afterCache, hsign, hafter.trans hle⟩ + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/SigningTrace.lean b/formal/sphincs/SphincsSecurity/Proof/SigningTrace.lean new file mode 100644 index 00000000..2b0fea3b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/SigningTrace.lean @@ -0,0 +1,469 @@ +import SphincsSecurity.Proof.SignSupport + +/-! +# Signing cache intervals + +The ordinary signing log records only requests and responses. This trace additionally records the +random-oracle cache immediately before and after each signer invocation. Its projections recover +the ordinary logged adversary run exactly. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +structure SigningCacheEntry where + request : SignRequest + signature : Option Signature + initialCache : QueryCache HashSpec + finalCache : QueryCache HashSpec + +abbrev SigningCacheTrace := List SigningCacheEntry + +def SigningCacheTrace.toSigningLog (trace : SigningCacheTrace) : QueryLog SigningSpec := + trace.map fun entry => ⟨entry.request, entry.signature⟩ + +def SigningCacheTrace.CachesLe + (trace : SigningCacheTrace) (cache : QueryCache HashSpec) : Prop := + ∀ entry ∈ trace, entry.initialCache ≤ cache ∧ entry.finalCache ≤ cache + +def SigningCacheEntry.ValidRun (secretKey : SecretKey) (entry : SigningCacheEntry) : Prop := + (entry.signature, entry.finalCache) ∈ support + ((simulateQ romImpl (Concrete.scheme.sign secretKey entry.request)).run entry.initialCache) + +def SigningCacheTrace.ValidRuns (secretKey : SecretKey) (trace : SigningCacheTrace) : Prop := + ∀ entry ∈ trace, entry.ValidRun secretKey + +def SigningCacheTrace.Chronological : SigningCacheTrace → Prop + | [] => True + | entry :: rest => + (∀ later ∈ rest, entry.finalCache ≤ later.initialCache) ∧ + SigningCacheTrace.Chronological rest + +theorem SigningCacheTrace.Chronological.append_singleton + {trace : SigningCacheTrace} {entry : SigningCacheEntry} + (hchronological : trace.Chronological) + (hle : ∀ earlier ∈ trace, earlier.finalCache ≤ entry.initialCache) : + (trace ++ [entry]).Chronological := by + induction trace with + | nil => simp [SigningCacheTrace.Chronological] + | cons head rest ih => + rw [List.cons_append] + constructor + · intro later hlater + rw [List.mem_append] at hlater + rcases hlater with hlater | hlater + · exact hchronological.1 later hlater + · simp only [List.mem_singleton] at hlater + subst later + exact hle head (by simp) + · exact ih hchronological.2 (fun earlier hearlier => + hle earlier (List.mem_cons_of_mem head hearlier)) + +theorem SigningCacheTrace.Chronological.get_finalCache_le_initialCache + {trace : SigningCacheTrace} (hchronological : trace.Chronological) + (earlier later : Fin trace.length) (hlt : earlier.val < later.val) : + (trace.get earlier).finalCache ≤ (trace.get later).initialCache := by + induction trace with + | nil => exact Fin.elim0 earlier + | cons head rest ih => + obtain ⟨earlier, hearlier⟩ := earlier + obtain ⟨later, hlater⟩ := later + cases earlier with + | zero => + cases later with + | zero => simp at hlt + | succ later => + apply hchronological.1 + exact List.get_mem rest ⟨later, by simpa using hlater⟩ + | succ earlier => + cases later with + | zero => simp at hlt + | succ later => + have hlt' : earlier < later := by + change Nat.succ earlier < Nat.succ later at hlt + exact Nat.lt_of_succ_lt_succ hlt + exact ih hchronological.2 + ⟨earlier, by simpa using hearlier⟩ ⟨later, by simpa using hlater⟩ hlt' + +theorem SigningCacheEntry.successfulSignRun {f : QueryImpl HashSpec Id} + {secretKey : SecretKey} {entry : SigningCacheEntry} {signature : Signature} + {finalCache : QueryCache HashSpec} (hvalid : entry.ValidRun secretKey) + (hresponse : entry.signature = some signature) (hle : entry.finalCache ≤ finalCache) + (hf : finalCache.AgreesWithFn f) : + Concrete.SuccessfulSignRun f finalCache secretKey entry.request signature := by + have hentryAgree : entry.finalCache.AgreesWithFn f := fun _ _ hcached => hf (hle hcached) + have hreplay := replayRom_of_mem_support + (Concrete.scheme.sign secretKey entry.request) entry.initialCache entry.signature + entry.finalCache hvalid f hentryAgree + rw [hresponse] at hreplay + exact Concrete.successfulSignRun_of_mem_support f secretKey entry.request signature + entry.initialCache entry.finalCache finalCache hreplay hle hf + +theorem SigningCacheTrace.CachesLe.mono + {trace : SigningCacheTrace} {initialCache finalCache : QueryCache HashSpec} + (htrace : trace.CachesLe initialCache) (hle : initialCache ≤ finalCache) : + trace.CachesLe finalCache := by + intro entry hentry + exact ⟨(htrace entry hentry).1.trans hle, (htrace entry hentry).2.trans hle⟩ + +def signingLogFragment + (input : (OracleWorld + SigningSpec).Domain) + (output : (OracleWorld + SigningSpec).Range input) : QueryLog SigningSpec := + match input with + | .inl _ => [] + | .inr request => [⟨request, output⟩] + +def signingCacheTraceUpdate + (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (finalCache : QueryCache HashSpec) + (trace : SigningCacheTrace) : SigningCacheTrace := + match input with + | .inl _ => trace + | .inr request => trace ++ [⟨request, output, initialCache, finalCache⟩] + +def signingLogUpdate + (input : (OracleWorld + SigningSpec).Domain) + (_initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (_finalCache : QueryCache HashSpec) + (log : QueryLog SigningSpec) : QueryLog SigningSpec := + log ++ signingLogFragment input output + +theorem signingCacheTraceUpdate_toSigningLog + (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (output : (OracleWorld + SigningSpec).Range input) + (finalCache : QueryCache HashSpec) (trace : SigningCacheTrace) : + (signingCacheTraceUpdate input initialCache output finalCache trace).toSigningLog = + signingLogUpdate input initialCache output finalCache trace.toSigningLog := by + cases input <;> simp [signingCacheTraceUpdate, signingLogUpdate, + signingLogFragment, SigningCacheTrace.toSigningLog] + +noncomputable def mappedAdversaryImpl (secretKey : SecretKey) : + QueryImpl (OracleWorld + SigningSpec) + (WriterT (QueryLog SigningSpec) (StateT (QueryCache HashSpec) ProbComp)) := + romImpl.writerTMapBase (forwardOracles + signingOracle Concrete.scheme secretKey) + +noncomputable def unloggedMappedAdversaryImpl (secretKey : SecretKey) : + QueryImpl (OracleWorld + SigningSpec) (StateT (QueryCache HashSpec) ProbComp) := by + intro input + cases input with + | inl worldInput => exact romImpl worldInput + | inr request => exact simulateQ romImpl (Concrete.scheme.sign secretKey request) + +noncomputable def cacheTracedMappedAdversaryImpl (secretKey : SecretKey) : + QueryImpl (OracleWorld + SigningSpec) + (StateT (QueryCache HashSpec × SigningCacheTrace) ProbComp) := + QueryImpl.extendState (unloggedMappedAdversaryImpl secretKey) signingCacheTraceUpdate + +theorem unloggedMappedAdversaryImpl_cache_le + (secretKey : SecretKey) (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) + (result : (OracleWorld + SigningSpec).Range input × QueryCache HashSpec) + (hmem : result ∈ support + ((unloggedMappedAdversaryImpl secretKey input).run initialCache)) : + initialCache ≤ result.2 := by + cases input with + | inl worldInput => + cases worldInput with + | inl uniformInput => + have hrun : + (unifFwdImpl HashSpec uniformInput).run initialCache = + (fun sample => (sample, initialCache)) <$> + (liftM (unifSpec.query uniformInput) : ProbComp _) := by + simpa [simulateQ_query] using + (unifFwdImpl.simulateQ_run + (hashSpec := HashSpec) + (liftM (unifSpec.query uniformInput) : ProbComp _) initialCache) + change result ∈ support + ((unifFwdImpl HashSpec uniformInput).run initialCache) at hmem + rw [hrun, support_map] at hmem + obtain ⟨sample, _, heq⟩ := hmem + exact le_of_eq (congrArg Prod.snd heq) + | inr hashInput => + change result ∈ support + ((randomOracle (spec := HashSpec) hashInput).run initialCache) at hmem + exact QueryImpl.withCaching_cache_le uniformSampleImpl hashInput initialCache result hmem + | inr request => + change result ∈ support + ((simulateQ romImpl (Concrete.scheme.sign secretKey request)).run initialCache) at hmem + exact simulateQ_romImpl_cache_le (Concrete.scheme.sign secretKey request) + initialCache result hmem + +theorem cacheTracedMappedAdversaryImpl_query_cachesLe + (secretKey : SecretKey) (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) (initialTrace : SigningCacheTrace) + (result : (OracleWorld + SigningSpec).Range input × + (QueryCache HashSpec × SigningCacheTrace)) + (htrace : initialTrace.CachesLe initialCache) + (hmem : result ∈ support + ((cacheTracedMappedAdversaryImpl secretKey input).run + (initialCache, initialTrace))) : + result.2.2.CachesLe result.2.1 := by + rw [cacheTracedMappedAdversaryImpl, QueryImpl.extendState_apply, + mem_support_bind_iff] at hmem + obtain ⟨⟨output, finalCache⟩, hbase, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + have hle := unloggedMappedAdversaryImpl_cache_le secretKey input initialCache + (output, finalCache) hbase + cases input with + | inl worldInput => simpa [signingCacheTraceUpdate] using htrace.mono hle + | inr request => + intro entry hentry + rw [signingCacheTraceUpdate, List.mem_append] at hentry + rcases hentry with hentry | hentry + · exact (htrace entry hentry).imp (fun h => h.trans hle) (fun h => h.trans hle) + · simp only [List.mem_singleton] at hentry + subst entry + exact ⟨hle, le_rfl⟩ + +theorem cacheTracedMappedAdversaryImpl_query_validRuns + (secretKey : SecretKey) (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) (initialTrace : SigningCacheTrace) + (result : (OracleWorld + SigningSpec).Range input × + (QueryCache HashSpec × SigningCacheTrace)) + (htrace : initialTrace.ValidRuns secretKey) + (hmem : result ∈ support + ((cacheTracedMappedAdversaryImpl secretKey input).run + (initialCache, initialTrace))) : + result.2.2.ValidRuns secretKey := by + rw [cacheTracedMappedAdversaryImpl, QueryImpl.extendState_apply, + mem_support_bind_iff] at hmem + obtain ⟨⟨output, finalCache⟩, hbase, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + cases input with + | inl worldInput => simpa [signingCacheTraceUpdate] using htrace + | inr request => + intro entry hentry + rw [signingCacheTraceUpdate, List.mem_append] at hentry + rcases hentry with hentry | hentry + · exact htrace entry hentry + · simp only [List.mem_singleton] at hentry + subst entry + exact hbase + +theorem cacheTracedMappedAdversaryImpl_query_chronological + (secretKey : SecretKey) (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) (initialTrace : SigningCacheTrace) + (result : (OracleWorld + SigningSpec).Range input × + (QueryCache HashSpec × SigningCacheTrace)) + (hcaches : initialTrace.CachesLe initialCache) + (hchronological : initialTrace.Chronological) + (hmem : result ∈ support + ((cacheTracedMappedAdversaryImpl secretKey input).run + (initialCache, initialTrace))) : + result.2.2.Chronological := by + rw [cacheTracedMappedAdversaryImpl, QueryImpl.extendState_apply, + mem_support_bind_iff] at hmem + obtain ⟨⟨output, finalCache⟩, _, hpure⟩ := hmem + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + cases input with + | inl worldInput => simpa [signingCacheTraceUpdate] using hchronological + | inr request => + apply hchronological.append_singleton + intro earlier hearlier + exact (hcaches earlier hearlier).2 + +theorem cacheTracedMappedAdversaryImpl_cachesLe + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (initialTrace : SigningCacheTrace) + (result : α × (QueryCache HashSpec × SigningCacheTrace)) + (htrace : initialTrace.CachesLe initialCache) + (hmem : result ∈ support + ((simulateQ (cacheTracedMappedAdversaryImpl secretKey) + computation).run (initialCache, initialTrace))) : + result.2.2.CachesLe result.2.1 := by + exact OracleComp.simulateQ_run_preservesInv + (cacheTracedMappedAdversaryImpl secretKey) + (fun state => state.2.CachesLe state.1) + (by + intro input state hstate queryResult hquery + exact cacheTracedMappedAdversaryImpl_query_cachesLe secretKey input state.1 state.2 + queryResult hstate hquery) + computation (initialCache, initialTrace) htrace result hmem + +theorem cacheTracedMappedAdversaryImpl_validRuns + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (initialTrace : SigningCacheTrace) + (result : α × (QueryCache HashSpec × SigningCacheTrace)) + (htrace : initialTrace.ValidRuns secretKey) + (hmem : result ∈ support + ((simulateQ (cacheTracedMappedAdversaryImpl secretKey) + computation).run (initialCache, initialTrace))) : + result.2.2.ValidRuns secretKey := by + exact OracleComp.simulateQ_run_preservesInv + (cacheTracedMappedAdversaryImpl secretKey) + (fun state => state.2.ValidRuns secretKey) + (by + intro input state hstate queryResult hquery + exact cacheTracedMappedAdversaryImpl_query_validRuns secretKey input state.1 state.2 + queryResult hstate hquery) + computation (initialCache, initialTrace) htrace result hmem + +theorem cacheTracedMappedAdversaryImpl_cachesLe_chronological + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (initialTrace : SigningCacheTrace) + (result : α × (QueryCache HashSpec × SigningCacheTrace)) + (hcaches : initialTrace.CachesLe initialCache) + (hchronological : initialTrace.Chronological) + (hmem : result ∈ support + ((simulateQ (cacheTracedMappedAdversaryImpl secretKey) + computation).run (initialCache, initialTrace))) : + result.2.2.CachesLe result.2.1 ∧ result.2.2.Chronological := by + exact OracleComp.simulateQ_run_preservesInv + (cacheTracedMappedAdversaryImpl secretKey) + (fun state => state.2.CachesLe state.1 ∧ state.2.Chronological) + (by + intro input state hstate queryResult hquery + exact ⟨cacheTracedMappedAdversaryImpl_query_cachesLe secretKey input state.1 state.2 + queryResult hstate.1 hquery, + cacheTracedMappedAdversaryImpl_query_chronological secretKey input state.1 state.2 + queryResult hstate.1 hstate.2 hquery⟩) + computation (initialCache, initialTrace) ⟨hcaches, hchronological⟩ result hmem + +noncomputable def selectivelyLoggedMappedAdversaryImpl (secretKey : SecretKey) : + QueryImpl (OracleWorld + SigningSpec) + (WriterT (QueryLog SigningSpec) (StateT (QueryCache HashSpec) ProbComp)) := + QueryImpl.withTraceAppend (unloggedMappedAdversaryImpl secretKey) signingLogFragment + +noncomputable def logTracedMappedAdversaryImpl (secretKey : SecretKey) : + QueryImpl (OracleWorld + SigningSpec) + (StateT (QueryCache HashSpec × QueryLog SigningSpec) ProbComp) := + QueryImpl.extendState (unloggedMappedAdversaryImpl secretKey) signingLogUpdate + +theorem selectivelyLoggedMappedAdversaryImpl_apply_inr + (secretKey : SecretKey) (request : SignRequest) : + selectivelyLoggedMappedAdversaryImpl secretKey (.inr request) = + QueryImpl.withLogging + (fun request => simulateQ romImpl (Concrete.scheme.sign secretKey request)) request := by + rfl + +theorem mappedAdversaryImpl_apply_inr (secretKey : SecretKey) (request : SignRequest) : + mappedAdversaryImpl secretKey (.inr request) = + QueryImpl.withLogging + (fun request => simulateQ romImpl (Concrete.scheme.sign secretKey request)) request := by + change WriterT.mk (simulateQ romImpl + ((QueryImpl.withLogging (spec := SigningSpec) + (fun request => Concrete.scheme.sign secretKey request) request).run)) = _ + apply WriterT.ext + rw [WriterT.run_mk, QueryImpl.run_withLogging_apply, + QueryImpl.run_withLogging_apply, simulateQ_bind] + simp + +theorem selectivelyLoggedMappedAdversaryImpl_eq_mapped (secretKey : SecretKey) : + selectivelyLoggedMappedAdversaryImpl secretKey = mappedAdversaryImpl secretKey := by + funext input + cases input with + | inl worldInput => + change (do + let output ← liftM (romImpl worldInput) + tell ([] : QueryLog SigningSpec) + pure output) = + WriterT.mk ((fun output => (output, ([] : QueryLog SigningSpec))) <$> + romImpl worldInput) + apply WriterT.ext + simp + | inr request => + rw [selectivelyLoggedMappedAdversaryImpl_apply_inr, + mappedAdversaryImpl_apply_inr] + +theorem cacheTracedMappedAdversaryImpl_cache_projection + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (initialTrace : SigningCacheTrace) : + Prod.map id Prod.fst <$> + (simulateQ (cacheTracedMappedAdversaryImpl secretKey) + computation).run (initialCache, initialTrace) = + (simulateQ (unloggedMappedAdversaryImpl secretKey) + computation).run initialCache := by + exact OracleComp.extendState_run_proj_eq + (unloggedMappedAdversaryImpl secretKey) signingCacheTraceUpdate + computation initialCache initialTrace + +theorem cacheTracedMappedAdversaryImpl_log_projection + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (initialTrace : SigningCacheTrace) : + Prod.map id (fun state => (state.1, state.2.toSigningLog)) <$> + (simulateQ (cacheTracedMappedAdversaryImpl secretKey) + computation).run (initialCache, initialTrace) = + (simulateQ (logTracedMappedAdversaryImpl secretKey) + computation).run (initialCache, initialTrace.toSigningLog) := by + apply OracleComp.map_run_simulateQ_eq_of_query_map_eq + (cacheTracedMappedAdversaryImpl secretKey) + (logTracedMappedAdversaryImpl secretKey) + (fun state => (state.1, state.2.toSigningLog)) + intro input state + rw [cacheTracedMappedAdversaryImpl, logTracedMappedAdversaryImpl, + QueryImpl.extendState_apply, QueryImpl.extendState_apply, map_bind] + apply bind_congr + intro result + simp only [map_pure] + simpa [Prod.map] using congrArg (fun log => (result.1, (result.2, log))) + (signingCacheTraceUpdate_toSigningLog input state.1 result.1 result.2 state.2) + +theorem selectivelyLoggedMappedAdversaryImpl_query_run_eq_logTraced + (secretKey : SecretKey) (input : (OracleWorld + SigningSpec).Domain) + (initialCache : QueryCache HashSpec) (initialLog : QueryLog SigningSpec) : + (fun result => + (result.1.1, (result.2, initialLog ++ result.1.2))) <$> + (((selectivelyLoggedMappedAdversaryImpl secretKey input).run).run initialCache) = + (logTracedMappedAdversaryImpl secretKey input).run (initialCache, initialLog) := by + rw [selectivelyLoggedMappedAdversaryImpl, QueryImpl.withTraceAppend_apply, + logTracedMappedAdversaryImpl, QueryImpl.extendState_apply] + simp only [WriterT.run_bind', WriterT.run_monadLift', WriterT.run_tell, + WriterT.run_pure', StateT.run_bind, StateT.run_pure, map_bind, + bind_map_left, pure_bind, map_pure, Prod.map, id_eq] + apply bind_congr + intro result + simp [signingLogUpdate] + +theorem selectivelyLoggedMappedAdversaryImpl_run_eq_logTraced + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) (initialLog : QueryLog SigningSpec) : + (fun result => + (result.1.1, (result.2, initialLog ++ result.1.2))) <$> + (((simulateQ (selectivelyLoggedMappedAdversaryImpl secretKey) + computation).run).run initialCache) = + (simulateQ (logTracedMappedAdversaryImpl secretKey) + computation).run (initialCache, initialLog) := by + induction computation using OracleComp.inductionOn generalizing initialCache initialLog with + | pure value => simp + | query_bind input next ih => + simp only [simulateQ_bind, simulateQ_query, OracleQuery.input_query, + OracleQuery.cont_query, WriterT.run_bind', StateT.run_bind, map_bind, id_map] + rw [← selectivelyLoggedMappedAdversaryImpl_query_run_eq_logTraced + secretKey input initialCache initialLog] + simp only [bind_map_left] + apply bind_congr + intro prefixResult + simpa [List.append_assoc] using + ih prefixResult.1.1 prefixResult.2 (initialLog ++ prefixResult.1.2) + +theorem cacheTracedMappedAdversaryImpl_log_projection_eq_mapped + (secretKey : SecretKey) + (computation : OracleComp (OracleWorld + SigningSpec) α) + (initialCache : QueryCache HashSpec) : + Prod.map id (fun state => (state.1, state.2.toSigningLog)) <$> + (simulateQ (cacheTracedMappedAdversaryImpl secretKey) + computation).run (initialCache, []) = + (fun result => (result.1.1, (result.2, result.1.2))) <$> + (((simulateQ (mappedAdversaryImpl secretKey) computation).run).run initialCache) := by + rw [cacheTracedMappedAdversaryImpl_log_projection] + simp only [SigningCacheTrace.toSigningLog, List.map_nil] + rw [← selectivelyLoggedMappedAdversaryImpl_run_eq_logTraced + secretKey computation initialCache []] + rw [selectivelyLoggedMappedAdversaryImpl_eq_mapped] + rfl + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/Slot.lean b/formal/sphincs/SphincsSecurity/Proof/Slot.lean new file mode 100644 index 00000000..719d5725 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Slot.lean @@ -0,0 +1,88 @@ +import SphincsSecurity.Proof.Honest + +/-! +# Reading a payload's blocks + +The accounting has to charge a query whose answer is what fixes an honest input one level up. What it +charges against is the block of the parent's payload that answer would have to land in, so it needs to +read a block out of an input: `slotDigest_flatMap` says the `k`-th block of a payload built from a +list of values is the `k`-th value. Nothing here is about the scheme, only about the fixed-width +encoding every payload of it uses. +-/ + +namespace SphincsSecurity + +open OracleComp + +/-- The digest a block of bytes encodes, and `0` if it encodes none. -/ +noncomputable def digestOfBytes (bs : HashInput) : Digest := + open Classical in + if h : ∃ value : Digest, Concrete.digestBytes value = bs then h.choose else 0 + +theorem digestOfBytes_digestBytes (value : Digest) : + digestOfBytes (Concrete.digestBytes value) = value := by + classical + have h : ∃ candidate : Digest, Concrete.digestBytes candidate = Concrete.digestBytes value := + ⟨value, rfl⟩ + rw [digestOfBytes, dif_pos h] + exact digestBytes_injective h.choose_spec + +/-- What follows the tweak and the parameter in a hash input. -/ +def payloadOf (input : HashInput) : HashInput := input.drop 32 + +theorem payloadOf_tweakableHashInput (parameter : PublicParameter) (domain : HashDomain) + (payload : HashInput) : payloadOf (tweakableHashInput parameter domain payload) = payload := by + have hlength : (tweakBytes domain ++ bytesLE 16 parameter).length = 32 := by + simp [tweakBytes_length, bytesLE_length] + simp only [payloadOf, tweakableHashInput] + rw [← hlength, List.drop_left] + +/-- The digest in a payload's `k`-th block. -/ +noncomputable def slotDigest (k : Nat) (input : HashInput) : Digest := + digestOfBytes (((payloadOf input).drop (16 * k)).take 16) + +theorem drop_flatMap_digestBytes (values : List Digest) (k : Nat) : + (values.flatMap Concrete.digestBytes).drop (16 * k) + = (values.drop k).flatMap Concrete.digestBytes := by + induction k generalizing values with + | zero => simp + | succ k ih => + cases values with + | nil => simp + | cons value values => + rw [List.flatMap_cons, List.drop_succ_cons, ← ih values, + show 16 * (k + 1) = (Concrete.digestBytes value).length + 16 * k by + rw [digestBytes_length]; ring, + List.drop_append, List.drop_eq_nil_of_le (by omega), List.nil_append, + Nat.add_sub_cancel_left] + +/-- **Reading a block.** The `k`-th block of a payload built from a list of values is the `k`-th +value. -/ +theorem slotDigest_flatMap (parameter : PublicParameter) (domain : HashDomain) + (values : List Digest) (k : Nat) (hk : k < values.length) : + slotDigest k (tweakableHashInput parameter domain + (values.flatMap Concrete.digestBytes)) = values[k] := by + rw [slotDigest, payloadOf_tweakableHashInput, drop_flatMap_digestBytes] + have hdrop : values.drop k = values[k] :: (values.drop (k + 1)) := + List.drop_eq_getElem_cons hk + rw [hdrop, List.flatMap_cons, ← digestBytes_length values[k], List.take_left, + digestOfBytes_digestBytes] + +/-- The slot occupied by a child in an honest input contains that child's honest value. -/ +theorem slotDigest_honestInput_child (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) {parent child : Position} + (hvalid : parent.Valid) (hmem : child ∈ parent.children) : + slotDigest (parent.children.idxOf child) + (honestInput f parameter otsSecret ftsSecret parent) + = honestValue f parameter otsSecret ftsSecret child := by + have hidx : parent.children.idxOf child < parent.children.length := + List.idxOf_lt_length_iff.mpr hmem + rw [honestInput, honestPayload_eq_slots f parameter otsSecret ftsSecret hvalid, + slots_eq_childValues_of_mem f parameter otsSecret ftsSecret hmem, + slotDigest_flatMap parameter parent.domain + (childValues f parameter otsSecret ftsSecret parent) (parent.children.idxOf child) + (by simpa [childValues] using hidx)] + simp [childValues, List.getElem_idxOf hidx] + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/StatementLemmas.lean b/formal/sphincs/SphincsSecurity/Proof/StatementLemmas.lean new file mode 100644 index 00000000..7c1ceba0 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/StatementLemmas.lean @@ -0,0 +1,154 @@ +import SphincsSecurity.Statement + +/-! +# Rewrite lemmas for the sealed definitions + +`Statement.lean` seals the two tree recursions against accidental unfolding, which also stops Lean +from generating their equational theorems. Unsealing them locally makes the equations hold by `rfl`, +so this module states them once as ordinary theorems and the rest of the development rewrites with +those instead of unfolding anything. +-/ + +namespace SphincsSecurity.Concrete + +attribute [local semireducible] treeNode ftsNode verify sign sampleRandomness + +noncomputable local instance : SampleableType Randomness := + SampleableType.ofFintype Randomness + +variable {m : Type → Type} [Monad m] [HasQuery HashSpec m] + +@[simp] +theorem treeNode_zero_eq (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) (nodeIdx : Nat) : + treeNode (m := m) parameter lay tree secret 0 nodeIdx + = (do + let endpoints ← oneTimePublicKey parameter lay tree (leafOfNat nodeIdx) + (secret (leafOfNat nodeIdx)) + leafHash parameter lay tree (leafOfNat nodeIdx) endpoints) := rfl + +theorem treeNode_succ_eq (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) (level nodeIdx : Nat) : + treeNode (m := m) parameter lay tree secret (level + 1) nodeIdx + = (do + let left ← treeNode parameter lay tree secret level (2 * nodeIdx) + let right ← treeNode parameter lay tree secret level (2 * nodeIdx + 1) + tweakableHash parameter (.node lay tree (level + 1) nodeIdx) (nodePayload left right)) := rfl + +@[simp] +theorem ftsNode_zero_eq (parameter : PublicParameter) (index : Index) (tree : FtsTree) + (secret : FtsLeaf → Digest) (nodeIdx : Nat) : + ftsNode (m := m) parameter index tree secret 0 nodeIdx + = ftsLeafHash parameter index tree (ftsLeafOfNat nodeIdx) (secret (ftsLeafOfNat nodeIdx)) := rfl + +theorem ftsNode_succ_eq (parameter : PublicParameter) (index : Index) (tree : FtsTree) + (secret : FtsLeaf → Digest) (level nodeIdx : Nat) : + ftsNode (m := m) parameter index tree secret (level + 1) nodeIdx + = (do + let left ← ftsNode parameter index tree secret level (2 * nodeIdx) + let right ← ftsNode parameter index tree secret level (2 * nodeIdx + 1) + tweakableHash parameter (.ftsNode index tree (level + 1) nodeIdx) + (nodePayload left right)) := rfl + +@[simp] +theorem treeFold_zero_eq (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leaf : LeafIndex) (path : Nat → Digest) (value : Digest) : + treeFold (m := m) parameter lay tree leaf path 0 value = pure value := rfl + +theorem treeFold_succ_eq (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (leaf : LeafIndex) (path : Nat → Digest) (levels : Nat) (value : Digest) : + treeFold (m := m) parameter lay tree leaf path (levels + 1) value + = (do + let current ← treeFold parameter lay tree leaf path levels value + if leaf.val.testBit levels then + tweakableHash parameter (.node lay tree (levels + 1) (leaf.val / 2 ^ (levels + 1))) + (nodePayload (path levels) current) + else + tweakableHash parameter (.node lay tree (levels + 1) (leaf.val / 2 ^ (levels + 1))) + (nodePayload current (path levels))) := rfl + +@[simp] +theorem ftsFold_zero_eq (parameter : PublicParameter) (index : Index) (tree : FtsTree) + (leaf : FtsLeaf) (path : Fin ftsTreeHeight → Digest) (value : Digest) : + ftsFold (m := m) parameter index tree leaf path 0 value = pure value := rfl + +theorem ftsFold_succ_eq (parameter : PublicParameter) (index : Index) (tree : FtsTree) + (leaf : FtsLeaf) (path : Fin ftsTreeHeight → Digest) (levels : Nat) (value : Digest) : + ftsFold (m := m) parameter index tree leaf path (levels + 1) value + = (do + let current ← ftsFold parameter index tree leaf path levels value + let sibling := if hlevel : levels < ftsTreeHeight then path ⟨levels, hlevel⟩ else 0 + if leaf.val.testBit levels then + tweakableHash parameter (.ftsNode index tree (levels + 1) (leaf.val / 2 ^ (levels + 1))) + (nodePayload sibling current) + else + tweakableHash parameter (.ftsNode index tree (levels + 1) (leaf.val / 2 ^ (levels + 1))) + (nodePayload current sibling)) := rfl + +@[simp] +theorem verifyLayers_zero_eq (parameter : PublicParameter) (index : Index) (signature : Signature) + (message : Digest) : + verifyLayers (m := m) parameter index signature 0 message = pure (some message) := rfl + +theorem verifyLayers_succ_eq (parameter : PublicParameter) (index : Index) (signature : Signature) + (remaining : Nat) (message : Digest) : + verifyLayers (m := m) parameter index signature (remaining + 1) message + = (if hlayer : remaining < numLayers then + (do + match ← otsLeaf parameter ⟨remaining, hlayer⟩ (treeIndexAt index ⟨remaining, hlayer⟩) + (leafIndexAt index ⟨remaining, hlayer⟩) message + (signature.counter ⟨remaining, hlayer⟩) + (signature.chainValue ⟨remaining, hlayer⟩) with + | none => pure none + | some value => do + let root ← treeFold parameter ⟨remaining, hlayer⟩ + (treeIndexAt index ⟨remaining, hlayer⟩) (leafIndexAt index ⟨remaining, hlayer⟩) + (signaturePath signature ⟨remaining, hlayer⟩) (layerHeight ⟨remaining, hlayer⟩) + value + verifyLayers parameter index signature remaining root) + else pure none) := rfl + +theorem verify_eq (publicKey : PublicKey) (message : Message) (signature : Signature) : + verify (m := m) publicKey message signature + = (do + let digest ← messageDigest publicKey.parameter publicKey.root message signature.randomness + if ¬ Admissible digest then + return false + else + let ftsPublicKey ← ftsRecover publicKey.parameter (digestIndex digest) + (digestLeaves digest) signature.ftsSecret signature.ftsPath + match ← verifyLayers publicKey.parameter (digestIndex digest) signature numLayers + ftsPublicKey with + | none => return false + | some root => return decide (root = publicKey.root)) := rfl + +theorem sign_eq (secretKey : SecretKey) (message : Message) : + sign secretKey message + = (do + match ← signDigestLoop digestAttemptLimit secretKey message with + | none => return none + | some (randomness, index, leaves) => do + let ftsPath ← liftM + (ftsOpen secretKey.parameter index leaves (secretKey.ftsSecret index) : + OracleComp HashSpec (FtsTree → Fin ftsTreeHeight → Digest)) + let layers ← liftM + (sequenceFin (fun lay => signLayer secretKey index lay) : + OracleComp HashSpec + (Layer → + Option (Counter × (ChainIndex → Digest) × (Fin maxLayerHeight → Digest)))) + match traverseOption layers with + | none => return none + | some parts => + return some + { randomness := randomness + ftsSecret := fun tree => + secretKey.ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (parts lay).2.1 + authPath := flattenPaths fun lay => (parts lay).2.2 }) := rfl + +theorem sampleRandomness_eq : + sampleRandomness = ($ᵗ Randomness : ProbComp Randomness) := rfl + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/Support.lean b/formal/sphincs/SphincsSecurity/Proof/Support.lean new file mode 100644 index 00000000..c808afc3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/Support.lean @@ -0,0 +1,311 @@ +import SphincsSecurity.Proof.Logged +import SphincsSecurity.Proof.Extract + +/-! +# From the run to an answer function + +The extraction lemmas are facts about `evalWithAnswerFn f`, and the game runs under the lazy oracle. +The bridge is VCVio's support characterization: a value comes out of the lazy oracle exactly when some +total answer function agreeing with the cache evaluates the computation to it. + +That characterization is stated for a computation over one spec, and the game's spec is +`unifSpec + HashSpec`. It applies anyway, because the part the extraction analyses is verification, +and verification samples nothing: it is an `OracleComp HashSpec Bool`, lifted into the sum. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +/-- The inputs queried on the execution path selected by an answer function. -/ +def queriedInputs {alpha : Type} (f : QueryImpl HashSpec Id) (oa : OracleComp HashSpec alpha) : + List HashInput := + ((simulateQ (f.withLogging) oa).run).2.map Sigma.fst + +@[simp] theorem queriedInputs_pure {alpha : Type} (f : QueryImpl HashSpec Id) (x : alpha) : + queriedInputs f (pure x) = [] := by + rfl + +@[simp] theorem queriedInputs_query_bind {alpha : Type} (f : QueryImpl HashSpec Id) + (input : HashInput) (next : HashOutput → OracleComp HashSpec alpha) : + queriedInputs f (liftM (HashSpec.query input) >>= next) + = input :: queriedInputs f (next (f input)) := by + rfl + +theorem queriedInputs_bind {alpha beta : Type} (f : QueryImpl HashSpec Id) + (oa : OracleComp HashSpec alpha) (next : alpha → OracleComp HashSpec beta) : + queriedInputs f (oa >>= next) + = queriedInputs f oa ++ queriedInputs f (next (evalWithAnswerFn f oa)) := by + induction oa using OracleComp.inductionOn with + | pure x => simp + | query_bind input rest ih => + rw [bind_assoc, queriedInputs_query_bind, queriedInputs_query_bind, ih, + evalWithAnswerFn_bind, + show evalWithAnswerFn f (liftM (HashSpec.query input)) = f input from + simulateQ_spec_query f input, List.cons_append] + +theorem queriedInputs_mono_bind_left {alpha beta : Type} (f : QueryImpl HashSpec Id) + (oa : OracleComp HashSpec alpha) (next : alpha → OracleComp HashSpec beta) + {input : HashInput} (hinput : input ∈ queriedInputs f oa) : + input ∈ queriedInputs f (oa >>= next) := by + rw [queriedInputs_bind] + exact List.mem_append_left _ hinput + +theorem queriedInputs_mono_bind_right {alpha beta : Type} (f : QueryImpl HashSpec Id) + (oa : OracleComp HashSpec alpha) (next : alpha → OracleComp HashSpec beta) + {input : HashInput} (hinput : input ∈ queriedInputs f (next (evalWithAnswerFn f oa))) : + input ∈ queriedInputs f (oa >>= next) := by + rw [queriedInputs_bind] + exact List.mem_append_right _ hinput + +@[simp] theorem queriedInputs_tweakableHash (f : QueryImpl HashSpec Id) + (parameter : PublicParameter) (domain : HashDomain) (payload : HashInput) : + queriedInputs f (Concrete.tweakableHash parameter domain payload) + = [tweakableHashInput parameter domain payload] := by + change queriedInputs f + (liftM (HashSpec.query (tweakableHashInput parameter domain payload)) >>= + fun answer => pure (truncateHash answer)) = _ + rw [queriedInputs_query_bind, queriedInputs_pure] + +/-- Every answer function agreeing with a run's final cache replays that run, and all inputs on the +replay path occur in the cache. -/ +theorem replay_of_mem_support {alpha : Type} (oa : OracleComp HashSpec alpha) + (cache : QueryCache HashSpec) (a : alpha) (cache' : QueryCache HashSpec) + (hmem : (a, cache') ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) oa).run cache)) + (f : QueryImpl HashSpec Id) (hf : cache'.AgreesWithFn f) : + cache ≤ cache' ∧ evalWithAnswerFn f oa = a + ∧ ∀ input, input ∈ queriedInputs f oa → cache' input ≠ none := by + classical + induction oa using OracleComp.inductionOn generalizing cache a cache' with + | pure x => + simp only [simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq] at hmem + obtain ⟨rfl, rfl⟩ := hmem + refine ⟨le_rfl, rfl, ?_⟩ + simp + | query_bind input next ih => + simp only [simulateQ_query_bind, StateT.run_bind, mem_support_bind_iff] at hmem + obtain ⟨⟨answer, cacheMid⟩, hquery, hrest⟩ := hmem + change (answer, cacheMid) ∈ support ((randomOracle input).run cache) at hquery + have hcached : cacheMid input = some answer := by + cases hcache : cache input with + | some old => + rw [QueryImpl.withCaching_run_some uniformSampleImpl hcache, support_pure, + Set.mem_singleton_iff] at hquery + obtain ⟨rfl, rfl⟩ := hquery + exact hcache + | none => + rw [QueryImpl.withCaching_run_none uniformSampleImpl hcache, support_map] at hquery + obtain ⟨sample, _, heq⟩ := hquery + obtain ⟨rfl, rfl⟩ := heq + exact QueryCache.cacheQuery_self cache input answer + obtain ⟨hle, heval, hqueries⟩ := ih answer cacheMid a cache' hrest hf + have hcached' : cache' input = some answer := hle hcached + have hfinput : f input = answer := hf hcached' + refine ⟨(QueryImpl.withCaching_cache_le uniformSampleImpl input cache + (answer, cacheMid) hquery).trans hle, ?_, ?_⟩ + · rw [evalWithAnswerFn_bind, + show evalWithAnswerFn f (liftM (HashSpec.query input)) = f input from + simulateQ_spec_query f input, hfinput] + exact heval + · intro input₀ hqueried + rw [queriedInputs_query_bind, List.mem_cons, hfinput] at hqueried + rcases hqueried with rfl | hqueried + · simp [hcached'] + · exact hqueries input₀ hqueried + +theorem replay_of_mem_support_of_le {alpha : Type} (oa : OracleComp HashSpec alpha) + (cache : QueryCache HashSpec) (a : alpha) (cache' finalCache : QueryCache HashSpec) + (hmem : (a, cache') ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) oa).run cache)) + (hle : cache' ≤ finalCache) (f : QueryImpl HashSpec Id) (hf : finalCache.AgreesWithFn f) : + evalWithAnswerFn f oa = a + ∧ ∀ input, input ∈ queriedInputs f oa → finalCache input ≠ none := by + have hf' : cache'.AgreesWithFn f := fun _ _ hcached => hf (hle hcached) + obtain ⟨_, heval, hqueries⟩ := replay_of_mem_support oa cache a cache' hmem f hf' + refine ⟨heval, fun input hinput => ?_⟩ + obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp (hqueries input hinput) + rw [hle hanswer] + simp + +/-- A cache entry absent initially stays absent when its input does not occur on the replay path. -/ +theorem cache_eq_none_of_not_mem_queriedInputs {alpha : Type} + (oa : OracleComp HashSpec alpha) (cache : QueryCache HashSpec) + (a : alpha) (cache' : QueryCache HashSpec) + (hmem : (a, cache') ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) oa).run cache)) + (f : QueryImpl HashSpec Id) (hf : cache'.AgreesWithFn f) + (target : HashInput) (hnone : cache target = none) + (hnot : target ∉ queriedInputs f oa) : cache' target = none := by + classical + induction oa using OracleComp.inductionOn generalizing cache a cache' with + | pure x => + simp only [simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq] at hmem + obtain ⟨rfl, rfl⟩ := hmem + exact hnone + | query_bind input next ih => + simp only [simulateQ_query_bind, StateT.run_bind, mem_support_bind_iff] at hmem + obtain ⟨⟨answer, cacheMid⟩, hquery, hrest⟩ := hmem + change (answer, cacheMid) ∈ support ((randomOracle input).run cache) at hquery + have hcached : cacheMid input = some answer := by + cases hcache : cache input with + | some old => + rw [QueryImpl.withCaching_run_some uniformSampleImpl hcache, + support_pure, Set.mem_singleton_iff] at hquery + obtain ⟨rfl, rfl⟩ := hquery + exact hcache + | none => + rw [QueryImpl.withCaching_run_none uniformSampleImpl hcache, support_map] at hquery + obtain ⟨sample, _, heq⟩ := hquery + obtain ⟨rfl, rfl⟩ := heq + exact QueryCache.cacheQuery_self cache input answer + have hle : cacheMid ≤ cache' := + (replay_of_mem_support (next answer) cacheMid a cache' hrest f hf).1 + have hfinput : f input = answer := hf (hle hcached) + have htarget : target ≠ input := by + intro heq + apply hnot + rw [queriedInputs_query_bind] + exact List.mem_cons.2 (Or.inl heq) + have hmid : cacheMid target = none := by + cases hcache : cache input with + | some old => + rw [QueryImpl.withCaching_run_some uniformSampleImpl hcache, + support_pure, Set.mem_singleton_iff] at hquery + obtain ⟨rfl, rfl⟩ := hquery + exact hnone + | none => + rw [QueryImpl.withCaching_run_none uniformSampleImpl hcache, support_map] at hquery + obtain ⟨sample, _, heq⟩ := hquery + obtain ⟨rfl, rfl⟩ := heq + rwa [QueryCache.cacheQuery_of_ne _ _ htarget] + apply ih answer cacheMid a cache' hrest hf hmid + rw [queriedInputs_query_bind, List.mem_cons, hfinput] at hnot + intro htail + exact hnot (Or.inr htail) + +/-- A random-oracle run can be replayed by an answer function agreeing with its final cache, and +every query on that replay path is present there. -/ +theorem exists_answerFn_replay_of_mem_support {α : Type} (oa : OracleComp HashSpec α) + (cache : QueryCache HashSpec) (a : α) (cache' : QueryCache HashSpec) + (hmem : (a, cache') ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) oa).run cache)) : + cache ≤ cache' ∧ + ∃ f : QueryImpl HashSpec Id, cache'.AgreesWithFn f ∧ evalWithAnswerFn f oa = a + ∧ ∀ input, input ∈ queriedInputs f oa → cache' input ≠ none := by + classical + induction oa using OracleComp.inductionOn generalizing cache a cache' with + | pure x => + simp only [simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff, + Prod.mk.injEq] at hmem + obtain ⟨rfl, rfl⟩ := hmem + obtain ⟨f, hf⟩ := QueryCache.exists_agreesWithFn (spec := HashSpec) cache' + refine ⟨le_rfl, f, hf, rfl, ?_⟩ + intro input hqueried + simp at hqueried + | query_bind input next ih => + simp only [simulateQ_query_bind, StateT.run_bind, mem_support_bind_iff] at hmem + obtain ⟨⟨answer, cacheMid⟩, hquery, hrest⟩ := hmem + change (answer, cacheMid) ∈ support ((randomOracle input).run cache) at hquery + have hcached : cacheMid input = some answer := by + cases hcache : cache input with + | some old => + rw [QueryImpl.withCaching_run_some uniformSampleImpl hcache, support_pure, + Set.mem_singleton_iff] at hquery + obtain ⟨rfl, rfl⟩ := hquery + exact hcache + | none => + rw [QueryImpl.withCaching_run_none uniformSampleImpl hcache, support_map] at hquery + obtain ⟨sample, _, heq⟩ := hquery + obtain ⟨rfl, rfl⟩ := heq + exact QueryCache.cacheQuery_self cache input answer + obtain ⟨hle, f, hf, heval, hqueries⟩ := ih answer cacheMid a cache' hrest + have hcached' : cache' input = some answer := hle hcached + have hfinput : f input = answer := hf hcached' + refine ⟨(QueryImpl.withCaching_cache_le uniformSampleImpl input cache + (answer, cacheMid) hquery).trans hle, f, hf, ?_, ?_⟩ + rw [evalWithAnswerFn_bind, + show evalWithAnswerFn f (liftM (HashSpec.query input)) = f input from + simulateQ_spec_query f input, hfinput] + exact heval + intro input₀ hqueried + rw [queriedInputs_query_bind, List.mem_cons, hfinput] at hqueried + rcases hqueried with rfl | hqueried + · simp [hcached'] + · exact hqueries input₀ hqueried + +/-- A random-oracle run can be replayed by an answer function agreeing with its final cache. -/ +theorem exists_answerFn_agrees_final_of_mem_support {α : Type} (oa : OracleComp HashSpec α) + (cache : QueryCache HashSpec) (a : α) (cache' : QueryCache HashSpec) + (hmem : (a, cache') ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) oa).run cache)) : + cache ≤ cache' ∧ + ∃ f : QueryImpl HashSpec Id, cache'.AgreesWithFn f ∧ evalWithAnswerFn f oa = a := by + obtain ⟨hle, f, hf, heval, _⟩ := exists_answerFn_replay_of_mem_support oa cache a cache' hmem + exact ⟨hle, f, hf, heval⟩ + +/-- Simulating a lifted hash-only computation is simulating it under the random oracle. -/ +theorem simulateQ_romImpl_liftM {α : Type} (oa : OracleComp HashSpec α) : + simulateQ romImpl (liftM oa : OracleComp OracleWorld α) + = simulateQ (randomOracle : QueryImpl HashSpec _) oa := + QueryImpl.simulateQ_add_liftM_right _ _ oa + +/-- **The bridge.** If verification accepts in the run, some answer function agreeing with the cache +accepts too, and every extraction lemma applies to that function. -/ +theorem exists_answerFn_of_verify (publicKey : PublicKey) (message : Message) + (signature : Signature) (cache cache' : QueryCache HashSpec) + (hmem : (true, cache') + ∈ support ((simulateQ (randomOracle : QueryImpl HashSpec _) + (Concrete.verify publicKey message signature)).run cache)) : + ∃ f : QueryImpl HashSpec Id, cache.AgreesWithFn f + ∧ evalWithAnswerFn f (Concrete.verify publicKey message signature) = true := + (exists_agreesWithFn_evalWithAnswerFn_eq_iff_mem_support + (Concrete.verify publicKey message signature) cache true).mpr ⟨cache', hmem⟩ + +theorem exists_answerFn_agrees_final_of_verify (publicKey : PublicKey) (message : Message) + (signature : Signature) (cache cache' : QueryCache HashSpec) + (hmem : (true, cache') + ∈ support ((simulateQ (randomOracle : QueryImpl HashSpec _) + (Concrete.verify publicKey message signature)).run cache)) : + ∃ f : QueryImpl HashSpec Id, cache'.AgreesWithFn f + ∧ evalWithAnswerFn f (Concrete.verify publicKey message signature) = true := + (exists_answerFn_agrees_final_of_mem_support _ cache true cache' hmem).2 + +/-! ### One layer of the walk, unpeeled + +What the extraction consumes is the two facts of a single layer: that `Ots.leaf` returned something, +and that folding it reached what the layer above was handed. This peels them off `verifyLayers`. +-/ + +namespace Concrete + +open OracleComp + +theorem verifyLayers_succ_extract (f : QueryImpl HashSpec Id) (parameter : PublicParameter) + (index : Index) (signature : Signature) (remaining : Nat) (hlayer : remaining < numLayers) + (message : Digest) (target : Digest) + (hverify : evalWithAnswerFn f + (verifyLayers parameter index signature (remaining + 1) message) = some target) : + ∃ leafValue, evalWithAnswerFn f (otsLeaf parameter ⟨remaining, hlayer⟩ + (treeIndexAt index ⟨remaining, hlayer⟩) (leafIndexAt index ⟨remaining, hlayer⟩) message + (signature.counter ⟨remaining, hlayer⟩) (signature.chainValue ⟨remaining, hlayer⟩)) + = some leafValue + ∧ evalWithAnswerFn f (verifyLayers parameter index signature remaining + (foldValue f parameter ⟨remaining, hlayer⟩ (treeIndexAt index ⟨remaining, hlayer⟩) + (leafIndexAt index ⟨remaining, hlayer⟩) (signaturePath signature ⟨remaining, hlayer⟩) + leafValue (layerHeight ⟨remaining, hlayer⟩))) = some target := by + rcases hleaf : evalWithAnswerFn f (otsLeaf parameter ⟨remaining, hlayer⟩ + (treeIndexAt index ⟨remaining, hlayer⟩) (leafIndexAt index ⟨remaining, hlayer⟩) message + (signature.counter ⟨remaining, hlayer⟩) (signature.chainValue ⟨remaining, hlayer⟩)) + with _ | leafValue + · rw [verifyLayers_succ_eq, dif_pos hlayer, evalWithAnswerFn_bind, hleaf] at hverify + simp at hverify + · refine ⟨leafValue, rfl, ?_⟩ + rw [verifyLayers_succ_eq, dif_pos hlayer, evalWithAnswerFn_bind, hleaf] at hverify + simpa [foldValue, evalWithAnswerFn_bind] using hverify + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/TerminalArith.lean b/formal/sphincs/SphincsSecurity/Proof/TerminalArith.lean new file mode 100644 index 00000000..64acd55b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TerminalArith.lean @@ -0,0 +1,54 @@ +import SphincsSecurity.Proof.MandatoryQueries + +/-! +# Arithmetic budget for the terminal bounds + +The structural charge and the complete proper few-time term consume less than 24 of the 32 units +available at denominator `2^125`. The mandatory root computation supplies the lower bound on `q` +needed to absorb the few-time term's single final-verifier candidate. +-/ + +namespace SphincsSecurity.Concrete + +open ENNReal + +theorem structural_add_properFewTime_le {q : Nat} (hq : numChains ≤ q) : + ((44 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + ((2 * q + 1 : Nat) : ℝ≥0∞) * + (9 * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹) ≤ + ((24 * q : Nat) : ℝ≥0∞) * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹ := by + apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_natCast] + have hpow : (2 : ℝ) ^ digestBits = 8 * (2 : ℝ) ^ 125 := by + norm_num [digestBits] + push_cast + simp only [ENNReal.toReal_ofNat] + rw [hpow, mul_inv] + norm_num only [pow_succ, pow_zero] at ⊢ + calc + 44 * (q : ℝ) * (1 / 340282366920938463463374607431768211456) + + (2 * (q : ℝ) + 1) * (9 / 42535295865117307932921825928971026432) = + ((47 / 2 : ℝ) * q + 9) / + 42535295865117307932921825928971026432 := by + norm_num + ring + _ ≤ (24 * (q : ℝ)) / + 42535295865117307932921825928971026432 := by + gcongr + have h18Nat : 18 ≤ q := le_trans (by norm_num [numChains]) hq + have h18 : (18 : ℝ) ≤ (q : ℝ) := by exact_mod_cast h18Nat + linarith + _ = 24 * (q : ℝ) * + (1 / 42535295865117307932921825928971026432) := by ring + +theorem terminal_budget_remainder : + ((24 : Nat) : ℝ≥0∞) * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹ + + ((64 : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ = + ((2 ^ 120 : Nat) : ℝ≥0∞)⁻¹ := by + apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp + rw [ENNReal.toReal_add (by finiteness) (by finiteness)] + simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_natCast] + norm_num [digestBits] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/TerminalBudget.lean b/formal/sphincs/SphincsSecurity/Proof/TerminalBudget.lean new file mode 100644 index 00000000..89fa77a0 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TerminalBudget.lean @@ -0,0 +1,100 @@ +import SphincsSecurity.Proof.TerminalArith +import SphincsSecurity.Proof.TerminalView + +/-! +# Reserving the completed terminal budget + +The structural bad event and the complete proper few-time event fit in the first 24 units at +denominator `2^125`. This module packages that fact around the trace-aware decomposition, leaving +only the five unresolved clean terminal probabilities. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem probEvent_win_le_reserved_add_remaining + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + let run := gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + Pr[= true | (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run' ∅] ≤ + ((24 * q : Nat) : ℝ≥0∞) * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹ + + (Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ result.1.2.2 = true) ∧ + ViewedWinningFreshLayerOpeningWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ result.1.2.2 = true) ∧ + ViewedWinningBackwardChainOpeningWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result | run] + + Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result | run])))) := by + dsimp only + let run := gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + have hgameBound := isQueryBoundP_gameAfterSecrets adversary q hq hparameter hots hfts + have hqMin := numChains_le_of_hasHashQueryBound adversary q hq parameter hparameter otsSecret + hots ftsSecret hfts + have hbad := probEvent_bad_gameAfterSecretsWithViewTrace_le adversary parameter otsSecret + ftsSecret q hgameBound + have hproper := probEvent_clean_properFewTimeLeak_le_nine_mul_inv adversary q hq hqMax + parameter hparameter otsSecret hots ftsSecret hfts + calc + _ ≤ Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache | run] + + (Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ result.1.2.2 = true) ∧ + ViewedWinningFreshLayerOpeningWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ result.1.2.2 = true) ∧ + ViewedWinningBackwardChainOpeningWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result | run] + + Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result | run]))))) := + probEvent_win_le_viewed_bad_add_terminal_cases adversary parameter otsSecret ftsSecret + _ ≤ (((44 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) + + (Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ result.1.2.2 = true) ∧ + ViewedWinningFreshLayerOpeningWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ result.1.2.2 = true) ∧ + ViewedWinningBackwardChainOpeningWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result | run] + + (((2 * q + 1 : Nat) : ℝ≥0∞) * (9 * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹) + + Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result | run]))))) := by + gcongr + _ = ((((44 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) + + ((2 * q + 1 : Nat) : ℝ≥0∞) * (9 * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹)) + + (Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ result.1.2.2 = true) ∧ + ViewedWinningFreshLayerOpeningWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ result.1.2.2 = true) ∧ + ViewedWinningBackwardChainOpeningWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result | run] + + Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result | run])))) := by + ac_rfl + _ ≤ _ := by + gcongr + exact structural_add_properFewTime_le hqMin + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/TerminalCache.lean b/formal/sphincs/SphincsSecurity/Proof/TerminalCache.lean new file mode 100644 index 00000000..56df4acd --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TerminalCache.lean @@ -0,0 +1,98 @@ +import SphincsSecurity.Proof.OneTimeEvents + +/-! +# Cache witnesses for terminal events + +Terminal classifications retain the executions that produced their oracle values. This module turns +those executions into concrete cache events for the probability bounds. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +def EncodingCacheCollision (parameter : PublicParameter) (cache : QueryCache HashSpec) : Prop := + ∃ (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex) + (leftPayload rightPayload : HashInput) (leftAnswer rightAnswer : HashOutput), + leftPayload ≠ rightPayload + ∧ cache (tweakableHashInput parameter (.encoding lay tree leafIdx) leftPayload) + = some leftAnswer + ∧ cache (tweakableHashInput parameter (.encoding lay tree leafIdx) rightPayload) + = some rightAnswer + ∧ truncateHash leftAnswer = truncateHash rightAnswer + +def MessageCacheCollision (parameter : PublicParameter) (cache : QueryCache HashSpec) : Prop := + ∃ (leftPayload rightPayload : HashInput) (leftAnswer rightAnswer : HashOutput), + leftPayload ≠ rightPayload + ∧ cache (tweakableHashInput parameter .message leftPayload) = some leftAnswer + ∧ cache (tweakableHashInput parameter .message rightPayload) = some rightAnswer + ∧ truncateMessageDigest leftAnswer = truncateMessageDigest rightAnswer + +theorem encodingCollision_cacheCollision {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} (hf : cache.AgreesWithFn f) + (hcollision : EncodingCollision f cache secretKey signingLog) : + EncodingCacheCollision secretKey.parameter cache := by + obtain ⟨lay, tree, leafIdx, forgedMessage, forgedCounter, _, _, entry, signature, index, _, + hforgedCached, _, _, _, _, _, _, _, _, _, hsignedCached, hhit⟩ := hcollision + let signedPayload := digestBytes (evalWithAnswerFn f (layerMessage secretKey index lay)) ++ + counterBytes (signature.counter lay) + let forgedPayload := digestBytes forgedMessage ++ counterBytes forgedCounter + let signedInput := tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) signedPayload + let forgedInput := tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx) forgedPayload + obtain ⟨signedAnswer, hsignedAnswer⟩ := Option.ne_none_iff_exists'.mp hsignedCached + have hforgedCached' : cache forgedInput ≠ none := by + exact CachedRun.otsLeaf_encode_cached hforgedCached + obtain ⟨forgedAnswer, hforgedAnswer⟩ := Option.ne_none_iff_exists'.mp hforgedCached' + change signedInput ≠ forgedInput ∧ truncateHash (f signedInput) = truncateHash (f forgedInput) + at hhit + refine ⟨lay, tree, leafIdx, signedPayload, forgedPayload, signedAnswer, forgedAnswer, ?_, + hsignedAnswer, hforgedAnswer, ?_⟩ + · exact fun heq => hhit.1 (congrArg + (tweakableHashInput secretKey.parameter (.encoding lay tree leafIdx)) heq) + · rw [← hf hsignedAnswer, ← hf hforgedAnswer] + exact hhit.2 + +theorem CachedRun.messageDigest_cached {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {parameter : PublicParameter} {root : Digest} + {message : Message} {randomness : Randomness} + (hrun : CachedRun cache f (messageDigest parameter root message randomness)) : + cache (tweakableHashInput parameter .message + (messageDigestPayload root message randomness)) ≠ none := by + apply hrun + rw [messageDigest] + apply queriedInputs_mono_bind_left + change tweakableHashInput parameter .message + (messageDigestPayload root message randomness) ∈ + [tweakableHashInput parameter .message (messageDigestPayload root message randomness)] + simp + +theorem messageDigestCollision_cacheCollision {f : QueryImpl HashSpec Id} + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {signingLog : QueryLog SigningSpec} {forgery : Forgery} + (hf : cache.AgreesWithFn f) + (hcollision : MessageDigestCollision f cache secretKey signingLog forgery) : + MessageCacheCollision secretKey.parameter cache := by + obtain ⟨entry, signature, _, _, hsignRun, hforgedRun, hinput, hvalue⟩ := hcollision + obtain ⟨_, _, _, hsignedDigest, _, _, _, _, _, _, _⟩ := hsignRun.indexed + obtain ⟨_, _, _, _, _, _, hsignedRun⟩ := hsignedDigest.extract + let signedPayload := messageDigestPayload secretKey.root entry.1 signature.randomness + let forgedPayload := messageDigestPayload secretKey.root forgery.message + forgery.signature.randomness + let signedInput := tweakableHashInput secretKey.parameter .message signedPayload + let forgedInput := tweakableHashInput secretKey.parameter .message forgedPayload + have hsignedCached : cache signedInput ≠ none := by + exact CachedRun.messageDigest_cached hsignedRun + have hforgedCached : cache forgedInput ≠ none := by + exact CachedRun.messageDigest_cached hforgedRun + obtain ⟨signedAnswer, hsignedAnswer⟩ := Option.ne_none_iff_exists'.mp hsignedCached + obtain ⟨forgedAnswer, hforgedAnswer⟩ := Option.ne_none_iff_exists'.mp hforgedCached + refine ⟨signedPayload, forgedPayload, signedAnswer, forgedAnswer, ?_, hsignedAnswer, + hforgedAnswer, ?_⟩ + · exact fun heq => hinput (congrArg + (tweakableHashInput secretKey.parameter HashDomain.message) heq) + · change truncateMessageDigest (f signedInput) = truncateMessageDigest (f forgedInput) at hvalue + rw [← hf hsignedAnswer, ← hf hforgedAnswer] + exact hvalue + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/TerminalDecomposition.lean b/formal/sphincs/SphincsSecurity/Proof/TerminalDecomposition.lean new file mode 100644 index 00000000..a1abd599 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TerminalDecomposition.lean @@ -0,0 +1,276 @@ +import SphincsSecurity.Proof.ChargeStep +import SphincsSecurity.Proof.OneTimeEvents + +/-! +# Probability decomposition after deterministic descent + +The support-level forgery classification is lifted to event probabilities. The structural branch +is discharged immediately by the amortized `44`-unit cache bound, leaving one explicit terminal +event for the remaining probability arguments. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +namespace Concrete + +def TerminalWitnessFor (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (event : QueryImpl HashSpec Id → QueryCache HashSpec → SecretKey → + QueryLog SigningSpec → Forgery → Index → (DigestTree → FtsLeaf) → Prop) + (result : Bool × QueryCache HashSpec) : Prop := + ∃ root forgery signingLog f digest, + let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + result.2.AgreesWithFn f + ∧ SigningTranscript.Valid signingLog + ∧ ¬ SigningTranscript.Contains signingLog forgery + ∧ evalWithAnswerFn f + (messageDigest parameter root forgery.message forgery.signature.randomness) = digest + ∧ Admissible digest + ∧ event f result.2 secretKey signingLog forgery + (digestIndex digest) (digestLeaves digest) + +def TerminalWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Bool × QueryCache HashSpec → Prop := + TerminalWitnessFor parameter otsSecret ftsSecret TerminalForgeryEvent + +def FreshLayerOpeningWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Bool × QueryCache HashSpec → Prop := + TerminalWitnessFor parameter otsSecret ftsSecret + fun f cache secretKey signingLog forgery index leaves => + SettledForgedFreshLayerOpening f cache secretKey signingLog index leaves forgery.signature + +def EncodingCollisionWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Bool × QueryCache HashSpec → Prop := + TerminalWitnessFor parameter otsSecret ftsSecret fun f cache secretKey signingLog _ _ _ => + EncodingCollision f cache secretKey signingLog + +def BackwardChainOpeningWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Bool × QueryCache HashSpec → Prop := + TerminalWitnessFor parameter otsSecret ftsSecret + fun f cache secretKey signingLog forgery index leaves => + SettledForgedBackwardChainOpening f cache secretKey signingLog index leaves + forgery.signature + +def MessageDigestCollisionWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Bool × QueryCache HashSpec → Prop := + TerminalWitnessFor parameter otsSecret ftsSecret + fun f cache secretKey signingLog forgery index leaves => + MessageDigestCollision f cache secretKey signingLog forgery ∧ + FewTimeLeak f cache secretKey signingLog index leaves + +def ProperFewTimeLeakWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Bool × QueryCache HashSpec → Prop := + TerminalWitnessFor parameter otsSecret ftsSecret + fun f cache secretKey signingLog _ index leaves => + ProperFewTimeLeak f cache secretKey signingLog index leaves + +def UncoveredFtsSecretWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Bool × QueryCache HashSpec → Prop := + TerminalWitnessFor parameter otsSecret ftsSecret + fun f cache secretKey signingLog forgery index leaves => + UncoveredFtsSecret f cache secretKey signingLog index leaves forgery.signature.ftsSecret + +noncomputable instance (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + DecidablePred (TerminalWitness parameter otsSecret ftsSecret) := + fun result => Classical.propDecidable (TerminalWitness parameter otsSecret ftsSecret result) + +theorem terminalWitness_cases (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : Bool × QueryCache HashSpec) + (hwitness : TerminalWitness parameter otsSecret ftsSecret result) : + FreshLayerOpeningWitness parameter otsSecret ftsSecret result + ∨ EncodingCollisionWitness parameter otsSecret ftsSecret result + ∨ BackwardChainOpeningWitness parameter otsSecret ftsSecret result + ∨ MessageDigestCollisionWitness parameter otsSecret ftsSecret result + ∨ ProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∨ UncoveredFtsSecretWitness parameter otsSecret ftsSecret result := by + obtain ⟨root, forgery, signingLog, f, digest, hf, hvalid, hnotContains, hdigest, + hadmissible, hterminal⟩ := hwitness + rcases hterminal with hfresh | hencoding | hbackward | hmessage | hfewTime | huncovered + · exact Or.inl ⟨root, forgery, signingLog, f, digest, hf, hvalid, hnotContains, + hdigest, hadmissible, hfresh⟩ + · exact Or.inr (Or.inl ⟨root, forgery, signingLog, f, digest, hf, hvalid, + hnotContains, hdigest, hadmissible, hencoding⟩) + · exact Or.inr (Or.inr (Or.inl ⟨root, forgery, signingLog, f, digest, hf, hvalid, + hnotContains, hdigest, hadmissible, hbackward⟩)) + · exact Or.inr (Or.inr (Or.inr (Or.inl ⟨root, forgery, signingLog, f, digest, hf, + hvalid, hnotContains, hdigest, hadmissible, hmessage⟩))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inl ⟨root, forgery, signingLog, f, + digest, hf, hvalid, hnotContains, hdigest, hadmissible, hfewTime⟩)))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr ⟨root, forgery, signingLog, f, + digest, hf, hvalid, hnotContains, hdigest, hadmissible, huncovered⟩)))) + +theorem probEvent_terminalWitness_le (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (oa : ProbComp (Bool × QueryCache HashSpec)) : + Pr[TerminalWitness parameter otsSecret ftsSecret | oa] ≤ + Pr[FreshLayerOpeningWitness parameter otsSecret ftsSecret | oa] + + (Pr[EncodingCollisionWitness parameter otsSecret ftsSecret | oa] + + (Pr[BackwardChainOpeningWitness parameter otsSecret ftsSecret | oa] + + (Pr[MessageDigestCollisionWitness parameter otsSecret ftsSecret | oa] + + (Pr[ProperFewTimeLeakWitness parameter otsSecret ftsSecret | oa] + + Pr[UncoveredFtsSecretWitness parameter otsSecret ftsSecret | oa])))) := by + classical + calc + _ ≤ Pr[fun result => + FreshLayerOpeningWitness parameter otsSecret ftsSecret result + ∨ EncodingCollisionWitness parameter otsSecret ftsSecret result + ∨ BackwardChainOpeningWitness parameter otsSecret ftsSecret result + ∨ MessageDigestCollisionWitness parameter otsSecret ftsSecret result + ∨ ProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∨ UncoveredFtsSecretWitness parameter otsSecret ftsSecret result | oa] := by + apply probEvent_mono + intro result _ hwitness + exact terminalWitness_cases parameter otsSecret ftsSecret result hwitness + _ ≤ Pr[FreshLayerOpeningWitness parameter otsSecret ftsSecret | oa] + + Pr[fun result => EncodingCollisionWitness parameter otsSecret ftsSecret result + ∨ BackwardChainOpeningWitness parameter otsSecret ftsSecret result + ∨ MessageDigestCollisionWitness parameter otsSecret ftsSecret result + ∨ ProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∨ UncoveredFtsSecretWitness parameter otsSecret ftsSecret result | oa] := + probEvent_or_le _ _ _ + _ ≤ Pr[FreshLayerOpeningWitness parameter otsSecret ftsSecret | oa] + + (Pr[EncodingCollisionWitness parameter otsSecret ftsSecret | oa] + + Pr[fun result => BackwardChainOpeningWitness parameter otsSecret ftsSecret result + ∨ MessageDigestCollisionWitness parameter otsSecret ftsSecret result + ∨ ProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∨ UncoveredFtsSecretWitness parameter otsSecret ftsSecret result | oa]) := by + gcongr + exact probEvent_or_le _ _ _ + _ ≤ Pr[FreshLayerOpeningWitness parameter otsSecret ftsSecret | oa] + + (Pr[EncodingCollisionWitness parameter otsSecret ftsSecret | oa] + + (Pr[BackwardChainOpeningWitness parameter otsSecret ftsSecret | oa] + + Pr[fun result => MessageDigestCollisionWitness parameter otsSecret ftsSecret result + ∨ ProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∨ UncoveredFtsSecretWitness parameter otsSecret ftsSecret result | oa])) := by + gcongr + exact probEvent_or_le _ _ _ + _ ≤ Pr[FreshLayerOpeningWitness parameter otsSecret ftsSecret | oa] + + (Pr[EncodingCollisionWitness parameter otsSecret ftsSecret | oa] + + (Pr[BackwardChainOpeningWitness parameter otsSecret ftsSecret | oa] + + (Pr[MessageDigestCollisionWitness parameter otsSecret ftsSecret | oa] + + Pr[fun result => ProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∨ UncoveredFtsSecretWitness parameter otsSecret ftsSecret result | oa]))) := by + gcongr + exact probEvent_or_le _ _ _ + _ ≤ _ := by + gcongr + exact probEvent_or_le _ _ _ + +theorem winning_implies_bad_or_terminal (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : Bool × QueryCache HashSpec) + (hresult : result ∈ support + ((simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅)) + (hwin : result.1 = true) : + Bad parameter otsSecret ftsSecret result.2 + ∨ TerminalWitness parameter otsSecret ftsSecret result := by + rcases result with ⟨verdict, finalCache⟩ + simp only at hwin + subst verdict + rcases winning_support_terminal_classify adversary parameter otsSecret ftsSecret + finalCache hresult with hbad | hwitness + · exact Or.inl hbad + · exact Or.inr hwitness + +theorem probEvent_win_le_bad_add_terminal (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[= true | (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run' ∅] ≤ + Pr[fun result => Bad parameter otsSecret ftsSecret result.2 | + (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅] + + Pr[TerminalWitness parameter otsSecret ftsSecret | + (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅] := by + let run := (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅ + calc + Pr[= true | (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run' ∅] = + Pr[fun result => result.1 = true | run] := by + rw [StateT.run'_eq, ← probEvent_eq_eq_probOutput, probEvent_map] + rfl + _ ≤ Pr[fun result => Bad parameter otsSecret ftsSecret result.2 + ∨ TerminalWitness parameter otsSecret ftsSecret result | run] := by + apply probEvent_mono + intro result hresult hwin + exact winning_implies_bad_or_terminal adversary parameter otsSecret ftsSecret + result hresult hwin + _ ≤ _ := probEvent_or_le _ _ _ + +theorem probEvent_win_le_structural_add_terminal (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : (gameAfterSecrets adversary parameter otsSecret ftsSecret).IsQueryBoundP + (· matches Sum.inr _) q) : + Pr[= true | (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run' ∅] ≤ + ((44 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + Pr[TerminalWitness parameter otsSecret ftsSecret | + (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅] := by + calc + _ ≤ _ := probEvent_win_le_bad_add_terminal adversary parameter otsSecret ftsSecret + _ ≤ _ := by + gcongr + exact probEvent_bad_gameAfterSecrets_le adversary parameter otsSecret ftsSecret q hq + +theorem probEvent_win_le_structural_add_terminal_cases (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : (gameAfterSecrets adversary parameter otsSecret ftsSecret).IsQueryBoundP + (· matches Sum.inr _) q) : + let run := (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅ + Pr[= true | (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run' ∅] ≤ + ((44 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + (Pr[FreshLayerOpeningWitness parameter otsSecret ftsSecret | run] + + (Pr[EncodingCollisionWitness parameter otsSecret ftsSecret | run] + + (Pr[BackwardChainOpeningWitness parameter otsSecret ftsSecret | run] + + (Pr[MessageDigestCollisionWitness parameter otsSecret ftsSecret | run] + + (Pr[ProperFewTimeLeakWitness parameter otsSecret ftsSecret | run] + + Pr[UncoveredFtsSecretWitness parameter otsSecret ftsSecret | run]))))) := by + dsimp only + let run := (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅ + calc + _ ≤ ((44 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + Pr[TerminalWitness parameter otsSecret ftsSecret | run] := + probEvent_win_le_structural_add_terminal adversary parameter otsSecret ftsSecret q hq + _ ≤ _ := by + gcongr + exact probEvent_terminalWitness_le parameter otsSecret ftsSecret run + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/TerminalFinish.lean b/formal/sphincs/SphincsSecurity/Proof/TerminalFinish.lean new file mode 100644 index 00000000..45a1bbae --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TerminalFinish.lean @@ -0,0 +1,81 @@ +import SphincsSecurity.Proof.TerminalSampling + +/-! +# Final residual interface + +Once the five sampled residual probabilities fit in the remaining 64 units at denominator `2^128`, +the concrete advantage has the claimed `q / 2^120` bound. Budgets above `2^120` are immediate from +the fact that a probability is at most one. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp ENNReal + +theorem forgeAdvantage_le_of_sampled_remaining_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) + (hremaining : + Pr[SampledViewedEvent cleanFreshEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanEncodingEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanBackwardEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanMessageEvent | sampledViewedGame adversary] + + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary]))) ≤ + ((64 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + forgeAdvantage scheme adversary ≤ q / ((2 ^ securityBits : Nat) : ℝ≥0∞) := by + calc + _ ≤ ((24 * q : Nat) : ℝ≥0∞) * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹ + + (Pr[SampledViewedEvent cleanFreshEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanEncodingEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanBackwardEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanMessageEvent | sampledViewedGame adversary] + + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary])))) := + forgeAdvantage_le_reserved_add_sampled_remaining adversary q hq hqMax + _ ≤ ((24 * q : Nat) : ℝ≥0∞) * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹ + + ((64 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + add_le_add_right hremaining _ + _ = (q : ℝ≥0∞) * + (((24 : Nat) : ℝ≥0∞) * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹ + + ((64 : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) := by + push_cast + ring + _ = (q : ℝ≥0∞) * ((2 ^ securityBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [show securityBits = 120 by rfl, terminal_budget_remainder] + _ = q / ((2 ^ securityBits : Nat) : ℝ≥0∞) := by + rw [div_eq_mul_inv] + +theorem forgeAdvantage_le_of_security_pow_le + (adversary : Adversary) (q : Nat) (hq : 2 ^ securityBits ≤ q) : + forgeAdvantage scheme adversary ≤ q / ((2 ^ securityBits : Nat) : ℝ≥0∞) := by + apply probOutput_le_one.trans + rw [div_eq_mul_inv] + have hcast : (((2 ^ securityBits : Nat) : Nat) : ℝ≥0∞) ≤ (q : ℝ≥0∞) := by + exact_mod_cast hq + calc + (1 : ℝ≥0∞) = ((2 ^ securityBits : Nat) : ℝ≥0∞) * + ((2 ^ securityBits : Nat) : ℝ≥0∞)⁻¹ := by + rw [ENNReal.mul_inv_cancel] + · norm_num + · finiteness + _ ≤ (q : ℝ≥0∞) * ((2 ^ securityBits : Nat) : ℝ≥0∞)⁻¹ := by + gcongr + +theorem security_of_sampled_remaining_le + (hremaining : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ securityBits → + Pr[SampledViewedEvent cleanFreshEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanEncodingEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanBackwardEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanMessageEvent | sampledViewedGame adversary] + + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary]))) ≤ + ((64 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + SphincsSecurityStatement := by + intro q hqPos adversary hq + by_cases hqMax : q ≤ 2 ^ securityBits + · apply forgeAdvantage_le_of_sampled_remaining_le adversary q hq + · simpa only [securityBits] using hqMax + · exact hremaining q hqPos adversary hq hqMax + · apply forgeAdvantage_le_of_security_pow_le adversary q + omega + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/TerminalResidual.lean b/formal/sphincs/SphincsSecurity/Proof/TerminalResidual.lean new file mode 100644 index 00000000..d8d6ce23 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TerminalResidual.lean @@ -0,0 +1,115 @@ +import SphincsSecurity.Proof.EncodingSelectionSampling +import SphincsSecurity.Proof.MessageCollision +import SphincsSecurity.Proof.TerminalFinish + +/-! +# Residual terminal interface after encoding collisions + +The completed encoding bound consumes 44 of the 64 units left at denominator `2^128`. The four +secret-opening and message branches therefore have a combined budget of 20 units. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp ENNReal + +noncomputable def sampledNonEncodingRisk (adversary : Adversary) : ℝ≥0∞ := + Pr[SampledViewedEvent cleanFreshEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanBackwardEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanMessageEvent | sampledViewedGame adversary] + + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary])) + +theorem forgeAdvantage_le_of_sampled_nonEncodingRisk_le + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) + (hresidual : sampledNonEncodingRisk adversary ≤ + ((20 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + forgeAdvantage scheme adversary ≤ q / ((2 ^ securityBits : Nat) : ℝ≥0∞) := by + apply forgeAdvantage_le_of_sampled_remaining_le adversary q hq hqMax + calc + Pr[SampledViewedEvent cleanFreshEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanEncodingEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanBackwardEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanMessageEvent | sampledViewedGame adversary] + + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary]))) = + Pr[SampledViewedEvent cleanEncodingEvent | sampledViewedGame adversary] + + sampledNonEncodingRisk adversary := by + rw [sampledNonEncodingRisk] + ring + _ ≤ ((44 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + ((20 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := + add_le_add (probEvent_sampled_cleanEncoding_le adversary q hq) hresidual + _ = ((64 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + push_cast + ring + +theorem security_of_sampled_nonEncodingRisk_le + (hresidual : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ securityBits → + sampledNonEncodingRisk adversary ≤ + ((20 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + SphincsSecurityStatement := by + intro q hqPos adversary hq + by_cases hqMax : q ≤ 2 ^ securityBits + · exact forgeAdvantage_le_of_sampled_nonEncodingRisk_le adversary q hq + (by simpa only [securityBits] using hqMax) + (hresidual q hqPos adversary hq hqMax) + · exact forgeAdvantage_le_of_security_pow_le adversary q (by omega) + +noncomputable def sampledHiddenOpeningRisk (adversary : Adversary) : ℝ≥0∞ := + Pr[SampledViewedEvent cleanFreshEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanBackwardEvent | sampledViewedGame adversary] + + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary]) + +theorem sampledNonEncodingRisk_le_of_hiddenOpeningRisk_le + (adversary : Adversary) (q : Nat) (hqPos : 1 ≤ q) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 120) + (hhidden : sampledHiddenOpeningRisk adversary ≤ + ((19 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + sampledNonEncodingRisk adversary ≤ + ((20 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + have hmessage := probEvent_sampled_cleanMessage_le adversary q hqPos hq hqMax + calc + sampledNonEncodingRisk adversary = + sampledHiddenOpeningRisk adversary + + Pr[SampledViewedEvent cleanMessageEvent | sampledViewedGame adversary] := by + rw [sampledNonEncodingRisk, sampledHiddenOpeningRisk] + ring + _ ≤ ((19 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + (q : ℝ≥0∞) * ((2 ^ 139 : Nat) : ℝ≥0∞)⁻¹ := + add_le_add hhidden hmessage + _ ≤ ((19 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ + + (q : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply add_le_add le_rfl + rw [mul_comm (q : ℝ≥0∞), mul_comm (q : ℝ≥0∞)] + apply mul_le_mul_left + rw [show digestBits = 128 by rfl] + norm_num + _ = ((20 * q : Nat) : ℝ≥0∞) * + ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + push_cast + ring + +theorem forgeAdvantage_le_of_sampled_hiddenOpeningRisk_le + (adversary : Adversary) (q : Nat) (hqPos : 1 ≤ q) + (hq : HasHashQueryBound scheme adversary q) (hqMax : q ≤ 2 ^ 120) + (hhidden : sampledHiddenOpeningRisk adversary ≤ + ((19 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + forgeAdvantage scheme adversary ≤ q / ((2 ^ securityBits : Nat) : ℝ≥0∞) := by + exact forgeAdvantage_le_of_sampled_nonEncodingRisk_le adversary q hq hqMax + (sampledNonEncodingRisk_le_of_hiddenOpeningRisk_le adversary q hqPos hq hqMax hhidden) + +theorem security_of_sampled_hiddenOpeningRisk_le + (hhidden : ∀ (q : Nat), 1 ≤ q → ∀ adversary : Adversary, + HasHashQueryBound scheme adversary q → q ≤ 2 ^ securityBits → + sampledHiddenOpeningRisk adversary ≤ + ((19 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹) : + SphincsSecurityStatement := by + intro q hqPos adversary hq + by_cases hqMax : q ≤ 2 ^ securityBits + · exact forgeAdvantage_le_of_sampled_hiddenOpeningRisk_le adversary q hqPos hq + (by simpa only [securityBits] using hqMax) + (hhidden q hqPos adversary hq hqMax) + · exact forgeAdvantage_le_of_security_pow_le adversary q (by omega) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/TerminalSampling.lean b/formal/sphincs/SphincsSecurity/Proof/TerminalSampling.lean new file mode 100644 index 00000000..f31c5425 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TerminalSampling.lean @@ -0,0 +1,231 @@ +import SphincsSecurity.Proof.TerminalBudget + +/-! +# Lifting residual terminal events across secret sampling + +The structural and few-time bounds hold after the sampled tables are fixed. The residual opening +events do not, because their probability comes from the hidden table entries themselves. This +module keeps the sampled tables in the observational output so those events can be averaged at the +correct point in the original game. +-/ + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +structure SampledSecrets where + parameter : PublicParameter + otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest + ftsSecret : Index → FtsTree → FtsLeaf → Digest + +noncomputable def sampleSecrets : ProbComp SampledSecrets := do + let parameter ← sampleParameter + let otsSecret ← sampleOtsSecrets + let ftsSecret ← sampleFtsSecrets + pure ⟨parameter, otsSecret, ftsSecret⟩ + +theorem SampledSecrets.support_components {secrets : SampledSecrets} + (hsecrets : secrets ∈ support sampleSecrets) : + secrets.parameter ∈ support sampleParameter + ∧ secrets.otsSecret ∈ support sampleOtsSecrets + ∧ secrets.ftsSecret ∈ support sampleFtsSecrets := by + rw [sampleSecrets, mem_support_bind_iff] at hsecrets + obtain ⟨parameter, hparameter, hsecrets⟩ := hsecrets + rw [mem_support_bind_iff] at hsecrets + obtain ⟨otsSecret, hots, hsecrets⟩ := hsecrets + rw [mem_support_bind_iff] at hsecrets + obtain ⟨ftsSecret, hfts, hsecrets⟩ := hsecrets + simp only [support_pure, Set.mem_singleton_iff] at hsecrets + subst secrets + exact ⟨hparameter, hots, hfts⟩ + +structure SampledViewedResult where + secrets : SampledSecrets + result : (Digest × Forgery × Bool) × ViewedFullTraceState + +noncomputable def sampledViewedGame (adversary : Adversary) : ProbComp SampledViewedResult := do + let secrets ← sampleSecrets + let result ← gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret + pure ⟨secrets, result⟩ + +noncomputable def sampledGame (adversary : Adversary) : ProbComp Bool := do + let secrets ← sampleSecrets + (simulateQ romImpl + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret secrets.ftsSecret)).run' ∅ + +theorem forgeAdvantage_eq_sampledGame (adversary : Adversary) : + forgeAdvantage scheme adversary = Pr[= true | sampledGame adversary] := by + rw [forgeAdvantage, gameCore_eq_secrets, simulateQ_romImpl_liftM_bind_run'] + simp_rw [simulateQ_romImpl_liftM_bind_run'] + simp only [sampledGame, sampleSecrets, bind_assoc, pure_bind] + +def SampledViewedEvent + (event : PublicParameter → + (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) → + (Index → FtsTree → FtsLeaf → Digest) → + ((Digest × Forgery × Bool) × ViewedFullTraceState) → Prop) + (output : SampledViewedResult) : Prop := + event output.secrets.parameter output.secrets.otsSecret output.secrets.ftsSecret output.result + +theorem probEvent_sampledViewedGame_eq_weighted + (adversary : Adversary) + (event : PublicParameter → + (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) → + (Index → FtsTree → FtsLeaf → Digest) → + ((Digest × Forgery × Bool) × ViewedFullTraceState) → Prop) : + Pr[SampledViewedEvent event | sampledViewedGame adversary] = + ∑' secrets : SampledSecrets, Pr[= secrets | sampleSecrets] * + Pr[event secrets.parameter secrets.otsSecret secrets.ftsSecret | + gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret] := by + classical + rw [sampledViewedGame, probEvent_bind_eq_tsum] + refine tsum_congr fun secrets => ?_ + rw [probEvent_bind_eq_tsum] + congr 1 + rw [probEvent_eq_tsum_ite] + refine tsum_congr fun result => ?_ + rw [probEvent_pure] + by_cases hresult : event secrets.parameter secrets.otsSecret secrets.ftsSecret result + · simp [SampledViewedEvent, hresult] + · simp [SampledViewedEvent, hresult] + +theorem probEvent_bind_le_const_add_weighted + {Alpha Beta : Type} {oa : ProbComp Alpha} {run : Alpha → ProbComp Beta} + {event : Beta → Prop} {cost : ℝ≥0∞} (risk : Alpha → ℝ≥0∞) + (hbound : ∀ value ∈ support oa, Pr[event | run value] ≤ cost + risk value) : + Pr[event | oa >>= run] ≤ + cost + ∑' value : Alpha, Pr[= value | oa] * risk value := by + rw [probEvent_bind_eq_tsum] + calc + _ ≤ ∑' value : Alpha, Pr[= value | oa] * (cost + risk value) := by + refine ENNReal.tsum_le_tsum fun value => ?_ + by_cases hvalue : value ∈ support oa + · gcongr + exact hbound value hvalue + · rw [probOutput_eq_zero_of_not_mem_support hvalue, zero_mul, zero_mul] + _ = (∑' value : Alpha, Pr[= value | oa] * cost) + + ∑' value : Alpha, Pr[= value | oa] * risk value := by + simp_rw [mul_add] + rw [ENNReal.tsum_add] + _ ≤ cost + ∑' value : Alpha, Pr[= value | oa] * risk value := by + gcongr + rw [ENNReal.tsum_mul_right] + exact mul_le_of_le_one_left zero_le tsum_probOutput_le_one + +def cleanFreshEvent (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : Prop := + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ result.1.2.2 = true) ∧ + ViewedWinningFreshLayerOpeningWitness parameter otsSecret ftsSecret result + +def cleanEncodingEvent (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : Prop := + ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result + +def cleanBackwardEvent (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : Prop := + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ result.1.2.2 = true) ∧ + ViewedWinningBackwardChainOpeningWitness parameter otsSecret ftsSecret result + +def cleanMessageEvent (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : Prop := + ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result + +def cleanUncoveredEvent (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : Prop := + ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result + +noncomputable def remainingRisk (adversary : Adversary) (secrets : SampledSecrets) : ℝ≥0∞ := + let run := gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret + Pr[cleanFreshEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | run] + + (Pr[cleanEncodingEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | run] + + (Pr[cleanBackwardEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | run] + + (Pr[cleanMessageEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | run] + + Pr[cleanUncoveredEvent secrets.parameter secrets.otsSecret secrets.ftsSecret | run]))) + +theorem weighted_remainingRisk_eq (adversary : Adversary) : + (∑' secrets : SampledSecrets, + Pr[= secrets | sampleSecrets] * remainingRisk adversary secrets) = + Pr[SampledViewedEvent cleanFreshEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanEncodingEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanBackwardEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanMessageEvent | sampledViewedGame adversary] + + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary]))) := by + simp only [remainingRisk, mul_add, ENNReal.tsum_add] + rw [← probEvent_sampledViewedGame_eq_weighted adversary cleanFreshEvent, + ← probEvent_sampledViewedGame_eq_weighted adversary cleanEncodingEvent, + ← probEvent_sampledViewedGame_eq_weighted adversary cleanBackwardEvent, + ← probEvent_sampledViewedGame_eq_weighted adversary cleanMessageEvent, + ← probEvent_sampledViewedGame_eq_weighted adversary cleanUncoveredEvent] + +theorem forgeAdvantage_le_reserved_add_sampled_remaining + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) : + forgeAdvantage scheme adversary ≤ + ((24 * q : Nat) : ℝ≥0∞) * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹ + + (Pr[SampledViewedEvent cleanFreshEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanEncodingEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanBackwardEvent | sampledViewedGame adversary] + + (Pr[SampledViewedEvent cleanMessageEvent | sampledViewedGame adversary] + + Pr[SampledViewedEvent cleanUncoveredEvent | sampledViewedGame adversary])))) := by + rw [forgeAdvantage_eq_sampledGame, sampledGame] + calc + _ ≤ ((24 * q : Nat) : ℝ≥0∞) * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹ + + ∑' secrets : SampledSecrets, + Pr[= secrets | sampleSecrets] * remainingRisk adversary secrets := by + rw [← probEvent_eq_eq_probOutput] + apply probEvent_bind_le_const_add_weighted + (oa := sampleSecrets) + (run := fun secrets => (simulateQ romImpl + (gameAfterSecrets adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret)).run' ∅) + (event := fun verdict => verdict = true) + (cost := ((24 * q : Nat) : ℝ≥0∞) * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹) + (remainingRisk adversary) + intro secrets hsecrets + obtain ⟨hparameter, hots, hfts⟩ := secrets.support_components hsecrets + have hrisk : remainingRisk adversary secrets = + let run := gameAfterSecretsWithViewTrace adversary secrets.parameter secrets.otsSecret + secrets.ftsSecret + Pr[fun result => + (¬Bad secrets.parameter secrets.otsSecret secrets.ftsSecret result.2.cache ∧ + result.1.2.2 = true) ∧ + ViewedWinningFreshLayerOpeningWitness secrets.parameter secrets.otsSecret + secrets.ftsSecret result | run] + + (Pr[fun result => ¬Bad secrets.parameter secrets.otsSecret secrets.ftsSecret + result.2.cache ∧ ViewedEncodingCollisionWitness secrets.parameter + secrets.otsSecret secrets.ftsSecret result | run] + + (Pr[fun result => + (¬Bad secrets.parameter secrets.otsSecret secrets.ftsSecret result.2.cache ∧ + result.1.2.2 = true) ∧ + ViewedWinningBackwardChainOpeningWitness secrets.parameter secrets.otsSecret + secrets.ftsSecret result | run] + + (Pr[fun result => ¬Bad secrets.parameter secrets.otsSecret secrets.ftsSecret + result.2.cache ∧ ViewedMessageDigestCollisionWitness secrets.parameter + secrets.otsSecret secrets.ftsSecret result | run] + + Pr[fun result => ¬Bad secrets.parameter secrets.otsSecret secrets.ftsSecret + result.2.cache ∧ ViewedUncoveredFtsSecretWitness secrets.parameter + secrets.otsSecret secrets.ftsSecret result | run]))) := by + rfl + rw [hrisk] + rw [probEvent_eq_eq_probOutput] + exact probEvent_win_le_reserved_add_remaining adversary q hq hqMax + secrets.parameter hparameter secrets.otsSecret hots secrets.ftsSecret hfts + _ = _ := by rw [weighted_remainingRisk_eq] + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/TerminalView.lean b/formal/sphincs/SphincsSecurity/Proof/TerminalView.lean new file mode 100644 index 00000000..87cceff3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TerminalView.lean @@ -0,0 +1,758 @@ +import SphincsSecurity.Proof.FewTimeTargetTerminal +import SphincsSecurity.Proof.TerminalDecomposition + +/-! +# Terminal events on the observational game + +The final probability bounds use the game that retains the actual forgery, signing transcript and +cache intervals. This prevents an existential terminal witness from choosing a transcript unrelated +to the supported execution. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +theorem FullAdversaryTrace.CacheChain.start_le_finish + {secretKey : SecretKey} {start finish : QueryCache HashSpec} + {intervals : List AdversaryCacheEntry} + (hchain : FullAdversaryTrace.CacheChain start intervals finish) + (hvalid : ∀ entry ∈ intervals, + (entry.output, entry.finalCache) ∈ support + ((unloggedMappedAdversaryImpl secretKey entry.input).run entry.initialCache)) : + start ≤ finish := by + induction intervals generalizing start finish with + | nil => + change finish = start at hchain + exact le_of_eq hchain.symm + | cons head rest ih => + obtain ⟨hstart, hrest⟩ := hchain + have hhead : head.initialCache ≤ head.finalCache := + unloggedMappedAdversaryImpl_cache_le secretKey head.input head.initialCache + (head.output, head.finalCache) (hvalid head (by simp)) + rw [← hstart] + exact hhead.trans (ih hrest fun entry hentry => hvalid entry (by simp [hentry])) + +namespace Concrete + +def ViewedTerminalWitnessFor (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (event : QueryImpl HashSpec Id → QueryCache HashSpec → SecretKey → + QueryLog SigningSpec → Forgery → Index → (DigestTree → FtsLeaf) → Prop) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : Prop := + ∃ (f : QueryImpl HashSpec Id) (digest : MessageDigest), + result.2.cache.AgreesWithFn f + ∧ SigningTranscript.Valid result.2.trace.signing.toSigningLog + ∧ ¬SigningTranscript.Contains result.2.trace.signing.toSigningLog result.1.2.1 + ∧ evalWithAnswerFn f + (messageDigest parameter result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) = digest + ∧ Admissible digest + ∧ event f result.2.cache ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.trace.signing.toSigningLog result.1.2.1 + (digestIndex digest) (digestLeaves digest) + +def ViewedWinningTerminalWitnessFor (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (event : QueryImpl HashSpec Id → QueryCache HashSpec → SecretKey → + QueryLog SigningSpec → Forgery → Index → (DigestTree → FtsLeaf) → Prop) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : Prop := + ∃ (f : QueryImpl HashSpec Id) (digest : MessageDigest), + result.2.cache.AgreesWithFn f + ∧ SigningTranscript.Valid result.2.trace.signing.toSigningLog + ∧ ¬SigningTranscript.Contains result.2.trace.signing.toSigningLog result.1.2.1 + ∧ evalWithAnswerFn f + (messageDigest parameter result.1.1 result.1.2.1.message + result.1.2.1.signature.randomness) = digest + ∧ Admissible digest + ∧ evalWithAnswerFn f + (verify ⟨result.1.1, parameter⟩ result.1.2.1.message result.1.2.1.signature) = true + ∧ event f result.2.cache ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.trace.signing.toSigningLog result.1.2.1 + (digestIndex digest) (digestLeaves digest) + +theorem ViewedWinningTerminalWitnessFor.toViewed + {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {event : QueryImpl HashSpec Id → QueryCache HashSpec → SecretKey → + QueryLog SigningSpec → Forgery → Index → (DigestTree → FtsLeaf) → Prop} + {result : (Digest × Forgery × Bool) × ViewedFullTraceState} + (hwitness : ViewedWinningTerminalWitnessFor parameter otsSecret ftsSecret event result) : + ViewedTerminalWitnessFor parameter otsSecret ftsSecret event result := by + obtain ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, _, hevent⟩ := hwitness + exact ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hevent⟩ + +def ViewedTerminalWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := + ViewedTerminalWitnessFor parameter otsSecret ftsSecret TerminalForgeryEvent + +def ViewedWinningTerminalWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := + ViewedWinningTerminalWitnessFor parameter otsSecret ftsSecret TerminalForgeryEvent + +def ViewedFreshLayerOpeningWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := + ViewedTerminalWitnessFor parameter otsSecret ftsSecret + fun f cache secretKey signingLog forgery index leaves => + SettledForgedFreshLayerOpening f cache secretKey signingLog index leaves forgery.signature + +def ViewedWinningFreshLayerOpeningWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := + ViewedWinningTerminalWitnessFor parameter otsSecret ftsSecret + fun f cache secretKey signingLog forgery index leaves => + SettledForgedFreshLayerOpening f cache secretKey signingLog index leaves forgery.signature + +def ViewedEncodingCollisionWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := + ViewedTerminalWitnessFor parameter otsSecret ftsSecret + fun f cache secretKey signingLog _ _ _ => + EncodingCollision f cache secretKey signingLog + +def ViewedBackwardChainOpeningWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := + ViewedTerminalWitnessFor parameter otsSecret ftsSecret + fun f cache secretKey signingLog forgery index leaves => + SettledForgedBackwardChainOpening f cache secretKey signingLog index leaves + forgery.signature + +def ViewedWinningBackwardChainOpeningWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := + ViewedWinningTerminalWitnessFor parameter otsSecret ftsSecret + fun f cache secretKey signingLog forgery index leaves => + SettledForgedBackwardChainOpening f cache secretKey signingLog index leaves + forgery.signature + +def ViewedMessageDigestCollisionWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := + ViewedTerminalWitnessFor parameter otsSecret ftsSecret + fun f cache secretKey signingLog forgery index leaves => + MessageDigestCollision f cache secretKey signingLog forgery ∧ + FewTimeLeak f cache secretKey signingLog index leaves + +def ViewedUncoveredFtsSecretWitness (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := + ViewedTerminalWitnessFor parameter otsSecret ftsSecret + fun f cache secretKey signingLog forgery index leaves => + UncoveredFtsSecret f cache secretKey signingLog index leaves forgery.signature.ftsSecret + +noncomputable instance (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + DecidablePred (ViewedTerminalWitness parameter otsSecret ftsSecret) := + fun result => Classical.propDecidable + (ViewedTerminalWitness parameter otsSecret ftsSecret result) + +theorem gameAfterSecretsWithViewTrace_winning_terminal_classify + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (hwin : result.1.2.2 = true) : + Bad parameter otsSecret ftsSecret result.2.cache ∨ + ViewedWinningTerminalWitness parameter otsSecret ftsSecret result := by + rw [gameAfterSecretsWithViewTrace, mem_support_bind_iff] at hresult + obtain ⟨⟨root, rootCache⟩, hroot, hrest⟩ := hresult + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult, hrest, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + rw [gameRestWithViewTrace, mem_support_bind_iff] at hrest + obtain ⟨⟨forgery, state⟩, hadversary, hfinish⟩ := hrest + rw [mem_support_bind_iff] at hfinish + obtain ⟨⟨⟨verified, targetView⟩, finalCache⟩, hverifyView, hpure⟩ := hfinish + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst restResult + have hverified : verified = true := by + cases verified <;> simp_all + subst verified + have htranscript : SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery := by + have h := (show (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) ∧ True by + simpa only [Bool.and_eq_true, decide_eq_true_eq] using hwin) + exact h.1 + have hverify : (true, finalCache) ∈ support + ((simulateQ romImpl + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).run state.cache) := by + rw [← simulateQ_verifyWithView_fst_run ⟨root, parameter⟩ forgery.message + forgery.signature state.cache, support_map] + exact ⟨((true, targetView), finalCache), hverifyView, rfl⟩ + obtain ⟨hverifyLe, f, hf, heval, hqueries⟩ := exists_answerFn_replay_of_mem_support + (verify ⟨root, parameter⟩ forgery.message forgery.signature) state.cache true finalCache + (by simpa only [scheme, simulateQ_romImpl_liftM] using hverify) + have hroot' : (root, rootCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅) := by + simpa only [simulateQ_romImpl_liftM] using hroot + have hbaseAdversary : (forgery, state.base) ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl + ⟨parameter, root, otsSecret, ftsSecret⟩) + (adversary.main ⟨root, parameter⟩)).run + (rootCache, ⟨[], [], []⟩)) := by + let initialState : ViewedFullTraceState := + ⟨rootCache, ⟨[], [], []⟩, [], none⟩ + have hprojection := viewedFullTracedMappedAdversaryImpl_projection + ⟨parameter, root, otsSecret, ftsSecret⟩ (adversary.main ⟨root, parameter⟩) + initialState + have hmapped : (forgery, state.base) ∈ support + (Prod.map id ViewedFullTraceState.base <$> + (simulateQ (viewedFullTracedMappedAdversaryImpl + ⟨parameter, root, otsSecret, ftsSecret⟩) + (adversary.main ⟨root, parameter⟩)).run initialState) := by + rw [support_map] + exact ⟨(forgery, state), by simpa only [initialState] using hadversary, rfl⟩ + rw [hprojection] at hmapped + simpa only [initialState, ViewedFullTraceState.base] using hmapped + have hchain : FullAdversaryTrace.CacheChain rootCache state.trace.intervals state.cache := + fullTracedMappedAdversaryImpl_cacheChain + ⟨parameter, root, otsSecret, ftsSecret⟩ (adversary.main ⟨root, parameter⟩) + rootCache rootCache ⟨[], [], []⟩ (forgery, state.base) rfl hbaseAdversary + have hvalidIntervals : state.trace.ValidIntervals + ⟨parameter, root, otsSecret, ftsSecret⟩ := + fullTracedMappedAdversaryImpl_validIntervals + ⟨parameter, root, otsSecret, ftsSecret⟩ (adversary.main ⟨root, parameter⟩) + rootCache ⟨[], [], []⟩ (forgery, state.base) + (by simp [FullAdversaryTrace.ValidIntervals]) hbaseAdversary + have hrootLe : rootCache ≤ finalCache := + (hchain.start_le_finish hvalidIntervals).trans hverifyLe + obtain ⟨hrootEval, hrootQueries⟩ := replay_of_mem_support_of_le + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree)) ∅ root rootCache finalCache + hroot' hrootLe f hf + have hrootSettled := settled_treeRoot_of_cachedRun + (otsSecret := otsSecret) (ftsSecret := ftsSecret) hf topLayer rootTree hrootQueries + obtain ⟨digest, hdigest, hdigestRun, hadmissible, hlayers, hftsRun, hlayersRun⟩ := + verify_extract ⟨root, parameter⟩ forgery.message forgery.signature heval hqueries + let index := digestIndex digest + let leaves := digestLeaves digest + let ftsPublicKey := evalWithAnswerFn f + (ftsRecover parameter index leaves forgery.signature.ftsSecret forgery.signature.ftsPath) + have hhypertree : HypertreeRun f finalCache parameter index forgery.signature + ftsPublicKey root := + hypertreeRun_of_verify index forgery.signature ftsPublicKey root hlayers hlayersRun + have htarget : root = honestNode f parameter topLayer rootTree + (otsSecret topLayer rootTree) (layerHeight topLayer) 0 := by + rw [← hrootEval] + rfl + have htop := hypertree_top_extract_or_bad hf index forgery.signature ftsPublicKey root + hhypertree htarget (by simpa using hrootSettled) + rcases htop with hbad | htop + · exact Or.inl hbad + · let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + have hclassified := accepted_forgery_classify f finalCache secretKey + state.trace.signing.toSigningLog index forgery.signature leaves ftsPublicKey root hf rfl + htop (by + have htree : treeIndexAt index topLayer = rootTree := by + apply Fin.ext + exact treeIndexAt_topLayer index + unfold LayerRootSettled + rw [htree] + simpa using hrootSettled) hftsRun + rcases hclassified with hbad | hobstacle | hfull + · exact Or.inl hbad + · rcases settledForgedLayerObstacle_classify f finalCache secretKey + state.trace.signing.toSigningLog index leaves forgery.signature hobstacle with + hfresh | hencoding | hbackward + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inl hfresh⟩ + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inl hencoding)⟩ + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inr (Or.inl hbackward))⟩ + · rcases fewTimeLeak_or_uncovered f finalCache secretKey state.trace.signing.toSigningLog + index leaves with hleak | ⟨tree, huncovered⟩ + · rcases fullyHonest_leak_classify f finalCache secretKey + state.trace.signing.toSigningLog forgery digest index leaves hdigest hdigestRun rfl rfl + hfull.1 htranscript.2 hleak with hcollision | hobstacle | hproper + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inr (Or.inr (Or.inl ⟨hcollision, hleak⟩)))⟩ + · rcases settledForgedLayerObstacle_classify f finalCache secretKey + state.trace.signing.toSigningLog index leaves forgery.signature + (hfull.settleObstacle hobstacle) with + hfresh | hencoding | hbackward + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inl hfresh⟩ + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inl hencoding)⟩ + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inr (Or.inl hbackward))⟩ + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inr (Or.inr (Or.inr (Or.inl hproper))))⟩ + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inr (Or.inr (Or.inr (Or.inr + ⟨tree, huncovered, (hfull.1.2.1 tree).1, by + apply hftsRun + exact ftsRecover_leaf_query_mem f parameter index leaves + forgery.signature.ftsSecret forgery.signature.ftsPath tree⟩))))⟩ + +theorem viewedTerminalWitness_cases (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hwitness : ViewedTerminalWitness parameter otsSecret ftsSecret result) : + ViewedFreshLayerOpeningWitness parameter otsSecret ftsSecret result + ∨ ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result + ∨ ViewedBackwardChainOpeningWitness parameter otsSecret ftsSecret result + ∨ ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result + ∨ ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∨ ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result := by + obtain ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hterminal⟩ := hwitness + rcases hterminal with hfresh | hencoding | hbackward | hmessage | hfewTime | huncovered + · exact Or.inl ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hfresh⟩ + · exact Or.inr (Or.inl + ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hencoding⟩) + · exact Or.inr (Or.inr (Or.inl + ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hbackward⟩)) + · exact Or.inr (Or.inr (Or.inr (Or.inl + ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hmessage⟩))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inl + ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hfewTime⟩)))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr + ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, huncovered⟩)))) + +theorem viewedWinningTerminalWitness_cases (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hwitness : ViewedWinningTerminalWitness parameter otsSecret ftsSecret result) : + ViewedWinningFreshLayerOpeningWitness parameter otsSecret ftsSecret result + ∨ ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result + ∨ ViewedWinningBackwardChainOpeningWitness parameter otsSecret ftsSecret result + ∨ ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result + ∨ ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∨ ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result := by + obtain ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hverified, + hterminal⟩ := hwitness + rcases hterminal with hfresh | hencoding | hbackward | hmessage | hfewTime | huncovered + · exact Or.inl ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hverified, hfresh⟩ + · exact Or.inr (Or.inl + ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hencoding⟩) + · exact Or.inr (Or.inr (Or.inl + ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hverified, hbackward⟩)) + · exact Or.inr (Or.inr (Or.inr (Or.inl + ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hmessage⟩))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inl + ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, hfewTime⟩)))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr + ⟨f, digest, hf, hvalid, hnotContains, hdigest, hadmissible, huncovered⟩)))) + +theorem probEvent_and_six_or_le (run : ProbComp alpha) + (guard first second third fourth fifth sixth : alpha → Prop) : + Pr[fun result => guard result ∧ + (first result ∨ second result ∨ third result ∨ fourth result ∨ fifth result ∨ + sixth result) | run] ≤ + Pr[fun result => guard result ∧ first result | run] + + (Pr[fun result => guard result ∧ second result | run] + + (Pr[fun result => guard result ∧ third result | run] + + (Pr[fun result => guard result ∧ fourth result | run] + + (Pr[fun result => guard result ∧ fifth result | run] + + Pr[fun result => guard result ∧ sixth result | run])))) := by + classical + calc + _ ≤ Pr[fun result => + (guard result ∧ first result) ∨ + (guard result ∧ second result) ∨ + (guard result ∧ third result) ∨ + (guard result ∧ fourth result) ∨ + (guard result ∧ fifth result) ∨ + (guard result ∧ sixth result) | run] := by + apply probEvent_mono + intro result _ hresult + rcases hresult with ⟨hguard, hfirst | hsecond | hthird | hfourth | hfifth | hsixth⟩ + · exact Or.inl ⟨hguard, hfirst⟩ + · exact Or.inr (Or.inl ⟨hguard, hsecond⟩) + · exact Or.inr (Or.inr (Or.inl ⟨hguard, hthird⟩)) + · exact Or.inr (Or.inr (Or.inr (Or.inl ⟨hguard, hfourth⟩))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inl ⟨hguard, hfifth⟩)))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr ⟨hguard, hsixth⟩)))) + _ ≤ _ := by + calc + _ ≤ Pr[fun result => guard result ∧ first result | run] + + Pr[fun result => + (guard result ∧ second result) ∨ + (guard result ∧ third result) ∨ + (guard result ∧ fourth result) ∨ + (guard result ∧ fifth result) ∨ + (guard result ∧ sixth result) | run] := probEvent_or_le _ _ _ + _ ≤ _ := by + gcongr + calc + _ ≤ Pr[fun result => guard result ∧ second result | run] + + Pr[fun result => + (guard result ∧ third result) ∨ + (guard result ∧ fourth result) ∨ + (guard result ∧ fifth result) ∨ + (guard result ∧ sixth result) | run] := probEvent_or_le _ _ _ + _ ≤ _ := by + gcongr + calc + _ ≤ Pr[fun result => guard result ∧ third result | run] + + Pr[fun result => + (guard result ∧ fourth result) ∨ + (guard result ∧ fifth result) ∨ + (guard result ∧ sixth result) | run] := probEvent_or_le _ _ _ + _ ≤ _ := by + gcongr + calc + _ ≤ Pr[fun result => guard result ∧ fourth result | run] + + Pr[fun result => + (guard result ∧ fifth result) ∨ + (guard result ∧ sixth result) | run] := probEvent_or_le _ _ _ + _ ≤ _ := by + gcongr + exact probEvent_or_le _ _ _ + +theorem probEvent_winning_clean_viewedTerminalWitness_le (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (run : ProbComp ((Digest × Forgery × Bool) × ViewedFullTraceState)) : + Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ result.1.2.2 = true) ∧ + ViewedWinningTerminalWitness parameter otsSecret ftsSecret result | run] ≤ + Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ result.1.2.2 = true) ∧ + ViewedWinningFreshLayerOpeningWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ result.1.2.2 = true) ∧ + ViewedWinningBackwardChainOpeningWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result | run] + + Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result | run])))) := by + classical + let guard := fun result : (Digest × Forgery × Bool) × ViewedFullTraceState => + ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ result.1.2.2 = true + let fresh := ViewedWinningFreshLayerOpeningWitness parameter otsSecret ftsSecret + let encoding := ViewedEncodingCollisionWitness parameter otsSecret ftsSecret + let backward := ViewedWinningBackwardChainOpeningWitness parameter otsSecret ftsSecret + let message := ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret + let proper := ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret + let uncovered := ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret + calc + _ ≤ Pr[fun result => guard result ∧ + (fresh result ∨ encoding result ∨ backward result ∨ message result ∨ proper result ∨ + uncovered result) | run] := by + apply probEvent_mono + intro result _ hresult + exact ⟨hresult.1, + viewedWinningTerminalWitness_cases parameter otsSecret ftsSecret result hresult.2⟩ + _ ≤ Pr[fun result => guard result ∧ fresh result | run] + + (Pr[fun result => guard result ∧ encoding result | run] + + (Pr[fun result => guard result ∧ backward result | run] + + (Pr[fun result => guard result ∧ message result | run] + + (Pr[fun result => guard result ∧ proper result | run] + + Pr[fun result => guard result ∧ uncovered result | run])))) := + probEvent_and_six_or_le run guard fresh encoding backward message proper uncovered + _ ≤ _ := by + dsimp only [guard, fresh, encoding, backward, message, proper, uncovered] + gcongr <;> exact probEvent_mono (fun _ _ hresult => ⟨hresult.1.1, hresult.2⟩) + +theorem probEvent_viewedTerminalWitness_le (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (run : ProbComp ((Digest × Forgery × Bool) × ViewedFullTraceState)) : + Pr[ViewedTerminalWitness parameter otsSecret ftsSecret | run] ≤ + Pr[ViewedFreshLayerOpeningWitness parameter otsSecret ftsSecret | run] + + (Pr[ViewedEncodingCollisionWitness parameter otsSecret ftsSecret | run] + + (Pr[ViewedBackwardChainOpeningWitness parameter otsSecret ftsSecret | run] + + (Pr[ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret | run] + + (Pr[ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret | run] + + Pr[ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret | run])))) := by + classical + calc + _ ≤ Pr[fun result => + ViewedFreshLayerOpeningWitness parameter otsSecret ftsSecret result + ∨ ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result + ∨ ViewedBackwardChainOpeningWitness parameter otsSecret ftsSecret result + ∨ ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result + ∨ ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∨ ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result | run] := by + apply probEvent_mono + intro result _ hwitness + exact viewedTerminalWitness_cases parameter otsSecret ftsSecret result hwitness + _ ≤ Pr[ViewedFreshLayerOpeningWitness parameter otsSecret ftsSecret | run] + + Pr[fun result => ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result + ∨ ViewedBackwardChainOpeningWitness parameter otsSecret ftsSecret result + ∨ ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result + ∨ ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∨ ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result | run] := + probEvent_or_le _ _ _ + _ ≤ Pr[ViewedFreshLayerOpeningWitness parameter otsSecret ftsSecret | run] + + (Pr[ViewedEncodingCollisionWitness parameter otsSecret ftsSecret | run] + + Pr[fun result => ViewedBackwardChainOpeningWitness parameter otsSecret ftsSecret result + ∨ ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result + ∨ ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∨ ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result | run]) := by + gcongr + exact probEvent_or_le _ _ _ + _ ≤ Pr[ViewedFreshLayerOpeningWitness parameter otsSecret ftsSecret | run] + + (Pr[ViewedEncodingCollisionWitness parameter otsSecret ftsSecret | run] + + (Pr[ViewedBackwardChainOpeningWitness parameter otsSecret ftsSecret | run] + + Pr[fun result => ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result + ∨ ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∨ ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result | run])) := by + gcongr + exact probEvent_or_le _ _ _ + _ ≤ Pr[ViewedFreshLayerOpeningWitness parameter otsSecret ftsSecret | run] + + (Pr[ViewedEncodingCollisionWitness parameter otsSecret ftsSecret | run] + + (Pr[ViewedBackwardChainOpeningWitness parameter otsSecret ftsSecret | run] + + (Pr[ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret | run] + + Pr[fun result => ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result + ∨ ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result | run]))) := by + gcongr + exact probEvent_or_le _ _ _ + _ ≤ _ := by + gcongr + exact probEvent_or_le _ _ _ + +theorem probEvent_clean_viewedTerminalWitness_le (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (run : ProbComp ((Digest × Forgery × Bool) × ViewedFullTraceState)) : + Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedTerminalWitness parameter otsSecret ftsSecret result | run] ≤ + Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedFreshLayerOpeningWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedBackwardChainOpeningWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result | run] + + Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result | run])))) := by + classical + calc + _ ≤ Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedFreshLayerOpeningWitness parameter otsSecret ftsSecret result) ∨ + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result) ∨ + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedBackwardChainOpeningWitness parameter otsSecret ftsSecret result) ∨ + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result) ∨ + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result) ∨ + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result) | run] := by + apply probEvent_mono + intro result _ hwitness + obtain ⟨hclean, hterminal⟩ := hwitness + rcases viewedTerminalWitness_cases parameter otsSecret ftsSecret result hterminal with + hfresh | hencoding | hbackward | hmessage | hproper | huncovered + · exact Or.inl ⟨hclean, hfresh⟩ + · exact Or.inr (Or.inl ⟨hclean, hencoding⟩) + · exact Or.inr (Or.inr (Or.inl ⟨hclean, hbackward⟩)) + · exact Or.inr (Or.inr (Or.inr (Or.inl ⟨hclean, hmessage⟩))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inl ⟨hclean, hproper⟩)))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr ⟨hclean, huncovered⟩)))) + _ ≤ _ := by + calc + _ ≤ Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedFreshLayerOpeningWitness parameter otsSecret ftsSecret result | run] + + Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result) ∨ + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedBackwardChainOpeningWitness parameter otsSecret ftsSecret result) ∨ + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result) ∨ + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result) ∨ + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result) | run] := + probEvent_or_le _ _ _ + _ ≤ _ := by + gcongr + calc + _ ≤ Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result | run] + + Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedBackwardChainOpeningWitness parameter otsSecret ftsSecret result) ∨ + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result) ∨ + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result) ∨ + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result) | run] := + probEvent_or_le _ _ _ + _ ≤ _ := by + gcongr + calc + _ ≤ Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedBackwardChainOpeningWitness parameter otsSecret ftsSecret result | run] + + Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result) ∨ + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result) ∨ + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result) | run] := + probEvent_or_le _ _ _ + _ ≤ _ := by + gcongr + calc + _ ≤ Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result | + run] + + Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result) ∨ + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result) | + run] := probEvent_or_le _ _ _ + _ ≤ _ := by + gcongr + exact probEvent_or_le _ _ _ +theorem gameAfterSecretsWithViewTrace_verdictCache_projection (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + (fun result => (result.1.2.2, result.2.cache)) <$> + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret = + (simulateQ romImpl (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅ := by + calc + _ = (fun result : (Digest × Forgery × Bool) × + (QueryCache HashSpec × FullAdversaryTrace) => (result.1.2.2, result.2.1)) <$> + ((fun result => (result.1, result.2.base)) <$> + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret) := by + simp only [Functor.map_map, ViewedFullTraceState.base] + _ = (fun result : (Digest × Forgery × Bool) × + (QueryCache HashSpec × FullAdversaryTrace) => (result.1.2.2, result.2.1)) <$> + gameAfterSecretsWithFullTrace adversary parameter otsSecret ftsSecret := by + rw [gameAfterSecretsWithViewTrace_projection] + _ = _ := gameAfterSecretsWithFullTrace_projection adversary parameter otsSecret ftsSecret + +theorem probEvent_bad_gameAfterSecretsWithViewTrace_le (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : (gameAfterSecrets adversary parameter otsSecret ftsSecret).IsQueryBoundP + (· matches Sum.inr _) q) : + Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + ((44 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ = Pr[fun result : Bool × QueryCache HashSpec => + Bad parameter otsSecret ftsSecret result.2 | + (fun result => (result.1.2.2, result.2.cache)) <$> + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + rw [probEvent_map] + rfl + _ = Pr[fun result => Bad parameter otsSecret ftsSecret result.2 | + (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅] := by + rw [gameAfterSecretsWithViewTrace_verdictCache_projection] + _ ≤ _ := probEvent_bad_gameAfterSecrets_le adversary parameter otsSecret ftsSecret q hq + +theorem probEvent_clean_properFewTimeLeak_le_nine_mul_inv + (adversary : Adversary) (q : Nat) (hq : HasHashQueryBound scheme adversary q) + (hqMax : q ≤ 2 ^ 120) + (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (hots : otsSecret ∈ support sampleOtsSecrets) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (hfts : ftsSecret ∈ support sampleFtsSecrets) : + Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + ((2 * q + 1 : Nat) : ℝ≥0∞) * + (9 * ((2 ^ 125 : Nat) : ℝ≥0∞)⁻¹) := by + apply le_trans (probEvent_mono fun _ _ event => event.2) + exact probEvent_gameAfterSecretsWithViewTrace_proper_leak_le_nine_mul_inv adversary q hq + hqMax parameter hparameter otsSecret hots ftsSecret hfts + +theorem viewedMessageDigestCollisionWitness_patternHit + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (hwitness : ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result) : + SomeFewTimePatternHit result.2.trace.signing.toSigningLog.length + ((gameAfterSecretsWithViewTrace_support_validViews adversary parameter otsSecret ftsSecret + result hresult).signingViewsForLog rfl, + result.2.targetView.getD default) := by + obtain ⟨f, digest, hf, _, _, hdigest, _, _, hleak⟩ := hwitness + exact gameAfterSecretsWithViewTrace_fewTimeLeak_patternHit adversary parameter otsSecret + ftsSecret result hresult f hf digest hdigest hleak + +theorem probEvent_win_le_viewed_bad_add_terminal_cases (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + let run := gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + Pr[= true | (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run' ∅] ≤ + Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache | run] + + (Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ result.1.2.2 = true) ∧ + ViewedWinningFreshLayerOpeningWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ result.1.2.2 = true) ∧ + ViewedWinningBackwardChainOpeningWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret result | run] + + (Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedProperFewTimeLeakWitness parameter otsSecret ftsSecret result | run] + + Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result | run]))))) := by + classical + dsimp only + let run := gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + calc + Pr[= true | (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run' ∅] = + Pr[fun result => result.1.2.2 = true | run] := by + rw [StateT.run'_eq, ← probEvent_eq_eq_probOutput, + ← gameAfterSecretsWithViewTrace_verdictCache_projection adversary parameter otsSecret + ftsSecret, probEvent_map] + rw [probEvent_map] + rfl + _ ≤ Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache ∨ + ((¬Bad parameter otsSecret ftsSecret result.2.cache ∧ result.1.2.2 = true) ∧ + ViewedWinningTerminalWitness parameter otsSecret ftsSecret result) | run] := by + apply probEvent_mono + intro result hresult hwin + rcases gameAfterSecretsWithViewTrace_winning_terminal_classify adversary parameter + otsSecret ftsSecret result hresult hwin with hbad | hterminal + · exact Or.inl hbad + · by_cases hbad : Bad parameter otsSecret ftsSecret result.2.cache + · exact Or.inl hbad + · exact Or.inr ⟨⟨hbad, hwin⟩, hterminal⟩ + _ ≤ Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache | run] + + Pr[fun result => + (¬Bad parameter otsSecret ftsSecret result.2.cache ∧ result.1.2.2 = true) ∧ + ViewedWinningTerminalWitness parameter otsSecret ftsSecret result | run] := + probEvent_or_le _ _ _ + _ ≤ _ := by + gcongr + exact probEvent_winning_clean_viewedTerminalWitness_le parameter otsSecret ftsSecret run + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/TightCharge.lean b/formal/sphincs/SphincsSecurity/Proof/TightCharge.lean new file mode 100644 index 00000000..97899a86 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TightCharge.lean @@ -0,0 +1,269 @@ +import SphincsSecurity.Proof.Charge + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +theorem Position.depth_eq_of_mem_children {left right parent : Position} + (hl : left ∈ parent.children) (hr : right ∈ parent.children) : left.depth = right.depth := by + cases parent with + | chain lay tree leafIdx chainIdx step => + rw [Position.children] at hl hr + split at hl + · simp_all + · simp_all + | leaf lay tree leafIdx => + simp only [Position.children, List.mem_ofFn] at hl hr + obtain ⟨_, rfl⟩ := hl + obtain ⟨_, rfl⟩ := hr + rfl + | node lay tree level nodeIdx => + rw [Position.children] at hl hr + split at hl + · split at hl <;> simp_all <;> + rcases hl with rfl | rfl <;> rcases hr with rfl | rfl <;> rfl + · simp_all + | ftsLeaf => simp [Position.children] at hl + | ftsNode index tree level nodeIdx => + rw [Position.children] at hl hr + split at hl + · split at hl <;> simp_all <;> + rcases hl with rfl | rfl <;> rcases hr with rfl | rfl <;> rfl + · simp_all + | ftsRoots index => + simp only [Position.children, List.mem_ofFn] at hl hr + obtain ⟨_, rfl⟩ := hl + obtain ⟨_, rfl⟩ := hr + rfl + +variable (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + +theorem settled_of_cacheQuery_other_depth_le + {cache : QueryCache HashSpec} {input : HashInput} {answer : HashOutput} + {queried position : Position} (hfresh : cache input = none) + (hat : AtPosition parameter input queried) (hne : position ≠ queried) + (hdepth : position.depth ≤ queried.depth) + (hsettled : Settled parameter otsSecret ftsSecret (cache.cacheQuery input answer) position) : + Settled parameter otsSecret ftsSecret cache position := by + have hle : cache ≤ cache.cacheQuery input answer := le_cacheQuery hfresh + have hchildren : ∀ child ∈ position.children, Settled parameter otsSecret ftsSecret cache child := by + intro child hchild + exact settled_of_cacheQuery_below parameter otsSecret ftsSecret hfresh hat + (child.depth + 1) child (by omega) + (lt_of_lt_of_le (Position.depth_lt_of_mem_children hchild) hdepth) + (hsettled.children child hchild) + have hpinned := honestInput_congr (fromCache (cache.cacheQuery input answer)) (fromCache cache) + parameter otsSecret ftsSecret hsettled.valid (fun child hchild => + honestValue_eq_of_settled (agreesWithFn_fromCache_of_le hle) (hchildren child hchild)) + change cachedInput parameter otsSecret ftsSecret (cache.cacheQuery input answer) position = + cachedInput parameter otsSecret ftsSecret cache position at hpinned + have hinputne : cachedInput parameter otsSecret ftsSecret cache position ≠ input := + atPosition_ne parameter (atPosition_cachedInput parameter otsSecret ftsSecret cache position) hat hne + rw [settled_iff] + refine ⟨hsettled.valid, ?_, hchildren⟩ + have hcached := hsettled.cached + rw [hpinned, QueryCache.cacheQuery_of_ne _ _ hinputne] at hcached + exact hcached + +def OtherChildrenSettled (cache : QueryCache HashSpec) (child parent : Position) : Prop := + ∀ sibling ∈ parent.children, sibling ≠ child → Settled parameter otsSecret ftsSecret cache sibling + +theorem otherChildrenSettled_of_parent_settled_cacheQuery + {cache : QueryCache HashSpec} {input : HashInput} {answer : HashOutput} + {child parent : Position} (hfresh : cache input = none) + (hat : AtPosition parameter input child) (hchild : child ∈ parent.children) + (hparent : Settled parameter otsSecret ftsSecret (cache.cacheQuery input answer) parent) : + OtherChildrenSettled parameter otsSecret ftsSecret cache child parent := by + intro sibling hsibling hne + exact settled_of_cacheQuery_other_depth_le parameter otsSecret ftsSecret hfresh hat hne + (Position.depth_eq_of_mem_children hsibling hchild).le (hparent.children sibling hsibling) + +noncomputable def tightSettlingTargets (cache : QueryCache HashSpec) (hfinite : Finite cache) + (child : Position) : Finset Digest := + open Classical in + match child.parentOf with + | none => answerTargets parameter cache hfinite child + | some parent => answerTargets parameter cache hfinite child ∪ + if OtherChildrenSettled parameter otsSecret ftsSecret cache child parent then + slotTargets parameter cache hfinite child parent else ∅ + +noncomputable def tightContribution (cache : QueryCache HashSpec) (position : Position) : Nat := + open Classical in + if Settled parameter otsSecret ftsSecret cache position then 0 else + (cachedAt parameter cache position).ncard * + (1 + if ∀ child ∈ position.children, Settled parameter otsSecret ftsSecret cache child then 0 else 1) + +noncomputable def tightPotential (cache : QueryCache HashSpec) : Nat := + ∑ position : Position, tightContribution parameter otsSecret ftsSecret cache position + +theorem tightPotential_empty : + tightPotential parameter otsSecret ftsSecret (∅ : QueryCache HashSpec) = 0 := by + classical + apply Finset.sum_eq_zero + intro position _ + have hcached : cachedAt parameter (∅ : QueryCache HashSpec) position = ∅ := by + ext input + simp [cachedAt] + simp [tightContribution, hcached] + +theorem tightContribution_le_of_cachedAt_eq {cache cache' : QueryCache HashSpec} + (hle : cache ≤ cache') (position : Position) + (hcached : cachedAt parameter cache' position = cachedAt parameter cache position) : + tightContribution parameter otsSecret ftsSecret cache' position ≤ + tightContribution parameter otsSecret ftsSecret cache position := by + classical + by_cases hs : Settled parameter otsSecret ftsSecret cache position + · simp [tightContribution, hs, hs.mono hle] + · by_cases hs' : Settled parameter otsSecret ftsSecret cache' position + · simp [tightContribution, hs, hs'] + · by_cases hc : ∀ child ∈ position.children, Settled parameter otsSecret ftsSecret cache child + · have hc' : ∀ child ∈ position.children, Settled parameter otsSecret ftsSecret cache' child := + fun child hchild => (hc child hchild).mono hle + simp only [tightContribution, hs, hs', if_false, hcached] + rw [if_pos hc', if_pos hc] + · simp only [tightContribution, hs, hs', if_false, hcached] + rw [if_neg hc] + split_ifs <;> omega + +theorem tightContribution_add_cachedAt_le_of_settled {cache cache' : QueryCache HashSpec} + {position : Position} (hunsettled : ¬ Settled parameter otsSecret ftsSecret cache position) + (hsettled : Settled parameter otsSecret ftsSecret cache' position) : + tightContribution parameter otsSecret ftsSecret cache' position + + (cachedAt parameter cache position).ncard ≤ + tightContribution parameter otsSecret ftsSecret cache position := by + classical + simp only [tightContribution, hunsettled, hsettled, if_false, if_true, zero_add] + split_ifs <;> omega + +noncomputable def tightParentCharge (cache : QueryCache HashSpec) (child parent : Position) : Nat := + open Classical in + if OtherChildrenSettled parameter otsSecret ftsSecret cache child parent then + (cachedAt parameter cache parent).ncard else 0 + +theorem tightContribution_add_parentCharge_le {cache cache' : QueryCache HashSpec} + (hle : cache ≤ cache') {parent child : Position} (hmem : child ∈ parent.children) + (hunsettled : ¬ Settled parameter otsSecret ftsSecret cache child) + (hsettled : Settled parameter otsSecret ftsSecret cache' child) + (hcached : cachedAt parameter cache' parent = cachedAt parameter cache parent) : + tightContribution parameter otsSecret ftsSecret cache' parent + + tightParentCharge parameter otsSecret ftsSecret cache child parent ≤ + tightContribution parameter otsSecret ftsSecret cache parent := by + classical + by_cases hother : OtherChildrenSettled parameter otsSecret ftsSecret cache child parent + · have hbefore : ¬ ∀ sibling ∈ parent.children, Settled parameter otsSecret ftsSecret cache sibling := + fun h => hunsettled (h child hmem) + have hafter : ∀ sibling ∈ parent.children, Settled parameter otsSecret ftsSecret cache' sibling := by + intro sibling hsibling + by_cases heq : sibling = child + · simpa only [heq] using hsettled + · exact (hother sibling hsibling heq).mono hle + have hparent : ¬ Settled parameter otsSecret ftsSecret cache parent := + fun h => hunsettled (h.children child hmem) + rw [tightParentCharge, if_pos hother] + simp only [tightContribution, hparent, if_false] + rw [if_neg hbefore] + by_cases hparentAfter : Settled parameter otsSecret ftsSecret cache' parent + · rw [if_pos hparentAfter] + omega + · rw [if_neg hparentAfter, if_pos hafter, hcached] + omega + · rw [tightParentCharge, if_neg hother, Nat.add_zero] + exact tightContribution_le_of_cachedAt_eq parameter otsSecret ftsSecret hle parent hcached + +theorem tightSettlingTargets_card_le (cache : QueryCache HashSpec) (hfinite : Finite cache) + (child : Position) : + (tightSettlingTargets parameter otsSecret ftsSecret cache hfinite child).card ≤ + (cachedAt parameter cache child).ncard + + match child.parentOf with + | none => 0 + | some parent => tightParentCharge parameter otsSecret ftsSecret cache child parent := by + classical + rw [tightSettlingTargets] + split + · simpa using answerTargets_card_le parameter cache hfinite child + · rename_i parent hparent + by_cases hother : OtherChildrenSettled parameter otsSecret ftsSecret cache child parent + · simp only [hother, if_true, tightParentCharge] + exact (Finset.card_union_le _ _).trans (Nat.add_le_add + (answerTargets_card_le parameter cache hfinite child) + (slotTargets_card_le parameter cache hfinite child parent)) + · simp only [hother, if_false, tightParentCharge, Finset.union_empty, Nat.add_zero] + exact answerTargets_card_le parameter cache hfinite child + +theorem clean_cacheQuery_of_settling_of_avoids_tight {cache : QueryCache HashSpec} + (hfinite : Finite cache) {input₀ : HashInput} {answer : HashOutput} {p₀ : Position} + (hclean : ¬ Bad parameter otsSecret ftsSecret cache) (huncached : cache input₀ = none) + (hposition : AtPosition parameter input₀ p₀) + (hunsettled : ¬ Settled parameter otsSecret ftsSecret cache p₀) + (hsettled : Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p₀) + (havoid : truncateHash answer ∉ tightSettlingTargets parameter otsSecret ftsSecret cache hfinite p₀) : + ¬ Bad parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) := by + have hle : cache ≤ cache.cacheQuery input₀ answer := le_cacheQuery huncached + obtain ⟨hinput₀, hchildren⟩ := eq_cachedInput_and_children_of_settled_cacheQuery + parameter otsSecret ftsSecret huncached hposition hunsettled hsettled + have hvalues : ∀ c ∈ p₀.children, + honestValue (fromCache (cache.cacheQuery input₀ answer)) parameter otsSecret ftsSecret c + = honestValue (fromCache cache) parameter otsSecret ftsSecret c := fun c hc => + honestValue_eq_of_settled (agreesWithFn_fromCache_of_le hle) (hchildren c hc) + have hpinned₀ : cachedInput parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p₀ + = cachedInput parameter otsSecret ftsSecret cache p₀ := + honestInput_congr _ _ parameter otsSecret ftsSecret hsettled.valid hvalues + have hinputNew : cachedInput parameter otsSecret ftsSecret + (cache.cacheQuery input₀ answer) p₀ = input₀ := hpinned₀.trans hinput₀.symm + have hparentClean : ∀ q parent, some p₀ = some q → q.parentOf = some parent → + ¬ Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) parent := by + intro q parent hq hparent + rw [Option.some.injEq] at hq + subst hq + have hmem : p₀ ∈ parent.children := Position.mem_children_iff.mpr hparent + by_cases hother : OtherChildrenSettled parameter otsSecret ftsSecret cache p₀ parent + · have hslotAvoid : truncateHash answer ∉ slotTargets parameter cache hfinite p₀ parent := by + intro hmemTarget + apply havoid + simp [tightSettlingTargets, hparent, hother, hmemTarget] + exact not_settled_parent_of_avoids_slotTargets parameter otsSecret ftsSecret hfinite + huncached hposition hunsettled hsettled hmem hslotAvoid + · intro hparentSettled + exact hother (otherChildrenSettled_of_parent_settled_cacheQuery parameter otsSecret ftsSecret + huncached hposition hmem hparentSettled) + rintro ⟨p, hsettled', input, ax, ay, hat, hne, hinput, hhonest, heq⟩ + by_cases hp : p = p₀ + · subst hp + have hinputne : input ≠ input₀ := by rwa [hinputNew] at hne + have hinputOld : cache input = some ax := by + rwa [QueryCache.cacheQuery_of_ne _ _ hinputne] at hinput + have hcachedAt : input ∈ cachedAt parameter cache p := + ⟨by simp [hinputOld], hat⟩ + have htarget : truncateHash ax ∈ answerTargets parameter cache hfinite p := by + simpa [hinputOld] using mem_answerTargets parameter hfinite hcachedAt + rw [hinputNew, QueryCache.cacheQuery_self] at hhonest + have hanswer : answer = ay := Option.some.inj hhonest + apply havoid + have heqAnswer : truncateHash answer = truncateHash ax := by rw [hanswer, ← heq] + rw [heqAnswer] + rw [tightSettlingTargets] + split + · exact htarget + · exact Finset.mem_union_left _ htarget + · have hsettledOld : Settled parameter otsSecret ftsSecret cache p := + settled_of_settled_cacheQuery parameter otsSecret ftsSecret huncached + (p₀ := some p₀) (fun q hq => by + rw [atPosition_unique parameter hposition hq]) hparentClean + (p.depth + 1) p (by omega) (by + intro heq + exact hp (Option.some.inj heq).symm) hsettled' + have hpinned := cachedInput_eq_of_settled hle hsettledOld + have hinputne : input ≠ input₀ := atPosition_ne parameter hat hposition hp + have hhonestne : cachedInput parameter otsSecret ftsSecret cache p ≠ input₀ := + atPosition_ne parameter (atPosition_cachedInput parameter otsSecret ftsSecret cache p) + hposition hp + have hinputOld : cache input = some ax := by + rwa [QueryCache.cacheQuery_of_ne _ _ hinputne] at hinput + rw [hpinned, QueryCache.cacheQuery_of_ne _ _ hhonestne] at hhonest + apply hclean + refine ⟨p, hsettledOld, input, ax, ay, hat, ?_, hinputOld, hhonest, heq⟩ + rwa [hpinned] at hne + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/TightChargePotential.lean b/formal/sphincs/SphincsSecurity/Proof/TightChargePotential.lean new file mode 100644 index 00000000..03f2c956 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TightChargePotential.lean @@ -0,0 +1,175 @@ +import SphincsSecurity.Proof.TightCharge + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +variable (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + +theorem tightPotential_add_settlingTargets_card_le {cache : QueryCache HashSpec} + (hfinite : Finite cache) {input₀ : HashInput} {answer : HashOutput} {p₀ : Position} + (huncached : cache input₀ = none) (hposition : AtPosition parameter input₀ p₀) + (hunsettled : ¬ Settled parameter otsSecret ftsSecret cache p₀) + (hsettled : Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p₀) : + tightPotential parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) + + (tightSettlingTargets parameter otsSecret ftsSecret cache hfinite p₀).card + ≤ tightPotential parameter otsSecret ftsSecret cache := by + classical + let cache' := cache.cacheQuery input₀ answer + have hle : cache ≤ cache' := le_cacheQuery huncached + have hrelease₀ : tightContribution parameter otsSecret ftsSecret cache' p₀ + + (cachedAt parameter cache p₀).ncard + ≤ tightContribution parameter otsSecret ftsSecret cache p₀ := + tightContribution_add_cachedAt_le_of_settled parameter otsSecret ftsSecret hunsettled + hsettled + have hcard := tightSettlingTargets_card_le parameter otsSecret ftsSecret cache hfinite p₀ + cases hparent : p₀.parentOf with + | none => + simp only [hparent] at hcard + have hsum : ∑ p : Position, (tightContribution parameter otsSecret ftsSecret cache' p + + if p = p₀ then (cachedAt parameter cache p₀).ncard else 0) + ≤ ∑ p : Position, tightContribution parameter otsSecret ftsSecret cache p := by + refine Finset.sum_le_sum fun p _ => ?_ + by_cases hp : p = p₀ + · subst hp + simpa using hrelease₀ + · simp only [hp, if_false, Nat.add_zero] + have hnotAt : ¬ AtPosition parameter input₀ p := by + intro hat + exact hp (atPosition_unique parameter hat hposition) + exact tightContribution_le_of_cachedAt_eq parameter otsSecret ftsSecret hle p + (cachedAt_cacheQuery_of_not_atPosition parameter hnotAt) + rw [Finset.sum_add_distrib, Finset.sum_ite_eq'] at hsum + simp only [Finset.mem_univ, if_true] at hsum + change tightPotential parameter otsSecret ftsSecret cache' + + (tightSettlingTargets parameter otsSecret ftsSecret cache hfinite p₀).card + ≤ tightPotential parameter otsSecret ftsSecret cache + rw [tightPotential, tightPotential] + omega + | some parent => + have hmem : p₀ ∈ parent.children := Position.mem_children_iff.mpr hparent + have hpne : parent ≠ p₀ := by + intro heq + subst heq + have := Position.depth_lt_of_mem_children hmem + omega + have hcachedAt : cachedAt parameter cache' parent = cachedAt parameter cache parent := + cachedAt_cacheQuery_of_not_atPosition parameter (by + intro hat + exact hpne (atPosition_unique parameter hat hposition)) + have hreleaseParent : tightContribution parameter otsSecret ftsSecret cache' parent + + tightParentCharge parameter otsSecret ftsSecret cache p₀ parent + ≤ tightContribution parameter otsSecret ftsSecret cache parent := + tightContribution_add_parentCharge_le parameter otsSecret ftsSecret hle hmem + hunsettled hsettled hcachedAt + simp only [hparent] at hcard + have hsum : ∑ p : Position, ((tightContribution parameter otsSecret ftsSecret cache' p + + if p = p₀ then (cachedAt parameter cache p₀).ncard else 0) + + if p = parent then tightParentCharge parameter otsSecret ftsSecret cache p₀ parent else 0) + ≤ ∑ p : Position, tightContribution parameter otsSecret ftsSecret cache p := by + refine Finset.sum_le_sum fun p _ => ?_ + by_cases hq : p = p₀ + · subst hq + simp only [if_pos, hpne.symm, if_false, Nat.add_zero] + exact hrelease₀ + · by_cases hp : p = parent + · subst hp + simp only [hpne, if_false, if_pos, Nat.add_zero] + exact hreleaseParent + · simp only [hq, hp, if_false, Nat.add_zero] + have hnotAt : ¬ AtPosition parameter input₀ p := by + intro hat + exact hq (atPosition_unique parameter hat hposition) + exact tightContribution_le_of_cachedAt_eq parameter otsSecret ftsSecret hle p + (cachedAt_cacheQuery_of_not_atPosition parameter hnotAt) + rw [Finset.sum_add_distrib, Finset.sum_add_distrib, Finset.sum_ite_eq', + Finset.sum_ite_eq'] at hsum + simp only [Finset.mem_univ, if_true] at hsum + change tightPotential parameter otsSecret ftsSecret cache' + + (tightSettlingTargets parameter otsSecret ftsSecret cache hfinite p₀).card + ≤ tightPotential parameter otsSecret ftsSecret cache + rw [tightPotential, tightPotential] + omega + +theorem tightPotential_cacheQuery_le_of_unsettled + {cache : QueryCache HashSpec} {input : HashInput} {answer : HashOutput} {queried : Position} + (hfresh : cache input = none) (hat : AtPosition parameter input queried) + (hunsettled : ¬ Settled parameter otsSecret ftsSecret (cache.cacheQuery input answer) queried) : + tightPotential parameter otsSecret ftsSecret (cache.cacheQuery input answer) ≤ + tightPotential parameter otsSecret ftsSecret cache + 2 := by + classical + let cache' := cache.cacheQuery input answer + have hle : cache ≤ cache' := le_cacheQuery hfresh + have hunsettledBefore : ¬ Settled parameter otsSecret ftsSecret cache queried := + fun h => hunsettled (h.mono hle) + have hcard : (cachedAt parameter cache' queried).ncard ≤ (cachedAt parameter cache queried).ncard + 1 := by + rw [show cachedAt parameter cache' queried = insert input (cachedAt parameter cache queried) from + cachedAt_cacheQuery_self parameter hat] + exact Set.ncard_insert_le _ _ + have hlocal : tightContribution parameter otsSecret ftsSecret cache' queried ≤ + tightContribution parameter otsSecret ftsSecret cache queried + 2 := by + change ¬ Settled parameter otsSecret ftsSecret cache' queried at hunsettled + simp only [tightContribution, hunsettled, hunsettledBefore, if_false] + by_cases hc : ∀ child ∈ queried.children, Settled parameter otsSecret ftsSecret cache child + · have hc' : ∀ child ∈ queried.children, Settled parameter otsSecret ftsSecret cache' child := + fun child hchild => (hc child hchild).mono hle + rw [if_pos hc', if_pos hc] + omega + · rw [if_neg hc] + split_ifs <;> omega + calc + _ ≤ ∑ position : Position, + (tightContribution parameter otsSecret ftsSecret cache position + + if position = queried then 2 else 0) := by + apply Finset.sum_le_sum + intro position _ + by_cases heq : position = queried + · simpa only [heq, if_true] using hlocal + · simp only [heq, if_false, Nat.add_zero] + exact tightContribution_le_of_cachedAt_eq parameter otsSecret ftsSecret hle position + (cachedAt_cacheQuery_of_not_atPosition parameter (fun h => + heq (atPosition_unique parameter h hat))) + _ = _ := by + rw [Finset.sum_add_distrib, Finset.sum_ite_eq'] + simp only [Finset.mem_univ, if_true] + rfl + +theorem tightPotential_cacheQuery_le_of_settled {cache : QueryCache HashSpec} {input₀ : HashInput} + {answer : HashOutput} {p₀ : Position} (huncached : cache input₀ = none) + (hposition : AtPosition parameter input₀ p₀) + (hsettled : Settled parameter otsSecret ftsSecret cache p₀) : + tightPotential parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) + ≤ tightPotential parameter otsSecret ftsSecret cache := by + classical + have hle : cache ≤ cache.cacheQuery input₀ answer := le_cacheQuery huncached + have hsettled' : Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p₀ := + hsettled.mono hle + rw [tightPotential, tightPotential] + refine Finset.sum_le_sum fun p _ => ?_ + by_cases hp : p = p₀ + · subst hp + simp [tightContribution, hsettled, hsettled'] + · have hnotAt : ¬ AtPosition parameter input₀ p := by + intro hat + exact hp (atPosition_unique parameter hat hposition) + exact tightContribution_le_of_cachedAt_eq parameter otsSecret ftsSecret hle p + (cachedAt_cacheQuery_of_not_atPosition parameter hnotAt) + +theorem clean_and_tightPotential_cacheQuery_of_not_atPosition + {cache : QueryCache HashSpec} {input : HashInput} {answer : HashOutput} + (hclean : ¬ Bad parameter otsSecret ftsSecret cache) (hfresh : cache input = none) + (hnotAt : ∀ position, ¬ AtPosition parameter input position) : + ¬ Bad parameter otsSecret ftsSecret (cache.cacheQuery input answer) ∧ + tightPotential parameter otsSecret ftsSecret (cache.cacheQuery input answer) ≤ + tightPotential parameter otsSecret ftsSecret cache := by + constructor + · exact (clean_and_potential_cacheQuery_of_not_atPosition parameter otsSecret ftsSecret + hclean hfresh hnotAt).1 + · apply Finset.sum_le_sum + intro position _ + exact tightContribution_le_of_cachedAt_eq parameter otsSecret ftsSecret (le_cacheQuery hfresh) + position (cachedAt_cacheQuery_of_not_atPosition parameter (hnotAt position)) + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/TightChargeStep.lean b/formal/sphincs/SphincsSecurity/Proof/TightChargeStep.lean new file mode 100644 index 00000000..7896924c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TightChargeStep.lean @@ -0,0 +1,211 @@ +import SphincsSecurity.Proof.Amortized +import SphincsSecurity.Proof.TightChargePotential +import SphincsSecurity.Proof.Guess +import SphincsSecurity.Proof.Secrets + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +attribute [local irreducible] tightPotential + +variable (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + +private theorem growth_empty (n : Nat) : + (n + 2) + (∅ : Finset Digest).card ≤ n + 2 := by + simp + +private theorem empty_growth (n : Nat) : n + (∅ : Finset Digest).card ≤ n + 2 := by + norm_num + +private theorem singleton_card_le (n : Nat) (target : Digest) : + ({target} : Finset Digest).card ≤ n + 2 := by + simp only [Finset.card_singleton] + omega + +private theorem singleton_growth (n : Nat) (target : Digest) : + n + ({target} : Finset Digest).card ≤ n + 2 := by + simp only [Finset.card_singleton] + omega + +/-- The target set and both obligations needed by `Amortized.probEvent_bad_le_amortized`. -/ +inductive TightStep (cache : QueryCache HashSpec) (input₀ : HashInput) : Prop where + | intro (targets : Finset Digest) + (card_le : targets.card ≤ tightPotential parameter otsSecret ftsSecret cache + 2) + (safe : ∀ answer : HashOutput, truncateHash answer ∉ targets → + ¬ Bad parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) + ∧ tightPotential parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) + targets.card + ≤ tightPotential parameter otsSecret ftsSecret cache + 2) : TightStep cache input₀ + +private theorem step_of_unsettled_after {cache : QueryCache HashSpec} {input₀ : HashInput} + {p₀ : Position} (hclean : ¬ Bad parameter otsSecret ftsSecret cache) + (huncached : cache input₀ = none) (hposition : AtPosition parameter input₀ p₀) + (hunsettled : ∀ answer : HashOutput, + ¬ Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p₀) : + TightStep parameter otsSecret ftsSecret cache input₀ := by + refine TightStep.intro (parameter := parameter) (otsSecret := otsSecret) (ftsSecret := ftsSecret) + (cache := cache) (input₀ := input₀) ∅ (Nat.zero_le _) (fun answer _ => ?_) + have hunsettled' := hunsettled answer + refine ⟨clean_cacheQuery_of_unsettled parameter otsSecret ftsSecret hclean + (cache := cache) (input₀ := input₀) (answer := answer) (p₀ := p₀) + huncached hposition hunsettled', ?_⟩ + have htightPotential := tightPotential_cacheQuery_le_of_unsettled parameter otsSecret ftsSecret + (cache := cache) (input := input₀) (answer := answer) (queried := p₀) + huncached hposition hunsettled' + exact (Nat.add_le_add htightPotential (Nat.le_refl _)).trans + (growth_empty (tightPotential parameter otsSecret ftsSecret cache)) + +private theorem step_of_settling {cache : QueryCache HashSpec} (hfinite : Finite cache) + {input₀ : HashInput} {p₀ : Position} + (hclean : ¬ Bad parameter otsSecret ftsSecret cache) (huncached : cache input₀ = none) + (hposition : AtPosition parameter input₀ p₀) + (hsettled : ¬ Settled parameter otsSecret ftsSecret cache p₀) + (hsettles : ∀ answer : HashOutput, + Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) p₀) : + TightStep parameter otsSecret ftsSecret cache input₀ := by + have hpaid := tightPotential_add_settlingTargets_card_le parameter otsSecret ftsSecret + (cache := cache) hfinite (input₀ := input₀) (answer := 0) (p₀ := p₀) + huncached hposition hsettled (hsettles 0) + have hcardBase : (tightSettlingTargets parameter otsSecret ftsSecret cache hfinite p₀).card + ≤ tightPotential parameter otsSecret ftsSecret cache := + (Nat.le_add_left (tightSettlingTargets parameter otsSecret ftsSecret cache hfinite p₀).card + (tightPotential parameter otsSecret ftsSecret (cache.cacheQuery input₀ 0))).trans hpaid + have hcard := hcardBase.trans + (Nat.le_add_right (tightPotential parameter otsSecret ftsSecret cache) 2) + refine TightStep.intro (parameter := parameter) (otsSecret := otsSecret) (ftsSecret := ftsSecret) + (cache := cache) (input₀ := input₀) (tightSettlingTargets parameter otsSecret ftsSecret cache hfinite p₀) hcard + (fun answer hanswer => ?_) + have hsettled' := hsettles answer + refine ⟨clean_cacheQuery_of_settling_of_avoids_tight parameter otsSecret ftsSecret + hfinite hclean huncached hposition hsettled hsettled' hanswer, ?_⟩ + exact (tightPotential_add_settlingTargets_card_le parameter otsSecret ftsSecret + (cache := cache) hfinite (input₀ := input₀) (answer := answer) (p₀ := p₀) + huncached hposition hsettled hsettled').trans + (Nat.le_add_right (tightPotential parameter otsSecret ftsSecret cache) 2) + +private theorem step_at_unsettled {cache : QueryCache HashSpec} (hfinite : Finite cache) + {input₀ : HashInput} {p₀ : Position} + (hclean : ¬ Bad parameter otsSecret ftsSecret cache) (huncached : cache input₀ = none) + (hposition : AtPosition parameter input₀ p₀) + (hsettled : ¬ Settled parameter otsSecret ftsSecret cache p₀) : + TightStep parameter otsSecret ftsSecret cache input₀ := by + by_cases hinput : input₀ = cachedInput parameter otsSecret ftsSecret cache p₀ + · by_cases hvalid : p₀.Valid + · by_cases hchildren : ∀ c ∈ p₀.children, Settled parameter otsSecret ftsSecret cache c + · apply step_of_settling parameter otsSecret ftsSecret hfinite hclean huncached + hposition hsettled + intro answer + have hle := le_cacheQuery (cache := cache) (input := input₀) (answer := answer) huncached + have hchildren' : ∀ c ∈ p₀.children, + Settled parameter otsSecret ftsSecret (cache.cacheQuery input₀ answer) c := + fun c hc => (hchildren c hc).mono hle + have hvalues : ∀ c ∈ p₀.children, + honestValue (fromCache (cache.cacheQuery input₀ answer)) parameter otsSecret ftsSecret c + = honestValue (fromCache cache) parameter otsSecret ftsSecret c := fun c hc => + honestValue_eq_of_settled (agreesWithFn_fromCache_of_le hle) (hchildren c hc) + have hpinned : cachedInput parameter otsSecret ftsSecret + (cache.cacheQuery input₀ answer) p₀ + = cachedInput parameter otsSecret ftsSecret cache p₀ := + honestInput_congr _ _ parameter otsSecret ftsSecret hvalid hvalues + rw [settled_iff] + refine ⟨hvalid, ?_, hchildren'⟩ + rw [hpinned, ← hinput, QueryCache.cacheQuery_self] + simp + · apply step_of_unsettled_after parameter otsSecret ftsSecret hclean huncached hposition + intro answer hsettled' + exact hchildren (eq_cachedInput_and_children_of_settled_cacheQuery + parameter otsSecret ftsSecret huncached hposition hsettled hsettled').2 + · apply step_of_unsettled_after parameter otsSecret ftsSecret hclean huncached hposition + exact fun _ hs => hvalid hs.valid + · apply step_of_unsettled_after parameter otsSecret ftsSecret hclean huncached hposition + intro answer hsettled' + exact hinput (eq_cachedInput_and_children_of_settled_cacheQuery + parameter otsSecret ftsSecret huncached hposition hsettled hsettled').1 + +private theorem step_at_position {cache : QueryCache HashSpec} (hfinite : Finite cache) + {input₀ : HashInput} {p₀ : Position} + (hclean : ¬ Bad parameter otsSecret ftsSecret cache) (huncached : cache input₀ = none) + (hposition : AtPosition parameter input₀ p₀) : + TightStep parameter otsSecret ftsSecret cache input₀ := by + by_cases hsettled : Settled parameter otsSecret ftsSecret cache p₀ + · let target := honestValue (fromCache cache) parameter otsSecret ftsSecret p₀ + refine TightStep.intro (parameter := parameter) (otsSecret := otsSecret) (ftsSecret := ftsSecret) + (cache := cache) (input₀ := input₀) {target} + (singleton_card_le (tightPotential parameter otsSecret ftsSecret cache) target) + (fun answer hanswer => ?_) + have havoid : truncateHash answer ≠ target := by simpa [target] using hanswer + refine ⟨clean_cacheQuery_of_settled_of_avoids parameter otsSecret ftsSecret hclean + huncached hposition hsettled havoid, ?_⟩ + have htightPotential := tightPotential_cacheQuery_le_of_settled parameter otsSecret ftsSecret + (cache := cache) (input₀ := input₀) (answer := answer) (p₀ := p₀) + huncached hposition hsettled + exact (Nat.add_le_add htightPotential (Nat.le_refl _)).trans + (singleton_growth (tightPotential parameter otsSecret ftsSecret cache) target) + · exact step_at_unsettled parameter otsSecret ftsSecret hfinite hclean huncached + hposition hsettled + +/-- **The per-query charge.** A fresh answer is dangerous only inside targets paid for by the +current tightPotential and `2` new units. -/ +theorem tight_bad_step (cache : QueryCache HashSpec) (hfinite : Finite cache) + (hclean : ¬ Bad parameter otsSecret ftsSecret cache) (input₀ : HashInput) + (huncached : cache input₀ = none) : TightStep parameter otsSecret ftsSecret cache input₀ := by + classical + by_cases hAt : ∃ p, AtPosition parameter input₀ p + · obtain ⟨p₀, hposition⟩ := hAt + exact step_at_position parameter otsSecret ftsSecret hfinite hclean huncached hposition + · refine TightStep.intro (parameter := parameter) (otsSecret := otsSecret) (ftsSecret := ftsSecret) + (cache := cache) (input₀ := input₀) ∅ (Nat.zero_le _) (fun answer _ => ?_) + obtain ⟨hclean', htightPotential⟩ := clean_and_tightPotential_cacheQuery_of_not_atPosition + parameter otsSecret ftsSecret hclean huncached (fun p hp => hAt ⟨p, hp⟩) + refine ⟨hclean', ?_⟩ + exact (Nat.add_le_add htightPotential (Nat.le_refl _)).trans + (empty_growth (tightPotential parameter otsSecret ftsSecret cache)) + +/-- **The amortized bad-event bound.** A `q`-query computation makes `Bad` true with probability at +most `(2q + tightPotential) / 2^128`. -/ +theorem probEvent_bad_le_tight {α : Type} (oa : OracleComp OracleWorld α) (q : Nat) + (hq : oa.IsQueryBoundP (· matches Sum.inr _) q) (cache : QueryCache HashSpec) + (hfinite : Finite cache) (hclean : ¬ Bad parameter otsSecret ftsSecret cache) : + Pr[fun result => Bad parameter otsSecret ftsSecret result.2 + | (simulateQ romImpl oa).run cache] + ≤ ((2 * q + tightPotential parameter otsSecret ftsSecret cache : Nat) : ℝ≥0∞) + * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + apply probEvent_bad_le_amortized + (Bad := Bad parameter otsSecret ftsSecret) (Inv := Finite) + (potential := tightPotential parameter otsSecret ftsSecret) (c := 2) + · intro target + rw [← probOutput_map] + exact probOutput_truncateHash_le target + · intro cache' input answer hfinite' + exact finite_cacheQuery hfinite' input answer + · intro cache' hfinite' hclean' input huncached + rcases tight_bad_step parameter otsSecret ftsSecret cache' hfinite' hclean' input huncached with + ⟨targets, hcard, hsafe⟩ + exact ⟨targets, hcard, hsafe⟩ + · exact hq + · exact hfinite + · exact hclean + +namespace Concrete + +/-- The accounted SPHINCS run starts clean with zero tightPotential, so its structural-hit probability is +at most `2q / 2^128`. -/ +theorem probEvent_bad_gameAfterSecrets_le_two_mul (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : (gameAfterSecrets adversary parameter otsSecret ftsSecret).IsQueryBoundP + (· matches Sum.inr _) q) : + Pr[fun result => Bad parameter otsSecret ftsSecret result.2 + | (simulateQ romImpl (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅] + ≤ ((2 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + have hbound := probEvent_bad_le_tight parameter otsSecret ftsSecret + (gameAfterSecrets adversary parameter otsSecret ftsSecret) q hq ∅ + finite_empty (not_bad_empty parameter otsSecret ftsSecret) + rw [tightPotential_empty, Nat.add_zero] at hbound + exact hbound + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/TightChargeTerminal.lean b/formal/sphincs/SphincsSecurity/Proof/TightChargeTerminal.lean new file mode 100644 index 00000000..dd5a64b6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TightChargeTerminal.lean @@ -0,0 +1,31 @@ +import SphincsSecurity.Proof.TightChargeStep +import SphincsSecurity.Proof.TerminalView + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem probEvent_bad_gameAfterSecretsWithViewTrace_le_two_mul (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hq : (gameAfterSecrets adversary parameter otsSecret ftsSecret).IsQueryBoundP + (· matches Sum.inr _) q) : + Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + ((2 * q : Nat) : ℝ≥0∞) * ((2 ^ digestBits : Nat) : ℝ≥0∞)⁻¹ := by + calc + _ = Pr[fun result : Bool × QueryCache HashSpec => + Bad parameter otsSecret ftsSecret result.2 | + (fun result => (result.1.2.2, result.2.cache)) <$> + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + rw [probEvent_map] + rfl + _ = Pr[fun result => Bad parameter otsSecret ftsSecret result.2 | + (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅] := by + rw [gameAfterSecretsWithViewTrace_verdictCache_projection] + _ ≤ _ := probEvent_bad_gameAfterSecrets_le_two_mul adversary parameter otsSecret ftsSecret q hq + + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/TightEncodingChildrenCharge.lean b/formal/sphincs/SphincsSecurity/Proof/TightEncodingChildrenCharge.lean new file mode 100644 index 00000000..f4439825 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TightEncodingChildrenCharge.lean @@ -0,0 +1,152 @@ +import SphincsSecurity.Proof.TightEncodingQueryCharge + +namespace SphincsSecurity + +open OracleComp OracleSpec ENNReal + +variable (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + +theorem settled_cacheQuery_of_settled_cacheQuery + {cache : QueryCache HashSpec} {input : HashInput} {answer : HashOutput} {position : Position} + (hfresh : cache input = none) (hat : AtPosition parameter input position) + (hunsettled : ¬ Settled parameter otsSecret ftsSecret cache position) + (hsettled : Settled parameter otsSecret ftsSecret (cache.cacheQuery input answer) position) + (otherAnswer : HashOutput) : + Settled parameter otsSecret ftsSecret (cache.cacheQuery input otherAnswer) position := by + obtain ⟨hinput, hchildren⟩ := eq_cachedInput_and_children_of_settled_cacheQuery + parameter otsSecret ftsSecret hfresh hat hunsettled hsettled + have hle := le_cacheQuery (cache := cache) (input := input) (answer := otherAnswer) hfresh + have hvalues : ∀ child ∈ position.children, + honestValue (fromCache (cache.cacheQuery input otherAnswer)) parameter otsSecret ftsSecret child = + honestValue (fromCache cache) parameter otsSecret ftsSecret child := + fun child hchild => honestValue_eq_of_settled (agreesWithFn_fromCache_of_le hle) + (hchildren child hchild) + have hpinned : cachedInput parameter otsSecret ftsSecret (cache.cacheQuery input otherAnswer) position = + cachedInput parameter otsSecret ftsSecret cache position := + honestInput_congr _ _ parameter otsSecret ftsSecret hsettled.valid hvalues + rw [settled_iff] + refine ⟨hsettled.valid, ?_, fun child hchild => (hchildren child hchild).mono hle⟩ + rw [hpinned, ← hinput, QueryCache.cacheQuery_self] + simp + +theorem tightPotential_cacheQuery_le_one_of_children_settled + {cache : QueryCache HashSpec} {input : HashInput} {answer : HashOutput} {position : Position} + (hfresh : cache input = none) (hat : AtPosition parameter input position) + (hchildren : ∀ child ∈ position.children, Settled parameter otsSecret ftsSecret cache child) + (hunsettled : ¬ Settled parameter otsSecret ftsSecret (cache.cacheQuery input answer) position) : + tightPotential parameter otsSecret ftsSecret (cache.cacheQuery input answer) ≤ + tightPotential parameter otsSecret ftsSecret cache + 1 := by + classical + have hle := le_cacheQuery (cache := cache) (input := input) (answer := answer) hfresh + have hbefore : ¬ Settled parameter otsSecret ftsSecret cache position := fun h => hunsettled (h.mono hle) + have hchildrenAfter : ∀ child ∈ position.children, + Settled parameter otsSecret ftsSecret (cache.cacheQuery input answer) child := + fun child hchild => (hchildren child hchild).mono hle + have hlocal : tightContribution parameter otsSecret ftsSecret (cache.cacheQuery input answer) position ≤ + tightContribution parameter otsSecret ftsSecret cache position + 1 := by + rw [tightContribution, if_neg hunsettled, if_pos hchildrenAfter, + tightContribution, if_neg hbefore, if_pos hchildren] + simp only [Nat.add_zero, Nat.mul_one] + rw [cachedAt_cacheQuery_self parameter hat] + exact Set.ncard_insert_le _ _ + calc + _ ≤ ∑ candidate : Position, (tightContribution parameter otsSecret ftsSecret cache candidate + + if candidate = position then 1 else 0) := by + apply Finset.sum_le_sum + intro candidate _ + by_cases heq : candidate = position + · rw [heq, if_pos rfl] + exact hlocal + · rw [if_neg heq, Nat.add_zero] + exact tightContribution_le_of_cachedAt_eq parameter otsSecret ftsSecret hle candidate + (cachedAt_cacheQuery_of_not_atPosition parameter + (fun hc => heq (atPosition_unique parameter hc hat))) + _ = _ := by + rw [Finset.sum_add_distrib, Fintype.sum_ite_eq'] + rfl + +end SphincsSecurity + +namespace SphincsSecurity.Concrete.TightEncoding + +open OracleComp OracleSpec ENNReal + +theorem encodingSelectionTotalPotential_cacheQuery_le_one_of_children_settled + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} {position : Position} + (hfresh : cache input = none) (hat : AtPosition secretKey.parameter input position) + (hchildren : ∀ child ∈ position.children, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache child) + (hunsettled : ¬ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) position) : + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey ≤ + encodingSelectionTotalPotential cache hfinite secretKey + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + have hnotEncoding : ∀ candidate : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input candidate := + fun _ hencoding => hencoding.not_atPosition position hat + by_cases hbad : Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + · have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = 1 := by + rw [encodingSelectionTotalPotential, if_pos hbad] + rw [hbefore] + exact (encodingSelectionTotalPotential_le_one _ secretKey).trans (le_add_right le_rfl) + · have hclean := clean_cacheQuery_of_unsettled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret hbad hfresh hat hunsettled + have hstructural := tightPotential_cacheQuery_le_one_of_children_settled secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret hfresh hat hchildren hunsettled + have hstage := encodingStagePotential_cacheQuery_le_of_not_atEncoding + (secretKey := secretKey) (answer := answer) hfresh hnotEncoding + have hselection := encodingSelectionPotential_cacheQuery_le_of_no_new_messages + (answer := answer) hfinite hfresh hnotEncoding + (fun candidate hafter => hafter.of_cacheQuery_of_at_unsettledAfter hfresh hat hunsettled) + have hsum : encodingStructuralPotential (cache.cacheQuery input answer) secretKey ≤ + encodingStructuralPotential cache secretKey + 1 := by + dsimp only [encodingStructuralPotential] + omega + let eps := (Fintype.card Digest : ℝ≥0∞)⁻¹ + let before := (encodingStructuralPotential cache secretKey : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey + by_cases hone : 1 ≤ before + · have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = 1 := by + rw [encodingSelectionTotalPotential, if_neg hbad, min_eq_left hone] + rw [hbefore] + exact (encodingSelectionTotalPotential_le_one _ secretKey).trans (le_add_right le_rfl) + · have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = before := by + rw [encodingSelectionTotalPotential, if_neg hbad, min_eq_right (le_of_not_ge hone)] + rw [hbefore] + calc + _ ≤ (encodingStructuralPotential (cache.cacheQuery input answer) secretKey : ℝ≥0∞) * eps + + encodingSelectionPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey := + encodingSelectionTotalPotential_le_uncapped _ secretKey hclean + _ ≤ ((encodingStructuralPotential cache secretKey + 1 : Nat) : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey := + add_le_add (mul_le_mul' (Nat.cast_le.mpr hsum) le_rfl) hselection + _ = before + eps := by + simp only [Nat.cast_add, Nat.cast_one, before] + ring + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_le_one_of_children_settled + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {position : Position} + (hfresh : cache input = none) (hat : AtPosition secretKey.parameter input position) + (hchildren : ∀ child ∈ position.children, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache child) + (hunsettled : ∀ answer : HashOutput, + ¬ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) position) : + (∑' answer : HashOutput, Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ + encodingSelectionTotalPotential cache hfinite secretKey + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + calc + _ ≤ ∑' answer : HashOutput, Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (encodingSelectionTotalPotential cache hfinite secretKey + (Fintype.card Digest : ℝ≥0∞)⁻¹) := + ENNReal.tsum_le_tsum fun answer => mul_le_mul' le_rfl + (encodingSelectionTotalPotential_cacheQuery_le_one_of_children_settled + hfinite hfresh hat hchildren (hunsettled answer)) + _ = _ := by rw [ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul] + +end SphincsSecurity.Concrete.TightEncoding diff --git a/formal/sphincs/SphincsSecurity/Proof/TightEncodingPrehitCharge.lean b/formal/sphincs/SphincsSecurity/Proof/TightEncodingPrehitCharge.lean new file mode 100644 index 00000000..fa21ad26 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TightEncodingPrehitCharge.lean @@ -0,0 +1,44 @@ +import SphincsSecurity.Proof.TightEncodingRefinedBound + +namespace SphincsSecurity.Concrete.TightEncoding + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +theorem uniform_encodingPrehit_or_potential_le_refined_charge + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} (hfresh : cache input = none) : + (∑' answer : HashOutput, Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if EncodingMessagePrehit cache secretKey input answer then 1 + else encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey)) ≤ + encodingSelectionTotalPotential cache hfinite secretKey + + refinedStructuralEncodingQueryCharge secretKey cache input * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + by_cases hbad : Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + · have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = 1 := by + simp [encodingSelectionTotalPotential, hbad] + rw [hbefore] + apply le_trans _ (le_self_add : (1 : ℝ≥0∞) ≤ 1 + _) + calc + _ ≤ ∑' answer : HashOutput, Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * 1 := by + apply ENNReal.tsum_le_tsum + intro answer + apply mul_le_mul' le_rfl + split_ifs + · exact le_rfl + · exact encodingSelectionTotalPotential_le_one _ secretKey + _ = 1 := by simp only [mul_one, tsum_probOutput_of_liftM_PMF] + · by_cases hhit : ∃ answer, EncodingMessagePrehit cache secretKey input answer + · obtain ⟨answer, hhit⟩ := hhit + obtain ⟨position, hat, hunsettled, hsettled⟩ := hhit.queried_settles hfinite hfresh + have hsettles := settled_cacheQuery_of_settled_cacheQuery secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret hfresh hat hunsettled hsettled + exact (uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settlingPosition_prehit + hfinite hbad hfresh hat hunsettled hsettles).trans le_self_add + · have hnone : ∀ answer, ¬ EncodingMessagePrehit cache secretKey input answer := by + simpa using hhit + simp_rw [if_neg (hnone _)] + exact uniform_encodingSelectionTotalPotential_cacheQuery_le_refined_charge hfinite hfresh + +end SphincsSecurity.Concrete.TightEncoding diff --git a/formal/sphincs/SphincsSecurity/Proof/TightEncodingQueryBound.lean b/formal/sphincs/SphincsSecurity/Proof/TightEncodingQueryBound.lean new file mode 100644 index 00000000..f2612330 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TightEncodingQueryBound.lean @@ -0,0 +1,71 @@ +import SphincsSecurity.Proof.TightEncodingQueryCharge +import SphincsSecurity.Proof.RomQueryCharge +import SphincsSecurity.Proof.FirstBad + +namespace SphincsSecurity.Concrete.TightEncoding + +open OracleComp OracleSpec ENNReal + +noncomputable def freshStructuralEncodingQueryCharge (parameter : PublicParameter) + (cache : QueryCache HashSpec) (input : HashInput) : ℝ≥0∞ := + if cache input = none then structuralEncodingQueryCharge parameter input else 0 + +theorem freshStructuralEncodingQueryCharge_le_three (parameter : PublicParameter) + (cache : QueryCache HashSpec) (input : HashInput) : + freshStructuralEncodingQueryCharge parameter cache input ≤ 3 := by + classical + unfold freshStructuralEncodingQueryCharge structuralEncodingQueryCharge + split_ifs <;> norm_num + +theorem expected_encodingSelectionAdaptivePotential_le_queryCharge + {α : Type} (computation : OracleComp OracleWorld α) + (secretKey : SecretKey) (cache : QueryCache HashSpec) (hfinite : Finite cache) : + (∑' result, Pr[= result | (simulateQ romImpl computation).run cache] * + encodingSelectionAdaptivePotential result.2 secretKey) ≤ + encodingSelectionAdaptivePotential cache secretKey + + expectedQueryCharge (freshStructuralEncodingQueryCharge secretKey.parameter) + computation cache * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + rw [← expectedQueryCharge_mul] + refine expected_potential_simulateQ_le_queryCharge + (fun cache => encodingSelectionAdaptivePotential cache secretKey) _ ?_ + computation cache hfinite + apply expected_potential_romImpl_le_charge + intro before hbefore input hfresh + simp_rw [encodingSelectionAdaptivePotential_eq (finite_cacheQuery hbefore input _)] + rw [encodingSelectionAdaptivePotential_eq hbefore, + freshStructuralEncodingQueryCharge, if_pos hfresh] + exact uniform_encodingSelectionTotalPotential_cacheQuery_le_charge hbefore hfresh + +theorem probEvent_bad_or_encodingBad_le_expectedPotential + {α : Type} (computation : OracleComp OracleWorld α) (secretKey : SecretKey) : + Pr[fun result => Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret result.2 ∨ + EncodingBad result.2 secretKey | (simulateQ romImpl computation).run ∅] ≤ + ∑' result, Pr[= result | (simulateQ romImpl computation).run ∅] * + encodingSelectionAdaptivePotential result.2 secretKey := by + classical + rw [probEvent_eq_tsum_ite] + apply ENNReal.tsum_le_tsum + intro result + by_cases hevent : Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret result.2 ∨ + EncodingBad result.2 secretKey + · rw [if_pos hevent] + by_cases hresult : result ∈ support ((simulateQ romImpl computation).run ∅) + · have hfinite := finite_cache_of_mem_support computation ∅ result.1 result.2 + hresult finite_empty + rw [encodingSelectionAdaptivePotential_eq hfinite, + encodingSelectionTotalPotential_eq_one_of_bad_or_encodingBad hfinite hevent, mul_one] + · rw [probOutput_eq_zero_of_not_mem_support hresult, zero_mul] + · rw [if_neg hevent] + exact bot_le + +theorem probEvent_bad_or_encodingBad_le_queryCharge + {α : Type} (computation : OracleComp OracleWorld α) (secretKey : SecretKey) : + Pr[fun result => Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret result.2 ∨ + EncodingBad result.2 secretKey | (simulateQ romImpl computation).run ∅] ≤ + expectedQueryCharge (freshStructuralEncodingQueryCharge secretKey.parameter) + computation ∅ * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + exact (probEvent_bad_or_encodingBad_le_expectedPotential computation secretKey).trans + ((expected_encodingSelectionAdaptivePotential_le_queryCharge computation secretKey ∅ + finite_empty).trans_eq (by rw [encodingSelectionAdaptivePotential_empty, zero_add])) + +end SphincsSecurity.Concrete.TightEncoding diff --git a/formal/sphincs/SphincsSecurity/Proof/TightEncodingQueryCharge.lean b/formal/sphincs/SphincsSecurity/Proof/TightEncodingQueryCharge.lean new file mode 100644 index 00000000..d59809a3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TightEncodingQueryCharge.lean @@ -0,0 +1,156 @@ +import SphincsSecurity.Proof.TightEncodingSelectionLift + +namespace SphincsSecurity.Concrete.TightEncoding + +open OracleComp OracleSpec ENNReal + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_not_encoding_sum_le + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} + (huncached : cache input = none) + (hnotEncoding : ∀ position : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input position) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ + encodingSelectionTotalPotential cache hfinite secretKey + + 2 * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + by_cases hstructural : ∃ position : Position, + AtPosition secretKey.parameter input position + · obtain ⟨position, hposition⟩ := hstructural + by_cases hsettled : Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache position + · have hbound := + uniform_encodingSelectionTotalPotential_cacheQuery_le_of_no_new_messages + hfinite huncached hnotEncoding + (fun answer candidate hafter => + hafter.of_cacheQuery_of_at_settled huncached hposition hsettled) + exact hbound + · by_cases hnever : ∀ answer : HashOutput, + ¬ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) position + · have hbound := + uniform_encodingSelectionTotalPotential_cacheQuery_le_of_no_new_messages + hfinite huncached hnotEncoding + (fun answer candidate hafter => + hafter.of_cacheQuery_of_at_unsettledAfter huncached hposition + (hnever answer)) + exact hbound + · push Not at hnever + obtain ⟨settlingAnswer, hsettling⟩ := hnever + obtain ⟨hinput, hchildren⟩ := + eq_cachedInput_and_children_of_settled_cacheQuery secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret huncached hposition hsettled hsettling + have hsettles : ∀ answer : HashOutput, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) position := by + intro answer + have hle := le_cacheQuery (cache := cache) (input := input) + (answer := answer) huncached + have hchildrenAfter : ∀ child ∈ position.children, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) child := + fun child hchild => (hchildren child hchild).mono hle + have hvalues : ∀ child ∈ position.children, + honestValue (fromCache (cache.cacheQuery input answer)) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret child = + honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret child := + fun child hchild => honestValue_eq_of_settled + (agreesWithFn_fromCache_of_le hle) (hchildren child hchild) + have hpinned : cachedInput secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (cache.cacheQuery input answer) position = + cachedInput secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + cache position := + honestInput_congr _ _ secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret hsettling.valid hvalues + rw [settled_iff] + refine ⟨hsettling.valid, ?_, hchildrenAfter⟩ + rw [hpinned, ← hinput, QueryCache.cacheQuery_self] + simp + by_cases hbad : Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache + · have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = 1 := by + rw [encodingSelectionTotalPotential, if_pos hbad] + rw [hbefore] + exact (expected_encodingSelectionTotalPotential_le_one hfinite secretKey input).trans + (le_add_right le_rfl) + · exact (uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settlingPosition + hfinite hbad huncached hposition hsettled hsettles).trans + (le_add_right le_rfl) + · have hbound := + uniform_encodingSelectionTotalPotential_cacheQuery_le_of_no_new_messages + hfinite huncached hnotEncoding + (fun answer candidate hafter => + hafter.of_cacheQuery_of_not_atPosition huncached + (fun position hposition => hstructural ⟨position, hposition⟩)) + exact hbound + + +theorem encodingSelectionTotalPotential_cacheQuery_le_of_unrelated + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + (huncached : cache input = none) + (hnotEncoding : ∀ position : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input position) + (hnotStructural : ∀ position : Position, + ¬ AtPosition secretKey.parameter input position) : + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey ≤ + encodingSelectionTotalPotential cache hfinite secretKey := by + by_cases hbad : Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + · have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = 1 := by + rw [encodingSelectionTotalPotential, if_pos hbad] + rw [hbefore] + exact encodingSelectionTotalPotential_le_one _ secretKey + · obtain ⟨hclean, hstructural⟩ := + clean_and_tightPotential_cacheQuery_of_not_atPosition secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret (answer := answer) hbad huncached hnotStructural + have hstage := encodingStagePotential_cacheQuery_le_of_not_atEncoding + (secretKey := secretKey) (answer := answer) huncached hnotEncoding + have hselection := encodingSelectionPotential_cacheQuery_le_of_no_new_messages + (answer := answer) hfinite huncached hnotEncoding + (fun position hafter => hafter.of_cacheQuery_of_not_atPosition huncached hnotStructural) + have hsum : encodingStructuralPotential (cache.cacheQuery input answer) secretKey ≤ + encodingStructuralPotential cache secretKey := Nat.add_le_add hstructural hstage + rw [encodingSelectionTotalPotential, if_neg hclean, + encodingSelectionTotalPotential, if_neg hbad] + exact min_le_min le_rfl (add_le_add (mul_le_mul' (Nat.cast_le.mpr hsum) le_rfl) hselection) + +noncomputable def structuralEncodingQueryCharge (parameter : PublicParameter) + (input : HashInput) : ℝ≥0∞ := + open Classical in + if ∃ position : EncodingPosition, AtEncodingPosition parameter input position then 3 + else if ∃ position : Position, AtPosition parameter input position then 2 + else 0 + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_le_charge + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} + (huncached : cache input = none) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ + encodingSelectionTotalPotential cache hfinite secretKey + + structuralEncodingQueryCharge secretKey.parameter input * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + classical + rw [structuralEncodingQueryCharge] + split_ifs with hencoding hstructural + · exact uniform_encodingSelectionTotalPotential_cacheQuery_sum_le hfinite huncached + · exact uniform_encodingSelectionTotalPotential_cacheQuery_not_encoding_sum_le + hfinite huncached (fun position hat => hencoding ⟨position, hat⟩) + · rw [zero_mul, add_zero] + calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionTotalPotential cache hfinite secretKey := by + exact ENNReal.tsum_le_tsum fun answer => mul_le_mul' le_rfl + (encodingSelectionTotalPotential_cacheQuery_le_of_unrelated hfinite huncached + (fun position hat => hencoding ⟨position, hat⟩) + (fun position hat => hstructural ⟨position, hat⟩)) + _ = _ := by rw [ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul] + +end SphincsSecurity.Concrete.TightEncoding diff --git a/formal/sphincs/SphincsSecurity/Proof/TightEncodingQueryTerminal.lean b/formal/sphincs/SphincsSecurity/Proof/TightEncodingQueryTerminal.lean new file mode 100644 index 00000000..9ac88c5b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TightEncodingQueryTerminal.lean @@ -0,0 +1,43 @@ +import SphincsSecurity.Proof.TightEncodingQueryBound +import SphincsSecurity.Proof.EncodingTerminalView + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem probEvent_bad_or_viewedEncodingCollision_le_queryCharge + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache ∨ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + expectedQueryCharge (TightEncoding.freshStructuralEncodingQueryCharge parameter) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + let accountingKey : SecretKey := ⟨parameter, default, otsSecret, ftsSecret⟩ + calc + _ ≤ Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache ∨ + EncodingBad result.2.cache accountingKey | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + apply probEvent_mono + intro result _ hevent + rcases hevent with hbad | hencoding + · exact Or.inl hbad + · exact Or.inr ((encodingBad_mk_root_iff parameter otsSecret ftsSecret result.2.cache + result.1.1 default).mp hencoding.encodingBad) + _ = Pr[fun result : Bool × QueryCache HashSpec => + Bad parameter otsSecret ftsSecret result.2 ∨ EncodingBad result.2 accountingKey | + (fun result => (result.1.2.2, result.2.cache)) <$> + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + rw [probEvent_map] + rfl + _ = Pr[fun result : Bool × QueryCache HashSpec => + Bad parameter otsSecret ftsSecret result.2 ∨ EncodingBad result.2 accountingKey | + (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅] := by + rw [gameAfterSecretsWithViewTrace_verdictCache_projection] + _ ≤ _ := TightEncoding.probEvent_bad_or_encodingBad_le_queryCharge + (gameAfterSecrets adversary parameter otsSecret ftsSecret) accountingKey + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/TightEncodingRefinedBound.lean b/formal/sphincs/SphincsSecurity/Proof/TightEncodingRefinedBound.lean new file mode 100644 index 00000000..091314ae --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TightEncodingRefinedBound.lean @@ -0,0 +1,81 @@ +import SphincsSecurity.Proof.TightEncodingSettledCharge +import SphincsSecurity.Proof.TightEncodingQueryBound +import SphincsSecurity.Proof.EncodingTerminalView + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +namespace TightEncoding + +theorem expected_encodingSelectionAdaptivePotential_le_refined_queryCharge + {α : Type} (computation : OracleComp OracleWorld α) + (secretKey : SecretKey) (cache : QueryCache HashSpec) (hfinite : Finite cache) : + (∑' result, Pr[= result | (simulateQ romImpl computation).run cache] * + encodingSelectionAdaptivePotential result.2 secretKey) ≤ + encodingSelectionAdaptivePotential cache secretKey + + expectedQueryCharge (refinedStructuralEncodingQueryCharge secretKey) + computation cache * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + rw [← expectedQueryCharge_mul] + refine expected_potential_simulateQ_le_queryCharge + (fun cache => encodingSelectionAdaptivePotential cache secretKey) _ ?_ + computation cache hfinite + apply expected_potential_romImpl_le_charge + intro before hbefore input hfresh + simp_rw [encodingSelectionAdaptivePotential_eq (finite_cacheQuery hbefore input _)] + rw [encodingSelectionAdaptivePotential_eq hbefore] + exact uniform_encodingSelectionTotalPotential_cacheQuery_le_refined_charge hbefore hfresh + +theorem probEvent_bad_or_encodingBad_le_refined_queryCharge + {α : Type} (computation : OracleComp OracleWorld α) (secretKey : SecretKey) : + Pr[fun result => Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret result.2 ∨ + EncodingBad result.2 secretKey | (simulateQ romImpl computation).run ∅] ≤ + expectedQueryCharge (refinedStructuralEncodingQueryCharge secretKey) + computation ∅ * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + exact (probEvent_bad_or_encodingBad_le_expectedPotential computation secretKey).trans + ((expected_encodingSelectionAdaptivePotential_le_refined_queryCharge computation secretKey ∅ + finite_empty).trans_eq (by rw [encodingSelectionAdaptivePotential_empty, zero_add])) + +end TightEncoding + +def primitiveAccountingKey (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : SecretKey := + ⟨parameter, default, otsSecret, ftsSecret⟩ + +theorem probEvent_bad_or_viewedEncodingCollision_le_refined_queryCharge + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache ∨ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + expectedQueryCharge + (TightEncoding.refinedStructuralEncodingQueryCharge (primitiveAccountingKey parameter otsSecret ftsSecret)) + (gameAfterSecrets adversary parameter otsSecret ftsSecret) ∅ * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + let accountingKey := primitiveAccountingKey parameter otsSecret ftsSecret + calc + _ ≤ Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache ∨ + EncodingBad result.2.cache accountingKey | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + apply probEvent_mono + intro result _ hevent + rcases hevent with hbad | hencoding + · exact Or.inl hbad + · exact Or.inr ((encodingBad_mk_root_iff parameter otsSecret ftsSecret result.2.cache + result.1.1 default).mp hencoding.encodingBad) + _ = Pr[fun result : Bool × QueryCache HashSpec => + Bad parameter otsSecret ftsSecret result.2 ∨ EncodingBad result.2 accountingKey | + (fun result => (result.1.2.2, result.2.cache)) <$> + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + rw [probEvent_map] + rfl + _ = Pr[fun result : Bool × QueryCache HashSpec => + Bad parameter otsSecret ftsSecret result.2 ∨ EncodingBad result.2 accountingKey | + (simulateQ romImpl (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅] := by + rw [gameAfterSecretsWithViewTrace_verdictCache_projection] + _ ≤ _ := TightEncoding.probEvent_bad_or_encodingBad_le_refined_queryCharge + (gameAfterSecrets adversary parameter otsSecret ftsSecret) accountingKey + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/TightEncodingSelectionLift.lean b/formal/sphincs/SphincsSecurity/Proof/TightEncodingSelectionLift.lean new file mode 100644 index 00000000..a843a3a8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TightEncodingSelectionLift.lean @@ -0,0 +1,210 @@ +import SphincsSecurity.Proof.TightEncodingSelectionPotential +import SphincsSecurity.Proof.CacheSize + +namespace SphincsSecurity.Concrete.TightEncoding + +open OracleComp OracleSpec ENNReal + +/-- The total encoding potential, extended harmlessly to caches not known to be finite. All caches +reachable from the empty lazy random oracle cache are finite. -/ +noncomputable def encodingSelectionAdaptivePotential + (cache : QueryCache HashSpec) (secretKey : SecretKey) : ℝ≥0∞ := + open Classical in + if hfinite : Finite cache then + encodingSelectionTotalPotential cache hfinite secretKey + else 0 + +theorem encodingSelectionAdaptivePotential_eq + {cache : QueryCache HashSpec} (hfinite : Finite cache) (secretKey : SecretKey) : + encodingSelectionAdaptivePotential cache secretKey = + encodingSelectionTotalPotential cache hfinite secretKey := by + rw [encodingSelectionAdaptivePotential, dif_pos hfinite] + +@[simp] theorem encodingSelectionAdaptivePotential_empty (secretKey : SecretKey) : + encodingSelectionAdaptivePotential ∅ secretKey = 0 := by + rw [encodingSelectionAdaptivePotential_eq finite_empty] + exact encodingSelectionTotalPotential_empty secretKey + +theorem uniform_encodingSelectionAdaptivePotential_cacheQuery_sum_le + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} + (huncached : cache input = none) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionAdaptivePotential (cache.cacheQuery input answer) secretKey) ≤ + encodingSelectionAdaptivePotential cache secretKey + + 3 * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + simp_rw [encodingSelectionAdaptivePotential_eq + (finite_cacheQuery hfinite input _)] + rw [encodingSelectionAdaptivePotential_eq hfinite] + exact uniform_encodingSelectionTotalPotential_cacheQuery_sum_le hfinite huncached + +theorem expected_encodingSelectionAdaptivePotential_simulateQ_le + {alpha : Type} (computation : OracleComp OracleWorld alpha) : + ∀ (q : Nat), computation.IsQueryBoundP (· matches Sum.inr _) q → + ∀ (cache : QueryCache HashSpec), Finite cache → ∀ secretKey : SecretKey, + (∑' result, + Pr[= result | (simulateQ romImpl computation).run cache] * + encodingSelectionAdaptivePotential result.2 secretKey) ≤ + encodingSelectionAdaptivePotential cache secretKey + + (3 * q : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + classical + induction computation using OracleComp.inductionOn with + | pure value => + intro q _ cache _ secretKey + simp [simulateQ_pure] + | query_bind query next ih => + intro q hq cache hfinite secretKey + rw [isQueryBoundP_query_bind_iff] at hq + obtain ⟨hcan, hcont⟩ := hq + rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind] + cases query with + | inl input => + simp only [Bool.false_eq_true, if_false] at hcont + have hrun : ((romImpl (Sum.inl input)).run cache + >>= fun result => (simulateQ romImpl (next result.1)).run result.2) = + (liftM (unifSpec.query input) : ProbComp _) >>= fun answer => + (simulateQ romImpl (next answer)).run cache := by + simp [romImpl, unifFwdImpl, QueryImpl.liftTarget, HasQuery.toQueryImpl, + StateT.run_monadLift, map_eq_bind_pure_comp, bind_assoc] + rw [hrun, tsum_probOutput_bind_mul] + calc + _ ≤ ∑' answer, + Pr[= answer | (liftM (unifSpec.query input) : ProbComp _)] * + (encodingSelectionAdaptivePotential cache secretKey + + (3 * q : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹) := by + apply ENNReal.tsum_le_tsum + intro answer + exact mul_le_mul' le_rfl (ih answer q (hcont answer) cache hfinite secretKey) + _ = _ := by + rw [ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul] + | inr input => + simp only [if_true] at hcont + have hq1 : 0 < q := by simpa using hcan + obtain ⟨q', rfl⟩ : ∃ q', q = q' + 1 := ⟨q - 1, by omega⟩ + simp only [Nat.add_sub_cancel] at hcont + simp only [Nat.cast_add, Nat.cast_one] + by_cases huncached : cache input = none + · have hrun : ((romImpl (Sum.inr input)).run cache + >>= fun result => (simulateQ romImpl (next result.1)).run result.2) = + ($ᵗ HashOutput : ProbComp HashOutput) >>= fun answer => + (simulateQ romImpl (next answer)).run + (cache.cacheQuery input answer) := by + have hro : (romImpl (Sum.inr input)).run cache = + ((uniformSampleImpl.withCaching : QueryImpl HashSpec _) input).run cache := rfl + rw [hro, QueryImpl.withCaching_run_none _ huncached] + simp [map_eq_bind_pure_comp, bind_assoc, uniformSampleImpl] + rw [hrun, tsum_probOutput_bind_mul] + calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (encodingSelectionAdaptivePotential (cache.cacheQuery input answer) secretKey + + (3 * q' : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹) := by + apply ENNReal.tsum_le_tsum + intro answer + exact mul_le_mul' le_rfl + (ih answer q' (hcont answer) (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) + _ = (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionAdaptivePotential (cache.cacheQuery input answer) secretKey) + + (3 * q' : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_mul_right, + tsum_probOutput_of_liftM_PMF, one_mul] + _ ≤ (encodingSelectionAdaptivePotential cache secretKey + + 3 * (Fintype.card Digest : ℝ≥0∞)⁻¹) + + (3 * q' : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := + add_le_add + (uniform_encodingSelectionAdaptivePotential_cacheQuery_sum_le + hfinite huncached) le_rfl + _ = encodingSelectionAdaptivePotential cache secretKey + + 3 * ((q' : ℝ≥0∞) + 1) * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + ring + · obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp huncached + have hrun : ((romImpl (Sum.inr input)).run cache + >>= fun result => (simulateQ romImpl (next result.1)).run result.2) = + (simulateQ romImpl (next answer)).run cache := by + have hro : (romImpl (Sum.inr input)).run cache = + ((uniformSampleImpl.withCaching : QueryImpl HashSpec _) input).run cache := rfl + rw [hro, QueryImpl.withCaching_run_some _ hanswer] + simp + rw [hrun] + exact (ih answer q' (hcont answer) cache hfinite secretKey).trans (by + gcongr + norm_num) + +theorem probEvent_clean_encodingBad_simulateQ_le + {alpha : Type} (computation : OracleComp OracleWorld alpha) + (q : Nat) (hq : computation.IsQueryBoundP (· matches Sum.inr _) q) + (secretKey : SecretKey) : + Pr[fun result => + ¬Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret result.2 ∧ + EncodingBad result.2 secretKey | + (simulateQ romImpl computation).run ∅] ≤ + (3 * q : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + classical + rw [probEvent_eq_tsum_ite] + calc + _ ≤ ∑' result, + Pr[= result | (simulateQ romImpl computation).run ∅] * + encodingSelectionAdaptivePotential result.2 secretKey := by + apply ENNReal.tsum_le_tsum + intro result + by_cases hevent : + ¬Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret result.2 ∧ + EncodingBad result.2 secretKey + · rw [if_pos hevent] + by_cases hresult : result ∈ support ((simulateQ romImpl computation).run ∅) + · have hfinite : Finite result.2 := Finite.of_enncard_le + (simulateQ_romImpl_enncard_le_queryBound computation q hq result hresult) + rw [encodingSelectionAdaptivePotential_eq hfinite, + encodingSelectionTotalPotential_eq_one_of_clean_of_encodingBad + hfinite hevent.1 hevent.2, mul_one] + · rw [probOutput_eq_zero_of_not_mem_support hresult, zero_mul] + · rw [if_neg hevent] + exact bot_le + _ ≤ encodingSelectionAdaptivePotential ∅ secretKey + + (3 * q : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := + expected_encodingSelectionAdaptivePotential_simulateQ_le computation q hq ∅ + finite_empty secretKey + _ = _ := by simp + +theorem probEvent_bad_or_encodingBad_simulateQ_le + {alpha : Type} (computation : OracleComp OracleWorld alpha) + (q : Nat) (hq : computation.IsQueryBoundP (· matches Sum.inr _) q) + (secretKey : SecretKey) : + Pr[fun result => + Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret result.2 ∨ + EncodingBad result.2 secretKey | + (simulateQ romImpl computation).run ∅] ≤ + (3 * q : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + classical + rw [probEvent_eq_tsum_ite] + calc + _ ≤ ∑' result, + Pr[= result | (simulateQ romImpl computation).run ∅] * + encodingSelectionAdaptivePotential result.2 secretKey := by + apply ENNReal.tsum_le_tsum + intro result + by_cases hevent : + Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret result.2 ∨ + EncodingBad result.2 secretKey + · rw [if_pos hevent] + by_cases hresult : result ∈ support ((simulateQ romImpl computation).run ∅) + · have hfinite : Finite result.2 := Finite.of_enncard_le + (simulateQ_romImpl_enncard_le_queryBound computation q hq result hresult) + rw [encodingSelectionAdaptivePotential_eq hfinite, + encodingSelectionTotalPotential_eq_one_of_bad_or_encodingBad + hfinite hevent, mul_one] + · rw [probOutput_eq_zero_of_not_mem_support hresult, zero_mul] + · rw [if_neg hevent] + exact bot_le + _ ≤ encodingSelectionAdaptivePotential ∅ secretKey + + (3 * q : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := + expected_encodingSelectionAdaptivePotential_simulateQ_le computation q hq ∅ + finite_empty secretKey + _ = _ := by simp + +end SphincsSecurity.Concrete.TightEncoding diff --git a/formal/sphincs/SphincsSecurity/Proof/TightEncodingSelectionPotential.lean b/formal/sphincs/SphincsSecurity/Proof/TightEncodingSelectionPotential.lean new file mode 100644 index 00000000..e287956a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TightEncodingSelectionPotential.lean @@ -0,0 +1,818 @@ +import SphincsSecurity.Proof.EncodingMessagePrehit +import SphincsSecurity.Proof.TightChargeStep + +namespace SphincsSecurity.Concrete.TightEncoding + +open OracleComp OracleSpec ENNReal + +attribute [local instance] Classical.propDecidable + +noncomputable def encodingStructuralPotential (cache : QueryCache HashSpec) + (secretKey : SecretKey) : Nat := + tightPotential secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + + encodingStagePotential cache secretKey + +@[simp] theorem encodingStructuralPotential_empty (secretKey : SecretKey) : + encodingStructuralPotential ∅ secretKey = 0 := by + rw [encodingStructuralPotential, tightPotential_empty, encodingStagePotential_empty, + Nat.zero_add] + +/-- Joint structural and encoding risk; a structural collision saturates the potential. -/ +noncomputable def encodingSelectionTotalPotential + (cache : QueryCache HashSpec) (hfinite : Finite cache) + (secretKey : SecretKey) : ℝ≥0∞ := + open Classical in + if Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache then 1 + else min 1 ((encodingStructuralPotential cache secretKey : ℝ≥0∞) * + (Fintype.card Digest : ℝ≥0∞)⁻¹ + + encodingSelectionPotential cache hfinite secretKey) + +theorem encodingSelection_hasCachedHit_mem_settlingTargets_of_prematureSettlement + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {position : EncodingPosition} {index : Index} {queriedPosition : Position} + (huncached : cache input = none) + (htree : treeIndexAt index position.lay = position.tree) + (hleaf : leafIndexAt index position.lay = position.leafIdx) + (hunsettled : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache (layerMessagePosition index position.lay)) + (hsettled : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) (layerMessagePosition index position.lay)) + (hnotMessage : ¬ AtPosition secretKey.parameter input + (layerMessagePosition index position.lay)) + (hqueried : AtPosition secretKey.parameter input queriedPosition) + (hhit : EncodingSelection.HasCachedHit + (encodingRetrySchedule secretKey.parameter (cache.cacheQuery input answer) + position (encodingSettledMessage (cache.cacheQuery input answer) secretKey position)) + (encodingSelectionCandidates secretKey.parameter (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) position)) : + truncateHash answer ∈ + tightSettlingTargets secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache hfinite queriedPosition := by + have hbad := latentEncodingBadAt_of_newlySettled_of_encodingSelection_hasCachedHit + hfinite (show EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position from + ⟨index, htree, hleaf, hsettled⟩) hhit + obtain ⟨targetIndex, counter, targetPayload, otherPayload, targetAnswer, + otherAnswer, htargetTree, htargetLeaf, htargetSettled, hpayload, + htargetAnswer, htargetValid, hbefore, hpayloadNe, hotherAnswer, + hcollision⟩ := hbad + have hmessagePosition : layerMessagePosition index position.lay = + layerMessagePosition targetIndex position.lay := + layerMessagePosition_eq_of_position_eq index targetIndex position.lay + (htree.trans htargetTree.symm) (hleaf.trans htargetLeaf.symm) + have hpremature : PrematureLayerMessageSettlement cache secretKey input answer := + ⟨position, targetIndex, htargetTree, htargetLeaf, + by rwa [← hmessagePosition], htargetSettled, + by rwa [← hmessagePosition]⟩ + obtain ⟨candidate, hcandidate, _, _, hmem⟩ := + hpremature.mem_tightSettlingTargets hfinite huncached + have heq : candidate = queriedPosition := + atPosition_unique secretKey.parameter hcandidate hqueried + simpa only [heq] using hmem + +theorem encodingSelectionPotential_cacheQuery_le_of_avoids_settlementTargets + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + {queriedPosition : Position} + (huncached : cache input = none) + (hqueried : AtPosition secretKey.parameter input queriedPosition) + (havoidMessage : ∀ (position : EncodingPosition) (index : Index), + treeIndexAt index position.lay = position.tree → + leafIndexAt index position.lay = position.leafIdx → + AtPosition secretKey.parameter input (layerMessagePosition index position.lay) → + truncateHash answer ∉ + encodingMessageTargets secretKey.parameter cache hfinite position) + (havoidSettling : truncateHash answer ∉ + tightSettlingTargets secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache hfinite queriedPosition) : + encodingSelectionPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey ≤ + encodingSelectionPotential cache hfinite secretKey := by + rw [encodingSelectionPotential, encodingSelectionPotential] + apply Finset.sum_le_sum + intro position _ + have hnotAt : ¬ AtEncodingPosition secretKey.parameter input position := + fun hencoding => hencoding.not_atPosition queriedPosition hqueried + by_cases hmessageSettled : EncodingMessageSettledAt cache secretKey position + · exact le_of_eq + (encodingSelectionContribution_cacheQuery_eq_of_settled_of_not_atPosition + hfinite huncached hmessageSettled hnotAt) + · by_cases hmessageSettledAfter : EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position + · by_cases hhit : EncodingSelection.HasCachedHit + (encodingRetrySchedule secretKey.parameter (cache.cacheQuery input answer) + position (encodingSettledMessage (cache.cacheQuery input answer) secretKey position)) + (encodingSelectionCandidates secretKey.parameter (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) position) + · obtain ⟨index, htree, hleaf, hsettled⟩ := + (show EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey position from hmessageSettledAfter) + have hunsettled : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache (layerMessagePosition index position.lay) := by + intro hposition + exact hmessageSettled ⟨index, htree, hleaf, hposition⟩ + by_cases hmessage : AtPosition secretKey.parameter input + (layerMessagePosition index position.lay) + · exact (havoidMessage position index htree hleaf hmessage + (encodingSelection_hasCachedHit_mem_messageTargets_of_newlySettled + hfinite huncached htree hleaf hunsettled hsettled hmessage hhit)).elim + · exact (havoidSettling + (encodingSelection_hasCachedHit_mem_settlingTargets_of_prematureSettlement + hfinite huncached htree hleaf hunsettled hsettled hmessage hqueried hhit)).elim + · exact encodingSelectionContribution_cacheQuery_le_of_newlySettled_of_not_hasCachedHit + hfinite hmessageSettled hmessageSettledAfter hnotAt hhit + · exact + encodingSelectionContribution_cacheQuery_le_of_unsettled_of_stillUnsettled_of_not_atPosition + hfinite huncached hmessageSettled hmessageSettledAfter hnotAt + +theorem encodingStructuralPotential_cacheQuery_le_of_atEncoding + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} {position : EncodingPosition} + (hclean : ¬ Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache) + (huncached : cache input = none) + (hposition : AtEncodingPosition secretKey.parameter input position) : + encodingStructuralPotential (cache.cacheQuery input answer) secretKey ≤ + encodingStructuralPotential cache secretKey + 2 := by + have hstructural := + (clean_and_tightPotential_cacheQuery_of_not_atPosition secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret (answer := answer) hclean huncached + (fun structuralPosition hat => + hposition.not_atPosition structuralPosition hat)).2 + have hencoding := encodingStagePotential_cacheQuery_le + (secretKey := secretKey) (answer := answer) huncached + rw [encodingStructuralPotential, encodingStructuralPotential] + omega + +theorem encodingSelectionTotalPotential_eq_one_of_clean_of_encodingBad + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} + (hclean : ¬ Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache) + (hbad : EncodingBad cache secretKey) : + encodingSelectionTotalPotential cache hfinite secretKey = 1 := by + rw [encodingSelectionTotalPotential, if_neg hclean, min_eq_left] + exact (one_le_encodingSelectionPotential_of_encodingBad hfinite hbad).trans + (le_add_left le_rfl) + +theorem encodingSelectionTotalPotential_eq_one_of_bad_or_encodingBad + {cache : QueryCache HashSpec} (hfinite : Finite cache) {secretKey : SecretKey} + (hevent : Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache ∨ + EncodingBad cache secretKey) : + encodingSelectionTotalPotential cache hfinite secretKey = 1 := by + by_cases hbad : Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + · rw [encodingSelectionTotalPotential, if_pos hbad] + · exact encodingSelectionTotalPotential_eq_one_of_clean_of_encodingBad + hfinite hbad (hevent.resolve_left hbad) + +theorem encodingSelectionTotalPotential_le_one + {cache : QueryCache HashSpec} (hfinite : Finite cache) + (secretKey : SecretKey) : + encodingSelectionTotalPotential cache hfinite secretKey ≤ 1 := by + rw [encodingSelectionTotalPotential] + split + · exact le_rfl + · exact min_le_left _ _ + +theorem encodingSelectionTotalPotential_le_uncapped + {cache : QueryCache HashSpec} (hfinite : Finite cache) + (secretKey : SecretKey) + (hclean : ¬Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache) : + encodingSelectionTotalPotential cache hfinite secretKey ≤ + (encodingStructuralPotential cache secretKey : ℝ≥0∞) * + (Fintype.card Digest : ℝ≥0∞)⁻¹ + + encodingSelectionPotential cache hfinite secretKey := by + rw [encodingSelectionTotalPotential, if_neg hclean] + exact min_le_right _ _ + +theorem expected_encodingSelectionTotalPotential_le_one + {cache : QueryCache HashSpec} (hfinite : Finite cache) + (secretKey : SecretKey) (input : HashInput) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ 1 := by + calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * 1 := by + apply ENNReal.tsum_le_tsum + intro answer + exact mul_le_mul_right (encodingSelectionTotalPotential_le_one _ secretKey) _ + _ = 1 := by simp only [mul_one, tsum_probOutput_of_liftM_PMF] + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_atPosition_sum_le + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {position : EncodingPosition} + (huncached : cache input = none) + (hposition : AtEncodingPosition secretKey.parameter input position) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ + encodingSelectionTotalPotential cache hfinite secretKey + + 3 * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + let eps := (Fintype.card Digest : ℝ≥0∞)⁻¹ + by_cases hbad : Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + · have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = 1 := by + rw [encodingSelectionTotalPotential, if_pos hbad] + rw [hbefore] + exact (expected_encodingSelectionTotalPotential_le_one hfinite secretKey input).trans + (le_add_right le_rfl) + · let uncapped := (encodingStructuralPotential cache secretKey : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey + by_cases hone : 1 ≤ uncapped + · calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * 1 := by + apply ENNReal.tsum_le_tsum + intro answer + exact mul_le_mul_right + (encodingSelectionTotalPotential_le_one _ secretKey) _ + _ = 1 := by + simp only [mul_one, tsum_probOutput_of_liftM_PMF] + _ = encodingSelectionTotalPotential cache hfinite secretKey := by + rw [encodingSelectionTotalPotential, if_neg hbad, min_eq_left] + simpa only [uncapped] using hone + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + 3 * eps := + le_add_right le_rfl + · have huncappedLe : uncapped ≤ 1 := le_of_not_ge hone + have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = uncapped := by + rw [encodingSelectionTotalPotential, if_neg hbad, min_eq_right] + exact huncappedLe + calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (((encodingStructuralPotential cache secretKey + 2 : Nat) : ℝ≥0∞) * eps + + encodingSelectionPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) := by + apply ENNReal.tsum_le_tsum + intro answer + apply mul_le_mul_right + have hcleanAfter := + (clean_and_tightPotential_cacheQuery_of_not_atPosition secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret (answer := answer) hbad huncached + (fun structuralPosition hat => hposition.not_atPosition structuralPosition hat)).1 + refine (encodingSelectionTotalPotential_le_uncapped _ secretKey hcleanAfter).trans ?_ + have hstructuralNat := + encodingStructuralPotential_cacheQuery_le_of_atEncoding + (answer := answer) hbad huncached hposition + have hstructural : + (encodingStructuralPotential (cache.cacheQuery input answer) + secretKey : ℝ≥0∞) ≤ + ((encodingStructuralPotential cache secretKey + 2 : Nat) : ℝ≥0∞) := + Nat.cast_le.mpr hstructuralNat + exact add_le_add (mul_le_mul_left hstructural eps) le_rfl + _ = (((encodingStructuralPotential cache secretKey + 2 : Nat) : ℝ≥0∞) * eps) + + ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_mul_right, + tsum_probOutput_of_liftM_PMF, one_mul] + _ ≤ (((encodingStructuralPotential cache secretKey + 2 : Nat) : ℝ≥0∞) * eps) + + (encodingSelectionPotential cache hfinite secretKey + eps) := by + exact add_le_add le_rfl + (uniform_encodingSelectionPotential_cacheQuery_atPosition_sum_le + (cache := cache) (secretKey := secretKey) (input := input) + (position := position) hfinite huncached hposition) + _ = uncapped + 3 * eps := by + simp only [Nat.cast_add, Nat.cast_ofNat] + dsimp only [uncapped] + ring + _ = encodingSelectionTotalPotential cache hfinite secretKey + 3 * eps := by + rw [hbefore] + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_le_of_no_new_messages + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} + (huncached : cache input = none) + (hnotEncoding : ∀ position : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input position) + (hnoNew : ∀ (answer : HashOutput) (position : EncodingPosition), + EncodingMessageSettledAt (cache.cacheQuery input answer) secretKey position → + EncodingMessageSettledAt cache secretKey position) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ + encodingSelectionTotalPotential cache hfinite secretKey + + 2 * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + let eps := (Fintype.card Digest : ℝ≥0∞)⁻¹ + by_cases hbad : Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + · have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = 1 := by + rw [encodingSelectionTotalPotential, if_pos hbad] + rw [hbefore] + exact (expected_encodingSelectionTotalPotential_le_one hfinite secretKey input).trans + (le_add_right le_rfl) + · let uncapped := (encodingStructuralPotential cache secretKey : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey + by_cases hone : 1 ≤ uncapped + · calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * 1 := by + apply ENNReal.tsum_le_tsum + intro answer + exact mul_le_mul_right + (encodingSelectionTotalPotential_le_one _ secretKey) _ + _ = 1 := by simp only [mul_one, tsum_probOutput_of_liftM_PMF] + _ = encodingSelectionTotalPotential cache hfinite secretKey := by + rw [encodingSelectionTotalPotential, if_neg hbad, min_eq_left] + simpa only [uncapped] using hone + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + 2 * eps := + le_add_right le_rfl + · have huncappedLe : uncapped ≤ 1 := le_of_not_ge hone + have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = uncapped := by + rw [encodingSelectionTotalPotential, if_neg hbad, min_eq_right] + exact huncappedLe + obtain ⟨targets, hcard, hsafe⟩ := tight_bad_step secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret cache hfinite hbad input huncached + let credit := tightPotential secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + + 2 - targets.card + have hcredit : credit + targets.card = + tightPotential secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + 2 := + Nat.sub_add_cancel hcard + have hpointwise (answer : HashOutput) : + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey ≤ + ((credit + encodingStagePotential cache secretKey : Nat) : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey + + if truncateHash answer ∈ targets then 1 else 0 := by + by_cases hmem : truncateHash answer ∈ targets + · rw [if_pos hmem] + exact (encodingSelectionTotalPotential_le_one _ secretKey).trans + (le_add_left le_rfl) + · rw [if_neg hmem, add_zero] + obtain ⟨hcleanAfter, hpaid⟩ := hsafe answer hmem + have hstructural : tightPotential secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (cache.cacheQuery input answer) ≤ credit := by + dsimp only [credit] + omega + have hstage := encodingStagePotential_cacheQuery_le_of_not_atEncoding + (secretKey := secretKey) (answer := answer) huncached hnotEncoding + have hsum : encodingStructuralPotential (cache.cacheQuery input answer) secretKey ≤ + credit + encodingStagePotential cache secretKey := by + rw [encodingStructuralPotential] + omega + refine (encodingSelectionTotalPotential_le_uncapped _ secretKey hcleanAfter).trans ?_ + exact add_le_add (mul_le_mul_left (Nat.cast_le.mpr hsum) eps) + (encodingSelectionPotential_cacheQuery_le_of_no_new_messages + (answer := answer) hfinite huncached hnotEncoding (hnoNew answer)) + calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (((credit + encodingStagePotential cache secretKey : Nat) : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey + + if truncateHash answer ∈ targets then 1 else 0) := by + apply ENNReal.tsum_le_tsum + intro answer + exact mul_le_mul_right (hpointwise answer) _ + _ = (((credit + encodingStagePotential cache secretKey : Nat) : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey) + + ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if truncateHash answer ∈ targets then 1 else 0) := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_add, + ENNReal.tsum_mul_right, ENNReal.tsum_mul_right, + tsum_probOutput_of_liftM_PMF, one_mul] + ring + _ = (((credit + encodingStagePotential cache secretKey : Nat) : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey) + + (targets.card : ℝ≥0∞) * eps := by + rw [uniformHashOutput_mem_bonus_sum_eq] + _ = uncapped + 2 * eps := by + have hcast := congrArg (fun n : Nat => (n : ℝ≥0∞)) hcredit + push_cast at hcast ⊢ + dsimp only [uncapped, encodingStructuralPotential] + push_cast + calc + _ = ((credit : ℝ≥0∞) + targets.card) * eps + + (encodingStagePotential cache secretKey : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey := by ring + _ = _ := by rw [hcast]; ring + _ = encodingSelectionTotalPotential cache hfinite secretKey + 2 * eps := by + rw [hbefore] + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settles_stopped + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {queriedPosition : Position} + (hclean : ¬ Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache) + (huncached : cache input = none) + (hqueried : AtPosition secretKey.parameter input queriedPosition) + (hsafe : ∀ answer : HashOutput, + truncateHash answer ∉ tightSettlingTargets secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache hfinite queriedPosition → + ¬Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret (cache.cacheQuery input answer)) + (messageTargets : Finset Digest) + (hdirectTargets : ∀ (position : EncodingPosition) (index : Index), + treeIndexAt index position.lay = position.tree → + leafIndexAt index position.lay = position.leafIdx → + layerMessagePosition index position.lay = queriedPosition → + encodingMessageTargets secretKey.parameter cache hfinite position ⊆ messageTargets) + (hdrop : ∀ answer : HashOutput, + encodingStructuralPotential (cache.cacheQuery input answer) secretKey + + (messageTargets ∪ + tightSettlingTargets secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache hfinite queriedPosition).card ≤ + encodingStructuralPotential cache secretKey) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if truncateHash answer ∈ (messageTargets ∪ tightSettlingTargets secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache hfinite queriedPosition) then 1 + else encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey)) ≤ + encodingSelectionTotalPotential cache hfinite secretKey := by + let eps := (Fintype.card Digest : ℝ≥0∞)⁻¹ + let targets := messageTargets ∪ + tightSettlingTargets secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache hfinite queriedPosition + let credit := encodingStructuralPotential cache secretKey - targets.card + have hcard : targets.card ≤ encodingStructuralPotential cache secretKey := by + have hpaid := hdrop 0 + simp only [targets] + omega + have hcredit : credit + targets.card = encodingStructuralPotential cache secretKey := by + exact Nat.sub_add_cancel hcard + let uncapped := (encodingStructuralPotential cache secretKey : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey + by_cases hone : 1 ≤ uncapped + · calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * 1 := by + apply ENNReal.tsum_le_tsum + intro answer + apply mul_le_mul' le_rfl + split_ifs + · exact le_rfl + · exact encodingSelectionTotalPotential_le_one _ secretKey + _ = 1 := by simp only [mul_one, tsum_probOutput_of_liftM_PMF] + _ = encodingSelectionTotalPotential cache hfinite secretKey := by + rw [encodingSelectionTotalPotential, if_neg hclean, min_eq_left] + simpa only [uncapped] using hone + · have huncappedLe : uncapped ≤ 1 := le_of_not_ge hone + have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = uncapped := by + rw [encodingSelectionTotalPotential, if_neg hclean, min_eq_right] + exact huncappedLe + have hstructural (answer : HashOutput) : + encodingStructuralPotential (cache.cacheQuery input answer) secretKey ≤ credit := by + have hpaid := hdrop answer + change encodingStructuralPotential (cache.cacheQuery input answer) secretKey ≤ + encodingStructuralPotential cache secretKey - + (messageTargets ∪ + tightSettlingTargets secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache hfinite queriedPosition).card + omega + have hpointwise (answer : HashOutput) : + (if truncateHash answer ∈ targets then 1 + else encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ + (credit : ℝ≥0∞) * eps + encodingSelectionPotential cache hfinite secretKey + + if truncateHash answer ∈ targets then 1 else 0 := by + by_cases hmem : truncateHash answer ∈ targets + · simp only [if_pos hmem] + exact le_add_left le_rfl + · simp only [if_neg hmem, add_zero] + have hcleanAfter := hsafe answer (fun htarget => + hmem (Finset.mem_union_right _ htarget)) + refine (encodingSelectionTotalPotential_le_uncapped _ secretKey hcleanAfter).trans ?_ + have hstructuralCast : + (encodingStructuralPotential (cache.cacheQuery input answer) + secretKey : ℝ≥0∞) ≤ (credit : ℝ≥0∞) := + Nat.cast_le.mpr (hstructural answer) + have hselection := + encodingSelectionPotential_cacheQuery_le_of_avoids_settlementTargets + (answer := answer) hfinite huncached hqueried + (fun position index htree hleaf hmessage hmemMessage => by + apply hmem + change truncateHash answer ∈ messageTargets ∪ + tightSettlingTargets secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache hfinite queriedPosition + rw [Finset.mem_union] + apply Or.inl + apply hdirectTargets position index htree hleaf + (atPosition_unique secretKey.parameter hmessage hqueried) + exact hmemMessage) + (fun hmemSettling => by + apply hmem + change truncateHash answer ∈ messageTargets ∪ + tightSettlingTargets secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache hfinite queriedPosition + rw [Finset.mem_union] + exact Or.inr hmemSettling) + exact add_le_add (mul_le_mul_left hstructuralCast eps) hselection + calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + ((credit : ℝ≥0∞) * eps + encodingSelectionPotential cache hfinite secretKey + + if truncateHash answer ∈ targets then 1 else 0) := by + apply ENNReal.tsum_le_tsum + intro answer + exact mul_le_mul_right (hpointwise answer) _ + _ = ((credit : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey) + + ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if truncateHash answer ∈ targets then 1 else 0) := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_add, + ENNReal.tsum_mul_right, ENNReal.tsum_mul_right, + tsum_probOutput_of_liftM_PMF, one_mul] + ring + _ = ((credit : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey) + + (targets.card : ℝ≥0∞) * eps := by + rw [uniformHashOutput_mem_bonus_sum_eq] + _ = uncapped := by + dsimp only [uncapped] + calc + (credit : ℝ≥0∞) * eps + encodingSelectionPotential cache hfinite secretKey + + (targets.card : ℝ≥0∞) * eps = + ((credit : ℝ≥0∞) + (targets.card : ℝ≥0∞)) * eps + + encodingSelectionPotential cache hfinite secretKey := by ring + _ = _ := by rw [← Nat.cast_add, hcredit] + _ = encodingSelectionTotalPotential cache hfinite secretKey := hbefore.symm + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settles + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {queriedPosition : Position} + (hclean : ¬ Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache) + (huncached : cache input = none) + (hqueried : AtPosition secretKey.parameter input queriedPosition) + (hsafe : ∀ answer : HashOutput, + truncateHash answer ∉ tightSettlingTargets secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache hfinite queriedPosition → + ¬Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret (cache.cacheQuery input answer)) + (messageTargets : Finset Digest) + (hdirectTargets : ∀ (position : EncodingPosition) (index : Index), + treeIndexAt index position.lay = position.tree → + leafIndexAt index position.lay = position.leafIdx → + layerMessagePosition index position.lay = queriedPosition → + encodingMessageTargets secretKey.parameter cache hfinite position ⊆ messageTargets) + (hdrop : ∀ answer : HashOutput, + encodingStructuralPotential (cache.cacheQuery input answer) secretKey + + (messageTargets ∪ + tightSettlingTargets secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache hfinite queriedPosition).card ≤ + encodingStructuralPotential cache secretKey) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ + encodingSelectionTotalPotential cache hfinite secretKey := by + apply le_trans _ (uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settles_stopped + hfinite hclean huncached hqueried hsafe messageTargets hdirectTargets hdrop) + apply ENNReal.tsum_le_tsum + intro answer + apply mul_le_mul' le_rfl + split_ifs + · exact encodingSelectionTotalPotential_le_one _ secretKey + · exact le_rfl + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settles_prehit + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {queriedPosition : Position} + (hclean : ¬ Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache) + (huncached : cache input = none) + (hqueried : AtPosition secretKey.parameter input queriedPosition) + (hsafe : ∀ answer : HashOutput, + truncateHash answer ∉ tightSettlingTargets secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache hfinite queriedPosition → + ¬Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret (cache.cacheQuery input answer)) + (messageTargets : Finset Digest) + (hdirectTargets : ∀ (position : EncodingPosition) (index : Index), + treeIndexAt index position.lay = position.tree → + leafIndexAt index position.lay = position.leafIdx → + layerMessagePosition index position.lay = queriedPosition → + encodingMessageTargets secretKey.parameter cache hfinite position ⊆ messageTargets) + (hdrop : ∀ answer : HashOutput, + encodingStructuralPotential (cache.cacheQuery input answer) secretKey + + (messageTargets ∪ + tightSettlingTargets secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache hfinite queriedPosition).card ≤ + encodingStructuralPotential cache secretKey) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if EncodingMessagePrehit cache secretKey input answer then 1 + else encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey)) ≤ + encodingSelectionTotalPotential cache hfinite secretKey := by + apply le_trans _ (uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settles_stopped + hfinite hclean huncached hqueried hsafe messageTargets hdirectTargets hdrop) + apply ENNReal.tsum_le_tsum + intro answer + apply mul_le_mul' le_rfl + by_cases hhit : EncodingMessagePrehit cache secretKey input answer + · have hmem := hhit.mem_settlementTargets hfinite huncached hqueried messageTargets hdirectTargets + simp only [hhit, hmem, if_true, le_refl] + · simp only [hhit, if_false] + split_ifs + · exact encodingSelectionTotalPotential_le_one _ secretKey + · exact le_rfl + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settlingPosition_prehit + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {queriedPosition : Position} + (hclean : ¬ Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache) + (huncached : cache input = none) + (hqueried : AtPosition secretKey.parameter input queriedPosition) + (hunsettled : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache queriedPosition) + (hsettles : ∀ answer : HashOutput, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) queriedPosition) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (if EncodingMessagePrehit cache secretKey input answer then 1 + else encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey)) ≤ + encodingSelectionTotalPotential cache hfinite secretKey := by + have hnotEncoding : ∀ position : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input position := by + intro position hposition + exact hposition.not_atPosition queriedPosition hqueried + by_cases hdirect : ∃ (position : EncodingPosition) (index : Index), + treeIndexAt index position.lay = position.tree ∧ + leafIndexAt index position.lay = position.leafIdx ∧ + layerMessagePosition index position.lay = queriedPosition + · obtain ⟨directPosition, directIndex, hdirectTree, hdirectLeaf, + hdirectMessage⟩ := hdirect + let messageTargets := encodingMessageTargets secretKey.parameter cache hfinite directPosition + apply uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settles_prehit + hfinite hclean huncached hqueried + (fun answer havoid => clean_cacheQuery_of_settling_of_avoids_tight + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret hfinite hclean + huncached hqueried hunsettled (hsettles answer) havoid) messageTargets + · intro position index htree hleaf hmessage + have heq : position = directPosition := + encodingPosition_eq_of_layerMessagePosition_eq htree hleaf + hdirectTree hdirectLeaf (hmessage.trans hdirectMessage.symm) + subst position + exact Finset.Subset.rfl + · intro answer + have hstructural := tightPotential_add_settlingTargets_card_le + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret hfinite + huncached hqueried hunsettled (hsettles answer) + have hmessageUnsettled : ¬ EncodingMessageSettledAt cache secretKey directPosition := by + rintro ⟨index, htree, hleaf, hsettled⟩ + have hpositionEq := layerMessagePosition_eq_of_position_eq directIndex index + directPosition.lay (hdirectTree.trans htree.symm) + (hdirectLeaf.trans hleaf.symm) + apply hunsettled + rwa [← hdirectMessage, hpositionEq] + have hmessageSettled : EncodingMessageSettledAt + (cache.cacheQuery input answer) secretKey directPosition := + ⟨directIndex, hdirectTree, hdirectLeaf, by + rw [hdirectMessage] + exact hsettles answer⟩ + have hstage := encodingStagePotential_add_messageTargets_card_le_of_new_message + hfinite huncached hnotEncoding hmessageUnsettled hmessageSettled + have hunion : (messageTargets ∪ + tightSettlingTargets secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache hfinite queriedPosition).card ≤ + messageTargets.card + + (tightSettlingTargets secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache hfinite queriedPosition).card := + Finset.card_union_le _ _ + rw [encodingStructuralPotential, encodingStructuralPotential] + dsimp only [messageTargets] at hstage hunion ⊢ + omega + · apply uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settles_prehit + hfinite hclean huncached hqueried + (fun answer havoid => clean_cacheQuery_of_settling_of_avoids_tight + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret hfinite hclean + huncached hqueried hunsettled (hsettles answer) havoid) ∅ + · intro position index htree hleaf hmessage + exact (hdirect ⟨position, index, htree, hleaf, hmessage⟩).elim + · intro answer + have hstructural := tightPotential_add_settlingTargets_card_le + secretKey.parameter secretKey.otsSecret secretKey.ftsSecret hfinite + huncached hqueried hunsettled (hsettles answer) + have hstage := encodingStagePotential_cacheQuery_le_of_not_atEncoding + (answer := answer) huncached hnotEncoding + rw [encodingStructuralPotential, encodingStructuralPotential] + simp only [Finset.empty_union] + omega + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settlingPosition + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {queriedPosition : Position} + (hclean : ¬ Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache) + (huncached : cache input = none) + (hqueried : AtPosition secretKey.parameter input queriedPosition) + (hunsettled : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache queriedPosition) + (hsettles : ∀ answer : HashOutput, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) queriedPosition) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ + encodingSelectionTotalPotential cache hfinite secretKey := by + apply le_trans _ (uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settlingPosition_prehit + hfinite hclean huncached hqueried hunsettled hsettles) + apply ENNReal.tsum_le_tsum + intro answer + apply mul_le_mul' le_rfl + split_ifs + · exact encodingSelectionTotalPotential_le_one _ secretKey + · exact le_rfl + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_sum_le + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} + (huncached : cache input = none) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ + encodingSelectionTotalPotential cache hfinite secretKey + + 3 * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + let eps := (Fintype.card Digest : ℝ≥0∞)⁻¹ + by_cases hencoding : ∃ position : EncodingPosition, + AtEncodingPosition secretKey.parameter input position + · obtain ⟨position, hposition⟩ := hencoding + exact uniform_encodingSelectionTotalPotential_cacheQuery_atPosition_sum_le + hfinite huncached hposition + · have hnotEncoding : ∀ position : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input position := + fun position hposition => hencoding ⟨position, hposition⟩ + by_cases hstructural : ∃ position : Position, + AtPosition secretKey.parameter input position + · obtain ⟨position, hposition⟩ := hstructural + by_cases hsettled : Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache position + · have hbound := + uniform_encodingSelectionTotalPotential_cacheQuery_le_of_no_new_messages + hfinite huncached hnotEncoding + (fun answer candidate hafter => + hafter.of_cacheQuery_of_at_settled huncached hposition hsettled) + calc + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + 2 * eps := hbound + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + 3 * eps := by + gcongr + norm_num + · by_cases hnever : ∀ answer : HashOutput, + ¬ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) position + · have hbound := + uniform_encodingSelectionTotalPotential_cacheQuery_le_of_no_new_messages + hfinite huncached hnotEncoding + (fun answer candidate hafter => + hafter.of_cacheQuery_of_at_unsettledAfter huncached hposition + (hnever answer)) + calc + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + 2 * eps := hbound + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + 3 * eps := by + gcongr + norm_num + · push Not at hnever + obtain ⟨settlingAnswer, hsettling⟩ := hnever + obtain ⟨hinput, hchildren⟩ := + eq_cachedInput_and_children_of_settled_cacheQuery secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret huncached hposition hsettled hsettling + have hsettles : ∀ answer : HashOutput, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) position := by + intro answer + have hle := le_cacheQuery (cache := cache) (input := input) + (answer := answer) huncached + have hchildrenAfter : ∀ child ∈ position.children, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) child := + fun child hchild => (hchildren child hchild).mono hle + have hvalues : ∀ child ∈ position.children, + honestValue (fromCache (cache.cacheQuery input answer)) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret child = + honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret child := + fun child hchild => honestValue_eq_of_settled + (agreesWithFn_fromCache_of_le hle) (hchildren child hchild) + have hpinned : cachedInput secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (cache.cacheQuery input answer) position = + cachedInput secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + cache position := + honestInput_congr _ _ secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret hsettling.valid hvalues + rw [settled_iff] + refine ⟨hsettling.valid, ?_, hchildrenAfter⟩ + rw [hpinned, ← hinput, QueryCache.cacheQuery_self] + simp + by_cases hbad : Bad secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache + · have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = 1 := by + rw [encodingSelectionTotalPotential, if_pos hbad] + rw [hbefore] + exact (expected_encodingSelectionTotalPotential_le_one hfinite secretKey input).trans + (le_add_right le_rfl) + · exact (uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settlingPosition + hfinite hbad huncached hposition hsettled hsettles).trans + (le_add_right le_rfl) + · have hbound := + uniform_encodingSelectionTotalPotential_cacheQuery_le_of_no_new_messages + hfinite huncached hnotEncoding + (fun answer candidate hafter => + hafter.of_cacheQuery_of_not_atPosition huncached + (fun position hposition => hstructural ⟨position, hposition⟩)) + calc + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + 2 * eps := hbound + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + 3 * eps := by + gcongr + norm_num + +@[simp] theorem encodingSelectionTotalPotential_empty (secretKey : SecretKey) : + encodingSelectionTotalPotential ∅ finite_empty secretKey = 0 := by + rw [encodingSelectionTotalPotential, + if_neg (not_bad_empty secretKey.parameter secretKey.otsSecret secretKey.ftsSecret), + encodingStructuralPotential_empty, encodingSelectionPotential_empty] + simp + +end SphincsSecurity.Concrete.TightEncoding diff --git a/formal/sphincs/SphincsSecurity/Proof/TightEncodingSettledCharge.lean b/formal/sphincs/SphincsSecurity/Proof/TightEncodingSettledCharge.lean new file mode 100644 index 00000000..5f65613a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TightEncodingSettledCharge.lean @@ -0,0 +1,159 @@ +import SphincsSecurity.Proof.TightEncodingQueryCharge +import SphincsSecurity.Proof.TightEncodingStageCost +import SphincsSecurity.Proof.TightEncodingChildrenCharge + +namespace SphincsSecurity.Concrete.TightEncoding + +open OracleComp OracleSpec ENNReal + +theorem encodingSelectionTotalPotential_cacheQuery_le_of_settled_of_avoids + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} {position : Position} + (hfresh : cache input = none) (hat : AtPosition secretKey.parameter input position) + (hsettled : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position) + (havoid : truncateHash answer ≠ honestValue (fromCache cache) secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret position) : + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey ≤ + encodingSelectionTotalPotential cache hfinite secretKey := by + have hnotEncoding : ∀ candidate : EncodingPosition, + ¬ AtEncodingPosition secretKey.parameter input candidate := + fun _ hencoding => hencoding.not_atPosition position hat + by_cases hbad : Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + · have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = 1 := by + rw [encodingSelectionTotalPotential, if_pos hbad] + rw [hbefore] + exact encodingSelectionTotalPotential_le_one _ secretKey + · have hclean := clean_cacheQuery_of_settled_of_avoids secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret hbad hfresh hat hsettled havoid + have hstructural := tightPotential_cacheQuery_le_of_settled secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret (answer := answer) hfresh hat hsettled + have hstage := encodingStagePotential_cacheQuery_le_of_not_atEncoding + (secretKey := secretKey) (answer := answer) hfresh hnotEncoding + have hselection := encodingSelectionPotential_cacheQuery_le_of_no_new_messages + (answer := answer) hfinite hfresh hnotEncoding + (fun candidate hafter => hafter.of_cacheQuery_of_at_settled hfresh hat hsettled) + have hsum : encodingStructuralPotential (cache.cacheQuery input answer) secretKey ≤ + encodingStructuralPotential cache secretKey := Nat.add_le_add hstructural hstage + rw [encodingSelectionTotalPotential, if_neg hclean, + encodingSelectionTotalPotential, if_neg hbad] + exact min_le_min le_rfl (add_le_add (mul_le_mul' (Nat.cast_le.mpr hsum) le_rfl) hselection) + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_settled_le + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {position : Position} + (hfresh : cache input = none) (hat : AtPosition secretKey.parameter input position) + (hsettled : Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position) : + (∑' answer : HashOutput, Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ + encodingSelectionTotalPotential cache hfinite secretKey + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + classical + let targets : Finset Digest := + {honestValue (fromCache cache) secretKey.parameter secretKey.otsSecret secretKey.ftsSecret position} + calc + _ ≤ ∑' answer : HashOutput, Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (encodingSelectionTotalPotential cache hfinite secretKey + + if truncateHash answer ∈ targets then 1 else 0) := by + apply ENNReal.tsum_le_tsum + intro answer + apply mul_le_mul' le_rfl + by_cases hhit : truncateHash answer ∈ targets + · rw [if_pos hhit] + exact (encodingSelectionTotalPotential_le_one _ secretKey).trans (le_add_left le_rfl) + · rw [if_neg hhit, add_zero] + exact encodingSelectionTotalPotential_cacheQuery_le_of_settled_of_avoids hfinite hfresh + hat hsettled (by simpa only [targets, Finset.mem_singleton] using hhit) + _ = _ := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul, + uniformHashOutput_mem_bonus_sum_eq] + simp [targets] + +noncomputable def refinedStructuralEncodingQueryCharge (secretKey : SecretKey) + (cache : QueryCache HashSpec) (input : HashInput) : ℝ≥0∞ := + open Classical in + if cache input = none then + if hencoding : ∃ position : EncodingPosition, AtEncodingPosition secretKey.parameter input position then + ((encodingStageIncrement cache secretKey (Classical.choose hencoding) + 1 : Nat) : ℝ≥0∞) + else if ∃ position : Position, AtPosition secretKey.parameter input position ∧ + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache position then 1 + else if ∃ position : Position, AtPosition secretKey.parameter input position ∧ + ∀ answer : HashOutput, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) position then 0 + else if ∃ position : Position, AtPosition secretKey.parameter input position ∧ + ∀ child ∈ position.children, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache child then 1 + else structuralEncodingQueryCharge secretKey.parameter input + else 0 + +theorem refinedStructuralEncodingQueryCharge_le_three (secretKey : SecretKey) + (cache : QueryCache HashSpec) (input : HashInput) : + refinedStructuralEncodingQueryCharge secretKey cache input ≤ 3 := by + classical + unfold refinedStructuralEncodingQueryCharge + split_ifs with hfresh hencoding hsettled hsettles hchildren + · unfold encodingStageIncrement + split_ifs <;> norm_num + · norm_num + · norm_num + · norm_num + · unfold structuralEncodingQueryCharge + split_ifs <;> norm_num + · norm_num + +theorem refinedStructuralEncodingQueryCharge_le_one_of_children_settled + (secretKey : SecretKey) (cache : QueryCache HashSpec) (input : HashInput) (position : Position) + (hat : AtPosition secretKey.parameter input position) + (hchildren : ∀ child ∈ position.children, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache child) : + refinedStructuralEncodingQueryCharge secretKey cache input ≤ 1 := by + classical + have hnotEncoding : ¬ ∃ candidate : EncodingPosition, + AtEncodingPosition secretKey.parameter input candidate := + fun ⟨candidate, hencoding⟩ => hencoding.not_atPosition position hat + have hsomeChildren : ∃ candidate : Position, AtPosition secretKey.parameter input candidate ∧ + ∀ child ∈ candidate.children, + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache child := + ⟨position, hat, hchildren⟩ + unfold refinedStructuralEncodingQueryCharge + split_ifs <;> simp_all only [zero_le_one, le_refl] + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_le_refined_charge + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} (hfresh : cache input = none) : + (∑' answer : HashOutput, Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ + encodingSelectionTotalPotential cache hfinite secretKey + + refinedStructuralEncodingQueryCharge secretKey cache input * + (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + classical + rw [refinedStructuralEncodingQueryCharge, if_pos hfresh] + split_ifs with hencoding hsettled hsettles hchildren + · exact uniform_encodingSelectionTotalPotential_cacheQuery_le_stage_increment + hfinite hfresh (Classical.choose_spec hencoding) + · obtain ⟨position, hat, hposition⟩ := hsettled + rw [one_mul] + exact uniform_encodingSelectionTotalPotential_cacheQuery_settled_le hfinite hfresh hat hposition + · obtain ⟨position, hat, hafter⟩ := hsettles + rw [zero_mul, add_zero] + by_cases hbad : Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + · have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = 1 := by + rw [encodingSelectionTotalPotential, if_pos hbad] + rw [hbefore] + exact expected_encodingSelectionTotalPotential_le_one hfinite secretKey input + · exact uniform_encodingSelectionTotalPotential_cacheQuery_le_of_settlingPosition + hfinite hbad hfresh hat (fun hposition => hsettled ⟨position, hat, hposition⟩) hafter + · obtain ⟨position, hat, hchildren⟩ := hchildren + rw [one_mul] + apply uniform_encodingSelectionTotalPotential_cacheQuery_le_one_of_children_settled + hfinite hfresh hat hchildren + intro answer hafter + exact hsettles ⟨position, hat, settled_cacheQuery_of_settled_cacheQuery secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret hfresh hat + (fun hposition => hsettled ⟨position, hat, hposition⟩) hafter⟩ + · exact uniform_encodingSelectionTotalPotential_cacheQuery_le_charge hfinite hfresh + +end SphincsSecurity.Concrete.TightEncoding diff --git a/formal/sphincs/SphincsSecurity/Proof/TightEncodingSettlement.lean b/formal/sphincs/SphincsSecurity/Proof/TightEncodingSettlement.lean new file mode 100644 index 00000000..c1673c16 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TightEncodingSettlement.lean @@ -0,0 +1,115 @@ +import SphincsSecurity.Proof.TightChargePotential +import SphincsSecurity.Proof.EncodingSelectionPotential + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem PrematureLayerMessageSettlement.mem_tightSettlingTargets + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {answer : HashOutput} + (huncached : cache input = none) + (hpremature : PrematureLayerMessageSettlement cache secretKey input answer) : + ∃ queriedPosition : Position, + AtPosition secretKey.parameter input queriedPosition ∧ + ¬ Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + cache queriedPosition ∧ + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) queriedPosition ∧ + truncateHash answer ∈ + tightSettlingTargets secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache hfinite queriedPosition := by + obtain ⟨encodingPosition, index, htree, hleaf, htargetUnsettled, + htargetSettled, hnotTarget⟩ := hpremature + let targetPosition := layerMessagePosition index encodingPosition.lay + have htargetUnsettled' : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache targetPosition := by + simpa only [targetPosition] using htargetUnsettled + have htargetSettled' : Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (cache.cacheQuery input answer) targetPosition := by + simpa only [targetPosition] using htargetSettled + have hnotTarget' : ¬ AtPosition secretKey.parameter input targetPosition := by + simpa only [targetPosition] using hnotTarget + have hat : ∃ queriedPosition, AtPosition secretKey.parameter input queriedPosition := by + by_contra hnone + apply htargetUnsettled' + exact settled_of_settled_cacheQuery secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret huncached (p₀ := none) + (fun position hposition => (hnone ⟨position, hposition⟩).elim) + (by simp) (targetPosition.depth + 1) targetPosition (by omega) (by simp) + htargetSettled' + obtain ⟨queriedPosition, hqueried⟩ := hat + have hqueriedNe : queriedPosition ≠ targetPosition := by + intro heq + exact hnotTarget' (heq ▸ hqueried) + have hqueriedUnsettled : ¬ Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret cache queriedPosition := by + intro hsettled + apply htargetUnsettled' + exact settled_of_cacheQuery_at_settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret huncached hqueried hsettled + (targetPosition.depth + 1) targetPosition (by omega) htargetSettled' + have hpositionRule : ∀ position, + AtPosition secretKey.parameter input position → + some queriedPosition = some position := by + intro position hposition + exact congrArg some (atPosition_unique secretKey.parameter hqueried hposition) + obtain ⟨parent, hparent, hparentSettled⟩ : ∃ parent, + queriedPosition.parentOf = some parent ∧ + Settled secretKey.parameter secretKey.otsSecret secretKey.ftsSecret + (cache.cacheQuery input answer) parent := by + cases hparent : queriedPosition.parentOf with + | none => + exfalso + apply htargetUnsettled' + exact settled_of_settled_cacheQuery secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret huncached (p₀ := some queriedPosition) hpositionRule + (by + intro position parent heq hparent' + have hpositionEq : position = queriedPosition := Option.some.inj heq.symm + subst position + rw [hparent] at hparent' + simp at hparent') + (targetPosition.depth + 1) targetPosition (by omega) + (by + intro heq + exact hqueriedNe (Option.some.inj heq)) htargetSettled' + | some parent => + by_cases hsettledParent : Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (cache.cacheQuery input answer) parent + · exact ⟨parent, rfl, hsettledParent⟩ + · exfalso + apply htargetUnsettled' + exact settled_of_settled_cacheQuery secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret huncached (p₀ := some queriedPosition) hpositionRule + (by + intro position candidateParent heq hparent' + have hpositionEq : position = queriedPosition := Option.some.inj heq.symm + subst position + rw [hparent] at hparent' + have : candidateParent = parent := Option.some.inj hparent'.symm + subst candidateParent + exact hsettledParent) + (targetPosition.depth + 1) targetPosition (by omega) + (by + intro heq + exact hqueriedNe (Option.some.inj heq)) htargetSettled' + have hchild : queriedPosition ∈ parent.children := + Position.mem_children_iff.mpr hparent + have hqueriedSettled : Settled secretKey.parameter secretKey.otsSecret + secretKey.ftsSecret (cache.cacheQuery input answer) queriedPosition := + hparentSettled.children queriedPosition hchild + have hslot : truncateHash answer ∈ slotTargets secretKey.parameter cache hfinite + queriedPosition parent := by + by_contra havoid + exact (not_settled_parent_of_avoids_slotTargets secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret hfinite huncached hqueried + hqueriedUnsettled hqueriedSettled hchild havoid) hparentSettled + refine ⟨queriedPosition, hqueried, hqueriedUnsettled, hqueriedSettled, ?_⟩ + have hother := otherChildrenSettled_of_parent_settled_cacheQuery secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret huncached hqueried hchild hparentSettled + simp only [tightSettlingTargets, hparent] + rw [if_pos hother] + exact Finset.mem_union_right _ hslot + + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/TightEncodingStageCost.lean b/formal/sphincs/SphincsSecurity/Proof/TightEncodingStageCost.lean new file mode 100644 index 00000000..a160ee63 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TightEncodingStageCost.lean @@ -0,0 +1,162 @@ +import SphincsSecurity.Proof.TightEncodingSelectionPotential + +namespace SphincsSecurity.Concrete.TightEncoding + +open OracleComp OracleSpec ENNReal + +noncomputable def encodingStageIncrement (cache : QueryCache HashSpec) + (secretKey : SecretKey) (position : EncodingPosition) : Nat := + open Classical in + if HasEncodingTarget cache secretKey position then 0 + else if EncodingMessageSettledAt cache secretKey position then 1 + else 2 + +theorem encodingStageContribution_cacheQuery_le_increment + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} {position : EncodingPosition} + (hfresh : cache input = none) (hat : AtEncodingPosition secretKey.parameter input position) : + encodingStageContribution (cache.cacheQuery input answer) secretKey position ≤ + encodingStageContribution cache secretKey position + encodingStageIncrement cache secretKey position := by + classical + have hle := le_cacheQuery (cache := cache) (input := input) (answer := answer) hfresh + rw [encodingStageIncrement] + by_cases htarget : HasEncodingTarget cache secretKey position + · rw [if_pos htarget] + simp [encodingStageContribution, htarget, htarget.mono hle] + · rw [if_neg htarget] + by_cases hmessage : EncodingMessageSettledAt cache secretKey position + · rw [if_pos hmessage] + have hcard : (encodingCachedAt secretKey.parameter (cache.cacheQuery input answer) position).ncard ≤ + (encodingCachedAt secretKey.parameter cache position).ncard + 1 := by + rw [encodingCachedAt_cacheQuery_self hat] + exact Set.ncard_insert_le _ _ + rw [encodingStageContribution, encodingStageContribution, if_neg htarget, if_pos hmessage] + rw [if_pos (hmessage.mono hle)] + split_ifs with hafter + · exact Nat.zero_le _ + · exact hcard + · rw [if_neg hmessage] + exact encodingStageContribution_cacheQuery_le_of_atPosition hfresh hat + +set_option maxRecDepth 10000 in +theorem encodingStagePotential_cacheQuery_le_increment + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} {position : EncodingPosition} + (hfresh : cache input = none) (hat : AtEncodingPosition secretKey.parameter input position) : + encodingStagePotential (cache.cacheQuery input answer) secretKey ≤ + encodingStagePotential cache secretKey + encodingStageIncrement cache secretKey position := by + classical + rw [encodingStagePotential, encodingStagePotential] + calc + _ ≤ ∑ candidate : EncodingPosition, + (encodingStageContribution cache secretKey candidate + + if candidate = position then encodingStageIncrement cache secretKey position else 0) := by + apply Finset.sum_le_sum + intro candidate _ + by_cases heq : candidate = position + · rw [heq, if_pos rfl] + exact encodingStageContribution_cacheQuery_le_increment (answer := answer) hfresh hat + · rw [if_neg heq, Nat.add_zero] + exact encodingStageContribution_cacheQuery_le_of_not_atPosition hfresh + (fun hc => heq (atEncodingPosition_unique hc hat)) + _ = _ := by rw [Finset.sum_add_distrib, Fintype.sum_ite_eq'] + +theorem encodingStructuralPotential_cacheQuery_le_increment + {cache : QueryCache HashSpec} {secretKey : SecretKey} + {input : HashInput} {answer : HashOutput} {position : EncodingPosition} + (hclean : ¬ Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache) + (hfresh : cache input = none) (hat : AtEncodingPosition secretKey.parameter input position) : + encodingStructuralPotential (cache.cacheQuery input answer) secretKey ≤ + encodingStructuralPotential cache secretKey + encodingStageIncrement cache secretKey position := by + have hstructural := + (clean_and_tightPotential_cacheQuery_of_not_atPosition secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret (answer := answer) hclean hfresh + (fun structural hstructural => hat.not_atPosition structural hstructural)).2 + have hstage := encodingStagePotential_cacheQuery_le_increment (answer := answer) hfresh hat + rw [encodingStructuralPotential, encodingStructuralPotential] + omega + +theorem uniform_encodingSelectionTotalPotential_cacheQuery_le_stage_increment + {cache : QueryCache HashSpec} (hfinite : Finite cache) + {secretKey : SecretKey} {input : HashInput} {position : EncodingPosition} + (huncached : cache input = none) + (hposition : AtEncodingPosition secretKey.parameter input position) : + (∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionTotalPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) ≤ + encodingSelectionTotalPotential cache hfinite secretKey + + ((encodingStageIncrement cache secretKey position + 1 : Nat) : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + let eps := (Fintype.card Digest : ℝ≥0∞)⁻¹ + by_cases hbad : Bad secretKey.parameter secretKey.otsSecret secretKey.ftsSecret cache + · have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = 1 := by + rw [encodingSelectionTotalPotential, if_pos hbad] + rw [hbefore] + exact (expected_encodingSelectionTotalPotential_le_one hfinite secretKey input).trans + (le_add_right le_rfl) + · let uncapped := (encodingStructuralPotential cache secretKey : ℝ≥0∞) * eps + + encodingSelectionPotential cache hfinite secretKey + by_cases hone : 1 ≤ uncapped + · calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * 1 := by + apply ENNReal.tsum_le_tsum + intro answer + exact mul_le_mul_right + (encodingSelectionTotalPotential_le_one _ secretKey) _ + _ = 1 := by + simp only [mul_one, tsum_probOutput_of_liftM_PMF] + _ = encodingSelectionTotalPotential cache hfinite secretKey := by + rw [encodingSelectionTotalPotential, if_neg hbad, min_eq_left] + simpa only [uncapped] using hone + _ ≤ encodingSelectionTotalPotential cache hfinite secretKey + ((encodingStageIncrement cache secretKey position + 1 : Nat) : ℝ≥0∞) * eps := + le_add_right le_rfl + · have huncappedLe : uncapped ≤ 1 := le_of_not_ge hone + have hbefore : encodingSelectionTotalPotential cache hfinite secretKey = uncapped := by + rw [encodingSelectionTotalPotential, if_neg hbad, min_eq_right] + exact huncappedLe + calc + _ ≤ ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + (((encodingStructuralPotential cache secretKey + encodingStageIncrement cache secretKey position : Nat) : ℝ≥0∞) * eps + + encodingSelectionPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey) := by + apply ENNReal.tsum_le_tsum + intro answer + apply mul_le_mul_right + have hcleanAfter := + (clean_and_tightPotential_cacheQuery_of_not_atPosition secretKey.parameter + secretKey.otsSecret secretKey.ftsSecret (answer := answer) hbad huncached + (fun structuralPosition hat => hposition.not_atPosition structuralPosition hat)).1 + refine (encodingSelectionTotalPotential_le_uncapped _ secretKey hcleanAfter).trans ?_ + have hstructuralNat := + encodingStructuralPotential_cacheQuery_le_increment + (answer := answer) hbad huncached hposition + have hstructural : + (encodingStructuralPotential (cache.cacheQuery input answer) + secretKey : ℝ≥0∞) ≤ + ((encodingStructuralPotential cache secretKey + encodingStageIncrement cache secretKey position : Nat) : ℝ≥0∞) := + Nat.cast_le.mpr hstructuralNat + exact add_le_add (mul_le_mul_left hstructural eps) le_rfl + _ = (((encodingStructuralPotential cache secretKey + encodingStageIncrement cache secretKey position : Nat) : ℝ≥0∞) * eps) + + ∑' answer : HashOutput, + Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] * + encodingSelectionPotential (cache.cacheQuery input answer) + (finite_cacheQuery hfinite input answer) secretKey := by + simp_rw [mul_add] + rw [ENNReal.tsum_add, ENNReal.tsum_mul_right, + tsum_probOutput_of_liftM_PMF, one_mul] + _ ≤ (((encodingStructuralPotential cache secretKey + encodingStageIncrement cache secretKey position : Nat) : ℝ≥0∞) * eps) + + (encodingSelectionPotential cache hfinite secretKey + eps) := by + exact add_le_add le_rfl + (uniform_encodingSelectionPotential_cacheQuery_atPosition_sum_le + (cache := cache) (secretKey := secretKey) (input := input) + (position := position) hfinite huncached hposition) + _ = uncapped + ((encodingStageIncrement cache secretKey position + 1 : Nat) : ℝ≥0∞) * eps := by + simp only [Nat.cast_add, Nat.cast_one] + dsimp only [uncapped] + ring + _ = encodingSelectionTotalPotential cache hfinite secretKey + ((encodingStageIncrement cache secretKey position + 1 : Nat) : ℝ≥0∞) * eps := by + rw [hbefore] + +end SphincsSecurity.Concrete.TightEncoding diff --git a/formal/sphincs/SphincsSecurity/Proof/TightEncodingTerminal.lean b/formal/sphincs/SphincsSecurity/Proof/TightEncodingTerminal.lean new file mode 100644 index 00000000..94788fd0 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TightEncodingTerminal.lean @@ -0,0 +1,81 @@ +import SphincsSecurity.Proof.TightEncodingSelectionLift +import SphincsSecurity.Proof.EncodingTerminalView + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +theorem probEvent_clean_viewedEncodingCollision_le_three_mul + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) + (hq : (gameAfterSecrets adversary parameter otsSecret ftsSecret).IsQueryBoundP + (· matches Sum.inr _) q) : + Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + (3 * q : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + let accountingKey : SecretKey := ⟨parameter, default, otsSecret, ftsSecret⟩ + calc + _ ≤ Pr[fun result => ¬Bad parameter otsSecret ftsSecret result.2.cache ∧ + EncodingBad result.2.cache accountingKey | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + apply probEvent_mono + intro result _ hevent + refine ⟨hevent.1, ?_⟩ + exact (encodingBad_mk_root_iff parameter otsSecret ftsSecret result.2.cache + result.1.1 default).mp hevent.2.encodingBad + _ = Pr[fun result : Bool × QueryCache HashSpec => + ¬Bad parameter otsSecret ftsSecret result.2 ∧ EncodingBad result.2 accountingKey | + (fun result => (result.1.2.2, result.2.cache)) <$> + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + rw [probEvent_map] + rfl + _ = Pr[fun result : Bool × QueryCache HashSpec => + ¬Bad parameter otsSecret ftsSecret result.2 ∧ EncodingBad result.2 accountingKey | + (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅] := by + rw [gameAfterSecretsWithViewTrace_verdictCache_projection] + _ ≤ _ := TightEncoding.probEvent_clean_encodingBad_simulateQ_le + (gameAfterSecrets adversary parameter otsSecret ftsSecret) q hq accountingKey + + +theorem probEvent_bad_or_viewedEncodingCollision_le_three_mul + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (q : Nat) + (hq : (gameAfterSecrets adversary parameter otsSecret ftsSecret).IsQueryBoundP + (· matches Sum.inr _) q) : + Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache ∨ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] ≤ + (3 * q : ℝ≥0∞) * (Fintype.card Digest : ℝ≥0∞)⁻¹ := by + let accountingKey : SecretKey := ⟨parameter, default, otsSecret, ftsSecret⟩ + calc + _ ≤ Pr[fun result => Bad parameter otsSecret ftsSecret result.2.cache ∨ + EncodingBad result.2.cache accountingKey | + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + apply probEvent_mono + intro result _ hevent + rcases hevent with hbad | hencoding + · exact Or.inl hbad + · exact Or.inr ((encodingBad_mk_root_iff parameter otsSecret ftsSecret result.2.cache + result.1.1 default).mp hencoding.encodingBad) + _ = Pr[fun result : Bool × QueryCache HashSpec => + Bad parameter otsSecret ftsSecret result.2 ∨ EncodingBad result.2 accountingKey | + (fun result => (result.1.2.2, result.2.cache)) <$> + gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret] := by + rw [probEvent_map] + rfl + _ = Pr[fun result : Bool × QueryCache HashSpec => + Bad parameter otsSecret ftsSecret result.2 ∨ EncodingBad result.2 accountingKey | + (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅] := by + rw [gameAfterSecretsWithViewTrace_verdictCache_projection] + _ ≤ _ := TightEncoding.probEvent_bad_or_encodingBad_simulateQ_le + (gameAfterSecrets adversary parameter otsSecret ftsSecret) q hq accountingKey + + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/TracedGame.lean b/formal/sphincs/SphincsSecurity/Proof/TracedGame.lean new file mode 100644 index 00000000..ea7235d7 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/TracedGame.lean @@ -0,0 +1,142 @@ +import SphincsSecurity.Proof.SigningTrace +import SphincsSecurity.Proof.OneTimeEvents + +/-! +# The game with signer cache intervals retained + +This is an observational refinement of the original game. Projecting away the forgery and signing +trace gives exactly the original verdict and final random-oracle cache. +-/ + +namespace SphincsSecurity + +open OracleComp OracleSpec + +noncomputable def gameRestWithSigningTrace (adversary : Adversary) + (publicKey : PublicKey) (secretKey : SecretKey) (initialCache : QueryCache HashSpec) : + ProbComp ((Forgery × Bool) × (QueryCache HashSpec × SigningCacheTrace)) := do + let (forgery, adversaryCache, trace) ← + (simulateQ (cacheTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run (initialCache, []) + let (verified, finalCache) ← + (simulateQ romImpl (Concrete.scheme.verify publicKey forgery.message forgery.signature)).run + adversaryCache + let log := trace.toSigningLog + let verdict := decide (SigningTranscript.Valid log ∧ + ¬ SigningTranscript.Contains log forgery) && verified + pure ((forgery, verdict), (finalCache, trace)) + +theorem gameRestWithSigningTrace_projection (adversary : Adversary) + (publicKey : PublicKey) (secretKey : SecretKey) (initialCache : QueryCache HashSpec) : + (fun result => (result.1.2, result.2.1)) <$> + gameRestWithSigningTrace adversary publicKey secretKey initialCache = + (simulateQ romImpl (gameRest Concrete.scheme adversary publicKey secretKey)).run + initialCache := by + let finish : Forgery × (QueryCache HashSpec × QueryLog SigningSpec) → + ProbComp (Bool × QueryCache HashSpec) := fun result => do + let (verified, finalCache) ← + (simulateQ romImpl + (Concrete.scheme.verify publicKey result.1.message result.1.signature)).run result.2.1 + pure (decide (SigningTranscript.Valid result.2.2 ∧ + ¬ SigningTranscript.Contains result.2.2 result.1) && verified, finalCache) + let traceRun := (simulateQ (cacheTracedMappedAdversaryImpl secretKey) + (adversary.main publicKey)).run (initialCache, []) + let mappedRun := (((simulateQ (mappedAdversaryImpl secretKey) + (adversary.main publicKey)).run).run initialCache) + have hprojection : + Prod.map id (fun state => (state.1, state.2.toSigningLog)) <$> traceRun = + (fun result => (result.1.1, (result.2, result.1.2))) <$> mappedRun := + cacheTracedMappedAdversaryImpl_log_projection_eq_mapped secretKey + (adversary.main publicKey) initialCache + calc + (fun result => (result.1.2, result.2.1)) <$> + gameRestWithSigningTrace adversary publicKey secretKey initialCache = + (Prod.map id (fun state => (state.1, state.2.toSigningLog)) <$> traceRun) >>= finish := by + simp [gameRestWithSigningTrace, traceRun, finish, bind_map_left, map_bind, Prod.map] + rfl + _ = ((fun result => (result.1.1, (result.2, result.1.2))) <$> mappedRun) >>= finish := by + rw [hprojection] + _ = (simulateQ romImpl (gameRest Concrete.scheme adversary publicKey secretKey)).run + initialCache := by + simp [gameRest, mappedRun, mappedAdversaryImpl, finish, bind_map_left, + QueryImpl.simulateQ_writerTMapBase_run] + +theorem gameRestWithSigningTrace_support_invariants (adversary : Adversary) + (publicKey : PublicKey) (secretKey : SecretKey) (initialCache : QueryCache HashSpec) + (result : (Forgery × Bool) × (QueryCache HashSpec × SigningCacheTrace)) + (hmem : result ∈ support + (gameRestWithSigningTrace adversary publicKey secretKey initialCache)) : + result.2.2.ValidRuns secretKey ∧ result.2.2.CachesLe result.2.1 + ∧ result.2.2.Chronological := by + rw [gameRestWithSigningTrace, mem_support_bind_iff] at hmem + obtain ⟨⟨forgery, adversaryCache, trace⟩, hadversary, hfinish⟩ := hmem + rw [mem_support_bind_iff] at hfinish + obtain ⟨⟨verified, finalCache⟩, hverify, hpure⟩ := hfinish + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + have hvalid := cacheTracedMappedAdversaryImpl_validRuns secretKey + (adversary.main publicKey) initialCache [] (forgery, adversaryCache, trace) + (by simp [SigningCacheTrace.ValidRuns]) hadversary + have hcachesChronological := cacheTracedMappedAdversaryImpl_cachesLe_chronological secretKey + (adversary.main publicKey) initialCache [] (forgery, adversaryCache, trace) + (by simp [SigningCacheTrace.CachesLe]) (by simp [SigningCacheTrace.Chronological]) hadversary + exact ⟨hvalid, hcachesChronological.1.mono + (simulateQ_romImpl_cache_le + (Concrete.scheme.verify publicKey forgery.message forgery.signature) + adversaryCache (verified, finalCache) hverify), + hcachesChronological.2⟩ + +namespace Concrete + +noncomputable def gameAfterSecretsWithSigningTrace (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + ProbComp ((Digest × Forgery × Bool) × (QueryCache HashSpec × SigningCacheTrace)) := do + let (root, rootCache) ← (simulateQ romImpl + (liftM ((treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : + OracleComp HashSpec Digest)) : + OracleComp OracleWorld Digest)).run ∅ + let result ← gameRestWithSigningTrace adversary ⟨root, parameter⟩ + ⟨parameter, root, otsSecret, ftsSecret⟩ rootCache + pure ((root, result.1.1, result.1.2), result.2) + +theorem gameAfterSecretsWithSigningTrace_projection (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + (fun result => (result.1.2.2, result.2.1)) <$> + gameAfterSecretsWithSigningTrace adversary parameter otsSecret ftsSecret = + (simulateQ romImpl (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run ∅ := by + rw [gameAfterSecretsWithSigningTrace, gameAfterSecrets, simulateQ_bind, StateT.run_bind] + simp only [map_bind] + apply bind_congr + intro rootResult + rw [← gameRestWithSigningTrace_projection adversary + (⟨rootResult.1, parameter⟩ : PublicKey) + (⟨parameter, rootResult.1, otsSecret, ftsSecret⟩ : SecretKey) rootResult.2] + simp + +theorem gameAfterSecretsWithSigningTrace_support_invariants (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × (QueryCache HashSpec × SigningCacheTrace)) + (hmem : result ∈ support + (gameAfterSecretsWithSigningTrace adversary parameter otsSecret ftsSecret)) : + let secretKey : SecretKey := ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ + result.2.2.ValidRuns secretKey ∧ result.2.2.CachesLe result.2.1 + ∧ result.2.2.Chronological := by + rw [gameAfterSecretsWithSigningTrace, mem_support_bind_iff] at hmem + obtain ⟨⟨root, rootCache⟩, _, hrest⟩ := hmem + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult, hrest, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + simpa using gameRestWithSigningTrace_support_invariants adversary + (⟨root, parameter⟩ : PublicKey) + (⟨parameter, root, otsSecret, ftsSecret⟩ : SecretKey) rootCache restResult hrest + +end Concrete + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof/VerifierPrimitiveTerminal.lean b/formal/sphincs/SphincsSecurity/Proof/VerifierPrimitiveTerminal.lean new file mode 100644 index 00000000..188d124b --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/VerifierPrimitiveTerminal.lean @@ -0,0 +1,76 @@ +import SphincsSecurity.Proof.VerifierStructuralCollision +import SphincsSecurity.Proof.JointPrimitiveTerminal + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec ENNReal + +def verifierPrimitiveEvent (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : Prop := + result.1.2.2 = true ∧ + (ViewedVerifierStructuralCollision parameter otsSecret ftsSecret result ∨ + ViewedEncodingCollisionWitness parameter otsSecret ftsSecret result ∨ + ViewedWinningFreshLayerOpeningWitness parameter otsSecret ftsSecret result ∨ + ViewedWinningBackwardChainOpeningWitness parameter otsSecret ftsSecret result ∨ + ViewedUncoveredFtsSecretWitness parameter otsSecret ftsSecret result) + +theorem verifierPrimitiveEvent_implies_jointPrimitiveEvent + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hprimitive : verifierPrimitiveEvent parameter otsSecret ftsSecret result) : + jointPrimitiveEvent parameter otsSecret ftsSecret result := by + obtain ⟨hwin, hevent⟩ := hprimitive + refine ⟨hwin, ?_⟩ + by_cases hbad : Bad parameter otsSecret ftsSecret result.2.cache + · exact Or.inl hbad + rcases hevent with hcollision | hencoding | hfresh | hbackward | huncovered + · exact (hbad hcollision.bad).elim + · exact Or.inr (Or.inl hencoding) + · exact Or.inr (Or.inr (Or.inl (Or.inl ⟨⟨hbad, hwin⟩, hfresh⟩))) + · exact Or.inr (Or.inr (Or.inl (Or.inr ⟨⟨hbad, hwin⟩, hbackward⟩))) + · exact Or.inr (Or.inr (Or.inr ⟨hbad, huncovered⟩)) + +theorem probEvent_win_le_verifierPrimitive_add_message_add_forest (adversary : Adversary) + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) : + let run := gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + Pr[= true | (simulateQ romImpl + (gameAfterSecrets adversary parameter otsSecret ftsSecret)).run' ∅] ≤ + Pr[verifierPrimitiveEvent parameter otsSecret ftsSecret | run] + + (Pr[ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret | run] + + Pr[ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret | run]) := by + classical + dsimp only + let run := gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret + let primitive := verifierPrimitiveEvent parameter otsSecret ftsSecret + let message := ViewedMessageDigestCollisionWitness parameter otsSecret ftsSecret + let forest := ViewedHonestProperFewTimeLeakWitness parameter otsSecret ftsSecret + calc + _ = Pr[fun result => result.1.2.2 = true | run] := by + rw [StateT.run'_eq, ← probEvent_eq_eq_probOutput, + ← gameAfterSecretsWithViewTrace_verdictCache_projection adversary parameter otsSecret + ftsSecret, probEvent_map] + rw [probEvent_map] + rfl + _ ≤ Pr[fun result => primitive result ∨ message result ∨ forest result | run] := by + apply probEvent_mono + intro result hresult hwin + rcases gameAfterSecretsWithViewTrace_winning_usedCollision_classify adversary + parameter otsSecret ftsSecret result hresult hwin with hcollision | hterminal + · exact Or.inl ⟨hwin, Or.inl hcollision⟩ + · rcases viewedWinningHonestLeakTerminalWitness_cases parameter otsSecret ftsSecret + result hterminal with hfresh | hencoding | hbackward | hmessage | hforest | huncovered + · exact Or.inl ⟨hwin, Or.inr (Or.inr (Or.inl hfresh))⟩ + · exact Or.inl ⟨hwin, Or.inr (Or.inl hencoding)⟩ + · exact Or.inl ⟨hwin, Or.inr (Or.inr (Or.inr (Or.inl hbackward)))⟩ + · exact Or.inr (Or.inl hmessage) + · exact Or.inr (Or.inr hforest) + · exact Or.inl ⟨hwin, Or.inr (Or.inr (Or.inr (Or.inr huncovered)))⟩ + _ ≤ _ := (probEvent_or_le _ _ _).trans (add_le_add le_rfl (probEvent_or_le _ _ _)) + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Proof/VerifierStructuralCollision.lean b/formal/sphincs/SphincsSecurity/Proof/VerifierStructuralCollision.lean new file mode 100644 index 00000000..90678866 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/VerifierStructuralCollision.lean @@ -0,0 +1,216 @@ +import SphincsSecurity.Proof.RetainedForgeryClassify +import SphincsSecurity.Proof.FewTimeHonestLeakTerminal + +namespace SphincsSecurity.Concrete + +open OracleComp OracleSpec + +def ViewedVerifierStructuralCollision (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : Prop := + result.1.2.2 = true ∧ ∃ f : QueryImpl HashSpec Id, + result.2.cache.AgreesWithFn f ∧ + evalWithAnswerFn f + (verify ⟨result.1.1, parameter⟩ result.1.2.1.message result.1.2.1.signature) = true ∧ + CachedRun result.2.cache f + (verify ⟨result.1.1, parameter⟩ result.1.2.1.message result.1.2.1.signature) ∧ + BadOnInputs ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ result.2.cache + {input | input ∈ queriedInputs f + (verify ⟨result.1.1, parameter⟩ result.1.2.1.message result.1.2.1.signature)} + +theorem ViewedVerifierStructuralCollision.bad + {parameter : PublicParameter} + {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest} + {ftsSecret : Index → FtsTree → FtsLeaf → Digest} + {result : (Digest × Forgery × Bool) × ViewedFullTraceState} + (hcollision : ViewedVerifierStructuralCollision parameter otsSecret ftsSecret result) : + Bad parameter otsSecret ftsSecret result.2.cache := by + obtain ⟨_, _, _, _, _, hbad⟩ := hcollision + exact hbad.bad + +theorem viewedVerifierStructuralCollision_iff_fromCache + (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) : + ViewedVerifierStructuralCollision parameter otsSecret ftsSecret result ↔ + result.1.2.2 = true ∧ + evalWithAnswerFn (fromCache result.2.cache) + (verify ⟨result.1.1, parameter⟩ result.1.2.1.message result.1.2.1.signature) = true ∧ + CachedRun result.2.cache (fromCache result.2.cache) + (verify ⟨result.1.1, parameter⟩ result.1.2.1.message result.1.2.1.signature) ∧ + BadOnInputs ⟨parameter, result.1.1, otsSecret, ftsSecret⟩ result.2.cache + {input | input ∈ queriedInputs (fromCache result.2.cache) + (verify ⟨result.1.1, parameter⟩ result.1.2.1.message result.1.2.1.signature)} := by + have hg := agreesWithFn_fromCache result.2.cache + constructor + · rintro ⟨hwin, f, hf, heval, hrun, hbad⟩ + refine ⟨hwin, (hrun.eval_eq hf hg).symm.trans heval, hrun.changeAnswerFn hf hg, ?_⟩ + simpa only [hrun.queriedInputs_eq hf hg] using hbad + · rintro ⟨hwin, heval, hrun, hbad⟩ + exact ⟨hwin, fromCache result.2.cache, hg, heval, hrun, hbad⟩ + +theorem gameAfterSecretsWithViewTrace_winning_usedCollision_classify + (adversary : Adversary) (parameter : PublicParameter) + (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) + (result : (Digest × Forgery × Bool) × ViewedFullTraceState) + (hresult : result ∈ support + (gameAfterSecretsWithViewTrace adversary parameter otsSecret ftsSecret)) + (hwin : result.1.2.2 = true) : + ViewedVerifierStructuralCollision parameter otsSecret ftsSecret result ∨ + ViewedWinningTerminalWitnessFor parameter otsSecret ftsSecret + HonestLeakTerminalForgeryEvent result := by + rw [gameAfterSecretsWithViewTrace, mem_support_bind_iff] at hresult + obtain ⟨⟨root, rootCache⟩, hroot, hrest⟩ := hresult + rw [mem_support_bind_iff] at hrest + obtain ⟨restResult, hrest, hpure⟩ := hrest + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst result + rw [gameRestWithViewTrace, mem_support_bind_iff] at hrest + obtain ⟨⟨forgery, state⟩, hadversary, hfinish⟩ := hrest + rw [mem_support_bind_iff] at hfinish + obtain ⟨⟨⟨verified, targetView⟩, finalCache⟩, hverifyView, hpure⟩ := hfinish + simp only [support_pure, Set.mem_singleton_iff] at hpure + subst restResult + have hverified : verified = true := by + cases verified <;> simp_all + subst verified + have htranscript : SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery := by + have h := (show (SigningTranscript.Valid state.trace.signing.toSigningLog ∧ + ¬SigningTranscript.Contains state.trace.signing.toSigningLog forgery) ∧ True by + simpa only [Bool.and_eq_true, decide_eq_true_eq] using hwin) + exact h.1 + have hverify : (true, finalCache) ∈ support + ((simulateQ romImpl + (scheme.verify ⟨root, parameter⟩ forgery.message forgery.signature)).run state.cache) := by + rw [← simulateQ_verifyWithView_fst_run ⟨root, parameter⟩ forgery.message + forgery.signature state.cache, support_map] + exact ⟨((true, targetView), finalCache), hverifyView, rfl⟩ + obtain ⟨hverifyLe, f, hf, heval, hqueries⟩ := exists_answerFn_replay_of_mem_support + (verify ⟨root, parameter⟩ forgery.message forgery.signature) state.cache true finalCache + (by simpa only [scheme, simulateQ_romImpl_liftM] using hverify) + have hroot' : (root, rootCache) ∈ support + ((simulateQ (randomOracle : QueryImpl HashSpec _) + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))).run ∅) := by + simpa only [simulateQ_romImpl_liftM] using hroot + have hbaseAdversary : (forgery, state.base) ∈ support + ((simulateQ (fullTracedMappedAdversaryImpl + ⟨parameter, root, otsSecret, ftsSecret⟩) + (adversary.main ⟨root, parameter⟩)).run + (rootCache, ⟨[], [], []⟩)) := by + let initialState : ViewedFullTraceState := + ⟨rootCache, ⟨[], [], []⟩, [], none⟩ + have hprojection := viewedFullTracedMappedAdversaryImpl_projection + ⟨parameter, root, otsSecret, ftsSecret⟩ (adversary.main ⟨root, parameter⟩) + initialState + have hmapped : (forgery, state.base) ∈ support + (Prod.map id ViewedFullTraceState.base <$> + (simulateQ (viewedFullTracedMappedAdversaryImpl + ⟨parameter, root, otsSecret, ftsSecret⟩) + (adversary.main ⟨root, parameter⟩)).run initialState) := by + rw [support_map] + exact ⟨(forgery, state), by simpa only [initialState] using hadversary, rfl⟩ + rw [hprojection] at hmapped + simpa only [initialState, ViewedFullTraceState.base] using hmapped + have hchain : FullAdversaryTrace.CacheChain rootCache state.trace.intervals state.cache := + fullTracedMappedAdversaryImpl_cacheChain + ⟨parameter, root, otsSecret, ftsSecret⟩ (adversary.main ⟨root, parameter⟩) + rootCache rootCache ⟨[], [], []⟩ (forgery, state.base) rfl hbaseAdversary + have hvalidIntervals : state.trace.ValidIntervals + ⟨parameter, root, otsSecret, ftsSecret⟩ := + fullTracedMappedAdversaryImpl_validIntervals + ⟨parameter, root, otsSecret, ftsSecret⟩ (adversary.main ⟨root, parameter⟩) + rootCache ⟨[], [], []⟩ (forgery, state.base) + (by simp [FullAdversaryTrace.ValidIntervals]) hbaseAdversary + have hrootLe : rootCache ≤ finalCache := + (hchain.start_le_finish hvalidIntervals).trans hverifyLe + obtain ⟨hrootEval, hrootQueries⟩ := replay_of_mem_support_of_le + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree)) ∅ root rootCache finalCache + hroot' hrootLe f hf + have hrootSettled := settled_treeRoot_of_cachedRun + (otsSecret := otsSecret) (ftsSecret := ftsSecret) hf topLayer rootTree hrootQueries + let secretKey : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩ + let inputs : Set HashInput := {input | input ∈ queriedInputs f + (verify ⟨root, parameter⟩ forgery.message forgery.signature)} + let retained := retainHonestCache secretKey finalCache inputs + have hretainedLe : retained ≤ finalCache := retainHonestCache_le secretKey finalCache inputs + have hfRetained : retained.AgreesWithFn f := + retainHonestCache_agreesWithFn secretKey finalCache inputs f hf + have hpreserved := settled_retainHonestCache secretKey finalCache inputs + have hqueriesRetained : CachedRun retained f + (verify ⟨root, parameter⟩ forgery.message forgery.signature) := + cachedRun_retainHonestCache secretKey finalCache inputs f _ hqueries (fun _ h => h) + obtain ⟨digest, hdigest, hdigestRunSmall, hadmissible, hlayers, hftsRunSmall, hlayersRunSmall⟩ := + verify_extract ⟨root, parameter⟩ forgery.message forgery.signature heval hqueriesRetained + have hdigestRun := hdigestRunSmall.mono hretainedLe + have hftsRun := hftsRunSmall.mono hretainedLe + let index := digestIndex digest + let leaves := digestLeaves digest + let ftsPublicKey := evalWithAnswerFn f + (ftsRecover parameter index leaves forgery.signature.ftsSecret forgery.signature.ftsPath) + have hhypertree : HypertreeRun f retained parameter index forgery.signature + ftsPublicKey root := + hypertreeRun_of_verify index forgery.signature ftsPublicKey root hlayers hlayersRunSmall + have htarget : root = honestNode f parameter topLayer rootTree + (otsSecret topLayer rootTree) (layerHeight topLayer) 0 := by + rw [← hrootEval] + rfl + have htop := hypertree_top_extract_or_bad hfRetained index forgery.signature ftsPublicKey root + hhypertree htarget (by simpa using hpreserved _ hrootSettled) + rcases htop with hbad | htop + · apply Or.inl + exact ⟨hwin, f, hf, heval, hqueries, + (bad_retainHonestCache_iff secretKey finalCache inputs).mp hbad⟩ + · have hclassified := accepted_forgery_classify_retained f finalCache retained secretKey + state.trace.signing.toSigningLog index forgery.signature leaves ftsPublicKey root hf + hretainedLe hpreserved rfl + htop (by + have htree : treeIndexAt index topLayer = rootTree := by + apply Fin.ext + exact treeIndexAt_topLayer index + unfold LayerRootSettled + rw [htree] + simpa using hrootSettled) hftsRunSmall + rcases hclassified with hbad | hobstacle | hfull + · apply Or.inl + exact ⟨hwin, f, hf, heval, hqueries, + (bad_retainHonestCache_iff secretKey finalCache inputs).mp hbad⟩ + · rcases settledForgedLayerObstacle_classify f finalCache secretKey + state.trace.signing.toSigningLog index leaves forgery.signature hobstacle with + hfresh | hencoding | hbackward + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inl hfresh⟩ + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inl hencoding)⟩ + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inr (Or.inl hbackward))⟩ + · rcases fewTimeLeak_or_uncovered f finalCache secretKey state.trace.signing.toSigningLog + index leaves with hleak | ⟨tree, huncovered⟩ + · rcases fullyHonest_leak_classify f finalCache secretKey + state.trace.signing.toSigningLog forgery digest index leaves hdigest hdigestRun rfl rfl + hfull.1 htranscript.2 hleak with hcollision | hobstacle | hproper + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inr (Or.inr (Or.inl ⟨hcollision, hleak⟩)))⟩ + · rcases settledForgedLayerObstacle_classify f finalCache secretKey + state.trace.signing.toSigningLog index leaves forgery.signature + (hfull.settleObstacle hobstacle) with + hfresh | hencoding | hbackward + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inl hfresh⟩ + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inl hencoding)⟩ + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inr (Or.inl hbackward))⟩ + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inr (Or.inr (Or.inr (Or.inl ⟨hproper, hfull.1⟩))))⟩ + · exact Or.inr ⟨f, digest, hf, htranscript.1, htranscript.2, hdigest, + hadmissible, heval, Or.inr (Or.inr (Or.inr (Or.inr (Or.inr + ⟨tree, huncovered, (hfull.1.2.1 tree).1, by + apply hftsRun + exact ftsRecover_leaf_query_mem f parameter index leaves + forgery.signature.ftsSecret forgery.signature.ftsPath tree⟩))))⟩ + +end SphincsSecurity.Concrete diff --git a/formal/sphincs/SphincsSecurity/Statement.lean b/formal/sphincs/SphincsSecurity/Statement.lean new file mode 100644 index 00000000..5e2627d1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Statement.lean @@ -0,0 +1,884 @@ +import VCVio.OracleComp.QueryTracking.LoggingOracle +import VCVio.OracleComp.QueryTracking.RandomOracle.Simulation +import VCVio.OracleComp.QueryTracking.QueryBound + +/-! +# Classical random-oracle security of the concrete SPHINCS instance + +This single module is the reviewer-facing statement of what has to be proven. It contains everything the statement depends on: the concrete parameters and types, the byte layout of every hash input, the three algorithms exactly as run in the security experiment, the strong-unforgeability experiment, and the security claims `SphincsSecurity126Statement`, `SphincsSecurity125Statement` and `SphincsSecurityStatement`. Nothing here describes a reduction or an intermediate game, and nothing instantiates the hash: it is a random oracle throughout. What the concrete parameters fix about the layout is proven rather than asserted, each lemma sitting next to the definitions it concerns: the index decomposition of Section `The index`, and the authentication path next to `flattenPaths`. + +The instance is the one specified in `doc/sphincs/main.tex`: 32-byte messages, 128-bit digests truncated from a 256-bit random-oracle output, 42 Winternitz chains of length 8 at target sum 191, a hypertree of height 26 over 3 layers of heights 12, 7 and 7, and a few-time forest of 14 trees of `2^10` leaves selected by a 176-bit message digest. A key answers for all `2^26` indices and signs at most `2^24` messages. + +Three things differ from `formal/xmss`. The signer takes no epoch, this scheme being stateless, so a signing request is a message alone and what the game caps is the number of signing queries, at `signatureLimit`. Signing is randomized, a fresh `randomnessBits` string per digest attempt, so a message has many valid signatures and a second one on a signed message is a strong forgery. And the secret key holds the sampled secrets rather than precomputed tables, so signing recomputes through the random oracle whatever tree it reads, exactly as `Sig` is specified. + +The strengthened claim is `126` bits: every adversary with a whole-experiment hash-query bound `q` has forgery probability at most `q / 2^126`. The earlier `125`-bit and `120`-bit statements are retained; `securityBits` names the original `120`-bit exponent for compatibility with the earlier proof. All three statements use exactly the same algorithms, strong-unforgeability game and query accounting. `HasHashQueryBound` bounds every execution path, including key generation, signing and verification, rather than only adversarial hash calls. The theorem is in the classical random-oracle model with independently sampled secrets; equivalence to seed-derived secrets and an instantiation with BLAKE2s are outside this model. +-/ + +open OracleComp OracleSpec ENNReal + +namespace SphincsSecurity + +/-! ## The instance: parameters, types, and hash-input layout -/ + +def digestBits : Nat := 128 +def hashOutputBits : Nat := 256 +def messageBits : Nat := 256 +def publicParameterBits : Nat := 128 +def randomnessBits : Nat := 128 +def counterBits : Nat := 32 +def winternitzBits : Nat := 3 +def chainLength : Nat := 2 ^ winternitzBits +def numChains : Nat := 42 +def targetSum : Nat := 191 +def numLayers : Nat := 3 +def totalHeight : Nat := 26 +/-- The tallest layer, `h_0`, which bounds every layer's leaf index. -/ +def maxLayerHeight : Nat := 12 +def ftsTreeHeight : Nat := 10 +/-- The `k` index groups a digest carries. The forest holds `k - 1` trees, the last group being pinned to zero. -/ +def ftsTrees : Nat := 15 +/-- Signatures allowed per key pair, `q_s`. -/ +def signatureLimit : Nat := 2 ^ 24 +/-- Digest attempts per signature, `A_max`. -/ +def digestAttemptLimit : Nat := 2 ^ 32 +/-- Encoding counters tried per layer, `C_max`. -/ +def encodingAttemptLimit : Nat := 2 ^ 32 +/-- The original security level, retained for the earlier statement and proof. -/ +def securityBits : Nat := 120 + +abbrev Digest := BitVec digestBits +abbrev HashOutput := BitVec hashOutputBits +abbrev Message := BitVec messageBits +abbrev PublicParameter := BitVec publicParameterBits +abbrev Randomness := BitVec randomnessBits +abbrev Counter := BitVec counterBits +abbrev Layer := Fin numLayers +abbrev Index := Fin (2 ^ totalHeight) +abbrev TreeIndex := Fin (2 ^ totalHeight) +abbrev LeafIndex := Fin (2 ^ maxLayerHeight) +abbrev ChainIndex := Fin numChains +abbrev Digit := Fin chainLength +abbrev ChainStep := Fin (chainLength - 1) +/-- A tree of the few-time forest, `kappa < k - 1`. -/ +abbrev FtsTree := Fin (ftsTrees - 1) +/-- An index group of the message digest, `kappa < k`. -/ +abbrev DigestTree := Fin ftsTrees +abbrev FtsLeaf := Fin (2 ^ ftsTreeHeight) +/-- A position in the signature's authentication path, the `h` nodes of the `d` layers concatenated top layer first. -/ +abbrev PathIndex := Fin totalHeight +abbrev Encoding := ChainIndex → Digit +abbrev HashInput := List UInt8 + +/-- The `d` Merkle heights, `(h_0, h_1, h_2) = (12, 7, 7)`. Layer `0` carries the public key. -/ +def layerHeight (lay : Layer) : Nat := if lay.val = 0 then maxLayerHeight else 7 + +def topLayer : Layer := ⟨0, by decide⟩ +def middleLayer : Layer := ⟨1, by decide⟩ +def bottomLayer : Layer := ⟨numLayers - 1, by decide⟩ + +/-- `sum_{j < lay} h_j`, the index bits above layer `lay`. -/ +def heightAbove (lay : Layer) : Nat := ∑ j : Layer, if j.val < lay.val then layerHeight j else 0 + +/-- `sum_{j > lay} h_j`, the index bits below layer `lay`. -/ +def heightBelow (lay : Layer) : Nat := totalHeight - heightAbove lay - layerHeight lay + +example : ∑ lay : Layer, layerHeight lay = totalHeight := by decide + +example : (layerHeight topLayer, layerHeight middleLayer, layerHeight bottomLayer) = (12, 7, 7) := by + decide + +example : (heightAbove topLayer, heightAbove middleLayer, heightAbove bottomLayer) = (0, 12, 19) := by + decide + +example : (heightBelow topLayer, heightBelow middleLayer, heightBelow bottomLayer) = (14, 7, 0) := by + decide + +theorem layerHeight_le (lay : Layer) : layerHeight lay ≤ maxLayerHeight := by + unfold layerHeight maxLayerHeight + split <;> omega + +/-- Keep the first 128 output bits, the low bits of the little-endian bit vector. -/ +def truncateHash (output : HashOutput) : Digest := + output.extractLsb' 0 digestBits + +/-- The message digest is `h + k * a = 176` bits, an index and `k` leaf indices. -/ +def messageDigestBits : Nat := totalHeight + ftsTrees * ftsTreeHeight + +abbrev MessageDigest := BitVec messageDigestBits + +/-- The digest is `h + k * a = 176` bits and has to fit in one oracle output. -/ +example : messageDigestBits = 176 ∧ messageDigestBits ≤ hashOutputBits := by decide + +def truncateMessageDigest (output : HashOutput) : MessageDigest := + output.extractLsb' 0 messageDigestBits + +structure PublicKey where + root : Digest + parameter : PublicParameter +deriving DecidableEq + +/-- The key of the specification: the public parameter, the layer-`0` root that every digest binds, and every sampled secret. `Gen` samples them independently and uniformly; the seed derivation of the specification is an implementation of this key, not this key. -/ +structure SecretKey where + parameter : PublicParameter + root : Digest + otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest + ftsSecret : Index → FtsTree → FtsLeaf → Digest + +/-- A signature, with every component the verifier reads and no other: the randomizer, one few-time secret and its `a` path nodes per held tree, and per layer a counter, `v` chain values, and its share of the `h` path nodes. That is `16 + 14 * 16 + 140 * 16 + 3 * 4 + 126 * 16 + 26 * 16 = 4924` bytes. -/ +structure Signature where + randomness : Randomness + ftsSecret : FtsTree → Digest + ftsPath : FtsTree → Fin ftsTreeHeight → Digest + counter : Layer → Counter + chainValue : Layer → ChainIndex → Digest + authPath : PathIndex → Digest +deriving DecidableEq + +/-- Serialize a bit vector into a fixed number of bytes, least significant byte first. -/ +def bytesLE (byteCount : Nat) (value : BitVec (8 * byteCount)) : List UInt8 := + List.ofFn fun index : Fin byteCount => + UInt8.ofBitVec (value.extractLsb' (8 * index.val) 8) + +structure TweakFields where + tag : BitVec 8 + layer : BitVec 8 + tree : BitVec 32 + position : BitVec 32 + index : BitVec 32 +deriving DecidableEq + +/-- The specification's 16 tweak bytes `tag || layer || tree || position || index || 0^2`, each field serialized least significant byte first. -/ +def fieldBytes (fields : TweakFields) : HashInput := + bytesLE 1 fields.tag ++ bytesLE 1 fields.layer ++ bytesLE 4 fields.tree ++ + bytesLE 4 fields.position ++ bytesLE 4 fields.index ++ List.replicate 2 0 + +/-- Every domain-separated hash call the instance makes. Tweak types `0` and `5` of the specification are absent: they belong to the seed derivation, and this key samples its secrets. -/ +inductive HashDomain where + | chain (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex) (step : ChainStep) + | leaf (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) + | node (lay : Layer) (tree : TreeIndex) (level : Nat) (nodeIdx : Nat) + | encoding (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) + | ftsLeaf (index : Index) (tree : FtsTree) (leaf : FtsLeaf) + | ftsNode (index : Index) (tree : FtsTree) (level : Nat) (nodeIdx : Nat) + | ftsRoots (index : Index) + | message +deriving DecidableEq + +/-- Serialize a typed hash domain into the fields of a tweak. Inside the hypertree the layer field is the layer and the tree field the tree; inside a few-time key they are the tree of the forest and the index that selects the instance. -/ +def hashDomainFields : HashDomain → TweakFields + | .chain lay tree leaf chainIdx step => + ⟨1#8, BitVec.ofNat 8 lay.val, BitVec.ofNat 32 tree.val, + BitVec.ofNat 32 (chainLength * chainIdx.val + step.val), BitVec.ofNat 32 leaf.val⟩ + | .leaf lay tree leaf => + ⟨2#8, BitVec.ofNat 8 lay.val, BitVec.ofNat 32 tree.val, 0#32, BitVec.ofNat 32 leaf.val⟩ + | .node lay tree level nodeIdx => + ⟨3#8, BitVec.ofNat 8 lay.val, BitVec.ofNat 32 tree.val, + BitVec.ofNat 32 level, BitVec.ofNat 32 nodeIdx⟩ + | .encoding lay tree leaf => + ⟨4#8, BitVec.ofNat 8 lay.val, BitVec.ofNat 32 tree.val, 0#32, BitVec.ofNat 32 leaf.val⟩ + | .ftsLeaf index tree leaf => + ⟨6#8, BitVec.ofNat 8 tree.val, BitVec.ofNat 32 index.val, 0#32, BitVec.ofNat 32 leaf.val⟩ + | .ftsNode index tree level nodeIdx => + ⟨7#8, BitVec.ofNat 8 tree.val, BitVec.ofNat 32 index.val, + BitVec.ofNat 32 level, BitVec.ofNat 32 nodeIdx⟩ + | .ftsRoots index => ⟨8#8, 0#8, BitVec.ofNat 32 index.val, 0#32, 0#32⟩ + | .message => ⟨9#8, 0#8, 0#32, 0#32, 0#32⟩ + +/-- The exact 16 bytes supplied by the specification as a hash tweak. -/ +def tweakBytes (domain : HashDomain) : HashInput := + fieldBytes (hashDomainFields domain) + +/-- The random-oracle input `tweak || parameter || message` used by every tweakable hash call and by the message digest. -/ +def tweakableHashInput (parameter : PublicParameter) (domain : HashDomain) + (message : HashInput) : HashInput := + tweakBytes domain ++ bytesLE 16 parameter ++ message + +/-! ### The target-sum code + +`v = 42` chunks of `w = 3` bits, 21 in each half of the digest, one pinned bit per half, and the code is the words of digit sum `T = 191`. Two distinct words of equal sum are incomparable, which is what removes the Winternitz checksum and forces the counter. -/ + +namespace TargetSum + +def sum (x : Encoding) : Nat := ∑ i, (x i).val + +def Valid (x : Encoding) : Prop := sum x = targetSum + +instance : DecidablePred Valid := + fun x => inferInstanceAs (Decidable (sum x = targetSum)) + +def digitsPerHalf : Nat := numChains / 2 + +/-- Offset of a three-bit digit, skipping padding bits 63 and 127. -/ +def digitOffset (i : ChainIndex) : Nat := + winternitzBits * i.val + if i.val < digitsPerHalf then 0 else 1 + +def digestEncoding (digest : Digest) : Encoding := + fun i => (digest.extractLsb' (digitOffset i) winternitzBits).toFin + +/-- Decode the concrete little-endian layout: 21 three-bit digits, padding bit 63, 21 digits, and padding bit 127. A digest decodes exactly when both padding bits are clear and the digits reach the target sum. -/ +def decodeDigest (digest : Digest) : Option Encoding := + if digest.getLsbD 63 = false ∧ digest.getLsbD 127 = false ∧ Valid (digestEncoding digest) + then some (digestEncoding digest) else none + +end TargetSum + +/-! ## The algorithms + +Key generation, signing and verification exactly as run in the experiment, together with the oracle hash calls they make. Key generation samples the parameter and every secret, builds layer `0`'s tree; signing rebuilds whatever tree it reads rather than caching anything, as specified, so the honest experiment spends `2^44.5` hash queries of its own and its worst-case path, which is what the query bound counts, `2^58`; verification is the ordinary verifier. + +The `irreducible` attributes only seal definitions against accidental unfolding in proofs. Lean restricts global reducibility attributes to the defining module, so they must appear here. -/ + +/-- A hash query takes an arbitrary byte string and returns 32 bytes. -/ +abbrev HashSpec := HashInput →ₒ HashOutput + +/-- `unifSpec` for uniform sampling, `HashSpec` for the random oracle. A query is `.inl` to sample or `.inr` to hash, so `HasHashQueryBound` counts only the hash side. -/ +abbrev OracleWorld := unifSpec + HashSpec + +namespace Concrete + +def digestBytes (value : Digest) : HashInput := bytesLE 16 value + +def messageBytes (message : Message) : HashInput := bytesLE 32 message + +def randomnessBytes (randomness : Randomness) : HashInput := bytesLE 16 randomness + +def counterBytes (counter : Counter) : HashInput := bytesLE 4 counter + +def oracleHash {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (input : HashInput) : m HashOutput := + HasQuery.query (spec := HashSpec) (m := m) input + +def tweakableHash {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (domain : HashDomain) (payload : HashInput) : m Digest := do + let output ← oracleHash (tweakableHashInput parameter domain payload) + return truncateHash output + +def sequenceFin {m : Type → Type} [Monad m] {α : Type} {n : Nat} + (computation : Fin n → m α) : m (Fin n → α) := + match n with + | 0 => pure Fin.elim0 + | n + 1 => do + let head ← computation 0 + let tail ← sequenceFin fun index : Fin n => computation index.succ + return Fin.cases head tail + +/-- Turn a family of optional results into an optional family: the specification's `Sig` returns nothing as soon as one layer fails. -/ +def traverseOption {α : Type} {n : Nat} (family : Fin n → Option α) : Option (Fin n → α) := + match n with + | 0 => some Fin.elim0 + | n + 1 => + match family 0, traverseOption fun index : Fin n => family index.succ with + | some head, some tail => some (Fin.cases head tail) + | _, _ => none + +/-! ### The index -/ + +/-- `tau_lay = floor(idx / 2^(sum_{j >= lay} h_j))`. -/ +def treeIndexAt (index : Index) (lay : Layer) : TreeIndex := + ⟨index.val / 2 ^ (totalHeight - heightAbove lay), + Nat.lt_of_le_of_lt (Nat.div_le_self _ _) index.isLt⟩ + +/-- `e_lay = floor(idx / 2^(sum_{j > lay} h_j)) mod 2^h_lay`. -/ +def leafIndexAt (index : Index) (lay : Layer) : LeafIndex := + ⟨index.val / 2 ^ heightBelow lay % 2 ^ layerHeight lay, by + have hmod : index.val / 2 ^ heightBelow lay % 2 ^ layerHeight lay < 2 ^ layerHeight lay := + Nat.mod_lt _ (Nat.two_pow_pos _) + have hpow : 2 ^ layerHeight lay ≤ 2 ^ maxLayerHeight := + Nat.pow_le_pow_right (by omega) (layerHeight_le lay) + omega⟩ + +theorem treeIndexAt_val (index : Index) (lay : Layer) : + (treeIndexAt index lay).val = index.val / 2 ^ (totalHeight - heightAbove lay) := rfl + +theorem leafIndexAt_val (index : Index) (lay : Layer) : + (leafIndexAt index lay).val = index.val / 2 ^ heightBelow lay % 2 ^ layerHeight lay := rfl + +/-- Layer `0` holds a single tree, the public key's. -/ +theorem treeIndexAt_topLayer (index : Index) : (treeIndexAt index topLayer).val = 0 := by + have hlt : index.val < 2 ^ 26 := index.isLt + have h0 : totalHeight - heightAbove topLayer = 26 := by decide + simp only [treeIndexAt_val, h0] + omega + +/-- The layers link: the tree used on a layer is the one whose root sits at leaf `e_(lay-1)` of the +tree used on the layer above. -/ +theorem layers_link_top (index : Index) : + (treeIndexAt index middleLayer).val + = (treeIndexAt index topLayer).val * 2 ^ layerHeight topLayer + + (leafIndexAt index topLayer).val := by + have hlt : index.val < 2 ^ 26 := index.isLt + have h0 : totalHeight - heightAbove topLayer = 26 := by decide + have h1 : totalHeight - heightAbove middleLayer = 14 := by decide + have hb : heightBelow topLayer = 14 := by decide + have hh : layerHeight topLayer = 12 := by decide + simp only [treeIndexAt_val, leafIndexAt_val, h0, h1, hb, hh] + omega + +theorem layers_link_middle (index : Index) : + (treeIndexAt index bottomLayer).val + = (treeIndexAt index middleLayer).val * 2 ^ layerHeight middleLayer + + (leafIndexAt index middleLayer).val := by + have h1 : totalHeight - heightAbove middleLayer = 14 := by decide + have h2 : totalHeight - heightAbove bottomLayer = 7 := by decide + have hb : heightBelow middleLayer = 7 := by decide + have hh : layerHeight middleLayer = 7 := by decide + simp only [treeIndexAt_val, leafIndexAt_val, h1, h2, hb, hh] + omega + +/-- The bottom layer's leaves are the `2^h` indices themselves. -/ +theorem leafIndexAt_bottomLayer (index : Index) : + (leafIndexAt index bottomLayer).val = index.val % 2 ^ layerHeight bottomLayer := by + have hb : heightBelow bottomLayer = 0 := by decide + simp [leafIndexAt_val, hb] + +/-! ### The one-time signature -/ + +def leafOfNat (value : Nat) : LeafIndex := + ⟨value % 2 ^ maxLayerHeight, Nat.mod_lt _ (Nat.two_pow_pos _)⟩ + +/-- `Chain_{lay,tau,e,i}(P, start, steps, value)`: the step onto position `start + steps + 1` carries tweak position `2^w * i + start + steps`. -/ +def chainWalk {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) + (chainIdx : ChainIndex) : Nat → Nat → Digest → m Digest + | _, 0, value => pure value + | start, steps + 1, value => do + let previous ← chainWalk parameter lay tree leaf chainIdx start steps value + if hstep : start + steps < chainLength - 1 then + tweakableHash parameter (.chain lay tree leaf chainIdx ⟨start + steps, hstep⟩) + (digestBytes previous) + else + pure 0 + +/-- The verifier's half of a chain: walk the remaining `2^w - 1 - x_i` steps. -/ +def recoverChain {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) + (chainIdx : ChainIndex) (digit : Digit) (value : Digest) : m Digest := + chainWalk parameter lay tree leaf chainIdx digit.val (chainLength - 1 - digit.val) value + +def oneTimePublicKey {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) + (secret : ChainIndex → Digest) : m (ChainIndex → Digest) := + sequenceFin fun chainIdx => + chainWalk parameter lay tree leaf chainIdx 0 (chainLength - 1) (secret chainIdx) + +def leafPayload (endpoints : ChainIndex → Digest) : HashInput := + (List.ofFn endpoints).flatMap digestBytes + +def leafHash {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) + (endpoints : ChainIndex → Digest) : m Digest := + tweakableHash parameter (.leaf lay tree leaf) (leafPayload endpoints) + +/-- `Enc(P, lay, tau, e, M, c)`: hash the message with the counter under the leaf's encoding tweak, and decode. -/ +def encode {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) + (message : Digest) (counter : Counter) : m (Option Encoding) := do + let digest ← tweakableHash parameter (.encoding lay tree leaf) + (digestBytes message ++ counterBytes counter) + return TargetSum.decodeDigest digest + +/-- `OtsSign`: the least admissible counter, and the chain values it dictates. The search starts at `0` and stops after `encodingAttemptLimit` counters. -/ +def otsSignFrom {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) + (secret : ChainIndex → Digest) (message : Digest) : + Nat → Nat → m (Option (Counter × (ChainIndex → Digest))) + | 0, _ => pure none + | attempts + 1, counter => do + match ← encode parameter lay tree leaf message (BitVec.ofNat counterBits counter) with + | some encoding => do + let values ← sequenceFin fun chainIdx => + chainWalk parameter lay tree leaf chainIdx 0 (encoding chainIdx).val (secret chainIdx) + return some (BitVec.ofNat counterBits counter, values) + | none => otsSignFrom parameter lay tree leaf secret message attempts (counter + 1) + +def otsSign {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) + (secret : ChainIndex → Digest) (message : Digest) : + m (Option (Counter × (ChainIndex → Digest))) := + otsSignFrom parameter lay tree leaf secret message encodingAttemptLimit 0 + +/-- `OtsLeaf`: the verifier's leaf, or nothing if the counter does not encode the message. -/ +def otsLeaf {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) + (message : Digest) (counter : Counter) (values : ChainIndex → Digest) : m (Option Digest) := do + match ← encode parameter lay tree leaf message counter with + | none => pure none + | some encoding => do + let endpoints ← sequenceFin fun chainIdx => + recoverChain parameter lay tree leaf chainIdx (encoding chainIdx) (values chainIdx) + let value ← leafHash parameter lay tree leaf endpoints + return some value + +/-! ### A layer -/ + +def nodePayload (left right : Digest) : HashInput := + digestBytes left ++ digestBytes right + +/-- `X^{lay,tau}_{level,nodeIdx}`, the Merkle tree over the layer's one-time leaves. -/ +def treeNode {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) : Nat → Nat → m Digest + | 0, nodeIdx => do + let leaf := leafOfNat nodeIdx + let endpoints ← oneTimePublicKey parameter lay tree leaf (secret leaf) + leafHash parameter lay tree leaf endpoints + | level + 1, nodeIdx => do + let left ← treeNode parameter lay tree secret level (2 * nodeIdx) + let right ← treeNode parameter lay tree secret level (2 * nodeIdx + 1) + tweakableHash parameter (.node lay tree (level + 1) nodeIdx) (nodePayload left right) + +attribute [irreducible] treeNode + +def treeRoot {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) : m Digest := + treeNode parameter lay tree secret (layerHeight lay) 0 + +/-- `TreePath`: `A_level = X^{lay,tau}_{level, floor(e / 2^level) xor 1}` for the layer's own `h_lay` levels, and nothing above them. -/ +def treePath {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) + (secret : LeafIndex → ChainIndex → Digest) (leaf : LeafIndex) : m (Fin maxLayerHeight → Digest) := + sequenceFin fun level => + if level.val < layerHeight lay then + treeNode parameter lay tree secret level (Nat.xor (leaf.val / 2 ^ level.val) 1) + else + pure 0 + +/-- `TreeFold`: fold a leaf and a path into the layer's root. -/ +def treeFold {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) + (path : Nat → Digest) : Nat → Digest → m Digest + | 0, value => pure value + | levels + 1, value => do + let current ← treeFold parameter lay tree leaf path levels value + let sibling := path levels + let nodeIdx := leaf.val / 2 ^ (levels + 1) + if leaf.val.testBit levels then + tweakableHash parameter (.node lay tree (levels + 1) nodeIdx) (nodePayload sibling current) + else + tweakableHash parameter (.node lay tree (levels + 1) nodeIdx) (nodePayload current sibling) + +/-! ### The few-time signature -/ + +def ftsLeafOfNat (value : Nat) : FtsLeaf := + ⟨value % 2 ^ ftsTreeHeight, Nat.mod_lt _ (Nat.two_pow_pos _)⟩ + +/-- The index group of the digest that selects this tree's leaf. -/ +def ftsIndexOf (tree : FtsTree) : DigestTree := + tree.castLE (Nat.sub_le ftsTrees 1) + +/-- The last index group, the one the digest is resampled to zero and the verifier checks. Its tree is the dropped one. -/ +def lastDigestTree : DigestTree := ⟨ftsTrees - 1, by decide⟩ + +def ftsLeafHash {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (index : Index) (tree : FtsTree) (leaf : FtsLeaf) + (secret : Digest) : m Digest := + tweakableHash parameter (.ftsLeaf index tree leaf) (digestBytes secret) + +/-- `Y^{idx,kappa}_{level,nodeIdx}`, one tree of the forest. -/ +def ftsNode {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (index : Index) (tree : FtsTree) + (secret : FtsLeaf → Digest) : Nat → Nat → m Digest + | 0, nodeIdx => do + let leaf := ftsLeafOfNat nodeIdx + ftsLeafHash parameter index tree leaf (secret leaf) + | level + 1, nodeIdx => do + let left ← ftsNode parameter index tree secret level (2 * nodeIdx) + let right ← ftsNode parameter index tree secret level (2 * nodeIdx + 1) + tweakableHash parameter (.ftsNode index tree (level + 1) nodeIdx) (nodePayload left right) + +attribute [irreducible] ftsNode + +def ftsRootsPayload (roots : FtsTree → Digest) : HashInput := + (List.ofFn roots).flatMap digestBytes + +/-- `FtsKey(P, idx)`, the hash of the forest's `k - 1` roots. -/ +def ftsKey {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (index : Index) + (secret : FtsTree → FtsLeaf → Digest) : m Digest := do + let roots ← sequenceFin fun tree => + ftsNode parameter index tree (secret tree) ftsTreeHeight 0 + tweakableHash parameter (.ftsRoots index) (ftsRootsPayload roots) + +/-- `FtsOpen`: the opened secrets and, per tree, the `a` siblings of the opened leaf. -/ +def ftsOpen {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (index : Index) (leaves : DigestTree → FtsLeaf) + (secret : FtsTree → FtsLeaf → Digest) : m (FtsTree → Fin ftsTreeHeight → Digest) := + sequenceFin fun tree => + sequenceFin fun level => + ftsNode parameter index tree (secret tree) level.val + (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level.val) 1) + +/-- The verifier's half of one few-time tree. -/ +def ftsFold {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (index : Index) (tree : FtsTree) (leaf : FtsLeaf) + (path : Fin ftsTreeHeight → Digest) : Nat → Digest → m Digest + | 0, value => pure value + | levels + 1, value => do + let current ← ftsFold parameter index tree leaf path levels value + let sibling := if hlevel : levels < ftsTreeHeight then path ⟨levels, hlevel⟩ else 0 + let nodeIdx := leaf.val / 2 ^ (levels + 1) + if leaf.val.testBit levels then + tweakableHash parameter (.ftsNode index tree (levels + 1) nodeIdx) + (nodePayload sibling current) + else + tweakableHash parameter (.ftsNode index tree (levels + 1) nodeIdx) + (nodePayload current sibling) + +/-- `FtsRec`: recover the few-time public key from the opened secrets and paths. -/ +def ftsRecover {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (index : Index) (leaves : DigestTree → FtsLeaf) + (secrets : FtsTree → Digest) (paths : FtsTree → Fin ftsTreeHeight → Digest) : m Digest := do + let roots ← sequenceFin fun tree => do + let leaf := leaves (ftsIndexOf tree) + let value ← ftsLeafHash parameter index tree leaf (secrets tree) + ftsFold parameter index tree leaf (paths tree) ftsTreeHeight value + tweakableHash parameter (.ftsRoots index) (ftsRootsPayload roots) + +/-! ### The message digest -/ + +def messageDigestPayload (root : Digest) (message : Message) (randomness : Randomness) : HashInput := + randomnessBytes randomness ++ digestBytes root ++ messageBytes message + +/-- `Digest(P, root, m, rho)`, truncated to `h + k * a` bits. -/ +def messageDigest {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (root : Digest) (message : Message) + (randomness : Randomness) : m MessageDigest := do + let output ← oracleHash + (tweakableHashInput parameter .message (messageDigestPayload root message randomness)) + return truncateMessageDigest output + +/-- `idx = N mod 2^h`. -/ +def digestIndex (digest : MessageDigest) : Index := + (digest.extractLsb' 0 totalHeight).toFin + +/-- `u_kappa = floor(N / 2^(h + kappa * a)) mod 2^a`. -/ +def digestLeaves (digest : MessageDigest) : DigestTree → FtsLeaf := + fun tree => (digest.extractLsb' (totalHeight + ftsTreeHeight * tree.val) ftsTreeHeight).toFin + +/-- A digest is admissible exactly when its last index group is zero. -/ +def Admissible (digest : MessageDigest) : Prop := digestLeaves digest lastDigestTree = 0 + +instance (digest : MessageDigest) : Decidable (Admissible digest) := + inferInstanceAs (Decidable (digestLeaves digest lastDigestTree = 0)) + +/-! ### Verification -/ + +/-- Layer `lay`'s share of the signature's authentication path, its `h_lay` nodes starting at offset `sum_{j < lay} h_j`. -/ +def signaturePath (signature : Signature) (lay : Layer) (level : Nat) : Digest := + if hlevel : heightAbove lay + level < totalHeight then + signature.authPath ⟨heightAbove lay + level, hlevel⟩ + else + 0 + +/-- The hypertree walk, from the bottom layer up: `remaining + 1` enters at layer `remaining`, and layer `0`'s fold returns the value compared against the public root. -/ +def verifyLayers {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (parameter : PublicParameter) (index : Index) (signature : Signature) : + Nat → Digest → m (Option Digest) + | 0, message => pure (some message) + | remaining + 1, message => do + if hlayer : remaining < numLayers then + let lay : Layer := ⟨remaining, hlayer⟩ + let tree := treeIndexAt index lay + let leaf := leafIndexAt index lay + match ← otsLeaf parameter lay tree leaf message (signature.counter lay) + (signature.chainValue lay) with + | none => pure none + | some value => do + let root ← treeFold parameter lay tree leaf (signaturePath signature lay) + (layerHeight lay) value + verifyLayers parameter index signature remaining root + else + pure none + +def verify {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (publicKey : PublicKey) (message : Message) (signature : Signature) : m Bool := do + let digest ← messageDigest publicKey.parameter publicKey.root message signature.randomness + if ¬ Admissible digest then + return false + else + let index := digestIndex digest + let ftsPublicKey ← ftsRecover publicKey.parameter index (digestLeaves digest) + signature.ftsSecret signature.ftsPath + match ← verifyLayers publicKey.parameter index signature numLayers ftsPublicKey with + | none => return false + | some root => return decide (root = publicKey.root) + +attribute [irreducible] verify + +/-! ### Key generation -/ + +noncomputable local instance : SampleableType PublicParameter := + SampleableType.ofFintype PublicParameter + +noncomputable opaque otsSecretsSampleableType : + SampleableType (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) := + SampleableType.ofFintype (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + +noncomputable local instance : + SampleableType (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) := + otsSecretsSampleableType + +noncomputable opaque ftsSecretsSampleableType : + SampleableType (Index → FtsTree → FtsLeaf → Digest) := + SampleableType.ofFintype (Index → FtsTree → FtsLeaf → Digest) + +noncomputable local instance : SampleableType (Index → FtsTree → FtsLeaf → Digest) := + ftsSecretsSampleableType + +noncomputable local instance : SampleableType Randomness := + SampleableType.ofFintype Randomness + +noncomputable def sampleParameter : ProbComp PublicParameter := + $ᵗ PublicParameter + +noncomputable def sampleOtsSecrets : + ProbComp (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) := + $ᵗ (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) + +noncomputable def sampleFtsSecrets : ProbComp (Index → FtsTree → FtsLeaf → Digest) := + $ᵗ (Index → FtsTree → FtsLeaf → Digest) + +noncomputable def sampleRandomness : ProbComp Randomness := + $ᵗ Randomness + +attribute [irreducible] sampleParameter sampleOtsSecrets sampleFtsSecrets sampleRandomness + +def rootTree : TreeIndex := ⟨0, Nat.two_pow_pos _⟩ + +/-- `Gen`: sample the parameter and every secret, and build layer `0`'s tree for the root. The trees below it are built when a signature needs them, so nothing else is computed here. -/ +noncomputable def keygen : OracleComp OracleWorld (PublicKey × SecretKey) := do + let parameter ← liftM sampleParameter + let otsSecret ← liftM sampleOtsSecrets + let ftsSecret ← liftM sampleFtsSecrets + let root ← liftM + (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree) : + OracleComp HashSpec Digest) + return (⟨root, parameter⟩, ⟨parameter, root, otsSecret, ftsSecret⟩) + +attribute [irreducible] keygen + +/-! ### Signing -/ + +/-- One digest attempt: one hash, keeping the index and the leaf indices if the digest is admissible. -/ +def signAttempt {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (secretKey : SecretKey) (message : Message) (randomness : Randomness) : + m (Option (Index × (DigestTree → FtsLeaf))) := do + let digest ← messageDigest secretKey.parameter secretKey.root message randomness + if Admissible digest then + return some (digestIndex digest, digestLeaves digest) + else + return none + +/-- The digest loop: at most `digestAttemptLimit` attempts, each sampling a fresh randomizer, stopping at the first admissible digest. It takes `2^a` attempts on average. -/ +noncomputable def signDigestLoop : Nat → SecretKey → Message → + OracleComp OracleWorld (Option (Randomness × Index × (DigestTree → FtsLeaf))) + | 0, _secretKey, _message => pure none + | attempts + 1, secretKey, message => do + let randomness ← liftM sampleRandomness + let attempt ← liftM + (signAttempt secretKey message randomness : + OracleComp HashSpec (Option (Index × (DigestTree → FtsLeaf)))) + match attempt with + | some (index, leaves) => pure (some (randomness, index, leaves)) + | none => signDigestLoop attempts secretKey message + +/-- The message layer `lay` signs: the root of the tree below it, or the few-time public key at the bottom. Every layer's message is fixed by the index alone, which is what makes the layers independent. -/ +def layerMessage {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (secretKey : SecretKey) (index : Index) (lay : Layer) : m Digest := + if hbelow : lay.val + 1 < numLayers then + let below : Layer := ⟨lay.val + 1, hbelow⟩ + treeRoot secretKey.parameter below (treeIndexAt index below) + (secretKey.otsSecret below (treeIndexAt index below)) + else + ftsKey secretKey.parameter index (secretKey.ftsSecret index) + +/-- One layer's contribution: its counter, its chain values, and its authentication path. -/ +def signLayer {m : Type → Type} [Monad m] [HasQuery HashSpec m] + (secretKey : SecretKey) (index : Index) (lay : Layer) : + m (Option (Counter × (ChainIndex → Digest) × (Fin maxLayerHeight → Digest))) := do + let tree := treeIndexAt index lay + let leaf := leafIndexAt index lay + let message ← layerMessage secretKey index lay + match ← otsSign secretKey.parameter lay tree leaf (secretKey.otsSecret lay tree leaf) message with + | none => return none + | some (counter, values) => do + let path ← treePath secretKey.parameter lay tree (secretKey.otsSecret lay tree) leaf + return some (counter, values, path) + +/-- Which layer's path an entry of the `h` belongs to. -/ +def layerOfPath (position : Nat) : Layer := + if position < heightAbove middleLayer then topLayer + else if position < heightAbove bottomLayer then middleLayer + else bottomLayer + +/-- Lay the `d` layers' paths end to end, top layer first, so that every one of the `h` entries is read by verification. -/ +def flattenPaths (paths : Layer → Fin maxLayerHeight → Digest) : PathIndex → Digest := + fun position => + let lay := layerOfPath position.val + let level := position.val - heightAbove lay + if hlevel : level < maxLayerHeight then paths lay ⟨level, hlevel⟩ else 0 + +theorem heightAbove_add_layerHeight_le (lay : Layer) : + heightAbove lay + layerHeight lay ≤ totalHeight := by decide +revert + +/-- An entry at a layer's own offset belongs to that layer. -/ +theorem layerOfPath_eq (lay : Layer) (level : Fin maxLayerHeight) (hlevel : level.val < layerHeight lay) : + layerOfPath (heightAbove lay + level.val) = lay := by + revert hlevel + revert level + revert lay + decide + +theorem flattenPaths_apply (paths : Layer → Fin maxLayerHeight → Digest) (lay : Layer) + (level : Fin maxLayerHeight) (hlevel : level.val < layerHeight lay) (position : PathIndex) + (hposition : position.val = heightAbove lay + level.val) : + flattenPaths paths position = paths lay level := by + simp only [flattenPaths, hposition, layerOfPath_eq lay level hlevel, Nat.add_sub_cancel_left, + dif_pos level.isLt, Fin.eta] + +/-- The verifier reads a layer's path node exactly where the signer laid it, so the `h` entries of the authentication path are the `d` layers' paths and nothing else. -/ +theorem signaturePath_flattenPaths (signature : Signature) + (paths : Layer → Fin maxLayerHeight → Digest) (hpath : signature.authPath = flattenPaths paths) + (lay : Layer) (level : Fin maxLayerHeight) (hlevel : level.val < layerHeight lay) : + signaturePath signature lay level.val = paths lay level := by + have hlt : heightAbove lay + level.val < totalHeight := + lt_of_lt_of_le (by omega) (heightAbove_add_layerHeight_le lay) + rw [signaturePath, dif_pos hlt, hpath] + exact flattenPaths_apply paths lay level hlevel _ rfl + +/-- Every one of the `h` entries is read by some layer: the offsets partition `0..h-1` into the `d` layers, so the path carries no entry verification skips and none twice. This is arithmetic about the offsets, not a statement about `verifyLayers`. -/ +theorem authPath_exhausted (position : PathIndex) : ∃ lay : Layer, ∃ level : Fin maxLayerHeight, + level.val < layerHeight lay ∧ heightAbove lay + level.val = position.val := by + revert position + decide + +/-- `Sig(sk, m)`: the digest loop, the few-time opening, one one-time signature per layer, and the assembled signature. -/ +noncomputable def sign (secretKey : SecretKey) (message : Message) : + OracleComp OracleWorld (Option Signature) := do + match ← signDigestLoop digestAttemptLimit secretKey message with + | none => return none + | some (randomness, index, leaves) => do + let ftsPath ← liftM + (ftsOpen secretKey.parameter index leaves (secretKey.ftsSecret index) : + OracleComp HashSpec (FtsTree → Fin ftsTreeHeight → Digest)) + let layers ← liftM + (sequenceFin (fun lay => signLayer secretKey index lay) : + OracleComp HashSpec + (Layer → Option (Counter × (ChainIndex → Digest) × (Fin maxLayerHeight → Digest)))) + match traverseOption layers with + | none => return none + | some parts => + return some + { randomness := randomness + ftsSecret := fun tree => secretKey.ftsSecret index tree (leaves (ftsIndexOf tree)) + ftsPath := ftsPath + counter := fun lay => (parts lay).1 + chainValue := fun lay => (parts lay).2.1 + authPath := flattenPaths fun lay => (parts lay).2.2 } + +attribute [irreducible] sign + +end Concrete + +/-! ## The security experiment -/ + +/-- The random-oracle semantics: hash queries are answered lazily and consistently by uniform sampling and cached; uniform-sampling queries are forwarded unchanged. -/ +noncomputable def romImpl : QueryImpl OracleWorld (StateT (QueryCache HashSpec) ProbComp) := + unifFwdImpl HashSpec + + (randomOracle : QueryImpl HashSpec (StateT (QueryCache HashSpec) ProbComp)) + +/-- A signing request is a message alone: the scheme is stateless, and the signer chooses the index by hashing. -/ +abbrev SignRequest := Message + +/-- A claimed forgery: a message and a signature. -/ +structure Forgery where + message : Message + signature : Signature +deriving DecidableEq + +/-- The interface of a stateless signature scheme in the random-oracle experiment. Signing is randomized and may fail, so it returns an option. -/ +structure Scheme where + keygen : OracleComp OracleWorld (PublicKey × SecretKey) + sign : SecretKey → Message → OracleComp OracleWorld (Option Signature) + verify : PublicKey → Message → Signature → OracleComp OracleWorld Bool + +/-- The signing oracle answers a request with either a signature or `none` if the signer fails. -/ +abbrev SigningSpec := SignRequest →ₒ Option Signature + +/-- A classical adaptive adversary. After receiving the public key, it may query the shared random oracle, request signatures, and finally return a claimed forgery. -/ +structure Adversary where + main : PublicKey → OracleComp (OracleWorld + SigningSpec) Forgery + +namespace SigningTranscript + +/-- A signing transcript is valid exactly when the key signed at most `q_s` messages. Nothing forbids repeating a message: the signer is stateless, and a fresh randomizer makes the second signature a different one. -/ +def Valid (log : QueryLog SigningSpec) : Prop := log.length ≤ signatureLimit + +instance (log : QueryLog SigningSpec) : Decidable (Valid log) := + inferInstanceAs (Decidable (log.length ≤ signatureLimit)) + +/-- The signer returned the claimed forgery exactly when the transcript contains the same message answered by the same signature. A different signature for a signed message is therefore a valid strong forgery. -/ +def Contains (log : QueryLog SigningSpec) (forgery : Forgery) : Prop := + ∃ entry ∈ log, entry.1 = forgery.message ∧ entry.2 = some forgery.signature + +instance (log : QueryLog SigningSpec) (forgery : Forgery) : Decidable (Contains log forgery) := + inferInstanceAs + (Decidable (∃ entry ∈ log, entry.1 = forgery.message ∧ entry.2 = some forgery.signature)) + +end SigningTranscript + +/-- The signing oracle used in the game. It records every request and response while forwarding the request to the scheme's signer. -/ +def signingOracle (scheme : Scheme) (sk : SecretKey) : + QueryImpl SigningSpec (WriterT (QueryLog SigningSpec) (OracleComp OracleWorld)) := + QueryImpl.withLogging fun request => scheme.sign sk request + +/-- Forward the shared random oracle and uniform sampling to the adversary unchanged, alongside the logged signing oracle. -/ +def forwardOracles : + QueryImpl OracleWorld (WriterT (QueryLog SigningSpec) (OracleComp OracleWorld)) := + fun input => liftM (OracleWorld.query input) + +/-- The complete strong-unforgeability experiment. + +The random oracle is sampled lazily by the semantics of `OracleWorld`. Key generation, the adversary, the signing oracle, and final verification all share the same oracle. The game returns `true` precisely when the transcript holds at most `q_s` signatures, the claimed forgery is not one the signer returned for that message, and the signature verifies. -/ +noncomputable def gameCore (scheme : Scheme) (adversary : Adversary) : + OracleComp OracleWorld Bool := do + let (pk, sk) ← scheme.keygen + let ((forgery, log) : Forgery × QueryLog SigningSpec) ← + (simulateQ (forwardOracles + signingOracle scheme sk) (adversary.main pk)).run + let verified ← scheme.verify pk forgery.message forgery.signature + return decide (SigningTranscript.Valid log ∧ ¬SigningTranscript.Contains log forgery) && verified + +/-- The probability that the adversary wins, over key generation, signer randomness, and the random oracle, which starts from the empty cache. The final cache is discarded. -/ +noncomputable def forgeAdvantage (scheme : Scheme) (adversary : Adversary) : ℝ≥0∞ := + Pr[= true | (simulateQ romImpl (gameCore scheme adversary)).run' ∅] + +/-- The whole experiment makes at most `q` random-oracle queries on every execution path. The count includes queries during key generation, adversarial hashing, signing, and final verification. Uniform sampling operations are not hash queries. -/ +def HasHashQueryBound (scheme : Scheme) (adversary : Adversary) (q : Nat) : Prop := + (gameCore scheme adversary).IsQueryBoundP (· matches .inr _) q + +/-- Having `bits` bits of classical security means that every classical adaptive adversary whose complete experiment stays within a nonzero hash-query budget `q` forges with probability at most `q / 2^bits`. The bound is a slope, so it bounds what a query buys and not what the first one does; a budget below what the honest experiment alone spends admits no adversary and the bound is vacuous there. -/ +def HasClassicalSecurityBits (scheme : Scheme) (bits : Nat) : Prop := + ∀ q, 1 ≤ q → ∀ adversary, HasHashQueryBound scheme adversary q → + forgeAdvantage scheme adversary ≤ q / ((2 ^ bits : Nat) : ℝ≥0∞) + +/-- The concrete SPHINCS scheme: key generation, the stateless randomized signer, and the verifier defined above. -/ +noncomputable def Concrete.scheme : Scheme where + keygen := Concrete.keygen + sign := Concrete.sign + verify := fun publicKey message signature => + liftM (Concrete.verify publicKey message signature : OracleComp HashSpec Bool) + +/-- The complete public security claim: `120` bits of classical strong unforgeability in the random-oracle model, at `2^24` signatures per key pair. -/ +abbrev SphincsSecurityStatement : Prop := + HasClassicalSecurityBits Concrete.scheme securityBits + +/-- The strengthened claim for the same scheme and SUF game: `125` classical random-oracle security bits, at `2^24` signing requests per key pair. -/ +abbrev SphincsSecurity125Statement : Prop := + HasClassicalSecurityBits Concrete.scheme 125 + +/-- The strengthened claim for the same scheme and SUF game: `126` classical random-oracle security bits, at `2^24` signing requests per key pair. -/ +abbrev SphincsSecurity126Statement : Prop := + HasClassicalSecurityBits Concrete.scheme 126 + +end SphincsSecurity diff --git a/formal/sphincs/lake-manifest.json b/formal/sphincs/lake-manifest.json new file mode 100644 index 00000000..19314c3c --- /dev/null +++ b/formal/sphincs/lake-manifest.json @@ -0,0 +1,126 @@ +{"version": "1.2.0", + "packagesDir": ".lake/packages", + "packages": + [{"url": "https://github.com/Verified-zkEVM/VCVio.git", + "type": "git", + "subDir": null, + "scope": "", + "rev": "cbd4144b51d92da00dd50f05e068b2348fa6e529", + "name": "VCVio", + "manifestFile": "lake-manifest.json", + "inputRev": "cbd4144", + "inherited": false, + "configFile": "lakefile.lean"}, + {"url": "https://github.com/Verified-zkEVM/PolyFun.git", + "type": "git", + "subDir": null, + "scope": "", + "rev": "04a12b67fa2048c9412fdd26ed9e446f25919d37", + "name": "PolyFun", + "manifestFile": "lake-manifest.json", + "inputRev": "04a12b67fa2048c9412fdd26ed9e446f25919d37", + "inherited": true, + "configFile": "lakefile.toml"}, + {"url": "https://github.com/leanprover-community/mathlib4", + "type": "git", + "subDir": null, + "scope": "leanprover-community", + "rev": "fabf563a7c95a166b8d7b6efca11c8b4dc9d911f", + "name": "mathlib", + "manifestFile": "lake-manifest.json", + "inputRev": "v4.31.0", + "inherited": true, + "configFile": "lakefile.lean"}, + {"url": "https://github.com/quangvdao/loom2", + "type": "git", + "subDir": null, + "scope": "", + "rev": "0e11dcf85dd5fbb362bf6a6cafaba5c476ed9333", + "name": "loom2", + "manifestFile": "lake-manifest.json", + "inputRev": "lean-4.31", + "inherited": true, + "configFile": "lakefile.toml"}, + {"url": "https://github.com/leanprover-community/plausible", + "type": "git", + "subDir": null, + "scope": "leanprover-community", + "rev": "63045536fe95024e6c18fc7b48e03f506701c5bc", + "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": "c5d5b8fe6e5158def25cd28eb94e4141ad97c843", + "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": "5c7542ed018c78194f1e2b903eaf6a792b74c03d", + "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": "24b0d9dc081c5423f8eec7e866c441e5184f29d9", + "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": "e3cb2f741431ce31bf73549fb52316a57368b06f", + "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": "f46324995fca5f0483b742e4eb4daec7f4ee50d2", + "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": "fa08db58b30eb033edcdab331bba000827f9f785", + "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": "92564e5770e4d09f2d86dfbf8ada1e9c715b384c", + "name": "Cli", + "manifestFile": "lake-manifest.json", + "inputRev": "v4.31.0", + "inherited": true, + "configFile": "lakefile.toml"}], + "name": "«xmss-security»", + "lakeDir": ".lake", + "fixedToolchain": false} diff --git a/formal/sphincs/lakefile.toml b/formal/sphincs/lakefile.toml new file mode 100644 index 00000000..982fa1d2 --- /dev/null +++ b/formal/sphincs/lakefile.toml @@ -0,0 +1,11 @@ +name = "sphincs-security" +version = "0.1.0" +defaultTargets = ["SphincsSecurity"] + +[[require]] +name = "VCVio" +git = "https://github.com/Verified-zkEVM/VCVio.git" +rev = "cbd4144" + +[[lean_lib]] +name = "SphincsSecurity" diff --git a/formal/sphincs/lean-toolchain b/formal/sphincs/lean-toolchain new file mode 100644 index 00000000..18640c8b --- /dev/null +++ b/formal/sphincs/lean-toolchain @@ -0,0 +1 @@ +leanprover/lean4:v4.31.0